(**************************************************************************)
(*   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 /.


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.