Require Import RamifyCoq.lib.Coqlib.
Require Import RamifyCoq.sample_mark.env_mark_bi.
Require Import RamifyCoq.graph.graph_model.
Require Import RamifyCoq.graph.weak_mark_lemmas.
Require Import RamifyCoq.graph.path_lemmas.
Require Import RamifyCoq.graph.subgraph2.
Require Import RamifyCoq.graph.reachable_computable.
Require Import RamifyCoq.msl_application.Graph.
Require Import RamifyCoq.msl_application.Graph_Mark.
Require Import RamifyCoq.msl_application.GraphBi.
Require Import RamifyCoq.msl_application.GraphBi_Mark.
Require Import RamifyCoq.floyd_ext.share.
Require Import RamifyCoq.sample_mark.spatial_graph_bi_mark.
Require Import VST.msl.wand_frame.
Require Import VST.floyd.reassoc_seq.
Require Import VST.floyd.field_at_wand.

Local Coercion Graph_LGraph: Graph >-> LGraph.
Local Coercion LGraph_SGraph: LGraph >-> SGraph.
Local Identity Coercion Graph_GeneralGraph: Graph >-> GeneralGraph.
Local Identity Coercion LGraph_LabeledGraph: LGraph >-> LabeledGraph.
Local Identity Coercion SGraph_PointwiseGraph: SGraph >-> PointwiseGraph.
Local Coercion pg_lg: LabeledGraph >-> PreGraph.

Notation graph sh x g := (@reachable_vertices_at _ _ _ _ _ _ _ _ _ _ (@SGP pSGG_VST bool unit (sSGG_VST sh)) _ x g).
Notation Graph := (@Graph pSGG_VST bool unit unit).
Existing Instances MGS biGraph maGraph finGraph RGF.

