From Coq Require Import ZArith.
Require Import coqutil.Z.Lia.
Require Import Coq.Lists.List. Import ListNotations.
Require Import coqutil.Map.Interface coqutil.Map.Properties.
Require Import coqutil.Word.Interface coqutil.Word.Properties.
Require Import riscv.Utility.Monads.
Require Import riscv.Utility.Utility.
Require Import riscv.Spec.Decode.
Require Import riscv.Platform.Memory.
Require Import riscv.Spec.Machine.
Require Import riscv.Platform.RiscvMachine.
Require Import riscv.Platform.MetricRiscvMachine.
Require Import riscv.Spec.Primitives.
Require Import riscv.Spec.MetricPrimitives.
Require Import riscv.Platform.MetricLogging.
Require Import riscv.Platform.Run.
Require Import riscv.Spec.Execute.
Require Import riscv.Proofs.DecodeEncode.
Require Import coqutil.Tactics.Tactics.
Require Import compiler.SeparationLogic.
Require Import bedrock2.ptsto_bytes.
Require Import bedrock2.Scalars.
Require Import riscv.Utility.Encode.
Require Import riscv.Proofs.EncodeBound.
Require Import coqutil.Decidable.
Require Import compiler.GoFlatToRiscv.
Require Import riscv.Utility.runsToNonDet.
Require Import riscv.Utility.InstructionCoercions.
Require Import compiler.ForeverSafe.
Require Import compiler.RunInstruction.
Require Import compiler.DivisibleBy4.
Require Import coqutil.Tactics.Simp.
Import Utility.

Section EventLoop.

  Context {width} {BW: Bitwidth width} {word: word.word width} {word_ok: word.ok word}.
  Context {Registers: map.map Z word}.
  Context {mem: map.map word byte}.
  Context {mem_ok: map.ok mem}.

  Local Notation RiscvMachineL := MetricRiscvMachine.
  Local Notation trace := (list LogItem).

  Context {M: Type -> Type}.
  Context {MM: Monad M}.
  Context {RVM: RiscvProgram M word}.
  Context {PRParams: PrimitivesParams M MetricRiscvMachine}.
  Context {PR: MetricPrimitives PRParams}.

  Add Ring wring : (word.ring_theory (word := word))
      (preprocess [autorewrite with rew_word_morphism],
       morphism (word.ring_morph (word := word)),
       constants [word_cst]).

  (* goodReadyState is the invariant which says that the machine is ready to execute
     the next iteration of the infinite event loop.
     It also gets a `done` boolean which says whether the PC is supposed to be at the
     beginning or at the end of the loop body, and should check for that *)
  Variable goodReadyState: bool -> RiscvMachineL -> Prop.

  Variables pc_start pc_end: word.
  Hypothesis pc_start_aligned: (word.unsigned pc_start) mod 4 = 0.
  Hypothesis start_ne_end: pc_start <> pc_end.

  Hypothesis goodReadyState_checks_PC: forall done m,
      goodReadyState done m -> m.(getPc) = if done then pc_end else pc_start.

  Hypothesis goodReadyState_preserved_by_jump_back:
    forall (state: RiscvMachineL) newMetrics,
      goodReadyState true state ->
      let state' := (withPc pc_start
                    (withNextPc (word.add pc_start (word.of_Z 4))
                    (withMetrics newMetrics state))) in
      valid_machine state' ->
      goodReadyState false state'.

  Hypothesis goodReadyState_implies_valid_machine: forall pc m,
      goodReadyState pc m -> valid_machine m.

  Variable jump: Z.
  Variable iset: InstructionSet.
  Hypothesis jump_bound: - 2 ^ 20 <= jump < 2 ^ 20.
  Hypothesis jump_aligned: jump mod 4 = 0.
  Hypothesis pc_end_def: pc_end = word.sub pc_start (word.of_Z jump).

  Hypothesis goodReadyState_implies_jump_back_instr: forall m,
      goodReadyState true m ->
      (exists R, (ptsto_instr iset pc_end (Jal Register0 jump) * R)%sep m.(getMem)) /\
      subset (footpr (ptsto_instr iset pc_end (Jal Register0 jump)))
             (of_list m.(getXAddrs)).

  (* loop body: between pc_start and pc_end *)
  Hypothesis body_correct: forall (initial: RiscvMachineL),
      goodReadyState false initial ->
      runsTo (mcomp_sat (run1 iset)) initial (goodReadyState true).

  Definition runsToGood_Invariant(m: RiscvMachineL): Prop :=
    runsTo (mcomp_sat (run1 iset)) m (goodReadyState false) /\ valid_machine m.

  (* "runs to a good state" is an invariant of the transition system
     (note that this does not depend on the definition of runN) *)
  Lemma runsToGood_is_Invariant: forall (st: RiscvMachineL),
      runsToGood_Invariant st -> mcomp_sat (run1 iset) st runsToGood_Invariant.
  Proof.
    unfold runsToGood_Invariant.
    intros m [R V].
    eapply run1_get_sane with (P := (fun m => runsTo (mcomp_sat (run1 iset)) m (goodReadyState false))).
    1, 3: eauto. revert R.
    eapply runsTo_safe1_inv; cycle 1.
    - intros. eapply body_correct; assumption.
    - intros.
      (* this is the loop verification code: *)
      eapply runsToStep. {
        specialize (goodReadyState_implies_jump_back_instr _ H).
        destruct goodReadyState_implies_jump_back_instr. simp.
        specialize (goodReadyState_checks_PC _ _ H). subst pc_end.
        eapply run_Jal0; try eauto.
        unfold program, array.
        rewrite goodReadyState_checks_PC.
        solve [ ecancel ].
      }
      simpl. intros. simp.
      destruct_RiscvMachine state.
      destruct_RiscvMachine mid.
      subst.
      apply runsToDone.
      ssplit; try assumption; cbn;
        ring_simplify (word.add (word.sub pc_start (word.of_Z jump)) (word.of_Z jump));
        try reflexivity.
      specialize (goodReadyState_checks_PC _ _ H). simpl in *. subst state_pc.
      eapply goodReadyState_preserved_by_jump_back in H.
      + simpl in H.
        match goal with
        | |- ?G => let T := type of H in replace G with T; [exact H|]
        end.
        repeat f_equal.
        all: solve_word_eq word_ok.
      + simpl.
        match goal with
        | H: valid_machine ?m1 |- valid_machine ?m2 => replace m2 with m1; [exact H|]
        end.
        f_equal. f_equal; solve_word_eq word_ok.
    - intros state [C1 C2].
      apply goodReadyState_checks_PC in C1.
      apply goodReadyState_checks_PC in C2.
      congruence.
  Qed.

End EventLoop.


Set Implicit Arguments.
Unset Strict Implicit.

Require Import basics.
Require Import enat.
Require Import allen.
Require Import signal.
Require Import compare.
Require Import borders.
Require Export reactives.
Require Import extend.

Section allenfuns.

Ltac G x := generalize x.

Ltac BAD := intros BAD; inversion BAD.

Ltac INC_CMP CV1 CV2 :=
  intros I J (LL,RR);
  apply (inc_allen_by_comp2 (CV1 _ _ LL) (CV2 _ _ RR)).

Ltac RINC_CMP CV1 CV2 :=
  intros I J (LL,RR);
  apply (inc_allen_by_comp2 (CV1 _ _ LL) (CV2 _ _ RR)).

Ltac SAFE_ALLEN_RELATION2 :=
  intros I1 I2 J1 J2 (E1,E2) (E3,E4) (LL1,RR1);
  rewrite E1 in *; rewrite E2 in *; rewrite E3 in *; rewrite E4 in *;
  split; auto.

(*
 * HOLDS
 *)
Definition holds (p q:sig) : sig := fun t =>
 (exists (I:allen), (tas t I q) /\ (on I p)).

(*
 * OCCURS
 *)
Definition occurs (p q:sig) : sig :=
 (filter (fun I => (exists t, (in_allen t I) /\ (p t))) q).

Lemma inc_sig_allen_occurs_right (p q:sig) :
  (inc_sig_allen (occurs p q) q).
apply inc_sig_allen_filter.
Qed.

Lemma in_sig_occurs_has (p q:sig) (I:allen) :
 (in_sig I (occurs p q)) ->
 (exists t, (in_allen t I) /\ (p t)).
intros IInO.
apply (in_sig_filter IInO).
intros A B EQA (t,(tInI,Pt)).
exists t; split; auto.
apply (inc_allen_refl EQA tInI).
Qed.

Lemma occurs_not_right (p q:sig) (I J:allen) (t:nat) :
 (tas t I p) ->
 (tas t J q) ->
 (occurs (not_sig p) q t) ->
 ((left I)<=(left J)) ->
 (ilt (right I) (right J)).
intros tIp tJq (JJ,((tInJJ,JJInq),(tt,(ttInJJ,NPtt)))) LL.
G (tas_uniq (tas_def tInJJ JJInq) tJq); intros JJJ; clear tInJJ JJInq.
G (eq_allen_in_allen JJJ ttInJJ). intros ttInJ. clear ttInJJ JJJ.
G NPtt; clear NPtt.
apply contra. rewrite <- ile__not_ilt, not_sig_def, not_not.
intros RR. apply (tas_p (I:=I)).
split;[|apply (tas_sig tIp)].
apply (in_allen_inter ttInJ LL RR).
Qed.

Lemma up_os_upr (p q:sig) (t:nat) : (up (occurs (sync p q) q) t) -> (up q t).
intros (GT0c,(I,(LI,IInO))).
split;[auto|].
exists I; split;[auto|].
apply (inc_sig_allen_filter IInO).
Qed.

Lemma up_os_os (p q:sig) (t:nat) :
 (up (occurs (sync p q) q) t) ->
 (occurs (sync p q) q t).
intros UP.
apply (up_in UP).
Qed.

Lemma up_os_up (p q:sig) (t:nat) :
 (up q t) ->
 (occurs (sync p q) q t) ->
 (up p t).
intros UQ (J,(tJq,(t2,(t2InJ,(UP2,UQ2))))).
rewrite (up_shared tJq t2InJ UQ UQ2); auto.
Qed.

Lemma up_os_upl (p q:sig) (t:nat) : (up (occurs (sync p q) q) t) -> (up p t).
intros UPO.
apply (up_os_up (up_os_upr UPO) (up_os_os UPO)).
Qed.

Lemma occurs_sync_shared_left (p q:sig) (I J1 J2:allen) (t2:nat) :
 (tas t2 I p) ->
 (tas (left I) J1 (occurs (sync p q) q)) ->
 (tas t2 J2 (occurs (sync p q) q)) ->
 (left J1)=(left J2).
intros t2Ip t1J1O t2J2O.
G (join_or_up t1J1O t2J2O (allen_left (tas_allen t2Ip))).
intros [EQ | (t,((LT,GT),UP))]; [apply (proj1 EQ)|exfalso].
G (lt_getS LT); intros (pt,PT). rewrite PT in *. clear PT t.
cut (in_allen pt I);[intros ptInI|].
- G (in_sig_slice (tas_sig t2Ip) ptInI).
  G (before_up (up_os_upl UP)); auto.
- split.
    rewrite <- ltS__le; auto.
  + G (allen_right (tas_allen t2Ip)); apply ilt_trans. simpl.
    G GT. apply lt_le_trans. auto.
Qed.

Lemma sync_shared_left__starts (p q:sig) (I J:allen) (t t1:nat) :
 (tas t I p) ->
 (tas t J (occurs (sync p q) q)) ->
 (in_allen t1 I) ->
 (sync p q t1) ->
 (left I)=(left J).
intros tIp tJO t1InI SY.
G (sync_left_first (tas_mov tIp t1InI) SY); intros LI.
rewrite <- LI in *. clear LI t1InI.
G (inc_sig_sync_first (sync_comm SY)); intros qt1.
G (get_sig qt1). intros (J1,t1J1q).
cut (tas (left I) J1 (occurs (sync p q) q)); [intros t1J1O|].
- rewrite <- (occurs_sync_shared_left tIp t1J1O tJO).
  apply (sync__left (tas_left tIp) t1J1q SY).
- apply (filter_tas t1J1q).
  exists (left J1); split;[apply in_allen_left|auto].
  rewrite <- (sync__left (tas_left tIp) t1J1q SY).
  auto.
Qed.

(*
 * OCCURS_UP
 *)
Definition occurs_up (p q:sig) := (occurs (up_after q p) p).

Lemma inc_sig_allen_occurs_up (p q:sig) : (inc_sig_allen (occurs_up p q) p).
  apply inc_sig_allen_filter.
Qed.

Lemma in_sig_occup (p q:sig) (I J:allen) :
 (in_sig I p) ->
 (tas (left I) J q) ->
 0 < (left I) ->
 (not_sig (up q) (left I)) ->
 (in_sig I (occurs_up p q)).
intros Ip ttJq GT0 NUPQtt.
apply (filter_in_sig Ip).
exists (left I). split.
- apply in_allen_left.
- split.
  + split; [assumption|].
    exists I. auto.
  + split;[|assumption].
    apply (tas_p ttJq).
Qed.

Lemma occoccup (p q:sig) (I J:allen) (t:nat) :
 (tas t I p) ->
 (tas (left I) J q) ->
 0 < (left I) ->
 (not_sig (up q) (left I)) ->
 (ilt (right J) (right I)) ->
 (occurs (not_sig q) (occurs_up p q) t).
intros tIp ttJq GT0 NUPQtt LT.
exists I. split;[split|].
- apply (tas_allen tIp).
- apply (in_sig_occup (tas_sig tIp) ttJq GT0 NUPQtt).
- apply (end_before_has_down ttJq LT).
Qed.

Lemma up_after_share_left (p q:sig) (I J:allen) (t l:nat) :
  (tas t I (occurs_up q p)) ->
  (tas t J (and_sig p q)) ->
  (up_after p q l) ->
  (in_allen l J) ->
  l=(left I).
intros tIO tJA ((GT0,(II,(LII,IIInq))),(Pl,NUpl)) lInL.
rewrite LII in *; clear LII l.
G (eq_sig_tas (and_sig_comm p q) tJA). intros tJrA.
G (tas_filter_tas_arg tIO); intros tIq.
G (in_sig_and__inc_allen tJrA tIq).
intros JIncI.
G (JIncI _ lInL). intros lInI.
G (in_allen_left II). intros lInII.
rewrite (tas_uniq_left (tas_def lInI (tas_sig tIq)) (tas_def lInII IIInq)).
auto.
Qed.

Lemma up_after_left (p q:sig) (I:allen) :
 (in_sig I (occurs_up q p)) ->
 (exists K, (in_sig K p)
         /\ (left K)<(left I)
         /\ (ilt (Fix (left I)) (right K)) ).
