Set Implicit Arguments.

Require Import Coq.Lists.List.

Require Import Bedrock.Labels.
Require Import Bedrock.LabelMap.
Require Bedrock.Platform.Cito.LabelMapFacts.
Require Import Bedrock.Platform.Cito.GLabel.
Require Import Bedrock.Platform.Cito.GLabelMap.
Import GLabelMap.
Require Import Bedrock.Platform.Cito.GLabelMapFacts.

Require Import Bedrock.Platform.Cito.ConvertLabel.

Definition to_bl_pair elt (p : glabel * elt) := (fst p : label, snd p).

Definition to_blm elt m := LabelMapFacts.of_list (List.map (@to_bl_pair _) (@elements elt m)).

Module Notations.
  Notation "m1 === m2" := (LabelMap.Equal m1 (to_blm m2)) (at level 70) : clm_scope.
End Notations.

Section TopSection.

  Import Notations.
  Open Scope clm_scope.
  Import ListNotations.
  Import FMapNotations.
  Open Scope fmap.

  Require Import Coq.Setoids.Setoid.
  Require Import Coq.Lists.SetoidList.
  Require Import Bedrock.Platform.Cito.GeneralTactics.
  Require Import Bedrock.Platform.Cito.ListFacts1.

  Set Printing Coercions.

  Lemma NoDupKey_to_bl_pair_elements : forall elt m, LabelMapFacts.NoDupKey (List.map (@to_bl_pair _) (@elements elt m)).
    intros.
    eapply LabelMapFacts.NoDupKey_NoDup_fst.
    rewrite map_map.
    unfold to_bl_pair; simpl in *.
    rewrite <- map_map.
    eapply Injection_NoDup.
    unfold to_bedrock_label.
    unfold IsInjection; intuition.
    destruct x; destruct y; simpl in *.
    injection H0; intros; subst.
    intuition.
    eapply NoDupKey_NoDup_fst.
    eapply elements_3w.
  Qed.

  Lemma to_blm_spec : forall elt (k : glabel) m, @LabelMap.find elt (k : label) (to_blm m) = find k m.
    unfold to_blm, LabelMapFacts.to_map.
    intros.
    eapply option_univalence; split; intros.
    eapply LabelMap.find_2 in H.
    eapply LabelMapFacts.of_list_1 in H.
    eapply LabelMapFacts.InA_eqke_In in H.
    eapply in_map_iff in H.
    openhyp.
    destruct x; simpl in *.
    unfold to_bl_pair, to_bedrock_label in *; simpl in *.
    destruct g; simpl in *.
    destruct k; simpl in *.
    injection H; intros; subst.
    eapply InA_eqke_In in H0.
    eapply elements_mapsto_iff in H0.
    eapply find_1; eauto.
    eapply NoDupKey_to_bl_pair_elements.

    eapply LabelMap.find_1.
    eapply LabelMapFacts.of_list_1.
    eapply NoDupKey_to_bl_pair_elements.
    eapply LabelMapFacts.InA_eqke_In.
    eapply in_map_iff.
    exists (k, v); split; eauto.
    eapply InA_eqke_In.
    eapply elements_1.
    eapply find_2.
    eauto.
  Qed.

  Lemma to_blm_no_local : forall elt s1 s2 m, @LabelMap.find elt (s1, Local s2) (to_blm m) = None.
    unfold to_blm, LabelMapFacts.to_map.
    intros.
    eapply LabelMapFacts.not_in_find.
    intuition.
    eapply LabelMapFacts.In_MapsTo in H.
    openhyp.
    eapply LabelMapFacts.of_list_1 in H.
    eapply LabelMapFacts.InA_eqke_In in H.
    eapply in_map_iff in H.
    openhyp.
    unfold to_bl_pair, to_bedrock_label in *; simpl in *.
    discriminate.
    eapply NoDupKey_to_bl_pair_elements.
  Qed.

  Lemma to_blm_local_not_in : forall elt s1 s2 m, ~ @LabelMap.In elt (s1, Labels.Local s2) (to_blm m).
    intros.
    eapply LabelMapFacts.not_find_in_iff.
    rewrite to_blm_no_local; eauto.
  Qed.

  Lemma to_blm_mapsto_iff : forall elt k (v : elt) m, LabelMap.MapsTo k v (to_blm m) <-> exists k' : glabel, MapsTo k' v m /\ k = (k' : label).
    split; intros.
    destruct k.
    destruct l.
    replace ((s, Labels.Global s0)) with (to_bedrock_label (s, s0)) in * by eauto.
    eapply LabelMap.find_1 in H.
    rewrite to_blm_spec in H.
    eapply find_2 in H.
    eexists; eauto.
    eapply LabelMapFacts.MapsTo_In in H.
    eapply to_blm_local_not_in in H; intuition.
    openhyp.
    subst.
    eapply LabelMap.find_2.
    rewrite to_blm_spec.
    eapply find_1; eauto.
  Qed.

  Lemma to_blm_Equal : forall elt m1 m2, @LabelMap.Equal elt (to_blm m1) (to_blm m2) <-> m1 == m2.
    unfold Equal, LabelMap.Equal.
    intuition.
    repeat erewrite <- to_blm_spec.
    eauto.
    destruct y.
    destruct l.
    replace ((s, Labels.Global s0)) with (to_bedrock_label (s, s0)) by eauto.
    repeat erewrite to_blm_spec.
    eauto.
    repeat rewrite to_blm_no_local.
    eauto.
  Qed.

  Global Add Parametric Morphism elt : (@to_blm elt)
      with signature Equal ==> LabelMap.Equal as to_blm_Equal_m.
    intros; eapply to_blm_Equal; eauto.
  Qed.

  Lemma to_blm_In : forall elt (k : glabel) m, @LabelMap.In elt (k : label) (to_blm m) <-> In k m.
    split; intros.
    eapply in_find_iff.
    eapply LabelMapFacts.in_find_iff in H.
    rewrite <- to_blm_spec.
    eauto.
    eapply in_find_iff in H.
    eapply LabelMapFacts.in_find_iff.
    rewrite to_blm_spec.
    eauto.
  Qed.

  Lemma to_blm_Compat : forall elt m1 m2, @LabelMapFacts.Compat elt (to_blm m1) (to_blm m2) <-> Compat m1 m2.
    unfold Compat, LabelMapFacts.Compat.
    intuition.
    repeat erewrite <- to_blm_spec.
    eapply H.
    eapply to_blm_In; eauto.
    eapply to_blm_In; eauto.
    destruct k.
    destruct l.
    replace ((s, Labels.Global s0)) with (to_bedrock_label (s, s0)) by eauto.
    repeat erewrite to_blm_spec.
    eapply H.
    eapply to_blm_In; eauto.
    eapply to_blm_In; eauto.
    repeat rewrite to_blm_no_local.
    eauto.
  Qed.

  Global Add Parametric Morphism elt : (@to_blm elt)
      with signature (@Compat elt) ==> (@LabelMapFacts.Compat elt) as to_blm_Compat_m.
    intros; eapply to_blm_Compat; eauto.
  Qed.

  Lemma to_blm_empty : forall elt, LabelMap.empty elt === {}.
    unfold Equal, LabelMap.Equal.
    intuition.
  Qed.

  Require Import Bedrock.Platform.Cito.GeneralTactics2.

  Lemma to_blm_update : forall elt m1 m2, @LabelMap.Equal elt (to_blm (update m1 m2)) (LabelMapFacts.update (to_blm m1) (to_blm m2)).
    unfold Equal, LabelMap.Equal.
    intros.
    destruct y.
    destruct l; simpl.
    replace ((s, Labels.Global s0)) with (to_bedrock_label (s, s0)) by eauto.
    repeat erewrite to_blm_spec.
    destruct (In_dec m2 (s, s0)).
    rewrite update_o_2 by eauto.
    rewrite LabelMapFacts.update_o_2.
    repeat erewrite to_blm_spec.
    eauto.
    eapply to_blm_In; eauto.
    rewrite update_o_1 by eauto.
    rewrite LabelMapFacts.update_o_1.
    repeat erewrite to_blm_spec.
    eauto.
    not_not.
    eapply to_blm_In; eauto.
    repeat rewrite to_blm_no_local.
    symmetry.
    eapply LabelMapFacts.not_in_find.
    intuition.
    eapply LabelMapFacts.update_in_iff in H.
    openhyp.
    eapply to_blm_local_not_in; eauto.
    eapply to_blm_local_not_in; eauto.
  Qed.

  Lemma to_blm_diff : forall elt m1 m2, @LabelMap.Equal elt (to_blm (diff m1 m2)) (LabelMapFacts.diff (to_blm m1) (to_blm m2)).
    unfold Equal, LabelMap.Equal.
    intros.
    destruct y.
    destruct l; simpl.
    replace ((s, Labels.Global s0)) with (to_bedrock_label (s, s0)) by eauto.
    repeat erewrite to_blm_spec.
    destruct (In_dec m2 (s, s0)).
    rewrite diff_o_none by eauto.
    rewrite LabelMapFacts.diff_o_none.
    eauto.
    eapply to_blm_In; eauto.
    rewrite diff_o by eauto.
    rewrite LabelMapFacts.diff_o.
    repeat erewrite to_blm_spec.
    eauto.
    not_not.
    eapply to_blm_In; eauto.
    repeat rewrite to_blm_no_local.
    symmetry.
    eapply LabelMapFacts.not_in_find.
    intuition.
    eapply LabelMapFacts.diff_in_iff in H.
    openhyp.
    eapply to_blm_local_not_in; eauto.
  Qed.

  Lemma to_blm_add : forall elt (k : glabel) v m, @LabelMap.Equal elt (to_blm (add k v m)) (LabelMap.add (k : label) v (to_blm m)).
    unfold Equal, LabelMap.Equal.
    intros.
    destruct y.
    destruct l; simpl.
    replace ((s, Labels.Global s0)) with (to_bedrock_label (s, s0)) by eauto.
    repeat erewrite to_blm_spec.
    rewrite add_o.
    destruct (eq_dec k (s, s0)).
    subst.
    symmetry.
    rewrite LabelMapFacts.add_eq_o; eauto.
    rewrite LabelMapFacts.add_neq_o.
    repeat erewrite to_blm_spec; eauto.
    not_not.
    unfold to_bedrock_label in *.
    destruct k; simpl in *.
    injection H; intros; subst.
    eauto.
    repeat rewrite to_blm_no_local.
    symmetry.
    eapply LabelMapFacts.not_in_find.
    intuition.
    eapply LabelMapFacts.add_in_iff in H.
    unfold to_bedrock_label in *.
    destruct k; simpl in *.
    openhyp.
    discriminate.
    eapply to_blm_local_not_in; eauto.
  Qed.

End TopSection.


Require Import Rel.Definitions.
Require Import Lang.BindingsFacts.
Require Import Lang.Sig.
Require Import Lang.SigFacts.
Require Import Wf_natnat.
Require Import Compat_sub.
Require Import Compat_map_EV.
Require Import Compat_map_LV.
Set Implicit Arguments.

Implicit Types EV LV V L : Set.

Section section_EV_bind_aux.

Hint Extern 0 => match goal with
| [ |- ?n ⊨ ?X ⇔ ?X ] => apply auto_contr_id
| [ |- ?n ⊨ ?X ≈ᵢ ?X ] => repeat iintro ; apply auto_contr_id
| [ |- Acc lt' (_, _) ] => try lt'_solve
| [ H : _ ⊨ (False)ᵢ |- _ ] => icontradict H
end.

Fixpoint
  EV_bind_𝓥_aux
  n EV EV' LV
  (Ξ : XEnv EV LV)
  (f : EV → eff ∅ EV' LV ∅)
  (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig)
  (δ₁' δ₂' : EV' → eff0) (δ' : EV' → IRel 𝓤_Sig)
  (ρ₁ ρ₂ : LV → lbl0) (ρ : LV → IRel 𝓣_Sig)
  (Hδ₁ : ∀ α, δ₁ α = subst_eff δ₁' ρ₁ (f α))
  (Hδ₂ : ∀ α, δ₂ α = subst_eff δ₂' ρ₂ (f α))
  (Hδ :
    n ⊨ ∀ᵢ α ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂,
        𝓾⟦ Ξ ⊢ ef_var α ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂ ⇔
        𝓤⟦ (EV_bind_XEnv f Ξ) ⊢ f α ⟧ δ₁' δ₂' δ' ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂
  )
  (ξ₁ ξ₂ : list var)
  (v₁ v₂ : val0) (T : ty ∅ EV LV ∅)
  (W : Acc lt' (n, size_ty T))
  {struct W} :
  (n ⊨
    𝓥⟦ Ξ ⊢ T ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ v₁ v₂ ⇔
    𝓥⟦ (EV_bind_XEnv f Ξ) ⊢ EV_bind_ty f T ⟧ δ₁' δ₂' δ' ρ₁ ρ₂ ρ ξ₁ ξ₂ v₁ v₂)
with
  EV_bind_𝓜_aux
  n EV EV' LV
  (Ξ : XEnv EV LV)
  (f : EV → eff ∅ EV' LV ∅)
  (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig)
  (δ₁' δ₂' : EV' → eff0) (δ' : EV' → IRel 𝓤_Sig)
  (ρ₁ ρ₂ : LV → lbl0) (ρ : LV → IRel 𝓣_Sig)
  (Hδ₁ : ∀ α, δ₁ α = subst_eff δ₁' ρ₁ (f α))
  (Hδ₂ : ∀ α, δ₂ α = subst_eff δ₂' ρ₂ (f α))
  (Hδ :
    n ⊨ ∀ᵢ α ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂,
        𝓾⟦ Ξ ⊢ ef_var α ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂ ⇔
        𝓤⟦ (EV_bind_XEnv f Ξ) ⊢ f α ⟧ δ₁' δ₂' δ' ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂
  )
  (ξ₁ ξ₂ : list var)
  (m₁ m₂ : md0) (σ : ms ∅ EV LV ∅) (ℓ : lbl LV ∅)
  (W : Acc lt' (n, size_ms σ))
  {struct W} :
  (n ⊨
    𝓜⟦ Ξ ⊢ σ ^ ℓ ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ m₁ m₂ ⇔
    𝓜⟦ (EV_bind_XEnv f Ξ) ⊢ (EV_bind_ms f σ) ^ ℓ ⟧ δ₁' δ₂' δ' ρ₁ ρ₂ ρ ξ₁ ξ₂ m₁ m₂)
with
  EV_bind_𝓾_aux
  n EV EV' LV
  (Ξ : XEnv EV LV)
  (f : EV → eff ∅ EV' LV ∅)
  (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig)
  (δ₁' δ₂' : EV' → eff0) (δ' : EV' → IRel 𝓤_Sig)
  (ρ₁ ρ₂ : LV → lbl0) (ρ : LV → IRel 𝓣_Sig)
  (Hδ₁ : ∀ α, δ₁ α = subst_eff δ₁' ρ₁ (f α))
  (Hδ₂ : ∀ α, δ₂ α = subst_eff δ₂' ρ₂ (f α))
  (Hδ :
    n ⊨ ∀ᵢ α ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂,
        𝓾⟦ Ξ ⊢ ef_var α ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂ ⇔
        𝓤⟦ (EV_bind_XEnv f Ξ) ⊢ f α ⟧ δ₁' δ₂' δ' ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂
  )
  (ξ₁ ξ₂ : list var)
  (t₁ t₂ : tm0) (ψ : IRel 𝓣_Sig) l₁ l₂ (ε : ef ∅ EV LV ∅)
  (W : Acc lt' (n, 0))
  {struct W} :
  (n ⊨
    𝓾⟦ Ξ ⊢ ε ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂ ⇔
    𝓤⟦ (EV_bind_XEnv f Ξ) ⊢ EV_bind_ef f ε ⟧ δ₁' δ₂' δ' ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂)
with
  EV_bind_𝓤_aux
  n EV EV' LV
  (Ξ : XEnv EV LV)
  (f : EV → eff ∅ EV' LV ∅)
  (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig)
  (δ₁' δ₂' : EV' → eff0) (δ' : EV' → IRel 𝓤_Sig)
  (ρ₁ ρ₂ : LV → lbl0) (ρ : LV → IRel 𝓣_Sig)
  (Hδ₁ : ∀ α, δ₁ α = subst_eff δ₁' ρ₁ (f α))
  (Hδ₂ : ∀ α, δ₂ α = subst_eff δ₂' ρ₂ (f α))
  (Hδ :
    n ⊨ ∀ᵢ α ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂,
        𝓾⟦ Ξ ⊢ ef_var α ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂ ⇔
        𝓤⟦ (EV_bind_XEnv f Ξ) ⊢ f α ⟧ δ₁' δ₂' δ' ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂
  )
  (ξ₁ ξ₂ : list var)
  (t₁ t₂ : tm0) (ψ : IRel 𝓣_Sig) l₁ l₂ (E : eff ∅ EV LV ∅)
  (W : Acc lt' (n, size_eff E))
  {struct W} :
  (n ⊨
    𝓤⟦ Ξ ⊢ E ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂ ⇔
    𝓤⟦ (EV_bind_XEnv f Ξ) ⊢ EV_bind_eff f E ⟧ δ₁' δ₂' δ' ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂)
with
  EV_bind_𝓣𝓵_aux
  n EV EV' LV
  (Ξ : XEnv EV LV)
  (f : EV → eff ∅ EV' LV ∅)
  (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig)
  (δ₁' δ₂' : EV' → eff0) (δ' : EV' → IRel 𝓤_Sig)
  (ρ₁ ρ₂ : LV → lbl0) (ρ : LV → IRel 𝓣_Sig)
  (Hδ₁ : ∀ α, δ₁ α = subst_eff δ₁' ρ₁ (f α))
  (Hδ₂ : ∀ α, δ₂ α = subst_eff δ₂' ρ₂ (f α))
  (Hδ :
    n ⊨ ∀ᵢ α ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂,
        𝓾⟦ Ξ ⊢ ef_var α ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂ ⇔
        𝓤⟦ (EV_bind_XEnv f Ξ) ⊢ f α ⟧ δ₁' δ₂' δ' ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂
  )
  (ξ₁ ξ₂ : list var)
  (t₁ t₂ : tm0) (ℓ : lbl LV ∅)
  (W : Acc lt' (n, size_lbl Ξ ℓ))
  {struct W} :
  (n ⊨
    𝓣𝓵⟦ Ξ ⊢ ℓ ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ⇔
    𝓣𝓵⟦ (EV_bind_XEnv f Ξ) ⊢ ℓ ⟧ δ₁' δ₂' δ' ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂)
.

Proof.
{
destruct T as [ | Ta Ea Tb Eb | N ℓ | σ ℓ ] eqn:HT ; simpl 𝓥_Fun.
+ auto.
+ auto_contr.
  apply 𝓚_Fun_nonexpansive ; repeat iintro ;
  apply 𝓣_Fun_Fix'_nonexpansive ; repeat iintro ; auto.
+ auto_contr.
  apply 𝓥_roll_unroll_iff.
  match goal with
  | [ |- ?n ⊨ 𝓥⟦ _ ⊢ ?T ⟧ _ _ _ _ _ _ _ _ _ _ ⇔
              𝓥⟦ _ ⊢ ?T' ⟧ _ _ _ _ _ _ _ _ _ _ ] =>
    replace T' with (EV_bind_ty f T)
    by (simpl ; erewrite EV_bind_it_msig ; crush)
  end.
  apply EV_bind_𝓥_aux ; auto.
+ auto_contr.
  apply EV_bind_𝓜_aux ; auto.
}

{
destruct σ as [ τ | τ | τ | Ta Ea ] eqn:Hσ ; simpl 𝓜_Fun.
+ auto_contr.
  erewrite <- EV_bind_map_XEnv ; [ | ].
  apply EV_bind_𝓜_aux ; [ | | | auto ].
  - intro α ; destruct α ; simpl ; [ rewrite app_nil_r ; reflexivity | ].
    rewrite Hδ₁.
    erewrite LV_bind_EV_map_eff, EV_bind_map_eff, EV_map_eff_id ; try reflexivity.
    intro ; erewrite EV_map_eff_id ; reflexivity.
  - intro α ; destruct α ; simpl ; [ rewrite app_nil_r ; reflexivity | ].
    rewrite Hδ₂.
    erewrite LV_bind_EV_map_eff, EV_bind_map_eff, EV_map_eff_id ; try reflexivity.
    intro ; erewrite EV_map_eff_id ; reflexivity.
  - iintro α ; repeat iintro ; destruct α ; simpl.
    * isplit ; iintro' H ; [ ileft | idestruct H as H H ] ; auto.
    * iespecialize Hδ.
      eapply I_iff_transitive ; [ apply Hδ | ].
      replace (EV_bind_XEnv (EV_lift_inc f) (EV_shift_XEnv Ξ))
      with (EV_shift_XEnv (EV_bind_XEnv f Ξ))
      by (erewrite EV_bind_map_XEnv ; reflexivity).
      apply EV_map_𝓤 ; auto.
      repeat iintro ; simpl ; apply auto_contr_id.
  - reflexivity.
+ auto_contr.
  erewrite <- EV_bind_LV_map_XEnv ; [ | ].
  apply EV_bind_𝓜_aux ; [ | | | auto ].
  - intro ; rewrite Hδ₁.
    unfold compose.
    erewrite LV_bind_map_eff, EV_bind_LV_map_eff, LV_map_eff_id ; try reflexivity.
    * intro ; erewrite LV_map_eff_id ; reflexivity.
    * intro ; erewrite LV_map_lbl_id ; reflexivity.
  - intro ; rewrite Hδ₂.
    unfold compose.
    erewrite LV_bind_map_eff, EV_bind_LV_map_eff, LV_map_eff_id ; try reflexivity.
    * intro ; erewrite LV_map_eff_id ; reflexivity.
    * intro ; erewrite LV_map_lbl_id ; reflexivity.
  - iintro α ; repeat iintro.
    iespecialize Hδ ; unfold compose.
    eapply I_iff_transitive ; [ apply Hδ | ].
    clear.
    erewrite EV_bind_LV_map_XEnv ; [ | reflexivity ].
    apply LV_map_𝓤 ;
    try (simpl ; reflexivity) ;
    try (repeat iintro ; simpl ; apply auto_contr_id).
  - auto.
+ auto_contr.
  - apply EV_bind_𝓥_aux ; auto.
  - apply EV_bind_𝓜_aux ; auto.
+ rewrite EV_bind_XEnv_dom.
  auto_contr.
  apply 𝓗_Fun_nonexpansive ; repeat iintro.
  - apply 𝓣_Fun_Fix'_nonexpansive ; repeat iintro ; [ auto | ].
    auto_contr.
    * apply 𝓗_Fun_nonexpansive ; repeat iintro ; [ auto_contr | ].
      apply EV_bind_𝓣𝓵_aux ; auto.
    * apply EV_bind_𝓤_aux ; auto.
  - apply EV_bind_𝓣𝓵_aux ; auto.
}

{
destruct ε as [ | α | [ α | [ α | X ] ] ] ; simpl.
+ auto.
+ iespecialize Hδ ; apply Hδ.
+ isplit ; iintro' H ; [ ileft ; apply H | ].
  idestruct H as H H ; [ apply H | auto ].
+ destruct α.
+ match goal with
  | [ |- n ⊨ ?P ⇔ ?Q ∨ᵢ (False)ᵢ ] =>
    cut (n ⊨ P ⇔ Q)
  end.
  { clear ; intro H.
    isplit ; iintro' H' ; [ ileft | idestruct H' as H' H' ; [ | auto ] ].
    + erewrite <- I_iff_elim_M ; eassumption.
    + erewrite I_iff_elim_M ; eassumption.
  }
  rewrite EV_bind_XEnv_dom.
  auto_contr.
  apply 𝓗_Fun_nonexpansive ; repeat iintro.
  - auto_contr.
  - destruct (get X Ξ) as [ [T E] | ] eqn:HX.
    * eapply binds_EV_bind in HX ; rewrite HX.
      apply 𝓣_Fun_Fix'_nonexpansive ; repeat iintro.
      { apply 𝓥_roll_unroll_iff ; auto. }
      { apply 𝓤_roll_unroll_iff ; auto. }
    * apply get_none_inv in HX.
      erewrite <- EV_bind_XEnv_dom in HX.
      apply get_none in HX.
      rewrite HX ; auto_contr.
}

{
destruct E as [ | ε E ] ; simpl ; [ auto | ].
isplit ; iintro' H.
+ idestruct H as H H.
  - eapply ccompat_se with (E := EV_bind_ef f ε).
    * crush.
    * erewrite <- I_iff_elim_M ; [ apply H | ].
      apply EV_bind_𝓾_aux ; auto.
  - apply ccompat_se with (E := EV_bind_eff f E).
    * crush.
    * erewrite <- I_iff_elim_M ; [ apply H | ].
      apply EV_bind_𝓤_aux ; auto.
+ apply ccompat_eff_In_inverse in H.
  destruct H as [ε' [Hε' H]].
  apply in_app_or in Hε'.
  destruct Hε' as [Hε' | Hε'] ; [ ileft | iright ].
  - eapply ccompat_eff_In in Hε' ; [ clear H | apply H ].
    erewrite I_iff_elim_M ; [ apply Hε' | ].
    apply EV_bind_𝓾_aux ; auto.
  - eapply ccompat_eff_In in Hε' ; [ clear H | apply H ].
    erewrite I_iff_elim_M ; [ apply Hε' | ].
    apply EV_bind_𝓤_aux ; auto.
}

{
destruct ℓ as [ α | [ | X ] ] ; simpl ; [ auto_contr | auto_contr | ].
destruct (get X Ξ) as [ [T E] | ] eqn:HX.
* simpl in W ; rewrite HX in W.
  eapply binds_EV_bind in HX as HX'; rewrite HX'.
  apply 𝓣_Fun_Fix'_nonexpansive ; repeat iintro.
  { apply 𝓥_roll_unroll_iff ; auto. }
  { apply 𝓤_roll_unroll_iff ; auto. }
* apply get_none_inv in HX.
  erewrite <- EV_bind_XEnv_dom in HX.
  apply get_none in HX.
  rewrite HX ; auto_contr.
}

Qed.

End section_EV_bind_aux.

Section section_EV_bind.
Context (n : nat).
Context (EV EV' LV : Set).
Context (Ξ : XEnv EV LV).
Context (f : EV → eff ∅ EV' LV ∅).
Context (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig).
Context (δ₁' δ₂' : EV' → eff0) (δ' : EV' → IRel 𝓤_Sig).
Context (ρ₁ ρ₂ : LV → lbl0) (ρ : LV → IRel 𝓣_Sig).
Context (Hδ₁ : ∀ α, δ₁ α = subst_eff δ₁' ρ₁ (f α)).
Context (Hδ₂ : ∀ α, δ₂ α = subst_eff δ₂' ρ₂ (f α)).
Context (Hδ :
  n ⊨ ∀ᵢ α ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂,
      𝓾⟦ Ξ ⊢ ef_var α ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂ ⇔
      𝓤⟦ (EV_bind_XEnv f Ξ) ⊢ f α ⟧ δ₁' δ₂' δ' ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂
).

Hint Resolve lt'_wf.

Lemma EV_bind_𝓥 T ξ₁ ξ₂ v₁ v₂ :
n ⊨
  𝓥⟦ Ξ ⊢ T ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ v₁ v₂ ⇔
  𝓥⟦ (EV_bind_XEnv f Ξ) ⊢ EV_bind_ty f T ⟧ δ₁' δ₂' δ' ρ₁ ρ₂ ρ ξ₁ ξ₂ v₁ v₂.
Proof.
apply EV_bind_𝓥_aux ; auto.
Qed.

Lemma EV_bind_𝓜 σ ℓ ξ₁ ξ₂ m₁ m₂ :
n ⊨
  𝓜⟦ Ξ ⊢ σ ^ ℓ ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ m₁ m₂ ⇔
  𝓜⟦ (EV_bind_XEnv f Ξ) ⊢ (EV_bind_ms f σ) ^ ℓ ⟧ δ₁' δ₂' δ' ρ₁ ρ₂ ρ ξ₁ ξ₂ m₁ m₂.
Proof.
apply EV_bind_𝓜_aux ; auto.
Qed.

Lemma EV_bind_𝓤 E ξ₁ ξ₂ t₁ t₂ ψ L₁ L₂ :
n ⊨
  𝓤⟦ Ξ ⊢ E ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ L₁ L₂ ⇔
  𝓤⟦ (EV_bind_XEnv f Ξ) ⊢ EV_bind_eff f E ⟧ δ₁' δ₂' δ' ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ L₁ L₂.
Proof.
apply EV_bind_𝓤_aux ; auto.
Qed.

Hint Resolve EV_bind_𝓥 EV_bind_𝓤.

Lemma EV_bind_𝓣 T E ξ₁ ξ₂ t₁ t₂ :
n ⊨
  𝓣⟦ Ξ ⊢ T # E ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ⇔
  𝓣⟦ (EV_bind_XEnv f Ξ) ⊢ (EV_bind_ty f T) # (EV_bind_eff f E) ⟧
  δ₁' δ₂' δ' ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂.
Proof.
apply 𝓣_Fun_Fix'_nonexpansive ; repeat iintro ; auto.
Qed.

End section_EV_bind.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Import ssrnat.
Require Import seq.
Require Import cfmap.
Require Import cfreducible.
Require Import configurations.

Lemma red106to164 : reducible_in_range 106 164 the_configs.
Proof. CheckReducible. Qed.


(** printing ⊢#    %\vdash_{\#}%    #⊢##     *)
(** printing ⊢##   %\vdash_{\#\#}%  #⊢&#35&#35#  *)
(** printing ⊢##v  %\vdash_{\#\#v}% #⊢&#35&#35v# *)
(** printing ⊢!    %\vdash_!%       #⊢!#         *)
(** remove printing ~ *)

Set Implicit Arguments.

Require Import Coq.Program.Equality String.
Require Import Definitions Subenvironments Weakening.

(** * Narrowing Lemma *)
(** The narrowing lemma states that typing is preserved under subenvironments.
    The lemma corresponds to Lemma 3.11 in the paper.
    The proof is by mutual induction on term typing, definition typing,
    and subtyping. *)

(** [G ⊢ t: T]                 #
#
    [G' subG G]                #
#
    [ok G']                    #
#
    [―――――――――――――――――]        #
#
    [G' ⊢ t: T]

    and

    [G ⊢ d: D]                 #
#
    [G' subG G]                #
#
    [ok G']                    #
#
    [―――――――――――――――――]        #
#
    [G' ⊢ d: D]

    and

    [G ⊢ ds :: T]              #
#
    [G' subG G]                #
#
    [ok G']                    #
#
    [―――――――――――――――――]        #
#
    [G' ⊢ ds :: T]

    and

    [G ⊢ S <: U]               #
#
    [G' subG G]                #
#
    [ok G']                    #
#
    [―――――――――――――――――]        #
#
    [G' ⊢ S <: U]              #
#

Note: for simplicity, the definition typing judgements and [ok] conditions
      are omitted from the paper formulation. *)
Lemma narrow_rules:
  (forall G t T, G ⊢ t : T -> forall G',
    G' ⪯ G ->
    G' ⊢ t : T)
/\ (forall G d D, G /- d : D -> forall G',
    G' ⪯ G ->
    G' /- d : D)
/\ (forall G ds T, G /- ds :: T -> forall G',
    G' ⪯ G ->
    G' /- ds :: T)
/\ (forall G S U, G ⊢ S <: U -> forall G',
    G' ⪯ G ->
    G' ⊢ S <: U).
Proof.
    apply rules_mutind; intros;
    match goal with
    | [ B: binds _ _ _, H : ?G' ⪯ _ |- _ ⊢ trm_var (avar_f _) : _ ] =>
      induction H; [auto | apply binds_push_inv in B];
        destruct_all; [ subst; eapply ty_sub | idtac];
          eauto using ty_var, weaken_subtyp, weaken_ty_trm
    | _ => try fresh_constructor; eauto
    end.
Qed.

(** The narrowing lemma, formulated only for term typing. *)
Lemma narrow_typing: forall G G' t T,
  G ⊢ t : T ->
  G' ⪯ G ->
  G' ⊢ t : T.
Proof.
  intros. apply* narrow_rules.
Qed.

(** The narrowing lemma, formulated only for subtyping. *)
Lemma narrow_subtyping: forall G G' S U,
  G ⊢ S <: U ->
  G' ⪯ G ->
  G' ⊢ S <: U.
Proof.
  intros. apply* narrow_rules.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal21.

Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma conj1synthconj2 : forall  (lv0 : lst), (@eq lst (append Nil lv0) lv0).
Admitted.
QuickChick conj1synthconj2.


Require Import VST.floyd.proofauto.
Require Import sha.sha.
Require Import sha.SHA256.
Require Import sha.spec_sha.
Require Import sha.sha_lemmas.
Require Import sha.bdo_lemmas.
Local Open Scope logic.

Definition load8 id ofs :=
 (Sset id
      (Ederef
        (Ebinop Oadd
          (Efield
            (Ederef (Etempvar _ctx (tptr t_struct_SHA256state_st))
              t_struct_SHA256state_st) _h (tarray tuint 8))
          (Econst_int (Int.repr ofs) tint) (tptr tuint)) tuint)).

Lemma Znth_is_int:
 forall i r,
  0 <=  i < Zlength r ->
  is_int I32 Unsigned (Znth i (map Vint r)).
Proof.
intros.
unfold Znth.
rewrite if_false by omega.
rewrite (nth_map' Vint Vundef Int.zero).
apply I.
destruct H as [H0 H]; rewrite Zlength_correct in H.
rewrite <- (Z2Nat.id i) in H; auto.
apply Nat2Z.inj_lt in H; auto.
Qed.

Lemma sha256_block_load8:
  forall (Espec : OracleKind)
     (data: val) (r_h: list int) (ctx: val) gv (wsh: share)
   (Hwsh: writable_share wsh)
   (H5 : length r_h = 8%nat),
     semax
         (func_tycontext f_sha256_block_data_order Vprog Gtot nil)
  (PROP  ()
   LOCAL  (temp _data data; temp _ctx ctx; temp _in data;
                gvars gv)
   SEP  (field_at wsh t_struct_SHA256state_st  [StructField _h] (map Vint r_h) ctx))
   (Ssequence (load8 _a 0)
     (Ssequence (load8 _b 1)
     (Ssequence (load8 _c 2)
     (Ssequence (load8 _d 3)
     (Ssequence (load8 _e 4)
     (Ssequence (load8 _f 5)
     (Ssequence (load8 _g 6)
     (Ssequence (load8 _h 7)
         Sskip))))))))
  (normal_ret_assert
  (PROP  ()
   LOCAL  (temp _a (Vint (nthi r_h 0));
                temp _b (Vint (nthi r_h 1));
                temp _c (Vint (nthi r_h 2));
                temp _d (Vint (nthi r_h 3));
                temp _e (Vint (nthi r_h 4));
                temp _f (Vint (nthi r_h 5));
                temp _g (Vint (nthi r_h 6));
                temp _h (Vint (nthi r_h 7));
                temp _data data; temp _ctx ctx; temp _in data;
                gvars gv)
   SEP  (field_at wsh t_struct_SHA256state_st  [StructField _h] (map Vint r_h) ctx))).
Proof.
intros.
unfold load8.
abbreviate_semax.
assert (H5': Zlength r_h = 8%Z)
  by (rewrite Zlength_correct; rewrite H5; reflexivity).
do 8 forward.
entailer!.
Qed.

Definition get_h (n: Z) :=
    Sset _t
        (Ederef
           (Ebinop Oadd
              (Efield
                 (Ederef (Etempvar _ctx (tptr t_struct_SHA256state_st))
                    t_struct_SHA256state_st) _h (tarray tuint 8))
              (Econst_int (Int.repr n) tint) (tptr tuint)) tuint).

Definition add_h (n: Z) (i: ident) :=
   Sassign
       (Ederef
          (Ebinop Oadd
             (Efield
                (Ederef (Etempvar _ctx (tptr t_struct_SHA256state_st))
                   t_struct_SHA256state_st) _h (tarray tuint 8))
             (Econst_int (Int.repr n) tint) (tptr tuint)) tuint)
       (Ebinop Oadd (Etempvar _t tuint) (Etempvar i tuint) tuint).

Definition add_them_back :=
 [get_h 0; add_h 0 _a;
  get_h 1; add_h 1 _b;
  get_h 2; add_h 2 _c;
  get_h 3; add_h 3 _d;
  get_h 4; add_h 4 _e;
  get_h 5; add_h 5 _f;
  get_h 6; add_h 6 _g;
  get_h 7; add_h 7 _h].

Fixpoint add_upto (k: nat) (u v: list int) {struct k} :=
 match k with
 | O => u
 | S k' => match u,v with
                | u1::us, v1::vs => Int.add u1 v1 :: add_upto k' us vs
                | _, _ => u
                end
 end.

Lemma length_add_upto:
  forall i r s,
   length r = length s  ->
   length (add_upto i r s) = length r.
Proof.
induction i; destruct r,s; intros;
 inv H; simpl; auto.
Qed.

Lemma force_lengthn_short:
  forall {A} i (b: list A) v,
     (i <= length b)%nat -> force_lengthn i b v = firstn i b.
Proof.
induction i; destruct b; intros.
reflexivity.
reflexivity.
inv H.
simpl. f_equal. apply IHi. simpl in H. omega.
Qed.

Lemma add_upto_S:
  forall (atoh regs : list int) (i : nat),
  length atoh = 8%nat ->
  length regs = 8%nat ->
   (i < 8)%nat ->
  map Vint (add_upto (S i) regs atoh) =
  upd_Znth (Z.of_nat i) (map Vint (add_upto i regs atoh))
   (Vint
     (Int.add (nthi (add_upto i regs atoh) (Z.of_nat i))
        (nthi atoh (Z.of_nat i)))).
Proof.
intros. rename H1 into H4.
 assert ( i < length (add_upto i regs atoh))%nat
    by (rewrite length_add_upto; omega).
 unfold upd_Znth.
 rewrite !sublist_map, <- map_cons, <- map_app.
 f_equal.

assert (H18: length regs = length atoh) by congruence.
assert (H19: (i < length regs)%nat) by omega.
clear - H18 H19.
revert regs atoh H18 H19; induction i; destruct regs,atoh; intros;
try solve [inv H19]; inv H18.
simpl.
f_equal.
change (i::regs) with ([i]++regs).
autorewrite with sublist. auto.
simpl in H19.
change (add_upto (S (S i)) (i0 :: regs) (i1 :: atoh))
  with (Int.add i0 i1 :: add_upto (S i) regs atoh).
simpl in H19.
rewrite (IHi regs atoh); auto; [ | omega].
clear IHi.
simpl add_upto.
rewrite (sublist_split 0 1 (Z.of_nat (S i))); try omega.
change (@sublist int 0 1) with (@sublist int 0 (0+1)).
rewrite sublist_len_1; try omega.
rewrite inj_S.
simpl.
autorewrite with sublist.
f_equal.
f_equal.
change (cons (Int.add i0 i1)) with (app [Int.add i0 i1]).
rewrite sublist_app2 by (autorewrite with sublist; omega).
f_equal.
autorewrite with sublist; omega.
f_equal.
f_equal.
unfold nthi.
rewrite Z2Nat.inj_succ by omega.
reflexivity.
unfold nthi.
rewrite Z2Nat.inj_succ by omega.
reflexivity.
change (cons (Int.add i0 i1)) with (app [Int.add i0 i1]).
rewrite sublist_app2 by (autorewrite with sublist; omega).
f_equal.
autorewrite with sublist; omega.
autorewrite with sublist; omega.
autorewrite with sublist. Omega1.
rewrite inj_S.
split; try omega.
rewrite Zlength_cons.
unfold Z.succ.
apply Zplus_le_compat_r.
rewrite Zlength_correct.
rewrite length_add_upto; auto.
apply Nat2Z.inj_le; auto.
omega.
Qed.

Lemma upd_reptype_array_gso: (* perhaps move to floyd? *)
 forall t (a: list (reptype t)) v i j,
    0 <= j <= Zlength a ->
    0 <= i < Zlength a ->
    i<>j ->
    Znth i (upd_Znth j a v) = Znth i a.
Proof.
intros.
unfold upd_Znth.
assert (i<j \/ i>j) by omega.
clear H1; destruct H2.
autorewrite with sublist; auto.
autorewrite with sublist; auto.
change (cons v) with (app [v]).
autorewrite with sublist; auto.
f_equal; omega.
Qed.

Lemma int_add_upto:
  forall (regs atoh: list int),
   Datatypes.length regs = 8%nat ->
   Datatypes.length atoh = 8%nat ->
   forall (j:nat)  (i:Z),
     j = Z.to_nat i ->
     0 <= i < 8 ->
     is_int I32 Unsigned (Znth i (map Vint (add_upto j  regs atoh))).
Proof.
intros until 2.
  assert (ZR: Zlength regs = 8) by ( rewrite Zlength_correct, H; reflexivity).
  induction j; intros.
  simpl. apply Znth_is_int; omega.
  unfold Znth.
  rewrite if_false by omega.
 rewrite nth_map' with (d' := Int.zero).
  apply I.
  rewrite length_add_upto by omega.
  rewrite H. apply Nat2Z.inj_lt.
  rewrite Z2Nat.id by omega. apply H2.
Qed.

Lemma add_s:
  forall (regs atoh: list int),
   Datatypes.length regs = 8%nat ->
   Datatypes.length atoh = 8%nat ->
 forall i i',
    (i < 8)%nat ->
    i' = Z.of_nat i ->
    upd_Znth i' (map Vint (add_upto i regs atoh))
             (Vint
                (Int.add
                   (Znth i' (add_upto i regs atoh))
                   (nthi atoh i'))) =
     map Vint (add_upto (S i) regs atoh).
Proof.
intros.
assert (is_int I32 Unsigned (Znth i' (map Vint (add_upto i regs atoh)))).
 apply  Znth_is_int.   rewrite Zlength_correct, length_add_upto, H.
 change (Z.of_nat 8) with 8; omega. rewrite H,H0;  auto.
subst i'.
rewrite add_upto_S; try omega.
f_equal.
destruct (Znth (Z.of_nat i) (map Vint (add_upto i regs atoh)));
   try contradiction H3.
simpl.
f_equal. f_equal.
unfold Znth. rewrite if_false by omega.
unfold nthi.
rewrite Nat2Z.id. auto.
Qed.

Lemma add_upto_8:
  forall (regs atoh: list int),
   Datatypes.length regs = 8%nat ->
   Datatypes.length atoh = 8%nat ->
    add_upto 8 regs atoh = map2 Int.add regs atoh.
Proof.
intros.
destruct atoh as [ | a [ | b [ | c [ | d [ | e [ | f [ | g [ | h [ | ]]]]]]]]]; inv H0.
destruct regs as [ | a' [ | b' [ | c' [ | d' [ | e' [ | f' [ | g' [ | h' [ | ]]]]]]]]]; inv H.
simpl; auto.
Qed.

Lemma add_them_back_proof:
  forall (Espec : OracleKind)
     (regs regs': list int) (ctx: val) gv (wsh: share) (Hwsh: writable_share wsh),
     length regs = 8%nat ->
     length regs' = 8%nat ->
     semax  (func_tycontext f_sha256_block_data_order Vprog Gtot nil)
   (PROP  ()
   LOCAL  (temp _ctx ctx;
                temp _a  (Vint (nthi regs' 0));
                temp _b  (Vint (nthi regs' 1));
                temp _c  (Vint (nthi regs' 2));
                temp _d  (Vint (nthi regs' 3));
                temp _e  (Vint (nthi regs' 4));
                temp _f  (Vint (nthi regs' 5));
                temp _g  (Vint (nthi regs' 6));
                temp _h  (Vint (nthi regs' 7));
                gvars gv)
   SEP
   (field_at wsh t_struct_SHA256state_st  [StructField _h] (map Vint regs) ctx))
   (sequence add_them_back Sskip)
  (normal_ret_assert
   (PROP() LOCAL(temp _ctx ctx; gvars gv)
    SEP (field_at wsh t_struct_SHA256state_st  [StructField _h]
                (map Vint (map2 Int.add regs regs')) ctx))).
Proof.
intros.
rename regs' into atoh.
unfold sequence, add_them_back.
change regs with  (add_upto 0 regs atoh) at 1.
unfold get_h, add_h.
abbreviate_semax.
assert (ZR: Zlength regs = 8) by (rewrite Zlength_correct, H; reflexivity).
assert (INT_ADD_UPTO := int_add_upto _ _ H H0).
assert (ADD_S := add_s _ _ H H0).

Opaque add_upto.
assert (forall i i', i'=Z.of_nat i -> 0<= i' <8 -> 0 <= i' < Zlength (add_upto i regs atoh)). {
 intros;
 rewrite Zlength_correct; rewrite length_add_upto by omega;
 rewrite H; simpl; omega.
}
assert (0<=0) by computable.
forward.
forward.
autorewrite with sublist.
rewrite ADD_S by (try reflexivity; clear; omega).
forward; forward.
autorewrite with sublist.
simpl upd_Znth; rewrite ADD_S by (try reflexivity; clear; omega).
forward; forward.
autorewrite with sublist.
simpl upd_Znth; rewrite ADD_S by (try reflexivity; clear; omega).
forward; forward.
autorewrite with sublist.
simpl upd_Znth; rewrite ADD_S by (try reflexivity; clear; omega).
forward; forward.
autorewrite with sublist.
simpl upd_Znth; rewrite ADD_S by (try reflexivity; clear; omega).
forward; forward.
autorewrite with sublist.
simpl upd_Znth; rewrite ADD_S by (try reflexivity; clear; omega).
forward; forward.
autorewrite with sublist.
simpl upd_Znth; rewrite ADD_S by (try reflexivity; clear; omega).
forward; forward.
autorewrite with sublist.
simpl upd_Znth; rewrite ADD_S by (try reflexivity; clear; omega).
rewrite (add_upto_8 _ _ H H0).
entailer!.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* 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 Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export projection_orthogonale.
Require Export angles_droites.
Set Implicit Arguments.
Unset Strict Implicit.

Lemma deux_hauteurs_trois :
 forall A B C H : PO,
 orthogonal (vec H A) (vec B C) ->
 orthogonal (vec H B) (vec A C) -> orthogonal (vec H C) (vec A B).
intros.
apply def_orthogonal2.
replace (vec H C) with (add_PP (vec H A) (vec A C)) by Ringvec.
lapply (def_orthogonal (A:=H) (B:=A) (C:=B) (D:=C)); auto; intros.
lapply (def_orthogonal (A:=H) (B:=B) (C:=A) (D:=C)); auto; intros.
Simplscal.
replace (scalaire (vec H A) (vec A B)) with (scalaire (vec H A) (vec A C)).
replace (scalaire (vec H A) (vec A C) + scalaire (vec A C) (vec A B))  with
 (scalaire (add_PP (vec H A) (vec A B)) (vec A C)).
replace (add_PP (vec H A) (vec A B)) with (vec H B); auto.
Ringvec.
Simplscal.
rewrite (scalaire_sym A B A C); auto.
replace (vec A B) with (add_PP (vec A C) (vec C B)).
Simplscal.
replace (vec C B) with (mult_PP (-1) (vec B C)).
Simplscal.
rewrite H2; ring.
Ringvec.
Ringvec.
Qed.

Lemma triangle_rectangle_une_fois :
 forall A B C : PO,
 triangle A B C ->
 orthogonal (vec A B) (vec A C) ->
 ~ orthogonal (vec A B) (vec B C) /\ ~ orthogonal (vec A C) (vec C B).
intros.
cut (triangle A C B); intros; auto with geo.
deroule_triangle A C B.
split; [ try assumption | idtac ].
red in |- *; intros; apply H2.
elim orthogonal_paralleles with (A := A) (B := B) (C := C) (E := B) (F := C);
 [ intros k H7; try exact H7
 | auto with geo
 | auto with geo
 | auto with geo
 | auto with geo ].
apply colineaire_alignes with (- k + 1); auto.
replace (vec A B) with (add_PP (mult_PP (-1) (vec B C)) (vec A C));
 [ idtac | Ringvec ].
rewrite H7; Ringvec.
deroule_triangle A B C.
red in |- *; intros; apply H6.
elim orthogonal_paralleles with (A := A) (B := C) (C := B) (E := C) (F := B);
 [ intros k H11; try exact H11
 | auto with geo
 | auto with geo
 | auto with geo
 | auto with geo ].
apply colineaire_alignes with (- k + 1); auto.
replace (vec A C) with (add_PP (mult_PP (-1) (vec C B)) (vec A B));
 [ idtac | Ringvec ].
rewrite H11; Ringvec.
Qed.

Lemma triangle_distincts_pied_hauteur :
 forall A B C H : PO,
 triangle A B C -> H = projete_orthogonal A B C -> C <> H :>PO.
intros.
deroule_triangle A B C.
elim (def_projete_orthogonal2 (A:=A) (B:=B) (C:=C) (H:=H)); auto; intros.
red in |- *; intros; apply H2.
rewrite H8; auto.
Qed.
Require Export Droite_espace.

Lemma triangle_hauteurs_secantes :
 forall A B C H K : PO,
 triangle A B C ->
 H = projete_orthogonal A B C ->
 K = projete_orthogonal A C B -> concours (droite C H) (droite B K).
intros.
deroule_triangle A B C.
elim (def_projete_orthogonal2 (A:=A) (B:=B) (C:=C) (H:=H)); auto; intros.
elim (def_projete_orthogonal2 (A:=A) (B:=C) (C:=B) (H:=K)); auto; intros.
cut (C <> H); intros.
cut (B <> K); intros.
elim (position_relative_droites_coplanaires (A:=C) (B:=H) (C:=B) (D:=K));
 auto with geo; intros.
absurd (paralleles (droite C H) (droite B K)); auto.
apply angle_non_paralleles; auto.
rewrite
 (angles_droites_orthogonales (A:=A) (B:=C) (C:=A) (D:=B) (E:=B) (F:=K)
    (G:=C) (I:=H)); auto with geo.
apply (triangle_distincts_pied_hauteur (A:=A) (B:=C) (C:=B) (H:=K));
 auto with geo.
apply (triangle_distincts_pied_hauteur (A:=A) (B:=B) (C:=C) (H:=H));
 auto with geo.
Qed.

Lemma aux :
 forall A B C H K : PO,
 triangle A B C ->
 H = projete_orthogonal A B C :>PO ->
 K = projete_orthogonal A C B :>PO -> ~ alignes C H B \/ ~ alignes C H K.
intros.
deroule_triangle A B C.
elim (def_projete_orthogonal2 (A:=A) (B:=B) (C:=C) (H:=H)); auto; intros.
elim (def_projete_orthogonal2 (A:=A) (B:=C) (C:=B) (H:=K)); auto; intros.
cut (C <> H); intros.
cut (B <> K); intros.
elim (classic (orthogonal (vec B A) (vec B C))); intros.
cut (H = B); intros.
right; try assumption.
rewrite H14.
cut (~ orthogonal (vec A C) (vec B C)); intros.
red in |- *; intros; apply H15.
assert (alignes B K C); auto with geo.
halignes H17 k.
apply ortho_sym.
rewrite H18.
Simplortho.
elim triangle_rectangle_une_fois with (A := B) (B := A) (C := C);
 [ try clear triangle_rectangle_une_fois; intros | auto with geo | auto ].
red in |- *; intros; apply H16.
auto with geo.
apply unicite_projete_orthogonal with (2 := H7) (3 := H8); auto with geo.
left.
red in |- *; intros; apply H13.
halignes H14 k.
apply ortho_sym.
replace (vec B C) with (mult_PP (-1) (vec C B)); [ idtac | Ringvec ].
rewrite H15.
replace (mult_PP (-1) (mult_PP k (vec C H))) with (mult_PP k (vec H C));
 [ idtac | Ringvec ].
Simplortho.
apply (triangle_distincts_pied_hauteur (A:=A) (B:=C) (C:=B) (H:=K));
 auto with geo.
apply (triangle_distincts_pied_hauteur (A:=A) (B:=B) (C:=C) (H:=H)); auto.
Qed.

Lemma existence_intersection_deux_hauteurs_triangle :
 forall A B C H K : PO,
 triangle A B C ->
 H = projete_orthogonal A B C :>PO ->
 K = projete_orthogonal A C B :>PO ->
 ex (fun I : PO => I = pt_intersection (droite C H) (droite B K) :>PO).
intros.
cut (~ alignes C H B \/ ~ alignes C H K); intros.
apply existence_pt_intersection; auto.
apply (triangle_distincts_pied_hauteur (A:=A) (B:=B) (C:=C) (H:=H)); auto.
apply (triangle_distincts_pied_hauteur (A:=A) (B:=C) (C:=B) (H:=K));
 auto with geo.
apply triangle_hauteurs_secantes with (A := A); auto.
apply aux with (A := A); auto.
Qed.
Parameter orthocentre : PO -> PO -> PO -> PO.

Axiom
  orthocentre_def :
    forall A B C H : PO,
    orthogonal (vec H A) (vec B C) ->
    orthogonal (vec H B) (vec A C) ->
    orthogonal (vec H C) (vec A B) -> H = orthocentre A B C :>PO.

Axiom
  orthocentre_def2 :
    forall A B C H : PO,
    H = orthocentre A B C :>PO ->
    (orthogonal (vec H A) (vec B C) /\ orthogonal (vec H B) (vec A C)) /\
    orthogonal (vec H C) (vec A B).

Lemma orthocentre_ordre :
 forall A B C H : PO,
 triangle A B C -> H = orthocentre A B C :>PO -> H = orthocentre C A B :>PO.
intros.
elim orthocentre_def2 with (A := A) (B := B) (C := C) (H := H);
 [ intros | auto ].
elim H2; intros H4 H5; try clear H2; try exact H5.
apply orthocentre_def; auto with geo.
Qed.

Lemma orthocentre_permute :
 forall A B C H : PO,
 triangle A B C -> H = orthocentre A B C :>PO -> H = orthocentre B A C :>PO.
intros.
elim orthocentre_def2 with (A := A) (B := B) (C := C) (H := H);
 [ intros | auto ].
elim H2; intros H4 H5; try clear H2; try exact H5.
apply orthocentre_def; auto with geo.
Qed.
#[export] Hint Immediate orthocentre_ordre orthocentre_permute: geo.

Lemma orthocentre_triangle_rectangle :
 forall A B C : PO,
 triangle A B C ->
 orthogonal (vec A B) (vec B C) -> B = orthocentre A B C :>PO.
intros.
apply orthocentre_def; auto with geo.
replace (vec B B) with zero; auto with geo.
Ringvec.
Qed.

Lemma intersection_deux_hauteurs_orthocentre_triangle :
 forall A B C H K I : PO,
 triangle A B C ->
 H = projete_orthogonal A B C :>PO ->
 K = projete_orthogonal A C B :>PO ->
 I = pt_intersection (droite C H) (droite B K) :>PO ->
 I = orthocentre A B C :>PO.
intros A B C H K I H0 H2 H3 H4.
deroule_triangle A B C.
elim (def_projete_orthogonal2 (A:=A) (B:=B) (C:=C) (H:=H)); auto; intros.
elim (def_projete_orthogonal2 (A:=A) (B:=C) (C:=B) (H:=K)); auto; intros.
cut (C <> H); intros.
cut (B <> K); intros.
cut (~ alignes C H B \/ ~ alignes C H K); intros.
elim def_pt_intersection2 with (A := C) (B := H) (C := B) (D := K) (I := I);
 [ try clear def_pt_intersection2; intros | auto | auto | auto | auto ].
halignes H16 k.
halignes H15 k0.
cut (orthogonal (vec I B) (vec A C) /\ orthogonal (vec I C) (vec A B));
 intros.
elim H19; intros H20 H21; try clear H19; try exact H21.
apply orthocentre_def; auto.
apply deux_hauteurs_trois.
auto with geo.
auto with geo.
split; [ idtac | try assumption ].
replace (vec I B) with (mult_PP (-1) (vec B I)).
rewrite H17.
replace (mult_PP (-1) (mult_PP k (vec B K))) with (mult_PP k (vec K B)).
Simplortho.
Ringvec.
Ringvec.
replace (vec I C) with (mult_PP (-1) (vec C I)).
rewrite H18.
replace (mult_PP (-1) (mult_PP k0 (vec C H))) with (mult_PP k0 (vec H C)).
Simplortho.
Ringvec.
Ringvec.
apply aux with (A := A); auto.
apply (triangle_distincts_pied_hauteur (A:=A) (B:=C) (C:=B) (H:=K));
 auto with geo.
apply (triangle_distincts_pied_hauteur (A:=A) (B:=B) (C:=C) (H:=H)); auto.
Qed.

Lemma orthocentre_intersection_hauteurs :
 forall A B C H K I : PO,
 triangle A B C ->
 H = projete_orthogonal A B C :>PO ->
 K = projete_orthogonal A C B :>PO ->
 I = orthocentre A B C :>PO ->
 I = pt_intersection (droite C H) (droite B K) :>PO.
intros.
elim orthocentre_def2 with (A := A) (B := B) (C := C) (H := I);
 [ intros | auto ].
elim H4; intros H6 H7; try clear H4; try exact H7.
cut (~ alignes C H B \/ ~ alignes C H K); intros.
deroule_triangle A B C.
elim (def_projete_orthogonal2 (A:=A) (B:=B) (C:=C) (H:=H)); auto; intros.
elim (def_projete_orthogonal2 (A:=A) (B:=C) (C:=B) (H:=K)); auto; intros.
cut (C <> H); intros.
cut (B <> K); intros.
apply def_pt_intersection; auto.
elim
 orthogonal_colineaires
  with (A := A) (B := B) (C := H) (D := C) (E := C) (F := I);
 [ intros k H18; try exact H18
 | auto with geo
 | auto with geo
 | auto with geo
 | auto with geo ].
apply colineaire_alignes with (- k); auto.
rewrite H18; Ringvec.
elim
 orthogonal_colineaires
  with (A := A) (B := C) (C := K) (D := B) (E := B) (F := I);
 [ intros k H18; try exact H18
 | auto with geo
 | auto with geo
 | auto with geo
 | auto with geo ].
apply colineaire_alignes with (- k); auto.
rewrite H18; Ringvec.
apply (triangle_distincts_pied_hauteur (A:=A) (B:=C) (C:=B) (H:=K));
 auto with geo.
apply (triangle_distincts_pied_hauteur (A:=A) (B:=B) (C:=C) (H:=H)); auto.
apply aux with (A := A); auto.
Qed.


Require Export MinBFT.
(* Require Export CorrectKeys. *)

Section MinBFT_at_most_f_byz.

  (*  Context { pk  : @Key }.    if I add this one MinBFT_at_most_f_byz1 complains, but it still does not solve my problem *)
  Local Open Scope eo.
  Local Open Scope proc.

  Context { minbft_context      : MinBFT_context }.
  Context { minbft_initial_keys : MinBFT_initial_keys }.
(*  Context { dm                  : DataMessage }. *)
  Context { minbft_auth         : MinBFT_auth }.
  Context { usig_hash : USIG_hash }.

  (* This says that all the events [e] _at all time_ that happen
      at non-faulty locations (not in the [faulty] list are indeed non-faulty *)
  Definition MinBFT_at_most_f_byz1 (eo : EventOrdering) :=
    exists (faulty : list Rep),
      length faulty <= F
      /\
      forall (e : Event),
        ~ In (loc e) (map MinBFT_replica faulty)
        -> isCorrect e.

  Lemma MinBFT_at_most_f_byz1_implies :
    forall (eo : EventOrdering) L,
      MinBFT_at_most_f_byz1 eo -> AXIOM_exists_at_most_f_faulty L F.
  Proof.
    introv atmost.
    unfold MinBFT_at_most_f_byz1 in *.
    exrepnd.
    exists faulty.
    repnd; dands; auto.
    introv i j k eqn w.
    apply atmost0.
    introv xx; allrw in_map_iff; exrepnd; subst.
    assert (loc e' = loc e1) as eqloc by eauto with eo.
    rewrite k in eqloc; rewrite <- xx1 in eqloc; simpl in eqloc; ginv.
  Qed.
  Hint Resolve MinBFT_at_most_f_byz1_implies : pbft.

(*  Check (fun i => @M_state_sm_before_event
                    MinBFT_I_Node
                    MinBFT_I_Key
                    MinBFT_I_Msg
                    baseFunIOusig
                    2
                    (MinBFT_replicaSM i)).
*)

  Definition AXIOM_MinBFT_correct_keys (eo : EventOrdering) :=
    forall (e : Event) (i : Rep) st,
      node_has_correct_trace_before e i
      -> M_state_sm_before_event (MinBFT_replicaSM i) e = st
      -> st >p>= (fun sop => match sop with
                            | Some s => ret _ (keys e = local_keys s)
                            | None => ret _ True
                            end).

  Definition default_local_key_map : local_key_map :=
    MkLocalKeyMap [] [].

  Definition MinBFT_get_keys0 (i : name) : MinBFT_nstate i -> local_key_map :=
    match i with
    | MinBFT_replica i => fun s => local_keys s
    | MinBFT_client _  => fun _ => default_local_key_map
    end.

  Definition MinBFT_get_keys (i : name) : sm2S (MinBFTsys i) -> local_key_map :=
    match i with
    | MinBFT_replica i => fun s => local_keys s
    | MinBFT_client _  => fun _ => default_local_key_map
    end.

 Lemma correct_keys_implies_MinBFT_correct_keys :
   forall {eo : EventOrdering} (e : Event),
     AXIOM_M_correct_keys
       (fun name => system2main_local e MinBFTsys)
       (fun name => MinBFT_get_keys name)
       eo
     -> AXIOM_MinBFT_correct_keys eo.
  Proof.
    introv cor ctrace eqst.
    apply (cor e (MinBFT_replica i) st); auto.
  Qed.

  Lemma correct_keys_implies_MinBFT_correct_keys_sys :
  forall (eo : EventOrdering) (e : Event),
    AXIOM_M_correct_keys_sys MinBFTsys  e (MinBFT_get_keys name) eo
    -> AXIOM_MinBFT_correct_keys eo.
  Proof.
    introv cor ctrace eqst.
    apply (cor e (MinBFT_replica i) st); auto.
  Qed.

  XXXXXXXXXXXXXXXXXXXx

End MinBFT_at_most_f_byz.

Hint Resolve MinBFT_at_most_f_byz1_implies : pbft.

(***************** old code to be checked ************************

(*  CHECK this one
 Definition AXIOM_M_correct_keys_new
             {eo   : EventOrdering}
             (sys  : M_USystem)
             (K    : forall (e : Event), sm2S (system2main_local e sys) -> local_key_map)
              : Prop :=
    forall (e : Event) (i : name) st,
      has_correct_trace_before e i
      -> M_state_sm_before_event (system2main_local e sys)  e = st
      -> st >p>= (fun sop => match sop with
                             | Some s => ret _ (keys e = K e s)
                             | None => ret _ True
                             end).
 *)

  (*  CHECK this one
  Definition AXIOM_M_correct_keys_new2
             {eo   : EventOrdering}
             (sys  : M_USystem)
             (K  : forall (i : name), sm2S (sys i) -> local_key_map)
              : Prop :=
    forall (e : Event) (i : name) st,
      has_correct_trace_before e i
      -> M_state_sm_before_event (system2main_local e sys)  e = st
      -> st >p>= (fun sop => match sop with
                             | Some s => ret _ (keys e = K i  (sm2S (sys i)))
                             | None => ret _ True
                             end).
*)
*******************************************************)


From Coq Require Import String Arith.

From Vyper Require Import Config Map.
From Vyper.L10 Require Import Base.
From Vyper.L50 Require Import Types AST Builtins DynError.

Local Open Scope list_scope.

(** Lookup all the names in the variable map and check types.
    The names need not be distinct.
 *)
Fixpoint get_vars_by_typenames {C: VyperConfig}
                               (typenames: list typename)
                               (vars: string_map dynamic_value)
: dynamic_error + list dynamic_value
:= match typenames with
   | nil => inr nil
   | (type, name) :: rest =>
       match map_lookup vars name as z return (_ = z -> _) with
       | None => fun _ => inl (DE_CannotResolveLocalVariable name)
       | Some value => fun found =>
           let t := projT1 value in
           if yul_type_eq_dec type t
             then match get_vars_by_typenames rest vars with
                  | inl err => inl err
                  | inr rest_results => inr (value :: rest_results)
                  end
             else inl (DE_TypeMismatch type t)
       end eq_refl
   end.

(** Bind several variables. This happens to the function arguments right after a call
    and also in a variable declaration with initializer.
    The names must be distinct because shadowing is not allowed.
 *)
Fixpoint bind_vars_to_values {C: VyperConfig}
                             (vars: list typename)
                             (init: list dynamic_value)
                             (loc: string_map dynamic_value)
: dynamic_error + string_map dynamic_value
:= match vars with
   | nil =>
      match init with
      | nil => inr loc
      | _ => inl DE_TooManyValues
      end
   | (vtype, vname) :: vtail =>
      match init with
      | nil => inl DE_TooFewValues
      | (existT _ itype ivalue as ihead) :: itail =>
          if yul_type_eq_dec vtype itype then
            match map_lookup loc vname with
            | Some _ => inl (DE_LocalNameShadowing vname)
            | None => bind_vars_to_values vtail itail (map_insert loc vname ihead)
            end
          else inl (DE_TypeMismatch vtype itype)
      end
   end.

(** Bind several variables to zeros.
    This happens to the function outputs right after a call
    and also in a variable declaration without initializer.
    The names must be distinct because shadowing is not allowed.
*)
Fixpoint bind_vars_to_zeros {C: VyperConfig}
                            (vars: list typename)
                            (loc: string_map dynamic_value)
: dynamic_error + string_map dynamic_value
:= match vars with
   | nil => inr loc
   | (vtype, vname) :: vtail =>
        match map_lookup loc vname with
        | Some _ => inl (DE_LocalNameShadowing vname)
        | None => bind_vars_to_zeros vtail (map_insert loc vname (existT _ vtype (zero_value vtype)))
        end
   end.

(** Rebind several variables. This happens in assignments. *)
Fixpoint rebind_vars_to_values {C: VyperConfig}
                               (vars: list string)
                               (rhs: list dynamic_value)
                               (loc: string_map dynamic_value)
: dynamic_error + string_map dynamic_value
:= match vars with
   | nil =>
      match rhs with
      | nil => inr loc
      | _ => inl DE_TooManyValues
      end
   | vname :: vtail =>
      match rhs with
      | nil => inl DE_TooFewValues
      | (existT _ rtype rvalue as rhead) :: rtail =>
            match map_lookup loc vname with
            | Some (existT _ vtype _) =>
                if yul_type_eq_dec vtype rtype
                  then rebind_vars_to_values vtail rtail (map_insert loc vname rhead)
                  else inl (DE_TypeMismatch rtype vtype)
            | None => inl (DE_CannotResolveLocalVariable vname)
            end
      end
   end.

Fixpoint unbind_vars {C: VyperConfig}
                     (vars: list typename)
                     (loc: string_map dynamic_value)
: string_map dynamic_value
:= match vars with
   | nil => loc
   | h :: t => unbind_vars t (map_remove loc (snd h))
   end.

Lemma unbind_vars_app {C: VyperConfig}
                      (a b: list typename)
                      (loc: string_map dynamic_value):
  unbind_vars b (unbind_vars a loc) = unbind_vars (a ++ b) loc.
Proof.
revert loc. induction a as [|h]; intros. { easy. }
cbn. apply IHa.
Qed.


From Coq Require Import ZArith List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq.
From BitBlasting Require Import TypEnv State QFBV CNF BBCommon.
From ssrlib Require Import Var ZAriths Tactics.
From nbits Require Import NBits.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* ===== bit_blast_var ===== *)

Fixpoint bit_blast_var' (g : generator) (w : nat) : generator * word :=
  match w with
  | O => (g, [::])
  | S n => let (g', hd) := gen g in
           let (g'', tl) := bit_blast_var' g' n in
           (g'', hd::tl)
  end.

Fixpoint mk_env_var' E g bs : env * generator * word :=
  match bs with
  | [::] => (E, g, [::])
  | bs_hd::bs_tl => let (g', hd) := gen g in
                    let E' := env_upd E (var_of_lit hd) bs_hd in
                    let '(E'', g'', tl) := mk_env_var' E' g' bs_tl in
                    (E'', g'', hd::tl)
  end.

Definition bit_blast_var (tenv : SSATE.env) g (v : ssavar) : generator * cnf * word :=
  let (g', vs) := bit_blast_var' g (SSATE.vsize v tenv) in
  (g', [::], vs).

Definition mk_env_var E g (bs : bits) (v : ssavar) : env * generator * cnf * word :=
  let '(E', g', vs) := mk_env_var' E g bs in
  (E', g', [::], vs).

Lemma bit_blast_var_cnf_empty tenv g v g' cs lrs :
  bit_blast_var tenv g v = (g', cs, lrs) -> cs = [::].
Proof.
  rewrite /bit_blast_var. dcase (bit_blast_var' g (SSATE.vsize v tenv)).
  move=> [g_v lrs_v] Hbb. by case=> _ <- _.
Qed.

Lemma mk_env_var'_is_bit_blast_var' E g bs E' g' lrs :
  mk_env_var' E g bs = (E', g', lrs) -> bit_blast_var' g (size bs) = (g', lrs).
Proof.
  elim: bs g E E' g' lrs => [|bs_hd bs_tl IH] /=.
  - by move=> ? ? ? ? ? [] _ <- <-.
  - move=> ig iE oE og olrs.
    dcase (mk_env_var' (env_upd iE ig bs_hd) (ig+1)%positive bs_tl).
    move=> [[E g] lrs] Henv. case=> _ <- <-. by rewrite (IH _ _ _ _ _ Henv).
Qed.

Lemma mk_env_var_is_bit_blast_var tenv E g bs v E' g' cs lrs :
  size bs = SSATE.vsize v tenv -> mk_env_var E g bs v = (E', g', cs, lrs) ->
  bit_blast_var tenv g v = (g', cs, lrs).
Proof.
  rewrite /mk_env_var /bit_blast_var. dcase (mk_env_var' E g bs).
  move=> [[E_env g_env] ls_env] Henv <-. rewrite (mk_env_var'_is_bit_blast_var' Henv).
  by case=> _ <- <- <-.
Qed.

Lemma mk_env_var_sat E g bs v E' g' cs lrs :
  mk_env_var E g bs v = (E', g', cs, lrs) -> interp_cnf E' cs.
Proof.
  rewrite /mk_env_var. dcase (mk_env_var' E g bs) => [[[oE og] olrs] Henv].
  by case=> <- _ <- _.
Qed.

Lemma mk_env_var'_preserve E g bs E' g' lrs :
  mk_env_var' E g bs = (E', g', lrs) -> env_preserve E E' g.
Proof.
  elim: bs E g E' g' lrs => [| bs_hd bs_tl IH] /=.
  - move=> ? ? ? ? ? [] <- _ _. exact: env_preserve_refl.
  - move=> E g E' g' lrs.
    dcase (mk_env_var' (env_upd E g bs_hd) (g + 1)%positive bs_tl).
    move=> [[oE og] olrs] Henv. case=> <- _ _. move: (IH _ _ _ _ _ Henv).
    exact: env_preserve_env_upd_succ.
Qed.

Lemma mk_env_var_preserve E g bs v E' g' cs lrs :
  mk_env_var E g bs v = (E', g', cs, lrs) -> env_preserve E E' g.
Proof.
  rewrite /mk_env_var. dcase (mk_env_var' E g bs) => [[[oE og] olrs] Henv].
  case=> <- _ _ _. exact: (mk_env_var'_preserve Henv).
Qed.

Lemma mk_env_var'_newer_gen E g bs E' g' lrs :
  mk_env_var' E g bs = (E', g', lrs) -> (g <=? g')%positive.
Proof.
  elim: bs E g E' g' lrs => [| bs_hd bs_tl IH] /=.
  - move=> ? ? ? ? ? [] _ <- _. exact: Pos.leb_refl.
  - move=> E g E' g' lrs.
    dcase (mk_env_var' (env_upd E g bs_hd) (g + 1)%positive bs_tl).
    move=> [[oE og] olrs] Henv. case=> _ <- _. move: (IH _ _ _ _ _ Henv).
    apply: pos_leb_trans. exact: pos_leb_add_diag_r.
Qed.

Lemma mk_env_var_newer_gen E g bs v E' g' cs lrs :
  mk_env_var E g bs v = (E', g', cs, lrs) -> (g <=? g')%positive.
Proof.
  rewrite /mk_env_var. dcase (mk_env_var' E g bs) => [[[oE og] olrs] Henv].
  case=> _ <- _ _. exact: (mk_env_var'_newer_gen Henv).
Qed.

Lemma mk_env_var'_newer_res E g bs E' g' lrs :
  mk_env_var' E g bs = (E', g', lrs) -> newer_than_lits g' lrs.
Proof.
  elim: bs E g E' g' lrs => [| bs_hd bs_tl IH] /=.
  - by move=> ? ? ? ? ? [] _ <- <-.
  - move=> E g E' g' lrs.
    dcase (mk_env_var' (env_upd E g bs_hd) (g + 1)%positive bs_tl).
    move=> [[oE og] olrs] Henv. case=> _ <- <-. rewrite newer_than_lits_cons.
    rewrite (IH _ _ _ _ _ Henv) andbT. rewrite /newer_than_lit /newer_than_var /=.
    move: (mk_env_var'_newer_gen Henv) => H. apply: (pos_ltb_leb_trans _ H).
    exact: pos_ltb_add_diag_r.
Qed.

Lemma mk_env_var_newer_res E g bs v E' g' cs lrs :
  mk_env_var E g bs v = (E', g', cs, lrs) -> newer_than_lits g' lrs.
Proof.
  rewrite /mk_env_var. dcase (mk_env_var' E g bs) => [[[oE og] olrs] Henv].
  case=> _ <- _ <-. exact: (mk_env_var'_newer_res Henv).
Qed.

Lemma mk_env_var_newer_cnf E g bs v E' g' cs lrs :
  mk_env_var E g bs v = (E', g', cs, lrs) -> newer_than_cnf g' cs.
Proof.
  rewrite /mk_env_var. dcase (mk_env_var' E g bs) => [[[oE og] olrs] Henv].
  by case=> _ <- <- _.
Qed.

Lemma mk_env_var'_enc E g bs E' g' lrs :
  mk_env_var' E g bs = (E', g', lrs) -> enc_bits E' lrs bs.
Proof.
  elim: bs E g E' g' lrs => [| bs_hd bs_tl IH] //=.
  - by move=> ? ? ? ? ? [] <- _ <-.
  - move=> E g E' g' lrs.
    dcase (mk_env_var' (env_upd E g bs_hd) (g + 1)%positive bs_tl).
    move=> [[oE og] olrs] Henv. case=> <- _ <-. rewrite enc_bits_cons.
    rewrite (IH _ _ _ _ _ Henv) andbT. move: (mk_env_var'_preserve Henv) => Hpre.
    apply: (env_preserve_enc_bit Hpre (newer_than_lit_add_diag_r (Pos g) 1)).
    exact: enc_bit_env_upd_eq_pos.
Qed.

Lemma mk_env_var_enc E g bs v E' g' cs lrs :
  mk_env_var E g bs v = (E', g', cs, lrs) -> enc_bits E' lrs bs.
Proof.
  rewrite /mk_env_var. dcase (mk_env_var' E g bs) => [[[oE og] olrs] Henv].
  case=> <- _ _ <-. exact: (mk_env_var'_enc Henv).
Qed.

Lemma mk_env_var'_env_equal E1 E2 g bs E1' E2' g1 g2 lrs1 lrs2 :
  env_equal E1 E2 ->
  mk_env_var' E1 g bs = (E1', g1, lrs1) ->
  mk_env_var' E2 g bs = (E2', g2, lrs2) ->
  env_equal E1' E2' /\ g1 = g2 /\ lrs1 = lrs2.
Proof.
  elim: bs E1 E2 g g1 g2 lrs1 lrs2 => [| b bs IH] //= E1 E2 g g1 g2 lrs1 lrs2 Heq.
  - case=> ? ? ?; subst. case=> ? ? ?; subst. done.
  - dcase (mk_env_var' (env_upd E1 g b) (g + 1)%positive bs) => [[[E1'' g1''] tl1] Hv1].
    dcase (mk_env_var' (env_upd E2 g b) (g + 1)%positive bs) => [[[E2'' g2''] tl2] Hv2].
    case=> ? ? ?; case=> ? ? ?; subst.
    move: (IH _ _ _ _ _ _ _ (env_equal_upd g b Heq) Hv1 Hv2) => [H1 [H2 H3]].
    rewrite H2 H3. done.
Qed.

Lemma mk_env_var_env_equal E1 E2 g bs v E1' E2' g1 g2 cs1 cs2 lrs1 lrs2 :
  env_equal E1 E2 ->
  mk_env_var E1 g bs v = (E1', g1, cs1, lrs1) ->
  mk_env_var E2 g bs v = (E2', g2, cs2, lrs2) ->
  env_equal E1' E2' /\ g1 = g2 /\ cs1 = cs2 /\ lrs1 = lrs2.
Proof.
  rewrite /mk_env_var => Heq.
  dcase (mk_env_var' E1 g bs) => [[[E1'' g1''] lrs1''] Hv1].
  dcase (mk_env_var' E2 g bs) => [[[E2'' g2''] lrs2''] Hv2].
  case=> ? ? ? ?; case=> ? ? ? ?; subst.
  move: (mk_env_var'_env_equal Heq Hv1 Hv2) => [H1 [H2 H3]]. done.
Qed.

Lemma mk_env_var_consistent s iE im ig v oE og ocs olrs :
  mk_env_var iE ig (SSAStore.acc v s) v = (oE, og, ocs, olrs) ->
  newer_than_vm ig im ->
  consistent im iE s ->
  consistent (SSAVM.add v olrs im) oE s.
Proof.
  move=> Henv Hnew Hcon. move=> x. rewrite /consistent1.
  dcase (SSAVM.find x (SSAVM.add v olrs im)); case => //=.
  move=> xls. case Hxv: (x == v).
  - rewrite (SSAVM.Lemmas.find_add_eq Hxv). case=> ?; subst.
    rewrite (eqP Hxv). exact: (mk_env_var_enc Henv).
  - move/negP: Hxv => Hxv. rewrite (SSAVM.Lemmas.find_add_neq Hxv) => Hfx.
    move: (Hcon x). rewrite /consistent1. rewrite Hfx => Henc.
    move: (Hnew x _ Hfx) => Hnew_igxls.
    exact: (env_preserve_enc_bits (mk_env_var_preserve Henv) Hnew_igxls Henc).
Qed.

(* agree *)

Lemma agree_bit_blast_var E1 E2 g v :
  QFBV.MA.agree (SSAVS.singleton v) E1 E2 ->
  bit_blast_var E1 g v = bit_blast_var E2 g v.
Proof.
  move=> Hag. rewrite /bit_blast_var. rewrite (QFBV.MA.agree_vsize_singleton Hag).
  reflexivity.
Qed.


Require Import Relations.
Require Import EquivDec.
Require Import Equality.
Require Import List.
Require Import Bool.
Require Import Lia.
Require Import NArith.
Require Import PArith.
Require Import ZArith.
Require Import FMapPositive.
Require Import FSetPositive.
Require Import sflib.

Require Import PromisingArch.lib.Basic.
Require Import PromisingArch.lib.Order.
Require Import PromisingArch.lib.Time.
Require Import PromisingArch.lib.Lang.
Require Import PromisingArch.promising.Promising.

Set Implicit Arguments.

Lemma rtc_state_step_state_exec
      m1 m2
      (WF: Machine.wf m1)
      (STEP: rtc (Machine.step ExecUnit.state_step) m1 m2):
  Machine.state_exec m1 m2.
Proof.
  revert WF. induction STEP.
  { econs; ss. ii. destruct (IdMap.find id (Machine.tpool x)); ss. econs. refl. }
  i. exploit Machine.step_state_step_wf; eauto. i.
  exploit IHSTEP; eauto. i. inv x0.
  destruct x as [tpool1 mem1].
  destruct y as [tpool2 mem2].
  inv H. inversion STEP0. inv STEP1. ss. subst. econs; ss.
  ii. specialize (TPOOL id). revert TPOOL.
  rewrite IdMap.add_spec. condtac; ss. i.
  inversion e0. inv TPOOL. rewrite FIND, <- H2. econs.
  econs; eauto.
Qed.

Lemma state_exec_rtc_state_step
      m1 m2
      (STEP: Machine.state_exec m1 m2):
  exists m2',
    <<EXEC: rtc (Machine.step ExecUnit.state_step) m1 m2'>> /\
    <<EQUIV: Machine.equiv m2 m2'>>.
Proof.
  inv STEP.
  assert (IN: forall tid sl1
                (FIND1: IdMap.find tid m1.(Machine.tpool) = Some sl1),
             exists sl2,
               IdMap.find tid m2.(Machine.tpool) = Some sl2 /\
               rtc (ExecUnit.state_step tid)
                   (ExecUnit.mk (fst sl1) (snd sl1) m1.(Machine.mem))
                   (ExecUnit.mk (fst sl2) (snd sl2) m1.(Machine.mem))).
  { i. specialize (TPOOL tid). rewrite FIND1 in TPOOL. inv TPOOL. esplits; ss. }
  assert (OUT: forall tid
                 (FIND1: IdMap.find tid m1.(Machine.tpool) = None),
             IdMap.find tid m1.(Machine.tpool) = IdMap.find tid m2.(Machine.tpool)).
  { i. specialize (TPOOL tid). rewrite FIND1 in TPOOL. inv TPOOL. ss. }
  assert (P: forall tid sl1
               (FIND1: IdMap.find tid m1.(Machine.tpool) = Some sl1),
             IdMap.find tid m1.(Machine.tpool) = Some sl1).
  { ss. }
  clear TPOOL.
  setoid_rewrite IdMap.elements_spec in IN at 1.
  setoid_rewrite IdMap.elements_spec in OUT at 1.
  setoid_rewrite IdMap.elements_spec in P at 1.
  generalize (IdMap.elements_3w m1.(Machine.tpool)). intro NODUP. revert NODUP.
  revert IN OUT P. generalize (IdMap.elements (m1.(Machine.tpool))). intro ps.
  revert m1 MEM. induction ps; ss.
  { i. esplits; eauto. econs; ss. ii. rewrite OUT; ss. }

  i. destruct a. inv NODUP.
  exploit (IN k).
  { destruct (equiv_dec k k); ss. congr. }
  exploit (P k).
  { destruct (equiv_dec k k); ss. congr. }
  i. des. destruct p. ss.

  cut (exists m2', rtc (Machine.step ExecUnit.state_step)
                 (Machine.mk (IdMap.add k (fst sl2, snd sl2) m1.(Machine.tpool)) m1.(Machine.mem))
                 m2' /\
             Machine.equiv m2 m2').
  { i. des. esplits; [|by eauto]. etrans; [|by eauto].
    eapply Machine.rtc_eu_step_step; [eauto|refl|eauto].
  }
  assert (TID: forall tid sl (FIND: SetoidList.findA (fun id' : IdMap.key => if equiv_dec tid id' then true else false) ps = Some sl), tid <> k).
  { ii. subst. apply H1. revert FIND. clear. induction ps; ss.
    destruct a. destruct (equiv_dec k k0); ss.
    - inv e. i. inv FIND. left. ss.
    - i. right. apply IHps. ss.
  }
  eapply IHps; ss.
  - i. eapply IN. destruct (equiv_dec tid k); ss.
    inv e. exfalso. eapply TID; eauto.
  - i. rewrite IdMap.add_spec. condtac.
    + inversion e. subst. rewrite x1. destruct sl2. ss.
    + eapply OUT. destruct (equiv_dec tid k); ss.
  - i. rewrite IdMap.add_spec. condtac.
    + inversion e. subst. exfalso. eapply TID; eauto.
    + eapply P. destruct (equiv_dec tid k); ss.
Qed.


Require Import Coq.Lists.List.
Require Import Coq.Numbers.BinNums.
Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.Named.PositiveContext.
Require Import Crypto.Compilers.CountLets.
Require Import Crypto.Compilers.Named.NameUtil.
Require Import Crypto.Compilers.Named.PositiveContext.Defaults.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.NatUtil.
Require Import Crypto.Util.Tactics.DestructHead.

Section language.
  Context {base_type_code : Type}
          {op : flat_type base_type_code -> flat_type base_type_code -> Type}.

  Lemma name_list_unique_map_pos_of_succ_nat_seq a b
    : name_list_unique (map BinPos.Pos.of_succ_nat (seq a b)).
  Proof using Type.
    unfold name_list_unique, oname_list_unique, mname_list_unique.
    intros k n.
    rewrite !map_map, firstn_map, skipn_map, firstn_seq, skipn_seq.
    rewrite !in_map_iff; intros; destruct_head' ex; destruct_head' and; inversion_option; subst.
    match goal with H : _ |- _ => apply Pnat.SuccNat2Pos.inj in H end; subst.
    rewrite in_seq in *.
    omega *.
  Qed.

  Lemma name_list_unique_default_names_forf {var dummy t e}
    : name_list_unique (@default_names_forf base_type_code op var dummy t e).
  Proof using Type. apply name_list_unique_map_pos_of_succ_nat_seq. Qed.
  Lemma name_list_unique_default_names_for {var dummy t e}
    : name_list_unique (@default_names_for base_type_code op var dummy t e).
  Proof using Type. apply name_list_unique_map_pos_of_succ_nat_seq. Qed.
  Lemma name_list_unique_DefaultNamesFor {t e}
    : name_list_unique (@DefaultNamesFor base_type_code op t e).
  Proof using Type. apply name_list_unique_map_pos_of_succ_nat_seq. Qed.
End language.


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section RefineRel.

  Inductive relate_share: option State -> option State -> Prop :=
  | RELATE_NONE: relate_share None None
  | RELATE_SHARE: forall st st'
                    (id_gs: gs st = gs st')
                    (id_gpt: gpt st = gpt st')
                    (id_gpt_lk: gpt_lk st = gpt_lk st')
                    (id_gpt_lk: tlbs st = tlbs st'),
      relate_share (Some st) (Some st').

  Record relate_RData (hadt: RData) (ladt: RData) :=
      mkrelate_RData {
          id_priv: priv ladt = priv hadt;
          rel_share: relate_share (Some (share ladt)) (Some (share hadt));
          hrepl: repl hadt = replay 4;
          lrepl: repl ladt = replay 3;
          valid_ho: ValidOracle 4 (oracle hadt);
          valid_lo: ValidOracle 3 (oracle ladt);
          rel_oracle: forall st st' l l',
              let lh := oracle hadt l in
              let lo := oracle ladt l' in
              relate_share (Some st) (Some st') -> relate_share (repl ladt lo st) (repl hadt lh st')
        }.

End RefineRel.


Require Import VST.floyd.base2.
Require Import VST.floyd.client_lemmas.

Import LiftNotation.
Local Open Scope logic.

Lemma typed_true_nullptr:
 forall v t0 t t',
   typed_true t0 (force_val (sem_cmp Ceq (tptr t) (tptr t') v (Vint Int.zero))) ->
   v=nullval.
Proof.
 intros.
 simpl in H. rewrite !andb_false_r in H. simpl in H.
 unfold typed_true, force_val, sem_cmp_pp, strict_bool_val, nullval in *.
 destruct Archi.ptr64  eqn:Hp;
 destruct t0, v; inv H;
 unfold sem_cmp_pp, strict_bool_val in H1;
 try (clear i; rename i0 into i);
 pose proof (Int.eq_spec i Int.zero);
 destruct (Int.eq i Int.zero); inv H1; auto.
Qed.

Lemma typed_true_nullptr':
  forall  {cs: compspecs} t0  t t' v,
    typed_true t0 (eval_binop Cop.Oeq (tptr t) (tptr t') v nullval) -> v=nullval.
Proof.
 intros.
 simpl in H. unfold sem_binary_operation' in H.
 unfold tptr, typed_true, force_val, sem_cmp, Cop.classify_cmp, sem_cmp_pp,
   typeconv, remove_attributes, change_attributes, strict_bool_val, nullval, Val.of_bool in *.
   rewrite (proj2 (eqb_type_false (Tpointer t noattr) int_or_ptr_type)) in H
     by (intro Hx; inv Hx).
   rewrite (proj2 (eqb_type_false (Tpointer t' noattr) int_or_ptr_type)) in H
     by (intro Hx; inv Hx).
   simpl in H.
 destruct Archi.ptr64  eqn:Hp;
 destruct t0, v; inv H;
 try solve [revert H1; simple_if_tac; intro H1; inv H1].
 pose proof (Int64.eq_spec i0 Int64.zero);
 destruct (Int64.eq i0 Int64.zero); inv H1; auto.
 pose proof (Int.eq_spec i0 Int.zero);
 destruct (Int.eq i0 Int.zero); inv H1; auto.
Qed.

Lemma typed_true_Oeq_nullval:
 forall  {cs: compspecs}  v t t',
   local (`(typed_true tint) (`(eval_binop Cop.Oeq (tptr t) (tptr t')) v `(nullval))) |--
   local (`(eq nullval) v).
Proof.
intros.
 intro rho; unfold local, lift1; unfold_lift.
 apply prop_derives; intro.
 unfold tptr in H; simpl in H. unfold sem_binary_operation' in H.
 simpl in H. rewrite !andb_false_r in H.
 destruct (v rho); inv H.
 unfold sem_cmp_pp, strict_bool_val, nullval in *.
 destruct Archi.ptr64  eqn:Hp; simpl in H1;
 try solve [inv H1];
 try solve [pose proof (Int64.eq_spec i Int64.zero);
                destruct (Int64.eq i Int64.zero); inv H1; auto];
 try solve [pose proof (Int.eq_spec i Int.zero);
                destruct (Int.eq i Int.zero); inv H1; auto].
Qed.

Definition  binary_operation_to_comparison (op: Cop.binary_operation) :=
 match op with
 | Cop.Oeq => Some (@eq Z)
 | Cop.One => Some Zne
 | Cop.Olt => Some Z.lt
 | Cop.Ole => Some Z.le
 | Cop.Ogt => Some Z.gt
 | Cop.Oge => Some Z.ge
 | _ => None
 end.

(*
Lemma typed_true_binop_int:
  forall op op' e1 e2 Espec  {cs: compspecs} Delta P Q R c Post,
   binary_operation_to_comparison op = Some op' ->
   typeof e1 = tint ->
   typeof e2 = tint ->
   (PROPx P (LOCALx (tc_env Delta :: Q) (SEPx R))) |--  tc_expr Delta e1 ->
   (PROPx P (LOCALx (tc_env Delta :: Q) (SEPx R))) |-- tc_expr Delta e2 ->
  @semax cs Espec Delta (PROPx P (LOCALx
      (`op' (`force_signed_int (eval_expr e1)) (`force_signed_int (eval_expr e2))
          :: Q) (SEPx R))) c Post ->
  @semax cs Espec Delta (PROPx P (LOCALx
      (`(typed_true
          (typeof (Ebinop op e1 e2 tint)))
          (eval_expr (Ebinop op e1 e2 tint)) :: Q) (SEPx R))) c Post.
Proof.
intros.
eapply semax_pre; [clear H4 | apply H4].
eapply derives_trans with
 (tc_expr Delta e1 && (tc_expr Delta e2
   && PROPx P (LOCALx (tc_environ Delta :: `(typed_true (typeof (Ebinop op e1 e2 tint)))(eval_expr (Ebinop op e1 e2 tint)) :: Q) (SEPx R)))).
rewrite <- andp_assoc.
apply andp_right; auto.
do 2 rewrite <- insert_local.
rewrite <- andp_assoc.
rewrite (andp_comm (local _)).
rewrite andp_assoc.
apply andp_left2.
rewrite insert_local.
apply andp_right; auto.
clear H2 H3.
(*do 2 rewrite insert_local.*)
unfold PROPx, LOCALx; intro rho; simpl.
normalize.
autorewrite with norm1 norm2; normalize.
rewrite <- andp_assoc.
apply andp_derives; auto.
eapply derives_trans.
apply andp_derives; apply typecheck_expr_sound; auto.
normalize. split; auto.
rewrite H1,H0 in *.
clear H5 H2 H0 H1.
destruct (eval_expr e1 rho); inv H6.
destruct (eval_expr e2 rho); inv H7.
unfold force_signed_int, force_int.
unfold typed_true, eval_binop in H4.
destruct op; inv H; simpl in H4.
pose proof (Int.eq_spec i i0); destruct (Int.eq i i0); subst; auto.
 contradiction H4; auto.
unfold Zne.
pose proof (Int.eq_spec i i0); destruct (Int.eq i i0); subst; auto.
contradict H.
rewrite <- (Int.repr_signed i).
rewrite <- (Int.repr_signed i0).
f_equal; auto.
unfold Int.lt in H4.
destruct (zlt (Int.signed i) (Int.signed i0)); auto; contradict H4; auto.
unfold Int.lt in H4.
destruct (zlt (Int.signed i0) (Int.signed i)); auto; try omega; contradict H4; auto.
unfold Int.lt in H4.
destruct (zlt (Int.signed i0) (Int.signed i)); auto; try omega; contradict H4; auto.
unfold Int.lt in H4.
destruct (zlt (Int.signed i) (Int.signed i0)); auto; try omega; contradict H4; auto.
Qed.
*)

Definition  binary_operation_to_opp_comparison (op: Cop.binary_operation) :=
 match op with
 | Cop.Oeq => Some Zne
 | Cop.One => Some (@eq Z)
 | Cop.Olt => Some Z.ge
 | Cop.Ole => Some Z.gt
 | Cop.Ogt => Some Z.le
 | Cop.Oge => Some Z.lt
 | _ => None
 end.

(*
Lemma typed_false_binop_int:
  forall op op' e1 e2 Espec  {cs: compspecs} Delta P Q R c Post,
   binary_operation_to_opp_comparison op = Some op' ->
   typeof e1 = tint ->
   typeof e2 = tint ->
   (PROPx P (LOCALx (tc_environ Delta :: Q) (SEPx R))) |-- (tc_expr Delta e1) ->
   (PROPx P (LOCALx (tc_environ Delta :: Q) (SEPx R))) |-- (tc_expr Delta e2) ->
  @semax cs Espec Delta (PROPx P (LOCALx
      (`op' (`force_signed_int (eval_expr e1)) (`force_signed_int (eval_expr e2))
          :: Q) (SEPx R))) c Post ->
  @semax cs Espec Delta (PROPx P (LOCALx
      (`(typed_false
          (typeof (Ebinop op e1 e2 tint)))
          (eval_expr (Ebinop op e1 e2 tint)) :: Q) (SEPx R))) c Post.
Proof.
intros.
eapply semax_pre; [clear H4 | apply H4].
eapply derives_trans with
 ( local (tc_environ Delta) && ((tc_expr Delta e1) && ( (tc_expr Delta e2)
   && PROPx P (LOCALx (tc_environ Delta :: `(typed_false (typeof (Ebinop op e1 e2 tint)))(eval_expr (Ebinop op e1 e2 tint)) :: Q) (SEPx R))))).
apply andp_right.
rewrite <- insert_local. apply andp_left1; auto.
rewrite <- andp_assoc.
apply andp_right; auto.
do 2 rewrite <- insert_local.
rewrite <- andp_assoc.
rewrite (andp_comm (local _)).
rewrite andp_assoc.
apply andp_left2.
rewrite insert_local.
apply andp_right; auto.
clear H2 H3.
unfold PROPx, LOCALx; intro rho; simpl.
unfold local,lift1 at 1.
apply derives_extract_prop; intro TCE.
eapply derives_trans.
apply andp_derives; [ apply typecheck_expr_sound; auto | ].
apply andp_derives; [ apply typecheck_expr_sound; auto | ].
apply derives_refl.
normalize. autorewrite with norm1 norm2; normalize.
apply andp_right; auto. apply prop_right.
split; auto.
clear H6 TCE.
rewrite H0 in *; rewrite H1 in *.
clear H0 H1 H4.
destruct (eval_expr e1 rho); inv H2.
destruct (eval_expr e2 rho); inv H3.
unfold force_signed_int, force_int.
unfold typed_true, eval_binop in H5.
destruct op; inv H; simpl in H5.
pose proof (Int.eq_spec i i0); destruct (Int.eq i i0); inv H5; auto.
intro; apply H.
rewrite <- (Int.repr_signed i).
rewrite <- (Int.repr_signed i0).
f_equal; auto.
pose proof (Int.eq_spec i i0); destruct (Int.eq i i0); inv H5; auto.
unfold Int.lt in H5.
destruct (zlt (Int.signed i) (Int.signed i0)); inv H5; auto.
unfold Int.lt in H5.
destruct (zlt (Int.signed i0) (Int.signed i)); inv H5; omega.
unfold Int.lt in H5.
destruct (zlt (Int.signed i0) (Int.signed i)); inv H5; omega.
unfold Int.lt in H5.
destruct (zlt (Int.signed i) (Int.signed i0)); inv H5; omega.
Qed.
*)

Lemma typed_false_One_nullval:
 forall  {cs: compspecs}  v t t',
   local (`(typed_false tint) (`(eval_binop Cop.One (tptr t) (tptr t')) v `(nullval))) |--
    local (`(eq nullval) v).
Proof.
intros.
 intro rho; unfold local, lift1; unfold_lift.
 apply prop_derives; intro.
 simpl in H. unfold sem_binary_operation' in H.
 simpl in H. rewrite !andb_false_r in H.
 unfold sem_cmp_pp, nullval in *.
 destruct Archi.ptr64 eqn:Hp;
 destruct (v rho); inv H.
 pose proof (Int64.eq_spec i Int64.zero).
 destruct (Int64.eq i Int64.zero); inv H1.
 reflexivity.
 pose proof (Int.eq_spec i Int.zero).
 destruct (Int.eq i Int.zero); inv H1.
 reflexivity.
Qed.

Lemma typed_true_One_nullval:
 forall  {cs: compspecs}  v t t',
   local (`(typed_true tint) (`(eval_binop Cop.One (tptr t) (tptr t')) v `(nullval))) |--
   local (`(ptr_neq nullval) v).
Proof.
intros.
 intro rho; unfold local, lift1; unfold_lift.
 apply prop_derives; intro.
 simpl in H. unfold sem_binary_operation' in H.
 simpl in H. rewrite !andb_false_r in H.
 unfold sem_cmp_pp, ptr_neq, ptr_eq, nullval in *; simpl; intro.
 destruct (v rho); try contradiction.
 simpl in *.
 unfold typed_true, force_val, strict_bool_val in *.
 destruct Archi.ptr64 eqn:?; auto.
 destruct H0 as [? [? ?]].
 first [ pose proof (Int64.eq_spec Int64.zero i)
        | pose proof (Int.eq_spec Int.zero i)];
 rewrite H1 in H3;
 subst; inv H.
Qed.

Lemma typed_false_Oeq_nullval:
 forall  {cs: compspecs} v t t',
   local (`(typed_false tint) (`(eval_binop Cop.Oeq (tptr t) (tptr t')) v `(nullval))) |--
   local (`(ptr_neq nullval) v).
Proof.
intros. subst.
 unfold_lift; intro rho.  unfold local, lift1; apply prop_derives; intro.
 simpl in H. unfold sem_binary_operation' in H.
 simpl in H. rewrite !andb_false_r in H.
 intro. apply ptr_eq_e in H0. rewrite <- H0 in H.
 inv H.
Qed.

Lemma local_entail_at:
  forall n S T (H: local (locald_denote S) |-- local (locald_denote T))
    P Q R,
    nth_error Q n = Some S ->
    PROPx P (LOCALx Q (SEPx R)) |--
    PROPx P (LOCALx (replace_nth n Q T) (SEPx R)).
Proof.
 intros.
 unfold PROPx, LOCALx; simpl; intro rho;  apply andp_derives; auto.
 apply andp_derives; auto.
 unfold local, lift1.
 specialize (H rho). unfold local,lift1 in H.
 revert Q H0; induction n; destruct Q; simpl; intros; inv H0.
 unfold_lift; repeat rewrite prop_and.
 apply andp_derives; auto.
  unfold_lift; repeat rewrite prop_and.
 apply andp_derives; auto.
Qed.

Lemma local_entail_at_semax_0:
  forall Espec {cs: compspecs}Delta P Q1 Q1' Q R c Post,
   local (locald_denote Q1) |-- local (locald_denote Q1') ->
   @semax cs Espec Delta (PROPx P (LOCALx (Q1'::Q) (SEPx R))) c Post  ->
   @semax cs Espec Delta (PROPx P (LOCALx (Q1::Q) (SEPx R))) c Post.
Proof.
intros.
eapply semax_pre0.
eapply (local_entail_at 0).
apply H. reflexivity.
auto.
Qed.

(*
Ltac simplify_typed_comparison :=
match goal with
| |- semax _ (PROPx _ (LOCALx (`(typed_true _) ?A :: _) _)) _ _ =>
 (eapply typed_true_binop_int;
   [reflexivity | reflexivity | reflexivity
   | try solve [go_lowerx; apply prop_right; auto ]
   | try solve [go_lowerx; apply prop_right; auto ]
   | ])
 ||
  (let a := fresh "a" in set (a:=A); simpl in a; unfold a; clear a;
   eapply local_entail_at_semax_0; [
    first [ apply typed_true_Oeq_nullval
           | apply typed_true_One_nullval
           ]
    |  ])
| |- semax _ (PROPx _ (LOCALx (`(typed_false _) ?A :: _) _)) _ _ =>
 (eapply typed_false_binop_int;
   [reflexivity | reflexivity | reflexivity
   | try solve [go_lowerx; apply prop_right; auto ]
   | try solve [go_lowerx; apply prop_right; auto ]
   | ])
 ||
  let a := fresh "a" in set (a:=A); simpl in a; unfold a; clear a;
   eapply local_entail_at_semax_0; [
    first [ apply typed_false_Oeq_nullval
           | apply typed_false_One_nullval
           ]
    |  ]
| |- _ => idtac
end.
*)

Definition compare_pp op p q :=
   match p with
            | Vptr b z =>
               match q with
               | Vptr b' z' => if eq_block b b'
                              then Vint (if Ptrofs.cmpu op z z' then Int.one else Int.zero)
                              else Vundef
               | _ => Vundef
               end
             | _ => Vundef
   end.

Lemma force_sem_cmp_pp:
  forall op p q,
  isptr p -> isptr q ->
  force_val (sem_cmp_pp op p q) =
   match op with
   | Ceq => Vint (if eq_dec p q then Int.one else Int.zero)
   | Cne => Vint (if eq_dec p q then Int.zero else Int.one)
   | _ => compare_pp op p q
   end.
Proof.
intros.
destruct p; try contradiction.
destruct q; try contradiction.
clear.
unfold sem_cmp_pp, compare_pp, Ptrofs.cmpu, Val.cmplu_bool.
destruct Archi.ptr64 eqn:Hp.
destruct op; simpl; auto.
if_tac. if_tac. inv H0. rewrite Ptrofs.eq_true; reflexivity.
rewrite Ptrofs.eq_false by congruence; reflexivity.
if_tac. congruence. reflexivity.
if_tac. if_tac. inv H0. rewrite Ptrofs.eq_true by auto. reflexivity.
rewrite Ptrofs.eq_false by congruence; reflexivity.
rewrite if_false by congruence. reflexivity.
if_tac; [destruct (Ptrofs.ltu i i0); reflexivity | reflexivity].
if_tac; [destruct (Ptrofs.ltu i0 i); reflexivity | reflexivity].
if_tac; [destruct (Ptrofs.ltu i0 i); reflexivity | reflexivity].
if_tac; [destruct (Ptrofs.ltu i i0); reflexivity | reflexivity].
destruct op; simpl; auto; rewrite Hp.
if_tac. if_tac. inv H0. rewrite Ptrofs.eq_true; reflexivity.
rewrite Ptrofs.eq_false by congruence; reflexivity.
if_tac. congruence. reflexivity.
if_tac. if_tac. inv H0. rewrite Ptrofs.eq_true by auto. reflexivity.
rewrite Ptrofs.eq_false by congruence; reflexivity.
rewrite if_false by congruence. reflexivity.
if_tac; [destruct (Ptrofs.ltu i i0); reflexivity | reflexivity].
if_tac; [destruct (Ptrofs.ltu i0 i); reflexivity | reflexivity].
if_tac; [destruct (Ptrofs.ltu i0 i); reflexivity | reflexivity].
if_tac; [destruct (Ptrofs.ltu i i0); reflexivity | reflexivity].
Qed.

Hint Rewrite force_sem_cmp_pp using (now auto) : norm.


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

(** Construction and coloring of the interference graph. *)

Require Import Coqlib.
Require Import Maps.
Require Import AST.
Require Import Op.
Require Import Registers.
Require Import RTL.
Require Import RTLtyping.
Require Import Locations.
Require Import Conventions.
Require Import InterfGraph.
Require Import BuiltinFunctions.

(** * Construction of the interference graph *)

(** Two registers interfere if there exists a program point where
    they are both simultaneously live, and it is possible that they
    contain different values at this program point.  Consequently,
    two registers that do not interfere can be merged into one register
    while preserving the program behavior: there is no program point
    where this merged register would have to hold two different values
    (for the two original registers), so to speak.

    The simplified algorithm for constructing the interference graph
    from the results of the liveness analysis is as follows:
<<
     start with empty interference graph
     for each parameter p and register r live at the function entry point:
         add conflict edge p <-> r
     for each instruction I in function:
         let L be the live registers "after" I
         if I is a "move" instruction  dst <- src, and dst is live:
            add conflict edges dst <-> r for each r in L \ {dst, src}
         else if I is an instruction with result dst, and dst is live:
            add conflict edges dst <-> r for each r in L \ {dst};
         if I is a "call" instruction dst <- f(args),
            add conflict edges between all pseudo-registers in L \ {dst}
            and all caller-save machine registers
     done
>>
    Notice that edges are added only when a register becomes live.
    A register becomes live either if it is the result of an operation
    (and is live afterwards), or if we are at the function entrance
    and the register is a function parameter.  For two registers to
    be simultaneously live at some program point, it must be the case
    that one becomes live at a point where the other is already live.
    Hence, it suffices to add interference edges between registers
    that become live at some instruction and registers that are already
    live at this instruction.

    Notice also the special treatment of ``move'' instructions:
    since the destination register of the ``move'' is assigned the same value
    as the source register, it is semantically correct to assign
    the destination and the source registers to the same register,
    even if the source register remains live afterwards.
    (This is even desirable, since the ``move'' instruction can then
    be eliminated.)  Thus, no interference is added between the
    source and the destination of a ``move'' instruction.

    Finally, for ``call'' instructions, we must make sure that
    pseudo-registers live across the instruction are allocated to
    callee-save machine register or to stack slots, but never to
    caller-save machine registers (these lose their values across
    the call).  We therefore add the corresponding conflict edges
    between pseudo-registers live across and caller-save machine
    registers (pairwise).

    The full algorithm is similar to the simplified algorithm above,
    but records preference edges in addition to conflict edges.
    Preference edges guide the graph coloring algorithm by telling it
    that better code will be obtained eventually if it is possible
    to allocate certain pseudo-registers to the same location or to
    a given machine register.  Preference edges are added:
-   between the destination and source pseudo-registers of a ``move''
    instruction;
-   between the arguments of a ``call'' instruction and the locations
    of the arguments as dictated by the calling conventions;
-   between the result of a ``call'' instruction and the location
    of the result as dictated by the calling conventions.
*)

Section WITHEF.
Context `{Hsc: SyntaxConfiguration}.

Definition add_interf_live
    (filter: reg -> bool) (res: reg) (live: Regset.t) (g: graph): graph :=
  Regset.fold
    (fun r g => if filter r then add_interf r res g else g) live g.

Definition add_interf_op
    (res: reg) (live: Regset.t) (g: graph): graph :=
  add_interf_live
    (fun r => if Reg.eq r res then false else true)
    res live g.

Definition add_interf_move
    (arg res: reg) (live: Regset.t) (g: graph): graph :=
  add_interf_live
    (fun r =>
       if Reg.eq r res then false else
       if Reg.eq r arg then false else true)
    res live g.

Definition add_interf_destroyed
    (live: Regset.t) (destroyed: list mreg) (g: graph): graph :=
  List.fold_left
    (fun g mr => Regset.fold (fun r g => add_interf_mreg r mr g) live g)
    destroyed g.

Definition add_interfs_indirect_call
    (rfun: reg) (locs: list loc) (g: graph): graph :=
  List.fold_left
    (fun g loc =>
      match loc with R mr => add_interf_mreg rfun mr g | _ => g end)
    locs g.

Definition add_interf_call
    (ros: reg + ident) (locs: list loc) (g: graph): graph :=
  match ros with
  | inl rfun => add_interfs_indirect_call rfun locs g
  | inr idfun => g
  end.

Fixpoint add_prefs_call
    (args: list reg) (locs: list loc) (g: graph) {struct args} : graph :=
  match args, locs with
  | a1 :: al, l1 :: ll =>
      add_prefs_call al ll
        (match l1 with R mr => add_pref_mreg a1 mr g | _ => g end)
  | _, _ => g
  end.

Definition add_prefs_builtin (ef: builtin_function)
                            (args: list reg) (res: reg) (g: graph) : graph :=
  match ef, args with
  | EF_annot_val txt targ, arg1 :: _ => add_pref arg1 res g
  | _, _ => g
  end.

Definition add_interf_entry
    (params: list reg) (live: Regset.t) (g: graph): graph :=
  List.fold_left (fun g r => add_interf_op r live g) params g.

Fixpoint add_interf_params
    (params: list reg) (g: graph) {struct params}: graph :=
  match params with
  | nil => g
  | p1 :: pl =>
      add_interf_params pl
        (List.fold_left
          (fun g r => if Reg.eq r p1 then g else add_interf r p1 g)
          pl g)
  end.

Definition add_edges_instr
    (sig: signature) (i: instruction) (live: Regset.t) (g: graph) : graph :=
  match i with
  | Iop op args res s =>
      if Regset.mem res live then
        match is_move_operation op args with
        | Some arg =>
            add_pref arg res (add_interf_move arg res live g)
        | None =>
            add_interf_op res live g
        end
      else g
  | Iload chunk addr args dst s =>
      if Regset.mem dst live
      then add_interf_op dst live g
      else g
  | Icall sig ros args res s =>
      let largs := loc_arguments sig in
      let lres := loc_result sig in
      add_prefs_call args largs
        (add_pref_mreg res lres
          (add_interf_op res live
            (add_interf_call ros largs
              (add_interf_destroyed
                (Regset.remove res live) destroyed_at_call_regs g))))
  | Itailcall sig ros args =>
      let largs := loc_arguments sig in
      add_prefs_call args largs
        (add_interf_call ros largs g)
  | Ibuiltin ef args res s =>
      add_prefs_builtin ef args res (add_interf_op res live g)
  | Ireturn (Some r) =>
      add_pref_mreg r (loc_result sig) g
  | _ => g
  end.

Definition add_edges_instrs (f: function) (live: PMap.t Regset.t) : graph :=
  PTree.fold
    (fun g pc i => add_edges_instr f.(fn_sig) i live!!pc g)
    f.(fn_code)
    empty_graph.

Definition interf_graph (f: function) (live: PMap.t Regset.t) (live0: Regset.t) :=
  add_prefs_call f.(fn_params) (loc_parameters f.(fn_sig))
    (add_interf_params f.(fn_params)
      (add_interf_entry f.(fn_params) live0
        (add_edges_instrs f live))).

(** * Graph coloring *)

(** The actual coloring of the graph is performed by a function written
  directly in Caml, and not proved correct in any way.  This function
  takes as argument the [RTL] function, the interference graph for
  this function, an assignment of types to [RTL] pseudo-registers,
  and the set of all [RTL] pseudo-registers mentioned in the
  interference graph.  It returns the coloring as a function from
  pseudo-registers to locations. *)

Parameter graph_coloring:
  function -> graph -> regenv -> Regset.t -> (reg -> loc).

(** To ensure that the result of [graph_coloring] is a correct coloring,
  we check a posteriori its result using the following Coq functions.
  Let [coloring] be the function [reg -> loc] returned by [graph_coloring].
  The three properties checked are:
- [coloring r1 <> coloring r2] if there is a conflict edge between
  [r1] and [r2] in the interference graph.
- [coloring r1 <> R m2] if there is a conflict edge between pseudo-register
  [r1] and machine register [m2] in the interference graph.
- For all [r] mentioned in the interference graph,
  the location [coloring r] is acceptable and has the same type as [r].
*)

Definition check_coloring_1 (g: graph) (coloring: reg -> loc) :=
  SetRegReg.for_all
    (fun r1r2 =>
      if Loc.eq (coloring (fst r1r2)) (coloring (snd r1r2)) then false else true)
    g.(interf_reg_reg).

Definition check_coloring_2 (g: graph) (coloring: reg -> loc) :=
  SetRegMreg.for_all
    (fun r1mr2 =>
      if Loc.eq (coloring (fst r1mr2)) (R (snd r1mr2)) then false else true)
    g.(interf_reg_mreg).

Definition same_typ (t1 t2: typ) :=
  match t1, t2 with
  | Tint, Tint => true
  | Tfloat, Tfloat => true
  | _, _ => false
  end.

Definition loc_is_acceptable (l: loc) :=
  match l with
  | R r =>
     if In_dec Loc.eq l temporaries then false else true
  | S (Local ofs ty) =>
     if zlt ofs 0 then false else true
  | _ =>
     false
  end.

Definition check_coloring_3 (rs: Regset.t) (env: regenv) (coloring: reg -> loc) :=
  Regset.for_all
    (fun r =>
      let l := coloring r in
      andb (loc_is_acceptable l) (same_typ (env r) (Loc.type l)))
    rs.

Definition check_coloring
       (g: graph) (env: regenv) (rs: Regset.t) (coloring: reg -> loc) :=
  andb (check_coloring_1 g coloring)
       (andb (check_coloring_2 g coloring)
             (check_coloring_3 rs env coloring)).

(** To preserve decidability of checking, the checks
  (especially the third one) are performed for the pseudo-registers
  mentioned in the interference graph.  To facilitate the proofs,
  it is convenient to ensure that the properties hold for all
  pseudo-registers.  To this end, we ``clip'' the candidate coloring
  returned by [graph_coloring]: the final coloring behave identically
  over pseudo-registers mentioned in the interference graph,
  but returns a dummy machine register of the correct type otherwise. *)

Definition alloc_of_coloring (coloring: reg -> loc) (env: regenv) (rs: Regset.t) :=
  fun r =>
    if Regset.mem r rs
    then coloring r
    else match env r with Tint => R dummy_int_reg | Tfloat => R dummy_float_reg end.

(** * Coloring of the interference graph *)

(** The following function combines the phases described above:
  construction of the interference graph, coloring by untrusted
  Caml code, checking of the candidate coloring returned,
  and adjustment of this coloring.  If the coloring candidate is
  incorrect, [None] is returned, causing register allocation to fail. *)

Definition regalloc
    (f: function) (live: PMap.t Regset.t) (live0: Regset.t) (env: regenv) :=
  let g := interf_graph f live live0 in
  let rs := all_interf_regs g in
  let coloring := graph_coloring f g env rs in
  if check_coloring g env rs coloring
  then Some (alloc_of_coloring coloring env rs)
  else None.

End WITHEF.


From lrust.lifetime Require Export primitive.
From lrust.lifetime Require Export faking.
From iris.algebra Require Import csum auth frac gmap agree gset.
From iris.base_logic.lib Require Import boxes.
From iris.proofmode Require Import proofmode.
From iris.prelude Require Import options.

Section borrow.
Context `{!invGS Σ, !lftGS Σ userE}.
Implicit Types κ : lft.

Lemma raw_bor_create E κ P :
  ↑lftN ⊆ E →
  lft_ctx -∗ ▷ P ={E}=∗ raw_bor κ P ∗ ([†κ] ={E}=∗ ▷ P).
Proof.
  iIntros (HE) "#LFT HP". iInv mgmtN as (A I) "(>HA & >HI & Hinv)" "Hclose".
  iMod (ilft_create _ _ κ with "HA HI Hinv") as (A' I') "(Hκ & HA & HI & Hinv)".
  iDestruct "Hκ" as %Hκ. iDestruct (@big_sepS_later with "Hinv") as "Hinv".
  iDestruct (big_sepS_elem_of_acc _ _ κ with "Hinv") as "[Hinv Hclose']".
  { by apply elem_of_dom. }
  rewrite {1}/lft_inv. iDestruct "Hinv" as "[[Hinv >%]|[Hinv >%]]".
  - rewrite {1}lft_inv_alive_unfold;
      iDestruct "Hinv" as (Pb Pi) "(Halive & Hvs & Hinh)".
    rewrite /lft_bor_alive; iDestruct "Halive" as (B) "(HboxB & >HownB & HB)".
    iMod (lft_inh_extend _ _ P with "Hinh")
      as "(Hinh & HIlookup & Hinh_close)"; first solve_ndisj.
    iMod (slice_insert_full _ _ true with "HP HboxB")
      as (γB) "(HBlookup & HsliceB & HboxB)"; first by solve_ndisj.
    rewrite lookup_fmap. iDestruct "HBlookup" as %HBlookup.
    rewrite -(fmap_insert bor_filled _ _ Bor_in).
    iMod (own_bor_update with "HownB") as "[HB● HB◯]".
    { eapply auth_update_alloc,
        (alloc_singleton_local_update _ γB (1%Qp, to_agree Bor_in)); last done.
      rewrite lookup_fmap. case:(B !! γB) HBlookup; done. }
    rewrite -fmap_insert.
    iSpecialize ("Hclose'" with "[Hvs Hinh HboxB HB● HB]").
    { iNext. rewrite /lft_inv. iLeft. iFrame "%".
      rewrite lft_inv_alive_unfold. iExists (P ∗ Pb)%I, (P ∗ Pi)%I.
      iFrame "Hinh". iSplitL "HboxB HB● HB"; last by iApply lft_vs_frame.
      rewrite /lft_bor_alive. iExists _. iFrame "HboxB HB●".
      iApply @big_sepM_insert; first by destruct (B !! γB).
      simpl. iFrame. }
    iMod ("Hclose" with "[HA HI Hclose']") as "_"; [by iNext; iExists _, _; iFrame|].
    iSplitL "HB◯ HsliceB".
    + rewrite /bor /raw_bor /idx_bor_own. iModIntro. iExists γB. iFrame.
      iExists P. rewrite -bi.iff_refl. auto.
    + clear -HE. iIntros "!> H†".
      iInv mgmtN as (A I) "(>HA & >HI & Hinv)" "Hclose".
      iDestruct ("HIlookup" with "HI") as %Hκ.
      iDestruct (big_sepS_elem_of_acc _ _ κ with "Hinv") as "[Hinv Hclose']".
      { by apply elem_of_dom. }
      rewrite /lft_dead; iDestruct "H†" as (Λ) "[% #H†]".
      iDestruct (own_alft_auth_agree A Λ false with "HA H†") as %EQAΛ.
      rewrite {1}/lft_inv; iDestruct "Hinv" as "[[_ >%]|[Hinv >%]]".
      { unfold lft_alive_in in *. naive_solver. }
      rewrite /lft_inv_dead; iDestruct "Hinv" as (Pinh) "(Hdead & >Hcnt & Hinh)".
      iMod ("Hinh_close" $! Pinh with "Hinh") as (Pinh') "(? & $ & ?)".
      iApply "Hclose". iExists A, I. iFrame. iNext. iApply "Hclose'".
      rewrite /lft_inv. iRight. iFrame "%".
      rewrite /lft_inv_dead. iExists Pinh'. iFrame.
  - iFrame "HP". iApply fupd_frame_r. iSplitR ""; last by auto.
    rewrite /lft_inv_dead. iDestruct "Hinv" as (Pinh) "(Hdead & Hcnt & Hinh)" .
    iMod (raw_bor_fake with "Hdead") as "[Hdead Hbor]"; first solve_ndisj.
    unfold bor. iFrame. iApply "Hclose". iExists _, _. iFrame. rewrite big_sepS_later.
    iApply "Hclose'". iNext. rewrite /lft_inv. iRight.
    rewrite /lft_inv_dead. iFrame. eauto.
Qed.

Lemma bor_create E κ P :
  ↑lftN ⊆ E →
  lft_ctx -∗ ▷ P ={E}=∗ &{κ}P ∗ ([†κ] ={E}=∗ ▷ P).
Proof.
  iIntros (?) "#LFT HP". iMod (raw_bor_create with "LFT HP") as "[HP $]"; [done|].
  rewrite /bor. iExists _. iFrame. iApply lft_incl_refl.
Qed.
End borrow.