Require Import LanguageUtil.
Require Import BasicProperties.
Require Import Properties.
Require Import Transitivity.
Require Import Extraction.
Require Import KindProperties.
Require Import BoxReasoning.
Require Import OccurenceReasoning.

Require Import Program.Tactics.

Definition Progressive (e : expr) : Prop := value e \/ exists e', e ⟶ e'.
Definition EProgressive (e : eexpr) := evalue e \/ exists e', e ⋆⟶ e'.

Hint Unfold Progressive : core.
Hint Unfold EProgressive : core.

Hint Rewrite extract_open_distr : reassoc.

Ltac find_impossible_reduction :=
  simpl in *;
  match goal with
  | _ : ee_app _ _ ⋆⟶ _ |- _ => fail
  | _ : e_app  _ _ ⟶  _ |- _ => fail
  | _ : e_app _ _ ⟹ _ |- _ => fail
  | H : _ ⋆⟶ _ |- _ => solve [inversion H]
  | H : _ ⟶  _ |- _ => solve [inversion H]
  | H : _ ⟹ _ |- _ => solve [inversion H]
  end
.

Ltac solve_impossible_reduction := try find_impossible_reduction.

Lemma deterministic_reduction : forall e e1 e2,
    e ⟹ e1 -> e ⟹ e2 -> e1 = e2.
Proof.
  intros. generalize dependent e2.
  induction H; intros.
  - inversion H1; subst; solve_impossible_reduction.
    rewrite (IHdreduce e6); auto.
  - inversion H2; subst; solve_impossible_reduction.
    auto.
  - inversion H1; subst; auto.
Qed.

Ltac conclude_refls H :=
  match type of H with
  | ?G ⊢ ?e1 <: ?e2 : ?A =>
    let H1 := fresh "H" in
    let H2 := fresh "H" in
    assert (H1 : G ⊢ e1 : A) by eauto;
    assert (H2 : G ⊢ e2 : A) by eauto;
    conclude_type_refl H
  end
.

Lemma castdn_not_of_star : forall Γ e,
    Γ ⊢ e_castdn e : * -> False.
Proof.
  intros.
  dependent induction H.
  - assert (e_kind k = BOX) by (eapply star_type_inversion; eauto).
    inversion H2; subst.
    conclude_type_refl H1.
    + inversion H0.
    + eauto using expr_of_box_never_be_reduced'.
  - apply star_sub_inversion_l in H0. subst.
    eapply IHusub1; eauto.
Qed.

Lemma castup_not_of_star : forall Γ A e,
    Γ ⊢ e_castup A e : * -> False.
Proof.
  intros.
  dependent induction H.
  - inversion H0.
  - apply star_sub_inversion_l in H0. subst.
    eapply IHusub1; eauto.
Qed.

Lemma abs_le : forall Γ A b e T,
    Γ ⊢ e_abs A b <: e : T ->
    exists c, e = e_abs A c.
Proof.
  intros.
  dependent induction H.
  - eauto.
  - now apply abs_not_of_star in H0.
  - now eapply IHusub1.
Qed.

Lemma abs_ge : forall Γ A b e T,
    Γ ⊢ e <: e_abs A b : T ->
    exists c, e = e_abs A c.
Proof.
  intros.
  dependent induction H.
  - eauto.
  - apply reflexivity_r in H2.
    now apply abs_not_of_star in H2.
  - now eapply IHusub1.
Qed.

Lemma bind_le : forall Γ A b e T,
    Γ ⊢ e_bind A b <: e : T ->
    exists c, e = e_bind A c.
Proof.
  intros.
  dependent induction H.
  - eauto.
  - now apply bind_not_of_star in H0.
  - now eapply IHusub1.
Qed.

Lemma bind_ge : forall Γ A b e T,
    Γ ⊢ e <: e_bind A b : T ->
    exists c, e = e_bind A c.
Proof.
  intros. dependent induction H.
  - eauto.
  - apply reflexivity_r in H2. now apply bind_not_of_star in H2.
  - now eapply IHusub1.
Qed.

Lemma castup_le : forall Γ A b e T,
    Γ ⊢ e_castup A b <: e : T ->
    exists c, e = e_castup A c.
Proof.
  intros. dependent induction H.
  - eauto.
  - now apply castup_not_of_star in H0.
  - now eapply IHusub1.
Qed.

Lemma castup_ge : forall Γ A b e T,
    Γ ⊢ e <: e_castup A b : T ->
    exists c, e = e_castup A c.
Proof.
  intros. dependent induction H.
  - eauto.
  - apply reflexivity_r in H2. now apply castup_not_of_star in H2.
  - now eapply IHusub1.
Qed.

Lemma castdn_le : forall Γ a e T,
    Γ ⊢ e_castdn a <: e : T ->
    exists b, e = e_castdn b.
Proof.
  intros. dependent induction H.
  - eauto.
  - now apply castdn_not_of_star in H0.
  - now eapply IHusub1.
Qed.

Lemma castdn_ge : forall Γ a e T,
    Γ ⊢ e <: e_castdn a: T ->
    exists b, e = e_castdn b.
Proof.
  intros. dependent induction H.
  - eauto.
  - apply reflexivity_r in H2. now apply castdn_not_of_star in H2.
  - now eapply IHusub1.
Qed.

