(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  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 file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Whole-program behaviors *)

(* Adapted to our customSmallstep library *)

Require Import Classical.
Require Import ClassicalEpsilon.
Require Import Coqlib.
Require Import Events.
Require Import Globalenvs.
Require Import Integers.
Require Import customSmallstep.

Set Implicit Arguments.

(** * Behaviors for program executions *)

(** The four possible outcomes for the execution of a program:
- Termination, with a finite trace of observable events
  and an integer value that stands for the process exit code
  (the return value of the main function).
- Divergence with a finite trace of observable events.
  (At some point, the program runs forever without doing any I/O.)
- Reactive divergence with an infinite trace of observable events.
  (The program performs infinitely many I/O operations separated
   by finite amounts of internal computations.)
- Going wrong, with a finite trace of observable events
  performed before the program gets stuck.
*)

Inductive program_behavior: Type :=
  | Terminates: trace -> int -> program_behavior
  | Diverges: trace -> program_behavior
  | Reacts: traceinf -> program_behavior
  | Goes_wrong: trace -> program_behavior.

(** Operations and relations on behaviors *)

Definition not_wrong (beh: program_behavior) : Prop :=
  match beh with
  | Terminates _ _ => True
  | Diverges _ => True
  | Reacts _ => True
  | Goes_wrong _ => False
  end.

Definition behavior_app (t: trace) (beh: program_behavior): program_behavior :=
  match beh with
  | Terminates t1 r => Terminates (t ** t1) r
  | Diverges t1 => Diverges (t ** t1)
  | Reacts T => Reacts (t *** T)
  | Goes_wrong t1 => Goes_wrong (t ** t1)
  end.

Lemma behavior_app_assoc:
  forall t1 t2 beh,
  behavior_app (t1 ** t2) beh = behavior_app t1 (behavior_app t2 beh).
Proof.
  intros. destruct beh; simpl; f_equal; traceEq.
Qed.

Lemma behavior_app_E0:
  forall beh, behavior_app E0 beh = beh.
Proof.
  destruct beh; auto.
Qed.

Definition behavior_prefix (t: trace) (beh: program_behavior) : Prop :=
  exists beh', beh = behavior_app t beh'.

Definition behavior_improves (beh1 beh2: program_behavior) : Prop :=
  beh1 = beh2 \/ exists t, beh1 = Goes_wrong t /\ behavior_prefix t beh2.

Lemma behavior_improves_refl:
  forall beh, behavior_improves beh beh.
Proof.
  intros; red; auto.
Qed.

Lemma behavior_improves_trans:
  forall beh1 beh2 beh3,
  behavior_improves beh1 beh2 -> behavior_improves beh2 beh3 ->
  behavior_improves beh1 beh3.
