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.


Require Import CpdtTactics.
From Coq Require Import Arith.PeanoNat.
From Coq Require Import Strings.String.
From Coq Require Import Lists.List.
Import ListNotations.

Require Import SyntaxRuntime.

Local Set Warnings "-implicit-core-hint-db".

Set Implicit Arguments.

Ltac inv H := inversion H; subst; clear H.

Fixpoint keyset_to_keyset (t : term) :=
match t with
| t_ks_nil => []
| t_ks_cons (t_result k) ks => k :: keyset_to_keyset ks
| _ => []
end.

Inductive frff : Type :=
| FRf : term -> rstream -> frff.
Hint Constructors frff.
Inductive frtt : Type :=
| FRt : term -> ostream -> frtt.
Hint Constructors frtt.
Reserved Notation "frff '==>' frtt" (at level 40).

Inductive fstep : frff -> frtt -> Prop :=
| F_Emit_PFold : forall rs l f t ks,
    value f ->
    value t ->
    value ks ->
    FRf (t_emit_pfold l f t ks) rs ==> FRt (t_label l) [l ->> pfold f t (keyset_to_keyset ks)]
| F_Emit_PMap : forall c b os rs l f ks,
    c = C b os rs (t_emit_pmap l f ks) ->
    value f ->
    value ks ->
    FRf (t_emit_pmap l f ks) rs ==> FRt (t_label l) [l ->> pmap f (keyset_to_keyset ks)]
| F_Emit_Add : forall rs l k v,
    FRf (t_emit_add l (t_result k) (t_result v)) rs ==> FRt (t_label l) [l ->> add k (t_result v)]
| F_Claim : forall rs l v,
    In (l ->>> v) rs ->
    FRf (t_downarrow (t_label l)) rs ==> FRt (t_result v) []
