From Undecidability.L.Datatypes Require Export LNat.
From Undecidability.L Require Export Util.L_facts.
From Undecidability.L.Tactics Require Import LTactics GenEncode.

(* ** Encoding for L-terms *)
MetaCoq Run (tmGenEncodeInj "term_enc" term).
#[export] Hint Resolve term_enc_correct : Lrewrite.

(* register the non-constant constructors *)
#[global]
Instance term_var : computable var.
Proof.
  extract constructor.
Qed.

#[global]
Instance term_app : computable L.app.
Proof.
  extract constructor.
Qed.

#[global]
Instance term_lam : computable lam.
Proof.
  extract constructor.
Qed.


(** Typeclass for decidable propositions *)

Require Import Coq.Logic.Eqdep_dec.
Require Import Coq.Lists.List.
Require Import Crypto.Util.FixCoqMistakes.
Require Import Crypto.Util.Sigma.
Require Import Crypto.Util.HProp.
Require Import Coq.ZArith.BinInt Coq.ZArith.ZArith_dec.
Require Import Coq.NArith.BinNat.

Local Open Scope type_scope.

Class Decidable (P : Prop) := dec : {P} + {~P}.
Arguments dec _%type_scope {_}.
Notation DecidableRel R := (forall x y, Decidable (R x y)).

Global Instance hprop_eq_dec {A} `{DecidableRel (@eq A)} : IsHPropRel (@eq A) | 10.
Proof. repeat intro; apply UIP_dec; trivial with nocore. Qed.

Global Instance eq_dec_hprop {A} {x y : A} {hp : IsHProp A} : Decidable (@eq A x y) | 5.
Proof. left; auto. Qed.

Ltac no_equalities_about x0 y0 :=
  lazymatch goal with
  | [ H' : x0 = y0 |- _ ] => fail
  | [ H' : y0 = x0 |- _ ] => fail
  | [ H' : x0 <> y0 |- _ ] => fail
  | [ H' : y0 <> x0 |- _ ] => fail
  | _ => idtac
  end.

Ltac destruct_decidable_step :=
  match goal with
  | [ H : Decidable _ |- _ ] => destruct H
  | [ H : forall x y : ?A, Decidable (x = y), x0 : ?A, y0 : ?A  |- _ ]
    => no_equalities_about x0 y0; destruct (H x0 y0)
  | [ H : forall a0 (x y : _), Decidable (x = y), x0 : ?A, y0 : ?A  |- _ ]
    => no_equalities_about x0 y0; destruct (H _ x0 y0)
  end.
Ltac destruct_decidable := repeat destruct_decidable_step.

Ltac pre_decide_destruct_sigma_step :=
  match goal with
  | [ H : sigT _ |- _ ] => destruct H
  | [ H : sig _ |- _ ] => destruct H
  | [ H : ex _ |- _ ] => destruct H
  end.
Ltac pre_decide_destruct_sigma := repeat pre_decide_destruct_sigma_step.

Ltac pre_decide :=
  repeat (intros
          || destruct_decidable
          || split
          || pre_decide_destruct_sigma
          || unfold Decidable in *
          || hnf).

(** Put the [subst] and reasoning about equalities after the [left]
    and [right]; opaque equality proofs should not block decidability
    proofs. *)
Ltac post_decide :=
  repeat (intros
          || subst
          || pre_hprop).

Ltac solve_decidable_transparent_with tac :=
  pre_decide;
  try solve [ left; abstract (post_decide; tac)
            | right; abstract (post_decide; tac)
            | decide equality; eauto with nocore ].

Ltac solve_decidable_transparent := solve_decidable_transparent_with firstorder.

Local Hint Extern 0 => solve [ solve_decidable_transparent ] : typeclass_instances.
Local Hint Extern 1 => progress inversion_sigma : core.

Global Instance dec_True : Decidable True | 10 := left I.
Global Instance dec_False : Decidable False | 10 := right (fun x => x).
Global Instance dec_or {A B} `{Decidable A, Decidable B} : Decidable (A \/ B) | 10. exact _. Defined.
Global Instance dec_and {A B} `{Decidable A, Decidable B} : Decidable (A /\ B) | 10. exact _. Defined.
Global Instance dec_impl {A B} `{Decidable (B \/ ~A)} : Decidable (A -> B) | 10. exact _. Defined.
Global Instance dec_impl_simple {A B} `{Decidable A, Decidable B} : Decidable (A -> B) | 10. exact _. Defined.
Global Instance dec_iff {A B} `{Decidable A, Decidable B} : Decidable (A <-> B) | 10. exact _. Defined.
Lemma dec_not {A} `{Decidable A} : Decidable (~A).
Proof. solve_decidable_transparent. Defined.
(** Disallow infinite loops of dec_not *)
Global Hint Extern 0 (Decidable (~?A)) => apply (@dec_not A) : typeclass_instances.
Global Instance dec_eq_unit : DecidableRel (@eq unit) | 10. exact _. Defined.
Global Instance dec_eq_bool : DecidableRel (@eq bool) | 10. exact _. Defined.
Global Instance dec_eq_Empty_set : DecidableRel (@eq Empty_set) | 10. exact _. Defined.
Global Instance dec_eq_prod {A B} `{DecidableRel (@eq A), DecidableRel (@eq B)} : DecidableRel (@eq (A * B)) | 10. exact _. Defined.
Global Instance dec_eq_option {A} `{DecidableRel (@eq A)} : DecidableRel (@eq (option A)) | 10. exact _. Defined.
Global Instance dec_eq_list {A} `{DecidableRel (@eq A)} : DecidableRel (@eq (list A)) | 10. exact _. Defined.
Global Instance dec_eq_list_nil_r {A} {ls} : Decidable (ls = @nil A) | 10.
Proof. destruct ls; [ left; reflexivity | right; abstract congruence ]. Defined.
Global Instance dec_eq_list_nil_l {A} {ls} : Decidable (@nil A = ls) | 10.
Proof. destruct ls; [ left; reflexivity | right; abstract congruence ]. Defined.
Global Instance dec_eq_sum {A B} `{DecidableRel (@eq A), DecidableRel (@eq B)} : DecidableRel (@eq (A + B)) | 10. exact _. Defined.
Global Instance dec_eq_sigT_hprop {A P} `{DecidableRel (@eq A), forall a : A, IsHProp (P a)} : DecidableRel (@eq (@sigT A P)) | 10. exact _. Defined.
Global Instance dec_eq_sig_hprop {A} {P : A -> Prop} `{DecidableRel (@eq A), forall a : A, IsHProp (P a)} : DecidableRel (@eq (@sig A P)) | 10. exact _. Defined.
Global Instance dec_eq_comparison : DecidableRel (@eq comparison) | 10. exact _. Defined.

Global Instance dec_eq_nat : DecidableRel (@eq nat) | 10. exact _. Defined.
Global Instance dec_le_nat : DecidableRel le := Compare_dec.le_dec.
Global Instance dec_lt_nat : DecidableRel lt := Compare_dec.lt_dec.
Global Instance dec_ge_nat : DecidableRel ge := Compare_dec.ge_dec.
Global Instance dec_gt_nat : DecidableRel gt := Compare_dec.gt_dec.

Global Instance dec_eq_N : DecidableRel (@eq N) | 10 := N.eq_dec.

Global Instance dec_eq_Z : DecidableRel (@eq Z) | 10 := Z.eq_dec.
Global Instance dec_lt_Z : DecidableRel BinInt.Z.lt := ZArith_dec.Z_lt_dec.
Global Instance dec_le_Z : DecidableRel BinInt.Z.le := ZArith_dec.Z_le_dec.
Global Instance dec_gt_Z : DecidableRel BinInt.Z.gt := ZArith_dec.Z_gt_dec.
Global Instance dec_ge_Z : DecidableRel BinInt.Z.ge := ZArith_dec.Z_ge_dec.

Global Instance dec_Forall {A P} {HD : forall x : A, Decidable (P x)} {ls}
  : Decidable (Forall P ls) | 10.
Proof.
  induction ls as [|x xs IHxs]; [ left | destruct (HD x), IHxs; [ left | right.. ] ];
    [ constructor; assumption | constructor; assumption | intro Hn.. ];
    clear HD;
    try abstract (inversion Hn; subst; tauto).
Defined.
Global Instance dec_Exists {A P} {HD : forall x : A, Decidable (P x)} {ls}
  : Decidable (Exists P ls) | 10.
Proof.
  induction ls as [|x xs IHxs]; [ right | destruct (HD x), IHxs; [ left.. | right ] ];
    [ intro Hn | constructor; assumption.. | intro Hn ];
    clear HD;
    try abstract (inversion Hn; subst; tauto).
Defined.

Global Instance dec_match_pair {A B} {P : A -> B -> Prop} {x : A * B}
       {HD : Decidable (P (fst x) (snd x))}
  : Decidable (let '(a, b) := x in P a b) | 1.
Proof. edestruct (_ : _ * _); assumption. Defined.

Global Instance dec_if_bool {b : bool} {A B} {HA : Decidable A} {HB : Decidable B}
  : Decidable (if b then A else B) | 10
  := if b return Decidable (if b then A else B)
     then HA
     else HB.

Lemma not_not P {d:Decidable P} : not (not P) <-> P.
Proof. destruct (dec P); intuition. Qed.

Global Instance dec_ex_forall_not : forall T (P:T->Prop) {d:Decidable (exists b, P b)}, Decidable (forall b, ~ P b).
Proof.
  intros T P d.
  destruct (dec (~ exists b, P b)) as [Hd|Hd]; [left|right];
    [abstract eauto | let Hd := Hd in abstract (rewrite not_not in Hd by eauto; destruct Hd; eauto) ].
Defined.

Lemma eqsig_eq {T} {U} {Udec:DecidableRel (@eq U)} (f g:T->U) (x x':T) pf pf' :
  (exist (fun x => f x = g x) x pf) = (exist (fun x => f x = g x) x' pf') <-> (x = x').
Proof. apply path_sig_hprop_iff; auto using UIP_dec, Udec. Qed.

Lemma Decidable_respects_iff A B (H : A <-> B) : (Decidable A -> Decidable B) * (Decidable B -> Decidable A).
Proof. solve_decidable_transparent. Defined.

Lemma Decidable_iff_to_impl A B (H : A <-> B) : Decidable A -> Decidable B.
Proof. solve_decidable_transparent. Defined.

Lemma Decidable_iff_to_flip_impl A B (H : A <-> B) : Decidable B -> Decidable A.
Proof. solve_decidable_transparent. Defined.

Global Instance dec_eq_positive : DecidableRel (@eq BinNums.positive) | 10 := BinPos.Pos.eq_dec.
Global Instance dec_lt_positive : DecidableRel BinPos.Pos.lt.
Proof. eauto using Decidable_iff_to_impl, Pos.ltb_lt with typeclass_instances. Defined.
Global Instance dec_le_positive : DecidableRel BinPos.Pos.le.
Proof. eauto using Decidable_iff_to_impl, Pos.leb_le with typeclass_instances. Defined.
Global Instance dec_gt_positive : DecidableRel BinPos.Pos.gt.
Proof. eauto using Decidable_iff_to_flip_impl, Pos.gt_lt_iff with typeclass_instances. Defined.
Global Instance dec_ge_positive : DecidableRel BinPos.Pos.ge.
Proof. eauto using Decidable_iff_to_flip_impl, Pos.ge_le_iff with typeclass_instances. Defined.

Lemma dec_of_semidec {P : Prop} (H : option P) (H_complete : H = None -> ~P) : Decidable P.
Proof. destruct H; [ left; assumption | right; apply H_complete, eq_refl ]. Defined.

Lemma dec_rel_of_semidec_rel {A} {R : A -> A -> Prop} (H : forall x y, option (R x y))
      (H_complete : forall x y, H x y = None -> ~R x y) : DecidableRel R.
Proof. eauto using dec_of_semidec. Defined.

Lemma dec_of_bool_dec {P : Prop} (b : bool) (Hbl : b = true -> P) (Hlb : P -> b = true)
  : Decidable P.
Proof. destruct b; [ left; apply Hbl; reflexivity | right; intro p; apply Bool.diff_false_true, Hlb, p ]. Defined.

Definition bool_of_dec (P : Prop) {H : Decidable P} : bool := if H then true else false.
Lemma bp_of_dec (P : Prop) {H : Decidable P} : bool_of_dec P = true -> P.
Proof. cbv [bool_of_dec]; destruct H; [ trivial with nocore | abstract congruence ]. Defined.
Lemma pb_of_dec (P : Prop) {H : Decidable P} : P -> bool_of_dec P = true.
Proof. cbv [bool_of_dec]; destruct H; [ reflexivity | abstract tauto ]. Defined.

Lemma dec_rel_of_bool_dec_rel {A} {R : A -> A -> Prop} (b : A -> A -> bool)
      (Hbl : forall x y, b x y = true -> R x y) (Hlb : forall x y, R x y -> b x y = true)
  : DecidableRel R.
Proof. eauto using dec_of_bool_dec. Defined.

Definition bool_rel_of_dec_rel {A} (R : A -> A -> Prop) {H : DecidableRel R} : A -> A -> bool
  := fun x y => if H x y then true else false.
Lemma br_of_dec_rel {A} (R : A -> A -> Prop) {H : DecidableRel R}
  : forall x y, bool_rel_of_dec_rel R x y = true -> R x y.
Proof. cbv [bool_rel_of_dec_rel]; intros x y; destruct (H x y); [ trivial with nocore | abstract congruence ]. Defined.
Lemma rb_of_dec_rel {A} (R : A -> A -> Prop) {H : DecidableRel R}
  : forall x y, R x y -> bool_rel_of_dec_rel R x y = true.
Proof. cbv [bool_rel_of_dec_rel]; intros x y; destruct (H x y); [ reflexivity | abstract tauto ]. Defined.

Lemma dec_bool : forall {P} {Pdec:Decidable P}, (if dec P then true else false) = true -> P.
Proof. intros. destruct dec; solve [ auto | discriminate ]. Qed.

Ltac vm_decide_no_check := apply dec_bool; vm_cast_no_check (eq_refl true).
Ltac lazy_decide_no_check := apply dec_bool; exact_no_check (eq_refl true).

Ltac vm_decide := abstract vm_decide_no_check.
Ltac lazy_decide := abstract lazy_decide_no_check.

(** For dubious compatibility with [eauto using]. *)
Global Hint Extern 2 (Decidable _) => progress unfold Decidable : typeclass_instances core.

Definition cast_if_eq {T} `{DecidableRel (@eq T)} {P} (t t' : T) (v : P t) : option (P t')
  := match dec (t = t'), dec (t' = t') with
     | left pf, left pf' => Some (eq_rect _ P v _ (eq_trans pf (eq_sym pf')))
     | _, right pf' => match pf' eq_refl with end
     | right pf, _ => None
     end.