Proof.
  intros. red. destruct H; destruct H0; subst; auto.
  destruct H as [t1 [EQ1 [beh2' EQ1']]].
  destruct H0 as [t2 [EQ2 [beh3' EQ2']]].
  subst. destruct beh2'; simpl in EQ2; try discriminate. inv EQ2.
  right. exists t1; split; auto. exists (behavior_app t beh3'). apply behavior_app_assoc.
Qed.

Lemma behavior_improves_bot:
  forall beh, behavior_improves (Goes_wrong E0) beh.
Proof.
  intros. right. exists E0; split; auto. exists beh. rewrite behavior_app_E0; auto.
Qed.

Lemma behavior_improves_app:
  forall t beh1 beh2,
  behavior_improves beh1 beh2 ->
  behavior_improves (behavior_app t beh1) (behavior_app t beh2).
Proof.
  intros. red; destruct H. left; congruence.
  destruct H as [t' [A [beh' B]]]. subst.
  right; exists (t ** t'); split; auto. exists beh'. rewrite behavior_app_assoc; auto.
Qed.

(** Associating behaviors to programs. *)

Section PROGRAM_BEHAVIORS.

Variable L: semantics.

Inductive state_behaves (s: state L): program_behavior -> Prop :=
  | state_terminates: forall t s' r,
      Star L s t s' ->
      final_state L s' r ->
      state_behaves s (Terminates t r)
  | state_diverges: forall t s',
      Star L s t s' -> Forever_silent L s' ->
      state_behaves s (Diverges t)
  | state_reacts: forall T,
      Forever_reactive L s T ->
      state_behaves s (Reacts T)
  | state_goes_wrong: forall t s',
      Star L s t s' ->
      Nostep L s' ->
      (forall r, ~final_state L s' r) ->
      state_behaves s (Goes_wrong t).

Inductive program_behaves: program_behavior -> Prop :=
  | program_runs: forall s beh,
      initial_state L s -> state_behaves s beh ->
      program_behaves beh
  | program_goes_initially_wrong:
      (forall s, ~initial_state L s) ->
      program_behaves (Goes_wrong E0).

Lemma state_behaves_app:
  forall s1 t s2 beh,
  Star L s1 t s2 -> state_behaves s2 beh -> state_behaves s1 (behavior_app t beh).
Proof.
  intros. inv H0; simpl; econstructor; eauto; try (eapply star_trans; eauto).
  eapply star_forever_reactive; eauto.
Qed.

(** * Existence of behaviors *)

(** We now show that any program admits at least one behavior.
  The proof requires classical logic: the axiom of excluded middle
  and an axiom of description. *)

(** The most difficult part of the proof is to show the existence
  of an infinite trace in the case of reactive divergence. *)

Section TRACEINF_REACTS.

Variable s0: state L.

Hypothesis reacts:
  forall s1 t1, Star L s0 t1 s1 ->
  exists s2, exists t2, Star L s1 t2 s2 /\ t2 <> E0.

Lemma reacts':
  forall s1 t1, Star L s0 t1 s1 ->
  { s2 : state L & { t2 : trace | Star L s1 t2 s2 /\ t2 <> E0 } }.
Proof.
  intros.
  destruct (constructive_indefinite_description _ (reacts H)) as [s2 A].
  destruct (constructive_indefinite_description _ A) as [t2 [B C]].
  exists s2; exists t2; auto.
Qed.

CoFixpoint build_traceinf' (s1: state L) (t1: trace) (ST: Star L s0 t1 s1) : traceinf' :=
  match reacts' ST with
  | existT _ s2 (exist _ t2 (conj A B)) =>
      Econsinf' t2
                (build_traceinf' (star_trans ST A (refl_equal _)))
                B
  end.

Lemma reacts_forever_reactive_rec:
  forall s1 t1 (ST: Star L s0 t1 s1),
  Forever_reactive L s1 (traceinf_of_traceinf' (build_traceinf' ST)).
Proof.
  cofix COINDHYP; intros.
  rewrite (unroll_traceinf' (build_traceinf' ST)). simpl.
  destruct (reacts' ST) as [s2 [t2 [A B]]].
  rewrite traceinf_traceinf'_app.
  econstructor. eexact A. auto. apply COINDHYP.
Qed.

Lemma reacts_forever_reactive:
  exists T, Forever_reactive L s0 T.
Proof.
  exists (traceinf_of_traceinf' (build_traceinf' (star_refl (step L) (globalenv L) s0))).
  apply reacts_forever_reactive_rec.
Qed.

End TRACEINF_REACTS.

Lemma diverges_forever_silent:
  forall s0,
  (forall s1 t1, Star L s0 t1 s1 -> exists s2, Step L s1 E0 s2) ->
  Forever_silent L s0.
Proof.
  cofix COINDHYP; intros.
  destruct (H s0 E0) as [s1 ST]. constructor.
  econstructor. eexact ST. apply COINDHYP.
  intros. eapply H. eapply star_left; eauto.
Qed.

Lemma state_behaves_exists:
  forall s, exists beh, state_behaves s beh.
Proof.
  intros s0.
  destruct (classic (forall s1 t1, Star L s0 t1 s1 -> exists s2, exists t2, Step L s1 t2 s2)).
(* 1 Divergence (silent or reactive) *)
  destruct (classic (exists s1, exists t1, Star L s0 t1 s1 /\
                       (forall s2 t2, Star L s1 t2 s2 ->
                        exists s3, Step L s2 E0 s3))).
(* 1.1 Silent divergence *)
  destruct H0 as [s1 [t1 [A B]]].
  exists (Diverges t1); econstructor; eauto.
  apply diverges_forever_silent; auto.
(* 1.2 Reactive divergence *)
  destruct (@reacts_forever_reactive s0) as [T FR].
  intros.
  generalize (not_ex_all_not _ _ H0 s1). intro A; clear H0.
  generalize (not_ex_all_not _ _ A t1). intro B; clear A.
  destruct (not_and_or _ _ B). contradiction.
  destruct (not_all_ex_not _ _ H0) as [s2 C]; clear H0.
  destruct (not_all_ex_not _ _ C) as [t2 D]; clear C.
  destruct (imply_to_and _ _ D) as [E F]; clear D.
  destruct (H s2 (t1 ** t2)) as [s3 [t3 G]]. eapply star_trans; eauto.
  exists s3; exists (t2 ** t3); split.
  eapply star_right; eauto.
  red; intros. destruct (app_eq_nil t2 t3 H0). subst. elim F. exists s3; auto.
  exists (Reacts T); econstructor; eauto.
(* 2 Termination (normal or by going wrong) *)
  destruct (not_all_ex_not _ _ H) as [s1 A]; clear H.
  destruct (not_all_ex_not _ _ A) as [t1 B]; clear A.
  destruct (imply_to_and _ _ B) as [C D]; clear B.
  destruct (classic (exists r, final_state L s1 r)) as [[r FINAL] | NOTFINAL].
(* 2.1 Normal termination *)
  exists (Terminates t1 r); econstructor; eauto.
(* 2.2 Going wrong *)
  exists (Goes_wrong t1); econstructor; eauto. red. intros.
  generalize (not_ex_all_not _ _ D s'); intros.
  generalize (not_ex_all_not _ _ H t); intros.
  auto.
Qed.

Theorem program_behaves_exists:
  exists beh, program_behaves beh.
Proof.
  destruct (classic (exists s, initial_state L s)) as [[s0 INIT] | NOTINIT].
(* 1. Initial state is defined. *)
  destruct (state_behaves_exists s0) as [beh SB].
  exists beh; econstructor; eauto.
(* 2. Initial state is undefined *)
  exists (Goes_wrong E0). apply program_goes_initially_wrong.
  intros. eapply not_ex_all_not; eauto.
Qed.

End PROGRAM_BEHAVIORS.

(** * Forward simulations and program behaviors *)

Section FORWARD_SIMULATIONS.

Variable L1: semantics.
Variable L2: semantics.
Variable S: forward_simulation L1 L2.

Lemma forward_simulation_state_behaves:
  forall i s1 s2 beh1,
  S i s1 s2 -> state_behaves L1 s1 beh1 ->
  exists beh2, state_behaves L2 s2 beh2 /\ behavior_improves beh1 beh2.
Proof.
  intros. inv H0.
(* termination *)
  exploit simulation_star; eauto. intros [i' [s2' [A B]]].
  exists (Terminates t r); split.
  econstructor; eauto. eapply fsim_match_final_states; eauto.
  apply behavior_improves_refl.
(* silent divergence *)
  exploit simulation_star; eauto. intros [i' [s2' [A B]]].
  exists (Diverges t); split.
  econstructor; eauto. eapply simulation_forever_silent; eauto.
  apply behavior_improves_refl.