Definition mark_spec :=
 DECLARE _mark
  WITH sh: wshare, g: Graph, x: pointer_val
  PRE [ _x OF (tptr (Tstruct _Node noattr))]
          PROP  (weak_valid g x)
          LOCAL (temp _x (pointer_val_val x))
          SEP   (graph sh x g)
  POST [ Tvoid ]
        EX g': Graph,
        PROP (mark x g g')
        LOCAL ()
        SEP   (graph sh x g').

Definition main_spec :=
 DECLARE _main
  WITH gv : globals
  PRE  [] main_pre prog nil gv
  POST [ tint ] main_post prog nil gv.

Definition Gprog : funspecs := ltac:(with_library prog [mark_spec ; main_spec]).

Lemma graph_local_facts: forall sh x (g: Graph), weak_valid g x -> @derives mpred Nveric (graph sh x g) (valid_pointer (pointer_val_val x)).
Proof.
  intros. destruct H.
  - simpl in H. subst x. entailer!.
  - eapply derives_trans; [apply (@va_reachable_root_stable_ramify pSGG_VST _ _ _ (sSGG_VST sh) g x (vgamma g x)); auto |].
    simpl vertex_at. entailer!.
Qed.

Opaque pSGG_VST sSGG_VST.

Lemma body_mark: semax_body Vprog Gprog f_mark mark_spec.
Proof.
  start_function.
  remember (vgamma g x) as dlr eqn:?H.
  destruct dlr as [[d l] r].
  rename H0 into H_GAMMA_g; symmetry in H_GAMMA_g.
  rename H into H_weak_valid.

  forward_if  (* if (x == 0) *)
    (PROP  (pointer_val_val x <> nullval)
     LOCAL (temp _x (pointer_val_val x))
     SEP   (graph sh x g)).
  - apply denote_tc_test_eq_split. 2: entailer!. apply graph_local_facts; auto.
  - forward. (* return *)
    Exists g. entailer!. destruct x. 1: simpl in H; inversion H. apply (mark_null_refl g).
  - forward. (* skip *) entailer!.
  - Intros. assert (vvalid g x) as gx_vvalid. {
      destruct H_weak_valid; [| auto].
      unfold is_null_SGBA in H0; simpl in H0; subst x.
      exfalso. apply H. auto.
    } assert (isptr (pointer_val_val x) /\ exists b i, x = ValidPointer b i). {
      destruct x. 2: exfalso; apply H; reflexivity. split; simpl; auto.
      exists b, i. reflexivity.
    } destruct H0 as [? [b [i ?]]]. clear H0 H_weak_valid.
    (* root_mark = x -> m; *)
    localize [data_at sh node_type (Vint (Int.repr (if d then 1 else 0)), (pointer_val_val l, pointer_val_val r)) (pointer_val_val x)].
    forward.
    unlocalize [graph sh x g].
    1: apply (@root_stable_ramify _ (sSGG_VST sh) g x _ H_GAMMA_g); auto.
    (* if (root_mark == 1) *)
    forward_if
      (PROP (d = false)
       LOCAL (temp _x (pointer_val_val x))
       SEP (graph sh x g)).
    + (* return *)
      forward. Exists g. entailer!.
      eapply (mark_vgamma_true_refl g); eauto.
      clear - H0; destruct d; [auto | inversion H0].
    + (* skip *)
      forward. entailer!. clear - H0; destruct d; congruence.
    + Intros. subst d.
      (* l = x -> l; *)
      localize [data_at sh node_type (Vint (Int.repr 0), (pointer_val_val l, pointer_val_val r)) (pointer_val_val x)].
      forward. 1: entailer!; destruct l; simpl; auto.
      forward. 1: entailer!; destruct r; simpl; auto.
      forward.
      unlocalize [graph sh x (Graph_vgen g x true)].
      1: apply (@root_update_ramify _ (sSGG_VST sh) g x _ (false, l, r) (true, l, r)); auto; eapply Graph_vgen_vgamma; eauto.
      pose proof Graph_vgen_true_mark1 g x _ _ H_GAMMA_g gx_vvalid.
      forget (Graph_vgen g x true) as g1.
      assert (weak_valid g1 l) by (eapply left_weak_valid; eauto).
      (* mark (l); *)
      localize [graph sh l g1].
      forward_call (sh, g1, l).
      Intros g2.
      unlocalize [graph sh x g2] using g2 assuming H3.
      1: subst; eapply (@graph_ramify_left _ (sSGG_VST sh) g); eauto.
      assert (weak_valid g2 r) by (eapply right_weak_valid; eauto).
      (* mark (r); *)
      localize [graph sh r g2].
      forward_call (sh, g2, r).
      Intros g3.
      unlocalize [graph sh x g3] using g3 assuming H5.
      1: subst; eapply (@graph_ramify_right _ (sSGG_VST sh) g); eauto.
      (* return; *)
      forward.
      Exists g3. entailer!.
      apply (mark1_mark_left_mark_right g g1 g2 g3 (ValidPointer b i) l r); auto.
Qed. (* original: 358 secs; VST 2.*: 4.772 secs *)

(* Print Assumptions body_mark. *)


Set Implicit Arguments.
Require Import Prelude.
Require Import Infrastructure.
Require Import Regularity.
Require Import Regularity2.
Require Import SubstMatch.
Require Import Equations.
Require Import TLC.LibLN.

#[export] Hint Resolve okt_is_ok.

Lemma typing_weakening_delta_eq:
  forall (u : trm) (Σ : GADTEnv) (D1 D2 : list typctx_elem) (E : env bind) (U : typ) eq TT,
    {Σ, D1 |,| D2, E} ⊢(TT) u ∈ U ->
    {Σ, D1 |,| [tc_eq eq]* |,| D2, E} ⊢(TT) u ∈ U.
Proof.
  introv Typ; gen_eq D': (D1 |,| D2); gen D2.
  induction Typ; introv EQ; subst;
    try solve [
          econstructor; fresh_intros; eauto
        | econstructor; eauto using okt_weakening_delta_eq; eauto using wft_weaken
        ].
  - apply_fresh typing_tabs as Y; auto.
    lets* IH: H1 Y (D2 |,| [tc_var Y]*).
  - econstructor; eauto.
    introv In Alen Adist Afr xfr xAfr.

    lets* IH: H4 In xAfr (D2 |,| tc_vars Alphas |,|
                          equations_from_lists Ts (List.map (open_tt_many_var Alphas) (Crettypes def))).
    repeat rewrite List.app_assoc in *.
    apply~ IH.
  - econstructor; eauto.
    + destruct eq. apply~ equation_weaken_eq.
    + apply~ wft_weaken.
Qed.

Lemma typing_weakening_delta:
  forall (u : trm) (Σ : GADTEnv) (D1 D2 : list typctx_elem) (E : env bind) (U : typ) (Y : var) TT,
    {Σ, D1 |,| D2, E} ⊢(TT) u ∈ U ->
    Y # E ->
    Y \notin domΔ D1 ->
    Y \notin domΔ D2 ->
    Y \notin fv_delta D2 ->
    {Σ, D1 |,| [tc_var Y]* |,| D2, E} ⊢(TT) u ∈ U.
Proof.
  introv Typ FE FD1 FD2 FrD; gen_eq D': (D1 |,| D2); gen D2.
  lets Typ2: Typ.
  induction Typ; introv FD2 FrD EQ; subst;
    try solve [
          econstructor; fresh_intros; eauto
        | econstructor; eauto using okt_weakening_delta; eauto using wft_weaken
        ].
  - econstructor; auto;
    try let envvars := gather_vars in
    instantiate (1:=envvars); auto.
    intros.
    lets* IH: H1 X (D2 |,| [tc_var X]*).
    repeat rewrite <- List.app_assoc in *.
    apply IH; auto.
    rewrite notin_domΔ_eq. split; auto.
    cbn. rewrite notin_union.
    split; auto.
  - econstructor; eauto.
    introv Hin.
    try let envvars := gather_vars in
    introv Hlen Hdist Afresh xfreshL xfreshA;
      instantiate (1:=envvars) in xfreshL.
    lets IH: H4 Hin Hlen (D2 |,| tc_vars Alphas |,| equations_from_lists Ts (List.map (open_tt_many_var Alphas) (Crettypes def))); eauto.
    + introv Ain. lets*: Afresh Ain.
    + eauto.
    + apply~ H3.
      introv Ain. lets*: Afresh Ain.
    + repeat rewrite List.app_assoc in *.
      apply IH; auto.
      rewrite notin_domΔ_eq; split; auto.
      * rewrite notin_domΔ_eq; split; auto.
        -- apply notin_dom_tc_vars.
           intro HF.
           lets HF2: from_list_spec HF.
           lets HF3: LibList_mem HF2.
           lets HF4: Afresh HF3.
           eapply notin_same.
           instantiate (1:=Y).
           eauto.
        -- rewrite equations_have_no_dom; auto.
           apply* equations_from_lists_are_equations.
      * repeat rewrite fv_delta_app.
        repeat rewrite notin_union.
        splits~.
        -- rewrite~ fv_delta_alphas.
        -- lets [? [? WFT]]: typing_regular Typ.
           lets FV: wft_gives_fv WFT.
           cbn in FV.
           apply fv_delta_equations.
           ++ intros T Tin.
              intro HF.
              lets FV2: fold_left_subset fv_typ Tin.
              lets FV3: subset_transitive FV2 FV.
              lets FV4: FV3 HF.
              rewrite domDelta_app in FV4.
              rewrite in_union in FV4.
              destruct FV4; auto.
           ++ intros R Rin.
              assert (OKS: okGadt Σ).
              ** apply~ okt_implies_okgadt.
                 apply* typing_regular.
              ** apply List.in_map_iff in Rin.
                 destruct Rin as [rT [? rTin]]; subst.
                 lets Sub: fv_smaller_many Alphas rT.
                 intro HF.
                 lets HF2: Sub HF.
                 rewrite in_union in HF2.
                 destruct HF2 as [HF2 | HF2].
                 ---
                   destruct OKS as [? OKS].
                   lets [? OKD]: OKS H0.
                   lets Din: fst_from_zip Hin.
                   lets OKC: OKD Din.
                   inversion OKC as [? ? ? ? ? ? ? ? ? FrR]; subst.
                   cbn in rTin.
                   lets FR: FrR rTin.
                   rewrite FR in HF2.
                   false* in_empty_inv.
                 ---
                   lets [A [Ain ?]]: in_from_list HF2; subst.
                   lets: Afresh Ain.
                   assert (A \notin \{ A}); auto.
                   false* notin_same.
  - econstructor.
    + apply~ IHTyp.
    + apply~ equation_weaken_var.
    + apply wft_weaken.
      lets~ [? [? ?]]: typing_regular Typ2.
Qed.

Lemma typing_weakening_delta_many_eq : forall Σ Δ E Deqs u U TT,
    {Σ, Δ, E} ⊢(TT) u ∈ U ->
    (forall eq, List.In eq Deqs -> exists ϵ, eq = tc_eq ϵ) ->
    {Σ, Δ |,| Deqs, E} ⊢(TT) u ∈ U.
Proof.
  induction Deqs; introv Typ EQs.
  - clean_empty_Δ. auto.
  - destruct a;
      try solve [lets HF: EQs (tc_var A); false~ HF].
    fold_delta.
    rewrite <- List.app_assoc.
    lets W: typing_weakening_delta_eq Σ (Δ |,| Deqs) emptyΔ.
    clean_empty_Δ.
    rewrite <- (List.app_nil_l ((Δ |,| Deqs) |,| [tc_eq eq]*)).
    apply~ W.
    apply~ IHDeqs.
    intros eq1 ?. lets Hin: EQs eq1.
    destruct Hin; eauto.
    cbn. auto.
Qed.

Lemma typing_weakening_delta_many : forall Σ Δ E As u U TT,
    (forall A, List.In A As -> A # E) ->
    (forall A, List.In A As -> A \notin domΔ Δ) ->
    DistinctList As ->
    {Σ, Δ, E} ⊢(TT) u ∈ U ->
    {Σ, Δ |,| tc_vars As, E} ⊢(TT) u ∈ U.
  induction As as [| Ah Ats]; introv AE AD Adist Typ.
Proof.
  - cbn. clean_empty_Δ. auto.
  - cbn. fold_delta.
    inversions Adist.
    rewrite <- (List.app_nil_l ((Δ |,| tc_vars Ats) |,| [tc_var Ah]*)).
    apply typing_weakening_delta; cbn; auto with listin.
    rewrite notin_domΔ_eq. split.
    + auto with listin.
    + apply notin_dom_tc_vars.
      intro HF.
      apply from_list_spec in HF.
      apply LibList_mem in HF.
      auto.
Qed.

Lemma typing_weakening : forall Σ Δ E F G e T TT,
    {Σ, Δ, E & G} ⊢(TT) e ∈ T ->
    okt Σ Δ (E & F & G) ->
    {Σ, Δ, E & F & G} ⊢(TT) e ∈ T.
Proof.
  introv HTyp. gen_eq K: (E & G). gen G F.
  induction HTyp using typing_ind; introv EQ Ok; subst; eauto.
  - apply* typing_var. apply* binds_weaken.
  - econstructor; eauto.
    let env := gather_vars in
    instantiate (2:=env).
    introv xfresh.
    lets IH: H0 x (G & x ~l V) F; auto.
    rewrite <- concat_assoc.
    apply IH.
    + auto using concat_assoc.
    + rewrite concat_assoc.
      econstructor; eauto.
      assert (xL: x \notin L); auto.
      lets Typ: H xL.
      lets [? [? ?]]: typing_regular Typ.
      eapply okt_is_wft. eauto.
  - apply_fresh* typing_tabs as X.
    lets IH: H1 X G F; auto.
    apply IH.
    + auto using JMeq_from_eq.
    + rewrite <- (List.app_nil_l (Δ |,| [tc_var X]*)).
      apply okt_weakening_delta; clean_empty_Δ; cbn; auto.
  - apply_fresh* typing_fix as x.
    lets IH: H1 x (G & x ~f T) F; auto.
    rewrite <- concat_assoc.
    apply IH; repeat rewrite concat_assoc; auto.
    constructor; auto.
    lets [? [? ?]]: typing_regular T; eauto.
  - apply_fresh* typing_let as x.
    lets IH: H0 x (G & x ~l V) F; auto.
    rewrite <- concat_assoc.
    apply IH; repeat rewrite concat_assoc; auto.
    constructor; auto.
    lets [? [? ?]]: typing_regular V; eauto.
  - eapply typing_case; eauto.
    introv Inzip.
    let envvars := gather_vars in
    (introv AlphasArity ADistinct Afresh xfresh xfreshA;
     instantiate (1:=envvars) in Afresh).
    assert (AfreshL: forall A : var, List.In A Alphas -> A \notin L);
      [ introv Ain; lets*: Afresh Ain | idtac ].
    assert (xfreshL: x \notin L); eauto.
    lets* IH1: H4 Inzip Alphas x AlphasArity ADistinct.
    lets* IH2: IH1 AfreshL xfreshL xfreshA (G & x ~l open_tt_many_var Alphas (Cargtype def)) F.
    repeat rewrite concat_assoc in IH2.
    apply~ IH2.

    constructor; auto.
    + rewrite <- (List.app_nil_l (Δ |,| tc_vars Alphas |,| equations_from_lists Ts (List.map (open_tt_many_var Alphas) (Crettypes def)))).
      apply okt_weakening_delta_many_eq.
      * apply okt_weakening_delta_many; clean_empty_Δ;
          try solve [introv Ain; cbn; lets: Afresh Ain; auto]; auto.
      * apply* equations_from_lists_are_equations.
    + assert (OKS: okGadt Σ).
      * apply~ okt_implies_okgadt.
        apply* typing_regular.
      * destruct OKS as [? OKS].
        lets [? OKD]: OKS H0.
        lets Din: fst_from_zip Inzip.
        lets OKC: OKD Din.
        inversion OKC as [? ? ? ? ? ? Harg ? ? ?]; subst.
        cbn.
        apply wft_weaken_simple.
        apply~ Harg.
    + repeat rewrite notin_domΔ_eq.
      split~.
      * split~.
        apply notin_dom_tc_vars. auto.
      * rewrite equations_have_no_dom; eauto using equations_from_lists_are_equations.
Qed.

Lemma typing_through_subst_ee_lam : forall Σ Δ E F x u U e T TT1 TT2,
    {Σ, Δ, E & (x ~l U) & F} ⊢(TT1) e ∈ T ->
    {Σ, Δ, E} ⊢(TT2) u ∈ U ->
    value u ->
    {Σ, Δ, E & F} ⊢(Tgen) subst_ee x lam_var u e ∈ T.
Proof.
  Ltac apply_ih :=
    match goal with
    | H: forall X, X \notin ?L -> forall E0 F0 x0 vk0 U0, ?P1 -> ?P2 |- _ =>
      apply_ih_bind* H end.
  introv TypT TypU ValU.
  inductions TypT; introv; cbn;
    try solve [eapply Tgen_from_any; eauto using okt_strengthen];
    lets [okU [termU wftU]]: typing_regular TypU.
  - match goal with
    | [ H: okt ?A ?B ?C |- _ ] =>
      lets: okt_strengthen H
    end.
    case_if~.
    + eapply Tgen_from_any.
      inversions C.
      binds_get H; eauto.
      assert (E & F & empty = E & F) as HEF by apply concat_empty_r.
      rewrite <- HEF.
      apply typing_weakening; rewrite concat_empty_r; eauto.
    + eapply Tgen_from_any. binds_cases H; apply* typing_var.
      match goal with
      | [H: bind_var ?vk ?T = bind_var ?vk2 ?U |- _] =>
        inversion* H
      end.
  - eapply Tgen_from_any.
    apply_fresh* typing_abs as y.
    rewrite* subst_ee_open_ee_var.
    apply_ih.
  - eapply Tgen_from_any.
    apply_fresh* typing_tabs as Y; rewrite* subst_ee_open_te_var.
    match goal with
    | [ H: forall X, X \notin ?L -> forall E0 F0 x0 vk0 U0, ?P1 -> ?P2 |- _ ] =>
      apply* H
    end.
    rewrite <- (List.app_nil_l (Δ |,| [tc_var Y]*)).
    apply typing_weakening_delta; clean_empty_Δ; cbn; auto.
  - eapply Tgen_from_any.
    apply_fresh* typing_fix as y; rewrite* subst_ee_open_ee_var.
    apply_ih.
  - eapply Tgen_from_any.
    apply_fresh* typing_let as y.
    rewrite* subst_ee_open_ee_var.
    apply_ih.
  - eapply Tgen_from_any.
    econstructor; eauto.
    + unfold map_clause_trm_trm.
      rewrite* List.map_length.
    + introv inzip.
      lets* [i [Hdefs Hmapped]]: Inzip_to_nth_error inzip.
      lets* [[clA' clT'] [Hclin Hclsubst]]: nth_error_map Hmapped.
      destruct clause as [clA clT]. cbn.
      inversions Hclsubst.
      lets* Hzip: Inzip_from_nth_error Hdefs Hclin.
      lets*: H2 Hzip.
    + introv inzip.
      let env := gather_vars in
      intros Alphas xClause Alen Adist Afresh xfresh xfreshA;
        instantiate (1:=env) in xfresh.
      lets* [i [Hdefs Hmapped]]: Inzip_to_nth_error inzip.
      lets* [[clA' clT'] [Hclin Hclsubst]]: nth_error_map Hmapped.
      destruct clause as [clA clT]. cbn.
      inversions Hclsubst.
      lets* Hzip: Inzip_from_nth_error Hdefs Hclin.
      lets* IH: H4 Hzip.

      assert (Htypfin: {Σ, Δ |,| tc_vars Alphas |,| equations_from_lists Ts (List.map (open_tt_many_var Alphas) (Crettypes def)),
                        E & F & xClause ~l (open_tt_many_var Alphas (Cargtype def))}
                ⊢(Tgen) subst_ee x lam_var u (open_te_many_var Alphas clT' open_ee_varlam xClause) ∈ Tc).
      * assert (AfreshL: forall A : var, List.In A Alphas -> A \notin L);
          [ introv Ain; lets*: Afresh Ain | idtac ].
        assert (xfreshL: xClause \notin L); eauto.
        lets Htmp: IH Alphas xClause Alen Adist AfreshL.
        lets Htmp2: Htmp xfreshL xfreshA.
        lets Htmp3: Htmp2 E (F & xClause ~l (open_tt_many_var Alphas (Cargtype def))) x U.
        cbn in Htmp3.
        rewrite <- concat_assoc.
        apply* Htmp3.
        apply JMeq_from_eq.
        eauto using concat_assoc.
        apply typing_weakening_delta_many_eq;
          eauto using equations_from_lists_are_equations.
        apply typing_weakening_delta_many; auto;
          try introv Ain; lets: Afresh Ain; auto.
      * assert (Horder:
                  subst_ee x lam_var u (open_te_many_var Alphas clT' open_ee_varlam xClause)
                  =
                  open_te_many_var Alphas (subst_ee x lam_var u clT') open_ee_varlam xClause).
        -- rewrite* <- subst_ee_open_ee_var.
           f_equal.
           apply* subst_commutes_with_unrelated_opens_te_ee.
        -- rewrite* <- Horder.
               Qed.

Lemma typing_through_subst_ee_fix : forall Σ Δ E F x u U e T TT1 TT2,
    {Σ, Δ, E & (x ~f U) & F} ⊢(TT1) e ∈ T ->
    {Σ, Δ, E} ⊢(TT2) u ∈ U ->
    {Σ, Δ, E & F} ⊢(Tgen) subst_ee x fix_var u e ∈ T.
Proof.
  introv TypT TypU.
  inductions TypT; introv; cbn;
    try solve [eapply Tgen_from_any; eauto using okt_strengthen];
    lets [okU [termU wftU]]: typing_regular TypU.
  - match goal with
    | [ H: okt ?A ?B ?C |- _ ] =>
      lets: okt_strengthen H
    end.
    case_if~.
    + inversions C.
      eapply Tgen_from_any. binds_get H; eauto.
      assert (E & F & empty = E & F) as HEF by apply concat_empty_r.
      rewrite <- HEF.
      apply typing_weakening; rewrite concat_empty_r; eauto.
    + eapply Tgen_from_any. binds_cases H; apply* typing_var.
      match goal with
      | [H: bind_var ?vk ?T = bind_var ?vk2 ?U |- _] =>
        inversion* H
      end.
  - eapply Tgen_from_any.
    apply_fresh* typing_abs as y.
    rewrite* subst_ee_open_ee_var.
    apply_ih.
  - eapply Tgen_from_any.
    apply_fresh* typing_tabs as Y; rewrite* subst_ee_open_te_var.
    + apply* subst_ee_fix_value.
    + match goal with
      | [ H: forall X, X \notin ?L -> forall E0 F0 x0 vk0 U0, ?P1 -> ?P2 |- _ ] =>
        apply* H
      end.
      rewrite <- (List.app_nil_l (Δ |,| [tc_var Y]* )).
      apply typing_weakening_delta; clean_empty_Δ; cbn; auto.
  - eapply Tgen_from_any.
    apply_fresh* typing_fix as y; rewrite* subst_ee_open_ee_var.
    + apply* subst_ee_fix_value.
    + apply_ih.
  - eapply Tgen_from_any.
    apply_fresh* typing_let as y.
    rewrite* subst_ee_open_ee_var.
    apply_ih.
  - eapply Tgen_from_any.
    econstructor; eauto.
    + unfold map_clause_trm_trm.
      rewrite* List.map_length.
    + introv inzip.
      lets* [i [Hdefs Hmapped]]: Inzip_to_nth_error inzip.
      lets* [[clA' clT'] [Hclin Hclsubst]]: nth_error_map Hmapped.
      destruct clause as [clA clT]. cbn.
      inversions Hclsubst.
      lets* Hzip: Inzip_from_nth_error Hdefs Hclin.
      lets*: H2 Hzip.
    + introv inzip.
      let env := gather_vars in
      intros Alphas xClause Alen Adist Afresh xfresh xfreshA;
        instantiate (1:=env) in xfresh.
      lets* [i [Hdefs Hmapped]]: Inzip_to_nth_error inzip.
      lets* [[clA' clT'] [Hclin Hclsubst]]: nth_error_map Hmapped.
      destruct clause as [clA clT]. cbn.
      inversions Hclsubst.
      lets* Hzip: Inzip_from_nth_error Hdefs Hclin.
      lets* IH: H4 Hzip.

      assert (Htypfin: {Σ, Δ |,| tc_vars Alphas |,| equations_from_lists Ts (List.map (open_tt_many_var Alphas) (Crettypes def)),
                        E & F & xClause ~l (open_tt_many_var Alphas (Cargtype def))}
                ⊢(Tgen) subst_ee x fix_var u (open_te_many_var Alphas clT' open_ee_varlam xClause) ∈ Tc).
      * assert (AfreshL: forall A : var, List.In A Alphas -> A \notin L);
          [ introv Ain; lets*: Afresh Ain | idtac ].
        assert (xfreshL: xClause \notin L); eauto.
        lets Htmp: IH Alphas xClause Alen Adist AfreshL.
        lets Htmp2: Htmp xfreshL xfreshA.
        lets Htmp3: Htmp2 E (F & xClause ~l (open_tt_many_var Alphas (Cargtype def))) x U.
        cbn in Htmp3.
        rewrite <- concat_assoc.
        apply* Htmp3.
        apply JMeq_from_eq.
        eauto using concat_assoc.
        apply typing_weakening_delta_many_eq;
          eauto using equations_from_lists_are_equations.
        apply typing_weakening_delta_many; auto;
          try introv Ain; lets: Afresh Ain; auto.
      * assert (Horder:
                  subst_ee x fix_var u (open_te_many_var Alphas clT' open_ee_varlam xClause)
                  =
                  open_te_many_var Alphas (subst_ee x fix_var u clT') open_ee_varlam xClause).
        -- rewrite* <- subst_ee_open_ee_var.
           f_equal.
           apply* subst_commutes_with_unrelated_opens_te_ee.
        -- rewrite* <- Horder.
Qed.

Lemma typing_through_subst_te_gen : forall Σ Δ1 Δ2 E Z e P T TT,
    {Σ, Δ1 |,| [tc_var Z]* |,| Δ2, E} ⊢(TT) e ∈ T ->
    wft Σ Δ1 P ->
    Z \notin fv_typ P ->
    Z \notin domΔ (Δ1 |,| Δ2) ->
    Z # E ->
    {Σ, Δ1 |,| List.map (subst_td Z P) Δ2, map (subst_tb Z P) E} ⊢(Tgen) subst_te Z P e ∈ subst_tt Z P T.
Proof.
  introv Typ.
  gen_eq G: (Δ1 |,| [tc_var Z]* |,| Δ2). gen Δ2.
  induction Typ; introv EQ WFT FVZP FVZD FVZE; subst; eapply Tgen_from_any;
    cbn; eauto.
  - constructor. apply~ okt_through_subst_tdtb.
  - cbn. econstructor.
    + fold (subst_tb Z P (bind_var vk T)).
      apply~ binds_map.
    + apply~ okt_through_subst_tdtb.
  - assert (OKS: okGadt Σ).
    1: {
      apply~ okt_implies_okgadt.
      apply* typing_regular.
    }
    destruct OKS as [? OKS].
    lets [? OKD]: OKS H.
    lets Din: List.nth_error_In H0.
    lets OKC: OKD Din.
    inversion OKC as [? ? ? ? ? ? Harg Hwft FVarg FVret]; subst.
    econstructor; auto.
    + apply H.
    + rewrite~ List.map_length.
      eauto.
    + rewrite~ subst_commutes_open_tt_many.
      * apply* type_from_wft.
      * rewrite~ FVarg.
    + intros T' Tin.
      apply List.in_map_iff in Tin.
      destruct Tin as [T [? Tin]]; subst.
      apply* wft_subst_tb_3.
    + rewrite~ subst_commutes_open_tt_many.
      * apply* type_from_wft.
      * cbn. fold (fv_typs CretTypes).
        apply~ notin_fold.
        intros TR Tin.
        rewrite~ FVret.
  - apply_fresh typing_abs as x.
    fold (subst_tb Z P (bind_var lam_var V)).
    rewrite <- map_push.
    rewrite subst_te_open_ee_var.
    apply~ H0.
  - lets: type_from_wft WFT.
    apply_fresh typing_tabs as X.
    + forwards~ : H X.
      rewrite~ subst_te_open_te_var.
    + forwards * IH : H1 X (Δ2 |,| [tc_var X]*).
      1: {
        fold_delta.
        repeat rewrite domDelta_app in *.
        repeat rewrite notin_union in *.
        destruct FVZD.
        repeat split~.
        cbn.
        rewrite notin_union; split~.
        apply* notin_inverse.
      }
      fold_delta.
      repeat rewrite List.app_assoc in *.
      rewrite~ subst_te_open_te_var.
      rewrite~ subst_tt_open_tt_var.
      apply* IH.
  - econstructor; auto.
    + apply* IHTyp.
    + apply* wft_subst_tb_3.
    + fold subst_tt.
      rewrite* subst_tt_open_tt.
  - apply_fresh typing_fix as x.
    + forwards~ : H x.
      rewrite subst_te_open_ee_var.
      apply~ subst_te_value.
      apply* type_from_wft.
    + fold (subst_tb Z P (bind_var fix_var T)).
      rewrite <- map_push.
      rewrite subst_te_open_ee_var.
      apply~ H1.
  - apply_fresh typing_let as x.
    + apply* IHTyp.
    + rewrite subst_te_open_ee_var.
      fold (subst_tb Z P (bind_var lam_var V)).
      rewrite <- map_push.
      apply~ H0.
  - econstructor; eauto.
    + cbn. eauto.
    + unfold map_clause_trm_trm.
      rewrite~ List.map_length.
    + introv Inzip.
      lets [clA [clT [In2 ?]]]: inzip_map_clause_trm Inzip; subst.
      lets: H2 In2.
      cbn in *. auto.
    + let FV := gather_vars in
      introv Inzip Len Dist FA Fx FxA;
        instantiate (1 := FV) in FA.
      lets [clA [clT [In2 ?]]]: inzip_map_clause_trm Inzip; subst.
      assert (OKS: okGadt Σ).
      1: {
        apply~ okt_implies_okgadt.
        apply* typing_regular.
      }
      destruct OKS as [? OKS].
      lets [? OKD]: OKS H0; clear OKS.
      lets Din: fst_from_zip In2.
      lets OKC: OKD Din.
      inversion OKC as [? ? ? ? ? ? Harg Hwft FVarg FVret]; subst.
      cbn in *.
      lets~ IH : H4 In2 x Len Dist (Δ2 |,| tc_vars Alphas
                                |,| equations_from_lists Ts
                                (List.map (open_tt_many_var Alphas) retTs)).
      * introv Ain. lets*: FA Ain.
      * cbn in *.
        forwards~ IH2: IH; clear IH.
        -- repeat rewrite~ List.app_assoc.
        -- repeat rewrite domDelta_app in *.
           repeat rewrite notin_union.
           repeat rewrite notin_union in FVZD.
           destruct FVZD.
           repeat split~.
           ++ apply notin_dom_tc_vars.
              apply~ notin_from_list.
              intro HF.
              lets HF2 : FA HF.
              repeat rewrite notin_union in HF2.
              assert (Z \notin \{ Z }).
              ** destruct~ HF2 as [? [[? ?] ?]].
              ** apply* notin_same.
           ++ rewrite~ equations_have_no_dom.
              apply* equations_from_lists_are_equations.
        -- assert (FVZA: forall X : var, List.In X Alphas -> X <> Z).
           1: {
             intros A Ain.
             intro HF.
             subst.
             lets FA2: FA Ain.
             repeat rewrite notin_union in FA2.
             destruct~ FA2 as [? [[?]]].
             apply* notin_same.
           }
           rewrite~ <- subst_commutes_with_unrelated_opens_te.
           ** rewrite subst_te_open_ee_var.
              rewrite List.map_app in IH2.
              rewrite List.map_app in IH2.
              rewrite subst_td_alphas in IH2.
              rewrite subst_td_eqs in IH2.
              --- rewrite map_concat in IH2.
                  rewrite map_single in IH2.
                  cbn in IH2.
                  assert (Hrew: subst_tt Z P (open_tt_many_var Alphas argT) = open_tt_many_var Alphas argT).
                  +++ rewrite~ subst_commutes_with_unrelated_opens.
                      *** f_equal. rewrite~ subst_tt_fresh.
                          rewrite~ FVarg.
                      *** apply* type_from_wft.
                  +++ rewrite Hrew in IH2; clear Hrew.
                      repeat rewrite List.app_assoc in *.
                      apply IH2.
              --- introv Uin.
                  apply List.in_map_iff in Uin.
                  destruct Uin as [V [EQ Vin]]; subst.
                  intro HF.
                  lets Sm: fv_smaller_many Alphas V.
                  apply Sm in HF.
                  rewrite in_union in HF.
                  destruct HF as [HF|HF].
                  +++ rewrite~ FVret in HF.
                      apply* in_empty_inv.
                  +++ apply from_list_spec in HF.
                      apply LibList_mem in HF.
                      lets: FVZA HF. false.
           ** apply* type_from_wft.
  - econstructor; eauto.
    + apply* entails_through_subst.
    + apply* wft_subst_tb_3.
Qed.

Lemma typing_through_subst_te_3 :
  forall Σ Δ E Z e P T TT,
    {Σ, Δ |,| [tc_var Z]*, E} ⊢(TT) e ∈ T ->
    wft Σ Δ P ->
    Z \notin fv_typ P ->
    Z # E ->
    Z \notin fv_env E ->
    Z \notin domΔ Δ ->
    {Σ, Δ, E} ⊢(Tgen) subst_te Z P e ∈ subst_tt Z P T.
Proof.
  introv Typ WFT ZP ZE1 ZE2 ZD.
  rewrite <- (List.app_nil_l (Δ |,| [tc_var Z]*)) in Typ.
  lets HT: typing_through_subst_te_gen Typ WFT ZP ZD ZE1.
  cbn in HT.
  rewrite~ subst_tb_id_on_fresh in HT.
Qed.

Lemma typing_through_subst_te_many : forall As Σ Δ Δ2 E F e T Ps TT,
    {Σ, (Δ |,| tc_vars As |,| Δ2), E & F} ⊢(TT) e ∈ T ->
    length As = length Ps ->
    (forall P, List.In P Ps -> wft Σ Δ P) ->
    (forall A, List.In A As -> A # E) ->
    (forall A, List.In A As -> A # F) ->
    (forall A, List.In A As -> A \notin domΔ Δ) ->
    (forall A, List.In A As -> A \notin domΔ Δ2) ->
    (forall A P, List.In A As -> List.In P Ps -> A \notin fv_typ P) ->
    (forall A, List.In A As -> A \notin fv_env E) ->
    DistinctList As ->
    {Σ, Δ |,| List.map (subst_td_many As Ps) Δ2, E & map (subst_tb_many As Ps) F} ⊢(Tgen) (subst_te_many As Ps e) ∈  subst_tt_many As Ps T.
Proof.
  induction As as [| Ah Ats]; introv Htyp Hlen Pwft AE AF AD AD2 AP AEE Adist;
    destruct Ps as [| Ph Pts]; try solve [cbn in *; congruence].
  - cbn. cbn in Htyp.
    rewrite List.map_id.
    rewrite map_def.
    rewrite <- LibList_map.
    rewrite <- map_id; eauto using Tgen_from_any.
    intros. destruct x as [? [?]].
    cbv. auto.
  - cbn.
    inversions Adist.
    lets IH0: IHAts Σ Δ (List.map (subst_td Ah Ph) Δ2) (map (subst_tb Ah Ph) E) (map (subst_tb Ah Ph) F).
    lets IH: IH0 (subst_te Ah Ph e) (subst_tt Ah Ph T) Pts; clear IH0.
    rewrite <- (@subst_tb_id_on_fresh E Ah Ph).
    rewrite subst_tb_many_split.
    rewrite List.map_map in IH.
    eapply IH; auto with listin.
    + clear IH IHAts.
      cbn in Htyp. fold_delta.
      lets HT: typing_through_subst_te_gen Ph Htyp.
      rewrite <- map_concat.
      apply HT; auto with listin.
      * assert (WFT: wft Σ Δ Ph); auto with listin.
        apply* wft_weaken_simple.
      * repeat rewrite domDelta_app.
        repeat rewrite notin_union.
        repeat split; auto with listin.
        apply notin_dom_tc_vars.
        intro HF.
        apply from_list_spec in HF.
        apply LibList_mem in HF.
        false~.
    + introv Ain.
      rewrite <- domDelta_subst_td; auto with listin.
    + introv Ain.
      apply~ fv_env_subst; auto with listin.
    + auto with listin.
Qed.

Ltac generalize_typings :=
  match goal with
  | [ H: {?Σ, ?D, ?E} ⊢(?TT) ?e ∈ ?T |- _ ] =>
    match TT with
    | Tgen => fail 1
    | Treg => fail 1
    | _ => apply Tgen_from_any in H;
           try clear TT
    end
  end.

Lemma typing_replace_typ_gen : forall Σ Δ E F x vk T1 TT e U T2,
    {Σ, Δ, E & x ~ bind_var vk T1 & F} ⊢( TT) e ∈ U ->
    wft Σ Δ T2 ->
    entails_semantic Σ Δ (T1 ≡ T2) ->
    {Σ, Δ, E & x ~ bind_var vk T2 & F} ⊢(Tgen) e ∈ U.
Proof.
  introv Typ.
  gen_eq K: (E & x ~ bind_var vk T1 & F). gen F x T1.
  induction Typ using typing_ind; introv EQ WFT Sem; subst; eauto;
    try solve [apply Tgen_from_any with Treg; eauto].
  - apply Tgen_from_any with Treg;
      econstructor. apply* okt_replace_typ.
  - destruct (classicT (x = x0)); subst.
    + lets: okt_is_ok H0.
      apply binds_middle_eq_inv in H; auto.
      inversions H.
      apply typing_eq with T2 Treg.
      * constructor.
        -- apply binds_concat_left.
           ++ apply binds_push_eq.
           ++ lets* [? ?]: ok_middle_inv H1.
        -- apply* okt_replace_typ.
      * apply~ teq_symmetry.
      * apply* okt_is_wft_2.
    + apply Tgen_from_any with Treg.
      constructor.
      * lets [? | [[? [? ?]] | [? [? ?]]]]: binds_middle_inv H; subst.
        -- apply~ binds_concat_right.
        -- false.
        -- apply~ binds_concat_left.
      * apply* okt_replace_typ.
  - apply Tgen_from_any with Treg.
    econstructor.
    introv xiL.
    lets IH: H0 xiL (F & x0 ~l V) x T0.
    repeat rewrite concat_assoc in IH.
    apply* IH.
  - apply Tgen_from_any with Treg.
    econstructor; eauto.
    introv xiL.
    lets IH: H1 xiL F x T0.
    repeat rewrite concat_assoc in IH.
    apply* IH.
    + apply~ wft_weaken_simple.
    + rewrite <- (List.app_nil_l (Δ |,| [tc_var X]*)).
      apply~ equation_weaken_var.
      cbn. auto.
  - apply Tgen_from_any with Treg.
    econstructor; eauto.
    introv xiL.
    lets IH: H1 xiL (F & x0 ~f T) x T1.
    repeat rewrite concat_assoc in IH.
    apply* IH.
  - apply Tgen_from_any with Treg.
    econstructor; eauto.
    introv xiL.
    lets IH: H0 xiL (F & x0 ~l V) x T1.
    repeat rewrite concat_assoc in IH.
    apply* IH.
  - apply Tgen_from_any with Treg.
    econstructor; eauto.
    introv In Alen Adist Afr xfr xAfr.
    lets Htmp: H4 In Alen Adist Afr xfr.
    lets IH: Htmp xAfr (F & x0 ~l open_tt_many_var Alphas (Cargtype def)) x T1. clear Htmp.
    repeat rewrite concat_assoc in IH.
    apply* IH.
    + repeat apply* wft_weaken_simple.
    + apply~ equations_weaken_match.
      rewrite List.map_length.
      lets [OKT [? WFT2]]: typing_regular Typ.
      inversions WFT2.
      lets OKS: okt_implies_okgadt OKT.
      inversion OKS as [? OKC].
      lets [? OKD]: OKC H0.
      lets indef: fst_from_zip In.
      lets OKE: OKD indef.
      inversions OKE.
      cbn.
      match goal with
      | [ H1: binds ?g ?A Σ, H2: binds ?g ?B Σ |- _ ] =>
        let H := fresh "H" in
        lets H: binds_ext H1 H2;
          inversions H
      end.
      auto.
Qed.

Lemma typing_replace_typ : forall Σ Δ E x vk T1 TT e U T2,
    {Σ, Δ, E & x ~ bind_var vk T1} ⊢( TT) e ∈ U ->
    entails_semantic Σ Δ (T1 ≡ T2) ->
    wft Σ Δ T2 ->
    {Σ, Δ, E & x ~ bind_var vk T2} ⊢( Tgen) e ∈ U.
Proof.
  intros.
  rewrite <- (concat_empty_r (E & x ~ bind_var vk T2)).
  apply* typing_replace_typ_gen.
  fold_env_empty.
Qed.

Lemma remove_true_equation : forall Σ Δ1 Δ2 E e TT T U1 U2,
    {Σ, Δ1 |,| [tc_eq (U1 ≡ U2)]* |,| Δ2, E} ⊢(TT) e ∈ T ->
    entails_semantic Σ Δ1 (U1 ≡ U2) ->
    {Σ, Δ1 |,| Δ2, E} ⊢(TT) e ∈ T.
Proof.
  introv Typ.
  gen_eq D3: (Δ1 |,| [tc_eq (U1 ≡ U2)]* |,| Δ2). gen Δ1 Δ2.
  lets: okt_strengthen_delta_eq.
  lets: wft_strengthen_equation.
  induction Typ using typing_ind; introv EQ Sem; subst; eauto.
  - econstructor; eauto.
    introv XFr.
    lets IH: H3 XFr Δ1 (Δ2 |,| [tc_var X]*).
    apply* IH.
  - econstructor; eauto.
    introv clin Hlen Hdist Afresh xfresh xfreshA.
    lets Htmp: H6 clin Hlen Hdist Afresh xfresh.
    lets IH: Htmp xfreshA Δ1
                  (Δ2 |,| tc_vars Alphas |,| equations_from_lists Ts (List.map (open_tt_many_var Alphas) (Crettypes def)));
      clear Htmp.
    repeat rewrite List.app_assoc in *.
    apply* IH.
  - lets: equation_strengthen H1 Sem.
    econstructor; eauto.
Qed.

Lemma remove_true_equations : forall Σ Δ E e TT V Ts Us,
    {Σ, Δ |,| equations_from_lists Ts Us, E} ⊢(TT) e ∈ V ->
    List.Forall2 (fun T U => entails_semantic Σ Δ (T ≡ U)) Ts Us ->
    {Σ, Δ, E} ⊢(TT) e ∈ V.
Proof.
  induction 2 as [| T U Ts Us].
  - cbn in *. auto.
  - cbn in H.
    fold (equations_from_lists Ts Us) in H.
    apply* IHForall2.
    rewrite <- (List.app_nil_l ((Δ |,| equations_from_lists Ts Us) |, tc_eq (T ≡ U))) in H.
    forwards~ H2: remove_true_equation H.
    forwards* H3: equations_weaken_match (@nil var) Ts Us.
    apply* Forall2_eq_len.
Qed.

Lemma helper_equations_commute : forall Ts As Us Vs,
    List.length As = List.length Us ->
    List.length Ts = List.length Vs ->
    (forall A, List.In A As -> A \notin fv_typs Ts) ->
    equations_from_lists
      Ts
      (List.map (fun T : typ => subst_tt_many As Us (open_tt_many_var As T)) Vs)
    =
    List.map
      (subst_td_many As Us)
      (equations_from_lists Ts (List.map (open_tt_many_var As) Vs)).
Proof.
  intros.
  rewrite (equations_from_lists_map _ (subst_tt_many As Us) (subst_tt_many As Us)).
  - f_equal.
    + gen Us.
      induction As as [| A As]; introv Len.
      * cbn. rewrite~ List.map_id.
      * destruct Us as [| U Us]; cbn.
        -- rewrite~ List.map_id.
        -- rewrite <- List.map_map.
           rewrite (List.map_ext_in (subst_tt A U) (fun x => x)).
           ++ rewrite List.map_id.
              apply~ IHAs; auto with listin.
           ++ intros T Tin.
              apply subst_tt_fresh.
              apply fv_typs_notin with Ts; auto with listin.
    + rewrite List.map_map. auto.
  - rewrite~ List.map_length.
  - introv In.
    gen H.
    clear.
    rename U into T2. rename T into T1.
    gen Us T1 T2.
    induction As as [| A As]; introv Len; destruct Us as [| U Us]; auto.
    cbn.
    rewrite~ IHAs.
Qed.

Theorem preservation_thm : preservation.
Proof.
  Ltac find_hopen :=
    let Hopen := fresh "Hopen" in
    match goal with
    | H: forall x, x \notin ?L -> typing _ _ _ _ _ _ |- _ =>
      rename H into Hopen
    end.
  unfold preservation.
  introv Htyp.
  assert (term e) as Hterm; eauto using typing_implies_term.
  generalize e'.
  clear e'.
  induction Htyp; inversions Hterm;
    introv Hred; inversions Hred;
      try solve [eauto using Tgen_from_any];
      repeat generalize_typings.
  - (* app *)
    lets [U [HT EQ]]: inversion_typing_eq Htyp2.
    inversions HT.
    pick_fresh x.
    find_hopen. forwards~ K: (Hopen x).
    rewrite* (@subst_ee_intro lam_var x).
    expand_env_empty E.
    apply* typing_through_subst_ee_lam.
    fold_env_empty.
    apply teq_symmetry in EQ.
    lets [EQarg EQret]: inversion_eq_arrow EQ.
    apply typing_eq with T0 Tgen; auto.
    + apply* typing_replace_typ.
      lets*: typing_regular Htyp1.
    + lets* [? [? WFT]]: typing_regular Htyp2.
      inversion~ WFT.
  - (* tabs *)
    lets [U [HT EQ]]: inversion_typing_eq Htyp.
    inversions HT.
    match goal with
    | _: {?A, ?B, ?C} ⊢( ?D ) ?e ∈ typ_all ?T |- _ =>
      rename T into Tall
    end.
    match goal with
    | _: wft ?A ?B ?T |- _ =>
      rename T into Targ
    end.

    apply teq_symmetry in EQ.
    lets: inversion_eq_typ_all EQ; subst.
    apply typing_eq with (open_tt T0 Targ) Tgen.
    + pick_fresh X.
      rewrite* (@subst_te_intro X).
      rewrite* (@subst_tt_intro X).
      apply~ typing_through_subst_te_3.
    + apply~ teq_open.
    + lets* [? [? WFT]]: typing_regular Htyp.
      apply~ wft_open.
  - (* fst *)
    lets [U [HT EQ]]: inversion_typing_eq Htyp.
    inversions HT.
    repeat generalize_typings.
    apply teq_symmetry in EQ.
    lets [EQarg EQret]: inversion_eq_tuple EQ.
    apply* typing_eq.
    lets* [? [? WFT]]: typing_regular Htyp.
    inversion~ WFT.
  - (* snd *)
    lets [U [HT EQ]]: inversion_typing_eq Htyp.
    inversions HT.
    repeat generalize_typings.
    apply teq_symmetry in EQ.
    lets [EQarg EQret]: inversion_eq_tuple EQ.
    apply* typing_eq.
    lets* [? [? WFT]]: typing_regular Htyp.
    inversion~ WFT.
  - (* fix *)
    pick_fresh f.
    rewrite* (@subst_ee_intro fix_var f).
    expand_env_empty E.
    apply* typing_through_subst_ee_fix.
    fold_env_empty.
  - (* let *)
    pick_fresh x.
    rewrite* (@subst_ee_intro lam_var x).
    expand_env_empty E.
    apply* typing_through_subst_ee_lam.
    fold_env_empty.
  - (* matchgadt *)
    (* we reduce to one of the branches which correspond to their definitions in type *)
    lets* [Def [nthDef Inzip]]: nth_error_implies_zip_swap Defs H10.
    lets HclTyp: H3 Inzip.
    remember (Cargtype Def) as argT.
    (* prepare fresh vars *)
    let fresh := gather_vars in
    lets* [Alphas [Hlen [Adist Afresh]]]: exist_alphas fresh (length Ts0).
    pick_fresh x.

    match goal with
    | [ H: term (trm_constructor ?A ?B ?C) |- _ ] =>
      inversions H7
    end.

    (* extract info from well-formedness of GADT env Σ - our constructors are well formed *)
    lets [Hokt ?]: typing_regular Htyp.
    lets okgadt: okt_implies_okgadt Hokt.
    unfold okGadt in okgadt.
    destruct okgadt as [okΣ okCtors].
    lets [defsNe okDefs]: okCtors H0.
    lets indef: fst_from_zip Inzip.
    lets okCtor: okDefs indef.
    inversion okCtor.
    clear H15 H16 Tarity0 Σ0.
    rename Carity into DefArity.

    (* replace open with subst+open_var *)
    rewrite~ (@subst_ee_intro lam_var x);
      [ idtac
      | apply fv_open_te_many;
        [ introv Tin;
          apply* fv_typs_notin
        | auto ]
      ].

    rewrite (@subst_te_intro_many Alphas _ Ts0); auto;
      [ idtac
      | introv Ain; subst; cbn; cbn in Afresh; lets*: Afresh Ain
      | introv Ain Tin; lets: Afresh Ain; apply* fv_typs_notin
      ].

    (* use fact that subst preserves typing *)
    lets [T' [Typ2 EQ]]: inversion_typing_eq Htyp.
    inversions Typ2.
    match goal with
    | [ H1: binds ?g ?A Σ, H2: binds ?g ?B Σ |- _ ] =>
      let H := fresh "H" in
      lets H: binds_ext H1 H2;
        inversions H
    end.

    rename H20 into TypCtorArg.
    match goal with
    | [ H1: List.nth_error Ctors cid = ?A, H2: List.nth_error Ctors cid = ?B |- _ ] =>
      let H := fresh "H" in
      assert (H: A = B); [ rewrite <- H2; auto | idtac ];
        inversions H
    end.
    rewrite (@subst_tt_intro_many Alphas _ Ts0) in TypCtorArg; auto.
    2: {
      intros A Ain; subst; cbn; cbn in Afresh.
      rewrite H13. auto.
    }
    2: {
      intros A U Ain Uin.
      lets WFT: H29 Uin.
      lets: wft_gives_fv WFT.
      intro HF.
      assert (HA: A \in domΔ Δ); auto.
      lets HA2: Afresh Ain.
      apply HA2. repeat rewrite in_union. repeat right~.
    }

    expand_env_empty E.
    match goal with
    | H: value (trm_constructor _ _ e1) |- _ =>
      inversions H
    end.
    eapply typing_through_subst_ee_lam with (subst_tt_many Alphas Ts0 (open_tt_many_var Alphas CargType)) Tgen _; auto; [idtac | eauto].

    (* instantiate the inductive hypothesis *)
    assert (AfreshL: forall A : var, List.In A Alphas -> A \notin L);
      [ introv Ain; lets*: Afresh Ain | idtac].
    assert (xfreshL: x \notin L); auto.
    assert (xfreshA: x \notin from_list Alphas); auto.

    lets* IH: H3 Inzip Alphas x Adist xfreshA.
    cbn in IH.

    rewrite subst_te_many_commutes_open; auto;
      [ idtac
      | introv Ain; lets: Afresh Ain;
        lets: from_list_spec2 Ain;
        intro; subst; auto
      ].

    fold (subst_tb_many Alphas Ts0 (bind_var lam_var (open_tt_many_var Alphas CargType))).
    rewrite <- map_single.
    fold_env_empty.

    rewrite subst_tt_many_free with Alphas Ts0 Tc;
      [ idtac | introv Ain; lets*: Afresh Ain ].

    assert (length CretTypes = length Ts).
    1: {
      lets [OKT [? WFT2]]: typing_regular Htyp.
      inversions WFT2.
      lets OKS: okt_implies_okgadt OKT.
      inversion OKS as [? OKC].
      lets [? OKD]: OKC H0.
      cbn in *.
      lets OKE: OKD indef.
      inversions OKE.
      match goal with
      | [ H1: binds ?g ?A Σ, H2: binds ?g ?B Σ |- _ ] =>
        let H := fresh "H" in
        lets H: binds_ext H1 H2;
          inversions H
      end.
      auto.
    }

    apply remove_true_equations with Ts (List.map (fun T => subst_tt_many Alphas Ts0 (open_tt_many_var Alphas T)) CretTypes).
    + assert (Hrew:
          equations_from_lists Ts (List.map (fun T : typ => subst_tt_many Alphas Ts0 (open_tt_many_var Alphas T)) CretTypes)
          =
          List.map (subst_td_many Alphas Ts0) (equations_from_lists Ts (List.map (open_tt_many_var Alphas) CretTypes))
        ).
      * apply~ helper_equations_commute.
        introv Ain. lets~ : Afresh Ain.
      * rewrite Hrew; clear Hrew.
        apply typing_through_subst_te_many with Tgen; trivial.
        -- intros A Ain.
           lets: Afresh Ain. auto.
        -- autorewrite with rew_env_dom.
           intros A Ain.
           apply notin_inverse.
           intro HF.
           apply xfreshA.
           rewrite in_singleton in HF. subst.
           apply from_list_spec2. auto.
        -- introv Ain.
           lets~ : Afresh Ain.
        -- introv Ain.
           rewrite~ equations_have_no_dom.
           apply* equations_from_lists_are_equations.
        -- introv Ain Tin.
           apply fv_typs_notin with Ts0; auto.
           lets: Afresh Ain.
           auto with listin.
        -- introv Ain; lets*: Afresh Ain.
    + assert (Hrew:
                open_tt_many Ts0 (typ_gadt CretTypes Name)
                =
                typ_gadt (List.map (open_tt_many Ts0) CretTypes) Name).
      * clear.
        rename Ts0 into Ts.
        rename CretTypes into Us.
        gen Us.
        induction Ts; introv.
        -- cbn. rewrite~ List.map_id.
        -- cbn. rewrite IHTs.
           f_equal.
           rewrite List.map_map.
           apply List.map_ext.
           intro T. auto.
      * rewrite Hrew in EQ; clear Hrew.
        assert (Hrew: (List.map (fun T : typ => subst_tt_many Alphas Ts0 (open_tt_many_var Alphas T)) CretTypes) = List.map (open_tt_many Ts0) CretTypes).
        1: {
          apply List.map_ext_in.
          intros T Tin.
          rewrite~ <- subst_tt_intro_many.
          - intros A Ain.
            rewrite~ H14.
          - intros A U Ain Uin.
            lets: Afresh Ain.
            apply fv_typs_notin with Ts0; auto.
        }
        rewrite Hrew; clear Hrew.
        lets EQ2: inversion_eq_typ_gadt EQ.
        rewrite <- (List.map_ext_in (fun T : typ => open_tt_many Ts0 T)).
        2: {
          intros T Tin.
          rewrite~ (@subst_tt_intro_many Alphas T Ts0).
          -- rewrite~ H14.
          -- introv Ain Uin. lets HF2: Afresh Ain.
             apply* fv_typs_notin.
        }
        -- rewrite~ List.map_length.
        -- apply EQ2.
Qed.

Check preservation_thm.


(**************************************************************************)
(*  This file is part of CertrBPF,                                        *)
(*  a formally verified rBPF verifier + interpreter + JIT in Coq.         *)
(*                                                                        *)
(*  Copyright (C) 2022 Inria                                              *)
(*                                                                        *)
(*  This program is free software; you can redistribute it and/or modify  *)
(*  it under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation; either version 2 of the License, or     *)
(*  (at your option) any later version.                                   *)
(*                                                                        *)
(*  This program is distributed in the hope that it will be useful,       *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
(*  GNU General Public License for more details.                          *)
(*                                                                        *)
(**************************************************************************)

From Coq Require Import List Lia ZArith.
From compcert Require Import Integers Values Clight Memory.
Import ListNotations.

From bpf.comm Require Import Monad.
From bpf.clightlogic Require Import CommonLemma CommonLib Clightlogic CorrectRel.
From bpf.verifier.comm Require Import monad.

From bpf.verifier.synthesismodel Require Import verifier_synthesis.
From bpf.verifier.clightmodel Require Import verifier.
From bpf.verifier.simulation Require Import VerifierSimulation VerifierRel.

(**
Check is_not_div_by_zero64.
is_not_div_by_zero64
     : int64 -> M bool
*)

Section Is_not_div_by_zero64.
  Context {S: special_blocks}.

  (** The program contains our function of interest [fn] *)
  Definition p : Clight.program := prog.

  (* [Args,Res] provides the mapping between the Coq and the C types *)
  (* Definition Args : list CompilableType := [stateCompilableType].*)
  Definition args : list Type := [(int64:Type)].
  Definition res : Type := (bool:Type).

  (* [f] is a Coq Monadic function with the right type *)
  Definition f : arrow_type args (M state.state res) := is_not_div_by_zero64.

  (* [fn] is the Cligth function which has the same behaviour as [f] *)
  Definition fn: Clight.function := f_is_not_div_by_zero64.

  (* [match_arg] relates the Coq arguments and the C arguments *)
  Definition match_arg_list : DList.t (fun x => x -> Inv _) args :=
    dcons (fun x => StateLess _ (int64_correct x))
          (DList.DNil _).

  (* [match_res] relates the Coq result and the C result *)
  Definition match_res : res -> Inv state.state := fun x  => StateLess _ (bool_correct x).

  Instance correct_function_is_not_div_by_zero64 : forall a, correct_function _ p args res f fn ModNothing true match_state match_arg_list match_res a.
  Proof.
    correct_function_from_body args.
    correct_body.

    unfold f. unfold is_not_div_by_zero64.
    correct_forward.

    get_invariant _i.
    unfold eval_inv, int64_correct in c0.
    subst.

    eexists.

    split_and; auto.
    {
      unfold exec_expr.
      match goal with
      | H: ?X = _ |- context [match ?X with _ => _ end] =>
        rewrite H
      end. simpl.
      unfold Cop.sem_shr, Cop.sem_shift; simpl.
      change Int64.iwordsize with (Int64.repr 64).
      change (Int64.ltu (Int64.repr 32) (Int64.repr 64)) with true; simpl.
      unfold Cop.sem_cmp; simpl.
      unfold Cop.sem_binarith; simpl.
      unfold Val.of_bool; simpl.
      unfold Vtrue, Vfalse.
      reflexivity.
    }

    unfold eval_inv, match_res, state.is_not_div_by_zero64'.
    unfold bool_correct, Val.of_bool.
    unfold BinrBPF.get_immediate, Int64.cmp, rBPFValues.int64_to_sint32.
    destruct negb; reflexivity.
    unfold Cop.sem_cast; simpl.
    destruct negb; reflexivity.
    destruct negb; constructor; reflexivity.
  Qed.

End Is_not_div_by_zero64.

Existing  Instance correct_function_is_not_div_by_zero64.


From Coq Require Import Program ssreflect ssrbool List.
From MetaCoq.Utils Require Import utils MCRelations.
From MetaCoq.Common Require Import config Kernames.

From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICPrimitive
  PCUICReduction
  PCUICReflect PCUICWeakeningEnv PCUICWeakeningEnvConv PCUICWeakeningEnvTyp PCUICCasesContexts
  PCUICWeakeningConv PCUICWeakeningTyp
  PCUICContextConversionTyp
  PCUICTyping PCUICGlobalEnv PCUICInversion PCUICGeneration
  PCUICConfluence PCUICConversion
  PCUICUnivSubstitutionTyp
  PCUICCumulativity PCUICSR PCUICSafeLemmata
  PCUICValidity PCUICPrincipality PCUICElimination
  PCUICOnFreeVars PCUICWellScopedCumulativity PCUICSN PCUICCanonicity.

From MetaCoq Require Import PCUICArities PCUICSpine.
From MetaCoq.PCUIC Require PCUICWcbvEval.
From MetaCoq.PCUIC Require Import PCUICEquality PCUICAlpha.

Section firstorder.

  Context {Σ : global_env_ext}.
  Context {Σb : list (kername × bool)}.

  Fixpoint plookup_env {A} (Σ : list (kername × A)) (kn : kername) {struct Σ} : option A :=
  match Σ with
  | [] => None
  | d :: tl => if eq_kername kn d.1 then Some d.2 else plookup_env tl kn
  end.
  (*
  Definition zo_type (t : term) :=
    match (PCUICAstUtils.decompose_app t).1 with
    | tProd _ _ _ => false
    | tSort _ => false
    | tInd (mkInd nm i) _ => match (plookup_env Σb nm) with
                             | Some l => nth i l false | None => false
                             end
    | _ => true
    end. *)

  Definition firstorder_type (n k : nat) (t : term) :=
    match (PCUICAstUtils.decompose_app t).1 with
    | tInd (mkInd nm i) u => match (plookup_env Σb nm) with
                             | Some b => b | None => false
                             end
    | tRel i => (k <=? i) && (i <? n + k)
    | _ => false
    end.
  (*
  Definition firstorder_type (t : term) :=
    match (PCUICAstUtils.decompose_app t).1 with
    | tInd (mkInd nm i) _ => match (plookup_env Σb nm) with
                             | Some l => nth i l false | None => false
                             end
    | _ => false
    end. *)

  Definition firstorder_con mind (c : constructor_body) :=
    let inds := #|mind.(ind_bodies)| in
    alli (fun k '({| decl_body := b ; decl_type := t ; decl_name := n|}) =>
      firstorder_type inds k t) 0
      (List.rev (c.(cstr_args) ++ mind.(ind_params)))%list.

  Definition firstorder_oneind mind (ind : one_inductive_body) :=
    forallb (firstorder_con mind) ind.(ind_ctors) && negb (Universe.is_level (ind_sort ind)).

  Definition firstorder_mutind (mind : mutual_inductive_body) :=
    (* if forallb (fun decl => firstorder_type decl.(decl_type)) mind.(ind_params) then *)
    (mind.(ind_finite) == Finite) &&
    forallb (firstorder_oneind mind) mind.(ind_bodies)
    (* else repeat false (length mind.(ind_bodies)). *).

  Definition firstorder_ind (i : inductive) :=
    match lookup_env Σ.1 (inductive_mind i) with
    | Some (InductiveDecl mind) => firstorder_mutind mind
    | _ => false
    end.

End firstorder.

Fixpoint firstorder_env' (Σ : global_declarations) :=
  match Σ with
  | nil => []
  | (nm, ConstantDecl _) :: Σ' =>
    let Σb := firstorder_env' Σ' in
    ((nm, false) :: Σb)
  | (nm, InductiveDecl mind) :: Σ' =>
    let Σb := firstorder_env' Σ' in
    ((nm, @firstorder_mutind Σb mind) :: Σb)
  end.

Definition firstorder_env (Σ : global_env_ext) :=
  firstorder_env' Σ.1.(declarations).

Section cf.

Context {cf : config.checker_flags}.

Definition isPropositional Σ ind b :=
  match lookup_env Σ (inductive_mind ind) with
  | Some (InductiveDecl mdecl) =>
    match nth_error mdecl.(ind_bodies) (inductive_ind ind) with
    | Some idecl =>
      match destArity [] idecl.(ind_type) with
      | Some (_, s) => is_propositional s = b
      | None => False
      end
    | None => False
    end
  | _ => False
  end.

Inductive firstorder_value Σ Γ : term -> Prop :=
| firstorder_value_C i n ui u args pandi :
   Σ ;;; Γ |- mkApps (tConstruct i n ui) args :
   mkApps (tInd i u) pandi ->
   Forall (firstorder_value Σ Γ) args ->
   isPropositional Σ i false ->
   firstorder_value Σ Γ (mkApps (tConstruct i n ui) args).

Lemma firstorder_value_inds :
 forall (Σ : global_env_ext) (Γ : context) (P : term -> Prop),
(forall (i : inductive) (n : nat) (ui u : Instance.t)
   (args pandi : list term),
 Σ;;; Γ |- mkApps (tConstruct i n ui) args : mkApps (tInd i u) pandi ->
 Forall (firstorder_value Σ Γ) args ->
 Forall P args ->
 isPropositional (PCUICEnvironment.fst_ctx Σ) i false ->
 P (mkApps (tConstruct i n ui) args)) ->
forall t : term, firstorder_value Σ Γ t -> P t.
Proof using Type.
  intros ? ? ? ?. fix rec 2. intros t [ ]. eapply H; eauto.
  clear - H0 rec.
  induction H0; econstructor; eauto.
Qed.

Lemma firstorder_ind_propositional {Σ : global_env_ext} {wfΣ:wf Σ} i mind oind :
  declared_inductive Σ i mind oind ->
  @firstorder_ind Σ (firstorder_env Σ) i ->
  isPropositional Σ i false.
Proof using Type.
  intros d. unshelve epose proof (d_ := declared_inductive_to_gen d); eauto.
  pose proof d_ as [d1 d2]. intros H. red in d1. unfold firstorder_ind in H.
  red. sq.
  unfold PCUICEnvironment.fst_ctx in *. rewrite d1 in H |- *.
  solve_all.
  unfold firstorder_mutind in H.
  rewrite d2. move/andP: H => [ind H0].
  eapply forallb_nth_error in H0; tea.
  erewrite d2 in H0. cbn in H0.
  unfold firstorder_oneind in H0. solve_all.
  destruct (ind_sort oind) eqn:E2; inv H0.
  eapply PCUICInductives.declared_inductive_type in d.
  rewrite d. rewrite E2.
  now rewrite destArity_it_mkProd_or_LetIn.
Qed.

Inductive firstorder_spine Σ (Γ : context) : term -> list term -> term -> Type :=
| firstorder_spine_nil ty ty' :
    isType Σ Γ ty ->
    isType Σ Γ ty' ->
    Σ ;;; Γ ⊢ ty ≤ ty' ->
    firstorder_spine Σ Γ ty [] ty'

| firstorder_spine_cons ty hd tl na i u args B B' mind oind :
    isType Σ Γ ty ->
    isType Σ Γ (tProd na (mkApps (tInd i u) args) B) ->
    Σ ;;; Γ ⊢ ty ≤ tProd na (mkApps (tInd i u) args) B ->
    declared_inductive Σ i mind oind ->
    Σ ;;; Γ |- hd : (mkApps (tInd i u) args) ->
    @firstorder_ind Σ (@firstorder_env Σ) i ->
    firstorder_spine Σ Γ (subst10 hd B) tl B' ->
    firstorder_spine Σ Γ ty (hd :: tl) B'.

Inductive instantiated {Σ} (Γ : context) : term -> Type :=
| instantiated_mkApps i u args : instantiated Γ (mkApps (tInd i u) args)
| instantiated_LetIn na d b ty :
  instantiated Γ (ty {0 := d}) ->
  instantiated Γ (tLetIn na d b ty)
| instantiated_tProd na B i u args :
  @firstorder_ind Σ (@firstorder_env Σ) i ->
    (forall x,
       (* Σ ;;; Γ |- x : mkApps (tInd i u) args ->  *)
      instantiated Γ (subst10 x B)) ->
    instantiated Γ (tProd na (mkApps (tInd i u) args) B).

Import PCUICLiftSubst.
Lemma isType_context_conversion {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Δ} {T} :
  isType Σ Γ T ->
  Σ ⊢ Γ = Δ ->
  wf_local Σ Δ ->
  isType Σ Δ T.
Proof using Type.
  intros [s Hs]. exists s. eapply context_conversion; tea. now eapply ws_cumul_ctx_pb_forget.
Qed.

Lemma typing_spine_arity_spine {Σ : global_env_ext} {wfΣ : wf Σ} Γ Δ args T' i u pars :
  typing_spine Σ Γ (it_mkProd_or_LetIn Δ (mkApps (tInd i u) pars)) args T' ->
  arity_spine Σ Γ (it_mkProd_or_LetIn Δ (mkApps (tInd i u) pars)) args T'.
Proof using Type.
  intros H. revert args pars T' H.
  induction Δ using PCUICInduction.ctx_length_rev_ind; intros args pars T' H.
  - cbn. depelim H.
    + econstructor; eauto.
    + eapply invert_cumul_ind_prod in w. eauto.
  - cbn. depelim H.
    + econstructor; eauto.
    + rewrite it_mkProd_or_LetIn_app in w, i0 |- *. cbn. destruct d as [name [body |] type]; cbn in *.
      -- constructor. rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn subst_mkApps. eapply X. now len.
         econstructor; tea. eapply isType_tLetIn_red in i0.
         rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn subst_mkApps Nat.add_0_r in i0. now rewrite Nat.add_0_r. pcuic.
         etransitivity; tea. eapply into_ws_cumul_pb. 2,4:fvs.
         econstructor 3. 2:{ econstructor. }
         rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn subst_mkApps //. constructor 1. reflexivity.
         eapply isType_tLetIn_red in i0. 2:pcuic.
         rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn subst_mkApps in i0.
         now eapply isType_open.
      -- eapply cumul_Prod_inv in w as []. econstructor.
         ++ eapply type_ws_cumul_pb. 3: eapply PCUICContextConversion.ws_cumul_pb_eq_le; symmetry. all:eauto.
            eapply isType_tProd in i0. eapply i0.
         ++ rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn. autorewrite with subst.
            cbn. eapply X. len.
            eapply typing_spine_strengthen. eauto.
            2:{ replace (it_mkProd_or_LetIn (subst_context [hd] 0 Γ0)
            (mkApps (tInd i u) (map (subst [hd] (#|Γ0| + 0)) pars))) with ((PCUICAst.subst10 hd (it_mkProd_or_LetIn Γ0 (mkApps (tInd i u) pars)))).
            2:{ rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn. now autorewrite with subst. }
            eapply substitution0_ws_cumul_pb. eauto. eauto.
            }
            replace (it_mkProd_or_LetIn (subst_context [hd] 0 Γ0)
            (mkApps (tInd i u) (map (subst [hd] (#|Γ0| + 0)) pars))) with ((PCUICAst.subst10 hd (it_mkProd_or_LetIn Γ0 (mkApps (tInd i u) pars)))).
            2:{ rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn. now autorewrite with subst. }
            eapply isType_subst. eapply PCUICSubstitution.subslet_ass_tip. eauto.
            eapply isType_tProd in i0 as [_ tprod].
            eapply isType_context_conversion; tea. constructor. eapply ws_cumul_ctx_pb_refl. now eapply typing_wf_local, PCUICClosedTyp.wf_local_closed_context in t.
            constructor; tea. constructor. pcuic. eapply validity in t. now eauto.
Qed.

Lemma leb_spect : forall x y : nat, BoolSpecSet (x <= y) (y < x) (x <=? y).
Proof using Type.
  intros x y. destruct (x <=? y) eqn:E;
  econstructor; destruct (Nat.leb_spec x y); lia.
Qed.

Lemma nth_error_inds {ind u mind n} : n < #|ind_bodies mind| ->
  nth_error (inds ind u mind.(ind_bodies)) n = Some (tInd (mkInd ind (#|mind.(ind_bodies)| - S n)) u).
Proof using Type.
  unfold inds.
  induction #|ind_bodies mind| in n |- *.
  - intros hm. inv hm.
  - intros hn. destruct n => /=. lia_f_equal.
    eapply IHn0. lia.
Qed.

Lemma alli_subst_instance (Γ : context) u p :
  (forall k t, p k t = p k t@[u]) ->
  forall n,
    alli (fun (k : nat) '{| decl_type := t |} => p k t) n Γ =
    alli (fun (k : nat) '{| decl_type := t |} => p k t) n Γ@[u].
Proof using Type.
  intros hp.
  induction Γ; cbn => //.
  move=> n. destruct a; cbn. f_equal. apply hp. apply IHΓ.
Qed.

Arguments firstorder_mutind : clear implicits.

Lemma plookup_env_lookup_env {Σ : global_env_ext} kn b :
  plookup_env (firstorder_env Σ) kn = Some b ->
  ∑ Σ' decl, lookup_env Σ kn = Some decl ×
    strictly_extends_decls Σ' Σ ×
    match decl with
    | ConstantDecl _ => b = false
    | InductiveDecl mind =>
      b = firstorder_mutind (firstorder_env' (declarations Σ')) mind
    end.
Proof using.
  destruct Σ as [[univs Σ retro] ext].
  induction Σ; cbn => //.
  destruct a as [kn' d] => //. cbn.
  case: eqb_specT.
  * intros ->.
    destruct d => //; cbn; rewrite eqb_refl => [=] <-;
    exists {| universes := univs; declarations := Σ; retroknowledge := retro |}.
    eexists; split => //. cbn. split => //.
    red. split => //. eexists (_ :: []); cbn; trea.
    eexists; split => //. cbn; split => //.
    red. split => //. eexists (_ :: []); cbn; trea.
  * intros neq h.
    destruct d => //. cbn in h.
    move: h. case: eqb_specT=> // _ h'.
    unfold firstorder_env in IHΣ. cbn in IHΣ.
    specialize (IHΣ h') as [Σ' [decl [Hdecl [ext' ?]]]].
    exists Σ', decl; split => //. split => //.
    destruct ext' as [equ [Σ'' eq]]. split => //.
    eexists (_ :: Σ''). cbn in *. rewrite eq. trea.
    move: h. cbn. apply neqb in neq. rewrite (negbTE neq).
    intros h'; specialize (IHΣ h') as [Σ' [decl [Hdecl [ext' ?]]]].
    exists Σ', decl; split => //. split => //.
    destruct ext' as [equ [Σ'' eq]]. split => //.
    eexists (_ :: Σ''). cbn in *. rewrite eq. trea.
Qed.

Lemma firstorder_spine_let {Σ : global_env_ext} {wfΣ : wf Σ} {Γ na a A B args T'} :
  firstorder_spine Σ Γ (B {0 := a}) args T' ->
  isType Σ Γ (tLetIn na a A B) ->
  firstorder_spine Σ Γ (tLetIn na a A B) args T'.
Proof using Type.
  intros H; depind H.
  - constructor; auto.
    etransitivity; tea. eapply cumulSpec_cumulAlgo_curry; tea; fvs.
    eapply cumul_zeta.
  - intros. econstructor. tea.
    2:{ etransitivity; tea.
        eapply cumulSpec_cumulAlgo_curry; tea; fvs.
        eapply cumul_zeta. }
    all:tea.
Qed.

Lemma instantiated_typing_spine_firstorder_spine {Σ : global_env_ext} {wfΣ : wf Σ} Γ T args T' :
  instantiated (Σ := Σ) Γ T ->
  arity_spine Σ Γ T args T' ->
  isType Σ Γ T ->
  firstorder_spine Σ Γ T args T'.
Proof using Type.
  intros hi hsp.
  revert hi; induction hsp; intros hi isty.
  - constructor => //. now eapply isType_ws_cumul_pb_refl.
  - econstructor; eauto.
  - depelim hi. solve_discr. eapply firstorder_spine_let; eauto. eapply IHhsp => //.
    now eapply isType_tLetIn_red in isty; pcuic.
  - depelim hi. solve_discr.
    specialize (i1 hd). specialize (IHhsp i1).
    destruct (validity t) as [s Hs]. eapply inversion_mkApps in Hs as [? [hi _]].
    eapply inversion_Ind in hi as [mdecl [idecl [decli [? ?]]]].
    econstructor; tea. 2:{ eapply IHhsp. eapply isType_apply in isty; tea. }
    now eapply isType_ws_cumul_pb_refl. eauto.
Qed.

Arguments firstorder_type : clear implicits.

(* Lemma firstorder_env'_app x y :
  firstorder_env' (x ++ y) = firstorder_env' x ++ firstorder_env' y.
Proof.
  induction x in y |- *; cbn => //.
  destruct a => //. destruct g => //. cbn. f_equal; eauto.
  cbn; f_equal; eauto.
  f_equal. f_equal. eauto. *)

Import PCUICGlobalMaps.

Lemma fresh_global_app decls decls' kn :
  fresh_global kn (decls ++ decls') ->
  fresh_global kn decls /\ fresh_global kn decls'.
Proof using Type.
  induction decls => /= //.
  - intros f; split => //.
  - intros f; depelim f.
    specialize (IHdecls f) as [].
    split; eauto. constructor => //.
Qed.

Lemma plookup_env_Some_not_fresh g kn b :
  plookup_env (firstorder_env' g) kn = Some b ->
  ~ PCUICGlobalMaps.fresh_global kn g.
Proof using Type.
  induction g; cbn => //.
  destruct a => //. destruct g0 => //.
  - cbn.
    case: eqb_spec.
    + move=> -> [=].
      intros neq hf. depelim hf. now cbn in H.
    + move=> neq hl hf.
      apply IHg => //. now depelim hf.
  - cbn.
    case: eqb_spec.
    + move=> -> [=].
      intros neq hf. depelim hf. now cbn in H.
    + move=> neq hl hf.
      apply IHg => //. now depelim hf.
Qed.

Lemma plookup_env_extends {Σ Σ' : global_env} kn b :
  strictly_extends_decls Σ' Σ ->
  wf Σ ->
  plookup_env (firstorder_env' (declarations Σ')) kn = Some b ->
  plookup_env (firstorder_env' (declarations Σ)) kn = Some b.
Proof using Type.
  intros [equ [Σ'' eq] eqr]. rewrite eq.
  clear equ eqr. intros []. clear o.
  rewrite eq in o0. clear eq. move: o0.
  generalize (declarations Σ'). clear Σ'.
  induction Σ''.
  - cbn => //.
  - cbn. destruct a => //. intros gs ong.
    depelim ong. specialize (IHΣ'' _ ong).
    destruct o as [f ? ? ?].
    destruct g => //.
    * intros hl. specialize (IHΣ'' hl).
      eapply plookup_env_Some_not_fresh in hl.
      cbn. case: eqb_spec.
      + intros <-.  apply fresh_global_app in f as [].
        contradiction.
      + now intros neq.
    * intros hl. specialize (IHΣ'' hl).
      eapply plookup_env_Some_not_fresh in hl.
      cbn. case: eqb_spec.
      + intros <-. apply fresh_global_app in f as [].
        contradiction.
      + now intros neq.
Qed.

Lemma firstorder_mutind_ext {Σ Σ' : global_env_ext} m :
  strictly_extends_decls Σ' Σ ->
  wf Σ ->
  firstorder_mutind (firstorder_env' (declarations Σ')) m ->
  firstorder_mutind (firstorder_env Σ) m.
Proof using Type.
  intros [equ [Σ'' eq]] wf.
  unfold firstorder_env. rewrite eq.
  unfold firstorder_mutind.
  move/andP => [] -> /=. apply forallb_impl => x _.
  unfold firstorder_oneind.
  move/andP => [] h -> /=; rewrite andb_true_r.
  eapply forallb_impl; tea => c _.
  unfold firstorder_con.
  eapply alli_impl => i [] _ _ ty.
  unfold firstorder_type.
  destruct decompose_app => // /=.
  destruct t => //. destruct ind => //.
  destruct plookup_env eqn:hl => //. destruct b => //.
  eapply (plookup_env_extends (Σ:=Σ)) in hl. 2:split; eauto.
  rewrite eq in hl. rewrite hl //. apply wf.
Qed.

Lemma firstorder_args {Σ : global_env_ext} {wfΣ : wf Σ} { mind cbody i n ui args u pandi oind} :
  declared_constructor Σ (i, n) mind oind cbody ->
  PCUICArities.typing_spine Σ [] (type_of_constructor mind cbody (i, n) ui) args (mkApps (tInd i u) pandi) ->
  @firstorder_ind Σ (@firstorder_env Σ) i ->
  firstorder_spine Σ [] (type_of_constructor mind cbody (i, n) ui) args (mkApps (tInd i u) pandi).
Proof using Type.
  intros Hdecl Hspine Hind. revert Hspine.
  unshelve edestruct @declared_constructor_inv with (Hdecl := Hdecl); eauto. exact weaken_env_prop_typing.

  (* revert Hspine. *) unfold type_of_constructor.
  erewrite cstr_eq. 2: eapply p.
  rewrite <- it_mkProd_or_LetIn_app.
  rewrite PCUICUnivSubst.subst_instance_it_mkProd_or_LetIn.
  rewrite PCUICSpine.subst0_it_mkProd_or_LetIn. intros Hspine.

  match goal with
   | [ |- firstorder_spine _ _ ?T _ _ ] =>
  assert (@instantiated Σ [] T) as Hi end.
  { clear Hspine. destruct Hdecl as [[d1 d3] d2]. pose proof d3 as Hdecl.
    unfold firstorder_ind in Hind.
    unshelve epose proof (d1_ := declared_minductive_to_gen d1); eauto.
    rewrite d1_ in Hind. solve_all. clear a.
    move/andP: Hind => [indf H0].
    eapply forallb_nth_error in H0 as H'.
    erewrite d3 in H'.
    unfold firstorder_oneind in H'. cbn in H'.
    rtoProp.
    eapply nth_error_forallb in H. 2: eauto.
    unfold firstorder_con in H.
    revert H. cbn.
    unfold cstr_concl.
    rewrite PCUICUnivSubst.subst_instance_mkApps subst_mkApps.
    rewrite subst_instance_length app_length.
    unfold cstr_concl_head. rewrite PCUICInductives.subst_inds_concl_head. now eapply nth_error_Some_length in Hdecl.
    rewrite -app_length.
    generalize (cstr_args cbody ++ ind_params mind)%list.
    clear -wfΣ d1 indf H1 H0 Hdecl.
    (* generalize conclusion to mkApps tInd args *)
    intros c.
    change (list context_decl) with context in c.
    move: (map (subst (inds _ _ _) _) _).
    intros args.
    rewrite (alli_subst_instance _ ui (fun k t => firstorder_type _ #|ind_bodies mind| k t)).
    { intros k t.
      rewrite /firstorder_type.
      rewrite -PCUICUnivSubstitutionConv.subst_instance_decompose_app /=.
      destruct (decompose_app) => //=. destruct t0 => //. }
    replace (List.rev c)@[ui] with (List.rev c@[ui]).
    2:{ rewrite /subst_instance /subst_instance_context /map_context map_rev //. }
    revert args.
    induction (c@[ui]) using PCUICInduction.ctx_length_rev_ind => args.
    - unfold cstr_concl, cstr_concl_head. cbn.
      autorewrite with substu subst.
      rewrite subst_context_nil. cbn -[subst0].
      econstructor.
    - rewrite rev_app_distr /=. destruct d as [na [b|] t].
      + move=> /andP[] fot foΓ.
        rewrite subst_context_app /=.
        rewrite it_mkProd_or_LetIn_app /= /mkProd_or_LetIn /=.
        constructor.
        rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn subst_mkApps /=. len.
        rewrite -subst_app_context' // PCUICSigmaCalculus.subst_context_decompo.
        cbn. len. eapply X. now len.
        rewrite -subst_telescope_subst_context. clear -foΓ.
        revert foΓ. move: (lift0 #|ind_bodies mind| _).
        generalize 0.
        induction (List.rev Γ) => //.
        cbn -[subst_telescope]. intros n t.
        destruct a; cbn -[subst_telescope].
        move/andP => [] fo fol.
        rewrite PCUICContextSubst.subst_telescope_cons /=.
        apply/andP; split; eauto.
        clear -fo.
        move: fo.
        unfold firstorder_type; cbn.
        destruct (decompose_app decl_type) eqn:da.
        rewrite (decompose_app_inv da) subst_mkApps /=.
        destruct t0 => //=.
        { move/andP => [/Nat.leb_le hn /Nat.ltb_lt hn'].
          destruct (Nat.leb_spec n n0).
          destruct (n0 - n) eqn:E. lia.
          cbn. rewrite nth_error_nil /=.
          rewrite decompose_app_mkApps //=.
          apply/andP. split. apply Nat.leb_le. lia. apply Nat.ltb_lt. lia.
          cbn.
          rewrite decompose_app_mkApps //=.
          apply/andP. split. apply Nat.leb_le. lia. apply Nat.ltb_lt. lia. }
        { destruct ind => //. rewrite decompose_app_mkApps //. }
      + move=> /andP[] fot foΓ.
        rewrite subst_context_app /=.
        rewrite it_mkProd_or_LetIn_app /= /mkProd_or_LetIn /=.
        unfold firstorder_type in fot.
        destruct ((PCUICAstUtils.decompose_app t)) eqn:E.
        cbn in fot. destruct t0; try solve [inv fot].
        * rewrite (decompose_app_inv E) /= subst_mkApps.
          rewrite Nat.add_0_r in fot. eapply Nat.ltb_lt in fot.
          cbn. rewrite nth_error_inds. lia. cbn.
          econstructor.
          unshelve epose proof (d1_ := declared_minductive_to_gen d1); eauto.
          { rewrite /firstorder_ind d1_ /= /firstorder_mutind indf H0 //. }
          intros x.
          rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn subst_mkApps /=. len.
          rewrite -subst_app_context' // PCUICSigmaCalculus.subst_context_decompo.
          cbn. len. eapply X. now len.
          rewrite -subst_telescope_subst_context. clear -foΓ.
          revert foΓ. generalize (lift0 #|ind_bodies mind| x).
          generalize 0.
          induction (List.rev Γ) => //.
          cbn -[subst_telescope]. intros n t.
          destruct a; cbn -[subst_telescope].
          move/andP => [] fo fol.
          rewrite PCUICContextSubst.subst_telescope_cons /=.
          apply/andP; split; eauto.
          clear -fo.
          move: fo.
          unfold firstorder_type; cbn.
          destruct (decompose_app decl_type) eqn:da.
          rewrite (decompose_app_inv da) subst_mkApps /=.
          destruct t0 => //=.
          { move/andP => [/Nat.leb_le hn /Nat.ltb_lt hn'].
            destruct (Nat.leb_spec n n0).
            destruct (n0 - n) eqn:E. lia.
            cbn. rewrite nth_error_nil /=.
            rewrite decompose_app_mkApps //=.
            apply/andP. split. apply Nat.leb_le. lia. apply Nat.ltb_lt. lia.
            cbn.
            rewrite decompose_app_mkApps //=.
            apply/andP. split. apply Nat.leb_le. lia. apply Nat.ltb_lt. lia. }
          { destruct ind => //. rewrite decompose_app_mkApps //. }
        * rewrite (decompose_app_inv E) subst_mkApps //=.
          constructor. {
             unfold firstorder_ind. destruct ind. cbn in *.
             destruct plookup_env eqn:hp => //.
             eapply plookup_env_lookup_env in hp as [Σ' [decl [eq [ext he]]]].
             rewrite eq. destruct decl; subst b => //.
             eapply (firstorder_mutind_ext (Σ' := (empty_ext Σ'))); tea. }
          intros x. rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn subst_mkApps /=; len.
          rewrite -subst_app_context' // PCUICSigmaCalculus.subst_context_decompo.
          eapply X. now len. len.
          rewrite -subst_telescope_subst_context. clear -foΓ.
          revert foΓ. generalize (lift0 #|ind_bodies mind| x).
          generalize 0.
          induction (List.rev Γ) => //.
          cbn -[subst_telescope]. intros n t.
          destruct a; cbn -[subst_telescope].
          move/andP => [] fo fol.
          rewrite PCUICContextSubst.subst_telescope_cons /=.
          apply/andP; split; eauto.
          clear -fo.
          move: fo.
          unfold firstorder_type; cbn.
          destruct (decompose_app decl_type) eqn:da.
          rewrite (decompose_app_inv da) subst_mkApps /=.
          destruct t0 => //=.
          { move/andP => [/Nat.leb_le hn /Nat.ltb_lt hn'].
            destruct (Nat.leb_spec n n0).
            destruct (n0 - n) eqn:E. lia.
            cbn. rewrite nth_error_nil /=.
            rewrite decompose_app_mkApps //=.
            apply/andP. split. apply Nat.leb_le. lia. apply Nat.ltb_lt. lia.
            cbn.
            rewrite decompose_app_mkApps //=.
            apply/andP. split. apply Nat.leb_le. lia. apply Nat.ltb_lt. lia. }
          { destruct ind => //. rewrite decompose_app_mkApps //. }
  }
  cbn in Hi |- *.
  revert Hi Hspine. cbn.
  unfold cstr_concl, cstr_concl_head.
  autorewrite with substu subst.
  rewrite subst_instance_length app_length.
  rewrite PCUICInductives.subst_inds_concl_head. { cbn. destruct Hdecl as [[d1 d2] d3]. eapply nth_error_Some. rewrite d2. congruence. }
  match goal with [ |- context[mkApps _ ?args]] => generalize args end.
  intros args' Hi Spine.
  eapply instantiated_typing_spine_firstorder_spine; tea.
  now eapply typing_spine_arity_spine in Spine.
  now eapply typing_spine_isType_dom in Spine.
Qed.

Lemma invert_cumul_it_mkProd_or_LetIn_Sort_Ind {Σ : global_env_ext} {wfΣ : wf Σ} {Γ Δ s i u args} :
  Σ ;;; Γ ⊢ it_mkProd_or_LetIn Δ (tSort s) ≤ mkApps (tInd i u) args -> False.
Proof using Type.
  induction Δ using PCUICInduction.ctx_length_rev_ind; cbn.
  - eapply invert_cumul_sort_ind.
  - rewrite it_mkProd_or_LetIn_app; destruct d as [na [b|] ty]; cbn.
    * intros hl.
      eapply ws_cumul_pb_LetIn_l_inv in hl.
      rewrite /subst1 PCUICLiftSubst.subst_it_mkProd_or_LetIn in hl.
      eapply H, hl. now len.
    * intros hl. now eapply invert_cumul_prod_ind in hl.
Qed.

Lemma firstorder_value_spec (Σ:global_env_ext) t i u args mind :
  wf Σ -> wf_local Σ [] ->
   Σ ;;; [] |- t : mkApps (tInd i u) args ->
  PCUICWcbvEval.value Σ t ->
  lookup_env Σ (i.(inductive_mind)) = Some (InductiveDecl mind) ->
  @firstorder_ind Σ (firstorder_env Σ) i ->
  firstorder_value Σ [] t.
Proof using Type.
  intros Hwf Hwfl Hty Hvalue.
  revert mind i u args Hty.

  induction Hvalue as [ t Hvalue | t args' Hhead Hargs IH ] using PCUICWcbvEval.value_values_ind;
   intros mind i u args Hty Hlookup Hfo.
  - destruct t; inversion_clear Hvalue.
    + exfalso. eapply inversion_Sort in Hty as (? & ? & Hcumul); eauto.
      now eapply invert_cumul_sort_ind in Hcumul.
    + exfalso. eapply inversion_Prod in Hty as (? & ? & ? & ? & Hcumul); eauto.
      now eapply invert_cumul_sort_ind in Hcumul.
    + exfalso. eapply inversion_Lambda in Hty as (? & ? & ? & ? & Hcumul); eauto.
      now eapply invert_cumul_prod_ind in Hcumul.
    + exfalso. eapply inversion_Ind in Hty as (? & ? & ? & ? & ? & ?); eauto.
      eapply PCUICInductives.declared_inductive_type in d.
      rewrite d in w.
      destruct (ind_params x ,,, ind_indices x0) as [ | [? [] ?] ? _] using rev_ind.
      * cbn in w. now eapply invert_cumul_sort_ind in w.
      * rewrite it_mkProd_or_LetIn_app in w. cbn in w.
        eapply ws_cumul_pb_LetIn_l_inv in w.
        rewrite /subst1 PCUICUnivSubst.subst_instance_it_mkProd_or_LetIn PCUICLiftSubst.subst_it_mkProd_or_LetIn in w.
        now eapply invert_cumul_it_mkProd_or_LetIn_Sort_Ind in w.
      * rewrite it_mkProd_or_LetIn_app in w. cbn in w.
        now eapply invert_cumul_prod_ind in w.
    + eapply inversion_Construct in Hty as Hty'; eauto.
      destruct Hty' as (? & ? & ? & ? & ? & ? & ?).
      assert (ind = i) as ->. {
         eapply PCUICInductiveInversion.Construct_Ind_ind_eq with (args := []); eauto.
      }
      eapply firstorder_value_C with (args := []); eauto.
      eapply firstorder_ind_propositional; eauto. sq. eauto.
      apply declared_inductive_from_gen.
      eapply (declared_constructor_inductive (ind := (i, _))).
      unshelve eapply declared_constructor_to_gen; eauto.
    + exfalso. eapply invert_fix_ind with (args := []) in Hty as [].
      destruct unfold_fix as [ [] | ]; auto. eapply nth_error_nil.
    + exfalso. eapply (typing_cofix_coind (args := [])) in Hty. red in Hty.
      red in Hfo. unfold firstorder_ind in Hfo.
      rewrite Hlookup in Hfo.
      eapply andb_true_iff in Hfo as [Hfo _].
      rewrite /check_recursivity_kind Hlookup in Hty.
      apply eqb_eq in Hfo, Hty. congruence.
    + eapply inversion_Prim in Hty as [prim_ty [cdecl [wf hp hdecl [s []] cum]]]; eauto.
      now eapply invert_cumul_axiom_ind in cum; tea.
  - destruct t; inv Hhead.
    + exfalso. now eapply invert_ind_ind in Hty.
    + apply inversion_mkApps in Hty as Hcon; auto.
      destruct Hcon as (?&typ_ctor& spine).
      apply inversion_Construct in typ_ctor as (?&?&?&?&?&?&?); auto.
      pose proof d as [[d' _] _]. red in d'. cbn in *. unfold PCUICEnvironment.fst_ctx in *.
      eapply @PCUICInductiveInversion.Construct_Ind_ind_eq with (mdecl := x0) in Hty as Hty'; eauto.
      destruct Hty' as (([[[]]] & ?)  & ? & ? & ? & ? & _). subst.
      econstructor; eauto.
      2:{ eapply firstorder_ind_propositional; sq; eauto.
          unshelve eapply declared_constructor_to_gen in d; eauto.
          eapply declared_constructor_inductive in d.
          apply declared_inductive_from_gen; eauto. }
      eapply PCUICSpine.typing_spine_strengthen in spine. 3: eauto.
      2: eapply PCUICInductiveInversion.declared_constructor_valid_ty; eauto.

      eapply firstorder_args in spine; eauto.
      clear c0 c1 e0 w Hty H0 Hargs.
      induction spine.
      * econstructor.
      * destruct d as [d1 d2]. inv IH.
        econstructor. inv X.
        eapply H0. tea.
        unshelve eapply declared_inductive_to_gen in d0; eauto.
        exact i3.
        inv X. eapply IHspine; eauto.
     + exfalso.
       destruct PCUICWcbvEval.cunfold_fix as [[] | ] eqn:E; inversion H.
       eapply invert_fix_ind in Hty. auto.
       unfold unfold_fix. unfold PCUICWcbvEval.cunfold_fix in E.
       destruct (nth_error mfix idx); auto.
       inversion E; subst; clear E.
       eapply nth_error_None. lia.
    + exfalso. eapply (typing_cofix_coind (args := args')) in Hty.
      red in Hfo. unfold firstorder_ind in Hfo.
      rewrite Hlookup in Hfo.
      eapply andb_true_iff in Hfo as [Hfo _].
      rewrite /check_recursivity_kind Hlookup in Hty.
      apply eqb_eq in Hfo, Hty. congruence.
Qed.

Lemma firstorder_value_alpha Σ t t' :
  t ≡α t' ->
  firstorder_value Σ [] t ->
  t = t'.
Proof.
  intros Ha H. induction H in t', Ha |- using firstorder_value_inds.
  eapply eq_term_upto_univ_napp_mkApps_l_inv in Ha as (? & ? & [] & ->).
  invs e. repeat f_equal.
  - now eapply eq_univ_make.
  - revert x0 a. clear - H0. induction H0; intros; invs a; f_equal; eauto.
Qed.

End cf.


Require Export MinBFTprops2.
Require Export MinBFTinv.
Require Export MinBFTrun.

Section MinBFTass_uniq.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { dtc                 : DTimeContext        }.
  Context { minbft_context      : MinBFT_context      }.
  Context { m_initial_keys      : MinBFT_initial_keys }.
  Context { u_initial_keys      : USIG_initial_keys   }.
  Context { usig_hash           : USIG_hash           }.
  Context { minbft_auth         : MinBFT_auth         }.

  Lemma ASSUMPTION_disseminate_unique_true :
    forall (eo : EventOrdering), assume_eo eo ASSUMPTION_disseminate_unique.
  Proof.
    introv h; simpl in *; exrepnd; subst; GC; f_equal.
    rewrite h0 in h1; ginv.

    unfold disseminate_data in *; simpl in *; exrepnd.
    rewrite h6 in *; ginv.
    unfold M_byz_output_sys_on_event in *; simpl in *.

    revert dependent o.
    allrw; simpl.
    introv dout1 out dout2.

    unfold M_byz_output_ls_on_event in *; simpl in *.

    remember (M_byz_run_ls_before_event (MinBFTlocalSys c3) e) as run; symmetry in Heqrun.
    apply M_byz_run_ls_before_event_ls_is_minbft in Heqrun.
    repndors; exrepnd; subst; simpl in *.

    { unfold M_byz_run_ls_on_one_event in *.
      unfold M_byz_run_ls_on_input in *.
      unfold data_is_in_out, event2out in *.
      remember (trigger e) as trig.
      destruct trig; simpl in *; tcsp.

      { apply in_flat_map in dout1; exrepnd.
        apply in_flat_map in dout2; exrepnd.
        unfold M_run_ls_on_input in *; simpl in *.
        autorewrite with comp minbft in *; simpl in *.

        Time minbft_dest_msg Case;
          repeat (simpl in *; autorewrite with minbft in *; smash_minbft2);
          repeat (repndors; subst; simpl in *; tcsp; ginv);
            try (rename_hyp_with invalid_prepare invp);
            try (rename_hyp_with invalid_commit invc);
            try (complete (eapply data_is_owned_by_invalid_prepare_implies_false in invp; eauto; tcsp));
            try (complete (unfold commit2ui_i in *; simpl in *;
                           unfold ui_has_counter in *; simpl in *;
                           unfold ui2counter in *; simpl in *; subst; simpl in *;
                           eapply data_is_owned_by_invalid_commit_not_pil_implies_false in invc; eauto; tcsp)). }

      { pose proof (snd_M_run_ls_on_trusted_incr_n_procs_eq (USIGlocalSys u) i) as z.
        unfold LocalSystem in *; simpl in *; rewrite z in out; clear z.
        rewrite rw_M_run_ls_on_trusted_USIGlocalSys in out.
        destruct i as [cn i]; simpl in *; dest_cases w;[].
        subst; simpl in *.
        destruct i; repnd; repeat (simpl in *; repndors; ginv; tcsp). } }

    { unfold M_byz_run_ls_on_one_event in *.
      unfold M_byz_run_ls_on_input in *.
      unfold data_is_in_out, event2out in *.
      remember (trigger e) as trig.
      destruct trig; simpl in *; tcsp;[].

      pose proof (snd_M_run_ls_on_trusted_incr_n_procs_eq (USIGlocalSys u) i) as z.
      unfold LocalSystem in *; simpl in *; rewrite z in out; clear z.
      rewrite rw_M_run_ls_on_trusted_USIGlocalSys in out.
      destruct i as [cn i]; simpl in *; dest_cases w;[].
      subst; simpl in *.
      destruct i; repnd; repeat (simpl in *; repndors; ginv; tcsp). }
  Qed.
  Hint Resolve ASSUMPTION_disseminate_unique_true : minbft.

End MinBFTass_uniq.

Hint Resolve ASSUMPTION_disseminate_unique_true : minbft.


From aneris.aneris_lang.lib Require Export
     assert_proof
     network_util_proof set_proof map_proof nodup_proof coin_flip_proof.
From aneris_examples.transaction_commit Require Import two_phase_prelude.

Section resource_manager.
  Context `{!network_topo}.
  Context `{!anerisG (TC_model RMs) Σ, !tcG Σ}.

  Lemma wp_rm_sendto_aborted st rm ip s h :
    ip_of_address rm = ip →
    s = udp_socket (Some rm) true →
    (st = WORKING ∨ st = PREPARED) →
    rm ∈ RMs →
    inv tcN tc_inv -∗
    tm ⤇ tm_si -∗
    h ↪[ip] s -∗
    pending_discarded -∗
    rm ↦●{1 / 2} st -∗
    WP SendTo #(LitSocket h) #"ABORTED" #tm @[ip] {{ _, True }}.
  Proof.
    iIntros (? -> Hst ?) "#Hinv #Htmsi Hh #Hpend HErm".
    wp_apply (aneris_wp_atomic_take_step_model).
    iInv tcN as (mdl) ">[? HrmI]" "Hclose".
    iModIntro.
    iDestruct (rm_inv_mdl_Exact with "HErm HrmI") as %?; [done|].
    iExists mdl, (<[rm:=ABORTED]> mdl).
    iDestruct (rm_inv_pending_discarded_notcommitted with "HrmI Hpend") as %?.
    iFrame.
    iSplit.
    { iPureIntro. right. destruct Hst; subst; constructor; auto. }
    iDestruct (big_sepS_delete with "HrmI") as "[Hrm HrmI]"; [done|].
    iDestruct "Hrm" as (R T st') "(% & HErm' & _ & Ha & %Hmcoh)".
    simplify_map_eq.
    iCombine "HErm HErm'" as "HErm".
    iMod (mono_mapsto_update _ _  (ABORTED : rm_stateO)
            with "HErm") as "[[HErm HErm'] #Hal]".
    { econstructor; [|reflexivity]. destruct Hst; subst; constructor. }
    wp_apply (aneris_wp_pers_send with "[$Hh $Ha $Htmsi]"); [done..| |].
    { rewrite /tm_si/=. iSplit; [done|]. iNext. auto. }
    iIntros "[Hh Hrm] Hfrag".
    iMod ("Hclose" with "[-]"); [|done].
    iModIntro. iExists _. iFrame.
    rewrite /rm_inv.
    iApply big_sepS_delete; [done|].
    iSplitL "Hrm HErm' Hpend".
    { iExists _, ({[_]} ∪ _), _. iFrame "∗#".
      rewrite lookup_insert //=.
      iSplit; [done|].
      iPureIntro.
      eapply messages_model_agree_send; [|done|done].
      destruct Hst; simplify_eq; constructor. }
    iApply (big_sepS_impl with "HrmI").
    iIntros "!#" (rm' ?).
    rewrite lookup_insert_ne; [eauto |set_solver].
  Qed.

  Lemma wp_rm_receivefrom rm ip s h :
    ip_of_address rm = ip →
    s = udp_socket (Some rm) true →
    rm ∈ RMs →
    {{{ inv tcN tc_inv ∗ rm ⤇ rm_si ∗ h ↪[ip] s }}}
      ReceiveFrom (# (LitSocket h)) @[ip]
    {{{ m, RET SOMEV (#(m_body m), #(m_sender m)); h ↪[ip] s ∗ rm_si m }}}.
  Proof.
    iIntros (? -> ? Φ) "(#Hinv & #Hrm_si & Hh) HΦ".
    iInv tcN as (?) ">[? HRMs]" "Hclose".
    rewrite /rm_inv (big_sepS_elem_of_acc _ _ rm) //.
    iDestruct "HRMs" as "[Hrm HRMs]".
    iDestruct "Hrm" as (R T st) "(?&?&?& Hrm & %)".
    wp_apply (aneris_wp_pers_receivefrom with "[$Hh $Hrm $Hrm_si]"); [done..|].
    iIntros (?) "(Hh & Hrm & Hm)".
    iMod ("Hclose" with "[-Hm Hh HΦ]") as "_".
    { iModIntro. iExists _. iFrame.
      iApply "HRMs". iExists _,_,_. by iFrame. }
    iApply "HΦ". eauto.
  Qed.

  Lemma wp_rm_wait_commit_abort_receivefrom ip rm h s :
    ip_of_address rm = ip →
    s = udp_socket (Some rm) true →
    rm ∈ RMs →
    {{{ inv tcN tc_inv ∗ rm ⤇ rm_si ∗ h ↪[ip] s }}}
      wait_receivefrom #(LitSocket h)
        (λ: "m", (Fst "m" = #"COMMIT") || (Fst "m" = #"ABORT"))
    @[ip] {{{ m, RET (#(m_body m), #(m_sender m));
                ⌜m_body m = "COMMIT" ∨ m_body m = "ABORT"⌝ ∗
                h ↪[ip] s ∗ rm_si m }}}.
  Proof.
    iIntros (??? Φ) "(#Hinv & #Hrmsi & Hh) HΦ" .
    rewrite /wait_receivefrom. do 7 wp_pure _.
    iLöb as "IH".
    wp_pures.
    wp_bind (ReceiveFrom _).
    wp_apply (wp_rm_receivefrom with "[$]"); [done..|].
    iIntros (v) "[Hh Hm]".
    simplify_eq.
    wp_apply wp_unSOME; [done|]. iIntros "_".
    wp_pures.
    case_bool_decide as Heq.
    - wp_pures. inversion Heq.
      iApply "HΦ". auto with iFrame.
    - wp_pures. case_bool_decide as Heq'.
      + wp_pures. inversion Heq'.
        iApply "HΦ". auto with iFrame.
      + wp_if. by wp_apply ("IH" with "Hh").
  Qed.

  (** * Resource manager spec *)
  Lemma resource_manager_spec A rm :
    rm ∈ A →
    rm ∈ RMs →
    fixed A -∗
    free_ports (ip_of_address rm) {[port_of_address rm]} -∗
    inv tcN tc_inv -∗
    rm ⤇ rm_si -∗
    tm ⤇ tm_si -∗
    pending -∗
    rm ↦●{1 / 2} WORKING -∗
    WP resource_manager #rm #tm @[ip_of_address rm] {{ v, True }}.
  Proof.
    iIntros (??) "#HA Hp #Hinv #Hrmsi #Htmsi Hpend HErm".
    rewrite /resource_manager.
    wp_pures. wp_socket h as "Hh". wp_pures. wp_socketbind_static.
    wp_bind (ReceiveFrom _).
    wp_apply (wp_rm_receivefrom with "[$Hh $Hrmsi $Hinv]"); [done..|].
    iIntros (?) "[Hh Hm]". simplify_eq.
    wp_apply wp_unSOME; [done|]; iIntros "_".
    wp_pures.
    iDestruct "Hm" as "[%Heq | [(%Heq & #Hshot & HRMs) | [%Heq Hpend_disc]]]";
      rewrite Heq; last first.
    - (* received "ABORT" *)
      rewrite bool_decide_eq_true_2 //. wp_if.
      wp_apply (wp_rm_sendto_aborted with "Hinv Htmsi Hh Hpend_disc HErm"); auto.
    - (* received "COMMIT"; cannot happen *)
      rewrite (big_sepS_elem_of _ _ rm) //.
      iDestruct (mono_mapsto_related with "HErm HRMs") as %Hrel.
      by apply rm_step_rtc_not_prepared_working in Hrel.
    - (* received "PREPARE" *)
      rewrite bool_decide_eq_false_2 //. wp_if.
      wp_apply coin_flip_spec; [done|].
      iIntros (b) "_".
      destruct b; wp_pures.
      { (* locally decided to abort *)
        iMod (pending_discard with "Hpend") as "#Hpend".
        wp_apply (wp_rm_sendto_aborted with "Hinv Htmsi Hh Hpend HErm"); auto. }
      (* locally preaparing to commit *)
      wp_bind (SendTo _ _ _).
      wp_apply aneris_wp_atomic_take_step_model.
      iInv tcN as (mdl) ">[? HrmI]" "Hclose".
      iModIntro.
      iDestruct (rm_inv_mdl_Exact with "HErm HrmI") as %?; [done|].
      iExists mdl, (<[rm:=PREPARED]> mdl).
      iDestruct (rm_inv_pending_notcommitted with "HrmI Hpend") as %?.
      iFrame.
      iSplit.
      { iPureIntro. right. constructor; auto. }
      iDestruct (big_sepS_delete with "HrmI") as "[Hrm HrmI]"; [done|].
      iDestruct "Hrm" as (R T st) "(% & HErm' & _ & Hrm & %Hmcoh)".
      simplify_map_eq.
      iCombine "HErm HErm'" as "HErm".
      iMod (mono_mapsto_update _  _ (PREPARED : rm_stateO) with "HErm")
        as "[[HErm HErm'] #Hal]".
      { econstructor; [|reflexivity]. constructor. }
      wp_apply (aneris_wp_pers_send with "[$Hh $Hrm $Htmsi Hpend]");
        [done..| |].
      { rewrite /tm_si/=. iSplit; [done|]. iNext. auto. }
      iIntros "[Hh Hrm] Hfrag".
      iMod ("Hclose" with "[Hrm HrmI HErm' Hfrag]") as "_".
      { iModIntro. iExists _. iFrame.
        rewrite /rm_inv.
        iApply big_sepS_delete; [done|].
        iSplitL "Hrm HErm'".
        { iExists _, (_ ∪ _), _. iFrame.
          rewrite lookup_insert //=.
          iSplit; [done|].
          iPureIntro.
          eapply messages_model_agree_send; [|done|done].
          constructor. }
        iApply (big_sepS_impl with "HrmI").
        iIntros "!#" (rm' ?).
        rewrite lookup_insert_ne; [eauto |set_solver]. }
      iModIntro. do 2 wp_pure _.
      wp_apply (wp_rm_wait_commit_abort_receivefrom
                       with "[$Hinv $Hrmsi $Hh]"); [done..|].
      iIntros (v).
      rewrite {2}/rm_si.
      iDestruct 1 as ([-> | ->]) "(Hh & Hm')"; simplify_eq.
      + (* decision to commit *)
        wp_pures.
        iDestruct "Hm'" as "[% | [(_ & #Hshot & Hprepared) | [% _]]]";
          [done| |done].
        wp_apply aneris_wp_atomic_take_step_model.
        iInv tcN as (mdl') ">[? HrmI]" "Hclose".
        iModIntro.
        iDestruct (rm_inv_mdl_Exact with "HErm HrmI") as %?; [done|].
        iExists mdl', (<[rm:=COMMITTED]> mdl').
        iFrame.
        iDestruct (rm_inv_cancommit with "HrmI Hprepared Hshot") as %?.
        iSplit.
        { iPureIntro. right. by constructor. }
        iClear "Hprepared".
        iFrame.
        iDestruct (big_sepS_delete with "HrmI") as "[Hrm HrmI]"; [done|].
        iDestruct "Hrm" as (?? st) "(% & HErm' & _ & Hrm & %Hmcoh')".
        simplify_map_eq.
        iCombine "HErm HErm'" as "HErm".
        iMod (mono_mapsto_update _  _ (COMMITTED : rm_stateO) with "HErm")
          as "[[HErm HErm'] #Hal']".
        { econstructor; [|reflexivity]. constructor. }
        wp_apply (aneris_wp_pers_send with "[$Hh $Hrm $Htmsi]"); [done..| |].
        { rewrite /tm_si/=. iSplit; [done|]. iNext. auto. }
        iIntros "[Hh Hrm] Hfrag".
        iMod ("Hclose" with "[Hrm HrmI HErm' Hfrag]"); [|done].
        iModIntro. iExists _. iFrame.
        rewrite /rm_inv.
        iApply big_sepS_delete; [done|].
        iSplitL "Hrm HErm'".
        { iExists _, (_ ∪ _), _. iFrame. iFrame "#".
          rewrite lookup_insert //=.
          iSplit; [done|].
          iPureIntro.
          eapply messages_model_agree_send; [|done|done].
          constructor. }
        iApply (big_sepS_impl with "HrmI").
        iIntros "!#" (rm' ?).
        rewrite lookup_insert_ne; [eauto |set_solver].
      + (* decision to abort *)
        wp_pures.
        iDestruct "Hm'" as "[% | [[% _] | (% & Hpend_disc)]]"; try done.
        wp_apply (wp_rm_sendto_aborted with "Hinv Htmsi Hh Hpend_disc HErm");
          auto.
  Qed.

End resource_manager.