Lemma cast_if_eq_refl {T H P} t v : @cast_if_eq T H P t t v = Some v.
Proof.
  compute; clear; destruct (H t t) as [ [] |e];
    [ reflexivity | destruct (e eq_refl) ].
Qed.


(* Copyright (c) 2012-2015, Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
Require Import String axiomatic_simple.

Section gcd.
Context `{EnvSpec K}.
Hint Extern 10 (Some Readable ⊆ _) => transitivity (Some Writable): core.
Hint Extern 0 (perm_locked _ = _) =>
  apply perm_Readable_locked; auto : typeclass_instances.

Hint Resolve ax_load' ax_var' assert_memext_l' assert_eval_int_cast_self'
  assert_memext_r' assert_and_l assert_singleton_eval assert_int_typed_eval
  assert_eval_singleton_r assert_eval_singleton_l assert_and_intro : exec.
Ltac exec :=
  repeat match goal with A := _ : assert _ |- _ => progress unfold A end;
  simpl; eauto 20 with exec.

Definition gcd_stmt : stmt K :=
  "l" :; if{load (var 1)} local{uintT} (
    !(var 2 ::= (
        var 0 ::= load (var 1) .{ArithOp ModOp} load (var 2),,
        var 1 ::= load (var 2),,
        load (var 0)));;
    goto "l"
  ) else skip.
Lemma gcd_typed : (∅,∅,[uintT%T;uintT%T]) ⊢ gcd_stmt : (false,None).
Proof.
  change false with (true && false).
  repeat (apply SLocal_typed || typed_constructor
                             || constructor); try set_solver.
  apply base_binop_type_of_sound; simpl.
  by rewrite (idemp_L _), int_promote_int.
Qed.
Lemma gcd_correct Γ δ R J T C y z μ1 γ1 μ2 γ2 :
  sep_valid γ1 → Some Writable ⊆ perm_kind γ1 →
  sep_valid γ2 → Some Writable ⊆ perm_kind γ2 →
  J "l"%string ≡{Γ,δ} (∃ y' z',
    ⌜ Z.gcd y' z' = Z.gcd y z ⌝%Z ★
    var 0 ↦{μ1,γ1} #intV{uintT} y' : uintT ★
    var 1 ↦{μ2,γ2} #intV{uintT} z' : uintT)%A →
  Γ\ δ\ R\ J\ T\ C ⊨ₛ
    {{ var 0 ↦{μ1,γ1} #intV{uintT} y : uintT ★
       var 1 ↦{μ2,γ2} #intV{uintT} z : uintT }}
      gcd_stmt
    {{ var 0 ↦{μ1,γ1} #intV{uintT} (Z.gcd y z) : uintT ★
       var 1 ↦{μ2,γ2} #intV{uintT} 0 : uintT }}.
Proof.
  intros ???? HJ; eapply ax_comp.
  { eapply ax_stmt_weaken_pre, ax_label; rewrite HJ.
    apply assert_exist_intro with y, assert_exist_intro with z.
    by rewrite assert_Prop_l by done. }
  eapply ax_stmt_weaken_pre; [by rewrite HJ|].
  apply ax_stmt_exist_pre; intros y'; apply ax_stmt_exist_pre; intros z'.
  apply ax_stmt_Prop_pre; try set_solver; intros Hgcd.
  eapply ax_stmt_weaken_pre.
  { by rewrite (assert_singleton_int_typed' _ _ (var 0)),
      (assert_singleton_int_typed' _ _ (var 1)), (assoc (★)%A),
      (comm _ _ (⌜ int_typed z' _ ⌝)%A), <-!(assoc (★)%A). }
  apply ax_stmt_Prop_pre; try set_solver; intros Hz'.
  apply ax_stmt_Prop_pre; try set_solver; intros Hy'.
  eapply ax_if'' with (intV{uintT} z')%B; auto.
  { apply ax_expr_frame_l'.
    rewrite (assert_singleton_l _ _ (var 1)) at 1.
    apply ax_expr_exist_pre; intros a1.
    eapply ax_expr_weaken_post';
      [by rewrite <-(assert_singleton_l_2 Γ _ (var 1) _ _ _ a1)|exec]. }
  { by eapply assert_exist_intro, assert_eval_int_unop';
      auto using assert_memext_r', assert_eval_singleton_r. }
  { apply ax_stmt_Prop_pre; try set_solver; simpl; intros.
    apply ax_local.
    set (R' v := (var 0 ↦{false,perm_full} - : uintT%BT ★ R v↑)%A).
    set (J' l := (var 0 ↦{false,perm_full} - : uintT%BT ★ (J l)↑)%A).
    set (T' n := (var 0 ↦{false,perm_full} - : uintT%BT ★ (T n)↑)%A).
    set (C' mz := (var 0 ↦{false,perm_full} - : uintT%BT ★ (C mz)↑)%A).
    rewrite !assert_lift_sep, !assert_lift_singleton; simpl.
    apply ax_comp with (
        var 0 ↦{false,perm_full} #intV{uintT} (y' `mod` z') : uintT
      ★ var 1 ↦{μ1,γ1} #intV{uintT} z' : uintT
      ★ var 2 ↦{μ2,γ2} #intV{uintT} (y' `mod` z') : uintT)%A.
    * eapply ax_do' with _ (inr (intV{uintT} (y' `mod` z')));
        [|by rewrite <-!assert_unlock_sep,
                     <-(assert_lock_singleton _ _ (var 2)), <-2!unlock_indep].
      rewrite (assert_singleton_l_ _ _ (var 0)), assert_exist_sep.
      apply ax_expr_exist_pre; intros a_tmp.
      eapply ax_expr_weaken_post';
        [by rewrite <-(assert_singleton_l_2 Γ _ (var 0) _ _ _ a_tmp)|].
      rewrite <-!(assoc (★)%A); apply ax_expr_invariant_l'.
      rewrite (right_id _ (★)%A), (assert_singleton_l _ _ (var 1)),
        (assert_exist_sep (A:=ptr _)), (assert_sep_exist (A:=ptr _)).
      apply ax_expr_exist_pre; intros a_y.
      eapply ax_expr_weaken_post';
        [by rewrite <-(assert_singleton_l_2 Γ _ (var 1) _ _ _ a_y)|].
      rewrite !(assoc (★)%A), !(comm (★)%A _ (_ ∧ _)%A).
      rewrite <-!(assoc (★)%A); apply ax_expr_invariant_l'.
      rewrite (assert_singleton_l _ _ (var 2)), !(assert_sep_exist (A:=ptr _)).
      apply ax_expr_exist_pre; intros a_z.
      eapply ax_expr_weaken_post';
        [by rewrite <-(assert_singleton_l_2 Γ _ (var 2) _ _ _ a_z)|].
      rewrite <-!(comm (★)%A _ (var 2 ⇓ _ ∧ _)%A), !(assoc (★)%A).
      apply ax_expr_invariant_r'.
      set (A' := ((var 2 ⇓ inl a_z ∧ emp) ★
        (var 1 ⇓ inl a_y ∧ emp) ★ var 0 ⇓ inl a_tmp ∧ emp)%A).
      rewrite <-!(assoc (★)%A).
      eapply ax_assign_r' with
        (%a_tmp ↦{false,perm_full} #intV{uintT} (y' `mod` z') : uintT
        ★ %a_y ↦{μ1,γ1} #intV{uintT} z' : uintT
        ★ %a_z ↦{μ2,γ2} #intV{uintT} z' : uintT)%A
        μ2 γ2 uintT%T a_z (intV{uintT} (y' `mod` z')) _; try by exec.
      { eapply ax_expr_comma' with
          (%a_tmp ↦{false,perm_full} #intV{uintT} (y' `mod` z') : uintT
          ★ %a_y ↦{μ1,γ1} #intV{uintT} y' : uintT
          ★ %a_z ↦{μ2,γ2} #intV{uintT} z' : uintT)%A
          (inr (intV{uintT} (y' `mod` z'))).
        { eapply ax_expr_weaken_post'; [by rewrite <-!assert_unlock_sep,
            <-(assert_lock_singleton _ _ (%a_tmp)), <-2!unlock_indep by done|].
          apply ax_expr_invariant_r'.
          set (A'' := ((%a_y ↦{μ1,γ1} #intV{uintT} y' : uintT%BT
            ★ %a_z ↦{μ2,γ2} #intV{uintT} z' : uintT%BT) ★ A')%A).
          eapply ax_assign_r' with _ _ perm_full
            uintT%T _ (intV{uintT} (y' `mod` z')) _.
          * exec.
          * eapply ax_binop_r'; try by exec.
            eapply assert_eval_int_arithop'; try by exec.
            + by simpl; rewrite (idemp_L _), int_promote_int.
            + by simpl; rewrite int_pre_cast_self by done.
            + simpl; rewrite !int_pre_cast_self by done.
              apply int_typed_unsigned_nonneg in Hy'.
              apply int_typed_unsigned_nonneg in Hz'.
              by rewrite Z.rem_mod_nonneg by lia.
          * cut (int_typed (y' `mod` z') uintT); [exec|].
            rewrite int_typed_spec_alt in Hz', Hy' |- *; simpl in *.
            split; [apply Z.mod_pos_bound;lia|].
            transitivity z'; [apply Z.mod_pos_bound|]; lia.
          * rewrite <-(right_id _ (★)%A) at 1.
            apply assert_sep_preserving, assert_wand_intro;
              rewrite ?(left_id _ (★)%A); eauto using assert_exist_intro.
          * done. }
        eapply ax_expr_comma' with _ (inr (intV{uintT} z')); [|exec].
        eapply ax_expr_weaken_post'; [by rewrite <-!assert_unlock_sep,
          <-(assert_lock_singleton _ _ (%a_y)), <-2!unlock_indep by done|].
        apply ax_expr_frame_l', ax_expr_invariant_r'.
        set (A'' := (%a_z ↦{μ2,γ2} #intV{uintT} z' : uintT%BT ★ A')%A).
        eapply ax_assign_r' with _ _ γ1 uintT%T _ (intV{uintT} z') _; try exec.
        * rewrite <-(right_id _ (★)%A);
          apply assert_sep_preserving, assert_wand_intro;
            rewrite ?(left_id _ (★)%A); eauto using assert_exist_intro. }
      { rewrite !(assoc (★)%A),
          (comm (★)%A _ (%a_z ↦{_,_} _ : _)%A).
        eauto using assert_sep_preserving,
          assert_wand_intro, assert_exist_intro. }
    * eapply ax_stmt_weaken_pre, ax_goto.
      apply assert_sep_preserving; eauto using assert_exist_intro.
      rewrite HJ; repeat setoid_rewrite (assert_lift_exists Γ δ).
      apply assert_exist_intro with z', assert_exist_intro with (y' `mod` z')%Z.
      rewrite !assert_lift_sep, !assert_lift_singleton, stack_indep; simpl.
      assert (Z.gcd z' (y' `mod` z') = Z.gcd y z).
      { by rewrite Z.gcd_comm, Z.gcd_mod, Z.gcd_comm by lia. }
      by rewrite assert_Prop_l by auto using Z_mod_pos, Z.gcd_mod with lia. }
  { eapply ax_stmt_weaken_pre, ax_skip; simpl.
    apply assert_Prop_intro_l; intros ->.
    by rewrite Z.gcd_0_r_nonneg in Hgcd
      by eauto using int_typed_unsigned_nonneg; subst. }
Qed.
End gcd.


(**
This file is part of the Elfic library

Copyright (C) Boldo, Clément, Leclerc

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

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

From Coq Require Import
    ssreflect
    ssrsearch
    Utf8
    Lia
    Lra

    Rdefinitions
    Rbasic_fun
    Raxioms
.

From Coquelicot Require Import
    Hierarchy
    Rbar
    Lim_seq
.

Require Import
    hierarchy_notations
    simpl_fun
    BInt_sf
    Bsf_Lsf
    CUS_Lim_seq
    topology_compl
    series
    Bi_fun
    BInt_Bif
.

Require Import
    measure
    LInt_p
    Rbar_compl
    simple_fun
    measurable_fun
    sigma_algebra
    sigma_algebra_R_Rbar_new
    subset_compl
.

Section BInt_to_LInt_p.

    (* espace de départ *)
    Context {X : Set}.
    (* Un espace mesuré *)
    Context {gen : (X -> Prop) -> Prop}.
    Context {μ : measure gen}.

    Lemma LInt_p_minus_le :
        ∀ f g : X -> R,
        inhabited X ->
        measurable_fun_R gen f ->
        measurable_fun_R gen g ->
        (∀ x : X, 0 <= f x) ->
        (∀ x : X, 0 <= g x) ->
        is_finite (LInt_p μ f) ->
        is_finite (LInt_p μ g) ->
            Rabs (LInt_p μ f - LInt_p μ g) <= LInt_p μ (fun x => Rabs (f x - g x)).
    Proof.
        move => f g ι Hmeasf Hmeasg Hposf Hposg Hfinf Hfing.
        assert (is_finite (LInt_p μ (λ x : X, Rabs (f x - g x)))) as finH1.
        apply: Rbar_bounded_is_finite.
        apply LInt_p_ge_0 => //.
        move => x /=; apply Rabs_pos.
        2 : easy.
        apply Rbar_le_trans with (LInt_p μ (λ x : X, Rbar_plus (f x) (g x))).
        apply LInt_p_monotone.
        move => x; rewrite Rbar_finite_plus.
        setoid_rewrite <-Rabs_pos_eq at 6 7.
        2, 3 : easy.
        setoid_rewrite <-Rabs_Ropp at 3.
        unfold Rminus.
        apply Rabs_triang.
        apply Rbar_le_refl.
        rewrite LInt_p_plus => //.
        2, 3 : apply measurable_fun_R_Rbar => //.
        rewrite <-Hfinf, <-Hfing => //.

        apply Rabs_le; split.
        suff: (LInt_p μ (λ x : X, g x) <= LInt_p μ (λ x : X, Rabs (f x - g x)) + LInt_p μ (λ x : X, f x)).
        lra.
        rewrite (LInt_p_ext _ _ (fun x => Rabs (f x - g x - f x))).
        all : swap 1 2.
        move => x.
        replace (f x - g x - f x) with (- g x) by lra.
        rewrite Rabs_Ropp.
        rewrite Rabs_pos_eq => //.
        apply RIneq.Rle_trans with (LInt_p μ (λ x : X, Rabs (f x - g x) + f x)).
        suff: Rbar_le (LInt_p μ (λ x : X, Rabs (f x - g x - f x))) (LInt_p μ (λ x : X, Rabs (f x - g x) + f x)).
        all : swap 1 2.
        apply LInt_p_monotone.
        move => x /=.
        setoid_rewrite <-Rabs_pos_eq at 12.
        2 : apply Hposf.
        setoid_rewrite <-Rabs_Ropp at 3.
        unfold Rminus at 1.
        apply Rabs_triang.
        assert (is_finite (LInt_p μ (λ x : X, Rabs (f x - g x - f x)))).
        rewrite (LInt_p_ext _ _ (fun x => g x)).
        assumption.
        move => x; replace (f x - g x - f x) with (- g x) by lra.
        rewrite Rabs_Ropp Rabs_pos_eq => //.
        rewrite <-H; clear H.
        assert (is_finite (LInt_p μ (λ x : X, Rabs (f x - g x) + f x))).
        rewrite (LInt_p_ext _ _ (λ x : X, Rbar_plus (Rabs (f x - g x)) (f x))).
        rewrite LInt_p_plus.
        rewrite <-Hfinf, <-finH1 => //.
        exact ι.
        move => x /=; apply Rabs_pos.
        apply measurable_fun_R_Rbar.
        2 : move => x /=; easy.
        2 : apply measurable_fun_R_Rbar => //.
        2 : easy.
        apply measurable_fun_composition with gen_R.
        apply measurable_fun_Rplus.
        assumption.
        apply measurable_fun_ext with (fun x => (-1) * (g x)).
        move => x; lra.
        apply measurable_fun_scal_R.
        assumption.
        suff: measurable_fun open open Rabs.
        move => Hmeas P /measurable_R_equiv_oo/Hmeas/measurable_R_equiv_oo//.
        apply measurable_fun_continuous.
        apply ElemFct.continuous_Rabs.
        rewrite <-H; clear H.
        simpl => //.
        rewrite (LInt_p_ext _ _ (fun x => Rbar_plus (Rabs (f x - g x)) (f x))).
        rewrite LInt_p_plus => //.
        rewrite <-Hfinf, <-finH1 => /=.
        apply RIneq.Rle_refl.
        move => x /=; apply Rabs_pos.
        apply measurable_fun_R_Rbar.
        apply measurable_fun_composition with gen_R.
        apply measurable_fun_Rplus.
        assumption.
        apply measurable_fun_ext with (fun x => (-1) * (g x)).
        move => x; lra.
        apply measurable_fun_scal_R.
        assumption.
        suff: measurable_fun open open Rabs.
        move => Hmeas P /measurable_R_equiv_oo/Hmeas/measurable_R_equiv_oo//.
        apply measurable_fun_continuous.
        apply ElemFct.continuous_Rabs.
        apply measurable_fun_R_Rbar => //.
        by [].

        suff: (LInt_p μ (λ x : X, f x) <= LInt_p μ (λ x : X, Rabs (f x - g x)) + LInt_p μ (λ x : X, g x)) by lra.
        rewrite (LInt_p_ext _ _ (fun x => Rabs (f x - g x + g x))).
        all : swap 1 2.
        move => x.
        replace (f x - g x + g x) with (f x) by lra.
        rewrite Rabs_pos_eq => //.
        apply RIneq.Rle_trans with (LInt_p μ (λ x : X, Rabs (f x - g x) + g x)).
        suff: Rbar_le (LInt_p μ (λ x : X, Rabs (f x - g x + g x))) (LInt_p μ (λ x : X, Rabs (f x - g x) + g x)).
        all : swap 1 2.
        apply LInt_p_monotone.
        move => x /=.
        setoid_rewrite <-Rabs_pos_eq at 12.
        2 : apply Hposg.
        apply Rabs_triang.
        assert (is_finite (LInt_p μ (λ x : X, Rabs (f x - g x + g x)))).
        rewrite (LInt_p_ext _ _ (fun x => f x)).
        assumption.
        move => x; replace (f x - g x + g x) with (f x) by lra.
        rewrite Rabs_pos_eq => //.
        rewrite <-H; clear H.
        assert (is_finite (LInt_p μ (λ x : X, Rabs (f x - g x) + g x))).
        rewrite (LInt_p_ext _ _ (λ x : X, Rbar_plus (Rabs (f x - g x)) (g x))).
        rewrite LInt_p_plus.
        rewrite <-Hfing, <-finH1 => //.
        exact ι.
        move => x /=; apply Rabs_pos.
        apply measurable_fun_R_Rbar.
        2 : move => x /=; easy.
        2 : apply measurable_fun_R_Rbar => //.
        2 : easy.
        apply measurable_fun_composition with gen_R.
        apply measurable_fun_Rplus.
        assumption.
        apply measurable_fun_ext with (fun x => (-1) * (g x)).
        move => x; lra.
        apply measurable_fun_scal_R.
        assumption.
        suff: measurable_fun open open Rabs.
        move => Hmeas P /measurable_R_equiv_oo/Hmeas/measurable_R_equiv_oo//.
        apply measurable_fun_continuous.
        apply ElemFct.continuous_Rabs.
        rewrite <-H; clear H.
        simpl => //.
        rewrite (LInt_p_ext _ _ (fun x => Rbar_plus (Rabs (f x - g x)) (g x))).
        rewrite LInt_p_plus => //.
        rewrite <-Hfing, <-finH1 => /=.
        apply RIneq.Rle_refl.
        move => x /=; apply Rabs_pos.
        apply measurable_fun_R_Rbar.
        apply measurable_fun_composition with gen_R.
        apply measurable_fun_Rplus.
        assumption.
        apply measurable_fun_ext with (fun x => (-1) * (g x)).
        move => x; lra.
        apply measurable_fun_scal_R.
        assumption.
        suff: measurable_fun open open Rabs.
        move => Hmeas P /measurable_R_equiv_oo/Hmeas/measurable_R_equiv_oo//.
        apply measurable_fun_continuous.
        apply ElemFct.continuous_Rabs.
        apply measurable_fun_R_Rbar => //.
        by [].
    Qed.

    Lemma is_finite_LInt_p_Bif {f : X -> R} :
        ∀ bf : Bif μ f,
        (∀ x : X, 0 <= bf x) ->
        is_finite (LInt_p μ (λ x : X, bf x)).
    Proof.
        move => bf Pos_bf.
        rewrite (LInt_p_ext _ _ (‖ bf ‖)%fn).
        apply integrable_Bif.
        move => x; unfold fun_norm.
        unfold norm => /=.
        unfold abs => /=.
        rewrite Rabs_pos_eq => //.
    Qed.

    Definition sf_shifter (sf : simpl_fun R_NormedModule gen) :
        simpl_fun R_NormedModule gen.
    (* Definition *)
        assert (measurable gen (fun x : X => sf x ≠ 0)).
        apply (measurable_fun_sf sf (fun x : R => x ≠ 0)).
        apply measurable_gen.
        apply NM_open_neq.
        pose M := proj1_sig (sf_bounded sf).
        exact (M ⋅ (sf_indic_aux _ _ H))%sf.
    Defined.

    Lemma pos_shifted_sf :
        ∀ sf : simpl_fun R_NormedModule gen,
            ∀ x : X, 0 <= (sf + (sf_shifter sf))%sf x.
    Proof.
        move => sf x.
        rewrite fun_sf_plus.
        unfold sf_shifter => /=.
        case: (ClassicalDescription.excluded_middle_informative
        (sf x ≠ 0)).
        move => Neq0.
        case: (sf_bounded sf) => M HM /=.
        unfold scal => /=.
        unfold mult => /=.
        rewrite RIneq.Rmult_1_r.
        unfold norm in HM; simpl in HM.
        unfold abs in HM; simpl in HM.
        apply RIneq.Rle_trans with (sf x + Rabs (sf x)).
        apply RIneq.Rle_trans with (sf x + - sf x).
        replace (sf x + - sf x) with (sf x - sf x).
        2 : unfold Rminus => //.
        rewrite RIneq.Rminus_eq_0; apply RIneq.Rle_refl.
        apply RIneq.Rplus_le_compat_l.
        apply Rcomplements.Rabs_maj2.
        apply RIneq.Rplus_le_compat_l.
        apply HM.
        case: (eq_dec (sf x) 0) => //.
        move => -> _.
        rewrite scal_zero_r.
        rewrite plus_zero_r.
        apply RIneq.Rle_refl.
    Qed.

    Lemma BInt_LInt_p_eq {f : X -> R} :
        ∀ bf : Bif μ f,
        (∀ x : X, 0 <= bf x) ->
        BInt bf = LInt_p μ (bf : X -> R).
    Proof.
        move => bf.
        case_eq bf => sf ι isf axfpw axfl1 /= Eqf axpos.
        apply lim_seq_eq => /=.
        apply is_lim_seq_epsilon.
        move => ɛ Hɛ.
        suff: (∃ N : nat,
            ∀ n : nat, N ≤ n →
            (‖ minus (BInt_sf μ (sf n + sf_shifter (sf n))%sf) (LInt_p μ (λ x : X, f x + (sf_shifter (sf n) x))) ‖) < ɛ).
        case => N HN.
        exists N => n /HN.
        rewrite BInt_sf_plus_aux.
        unfold sf_shifter.
        case: (sf_bounded (sf n)) => M HM.
        rewrite BInt_sf_scal_aux.
        rewrite BInt_sf_indic.
        simpl.
        rewrite (LInt_p_ext _ _ (fun x => Rbar_plus (f x) (Rbar_mult M (charac (fun x => sf n x ≠ 0) x)))).
        rewrite LInt_p_plus.
        rewrite LInt_p_scal.
        rewrite LInt_p_charac.
        assert (is_finite (μ (λ x : X, sf n x ≠ 0))).
        apply: finite_sf_preim_neq_0' => //.
        rewrite <-H => /=.
        unfold scal => /=.
        rewrite (LInt_p_ext _ _ (bf : X -> R)).
        2 : rewrite Eqf => //.
        2, 4 : exact ι.
        rewrite <-(is_finite_LInt_p_Bif).
        2 : rewrite Eqf => //.
        simpl.
        unfold minus.
        rewrite <-plus_assoc.
        rewrite opp_plus.
        setoid_rewrite plus_comm at 3.
        rewrite <-plus_assoc.
        rewrite plus_opp_l plus_zero_r.
        easy.
        apply (measurable_fun_sf (sf n) (λ x, x ≠ 0)).
        apply measurable_gen.
        apply NM_open_neq.
        move => x /=.
        unfold charac.
        case: (ClassicalDescription.excluded_middle_informative (sf n x ≠ 0)).
        1,2 : move => _.
        exact RIneq.Rle_0_1.
        apply RIneq.Rle_refl.
        all : swap 1 2.
        case ι => x.
        apply RIneq.Rle_trans with (‖ sf n x ‖).
        apply norm_ge_0.
        apply HM.
        2 : exact ι.
        all : swap 1 2.
        move => x; apply axpos.
        all : swap 3 1.
        move => x => /=.
        apply RIneq.Rmult_le_pos.
        apply RIneq.Rle_trans with (‖ sf n x ‖).
        apply norm_ge_0.
        apply HM.
        unfold charac.
        case: (ClassicalDescription.excluded_middle_informative (sf n x ≠ 0)).
        1,2 : move => _.
        exact RIneq.Rle_0_1.
        apply RIneq.Rle_refl.
        5 : apply isf.
        5 : apply: integrable_sf_indic.
        5 : apply (measurable_fun_sf (sf n) (λ x, x ≠ 0)).
        5 : apply measurable_gen.
        5 : apply NM_open_neq.
        5 : apply: finite_sf_preim_neq_0'.
        5 : apply isf.
        apply measurable_fun_R_Rbar.
        suff: (measurable_fun gen open f).
        move => Hmeas P /measurable_R_equiv_oo/Hmeas//.
        apply measurable_fun_ext with (fun x => bf x).
        move => x; rewrite Eqf //.
        apply: measurable_Bif; exact bf.
        apply measurable_fun_charac.
        apply (measurable_fun_sf (sf n) (λ x, x ≠ 0)).
        apply measurable_gen.
        apply NM_open_neq.
        apply measurable_fun_mult.
        apply measurable_fun_cte.
        apply measurable_fun_charac.
        apply (measurable_fun_sf (sf n) (λ x, x ≠ 0)).
        apply measurable_gen.
        apply NM_open_neq.
        move => x; unfold charac.
        case: (ClassicalDescription.excluded_middle_informative (sf n x ≠ 0)).
        move => Neq0 /=.
        unfold scal => /=; unfold mult => //.
        move => NNeq0 /=.
        unfold scal => /=; unfold mult => //.

        pose sigɛ := {| RIneq.pos := ɛ; RIneq.cond_pos := Hɛ |}.
        case: (axfl1 sigɛ) => _; case => N HN.
        exists N => n Hn.
        pose Hn' := (HN _ Hn); clearbody Hn'.
        rewrite Raxioms.Rplus_0_l in Hn'.
        simpl in Hn'; clear HN.
        unfold minus.
        rewrite BInt_sf_LInt_SFp.
        all : swap 1 2.
        apply integrable_sf_plus.
        apply isf.
        apply: integrable_sf_indic.
        apply (measurable_fun_sf (sf n) (λ x, x ≠ 0)).
        apply measurable_gen.
        apply NM_open_neq.
        apply: finite_sf_preim_neq_0'.
        apply isf.
        rewrite <-LInt_p_SFp_eq.
        2 : exact ι.
        all : swap 1 2.
        move => x /=.
        apply pos_shifted_sf.
        unfold opp.
        pose ss := sf_shifter (sf n).
        assert (ss = sf_shifter (sf n)) as Eqss by easy.
        clearbody ss.
        rewrite <-Eqss => /=.
        apply RIneq.Rle_lt_trans with (LInt_p μ (fun x => Rabs ((sf n + ss)%sf x - (f x + ss x)%R))).
        unfold norm => /=.
        unfold abs => /=.
        apply LInt_p_minus_le.
        exact ι.
        rewrite Eqss.
        suff: (measurable_fun gen open (sf n + sf_shifter (sf n))%sf).
        move => Hmeas P /measurable_R_equiv_oo/Hmeas//.
        apply measurable_fun_sf.
        apply measurable_fun_Rplus.
        suff: (measurable_fun gen open f).
        move => Hmeas P /measurable_R_equiv_oo/Hmeas//.
        apply measurable_fun_ext with (fun x => bf x).
        move => x; rewrite Eqf => //.
        apply: measurable_Bif; exact bf.
        suff: (measurable_fun gen open ss).
        move => Hmeas P /measurable_R_equiv_oo/Hmeas//.
        rewrite Eqss.
        apply measurable_fun_sf.
        move => x; rewrite Eqss.
        apply pos_shifted_sf.
        move => x.
        apply RIneq.Rplus_le_le_0_compat.
        apply axpos.
        rewrite Eqss /=.
        case: (ClassicalDescription.excluded_middle_informative (sf n x ≠ 0)).
        1, 2 : case: (sf_bounded (sf n)) => M HM.
        move => _ /=.
        unfold scal => /=; unfold mult => /=.
        rewrite RIneq.Rmult_1_r.
        apply RIneq.Rle_trans with (‖ sf n x ‖).
        apply norm_ge_0.
        apply HM.
        move => _ /=.
        rewrite scal_zero_r; unfold zero => /=.
        apply RIneq.Rle_refl.
        replace (LInt_p μ (λ x : X, (sf n + ss)%sf x)) with
            (Finite (BInt_sf μ (sf n + ss)%sf)).
        easy.
        rewrite Finite_BInt_sf_LInt_SFp.
        rewrite <-LInt_p_SFp_eq => //.
        move => x /=.
        rewrite Eqss.
        apply pos_shifted_sf.
        apply integrable_sf_plus.
        apply isf.
        rewrite Eqss.
        apply: integrable_sf_indic.
        apply (measurable_fun_sf (sf n) (λ x, x ≠ 0)).
        apply measurable_gen.
        apply NM_open_neq.
        apply: finite_sf_preim_neq_0'.
        apply isf.
        rewrite (LInt_p_ext _ _ (fun x => Rbar_plus (f x) (ss x))).
        2 : easy.
        rewrite LInt_p_plus => //.
        rewrite (LInt_p_ext _ _ (fun x => bf x)).
        2 : move => x; rewrite Eqf => //.
        pose H := (integrable_Bif bf).
        rewrite <-is_finite_LInt_p_Bif.
        2 : rewrite Eqf => //.
        assert (is_finite (LInt_p μ (λ x : X, ss x))).
        replace (LInt_p μ (λ x : X, (ss)%sf x)) with
            (Finite (BInt_sf μ (ss)%sf)).
        easy.
        rewrite Finite_BInt_sf_LInt_SFp.
        rewrite <-LInt_p_SFp_eq => //.
        move => x.
        rewrite Eqss /=.
        case: (ClassicalDescription.excluded_middle_informative (sf n x ≠ 0)).
        1, 2 : case: (sf_bounded (sf n)) => M HM.
        move => _ /=.
        unfold scal => /=; unfold mult => /=.
        rewrite RIneq.Rmult_1_r.
        apply RIneq.Rle_trans with (‖ sf n x ‖).
        apply norm_ge_0.
        apply HM.
        move => _ /=.
        rewrite scal_zero_r; unfold zero => /=.
        apply RIneq.Rle_refl.
        rewrite Eqss.
        apply: integrable_sf_indic.
        apply (measurable_fun_sf (sf n) (λ x, x ≠ 0)).
        apply measurable_gen.
        apply NM_open_neq.
        apply: finite_sf_preim_neq_0'.
        apply isf.
        rewrite <-H0.
        apply Rbar_finite_plus.
        apply measurable_fun_R_Rbar.
        suff: (measurable_fun gen open f).
        move => Hmeas P /measurable_R_equiv_oo/Hmeas//.
        apply measurable_fun_ext with (fun x => bf x).
        move => x; rewrite Eqf //.
        apply: measurable_Bif; exact bf.
        rewrite Eqss => x /=.
        case: (ClassicalDescription.excluded_middle_informative (sf n x ≠ 0)).
        1, 2 : case: (sf_bounded (sf n)) => M HM.
        move => _ /=.
        unfold scal => /=; unfold mult => /=.
        rewrite RIneq.Rmult_1_r.
        apply RIneq.Rle_trans with (‖ sf n x ‖).
        apply norm_ge_0.
        apply HM.
        move => _ /=.
        rewrite scal_zero_r; unfold zero => /=.
        apply RIneq.Rle_refl.
        apply measurable_fun_R_Rbar.
        suff: (measurable_fun gen open (λ x, ss x)).
        move => Hmeas P /measurable_R_equiv_oo/Hmeas//.
        rewrite Eqss.
        apply measurable_fun_sf.

        rewrite (LInt_p_ext _ _ (λ x : X, (‖ f - sf n ‖)%fn x)).
        assert (is_finite (LInt_p μ (λ x : X, (‖ f - sf n ‖)%fn x))).
        apply Rbar_bounded_is_finite with 0 ɛ.
        apply LInt_p_ge_0 => //.
        move => x; unfold fun_norm; apply norm_ge_0.
        apply Rbar_lt_le => //.
        1, 2 : easy.
        rewrite <-H in Hn'.
        simpl in Hn' => //.
        move => x; unfold fun_norm, norm => /=.
        unfold abs => /=.
        unfold fun_plus.
        rewrite fun_sf_plus.
        unfold fun_scal.
        rewrite scal_opp_one.
        unfold opp => /=.
        unfold plus => /=.
        unfold Rminus.
        rewrite Rplus_assoc.
        setoid_rewrite Rplus_comm at 2.
        rewrite <-Rplus_assoc.
        rewrite RIneq.Ropp_plus_distr.
        do 2 rewrite Rplus_assoc.
        rewrite RIneq.Rplus_opp_l.
        rewrite RIneq.Rplus_0_r.
        rewrite <-Rabs_Ropp.
        rewrite RIneq.Ropp_plus_distr.
        rewrite RIneq.Ropp_involutive.
        congr Rabs.
        rewrite Rplus_comm => //.
    Qed.

End BInt_to_LInt_p.


(** * Writer *)

(** Output events. *)

(* begin hide *)
Set Implicit Arguments.
Set Contextual Implicit.

From Coq Require Import
     List.
Import ListNotations.

From ExtLib Require Import
     Structures.Functor
     Structures.Monad
     Structures.Monoid.

From ITree Require Import
     Basics.Basics
     Basics.CategoryOps
     Basics.MonadState
     Indexed.Function
     Indexed.Sum
     Core.ITreeDefinition
     Core.Subevent
     Interp.Interp
     Interp.Handler
     Events.State.

Import Basics.Basics.Monads.
(* end hide *)

(** Event to output values of type [W]. *)
Variant writerE (W : Type) : Type -> Type :=
| Tell : W -> writerE W unit.

(** Output action. *)
Definition tell {W E} `{writerE W -< E} : W -> itree E unit :=
  fun w => trigger (Tell w).

(** One interpretation is to accumulate outputs in a list. *)

(** Note that this handler appends new outputs to the front of the list. *)
Definition handle_writer_list {W E}
  : writerE W ~> stateT (list W) (itree E)
  := fun _ e s =>
       match e with
       | Tell w => Ret (w :: s, tt)
       end.

Definition run_writer_list_state {W E}
  : itree (writerE W +' E) ~> stateT (list W) (itree E)
  := interp_state (case_ handle_writer_list pure_state).

Arguments run_writer_list_state {W E} [T].

(** Returns the outputs in order: the first output at the head, the last
    output and the end of the list. *)
Definition run_writer_list {W E}
  : itree (writerE W +' E) ~> writerT (list W) (itree E)
  := fun _ t =>
       ITree.map (fun wsx => (rev' (fst wsx), snd wsx))
                 (run_writer_list_state t []).

Arguments run_writer_list {W E} [T].

(** When [W] is a monoid, we can also use that to append the outputs together. *)

Definition handle_writer {W E} (Monoid_W : Monoid W)
  : writerE W ~> stateT W (itree E)
  := fun _ e s =>
       match e with
       | Tell w => Ret (monoid_plus Monoid_W s w, tt)
       end.

Definition run_writer {W E} (Monoid_W : Monoid W)
  : itree (writerE W +' E) ~> writerT W (itree E)
  := fun _ t =>
       interp_state (case_ (handle_writer Monoid_W) pure_state) t
                    (monoid_unit Monoid_W).

Arguments run_writer {W E} Monoid_W [T].


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2009-05-06

list of reducts of a term and proof that rewriting is finitely branching
*)

Set Implicit Arguments.

From CoLoR Require Import LogicUtil ATrs RelUtil ListUtil VecUtil AMatching
     NatUtil.

Section S.

  Variable Sig : Signature.

  Notation term := (term Sig). Notation terms := (vector term).
  Notation rule := (rule Sig). Notation rules := (list rule).

(***********************************************************************)
(** top reducts *)

  Definition top_reduct (t : term) lr :=
    match matches (lhs lr) t with
      | Some s => Some (sub s (rhs lr))
      | None => None
    end.

  Lemma top_reduct_correct : forall R lr t u,
    In lr R -> top_reduct t lr = Some u -> hd_red R t u.

  Proof.
    intros R0 lr t u hlr. unfold top_reduct. destruct lr as [l r]. simpl.
    case_eq (matches l t); intros t0 H.
    intro H0. ded (matches_correct H). subst. inversion H0.
    apply hd_red_rule. hyp. discr.
  Qed.

  Definition top_reducts R t := filter_opt (top_reduct t) R.

  Lemma top_reducts_correct : forall t u R,
    In u (top_reducts R t) -> hd_red R t u.

  Proof.
    induction R; simpl. contr.
    assert (h : List.incl R (a::R)). unfold List.incl. simpl. auto.
    case_eq (top_reduct t a); intros t0 H.
    intro H0. simpl in H0. split_all. subst.
    eapply top_reduct_correct with (lr := a). simpl. auto. hyp.
    eapply incl_elim. apply hd_red_incl with (x := R). hyp. tauto.
    eapply incl_elim. apply hd_red_incl with (x := R). hyp. tauto.
  Qed.

  Arguments top_reducts_correct [t u R] _.

  Lemma top_reducts_correct_red : forall t u R,
    In u (top_reducts R t) -> red R t u.

  Proof.
    intros. ded (top_reducts_correct H).
    eapply incl_elim. apply hd_red_incl_red. hyp.
  Qed.

  Lemma top_reducts_complete : forall t u R,
    rules_preserve_vars R -> hd_red R t u -> In u (top_reducts R t).

  Proof.
    induction R; intros; redtac. hyp. simpl in lr.
    assert (h0 : rules_preserve_vars R). eapply rules_preserve_vars_incl.
    2: apply H. apply incl_tl. refl. split_all.
    (* In (mkRule l r) R *)
    2:{ simpl. assert (h1 : hd_red R t u). subst. apply hd_red_rule. hyp.
    case (top_reduct t a). right. apply IHR; hyp. apply IHR; hyp. }
    (* a = mkRule l r *)
    subst a. simpl. unfold top_reduct. simpl.
    case_eq (matches l t).
    intros t0 H0. ded (matches_correct H0). left. subst u. apply sub_eq. intros.
    eapply subeq_inversion. rewrite xl in H1. apply H1.
    unfold rules_preserve_vars in H. unfold List.incl in H. eapply H. simpl.
    auto. hyp.
    intro H0. symmetry in xl. ded (matches_complete xl). congruence.
  Qed.

(***********************************************************************)
(** list of reducts of a term *)

  Variable R : rules.

  Lemma reducts_aux1 : forall k n, S k <= n -> k <= n.

  Proof. lia. Qed.

  Lemma reducts_aux2 : forall k n, S k <= n -> n - S k < n.

  Proof. lia. Qed.

  Fixpoint reducts t :=
    match t with
      | Var _ => top_reducts R t
      | Fun f ts =>
        let fix reducts_vec k (us : terms k) : k <= arity f -> list term :=
          match us in vector _ k return k <= arity f -> list term with
            | Vnil => fun _ => nil
            | Vcons u1 us' => fun h =>
              map (fun x => Fun f (Vreplace ts (reducts_aux2 h) x)) (reducts u1)
              ++ reducts_vec _ us' (reducts_aux1 h)
          end
          in top_reducts R t ++ reducts_vec (arity f) ts (le_refl (arity f))
    end.

  Fixpoint reducts_vec f ts k (us : terms k) : k <= arity f -> list term :=
    match us in vector _ k return k <= arity f -> list term with
      | Vnil => fun _ => nil
      | Vcons u1 us' => fun h =>
        map (fun x => Fun f (Vreplace ts (reducts_aux2 h) x)) (reducts u1)
        ++ reducts_vec f ts us' (reducts_aux1 h)
    end.

  Lemma fix_reducts_vec : forall f ts k us h,
    (fix reducts_vec (k : nat) (us : terms k) : k <= arity f -> list term :=
      match us in (vector _ k0) return (k0 <= arity f -> list term) with
        | Vnil => fun _ => nil
        | Vcons u1 us' => fun h =>
          map (fun x => Fun f (Vreplace ts (reducts_aux2 h) x)) (reducts u1)
          ++ reducts_vec _ us' (reducts_aux1 h)
      end) k us h = reducts_vec f ts us h.

  Proof.
    induction us; simpl; intros. refl. apply app_eq. refl. apply IHus.
  Qed.

  Lemma reducts_fun : forall f ts, reducts (Fun f ts)
    = top_reducts R (Fun f ts) ++ reducts_vec f ts ts (le_refl (arity f)).

  Proof. intros. simpl. rewrite <- fix_reducts_vec. refl. Qed.

(***********************************************************************)
(** properties *)

  Lemma reducts_vec_pi : forall f ts k (us : terms k) h h',
    reducts_vec f ts us h = reducts_vec f ts us h'.

  Proof. intros. assert (h=h'). apply le_unique. subst h'. refl. Qed.

  Lemma reducts_vec_cast : forall f ts k (us : terms k) h k' (e : k = k') h',
    reducts_vec f ts (Vcast us e) h' = reducts_vec f ts us h.

  Proof.
    induction us; intros; destruct k'; try discr. rewrite Vcast_refl. refl.
    rewrite Vcast_cons. simpl. inversion e. subst k'.
    apply app_eq. apply map_eq. intros. apply args_eq. apply Vreplace_pi.
    lia. apply IHus.
  Qed.

  (*Arguments reducts_vec_cast [f ts k us] _ [k' e h'].*)

  Lemma In_reducts_vec_elim_aux : forall v' f ts k (us : terms k),
    (forall i (p : i < k), exists r : arity f - k + i < arity f,
      Vnth us p = Vnth ts r) -> forall h, In v' (reducts_vec f ts us h) ->
    exists i, exists p : i < arity f, exists u',
      In u' (reducts (Vnth ts p)) /\ v' = Fun f (Vreplace ts p u').

  Proof.
    induction us.
    (* Vnil *)
    contr.
    (* Vcons *)
    intros E g H. simpl in H. rewrite in_app in H. split_all.
    (* case 1 *)
    ded (in_map_elim H). decomp H0. destruct (E 0 (lt_O_Sn n)). simpl in H0.
    ex (arity f - S n + 0) x0 x. rewrite <- H0. split_all.
    rewrite H3. apply args_eq. apply Vreplace_pi. lia.
    (* case 2 *)
    assert (E' : forall (i : nat) (p : i < n),
      exists r : arity f - n + i < arity f, Vnth us p = Vnth ts r). intros.
    assert (p' : S i < S n). lia. destruct (E (S i) p'). simpl in H.
    assert (lt_S_n p' = p). apply lt_unique. simpl in H0. rewrite H1 in H0.
    rewrite H0.
    assert (r : arity f - n + i < arity f). lia. exists r. apply Vnth_eq.
    lia.
    assert (h' : n <= arity f). lia.
    rewrite reducts_vec_pi with (h':=h') in H.
    apply IHus with (h:=h'); hyp.
  Qed.

  Arguments In_reducts_vec_elim_aux [v' f ts k us] _ [h] _.

  Lemma In_reducts_vec_elim : forall v' f ts,
    In v' (reducts_vec f ts ts (le_refl (arity f))) ->
    exists i, exists p : i < arity f, exists u',
      In u' (reducts (Vnth ts p)) /\ v' = Fun f (Vreplace ts p u').

  Proof.
    intros. apply In_reducts_vec_elim_aux
    with (k := arity f) (us := ts) (h := le_refl (arity f)).
    intros. assert (r : arity f - arity f + i < arity f). lia. exists r.
    apply Vnth_eq. lia. hyp.
  Qed.

  Arguments In_reducts_vec_elim [v' f ts] _.

  Lemma In_reducts_vec_intro_aux : forall f ts k (us : terms k)
    (h : k <= arity f) t i (p : i < k) (q : arity f - k + i < arity f),
    In t (reducts (Vnth us p)) ->
    In (Fun f (Vreplace ts q t)) (reducts_vec f ts us h).

  Proof.
    induction us.
    (* Vnil *)
    intros. lia.
    (* Vcons *)
    intros g t. simpl.
    set (F := fun x : term => Fun f (Vreplace ts (reducts_aux2 g) x)).
    destruct i; intros p q; rewrite in_app.
    (* i = 0 *)
    left. assert (e : arity f - S n + 0 = arity f - S n). lia.
    rewrite (Vreplace_pi ts q (reducts_aux2 g) t e).
    apply in_map with (f:=F). hyp.
    (* i > 0 *)
    right. assert (q' : arity f - n + i < arity f). lia.
    assert (Vreplace ts q t = Vreplace ts q' t). apply Vreplace_pi. lia.
    rewrite H0. apply IHus with (p := lt_S_n p). hyp.
  Qed.

  Arguments In_reducts_vec_intro_aux _ _ [k us] _ _ [i p] _ _.

  Lemma In_reducts_vec_intro : forall f ts t i (p : i < arity f),
    In t (reducts (Vnth ts p)) ->
    In (Fun f (Vreplace ts p t)) (reducts_vec f ts ts (le_refl (arity f))).

  Proof.
    intros. assert (q : arity f - arity f + i < arity f). lia.
    assert (Vreplace ts p t = Vreplace ts q t). apply Vreplace_pi. lia.
    rewrite H0. apply In_reducts_vec_intro_aux with (p := p). hyp.
  Qed.

(***********************************************************************)
(** alternative definition (Pierre-Yves Strub) *)

  Fixpoint reducts2 t :=
    match t with
      | Var _ => top_reducts R t
      | Fun f ts =>
        let fix reducts2_vec k (us : terms k) : list (terms k) :=
          match us with
            | Vnil => nil
            | Vcons u1 us' => map (fun x => Vcons x us') (reducts2 u1)
              ++ map (fun x => Vcons u1 x) (reducts2_vec _ us')
          end
          in top_reducts R t ++ map (Fun f) (reducts2_vec (arity f) ts)
    end.

  Fixpoint reducts2_vec k (us : terms k) : list (terms k) :=
    match us with
      | Vnil => nil
      | Vcons u1 us' => map (fun x => Vcons x us') (reducts2 u1)
        ++ map (fun x => Vcons u1 x) (reducts2_vec us')
    end.

  Lemma reducts2_fun : forall f ts, reducts2 (Fun f ts)
    = top_reducts R (Fun f ts) ++ map (Fun f) (reducts2_vec ts).

  Proof. auto. Qed.

  Lemma In_reducts2_vec_elim : forall n (vs ts : terms n),
    In vs (reducts2_vec ts) -> exists i, exists p : i < n, exists u,
      In u (reducts2 (Vnth ts p)) /\ vs = Vreplace ts p u.

  Proof.
    induction ts; intros.
    (* Vnil *)
    contr.
    (* Vcons *)
    simpl in H. rewrite in_app in H.
    split_all; ded (in_map_elim H); clear H; decomp H0.
    (* case 1 *)
    set (p := lt_O_Sn n). ex 0 p x. simpl. auto.
    (* case 2 *)
    ded (IHts x H1); clear IHts. decomp H. assert (p : S x0<S n). lia.
    ex (S x0) p x2. simpl. assert (lt_S_n p = x1). apply lt_unique.
    rewrite H. subst x. auto.
  Qed.

  Arguments In_reducts2_vec_elim [n vs ts] _.

  Lemma In_reducts2_vec_intro : forall n (ts : terms n) t i (p : i < n),
    In t (reducts2 (Vnth ts p)) -> In (Vreplace ts p t) (reducts2_vec ts).

  Proof.
    induction ts.
    (* Vnil *)
    intros. lia.
    (* Vcons *)
    destruct i; simpl; intro; rewrite in_app.
    left. apply in_map with (f := fun x => Vcons x ts). hyp.
    right. apply in_map with (f := fun x => Vcons h x). apply IHts. hyp.
  Qed.

(***********************************************************************)
(** correctness *)

  Lemma reducts_correct : forall t u, In u (reducts t) -> red R t u.

  Proof.
    intro t. pattern t; apply term_ind_forall; clear t.
    (* Var *)
    intros. apply top_reducts_correct_red. hyp.
    (* Fun *)
    intros f ts IH u. rewrite reducts_fun, in_app. split_all.
    apply hd_red_incl_red. apply top_reducts_correct. hyp.
    rename H into h. ded (In_reducts_vec_elim h). decomp H.
    ded (Vforall_nth x0 IH _ H1). redtac. unfold red. ex l r.
    assert (h1 : 0+x<=arity f). lia. set (v1 := Vsub ts h1).
    assert (h2 : S x+(arity f-S x)<=arity f). lia. set (v2 := Vsub ts h2).
    assert (e : x+S(arity f-S x)=arity f). lia.
    exists (Cont f e v1 c v2). exists s. split_all. simpl. apply args_eq.
    rewrite <- xl. unfold v2. rewrite Vcons_nth. unfold v1.
    apply Veq_app_cons_aux.
    simpl. rewrite H2. apply args_eq. apply Veq_nth; intros.
    rewrite Vnth_cast, Vnth_app. destruct (le_gt_dec x i).
    (* 1) x <= i *)
    destruct (eq_nat_dec x i).
    (* a) x = i *)
    set (q := Vnth_app_aux (S (arity f - S x)) (Vnth_cast_aux e ip) l0).
    gen q. assert (i - x = 0). subst; clear; lia. rewrite H. intro. simpl.
    trans (Vnth (Vreplace ts x0 x1) x0). apply Vnth_eq. auto.
    rewrite Vnth_replace. hyp.
    (* b) x <> i *)
    rewrite Vnth_replace_neq. 2: hyp.
    rewrite (Veq_app_cons ts x0), Vnth_cast, Vnth_app. destruct (le_gt_dec x i).
    2: lia.
    rewrite !Vnth_cons. destruct (lt_ge_dec 0 (i-x)). unfold v2.
    rewrite !Vnth_sub. apply Vnth_eq. refl. lia.
    (* 2) x > i *)
    rewrite Vnth_replace_neq. 2: lia.
    rewrite (Veq_app_cons ts x0), Vnth_cast, Vnth_app. destruct (le_gt_dec x i).
    lia.
    assert (g0 = g). apply lt_unique. subst g0.
    assert (Vsub ts (Veq_app_cons_aux1 x0) = v1). unfold v1.
    f_equal. apply le_unique. rewrite H. refl.
  Qed.

(***********************************************************************)
(** completeness *)

  Lemma reducts_complete : rules_preserve_vars R ->
    forall t u, red R t u -> In u (reducts t).

  Proof.
    intros H t; pattern t; apply term_ind_forall; clear t; intros.
    (* Var *)
    ded (red_case H0). split_all.
    simpl. apply top_reducts_complete; hyp.
    decomp H2. discr.
    (* Fun *)
    rewrite reducts_fun, in_app. ded (red_case H1). split_all.
    left. apply top_reducts_complete; hyp.
    right. Funeqtac. subst x0. ded (Vforall_nth x2 H0). subst u.
    apply In_reducts_vec_intro. apply H2. hyp.
  Qed.

(***********************************************************************)
(** rewriting is finitely branching *)

  Lemma fin_branch : rules_preserve_vars R -> finitely_branching (red R).

  Proof.
    unfold finitely_branching. intros. exists (reducts x). split_all.
    apply reducts_complete; hyp. apply reducts_correct. hyp.
  Qed.

End S.


From iris.proofmode Require Export base intro_patterns spec_patterns
     sel_patterns coq_tactics reduction
     coq_tactics ltac_tactics.
Require Import FunctionalExtensionality.
From iris Require Export bi.bi proofmode.tactics proofmode.monpred proofmode.reduction.
From stdpp Require Export pmap.

Axiom prop_extensionality : forall A B:Prop, (A <-> B) -> A = B.
Global Set Warnings "-convert_concl_no_check".

Definition pred_incl {A} (P Q : A -> Prop) :=
  forall x, P x -> Q x.

Definition pred_impl {A} (P Q : A -> Prop) :=
  fun x => P x -> Q x.

Notation "P ==> Q" := (pred_incl P Q).

Module SepBasicCore.
  Export monpred.
  Section hprop.
    Context {type : Type}.
    Definition heap : Type := Pmap type.

    (* Properties on heap *)
    Instance heap_union_empty_l : LeftId (=@{heap}) ∅ (∪) := _.
    Instance heap_union_empty_r : RightId (=@{heap}) ∅ (∪) := _.
    Instance heap_union_assoc : base.Assoc (=@{heap}) (∪).
    Proof.
      intros m1 m2 m3. unfold base.union, map_union, union_with, map_union_with.
      apply (merge_assoc _). intros i.
      unfold heap in m1. unfold heap in m2. unfold heap in m3.
        by destruct (m1 !! i), (m2 !! i), (m3 !! i).
    Qed.

    Definition heap_union_comm (h1 h2 : heap) := map_union_comm h1 h2.

    Lemma heap_disjoint_union_l_l : forall (h1 h2 h3 :heap) , h1 ∪ h2 ##ₘ h3 -> h1 ##ₘ h3.
    Proof.
      intros. apply map_disjoint_union_l in H as (P0&P1). assumption.
    Qed.

    Lemma heap_disjoint_union_l_r : forall (h1 h2 h3 :heap) , h1 ∪ h2 ##ₘ h3 -> h2 ##ₘ h3.
    Proof.
      intros. apply map_disjoint_union_l in H as (P0&P1). assumption.
    Qed.

    Lemma heap_disjoint_union_r_r : forall (h1 h2 h3 :heap) , h1 ##ₘ h2 ∪ h3 -> h1 ##ₘ h3.
    Proof.
      intros. apply map_disjoint_union_r in H as (P0&P1). assumption.
    Qed.

    Lemma heap_disjoint_union_r_l : forall (h1 h2 h3 :heap) , h1 ##ₘ h2 ∪ h3 -> h1 ##ₘ h2.
    Proof.
      intros. apply map_disjoint_union_r in H as (P0&P1). assumption.
    Qed.

    (* Operators *)

    Definition hprop := heap -> Prop.

    Definition hand (H1 H2:hprop):hprop :=
      fun h => H1 h /\ H2 h.

    Definition hor (H1 H2:hprop) : hprop := fun h => H1 h \/ H2 h.

    Definition hempty : hprop :=
      fun h => h = ∅.

    Definition hsingle loc t : hprop :=
      fun h =>  h = {[loc := t]}.

    Definition hheap_ctx (ctx : heap) : hprop := fun h => h = ctx.

    Definition hstar (H1 H2 : hprop) : hprop :=
      fun h => exists h1 h2, H1 h1
                     /\ H2 h2
                     /\ (h1 ##ₘ h2)
                     /\ h = h1 ∪ h2.

    Definition hexists {A} (J : A -> hprop) : hprop :=
      fun h => exists x, J x h.

    Definition hpure (P:Prop) : hprop :=
      fun h => P /\ hempty h.

    Definition htop : hprop :=
      fun h => True.

    Definition hforall {A} (f : A -> hprop) : hprop := fun h => forall a, f a h.

    Definition hwand (H1 H2 : hprop) : hprop :=
      hexists (fun (H:hprop) => (hstar H (hpure ((hstar H H1) ==> H2)))).

    Definition qwand A (Q1 Q2:A->hprop) :=
      hforall (fun x => hwand (Q1 x) (Q2 x)).

    Definition hpure_abs (φ : Prop) : hprop := hstar (hpure φ) htop.

    Lemma hempty_intro : hempty ∅.
    Proof using. reflexivity. Qed.

    Lemma hempty_inv : forall h, hempty h -> h = ∅.
    Proof using. auto. Qed.

    Local Notation "'heap_empty'" := (∅ : heap).

    Local Notation "h1 \u h2" := (h1 ∪ h2) (at level 37, right associativity).

    Local Notation "'Hexists' x1 , H" := (hexists (fun x1 => H))
                                           (at level 39, x1 ident, H at level 50).
    Local Notation "'Hexists' x1 x2 , H" := (Hexists x1, Hexists x2, H)
                                              (at level 39, x1 ident, x2 ident, H at level 50).
    Local Notation "'Hexists' x1 x2 x3 , H" := (Hexists x1, Hexists x2, Hexists x3, H)
                                                 (at level 39, x1 ident, x2 ident, x3 ident, H at level 50).

    Local Notation "'\[]'" := (hempty)
                                (at level 0).

    Local Notation "\[ P ]" := (hpure P)
                                 (at level 0, P at level 99, format "\[ P ]").

    Local Notation "H1 '\*' H2" := (hstar H1 H2)
                                     (at level 41, right associativity).

    Local Notation "\Top" := htop.

    Declare Scope heap_scope.

    Hint Resolve heap_union_empty_l heap_union_empty_r hempty_intro map_disjoint_empty_l map_disjoint_empty_r heap_union_assoc heap_disjoint_union_r_l heap_disjoint_union_l_l heap_disjoint_union_r_r heap_disjoint_union_l_r : heap_scope.

    Ltac inversion_star h P :=
      match goal with
      | H : (_ \* _) _ |- _ =>
        let W := fresh h in
        let w := fresh P in
        inversion H as (W&w);
        let W := fresh h in
        destruct w as (W&w);
        do 3 (let w0 := fresh P in
              destruct w as (w0&w))
      end.
    Ltac extens := apply functional_extensionality; intro; apply prop_extensionality.

    Section Properties.

      Lemma hstar_intro : forall (H1 H2 :hprop) h1 h2,
        H1 h1 ->
        H2 h2 ->
        h1 ##ₘ h2 ->
        (H1 \* H2) (h1 ∪ h2).
      Proof using. intros. exists h1; exists h2. auto. Qed.

      Lemma hstar_hempty_l : forall H,
          hempty \* H = H.
      Proof using.
        intros. extens.
        split; intro.
        - inversion_star h P. inversion P0; subst. rewrite heap_union_empty_l. assumption.
        - exists heap_empty; exists x. repeat split; auto with heap_scope. apply map_disjoint_empty_l.
      Qed.

      Lemma hstar_comm : forall H1 H2,
          H1 \* H2 = H2 \* H1.
      Proof using.
        intros H1 H2. extens.
        split; intro P; inversion_star h P; exists h0; exists h; repeat split; auto;
          rewrite heap_union_comm; auto.
      Qed.

      Lemma hstar_assoc : forall H1 H2 H3,
          (H1 \* H2) \* H3 = H1 \* (H2 \* H3).
      Proof using.
        intros H1 H2 H3. extens. split.
        { intros (h'&h3&(h1&h2&M3&M4&D'&U')&M2&D&U). subst h'.
          exists h1; exists (h2 ∪ h3). repeat split; auto.
          { exists h2; exists h3; eauto with heap_scope. }
          { apply map_disjoint_union_l in D as (P0&P1).
            apply map_disjoint_union_r. split; auto. }
          { by rewrite heap_union_assoc. }}
        { intros (h1&h'&M1&(h2&h3&M3&M4&D'&U')&D&U). subst h'.
          exists (h1 ∪ h2); exists h3. repeat split; auto.
          { exists h1; exists h2; eauto with heap_scope. }
          { rewrite map_disjoint_union_l. split; auto.
            apply map_disjoint_union_r in D as (P0&P1).
            assumption. }
            by rewrite <- heap_union_assoc. }
      Qed.

      Lemma hstar_hexists : forall A (J:A->hprop) H,
          (hexists J) \* H = hexists (fun x => (J x) \* H).
      Proof using.
        intros. extens. split; intro M.
        { destruct M as (h1&h2&(h3&M1)&M2&D&U). exists h3; exists h1; exists h2; eauto. }
        { destruct M as (h3&(h1&h2&M1&M2&D&U)). exists h1; exists h2. split; eauto. by exists h3. }
      Qed.

      Lemma himpl_frame_l : forall H2 H1 H1',
          H1 ==> H1' ->
          (H1 \* H2) ==> (H1' \* H2).
      Proof using. intros. intros h P. inversion_star h P. exists h0; exists h1. split; eauto. Qed.

    End Properties.

    Definition hpersistent (H:hprop) : hprop := fun h => H heap_empty.

    Set Warnings "-redundant-canonical-projection".
    Canonical Structure hpropO := leibnizO hprop.

    Definition hprop_emp := hpure True.

    Program Canonical Structure hpropI : bi :=
      Bi hprop _ _ pred_incl hprop_emp hpure_abs hand hor
         pred_impl (@hforall) (@hexists) hstar hwand hpersistent _ _.
    Next Obligation.
      apply discrete_ofe_mixin, _.
    Qed.
    Next Obligation.
      repeat split; try(solve_proper); eauto.
      - intros H h P. assumption.
      - rewrite /Transitive. intros. intros h P. eauto.
      - rewrite leibniz_equiv_iff. intros (P0&P1). extens. split; intro; auto.
      - intros X Y Z. rewrite /hpure_abs. repeat red. intro. extens.
        split; intro; inversion_star h P; exists h; exists h0; repeat split; auto; inversion P0; inversion H2;
          auto with heap_scope; apply H; assumption.
      - intros X Y Z. rewrite /hforall. repeat red. intros. extens. split; intros; repeat red in H;
                                                                      apply functional_extensionality in H; subst; auto.
      - intros X Y Z. rewrite /hexists. repeat red. intros. extens.
        split; intro; repeat red in H; apply functional_extensionality in H; subst; auto.
      - rewrite /hpure_abs. intros φ P. exists heap_empty. exists x. repeat split; auto with heap_scope.
        apply map_disjoint_empty_l.
      - unfold hpure_abs in *. intros x W P h P0. inversion_star h P. inversion P2. apply P; auto.
        exists h0; exists h1. repeat split; auto.
      - rewrite /hforall /hpure_abs. intros h W h0 P. exists heap_empty; exists h0.
        repeat split; auto with heap_scope.
        + intro a. pose (P a). inversion_star h P. inversion P1. apply H.
        + apply map_disjoint_empty_l.
      - rewrite /hand. intros P Q h (P0&P1). apply P0.
      - rewrite /hand. intros P Q h (P0&P1). apply P1.
      - rewrite /hor. intros P Q h P0. auto.
      - rewrite /hor. intros P Q h P0. auto.
      - rewrite /hor. intros P Q h P0 P1 h0 P2. destruct P2; auto.
      - intros x W X H h P x0. apply H. split; auto.
      - intros x W X H h P. destruct P. apply H in H0. apply H0 in H1. assumption.
      - intros x W a H h P h0. apply H. apply P.
      - intros h Q a H H0. apply H0.
      - intros x W H P Q. exists H. apply Q.
      - intros x W Q P h P0. destruct P0. eapply P. apply H.
      - intros P P' Q Q' A B C D. inversion_star h P. exists h; exists h0. repeat split; auto.
      - intros x W A. exists heap_empty; exists W. repeat split; auto with heap_scope.
        apply map_disjoint_empty_l.
      - intros P h Q. inversion_star H H. inversion H3; inversion H6; subst.
        rewrite heap_union_empty_l. apply H4.
      - intros P Q h R. inversion_star H H. exists H2; exists H0. repeat split; auto. subst.
        apply heap_union_comm. apply H5.
      - intros P Q R h P0. rewrite <- hstar_assoc. apply P0.
      - intros P Q R P0 h P1. exists P. exists h; exists heap_empty. repeat split; auto with heap_scope.
        apply map_disjoint_empty_r.
      - intros P Q R W h P0. inversion_star h P. apply W in P2. destruct P2. inversion_star h H.
        inversion H2. apply H4. exists h2; exists h1. repeat split; auto; subst.
        + apply heap_disjoint_union_l_l in P4. apply P4.
        + inversion H5. subst. rewrite heap_union_empty_r. reflexivity.
      - rewrite /hpersistent. intros P Q H h P0. apply H. apply P0.
      - rewrite /hpersistent. rewrite /hforall. intros A B C D E. apply D.
      - rewrite /hpersistent. intros P Q h P0. inversion_star h P. apply P2.
      - intros P Q x W. destruct W. exists heap_empty; exists x. repeat split; auto with heap_scope.
        apply map_disjoint_empty_l.
    Qed.

    Lemma hpure_pure φ : \[φ] = bi_affinely ⌜φ⌝.
    Proof.
      extens. split.
      - intro. destruct H. split. split; auto. exists heap_empty; exists x. repeat split; auto with heap_scope.
        apply map_disjoint_empty_l.
      - intros [? Hφ]. destruct Hφ as (h1&h2&P0&P1&P2&P3). destruct P0. repeat split; auto.
        inversion H. apply H3.
    Qed.

    Lemma htop_True : \Top = True%I.
    Proof.
      extens. split.
      - exists heap_empty; exists x. repeat split; auto with heap_scope. apply map_disjoint_empty_l.
      - red; trivial.
    Qed.

    Opaque hpure_abs.

    (** * Specific Proofmode instances about hpure and htop. *)

    Global Instance htop_absorbing : Absorbing \Top.
    Proof. intros ??. red; trivial. Qed.
    Global Instance htop_persistent : Persistent \Top.
    Proof. intros ??. repeat red. trivial. Qed.

    Global Instance htop_into_pure : IntoPure \Top True.
    Proof.
      unfold IntoPure. intros h H. exists ∅, h. repeat split; auto with heap_scope.
      apply map_disjoint_empty_l.
    Qed.
    Global Instance htop_from_pure a : FromPure a \Top True.
    Proof. intros ??. red; trivial. Qed.

    Global Instance hpure_affine φ : Affine \[φ].
    Proof. rewrite hpure_pure. apply _. Qed.
    Global Instance hpure_persistent φ : Persistent \[φ].
    Proof. rewrite hpure_pure. apply _. Qed.

    Global Instance hpure_into_pure φ : IntoPure \[φ] φ.
    Proof. rewrite hpure_pure /IntoPure. intros h H. destruct H. auto. Qed.
    Global Instance hpure_from_pure φ : FromPure true \[φ] φ.
    Proof. by rewrite hpure_pure /FromPure /= /bi_affinely stdpp.base.comm. Qed.

    Global Instance from_and_hpure φ ψ : FromAnd \[φ ∧ ψ] \[φ] \[ψ].
    Proof.
      rewrite /FromAnd. intros h H. destruct H. inversion H. inversion H0. repeat eexists; auto.
    Qed.
    Global Instance from_sep_hpure φ ψ : FromSep \[φ ∧ ψ] \[φ] \[ψ].
    Proof.
      rewrite /FromSep. intros h H. red in H. inversion_star h P.
      inversion P0. inversion P1. inversion H1. inversion H3. subst. rewrite heap_union_empty_l.
      repeat eexists; auto.
    Qed.

    Global Instance into_and_hpure (p : bool) φ ψ : IntoAnd p \[φ ∧ ψ] \[φ] \[ψ].
    Proof. rewrite /IntoAnd. f_equiv. auto. Qed.
    Global Instance into_sep_hpure φ ψ : IntoSep \[φ ∧ ψ] \[φ] \[ψ].
    Proof. rewrite /IntoSep. auto. Qed.
    Global Instance from_or_hpure φ ψ : FromOr \[φ ∨ ψ] \[φ] \[ψ].
    Proof. rewrite /FromOr. auto. Qed.
    Global Instance into_or_hpure φ ψ : IntoOr \[φ ∨ ψ] \[φ] \[ψ].
    Proof. rewrite /IntoOr. auto. Qed.
    Global Instance from_exist_hpure {A} (φ : A → Prop) :
      FromExist \[∃ x : A, φ x] (λ a : A, \[φ a]).
    Proof. rewrite /FromExist. auto. Qed.
    Global Instance into_exist_hpure {A} (φ : A → Prop) :
      IntoExist \[∃ x : A, φ x] (λ a : A, \[φ a]).
    Proof. rewrite /IntoExist. auto. Qed.
    Global Instance from_forall_hpure {A : Type} `{Inhabited A} (φ : A → Prop) :
      FromForall \[∀ a : A, φ a] (λ a : A, \[φ a]).
    Proof. rewrite /FromForall. auto. Qed.
    Global Instance frame_here_hpure p (φ : Prop) Q :
      FromPure true Q φ → Frame p \[φ] Q emp.
    Proof.
      rewrite /FromPure /Frame=><- /=. destruct p=>/=; iIntros "[% _] !%"; auto.
    Qed.

    (** Instance affine *)

    Global Instance from_affinely_affine P : Affine P → @FromAffinely hpropI P P.
    Proof. intros. rewrite /FromAffinely. iIntros "HA". iApply "HA". Qed.
    Global Instance from_affinely_default P : @FromAffinely hpropI (<affine> P) P | 100.
    Proof. by rewrite /FromAffinely. Qed.
    Global Instance from_affinely_intuitionistically P : @FromAffinely hpropI (□ P) (<pers> P) | 100.
    Proof. by rewrite /FromAffinely. Qed.

    (** Instance Sep *)

    Global Instance from_sep_sep P1 P2 : @FromSep hpropI (P1 ∗ P2) P1 P2 | 100.
    Proof. by rewrite /FromSep. Qed.

    Global Instance into_sep_sep P Q : @IntoSep hpropI (P ∗ Q) P Q.
    Proof. by rewrite /IntoSep. Qed.

    (** Instance Wand *)

    Global Instance from_wand_wand P1 P2 : @FromWand hpropI (P1 -∗ P2) P1 P2.
    Proof. by rewrite /FromWand. Qed.

    Instance inhabited_unit : Inhabited unit.
    Proof.
      split. apply ().
    Qed.

    Instance PreOrder_unit : PreOrder (fun (t1 t2 : unit) => t1 = t2).
    Proof.
      split; repeat red; intros; trivial. destruct x,y,z. reflexivity.
    Qed.

    Program Canonical Structure biInd := BiIndex unit inhabited_unit _ PreOrder_unit.

    Definition single (l : positive) (t : type) : monPred biInd hpropI := MonPred (fun _ => hsingle l t) _.

    Definition heap_ctx (h : heap) : monPred biInd hpropI := MonPred (fun _ => hheap_ctx h) _.

    Ltac inv H := inversion H; clear H; subst.

    Local Open Scope bi_scope.
    Local Notation "l ↦ t" :=
      (single l t) (at level 20) : bi_scope.

    Local Notation "\s l" :=
      (∃ t, l ↦ t) (at level 10) : bi_scope.

    Lemma singleton_false : forall t, ⊢ \s t -∗ \s t -∗ False.
    Proof.
      MonPred.unseal. split. MonPred.unseal. repeat red. intros. destruct i. destruct a. clear H0.
      inv H. inv H1. clear H0. exists emp, heap_empty, heap_empty. repeat split; auto with heap_scope.
      intros h H j C. clear C. clear j. inversion_star h P. clear H. inv P0. inv H0. clear H. clear P2.
      destruct P1. red in H. rewrite heap_union_empty_l. exists (hheap_ctx h1), h1, heap_empty.
      repeat split; eauto with heap_scope. subst. intros h H. inversion_star h P. destruct P1.
      red in H0. red in P0. subst. clear H. erewrite map_disjoint_spec in P2.
      edestruct P2; eapply lookup_singleton_Some; eauto.
      apply map_disjoint_empty_r.
    Qed.

    Definition pure_empty (P : Prop) : monPred biInd hpropI := <affine> ⌜P⌝.

    Local Notation "\⌜ P ⌝" := (pure_empty P)
                                 (at level 0, P at level 99, format "\⌜ P ⌝").

    Global Instance affine_pure (P : Prop) : Affine (pure_empty P).
    Proof.
      red. iIntros "HA". trivial.
    Qed.

    Lemma pureIntro {X} P : ∀ (a b : X), P a ⊢ pure_empty (a = b) -∗ P b.
    Proof.
      iIntros (a b) "HA %". rewrite a0. iApply "HA".
    Qed.

    Lemma pure_empty_destruct : forall P Q, ⊢ \⌜ P /\ Q ⌝ -∗ \⌜ P ⌝ ∗ \⌜ Q ⌝ .
    Proof. iIntros. destruct a. iSplit; iPureIntro; auto. Qed.

    Global Instance affine_heap_empty : Affine (heap_ctx ∅).
    Proof.
      split. intro. MonPred.unseal. repeat red. intros. split; auto.
    Qed.

    Lemma init_heap : ⊢ heap_ctx ∅.
    Proof.
      split. MonPred.unseal. repeat red. intros. inversion H. inversion H1. reflexivity.
    Qed.

    Lemma instance_heap : forall (P : monPred biInd hpropI) (Q : Prop), (forall tmps, P () tmps -> Q) -> (P ⊢ ⌜Q⌝).
    Proof.
      MonPred.unseal. intros. split. repeat red. intros.
      exists ∅, x. repeat split; auto. destruct i. eapply H. eauto.
      apply map_disjoint_empty_l. rewrite heap_union_empty_l. reflexivity.
    Qed.

    Lemma soundness1 h (Φ : Prop) : (heap_ctx h ⊢ (⌜ Φ ⌝) : monPred biInd hpropI) -> Φ.
    Proof.
      MonPred.unseal=> -[H]. repeat red in H.
      pose (e := H () h).
      edestruct e as (h1&h2&P0&P1&P2&P3).
      - reflexivity.
      - inversion P0. apply H0.
    Qed.

    Lemma soundness2 (Φ : monPred biInd hpropI) h : (⊢heap_ctx h -∗ Φ) -> Φ () h.
    Proof.
      MonPred.unseal=> -[H]. repeat red in H.
      pose (e := H () ∅).
      simpl in *. edestruct e.
      - rewrite monPred_at_emp. split; auto; apply hempty_intro.
      - repeat red. exists ∅. exists ∅. repeat split; auto. rewrite heap_union_empty_l. auto.
      - inversion_star h P.
        inversion P1.
        apply H1.
        exists heap_empty; exists h.
        inversion H2; subst. rewrite heap_union_empty_r in P; subst.
        repeat split; auto. apply map_disjoint_empty_l. rewrite heap_union_empty_l. auto.
    Qed.

    Lemma soundness3 (Φ : monPred biInd hpropI) h : Φ () h -> (⊢heap_ctx h -∗ Φ).
    Proof.
      MonPred.unseal. unfold monPred_wand_def. unfold monPred_upclosed. simpl. split.
      intros. simpl. repeat red. intros. exists emp. exists x; exists heap_empty.
      repeat split; auto with heap_scope. rewrite monPred_at_emp in H0. apply H0.
      intros h0 P0. inversion_star h P. simpl in *. rewrite <- P2 in *. inversion P1. inversion H3.
      subst. rewrite heap_union_empty_l. rewrite <- P2. destruct a. apply H.
      apply map_disjoint_empty_r.
    Qed.

    Lemma heap_ctx_split (h h' : heap) : h ##ₘ h' -> (⊢heap_ctx (h \u h') -∗ heap_ctx h ∗ heap_ctx h').
    Proof.
      intro.
      MonPred.unseal. repeat red.
      unfold monPred_wand_def.
      unfold monPred_sep_def.
      unfold monPred_upclosed. split. simpl.
      intro. intro P. intro. repeat red. exists hempty. rewrite monPred_at_emp in H0.
      inversion H0; subst.
      exists heap_empty; exists heap_empty. repeat split; auto.
      + repeat intro. inversion_star h P. inversion P1. subst.
        exists h; exists h'. repeat split; auto. inversion P2; subst.
        rewrite heap_union_empty_l. reflexivity.
      + inversion H3. rewrite heap_union_empty_l. reflexivity.
    Qed.

    Lemma heap_ctx_split_sing (h : heap) l t : h ##ₘ ({[l := t]}) ->
                                                (⊢heap_ctx (<[l := t]>h) -∗ heap_ctx h ∗ l ↦ t).
    Proof.
      iIntros (?) "HA". rewrite insert_union_singleton_r; auto. iApply heap_ctx_split; auto.
      rewrite <- map_disjoint_singleton_r. eauto.
    Qed.

  End hprop.

  Notation "'heap_empty'" := (∅ : heap).

  Notation "h1 \u h2" := (h1 ∪ h2) (at level 37, right associativity).

  Notation "'Hexists' x1 , H" := (hexists (fun x1 => H))
                                   (at level 39, x1 ident, H at level 50).
  Notation "'Hexists' x1 x2 , H" := (Hexists x1, Hexists x2, H)
                                      (at level 39, x1 ident, x2 ident, H at level 50).
  Notation "'Hexists' x1 x2 x3 , H" := (Hexists x1, Hexists x2, Hexists x3, H)
                                         (at level 39, x1 ident, x2 ident, x3 ident, H at level 50).

  Notation "'\[]'" := (hempty) (at level 0).

  Notation "\[ P ]" := (hpure P) (at level 0, P at level 99, format "\[ P ]").

  Notation "H1 '\*' H2" := (hstar H1 H2) (at level 41, right associativity).

  Notation "\Top" := htop.

  Declare Scope heap_scope.

  Hint Resolve heap_union_empty_l heap_union_empty_r hempty_intro map_disjoint_empty_l map_disjoint_empty_r heap_union_assoc heap_disjoint_union_r_l heap_disjoint_union_l_l heap_disjoint_union_r_r heap_disjoint_union_l_r : heap_scope.

  Ltac inversion_star h P :=
    match goal with
    | H : (_ \* _) _ |- _ =>
      let W := fresh h in
      let w := fresh P in
      inversion H as (W&w);
      let W := fresh h in
      destruct w as (W&w);
      do 3 (let w0 := fresh P in
            destruct w as (w0&w))
    end.

  Open Scope bi_scope.

  Notation "l ↦ t" :=
    (single l t) (at level 20) : bi_scope.

  Notation "\s l" :=
    (∃ t, l ↦ t) (at level 10) : bi_scope.

  Notation "\⌜ P ⌝" := (pure_empty P)
                         (at level 0, P at level 99, format "\⌜ P ⌝").

  Local Ltac Fresh :=
    let x := iFresh in
    match x with
    | IAnon ?x =>
      let x := eval compute in (ascii_of_pos (x + 64)) in
          let x := eval compute in (append "H" (string_of_list_ascii [x])) in
              let env := iGetCtx in
              let P := reduction.pm_eval (envs_lookup x env) in
              match P with
              | None => x
              | Some _ => Fresh
              end
    | _ => fail "iFresh returns " x " sometimes."
    end.

  (*h should be in the environment *)
  Local Ltac norm h :=
    let env := iGetCtx in
    let P := reduction.pm_eval (envs_lookup h env) in
    match P with
    | None => fail "assert false"
    | Some (false, ?P) =>
      match P with
      | bi_exist ?Q => let x := fresh "x" in (iDestruct h as (x) h; norm h)
      | bi_sep ?Q ?W =>
        let x := Fresh in
        let y := Fresh in
        eapply tac_and_destruct with h _ x y _ _ _;
        [ pm_reflexivity | pm_reduce; iSolveTC | pm_reduce; norm x; norm y]
      | pure_empty (and ?P ?Q) =>
        let x := Fresh in
        iPoseProof (pure_empty_destruct with h) as x; norm x
      | pure_empty _ => iPure h as ?
      | bi_pure (and ?P ?Q) =>
        let x := Fresh in
        eapply tac_and_destruct with h _ h x _ _ _;
        [pm_reflexivity
        |pm_reduce; iSolveTC
        |pm_reduce; norm h; norm x]
      | bi_pure _ => iPure h as ?
      | bi_wand _ _ => iDestruct (h with "[]") as h; [progress auto | norm h]
      | bi_absorbingly _ =>
        let name := Fresh in
        let name_mod := eval compute in (append ">" name) in
            iPoseProof h as name; iDestruct name as name_mod; norm name
      | _ =>
        match h with
        | IAnon _ =>
          let x := Fresh in
          iPoseProof h as x
        | _ => idtac
        end
      end
    | Some (true,?P) => idtac
    end.

  (* (List.fold norm) in Ltac *)
  Local Ltac norm_list l :=
    match l with
    | [] => idtac
    | ?h :: ?t => norm h ; norm_list t
    end.

  (* List.fold norm list_ident idtac *)
  Ltac norm_all :=
    iStartProof;
    let env := iGetCtx in
    let list_ident := eval compute in (rev (envs_dom env)) in
        norm_list list_ident; auto.

  Tactic Notation "iNorm" := norm_all.

  (* Context {type : Type}. *)
  (* Lemma test : forall P Q (R T: monPred biInd (@hpropI type)), *)
  (*     ⊢  <absorb> (T ∗ R) -∗ (∃ (x: nat), (True -∗ T)) -∗ ⌜ P /\ Q ⌝ -∗ ((⌜ P ⌝ -∗ R) ∗ True) -∗ <absorb> R. *)
  (* Proof. iIntros. destruct a. iNorm. Qed. *)

End SepBasicCore.

Module fresh.
  Import SepBasicCore.
  Definition ident := positive.

  Record state_gen {X} := mk_state
                            {state_heap : @heap X;
                             next : ident;
                             wf_heap : forall p, (∃ v, state_heap !! p = Some v) -> Pos.lt p next
                            }.

  Lemma succ_fresh_state : forall {X} (x : X) (s : @state_gen X),
      forall (p :ident), (∃ v, (<[next s:=x]>(state_heap s)) !! p = Some v) -> Pos.lt p (Pos.succ (next s)).
  Proof.
    intros. destruct s. destruct H. simpl in *. destruct (Pos.eq_dec next0 p).
    - subst. lia.
    - rewrite lookup_insert_ne in H; auto.
      assert (Pos.lt p next0). apply wf_heap0. eauto. lia.
  Qed.

  Definition fresh {X} (x : X) (s: state_gen) : ident * state_gen :=
    let h := state_heap s in
    let n := next s in
    (n, mk_state X (<[next s:=x]>h) (Pos.succ n) (succ_fresh_state x s)).

  Lemma fresh_is_fresh : forall {X} (l : @state_gen X), (state_heap l) !! (next l) = None.
  Proof.
    destruct l. simpl. destruct (state_heap0 !! next0) eqn:?; auto.
    assert (Pos.lt next0 next0). apply wf_heap0. eauto. lia.
  Qed.

End fresh.

Require Import Ctypes.

Module gensym.
  Import Errors.
  Export SepBasicCore.
  Import fresh.

  Definition state := @state_gen type.

  Lemma init_state : forall {X},
      forall (p :ident), (∃ v, (∅ : @heap X) !! p = Some v) -> Pos.lt p xH.
  Proof.
    intros. destruct H. rewrite lookup_empty in H. inversion H.
  Qed.

  Definition initial_state : state := mk_state type ∅ xH init_state.

  Import fresh.
  Inductive sig (X : Type) : Type :=
  | Err : Errors.errmsg -> sig X
  | Gensym : type -> (ident -> X) -> sig X.

  Arguments Err [X].
  Arguments Gensym [X].

  Inductive mon (X : Type) : Type :=
  | ret : X -> mon X
  | op : sig (mon X) -> mon X.

  Arguments ret {_} x.
  Arguments op {_} s.

  Fixpoint bind {X Y} (m : mon X) (f : X -> mon Y) : mon Y :=
    match m with
    | ret x => f x
    | op (Err e) => op (Err e)
    | op (Gensym t g) => op (Gensym t (fun x => bind (g x) f))
    end.

  Notation "'let!' x ':=' e1 'in' e2" := (bind e1 (fun x => e2))
                                           (x ident, at level 90).

  Definition error {X} (e : Errors.errmsg) : mon X := op (Err e).
  Definition gensym (t : type) : mon ident := op (Gensym t ret).

  Lemma lid : forall X Y (a : X) (f : X -> mon Y), bind (ret a) f = f a.
  Proof. auto. Qed.

  Lemma rid : forall X (m : mon X), bind m ret = m.
  Proof.
    fix m 2.
    destruct m0.
    * reflexivity.
    * destruct s.
      ** reflexivity.
      ** simpl. do 2 f_equal. apply functional_extensionality. intro. apply m.
  Qed.

  Lemma ass_bind : forall X Y Z (m : mon X) f (g : Y -> mon Z),
      bind (bind m f) g = bind m (fun x => bind (f x) g).
  Proof.
    fix m 4.
    destruct m0; intros.
    * reflexivity.
    * destruct s.
      ** reflexivity.
      ** simpl. do 2 f_equal. apply functional_extensionality. intro. apply m.
  Qed.

  (* Inductive err (X: Type) : Type := *)
  (* | Erro : Errors.errmsg -> err X *)
  (* | Res : X -> err X. *)

  (* Arguments Erro [X]. *)
  (* Arguments Res [X]. *)
  Local Open Scope positive_scope.

  Fixpoint run {X} (m : mon X) : state -> res (state * X) :=
    match m with
    | ret v => fun s => OK (s, v)
    | op (Err e) => fun s => Error e
    | op (Gensym t f) =>
      fun s =>
        let (l,s') := fresh t s in
        run (f l) s'
    end.

End gensym.

Module weakestpre_gensym.
  Export gensym.
  Export proofmode.monpred.
  Export SepBasicCore.
  Import reduction.

  Definition iProp := monPred biInd (@hpropI type).

  Fixpoint mwp {X} (e1 : mon X) (Q : X -> iProp) : iProp :=
    match e1 with
    | ret v => Q v
    | op (Err e) => True
    | op (Gensym _ f) =>
      ∀ l, \s l -∗ mwp (f l) Q
    end.

  Notation "'WP' e |{ Φ } |" := (mwp e Φ)
                                  (at level 20, e, Φ at level 200, only parsing) : bi_scope.

  Notation "'WP' e |{ v , Q } |" := (mwp e (λ v, Q))
                                      (at level 20, e, Q at level 200,
                                       format "'[' 'WP'  e  '[ ' |{  v ,  Q  } | ']' ']'") : bi_scope.

  Notation "'{{' P } } e {{ x .. y , 'RET' pat ; Q } }" :=
    (∀ Φ,
        P -∗ (∀ x, .. (∀ y, Q -∗ Φ pat) .. ) -∗ WP e |{ Φ }|)%I
                                                             (at level 20, x closed binder, y closed binder,
                                                              format "'[hv' {{  P  } }  '/  ' e  '/'  {{  x  ..  y ,  RET  pat ;  Q  } } ']'") : bi_scope.

  (** wp rules *)
  (** Generic rules *)
  Lemma wp_value' {X} (Φ : X -> iProp) (v : X) : Φ v ⊢ WP ret v |{ Φ }|%I.
  Proof. auto. Qed.

  Lemma wp_value_inv' {X} Φ (v : X) : WP ret v |{ Φ }| ⊢ Φ v%I.
  Proof. auto. Qed.

  Lemma wp_mono {X} e (Φ Ψ : X -> iProp) :
    WP e |{ Φ }| ⊢ (∀ (v : X), Φ v -∗ Ψ v) -∗ WP e |{ Ψ }|%I.
  Proof.
    iIntros "HA HB". revert e. fix e 1.
    destruct e0.
    { iApply "HB". iApply "HA". }
    { destruct s.
      { simpl. trivial. }
      { simpl. iIntros (l) "HC".
        iDestruct ("HA" with "HC") as "HA".
        iPoseProof "HB" as "HB". apply e. }}
  Qed.

  Lemma wp_bind {X Y} (e : mon X) (f :  X → mon Y) (Φ : Y -> iProp)  (Φ' : X -> iProp) :
    WP e |{ Φ' }| ⊢ (∀ v,  Φ' v -∗ WP (f v) |{ Φ }|) -∗ WP bind e f |{ Φ }|%I.
  Proof.
    iIntros "HA HB". revert e. fix e 1.
    destruct e0.
    { iApply "HB". iApply "HA". }
    { destruct s.
      { simpl. auto. }
      { simpl. iIntros (l) "HC".
        iDestruct ("HA" with "HC") as "HA".
        iPoseProof "HB" as "HB". apply e. }}
  Qed.

  (** Monad rules *)
  Lemma wp_gensym (t : type) : ⊢ WP gensym t |{ l, \s l }|.
  Proof.
    simpl. iIntros. auto.
  Qed.

  Lemma wp_frame_l {X} (e : mon X) Φ (R : iProp) : R ∗ WP e |{ Φ }| ⊢ WP e |{ v, R ∗ Φ v }|.
  Proof. iIntros "[HA HB]". iApply (wp_mono with "HB"). auto with iFrame. Qed.
  Lemma wp_frame_r {X} (e : mon X) Φ R : WP e |{ Φ }| ∗ R ⊢ WP e |{ v, Φ v ∗ R }|.
  Proof. iIntros "[H ?]". iApply (wp_mono with "H"); auto with iFrame. Qed.

  (** triple rules *)
  (** Generic rules *)

  Lemma ret_spec_complete {X} (v : X) H (Q : X -> iProp) :
    (H ⊢ Q v) -> ⊢{{ H }} ret v {{ v', RET v'; Q v' }}.
  Proof.
    iIntros (? ?) "HA HB". iDestruct (H0 with "HA") as "HA". iApply "HB". iApply "HA".
  Qed.

  Lemma ret_spec {X} (v : X) :
    ⊢{{ emp }} ret v {{ v', RET v'; ⌜ v' = v ⌝  }}.
  Proof. iIntros (?) "HA HB". iApply "HB". auto. Qed.

  Lemma ret_spec_pure {X} (v : X) :
    ⊢{{ emp }} ret v {{ v', RET v'; \⌜ v' = v ⌝  }}.
  Proof.
    iIntros (?) "HA HB". iApply "HB". auto.
  Qed.

  Lemma ret_spec_bis {X} (v : X) (Q : X -> iProp) :
    Q v ⊢{{ emp }} ret v {{ v', RET v'; Q v' }}.
  Proof.
    iIntros "HA" (?) "_ HB". iApply "HB". iFrame.
  Qed.

  Lemma bind_spec {X Y} (e : mon X) (f : X -> mon Y) Φ' Φ'' H :
    (⊢{{ H }} e {{ v, RET v; Φ'' v }}) ->
    (∀ v, ⊢ {{ Φ'' v }} (f v) {{ v', RET v'; Φ' v' }}) ->
    ⊢{{ H }} (bind e f) {{ v, RET v; Φ' v}}.
  Proof.
    intros. iIntros (?) "HA HB".
    iApply (wp_bind e f _ Φ'' with "[HA]").
    - iApply (H0 with "[HA]"); auto.
    - iIntros (v) "HC". iApply (H1 with "[HC]"); auto.
  Qed.

  Lemma frame_r {X} H R Φ' (e : mon X) :
    (⊢{{ H }} e {{ v, RET v; Φ' v }}) ->
    ⊢{{ H ∗ R }} e {{ v, RET v; Φ' v ∗ R }}.
  Proof.
    intro P. iIntros (?) "[HA HC] HB".
    iApply (P with "[HA]"); auto.
    iIntros (v) "HA". iApply "HB". iFrame.
  Qed.

  Lemma frame_l {X} H R Φ' (e : mon X) :
    (⊢{{ H }} e {{ v, RET v; Φ' v }}) ->
    ⊢{{ R ∗ H }} e {{ v, RET v; R ∗ Φ' v }}.
  Proof.
    intro P. iIntros (?) "HA HB". iDestruct "HA" as "[HA HC]".
    iApply (P with "[HC]"); auto.
    iIntros (v) "HC". iApply "HB". iFrame.
  Qed.

  Lemma exists_spec {X Y} v' H (Q : X -> Y -> iProp) (e : mon X) :
    (⊢{{ H }} e {{ v, RET v; Q v v' }}) ->
    ⊢{{ H }} e {{ v, RET v; ∃ t, Q v t }}.
  Proof.
    iIntros (? ?) "HA HB".
    iApply (H0 with "HA").
    iIntros (?) "HA". iApply "HB". iExists v'. iApply "HA".
  Qed.

  Lemma post_weaker {X} H (Q : X -> iProp) (Q' : X -> iProp) (e : mon X) :
    (⊢{{ H }} e {{ v, RET v; Q' v }}) ->
    (forall v, Q' v ⊢ Q v) ->
    ⊢{{ H }} e {{ v, RET v; Q v }}.
  Proof.
    intros. iIntros (?) "HA HB". iApply (H0 with "HA"). iIntros (?) "HA". iApply "HB".
    iApply H1. iApply "HA".
  Qed.

  Lemma pre_stronger {X} H H' (Q : X -> iProp) (e : mon X) :
    (⊢{{ H }} e {{ v, RET v; Q v }}) ->
    (H' ⊢ H) ->
    ⊢{{ H' }} e {{ v, RET v; Q v }}.
  Proof.
    intros. iIntros (?) "HA HB". iApply (H0 with "[HA]").
    - iApply H1. iApply "HA".
    - iApply "HB".
  Qed.

  Lemma intro_true_l {X} H Φ' (e : mon X) :
    (⊢{{ H ∗ emp }} e {{ v, RET v; Φ' v }}) ->
    ⊢{{ H }} e {{ v, RET v; Φ' v }}.
  Proof.
    intro P. iIntros (?) "HA HB". iApply (P with "[HA]").
    iFrame.
    iIntros (v) "HA". iApply "HB". iFrame.
  Qed.

  Lemma intro_true_r {X} H Φ' (e : mon X) :
    (⊢{{ emp ∗ H }} e {{ v, RET v; Φ' v }}) ->
    ⊢{{ H }} e {{ v, RET v; Φ' v }}.
  Proof.
    intro P. iIntros (?) "HA HB". iApply (P with "[HA]").
    iFrame.
    iIntros (v) "HA". iApply "HB". iFrame.
  Qed.

  Lemma wand_post {X} H R Φ' (v : X):
    (⊢{{ H ∗ R }} ret v {{ v, RET v; Φ' v }}) ->
    ⊢{{ H }} ret v {{ v, RET v; R -∗ Φ' v }}.
  Proof.
    iIntros (? ?) "HH HB". iApply "HB". iIntros "HR". iApply (H0 with "[HH HR]"). iFrame.
    iIntros. iFrame.
  Qed.

  Lemma assoc_pre {X} H R Q Φ' (e : mon X):
    (⊢{{ H ∗ R ∗ Q }} e {{ v, RET v; Φ' v }}) <->
    ⊢{{ (H ∗ R) ∗ Q}} e {{ v, RET v; Φ' v }}.
  Proof.
    split; iIntros (? ?) "[HA HC] HB"; iApply (H0 with "[HA HC]"); iFrame. iApply "HC".
  Qed.

  Lemma assoc_post {X} H R Q P (e : mon X) :
    (⊢{{ P }} e {{ v, RET v; H v ∗ R v ∗ Q v }}) <->
    ⊢{{ P }} e {{ v, RET v; (H v ∗ R v) ∗ Q v}}.
  Proof.
    split; iIntros (? ?) "HA HB"; iApply (H0 with "HA"); iIntros (?) "[HA HC]"; iApply "HB"; iFrame.
    iApply "HC".
  Qed.

  Lemma comm_pre {X} H R Φ' (e : mon X):
    (⊢{{ H ∗ R }} e {{ v, RET v; Φ' v }}) <->
    ⊢{{ R ∗ H }} e {{ v, RET v; Φ' v }}.
  Proof.
    split; iIntros (? ?) "[HA HC] HB"; iApply (H0 with "[HA HC]"); iFrame.
  Qed.

  Lemma comm_post {X} P H R (e : mon X):
    (⊢{{ P }} e {{ v, RET v; H v ∗ R v }}) <->
    ⊢{{ P }} e {{ v, RET v; R v ∗ H v }}.
  Proof.
    split; iIntros (? ?) "HA HB"; iApply (H0 with "HA"); iIntros (?) "[HA HC]"; iApply "HB"; iFrame.
  Qed.

  Lemma forall_useless_post {X Y} P Q (e : mon X):
    (⊢{{ P }} e {{ v, RET v; Q v }}) ->
    ⊢{{ P }} e {{ v, RET v; ∀ (t : Y), Q v }}.
  Proof.
    iIntros (? ?) "HA HB". iApply (H with "HA"). iIntros (?) "HA". iApply "HB"; iFrame.
    iIntros. trivial.
  Qed.

  Lemma wand_true_pre {X} P (Q : X -> iProp) e :
    (⊢{{ P }} e {{ v, RET v; Q v }}) ->
    ⊢{{ \⌜True⌝ -∗ P }} e {{ v, RET v; Q v }}.
  Proof.
    iIntros (? ?) "HA HB". iApply (H with "[HA]"). iApply "HA". trivial. iApply "HB".
  Qed.

  Lemma wand_true_post {X} P (Q : X -> iProp) e :
    (⊢{{ P }} e {{ v, RET v; Q v }}) ->
    ⊢{{ P }} e {{ v, RET v; \⌜True⌝ -∗ Q v }}.
  Proof.
    iIntros (? ?) "HA HB". iApply (H with "HA"). iIntros (v) "HA". iApply "HB". eauto.
  Qed.

  Lemma wand_true_pre_l {X} P H (Q : X -> iProp) e :
    (⊢{{ P ∗ H }} e {{ v, RET v; Q v }}) ->
    ⊢{{ (\⌜True⌝ -∗ P) ∗ H }} e {{ v, RET v; Q v }}.
  Proof.
    iIntros (? ?) "[HA HC] HB". iApply (H0 with "[HA HC]"); eauto. iFrame. iApply "HA". trivial.
  Qed.

  Lemma wand_true_pre_r {X} P H (Q : X -> iProp) e :
    (⊢{{ P ∗ H }} e {{ v, RET v; Q v }}) ->
    ⊢{{ P ∗ (\⌜True⌝ -∗ H) }} e {{ v, RET v; Q v }}.
  Proof.
    iIntros (? ?) "[HA HC] HB". iApply (H0 with "[HA HC]"); eauto. iFrame. iApply "HC". trivial.
  Qed.

  Lemma wand_true_post_l {X} P H (Q : X -> iProp) e :
    (⊢{{ P }} e {{ v, RET v; Q v ∗ H v }}) ->
    ⊢{{ P }} e {{ v, RET v; (\⌜True⌝ -∗ Q v) ∗ H v }}.
  Proof.
    iIntros (? ?) "HA HB". iApply (H0 with "HA"). iIntros (v) "[HA HC]". iApply "HB". iFrame. eauto.
  Qed.

  Lemma wand_true_post_r {X} P H (Q : X -> iProp) e :
    (⊢{{ P }} e {{ v, RET v; Q v ∗ H v }}) ->
    ⊢{{ P }} e {{ v, RET v; Q v ∗ (\⌜True⌝ -∗ H v) }}.
  Proof.
    iIntros (? ?) "HA HB". iApply (H0 with "HA"). iIntros (v) "[HA HC]". iApply "HB". iFrame. eauto.
  Qed.

  Lemma forall_wand_true_pre {X Y} P (Q : X -> iProp) e :
    (⊢{{ ∀ (y : Y), P y }} e {{ v, RET v; Q v }}) ->
    ⊢{{ ∀ (y : Y), \⌜True⌝ -∗ P y }} e {{ v, RET v; Q v }}.
  Proof.
    iIntros (? ?) "HA HB". iApply (H with "[HA]"); eauto. iIntros. iApply "HA". trivial.
  Qed.

  Ltac frameL := apply intro_true_l; apply frame_l.
  Ltac frameR := apply intro_true_r; apply frame_r.

  (** Monad rules *)
  Lemma gensym_spec t :
    ⊢{{ emp }} gensym t {{ l, RET l; \s l }}.
  Proof.
    iIntros (Φ) "HA HB". simpl.
    iIntros (σ) "HC". iApply "HB". iApply "HC".
  Qed.

  Lemma error_spec {X} (Q : X -> iProp) e :
    ⊢{{ emp }} error e {{ v, RET v; Q v }}.
  Proof.
    simpl. auto.
  Qed.

End weakestpre_gensym.

Module adequacy.
  Import fresh.
  Export gensym.
  Export weakestpre_gensym.

  Lemma adequacy {X} : forall (e : mon X) (Φ : X -> iProp) (s s' : state) v ,
      (heap_ctx (state_heap s) ⊢ WP e |{ Φ }|) ->
      run e s = Errors.OK (s', v) ->
      (Φ v) () (state_heap s').
  Proof.
    fix e 1. destruct e0; simpl; intros.
    - inversion H0; subst. apply soundness2. iApply H.
    - destruct s.
      + inversion H0.
      + eapply e.
        2 : apply H0.
        iIntros "HA". simpl.
        epose (fresh_is_fresh s0).
        apply (map_disjoint_singleton_r _ _ t) in e0.
        iDestruct (heap_ctx_split_sing _ _ _ e0 with "HA") as "[HA HB]".
        iApply (H with "HA [HB]"); auto.
  Qed.

  Lemma adequacy_triple {X} : forall (e : mon X) (Φ : X -> iProp) s v s' H,
      (heap_ctx (state_heap s) ⊢ H) -> (⊢ {{ H }} e {{ v, RET v; Φ v }}) ->
      run e s = Errors.OK (s', v) ->
      (Φ v) () (state_heap s').
  Proof.
    intros. eapply adequacy; eauto. iIntros "HA". iDestruct (H0 with "HA") as "HA".
    iApply (H1 with "HA"). auto.
  Qed.

  Lemma adequacy_wp_pure {X} : forall (e : mon X) (Φ : X -> Prop) s v s',
      (heap_ctx (state_heap s) ⊢ WP e |{ v, ⌜Φ v⌝ }|) ->
      run e s = Errors.OK (s', v) ->
      Φ v.
  Proof.
    fix e 1. destruct e0; intros.
    - apply (soundness1 (state_heap s)). inversion H0. subst.
      simpl in H. apply H.
    - destruct s.
      + inversion H0.
      + simpl in *. eapply e.
        2 : apply H0.
        simpl. iIntros "HA".
        epose (fresh_is_fresh s0).
        apply (map_disjoint_singleton_r _ _ t) in e0.
        iDestruct (heap_ctx_split_sing _ _ _ e0 with "HA") as "[HA HB]".
        iApply (H with "HA [HB]"); auto.
  Qed.

  Lemma adequacy_pure {X} : forall (e : mon X) (Φ : X -> Prop) s v s' H,
      (heap_ctx (state_heap s) ⊢ H) -> (⊢ {{ H }} e {{ v, RET v; ⌜ Φ v ⌝}}) ->
      run e s = Errors.OK (s', v) ->
      Φ v.
  Proof.
    intros. eapply adequacy_wp_pure; eauto. iIntros "HA". iDestruct (H0 with "HA") as "HA".
    iDestruct (H1 $! (fun v => ⌜ Φ v ⌝) with "HA") as "HA". iApply "HA"; auto.
  Qed.

End adequacy.