(* ***********************************************************************)
(*                                                                       *)
(*   Synchronously executed Interpreted Time Petri Nets (SITPNs)         *)
(*                                                                       *)
(*                                                                       *)
(*   Copyright Université de Montpellier, contributor(s): Vincent        *)
(*   Iampietro, David Andreu, David Delahaye (May 2020)                  *)
(*                                                                       *)
(*   This software is governed by the CeCILL-C license under French law  *)
(*   and abiding by the rules of distribution of free software.  You can *)
(*   use, modify and/ or redistribute the software under the terms of    *)
(*   the CeCILL-C license as circulated by CEA, CNRS and INRIA at the    *)
(*   following URL "http://www.cecill.info".  The fact that you are      *)
(*   presently reading this means that you have had knowledge of the     *)
(*   CeCILL-C license and that you accept its terms.                     *)
(*                                                                       *)
(* ***********************************************************************)

(* Import Sitpn material. *)

Require Import simpl.Sitpn.
Require Import simpl.SitpnTokenPlayer.
Require Import simpl.SitpnSemantics.
Require Import simpl.SitpnTactics.
Require Import simpl.SitpnCoreLemmas.

(* Import misc. lemmas, tactics and definitions. *)

(* Import lemmas about marking. *)

Require Import simpl.SitpnWellDefMarking.
Require Import simpl.SitpnRisingEdgeMarking.
Require Import simpl.SitpnFallingEdgeFiredComplete.

(* Import classical logic. *)

Require Import Classical_Prop.

(** * Completeness for [map_update_marking_pre]. *)

