(** * Step Machine of the Heap Machine Simulator *)

Require Import TM.Code.ProgrammingTools.
Require Import TM.LM.Semantics TM.LM.Alphabets.
Require Import TM.LM.CaseCom TM.LM.LookupTM TM.LM.JumpTargetTM.
Require Import TM.Code.ListTM TM.Code.CaseList TM.Code.CasePair TM.Code.CaseSum.

Local Arguments plus : simpl never.
Local Arguments mult : simpl never.

(** Here we compose the [Lookup] and [JumpTarget] machines. *)

Section StepMachine.

  Implicit Types H : Heap.
  Implicit Types T V : list HClos.
  Implicit Types a b c : HAdd.
  Implicit Types g : HClos.
  Implicit Types (P Q : Pro).

  (** The machine operates on lists of closures and on a heap, so we need a closure-list alphabet and a heap alphabet. *)
  Variable sigStep : finType.
  Variable retr_closures_step : Retract (sigList sigHClos) sigStep.
  Variable retr_heap_step : Retract sigHeap sigStep.

  (** Retracts *)
  (* Closures *)
  Local Definition retr_clos_step : Retract sigHClos sigStep := ComposeRetract retr_closures_step _.

  (* Closure addresses *)

  Definition retr_pro_clos : Retract sigPro sigHClos := _.
  Local Definition retr_pro_step : Retract sigPro sigStep := ComposeRetract retr_clos_step retr_pro_clos.
  Local Definition retr_tok_step : Retract sigCom sigStep := ComposeRetract retr_pro_step _.

  Local Definition retr_nat_clos_ad : Retract sigNat sigHClos := Retract_sigPair_X _ (Retract_id _).
  Local Definition retr_nat_step_clos_ad : Retract sigNat sigStep := ComposeRetract retr_clos_step retr_nat_clos_ad.

  Local Definition retr_nat_clos_var : Retract sigNat sigHClos := Retract_sigPair_Y _ _.
  Local Definition retr_nat_step_clos_var : Retract sigNat sigStep := ComposeRetract retr_clos_step retr_nat_clos_var.

  (** Instance of the [Lookup] and [JumpTarget] machine *)
  Local Definition Step_Lookup := Lookup retr_clos_step retr_heap_step.

  (** Cons a closure to a closure list, if the programm of the closure is not empty, and reset the program but not the address of the closure *)

  Definition TailRec_Rel : pRel sigStep^+ unit 3 :=
    ignoreParam (
        fun tin tout =>
          forall T P a,
            tin[@Fin0] ≃ T ->
            tin[@Fin1] ≃(Encode_map Encode_Prog retr_pro_step) P ->
            tin[@Fin2] ≃(Encode_map Encode_nat retr_nat_step_clos_ad) a ->
            tout[@Fin0] ≃ tailRecursion (a, P) T /\
            isRight tout[@Fin1] /\
            tout[@Fin2] ≃(Encode_map Encode_nat retr_nat_step_clos_ad) a
      ).

  Definition TailRec : pTM sigStep^+ unit 3 :=
    If (IsNil sigCom_fin ⇑ retr_pro_step @ [|Fin1|])
       (Reset _ @ [|Fin1|])
       (Constr_pair sigHAdd_fin sigPro_fin ⇑ retr_clos_step @ [|Fin2; Fin1|];;
        Constr_cons sigHClos_fin ⇑ _ @ [|Fin0; Fin1|];;
        Reset _ @ [|Fin1|]).

  Lemma TailRec_Realise : TailRec ⊨ TailRec_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold TailRec. TM_Correct.
      - apply Reset_Realise with (cX := Encode_map Encode_Prog retr_pro_step).
      - apply Reset_Realise with (cX := Encode_map Encode_HClos retr_clos_step).
    }
    {
      intros tin ((), tout) H. intros T P a HEncT HEncP HEncA.
      destruct H; TMSimp.
      - modpon H. destruct P; auto; modpon H. modpon H0. repeat split; auto.
      - modpon H. destruct P; auto; modpon H.
        specialize (H0 a (c :: P)). modpon H0.
        specialize (H1 T (a, c :: P)). modpon H1.
        specialize (H2 (a, c :: P)). modpon H2.
        repeat split; auto. contains_ext.
    }
  Qed.

  Local Arguments tailRecursion : simpl never.

  Definition TailRec_steps P a :=
    match P with
    | nil => 1 + IsNil_steps + Reset_steps _ nil
    | t::P => 1 + IsNil_steps + 1 + Constr_pair_steps _ a + 1 + Constr_cons_steps _ (a,t::P) + Reset_steps _ (a, t :: P)
    end.

  Definition TailRec_T : tRel sigStep^+ 3 :=
    fun tin k =>
      exists T P a, tin[@Fin0] ≃ T /\
               tin[@Fin1] ≃(Encode_map Encode_Prog retr_pro_step) P /\
               tin[@Fin2] ≃(Encode_map Encode_nat retr_nat_step_clos_ad) a /\
               TailRec_steps P a <= k.

  Lemma TailRec_Terminates : projT1 TailRec ↓ TailRec_T.
  Proof.
    eapply TerminatesIn_monotone.
    { unfold TailRec. TM_Correct.
      - apply Reset_Terminates with (cX := Encode_map Encode_Prog retr_pro_step).
      - apply Reset_Terminates with (cX := Encode_map Encode_HClos retr_clos_step).
    }
    {
      intros tin k (T&P&a&HEncT&HEncP&HEncA&Hk). unfold TailRec_steps in Hk.
      destruct P as [ | t P]; cbn.
      - exists (IsNil_steps), (Reset_steps _ nil). repeat split; try omega.
        intros tmid b (HIsNil&IsNilInj); TMSimp. modpon HIsNil. destruct b; auto; modpon HIsNil. eauto.
      - exists (IsNil_steps), (1 + Constr_pair_steps _ a + 1 + Constr_cons_steps _ (a,t::P) + Reset_steps _ (a, (t::P))).
        repeat split; try omega.
        intros tmid b (HIsNil&IsNilInj); TMSimp. modpon HIsNil. destruct b; auto; modpon HIsNil.
        exists (Constr_pair_steps _ a), (1 + Constr_cons_steps _ (a,t::P) + Reset_steps _ (a,t::P)). repeat split; try omega.
        { hnf; cbn. eexists; split. simpl_surject; contains_ext. reflexivity. } now rewrite !Nat.add_assoc.
        intros tmid0 () (HPair&HPairInj); TMSimp.
        specialize (HPair a (t::P)); modpon HPair.
        exists (Constr_cons_steps _ (a,t::P)), (Reset_steps _ (a,t::P)). repeat split; try omega.
        { hnf; cbn. do 2 eexists; repeat split; simpl_surject; eauto. contains_ext. } reflexivity.
        intros tmid1 () (HCons&HConsInj); TMSimp. specialize (HCons T (a,t::P)). modpon HCons.
        exists (a, t :: P). split; eauto. contains_ext. now setoid_rewrite Reset_steps_comp.
    }
  Qed.

  (** Like [TailRec], but doesn't check whether the program is empty, and resets [a] and [Q] *)
  Definition ConsClos_Rel : pRel sigStep^+ unit 3 :=
    ignoreParam (
        fun tin tout =>
          forall T Q a,
            tin[@Fin0] ≃ T ->
            tin[@Fin1] ≃(Encode_map Encode_nat retr_nat_step_clos_ad) a ->
            tin[@Fin2] ≃(Encode_map Encode_Prog retr_pro_step) Q ->
            tout[@Fin0] ≃ (a, Q) :: T /\
            isRight tout[@Fin1] /\
            isRight tout[@Fin2]
      ).

  Definition ConsClos : pTM sigStep^+ unit 3 :=
    Constr_pair sigHAdd_fin sigPro_fin ⇑ retr_clos_step @ [|Fin1; Fin2|];;
    Constr_cons sigHClos_fin ⇑ _ @ [|Fin0; Fin2|];;
    Reset _ @ [|Fin2|];;
    Reset _ @ [|Fin1|].

  Lemma ConsClos_Realise : ConsClos ⊨ ConsClos_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold ConsClos. TM_Correct.
      - apply Reset_Realise with (cX := Encode_map Encode_HClos retr_clos_step).
      - apply Reset_Realise with (cX := Encode_map Encode_nat retr_nat_step_clos_ad).
    }
    {
      intros tin ((), tout) H. intros T Q a HEncT HEncA HEncQ.
      TMSimp.
      specialize (H a Q). modpon H. (* Constr_pair *)
      specialize (H0 T (a, Q)). modpon H0. (* Constr_cons *)
      specialize (H1 (a, Q)). modpon H1. (* Reset HClos *)
      modpon H2. (* Reset HAdd *) auto.
    }
  Qed.

  Definition ConsClos_steps Q a :=
    3 + Constr_pair_steps _ a + Constr_cons_steps _ (a,Q) + Reset_steps _ (a,Q) + Reset_steps _ a.

  Definition ConsClos_T : tRel sigStep^+ 3 :=
    fun tin k =>
          exists T Q a,
            tin[@Fin0] ≃ T /\
            tin[@Fin1] ≃(Encode_map Encode_nat retr_nat_step_clos_ad) a /\
            tin[@Fin2] ≃(Encode_map Encode_Prog retr_pro_step) Q /\
            ConsClos_steps Q a <= k.

  Lemma ConsClos_Terminates : projT1 ConsClos ↓ ConsClos_T.
  Proof.
    eapply TerminatesIn_monotone.
    { unfold ConsClos. TM_Correct.
      - apply Reset_Realise with (cX := Encode_map Encode_HClos retr_clos_step).
      - apply Reset_Terminates with (cX := Encode_map Encode_HClos retr_clos_step).
      - apply Reset_Terminates with (cX := Encode_map Encode_nat retr_nat_step_clos_ad).
    }
    {
      intros tin k. intros (T&Q&a&HEncT&HEnca&HEncQ&Hk). unfold ConsClos_steps in Hk.
      exists (Constr_pair_steps _ a), (1 + Constr_cons_steps _ (a,Q) + 1 + Reset_steps _ (a,Q) + Reset_steps _ a).
      cbn; repeat split; try omega.
      { hnf; cbn. exists a. repeat split; simpl_surject; eauto. contains_ext. }
      intros tmid () (HPair&HPairInj); TMSimp. modpon HPair.
      exists (Constr_cons_steps _ (a,Q)), (1 + Reset_steps _ (a,Q) + Reset_steps _ a).
      cbn; repeat split; try omega.
      { hnf; cbn. exists T, (a, Q). repeat split; simpl_surject; eauto. contains_ext. } now rewrite !Nat.add_assoc.
      intros tmid0 () (HCons&HConsInj); TMSimp. specialize (HCons T (a,Q)); modpon HCons.
      exists (Reset_steps _ (a,Q)), (Reset_steps _ a).
      cbn; repeat split; try omega; eauto.
      { hnf; cbn. exists (a, Q). repeat split; simpl_surject; eauto. contains_ext. now setoid_rewrite Reset_steps_comp. }
      intros tmid1 () (HReset&HResetInj); TMSimp. clear HReset.
      exists a. split; eauto. contains_ext. now setoid_rewrite Reset_steps_comp.
    }
  Qed.

  Definition Step_lam_Rel : pRel sigStep^+ bool 10 :=
    fun tin '(yout, tout) =>
      forall (T V : list HClos) (H : Heap) (a : HAdd) (P : Pro),
        tin[@Fin0] ≃ T ->
        tin[@Fin1] ≃ V ->
        tin[@Fin2] ≃ H ->
        tin[@Fin3] ≃(Encode_map Encode_Prog retr_pro_step) P ->
        tin[@Fin4] ≃(Encode_map Encode_nat retr_nat_step_clos_ad) a ->
        (forall i : Fin.t 5, isRight tin[@FinR 5 i]) ->
        match yout with
        | true =>
          exists (P' Q : Pro),
          jumpTarget 0 [] P = Some (Q, P') /\
          tout[@Fin0] ≃ tailRecursion (a, P') T /\
          tout[@Fin1] ≃ (a, Q) :: V /\
          tout[@Fin2] ≃ H /\
          (forall i : Fin.t 7, isRight tout[@FinR 3 i])
        | false => jumpTarget 0 [] P = None
        end.

  Definition Step_lam : pTM sigStep^+ bool 10 :=
    If (JumpTarget ⇑ retr_pro_step @ [|Fin3; Fin6; Fin7; Fin8; Fin9|])
       (Return (TailRec @ [|Fin0; Fin3; Fin4|];;
                ConsClos @ [|Fin1; Fin4; Fin6|])
               true)
       (Return Nop false).

  Lemma Step_lam_Realise : Step_lam ⊨ Step_lam_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold Step_lam. TM_Correct.
      - apply JumpTarget_Realise.
      - apply TailRec_Realise.
      - apply ConsClos_Realise.
    }
    {
      intros tin (yout, tout) H. cbn. intros T V heap a P HEncT HEncV HEncHeap HEncP HEncA HInt.
      destruct H; TMSimp.
      { (* Then, i.e. [jumpTarget 0 [] = Some (Q', P')] *) rename H into HJumpTarget, H0 into HTailRec, H1 into HConsClos.
        modpon HJumpTarget.
        { intros i; destruct_fin i; cbn; simpl_surject; auto. }
        destruct HJumpTarget as (P'&Q'&HJumpTarget); modpon HJumpTarget.
        modpon HTailRec.
        modpon HConsClos.
        do 2 eexists; repeat split; eauto.
        generalize (HJumpTarget2 Fin0); generalize (HJumpTarget2 Fin1); generalize (HJumpTarget2 Fin2); cbn; TMSimp_goal.
        intros; simpl_surject; destruct_fin i; TMSimp_goal; auto.
      }
      { (* Else, i.e. [jumpTarget 0 [] = None] *)
        modpon H.
        { intros i; destruct_fin i; cbn; simpl_surject; auto. }
        assumption.
      }
    }
  Qed.

  (* Steps depending on the result of [JumpTarget] *)
  Definition Step_lam_steps_JumpTarget P a :=
    match jumpTarget 0 [] P with
    | Some (Q', P') =>
      1 + TailRec_steps P' a + ConsClos_steps Q' a
    | None => 0
    end.

  Definition Step_lam_steps P a := 1 + JumpTarget_steps P + Step_lam_steps_JumpTarget P a.

  Definition Step_lam_T : tRel sigStep^+ 10 :=
    fun tin k =>
      exists (T V : list HClos) (H : Heap) (a : HAdd) (P : Pro),
        tin[@Fin0] ≃ T /\
        tin[@Fin1] ≃ V /\
        tin[@Fin2] ≃ H /\
        tin[@Fin3] ≃(Encode_map Encode_Prog retr_pro_step) P /\
        tin[@Fin4] ≃(Encode_map Encode_nat retr_nat_step_clos_ad) a /\
        (forall i : Fin.t 5, isRight tin[@FinR 5 i]) /\
        Step_lam_steps P a <= k.

  Lemma Step_lam_Terminates : projT1 Step_lam ↓ Step_lam_T.
  Proof.
    eapply TerminatesIn_monotone.
    { unfold Step_lam. TM_Correct.
      - apply JumpTarget_Realise.
      - apply JumpTarget_Terminates.
      - apply TailRec_Realise.
      - apply TailRec_Terminates.
      - apply ConsClos_Terminates.
    }
    {
      intros tin k. intros (T&V&H&a&P&HEncT&HEncV&HEncH&HEncP&HEncA&HInt&Hk). unfold Step_lam_steps in Hk.
      exists (JumpTarget_steps P), (Step_lam_steps_JumpTarget P a). cbn; repeat split; try omega.
      { hnf; cbn. do 1 eexists; repeat split; simpl_surject; eauto.
        - apply HInt.
        - intros i; destruct_fin i; cbn; simpl_surject; TMSimp_goal; eauto; apply HInt. }
      intros tmid ymid (HJump&HJumpInj); TMSimp. modpon HJump.
      { intros i; destruct_fin i; cbn; simpl_surject; TMSimp_goal; eauto; apply HInt. }
      destruct ymid.
      {
        destruct HJump as (P'&Q'&HJump); modpon HJump.
        unfold Step_lam_steps_JumpTarget. rewrite HJump.
        exists (TailRec_steps P' a), (ConsClos_steps Q' a). cbn; repeat split; try omega. hnf; cbn; eauto 7.
        intros tmid0 () (HTailRec&HTailRecInj); TMSimp. modpon HTailRec.
        hnf; cbn. eauto 7.
      }
      { omega. }
    }
  Qed.

  Definition Put_Rel : pRel sigStep^+ unit 6 :=
    ignoreParam (
        fun tin tout =>
          forall (H : Heap) (g : HClos) (b : HAdd),
            tin[@Fin0] ≃ H ->
            tin[@Fin1] ≃(Encode_map Encode_HClos retr_clos_step) g ->
            tin[@Fin2] ≃(Encode_map Encode_nat retr_nat_step_clos_ad) b ->
            isRight tin[@Fin3] -> isRight tin[@Fin4] -> isRight tin[@Fin5] ->
            tout[@Fin0] ≃ H ++ [Some (g,b)] /\
            isRight tout[@Fin1] /\
            isRight tout[@Fin2] /\
            tout[@Fin3] ≃(Encode_map Encode_nat retr_nat_step_clos_ad) length H /\
            isRight tout[@Fin4] /\
            isRight tout[@Fin5]
      ).

  Local Definition retr_nat_step_hent : Retract sigNat sigStep := ComposeRetract retr_heap_step retr_nat_heap_entry.

  Local Definition retr_clos_step_hent : Retract sigHClos sigStep := ComposeRetract retr_heap_step retr_clos_heap.

  Local Definition retr_hent'_step : Retract sigHEntr' sigStep := ComposeRetract retr_heap_step retr_hent'_heap.

  Local Definition retr_hent_step : Retract sigHEntr sigStep := ComposeRetract retr_heap_step retr_hent_heap.

  Definition Put : pTM sigStep^+ unit 6 :=
    Length retr_heap_step retr_nat_step_clos_ad @ [|Fin0; Fin3; Fin4; Fin5|];;
    Constr_nil sigHEntr_fin ⇑ _ @ [|Fin4|];;
    Translate retr_nat_step_clos_ad retr_nat_step_hent @ [|Fin2|];;
    Translate retr_clos_step retr_clos_step_hent @ [|Fin1|];;
    Constr_pair sigHClos_fin sigHAdd_fin ⇑ retr_hent'_step @ [|Fin1; Fin2|];;
    Constr_Some sigHEntr'_fin ⇑ retr_hent_step @ [|Fin2|];;
    Constr_cons sigHEntr_fin ⇑ _ @ [|Fin4; Fin2|];;
    App' sigHEntr_fin ⇑ _ @ [|Fin0; Fin4|];;
    MoveValue _ @ [|Fin4; Fin0|];;
    Reset _ @ [|Fin2|];;
    Reset _ @ [|Fin1|].

  Lemma Put_Realise : Put ⊨ Put_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold Put. TM_Correct.
      - apply Length_Computes with (X := HEntr).
      - apply Translate_Realise with (X := nat).
      - apply Translate_Realise with (X := HClos).
      - apply App'_Realise with (X := HEntr).
      - apply MoveValue_Realise with (X := Heap) (Y := Heap).
      - apply Reset_Realise with (cX := Encode_map Encode_HEntr retr_hent_step).
      - apply Reset_Realise with (cX := Encode_map Encode_HClos retr_clos_step_hent).
    }
    {
      intros tin ((), tout) H. cbn. intros heap g b HEncHeap HEncG HEncB HRigh3 HRight4 HRight5.
      TMSimp. (* This takes long *)
      rename H into HLength; rename H0 into HNil; rename H1 into HTranslate; rename H2 into HTranslate'; rename H3 into HPair; rename H4 into HSome; rename H5 into HCons; rename H6 into HApp; rename H7 into HMove; rename H8 into HReset; rename H9 into HReset'.
      modpon HLength.
      { intros i; destruct_fin i; TMSimp_goal; auto. }
      specialize (HLength1 Fin1) as HLength2; specialize (HLength1 Fin0).
      modpon HNil.
      modpon HTranslate.
      modpon HTranslate'.
      modpon HPair.
      specialize (HSome (g, b)). modpon HSome. cbn in *.
      specialize (HCons [] (Some (g, b))). modpon HCons.
      modpon HApp.
      modpon HMove.
      specialize (HReset (Some (g, b))). modpon HReset.
      modpon HReset'.
      repeat split; auto.
    }
  Qed.

  Definition Put_steps H g b :=
    10 + Length_steps _ H + Constr_nil_steps + Translate_steps _ b + Translate_steps _ g + Constr_pair_steps _ g + Constr_Some_steps +
    Constr_cons_steps _ (Some (g, b)) + App'_steps _ H + MoveValue_steps _ _ (H++[Some(g,b)]) H + Reset_steps _ (Some (g, b)) + Reset_steps _ g.

  Definition Put_T : tRel sigStep ^+ 6 :=
    fun tin k =>
      exists (H : Heap) (g : HClos) (b : HAdd),
        tin[@Fin0] ≃ H /\
        tin[@Fin1] ≃(Encode_map Encode_HClos retr_clos_step) g /\
        tin[@Fin2] ≃(Encode_map Encode_nat retr_nat_step_clos_ad) b /\
        isRight tin[@Fin3] /\ isRight tin[@Fin4] /\ isRight tin[@Fin5] /\
        Put_steps H g b <= k.

  Lemma Put_Terminates : projT1 Put ↓ Put_T.
  Proof.
    eapply TerminatesIn_monotone.
    { unfold Put. TM_Correct.
      - apply Length_Computes with (X := HEntr).
      - apply Length_Terminates with (X := HEntr).
      - apply Translate_Realise with (X := nat).
      - apply Translate_Terminates with (X := nat).
      - apply Translate_Realise with (X := HClos).
      - apply Translate_Terminates with (X := HClos).
      - apply App'_Realise with (X := HEntr).
      - apply App'_Terminates with (X := HEntr).
      - apply MoveValue_Realise with (X := Heap) (Y := Heap).
      - apply MoveValue_Terminates with (X := Heap) (Y := Heap).
      - apply Reset_Realise with (cX := Encode_map Encode_HEntr retr_hent_step).
      - apply Reset_Terminates with (cX := Encode_map Encode_HEntr retr_hent_step).
      - apply Reset_Terminates with (cX := Encode_map Encode_HClos retr_clos_step_hent).
    }
    {
      intros tin k. intros (H&g&b&HEncH&HEncG&HEncB&HRight3&HRight4&HRight5&Hk). unfold Put_steps in Hk.
      exists (Length_steps _ H),
      (1 + Constr_nil_steps + 1 + Translate_steps _ b + 1 + Translate_steps _ g + 1 + Constr_pair_steps _ g + 1 + Constr_Some_steps +
       1 + Constr_cons_steps _ (Some (g, b)) + 1 + App'_steps _ H + 1 + MoveValue_steps _ _ (H++[Some(g,b)]) H + 1 + Reset_steps _ (Some (g, b)) +
       Reset_steps _ g).
      cbn; repeat split; try omega. now hnf; cbn; eauto 10.
      intros tmid () (HLength&HLengthInj); TMSimp. modpon HLength. 1: now intros i; destruct_fin i; cbn; auto.
      exists (Constr_nil_steps),
      (1 + Translate_steps _ b + 1 + Translate_steps _ g + 1 + Constr_pair_steps _ g + 1 + Constr_Some_steps +
       1 + Constr_cons_steps _ (Some (g, b)) + 1 + App'_steps _ H + 1 + MoveValue_steps _ _ (H++[Some(g,b)]) H + 1 + Reset_steps _ (Some (g, b)) +
       Reset_steps _ g).
      cbn; repeat split; try omega. now rewrite !Nat.add_assoc.
      intros tmid0 () (HNil&HNilInj); TMSimp. modpon HNil. simpl_surject. exact (HLength1 Fin0).
      exists (Translate_steps _ b),
      (1 + Translate_steps _ g + 1 + Constr_pair_steps _ g + 1 + Constr_Some_steps + 1 + Constr_cons_steps _ (Some (g, b)) +
       1 + App'_steps _ H + 1 + MoveValue_steps _ _ (H++[Some(g,b)]) H + 1 + Reset_steps _ (Some (g, b)) + Reset_steps _ g).
      cbn; repeat split; try omega. now hnf; cbn; eexists; split; eauto. now rewrite !Nat.add_assoc.
      intros tmid1 () (HTranslate&HTranslateInj); TMSimp. modpon HTranslate.
      exists (Translate_steps _ g),
      (1 + Constr_pair_steps _ g + 1 + Constr_Some_steps + 1 + Constr_cons_steps _ (Some (g, b)) +
       1 + App'_steps _ H + 1 + MoveValue_steps _ _ (H++[Some(g,b)]) H + 1 + Reset_steps _ (Some (g, b)) + Reset_steps _ g).
      cbn; repeat split; try omega. now hnf; cbn; eauto. now rewrite !Nat.add_assoc.
      intros tmid2 () (HTranslate'&HTranslateInj'); TMSimp. modpon HTranslate'.
      exists (Constr_pair_steps _ g),
      (1 + Constr_Some_steps + 1 + Constr_cons_steps _ (Some (g, b)) +
       1 + App'_steps _ H + 1 + MoveValue_steps _ _ (H++[Some(g,b)]) H + 1 + Reset_steps _ (Some (g, b)) + Reset_steps _ g).
      cbn; repeat split; try omega. 2: now rewrite !Nat.add_assoc.
      { hnf; cbn; eexists; split; simpl_surject; eauto; contains_ext. }
      intros tmid3 () (HPair&HPairInj); TMSimp. modpon HPair.
      exists (Constr_Some_steps),
      (1 + Constr_cons_steps _ (Some (g, b)) + 1 + App'_steps _ H + 1 + MoveValue_steps _ _ (H++[Some(g,b)]) H + 1 +
       Reset_steps _ (Some (g, b)) + Reset_steps _ g).
      cbn; repeat split; try omega. now rewrite !Nat.add_assoc.
      intros tmid4 () (HSome&HSomeInj); TMSimp. specialize (HSome (g,b)); modpon HSome.
      exists (Constr_cons_steps _ (Some (g, b))),
         (1 + App'_steps _ H + 1 + MoveValue_steps _ _ (H++[Some(g,b)]) H + 1 + Reset_steps _ (Some (g, b)) + Reset_steps _ g).
      cbn; repeat split; try omega. 2: now rewrite !Nat.add_assoc.
      { do 2 eexists; repeat split; simpl_surject; eauto. contains_ext. }
      intros tmid5 () (HCons&HConsInj); TMSimp. specialize (HCons [] (Some (g,b))); modpon HCons.
      exists (App'_steps _ H), (1 + MoveValue_steps _ _ (H++[Some(g,b)]) H + 1 + Reset_steps _ (Some (g, b)) + Reset_steps _ g).
      cbn; repeat split; try omega. 2: now rewrite !Nat.add_assoc.
      { hnf; cbn. do 2 eexists; repeat split; simpl_surject; eauto. }
      intros tmid6 () (HApp&HAppInj); TMSimp. modpon HApp.
      exists (MoveValue_steps _ _ (H++[Some(g,b)]) H), (1 + Reset_steps _ (Some (g, b)) + Reset_steps _ g).
      cbn; repeat split; try omega. 2: now rewrite !Nat.add_assoc.
      { hnf; cbn. do 2 eexists; repeat split; simpl_surject; eauto.
        now rewrite (MoveValue_steps_comp Encode_Heap Encode_Heap retr_heap_step retr_heap_step). }
      intros tmid7 () (HMove&HMoveInj); TMSimp. modpon HMove.
      exists (Reset_steps _ (Some (g, b))), (Reset_steps _ g).
      cbn; repeat split; try omega.
      { hnf; cbn. exists (Some (g, b)). split; eauto. contains_ext. now setoid_rewrite Reset_steps_comp. } reflexivity. (* oh omega... *)
      intros tmid8 () (HReset&HResetInj); TMSimp. specialize (HReset (Some (g,b))); modpon HReset.
      { hnf; cbn. exists g. repeat split; eauto. contains_ext. now setoid_rewrite Reset_steps_comp. }
    }
  Qed.

  Definition Step_app_Rel : pRel sigStep^+ bool 11 :=
    fun tin '(yout, tout) =>
      forall (T V : list HClos) (H : Heap) (a : HAdd) (P : Pro),
        tin[@Fin0] ≃ T ->
        tin[@Fin1] ≃ V ->
        tin[@Fin2] ≃ H ->
        tin[@Fin3] ≃(Encode_map Encode_Prog retr_pro_step) P ->
        tin[@Fin4] ≃(Encode_map Encode_nat retr_nat_step_clos_ad) a ->
        (forall i : Fin.t 6, isRight tin[@FinR 5 i]) ->

        match yout, V with
        | true, g :: (b, Q) :: V =>
          let (c, H') := put H (Some (g, b)) in (* This simplifys immediatly by computation *)
          tout[@Fin0] ≃ (c, Q) :: tailRecursion (a, P) T /\
          tout[@Fin1] ≃ V /\
          tout[@Fin2] ≃ H' /\
          (forall i : Fin.t 8, isRight tout[@FinR 3 i])
        | false, [] => True
        | false, [_] => True
        | _, _ => False
        end.

  Definition Step_app : pTM sigStep^+ bool 11 :=
    If (CaseList sigHClos_fin ⇑ _ @ [|Fin1; Fin5|])
       (If (CaseList sigHClos_fin ⇑ _ @ [|Fin1; Fin6|])
           (Return (CasePair sigHAdd_fin sigPro_fin ⇑ retr_clos_step @ [|Fin6; Fin7|];;
                    TailRec @ [|Fin0; Fin3; Fin4|];;
                    Reset _ @ [|Fin4|];;
                    Put @ [|Fin2; Fin5; Fin7; Fin8; Fin9; Fin10|];;
                    ConsClos @ [|Fin0; Fin8; Fin6|])
                   (true))
           (Return Nop false))
       (Return Nop false)
  .

  Lemma Step_app_Realise : Step_app ⊨ Step_app_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold Step_app. TM_Correct.
      - apply TailRec_Realise.
      - apply Reset_Realise with (cX := Encode_map Encode_nat retr_nat_step_clos_ad).
      - apply Put_Realise.
      - apply ConsClos_Realise.
    }
    {
      intros tin (yout, tout) H. cbn. intros T V heap a P HEncT HEncV HEncH HEncP HEncA HInt.
      TMSimp. rename H into HIf.
      destruct HIf; TMSimp.
      { (* Then of first [CaseList], i.e. [V = g :: V'] *) rename H into HCaseList, H0 into HIf'.
        modpon HCaseList. destruct V as [ | g V']; auto; modpon HCaseList.
        destruct HIf'; TMSimp. (* This takes long *)
        {
          rename H into HCaseList'; rename H0 into HCasePair; rename H1 into HTailRec; rename H2 into HReset; rename H3 into HPut; rename H4 into HConsClos.
          modpon HCaseList'. destruct V' as [ | (b, Q) V'']; auto. modpon HCaseList'.
          specialize (HCasePair (b,Q)). modpon HCasePair. cbn in *.
          modpon HTailRec.
          modpon HReset.
          modpon HPut.
          modpon HConsClos.
          repeat split; auto.
          intros i; destruct_fin i; auto; TMSimp_goal; auto.
        }
        { modpon H. destruct V'; auto. }
      }
      { modpon H. destruct V; auto. }
    }
  Qed.

  Definition Step_app_steps_CaseList' T g V' H P a :=
    match V' with
    | nil => 0 (* Nop *)
    | (b, Q) :: V'' =>
      4 + CasePair_steps _ b + TailRec_steps P a + Reset_steps _ a + Put_steps H g b + ConsClos_steps Q (length H)
    end.

  Definition Step_app_steps_CaseList T V H P a :=
    match V with
    | nil => 0 (* Nop *)
    | g :: V' => 1 + CaseList_steps _ V' + Step_app_steps_CaseList' T g V' H P a
    end.

  Definition Step_app_steps T V H a P := 1 + CaseList_steps _ V + Step_app_steps_CaseList T V H P a.

  Definition Step_app_T : tRel sigStep^+ 11 :=
    fun tin k =>
      exists (T V : list HClos) (H : Heap) (P : Pro) (a : HAdd),
        tin[@Fin0] ≃ T /\
        tin[@Fin1] ≃ V /\
        tin[@Fin2] ≃ H /\
        tin[@Fin3] ≃(Encode_map Encode_Prog retr_pro_step) P /\
        tin[@Fin4] ≃(Encode_map Encode_nat retr_nat_step_clos_ad) a /\
        (forall i : Fin.t 6, isRight tin[@FinR 5 i]) /\
        Step_app_steps T V H a P <= k.

  Lemma Step_app_Terminates : projT1 Step_app ↓ Step_app_T.
  Proof.
    eapply TerminatesIn_monotone.
    { unfold Step_app. TM_Correct.
      - apply TailRec_Realise.
      - apply TailRec_Terminates.
      - apply Reset_Realise with (cX := Encode_map Encode_nat retr_nat_step_clos_ad).
      - apply Reset_Terminates with (cX := Encode_map Encode_nat retr_nat_step_clos_ad).
      - apply Put_Realise.
      - apply Put_Terminates.
      - apply ConsClos_Terminates.
    }
    {
      intros tin k. intros (T&V&H&P&a&HEncT&HEncV&HEncH&HEncP&HEncA&HInt&Hk). unfold Step_app_steps in Hk.
      exists (CaseList_steps _ V), (Step_app_steps_CaseList T V H P a).
      cbn; repeat split; try omega.
      { exists V. repeat split; simpl_surject; eauto. apply HInt. }
      intros tmid bml1 (HCaseList&HCaseListInj); TMSimp. modpon HCaseList.
      destruct bml1, V as [ | g V']; auto; modpon HCaseList.
      {
        unfold Step_app_steps_CaseList.
        exists (CaseList_steps _ V'), (Step_app_steps_CaseList' T g V' H P a).
        cbn; repeat split; try omega.
        { exists V'. repeat split; simpl_surject; eauto. }
        intros tmid1 bml2 (HCaseList'&HCaseListInj'); TMSimp. modpon HCaseList'.
        destruct bml2, V' as [ | (b, Q) V'']; auto; modpon HCaseList'.
        {
          unfold Step_app_steps_CaseList'.
          exists (CasePair_steps _ b), (1 + TailRec_steps P a + 1 + Reset_steps _ a + 1 + Put_steps H g b + ConsClos_steps Q (length H)).
          cbn; repeat split; try omega.
          { hnf; cbn. exists (b, Q). repeat split; simpl_surject; eauto. contains_ext. }
          intros tmid2 () (HCasePair&HCasePairInj); TMSimp. specialize (HCasePair (b,Q)); modpon HCasePair.
          exists (TailRec_steps P a), (1 + Reset_steps _ a + 1 + Put_steps H g b + ConsClos_steps Q (length H)).
          cbn; repeat split; try omega. 2: now rewrite !Nat.add_assoc.
          { hnf; cbn. do 3 eexists. repeat split; simpl_surject; eauto. }
          intros tmid3 () (HTailRec&HTailRecInj); TMSimp. modpon HTailRec.
          exists (Reset_steps _ a), (1 + Put_steps H g b + ConsClos_steps Q (length H)).
          cbn; repeat split; try omega. 2: now rewrite !Nat.add_assoc.
          { hnf; cbn. do 1 eexists. repeat split; simpl_surject; eauto. now setoid_rewrite Reset_steps_comp. }
          intros tmid4 () (HReset&HResetInj); TMSimp. modpon HReset.
          exists (Put_steps H g b), (ConsClos_steps Q (length H)).
          cbn; repeat split; try omega.
          { hnf; cbn. do 3 eexists. repeat split; simpl_surject; eauto; contains_ext. }
          intros tmid5 () (HPut&HInjPut); TMSimp. modpon HPut.
          { hnf; cbn. do 3 eexists. repeat split; simpl_surject; eauto; contains_ext. }
        }
      }
    }
  Qed.

  Definition Step_var_Rel : pRel sigStep^+ bool 8 :=
    fun tin '(yout, tout) =>
      forall (T V : list HClos) (H : Heap) (a : HAdd) (n : nat) (P : Pro),
        tin[@Fin0] ≃ T ->
        tin[@Fin1] ≃ V ->
        tin[@Fin2] ≃ H ->
        tin[@Fin3] ≃(Encode_map Encode_Prog retr_pro_step) P ->
        tin[@Fin4] ≃(Encode_map Encode_nat retr_nat_step_clos_ad) a ->
        tin[@Fin5] ≃(Encode_map Encode_nat retr_nat_step_clos_var) n ->
        isRight tin[@Fin6] -> isRight tin[@Fin7] ->
        match yout with
        | true =>
          exists (g : HClos),
          lookup H a n = Some g /\
          tout[@Fin0] ≃ tailRecursion (a, P) T /\
          tout[@Fin1] ≃ g :: V /\
          tout[@Fin2] ≃ H /\
          (forall i : Fin.t 5, isRight tout[@FinR 3 i])
        | false => lookup H a n = None
        end
  .

  Definition Step_var : pTM sigStep^+ bool 8 :=
    TailRec @ [|Fin0; Fin3; Fin4|];;
    If (Step_Lookup @ [|Fin2; Fin4; Fin5; Fin6; Fin7|])
       (Return (Constr_cons sigHClos_fin ⇑ _ @ [|Fin1; Fin6|];;
                Reset _ @ [|Fin6|])
               (true))
       (Return Nop false).

  Local Definition retr_closure_step : Retract sigHClos sigStep := ComposeRetract retr_closures_step _.

  Lemma Step_var_Realise : Step_var ⊨ Step_var_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold Step_var. TM_Correct.
      - apply TailRec_Realise.
      - apply Lookup_Realise.
      - apply Reset_Realise with (cX := Encode_map Encode_HClos retr_closure_step).
    }
    {
      intros tin (yout, tout) H. cbn. intros T V heap a n P HEncT HEncV HEncHeap HEncP HEncA HEncN HRight6 HRight7.
      TMSimp. rename H into HTailRec, H0 into HIf.
      modpon HTailRec.
      destruct HIf; TMSimp.
      { rename H into HLookup, H0 into HCons, H1 into HReset.
        modpon HLookup. destruct HLookup as (g&HLookup); modpon HLookup.
        modpon HCons. modpon HReset.
        eexists; repeat split; eauto. intros i; destruct_fin i; auto; TMSimp_goal; auto.
      }
      { now modpon H. }
    }
  Qed.

  Definition Step_var_steps_Lookup P V H a n :=
    match lookup H a n with
    | None => 0 (* Nop *)
    | Some g => 1 + Constr_cons_steps _ g + Reset_steps _ g
    end.

  Definition Step_var_steps P V H a n := 2 + TailRec_steps P a + Lookup_steps H a n + Step_var_steps_Lookup P V H a n.

  Definition Step_var_T : tRel sigStep^+ 8 :=
    fun tin k =>
      exists (T V : list HClos) (H : Heap) (a : HAdd) (n : nat) (P : Pro),
        tin[@Fin0] ≃ T /\
        tin[@Fin1] ≃ V /\
        tin[@Fin2] ≃ H /\
        tin[@Fin3] ≃(Encode_map Encode_Prog retr_pro_step) P /\
        tin[@Fin4] ≃(Encode_map Encode_nat retr_nat_step_clos_ad) a /\
        tin[@Fin5] ≃(Encode_map Encode_nat retr_nat_step_clos_var) n /\
        isRight tin[@Fin6] /\ isRight tin[@Fin7] /\
        Step_var_steps P V H a n <= k.

  Lemma Step_var_Terminates : projT1 Step_var ↓ Step_var_T.
  Proof.
    eapply TerminatesIn_monotone.
    { unfold Step_var. TM_Correct.
      - apply TailRec_Realise.
      - apply TailRec_Terminates.
      - apply Lookup_Realise.
      - apply Lookup_Terminates.
      - apply Reset_Terminates with (cX := Encode_map Encode_HClos retr_closure_step).
    }
    {
      intros tin k. intros (T&V&H&a&n&P&HEncT&HEncV&HEncH&HEncP&HEncA&HEncN&HRight6&HRigth7&Hk). unfold Step_var_steps in Hk.
      exists (TailRec_steps P a), (1 + Lookup_steps H a n + Step_var_steps_Lookup P V H a n).
      cbn; repeat split; try omega.
      { hnf; cbn. do 3 eexists; repeat split; eauto. }
      intros tmid () (HTailRec&HTailRecInj); TMSimp. modpon HTailRec.
      exists (Lookup_steps H a n), (Step_var_steps_Lookup P V H a n).
      cbn; repeat split; try omega.
      { hnf; cbn. do 3 eexists; repeat split; eauto. }
      intros tmid0 ymid (HLookup&HLookupInj); TMSimp. modpon HLookup.
      destruct ymid.
      {
        destruct HLookup as (g&HLookup); modpon HLookup.
        unfold Step_var_steps_Lookup. rewrite HLookup.
        exists (Constr_cons_steps _ g), (Reset_steps _ g).
        cbn; repeat split; try omega.
        { hnf; cbn. do 2 eexists; repeat split; simpl_surject; eauto. contains_ext. }
        intros tmid1 () (HCons&HConsInj); TMSimp. modpon HCons.
        { hnf; cbn. do 1 eexists; repeat split; simpl_surject; eauto. contains_ext. now setoid_rewrite Reset_steps_comp. }
      }
      { omega. }
    }
  Qed.

  (* I forgot that [While] takes a machine over [option unit] instead of [bool]. But that's no problem since we have [Relabel]. *)
  Coercion bool2optunit := fun b : bool => if b then None else Some tt.

  Definition Step : pTM sigStep^+ (option unit) 11 :=
    Relabel
      (If (CaseList sigHClos_fin ⇑ _ @ [|Fin0; Fin3|])
          (CasePair sigHAdd_fin sigPro_fin ⇑ retr_clos_step @ [|Fin3; Fin4|];;
           If (CaseList sigCom_fin ⇑ retr_pro_step @ [|Fin3; Fin5|])
              (Switch (CaseCom ⇑ retr_tok_step @ [|Fin5|])
                     (fun t : option ACom =>
                        match t with
                        | Some lamAT =>
                          Step_lam @ [|Fin0; Fin1; Fin2; Fin3; Fin4; Fin5; Fin6; Fin7; Fin8; Fin9|]
                        | Some appAT =>
                          Step_app
                        | Some retAT =>
                          Return Nop false
                        | None (* Variable *) =>
                          Step_var @ [|Fin0; Fin1; Fin2; Fin3; Fin4; Fin5; Fin6; Fin7|]
                        end))
              (Return Nop false))
          (Return Nop false)
        ) bool2optunit.

  Definition Step_Rel : pRel sigStep^+ (option unit) 11 :=
    fun tin '(yout, tout) =>
      forall (T V : list HClos) (H: Heap),
        tin[@Fin0] ≃ T ->
        tin[@Fin1] ≃ V ->
        tin[@Fin2] ≃ H ->
        (forall i : Fin.t 8, isRight tin[@FinR 3 i]) ->
        match yout with
        | None =>
          exists T' V' H',
          step (T,V,H) (T',V',H') /\
          tout[@Fin0] ≃ T' /\
          tout[@Fin1] ≃ V' /\
          tout[@Fin2] ≃ H' /\
          (forall i : Fin.t 8, isRight tout[@FinR 3 i])
        | Some tt =>
          halt_state (T,V,H) /\
          match T with
          | nil =>
            tout[@Fin0] ≃ (@nil HClos) /\
            tout[@Fin1] ≃ V /\
            tout[@Fin2] ≃ H /\
            (forall i : Fin.t 8, isRight tout[@FinR 3 i])
          | _ => True
          end
        end.

  Lemma Step_Realise : Step ⊨ Step_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold Step. TM_Correct.
      - eapply RealiseIn_Realise. apply CaseCom_Sem.
      - apply Step_lam_Realise.
      - apply Step_app_Realise.
      - apply Step_var_Realise.
    }
    {
      intros tin (yout, tout) H. cbn. intros T V Heap HEncT HEncV HEncHeap HInt.
      TMSimp. rename H0 into HIf.
      destruct HIf; TMSimp.
      { (* Then of [CaseList], i.e. [T = (a, P) :: T'] *) rename H into HCaseList, H0 into HCasePair, H1 into HIf'.
        modpon HCaseList. destruct T as [ | (a, P) T' ]; auto; modpon HCaseList.
        specialize (HCasePair (a, P)); modpon HCasePair.
        destruct HIf'; TMSimp.
        { (* Then of second [CaseList], i.e [P = t :: P'] *) rename H into HCaseList', H0 into HCaseCom, H1 into HCase.
          modpon HCaseList'. destruct P as [ | t P']; auto; modpon HCaseList'.
          modpon HCaseCom. destruct ymid0 as [ [ | | ] | ], t; auto; simpl_surject; cbn in *.
          { (* retT *)
            destruct HCase as (->&(?&->)); cbn. split; auto. hnf. intros s HStep. inv HStep.
          }
          { (* lamT *)
            rename HCase into HStepLam. modpon HStepLam; TMSimp_goal; eauto; try contains_ext.
            intros i; destruct_fin i; auto; TMSimp_goal; cbn; auto.
            destruct ymid.
            - cbn. destruct HStepLam as (jump_P&jump_Q&HStepLam); modpon HStepLam.
              do 3 eexists. repeat split; eauto.
              + econstructor. eauto.
              + generalize (HStepLam4 Fin0); generalize (HStepLam4 Fin1); generalize (HStepLam4 Fin2); generalize (HStepLam4 Fin3); generalize (HStepLam4 Fin4); generalize (HStepLam4 Fin5); generalize (HStepLam4 Fin6); cbn; TMSimp_goal; intros.
                destruct_fin i; TMSimp_goal; auto. rewrite HStepLam0 by vector_not_in. now TMSimp_goal.
            - cbn. split; auto. intros s' HStep. inv HStep. congruence.
          }
          { (* appT *)
            rename HCase into HStepApp. cbn in HStepApp.
            cbv [put] in *. modpon HStepApp; TMSimp_goal; eauto; try contains_ext.
            { intros i; destruct_fin i; auto; TMSimp_goal; auto. }
            destruct ymid; cbn.
            - destruct V as [ | g V']; auto.
              destruct V' as [ | (b, Q) V'']; auto. modpon HStepApp.
              do 3 eexists. repeat split; eauto.
              + econstructor. reflexivity.
            - split; auto. intros s' HStep. now inv HStep.
          }
          { (* varT *)
            rename HCase into HStepVar. modpon HStepVar; TMSimp_goal; eauto; try contains_ext.
            destruct ymid; cbn.
            - destruct HStepVar as (g&HStepVar); modpon HStepVar.
              do 3 eexists; repeat split; eauto.
              + econstructor; eauto.
              + generalize (HStepVar4 Fin0); generalize (HStepVar4 Fin1); generalize (HStepVar4 Fin2); generalize (HStepVar4 Fin3); generalize (HStepVar4 Fin4); cbn; TMSimp_goal; intros.
                simpl_not_in. destruct_fin i; auto; TMSimp_goal; auto.
            - split; auto. intros s' HStep. inv HStep. congruence.
          }
        }
        { (* Else of the second [CaseList], i.e [P = nil] *)
          modpon H. destruct P; auto. split; auto. intros s HStep. now inv HStep.
        }
      }
      { (* Else of the first [CaseList], i.e. [T = nil] *)
        modpon H. destruct T; auto. modpon H. split; auto. intros s HStep. now inv HStep.
        repeat split; eauto. intros i; destruct_fin i; TMSimp_goal; auto.
      }
    }
  Qed.

  Definition Step_steps_CaseCom a t P' T' V H :=
    match t with
    | varT n => Step_var_steps P' V H a n
    | appT => Step_app_steps T' V H a P'
    | lamT => Step_lam_steps P' a
    | retT => 0 (* Nop *)
    end.

  Definition Step_steps_CaseList' a P T' V H :=
    match P with
    | nil => 0
    | t :: P' => 1 + CaseCom_steps + Step_steps_CaseCom a t P' T' V H
    end.

  Definition Step_steps_CaseList T V H :=
    match T with
    | nil => 0
    | (a,P) :: T' => 2 + CasePair_steps _ a + CaseList_steps _ P + Step_steps_CaseList' a P T' V H
    end.

  Definition Step_steps T V H :=
    1 + CaseList_steps _ T + Step_steps_CaseList T V H.

  Definition Step_T : tRel sigStep^+ 11 :=
    fun tin k =>
      exists (T V : list HClos) (H: Heap),
        tin[@Fin0] ≃ T /\
        tin[@Fin1] ≃ V /\
        tin[@Fin2] ≃ H /\
        (forall i : Fin.t 8, isRight tin[@FinR 3 i]) /\
        Step_steps T V H <= k.

  Lemma Step_Terminates : projT1 Step ↓ Step_T.
  Proof.
    eapply TerminatesIn_monotone.
    { unfold Step. TM_Correct.
      - eapply RealiseIn_Realise. apply CaseCom_Sem.
      - eapply RealiseIn_TerminatesIn. apply CaseCom_Sem.
      - apply Step_lam_Terminates.
      - apply Step_app_Terminates.
      - apply Step_var_Terminates.
    }
    {
      intros tin k (T&V&H&HEncT&HEncV&HEncH&HInt&Hk). unfold Step_steps in Hk.
      exists (CaseList_steps _ T), (Step_steps_CaseList T V H). cbn; repeat split; try omega.
      { do 1 eexists; repeat split; simpl_surject; eauto. apply HInt. }
      intros tmid bif (HCaseList&HCaseListInj); TMSimp. modpon HCaseList.
      destruct bif, T as [ | (a,P) T']; cbn; auto; modpon HCaseList.
      exists (CasePair_steps _ a), (1 + CaseList_steps _ P + Step_steps_CaseList' a P T' V H). cbn; repeat split; try omega.
      { hnf; cbn. exists (a, P); repeat split; simpl_surject; eauto. contains_ext. }
      intros tmid0 () (HCasePair&HCasePairInj); TMSimp. specialize (HCasePair (a,P)). modpon HCasePair. cbn in *.
      exists (CaseList_steps _ P), (Step_steps_CaseList' a P T' V H). cbn; repeat split; try omega. 2: reflexivity.
      { hnf; cbn. exists P; repeat split; simpl_surject; eauto. contains_ext. }
      intros tmid1 bif (HCaseList'&HCaseListInj'); TMSimp. modpon HCaseList'.
      destruct bif, P as [ | t P']; auto; modpon HCaseList'. cbn.
      exists (CaseCom_steps), (Step_steps_CaseCom a t P' T' V H). cbn; repeat split; try omega.
      intros tmid2 ymid (HCaseCom&HCaseComInj); TMSimp. modpon HCaseCom.
      destruct ymid as [ [ | | ] | ]; destruct t; cbn; auto; simpl_surject.
      - hnf; cbn. do 5 eexists; repeat split; TMSimp_goal; eauto. contains_ext. intros i; destruct_fin i; cbn; TMSimp_goal; auto.
      - hnf; cbn. do 5 eexists; repeat split; TMSimp_goal; eauto. contains_ext. intros i; destruct_fin i; cbn; TMSimp_goal; auto.
      - hnf; cbn. do 6 eexists; repeat split; TMSimp_goal; eauto. contains_ext. contains_ext.
    }
  Qed.

End StepMachine.


(**************************************************************************)
(*           *                                                            *)
(*     _     *   The Coccinelle Library / Evelyne Contejean               *)
(*    <o>    *          CNRS-LRI-Universite Paris Sud                     *)
(*  -/@|@\-  *                   A3PAT Project                            *)
(*  -@ | @-  *                                                            *)
(*  -\@|@/-  *      This file is distributed under the terms of the       *)
(*    -v-    *      CeCILL-C licence                                      *)
(*           *                                                            *)
(**************************************************************************)

(*
   - Ly Kim Quyen, 2013-09-16

   Re-define Module type into Section to be able to use in new
   formalization of Rainbow.
*)

(** * Term algebra defined as functor from a Module Signature and a Module Variable.*)

Require Import Recdef.
Require Import List.
Require Import closure.
Require Import more_list.
Require Import list_permut.
Require Import list_set.
Require Import Arith.
Require Import Setoid.

Set Implicit Arguments.

(***********************************************************************)
(** convert a CoLoR signature into a Coccinelle signature *)

Require Import term_spec EqUtil ASignature.

Section Make_Signature.

  Variable Sig: Signature.

  Definition A_symb := symbol Sig.

  Definition eq_bool_symb := @beq_symb Sig.

  Lemma eq_bool_symb_ok : forall a1 a2,
    match eq_bool_symb a1 a2 with true => a1 = a2 | false => ~ a1 = a2 end.

  Proof.
    intros a1 a2. unfold eq_bool_symb. case_beq_symb Sig a1 a2. auto.
    rewrite <- (beq_ko (@beq_symb_ok Sig)). apply H.
  Qed.

  Definition arity' (f: Sig) : arity_type  := Free (ASignature.arity f).

End Make_Signature.

(***********************************************************************)
(** convert CoLoR variables to Coccinelle variables *)

Require Import NatUtil LogicUtil.

Section Var.

  Definition var_A := nat.

  Definition var_eq_bool := beq_nat.

  Lemma var_eq_bool_ok: forall a1 a2,
    match var_eq_bool a1 a2 with true => a1 = a2 | false => ~ a1 = a2 end.

  Proof.
    intros a1 a2. unfold var_eq_bool. case_beq_nat a1 a2. auto.
    rewrite <- (beq_ko beq_nat_ok). hyp.
  Qed.

End Var.

(******************************************************************************************)
(** * A functor building a Term Module from a Signature and a set of Variables.*)

Section Make'.

  Variable Sig: Signature.

  Notation A := (A_symb Sig).
  Notation eq_symb_bool := (eq_bool_symb Sig).
  Notation eq_symb_bool_ok := (eq_bool_symb_ok Sig).
  Notation eq_var_bool := var_eq_bool.
  Notation eq_var_bool_ok := var_eq_bool_ok.

  (******************************************************************************************)
  (** Definition of terms.
     Arity is not taken into account, and terms may be hill-formed. *)

  (* Define symbol of type [symbol Sig] for Term in CoLoR has [symbol
  Sig] *)

  Notation symbol := A.
  Notation variable := nat (only parsing).

  Inductive term : Type :=
  | Var : variable -> term
  | Term : symbol -> list term -> term.

  (** Definition and a few properties of the size of a term.*)

  Fixpoint size (t: term) : nat :=
    match t with
      | Var v => 1
      | Term _ l =>
        let size_list :=
          (fix size_list (l : list term) {struct l} : nat :=
            match l with
              | nil => 0
              | t :: lt => size t + size_list lt
            end) in
          1 + size_list l
    end.

  Definition size_unfold :
    forall t,
      size t = match t with
                 | Var _ => 1
                 | Term f l => 1 + list_size size l
               end.
  Proof.
    intro t; case t; clear t.
    intro v; reflexivity.
    intros f l; simpl; apply f_equal.
    revert l; fix 1.
    intro l; case l; clear l.
    reflexivity.
    intros t l; simpl; rewrite size_unfold; reflexivity.
  Defined.

  Lemma size_ge_one : forall t, 1 <= size t.
  Proof.
    intro t; case t; clear t.
    intro v; apply le_n.
    intros f l; rewrite size_unfold; apply le_n_S; apply le_O_n.
  Qed.

  Function var_in_term_list (x : variable) (l : list term)
    { measure (list_size size) l } : bool :=
    match l with
      | nil => false
      | (Var y) :: l => orb (eq_var_bool x y) (var_in_term_list x l)
      | (Term _ ll) :: l => orb (var_in_term_list x ll) (var_in_term_list x l)
    end.
  Proof.
    intros _ l t l' y H1 H2;  simpl; auto with arith.
    intros _ l t l' f ll H1 H2; simpl; auto with arith.
    intros _ l t l' f ll H1 H2; simpl; apply lt_le_trans with (size (Term f ll)).
    rewrite size_unfold; simpl; auto with arith.
    simpl; auto with arith.
  Defined.

  Definition direct_subterm t1 t2 : Prop :=
    match t2 with
      | Var _ => False
      | Term _ l => In t1 l
    end.

  Definition size_direct_subterm :
    forall t1 t2, direct_subterm t1 t2 -> size t1 < size t2.

  Proof.
    intros t1 t2; unfold direct_subterm; case t2; clear t2.
    intros a Abs; elim Abs.
    intros f l; rewrite (size_unfold (Term f l)).
    revert t1 l; clear f; fix 2.
    intros t1 l; case l; clear l; simpl.
    intro Abs; elim Abs.
    intros t l t1_in_tl; case t1_in_tl; clear t1_in_tl.
    intro t_eq_t1; subst t1; apply le_n_S; apply le_plus_l.
    intro t_in_l; apply lt_le_trans with (1 + list_size size l).
    apply size_direct_subterm; assumption.
    apply le_n_S; apply le_plus_r.
  Defined.

  Fixpoint t_eq_bool (t1 t2 : term) : bool :=
    match t1, t2 with
      | Var v1, Var v2 => eq_var_bool v1 v2
      | Var _, Term _ _ => false
      | Term _ _, Var _ => false
      | Term f1 l1, Term f2 l2 =>
        if eq_symb_bool f1 f2
          then
            let eq_bool_list :=
              (fix eq_bool_list (l1 l2: list term) {struct l1} : bool :=
                match l1, l2 with
                  | nil, nil => true
                  | nil, (_ :: _) => false
                  | (_::_), nil => false
                  | t1 :: k1, t2 :: k2 => if t_eq_bool t1 t2 then eq_bool_list k1 k2 else false
                end) in
              eq_bool_list l1 l2
          else false
    end.

  Lemma t_eq_bool_ok : forall t1 t2,
    match t_eq_bool t1 t2 with true => t1 = t2 | false => t1<> t2 end.

    fix 1.
    intro t1; case t1; [intro v1 | intros f1 l1];
      (intro t2; case t2; [intro v2 | intros f2 l2]); simpl.
    generalize (eq_var_bool_ok v1 v2); case (eq_var_bool v1 v2).
    intros v1_eq_v2; rewrite v1_eq_v2; reflexivity.
    intros v1_diff_v2 v1_eq_v2; apply v1_diff_v2;
      injection v1_eq_v2; intro; assumption.
    discriminate.
    discriminate.
    generalize (eq_symb_bool_ok f1 f2); case (eq_symb_bool f1 f2).
    intros f1_eq_f2; rewrite f1_eq_f2.
    assert (eq_bool_list_ok : match (fix eq_bool_list (l0 l3 : list term) : bool :=
      match l0 with
        | nil => match l3 with
                   | nil => true
                   | _ :: _ => false
                 end
        | t3 :: k1 =>
          match l3 with
            | nil => false
            | t4 :: k2 => if t_eq_bool t3 t4 then eq_bool_list k1 k2 else false
          end
      end) l1 l2 with true => l1 = l2 | false => l1 <> l2 end).
    revert l1 l2; clear -t_eq_bool_ok.
    fix t_eq_bool_list_ok 1.
    intro l1; case l1; [idtac | intros t1 k1]; (intro l2; case l2; [idtac | intros t2 k2]).
    reflexivity.
    discriminate.
    discriminate.
    generalize (t_eq_bool_ok t1 t2); case (t_eq_bool t1 t2).
    intro t1_eq_t2; rewrite t1_eq_t2.
    generalize (t_eq_bool_list_ok k1 k2);
      case ((fix eq_bool_list (l0 l3 : list term) : bool :=
        match l0 with
          | nil => match l3 with
                     | nil => true
                     | _ :: _ => false
                   end
          | t3 :: k3 =>
            match l3 with
              | nil => false
              | t4 :: k4 => if t_eq_bool t3 t4 then eq_bool_list k3 k4 else false
            end
        end) k1 k2).
    intro k1_eq_k2; rewrite k1_eq_k2; reflexivity.
    intros k1_diff_k2 tk1_eq_tk2; apply k1_diff_k2; injection tk1_eq_tk2; intro; assumption.
    intros t1_diff_t2 tk1_eq_tk2; apply t1_diff_t2; injection tk1_eq_tk2; intros; assumption.
    revert eq_bool_list_ok;
      case ((fix eq_bool_list (l0 l3 : list term) : bool :=
        match l0 with
          | nil =>
            match l3 with
              | nil => true
              | _ :: _ => false
            end
          | t3 :: k1 =>
            match l3 with
              | nil => false
              | t4 :: k2 =>
                if t_eq_bool t3 t4
                  then eq_bool_list k1 k2
                  else false
            end
        end) l1 l2).
    intro l1_eq_l2; rewrite l1_eq_l2; reflexivity.
    intros l1_diff_l2 fl1_eq_fl2; apply l1_diff_l2; injection fl1_eq_fl2; intros; assumption.
    intros f1_diff_f2 fl1_eq_fl2; apply f1_diff_f2; injection fl1_eq_fl2; intros; assumption.
  Defined.

  Definition term_A := term.
  Definition term_eq_bool := t_eq_bool.
  Definition term_eq_bool_ok := t_eq_bool_ok.

  Definition eq_term_dec : forall t t': term, {t=t'}+{t<>t'}.
  intros t t'; generalize (t_eq_bool_ok t t').
  case (t_eq_bool t t').
  intro t_eq_t'; left; assumption.
  intro t_diff_t'; right; assumption.
  Defined.

  (** ** Recursion on terms. *)

  Section Recursion.

    Variable P : term -> Type.
    Variable Pl : list term -> Type.

    Definition term_rec2 : (forall n t, size t <= n -> P t) -> forall t, P t.

    Proof.
      intros H t; apply (H (size t) t); apply le_n.
    Defined.

    Definition term_rec3 :
      (forall v, P (Var v)) -> (forall f l, (forall t, In t l -> P t)
        -> P (Term f l)) -> forall t, P t.

    Proof.
      intros Hv Halg.
      fix 1.
      intro t;case t.
      exact Hv.
      intro a.
      intro l. apply Halg.
      revert l.
      fix term_list_rec_3 1  .
      intro l;case l.
      simpl;intros t0 abs;elim abs.
      intros t0 l0 t1 .
      simpl.
      intros H.
      case (eq_term_dec t0 t1).
      intros t_eq_t1.
      rewrite <- t_eq_t1.
      apply term_rec3.
      intro t_eq_t1. assert (In t1 l0).
      case H. intro abs;elim t_eq_t1;exact abs.
      intro h;exact h.
      apply term_list_rec_3 with l0.
      exact H0.
    Defined.

  End Recursion.

  (** ** Substitutions. *)

  Definition substitution := list (variable * term).

  Fixpoint apply_subst (sigma : substitution) (t : term) {struct t} : term :=
    match t with
      | Var v =>
        match find eq_var_bool v sigma with
          | None => t
          | Some v_sigma => v_sigma
        end
      | Term f l => Term f (map (apply_subst sigma) l)
    end.

  (** ** Positions in a term.*)

  Fixpoint is_a_pos (t : term) (p : list nat) {struct p}: bool :=
    match p with
  | nil => true
      | i :: q =>
        match t with
          | Var _ => false
          | Term _ l =>
            match nth_error l i with
              | Some ti => is_a_pos ti q
              | None => false
            end
        end
    end.

  Fixpoint replace_at_pos (t u : term) (p : list nat) {struct p} : term :=
    match p with
      | nil => u
      | i :: q =>
        match t with
          | Var _ => t
          | Term f l =>
            let replace_at_pos_list :=
              (fix replace_at_pos_list j (l : list term) {struct l}: list term :=
                match l with
                  | nil => nil
                  | h :: tl =>
                    match j with
                      | O => (replace_at_pos h u q) :: tl
                      | S k => h :: (replace_at_pos_list k tl)
                    end
                end) in
              Term f (replace_at_pos_list i l)
        end
    end.

  Fixpoint replace_at_pos_list (l : list term) (u : term) (i : nat) (p : list nat)
    {struct l}: list term :=
    match l with
      | nil => nil
      | h :: tl =>
        match i with
          | O => (replace_at_pos h u p) :: tl
          | S j => h :: (replace_at_pos_list tl  u j p)
        end
    end.

  Lemma replace_at_pos_unfold :
    forall f l u i q,
      replace_at_pos (Term f l) u (i :: q) = Term f (replace_at_pos_list l u i q).
  Proof.
    intros f l u i q; simpl; apply (f_equal (fun l => Term f l));
      generalize u i q; clear u i q;
        induction l as [| t l]; intros u i q; trivial.
    simpl; destruct i as [ | i ]; trivial.
    rewrite <- IHl; trivial.
  Qed.

  Lemma replace_at_pos_list_replace_at_pos_in_subterm :
    forall l1 ui l2 u i p, length l1 = i ->
      replace_at_pos_list (l1 ++ ui :: l2) u i p =
      l1 ++ (replace_at_pos ui u p) :: l2.
  Proof.
    intros l1; induction l1 as [ | u1 l1 ]; intros ui l2 u i p L; simpl in L.
    subst i; trivial.
    destruct i as [ | i ].
    discriminate.
    simpl; rewrite IHl1; trivial.
    inversion L; trivial.
  Qed.

End Make'.


(*
 * Copyright (c) 2020-21 BedRock Systems, Inc.
 * This software is distributed under the terms of the BedRock Open-Source License.
 * See the LICENSE-BedRock file in the repository root for details.
 *)
Require Import stdpp.countable.
From bedrock.prelude Require Import numbers list_numbers.

Section type.
  #[local] Set Primitive Projections.
  (** A generic wrapper for types isomorphic to N *)
  Record WrapN {Phant : Set} : Set := MkWrapN { unwrapN : N }.
End type.
Add Printing Constructor WrapN.

Arguments WrapN Phant : clear implicits.
Arguments MkWrapN {Phant} _ : assert.

Notation Build_WrapN := @MkWrapN (only parsing).

(* Using the wrapper means we define these instances/lemmas only once. *)

Lemma cancel_unwrapN {Phant} (x : WrapN Phant) : MkWrapN (unwrapN x) = x.
Proof. done. Qed.

(** This instance is useful in combination with [Refine1_Cancel]. *)
#[global] Instance cancel_Build_WrapN_unwrapN {Phant} :
  Cancel eq (@MkWrapN Phant) unwrapN.
Proof. exact cancel_unwrapN. Qed.

#[global] Instance wrapN_eq_decision {Phant} : EqDecision (WrapN Phant).
Proof. solve_decision. Defined.

#[global] Instance wrapN_countable {Phant} : Countable (WrapN Phant) :=
  inj_countable' unwrapN MkWrapN cancel_unwrapN.

#[global] Instance wrapN_inhabited {Phant} : Inhabited (WrapN Phant) :=
  populate (MkWrapN 0).

#[global] Instance unwrapN_inj Phant : Inj eq eq (@unwrapN Phant).
Proof. intros [] [] ?. by simplify_eq/=. Qed.

#[global] Instance MkWrapN_inj Phant : Inj eq eq (@MkWrapN Phant).
Proof. by intros ?? [=]. Qed.

#[global] Declare Scope wrapN_scope.
#[global] Delimit Scope wrapN_scope with wrapN.
(* ^ it would be nicer to have one delimiting key per instantiation of WrapN,
    but that doesn't seem possible? *)
#[global] Bind Scope wrapN_scope with WrapN.

Module Import wrapN_notations.
  Class WrapNAdd {T U R : Set} := wrapN_add : T -> U -> R.
  #[global] Instance wrapNN_add {Phant} : @WrapNAdd (WrapN Phant) N (WrapN Phant) :=
    fun w n => MkWrapN (unwrapN w + n).
  #[global] Instance NwrapN_add {Phant} : @WrapNAdd N (WrapN Phant) (WrapN Phant) :=
    fun n w => MkWrapN (n + unwrapN w).
  #[global] Instance wrapNwrapN_add {Phant} : @WrapNAdd (WrapN Phant) (WrapN Phant) (WrapN Phant) :=
    fun w1 w2 => MkWrapN (unwrapN w1 + unwrapN w2).
  Notation "0" := (MkWrapN 0) (only parsing) : wrapN_scope.
  Infix "+" := wrapN_add (only parsing) : wrapN_scope.
End wrapN_notations.

#[global] Arguments wrapNN_add {_} _ _ /.
#[global] Arguments NwrapN_add {_} _ _ /.
#[global] Arguments wrapNwrapN_add {_} _ _ /.
#[global] Arguments wrapN_add {T U R _} _ _ /.

Section seqW.
  Context {Phant : Set}.
  Implicit Types (w : WrapN Phant).
  #[local] Open Scope wrapN_scope.

  Lemma wrapN_add_0N_l w : 0%N + w = w.
  Proof. by rewrite /= N.add_0_l. Qed.
  Lemma wrapN_add_0w_l w : 0 + w = w.
  Proof. by rewrite /= N.add_0_l. Qed.
  Lemma wrapN_add_0N_r w : w + 0%N = w.
  Proof. by rewrite /= N.add_0_r. Qed.
  Lemma wrapN_add_0w_r w : w + 0 = w.
  Proof. by rewrite /= N.add_0_r. Qed.

  Definition wrapN_succ w : WrapN Phant :=
    MkWrapN $ N.succ $ unwrapN w.

  Lemma unwrapN_succ_inj w : unwrapN (wrapN_succ w) = N.succ (unwrapN w).
  Proof. done. Qed.

  Definition seqW w (sz : N) : list (WrapN Phant) :=
    MkWrapN <$> seqN (unwrapN w) sz.

  Lemma cons_seqW len start :
    start :: seqW (wrapN_succ start) len = seqW start (N.succ len).
  Proof. by rewrite /seqW -cons_seqN. Qed.

  (* Lifts [seqN_S_end_app] *)
  Lemma seqW_S_end_app w n : seqW w (N.succ n) = seqW w n ++ [w + n].
  Proof. by rewrite /seqW seqN_S_end_app fmap_app. Qed.

  Lemma cons_seqW' [len start] sstart :
    sstart = wrapN_succ start ->
    start :: seqW sstart len = seqW start (N.succ len).
  Proof. move->. apply cons_seqW. Qed.

  Lemma seqW_S_end_app' [w n] sn :
    sn = N.succ n ->
    seqW w sn = seqW w n ++ [w + n].
  Proof. move->. apply seqW_S_end_app. Qed.
End seqW.

Module Type wrapper.
  Variant Phant : Set :=.	(** i.e., empty *)

  Definition t := WrapN Phant.

  (** Beware this is not actually (super)global:
  https://github.com/coq/coq/issues/14988 *)
  #[global] Bind Scope wrapN_scope with t.

  Definition of_N : N -> t := MkWrapN.
  Definition to_N : t -> N := unwrapN.
  Lemma of_to_N x : of_N (to_N x) = x.
  Proof. apply cancel_unwrapN. Qed.
  Lemma to_of_N x : to_N (of_N x) = x.
  Proof. apply (inj of_N). by rewrite of_to_N. Qed.

End wrapper.

Module Type succ_wrapper (Import W : wrapper).
  Notation succ := (wrapN_succ (Phant := Phant) : t -> t) (only parsing).
  Notation seqW := (seqW (Phant := Phant) : (t -> N -> list t)) (only parsing).
End succ_wrapper.

(**
Example usage for [wrapper]:
Module your_type.
  (* Include wrapper. *) (* Or *)
  Include val_wrapper. (* Using [val_wrap.v] *)

  Include succ_wrapper. (* If appropriate for your type. *)
End your_type.

(* Workaround https://github.com/coq/coq/issues/14988 *)
#[global] Bind Scope wrapN_scope with your_type.t.

 *)


Require Import Poulet4.P4light.Syntax.P4defs.
Require Import Poulet4.P4light.Syntax.P4Notations.
Require Import Coq.Program.Program.
Require Import Poulet4.Utils.Maps.
Require Import ProD3.examples.bloomfilter.p4ast.
Require Import ProD3.examples.sbf.ConFilter.
Require Import ProD3.examples.sbf.general_bf.
Require Import ProD3.examples.bloomfilter.switch.
Require Import ProD3.examples.bloomfilter.verif.

Require Import VST.zlist.Zlist.
Require Import Coq.micromega.Lia.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Import ListNotations.
Open Scope list_scope.
Open Scope string_scope.

Require Import ProD3.core.Coqlib.

Definition process' (bf : bloomfilter_state) (p : Z * port) :=
  let (data, pt) := p in
  match pt with
  | port_int =>
      (general_bf.add CRC_pads bf data, (Some (data, port_ext)))
  | port_ext =>
      if general_bf.query (`CRC_pads) bf data then
        (bf, Some (data, port_int))
      else
        (bf, None)
  end.

Definition bf_encode (es : V1ModelTarget.extern_state) (bf : bloomfilter_state) :=
  PathMap.get ["bloom0"] es = Some (reg_encode (Znth 0 (` (blooms bf))))
  /\ PathMap.get ["bloom1"] es = Some (reg_encode (Znth 1 (` (blooms bf))))
  /\ PathMap.get ["bloom2"] es = Some (reg_encode (Znth 2 (` (blooms bf)))).

Open Scope Z_scope.

Lemma process_packet_prop : forall es bf p es' p',
  process_packet ge custom_metadata_t es p es' p' ->
  bf_encode es bf ->
  exists bf',
    process' bf p = (bf', p') /\ bf_encode es' bf'.
Proof.
  intros.
  inv H.
  inv H1. inv H2.
  apply (proj1 bloomfilter_body (port_to_Z in_port) data bf) in H6; auto.
  2 : {
    destruct in_port; simpl; lia.
  }
  2 : {
    clear H5.
    split. {
      simpl. unfold AssertionLang.arg_denote, AssertionLang.arg_satisfies.
      destruct in_port; Tactics.Forall2_sval_refine.
    }
    split. {
      repeat constructor.
    }
    destruct H0 as [? []].
    repeat constructor.
    - red; simpl; destruct (PathMap.get ["bloom0"] es); inv H; auto.
    - red; simpl; destruct (PathMap.get ["bloom1"] es); inv H0; auto.
    - red; simpl; destruct (PathMap.get ["bloom2"] es); inv H1; auto.
  }
  destruct H6 as  [? [? []]].
  exists (fst (process (port_to_Z in_port) data bf)).
  split.
  2 : {
    unfold encode_bloomfilter_state, AssertionNotations.EXT, id in H6.
    destruct H6 as [[? [? ?]] []]. unfold blooms. simpl.
    repeat constructor.
    - red in H6; simpl in H6; destruct (PathMap.get ["bloom0"] es'); inv H6; auto.
    - red in H7; simpl in H7; destruct (PathMap.get ["bloom1"] es'); inv H7; auto.
    - red in H8; simpl in H8; destruct (PathMap.get ["bloom2"] es'); inv H8; auto.
  }
  assert (data' = data
    /\ out_port_to_Z out_port = snd (process (port_to_Z in_port) data bf)).
  {
    inv H.
    split.
    - clear -H3 H4 H10.
      subst hdr'.
      inv H10. inv H1. destruct H5.
      clear -H3 H4 H0. inv H0. inv H7. destruct H2.
      clear -H3 H4 H0.
      apply Members.sval_refine_to_loptbool_eq in H0; eauto.
    - inv H12. inv H13.
      clear -H5 H11.
      apply Members.sval_refine_get with (f := "egress_spec") in H11.
      simpl in H11.
      rewrite H5 in H11.
      apply Members.sval_refine_to_loptbool_eq in H11; eauto.
      + destruct in_port; simpl.
        2 : destruct (query [CRC_pad0; CRC_pad1; CRC_pad2] bf data); simpl.
        all : lia.
      + destruct out_port as [[] | ]; simpl.
        all : lia.
  }
  clear -H7.
  destruct H7; subst.
  unfold process, process' in *.
  destruct in_port; destruct out_port as [[] | ];
    simpl in *; try solve [inv H0]; auto;
    destruct (query [CRC_pad0; CRC_pad1; CRC_pad2] bf data);
    try solve [inv H0]; auto.
Qed.

Definition packet1: BinNums.Z * port := (Z0, port_int).
Definition packet2: BinNums.Z * port := (1%Z, port_ext).

Program Definition test_row: row NUM_ENTRY := Zrepeat false NUM_ENTRY.

Program Definition test_frame: frame 3 NUM_ENTRY := Zrepeat test_row 3.

Lemma Test1: forall st' output,
     @process_packets _ _ ge custom_metadata_t  init_es  [packet1;packet2] st' output ->
     bf_encode st' (add CRC_pads test_frame 0) /\
    output = [Some (0, port_ext); None].
Proof.
intros. inv H.
assert (Bf: bf_encode init_es test_frame).
{ split. reflexivity. split; reflexivity. }
eapply process_packet_prop in H3;
  [clear Bf; destruct H3 as [bf1 [Proc1 Bf1]] | eassumption].
inv Proc1. inv H6.
eapply process_packet_prop in H2; [ clear Bf1; destruct H2 as [bf2 [Proc2 Bf2]] | eassumption]. inv H5. unfold packet2 in Proc2. cbn [process'] in Proc2.
cut (query (`CRC_pads) (add CRC_pads test_frame 0) 1 = false).
- intros. rewrite H in Proc2. inv Proc2. split; auto.
- unfold query, frame_query, add, frame_insert, row_insert, Utils.map2, row_query.
  simpl. rewrite !Znth_upd_Znth_diff; [|vm_compute; lia..].
  rewrite !Znth_Zrepeat; [| apply CRC_range..].
  now simpl.
Qed.

Definition packet1': BinNums.Z * port := (Z0, port_int).
Definition packet2': BinNums.Z * port := (Z0, port_ext).

Lemma Test2: forall es' output,
     @process_packets _ _ ge custom_metadata_t  init_es  [packet1';packet2'] es' output ->
     bf_encode es' (add CRC_pads test_frame 0) /\
     output = [Some (0, port_ext); Some (0, port_int)].
Proof.
intros. inv H.
assert (Bf: bf_encode init_es test_frame).
{ split. reflexivity. split; reflexivity. }
eapply process_packet_prop in H3;
  [ clear Bf; destruct H3 as [bf1 [Proc1 Bf1]] |eassumption].
inv Proc1. inv H6.
eapply process_packet_prop in H2;
  [ clear Bf1; destruct H2 as [bf2 [Proc2 Bf2]] | eassumption]. inv H5.
unfold packet2' in Proc2. cbn [process'] in Proc2.
cut (query (`CRC_pads) (add CRC_pads test_frame 0) 0 = true).
- intros. rewrite H in Proc2. inv Proc2. split; auto.
- apply bf_add_query_true. simpl.
  do 3 (constructor; [intro; apply CRC_range |]). constructor.
Qed.

Fixpoint multi_process (bf : bloomfilter_state) (l :list (Z * port)): bloomfilter_state * list (option (Z * port)) :=
  match l with
     nil => (bf, nil)
  | h::t => match process' bf h with
            (bf1, out) => match multi_process bf1 t with
                           (bf2, out2) => (bf2, out::out2)
                          end
            end
  end.

Lemma multi_process_length: forall l bf bf2 out, multi_process bf l = (bf2, out) -> length out = length l.
Proof. induction l; simpl; intros. inv H; trivial.
destruct (process' bf a). remember (multi_process f l) as x; symmetry in Heqx; destruct x. inv H.
apply IHl in Heqx. simpl; rewrite Heqx; trivial.
Qed.

Lemma multi_process_app_inv: forall l1 l2 bf bf2 out, multi_process bf (l1++l2) = (bf2, out) ->
      exists bf1 out1 out2, multi_process bf l1 = (bf1, out1) /\ multi_process bf1 l2 = (bf2, out2) /\ out=out1++out2.
Proof.
  induction l1; simpl; intros.
+ do 3 eexists; split. reflexivity. split; eauto.
+ destruct (process' bf a) as [bf0 out0].
  specialize (IHl1 l2 bf0).
  remember ( multi_process bf0 (l1 ++ l2)) as mp; symmetry in Heqmp; destruct mp. inv H.
  specialize (IHl1 _ _ (eq_refl _)). destruct IHl1 as [bf1 [out1 [out2 [MP1 [MP2 L]]]]]. subst.
  rewrite MP1. do 3 eexists; split. reflexivity. rewrite MP2. split; eauto.
Qed.

Lemma multi_process_prop : forall es bf p es' p',
  process_packets ge custom_metadata_t es p es' p' ->
  bf_encode es bf ->
  exists bf',
    multi_process bf p = (bf', p') /\ bf_encode es' bf'.
Proof. intros. generalize dependent bf. induction H; simpl; intros.
- exists bf; split; auto.
- eapply process_packet_prop in H. 2: eassumption.
  destruct H as [bf2 [K1 BF2]]; rewrite K1; clear K1.
  destruct (IHprocess_packets _ BF2) as [bf3 [K2 BF3]]. rewrite K2; clear K2.
  eexists; split. reflexivity. auto.
Qed.

Lemma process_packets_app_inv: forall l1 l2 es es2 output,
     @process_packets _ _ ge custom_metadata_t es (l1++l2) es2 output ->
      exists es1 output1 output2, output = output1 ++ output2 /\
     @process_packets _ _ ge custom_metadata_t es l1 es1 output1 /\
     @process_packets _ _ ge custom_metadata_t es1 l2 es2 output2.
Proof.
 intros l1. induction l1; simpl; intros.
+ do 3 eexists. split. 2:{ split. apply process_packets_nil. eassumption. }
  reflexivity.
+ inv H. apply IHl1 in H6; clear IHl1. destruct H6 as [es1 [out1 [out2 [X [PP1 PP2]]]]]; subst.
  do 3 eexists; split.
  2:{ split. eapply process_packets_cons; eassumption. eassumption. }
  reflexivity.
Qed.

Lemma process_packets_app_inv_encode: forall l1 l2 es es2 output bf,
    @process_packets _ _ ge custom_metadata_t es (l1++l2) es2 output ->
    bf_encode es bf ->
      exists es1 output1 output2 bf1 bf2, output = output1 ++ output2 /\
     @process_packets _ _ ge custom_metadata_t es l1 es1 output1 /\ multi_process bf l1 = (bf1, output1) /\ bf_encode es1 bf1 /\
     @process_packets _ _ ge custom_metadata_t es1 l2 es2 output2 /\ multi_process bf1 l2 = (bf2, output2) /\ bf_encode es2 bf2.
Proof.
  intros. apply process_packets_app_inv in H.
  destruct H as [es1 [out1 [out2 [Hout [P1 P2]]]]].
  destruct (multi_process_prop _ _ _ _ _  P1 H0) as [bf1 [PR1 BF1]].
  destruct (multi_process_prop _ _ _ _ _  P2 BF1) as [bf2 [PR2 BF2]].
  do 5 eexists; split. apply Hout.
  split. eassumption.
  split. eassumption.
  split. eassumption.
  split. eassumption.
  split. eassumption. eassumption.
Qed.

Lemma process_packets_length: forall l es1 es2 output,
     @process_packets _ _ ge custom_metadata_t es1 l es2 output ->
      length output = length l.
Proof. intros. induction H; simpl. trivial. f_equal; trivial. Qed.

Lemma CRC_pads_in_range:
  Forall (hash_in_range NUM_ENTRY) (`CRC_pads).
Proof.
  unfold CRC_pads. simpl. do 3 (constructor; [intro; apply CRC_range |]). constructor.
Qed.

Lemma multi_process_firewall_aux: forall {l bf z bf1 bf' a out2 out1},
process' (add CRC_pads bf z) a = (bf1, out1) ->
multi_process bf1 l = (bf', out2) ->
query (`CRC_pads) bf' z = true.
Proof.
induction l; simpl; intros.
- inv H0. destruct a. destruct p; simpl in H.
  + inv H. rewrite add_comm. apply bf_add_query_true. apply CRC_pads_in_range.
  + destruct (query [CRC_pad0; CRC_pad1; CRC_pad2]
                (add CRC_pads bf z) z0);
      inv H; apply bf_add_query_true; apply CRC_pads_in_range.
- remember (process' bf1 a) as x; symmetry in Heqx; destruct x as [bf3 out3].
  remember (multi_process bf3 l) as y; symmetry in Heqy; destruct y as [bf4 out4].
  inv H0. destruct a0 as [zz q]. destruct q.
  + simpl in H. rewrite add_comm in H. inv H. eapply IHl; eauto.
  + simpl in H.
    remember (query [CRC_pad0; CRC_pad1; CRC_pad2]
                (add CRC_pads bf z) zz) as u;
      symmetry in Hequ; destruct u; inv H; eauto.
Qed.

Lemma multi_process_firewall_endpoints z: forall l bf bf' out,
multi_process bf ((z, port_int)::l++[(z, port_ext)]) = (bf', out) ->
exists m, out = (Some (z, port_ext)::m++[Some (z, port_int)]).
Proof.
  induction l; simpl; intros.
  - change [CRC_pad0; CRC_pad1; CRC_pad2] with (`CRC_pads) in H.
    rewrite bf_add_query_true in H by (apply CRC_pads_in_range).
    inv H. exists (@nil(option (Z * port))). reflexivity.
  - remember (process' (add CRC_pads bf z) a) as x; symmetry in Heqx; destruct x as [bf1 out1].
  remember (multi_process bf1 (l ++ [(z, port_ext)])) as y; symmetry in Heqy; destruct y. inv H.
  apply multi_process_app_inv in Heqy. destruct Heqy as [bf2 [out2 [out3 [MP1 [MP2 X]]]]]. subst l0.
  simpl in MP2.
  remember (query [CRC_pad0; CRC_pad1; CRC_pad2] bf2 z). destruct b.
  + inv MP2. exists (out1::out2). simpl; trivial.
  + change [CRC_pad0; CRC_pad1; CRC_pad2] with (`CRC_pads) in Heqb.
    rewrite (multi_process_firewall_aux Heqx MP1) in Heqb. discriminate.
Qed.

Lemma multi_process_firewall {l1 l2 l3 bf bf' out z}:
  multi_process bf (l1++(z, port_int)::l2++[(z, port_ext)]++l3) = (bf', out) ->
exists m1 m2 m3, out = m1++(Some (z, port_ext))::m2++[Some (z, port_int)]++m3 /\
      length m1=length l1 /\ length m2 = length l2 /\ length m3=length l3.
Proof.
  intros.
  destruct (multi_process_app_inv _ _ _ _ _  H) as [bf1 [m1 [out1 [P1 [Ptail1 X]]]]]; subst out; clear H.
  specialize (multi_process_app_inv ((z, port_int) :: l2 ++ [(z, port_ext)]) l3 bf1 bf' out1). intros.
simpl in H. simpl in Ptail1. rewrite <- app_assoc in H. specialize (H Ptail1); clear Ptail1.
destruct H as [bf3 [out2 [out3 [ST [P3 Hout]]]]]; subst out1.
remember (multi_process (add CRC_pads bf1 z) (l2 ++ [(z, port_ext)]) ) as x; symmetry in Heqx; destruct x.
inv ST.
specialize (multi_process_firewall_endpoints z l2 bf1). simpl; intros.
rewrite Heqx in H. destruct (H _ _ (eq_refl _)) as [m2 M2]; clear H.
inv M2. exists m1, m2, out3. rewrite <- app_assoc. simpl. split. trivial.
apply multi_process_length in P1. split; trivial.
apply multi_process_length in P3. split; trivial.
apply multi_process_length in Heqx. rewrite 2 app_length in Heqx. simpl in Heqx. lia.
Qed.

Lemma process_packets_firewall {l1 l2 l3 es es' out z bf}:
      process_packets ge custom_metadata_t es (l1++(z, port_int)::l2++[(z, port_ext)]++l3) es' out -> bf_encode es bf ->
  exists bf', bf_encode es' bf' /\
  exists m1 m2 m3, out = m1++(Some (z, port_ext))::m2++[Some (z, port_int)]++m3 /\
      length m1=length l1 /\ length m2 = length l2 /\ length m3=length l3.
Proof.
  intros.
  destruct (multi_process_prop _ _ _ _ _ H H0) as [bf' [MP BF']].
  exists bf'; split; [trivial.. |].
  apply (multi_process_firewall MP).
Qed.

(*
(*intermediate property, likely to be deleted eventally*)
Lemma Firewall': forall l1 l2 l3 es es' output bf,
     @process_packets _ _ ge custom_metadata_t es (l1++packet1'::l2++packet2'::l3) es' output -> bf_encode es bf ->
     exists out1 out2 out3 act1 act2,
     output = out1++act1::out2++act2::out3 /\
     length out1 = length l1 /\ length out2 = length l2 /\ length out3 = length l3.
Proof. intros.
  destruct (process_packets_app_inv_encode _ _ _ _ _ _ H H0) as [es1 [out1 [tail1 [bf1 [bftail [Hout [P1 [MP1 [BF1 [Tail1 [MTail1 BFtail1]]]]]]]]]]]; subst.
  clear H.
  apply process_packets_length in P1. clear MTail1 MP1. (*for now*)
  exists out1; rewrite P1.
  inv Tail1.
  destruct (process_packet_prop _ _ _ _ _ H3 BF1) as [bf2 [PR2 BF2]]. clear H3.
  destruct (process_packets_app_inv_encode _ _ _ _ _ _ H6 BF2) as [es3 [out2 [tail2 [bf3 [bftail3 [Hout [P2 [MP3 [BF3 [Tail3 [MTail3 BFtail3]]]]]]]]]]]; subst.
  clear H6.
  apply process_packets_length in P2. clear MTail3 MP3. (*for now*)
  exists out2; rewrite P2.
  inv Tail3.
  destruct (process_packet_prop _ _ _ _ _ H3 BF3) as [bf4 [PR4 BF4]]. clear H3.
  specialize (process_packets_length _ _ _ _ H6); intros.
  exists ps'; rewrite H.
  do 2 eexists. split. reflexivity. split; eauto.
Qed.
Require Import VST.zlist.Zlist.

Lemma app_inv {A}: forall (l1 l2 m1 m2:list A), l1++l2 = m1++m2 -> length l1=length m1 -> l1=m1 /\  l2=m2.
Proof.
induction l1; simpl; intros.
+ destruct m1; inv H0. split; trivial.
+ destruct m1; inv H0. inv H. destruct (IHl1 _ _ _ H3 H2); subst. split; trivial.
Qed.

Lemma multi_process_firewall_nth n m l bf bf' out z (H: (n<m<length l)%nat):
      multi_process bf l = (bf', out) ->
      nth_error l n = Some (z, port_int) -> nth_error l m = Some (z, port_ext) ->
      nth_error l n = Some (z, port_ext) /\ nth_error l m = Some (z, port_int).
Proof. intros.
destruct (@multi_process_firewall (firstn n l) (firstn m (skipn (S n) l)) (skipn (S (S (m+n))) l) bf bf' out z)
  as [m1 [m2 [m3 [M [M1 [M2 M3]]]]]].
+ assert (L: l = (firstn n l ++ (z, port_int) :: (firstn m (skipn (S n) l)) ++ [(z, port_ext)] ++ skipn (S (S (m + n))) l)).
  { clear H0. apply nth_error_split in H1. destruct H1 as [l1 [l2 [Hl Len1]]].
    specialize (firstn_skipn n l); intros X. rewrite <- X at 1. f_equal. symmetry in X.
    assert (Datatypes.length l1 = Datatypes.length (firstn n (l1 ++ (z, port_int) :: l2))).
    {  rewrite firstn_length, app_length; simpl. rewrite Nat.min_l; trivial. lia. }
    rewrite Hl in X. destruct (app_inv  _ _ _ _ X H0). clear X.
    erewrite (skipn_cons (S n)). intros.
Search app length.

 subst.  Search nth_error app. rewrite <-(firstn_skipn n l) at 1. f_equal.
    intros L.  rewrite <- L at 1. firstn_skipnSearch firstn app skipn.
  rewrite <- L; trivial.

 Search nth_error.
 ++m3 /\

Definition DummyEntry: (Z * port) := (0, port_int).

Lemma multi_process_firewall_nth n m l bf bf' out z (H: (n<m<length l)%nat):
      multi_process bf l = (bf', out) ->
      nth n l DummyEntry = (z, port_int) ->
      nth m l DummyEntry = (z, port_ext) ->
      nth n l DummyEntry = (z, port_ext) /\ nth m l DummyEntry = (z, port_int).
Proof. Search nth_error.
 ++m3 /\
      length m1=length l1 /\ length m2 = length l2 /\ length m3=length l3.
Search length.
Check nth.
multi_process bf (l1++(z, port_int)::l2++[(z, port_ext)]++l3) = (bf', out)
   X].

Search process_packets.
 destruct (multi_process_app_inv _ _ _ _ _  H) as [bf1 [m1 [out1 [P1 [Ptail1 X]]]]]; subst out; clear H.
Proof. intros. specialize (multi_process_app_inv ((z, port_int) :: l2 ++ [(z, port_ext)]) l3 bf1 bf' out1). intros.
simpl in H. simpl in Ptail1. rewrite <- app_assoc in H. specialize (H Ptail1); clear Ptail1.
destruct H as [bf3 [out2 [out3 [ST [P3 Hout]]]]]; subst out1.
remember (multi_process (add Z Z.eqb CRC_pad0 CRC_pad1 CRC_pad2 bf1 z) (l2 ++ [(z, port_ext)]) ) as x; symmetry in Heqx; destruct x.
inv ST.
specialize (multi_process_query_endpoints z l2 bf1). simpl; intros.
rewrite Heqx in H. destruct (H _ _ (eq_refl _)) as [m2 M2]; clear H.
inv M2. exists m1, m2, out3. rewrite <- app_assoc. simpl. split. trivial.
apply multi_process_length in P1. split; trivial.
apply multi_process_length in P3. split; trivial.
apply multi_process_length in Heqx. rewrite 2 app_length in Heqx. simpl in Heqx. lia.
Qed.

Require Import VST.zlist.Zlist.

Lemma multi_process_query' n m l bf bf' out z (H: n<m):
      multi_process bf l = (bf', out) ->
      Znth n l = (z, port_int) ->
      Znth m l = (z, port_ext) ->
      Znth n l = (z, port_ext) /\ Znth m l = (z, port_int). ++m3 /\
      length m1=length l1 /\ length m2 = length l2 /\ length m3=length l3.
Search Datatypes.length app. split; trivial.

*)


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O P A B C I C1 C2 : Universe, ((wd_ A I /\ (wd_ B I /\ (wd_ A B /\ (wd_ B O /\ (wd_ A O /\ (wd_ B C /\ (wd_ A C /\ (wd_ O P /\ (wd_ O C2 /\ (wd_ C1 C2 /\ (wd_ O C1 /\ (col_ C1 C2 I /\ (col_ B C1 C2 /\ (col_ C1 O C2 /\ col_ A I B)))))))))))))) -> col_ A B O)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime P A B C A1 B1 C1 D1 C1prime M D1prime N : Universe, ((wd_ O E /\ (wd_ P B /\ (wd_ A B /\ (wd_ O M /\ (wd_ M C1 /\ (wd_ O C1 /\ (wd_ C1 C1prime /\ (wd_ O C1prime /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ P A /\ (wd_ A C /\ (wd_ P C /\ (wd_ C B /\ (wd_ C1prime A1 /\ (wd_ O A1 /\ (wd_ O D1 /\ (wd_ O D1prime /\ (wd_ O B1 /\ (wd_ M C1prime /\ (wd_ N O /\ (wd_ D1 N /\ (wd_ D1 D1prime /\ (wd_ N D1prime /\ (wd_ A1 Eprime /\ (col_ P A B /\ (col_ P C B /\ (col_ O E A1 /\ (col_ O E B1 /\ (col_ O E C1 /\ (col_ O E D1 /\ (col_ O M N /\ (col_ N D1 D1prime /\ (col_ M C1 C1prime /\ (col_ O C1prime D1prime /\ (col_ O A1 C1 /\ col_ O C1 D1)))))))))))))))))))))))))))))))))))) -> col_ P A C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Lia.
Require Import RelationClasses.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Loc.

Require Import Event.
Require Import Time.
From PromisingLib Require Import Language.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import MemoryFacts.
Require Import TView.
Require Import Local.
Require Import Thread.

Set Implicit Arguments.

Lemma write_step_promise
      lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind
      (STEP: Local.write_step lc1 sc1 mem1 loc from to val releasedm released ord lc2 sc2 mem2 kind)
      (PROMISES: (Local.promises lc1) = Memory.bot):
  (Local.promises lc2) = Memory.bot.
Proof.
  inv STEP. rewrite PROMISES in *. s.
  apply Memory.ext. i. rewrite Memory.bot_get.
  inv WRITE.
  erewrite Memory.remove_o; eauto. condtac; ss. guardH o.
  inv PROMISE; ss.
  - erewrite Memory.add_o; eauto. condtac; ss.
    apply Memory.bot_get.
  - erewrite Memory.split_o; eauto. repeat condtac; ss.
    + guardH o0. des. subst.
      exploit Memory.split_get0; try exact PROMISES0; eauto. i. des.
      rewrite Memory.bot_get in *. congr.
    + apply Memory.bot_get.
  - erewrite Memory.lower_o; eauto. condtac; ss.
    apply Memory.bot_get.
Qed.

Lemma program_step_promise
      lang e
      st1 lc1 sc1 mem1
      st2 lc2 sc2 mem2
      (STEP: Thread.program_step e (Thread.mk lang st1 lc1 sc1 mem1) (Thread.mk lang st2 lc2 sc2 mem2))
      (PROMISES: (Local.promises lc1) = Memory.bot):
  (Local.promises lc2) = Memory.bot.
Proof.
  inv STEP. inv LOCAL; ss; try by inv LOCAL0.
  - eapply write_step_promise; eauto.
  - eapply write_step_promise; eauto.
    inv LOCAL1. auto.
Qed.

Lemma closed_timemap_max_ts
      loc tm mem
      (CLOSED: Memory.closed_timemap tm mem):
  Time.le (tm loc) (Memory.max_ts loc mem).
Proof.
  specialize (CLOSED loc). des.
  eapply Memory.max_ts_spec. eauto.
Qed.

Lemma closed_timemap_max_full_ts
      loc tm mem mts
      (CLOSED: Memory.closed_timemap tm mem)
      (MAX: Memory.max_full_ts mem loc mts):
  Time.le (tm loc) mts.
Proof.
  specialize (CLOSED loc). des.
  eapply Memory.max_full_ts_spec; eauto.
Qed.

Lemma progress_promise_step
      lc1 sc1 mem1
      loc to val releasedm ord
      (LT: Time.lt (Memory.max_ts loc mem1) to)
      (WF1: Local.wf lc1 mem1)
      (MEM1: Memory.closed mem1)
      (SC1: Memory.closed_timemap sc1 mem1)
      (WF_REL: View.opt_wf releasedm)
      (CLOSED_REL: Memory.closed_opt_view releasedm mem1):
  exists promises2 mem2,
    Local.promise_step lc1 mem1 loc (Memory.max_ts loc mem1) to
                       (Message.full val (TView.write_released (Local.tview lc1) sc1 loc to releasedm ord))
                       (Local.mk (Local.tview lc1) promises2) mem2 Memory.op_kind_add.
Proof.
  exploit (@Memory.add_exists_max_ts
             mem1 loc to
             (Message.full val (TView.write_released (Local.tview lc1) sc1 loc to releasedm ord))); eauto.
  { econs. eapply TViewFacts.write_future0; eauto. apply WF1. }
  i. des.
  exploit Memory.add_exists_le; try apply WF1; eauto. i. des.
  hexploit Memory.add_inhabited; try apply x0; [viewtac|]. i. des.
  esplits. econs; eauto.
  - econs; eauto; try congr.
    + econs. unfold TView.write_released.
      viewtac; repeat (condtac; viewtac);
        (try by apply Time.bot_spec);
        (try by unfold TimeMap.singleton, LocFun.add; condtac; [refl|congr]);
        (try by left; eapply TimeFacts.le_lt_lt; [|eauto];
         eapply closed_timemap_max_ts; apply WF1).
      left. eapply TimeFacts.le_lt_lt; [|eauto].
      eapply closed_timemap_max_ts. apply Memory.unwrap_closed_opt_view; viewtac.
    + i. inv x0. inv ADD. clear DISJOINT MSG_WF CELL2.
      exploit Memory.get_ts; try exact GET. i. des.
      { subst. inv TO. }
      exploit Memory.max_ts_spec; try exact GET. i. des.
      eapply Time.lt_strorder. etrans; try exact TO.
      eapply TimeFacts.lt_le_lt; eauto.
  - econs. unfold TView.write_released. condtac; econs.
    viewtac;
      repeat condtac; viewtac;
        (try eapply Memory.add_closed_view; eauto);
        (try apply WF1).
    + viewtac.
    + erewrite Memory.add_o; eauto. condtac; eauto. ss. des; congr.
    + erewrite Memory.add_o; eauto. condtac; eauto. ss. des; congr.
Qed.

Lemma progress_read_step
      lc1 mem1
      loc ord
      (WF1: Local.wf lc1 mem1)
      (MEM1: Memory.closed mem1):
  exists val released lc2 mts,
    <<MAX: Memory.max_full_ts mem1 loc mts>> /\
    <<READ: Local.read_step lc1 mem1 loc mts val released ord lc2>>.
Proof.
  dup MEM1. inv MEM0.
  exploit (Memory.max_full_ts_exists); eauto. i. des.
  exploit (Memory.max_full_ts_spec); eauto. i. des.
  esplits; eauto. econs; eauto.
  econs; i; eapply Memory.max_full_ts_spec2; eauto; apply WF1.
Qed.

Lemma progress_read_step_cur
      lc1 mem1
      loc ord
      (WF1: Local.wf lc1 mem1)
      (MEM1: Memory.closed mem1):
  exists val released lc2,
    <<READ: Local.read_step lc1 mem1 loc ((TView.cur (Local.tview lc1)).(View.rlx) loc) val released ord lc2>>.
Proof.
  dup WF1. inv WF0. inv TVIEW_CLOSED. inv CUR.
  specialize (RLX loc). des.
  esplits. econs; eauto.
  econs; try apply TVIEW_WF; try refl.
Qed.

Lemma progress_write_step
      lc1 sc1 mem1
      loc to val releasedm ord
      (LT: Time.lt (Memory.max_ts loc mem1) to)
      (WF1: Local.wf lc1 mem1)
      (SC1: Memory.closed_timemap sc1 mem1)
      (MEM1: Memory.closed mem1)
      (WF_REL: View.opt_wf releasedm)
      (CLOSED_REL: Memory.closed_opt_view releasedm mem1)
      (PROMISES1: Ordering.le Ordering.strong_relaxed ord -> Memory.nonsynch_loc loc (Local.promises lc1)):
  exists released lc2 sc2 mem2,
    Local.write_step lc1 sc1 mem1 loc (Memory.max_ts loc mem1) to val releasedm released ord lc2 sc2 mem2 Memory.op_kind_add.
Proof.
  exploit progress_promise_step; eauto. i. des.
  exploit Local.promise_step_future; eauto. i. des. inv x0.
  exploit Memory.remove_exists; eauto.
  { inv PROMISE. erewrite Memory.add_o; try eexact PROMISES.
    condtac; eauto. ss. des; exfalso; apply o; eauto.
  }
  i. des.
  esplits. econs; eauto.
  econs; i; (try eapply TimeFacts.le_lt_lt; [|eauto]).
  apply Memory.max_ts_spec2. apply WF1.
Qed.

Lemma progress_write_step_split
      lc1 sc1 mem1
      loc from to msg val releasedm ord
      (GET: Memory.get loc to (Local.promises lc1) = Some (from, msg))
      (CONS: Time.lt ((TView.cur (Local.tview lc1)).(View.rlx) loc) to)
      (WF1: Local.wf lc1 mem1)
      (SC1: Memory.closed_timemap sc1 mem1)
      (MEM1: Memory.closed mem1)
      (WF_REL: View.opt_wf releasedm)
      (TS_REL: Time.le ((View.rlx (View.unwrap releasedm)) loc) from)
      (CLOSED_REL: Memory.closed_opt_view releasedm mem1)
      (PROMISES1: Ordering.le Ordering.strong_relaxed ord -> Memory.nonsynch_loc loc (Local.promises lc1)):
  exists released lc2 sc2 mem2,
    Local.write_step lc1 sc1 mem1 loc from (Time.middle from to) val releasedm
                     released ord lc2 sc2 mem2 (Memory.op_kind_split to msg).
Proof.
  exploit Memory.get_ts; try exact GET. i. des.
  { subst. inv WF1. rewrite BOT in GET. ss. }
  exploit (@Memory.split_exists
             (Local.promises lc1) loc from (Time.middle from to) to
             (Message.full val (TView.write_released (Local.tview lc1) sc1 loc (Time.middle from to) releasedm ord))
             msg);
    try apply Time.middle_spec; auto.
  { econs. eapply TViewFacts.write_future0; eauto. apply WF1. }
  i. des.
  exploit Memory.split_exists_le; try apply WF1; eauto. i. des.
  exploit Memory.split_get0; try exact x1. i. des.
  exploit Memory.remove_exists; try exact GET2. i. des.
  clear GET0 GET1 GET2 GET3.
  assert (TS: Time.le ((TView.cur (Local.tview lc1)).(View.rlx) loc) from).
  { destruct (TimeFacts.le_lt_dec ((TView.cur (Local.tview lc1)).(View.rlx) loc) from); ss.
    inv WF1. inv TVIEW_CLOSED. inv CUR.
    specialize (RLX loc). des.
    clear REL ACQ PLN.
    exploit PROMISES; try exact GET. intro x. i.
    exploit Memory.get_ts; try exact RLX. i. des.
    { subst. rewrite x4 in l. inv l. }
    exploit Memory.get_disjoint; [exact RLX|exact x|..]. i. des.
    { subst. timetac. }
    exfalso.
    eapply x6; econs; [|refl|..]; ss. econs. ss.
  }
  esplits. econs; eauto.
  - econs; ss.
    eapply TimeFacts.le_lt_lt; eauto.
    apply Time.middle_spec. ss.
  - econs; eauto. econs; eauto.
    econs. unfold TView.write_released. ss.
    condtac; ss; try by unfold TimeMap.bot; apply Time.bot_spec.
    unfold LocFun.add. condtac; ss.
    unfold TimeMap.join. condtac; ss.
    + unfold TimeMap.join, TimeMap.singleton.
      unfold LocFun.add, LocFun.init, LocFun.find.
      condtac; ss.
      repeat apply Time.join_spec; ss; try refl.
      * etrans; eauto. econs. apply Time.middle_spec; ss.
      * etrans; eauto. econs. apply Time.middle_spec; ss.
    + unfold TimeMap.join, TimeMap.singleton.
      unfold LocFun.add, LocFun.init, LocFun.find.
      condtac; ss.
      repeat apply Time.join_spec; ss; try refl.
      * etrans; eauto. econs. apply Time.middle_spec; ss.
      * inv WF1. inv TVIEW_WF. etrans; try eapply REL_CUR.
        etrans; eauto. econs. apply Time.middle_spec; ss.
Qed.

Lemma progress_fence_step
      lc1 sc1
      ordr ordw
      (PROMISES1: Ordering.le Ordering.strong_relaxed ordw -> Memory.nonsynch (Local.promises lc1)):
  exists lc2 sc2,
    Local.fence_step lc1 sc1 ordr ordw lc2 sc2.
Proof.
  esplits. econs; eauto.
Qed.


Set Automatic Coercions Import.

Require Import List.
Require Import c_util util list_util stability containers.
Require Import CSetoids CRreal.
Require Import flow.
Require concrete abstract.
Set Implicit Arguments.
Open Local Scope CR_scope.
Require Import EquivDec.

Module c := concrete.
Module a := abstract.

Section contents.

  Variable (chs: concrete.System) (ap: abstract.Space chs).

  Definition substantial_cont_trans (l: c.Location chs): relation (a.Region ap)
    := fun r r' => exists p q, p ∈ r /\ q ∈ r' /\ ~ q ∈ r /\ c.can_flow chs l p q.

  Hint Unfold substantial_cont_trans.

  Program Definition cont_sharing_overestimator_from_substantial_overestimator (x: overestimator substantial_cont_trans):
    a.sharing_transition_overestimator ap (@concrete.cont_trans _) :=
    fun y => map (pair (fst y)) (filter (fun z => (z == snd y) ||
	  overestimation_bool (x (fst y) (snd y) z)) exhaustive_list).
  Next Obligation. Proof with auto.
    split.
      apply NoDup_map...
        congruence.
      apply NoDup_filter...
      apply a.NoDup_regions...
    intros [l s] [H0 [[l0 s0] [[H1 H4] [H2 H5]]]].
    unfold util.flip, In, predicate_container in H2.
    destruct y as (l', r).
    apply (DN_bind (DN_decision (s ∈ r))).
    intro.
    simpl in H1, H2. repeat subst.
    destruct H3.
      apply DN_return.
      exists (l, r).
      split. split...
      apply in_map. apply in_filter...
      apply orb_true_intro.
      left. apply show_unsumbool. reflexivity.
    apply (DN_fmap (a.regions_cover ap _ _ H0)).
    intros [r' i].
    exists (l, r').
    split. split...
    apply in_map, in_filter...
    apply orb_true_intro.
    destruct (a.Region_eq_dec ap r r'); [left | right].
      apply show_unsumbool.
      rewrite e. reflexivity.
    apply overestimation_true.
    simpl.
    unfold substantial_cont_trans.
    eauto 20.
  Qed.

  Variable simple_overestimator: overestimator (abstract.cont_trans ap).

  Definition redundant (l: c.Location chs) (r r': abstract.Region ap) (H: r <> r'): Prop :=
    forall p, p ∈ r ->
      forall t, 0 <= t -> concrete.flow chs l p t ∈ r' ->
        concrete.flow chs l p t ∈ r.

  Variable under_redundant: underestimator redundant.

  (* Before we proceed to define the abstract continuous transition function,
   we first put the hints in a more convenient form in which the region
   inequality is integrated in the optionality: *)

  Definition hints (l: c.Location chs) (r r': abstract.Region ap):
    option (forall p, p ∈ r -> forall t, 0 <= t -> concrete.flow chs l p t ∈ r' -> concrete.flow chs l p t ∈ r) :=
    match r == r' with
    | left _ => None
    | right E => under_redundant l E
    end.

  Program Definition cont_trans l r r': overestimation (substantial_cont_trans l r r') :=
    (simple_overestimator l r r': bool) && negb (hints l r r').

  Hint Unfold abstract.cont_trans.

  Next Obligation. Proof with eauto 20.
    intros [x [x0 [H0 [H1 [H2 H3]]]]].
    apply andb_false_elim in H.
    destruct H.
      apply overestimation_false in e...
    destruct hints.
      destruct H3. destruct H. destruct x1.
      rewrite <- H3 in H2.
      apply H2.
      simpl proj1_sig.
      apply (i x H0 x1)...
        apply (CRnonNeg_le_zero x1)...
      rewrite H3...
    discriminate.
  Qed.

  (* This concludes the primary contents of this module. Now follow a few more
   notes and utilities about hints.

  First, note that this module takes hints as given, saying nothing about how
  clients are expected to actually construct them. Some utilities for that can
  be found in interval_spec.v. We /can/ however easily make things a bit
  easier by recognizing that there is a stronger notion of Hint that composes
  better.

  Hint is sufficiently strong to support the above development, but is actually rather
  weak. This is generally a good thing in interfaces, but Hint is so weak that
  when using abstraction parameter sets combined with param_prod (from
  abstract.v), hints for the component parameter sets don't necessarily translate
  into hints for the composite parameter set (whose regions are intersections of
  regions of the component parameter sets). After all, just because destination
  points in a destination region are contained in a source region in one
  set of abstraction parameters, doesn't mean this automatically also holds for
  intersections of these regions with regions from another set of abstraction
  parameters. (Todo: Shouldn't be hard to prove, though it could be a bit of work,
  since one would need to construct a counterexample concrete system.)

  However, in some cases, one can actually prove a stronger kind of Hint
  which /does/ support such "upward" conversion:
  *)

  Definition strong_redundant l (r r': a.Region ap) (H: r <> r'): Prop :=
    forall p: c.Point chs, p ∈ r ->
      forall t: Time, concrete.flow chs l p t ∈ r' -> t <= 0.

  (* Whereas Hint merely says that the destination point lies in the source region,
   StrongHint says that the flow duration is nonpositive. Since flow durations
   are always nonnegative, this means that the duration is zero. This then implies
   that the destination point /is/ the source point, which is a stronger property that
   is no longer relative to any particular set of abstraction parameters. Hence, we
   trivially get that these stronger kinds of hints are "upward" convertible. We will
   show this in a moment, but first show that StrongHints can easily be
   converted to Hints: *)

  Lemma weaken_hint l r r' (H: r <> r'): strong_redundant l H -> redundant l H.
  Proof with eauto.
    repeat intro.
    assert (t [=] 0). apply (CRle_def t 0)...
    rewrite H4, flow_zero...
  Qed.

  Definition weaken_hints (H: forall l r r' (H: r <> r'), option (strong_redundant l H)) l r r' (E: r <> r'): option (redundant l E) :=
    option_map (@weaken_hint l r r' E) (H l r r' E).

End contents.

(* For the sake of exposition (this result is not used anywhere else in the
development) we show that strong hints support "upward conversion". That is,
that a StrongHint for a set of abstraction parameters is convertible to a
StrongHint for the product of those abstraction parameters with another set of
abstraction parameters. *)

Section strong_upward.

  Variables
    (chs: concrete.System)
    (ap_x ap_y: abstract.Space chs).

  Definition ap := abstract.prod_space ap_x ap_y.

  Definition lift_strong_redundant (l: concrete.Location chs) (r r': abstract.Region ap) (H: fst r <> fst r') (H0: r <> r')
    (h: strong_redundant ap_x l H): strong_redundant ap l H0 :=
    fun p A t B => h _ (fst A) _ (fst B).

End strong_upward.