Require Import POCS.

(** * Logging API *)

(** This file defines the desired API for an append-only durable log.
    A log like the one defined here is widely used in storage systems,
    such as a file system or a database, to make atomic crash-safe
    updates.  In this lab, you will implement and prove correct the
    log itself, though the lab does not involve building anything on
    top of this log (like a file system).
  *)

(** Logically, the state of the log is a list of blocks: *)
Definition State : Type := list block.

(** The log provides three operations: [get], [append], and [reset].
    The [get] retrieves all of the blocks currently in the log: *)
Definition get_spec : Specification unit (list block) unit State :=
  fun (_ : unit) state => {|
    pre := True;
    post := fun r state' => r = state /\ state' = state;
    recovered := fun _ state' => state' = state
  |}.

(** [append] adds blocks to the log.  The [append] is the most interesting
    part of the log, because [append] must be atomic with respect to crashes.
    That means that, if the system crashes in the middle of an [append],
    either all of the blocks should be present (i.e., returned by [get]),
    or none of them should be present.

    [append] returns a boolean to indicate whether it succeeded
    or not.  The intent is that [append] might fail if the log
    has grown too big on disk, and there's no room for the new
    blocks. *)
Definition append_spec v : Specification unit bool unit State :=
  fun (_ : unit) state => {|
    pre := True;
    post := fun r state' => r = true /\ state' = state ++ v \/
                            r = false /\ state' = state;
    recovered := fun _ state' => state' = state \/ state' = state ++ v
  |}.

(** Finally, [reset] logically clears the log, removing all entries.  This
    also must be crash-safe: if the system crashes in the middle of clearing
    the log, either the log contents should still be there, or the log should
    appear to be empty (according to [get]).
  *)
Definition reset_spec : Specification unit unit unit State :=
  fun (_ : unit) state => {|
    pre := True;
    post := fun r state' => r = tt /\ state' = nil;
    recovered := fun _ state' => state' = state \/ state' = nil
  |}.

Module Type LogAPI.

  Axiom init : proc InitResult.
  Axiom get : proc (list block).
  Axiom append : list block -> proc bool.
  Axiom reset : proc unit.
  Axiom recover : proc unit.

  Axiom abstr : Abstraction State.

  Axiom init_ok : init_abstraction init recover abstr inited_any.
  Axiom get_ok : proc_spec get_spec get recover abstr.
  Axiom append_ok : forall v, proc_spec (append_spec v) (append v) recover abstr.
  Axiom reset_ok : proc_spec reset_spec reset recover abstr.
  Axiom recover_wipe : rec_wipe recover abstr no_wipe.

  Hint Resolve init_ok : core.
  Hint Resolve get_ok : core.
  Hint Resolve append_ok : core.
  Hint Resolve reset_ok : core.
  Hint Resolve recover_wipe : core.

End LogAPI.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj20synthconj6 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (Succ (plus lv0 (plus lv1 lv2))) (plus (mult lv2 (Succ lv1)) (Succ lv1))).
Admitted.
QuickChick conj20synthconj6.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^206 - 5
Base: 22 + 8/9
***)