Section MapUpdateMarkingPreComplete.

  (** Completeness lemma for [modify_m]. *)

  Lemma modify_m_complete :
    forall (marking : list (Place * nat))
           (p : Place)
           (op : nat -> nat -> nat)
           (nboftokens : nat),
      In p (fs marking) ->
      NoDup (fs marking) ->
      exists m' : list (Place * nat),
        modify_m marking p op nboftokens = Some m'
        /\ forall (n : nat), In (p, n) marking -> In (p, op n nboftokens) m'.
  Proof.
    induction marking.

    (* BASE CASE, marking = [] *)
    - intros p op nboftokens Hin; simpl in Hin; inversion Hin.

    (* INDUCTION CASE *)
    - destruct a; simpl; intros pl op nboftkens Hin_p_fsm Hnodup_fsm.

      (* Two case, for p =? pl *)
      case_eq (p =? pl); intros Heq_ppl.

      (* Case (p =? pl) = true *)
      + exists ((pl, op n nboftkens) :: marking).
        repeat split.
        intros nb Hv; inversion_clear Hv as [Heq_pn | Hin_m].

        (* Case (p, n) = (pl, nb) *)
        -- injection Heq_pn as Heq_p Heq_n; rewrite Heq_n; apply in_eq.

        (* Case (pl, nb) ∈ marking, contradiction with NoDup (fs ((p, n) :: marking))
           knowing that p = pl. *)
        -- apply beq_nat_true in Heq_ppl.
           rewrite Heq_ppl in Hnodup_fsm.
           unfold fs in Hnodup_fsm; rewrite fst_split_cons_app in Hnodup_fsm.
           simpl in Hnodup_fsm.
           rewrite NoDup_cons_iff in Hnodup_fsm.
           apply proj1 in Hnodup_fsm.
           apply in_fst_split in Hin_m.
           contradiction.

      (* Case (p =? pl) = false *)
      +
        (* Specializes IHmarking. *)

        assert (Hin_p_fsm' : In pl (fs marking)).
        {
          unfold fs in Hin_p_fsm; rewrite fst_split_cons_app in Hin_p_fsm.
          simpl in Hin_p_fsm.
          apply beq_nat_false in Heq_ppl.
          inversion_clear Hin_p_fsm as [Heq_ppl' | Hin_pl_fsm];
            [ contradiction | assumption ].
        }

        assert (Hnodup_fsm' : NoDup (fs marking)).
        {
          unfold fs in Hnodup_fsm; rewrite fst_split_cons_app in Hnodup_fsm.
          simpl in Hnodup_fsm.
          rewrite NoDup_cons_iff in Hnodup_fsm.
          apply proj2 in Hnodup_fsm.
          assumption.
        }

        specialize (IHmarking pl op nboftkens Hin_p_fsm' Hnodup_fsm')
          as Hex_modif_m.
        inversion_clear Hex_modif_m as (m' & Hw_modif_m).
        inversion_clear Hw_modif_m as (Hmodif_m & Hdef_m').

        (* Rewrites the goal with the newly-built hypothesis. *)
        rewrite Hmodif_m.

        (* Instantiates the new marking, then completes the goal. *)
        exists ((p, n) :: m').
        repeat split.
        intros nb Hw.
        inversion_clear Hw as [Heq_pn | Hin_m].
        -- injection Heq_pn as Heq_p Heq_n.
           apply beq_nat_false in Heq_ppl; contradiction.
        -- apply in_cons; apply (Hdef_m' nb Hin_m).
  Qed.

  (** Completeness lemma for [update_marking_pre_aux]. *)

  Lemma update_marking_pre_aux_complete :
    forall (pre_places : list Place)
           (sitpn : Sitpn)
           (t : Trans)
           (marking : list (Place * nat)),
      IsWellDefinedSitpn sitpn ->
      In t (transs sitpn) ->
      Permutation (places sitpn) (fs marking) ->
      IsDecListCons pre_places (pre_pl (lneighbours sitpn t)) ->
      NoDup pre_places ->
      exists m' : list (Place * nat),
        update_marking_pre_aux sitpn marking t pre_places = Some m'
        /\ (forall (p : Place) (n : nat), In p pre_places -> In (p, n) marking -> In (p, n - pre sitpn t p) m')
        /\ (fs marking) = (fs m').
  Proof.
    intros pre_places sitpn t;
      induction pre_places;
      intros marking Hwell_def_sitpn Hin_t_transs
             Hperm_pls His_dec Hnodup_prepl;
      simpl.

    (* BASE CASE, pre_places = [] *)

    - exists marking; repeat split.
      intros p n Hfalse; inversion Hfalse.

    (* INDUCTION CASE *)
    -
      (* Specializes modify_m_complete, then rewrites the goal. *)

      assert (Hin_a_fsm : In a (fs marking)).
      {
        assert (Hin_a_fn : In a (flatten_neighbours (lneighbours sitpn t))).
        {
          unfold flatten_neighbours.
          apply in_or_app; left.
          deduce_in_from_is_dec_list_cons His_dec as Hin_a_prepl.
          assumption.
        }

        specialize (in_transs_incl_flatten t Hwell_def_sitpn Hin_t_transs)
          as Hincl_fn_fl.
        specialize (Hincl_fn_fl a Hin_a_fn).
        explode_well_defined_sitpn.
        unfold NoUnknownPlaceInNeighbours in Hunk_pl_neigh.
        specialize (Hunk_pl_neigh a Hincl_fn_fl).
        rewrite Hperm_pls in Hunk_pl_neigh; assumption.
      }

      assert (Hnodup_fsm : NoDup (fs marking)).
      {
        explode_well_defined_sitpn.
        unfold NoDupPlaces in Hnodup_places.
        rewrite Hperm_pls in Hnodup_places.
        assumption.
      }

      specialize (modify_m_complete marking a Nat.sub (pre sitpn t a) Hin_a_fsm Hnodup_fsm)
        as Hex_modif_m.

      (* Explodes the newly-built hypotheses, then rewrites the goal. *)
      inversion_clear Hex_modif_m as (m' & Hmodif_m_w).
      inversion_clear Hmodif_m_w as (Hmodif_m & Hdef_m').
      rewrite Hmodif_m.

      (* Then specializes IHpre_places. *)

      assert (Hperm_pls_m' : Permutation (places sitpn) (fs m')).
      {
        specialize (modify_m_same_struct marking a Nat.sub (pre sitpn t a) m' Hmodif_m)
          as Heq_fsm_fsm'.
        unfold fs; rewrite <- Heq_fsm_fsm'; assumption.
      }

      assert (Hnodup_prepl' : NoDup pre_places).
      {
        rewrite NoDup_cons_iff in Hnodup_prepl;
          apply proj2 in Hnodup_prepl;
          assumption.
      }

      specialize (@IHpre_places m' Hwell_def_sitpn Hin_t_transs Hperm_pls_m'
                                (is_dec_list_cons_cons His_dec) Hnodup_prepl')
        as Hex_up_mark_pre.

      (* Explodes the newly-built hypothesis. *)
      inversion_clear Hex_up_mark_pre as (final_marking & Hup_mark_pre_w).
      inversion_clear Hup_mark_pre_w as (Hup_mark_pre & Hw).
      inversion_clear Hw as (Hdef_fm & Heq_fsm'_fsfm).

      (* Instantiates final_marking, then solves each branch of the goal. *)
      exists final_marking.
      repeat split.

      (* Trivial case. *)
      + assumption.

      (* Case definition of final_marking. *)
      + intros p n Hin_prepl_v Hin_pn_m.

        (* Two case: a = p \/ In p pre_places. *)
        inversion_clear Hin_prepl_v as [Heq_ap | Hin_p_prepl].

        (* Case a = p *)
        -- rewrite <- Heq_ap in Hin_pn_m.
           specialize (Hdef_m' n Hin_pn_m) as Hin_ansub_m'.

           (* Specializes update_marking_pre_aux_not_in_pre_places
              to deduce In (a, n - pre) final_marking. *)

           assert (Heq_fsm_fsm' : (fs marking) = (fs m')).
           {
             apply (modify_m_same_struct marking a Nat.sub (pre sitpn t a) m' Hmodif_m).
           }

           assert (Hnot_in_a_prepl : ~In a pre_places).
           {
             apply NoDup_cons_iff, proj1 in Hnodup_prepl; assumption.
           }

           rewrite (update_marking_pre_aux_not_in_pre_places
                      sitpn m' t pre_places final_marking Hup_mark_pre
                      a Hnot_in_a_prepl (n - pre sitpn t a)) in Hin_ansub_m'.
           rewrite Heq_ap in Hin_ansub_m'.
           assumption.

        (* Case In p pre_places *)
        --
          (* Rewrites In (p, n) marking with modify_m_in_if_diff to
             get In (p, n) m'. *)

          assert (Hneq_ap : a <> p).
          {
            apply NoDup_cons_iff, proj1 in Hnodup_prepl.
            apply (not_in_in_diff a p pre_places (conj Hnodup_prepl Hin_p_prepl)).
          }

          rewrite (modify_m_in_if_diff marking a Nat.sub (pre sitpn t a) m'
                                       Hmodif_m p n Hneq_ap)
            in Hin_pn_m.

          (* Completes the goal by applying Hdef_fm. *)
          apply (Hdef_fm p n Hin_p_prepl Hin_pn_m).

      (* Case fs marking = fs final_marking *)
      +
        assert (Heq_fsm_fsm' : (fs marking) = (fs m')).
        {
          apply (modify_m_same_struct marking a Nat.sub (pre sitpn t a) m' Hmodif_m).
        }

        transitivity (fs m'); [assumption | assumption].
  Qed.

  (** Completeness lemma for [map_update_marking_pre]. *)

  Lemma map_update_marking_pre_complete :
    forall (sitpn : Sitpn)
           (s s' : SitpnState)
           (time_value : nat)
           (env : Condition -> nat -> bool)
           (fired : list Trans)
           (marking : list (Place * nat)),
      IsWellDefinedSitpn sitpn ->
      IsWellDefinedSitpnState sitpn s ->
      IsWellDefinedSitpnState sitpn s' ->
      SitpnSemantics sitpn s s' time_value env rising_edge ->
      Permutation (places sitpn) (fs marking) ->
      incl fired (Sitpn.fired s) ->
      NoDup fired ->
      exists transient_marking : list (Place * nat),
        map_update_marking_pre sitpn marking fired = Some transient_marking
        /\ forall (p : Place) (n : nat), In (p, n) marking ->
                                         In (p, n - pre_sum sitpn p fired) transient_marking.
  Proof.
    intros sitpn s s' time_value env;
      induction fired;
      intros marking Hwell_def_sitpn Hwell_def_s Hwell_def_s' Hspec
             Hperm_m Hincl_fired Hnodup_fired.

    (* BASE CASE, fired = [] *)
    - simpl; exists marking; split;
        [ reflexivity | intros p n Hin; rewrite <- minus_n_O; assumption ].

    (* INDUCTION CASE, a :: fired *)
    - simpl.
      unfold update_marking_pre.

      (* Specializes update_marking_pre_aux_complete *)

      assert (Hin_a_transs : In a (transs sitpn)).
      {
        specialize (Hincl_fired a (in_eq a fired)) as Hin_a_fired.
        explode_well_defined_sitpn_state Hwell_def_s.
        apply (Hincl_state_fired_transs a Hin_a_fired).
      }

      assert (Hnodup_prepl : NoDup (pre_pl (lneighbours sitpn a))).
      {
        explode_well_defined_sitpn.
        unfold NoDupInNeighbours in Hnodup_neigh.
        specialize (Hnodup_neigh a Hin_a_transs) as Hnodup_w.
        apply proj1 in Hnodup_w.
        apply nodup_app, proj1 in Hnodup_w.
        assumption.
      }

      specialize (update_marking_pre_aux_complete
                    (pre_pl (lneighbours sitpn a)) sitpn a marking
                    Hwell_def_sitpn Hin_a_transs Hperm_m
                    (IsDecListCons_refl (pre_pl (lneighbours sitpn a)))
                    Hnodup_prepl)
        as Hex_up_mark_pre.

      (* Explodes the newly-built hypothesis, then rewrites the goal. *)

      inversion_clear Hex_up_mark_pre as (m' & Hw).
      inversion_clear Hw as (Hup_mark_pre & H_defm'_w).
      inversion_clear H_defm'_w as (Hdef_m' & Heq_fsm_fsm').
      rewrite Hup_mark_pre.

      (* Then specializes IHfired. *)

      assert (Hperm_m' : Permutation (places sitpn) (fs m'))
        by (rewrite Heq_fsm_fsm' in Hperm_m; assumption).

      assert (Hincl_fired' : incl fired (Sitpn.fired s))
        by (apply (incl_cons_inv a fired (Sitpn.fired s) Hincl_fired)).

      assert (Hnodup_fired' : NoDup fired)
        by (apply NoDup_cons_iff, proj2 in Hnodup_fired; assumption).

      specialize (IHfired m' Hwell_def_sitpn Hwell_def_s Hwell_def_s' Hspec
                          Hperm_m' Hincl_fired' Hnodup_fired')
        as Hex_map_up_pre.

      (* Explodes the newly-built hypothesis and instantiates
         transient_marking. *)

      inversion_clear Hex_map_up_pre as (transient_marking & Hw).
      inversion_clear Hw as (Hmap_up_pre & Hdef_tm).
      exists transient_marking.

      (* Splits and solves each branch of the goal. *)

      repeat split.

      (* Equality case, trivial. *)
      + trivial.

      (* Case transient_marking definition. *)
      + intros p n Hin_pn_m.

        (* Two cases, either p ∈ (pre_pl a) or p ∉ (pre_pl a) *)

        assert (Hin_prepl_v := classic (In p (pre_pl (lneighbours sitpn a)))).
        inversion_clear Hin_prepl_v as [Hin_prepl | Hnot_in_prepl].

        (* Case In p pre_pl *)
        -- specialize (Hdef_m' p n Hin_prepl Hin_pn_m) as Hin_pn_m'.
           rewrite Nat.sub_add_distr.
           apply (Hdef_tm p (n - pre sitpn a p) Hin_pn_m').

        (* Case ~In p pre_pl *)
        --
          (* If p in not is pre-places of a then there's no pre arc
             between p and a. *)

          assert (Heq_pre_0 : pre sitpn a p = 0).
          {
            explode_well_defined_sitpn.
            unfold AreWellDefinedPreEdges in Hwell_def_pre.
            specialize (Hwell_def_pre a p Hin_a_transs).
            apply proj2 in Hwell_def_pre.
            apply (Hwell_def_pre Hnot_in_prepl).
          }

          rewrite Heq_pre_0, Nat.add_0_l.

          (* Rewrites In (p, n) marking with
             update_marking_pre_aux_not_in_pre_places to get In (p, n) m'. *)

          rewrite (update_marking_pre_aux_not_in_pre_places
                     sitpn marking a (pre_pl (lneighbours sitpn a))
                     m' Hup_mark_pre p Hnot_in_prepl) in Hin_pn_m.

          (* Then completes the goal. *)

          apply (Hdef_tm p n Hin_pn_m).
  Qed.

End MapUpdateMarkingPreComplete.

(** * Completeness for [map_update_marking_post]. *)

Section MapUpdateMarkingPostComplete.

  (** Completeness lemma for [update_marking_post_aux]. *)

  Lemma update_marking_post_aux_complete :
    forall (post_places : list Place)
           (sitpn : Sitpn)
           (t : Trans)
           (marking : list (Place * nat)),
      IsWellDefinedSitpn sitpn ->
      In t (transs sitpn) ->
      Permutation (places sitpn) (fs marking) ->
      IsDecListCons post_places (post_pl (lneighbours sitpn t)) ->
      NoDup post_places ->
      exists m' : list (Place * nat),
        update_marking_post_aux sitpn marking t post_places = Some m'
        /\ (forall (p : Place) (n : nat), In p post_places -> In (p, n) marking -> In (p, n + post sitpn t p) m')
        /\ (fs marking) = (fs m').
  Proof.
    intros post_places sitpn t;
      induction post_places;
      intros marking Hwell_def_sitpn Hin_t_transs
             Hperm_pls His_dec Hnodup_postpl;
      simpl.

    (* BASE CASE, post_places = [] *)

    - exists marking; repeat split.
      intros p n Hfalse; inversion Hfalse.

    (* INDUCTION CASE *)
    -
      (* Specializes modify_m_complete, then rewrites the goal. *)

      assert (Hin_a_fsm : In a (fs marking)).
      {
        assert (Hin_a_fn : In a (flatten_neighbours (lneighbours sitpn t))).
        {
          unfold flatten_neighbours.
          do 3 (apply in_or_app; right).
          deduce_in_from_is_dec_list_cons His_dec as Hin_a_postpl.
          assumption.
        }

        specialize (in_transs_incl_flatten t Hwell_def_sitpn Hin_t_transs)
          as Hincl_fn_fl.
        specialize (Hincl_fn_fl a Hin_a_fn).
        explode_well_defined_sitpn.
        unfold NoUnknownPlaceInNeighbours in Hunk_pl_neigh.
        specialize (Hunk_pl_neigh a Hincl_fn_fl).
        rewrite Hperm_pls in Hunk_pl_neigh; assumption.
      }

      assert (Hnodup_fsm : NoDup (fs marking)).
      {
        explode_well_defined_sitpn.
        unfold NoDupPlaces in Hnodup_places.
        rewrite Hperm_pls in Hnodup_places.
        assumption.
      }

      specialize (modify_m_complete marking a Nat.add (post sitpn t a) Hin_a_fsm Hnodup_fsm)
        as Hex_modif_m.

      (* Explodes the newly-built hypotheses, then rewrites the goal. *)
      inversion_clear Hex_modif_m as (m' & Hmodif_m_w).
      inversion_clear Hmodif_m_w as (Hmodif_m & Hdef_m').
      rewrite Hmodif_m.

      (* Then specializes IHpost_places. *)

      assert (Hperm_pls_m' : Permutation (places sitpn) (fs m')).
      {
        specialize (modify_m_same_struct marking a Nat.add (post sitpn t a) m' Hmodif_m)
          as Heq_fsm_fsm'.
        unfold fs; rewrite <- Heq_fsm_fsm'; assumption.
      }

      assert (Hnodup_postpl' : NoDup post_places).
      {
        rewrite NoDup_cons_iff in Hnodup_postpl;
          apply proj2 in Hnodup_postpl;
          assumption.
      }

      specialize (@IHpost_places m' Hwell_def_sitpn Hin_t_transs Hperm_pls_m'
                                (is_dec_list_cons_cons His_dec) Hnodup_postpl')
        as Hex_up_mark_post.

      (* Explodes the newly-built hypothesis. *)
      inversion_clear Hex_up_mark_post as (final_marking & Hup_mark_post_w).
      inversion_clear Hup_mark_post_w as (Hup_mark_post & Hw).
      inversion_clear Hw as (Hdef_fm & Heq_fsm'_fsfm).

      (* Instantiates final_marking, then solves each branch of the goal. *)
      exists final_marking.
      repeat split.

      (* Trivial case. *)
      + assumption.

      (* Case definition of final_marking. *)
      + intros p n Hin_postpl_v Hin_pn_m.

        (* Two case: a = p \/ In p post_places. *)
        inversion_clear Hin_postpl_v as [Heq_ap | Hin_p_postpl].

        (* Case a = p *)
        -- rewrite <- Heq_ap in Hin_pn_m.
           specialize (Hdef_m' n Hin_pn_m) as Hin_ansub_m'.

           (* Specializes update_marking_post_aux_not_in_post_places
              to deduce In (a, n + post) final_marking. *)

           assert (Heq_fsm_fsm' : (fs marking) = (fs m')).
           {
             apply (modify_m_same_struct marking a Nat.add (post sitpn t a) m' Hmodif_m).
           }

           assert (Hnot_in_a_postpl : ~In a post_places).
           {
             apply NoDup_cons_iff, proj1 in Hnodup_postpl; assumption.
           }

           rewrite (update_marking_post_aux_not_in_post_places
                      sitpn m' t post_places final_marking Hup_mark_post
                      a Hnot_in_a_postpl (n + post sitpn t a)) in Hin_ansub_m'.
           rewrite Heq_ap in Hin_ansub_m'.
           assumption.

        (* Case In p post_places *)
        --
          (* Rewrites In (p, n) marking with modify_m_in_if_diff to
             get In (p, n) m'. *)

          assert (Hneq_ap : a <> p).
          {
            apply NoDup_cons_iff, proj1 in Hnodup_postpl.
            apply (not_in_in_diff a p post_places (conj Hnodup_postpl Hin_p_postpl)).
          }

          rewrite (modify_m_in_if_diff marking a Nat.add (post sitpn t a) m'
                                       Hmodif_m p n Hneq_ap)
            in Hin_pn_m.

          (* Completes the goal by applying Hdef_fm. *)
          apply (Hdef_fm p n Hin_p_postpl Hin_pn_m).

      (* Case fs marking = fs final_marking *)
      +
        assert (Heq_fsm_fsm' : (fs marking) = (fs m')).
        {
          apply (modify_m_same_struct marking a Nat.add (post sitpn t a) m' Hmodif_m).
        }

        transitivity (fs m'); [assumption | assumption].
  Qed.

  (** Completeness lemma for [map_update_marking_post]. *)

  Lemma map_update_marking_post_complete :
    forall (sitpn : Sitpn)
           (s s' : SitpnState)
           (time_value : nat)
           (env : Condition -> nat -> bool)
           (fired : list Trans)
           (marking : list (Place * nat)),
      IsWellDefinedSitpn sitpn ->
      IsWellDefinedSitpnState sitpn s ->
      IsWellDefinedSitpnState sitpn s' ->
      SitpnSemantics sitpn s s' time_value env rising_edge ->
      Permutation (places sitpn) (fs marking) ->
      incl fired (Sitpn.fired s) ->
      NoDup fired ->
      exists transient_marking : list (Place * nat),
        map_update_marking_post sitpn marking fired = Some transient_marking
        /\ forall (p : Place) (n : nat), In (p, n) marking ->
                                         In (p, n + post_sum sitpn p fired) transient_marking.
  Proof.
    intros sitpn s s' time_value env;
      induction fired;
      intros marking Hwell_def_sitpn Hwell_def_s Hwell_def_s' Hspec
             Hperm_m Hincl_fired Hnodup_fired.

    (* BASE CASE, fired = [] *)
    - simpl; exists marking; split;
        [ reflexivity | intros p n Hin; rewrite <- plus_n_O; assumption ].

    (* INDUCTION CASE, a :: fired *)
    - simpl.
      unfold update_marking_post.

      (* Specializes update_marking_post_aux_complete *)

      assert (Hin_a_transs : In a (transs sitpn)).
      {
        specialize (Hincl_fired a (in_eq a fired)) as Hin_a_fired.
        explode_well_defined_sitpn_state Hwell_def_s.
        apply (Hincl_state_fired_transs a Hin_a_fired).
      }

      assert (Hnodup_postpl : NoDup (post_pl (lneighbours sitpn a))).
      {
        explode_well_defined_sitpn.
        unfold NoDupInNeighbours in Hnodup_neigh.
        specialize (Hnodup_neigh a Hin_a_transs) as Hnodup_w.
        apply proj2 in Hnodup_w.
        assumption.
      }

      specialize (update_marking_post_aux_complete
                    (post_pl (lneighbours sitpn a)) sitpn a marking
                    Hwell_def_sitpn Hin_a_transs Hperm_m
                    (IsDecListCons_refl (post_pl (lneighbours sitpn a)))
                    Hnodup_postpl)
        as Hex_up_mark_post.

      (* Explodes the newly-built hypothesis, then rewrites the goal. *)

      inversion_clear Hex_up_mark_post as (m' & Hw).
      inversion_clear Hw as (Hup_mark_post & H_defm'_w).
      inversion_clear H_defm'_w as (Hdef_m' & Heq_fsm_fsm').
      rewrite Hup_mark_post.

      (* Then specializes IHfired. *)

      assert (Hperm_m' : Permutation (places sitpn) (fs m'))
        by (rewrite Heq_fsm_fsm' in Hperm_m; assumption).

      assert (Hincl_fired' : incl fired (Sitpn.fired s))
        by (apply (incl_cons_inv a fired (Sitpn.fired s) Hincl_fired)).

      assert (Hnodup_fired' : NoDup fired)
        by (apply NoDup_cons_iff, proj2 in Hnodup_fired; assumption).

      specialize (IHfired m' Hwell_def_sitpn Hwell_def_s Hwell_def_s' Hspec
                          Hperm_m' Hincl_fired' Hnodup_fired')
        as Hex_map_up_post.

      (* Explodes the newly-built hypothesis and instantiates
         transient_marking. *)

      inversion_clear Hex_map_up_post as (transient_marking & Hw).
      inversion_clear Hw as (Hmap_up_post & Hdef_tm).
      exists transient_marking.

      (* Splits and solves each branch of the goal. *)

      repeat split.

      (* Equality case, trivial. *)
      + trivial.

      (* Case transient_marking definition. *)
      + intros p n Hin_pn_m.

        (* Two cases, either p ∈ (post_pl a) or p ∉ (post_pl a) *)

        assert (Hin_postpl_v := classic (In p (post_pl (lneighbours sitpn a)))).
        inversion_clear Hin_postpl_v as [Hin_postpl | Hnot_in_postpl].

        (* Case In p post_pl *)
        -- specialize (Hdef_m' p n Hin_postpl Hin_pn_m) as Hin_pn_m'.
           rewrite Nat.add_assoc.
           apply (Hdef_tm p (n + post sitpn a p) Hin_pn_m').

        (* Case ~In p post_pl *)
        --
          (* If p in not is post-places of a then there's no post arc
             between p and a. *)

          assert (Heq_post_0 : post sitpn a p = 0).
          {
            explode_well_defined_sitpn.
            unfold AreWellDefinedPostEdges in Hwell_def_post.
            specialize (Hwell_def_post a p Hin_a_transs).
            apply proj2 in Hwell_def_post.
            apply (Hwell_def_post Hnot_in_postpl).
          }

          rewrite Heq_post_0, Nat.add_0_l.

          (* Rewrites In (p, n) marking with
             update_marking_post_aux_not_in_post_places to get In (p, n) m'. *)

          rewrite (update_marking_post_aux_not_in_post_places
                     sitpn marking a (post_pl (lneighbours sitpn a))
                     m' Hup_mark_post p Hnot_in_postpl) in Hin_pn_m.

          (* Then completes the goal. *)

          apply (Hdef_tm p n Hin_pn_m).
  Qed.

End MapUpdateMarkingPostComplete.

(** * Completeness of the combination of map_update_marking functions. *)

Section MapUpdateMarkingComplete.

  (** ∀ t, ∀ l, t ∈ l ∧ NoDup l ⇒ post_sum l = post t + post_sum (l - {t})
   *  Needed to prove post_sum_eq_iff_incl. *)

  Lemma post_sum_add_rm :
    forall (sitpn : Sitpn)
           (p : Place)
           (l : list Trans)
           (t : Trans),
      In t l -> NoDup l -> post_sum sitpn p l = post sitpn t p + post_sum sitpn p (remove eq_nat_dec t l).
  Proof.
    intros sitpn p l;
      functional induction (post_sum sitpn p l) using post_sum_ind;
      intros a Hin_a_l Hnodup_l.
    - inversion Hin_a_l.
    - inversion_clear Hin_a_l as [Heq_at | Hin_a_tl].
      + rewrite <- Heq_at.
        simpl; case (Nat.eq_dec t t).
        -- intro Heq_refl.
           rewrite NoDup_cons_iff in Hnodup_l; apply proj1 in Hnodup_l.
           specialize (not_in_remove_eq Nat.eq_dec t tail Hnodup_l) as Heq_rm.
           rewrite Heq_rm; reflexivity.
        -- intro Heq_diff; elim Heq_diff; reflexivity.
      + simpl; case (Nat.eq_dec a t).
        -- rewrite NoDup_cons_iff in Hnodup_l; apply proj1 in Hnodup_l.
           specialize (not_in_in_diff t a tail (conj Hnodup_l Hin_a_tl)) as Hdiff_ta.
           intro Heq_at; symmetry in Heq_at; contradiction.
        -- intro Hdiff_at.
           simpl; symmetry; rewrite Nat.add_comm.
           rewrite <- Nat.add_assoc.
           rewrite Nat.add_cancel_l; symmetry; rewrite Nat.add_comm.
           rewrite NoDup_cons_iff in Hnodup_l; apply proj2 in Hnodup_l.
           apply (IHn a Hin_a_tl Hnodup_l).
  Qed.

  (** For all list of transitions l and l', if l is a permutation
   *  of l', then post_sum l = post_sum l'. *)

  Lemma post_sum_eq_iff_incl :
    forall (sitpn : Sitpn)
           (p : Place)
           (l l' : list Trans),
      NoDup l ->
      NoDup l' ->
      (forall t : Trans, In t l <-> In t l') ->
      post_sum sitpn p l = post_sum sitpn p l'.
  Proof.
    intros sitpn p l;
      functional induction (post_sum sitpn p l) using post_sum_ind;
      intros l' Hnodup_l Hnodup_l' Hequiv.

    (* BASE CASE *)
    - functional induction (post_sum sitpn p l') using post_sum_ind.
      + reflexivity.
      + assert (Hin_eq : In t (t :: tail)) by apply in_eq.
        rewrite <- Hequiv in Hin_eq; inversion Hin_eq.

    (* GENERAL CASE *)
    - assert (Hin_eq : In t (t :: tail)) by apply in_eq.
      rewrite Hequiv in Hin_eq.
      specialize (post_sum_add_rm sitpn p l' t Hin_eq Hnodup_l') as Heq_postsum.
      rewrite Heq_postsum.
      rewrite Nat.add_cancel_l.
      assert (Hequiv_tl : forall t0 : Trans, In t0 tail <-> In t0 (remove Nat.eq_dec t l')).
      {
        intro t0; split.
        - intro Hin_tl; specialize (in_cons t t0 tail Hin_tl) as Hin_t0_ctl.
          rewrite NoDup_cons_iff in Hnodup_l.
          apply proj1 in Hnodup_l.
          specialize (not_in_in_diff t t0 tail (conj Hnodup_l Hin_tl)) as Hdiff_tt0.
          apply not_eq_sym in Hdiff_tt0.
          rewrite Hequiv in Hin_t0_ctl.
          rewrite in_remove_iff; apply (conj Hin_t0_ctl Hdiff_tt0).
        - intro Hin_rm.
          rewrite in_remove_iff in Hin_rm.
          elim Hin_rm; clear Hin_rm; intros Hin_t0_l' Hdiff_t0t.
          rewrite <- Hequiv in Hin_t0_l'.
          inversion_clear Hin_t0_l' as [Heq_t0t | Hin_t0_tl].
          + symmetry in Heq_t0t; contradiction.
          + assumption.
      }

      rewrite NoDup_cons_iff in Hnodup_l; apply proj2 in Hnodup_l.
      specialize (nodup_if_remove l' Hnodup_l' t Nat.eq_dec) as Hnodup_rm.
      apply (IHn (remove Nat.eq_dec t l') Hnodup_l Hnodup_rm Hequiv_tl).
  Qed.

  (** Completeness lemma for map_update_marking functions. *)

  Lemma map_update_marking_complete :
    forall (sitpn : Sitpn)
           (s s' : SitpnState)
           (time_value : nat)
           (env : Condition -> nat -> bool)
           (frd : list Trans)
           (m : list (Place * nat))
           (transient_marking : list (Place * nat))
           (final_marking : list (Place * nat)),
      IsWellDefinedSitpn sitpn ->
      IsWellDefinedSitpnState sitpn s ->
      IsWellDefinedSitpnState sitpn s' ->
      SitpnSemantics sitpn s s' time_value env rising_edge ->
      (forall (p : Place) (n : nat),
          In (p, n) m ->
          In (p, n - pre_sum sitpn p frd) transient_marking) ->
      (forall (p : Place) (n : nat),
          In (p, n) transient_marking ->
          In (p, n + post_sum sitpn p frd) final_marking) ->
      Permutation (marking s) m ->
      Permutation (fired s) frd ->
      fs final_marking = fs m ->
      NoDup final_marking ->
      Permutation final_marking (marking s').
  Proof.
    intros sitpn s s' time_value env frd m transient_marking final_marking
           Hwell_def_sitpn Hwell_def_s Hwell_def_s' Hspec
           Hdef_tm Hdef_fm Hperm_ms Hperm_fs Heq_fsfm_fsm Hnodup_fm.

    (* Strategy: apply NoDup_Permutation, then we need:

       - NoDup (marking s')
       - ∀ x ∈ final_marking ⇔ x ∈ (marking s') *)

    assert (Hnodup_ms' : NoDup (marking s')).
    {
      explode_well_defined_sitpn_state Hwell_def_s'.
      explode_well_defined_sitpn.
      unfold NoDupPlaces in Hnodup_places.
      rewrite Hwf_state_marking in Hnodup_places.
      apply (nodup_fst_split (marking s') Hnodup_places).
    }

    assert (Hequiv_fm_ms' : forall x : (Place * nat), In x final_marking <-> In x (marking s')).
    {

      assert (Heq_fsm_fsm' : fst (split (marking s)) = fst (split (marking s'))).
      {
        explode_well_defined_sitpn_state Hwell_def_s.
        explode_well_defined_sitpn_state Hwell_def_s'.
        rewrite <- Hwf_state_marking, <- Hwf_state_marking0.
        reflexivity.
      }

      assert (Hnodup_fs : NoDup (fired s))
        by (explode_well_defined_sitpn_state Hwell_def_s; assumption).

      assert (Hnodup_frd : NoDup frd) by (rewrite <- Hperm_fs; assumption).

      assert (Hequiv_frd : forall t : Trans, In t frd <-> In t (fired s))
        by (intros t; rewrite Hperm_fs; reflexivity).

      intros x; destruct x.

      assert (Heq_presum : pre_sum sitpn p frd = pre_sum sitpn p (fired s))
        by (apply (pre_sum_eq_iff_incl sitpn p frd (fired s) Hnodup_frd Hnodup_fs Hequiv_frd)).

      assert (Heq_postsum : post_sum sitpn p frd = post_sum sitpn p (fired s))
        by (apply (post_sum_eq_iff_incl sitpn p frd (fired s) Hnodup_frd Hnodup_fs Hequiv_frd)).

      split; intros Hin.

      - (* Builds In (p, x) m, then specializes Hdef_tm and Hdef_fm to
           get In (p, n - pre + post) final_marking *)

        specialize (in_fst_split p n final_marking Hin) as Hin_fsfm_ex.
        unfold fs in Heq_fsfm_fsm.
        rewrite Heq_fsfm_fsm in Hin_fsfm_ex.
        apply in_fst_split_in_pair in Hin_fsfm_ex.

        inversion_clear Hin_fsfm_ex as (x & Hin_m).

        (* Specializes Hdef_tm then Hdef_fm. *)

        specialize (Hdef_tm p x Hin_m) as Hin_tm.
        specialize (Hdef_fm p (x - pre_sum sitpn p frd) Hin_tm) as Hin_fm.

        (* Gets Sitpn semantics rule about definition of (marking s'), then deduces
           In (p, n - pre + post) (marking s') from it. *)

        inversion Hspec; clear H H0 H1 H2 H4 H5 H6 H7 H8 H9 H10 H11.
        rename H3 into Hdef_ms'.

        assert (Hin_ms : In (p, x) (marking s)) by (rewrite Hperm_ms; assumption).

        specialize (Hdef_ms' p x Hin_ms) as Hin_ms'.

        (* Gets (n = x - pre + post) by specializing nodup_same_pair. *)

        assert (Hnodup_fsfm : NoDup (fst (split final_marking))).
        {
          explode_well_defined_sitpn.
          explode_well_defined_sitpn_state Hwell_def_s.
          unfold NoDupPlaces in Hnodup_places.
          rewrite Hwf_state_marking in Hnodup_places.
          assert (Hnodup_fsms : NoDup (fs (marking s))) by (unfold fs; assumption).
          rewrite Hperm_ms in Hnodup_fsms.
          unfold fs in Hnodup_fsms.
          rewrite <- Heq_fsfm_fsm in Hnodup_fsms; assumption.
        }

        assert (Hfst_eq : fst (p, n) = fst (p, x - pre_sum sitpn p frd + post_sum sitpn p frd))
          by (simpl; reflexivity).

        specialize (nodup_same_pair
                      final_marking Hnodup_fsfm
                      (p, n)
                      (p, x - pre_sum sitpn p frd + post_sum sitpn p frd)
                      Hin Hin_fm Hfst_eq)
          as Heq_pair.
        injection Heq_pair as Heq_nx.
        rewrite Heq_nx.

        (* Rewrites pre_sum frd and post_sum frd with pre_sum (fired s)
           and post_sum (fired s) *)

        rewrite Heq_presum, Heq_postsum; assumption.

      - (* Builds In (p, x) (marking s), then specializes hyp. from Hspec to
           get In (p, n - pre + post) (marking s') *)

        specialize (in_fst_split p n (marking s') Hin) as Hin_fsm_ex.
        rewrite <- Heq_fsm_fsm' in Hin_fsm_ex.
        apply in_fst_split_in_pair in Hin_fsm_ex.

        inversion_clear Hin_fsm_ex as (x & Hin_ms).

        (* Gets Sitpn semantics rule about definition of (marking s'), then deduces
           In (p, n - pre + post) (marking s') from it. *)

        inversion Hspec; clear H H0 H1 H2 H4 H5 H6 H7 H8 H9 H10 H11.
        rename H3 into Hdef_ms'.

        specialize (Hdef_ms' p x Hin_ms) as Hin_ms'.

        (* Gets (n = x - pre + post) by specializing
           nodup_same_pair. *)

        assert (Hnodup_fs_ms' : NoDup (fst (split (marking s')))).
        {
          explode_well_defined_sitpn.
          explode_well_defined_sitpn_state Hwell_def_s'.
          unfold NoDupPlaces in Hnodup_places.
          rewrite Hwf_state_marking in Hnodup_places.
          assumption.
        }

        assert (Hfst_eq : fst (p, n) = fst (p, x - pre_sum sitpn p (fired s) + post_sum sitpn p (fired s)))
          by (simpl; reflexivity).

        specialize (nodup_same_pair
                      (marking s') Hnodup_fs_ms'
                      (p, n)
                      (p, x - pre_sum sitpn p (fired s) + post_sum sitpn p (fired s))
                      Hin Hin_ms' Hfst_eq)
          as Heq_pair.
        injection Heq_pair as Heq_nx.
        rewrite Heq_nx.

        (* Specializes Hdef_tm then Hdef_fm to get
           In (p, x - pre + post) final_marking *)

        assert (Hin_m : In (p, x) m) by (rewrite <- Hperm_ms; assumption).
        specialize (Hdef_tm p x Hin_m) as Hin_tm.
        specialize (Hdef_fm p (x - pre_sum sitpn p frd) Hin_tm) as Hin_fm.

        (* Rewrites pre_sum frd and post_sum frd with
           pre_sum (fired s) and post_sum (fired s) *)

        rewrite <- Heq_presum, <- Heq_postsum; assumption.
    }

    apply (NoDup_Permutation Hnodup_fm Hnodup_ms' Hequiv_fm_ms').
  Qed.

End MapUpdateMarkingComplete.


From Undecidability.L.Tactics Require Import LTactics.
From Undecidability.L Require Import UpToC.
From Undecidability.L.Datatypes Require Export List.List_enc LNat LOptions LBool.

Set Default Proof Using "Type".

Definition c__ntherror := 15.
Definition nth_error_time (X : Type) (A : list X) (n : nat) := (min (length A) n + 1) * c__ntherror.
Instance termT_nth_error (X:Type) (Hx : registered X): computableTime' (@nth_error X) (fun l _ => (5, fun n _ => (nth_error_time l n, tt))).
Proof.
  extract. solverec. all: unfold nth_error_time, c__ntherror; solverec.
Qed.

Definition c__length := 11.
Instance termT_length X `{registered X} : computableTime' (@length X) (fun A _ => (c__length * (1 + |A|),tt)).
Proof.
extract. solverec. all: unfold c__length; solverec.
Qed.

Instance term_nth X (Hx : registered X) : computableTime' (@nth X) (fun n _ => (5,fun l lT => (1,fun d _ => (n*20+9,tt)))).
Proof.
  extract.
  solverec.
Qed.

Instance term_repeat A `{registered A}: computableTime' (@repeat A) (fun _ _ => (5, fun n _ => (n * 12 + 4,tt))).
Proof.
  extract. solverec.
Qed.

Section Fix_X.
  Context {X:Type} {intX : registered X}.

  Variable X_eqb : X -> X -> bool.
  Hypothesis X_eqb_spec : (forall (x y:X), Bool.reflect (x=y) (X_eqb x y)).

  Definition pos_nondec :=
    fix pos_nondec (eqb: X -> X -> bool) (s : X) (A : list X) {struct A} : option nat :=
      match A with
      | [] => None
      | a :: A0 =>
        if eqb s a
        then Some 0
        else match pos_nondec eqb s A0 with
            | Some n => Some (S n)
            | None => None
            end
      end.

  Lemma pos_nondec_spec (x:X) `{eq_dec X} A: pos_nondec X_eqb x A = pos x A.
  Proof using X_eqb_spec.
    induction A;[reflexivity|];cbn.
    rewrite IHA. destruct (X_eqb_spec x a); repeat (destruct _; try congruence).
  Defined. (* because other extract *)

  Global Instance term_pos_nondec:
    computable pos_nondec.
  Proof.
    extract.
  Defined. (* because other extract *)
End Fix_X.


(**************************************************************************)
(*  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.                          *)
(*                                                                        *)
(**************************************************************************)

(**r: equivalence between bpf.model (with formal syntax + semantics) and bpf.src (for dx) *)

From Coq Require Import Logic.FunctionalExtensionality ZArith Lia List.
Import ListNotations.
From compcert Require Import Integers Values Memory Memdata.

From bpf.comm Require Import State Monad LemmaNat rBPFMonadOp.

From bpf.model Require Import Semantics.
From bpf.monadicmodel Require Import Opcode rBPFInterpreter.

(*
From bpf.equivalence Require Import switch decode_if. *)

Open Scope Z_scope.

Lemma Hrepr_eq: forall (a b:Z), (0 <= a <= 255)%Z -> (0 <= b <= 255)%Z ->
  Int.repr a = Int.repr b <-> a = b.
Proof.
  intros.
  split; intro.
  Transparent Int.repr.
  unfold Int.repr in *.
  inversion H1.
  rewrite ! Int.Z_mod_modulus_eq in H3.
  change Int.modulus with 4294967296%Z in H3.
  rewrite ! Z.mod_small in H3.
  all: try lia.

  rewrite H1; reflexivity.
Qed.

Lemma Hrepr_neq: forall (a b:Z), (0 <= a <= 255)%Z -> (0 <= b <= 255)%Z ->
  Int.repr a <> Int.repr b <-> a <> b.
Proof.
  intros.
  split; intro.
  intro.
  apply H1.
  rewrite H2; reflexivity.
  intro.
  apply H1.
  Transparent Int.repr.
  unfold Int.repr in *.
  inversion H2.
  rewrite ! Int.Z_mod_modulus_eq in H4.
  change Int.modulus with 4294967296%Z in H4.
  rewrite ! Z.mod_small in H4.
  all: lia.
Qed.

Open Scope nat_scope.

Lemma equivalence_between_check_mem:
  forall st p ck v,
    Semantics.check_mem p ck v st =rBPFInterpreter.check_mem p ck v st.
Proof.
  intros.
  unfold Semantics.check_mem, check_mem.
  unfold Semantics.is_well_chunk_bool, is_well_chunk_bool.
  unfold bindM, returnM.
  destruct ck; try reflexivity.
Qed.

Lemma equivalence_between_Semantics_and_rBPFInterpreter:
  Semantics.step = rBPFInterpreter.step.
Proof.
  unfold Semantics.step, rBPFInterpreter.step.
  unfold bindM, returnM.
  apply functional_extensionality.

  intros.
  destruct eval_pc; [|reflexivity].
  destruct p.
  destruct eval_ins; [|reflexivity].
  destruct p.
  unfold decodeM, Decode.decode.

  unfold get_opcode_ins,get_opcode, BinrBPF.get_opcode, byte_to_opcode, get_dst, int64_to_dst_reg.
  unfold eval_reg, get_src64.

  unfold bindM, returnM.

  destruct BinrBPF.int64_to_dst_reg'; [| reflexivity].

  remember (Z.to_nat (Int64.unsigned (Int64.and i0 (Int64.repr 255)))) as ins.
  assert (Hins_255: ins <= 255). {
    rewrite Heqins.
    unfold Int64.and.

    assert (Heq: (Int64.unsigned i0) = Z.of_nat (Z.to_nat(Int64.unsigned i0))). {
      rewrite Z2Nat.id.
      reflexivity.
      assert (Hrange: (0 <= Int64.unsigned i0 < Int64.modulus)%Z) by apply Int64.unsigned_range.
      lia.
    }
    rewrite Heq; clear.
    change (Int64.unsigned (Int64.repr 255)) with (Z.of_nat (Z.to_nat 255%Z)) at 1.
    rewrite LemmaNat.land_land.
    assert (H: (Nat.land (Z.to_nat (Int64.unsigned i0)) (Z.to_nat 255)) <= 255%nat). {
      rewrite Nat.land_comm.
      rewrite LemmaNat.land_bound.
      lia.
    }
    rewrite Int64.unsigned_repr; [ | change Int64.max_unsigned with 18446744073709551615%Z; lia].
    lia.
  }

  assert (Heq_int_iff: Int.eq Int.zero (Int.and (Int.repr (Z.of_nat ins)) (Int.repr 8)) = (0 =? Nat.land ins  8)). {
    assert (Hrange: Nat.land ins 8 <= 8).
    rewrite Nat.land_comm.
    rewrite land_bound. lia.
    unfold Int.and, Int.zero.
    rewrite Int.unsigned_repr; [| change Int.max_unsigned with 4294967295%Z; lia].
    change (Int.unsigned (Int.repr 8)) with (Z.of_nat (Z.to_nat 8%Z)).
    rewrite land_land.
    change (Z.to_nat 8%Z) with 8.
    destruct (0 =? Nat.land ins 8) eqn: Heq; [rewrite Nat.eqb_eq in Heq | rewrite Nat.eqb_neq in Heq].
    rewrite Syntax.Int_eq_true.
    apply Hrepr_eq. all: try lia.

    rewrite Syntax.Int_eq_false.
    apply Hrepr_neq. all: try lia.
  }

Ltac or_simpl Hand :=
  match goal with
  | H: ?X = Nat.land ?Y ?Z |- ?W = ?Y \/ _ =>
    destruct (W =? Y) eqn: Hand; [rewrite Nat.eqb_eq in Hand; left; assumption | rewrite Nat.eqb_neq in Hand; right ]
  end.

Ltac nat_land_compute :=
  match goal with
  | |- context [Nat.land ?X ?Y] =>
    let res := eval compute in (Nat.land X Y) in
      change (Nat.land X Y) with res; simpl
  end.

Ltac destruct_match :=
  match goal with
  | |- ?X = ?X => reflexivity
  | |- context[match match ?X with | _ => _ end with | _ => _ end] =>
    destruct X; [ try reflexivity; try destruct_match | reflexivity]
  | |- context[match match ?X with | _ => _ end with | _ => _ end] =>
    destruct X; try reflexivity; try destruct_match
  end.

Ltac nat_land_computeH :=
  match goal with
  | H: 0 <> Nat.land ?X ?Y |- _ =>
    let res := eval compute in (Nat.land X Y) in
      change (Nat.land X Y) with res in H; exfalso; apply H; reflexivity
  end.

  unfold reg64_to_reg32, State.eval_reg, get_src32, get_immediate, get_src, rBPFValues.sint32_to_vint, BinrBPF.get_immediate, rBPFValues.int64_to_sint32, int64_to_src_reg, eval_reg, reg64_to_reg32, bindM, returnM.
  unfold Decode.get_instruction_alu32_imm, Decode.get_instruction_alu32_reg.
  unfold step_opcode_alu32, get_opcode_alu32, byte_to_opcode_alu32, step_alu_binary_operation,eval_reg32, eval_src32, eval_reg, upd_reg, rBPFValues.val_intuoflongu, rBPFValues.val32_divu, rBPFValues.val32_modu, State.eval_reg, bindM, returnM.
    rewrite Heq_int_iff. clear Heqins Heq_int_iff.
    remember (Int.repr (Int64.unsigned (Int64.shru i0 (Int64.repr 32)))) as imm.

  destruct (Nat.land ins 7 =? 0) eqn: Hland0; [rewrite Nat.eqb_eq in Hland0; rewrite Hland0 | rewrite Nat.eqb_neq in Hland0].
  {
    rewrite nat_land_7_eq in Hland0; [| lia].
    destruct Hland0 as (m & Hins_eq).
    rewrite Hins_eq in *.
    unfold Decode.get_instruction_ld, step_opcode_mem_ld_imm, eval_ins_len, get_opcode_mem_ld_imm, byte_to_opcode_mem_ld_imm, eval_ins, get_immediate, upd_pc_incr,
      bindM, returnM.
    rewrite ! Nat.add_0_l in *.
    do 32 (destruct m; [nat_land_compute; try reflexivity | ]).
    destruct m; [nat_land_compute; try reflexivity | ].
    lia.
  }

  destruct (Nat.land ins 7 =? 1) eqn: Hland1; [rewrite Nat.eqb_eq in Hland1; rewrite Hland1 | rewrite Nat.eqb_neq in Hland1].
  {
    rewrite nat_land_7_eq in Hland1; [| lia].
    destruct Hland1 as (m & Hins_eq).
    rewrite Hins_eq in *.
    destruct BinrBPF.int64_to_src_reg'; [| reflexivity].
    unfold Decode.get_instruction_ldx, get_offset, get_addr_ofs, step_opcode_mem_ld_reg, get_opcode_mem_ld_reg, byte_to_opcode_mem_ld_reg,
      bindM, returnM.
      do 33 (destruct m; [nat_land_compute; try reflexivity | ]).
      lia.
  }

  destruct (Nat.land ins 7 =? 2) eqn: Hland2; [rewrite Nat.eqb_eq in Hland2; rewrite Hland2 | rewrite Nat.eqb_neq in Hland2].
  {
    rewrite nat_land_7_eq in Hland2; [| lia].
    destruct Hland2 as (m & Hins_eq).
    rewrite Hins_eq in *.
    unfold Decode.get_instruction_st, get_offset, get_addr_ofs, step_opcode_mem_st_imm, get_opcode_mem_st_imm, byte_to_opcode_mem_st_imm,
      bindM, returnM.
      do 33 (destruct m; [nat_land_compute; try reflexivity | ]).
      lia.
  }

  destruct (Nat.land ins 7 =? 3) eqn: Hland3; [rewrite Nat.eqb_eq in Hland3; rewrite Hland3 | rewrite Nat.eqb_neq in Hland3].
  {
    rewrite nat_land_7_eq in Hland3; [| lia].
    destruct Hland3 as (m & Hins_eq).
    rewrite Hins_eq in *.
    destruct BinrBPF.int64_to_src_reg'; [| reflexivity].
    unfold Decode.get_instruction_stx, BinrBPF.get_offset, get_offset, get_addr_ofs, step_opcode_mem_st_reg, get_opcode_mem_st_reg, byte_to_opcode_mem_st_reg,
      bindM, returnM.
      do 33 (destruct m; [nat_land_compute; try reflexivity | ]).
      lia.
  }

  destruct (Nat.land ins 7 =? 4) eqn: Hland4; [rewrite Nat.eqb_eq in Hland4; rewrite Hland4 | rewrite Nat.eqb_neq in Hland4].
  {
    rewrite nat_land_7_eq in Hland4; [| lia].
    destruct Hland4 as (m & Hins_eq).
    rewrite Hins_eq in *.

    destruct (0 =? Nat.land (4 + 8 * m) 8) eqn: Hand8; [rewrite Nat.eqb_eq in Hand8 | rewrite Nat.eqb_neq in Hand8].
    - destruct m; [nat_land_compute; destruct Val.longofintu; try reflexivity |].
      destruct m; [inversion Hand8 | ].
      destruct m; [nat_land_compute; destruct Val.longofintu; try reflexivity |].
      destruct m; [inversion Hand8 | ].
      destruct m; [nat_land_compute; destruct Val.longofintu; try reflexivity |].
      destruct m; [inversion Hand8 | ].
      destruct m.
      { nat_land_compute. destruct negb; [| reflexivity]. destruct Val.divu; try reflexivity. destruct Val.longofintu; try reflexivity. }
      destruct m; [inversion Hand8 | ].
      destruct m; [nat_land_compute; destruct Val.longofintu; try reflexivity |].
      destruct m; [inversion Hand8 | ].
      destruct m; [nat_land_compute; destruct Val.longofintu; try reflexivity |].
      destruct m; [inversion Hand8 | ].
      destruct m; [nat_land_compute; destruct Val.longofintu; try reflexivity |].
      destruct m; [inversion Hand8 | ].
      destruct m; [nat_land_compute; destruct Val.longofintu; try reflexivity |].
      destruct m; [inversion Hand8 | ].
      destruct m; [nat_land_compute; destruct Val.longofintu; try reflexivity |].
      destruct m; [inversion Hand8 | ].
      destruct m.
      { nat_land_compute. destruct negb; [| reflexivity]. destruct Val.modu; try reflexivity. destruct Val.longofintu; try reflexivity. }
      destruct m; [inversion Hand8 | ].
      destruct m; [nat_land_compute; destruct Val.longofintu; try reflexivity |].
      destruct m; [inversion Hand8 | ].
      destruct m.
      { nat_land_compute. reflexivity. }
      destruct m; [inversion Hand8 | ].
      destruct m.
      { nat_land_compute. destruct Int.ltu; [| reflexivity]. destruct Val.longofint; try reflexivity. }
      destruct m; [inversion Hand8 | ].
      destruct m.
      { nat_land_compute. reflexivity. }
      destruct m; [inversion Hand8 | ].
      destruct m.
      { nat_land_compute. reflexivity. }
      destruct m; [inversion Hand8 | ].
      destruct m.
      { nat_land_compute. reflexivity. }
      destruct m; [inversion Hand8 | ].
      lia.
    - destruct BinrBPF.int64_to_src_reg'; [| reflexivity].

      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. destruct Val.longofintu; try reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. destruct Val.longofintu; try reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. destruct Val.longofintu; try reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. destruct rBPFValues.comp_ne_32; [| reflexivity]. destruct Val.divu; try reflexivity. destruct Val.longofintu; try reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. destruct Val.longofintu; try reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. destruct Val.longofintu; try reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. destruct Val.longofintu; try reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. destruct Val.longofintu; try reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. destruct rBPFValues.comp_ne_32; [| reflexivity]. destruct Val.modu; try reflexivity. destruct Val.longofintu; try reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. destruct Val.longofintu; try reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. destruct Val.longofintu; try reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. destruct rBPFValues.compu_lt_32; [| reflexivity]. destruct Val.longofint; try reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. reflexivity. }
      destruct m; [nat_land_computeH |].
      lia.
  }

Ltac destruct_if_reflexivity :=
  match goal with
  | |- ?X = ?X => reflexivity
  | |- context[(if ?X then _ else _) ] =>
    destruct X; try reflexivity
  end.

  destruct (Nat.land ins 7 =? 5) eqn: Hland5; [rewrite Nat.eqb_eq in Hland5; rewrite Hland5 | rewrite Nat.eqb_neq in Hland5].
  {
    rewrite nat_land_7_eq in Hland5; [| lia].
    destruct Hland5 as (m & Hins_eq).
    rewrite Hins_eq in *.
    unfold Decode.get_instruction_branch_imm, BinrBPF.get_offset, Decode.get_instruction_branch_reg, get_offset, eval_immediate, step_opcode_branch, get_opcode_branch, byte_to_opcode_branch, upd_pc, BinrBPF.get_offset, upd_flag,
      bindM, returnM.

    destruct (0 =? Nat.land (5 + 8 * m) 8) eqn: Hand8; [rewrite Nat.eqb_eq in Hand8 | rewrite Nat.eqb_neq in Hand8].
    - destruct m; [nat_land_compute; destruct_if_reflexivity | ].
      destruct m; [nat_land_compute; destruct_if_reflexivity | ].
      destruct m; [nat_land_compute; unfold State.eval_reg; destruct_if_reflexivity; destruct_if_reflexivity | ].
      destruct m; [inversion Hand8 | ].
      destruct m; [nat_land_compute; unfold State.eval_reg; destruct_if_reflexivity; destruct_if_reflexivity | ].
      destruct m; [inversion Hand8 | ].
      destruct m; [nat_land_compute; unfold State.eval_reg; destruct_if_reflexivity; destruct_if_reflexivity | ].
      destruct m; [inversion Hand8 | ].
      destruct m; [nat_land_compute; unfold State.eval_reg; destruct_if_reflexivity; destruct_if_reflexivity | ].
      destruct m; [inversion Hand8 | ].
      destruct m; [nat_land_compute; unfold State.eval_reg; destruct_if_reflexivity; destruct_if_reflexivity | ].
      destruct m; [inversion Hand8 | ].
      destruct m; [nat_land_compute; unfold State.eval_reg; destruct_if_reflexivity; destruct_if_reflexivity | ].
      destruct m; [inversion Hand8 | ].
      destruct m; [nat_land_compute; unfold State.eval_reg; destruct_if_reflexivity; destruct_if_reflexivity | ].
      destruct m; [inversion Hand8 | ].
      destruct m; [nat_land_compute | ]. destruct _bpf_get_call; try reflexivity.
      destruct m; [inversion Hand8 | ].
      destruct m; [nat_land_compute; unfold State.eval_reg; destruct_if_reflexivity; destruct_if_reflexivity | ].
      destruct m; [inversion Hand8 | ].
      destruct m; [nat_land_compute; unfold State.eval_reg; destruct_if_reflexivity; destruct_if_reflexivity | ].
      destruct m; [inversion Hand8 | ].
      destruct m; [nat_land_compute; unfold State.eval_reg; destruct_if_reflexivity; destruct_if_reflexivity | ].
      destruct m; [inversion Hand8 | ].
      destruct m; [nat_land_compute; unfold State.eval_reg; destruct_if_reflexivity; destruct_if_reflexivity | ].
      destruct m; [inversion Hand8 | ].
      destruct m; [nat_land_compute; unfold State.eval_reg; destruct_if_reflexivity; destruct_if_reflexivity | ].
      destruct m; [inversion Hand8 | ].
      destruct m; [nat_land_compute; unfold State.eval_reg; destruct_if_reflexivity; destruct_if_reflexivity | ].
      destruct m; [inversion Hand8 | ].
      destruct m; [nat_land_compute; unfold State.eval_reg; destruct_if_reflexivity; destruct_if_reflexivity | ].
      destruct m; [inversion Hand8 | ].
      lia.
    - destruct BinrBPF.int64_to_src_reg'; [| reflexivity].

      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute; unfold State.eval_reg; destruct_if_reflexivity; destruct_if_reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute; unfold State.eval_reg; destruct_if_reflexivity; destruct_if_reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute; unfold State.eval_reg; destruct_if_reflexivity; destruct_if_reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute; unfold State.eval_reg; destruct_if_reflexivity; destruct_if_reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute; unfold State.eval_reg; destruct_if_reflexivity; destruct_if_reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute; unfold State.eval_reg; destruct_if_reflexivity; destruct_if_reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute; unfold State.eval_reg; destruct_if_reflexivity; destruct_if_reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute; unfold State.eval_reg; destruct_if_reflexivity; destruct_if_reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute; unfold State.eval_reg; destruct_if_reflexivity; destruct_if_reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute; unfold State.eval_reg; destruct_if_reflexivity; destruct_if_reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute; unfold State.eval_reg; destruct_if_reflexivity; destruct_if_reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute; unfold State.eval_reg; destruct_if_reflexivity; destruct_if_reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. reflexivity. }
      destruct m; [nat_land_computeH |].
      lia.
  }

  destruct (Nat.land ins 7 =? 6) eqn: Hland6; [rewrite Nat.eqb_eq in Hland6; rewrite Hland6 | rewrite Nat.eqb_neq in Hland6].
  {
    rewrite nat_land_7_eq in Hland6; [| lia].
    destruct Hland6 as (m & Hins_eq).
    rewrite Hins_eq in *.
    reflexivity.
  }

  destruct (Nat.land ins 7 =? 7) eqn: Hland7; [rewrite Nat.eqb_eq in Hland7; rewrite Hland7 | rewrite Nat.eqb_neq in Hland7].
  {
    rewrite nat_land_7_eq in Hland7; [| lia].
    destruct Hland7 as (m & Hins_eq).
    rewrite Hins_eq in *.
    unfold Decode.get_instruction_alu64_imm, Decode.get_instruction_alu64_reg, eval_immediate, step_opcode_alu64, get_opcode_alu64, byte_to_opcode_alu64, upd_reg, rBPFValues.val64_divlu, rBPFValues.val64_modlu,
      bindM, returnM.

    destruct (0 =? Nat.land (7 + 8 * m) 8) eqn: Hand8; [rewrite Nat.eqb_eq in Hand8 | rewrite Nat.eqb_neq in Hand8].
    - destruct m; [nat_land_compute; destruct Val.addl; try reflexivity |].
      destruct m; [inversion Hand8 | ].
      destruct m; [nat_land_compute; destruct Val.subl; try reflexivity |].
      destruct m; [inversion Hand8 | ].
      destruct m; [nat_land_compute; destruct Val.mull; try reflexivity |].
      destruct m; [inversion Hand8 | ].
      destruct m.
      { nat_land_compute. destruct_if_reflexivity. destruct Val.divlu; try reflexivity. destruct v; try reflexivity. }
      destruct m; [inversion Hand8 | ].
      destruct m; [nat_land_compute; destruct Val.orl; try reflexivity |].
      destruct m; [inversion Hand8 | ].
      destruct m; [nat_land_compute; destruct Val.andl; try reflexivity |].
      destruct m; [inversion Hand8 | ].
      destruct m.
      { nat_land_compute. destruct_if_reflexivity. destruct Val.shll; try reflexivity. }
      destruct m; [inversion Hand8 | ].
      destruct m.
      { nat_land_compute. destruct_if_reflexivity. destruct Val.shrlu; try reflexivity. }
      destruct m; [inversion Hand8 | ].
      destruct m; [nat_land_compute; destruct Val.negl; try reflexivity |].
      destruct m; [inversion Hand8 | ].
      destruct m.
      { nat_land_compute. destruct_if_reflexivity. destruct Val.modlu; try reflexivity. destruct v; try reflexivity. }
      destruct m; [inversion Hand8 | ].
      destruct m; [nat_land_compute; destruct Val.xorl; try reflexivity |].
      destruct m; [inversion Hand8 | ].
      destruct m.
      { nat_land_compute. reflexivity. }
      destruct m; [inversion Hand8 | ].
      destruct m.
      { nat_land_compute. destruct_if_reflexivity. destruct Val.shrl; try reflexivity. }
      destruct m; [inversion Hand8 | ].
      destruct m.
      { nat_land_compute. reflexivity. }
      destruct m; [inversion Hand8 | ].
      destruct m.
      { nat_land_compute. reflexivity. }
      destruct m; [inversion Hand8 | ].
      destruct m.
      { nat_land_compute. reflexivity. }
      destruct m; [inversion Hand8 | ].
      lia.
    - destruct BinrBPF.int64_to_src_reg'; [| reflexivity].

      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. destruct Val.addl; try reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. destruct Val.subl; try reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. destruct Val.mull; try reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. unfold State.eval_reg, Regs.val64_zero; destruct_if_reflexivity. destruct Val.divlu; try reflexivity. destruct v; try reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. destruct Val.orl; try reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. destruct Val.andl; try reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. unfold State.eval_reg, rBPFValues.val_intuoflongu; destruct_if_reflexivity. destruct Val.shll; try reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute.  unfold State.eval_reg, rBPFValues.val_intuoflongu; destruct_if_reflexivity. destruct Val.shrlu; try reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. unfold State.eval_reg, Regs.val64_zero; destruct_if_reflexivity. destruct Val.modlu; try reflexivity. destruct v; try reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. destruct Val.xorl; try reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. unfold State.eval_reg. destruct Regs.eval_regmap; try reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. unfold State.eval_reg, rBPFValues.val_intuoflongu; destruct_if_reflexivity. destruct Val.shrl; try reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. reflexivity. }
      destruct m; [nat_land_computeH |].
      destruct m.
      { nat_land_compute. reflexivity. }
      destruct m; [nat_land_computeH |].
      lia.
  }

  exfalso.

  remember (Nat.land ins 7) as Hand7.
  assert (Hand7_le: Hand7 <= 7). {
    rewrite HeqHand7.
    rewrite Nat.land_comm.
    rewrite land_bound.
    lia.
  }

  lia.
Qed.

Close Scope nat_scope.

Lemma equivalence_between_formal_and_dx_aux:
  forall f,
    Semantics.bpf_interpreter_aux f = rBPFInterpreter.bpf_interpreter_aux f.
Proof.
  unfold Semantics.bpf_interpreter_aux, rBPFInterpreter.bpf_interpreter_aux.
  rewrite equivalence_between_Semantics_and_rBPFInterpreter.
  reflexivity.
Qed.

Theorem equivalence_between_formal_and_dx:
  forall f,
    Semantics.bpf_interpreter f = rBPFInterpreter.bpf_interpreter f.
Proof.
  intros.
  unfold Semantics.bpf_interpreter, rBPFInterpreter.bpf_interpreter.
  rewrite equivalence_between_formal_and_dx_aux.
  reflexivity.
Qed.

Close Scope Z_scope.


Load "IND_MORPHISMS".

(***********Indistinguishability Axioms*******************************************)
(************************************************************************************)

(*********************FUNCApp***************************************************)
(*******************************************************************************)

 Section  Core_Axioms.
Variable fmb4 : message -> message -> message -> message -> Bool.
Variable fm: message.
Variable fb: Bool.
Variable f1 : message  -> message.
Variable f2b : message  -> message -> Bool.
Variable f2m : message ->  message -> message.
Variable f3b: message -> message -> message -> Bool.
Variable f3bm: Bool -> message -> message -> message.
Variable f3m : message -> message -> message -> message .
Variable f4b: message -> message -> message -> message -> Bool.
Variable f4m: message -> message -> message -> message -> message.
Variable g2: Bool -> Bool -> Bool.
Variable g3 : Bool -> Bool -> Bool -> Bool.
 (*************************************************************************************************)
Axiom FUNCApp_att4: forall (p1 p2 p3 p4 : nat) {n} (ml1 ml2 : mylist n), (ml1 ~ ml2 ) -> (ml1 ++ [ bol (fmb4 (ostomsg (getelt_at_pos p1 ml1)) (ostomsg (getelt_at_pos  p2 ml1)) (ostomsg (getelt_at_pos  p3 ml1)) (ostomsg (getelt_at_pos  p4 ml1)))] )
 ~ (ml2 ++ [ bol (fmb4 (ostomsg (getelt_at_pos  p1 ml2)) (ostomsg (getelt_at_pos p2 ml2)) (ostomsg (getelt_at_pos  p3 ml2)) (ostomsg (getelt_at_pos p4 ml2)))] ).

Axiom FUNCApp_fm: forall  {n} (ml1 ml2 : mylist n), (ml1 ~ ml2 ) -> (ml1 ++ [ msg  fm] )
 ~ (ml2 ++ [ msg fm] ).
Axiom FUNCApp_fb: forall  {n} (ml1 ml2 : mylist n), (ml1 ~ ml2 ) -> (ml1 ++ [ bol  fb] )
 ~ (ml2 ++ [ bol fb] ).

Axiom FUNCApp_f1: forall (p:nat) {n} (ml1 ml2 : mylist n), (ml1 ~ ml2 ) -> (ml1 ++ [ msg  (f1 (ostomsg (getelt_at_pos p ml1)))] ) ~ (ml2 ++ [ msg  (f1 (ostomsg (getelt_at_pos p ml2)))] ).

Axiom FUNCApp_f2b: forall (p1 p2 :nat) {n} (ml1 ml2 : mylist n), (ml1 ~ ml2 ) -> (ml1 ++ [ bol  (f2b (ostomsg (getelt_at_pos p1 ml1)) (ostomsg (getelt_at_pos p2 ml1)))] ) ~ (ml2 ++ [ bol  (f2b (ostomsg (getelt_at_pos p1 ml2)) (ostomsg (getelt_at_pos p2 ml2)))] ).

Axiom FUNCApp_f2m: forall (p1 p2 :nat) {n} (ml1 ml2 : mylist n), (ml1 ~ ml2 ) -> (ml1 ++ [ msg  (f2m (ostomsg (getelt_at_pos p1 ml1)) (ostomsg (getelt_at_pos p2 ml1)))] ) ~ (ml2 ++ [ msg (f2m (ostomsg (getelt_at_pos p1 ml2)) (ostomsg (getelt_at_pos p2 ml2)))] ).

 Axiom FUNCApp_f3b: forall (p1 p2 p3 :nat) {n} (ml1 ml2 : mylist n), (ml1 ~ ml2 ) -> (ml1 ++ [ bol  (f3b (ostomsg (getelt_at_pos p1 ml1)) (ostomsg (getelt_at_pos p2 ml1)) (ostomsg (getelt_at_pos p3 ml1)))] ) ~ (ml2 ++ [ bol  (f3b (ostomsg (getelt_at_pos p1 ml2)) (ostomsg (getelt_at_pos p2 ml2)) (ostomsg (getelt_at_pos p3 ml2)))] ).

 Axiom FUNCApp_f3bm: forall (p1 p2 p3 :nat) {n} (ml1 ml2 : mylist n), (ml1 ~ ml2 ) -> (ml1 ++ [ msg  (f3bm (ostobol (getelt_at_pos p1 ml1)) (ostomsg (getelt_at_pos p2 ml1)) (ostomsg (getelt_at_pos p3 ml1)))] ) ~ (ml2 ++ [ msg  (f3bm (ostobol (getelt_at_pos p1 ml2)) (ostomsg (getelt_at_pos p2 ml2)) (ostomsg (getelt_at_pos p3 ml2)))] ).

 Axiom FUNCApp_f3m: forall (p1 p2 p3 :nat) {n} (ml1 ml2 : mylist n), (ml1 ~ ml2 ) -> (ml1 ++ [ msg  (f3m (ostomsg (getelt_at_pos p1 ml1)) (ostomsg (getelt_at_pos p2 ml1)) (ostomsg (getelt_at_pos p3 ml1)))] ) ~ (ml2 ++ [ msg  (f3m (ostomsg (getelt_at_pos p1 ml2)) (ostomsg (getelt_at_pos p2 ml2)) (ostomsg (getelt_at_pos p3 ml2)))] ).

Axiom FUNCApp_f4b: forall (p1 p2 p3 p4 :nat) {n} (ml1 ml2 : mylist n), (ml1 ~ ml2 ) -> (ml1 ++ [ bol  (f4b (ostomsg (getelt_at_pos p1 ml1)) (ostomsg (getelt_at_pos p2 ml1)) (ostomsg (getelt_at_pos p3 ml1)) (ostomsg (getelt_at_pos p4 ml1)))] ) ~ (ml2 ++  [ bol  (f4b (ostomsg (getelt_at_pos p1 ml2)) (ostomsg (getelt_at_pos p2 ml2)) (ostomsg (getelt_at_pos p3 ml2)) (ostomsg (getelt_at_pos p4 ml2)))] ).

Axiom FUNCApp_f4m: forall (p1 p2 p3 p4 :nat) {n} (ml1 ml2 : mylist n), (ml1 ~ ml2 ) -> (ml1 ++ [ msg  (f4m (ostomsg (getelt_at_pos p1 ml1)) (ostomsg (getelt_at_pos p2 ml1)) (ostomsg (getelt_at_pos p3 ml1)) (ostomsg (getelt_at_pos p4 ml1)))] ) ~ (ml2 ++  [ msg  (f4m (ostomsg (getelt_at_pos p1 ml2)) (ostomsg (getelt_at_pos p2 ml2)) (ostomsg (getelt_at_pos p3 ml2)) (ostomsg (getelt_at_pos p4 ml2)))] ).
Axiom FUNCApp_g2: forall (p1 p2 :nat) {n} (ml1 ml2 : mylist n), (ml1 ~ ml2 ) -> (ml1 ++ [ bol  (g2 (ostobol (getelt_at_pos p1 ml1)) (ostobol (getelt_at_pos p2 ml1)))] ) ~ (ml2 ++ [ bol  (g2 (ostobol (getelt_at_pos p1 ml2)) (ostobol (getelt_at_pos p2 ml2)))] ).

 Axiom FUNCApp_g3: forall (p1 p2 p3 :nat) {n} (ml1 ml2 : mylist n), (ml1 ~ ml2 ) -> (ml1 ++ [ bol  (g3 (ostobol (getelt_at_pos p1 ml1)) (ostobol (getelt_at_pos p2 ml1)) (ostobol (getelt_at_pos p3 ml1)))] ) ~ (ml2 ++ [ bol  (g3 (ostobol (getelt_at_pos p1 ml2)) (ostobol (getelt_at_pos p2 ml2)) (ostobol (getelt_at_pos p3 ml2)))] ).
Axiom FUNCApp_sublist:  forall (m n:nat) {n1} (ml1 ml2:mylist n1), (ml1 ~ ml2) -> (ml1 ++ [msg (f  (sublist m n (conv_mylist_listm ml1)))]) ~ (ml2 ++ [msg (f (sublist m n (conv_mylist_listm ml2)))]).

(**************************************************************************************************)
Axiom FUNCApp_const: forall (n m :nat) (ml1 ml2: mylist n) (a: mylist m), (ml1 ~ ml2) -> (ml1 ++ (const  a ml1 )) ~ (ml2 ++ (const a ml2)).

Axiom FUNCApp_appelt:  forall (n p :nat) (ml1 ml2: mylist n), (ml1 ~ ml2) -> (ml1 ++ [getelt_at_pos  p ml1]  ) ~ (ml2 ++ [getelt_at_pos  p ml2]).

Axiom FUNCApp_EQ_M: forall (p1 p2:nat) {n} (ml1 ml2: mylist n), (ml1 ~ ml2) -> (ml1 ++ ([ bol (EQ_M_at_pos  p1 p2 ml1) ])) ~ (ml2 ++ ([ bol (EQ_M_at_pos  p1 p2 ml2)])).
(**
Axiom FUNCApp_EQ_M1: forall (p p1 p2  :nat) {n}(ml1 ml2 :mylist n), (ml1 ~ ml2) -> (@insert_at_pos p  ( bol (EQ_M_at_pos (msg O) p1 p2 ml1)) n  ml1) ~ (@insert_at_pos p ( bol (EQ_M_at_pos (msg O) p1 p2 ml2)) n ml2). **)
Axiom FUNCApp_EQ_B: forall ( p1 p2:nat) {n} (ml1 ml2: mylist n), (ml1 ~ ml2) ->  (ml1 ++  [ bol (EQ_B_at_pos  p1 p2 ml1)])  ~ (ml2 ++  [ bol (EQ_B_at_pos  p1 p2 ml2)])  .

(**Axiom FUNCApp_EQ_B1: forall ( p p1 p2:nat) {n} (ml1 ml2: mylist n), (ml1 ~ ml2) ->  (@insert_at_pos p  ( bol (EQ_B_at_pos (bol TRue) p1 p2 ml1)) n  ml1)  ~ (@insert_at_pos p  ( bol (EQ_B_at_pos (bol TRue) p1 p2 ml1)) n  ml2) .**)

Axiom FUNCApp_negpos: forall (p :nat) {n} (ml1 ml2: mylist n), (ml1 ~ ml2) -> (ml1 ++ (neg_at_pos p ml1)) ~ (ml2 ++ (neg_at_pos p ml2)).

Axiom FUNCApp_ifmnespair : forall ( p1 p2 p3 p4 : nat) {n} (ml1 ml2 : mylist n), (ml1 ~ ml2) -> (ml1 ++ [msg (ifm_nespair  p1 p2 p3 p4 ml1)]) ~(ml2 ++ [msg (ifm_nespair  p1 p2 p3 p4 ml2)]).

Axiom FUNCApp_ifmpair: forall ( p1 p2 p3 p4  : nat) {n} (ml1 ml2 : mylist n), (ml1 ~ ml2) -> (ml1 ++ [msg (ifm_pair  p1 p2 p3 p4 ml1)]) ~ (ml2 ++ [ msg (ifm_pair p1 p2 p3 p4 ml2)]).

(*Axiom FUNCApp_expatpos: forall (n p p1 p2 p3 : nat) (ml1 ml2 : mylist n), (ml1 ~ ml2) -> ( app_elt_pos (msg (exp_at_pos (msg O) p1 p2 p3  ml1)) p ml1 ) ~ ( app_elt_pos (msg (exp_at_pos (msg O) p1 p2 p3  ml2)) p ml2 ) .  *)

Axiom FUNCApp_expatpos: forall (p1 p2 p3 : nat) {n} (ml1 ml2 : mylist n), (ml1 ~ ml2) -> ( ml1 ++ [msg (exp_at_pos  p1 p2 p3  ml1)]) ~ ( ml2 ++ [msg (exp_at_pos  p1 p2 p3  ml2)]) .
(**
Axiom FUNCApp_expatpos1: forall (p p1 p2 p3 : nat) {n} (ml1 ml2 : mylist n), (ml1 ~ ml2) -> ( @insert_at_pos p  (msg (exp_at_pos (msg O) p1 p2 p3  ml1)) n ml1 ) ~ ( @insert_at_pos p  (msg (exp_at_pos (msg O) p1 p2 p3  ml2)) n ml2 ).
**)

Axiom FUNCApp_att : forall {n} (ml1 ml2: mylist n) (l1 l2 :list message ), (ml1 ~ ml2) -> ([msg (f l1)] ++ ml1) ~ ([msg (f l2)] ++ ml2).

Axiom FUNCApp_reveal:  forall ( p:nat) {n} (ml1 ml2 : mylist n) , (ml1 ~ ml2) -> ([msg (reveal_at_pos p ml1)] ++ml1   ) ~ ([msg (reveal_at_pos p ml2)] ++ml2 ).

Axiom FUNCApp_to:  forall (p:nat) {n} (ml1 ml2 : mylist n) , (ml1 ~ ml2) -> ([msg (to_at_pos p ml1)] ++ ml1)  ~ ([msg (to_at_pos p ml2)] ++ ml2).

Axiom FUNCApp_act:  forall (p:nat) {n} (ml1 ml2 : mylist n) , (ml1 ~ ml2) -> ([msg (act_at_pos p ml1)] ++ ml1)  ~ ([msg (act_at_pos p ml2)] ++ ml2).

Axiom FUNCApp_new : forall {n} (ml1 ml2 : mylist n) , (ml1 ~ ml2) -> ([msg new ] ++ ml1) ~ ([msg new ] ++ ml2).
Axiom FUNCApp_O : forall {n} (ml1 ml2 : mylist n) , (ml1 ~ ml2) -> ( ml1 ++ [msg O]) ~ (ml2 ++ [msg O]).
Axiom FUNCApp_acc : forall {n} (ml1 ml2 : mylist n) , (ml1 ~ ml2) -> ( ml1 ++ [msg acc]) ~ (ml2 ++ [msg acc]).
Axiom FUNCApp_session : forall ( m: nat ) {n} (ml1 ml2 : mylist m) , (ml1 ~ ml2) -> ([msg (i n) ] ++ ml1) ~ ([msg (i n) ] ++ ml2).
(**
Axiom FUNCApp_andB1: forall (p p1 p2:nat)  {n}(ml1 ml2: mylist n), (ml1 ~ ml2) ->  (@insert_at_pos p  ( bol (andB_at_pos (msg O) p1 p2 ml1)) n  ml1)  ~ (@insert_at_pos p  ( bol (andB_at_pos (msg O) p1 p2 ml1)) n  ml2) .
**)
Axiom FUNCApp_andB : forall (p1 p2 :nat) {m} (ml1 ml2 : mylist m), (ml1 ~ ml2) -> (ml1 ++ [bol (andB_at_pos p1 p2 ml1)]) ~  (ml2 ++ [bol (andB_at_pos p1 p2 ml2)]).
Axiom FUNCApp_notB : forall (p :nat) {m} (ml1 ml2:mylist m), (ml1 ~ ml2) -> (ml1 ++ [bol (notB_at_pos  p ml1)]) ~ (ml2 ++ [bol (notB_at_pos p ml2)]).
Axiom FUNCApp_m : forall (p :nat) {m} (ml1 ml2:mylist m), (ml1 ~ ml2) -> ( [ msg (m_at_pos  p ml1)] ++ ml1) ~  (  [msg (m_at_pos  p ml2) ] ++ ml2).
(**
Axiom FUNCApp_exptrm : forall (p n n1:nat) {m} (ml1 ml2:mylist m), (ml1~ml2) -> ((occexp_in_mylist n n1 ml1) = true) ->  ((occexp_in_mylist n n1 ml2) = true)  -> (@insert_at_pos p ( msg (exp (G n) (g n) (r n1))) m ml1) ~ (@insert_at_pos p ( msg (exp (G n) (g n) (r n1))) m ml2).
**)
Axiom FUNCApp_elt :   forall (p p1  :nat) {m} (ml1 ml2:mylist m), (ml1~ml2) ->  (ml1 ++ [getelt_at_pos  p1 ml1 ] ) ~ (ml2 ++ [  getelt_at_pos p1 ml2]).
(*******************************add closed term at pos p***************************************)

Axiom FUNCApp_os : forall (p n :nat) (t: oursum) (ml1 ml2:mylist n),
                     ml1 ~ ml2 -> (clos_os t = true) -> (@insert_at_pos p t n ml1) ~ (@insert_at_pos p t n ml2).

(*******************RESTR******************************************************)
(******************************************************************************)

(****************** Ind closed under projections ****************)
Axiom RESTR_proj : forall ( p :nat) {m} (ml1 ml2 :mylist m), ml1 ~ ml2 -> (proj_at_pos p ml1) ~ (proj_at_pos p ml2).
(****************** Ind closed under permutations ****************)
Axiom RESTR_swap : forall (p1 p2 : nat) {n} (ml1 ml2 : mylist n), ml1~ ml2 -> (swap_mylist p1 p2 ml1) ~ (swap_mylist p1 p2 ml2).

Axiom FUNCApp_dropls: forall {n} (ml1 ml2: mylist n), ml1 ~ ml2 -> (droplastsec ml1) ~ (droplastsec ml2).
(**
Axiom FUNCApp_droplt: forall {n} (ml1 ml2: mylist n), ml1 ~ ml2 -> (droplast3rd ml1) ~ (droplast3rd ml2).

Axiom RESTR_Drop: forall (n :nat)  (ml1 ml2 : mylist n) , ml1 ~ ml2 ->  (dropone ml1) ~ (dropone ml2).
Axiom RESTR1 : forall (n m:nat)  (l1 l1' : mylist n) (l2 l2': mylist m) (x y: oursum), (l1 ++ [x] ++l2) ~ (l1'++ [y]++l2') -> (l1 ++ l2) ~ (l1'++l2').
**)
(********************Ind closed under permutations **********************)
(**

Axiom RESTR_SWAP : forall (p1 p2 : nat) {n} (ml1 ml2 : mylist n), ml1~ ml2 -> (swap_mylist p1 p2 ml1) ~ (swap_mylist p1 p2 ml2).
Axiom RESTR_rev: forall (n:nat) (ml1 ml2: mylist n) , ml1 ~ ml2 -> (reverse ml1) ~ (reverse ml2).
Axiom RESTR2 : forall (n1 n2 n3 :nat) (l1 l1' : mylist n1) (l2 l2' : mylist n2) (l3 l3' : mylist n3) (x1 x2 y1 y2 : oursum), (l1 ++ [x1] ++ l2 ++ [x2] ++ l3) ~ (l1' ++ [y1] ++ l2' ++ [y2] ++ l3') ->
 (l1 ++ [x2] ++ l2 ++ [x1] ++ l3) ~ (l1' ++ [y2] ++ l2' ++ [y1] ++ l3').
**)
(********************************************************************************)
Axiom TFDIST: not ([bol TRue]~[bol FAlse]).

(*****Axioms for if_then_else *****************)

(**IFSAME**)

Axiom IFSAME_M: forall (b:Bool) (x : message), (if_then_else_M b x x) # x.
Axiom IFSAME_B: forall (b:Bool) (b1 : Bool),  (if_then_else_B b b1 b1) ## b1.

(**IFEVAL**)

Axiom IFEVAL_B : forall (b1 b2 : Bool)(n:nat),  (if_then_else_B (Bvar n) b1 b2) ## (if_then_else_B (Bvar n) ([n := TRue] b1) ([n := FAlse] b2)).
Axiom IFEVAL_M : forall (t1 t2 : message) (n:nat),  (if_then_else_M (Bvar n) t1 t2) #(if_then_else_M (Bvar n) ((n := TRue) t1) ((n := FAlse) t2)).
Axiom IFEVAL_B' : forall (b b1 b2 : Bool),  (if_then_else_B b b1 b2) ## (if_then_else_B b (subbol_bol' b TRue b1) (subbol_bol' b FAlse b2)).

Axiom IFEVAL_M' : forall (b:Bool)(t1 t2  : message),  (if_then_else_M b t1 t2) #(if_then_else_M b (subbol_msg' b TRue t1) (subbol_msg' b FAlse t2)).

(**IFTRue**)

Axiom IFTRUE_M : forall (x y : message),  (if_then_else_M TRue x y) # x .
Axiom IFTRUE_B : forall (b1 b2 : Bool), (if_then_else_B TRue b1 b2) ## b1.

(**IFFAlse**)

Axiom IFFALSE_M: forall (x y : message), (if_then_else_M FAlse x y) # y.
Axiom IFFALSE_B: forall (b1 b2 : Bool),  (if_then_else_B FAlse b1 b2) ## b2.

(********************************************IFBRANCH******************************************)
(**********************************************************************************************)

Axiom IFBRANCH_M: forall (n: nat) (ml1 ml2 : mylist n) (b b' : Bool)(x x' y y':message), (ml1 ++ [ bol b ; msg x] ) ~  ( ml2 ++ [ bol b'; msg x'])  ->  (ml1 ++ [bol b ; msg y ] ) ~( ml2 ++ [bol b' ; msg y'])
-> (ml1 ++ [bol b ;msg (if_then_else_M b x y)])~ ( ml2 ++ [bol b' ; msg (if_then_else_M b' x' y')]).

Axiom IFBRANCH_B: forall (n: nat) (ml1 ml2 : mylist n) (b b' : Bool)(b1 b1' b2 b2':Bool), (ml1 ++ [bol b ;bol b1]) ~ ( ml2 ++ [bol b' ; bol b1'])  ->  (ml1 ++ [ bol b; bol b2]) ~( ml2 ++ [bol b'; bol b2'])
-> (ml1 ++ [ bol b ;bol (if_then_else_B b b1 b2)])~ (  ml2 ++ [bol b' ; bol (if_then_else_B b' b1' b2')] ).

(*******************************Axioms for Fresh names*****************************************)
(**********************************************************************************************)

Axiom FRESHNEQ: forall (n : nat) (m : message), ((clos_msg m) = true)/\ ( (Fresh [n] [msg m]) = true) ->[bol (EQ_M (N n) m)]~ [bol FAlse] .

Axiom FRESHIND: forall (n n1 n2:nat) (v w: mylist n), ((clos_mylist (v++w)) = true) /\ ( (Fresh [ n1] (v++w)) = true) /\ ( (Fresh [ n2] (v++w)) = true) /\  (v ~ w) <-> ((msg (r n1) ) +++ v) ~ (( msg (r n2)) +++w ) .
Axiom FRESHIND_rs : forall (n n1 n2:nat) (v w: mylist n), ((clos_mylist (v++w)) = true) /\ ( (Fresh [ n1] (v++w)) = true) /\ ( (Fresh [ n2] (v++w)) = true) /\  (v ~ w) <-> ((msg  (N n1)) +++ v) ~ (( msg  (N n2)) +++w ) .

(*****************************************************************************************************************************************************************)
(****Fresh [n;n1;n2;n3]-> [G(n); g(n);g(n)^(r (n1));g(n)^(r (n2)); g(n)^(r (n1))(r (n2))] ~[G(n); g(n);g(n)^(r (n1));g(n)^(r (n2)); g(n)^(r (n3))]*****************)

Axiom DDH : forall (n n1 n2 n3: nat),  (Fresh [ n ; n1 ;  n2  ; n3 ] []) = true->
[ msg (G n) ; msg (g n) ; msg (exp (G n) (g n) (r  n1)) ; msg (exp (G n) (g n) (r  n2)) ; msg (exp (G n) (exp (G n) (g n) (r  n1)) (r  n2))]
~ [msg (G n) ; msg (g n) ; msg (exp (G n) (g n) (r  n1)) ; msg (exp (G n) (g n) (r n2)) ; msg (exp (G n) (g n) (r n3))]  .

Goal (f [ (if_then_else_M TRue O O)]) # (f [ O]).
rewrite IFTRUE_M. reflexivity.  Qed.
 Check f.
End Core_Axioms.

Eval compute in sublist 0 3 [ msg O; msg  (N 1); msg (N 2)].
Check f.


Require Import Coqlib.
Require Import Maps.

Require Import Integers.
Open Scope Z_scope.
Import ListNotations.

Set Asymmetric Patterns.

Require Import state.
Require Import language.

Set Implicit Arguments.
Unset Strict Implicit.

Require Import logic.

Open Scope nat.
Open Scope code_scope.

(*+ soundness of instruction rule +*)
Definition ins_sound p q i :=
  forall s,
    s |= p -> (exists s', (Q__ s (cntrans i) s') /\ s' |= q).

(*+ soundness of instruction sequence rule +*)
Inductive safety_insSeq : CodeHeap -> State -> Label -> Label -> asrt -> funspec -> Prop :=
| i_seq : forall C S pc npc q Spec i,
    C pc = Some (cntrans i) ->
    (
      exists S' pc' npc',
        P__ C (S, pc, npc) (S', pc', npc')
    ) ->
    (
      forall S' pc' npc',
        P__ C (S, pc, npc) (S', pc', npc') ->
        safety_insSeq C S' pc' npc' q Spec
    ) ->
    safety_insSeq C S pc npc q Spec

| call_seq : forall C S pc npc q Spec f,
    C pc = Some (ccall f) ->
    (
      exists S1 S2 pc1 npc1 pc2 npc2,
        P__ C (S, pc, npc) (S1, pc1, npc1) /\
        P__ C (S1, pc1, npc1) (S2, pc2, npc2)
    ) ->
    (
      forall S1 S2 pc1 npc1 pc2 npc2,
        P__ C (S, pc, npc) (S1, pc1, npc1) ->
        P__ C (S1, pc1, npc1) (S2, pc2, npc2) ->
        (
          exists fp fq L r,
            pc2 = f /\ npc2 = f +ᵢ ($ 4) /\
            Spec f = Some (fp, fq) /\ S2 |= (fp L) ** r /\
            (forall S', S' |= (fq L) ** r ->
                        safety_insSeq C S' (pc +ᵢ ($ 8)) (pc +ᵢ ($ 12)) q Spec) /\
            (forall S', S' |= fq L -> get_R (getregs S') r15 = Some (W pc))
        )
    ) ->
    safety_insSeq C S pc npc q Spec

| jmpl_seq : forall C S pc npc q aexp rd Spec,
    C pc = Some (cjumpl aexp rd) ->
    (
      exists S1 S2 pc1 npc1 pc2 npc2,
        P__ C (S, pc, npc) (S1, pc1, npc1) /\
        P__ C (S1, pc1, npc1) (S2, pc2, npc2)
    ) ->
    (
      forall S1 S2 pc1 npc1 pc2 npc2,
        P__ C (S, pc, npc) (S1, pc1, npc1) ->
        P__ C (S1, pc1, npc1) (S2, pc2, npc2) ->
        (
          exists fp fq L r,
            Spec pc2 = Some (fp, fq) /\ S2 |= (fp L) ** r /\ (fq L) ** r ==> q /\
            npc2 = pc2 +ᵢ ($ 4)
        )
    ) ->
    safety_insSeq C S pc npc q Spec

| be_seq : forall C S pc npc q f Spec,
    C pc = Some (cbe f) ->
    (
      exists S1 S2 pc1 npc1 pc2 npc2,
        P__ C (S, pc, npc) (S1, pc1, npc1) /\
        P__ C (S1, pc1, npc1) (S2, pc2, npc2)
    ) ->
    (
      forall S1 S2 pc1 npc1 pc2 npc2,
        P__ C (S, pc, npc) (S1, pc1, npc1) ->
        P__ C (S1, pc1, npc1) (S2, pc2, npc2) ->
        (
          exists v, get_R (getregs S) z = Some (W v) /\
          (
            v <> ($ 0) ->
            (
              exists fp fq L r,
                Spec pc2 = Some (fp, fq) /\ S2 |= (fp L) ** r /\
                (fq L ** r) ==> q /\ npc2 = pc2 +ᵢ ($ 4)
            )
          ) /\
          (
            v = ($ 0) ->
            safety_insSeq C S2 pc2 npc2 q Spec
          )
        )
    ) ->
    safety_insSeq C S pc npc q Spec

| bne_seq : forall C S pc npc q f Spec,
    C pc = Some (cbne f) ->
    (
      exists S1 S2 pc1 npc1 pc2 npc2,
        P__ C (S, pc, npc) (S1, pc1, npc1) /\
        P__ C (S1, pc1, npc1) (S2, pc2, npc2)
    ) ->
    (
      forall S1 S2 pc1 npc1 pc2 npc2,
        P__ C (S, pc, npc) (S1, pc1, npc1) ->
        P__ C (S1, pc1, npc1) (S2, pc2, npc2) ->
        (
          exists v, get_R (getregs S) z = Some (W v) /\
          (
            v = ($ 0) ->
            (
              exists fp fq L r,
                Spec pc2 = Some (fp, fq) /\ S2 |= (fp L) ** r /\
                (fq L ** r) ==> q /\ npc2 = pc2 +ᵢ ($ 4)
            )
          ) /\
          (
            v <> ($ 0) ->
            safety_insSeq C S2 pc2 npc2 q Spec
          )
        )
    ) ->
    safety_insSeq C S pc npc q Spec

| retl_seq : forall C S pc npc q Spec,
    C pc = Some (cretl) ->
    (
      exists S1 S2 pc1 npc1 pc2 npc2,
        P__ C (S, pc, npc) (S1, pc1, npc1) /\
        P__ C (S1, pc1, npc1) (S2, pc2, npc2)
    ) ->
    (
      forall S1 S2 pc1 npc1 pc2 npc2,
        P__ C (S, pc, npc) (S1, pc1, npc1) ->
        P__ C (S1, pc1, npc1) (S2, pc2, npc2) ->
        (
          S2 |= q /\
          (exists f,
              get_R (getregs S2) r15 = Some (W f) /\
              pc2 = f +ᵢ ($ 8) /\ npc2 = f +ᵢ ($ 12)
          )
        )
    ) ->
    safety_insSeq C S pc npc q Spec

| ret_seq : forall C S pc npc q Spec,
    C pc = Some (cret) ->
    (
      exists S1 S2 pc1 npc1 pc2 npc2,
        P__ C (S, pc, npc) (S1, pc1, npc1) /\
        P__ C (S1, pc1, npc1) (S2, pc2, npc2)
    ) ->
    (
      forall S1 S2 pc1 npc1 pc2 npc2,
        P__ C (S, pc, npc) (S1, pc1, npc1) ->
        P__ C (S1, pc1, npc1) (S2, pc2, npc2) ->
        (
          S2 |= q /\
          (exists f,
              get_R (getregs S2) r15 = Some (W f) /\
              pc2 = f +ᵢ ($ 8) /\ npc2 = f +ᵢ ($ 12)
          )
        )
    ) ->
    safety_insSeq C S pc npc q Spec.

(*+ Safety +*)
Inductive safety : nat -> CodeHeap -> State -> Label -> Label -> asrt -> nat -> Prop :=
| safety_end :
    forall C S pc npc q k,
      safety 0 C S pc npc q k

| safety_cons : forall C S pc npc q n k,
    (
      forall i,
        C pc = Some (cntrans i) ->
        (
          (
            exists S' pc' npc',
              P__ C (S, pc, npc) (S', pc', npc')
          ) /\
          (
            forall S' pc' npc',
              P__ C (S, pc, npc) (S', pc', npc') ->
              safety n C S' pc' npc' q k
          )
        )
    ) ->
    (
      forall aexp rd,
        C pc = Some (cjumpl aexp rd) ->
        (
          (
            exists S1 S2 pc1 npc1 pc2 npc2,
              P__ C (S, pc, npc) (S1, pc1, npc1) /\ P__ C (S1, pc1, npc1) (S2, pc2, npc2)
          ) /\
          (
            forall S1 S2 pc1 npc1 pc2 npc2,
              P__ C (S, pc, npc) (S1, pc1, npc1) ->
              P__ C (S1, pc1, npc1) (S2, pc2, npc2) ->
              safety n C S2 pc2 npc2 q k
          )
        )
    ) ->
    (
      forall f,
        C pc = Some (cbe f) ->
        (
          (
            exists S1 S2 pc1 npc1 pc2 npc2,
              P__ C (S, pc, npc) (S1, pc1, npc1) /\ P__ C (S1, pc1, npc1) (S2, pc2, npc2)
          ) /\
          (
            forall S1 S2 pc1 npc1 pc2 npc2,
              P__ C (S, pc, npc) (S1, pc1, npc1) ->
              P__ C (S1, pc1, npc1) (S2, pc2, npc2) ->
              safety n C S2 pc2 npc2 q k
          )
        )
    ) ->
    (
      forall f,
        C pc = Some (cbne f) ->
        (
          (
            exists S1 S2 pc1 npc1 pc2 npc2,
              P__ C (S, pc, npc) (S1, pc1, npc1) /\ P__ C (S1, pc1, npc1) (S2, pc2, npc2)
          ) /\
          (
            forall S1 S2 pc1 npc1 pc2 npc2,
              P__ C (S, pc, npc) (S1, pc1, npc1) ->
              P__ C (S1, pc1, npc1) (S2, pc2, npc2) ->
              safety n C S2 pc2 npc2 q k
          )
        )
    ) ->
    (
      forall f,
        C pc = Some (ccall f) ->
        (
          (
            exists S1 S2 pc1 npc1 pc2 npc2,
              P__ C (S, pc, npc) (S1, pc1, npc1) /\ P__ C (S1, pc1, npc1) (S2, pc2, npc2)
          ) /\
          (
            forall S1 S2 pc1 npc1 pc2 npc2,
              P__ C (S, pc, npc) (S1, pc1, npc1) ->
              P__ C (S1, pc1, npc1) (S2, pc2, npc2) ->
              safety n C S2 pc2 npc2 q (Nat.succ k)
          )
        )
    ) ->
    (
      C pc = Some (cretl) ->
      (
        (
          exists S1 S2 pc1 npc1 pc2 npc2,
            P__ C (S, pc, npc) (S1, pc1, npc1) /\ P__ C (S1, pc1, npc1) (S2, pc2, npc2)
        ) /\
        (
          forall S1 S2 pc1 pc2 npc1 npc2,
            P__ C (S, pc, npc) (S1, pc1, npc1) ->
            P__ C (S1, pc1, npc1) (S2, pc2, npc2) ->
            (
              (Nat.eqb k 0 = true /\ S2 |= q) \/
              (Nat.eqb k 0 = false /\ safety n C S2 pc2 npc2 q (Nat.pred k))
            )
        )
      )
    ) ->
    (
      C pc = Some (cret) ->
      (
        (
          exists S1 S2 pc1 npc1 pc2 npc2,
            P__ C (S, pc, npc) (S1, pc1, npc1) /\ P__ C (S1, pc1, npc1) (S2, pc2, npc2)
        ) /\
        (
          forall S1 S2 pc1 pc2 npc1 npc2,
            P__ C (S, pc, npc) (S1, pc1, npc1) ->
            P__ C (S1, pc1, npc1) (S2, pc2, npc2) ->
            (
              (Nat.eqb k 0 = true /\ S2 |= q) \/
              (Nat.eqb k 0 = false /\ safety n C S2 pc2 npc2 q (Nat.pred k))
            )
        )
      )
    ) ->
    safety (Nat.succ n) C S pc npc q k.

(*
CoInductive safety : CodeHeap -> State -> Label -> Label -> asrt -> nat -> Prop :=
| safety_cons : forall C S pc npc q n,
    (
      forall S' i pc' npc',
        C pc = Some (cntrans i) ->
        P__ C (S, pc, npc) (S', pc', npc') ->
        safety C S' pc' npc' q n
    ) ->
    (
      forall S' pc' npc' aexp rd,
        C pc = Some (cjumpl aexp rd) ->
        P__ C (S, pc, npc) (S', pc', npc') ->
        safety C S' pc' npc' q n
    ) ->
    (
      forall S' pc' npc' aexp,
        C pc = Some (cbe aexp) ->
        P__ C (S, pc, npc) (S', pc', npc') ->
        safety C S' pc' npc' q n
    ) ->
    (
      forall S' pc' npc' aexp,
        C pc = Some (cbne aexp) ->
        P__ C (S, pc, npc) (S', pc', npc') ->
        safety C S' pc' npc' q n
    ) ->
    (
      forall f S1 S2 pc1 pc2 npc1 npc2,
        C pc = Some (ccall f) ->
        P__ C (S, pc, npc) (S1, pc1, npc1) ->
        P__ C (S1, pc1, npc1) (S2, pc2, npc2) ->
        safety C S2 pc2 npc2 q (Nat.succ n)
    ) ->
    (
      forall S1 S2 pc1 pc2 npc1 npc2,
        C pc = Some (cretl) ->
        P__ C (S, pc, npc) (S1, pc1, npc1) ->
        P__ C (S1, pc1, npc1) (S2, pc2, npc2) ->
        (
          (Nat.eqb n 0 = true /\ S2 |= q) \/
          (Nat.eqb n 0 = false /\ safety C S2 pc2 npc2 q (Nat.pred n))
        )
    ) ->
    safety C S pc npc q n.
*)

(*
Definition cdhp_subst (Spec Spec' : funspec) :=
  forall f fsp, Spec f = Some fsp -> Spec' f = Some fsp.
*)

(** Instruction Sequence rule Sound *)
Definition insSeq_sound (Spec : funspec) (p : asrt) (f : Label) (I : InsSeq) (q : asrt) :=
  forall C S,
    LookupC C f I -> S |= p -> safety_insSeq C S f (f +ᵢ ($ 4)) q Spec.

(** Code Heap Sound *)
Definition cdhp_sound (Spec : funspec) (C : CodeHeap) :=
  forall f fp fq L S,
    Spec f = Some (fp, fq) -> S |= (fp L) ->
    (*cdhp_subst Spec Spec' ->*)
    exists I, LookupC C f I /\ insSeq_sound Spec (fp L) f I (fq L).


Require Import MachineModel.

(* ===============================================================
   Labels for the trace semantics and the labelled operational
   ================================================================*)

Inductive Label :=
| Tau : Label
| Tick : Label
| Write_out : Address -> Value -> Label
| Call : RegisterFile -> Flags -> Address -> Label
| Callback : RegisterFile -> Flags -> Address -> Label
| Return : RegisterFile -> Flags -> Address -> Label
| Returnback : RegisterFile -> Flags -> Address -> Label.


From CoreErlang.FrameStack Require Export Frames.
From CoreErlang Require Export Auxiliaries Matching.

Import ListNotations.

Definition create_result (ident : FrameIdent) (vl : list Val)
  : Redex :=
match ident with
| IValues => RValSeq vl
| ITuple => RValSeq [VTuple vl]
| IMap => RValSeq [VMap (make_val_map (deflatten_list vl))]
| ICall m f => fst (eval m f vl []) (*side effects!!! *)
| IPrimOp f => fst (primop_eval f vl []) (* side effects !!!!*)
| IApp (VClos ext id vars e) =>
  if Nat.eqb vars (length vl)
  then RExp (e.[list_subst (convert_to_closlist ext ++ vl) idsubst])
  else RExc (badarity (VClos ext id vars e))
| IApp v => RExc (badfun v)
end.

Proposition FrameIdent_eq_dec :
  forall id1 id2 : FrameIdent, {id1 = id2} + {id1 <> id2}.
Proof.
  decide equality; try apply string_dec.
  apply Val_eq_dec.
Qed.

(* Note: for simplicity, this semantics allows guards to evaluate
   to exceptions, which is not allowed in normal Core Erlang. *)
Reserved Notation "⟨ fs , e ⟩ --> ⟨ fs' , e' ⟩" (at level 50).
Inductive step : FrameStack -> Redex -> FrameStack -> Redex -> Prop :=
(**  Reduction rules *)

(** Cooling: single value *)
| cool_value v xs:
  ⟨ xs, `v ⟩ --> ⟨ xs, RValSeq [v] ⟩

(************************************************)
(* heating should be separate for all complex expressions (to be
   syntax-driven).
   Only the intermediate and last steps can be extracted: *)
| eval_step_params xs ident (el : list Exp) (vl : list Val) (v : Val) (e : Exp):
  ⟨FParams ident vl (e :: el) :: xs, RValSeq [v]⟩ -->
  ⟨FParams ident (vl ++ [v]) el :: xs, e⟩

(* technical rule to avoid duplication for 0 subexpressions : *)
| eval_step_params_0 xs ident e el vl:
  ident <> IMap ->
  ⟨FParams ident vl (e::el) ::xs, RBox⟩ --> ⟨FParams ident vl el :: xs, e⟩

(* 0 subexpression in complex expressions: *)
| eval_cool_params_0 xs ident (vl : list Val) (res : Redex) :
  ident <> IMap ->
  res = create_result ident vl ->
  ⟨FParams ident vl [] ::xs, RBox⟩ --> ⟨xs, res⟩

| eval_cool_params xs ident (vl : list Val) (v : Val) (res : Redex):
  res = create_result ident (vl ++ [v]) ->
  ⟨FParams ident vl [] :: xs, RValSeq [v]⟩ --> ⟨xs, res⟩

(************************************************)
(* Heating constructs with list subexpressions: *)
| eval_heat_values (el : list Exp) (xs : list Frame):
  ⟨ xs, EValues el ⟩ --> ⟨ (FParams IValues [] el)::xs, RBox ⟩

| eval_heat_tuple (el : list Exp) (xs : list Frame):
  ⟨ xs, ETuple el ⟩ --> ⟨ (FParams ITuple [] el)::xs, RBox ⟩

(* This is handled separately, to satisfy the invariant in FCLOSED for maps *)
| eval_heat_map_0 (xs : list Frame):
  ⟨ xs, EMap [] ⟩ --> ⟨ xs, RValSeq [VMap []] ⟩

| eval_heat_map (e1 e2 : Exp) (el : list (Exp * Exp)) (xs : list Frame):
  ⟨ xs, EMap ((e1, e2) :: el) ⟩ -->
  ⟨ (FParams IMap [] (e2 :: flatten_list el))::xs, e1 ⟩

| eval_heat_call (el : list Exp) (xs : list Frame) m f:
  ⟨ xs, ECall m f el ⟩ --> ⟨ (FParams (ICall m f) [] el)::xs, RBox ⟩

| eval_heat_primop (el : list Exp) (xs : list Frame) f:
  ⟨ xs, EPrimOp f el ⟩ --> ⟨ (FParams (IPrimOp f) [] el)::xs, RBox ⟩

| eval_heat_app2 (el : list Exp) (xs : list Frame) (v : Val):
  ⟨ FApp1 el :: xs, RValSeq [v] ⟩ --> ⟨ (FParams (IApp v) [] el)::xs, RBox ⟩

(************************************************)
(**  App *)
| eval_heat_app xs e l:
  ⟨xs, EApp e l⟩ --> ⟨FApp1 l :: xs, e⟩
(**  List *)
(**  Cooling *)

| eval_cool_cons_1 (hd : Exp) (tl : Val) xs :
  ⟨ (FCons1 hd)::xs, RValSeq [tl] ⟩ --> ⟨ (FCons2 tl)::xs, RExp hd ⟩

| eval_cool_cons_2 (hd tl : Val) xs :
  ⟨ (FCons2 tl)::xs, RValSeq [hd] ⟩ --> ⟨ xs, RValSeq [VCons hd tl] ⟩

(**  Heating *)
| eval_heat_cons (hd tl : Exp) xs :
  ⟨ xs, ECons hd tl ⟩ --> ⟨ (FCons1 hd)::xs, RExp tl ⟩

(**  Let *)
(**  Cooling *)
| eval_cool_let l e2 vs xs :
  length vs = l ->
  ⟨ (FLet l e2)::xs, RValSeq vs ⟩ --> ⟨ xs, RExp (e2.[ list_subst vs idsubst ]) ⟩

(**  Heating *)
| eval_heat_let l e1 e2 xs :
  ⟨ xs, ELet l e1 e2 ⟩ --> ⟨ (FLet l e2)::xs, RExp e1 ⟩

(**  Seq *)
(**  Cooling *)
| eval_cool_seq e2 v xs :
  ⟨ (FSeq e2)::xs, RValSeq [v] ⟩ --> ⟨ xs, RExp e2 ⟩
(**  Heating *)
| eval_heat_seq e1 e2 xs :
  ⟨ xs, ESeq e1 e2 ⟩ --> ⟨ (FSeq e2)::xs, RExp e1 ⟩

(**  Fun *)
(**  Cooling *)
| eval_cool_fun e vl xs :
  ⟨ xs, EFun vl e ⟩ --> ⟨ xs, RValSeq [ VClos [] 0 vl e ] ⟩
  (* TODO : id <> 0 usually *)

(**  Case *)
(**  Heating *)
| eval_heat_case e l xs:
  ⟨ xs, ECase e l ⟩ --> ⟨ (FCase1 l)::xs, RExp e ⟩

(**  Cooling *)
(* reduction started or it is already ongoing, the first pattern matched,
   e1 the guard needs to be evaluated. vs' (the result of the pattern
   matching is stored in the frame) *)
| eval_step_case_match lp e1 e2 l vs vs' xs :
  match_pattern_list lp vs = Some vs' ->
  ⟨ (FCase1 ((lp,e1,e2)::l))::xs, RValSeq vs ⟩ -->
  ⟨ (FCase2 vs lp e2 l)::xs, RExp (e1.[list_subst vs' idsubst]) ⟩

(* reduction started or it is already ongoing, the first pattern doesn't
   match, so we check the next pattern *)
| eval_step_case_not_match lp e1 e2 l vs xs :
  match_pattern_list lp vs = None ->
  ⟨ (FCase1 ((lp,e1,e2)::l))::xs, RValSeq vs ⟩ -->
  ⟨ (FCase1 l)::xs, RValSeq vs ⟩

(* reduction is ongoing, the pattern matched, and the guard is true, thus
   the reduction continues inside the given clause *)
| eval_step_case_true vs lp e' l xs vs' :
  match_pattern_list lp vs = Some vs' ->
  ⟨ (FCase2 vs lp e' l)::xs, RValSeq [ VLit (Atom "true") ] ⟩ -->
  ⟨ xs, RExp (e'.[list_subst vs' idsubst]) ⟩

(* reduction is ongoing, the pattern matched, and the guard is false, thus
   we check the next pattern. *)
| eval_step_case_false vs lp' e' l xs :
  (* NOTE: match_pattern_list lp vs = Some vs' -> is necessary? *)
  ⟨ (FCase2 vs lp' e' l)::xs, RValSeq [ VLit (Atom "false") ] ⟩ --> ⟨ (FCase1 l)::xs, RValSeq vs ⟩

(** Exceptions *)
| eval_cool_case_empty vs xs:
  ⟨ (FCase1 [])::xs, RValSeq vs ⟩ --> ⟨ xs, RExc if_clause ⟩

(**  LetRec *)
(**  Cooling *)
(**  Heating *)
| eval_heat_letrec l e lc xs :
  convert_to_closlist (map (fun '(x,y) => (0,x,y)) l) = lc ->
  (* TODO: for now the funids are 0 coded in *)
  ⟨ xs, ELetRec l e ⟩ --> ⟨ xs, RExp e.[list_subst lc idsubst] ⟩

(**  Try *)
(**  Cooling *)
| eval_cool_try_ok vl1 e2 vl2 e3 vs xs:
  vl1 = length vs ->
  ⟨ (FTry vl1 e2 vl2 e3)::xs, RValSeq vs ⟩ --> ⟨ xs, RExp e2.[ list_subst vs idsubst ] ⟩
| eval_cool_try_err vl1 e2 e3 class reason details xs:
  (* in Core Erlang exceptions always have 3 parts *)
  ⟨ (FTry vl1 e2 3 e3)::xs, RExc (class, reason, details) ⟩ -->
  ⟨ xs, RExp e3.[ list_subst [exclass_to_value class; reason; details] idsubst ] ⟩
(**  Heating *)
| eval_heat_try e1 vl1 e2 vl2 e3 xs :
  ⟨ xs, ETry e1 vl1 e2 vl2 e3 ⟩ --> ⟨ (FTry vl1 e2 vl2 e3)::xs, RExp e1 ⟩

(** Exceptions *)
(** Propogation *)
| eval_prop_exc F exc xs :
  (forall vl1 e2 vl2 e3, (FTry vl1 e2 vl2 e3) <> F) ->
  ⟨ F::xs, RExc exc ⟩ --> ⟨ xs, RExc exc ⟩
  (* TODO: details could be appended here to the stack trace *)

where "⟨ fs , e ⟩ --> ⟨ fs' , e' ⟩" := (step fs e fs' e').

Reserved Notation "⟨ fs , e ⟩ -[ k ]-> ⟨ fs' , e' ⟩" (at level 50).
Inductive step_rt : FrameStack -> Redex -> nat -> FrameStack -> Redex -> Prop :=
| step_refl fs e : ⟨ fs, e ⟩ -[ 0 ]-> ⟨ fs, e ⟩
| step_trans fs e fs' e' fs'' e'' k:
  ⟨ fs, e ⟩ --> ⟨ fs', e'⟩ -> ⟨fs', e'⟩ -[ k ]-> ⟨fs'', e''⟩
  ->
  ⟨ fs, e ⟩ -[S k]-> ⟨fs'', e''⟩
where "⟨ fs , e ⟩ -[ k ]-> ⟨ fs' , e' ⟩" := (step_rt fs e k fs' e').

Definition step_any (fs : FrameStack) (e : Redex) (r : Redex) : Prop :=
  exists k, is_result r /\ ⟨fs, e⟩ -[k]-> ⟨[], r⟩.
Notation "⟨ fs , e ⟩ -->* v" := (step_any fs e v) (at level 50).


Require Import Coq.Classes.Morphisms.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.BaseTypes Fiat.Parsers.CorrectnessBaseTypes.
Require Import Fiat.Parsers.GenericBaseTypes Fiat.Parsers.GenericCorrectnessBaseTypes.
Require Import Fiat.Parsers.ContextFreeGrammar.Valid.
Require Import Fiat.Parsers.GenericRecognizerCorrect.
Require Import Fiat.Parsers.BooleanRecognizer.

Local Coercion is_true : bool >-> Sortclass.

Section convenience.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char} {G : grammar Char}.
  Context {data : @boolean_parser_dataT Char _}
          {cdata : @boolean_parser_completeness_dataT' Char _ _ G _}
          {rdata : @parser_removal_dataT' _ G _}
          (gvalid : grammar_valid G).

  Local Instance gencdata_default_proper {A}
    : Proper (beq ==> eq ==> eq ==> eq ==> Basics.impl) (fun _ (_ : A) (x y : bool) => y = x).
  Proof.
    repeat intro; repeat subst; reflexivity.
  Qed.

  Local Existing Instance boolean_gendata.
  Global Program Instance boolean_gencdata : generic_parser_correctness_dataT
    := { parse_nt_is_correct str nt exp act := act = exp;
         parse_item_is_correct str it exp act := act = exp;
         parse_production_is_correct str p exp act := act = exp;
         parse_productions_is_correct str p exp act := act = exp }.

  Definition parse_item_sound
    : forall str it, parse_item str it -> parse_of_item G str it
    := parse_item_sound.

  Definition parse_item_complete
    : forall str it, parse_of_item G str it -> parse_item str it
    := parse_item_complete.

  Definition parse_nonterminal_sound
    : forall str nt, parse_nonterminal str nt -> parse_of_item G str (NonTerminal nt)
    := parse_nonterminal_sound.

  Definition parse_nonterminal_complete
    : forall str nt, parse_of_item G str (NonTerminal nt) -> parse_nonterminal str nt
    := parse_nonterminal_complete.

  Definition parse_of_nonterminal_complete
    : forall str nt,
      List.In nt (Valid_nonterminals G)
      -> parse_of G str (Lookup G nt)
      -> parse_nonterminal str nt
    := parse_of_nonterminal_complete.
End convenience.