(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export sequents_tacs.
Require Export sequents_equality.
Require Export per_props_equality.
Require Export per_props_iff.
(*Require Export per_props4.*)
(** printing |- $\vdash$ *)
(** printing ->  $\rightarrow$ *)

(* !!MOVE *)
Lemma inhabited_approx {o} :
  forall lib (t1 t2 : @CTerm o),
    inhabited_type lib (mkc_approx t1 t2)
    <=> (t1) ~<~( lib)(t2).
Proof.
  introv.
  split; intro h.
  - unfold inhabited_type in h; exrepnd.
    rw <- @equality_in_approx in h0; sp.
  - unfold inhabited_type.
    exists (@mkc_axiom o).
    apply equality_in_approx; dands; spcast; auto;
    apply computes_to_valc_refl; eauto 3 with slow.
Qed.

(*
   H |- a <= b = c <= d

     By approxExtensionalEquality

     H |- a <= b <=> b <= a
 *)
Definition rule_approx_extensional_equality {o}
           (H : barehypotheses)
           (i : nat)
           (a b c d e : @NTerm o) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_equality (mk_approx a b) (mk_approx c d) (mk_uni i))))
    [ mk_baresequent H (mk_concl (mk_iff (mk_approx a b) (mk_approx c d)) e)
    ]
    [].

Lemma rule_approx_extensional_equality_true {o} :
  forall lib (H : barehypotheses) (i : nat)
         (a b c d e : @NTerm o),
    rule_true lib (rule_approx_extensional_equality H i a b c d e).
Proof.
  unfold rule_approx_extensional_equality, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  destseq; allsimpl; proof_irr; GC.

  assert (closed_extract H (mk_conclax (mk_equality (mk_approx a b) (mk_approx c b) (mk_uni i)))) as cs.
  clear hyp1.
  dwfseq; prove_seq; unfold covered; allrw subvars_prop; sp.

  exists cs.

  (* we now start proving the sequent *)
  vr_seq_true.

  lsubst_tac.
  rw @member_eq.
  rw <- @member_equality_iff.

  pose proof (teq_and_eq_if_equality
                lib
                (mk_uni i)
                (mk_approx a b)
                (mk_approx c d)
                s1 s2 H wT w1 w2 c1 c0 c2 c3 cT cT0) as h.
  lsubst_tac.
  apply h; auto; clear h.

  { apply tequality_mkc_uni. }

  { clear dependent s1.
    clear dependent s2.
    introv hf sim.

    vr_seq_true in hyp1.
    pose proof (hyp1 s1 s2 hf sim) as hyp; clear hyp1.
    exrepnd.
    lsubst_tac.
    apply equality_in_iff in hyp1; exrepnd; spcast.
    pose proof (hyp6 mkc_axiom mkc_axiom) as h1.
    pose proof (hyp1 mkc_axiom mkc_axiom) as h2.
    clear hyp1 hyp4 hyp5 hyp6.
    allrw <- @equality_in_approx.
    apply tequality_mkc_iff in hyp0; repnd.
    allrw @tequality_mkc_approx.
    allrw @inhabited_approx.

    clear hyp2 hyp3.

    apply mkc_approx_equality_in_uni.
    split; intro h.

    - autodimp h1 hyp; repnd; dands; auto;
      try (spcast; apply computes_to_valc_refl; eauto 3 with slow).
      autodimp hyp4 hyp.
      apply hyp4; auto.

    - autodimp hyp0 hyp.

      { exists (@mkc_id o).
        apply equality_in_fun; dands.

        - apply tequality_mkc_approx; sp.

        - introv inh.
          apply tequality_mkc_approx; sp.

        - introv ea.
          allrw <- @equality_in_approx; repnd.
          dands; tcsp.

          + autodimp h1 hyp; repnd; dands; auto;
            try (spcast; apply computes_to_valc_refl; eauto 3 with slow).

          + spcast.
            allrw @computes_to_valc_iff_reduces_toc; repnd; dands; auto.
            eapply reduces_toc_trans;[apply reduces_toc_apply_id|]; auto.

          + spcast.
            allrw @computes_to_valc_iff_reduces_toc; repnd; dands; auto.
            eapply reduces_toc_trans;[apply reduces_toc_apply_id|]; auto.
      }

      apply hyp0 in h; clear hyp0.
      autodimp h2 hyp; repnd; dands; auto; spcast;
      apply computes_to_valc_refl; eauto 3 with slow.
  }
Qed.

(*
   H |- a ~ b = c ~ d

     By cequivExtensionalEquality

     H |- a ~ b <=> b ~ a
 *)
Definition rule_cequiv_extensional_equality {o}
           (H : barehypotheses)
           (i : nat)
           (a b c d e : @NTerm o) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_equality (mk_cequiv a b) (mk_cequiv c d) (mk_uni i))))
    [ mk_baresequent H (mk_concl (mk_iff (mk_cequiv a b) (mk_cequiv c d)) e)
    ]
    [].

Lemma rule_cequiv_extensional_equality_true {o} :
  forall lib (H : barehypotheses) (i : nat)
         (a b c d e : @NTerm o),
    rule_true lib (rule_cequiv_extensional_equality H i a b c d e).
Proof.
  unfold rule_cequiv_extensional_equality, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  destseq; allsimpl; proof_irr; GC.

  assert (closed_extract H (mk_conclax (mk_equality (mk_cequiv a b) (mk_cequiv c b) (mk_uni i)))) as cs.
  clear hyp1.
  dwfseq; prove_seq; unfold covered; allrw subvars_prop; sp.

  exists cs.

  (* we now start proving the sequent *)
  vr_seq_true.

  lsubst_tac.
  rw @member_eq.
  rw <- @member_equality_iff.

  pose proof (teq_and_eq_if_equality
                lib
                (mk_uni i)
                (mk_cequiv a b)
                (mk_cequiv c d)
                s1 s2 H wT w1 w2 c1 c0 c2 c3 cT cT0) as h.
  lsubst_tac.
  apply h; auto; clear h.

  { apply tequality_mkc_uni. }

  { clear dependent s1.
    clear dependent s2.
    introv hf sim.

    vr_seq_true in hyp1.
    pose proof (hyp1 s1 s2 hf sim) as hyp; clear hyp1.
    exrepnd.
    lsubst_tac.
    apply equality_in_iff in hyp1; exrepnd; spcast.
    pose proof (hyp6 mkc_axiom mkc_axiom) as h1; clear hyp6.
    pose proof (hyp1 mkc_axiom mkc_axiom) as h2; clear hyp1.
    clear hyp2 hyp3 hyp4 hyp5.
    allrw @equality_in_mkc_cequiv.
    apply tequality_mkc_iff in hyp0; repnd.
    allrw @tequality_mkc_cequiv.
    allrw @inhabited_cequiv.

    apply mkc_cequiv_equality_in_uni.
    split; intro h.

    - autodimp hyp2 hyp; auto;[].
      apply hyp2.
      autodimp h1 hyp; repnd; dands; auto;
      try (spcast; apply computes_to_valc_refl; eauto 3 with slow).

    - autodimp hyp0 hyp.

      { exists (@mkc_id o).
        apply equality_in_fun; dands.

        - apply tequality_mkc_cequiv; sp.

        - introv inh.
          apply tequality_mkc_cequiv; sp.

        - introv ea.
          allrw @equality_in_mkc_cequiv; repnd.
          dands; tcsp.

          + spcast.
            allrw @computes_to_valc_iff_reduces_toc; repnd; dands; auto.
            eapply reduces_toc_trans;[apply reduces_toc_apply_id|]; auto.

          + spcast.
            allrw @computes_to_valc_iff_reduces_toc; repnd; dands; auto.
            eapply reduces_toc_trans;[apply reduces_toc_apply_id|]; auto.

          + autodimp h1 hyp; repnd; dands; auto;
            try (spcast; apply computes_to_valc_refl; eauto 3 with slow).
      }

      apply hyp0 in h; clear hyp0.
      autodimp h2 hyp; repnd; dands; auto; spcast;
      apply computes_to_valc_refl; eauto 3 with slow.
  }
Qed.


(*===========================================================================
    Model for x86 registers
    Note that the EFL register (flags) is treated separately.
  ===========================================================================*)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype tuple.
Require Import bitsrep.

(* General purpose registers, excluding ESP *)
(*=NonSPReg *)
Inductive NonSPReg := EAX | EBX | ECX | EDX | ESI | EDI | EBP.
(*=End *)
Definition NonSPRegToNat r :=
  match r with EAX => 0 | ECX => 1 | EDX => 2 | EBX => 3 | EBP => 5 | ESI => 6 | EDI => 7 end.
Lemma NonSPRegToNat_inj : injective NonSPRegToNat. Proof. by case => //; case => //. Qed.
Canonical Structure NonSPRegEqMixin := InjEqMixin NonSPRegToNat_inj.
Canonical Structure NonSPRegEqType := Eval hnf in EqType _ NonSPRegEqMixin.

(* General purpose registers, including ESP *)
(*=Reg *)
Inductive Reg := nonSPReg (r: NonSPReg) | ESP.
(*=End *)
Coercion nonSPReg : NonSPReg >-> Reg.
Definition RegToNat r :=  match r with | ESP => 4 | nonSPReg r => NonSPRegToNat r end.
Lemma RegToNat_inj : injective RegToNat.
Proof. case => //; case => //; case => //; case => //. Qed.
Canonical Structure RegEqMixin := InjEqMixin RegToNat_inj.
Canonical Structure RegEqType := Eval hnf in EqType _ RegEqMixin.

(* All registers, including EIP but excluding EFL *)
(*=AnyReg *)
Inductive AnyReg := regToAnyReg (r: Reg) | EIP.
(*=End *)
Coercion regToAnyReg : Reg >-> AnyReg.
Definition AnyRegToNat r :=  match r with | EIP => 8 | regToAnyReg r => RegToNat r end.
Lemma AnyRegToNat_inj : injective AnyRegToNat.
Proof. case => //; case => //; case => //; case => //; case => //; case => //. Qed.
Canonical Structure AnyRegEqMixin := InjEqMixin AnyRegToNat_inj.
Canonical Structure AnyRegEqType := Eval hnf in EqType _ AnyRegEqMixin.

(* Segment registers *)
Inductive SegReg := CS | DS | SS | ES | FS | GS.

(* Standard numbering of registers *)
Definition natToReg n : option Reg :=
  match n return option Reg with
  | 0 => Some (EAX:Reg)
  | 1 => Some (ECX:Reg)
  | 2 => Some (EDX:Reg)
  | 3 => Some (EBX:Reg)
  | 4 => Some (ESP:Reg)
  | 5 => Some (EBP:Reg)
  | 6 => Some (ESI:Reg)
  | 7 => Some (EDI:Reg)
  | _ => None
  end.

Lemma roundtripReg : forall r, natToReg (RegToNat r) = Some r.
Proof. case. by case. done. Qed.

(* Reg is a choiceType and a countType *)
Definition Reg_countMixin := CountMixin roundtripReg.
Definition Reg_choiceMixin := CountChoiceMixin Reg_countMixin.
Canonical Reg_choiceType :=  Eval hnf in ChoiceType _ Reg_choiceMixin.
Canonical Reg_countType  :=  Eval hnf in CountType _ Reg_countMixin.

(* Reg is a finType *)
Lemma Reg_enumP :
  Finite.axiom [:: EAX:Reg; EBX:Reg; ECX:Reg; EDX:Reg; ESI:Reg; EDI:Reg; EBP:Reg; ESP].
Proof. case;  [by case | done]. Qed.

Definition Reg_finMixin := Eval hnf in FinMixin Reg_enumP.
Canonical Reg_finType   := Eval hnf in FinType _ Reg_finMixin.

(* Standard numbering of registers *)
Definition natToAnyReg n :=
  match natToReg n with
  | Some r => Some (regToAnyReg r)
  | None => match n with 8 => Some EIP | _ => None end
  end.

Lemma roundtripAnyReg : forall r, natToAnyReg (AnyRegToNat r) = Some r.
Proof. case. case; [case; by constructor | done]. done. Qed.

(* AnyReg is a choiceType and a countType *)
Definition AnyReg_countMixin := CountMixin roundtripAnyReg.
Definition AnyReg_choiceMixin := CountChoiceMixin AnyReg_countMixin.
Canonical AnyReg_choiceType := Eval hnf in ChoiceType _ AnyReg_choiceMixin.
Canonical AnyReg_countType  := Eval hnf in CountType  _ AnyReg_countMixin.

(* AnyReg is a finType *)
Lemma AnyReg_enumP :
  Finite.axiom [:: EAX:AnyReg; EBX:AnyReg; ECX:AnyReg;
                   EDX:AnyReg; ESI:AnyReg; EDI:AnyReg; EBP:AnyReg; ESP:AnyReg; EIP].
