From Tealeaves Require Export
  Functors.List
  Categories.TypeFamilies
  Classes.Kleisli.Decorated.Monad (* preincr *)
  Multisorted.Classes.DTM.

From Tealeaves.Backends.LN Require Import
  Atom AtomSet AssocList Multisorted.LN.

Import AtomSet.Notations.
Import Tealeaves.Classes.Monoid.Notations.
Import Tealeaves.Data.Product.Notations.
Import Tealeaves.Classes.Applicative.Notations.
Import Multisorted.Classes.DTM.Notations.
Import List.ListNotations.

#[local] Generalizable Variables F G A B C ϕ.

(** * The index [K] *)
(******************************************************************************)
Inductive K2 : Type := KType | KTerm.

#[export] Instance Keq : EqDec K2 eq.
Proof.
  change (forall x y : K2, {x = y} + {x <> y}).
  decide equality.
Defined.

#[export] Instance I2 : Index := {| K := K2 |}.

(** * System F syntax and typeclass instances *)
(******************************************************************************)
Parameter base_typ : Type.

Section syntax.

  Context
    {V : Type}.

  Inductive typ : Type :=
  | ty_c : base_typ -> typ
  | ty_v : V -> typ
  | ty_ar : typ -> typ -> typ
  | ty_univ : typ -> typ.

  Inductive term : Type :=
  | tm_var : V -> term
  | tm_abs : typ -> term -> term
  | tm_app : term -> term -> term
  | tm_tab : term -> term
  | tm_tap : term -> typ -> term.

End syntax.

(** Clear the implicit arguments to the type constructors. This keeps <<V>>
    implicit for the constructors. *)
Arguments typ V : clear implicits.
Arguments term V : clear implicits.

Definition SystemF (k : K) (v : Type) : Type :=
  match k with
  | KType => typ v
  | KTerm => term v
  end.

(** ** Notations *)
(******************************************************************************)
Module Notations.

  Declare Scope SystemF_scope.

  (** *** Notations for type expressions *)
  Notation "A ⟹ B" := (ty_ar A B) (at level 51, right associativity) : SystemF_scope.
  Notation "∀ τ" := (ty_univ τ) (at level 60) : SystemF_scope.

  (** *** Notations for term expressions *)
  Notation "'λ' X ⋅ body" := (tm_abs X body) (at level 45) : SystemF_scope.
  Notation "t1 @ t2" := (tm_app t1 t2) (at level 40) : SystemF_scope.
  Notation "'Λ' body" := (tm_tab body) (at level 45) : SystemF_scope.
  Notation "t1 @@ t2" := (tm_tap t1 t2) (at level 40) : SystemF_scope.

  (** *** Coercions from variables to leaves *)
  Coercion Fr : atom >-> LN.
  Coercion Bd : nat >-> LN.

  (** *** Coercions from leaves to term expressions *)
  Definition tm_var_ : LN -> term LN := @tm_var LN.
  Coercion tm_var_ : LN >-> term.

  (** *** Coercions from leaves to type expressions *)
  Definition c_base_type: base_typ -> typ LN := @ty_c LN.
  Definition c_LN_type : LN -> typ LN := @ty_v LN.
  Coercion c_base_type : base_typ >-> typ.
  Coercion c_LN_type : LN >-> typ.

End Notations.

Open Scope SystemF_scope.
Import Notations.

(** ** Example expressions *)
(******************************************************************************)
Module examples.

  Context
    (x y z : atom)
    (c1 c2 c3 : base_typ).

  (** *** Raw abstract syntax *)
  (** Abstract syntax trees without notations or coercions *)
  (******************************************************************************)

  (** *** Constants and variables *)
  Example typ_1 : typ LN := ty_v (Fr x).
  Example typ_2 : typ LN := ty_v (Fr y).
  Example typ_3 : typ LN := ty_v (Fr z).
  Example typ_4 : typ LN := ty_v (Bd 0).
  Example typ_5 : typ LN := ty_v (Bd 1).
  Example typ_6 : typ LN := ty_v (Bd 2).
  Example typ_7 : typ LN := ty_c c1.
  Example typ_8 : typ LN := ty_c c2.

  (** *** Simple types *)
  Example typ_9  : typ LN := ty_ar (ty_v (Fr x))
                                     (ty_v (Fr x)).
  Example typ_10 : typ LN := ty_ar (ty_v (Fr x))
                                     (ty_v (Fr y)).
  Example typ_11 : typ LN := ty_ar (ty_v (Fr x))
                                     (ty_v (Bd 1)).
  Example typ_12 : typ LN := ty_ar (ty_v (Bd 1))
                                     (ty_c c1).
  Example typ_13 : typ LN := ty_ar (ty_ar (ty_v (Bd 0))
                                            (ty_v (Fr x)))
                                     (ty_v (Bd 1)).
  Example typ_14 : typ LN := ty_ar (ty_c c2)
                                     (ty_ar (ty_v (Fr x))
                                            (ty_v (Bd 1))).
  Example typ_15 : typ LN := ty_ar (ty_ar (ty_v (Bd 2))
                                            (ty_c c1))
                                     (ty_ar (ty_v (Fr y))
                                            (ty_v (Fr x))).
  Example typ_16 : typ LN := ty_ar (ty_ar (ty_v (Bd 2))
                                            (ty_v (Bd 1)))
                                     (ty_ar (ty_v (Fr y))
                                            (ty_v (Fr x))).

  (** *** Universal types *)
  Example typ_17 : typ LN := ty_univ (ty_ar (ty_v (Bd 0))
                                              (ty_v (Bd 0))).
  Example typ_18 : typ LN := ty_univ (ty_ar (ty_ar (ty_v (Bd 2))
                                                     (ty_v (Bd 1)))
                                              (ty_ar (ty_v (Fr y))
                                                     (ty_v (Fr x)))).

  (** *** Printy printed syntax *)
  (******************************************************************************)
  Module pretty.

    #[local] Open Scope SystemF_scope.

    Compute (0 : typ LN).
    Compute (x : typ LN).
    Compute (c1 : typ LN).

    (** Constants and variables *)
    Example typ_1 : typ LN := x.
    Example typ_2 : typ LN := y.
    Example typ_3 : typ LN := Fr z.
    Example typ_4 : typ LN := 0.
    Example typ_5 : typ LN := Bd 1.
    Example typ_6 : typ LN := 2.
    Example typ_7 : typ LN := c1.
    Example typ_8 : typ LN := c2.

    (** Simple types *)
    Example typ_9  : typ LN := x ⟹ x.
    Example typ_10 : typ LN := x ⟹ y.

    Goal ((x ⟹ x : typ LN) = Fr x ⟹ Fr x). reflexivity. Qed.
    Goal ((x ⟹ 1 : typ LN) = Fr x ⟹ Bd 1). reflexivity. Qed.

    Example typ_11 : typ LN := x ⟹ 1.
    Example typ_12 : typ LN := x ⟹ c1.
    Example typ_13 : typ LN := (x ⟹ 0) ⟹ 1.
    Example typ_14 : typ LN := c2 ⟹ (x ⟹ 1).

    Goal c2 ⟹ x ⟹ 1 = c2 ⟹ (x ⟹ 1). reflexivity. Qed.

    Example typ_15 : typ LN := (2 ⟹ c1) ⟹ (y ⟹ x).
    Example typ_16 : typ LN := (2 ⟹ 1) ⟹ (y ⟹ x).

    (** Universal types *)
    Example typ_17 : typ LN := ∀ (0 ⟹ 0).
    Goal ∀ (0 ⟹ 0) = ∀ 0 ⟹ 0. reflexivity. Qed.

    Example typ_18 : typ LN := ∀ (2 ⟹ 1) ⟹ (y ⟹ x).
    Goal ∀ (2 ⟹ 1) ⟹ (y ⟹ x) = ∀ ((2 ⟹ 1) ⟹ (y ⟹ x)). reflexivity. Qed.

    Example typ_19 : typ LN := (∀ 2 ⟹ 1) ⟹ (y ⟹ x).
    Example typ_20 : typ LN := (2 ⟹ 1) ⟹ ∀ y ⟹ x.

  End pretty.

  Example term_1 : term LN := tm_var (Fr x).
  Example term_2 : term LN := tm_var (Bd 0).
  Example term_3 : term LN := tm_app term_1 term_2.
  Example term_4 : term LN := tm_app term_3 term_3.

  (** Identity function on type [c1]. *)
  Example term_5 : term LN := tm_abs (ty_c c1) (tm_var (Bd 0)).
  Example term_6 : term LN := tm_app term_5 term_3.

  (** Polymorphic identity function. *)
  Example term_7 : term LN := tm_tab (tm_abs (ty_v (Bd 0))(tm_var (Bd 0))).

  (** Instantiate identity at <<c1>> *)
  Example term_8 : term LN := tm_tap term_7 c1.

  #[local] Open Scope SystemF_scope.

  Example term_9 : term LN := (Λ λ 0 ⋅ 0).

End examples.

