From iris.proofmode Require Export coq_tactics ltac_tactics.
Require Import FunctionalExtensionality.
From iris Require Export bi proofmode.tactics proofmode.monpred.
From stdpp Require Export pmap.
Require Import Csyntax.
Axiom prop_extensionality : forall A B:Prop, (A <-> B) -> A = B.

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.

  Definition heap : Type := Pmap type.

  Definition hprop := heap -> Prop.

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

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

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

  Open Scope heap_scope.

  (* Operators *)

  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 = heap_empty.

  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.

  Notation "'Hexists' x1 , H" := (hexists (fun x1 => H))
                                   (at level 39, x1 ident, H at level 50) : heap_scope.
  Notation "'Hexists' x1 x2 , H" := (Hexists x1, Hexists x2, H)
                                      (at level 39, x1 ident, x2 ident, H at level 50) : heap_scope.
  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) : heap_scope.

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

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

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

  Notation "\Top" := (htop) : heap_scope.
  Open Scope heap_scope.

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

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

  Definition hpure_abs (φ : Prop) : hprop := \[φ] \* \Top.

  Lemma hempty_intro :
    \[] heap_empty.
  Proof using. reflexivity. Qed.

  Lemma hempty_inv : forall h,
      \[] h ->
      h = heap_empty.
  Proof using. auto. Qed.

  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.

  Ltac inversion_star H 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))
    (* | 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 h P. inversion P0; subst. rewrite heap_union_empty_l. assumption.
      - exists heap_empty; exists x. repeat split; auto. 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 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. }
                                               { 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. }
                                               { 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 h P. exists h0; exists h1. split; eauto. Qed.

  End Properties.

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

End SepBasicCore.

Export SepBasicCore.

Module ProofModeInstantiate.

  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 h P; exists h; exists h0; repeat split; auto; inversion P0; inversion H2;
        auto; 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.
      apply map_disjoint_empty_l.
    - unfold hpure_abs in *. intros x W P h P0. inversion_star W 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.
      + intro a. pose (P a). inversion_star h0 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 HHH h P. exists h; exists h0. repeat split; auto.
    - intros x W A. exists heap_empty; exists W. repeat split; auto. apply map_disjoint_empty_l.
    - intros P h Q. inversion_star H H H. inversion H3; inversion H6; subst.
      rewrite heap_union_empty_l. apply H4.
    - intros P Q h R. inversion_star H 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. apply map_disjoint_empty_r.
    - intros P Q R W h P0. inversion_star h h P. apply W in P2. destruct P2. inversion_star H 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 P0 h P. apply P2.
    - intros P Q x W. destruct W. exists heap_empty; exists x. repeat split; auto. 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.
      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.

  Open Scope bi_scope.

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

  Opaque hpure_abs.

End ProofModeInstantiate.

Module ProofMode.

  Export ProofModeInstantiate.

  (* We need to repeat all these hints appearing in proofmode/tactics.v,
   so that they state something about CFML connectives. [Hint Extern]
   patterns are not matched modulo canonical structure unification. *)

  Hint Extern 0 (_ ==> _) => iStartProof.
  Hint Extern 0 (envs_entails _ (hpure _)) => iPureIntro.
  Hint Extern 0 (envs_entails _ (hempty)) => iEmpIntro.
  Hint Extern 0 (envs_entails _ (hforall _)) => iIntros (?).
  Hint Extern 0 (envs_entails _ (hwand _ _)) => iIntros "?".

  Hint Extern 1 (envs_entails _ (hand _ _)) => iSplit.
  Hint Extern 1 (envs_entails _ (hstar _ _)) => iSplit.
  Hint Extern 1 (envs_entails _ (hexists _)) => iExists _.
  Hint Extern 1 (envs_entails _ (hor _ _)) => iLeft.
  Hint Extern 1 (envs_entails _ (hor _ _)) => iRight.

  Hint Extern 2 (envs_entails _ (hstar _ _)) => progress iFrame : iFrame.

  (* Specific instances for CFML. *)

  Hint Extern 3 (envs_entails _ ?P) => is_evar P; iAccu.
  Hint Extern 3 (envs_entails _ (?P _)) => is_evar P; iAccu.

  Hint Extern 0 (envs_entails _ (\[_] \* _)) => iSplitR.
  Hint Extern 0 (envs_entails _ (\[_] ∗ _)) => iSplitR.
  Hint Extern 0 (envs_entails _ (_ \* \[_])) => iSplitL.
  Hint Extern 0 (envs_entails _ (_ ∗ \[_])) => iSplitL.

  Hint Extern 0 (envs_entails _ (emp \* _)) => iSplitR.
  Hint Extern 0 (envs_entails _ (emp ∗ _)) => iSplitR.
  Hint Extern 0 (envs_entails _ (_ \* emp)) => iSplitL.
  Hint Extern 0 (envs_entails _ (_ ∗ emp)) => iSplitL.

  (** * 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. auto. 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. by iDestruct 1 as "%". 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. auto. Qed.
  Global Instance from_sep_hpure φ ψ : FromSep \[φ ∧ ψ] \[φ] \[ψ].
  Proof. rewrite /FromSep. 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 bi_emp_valid *) *)

  (* Global Instance as_emp_valid_emp_valid0 P : @AsEmpValid0 hpropI (emp ⊢ P) P | 0. *)
  (* Proof. by rewrite /AsEmpValid0 /AsEmpValid. Qed. *)

  (* Global Instance as_emp_valid_emp_valid0_bis (P : hprop) : *)
  (*   @AsEmpValid0 hpropI (bi_emp_valid P) P | 0. *)
  (* Proof. by rewrite /AsEmpValid0 /AsEmpValid. Qed. *)

  (* Global Instance as_emp_valid_entails0 P Q : @AsEmpValid0 hpropI (P ⊢ Q) (P -∗ Q). *)
  (* Proof. split. apply bi.entails_wand. apply bi.wand_entails. Qed. *)

  (* Global Instance as_emp_valid_entails P Q : @AsEmpValid hpropI (P ⊢ Q) (P -∗ Q). *)
  (* Proof. split. apply bi.entails_wand. apply bi.wand_entails. Qed. *)

  (* Global Instance as_emp_valid_forall {A : Type} (φ : A → Prop) (P : A → hprop) : *)
  (*   (∀ x, AsEmpValid (φ x) (P x)) → AsEmpValid (∀ x, φ x) (∀ x, P x). *)
  (* Proof. *)
  (*   rewrite /AsEmpValid=>H1. split=>H2. *)
  (*   - apply bi.forall_intro=>?. apply H1, H2. *)
  (*   - intros x. apply H1. revert H2. by rewrite (bi.forall_elim x). *)
  (* Qed. *)

  (* Global Instance as_emp_valid_emp_valid (P : hprop) : *)
  (*   @AsEmpValid hpropI (emp ⊢ P) P | 0. *)
  (* Proof. *)
  (*   rewrite /AsEmpValid. split. *)
  (*   - intro. eapply H. *)
  (*   - intro. intro. intro. inversion H0. apply H. apply H0.  *)
  (* Qed. *)

  (* Global Instance as_emp_valid_emp_valid_bis (P : hprop) : *)
  (*   @AsEmpValid hpropI (bi_emp_valid P) P | 0. *)
  (* Proof. *)
  (*     by rewrite /AsEmpValid. *)
  (* 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.

End ProofMode.

Module biInd.
  Import ProofMode.
  Import monpred.

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

  Instance PreOrder_unit : PreOrder (fun (_ _ : unit) => true).
  Proof.
    split; repeat red; intros; trivial.
  Qed.

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

End biInd.

Module gensym.

  Definition ident := positive.

  Definition state := heap.

  Definition max := Pos.max.
  Definition upper := fun r i => max (i+1) r.
  Definition fresh (s:list ident) : ident := foldl upper 1%positive s.

  Lemma max_comm : forall n m, max n m = max m n.
  Proof.
    intros. unfold max. rewrite Pos.max_comm. reflexivity.
  Qed.

  Lemma foldl_upper : forall l a0 a1, foldl upper (max a0 a1) l = max a1 (foldl upper a0 l).
  Proof.
    induction l; simpl; intros.
    - by rewrite max_comm.
    - repeat rewrite IHl. unfold max. rewrite Pos.max_assoc. rewrite (Pos.max_comm a0). reflexivity.
  Qed.

  Lemma upper_spec: forall l a, Pos.le a (foldl upper a l).
  Proof.
    unfold upper.
    induction l; simpl.
    - reflexivity.
    - intro. rewrite foldl_upper. apply Pos.le_max_l.
  Qed.

  Lemma test3 : forall l a, fresh (a :: l) = max (a + 1) (fresh l).
  Proof.
    induction l; intros.
    - reflexivity.
    - unfold fresh. unfold upper. simpl. unfold max.
      unfold fresh in IHl. unfold upper in IHl. simpl in IHl. unfold max in IHl.
      rewrite IHl. rewrite Pos.max_1_r. rewrite foldl_upper.
      unfold upper. unfold max.
      f_equal. rewrite <- (Pos.max_1_r (a+1)%positive). rewrite IHl.
      rewrite Pos.max_1_r. reflexivity.
  Qed.

  Lemma test4 : forall l v, v ∈ l -> Pos.lt v (fresh l).
  Proof.
    intros. unfold fresh.
    apply elem_of_list_split in H as (l1&l2&H0).
    rewrite H0. rewrite foldl_app. pose test3. unfold fresh in e. simpl in *. unfold upper.
    rewrite foldl_upper.
    destruct (Pos.max_spec (foldl (λ r i : positive, max (i + 1) r) 1%positive l1)
                           (foldl upper (v + 1)%positive l2)); destruct H.
    - unfold max. rewrite H1. pose (upper_spec l2 (v+1)).
      eapply Pos.lt_le_trans; eauto.
      setoid_rewrite Pos2Nat.inj_lt. rewrite <- Pplus_one_succ_r.
      rewrite Pos2Nat.inj_succ. omega.
    - unfold max. rewrite H1. pose (upper_spec l2 (v+1)). eapply Pos.lt_le_trans; eauto.
      eapply Pos.lt_le_trans; eauto.
      setoid_rewrite Pos2Nat.inj_lt. rewrite <- Pplus_one_succ_r.
      rewrite Pos2Nat.inj_succ. omega.
  Qed.

  Lemma fresh_is_fresh : forall l, (fresh l) ∉ l.
  Proof.
    induction l.
    - intro. inversion H.
    - intro. inversion H ; subst.
      + unfold fresh in H2. unfold upper in H2. unfold max in H2.
        simpl in H2. rewrite Pos.max_1_r in H2.
        pose (upper_spec l (a+1)%positive). unfold upper in l0. unfold max in l0.
        rewrite <- H2 in l0 at 1.
        rewrite Pos.add_1_r in l0. apply Pos.le_succ_l in l0.
        apply Pos.lt_irrefl in l0. apply l0.
      + rewrite  test3 in H2. destruct (Pos.max_spec (a+1) (fresh l)); destruct H0.
        * unfold max in H2. rewrite H1 in H2.
          contradiction IHl.
        * unfold max in H2. rewrite H1 in H2. apply test4 in H.
          setoid_rewrite Pos2Nat.inj_lt in H. setoid_rewrite Pos2Nat.inj_le in H0.
          omega.
  Qed.

  Definition fresh_ident (s:state) :=
    fresh (map_to_list s).*1.

  Lemma fresh_ident_spec : forall (s : state), s !! (fresh_ident s) = None.
  Proof.
    intros. unfold fresh_ident. pose (fresh_is_fresh (map_to_list s).*1).
    apply not_elem_of_list_to_map in n.
    rewrite (list_to_map_to_list s) in n.
    apply n.
  Qed.

  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 -> err (state * X) :=
    match m with
    | ret v => fun s => Res (s, v)
    | op (Err e) => fun s => Erro e
    | op (Gensym t f) =>
      fun s =>
        let l := fresh_ident s in
        run (f l) (<[l:=t]>s)
    end.

End gensym.

Module weakestpre_gensym.
  Export gensym.
  Export ProofMode.
  Export proofmode.monpred.
  Import biInd.

  Definition iProp := monPred biInd hpropI.

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

  Definition heap_ctx (h : heap) : iProp := MonPred (fun _ => hheap_ctx h) _.

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

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

  Definition pure_empty (P : Prop) : iProp := <affine> ⌜P⌝.

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

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

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

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

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

  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, l ↦ t }|.
  Proof.
    simpl. iIntros. iFrame.
  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; l ↦ t }}.
  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.

  Ltac tac :=
    match goal with
    | |- bi_emp_valid ({{ _ }} bind _ (fun _ => _) {{ _, RET _; _ }}) =>
      eapply bind_spec; [> tac | intro; tac]
    | |- bi_emp_valid ({{ _ }} ret _ {{ _, RET _; ∃ _, _ }}) => eapply exists_spec; tac
    | |- bi_emp_valid ({{ emp }} error _ {{ _, RET _; _ }}) => apply error_spec
    | |- bi_emp_valid ({{ emp }} gensym _ {{ _, RET _; _ }}) => apply gensym_spec
    | |- bi_emp_valid ({{ ?H }} gensym _ {{ _, RET _; _ }}) => frameR; apply gensym_spec
    | |- bi_emp_valid ({{ _ }} ret _ {{ _, RET _; _ -∗ _ }}) => apply wand_post; tac
    | |- bi_emp_valid ({{ emp }} _ {{ v', RET v'; ∀ _, _ }}) => apply forall_useless_post; tac
    | |- bi_emp_valid ({{ _ }} _ {{ v', RET v'; \⌜True⌝ -∗ _ }}) => apply wand_true_post; tac
    | |- bi_emp_valid ({{ _ }} _ {{ v', RET v'; (\⌜True⌝ -∗ _) ∗ _ }}) => apply wand_true_post_l; tac
    | |- bi_emp_valid ({{ _ }} _ {{ v', RET v'; _ ∗ (\⌜True⌝ -∗ _) }}) => apply wand_true_post_r; tac
    | |- bi_emp_valid ({{ \⌜True⌝ -∗ _ }} _ {{ v', RET v'; _ }}) => apply wand_true_pre; tac
    | |- bi_emp_valid ({{ (\⌜True⌝ -∗ _) ∗ _ }} _ {{ v', RET v'; _ }}) => apply wand_true_pre_l; tac
    | |- bi_emp_valid ({{ _ ∗ (\⌜True⌝ -∗ _) }} _ {{ v', RET v'; _ }}) => apply wand_true_pre_r; tac
    | |- bi_emp_valid ({{ ∀ _, \⌜True⌝ -∗ _ }} _ {{ v', RET v'; _ }}) => apply forall_wand_true_pre; tac
    | H :  bi_emp_valid ({{ ?Pre }} ?e {{ _, RET _; _ }})
      |-  bi_emp_valid ({{ ?Pre }} ?e {{ _, RET _; _ }}) => apply H
    | H :  (forall x, bi_emp_valid ({{ ?Pre }} ?e x {{ _, RET _; _ }}))
      |-  bi_emp_valid ({{ ?Pre }} ?e _ {{ _, RET _; _ }}) => apply H
    | H :  (forall x, bi_emp_valid ({{ ?Pre }} ?e x ?l {{ _, RET _; _ }}))
      |-  bi_emp_valid ({{ ?Pre }} ?e _ ?l {{ _, RET _; _ }}) => apply H
    | H :  (forall x y, bi_emp_valid ({{ ?Pre }} ?e x y {{ _, RET _; _ }}))
      |-  bi_emp_valid ({{ ?Pre }} ?e _ _ {{ _, RET _; _ }}) => apply H
    | H :  (forall x y, bi_emp_valid ({{ ?Pre }} ?e x ?r {{ _, RET _; _ }}))
      |-  bi_emp_valid ({{ ?Pre }} ?e _ ?r {{ _, RET _; _ }}) => apply H
    | H :  (forall x y z, bi_emp_valid ({{ ?Pre }} ?e x y z {{ _, RET _; _ }}))
      |-  bi_emp_valid ({{ ?Pre }} ?e _ _ _ {{ _, RET _; _ }}) => apply H
    | H :  bi_emp_valid ({{ emp }} ?e {{ _, RET _; _ }}) |-
      bi_emp_valid ({{ ?Pre }} ?e {{ _, RET _; _ }}) => frameR; apply H
    | |- bi_emp_valid ({{ emp }} ret ?v {{ v', RET v'; ⌜ v' = ?v ⌝ }}) => apply ret_spec
    | |- bi_emp_valid ({{ emp }} ret ?v {{ v', RET v'; \⌜ v' = ?v ⌝ }}) => apply ret_spec_pure
    | _ => idtac
    end.

End weakestpre_gensym.

Module adequacy.
  Export gensym.
  Export weakestpre_gensym.
  Lemma soundness1 (Φ : Prop) h : (heap_ctx h ⊢ (⌜ Φ ⌝) : iProp) -> Φ.
  Proof.
    MonPred.unseal=> -[H]. repeat red in H.
    pose (H () h).
    edestruct e as (h1&h2&P0&P1&P2&P3).
    - reflexivity.
    - inversion P0. apply H0.
  Qed.
  Lemma soundness_pure (Φ : Prop) : bi_emp_valid ((⌜ Φ ⌝) : iProp) -> Φ.
  Proof.
    MonPred.unseal=> -[H]. repeat red in H.
    pose (H () heap_empty).
    edestruct e as (h1&h2&P0&P1&P2&P3).
    - rewrite monPred_at_emp. split; auto; apply hempty_intro.
    - inversion P0. apply H0.
  Qed.

  Lemma soundness2 (Φ : iProp) h : (⊢heap_ctx h -∗ Φ) -> Φ () h.
  Proof.
    MonPred.unseal=> -[H]. repeat red in H.
    pose (H () heap_empty).
    simpl in *. edestruct e.
    - rewrite monPred_at_emp. split; auto; apply hempty_intro.
    - repeat red. exists heap_empty; exists heap_empty. repeat split; auto.
    - inversion_star H0 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.
  Qed.

  Lemma soundness3 (Φ : iProp) 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. rewrite monPred_at_emp in H0. apply H0.
    intros h0 P0. inversion_star H 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 soundness4 (Φ : Prop) 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. rewrite monPred_at_emp in H0. apply H0.
    apply map_disjoint_empty_r.
  Qed.

  Lemma heap_ctx_split_sing h l t : h ##ₘ ({[l := t]}) -> (⊢heap_ctx (<[l := t]>h) -∗ heap_ctx h ∗ l ↦ t).
  Proof.
    intro.
    MonPred.unseal. repeat red.
    unfold monPred_wand_def.
    unfold monPred_sep_def.
    unfold monPred_upclosed. split. simpl.
    intro. intro P. intro. intros. 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 H1 h P. inversion P1. subst.
      exists h; exists ({[l := t]} : heap). repeat split; auto. inversion P2; subst.
      rewrite heap_union_empty_l. rewrite insert_union_singleton_r. reflexivity.
      apply (map_disjoint_singleton_r) in H. apply H.
    + inversion H3. rewrite heap_union_empty_l. reflexivity.
  Qed.

    Lemma heap_ctx_split h h' : 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 H1 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 adequacy {X} : forall (e : mon X) (Φ : X -> iProp) h v h',
      (heap_ctx h ⊢ WP e |{ Φ }|) ->
      run e h = Res (h', v) ->
      (Φ v) () h'.
  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".
        pose (fresh_ident_spec h).
        apply (map_disjoint_singleton_r h (fresh_ident h) t) in e0.
        iDestruct ((heap_ctx_split_sing _ _ _ e0) with "HA") as "[HA HB]".
        iApply (H with "HA HB").
  Qed.

  Lemma adequacy_triple {X} : forall (e : mon X) (Φ : X -> iProp) h v h' H,
      (heap_ctx h ⊢ {{ H }} e {{ v, RET v; Φ v }} ∗ H) ->
      run e h = Res (h', v) ->
      (Φ v) () h'.
  Proof.
    fix e 1. destruct e0; simpl; intros.
    - apply soundness2. inversion H1; subst.
      iIntros "HA". iDestruct (H0 with "HA") as "[HA HB]".
      iApply ("HA" with "HB"). auto.
    - destruct s.
      + inversion H1.
      + eapply (e _ _ _ _ _ _).
        2: eapply H1.
        iIntros "HA". pose (fresh_ident_spec h).
        apply (map_disjoint_singleton_r h (fresh_ident h) t) in e0.
        iDestruct ((heap_ctx_split_sing _ _ _ e0) with "HA") as "[HA HB]".
        iDestruct (H0 with "HA") as "[HA HC]".
        iSplitR "HC".
        iIntros (?) "HC HD". iApply ("HA" with "HC [HD]"); eauto. iApply "HC".
  Qed.

  Lemma adequacy_pure {X} : forall (e : mon X) (Φ : X -> Prop) h v h' H,
      (heap_ctx h ⊢ {{ H }} e {{ v, RET v; ⌜ Φ v ⌝}} ∗ H) ->
      run e h = Res (h', v) ->
      Φ v.
  Proof.
    fix e 1. destruct e0; simpl; intros.
    - apply (soundness1 _ h).
      inversion H1; subst.
      iIntros "HA".
      iDestruct (H0 with "HA") as "[HA HB]".
      iDestruct ("HA" $! (fun v => ⌜ Φ v ⌝) with "HB") as "HA".
      iApply "HA". eauto.
    - destruct s.
      + inversion H1.
      + eapply e.
        2 : apply H1.
        iIntros "HA". pose (fresh_ident_spec h).
        apply (map_disjoint_singleton_r h (fresh_ident h) t) in e0.
        iDestruct ((heap_ctx_split_sing _ _ _ e0) with "HA") as "[HA HB]".
        iDestruct (H0 with "HA") as "[HA HC]".
        iSplitR "HC".
        iIntros (?) "HC HD". iApply ("HA" with "HC [HD]"); eauto. iApply "HC".
  Qed.

End adequacy.


Local Lemma abstract_away_helper {A} (P: A -> Prop) (x y:A) :
  P y -> y = x -> P x.
Proof.
  intros; subst; auto.
Qed.

Ltac abstract_term t :=
  match goal with
  | |- ?g => let p := eval pattern t in g in
               match p with
               | ?P ?x => eapply (abstract_away_helper P)
               end
  end.


Require Import List.
Require Import Coq.Lists.ListSet.
Import ListNotations.
Require Import Unify.
Require Import MiniKanrenSyntax.
Require Import Omega.

Lemma set_empty_union
      (s1 s2 : var_set)
      (EQ : var_set_union s1 s2 = var_set_empty) :
      s1 = var_set_empty /\ s2 = var_set_empty.
Proof.
  split.
  { destruct s1; auto.
    assert (In n var_set_empty).
    { rewrite <- EQ. apply set_union_intro. left. constructor. auto. }
    inversion H. }
  { destruct s2; auto.
    assert (In n var_set_empty).
    { rewrite <- EQ. apply set_union_intro. right. constructor. auto. }
    inversion H. }
Qed.

Definition repr_fun : Set := name -> ground_term.

Definition gt_eq (gt1 : ground_term) (gt2 : ground_term) : Prop :=
  proj1_sig gt1 = proj1_sig gt2.

Definition repr_fun_eq (f1 : repr_fun) (f2 : repr_fun) : Prop :=
  forall x, gt_eq (f1 x) (f2 x).

Fixpoint apply_repr_fun (f : repr_fun) (t : term) : ground_term.
refine (
  match t with
  | Var x => f x
  | Cst n => exist _ (Cst n) eq_refl
  | Con n l r => match apply_repr_fun f l, apply_repr_fun f r with
                 | exist _ lt lg, exist _ rt rg => exist _ (Con n lt rt) _
                 end
  end
).
simpl. rewrite lg. rewrite rg. reflexivity.
Defined.

Lemma repr_fun_eq_apply
      (f1 f2 : repr_fun)
      (t : term)
      (FEQ : repr_fun_eq f1 f2) :
      gt_eq (apply_repr_fun f1 t) (apply_repr_fun f2 t).
Proof.
  induction t.
  { simpl. auto. }
  { reflexivity. }
  { red. simpl.
    destruct (apply_repr_fun f1 t1). destruct (apply_repr_fun f1 t2).
    destruct (apply_repr_fun f2 t1). destruct (apply_repr_fun f2 t2).
    simpl.
    red in IHt1. simpl in IHt1.
    red in IHt2. simpl in IHt2.
    subst. auto. }
Qed.

Lemma apply_repr_fun_fv
      (f1 f2 : repr_fun)
      (t : term)
      (F12_FV_EQ : forall x, (In x (fv_term t)) -> gt_eq (f1 x) (f2 x)) :
      gt_eq (apply_repr_fun f1 t) (apply_repr_fun f2 t).
Proof.
  induction t.
  { simpl. apply F12_FV_EQ. simpl. auto. }
  { unfold gt_eq. auto. }
  { unfold gt_eq. simpl.
    remember (apply_repr_fun f1 t1) as p11. destruct p11.
    remember (apply_repr_fun f1 t2) as p12. destruct p12.
    remember (apply_repr_fun f2 t1) as p21. destruct p21.
    remember (apply_repr_fun f2 t2) as p22. destruct p22.
    simpl.
    assert (x = x1).
    { apply IHt1. intros. apply F12_FV_EQ. unfold fv_term.
      apply (set_union_intro name_eq_dec). left. auto. }
    assert (x0 = x2).
    { apply IHt2. intros. apply F12_FV_EQ. unfold fv_term.
      apply (set_union_intro name_eq_dec). right. auto. }
    subst. auto. }
Qed.

Lemma repr_fun_eq_trans
      (f1 f2 f3 : repr_fun)
      (EQ12 : repr_fun_eq f1 f2)
      (EQ23 : repr_fun_eq f2 f3) :
      repr_fun_eq f1 f3.
Proof.
  revert EQ12 EQ23. unfold repr_fun_eq. unfold gt_eq. intros.
  rewrite EQ12. auto.
Qed.

Lemma subst_of_gt
      (t : term)
      (s : subst)
      (f : repr_fun)
      (FV_IMG : forall x : name, In x (fv_term t) -> image s x = Some (proj1_sig (f x))) :
      apply_subst s t = proj1_sig (apply_repr_fun f t).
Proof.
  induction t.
  { simpl. replace (image s n) with (Some (proj1_sig (f n))).
    { auto. }
    { symmetry. apply FV_IMG. constructor. auto. } }
  { auto. }
  { simpl.
    destruct (apply_repr_fun f t1).
    destruct (apply_repr_fun f t2).
    simpl.
    replace x with (apply_subst s t1).
    { replace x0 with (apply_subst s t2).
      { auto. }
      { apply IHt2. intros. apply FV_IMG.
        apply set_union_intro2. auto. } }
    { apply IHt1. intros. apply FV_IMG.
      apply set_union_intro1. auto. } }
Qed.

Definition subst_repr_fun_compose (s : subst) (f : repr_fun) : repr_fun :=
  fun x => apply_repr_fun f (apply_subst s (Var x)).

Lemma repr_fun_apply_compose
      (s : subst)
      (f : repr_fun)
      (t : term) :
      gt_eq (apply_repr_fun (subst_repr_fun_compose s f) t) (apply_repr_fun f (apply_subst s t)).
Proof.
  induction t.
  { reflexivity. }
  { reflexivity. }
  { red. simpl.
    destruct (apply_repr_fun (subst_repr_fun_compose s f) t1).
    destruct (apply_repr_fun (subst_repr_fun_compose s f) t2).
    destruct (apply_repr_fun f (apply_subst s t1)).
    destruct (apply_repr_fun f (apply_subst s t2)).
    simpl.
    red in IHt1. simpl in IHt1.
    red in IHt2. simpl in IHt2.
    subst. auto. }
Qed.

Lemma repr_fun_eq_compose
      (f1 f2 : repr_fun)
      (EQ : repr_fun_eq f1 f2)
      (s : subst) :
      repr_fun_eq (subst_repr_fun_compose s f1) (subst_repr_fun_compose s f2).
Proof.
  unfold repr_fun_eq. unfold repr_fun_eq in EQ. unfold subst_repr_fun_compose.
  intro. induction (apply_subst s (Var x)).
  { simpl. auto. }
  { reflexivity. }
  { unfold gt_eq. simpl.
    remember (apply_repr_fun f1 t1) as p11. destruct p11.
    remember (apply_repr_fun f1 t2) as p12. destruct p12.
    remember (apply_repr_fun f2 t1) as p21. destruct p21.
    remember (apply_repr_fun f2 t2) as p22. destruct p22.
    simpl.
    unfold gt_eq in IHt1. simpl in IHt1. rewrite IHt1.
    unfold gt_eq in IHt2. simpl in IHt2. rewrite IHt2.
    auto. }
Qed.

Lemma repr_fun_compose_eq
      (f : repr_fun)
      (s1 s2 : subst)
      (EQ : forall t, apply_subst s1 t = apply_subst s2 t) :
      repr_fun_eq (subst_repr_fun_compose s1 f) (subst_repr_fun_compose s2 f).
Proof.
  unfold repr_fun_eq. unfold subst_repr_fun_compose. unfold gt_eq.
  intro. rewrite EQ. auto.
Qed.

Lemma subst_repr_fun_compose_assoc_subst
      (f : repr_fun)
      (s s' : subst) :
      repr_fun_eq (subst_repr_fun_compose (compose s s') f)
                (subst_repr_fun_compose s (subst_repr_fun_compose s' f)).
Proof.
  unfold repr_fun_eq. intros. unfold gt_eq.
  replace (subst_repr_fun_compose (compose s s') f x) with
          (apply_repr_fun (subst_repr_fun_compose (compose s s') f) (Var x)); auto.
  rewrite repr_fun_apply_compose. rewrite compose_correctness.
  replace (subst_repr_fun_compose s (subst_repr_fun_compose s' f) x) with
          (apply_repr_fun (subst_repr_fun_compose s (subst_repr_fun_compose s' f)) (Var x)); auto.
  rewrite repr_fun_apply_compose. rewrite repr_fun_apply_compose. auto.
Qed.

Definition in_denotational_sem_subst (s : subst) (f : repr_fun) : Prop :=
  exists (f' : repr_fun), repr_fun_eq (subst_repr_fun_compose s f') f.

Notation "[ s , f ]" := (in_denotational_sem_subst s f) (at level 0).

Lemma empty_subst_ds
      (f : repr_fun) :
      [ empty_subst , f ].
Proof.
  red. exists f. red. intros.
  unfold subst_repr_fun_compose. rewrite apply_empty. reflexivity.
Qed.

Lemma unfier_from_gt_unifier
      (t1 t2 : term)
      (f : repr_fun)
      (F_UNIFIES : gt_eq (apply_repr_fun f t1) (apply_repr_fun f t2)) :
      exists s, unifier s t1 t2 /\ [ s , f ].
Proof.
  remember (map (fun x => (x, proj1_sig (f x))) (var_set_union (fv_term t1) (fv_term t2))) as s.
  exists s. split.
  { red. red in F_UNIFIES.
    assert (apply_subst s t1 = proj1_sig (apply_repr_fun f t1)).
    { clear F_UNIFIES.
      assert (forall x, In x (fv_term t1) -> image s x = Some (proj1_sig (f x))).
      { intros. assert (In x (var_set_union (fv_term t1) (fv_term t2))).
        { apply set_union_intro1. auto. }
        remember (var_set_union (fv_term t1) (fv_term t2)).
        subst. apply map_image. auto. }
      apply subst_of_gt. auto. }
    assert (apply_subst s t2 = proj1_sig (apply_repr_fun f t2)).
    { clear F_UNIFIES.
      assert (forall x, In x (fv_term t2) -> image s x = Some (proj1_sig (f x))).
      { intros. assert (In x (var_set_union (fv_term t1) (fv_term t2))).
        { apply set_union_intro2. auto. }
        remember (var_set_union (fv_term t1) (fv_term t2)).
        subst. apply map_image. auto. }
      apply subst_of_gt. auto. }
    congruence. }
  { red. exists f. red. intros x. unfold subst_repr_fun_compose.
    unfold apply_subst. destruct (image s x) eqn:eq.
    { destruct (f x) eqn:eqfx.
      assert (x0 = t).
      { unfold image in eq.
        remember (var_set_union (fv_term t1) (fv_term t2)). clear Heqv.
        revert Heqs. revert v.
        induction s.
        { inversion eq. }
        { intros. destruct a as [y t0]. destruct v; good_inversion Heqs.
          destruct (Nat.eq_dec n x).
          { good_inversion eq. rewrite eqfx. auto. }
          { apply IHs with v; auto. } } }
      subst. red. simpl. clear eqfx. clear eq. induction t.
      { inversion e. }
      { auto. }
      { simpl in e. apply set_empty_union in e. destruct e.
        apply IHt1 in H. apply IHt2 in H0. simpl.
        destruct (apply_repr_fun f t3). simpl in H.
        destruct (apply_repr_fun f t4). simpl in H0.
        simpl. subst. auto. } }
    { red. auto. } }
Qed.

Lemma denotational_sem_uni
      (s d : subst)
      (t1 t2 : term)
      (MGU : mgu (apply_subst s t1) (apply_subst s t2) (Some d))
      (f : repr_fun) :
      [ compose s d , f ] <-> [ s , f ] /\ gt_eq (apply_repr_fun f t1) (apply_repr_fun f t2).
Proof.
   split.
   { intros DSS. red in DSS. destruct DSS as [f' ff'_eq]. split.
      { red. exists (subst_repr_fun_compose d f').
        eapply repr_fun_eq_trans; eauto.
        red. symmetry. apply subst_repr_fun_compose_assoc_subst. }
      { red.
        specialize (repr_fun_eq_apply _ _ t1 ff'_eq). intro. rewrite <- H.
        specialize (repr_fun_eq_apply _ _ t2 ff'_eq). intro. rewrite <- H0.
        rewrite repr_fun_apply_compose. rewrite repr_fun_apply_compose.
        rewrite compose_correctness. rewrite compose_correctness.
        apply mgu_unifies in MGU. rewrite MGU. reflexivity. } }
    { intros [DSS F_UNIFIES]. destruct DSS as [fs COMP_s_fs].
      assert (FS_UNIFIES : gt_eq (apply_repr_fun fs (apply_subst s t1))
                                 (apply_repr_fun fs (apply_subst s t2))).
      { red. rewrite <- repr_fun_apply_compose. rewrite <- repr_fun_apply_compose.
        apply eq_trans with (proj1_sig (apply_repr_fun f t1)).
        { apply repr_fun_eq_apply. auto. }
        { apply eq_trans with (proj1_sig (apply_repr_fun f t2)); auto.
          symmetry. apply repr_fun_eq_apply. auto. } }
      apply unfier_from_gt_unifier in FS_UNIFIES.
      destruct FS_UNIFIES as [u [UNI DSSu]].
      specialize (mgu_most_general _ _ _ u MGU UNI). intro MG_d.
      red in MG_d. destruct MG_d as [ds COMP_u_ds]. destruct DSSu as [fu COMP_u_fu].
      red. exists (subst_repr_fun_compose ds fu).
      eapply repr_fun_eq_trans. 2: eauto.
      eapply repr_fun_eq_trans. eapply subst_repr_fun_compose_assoc_subst.
      eapply repr_fun_eq_trans. 2: eapply repr_fun_eq_compose; eauto.
      apply repr_fun_eq_compose.
      eapply repr_fun_eq_trans. red; symmetry; eapply subst_repr_fun_compose_assoc_subst.
      apply repr_fun_compose_eq. intros. rewrite COMP_u_ds. apply compose_correctness. }
Qed.

Reserved Notation "[| g , f |]" (at level 0).

Inductive in_denotational_sem_goal : goal -> repr_fun -> Prop :=
| dsgCut    : forall f,  [| Cut , f |]
| dsgUnify  : forall f t1 t2 (UNI : gt_eq (apply_repr_fun f t1) (apply_repr_fun f t2)),
                             [| Unify t1 t2 , f |]
| dsgDisunify  : forall f t1 t2 (DISUNI : ~ gt_eq (apply_repr_fun f t1) (apply_repr_fun f t2)),
                             [| Disunify t1 t2 , f |]
| dsgDisjL  : forall f g1 g2 (DSG : in_denotational_sem_goal g1 f),
                             [| Disj g1 g2 , f |]
| dsgDisjR  : forall f g1 g2 (DSG : in_denotational_sem_goal g2 f),
                             [| Disj g1 g2 , f |]
| dsgConj   : forall f g1 g2 (DSG_L : [| g1 , f |])
                             (DSG_R : [| g2 , f |]),
                             [| Conj g1 g2 , f |]
| dsgFresh  : forall f fn a fg (A_NOT_FV : ~ is_fv_of_goal a (Fresh fg))
                               (DSG : [| fg a , fn |])
                               (EASE : forall (x : name) (neq : x <> a), gt_eq (fn x) (f x)),
                               [| Fresh fg , f |]
| dsgInvoke : forall r t f (DSG : [| proj1_sig (MiniKanrenSyntax.Prog r) t , f |]),
                              [| Invoke r t, f |]
where "[| g , f |]" := (in_denotational_sem_goal g f).

Hint Constructors in_denotational_sem_goal.

Reserved Notation "[| n | g , f |]" (at level 0).

Inductive in_denotational_sem_lev_goal : nat -> goal -> repr_fun -> Prop :=
| dslgCut    : forall l f, [| (S l) | Cut , f |]
| dslgUnify  : forall l f t1 t2 (UNI : gt_eq (apply_repr_fun f t1) (apply_repr_fun f t2)),
                                [| S l | Unify t1 t2 , f |]
| dslgDisunify  : forall l f t1 t2 (DISUNI : ~ gt_eq (apply_repr_fun f t1) (apply_repr_fun f t2)),
                                [| S l | Disunify t1 t2 , f |]
| dslgDisjL  : forall l f g1 g2 (DSG : [| l | g1 , f |]),
                                [| l | Disj g1 g2 , f |]
| dslgDisjR  : forall l f g1 g2 (DSG : [| l | g2 , f |]),
                                [| l | Disj g1 g2 , f |]
| dslgConj   : forall l f g1 g2 (DSG_L : [| l | g1 , f |])
                                (DSG_R : [| l | g2 , f |]),
                                [| l | Conj g1 g2 , f |]
| dslgFresh  : forall l f fn a fg (A_NOT_FV : ~ is_fv_of_goal a (Fresh fg))
                                  (DSG : [| l | (fg a) , fn |])
                                  (EASE : forall (x : name) (neq : x <> a), gt_eq (fn x) (f x)),
                                  in_denotational_sem_lev_goal l (Fresh fg) f
| dslgInvoke : forall l r t f (DSG : [| l | (proj1_sig (MiniKanrenSyntax.Prog r) t) , f |]),
                              [| S l | Invoke r t , f |]
where "[| n | g , f |]" := (in_denotational_sem_lev_goal n g f).

Hint Constructors in_denotational_sem_lev_goal.

Lemma in_denotational_sem_zero_lev
      (g : goal)
      (f : repr_fun) :
      ~ [| 0 | g , f |].
Proof.
  intro. remember 0 as l. induction H; inversion Heql; auto.
Qed.

Lemma in_denotational_sem_lev_monotone
      (l : nat)
      (g : goal)
      (f : repr_fun)
      (DSG : [| l | g , f |])
      (l' : nat)
      (LE: l <= l') :
      [| l' | g , f |].
Proof.
  revert LE. revert l'. induction DSG; eauto.
  1-3: intros; destruct l'; auto; inversion LE.
  { intros. destruct l'.
    { inversion LE. }
    { apply le_S_n in LE. auto. } }
Qed.

Lemma in_denotational_sem_some_lev
      (g : goal)
      (f : repr_fun)
      (DSG : [| g , f |]) :
      exists l, [| l | g , f |].
Proof.
  induction DSG.
  1-3: exists 1; auto.
  1-2, 4-5: destruct IHDSG; eauto.
  { destruct IHDSG1. destruct IHDSG2.
    exists (max x x0). constructor.
    { eapply in_denotational_sem_lev_monotone; eauto. apply PeanoNat.Nat.le_max_l. }
    { eapply in_denotational_sem_lev_monotone; eauto. apply PeanoNat.Nat.le_max_r. } }
Qed.

Lemma in_denotational_sem_drop_lev
      (g : goal)
      (f : repr_fun)
      (l : nat)
      (DSLG : [| l | g , f |]) :
      [| g , f |].
Proof.
  induction DSLG; eauto.
Qed.

Lemma completeness_condition_lev
      (f f' : repr_fun)
      (g : goal)
      (l : nat)
      (FF'_EQ : forall x, is_fv_of_goal x g -> gt_eq (f x) (f' x))
      (DSG : [| l | g , f |]) :
      [| l | g , f' |].
Proof.
  revert FF'_EQ. revert f'. induction DSG; intros.
  { constructor. }
  { constructor. assert (gt_eq (apply_repr_fun f t1) (apply_repr_fun f' t1)).
    { apply apply_repr_fun_fv. auto. }
    assert (gt_eq (apply_repr_fun f t2) (apply_repr_fun f' t2)).
    { apply apply_repr_fun_fv. auto. }
    revert UNI H H0. unfold gt_eq. intros. congruence. }
  { constructor. intros C. apply DISUNI.
    assert (gt_eq (apply_repr_fun f t1) (apply_repr_fun f' t1)).
    { apply apply_repr_fun_fv. auto. }
    assert (gt_eq (apply_repr_fun f t2) (apply_repr_fun f' t2)).
    { apply apply_repr_fun_fv. auto. }
    revert C H H0. unfold gt_eq. intros. congruence. }
  { constructor. apply IHDSG. intros.
    apply FF'_EQ. auto. }
  { apply dslgDisjR. apply IHDSG. intros.
    apply FF'_EQ. auto. }
  { constructor.
    { apply IHDSG1; intros; apply FF'_EQ; auto. }
    { apply IHDSG2; intros; apply FF'_EQ; auto. } }
  { remember (fun x => if name_eq_dec x a
                         then fn a
                         else f' x) as fn'.
    apply dslgFresh with fn' a; auto.
    { apply IHDSG. intros. rewrite Heqfn'.
      destruct (name_eq_dec x a).
      { unfold gt_eq. subst. auto. }
      { specialize (EASE _ n). red. rewrite EASE.
        apply FF'_EQ. eauto. } }
    { rewrite Heqfn'. intros.
      destruct (name_eq_dec x a); try contradiction.
      reflexivity. } }
  { constructor. apply IHDSG. intros.
    apply FF'_EQ. constructor.
    remember (MiniKanrenSyntax.Prog r). destruct d as [rel [Hcl Hco]].
    simpl in H. red in Hcl. red in Hcl. auto. }
Qed.

Lemma completeness_condition
      (f f' : repr_fun)
      (g : goal)
      (FF'_EQ : forall x, is_fv_of_goal x g -> gt_eq (f x) (f' x))
      (DSG : [| g , f |]) :
      [| g , f' |].
Proof.
  apply in_denotational_sem_some_lev in DSG.
  destruct DSG as [l DSLG].
  eapply in_denotational_sem_drop_lev.
  eapply completeness_condition_lev; eauto.
Qed.

Lemma den_sem_rename_var
      (g1 g2 : goal)
      (CG : consistent_goal g1)
      (n : nat)
      (G1_BOUND : forall x : name, is_fv_of_goal x g1 -> x < n)
      (G2_BOUND : forall x : name, is_fv_of_goal x g2 -> x < n)
      (a1 a2 : name)
      (A12_NEQ : a1 <> a2)
      (A2_FRESH : ~ is_fv_of_goal a2 g1)
      (REN : renaming a1 a2 g1 g2)
      (fa1 fa2 : repr_fun)
      (l : nat)
      (DSG1 : [| l | g1 , fa1 |])
      (F_SWITCH : gt_eq (fa1 a1) (fa2 a2))
      (F12_EQ : forall x, x <> a1 -> x <> a2 -> gt_eq (fa1 x) (fa2 x)) :
      [| l | g2 , fa2 |].
Proof.
  revert CG G1_BOUND G2_BOUND A12_NEQ A2_FRESH REN DSG1 F_SWITCH F12_EQ.
  revert g1 g2 n a1 a2 fa1 fa2.
  induction l.
  { intros. apply in_denotational_sem_zero_lev in DSG1. contradiction. }
  { induction g1; intros; good_inversion DSG1; good_inversion REN; good_inversion CG.
    { constructor. }
    { constructor.
      etransitivity.
      2: etransitivity.
      2: apply UNI.
      1-2: etransitivity.
      1, 3: symmetry.
      1, 4: apply repr_fun_apply_compose.
      all: apply apply_repr_fun_fv; intros; unfold subst_repr_fun_compose;
        simpl; destruct (Nat.eq_dec a1 x); subst; symmetry; auto;
        apply F12_EQ; auto; intro; subst; auto. }
    { constructor. intros UNI. apply DISUNI.
      etransitivity.
      2: etransitivity.
      2: apply UNI.
      1-2: etransitivity.
      1, 3: symmetry.
      2, 3: apply repr_fun_apply_compose.
      all: apply apply_repr_fun_fv; intros; unfold subst_repr_fun_compose;
        simpl; destruct (Nat.eq_dec a1 x); subst; symmetry; auto;
        apply F12_EQ; auto; intro; subst; auto. }
    { apply dslgDisjL; eauto. eapply IHg1_1; eauto. }
    { apply dslgDisjR; eauto. eapply IHg1_2; eauto. }
    { constructor; eauto.
      { eapply IHg1_1; eauto. }
      { eapply IHg1_2; eauto. } }
    { apply completeness_condition_lev with fa1.
      { intros; apply F12_EQ; intro; subst; auto. }
      { econstructor.
        2: eauto.
        all: eauto. } }
    { rename g into fg. rename fn into fn1. rename a into a0. red in CB_FG.
      assert (very_fresh_var : exists y, a0 <> y /\ a2 <> y /\
                                         (~ is_fv_of_goal y (Fresh fg)) /\
                                         (~ is_fv_of_goal y (Fresh rfg))).
      { destruct (name_eq_dec a0 n); destruct (name_eq_dec a0 (S n));
        destruct (name_eq_dec a2 n); destruct (name_eq_dec a2 (S n)); subst; try omega.
        5, 6, 8, 9: exists n.
        1, 3, 9: exists (S n).
        4, 5: exists (S (S n)).
        all: repeat split; try omega.
        all: intro CH; try apply G1_BOUND in CH; try apply G2_BOUND in CH; omega. }
      destruct very_fresh_var as [a3 [a03_neq [a23_neq [a3_fresh a3_rfresh]]]].
      assert (a13_neq : a1 <> a3).
      { intro; subst; auto. }
      remember (fun x => if name_eq_dec x a3
                           then fn1 a0
                           else if name_eq_dec x a0
                                  then fa2 a0
                                  else fn1 x) as fn0 eqn:fn0_def.
      assert (AH0 : in_denotational_sem_lev_goal (S l) (fg a3) fn0).
      { subst.
        apply H with a0 (max n (max (S a0) (S a3))) a0 a3 fn1; eauto.
        { intros. destruct (name_eq_dec x a0); subst.
          { zify. omega. }
          { assert (x < n); eauto. zify. omega. } }
        { intros. destruct (name_eq_dec x a3); subst.
          { zify. omega. }
          { assert (x < n); eauto. zify. omega. } }
        { destruct (name_eq_dec a3 a3); subst.
          { reflexivity. }
          { contradiction. } }
        { intros. destruct (name_eq_dec x a3).
          { contradiction. }
          { destruct (name_eq_dec x a0).
            { contradiction. }
            { reflexivity. } } } }
      remember (fun x => if name_eq_dec x a2
                           then fn0 a1
                           else if name_eq_dec x a1
                                  then fa2 a1
                                  else fn0 x) as fn2 eqn:fn2_def.
      assert (AH2 : in_denotational_sem_lev_goal (S l) (rfg a3) fn2).
      { apply H with a3 (max n (max (S a0) (S a3))) a1 a2 fn0; subst; eauto.
        { intros. destruct (name_eq_dec x a3); subst.
          { zify. omega. }
          { assert (x < n); eauto. zify. omega. } }
        { intros. destruct (name_eq_dec x a3); subst.
          { zify. omega. }
          { assert (x < n); eauto. zify. omega. } }
        { simpl. destruct (name_eq_dec a2 a2); subst.
          { reflexivity. }
          { contradiction. } }
        { intros. simpl. destruct (name_eq_dec x a2).
          { contradiction. }
          { destruct (name_eq_dec x a1).
            { contradiction. }
            { reflexivity. } } } }
      econstructor; eauto.
      intros. subst. destruct (name_eq_dec x a2); subst.
      { destruct (name_eq_dec a1 a0); subst.
        { contradiction. }
        { destruct (name_eq_dec a1 a3); subst.
          { contradiction. }
          { etransitivity.
            { apply EASE. auto. }
            { auto. } } } }
      { destruct (name_eq_dec x a1); subst.
        { reflexivity. }
        { destruct (name_eq_dec x a3).
          { contradiction. }
          { destruct (name_eq_dec x a0); subst.
            { reflexivity. }
            { etransitivity.
              { apply EASE. auto. }
              { apply F12_EQ; auto. } } } } } }
    { rename n into r. rename n0 into n.
      remember (MiniKanrenSyntax.Prog r) as d. destruct d as [rel [Hcl Hco]].
      red in Hco. destruct (Hco t) as [Hcog Hcof].
      red in Hcl. unfold closed_goal_in_context in Hcl.
      econstructor.
      rewrite <- Heqd. simpl.
      eapply IHl.
      7: eauto.
      all: simpl; eauto. } }
Qed.

Lemma den_sem_another_fresh_var
      (b : name -> goal)
      (CG : consistent_goal (Fresh b))
      (n : nat)
      (FRESH_BOUND : forall x : name, is_fv_of_goal x (Fresh b) -> x < n)
      (a1 a2 : name)
      (A1_FRESH : ~ is_fv_of_goal a1 (Fresh b))
      (A2_FRESH : ~ is_fv_of_goal a2 (Fresh b))
      (fa1 fa2 : repr_fun)
      (l : nat)
      (DSG1 : in_denotational_sem_lev_goal l (b a1) fa1)
      (F_SWITCH : gt_eq (fa1 a1) (fa2 a2))
      (F12_EQ : forall x, x <> a1 -> x <> a2 -> gt_eq (fa1 x) (fa2 x)) :
      [| l | b a2 , fa2 |].
Proof.
  destruct (name_eq_dec a1 a2); subst.
  { apply completeness_condition_lev with fa1; auto.
    intros. destruct (name_eq_dec x a2); subst; auto. }
  { good_inversion CG. red in CB_FG.
    eapply den_sem_rename_var with (g1 := (b a1)) (n := max n (max (S a1) (S a2))); eauto.
    { intros. destruct (name_eq_dec x a1); subst.
      { zify. omega. }
      { assert (x < n); eauto. zify. omega. } }
    { intros. destruct (name_eq_dec x a2); subst.
      { zify. omega. }
      { assert (x < n); eauto. zify. omega. } } }
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A B C D U Xu : Universe, ((wd_ U O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ D O /\ (wd_ U Eprime /\ (wd_ A Eprime /\ (wd_ B Xu /\ (wd_ B U /\ (wd_ B Eprime /\ (wd_ Xu U /\ (wd_ Xu Eprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O E D /\ (col_ O E U /\ (col_ O Eprime Xu /\ col_ O E Xu))))))))))))))))))))) -> col_ U B Xu)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime S U1 A AX B BX C CX BXMAX CXMAX AB AC IAC T A1 A2 : Universe, ((wd_ A B /\ (wd_ A C /\ (wd_ B C /\ (wd_ A1 A2 /\ (wd_ O E /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ S U1 /\ (col_ O E AX /\ (col_ O E BX /\ (col_ O E CX /\ (col_ O E BXMAX /\ (col_ O E CXMAX /\ (col_ O E T /\ (col_ O E AB /\ (col_ O E AC /\ (col_ O E IAC /\ (col_ A A1 A2 /\ (col_ A1 S U1 /\ (col_ A2 S U1 /\ col_ A B C)))))))))))))))))))) -> col_ S U1 A)).
Proof.
  time tac.
Qed.

End FOFProblem.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University

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

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

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

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

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export computation7.
Require Export terms5.

Lemma reduces_in_atmost_k_steps_exc_0 {o} :
  forall lib (t u : @NTerm o),
    reduces_in_atmost_k_steps_exc lib t u 0 <=> t = u.
Proof.
  introv.
  unfold reduces_in_atmost_k_steps_exc; simpl; split; intro e; subst; ginv; auto.
Qed.

Lemma compute_at_most_k_steps_exc_iscan {o} :
  forall lib k (t : @NTerm o) u,
    iscan t
    -> (compute_at_most_k_steps_exc lib k t = csuccess u <=> u = t).
Proof.
  induction k; introv isc; split; intro comp; subst; allsimpl; ginv; auto.
  - apply iscan_implies in isc; repndors; exrepnd; subst; allsimpl;
    apply IHk in comp; allsimpl; auto.
  - apply iscan_implies in isc; repndors; exrepnd; subst; allsimpl;
    apply IHk; allsimpl; auto.
Qed.

Lemma reduces_in_atmost_k_steps_exc_S {o} :
  forall lib k (t u : @NTerm o),
    reduces_in_atmost_k_steps_exc lib t u (S k)
     <=> ({a : NTerm
           & {e : NTerm
           & {a' : NTerm
           & {e' : NTerm
           & t = mk_exception a e
           # ((isvalue_like a # compute_step lib e = csuccess e' # a = a')
              [+]
              (isnoncan_like a # compute_step lib a = csuccess a' # e = e'))
           # reduces_in_atmost_k_steps_exc lib (mk_exception a' e') u k}}}}
         [+]
         (!isexc t
          # {v : NTerm
             & compute_step lib t = csuccess v
             # reduces_in_atmost_k_steps_exc lib v u k})).
Proof.
  introv.
  unfold reduces_in_atmost_k_steps_exc; simpl.
  destruct t as [v|f|op bs]; simpl.

  - split; intro e; repndors; exrepnd; ginv.

  - split; intro e.

    + apply compute_at_most_k_steps_exc_iscan in e; simpl; auto; subst.
      right; dands; tcsp.
      csunf; simpl.
      eexists; dands; eauto.
      apply compute_at_most_k_steps_exc_iscan; simpl; auto.

    + repndors; exrepnd; ginv; GC.
      csunf e2; allsimpl; ginv.

  - dopid op as [can|ncan|exc|abs] Case; allsimpl.

    + Case "Can".
      split; introv e; repndors; exrepnd; ginv; tcsp.
      * right; dands; tcsp.
        exists (oterm (Can can) bs); csunf; simpl; dands; auto.
      * csunf e2; allsimpl; ginv.

    + Case "NCan".
      split; intro e; repndors; exrepnd; ginv; tcsp.
      * right; dands; tcsp.
        remember (compute_step lib (oterm (NCan ncan) bs)) as c; destruct c; ginv.
        exists n; dands; auto.
      * rw e2; auto.

    + Case "Exc".
      destruct bs as [|b1 bs]; allsimpl; tcsp.

      * split; introv e; repndors; exrepnd; ginv; tcsp.

      * destruct b1 as [l1 t1].
        destruct l1 as [|v1].

        { destruct bs as [|b2 bs]; allsimpl; tcsp.

          - split; introv e; repndors; exrepnd; ginv; tcsp.

          - destruct b2 as [l2 t2].
            destruct l2 as [|v2].

            + destruct bs; allsimpl.

              * split; intro e.

                { left.
                  exists t1 t2.
                  unfold compute_eager_exc in e.
                  destruct t1 as [v|f|op bs]; ginv.

                  { remember (compute_step lib t2) as c; destruct c; ginv.
                    exists (sterm f) n; dands; auto.
                    left; dands; eauto 3 with slow. }

                  dopid op as [can|ncan|exc|abs] SCase.
                  - SCase "Can".
                    remember (compute_step lib t2) as c; destruct c; ginv.
                    exists (oterm (Can can) bs) n.
                    dands; auto.
                    left; dands; eauto 3 with slow.
                  - SCase "NCan".
                    remember (compute_step lib (oterm (NCan ncan) bs)) as c; destruct c; ginv.
                    exists n t2.
                    dands; auto.
                  - SCase "Exc".
                    remember (compute_step lib t2) as c; destruct c; ginv.
                    exists (oterm Exc bs) n.
                    dands; auto.
                    left; dands; eauto 3 with slow.
                  - SCase "Abs".
                    remember (compute_step lib (oterm (Abs abs) bs)) as c; destruct c; ginv.
                    exists n t2.
                    dands; auto. }

                { repndors; exrepnd; fold_terms; ginv; repndors; exrepnd; subst; tcsp.
                  - unfold isvalue_like in e0; repndors.
                    + apply iscan_implies in e0; repndors; exrepnd; subst; simpl;
                      rw e3; auto.
                    + apply isexc_implies2 in e0; exrepnd; subst; simpl.
                      rw e3; auto.
                  - unfold isnoncan_like in e0; repndors.
                    + apply isnoncan_implies in e0; exrepnd; subst; simpl.
                      rw e3; auto.
                    + apply isabs_implies in e0; exrepnd; subst; simpl.
                      rw e3; auto. }

              * split; intro e; ginv; repndors; exrepnd; ginv; tcsp.

            + split; intro e; ginv; repndors; exrepnd; ginv; tcsp.
        }

        { split; intro e; ginv; repndors; exrepnd; ginv; tcsp. }

    + Case "Abs".
      split; intro e; repndors; exrepnd; ginv; tcsp.
      * right; dands; tcsp.
        remember (compute_step lib (oterm (Abs abs) bs)) as c; destruct c; ginv.
        exists n; dands; auto.
      * rw e2; auto.
Qed.

Lemma reduces_in_atmost_k_steps_preserves_isprog {o} :
  forall lib k (a b : @NTerm o),
    reduces_in_atmost_k_steps_exc lib a b k
    -> isprog a
    -> isprog b.
Proof.
  induction k; introv r isp.
  - allrw @reduces_in_atmost_k_steps_exc_0; subst; auto.
  - allrw @reduces_in_atmost_k_steps_exc_S; repndors; exrepnd; subst;
    repndors; exrepnd; subst.
    + apply IHk in r1; auto.
      allrw @isprog_exception_iff; repnd; dands; auto.
      apply preserve_compute_step in r3; allrw @isprogram_eq; auto.
    + apply IHk in r1; auto.
      allrw @isprog_exception_iff; repnd; dands; auto.
      apply preserve_compute_step in r3; allrw @isprogram_eq; auto.
    + apply IHk in r1; auto.
      apply preserve_compute_step in r2; allrw @isprogram_eq; auto.
Qed.


(** This proof shows that PCUICToTemplate is injective
    and TemplateToPCUIC is surjective
**)

From Coq Require Import Bool String List Program BinPos Compare_dec ZArith.

From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICInduction
     PCUICLiftSubst PCUICEquality
     PCUICUnivSubst PCUICTyping PCUICGeneration.

Require Import MetaCoq.Template.All.
Require Import MetaCoq.Checker.All.

From MetaCoq.PCUIC Require Import
  PCUICToTemplate
  TemplateToPCUIC.
From MetaCoq.PCUIC Require Import
  (* PCUICToTemplateCorrectness. *)
  TemplateToPCUICCorrectness.

Require Import String.
Local Open Scope string_scope.
Set Asymmetric Patterns.

Lemma inj_sur (t:PCUICAst.term):
  TemplateToPCUIC.trans (PCUICToTemplate.trans t) = t.
Proof.
  induction t using PCUICInduction.term_forall_list_ind;cbn;try congruence.
  - f_equal.
    induction X;cbn;trivial.
    now rewrite IHX.
  - now rewrite trans_mkApp,IHt1,IHt2.
  - rewrite IHt1, IHt2.
    f_equal.
    induction X;cbn;trivial.
    rewrite IHX.
    destruct x; unfold on_snd; cbn in *; now rewrite p0.
  - f_equal.
    induction X;cbn;trivial.
    rewrite IHX.
    destruct x;
    unfold map_def;
    cbn in *.
    destruct p.
    now do 2 f_equal.
  - f_equal.
    induction X;cbn;trivial.
    rewrite IHX.
    destruct x;
    unfold map_def;
    cbn in *.
    destruct p.
    now do 2 f_equal.
Qed.


Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.PropExtensionality.
Require Import Coq.Lists.List.

Class Monad(M: Type -> Type) := mkMonad {
  Bind: forall {A B}, M A -> (A -> M B) -> M B;
  Return: forall {A}, A -> M A;

  left_identity: forall {A B} (a: A) (f: A -> M B),
    Bind (Return a) f = f a;
  right_identity: forall {A} (m: M A),
    Bind m Return = m;
  associativity: forall {A B C} (m: M A) (f: A -> M B) (g: B -> M C),
    Bind (Bind m f) g = Bind m (fun x => Bind (f x) g)
}.

Definition when{M: Type -> Type}{MM: Monad M}(a: bool)(b: M unit): M unit :=
  if a then b else Return tt.

Create HintDb unf_monad_ops.

Ltac prove_monad_law :=
  repeat match goal with
         | |- _ => intro
         | |- _ => apply functional_extensionality
         | |- _ => apply propositional_extensionality; split; intros
         | H: exists x, _ |- _ => destruct H
         | H: _ /\ _ |- _ => destruct H
         | p: _ * _ |- _ => destruct p
         | |- context [ let (_, _) := ?p in _ ] => let E := fresh "E" in destruct p eqn: E
         | H: Some _ = Some _ |- _ => inversion H; clear H; subst
         | H: (_, _) = (_, _) |- _ => inversion H; clear H; subst
         | |- _ => discriminate
         | |- _ => progress (autounfold with unf_monad_ops in *; subst; simpl in *)
         | |- _ => solve [eauto 10]
         | H: _ \/ _ |- _ => destruct H
         | o: option _ |- _ => destruct o
         end.

#[global] Instance option_Monad: Monad option. refine ({|
  Bind A B (o: option A) (f: A -> option B) :=
    match o with
    | Some x => f x
    | None => None
    end;
  Return A (a: A) := Some a
|}).
all: prove_monad_law.
Defined.

Definition NonDet(A: Type): Type := A -> Prop.

#[global] Instance NonDet_Monad: Monad NonDet. refine ({|
  Bind A B (m: NonDet A)(f: A -> NonDet B) :=
    fun (b: B) => exists a, m a /\ f a b;
  Return A := eq;
|}).
all: prove_monad_law.
Defined.

Definition State(S A: Type) := S -> (A * S).

#[global] Instance State_Monad(S: Type): Monad (State S). refine ({|
  Bind A B (m: State S A) (f: A -> State S B) :=
    fun (s: S) => let (a, s') := m s in f a s' ;
  Return A (a: A) :=
    fun (s: S) => (a, s)
|}).
all: prove_monad_law.
Defined.

Module StateOperations.
  Definition get{S: Type}: State S S := fun (s: S) => (s, s).
  Definition gets{S A: Type}(f: S -> A): State S A := fun (s: S) => (f s, s).
  Definition put{S: Type}(s: S): State S unit := fun _ => (tt, s).
End StateOperations.

Definition OState(S A: Type) := S -> (option A) * S.

#[global] Instance OState_Monad(S: Type): Monad (OState S). refine ({|
  Bind A B (m: OState S A) (f: A -> OState S B) :=
    fun (s: S) => match m s with
                  | (Some a, s') => f a s'
                  | (None, s') => (None, s')
                  end;
  Return A (a: A) := fun (s: S) => (Some a, s)
|}).
all: prove_monad_law.
Defined.

Module OStateOperations.

  Definition get{S: Type}: OState S S := fun (s: S) => (Some s, s).

  Definition put{S: Type}(s: S): OState S unit := fun _ => (Some tt, s).

  Definition fail_hard{S A: Type}: OState S A :=
    fun (s: S) => (None, s).

  #[global] Hint Unfold get put fail_hard : unf_monad_ops.

  Lemma Bind_get{S A: Type}: forall (f: S -> OState S A) (s: S),
      Bind get f s = f s s.
  Proof. prove_monad_law. Qed.

  Lemma Bind_put{S A: Type}: forall (f: unit -> OState S A) (s0 s1: S),
      Bind (put s1) f s0 = f tt s1.
  Proof. prove_monad_law. Qed.

  (* provides the link between "S -> option A * S" and "S -> (S -> Prop) -> Prop" *)
  Definition computation_satisfies{S: Type}(m: OState S unit)(s: S)(post: S -> Prop): Prop :=
    exists s', m s = (Some tt, s') /\ post s'.

  (* provides the link between "S -> option A * S" and "S -> (A -> S -> Prop) -> Prop" *)
  Definition computation_with_answer_satisfies
             {S A: Type}(m: OState S A)(s: S)(post: A -> S -> Prop): Prop :=
    exists a s', m s = (Some a, s') /\ post a s'.

  Lemma computation_with_answer_satisfies_Return{S A: Type}: forall (a: A) (initial: S) post,
      computation_with_answer_satisfies (Return a) initial post ->
      post a initial.
  Proof.
    unfold computation_with_answer_satisfies.
    intros. simpl in *.
    destruct H as (? & ? & ? & ?).
    inversion H. subst. assumption.
  Qed.

  Lemma computation_with_answer_satisfies_Bind{S A B: Type}:
    forall (m: OState S A) (f: A -> OState S B) (initial: S) post,
      computation_with_answer_satisfies (Bind m f) initial post ->
      (exists mid, computation_with_answer_satisfies m initial mid
                   /\ forall a s, mid a s -> computation_with_answer_satisfies (f a) s post).
  Proof.
    unfold computation_with_answer_satisfies.
    intros. simpl in *.
    eexists.
    split.
    - intros. destruct (m initial).
      destruct o. 2: { destruct H as (? & ? & ? & ?). discriminate. }
      do 2 eexists; split; [reflexivity|].
      exact H.
    - simpl. intros. assumption.
  Qed.

  Lemma computation_with_answer_satisfies_get{S: Type}: forall (initial: S) post,
      computation_with_answer_satisfies get initial post ->
      post initial initial.
  Proof.
    unfold computation_with_answer_satisfies, get.
    intros. destruct H as (? & ? & ? & ?).
    inversion H. subst. assumption.
  Qed.

  Lemma computation_with_answer_satisfies_put{S: Type}: forall (initial new: S) post,
      computation_with_answer_satisfies (put new) initial post ->
      post tt new.
  Proof.
    unfold computation_with_answer_satisfies, put.
    intros. destruct H as (? & ? & ? & ?).
    inversion H. subst. assumption.
  Qed.

  Lemma computation_with_answer_satisfies_fail_hard{S A: Type}:
    forall (initial: S) (post: A -> S -> Prop),
      computation_with_answer_satisfies fail_hard initial post ->
      False.
  Proof.
    unfold computation_with_answer_satisfies, fail_hard.
    intros. destruct H as (? & ? & ? & ?). discriminate.
  Qed.

  Ltac simpl_computation_with_answer_satisfies :=
    match goal with
    | H: computation_with_answer_satisfies (Return _) _ _ |- _ =>
      apply computation_with_answer_satisfies_Return in H
    | H: computation_with_answer_satisfies (Bind _ _) _ _ |- _ =>
      apply computation_with_answer_satisfies_Bind in H
    | H: computation_with_answer_satisfies get _ _ |- _ =>
      apply computation_with_answer_satisfies_get in H
    | H: computation_with_answer_satisfies (put _) _ _ |- _ =>
      apply computation_with_answer_satisfies_put in H
    | H: computation_with_answer_satisfies fail_hard _ _ |- _ =>
      apply computation_with_answer_satisfies_fail_hard in H; contradiction
    end.

End OStateOperations.

(* We can think of it as "S -> ((A * S) -> Prop)", i.e. a function returning
   a unique set of all possible outcomes. *)
Definition StateND(S A: Type) := S -> (A * S) -> Prop.

#[global] Instance StateND_Monad(S: Type): Monad (StateND S). refine ({|
  Bind A B (m: StateND S A)(f : A -> StateND S B) :=
    fun (s1 : S) bs3 => exists a s2, m s1 (a, s2) /\ f a s2 bs3;
  Return A (a : A) :=
    fun (s : S) '(a', s') => a' = a /\ s' = s;
|}).
all: prove_monad_law.
Defined.

Module StateNDOperations.

  Definition get{S: Type}: StateND S S :=
    fun (s: S) (ss: (S * S)) => ss = (s, s).

  Definition put{S: Type}(new_s: S): StateND S unit :=
    fun (s: S) (us: (unit * S)) => us = (tt, new_s).

  Definition unspecified_behavior{S A: Type}: StateND S A :=
    fun (s: S) (a_s: (A * S)) => True. (* everything's possible *)

  Definition arbitrary{S: Type}(A: Type): StateND S A :=
    fun (s: S) (a_s: (A * S)) => exists a, a_s = (a, s).

  #[global] Hint Unfold get put unspecified_behavior arbitrary : unf_monad_ops.

  Lemma Bind_get{S A: Type}: forall (f: S -> StateND S A) (s: S),
      Bind get f s = f s s.
  Proof. prove_monad_law. Qed.

  Lemma Bind_put{S A: Type}: forall (f: unit -> StateND S A) (s0 s1: S),
      Bind (put s1) f s0 = f tt s1.
  Proof. prove_monad_law. Qed.

  (* provides the link between "S -> (A * S) -> Prop" and "S -> (S -> Prop) -> Prop" *)
  Definition computation_satisfies{S: Type}(m: StateND S unit)(s: S)(post: S -> Prop): Prop :=
    forall (o: (unit * S)), m s o -> exists s', o = (tt, s') /\ post s'.

  (* provides the link between "S -> (A * S) -> Prop" and "S -> (A -> S -> Prop) -> Prop" *)
  Definition computation_with_answer_satisfies
             {S A: Type}(m: StateND S A)(s: S)(post: A -> S -> Prop): Prop :=
    forall (o: (A * S)), m s o -> exists a s', o = (a, s') /\ post a s'.

End StateNDOperations.

(* option is for failure, Prop is for non-determinism.
   We can think of it as "S -> (option (A * S) -> Prop)", i.e. a function returning
   a unique set of all possible outcomes. *)
Definition OStateND(S A: Type) := S -> option (A * S) -> Prop.

#[global] Instance OStateND_Monad(S: Type): Monad (OStateND S). refine ({|
  Bind A B (m: OStateND S A)(f : A -> OStateND S B) :=
    fun (s : S) (obs: option (B * S)) =>
      (m s None /\ obs = None) \/
      (exists a s', m s (Some (a, s')) /\ f a s' obs);
  Return A (a : A) :=
    fun (s : S) (oas: option (A * S)) => oas = Some (a, s);
|}).
all: prove_monad_law.
Defined.

Module OStateNDOperations.

  Definition get{S: Type}: OStateND S S :=
    fun (s: S) (oss: option (S * S)) => oss = Some (s, s).

  Definition put{S: Type}(new_s: S): OStateND S unit :=
    fun (s: S) (ous: option (unit * S)) => ous = Some (tt, new_s).

  Definition fail_hard{S A: Type}: OStateND S A :=
    fun (s: S) (oas: option (A * S)) => oas = None.

  Definition arbitrary{S: Type}(A: Type): OStateND S A :=
    fun (s: S) (oas: option (A * S)) => exists a, oas = Some (a, s).

  #[global] Hint Unfold get put fail_hard arbitrary : unf_monad_ops.

  Lemma Bind_get{S A: Type}: forall (f: S -> OStateND S A) (s: S),
      Bind get f s = f s s.
  Proof. prove_monad_law. Qed.

  Lemma Bind_put{S A: Type}: forall (f: unit -> OStateND S A) (s0 s1: S),
      Bind (put s1) f s0 = f tt s1.
  Proof. prove_monad_law. Qed.

  (* provides the link between "S -> option (A * S) -> Prop" and "S -> (S -> Prop) -> Prop" *)
  Definition computation_satisfies{S: Type}(m: OStateND S unit)(s: S)(post: S -> Prop): Prop :=
    forall (o: option (unit * S)), m s o -> exists s', o = Some (tt, s') /\ post s'.

  (* provides the link between "S -> option (A * S) -> Prop" and "S -> (A -> S -> Prop) -> Prop" *)
  Definition computation_with_answer_satisfies
             {S A: Type}(m: OStateND S A)(s: S)(post: A -> S -> Prop): Prop :=
    forall (o: option (A * S)), m s o -> exists a s', o = Some (a, s') /\ post a s'.

  Lemma computation_with_answer_satisfies_Return{S A: Type}: forall (a: A) (initial: S) post,
      computation_with_answer_satisfies (Return a) initial post ->
      post a initial.
  Proof.
    unfold computation_with_answer_satisfies.
    intros. simpl in *.
    edestruct H as (? & ? & ? & ?); [reflexivity|].
    inversion H0. subst. assumption.
  Qed.

  Lemma computation_with_answer_satisfies_Bind{S A B: Type}:
    forall (m: OStateND S A) (f: A -> OStateND S B) (initial: S) post,
      computation_with_answer_satisfies (Bind m f) initial post ->
      (exists mid, computation_with_answer_satisfies m initial mid
                   /\ forall a s, mid a s -> computation_with_answer_satisfies (f a) s post).
  Proof.
    unfold computation_with_answer_satisfies.
    intros. simpl in *.
    eexists.
    split.
    - intros. destruct o as [(? & ?) |]. 1: do 2 eexists; split; [reflexivity|].
      2: { edestruct (H None) as (? & ? & ? & ?); [auto|discriminate]. }
      exact H0.
    - simpl. intros. specialize (H o). eapply H. right. eauto.
  Qed.

  Lemma computation_with_answer_satisfies_get{S: Type}: forall (initial: S) post,
      computation_with_answer_satisfies get initial post ->
      post initial initial.
  Proof.
    unfold computation_with_answer_satisfies, get.
    intros. specialize (H _ eq_refl). destruct H as (? & ? & ? & ?).
    inversion H. subst. assumption.
  Qed.

  Lemma computation_with_answer_satisfies_put{S: Type}: forall (initial new: S) post,
      computation_with_answer_satisfies (put new) initial post ->
      post tt new.
  Proof.
    unfold computation_with_answer_satisfies, put.
    intros. specialize (H _ eq_refl). destruct H as (? & ? & ? & ?).
    inversion H. subst. assumption.
  Qed.

  Lemma computation_with_answer_satisfies_arbitrary{S A: Type}: forall (initial: S) post,
      computation_with_answer_satisfies (arbitrary A) initial post ->
      forall (a: A), post a initial.
  Proof.
    unfold computation_with_answer_satisfies, arbitrary.
    intros. specialize (H (Some (a, initial))). destruct H as (? & ? & ? & ?).
    - eexists. reflexivity.
    - inversion H. subst. assumption.
  Qed.

  Lemma computation_with_answer_satisfies_fail_hard{S A: Type}:
    forall (initial: S) (post: A -> S -> Prop),
      computation_with_answer_satisfies fail_hard initial post ->
      False.
  Proof.
    unfold computation_with_answer_satisfies, fail_hard.
    intros. specialize (H _ eq_refl). destruct H as (? & ? & ? & ?). discriminate.
  Qed.

  Ltac simpl_computation_with_answer_satisfies :=
    match goal with
    | H: computation_with_answer_satisfies (Return _) _ _ |- _ =>
      apply computation_with_answer_satisfies_Return in H
    | H: computation_with_answer_satisfies (Bind _ _) _ _ |- _ =>
      apply computation_with_answer_satisfies_Bind in H
    | H: computation_with_answer_satisfies get _ _ |- _ =>
      apply computation_with_answer_satisfies_get in H
    | H: computation_with_answer_satisfies (put _) _ _ |- _ =>
      apply computation_with_answer_satisfies_put in H
    | H: computation_with_answer_satisfies (arbitrary _) _ _ |- _ =>
      specialize @computation_with_answer_satisfies_arbitrary with (1 := H);
      clear H
    | H: computation_with_answer_satisfies fail_hard _ _ |- _ =>
      apply computation_with_answer_satisfies_fail_hard in H; contradiction
    end.

End OStateNDOperations.

(* The postcondition monad: if `m: Post S A` and `m s post` holds,
   it means that running the computation m on initial state s
   will return an answer and a final state that satisfy post. *)
Definition Post(S A: Type) := S -> (A -> S -> Prop) -> Prop.

#[global] Instance Post_Monad(S: Type): Monad (Post S). refine ({|
  Bind A B (m: Post S A) (f : A -> Post S B) :=
    fun s1 post => m s1 (fun a s2 => f a s2 post);
  Return A (a : A) :=
    fun s post => post a s
|}).
all: reflexivity.
Defined.

Module PostMonadOperations.

  Definition get{S: Type}: Post S S := fun s post => post s s.

  Definition put{S: Type}(new_s: S): Post S unit := fun s post => post tt s.

  Definition fail_hard{S A: Type}: Post S A := fun s post => False.

  Definition arbitrary{S: Type}(A: Type): Post S A := fun s post => forall a, post a s.

  Definition weaken{S A: Type}(m: Post S A): Post S A :=
    fun s post => exists stronger, m s stronger /\ forall a final, stronger a final -> post a final.

End PostMonadOperations.

(* outer option is for failure, inner option is for early return (abort) *)
Definition StateAbortFail(S A: Type) := S -> (option (option A) * S).

#[global] Instance StateAbortFail_Monad(S: Type): Monad (StateAbortFail S). refine ({|
  Bind A B (m: StateAbortFail S A) (f: A -> StateAbortFail S B) (s1 : S) :=
    match m s1 with
    | (Some (Some a), s2) => f a s2
    | (Some None, s2) => (Some None, s2)
    | (None, s2) => (None, s2)
    end;
  Return A (a: A) (s1: S) := (Some (Some a), s1);
|}).
all: prove_monad_law.
Defined.

Module StateAbortFailOperations.

  Definition get{S: Type}: StateAbortFail S S := fun (s: S) => (Some (Some s), s).

  Definition put{S: Type}(s: S): StateAbortFail S unit := fun _ => (Some (Some tt), s).

  Definition abort{S A: Type}: StateAbortFail S A := fun (s: S) => (Some None, s).

  Definition fail_hard{S A: Type}: StateAbortFail S A := fun (s: S) => (None, s).

End StateAbortFailOperations.


(** Sequential computations. *)

Module Effect.
  Record t := New {
    command : Type;
    answer : command -> Type }.
End Effect.

Module Callback.
  Inductive t (E : Effect.t) (A : Type) : Type :=
  | Ret : t E A
  | Call : forall (c : Effect.command E), (Effect.answer E c -> t E A) -> t E A.
  Arguments Ret _ _.
  Arguments Call {E A} _ _.
End Callback.

Module Monad.
  Inductive t (E : Effect.t) : Type -> Type :=
  | Ret : forall (A : Type) (x : A), t E A
  | Call : forall (c : Effect.command E), t E (Effect.answer E c)
  | Let : forall (A B : Type), t E A -> (A -> t E B) -> t E B.
  Arguments Ret _ {A} _.
  Arguments Call {E} _.
  Arguments Let {E} _ _ _ _.
End Monad.

Fixpoint compile {E : Effect.t} {A B : Type} (x : Monad.t E A)
  : (A -> Callback.t E B) -> Callback.t E B :=
  match x with
  | Monad.Ret _ x => fun k => k x
  | Monad.Call c => fun k => Callback.Call c k
  | Monad.Let _ _ x f => fun k => compile x (fun x => compile (f x) k)
  end.


From mathcomp Require Import all_ssreflect.

From PoS_NSB Require Import
     GlobalState
     Messages
     MessageTuple
     Parameters.

From mathcomp Require Import finmap.

From RecordUpdate Require Import RecordSet.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** * Network
      This file contains the basic operation for the synchronous network.
**)

(* Notation for record update *)

Notation "x [[ proj  :=  v ]]" := (set proj (fun _ => v) x)
                                    (at level 12, left associativity).

Notation "x [ proj  ::=  f ]" := (set proj f x)
                                     (at level 12, f at next level, left associativity).

(** Honest send of messages *)
Definition flood_msg (m : Message) (N : GlobalState) : GlobalState :=
  let: newMessages := [seq mkMessageTuple m r 1 | r <- exec_order N] in
  N[[msg_buff := newMessages ++ (msg_buff N)]][[history := m :: (history N)]].

(** Adversarial send of messages An adversary can for each of the
    messages choose to have them delivered in round t+1 or t+2.  *)
Definition Delay : Type := seq_sub [:: 1 ; 2].

Definition nat_of_delay (d : Delay) : nat.
  case d=> n; case: (n == 1)=> _; [exact 1| exact 2].
Defined.

Coercion nat_of_delay : Delay >-> nat.
Definition DelayMap := Party -> Delay.

Lemma delay12 (d : Delay): (d : nat) = 1 \/ (d : nat) = 2.
Proof. case d=> //= n. rewrite mem_seq2. case (_ == _) => //= _; by [constructor |constructor 2]. Qed.

Definition flood_msg_adv (m : Message) (ϕ : DelayMap) (N : GlobalState)  : GlobalState :=
  let: newMessages := [seq mkMessageTuple m r (ϕ(r)) | r <- exec_order N] in
  N[[msg_buff := newMessages ++ (msg_buff N)]][[history := m :: (history N)]].

(** Fetching of messages for a party *)
Definition collect_zero_pairs (r : Party) (N : GlobalState) : MessagePool :=
  [seq mt <- (msg_buff N) | (cd mt == 0) && (rcv mt == r)].

Definition rmv_zero_msgs (r : Party ) (N : GlobalState) : GlobalState :=
  N[[msg_buff := [seq mt <- (msg_buff N) | ~~ ((cd mt == 0) && (rcv mt == r))] ]].

Definition fetch_msgs (r : Party) (N : GlobalState): (seq Message * GlobalState) :=
  ([seq msg mt | mt <- collect_zero_pairs r N], rmv_zero_msgs r N).

(** Round tick *)
Definition round_tick (N : GlobalState) : GlobalState :=
  N[[msg_buff := [seq m[[cd := (cd m) - 1]] | m <- msg_buff N] ]].