Ltac invert_sub_hyp :=
  let b := fresh "b" in
  let E := fresh "E" in
  let H' := fresh "H" in
  match goal with
  | _ : _ ⊢ e_abs    ?A _ <: e_abs    ?A _ : _ |- _ => idtac
  | _ : _ ⊢ e_bind   ?A _ <: e_bind   ?A _ : _ |- _ => idtac
  | _ : _ ⊢ e_castdn    _ <: e_castdn    _ : _ |- _ => idtac
  | _ : _ ⊢ e_castup ?A _ <: e_castup ?A _ : _ |- _ => idtac
  | H : _ ⊢ e_abs _ _ <: _ : _ |- _ =>
    pose (H' := H); apply abs_le in H' as (b & E)
  | H : _ ⊢ _ <: e_abs _ _ : _ |- _ =>
    pose (H' := H); apply abs_ge in H' as (b & E)
  | H : _ ⊢ e_bind _ _ <: _ : _ |- _ =>
    pose (H' := H); apply bind_le in H' as (b & E)
  | H : _ ⊢ _ <: e_bind _ _ : _ |- _ =>
    pose (H' := H); apply bind_ge in H' as (b & E)
  | H : _ ⊢ e_castup _ _ <: _ : _ |- _ =>
    pose (H' := H); apply castup_le in H' as (b & E)
  | H : _ ⊢ _ <: e_castup _ _ : _ |- _ =>
    pose (H' := H); apply castup_ge in H' as (b & E)
  | H : _ ⊢ e_castdn _ _ <: _ : _ |- _ =>
    pose (H' := H); apply castdn_le in H' as (b & E)
  | H : _ ⊢ _ <: e_castdn _ _ : _ |- _ =>
    pose (H' := H); apply castdn_ge in H' as (b & E)
  end; inversion E; subst; simpl in *
.

Lemma abs_pi_principal : forall Γ A b1 b2 T,
    Γ ⊢ e_abs A b1 <: e_abs A b2 : T ->
    exists B k, Γ ⊢ e_abs A b1 <: e_abs A b2 : e_pi A B /\ Γ ⊢ e_pi A B <: T : e_kind k.
Proof.
  intros.
  dependent induction H.
  - assert (Sub : G ⊢ e_abs A b1 <: e_abs A b2 : e_pi A B) by eauto.
    conclude_type_refl Sub. eauto.
  - edestruct IHusub1 as (B' & k' & Sub & Subpi); eauto.
    exists B', k'. split.
    + assumption.
    + eapply transitivity; eauto.
Qed.

Lemma pi_sub_inversion : forall Γ A B C D k,
    Γ ⊢ e_pi A B <: e_pi C D : e_kind k ->
    exists k' L,
      Γ ⊢ C <: A : e_kind k' /\
      forall x, x `notin` L -> Γ, x : C ⊢ B ^` x <: D ^` x : e_kind k.
Proof.
  intros.
  dependent induction H.
  - exists k1, L. auto.
  - apply IHusub1; auto.
    apply kind_sub_inversion_l in H0. destruct_pairs. congruence.
Qed.

Lemma abs_inversion : forall Γ A b1 b2 T,
    Γ ⊢ e_abs A b1 <: e_abs A b2 : T ->
    forall B k,
    Γ ⊢ T <: e_pi A B : e_kind k ->
    exists L, forall x, x `notin` L -> Γ, x : A ⊢ b1 ^` x <: b2 ^` x : B ^` x.
Proof.
  intros * Sub.
  dependent induction Sub; intros.
  - apply pi_sub_inversion in H3 as (k' & L' & H').
    exists (L `union` L'). intros.
    destruct_pairs. instantiate_cofinites. eauto.
  - apply IHSub1 with k; eauto using transitivity.
Qed.

Lemma abs_principal_inversion : forall Γ A b1 b2 B,
    Γ ⊢ e_abs A b1 <: e_abs A b2 : e_pi A B ->
    exists L, forall x, x `notin` L -> Γ, x : A ⊢ b1 ^` x <: b2 ^` x : B ^` x.
Proof.
  intros.
  conclude_type_refl H.
  now apply abs_inversion with (e_pi A B) k.
Qed.

Lemma castup_inversion : forall Γ e1 e2 A B,
    Γ ⊢ e_castup A e1 <: e_castup A e2 : B ->
    exists C k, Γ ⊢ e1 <: e2 : C /\ A ⟶ C /\ Γ ⊢ A <: B : e_kind k.
Proof.
  intros. dependent induction H.
  - eauto.
  - edestruct IHusub1 as (C & k1 & Sub1 & R & Sub2); eauto.
    exists C, k1; eauto using transitivity.
Qed.

Ltac rewrite_open_with_subst_impl G :=
  match G with
  | context [?e ^^ ?v] =>
    progress
      match v with
      | e_var_f _ => idtac
      | _ => erewrite (open_subst_eq e); eauto 3
      end
  end
.

Ltac rewrite_open_with_subst :=
  repeat
    match goal with
    | |- ?g => rewrite_open_with_subst_impl g
    end
.

Lemma type_preservation' : forall Γ e1 e2 A,
    Γ ⊢ e1 <: e2 : A -> forall k n e1' e2', head_kind A k n -> e1 ⟹ e1' -> e2 ⟹ e2' -> Γ ⊢ e1' <: e2' : A.
Proof.
  intros * Sub.
  induction Sub; intros k' n' e1' e2' K R1 R2;
    try solve [inversion K | inversion R1 | inversion R2].
  - inversion R1; inversion R2; subst.
    + box_reasoning.
      * destruct k'; box_reasoning.
      * conclude_type_refl Sub2.
        apply s_app with A; auto.
        eapply IHSub2; eauto.
    + invert_sub_hyp. solve_impossible_reduction.
    + invert_sub_hyp. solve_impossible_reduction.
    + invert_sub_hyp.
      box_reasoning.
      * destruct k'; box_reasoning.
      * apply abs_pi_principal in Sub2 as (B' & k2 & Sub2 & Sub3).
        apply pi_sub_inversion in Sub3 as (k3 & L2 & Sub3 & Sub4).
        apply abs_principal_inversion in Sub2 as (L3 & Sub2).
        pick fresh x for (L3 `union` L2 `union` fv_expr b `union` fv_expr e0 `union` fv_expr B).
        instantiate_cofinites.
        rewrite (open_subst_eq b x t), (open_subst_eq e0 x t), (open_subst_eq B x t); auto.
        eauto 4 using substitution_cons, context_narrowing_cons.
  - inversion R1; inversion R2; subst.
    assert (G ⊢ e_mu t s : t) by eauto.
    instantiate_cofinites. conclude_freshes. rewrite_open_with_subst.
    pose (t' := t); assert (t' = t) as E by auto.
    replace (e_mu t s) with (e_mu t' s) by auto.
    replace t with ([(e_mu t s) / x] t). rewrite E.
    eapply substitution_cons; eauto.
    now apply fresh_subst_eq.

  - assert (head_kind A k' n') by (eapply head_kind_sub_l; eauto).
    eauto.
Qed.

Corollary type_preservation : forall Γ e1 e2 e1' e2' k,
    Γ ⊢ e1 <: e2 : e_kind k -> e1 ⟹ e1' -> e2 ⟹ e2' -> Γ ⊢ e1' <: e2' : e_kind k.
Proof.
  intros.
  eapply type_preservation'; eauto.
  Unshelve. exact 0.
Qed.

Hint Extern 1 (lc_expr _) => instantiate_cofinites : inst.

Ltac cleanup_hyps := instantiate_trivial_equals; destruct_pairs; clear_dups.
Ltac solve_progress_value := auto || left; eauto with inst.

Lemma pi_ge_inversion : forall Γ e A B k,
    Γ ⊢ e <: e_pi A B : k -> (exists A' B', e = e_pi A' B') \/ (exists C' D', e = e_all C' D').
Proof.
  intros.
  dependent induction H.
  - eauto.
  - eauto.
  - now apply IHusub1 with A B.
Qed.

Lemma normal_form_forall_pi : forall Γ e A,
    Γ ⊢ e : A -> value e ->
    forall C D, A = e_all C D \/ A = e_pi C D ->
    forall E F k, Γ ⊢ A <: e_pi E F : k ->
    (exists A' b, e = e_abs A' b) \/ (exists A' b, e = e_bind A' b).
Proof.
  intros * H V.
  dependent induction H.
    all: try solve [inversion V]. (* solving cases where `e` is not value *)
    all: intros C' D' [E | E]; inversion E; (* solving invalid cases *)
      subst; intros; solve_impossible_reduction; eauto. (* solving trivial base cases *)
  - assert (G ⊢ A <: e_pi E F : (e_kind k)).
    now apply transitivity with (e_all C' D') k0.
    apply pi_ge_inversion in H3. destruct H3; destruct_exists; subst.
    eapply IHusub1; eauto.
    eapply IHusub1; auto.
    apply transitivity with (e_all C' D') k0; eauto.
  - assert (G ⊢ A <: e_pi E F : (e_kind k)).
    now apply transitivity with (e_pi C' D') k0.
    apply pi_ge_inversion in H3. destruct H3; destruct_exists; subst.
    eapply IHusub1; eauto.
    eapply IHusub1; auto.
    apply transitivity with (e_pi C' D') k0; eauto.
Qed.

Lemma normal_form_pi : forall Γ e A B,
    Γ ⊢ e : e_pi A B -> value e ->
    (exists A' b, e = e_abs A' b) \/ (exists A' b, e = e_bind A' b).
Proof.
  intros. conclude_type_refl H.
  eapply normal_form_forall_pi; eauto.
Qed.

Ltac invert_to_normal_forms H :=
  match type of H with
  | _ ⊢ _ <: _ : e_pi ?A ?B => apply normal_form_pi in H; eauto; destruct H
  end; destruct_exists; subst
.

Ltac invert_operator_to_nf :=
  match goal with
  | H : _ ⊢ ?e : e_pi _ _ |- ?g =>
    match g with
    | context [e] => invert_to_normal_forms H
    | _ => fail
    end
  end
.

Ltac destruct_progressive_for_app :=
  let destruct_with_new_name H := (
      let V := fresh "V" in
      let e' := fresh "e'" in
      destruct H as [V | [e' H]])
  in
  match goal with
  | H : Progressive ?e |- exists e', e_app ?e _ ⟶ e' =>
    destruct_with_new_name H
  | H : EProgressive ?e |- exists e', ee_app ?e _ ⋆⟶ e' =>
    destruct_with_new_name H
  end
.

Definition is_castup (e : expr) : Prop :=
  match e with
  | e_castup _ _ => True
  | _ => False
  end
.

Lemma is_castup_dec : forall e,
    is_castup e \/ not (is_castup e).
Proof.
  destruct e; simpl; eauto.
Qed.

Lemma is_castup_eq : forall e,
    is_castup e -> exists A b, e = e_castup A b.
Proof.
  intros. destruct e; solve [inversion H | eauto].
Qed.

Definition is_bind (e : expr) : Prop :=
  match e with
  | e_bind _ _ => True
  | _ => False
  end
.

Lemma is_bind_dec : forall e,
    is_bind e \/ not (is_bind e).
Proof.
  destruct e; simpl; auto.
Qed.

Lemma is_bind_eq : forall e,
    is_bind e -> exists A b, e = e_bind A b.
Proof.
  intros. destruct e; solve [inversion H | eauto].
Qed.

Lemma num_type_inversion : forall Γ n A,
    Γ ⊢ e_num n : A -> Γ ⊢ e_int <: A : *.
Proof.
  intros.
  dependent induction H; eauto 3 using transitivity.
Qed.

Lemma int_le_inversion : forall Γ A B,
    Γ ⊢ e_int <: A : B -> A = e_int \/ exists B c, A = e_all B c.
Proof.
  intros. dependent induction H; eauto.
Qed.

Lemma pi_le_inversion : forall Γ A B C k,
    Γ ⊢ e_pi A B <: C : k -> (exists D E, C = e_pi D E) \/ (exists D E, C = e_all D E).
Proof.
  intros.
  dependent induction H; eauto.
Qed.

Lemma kind_le_inversion : forall Γ kl ek k,
    Γ ⊢ e_kind kl <: ek : k -> ek = * /\ kl = k_star /\ k = BOX.
Proof.
  intros.
  dependent induction H.
  - auto.
  - edestruct IHusub2; eauto. destruct H4. discriminate.
  - edestruct IHusub1 as (E1 & E2 & E3); auto; subst.
    apply reflexivity_l in H0. now apply box_never_welltype in H0.
Qed.

Lemma pi_of_kind : forall Γ A B C D E,
    Γ ⊢ e_pi A B <: e_pi C D : E -> exists k, E = e_kind k.
Proof.
  intros.
  dependent induction H; eauto.
  - edestruct IHusub1; eauto. subst.
    apply kind_le_inversion in H0.
    destruct_conjs; subst; eauto.
Qed.

Lemma forall_of_star : forall Γ A B C D E,
    Γ ⊢ e_all A B <: e_all C D : E -> E = *.
Proof.
  intros.
  dependent induction H; eauto.
  - erewrite IHusub1 in H0; eauto.
    apply kind_le_inversion in H0. now destruct_conjs.
Qed.

Lemma reducible_type : forall Γ e A B,
    Γ ⊢ e : A -> A ⟶ B -> not (is_castup e) -> not (is_bind e) -> value e -> False.
Proof.
  intros * Sub R H1 H2 V.
  inversion V; subst.
  - apply kind_sub_inversion_l in Sub.
    destruct_conjs. subst. inversion R.
  - apply num_type_inversion, int_le_inversion in Sub.
    destruct Sub; destruct_conjs; subst; inversion R.
  - apply int_of_star in Sub. subst. inversion R.
  - apply abs_pi_principal in Sub as (C & k & _ & Sub).
    apply pi_le_inversion in Sub as [|]; destruct_conjs; subst; inversion R.
  - contradict H2. simpl. auto.
  - apply pi_of_kind in Sub as (k & E); subst.
    inversion R.
  - apply forall_of_star in Sub. subst. inversion R.
  - contradict H1. simpl. auto.
Qed.

Theorem generalized_progress : forall e1 e2 A,
    nil ⊢ e1 <: e2 : A -> Progressive e1 /\ Progressive e2.
Proof.
  intros.
  dependent induction H; cleanup_hyps;
    try solve [split; solve_progress_value].
  (* var is not value *)
  - inversion H0.
  (* app *)
  - conclude_refls H1. split; right;
    destruct_progressive_for_app;
    eauto 3; (* solves r_app cases *)
    invert_operator_to_nf.
    + inversion V; subst. exists (H5 ^^ t). eauto.
    + inversion V. inversion H11. subst.
        pick fresh x. instantiate_cofinites.
        exists (e_app (H5 ^` x) t). eauto.
    + inversion V; subst. exists (H6 ^^ t). eauto.
    + inversion V; inversion H11. subst.
        pick fresh x. instantiate_cofinites.
        exists (e_app (H6 ^` x) t). eauto.
  - split; right; eauto.
  - split.
    + destruct H2.
      * destruct (is_castup_dec e1), (is_bind_dec e1).
        -- apply is_castup_eq in H5; destruct_conjs; subst; eauto.
        -- apply is_castup_eq in H5; destruct_conjs; subst; eauto.
        -- apply is_bind_eq in H6; destruct_conjs; subst;
           eauto. Unshelve. exact 0.
        -- apply reflexivity_l in H1.
           eapply reducible_type in H1; [easy | eauto..].
      * destruct H2. eauto.
    + destruct H3.
      * destruct (is_castup_dec e2), (is_bind_dec e2).
        -- apply is_castup_eq in H5; destruct_conjs; subst; eauto.
        -- apply is_castup_eq in H5; destruct_conjs; subst; eauto.
        -- apply is_bind_eq in H6; destruct_conjs; subst; eauto.
           Unshelve. exact 0.
        -- apply reflexivity_r in H1.
           eapply reducible_type in H1; [easy | eauto..].
      * destruct H3. eauto.
Qed.

Corollary progress : forall e A,
    nil ⊢ e : A -> Progressive e.
Proof.
  intros. apply generalized_progress in H.
  now destruct H.
Qed.

Ltac solve_progress_evalue := auto || left; solve_evalue.

Lemma extract_abs : forall A b,
    ee_abs (extract b) = extract (e_abs A b).
Proof.
  easy.
Qed.

Theorem generalized_erased_progress : forall e1 e2 A,
    nil ⊢ e1 <: e2 : A -> forall e1' e2', extract e1 = e1' -> extract e2 = e2' ->
    EProgressive e1' /\ EProgressive e2'.
Proof.
  intros * H.
  dependent induction H; simpl; intros e1' e2' E1 E2; subst; auto;
    try solve [split; solve_progress_evalue].
  (* var is not value *)
  - inversion H0.
  (* app *)
  - instantiate_trivial_equals.
    destruct IHusub2 with (extract e1) (extract e2); auto.
    conclude_refls H1;
    split; right; destruct_progressive_for_app; eauto; (* solve r_app cases *)
      apply evalue_value in V; auto;
        invert_operator_to_nf; simpl.
    + exists ((extract H4) ⋆^^ (extract t)). constructor.
      replace (ee_abs (extract H4)) with (extract (e_abs H2 H4)) by reflexivity.
      all: eauto using lc_extract_lc.
    + pick fresh x. exists (ee_app (extract H4 ⋆^` x) (extract t)).
      eapply er_elim; eauto 3.
      replace (ee_bind (extract H4)) with (extract (e_bind H2 H4)) by reflexivity.
      eauto using lc_extract_lc.
    + exists ((extract H5) ⋆^^ (extract t)). constructor.
      replace (ee_abs (extract H5)) with (extract (e_abs H3 H5)) by reflexivity.
      all: eauto using lc_extract_lc.
    + pick fresh x. exists (ee_app (extract H5 ⋆^` x) (extract t)).
      eapply er_elim; eauto 3.
      replace (ee_bind (extract H5)) with (extract (e_bind H3 H5)) by reflexivity.
      eauto using lc_extract_lc.
  - split; right; exists ((extract s) ⋆^^ ee_mu (extract s));
      econstructor; replace (ee_mu (extract s)) with (extract (e_mu t s)) by auto;
      eauto using lc_extract_lc.
  (* castdn *)
  - instantiate_trivial_equals.
    destruct IHusub2 with (extract e1) (extract e2); auto.
    split.
    + destruct H2.
      * apply evalue_value in H2; auto.
        destruct (is_castup_dec e1), (is_bind_dec e1).
        -- apply is_castup_eq in H4 as (C & e1' & E). subst.
           simpl. right. exists (extract e1'). eauto.
        -- apply is_castup_eq in H4 as (C & e1' & E). subst.
           simpl. right. exists (extract e1'). eauto.
        -- apply is_bind_eq in H5 as (C & e1' & E). subst.
           simpl. right. pick fresh x. exists (ee_castdn (extract e1' ⋆^` x)).
           apply er_cast_inst with empty.
           replace (ee_bind (extract e1')) with (extract (e_bind C e1')) by reflexivity.
           eauto using lc_extract_lc. auto.
        -- apply reflexivity_l in H1.
           eapply reducible_type in H1; [easy | eauto..].
      * destruct H2; eauto.
    + destruct H3.
      * apply evalue_value in H3; auto.
        destruct (is_castup_dec e2), (is_bind_dec e2).
        -- apply is_castup_eq in H4 as (C & e2' & E). subst.
           simpl. right. exists (extract e2'). eauto.
        -- apply is_castup_eq in H4 as (C & e2' & E). subst.
           simpl. right. exists (extract e2'). eauto.
        -- apply is_bind_eq in H5 as (C & e1' & E). subst.
           simpl. right. pick fresh x. exists (ee_castdn (extract e1' ⋆^` x)).
           apply er_cast_inst with empty.
           replace (ee_bind (extract e1')) with (extract (e_bind C e1')) by reflexivity.
           eauto using lc_extract_lc. auto.
        -- apply reflexivity_r in H1.
           eapply reducible_type in H1; [easy | eauto..].
      * destruct H3; eauto.
  (* forall_l *)
  - split.
    + solve_progress_evalue.
    + instantiate_trivial_equals.
      now destruct IHusub3 with (extract (B ^^ t)) (extract C).
  (* forall_r *)
  - split.
    + instantiate_trivial_equals.
      now destruct IHusub2 with (extract A) (extract A).
    + solve_progress_evalue.
Qed.

Corollary erased_progress : forall e A,
    nil ⊢ e : A -> EProgressive (extract e).
Proof.
  intros.
  apply generalized_erased_progress
    with (e1' := extract e) (e2' := extract e) in H.
  destruct H. all: auto.
Qed.

Lemma bind_extraction_inversion : forall e ee,
    ee_bind ee = extract e ->
    exists A e', e = e_bind A e' /\ ee = extract e'.
Proof.
  induction e; simpl; intros; inversion H; eauto.
Qed.

Lemma abs_extraction_inversion : forall e ee,
    ee_abs ee = extract e ->
    exists A e', e = e_abs A e' /\ ee = extract e'.
Proof.
  induction e; simpl; intros; inversion H; eauto.
Qed.

Lemma castdn_extraction_inversion : forall e ee,
    ee_castdn ee = extract e ->
    exists e', e = e_castdn e' /\ ee = extract e'.
Proof.
  induction e; simpl; intros; inversion H; eauto.
Qed.

Lemma castup_extraction_inversion : forall e ee,
    ee_castup ee = extract e ->
    exists A e', e = e_castup A e' /\ ee = extract e'.
Proof.
  induction e; simpl; intros; inversion H; eauto.
Qed.

Ltac invert_extraction :=
  let A := fresh "A" in
  let e2 := fresh "e" in
  let E1 := fresh "E" in
  let E2 := fresh "E" in
  match goal with
  | H : ee_bind _ = extract _ |- _ =>
    apply bind_extraction_inversion in H as (A & e2 & E1 & E2)
  | H : ee_abs  _ = extract _ |- _ =>
    apply abs_extraction_inversion in H as (A & e2 & E1 & E2)
  | H : ee_castdn _ = extract _ |- _ =>
    apply castdn_extraction_inversion in H as (A & e2 & E1 & E2)
  | H : ee_castup _ = extract _ |- _ =>
    apply castup_extraction_inversion in H as (A & e2 & E1 & E2)
  end; subst; simpl in *
.

Ltac invert_extractions := repeat invert_extraction.

Lemma bind_inversion : forall Γ A b1 b2 T,
    Γ ⊢ e_bind A b1 <: e_bind A b2 : T ->
    exists B L, Γ ⊢ e_bind A b1 <: e_bind A b2 : e_all A B
         /\ Γ ⊢ e_all A B <: T : *
         /\ (forall x, x `notin` L -> Γ , x : A ⊢ b1 ^` x <: b2 ^` x : B ^` x)
         /\ (forall x, x `notin` L -> x `notin` fv_eexpr (extract (b1 ^` x)))
         /\ (forall x, x `notin` L -> x `notin` fv_eexpr (extract (b2 ^` x))).
Proof.
  intros. dependent induction H.
  - exists B. exists L. repeat split; eauto 2.
  - specialize (IHusub1 A b1 b2). instantiate_trivial_equals.
    destruct IHusub1 as (B' & L & IH). destruct_pairs.
    exists B', L. repeat split; eauto 3 using transitivity.
Qed.

Definition is_forall (e : expr) : Prop :=
  match e with
  | e_all _ _ => True
  | _ => False
  end
.

Lemma forall_l_sub_inversion : forall Γ A B C,
    Γ ⊢ e_all A B <: C : * ->
    not (is_forall C) ->
    exists e, mono_type e /\ Γ ⊢ e : A /\ Γ ⊢ B ^^ e <: C : *.
Proof.
  intros * Sub.
  dependent induction Sub; simpl; intros.
  + eauto.
  + contradiction.
  + contradiction.
  + eapply IHSub1; eauto.
    apply kind_sub_inversion_l in Sub2. destruct_pairs. congruence.
Qed.

Ltac split_all := repeat split.

Ltac rewrite_extract_invariant G e :=
  match G with
  | context [e ⋆^^ _] =>
    erewrite (notin_open_var_notin_open e); eauto
  end
.

Ltac find_extract_invariants :=
  repeat
    match goal with
    | H : ?x `notin` fv_eexpr (extract _) |- _  => autorewrite with reassoc in H; simpl in H
    | H : ?x `notin` fv_eexpr (?e ⋆^` ?x) |- ?G => rewrite_extract_invariant G e
    | _ => progress autorewrite with reassoc
    end
.

Lemma is_forall_eq : forall e,
    is_forall e -> exists A b, e = e_all A b.
Proof.
  intros. destruct e; simpl in *; inversion H; eauto.
Qed.

Lemma expr_of_box_never_be_reduced : forall A B a Γ1 Γ2,
    A ⟶ B -> Γ1 ⊢ a : A -> Γ2 ⊢ B : BOX -> False.
Proof.
  intros.
  conclude_type_refl H0.
  - inversion H.
  - eauto using expr_of_box_never_be_reduced'.
Qed.

Tactic Notation "absurd" "by" tactic(t) :=
  assert False by t; contradiction.

Lemma deterministic_type_reduction' : forall e e',
    e ⟶ e' -> forall Γ A n k, Γ ⊢ e : A -> head_kind A k n -> e ⟹ e'.
Proof.
  intros * R.
  induction R; intros * Sub K; eauto.
  (* r_app *)
  - dependent induction Sub.
    + box_reasoning.
      * destruct k; box_reasoning.
      * eauto.
    (* or `eauto using head_kind_sub_l` *)
    + eapply IHSub1; eauto. eapply head_kind_sub_l; eauto.
  (* r_inst *)
  - dependent induction Sub.
    + box_reasoning.
      * destruct k; box_reasoning.
      * apply bind_inversion in Sub2. destruct_conjs.
        eapply head_kind_sub_l in H6. inversion H6. eauto.
    + eapply IHSub1; eauto. eapply head_kind_sub_l; eauto.
  (* r_castdn *)
  - dependent induction Sub.
    + destruct k; box_reasoning.
      absurd by eauto 3 using expr_of_box_never_be_reduced.
    + eapply IHSub1; eauto. eapply head_kind_sub_l; eauto.
  (* r_cast_inst *)
  - dependent induction Sub.
    + destruct k; box_reasoning.
      absurd by eauto 3 using expr_of_box_never_be_reduced.
    + eapply IHSub1; eauto. eapply head_kind_sub_l; eauto.
  (* r_cast_elim *)
  - dependent induction Sub.
    + destruct k; box_reasoning.
      absurd by eauto 3 using expr_of_box_never_be_reduced.
    + eapply IHSub1; eauto. eapply head_kind_sub_l; eauto.
Qed.

Lemma deterministic_type_reduction : forall Γ e e' k,
    e ⟶ e' -> Γ ⊢ e : e_kind k -> e ⟹ e'.
Proof.
  intros.
  eapply deterministic_type_reduction'; eauto.
  Unshelve. exact 0.
Qed.

Lemma deterministic_type_reduction_2 : forall Γ e A A',
    A ⟶ A' -> Γ ⊢ e : A -> A ⟹ A'.
Proof.
  intros.
  conclude_type_refl H0.
  - inversion H.
  - eapply deterministic_type_reduction; eauto.
Qed.

Lemma deterministic_erased_reduction : forall e e1 e2,
    extract e ⋆⟶ e1 -> extract e ⋆⟶ e2 ->
    forall Γ A, Γ ⊢ e : A -> e1 = e2.
Proof.
  induction e; simpl; intros E1 E2 R1 R2 Γ A Sub;
    solve_impossible_reduction.
  - inversion R1; inversion R2; subst;
      invert_extractions; solve_impossible_reduction.
    + dependent induction Sub.
      * assert (ee2 = ee5) by (eapply IHe1; eauto 3). now subst.
      * eauto 2.
    + now inversion H.
    + inversion H.
    + inversion H5.
    + inversion H. dependent induction Sub; eauto 2.
      clear IHSub1 IHSub2.
      apply bind_inversion in Sub2; destruct_conjs.
      pick fresh x'. instantiate_cofinites. find_extract_invariants.
  - inversion R1; inversion R2; subst. auto.
  - inversion R1; inversion R2; subst;
      invert_extractions; solve_impossible_reduction.
    + dependent induction Sub.
      * assert (ee2 = ee3) by (eapply IHe; eauto 3). now subst.
      * eauto 2.
    + inversion H. dependent induction Sub; eauto 2.
      clear IHSub1 IHSub2.
      apply bind_inversion in Sub2; destruct_conjs.
      pick fresh x'. instantiate_cofinites. find_extract_invariants.
    + inversion H3.
    + inversion H.
    + now inversion H.
Qed.

Theorem preservation : forall e1 e2 A,
    nil ⊢ e1 <: e2 : A ->
    forall e1'' e2'', extract e1 ⋆⟶ e1'' -> extract e2 ⋆⟶ e2''  ->
    exists e1' e2', extract e1' = e1''
             /\ extract e2' = e2''
             /\ e1 ⟶ e1'
             /\ e2 ⟶ e2'
             /\ nil ⊢ e1' <: e2' : A.
Proof.
  intros * Sub.
  dependent induction Sub; simpl; intros;
    solve_impossible_reduction;
    instantiate_trivial_equals.
  - inversion H0; subst.
    + inversion H1; subst.
      (* main case for r_app *)
      * destruct IHSub2 with ee2 ee0 as (e1' & e2' & IH); eauto.
        destruct_conjs. subst.
        exists (e_app e1' t), (e_app e2' t). repeat split; eauto 3.
      * invert_extractions. invert_sub_hyp. solve_impossible_reduction.
      * invert_extractions. invert_sub_hyp. solve_impossible_reduction.
    + invert_extractions. invert_sub_hyp.
      inversion H1; subst; solve_impossible_reduction.
      (* main case for r_beta *)
      exists (e ^^ t), (b ^^ t).
      autorewrite with reassoc.
      split_all; eauto.
      pose (B' := Sub2). apply abs_pi_principal in B'. destruct_conjs.
      apply pi_sub_inversion in H8 as (k' & L & Sub3).
      apply abs_principal_inversion in H5 as (L' & Sub4).
      pick fresh x for
           (L `union` L' `union` fv_expr e `union` fv_expr b `union` fv_expr B).
      instantiate_cofinites. destruct_pairs.
      rewrite_open_with_subst.
      eapply context_narrowing_cons in Sub4; eauto 4 using substitution_cons.
    + invert_extractions. invert_sub_hyp.
      inversion H1; subst; solve_impossible_reduction.
      (* main case for r_inst *)
      apply bind_inversion in Sub2 as (F & L1 & Hb). destruct_pairs.
      apply forall_l_sub_inversion in H6 as (m & M & Subm & Sub_inst); auto.
      exists (e_app (e ^^ m) t), (e_app (b ^^ m) t). split_all; simpl.
      * pick fresh x'. instantiate_cofinites. find_extract_invariants.
      * pick fresh x'. instantiate_cofinites. find_extract_invariants.
      * eauto.
      * eauto.
      * eapply s_app; eauto. apply s_sub with (F ^^ m) k_star; auto.
        pick fresh x' for
             (L `union` L0 `union` L1 `union`
                fv_expr e `union` fv_expr b `union` fv_expr F).
        rewrite_open_with_subst.
        eauto 3 using substitution_cons.
  - inversion H2; inversion H3; subst.
    (* r_mu *)
    assert (nil ⊢ e_mu t s : t) by eauto.
    exists (s ^^ (e_mu t s)), (s ^^ (e_mu t s)). split_all.
    + now rewrite extract_open_distr.
    + now rewrite extract_open_distr.
    + eauto.
    + eauto.
    + pick fresh x for (L `union` fv_expr t `union` fv_expr s).
      instantiate_cofinites.
      conclude_freshes. rewrite_open_with_subst.
      pose (t' := t). assert (t' = t) as E by auto.
      replace (e_mu t s) with (e_mu t' s) by auto.
      replace t with ([(e_mu t s) / x] t) by now apply fresh_subst_eq.
      rewrite E.
      eapply substitution_cons; eauto 3.
  - inversion H0; subst.
    + inversion H1; subst.
      (* main case for r_castdn *)
      * destruct IHSub2 with ee2 ee0 as (e1' & e2' & IH); eauto.
        destruct_conjs. subst.
        exists (e_castdn e1'), (e_castdn e2'). repeat split; eauto 3.
      * invert_extractions. invert_sub_hyp. inversion H3.
      * invert_extractions. invert_sub_hyp. inversion H3.
    + invert_extractions. invert_sub_hyp. inversion H1; subst; solve_impossible_reduction.
    (* main case for r_cast_inst *)
      apply bind_inversion in Sub2 as (F & L1 & Hb). destruct_pairs.
      apply forall_l_sub_inversion in H8 as (m & M & Subm & Sub_inst); auto.
      exists (e_castdn (e ^^ m)), (e_castdn (b ^^ m)). split_all; simpl.
      * pick fresh x'. instantiate_cofinites. find_extract_invariants.
      * pick fresh x'. instantiate_cofinites. find_extract_invariants.
      * eauto.
      * eauto.
      * eapply s_castdn; eauto.
        eapply s_sub with (F ^^ m) k_star; auto.
        pick fresh x' for (L `union` L0 `union` L1 `union` fv_expr e `union` fv_expr b `union` fv_expr F).
        rewrite_open_with_subst.
        eauto 3 using substitution_cons.
      * intro. apply is_forall_eq in H12. destruct_exists. subst. inversion H.
    + invert_extractions. invert_sub_hyp. inversion H1; subst; solve_impossible_reduction.
      (* main case for r_cast_elim *)
      * exists e, b. repeat split; eauto.
        apply castup_inversion in Sub2 as (C & k' & Sub & R & Sub').
        apply s_sub with C k'. auto.
        eapply type_preservation; eauto using deterministic_type_reduction. Unshelve. all: exact 0.
  - edestruct IHSub1 as (e1' & e2' & H1); eauto.
    destruct_pairs.
    exists e1', e2'. repeat split; eauto.
Qed.


From iris.algebra Require Export frac.
From iris.bi.lib Require Import fractional.
From iris.proofmode Require Import tactics.
From Perennial.base_logic.lib Require Export invariants.
From iris.prelude Require Import options.
Import uPred.

Class cinvG Σ := cinv_inG :> inG Σ fracR.
Definition cinvΣ : gFunctors := #[GFunctor fracR].

Global Instance subG_cinvΣ {Σ} : subG cinvΣ Σ → cinvG Σ.
Proof. solve_inG. Qed.

Section defs.
  Context `{!invGS Σ, !cinvG Σ}.

  Definition cinv_own (γ : gname) (p : frac) : iProp Σ := own γ p.

  Definition cinv (N : namespace) (γ : gname) (P : iProp Σ) : iProp Σ :=
    inv N (P ∨ cinv_own γ 1).
End defs.

Global Instance: Params (@cinv) 5 := {}.

Section proofs.
  Context `{!invGS Σ, !cinvG Σ}.

  Global Instance cinv_own_timeless γ p : Timeless (cinv_own γ p).
  Proof. rewrite /cinv_own; apply _. Qed.

  Global Instance cinv_contractive N γ : Contractive (cinv N γ).
  Proof. solve_contractive. Qed.
  Global Instance cinv_ne N γ : NonExpansive (cinv N γ).
  Proof. exact: contractive_ne. Qed.
  Global Instance cinv_proper N γ : Proper ((≡) ==> (≡)) (cinv N γ).
  Proof. exact: ne_proper. Qed.

  Global Instance cinv_persistent N γ P : Persistent (cinv N γ P).
  Proof. rewrite /cinv; apply _. Qed.

  Global Instance cinv_own_fractional γ : Fractional (cinv_own γ).
  Proof. intros ??. by rewrite /cinv_own -own_op. Qed.
  Global Instance cinv_own_as_fractional γ q :
    AsFractional (cinv_own γ q) (cinv_own γ) q.
  Proof. split; [done|]. apply _. Qed.

  Lemma cinv_own_valid γ q1 q2 : cinv_own γ q1 -∗ cinv_own γ q2 -∗ ⌜q1 + q2 ≤ 1⌝%Qp.
  Proof. rewrite -frac_validI. apply (own_valid_2 γ q1 q2). Qed.

  Lemma cinv_own_1_l γ q : cinv_own γ 1 -∗ cinv_own γ q -∗ False.
  Proof.
    iIntros "H1 H2".
    iDestruct (cinv_own_valid with "H1 H2") as %[]%(exclusive_l 1%Qp).
  Qed.

  Lemma cinv_iff N γ P Q : cinv N γ P -∗ ▷ □ (P ↔ Q) -∗ cinv N γ Q.
  Proof.
    iIntros "HI #HPQ". iApply (inv_iff with "HI"). iIntros "!> !>".
    iSplit; iIntros "[?|$]"; iLeft; by iApply "HPQ".
  Qed.

  (*** Allocation rules. *)
  (** The "strong" variants permit any infinite [I], and choosing [P] is delayed
  until after [γ] was chosen.*)
  Lemma cinv_alloc_strong (I : gname → Prop) E N :
    pred_infinite I →
    ⊢ |={E}=> ∃ γ, ⌜ I γ ⌝ ∗ cinv_own γ 1 ∗ ∀ P, ▷ P ={E}=∗ cinv N γ P.
  Proof.
    iIntros (?). iMod (own_alloc_strong 1%Qp I) as (γ) "[Hfresh Hγ]"; [done|done|].
    iExists γ. iIntros "!> {$Hγ $Hfresh}" (P) "HP".
    iMod (inv_alloc N _ (P ∨ cinv_own γ 1) with "[HP]"); eauto.
  Qed.

  (** The "open" variants create the invariant in the open state, and delay
  having to prove [P].
  These do not imply the other variants because of the extra assumption [↑N ⊆ E]. *)
  Lemma cinv_alloc_strong_open (I : gname → Prop) E N :
    pred_infinite I →
    ↑N ⊆ E →
    ⊢ |={E}=> ∃ γ, ⌜ I γ ⌝ ∗ cinv_own γ 1 ∗ ∀ P,
      |={E,E∖↑N}=> cinv N γ P ∗ (▷ P ={E∖↑N,E}=∗ True).
  Proof.
    iIntros (??). iMod (own_alloc_strong 1%Qp I) as (γ) "[Hfresh Hγ]"; [done|done|].
    iExists γ. iIntros "!> {$Hγ $Hfresh}" (P).
    iMod (inv_alloc_open N _ (P ∨ cinv_own γ 1)) as "[Hinv Hclose]"; first by eauto.
    iIntros "!>". iFrame. iIntros "HP". iApply "Hclose". iLeft. done.
  Qed.

  Lemma cinv_alloc_cofinite (G : gset gname) E N :
    ⊢ |={E}=> ∃ γ, ⌜ γ ∉ G ⌝ ∗ cinv_own γ 1 ∗ ∀ P, ▷ P ={E}=∗ cinv N γ P.
  Proof.
    apply cinv_alloc_strong. apply (pred_infinite_set (C:=gset gname))=> E'.
    exists (fresh (G ∪ E')). apply not_elem_of_union, is_fresh.
  Qed.

  Lemma cinv_alloc E N P : ▷ P ={E}=∗ ∃ γ, cinv N γ P ∗ cinv_own γ 1.
  Proof.
    iIntros "HP". iMod (cinv_alloc_cofinite ∅ E N) as (γ _) "[Hγ Halloc]".
    iExists γ. iFrame "Hγ". by iApply "Halloc".
  Qed.

  Lemma cinv_alloc_open E N P :
    ↑N ⊆ E → ⊢ |={E,E∖↑N}=> ∃ γ, cinv N γ P ∗ cinv_own γ 1 ∗ (▷ P ={E∖↑N,E}=∗ True).
  Proof.
    iIntros (?). iMod (cinv_alloc_strong_open (λ _, True)) as (γ) "(_ & Htok & Hmake)"; [|done|].
    { apply pred_infinite_True. }
    iMod ("Hmake" $! P) as "[Hinv Hclose]". iIntros "!>". iExists γ. iFrame.
  Qed.

  (*** Accessors *)
  Lemma cinv_acc_strong E N γ p P :
    ↑N ⊆ E →
    cinv N γ P -∗ (cinv_own γ p ={E,E∖↑N}=∗
    ▷ P ∗ cinv_own γ p ∗ (∀ E' : coPset, ▷ P ∨ cinv_own γ 1 ={E',↑N ∪ E'}=∗ True)).
  Proof.
    iIntros (?) "Hinv Hown".
    iPoseProof (inv_acc (↑ N) N with "Hinv") as "H"; first done.
    rewrite difference_diag_L.
    iPoseProof (fupd_mask_frame_r _ _ (E ∖ ↑ N) with "H") as "H"; first set_solver.
    rewrite left_id_L -union_difference_L //. iMod "H" as "[[$ | >Hown'] H]".
    - iIntros "{$Hown} !>" (E') "HP".
      iPoseProof (fupd_mask_frame_r _ _ E' with "(H [HP])") as "H"; first set_solver.
      { iDestruct "HP" as "[?|?]"; eauto. }
      by rewrite left_id_L.
    - iDestruct (cinv_own_1_l with "Hown' Hown") as %[].
  Qed.

  Lemma cinv_acc E N γ p P :
    ↑N ⊆ E →
    cinv N γ P -∗ cinv_own γ p ={E,E∖↑N}=∗ ▷ P ∗ cinv_own γ p ∗ (▷ P ={E∖↑N,E}=∗ True).
  Proof.
    iIntros (?) "#Hinv Hγ".
    iMod (cinv_acc_strong with "Hinv Hγ") as "($ & $ & H)"; first done.
    iIntros "!> HP".
    rewrite {2}(union_difference_L (↑N) E)=> //.
    iApply "H". by iLeft.
  Qed.

  (*** Other *)
  Lemma cinv_cancel E N γ P : ↑N ⊆ E → cinv N γ P -∗ cinv_own γ 1 ={E}=∗ ▷ P.
  Proof.
    iIntros (?) "#Hinv Hγ".
    iMod (cinv_acc_strong with "Hinv Hγ") as "($ & Hγ & H)"; first done.
    rewrite {2}(union_difference_L (↑N) E)=> //.
    iApply "H". by iRight.
  Qed.

  Global Instance into_inv_cinv N γ P : IntoInv (cinv N γ P) N := {}.

  Global Instance into_acc_cinv E N γ P p :
    IntoAcc (X:=unit) (cinv N γ P)
            (↑N ⊆ E) (cinv_own γ p) (fupd E (E∖↑N)) (fupd (E∖↑N) E)
            (λ _, ▷ P ∗ cinv_own γ p)%I (λ _, ▷ P)%I (λ _, None)%I.
  Proof.
    rewrite /IntoAcc /accessor. iIntros (?) "#Hinv Hown".
    rewrite exist_unit -assoc.
    iApply (cinv_acc with "Hinv"); done.
  Qed.
End proofs.

Typeclasses Opaque cinv_own cinv.


(* Multiple inputs and outputs, blocking reads *)
Require Import Merges.Tactics.
Require Import Merges.Map.

Require Import Merges.Machine.
Require Import Merges.Fusion.Base.
Require Import Merges.Fusion.Tactics.

Require Import Coq.Lists.List.
Import ListNotations.
Set Implicit Arguments.
Require Import Coq.Logic.FunctionalExtensionality.

  Module B := Machine.Base.
  Module P := Machine.Program.
  Module F := Base.Fuse.
  Module FT := Tactics.Tactics.

Section Proof.
  Variable C : Set.
  Variable V1 : Set.
  Variable L1 : Set.
  Variable P1 : P.Program L1 C V1.

  Variable V2 : Set.
  Variable L2 : Set.
  Variable P2 : P.Program L2 C V2.

  Variable EqDec_C : EqDec C.

  Theorem EvalBlockJump pL:
   FT.EvalStep P1 P2 EqDec_C
    (B.BlockJump _ _ pL).
  Proof.
    EvalStep_intros.
    EvalStep_unfold_all.
    jauto_set.
      (* EvalBs P1 *)
      - matchmaker hBlockEq; inject_all.

        all: try EvalStep_Rule hEv1 hSv1.
        all: !eapply B.EvalBs1.
        all: try EvalStep_Rule B.EvalBJump hSv1.
        all: try EvalStep_Rule B.EvalBRelease hSv1.

      (* Sv P1 *)
      - EvalStep_Invariant hSv1 hBlockEq.

      (* EvalBs P2 *)
      - matchmaker hBlockEq; inject_all.

        all: try EvalStep_Rule hEv2 hSv2.
        all: !eapply B.EvalBs1.
        all: try EvalStep_Rule B.EvalBJump hSv2.
        all: try EvalStep_Rule B.EvalBRelease hSv2.

      (* Sv P2 *)
      - EvalStep_Invariant hSv2 hBlockEq.
    Qed.

End Proof.


(* We make a translation from full brunerie (any ctx) to brunerie *)
Require Import ssreflect ssrfun ssrbool .

From Modules Require Import HomotopicalEquality TypesAreOmegaGroupoids.FunctionalRelation lib PreSyntaxOnlyContr .
From Modules Require Import WfSyntaxBrunerieOnlyContr.
(* gtype decl omegagroupoids fullomegagroupoids. *)
From Modules Require Import WfSyntaxBrunerieAllCtx.
Set Bullet Behavior "Strict Subproofs".

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* Local Notation "⟦ X ⟧V" := (dTm (w_va X)). *)

Module B := WfSyntaxBrunerieOnlyContr.
Module FB := WfSyntaxBrunerieAllCtx.

Local Notation SB := (B.syntax).
Local Notation SF := (FB.syntax).

Module Syn := Syntax.
Local Notation "'WC' S" := (@Syn.WC _ S) (at level 0).
Local Notation "'WTy' S" := (@Syn.WTy _ S)(at level 0).
Local Notation "'Wtm' S":= (@Syn.Wtm _ S)(at level 0).
Local Notation "'WS' S":= (@Syn.WS _ S)(at level 0).
Local Notation "'SF_WVar' S":= (FB.WVar S)(at level 0).
Local Notation "'SB_WVar' S":= (B.WVar S)(at level 0).

Module SS  := PreSyntaxOnlyContr.
(*
Local Notation WTy := (@Syn.WTy _).
Local Notation Wtm := (@Syn.Wtm _).
Local Notation WS := (@Syn.WS _).
Local Notation SC_WVar := (WfSyntaxEricSamOnlyPs.WVar).
Local Notation SB_WVar := (WfSyntaxBrunerieOnlyContr.WVar).
*)
(*

On pourrait essayer de montrer la chose suivante pour la syntaxe full brunerie :
si Γ ⊢ coh_Δ,A[σ] alors il existe Γ' ⊂ Γ  contractile et Γ' ⊢ δ : Δ telles que σ
bof..

Ou encore: on fait une traduction Full Brunerie -> Brunerie pour la sous-syntaxe de Full Brunerie
restreint aux contextes contractiles.
C'est parti

*)

Fixpoint tradV Γ x  : SS.Var :=
  match Γ,x with
    ext empty _, v0 => vstar
  | ext (ext Γ A) B, v0 => SS.v0
  | ext (ext Γ A) B, vwk v0 => SS.v1
  | ext (ext Γ A) B, vwk (vwk x) => SS.vwk (tradV Γ x)
  (* dummy *)
  | _,_ => vstar
  end.

(*
Fixpoint tradV Γ A x (wx : SF_WVar Γ A x) : SB.Var.
 destruct wx.
 - (* dummy *)
   exact:vstar.
 - (* cas v0 *)
*)

Ltac exfalsoinvert h := exfalso; inversion h.

Fixpoint tradC (Γ : FB.Con)  (isC : isContr Γ) (wΓ: FB.WC Γ) : SS.Con
with tradTy (Γ : FB.Con) (A : FB.Ty) (wA : FB.WTy Γ A) : SS.Ty
with tradTm (Γ : FB.Con) A (t : FB.Tm) (wt : FB.Wtm Γ A t) : SS.Tm
with tradS Γ (Δ : FB.Con) (σ : FB.sub) (wσ : FB.WS Γ Δ σ) : SS.sub.
- destruct wΓ as [| ? ? ? wA].
  + by exfalsoinvert isC.
  + destruct wΓ.
    * destruct A ; last by exfalsoinvert isC.
      exact:astar.
    * destruct A; first by exfalsoinvert isC.
      destruct t; last by  exfalsoinvert isC.
      destruct x; last by  exfalsoinvert isC.
      apply:SS.ext.
    -- apply:(tradC _  (snd isC)) => //.
    (* apply:isContr_WC => //. *)
    -- apply:(tradTy Γ).
      eassumption.
    -- apply:tradTm.
      eassumption.
- destruct wA.
  (* star *)
  + exact:SS.star.
  + apply:SS.ar.
    * apply:tradTy.
      exact:wA.
    * apply:tradTm.
      exact :w.
    * apply:tradTm.
      exact :w0.
- destruct wt.
  (* variable *)
  + exact:(SS.va (tradV Γ x)).
  + apply:SS.coh.
    * apply:tradC; last by eassumption.
      (* eassumption. *)
    * apply:tradTy.
      exact:w0.
    * apply:tradS.
      eassumption.
- destruct wσ.
  (* to_empty.. *)
  + (* dummy *)
    exact :(SS.to_star (SS.va (SS.vstar))).
  + destruct wσ; first by exact :(SS.to_star (SS.va (SS.vstar))).
    apply:SS.to_ext.
    * apply:tradS.
      eassumption.
    * apply:tradTm.
      exact:w2.
    * apply:tradTm.
      exact:w0.
Defined.

(*
Fixpoint tradC (Γ : FB.Con)  (isC : isContr Γ) : SS.Con
with tradTy (Γ : FB.Con) (A : FB.Ty) (wA : FB.WTy Γ A) : SS.Ty
with tradTm (Γ : FB.Con) A (t : FB.Tm) (wt : FB.Wtm Γ A t) : SS.Tm
with tradS Γ (Δ : FB.Con) (σ : FB.sub) (wσ : FB.WS Γ Δ σ) : SS.sub.
- destruct isC.
  + exact:astar.
  + apply:SS.ext.
    * apply:(tradC _  isC) => //.
      (* apply:isContr_WC => //. *)
    * apply:(tradTy Γ).
      eassumption.
    * apply:tradTm.
      eassumption.
- destruct wA.
  (* star *)
  + exact:SS.star.
  + apply:SS.ar.
    * apply:tradTy.
      exact:wA.
    * apply:tradTm.
      exact :w.
    * apply:tradTm.
      exact :w0.
- destruct wt.
  (* variable *)
  + exact:(SS.va (tradV Γ x)).
  + apply:SS.coh.
    * apply:tradC; last by eassumption.
      (* eassumption. *)
    * apply:tradTy.
      exact:w0.
    * apply:tradS.
      eassumption.
- destruct wσ.
  (* to_empty.. *)
  + (* dummy *)
    exact :(SS.to_star (SS.va (SS.vstar))).
  + destruct wσ; first by exact :(SS.to_star (SS.va (SS.vstar))).
    apply:SS.to_ext.
    * apply:tradS.
      eassumption.
    * apply:tradTm.
      exact:w2.
    * apply:tradTm.
      exact:w0.
Defined.

Local Notation "⟦ X  ⟧C" := (tradC X ).
Local Notation "⟦ X ⟧T" := (tradTy X).
Local Notation "⟦ X ⟧t" := (tradTm X).
Local Notation "⟦ X ⟧S" := (tradS X).

Lemma w_tradStar (Γ : FB.Con) wΓ (isC : isContr Γ)   : B.WTy ⟦ isC ⟧C ⟦ w_star (Γ := Γ) wΓ ⟧T.
Proof.
  induction isC => /=; repeat constructor.
Abort.

Fixpoint w_tradC Γ  (isC : isContr Γ) : (B.WC ⟦ isC ⟧C * B.WTy ⟦ isC ⟧C ⟦ w_star (Γ := Γ) (isContr_WC isC) ⟧T)
with w_tradTy (Γ : FB.Con) (isC : isContr Γ) (A : FB.Ty) (wA : FB.WTy Γ A) : B.WTy ⟦ isC ⟧C ⟦ wA ⟧T.
- destruct isC => /=.
  + repeat constructor.
  + split.
    {
      constructor.
    * apply:(fst (w_tradC _ _)).
    * apply:w_tradTy.
    * admit.
      }
    {
      repeat constructor.
      - apply:(fst (w_tradC _ _)).
      - apply:w_tradTy.
      - admit.
        }

- Guarded.
    destruct wA => /=.
  + apply:(snd (w_tradC _ isC)).
  + Guarded.
(*
Fixpoint tradC (Γ : FB.Con)  : SS.Con :=
  match Γ with
    | ext empty star => astar
    | ext (ext Γ A) (ar _ (va v0) u) => astar
    (* dummy *)
    | _ => astar
  end
with tradTy (Γ : FB.Con) (A : FB.Ty) : SS.Ty
with tradTm (Γ : FB.Con) (t : FB.Tm) : SS.Tm
with tradS (Δ : FB.Con) (σ : FB.sub) : SS.sub.
  - destruct isC.
    + exact astar.
    + apply:SB.ext.
      * exact:(tradC _ isC).
      * exact:IHisC.
*)

(*
La syntaxe bien typée full brunerie s'injecte dans brunerie minimal
avec des contextes non vides

Traduction Full Brunerie --> Brunerie

⟦ x:* ⟧ = ⟦ x : * ⟧
⟦ Γ , x : A ⟧ = ⟦ Γ ⟧ , x : ⟦ A ⟧, f : x -> coh_⟦Γ⟧,⟦A⟧

⟦ * ⟧ = *
⟦ t ->_A u ⟧ = ⟦ t ⟧ ->_⟦A⟧ ⟦ u ⟧

⟦ v0 ⟧ = v1
⟦ vwk x ⟧ = vwk ⟦ x ⟧
⟦ coh_Γ,A [σ ] ⟧ = coh_⟦Γ⟧,⟦A⟧ [ ⟦ σ ⟧ ]

Pour les substitutions
⟦ (t) ⟧ = to_star ⟦ t ⟧
⟦ (σ, t) ⟧ =  (⟦ σ ⟧, ⟦ t ⟧, coh_⟦Γ⟧,(⟦t⟧ -> coh_⟦Δ⟧,⟦A⟧[⟦σ⟧])

où Γ ⊢ (σ,t) : (Δ, x : A)

 Γ ⊢ A implique  ⟦ Γ ⟧ ⊢ ⟦ A ⟧
 Γ ⊢ t: A -> ⟦ Γ ⟧ ⊢ ⟦ t ⟧ : ⟦ A ⟧
 Γ ⊢ σ : Δ -> ⟦ Γ ⟧ ⊢ ⟦ σ ⟧ : ⟦ Δ ⟧

 *)

Fixpoint wCB_C (Γ : Con) (wΓ : WC SC Γ) : WC SB Γ
with wCB_T Γ A (wA : WTy SC Γ A) : WTy SB Γ A
with wCB_Tm Γ A t (wt : Wtm SC Γ A t) : Wtm SB Γ A t
with wCB_V Γ A x (wx : SC_WVar Γ A x) : SB_WVar Γ A x
with wCB_S Γ Δ σ (wσ : WS SC Γ Δ σ) : WS SB Γ Δ σ.
  - destruct wΓ.
    + constructor.
    + constructor.
      * apply:wCB_C => //.
      * apply:wCB_T => //.
      * constructor.
        apply:wCB_V => //.
  - destruct wA.
    + constructor.
      apply:wCB_C => //.
    + constructor.
      * apply:wCB_T => //.
      * apply:wCB_Tm => //.
      * apply:wCB_Tm => //.
  - destruct wt.
    + constructor.
      by apply:wCB_V => //.
    + constructor.
      * apply:wCB_C => //.
      * apply:wCB_T => //.
      * apply:wCB_S => //.
    + rewrite -/((ar  A t u).[σ]T).
      constructor.
      * apply:wCB_C => //.
      * constructor.
        -- apply:wCB_T => //.
        -- apply:wCB_Tm => //.
        -- apply:wCB_Tm => //.
      * apply:wCB_S => //.
 - destruct wx.
   + constructor.
   + constructor.
     * apply:wCB_V => //.
     * apply:wCB_Tm => //.
   + constructor.
     apply:wCB_Tm => //.
   + constructor.
     apply:wCB_Tm => //.
 - destruct wσ.
   + constructor.
     apply:wCB_Tm => //.
   + constructor.
      * apply:wCB_S => //.
      * apply:wCB_T => //.
      * apply:wCB_Tm => //.
      * apply:wCB_Tm => //.
      * apply:wCB_Tm => //.
Defined.

Section GroupoidToCat.
  Context (d : @Decl _ SB).

  Definition d' : @Decl _ SC :=
    {|
      dC := fun Γ  (wΓ : Syn.WC Γ) => ⟦ wCB_C wΓ ⟧C;
      dTy := fun (Γ : Con) (A : Ty) (wΓ : Syn.WC Γ) (wA : Γ ⊢ A) => ⟦ wCB_T wA ⟧T;
      dTm := fun (Γ : Con) (A : Ty) (t : Tm) (wΓ : Syn.WC Γ) (wt : Γ ⊢ t : A) (wA : Γ ⊢ A) =>
               ⟦ wCB_Tm wt ⟧t (wCB_T wA);
      dS := fun (Γ Δ : Con) (σ : sub) (wσ : WfSyntaxEricSamOnlyPs.WS Γ Δ σ) (wΓ : WfSyntaxEricSamOnlyPs.WC Γ) (wΔ : WfSyntaxEricSamOnlyPs.WC Δ) =>
              ⟦ wCB_S wσ ⟧S (wCB_C wΓ)(wCB_C wΔ) |}.

  Import omegagroupoids.
  Lemma isGroupoid_isCat (G : GType)  (gr : isOmegaGroupoid G d) : isOmegaCategory G d'.
    constructor.
    - by apply:dC_astar.
    - intros.
      apply:(dC_ext gr).
    - intros.
      apply:(dT_star gr).
    - intros.
      apply:(dT_ar gr).
    - intros.
      simpl.
      apply:JMeq_trans; last by apply:(sb_dTm gr).
      match goal with
        [ |- ⟦ ?w1 ⟧t ?w2 γ ≅ ⟦ ?w3 ⟧t ?w4 γ ] =>
        rewrite (WTm_hp w1 w3) (WTy_hp w2 w4)
      end.
      easy.
    - apply:(dTm_vstar gr).
    - intros; apply:(dTm_v1 gr).
      eassumption.
    - intros; apply:(dTm_v0 gr) => //.
    - intros; apply:(dTm_vwk gr) => //.
      eassumption.
    - intros;apply:(dS_to_star gr) => //.
    - intros;apply:(dS_to_ext gr) => //.
      exact:H.
      exact:H0.
      exact:H1.
  Qed.

End GroupoidToCat.


From ConCert.Execution Require Import Blockchain.
From ConCert.Execution Require Import BoundedN.
From ConCert.Execution Require Import Containers.
From ConCert.Execution Require Import Serializable.
From ConCert.Execution.Test Require Import QCTest.
From ConCert.Examples.Congress Require Import Congress_Buggy.
From Coq Require Import ZArith.
From Coq Require Import List. Import ListNotations.
Import MonadNotation.

Arguments SerializedValue : clear implicits.
Arguments deserialize : clear implicits.
Arguments serialize : clear implicits.

Definition serializeMsg := serialize Msg _.

Definition gRulesSized (n : nat) : G Rules :=
  vote_count <- choose(1%Z, 1000%Z) ;;
  margin <- choose(1%Z, 1000%Z) ;;
  liftM (build_rules vote_count margin) arbitrary.

#[export]
Instance genRulesSized : GenSized Rules :=
{|
  arbitrarySized := gRulesSized
|}.

#[export]
Instance genSetupSized : GenSized Setup :=
{|
  arbitrarySized n := liftM build_setup (arbitrarySized n)
|}.

(* ------------------ generators of actions --------------------------- *)

(* helpers *)

Definition genToOpt {A : Type} (g : G A) : GOpt A :=
  a <- g ;;
  returnGenSome a.

Definition congressContractsMembers_nonowners state : list Address :=
    let members := (map fst o FMap.elements) (members state) in
    let non_owner_members := filter (fun member => address_neqb member (owner state)) members in
    non_owner_members.

Definition gCongressMember_without_caller (state : Congress_Buggy.State)
                           (calling_addr : Address)
                           (contract_addr : Address)
                           : GOpt Address :=
  let members := (map fst o FMap.elements) (members state) in
  let members_without_caller := List.remove address_eqdec calling_addr members in
  match members_without_caller with
  | [] => returnGen None
  | m ::ms => liftM Some (elems_ m members_without_caller)
  end.

Definition try_newCongressMember_fix (members : list Address)
                                   nr_attempts curr_nr
                                   : option Address :=
  let fix aux nr_attempts curr_nr :=
  match nr_attempts with
  | 0 => None
  | S n' =>
      match @BoundedN.of_nat AddrSize curr_nr with
      | Some addr_attempt =>
          if List.existsb (address_eqb addr_attempt) members
          then aux n' (S curr_nr)
          else Some addr_attempt
      | None => None
      end
  end in aux nr_attempts curr_nr.

Definition try_newCongressMember (state : Congress_Buggy.State)
                                 (congress_addr : Address)
                                 (nr_attempts : nat)
                                 : option Address :=
  let members := (map fst o FMap.elements) (members state) in
  try_newCongressMember_fix members nr_attempts 0.

Definition bindCallerIsOwnerOpt {A : Type}
                                (state : Congress_Buggy.State)
                                (calling_addr : Address)
                                (contract_addr : Address)
                                (g : GOpt A)
                                : GOpt A :=
  if address_eqb calling_addr contract_addr
  then g
  else if address_eqb state.(owner) calling_addr
       then g
       else returnGen None.

Definition try_gNewOwner state calling_addr contract_addr : GOpt Address :=
  bindCallerIsOwnerOpt state calling_addr contract_addr
    (gCongressMember_without_caller state calling_addr contract_addr).

Definition validate_addr (a : Address) : GOpt (address_is_contract a = false) :=
  match (Bool.bool_dec (address_is_contract a) true ) with
  | left _ => ret None
  | right p => ret (Some (Bool.not_true_is_false _ p))
  end.

Definition vote_proposal (caddr : Address)
                         (members_and_proposals : FMap Address (list ProposalId))
                         (call : forall (caddr : Address) (origin : Address),
                             address_is_contract origin = false -> Msg -> GOpt Action)
                         (vote : ProposalId -> Msg) :=
  '(member, pids) <- sampleFMapOpt members_and_proposals ;;
  p <- validate_addr member ;;
  pid <- elems_opt pids ;;
  call caddr member p (vote pid).

(* Returns a mapping to proposals which have been discussed long enough, according to the
   current rules in the given congress' state *)
Definition finishable_proposals (state : Congress_Buggy.State)
                                (current_slot : nat)
                                : FMap ProposalId Proposal :=
  let pids_map_filtered := filter_FMap (fun '(_, proposal) =>
    proposal.(proposed_in) + state.(state_rules).(debating_period_in_blocks) <=? current_slot
  ) state.(proposals) in
  if 0 <? FMap.size pids_map_filtered
  then pids_map_filtered
  else FMap.empty.

Definition lc_contract_members_and_proposals_new_voters (state : Congress_Buggy.State)
                                                        : (FMap Address (list ProposalId)) :=
    let candidate_members := (map fst o FMap.elements) (members state) in
    let proposals_pairs := FMap.elements (proposals state) in
    if (0 <? length candidate_members) && (0 <? length proposals_pairs)
    then
      let voters_to_proposals : FMap Address (list ProposalId) :=
        List.fold_left (fun acc m =>
        let unvoted_proposals : list (ProposalId * Proposal) :=
          List.filter (fun p => match FMap.find m (votes (snd p)) with
                                | Some _ => false
                                | None => true
                                end) proposals_pairs in
        match List.map fst unvoted_proposals with
        | [] => acc
        | _ as ps => FMap.add m ps acc
        end
      ) candidate_members FMap.empty in
      voters_to_proposals
    else FMap.empty.

Definition lc_contract_members_and_proposals_with_votes (state : Congress_Buggy.State)
                                                        : FMap Address (list ProposalId) :=
    let members : list Address := (map fst o FMap.elements) (members state) in
    let proposals_map : FMap nat Proposal :=
      filter_FMap (fun p => 0 =? (FMap.size (votes (snd p)))) (proposals state) in
    if (0 <? length members) && (0 =? (FMap.size proposals_map))
    then (
      let propIds : list ProposalId := (map fst o FMap.elements) proposals_map in
      fold_left (fun acc m => FMap.add m propIds acc) members FMap.empty
    )
    else FMap.empty.

Fixpoint GCongressAction (env : Environment)
                         (fuel : nat)
                         (caddr : Address)
                         : GOpt Action :=
  let call contract_addr caller_addr caller_addr_is_user msg :=
    amount <- match env.(env_account_balances) caller_addr with
              | 0%Z => returnGenSome 0%Z
              | caller_balance => genToOpt (choose (0%Z, caller_balance))
              end ;;
    returnGenSome (build_act caller_addr caller_addr
      (congress_action_to_chain_action (cact_call contract_addr amount (serializeMsg msg)))) in
  congress_state <- returnGen (get_contract_state Congress_Buggy.State env caddr) ;;
  let members := (map fst o FMap.elements) congress_state.(members) in
  let owner := congress_state.(owner) in
  match fuel with
  | 0 =>
    backtrack [
      (* transfer_ownership *)
      (1, members <- elems_opt (congressContractsMembers_nonowners congress_state) ;;
          new_owner <- (try_gNewOwner congress_state owner caddr) ;;
          p <- validate_addr owner ;;
          call caddr owner p (transfer_ownership new_owner)
      ) ;
      (* change_rules *)
      (1, rules <- genToOpt (gRulesSized 4) ;;
          p <- validate_addr owner ;;
          call caddr owner p (change_rules rules)
      ) ;
      (* add_member *)
      (2, addr <- returnGen (try_newCongressMember congress_state caddr 10) ;;
          p <- validate_addr owner ;;
          call caddr owner p (add_member addr)
      ) ;
      (* remove_member *)
      (1, member <- elems_opt members ;;
          p <- validate_addr owner ;;
          call caddr owner p (remove_member member)
      ) ;
      (* vote_for_proposal *)
      (* Requirements:
         - contract with a proposal and members must exist
         - only members which have not already voted can vote again *)
      (2, vote_proposal caddr (lc_contract_members_and_proposals_new_voters congress_state)
                        call vote_for_proposal ) ;
      (* vote_against_proposal *)
      (2, vote_proposal caddr (lc_contract_members_and_proposals_new_voters congress_state)
                        call vote_against_proposal ) ;
      (* retract_vote *)
      (2, vote_proposal caddr (lc_contract_members_and_proposals_with_votes congress_state)
                        call retract_vote) ;
      (* finish_proposal *)
      (* Requirements:
         - only contract owner can finish proposals
         - the debating period must have passed *)
      (2, '(pid, _) <- sampleFMapOpt (finishable_proposals congress_state env.(current_slot)) ;;
          p <- validate_addr owner ;;
          call caddr owner p (finish_proposal pid)
      )
    ]
  | S fuel' => backtrack [
    (3, GCongressAction env fuel' caddr) ;
    (* add_proposal *)
    (1,
      (* recurse. Msg is converted to a SerializedType using 'serialize' *)
      (* This makes it possible to create proposals about proposals about proposals etc... *)
      (* Note: currently we don't support having multiple actions in a proposal *)
      (* Note: the way we recurse may be too restrictive - we fix a caddr, which may cause gCongressMember
               to return None even though it could have succeeded for another caddr.
               Maybe this is not a big issue, though. *)
      act <- GCongressAction env fuel' caddr ;;
      let caller_addr := act.(act_from) in
      match act.(act_body) with
      | act_call caddr amount msg =>
        member <- elems_opt members ;;
        let ca := cact_call caddr amount msg in
        p <- validate_addr member ;;
        call caddr member p (create_proposal [ca])
      | _ => returnGenSome act
      end)
  ]
  end.


Require Export Basics.

Require Export EnvListAux7.
Require Export EnvListAuxT1.

Require Export Coq.Program.Equality.
Require Import Coq.Init.Specif.
Require Import Coq.Arith.PeanoNat.
Require Import Omega.
Require Import Coq.Lists.List.

Require Import TPipStaticM2.
Require Import TPipDynamicM2.
Require Import TRInductM2.
Require Import WeakM2.

Require Import TSoundnessRM2.
Require Import ReflectInterpM2.
Require Import IdModType.

Module SOS2Gall (IdT: IdModType) <: IdModType.
Export IdT.

Definition Id := IdT.Id.
Definition IdEqDec := IdT.IdEqDec.
Definition IdEq := IdT.IdEq.
Definition W := IdT.W.
Definition Loc_PI := IdT.Loc_PI.
Definition BInit := IdT.BInit.
Definition WP := IdT.WP.

Module ReflectC := Reflect IdT.
Export ReflectC.

Program Definition SOS_Exp
                   (fenv: funEnv) (env: valEnv)
                   (e: Exp) (t: VTyp) (n: W)
                   (k: SoundExp fenv env e t n) :
                              prod (vtypExt t) W := _.

Next Obligation.
  unfold SoundExp in k.
  destruct k.
  split.
  - inversion v; subst.
    subst T.
    rewrite H in H0.
    assert (projT1 x).
    exact (cstExt x).
    unfold vtypExt.
    rewrite <- H.
    exact X.
  - destruct s.
    exact x0.
Defined.

Program Definition SOS_Fun
        (f: Fun) (ft: FTyp) (n: W)
        (k0: FunTyping f ft)
        (env: valEnv)
        (k: SoundFun env (extParType ft) f (extRetType ft) n)
                   : prod (vtypExt (extRetType ft)) W := _.

Next Obligation.
  unfold SoundFun in k.
  destruct ft.
  (*simpl in m.*)
  simpl in k.
  simpl.
  destruct f.
  inversion k0; subst.
  specialize (k eq_refl).
  eapply SOS_Exp.
  exact k.
  specialize (k eq_refl).
  eapply SOS_Exp.
  exact k.
Defined.

Program Definition SOS_QFun
         (ftenv: funTC) (fenv: funEnv)
         (q: QFun) (ft: FTyp) (n: W)
         (k0: QFunTyping ftenv fenv q ft)
         (env: valEnv)
         (k: SoundQFun fenv env (extParType ft) q (extRetType ft) n)
              : prod (vtypExt (extRetType ft)) W := _.

Next Obligation.
  unfold SoundQFun in k.
  destruct k.
  specialize (q0 n).
  eapply SOS_Fun in s.
  exact s.
  inversion k0; subst.
  inversion q0; subst.
  exact X.
  inversion X0.
  inversion q0; subst.
  inversion X0; subst.
  inversion X; subst.
  assert (findE ls1 x0 = None).
  eapply ExRelValTNone in X3.
  exact X3.
  exact ft.
  exact H.
  inversion X1; subst.
  assert (findE (overrideE ls1 ((x0, f) :: ls3)) x0 =
                 findE ((x0, f) :: ls3) x0).
  rewrite overrideRedux2.
  auto.
  exact H0.
  unfold overrideE in H2.
  rewrite H2 in H1.
  simpl in H1.
  destruct (IdT.IdEqDec x0 x0) in H1.
  inversion H1; subst.
  exact X2.
  intuition n.
Defined.

Program Fixpoint SOS_Prms
                   (fenv: funEnv) (env: valEnv)
                   (ps: Prms) (pt: PTyp) (n: W)
                   (k: SoundPrms fenv env ps pt n) :
                              prod (PTyp_Trans pt) W := _.

Next Obligation.
  unfold SoundPrms in k.
  destruct k as [es m].
  split.
(**)
  - destruct m as [vs m1 k].
    destruct k as [m2 k].
    inversion m2; subst.
    unfold PTyp_Trans.
    revert m1.
    revert vs.
    revert k.
    revert ps.
    revert n.
    induction X.
    + simpl.
      intros.
      exact tt.
    + intros.
      destruct vs.
      inversion m1; subst.
      simpl in H.
      inversion H.
      destruct ps.
      destruct es.
      destruct k as [n2 k].
      inversion k; subst.
      inversion X0.
      inversion m2; subst.
      inversion X0; subst.

      assert (PrmsTyping emptyE emptyE emptyE (PS l) (PT l')).
      * constructor.
        exact X2.
      * specialize (IHX X3).
        inversion m1; subst.
        simpl in H.
        inversion H; subst.
        clear H.
        assert (isValueList2T (map Val vs) vs) as J1.
        constructor.
        auto.
        inversion X1; subst.

        eapply PrmsClos_aux1 in k.
        destruct k.
        destruct p.

        constructor.
        unfold VTyp_Trans.
        eapply (SOS_Exp fenv env e y n).
        unfold SoundExp.
        constructor 1 with (x:=v).
        exact H3.
        econstructor 1 with (x:=x).
        exact e0.

        specialize (IHX x (PS es) s vs J1).
        exact IHX.
  - destruct m.
    destruct p.
    destruct s.
    exact x0.
(*  Show Proof.
  Unshelve.
  exact fenv.
  exact env.
  exact n.
*)
Defined.

(*
Program Definition SOS_Exp (Z: Type) (PZ: PState Z)
                   (fenv: funEnv) (env: valEnv)
                   (e: Exp) (t: VTyp) (n: Z)
                   (k: SoundExp Z PZ fenv env e t n) (n: Z) :
                              prod (vtypExt t) Z := _.
*)
(*
Lemma InterEquivExp
         (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
         (e: Exp) (t: VTyp) (k0: ExpTyping ftenv tenv fenv e t)
         (k1: FEnvTyping fenv ftenv)
         (env: valEnv)
         (k2: EnvTyping env tenv) (n: W) :
         Exp_Trans ftenv tenv fenv e t k0 k1 env k2 n =
         SOS_Exp fenv env e t n
                 (ExpEval ftenv tenv fenv e t k0 k1 env k2 n).
Proof.
  unfold Exp_Trans.
  unfold SOS_Exp.
Admitted.

Lemma InterEquivPrms
         (ftenv: funTC) (tenv: valTC) (fenv: funEnv)
         (ps: Prms) (pt: PTyp) (k0: PrmsTyping ftenv tenv fenv ps pt)
         (k1: FEnvTyping fenv ftenv)
         (env: valEnv)
         (k2: EnvTyping env tenv) (n: W) :
         Prms_Trans ftenv tenv fenv ps pt k0 k1 env k2 n =
         SOS_Prms fenv env ps pt n
                 (PrmsEval ftenv tenv fenv ps pt k0 k1 env k2 n).
Proof.
Admitted.

Lemma InterEquivFun
         (f: Fun) (ft: FTyp) (k0: FunTyping f ft)
         (env: valEnv)
         (k1: EnvTyping env (extParType ft)) (n: W) :
         Fun_Trans f ft k0 (WT_valEnv_Trans (extParType ft) env k1) n =
         SOS_Fun f ft n k0 env (FunEval f ft k0 env k1 n).
Proof.
Admitted.

Lemma InterEquivQFun
         (ftenv: funTC) (fenv: funEnv)
         (q: QFun) (ft: FTyp)
         (k0: QFunTyping ftenv fenv q ft)
         (k1: FEnvTyping fenv ftenv)
         (env: valEnv)
         (k2: EnvTyping env (extParType ft)) (n: W) :
  QFun_Trans ftenv fenv q ft k0 k1
             (WT_valEnv_Trans (extParType ft) env k2) n =
         SOS_QFun ftenv fenv q ft n k0 env
                          (QFunEval ftenv fenv q ft k0 k1 env k2 n).
Proof.
Admitted.

*)

(*************************************************************************)
(*** superseded ******************)

Definition SoundFunB
         (f: Fun) (ft: FTyp)
         (k: FunTyping f ft)
         (env: valEnv)
         (m: EnvTyping env (extParType ft)) (n: W) :=
  SoundFun env (extParType ft) f (extRetType ft) n.

Program Definition SOS_FunB
        (f: Fun) (ft: FTyp) (n: W)
        (k0: FunTyping f ft)
        (env: valEnv)
        (m: EnvTyping env (extParType ft))
        (k: SoundFunB f ft k0 env m n)
                   : prod (vtypExt (extRetType ft)) W := _.

Next Obligation.
  unfold SoundFunB in k.
  destruct ft.
  simpl in m.
  simpl in k.
  simpl.
  unfold SoundFun in k.
  destruct f.
  inversion k0; subst.
  specialize (k eq_refl).
  eapply SOS_Exp.
  exact k.
  specialize (k eq_refl).
  eapply SOS_Exp.
  exact k.
Defined.

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

Definition SoundFunC
         (f: Fun) (ft: FTyp) (n: W)
         (k: FunTyping f ft)
         (env: valEnv) :=
         (* EnvTyping env (extParType ft) -> *)
  SoundFun env (extParType ft) f (extRetType ft) n.

Definition SoundQFunC
         (ftenv: funTC) (fenv: funEnv)
         (q: QFun) (ft: FTyp) (n: W)
         (k: QFunTyping ftenv fenv q ft)
         (env: valEnv) :=
(*         EnvTyping env (extParType ft) ->  *)
  SoundQFun fenv env (extParType ft) q (extRetType ft) n.

End SOS2Gall.


From Coq Require Import ZArith List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun.
From BitBlasting Require Import QFBV CNF BBCommon.
From ssrlib Require Import ZAriths Seqs Tactics.
From nbits Require Import NBits.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* auxiliary lemmas *)

Lemma enc_bits_take E n ls bs :
  enc_bits E ls bs -> enc_bits E (take n ls) (take n bs) .
Proof .
  move => Hlsbs .
  move : (enc_bits_size Hlsbs) => Hsize .
  move : ls bs Hsize Hlsbs n .
  apply : seq_ind2 => [|ls_hd bs_hd ls_tl bs_tl Hsize IH] .
  - by rewrite /= .
  - rewrite enc_bits_cons => /andP [Hlsbshd Hlsbstl] .
    case => [| n ] .
    + by rewrite /= .
    + by rewrite /= enc_bits_cons Hlsbshd (IH Hlsbstl n) .
Qed .

Lemma newer_than_lits_take g n ls :
  newer_than_lits g ls -> newer_than_lits g (take n ls) .
Proof .
  elim : ls n => [| ls_hd ls_tl IH] n .
  - by rewrite /= .
  - rewrite newer_than_lits_cons => /andP [Hlshd Hlstl] .
    case : n => [|n]; first by rewrite /= .
    by rewrite /= Hlshd (IH n Hlstl) .
Qed .

(* ===== bit_blast_low ===== *)

Definition bit_blast_low g n ls : generator * cnf * word :=
  (g, [::], take n ls ++ copy (n - size ls) lit_ff) .

Definition mk_env_low E g n ls : env * generator * cnf * word :=
  (E, g, [::], take n ls ++ copy (n - size ls) lit_ff) .

Lemma bit_blast_low_correct E g n bs ls g' cs lr :
  bit_blast_low g n ls = (g', cs, lr) ->
  enc_bits E ls bs ->
  interp_cnf E (add_prelude cs) ->
  enc_bits E lr (low n bs) .
Proof .
  rewrite /bit_blast_low /low /zeros .
  case => _ _ <- Hlsbs Hcnf .
  rewrite enc_bits_cat /=; first done .
  - exact : enc_bits_take .
  - rewrite /b0 (enc_bits_size Hlsbs) .
    move : (add_prelude_enc_bit_ff Hcnf) .
    exact : enc_bits_copy .
Qed .

Lemma mk_env_low_is_bit_blast_low E g n ls E' g' cs lr :
  mk_env_low E g n ls = (E', g', cs, lr) -> bit_blast_low g n ls = (g', cs, lr) .
Proof .
  rewrite /mk_env_low /bit_blast_low .
  by case => _ <- <- <- .
Qed .

Lemma mk_env_low_newer_gen E g n ls E' g' cs lr :
  mk_env_low E g n ls = (E', g', cs, lr) -> (g <=? g')%positive.
Proof .
  rewrite /mk_env_low .
  t_auto_newer .
Qed .

Lemma mk_env_low_newer_res E g n ls E' g' cs lrs :
  mk_env_low E g n ls = (E', g', cs, lrs) ->
  newer_than_lit g lit_tt -> newer_than_lits g ls ->
  newer_than_lits g' lrs .
Proof .
  rewrite /mk_env_low .
  case => _ <- _ <- Htt Hls .
  rewrite newer_than_lits_cat .
  apply /andP; split .
  - exact : newer_than_lits_take .
  - exact : newer_than_lits_copy .
Qed .

Lemma mk_env_low_newer_cnf E g n ls E' g' cs lrs :
  mk_env_low E g n ls = (E', g', cs, lrs) ->
  newer_than_lit g lit_tt -> newer_than_lits g ls ->
  newer_than_cnf g' cs .
Proof .
  rewrite /mk_env_low .
  by case => _ <- <- _ .
Qed .

Lemma mk_env_low_preserve E g n ls E' g' cs lrs :
  mk_env_low E g n ls = (E', g', cs, lrs) -> env_preserve E E' g .
Proof .
  by rewrite /mk_env_low; case => <- _ _ _ .
Qed .

Lemma mk_env_low_sat E g n ls E' g' cs lrs :
  mk_env_low E g n ls = (E', g', cs, lrs) ->
  newer_than_lits g ls -> interp_cnf E' cs .
Proof .
  by rewrite /mk_env_low; case => <- _ <- _ .
Qed .

Lemma mk_env_low_env_equal E1 E2 g n ls E1' E2' g1 g2 cs1 cs2 lrs1 lrs2 :
  env_equal E1 E2 ->
  mk_env_low E1 g n ls = (E1', g1, cs1, lrs1) ->
  mk_env_low E2 g n ls = (E2', g2, cs2, lrs2) ->
  env_equal E1' E2' /\ g1 = g2 /\ cs1 = cs2 /\ lrs1 = lrs2.
Proof.
  rewrite /mk_env_low => Heq.
  case=> ? ? ? ?; case=> ? ? ? ?; subst. done.
Qed.