(** ** <<binddt>> operations *)
(******************************************************************************)
Section operations.

  Context
    (F : Type -> Type)
    `{Applicative F}
    {A B : Type}.

  Fixpoint bind_type (f : forall (k : K), list K2 * A -> F (SystemF k B)) (t : typ A) : F (typ B) :=
    match t with
    | ty_c t =>
      pure F (ty_c t)
    | ty_v a =>
      f KType (nil, a)
    | ty_ar t1 t2 =>
      pure F (ty_ar) <⋆> (bind_type f t1) <⋆> (bind_type f t2)
    | ty_univ body =>
      pure F (ty_univ) <⋆> (bind_type (fun k => preincr [KType] (f k)) body)
    end.

  Fixpoint bind_term (f : forall (k : K), list K2 * A -> F (SystemF k B)) (t : term A) : F (term B) :=
    match t with
    | tm_var a =>
      f KTerm (nil, a)
    | tm_abs ty body =>
      pure F (tm_abs)
           <⋆> bind_type (fun k => f k) ty
           <⋆> bind_term (fun k => f k ∘ incr [KTerm]) body
    | tm_app t1 t2 =>
      pure F tm_app <⋆> bind_term f t1 <⋆> bind_term f t2
    | tm_tab body =>
      pure F tm_tab <⋆> (bind_term (fun k => f k ∘ incr [KType]) body)
    | tm_tap t1 ty =>
      pure F tm_tap <⋆> bind_term f t1 <⋆> bind_type f ty
    end.

End operations.

#[export] Instance MReturn_SystemF : MReturn SystemF :=
  fun A k => match k with
          | KType => ty_v
          | KTerm => tm_var
          end.

#[export] Instance MBind_type : MBind (list K2) SystemF typ := @bind_type.
#[export] Instance MBind_term : MBind (list K2) SystemF term := @bind_term.
#[export] Instance MBind_SystemF : forall k, MBind (list K2) SystemF (SystemF k) :=
  ltac:(intros [|]; typeclasses eauto).

(** ** Example computations *)
(******************************************************************************)
Section example_computations.

  Open Scope SystemF_scope.

  Context
    (x y z : atom)
    (c1 c2 c3 : base_typ).

  (** ** Demo of opening operation *)
  Goal open (T := SystemF) typ KType (Fr x) (Bd 0) = Fr x. reflexivity. Qed.
  Goal open typ KType (Fr x) (Bd 1) = Bd 0. reflexivity. Qed.
  Goal open typ KType (Fr x) (Fr x) = Fr x. reflexivity. Qed.
  Goal open typ KType (Fr x) (Fr y) = Fr y. reflexivity. Qed.
  Goal open typ KType (Fr y) (Fr x) = Fr x. reflexivity. Qed.
  Goal open typ KType (Fr y) (Fr y) = Fr y. reflexivity. Qed.
  Goal open typ KType (Fr x) (∀ Bd 0) = (∀ (Bd 0)). reflexivity. Qed.
  Goal open typ KType (Fr x) (∀ Bd 1) = (∀ (Fr x)). reflexivity. Qed.
  Goal open typ KType (Fr x) (∀ (Bd 1 ⟹ Bd 0)) = (∀ Fr x ⟹ Bd 0). reflexivity. Qed.
  Goal open typ KType (Fr x) (∀ Bd 1 ⟹ Bd 2) = (∀ Fr x ⟹ Bd 1). reflexivity. Qed.

End example_computations.

(** * Proofs of the DTM axioms *)
(******************************************************************************)

(** ** Helper lemmas for proving DTM axioms *)
(******************************************************************************)
Section DTM_instance_lemmas.

  Context
    (W : Type)
    (S : Type -> Type)
    (T : K -> Type -> Type)
    `{! MReturn T}
    `{! MBind W T S}
    `{! forall k, MBind W T (T k)}
    {mn_op : Monoid_op W}
    {mn_unit : Monoid_unit W}.

  Lemma mbinddt_inst_law1_case1 : forall (A : Type) (t : S A) (w : W),
      (mbinddt S (fun A => A) (fun k => mret T k ∘ extract (W ×)) t = t) ->
      (mbinddt S (fun A => A) (fun k => mret T k ∘ extract (W ×) ∘ incr w) t = t).
  Proof.
    introv IH. rewrite <- IH at 2.
    fequal. ext k [w' a]. easy.
  Qed.

  Lemma mbinddt_inst_law1_case12 : forall (A : Type) (w : W),
      mbinddt S (fun A => A) (fun k => mret T k ∘ extract (W ×)) (A := A) =
      mbinddt S (fun A => A) (fun k => mret T k ∘ extract (W ×) ∘ incr w).
  Proof.
    introv. fequal. now ext k [w' a].
  Qed.

  Context
    `{Applicative G}
    `{Applicative F}
    `{! Monoid W}
    {A B C : Type}
    (g : forall k, W * B -> G (T k C))
    (f : forall k, W * A -> F (T k B)).

  (* for Var case *)
  Lemma mbinddt_inst_law2_case2 : forall (a : A) (k : K),
    fmap F (mbinddt (T k) G g) (f k (Ƶ, a)) =
    fmap F (mbinddt (T k) G (fun k => g k ∘ const (incr Ƶ) k)) (f k (Ƶ, a)).
  Proof.
    intros. repeat fequal. ext k' [w b].
    unfold compose. cbn. now simpl_monoid.
  Qed.

  Lemma compose_dtm_incr : forall (w : W),
      (fun k => (g ⋆dtm f) k ∘ incr w) =
      ((fun k => g k ∘ incr w) ⋆dtm (fun k => f k ∘ incr w)).
  Proof.
    intros. ext k [w' a].
    cbn. do 2 fequal.
    ext j [w'' b].
    unfold compose. cbn. fequal.
    now rewrite monoid_assoc.
  Qed.

End DTM_instance_lemmas.

Arguments compose_dtm_incr {W}%type_scope {T}%function_scope {H}%function_scope {mn_op mn_unit}
  {G}%function_scope {H0 H1 H2} {F}%function_scope {H4 H5 H6 Monoid0} {A B C}%type_scope (_
  _)%function_scope _.

(** ** <<mbinddt_mret>> *)
(******************************************************************************)
Lemma mbinddt_mret_typ : forall (A : Type),
    mbinddt typ (fun A => A) (fun k => mret SystemF k ∘ extract (list K2 ×)) = @id (typ A).
Proof.
  intros. ext t. unfold id. induction t.
  - cbn. reflexivity.
  - cbn. reflexivity.
  - cbn. fequal.
    + apply IHt1.
    + apply IHt2.
  - cbn. fequal.
    unfold preincr.
    rewrite <- mbinddt_inst_law1_case12.
    apply IHt.
Qed.

Lemma mbinddt_mret_term : forall (A : Type),
    mbinddt term (fun A => A) (fun k => mret SystemF k ∘ extract (list K2 ×)) = @id (term A).
Proof.
  intros. ext t. unfold id. induction t.
  - easy.
  - cbn. fequal.
    + change (bind_type ?F ?f) with (mbinddt typ F f).
      now rewrite mbinddt_mret_typ.
    + rewrite <- mbinddt_inst_law1_case12.
      apply IHt.
  - cbn. fequal.
    + apply IHt1.
    + apply IHt2.
  - cbn. fequal.
    rewrite <- mbinddt_inst_law1_case12.
    apply IHt.
  - cbn. fequal.
    + apply IHt.
    + now rewrite mbinddt_mret_typ.
Qed.

(** ** <<mbinddt_mbinddt>> *)
(******************************************************************************)
Lemma mbinddt_mbinddt_typ :
  forall (F : Type -> Type)
    (G : Type -> Type)
    `{Applicative F}
    `{Applicative G}
    `(g : forall k, list K2 * B -> G (SystemF k C))
    `(f : forall k, list K2 * A -> F (SystemF k B)),
    fmap F (mbinddt typ G g) ∘ mbinddt typ F f =
    mbinddt typ (F ∘ G) (g ⋆dtm f).
Proof.
  intros. ext t. generalize dependent f. generalize dependent g.
  unfold compose at 1. induction t; intros g f.
  - cbn.
    rewrite (app_pure_natural F).
    reflexivity.
  - cbn.
    change (MBind_type ?G H3 H4 H5 ?A ?B) with (mbinddt typ G (A := A) (B := B)).
    change [] with (Ƶ : list K2).
    change typ with (SystemF KType).
    rewrite <- (mbinddt_inst_law2_case2 (list K2) SystemF (H := MBind_SystemF )).
    reflexivity.
  - cbn.
    rewrite <- IHt1.
    rewrite <- IHt2.
    do 2 rewrite (ap_compose2 G F).
    rewrite <- (ap_fmap (G := F)).
    rewrite <- (ap_fmap (G := F)).
    do 2 rewrite fmap_ap.
    do 2 rewrite fmap_ap.
    do 3 (compose near (pure (F ∘ G) (ty_ar (V := C)));
          rewrite (fun_fmap_fmap F)).
    unfold_ops @Pure_compose.
    rewrite (app_pure_natural F).
    rewrite (app_pure_natural F).
    reflexivity.
  - cbn. setoid_rewrite compose_dtm_incr.
    rewrite <- IHt.
    rewrite (ap_compose2 G F).
    rewrite <- (ap_fmap (G := F)).
    compose near (pure (F ∘ G) (ty_univ (V := C))).
    rewrite (fun_fmap_fmap F).
    unfold_ops @Pure_compose.
    rewrite (app_pure_natural F).
    rewrite fmap_ap.
    rewrite (app_pure_natural F).
    reflexivity.
Qed.

Lemma mbinddt_mbinddt_term :
  forall (F : Type -> Type)
    (G : Type -> Type)
    `{Applicative F}
    `{Applicative G}
    `(g : forall k, list K2 * B -> G (SystemF k C))
    `(f : forall k, list K2 * A -> F (SystemF k B)),
    fmap F (mbinddt term G g) ∘ mbinddt term F f =
    mbinddt term (F ∘ G) (g ⋆dtm f).
Proof.
  intros. ext t. generalize dependent f. generalize dependent g.
  unfold compose at 1. induction t; intros g f.
  - cbn.
    change (MBind_term ?G H3 H4 H5 ?A ?B) with (mbinddt term G (A := A) (B := B)).
    fequal. fequal. now ext k [w a].
  - cbn.
    change (bind_type ?F ?f) with (mbinddt typ F f).
    setoid_rewrite compose_dtm_incr.
    rewrite <- IHt.
    rewrite <- (mbinddt_mbinddt_typ F G).
    unfold compose at 6.
    do 2 rewrite (ap_compose2 G F).
    unfold compose.
    do 2 rewrite <- (ap_fmap (G := F)).
    unfold_ops @Pure_compose.
    rewrite (app_pure_natural F).
    do 4 rewrite fmap_ap.
    compose near ((pure F (ap G (pure G (@tm_abs C))))).
    rewrite (fun_fmap_fmap F).
    do 3 rewrite (app_pure_natural F).
    reflexivity.
  - cbn.
    rewrite <- IHt1.
    rewrite <- IHt2.
    do 2 rewrite (ap_compose2 G F).
    do 2 rewrite <- (ap_fmap (G := F)).
    do 4 rewrite fmap_ap.
    compose near (pure (F ∘ G) (@tm_app C)).
    rewrite (fun_fmap_fmap F).
    compose near (pure (F ∘ G) (@tm_app C)).
    rewrite (fun_fmap_fmap F).
    compose near (pure (F ∘ G) (@tm_app C)).
    rewrite (fun_fmap_fmap F).
    unfold_ops @Pure_compose.
    do 2 rewrite (app_pure_natural F).
    reflexivity.
  - cbn.
    setoid_rewrite compose_dtm_incr.
    rewrite <- IHt.
    rewrite (ap_compose2 G F).
    rewrite <- (ap_fmap (G := F)).
    rewrite fmap_ap.
    unfold_ops @Pure_compose.
    do 3 rewrite (app_pure_natural F).
    reflexivity.
  - cbn.
    rewrite <- IHt.
    rewrite <- (mbinddt_mbinddt_typ F G).
    unfold compose at 4.
    do 2 rewrite (ap_compose2 G F).
    repeat rewrite <- (ap_fmap (G := F)).
    change (bind_type ?F ?f) with (mbinddt typ F f).
    do 4 rewrite fmap_ap.
    compose near (pure (F ∘ G) (@tm_tap C)).
    rewrite (fun_fmap_fmap F).
    compose near (pure (F ∘ G) (@tm_tap C)).
    rewrite (fun_fmap_fmap F).
    compose near (pure (F ∘ G) (@tm_tap C)).
    rewrite (fun_fmap_fmap F).
    unfold_ops @Pure_compose.
    rewrite (app_pure_natural F).
    rewrite (app_pure_natural F).
    reflexivity.
Qed.

(** ** <<mbinddt_morphism>> *)
(******************************************************************************)

#[local] Set Keyed Unification.

Lemma mbinddt_morphism_typ :
  forall (F : Type -> Type)
    (G : Type -> Type)
    `{ApplicativeMorphism F G ϕ}
    `(f : forall k, list K2 * A -> F (SystemF k B)),
    ϕ (typ B) ∘ mbinddt typ F f =
    mbinddt typ G (fun k => ϕ (SystemF k B) ∘ f k).
Proof.
  intros. ext t. generalize dependent f. unfold compose. induction t; intro f.
  - cbn. rewrite (appmor_pure F G). reflexivity.
  - reflexivity.
  - cbn.
    rewrite <- IHt1. clear IHt1.
    rewrite <- IHt2. clear IHt2.
    rewrite ap_morphism_1.
    rewrite ap_morphism_1.
    rewrite (appmor_pure F G).
    reflexivity.
  - cbn.
    rewrite <- IHt. clear IHt.
    rewrite ap_morphism_1.
    rewrite (appmor_pure F G).
    reflexivity.
Qed.

Lemma mbinddt_morphism_term :
  forall (F : Type -> Type)
    (G : Type -> Type)
    `{ApplicativeMorphism F G ϕ}
    `(f : forall k, list K2 * A -> F (SystemF k B)),
    ϕ (term B) ∘ mbinddt term F f =
    mbinddt term G (fun k => ϕ (SystemF k B) ∘ f k).
Proof.
  intros. ext t. generalize dependent f. unfold compose. induction t; intro f.
  - reflexivity.
  - cbn.
    rewrite <- IHt. clear IHt.
    do 2 rewrite ap_morphism_1.
    rewrite (appmor_pure F G).
    change (bind_type ?F ?f) with (mbinddt typ F f).
    compose near t on left.
    rewrite (mbinddt_morphism_typ F G).
    reflexivity.
  - cbn.
    rewrite <- IHt1. clear IHt1.
    rewrite <- IHt2. clear IHt2.
    rewrite ap_morphism_1.
    rewrite ap_morphism_1.
    rewrite (appmor_pure F G).
    reflexivity.
  - cbn.
    rewrite <- IHt. clear IHt.
    rewrite ap_morphism_1.
    rewrite (appmor_pure F G).
    reflexivity.
  - cbn.
    rewrite <- IHt. clear IHt.
    do 2 rewrite ap_morphism_1.
    rewrite (appmor_pure F G).
    change (bind_type ?F ?f) with (mbinddt typ F f).
    compose near t0 on left.
    rewrite (mbinddt_morphism_typ F G).
    reflexivity.
Qed.

#[local] Unset Keyed Unification.

(** ** <<mbinddt_comp_mret>> *)
(******************************************************************************)
Lemma mbinddt_comp_mret_typ :
  forall (F : Type -> Type)
    `{Applicative F}
    `(f : forall k, list K2 * A -> F (SystemF k B)),
    mbinddt typ F f ∘ mret SystemF KType = f KType ∘ pair nil.
Proof.
  reflexivity.
Qed.

Lemma mbinddt_comp_mret_term :
  forall (F : Type -> Type)
    `{Applicative F}
    `(f : forall k, list K2 * A -> F (SystemF k B)),
    mbinddt term F f ∘ mret SystemF KTerm = f KTerm ∘ pair nil.
Proof.
  reflexivity.
Qed.

Corollary mbinddt_comp_mret_F :
  forall k F `{Applicative F}
    `(f : forall k, (list K2) * A -> F (SystemF k B)),
    mbinddt (W := list K2) (T := SystemF) (SystemF k) F f ∘ mret SystemF k = (fun a => f k (Ƶ, a)).
Proof.
  intro k. destruct k.
  - apply mbinddt_comp_mret_typ.
  - apply mbinddt_comp_mret_term.
Qed.

(** ** <<DTPreModule>> instances *)
(******************************************************************************)
#[export] Instance DTP_typ: DTPreModule (list K2) typ SystemF :=
  {| dtp_mbinddt_mret := @mbinddt_mret_typ;
     dtp_mbinddt_mbinddt := @mbinddt_mbinddt_typ;
     dtp_mbinddt_morphism := @mbinddt_morphism_typ;
  |}.

#[export] Instance DTP_term: DTPreModule (list K2) term SystemF :=
  {| dtp_mbinddt_mret := @mbinddt_mret_term;
     dtp_mbinddt_mbinddt := @mbinddt_mbinddt_term;
     dtp_mbinddt_morphism := @mbinddt_morphism_term;
  |}.

#[export] Instance: forall k, DTPreModule (list K2) (SystemF k) SystemF :=
  fun k => match k with
        | KType => DTP_typ
        | KTerm => DTP_term
        end.

#[export] Instance: DTM (list K2) SystemF :=
  {| dtm_mbinddt_comp_mret := mbinddt_comp_mret_F;
  |}.

(** * System F type system and operational rules *)
(******************************************************************************)
Reserved Notation "Δ ; Γ ⊢ t : τ" (at level 90, t at level 99).

Import Tealeaves.Classes.Setlike.Functor.Notations.
Export LN.AtomSet.Notations.
Export LN.AssocList.Notations.

(** ** Contexts and well-formedness predicates *)
(******************************************************************************)

(** *** Context of type variables *)
Definition kind_ctx := alist unit.

(** *** Context of term variables *)
Definition type_ctx := alist (typ LN).

(** *** Well-formedness for kinding contexts *)
(** A kinding context is well-formed when its keys, i.e. type
    variables, are unique. *)
Definition ok_kind_ctx : kind_ctx -> Prop := uniq.

(** *** Well-formedness of type expressions in a kinding context *)
(** A type is well-formed in a kinding context <<Δ>> when all of its
    type variables appear in Δ and the type is locally closed. *)
Definition ok_type : kind_ctx -> typ LN -> Prop :=
  fun Δ τ => scoped typ KType τ (domset Δ) /\ locally_closed typ KType τ.

(** *** Well-formedness for typing contexts *)
(** A typing context <<Γ>> is well-formed in kinding context <<Δ>>
    when the keys of <<Γ>> (i.e. term variables) are unique, and each
    associated type is itself well-formed in context <<Δ>>. *)
Definition ok_type_ctx : kind_ctx -> type_ctx -> Prop :=
  fun Δ Γ => uniq Γ /\ forall τ, τ ∈ range Γ -> ok_type Δ τ.

(** *** Well-formedness of term expressions in context *)
(** A term <<t>> is well-formed in contexts <<Δ>> and <<Γ>> when its
    type variables are declared in <<Δ>>, its term variables are
    declared in <<Γ>>, and it is locally closed with respect to both
    kinds of variables. *)
Definition ok_term : kind_ctx -> type_ctx -> term LN -> Prop :=
  fun Δ Γ t => scoped term KType t (domset Δ) /\
            scoped term KTerm t (domset Γ) /\
            locally_closed term KTerm t /\
            locally_closed term KType t.

(** ** Typing judgments *)
(******************************************************************************)
Implicit Types (Δ : kind_ctx) (Γ : type_ctx) (τ : typ LN).

Inductive Judgment : kind_ctx -> type_ctx -> term LN -> typ LN -> Prop :=
| j_var :
    forall Δ Γ x τ,
      ok_kind_ctx Δ ->
      ok_type_ctx Δ Γ ->
      (x, τ) ∈ (Γ : list (atom * typ LN)) ->
      (Δ ; Γ ⊢ tm_var (Fr x) : τ)
| j_abs :
    forall Δ Γ L t τ1 τ2,
      (forall x, ~ x ∈@ L  ->
            Δ ; Γ ++ x ~ τ1 ⊢ open term KTerm (tm_var (Fr x)) t : τ2) ->
      (Δ ; Γ ⊢ tm_abs τ1 t : ty_ar τ1 τ2)
| j_app :
    forall Δ Γ t1 t2 τ1 τ2,
      (Δ ; Γ ⊢ t1 : ty_ar τ1 τ2) ->
      (Δ ; Γ ⊢ t2 : τ1) ->
      (Δ ; Γ ⊢ tm_app t1 t2 : τ2)
| j_univ :
    forall Δ Γ L τ t,
      (forall x, ~ x ∈@ L ->
            Δ ++ x ~ tt ; Γ ⊢ open term KType (ty_v (Fr x)) t
                          : open typ KType (ty_v (Fr x)) τ) ->
      (Δ ; Γ ⊢ tm_tab t : ty_univ τ)
| j_inst :
    forall Δ Γ t τ1 τ2,
      ok_type Δ τ1 ->
      (Δ ; Γ ⊢ t : ty_univ τ2) ->
      (Δ ; Γ ⊢ tm_tap t τ1 : open typ KType τ1 τ2)
where "Δ ; Γ ⊢ t : τ" := (Judgment Δ Γ t τ).

(** ** Values and reduction rules *)
(******************************************************************************)
Inductive value : term LN -> Prop :=
| val_abs : forall T t, value (tm_abs T t)
| val_tab : forall t, value (tm_tab t).

Inductive red : term LN -> term LN -> Prop :=
| red_app_l : forall t1 t1' t2,
    red t1 t1' ->
    red (tm_app t1 t2) (tm_app t1' t2)
| red_app_r : forall t1 t2 t2',
    value t1 ->
    red t2 t2' ->
    red (tm_app t1 t2) (tm_app t1 t2')
| red_abs : forall T t1 t2,
    value t2 ->
    red (tm_app (tm_abs T t1) t2) (open term KTerm t2 t1)
| red_tapl : forall t t' T,
    red t t' ->
    red (tm_tap t T) (tm_tap t' T)
| red_tab : forall T t,
    red (tm_tap (tm_tab t) T) (open term KType T t).

Definition preservation := forall t t' τ,
    (nil ; nil ⊢ t : τ) ->
    red t t' ->
    (nil ; nil ⊢ t' : τ).

Definition progress := forall t τ,
    (nil ; nil ⊢ t : τ) ->
    value t \/ exists t', red t t'.

(*
(** ** Example: Typing the polymorphic identity *)
(******************************************************************************)
Example polymorphic_identity_function :
  (nil ; nil ⊢ (Λ λ 0 ⋅ 0) : (∀ 0 ⟹ 0)).
Proof.
  apply j_univ with (L := ∅). introv _.
  cbn. apply j_abs with (L := ∅).
  - introv _. apply j_var.
    + auto with sysf_ctx.
    + simpl_alist. apply ok_tmv_tm_one.
      unfold ok_type, scoped_env, scoped.
      autorewrite with sysf_rw tea_rw_dom.
      split; [fsetdec | apply lc_ty_ty_Fr].
    + simpl_alist. now autorewrite with tea_list.
Qed.
*)


From Bremen.theories.rhythm Require Import Duration.
From Bremen.theories.physics Require Import Dynamics.
From Bremen.theories.structure Require Import MelodicPart.
Require Import List.
Import ListNotations.

Inductive harmonic_part : Type :=
  | first_melodic_part_at_start : melodic_part -> harmonic_part
  | melodic_part_at_start       : melodic_part -> harmonic_part -> harmonic_part
  | melodic_part_later          : duration -> melodic_part -> harmonic_part -> harmonic_part.

Definition harmonic_part1 :=
  melodic_part_later (Whole_) melody1 (
  melodic_part_at_start melody1 (
  first_melodic_part_at_start (melody1))).

Fixpoint part_durations (h : harmonic_part) : list duration :=
  match h with
  | first_melodic_part_at_start x => match duration_of x with
    | None => []
    | Some z => [z]
    end
  | melodic_part_at_start x y => match duration_of x with
    | None => part_durations y
    | Some z => concat [[z]; part_durations y]
    end
  | melodic_part_later d x y =>  match duration_of x with
    | None => part_durations y
    | Some z => concat [[tie z d]; part_durations y]
    end
  end.

Fixpoint max_duration (dl : list duration) (default : duration ): duration :=
  match dl with
  | [] => default
  | x :: rest => match max_duration rest default with | y =>
    if longer_equal x y then x else y end
  end.

Definition duration_of (h : harmonic_part) : duration :=
  max_duration (part_durations h) (Quarter_).

Eval compute in duration_of harmonic_part1.


Require Import Poulet4.P4light.Syntax.P4defs.
Require Import Poulet4.P4light.Semantics.Semantics.
Require Import ProD3.core.Core.
Require Import ProD3.core.Tofino.
Require Import ProD3.examples.sbf.p4ast.
Require Import ProD3.examples.sbf.ConFilter.
Require Import ProD3.examples.sbf.common.
Require Import ProD3.examples.sbf.FilterRepr.
Require Import ProD3.examples.sbf.verif_Win1.
Require Import ProD3.examples.sbf.verif_Win2.
Require Import ProD3.examples.sbf.verif_Win3.
Require Import ProD3.examples.sbf.verif_Win4.
Require Import Hammer.Plugin.Hammer.
Require Export Coq.Program.Program.
Import ListNotations.

Notation ident := string.
Notation path := (list ident).
Notation Val := (@ValueBase bool).
Notation Sval := (@ValueBase (option bool)).

Definition p := ["pipe"; "ingress"; "bf2_ds"].

Definition act_hash_index_1_fd :=
  ltac:(get_fd ["Bf2BloomFilter"; "act_hash_index_1"] ge).

Definition act_hash_index_1_spec : func_spec :=
  WITH (* p *),
    PATH p
    MOD (Some [["ds_md"]; ["act_hash_index_1"; "t'0"]]) []
    WITH (key : Val) (ds_md : Sval),
      PRE
        (ARG []
        (MEM [(["ds_key"], eval_val_to_sval key); (["ds_md"], ds_md)]
        (EXT [])))
      POST
        (ARG_RET [] ValBaseNull
        (MEM [(["ds_md"], update "hash_index_1" (P4Bit index_w (hash1 key)) ds_md)]
        (EXT []))).

(*  action act_hash_index_1() {
        ds_md.hash_index_1 = hash_idx_1.get(ds_key)[17:0];
    }
*)

Lemma act_hash_index_1_body :
  func_sound ge act_hash_index_1_fd nil act_hash_index_1_spec.
Proof.
  start_function.
  step_call @Hash_get_body.
  { entailer. }
  { compute. reflexivity. }
  { compute. reflexivity. }
  step.
  step.
  simpl sval_to_bits_width.
  cbv match.
  rewrite bitstring_slice_lower_bit with (w' := index_w) by lia.
  entailer.
  { apply sval_refine_refl'.
    f_equal.
    apply P4Bit_mod_eq.
    unfold hash1.
    rewrite Z.mod_mod by lia.
    auto.
  }
Qed.

#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply act_hash_index_1_body) : func_specs.

Definition tbl_hash_index_1_fd :=
  ltac:(get_fd ["Bf2BloomFilter"; "tbl_hash_index_1"; "apply"] ge).

Definition tbl_hash_index_1_spec : func_spec :=
  WITH (* p *),
    PATH p
    MOD (Some [["ds_md"]; ["act_hash_index_1"; "t'0"]]) []
    WITH (key : Val) (ds_md : Sval),
      PRE
        (ARG []
        (MEM [(["ds_key"], eval_val_to_sval key); (["ds_md"], ds_md)]
        (EXT [])))
      POST
        (EX retv,
        (ARG_RET [] retv
        (MEM [(["ds_md"], update "hash_index_1" (P4Bit index_w (hash1 key)) ds_md)]
        (EXT []))))%arg_ret_assr.

Lemma tbl_hash_index_1_body :
  func_sound ge tbl_hash_index_1_fd nil tbl_hash_index_1_spec.
Proof.
  start_function.
  table_action act_hash_index_1_body.
  { entailer. }
  { entailer. }
Qed.

#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply tbl_hash_index_1_body) : func_specs.

Definition act_hash_index_2_fd :=
  ltac:(get_fd ["Bf2BloomFilter"; "act_hash_index_2"] ge).

Definition act_hash_index_2_spec : func_spec :=
  WITH (* p *),
    PATH p
    MOD (Some [["ds_md"]; ["act_hash_index_2"; "t'1"]]) []
    WITH (key : Val) (ds_md : Sval),
      PRE
        (ARG []
        (MEM [(["ds_key"], eval_val_to_sval key); (["ds_md"], ds_md)]
        (EXT [])))
      POST
        (ARG_RET [] ValBaseNull
        (MEM [(["ds_md"], update "hash_index_2" (P4Bit index_w (hash2 key)) ds_md)]
        (EXT []))).

(*  action act_hash_index_2() {
        ds_md.hash_index_2 = hash_idx_2.get(ds_key)[17:0];
    }
*)

Lemma act_hash_index_2_body :
  func_sound ge act_hash_index_2_fd nil act_hash_index_2_spec.
Proof.
  start_function.
  step_call @Hash_get_body.
  { entailer. }
  { compute. reflexivity. }
  { compute. reflexivity. }
  step.
  step.
  simpl sval_to_bits_width.
  cbv match.
  rewrite bitstring_slice_lower_bit with (w' := index_w) by lia.
  entailer.
  { apply sval_refine_refl'.
    f_equal.
    apply P4Bit_mod_eq.
    unfold hash2.
    rewrite Z.mod_mod by lia.
    auto.
  }
Qed.

#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply act_hash_index_2_body) : func_specs.

Definition tbl_hash_index_2_fd :=
  ltac:(get_fd ["Bf2BloomFilter"; "tbl_hash_index_2"; "apply"] ge).

Definition tbl_hash_index_2_spec : func_spec :=
  WITH (* p *),
    PATH p
    MOD (Some [["ds_md"]; ["act_hash_index_2"; "t'1"]]) []
    WITH (key : Val) (ds_md : Sval),
      PRE
        (ARG []
        (MEM [(["ds_key"], eval_val_to_sval key); (["ds_md"], ds_md)]
        (EXT [])))
      POST
        (EX retv,
        (ARG_RET [] retv
        (MEM [(["ds_md"], update "hash_index_2" (P4Bit index_w (hash2 key)) ds_md)]
        (EXT []))))%arg_ret_assr.

Lemma tbl_hash_index_2_body :
  func_sound ge tbl_hash_index_2_fd nil tbl_hash_index_2_spec.
Proof.
  start_function.
  table_action act_hash_index_2_body.
  { entailer. }
  { entailer. }
Qed.

#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply tbl_hash_index_2_body) : func_specs.

Definition act_hash_index_3_fd :=
  ltac:(get_fd ["Bf2BloomFilter"; "act_hash_index_3"] ge).

Definition act_hash_index_3_spec : func_spec :=
  WITH (* p *),
    PATH p
    MOD (Some [["ds_md"]; ["act_hash_index_3"; "t'2"]]) []
    WITH (key : Val) (ds_md : Sval),
      PRE
        (ARG []
        (MEM [(["ds_key"], eval_val_to_sval key); (["ds_md"], ds_md)]
        (EXT [])))
      POST
        (ARG_RET [] ValBaseNull
        (MEM [(["ds_md"], update "hash_index_3" (P4Bit index_w (hash3 key)) ds_md)]
        (EXT []))).

(*  action act_hash_index_3() {
        ds_md.hash_index_3 = hash_idx_3.get(ds_key)[17:0];
    }
*)

Lemma act_hash_index_3_body :
  func_sound ge act_hash_index_3_fd nil act_hash_index_3_spec.
Proof.
  start_function.
  step_call @Hash_get_body.
  { entailer. }
  { compute. reflexivity. }
  { compute. reflexivity. }
  step.
  step.
  simpl sval_to_bits_width.
  cbv match.
  rewrite bitstring_slice_lower_bit with (w' := index_w) by lia.
  entailer.
  { apply sval_refine_refl'.
    f_equal.
    apply P4Bit_mod_eq.
    unfold hash3.
    rewrite Z.mod_mod by lia.
    auto.
  }
Qed.

#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply act_hash_index_3_body) : func_specs.

Definition tbl_hash_index_3_fd :=
  ltac:(get_fd ["Bf2BloomFilter"; "tbl_hash_index_3"; "apply"] ge).

Definition tbl_hash_index_3_spec : func_spec :=
  WITH (* p *),
    PATH p
    MOD (Some [["ds_md"]; ["act_hash_index_3"; "t'2"]]) []
    WITH (key : Val) (ds_md : Sval),
      PRE
        (ARG []
        (MEM [(["ds_key"], eval_val_to_sval key); (["ds_md"], ds_md)]
        (EXT [])))
      POST
        (EX retv,
        (ARG_RET [] retv
        (MEM [(["ds_md"], update "hash_index_3" (P4Bit index_w (hash3 key)) ds_md)]
        (EXT []))))%arg_ret_assr.

Lemma tbl_hash_index_3_body :
  func_sound ge tbl_hash_index_3_fd nil tbl_hash_index_3_spec.
Proof.
  start_function.
  table_action act_hash_index_3_body.
  { entailer. }
  { entailer. }
Qed.

#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply tbl_hash_index_3_body) : func_specs.

Definition regact_clear_index_apply_body :=
  ltac:(auto_regact ge am_ge (p ++ ["regact_clear_index"])).

Definition regact_clear_index_execute_body :=
  ltac:(build_execute_body ge regact_clear_index_apply_body).

#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply regact_clear_index_execute_body) : func_specs.

Definition act_clear_index_fd :=
  ltac:(get_fd ["Bf2BloomFilter"; "act_clear_index"] ge).

Definition act_clear_index_spec : func_spec :=
  WITH (* p *),
    PATH p
    MOD (Some [["ds_md"]; ["act_clear_index"; "t'3"]]) [p ++ ["reg_clear_index"]]
    WITH (i : Z) (ds_md : Sval),
      PRE
        (ARG []
        (MEM [(["ds_md"], ds_md)]
        (EXT [fil_clear_index_repr p index_w i])))
      POST
        (ARG_RET [] ValBaseNull
        (MEM [(["ds_md"], update "clear_index_1" (P4Bit index_w i) ds_md)]
        (EXT [fil_clear_index_repr p index_w (update_clear_index (num_slots := num_slots) i)]))).

Lemma act_clear_index_body :
  func_sound ge act_clear_index_fd nil act_clear_index_spec.
Proof.
  start_function.
  unfold fil_clear_index_repr.
  Intros i'.
  normalize_EXT.
  Intros_prop.
  step_call regact_clear_index_execute_body.
  { entailer. }
  { reflexivity. }
  { simpl; lia. }
  { simpl. list_solve. }
  step.
  step.
  entailer.
  { apply sval_refine_refl'.
    f_equal.
    cbn [sval_to_bits_width P4Bit].
    rewrite bitstring_slice_lower_bit with (w' := index_w). 2, 3 : lia.
    apply P4Bit_mod_eq.
    pose proof (Z.mod_pos_bound i' (2 ^ Z.of_N index_w) ltac:(lia)).
    replace (i mod 2 ^ Z.of_N index_w) with i. 2 : {
      symmetry; apply Z.mod_small; lia.
    }
    auto.
  }
  { simpl.
    Exists (i' + 1).
    normalize_EXT.
    entailer.
    apply ext_implies_prop_intro.
    unfold update_clear_index.
    change (Z.pow_pos 2 _) with (2 ^ Z.of_N index_w).
    assert (0 <= i < num_slots) by (subst; apply Z.mod_pos_bound; reflexivity).
    rewrite Zplus_mod, H. clear H.
    destruct (i + 1 =? num_slots) eqn:?H.
    - assert (i = num_slots - 1) by lia.
      subst; auto.
    - rewrite Z.mod_small with (a := i + 1); auto.
      lia.
  }
Qed.

#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply act_clear_index_body) : func_specs.

Definition tbl_clear_index_fd :=
  ltac:(get_fd ["Bf2BloomFilter"; "tbl_clear_index"; "apply"] ge).

Definition tbl_clear_index_spec : func_spec :=
  WITH (* p *),
    PATH p
    MOD (Some [["ds_md"]; ["act_clear_index"; "t'3"]]) [p ++ ["reg_clear_index"]]
    WITH (i : Z) (ds_md : Sval),
      PRE
        (ARG []
        (MEM [(["ds_md"], ds_md)]
        (EXT [fil_clear_index_repr p index_w i])))
      POST
        (EX retv,
        (ARG_RET [] retv
        (MEM [(["ds_md"], update "clear_index_1" (P4Bit index_w i) ds_md)]
        (EXT [fil_clear_index_repr p index_w (update_clear_index (num_slots := num_slots) i)]))))%arg_ret_assr.

Lemma tbl_clear_index_body :
  func_sound ge tbl_clear_index_fd nil tbl_clear_index_spec.
Proof.
  start_function.
  table_action act_clear_index_body.
  { entailer. }
  { entailer. }
Qed.

#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply tbl_clear_index_body) : func_specs.

Definition regact_clear_window_signal_0_apply_fd :=
  ltac:(get_am_fd ge am_ge (p ++ ["regact_clear_window_signal_0"; "apply"])).

Notation update_timer := (@update_timer num_frames frame_tick_tocks).

Definition regact_clear_window_signal_0_apply_spec : func_spec :=
  RegisterAction_apply_spec' (p ++ ["regact_clear_window_signal_0"]) (fun t => 0 <= fst t < 28136) timer_repr_val
    (fun t => update_timer t false) (fun t => P4Bit 16 (fst (update_timer t false))).

(*  RegisterAction<window_pair_t, bit<1>, window_t>(reg_clear_window) regact_clear_window_signal_0 = {
        void apply(inout window_pair_t val, out window_t rv) {
            if ((val.lo != 16w0))
            {
                val.hi = (val.hi + 16w1);
                val.lo = 16w0;
            }
            rv = val.hi;
        }
    };
*)

Lemma regact_clear_window_signal_0_apply_body :
  func_sound am_ge regact_clear_window_signal_0_apply_fd nil regact_clear_window_signal_0_apply_spec.
Proof.
  start_function.
  rename old_value into t.
  change (eval_val_to_sval (timer_repr_val t)) with (timer_repr_sval t).
  unfold timer_repr_sval in *.
  step.
  step.
  step.
  (* TODO fix this bug in semantics:
    why we have ["rv"] here?
    when generating uninitialized value for out parameters, the locators in these are not properly set.
  *)
  step_if (MEM [(["apply"; "val"], timer_repr_sval (update_timer t false))]
          (EXT [])).
  { unfold timer_repr_sval in *.
    step.
    step_if.
    { step.
      step.
      step.
      step.
      destruct t as [? []]; inv H.
      simpl fst in *.
      change (P4Arith.BitArith.mod_bound 16 28135) with 28135 in H0.
      replace (P4Arith.BitArith.mod_bound 16 z) with z in H0. 2 : {
        unfold P4Arith.BitArith.mod_bound.
        rewrite Z.mod_small; auto.
        change (P4Arith.BitArith.upper_bound 16) with 65536.
        lia.
      }
      unfold update_timer.
      simpl.
      destruct (z =? 28135); inv H0.
      entailer.
    }
    { step.
      step.
      step.
      step.
      destruct t as [? []]; inv H.
      simpl fst in *.
      change (P4Arith.BitArith.mod_bound 16 28135) with 28135 in H0.
      replace (P4Arith.BitArith.mod_bound 16 z) with z in H0. 2 : {
        unfold P4Arith.BitArith.mod_bound.
        rewrite Z.mod_small; auto.
        change (P4Arith.BitArith.upper_bound 16) with 65536.
        lia.
      }
      unfold update_timer.
      simpl.
      destruct (z =? 28135); inv H0.
      entailer.
    }
  }
  { unfold timer_repr_sval in *.
    step.
    step.
    step.
    step.
    destruct t as [? []]; inv H.
    entailer.
  }
  step.
  step.
  entailer.
Qed.

Definition regact_clear_window_signal_0_execute_body :=
  ltac:(build_execute_body ge regact_clear_window_signal_0_apply_body).

Definition regact_clear_window_signal_1_apply_fd :=
  ltac:(get_am_fd ge am_ge (p ++ ["regact_clear_window_signal_1"; "apply"])).

Definition regact_clear_window_signal_1_apply_spec : func_spec :=
  RegisterAction_apply_spec (p ++ ["regact_clear_window_signal_1"]) timer_repr_val
    (fun t => update_timer t true) (fun t => P4Bit 16 (fst (update_timer t true))).

(*  RegisterAction<window_pair_t, bit<1>, window_t>(reg_clear_window) regact_clear_window_signal_1 = {
        void apply(inout window_pair_t val, out window_t rv) {
            if ((val.hi == 16w28136))
            {
                val.hi = 16w0;
            }
            if ((val.lo != 16w1))
            {
                val.lo = 16w1;
            }
            rv = val.hi;
        }
    };
*)

Lemma regact_clear_window_signal_1_apply_body :
  func_sound am_ge regact_clear_window_signal_1_apply_fd nil regact_clear_window_signal_1_apply_spec.
Proof.
  start_function.
  rename old_value into t.
  change (eval_val_to_sval (timer_repr_val t)) with (timer_repr_sval t).
  unfold timer_repr_sval in *.
  step.
  step_if (MEM [(["apply"; "val"], timer_repr_sval (update_timer t true))]
          (EXT [])).
  { step.
    step.
    step.
    destruct t as [? []]; inv H.
    entailer.
  }
  { step.
    destruct t as [? []]; inv H.
    entailer.
  }
  step.
  step.
  entailer.
Qed.

Definition regact_clear_window_signal_1_execute_body :=
  ltac:(build_execute_body ge regact_clear_window_signal_1_apply_body).

#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply regact_clear_window_signal_0_execute_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply regact_clear_window_signal_1_execute_body) : func_specs.

Definition act_clear_window_signal_0_fd :=
  ltac:(get_fd ["Bf2BloomFilter"; "act_clear_window_signal_0"] ge).

Notation timer_repr := (@timer_repr num_frames frame_tick_tocks).

Definition act_clear_window_signal_0_spec : func_spec :=
  WITH (* p *),
    PATH p
    MOD (Some [["ds_md"]]) [p ++ ["reg_clear_window"]]
    WITH (t : Z * bool) (ds_md : Sval),
      PRE
        (ARG []
        (MEM [(["ds_md"], ds_md)]
        (EXT [timer_repr p t])))
      POST
        (ARG_RET [] ValBaseNull
        (MEM [(["ds_md"], update "clear_window" (P4Bit 16 (fst (update_timer t false))) ds_md)]
        (EXT [timer_repr p (update_timer t false)]))).

(*  action act_clear_window_signal_0() {
        ds_md.clear_window = regact_clear_window_signal_0.execute(1w0);
    }
*)

Lemma act_clear_window_signal_0_body :
  func_sound ge act_clear_window_signal_0_fd nil act_clear_window_signal_0_spec.
Proof.
  start_function.
  unfold timer_repr.
  normalize_EXT.
  Intros_prop.
  step_call regact_clear_window_signal_0_execute_body.
  { entailer. }
  { auto. }
  { lia. }
  { reflexivity. }
  { auto. }
  step.
  entailer.
  simpl ext_exclude.
  apply ext_implies_prop_intro.
  apply update_timer_wf; auto; lia.
Qed.

Definition act_clear_window_signal_1_fd :=
  ltac:(get_fd ["Bf2BloomFilter"; "act_clear_window_signal_1"] ge).

Definition act_clear_window_signal_1_spec : func_spec :=
  WITH (* p *),
    PATH p
    MOD (Some [["ds_md"]]) [p ++ ["reg_clear_window"]]
    WITH (t : Z * bool) (ds_md : Sval),
      PRE
        (ARG []
        (MEM [(["ds_md"], ds_md)]
        (EXT [timer_repr p t])))
      POST
        (ARG_RET [] ValBaseNull
        (MEM [(["ds_md"], update "clear_window" (P4Bit 16 (fst (update_timer t true))) ds_md)]
        (EXT [timer_repr p (update_timer t true)]))).

(*  action act_clear_window_signal_1() {
        ds_md.clear_window = regact_clear_window_signal_1.execute(1w0);
    }
*)

Lemma act_clear_window_signal_1_body :
  func_sound ge act_clear_window_signal_1_fd nil act_clear_window_signal_1_spec.
Proof.
  start_function.
  unfold timer_repr.
  normalize_EXT.
  Intros_prop.
  step_call regact_clear_window_signal_1_execute_body.
  { entailer. }
  { auto. }
  { lia. }
  { reflexivity. }
  step.
  entailer.
  apply ext_implies_prop_intro.
  apply update_timer_wf; auto; lia.
Qed.

#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply act_clear_window_signal_0_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply act_clear_window_signal_1_body) : func_specs.

Definition tbl_clear_window_fd :=
  ltac:(get_fd ["Bf2BloomFilter"; "tbl_clear_window"; "apply"] ge).

Definition tbl_clear_window_spec : func_spec :=
  WITH (* p *),
    PATH p
    MOD (Some [["ds_md"]]) [p ++ ["reg_clear_window"]]
    WITH (t : Z * bool) (ds_md : Sval) (tstamp : Z),
      PRE
        (ARG []
        (MEM [(["ds_md"], ds_md); (["ingress_mac_tstamp"], P4Bit 48 tstamp)]
        (EXT [timer_repr p t])))
      POST
        (EX retv,
        (ARG_RET [] retv
        (MEM [(["ds_md"], update "clear_window" (P4Bit 16 (fst (update_timer t (Z.odd (tstamp / 2097152))))) ds_md)]
        (EXT [timer_repr p (update_timer t (Z.odd (tstamp / 2097152)))]))))%arg_ret_assr.

(*  table tbl_clear_window {
        key = {
            ingress_mac_tstamp : ternary;
        }
        actions = {
            act_clear_window_signal_0();
            act_clear_window_signal_1();
        }
        const entries = {
            48w0 &&& 48w2097152 : act_clear_window_signal_0();
            _ : act_clear_window_signal_1();
        }
        default_action = act_clear_window_signal_1();
        size = 2;
    }
*)

Lemma tbl_clear_window_body :
  func_sound ge tbl_clear_window_fd nil tbl_clear_window_spec.
Proof.
  start_function; elim_trivial_cases.
  { repeat rewrite Z.div_div in H by lia.
    simpl in H.
    destruct (Z.odd (tstamp / 2097152)); try solve [inv H].
    table_action act_clear_window_signal_0_body.
    { entailer. }
    { entailer. }
  }
  { repeat rewrite Z.div_div in H by lia.
    simpl in H.
    destruct (Z.odd (tstamp / 2097152)); try solve [inv H].
    table_action act_clear_window_signal_1_body.
    { entailer. }
    { entailer. }
  }
Qed.

#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply tbl_clear_window_body) : func_specs.

Definition act_set_clear_win_1_fd :=
  ltac:(get_fd ["Bf2BloomFilter"; "act_set_clear_win_1"] ge).

(* Definition act_set_clear_win_1_spec : func_spec :=
  WITH (* p *),
    PATH p
    MOD (Some [["ds_md"];
               ["act_set_clear_win_1"; "api_1"];
               ["act_set_clear_win_1"; "api_2"];
               ["act_set_clear_win_1"; "api_3"];
               ["act_set_clear_win_1"; "api_4"]]) []
    WITH (ds_md : Sval) (api_1 api_2 api_3 api_4 : Sval),
      PRE
        (ARG [api_1; api_2; api_3; api_4]
        (MEM [(["ds_md"], ds_md)]
        (EXT [])))
      POST
        (ARG_RET [] ValBaseNull
        (MEM [
          (["ds_md"], update "win_1" (
            update "index_1" (get "clear_index_1" ds_md)
            (update "index_2" (get "clear_index_1" ds_md)
            (update "index_3" (get "clear_index_1" ds_md) (get "win_1" ds_md))))
            ds_md)]
        (EXT []))).

Lemma act_set_clear_win_1_body :
  func_sound ge act_set_clear_win_1_fd nil act_set_clear_win_1_spec.
Proof.
  start_function.
  assert (has_field "win_1" ds_md) by admit.
  assert (has_field "win_2" ds_md) by admit.
  assert (has_field "win_3" ds_md) by admit.
  assert (has_field "win_4" ds_md) by admit.
  simpl.
  Time step.
  simpl.
  Time step.
  simpl.

Ltac rewrite_get_update_same :=
  rewrite get_update_same by (auto using has_field_update).

Ltac rewrite_get_update_diff :=
  rewrite get_update_diff; [ | auto using has_field_update | discriminate].

Ltac rewrite_update_update_same :=
  rewrite update_update_same by (auto using has_field_update).

Ltac get_update_simpl :=
  repeat first [
    rewrite_get_update_same
  | rewrite_get_update_diff
  | rewrite_update_update_same
  ].

  get_update_simpl.
  Time step.
  Time simpl; get_update_simpl.
  Time step.
  Time simpl; get_update_simpl.
  Time step.
  Time simpl; get_update_simpl.
  Time step.
  Time simpl; get_update_simpl.
  Time step.
  Time simpl; get_update_simpl.
  Time step.
  Time simpl; get_update_simpl.
  Time step.
  Time simpl; get_update_simpl.
  Time step.
  Time simpl; get_update_simpl.
  Time step.
  Time simpl; get_update_simpl.
  Time step.
  Time simpl; get_update_simpl.
  Time step.
  Time simpl; get_update_simpl.
  Time step.
  Time simpl; get_update_simpl.
  Time step.
  Time simpl; get_update_simpl.
  Time step.
  Time simpl; get_update_simpl.
  (* Then we need a update_update_diff rule and guide it nicely. *)
Abort. *)

Definition P4_bf2_win_md_t_ :=
  ValBaseStruct
    [("api", P4Bit_ 8);
     ("index_1", P4Bit_ index_w);
     ("index_2", P4Bit_ index_w);
     ("index_3", P4Bit_ index_w);
     ("rw_1", P4Bit_ 8);
     ("rw_2", P4Bit_ 8);
     ("rw_3", P4Bit_ 8)].

Definition P4_bf2_win_md_t (op : Sval) (is : list Sval) :=
  ValBaseStruct
    [("api", op);
     ("index_1", Znth 0 is);
     ("index_2", Znth 1 is);
     ("index_3", Znth 2 is);
     ("rw_1", P4Bit_ 8);
     ("rw_2", P4Bit_ 8);
     ("rw_3", P4Bit_ 8)].

Definition act_set_clear_win_1_spec : func_spec :=
  WITH (* p *),
    PATH p
    MOD (Some [["ds_md"];
               ["act_set_clear_win_1"; "api_1"];
               ["act_set_clear_win_1"; "api_2"];
               ["act_set_clear_win_1"; "api_3"];
               ["act_set_clear_win_1"; "api_4"]]) []
    WITH (clear_window clear_index_1 hash_index_1 hash_index_2 hash_index_3: Sval) (api_1 api_2 api_3 api_4 : Sval),
      PRE
        (ARG [api_1; api_2; api_3; api_4]
        (MEM [(["ds_md"], ValBaseStruct
                 [("clear_window", clear_window);
                  ("clear_index_1", clear_index_1);
                  ("hash_index_1", hash_index_1);
                  ("hash_index_2", hash_index_2);
                  ("hash_index_3", hash_index_3);
                  ("win_1", P4_bf2_win_md_t_);
                  ("win_2", P4_bf2_win_md_t_);
                  ("win_3", P4_bf2_win_md_t_);
                  ("win_4", P4_bf2_win_md_t_)])]
        (EXT [])))
      POST
        (ARG_RET [] ValBaseNull
        (MEM [(["ds_md"], ValBaseStruct
                 [("clear_window", clear_window);
                  ("clear_index_1", clear_index_1);
                  ("hash_index_1", hash_index_1);
                  ("hash_index_2", hash_index_2);
                  ("hash_index_3", hash_index_3);
                  ("win_1", P4_bf2_win_md_t api_1 [clear_index_1; clear_index_1; clear_index_1]);
                  ("win_2", P4_bf2_win_md_t api_2 [hash_index_1; hash_index_2; hash_index_3]);
                  ("win_3", P4_bf2_win_md_t api_3 [hash_index_1; hash_index_2; hash_index_3]);
                  ("win_4", P4_bf2_win_md_t api_4 [hash_index_1; hash_index_2; hash_index_3])])]
        (EXT []))).

Lemma act_set_clear_win_1_body :
  func_sound ge act_set_clear_win_1_fd nil act_set_clear_win_1_spec.
Proof.
  start_function.
  unfold P4_bf2_win_md_t_.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  entailer.
Qed.

Definition act_set_clear_win_2_fd :=
  ltac:(get_fd ["Bf2BloomFilter"; "act_set_clear_win_2"] ge).

Definition act_set_clear_win_2_spec : func_spec :=
  WITH (* p *),
    PATH p
    MOD (Some [["ds_md"];
               ["act_set_clear_win_2"; "api_1"];
               ["act_set_clear_win_2"; "api_2"];
               ["act_set_clear_win_2"; "api_3"];
               ["act_set_clear_win_2"; "api_4"]]) []
    WITH (clear_window clear_index_1 hash_index_1 hash_index_2 hash_index_3: Sval) (api_1 api_2 api_3 api_4 : Sval),
      PRE
        (ARG [api_1; api_2; api_3; api_4]
        (MEM [(["ds_md"], ValBaseStruct
                 [("clear_window", clear_window);
                  ("clear_index_1", clear_index_1);
                  ("hash_index_1", hash_index_1);
                  ("hash_index_2", hash_index_2);
                  ("hash_index_3", hash_index_3);
                  ("win_1", P4_bf2_win_md_t_);
                  ("win_2", P4_bf2_win_md_t_);
                  ("win_3", P4_bf2_win_md_t_);
                  ("win_4", P4_bf2_win_md_t_)])]
        (EXT [])))
      POST
        (ARG_RET [] ValBaseNull
        (MEM [(["ds_md"], ValBaseStruct
                 [("clear_window", clear_window);
                  ("clear_index_1", clear_index_1);
                  ("hash_index_1", hash_index_1);
                  ("hash_index_2", hash_index_2);
                  ("hash_index_3", hash_index_3);
                  ("win_1", P4_bf2_win_md_t api_1 [hash_index_1; hash_index_2; hash_index_3]);
                  ("win_2", P4_bf2_win_md_t api_2 [clear_index_1; clear_index_1; clear_index_1]);
                  ("win_3", P4_bf2_win_md_t api_3 [hash_index_1; hash_index_2; hash_index_3]);
                  ("win_4", P4_bf2_win_md_t api_4 [hash_index_1; hash_index_2; hash_index_3])])]
        (EXT []))).

Lemma act_set_clear_win_2_body :
  func_sound ge act_set_clear_win_2_fd nil act_set_clear_win_2_spec.
Proof.
  start_function.
  unfold P4_bf2_win_md_t_.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  entailer.
Qed.

Definition act_set_clear_win_3_fd :=
  ltac:(get_fd ["Bf2BloomFilter"; "act_set_clear_win_3"] ge).

Definition act_set_clear_win_3_spec : func_spec :=
  WITH (* p *),
    PATH p
    MOD (Some [["ds_md"];
               ["act_set_clear_win_3"; "api_1"];
               ["act_set_clear_win_3"; "api_2"];
               ["act_set_clear_win_3"; "api_3"];
               ["act_set_clear_win_3"; "api_4"]]) []
    WITH (clear_window clear_index_1 hash_index_1 hash_index_2 hash_index_3: Sval) (api_1 api_2 api_3 api_4 : Sval),
      PRE
        (ARG [api_1; api_2; api_3; api_4]
        (MEM [(["ds_md"], ValBaseStruct
                 [("clear_window", clear_window);
                  ("clear_index_1", clear_index_1);
                  ("hash_index_1", hash_index_1);
                  ("hash_index_2", hash_index_2);
                  ("hash_index_3", hash_index_3);
                  ("win_1", P4_bf2_win_md_t_);
                  ("win_2", P4_bf2_win_md_t_);
                  ("win_3", P4_bf2_win_md_t_);
                  ("win_4", P4_bf2_win_md_t_)])]
        (EXT [])))
      POST
        (ARG_RET [] ValBaseNull
        (MEM [(["ds_md"], ValBaseStruct
                 [("clear_window", clear_window);
                  ("clear_index_1", clear_index_1);
                  ("hash_index_1", hash_index_1);
                  ("hash_index_2", hash_index_2);
                  ("hash_index_3", hash_index_3);
                  ("win_1", P4_bf2_win_md_t api_1 [hash_index_1; hash_index_2; hash_index_3]);
                  ("win_2", P4_bf2_win_md_t api_2 [hash_index_1; hash_index_2; hash_index_3]);
                  ("win_3", P4_bf2_win_md_t api_3 [clear_index_1; clear_index_1; clear_index_1]);
                  ("win_4", P4_bf2_win_md_t api_4 [hash_index_1; hash_index_2; hash_index_3])])]
        (EXT []))).

Lemma act_set_clear_win_3_body :
  func_sound ge act_set_clear_win_3_fd nil act_set_clear_win_3_spec.
Proof.
  start_function.
  unfold P4_bf2_win_md_t_.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  entailer.
Qed.

Definition act_set_clear_win_4_fd :=
  ltac:(get_fd ["Bf2BloomFilter"; "act_set_clear_win_4"] ge).

Definition act_set_clear_win_4_spec : func_spec :=
  WITH (* p *),
    PATH p
    MOD (Some [["ds_md"];
               ["act_set_clear_win_4"; "api_1"];
               ["act_set_clear_win_4"; "api_2"];
               ["act_set_clear_win_4"; "api_3"];
               ["act_set_clear_win_4"; "api_4"]]) []
    WITH (clear_window clear_index_1 hash_index_1 hash_index_2 hash_index_3: Sval) (api_1 api_2 api_3 api_4 : Sval),
      PRE
        (ARG [api_1; api_2; api_3; api_4]
        (MEM [(["ds_md"], ValBaseStruct
                 [("clear_window", clear_window);
                  ("clear_index_1", clear_index_1);
                  ("hash_index_1", hash_index_1);
                  ("hash_index_2", hash_index_2);
                  ("hash_index_3", hash_index_3);
                  ("win_1", P4_bf2_win_md_t_);
                  ("win_2", P4_bf2_win_md_t_);
                  ("win_3", P4_bf2_win_md_t_);
                  ("win_4", P4_bf2_win_md_t_)])]
        (EXT [])))
      POST
        (ARG_RET [] ValBaseNull
        (MEM [(["ds_md"], ValBaseStruct
                 [("clear_window", clear_window);
                  ("clear_index_1", clear_index_1);
                  ("hash_index_1", hash_index_1);
                  ("hash_index_2", hash_index_2);
                  ("hash_index_3", hash_index_3);
                  ("win_1", P4_bf2_win_md_t api_1 [hash_index_1; hash_index_2; hash_index_3]);
                  ("win_2", P4_bf2_win_md_t api_2 [hash_index_1; hash_index_2; hash_index_3]);
                  ("win_3", P4_bf2_win_md_t api_3 [hash_index_1; hash_index_2; hash_index_3]);
                  ("win_4", P4_bf2_win_md_t api_4 [clear_index_1; clear_index_1; clear_index_1])])]
        (EXT []))).

Lemma act_set_clear_win_4_body :
  func_sound ge act_set_clear_win_4_fd nil act_set_clear_win_4_spec.
Proof.
  start_function.
  unfold P4_bf2_win_md_t_.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  step.
  entailer.
Qed.

#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply act_set_clear_win_1_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply act_set_clear_win_2_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply act_set_clear_win_3_body) : func_specs.
#[local] Hint Extern 5 (func_modifies _ _ _ _ _) => (apply act_set_clear_win_4_body) : func_specs.

Definition tbl_set_win_fd :=
  ltac:(get_fd ["Bf2BloomFilter"; "tbl_set_win"; "apply"] ge).

Notation get_clear_frame := (get_clear_frame frame_tick_tocks).
Notation get_insert_frame := (get_insert_frame num_frames).

Lemma Z_div_squeeze_pos : forall a b lo hi res,
  0 < b ->
  lo <= a <= hi ->
  lo / b = res ->
  hi / b = res ->
  a / b = res.
Proof.
  intros.
  pose proof (Z.div_le_mono lo a b ltac:(auto) ltac:(lia)).
  pose proof (Z.div_le_mono a hi b ltac:(auto) ltac:(lia)).
  lia.
Qed.

Lemma Z_div_squeeze : forall a b lo hi res,
  lo <= a <= hi ->
  lo / b = res ->
  hi / b = res ->
  a / b = res.
Proof.
  intros.
  destruct b.
  - rewrite Zdiv_0_r in *. auto.
  - eapply Z_div_squeeze_pos; eauto; lia.
  - rewrite <- Zdiv_opp_opp in *.
    eapply Z_div_squeeze_pos with (-hi) (-lo); lia.
Qed.

Lemma Z_div_squeeze' : forall a b lo hi res,
  (lo <=? a) && (a <=? hi) ->
  lo / b = res ->
  hi / b = res ->
  a / b = res.
Proof.
  intros.
  apply Z_div_squeeze with lo hi; lia.
Qed.

Definition Filter_fd :=
  ltac:(get_fd ["Bf2BloomFilter"; "apply"] ge).

Program Definition hashes (key : Val) : listn Z num_rows := (exist _ [hash1 key; hash2 key; hash3 key] eq_refl).

Notation filter_repr := (filter_repr (frame_tick_tocks := frame_tick_tocks)).


(** * Properties about Context Free Grammars *)
Require Import Fiat.Parsers.StringLike.Core Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.ContextFreeGrammar.Transfer.
Require Import Fiat.Parsers.ContextFreeGrammar.SimpleCorrectness.

Local Coercion is_true : bool >-> Sortclass.

Set Implicit Arguments.

Section cfg.
  Context {Char} {HSLM1 HSLM2 : StringLikeMin Char}
          {HSL1 : @StringLike _ HSLM1}
          {HSL2 : @StringLike _ HSLM2}
          (G : @grammar Char).
  Context (R : @String _ HSLM1 -> @String _ HSLM2 -> Prop).
  Context {is_respectful : transfer_respectful R}.

  Local Ltac t' :=
    repeat match goal with
           | _ => assumption
           | [ |- context[match ?e with _ => _ end] ]
             => is_var e; destruct e
           | _ => tauto
           | _ => solve [ eauto with nocore ]
           | _ => intro
           | [ H : and _ _ |- _ ] => destruct H
           | [ H : ex _ |- _ ] => destruct H
           | [ H : transfer_respectful _ |- _ ] => destruct H; try clear H
           | [ |- and _ _ ] => split
           | [ |- ex _ ] => eexists; solve [ t' ]
           | [ H : is_true (andb ?x _) |- is_true (andb ?x _) ]
             => destruct x eqn:?; simpl in *
           end.

  Local Ltac t :=
    lazymatch goal with
    | [ p : _ |- _ ] => destruct p
    end;
    simpl_simple_parse_of_correct;
    t'.

  Fixpoint transfer_simple_parse_of_correct {str1 str2 pats} (H : R str1 str2) (p : @simple_parse_of Char)
    : simple_parse_of_correct G str1 pats p -> simple_parse_of_correct G str2 pats p
  with transfer_simple_parse_of_production_correct {str1 str2 pat} (H : R str1 str2) (p : @simple_parse_of_production Char)
    : simple_parse_of_production_correct G str1 pat p -> simple_parse_of_production_correct G str2 pat p
  with transfer_simple_parse_of_item_correct {str1 str2 it} (H : R str1 str2) (p : @simple_parse_of_item Char)
    : simple_parse_of_item_correct G str1 it p -> simple_parse_of_item_correct G str2 it p.
  Proof.
    { t. }
    { t. }
    { t. }
  Defined.
End cfg.