| F_Ctx_Downarrow : forall os rs t t',
    FRf t rs ==> FRt t' os ->
    FRf (t_downarrow t) rs ==> FRt (t_downarrow t') os
| F_Ctx_Emit_PFold1 : forall os rs l t1 t2 t3 t1',
    FRf t1 rs ==> FRt t1' os ->
    FRf (t_emit_pfold l t1 t2 t3) rs ==> FRt (t_emit_pfold l t1' t2 t3) os
| F_Ctx_Emit_PFold2 : forall os rs l t1 t2 t3 t2',
    value t1 ->
    FRf t2 rs ==> FRt t2' os ->
    FRf (t_emit_pfold l t1 t2 t3) rs ==> FRt (t_emit_pfold l t1 t2' t3) os
| F_Ctx_Emit_PFold3 : forall os rs l t1 t2 t3 t3',
    value t1 ->
    value t2 ->
    FRf t3 rs ==> FRt t3' os ->
    FRf (t_emit_pfold l t1 t2 t3) rs ==> FRt (t_emit_pfold l t1 t2 t3') os
| F_Ctx_Emit_PMap1 : forall os rs l t1 t2 t1',
    FRf t1 rs ==> FRt t1' os ->
    FRf (t_emit_pmap l t1 t2) rs ==> FRt (t_emit_pmap l t1' t2) os
| F_Ctx_Emit_PMap2 : forall os rs l t1 t2 t2',
    value t1 ->
    FRf t2 rs ==> FRt t2' os ->
    FRf (t_emit_pmap l t1 t2) rs ==> FRt (t_emit_pmap l t1 t2') os
| F_Ctx_Emit_Add1 : forall os rs l t1 t2 t1',
    FRf t1 rs ==> FRt t1' os ->
    FRf (t_emit_add l t1 t2) rs ==> FRt (t_emit_add l t1' t2) os
| F_Ctx_Emit_Add2 : forall os rs l t1 t2 t2',
    value t1 ->
    FRf t2 rs ==> FRt t2' os ->
    FRf (t_emit_add l t1 t2) rs ==> FRt (t_emit_add l t1 t2') os
| F_App : forall rs x T t12 v2,
    value v2 ->
    FRf (t_app (t_abs x T t12) v2) rs ==> FRt (#[x:=v2]t12) []
| F_App1 : forall os rs t1 t2 t1',
    FRf t1 rs ==> FRt t1' os ->
    FRf (t_app t1 t2) rs ==> FRt (t_app t1' t2) os
| F_App2 : forall os rs t1 t2 t2',
    value t1 ->
    FRf t2 rs ==> FRt t2' os ->
    FRf (t_app t1 t2) rs ==> FRt (t_app t1 t2') os
| F_Ctx_KS1 : forall os rs k ks k',
    FRf k rs ==> FRt k' os ->
    FRf (t_ks_cons k ks) rs ==> FRt (t_ks_cons k' ks) os
| F_Ctx_KS2 : forall os rs k ks ks',
    value k ->
    FRf ks rs ==> FRt ks' os ->
    FRf (t_ks_cons k ks) rs ==> FRt (t_ks_cons k ks') os
| F_Ctx_Node1 : forall os rs k p es k',
    FRf k rs ==> FRt k' os ->
    FRf (t_node k p es) rs ==> FRt (t_node k' p es) os
| F_Ctx_Node2 : forall os rs k p es p',
    value k ->
    FRf p rs ==> FRt p' os ->
    FRf (t_node k p es) rs ==> FRt (t_node k p' es) os
| F_Ctx_Node3 : forall os rs k p es es',
    value k ->
    value p ->
    FRf es rs ==> FRt es' os ->
    FRf (t_node k p es) rs ==> FRt (t_node k p es') os
| F_Fix : forall rs t T,
    value t ->
    FRf (t_fix T t) rs ==> FRt (t_abs "x" T (t_app (t_app t (t_fix T t)) (t_var "x"))) []
| F_Ctx_Na1 : forall os rs t t',
    FRf t rs ==> FRt t' os ->
    FRf (t_na1 t) rs ==> FRt (t_na1 t') os
| F_Ctx_Na2 : forall os rs t t',
    FRf t rs ==> FRt t' os ->
    FRf (t_na2 t) rs ==> FRt (t_na2 t') os
| F_Ctx_Na3 : forall os rs t t',
    FRf t rs ==> FRt t' os ->
    FRf (t_na3 t) rs ==> FRt (t_na3 t') os
| F_Na1 : forall rs t1 t2 t3,
    value t1 ->
    value t2 ->
    value t3 ->
    FRf (t_na1 (t_node t1 t2 t3)) rs ==> FRt t1 []
| F_Na2 : forall rs t1 t2 t3,
    value t1 ->
    value t2 ->
    value t3 ->
    FRf (t_na2 (t_node t1 t2 t3)) rs ==> FRt t2 []
| F_Na3 : forall rs t1 t2 t3,
    value t1 ->
    value t2 ->
    value t3 ->
    FRf (t_na3 (t_node t1 t2 t3)) rs ==> FRt t3 []
| F_Ctx_Fix : forall os rs t t' T,
    FRf t rs ==> FRt t' os ->
    FRf (t_fix T t) rs ==> FRt (t_fix T t') os
where "frff ==> frtt" := (fstep frff frtt).
Hint Constructors fstep.

Inductive lappears_free_in : label -> term -> Prop :=
| lafi_label : forall l,
    lappears_free_in l (t_label l)
| lafi_app1 : forall x t1 t2,
    lappears_free_in x t1 ->
    lappears_free_in x (t_app t1 t2)
| lafi_app2 : forall x t1 t2,
    lappears_free_in x t2 ->
    lappears_free_in x (t_app t1 t2)
| lafi_abs : forall x y T11 t12,
    lappears_free_in x t12 ->
    lappears_free_in x (t_abs y T11 t12)
| lafi_ks1 : forall x k ks,
    lappears_free_in x k ->
    lappears_free_in x (t_ks_cons k ks)
| lafi_ks2 : forall x k ks,
    lappears_free_in x ks ->
    lappears_free_in x (t_ks_cons k ks)
| lafi_node1 : forall x k p es,
    lappears_free_in x k ->
    lappears_free_in x (t_node k p es)
| lafi_node2 : forall x k p es,
    lappears_free_in x p ->
    lappears_free_in x (t_node k p es)
| lafi_node3 : forall x k p es,
    lappears_free_in x es ->
    lappears_free_in x (t_node k p es)
| lafi_downarrow : forall x t,
    lappears_free_in x t ->
    lappears_free_in x (t_downarrow t)
| lafi_emit_getpay1 : forall x l t1 t2 t3,
    lappears_free_in x t1 ->
    lappears_free_in x (t_emit_pfold l t1 t2 t3)
| lafi_emit_getpay2 : forall x l t1 t2 t3,
    lappears_free_in x t2 ->
    lappears_free_in x (t_emit_pfold l t1 t2 t3)
| lafi_emit_getpay3 : forall x l t1 t2 t3,
    lappears_free_in x t3 ->
    lappears_free_in x (t_emit_pfold l t1 t2 t3)
| lafi_emit_pmap1 : forall x l t1 t2,
    lappears_free_in x t1 ->
    lappears_free_in x (t_emit_pmap l t1 t2)
| lafi_emit_pmap2 : forall x l t1 t2,
    lappears_free_in x t2 ->
    lappears_free_in x (t_emit_pmap l t1 t2)
| lafi_emit_add1 : forall x l t1 t2,
    lappears_free_in x t1 ->
    lappears_free_in x (t_emit_add l t1 t2)
| lafi_emit_add2 : forall x l t1 t2,
    lappears_free_in x t2 ->
    lappears_free_in x (t_emit_add l t1 t2)
| lafi_na1 : forall x t,
    lappears_free_in x t ->
    lappears_free_in x (t_na1 t)
| lafi_na2 : forall x t,
    lappears_free_in x t ->
    lappears_free_in x (t_na2 t)
| lafi_na3 : forall x t,
    lappears_free_in x t ->
    lappears_free_in x (t_na3 t)
| lafi_fix : forall x t T,
    lappears_free_in x t ->
    lappears_free_in x (t_fix T t).
Hint Constructors lappears_free_in.

Definition pmap_compose f f' :=
t_abs "x" Result (t_app f (t_app f' (t_var "x"))).

Reserved Notation "c1 '-->' c2" (at level 40).

(* Fig 11: Operational Semantics *)

Inductive step : config -> config -> Prop :=
(* frontend *)
| S_Frontend : forall c b os rs t os' t',
    c = C b os rs t ->
    FRf t rs ==> FRt t' os' ->
    c --> C b (os ++ os') rs t'
(* to-graph *)
| S_Empty : forall c os rs os' o l op term H,
    c = C [] os rs term ->
    os = o :: os' ->
    o = l ->> op ->
    not_add op ->
    c --> C [] os' (l ->>> (@final op) H :: rs) term
| S_First : forall c b os rs o os' b' n1 os1 op l term,
    c = C b os rs term ->
    os = o :: os' ->
    b = (<<n1; os1>>)::b' ->
    o = l ->> op ->
    not_add op ->
    c --> C (<<n1; (os1 ++ [o])>> :: b') os' rs term
| S_Add : forall c b os rs os' l k v o term H,
    c = C b os rs term ->
    os = o :: os' ->
    o = l ->> add k v ->
    c --> C (<<(N k v t_ks_nil); []>> :: b) os' (l ->>> (@final (add k v)) H :: rs) term
(* task *)
| S_PMap : forall c b os rs b1 s1 s1' os1 os1' os1'' b2 k v es ks l term f,
    c = C b os rs term ->
    b = b1 ++ s1 :: b2 ->
    s1 = <<N k v es; os1>> ->
    os1 = l ->> pmap f ks :: os1'' ->
    os1' = l ->> pmap f (remove Nat.eq_dec k ks) :: os1'' ->
    s1' = <<N k (t_app f v) es; os1'>> ->
    In k ks ->
    c --> C (b1 ++ s1' :: b2) os rs term
| S_PFold : forall c b os rs b1 s1 s1' os1 os1' os1'' b2 k t es f t' ks l term,
    c = C b os rs term ->
    b = b1 ++ s1 :: b2 ->
    s1 = <<N k t es; os1>> ->
    os1 = l ->> pfold f t' ks :: os1'' ->
    os1' = l ->> pfold f (t_app (t_app f t) t') (remove Nat.eq_dec k ks) :: os1'' ->
    s1' = <<N k t es; os1'>> ->
    In k ks ->
    c --> C (b1 ++ s1' :: b2) os rs term
| S_Last : forall c b os rs l n1 os1 os1' op b1 k term H,
    c = C b os rs term ->
    b = b1 ++ [<<n1; os1>>] ->
    os1 = l ->> op :: os1' ->
    k = getKey n1 ->
    not (In k (target op)) ->
    c --> C (b1 ++ [<<n1; os1'>>]) os (l ->>> (@final op) H :: rs) term
(* Fig 12: Temporal Locality Optimization *)
| S_FusePMap : forall c b n b1 b2 os os1 os2 rs term f f' ks l l' H,
    c = C b os rs term ->
    b = b1 ++ <<n; os1 ++ l ->> pmap f ks :: l' ->> pmap f' ks :: os2>> :: b2 ->
    c --> C (b1 ++ <<n; os1 ++ l' ->> pmap (pmap_compose f' f) ks :: os2>> :: b2) os (l ->>> (@final (pmap f ks)) H :: rs) term
| S_SwapReads : forall c b n b1 b2 os os1 os2 rs term l l' f f' ks ks' t t',
    c = C b os rs term ->
    b = b1 ++ <<n; os1 ++ l ->> pfold f t ks :: l' ->> pfold f' t' ks' :: os2>> :: b2 ->
    not (lappears_free_in l f') ->
    not (lappears_free_in l t') ->
    c --> (C (b1 ++ <<n; os1 ++ l' ->> pfold f' t' ks' :: l ->> pfold f t ks :: os2>> :: b2) os rs term)
| S_Prop : forall c b os rs n1 n2 os1 os2 b1 b2 l op term,
    c = C b os rs term ->
    ~ (In (getKey n1) (target op)) ->
    b = b1 ++ <<n1; l ->> op :: os1>> :: <<n2; os2>> :: b2 ->
    c --> C (b1 ++ <<n1; os1>> :: <<n2; os2 ++ [l ->> op]>> :: b2) os rs term
(* task *)
| S_Load : forall c b os0 rs0 term0 b1 b2 k t es t' os,
   c = C b os0 rs0 term0 ->
   b = b1 ++ <<N k t es; os>> :: b2 ->
   FRf t rs0 ==> FRt t' [] ->
   c --> C (b1 ++ <<N k t' es; os>> :: b2) os0 rs0 term0
| S_LoadPFold : forall c b b' os0 rs0 term0 l b1 b2 k t es f t1 t1' ks os os',
   c = C b os0 rs0 term0 ->
   b = b1 ++ <<N k t es; os ++ l ->> pfold f t1 ks :: os'>> :: b2 ->
   FRf t1 rs0 ==> FRt t1' [] ->
   b' = b1 ++ <<N k t es; os ++ l ->> pfold f t1' ks :: os'>> :: b2 ->
   c --> C b' os0 rs0 term0
where "c1 --> c2" := (step c1 c2).
Hint Constructors step.

Inductive star {A : Type} (R : A -> A -> Prop) : nat -> A -> A -> Prop :=
| Zero : forall x, star R 0 x x
| Step : forall x y, R x y -> forall n z, star R n y z -> star R (S n) x z.
Hint Constructors star.

Notation "c1 '-->*[' n ']' c2" := (star step n c1 c2) (at level 40).

Lemma star_zero :
  forall {A : Type} (R : A -> A -> Prop) x y,
  star R 0 x y ->
  x = y.
Proof using.
  intros.
  inversion H; subst; clear H; crush.
Qed.
Hint Immediate star_zero.

Lemma one_star :
  forall {A : Type} R (x:A) y,
  star R 1 x y <->
  R x y.
Proof using.
  split; intros.
  - inv H.
    apply star_zero in H2; subst.
    assumption.
  - eapply Step.
    instantiate (1:=y).
    assumption.
    apply Zero.
Qed.
Hint Immediate one_star.

Lemma star_zero_exists :
  forall {A : Type} (R : A -> A -> Prop) x,
  exists m, star R m x x.
Proof using.
  intros.
  apply ex_intro with (0).
  crush.
Qed.
Hint Immediate star_zero_exists.

Lemma star_trans :
  forall {A : Type} (R : A -> A -> Prop) x y z m n,
  star R m x y ->
  star R n y z ->
  star R (m+n) x z.
Proof using.
  intros.
  generalize dependent z.
  generalize dependent x.
  generalize dependent y.
  generalize dependent n.
  induction m; induction n; intros.
  - crush.
    apply star_zero in H; subst; crush.
  - simpl.
    apply star_zero in H; subst; crush.
  - apply star_zero in H0; subst.
    assert (S m = S m + 0) by crush.
    rewrite H0 in H.
    crush.
  - simpl in *.
    inversion H; subst; clear H.
    inversion H0; subst; clear H0.
    eapply Step.
    instantiate (1:=y0).
    assumption.
    eapply IHm.
    instantiate (1:=y).
    assumption.
    eapply Step.
    instantiate (1:=y1).
    assumption.
    assumption.
Qed.
Hint Resolve star_trans.

Definition backend_keys (b : backend) :=
map (fun s => getKey (get_node s)) b.
Hint Unfold backend_keys.

Definition ostream_keys (os : ostream) :=
List.concat (map (fun o => match o with
             | l ->> add k _ => [k]
             | _ => []
           end) os).
Hint Unfold ostream_keys.

Definition config_keys (c : config) :=
match c with
| C b os rs term => List.concat [backend_keys b; ostream_keys os]
end.
Hint Unfold config_keys.

Definition ostream_labels (os : ostream) :=
map (fun o => match o with l ->> _ => l end) os.
Hint Unfold ostream_labels.

Lemma ostream_labels_dist :
  forall os1 os2,
  ostream_labels (os1 ++ os2) = ostream_labels os1 ++ ostream_labels os2.
Proof using.
 induction os1; intros; crush.
Qed.
Hint Rewrite ostream_labels_dist.

Lemma cons_equal :
  forall {A: Type} (x : A) y xs ys,
  x = y ->
  xs = ys ->
  x :: xs = y :: ys.
Proof using.
  crush.
Qed.

Lemma ostream_keys_dist :
  forall os1 os2,
  ostream_keys (os1 ++ os2) = ostream_keys os1 ++ ostream_keys os2.
Proof using.
  induction os1; intros.
  - crush.
  - simpl.
    destruct a; destruct o.
    + unfold ostream_keys.
      simpl.
      apply IHos1.
    + unfold ostream_keys.
      simpl.
      apply cons_equal; crush.
      apply IHos1.
    + unfold ostream_keys.
      simpl.
      eauto.
Qed.
Hint Rewrite ostream_labels_dist.

Lemma backend_keys_dist :
  forall b1 b2,
  backend_keys (b1 ++ b2) = backend_keys b1 ++ backend_keys b2.
Proof using.
 induction b1; intros; crush.
Qed.
Hint Rewrite backend_keys_dist.

Definition rstream_labels (rs : rstream) :=
map (fun r => match r with l ->>> _ => l end) rs.
Hint Unfold rstream_labels.

Lemma rstream_labels_dist :
  forall rs1 rs2,
  rstream_labels (rs1 ++ rs2) = rstream_labels rs1 ++ rstream_labels rs2.
Proof using.
 induction rs1; intros; crush.
Qed.
Hint Rewrite rstream_labels_dist.

Definition backend_labels (b : backend) :=
List.concat (map (fun s => ostream_labels (get_ostream s)) b).
Hint Unfold backend_labels.

Lemma backend_labels_dist :
  forall b1 b2,
  backend_labels (b1 ++ b2) = backend_labels b1 ++ backend_labels b2.
Proof using.
  induction b1; intros; intuition.
  simpl.
  unfold backend_labels in *.
  simpl.
  crush.
Qed.
Hint Rewrite backend_labels_dist.

Definition config_labels (c : config) :=
match c with
| C b os rs term => List.concat [backend_labels b; ostream_labels os; rstream_labels rs]
end.
Hint Unfold config_labels.

Inductive distinct (A : Type) : list A -> Prop :=
| distinct_empty : distinct []
| distinct_one : forall x, distinct [x]
| distinct_many : forall xs x xs', xs = x :: xs' -> not (In x xs') -> distinct xs' -> distinct xs.
Hint Constructors distinct.

Lemma distinct_remove :
  forall A (x : A) xs,
  distinct (x :: xs) ->
  distinct xs /\ not (In x xs).
Proof using.
  intros.
  inversion H; crush.
Qed.
Hint Resolve distinct_remove.

Lemma not_in_app_comm :
  forall A (x : A) xs ys,
  ~ In x (xs ++ ys) ->
  ~ In x (ys ++ xs).
Proof using.
  unfold not in *.
  intros.
  apply List.in_app_or in H0.
  inversion H0; crush.
Qed.
Hint Resolve not_in_app_comm.

Lemma not_in_remove :
  forall A (x : A) y xs,
  ~ In x (y :: xs) ->
  ~ In x xs /\ x <> y.
Proof using.
  induction xs; crush.
Qed.
Hint Resolve not_in_remove.

Lemma distinct_rotate_back_one :
  forall A (x : A) xs,
  distinct (x :: xs) ->
  distinct (xs ++ [x]).
Proof using.
  induction xs; intros; crush.
  apply distinct_remove in H.
  destruct H.
  eapply distinct_many.
  instantiate (1:=xs ++ [x]).
  instantiate (1:=a).
  crush.
  crush.
  apply List.in_app_iff in H1.
  destruct H1.
  - inv H; crush.
  - inv H0; crush.
  - apply IHxs.
    apply List.not_in_cons in H0.
    destruct H0.
    inv H; crush.
    eapply distinct_many.
    instantiate (1:=xs').
    instantiate (1:=x).
    crush.
    crush.
    crush.
Qed.

Lemma distinct_rotate_back :
  forall A (x : A) xs ys,
  distinct (xs ++ x :: ys) ->
  distinct (xs ++ ys ++ [x]).
Proof using.
  induction xs; intros.
  - simpl.
    apply distinct_rotate_back_one.
    crush.
  - simpl in *.
    apply distinct_remove in H.
    eapply distinct_many.
    instantiate (1:=(xs ++ ys ++ [x])).
    instantiate (1:=a).
    crush.
    destruct H.
    crush.
    assert (In a (xs ++ x :: ys)).
    apply List.in_app_iff in H1.
    destruct H1.
    crush.
    apply List.in_app_iff in H1.
    destruct H1.
    crush.
    crush.
    crush.
    apply IHxs.
    crush.
Qed.

Lemma distinct_rotate :
  forall A (x : A) xs ys,
  distinct (x :: xs ++ ys) ->
  distinct (xs ++ x :: ys).
Proof using.
  induction xs; intros; crush.
  apply distinct_remove in H; destruct H.
  apply distinct_remove in H; destruct H.
  crush.
  assert (distinct (x :: xs ++ ys)).
  eapply distinct_many; crush.
  apply IHxs in H0.
  apply distinct_many with (x := a) (xs' := xs ++ x :: ys); crush.
  apply List.in_app_or in H4; destruct H4; crush.
Qed.
Hint Resolve distinct_rotate.

Lemma distinct_rotate_rev :
  forall A (x : A) xs ys,
  distinct (xs ++ x :: ys) ->
  distinct (x :: xs ++ ys).
Proof using.
  induction xs; intros; crush.
  apply distinct_remove in H; destruct H.
  apply IHxs in H.
  apply distinct_remove in H; destruct H.
  assert (distinct (a :: xs ++ ys)).
  eapply distinct_many; crush.
  apply List.in_app_or in H2; destruct H2; crush.
  apply distinct_many with (x := x) (xs' := a :: xs ++ ys); crush.
Qed.
Hint Resolve distinct_rotate.

Lemma distinct_app_comm :
  forall A (xs : list A) ys,
  distinct (xs ++ ys) ->
  distinct (ys ++ xs).
Proof using.
  induction xs; intros ys Ih.
  - rewrite List.app_nil_r; assumption.
  - simpl in Ih.
    apply distinct_remove in Ih.
    destruct Ih.
    apply IHxs in H.
    apply not_in_app_comm in H0.
    apply distinct_rotate.
    eapply distinct_many; crush.
Qed.
Hint Resolve distinct_app_comm.

Lemma distinct_remove_middle :
  forall A (x : A) xs ys,
  distinct (xs ++ [x] ++ ys) ->
  distinct (xs ++ ys).
Proof using.
  intros.
  assert ([x] ++ ys = x :: ys) by crush.
  rewrite H0 in H.
  apply distinct_rotate_rev in H.
  apply distinct_remove in H.
  crush.
Qed.
Hint Resolve distinct_remove_middle.

Lemma in_empty :
  forall A (x : A),
  In x [] -> False.
Proof using.
  intros A.
  unfold In.
  auto.
Qed.
Hint Immediate in_empty.

Lemma distinct_rotate_front :
  forall A (x : A) y xs,
  distinct (x :: y :: xs) ->
  distinct (y :: x :: xs).
Proof using.
  intros.
  assert (x :: y :: xs = [x] ++ y :: xs) by crush.
  rewrite H0 in H.
  clear H0.
  apply distinct_rotate_rev in H.
  crush.
Qed.

Lemma distinct_concat :
  forall A (xs : list A) ys,
  distinct (xs ++ ys) ->
  distinct xs /\ distinct ys.
Proof using.
  intros A xs.
  induction xs; intros.
  - simpl in H. split; crush.
  - split. simpl in H. eapply distinct_many. crush.
    inversion H.
    * intuition.
      assert (xs = []).
      destruct xs.
      + reflexivity.
      + inversion H2.
      + crush.
    * assert (a = x) by crush.
      crush.
    * apply distinct_remove in H.
      destruct H.
      eapply IHxs in H.
      inversion H.
      assumption.
    * simpl in H.
      apply distinct_remove in H.
      destruct H.
      eapply IHxs in H.
      inversion H.
      assumption.
Qed.
Hint Resolve distinct_concat.

Lemma distinct_center :
  forall {A : Type} (xs : list A) x ys xs' ys' l l',
  distinct l ->
  l = l' ->
  l = xs ++ x :: ys ->
  l = xs' ++ x :: ys' ->
  xs = xs' /\ ys = ys'.
Proof using.
  induction xs; intros.
  - simpl in *.
    subst.
    destruct xs'.
    + crush.
    + inv H2.
      rewrite List.app_comm_cons in H.
      apply distinct_rotate_rev in H.
      inversion H; subst.
      inv H0.
      crush.
  - simpl in *.
    subst.
    destruct xs'.
    + simpl in H2.
      rewrite List.app_comm_cons in H.
      apply distinct_rotate_rev in H.
      inv H2.
      inversion H; subst.
      inv H0.
      crush.
    + simpl in *.
      inv H2.
      eapply IHxs in H3; eauto.
      * destruct H3; split; eauto; crush.
      * inversion H; crush.
Qed.


Require Import Verdi.Verdi.
Require Import Verdi.VarD.
Require Import Verdi.PartialMapSimulations.
Require Import Cheerios.Cheerios.
Require Import VerdiRaft.Raft.

Require Import VerdiRaft.CommonDefinitions.
Require Import VerdiRaft.Linearizability.
Require Import VerdiRaft.RaftLinearizableProofs.

Require Import VerdiRaft.EndToEndLinearizability.
Require Import Verdi.SerializedMsgParamsCorrect.

Require Import VerdiRaft.VarDRaftSerialized.

Section VarDSerializedCorrect.
  Variable n : nat.

  Instance raft_params : RaftParams VarD.vard_base_params :=
    raft_params n.

  Instance base_params : BaseParams :=
    transformed_base_params n.

  Instance multi_params : MultiParams _ :=
    transformed_multi_params n.

  Instance failure_params : FailureParams _ :=
    transformed_failure_params n.

  Lemma correct_input_correct_filterMap_trace_non_empty_out :
    forall tr,
      input_correct tr ->
      input_correct (filterMap trace_non_empty_out tr).
  Proof using.
    induction tr; simpl; intro H_inp; auto.
    destruct a, s; simpl.
    - assert (H_inp': input_correct tr).
        intros client id i0 i1 h h' H_in H_in'.
        eapply H_inp; right; eauto.
      concludes.
      intros client id i0 i1 h h' H_in H_in'.
      simpl in *.
      break_or_hyp; break_or_hyp.
      * find_injection; find_injection; auto.
      * find_injection.
        eapply H_inp.
        + right.
          find_apply_lem_hyp In_filterMap.
          break_exists_name e.
          break_and.
          destruct e, s; simpl in *; [ find_injection; eauto | destruct l; congruence ].
        + left; eauto.
      * find_injection.
        eapply H_inp.
        + left; eauto.
        + right.
          find_apply_lem_hyp In_filterMap.
          break_exists_name e.
          break_and.
          destruct e, s; simpl in *; [ find_injection; eauto | destruct l; congruence ].
       * eapply IHtr; eauto.
     - destruct l.
       * apply IHtr.
         intros client id i0 i1 h h' H_in H_in'.
         eapply H_inp; right; eauto.
       * assert (H_inp': input_correct tr).
           intros client id i0 i1 h h' H_in H_in'.
           eapply H_inp; right; eauto.
         concludes.
         intros client id i0 i1 h h' H_in H_in'.
         simpl in *.
         break_or_hyp; [ find_inversion | idtac ].
         break_or_hyp; [ find_inversion | idtac ].
         eapply IHtr; eauto.
  Qed.

  Lemma correct_filterMap_trace_non_empty_out_input_correct :
    forall tr,
      input_correct (filterMap trace_non_empty_out tr) ->
      input_correct tr.
  Proof using.
    induction tr; simpl; auto.
    destruct a, s; simpl; intro H_inp.
    - assert (H_inp': input_correct (filterMap trace_non_empty_out tr)).
        intros client id i0 i1 h h' H_in H_in'.
        eapply H_inp; right; eauto.
      concludes.
      intros client id i0 i1 h h' H_in H_in'.
      simpl in *.
      break_or_hyp; break_or_hyp.
      * find_injection; find_injection; auto.
      * find_injection.
        eapply H_inp; [ idtac | left; eauto ].
        right.
        eapply filterMap_In; eauto.
        simpl; eauto.
      * find_injection.
        eapply H_inp; [ left; eauto | idtac ].
        right.
        eapply filterMap_In; eauto.
        simpl; eauto.
      * eapply IHtr; eauto.
    - destruct l.
      * intros client id i0 i1 h h' H_in H_in'.
        simpl in *.
        break_or_hyp; [ find_inversion | idtac ].
        break_or_hyp; [ find_inversion | idtac ].
        eapply IHtr; eauto.
      * assert (H_inp': input_correct (filterMap trace_non_empty_out tr)).
          intros client id i0 i1 h h' H_in H_in'.
          eapply H_inp; right; eauto.
        concludes.
        intros client id i0 i1 h h' H_in H_in'.
        simpl in *.
        break_or_hyp; [ find_inversion | idtac ].
        break_or_hyp; [ find_inversion | idtac ].
        eapply IHtr; eauto.
  Qed.

  Lemma input_correct_filterMap_trace_non_empty_out :
    forall tr tr',
      input_correct tr ->
      filterMap trace_non_empty_out tr = filterMap trace_non_empty_out tr' ->
      input_correct tr'.
  Proof using.
    intros tr tr' H_in H_eq.
    apply correct_filterMap_trace_non_empty_out_input_correct.
    rewrite <- H_eq.
    apply correct_input_correct_filterMap_trace_non_empty_out; auto.
  Qed.

  Lemma get_input_tr_filterMap_trace_non_empty_out :
    forall tr,
      get_input tr = get_input (filterMap trace_non_empty_out tr).
  Proof using.
    induction tr; simpl; auto.
    destruct a, s; simpl.
    - rewrite IHtr; auto.
    - destruct l; auto.
  Qed.

  Lemma get_output_tr_filterMap_trace_non_empty_out :
    forall tr,
      get_output tr = get_output (filterMap trace_non_empty_out tr).
  Proof using.
    induction tr; simpl; auto.
    destruct a, s; simpl.
    - rewrite IHtr; auto.
    - destruct l; auto.
      rewrite IHtr; auto.
  Qed.

  Lemma exported_filterMap_trace_non_empty_out :
    forall tr tr' l tr1,
      exported (get_input tr') (get_output tr') l tr1 ->
      filterMap trace_non_empty_out tr = filterMap trace_non_empty_out tr' ->
      exported (get_input tr) (get_output tr) l tr1.
  Proof using.
    intros tr tr' l tr1 H_exp H_eq.
    rewrite get_input_tr_filterMap_trace_non_empty_out in H_exp.
    rewrite get_output_tr_filterMap_trace_non_empty_out in H_exp.
    rewrite <- H_eq in H_exp.
    rewrite <- get_input_tr_filterMap_trace_non_empty_out in H_exp.
    rewrite <- get_output_tr_filterMap_trace_non_empty_out in H_exp.
    auto.
  Qed.

  Lemma import_exported_filterMap_trace_non_empty_out :
    forall tr,
      import tr = import (filterMap trace_non_empty_out tr).
  Proof using.
    induction tr; simpl; auto.
    destruct a, s; simpl.
    - rewrite IHtr; auto.
    - rewrite IHtr.
      destruct l; auto.
  Qed.

  Lemma equivalent_filterMap_trace_non_empty_out :
    forall tr tr' l,
      equivalent key (import tr') l ->
      filterMap trace_non_empty_out tr = filterMap trace_non_empty_out tr' ->
      equivalent key (import tr) l.
  Proof using.
    intros tr tr' l H_equ H_eq.
    rewrite import_exported_filterMap_trace_non_empty_out.
    rewrite H_eq.
    rewrite <- import_exported_filterMap_trace_non_empty_out.
    auto.
  Qed.

  Theorem vard_raft_serialized_linearizable :
    forall failed net tr,
      input_correct tr ->
      step_failure_star step_failure_init (failed, net) tr ->
      exists l tr1 st,
        equivalent _ (import tr) l /\
        exported (get_input tr) (get_output tr) l tr1 /\
        step_1_star init st tr1.
  Proof using.
    intros failed net tr H_inp H_step.
    apply step_failure_deserialized_simulation_star in H_step.
    break_exists_name tr'.
    break_and.
    find_apply_lem_hyp raft_linearizable.
    - break_exists_name l.
      break_exists_name tr1.
      break_exists_name st.
      break_and.
      exists l, tr1, st.
      split.
      * eapply equivalent_filterMap_trace_non_empty_out; eauto.
      * split; auto. eapply exported_filterMap_trace_non_empty_out; eauto.
    - eapply input_correct_filterMap_trace_non_empty_out; eauto.
  Qed.
End VarDSerializedCorrect.