Proof. case; [case; [case; done | done] | done]. Qed.

Definition AnyReg_finMixin := Eval hnf in FinMixin AnyReg_enumP.
Canonical AnyReg_finType :=  Eval hnf in FinType _ AnyReg_finMixin.


Require Import Logic.Logic.
Require Import Logic.BasicProofRules.
Require Import Logic.Tactics.
Require Import Coq.Classes.Morphisms.

Local Open Scope HP_scope.

Definition Preserves (P : StateFormula) (A : ActionFormula) : Formula :=
  A -->> (P -->> next P).

Global Instance Proper_Preserves_lequiv :
  Proper (eq ==> lequiv ==> lequiv) Preserves.
Proof.
  morphism_intro. unfold Preserves.
  subst. rewrite H0. reflexivity.
Qed.

Global Instance Proper_Preserves_lentails :
  Proper (eq ==> lentails --> lentails) Preserves.
Proof.
  morphism_intro. unfold Preserves.
  subst. rewrite H0. reflexivity.
Qed.

Theorem Preserves_Or
  : forall (P Q : StateFormula) (S1 S2 : ActionFormula),
    Preserves P S1 //\\ Preserves Q S2
              |-- Preserves (P \\// Q) (P //\\ S1 \\// Q //\\ S2).
Proof.
  unfold Preserves.
  simpl; restoreAbstraction.
  intros.
  charge_intro.
  charge_assert (next P \\// next Q); [ | charge_intros; charge_assumption ].
  charge_cases; solve [ charge_left; charge_use; charge_tauto
                      | charge_right; charge_use; charge_tauto ].
Qed.

Lemma Preserves_Inv_simple
: forall (P : StateFormula) (A : ActionFormula),
    is_st_formula P ->
    |-- Preserves P A ->
    P //\\ []A |-- []P.
Proof.
  intros.
  eapply discr_indX.
  - assumption.
  - charge_assumption.
  - charge_assumption.
  - unfold Preserves in *.
    charge_tauto.
Qed.

Lemma Preserves_Inv
: forall (P X : StateFormula) (A : ActionFormula) (G : Formula),
    is_st_formula P ->
    G |-- [] X ->
    X |-- Preserves P A ->
    G |-- P //\\ []A -->> []P.
Proof.
  intros.
  rewrite landC. rewrite curry.
  charge_intros.
  eapply discr_indX.
  - assumption.
  - rewrite H0. rewrite Always_and. charge_assumption.
  - charge_assumption.
  - unfold Preserves in *.
    charge_tauto.
Qed.

Lemma Preserves_And_simple : forall P Q A B,
    Preserves P A //\\
    Preserves Q B
    |-- Preserves (P //\\ Q) (A //\\ B).
Proof.
  unfold Preserves. intros.
  rewrite next_And.
  charge_tauto.
Qed.

Lemma Preserves_And
  : forall (P Q : StateFormula) (A B : ActionFormula),
    Preserves P (Q //\\ A) //\\ Preserves Q (P //\\ B)
    |-- Preserves (P //\\ Q) (A //\\ B).
Proof.
  unfold Preserves. intros.
  rewrite next_And.
  charge_tauto.
Qed.

Lemma Preserves_intro
  : forall (I P G : Formula) (A : ActionFormula),
    G //\\ P |-- Preserves I A ->
    G |-- Preserves I (P //\\ A).
Proof.
  unfold Preserves. intros.
  charge_intros. charge_apply H.
  charge_tauto.
Qed.

Lemma Preserves_equiv
: forall a b : StateFormula,
    is_st_formula a -> is_st_formula b ->
    a -|- b ->
    forall c d : Formula,
      c -|- d ->
      Preserves a c -|- Preserves b d.
Proof.
  unfold Preserves. intros.
  rewrite H2; clear H2.
  eapply limpl_lequiv_m.
  { reflexivity. }
  { split;
    [ rewrite H1 at 1; rewrite (next_st_formula_entails a b)
    | rewrite <- H1 at 1; rewrite (next_st_formula_entails b a) ];
    try reflexivity; auto; eapply H1. }
Qed.

Lemma Preserves_entails
  : forall a b : Formula,
    is_st_formula a -> is_st_formula b ->
    b -|- a ->
    forall c d : Formula,
      d |-- c ->
      Preserves a c |-- Preserves b d.
Proof.
  unfold Preserves. intros.
  rewrite H2; clear H2.
  eapply limpl_lentails_m.
  { red. reflexivity. }
  { rewrite H1 at 1.
    rewrite (next_st_formula_entails a b); eauto. eapply H1. }
Qed.

Definition Inductively (P : StateFormula) (A : ActionFormula) : Formula :=
  []Preserves P A.

Lemma Inductively_Inv :
  forall P A,
    is_st_formula P ->
    P //\\ []A //\\ Inductively P A |-- []P.
Proof.
  unfold Inductively, Preserves. intros.
  rewrite Always_and. eapply discr_indX.
  - auto.
  - charge_assumption.
  - charge_assumption.
  - charge_tauto.
Qed.

Lemma Inductively_And : forall P Q E,
    Inductively P (Q //\\ E) //\\
    Inductively Q (P //\\ E)
    |-- Inductively (P //\\ Q) E.
Proof.
  unfold Inductively, Preserves. intros.
  rewrite Always_and. always_imp_tac. rewrite next_And.
  charge_tauto.
Qed.

Lemma Inductively_Or : forall P Q S1 S2,
    Inductively P S1 //\\
    Inductively Q S2
    |-- Inductively (P \\// Q) ((P //\\ S1) \\// (Q //\\ S2)).
Proof.
  unfold Inductively, Preserves.
  intros.
  tlaRevert. tlaRevert.
  rewrite <- curry. rewrite Always_and.
  apply Always_imp. simpl. restoreAbstraction.
  charge_intro. charge_intro.
  charge_cases; charge_tauto.
Qed.

Lemma Proper_Inductively
: Proper (eq ==> lequiv ==> lequiv)%signature Inductively.
Proof.
 red. do 2 red. unfold Inductively, Preserves. intros.
 apply Proper_Always_lequiv.
 eapply limpl_lequiv_m.
 { assumption. }
 { subst. reflexivity. }
Qed.

Lemma Proper_Inductively_entails
: Proper (eq ==> lentails --> lentails)%signature Inductively.
Proof.
 red. do 2 red. unfold Inductively, Preserves. intros.
 eapply Proper_Always_entails. subst.
 red in H0. rewrite H0. reflexivity.
Qed.

Lemma Inductively_equiv
: forall a b : StateFormula,
    is_st_formula a -> is_st_formula b ->
    a -|- b ->
    forall c d : Formula,
      c -|- d ->
      Inductively a c -|- Inductively b d.
Proof.
  unfold Inductively, Preserves. intros.
  apply Proper_Always_lequiv.
  rewrite H2; clear H2.
  eapply limpl_lequiv_m.
  { reflexivity. }
  { split;
    [ rewrite H1 at 1; rewrite (next_st_formula_entails a b)
    | rewrite <- H1 at 1; rewrite (next_st_formula_entails b a) ];
    try reflexivity; auto; eapply H1. }
Qed.

Lemma Inductively_entails
  : forall a b : Formula,
    is_st_formula a -> is_st_formula b ->
    b -|- a ->
    forall c d : Formula,
      d |-- c ->
      Inductively a c |-- Inductively b d.
Proof.
  unfold Inductively, Preserves. intros.
  eapply Proper_Always_entails.
  rewrite H2; clear H2.
  eapply limpl_lentails_m.
  { red. reflexivity. }
  { rewrite H1 at 1.
    rewrite (next_st_formula_entails a b); eauto. eapply H1. }
Qed.

Lemma Inductively_Or' : forall G P Q S1 S2,
    G |-- Inductively P S1 ->
    G |-- Inductively Q S2 ->
    G |-- Inductively (P \\// Q) ((P //\\ S1) \\// (Q //\\ S2)).
Proof.
  intros. charge_apply (Inductively_Or P Q S1 S2).
  charge_tauto.
Qed.


From iris.algebra Require Import frac.
From iris.proofmode Require Import proofmode.
From iris.base_logic Require Import invariants.
From cap_machine Require Import stdpp_extra.

Lemma big_sepM_to_big_sepL {Σ : gFunctors} {A B : Type} `{EqDecision A} `{Countable A}
      (r : gmap A B) (lr : list A) (φ : A → B → iProp Σ) :
  NoDup lr →
  (∀ r0, r0 ∈ lr → ∃ b, r !! r0 = Some b) →
  ([∗ map] k↦y ∈ r, φ k y) -∗ ([∗ list] y ∈ lr, ∃ b, φ y b).
Proof.
  iInduction (lr) as [ | r0 ] "IHl" forall (r); iIntros (Hdup Hlookup) "Hmap".
  - done.
  - assert (∃ b, r !! r0 = Some b) as [b Hr0].
    { apply Hlookup. apply elem_of_cons. by left. }
    iDestruct (big_sepM_delete _ _ r0 with "Hmap") as "[Hr0 Hmap]"; eauto.
    iSplitL "Hr0".
    + iExists b. iFrame.
    + iApply ("IHl" with "[] [] [$Hmap]").
      { iPureIntro. apply NoDup_cons_1_2 in Hdup. auto. }
      iPureIntro.
      intros r1 Hr1.
      destruct (decide (r0 = r1)).
      * subst. apply NoDup_cons in Hdup as [Hnelem Hdup]. contradiction.
      * rewrite lookup_delete_ne;auto. apply Hlookup.
        apply elem_of_cons. by right.
Qed.

Lemma big_sepM_to_big_sepL2 (PROP : bi) (A B : Type) `{EqDecision A} `{Countable A}
      (φ: A -> B -> PROP) (l1: list A) (l2: list B):
      NoDup l1 -> length l1 = length l2 →
      ⊢ (([∗ map] y1↦y2 ∈ list_to_map (zip l1 l2), φ y1 y2) -∗
         ([∗ list] y1;y2 ∈ l1;l2, φ y1 y2))%I.
Proof.
  revert l2. iInduction (l1) as [|x l1] "IH"; iIntros (l2 Hnd Hlen) "H".
  - iSimpl. destruct l2;inversion Hlen. done.
  - destruct l2;inversion Hlen. simpl.
    inversion Hnd. subst.
    iDestruct (big_sepM_insert with "H") as "[A B]".
    + eapply not_elem_of_list_to_map.
      rewrite fst_zip; auto. lia.
    + iFrame. iApply ("IH" $! l2 H4 H1 with "B"); auto.
Qed.

Lemma NoDup_of_sepL2_exclusive {Σ : gFunctors} {A B: Type} (l1: list A) (l2: list B) (Φ: A -> B -> iProp Σ):
  (∀ a x1 x2, Φ a x1 -∗ Φ a x2 -∗ False) -∗
  ([∗ list] a;x ∈ l1;l2, Φ a x) -∗
  ⌜NoDup l1⌝.
Proof.
  revert l2. induction l1 as [| a1' l1].
  { iIntros (?) "_ _". iPureIntro. constructor. }
  { iIntros (l2) "HΦ H". destruct l2 as [| a2' l2]; [done|]. cbn. iDestruct "H" as "[Ha1 H]".
    iDestruct (IHl1 with "HΦ H") as %?.
    iAssert (⌜a1' ∉ l1⌝)%I as %?.
    { iIntros (Hin). destruct (elem_of_list_lookup_1 _ _ Hin) as [k ?].
      iDestruct (big_sepL2_length with "H") as %Hlen12.
      destruct (lookup_lt_is_Some_2 l2 k).
      { rewrite -Hlen12 -lookup_lt_is_Some; eauto. }
      iDestruct (big_sepL2_lookup with "H") as "Ha1'"; eauto.
      iApply ("HΦ" with "Ha1 Ha1'"). }
    iPureIntro. by constructor. }
Qed.

Lemma big_sepL2_extract_l `{Σ : gFunctors} {A B : Type}
      (i : nat) (ai : A) (a : list A) (b : list B) (φ : A -> B -> iProp Σ) :
  a !! i = Some ai ->
  ⊢ (([∗ list] a_i;b_i ∈ a;b, φ a_i b_i) -∗
    (∃ b', [∗ list] a_i;b_i ∈ (delete i a);b', φ a_i b_i) ∗ ∃ b, φ ai b)%I.
Proof.
  iIntros (Hsome) "Hl".
  iDestruct (big_sepL2_length with "Hl") as %Hlength.
  assert (take i a ++ drop i a = a) as Heqa;[apply take_drop|].
  assert (take i b ++ drop i b = b) as Heqb;[apply take_drop|].
  rewrite -Heqa -Heqb.
  iDestruct (big_sepL2_app_inv with "Hl") as "[Htake Hdrop]".
  { apply lookup_lt_Some in Hsome.
    do 2 (rewrite take_length_le;[|lia]). left; auto.
  }
  apply take_drop_middle in Hsome as Hcons.
  assert (ai :: drop (S i) a = drop i a) as Hh.
  { apply app_inv_head with (take i a). congruence. }
  rewrite -Hh.
  iDestruct (big_sepL2_length with "Hdrop") as %Hlength'.
  destruct (drop i b);[inversion Hlength'|].
  iDestruct "Hdrop" as "[Hφ Hdrop]".
  iSplitR "Hφ";[|eauto].
  iExists (take i b ++ l). rewrite Hcons.
  iDestruct (big_sepL2_app with "Htake Hdrop") as "Hl".
  rewrite delete_take_drop. iFrame.
Qed.

Lemma big_sepL2_extract_l' {Σ : gFunctors} {A B : Type} (i : nat) (ai : A) (a : list A) (b : list B) (φ : A -> B -> iProp Σ) :
    a !! i = Some ai ->
    ⊢ (([∗ list] a_i;b_i ∈ a;b, φ a_i b_i) -∗
     ([∗ list] a_i;b_i ∈ (delete i a);(delete i b), φ a_i b_i) ∗ ∃ b, φ ai b)%I.
Proof.
  iIntros (Hsome) "Hl".
  iDestruct (big_sepL2_length with "Hl") as %Hlength.
  assert (take i a ++ drop i a = a) as Heqa;[apply take_drop|].
  assert (take i b ++ drop i b = b) as Heqb;[apply take_drop|].
  rewrite -Heqa -Heqb.
  iDestruct (big_sepL2_app_inv with "Hl") as "[Htake Hdrop]".
  { apply lookup_lt_Some in Hsome.
    do 2 (rewrite take_length_le;[|lia]). left; auto.
  }
  apply take_drop_middle in Hsome as Hcons.
  assert (ai :: drop (S i) a = drop i a) as Hh.
  { apply app_inv_head with (take i a). congruence. }
  rewrite -Hh.
  iDestruct (big_sepL2_length with "Hdrop") as %Hlength'.
  destruct (drop i b);[inversion Hlength'|].
  iDestruct "Hdrop" as "[Hφ Hdrop]".
  iSplitR "Hφ";[|eauto].
  rewrite Hcons. iDestruct (big_sepL2_app with "Htake Hdrop") as "Hl".
  rewrite Heqb. rewrite (delete_take_drop a).
  rewrite (delete_take_drop b).
  assert (drop (S i) b = l) as Hb.
  { pose proof (take_drop_middle b i b0) as HH.
    enough (b0 :: drop (S i) b = b0 :: l) as He by (inversion He; auto).
    eapply (app_inv_head (take i b)). rewrite HH //.
    rewrite -Heqb. apply list_lookup_middle.
    rewrite take_length_le //. enough (i < length b) by lia.
    rewrite -Hlength. apply lookup_lt_is_Some. eauto. }
  rewrite Hb. iFrame.
Qed.

Lemma big_sepL2_extract' {Σ : gFunctors} {A B : Type} (i : nat) (ai : A) (bi : B) (a : list A) (b : list B) (φ : A -> B -> iProp Σ) :
  a !! i = Some ai -> b !! i = Some bi ->
  ⊢ (([∗ list] a_i;b_i ∈ a;b, φ a_i b_i) -∗
   ([∗ list] a_i;b_i ∈ (delete i a);(delete i b), φ a_i b_i) ∗ φ ai bi)%I.
Proof.
  iIntros (Hsome Hsome') "Hl".
  iDestruct (big_sepL2_length with "Hl") as %Hlength.
  assert (take i a ++ drop i a = a) as Heqa;[apply take_drop|].
  assert (take i b ++ drop i b = b) as Heqb;[apply take_drop|].
  rewrite -Heqa -Heqb.
  iDestruct (big_sepL2_app_inv with "Hl") as "[Htake Hdrop]".
  { apply lookup_lt_Some in Hsome.
    do 2 (rewrite take_length_le;[|lia]). auto.
  }
  apply take_drop_middle in Hsome as Hcons.
  apply take_drop_middle in Hsome' as Hcons'.
  assert (ai :: drop (S i) a = drop i a) as Hh.
  { apply app_inv_head with (take i a). congruence. }
  assert (bi :: drop (S i) b = drop i b) as Hhb.
  { apply app_inv_head with (take i b). congruence. }
  rewrite -Hh. rewrite -Hhb.
  iDestruct "Hdrop" as "[Hφ Hdrop]".
  iSplitR "Hφ";[|eauto].
  rewrite Hcons. rewrite Hcons'. iDestruct (big_sepL2_app with "Htake Hdrop") as "Hl".
  rewrite (delete_take_drop b). rewrite (delete_take_drop a). iFrame.
Qed.

Lemma big_sepL2_close_l {Σ : gFunctors} {A B : Type} (i : nat) (ai : A) (bi : B) (a : list A) (b : list B) (φ : A -> B -> iProp Σ) :
  length a = length b ->
  a !! i = Some ai ->
  ⊢ (([∗ list] a_i;b_i ∈ (delete i a);(delete i b), φ a_i b_i) ∗ φ ai bi -∗
                                                             ([∗ list] a_i;b_i ∈ a;<[i:= bi]> b, φ a_i b_i) )%I.
Proof.
  iIntros (Hlen Hsome) "[Hl Hb]".
  iDestruct (big_sepL2_length with "Hl") as %Hlength.
  repeat rewrite delete_take_drop.
  apply lookup_lt_Some in Hsome as Hlt.
  assert (i < strings.length b) as Hlt';[lia|].
  iDestruct (big_sepL2_app_inv with "Hl") as "[Htake Hdrop]".
  { repeat rewrite take_length. lia. }
  apply take_drop_middle in Hsome as Hcons.
  assert (ai :: drop (S i) a = drop i a) as Hh.
  { apply app_inv_head with (take i a). rewrite Hcons. by rewrite take_drop. }
  iAssert ([∗ list] y1;y2 ∈ ai :: drop (S i) a;bi :: drop (S i) b, φ y1 y2)%I
    with "[Hb Hdrop]" as "Hdrop";[iFrame|].
  rewrite Hh.
  iDestruct (big_sepL2_app with "Htake Hdrop") as "Hab".
  rewrite take_drop.
  assert (take i b ++ bi :: drop (S i) b = <[i:=bi]> b) as ->;[|iFrame].
  assert (<[i:=bi]> b !! i = Some bi) as Hsome'.
  { apply list_lookup_insert. lia. }
  apply take_drop_middle in Hsome'. rewrite -Hsome'.
  rewrite take_insert;[|lia]. rewrite drop_insert_gt;[|lia]. auto.
Qed.

Lemma region_addrs_exists `{Σ : gFunctors} {A B: Type} (a : list A) (φ : A → B → iProp Σ) :
     ⊢ (([∗ list] a0 ∈ a, (∃ b0, φ a0 b0)) ∗-∗
      (∃ (ws : list B), [∗ list] a0;b0 ∈ a;ws, φ a0 b0))%I.
Proof.
  iSplit.
  - iIntros "Ha".
    iInduction (a) as [ | a0] "IHn".
    + iExists []. done.
    + iDestruct "Ha" as "[Ha0 Ha]".
      iDestruct "Ha0" as (w0) "Ha0".
      iDestruct ("IHn" with "Ha") as (ws) "Ha'".
      iExists (w0 :: ws). iFrame.
  - iIntros "Ha".
    iInduction (a) as [ | a0] "IHn".
    + done.
    + iDestruct "Ha" as (ws) "Ha".
      destruct ws;[by iApply bi.False_elim|].
      iDestruct "Ha" as "[Ha0 Ha]".
      iDestruct ("IHn" with "[Ha]") as "Ha'"; eauto.
      iFrame. eauto.
Qed.

Lemma region_addrs_exists_zip `{Σ : gFunctors} {A B C: Type} (a : list A) (φ : A → B → C -> iProp Σ) :
  ⊢ (([∗ list] a0 ∈ a, (∃ b0 c0, φ a0 b0 c0)) ∗-∗
  (∃ (ws : list (B * C)), [∗ list] a0;bc0 ∈ a;ws, φ a0 bc0.1 bc0.2))%I.
Proof.
  iSplit.
  - iIntros "Ha".
    iInduction (a) as [ | a0] "IHn".
    + iExists []. done.
    + iDestruct "Ha" as "[Ha0 Ha]".
      iDestruct "Ha0" as (w0 p0) "Ha0".
      iDestruct ("IHn" with "Ha") as (ws) "Ha'".
      iExists ((w0,p0) :: ws). iFrame.
  - iIntros "Ha".
    iInduction (a) as [ | a0] "IHn".
    + done.
    + iDestruct "Ha" as (ws) "Ha".
      destruct ws;[by iApply bi.False_elim|].
      iDestruct "Ha" as "[Ha0 Ha]".
      iDestruct ("IHn" with "[Ha]") as "Ha'"; eauto.
      iFrame. eauto.
Qed.

Lemma region_addrs_exists2 `{Σ : gFunctors} {A B C: Type} (a : list A) (b : list B) (φ : A → B → C -> iProp Σ) :
     ⊢ (([∗ list] a0;b0 ∈ a;b, (∃ c0, φ a0 b0 c0)) ∗-∗
      (∃ (ws : list C), ⌜length ws = length b⌝ ∗ [∗ list] a0;bc0 ∈ a;(zip b ws), φ a0 bc0.1 bc0.2))%I.
Proof.
  iSplit.
  - iIntros "Ha".
    iInduction (a) as [ | a0] "IHn" forall (b).
    + iExists []. iDestruct (big_sepL2_length with "Ha") as %Hlength.
      destruct b;inversion Hlength. iSplit;auto.
    + iDestruct (big_sepL2_length with "Ha") as %Hlength.
      destruct b; [inversion Hlength|].
      iDestruct "Ha" as "[Ha0 Ha]".
      iDestruct "Ha0" as (w0) "Ha0".
      iDestruct ("IHn" with "Ha") as (ws Hlen) "Ha'".
      iExists (w0 :: ws). simpl. iSplit;auto. iFrame.
   - iIntros "Ha".
     iInduction (a) as [ | a0] "IHn" forall (b).
     + iDestruct "Ha" as (ws Hlen) "Ha".
       iDestruct (big_sepL2_length with "Ha") as %Hlength. destruct b,ws;inversion Hlength; done.
     + iDestruct "Ha" as (ws Hlen) "Ha".
       destruct ws,b;try by iApply bi.False_elim. simpl.
       iDestruct "Ha" as "[Ha0 Ha]". iDestruct (big_sepL2_length with "Ha") as %Hlength.
       iDestruct ("IHn" with "[Ha]") as "Ha'"; iFrame; eauto.
Qed.

Lemma big_sepL2_to_big_sepL_r `{Σ : gFunctors} {A B : Type} (φ : B → iProp Σ) (l1 : list A) l2 :
  length l1 = length l2 →
  ⊢ (([∗ list] _;y2 ∈ l1;l2, φ y2) ∗-∗
                                 ([∗ list] y ∈ l2, φ y))%I.
Proof.
  iIntros (Hlen).
  iSplit.
  - iIntros "Hl2". iRevert (Hlen).
    iInduction (l2) as [ | y2] "IHn" forall (l1); iIntros (Hlen).
    + done.
    + destruct l1;[by iApply bi.False_elim|].
      iDestruct "Hl2" as "[$ Hl2]".
      iApply ("IHn" with "Hl2"). auto.
  - iIntros "Hl2".
    iRevert (Hlen).
    iInduction (l2) as [ | y2] "IHn" forall (l1); iIntros (Hlen).
    + destruct l1; inversion Hlen. done.
    + iDestruct "Hl2" as "[Hy2 Hl2]".
      destruct l1; inversion Hlen.
      iDestruct ("IHn" $! l1 with "Hl2") as "Hl2".
      iFrame. iApply "Hl2". auto.
Qed.

Lemma big_sepL2_to_big_sepL_l `{Σ : gFunctors} {A B : Type} (φ : A → iProp Σ) (l1 : list A)
      (l2 : list B) :
  length l1 = length l2 →
  ⊢ (([∗ list] y1;_ ∈ l1;l2, φ y1) ∗-∗
  ([∗ list] y ∈ l1, φ y))%I.
Proof.
  iIntros (Hlen).
  iSplit.
  - iIntros "Hl2". iRevert (Hlen).
    iInduction (l1) as [ | y1] "IHn" forall (l2); iIntros (Hlen).
    + done.
    + destruct l2;[by iApply bi.False_elim|].
      iDestruct "Hl2" as "[$ Hl2]".
      iApply ("IHn" with "Hl2"). auto.
  - iIntros "Hl2".
    iRevert (Hlen).
    iInduction (l1) as [ | y1] "IHn" forall (l2); iIntros (Hlen).
    + destruct l2; inversion Hlen. done.
    + iDestruct "Hl2" as "[Hy2 Hl2]".
      destruct l2; inversion Hlen.
      iDestruct ("IHn" $! l2 with "Hl2") as "Hl2".
      iFrame. iApply "Hl2". auto.
Qed.

Lemma big_sepL2_app'
      (PROP : bi) (A B : Type) (Φ : nat → A → B → PROP) (l1 l2 : list A)
      (l1' l2' : list B) :
  (length l1) = (length l1') →
  (([∗ list] k↦y1;y2 ∈ l1;l1', Φ k y1 y2)
     ∗ ([∗ list] k↦y1;y2 ∈ l2;l2', Φ (strings.length l1 + k) y1 y2))%I
   ≡ ([∗ list] k↦y1;y2 ∈ (l1 ++ l2);(l1' ++ l2'), Φ k y1 y2)%I.
Proof.
  intros Hlenl1.
  iSplit.
  - iIntros "[Hl1 Hl2]". iApply (big_sepL2_app with "Hl1 Hl2").
  - iIntros "Happ".
    iAssert (∃ l0' l0'' : list A,
                ⌜(l1 ++ l2) = l0' ++ l0''⌝
                ∧ ([∗ list] k↦y1;y2 ∈ l0';l1', Φ k y1 y2)
                    ∗ ([∗ list] k↦y1;y2 ∈ l0'';l2', Φ (strings.length l1' + k) y1 y2))%I
      with "[Happ]" as (l0' l0'') "(% & Happl0' & Happl0'')".
    { by iApply (big_sepL2_app_inv_r with "Happ"). }
    iDestruct (big_sepL2_length with "Happl0'") as %Hlen1.
    iDestruct (big_sepL2_length with "Happl0''") as %Hlen2.
    rewrite -Hlenl1 in Hlen1.
    assert (l1 = l0' ∧ l2 = l0'') as [Heq1 Heq2]; first by apply app_inj_1.
    simplify_eq; rewrite Hlenl1.
    iFrame.
Qed.

Lemma big_sepL2_split_at `{Σ : gFunctors} {A B: Type} `{EqDecision A} `{Countable A}
      (k: nat) (l1: list A) (l2: list B) (φ : A → B → iProp Σ):
  ([∗ list] a;b ∈ l1;l2, φ a b) -∗
  ([∗ list] a;b ∈ (take k l1);(take k l2), φ a b) ∗ ([∗ list] a;b ∈ (drop k l1);(drop k l2), φ a b).
Proof.
  iIntros "H".
  iDestruct (big_sepL2_length with "H") as %?.
  rewrite -{1}(take_drop k l1) -{1}(take_drop k l2).
  iDestruct (big_sepL2_app' with "H") as "[? ?]".
  { rewrite !take_length. lia. }
  iFrame.
Qed.

Lemma big_sepL_delete' {PROP: bi} {A: Type} (φ: A -> PROP) (l: list A):
      forall k, ⊢ (([∗ list] k0↦y ∈ l, if decide (k0 = k) then emp else φ y) -∗
           ([∗ list] k0↦x0 ∈ delete k l, (λ (_ : nat) (x1 : A), φ x1) k0 x0))%I.
Proof.
  iInduction (l) as [|x l] "IH"; simpl; auto; iIntros (k) "H".
  iDestruct "H" as "[H1 H2]".
  rewrite /delete /=. destruct k.
  - iApply (big_sepL_impl with "H2").
    iClear "H1". iModIntro. iIntros. destruct (decide (S k = 0)); auto.
  - simpl. iFrame. iApply ("IH" with "[H2]").
    iApply (big_sepL_impl with "H2").
    iModIntro; iIntros. destruct (decide (k0 = k)); destruct (decide (S k0 = S k)); auto; lia.
Qed.

Lemma big_sepL_merge {PROP: bi} {A: Type} (l: list A) (HNoDup: NoDup l) (φ: A -> PROP) {Haffine: forall a, Affine (φ a)}:
  forall l1 l2, (forall a, a ∈ l -> a ∈ l1 \/ a ∈ l2) ->
           ⊢ (([∗ list] a ∈ l1, φ a) -∗
            ([∗ list] a ∈ l2, φ a) -∗
            ([∗ list] a ∈ l, φ a))%I.
Proof.
  iInduction (l) as [|x l] "IH"; iIntros (l1 l2 H) "Hl1 Hl2".
  - iApply big_sepL_nil; auto.
  - iApply big_sepL_cons. destruct (H x ltac:(eapply elem_of_list_here)) as [H'|H']; eapply elem_of_list_lookup in H'; destruct H' as [k H'].
    + iDestruct (big_sepL_delete with "Hl1") as "[$ Hl1]"; eauto.
      iAssert ([∗ list] a ∈ delete k l1, φ a)%I with "[Hl1]" as "Hl1".
      { iApply (big_sepL_impl with "[Hl1]"); auto.
        iApply (big_sepL_delete' with "Hl1"). }
      assert (Hincl: ∀ a : A, a ∈ l → a ∈ delete k l1 ∨ a ∈ l2).
      { intros. destruct (H a ltac:(eapply elem_of_list_further; eauto)).
        - left. eapply elem_of_list_lookup in H1. destruct H1.
          eapply elem_of_list_lookup. assert (x0 <> k).
          + red; intros; subst x0. rewrite H1 in H'; inversion H'.
            inversion HNoDup. eapply H5. subst. auto.
          + assert  (x0 < k \/ k <= x0) by lia. destruct H3.
            * exists x0. rewrite lookup_delete_lt; auto.
            * exists (x0 - 1). rewrite lookup_delete_ge; auto; try lia.
              replace (S (x0 - 1)) with x0; auto. lia.
        - right. auto. }
      inversion HNoDup. iApply ("IH" $! H3 (delete k l1) l2 Hincl with "[$Hl1] [$Hl2]").
    + iDestruct (big_sepL_delete with "Hl2") as "[$ Hl2]"; eauto.
      iAssert ([∗ list] a ∈ delete k l2, φ a)%I with "[Hl2]" as "Hl2".
      { iApply (big_sepL_impl with "[Hl2]"); auto.
        iApply (big_sepL_delete' with "Hl2"). }
      assert (Hincl: ∀ a : A, a ∈ l → a ∈ l1 ∨ a ∈ delete k l2).
      { intros. destruct (H a ltac:(eapply elem_of_list_further; eauto)).
        - left. auto.
        - right. eapply elem_of_list_lookup in H1. destruct H1.
          eapply elem_of_list_lookup. assert (x0 <> k).
          + red; intros; subst x0. rewrite H1 in H'; inversion H'.
            inversion HNoDup. subst. eapply H5. auto.
          + assert  (x0 < k \/ k <= x0) by lia. destruct H3.
            * exists x0. rewrite lookup_delete_lt; auto.
            * exists (x0 - 1). rewrite lookup_delete_ge; auto; try lia.
              replace (S (x0 - 1)) with x0; auto. lia. }
      inversion HNoDup. iApply ("IH" $! H3 l1 (delete k l2) Hincl with "[$Hl1] [$Hl2]").
Qed.

Lemma big_sepL2_to_big_sepM (PROP : bi) (A B : Type) `{EqDecision A} `{Countable A}
      (φ: A -> B -> PROP) (l1: list A) (l2: list B):
      NoDup l1 ->
      ⊢ (([∗ list] y1;y2 ∈ l1;l2, φ y1 y2) -∗
      ([∗ map] y1↦y2 ∈ list_to_map (zip l1 l2), φ y1 y2))%I.
Proof.
  revert l2. iInduction (l1) as [|x l1] "IH"; iIntros (l2 Hnd) "H".
  - iSimpl. iDestruct (big_sepL2_length with "H") as "%".
    destruct l2; simpl in H0; inversion H0.
    iApply big_sepM_empty. auto.
  - iDestruct (big_sepL2_length with "H") as "%".
    destruct l2; simpl in H0; inversion H0.
    simpl. inversion Hnd. iDestruct "H" as "[A B]".
    iApply (big_sepM_insert with "[A B]").
    + eapply not_elem_of_list_to_map.
      rewrite fst_zip; auto. lia.
    + iFrame. iApply ("IH" $! l2 H5 with "B"); auto.
Qed.

Lemma big_sepL2_bupd
   : ∀ (PROP : bi) (H : BiBUpd PROP) (A B : Type) (Φ : A → B → PROP) (l1 : list A) (l2: list B),
       ([∗ list] k;x ∈ l1;l2, |==> Φ k x) -∗ |==> [∗ list] k;x ∈ l1;l2, Φ k x.
Proof.
  intros. revert l2. induction l1 as [| x l1].
  { intros. iIntros "H".
    iDestruct (big_sepL2_length with "H") as %Hlen. cbn in Hlen.
    destruct l2; [| by inversion Hlen]. cbn. eauto. }
  { intros. iIntros "H".
    iDestruct (big_sepL2_length with "H") as %Hlen. cbn in Hlen.
    destruct l2; [by inversion Hlen |]. cbn. iDestruct "H" as "[>? H]".
    iDestruct (IHl1 with "H") as ">?". iModIntro. iFrame. }
Qed.

(* Helper lemma for reasoning about the current state of a region map *)
Lemma big_sepM_exists `{Σ : gFunctors} {A B C : Type} `{EqDecision A, Countable A} (m : gmap A B) (φ : A → C -> B → iProp Σ) :
  ⊢ (([∗ map] a↦b ∈ m, ∃ c, φ a c b) ∗-∗ (∃ (m' : gmap A C), [∗ map] a↦c;b ∈ m';m, φ a c b))%I.
Proof.
  iSplit.
  - iIntros "Hmap".
    iInduction (m) as [| a x m Hnone] "IH" using map_ind.
    + iExists empty. done.
    + iDestruct (big_sepM_insert with "Hmap") as "[Hc Hmap]"; auto.
      iDestruct "Hc" as (c) "Hc".
      iDestruct ("IH" with "Hmap") as (m') "Hmap".
      iExists (<[a:=c]> m').
      iApply (big_sepM2_insert_2 with "Hc").
      iFrame.
  - iIntros "Hmap".
    iDestruct "Hmap" as (m') "Hmap".
    iInduction (m) as [| a x m Hnone] "IH" using map_ind forall (m').
    + done.
    + iDestruct (big_sepM2_dom with "Hmap") as %Hdom.
      assert (is_Some (m' !! a)) as [ρ Hρ].
      { apply elem_of_dom. rewrite Hdom dom_insert_L.
        apply elem_of_union_l, elem_of_singleton; auto. }
      rewrite -(insert_id m' a ρ); auto.
      rewrite -insert_delete_insert.
      iDestruct (big_sepM2_insert with "Hmap") as "[Hφ Hmap]";[apply lookup_delete|auto|].
      iApply big_sepM_insert;auto.
      iDestruct ("IH" with "Hmap") as "Hmap". iFrame.
      iExists ρ. iFrame.
Qed.

Lemma big_sepL2_to_big_sepL_replicate {Σ : gFunctors} {A B: Type} (l1: list A) (b : B) (Φ: A -> B -> iProp Σ) :
  ([∗ list] a;b' ∈ l1;replicate (length l1) b, Φ a b')%I -∗
  ([∗ list] a ∈ l1, Φ a b).
Proof.
  iIntros "Hl".
  iInduction l1 as [|a l1] "IH".
  - done.
  - simpl. iDestruct "Hl" as "[$ Hl]".
    iApply "IH". iFrame.
Qed.

Lemma big_sepM_to_create_gmap_default {Σ : gFunctors} {A B : Type} `{Countable A} (m m' : gmap A B) (φ : A -> B -> iProp Σ) (b : B) (l : list A) :
  l ≡ₚ(map_to_list m).*1 →
  m' = create_gmap_default l b →
  ([∗ map] a↦_ ∈ m, φ a b) -∗ ([∗ map] a↦b' ∈ m', φ a b').
Proof.
  iIntros (Hl Hm) "Hm".
  iInduction l as [|a l] "IH" forall (m m' Hl Hm).
  - simpl in Hm. rewrite Hm. done.
  - assert (NoDup (a :: l)) as Hdup.
    { rewrite Hl. apply NoDup_map_to_list_fst. done. }
    assert (a ∈ (map_to_list m).*1) as Hin'.
    { rewrite -Hl. constructor. }
    assert (is_Some(m !! a)) as [b' Hsome].
    { apply elem_of_dom. rewrite -list_to_set_map_to_list. apply elem_of_list_to_set. auto. }
    iDestruct (big_sepM_delete _ _ a with "Hm") as "[Ha Hm]";eauto.
    iApply big_sepM_delete;[|iFrame].
    { rewrite Hm.  apply lookup_insert. }
    rewrite Hm /= delete_insert_delete.
    iApply ("IH" $! (delete a m));[..|iFrame].
    + iPureIntro. rewrite map_to_list_delete_fst;eauto.
    + iPureIntro. rewrite delete_notin;auto.
      destruct (create_gmap_default l b !! a) eqn:Hsome';auto.
      exfalso. apply NoDup_cons in Hdup as [Hnin Hdup].
      apply Hnin. apply create_gmap_default_lookup_is_Some in Hsome' as [Hin Hsome'].
      subst. auto.
Qed.


Require Import HoTT.
From GR Require Import
     bicategories.bicategory.bicategory
     bicategories.bicategory.univalent
     bicategories.bicategory.locally_strict
     bicategories.bicategory.strict
     bicategories.lax_functor.lax_functor
     bicategories.lax_transformation.lax_transformation
     bicategories.lax_transformation.examples.identity
     bicategories.lax_transformation.examples.composition
     bicategories.bicategory.examples.full_sub
     bicategories.bicategory.examples.lax_functors_bicat
     bicategories.bicategory.examples.arrow_subcategory.

Definition Pseudo `{Univalence} (C D : BiCategory) : BiCategory.
Proof.
  refine (arrow_subcat
            (full_sub (Lax C D) (fun F => BuildhProp (is_pseudo F)))
            (fun _ _ η => BuildhProp (is_pseudo_transformation η))
            _
            _
         ).
  - intros F ; simpl in *.
    apply identity_transformation.
  - intros F₁ F₂ F₃ η₁ η₂ Hη₁ Hη₂ ; simpl in *.
    apply (compose_pseudo (η₁;Hη₁) (η₂;Hη₂)).
Defined.

Global Instance univalent_Pseudo
       `{Univalence}
       (C D : BiCategory)
       `{@Univalent _ D}
  : Univalent (Pseudo C D).
Proof.
  admit.
Admitted.

Global Instance is_2category_Pseudo
       `{Univalence}
       (C D : BiCategory)
       `{HD : is_2category D}
  : is_2category (Pseudo C D).
Proof.
  apply is_2category_arrow_subcategory.
  apply is_2category_full_sub.
  apply is_2_category_Lax ; apply HD.
Defined.


From Perennial.program_logic Require Export language.
From Perennial.Helpers Require Import Transitions.
From Perennial.goose_lang Require Export lang.
From Perennial.goose_lang Require Import tactics notation lifting.

(* Define the notion of trace refinement *)

Section go_refinement.
  (* Records defining spec language extensions *)
  Context {spec_op: ffi_syntax}.
  Context {spec_ffi: ffi_model}.
  Context {spec_semantics: ffi_semantics spec_op spec_ffi}.

  (* Records for the target language *)
  Context {impl_op: ffi_syntax}.
  Context {impl_ffi: ffi_model}.
  Context {impl_semantics: ffi_semantics impl_op impl_ffi}.

  Notation sexpr := (@expr spec_op).
  Notation sstate := (@state spec_op spec_ffi).
  Notation sgstate := (@global_state spec_ffi).
  Notation iexpr := (@expr impl_op).
  Notation istate := (@state impl_op impl_ffi).
  Notation igstate := (@global_state impl_ffi).

  Canonical Structure spec_lang : language :=
    @goose_lang (spec_op) (spec_ffi) (spec_semantics).
  Canonical Structure spec_crash_lang : crash_semantics spec_lang :=
    @goose_crash_lang (spec_op) (spec_ffi) (spec_semantics).

  Canonical Structure impl_lang : language :=
    @goose_lang (impl_op) (impl_ffi) (impl_semantics).
  Canonical Structure impl_crash_lang : crash_semantics impl_lang :=
    @goose_crash_lang (impl_op) (impl_ffi) (impl_semantics).

  Definition trace_refines (e r: iexpr) (σ: istate) (g: igstate) (e' r': sexpr) (σ': sstate) (g': sgstate):=
    @crash_safe spec_lang spec_crash_lang r' ([e'], (σ',g')) →
    @crash_safe impl_lang impl_crash_lang r ([e], (σ,g)) ∧
    (∀ tr, trace_observable e r σ g tr → trace_observable e' r' σ' g' tr).

End go_refinement.


(*
    Copyright (C) 2012  G. Gonthier, B. Ziliani, A. Nanevski, D. Dreyer

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
*)

From mathcomp
Require Import ssreflect ssrbool ssrfun ssrnat eqtype seq.
From LemmaOverloading
Require Import prelude heaps rels hprop domains.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* Exceptions are an equality type *)
Inductive exn : Type := exn_from_nat : nat -> exn.

Definition exn_to_nat (e : exn) : nat :=
  let: exn_from_nat y := e in y.

Definition eqexn (e1 e2 : exn) : bool :=
  match e1, e2 with exn_from_nat m, exn_from_nat n => m == n end.

Lemma eqexnP : Equality.axiom eqexn.
Proof.
move=>[x][y]//=; case: eqP=>[->|*];constructor=>//.
by move=>[*].
Qed.

Canonical Structure exn_eqMixin := EqMixin eqexnP.
Canonical Structure exn_eqType := EqType exn exn_eqMixin.

(* Answer type *)
Inductive ans (A : Type) : Type := Val of A | Exn of exn.
Arguments Exn [A].

Notation pre := (Pred heap).
Notation post A := (ans A -> heap -> heap -> Prop).
Definition spec B := pre * post B : Type.

(********************************)
(* Definition of the Hoare type *)
(********************************)

Definition defed (P : Pred heap) : Pred heap :=
  fun i => i \In P /\ def i.

Notation ideald P := (ideal (defed P)).

Section BasePrograms.
Variables (A : Type) (P : Pred heap).

Lemma singleP i : i \In defed P -> this i <== defed P.
Proof. by move=>[pf1 pf2] h <-; split. Qed.

Definition single i (pf : i \In defed P) := Ideal (singleP pf).

Lemma bound (p : ideald P) i : i \In id_val p -> i \In defed P.
Proof. by case: p=>p H; case/H. Qed.

(* we carve out the model out of the following base type *)
Definition prog := ideald P -> ans A -> Pred heap.

(* we take progs with only special properties *)
(* which we defined next *)

(* coherence is continuity stated with *)
(* directed sets instead of chains *)
Definition coherent (e : prog) :=
  forall p x m,
    m \In e p x <-> exists i, exists pf : i \In id_val p,
                    m \In e (single (bound pf)) x.

(* defined heaps map to defined heaps *)
Definition def_strict (e : prog) := forall p x, Undef \Notin e p x.

(* set of program runs *)
Definition runs_of (e : prog) : Pred (heap * ans A * heap) :=
  fun r => exists pf : r.1.1 \In defed P, r.2 \In e (single pf) r.1.2.

End BasePrograms.

Definition has_spec A (s : spec A) :=
  [Pred c : prog A s.1 |
     forall i y m, (i, y, m) \In runs_of c -> s.2 y i m].

Section STDef.
Variables (A : Type) (s : spec A).

Structure ST := STprog {
  model : prog A s.1;
  _ : coherent model;
  _ : def_strict model;
  _ : model \In has_spec s}.

Lemma modelE (e1 e2 : ST) : e1 = e2 <-> model e1 = model e2.
Proof.
move: e1 e2=>[e1 M1 S1 H1][e2 M2 S2 H2] /=; split=>[[//]|E].
rewrite E in M1 S1 H1 *.
by congr STprog; apply: proof_irrelevance.
Qed.

(* poset structure on ST *)

Definition st_leq e1 e2 := model e1 <== model e2.

Lemma st_refl e : st_leq e e.
Proof. by []. Qed.

Lemma st_asym e1 e2 : st_leq e1 e2 -> st_leq e2 e1 -> e1 = e2.
Proof.
move: e1 e2=>[e1 M1 S1 H1][e2 M2 S2 H2]; rewrite /st_leq /= => E1 E2.
rewrite (poset_asym E1 E2) in M1 M2 S1 S2 H1 H2 *; congr STprog;
by apply: proof_irrelevance.
Qed.

Lemma st_trans e1 e2 e3 : st_leq e1 e2 -> st_leq e2 e3 -> st_leq e1 e3.
Proof.
move: e1 e2 e3=>[e1 M1 S1 H1][e2 M2 S2 H2][e3 M3 S3 H3].
by apply: poset_trans.
Qed.

Definition st_bot' := bot : [poset of prog A s.1].

Lemma st_bot_coherent : coherent st_bot'.
Proof. by move=>r x m; split=>//; case=>i []. Qed.

Lemma st_bot_dstrict : def_strict st_bot'.
Proof. by move=>r x. Qed.

Lemma st_bot_has_spec : st_bot' \In has_spec s.
Proof. by move=>i y m [/= H][]. Qed.

Definition st_bot := STprog st_bot_coherent st_bot_dstrict st_bot_has_spec.

Lemma st_botP e : st_leq st_bot e.
Proof. by case: e=>*; apply: botP. Qed.

Definition stPosetMixin := PosetMixin st_botP st_refl st_asym st_trans.
Canonical stPoset := Eval hnf in Poset ST stPosetMixin.

(* lattice structure on ST *)

Definition st_sup' (u : Pred ST) :=
  sup [Pred p | exists e, p = model e /\ e \In u].

Lemma st_sup_coherent u : coherent (st_sup' u).
Proof.
move=>r x m; split.
- case=>_ [[_]][[_]][[_]][[]][p] M S H [->] P -> -> -> /=.
  case/M=>i [pf] H1.
  exists i; exists pf; exists (p (single (bound pf)) x m).
  split=>//; do 3![eexists _; split=>//].
  by exists (STprog M S H).
case=>i [pf][_][[_]][[_]][[_]][[]][p] M D H [->] P -> -> -> /= E.
have: exists i, exists pf : i \In id_val r, m \In p (single (bound pf)) x.
- by exists i; exists pf.
move/M=>H3; exists (p r x m); split=>//; do 3![eexists _; split=>//].
by exists (STprog M D H).
Qed.

Lemma st_sup_dstrict u : def_strict (st_sup' u).
Proof.
by move=>p x [_][[_]][[_]][[_]][[]][r] M D H [->] P -> -> -> /=; move/D.
Qed.

Lemma st_sup_has_spec u : st_sup' u \In has_spec s.
Proof.
move=>i y m [/= D].
case=>_ [[_]][[_]][[_]][[]][p] M S H [->] P -> -> -> /= R.
by apply: (H); exists D.
Qed.

Definition st_sup u :=
  STprog (@st_sup_coherent u) (@st_sup_dstrict u) (@st_sup_has_spec u).

Lemma st_supP (u : Pred ST) e : e \In u -> st_leq e (st_sup u).
Proof. by case: e=>p M S H R; apply: supP; exists (STprog M S H). Qed.

Lemma st_supM (u : Pred ST) e :
        (forall e1, e1 \In u -> st_leq e1 e) -> st_leq (st_sup u) e.
Proof. by case: e=>p M S H R; apply: supM=>y [q][->]; apply: R. Qed.

Definition stLatticeMixin := LatticeMixin st_supP st_supM.
Canonical stLattice := Lattice ST stLatticeMixin.

(* In proofs, we keep goals in form (i, x, m) \In runs_of (model e). *)
(* We need a couple of lemmas about this form. *)

Lemma bot_runs : runs_of (model st_bot) =p Pred0.
Proof. by move=>r; split=>//; case. Qed.

Lemma model_runs p y m (e : ST) :
        m \In model e p y <->
        exists i, i \In id_val p /\ (i, y, m) \In runs_of (model e).
Proof.
case: e=>mod M S H; rewrite M; split; case=>i [H1] H2.
- by exists i; split=>//; exists (bound H1).
exists i; exists H1; case: H2 =>/= H2.
by rewrite (proof_irrelevance H2 (bound H1)).
Qed.

Lemma def_runs i y m (e : ST) :
        (i, y, m) \In runs_of (model e) -> [/\ def i, i \In s.1 & def m].
Proof.
case=>[[/= P D]] R; split=>//.
by case: e R=>p M S H; case: m=>//; move/S.
Qed.

Lemma spec_runs i y m (e : ST) :
        (i, y, m) \In runs_of (model e) -> s.2 y i m.
Proof. by case: e=>p M S; apply. Qed.

End STDef.

Arguments spec_runs {A s i y m}.
Prenex Implicits bot_runs model_runs def_runs.

(************************************)
(* modeling the language primitives *)
(************************************)

Module Model.

(* recursion *)
Section Fix.
Variables (A : Type) (B : A -> Type) (s : forall x, spec (B x)).
Notation tp := (forall x, ST (s x)).
Notation lat := (dfunLattice (fun x => [lattice of ST (s x)])).
Variable (f : tp -> tp).

(* we take a fixpoint not of f, but of its monotone completion f' *)
(* should eventually prove that f' is monotone *)

Definition f' (e : lat) :=
  sup [Pred t : lat | exists e', e' <== e /\ t = f e'].

Definition ffix : tp := tarski_lfp f'.

End Fix.

Section Return.
Variables (A : Type) (x : A).

Definition ret_s : spec A :=
  (fun i => True, fun y i m => m = i /\ y = Val x).

Definition ret_sp (p : ideald ret_s.1) y m :=
  m \In id_val p /\ y = Val x.

Lemma ret_coherent : coherent ret_sp.
Proof.
move=>p y m; split; first by case=>H ->{y}; exists m; exists H.
by case=>i [H1] [<-{m}] ->{y}.
Qed.

Lemma ret_dstrict : def_strict ret_sp.
Proof. by case=>p H y /= []; case/H. Qed.

Lemma ret_has_spec : ret_sp \In has_spec ret_s.
Proof. by move=>i y m; case=>/= T [-> ->]. Qed.

Definition ret := STprog ret_coherent ret_dstrict ret_has_spec.

End Return.

Section Throw.
Variables (A : Type) (e : exn).

Definition throw_s : spec A :=
  (fun i => True, fun y i m => m = i /\ y = Exn e).

Definition throw_sp (p : ideald throw_s.1) y m :=
  m \In id_val p /\ y = @Exn A e.

Lemma throw_coherent : coherent throw_sp.
Proof.
move=>p y m; split; first by case=>H ->{y}; exists m; exists H.
by case=>i [H1] [<-{m}] ->{y}.
Qed.

Lemma throw_dstrict : def_strict throw_sp.
Proof. by case=>p H y /= []; case/H. Qed.

Lemma throw_has_spec : throw_sp \In has_spec throw_s.
Proof. by move=>i y m; case=>/= T [-> ->]. Qed.

Definition throw := STprog throw_coherent throw_dstrict throw_has_spec.

End Throw.

Section Bind.
Variables (A B : Type).
Variables (s1 : spec A) (s2 : A -> spec B).
Variables (e1 : ST s1) (e2 : forall x, ST (s2 x)).

Definition bind_pre : pre :=
  fun i => s1.1 i /\ forall x m, s1.2 (Val x) i m -> (s2 x).1 m.
Definition bind_post : post B :=
  fun y i m => (exists x, exists h, s1.2 (Val x) i h /\ (s2 x).2 y h m) \/
               (exists e, y = Exn e /\ s1.2 (Exn e) i m).
Definition bind_s := (bind_pre, bind_post).

Definition bind_sp (p : ideald bind_s.1) y m :=
   exists i, exists x, exists h, i \In id_val p /\
     (i, x, h) \In runs_of (model e1) /\
     match x with
       Val x' => (h, y, m) \In runs_of (model (e2 x'))
     | Exn e => y = Exn e /\ m = h
     end.

Lemma bind_coherent : coherent bind_sp.
Proof.
case=>p H y m; split.
- case=>i [x][h][/= H1][H2] H3.
  by exists i; exists H1; exists i; exists x; exists h.
case=>i [/= H1][_][x][h][<-][T1 T2].
by exists i; exists x; exists h.
Qed.

Lemma bind_dstrict : def_strict bind_sp.
Proof.
move=>p y [i][x][h][H1][].
case: x=>[x'|e] H2; first by case/def_runs.
by case=>_ E; case/def_runs: H2; rewrite -E.
Qed.

Lemma bind_has_spec : bind_sp \In has_spec bind_s.
Proof.
move=>i y m.
case=>[[[/= S1 S2]]] D [h][x][j][<-][].
case: x=>[x|e] T1; last first.
- case=>->->; right; exists e; split=>//.
  by apply: spec_runs T1.
move=>T2; left; exists x; exists j.
by split; [apply: spec_runs T1 | apply: spec_runs T2].
Qed.

Definition bind := STprog bind_coherent bind_dstrict bind_has_spec.

End Bind.

Section Try.
Variables (A B : Type) (s : spec A) (s1 : A -> spec B) (s2 : exn -> spec B).
Variables (e : ST s) (e1 : forall x, ST (s1 x)) (e2 : forall x, ST (s2 x)).

Definition try_pre : pre :=
  fun i => s.1 i /\ (forall y m, s.2 (Val y) i m -> (s1 y).1 m) /\
                     forall e m, s.2 (Exn e) i m -> (s2 e).1 m.
Definition try_post : post B :=
  fun y i m => (exists x, exists h, s.2 (Val x) i h /\ (s1 x).2 y h m) \/
               (exists e, exists h, s.2 (Exn e) i h /\ (s2 e).2 y h m).
Definition try_s := (try_pre, try_post).

Definition try_sp (p : ideald try_s.1) y m :=
   exists i, exists x, exists h, i \In id_val p /\
     (i, x, h) \In runs_of (model e) /\
     match x with
       Val x' => (h, y, m) \In runs_of (model (e1 x'))
     | Exn e => (h, y, m) \In runs_of (model (e2 e))
     end.

Lemma try_coherent : coherent try_sp.
Proof.
case=>p H y m; split.
- case=>i [x][h][/= H1][H2] H3.
  by exists i; exists H1; exists i; exists x; exists h.
case=>i [/= H1][_][x][h][<-][T1 T2].
by exists i; exists x; exists h.
Qed.

Lemma try_dstrict : def_strict try_sp.
Proof.
move=>p y [i][x][h][H1][].
by case: x=>[x'|e'] H2; case/def_runs.
Qed.

Lemma try_has_spec : try_sp \In has_spec try_s.
Proof.
move=>i y m; case=>[[[/= S1 [S2 S3]]]] D [h][x][j][<-][].
case: x=>[x'|e'] T1 T2; [left; exists x' | right; exists e'];
exists j; by split; [apply: spec_runs T1 | apply: spec_runs T2].
Qed.

Definition try := STprog try_coherent try_dstrict try_has_spec.

End Try.

Definition conseq A (s1 s2 : spec A) :=
  forall i, s2.1 i -> def i ->
    s1.1 i /\ forall y m, s1.2 y i m -> def m -> s2.2 y i m.

Lemma conseq_refl (A : Type) (s : spec A) : conseq s s.
Proof. by []. Qed.

Hint Resolve conseq_refl : core.

Section Consequence.
Variables (A : Type) (s1 s2 : spec A) (e : ST s1) (pf : conseq s1 s2).

Definition do_sp (p : ideald s2.1) y m :=
  exists i, i \In id_val p /\ (i, y, m) \In runs_of (model e).

Lemma do_coherent : coherent do_sp.
Proof.
case=>q H y m; split.
- by case=>i [/= H1 T1]; exists i; exists H1; exists i.
by case=>i [/= H1][_][<-] T1; exists i.
Qed.

Lemma do_dstrict : def_strict do_sp.
Proof. by move=>q y [h][/= H]; case/def_runs. Qed.

Lemma do_has_spec : do_sp \In has_spec s2.
Proof.
move=>i y m [[/= S1 D1]][_][<-] T; case/def_runs: (T)=>_ S2 D2.
by apply: (proj2 (pf S1 D1)) D2; apply: spec_runs T.
Qed.

Definition Do := STprog do_coherent do_dstrict do_has_spec.

End Consequence.

Section Read.
Variable (A : Type) (x : ptr).

Definition read_s : spec A :=
  (fun i => x \in dom i /\ exists v:A, look x i = dyn v,
   fun y i m => m = i /\ forall v, look x i = dyn v -> y = Val v).

Definition read_sp (p : ideald read_s.1) (v : ans A) m :=
  m \In id_val p /\ exists w, v = Val w /\ look x m = dyn w.

Lemma read_coherent : coherent read_sp.
Proof.
move=>p v m; split; last first.
- by case=>i [H1][<-][w][->]; split=>//; exists w.
case=>H1 [w][->] H2.
by exists m; exists H1; split=>//; exists w.
Qed.

Lemma read_dstrict : def_strict read_sp.
Proof. by case=>p H y []; case/H. Qed.

Lemma read_has_spec : read_sp \In has_spec read_s.
Proof.
move=>i y m [[[/= H1]]][v] H2 D [<-][w][->] H3.
by split=>// b1; rewrite H3=>H; move:(dyn_inj H)=>->.
Qed.

Definition read := STprog read_coherent read_dstrict read_has_spec.

End Read.

Section Write.
Variable (A : Type) (x : ptr) (v : A).

Definition write_s : spec unit :=
  (fun i => x \in dom i : Prop,
   fun y i m => y = Val tt /\ upd i x (dyn v) = m).

Definition write_sp (p : ideald write_s.1) (y : ans unit) m :=
  exists i, i \In id_val p /\ x \in dom i /\
            y = Val tt /\ m = upd i x (dyn v).

Lemma write_coherent : coherent write_sp.
Proof.
move=>p y m; split; case=>i [H1].
- by case=>H2 [->->]; exists i; exists H1; exists i.
by case=>_ [<-][H2][->] ->; exists i.
Qed.

Lemma write_dstrict : def_strict write_sp.
Proof.
case=>p H y [i] /= [H1][H2][H3].
suff L: def (upd i x (dyn v)) by move=>H4; rewrite -H4 in L.
by rewrite defU (dom_null H2) (dom_def H2).
Qed.

Lemma write_has_spec : write_sp \In has_spec write_s.
Proof. by move=>i y m [[/= H1 D1]][_][<-][H2][->] ->. Qed.

Definition write := STprog write_coherent write_dstrict write_has_spec.

End Write.

Section Allocation.
Variables (A : Type) (v : A).

Definition alloc_s : spec ptr :=
  (fun i => def i : Prop,
   fun y i m => exists x, x != null /\ y = Val x /\ x \notin dom i /\
                          upd i x (dyn v) = m).

Definition alloc_sp (p : ideald alloc_s.1) y m :=
  exists i, i \In id_val p /\ exists l : ptr, y = Val l /\
    m = i :+ l :-> v /\ l != null /\ l \notin dom i.

Lemma alloc_coherent : coherent alloc_sp.
Proof.
move=>p x m; split.
- case=>i [H1][l][->][->][H2] H3.
  by exists i; exists H1; exists i; split=>//; exists l.
case=>i [H1][_][<-][l][->][->][H2] H3.
by exists i; split=>//; exists l.
Qed.

Lemma alloc_dstrict : def_strict alloc_sp.
Proof.
case=>p H y [m][/= H1][l][H2][H3][H4] H5; case/H: H1=>_ D.
suff {H3}: def (m :+ l :-> v) by rewrite -H3.
by rewrite unC defPtUn H4 D H5.
Qed.

Lemma alloc_has_spec : alloc_sp \In has_spec alloc_s.
Proof.
move=>i y m [[/= H D]][_][<-][l][->][->][H1] H2.
exists l; do !split=>//.
rewrite (_ : i = i :+ empty); last by rewrite unh0.
by rewrite updUnl (negbTE H2) unh0.
Qed.

Definition alloc := STprog alloc_coherent alloc_dstrict alloc_has_spec.

End Allocation.

Section BlockAllocation.
Variables (A : Type) (v : A) (n : nat).

Definition allocb_s : spec ptr :=
  (fun i => def i : Prop,
   fun y i m => exists r, y = Val r /\ m = i :+ updi r (nseq n v)).

Definition allocb_sp (p : ideald allocb_s.1) y m :=
  exists i, i \In id_val p /\ y = Val (fresh i) /\
            m = i :+ updi (fresh i) (nseq n v).

Lemma allocb_coherent : coherent allocb_sp.
Proof.
move=>p x m; split.
- by case=>i [H1][->] ->; exists i; exists H1; exists i.
by case=>i [H1][_][<-][->] ->; exists i.
Qed.

Lemma allocb_dstrict : def_strict allocb_sp.
Proof.
case=>p H y [m][/= H1][_] H2; case/H: H1=>_ D.
suff {H2}: def (m :+ updi (fresh m) (nseq n v)) by rewrite -H2.
elim: n =>[|k IH]; first by rewrite /= unh0.
rewrite (_ : nseq k.+1 v = rcons (nseq k v) v); last first.
- by elim: {IH} k=>[|k IH] //=; rewrite -IH.
rewrite updi_last unA unC defPtUn IH /=.
rewrite ptr_null negb_and fresh_null /=.
rewrite domUn !inE /= negb_and IH negb_or /=.
by rewrite dom_fresh updimV negb_and fresh_null ltnn.
Qed.

Lemma allocb_has_spec : allocb_sp \In has_spec allocb_s.
Proof. by move=>i y m [[/= H D]][_][<-][->] ->; exists (fresh i). Qed.

Definition allocb := STprog allocb_coherent allocb_dstrict allocb_has_spec.

End BlockAllocation.

Section Deallocation.
Variable x : ptr.

Definition dealloc_s : spec unit :=
  (fun i => x \in dom i : Prop,
   fun y i m => y = Val tt /\ free x i = m).

Definition dealloc_sp (p : ideald dealloc_s.1) (y : ans unit) m :=
  exists i, i \In id_val p /\ y = Val tt /\ x \in dom i /\ m = free x i.

Lemma dealloc_coherent : coherent dealloc_sp.
Proof.
move=>p y m; split.
- by case=>i [H1][->][H2] ->; exists i; exists H1; exists i.
by case=>i [H1][_][<-][->][H2] ->; exists i.
Qed.

Lemma dealloc_dstrict : def_strict dealloc_sp.
Proof.
case=>p H y [h][/=]; case/H=>_ H1 [H2][H3] H4.
suff: def (free x h) by rewrite -H4.
by rewrite defF.
Qed.

Lemma dealloc_has_spec : dealloc_sp \In has_spec dealloc_s.
Proof. by move=>i y m [[/= H1 D1]][_][<-][->][H2] ->. Qed.

Definition dealloc :=
  STprog dealloc_coherent dealloc_dstrict dealloc_has_spec.

End Deallocation.

End Model.


From Hammer Require Import Hammer.

Set Implicit Arguments.
Unset Standard Proposition Elimination Names.

From QuicksortComplexity Require Import util.
Require Import Le.
Require Import EqNat.
Require Import Compare_dec.
Require Import Bool.
Require Import Lt.
From QuicksortComplexity Require Import list_utils.
Require Import List.
Require Import Compare_dec.
From QuicksortComplexity Require Import monads.
From QuicksortComplexity Require Import monoid_monad_trans.
From QuicksortComplexity Require Import nat_seqs.
From QuicksortComplexity Require Import qs_definitions.
From QuicksortComplexity Require Import monoid_expec.
From QuicksortComplexity Require qs_parts.
From QuicksortComplexity Require Import sort_order.
From QuicksortComplexity Require Import indices.
Require Import Arith.
From QuicksortComplexity Require Import nat_below.
Require Vector.
From QuicksortComplexity Require ne_tree_monad.

Import mon_nondet.

Section contents.

Variable (e: E) (ol: list e).

Definition monoid := ListMonoid.M (nat * nat).

Definition M: Monad := MonoidMonadTrans.M monoid ne_tree_monad.ext.

Lemma Mext: extMonad M.
Proof. hammer_hook "U" "U.Mext". exact (MonoidMonadTrans.Mext monoid ne_tree_monad.ext). Qed.

Definition unordered_nat_pair (x y: nat): nat * nat :=
if le_lt_dec x y then (x, y) else (y, x).

Definition cmp (x y: Index e ol): M comparison
:= ret (unordered_nat_pair x y :: nil, Ecmp e (subscript x) (subscript y)).

Definition homo: monoidHomo monoid NatAddMonoid (fun x => length x).
Proof with auto. hammer_hook "U" "U.homo". apply Build_monoidHomo... simpl. intros. rewrite app_length... Qed.

Definition pick := monoid_tree_monad.pick monoid.

Require Import Rdefinitions.

Lemma partition d (l: list (Index e ol)):
partition M cmp d l =
ne_tree.Leaf (map (fun i: Index e ol => unordered_nat_pair i d) l, simplerPartition (UE e ol) d l).
Proof with auto. hammer_hook "U" "U.partition".
induction l...
simpl.
rewrite (@mon_assoc (ne_tree_monad.M)).
rewrite IHl.
simpl.
rewrite app_nil_r...
Qed.

Lemma simplePartition_component (ee: E) i cr l:
proj1_sig (simplerPartition ee i l) cr =
filter (fun f => unsum_bool (cmp_cmp (Ecmp ee f i) cr)) l.
Proof with auto. hammer_hook "U" "U.simplePartition_component".
induction l...
simpl.
rewrite IHl.
destruct (Ecmp ee a i); destruct cr...
Qed.

Section Uqs_ind.

Variable P: list (Index e ol) -> M (list (Index e ol)) -> Prop.
Hypothesis Pnil: P nil (ret nil).

Hypothesis Pcons: forall n (v: Vector.t (Index e ol) (S n)),
(forall x0 cr, P (filter (fun f: Index e ol => unsum_bool (cmp_cmp (Ecmp (UE e ol) f (vec.nth v x0)) cr)) (vec.to_list (vec.remove v x0))) (qs cmp pick (filter (fun f: Index e ol => unsum_bool (cmp_cmp (Ecmp (UE e ol) f (vec.nth v x0)) cr)) (vec.to_list (vec.remove v x0))))) ->
P (vec.to_list v)
(ne_tree.Node
(ne_list.map
(fun x0: natBelow (S n) =>
ne_tree.map
(map_fst (C:=list (Index e ol)) (app (map (fun i0: Index e ol => unordered_nat_pair i0 (vec.nth v x0)) (vec.to_list (vec.remove v x0)))))
(foo <- qs cmp pick (filter (fun f: Index e ol => unsum_bool (cmp_cmp (Ecmp (UE e ol) f (vec.nth v x0)) Lt)) (vec.to_list (vec.remove v x0)));
bar <- qs cmp pick (filter (fun f: Index e ol => unsum_bool (cmp_cmp (Ecmp (UE e ol) f (vec.nth v x0)) Gt)) (vec.to_list (vec.remove v x0)));
ret (foo ++ (vec.nth v x0 :: filter (fun f0: Index e ol => unsum_bool (cmp_cmp (Ecmp (UE e ol) f0 (vec.nth v x0)) Eq)) (vec.to_list (vec.remove v x0))) ++ bar)))
(ne_list.from_vec (vec.nats 0 (S n))))).

Theorem qs_ind: forall l, P l (qs cmp pick l).
Proof with auto. hammer_hook "U" "U.qs_ind".
apply qs_parts.rect...
apply Mext.
intros.
unfold qs_parts.body.
replace (qs_parts.selectPivotPart M pick cmp v) with (ne_tree.Node (ne_list.map (fun x0: natBelow (S n) => ne_tree.map (map_fst (app (map (fun i0: Index e ol => unordered_nat_pair i0 ((vec.nth v x0))) (vec.to_list (vec.remove v x0))))) (
foo <- qs cmp pick (filter (fun f: Index e ol => unsum_bool (cmp_cmp (Ecmp (UE e ol) f (vec.nth v x0)) Lt)) (vec.to_list (vec.remove v x0)));
bar <- qs cmp pick (filter (fun f: Index e ol => unsum_bool (cmp_cmp (Ecmp (UE e ol) f (vec.nth v x0)) Gt)) (vec.to_list (vec.remove v x0)));
ret (m:=ne_tree_monad.M) (nil, foo ++ (vec.nth v x0 :: filter (fun f0: Index e ol => unsum_bool (cmp_cmp (Ecmp (UE e ol) f0 (vec.nth v x0)) Eq)) (vec.to_list (vec.remove v x0))) ++ bar))) (ne_list.from_vec (vec.nats 0 (S n))))).
simpl @ret in Pcons.
Focus 1.
specialize (Pcons v).
simpl vec.to_list in Pcons.
apply Pcons. clear Pcons.
intros.
apply H.
rewrite length_filter.
apply le_lt_trans with (length (vec.to_list (vec.remove v x0))).
apply count_le.
rewrite vec.length...
unfold qs_parts.selectPivotPart.
unfold qs_parts.partitionPart.
unfold qs_parts.lowRecPart.
simpl.
f_equal.
repeat rewrite ne_list.map_map.
apply ne_list.map_ext. intro.
unfold compose. simpl.
rewrite ne_tree_monad.map_bind.
rewrite (@mon_assoc (ne_tree_monad.M)).
rewrite partition. simpl.
rewrite (@mon_assoc (ne_tree_monad.M)). simpl.
rewrite (@mon_assoc (ne_tree_monad.M)). simpl.
rewrite (@simplePartition_component (UE e ol)).
apply ne_tree_monad.ext. intro.
rewrite (@mon_assoc (ne_tree_monad.M)). simpl.
rewrite ne_tree_monad.map_bind.
rewrite (@mon_assoc (ne_tree_monad.M)). simpl.
rewrite (@mon_assoc (ne_tree_monad.M)). simpl.
rewrite (@simplePartition_component (UE e ol)).
apply ne_tree_monad.ext. intro.
unfold compose, map_fst.
simpl.
rewrite (@simplePartition_component (UE e ol)).
reflexivity.
Qed.

End Uqs_ind.

Lemma UcmpDec (x y: nat * nat): { x = y } + { x <> y }.
Proof with auto. hammer_hook "U" "U.UcmpDec".
intros.
destruct x.
destruct y.
destruct (eq_nat_dec n n1).
destruct (eq_nat_dec n0 n2).
subst.
left...
right. intro. inversion H...
right. intro. inversion H...
Qed.

Definition UcmpCmp (x y: nat * nat): bool := unsum_bool (UcmpDec x y).

Definition ijcount (i j: nat): monoid -> nat := count (UcmpCmp (i, j)).

Lemma ijcount_0 i j l: ~ In (i, j) l -> ijcount i j l = 0.
Proof with auto. hammer_hook "U" "U.ijcount_0".
unfold ijcount.
intros.
apply count_0.
intros.
unfold UcmpCmp.
case_eq (UcmpDec (i, j) x); intros...
elimtype False.
apply H.
rewrite e0...
Qed.

Lemma hom_ijcount i j: monoidHomo monoid NatAddMonoid (ijcount i j).
Proof with auto. hammer_hook "U" "U.hom_ijcount".
unfold ijcount.
intros.
apply Build_monoidHomo; intros; simpl...
apply count_app.
Qed.

Hint Resolve hom_ijcount.

Lemma ijcount_eq_count i j: ijcount i j = eq_count UcmpDec (i, j).
Proof. hammer_hook "U" "U.ijcount_eq_count". auto. Qed.

Definition qs: list (Index e ol) -> M (list (Index e ol)) := qs cmp pick.

End contents.


Require Import VerdiRaft.Raft.

Require Import VerdiRaft.CommonDefinitions.

Section LogMatchingInterface.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition log_matching_hosts (net : network) : Prop :=
    (forall h h', entries_match (log (nwState net h)) (log (nwState net h'))) /\
    (forall h i,
       1 <= i <= maxIndex (log (nwState net h)) ->
       exists e,
         eIndex e = i /\
         In e (log (nwState net h))) /\
    (forall h e,
       In e (log (nwState net h)) ->
       eIndex e > 0).

  Definition log_matching_nw (net : network) : Prop :=
    forall p t leaderId prevLogIndex prevLogTerm entries leaderCommit,
      In p (nwPackets net) ->
      pBody p = AppendEntries t leaderId prevLogIndex prevLogTerm entries leaderCommit ->
      (forall h e1 e2,
         In e1 entries ->
         In e2 (log (nwState net h)) ->
         eIndex e1 = eIndex e2 ->
         eTerm e1 = eTerm e2 ->
         (forall e3,
           eIndex e3 <= eIndex e1 ->
           In e3 entries ->
           In e3 (log (nwState net h))) /\
         (prevLogIndex <> 0 ->
          exists e4,
            eIndex e4 = prevLogIndex /\
            eTerm e4 = prevLogTerm /\
            In e4 (log (nwState net h)))) /\
      (forall i,
         prevLogIndex < i <= maxIndex entries ->
         exists e,
           eIndex e = i /\
           In e entries) /\
      (forall e,
         In e entries ->
         prevLogIndex < eIndex e) /\
      (forall p' t' leaderId' prevLogIndex' prevLogTerm' entries' leaderCommit',
         In p' (nwPackets net) ->
         pBody p' = AppendEntries t' leaderId' prevLogIndex' prevLogTerm' entries' leaderCommit' ->
         (forall e1 e2,
            In e1 entries ->
            In e2 entries' ->
            eIndex e1 = eIndex e2 ->
            eTerm e1 = eTerm e2 ->
            (forall e3,
               prevLogIndex' < eIndex e3 <= eIndex e1 ->
               In e3 entries ->
               In e3 entries') /\
            (forall e3,
               In e3 entries ->
               eIndex e3 = prevLogIndex' ->
               eTerm e3 = prevLogTerm') /\
            (prevLogIndex <> 0 -> prevLogIndex = prevLogIndex' -> prevLogTerm = prevLogTerm'))).

  Definition log_matching (net : network) : Prop :=
    log_matching_hosts net /\ log_matching_nw net.

  Class log_matching_interface : Prop :=
    {
      log_matching_invariant:
        forall net,
          raft_intermediate_reachable net ->
          log_matching net
    }.
End LogMatchingInterface.


From Hammer Require Import Hammer.

From WeakUpTo Require Export WeakMonotonic.
Set Implicit Arguments.

Section Global.

Variables A X Y: Type.
Variable TX: reduction_t A X.
Variable TY: reduction_t A Y.

Section MonotonicCorrect.

Variable F: function X Y.
Hypothesis HF: monotonic TX TY F.

Variable R: relation2 X Y.
Hypothesis HR: evolve TX TY R (F R).

Let phi: forall n, evolve TX TY (UExp F R n) (UExp F R (S n)).
Proof. hammer_hook "Theory" "Theory.Global.MonotonicCorrect.phi".
intro n; induction n as [ | n IH ].
intros l x x' y Hxx' xRy.
destruct (HR Hxx' xRy) as [ y']; exists y'; auto; right; assumption.
simpl; intro l; apply union2_evolve.
apply union2_evolve_left; auto.
apply union2_evolve_right.
destruct l as [ | a ].
apply (mon_t HF); [ unfold evolve_t; apply IH | left; auto ].
apply (mon_a HF); auto; left; auto.
Qed.

Theorem monotonic_correct: simulation TX TY (UIter F R).
Proof. hammer_hook "Theory" "Theory.monotonic_correct".
intro l; unfold UIter; union_evolve n; exists (S n); apply phi.
Qed.

End MonotonicCorrect.

Section WeakMonotonicCorrect.

Variable F: function X Y.
Hypothesis HF: wmonotonic TX TY F.

Variable R: relation2 X Y.
Hypothesis HRt: simulation_t TX TY R.
Hypothesis HRa: evolve_a TX TY R (F R).

Let silent: forall n, simulation_t TX TY (UExp F R n).
Proof. hammer_hook "Theory" "Theory.Global.WeakMonotonicCorrect.silent".
intro n; induction n as [ | n IH ]; auto.
simpl; unfold simulation_t, evolve_t.
apply union2_evolve.
apply union2_evolve_left; auto.
apply union2_evolve_right; apply (wmon_t HF IH).
Qed.

Lemma wmonotonic_correct_t: simulation_t TX TY (UIter F R).
Proof. hammer_hook "Theory" "Theory.wmonotonic_correct_t".
unfold UIter, simulation_t, evolve_t; union_evolve n; exists n; apply silent.
Qed.

Let visible: forall n, evolve_a TX TY (UExp F R n) (UExp F R (S n)).
Proof. hammer_hook "Theory" "Theory.Global.WeakMonotonicCorrect.visible".
intro n; induction n as [ | n IH ]; intro a; simpl.
apply union2_evolve_right; apply HRa.
apply union2_evolve.
apply union2_evolve_left; auto.
apply union2_evolve_right.
apply (wmon_a HF); auto.
apply (silent (S n)).
left; auto.
Qed.

Theorem wmonotonic_correct: simulation TX TY (UIter F R).
Proof. hammer_hook "Theory" "Theory.wmonotonic_correct".
intro l; destruct l.
apply wmonotonic_correct_t.
unfold UIter; union_evolve n; exists (S n); apply visible.
Qed.

End WeakMonotonicCorrect.

Section UnifiedCorrect.

Variables F G: function X Y.
Hypothesis HF : monotonic TX TY F.
Hypothesis HG : wmonotonic TX TY G.

Variable R: relation2 X Y.

Hypothesis HFG: contains F G.

Hypothesis HRt: evolve_t TX TY R (F R).
Hypothesis HRa: evolve_a TX TY R (G R).

Let pre_silent: forall n, evolve_t TX TY (UExp F R n) (UExp F R (S n)).
Proof. hammer_hook "Theory" "Theory.Global.UnifiedCorrect.pre_silent".
intro n; induction n as [ | n IH ]; simpl; unfold evolve_t.
apply union2_evolve_right; apply HRt.
apply union2_evolve.
apply union2_evolve_left; auto.
apply union2_evolve_right.
apply (mon_t HF); auto; left; auto.
Qed.
Let silent: simulation_t TX TY (UIter F R).
Proof. hammer_hook "Theory" "Theory.Global.UnifiedCorrect.silent".
unfold UIter, simulation_t, evolve_t; union_evolve n; exists (S n); apply pre_silent.
Qed.

Let HFGn: forall n, incl (UExp F R n) (UExp G R n).
Proof. hammer_hook "Theory" "Theory.Global.UnifiedCorrect.HFGn".
intro n; induction n as [ | n IH ]; simpl; auto.
intros x y H; destruct H.
left; auto.
right; apply (HFG (mon_m HF IH _ _ H)).
Qed.

Let pre_visible: forall n, evolve TX TY (UExp F R n) (UExp G R (S n)).
Proof. hammer_hook "Theory" "Theory.Global.UnifiedCorrect.pre_visible".
intros n; induction n as [ | n IH ]; simpl; intro l.
destruct l; auto.
apply evolve_incl with (F R); unfold evolve_1; auto; right; apply HFG; auto.
apply union2_evolve_right; auto.
apply union2_evolve; [ apply union2_evolve_left | apply union2_evolve_right ]; auto.
apply evolve_incl with (F (UExp G R (S n))); auto.
destruct l.
apply (mon_t HF (IH _)); left; apply HFGn; auto.
apply (mon_a HF IH); left; apply HFGn; auto.
Qed.
Let visible: evolve_a TX TY (UIter F R) (UIter G R).
Proof. hammer_hook "Theory" "Theory.Global.UnifiedCorrect.visible".
intro a; unfold UIter; union_evolve n; exists (S n); apply pre_visible.
Qed.

Let HGFGn: forall n, incl (UExp (UIter G) (UIter G R) n) (UExp (UIter G) R (S n)).
Proof. hammer_hook "Theory" "Theory.Global.UnifiedCorrect.HGFGn".
intro n; induction n as [ | n IH ].
right; auto.
intros x y H; celim H; intro H; auto.
left; auto.
right; exact (UIter_inc (wmon_m HG) IH H).
Qed.
Let HGFG: eeq (UIter (UIter G) (UIter F R)) (UIter (UIter G) R).
Proof. hammer_hook "Theory" "Theory.Global.UnifiedCorrect.HGFG".
split.
apply incl_trans with (UIter (UIter G) (UIter G R)).
repeat apply UIter_inc.
apply (wmon_m HG).
intros x y H; destruct H as [ n H ]; exists n; apply HFGn; assumption.
intros x y H; destruct H as [ n H ]; exists (S n); apply HGFGn; exact H.
repeat apply UIter_inc; auto; apply (wmon_m HG).
Qed.

Theorem unified_correct: simulation TX TY (UIter (UIter G) R).
Proof. hammer_hook "Theory" "Theory.unified_correct".
eapply simulation_eeq; try apply HGFG.
apply wmonotonic_correct.
apply UIter_wmon; exact HG.
exact silent.
intro a; apply evolve_incl with (UIter G R); auto.
apply UIter_inc; auto; apply (wmon_m HG).
Qed.

End UnifiedCorrect.

Section ControlledCorrect.

Variable B: relation X.
Hypothesis HB: controlled TX TY B.

Variables F G: function X Y.
Hypothesis HF : monotonic TX TY F.
Hypothesis HG : wmonotonic TX TY G.

Hypothesis HBF: transparent B F.
Hypothesis HFG: contains F G.
Hypothesis HBG: contains (chaining_l (star B)) G.

Variable R: relation2 X Y.
Hypothesis HRt: evolve_t TX TY R (comp (star B) (F R)).
Hypothesis HRa: evolve_a TX TY R (G R).

Let pre_silent: forall n, evolve_t TX TY (UExp F R n) (comp (star B) (UExp F R (S n))).
Proof. hammer_hook "Theory" "Theory.Global.ControlledCorrect.pre_silent".
intro n; induction n as [ | n IH ]; simpl; unfold evolve_t.
apply evolve_incl with (comp (star B) (F R)); auto;
intros x y H; destruct H as [ w ]; exists w; auto; right; auto.
apply union2_evolve.
eapply evolve_incl; [ apply comp_incl | apply IH ]; auto; left; exact H.
eapply evolve_incl; try apply (mon_t HF IH).
eapply incl_trans; try apply HBF; apply comp_incl; auto; right; auto.
intros x y H; exists x; auto; left; auto.
Qed.
Let silent: simulation_t TX TY (comp (star B) (UIter F R)).
Proof. hammer_hook "Theory" "Theory.Global.ControlledCorrect.silent".
apply (ctrl_t HB).
unfold UIter, evolve_t; apply union_evolve; intro n.
apply evolve_incl with (union (fun n: nat => comp (star B) (UExp F R n))).
intros x y H; destruct H as [ j H ]; destruct H as [ w ]; exists w; auto; exists j; auto.
apply evolve_union; exists (S n); apply pre_silent.
Qed.

Let HFGn: forall n, incl (UExp F R n) (UExp G R n).
Proof. hammer_hook "Theory" "Theory.Global.ControlledCorrect.HFGn".
intro n; induction n as [ | n IH ]; simpl; auto.
intros x y H; destruct H.
left; auto.
right; apply (HFG (mon_m HF IH _ _ H)).
Qed.
Let HBGGn: forall R n, incl (comp (star B) (UExp G R n)) (UExp G R (S n)).
Proof. hammer_hook "Theory" "Theory.Global.ControlledCorrect.HBGGn". intros RR n x y H; right; apply (HBG H). Qed.

Let pre_visible: forall n, evolve TX TY (UExp F R n) (UExp G R (2+n)).
Proof. hammer_hook "Theory" "Theory.Global.ControlledCorrect.pre_visible".
intros n; induction n as [ | n IH ]; intro l.
destruct l.
apply evolve_incl with (comp (star B) (F R)); auto.
intros x y H; destruct H as [ w H H' ]; right; apply HBG; exists w; auto; right; apply (HFG H').
simpl; apply union2_evolve_left; auto; apply union2_evolve_right; auto.
simpl; apply union2_evolve.
apply union2_evolve_left; auto.
apply union2_evolve_right; auto.
destruct l; eapply evolve_incl;
try (apply (mon_t HF (IH _)) || apply (mon_a HF IH)); auto;
apply incl_trans with (UExp G R n); auto; intros x y H; left; left; exact H.
Qed.
Let visible: evolve_a TX TY (comp (star B) (UIter F R)) (UIter G (comp (star B) (UIter F R))).
Proof. hammer_hook "Theory" "Theory.Global.ControlledCorrect.visible".
intro a; apply evolve_incl with (comp (star B) (UIter G (comp (star B) (UIter F R)))).
intros x y H; destruct H as [ w XW WY ]; destruct WY as [ n WY ]; exists (S n); apply HBGGn; exists w; auto.
apply (ctrl_a HB); auto.
intros x x' y Hxx' xRy; elim (silent (y:=y) Hxx'); [ intros y'; exists y' | exists x ]; auto.
union_evolve n; exists n; induction n as [ | n IH ]; auto; simpl; apply union2_evolve;
[ apply union2_evolve_left; apply IH | apply union2_evolve_right; apply (wmon_t HG IH) ].
clear a; intro a; union_evolve n; exists (2+n);
eapply evolve_incl; try apply pre_visible;
apply (UExp_inc (wmon_m HG)); intros x; exists x; auto; exists 0; auto.
intros x; exists 0; exists x; auto.
Qed.

Let HGGBF: eeq (UIter (UIter G) (comp (star B) (UIter F R))) (UIter (UIter G) R).
Proof. hammer_hook "Theory" "Theory.Global.ControlledCorrect.HGGBF".
split.
intros x y H; destruct H as [ n H ]; exists (S n).
cgen H; cgen y; cgen x; induction n as [ | n IH ]; intros x y H.
destruct H as [ w XW WY ]; destruct WY as [ n ].
right; exists (S n); apply HBGGn; exists w; auto; apply HFGn; auto.
celim H; intro H.
left; apply IH; auto.
right; exact (UIter_inc (wmon_m HG) IH H).
intros x y H; apply (UIter_inc (UIter_inc (wmon_m HG)) (R:=R)); auto.
intros u v K; exists u; auto; exists 0; auto.
Qed.

Theorem controlled_correct: simulation TX TY (UIter (UIter G) R).
Proof. hammer_hook "Theory" "Theory.controlled_correct".
eapply simulation_eeq; try apply HGGBF.
exact (wmonotonic_correct (UIter_wmon HG) silent visible).
Qed.

End ControlledCorrect.

End Global.