(* reactive divergence *)
  exists (Reacts T); split.
  econstructor. eapply simulation_forever_reactive; eauto.
  apply behavior_improves_refl.
(* going wrong *)
  exploit simulation_star; eauto. intros [i' [s2' [A B]]].
  destruct (state_behaves_exists L2 s2') as [beh' SB].
  exists (behavior_app t beh'); split.
  eapply state_behaves_app; eauto.
  replace (Goes_wrong t) with (behavior_app t (Goes_wrong E0)).
  apply behavior_improves_app. apply behavior_improves_bot.
  simpl. decEq. traceEq.
Qed.

Theorem forward_simulation_behavior_improves:
  forall beh1, program_behaves L1 beh1 ->
  exists beh2, program_behaves L2 beh2 /\ behavior_improves beh1 beh2.
Proof.
  intros. inv H.
(* initial state defined *)
  exploit (fsim_match_initial_states S); eauto. intros [i [s' [INIT MATCH]]].
  exploit forward_simulation_state_behaves; eauto. intros [beh2 [A B]].
  exists beh2; split; auto. econstructor; eauto.
(* initial state undefined *)
  destruct (classic (exists s', initial_state L2 s')).
  destruct H as [s' INIT].
  destruct (state_behaves_exists L2 s') as [beh' SB].
  exists beh'; split. econstructor; eauto. apply behavior_improves_bot.
  exists (Goes_wrong E0); split.
  apply program_goes_initially_wrong.
  intros; red; intros. elim H; exists s; auto.
  apply behavior_improves_refl.
Qed.

Corollary forward_simulation_same_safe_behavior:
  forall beh,
  program_behaves L1 beh -> not_wrong beh ->
  program_behaves L2 beh.
Proof.
  intros. exploit forward_simulation_behavior_improves; eauto.
  intros [beh' [A B]]. destruct B.
  congruence.
  destruct H1 as [t [C D]]. subst. contradiction.
Qed.

End FORWARD_SIMULATIONS.

(** * Backward simulations and program behaviors *)

Section BACKWARD_SIMULATIONS.

Variable L1: semantics.
Variable L2: semantics.
Variable S: backward_simulation L1 L2.

Definition safe_along_behavior (s: state L1) (b: program_behavior) : Prop :=
  forall t1 s' b2, Star L1 s t1 s' -> b = behavior_app t1 b2 ->
     (exists r, final_state L1 s' r)
  \/ (exists t2, exists s'', Step L1 s' t2 s'').

Remark safe_along_safe:
  forall s b, safe_along_behavior s b -> safe L1 s.
Proof.
  intros; red; intros. eapply H; eauto. symmetry; apply behavior_app_E0.
Qed.

Remark star_safe_along:
  forall s b t1 s' b2,
  safe_along_behavior s b ->
  Star L1 s t1 s' -> b = behavior_app t1 b2 ->
  safe_along_behavior s' b2.
Proof.
  intros; red; intros. eapply H. eapply star_trans; eauto.
  subst. rewrite behavior_app_assoc. eauto.
Qed.

Remark not_safe_along_behavior:
  forall s b,
  ~ safe_along_behavior s b ->
  exists t, exists s',
     behavior_prefix t b
  /\ Star L1 s t s'
  /\ Nostep L1 s'
  /\ (forall r, ~(final_state L1 s' r)).
Proof.
  intros.
  destruct (not_all_ex_not _ _ H) as [t1 A]; clear H.
  destruct (not_all_ex_not _ _ A) as [s' B]; clear A.
  destruct (not_all_ex_not _ _ B) as [b2 C]; clear B.
  destruct (imply_to_and _ _ C) as [D E]; clear C.
  destruct (imply_to_and _ _ E) as [F G]; clear E.
  destruct (not_or_and _ _ G) as [P Q]; clear G.
  exists t1; exists s'.
  split. exists b2; auto.
  split. auto.
  split. red; intros; red; intros. elim Q. exists t; exists s'0; auto.
  intros; red; intros. elim P. exists r; auto.
Qed.

Lemma backward_simulation_star:
  forall s2 t s2', Star L2 s2 t s2' ->
  forall i s1 b, S i s1 s2 -> safe_along_behavior s1 (behavior_app t b) ->
  exists i', exists s1', Star L1 s1 t s1' /\ S i' s1' s2'.
Proof.
  induction 1; intros.
  exists i; exists s1; split; auto. apply star_refl.
  exploit (bsim_simulation S); eauto. eapply safe_along_safe; eauto.
  intros [i' [s1' [A B]]].
  assert (Star L1 s0 t1 s1'). intuition. apply plus_star; auto.
  exploit IHstar; eauto. eapply star_safe_along; eauto.
  subst t; apply behavior_app_assoc.
  intros [i'' [s2'' [C D]]].
  exists i''; exists s2''; split; auto. eapply star_trans; eauto.
Qed.

Lemma backward_simulation_forever_silent:
  forall i s1 s2,
  Forever_silent L2 s2 -> S i s1 s2 -> safe L1 s1 ->
  Forever_silent L1 s1.
Proof.
  assert (forall i s1 s2,
         Forever_silent L2 s2 -> S i s1 s2 -> safe L1 s1 ->
         forever_silent_N (step L1) (bsim_order S) (globalenv L1) i s1).
    cofix COINDHYP; intros.
    inv H.  destruct (bsim_simulation S _ _ _ H2 _ H0 H1) as [i' [s2' [A B]]].
    destruct A as [C | [C D]].
    eapply forever_silent_N_plus; eauto. eapply COINDHYP; eauto.
      eapply star_safe; eauto. apply plus_star; auto.
    eapply forever_silent_N_star; eauto. eapply COINDHYP; eauto.
      eapply star_safe; eauto.
  intros. eapply forever_silent_N_forever; eauto. apply bsim_order_wf.
Qed.

Lemma backward_simulation_forever_reactive:
  forall i s1 s2 T,
  Forever_reactive L2 s2 T -> S i s1 s2 -> safe_along_behavior s1 (Reacts T) ->
  Forever_reactive L1 s1 T.
Proof.
  cofix COINDHYP; intros. inv H.
  destruct (backward_simulation_star H2 _ (Reacts T0) H0) as [i' [s1' [A B]]]; eauto.
  econstructor; eauto. eapply COINDHYP; eauto. eapply star_safe_along; eauto.
Qed.

Lemma backward_simulation_state_behaves:
  forall i s1 s2 beh2,
  S i s1 s2 -> state_behaves L2 s2 beh2 ->
  exists beh1, state_behaves L1 s1 beh1 /\ behavior_improves beh1 beh2.
Proof.
  intros. destruct (classic (safe_along_behavior s1 beh2)).
(* 1. Safe along *)
  exists beh2; split; [idtac|apply behavior_improves_refl].
  inv H0.
(* termination *)
  assert (Terminates t r = behavior_app t (Terminates E0 r)).
    simpl. rewrite E0_right; auto.
  rewrite H0 in H1.
  exploit backward_simulation_star; eauto.
  intros [i' [s1' [A B]]].
  exploit (bsim_match_final_states S); eauto.
    eapply safe_along_safe. eapply star_safe_along; eauto.
  intros [s1'' [C D]].
  econstructor. eapply star_trans; eauto. traceEq. auto.
(* silent divergence *)
  assert (Diverges t = behavior_app t (Diverges E0)).
    simpl. rewrite E0_right; auto.
  rewrite H0 in H1.
  exploit backward_simulation_star; eauto.
  intros [i' [s1' [A B]]].
  econstructor. eauto. eapply backward_simulation_forever_silent; eauto.
  eapply safe_along_safe. eapply star_safe_along; eauto.
(* reactive divergence *)
  econstructor. eapply backward_simulation_forever_reactive; eauto.
(* goes wrong *)
  assert (Goes_wrong t = behavior_app t (Goes_wrong E0)).
    simpl. rewrite E0_right; auto.
  rewrite H0 in H1.
  exploit backward_simulation_star; eauto.
  intros [i' [s1' [A B]]].
  exploit (bsim_progress S); eauto. eapply safe_along_safe. eapply star_safe_along; eauto.
  intros [[r FIN] | [t' [s2' STEP2]]].
  elim (H4 _ FIN).
  elim (H3 _ _ STEP2).

(* 2. Not safe along *)
  exploit not_safe_along_behavior; eauto.
  intros [t [s1' [PREF [STEPS [NOSTEP NOFIN]]]]].
  exists (Goes_wrong t); split.
  econstructor; eauto.
  right. exists t; auto.
Qed.

Theorem backward_simulation_behavior_improves:
  forall beh2, program_behaves L2 beh2 ->
  exists beh1, program_behaves L1 beh1 /\ behavior_improves beh1 beh2.
Proof.
  intros. inv H.
(* L2's initial state is defined. *)
  destruct (classic (exists s1, initial_state L1 s1)) as [[s1 INIT] | NOINIT].
(* L1's initial state is defined too. *)
  exploit (bsim_match_initial_states S); eauto. intros [i [s1' [INIT1' MATCH]]].
  exploit backward_simulation_state_behaves; eauto. intros [beh1 [A B]].
  exists beh1; split; auto. econstructor; eauto.
(* L1 has no initial state *)
  exists (Goes_wrong E0); split.
  apply program_goes_initially_wrong.
  intros; red; intros. elim NOINIT; exists s0; auto.
  apply behavior_improves_bot.
(* L2 has no initial state *)
  exists (Goes_wrong E0); split.
  apply program_goes_initially_wrong.
  intros; red; intros.
  exploit (bsim_initial_states_exist S); eauto. intros [s2 INIT2].
  elim (H0 s2); auto.
  apply behavior_improves_refl.
Qed.

Corollary backward_simulation_same_safe_behavior:
  (forall beh, program_behaves L1 beh -> not_wrong beh) ->
  (forall beh, program_behaves L2 beh -> program_behaves L1 beh).
Proof.
  intros. exploit backward_simulation_behavior_improves; eauto.
  intros [beh' [A B]]. destruct B.
  congruence.
  destruct H1 as [t [C D]]. subst. elim (H (Goes_wrong t)). auto.
Qed.

End BACKWARD_SIMULATIONS.

(** * Program behaviors for the "atomic" construction *)

Section ATOMIC.

Variable L: semantics.
Hypothesis Lwb: well_behaved_traces L.

Remark atomic_finish: forall s t, output_trace t -> Star (atomic L) (t, s) t (E0, s).
Proof.
  induction t; intros.
  apply star_refl.
  simpl in H; destruct H. eapply star_left; eauto.
  simpl. apply atomic_step_continue; auto. simpl; auto. auto.
Qed.

Lemma step_atomic_plus:
  forall s1 t s2, Step L s1 t s2 -> SPlus (atomic L) (E0,s1) t (E0,s2).
Proof.
  intros.  destruct t.
  apply plus_one. simpl; apply atomic_step_silent; auto.
  exploit Lwb; eauto. simpl; intros.
  eapply plus_left. eapply atomic_step_start; eauto. eapply atomic_finish; eauto. auto.
Qed.

Lemma star_atomic_star:
  forall s1 t s2, Star L s1 t s2 -> Star (atomic L) (E0,s1) t (E0,s2).
Proof.
  induction 1. apply star_refl. eapply star_trans with (s2 := (E0,s2)).
  apply plus_star. eapply step_atomic_plus; eauto. eauto. auto.
Qed.

Lemma atomic_forward_simulation: forward_simulation L (atomic L).
Proof.
  set (ms := fun (s: state L) (ts: state (atomic L)) => ts = (E0,s)).
  apply forward_simulation_plus with ms; intros.
  auto.
  exists (E0,s1); split. simpl; auto. red; auto.
  red in H. subst s2. simpl; auto.
  red in H0. subst s2. exists (E0,s1'); split.
  apply step_atomic_plus; auto. red; auto.
Qed.

Lemma atomic_star_star_gen:
  forall ts1 t ts2, Star (atomic L) ts1 t ts2 ->
  exists t', Star L (snd ts1) t' (snd ts2) /\ fst ts1 ** t' = t ** fst ts2.
Proof.
  induction 1.
  exists E0; split. apply star_refl. traceEq.
  destruct IHstar as [t' [A B]].
  simpl in H; inv H; simpl in *.
  exists t'; split. eapply star_left; eauto. auto.
  exists (ev :: t0 ** t'); split. eapply star_left; eauto. rewrite B; auto.
  exists t'; split. auto. rewrite B; auto.
Qed.

Lemma atomic_star_star:
  forall s1 t s2, Star (atomic L) (E0,s1) t (E0,s2) -> Star L s1 t s2.
Proof.
  intros. exploit atomic_star_star_gen; eauto. intros [t' [A B]].
  simpl in *. replace t with t'. auto. subst; traceEq.
Qed.

Lemma atomic_forever_silent_forever_silent:
  forall s, Forever_silent (atomic L) s -> Forever_silent L (snd s).
Proof.
  cofix COINDHYP; intros. inv H. inv H0.
  apply forever_silent_intro with (snd (E0, s')). auto. apply COINDHYP; auto.
Qed.

Remark star_atomic_output_trace:
  forall s t t' s',
  Star (atomic L) (E0, s) t (t', s') -> output_trace t'.
Proof.
  assert (forall ts1 t ts2, Star (atomic L) ts1 t ts2 ->
          output_trace (fst ts1) -> output_trace (fst ts2)).
  induction 1; intros. auto. inv H; simpl in *.
  apply IHstar. auto.
  apply IHstar. exploit Lwb; eauto.
  destruct H2. apply IHstar. auto.
  intros. change t' with (fst (t',s')). eapply H; eauto. simpl; auto.
Qed.

Lemma atomic_forever_reactive_forever_reactive:
  forall s T, Forever_reactive (atomic L) (E0,s) T -> Forever_reactive L s T.
Proof.
  assert (forall t s T, Forever_reactive (atomic L) (t,s) T ->
          exists T', Forever_reactive (atomic L) (E0,s) T' /\ T = t *** T').
  induction t; intros. exists T; auto.
  inv H. inv H0. congruence. simpl in H; inv H.
  destruct (IHt s (t2***T0)) as [T' [A B]]. eapply star_forever_reactive; eauto.
  exists T'; split; auto. simpl. congruence.

  cofix COINDHYP; intros. inv H0. destruct s2 as [t2 s2].
  destruct (H _ _ _ H3) as [T' [A B]].
  assert (Star (atomic L) (E0, s) (t**t2) (E0, s2)).
    eapply star_trans. eauto. apply atomic_finish. eapply star_atomic_output_trace; eauto. auto.
  replace (t *** T0) with ((t ** t2) *** T'). apply forever_reactive_intro with s2.
  apply atomic_star_star; auto. destruct t; simpl in *; unfold E0 in *; congruence.
  apply COINDHYP. auto.
  subst T0; traceEq.
Qed.

Theorem atomic_behaviors:
  forall beh, program_behaves L beh <-> program_behaves (atomic L) beh.
Proof.
  intros; split; intros.
  (* L -> atomic L *)
  exploit forward_simulation_behavior_improves. eapply atomic_forward_simulation. eauto.
  intros [beh2 [A B]]. red in B. destruct B as [EQ | [t [C D]]].
  congruence.
  subst beh. inv H. inv H1.
  apply program_runs with (E0,s). simpl; auto.
  apply state_goes_wrong with (E0,s'). apply star_atomic_star; auto.
  red; intros; red; intros. inv H. eelim H3; eauto. eelim H3; eauto.
  intros; red; intros. simpl in H. destruct H. eelim H4; eauto.
  apply program_goes_initially_wrong.
  intros; red; intros. simpl in H; destruct H. eelim H1; eauto.
  (* atomic L -> L *)
  inv H.
  (* initial state defined *)
  destruct s as [t s]. simpl in H0. destruct H0; subst t.
  apply program_runs with s; auto.
  inv H1.
  (* termination *)
  destruct s' as [t' s']. simpl in H2; destruct H2; subst t'.
  econstructor. eapply atomic_star_star; eauto. auto.
  (* silent divergence *)
  destruct s' as [t' s'].
  assert (t' = E0). inv H2. inv H1; auto. subst t'.
  econstructor. eapply atomic_star_star; eauto.
  change s' with (snd (E0,s')). apply atomic_forever_silent_forever_silent. auto.
  (* reactive divergence *)
  econstructor. apply atomic_forever_reactive_forever_reactive. auto.
  (* going wrong *)
  destruct s' as [t' s'].
  assert (t' = E0).
    destruct t'; auto. eelim H2. simpl. apply atomic_step_continue.
    eapply star_atomic_output_trace; eauto.
  subst t'. econstructor. apply atomic_star_star; eauto.
  red; intros; red; intros. destruct t0.
  elim (H2 E0 (E0,s'0)). constructor; auto.
  elim (H2 (e::nil) (t0,s'0)). constructor; auto.
  intros; red; intros. elim (H3 r). simpl; auto.
  (* initial state undefined *)
  apply program_goes_initially_wrong.
  intros; red; intros. elim (H0 (E0,s)); simpl; auto.
Qed.

End ATOMIC.

(** * Additional results about infinite reduction sequences *)

(** We now show that any infinite sequence of reductions is either of
  the "reactive" kind or of the "silent" kind (after a finite number
  of non-silent transitions).  The proof necessitates the axiom of
  excluded middle.  This result is used below to relate
  the coinductive big-step semantics for divergence with the
  small-step notions of divergence. *)

Unset Implicit Arguments.

Section INF_SEQ_DECOMP.

Variable genv: Type.
Variable state: Type.
Variable step: genv -> state -> trace -> state -> Prop.

Variable ge: genv.

Inductive tstate: Type :=
  ST: forall (s: state) (T: traceinf), forever step ge s T -> tstate.

Definition state_of_tstate (S: tstate): state :=
  match S with ST s T F => s end.
Definition traceinf_of_tstate (S: tstate) : traceinf :=
  match S with ST s T F => T end.

Inductive tstep: trace -> tstate -> tstate -> Prop :=
  | tstep_intro: forall s1 t T s2 S F,
      tstep t (ST s1 (t *** T) (@forever_intro genv state step ge s1 t s2 T S F))
              (ST s2 T F).

Inductive tsteps: tstate -> tstate -> Prop :=
  | tsteps_refl: forall S, tsteps S S
  | tsteps_left: forall t S1 S2 S3, tstep t S1 S2 -> tsteps S2 S3 -> tsteps S1 S3.

Remark tsteps_trans:
  forall S1 S2, tsteps S1 S2 -> forall S3, tsteps S2 S3 -> tsteps S1 S3.
Proof.
  induction 1; intros. auto. econstructor; eauto.
Qed.

Let treactive (S: tstate) : Prop :=
  forall S1,
  tsteps S S1 ->
  exists S2, exists S3, exists t, tsteps S1 S2 /\ tstep t S2 S3 /\ t <> E0.

Let tsilent (S: tstate) : Prop :=
  forall S1 t S2, tsteps S S1 -> tstep t S1 S2 -> t = E0.

Lemma treactive_or_tsilent:
  forall S, treactive S \/ (exists S', tsteps S S' /\ tsilent S').
Proof.
  intros. destruct (classic (exists S', tsteps S S' /\ tsilent S')).
  auto.
  left. red; intros.
  generalize (not_ex_all_not _ _ H S1). intros.
  destruct (not_and_or _ _ H1). contradiction.
  unfold tsilent in H2.
  generalize (not_all_ex_not _ _ H2). intros [S2 A].
  generalize (not_all_ex_not _ _ A). intros [t B].
  generalize (not_all_ex_not _ _ B). intros [S3 C].
  generalize (imply_to_and _ _ C). intros [D F].
  generalize (imply_to_and _ _ F). intros [G J].
  exists S2; exists S3; exists t. auto.
Qed.

Lemma tsteps_star:
  forall S1 S2, tsteps S1 S2 ->
  exists t, star step ge (state_of_tstate S1) t (state_of_tstate S2)
         /\ traceinf_of_tstate S1 = t *** traceinf_of_tstate S2.
Proof.
  induction 1.
  exists E0; split. apply star_refl. auto.
  inv H. destruct IHtsteps as [t' [A B]].
  exists (t ** t'); split.
  simpl; eapply star_left; eauto.
  simpl in *. subst T. traceEq.
Qed.

Lemma tsilent_forever_silent:
  forall S,
  tsilent S -> forever_silent step ge (state_of_tstate S).
Proof.
  cofix COINDHYP; intro S. case S. intros until f. simpl. case f. intros.
  assert (tstep t (ST s1 (t *** T0) (forever_intro s1 t s0 f0))
                  (ST s2 T0 f0)).
    constructor.
  assert (t = E0).
    red in H. eapply H; eauto. apply tsteps_refl.
  apply forever_silent_intro with (state_of_tstate (ST s2 T0 f0)).
  rewrite <- H1. assumption.
  apply COINDHYP.
  red; intros. eapply H. eapply tsteps_left; eauto. eauto.
Qed.

Lemma treactive_forever_reactive:
  forall S,
  treactive S -> forever_reactive step ge (state_of_tstate S) (traceinf_of_tstate S).
Proof.
  cofix COINDHYP; intros.
  destruct (H S) as [S1 [S2 [t [A [B C]]]]]. apply tsteps_refl.
  destruct (tsteps_star _ _ A) as [t' [P Q]].
  inv B. simpl in *. rewrite Q. rewrite <- Eappinf_assoc.
  apply forever_reactive_intro with s2.
  eapply star_right; eauto.
  red; intros. destruct (Eapp_E0_inv _ _ H0). contradiction.
  change (forever_reactive step ge (state_of_tstate (ST s2 T F)) (traceinf_of_tstate (ST s2 T F))).
  apply COINDHYP.
  red; intros. apply H.
  eapply tsteps_trans. eauto.
  eapply tsteps_left. constructor. eauto.
Qed.

Theorem forever_silent_or_reactive:
  forall s T,
  forever step ge s T ->
  forever_reactive step ge s T \/
  exists t, exists s', exists T',
  star step ge s t s' /\ forever_silent step ge s' /\ T = t *** T'.
Proof.
  intros.
  destruct (treactive_or_tsilent (ST s T H)).
  left.
  change (forever_reactive step ge (state_of_tstate (ST s T H)) (traceinf_of_tstate (ST s T H))).
  apply treactive_forever_reactive. auto.
  destruct H0 as [S' [A B]].
  exploit tsteps_star; eauto. intros [t [C D]]. simpl in *.
  right. exists t; exists (state_of_tstate S'); exists (traceinf_of_tstate S').
  split. auto.
  split. apply tsilent_forever_silent. auto.
  auto.
Qed.

End INF_SEQ_DECOMP.

Set Implicit Arguments.

(** * Big-step semantics and program behaviors *)

Section BIGSTEP_BEHAVIORS.

Variable B: bigstep_semantics.
Variable L: semantics.
Hypothesis sound: bigstep_sound B L.

Lemma behavior_bigstep_terminates:
  forall t r,
  bigstep_terminates B t r -> program_behaves L (Terminates t r).
Proof.
  intros. exploit (bigstep_terminates_sound sound); eauto.
  intros [s1 [s2 [P [Q R]]]].
  econstructor; eauto. econstructor; eauto.
Qed.

Lemma behavior_bigstep_diverges:
  forall T,
  bigstep_diverges B T ->
  program_behaves L (Reacts T)
  \/ exists t, program_behaves L (Diverges t) /\ traceinf_prefix t T.
Proof.
  intros. exploit (bigstep_diverges_sound sound); eauto. intros [s1 [P Q]].
  exploit forever_silent_or_reactive; eauto. intros [X | [t [s' [T' [X [Y Z]]]]]].
  left. econstructor; eauto. constructor; auto.
  right. exists t; split. econstructor; eauto. econstructor; eauto. exists T'; auto.
Qed.

End BIGSTEP_BEHAVIORS.


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.