(* Distributed under the terms of the MIT license. *)
From Coq Require Import Morphisms.
From MetaCoq.Utils Require Import utils.
From MetaCoq.Common Require Import config.
From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICInduction
     PCUICLiftSubst PCUICSigmaCalculus PCUICTyping PCUICWeakeningEnv PCUICWeakeningEnvTyp
     PCUICWeakeningConv PCUICWeakeningTyp
     PCUICSubstitution PCUICReduction PCUICCumulativity PCUICGeneration
     PCUICUnivSubst PCUICUnivSubstitutionConv.

From Equations Require Import Equations.
Require Import Equations.Prop.DepElim.
Require Import ssreflect ssrbool.

From MetaCoq.PCUIC Require Import PCUICInduction.

Section CheckerFlags.
  Context {cf:checker_flags}.

  Lemma wf_universe_type0 Σ : wf_universe Σ Universe.type0.
  Proof using Type.
    simpl.
    intros l hin%LevelExprSet.singleton_spec.
    subst l. simpl.
    apply global_ext_levels_InSet.
  Qed.

  Lemma wf_universe_type1 Σ : wf_universe Σ Universe.type1.
  Proof using Type.
    simpl.
    intros l hin%LevelExprSet.singleton_spec.
    subst l. simpl.
    apply global_ext_levels_InSet.
  Qed.

  Lemma wf_universe_super {Σ u} : wf_universe Σ u -> wf_universe Σ (Universe.super u).
  Proof using Type.
    destruct u; cbn.
    1-2:intros _ l hin%LevelExprSet.singleton_spec; subst l; apply wf_universe_type1;
     now apply LevelExprSet.singleton_spec.
    intros Hl.
    intros l hin.
    eapply Universes.spec_map_succ in hin as [x' [int ->]].
    simpl. now specialize (Hl _ int).
  Qed.

  Lemma wf_universe_sup {Σ u u'} : wf_universe Σ u -> wf_universe Σ u' ->
    wf_universe Σ (Universe.sup u u').
  Proof using Type.
    destruct u, u'; cbn; auto.
    intros Hu Hu' l [Hl|Hl]%LevelExprSet.union_spec.
    now apply (Hu _ Hl).
    now apply (Hu' _ Hl).
  Qed.

  Lemma wf_universe_product {Σ u u'} : wf_universe Σ u -> wf_universe Σ u' ->
    wf_universe Σ (Universe.sort_of_product u u').
  Proof using Type.
    intros Hu Hu'. unfold Universe.sort_of_product.
    destruct (Universe.is_prop u' || Universe.is_sprop u'); auto.
    now apply wf_universe_sup.
  Qed.

  Hint Resolve wf_universe_type1 wf_universe_super wf_universe_sup wf_universe_product : pcuic.

  Definition wf_universeb_level Σ l :=
    LevelSet.mem l (global_ext_levels Σ).

  Definition wf_universe_level Σ l :=
    LevelSet.In l (global_ext_levels Σ).

  Definition wf_universe_instance Σ u :=
    Forall (wf_universe_level Σ) u.

  Definition wf_universeb_instance Σ u :=
    forallb (wf_universeb_level Σ) u.

  Lemma wf_universe_levelP {Σ l} : reflect (wf_universe_level Σ l) (wf_universeb_level Σ l).
  Proof using Type.
    unfold wf_universe_level, wf_universeb_level.
    destruct LevelSet.mem eqn:ls; constructor.
    now apply LevelSet.mem_spec in ls.
    intros hin.
    now apply LevelSet.mem_spec in hin.
  Qed.

  Lemma wf_universe_instanceP {Σ u} : reflect (wf_universe_instance Σ u) (wf_universeb_instance Σ u).
  Proof using Type.
    unfold wf_universe_instance, wf_universeb_instance.
    apply forallbP. intros x; apply wf_universe_levelP.
  Qed.

  Lemma wf_universe_subst_instance_univ (Σ : global_env_ext) univs u s :
    wf Σ ->
    wf_universe Σ s ->
    wf_universe_instance (Σ.1, univs) u ->
    wf_universe (Σ.1, univs) (subst_instance u s).
  Proof using Type.
    destruct s as [| |t]; cbnr.
    intros wfΣ Hl Hu e [[l n] [inl ->]]%In_subst_instance.
    destruct l as [|s|n']; simpl; auto.
    - apply global_ext_levels_InSet.
    - specialize (Hl (Level.Level s, n) inl).
      simpl in Hl.
      apply monomorphic_level_in_global_ext in Hl.
      eapply LS.union_spec. now right.
    - specialize (Hl (Level.Var n', n) inl).
      eapply LS.union_spec in Hl as [Hl|Hl].
      + red in Hu.
        unfold levels_of_udecl in Hl.
        destruct Σ.2.
        * simpl in Hu. simpl in *.
          unfold subst_instance; simpl.
          destruct nth_error eqn:hnth; simpl.
          eapply nth_error_forall in Hu; eauto.
          apply global_ext_levels_InSet.
        * unfold subst_instance. simpl.
          destruct (nth_error u n') eqn:hnth.
          2:{ simpl. rewrite hnth. apply global_ext_levels_InSet. }
          eapply nth_error_forall in Hu. 2:eauto.
          change (nth_error u n') with (nth_error u n') in *.
          rewrite -> hnth. simpl. apply Hu.
      + now apply not_var_global_levels in Hl.
  Qed.

  Lemma wf_universe_instantiate Σ univs s u φ :
    wf Σ ->
    wf_universe (Σ, univs) s ->
    wf_universe_instance (Σ, φ) u ->
    wf_universe (Σ, φ) (subst_instance_univ u s).
  Proof using Type.
    intros wfΣ Hs.
    apply (wf_universe_subst_instance_univ (Σ, univs) φ); auto.
  Qed.

  Lemma subst_instance_empty u :
    forallb (fun x => ~~ Level.is_var x) u ->
    subst_instance [] u = u.
  Proof using Type.
    induction u; simpl; intros Hu; auto.
    rewrite subst_instance_cons.
    move/andP: Hu => [] isv Hf.
    rewrite IHu //.
    now destruct a => /= //; auto.
  Qed.

  Lemma wf_universe_level_mono Σ u :
    wf Σ ->
    on_udecl_prop Σ (Monomorphic_ctx) ->
    Forall (wf_universe_level (Σ, Monomorphic_ctx)) u ->
    forallb (fun x => ~~ Level.is_var x) u.
  Proof using Type.
    intros wf uprop.
    induction 1 => /= //.
    destruct x eqn:isv => /= //.
    apply LS.union_spec in H as [H|H]; simpl in H.
    epose proof (@udecl_prop_in_var_poly _ (Σ, _) _ uprop H) as [ctx' eq].
    discriminate.
    now pose proof (not_var_global_levels wf _ H).
  Qed.

  Lemma wf_universe_level_sub Σ univs u :
    wf_universe_level (Σ, Monomorphic_ctx) u ->
    wf_universe_level (Σ, univs) u.
  Proof using cf.
    intros wfx.
    red in wfx |- *.
    eapply LevelSet.union_spec in wfx; simpl in *.
    destruct wfx as [wfx|wfx]. lsets.
    eapply LevelSet.union_spec. now right.
  Qed.

  Lemma wf_universe_instance_sub Σ univs u :
    wf_universe_instance (Σ, Monomorphic_ctx) u ->
    wf_universe_instance (Σ, univs) u.
  Proof using cf.
    intros wfu.
    red in wfu |- *.
    eapply Forall_impl; eauto.
    intros. red in H. cbn in H. eapply wf_universe_level_sub; eauto.
  Qed.

  Lemma In_Level_global_ext_poly s Σ cst :
    LS.In (Level.Level s) (global_ext_levels (Σ, Polymorphic_ctx cst)) ->
    LS.In (Level.Level s) (global_levels Σ).
  Proof using Type.
    intros [hin|hin]%LS.union_spec.
    simpl in hin.
    now apply monomorphic_level_notin_AUContext in hin.
    apply hin.
  Qed.

  Lemma Forall_In (A : Type) (P : A -> Prop) (l : list A) :
    Forall P l -> (forall x : A, In x l -> P x).
  Proof using Type.
    induction 1; simpl; auto.
    intros x' [->|inx]; auto.
  Qed.

  Lemma wf_universe_instance_In {Σ u} : wf_universe_instance Σ u <->
    (forall l, In l u -> LS.In l (global_ext_levels Σ)).
  Proof using Type.
    unfold wf_universe_instance.
    split; intros. eapply Forall_In in H; eauto.
    apply In_Forall. auto.
  Qed.

  Lemma in_subst_instance l u u' :
    In l (subst_instance u u') ->
    In l u \/ In l u' \/ l = Level.lzero.
  Proof using Type.
    induction u'; simpl; auto.
    intros [].
    destruct a; simpl in *; subst; auto.
    destruct (nth_in_or_default n u Level.lzero); auto.
    specialize (IHu' H). intuition auto.
  Qed.

  Lemma wf_universe_subst_instance Σ univs u u' φ :
    wf Σ ->
    on_udecl_prop Σ univs ->
    wf_universe_instance (Σ, univs) u' ->
    wf_universe_instance (Σ, φ) u ->
    wf_universe_instance (Σ, φ) (subst_instance u u').
  Proof using Type.
    intros wfΣ onup Hs cu.
    destruct univs.
    - red in Hs |- *.
      unshelve epose proof (wf_universe_level_mono _ _ _ _ Hs); eauto.
      eapply forallb_Forall in H. apply Forall_map.
      solve_all. destruct x; simpl => //.
      red. apply global_ext_levels_InSet.
      eapply wf_universe_level_sub; eauto.
    - clear onup.
      red in Hs |- *.
      eapply Forall_map, Forall_impl; eauto.
      intros x wfx.
      red in wfx. destruct x => /= //.
      { red. apply global_ext_levels_InSet. }
      eapply In_Level_global_ext_poly in wfx.
      apply LS.union_spec; now right.
      eapply in_var_global_ext in wfx; simpl in wfx; auto.
      unfold AUContext.levels, AUContext.repr in wfx.
      destruct cst as [? cst].
      rewrite mapi_unfold in wfx.
      eapply (proj1 (LevelSetProp.of_list_1 _ _)) in wfx.
      apply SetoidList.InA_alt in wfx as [? [<- wfx]]. simpl in wfx.
      eapply In_unfold_inj in wfx; [|congruence].
      destruct (nth_in_or_default n u (Level.lzero)).
      red in cu. eapply Forall_In in cu; eauto. rewrite e.
      red. apply global_ext_levels_InSet.
  Qed.

  Section WfUniverses.
    Context (Σ : global_env_ext).

    Definition wf_universeb (s : Universe.t) : bool :=
      match s with
      | Universe.lType l => LevelExprSet.for_all (fun l => LevelSet.mem (LevelExpr.get_level l) (global_ext_levels Σ)) l
      | _ => true
      end.

    Lemma wf_universe_reflect {u : Universe.t} :
      reflect (wf_universe Σ u) (wf_universeb u).
    Proof using Type.
      destruct u; simpl; try now constructor.
      eapply iff_reflect.
      rewrite LevelExprSet.for_all_spec.
      split; intros.
      - intros l Hl; specialize (H l Hl).
        now eapply LS.mem_spec.
      - specialize (H l H0). simpl in H.
        now eapply LS.mem_spec in H.
    Qed.

    Fixpoint on_universes fu fc t :=
      match t with
      | tSort s => fu s
      | tApp t u
      | tProd _ t u
      | tLambda _ t u => on_universes fu fc t && on_universes fu fc u
      | tCase _ p c brs =>
        [&&
        forallb fu (map Universe.make p.(puinst)) ,
        forallb (on_universes fu fc) p.(pparams) ,
        test_context (fc #|p.(puinst)|) p.(pcontext) ,
        on_universes fu fc p.(preturn) ,
        on_universes fu fc c &
        forallb (test_branch (fc #|p.(puinst)|) (on_universes fu fc)) brs ]
      | tLetIn _ t t' u =>
        [&& on_universes fu fc t , on_universes fu fc t' & on_universes fu fc u]
      | tProj _ t => on_universes fu fc t
      | tFix mfix _ | tCoFix mfix _ =>
        forallb (fun d => on_universes fu fc d.(dtype) && on_universes fu fc d.(dbody)) mfix
      | tConst _ u | tInd _ u | tConstruct _ _ u =>
          forallb fu (map Universe.make u)
      | tEvar _ args => forallb (on_universes fu fc) args
      | _ => true
      end.

    Definition wf_universes t := on_universes wf_universeb closedu t.

    Lemma wf_universeb_instance_forall u :
      forallb wf_universeb (map Universe.make u) = wf_universeb_instance Σ u.
    Proof using Type.
      induction u => //=.
      rewrite IHu.
      f_equal.
      cbn.
      now rewrite if_true_false.
    Qed.

    (* Lemma All_forallb {A} (P : A -> Type) l (H : All P l) p p' : (forall x, P x -> p x = p' x) -> forallb p l = forallb p' l.
    Proof.
      intros; induction H; simpl; auto.
      now rewrite IHAll H0.
    Qed. *)

    Lemma test_context_mapi (p : term -> bool) f (ctx : context) k :
  test_context p (mapi_context (shiftf f k) ctx) = test_context_k (fun k => p ∘ f k) k ctx.
Proof using Type.
  induction ctx; simpl; auto.
  rewrite IHctx. f_equal.
  now rewrite test_decl_map_decl.
Qed.
Hint Rewrite test_context_mapi : map.

Lemma test_context_k_ctx (p : term -> bool) (ctx : context) k :
  test_context p ctx = test_context_k (fun k => p) k ctx.
Proof using Type.
  induction ctx; simpl; auto.
Qed.

    Lemma on_universes_lift pu pc n k t : on_universes pu pc (lift n k t) = on_universes pu pc t.
    Proof using Type.
      induction t in n, k |- * using term_forall_list_ind; simpl ; auto ; try
        rewrite ?IHt1 ?IHt2 ?IHt3; auto.
      - solve_all.
      - destruct X as [? [? ?]]. solve_all.
        rewrite IHt.
        f_equal.
        f_equal ; [now solve_all|..].
        f_equal.
        f_equal ; [now rewrite /id e|..].
        f_equal.
        solve_all.
        rewrite /test_branch. rewrite b. f_equal.
      - rewrite forallb_map.
        eapply All_forallb_eq_forallb; eauto. simpl; intros [].
        simpl. intros. cbn. now rewrite H.
      - rewrite forallb_map.
        eapply All_forallb_eq_forallb; eauto. simpl; intros [].
        simpl. intros. cbn. now rewrite H.
    Qed.

    Corollary wf_universes_lift n k t : wf_universes (lift n k t) = wf_universes t.
    Proof using Type.
      by apply on_universes_lift.
    Qed.

    Lemma on_universes_subst s k pu pc t :
      All (on_universes pu pc) s ->
      on_universes pu pc (subst s k t) = on_universes pu pc t.
    Proof using Type.
      intros Hs.
      induction t in k |- * using term_forall_list_ind; simpl; auto; try
        rewrite ?IHt1 ?IHt2 ?IHt3; auto.
      - destruct (Nat.leb_spec k n); auto.
        destruct nth_error eqn:nth; simpl; auto.
        eapply nth_error_all in nth; eauto.
        simpl in nth. intros. now rewrite on_universes_lift.
      - solve_all.
      - destruct X as [? [? ?]]. solve_all.
        rewrite IHt.
        f_equal.
        f_equal ; [now solve_all|..].
        f_equal.
        f_equal ; [now rewrite /id e|..].
        f_equal.
        solve_all.
        rewrite /test_branch. rewrite b. f_equal.
      - rewrite forallb_map.
        eapply All_forallb_eq_forallb; eauto. simpl; intros [].
        simpl. intros. cbn. now rewrite H.
      - rewrite forallb_map.
        eapply All_forallb_eq_forallb; eauto. simpl; intros [].
        simpl. intros. cbn. now rewrite H.
    Qed.

    Corollary wf_universes_subst s k t :
      All wf_universes s ->
      wf_universes (subst s k t) = wf_universes t.
    Proof using Type.
      by apply on_universes_subst.
    Qed.

  End WfUniverses.
  Arguments wf_universe_reflect {Σ u}.

  Ltac to_prop :=
    repeat match goal with
    | [ H: is_true (?x && ?y) |- _ ] =>
     let x := fresh in let y := fresh in move/andP: H; move=> [x y]; rewrite ?x ?y; simpl
    end.

  Ltac to_wfu :=
    repeat match goal with
    | [ H: is_true (wf_universeb _ ?x) |- _ ] => apply (elimT (@wf_universe_reflect _ x)) in H
    | [ |- is_true (wf_universeb _ ?x) ] => apply (introT (@wf_universe_reflect _ x))
    end.

  Lemma wf_universes_inst {Σ : global_env_ext} univs t u :
    wf Σ ->
    on_udecl_prop Σ.1 univs ->
    wf_universe_instance Σ u  ->
    wf_universes (Σ.1, univs) t ->
    wf_universes Σ (subst_instance u t).
  Proof using Type.
    intros wfΣ onudecl cu wft.
    induction t using term_forall_list_ind; simpl in *; auto; try to_prop;
      try apply /andP; to_wfu; intuition eauto 4.

    all:cbn in * ; autorewrite with map; repeat (f_equal; solve_all).

    - to_wfu. destruct Σ as [Σ univs']. simpl in *.
      eapply (wf_universe_subst_instance_univ (Σ, univs)); auto.

    - apply forallb_All.
      rewrite -forallb_map wf_universeb_instance_forall.
      apply All_forallb in wft.
      rewrite -forallb_map wf_universeb_instance_forall in wft.
      apply/wf_universe_instanceP.
      eapply wf_universe_subst_instance; eauto.
      destruct Σ; simpl in *.
      now move/wf_universe_instanceP: wft.
    - apply forallb_All.
      rewrite -forallb_map wf_universeb_instance_forall.
      apply All_forallb in wft.
      rewrite -forallb_map wf_universeb_instance_forall in wft.
      apply/wf_universe_instanceP.
      eapply wf_universe_subst_instance; eauto.
      destruct Σ; simpl in *.
      now move/wf_universe_instanceP: wft.
    - apply forallb_All.
      rewrite -forallb_map wf_universeb_instance_forall.
      apply All_forallb in wft.
      rewrite -forallb_map wf_universeb_instance_forall in wft.
      apply/wf_universe_instanceP.
      eapply wf_universe_subst_instance; eauto.
      destruct Σ; simpl in *.
      now move/wf_universe_instanceP: wft.

    - apply forallb_All.
      rewrite -forallb_map wf_universeb_instance_forall.
      apply All_forallb in H.
      rewrite -forallb_map wf_universeb_instance_forall in H.
      apply/wf_universe_instanceP.
      eapply wf_universe_subst_instance; eauto.
      destruct Σ ; simpl in *.
      now move/wf_universe_instanceP: H.

    - now len.
    - rewrite /test_branch. rtoProp.
      move/andP: a => [] tctx wfu.
      split; auto. simpl.
      solve_all. now len.
  Qed.

  Lemma weaken_wf_universe Σ Σ' t : wf Σ' -> extends Σ.1 Σ' ->
    wf_universe Σ t ->
    wf_universe (Σ', Σ.2) t.
  Proof using Type.
    intros wfΣ ext.
    destruct t; simpl; auto.
    intros Hl l inl; specialize (Hl l inl).
    apply LS.union_spec. apply LS.union_spec in Hl as [Hl|Hl]; simpl.
    left; auto.
    right. now eapply global_levels_sub; [apply ext|].
  Qed.

  Lemma weaken_wf_universe_level {Σ : global_env_ext} Σ' t : wf Σ -> wf Σ' -> extends Σ Σ' ->
    wf_universe_level Σ t ->
    wf_universe_level (Σ', Σ.2) t.
  Proof using Type.
    intros wfΣ wfΣ' ext.
    unfold wf_universe_level.
    destruct t; simpl; auto using global_ext_levels_InSet;
    intros; apply LS.union_spec.
    - eapply LS.union_spec in H as [H|H].
      left; auto.
      right; auto. simpl.
      eapply global_levels_sub. apply ext. apply H.
    - cbn. eapply in_var_global_ext in H; eauto.
  Qed.

  Lemma weaken_wf_universe_instance {Σ : global_env_ext} Σ' t : wf Σ -> wf Σ' -> extends Σ.1 Σ' ->
    wf_universe_instance Σ t ->
    wf_universe_instance (Σ', Σ.2) t.
  Proof using Type.
    intros wfΣ wfΣ' ext.
    unfold wf_universe_instance.
    intros H; eapply Forall_impl; eauto.
    intros. now eapply weaken_wf_universe_level.
  Qed.

  Lemma weaken_wf_universes {Σ : global_env_ext} Σ' t : wf Σ -> wf Σ' -> extends Σ.1 Σ' ->
    wf_universes Σ t ->
    wf_universes (Σ', Σ.2) t.
  Proof using Type.
    intros wfΣ wfΣ' ext.
    induction t using term_forall_list_ind; cbn in *; auto; intros; to_prop;
    try apply /andP; to_wfu; intuition eauto 4.

  - solve_all.
  - now eapply weaken_wf_universe.
  - eapply forallb_impl ; tea.
    now move => ? _ /wf_universe_reflect /weaken_wf_universe /wf_universe_reflect.
  - eapply forallb_impl ; tea.
    now move => ? _ /wf_universe_reflect /weaken_wf_universe /wf_universe_reflect.
  - eapply forallb_impl ; tea.
    now move => ? _ /wf_universe_reflect /weaken_wf_universe /wf_universe_reflect.
  - eapply forallb_impl ; tea.
    now move => ? _ /wf_universe_reflect /weaken_wf_universe /wf_universe_reflect.
  - red in X.
    solve_all.
    rewrite /test_branch in b |- *.
    rtoProp.
    intuition.
  - red in X; solve_all.
  - red in X. solve_all.
  Qed.

  Lemma wf_universes_weaken_full : weaken_env_prop_full cumulSpec0 (lift_typing typing) (fun Σ Γ t T =>
      wf_universes Σ t && wf_universes Σ T).
  Proof using Type.
    do 2 red. intros.
    to_prop; apply /andP; split; now apply weaken_wf_universes.
  Qed.

  Lemma wf_universes_weaken :
    weaken_env_prop cumulSpec0 (lift_typing typing)
      (lift_typing (fun Σ Γ (t T : term) =>
        wf_universes Σ t && wf_universes Σ T)).
  Proof using Type.
    intros Σ Σ' φ wfΣ wfΣ' Hext Γ t T HT.
    apply lift_typing_impl with (1 := HT); intros ? Hty.
    now eapply (wf_universes_weaken_full (Σ, _)).
  Qed.

  Lemma wf_universes_inds Σ mind u bodies :
    wf_universe_instance Σ u ->
    All (fun t : term => wf_universes Σ t) (inds mind u bodies).
  Proof using Type.
    intros wfu.
    unfold inds.
    generalize #|bodies|.
    induction n; simpl; auto.
    constructor; auto.
    cbn.
    rewrite wf_universeb_instance_forall.
    now apply /wf_universe_instanceP.
  Qed.

  Lemma wf_universes_mkApps Σ f args :
    wf_universes Σ (mkApps f args) = wf_universes Σ f && forallb (wf_universes Σ) args.
  Proof using Type.
    induction args using rev_ind; simpl; auto. now rewrite andb_true_r.
    now rewrite mkApps_app forallb_app /= andb_true_r andb_assoc -IHargs.
  Qed.

  Lemma type_local_ctx_wf Σ Γ Δ s : type_local_ctx
    (lift_typing
     (fun (Σ : PCUICEnvironment.global_env_ext)
        (_ : PCUICEnvironment.context) (t T : term) =>
      wf_universes Σ t && wf_universes Σ T)) Σ Γ Δ s ->
      All (fun d => option_default (wf_universes Σ) (decl_body d) true && wf_universes Σ (decl_type d)) Δ.
  Proof using Type.
    induction Δ as [|[na [b|] ty] ?]; simpl; constructor; auto.
    simpl.
    destruct X as [? [? ?]]. now to_prop.
    apply IHΔ. apply X.
    simpl.
    destruct X as [? ?]. now to_prop.
    apply IHΔ. apply X.
  Qed.

  Lemma consistent_instance_ext_wf Σ univs u : consistent_instance_ext Σ univs u ->
    wf_universe_instance Σ u.
  Proof using Type.
    destruct univs; simpl.
    - destruct u => // /=.
      intros _. constructor.
    - intros [H%forallb_Forall [H' H'']].
      eapply Forall_impl; eauto.
      simpl; intros. now eapply LS.mem_spec in H0.
  Qed.

  Ltac specIH :=
    repeat match goal with
    | [ H : on_udecl _ _, H' : on_udecl _ _ -> _ |- _ ] => specialize (H' H)
    end.

  Local Lemma wf_sorts_local_ctx_smash (Σ : global_env_ext) mdecl args sorts :
    sorts_local_ctx
    (lift_typing
       (fun (Σ : PCUICEnvironment.global_env_ext)
          (_ : PCUICEnvironment.context) (t T : term) =>
        wf_universes Σ t && wf_universes Σ T)) (Σ.1, ind_universes mdecl)
    (arities_context (ind_bodies mdecl),,, ind_params mdecl)
    args sorts ->
    sorts_local_ctx
    (lift_typing
       (fun (Σ : PCUICEnvironment.global_env_ext)
          (_ : PCUICEnvironment.context) (t T : term) =>
        wf_universes Σ t && wf_universes Σ T)) (Σ.1, ind_universes mdecl)
    (arities_context (ind_bodies mdecl),,, ind_params mdecl)
    (smash_context [] args) sorts.
  Proof using Type.
    induction args as [|[na [b|] ty] args] in sorts |- *; simpl; auto.
    intros [].
    rewrite subst_context_nil. auto.
    destruct sorts; auto.
    intros [].
    rewrite smash_context_acc /=. split. eauto.
    rewrite wf_universes_subst.
    clear -s. generalize 0.
    induction args as [|[na [b|] ty] args] in sorts, s |- *; simpl in *; auto.
    - destruct s as [? [[s' wf] [? ?]%andb_and]].
      constructor; eauto.
      rewrite wf_universes_subst. eapply IHargs; eauto.
      now rewrite wf_universes_lift.
    - destruct sorts => //. destruct s.
      constructor => //. eapply IHargs; eauto.
    - now rewrite wf_universes_lift.
  Qed.

  Lemma wf_sorts_local_ctx_nth_error Σ P Γ Δ s n d :
    sorts_local_ctx P Σ Γ Δ s ->
    nth_error Δ n = Some d ->
    ∑ Γ' t, P Σ Γ' (decl_type d) t.
  Proof using Type.
    induction Δ as [|[na [b|] ty] Δ] in n, s |- *; simpl; auto.
    - now rewrite nth_error_nil.
    - intros [h [h' h'']].
      destruct n. simpl. move=> [= <-] /=. do 2 eexists; eauto.
      now simpl; eapply IHΔ.
    - destruct s => //. intros [h h'].
      destruct n. simpl. move=> [= <-] /=. eexists; eauto.
      now simpl; eapply IHΔ.
  Qed.

  Lemma In_unfold_var x n : In x (unfold n Level.Var) <-> exists k, k < n /\ (x = Level.Var k).
  Proof using Type.
    split.
    - induction n => /= //.
      intros [hin|hin]%in_app_or.
      destruct (IHn hin) as [k [lt eq]].
      exists k; auto.
      destruct hin => //. subst x.
      eexists; eauto.
    - intros [k [lt ->]].
      induction n in k, lt |- *. lia.
      simpl. apply in_or_app.
      destruct (lt_dec k n). left; auto.
      right. left. f_equal. lia.
  Qed.

  Lemma wf_abstract_instance Σ decl :
    wf_universe_instance (Σ, decl) (abstract_instance decl).
  Proof using Type.
    destruct decl as [|[u cst]]=> /= //.
    red. constructor.
    rewrite /UContext.instance /AUContext.repr /=.
    rewrite mapi_unfold.
    red. eapply In_Forall.
    intros x hin. eapply In_unfold_var in hin as [k [lt eq]].
    subst x. red.
    eapply LS.union_spec; left. simpl.
    rewrite /AUContext.levels /= mapi_unfold.
    eapply (proj2 (LevelSetProp.of_list_1 _ _)).
    apply SetoidList.InA_alt. eexists; split; eauto.
    eapply In_unfold_var. exists k; split; eauto.
  Qed.

  Definition on_decl_universes (fu : Universe.t -> bool) (fc : nat -> term -> bool) d :=
      option_default (on_universes fu fc) d.(decl_body) true &&
      on_universes fu fc d.(decl_type).

  Definition wf_decl_universes Σ := on_decl_universes (wf_universeb Σ) closedu.

  Definition on_ctx_universes (fu : Universe.t -> bool) (fc : nat -> term -> bool) Γ :=
    forallb (on_decl_universes fu fc) Γ.

  Definition wf_ctx_universes Σ Γ :=
    forallb (wf_decl_universes Σ) Γ.

  Lemma wf_universes_it_mkProd_or_LetIn {Σ Γ T} :
    wf_universes Σ (it_mkProd_or_LetIn Γ T) = wf_ctx_universes Σ Γ && wf_universes Σ T.
  Proof using Type.
    induction Γ as [ |[na [b|] ty] Γ] using rev_ind ; simpl; auto;
    rewrite it_mkProd_or_LetIn_app {1}/wf_universes /=
    -!/(wf_universes _ _) IHΓ /wf_ctx_universes forallb_app /=
    {3}/wf_decl_universes -!/(wf_universes _ _) / on_decl_universes /= /wf_universes;
    repeat bool_congr.

  Qed.

  Lemma test_context_app p Γ Δ :
    test_context p (Γ ,,, Δ) = test_context p Γ && test_context p Δ.
  Proof using Type.
    induction Δ; simpl; auto.
    - now rewrite andb_true_r.
    - now rewrite IHΔ andb_assoc.
  Qed.

  Lemma wf_universes_it_mkLambda_or_LetIn {Σ Γ T} :
    wf_universes Σ (it_mkLambda_or_LetIn Γ T) = test_context (wf_universes Σ) Γ && wf_universes Σ T.
  Proof using Type.
    induction Γ as [ |[na [b|] ty] Γ] using rev_ind; simpl; auto;
    now rewrite it_mkLambda_or_LetIn_app {1}/wf_universes
      /= -!/(wf_universes _ _) IHΓ test_context_app /= /test_decl /= ;
    repeat bool_congr.
  Qed.

  Lemma wf_projs Σ ind npars p :
    All (fun t : term => wf_universes Σ t) (projs ind npars p).
  Proof using Type.
    induction p; simpl; auto.
  Qed.

  Lemma wf_extended_subst Σ Γ n :
    wf_ctx_universes Σ Γ ->
    All (fun t : term => wf_universes Σ t) (extended_subst Γ n).
  Proof using Type.
    induction Γ as [|[na [b|] ty] Γ] in n |- *; simpl; auto.
    move=> /andP []; rewrite /wf_decl_universes /= => /andP [] wfb wfty wfΓ.
    constructor; eauto. rewrite wf_universes_subst //. now apply IHΓ.
    now rewrite wf_universes_lift. eauto.
    move=> /andP []; rewrite /wf_decl_universes /= => wfty wfΓ.
    constructor; eauto.
  Qed.

  Lemma closedu_compare_decls k Γ Δ :
    All2 (PCUICEquality.compare_decls eq eq) Γ Δ ->
    test_context (closedu k) Γ = test_context (closedu k) Δ.
  Proof using Type.
    induction 1; cbn; auto.
    f_equal; auto. destruct r; subst; auto.
  Qed.

  Lemma closedu_mkApps k f args : closedu k (mkApps f args) = closedu k f && forallb (closedu k) args.
  Proof using Type.
    induction args in f |- *; cbn; auto. ring.
    rewrite IHargs /=. ring.
  Qed.

  Lemma closedu_abstract_instance univs : closedu_instance #|abstract_instance univs| (abstract_instance univs).
  Proof using Type.
    destruct univs as [|[l csts]] => // /=.
    rewrite /UContext.instance /AUContext.repr.
    rewrite /closedu_instance forallb_mapi //.
    intros i hi. cbn; len. now eapply Nat.ltb_lt.
  Qed.

  Notation closedu_ctx k := (test_context (closedu k)).

  Lemma closedu_lift k n k' t :
    closedu k (lift n k' t) = closedu k t.
  Proof using Type.
    induction t in k' |- * using term_forall_list_ind; cbn; auto; intros; solve_all.
    - rewrite IHt.
      rewrite /map_predicate_k /= /test_predicate /test_predicate_ku /= /id.
      f_equal. f_equal. rewrite e. f_equal. f_equal. f_equal.
      solve_all.
      solve_all.
      rewrite /map_branch_k /test_branch /=. f_equal.
      now rewrite b.
    - rewrite /test_def /map_def /=. now rewrite a b.
    - rewrite /test_def /map_def /=. now rewrite a b.
  Qed.

  Ltac try_hyp :=
    multimatch goal with H : _ |- _ => eapply H end.

  Ltac crush := repeat (solve_all; try try_hyp; cbn).

  Lemma closedu_subst k s k' t :
    forallb (closedu k) s && closedu k t ->
    closedu k (subst s k' t).
  Proof using Type.
    Ltac t := repeat (solve_all; try try_hyp).
    induction t in k' |- * using term_forall_list_ind; cbn; auto; intros;
      try solve [t].
    - destruct Nat.leb => //.
      destruct nth_error eqn:eq => //.
      rewrite closedu_lift.
      eapply nth_error_forallb in eq; tea. solve_all.
    - unfold test_predicate_ku in *. unfold test_branch in *. crush.
    - unfold test_def in *; crush.
    - unfold test_def in *; crush.
  Qed.

  Lemma closedu_subst_context k s k' Γ :
    forallb (closedu k) s && closedu_ctx k Γ ->
    closedu_ctx k (subst_context s k' Γ).
  Proof using Type.
    rewrite /subst_context.
    induction Γ.
    * cbn; auto.
    * rtoProp. intros []. cbn in H0. rtoProp.
      rewrite fold_context_k_snoc0 /= IHΓ //. crush.
      unfold test_decl in *. crush.
      destruct decl_body eqn:heq => /= //.
      rewrite closedu_subst //. crush.
      rewrite closedu_subst //. crush.
  Qed.

  Lemma closedu_lift_context k n k' Γ :
    closedu_ctx k (lift_context n k' Γ) = closedu_ctx k Γ.
  Proof using Type.
    rewrite /lift_context.
    induction Γ.
    * cbn; auto.
    * rtoProp.
      rewrite fold_context_k_snoc0 /= IHΓ //.
      unfold test_decl in *.
      cbn.
      rewrite closedu_lift.
      destruct (decl_body a) => /= //.
      rewrite closedu_lift //.
  Qed.

  Lemma closedu_extended_subst k Γ k' :
    closedu_ctx k Γ ->
    forallb (closedu k) (extended_subst Γ k').
  Proof using Type.
    induction Γ in k' |- *; cbn; auto. destruct a as [na [b|] ty] => /= //.
    unfold test_decl; move/andP=> [] clΓ /= cld. apply/andP. split.
    eapply closedu_subst. rewrite IHΓ // /= closedu_lift. crush.
    now rewrite IHΓ.
    unfold test_decl; move/andP=> [] clΓ /= cld. now apply IHΓ.
  Qed.

  Lemma closedu_expand_lets_ctx k Γ Δ :
    closedu_ctx k Γ && closedu_ctx k Δ ->
    closedu_ctx k (expand_lets_ctx Γ Δ).
  Proof using Type.
    rewrite /expand_lets_ctx /expand_lets_k_ctx.
    move/andP => [] clΓ clΔ.
    apply closedu_subst_context.
    rewrite closedu_extended_subst // /= closedu_lift_context //.
  Qed.

  Lemma closedu_smash_context_gen k Γ Δ :
    closedu_ctx k Γ -> closedu_ctx k Δ ->
    closedu_ctx k (smash_context Γ Δ).
  Proof using Type.
    induction Δ in Γ |- *; cbn; auto.
    move=> clΓ /andP[] clΔ cla.
    destruct a as [na [b|] ty] => //.
    - apply IHΔ => //. apply closedu_subst_context => /= //.
      now move/andP: cla => [] /= -> clty.
    - apply IHΔ => //.
      now rewrite test_context_app clΓ /= andb_true_r.
  Qed.

  Lemma closedu_smash_context k Δ :
    closedu_ctx k Δ ->
    closedu_ctx k (smash_context [] Δ).
  Proof using Type.
    apply closedu_smash_context_gen => //.
  Qed.

  Lemma wf_universe_level_closed {Σ : global_env} {wfΣ : wf Σ} univs u :
    on_udecl_prop Σ univs ->
    wf_universe_level (Σ, univs) u -> closedu_level #|polymorphic_instance univs| u.
  Proof using Type.
    intros ond Ht; destruct u => //.
    cbn in Ht. unfold closedu_universe, closedu_universe_levels.
    cbn. red in Ht.
    eapply in_var_global_ext in Ht => //.
    cbn in Ht.
    destruct (udecl_prop_in_var_poly (Σ := (Σ, univs)) ond Ht) as [ctx eq].
    cbn in eq. subst univs.
    cbn in Ht. cbn. unfold AUContext.levels in Ht.
    eapply (proj1 (LevelSetProp.of_list_1 _ _)) in Ht.
    eapply InA_In_eq in Ht.
    destruct ctx as [names cstrs].
    unfold AUContext.repr in Ht |- *. cbn in *. len.
    rewrite mapi_unfold in Ht. eapply In_unfold_var in Ht as [k []].
    eapply Nat.leb_le. noconf H0. lia.
  Qed.

  Lemma wf_universe_closed {Σ : global_env} {wfΣ : wf Σ} univs u :
    on_udecl_prop Σ univs ->
    wf_universe (Σ, univs) u -> closedu #|polymorphic_instance univs| (tSort u).
  Proof using Type.
    intros ond Ht; destruct u => //.
    cbn in Ht. unfold closedu_universe, closedu_universe_levels.
    eapply LevelExprSet.for_all_spec.
    intros x y ?; subst; auto.
    intros i hi. specialize (Ht i hi).
    unfold closedu_level_expr.
    apply wf_universe_level_closed => //.
  Qed.

  Lemma wf_universe_instance_closed {Σ : global_env} {wfΣ : wf Σ} {univs u} :
    on_udecl_prop Σ univs ->
    wf_universe_instance (Σ, univs) u ->
    closedu_instance #|polymorphic_instance univs| u.
  Proof using Type.
    intros ond Ht.
    red in Ht. unfold closedu_instance. solve_all.
    now eapply wf_universe_level_closed.
  Qed.

  Lemma wf_universes_closedu {Σ : global_env} {wfΣ : wf Σ} {univs t} :
    on_udecl_prop Σ univs ->
    wf_universes (Σ, univs) t -> closedu #|polymorphic_instance univs| t.
  Proof using Type.
    intros ond. induction t using term_forall_list_ind; cbn => //; solve_all.
    - apply wf_universe_closed => //.
      now move/wf_universe_reflect: H.
    - eapply wf_universe_instance_closed => //.
      apply All_forallb in H.
      rewrite -forallb_map wf_universeb_instance_forall in H.
      now move/wf_universe_instanceP: H.
    - eapply wf_universe_instance_closed => //.
      apply All_forallb in H.
      rewrite -forallb_map wf_universeb_instance_forall in H.
      now move/wf_universe_instanceP: H.
    - eapply wf_universe_instance_closed => //.
      apply All_forallb in H.
      rewrite -forallb_map wf_universeb_instance_forall in H.
      now move/wf_universe_instanceP: H.
    - unfold test_predicate_ku in *; solve_all.
      eapply wf_universe_instance_closed => //.
      apply All_forallb in H0.
      rewrite -forallb_map wf_universeb_instance_forall in H0.
      now move/wf_universe_instanceP: H0.
    - unfold test_branch in *; solve_all.
    - unfold test_def in *; solve_all.
    - unfold test_def in *; solve_all.
  Qed.

  Lemma wf_ctx_universes_closed {Σ} {wfΣ : wf Σ} {univs ctx} :
    on_udecl_prop Σ univs ->
    wf_ctx_universes (Σ, univs) ctx ->
    closedu_ctx #|polymorphic_instance univs| ctx.
  Proof using Type.
    intros ond. induction ctx => //.
    rewrite /wf_ctx_universes /= => /andP[] wfa wfctx.
    rewrite IHctx // /=.
    unfold wf_decl_universes, test_decl in *.
    destruct a as [na [b|] ty]; cbn in *.
    move/andP: wfa => [].
    now do 2 move/(wf_universes_closedu ond) => ->.
    now move/(wf_universes_closedu ond): wfa => ->.
  Qed.

  Lemma closedu_reln k Γ k' acc :
    closedu_ctx k Γ ->
    forallb (closedu k) acc ->
    forallb (closedu k) (reln acc k' Γ).
  Proof using Type.
    induction Γ in acc, k' |- *; cbn; auto.
    destruct a as [na [b|] ty] => /= //.
    - unfold test_decl; move/andP=> [] clΓ /= cld. now eapply IHΓ.
    - unfold test_decl; move/andP=> [] clΓ /= cld clacc; now apply IHΓ => //.
  Qed.

  Lemma closedu_to_extended_list_k k Γ k' :
    closedu_ctx k Γ ->
    forallb (closedu k) (to_extended_list_k Γ k').
  Proof using Type.
    intros clΓ. apply closedu_reln => //.
  Qed.

  Lemma closed_ind_predicate_context {Σ ind mdecl idecl} {wfΣ : wf Σ} :
    declared_inductive Σ ind mdecl idecl ->
    closedu_ctx #|polymorphic_instance (ind_universes mdecl)|
        (ind_params mdecl) ->
    closedu_ctx #|polymorphic_instance (ind_universes mdecl)|
            (ind_indices idecl) ->
    test_context (closedu #|abstract_instance (ind_universes mdecl)|) (ind_predicate_context ind mdecl idecl).
  Proof using Type.
    intros decli.
    rewrite /ind_predicate_context; cbn.
    rewrite closedu_mkApps /=.
    rewrite closedu_abstract_instance /= => clpars clinds.
    apply/andP; split.
    * apply closedu_expand_lets_ctx. now rewrite clpars clinds.
    * apply closedu_to_extended_list_k.
      rewrite test_context_app.
      rewrite (closedu_smash_context _ _ clpars).
      apply closedu_expand_lets_ctx => //.
      now rewrite clpars.
  Qed.

  Lemma closedu_inds {Σ ind mdecl} {wfΣ : wf Σ} :
    forallb (closedu #|abstract_instance (ind_universes mdecl)|)
      (inds ind (abstract_instance (ind_universes mdecl)) (ind_bodies mdecl)).
  Proof using Type.
    rewrite /inds.
    induction #|ind_bodies mdecl|; cbn; auto.
    rewrite IHn andb_true_r.
    eapply closedu_abstract_instance.
  Qed.

  Theorem wf_types :
    env_prop (fun Σ Γ t T =>
      wf_universes Σ t && wf_universes Σ T)
      (fun Σ Γ =>
      All_local_env
      (lift_typing (fun (Σ : global_env_ext) (Γ : context) (t T : term) =>
         wf_universes Σ t && wf_universes Σ T) Σ) Γ ×
         test_context (wf_universes Σ) Γ).
  Proof using Type.
    apply typing_ind_env; intros; rename_all_hyps; cbn; rewrite -!/(wf_universes _ _) ;
    specIH; to_prop;
    cbn; auto.

    - split.
      * induction X; constructor; auto.
        destruct tu as [s tu]; exists s; simpl.
        now simpl in Hs.
        destruct tu as [s tu]; exists s; simpl.
        now simpl in Hs.
      * induction X; simpl; auto.
        rewrite IHX /= /test_decl /=. now move/andP: Hs.

    - rewrite wf_universes_lift.
      destruct X as [X _].
      pose proof (nth_error_Some_length heq_nth_error).
      eapply nth_error_All_local_env in X; tea.
      rewrite heq_nth_error /= in X. red in X.
      destruct decl as [na [b|] ty]; cbn -[skipn] in *.
      + now to_prop.
      + destruct X as [s Hs]. now to_prop.

    - apply/andP; split; to_wfu; cbn ; eauto with pcuic.

    - cbn in *; to_wfu ; eauto with pcuic.
    - rewrite wf_universes_subst. constructor. to_wfu; auto. constructor.
      now move/andP: H4 => [].

    - apply/andP; split.
      { rewrite wf_universeb_instance_forall.
        apply/wf_universe_instanceP.
        eapply consistent_instance_ext_wf; eauto. }
      pose proof (declared_constant_inv _ _ _ _ wf_universes_weaken wf X H).
      red in X1; cbn in X1.
      unshelve eapply declared_constant_to_gen in H; eauto.
      destruct (cst_body decl).
      * to_prop.
        epose proof (weaken_lookup_on_global_env' Σ.1 _ _ wf H).
        eapply wf_universes_inst. 2:eauto. all:eauto.
        simpl in H2.
        now eapply consistent_instance_ext_wf.
      * move: X1 => [s /andP[Hc _]].
        to_prop.
        eapply wf_universes_inst; eauto.
        exact (weaken_lookup_on_global_env' Σ.1 _ _ wf H).
        now eapply consistent_instance_ext_wf.

    - apply/andP; split.
      { rewrite wf_universeb_instance_forall.
        apply/wf_universe_instanceP.
        eapply consistent_instance_ext_wf; eauto. }
      pose proof (declared_inductive_inv wf_universes_weaken wf X isdecl).
      cbn in X1. eapply onArity in X1. cbn in X1.
      move: X1 => [s /andP[Hind ?]].
      unshelve eapply declared_inductive_to_gen in isdecl; eauto.
      eapply wf_universes_inst; eauto.
      exact (weaken_lookup_on_global_env' Σ.1 _ _ wf (proj1 isdecl)).
      now eapply consistent_instance_ext_wf.

    - apply/andP; split.
      { rewrite wf_universeb_instance_forall.
        apply/wf_universe_instanceP.
        eapply consistent_instance_ext_wf; eauto. }
      pose proof (declared_constructor_inv wf_universes_weaken wf X isdecl) as [sc [nthe onc]].
      unfold type_of_constructor.
      rewrite wf_universes_subst.
      { apply wf_universes_inds.
        now eapply consistent_instance_ext_wf. }
      eapply on_ctype in onc. cbn in onc.
      move: onc=> [_ /andP[onc _]].
      clear nthe. unshelve eapply declared_constructor_to_gen in isdecl; eauto.
      eapply wf_universes_inst; eauto.
      exact (weaken_lookup_on_global_env' Σ.1 _ _ wf (proj1 (proj1 isdecl))).
      now eapply consistent_instance_ext_wf.

    - rewrite wf_universes_mkApps in H5.
      move/andP: H5 => /= [] wfu; rewrite forallb_app.
      move/andP=> [] wfpars wfinds.
      cbn in wfu.
      rewrite wfu /= wfpars wf_universes_mkApps /=
        forallb_app wfinds /= H /= !andb_true_r.
      pose proof (declared_inductive_inv wf_universes_weaken wf X isdecl).
      destruct X5. destruct onArity as [s Hs].
      move/andP: Hs => [] /= hty hs.
      rewrite ind_arity_eq in hty.
      rewrite !wf_universes_it_mkProd_or_LetIn in hty.
      move/and3P: hty => [] wfp wfindis wfisort.
      have ond : on_udecl_prop Σ (ind_universes mdecl).
      { eapply (weaken_lookup_on_global_env' _ _ (InductiveDecl mdecl)); eauto.
      unshelve eapply declared_inductive_to_gen in isdecl; eauto.
      }
      eapply wf_ctx_universes_closed in wfp => //.
      eapply wf_ctx_universes_closed in wfindis => //.
      rewrite (consistent_instance_length H1).
      erewrite closedu_compare_decls; tea.
      rewrite closed_ind_predicate_context // /=.
      unfold test_branch.
      apply/andP; split.
      * have wfbrctx : All (fun cdecl =>
          closedu_ctx #|polymorphic_instance (ind_universes mdecl)| (cstr_args cdecl))
          (ind_ctors idecl).
        { clear -wf ond onConstructors.
          red in onConstructors. solve_all. destruct X.
          do 2 red in on_ctype. destruct on_ctype as [s Hs].
          move/andP: Hs => [] wfty _.
          rewrite cstr_eq in wfty.
          rewrite !wf_universes_it_mkProd_or_LetIn in wfty.
          move/and3P: wfty => [] _ clargs _.
          apply wf_ctx_universes_closed in clargs => //. }
        solve_all.
        erewrite closedu_compare_decls; [|tea].
        rewrite /cstr_branch_context.
        eapply closedu_expand_lets_ctx.
        rewrite wfp. eapply closedu_subst_context.
        rewrite a1.
        now rewrite closedu_inds.
      * rewrite /ptm.
        rewrite wf_universes_it_mkLambda_or_LetIn H4 andb_true_r.
        rewrite /predctx.
        destruct X3 as [_ hctx]. move: hctx.
        now rewrite test_context_app => /andP[].

    - rewrite /subst1. rewrite wf_universes_subst.
      constructor => //. eapply All_rev.
      rewrite wf_universes_mkApps in H1.
      move/andP: H1 => [].
      now intros _ hargs%forallb_All.
      pose proof (declared_projection_inv wf_universes_weaken wf X isdecl).
      destruct (declared_inductive_inv); simpl in *.
      destruct ind_ctors as [|cs []] => //.
      destruct ind_cunivs as [|cunivs []] => //;
      destruct X1 as [[[? ?] ?] ?] => //.
      red in o0.
      destruct nth_error eqn:heq => //.
      destruct o0  as [_ ->].
      rewrite wf_universes_mkApps {1}/wf_universes /= -!/(wf_universes _ _)
        wf_universeb_instance_forall in H1.
      move/andP: H1 => [/wf_universe_instanceP wfu wfargs].
      unshelve eapply declared_projection_to_gen in isdecl; eauto.
      eapply (wf_universes_inst (ind_universes mdecl)); eauto.
      exact (weaken_lookup_on_global_env' Σ.1 _ _ wf (proj1 (proj1 (proj1 isdecl)))).
      rewrite wf_universes_subst.
      eapply wf_universes_inds; eauto.
      eapply wf_abstract_instance.
      rewrite wf_universes_subst. apply wf_projs.
      rewrite wf_universes_lift.
      rewrite smash_context_app smash_context_acc in heq.
      autorewrite with len in heq. rewrite nth_error_app_lt in heq.
      autorewrite with len. lia.
      rewrite nth_error_subst_context in heq.
      autorewrite with len in heq. simpl in heq.
      epose proof (nth_error_lift_context_eq _ (smash_context [] (ind_params mdecl)) _ _).
      autorewrite with len in H. simpl in H. rewrite -> H in heq. clear H.
      autorewrite with len in heq.
      simpl in heq.
      destruct nth_error eqn:hnth; simpl in * => //.
      noconf heq. simpl.
      rewrite wf_universes_subst.
      apply wf_extended_subst.
      rewrite ind_arity_eq in onArity. destruct onArity as [s' Hs].
      rewrite wf_universes_it_mkProd_or_LetIn in Hs.
      now move/andP: Hs => /andP /andP [] /andP [].
      rewrite wf_universes_lift.
      eapply wf_sorts_local_ctx_smash in s.
      eapply wf_sorts_local_ctx_nth_error in s as [? [? H]]; eauto.
      red in H. destruct x0. now move/andP: H => [].
      now destruct H as [s [Hs _]%andb_and].

    - apply/andP; split; auto.
      solve_all; destruct a0 as (? & _ & ?), b0; rtoProp; tas.
      eapply nth_error_all in X0; eauto.
      simpl in X0. now move: X0 => [s [Hty /andP[wfty _]]].

    - apply/andP; split; auto.
      solve_all; destruct a0 as (? & _ & ?), b0; rtoProp; tas.
      eapply nth_error_all in X0; eauto.
      simpl in X0. now move: X0 => [s [Hty /andP[wfty _]]].
  Qed.

  Lemma typing_wf_universes {Σ : global_env_ext} {Γ t T} :
    wf Σ ->
    Σ ;;; Γ |- t : T -> wf_universes Σ t && wf_universes Σ T.
  Proof using Type.
    intros wfΣ Hty.
    exact (env_prop_typing wf_types _ wfΣ _ _ _ Hty).
  Qed.

  Lemma typing_wf_universe {Σ : global_env_ext} {Γ t s} :
    wf Σ ->
    Σ ;;; Γ |- t : tSort s -> wf_universe Σ s.
  Proof using Type.
    intros wfΣ Hty.
    apply typing_wf_universes in Hty as [_ wfs]%andb_and; auto.
    cbn in wfs. now to_wfu.
  Qed.

  Lemma isType_wf_universes {Σ Γ T} : wf Σ.1 -> isType Σ Γ T -> wf_universes Σ T.
  Proof using Type.
    intros wfΣ [s Hs]. now eapply typing_wf_universes in Hs as [HT _]%andb_and.
  Qed.

End CheckerFlags.

Arguments wf_universe_reflect {Σ u}.
#[global] Hint Resolve wf_universe_type1 wf_universe_super wf_universe_sup wf_universe_product : pcuic.

#[global]
Hint Extern 4 (wf_universe _ ?u) =>
  match goal with
  [ H : typing _ _ _ (tSort u) |- _ ] => apply (typing_wf_universe _ H)
  end : pcuic.


(** Wasm interpreter **)
(* (C) J. Pichon, M. Bodin - see LICENSE.txt *)

From Wasm Require Import common.
From Coq Require Import ZArith.BinInt.
From mathcomp Require Import ssreflect ssrfun ssrnat ssrbool eqtype seq.
From Wasm Require Export operations host type_checker.
Require Import BinNat.

Set Implicit Arguments.
Unset Strict Implicit.

Unset Printing Implicit Defensive.

Inductive res_crash : Type :=
| C_error : res_crash
| C_exhaustion : res_crash.

Scheme Equality for res_crash.
Definition res_crash_eqb c1 c2 := is_left (res_crash_eq_dec c1 c2).
Definition eqres_crashP : Equality.axiom res_crash_eqb :=
  eq_dec_Equality_axiom res_crash_eq_dec.

Canonical Structure res_crash_eqMixin := EqMixin eqres_crashP.
Canonical Structure res_crash_eqType := Eval hnf in EqType res_crash res_crash_eqMixin.

Inductive res : Type :=
| R_crash : res_crash -> res
| R_trap : res
| R_value : list value -> res.

Definition res_eq_dec : forall r1 r2 : res, {r1 = r2} + {r1 <> r2}.
Proof. decidable_equality. Defined.

Definition res_eqb (r1 r2 : res) : bool := res_eq_dec r1 r2.
Definition eqresP : Equality.axiom res_eqb :=
  eq_dec_Equality_axiom res_eq_dec.

Canonical Structure res_eqMixin := EqMixin eqresP.
Canonical Structure res_eqType := Eval hnf in EqType res res_eqMixin.

Section Host_func.

Variable host_function : eqType.
Let host := host host_function.

Variable host_instance : host.

Let store_record := store_record host_function.
(*Let administrative_instruction := administrative_instruction host_function.*)
Let host_state := host_state host_instance.

(*Let vs_to_es : seq value -> seq administrative_instruction := @vs_to_es _.*)

Variable host_application_impl : host_state -> store_record -> function_type -> host_function -> seq value ->
                       (host_state * option (store_record * result)).

Hypothesis host_application_impl_correct :
  (forall hs s ft hf vs hs' hres, (host_application_impl hs s ft hf vs = (hs', hres)) -> host_application hs s ft hf vs hs' hres).

Inductive res_step : Type :=
| RS_crash : res_crash -> res_step
| RS_break : nat -> list value -> res_step
| RS_return : list value -> res_step
| RS_normal : list administrative_instruction -> res_step.

Definition res_step_eq_dec : forall r1 r2 : res_step, {r1 = r2} + {r1 <> r2}.
Proof. decidable_equality. Defined.

Definition res_step_eqb (r1 r2 : res_step) : bool := res_step_eq_dec r1 r2.
Definition eqres_stepP : Equality.axiom res_step_eqb :=
  eq_dec_Equality_axiom res_step_eq_dec.

Canonical Structure res_step_eqMixin := EqMixin eqres_stepP.
Canonical Structure res_step_eqType := Eval hnf in EqType res_step res_step_eqMixin.

Definition crash_error := RS_crash C_error.

Definition depth := nat.

Definition fuel := nat.

Definition config_tuple := ((host_state * store_record * frame * list administrative_instruction)%type).

Definition config_one_tuple_without_e := (host_state * store_record * frame * list value)%type.

Definition res_tuple := (host_state * store_record * frame * res_step)%type.
(*
Fixpoint split_vals (es : list basic_instruction) : ((list value) * (list basic_instruction))%type :=
  match es with
  | (EConst v) :: es' =>
    let: (vs', es'') := split_vals es' in
    (v :: vs', es'')
  | _ => ([::], es)
  end.

(** [split_vals_e es]: takes the maximum initial segment of [es] whose elements
    are all of the form [AI_basic (EConst v)];
    returns a pair of lists [(ves, es')] where [ves] are those [v]'s in that initial
    segment and [es] is the remainder of the original [es]. **)
Fixpoint split_vals_e (es : list administrative_instruction) : ((list value) * (list administrative_instruction))%type :=
  match es with
  | (AI_basic (EConst v)) :: es' =>
    let: (vs', es'') := split_vals_e es' in
    (v :: vs', es'')
  | _ => ([::], es)
  end.

Fixpoint split_n (es : list value) (n : nat) : ((list value) * (list value))%type :=
  match (es, n) with
  | ([::], _) => ([::], [::])
  | (_, 0) => ([::], es)
  | (e :: esX, n.+1) =>
    let: (es', es'') := split_n esX n in
    (e :: es', es'')
  end.

Definition expect {A B : Type} (ao : option A) (f : A -> B) (b : B) : B :=
  match ao with
  | Some a => f a
  | None => b
  end.

Definition vs_to_es (vs : list value) : list administrative_instruction :=
  v_to_e_list (rev vs).

Definition e_is_trap (e : administrative_instruction) : bool :=
  match e with
  | AI_trap => true
  | _ => false
  end.

Lemma e_is_trapP : forall e, reflect (e = AI_trap) (e_is_trap e).
Proof.
  case => //= >; by [ apply: ReflectF | apply: ReflectT ].
Qed.

(** [es_is_trap es] is equivalent to [es == [:: AI_trap]]. **)
Definition es_is_trap (es : list administrative_instruction) : bool :=
  match es with
  | [::e] => e_is_trap e
  | _ => false
  end.

Lemma es_is_trapP : forall l, reflect (l = [::AI_trap]) (es_is_trap l).
Proof.
  case; first by apply: ReflectF.
  move=> // a l. case l => //=.
  - apply: (iffP (e_is_trapP _)); first by elim.
    by inversion 1.
  - move=> >. by apply: ReflectF.
Qed.*)

Fixpoint run_step_with_fuel (fuel : fuel) (d : depth) (cfg : config_tuple) : res_tuple :=
  let: (hs, s, f, es) := cfg in
  match fuel with
  | 0 => (hs, s, f, RS_crash C_exhaustion)
  | fuel.+1 =>
    let: (ves, es') := split_vals_e es in (** Framing out constants. **)
    match es' with
    | [::] => (hs, s, f, crash_error)
    | e :: es'' =>
      if e_is_trap e
      then
        if (es'' != [::]) || (ves != [::])
        then (hs, s, f, RS_normal [::AI_trap])
        else (hs, s, f, crash_error)
      else
        let: (hs', s', f', r) := run_one_step fuel d (hs, s, f, (rev ves)) e in
        if r is RS_normal res
        then (hs', s', f', RS_normal (res ++ es''))
        else (hs', s', f', r)
    end
  end

with run_one_step (fuel : fuel) (d : depth) (cfg : config_one_tuple_without_e) (e : administrative_instruction) : res_tuple :=
  let: (hs, s, f, ves) := cfg in
  match fuel with
  | 0 => (hs, s, f, RS_crash C_exhaustion)
  | fuel.+1 =>
    match e with
    (* unop *)
    | AI_basic (BI_unop t op) =>
      if ves is v :: ves' then
        (hs, s, f, RS_normal (vs_to_es (app_unop op v :: ves')))
      else (hs, s, f, crash_error)
    (* binop *)
    | AI_basic (BI_binop t op) =>
      if ves is v2 :: v1 :: ves' then
        expect (app_binop op v1 v2)
               (fun v => (hs, s, f, RS_normal (vs_to_es (v :: ves'))))
               (hs, s, f, RS_normal ((vs_to_es ves') ++ [::AI_trap]))
      else (hs, s, f, crash_error)
    (* testops *)
    | AI_basic (BI_testop T_i32 testop) =>
      if ves is (VAL_int32 c) :: ves' then
        (hs, s, f, RS_normal (vs_to_es ((VAL_int32 (wasm_bool (@app_testop_i i32t testop c))) :: ves')))
      else (hs, s, f, crash_error)
    | AI_basic (BI_testop T_i64 testop) =>
      if ves is (VAL_int64 c) :: ves' then
        (hs, s, f, RS_normal (vs_to_es ((VAL_int32 (wasm_bool (@app_testop_i i64t testop c))) :: ves')))
      else (hs, s, f, crash_error)
    | AI_basic (BI_testop _ _) => (hs, s, f, crash_error)
    (* relops *)
    | AI_basic (BI_relop t op) =>
      if ves is v2 :: v1 :: ves' then
        (hs, s, f, RS_normal (vs_to_es (VAL_int32 (wasm_bool (app_relop op v1 v2)) :: ves')))
      else (hs, s, f, crash_error)
    (* convert & reinterpret *)
    | AI_basic (BI_cvtop t2 CVO_convert t1 sx) =>
      if ves is v :: ves' then
        if types_agree t1 v
        then
          expect (cvt t2 sx v) (fun v' =>
               (hs, s, f, RS_normal (vs_to_es (v' :: ves'))))
            (hs, s, f, RS_normal ((vs_to_es ves') ++ [::AI_trap]))
        else (hs, s, f, crash_error)
      else (hs, s, f, crash_error)
    | AI_basic (BI_cvtop t2 CVO_reinterpret t1 sx) =>
      if ves is v :: ves' then
        if types_agree t1 v && (sx == None)
        then (hs, s, f, RS_normal (vs_to_es (wasm_deserialise (bits v) t2 :: ves')))
        else (hs, s, f, crash_error)
      else (hs, s, f, crash_error)
    (**)
    | AI_basic BI_unreachable => (hs, s, f, RS_normal ((vs_to_es ves) ++ [::AI_trap]))
    | AI_basic BI_nop => (hs, s, f, RS_normal (vs_to_es ves))
    | AI_basic BI_drop =>
      if ves is v :: ves' then
        (hs, s, f, RS_normal (vs_to_es ves'))
      else (hs, s, f, crash_error)
    | AI_basic BI_select =>
      if ves is (VAL_int32 c) :: v2 :: v1 :: ves' then
        if c == Wasm_int.int_zero i32m
        then (hs, s, f, RS_normal (vs_to_es (v2 :: ves')))
        else (hs, s, f, RS_normal (vs_to_es (v1 :: ves')))
      else (hs, s, f, crash_error)
    | AI_basic (BI_block (Tf t1s t2s) es) =>
      if length ves >= length t1s
      then
        let: (ves', ves'')  := split_n ves (length t1s) in
        (hs, s, f, RS_normal (vs_to_es ves''
                ++ [::AI_label (length t2s) [::] (vs_to_es ves' ++ to_e_list es)]))
      else (hs, s, f, crash_error)
    | AI_basic (BI_loop (Tf t1s t2s) es) =>
      if length ves >= length t1s
      then
        let: (ves', ves'') := split_n ves (length t1s) in
        (hs, s, f, RS_normal (vs_to_es ves''
                ++ [::AI_label (length t1s) [::AI_basic (BI_loop (Tf t1s t2s) es)]
                        (vs_to_es ves' ++ to_e_list es)]))
      else (hs, s, f, crash_error)
    | AI_basic (BI_if tf es1 es2) =>
      if ves is VAL_int32 c :: ves' then
        if c == Wasm_int.int_zero i32m
        then (hs, s, f, RS_normal (vs_to_es ves' ++ [::AI_basic (BI_block tf es2)]))
        else (hs, s, f, RS_normal (vs_to_es ves' ++ [::AI_basic (BI_block tf es1)]))
      else (hs, s, f, crash_error)
    | AI_basic (BI_br j) => (hs, s, f, RS_break j ves)
    | AI_basic (BI_br_if j) =>
      if ves is VAL_int32 c :: ves' then
        if c == Wasm_int.int_zero i32m
        then (hs, s, f, RS_normal (vs_to_es ves'))
        else (hs, s, f, RS_normal (vs_to_es ves' ++ [::AI_basic (BI_br j)]))
      else (hs, s, f, crash_error)
    | AI_basic (BI_br_table js j) =>
      if ves is VAL_int32 c :: ves' then
        let: k := Wasm_int.nat_of_uint i32m c in
        if k < length js
        then
          expect (List.nth_error js k) (fun js_at_k =>
              (hs, s, f, RS_normal (vs_to_es ves' ++ [::AI_basic (BI_br js_at_k)])))
            (hs, s, f, crash_error)
        else (hs, s, f, RS_normal (vs_to_es ves' ++ [::AI_basic (BI_br j)]))
      else (hs, s, f, crash_error)
    | AI_basic (BI_call j) =>
      if List.nth_error f.(f_inst).(inst_funcs) j is Some a then
        (hs, s, f, RS_normal (vs_to_es ves ++ [::AI_invoke a]))
      else (hs, s, f, crash_error)
    | AI_basic (BI_call_indirect j) =>
      if ves is VAL_int32 c :: ves' then
        match stab_addr s f (Wasm_int.nat_of_uint i32m c) with
        | Some a =>
          match List.nth_error s.(s_funcs) a with
          | Some cl =>
            if stypes s f.(f_inst) j == Some (cl_type cl)
            then (hs, s, f, RS_normal (vs_to_es ves' ++ [::AI_invoke a]))
            else (hs, s, f, RS_normal (vs_to_es ves' ++ [::AI_trap]))
          | None => (hs, s, f, crash_error)
          end
        | None => (hs, s, f, RS_normal (vs_to_es ves' ++ [::AI_trap]))
        end
      else (hs, s, f, crash_error)
    | AI_basic BI_return => (hs, s, f, RS_return ves)
    | AI_basic (BI_get_local j) =>
      if j < length f.(f_locs)
      then
        expect (List.nth_error f.(f_locs) j) (fun vs_at_j =>
            (hs, s, f, RS_normal (vs_to_es (vs_at_j :: ves))))
          (hs, s, f, crash_error)
      else (hs, s, f, crash_error)
    | AI_basic (BI_set_local j) =>
      if ves is v :: ves' then
        if j < length f.(f_locs)
        then (hs, s, Build_frame (update_list_at f.(f_locs) j v) f.(f_inst), RS_normal (vs_to_es ves'))
        else (hs, s, f, crash_error)
      else (hs, s, f, crash_error)
    | AI_basic (BI_tee_local j) =>
      if ves is v :: ves' then
        (hs, s, f, RS_normal (vs_to_es (v :: ves) ++ [::AI_basic (BI_set_local j)]))
      else (hs, s, f, crash_error)
    | AI_basic (BI_get_global j) =>
      if sglob_val s f.(f_inst) j is Some xx
      then (hs, s, f, RS_normal (vs_to_es (xx :: ves)))
      else (hs, s, f, crash_error)
    | AI_basic (BI_set_global j) =>
      if ves is v :: ves' then
        if supdate_glob s f.(f_inst) j v is Some xx
        then (hs, xx, f, RS_normal (vs_to_es ves'))
        else (hs, s, f, crash_error)
      else (hs, s, f, crash_error)
    | AI_basic (BI_load t None a off) =>
      if ves is VAL_int32 k :: ves' then
        expect
          (smem_ind s f.(f_inst))
          (fun j =>
             if List.nth_error s.(s_mems) j is Some mem_s_j then
               expect
                 (load (mem_s_j) (Wasm_int.N_of_uint i32m k) off (t_length t))
                 (fun bs => (hs, s, f, RS_normal (vs_to_es (wasm_deserialise bs t :: ves'))))
                 (hs, s, f, RS_normal (vs_to_es ves' ++ [::AI_trap]))
             else (hs, s, f, crash_error))
          (hs, s, f, crash_error)
      else (hs, s, f, crash_error)
    | AI_basic (BI_load t (Some (tp, sx)) a off) =>
      if ves is VAL_int32 k :: ves' then
        expect
          (smem_ind s f.(f_inst))
          (fun j =>
             if List.nth_error s.(s_mems) j is Some mem_s_j then
               expect
                 (load_packed sx (mem_s_j) (Wasm_int.N_of_uint i32m k) off (tp_length tp) (t_length t))
                 (fun bs => (hs, s, f, RS_normal (vs_to_es (wasm_deserialise bs t :: ves'))))
                 (hs, s, f, RS_normal (vs_to_es ves' ++ [::AI_trap]))
             else (hs, s, f, crash_error))
          (hs, s, f, crash_error)
      else (hs, s, f, crash_error)
    | AI_basic (BI_store t None a off) =>
      if ves is v :: VAL_int32 k :: ves' then
        if types_agree t v
        then
          expect
            (smem_ind s f.(f_inst))
            (fun j =>
               if List.nth_error s.(s_mems) j is Some mem_s_j then
                 expect
                   (store mem_s_j (Wasm_int.N_of_uint i32m k) off (bits v) (t_length t))
                   (fun mem' =>
                      (hs, upd_s_mem s (update_list_at s.(s_mems) j mem'), f, RS_normal (vs_to_es ves')))
                   (hs, s, f, RS_normal (vs_to_es ves' ++ [::AI_trap]))
               else (hs, s, f, crash_error))
            (hs, s, f, crash_error)
        else (hs, s, f, crash_error)
      else (hs, s, f, crash_error)
    | AI_basic (BI_store t (Some tp) a off) =>
      if ves is v :: VAL_int32 k :: ves' then
        if types_agree t v
        then
          expect
            (smem_ind s f.(f_inst))
            (fun j =>
               if List.nth_error s.(s_mems) j is Some mem_s_j then
                 expect
                   (store_packed mem_s_j (Wasm_int.N_of_uint i32m k) off (bits v) (tp_length tp))
                   (fun mem' =>
                      (hs, upd_s_mem s (update_list_at s.(s_mems) j mem'), f, RS_normal (vs_to_es ves')))
                   (hs, s, f, RS_normal (vs_to_es ves' ++ [::AI_trap]))
               else (hs, s, f, crash_error))
            (hs, s, f, crash_error)
        else (hs, s, f, crash_error)
      else (hs, s, f, crash_error)
    | AI_basic BI_current_memory =>
      expect
        (smem_ind s f.(f_inst))
        (fun j =>
           if List.nth_error s.(s_mems) j is Some s_mem_s_j then
             (hs, s, f, RS_normal (vs_to_es (VAL_int32 (Wasm_int.int_of_Z i32m (Z.of_nat (mem_size s_mem_s_j))) :: ves)))
           else (hs, s, f, crash_error))
        (hs, s, f, crash_error)
    | AI_basic BI_grow_memory =>
      if ves is VAL_int32 c :: ves' then
        expect
          (smem_ind s f.(f_inst))
          (fun j =>
            if List.nth_error s.(s_mems) j is Some s_mem_s_j then
              let: l := mem_size s_mem_s_j in
              let: mem' := mem_grow s_mem_s_j (Wasm_int.N_of_uint i32m c) in
              if mem' is Some mem'' then
                (hs, upd_s_mem s (update_list_at s.(s_mems) j mem''), f,
                 RS_normal (vs_to_es (VAL_int32 (Wasm_int.int_of_Z i32m (Z.of_nat l)) :: ves')))
              else (hs, s, f, crash_error)
            else (hs, s, f, crash_error))
          (hs, s, f, crash_error)
      else (hs, s, f, crash_error)
    | AI_basic (BI_const _) => (hs, s, f, crash_error)
    | AI_invoke a =>
      match List.nth_error s.(s_funcs) a with
      | Some cl =>
        match cl with
        | FC_func_native i (Tf t1s t2s) ts es =>
            let: n := length t1s in
            let: m := length t2s in
            if length ves >= n
            then
            let: (ves', ves'') := split_n ves n in
            let: zs := n_zeros ts in
            (hs, s, f, RS_normal (vs_to_es ves''
                    ++ [::AI_local m (Build_frame (rev ves' ++ zs) i) [::AI_basic (BI_block (Tf [::] t2s) es)]]))
            else (hs, s, f, crash_error)
        | FC_func_host (Tf t1s t2s) cl' =>
            let: n := length t1s in
            let: m := length t2s in
            if length ves >= n
            then
            let: (ves', ves'') := split_n ves n in
            match host_application_impl hs s (Tf t1s t2s) cl' (rev ves') with
            | (hs', Some (s', rves)) =>
                (hs', s', f, RS_normal (vs_to_es ves'' ++ (result_to_stack rves)))
            | (hs', None) => (hs', s, f, RS_normal (vs_to_es ves ++ [::AI_invoke a]))
            end
            else (hs, s, f, crash_error)
        end
      | None => (hs, s, f, crash_error)
      end
    | AI_label ln les es =>
      if es_is_trap es
      then (hs, s, f, RS_normal (vs_to_es ves ++ [::AI_trap]))
      else
        if const_list es
        then (hs, s, f, RS_normal (vs_to_es ves ++ es))
        else
          let: (hs', s', f', res) := run_step_with_fuel fuel d (hs, s, f, es) in
          match res with
          | RS_break 0 bvs =>
            if length bvs >= ln
            then (hs', s', f', RS_normal ((vs_to_es ((take ln bvs) ++ ves)) ++ les))
            else (hs', s', f', crash_error)
          | RS_break (n.+1) bvs => (hs', s', f', RS_break n bvs)
          | RS_return rvs => (hs', s', f', RS_return rvs)
          | RS_normal es' =>
            (hs', s', f', RS_normal (vs_to_es ves ++ [::AI_label ln les es']))
          | RS_crash error => (hs', s', f', RS_crash error)
          end
    | AI_local ln lf es =>
      if es_is_trap es
      then (hs, s, f, RS_normal (vs_to_es ves ++ [::AI_trap]))
      else
        if const_list es
        then
          if length es == ln
          then (hs, s, f, RS_normal (vs_to_es ves ++ es))
          else (hs, s, f, crash_error)
        else
          let: (hs', s', f', res) := run_step_with_fuel fuel d (hs, s, lf, es) in
          match res with
          | RS_return rvs =>
            if length rvs >= ln
            then (hs', s', f, RS_normal (vs_to_es (take ln rvs ++ ves)))
            else (hs', s', f, crash_error)
          | RS_normal es' =>
            (hs', s', f, RS_normal (vs_to_es ves ++ [::AI_local ln f' es']))
          | RS_crash error => (hs', s', f, RS_crash error)
          | RS_break _ _ => (hs', s', f, crash_error)
          end
    | AI_trap => (hs, s, f, crash_error)
    end
  end.

(** Enough fuel so that [run_one_step] does not run out of exhaustion. **)
Definition run_one_step_fuel : administrative_instruction -> nat.
Proof.
  move=> es. induction es using administrative_instruction_rect';
    let rec aux v :=
      lazymatch goal with
      | F : TProp.Forall _ _ |- _ =>
        apply TProp.max in F;
        move: F;
        let n := fresh "n" in
        move=> n;
        aux (n + v)
      | |- _ => exact (v.+1)
      end in
    aux (1 : nat).
Defined.

(** Enough fuel so that [run_step] does not run out of exhaustion. **)
Definition run_step_fuel (cfg : config_tuple) : nat :=
  let: (hs, s, f, es) := cfg in
  1 + List.fold_left max (List.map run_one_step_fuel es) 0.

Definition run_step (d : depth) (cfg : config_tuple) : res_tuple :=
  run_step_with_fuel (run_step_fuel cfg) d cfg.

Fixpoint run_v (fuel : fuel) (d : depth) (cfg : config_tuple) : ((host_state * store_record * res)%type) :=
  let: (hs, s, f, es) := cfg in
  match fuel with
  | 0 => (hs, s, R_crash C_exhaustion)
  | fuel.+1 =>
    if es_is_trap es
    then (hs, s, R_trap)
    else
      if const_list es
      then (hs, s, R_value (fst (split_vals_e es)))
      else
        let: (hs', s', f', res) := run_step d (hs, s, f, es) in
        match res with
        | RS_normal es' => run_v fuel d (hs', s', f', es')
        | RS_crash error => (hs', s', R_crash error)
        | _ => (hs', s', R_crash C_error)
        end
  end.

End Host_func.


From Coq Require Import Arith ZArith OrderedType.
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq.
From nbits Require Import NBits.
From ssrlib Require Import Types SsrOrder Var Nats ZAriths Tactics.
From BitBlasting Require Import Typ TypEnv State QFBV CNF BBExport AdhereConform.
From BBCache Require Import CompCache BitBlastingCCacheDef.

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

Ltac auto_prove_neq_by_len :=
  match goal with
  | Hlen : is_true (QFBV.len_exp ?e1 < QFBV.len_exp ?e2)
    |- ~ is_true (?e2 == ?e1) =>
    let Heq := fresh in
    move/eqP=> Heq; rewrite Heq /= ltnn in Hlen; done
  | Hlen : is_true (QFBV.len_bexp ?e1 < QFBV.len_bexp ?e2)
    |- ~ is_true (?e2 == ?e1) =>
    let Heq := fresh in
    move/eqP=> Heq; rewrite Heq /= ltnn in Hlen; done
  end.

Ltac auto_prove_lt :=
  match goal with
  | H : is_true (?a.+1 < ?p)
    |- is_true (?a < ?p) =>
    by apply: (ltn_trans (ltnSn a))
  | H : is_true ((?a + ?b).+1 < ?p)
    |- is_true (?a < ?p) =>
    let Haux := fresh in
    (have Haux : a < (a + b).+1 by apply leq_addr); exact: (ltn_trans Haux H)
  | H : is_true ((?b + ?a).+1 < ?p)
    |- is_true (?a < ?p) =>
    let Haux := fresh in
    (have Haux : a < (b + a).+1 by apply leq_addl); exact: (ltn_trans Haux H)
  | H : is_true ((?a + ?b + ?c).+1 < ?p)
    |- is_true (?a < ?p) =>
    let Haux := fresh in
    (have Haux : a < (a + b + c).+1 by rewrite -addnA; exact: leq_addr);
    exact: (ltn_trans Haux H)
  | H : is_true ((?b + ?a + ?c).+1 < ?p)
    |- is_true (?a < ?p) =>
    let Haux := fresh in
    (have Haux : a < (b + a + c).+1 by rewrite (addnC b) -addnA; exact: leq_addr);
    exact: (ltn_trans Haux H)
  | |- is_true (?a < ?a.+1) => exact: leqnn
  | |- is_true (?a < (?a + _).+1) => exact: leq_addr
  | |- is_true (?a < (_ + ?a).+1) => exact: leq_addl
  | |- is_true (?a < (?a + _ + _).+1) => rewrite -addnA; exact: leq_addr
  | |- is_true (?a < (?b + ?a + _).+1) => rewrite (addnC b) -addnA; exact: leq_addr
  end.

Ltac auto_prove_len_lt :=
  match goal with
  | H : is_true (QFBV.len_exp ?e0 < QFBV.len_exp ?e)
    |- is_true (QFBV.len_exp ?e1 < QFBV.len_exp ?e) =>
    match e0 with
    | context [e1] =>
    rewrite /= in H; by auto_prove_lt
    end
  | H : is_true (QFBV.len_exp ?e0 < QFBV.len_exp ?e)
    |- is_true (QFBV.len_bexp ?e1 < QFBV.len_exp ?e) =>
    match e0 with
    | context [e1] =>
    rewrite /= in H; by auto_prove_lt
    end
  | H : is_true (QFBV.len_bexp ?e0 < QFBV.len_exp ?e)
    |- is_true (QFBV.len_exp ?e1 < QFBV.len_exp ?e) =>
    match e0 with
    | context [e1] =>
    rewrite /= in H; by auto_prove_lt
    end
  | H : is_true (QFBV.len_bexp ?e0 < QFBV.len_exp ?e)
    |- is_true (QFBV.len_bexp ?e1 < QFBV.len_exp ?e) =>
    match e0 with
    | context [e1] =>
    rewrite /= in H; by auto_prove_lt
    end
  | H : is_true (QFBV.len_exp ?e0 < QFBV.len_bexp ?e)
    |- is_true (QFBV.len_exp ?e1 < QFBV.len_bexp ?e) =>
    match e0 with
    | context [e1] =>
    rewrite /= in H; by auto_prove_lt
    end
  | H : is_true (QFBV.len_exp ?e0 < QFBV.len_bexp ?e)
    |- is_true (QFBV.len_bexp ?e1 < QFBV.len_bexp ?e) =>
    match e0 with
    | context [e1] =>
    rewrite /= in H; by auto_prove_lt
    end
  | H : is_true (QFBV.len_bexp ?e0 < QFBV.len_bexp ?e)
    |- is_true (QFBV.len_exp ?e1 < QFBV.len_bexp ?e) =>
    match e0 with
    | context [e1] =>
    rewrite /= in H; by auto_prove_lt
    end
  | H : is_true (QFBV.len_bexp ?e0 < QFBV.len_bexp ?e)
    |- is_true (QFBV.len_bexp ?e1 < QFBV.len_bexp ?e) =>
    match e0 with
    | context [e1] =>
    rewrite /= in H; by auto_prove_lt
    end
  | |- is_true (QFBV.len_exp ?e0 < QFBV.len_exp ?e) =>
    match e with
    | context [e0] =>
    rewrite /=; by auto_prove_lt
    end
  | |- is_true (QFBV.len_bexp ?e0 < QFBV.len_bexp ?e) =>
    match e with
    | context [e0] =>
    rewrite /=; by auto_prove_lt
    end
  | |- is_true (QFBV.len_bexp ?e0 < QFBV.len_exp ?e) =>
    match e with
    | context [e0] =>
    rewrite /=; by auto_prove_lt
    end
  | |- is_true (QFBV.len_exp ?e0 < QFBV.len_bexp ?e) =>
    match e with
    | context [e0] =>
    rewrite /=; by auto_prove_lt
    end
  end.

(* = bit_blast_exp_ccache_find_cet and bit_blast_bexp_ccache_find_cet = *)

Lemma bit_blast_exp_ccache_find_cet :
  forall e0 e te m c g m' c' g' cs ls,
    QFBV.len_exp e0 < QFBV.len_exp e ->
    bit_blast_exp_ccache te m c g e0 = (m', c', g', cs, ls) ->
    find_cet e c' = find_cet e c
  with
    bit_blast_bexp_ccache_find_cet :
      forall e0 e te m c g m' c' g' cs l,
        QFBV.len_bexp e0 < QFBV.len_exp e ->
        bit_blast_bexp_ccache te m c g e0 = (m', c', g', cs, l) ->
        find_cet e c' = find_cet e c.
Proof.
  (* bit_blast_exp_ccache_find_cet *)
  set IHe := bit_blast_exp_ccache_find_cet.
  set IHb := bit_blast_bexp_ccache_find_cet.
  move=> e0 e te m c g m' c' g' cs ls.
  case Hfcet: (find_cet e0 c) => [[cs0 ls0] | ].
  - move=> _. rewrite bit_blast_exp_ccache_equation Hfcet /=.
    case=> _ <- _ _ _. done.
  - move: Hfcet. case e0 => [v | bs | op e1 | op e1 e2 | b e1 e2] Hfcet Hlen.
    + rewrite /= Hfcet.
      case Hfhet : (find_het (QFBV.Evar v) c) => [[csh lsh] | ].
      * case=> _ <- _ _ _; apply find_cet_add_cet_neq;
        by auto_prove_neq_by_len.
      * case Hfind: (SSAVM.find v m) => [rs | ];
          last case Hblast : (bit_blast_var te g v) => [[vg vcs] vls];
          case=> _ <- _ _ _; rewrite find_cet_add_cet_neq;
          (try by auto_prove_neq_by_len); by apply find_cet_add_het.
    + rewrite /= Hfcet.
      case Hfhet : (find_het (QFBV.Econst bs) c) => [[csh lsh] | ];
        case=> _ <- _ _ _; rewrite find_cet_add_cet_neq; (try done);
        (try by auto_prove_neq_by_len); by apply find_cet_add_het.
    + rewrite /= Hfcet.
      case Hbb1: (bit_blast_exp_ccache te m c g e1) => [[[[m1 c1] g1] cs1] ls1].
      have He1e : QFBV.len_exp e1 < QFBV.len_exp e by auto_prove_len_lt.
      move: (IHe _ _ _ _ _ _ _ _ _ _ _ He1e Hbb1) => Hc1c.
      rewrite -Hc1c.
      case Hfhet : (find_het (QFBV.Eunop op e1) c1) => [[csop lsop] | ];
        last case Hbbop : (bit_blast_eunop op g1 ls1) => [[gop csop] lsop];
        case=> _ <- _ _ _; rewrite find_cet_add_cet_neq; (try done);
        (try by auto_prove_neq_by_len); by apply find_cet_add_het.
    + rewrite /= Hfcet.
      case Hbb1: (bit_blast_exp_ccache te m c g e1) => [[[[m1 c1] g1] cs1] ls1].
      have He1e : QFBV.len_exp e1 < QFBV.len_exp e by auto_prove_len_lt.
      move: (IHe _ _ _ _ _ _ _ _ _ _ _ He1e Hbb1) => Hc1c.
      case Hbb2: (bit_blast_exp_ccache te m1 c1 g1 e2) => [[[[m2 c2] g2] cs2] ls2].
      have He2e : QFBV.len_exp e2 < QFBV.len_exp e by auto_prove_len_lt.
      move: (IHe _ _ _ _ _ _ _ _ _ _ _ He2e Hbb2) => Hc2c1.
      rewrite -Hc1c -Hc2c1.
      case Hfhet : (find_het (QFBV.Ebinop op e1 e2) c2) => [[csop lsop] | ];
        last case Hbbop : (bit_blast_ebinop op g2 ls1 ls2) => [[gop csop] lsop];
        case=> _ <- _ _ _; rewrite find_cet_add_cet_neq; (try done);
        (try by auto_prove_neq_by_len); by apply find_cet_add_het.
    + rewrite /= Hfcet.
      case Hbbb: (bit_blast_bexp_ccache te m c g b) => [[[[mb cb] gb] csb] lb].
      have Hbe : QFBV.len_bexp b < QFBV.len_exp e by auto_prove_len_lt.
      move: (IHb _ _ _ _ _ _ _ _ _ _ _ Hbe Hbbb) => Hcbc.
      case Hbb1: (bit_blast_exp_ccache te mb cb gb e1) => [[[[m1 c1] g1] cs1] ls1].
      have He1e : QFBV.len_exp e1 < QFBV.len_exp e by auto_prove_len_lt.
      move: (IHe _ _ _ _ _ _ _ _ _ _ _ He1e Hbb1) => Hc1cb.
      case Hbb2: (bit_blast_exp_ccache te m1 c1 g1 e2) => [[[[m2 c2] g2] cs2] ls2].
      have He2e : QFBV.len_exp e2 < QFBV.len_exp e by auto_prove_len_lt.
      move: (IHe _ _ _ _ _ _ _ _ _ _ _ He2e Hbb2) => Hc2c1.
      rewrite -Hcbc -Hc1cb -Hc2c1.
      case Hfhet : (find_het (QFBV.Eite b e1 e2) c2) => [[csop lsop] | ];
        last case Hbbop : (bit_blast_ite g2 lb ls1 ls2) => [[gop csop] lsop];
        case=> _ <- _ _ _; rewrite find_cet_add_cet_neq; (try done);
        (try by auto_prove_neq_by_len); by apply find_cet_add_het.
  (* bit_blast_bexp_ccache_find_cet *)
  set IHe := bit_blast_exp_ccache_find_cet.
  set IHb := bit_blast_bexp_ccache_find_cet.
  move=> e0 e te m c g m' c' g' cs l.
  case Hfcbt: (find_cbt e0 c) => [[cs0 l0] | ].
  - move=> _. rewrite bit_blast_bexp_ccache_equation Hfcbt /=.
    case=> _ <- _ _ _. done.
  - move: Hfcbt. case e0 => [ | | op e1 e2 | e1 | e1 e2 | e1 e2] Hfcbt Hlen.
    + rewrite /= Hfcbt.
      case Hfhet : (find_hbt QFBV.Bfalse c) => [[csh lh] | ]; case=> _ <- _ _ _;
        rewrite find_cet_add_cbt; (try rewrite find_cet_add_hbt); done.
    + rewrite /= Hfcbt.
      case Hfhet : (find_hbt QFBV.Btrue c) => [[csh lh] | ]; case=> _ <- _ _ _;
        rewrite find_cet_add_cbt; (try rewrite find_cet_add_hbt); done.
    + rewrite /= Hfcbt.
      case Hbb1: (bit_blast_exp_ccache te m c g e1) => [[[[m1 c1] g1] cs1] ls1].
      have He1e : QFBV.len_exp e1 < QFBV.len_exp e by auto_prove_len_lt.
      move: (IHe _ _ _ _ _ _ _ _ _ _ _ He1e Hbb1) => Hc1c.
      case Hbb2: (bit_blast_exp_ccache te m1 c1 g1 e2) => [[[[m2 c2] g2] cs2] ls2].
      have He2e : QFBV.len_exp e2 < QFBV.len_exp e by auto_prove_len_lt.
      move: (IHe _ _ _ _ _ _ _ _ _ _ _ He2e Hbb2) => Hc2c1.
      rewrite -Hc1c -Hc2c1.
      case Hfhbt : (find_hbt (QFBV.Bbinop op e1 e2) c2) => [[csop lop] | ];
        last case Hbbop : (bit_blast_bbinop op g2 ls1 ls2) => [[gop csop] lsop];
        case=> _ <- _ _ _; rewrite find_cet_add_cbt;
        (try rewrite find_cet_add_hbt); done.
    + rewrite /= Hfcbt.
      case Hbb1: (bit_blast_bexp_ccache te m c g e1) => [[[[m1 c1] g1] cs1] l1].
      have He1e : QFBV.len_bexp e1 < QFBV.len_exp e by auto_prove_len_lt.
      move: (IHb _ _ _ _ _ _ _ _ _ _ _ He1e Hbb1) => Hc1c.
      rewrite -Hc1c.
      case Hfhbt : (find_hbt (QFBV.Blneg e1) c1) => [[csop lop] | ];
        case=> _ <- _ _ _; rewrite find_cet_add_cbt;
        (try rewrite find_cet_add_hbt); done.
    + rewrite /= Hfcbt.
      case Hbb1: (bit_blast_bexp_ccache te m c g e1) => [[[[m1 c1] g1] cs1] l1].
      have He1e : QFBV.len_bexp e1 < QFBV.len_exp e by auto_prove_len_lt.
      move: (IHb _ _ _ _ _ _ _ _ _ _ _ He1e Hbb1) => Hc1c.
      case Hbb2: (bit_blast_bexp_ccache te m1 c1 g1 e2) => [[[[m2 c2] g2] cs2] l2].
      have He2e : QFBV.len_bexp e2 < QFBV.len_exp e by auto_prove_len_lt.
      move: (IHb _ _ _ _ _ _ _ _ _ _ _ He2e Hbb2) => Hc2c1.
      rewrite -Hc1c -Hc2c1.
      case Hfhbt : (find_hbt (QFBV.Bconj e1 e2) c2) => [[csop lop] | ];
        case=> _ <- _ _ _; rewrite find_cet_add_cbt;
        (try rewrite find_cet_add_hbt); done.
    + rewrite /= Hfcbt.
      case Hbb1: (bit_blast_bexp_ccache te m c g e1) => [[[[m1 c1] g1] cs1] l1].
      have He1e : QFBV.len_bexp e1 < QFBV.len_exp e by auto_prove_len_lt.
      move: (IHb _ _ _ _ _ _ _ _ _ _ _ He1e Hbb1) => Hc1c.
      case Hbb2: (bit_blast_bexp_ccache te m1 c1 g1 e2) => [[[[m2 c2] g2] cs2] l2].
      have He2e : QFBV.len_bexp e2 < QFBV.len_exp e by auto_prove_len_lt.
      move: (IHb _ _ _ _ _ _ _ _ _ _ _ He2e Hbb2) => Hc2c1.
      rewrite -Hc1c -Hc2c1.
      case Hfhbt : (find_hbt (QFBV.Bdisj e1 e2) c2) => [[csop lop] | ];
        case=> _ <- _ _ _; rewrite find_cet_add_cbt;
        (try rewrite find_cet_add_hbt); done.
Qed.

(* = bit_blast_exp_ccache_find_cbt and bit_blast_bexp_ccache_find_cbt = *)

Lemma bit_blast_exp_ccache_find_cbt :
  forall e0 e te m c g m' c' g' cs ls,
    QFBV.len_exp e0 < QFBV.len_bexp e ->
    bit_blast_exp_ccache te m c g e0 = (m', c', g', cs, ls) ->
    find_cbt e c' = find_cbt e c
  with
    bit_blast_bexp_ccache_find_cbt :
      forall e0 e te m c g m' c' g' cs l,
        QFBV.len_bexp e0 < QFBV.len_bexp e ->
        bit_blast_bexp_ccache te m c g e0 = (m', c', g', cs, l) ->
        find_cbt e c' = find_cbt e c.
Proof.
  (* bit_blast_exp_ccache_find_cbt *)
  set IHe := bit_blast_exp_ccache_find_cbt.
  set IHb := bit_blast_bexp_ccache_find_cbt.
  move=> e0 e te m c g m' c' g' cs ls.
  case Hfcet: (find_cet e0 c) => [[cs0 ls0] | ].
  - move=> _. rewrite bit_blast_exp_ccache_equation Hfcet /=.
    case=> _ <- _ _ _. done.
  - move: Hfcet. case e0 => [v | bs | op e1 | op e1 e2 | b e1 e2] Hfcet Hlen.
    + rewrite /= Hfcet.
      case Hfhet : (find_het (QFBV.Evar v) c) => [[csh lsh] | ].
      * case=> _ <- _ _ _; apply find_cbt_add_cet.
      * case Hfind: (SSAVM.find v m) => [rs | ];
          last case Hblast : (bit_blast_var te g v) => [[vg vcs] vls];
          case=> _ <- _ _ _; rewrite find_cbt_add_cet; by apply find_cbt_add_het.
    + rewrite /= Hfcet.
      case Hfhet : (find_het (QFBV.Econst bs) c) => [[csh lsh] | ];
        case=> _ <- _ _ _; rewrite find_cbt_add_cet; (try done);
        by apply find_cbt_add_het.
    + rewrite /= Hfcet.
      case Hbb1: (bit_blast_exp_ccache te m c g e1) => [[[[m1 c1] g1] cs1] ls1].
      have He1e : QFBV.len_exp e1 < QFBV.len_bexp e by auto_prove_len_lt.
      move: (IHe _ _ _ _ _ _ _ _ _ _ _ He1e Hbb1) => Hc1c.
      rewrite -Hc1c.
      case Hfhet : (find_het (QFBV.Eunop op e1) c1) => [[csop lsop] | ];
        last case Hbbop : (bit_blast_eunop op g1 ls1) => [[gop csop] lsop];
        case=> _ <- _ _ _; rewrite find_cbt_add_cet; (try done);
        by apply find_cbt_add_het.
    + rewrite /= Hfcet.
      case Hbb1: (bit_blast_exp_ccache te m c g e1) => [[[[m1 c1] g1] cs1] ls1].
      have He1e : QFBV.len_exp e1 < QFBV.len_bexp e by auto_prove_len_lt.
      move: (IHe _ _ _ _ _ _ _ _ _ _ _ He1e Hbb1) => Hc1c.
      case Hbb2: (bit_blast_exp_ccache te m1 c1 g1 e2) => [[[[m2 c2] g2] cs2] ls2].
      have He2e : QFBV.len_exp e2 < QFBV.len_bexp e by auto_prove_len_lt.
      move: (IHe _ _ _ _ _ _ _ _ _ _ _ He2e Hbb2) => Hc2c1.
      rewrite -Hc1c -Hc2c1.
      case Hfhet : (find_het (QFBV.Ebinop op e1 e2) c2) => [[csop lsop] | ];
        last case Hbbop : (bit_blast_ebinop op g2 ls1 ls2) => [[gop csop] lsop];
        case=> _ <- _ _ _; rewrite find_cbt_add_cet; (try done);
        by apply find_cbt_add_het.
    + rewrite /= Hfcet.
      case Hbbb: (bit_blast_bexp_ccache te m c g b) => [[[[mb cb] gb] csb] lb].
      have Hbe : QFBV.len_bexp b < QFBV.len_bexp e by auto_prove_len_lt.
      move: (IHb _ _ _ _ _ _ _ _ _ _ _ Hbe Hbbb) => Hcbc.
      case Hbb1: (bit_blast_exp_ccache te mb cb gb e1) => [[[[m1 c1] g1] cs1] ls1].
      have He1e : QFBV.len_exp e1 < QFBV.len_bexp e by auto_prove_len_lt.
      move: (IHe _ _ _ _ _ _ _ _ _ _ _ He1e Hbb1) => Hc1cb.
      case Hbb2: (bit_blast_exp_ccache te m1 c1 g1 e2) => [[[[m2 c2] g2] cs2] ls2].
      have He2e : QFBV.len_exp e2 < QFBV.len_bexp e by auto_prove_len_lt.
      move: (IHe _ _ _ _ _ _ _ _ _ _ _ He2e Hbb2) => Hc2c1.
      rewrite -Hcbc -Hc1cb -Hc2c1.
      case Hfhet : (find_het (QFBV.Eite b e1 e2) c2) => [[csop lsop] | ];
        last case Hbbop : (bit_blast_ite g2 lb ls1 ls2) => [[gop csop] lsop];
        case=> _ <- _ _ _; rewrite find_cbt_add_cet; (try done);
        by apply find_cbt_add_het.
  (* bit_blast_bexp_ccache_find_cbt *)
  set IHe := bit_blast_exp_ccache_find_cbt.
  set IHb := bit_blast_bexp_ccache_find_cbt.
  move=> e0 e te m c g m' c' g' cs l.
  case Hfcbt: (find_cbt e0 c) => [[cs0 l0] | ].
  - move=> _. rewrite bit_blast_bexp_ccache_equation Hfcbt /=.
    case=> _ <- _ _ _. done.
  - move: Hfcbt. case e0 => [ | | op e1 e2 | e1 | e1 e2 | e1 e2] Hfcbt Hlen.
    + rewrite /= Hfcbt.
      case Hfhet : (find_hbt QFBV.Bfalse c) => [[csh lh] | ]; case=> _ <- _ _ _;
        rewrite find_cbt_add_cbt_neq; (try auto_prove_neq_by_len);
        (try rewrite find_cbt_add_hbt); done.
    + rewrite /= Hfcbt.
      case Hfhet : (find_hbt QFBV.Btrue c) => [[csh lh] | ]; case=> _ <- _ _ _;
        rewrite find_cbt_add_cbt_neq; (try auto_prove_neq_by_len);
        (try rewrite find_cbt_add_hbt); done.
    + rewrite /= Hfcbt.
      case Hbb1: (bit_blast_exp_ccache te m c g e1) => [[[[m1 c1] g1] cs1] ls1].
      have He1e : QFBV.len_exp e1 < QFBV.len_bexp e by auto_prove_len_lt.
      move: (IHe _ _ _ _ _ _ _ _ _ _ _ He1e Hbb1) => Hc1c.
      case Hbb2: (bit_blast_exp_ccache te m1 c1 g1 e2) => [[[[m2 c2] g2] cs2] ls2].
      have He2e : QFBV.len_exp e2 < QFBV.len_bexp e by auto_prove_len_lt.
      move: (IHe _ _ _ _ _ _ _ _ _ _ _ He2e Hbb2) => Hc2c1.
      rewrite -Hc1c -Hc2c1.
      case Hfhbt : (find_hbt (QFBV.Bbinop op e1 e2) c2) => [[csop lop] | ];
        last case Hbbop : (bit_blast_bbinop op g2 ls1 ls2) => [[gop csop] lsop];
        case=> _ <- _ _ _; rewrite find_cbt_add_cbt_neq;
        (try auto_prove_neq_by_len); (try rewrite find_cbt_add_hbt); done.
    + rewrite /= Hfcbt.
      case Hbb1: (bit_blast_bexp_ccache te m c g e1) => [[[[m1 c1] g1] cs1] l1].
      have He1e : QFBV.len_bexp e1 < QFBV.len_bexp e by auto_prove_len_lt.
      move: (IHb _ _ _ _ _ _ _ _ _ _ _ He1e Hbb1) => Hc1c.
      rewrite -Hc1c.
      case Hfhbt : (find_hbt (QFBV.Blneg e1) c1) => [[csop lop] | ];
        case=> _ <- _ _ _; rewrite find_cbt_add_cbt_neq;
        (try auto_prove_neq_by_len); (try rewrite find_cbt_add_hbt); done.
    + rewrite /= Hfcbt.
      case Hbb1: (bit_blast_bexp_ccache te m c g e1) => [[[[m1 c1] g1] cs1] l1].
      have He1e : QFBV.len_bexp e1 < QFBV.len_bexp e by auto_prove_len_lt.
      move: (IHb _ _ _ _ _ _ _ _ _ _ _ He1e Hbb1) => Hc1c.
      case Hbb2: (bit_blast_bexp_ccache te m1 c1 g1 e2) => [[[[m2 c2] g2] cs2] l2].
      have He2e : QFBV.len_bexp e2 < QFBV.len_bexp e by auto_prove_len_lt.
      move: (IHb _ _ _ _ _ _ _ _ _ _ _ He2e Hbb2) => Hc2c1.
      rewrite -Hc1c -Hc2c1.
      case Hfhbt : (find_hbt (QFBV.Bconj e1 e2) c2) => [[csop lop] | ];
        case=> _ <- _ _ _; rewrite find_cbt_add_cbt_neq;
        (try auto_prove_neq_by_len); (try rewrite find_cet_add_hbt); done.
    + rewrite /= Hfcbt.
      case Hbb1: (bit_blast_bexp_ccache te m c g e1) => [[[[m1 c1] g1] cs1] l1].
      have He1e : QFBV.len_bexp e1 < QFBV.len_bexp e by auto_prove_len_lt.
      move: (IHb _ _ _ _ _ _ _ _ _ _ _ He1e Hbb1) => Hc1c.
      case Hbb2: (bit_blast_bexp_ccache te m1 c1 g1 e2) => [[[[m2 c2] g2] cs2] l2].
      have He2e : QFBV.len_bexp e2 < QFBV.len_bexp e by auto_prove_len_lt.
      move: (IHb _ _ _ _ _ _ _ _ _ _ _ He2e Hbb2) => Hc2c1.
      rewrite -Hc1c -Hc2c1.
      case Hfhbt : (find_hbt (QFBV.Bdisj e1 e2) c2) => [[csop lop] | ];
        case=> _ <- _ _ _; rewrite find_cbt_add_cbt_neq;
        (try auto_prove_neq_by_len); (try rewrite find_cbt_add_hbt); done.
Qed.

(* = bit_blast_exp_ccache_in_cet and bit_blast_bexp_ccache_in_cbt = *)

Lemma bit_blast_exp_ccache_in_cet :
  forall e te m c g m' c' g' cs ls,
    bit_blast_exp_ccache te m c g e = (m', c', g', cs, ls) ->
    exists cse, find_cet e c' = Some (cse, ls)
  with
    bit_blast_bexp_ccache_in_cbt :
      forall e te m c g m' c' g' cs l,
        bit_blast_bexp_ccache te m c g e = (m', c', g', cs, l) ->
        exists cse, find_cbt e c' = Some (cse, l).
Proof.
  (* exp *)
  move=> e te m c g m' c' g' cs ls.
  case Hfcet: (find_cet e c) => [[cse lse] | ].
  - rewrite bit_blast_exp_ccache_equation Hfcet /=.
    case=> _ <- _ _ <-. exists cse; done.
  - move: Hfcet. case: e.
    + move=> v Hfcet. rewrite /= Hfcet.
      case Hfhet : (find_het (QFBV.Evar v) c) => [[cse lse] | ];
        last case Hfv : (SSAVM.find v m);
        last case Hv : (bit_blast_var te g v) => [[gv csv] lsv];
        case=> _ <- _ _ <-; [ exists cse | exists [::] | exists csv];
        exact: find_cet_add_cet_eq.
    + move=> bs Hfcet. rewrite /= Hfcet.
      case Hfhet : (find_het (QFBV.Econst bs) c) => [[cse lse] | ];
        case=> _ <- _ _ <-; [ exists cse | exists [::]]; exact: find_cet_add_cet_eq.
    + move=> op e1 Hfcet. rewrite /= Hfcet.
      case He1 : (bit_blast_exp_ccache te m c g e1) => [[[[m1 c1] g1] cs1] ls1].
      case Hfhet : (find_het (QFBV.Eunop op e1) c1) => [[csop lsop] | ];
        last case Hop : (bit_blast_eunop op g1 ls1) => [[gop csop] lsop];
        case=> _ <- _ _ <-; exists csop; exact: find_cet_add_cet_eq.
    + move=> op e1 e2 Hfcet. rewrite /= Hfcet.
      case He1 : (bit_blast_exp_ccache te m c g e1) => [[[[m1 c1] g1] cs1] ls1].
      case He2 : (bit_blast_exp_ccache te m1 c1 g1 e2) => [[[[m2 c2] g2] cs2] ls2].
      case Hfhet : (find_het (QFBV.Ebinop op e1 e2) c2) => [[csop lsop] | ];
        last case Hop : (bit_blast_ebinop op g2 ls1 ls2) => [[gop csop] lsop];
        case=> _ <- _ _ <-; exists csop; exact: find_cet_add_cet_eq.
    + move=> b e1 e2 Hfcet. rewrite /= Hfcet.
      case Hb : (bit_blast_bexp_ccache te m c g b) => [[[[mb cb] gb] csb] lb].
      case He1 : (bit_blast_exp_ccache te mb cb gb e1) => [[[[m1 c1] g1] cs1] ls1].
      case He2 : (bit_blast_exp_ccache te m1 c1 g1 e2) => [[[[m2 c2] g2] cs2] ls2].
      case Hfhet : (find_het (QFBV.Eite b e1 e2) c2) => [[csop lsop] | ];
        last case Hop : (bit_blast_ite g2 lb ls1 ls2) => [[gop csop] lsop];
        case=> _ <- _ _ <-; exists csop; exact: find_cet_add_cet_eq.
  (* bexp *)
  move=> e te m c g m' c' g' cs l.
  case Hfcbt: (find_cbt e c) => [[cse le] | ].
  - rewrite bit_blast_bexp_ccache_equation Hfcbt /=.
    case=> _ <- _ _ <-. exists cse; done.
  - move: Hfcbt. case: e.
    + move=> Hfcbt. rewrite /= Hfcbt.
      case Hfhbt : (find_hbt (QFBV.Bfalse) c) => [[cse le] | ];
        case=> _ <- _ _ <-; [ exists cse | exists [::]]; exact: find_cbt_add_cbt_eq.
    + move=> Hfcbt. rewrite /= Hfcbt.
      case Hfhbt : (find_hbt (QFBV.Btrue) c) => [[cse le] | ];
        case=> _ <- _ _ <-; [ exists cse | exists [::]]; exact: find_cbt_add_cbt_eq.
    + move=> op e1 e2 Hfcbt. rewrite /= Hfcbt.
      case He1 : (bit_blast_exp_ccache te m c g e1) => [[[[m1 c1] g1] cs1] ls1].
      case He2 : (bit_blast_exp_ccache te m1 c1 g1 e2) => [[[[m2 c2] g2] cs2] ls2].
      case Hfhet : (find_hbt (QFBV.Bbinop op e1 e2) c2) => [[csop lop] | ];
        last case Hop : (bit_blast_bbinop op g2 ls1 ls2) => [[gop csop] lop];
        case=> _ <- _ _ <-; exists csop; exact: find_cbt_add_cbt_eq.
    + move=> e1 Hfcbt. rewrite /bit_blast_bexp_ccache -/bit_blast_bexp_ccache Hfcbt.
      case He1 : (bit_blast_bexp_ccache te m c g e1) => [[[[m1 c1] g1] cs1] l1].
      case Hfhbt : (find_hbt (QFBV.Blneg e1) c1) => [[csop lop] | ];
        last case Hop : (bit_blast_lneg g1 l1) => [[gop csop] lop];
        case=> _ <- _ _ <-; exists csop; exact: find_cbt_add_cbt_eq.
    + move=> e1 e2 Hfcbt.
      rewrite /bit_blast_bexp_ccache -/bit_blast_bexp_ccache Hfcbt.
      case He1 : (bit_blast_bexp_ccache te m c g e1) => [[[[m1 c1] g1] cs1] l1].
      case He2 : (bit_blast_bexp_ccache te m1 c1 g1 e2) => [[[[m2 c2] g2] cs2] l2].
      case Hfhbt : (find_hbt (QFBV.Bconj e1 e2) c2) => [[csop lop] | ];
        last case Hop : (bit_blast_conj g2 l1 l2) => [[gop csop] lop];
        case=> _ <- _ _ <-; exists csop; exact: find_cbt_add_cbt_eq.
    + move=> e1 e2 Hfcbt.
      rewrite /bit_blast_bexp_ccache -/bit_blast_bexp_ccache Hfcbt.
      case He1 : (bit_blast_bexp_ccache te m c g e1) => [[[[m1 c1] g1] cs1] l1].
      case He2 : (bit_blast_bexp_ccache te m1 c1 g1 e2) => [[[[m2 c2] g2] cs2] l2].
      case Hfhbt : (find_hbt (QFBV.Bdisj e1 e2) c2) => [[csop lop] | ];
        last case Hop : (bit_blast_disj g2 l1 l2) => [[gop csop] lop];
        case=> _ <- _ _ <-; exists csop; exact: find_cbt_add_cbt_eq.
Qed.

(* = bit_blast_exp_ccache_in_het and bit_blast_bexp_ccache_in_hbt = *)

Lemma bit_blast_exp_ccache_in_het :
  forall e te m c g m' c' g' cs ls,
    bit_blast_exp_ccache te m c g e = (m', c', g', cs, ls) ->
    CompCache.well_formed c ->
    exists cse, find_het e c' = Some (cse, ls)
  with
    bit_blast_bexp_ccache_in_hbt :
      forall e te m c g m' c' g' cs l,
        bit_blast_bexp_ccache te m c g e = (m', c', g', cs, l) ->
        CompCache.well_formed c ->
        exists cse, find_hbt e c' = Some (cse, l).
Proof.
  (* exp *)
  move=> e te m c g m' c' g' cs ls Hbb Hwfc. move: Hbb.
  case Hfcet: (find_cet e c) => [[cse lse] | ].
  - rewrite bit_blast_exp_ccache_equation Hfcet /=.
    case=> _ <- _ _ <-. exists cse; exact: (well_formed_find_cet Hwfc Hfcet).
  - move: Hfcet. case: e.
    + move=> v Hfcet. rewrite /= Hfcet.
      case Hfhet : (find_het (QFBV.Evar v) c) => [[cse lse] | ];
        last case Hfv : (SSAVM.find v m);
        last case Hv : (bit_blast_var te g v) => [[gv csv] lsv];
        case=> _ <- _ _ <-; [ exists cse | exists [::] | exists csv];
        rewrite find_het_add_cet; try rewrite find_het_add_het_eq; done.
    + move=> bs Hfcet. rewrite /= Hfcet.
      case Hfhet : (find_het (QFBV.Econst bs) c) => [[csop lsop] | ];
        case=> _ <- _ _ <-; [ exists csop | exists [::]];
        rewrite find_het_add_cet; try rewrite find_het_add_het_eq; done.
    + move=> op e1 Hfcet. rewrite /= Hfcet.
      case He1 : (bit_blast_exp_ccache te m c g e1) => [[[[m1 c1] g1] cs1] ls1].
      case Hfhet : (find_het (QFBV.Eunop op e1) c1) => [[csop lsop] | ];
        last case Hop : (bit_blast_eunop op g1 ls1) => [[gop csop] lsop];
        case=> _ <- _ _ <-; exists csop;
        rewrite find_het_add_cet; try rewrite find_het_add_het_eq; done.
    + move=> op e1 e2 Hfcet. rewrite /= Hfcet.
      case He1 : (bit_blast_exp_ccache te m c g e1) => [[[[m1 c1] g1] cs1] ls1].
      case He2 : (bit_blast_exp_ccache te m1 c1 g1 e2) => [[[[m2 c2] g2] cs2] ls2].
      case Hfhet : (find_het (QFBV.Ebinop op e1 e2) c2) => [[csop lsop] | ];
        last case Hop : (bit_blast_ebinop op g2 ls1 ls2) => [[gop csop] lsop];
        case=> _ <- _ _ <-; exists csop;
        rewrite find_het_add_cet; try rewrite find_het_add_het_eq; done.
    + move=> b e1 e2 Hfcet. rewrite /= Hfcet.
      case Hb : (bit_blast_bexp_ccache te m c g b) => [[[[mb cb] gb] csb] lb].
      case He1 : (bit_blast_exp_ccache te mb cb gb e1) => [[[[m1 c1] g1] cs1] ls1].
      case He2 : (bit_blast_exp_ccache te m1 c1 g1 e2) => [[[[m2 c2] g2] cs2] ls2].
      case Hfhet : (find_het (QFBV.Eite b e1 e2) c2) => [[csop lsop] | ];
        last case Hop : (bit_blast_ite g2 lb ls1 ls2) => [[gop csop] lsop];
        case=> _ <- _ _ <-; exists csop;
        rewrite find_het_add_cet; try rewrite find_het_add_het_eq; done.
  (* bexp *)
  move=> e te m c g m' c' g' cs l Hbb Hwfc. move: Hbb.
  case Hfcbt: (find_cbt e c) => [[cse le] | ].
  - rewrite bit_blast_bexp_ccache_equation Hfcbt /=.
    case=> _ <- _ _ <-. exists cse; exact: (well_formed_find_cbt Hwfc Hfcbt).
  - move: Hfcbt. case: e.
    + move=> Hfcbt. rewrite /= Hfcbt.
      case Hfhbt : (find_hbt (QFBV.Bfalse) c) => [[csop lop] | ];
        case=> _ <- _ _ <-; [ exists csop | exists [::]];
        rewrite find_hbt_add_cbt; try rewrite find_hbt_add_hbt_eq; done.
    + move=> Hfcbt. rewrite /= Hfcbt.
      case Hfhbt : (find_hbt (QFBV.Btrue) c) => [[csop lop] | ];
        case=> _ <- _ _ <-; [ exists csop | exists [::]];
        rewrite find_hbt_add_cbt; try rewrite find_hbt_add_hbt_eq; done.
    + move=> op e1 e2 Hfcbt. rewrite /= Hfcbt.
      case He1 : (bit_blast_exp_ccache te m c g e1) => [[[[m1 c1] g1] cs1] ls1].
      case He2 : (bit_blast_exp_ccache te m1 c1 g1 e2) => [[[[m2 c2] g2] cs2] ls2].
      case Hfhbt : (find_hbt (QFBV.Bbinop op e1 e2) c2) => [[csop lop] | ];
        last case Hop : (bit_blast_bbinop op g2 ls1 ls2) => [[gop csop] lop];
        case=> _ <- _ _ <-; exists csop;
        rewrite find_hbt_add_cbt; try rewrite find_hbt_add_hbt_eq; done.
    + move=> e1 Hfcbt.
      rewrite /bit_blast_bexp_ccache -/bit_blast_bexp_ccache Hfcbt.
      case He1 : (bit_blast_bexp_ccache te m c g e1) => [[[[m1 c1] g1] cs1] l1].
      case Hfhbt : (find_hbt (QFBV.Blneg e1) c1) => [[csop lop] | ];
        last case Hop : (bit_blast_lneg g1 l1) => [[gop csop] lop];
        case=> _ <- _ _ <-; exists csop;
        rewrite find_hbt_add_cbt; try rewrite find_hbt_add_hbt_eq; done.
    + move=> e1 e2 Hfcbt.
      rewrite /bit_blast_bexp_ccache -/bit_blast_bexp_ccache Hfcbt.
      case He1 : (bit_blast_bexp_ccache te m c g e1) => [[[[m1 c1] g1] cs1] l1].
      case He2 : (bit_blast_bexp_ccache te m1 c1 g1 e2) => [[[[m2 c2] g2] cs2] l2].
      case Hfhbt : (find_hbt (QFBV.Bconj e1 e2) c2) => [[csop lop] | ];
        last case Hop : (bit_blast_conj g2 l1 l2) => [[gop csop] lop];
        case=> _ <- _ _ <-; exists csop;
        rewrite find_hbt_add_cbt; try rewrite find_hbt_add_hbt_eq; done.
    + move=> e1 e2 Hfcbt.
      rewrite /bit_blast_bexp_ccache -/bit_blast_bexp_ccache Hfcbt.
      case He1 : (bit_blast_bexp_ccache te m c g e1) => [[[[m1 c1] g1] cs1] l1].
      case He2 : (bit_blast_bexp_ccache te m1 c1 g1 e2) => [[[[m2 c2] g2] cs2] l2].
      case Hfhbt : (find_hbt (QFBV.Bdisj e1 e2) c2) => [[csop lop] | ];
        last case Hop : (bit_blast_disj g2 l1 l2) => [[gop csop] lop];
        case=> _ <- _ _ <-; exists csop;
        rewrite find_hbt_add_cbt; try rewrite find_hbt_add_hbt_eq; done.
Qed.