(*
 * © 2020 Massachusetts Institute of Technology.
 * MIT Proprietary, Subject to FAR52.227-11 Patent Rights - Ownership by the Contractor (May 2014)
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     List
     Lia.

From SPICY Require Import
     MyPrelude
     Maps
     ChMaps
     Messages
     Keys
     Automation
     Tactics
     Simulation
     AdversaryUniverse

     ModelCheck.SafeProtocol
     ModelCheck.ProtocolFunctions
     ModelCheck.SilentStepElimination
     ModelCheck.SteppingTactics
     ModelCheck.InvariantSearch
.

From protocols Require Import
     GenProto.

From SPICY Require IdealWorld RealWorld.

Import IdealWorld.IdealNotations
       RealWorld.RealWorldNotations
       SimulationAutomation.

From Frap Require Sets.

Module Foo <: Sets.EMPTY.
End Foo.
Module Import SN := Sets.SetNotations(Foo).

Set Implicit Arguments.

Open Scope protocol_scope.

Module MyProtocolSecure <: AutomatedSafeProtocolSS.

  Import MyProtocol.

  (* Some things may need to change here.  t__hon is where we place the
   * type that the protocol computes.  It is set to Nat now, because we
   * return a natual number.
   *)
  Definition t__hon := Nat.
  Definition t__adv := Unit.
  Definition b    := tt.

  (* These two variables hook up the starting points for both specification and
   * implementation universes.  If you followed the template above, this shouldn't
   * need to be changed.
   *)
  Definition iu0  := ideal_univ_start.
  Definition ru0  := real_univ_start.

  Import Gen Tacs.

  (* These are here to help the proof automation.  Don't change. *)
  #[export] Hint Unfold t__hon t__adv b ru0 iu0 ideal_univ_start real_univ_start : core.
  #[export] Hint Unfold
       mkiU mkiUsr mkrU mkrUsr
       mkKeys
    : core.

  (* Set Ltac Profiling. *)

  Lemma safe_invariant :
    invariantFor
      {| Initial := {(ru0, iu0, true)}; Step := @stepSS t__hon t__adv  |}
      (@safety_inv t__hon t__adv).
      (* (fun st => safety st /\ alignment st /\ returns_align st). *)
  Proof.
    unfold invariantFor
    ; unfold Initial, Step
    ; intros
    ; simpl in *
    ; split_ors
    ; try contradiction
    ; subst.

    autounfold in H0
    ; unfold fold_left, fst, snd in *.

    time (
        repeat transition_system_step
      ).

      Unshelve.
      all: exact 0 || auto.
  Qed.

  Lemma U_good : @universe_starts_sane _ Unit b ru0.
  Proof.
    autounfold;
      unfold universe_starts_sane; simpl.
    repeat (apply conj); intros; eauto.
    - focus_user; auto.
    - econstructor.
    - unfold AdversarySafety.keys_honest; rewrite Forall_natmap_forall; intros.
      unfold mkrUsr; simpl.
      rewrite !findUserKeys_add_reduce, findUserKeys_empty_is_empty; eauto.
    - unfold lameAdv; simpl; eauto.
  Qed.

  Lemma universe_starts_safe : universe_ok ru0.
  Proof.
    pose proof (adversary_is_lame_adv_univ_ok_clauses U_good).

    unfold universe_ok
    ; autounfold
    ; simpl
    ; intuition eauto
    .

    - econstructor; eauto.
    - unfold keys_and_permissions_good; solve_simple_maps; intuition eauto.
      solve_simple_maps; eauto.

      rewrite Forall_natmap_forall; intros.

      solve_simple_maps; simpl
      ; unfold permission_heap_good; intros;
        solve_simple_maps; solve_concrete_maps; eauto.

    - unfold user_cipher_queues_ok.
      rewrite Forall_natmap_forall; intros.
      focus_user
      ; simpl in *; econstructor; eauto.

    - unfold honest_nonces_ok, honest_user_nonces_ok, honest_nonces_ok
      ; repeat simple apply conj
      ; intros
      ; clean_map_lookups
      ; intros
      ; focus_user
      ; try contradiction; try discriminate; simpl;
        repeat (apply conj); intros; clean_map_lookups; eauto.

    - unfold honest_users_only_honest_keys; intros.
      focus_user;
        subst;
        simpl in *;
        clean_map_lookups;
        unfold mkrUsr; simpl;
          rewrite !findUserKeys_add_reduce, findUserKeys_empty_is_empty;
          eauto;
          simpl in *;
          solve_concrete_perm_merges;
          solve_concrete_maps;
          solve_simple_maps;
          eauto.
  Qed.

End MyProtocolSecure.


Require Import Reals Psatz ClassicalEpsilon.
(** An axiomatization of evaluation-context based languages, including a proof
    that this gives rise to a "language" in the Iris sense. *)
From iris.algebra Require Export base.
From iris.program_logic Require Import prob_language.
From discprob.prob Require Import prob countable.
From mathcomp Require Import ssreflect bigop choice fintype finset ssrbool eqtype.
Set Default Proof Using "Type".

(* TAKE CARE: When you define an [ectxLanguage] canonical structure for your
language, you need to also define a corresponding [language] canonical
structure. Use the coercion [LanguageOfEctx] as defined in the bottom of this
file for doing that. *)

Section ectx_language_mixin.
  Context {expr val ectx state : Type}.
  Context (of_val : val → expr).
  Context (to_val : expr → option val).
  Context (empty_ectx : ectx).
  Context (comp_ectx : ectx → ectx → ectx).
  Context (fill : ectx → expr → expr).
  Context (head_step : expr → state → expr → state → list expr → Prop).
  Context (head_step_prob : expr → state → expr → state → list expr → R).

  Record EctxLanguageMixin := {
    mixin_to_of_val v : to_val (of_val v) = Some v;
    mixin_of_to_val e v : to_val e = Some v → of_val v = e;
    mixin_val_head_stuck e1 σ1 e2 σ2 efs :
      head_step e1 σ1 e2 σ2 efs → to_val e1 = None;

    mixin_fill_empty e : fill empty_ectx e = e;
    mixin_fill_comp K1 K2 e : fill K1 (fill K2 e) = fill (comp_ectx K1 K2) e;
    mixin_fill_inj K : Inj (=) (=) (fill K);
    mixin_fill_val K e : is_Some (to_val (fill K e)) → is_Some (to_val e);

    (* There are a whole lot of sensible axioms (like associativity, and left and
    right identity, we could demand for [comp_ectx] and [empty_ectx]. However,
    positivity suffices. *)
    mixin_ectx_positive K1 K2 :
      comp_ectx K1 K2 = empty_ectx → K1 = empty_ectx ∧ K2 = empty_ectx;

    mixin_step_by_val K K' e1 e1' σ1 e2 σ2 efs :
      fill K e1 = fill K' e1' →
      to_val e1 = None →
      head_step e1' σ1 e2 σ2 efs →
      ∃ K'', K' = comp_ectx K K'';

    mixin_step_by_val_eq K K' e1 e1' σ1 e2 e2' σ2 σ2' efs efs' :
      fill K e1 = fill K' e1' →
      head_step e1 σ1 e2 σ2 efs →
      head_step e1' σ1 e2' σ2' efs' →
      K = K';

    mixin_head_step_count e σ:
      Countable.class_of { esf: expr * state * list expr |
                           head_step e σ (esf.1.1) (esf.1.2) (esf.2) };
    mixin_head_step_sum1 e σ:
        (∃ e' σ' efs, head_step e σ e' σ' efs) →
        is_series (countable_sum (λ t : Countable.Pack (mixin_head_step_count e σ)
                                        { esf: expr * state * list expr |
                                          head_step e σ (esf.1.1) (esf.1.2) (esf.2) },
                                    head_step_prob e σ
                                                   (fst (fst (sval t)))
                                                   (snd (fst (sval t)))
                                                   (snd (sval t)))) 1;
    mixin_head_step_nonneg : ∀ e1 σ1 e2 σ2 efs, (head_step_prob e1 σ1 e2 σ2 efs >= 0)%R;
    mixin_head_step_strict_gt :
    ∀ e1 σ1 e2 σ2 efs, head_step e1 σ1 e2 σ2 efs ↔ (head_step_prob e1 σ1 e2 σ2 efs > 0)%R

  }.
End ectx_language_mixin.

Structure ectxLanguage := EctxLanguage {
  expr : Type;
  val : Type;
  ectx : Type;
  state : Type;

  of_val : val → expr;
  to_val : expr → option val;
  empty_ectx : ectx;
  comp_ectx : ectx → ectx → ectx;
  fill : ectx → expr → expr;
  head_step : expr → state → expr → state → list expr → Prop;
  head_step_prob : expr → state → expr → state → list expr → R;

  ectx_language_mixin :
    EctxLanguageMixin of_val to_val empty_ectx comp_ectx fill head_step head_step_prob;

}.

Arguments EctxLanguage {_ _ _ _ _ _ _ _ _ _ _} _.
Arguments of_val {_} _%V.
Arguments to_val {_} _%E.
Arguments empty_ectx {_}.
Arguments comp_ectx {_} _ _.
Arguments fill {_} _ _%E.
Arguments head_step {_} _%E _ _%E _ _.
Arguments head_step_prob {_} _%E _ _%E _ _.

(* From an ectx_language, we can construct a language. *)
Section ectx_language.
  Context {Λ : ectxLanguage}.
  Implicit Types v : val Λ.
  Implicit Types e : expr Λ.
  Implicit Types K : ectx Λ.

  (* Only project stuff out of the mixin that is not also in language *)
  Lemma val_head_stuck e1 σ1 e2 σ2 efs : head_step e1 σ1 e2 σ2 efs → to_val e1 = None.
  Proof. apply ectx_language_mixin. Qed.
  Lemma fill_empty e : fill empty_ectx e = e.
  Proof. apply ectx_language_mixin. Qed.
  Lemma fill_comp K1 K2 e : fill K1 (fill K2 e) = fill (comp_ectx K1 K2) e.
  Proof. apply ectx_language_mixin. Qed.
  Global Instance fill_inj K : Inj (=) (=) (fill K).
  Proof. apply ectx_language_mixin. Qed.
  Lemma fill_val K e : is_Some (to_val (fill K e)) → is_Some (to_val e).
  Proof. apply ectx_language_mixin. Qed.
  Lemma ectx_positive K1 K2 :
    comp_ectx K1 K2 = empty_ectx → K1 = empty_ectx ∧ K2 = empty_ectx.
  Proof. apply ectx_language_mixin. Qed.
  Lemma step_by_val_eq K K' e1 e1' σ1 e2 e2' σ2 σ2' efs efs' :
      fill K e1 = fill K' e1' →
      head_step e1 σ1 e2 σ2 efs →
      head_step e1' σ1 e2' σ2' efs' →
      K = K'.
  Proof. apply ectx_language_mixin. Qed.
  Lemma step_by_val K K' e1 e1' σ1 e2 σ2 efs :
    fill K e1 = fill K' e1' →
    to_val e1 = None →
    head_step e1' σ1 e2 σ2 efs →
    ∃ K'', K' = comp_ectx K K''.
  Proof. apply ectx_language_mixin. Qed.
  Lemma head_step_count e σ:
    Countable.class_of { esf: expr Λ * state Λ * list (expr Λ) |
                           head_step e σ (esf.1.1) (esf.1.2) (esf.2) }.
  Proof. apply ectx_language_mixin. Defined.
  Lemma head_step_sum1 e σ:
    (∃ e' σ' efs, head_step e σ e' σ' efs) →
    is_series (countable_sum (λ t : Countable.Pack (head_step_count e σ)
                                                   { esf: expr Λ * state Λ * list (expr Λ) |
                                                     head_step e σ (esf.1.1) (esf.1.2) (esf.2) },
                                    head_step_prob e σ
                                                   (fst (fst (sval t)))
                                                   (snd (fst (sval t)))
                                                   (snd (sval t)))) 1.
  Proof. apply ectx_language_mixin. Qed.
  Lemma head_step_nonneg e1 σ1 e2 σ2 efs:
    (head_step_prob e1 σ1 e2 σ2 efs >= 0)%R.
  Proof. apply ectx_language_mixin. Qed.
  Lemma head_step_strict_gt e1 σ1 e2 σ2 efs:
    head_step e1 σ1 e2 σ2 efs ↔ (head_step_prob e1 σ1 e2 σ2 efs > 0)%R.
  Proof. apply ectx_language_mixin. Qed.

  Definition head_reducible (e : expr Λ) (σ : state Λ) :=
    ∃ e' σ' efs, head_step e σ e' σ' efs.
  Definition head_irreducible (e : expr Λ) (σ : state Λ) :=
    ∀ e' σ' efs, ¬head_step e σ e' σ' efs.
  Definition head_stuck (e : expr Λ) (σ : state Λ) :=
    to_val e = None ∧ ∀ K e', e = fill K e' → head_irreducible e' σ.

  (* All non-value redexes are at the root.  In other words, all sub-redexes are
     values. *)
  Definition sub_redexes_are_values (e : expr Λ) :=
    ∀ K e', e = fill K e' → to_val e' = None → K = empty_ectx.

  Inductive prim_step (e1 : expr Λ) (σ1 : state Λ)
      (e2 : expr Λ) (σ2 : state Λ) (efs : list (expr Λ)) : Prop :=
    Ectx_step K e1' e2' :
      e1 = fill K e1' → e2 = fill K e2' →
      head_step e1' σ1 e2' σ2 efs → prim_step e1 σ1 e2 σ2 efs.

  Definition prim_step_prob (e1 : expr Λ) (σ1 : state Λ)
             (e2 : expr Λ) (σ2 : state Λ) (efs : list (expr Λ)) : R :=
    (let s :=
         excluded_middle_informative
           (∃ (K : ectx Λ) (e1' e2' : expr Λ), e1 = fill K e1' ∧ e2 = fill K e2'
                                           ∧ head_step e1' σ1 e2' σ2 efs) in
     match s with
     | left Hhead =>
       let (K, Hhead1) := constructive_indefinite_description _ Hhead in
       let (e1', Hhead2) := constructive_indefinite_description _ Hhead1 in
       let (e2', _) := constructive_indefinite_description _ Hhead2 in
       head_step_prob e1' σ1 e2' σ2 efs
     | right _ => 0%R
     end).

  Definition prim_step_pickle e σ (esf: {esf : expr Λ * state Λ * list (expr Λ) |
                                         prim_step e σ esf.1.1 esf.1.2 esf.2}):
    nat.
  Proof.
    destruct esf as (esf&Hstep).
    destruct (excluded_middle_informative
                (∃ (K : ectx Λ) (e1' e2' : expr Λ),
                    e = fill K e1' ∧ esf.1.1 = fill K e2'
                    ∧ head_step e1' σ e2' esf.1.2 esf.2)) as [Hex|Hnex].
    - apply constructive_indefinite_description in Hex as (K&Hex).
      apply constructive_indefinite_description in Hex as (e1'&Hex).
      apply constructive_indefinite_description in Hex as (e2'&Hex).
      apply (@pickle (Countable.Pack (head_step_count e1' σ)
                                     { esf: expr Λ * state Λ * list (expr Λ) |
                                       head_step e1' σ e2' (esf.1.2) (esf.2)})).
      exists (e2', esf.1.2, esf.2); rewrite //=; abstract (intuition).
    - abstract (exfalso; eapply Hnex; inversion Hstep; do 3 eexists; split_and!; eauto).
  Defined.

  Definition prim_step_unpickle e σ (n: nat) :
    option {esf : expr Λ * state Λ * list (expr Λ) | prim_step e σ esf.1.1 esf.1.2 esf.2}.
  Proof.
    destruct (excluded_middle_informative
                (∃ (K : ectx Λ) (e1' e2' : expr Λ) σ' efs,
                    e = fill K e1' ∧ head_step e1' σ e2' σ' efs)) as [Hex|Hnex].
    - apply constructive_indefinite_description in Hex as (K&Hex).
      apply constructive_indefinite_description in Hex as (e1'&Hex).
      destruct (@unpickle (Countable.Pack (head_step_count e1' σ)
                                     { esf: expr Λ * state Λ * list (expr Λ) |
                                       head_step e1' σ (esf.1.1) (esf.1.2) (esf.2)}) n)
               as [s|].
      * destruct s as (esf&Hpf).
        apply Some. exists (fill K (esf.1.1), esf.1.2, esf.2).
        abstract (destruct Hex as (?&?&?&?); eexists; eauto; intuition).
      * apply None.
    - apply None.
  Defined.

  Lemma pickle_primK e σ:
    ssrfun.pcancel (prim_step_pickle e σ) (prim_step_unpickle e σ).
  Proof.
    rewrite /prim_step_pickle/prim_step_unpickle//=.
    intros (esf&Hstep) => //=.
    destruct excluded_middle_informative as [Hex|Hnex]; last first.
    {
      exfalso. apply Hnex. inversion Hstep.
      do 5 eexists. split_and!; eauto.
    }
    destruct constructive_indefinite_description as (K&?).
    destruct constructive_indefinite_description as (e1'&Hex'').
    destruct excluded_middle_informative as [Hex'|Hnex']; last first.
    {
      exfalso. eapply Hnex'.
      destruct Hex'' as (?&?&?&?&?).
      inversion Hstep. subst.
      do 3 eexists; eauto.
    }
    destruct Hex'' as (e2'&σ'&efs&?&?).
    destruct constructive_indefinite_description as (K'&?).
    destruct constructive_indefinite_description as (e1''&?).
    destruct constructive_indefinite_description as (e2''&Hex''').
    assert (K' = K).
    { intuition. eapply step_by_val_eq.
      * transitivity e; eauto.
      * eauto.
      * eauto.
    }
    subst.
    assert (e1' = e1'').
    { intuition. eapply fill_inj. eauto. }
    subst.
    rewrite pickleK => //=.
    f_equal. apply sval_inj_pi => //=.
    intuition.
    destruct esf as [[? ?] ?].
    rewrite //=. subst.
    f_equal. f_equal. eauto.
  Qed.

  Lemma Ectx_step' K e1 σ1 e2 σ2 efs :
    head_step e1 σ1 e2 σ2 efs → prim_step (fill K e1) σ1 (fill K e2) σ2 efs.
  Proof. econstructor; eauto. Qed.

  Definition ectx_lang_mixin : LanguageMixin of_val to_val prim_step.
  Proof.
    split.
    - apply ectx_language_mixin.
    - apply ectx_language_mixin.
    - intros ????? [??? -> -> ?%val_head_stuck].
      apply eq_None_not_Some. by intros ?%fill_val%eq_None_not_Some.
  Qed.

  Lemma map_legacy {A B: Type} (f: A → B) l:
    seq.map f l = List.map f l.
  Proof.
    induction l => //=.
  Qed.

  Lemma ectx_count_mixin:
  ∀ (e : expr Λ) (σ : state Λ),
    Countable.class_of {esf : expr Λ * state Λ * list (expr Λ) | prim_step e σ esf.1.1 esf.1.2 esf.2}.
  Proof.
    intros e σ.
    split.
    - econstructor.
      * exists (λ x y, ClassicalEpsilon.excluded_middle_informative (x = y)).
        intros x y. destruct excluded_middle_informative; eauto; econstructor => //=.
      * eapply PcanChoiceMixin; eapply pickle_primK.
    - eapply PcanCountMixin; eapply pickle_primK.
  Qed.

  Definition ectx_prob_lang_mixin : ProbLanguageMixin of_val to_val prim_step prim_step_prob.
  Proof.
    unshelve (econstructor).
    - intros. apply ectx_count_mixin.
    - apply ectx_language_mixin.
    - apply ectx_language_mixin.
    - intros ????? [??? -> -> ?%val_head_stuck].
      apply eq_None_not_Some. by intros ?%fill_val%eq_None_not_Some.
    - intros e1 σ1 (e2&σ2&efs&Hprim).
      inversion Hprim as [K e1' e2' ? ? ?]; subst.
      feed pose proof (head_step_sum1 e1' σ1) as His.
      { do 3 eexists; eauto. }
      rewrite -(is_series_unique _ _ His).
      unshelve (edestruct (@rearrange.countable_series_rearrange_covering
                             (Countable.Pack (ectx_count_mixin (fill K e1') σ1)
                                             {esf : expr Λ * state Λ * list (expr Λ) |
                                              prim_step (fill K e1') σ1 esf.1.1 esf.1.2 esf.2})
                             (Countable.Pack (head_step_count e1' σ1)
                                             {esf : expr Λ * state Λ * list (expr Λ) |
                                              head_step e1' σ1 esf.1.1 esf.1.2 esf.2})
                          ) as (His1&His2));
       last (eapply is_seriesC_ext; last eapply His2).
      * intros (esf&Hstep).
        assert (Hfill: ∃ e2'', fill K e2'' = esf.1.1 ∧
                        head_step e1' σ1 e2'' esf.1.2 esf.2).
        {
        inversion Hstep as [K' e1'' e2''].
          assert (K = K').
          { abstract (intuition; eapply step_by_val_eq; eauto). }
          assert (e1' = e1'').
          { abstract (subst; eapply fill_inj; eauto). }
          exists e2'';
            abstract (rewrite //=; subst; eauto).
        }
        apply constructive_indefinite_description in Hfill as (e2''&?&?).
        exists (e2'', esf.1.2, esf.2); auto.
      * exact 1.
      * intros (esf1&Hstep1) (esf2&Hstep2) Hnz => //=.
        destruct Hstep1.
        destruct esf1 as [[? ?] ?].
        destruct esf2 as [[? ?] ?].
        rewrite //=.
        destruct constructive_indefinite_description as (e2''&?&?).
        destruct constructive_indefinite_description as (e2'''&?&?).
        inversion 1. subst. eapply sval_inj_pi.
        rewrite //=.
      * intros (esf&Hstep1) Hnz.
        unshelve (eexists).
        { exists (fill K (esf.1.1), esf.1.2, esf.2).
          { econstructor => //=. }
        }
        rewrite //=.
        destruct esf as [[? ?] ?] => //=.
        destruct constructive_indefinite_description as (e2''&?&?).
        apply sval_inj_pi => //=.
        subst; f_equal.
        f_equal.
        eapply fill_inj; eauto.
      * eapply is_seriesC_ext; try eassumption.
        intros n => //=. rewrite Rabs_right //=. apply head_step_nonneg.
      * intros (esf&Hstep) => //=.
        destruct constructive_indefinite_description as (e2''&?&?).
        rewrite /prim_step_prob.
        destruct excluded_middle_informative as [?|Hnex].
        ** destruct (constructive_indefinite_description) as (K'&?).
           destruct (constructive_indefinite_description) as (e1''&?).
           destruct (constructive_indefinite_description) as (e2'''&Hfill1'&Hfill2'&Hstep').

           assert (K = K') as HeqK.
           { eapply (step_by_val_eq K K' e1' e1'');
               eauto; congruence. }
           assert (e1' = e1'') as Heqe.
           { subst. eapply fill_inj; eauto.  }
           subst.
           rewrite //=.
           f_equal.
           eapply fill_inj; eauto.
           transitivity (esf.1.1); eauto.
        ** exfalso; eapply Hnex. do 3 eexists; intuition; eauto.
    - intros. rewrite /prim_step_prob.
      destruct (excluded_middle_informative); last by nra.
      repeat destruct (constructive_indefinite_description).
      apply ectx_language_mixin.
    - intros ?????. split.
      * intros Hstep. rewrite /prim_step_prob.
        destruct (excluded_middle_informative) as [|Hn].
        ** repeat destruct (constructive_indefinite_description).
           apply ectx_language_mixin.
           firstorder.
        ** exfalso. edestruct Hn.
           inversion Hstep. do 3 eexists; split_and!; eauto.
      * rewrite /prim_step_prob. intros Hgt.
        destruct (excluded_middle_informative) as [|Hn].
        ** do 2 destruct (constructive_indefinite_description).
           destruct constructive_indefinite_description as (?&?&?&?).
           econstructor; eauto.
        ** nra.
  Qed.
  Canonical Structure ectx_prob_lang : probLanguage := ProbLanguage ectx_prob_lang_mixin.
  Canonical Structure ectx_lang := LanguageOfProb ectx_prob_lang.

  Definition head_atomic (a : atomicity) (e : expr Λ) : Prop :=
    ∀ σ e' σ' efs,
      head_step e σ e' σ' efs →
      if a is WeaklyAtomic then irreducible e' σ' else is_Some (to_val e').

  (* Some lemmas about this language *)
  Lemma fill_not_val K e : to_val e = None → to_val (fill K e) = None.
  Proof. rewrite !eq_None_not_Some. eauto using fill_val. Qed.

  Lemma head_prim_step e1 σ1 e2 σ2 efs :
    head_step e1 σ1 e2 σ2 efs → prim_step e1 σ1 e2 σ2 efs.
  Proof. apply Ectx_step with empty_ectx; by rewrite ?fill_empty. Qed.

  Lemma not_head_reducible e σ : ¬head_reducible e σ ↔ head_irreducible e σ.
  Proof. unfold head_reducible, head_irreducible. naive_solver. Qed.

  Program Lemma head_prim_reducible e σ : head_reducible e σ → reducible e σ.
  Proof. intros (e'&σ'&efs&?). eexists e', σ', efs. by apply head_prim_step. Qed.

  Lemma head_prim_irreducible e σ : irreducible e σ → head_irreducible e σ.
  Proof.
    rewrite -not_reducible -not_head_reducible. eauto using head_prim_reducible.
  Qed.

  Lemma prim_head_reducible e σ :
    reducible e σ → sub_redexes_are_values e → head_reducible e σ.
  Proof.
    intros (e'&σ'&efs&[K e1' e2' -> -> Hstep]) ?.
    assert (K = empty_ectx) as -> by eauto 10 using val_head_stuck.
    rewrite fill_empty /head_reducible; eauto.
  Qed.
  Lemma prim_head_irreducible e σ :
    head_irreducible e σ → sub_redexes_are_values e → irreducible e σ.
  Proof.
    rewrite -not_reducible -not_head_reducible. eauto using prim_head_reducible.
  Qed.

  Lemma head_stuck_stuck e σ :
    head_stuck e σ → sub_redexes_are_values e → stuck e σ.
  Proof.
    move=>[] ? Hirr ?. split; first done.
    apply prim_head_irreducible; last done.
    apply (Hirr empty_ectx). by rewrite fill_empty.
  Qed.

  Lemma ectx_language_atomic a e :
    head_atomic a e → sub_redexes_are_values e → Atomic a e.
  Proof.
    intros Hatomic_step Hatomic_fill σ e' σ' efs [K e1' e2' -> -> Hstep].
    assert (K = empty_ectx) as -> by eauto 10 using val_head_stuck.
    rewrite fill_empty. eapply Hatomic_step. by rewrite fill_empty.
  Qed.

  Lemma head_reducible_prim_step e1 σ1 e2 σ2 efs :
    head_reducible e1 σ1 →
    prim_step e1 σ1 e2 σ2 efs →
    head_step e1 σ1 e2 σ2 efs.
  Proof.
    intros (e2''&σ2''&efs''&?) [K e1' e2' -> -> Hstep].
    erewrite (step_by_val_eq K empty_ectx e1' (fill K e1'));
      eauto using fill_empty, fill_not_val, val_stuck.
    by rewrite !fill_empty.
  Qed.

  Lemma head_reducible_prim_step_prob e1 σ1 e2 σ2 efs :
    head_reducible e1 σ1 →
    sub_redexes_are_values e1 →
    prim_step_prob e1 σ1 e2 σ2 efs = head_step_prob e1 σ1 e2 σ2 efs.
  Proof.
    intros Hred Hsub. rewrite /prim_step_prob.
    destruct ClassicalEpsilon.excluded_middle_informative as [?|Hnot]; last first.
    {
      edestruct head_step_nonneg; eauto.
      exfalso. apply Hnot.
      exists empty_ectx. do 2 eexists; rewrite ?fill_empty; split_and!; eauto.
      apply head_step_strict_gt; auto.
    }

    destruct (ClassicalEpsilon.constructive_indefinite_description) as (K&?).
    destruct (ClassicalEpsilon.constructive_indefinite_description) as (e1'&?).
    destruct (ClassicalEpsilon.constructive_indefinite_description) as (e2'&?&?&?).
    subst. rewrite /sub_redexes_are_values in Hsub.
    assert (K = empty_ectx).
    { eapply Hsub; eauto. eapply val_head_stuck; eauto. }
    subst; rewrite ?fill_empty => //=.
  Qed.

  (* Every evaluation context is a context. *)
  Global Instance ectx_lang_ctx K : LanguageCtx (fill K).
  Proof.
    split; simpl.
    - eauto using fill_not_val.
    - intros ????? [K' e1' e2' Heq1 Heq2 Hstep].
      by exists (comp_ectx K K') e1' e2'; rewrite ?Heq1 ?Heq2 ?fill_comp.
    - intros e1 σ1 e2 σ2 ? Hnval [K'' e1'' e2'' Heq1 -> Hstep].
      destruct (step_by_val K K'' e1 e1'' σ1 e2'' σ2 efs) as [K' ->]; eauto.
      rewrite -fill_comp in Heq1; apply (inj (fill _)) in Heq1.
      exists (fill K' e2''); rewrite -fill_comp; split; auto.
      econstructor; eauto.
    - eauto using fill_inj.
  Qed.

  Global Instance ectx_lang_ctx_prob K : ProbLanguageCtx (fill K).
  Proof.
    split.
    - apply: _.
    - intros. rewrite //=/prim_step_prob//=.
      destruct (excluded_middle_informative) as [|Hn] => //=;
      destruct (excluded_middle_informative) as [|HnK] => //=.
      ** destruct (constructive_indefinite_description) as (K'&?).
         destruct (constructive_indefinite_description) as (e1''&?).
         destruct (constructive_indefinite_description) as (e2''&Hfill1'&Hfill2'&Hstep).

         destruct (constructive_indefinite_description) as (K''&?).
         destruct (constructive_indefinite_description) as (e1'''&?).
         destruct (constructive_indefinite_description) as (e2'''&Hfill1''&Hfill2''&Hstep').

         rewrite Hfill1' fill_comp in Hfill1''.
         rewrite Hfill2' fill_comp in Hfill2''.
         assert (comp_ectx K K' = K'').
         { eapply step_by_val_eq.
           * apply Hfill1''.
           * eauto.
           * eauto.
         }
         subst.
         f_equal; auto.
         *** eapply fill_inj; eauto.
         *** eapply fill_inj; eauto.
      ** destruct (constructive_indefinite_description) as (K'&?).
         destruct (constructive_indefinite_description) as (e1''&?).
         destruct (constructive_indefinite_description) as (e2''&Hfill1'&Hfill2'&Hstep).

         exfalso; eapply HnK.
         exists (comp_ectx K K'), e1'', e2''; split_and!; subst.
         *** apply fill_comp.
         *** apply fill_comp.
         *** eauto.
      ** destruct (constructive_indefinite_description) as (K'&?).
         destruct (constructive_indefinite_description) as (e1''&?).
         destruct (constructive_indefinite_description) as (e2''&Hfill1'&Hfill2'&Hstep).

         exfalso; eapply Hn.
         edestruct step_by_val as (K''&Heq); try apply Hstep; eauto.
         subst.
         rewrite -?fill_comp in Hfill1' Hfill2'.
         apply fill_inj in Hfill1'.
         apply fill_inj in Hfill2'.
         exists K'', e1'', e2''; repeat split; auto.
  Qed.

  Lemma det_head_step_pure_exec (P : Prop) e1 e2 :
    (∀ σ, P → head_reducible e1 σ) →
    (∀ σ1 e2' σ2 efs,
      P → head_step e1 σ1 e2' σ2 efs → σ1 = σ2 ∧ e2=e2' ∧ efs = []) →
    PureExec P e1 e2.
  Proof.
    intros Hp1 Hp2. split.
    - intros σ ?. destruct (Hp1 σ) as (e2' & σ2 & efs & ?); first done.
      eexists e2', σ2, efs. by apply head_prim_step.
    - intros σ1 e2' σ2 efs ? ?%head_reducible_prim_step; eauto.
  Qed.

  Global Instance pure_exec_fill K e1 e2 φ :
    PureExec φ e1 e2 →
    PureExec φ (fill K e1) (fill K e2).
  Proof. apply: pure_exec_ctx. Qed.

End ectx_language.

Arguments ectx_prob_lang : clear implicits.
Arguments ectx_lang : clear implicits.
Coercion ectx_prob_lang : ectxLanguage >-> probLanguage.
Coercion ectx_lang : ectxLanguage >-> language.

(* This definition makes sure that the fields of the [language] record do not
refer to the projections of the [ectxLanguage] record but to the actual fields
of the [ectxLanguage] record. This is crucial for canonical structure search to
work.

Note that this trick no longer works when we switch to canonical projections
because then the pattern match [let '...] will be desugared into projections. *)
Definition ProbLanguageOfEctx (Λ : ectxLanguage) : probLanguage :=
  let '@EctxLanguage E V C St of_val to_val empty comp fill head head_prob mix := Λ in
  @ProbLanguage E V St of_val to_val _ _
    (@ectx_prob_lang_mixin (@EctxLanguage E V C St of_val to_val empty comp fill head head_prob mix)).


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

From compcert Require Import Integers Values.
From bpf.comm Require Import ListAsArray Regs BinrBPF State LemmaNat.
From bpf.model Require Import Semantics.
From bpf.isolation Require Import AlignChunk CommonISOLib VerifierOpcode.
From bpf.verifier.comm Require Import state.
From Coq Require Import ZArith Lia List.
Import ListNotations.

Ltac destruct_if_zeqb Hname :=
  match goal with
  | |- context [(if ?X then _ else _) = Some _] =>
    destruct X eqn: Hname;
    [ eexists; rewrite Z.eqb_eq in Hname; rewrite Hname;
  reflexivity |
      rewrite Z.eqb_neq in Hname]
  end.

Open Scope nat_scope.
(**r CertrBPF needs the following two properties guaranteed by an assumed rbpf verifier, we will implement a verified verifier later~

\begin{enumerate}
    \item dst \& src registers are in [0, 10].
    \item all jump operations are always within in bound.
    tbc...
    \item when ins.opcode = div, ins.src != 0
    \item when ins.opcode = shift (lsh/rsh/arsh), $0 \leq ins.src \leq 32/64$
    \item etc... (more ambitious: {\color{red} check\_mem = true?}  ...)
\end{enumerate}

 *)

Definition is_well_dst (i: int64) : bool := Int.cmpu Cle (Int.repr (get_dst i)) (Int.repr 10).

Definition is_well_src (i: int64) : bool := Int.cmpu Cle (Int.repr (get_src i)) (Int.repr 10).

Definition is_well_jump (pc len: nat) (ofs: int) : bool :=
  Int.cmpu Cle (Int.add (Int.repr (Z.of_nat pc)) ofs) (Int.sub (Int.repr (Z.of_nat len)) (Int.repr 2%Z)).
(*
Definition is_well_jump (pc len: nat) (ofs: int) : bool :=
  Int.cmpu Clt (Int.add (Int.repr (Z.of_nat pc)) ofs) (Int.repr (Z.of_nat len)). *)

Definition is_not_div_by_zero (i: int64) : bool :=
  Int.cmp Cne (BinrBPF.get_immediate i) Int.zero.

Definition is_not_div_by_zero64 (i: int64) : bool :=
  Int64.cmp Cne (Int64.repr (Int.signed (BinrBPF.get_immediate i))) Int64.zero.

Definition is_shift_range (i: int64) (upper: int): bool :=
  Int.cmpu Clt (BinrBPF.get_immediate i) upper.

Definition is_shift_range64 (i: int64) (upper: int): bool :=
  Int.ltu (Int.repr (Int64.unsigned (Int64.repr (Int.signed (BinrBPF.get_immediate i))))) upper.

Definition bpf_verifier_aux2 (pc len op: nat) (ins: int64) : bool :=
  match nat_to_opcode op with
  | ALU64  (**r 0xX7 / 0xXf *) =>
    match nat_to_opcode_alu op with
    | ALU_DIV => (**r DIV_IMM *) is_well_dst ins && is_not_div_by_zero64 ins
    | ALU_SHIFT => (**r SHIFT_IMM *) is_well_dst ins && is_shift_range64 ins (Int.repr 64%Z)
    | ALU_IMM_Normal => (**r ALU_IMM *) is_well_dst ins
    | ALU_REG_Normal => (**r ALU_REG *) is_well_dst ins && is_well_src ins
    | ALU_ILLEGAL => false
    end
  | ALU32  (**r 0xX4 / 0xXc *) =>
    match nat_to_opcode_alu op with
    | ALU_DIV => (**r DIV_IMM *) is_well_dst ins && is_not_div_by_zero ins
    | ALU_SHIFT => (**r SHIFT_IMM *) is_well_dst ins && is_shift_range ins (Int.repr 32%Z)
    | ALU_IMM_Normal => (**r ALU_IMM *) is_well_dst ins
    | ALU_REG_Normal => (**r ALU_REG *) is_well_dst ins && is_well_src ins
    | ALU_ILLEGAL => false
    end
  | Branch (**r 0xX5 / 0xXd *) =>
    match nat_to_opcode_branch op with
    | JMP_IMM =>
      let ofs := get_offset ins in
        is_well_dst ins && is_well_jump pc len ofs
    | JMP_REG =>
      let ofs := get_offset ins in
        is_well_dst ins && is_well_src ins && is_well_jump pc len ofs
    | JMP_SP => Int.cmpu Ceq (Int.repr (get_dst ins)) (Int.repr 0)
    | JMP_ILLEGAL => false
    end
  | LD_IMM (**r 0xX8 *) =>
    match nat_to_opcode_load_imm op with
    | LD_IMM_Normal  => is_well_dst ins
    | LD_IMM_ILLEGAL => false
    end
  | LD_REG (**r 0xX1/0xX9 *) =>
    match nat_to_opcode_load_reg op with
    | LD_REG_Normal  => is_well_dst ins && is_well_src ins
    | LD_REG_ILLEGAL => false
    end
  | ST_IMM (**r 0xX2/0xXa *) =>
    match nat_to_opcode_store_imm op with
    | ST_IMM_Normal  => is_well_dst ins
    | ST_IMM_ILLEGAL => false
    end
  | ST_REG (**r 0xX3/0xXb *)  =>
    match nat_to_opcode_store_reg op with
    | ST_REG_Normal  => is_well_dst ins && is_well_src ins
    | ST_REG_ILLEGAL => false
    end
  | ILLEGAL => false
  end.

Fixpoint bpf_verifier_aux (pc len: nat) (st: state.state): bool :=
    match pc with
    | O => true
    | S n =>
      let i := List64AsArray.index (ins st) (Int.repr (Z.of_nat n)) in
      let op := get_opcode i in
        if (bpf_verifier_aux2 n len op i) then
            bpf_verifier_aux n len st
          else
            false
    end.

Definition bpf_verifier (st: state.state): bool :=
  let len := ins_len st in
  (**r (0, Int.max_unsigned/8): at least one instruction, and at most Int.max_unsigned/8 because of memory region *)
    if negb (Int.ltu (Int.repr (Z.of_nat len)) Int.one) then
      if negb
       (Int.ltu (Int.divu (Int.repr Int.max_unsigned) (Int.repr 8))
          (Int.repr (Z.of_nat len))) then
        if bpf_verifier_aux len len st then
          let i := List64AsArray.index (ins st) (Int.repr (Z.of_nat  (len - 1))) in
            Int64.eq i (Int64.repr 0x95)
        else
          false
      else
        false
    else
      false.

Lemma sub_lt:
  forall a b,
    b < a ->
    a - 1 - b < a.
Proof.
  intros.
  assert (1+b <= a) by lia.
  rewrite <- Nat.sub_add_distr.
  apply Nat.sub_lt.
  assumption.
  lia.
Qed.

Lemma bpf_verifier_aux_implies:
  forall st pc op ins k
    (Hst: bpf_verifier_aux k (ins_len st) st = true)
    (Hlen: List.length (state.ins st) = ins_len st)
    (Hpc: pc < k)
    (Hop: op = get_opcode ins)
    (Hins: ins = List64AsArray.index (state.ins st) (Int.repr (Z.of_nat pc))),
      bpf_verifier_aux2 pc (ins_len st) op ins = true.
Proof.
  unfold List64AsArray.index.
  intros.

  induction k.
  - lia.
  - assert (Hpc_eq: pc = k \/ pc < k) by lia.
    destruct Hpc_eq as [Hpc_eq | Hpc_lt].
    + simpl in Hst.
      unfold List64AsArray.index in Hst.
      rewrite Hpc_eq in *.
      rewrite <- Hins in *.
      match goal with
      | H: (if ?X then _ else _) = _ |- _ =>
        destruct X eqn: Haux2;[ | inversion H]
      end.
      rewrite Hop.
      assumption.
    + apply IHk; auto.
      simpl in Hst.
      match goal with
      | H: (if ?X then _ else _) = _ |- _ =>
        destruct X eqn: Haux2;[ | inversion H]
      end.
      assumption.
Qed.

(*
Lemma is_well_jump_ind:
  forall k len ofs,
    is_well_jump k len ofs = true ->
      is_well_jump 0 len ofs = true.
Proof.
  unfold is_well_jump; intros.
  destruct k.
  - assumption.
  - unfold Int.cmpu in *.
    rewrite Clt_Zlt_iff in *.

Qed. *)

Lemma bpf_verifier_aux_implies':
  forall st pc op ins k
    (Hst: bpf_verifier_aux k (ins_len st) st = true)
    (Hlen: List.length (state.ins st) = ins_len st)
    (Hpc: pc < k)
    (Hop: op = get_opcode ins)
    (Hins: ins = List64AsArray.index (state.ins st) (Int.repr (Z.of_nat (k-1-pc)))),
      bpf_verifier_aux2 (k-1-pc) (ins_len st) op ins = true.
Proof.
  intros.
  assert (H: k-1-pc < k). {
    eapply sub_lt; eauto.
  }
  eapply bpf_verifier_aux_implies; eauto.
Qed.

Lemma bpf_verifier_aux_implies_bpf_verifier_aux:
  forall st pc k
    (Hst: bpf_verifier_aux k (ins_len st) st = true)
    (Hlen: List.length (state.ins st) = ins_len st)
    (Hpc: pc < k),
      bpf_verifier_aux pc (ins_len st) st = true.
Proof.
  intros.
  induction k.
  - lia.
  - assert (Hpc_eq: pc = k \/ pc < k) by lia.
    destruct Hpc_eq as [Hpc_eq | Hpc_lt].
    + simpl in Hst.
      unfold List64AsArray.index in Hst.
      rewrite Hpc_eq in *.
      match goal with
      | H: (if ?X then _ else _) = _ |- _ =>
        destruct X eqn: Haux2;[ | inversion H]
      end.
      assumption.
    + apply IHk; auto.
      simpl in Hst.
      match goal with
      | H: (if ?X then _ else _) = _ |- _ =>
        destruct X eqn: Haux2;[ | inversion H]
      end.
      assumption.
Qed.

Lemma bpf_verifier_aux_implies_bpf_verifier_aux':
  forall st pc k
    (Hst: bpf_verifier_aux k (ins_len st) st = true)
    (Hlen: List.length (state.ins st) = ins_len st)
    (Hpc: pc < k),
      bpf_verifier_aux (k-1-pc) (ins_len st) st = true.
Proof.
  intros.
  assert (H: k-1-pc < k). {
    eapply sub_lt; eauto.
  }
  eapply bpf_verifier_aux_implies_bpf_verifier_aux; eauto.
Qed.

Lemma bpf_verifier_implies:
  forall st pc op ins
    (Hst: bpf_verifier st = true)
    (Hlen: List.length (state.ins st) = ins_len st)
    (Hpc: pc < ins_len st)
    (Hop: op = get_opcode ins)
    (Hins: ins = List64AsArray.index (state.ins st) (Int.repr (Z.of_nat pc))),
      bpf_verifier_aux2 pc (ins_len st) op ins = true.
Proof.
  unfold bpf_verifier, List64AsArray.index.
  intros.
  match goal with
  | H: (if ?X then _ else _) = _ |- _ =>
    destruct X eqn: Hlen_low;[ | inversion H]
  end.
  match goal with
  | H: (if ?X then _ else _) = _ |- _ =>
    destruct X eqn: Hlen_high;[ | inversion H]
  end.
  match goal with
  | H: (if ?X then _ else _) = _ |- _ =>
    destruct X eqn: Haux;[ | inversion H]
  end.
  eapply bpf_verifier_aux_implies; eauto.
Qed.

(*
Lemma bpf_verifier_aux_rev_iff:
  forall st k,
    bpf_verifier_aux k (ins_len st) st = bpf_verifier_aux_rev k (ins_len st) st.
Proof.
  intros.
  induction k.
  - simpl. reflexivity.
  - simpl.

    destruct bpf_verifier_aux eqn: Hst; rewrite <-IHk.
    + symmetry in IHk.

    + destruct bpf_verifier_aux2; destruct bpf_verifier_aux2; reflexivity.

    rewrite Nat.sub_0_r.
    rewrite Nat.sub_diag.
  Search List.rev.
Qed. *)

Close Scope nat_scope.

Lemma verifier_inv_dst_zero:
  forall ins,
    Int.cmpu Ceq (Int.repr (get_dst ins))
              (Int.repr 0) = true ->
      BinrBPF.int64_to_dst_reg' ins = Some R0.
Proof.
  unfold BinrBPF.int64_to_dst_reg', z_to_reg; intros.
  remember (get_dst ins) as i.
  unfold get_dst in Heqi.
  rewrite <- Int64.and_shru in Heqi.
  change (Int64.shru (Int64.repr 4095) (Int64.repr 8)) with (Int64.repr 15) in Heqi.
  rewrite Int64.and_commut in Heqi.
  assert (Hi_le: (0 <= Int64.unsigned
         (Int64.and (Int64.repr 15)
            (Int64.shru ins (Int64.repr 8))) <= (Int64.unsigned (Int64.repr 15)))%Z). {
    split;[ | apply Int64.and_le].
    apply Int64_unsigned_ge_0.
  }
  change (Int64.unsigned (Int64.repr 15)) with 15%Z in Hi_le.
  assert (Hi: (0 <= i <= 15)%Z) by lia.
  clear Heqi Hi_le.
  unfold Int.cmpu in H.
Ltac destruct_if_zeq Hname H :=
  match goal with
  | |- context [(if ?X then _ else _) = Some _] =>
    destruct X eqn: Hname;
    [ rewrite Z.eqb_eq in Hname; rewrite Hname in H; inversion H |
      rewrite Z.eqb_neq in Hname]
  end.
  destruct_if_zeqb Heq0.
  destruct_if_zeq Heq1 H.
  destruct_if_zeq Heq2 H.
  destruct_if_zeq Heq3 H.
  destruct_if_zeq Heq4 H.
  destruct_if_zeq Heq5 H.
  destruct_if_zeq Heq6 H.
  destruct_if_zeq Heq7 H.
  destruct_if_zeq Heq8 H.
  destruct_if_zeq Heq9 H.
  destruct_if_zeq Heq10 H.
  destruct (i =? 11)%Z eqn: H11;
  [ rewrite Z.eqb_eq in H11; rewrite H11 in H; inversion H |
      rewrite Z.eqb_neq in H11].
  destruct (i =? 12)%Z eqn: H12;
  [ rewrite Z.eqb_eq in H12; rewrite H12 in H; inversion H |
      rewrite Z.eqb_neq in H12].
  destruct (i =? 13)%Z eqn: H13;
  [ rewrite Z.eqb_eq in H13; rewrite H13 in H; inversion H |
      rewrite Z.eqb_neq in H13].
  destruct (i =? 14)%Z eqn: H14;
  [ rewrite Z.eqb_eq in H14; rewrite H14 in H; inversion H |
      rewrite Z.eqb_neq in H14].
  destruct (i =? 15)%Z eqn: H15;
  [ rewrite Z.eqb_eq in H15; rewrite H15 in H; inversion H |
      rewrite Z.eqb_neq in H15].
  lia.
Qed.

Lemma verifier_inv_is_well_dst:
  forall ins,
    is_well_dst ins = true ->
    exists r,
      BinrBPF.int64_to_dst_reg' ins = Some r.
Proof.
  unfold is_well_dst, BinrBPF.int64_to_dst_reg', z_to_reg; intros.
  remember (get_dst ins) as i.
  unfold get_dst in Heqi.
  rewrite <- Int64.and_shru in Heqi.
  change (Int64.shru (Int64.repr 4095) (Int64.repr 8)) with (Int64.repr 15) in Heqi.
  rewrite Int64.and_commut in Heqi.
  assert (Hi_le: (0 <= Int64.unsigned
         (Int64.and (Int64.repr 15)
            (Int64.shru ins (Int64.repr 8))) <= (Int64.unsigned (Int64.repr 15)))%Z). {
    split;[ | apply Int64.and_le].
    apply Int64_unsigned_ge_0.
  }
  change (Int64.unsigned (Int64.repr 15)) with 15%Z in Hi_le.
  assert (Hi: (0 <= i <= 15)%Z) by lia.
  clear Heqi Hi_le.
  unfold Int.cmpu in H.
  rewrite Cle_Zle_iff in H.
  change (Int.unsigned (Int.repr 10)) with 10%Z in H.
  rewrite Int.unsigned_repr in H; [| change Int.max_unsigned with 4294967295%Z; lia].
  destruct_if_zeqb Heq0.
  destruct_if_zeqb Heq1.
  destruct_if_zeqb Heq2.
  destruct_if_zeqb Heq3.
  destruct_if_zeqb Heq4.
  destruct_if_zeqb Heq5.
  destruct_if_zeqb Heq6.
  destruct_if_zeqb Heq7.
  destruct_if_zeqb Heq8.
  destruct_if_zeqb Heq9.
  destruct_if_zeqb Heq10.
  lia.
Qed.

Lemma verifier_inv_is_well_src:
  forall ins,
    is_well_src ins = true ->
    exists r,
      BinrBPF.int64_to_src_reg' ins = Some r.
Proof.
  unfold is_well_src, BinrBPF.int64_to_src_reg', z_to_reg; intros.
  remember (get_src ins) as i.
  unfold get_src in Heqi.
  rewrite <- Int64.and_shru in Heqi.
  change (Int64.shru (Int64.repr 65535) (Int64.repr 12)) with (Int64.repr 15) in Heqi.
  rewrite Int64.and_commut in Heqi.
  assert (Hi_le: (0 <= Int64.unsigned
         (Int64.and (Int64.repr 15)
            (Int64.shru ins (Int64.repr 12))) <= (Int64.unsigned (Int64.repr 15)))%Z). {
    split;[ | apply Int64.and_le].
    apply Int64_unsigned_ge_0.
  }
  change (Int64.unsigned (Int64.repr 15)) with 15%Z in Hi_le.
  assert (Hi: (0 <= i <= 15)%Z) by lia.
  clear Heqi Hi_le.
  unfold Int.cmpu in H.
  rewrite Cle_Zle_iff in H.
  change (Int.unsigned (Int.repr 10)) with 10%Z in H.
  rewrite Int.unsigned_repr in H; [| change Int.max_unsigned with 4294967295%Z; lia].
  destruct_if_zeqb Heq0.
  destruct_if_zeqb Heq1.
  destruct_if_zeqb Heq2.
  destruct_if_zeqb Heq3.
  destruct_if_zeqb Heq4.
  destruct_if_zeqb Heq5.
  destruct_if_zeqb Heq6.
  destruct_if_zeqb Heq7.
  destruct_if_zeqb Heq8.
  destruct_if_zeqb Heq9.
  destruct_if_zeqb Heq10.
  lia.
Qed.

(*
Lemma verifier_inv_src_reg :
  forall ins,
    well_src ins ->
    exists r,
      BinrBPF.int64_to_src_reg' ins = Some r.
Proof.
  unfold well_src, BinrBPF.int64_to_src_reg'; intros.
  unfold z_to_reg.
  remember (get_src ins) as i.
  clear Heqi.
  destruct_if_zeqb Heq0.
  destruct_if_zeqb Heq1.
  destruct_if_zeqb Heq2.
  destruct_if_zeqb Heq3.
  destruct_if_zeqb Heq4.
  destruct_if_zeqb Heq5.
  destruct_if_zeqb Heq6.
  destruct_if_zeqb Heq7.
  destruct_if_zeqb Heq8.
  destruct_if_zeqb Heq9.
  destruct_if_zeqb Heq10.
  lia.
Qed.
*)
Lemma opcode_and_255:
  forall ins,
    Nat.land (get_opcode ins) 255 = get_opcode ins.
Proof.
  intros.
  unfold get_opcode.
  unfold Int64.and.
  change (Int64.unsigned (Int64.repr 255)) with (Z.of_nat (Z.to_nat 255)).
  assert (Heq: Z.of_nat (Z.to_nat (Int64.unsigned ins)) = Int64.unsigned ins).
  {
    rewrite Z2Nat.id.
    reflexivity.
    apply Int64_unsigned_ge_0.
  }
  rewrite <- Heq; clear Heq.
  rewrite land_land.
  change (Z.to_nat 255) with 255%nat.
  assert (Hrange: (Nat.land (Z.to_nat (Int64.unsigned ins)) 255 <= 255)%nat). {
    rewrite Nat.land_comm.
    rewrite land_bound.
    lia.
  }
  assert (Hrange_z: (Z.of_nat (Nat.land (Z.to_nat (Int64.unsigned ins)) 255%nat) <= 255)%Z) by lia.
  rewrite Int64.unsigned_repr.
  rewrite Nat2Z.id.
  rewrite <- Nat.land_assoc.
  rewrite Nat.land_diag.
  reflexivity.
  change Int64.max_unsigned with 18446744073709551615%Z.
  lia.
Qed.


From TypingFlags Require Import Loader.

Fail Definition T := let T := Type in (T : T).

Set Type In Type.

Print Typing Flags.

Definition T := let T := Type in (T : T).

Section t.

  Unset Guard Checking.

  Variable b : bool.

  Fixpoint f (n : nat) {struct n} : True :=
    match n with
    | O => I
    | S _ => if b then f n else I
    end.

  Print Typing Flags.
End t.

Fail Definition g := Eval lazy in (f true).

Unset Guard Checking.
Definition g := Eval lazy in (f true).

(* SetGuardChecking. *)
Inductive T2 :=
  l : (T2 -> False) -> T2.

Goal False.
  assert T2.
  constructor. intro.
  remember H.
  destruct H. auto.
  remember H.
  destruct H. auto.
(* Defined. (* Does not terminate? *) *)
Qed.

Check g.

Compute (f false 12).

Unset Type In Type.
Set Guard Checking.
Definition ff := f.
Print Assumptions ff.


Require Import depoolContract.SolidityNotations.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.

Module DePoolSpec (xt: XTypesSig) (sm: StateMonadSig).
Module LedgerClass := LedgerClass xt sm .
Import LedgerClass.
Import SolidityNotations.

Module Type DePoolSpecSig.
Import xt. Import sm.

Parameter DePoolContract_Ф__returnChange : LedgerT True .
Parameter DePoolContract_Ф__calcLastRoundInterest : XInteger64 -> XInteger64 -> LedgerT XInteger64 .
Parameter DePoolContract_Ф__sendError : XInteger32 -> XInteger64 -> LedgerT True .
Parameter DePoolContract_Ф__sendAccept : XInteger64 -> LedgerT True .
Parameter DePoolContract_Ф_cutWithdrawalValueAndActivateStake : RoundsBase_ι_InvestParams -> LedgerT ( (XMaybe RoundsBase_ι_InvestParams) # XInteger64 )%sol .
Parameter DePoolContract_Ф_onStakeAccept : XInteger64 -> XInteger32 -> XAddress -> LedgerT ( XErrorValue True XInteger ) .
Parameter DePoolContract_Ф_onStakeReject : XInteger64 -> XInteger32 -> XAddress -> LedgerT ( XErrorValue True XInteger ) .
(* Parameter DePool_Ф_Constructor2 : XInteger64 -> XAddress -> XAddress -> XAddress -> XInteger64 -> LedgerT True . *)
Parameter DePool_Ф_getParticipantInfo : XAddress -> LedgerT (XErrorValue ( XInteger64 # XInteger64 # XBool # XInteger64 # (XHMap XInteger64 XInteger64) # (XHMap XInteger64 RoundsBase_ι_InvestParams) # (XHMap XInteger64 RoundsBase_ι_InvestParams) ) XInteger)%sol.
Parameter ValidatorBase_Ф_Constructor2 : XAddress -> LedgerT True.
Parameter DePool_Ф_getDePoolInfo : LedgerT ( XInteger64 # XInteger64 # XInteger64 # XAddress # XAddress # XAddress # XBool # XInteger64 # XInteger64 # XInteger64 # XInteger64 # XInteger64 # XInteger64 # XInteger64 # XInteger64 # XInteger64 # XInteger64 # XInteger64 # XInteger64 # XInteger64 )%sol .
Parameter DePool_Ф_getParticipants : LedgerT (XArray XAddress) .
Parameter ProxyBase_Ф_Constructor3 : XAddress -> XAddress -> LedgerT True .
Parameter DePoolHelper_Ф_Constructor4 : XAddress -> LedgerT ( XErrorValue True XInteger ) .
Parameter ProxyBase_Ф_getProxy : XInteger64 -> LedgerT XAddress .
Parameter ProxyBase_Ф__recoverStake : XAddress -> XInteger64 -> XAddress -> LedgerT True .
Parameter ProxyBase_Ф__sendElectionRequest : XAddress -> XInteger64 -> XInteger64 -> DePoolLib_ι_Request -> XAddress -> LedgerT True .
Parameter ConfigParamsBase_Ф_getCurValidatorData : LedgerT ( XErrorValue ( XInteger256 # XInteger32 # XInteger32 )%sol XInteger ) .
Parameter ConfigParamsBase_Ф_getPrevValidatorHash : LedgerT ( XErrorValue XInteger XInteger ) .
Parameter ConfigParamsBase_Ф_roundTimeParams : LedgerT ( XErrorValue ( XInteger32 # XInteger32 # XInteger32 # XInteger32 )%sol XInteger ) .
Parameter ConfigParamsBase_Ф_getMaxStakeFactor : LedgerT ( XErrorValue XInteger32 XInteger ) .
Parameter ConfigParamsBase_Ф_getElector : LedgerT ( XErrorValue XAddress XInteger ) .
Parameter ParticipantBase_Ф__setOrDeleteParticipant : XAddress -> DePoolLib_ι_Participant -> LedgerT True .
Parameter DePoolProxyContract_Ф_Constructor5 : XAddress -> LedgerT ( XErrorValue True XInteger ) .
Parameter DePoolHelper_Ф_updateDePoolPoolAddress : XAddress -> LedgerT ( XErrorValue True XInteger ) .
Parameter DePoolHelper_Ф__settimer : XAddress -> XInteger -> LedgerT True .
Parameter DePoolHelper_Ф_sendTicktock : LedgerT ( XErrorValue True XInteger ) .
Parameter DePoolHelper_Ф_getDePoolPoolAddress : LedgerT XAddress .
Parameter DePoolHelper_Ф_getHistory : LedgerT (XHMap XInteger XAddress) .
Parameter DePoolHelper_Ф_onCodeUpgrade : LedgerT True .
Parameter DePoolContract_Ф_Constructor6 : XInteger64 -> XAddress -> XAddress -> XAddress -> XInteger64 -> LedgerT ( XErrorValue True XInteger )  .
Parameter DePoolProxyContract_Ф_process_new_stake : XInteger64 -> XInteger256 -> XInteger32 -> XInteger32 -> XInteger256 -> XList XInteger8 -> XAddress -> LedgerT ( XErrorValue True XInteger ) .
Parameter DePoolProxyContract_Ф_recover_stake : XInteger64 -> XAddress -> LedgerT ( XErrorValue True XInteger ) .
Parameter DePoolContract_Ф_onSuccessToRecoverStake : XInteger64 -> XAddress -> LedgerT ( XErrorValue True XInteger ) .
Parameter DePoolProxyContract_Ф_getProxyInfo : LedgerT ( XAddress # XInteger64 )%sol .
Parameter RoundsBase_Ф__addStakes : RoundsBase_ι_Round -> DePoolLib_ι_Participant -> XAddress -> XInteger64 -> XMaybe RoundsBase_ι_InvestParams -> XMaybe RoundsBase_ι_InvestParams -> LedgerT ( RoundsBase_ι_Round # DePoolLib_ι_Participant )%sol .
Parameter RoundsBase_Ф_activeAndNotStakeSum : RoundsBase_ι_StakeValue -> LedgerT XInteger64 .
Parameter RoundsBase_Ф_activeStakeSum : RoundsBase_ι_StakeValue -> LedgerT XInteger64 .
Parameter RoundsBase_Ф_toTruncatedRound : RoundsBase_ι_Round -> LedgerT RoundsBase_ι_TruncatedRound .
Parameter DePool_Ф_Constructor7 : XInteger64 -> XAddress -> XAddress -> XAddress -> XInteger64 -> LedgerT (XErrorValue True XInteger)  .
Parameter DePoolContract_Ф_onFailToRecoverStake : XInteger64 -> XAddress -> LedgerT ( XErrorValue True XInteger ) .
Parameter DePoolContract_Ф_ticktock : LedgerT ( XErrorValue True XInteger ) .
Parameter Participant_Ф_onRoundComplete : XInteger64 -> XInteger64 -> XInteger64 -> XInteger64 -> XInteger64 -> XBool -> XInteger8 -> LedgerT True .
Parameter Participant_Ф_receiveAnswer : XInteger32 -> XInteger64 -> LedgerT True .
Parameter Participant_Ф_onTransfer : XAddress -> XInteger128 -> LedgerT True .
Parameter Participant_Ф_sendTransaction : XAddress -> XInteger64 -> XBool -> XInteger16 -> TvmCell -> LedgerT ( XErrorValue True XInteger ) .
(* Parameter TestElector_Ф_Constructor8 : XInteger32 -> LedgerT True . *)
(* Parameter TestElector_Ф_getElectionId : LedgerT XInteger32 . *)
Parameter DePoolContract_Ф__returnOrReinvestForParticipant : RoundsBase_ι_Round -> RoundsBase_ι_Round -> XAddress -> RoundsBase_ι_StakeValue -> LedgerT ( XErrorValue RoundsBase_ι_Round XInteger ) .
Parameter DePoolContract_Ф__returnOrReinvest : RoundsBase_ι_Round -> XInteger8 -> LedgerT ( XErrorValue RoundsBase_ι_Round XInteger ) .
Parameter DePoolContract_Ф_calculateStakeWithAssert : XBool -> XInteger64 -> LedgerT  ( XInteger64 # XBool )%sol  .
Parameter DePoolContract_Ф_addOrdinaryStake : XBool -> LedgerT ( XErrorValue  True XInteger ) .
Parameter DePoolContract_Ф_removeOrdinaryStake : XInteger64 -> LedgerT ( XErrorValue True XInteger ) .
Parameter DePoolContract_Ф_addVestingOrLock : XAddress -> XInteger32 -> XInteger32 -> XBool -> LedgerT (XErrorValue  True XInteger) .
Parameter DePoolContract_Ф_withdrawPartAfterCompleting : XInteger64 -> LedgerT (XErrorValue True XInteger) .
Parameter DePoolContract_Ф_withdrawAllAfterCompleting : XBool -> LedgerT (XErrorValue  True XInteger) .
Parameter DePoolContract_Ф_transferStake : XAddress -> XInteger64 -> LedgerT ( XErrorValue  True XInteger ) .
Parameter DePoolContract_Ф_participateInElections : XInteger64 -> XInteger256 -> XInteger32 -> XInteger32 -> XInteger256 -> XList XInteger8 -> LedgerT ( XErrorValue True XInteger ) .
Parameter DePoolContract_Ф_updateRound2 : RoundsBase_ι_Round -> XInteger256 -> XInteger256 -> XInteger32 -> XInteger32 -> LedgerT RoundsBase_ι_Round .
Parameter DePoolContract_Ф_updateRounds :LedgerT (XErrorValue True XInteger) .
Parameter DePoolContract_Ф_completeRoundWithChunk : XInteger64 -> XInteger8 -> LedgerT ( XErrorValue True XInteger ) .
Parameter DePoolContract_Ф_completeRound : XInteger64 -> XInteger32 -> LedgerT ( XErrorValue True XInteger ) .
Parameter DePoolContract_Ф_acceptRewardAndStartRoundCompleting : RoundsBase_ι_Round -> XInteger64 -> LedgerT RoundsBase_ι_Round .
Parameter DePoolContract_Ф_terminator : LedgerT ( XErrorValue True XInteger ) .
Parameter DePoolContract_Ф_receiveFunds : LedgerT True .
Parameter DePoolHelper_Ф_onTimer : LedgerT True .
Parameter RoundsBase_Ф_getRounds : LedgerT (XHMap XInteger64 RoundsBase_ι_TruncatedRound) .
Parameter DebugDePool_Ф_getCurValidatorData2 : LedgerT ( XInteger256 # XInteger32 # XInteger32 )%sol .
Parameter DebugDePool_Ф_getPrevValidatorHash2 : LedgerT XInteger .
Parameter DebugDePool_Ф_Constructor1 : XInteger64 -> XAddress -> XAddress -> XAddress -> XInteger64 -> LedgerT True .
Parameter DePoolContract_Ф_startRoundCompleting : RoundsBase_ι_Round -> RoundsBase_ι_CompletionReason -> LedgerT RoundsBase_ι_Round .
Parameter DePoolContract_Ф_addVestingStake : XAddress -> XInteger32 -> XInteger32 -> LedgerT (XErrorValue True XInteger) .
Parameter DePoolContract_Ф_addLockStake : XAddress -> XInteger32 -> XInteger32 -> LedgerT (XErrorValue True XInteger) .
Parameter DePoolContract_Ф_generateRound : LedgerT RoundsBase_ι_Round .
Parameter DePoolHelper_Ф_initTimer : XAddress -> XInteger -> LedgerT ( XErrorValue True XInteger ) .
Parameter DePoolHelper_Ф_upgrade : TvmCell -> LedgerT ( XErrorValue True XInteger ) .
Parameter RoundsBase_Ф_transferStakeInOneRound : RoundsBase_ι_Round -> DePoolLib_ι_Participant -> DePoolLib_ι_Participant -> XAddress -> XAddress -> XInteger64 -> XInteger64 -> LedgerT ( RoundsBase_ι_Round # XInteger64 # XInteger64 # DePoolLib_ι_Participant # DePoolLib_ι_Participant )%sol .
Parameter RoundsBase_Ф_withdrawStakeInPoolingRound : DePoolLib_ι_Participant -> XAddress -> XInteger64 -> XInteger64 -> LedgerT ( XInteger64 # DePoolLib_ι_Participant )%sol .

End DePoolSpecSig.

End DePoolSpec.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import TableDataOpsIntro.Spec.
Require Import TableDataOpsRef2.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition table_map3_spec (g_rd: Pointer) (map_addr: Z64) (level: Z64) (adt: RData) : option (RData * Z64) :=
    match map_addr, level with
    | VZ64 map_addr, VZ64 level =>
      rely is_int64 map_addr; rely (level >=? 3); rely is_int64 level;
      let idx0 := __addr_to_idx map_addr 0 in
      let idx1 := __addr_to_idx map_addr 1 in
      let idx2 := __addr_to_idx map_addr 2 in
      let idx3 := __addr_to_idx map_addr 3 in
      let ret_idx := (if level =? 1 then idx0 else if level =? 2 then idx1 else if level =? 3 then idx2 else idx3) in
      rely (peq (base g_rd) ginfo_loc);
      rely prop_dec ((buffer (priv adt)) @ SLOT_RD = None);
      rely prop_dec ((buffer (priv adt)) @ SLOT_TABLE = None);
      let rd_gidx := (offset g_rd) in
      let grd := (gs (share adt)) @ rd_gidx in
      rely (g_tag (ginfo grd) =? GRANULE_STATE_RD);
      rely prop_dec (glock grd = Some CPU_ID);
      let root_gidx := (g_rtt (gnorm grd)) in
      rely is_gidx rd_gidx; rely is_gidx root_gidx;
      when adt == query_oracle adt;
      (* hold root lock *)
      let groot := (gs (share adt)) @ root_gidx in
      rely (tbl_level (gaux groot) =? 0);
      rely prop_dec (glock groot = None);
      rely (g_tag (ginfo groot) =? GRANULE_STATE_TABLE);
      rely (gtype groot =? GRANULE_STATE_TABLE);
      (* walk deeper root *)
      let entry0 := (g_data (gnorm groot)) @ idx0 in
      rely is_int64 entry0;
      let phys0 := __entry_to_phys entry0 3 in
      let lv1_gidx := __addr_to_gidx phys0 in
      if (__entry_is_table entry0) && (GRANULE_ALIGNED phys0) && (is_gidx lv1_gidx) then
        (* level 1 valid, hold level 1 lock *)
        let glv1 := (gs (share adt)) @ lv1_gidx in
        rely prop_dec (glock glv1 = None);
        rely (tbl_level (gaux glv1) =? 1);
        (* walk deeper level 1 *)
        rely (g_tag (ginfo glv1) =? GRANULE_STATE_TABLE);
        rely (gtype glv1 =? GRANULE_STATE_TABLE);
        let entry1 := (g_data (gnorm glv1)) @ idx1 in
        rely is_int64 entry1;
        let phys1 := __entry_to_phys entry1 3 in
        let lv2_gidx := __addr_to_gidx phys1 in
        if (__entry_is_table entry1) && (GRANULE_ALIGNED phys1) && (is_gidx lv2_gidx) then
          (* level 2 valid, hold level 2 lock *)
          let glv2 := (gs (share adt)) @ lv2_gidx in
          rely (tbl_level (gaux glv2) =? 2);
          rely prop_dec (glock glv2 = None);
          if level =? 3 then
            (* walk until level 2 *)
            let adt := adt {log: EVT CPU_ID (RTT_WALK root_gidx map_addr 2) :: log adt} in
            let adt :=  adt {priv: (priv adt) {wi_llt: lv2_gidx} {wi_index: idx2}} in
            map_table lv2_gidx idx2 level adt
          else
            (* walk deeper level 2 *)
            rely (g_tag (ginfo glv2) =? GRANULE_STATE_TABLE);
            rely (gtype glv2 =? GRANULE_STATE_TABLE);
            let entry2 := (g_data (gnorm glv2)) @ idx2 in
            rely is_int64 entry2;
            let phys2 := __entry_to_phys entry2 3 in
            let lv3_gidx := __addr_to_gidx phys2 in
            if (__entry_is_table entry2) && (GRANULE_ALIGNED phys2) && (is_gidx lv3_gidx) then
              (* level 2 valid, hold level 2 lock *)
              let glv3 := (gs (share adt)) @ lv3_gidx in
              rely prop_dec (glock glv3 = None);
              rely (tbl_level (gaux glv3) =? 3);
              if level =? 4 then
                (* walk until level 3 *)
                let adt := adt {log: EVT CPU_ID (RTT_WALK root_gidx map_addr 3) :: log adt} in
                let adt :=  adt {priv: (priv adt) {wi_llt: lv3_gidx} {wi_index: idx3}} in
                map_table lv3_gidx idx3 level adt
              else (* can't be other level *)
                None
            else
              (* level 3 invalid *)
              Some (adt {priv: (priv adt) {wi_llt: 0} {wi_index: ret_idx}}, VZ64 1)
        else
          (* level 2 invalid *)
          Some (adt {priv: (priv adt) {wi_llt: 0} {wi_index: ret_idx}}, VZ64 1)
      else
        (* level 1 invalid *)
        Some (adt {priv: (priv adt) {wi_llt: 0} {wi_index: ret_idx}}, VZ64 1)
  end.

End Spec.


Require Import BasicMachineTypes.
Require Import ClassDatatypesIface.
Require Import ClasspoolIface.
Require Import AssignabilityIface.
Require Import Twosig.

Require Import AnnotationIface.

Module Type VIRTUALMETHODLOOKUP
  (VM_B : BASICS)
  (ANN : ANNOTATION VM_B)
  (VM_C : CLASSDATATYPES VM_B ANN)
  (VM_CP : CLASSPOOL VM_B ANN VM_C)
  (VM_A  : ASSIGNABILITY VM_B ANN VM_C VM_CP).

Definition lookup_minimal : VM_CP.cert_classpool -> VM_B.Classname.t -> VM_B.Classname.t -> (VM_B.Methodname.t * VM_C.descriptor) -> Prop
 := fun classes nmA nmB mdesc =>
    forall nmB' cB',
     VM_A.assignable classes (VM_C.ty_obj nmA) (VM_C.ty_obj nmB') ->
     VM_A.assignable classes (VM_C.ty_obj nmB') (VM_C.ty_obj nmB) ->
     VM_CP.class_loaded classes nmB' cB' ->
     VM_C.class_interface cB' = false ->
     nmB' <> nmB ->
        VM_C.MethodList.lookup (VM_C.class_methods cB') mdesc = None
     \/ exists m, VM_C.MethodList.lookup (VM_C.class_methods cB') mdesc = Some m /\ VM_C.method_static m = true.

Parameter lookup_minimal_refl : forall classes nm md c,
  VM_CP.class_loaded classes nm c ->
  VM_C.class_interface c = false ->
  lookup_minimal classes nm nm md.

Parameter lookup_minimal_mid : forall classes nmA nmB nmB' md,
  VM_A.assignable classes (VM_C.ty_obj nmA) (VM_C.ty_obj nmB') ->
  VM_A.assignable classes (VM_C.ty_obj nmB') (VM_C.ty_obj nmB) ->
  lookup_minimal classes nmA nmB md ->
  lookup_minimal classes nmB' nmB md.

Parameter lookup_minimal_preserved : forall classes classes' nmA cA nmB cB mdesc,
  VM_CP.class_loaded classes nmA cA ->
  VM_C.class_interface cA = false ->
  VM_CP.class_loaded classes nmB cB ->
  VM_C.class_interface cB = false ->
  lookup_minimal classes nmA nmB mdesc ->
  VM_CP.preserve_old_classes classes classes' ->
  lookup_minimal classes' nmA nmB mdesc.

Parameter lookup_virtual_method : forall classes nm d,
  (exists c, VM_CP.class_loaded classes nm c /\ VM_C.class_interface c = false) ->
  option { c : VM_C.class, m : VM_C.method |
     VM_CP.class_loaded classes (VM_C.class_name c) c /\
     VM_C.MethodList.lookup (VM_C.class_methods c) d = Some m /\
     VM_C.class_interface c = false /\
     VM_C.method_static m = false /\
     VM_A.assignable classes (VM_C.ty_obj nm) (VM_C.ty_obj (VM_C.class_name c)) /\
     lookup_minimal classes nm (VM_C.class_name c) d}.

End VIRTUALMETHODLOOKUP.


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

From bpf.comm Require Import Regs State Monad.
From bpf.monadicmodel Require Import Opcode rBPFInterpreter.
From Coq Require Import List Lia ZArith.
From compcert Require Import Integers Values Clight Memory.
Import ListNotations.

From bpf.clightlogic Require Import Clightlogic CorrectRel CommonLemma CommonLemmaNat.

From bpf.clight Require Import interpreter.

From bpf.simulation Require Import MatchState InterpreterRel.

(**
Check get_opcode_alu64.
get_opcode_alu64
     : int8_t -> M DxOpcode.opcode_alu64

*)

Section Get_opcode_alu64.
  Context {S: special_blocks}.
  (** The program contains our function of interest [fn] *)
  Definition p : Clight.program := prog.

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

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

  Variable state_block: block. (**r a block storing all rbpf state information? *)
  Variable mrs_block: block.
  Variable ins_block: block.

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

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

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

  Instance correct_function_get_opcode_alu64 : forall a, correct_function _ p args res f fn ModNothing true match_state match_arg_list match_res a.
  Proof.
    correct_function_from_body args.
    correct_body.
    (** how to use correct_* *)
    unfold INV.
    unfold f.
    repeat intro.
    get_invariant _op.

    unfold eval_inv, opcode_correct in c0.
    destruct c0 as (H0 & Hge).
    subst.

    eexists. exists m, Events.E0.

    split_and; unfold step2.
    -
      repeat forward_star.
    - simpl.
      (**r Search (Int.zero_ext).*)
      rewrite Int.zero_ext_idem;[idtac | lia].
      rewrite Int.zero_ext_and; [| lia].
      rewrite nat8_land_240_255_eq; [| apply Hge].
      unfold match_res, opcode_alu64_correct.
      rewrite byte_to_opcode_alu64_if_same.
      unfold byte_to_opcode_alu64_if.

      simpl_opcode Hadd.
      simpl_opcode Hsub.
      simpl_opcode Hmul.
      simpl_opcode Hdiv.
      simpl_opcode Hor.
      simpl_opcode Hand.
      simpl_opcode Hlsh.
      simpl_opcode Hrsh.
      simpl_opcode Hneg.
      simpl_opcode Hmod.
      simpl_opcode Hxor.
      simpl_opcode Hmov.
      simpl_opcode Harsh.
      exists c; split; [reflexivity| idtac].
      unfold is_illegal_alu64_ins.
      repeat simpl_land H0.
    - simpl.
      constructor.
      rewrite Int.zero_ext_idem;[idtac | lia].
      simpl.
      rewrite Int.zero_ext_idem;[idtac | lia].
      reflexivity.
    - auto.
    - apply unmodifies_effect_refl.
  Qed.

End Get_opcode_alu64.

Existing Instance correct_function_get_opcode_alu64.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
(** * Definition of an optimized CFG parser-recognizer *)
Require Import Coq.Lists.List Coq.Strings.String.
Require Import Coq.Numbers.Natural.Peano.NPeano Coq.Arith.Compare_dec Coq.Arith.Wf_nat.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Common.List.ListMorphisms.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.ContextFreeGrammar.PreNotations.
Require Import Fiat.Parsers.ContextFreeGrammar.Properties.
Require Import Fiat.Parsers.ContextFreeGrammar.Carriers.
Require Import Fiat.Parsers.ContextFreeGrammar.SimpleCorrectness.
Require Import Fiat.Parsers.GenericBaseTypes.
Require Import Fiat.Parsers.GenericCorrectnessBaseTypes.
Require Import Fiat.Parsers.BaseTypes.
Require Import Fiat.Parsers.BaseTypesLemmas.
Require Import Fiat.Parsers.CorrectnessBaseTypes.
Require Import Fiat.Common Fiat.Common.Wf Fiat.Common.Wf2 Fiat.Common.Telescope.Core.
Require Import Fiat.Parsers.GenericRecognizerExt.
Require Import Fiat.Parsers.GenericRecognizer.
Require Import Fiat.Parsers.GenericRecognizerCorrect.
Require Import Fiat.Parsers.Splitters.RDPList.
Require Import Fiat.Parsers.ContextFreeGrammar.Valid.
Require Import Fiat.Parsers.ContextFreeGrammar.ValidReflective.
Require Import Fiat.Parsers.ContextFreeGrammar.Reflective.
Require Import Fiat.Parsers.ContextFreeGrammar.ReflectiveLemmas.
Require Import Fiat.Parsers.RecognizerPreOptimized.
Require Import Fiat.Common.Match.
Require Import Fiat.Common.List.ListFacts.
Require Import Fiat.Common.Equality.
Require Export Fiat.Common.SetoidInstances.
Require Export Fiat.Common.List.ListMorphisms.
Require Export Fiat.Common.OptionFacts.
Require Export Fiat.Common.BoolFacts.
Require Export Fiat.Common.NatFacts.
Require Export Fiat.Common.Sigma.
Require Import Fiat.Parsers.StringLike.Core.
Require Import Fiat.Parsers.StringLike.Properties.
Require Import Fiat.Parsers.GenericRecognizerOptimizedTactics.
Import NPeano.

Set Implicit Arguments.
Local Open Scope string_like_scope.

Global Arguments string_dec : simpl never.
Global Arguments string_beq : simpl never.

Section recursive_descent_parser.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char}
          {G : pregrammar Char}.

  Context (Hvalid : is_true (grammar_rvalid G)).

  Let predata := @rdp_list_predata _ G.
  Local Existing Instance predata.

  Context {splitdata : @split_dataT Char _ _}.

  Let data : boolean_parser_dataT :=
    {| split_data := splitdata |}.
  Let optdata : boolean_parser_dataT :=
    {| split_data := optsplitdata |}.
  Local Existing Instance data.

  Let rdata' : @parser_removal_dataT' _ G predata := rdp_list_rdata'.
  Local Existing Instance rdata'.

  Context {gendata : generic_parser_dataT Char}
          {gencdata : generic_parser_correctness_dataT}.

  Local Arguments minus !_ !_.
  Local Arguments min !_ !_.

  Let is_correct pnt str nt
    := forall b,
      parse_nt_is_correct str (of_nonterminal nt) b pnt
      <-> parse_nt_is_correct str (of_nonterminal nt) b (parse_nonterminal (data := data) str nt).

  Local Arguments Compare_dec.leb !_ !_.
  Local Arguments to_nonterminal / _ _ _.

  Local Instance good_nth_proper {A}
  : Proper (eq ==> _ ==> _ ==> eq) (nth (A:=A))
    := _.
  Local Instance good_nth'_proper {A}
  : Proper (eq ==> _ ==> _ ==> eq) (nth' (A:=A))
    := _.

  Lemma parse_nonterminal_optdata_eq
        {HSLP : StringLikeProperties Char}
        {splitdata_correct : @boolean_parser_completeness_dataT' _ _ _ G data}
        (str : String)
        (nt : String.string)
    : is_correct (parse_nonterminal (data := optdata) str nt) str nt.
  Proof.
    pose optsplitdata_correct.
    unfold is_correct.
    pose proof (GenericRecognizerMin.parse_nonterminal_correct str nt).
    pose proof (GenericRecognizerMin.parse_nonterminal_correct (cdata := optsplitdata_correct) str nt).
    do 2 edestruct @GenericRecognizerMin.parse_nonterminal; simpl in *;
      intros []; split; intro;
        try solve [ tauto
                  | exfalso; eauto using @parse_nt_is_correct_disjoint ].
  Qed.

  Let Let_In' {A B} (x : A) (f : forall y : A, B y) : B x
    := let y := x in f y.

  Local Notation "@ 'Let_In' A B" := (@Let_In' A B) (at level 10, A at level 8, B at level 8, format "@ 'Let_In'  A  B").
  Local Notation Let_In := (@Let_In' _ _).

  Let Let_In_Proper {A B} x
  : Proper (forall_relation (fun _ => eq) ==> eq) (@Let_In A B x).
  Proof.
    lazy; intros ?? H; apply H.
  Defined.

  Definition inner_nth' {A} := Eval unfold nth' in @nth' A.
  Definition inner_nth'_nth' : @inner_nth' = @nth'
    := eq_refl.

  Local Instance good_inner_nth'_proper {A}
  : Proper (eq ==> _ ==> _ ==> eq) (inner_nth' (A:=A))
    := _.

  Lemma rdp_list_to_production_opt_sig x
  : { f : _ | rdp_list_to_production (G := G) x = f }.
  Proof.
    eexists.
    set_evars.
    unfold rdp_list_to_production at 1.
    cbv beta iota delta [Carriers.default_to_production productions production].
    simpl @Lookup.
    match goal with
      | [ |- (let a := ?av in
              let b := @?bv a in
              let c := @?cv a b in
              let d := @?dv a b c in
              let e := @?ev a b c d in
              @?v a b c d e) = ?R ]
        => change (Let_In av (fun a =>
                   Let_In (bv a) (fun b =>
                   Let_In (cv a b) (fun c =>
                   Let_In (dv a b c) (fun d =>
                   Let_In (ev a b c d) (fun e =>
                   v a b c d e))))) = R);
          cbv beta
    end.
    lazymatch goal with
      | [ |- Let_In ?x ?P = ?R ]
        => subst R; refine (@Let_In_Proper _ _ x _ _ _); intro; set_evars
    end.
    unfold Lookup_idx.
    symmetry; rewrite_map_nth_rhs; symmetry.
    repeat match goal with
             | [ |- context G[@Let_In ?A ?B ?k ?f] ]
               => first [ let h := head k in constr_eq h @nil
                        | constr_eq k 0
                        | constr_eq k (snd (snd x)) ];
                 test pose f; (* make sure f is closed *)
                 let c := constr:(@Let_In A B k) in
                 let c' := (eval unfold Let_In' in c) in
                 let G' := context G[c' f] in
                 change G'; simpl
           end.
    rewrite drop_all by (simpl; omega).
    unfold productions, production.
    rewrite <- nth'_nth at 1.
    rewrite map_map; simpl.
    match goal with
      | [ H := ?e |- _ ] => is_evar e; subst H
    end.
    match goal with
      | [ |- nth' ?a ?ls ?d = ?e ?a ]
        => refine (_ : inner_nth' a ls d = (fun a' => inner_nth' a' _ d) a); cbv beta;
           apply f_equal2; [ clear a | reflexivity ]
    end.
    etransitivity.
    { apply (_ : Proper (pointwise_relation _ _ ==> eq ==> eq) (@List.map _ _));
      [ intro | reflexivity ].
      do 2 match goal with
             | [ |- Let_In ?x ?P = ?R ]
               => refine (@Let_In_Proper _ _ x _ _ _); intro
           end.
      etransitivity.
      { symmetry; rewrite_map_nth_rhs; symmetry.
        unfold Let_In' at 2 3 4; simpl.
        set_evars.
        rewrite drop_all by (simpl; omega).
        unfold Let_In'.
        rewrite <- nth'_nth.
        change @nth' with @inner_nth'.
        subst_body; reflexivity. }
      reflexivity. }
    reflexivity.
  Defined.

  Definition rdp_list_to_production_opt x
    := Eval cbv beta iota delta [proj1_sig rdp_list_to_production_opt_sig Let_In']
      in proj1_sig (rdp_list_to_production_opt_sig x).

  Lemma rdp_list_to_production_opt_correct x
  : rdp_list_to_production (G := G) x = rdp_list_to_production_opt x.
  Proof.
    exact (proj2_sig (rdp_list_to_production_opt_sig x)).
  Qed.

  Definition parse_nonterminal_opt'0
             (str : String)
             (nt : String.string)
  : { b : _ | b = parse_nonterminal (data := optdata) str nt }.
  Proof.
    exists (parse_nonterminal (data := optdata) str nt).
    reflexivity.
  Defined.

  Local Unset Keyed Unification.
  Definition parse_nonterminal_opt'1
             (str : String)
             (nt : String.string)
  : { b : _ | b = parse_nonterminal (data := optdata) str nt }.
  Proof.
    let c := constr:(parse_nonterminal_opt'0 str nt) in
    let h := head c in
    let p := (eval cbv beta iota zeta delta [proj1_sig h] in (proj1_sig c)) in
    sigL_transitivity p; [ | abstract exact (proj2_sig c) ].
    cbv beta iota zeta delta [parse_nonterminal GenericRecognizer.parse_nonterminal parse_nonterminal' GenericRecognizer.parse_nonterminal' parse_nonterminal_or_abort GenericRecognizer.parse_nonterminal_or_abort list_to_grammar].
    simpl @GenericBaseTypes.parse_nt_T.
    change (@GenericRecognizer.parse_nonterminal_step Char) with (fun b c d e f g h i j k l m => @GenericRecognizer.parse_nonterminal_step Char b c d e f g h i j k l m); cbv beta.
    evar (b' : parse_nt_T).
    sigL_transitivity b'; subst b';
    [
    | rewrite Fix5_2_5_eq by (intros; rapply (@parse_nonterminal_step_ext _ _ _ optdata _); assumption);
      reflexivity ].
    simpl @fst; simpl @snd.
    cbv beta iota zeta delta [parse_nonterminal_step parse_productions parse_productions' parse_production parse_item parse_item' GenericRecognizer.parse_nonterminal_step GenericRecognizer.parse_productions GenericRecognizer.parse_productions' GenericRecognizer.parse_production GenericRecognizer.parse_item GenericRecognizer.parse_item' Lookup list_to_grammar list_to_productions].
    simpl.
    cbv beta iota zeta delta [predata BaseTypes.predata initial_nonterminals_data nonterminals_length remove_nonterminal production_carrierT].
    cbv beta iota zeta delta [rdp_list_predata Carriers.default_production_carrierT rdp_list_is_valid_nonterminal rdp_list_initial_nonterminals_data rdp_list_remove_nonterminal Carriers.default_nonterminal_carrierT rdp_list_nonterminals_listT rdp_list_production_tl Carriers.default_nonterminal_carrierT].
    (*cbv beta iota zeta delta [rdp_list_of_nonterminal].*)
    simpl; unfold pregrammar_nonterminals; simpl.
    evar (b' : parse_nt_T).
    sigL_transitivity b'; subst b';
    [
    | simpl;
      rewrite !map_length, !length_up_to;
      reflexivity ].

    refine_Fix2_5_Proper_eq_with_assumptions.
    etransitivity_rev _.
    { fix2_trans_with_assumptions;
      [
      | unfold parse_production', parse_production'_for, parse_item', GenericRecognizer.parse_production', GenericRecognizer.parse_production'_for, GenericRecognizer.parse_item', productions, production;
        solve [ t_reduce_fix;
                t_reduce_list;
                t_reduce_fix ] ].

      (** Now we take advantage of the optimized splitter *)
      etransitivity_rev _.
      { eapply option_rect_Proper_nondep_eq; [ intros ? Hv | reflexivity ].
        apply (f_equal (fun x => match x with Some _ => true | None => false end)) in Hv.
        simpl in Hv.
        lazymatch goal with
        | [ H : _ /\ (_ \/ is_true (is_valid_nonterminal initial_nonterminals_data ?nt)) |- _ ]
          => assert (Hvalid' : is_valid_nonterminal initial_nonterminals_data nt)
        end.
        { destruct_head and; destruct_head or; try assumption; [].
          edestruct lt_dec; simpl in *; [ omega | ].
          edestruct dec; simpl in *; [ | congruence ].
          match goal with
          | [ H : _ = true |- _ ] => apply Bool.andb_true_iff in H; destruct H as [? H']
          end.
          match goal with
          | [ H : sub_nonterminals_listT ?ls ?init, H' : list_bin_eq ?nt ?ls = true
              |- is_true (?R ?init ?nt) ]
            => apply H, H'
          end. }
        let nt := match type of Hvalid' with is_true (is_valid_nonterminal _ ?nt) => nt end in
        assert (Hvalid'' : productions_rvalid G (map to_production (nonterminal_to_production nt))).
        { unfold grammar_rvalid in Hvalid.
          eapply (proj1 fold_right_andb_map_in_iff) in Hvalid; [ eassumption | ].
          rewrite nonterminal_to_production_correct' by assumption.
          apply in_map, initial_nonterminals_correct'; assumption. }
        simpl @nonterminal_to_production in Hvalid''.
        unfold productions_rvalid in Hvalid''.
        rewrite map_map in Hvalid''.
        pose proof (proj1 fold_right_andb_map_in_iff Hvalid'') as Hvalid'''.
        cbv beta in Hvalid'''.

        misc_opt.
        step_opt'.
        step_opt'.
        step_opt'.
        step_opt'.
        apply map_Proper_eq_In; intros ? Hin.
        apply in_rev in Hin.
        specialize (Hvalid''' _ Hin).
        unfold parse_production', parse_production'_for, GenericRecognizer.parse_production', GenericRecognizer.parse_production'_for.
        simpl.
        (** Switch to using the list hypothesis, rather than lookup with the index *)
        etransitivity_rev _.
        { t_reduce_list_evar_with_hyp;
          [
          |
          | ].
          { step_opt'.
            reflexivity. }
          { rewrite rdp_list_production_tl_correct.
            match goal with
              | [ H : _ = ?x |- context[?x] ]
                => rewrite <- H; reflexivity
            end. }
          { match goal with
              | [ H : _ = ?x |- context[match ?x with _ => _ end] ]
                => rewrite <- H
            end.
            reflexivity. } }
        (** Pull out the nil case once and for all *)
        etransitivity_rev _.
        { lazymatch goal with
            | [ |- _ = list_rect ?P ?N ?C (?f ?a) ?a ?b ?c ]
              => let P0 := fresh in
                 let N0 := fresh in
                 let C0 := fresh in
                 set (P0 := P);
                   set (N0 := N);
                   set (C0 := C);
                   let IH := fresh "IH" in
                   let xs := fresh "xs" in
                   refine (list_rect
                             (fun ls' => forall a' (pf : ls' = f a') b' c',
                                           (bool_rect
                                              (fun _ => _)
                                              (N0 a' b' c')
                                              (list_rect P0 (fun _ _ _ => ret_production_nil_true) C0 ls' a' b' c')
                                              (EqNat.beq_nat (List.length ls') 0))
                                           = list_rect P0 N0 C0 ls' a' b' c')
                             _
                             _
                             (f a) a eq_refl b c);
                     simpl @list_rect;
                     [ subst P0 N0 C0; intros; cbv beta
                     | intros ? xs IH; intros; unfold C0 at 1 3; cbv beta;
                       match goal with
                         | [ |- context[list_rect P0 N0 C0 ?ls'' ?a''] ]
                           => specialize (IH a'')
                       end;
                       let T := match type of IH with ?T -> _ => T end in
                       let H_helper := fresh in
                       assert (H_helper : T);
                         [
                         | specialize (IH H_helper);
                           setoid_rewrite <- IH; clear IH ] ]
          end.
          { reflexivity. }
          { rewrite rdp_list_production_tl_correct.
            match goal with
              | [ H : _ = ?x |- context[?x] ]
                => rewrite <- H; reflexivity
            end. }
          { simpl.
            match goal with
            | [ |- context[EqNat.beq_nat (List.length ?ls) 0] ]
              => is_var ls; destruct ls; simpl; try reflexivity
            end; [].
            repeat match goal with
                   | [ |- ?x = ?x ] => reflexivity
                   | [ H := fun _ _ => _ |- _ ] => subst H; cbv beta
                   | [ |- context[?x - (?y + (?x - ?y)) ] ]
                     => replace (x - (y + (x - y))) with 0 by (clear; omega)
                   | _ => rewrite minusr_minus
                   | _ => progress simpl
                   end. } }
        simpl.
        step_opt'; [ | reflexivity ].
        etransitivity_rev _.
        { move Hvalid''' at bottom.
          simpl @to_production in Hvalid'''.
          unfold production_rvalid in Hvalid'''.
          t_prereduce_list_evar.
          t_postreduce_list_with_hyp_with_assumption;
            [ reflexivity
            | let lem := constr:(production_tl_correct) in
              simpl rewrite lem;
              match goal with
              | [ H : _::_ = ?y |- context[tl ?y] ] => generalize dependent y; intros; subst
              end;
              simpl in *;
              try reflexivity;
              try assumption..
            | ].
          { match goal with
            | [ H : andb _ _ = true |- _ ] => apply Bool.andb_true_iff in H
            end.
            split_and; assumption. }
          match goal with
          | [ |- context[match ?nt with Terminal _ => _ | _ => _ end] ]
            => assert (Hvalid'''' : item_rvalid G nt)
          end.
          { repeat match goal with
                   | _ => assumption
                   | [ H : ?nt :: _ = ?ls, H' : context[?ls] |- is_true (item_rvalid _ ?nt) ]
                     => rewrite <- H in H'
                   | _ => progress simpl in *
                   | [ H : andb _ _ = true |- _ ] => apply Bool.andb_true_iff in H
                   | _ => progress split_and
                   end. }
          etransitivity_rev _.
          { do 4 step_opt'; [].
            etransitivity_rev _.
            { step_opt'; [ reflexivity | ].
              repeat optsplit_t'.
              { reflexivity. }
              { reflexivity. } }
            unfold list_caset, item_rect.
            repeat optsplit_t'.
            { apply (f_equal2 ret_production_cons); [ | reflexivity ].
              repeat misc_opt'.
              rewrite Min.min_idempotent.
              reflexivity. }
            { apply (f_equal2 ret_production_cons).
              { apply (f_equal3 (fun (b : bool) x y => if b then x else y)); [ | reflexivity | reflexivity ].
                apply (f_equal2 andb); [ | reflexivity ].
                match goal with
                | [ |- _ = EqNat.beq_nat (min ?v ?x) ?v ]
                  => refine (_ : Compare_dec.leb v x = _)
                end.
                match goal with
                | [ |- Compare_dec.leb 1 ?x = _ ]
                  => destruct x as [|[|]]; try reflexivity
                end. }
              { rewrite !Nat.add_1_r.
                reflexivity. } }
            { simpl in *.
              match goal with
              | [ H : is_true ?x |- context[?x] ] => rewrite H
              end.
              reflexivity. } }
          etransitivity_rev _.
          { unfold parse_item', GenericRecognizer.parse_item'.
            simpl.
            repeat optsplit_t'; repeat step_opt';
              [ apply (f_equal2 ret_production_cons) | ];
              repeat optsplit_t'; try misc_opt; repeat step_opt'.
          { reflexivity. }
          { set_evars.
            match goal with
            | [ H : is_true ?x |- context[?x] ] => rewrite H
            end.
            match goal with
            | [ H := ?e |- _ ] => is_evar e; subst H
            end.
            reflexivity. }
          { rewrite !minusr_minus, <- max_def, <- !minusr_minus.
            reflexivity. }
          { reflexivity. } }
        reflexivity. }
      reflexivity. }

      progress unfold productions, production, rproductions, rproduction.
      progress cbv beta iota zeta delta [rdp_list_predata Carriers.default_production_carrierT rdp_list_is_valid_nonterminal rdp_list_initial_nonterminals_data rdp_list_remove_nonterminal Carriers.default_nonterminal_carrierT rdp_list_nonterminals_listT rdp_list_production_tl Carriers.default_nonterminal_carrierT].

      step_opt'; [ | reflexivity ].
      step_opt'.
      step_opt'.
      etransitivity_rev _.
      { cbv beta iota delta [rdp_list_nonterminal_to_production Carriers.default_production_carrierT Carriers.default_nonterminal_carrierT].
        simpl rewrite list_to_productions_to_nonterminal; unfold Lookup_idx.
        etransitivity_rev _.
        { step_opt'; [ reflexivity | ].
          step_opt'.
          etransitivity_rev _.
          { step_opt'.
            rewrite_map_nth_rhs; simpl; rewrite !map_map; simpl.
            unfold interp_rproductions, interp_rproduction.
            apply (f_equal2 (@nth _ _)); [ | reflexivity ].
            step_opt'; [].
            rewrite map_length.
            reflexivity. }
          rewrite_map_nth_dep_rhs; simpl.
          rewrite map_length.
          unfold rproductions, rproduction.
          reflexivity. }
        rewrite_map_nth_rhs; rewrite !map_map; simpl.
        apply (f_equal2 (@nth _ _)); [ | reflexivity ].
        step_opt'; [ | reflexivity ].
        rewrite !map_map; simpl.
        reflexivity. }
      rewrite_map_nth_rhs; rewrite !map_map; simpl.
      rewrite <- nth'_nth.
      etransitivity_rev _.
      { step_opt'.
        step_opt'; [ | reflexivity ].
        reflexivity. }
      reflexivity. }
    etransitivity_rev _.
    { etransitivity_rev _.
      { repeat first [ rewrite uneta_bool
                     | idtac;
                       match goal with
                       | [ |- context[@rdp_list_of_nonterminal] ] => fail 1
                       | [ |- context[@Carriers.default_of_nonterminal] ] => fail 1
                       | [ |- context[@Carriers.default_production_tl] ] => fail 1
                       | _ => reflexivity
                       end
                     | step_opt'
                     | t_reduce_list_evar
                     | apply (f_equal2 andb)
                     | apply (f_equal2 ret_production_cons)
                     | apply (f_equal2 (@cons _))
                     | t_refine_item_match ];
        first [ progress unfold rdp_list_of_nonterminal, Carriers.default_of_nonterminal, Valid_nonterminals, grammar_of_pregrammar, pregrammar_nonterminals; simpl;
                rewrite !map_length;
                reflexivity
              | idtac;
                match goal with
                  | [ |- _ = ?f ?A ?b ?c ]
                    => refine (f_equal (fun A' => f A' b c) _)
                end;
                progress unfold Carriers.default_production_tl; simpl;
                repeat step_opt'; [ reflexivity | ];
                unfold Lookup_idx;
                unfold productions, production;
                rewrite_map_nth_rhs; simpl;
                rewrite <- nth'_nth;
                rewrite_map_nth_dep_rhs; simpl;
                step_opt'; simpl;
                rewrite !nth'_nth; simpl;
                rewrite map_length;
                rewrite <- !nth'_nth;
                change @nth' with @inner_nth';
                reflexivity
              | idtac ].
        reflexivity. }
      etransitivity_rev _.
      { set_evars.
        repeat first [ idtac;
                       match goal with
                         | [ |- context[@rdp_list_to_production] ] => fail 1
                         | _ => reflexivity
                       end
                     | rewrite rdp_list_to_production_opt_correct
                     | step_opt'
                     | t_reduce_list_evar ].
        subst_evars.
        reflexivity. }
      etransitivity_rev _.
      { step_opt'; [ | reflexivity ].
        step_opt'.
        step_opt'.
        step_opt'.
        step_opt'; [ | reflexivity ].
        unfold rdp_list_to_production_opt at 1; simpl.
        change @inner_nth' with @nth' at 3.
        etransitivity_rev _.
        { step_opt'.
          etransitivity_rev _.
          { repeat step_opt'; [ | reflexivity ].
            rewrite nth'_nth.
            rewrite_map_nth_rhs; rewrite !map_map; simpl.
            rewrite <- nth'_nth.
            change @nth' with @inner_nth'.
            apply (f_equal2 (inner_nth' _)); [ | reflexivity ].
            step_opt'; [].
            rewrite map_id.
            change @inner_nth' with @nth' at 3.
            rewrite nth'_nth.
            unfold interp_rproductions, interp_rproduction, rproductions, rproduction, production.
            rewrite !map_length.
            progress repeat match goal with
                            | [ |- context[List.nth (?minus (@List.length ?B (@List.map ?A ?B ?f ?ls)) _)] ]
                              => rewrite (@map_length A B f ls)
                            end.
            rewrite_map_nth_rhs; simpl.
            rewrite !map_map; simpl.
            unfold productions, production.
            rewrite <- nth'_nth.
            change @nth' with @inner_nth'.
            apply f_equal2; [ | reflexivity ].
            reflexivity. }
          etransitivity_rev _.
          { change @inner_nth' with @nth' at 1.
            rewrite nth'_nth.
            rewrite_map_nth_rhs; rewrite !map_map; simpl.
            rewrite <- nth'_nth.
            change @nth' with @inner_nth' at 1.
            reflexivity. }
          etransitivity_rev _.
          { apply f_equal2; [ reflexivity | ].
            lazymatch goal with
            | [ |- _ = bool_rect ?P (if ?b then ?t else ?f) ?t ?b' ]
              => transitivity (if (orb (negb b') b) then t else f); [ | destruct b, b'; reflexivity ]
            end; fin_step_opt.
            match goal with
            | [ |- context[negb (EqNat.beq_nat ?x 0)] ]
              => replace (negb (EqNat.beq_nat x 0)) with (Compare_dec.leb 1 x)
                by (destruct x as [|[]]; reflexivity)
            end.
            reflexivity. }
          etransitivity_rev _.
          { apply (f_equal2 (inner_nth' _)); [ | reflexivity ].
            step_opt'; [ ].
            change @inner_nth' with @nth' at 1.
            rewrite nth'_nth.
            rewrite_map_nth_rhs; rewrite !map_map; simpl.
            rewrite <- nth'_nth.
            change @nth' with @inner_nth' at 1.
            reflexivity. }
          etransitivity_rev _.
          { apply (f_equal2 (inner_nth' _)); [ | reflexivity ].
            step_opt'.
            apply (f_equal2 (inner_nth' _)); [ reflexivity | ].
            lazymatch goal with
            | [ |- _ = bool_rect ?P (if ?b then ?t else ?f) ?t ?b' ]
              => transitivity (if (orb (negb b') b) then t else f); [ | destruct b, b'; reflexivity ]
            end; fin_step_opt.
            match goal with
            | [ |- context[negb (EqNat.beq_nat ?x 0)] ]
              => replace (negb (EqNat.beq_nat x 0)) with (Compare_dec.leb 1 x)
                by (destruct x as [|[]]; reflexivity)
            end.
            reflexivity. }
          reflexivity. }
        reflexivity. }
      reflexivity. }
    etransitivity_rev _.
    { repeat first [ step_opt'
                   | apply (f_equal2 (inner_nth' _)); fin_step_opt
                   | apply (f_equal2 orb); fin_step_opt
                   | idtac;
                     match goal with
                     | [ |- _ = List.length (rdp_list_to_production_opt _) ]
                       => progress unfold rdp_list_to_production_opt at 1; simpl;
                          change @inner_nth' with @nth';
                          repeat match goal with
                                 | _ => progress simpl
                                 | _ => progress fin_step_opt
                                 | _ => rewrite !map_length
                                 | _ => rewrite !map_map
                                 | _ => progress unfold interp_rproductions, interp_rproduction, rproductions, rproduction
                                 | [ |- _ = nth' ?n ?ls ?d ]
                                   => refine (f_equal2 (nth' n) _ _)
                                 | [ |- _ = List.map _ (pregrammar_rproductions G) ]
                                   => step_opt'
                                 | [ |- _ = List.map (fun x : list (ritem _) => _) _ ]
                                   => step_opt'
                                 | _
                                   => progress (rewrite nth'_nth;
                                                progress rewrite_map_nth_rhs; rewrite !map_map; simpl;
                                                rewrite <- nth'_nth)
                                 | [ |- _ = List.length ?x ] => is_var x; reflexivity
                                 end;
                          fin_step_opt
                     end ];
      [ | reflexivity | reflexivity | ].
      { rewrite list_rect_map.
        t_reduce_list_evar; [ reflexivity | ].
        set_evars.
        setoid_rewrite list_caset_map.
        unfold predata in *. (* work around bug #4673, https://coq.inria.fr/bugs/show_bug.cgi?id=4673 *)
        setoid_rewrite item_rect_ritem_rect; cbv beta.
        try setoid_rewrite uneta_bool.
        subst_evars.

        step_opt'; [].
        step_opt'.
        { etransitivity_rev _.
          { set_evars.
            do 2 setoid_rewrite combine_map_r.
            do 3 setoid_rewrite map_map; simpl.
            setoid_rewrite map_length.
            progress change (fun x : ?A * ?B => fst x) with (@fst A B).
            subst_evars.

            reflexivity. }

          refine (f_equal2 ret_production_cons _ _); [ | reflexivity ].
          apply (_ : Proper (pointwise_relation _ _ ==> _ ==> _ ==> _) (ritem_rect (fun _ => parse_item_T))); repeat intro;
            [ | reflexivity | reflexivity ].
          change_char_at_matches.
          reflexivity. }
        { set_evars.
          do 2 setoid_rewrite combine_map_r.
          subst_evars.

          step_opt'.
          { set_evars.
            change_char_at_matches.
            do 3 setoid_rewrite map_map; simpl.
            setoid_rewrite map_length.
            subst_evars.

            reflexivity. }
          { step_opt'; [ | reflexivity ].
            set_evars.
            do 3 setoid_rewrite map_map; simpl.
            setoid_rewrite map_length.
            progress change (fun x : ?A * ?B => fst x) with (@fst A B).
            subst_evars.

            reflexivity. } } }
      { reflexivity. } }

    simpl.
    progress change (fun x : list ?T => @List.length ?T x) with (@List.length T).
    progress change @inner_nth' with @nth'.

    (** change [nth'] back to [nth] *)
    etransitivity_rev _.
    { step_opt'; [ | reflexivity ].
      step_opt'.
      step_opt'.
      apply (f_equal2 (nth' _)); fin_step_opt; [].
      repeat lazymatch goal with
             | [ |- _ = nth' _ _ _ ]
               => rewrite nth'_nth; apply (f_equal2 (nth _))
             | [ |- _ = orb _ _ ] => apply f_equal2
             | [ |- _ = ret_production_cons _ _ ] => apply f_equal2
             | [ |- _ = list_rect _ _ _ ?x _ _ _ ]
               => is_var x; t_reduce_list_evar
             | [ |- _ = ?f (_, (_, _)) _ _ ]
               => is_var f; apply f_equal3
             | [ |- context[@nth'] ]
               => step_opt' || fin_step_opt
             | _ => reflexivity
             end. }

    simpl.
    reflexivity.
  Defined.

  Definition parse_nonterminal_opt
             (str : String)
             (nt : String.string)
  : { b : _ | b = parse_nonterminal (data := optdata) str nt }.
  Proof.
    let c := constr:(parse_nonterminal_opt'1 str nt) in
    let h := head c in
    let impl := (eval cbv beta iota zeta delta [h proj1_sig] in (proj1_sig c)) in
    (exists impl);
      abstract (exact (proj2_sig c)).
  Defined.

  Lemma parse_nonterminal_opt_eq
        {HSLP : StringLikeProperties Char}
        {splitdata_correct : @boolean_parser_completeness_dataT' _ _ _ G data}
        (str : String)
        (nt : String.string)
    : is_correct (proj1_sig (parse_nonterminal_opt str nt)) str nt.
  Proof.
    let p := match goal with |- context[proj1_sig ?p] => p end in
    rewrite (proj2_sig p).
    apply parse_nonterminal_optdata_eq.
  Qed.
End recursive_descent_parser.