intros IInO.
cut (exists t, (in_allen t I)/\ (up_after p q t)).
- intros (t,(tInI,((GT0,(II,(LII,IIInq))),(Pt,NUpt)))).
  G (get_sig Pt); intros (K,(tInK,KInp)).
  exists K; split; auto.
  G (in_allen_left II); rewrite <- LII; intros tInII.
  G (tas_uniq_left (tas_def tInII IIInq) (tas_def tInI (inc_sig_allen_occurs_right IInO))).
  intros LILII.
  G (nat_compare (left K) (left I)); intros [OK|[BAD|BAD]].
  + split; auto.
    rewrite <- LILII.
    apply (le_ilt_trans (allen_left tInII) (allen_right tInK)).
  + exfalso.
    G NUpt; apply not_not; unfold up.
    split;[apply GT0|].
    exists K; split;[|auto].
    rewrite BAD, LII; auto.
  + exfalso; G BAD. apply le_not_gt.
    rewrite <- LILII, <- LII; apply (allen_left tInK).
- apply (in_sig_filter IInO).
  intros A B EQ (t,(tInA,UP)).
  exists t; split; [apply (eq_allen_in_allen EQ tInA)|auto].
Qed.

Lemma occurs_up_after_on_left (p q:sig) (I J K:allen) (t u':nat) :
 (tas t I (occurs_up q p)) ->
 (tas t J (and_sig p q)) ->
 (tas t K p) ->
 (in_allen u' J) ->
 (up_after p q u') ->
 (left K)<(left I).
intros tIO tJA tKp u'InJ NPu'.
G (up_after_left (tas_sig tIO)). intros (K2,(K2Inp,(K2I,ILT))).
rewrite (tas_uniq_left (p:=p) (I1:=K) (I2:=K2) (t:=u')); auto.
- apply (tas_mov tKp (in_sig_and__inc_allen tJA tKp u'InJ)).
- split;[split|auto].
  + apply lt_le.
    apply (lt_le_trans _ _ _ K2I).
    G (allen_left u'InJ).
    apply le_trans.
    G (eq_sig_tas (and_sig_comm p q) tJA). intros tJrA.
    G (in_sig_and__inc_allen tJrA (tas_filter_tas_arg tIO)).
    intros JincI.
    apply (allen_left (JincI _ (in_allen_left J))).
  + rewrite (up_after_share_left tIO tJA NPu' u'InJ); auto.
Qed.

Lemma overlaps_occurs_up (p q:sig) (I J:allen) (t:nat) :
 (tas t I p) ->
 (tas t J q) ->
 (left I) < (left J) ->
 (ilt (right I) (right J)) ->
 (tas t J (occurs_up q p)).
intros tIp tJq LIJ RIJ.
split;[apply (tas_allen tJq)|].
split;[|split].
- case_eq (left J); auto; intros lj LJ.
  intros (K,(ljKq,_)).
  G (tas_p ljKq).
  apply (previous_left_out (tas_sig tJq) LJ).
- case_eq (right J); auto; intros ri RJ.
  intros (K,(ljKq,_)).
  G (tas_p ljKq).
  apply (bounded_right_out (tas_sig tJq) RJ).
- intros t' t'InJ; exists J. split; [apply (tas_mov tJq t'InJ)|].
  exists (left J). split;[|].
  + apply in_allen_left.
  + apply (overlaps_up_after_left tIp tJq LIJ RIJ).
    apply (tas_has_intersection tJq tIp).
Qed.

(*
 * AUXILARY ALLEN'S FUNCTIONS
 *)
(*
 * init
 *)
Definition init (p:sig) : sig := (filter (fun I => (left I)=0) p).

(*
 * final
 *)
Definition final (p:sig) : sig := (filter (fun I => (right I)=Inf) p).

Lemma not_final (p:sig) (I:allen) (t:nat) :
 (tas t I p) ->
 (not_sig (final p) t) ->
 (right I)<>Inf.
intros tIp.
apply ncontra; intros RI.
exists I; auto.
Qed.

Lemma not_final_fix_right (p:sig) (I:allen) (t:nat) :
 (tas t I p) ->
 (not_sig (final p) t) ->
 (exists ri, (right I)=(Fix ri)).
intros tIp.
case_eq (right I).
- intros ri RI _. exists ri; auto.
- intros RI NF. exfalso.
  G NF. rewrite not_sig_def. apply tilde. rewrite not_not.
  exists I; auto.
Qed.

(*
 * ALLEN'S FUNCION
 *)
(*
 * MEETS
 *)
Definition Meets (x:allen) (y:allen) : Prop := (right x)=(Fix (left y)).
Definition meets := extend Meets.

Lemma meets_by_end (p q:sig) (I J:allen) (t:nat) :
 (tas t I p) ->
 (in_sig J (not_sig q)) ->
 (right I)=(right J) ->
 (not_sig (final p) t) ->
 (meets p q t).
intros tIp JInNq RI NotF.
exists I. split;[auto|].
G (not_final_fix_right tIp NotF). intros (ri,FRI).
G (previous_right FRI). intros (pri,PRI).
rewrite PRI in *. clear PRI.
rewrite FRI in RI.
G (bounded_right_out JInNq (eq_sym RI)). rewrite not_sig_def, not_not. intros QSri.
G (previous_right_in JInNq (eq_sym RI)); rewrite not_sig_def; intros NQri.
G (up_allen_right NQri QSri); intros (K,(KInq,EQ)).
exists K. split;[auto|unfold Meets; rewrite FRI, EQ; auto].
Qed.

(*
 * MET
 *)
Definition MetBy (x:allen) (y:allen) : Prop := (Fix (left x))=(right y).
Definition met := extend MetBy.

(*
 * EQ
 *)
Definition Eq (x:allen) (y:allen) : Prop := (eq_allen x y).
Definition eq := extend Eq.

Lemma Eq_inc : (inclusive_relation Eq). INC_CMP eq_le2 eq_ile. Qed.

Lemma inc_sig_eq_left (p q r:sig) :
 (inc_sig p (eq q r)) ->
 (inc_sig p q).
intros INC.
apply (inc_sig_trans INC).
apply inc_sig_extend_left.
Qed.

(*
 * STARTS
 *)
Definition Starts (x:allen) (y:allen) : Prop :=
    (left x)=(left y)
 /\ (ilt (right x) (right y)).
Definition starts := extend Starts.

Lemma Starts_inc : (inclusive_relation Starts). INC_CMP eq_le2 ilt_ile. Qed.

(*
 * STARTED
 *)
Definition StartedBy (x:allen) (y:allen) : Prop :=
    (left x)=(left y)
 /\ (ilt (right y) (right x)).
Definition started := extend StartedBy.

Lemma startedBy_Starts (I J:allen) :
 (StartedBy I J) ->
 (Starts J I).
intros (LL,RR); split; auto.
Qed.

(*
 * ENDS
 *)
Definition Ends (x:allen) (y:allen) : Prop :=
    (left y)<(left x)
 /\ (right x)=(right y).
Definition ends := extend Ends.

Lemma ends_safe : (safe_allen_relation Ends). SAFE_ALLEN_RELATION2. Qed.

Lemma Ends_inc : (inclusive_relation Ends). INC_CMP lt_le eq_ile. Qed.

(*
 * ENDED
 *)
Definition EndedBy (x:allen) (y:allen) : Prop :=
    (left x)<(left y)
 /\ (right x)=(right y).
Definition ended := extend EndedBy.

Lemma EndedBy_inc : (rinclusive_relation EndedBy). RINC_CMP lt_le eq_ile2. Qed.

(*
 * OVERALAPS
 *)
Definition Overlaps (x:allen) (y:allen) : Prop :=
    (left x)<(left y)
 /\ (ilt (Fix (left y)) (right x))
 /\ (ilt (right x) (right y)).
Definition overlaps := extend Overlaps.

(*
 * OVERLAPPED
 *)
Definition OverlappedBy (x:allen) (y:allen) : Prop :=
    (left y)<(left x)
 /\ (ilt (Fix (left x)) (right y))
 /\ (ilt (right y) (right x)).
Definition overlapped := extend OverlappedBy.

(*
 * DURING
 *)
Definition During (x:allen) (y:allen) : Prop :=
    (left y)<(left x)
 /\ (ilt (right x) (right y)).
Definition during := extend During.

Lemma During_inc_allen (I J:allen) : (During I J) -> (inc_allen I J).
intros (LL,RR).
apply (left_right_inc_allen (lt_le LL) (ilt_ile RR)).
Qed.

Lemma During_safe : (safe_allen_relation During). SAFE_ALLEN_RELATION2. Qed.

Lemma During_inc : (inclusive_relation During). INC_CMP lt_le ilt_ile. Qed.

Lemma eq_right_during (I J1 J2:allen) :
 (eq_allen J1 J2) ->
 (During I J1) ->
 (During I J2).
intros (LL,RR) (L1,R1). rewrite LL in L1. rewrite RR in R1.
split; auto.
Qed.

Lemma During_in_allen_left (I J:allen) :
  (During I J) ->
  (in_allen (left I) J).
intros DRG.
apply (inc_allen_in_allen_left (During_inc DRG)).
Qed.

(*
 * CONTAINS
 *)
Definition Contains (x:allen) (y:allen) : Prop :=
    (left x)<(left y)
 /\ (ilt (right y) (right x)).
Definition contains := extend Contains.

Lemma contains_has_left (I J:allen) : (Contains I J) -> (in_allen (left J) I).
intros (LL,RR).
split;[apply (lt_le LL) | apply (ilt_trans (wf J) RR)].
Qed.

Lemma During_Contains (I J:allen) : (During I J) -> (Contains J I).
auto.
Qed.

Lemma Contains_During (I J:allen) : (Contains I J) -> (During J I).
auto.
Qed.

(*
 * OVER
 *)
Definition over (p q:sig) : sig := fun t =>
  (exists I, (tas t I p)
          /\ (exists J, (tas t J q)
                     /\ ((left I) < (left J))
                     /\ (ilt (right I) (right J)) )).

Lemma ends_fix_over (p q:sig) (I J:allen) (t ri:nat) :
 (tas t I p) ->
 (tas t J q) ->
 (left J)<(left I) ->
 (right I)=(right J) ->
 (right I)=(Fix ri) ->
 (over q (imp_sig q p) t).
intros tIp tJq LL RR RI.
exists J. split;[auto|].
G (get_sig (or_sig_right (not_sig q) (tas_p tIp))). intros (K,tKO).
exists K. split;[auto|split].
- apply (in_sig_imp_left tIp tJq tKO LL RR RI).
- apply (in_sig_imp_right tIp tJq tKO LL RR RI).
Qed.

End allenfuns.


Require Import
        Coq.Vectors.Vector
        Coq.Strings.Ascii
        Coq.Bool.Bool
        Coq.Lists.List
        Bedrock.Word
        Bedrock.Memory
        Fiat.Computation.ListComputations.

Require Import
        Fiat.Computation.IfDec
        Fiat.QueryStructure.Specification.Operations.InsertAll
        Fiat.QueryStructure.Automation.AutoDB
        Fiat.Examples.DnsServer.Packet
        Fiat.Examples.DnsServer.RecursiveDNSSchema.

Import Vectors.VectorDef.VectorNotations.

Local Open Scope vector.
Local Open Scope Tuple_scope.

Definition linkAuthorityToAdditional
           (curTime : timeT)
           (this : QueryStructure RecResolverSchema)
           (authority : list resourceRecord)
           (additional : list resourceRecord)
  : Comp (QueryStructure RecResolverSchema) :=
  authorityAndAdditional <-
                         {aal | NoDup aal /\
                                forall (ns : NS_Record)
                                       (ans : A_Record),
                                  List.In < sDOMAIN :: (ns!sRDATA : DomainName),
                                            sIP :: (ans!sRDATA : W) > aal
                            <-> (List.In (NS_Record2RRecord ns) authority
                                 /\ List.In (A_Record2RRecord ans) additional
                                 /\ ns!sRDATA = ans!sNAME) };
    `(this, _) <- @StatefulInsertAll RecResolverSchema _ _ _ this ``sSLIST
                       () authorityAndAdditional
                       (@QSInsert _)
                       (fun aal _ => ret (< sQUERYCOUNT :: (natToWord _ 0 : W),
                                          sTTL :: (curTime ^+ serverTTL : timeT ) > ++ aal, tt))
                       (fun a s => ret s);
    ret this
.

Definition addAnswersToCache
           (curTime : timeT)
           (this : QueryStructure RecResolverSchema)
           (answers : list resourceRecord)
           (authority : list resourceRecord)
           (additional : list resourceRecord)
  : Comp (QueryStructure RecResolverSchema) :=
  `(this, _) <- @StatefulInsertAll RecResolverSchema _ _ _ this ``sCACHE
   () (answers ++ authority ++ additional)
   (@QSInsert _)
   (fun aal _ => ret (< sTTL :: curTime ^+ cachedTTL,
                        sCACHETYPE :: ``"Answer",
                        sDOMAIN :: aal!sNAME,
                        sQTYPE :: aal!sTYPE,
                        sCACHEDVALUE :: rRecord2CachedValue aal >, tt))
   (fun a s => ret s);
    ret this.

Definition DnsSpec : ADT _ :=
  Def ADT {
    rep := QueryStructure RecResolverSchema,

    Def Constructor "Init" : rep := empty,,

    Def Method3 "Process"
        (this : rep)
        (sourceIP : W)
        (curTime : timeT)
        (p : packet) : rep * packet * option W :=
      If p!"QR" Then
         (* It's a new request! *)
         vs <- For (v in this!sCACHE) (* Search cache for an answer *)
                    Where (p!"question"!"qtype" = CachedQueryTypes_inj v!sQTYPE)
                    Where (curTime <= v!sTTL) (* only alive cached values *)
                    Return (v ! sCACHEDVALUE) ;
         If is_empty vs Then (* Need to launch a recursive query *)
            (* Generate a unique ID for the new request. *)
            (reqIDs <- For (req in this!sREQUESTS)
                            Where (curTime <= req!sTTL)
                            Return (req!sID);
             newID <- { newID | ~ List.In newID reqIDs};
             (* Find the best known servers to query *)
             bestServer <- MaxElement
                             (fun r r' : @Tuple SLISTHeading =>
                                (prefix r!sDOMAIN r'!sDOMAIN)
                                /\ r!sQUERYCOUNT <= r'!sQUERYCOUNT)
                             (For (server in this!sSLIST)
                              Where (prefix server!sDOMAIN p!"question"!"qname")
                              Where (curTime <= server!sTTL)
                              Return server);
             Ifopt bestServer as bestServer Then (* Pick the first server*)
             `(this, _) <- Delete req from this ! sREQUESTS where (req!sTTL <= curTime);
             `(this, b) <- Insert < sID :: newID,
                                    sIP :: sourceIP,
                                    sTTL :: curTime ^+ requestTTL > ++ p into this!sREQUESTS; (* Add the request to the list. *)
             ret (this, (<"id" :: newID,
                          "QR" :: false,
                          "Opcode" :: ``"Query",
                          "AA" :: false,
                          "TC" :: false,
                          "RD" :: true,
                          "RA" :: false,
                          "RCode" :: ``"NoError",
                          "question" :: p!"question",
                          "answers" :: [ ],
                          "authority" :: [ ],
                          "additional" :: [ ] >, Some bestServer!sIP))
             Else (* There are no known servers that can answer this request. *)
             ret (this, (buildempty false ``"ServFail" p, Some sourceIP)) (* This won't happen if the server has been properly initialized with the root servers. *)
            )
       Else                   (* Return cached answer *)
       (answers <- { answers | NoDup answers
                               /\ forall ans : resourceRecord,
                         List.In ans answers <->
                         List.In (A := CachedValue) ans vs };
          If is_empty answers Then (* It must be a cached failure *)
             failures <- { failures | NoDup failures
                                      /\ forall fail : SOA_Record,
                               List.In (A := resourceRecord) fail failures <->
                               List.In (A := CachedValue) fail vs };
             ret (this, (add_additionals failures (buildempty false ``"NXDomain" p), Some sourceIP)) (* Add the SoA record to additional and return negative result*)
          Else
          ret (this, (add_answers answers (buildempty false ``"NoError" p), Some sourceIP)))
         (* Add the answers to the packet.  *)
       Else (* It's a response *)
       (reqs <- For (req in this!sREQUESTS)
                     Where (req!sID = p!"id")
                     Where (req!"question"!"qtype" = p!"question"!"qtype")
                     Return req;
        Ifopt List.hd_error reqs as req Then
          (IfDec p!"RCODE" = ``"NoError" Then
            (If isAnswer p Then    (* We have an answer! We first try to  the outstanding request that this is an answer to. *)
                `(this, reqs) <- Delete req from this!sREQUESTS where (req!sID = p!"id");
                this <- addAnswersToCache curTime this p!"answers" p!"authority" p!"additional";
                ret (this, (<"id" :: req!"id",
                             "QR" :: true,
                             "Opcode" :: req!"Opcode",
                             "AA" :: false,
                             "TC" :: p!"TC",
                             "RD" :: req!"RD",
                             "RA" :: true,
                             "RCode" :: ``"NoError",
                             "question" :: req!"question",
                             "answers" :: p!"answers",
                             "authority" :: p!"authority",
                             "additional" :: p!"additional" >, Some req!sIP) )

           Else  (* We need to issue another query based on the response. *)
           (this <- linkAuthorityToAdditional curTime this p!"authority" p!"additional";
             bestServer <- MaxElement
                             (fun r r' : @Tuple SLISTHeading =>
                                (prefix r!sDOMAIN r'!sDOMAIN)
                                /\ r!sQUERYCOUNT <= r'!sQUERYCOUNT)
                             (For (server in this!sSLIST)
                              Where (prefix server!sDOMAIN p!"question"!"qname")
                              Where (curTime <= server!sTTL)
                              Return server);
             Ifopt bestServer as bestServer Then (* Pick the first server*)
               ret (this, (<"id" :: p!"id",
                            "QR" :: false,
                            "Opcode" :: ``"Query",
                            "AA" :: false,
                            "TC" :: false,
                            "RD" :: true,
                            "RA" :: false,
                            "RCode" :: ``"NoError",
                            "question" :: p!"question",
                            "answers" :: [ ],
                            "authority" :: [ ],
                            "additional" :: [ ] >, Some bestServer!sIP))
             Else
               ret (this, (p, None ) )
         ) )
         Else (* We need to cache a negative response*)
         (soas <- { soas | NoDup soas
                           /\ forall soa : SOA_Record,
                        List.In soa soas <->
                        List.In (A := resourceRecord) soa (p!"authority") };
         Ifopt List.hd_error soas as soa Then (* The response has an SOA *)
           reqType <- SingletonSet (fun b : CachedQueryTypes => req!"question"!"qtype" = CachedQueryTypes_inj b);
           Ifopt reqType as reqType Then
             (`(this, foo) <- Insert (< sTTL :: curTime ^+ cachedTTL,
                                        sCACHETYPE :: ``"Failure",
                                        sDOMAIN :: req!"question"!"qname",
                                        sQTYPE :: reqType,
                                        sCACHEDVALUE :: Failure2CachedValue (<"RCODE" :: (p!"RCODE" : ResponseCode) > ++ soa!sRDATA : FailureRecord ) > )
               into this!sCACHE;
              ret (this, (p, Some req!sIP))  )
            Else (* It's not a record we care to cache *)
             ret (this, (p, Some req!sIP) )
           Else (* If there's no SOA record in authority, don't cache *)
           ret (this, (p, Some req!sIP ) ) ) )
         Else (* The answer is not affiliated with the packet *)
           ret (this, (p, None ) ) )
       }.


Require Import Program.

Require Import Sem SimProg Skeleton Mod ModSem SimMod SimModSem SimSymb SimMem Sound SimSymb.
Require Import Cop Ctypes ClightC.
Require Import AsmC.
Require SimMemInjInvC.
Require Import CoqlibC.
Require Import ValuesC.
Require Import LinkingC.
Require Import MapsC.
Require Import AxiomsC.
Require Import Ord.
Require Import MemoryC.
Require Import SmallstepC.
Require Import Events.
Require Import Preservation.
Require Import Integers.
Require Import LocationsC Conventions.
Require Import Conventions1C.

Require Import MatchSimModSem.
Require Import IntegersC.
Require Import Coq.Logic.PropExtensionality.
Require Import CtypingC.
Require Import CopC.

Require Import MatchSimModSem.
Require Import Conventions1C.

Require Import ClightStepInj.
Require Import IdSimExtra IdSimInvExtra IdSimClightExtra.
Require Import mktac.

Set Implicit Arguments.

Local Opaque Z.mul Z.add Z.sub Z.div.

Section INJINV.

Variable P: SimMemInjInv.memblk_invariant.

Local Instance SimMemP: SimMem.class := SimMemInjInvC.SimMemInjInv SimMemInjInv.top_inv P.
Local Instance SimSymbP: SimSymb.class SimMemP := SimMemInjInvC.SimSymbIdInv P.

Local Existing Instance SoundTop.Top.

Inductive match_states_clight_inv
  : unit -> Clight.state -> Clight.state -> SimMem.t -> Prop :=
| match_states_clight_intro
    st_src st_tgt j m_src m_tgt sm0
    (MWFSRC: m_src = sm0.(SimMem.src))
    (MWFTGT: m_tgt = sm0.(SimMem.tgt))
    (MWFINJ: j = sm0.(SimMemInjInv.minj).(SimMemInj.inj))
    (MATCHST: match_states_clight_internal st_src st_tgt j m_src m_tgt)
    (MWF: SimMem.wf sm0)
  :
    match_states_clight_inv
      tt st_src st_tgt sm0
.

Lemma clight_inj_inv_id
      (clight: Clight.program)
      (WF: Sk.wf (module2 clight))
  :
    exists mp,
      (<<SIM: ModPair.sim mp>>)
      /\ (<<SRC: mp.(ModPair.src) = (module2 clight)>>)
      /\ (<<TGT: mp.(ModPair.tgt) = (module2 clight)>>)
.
Proof.
  eexists (ModPair.mk _ _ _); s. instantiate (3:= (SimMemInjInvC.mk bot1 _ _)).
  esplits; eauto.
  econs; ss; i.
  { econs; ss; i; clarify. }
  eapply match_states_sim with (match_states := match_states_clight_inv); ss.
  - apply unit_ord_wf.
  - eapply SoundTop.sound_state_local_preservation.

  - i. ss. exploit SimSymbIdInv_match_globals.
    { inv SIMSKENV. ss. eauto. } intros GEMATCH.
    inv INITTGT. inv SAFESRC. inv SIMARGS; ss. inv H. ss.
    exploit match_globals_find_funct; eauto.
    i. clarify.
    esplits; eauto.
    + econs; eauto.
    + refl.
    + econs; eauto. econs; eauto.
      { inv TYP. inv TYP0. eapply inject_list_typify_list; eauto. }
      econs.

  - i. ss. exploit SimSymbIdInv_match_globals.
    { inv SIMSKENV. ss. eauto. } intros GEMATCH.
    des. inv SAFESRC. inv SIMARGS; ss. esplits. econs; ss.
    + eapply match_globals_find_funct; eauto.
    + inv TYP. econs; eauto.
      erewrite <- inject_list_length; eauto.

  - i. ss. inv MATCH; eauto.

  - i. ss. clear SOUND. inv CALLSRC. inv MATCH. inv MATCHST. inv SIMSKENV. ss.
    esplits; eauto.
    + econs; ss; eauto.
      * eapply SimSymbIdInv_find_None; eauto.
        ii. clarify. ss. des. clarify.
      * des. clear EXTERNAL.
        unfold Genv.find_funct, Genv.find_funct_ptr in *. des_ifs_safe.
        inv INJ. inv SIMSKELINK. inv INJECT. exploit IMAGE; eauto.
        { left. eapply Genv.genv_defs_range; eauto. }
        { i. des. clarify. inv SIMSKENV. des_ifs. esplits; eauto. }
    + econs; ss.
    + refl.
    + instantiate (1:=top4). ss.

  - i. ss. clear SOUND HISTORY.
    exists (SimMemInjInvC.unlift' sm_arg sm_ret).
    inv AFTERSRC. inv MATCH. inv MATCHST.
    esplits; eauto.
    + econs; eauto. inv SIMRET; ss.
    + inv SIMRET; ss. econs; eauto. econs; eauto.
      { eapply inject_typify; et. }
      ss. eapply match_cont_incr; try eassumption.
      inv MLE. inv MLE1. inv MLE0. inv MLE. etrans; eauto.
    + refl.

  - i. ss. inv FINALSRC. inv MATCH. inv MATCHST. inv CONT.
    esplits; eauto.
    + econs.
    + econs; eauto.
    + refl.

  - left. i. split.
    + eapply modsem2_receptive.
    + ii. inv MATCH. destruct sm0 as [sm0 mem_inv_src mem_inv_tgt].
      cinv MWF. cinv WF0. ss.
      exploit clight_step_preserve_injection2; try eassumption.
      { instantiate (1:=cgenv skenv_link_tgt clight). ss. }
      { eapply function_entry2_inject. ss. }
      { inv SIMSKENV. ss.
        exploit SimMemInjInvC.skenv_inject_symbols_inject; eauto. }
      { inv SIMSKENV. ss. exploit SimSymbIdInv_match_globals; eauto. } i. des.
      exploit SimMemInjC.parallel_gen; eauto. i. des.
      hexploit SimMemInjInv.le_inj_wf_wf; eauto.
      { eapply SimMemInjInv.private_unchanged_on_invariant; eauto.
        - ii. exploit INVRANGETGT; eauto. i. des. inv MWF. eapply Plt_Ple_trans; eauto.
        - eapply Mem.unchanged_on_implies; eauto.
          i. exploit INVRANGETGT; eauto. i. des. eauto. } intros MWFINV0.

      esplits; eauto.
      * left. apply plus_one. econs; ss; eauto.
        eapply modsem2_determinate.
      * instantiate (1:=SimMemInjInv.mk _ _ _). econs; ss; eauto.
      * econs; ss; eauto.
Unshelve. apply 0.
Qed.

End INJINV.


From sflib Require Import sflib.
Require Import Coq.Classes.RelationClasses.
From Fairness Require Import Axioms NatStructsLarge.
From Fairness Require Import PCMLarge.
From Fairness Require Import Mod.

Set Implicit Arguments.

(* Definition _thsRA {A: Type}: URA.t := Auth.t (Excl.t A). *)
Global Instance thsRA {A: Type}: URA.t := (thread_id ==> Auth.t (Excl.t A))%ra.
(* Compute (URA.car (t:=_thsRA)). *)
(* Global Instance thsRA {A: Type}: URA.t := Auth.t (@_thsRA A). *)

Section THHAS.

  Definition ae_white {A} (a: A) := @Auth.white (Excl.t A) (Some a).
  Definition ae_black {A} (a: A) := @Auth.black (Excl.t A) (Some a).

  Definition th_has {A: Type} (tid: thread_id) (a: A): (@thsRA A) :=
    fun _tid => if (tid_dec _tid tid) then ae_white a else ε.

  Lemma unfold_th_has {A} tid (a: A):
    th_has tid a = fun _tid => if (tid_dec _tid tid) then ae_white a else ε.
  Proof. reflexivity. Qed.

  (* Definition th_has {A: Type} (tid: thread_id) (a: A): @thsRA A := Auth.black (_th_has tid a). *)

  (* properties *)
  Lemma th_has_hit {A: Type}: forall tid (a: A), (th_has tid a) tid = ae_white a.
  Proof. i. rewrite unfold_th_has. des_ifs. Qed.

  Lemma th_has_miss {A: Type}: forall tid tid' (MISS: tid <> tid') (a: A), (th_has tid a tid') = ε.
  Proof. i. rewrite unfold_th_has. des_ifs. Qed.

  Lemma th_has_disj {A: Type}: forall tid0 tid1 (a0 a1: A),
      URA.wf (th_has tid0 a0 ⋅ th_has tid1 a1) -> tid0 <> tid1.
  Proof. ii. do 2 ur in H. clarify. specialize (H tid1). rewrite !th_has_hit in H. ss. ur in H. ss. Qed.

End THHAS.
Notation "tid |-> a" := (th_has tid a) (at level 20).
Global Opaque th_has.

(* black + delta --> new_black *)
Definition add_delta_to_black `{M: URA.t} (b: Auth.t M) (w: Auth.t _): Auth.t _ :=
  match b, w with
  | Auth.excl e _, Auth.frag f1 => Auth.black (e ⋅ f1)
  | _, _ => Auth.boom
  end
.


Require Import Fiat.Parsers.Grammars.JavaScriptAssignmentExpression.
Require Import Fiat.Parsers.Refinement.Tactics.
Require Import Fiat.Parsers.Refinement.DisjointRules.
Require Import Fiat.Parsers.Refinement.DisjointRulesRev.
Require Import Fiat.Parsers.ExtrOcamlParsers. (* for simpl rules for [find_first_char_such_that] *)
Require Import Fiat.Parsers.Refinement.BinOpBrackets.BinOpRules.
Require Import Fiat.Parsers.StringLike.String.

(*Require Coq.micromega.Lia.
Require Coq.PArith.BinPos.
Require Coq.Lists.List.
Require Coq.Sorting.Mergesort.
Require Coq.Structures.OrdersEx.
Require Coq.Strings.Ascii.
Require Coq.Strings.String.
Require Fiat.Parsers.ContextFreeGrammar.Core.
Require Fiat.Parsers.ContextFreeGrammar.Carriers.
Require Fiat.Parsers.ContextFreeGrammar.Reflective.
Require Fiat.Parsers.ContextFreeGrammar.PreNotations.
Require Fiat.Parsers.Refinement.PossibleTerminalsSets.*)
Require ExplorationUtil.
Set Ltac Profiling.
Section IndexedImpl.
  (*Context {HSLM : StringLikeMin Ascii.ascii}
          {HSL : StringLike Ascii.ascii}
          {HSI : StringIso Ascii.ascii}
          {HSLP : StringLikeProperties Ascii.ascii}
          {HSEP : StringEqProperties Ascii.ascii}
          {HSIP : StringIsoProperties Ascii.ascii}.*)

  Lemma ComputationalSplitter'
  : FullySharpened (string_spec javascript_assignment_expression_pregrammar string_stringlike).
  Proof.

    Time start sharpening ADT.

    Reset Ltac Profile.
    Time start honing parser using indexed representation.
    Show Ltac Profile.

    Reset Ltac Profile.
    Time hone method "splits".
    Show Ltac Profile.
    {
      Reset Ltac Profile.
      Time simplify parser splitter.
      Show Ltac Profile.
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse binop search for , \s* ... *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse binop search for , \s* ... *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse binop search for , \s* ... *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse binop search for , \s* ... *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* binop search for ... \s* = *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse binop search for *= \s* ... N.B. This is different, requires 2-char binop *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* binop search for ... \s* = *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse binop search for *= \s* ... N.B. This is different, requires 2-char binop *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* binop search for ... \s* = *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse binop search for *= \s* ... N.B. This is different, requires 2-char binop *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* binop search for ... \s* = *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse binop search for *= \s* ... N.B. This is different, requires 2-char binop *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* binop search for ... \s* & *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* binop search for ... \s* & *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* binop search for ... \s* & *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* binop search for ... \s* & *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse binop search for = \s* ... *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse binop search for = \s* ... *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse binop search for = \s* ... *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse binop search for = \s* ... *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse binop search for < \s* ... *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* ??? wtf [true instanceof Boolean instanceof new "instanceof"] and [true instanceof Boolean instanceof new instanceof] *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse binop search for < \s* ... *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* ??? wtf [true instanceof Boolean instanceof new "instanceof"] and [true instanceof Boolean instanceof new instanceof] *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse binop search for < \s* ... *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* ??? wtf [true instanceof Boolean instanceof new "instanceof"] and [true instanceof Boolean instanceof new instanceof] *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* ??? wtf [true in Object in new "in"] and [true in Object in new in] (invalid parse) *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse binop search for < \s* ... *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* ??? wtf [true instanceof Boolean instanceof new "instanceof"] and [true instanceof Boolean instanceof new instanceof] *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* ??? wtf [true in Object in new "in"] and [true in Object in new in] (invalid parse) *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse binop search for + \s* ... *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse binop search for + \s* ... *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse binop search for * \s* ... *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse binop search for * \s* ... *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse disjoint + fixed length for ... \s* ++ *) }
      { exfalso; admit. (* reverse disjoint + fixed length for ... \s* ++ *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse binop search for , \s* ... *) }
      { exfalso; admit. (* reverse disjoint + fixed length for ... \s* ) *) }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse disjoint + fixed length for ... \s* ] *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* ???  "[]. a . a", "[]. a [ [] + [] ]" *) }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse paren search for \s* (...) N.B. this requires 0-char binops *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse paren search for \s* (...) N.B. this requires 0-char binops *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* ???  "[]. a . a", "[]. a [ [] + [] ]" *) }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse paren search for \s* (...) N.B. this requires 0-char binops *) }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* ???  "[]. a . a", "[]. a [ [] + [] ]" *) }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse paren search for \s* (...) N.B. this requires 0-char binops *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse binop search for , \s* ... *) }
      { exfalso; admit. (* reverse disjoint + fixed length for ... \s* ] *) }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse binop search for , \s* ... (hopefully?) *) }
      { exfalso; admit. (* reverse disjoint + fixed length for ... \s* } *) }
      { Time shelve; refine_disjoint_search_for. }
      { exfalso; admit. (* reverse disjoint + fixed length for ... \s* ) *) }
      { Time shelve; refine_disjoint_search_for. }
      (*{ Time Import ExplorationUtil.
        pose javascript_assignment_expression_pregrammar as G.
        print_production javascript_assignment_expression_pregrammar (4, (0, 1)).
        print_productions G "LiteralField".
        print_productions G "LiteralElement".
        print_productions G "AssignmentExpression normal,allowIn".
        print_productions G "MemberOperator".
        print_productions G "CallExpression initial".
        print_productions G "ShortNewSubexpression".
        print_productions G "Arguments".
        print_productions G "FullNewSubexpression".
        print_productions G "FullNewSubexpression".
        print_productions G "PrimaryExpression normal".
        print_productions G "MemberOperator".
        print_chars "MemberOperator".
        print_productions G "ArgumentList".
        print_last_chars "PostfixExpression normal".
        print_productions G "RelationalExpression initial,noIn".
        print_productions G "AdditiveExpression normal".
        print_productions G "MultiplicativeExpression normal".
        print_productions G "UnaryExpression normal".
        print_productions G "PostfixExpression normal".
        print_productions G "LeftSideExpression normal".
        print_productions G "ShortNewExpression".
        print_productions G "Arguments".
        print_productions G "ShortNewSubexpression".
        print_productions G "FullNewSubexpression".
        print_productions G "PrimaryExpression normal".
        print_productions G "SimpleExpression".
        print_productions G "ObjectLiteral".
        print_productions G "Identifier".
        print_productions G "CallExpression normal"
        print_productions G "SimpleExpression".
        print_productions G "AssignmentExpression normal,noIn".
        print_chars "CompoundAssignment".
        print_productions javascript_assignment_expression_pregrammar "Expression initial,noIn".
        print_productions G "AssignmentExpression normal,noIn".
        print_productions javascript_assignment_expression_pregrammar "LeftSideExpression normal".
        print_productions javascript_assignment_expression_pregrammar "AssignmentExpression normal,allowIn".
        print_productions G "CompoundAssignment".*)
      (*{ Require Import ExplorationUtil.
        print_production javascript_assignment_expression_pregrammar (4, (0, 2)).
print_productions javascript_assignment_expression_pregrammar "LiteralField". (*"MemberOperator". *)
        pose javascript_assignment_expression_pregrammar as G.
        print_productions javascript_assignment_expression_pregrammar "LeftSideExpression normal".
        print_productions javascript_assignment_expression_pregrammar "AssignmentExpression normal,allowIn".
        print_productions G "CompoundAssignment".*)

      simplify parser splitter.
      Show Ltac Profile.
      (*
total time:     84.328s

 tactic                                    self  total   calls       max
────────────────────────────────────────┴──────┴──────┴───────┴─────────┘
─rewrite_disjoint_search_for -----------   0.0%  39.4%      20    4.268s
─rewrite_disjoint_search_for_no_clear --   0.0%  39.3%      20    4.260s
─rewrite_once_disjoint_search_for ------   0.0%  38.8%      40    4.240s
─rewrite_once_disjoint_search_for_specia  33.6%  38.3%      40    4.212s
─refine_binop_table --------------------   0.0%  37.9%       4    8.036s
─setoid_rewrite_refine_binop_table_idx -  37.0%  37.9%       4    8.032s
─simplify parser splitter --------------   0.0%  18.7%       2   14.980s
─simplify_parser_splitter' -------------   0.0%  18.7%      31   12.444s
─simplify ------------------------------   0.0%  18.7%       2   14.980s
─eapply (refine_opt2_fold_right r_o retv  13.5%  13.5%       1   11.364s
─simplify with monad laws --------------   0.0%   4.4%      30    1.900s
─simplify_with_applied_monad_laws ------   0.0%   4.4%      30    1.900s
─rewrite_disjoint_rev_search_for -------   0.0%   3.9%       2    1.636s
─rewrite_disjoint_rev_search_for_no_clea   0.0%   3.8%       2    1.632s
─rewrite_once_disjoint_rev_search_for --   0.0%   3.8%       4    1.608s
─rewrite_once_disjoint_rev_search_for_sp   3.4%   3.7%       4    1.572s
─specialize (lem' H') ------------------   2.7%   2.7%      44    1.996s

 tactic                                    self  total   calls       max
────────────────────────────────────────┴──────┴──────┴───────┴─────────┘
─rewrite_disjoint_search_for -----------   0.0%  39.4%      20    4.268s
└rewrite_disjoint_search_for_no_clear --   0.0%  39.3%      20    4.260s
└rewrite_once_disjoint_search_for ------   0.0%  38.8%      40    4.240s
└rewrite_once_disjoint_search_for_specia  33.6%  38.3%      40    4.212s
└specialize (lem' H') ------------------   2.6%   2.6%      40    1.996s
─refine_binop_table --------------------   0.0%  37.9%       4    8.036s
└setoid_rewrite_refine_binop_table_idx -  37.0%  37.9%       4    8.032s
─simplify parser splitter --------------   0.0%  18.7%       2   14.980s
└simplify ------------------------------   0.0%  18.7%       2   14.980s
└simplify_parser_splitter' -------------   0.0%  18.7%      31   12.444s
 ├─eapply (refine_opt2_fold_right r_o re  13.5%  13.5%       1   11.364s
 └─simplify with monad laws ------------   0.0%   4.4%      30    1.900s
  └simplify_with_applied_monad_laws ----   0.0%   4.4%      30    1.900s
─rewrite_disjoint_rev_search_for -------   0.0%   3.9%       2    1.636s
└rewrite_disjoint_rev_search_for_no_clea   0.0%   3.8%       2    1.632s
└rewrite_once_disjoint_rev_search_for --   0.0%   3.8%       4    1.608s
└rewrite_once_disjoint_rev_search_for_sp   3.4%   3.7%       4    1.572s
 *)
      Time finish honing parser method.
    }

    Time finish_Sharpening_SplitterADT.

  Time Defined. (* 85 seconds *)

  Lemma ComputationalSplitter
  : FullySharpened (string_spec json'_grammar string_stringlike).
  Proof.
    Reset Ltac Profile.
    Time make_simplified_splitter ComputationalSplitter'. (* 19 s *)
    Show Ltac Profile.
  Time Defined.

Time End IndexedImpl.

Require Export Fiat.Parsers.ParserFromParserADT.
Require Export Fiat.Parsers.ExtrOcamlParsers.
Export Fiat.Parsers.ExtrOcamlParsers.HideProofs.
Require Export Fiat.Parsers.StringLike.OcamlString.

Definition json_parser (str : Coq.Strings.String.string) : bool.
Proof.
  Reset Ltac Profiling.
  Time make_parser (@ComputationalSplitter(* _ String.string_stringlike _ _*)). (* 75 seconds *)
  Show Ltac Profile.
Time Defined.

(*Definition json_parser_ocaml (str : Ocaml.Ocaml.string) : bool.
Proof.
  Time make_parser (@ComputationalSplitter _ Ocaml.string_stringlike _ _). (* 0.82 s *)
Defined.*)

Print json_parser(*_ocaml*).

Recursive Extraction json_parser(*_ocaml*).
(*
Definition main_json := premain json_parser.
Definition main_json_ocaml := premain_ocaml json_parser_ocaml.

Parameter reference_json_parser : Coq.Strings.String.string -> bool.
Parameter reference_json_parser_ocaml : Ocaml.Ocaml.string -> bool.
Extract Constant reference_json_parser
=> "fun str ->
  let needs_b : bool Pervasives.ref = Pervasives.ref false in
  try
    (List.iter (fun ch ->
       match ch, !needs_b with
       | 'a', false -> needs_b := true; ()
       | 'b', true  -> needs_b := false; ()
       | _, _       -> raise Not_found)
       str;
     if !needs_b then false else true)
  with
   | Not_found -> false".
Extract Constant reference_json_parser_ocaml
=> "fun str ->
  let needs_b : bool Pervasives.ref = Pervasives.ref false in
  try
    (String.iter (fun ch ->
       match ch, !needs_b with
       | 'a', false -> needs_b := true; ()
       | 'b', true  -> needs_b := false; ()
       | _, _       -> raise Not_found)
       str;
     if !needs_b then false else true)
  with
   | Not_found -> false".

Definition main_json_reference := premain reference_json_parser.
Definition main_json_reference_ocaml := premain_ocaml reference_json_parser_ocaml.

(*
(* val needs_b : bool Pervasives.ref;; *)
let needs_b = Pervasives.ref false;;

let chan = match Array.length Sys.argv with
| 0 | 1 -> Pervasives.stdin
| 2 -> let chan = Pervasives.open_in Sys.argv.(1)
       in Pervasives.at_exit (fun () -> Pervasives.close_in chan);
	  chan
| argc -> Pervasives.exit argc;;

(* val line : string;; *)
let line = Pervasives.input_line chan;;

String.iter (fun ch ->
  match ch, !needs_b with
  | 'a', false -> needs_b := true; ()
  | 'b', true  -> needs_b := false; ()
  | _, _       -> Pervasives.exit 1)
  line;;

Pervasives.exit 0;;
*)
(*
Definition test0 := json_parser "".
Definition test1 := json_parser "ab".
Definition str400 := "abababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababababab".
Definition test2 := json_parser (str400 ++ str400 ++ str400 ++ str400).

Recursive Extraction test0 test1 test2.
*)
*)


Load "frame3".
(*
(** * Frame [phi4] *)
Definition mphi3ttt n1 n2 := (phi2tt n1) ++ [msg ((pk 2), ( (e (b n2 19) 20),  (sign (sk 2) (e (b n2 19) 20))))].
Definition x4ttt n1 n2 := (f (conv_mylist_listm (mphi3ttt n1 n2))).
Definition phi3ttft n1  := (phi2tt n1) ++ [msg  ((bsign (sk 3)  (pi1 (pi2 (pi1  (x3tt n1 ))))),  (bsign (sk 3)  (pi1 (pi2 (pi2  (x3tt n1 ))))))].
Definition x4ttft n1 := (f (conv_mylist_listm (phi3ttft n1))).

Definition phi3tftt n1 n2 := (phi2tft n1 n2) ++ [msg ok].
Definition x4tftt n1 n2 := (f (conv_mylist_listm (phi3tftt n1 n2))).

Definition phi3tftft n1 n2 := (phi2tft n1 n2) ++ [msg ok].
Definition x4tftft n1 n2 := (f (conv_mylist_listm (phi3tftft n1 n2))).

Definition phi3tftfft n1 n2 := (phi2tft n1 n2) ++ [msg  ((bsign (sk 3)  (pi1 (pi2 (pi1 (x3tft n1 n2))))),  (bsign (sk 3)  (pi1 (pi2 (pi2 (x3tft n1 n2))))))].
Definition x4tftfft n1 n2 := (f (conv_mylist_listm (phi3tftfft n1 n2))).
Definition phi3tfftt n1  := (phi2tfft n1) ++ [msg ok].
Definition x4tfftt n1  := (f (conv_mylist_listm (phi3tfftt n1))).

Definition phi3tfftft n1 n2 := (phi2tfft n1) ++ [msg ((pk 2), ( (e (b n2 21) 22),  (sign (sk 2) (e (b n2 21) 22))))].
Definition x4tfftft n1 n2 := (f (conv_mylist_listm (phi3tfftft n1 n2))).
Definition phi3fttt n1 n2 := (phi2ftt n2) ++ [msg  ((pk 1), ( (e (b n1 23) 24),  (sign (sk 1) (e (b n1 23) 24))))].

Definition x4fttt n1 n2 := (f (conv_mylist_listm (phi3fttt n1 n2))).
Definition phi3fttft  n2 := (phi2ftt n2) ++ [msg  ((bsign (sk 3)  (pi1 (pi2 (pi1 (x3ftt n2 ))))),  (bsign (sk 3)  (pi1 (pi2 (pi2 (x3ftt n2 ))))))].

Definition x4fttft n2 := (f (conv_mylist_listm (phi3fttft n2))).
Definition phi3ftftt n1 n2:= (phi2ftft n1 n2) ++ [msg ok].
Definition x4ftftt n1 n2 := (f (conv_mylist_listm (phi3ftftt n1 n2))).
Definition phi3ftftft n1 n2:= (phi2ftft n1 n2) ++ [msg ok].
Definition x4ftftft n1 n2 := (f (conv_mylist_listm (phi3ftftft n1 n2))).
Definition phi3ftftfft n1 n2:= (phi2ftft n1 n2) ++ [msg  ((bsign (sk 3)  (pi1 (pi2 (pi1 (x3ftft n1 n2))))),  (bsign (sk 3)  (pi1 (pi2 (pi2 (x3ftft n1 n2))))))].
Definition x4ftftfft n1 n2 := (f (conv_mylist_listm (phi3tftft n1 n2))).
Definition phi3ftfftt  n2 := (phi2ftfft n2) ++ [msg ok].
Definition x4ftfftt n2 := (f (conv_mylist_listm (phi3ftfftt n2))).

Definition phi3ftfftft n1 n2 := (phi2ftfft n2) ++ [msg ((pk 1), ( (e (b n1 25) 26),  (sign (sk 1) (e (b n1 25) 26))))].

Definition x4ftfftft n1 n2 := (f (conv_mylist_listm (phi3ftfftft n1 n2))).

Definition phi3ffttt n1  := (phi2fftt n1) ++ [msg ok].
Definition x4ffttt n1 := (f (conv_mylist_listm (phi3ffttt n1))).

Definition phi3ffttft n1 n2 := (phi2fftt n1) ++ [msg ((pk 2), ( (e (b n2 27) 28),  (sign (sk 2) (e (b n2 27) 28))))].
Definition x4ffttft n1 n2 := (f (conv_mylist_listm (phi3ffttft n1 n2))).

Definition phi3fftftt  n2 := (phi2fftft n2) ++ [msg ok].

Definition x4fftftt n2 := (f (conv_mylist_listm (phi3fftftt n2))).
Definition phi3fftftft n1 n2 := (phi2fftft n2) ++ [msg  ((pk 1), ( (e (b n1 29) 30),  (sign (sk 1) (e (b n1 29) 30))))].
Definition x4fftftft n1 n2 := (f (conv_mylist_listm (phi3fftftft n1 n2))).
(************************************************************************************************************************)
Definition mphi3 n1 n2 := (conv_mylist_listm (phi3 n1 n2)).
Definition x4 n1 n2 := (f (mphi3 n1 n2)).

Definition q111 n1 n2 := (ifm  (eqm (to (x4ttt n1 n2)) (V 2))& (bacc (pk 3) (b n2 19) (r 20) (pi2 (x4ttt n1 n2))) ok
                                     (admin (x4ttt n1 n2))).

Definition q112 n1 := (ifm  (eqm (to (x4ttft n1)) (V 2))  ((pk 2), ( (e (b n1 31) 32),  (sign (sk 2) (e (b n1 31) 32)))) O).

 (*************************************************)

Definition q121 n1 n2 := (ifm (eqm (to (x4tftt n1 n2)) (V 2 ))& (bacc (pk 3) (b n2 11) (r 12) (pi2 (x4tftt n1 n2))) ok
                         (admin (x4tftt n1 n2))).

Definition q122 n1 n2 := (ifm (eqm (to (x4tftft n1 n2)) (V 1 ))& (bacc (pk 3) (b n1 7) (r 8) (pi1 (x4tftft n1 n2))) ok
                         (admin (x4tftft n1 n2))).

Definition  q123 n1 n2 := (ifm (eqm (to (x4tftfft n1 n2)) (V 1 ))& (bacc (pk 3) (b n1 7) (r 8) (pi1 (x4tftfft n1 n2))) ok
                          (ifm (eqm (to (x4tftfft n1 n2)) (V 2 ))& (bacc (pk 3) (b n2 11) (r 12) (pi2 (x4tftfft n1 n2))) ok
                               O)).
(****************************************************)

Definition q131 n1 n2 := (ifm  (eqm (to (x4tfftt n1 )) (V 2))  ((pk 2), ( (e (b n2 33) 34),  (sign (sk 2) (e (b n2 33) 34)))) O).

Definition q132  n1 n2:=  (ifm (eqm (to (x4tfftft n1 n2)) (V 1 ))& (bacc (pk 3) (b n1 7) (r 8) (pi1 (x4tfftft n1 n2))) ok
                          (ifm (eqm (to (x4tfftft n1 n2)) (V 2 ))& (bacc (pk 3) (b n2 21) (r 22) (pi2 (x4tfftft n1 n2))) ok
                               O)).
(****************************************************)

Definition q211 n1 n2 :=  (ifm (eqm (to (x4fttt n1 n2)) (V 1 ))& (bacc (pk 3) (b n1 23) (r 24) (pi1 (x4fttt n1 n2))) ok
                          (admin (x4fttt n1 n2))).

Definition q212  n2 :=  (ifm  (eqm (to (x4fttft n2)) (V 2))  ((pk 2), ( (e (b n2 35) 36),  (sign (sk 2) (e (b n2 35) 36)))) O).

(***************************************************)

Definition q221 n1 n2:=   (ifm (eqm (to (x4ftftt n1 n2)) (V 2 ))& (bacc (pk 3) (b n2 9) (r 10) (pi2 (x4ftftt n1 n2))) ok
                           (admin (x4ftftt n1 n2))).
Definition q222 n1 n2 :=  (ifm (eqm (to (x4ftftft n1 n2)) (V 1 ))& (bacc (pk 3) (b n1 13) (r 14) (pi1 (x4ftftft n1 n2))) ok                               (admin (x4ftftft n1 n2))).
Definition q223 n1 n2 := (ifm (eqm (to (x4ftftfft n1 n2)) (V 1 ))& (bacc (pk 3) (b n1 13) (r 14) (pi1 (x4ftftfft n1 n2))) ok
                         (ifm (eqm (to (x4ftftfft n1 n2)) (V 2 ))& (bacc (pk 3) (b n2 9) (r 10) (pi2 (x4ftftfft n1 n2))) ok
                              O)).

(***************************************************)

Definition q231 n1 n2 := (ifm (eqm (to (x4ftfftt n2)) (V 1))  ((pk 1), ( (e (b n1 37) 38),  (sign (sk 2) (e (b n1 37) 38)))) O).

Definition q232 n1 n2 := (ifm (eqm (to (x4ftfftft n1 n2)) (V 1 ))& (bacc (pk 3) (b n1 25) (r 26) (pi1 (x2 n1 n2))) ok

                              (ifm (eqm (to (x4ftfftft n1 n2)) (V 2 ))& (bacc (pk 3) (b n2 9) (r 10) (pi2 (x2 n1 n2))) ok
                               O)).
(***************************************************)

Definition q311  n1 n2 := (ifm  (eqm (to (x4ffttt n1 )) (V 2))  ((pk 2), ( (e (b n2 39) 40),  (sign (sk 2) (e (b n2 39) 40))))
                                                    O).
Definition q312 n1 n2  :=  (ifm (eqm (to (x4ffttft n1 n2)) (V 1 ))& (bacc (pk 3) (b n1 15) (r 16) (pi1 (x4ffttft n1 n2))) ok
                          (ifm (eqm (to (x4ffttft n1 n2)) (V 2 ))& (bacc (pk 3) (b n2 27) (r 28) (pi2 (x4ffttft n1 n2))) ok
                               O)).

(****************************************)

Definition q321  n1 n2 := (ifm  (eqm (to (x4fftftt n2)) (V 1))  ((pk 1), ( (e (b n1 41) 42),  (sign (sk 1) (e (b n1 41) 42)))) O).

Definition q322 n1 n2 :=  (ifm (eqm (to (x4fftftft n1 n2)) (V 1 ))& (bacc (pk 3) (b n1 29) (r 30) (pi1 (x4fftftft n1 n2))) ok
                          (ifm (eqm (to (x4fftftft n1 n2)) (V 2 ))& (bacc (pk 3) (b n2 17) (r 18) (pi2 (x4fftftft n1 n2))) ok
                               O)).

(*****************************************)

Definition q11_s n1 n2 :=  (ifm  (eqm (to (x3tt n1 )) (V 2)) (q111 n1 n2)
                                      (ifm (achecks (x3tt n1 )) (q112 n1 )  O)).

Definition q12_s n1 n2 := (ifm (eqm (to (x3tft n1 n2)) (V 1))& (bacc (pk 3) (b n1 7) (r 8) (pi2 (x3tft n1 n2))) (q121 n1 n2)
                                    (ifm (eqm (to (x3tft n1 n2)) (V 2))& (bacc (pk 3) (b n2 11) (r 12) (pi2 (x3tft n1 n2))) (q122 n1 n2)
                                                    (ifm (achecks (x3tft n1 n2)) (q123 n1 n2) O))).

Definition q13_s n1 n2 := (ifm (eqm (to (x3tfft n1 )) (V 1))& (bacc (pk 3) (b n1 7) (r 8) (pi2 (x3tfft n1 ))) (q131 n1 n2)
                                    (ifm  (eqm (to (x3tfft n1 )) (V 2)) (q132 n1 n2) O)).

Definition q21_s n1 n2 := (ifm  (eqm (to (x3ftt n2)) (V 1))  (q211 n1 n2)
                                   (ifm (achecks (x3ftt n2)) (q212  n2) O)).

Definition q22_s n1 n2  := (ifm (eqm (to (x3ftft n1 n2)) (V 1))& (bacc (pk 3) (b n1 13) (r 14) (pi1 (x3ftft n1 n2))) (q221 n1 n2)
                                    (ifm (eqm (to (x3ftft n1 n2)) (V 2))& (bacc (pk 3) (b n2 9) (r 10) (pi2 (x3ftft n1 n2))) (q222 n1 n2)
                                                   (ifm (achecks (x3ftft n1 n2)) (q223 n1 n2) O))).

Definition q23_s n1 n2 := (ifm (eqm (to (x3ftfft  n2)) (V 2))& (bacc (pk 3) (b n2 9) (r 10) (pi2 (x3ftfft n2))) (q231 n1 n2)
                        (ifm  (eqm (to (x3ftfft  n2)) (V 1))  (q232 n1 n2) O)).

Definition q31_s n1 n2 := (ifm (eqm (to (x3fftt n1 )) (V 1))& (bacc (pk 3) (b n1 15) (r 16) (pi1 (x3fftt n1 ))) (q311 n1 n2)
                                    (ifm  (eqm (to (x3fftt n1 )) (V 2))  (q312 n1 n2) O)).

Definition q32_s n1 n2 := (ifm (eqm (to (x3fftft  n2)) (V 2))& (bacc (pk 3) (b n2 17) (r 18) (pi2 (x3fftft n2))) (q321 n1 n2)
                                    (ifm  (eqm (to (x3fftft  n2)) (V 1)) (q322 n1 n2) O)).
(********************************************************************************************)

Definition q1_ss n1 n2 := (ifm (eqm (to (x2t n1 )) (V 1))& (bacc (pk 3) (b n1 7) (r 8) (pi1 (x2t n1 )))  (q11_s n1 n2)
			           (ifm (eqm (to (x2t n1 )) (V 2))  (q12_s n1 n2)
                                                  (ifm (achecks (x2t n1 )) (q13_s n1 n2) O))).

Definition q2_ss n1 n2 :=  (ifm (eqm (to (x2ft n2)) (V 2))& (bacc (pk 3) (b n2 9) (r 10) (pi2 (x2ft n2)))  (q21_s n1 n2)
			           (ifm (eqm (to (x2ft n2)) (V 1))  (q22_s n1 n2)
                                                   (ifm (achecks (x2ft n2)) (q23_s n1 n2) O))).

Definition q3_ss n1 n2 := (ifm (eqm (to (x2fft)) (V 1)) (q31_s n1 n2)
		    	            (ifm  (eqm (to (x2fft )) (V 2))  (q32_s n1 n2) O)).

Definition t3 n1 n2 :=  (ifm (eqm (to x1) (V 1)) (q1_ss n1 n2)
		    	           (ifm (eqm (to x1) (V 2))  (q2_ss n1 n2)
                                                   (ifm (achecks x1) (q3_ss n1 n2)
                                                                   O))).

Definition phi4 n1 n2 := (phi3 n1 n2) ++ [msg (t3 n1 n2)] .

(*

Theorem frame4ind : (phi4 0 1) ~ (phi4 1 0).
Proof.  unfold phi4, phi3. unfold t2, t3. simpl.
        unfold q1_s, q2_s, q3_s. unfold q1_ss, q2_ss, q3_ss.
        repeat unf.
repeat unfold admin, achecks.
  ufcma_pi1 x1.
ufcma_pi1 (x2t 0).
ufcma_pi2 (x2t 0).
ufcma_pi1 (x2ft 1).
ufcma_pi2 (x2ft 0).
ufcma_pi1 (x2t 1).
ufcma_pi2 (x2t 1).
ufcma_pi1 (x2ft 0).
repeat aply_andB_elm.
repeat (rew_mupbver;aply_bver; rew_hyps; try split; try reflexivity).

repeat unfold q11_s, q21_s. repeat unf.  unfold q12_s, q22_s.
repeat unfold q111, q112, q121, q122, q123, q121, q132, q211, q212, q221, q222, q223, q231, q232, q311, q312, q321, q322; repeat unfold q11, q12, q13, q21, q22, q23, q31, q32. repeat unf.
repeat unfold admin, achecks.
ufcma_pi1 (x3ftft 0 1);
ufcma_pi2 (x3ftft 0 1);
ufcma_pi1 (x3ftft 1 0);
ufcma_pi2 (x3ftft 1 0).
Ltac unforge x1 n1 n2:=
  ufcma_pi1 (x1 n1 n2); ufcma_pi2 (x1 n1 n2);   ufcma_pi1 (x1 n2 n1);   ufcma_pi2 (x1 n2 n1).
unforge x3tft 0 1 .
unforge x4tftft 0 1.
unforge x4ftftt 0 1.
apply IFBRANCH_M4 with (ml1:= (phi0)) (ml2:= phi0).
simpl.
repeat aply_andB_elm.

apply IFBRANCH_M3 with (ml1:= [msg (pk 0); msg (pk 1); msg (pk 2); msg (pk 3);
    msg (nonce 4); msg (pk 5); bol (eqm (to x1) (V 1));
    msg (pk 1, (e (b 0 7) 8, sign (sk 1) (e (b 0 7) 8)))]) (ml2:=  [msg (pk 0); msg (pk 1); msg (pk 2); msg (pk 3);
   msg (nonce 4); msg (pk 5); bol (eqm (to x1) (V 1));
   msg (pk 1, (e (b 1 7) 8, sign (sk 1) (e (b 1 7) 8)))]).
simpl.
apply IFBRANCH_M2 with (ml1:= [msg (pk 0); msg (pk 1); msg (pk 2); msg (pk 3);
    msg (nonce 4); msg (pk 5); bol (eqm (to x1) (V 1));
    msg (pk 1, (e (b 0 7) 8, sign (sk 1) (e (b 0 7) 8)));
    bol (eqm (to (x2t 0)) (V 2));
    msg (pk 2, (e (b 1 11) 12, sign (sk 2) (e (b 1 11) 12)))]) (ml2:= [msg (pk 0); msg (pk 1); msg (pk 2); msg (pk 3);
   msg (nonce 4); msg (pk 5); bol (eqm (to x1) (V 1));
   msg (pk 1, (e (b 1 7) 8, sign (sk 1) (e (b 1 7) 8)));
   bol (eqm (to (x2t 1)) (V 2));
   msg (pk 2, (e (b 0 11) 12, sign (sk 2) (e (b 0 11) 12)))]).
simpl.
repeat (rew_mupbver;aply_bver; rew_hyps; try split; try reflexivity).
  aply_blindness 3 8 12 0 1 (b 0 7) (b 1 11)  ((Mvar 0), (Mvar 1)) ((Mvar 0), (Mvar 1))  [msg (pk 0); msg (pk 1); msg (pk 2); msg (pk 3);
                                                                                msg (nonce 4); msg (pk 5); msg (sk 1); msg (sk 2); msg (sk 3) ] ; simpl;
aplyprojn 1 16 H; try split; try reflexivity;
rep_commits 0 1 11 21 7 22 fr1 fr2 temp H H0;
rename H0 into H;
appconst H;
x1checks x1 x1 H;
funapp_vtrm 1 0 1 7 8 H;
funapp_vtrm 2 1 0 11 12 H.
x1checks (x2t 0 ) (x2t 1) H.
x1checks (x3tft 0 1) (x3tft 1 0) H.
adminchecks (x3tft 0 1) (x3tft 1 0) H.
Ltac ver_suc1 n x1 e1 x2 e2 H:=
  funapptrmhyp (bol (eqm (pi1 (pi2 x1)) e1)) (bol (eqm (pi1 (pi2 x2)) e2)) H;
  funapptrmhyp (bol  (ver (pk n) e1 (pi2 (pi2 x1))))  (bol (ver (pk n) e2 (pi2 (pi2 x2)))) H.

ver_suc1 2 (pi2 (x3tft 0 1)) (e (b 1 11) 12) (pi2 (x3tft 1 0)) (e (b 0 11) 12) H.
  funapptrmhyp (msg (ifm
                     (ver (pk 2) (e (b 1 11) 12)
                        (pi2 (pi2 (pi2 (x3tft 0 1)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3tft 0 1)))),
                     bsign (sk 3) (pi1 (pi2 (pi2 (x3tft 0 1))))) O)) (msg    (ifm
                     (ver (pk 2) (e (b 0 11) 12)
                        (pi2 (pi2 (pi2 (x3tft 1 0)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3tft 1 0)))),
                      bsign (sk 3) (pi1 (pi2 (pi2 (x3tft 1 0))))) O)) H.
  funapptrmhyp (msg  (ifm (eqm (pi1 (pi2 (pi2 (x3tft 0 1)))) (e (b 1 11) 12)) (ifm
                     (ver (pk 2) (e (b 1 11) 12)
                        (pi2 (pi2 (pi2 (x3tft 0 1)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3tft 0 1)))),
                     bsign (sk 3) (pi1 (pi2 (pi2 (x3tft 0 1))))) O) O)) (msg  (ifm (eqm (pi1 (pi2 (pi2 (x3tft 1 0)))) (e (b 0 11) 12))  (ifm (ver (pk 2) (e (b 0 11) 12) (pi2 (pi2 (pi2 (x3tft 1 0))))) (bsign (sk 3) (pi1 (pi2 (pi1 (x3tft 1 0)))),
                                                                                bsign (sk 3) (pi1 (pi2 (pi2 (x3tft 1 0))))) O) O)) H.

  ver_suc1 1 (pi1 (x3tft 0 1)) (e (b 0 7) 8) (pi1 (x3tft 1 0)) (e (b 1 7) 8) H.
  funapptrmhyp (msg  (ifm (ver (pk 1) (e (b 0 7) 8) (pi2 (pi2 (pi1 (x3tft 0 1)))))
               (ifm (eqm (pi1 (pi2 (pi2 (x3tft 0 1)))) (e (b 1 11) 12))
                  (ifm
                     (ver (pk 2) (e (b 1 11) 12)
                        (pi2 (pi2 (pi2 (x3tft 0 1)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3tft 0 1)))),
                     bsign (sk 3) (pi1 (pi2 (pi2 (x3tft 0 1))))) O) O) O)) (msg  (ifm (ver (pk 1) (e (b 1 7) 8) (pi2 (pi2 (pi1 (x3tft 1 0)))))
               (ifm (eqm (pi1 (pi2 (pi2 (x3tft 1 0)))) (e (b 0 11) 12))
                  (ifm
                     (ver (pk 2) (e (b 0 11) 12)
                        (pi2 (pi2 (pi2 (x3tft 1 0)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3tft 1 0)))),
                      bsign (sk 3) (pi1 (pi2 (pi2 (x3tft 1 0))))) O) O) O)) H.
funapptrmhyp (msg   (ifm (eqm (pi1 (pi2 (pi1 (x3tft 0 1)))) (e (b 0 7) 8))
            (ifm (ver (pk 1) (e (b 0 7) 8) (pi2 (pi2 (pi1 (x3tft 0 1)))))
               (ifm (eqm (pi1 (pi2 (pi2 (x3tft 0 1)))) (e (b 1 11) 12))
                  (ifm
                     (ver (pk 2) (e (b 1 11) 12)
                        (pi2 (pi2 (pi2 (x3tft 0 1)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3tft 0 1)))),
                     bsign (sk 3) (pi1 (pi2 (pi2 (x3tft 0 1))))) O) O) O) O)) (msg  (ifm (eqm (pi1 (pi2 (pi1 (x3tft 1 0)))) (e (b 1 7) 8))
            (ifm (ver (pk 1) (e (b 1 7) 8) (pi2 (pi2 (pi1 (x3tft 1 0)))))
               (ifm (eqm (pi1 (pi2 (pi2 (x3tft 1 0)))) (e (b 0 11) 12))
                  (ifm
                     (ver (pk 2) (e (b 0 11) 12)
                        (pi2 (pi2 (pi2 (x3tft 1 0)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3tft 1 0)))),
                      bsign (sk 3) (pi1 (pi2 (pi2 (x3tft 1 0))))) O) O) O) O)) H.

funapptrmhyp  (msg
      (ifm (eqm (to (x3tft 0 1)) (pk 3))
         (ifm (eqm (pi1 (pi2 (pi1 (x3tft 0 1)))) (e (b 0 7) 8))
            (ifm (ver (pk 1) (e (b 0 7) 8) (pi2 (pi2 (pi1 (x3tft 0 1)))))
               (ifm (eqm (pi1 (pi2 (pi2 (x3tft 0 1)))) (e (b 1 11) 12))
                  (ifm
                     (ver (pk 2) (e (b 1 11) 12)
                        (pi2 (pi2 (pi2 (x3tft 0 1)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3tft 0 1)))),
                     bsign (sk 3) (pi1 (pi2 (pi2 (x3tft 0 1))))) O) O) O) O)
         O))  (msg
     (ifm (eqm (to (x3tft 1 0)) (pk 3))
        (ifm (eqm (pi1 (pi2 (pi1 (x3tft 1 0)))) (e (b 1 7) 8))
           (ifm (ver (pk 1) (e (b 1 7) 8) (pi2 (pi2 (pi1 (x3tft 1 0)))))
              (ifm (eqm (pi1 (pi2 (pi2 (x3tft 1 0)))) (e (b 0 11) 12))
                 (ifm
                    (ver (pk 2) (e (b 0 11) 12) (pi2 (pi2 (pi2 (x3tft 1 0)))))
                    (bsign (sk 3) (pi1 (pi2 (pi1 (x3tft 1 0)))),
                     bsign (sk 3) (pi1 (pi2 (pi2 (x3tft 1 0))))) O) O) O) O) O)) H.

restrsublis H.
(** subgoal *)
simpl.
apply IFBRANCH_M2 with (ml1:= [msg (pk 0); msg (pk 1); msg (pk 2); msg (pk 3);
    msg (nonce 4); msg (pk 5); bol (eqm (to x1) (V 1));
    msg (pk 1, (e (b 0 7) 8, sign (sk 1) (e (b 0 7) 8)));
    bol (eqm (to (x2t 0)) (V 2));
    msg (pk 2, (e (b 1 11) 12, sign (sk 2) (e (b 1 11) 12)));
    bol (eqm (to (x3tft 0 1)) (V 1))]) (ml2:= [msg (pk 0); msg (pk 1); msg (pk 2); msg (pk 3);
   msg (nonce 4); msg (pk 5); bol (eqm (to x1) (V 1));
   msg (pk 1, (e (b 1 7) 8, sign (sk 1) (e (b 1 7) 8)));
   bol (eqm (to (x2t 1)) (V 2));
   msg (pk 2, (e (b 0 11) 12, sign (sk 2) (e (b 0 11) 12)));
   bol (eqm (to (x3tft 1 0)) (V 1))]). simpl.
repeat (rew_mupbver;aply_bver; rew_hyps; try split; try reflexivity).

 aply_blindness 3 8 12 0 1 (b 0 7) (b 1 11)  ((Mvar 0), (Mvar 1)) ((Mvar 0), (Mvar 1))  [msg (pk 0); msg (pk 1); msg (pk 2); msg (pk 3);
                                                                                msg (nonce 4); msg (pk 5); msg (sk 1); msg (sk 2); msg (sk 3) ] ; simpl;
aplyprojn 1 16 H; try split; try reflexivity;
rep_commits 0 1 11 21 7 22 fr1 fr2 temp H H0;
rename H0 into H;
appconst H;
x1checks x1 x1 H;
funapp_vtrm 1 0 1 7 8 H;
funapp_vtrm 2 1 0 11 12 H.
x1checks (x2t 0 ) (x2t 1) H.
x1checks (x3tft 0 1) (x3tft 1 0) H.
adminchecks (x3tft 0 1) (x3tft 1 0) H.

ver_suc1 2 (pi2 (x3tft 0 1)) (e (b 1 11) 12) (pi2 (x3tft 1 0)) (e (b 0 11) 12) H.
  funapptrmhyp (msg (ifm
                     (ver (pk 2) (e (b 1 11) 12)
                        (pi2 (pi2 (pi2 (x3tft 0 1)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3tft 0 1)))),
                     bsign (sk 3) (pi1 (pi2 (pi2 (x3tft 0 1))))) O)) (msg    (ifm
                     (ver (pk 2) (e (b 0 11) 12)
                        (pi2 (pi2 (pi2 (x3tft 1 0)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3tft 1 0)))),
                      bsign (sk 3) (pi1 (pi2 (pi2 (x3tft 1 0))))) O)) H.
  funapptrmhyp (msg  (ifm (eqm (pi1 (pi2 (pi2 (x3tft 0 1)))) (e (b 1 11) 12)) (ifm
                     (ver (pk 2) (e (b 1 11) 12)
                        (pi2 (pi2 (pi2 (x3tft 0 1)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3tft 0 1)))),
                     bsign (sk 3) (pi1 (pi2 (pi2 (x3tft 0 1))))) O) O)) (msg  (ifm (eqm (pi1 (pi2 (pi2 (x3tft 1 0)))) (e (b 0 11) 12))  (ifm (ver (pk 2) (e (b 0 11) 12) (pi2 (pi2 (pi2 (x3tft 1 0))))) (bsign (sk 3) (pi1 (pi2 (pi1 (x3tft 1 0)))),
                                                                                bsign (sk 3) (pi1 (pi2 (pi2 (x3tft 1 0))))) O) O)) H.

  ver_suc1 1 (pi1 (x3tft 0 1)) (e (b 0 7) 8) (pi1 (x3tft 1 0)) (e (b 1 7) 8) H.
  funapptrmhyp (msg  (ifm (ver (pk 1) (e (b 0 7) 8) (pi2 (pi2 (pi1 (x3tft 0 1)))))
               (ifm (eqm (pi1 (pi2 (pi2 (x3tft 0 1)))) (e (b 1 11) 12))
                  (ifm
                     (ver (pk 2) (e (b 1 11) 12)
                        (pi2 (pi2 (pi2 (x3tft 0 1)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3tft 0 1)))),
                     bsign (sk 3) (pi1 (pi2 (pi2 (x3tft 0 1))))) O) O) O)) (msg  (ifm (ver (pk 1) (e (b 1 7) 8) (pi2 (pi2 (pi1 (x3tft 1 0)))))
               (ifm (eqm (pi1 (pi2 (pi2 (x3tft 1 0)))) (e (b 0 11) 12))
                  (ifm
                     (ver (pk 2) (e (b 0 11) 12)
                        (pi2 (pi2 (pi2 (x3tft 1 0)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3tft 1 0)))),
                      bsign (sk 3) (pi1 (pi2 (pi2 (x3tft 1 0))))) O) O) O)) H.
funapptrmhyp (msg   (ifm (eqm (pi1 (pi2 (pi1 (x3tft 0 1)))) (e (b 0 7) 8))
            (ifm (ver (pk 1) (e (b 0 7) 8) (pi2 (pi2 (pi1 (x3tft 0 1)))))
               (ifm (eqm (pi1 (pi2 (pi2 (x3tft 0 1)))) (e (b 1 11) 12))
                  (ifm
                     (ver (pk 2) (e (b 1 11) 12)
                        (pi2 (pi2 (pi2 (x3tft 0 1)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3tft 0 1)))),
                     bsign (sk 3) (pi1 (pi2 (pi2 (x3tft 0 1))))) O) O) O) O)) (msg  (ifm (eqm (pi1 (pi2 (pi1 (x3tft 1 0)))) (e (b 1 7) 8))
            (ifm (ver (pk 1) (e (b 1 7) 8) (pi2 (pi2 (pi1 (x3tft 1 0)))))
               (ifm (eqm (pi1 (pi2 (pi2 (x3tft 1 0)))) (e (b 0 11) 12))
                  (ifm
                     (ver (pk 2) (e (b 0 11) 12)
                        (pi2 (pi2 (pi2 (x3tft 1 0)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3tft 1 0)))),
                      bsign (sk 3) (pi1 (pi2 (pi2 (x3tft 1 0))))) O) O) O) O)) H.

funapptrmhyp  (msg
      (ifm (eqm (to (x3tft 0 1)) (pk 3))
         (ifm (eqm (pi1 (pi2 (pi1 (x3tft 0 1)))) (e (b 0 7) 8))
            (ifm (ver (pk 1) (e (b 0 7) 8) (pi2 (pi2 (pi1 (x3tft 0 1)))))
               (ifm (eqm (pi1 (pi2 (pi2 (x3tft 0 1)))) (e (b 1 11) 12))
                  (ifm
                     (ver (pk 2) (e (b 1 11) 12)
                        (pi2 (pi2 (pi2 (x3tft 0 1)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3tft 0 1)))),
                     bsign (sk 3) (pi1 (pi2 (pi2 (x3tft 0 1))))) O) O) O) O)
         O))  (msg
     (ifm (eqm (to (x3tft 1 0)) (pk 3))
        (ifm (eqm (pi1 (pi2 (pi1 (x3tft 1 0)))) (e (b 1 7) 8))
           (ifm (ver (pk 1) (e (b 1 7) 8) (pi2 (pi2 (pi1 (x3tft 1 0)))))
              (ifm (eqm (pi1 (pi2 (pi2 (x3tft 1 0)))) (e (b 0 11) 12))
                 (ifm
                    (ver (pk 2) (e (b 0 11) 12) (pi2 (pi2 (pi2 (x3tft 1 0)))))
                    (bsign (sk 3) (pi1 (pi2 (pi1 (x3tft 1 0)))),
                     bsign (sk 3) (pi1 (pi2 (pi2 (x3tft 1 0))))) O) O) O) O) O)) H.

restrsublis H.
(** subgoal *)

simpl.
apply IFBRANCH_M2 with (ml1:= [msg (pk 0); msg (pk 1); msg (pk 2); msg (pk 3);
    msg (nonce 4); msg (pk 5); bol (eqm (to x1) (V 1));
    msg (pk 1, (e (b 0 7) 8, sign (sk 1) (e (b 0 7) 8)));
    bol (eqm (to (x2t 0)) (V 2));
    msg (pk 2, (e (b 1 11) 12, sign (sk 2) (e (b 1 11) 12)));
    bol (eqm (to (x3tft 0 1)) (V 1)); bol (eqm (to (x3tft 0 1)) (V 2))]) (ml2:= [msg (pk 0); msg (pk 1); msg (pk 2); msg (pk 3);
   msg (nonce 4); msg (pk 5); bol (eqm (to x1) (V 1));
   msg (pk 1, (e (b 1 7) 8, sign (sk 1) (e (b 1 7) 8)));
   bol (eqm (to (x2t 1)) (V 2));
   msg (pk 2, (e (b 0 11) 12, sign (sk 2) (e (b 0 11) 12)));
   bol (eqm (to (x3tft 1 0)) (V 1)); bol (eqm (to (x3tft 1 0)) (V 2))]). simpl.
repeat (rew_mupbver;aply_bver; rew_hyps; try split; try reflexivity).
 aply_blindness 3 8 12 0 1 (b 0 7) (b 1 11)  ((Mvar 0), (Mvar 1)) ((Mvar 0), (Mvar 1))  [msg (pk 0); msg (pk 1); msg (pk 2); msg (pk 3);
                                                                                msg (nonce 4); msg (pk 5); msg (sk 1); msg (sk 2); msg (sk 3) ] ; simpl;
aplyprojn 1 16 H; try split; try reflexivity;
rep_commits 0 1 11 21 7 22 fr1 fr2 temp H H0;
rename H0 into H;
appconst H;
x1checks x1 x1 H;
funapp_vtrm 1 0 1 7 8 H;
funapp_vtrm 2 1 0 11 12 H.
x1checks (x2t 0 ) (x2t 1) H.
x1checks (x3tft 0 1) (x3tft 1 0) H.
adminchecks (x3tft 0 1) (x3tft 1 0) H.

ver_suc1 2 (pi2 (x3tft 0 1)) (e (b 1 11) 12) (pi2 (x3tft 1 0)) (e (b 0 11) 12) H.
  funapptrmhyp (msg (ifm
                     (ver (pk 2) (e (b 1 11) 12)
                        (pi2 (pi2 (pi2 (x3tft 0 1)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3tft 0 1)))),
                     bsign (sk 3) (pi1 (pi2 (pi2 (x3tft 0 1))))) O)) (msg    (ifm
                     (ver (pk 2) (e (b 0 11) 12)
                        (pi2 (pi2 (pi2 (x3tft 1 0)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3tft 1 0)))),
                      bsign (sk 3) (pi1 (pi2 (pi2 (x3tft 1 0))))) O)) H.
  funapptrmhyp (msg  (ifm (eqm (pi1 (pi2 (pi2 (x3tft 0 1)))) (e (b 1 11) 12)) (ifm
                     (ver (pk 2) (e (b 1 11) 12)
                        (pi2 (pi2 (pi2 (x3tft 0 1)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3tft 0 1)))),
                     bsign (sk 3) (pi1 (pi2 (pi2 (x3tft 0 1))))) O) O)) (msg  (ifm (eqm (pi1 (pi2 (pi2 (x3tft 1 0)))) (e (b 0 11) 12))  (ifm (ver (pk 2) (e (b 0 11) 12) (pi2 (pi2 (pi2 (x3tft 1 0))))) (bsign (sk 3) (pi1 (pi2 (pi1 (x3tft 1 0)))),
                                                                                bsign (sk 3) (pi1 (pi2 (pi2 (x3tft 1 0))))) O) O)) H.

  ver_suc1 1 (pi1 (x3tft 0 1)) (e (b 0 7) 8) (pi1 (x3tft 1 0)) (e (b 1 7) 8) H.
  funapptrmhyp (msg  (ifm (ver (pk 1) (e (b 0 7) 8) (pi2 (pi2 (pi1 (x3tft 0 1)))))
               (ifm (eqm (pi1 (pi2 (pi2 (x3tft 0 1)))) (e (b 1 11) 12))
                  (ifm
                     (ver (pk 2) (e (b 1 11) 12)
                        (pi2 (pi2 (pi2 (x3tft 0 1)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3tft 0 1)))),
                     bsign (sk 3) (pi1 (pi2 (pi2 (x3tft 0 1))))) O) O) O)) (msg  (ifm (ver (pk 1) (e (b 1 7) 8) (pi2 (pi2 (pi1 (x3tft 1 0)))))
               (ifm (eqm (pi1 (pi2 (pi2 (x3tft 1 0)))) (e (b 0 11) 12))
                  (ifm
                     (ver (pk 2) (e (b 0 11) 12)
                        (pi2 (pi2 (pi2 (x3tft 1 0)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3tft 1 0)))),
                      bsign (sk 3) (pi1 (pi2 (pi2 (x3tft 1 0))))) O) O) O)) H.
funapptrmhyp (msg   (ifm (eqm (pi1 (pi2 (pi1 (x3tft 0 1)))) (e (b 0 7) 8))
            (ifm (ver (pk 1) (e (b 0 7) 8) (pi2 (pi2 (pi1 (x3tft 0 1)))))
               (ifm (eqm (pi1 (pi2 (pi2 (x3tft 0 1)))) (e (b 1 11) 12))
                  (ifm
                     (ver (pk 2) (e (b 1 11) 12)
                        (pi2 (pi2 (pi2 (x3tft 0 1)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3tft 0 1)))),
                     bsign (sk 3) (pi1 (pi2 (pi2 (x3tft 0 1))))) O) O) O) O)) (msg  (ifm (eqm (pi1 (pi2 (pi1 (x3tft 1 0)))) (e (b 1 7) 8))
            (ifm (ver (pk 1) (e (b 1 7) 8) (pi2 (pi2 (pi1 (x3tft 1 0)))))
               (ifm (eqm (pi1 (pi2 (pi2 (x3tft 1 0)))) (e (b 0 11) 12))
                  (ifm
                     (ver (pk 2) (e (b 0 11) 12)
                        (pi2 (pi2 (pi2 (x3tft 1 0)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3tft 1 0)))),
                      bsign (sk 3) (pi1 (pi2 (pi2 (x3tft 1 0))))) O) O) O) O)) H.
restrsublis H.
(** subgoal *)

  (aply_blindness 3 8 12 0 1 (b 0 7) (b 1 11)  ((Mvar 0), (Mvar 1)) ((Mvar 0), (Mvar 1))  [msg (pk 0); msg (pk 1); msg (pk 2); msg (pk 3);
                                                                                msg (nonce 4); msg (pk 5); msg (sk 1); msg (sk 2); msg (sk 3) ] ; simpl;
aplyprojn 1 16 H; try split; try reflexivity;
rep_commits 0 1 11 21 7 22 fr1 fr2 temp H H0;
rename H0 into H;
appconst H;
x1checks x1 x1 H;
funapp_vtrm 1 0 1 7 8 H;
funapp_vtrm 2 1 0 11 12 H;
x1checks (x2t 0 ) (x2t 1) H;
x1checks (x3tft 0 1) (x3tft 1 0) H;
restrsublis H).
 aply_blindness 3 8 12 0 1 (b 0 7) (b 1 11)  ((Mvar 0), (Mvar 1)) ((Mvar 0), (Mvar 1))  [msg (pk 0); msg (pk 1); msg (pk 2); msg (pk 3);
                                                                                msg (nonce 4); msg (pk 5); msg (sk 1); msg (sk 2); msg (sk 3) ] ; simpl;
aplyprojn 1 16 H; try split; try reflexivity;
rep_commits 0 1 11 21 7 22 fr1 fr2 temp H H0;
rename H0 into H;
appconst H;
x1checks x1 x1 H;
funapp_vtrm 1 0 1 7 8 H;
funapp_vtrm 2 1 0 11 12 H;
x1checks (x2t 0 ) (x2t 1) H;
x1checks (x3tft 0 1) (x3tft 1 0) H;
restrsublis H.
 (** subgoal *)
 simpl.
 apply IFBRANCH_M4 with (ml1:= [msg (pk 0); msg (pk 1); msg (pk 2); msg (pk 3);
    msg (nonce 4); msg (pk 5); bol (eqm (to x1) (V 1))]) (ml2:= [msg (pk 0); msg (pk 1); msg (pk 2); msg (pk 3);
                                                             msg (nonce 4); msg (pk 5); bol (eqm (to x1) (V 1))]). simpl.
 apply IFBRANCH_M3 with (ml1:= [msg (pk 0); msg (pk 1); msg (pk 2); msg (pk 3);
    msg (nonce 4); msg (pk 5); bol (eqm (to x1) (V 1));
    bol (eqm (to x1) (V 2));
    msg (pk 2, (e (b 1 9) 10, sign (sk 2) (e (b 1 9) 10)))]) (ml2:= [msg (pk 0); msg (pk 1); msg (pk 2); msg (pk 3);
   msg (nonce 4); msg (pk 5); bol (eqm (to x1) (V 1));
   bol (eqm (to x1) (V 2));
   msg (pk 2, (e (b 0 9) 10, sign (sk 2) (e (b 0 9) 10)))]). simpl.
 repeat aply_andB_elm.
 repeat (rew_mupbver;aply_bver; rew_hyps; try split; try reflexivity).

 aply_blindness 3 10 14 0 1 (b 1 9) (b 0 13)  ((Mvar 0), (Mvar 1)) ((Mvar 0), (Mvar 1))  [msg (pk 0); msg (pk 1); msg (pk 2); msg (pk 3);
                                                                                msg (nonce 4); msg (pk 5); msg (sk 1); msg (sk 2); msg (sk 3) ] ; simpl;
aplyprojn 1 16 H; try split; try reflexivity.
rep_commits 1 0 13 30 9 31 fr1 fr2 temp H H0.
rename H0 into H;
appconst H;
x1checks x1 x1 H;
funapp_vtrm 2 1 0 9 10 H;
funapp_vtrm 1 0 1 13 14 H.
x1checks (x2ft 1) (x2ft 0) H.
x1checks (x3ftft 0 1) (x3ftft 1 0) H.
adminchecks (x3ftft 0 1) (x3ftft 1 0) H.

ver_suc1 2 (pi2 (x3ftft 0 1)) (e (b 1 9) 10) (pi2 (x3ftft 1 0)) (e (b 0 9) 10) H.
  funapptrmhyp (msg (ifm
                     (ver (pk 2) (e (b 1 9) 10)
                        (pi2 (pi2 (pi2 (x3ftft 0 1)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3ftft 0 1)))),
                     bsign (sk 3) (pi1 (pi2 (pi2 (x3ftft 0 1))))) O))  (msg    (ifm
                     (ver (pk 2) (e (b 0 9) 10)
                        (pi2 (pi2 (pi2 (x3ftft 1 0)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3ftft 1 0)))),
                      bsign (sk 3) (pi1 (pi2 (pi2 (x3ftft 1 0))))) O)) H.
   funapptrmhyp (msg  (ifm (eqm (pi1 (pi2 (pi2 (x3ftft 0 1)))) (e (b 1 9) 10)) (ifm
                     (ver (pk 2) (e (b 1 9) 10)
                        (pi2 (pi2 (pi2 (x3ftft 0 1)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3ftft 0 1)))),
                     bsign (sk 3) (pi1 (pi2 (pi2 (x3ftft 0 1))))) O) O)) (msg  (ifm (eqm (pi1 (pi2 (pi2 (x3ftft 1 0)))) (e (b 0 9) 10))  (ifm (ver (pk 2) (e (b 0 9) 10) (pi2 (pi2 (pi2 (x3ftft 1 0))))) (bsign (sk 3) (pi1 (pi2 (pi1 (x3ftft 1 0)))),
                                                                                bsign (sk 3) (pi1 (pi2 (pi2 (x3ftft 1 0))))) O) O)) H.

   ver_suc1 1 (pi1 (x3ftft 0 1)) (e (b 0 13) 14) (pi1 (x3ftft 1 0)) (e (b 1 13) 14) H.

 funapptrmhyp (msg  (ifm (ver (pk 1) (e (b 0 13) 14) (pi2 (pi2 (pi1 (x3ftft 0 1))))) (ifm (eqm (pi1 (pi2 (pi2 (x3ftft 0 1)))) (e (b 1 9) 10)) (ifm
                     (ver (pk 2) (e (b 1 9) 10)
                        (pi2 (pi2 (pi2 (x3ftft 0 1)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3ftft 0 1)))),
                     bsign (sk 3) (pi1 (pi2 (pi2 (x3ftft 0 1))))) O) O) O)) (msg (ifm (ver (pk 1) (e (b 1 13) 14) (pi2 (pi2 (pi1 (x3ftft 1 0)))))  (ifm (eqm (pi1 (pi2 (pi2 (x3ftft 1 0)))) (e (b 0 9) 10))  (ifm (ver (pk 2) (e (b 0 9) 10) (pi2 (pi2 (pi2 (x3ftft 1 0))))) (bsign (sk 3) (pi1 (pi2 (pi1 (x3ftft 1 0)))),
                                                                                bsign (sk 3) (pi1 (pi2 (pi2 (x3ftft 1 0))))) O) O) O)) H.
   funapptrmhyp  (msg
              (ifm (eqm (pi1 (pi2 (pi1 (x3ftft 0 1)))) (e (b 0 13) 14))
            (ifm (ver (pk 1) (e (b 0 13) 14) (pi2 (pi2 (pi1 (x3ftft 0 1)))))
               (ifm (eqm (pi1 (pi2 (pi2 (x3ftft 0 1)))) (e (b 1 9) 10))
                  (ifm
                     (ver (pk 2) (e (b 1 9) 10)
                        (pi2 (pi2 (pi2 (x3ftft 0 1)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3ftft 0 1)))),
                     bsign (sk 3) (pi1 (pi2 (pi2 (x3ftft 0 1))))) O) O) O) O))
           (msg
               (ifm (eqm (pi1 (pi2 (pi1 (x3ftft 1 0)))) (e (b 1 13) 14))
            (ifm (ver (pk 1) (e (b 1 13) 14) (pi2 (pi2 (pi1 (x3ftft 1 0)))))
               (ifm (eqm (pi1 (pi2 (pi2 (x3ftft 1 0)))) (e (b 0 9) 10))
                  (ifm
                     (ver (pk 2) (e (b 0 9) 10)
                        (pi2 (pi2 (pi2 (x3ftft 1 0)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3ftft 1 0)))),
                     bsign (sk 3) (pi1 (pi2 (pi2 (x3ftft 1 0))))) O) O) O) O))
          H.
  funapptrmhyp  (msg
      (ifm (eqm (to (x3ftft 0 1)) (pk 3))
         (ifm (eqm (pi1 (pi2 (pi1 (x3ftft 0 1)))) (e (b 0 13) 14))
            (ifm (ver (pk 1) (e (b 0 13) 14) (pi2 (pi2 (pi1 (x3ftft 0 1)))))
               (ifm (eqm (pi1 (pi2 (pi2 (x3ftft 0 1)))) (e (b 1 9) 10))
                  (ifm
                     (ver (pk 2) (e (b 1 9) 10)
                        (pi2 (pi2 (pi2 (x3ftft 0 1)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3ftft 0 1)))),
                     bsign (sk 3) (pi1 (pi2 (pi2 (x3ftft 0 1))))) O) O) O) O)
         O))   (msg
      (ifm (eqm (to (x3ftft 1 0)) (pk 3))
         (ifm (eqm (pi1 (pi2 (pi1 (x3ftft 1 0)))) (e (b 1 13) 14))
            (ifm (ver (pk 1) (e (b 1 13) 14) (pi2 (pi2 (pi1 (x3ftft 1 0)))))
               (ifm (eqm (pi1 (pi2 (pi2 (x3ftft 1 0)))) (e (b 0 9) 10))
                  (ifm
                     (ver (pk 2) (e (b 0 9) 10)
                        (pi2 (pi2 (pi2 (x3ftft 1 0)))))
                     (bsign (sk 3) (pi1 (pi2 (pi1 (x3ftft 1 0)))),
                     bsign (sk 3) (pi1 (pi2 (pi2 (x3ftft 1 0))))) O) O) O) O)
         O)) H.
  restrsublis H.
(** subgoal *)
  simpl.
aply_blindness 3 10 11 0 1 (b 1 9) (b 0 9)  ((Mvar 0), (Mvar 1)) ((Mvar 0), (Mvar 1))  [msg (pk 0); msg (pk 1); msg (pk 2); msg (pk 3);
                                                                                msg (nonce 4); msg (pk 5); msg (sk 1); msg (sk 2); msg (sk 3) ] ; simpl;
aplyprojn 2 15 H; try split; try reflexivity;
appconst H;
x1checks x1 x1 H;
funapp_vtrm 2 1 0 9 10 H;
x1checks (x2ft 1 ) (x2ft 0) H;
restrsublis H.
reflexivity.
Qed. *)

End foo_prot2. *)


Require Import
        Coq.Strings.String
        Coq.Bool.Bool
        Coq.Lists.List
        Coq.Arith.Arith
        Coq.Program.Program
        Fiat.ADT
        Fiat.ADT.ComputationalADT
        Fiat.ADTNotation
        Fiat.ADTRefinement
        Fiat.ADTRefinement.BuildADTRefinements
        Fiat.Fiat4Monitors.RADL_Topics
        Fiat.Fiat4Monitors.RADL_Messages
        Fiat.Fiat4Monitors.RADL_Flags.

Section RADL_ADT.

  Open Scope ADT_scope.
  Open Scope string_scope.
  Open Scope list_scope.
  Open Scope ADTSig_scope.

  Definition RADL_Init := "Init".
  Definition RADL_Step := "Step".

  Context {n : nat}.
  Variable TopicTypes : Vector.t Type n. (* List of Topics in the Network. *)
  Variable TopicNames : Vector.t string n. (* List of Topics IDs in the Network. *)

  Record RADL_Node :=
    { (* Subscription + Publication info for this node *)
      RADL_NumSubscriptions : nat;
      RADL_Subscriptions : Vector.t (Fin.t n) RADL_NumSubscriptions;
      RADL_NumPublications : nat;
      RADL_Publications : Vector.t (Fin.t n) RADL_NumPublications;
      RADL_Defs : list string;
      RADL_Period : string;
      RADL_Path : string;
      RADL_CXX : list string
    }.

  Definition radl_in_t (Node : RADL_Node) :=
    MessageADT TopicTypes TopicNames (RADL_Subscriptions Node).
  Definition radl_in_flags_t (Node : RADL_Node) :=
    FlagsADT TopicNames (RADL_Subscriptions Node).
  Definition radl_out_t (Node : RADL_Node) :=
    MessageADT TopicTypes TopicNames (RADL_Publications Node).
  Definition radl_out_flags_t (Node : RADL_Node) :=
    FlagsADT TopicNames (RADL_Publications Node).

  Definition RADL_ADTSig  (Node : RADL_Node)
  : DecoratedADTSig :=                         (* A RADL Node is modeled as an ADT with a  *)
    ADTsignature {                    (* single constructor and a step function. *)
        Constructor RADL_Init      : unit -> rep,
        Method      RADL_Step      : rep x (prod (cRep (radl_in_t Node)) (cRep (radl_in_flags_t Node)))
                                     -> rep x (prod (cRep (radl_out_t Node)) (cRep (radl_out_flags_t Node)))
      }.

  (*Definition RADL_ADTSpec (Node : RADL_Node)
  : ADT (RADL_ADTSig Node) :=
    ADTRep unit (* Since RADL Nodes are untrusted, we'll treat their state as completely unknown *)
           { Def Constructor RADL_Init (_ : unit) : rep := ret tt,
             Def Method RADL_Step (r : rep, in_t : _) : _ :=
               (* Again, since the RADL Node is untrusted code, we'll assume that it can publish
                  whatever the heck it wants. *)
               results <- {out_t : cRep (radl_out_t Node) | True };
               result_flags <- {out_t : cRep (radl_out_flags_t Node) | True };
             ret (tt, (results, result_flags)) }. *)

  Record RADLM_Node :=
    { (* The monitored node*)
      RADLM_MonitoredNode : RADL_Node;
      (* Additional Subscription + Publication info *)
      RADLM_NumSubscriptions : nat;
      RADLM_Subscriptions : Vector.t (Fin.t n) RADLM_NumSubscriptions;
      RADLM_NumPublications : nat;
      RADLM_Publications : Vector.t (Fin.t n) RADLM_NumPublications
    }.

  Definition radlm_in_t (Node : RADLM_Node) :=
    MessageADT TopicTypes TopicNames (RADL_Subscriptions (RADLM_MonitoredNode Node)).
  Definition radlm_in_flags_t (Node : RADLM_Node) :=
    FlagsADT TopicNames (RADL_Subscriptions (RADLM_MonitoredNode Node)).

  Definition radlm_out_t (Node : RADLM_Node) :=
    MessageADT TopicTypes TopicNames (RADL_Publications (RADLM_MonitoredNode Node)).
  Definition radlm_out_flags_t (Node : RADLM_Node) :=
    FlagsADT TopicNames (RADL_Publications (RADLM_MonitoredNode Node)).

  Definition radlm_monitor_in_t (Node : RADLM_Node) :=
    MessageADT TopicTypes TopicNames (RADLM_Subscriptions Node).
  Definition radlm_monitor_out_t (Node : RADLM_Node) :=
    MessageADT TopicTypes TopicNames (RADLM_Publications Node).

  Definition RADL_Start_Step := "Start_Step".
  Definition RADL_Finish_Step := "Finish_Step".

  Record RADLM_start_msg_t (MonitorNode : RADLM_Node) :=
    { radlm_in : cRep (radlm_in_t MonitorNode);
      radlm_in_flags : cRep (radlm_in_flags_t MonitorNode);
      radlm_monitor_in : cRep (radlm_monitor_in_t MonitorNode) }.

  Record RADLM_finish_msg_t (MonitorNode : RADLM_Node) :=
    { radlm_out : cRep (radlm_out_t MonitorNode);
      radlm_out_flags : cRep (radlm_out_flags_t MonitorNode) }.

  Definition RADLM_ADTSig
             (MonitorNode : RADLM_Node)
             (InitDom : Type)
  : DecoratedADTSig :=
    ADTsignature {
        Constructor RADL_Init       : InitDom -> rep,
        (* Monitor Nodes have two methods which are used to guard the node's step function:
           1) an initial step function that examines the subscriptions and decides whether
           to pass them on (potentially modifying them) or to publish on its own. *)
        Method      RADL_Start_Step : rep x RADLM_start_msg_t MonitorNode
                                      -> rep x (cRep (radlm_in_t MonitorNode)
                                                * cRep (radlm_in_flags_t MonitorNode)),
        (* 2) A finish step function that examines the publications after a node's
         step function has been called, potentially modifying the publications and publishing
         its own topics. *)
        Method      RADL_Finish_Step : rep x RADLM_finish_msg_t MonitorNode
                                       -> rep x (cRep (radlm_out_t MonitorNode)
                                                 * cRep (radlm_out_flags_t MonitorNode)
                                                 * cRep (radlm_monitor_out_t MonitorNode))
      }.

End RADL_ADT.

Definition RADL_ADT {n} Topics Node :=
  DecoratedADT (@RADL_ADTSig n (Vector.map Topic_Type Topics)
                    (Vector.map Topic_Name Topics)
                    Node).

Definition RADLM_ADT {n} Topics MonitorNode InitDom :=
  DecoratedADT (@RADLM_ADTSig n (Vector.map Topic_Type Topics)
                     (Vector.map Topic_Name Topics)
                     MonitorNode InitDom).


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Util.ZRange.
Require Import Rewriter.Language.Language.
Require Import Crypto.Language.API.
Require Import Rewriter.Language.Wf.
Require Import Crypto.Language.WfExtra.
Require Import Crypto.Rewriter.AllTacticsExtra.
Require Import Crypto.Rewriter.RulesProofs.

Module Compilers.
  Import Language.Compilers.
  Import Language.API.Compilers.
  Import Language.Wf.Compilers.
  Import Language.WfExtra.Compilers.
  Import Rewriter.AllTacticsExtra.Compilers.RewriteRules.GoalType.
  Import Rewriter.AllTactics.Compilers.RewriteRules.Tactic.
  Import Compilers.Classes.

  Module Import RewriteRules.
    Section __.
      Context (invert_low invert_high : Z (*log2wordmax*) -> Z -> @option Z)
              (value_range flag_range : zrange)
              (Hlow : forall s v v', invert_low s v = Some v' -> v = Z.land v' (2^(s/2)-1))
              (Hhigh : forall s v v', invert_high s v = Some v' -> v = Z.shiftr v' (s/2)).

      Definition VerifiedRewriterToFancyWithCasts : VerifiedRewriter_with_args false false true (@fancy_with_casts_rewrite_rules_proofs invert_low invert_high value_range flag_range Hlow Hhigh).
      Proof using All. make_rewriter. Defined.

      Definition default_opts := Eval hnf in @default_opts VerifiedRewriterToFancyWithCasts.
      Let optsT := Eval hnf in optsT VerifiedRewriterToFancyWithCasts.

      Definition RewriteToFancyWithCasts (opts : optsT) {t : API.type} : API.Expr t -> API.Expr t.
      Proof using invert_low invert_high value_range flag_range.
        let v := (eval hnf in (@Rewrite VerifiedRewriterToFancyWithCasts opts t)) in exact v.
      Defined.

      Lemma Wf_RewriteToFancyWithCasts opts {t} e (Hwf : Wf e) : Wf (@RewriteToFancyWithCasts opts t e).
      Proof using All. now apply VerifiedRewriterToFancyWithCasts. Qed.

      Lemma Interp_RewriteToFancyWithCasts opts {t} e (Hwf : Wf e) : API.Interp (@RewriteToFancyWithCasts opts t e) == API.Interp e.
      Proof using All. now apply VerifiedRewriterToFancyWithCasts. Qed.
    End __.
  End RewriteRules.

  Module Export Hints.
#[global]
    Hint Resolve Wf_RewriteToFancyWithCasts : wf wf_extra.
#[global]
    Hint Opaque RewriteToFancyWithCasts : wf wf_extra interp interp_extra rewrite.
#[global]
    Hint Rewrite @Interp_RewriteToFancyWithCasts : interp interp_extra.
  End Hints.
End Compilers.