Definition curve : CurveParameters :=
  {|
    sz := 9%nat;
    base := 22 + 8/9;
    bitwidth := 32;
    s := 2^206;
    c := [(1, 5)];
    carry_chains := Some [seq 0 (pred 9); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


(**************************************************************************)
(*   Mechanised Framework for Local Interactions & Distributed Algorithms *)
(*   T. Balabonski, P. Courtieu, R. Pelle, L. Rieg, X. Urbain             *)
(*   PACTOLE project                                                      *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence     *)
(*                                                                        *)
(**************************************************************************)

(**************************************************************************)
(**   Mechanised Framework for Local Interactions & Distributed Algorithms
      T. Balabonski, P. Courtieu, R. Pelle, L. Rieg, X. Urbain

      PACTOLE project

      This file is distributed under the terms of the CeCILL-C licence
                                                                          *)
(**************************************************************************)

Require Import Utf8_core.
Require Import Arith_base.
Require Import Reals.
Require Import Lia.
Require Import Psatz.
Require Import SetoidList.
Require Import Pactole.Setting.
Require Import Pactole.Spaces.Graph.
Require Import Pactole.Spaces.Isomorphism.
Require Import Pactole.Models.Flexible.

Notation "x == y" := (equiv x y).
Typeclasses eauto := (bfs).
Remove Hints eq_setoid : typeclass_instances.

Section CGF.

Context {V E : Type}.
Context `{Names}.
Context {G : Graph V E}.

Instance LocationV : Location := { location := V }.

(** We do not want to use the default equivalence on [E]
    because we only need equality of source, target and threshold on the edge. *)
Global Instance E_src_tgt_thd_Setoid : Setoid E :=
  @inter_Setoid E (@inter_Setoid E (precompose_Setoid src) (precompose_Setoid tgt))
                  (precompose_Setoid threshold).
Global Instance E_src_tgt_thd_EqDec : EqDec E_src_tgt_thd_Setoid :=
  inter_EqDec (inter_EqDec (precompose_EqDec src) (precompose_EqDec tgt))
              (precompose_EqDec threshold).

Global Instance E_subrelation : subrelation (@equiv E E_Setoid) (@equiv E E_src_tgt_thd_Setoid).
Proof using . intros ? ? Heq. split; simpl; now rewrite Heq. Qed.

Global Instance src_compat : Proper (equiv ==> equiv) src.
Proof using . intros ? ? Heq. apply Heq. Qed.

Global Instance tgt_compat : Proper (equiv ==> equiv) tgt.
Proof using . intros ? ? Heq. apply Heq. Qed.

Global Instance threshold_compat : Proper (equiv ==> equiv) threshold.
Proof using . intros ? ? Heq. apply Heq. Qed.

(* Since iso_E gives a bijection that comes with its setoid,
   we need to be lower level to change it from [E_Setoid] to [E_src_tgt_thd_Setoid]. *)
Global Instance iso_E_compat : forall iso,
  Proper (equiv ==> equiv) (iso_E iso).
Proof using .
intros iso ? ? [[Hsrc Htgt] Hthd].
repeat split; unfold equiv in *; cbn -[equiv] in *.
- now rewrite <- 2 (proj1 (iso_morphism _ _)), Hsrc.
- now rewrite <- 2 (proj2 (iso_morphism _ _)), Htgt.
- rewrite <- 2 iso_threshold. now f_equiv.
Qed.

(** Robots can be either on a location or somewhere on an edge. *)
Inductive loc :=
  | OnVertex (l : location)
  | OnEdge (e : E) (p : strict_ratio).

Global Instance locG_Setoid : Setoid loc.
simple refine {| equiv := fun l l' =>
                     match l, l' with
                       | OnVertex l, OnVertex l' => l == l'
                       | OnEdge e p, OnEdge e' p' => e == e' /\ p == p'
                       | _, _ => False
                     end |}; autoclass; [].
Proof. split.
+ now intros [].
+ intros [] [] Heq; simpl in *; decompose [False and] Heq; repeat split; now symmetry.
+ intros [] [] [] Heq1 Heq2; simpl in *;
  decompose [False and] Heq1; decompose [False and] Heq2; repeat split; etransitivity; eauto.
Defined.

Global Instance locG_EqDec: EqDec locG_Setoid.
Proof using .
  intros [l1 | e1 p1] [l2 | e2 p2]; simpl.
+ apply equiv_dec.
+ intuition.
+ intuition.
+ destruct (e1 =?= e2); [destruct (p1 =?= p2) |]; intuition.
Qed.

Instance LocationG : Location := { location := loc }.

Notation locV := (@location LocationV).
Notation locG := (@location LocationG).

Global Instance OnVertex_compat : Proper (equiv ==> equiv) OnVertex.
Proof using . repeat intro. auto. Qed.

Global Instance OnEdge_compat : Proper (equiv ==> equiv ==> equiv) OnEdge.
Proof using . repeat intro. auto. Qed.

(** We can use an isomorphism to build a bijection on a continuous graph. *)
Definition bijectionG (iso : isomorphism G) : Bijection.bijection loc.
simple refine {| Bijection.section := fun pt => match pt with
          | OnVertex v => OnVertex (iso.(iso_V) v)
          | OnEdge e p => OnEdge (iso.(iso_E) e) p
        end;
  Bijection.retraction := fun pt => match pt with
          | OnVertex v => OnVertex (Bijection.retraction iso.(iso_V) v)
          | OnEdge e p => OnEdge (Bijection.retraction iso.(iso_E) e) p
        end |}.
Proof.
* intros [| e1 p1] [| e2 p2] Heq; simpl in Heq; trivial.
  + now repeat f_equiv.
  + destruct Heq as [[[Hsrc Htgt] Hthd] Hp]. repeat split; simpl.
    - rewrite <- (proj1 (iso_morphism iso e1)), Hsrc. apply iso_morphism.
    - rewrite <- (proj2 (iso_morphism iso e1)), Htgt. apply iso_morphism.
    - now rewrite <- 2 iso_threshold, Hthd.
    - assumption.
* intros [| e1 p1] [| e2 p2] ; simpl in *; try tauto; [|]; split; intro Heq.
  + rewrite <- Heq. apply Bijection.retraction_section.
  + rewrite <- Heq. apply Bijection.section_retraction.
  + destruct Heq as [[[Hsrc Htgt] Hthd] Hp]. repeat split.
    - change (Bijection.retraction (iso_E iso)) with (Bijection.section (iso_E (inverse iso))).
      rewrite <- (proj1 (iso_morphism _ e2)). simpl.
      now rewrite <- (Bijection.Inversion iso), (proj1 (iso_morphism _ e1)).
    - change (Bijection.retraction (iso_E iso)) with (Bijection.section (iso_E (inverse iso))).
      rewrite <- (proj2 (iso_morphism _ e2)). simpl.
      now rewrite <- (Bijection.Inversion iso), (proj2 (iso_morphism _ e1)).
    - change (Bijection.retraction (iso_E iso)) with (Bijection.section (iso_E (inverse iso))).
      rewrite <- (iso_threshold _ e2), <- Hthd, iso_threshold.
      simpl. now rewrite Bijection.retraction_section.
    - auto.
  + destruct Heq as [[[Hsrc Htgt] Hthd] Hp]. repeat split.
    - now rewrite <- (proj1 (iso_morphism _ e1)), <- Hsrc, (proj1 (iso_morphism _ _)),
                  Bijection.section_retraction.
    - now rewrite <- (proj2 (iso_morphism _ e1)), <- Htgt, (proj2 (iso_morphism _ _)),
                  Bijection.section_retraction.
    - now rewrite <- (iso_threshold _ e1), <- Hthd, (iso_threshold _ _),
                  Bijection.section_retraction.
    - auto.
Defined.

Global Instance bijectionG_compat :  Proper (equiv ==> equiv) bijectionG.
Proof using .
intros iso1 iso2 Hiso []; simpl.
+ apply Hiso.
+ repeat split; apply Graph.src_compat || apply Graph.tgt_compat
                                       || apply Graph.threshold_compat; apply Hiso.
Qed.

(** ** Translation of locations *)

Definition location_G2V (loc : locG) : locV :=
  match loc with
    | OnVertex l => l
    | OnEdge e p => if Rle_dec (threshold e) p then Graph.tgt e else Graph.src e
  end.

Global Instance location_G2V_compat : Proper (equiv ==> equiv) location_G2V.
Proof using .
unfold location_G2V. intros [l1 | e1 p1] [l2 | e2 p2] Hxy; try tauto; [].
destruct Hxy as [Hexy Hpxy],
         (Rle_dec (threshold e1) p1) eqn:Hx,
         (Rle_dec (threshold e2) p2) eqn:Hy.
+ apply Hexy.
+ assert (Ht := proj2 Hexy).
  assert (Hr : (threshold e1 <= p1)%R) by assumption.
  now rewrite Ht, Hpxy in Hr.
+ assert (Hr : (threshold e2 <= p2)%R) by assumption.
  assert (Ht := proj2 Hexy).
  now rewrite <- Ht, <- Hpxy in Hr.
+ apply Hexy.
Qed.

Definition location_V2G : locV -> locG := OnVertex.

Global Instance location_V2G_compat : Proper (equiv ==> equiv) location_V2G.
Proof using . repeat intro. now simpl. Qed.

(** ** Translation of states **)

(** Even in the discrete setting, the current location is either the source or the target
    of the edge the robot wants to move along. *)
Definition valid_stateV (state : locV * E) :=
  fst state == src (snd state) \/ fst state == tgt (snd state).

Definition stateV := sig valid_stateV.

Instance stateV_Setoid : Setoid stateV :=
  sig_Setoid (prod_Setoid location_Setoid E_src_tgt_thd_Setoid).
Instance stateV_EqDec : EqDec stateV_Setoid :=
  @sig_EqDec _ _ (prod_EqDec location_EqDec E_src_tgt_thd_EqDec) _.

Global Instance valid_stateV_compat :
  Proper (@equiv _ (prod_Setoid _ E_src_tgt_thd_Setoid) ==> iff) valid_stateV.
Proof using .
intros ? ? [Hpt [[Hsrc Htgt] _]]. simpl in Hsrc, Htgt.
unfold valid_stateV. now rewrite Hpt, Hsrc, Htgt.
Qed.

(** Applying a graph isomorphism preserves this property. *)
Lemma valid_stateV_iso : forall state iso,
  valid_stateV state -> valid_stateV (iso.(iso_V) (fst state), iso.(iso_E) (snd state)).
Proof using .
intros [pt e] iso [Hcase | Hcase].
+ left. simpl in *. rewrite Hcase. apply iso_morphism.
+ right. simpl in *. rewrite Hcase. apply iso_morphism.
Qed.

Lemma valid_stateV_iso' : forall v e iso pt, pt == iso.(iso_V) v ->
  valid_stateV (v, e) -> valid_stateV (pt, iso.(iso_E) e).
Proof using .
intros v e iso pt Hpt [Hcase | Hcase].
+ left. simpl in *. rewrite Hpt, Hcase. apply iso_morphism.
+ right. simpl in *. rewrite Hpt, Hcase. apply iso_morphism.
Qed.

(** In the continuous case, the state must also contain the destination of the robot.
    If it is on an edge, the destination is the [tgt] of the edge.
    If it is on a vertex, we it is the case as in the discrete case: we add the destination. *)
Inductive stateG :=
  | SOnVertex v e (proof : valid_stateV (v, e))
  | SOnEdge (e : E) (p : strict_ratio).

Global Instance stateG_Setoid : Setoid stateG.
simple refine {| equiv := fun x y =>
                            match x, y with
                              | SOnVertex v e _, SOnVertex v' e' _ => v == v' /\ e == e'
                              | SOnEdge e p, SOnEdge e' p' => e == e' /\ p == p'
                              | _, _ => False
                            end |}; autoclass; [].
Proof. split.
+ intros [|]; split; reflexivity.
+ intros [|] [|] []; split; now symmetry.
+ intros [|] [|] [|] [] []; split; etransitivity; eauto.
Defined.

Global Instance stateG_EqDec : EqDec stateG_Setoid.
Proof.
intros [v1 e1 proof1 | e1 p1] [v2 e2 proof2 | e2 p2]; simpl.
+ destruct (v1 =?= v2); [destruct (e1 =?= e2) |]; auto.
+ auto.
+ auto.
+ destruct (e1 =?= e2); [destruct (p1 =?= p2) |]; auto.
Defined.

Lemma SOnVertex_compat : forall v v' e e' p p',
  v == v' -> e == e' -> SOnVertex v e p == SOnVertex v' e' p'.
Proof using . intros. now split. Qed.

Global Instance SOnEdge_compat : Proper (equiv ==> equiv ==> equiv) SOnEdge.
Proof using . intros ? ? He ? ? Hp. now split. Qed.

Definition stateG2loc state :=
  match state with
    | SOnVertex v _ _ => OnVertex v
    | SOnEdge e p => OnEdge e p
  end.

Instance stateG2loc_compat : Proper (equiv ==> equiv) stateG2loc.
Proof using . intros [] [] *; simpl in *; tauto. Qed.

(** Embedding and projection between both kinds of states. *)
Definition state_V2G (state : stateV) : stateG :=
  SOnVertex (fst (proj1_sig state)) (snd (proj1_sig state)) (proj2_sig state).

Global Instance state_V2G_compat : Proper (equiv ==> equiv) state_V2G.
Proof using . intros ? ? []. unfold state_V2G. now split. Qed.

Definition state_G2V (state : stateG) : stateV :=
  match state with
    | SOnVertex v e p => exist valid_stateV (v, e) p
    | SOnEdge e p => if Rle_dec (@threshold locV E G e) p
                     then exist valid_stateV (Graph.tgt e, e) ltac:(now right)
                     else exist valid_stateV (Graph.src e, e) ltac:(now left)
  end.

Global Instance state_G2V_compat : Proper (equiv ==> equiv) state_G2V.
Proof using .
intros [v e p | e p] [v' e' p' | e' p'] Hstate; auto; [].
destruct Hstate as [[[Hsrc Htgt] Hthd] Hp]. simpl.
destruct (Rle_dec (threshold e) p), (Rle_dec (threshold e') p');
repeat split; simpl in *; rewrite ?Hsrc, ?Htgt, ?Hthd in *; try reflexivity; [|];
destruct p, p'; simpl in *; subst; contradiction.
Qed.

Lemma state_V2G2V : forall state, state_G2V (state_V2G state) == state.
Proof using . intro. simpl. repeat (split; try reflexivity). Qed.

(** ** On configurations *)

(** The precondition for liftable changes of frame is that they must come from isomorphisms
    (which must not change the thresholds). *)
Local Instance InfoV : @State LocationV stateV.
simple refine {|
  get_location := fun state => fst (proj1_sig state);
  state_Setoid := stateV_Setoid;
  precondition := fun f => sigT (fun iso => f == iso.(iso_V) /\ iso_T iso == @Bijection.id R _);
  lift := fun f state => exist _ (projT1 f (fst (proj1_sig state)),
                                  iso_E (projT1 (projT2 f)) (snd (proj1_sig state))) _ |}; autoclass.
Proof.
+ abstract (destruct f as [f [iso [Hiso ?]]], state as [state [Hcase | Hcase]];
            cbn; left + right; rewrite Hiso, Hcase; cbn; apply iso_morphism).
+ (* lift_id *)
  intros [iso [Hiso Ht]] [state Hstate]. simpl. split; try reflexivity; [].
  change (src (snd state)) with (Datatypes.id (src (snd state))).
  change (tgt (snd state)) with (Datatypes.id (tgt (snd state))).
  rewrite (Hiso (src (snd state))), (Hiso (tgt (snd state))).
  repeat split; symmetry; try apply iso_morphism; [].
  now rewrite <- iso_threshold, Ht.
+ intros ? ? Heq. apply Heq.
+ (* lift_compat *)
  intros [f [iso1 [Hiso1 Ht1]]] [g [iso2 [Hiso2 Ht2]]] Heq [] [] [Heq1 [Heq2 Heq3]].
  cbn in *. repeat split.
  - now apply Heq.
  - rewrite <- (proj1 (iso_morphism iso1 _)), <- Hiso1,
            <- (proj1 (iso_morphism iso2 _)), <- Hiso2.
    now apply Heq.
  - rewrite <- (proj2 (iso_morphism iso1 _)), <- Hiso1,
            <- (proj2 (iso_morphism iso2 _)), <- Hiso2.
    now apply Heq.
  - now rewrite <- 2 iso_threshold, Ht1, Ht2.
Defined.

Definition good_iso_of f iso := f == Bijection.section (bijectionG iso)
                                /\ iso_T iso == @Bijection.id R _.
Definition preconditionG := fun f => sigT (good_iso_of f).

Definition liftG (f : sigT preconditionG) state :=
  let iso := projT1 (projT2 f) in
  match state with
    | SOnVertex v e proof =>
        SOnVertex (iso_V iso v) (iso_E iso e) (valid_stateV_iso (v, e) iso proof)
    | SOnEdge e p => SOnEdge (iso_E iso e) p
  end.

Global Instance liftG_compat : Proper (@equiv (sigT preconditionG) _ ==> equiv ==> equiv) liftG.
Proof using .
intros [f [iso1 [Hiso1 Ht1]]] [g [iso2 [Hiso2 Ht2]]] Hfg state1 state2 Hstate.
assert (Heq : iso_V iso1 == iso2).
{ intro x. assert (Heq1 := Hiso1 (OnVertex x)). assert (Heq2 := Hiso2 (OnVertex x)).
  cut ((bijectionG iso1) (OnVertex x) == (bijectionG iso2) (OnVertex x)); auto; [].
  rewrite <- Heq1, <- Heq2. now apply Hfg. }
hnf in Hfg. simpl projT1 in Hfg.
destruct state1 as [v1 e1 proof1 | e1 p1],
         state2 as [v2 e2 proof2 | e2 p2];
simpl; hnf in *; simpl fst in *; simpl snd in *.
+ repeat split.
  - rewrite Heq. now f_equiv.
  - rewrite <- (proj1 (iso_morphism iso1 e1)), <- (proj1 (iso_morphism iso2 e2)).
    rewrite Heq. f_equiv. apply Hstate.
  - rewrite <- (proj2 (iso_morphism iso1 e1)), <- (proj2 (iso_morphism iso2 e2)).
    rewrite Heq. f_equiv. apply Hstate.
  - rewrite <- 2 iso_threshold, Ht1, Ht2. simpl. apply Hstate.
+ tauto.
+ tauto.
+ repeat split.
  - rewrite <- (proj1 (iso_morphism iso1 e1)), Heq, <- (proj1 (iso_morphism iso2 e2)).
    f_equiv. apply Hstate.
  - rewrite <- (proj2 (iso_morphism iso1 e1)), Heq, <- (proj2 (iso_morphism iso2 e2)).
    f_equiv. apply Hstate.
  - rewrite <- 2 iso_threshold, Ht1, Ht2. simpl. apply Hstate.
  - apply Hstate.
Qed.

Lemma compose_precondition_proof : forall f g : sigT preconditionG,
  preconditionG (fun x => projT1 f (projT1 g x)).
Proof.
intros f g.
exists (compose (projT1 (projT2 f)) (projT1 (projT2 g))).
destruct f as [f [isof [Hf Hft]]], g as [g [isog [Hg Hgt]]].
split; intro x.
- simpl projT1. rewrite Hf, Hg. now destruct x.
- simpl iso_T. simpl Bijection.section. now rewrite Hft, Hgt.
Defined.

Definition compose_precondition f g :=
  existT preconditionG (fun x => projT1 f (projT1 g x)) (compose_precondition_proof f g).

Lemma liftG_compose : forall f g,
  (fun x => liftG f (liftG g x)) == liftG (compose_precondition f g).
Proof using .
intros [f [isof [Hisof Hft]]] [g [isog [Hisog Hgt]]] x.
unfold compose_precondition.
destruct x; simpl; repeat split; reflexivity.
Qed.

Local Instance InfoG : @State LocationG stateG.
simple refine {|
  get_location := stateG2loc;
  state_Setoid := stateG_Setoid;
  precondition := preconditionG;
  lift := liftG |}.
Proof.
* (* lift_id *)
  intros [iso [Hiso Ht]] [v e proof | e p]; simpl.
  + assert (Hv := Hiso (OnVertex v)).
    assert (Hsrc := Hiso (OnVertex (src e))).
    assert (Htgt := Hiso (OnVertex (tgt e))).
    specialize (Ht (threshold e)).
    simpl in Hv, Hsrc, Htgt, Ht.
    rewrite <- (proj1 (iso_morphism iso e)),
            <- (proj2 (iso_morphism iso e)), <- iso_threshold; auto.
  + assert (Hsrc := Hiso (OnVertex (src e))).
    assert (Htgt := Hiso (OnVertex (tgt e))).
    specialize (Ht (threshold e)).
    simpl in Hsrc, Htgt, Ht.
    rewrite <- (proj1 (iso_morphism iso e)),
            <- (proj2 (iso_morphism iso e)), <- iso_threshold; auto.
* (* get_location_lift *)
  intros [f [iso [Hiso Ht]]] [v e proof | e p]; simpl;
  destruct_match_eq Hf; simpl in Hf;
  (apply (@eq_subrelation _ equiv) in Hf; autoclass; []);
  rewrite Hiso in Hf; simpl in Hf; tauto.
* (* lift_compat *)
  intros [f [iso1 [Hiso1 Ht1]]] [g [iso2 [Hiso2 Ht2]]] Hfg state1 state2 Hstate.
  apply liftG_compat; trivial; [].
  hnf. simpl projT1. intro x. apply (Hfg x x (reflexivity x)).
Defined.

Notation configV := (@configuration _ stateV _ _).
Notation configG := (@configuration _ stateG _ _).

(* RMK: we cannot use [map_config] here as the Location instance is not the same. *)
Definition config_V2G (config : configV) : configG := fun id => state_V2G (config id).

Global Instance config_V2G_compat : Proper (equiv ==> equiv) config_V2G.
Proof using . intros ? ? Hconfig id. unfold config_V2G. f_equiv. apply Hconfig. Qed.

Definition config_G2V (config : configG) : configV := fun id => state_G2V (config id).

Global Instance config_G2V_compat : Proper (equiv ==> equiv) config_G2V.
Proof using . intros ? ? Hconfig id. unfold config_G2V. f_equiv. apply Hconfig. Qed.

Lemma config_V2G2V : forall config : configV, config_G2V (config_V2G config) == config.
Proof using . intros. unfold config_G2V, config_V2G. now repeat try (split; simpl). Qed.

(** The observation for the continuous setting is almost the same as for the discrete one:
    we simply project robots on edges either to the source or target of the edge
    depending on where they are located compared to the threshold of the edge;
    and add the current location. *)
Global Instance obs_V2G (Spect : @Observation _ _ InfoV _) : @Observation _ _ InfoG _.
simple refine {|
  observation := @observation _ _ _ _ Spect;
  obs_from_config := fun config st => obs_from_config (config_G2V config) (state_G2V st);
  obs_is_ok s config st := obs_is_ok s (config_G2V config) (state_G2V st) |}; autoclass; [|].
Proof.
+ abstract (now repeat intro; repeat f_equiv).
+ repeat intro. apply obs_from_config_spec.
Defined.

(** Robograms can only pick which edge they want to move on.
    The update function will check that they only move to adjacent locations. *)
Global Instance Robot : robot_choice E := {robot_choice_Setoid := E_src_tgt_thd_Setoid}.

(** ** Translation of robograms **)

Context {Obs : @Observation _ _ InfoV _}.
Notation robogramV := (@robogram _ _ InfoV _ Obs).
Notation robogramG := (@robogram _ _ InfoG _ (obs_V2G Obs)).

Definition rbg_V2G (rbgV : robogramV) : robogramG :=
  @Build_robogram _ _ InfoG _ (obs_V2G Obs) _ _ rbgV rbgV.(pgm_compat).

Global Instance rbg_V2G_compat : Proper (equiv ==> equiv) rbg_V2G.
Proof using . intros ra1 ra2 Hra. simpl. apply Hra. Qed.

Definition rbg_G2V (rbgG : robogramG) : robogramV :=
  @Build_robogram _ _ InfoV _ Obs _ _ rbgG rbgG.(pgm_compat).

Global Instance rbg_G2V_compat : Proper (equiv ==> equiv) rbg_G2V.
Proof using . intros ra1 ra2 Hra s. simpl. apply Hra. Qed.

Lemma rbg_V2G2V : forall rbgV, rbg_G2V (rbg_V2G rbgV) == rbgV.
Proof using . intro. simpl. repeat split; reflexivity. Qed.

(** **  Demonic schedulers  **)

(** Acceptable frame changes must not change the thresholds. *)
Definition stable_threshold iso := iso_T iso == @Bijection.id R _.

Definition stable_threshold_inverse : forall iso,
  stable_threshold iso -> stable_threshold (inverse iso).
Proof using .
intros iso Hstable x. unfold stable_threshold in *. simpl in *.
now rewrite <- (Hstable x), Bijection.retraction_section.
Qed.

(** Frame choice: graph isomorphisms not changing thresholds *)
Global Instance FrameChoiceIsomorphismV : @frame_choice LocationV (sig stable_threshold) := {|
  frame_choice_bijection := fun f => @iso_V locV E G (proj1_sig f);
  frame_choice_Setoid := sig_Setoid (@isomorphism_Setoid locV E G);
  frame_choice_bijection_compat :=
    fun f g => @iso_V_compat locV E G (proj1_sig f) (proj1_sig g) |}.

Global Instance FrameChoiceIsomorphismG : @frame_choice LocationG (sig stable_threshold) := {|
  frame_choice_bijection := fun f => bijectionG (proj1_sig f);
  frame_choice_Setoid := sig_Setoid (@isomorphism_Setoid locV E G);
  frame_choice_bijection_compat := fun f g => bijectionG_compat (proj1_sig f) (proj1_sig g) |}.

(** The demon update choice only contains the movement ratio, either a boolean or a ratio. *)
Global Instance graph_update_bool : update_choice bool := { update_choice_EqDec := bool_eqdec }.
Global Instance graph_update_ratio : update_choice ratio := Flexible.OnlyFlexible.

Global Instance graph_inactive_bool : inactive_choice bool := {
  inactive_choice_EqDec := bool_eqdec }.
Global Instance graph_inactive_ratio : inactive_choice ratio := {
  inactive_choice_EqDec := ratio_EqDec }.

End CGF.

Arguments config_V2G _ _ _ _ config id /.
Arguments config_G2V _ _ _ _ config id /.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj2synthconj1 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (mult (Succ Zero) lv0) (plus lv1 lv2)).
Admitted.
QuickChick conj2synthconj1.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj3synthconj5 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus Zero lv0) (plus lv1 (Succ lv2))).
Admitted.
QuickChick conj3synthconj5.


Inductive Unit : Type := tt : Unit.

Module Notation.
  Notation "⊤" := Unit.
End Notation.


Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.RewriteClass.
Require Import Logic.MinimumLogic.ProofTheory.ExtensionTactic.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.

Class ClassicalPropositionalLogic (L: Language) {minL: MinimumLanguage L} {pL: PropositionalLanguage L} (Gamma: Provable L) {minAX: MinimumAxiomatization L Gamma} {ipGamma: IntuitionisticPropositionalLogic L Gamma} := {
  excluded_middle: forall x, |-- x || ~~ x
}.

Class ClassicalPropositionalSequentCalculus (L: Language) {minL: MinimumLanguage L} {pL: PropositionalLanguage L} (Gamma: Derivable L) {bSC: BasicSequentCalculus L Gamma} {minSC: MinimumSequentCalculus L Gamma} {ipSC: IntuitionisticPropositionalSequentCalculus L Gamma} := {
  derivable_excluded_middle: forall Phi x, Phi |-- x || ~~ x
}.

Section Axiomatization2SequentCalculus.

Context {L: Language}
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {GammaP: Provable L}
        {GammaD: Derivable L}
        {minAX: MinimumAxiomatization L GammaP}
        {ipAX: IntuitionisticPropositionalLogic L GammaP}
        {cpAX: ClassicalPropositionalLogic L GammaP}
        {SC: NormalSequentCalculus L GammaP GammaD}
        {bSC: BasicSequentCalculus L GammaD}
        {minSC: MinimumSequentCalculus L GammaD}
        {ipSC: IntuitionisticPropositionalSequentCalculus L GammaD}.

Lemma Axiomatization2SequentCalculus_cpSC:
  ClassicalPropositionalSequentCalculus L GammaD.
Proof.
  intros.
  constructor.
  intros.
  apply deduction_weaken0.
  apply excluded_middle.
Qed.

End Axiomatization2SequentCalculus.

Instance reg_Axiomatization2SequentCalculus_cpSC:
  RegisterClass P2D_reg (fun cpSC: unit => @Axiomatization2SequentCalculus_cpSC) 5.
Qed.

Section SequentCalculus2Axiomatization.

Context {L: Language}
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {GammaP: Provable L}
        {GammaD: Derivable L}
        {SC: NormalSequentCalculus L GammaP GammaD}
        {bSC: BasicSequentCalculus L GammaD}
        {minSC: MinimumSequentCalculus L GammaD}
        {ipSC: IntuitionisticPropositionalSequentCalculus L GammaD}
        {cpSC: ClassicalPropositionalSequentCalculus L GammaD}
        {minAX: MinimumAxiomatization L GammaP}
        {ipAX: IntuitionisticPropositionalLogic L GammaP}.

Lemma SequentCalculus2Axiomatization_cpAX: ClassicalPropositionalLogic L GammaP.
Proof.
  intros.
  constructor.
  intros.
  rewrite provable_derivable.
  apply derivable_excluded_middle.
Qed.

End SequentCalculus2Axiomatization.

Instance reg_SequentCalculus2Axiomatization_cpAX:
  RegisterClass D2P_reg (fun cpAX: unit => @SequentCalculus2Axiomatization_cpAX) 3.
Qed.

Section DerivableRulesFromAxiomatization1.

Context {L: Language}
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {ipAX: IntuitionisticPropositionalLogic L Gamma}
        {cpAX: ClassicalPropositionalLogic L Gamma}.

Lemma double_negp_elim: forall (x: expr),
  |-- ~~ (~~ x) --> x.
Proof.
  AddSequentCalculus.
  intros.
  unfold negp.
  pose proof orp_elim x (x --> FF) (((x --> FF) --> FF) --> x).
  pose proof axiom1 x ((x --> FF) --> FF).
  pose proof modus_ponens _ _ H H0.
  clear H H0.

  pose proof derivable_contradiction_elim empty_context (x --> FF) x.
  rewrite <- provable_derivable in H.
  pose proof modus_ponens _ _ H1 H.
  clear H H1.

  pose proof excluded_middle x.
  pose proof modus_ponens _ _ H0 H.
  auto.
Qed.

Lemma double_negp: forall (x: expr),
  |-- ~~ (~~ x) <--> x.
Proof.
  AddSequentCalculus.
  intros.
  rewrite provable_derivable.
  apply deduction_andp_intros;
  rewrite <- provable_derivable.
  + apply double_negp_elim.
  + apply double_negp_intros.
Qed.

Instance Classical2GodelDummett: GodelDummettPropositionalLogic L Gamma.
Proof.
  constructor.
  AddSequentCalculus.
  intros.
  rewrite provable_derivable.
  set (Phi := empty_context).
  clearbody Phi.
  pose proof excluded_middle x.
  apply deduction_weaken0 with (Phi0 := Phi) in H.
  eapply deduction_modus_ponens; [exact H |].
  apply deduction_orp_elim'.
  + rewrite <- deduction_theorem.
    apply deduction_orp_intros2.
    rewrite deduction_theorem.
    apply derivable_axiom1.
  + rewrite <- deduction_theorem.
    apply deduction_orp_intros1.
    rewrite deduction_theorem.
    apply deduction_impp_arg_switch.
    apply derivable_contradiction_elim.
Qed.

Lemma contrapositiveNN: forall (x y: expr),
  |-- (~~ y --> ~~ x) --> (x --> y).
Proof.
  AddSequentCalculus.
  intros.
  rewrite <- (double_negp_elim y) at 2.
  rewrite provable_derivable.
  rewrite <- deduction_theorem.
  apply deduction_contrapositivePN.
  solve_assum.
Qed.

Lemma contrapositiveNP: forall (x y: expr),
  |-- (~~ y --> x) --> (~~ x --> y).
Proof.
  AddSequentCalculus.
  intros.
  rewrite <- (contrapositiveNN (~~ x) y).
  rewrite <- (double_negp_intros x).
  apply provable_impp_refl.
Qed.

End DerivableRulesFromAxiomatization1.

Section DerivableRulesFromSequentCalculus.

Context {L: Language}
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {Gamma: Derivable L}
        {bSC: BasicSequentCalculus L Gamma}
        {minSC: MinimumSequentCalculus L Gamma}
        {ipSC: IntuitionisticPropositionalSequentCalculus L Gamma}
        {cpSC: ClassicalPropositionalSequentCalculus L Gamma}.

Lemma deduction_contrapositiveNN: forall Phi (x y: expr),
  Phi |-- ~~ y --> ~~ x ->
  Phi |-- x --> y.
Proof.
  AddAxiomatization.
  intros.
  rewrite <- contrapositiveNN.
  auto.
Qed.

Lemma deduction_contrapositiveNP: forall Phi (x y: expr),
  Phi |-- ~~ y --> x ->
  Phi |-- ~~ x --> y.
Proof.
  AddAxiomatization.
  intros.
  rewrite <- contrapositiveNP.
  auto.
Qed.

End DerivableRulesFromSequentCalculus.

Section DerivableRulesFromAxiomatization2.

Context {L: Language}
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {ipAX: IntuitionisticPropositionalLogic L Gamma}
        {cpAX: ClassicalPropositionalLogic L Gamma}.

Lemma impp2orp: forall (x y: expr),
  |-- (x --> y) <--> (~~ x || y).
Proof.
  AddSequentCalculus.
  intros.
  rewrite provable_derivable.
  apply deduction_andp_intros.
  + rewrite <- deduction_theorem.
    apply (deduction_modus_ponens _ (x || ~~ x)); [apply derivable_excluded_middle |].
    apply deduction_orp_elim'.
    - rewrite <- deduction_theorem.
      apply deduction_orp_intros2.
      rewrite -> deduction_theorem.
      apply derivable_assum1.
    - rewrite <- deduction_theorem.
      apply deduction_orp_intros1.
      apply derivable_assum1.
  + apply deduction_orp_elim'.
    - rewrite <- deduction_theorem.
      rewrite <- deduction_theorem.
      apply deduction_falsep_elim.
      rewrite -> deduction_theorem.
      apply derivable_assum1.
    - apply derivable_axiom1.
Qed.

End DerivableRulesFromAxiomatization2.


(** This file proves the basic laws of the HeapLang program logic by applying
the Iris lifting lemmas. *)

From iris.algebra Require Import lib.frac_auth numbers auth.
From iris.proofmode Require Import tactics.
From iris.bi.lib Require Import fractional.
From iris.base_logic.lib Require Export gen_heap proph_map gen_inv_heap invariants.
From iris.program_logic Require Export weakestpre total_weakestpre.
From iris.program_logic Require Import ectx_lifting total_ectx_lifting.
From iris.heap_lang Require Export class_instances.
From iris.heap_lang Require Import tactics notation.
From iris.prelude Require Import options.

Class heapG Σ := HeapG {
  heapG_invG : invG Σ;
  heapG_crashG : crashG Σ;
  heapG_gen_heapG :> gen_heapG loc (option val) Σ;
  heapG_inv_heapG :> inv_heapG loc (option val) Σ;
  heapG_proph_mapG :> proph_mapG proph_id (val * val) Σ;
  heapG_credit_inG :> inG Σ (frac_authR natR);
  heapG_credit_name : gname;
}.

Section credit.
Context `{heapG Σ}.

Definition cred_frag (n : nat) : iProp Σ :=
  (∃ q, own (heapG_credit_name) (◯F{q} n)).

Definition cred_auth `{heapG Σ} (ns : nat) : iProp Σ :=
  (own (heapG_credit_name) (●F ns)).

Lemma cred_auth_frag_incr (ns n: nat) :
  cred_auth ns ∗ cred_frag n ==∗
  cred_auth (S ns) ∗ cred_frag (S n).
Proof.
  iIntros "(Hγ&Hγf)".
  iDestruct "Hγf" as (q) "Hγf".
  iMod (own_update_2 with "Hγ Hγf") as "[Hγ Hγf]".
  { apply frac_auth_update, (nat_local_update _ _ (S ns) (S n)); lia. }
  iFrame. iExists _. eauto.
Qed.

Lemma cred_auth_frag_decr (ns n: nat) :
  cred_auth ns ∗ cred_frag (S n) ==∗
  ∃ ns', ⌜ ns = S ns' ⌝ ∗ cred_auth ns' ∗ cred_frag n.
Proof.
  iIntros "(Hγ&Hγf)".
  iDestruct "Hγf" as (q) "Hγf".
  iDestruct (own_valid_2 with "Hγ Hγf") as % ?%frac_auth_included_total%nat_included.
  destruct ns as [| ns']; first lia.
  iMod (own_update_2 with "Hγ Hγf") as "[Hγ Hγf]".
  { apply frac_auth_update, (nat_local_update _ _ ns' n); lia. }
  iExists _. iFrame. iModIntro. iSplit; first eauto. iExists _. eauto.
Qed.

Definition cred_interp ns : iProp Σ :=
  cred_auth ns ∗ cred_frag 0.

Lemma cred_frag_split ns1 ns2 :
  cred_frag (ns1 + ns2) -∗ cred_frag ns1 ∗ cred_frag ns2.
Proof.
  iIntros "H". iDestruct "H" as (q) "H".
  replace q with (q/2 + q/2)%Qp by apply Qp_div_2.
  rewrite frac_auth_frag_op.
  iDestruct "H" as "(H1&H2)".
  iSplitL "H1".
  { iExists _. iFrame. }
  { iExists _. iFrame. }
Qed.

Lemma cred_interp_incr ns :
  cred_interp ns ==∗ cred_interp (S ns) ∗ cred_frag 1.
Proof.
  iIntros "H".
  iMod (cred_auth_frag_incr with "H") as "(?&H)".
  iEval (replace 1 with (1 + 0) by lia) in "H".
  iDestruct (cred_frag_split with "H") as "($&$)".
  eauto.
Qed.

Lemma cred_interp_decr ns n :
  cred_interp ns ∗ cred_frag (S n) ==∗
  ∃ ns', ⌜ ns = S ns' ⌝ ∗ cred_interp ns' ∗ cred_frag n.
Proof.
  iIntros "((H&?)&Hfrag)".
  iMod (cred_auth_frag_decr with "[$H $Hfrag]") as (ns' Heq) "(?&H)". subst.
  iExists ns'. iModIntro. iSplit; eauto.
  iFrame.
Qed.

End credit.

Program Global Instance heapG_irisG `{!heapG Σ} : irisG heap_lang Σ := {
  iris_invG := heapG_invG;
  iris_crashG := heapG_crashG;
  state_interp σ ns κs _ :=
    (cred_interp ns ∗ gen_heap_interp σ.(heap) ∗ proph_map_interp κs σ.(used_proph_id))%I;
  fork_post _ := True%I;
  num_laters_per_step n := n;
}.
Next Obligation.
  iIntros (?? σ ns κs nt) "(Hcred&Hσ&Hproph)".
  iFrame. by iMod (cred_interp_incr with "Hcred") as "($&_)".
Qed.

(** Since we use an [option val] instance of [gen_heap], we need to overwrite
the notations.  That also helps for scopes and coercions. *)
(** FIXME: Refactor these notations using custom entries once Coq bug #13654
has been fixed. *)
Notation "l ↦{ dq } v" := (mapsto (L:=loc) (V:=option val) l dq (Some v%V))
  (at level 20, format "l  ↦{ dq }  v") : bi_scope.
Notation "l ↦□ v" := (mapsto (L:=loc) (V:=option val) l DfracDiscarded (Some v%V))
  (at level 20, format "l  ↦□  v") : bi_scope.
Notation "l ↦{# q } v" := (mapsto (L:=loc) (V:=option val) l (DfracOwn q) (Some v%V))
  (at level 20, format "l  ↦{# q }  v") : bi_scope.
Notation "l ↦ v" := (mapsto (L:=loc) (V:=option val) l (DfracOwn 1) (Some v%V))
  (at level 20, format "l  ↦  v") : bi_scope.

(** Same for [gen_inv_heap], except that these are higher-order notations so to
make setoid rewriting in the predicate [I] work we need actual definitions
here. *)
Section definitions.
  Context `{!heapG Σ}.
  Definition inv_mapsto_own (l : loc) (v : val) (I : val → Prop) : iProp Σ :=
    inv_mapsto_own l (Some v) (from_option I False).
  Definition inv_mapsto (l : loc) (I : val → Prop) : iProp Σ :=
    inv_mapsto l (from_option I False).
End definitions.

Global Instance: Params (@inv_mapsto_own) 4 := {}.
Global Instance: Params (@inv_mapsto) 3 := {}.

Notation inv_heap_inv := (inv_heap_inv loc (option val)).
Notation "l '↦_' I □" := (inv_mapsto l I%stdpp%type)
  (at level 20, I at level 9, format "l  '↦_' I  '□'") : bi_scope.
Notation "l ↦_ I v" := (inv_mapsto_own l v I%stdpp%type)
  (at level 20, I at level 9, format "l  ↦_ I  v") : bi_scope.

Section lifting.
Context `{!heapG Σ}.
Implicit Types P Q : iProp Σ.
Implicit Types Φ Ψ : val → iProp Σ.
Implicit Types efs : list expr.
Implicit Types σ : state.
Implicit Types v : val.
Implicit Types l : loc.

Lemma state_interp_step_incr σ ns κs nt :
  state_interp σ ns κs nt ==∗
  state_interp σ (S ns) κs nt.
Proof.
  iIntros "(Hcred&Hσ&Hproph)".
  iFrame. by iMod (cred_interp_incr with "Hcred") as "($&_)".
Qed.

Lemma state_interp_step_incr' σ ns κs nt :
  state_interp σ ns κs nt ==∗
  state_interp σ (S ns) κs nt ∗ cred_frag 1.
Proof.
  iIntros "(Hcred&Hσ&Hproph)".
  iFrame. by iMod (cred_interp_incr with "Hcred") as "($&$)".
Qed.

Lemma state_interp_step_decr σ ns κs nt n:
  state_interp σ ns κs nt ∗ cred_frag (S n) ==∗
  ∃ ns', ⌜ ns = S ns' ⌝ ∗ state_interp σ ns' κs nt ∗ cred_frag n.
Proof.
  iIntros "((Hcred&Hσ&Hproph)&Hfrag)".
  iFrame. iMod (cred_interp_decr with "[$]") as (ns' Heq) "(?&$)".
  iExists _. iModIntro. iFrame. eauto.
Qed.

Lemma wp_pure_later_cred s E e1 e2 φ Φ :
  PureExec φ 1 e1 e2 → φ → ▷ WP e2 @ s; E {{ v, cred_frag 1 -∗ Φ v }} -∗ WP e1 @ s; E {{ v, Φ v }}.
Proof.
  iIntros (HPure Hφ) "Hwp".
  rewrite /PureExec in HPure. apply HPure in Hφ.
  iApply wp_lift_step.
  {
    eapply (reducible_not_val _ inhabitant), reducible_no_obs_reducible.
    inversion Hφ. eapply pure_step_safe; eauto.
  }
  iIntros (σ1 ns κ κs nt) "(Hcred&Hσ)".
  iMod (cred_interp_incr with "[$]") as "($&Hcred)".
  iApply (fupd_mask_intro); first by set_solver+.
  iIntros "H".
  iSplit.
  {
    destruct s; auto. iPureIntro. eapply reducible_no_obs_reducible.
    inversion Hφ. eapply pure_step_safe; eauto.
  }
  iIntros "!>" (v2 σ2 efs Hstep); inv_head_step.
  inversion Hφ; subst. eapply pure_step_det in Hstep; eauto.
  destruct Hstep as (->&->&?&?). rewrite /=. iFrame.
  subst. inversion H1; subst. rewrite big_sepL_nil.
  iMod "H". iModIntro. iSplitL; last done.
  iApply (wp_wand with "Hwp"). iIntros (?) "Hw".
  iApply "Hw". iFrame.
Qed.

Lemma wp_later_cred_use s E e Φ :
  language.to_val e = None →
  cred_frag 1 -∗
  ▷ WP e @ s; E {{ v, cred_frag 1 -∗ Φ v }} -∗
  WP e @ s; E {{ Φ }}.
Proof.
  iIntros (Hnval) "Hcred Hwp".
  rewrite ?wp_unfold /wp_pre.
  rewrite Hnval.
  iIntros (q σ1 ns κ κs nt) "Hσ HNC".
  iMod (state_interp_step_decr with "[$]") as (ns' ->) "(Hσ&Hcred)".
  iApply (fupd_mask_weaken ∅); first by set_solver+.
  iIntros "H". iModIntro. simpl. iModIntro. iNext. iModIntro. iMod "H" as "_".
  iSpecialize ("Hwp" $! _ _ _ _ _ 0 with "[Hσ] [$]").
  { iFrame. }
  iMod "Hwp". iApply (step_fupdN_wand with "Hwp").
  iNext. iIntros "($&H)".
  iIntros. iMod ("H" with "[//]") as "(Hσ&Hwp&$)".
  iMod (state_interp_step_incr' _ _ _ 0 with "[$]") as "(Hσ&Hcred')".
  iFrame. iModIntro.
  iApply (wp_wand with "Hwp").
  iIntros (?) "H". iApply "H". iFrame.
Qed.

Lemma wp_later_cred_inv N E e `{Atomic _ StronglyAtomic e} Φ P :
  ↑N ⊆ E →
  language.to_val e = None →
  inv N (cred_frag 1 ∗ P) -∗
  (P -∗ WP e @ E ∖ ↑N {{ v, P ∗ Φ v }}) -∗
  WP e @ E {{ Φ }}.
Proof.
  iIntros (? Hnval) "Hcred Hwp".
  iInv "Hcred" as "(>H&HP)".
  iApply (wp_later_cred_use with "[$]"); auto.
  iNext. iSpecialize ("Hwp" with "[$]").
  iApply (wp_mono with "Hwp").
  rewrite ?wp_unfold /wp_pre.
  iIntros (?) "(HP&HΦ) Hcred". iFrame. eauto.
Qed.

(** Recursive functions: we do not use this lemmas as it is easier to use Löb
induction directly, but this demonstrates that we can state the expected
reasoning principle for recursive functions, without any visible ▷. *)
Lemma wp_rec_löb s E f x e Φ Ψ :
  □ ( □ (∀ v, Ψ v -∗ WP (rec: f x := e)%V v @ s; E {{ Φ }}) -∗
     ∀ v, Ψ v -∗ WP (subst' x v (subst' f (rec: f x := e) e)) @ s; E {{ Φ }}) -∗
  ∀ v, Ψ v -∗ WP (rec: f x := e)%V v @ s; E {{ Φ }}.
Proof.
  iIntros "#Hrec". iLöb as "IH". iIntros (v) "HΨ".
  iApply lifting.wp_pure_step_later; first done.
  iNext. iApply ("Hrec" with "[] HΨ"). iIntros "!>" (w) "HΨ".
  iApply ("IH" with "HΨ").
Qed.

(** Fork: Not using Texan triples to avoid some unnecessary [True] *)
Lemma wp_fork s E e Φ :
  ▷ WP e @ s; ⊤ {{ _, True }} -∗ ▷ Φ (LitV LitUnit) -∗ WP Fork e @ s; E {{ Φ }}.
Proof.
  iIntros "He HΦ". iApply wp_lift_atomic_head_step; [done|].
  iIntros (σ1 ns κ κs nt) "(Hcred&Hσ) !>"; iSplit; first by eauto with head_step.
  iIntros "!>" (v2 σ2 efs Hstep); inv_head_step.
  iMod (cred_interp_incr with "[$]") as "($&_)". by iFrame.
Qed.

Lemma twp_fork s E e Φ :
  WP e @ s; ⊤ [{ _, True }] -∗ Φ (LitV LitUnit) -∗ WP Fork e @ s; E [{ Φ }].
Proof.
  iIntros "He HΦ". iApply twp_lift_atomic_head_step; [done|].
  iIntros (σ1 ns κs nt) "(Hcred&Hσ) !>"; iSplit; first by eauto with head_step.
  iIntros (κ v2 σ2 efs Hstep); inv_head_step.
  iMod (cred_interp_incr with "[$]") as "($&_)". by iFrame.
Qed.

(** Heap *)

(** We need to adjust the [gen_heap] and [gen_inv_heap] lemmas because of our
value type being [option val]. *)

Lemma mapsto_valid l dq v : l ↦{dq} v -∗ ⌜✓ dq⌝.
Proof. apply mapsto_valid. Qed.
Lemma mapsto_valid_2 l dq1 dq2 v1 v2 :
  l ↦{dq1} v1 -∗ l ↦{dq2} v2 -∗ ⌜✓ (dq1 ⋅ dq2) ∧ v1 = v2⌝.
Proof.
  iIntros "H1 H2". iDestruct (mapsto_valid_2 with "H1 H2") as %[? [=?]]. done.
Qed.
Lemma mapsto_agree l dq1 dq2 v1 v2 : l ↦{dq1} v1 -∗ l ↦{dq2} v2 -∗ ⌜v1 = v2⌝.
Proof. iIntros "H1 H2". iDestruct (mapsto_agree with "H1 H2") as %[=?]. done. Qed.

Lemma mapsto_combine l dq1 dq2 v1 v2 :
  l ↦{dq1} v1 -∗ l ↦{dq2} v2 -∗ l ↦{dq1 ⋅ dq2} v1 ∗ ⌜v1 = v2⌝.
Proof.
  iIntros "Hl1 Hl2". iDestruct (mapsto_combine with "Hl1 Hl2") as "[$ Heq]".
  by iDestruct "Heq" as %[= ->].
Qed.

Lemma mapsto_frac_ne l1 l2 dq1 dq2 v1 v2 :
  ¬ ✓(dq1 ⋅ dq2) → l1 ↦{dq1} v1 -∗ l2 ↦{dq2} v2 -∗ ⌜l1 ≠ l2⌝.
Proof. apply mapsto_frac_ne. Qed.
Lemma mapsto_ne l1 l2 dq2 v1 v2 : l1 ↦ v1 -∗ l2 ↦{dq2} v2 -∗ ⌜l1 ≠ l2⌝.
Proof. apply mapsto_ne. Qed.

Lemma mapsto_persist l dq v : l ↦{dq} v ==∗ l ↦□ v.
Proof. apply mapsto_persist. Qed.

Global Instance inv_mapsto_own_proper l v :
  Proper (pointwise_relation _ iff ==> (≡)) (inv_mapsto_own l v).
Proof.
  intros I1 I2 HI. rewrite /inv_mapsto_own. f_equiv=>-[w|]; last done.
  simpl. apply HI.
Qed.
Global Instance inv_mapsto_proper l :
  Proper (pointwise_relation _ iff ==> (≡)) (inv_mapsto l).
Proof.
  intros I1 I2 HI. rewrite /inv_mapsto. f_equiv=>-[w|]; last done.
  simpl. apply HI.
Qed.

Lemma make_inv_mapsto l v (I : val → Prop) E :
  ↑inv_heapN ⊆ E →
  I v →
  inv_heap_inv -∗ l ↦ v ={E}=∗ l ↦_I v.
Proof. iIntros (??) "#HI Hl". iApply make_inv_mapsto; done. Qed.
Lemma inv_mapsto_own_inv l v I : l ↦_I v -∗ l ↦_I □.
Proof. apply inv_mapsto_own_inv. Qed.

Lemma inv_mapsto_own_acc_strong E :
  ↑inv_heapN ⊆ E →
  inv_heap_inv ={E, E ∖ ↑inv_heapN}=∗ ∀ l v I, l ↦_I v -∗
    (⌜I v⌝ ∗ l ↦ v ∗ (∀ w, ⌜I w ⌝ -∗ l ↦ w ==∗
      inv_mapsto_own l w I ∗ |={E ∖ ↑inv_heapN, E}=> True)).
Proof.
  iIntros (?) "#Hinv".
  iMod (inv_mapsto_own_acc_strong with "Hinv") as "Hacc"; first done.
  iIntros "!>" (l v I) "Hl". iDestruct ("Hacc" with "Hl") as "(% & Hl & Hclose)".
  iFrame "%∗". iIntros (w) "% Hl". iApply "Hclose"; done.
Qed.

Lemma inv_mapsto_own_acc E l v I:
  ↑inv_heapN ⊆ E →
  inv_heap_inv -∗ l ↦_I v ={E, E ∖ ↑inv_heapN}=∗
    (⌜I v⌝ ∗ l ↦ v ∗ (∀ w, ⌜I w ⌝ -∗ l ↦ w ={E ∖ ↑inv_heapN, E}=∗ l ↦_I w)).
Proof.
  iIntros (?) "#Hinv Hl".
  iMod (inv_mapsto_own_acc with "Hinv Hl") as "(% & Hl & Hclose)"; first done.
  iFrame "%∗". iIntros "!>" (w) "% Hl". iApply "Hclose"; done.
Qed.

Lemma inv_mapsto_acc l I E :
  ↑inv_heapN ⊆ E →
  inv_heap_inv -∗ l ↦_I □ ={E, E ∖ ↑inv_heapN}=∗
    ∃ v, ⌜I v⌝ ∗ l ↦ v ∗ (l ↦ v ={E ∖ ↑inv_heapN, E}=∗ ⌜True⌝).
Proof.
  iIntros (?) "#Hinv Hl".
  iMod (inv_mapsto_acc with "Hinv Hl") as ([v|]) "(% & Hl & Hclose)"; [done| |done].
  iIntros "!>". iExists (v). iFrame "%∗".
Qed.

(** The usable rules for [allocN] stated in terms of the [array] proposition
are derived in te file [array]. *)
Lemma heap_array_to_seq_meta l vs (n : nat) :
  length vs = n →
  ([∗ map] l' ↦ _ ∈ heap_array l vs, meta_token l' ⊤) -∗
  [∗ list] i ∈ seq 0 n, meta_token (l +ₗ (i : nat)) ⊤.
Proof.
  iIntros (<-) "Hvs". iInduction vs as [|v vs] "IH" forall (l)=> //=.
  rewrite big_opM_union; last first.
  { apply map_disjoint_spec=> l' v1 v2 /lookup_singleton_Some [-> _].
    intros (j&w&?&Hjl&?&?)%heap_array_lookup.
    rewrite loc_add_assoc -{1}[l']loc_add_0 in Hjl. simplify_eq; lia. }
  rewrite loc_add_0 -fmap_S_seq big_sepL_fmap.
  setoid_rewrite Nat2Z.inj_succ. setoid_rewrite <-Z.add_1_l.
  setoid_rewrite <-loc_add_assoc.
  rewrite big_opM_singleton; iDestruct "Hvs" as "[$ Hvs]". by iApply "IH".
Qed.

Lemma heap_array_to_seq_mapsto l v (n : nat) :
  ([∗ map] l' ↦ ov ∈ heap_array l (replicate n v), gen_heap.mapsto l' (DfracOwn 1) ov) -∗
  [∗ list] i ∈ seq 0 n, (l +ₗ (i : nat)) ↦ v.
Proof.
  iIntros "Hvs". iInduction n as [|n] "IH" forall (l); simpl.
  { done. }
  rewrite big_opM_union; last first.
  { apply map_disjoint_spec=> l' v1 v2 /lookup_singleton_Some [-> _].
    intros (j&w&?&Hjl&_)%heap_array_lookup.
    rewrite loc_add_assoc -{1}[l']loc_add_0 in Hjl. simplify_eq; lia. }
  rewrite loc_add_0 -fmap_S_seq big_sepL_fmap.
  setoid_rewrite Nat2Z.inj_succ. setoid_rewrite <-Z.add_1_l.
  setoid_rewrite <-loc_add_assoc.
  rewrite big_opM_singleton; iDestruct "Hvs" as "[$ Hvs]". by iApply "IH".
Qed.

Lemma twp_allocN_seq s E v n :
  (0 < n)%Z →
  [[{ True }]] AllocN (Val $ LitV $ LitInt $ n) (Val v) @ s; E
  [[{ l, RET LitV (LitLoc l); [∗ list] i ∈ seq 0 (Z.to_nat n),
      (l +ₗ (i : nat)) ↦ v ∗ meta_token (l +ₗ (i : nat)) ⊤ }]].
Proof.
  iIntros (Hn Φ) "_ HΦ". iApply twp_lift_atomic_head_step_no_fork; first done.
  iIntros (σ1 ns κs nt) "[Hcred [Hσ Hκs]] !>"; iSplit; first by destruct n; auto with lia head_step.
  iIntros (κ v2 σ2 efs Hstep); inv_head_step.
  iMod (gen_heap_alloc_big _ (heap_array _ (replicate (Z.to_nat n) v)) with "Hσ")
    as "(Hσ & Hl & Hm)".
  { apply heap_array_map_disjoint.
    rewrite replicate_length Z2Nat.id; auto with lia. }
  iMod (cred_interp_incr with "[$]") as "($&_)".
  iModIntro; do 2 (iSplit; first done). iFrame "Hσ Hκs".
  iApply "HΦ".
  iApply big_sepL_sep. iSplitL "Hl".
  - by iApply heap_array_to_seq_mapsto.
  - iApply (heap_array_to_seq_meta with "Hm"). by rewrite replicate_length.
Qed.
Lemma wp_allocN_seq s E v n :
  (0 < n)%Z →
  {{{ True }}} AllocN (Val $ LitV $ LitInt $ n) (Val v) @ s; E
  {{{ l, RET LitV (LitLoc l); [∗ list] i ∈ seq 0 (Z.to_nat n),
      (l +ₗ (i : nat)) ↦ v ∗ meta_token (l +ₗ (i : nat)) ⊤ }}}.
Proof.
  iIntros (Hn Φ) "_ HΦ". iApply (twp_wp_step with "HΦ").
  iApply twp_allocN_seq; [by auto..|]; iIntros (l) "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_alloc s E v :
  [[{ True }]] Alloc (Val v) @ s; E [[{ l, RET LitV (LitLoc l); l ↦ v ∗ meta_token l ⊤ }]].
Proof.
  iIntros (Φ) "_ HΦ". iApply twp_allocN_seq; [auto with lia..|].
  iIntros (l) "/= (? & _)". rewrite loc_add_0. iApply "HΦ"; iFrame.
Qed.
Lemma wp_alloc s E v :
  {{{ True }}} Alloc (Val v) @ s; E {{{ l, RET LitV (LitLoc l); l ↦ v ∗ meta_token l ⊤ }}}.
Proof.
  iIntros (Φ) "_ HΦ". iApply (twp_wp_step with "HΦ").
  iApply twp_alloc; [by auto..|]; iIntros (l) "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_free s E l v :
  [[{ l ↦ v }]] Free (Val $ LitV $ LitLoc l) @ s; E
  [[{ RET LitV LitUnit; True }]].
Proof.
  iIntros (Φ) "Hl HΦ". iApply twp_lift_atomic_head_step_no_fork; first done.
  iIntros (σ1 ns κs nt) "[Hcred [Hσ Hκs]] !>". iDestruct (gen_heap_valid with "Hσ Hl") as %?.
  iSplit; first by eauto with head_step.
  iIntros (κ v2 σ2 efs Hstep); inv_head_step.
  iMod (gen_heap_update with "Hσ Hl") as "[$ Hl]".
  iMod (cred_interp_incr with "[$]") as "($&_)".
  iModIntro. iSplit; first done. iSplit; first done. iFrame. by iApply "HΦ".
Qed.
Lemma wp_free s E l v :
  {{{ ▷ l ↦ v }}} Free (Val $ LitV (LitLoc l)) @ s; E
  {{{ RET LitV LitUnit; True }}}.
Proof.
  iIntros (Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_free with "H"); [by auto..|]; iIntros "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_load s E l dq v :
  [[{ l ↦{dq} v }]] Load (Val $ LitV $ LitLoc l) @ s; E [[{ RET v; l ↦{dq} v }]].
Proof.
  iIntros (Φ) "Hl HΦ". iApply twp_lift_atomic_head_step_no_fork; first done.
  iIntros (σ1 ns κs nt) "[Hcred [Hσ Hκs]] !>". iDestruct (gen_heap_valid with "Hσ Hl") as %?.
  iSplit; first by eauto with head_step.
  iIntros (κ v2 σ2 efs Hstep); inv_head_step.
  iMod (cred_interp_incr with "[$]") as "($&_)".
  iModIntro; iSplit=> //. iSplit; first done. iFrame. by iApply "HΦ".
Qed.
Lemma wp_load s E l dq v :
  {{{ ▷ l ↦{dq} v }}} Load (Val $ LitV $ LitLoc l) @ s; E {{{ RET v; l ↦{dq} v }}}.
Proof.
  iIntros (Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_load with "H"). iIntros "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_store s E l v' v :
  [[{ l ↦ v' }]] Store (Val $ LitV $ LitLoc l) (Val v) @ s; E
  [[{ RET LitV LitUnit; l ↦ v }]].
Proof.
  iIntros (Φ) "Hl HΦ". iApply twp_lift_atomic_head_step_no_fork; first done.
  iIntros (σ1 ns κs nt) "[Hcred [Hσ Hκs]] !>". iDestruct (gen_heap_valid with "Hσ Hl") as %?.
  iSplit; first by eauto with head_step.
  iIntros (κ v2 σ2 efs Hstep); inv_head_step.
  iMod (gen_heap_update with "Hσ Hl") as "[$ Hl]".
  iMod (cred_interp_incr with "[$]") as "($&_)".
  iModIntro. iSplit; first done. iSplit; first done. iFrame. by iApply "HΦ".
Qed.
Lemma wp_store s E l v' v :
  {{{ ▷ l ↦ v' }}} Store (Val $ LitV (LitLoc l)) (Val v) @ s; E
  {{{ RET LitV LitUnit; l ↦ v }}}.
Proof.
  iIntros (Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_store with "H"); [by auto..|]; iIntros "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_cmpxchg_fail s E l dq v' v1 v2 :
  v' ≠ v1 → vals_compare_safe v' v1 →
  [[{ l ↦{dq} v' }]] CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2) @ s; E
  [[{ RET PairV v' (LitV $ LitBool false); l ↦{dq} v' }]].
Proof.
  iIntros (?? Φ) "Hl HΦ". iApply twp_lift_atomic_head_step_no_fork; first done.
  iIntros (σ1 ns κs nt) "[Hcred [Hσ Hκs]] !>". iDestruct (gen_heap_valid with "Hσ Hl") as %?.
  iSplit; first by eauto with head_step.
  iIntros (κ v2' σ2 efs Hstep); inv_head_step.
  rewrite bool_decide_false //.
  iMod (cred_interp_incr with "[$]") as "($&_)".
  iModIntro; iSplit; first done. iSplit; first done. iFrame. by iApply "HΦ".
Qed.
Lemma wp_cmpxchg_fail s E l dq v' v1 v2 :
  v' ≠ v1 → vals_compare_safe v' v1 →
  {{{ ▷ l ↦{dq} v' }}} CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2) @ s; E
  {{{ RET PairV v' (LitV $ LitBool false); l ↦{dq} v' }}}.
Proof.
  iIntros (?? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_cmpxchg_fail with "H"); [by auto..|]; iIntros "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_cmpxchg_suc s E l v1 v2 v' :
  v' = v1 → vals_compare_safe v' v1 →
  [[{ l ↦ v' }]] CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2) @ s; E
  [[{ RET PairV v' (LitV $ LitBool true); l ↦ v2 }]].
Proof.
  iIntros (?? Φ) "Hl HΦ". iApply twp_lift_atomic_head_step_no_fork; first done.
  iIntros (σ1 ns κs nt) "[Hcred [Hσ Hκs]] !>". iDestruct (gen_heap_valid with "Hσ Hl") as %?.
  iSplit; first by eauto with head_step.
  iIntros (κ v2' σ2 efs Hstep); inv_head_step.
  rewrite bool_decide_true //.
  iMod (gen_heap_update with "Hσ Hl") as "[$ Hl]".
  iMod (cred_interp_incr with "[$]") as "($&_)".
  iModIntro. iSplit; first done. iSplit; first done. iFrame. by iApply "HΦ".
Qed.
Lemma wp_cmpxchg_suc s E l v1 v2 v' :
  v' = v1 → vals_compare_safe v' v1 →
  {{{ ▷ l ↦ v' }}} CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2) @ s; E
  {{{ RET PairV v' (LitV $ LitBool true); l ↦ v2 }}}.
Proof.
  iIntros (?? Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_cmpxchg_suc with "H"); [by auto..|]; iIntros "H HΦ". by iApply "HΦ".
Qed.

Lemma twp_faa s E l i1 i2 :
  [[{ l ↦ LitV (LitInt i1) }]] FAA (Val $ LitV $ LitLoc l) (Val $ LitV $ LitInt i2) @ s; E
  [[{ RET LitV (LitInt i1); l ↦ LitV (LitInt (i1 + i2)) }]].
Proof.
  iIntros (Φ) "Hl HΦ". iApply twp_lift_atomic_head_step_no_fork; first done.
  iIntros (σ1 ns κs nt) "[Hcred [Hσ Hκs]] !>". iDestruct (gen_heap_valid with "Hσ Hl") as %?.
  iSplit; first by eauto with head_step.
  iIntros (κ e2 σ2 efs Hstep); inv_head_step.
  iMod (gen_heap_update with "Hσ Hl") as "[$ Hl]".
  iMod (cred_interp_incr with "[$]") as "($&_)".
  iModIntro. do 2 (iSplit; first done). iFrame. by iApply "HΦ".
Qed.
Lemma wp_faa s E l i1 i2 :
  {{{ ▷ l ↦ LitV (LitInt i1) }}} FAA (Val $ LitV $ LitLoc l) (Val $ LitV $ LitInt i2) @ s; E
  {{{ RET LitV (LitInt i1); l ↦ LitV (LitInt (i1 + i2)) }}}.
Proof.
  iIntros (Φ) ">H HΦ". iApply (twp_wp_step with "HΦ").
  iApply (twp_faa with "H"); [by auto..|]; iIntros "H HΦ". by iApply "HΦ".
Qed.

Lemma wp_new_proph s E :
  {{{ True }}}
    NewProph @ s; E
  {{{ pvs p, RET (LitV (LitProphecy p)); proph p pvs }}}.
Proof.
  iIntros (Φ) "_ HΦ". iApply wp_lift_atomic_head_step_no_fork; first done.
  iIntros (σ1 ns κ κs nt) "[Hcred [Hσ HR]] !>". iSplit; first by eauto with head_step.
  iIntros "!>" (v2 σ2 efs Hstep). inv_head_step.
  rename select proph_id into p.
  iMod (proph_map_new_proph p with "HR") as "[HR Hp]"; first done.
  iMod (cred_interp_incr with "[$]") as "($&_)".
  iModIntro; iSplit; first done. iFrame. by iApply "HΦ".
Qed.

(* In the following, strong atomicity is required due to the fact that [e] must
be able to make a head step for [Resolve e _ _] not to be (head) stuck. *)

Lemma resolve_reducible e σ (p : proph_id) v :
  Atomic StronglyAtomic e → reducible e σ →
  reducible (Resolve e (Val (LitV (LitProphecy p))) (Val v)) σ.
Proof.
  intros A (κ & e' & σ' & efs & H).
  exists (κ ++ [(p, (default v (to_val e'), v))]), e', σ', efs.
  eapply (Ectx_step []); try done.
  assert (∃w, Val w = e') as [w <-].
  { unfold Atomic in A. apply (A σ e' κ σ' efs) in H. unfold is_Some in H.
    destruct H as [w H]. exists w. simpl in H. by apply (of_to_val _ _ H). }
  simpl. constructor. by apply prim_step_to_val_is_head_step.
Qed.

Lemma step_resolve e vp vt σ1 κ e2 σ2 efs :
  Atomic StronglyAtomic e →
  prim_step (Resolve e (Val vp) (Val vt)) σ1 κ e2 σ2 efs →
  head_step (Resolve e (Val vp) (Val vt)) σ1 κ e2 σ2 efs.
Proof.
  intros A [Ks e1' e2' Hfill -> step]. simpl in *.
  induction Ks as [|K Ks _] using rev_ind.
  + simpl in *. subst. inv_head_step. by constructor.
  + rewrite fill_app /= in Hfill. destruct K; inversion Hfill; subst; clear Hfill.
    - rename select ectx_item into Ki.
      assert (fill_item Ki (fill Ks e1') = fill (Ks ++ [Ki]) e1') as Eq1;
        first by rewrite fill_app.
      assert (fill_item Ki (fill Ks e2') = fill (Ks ++ [Ki]) e2') as Eq2;
        first by rewrite fill_app.
      rewrite fill_app /=. rewrite Eq1 in A.
      assert (is_Some (to_val (fill (Ks ++ [Ki]) e2'))) as H.
      { apply (A σ1 _ κ σ2 efs). eapply (Ectx_step (Ks ++ [Ki])); done. }
      destruct H as [v H]. apply to_val_fill_some in H. by destruct H, Ks.
    - rename select (of_val vp = _) into Hvp.
      assert (to_val (fill Ks e1') = Some vp) as Hfillvp by rewrite -Hvp //.
      apply to_val_fill_some in Hfillvp as [-> ->]. inv_head_step.
    - rename select (of_val vt = _) into Hvt.
      assert (to_val (fill Ks e1') = Some vt) as Hfillvt by rewrite -Hvt //.
      apply to_val_fill_some in Hfillvt as [-> ->]. inv_head_step.
Qed.

Lemma wp_resolve s E e Φ (p : proph_id) v (pvs : list (val * val)) :
  Atomic StronglyAtomic e →
  to_val e = None →
  proph p pvs -∗
  WP e @ s; E {{ r, ∀ pvs', ⌜pvs = (r, v)::pvs'⌝ -∗ proph p pvs' -∗ Φ r }} -∗
  WP Resolve e (Val $ LitV $ LitProphecy p) (Val v) @ s; E {{ Φ }}.
Proof.
  (* TODO we should try to use a generic lifting lemma (and avoid [wp_unfold])
     here, since this breaks the WP abstraction. *)
  iIntros (A He) "Hp WPe". rewrite !wp_unfold /wp_pre /= He. simpl in *.
  iIntros (q σ1 ns κ κs nt) "[Hcred [Hσ Hκ]] HNC".
  destruct κ as [|[p' [w' v']] κ' _] using rev_ind.
  - iMod ("WPe" $! q σ1 ns [] κs nt with "[$Hcred $Hσ $Hκ] [$]") as "HWpe".
    iModIntro. iApply (step_fupdN_wand with "HWpe"). iNext.
    iIntros "[Hs WPe]".
    iSplit.
    { iDestruct "Hs" as "%". iPureIntro. destruct s; [ by apply resolve_reducible | done]. }
    iIntros (e2 σ2 efs step). exfalso. apply step_resolve in step; last done.
    inv_head_step. match goal with H: ?κs ++ [_] = [] |- _ => by destruct κs end.
  - rewrite -assoc.
    iMod ("WPe" $! q σ1 ns _ _ nt with "[$Hcred $Hσ $Hκ] [$]") as "HWpe".
    iModIntro. iApply (step_fupdN_wand with "HWpe"). iNext.
    iIntros "[Hs WPe]".
    iSplit.
    { iDestruct "Hs" as %?. iPureIntro. destruct s; [ by apply resolve_reducible | done]. }
    iIntros (e2 σ2 efs step). apply step_resolve in step; last done.
    inv_head_step; simplify_list_eq.
    iMod ("WPe" $! (Val w') σ2 efs with "[%]") as "WPe".
    { by eexists [] _ _. }
    iDestruct "WPe" as "[[$ [$ Hκ]] WPe]".
    iMod (proph_map_resolve_proph p' (w',v') κs with "[$Hκ $Hp]") as (vs' ->) "[$ HPost]".
    iModIntro. rewrite !wp_unfold /wp_pre /=. iDestruct "WPe" as "[HΦ $]".
    iIntros.
    iMod ("HΦ" with "[$]") as "(HΦ&$)". iModIntro. by iApply "HΦ".
Qed.

End lifting.