(* begin hide *)
From Coq Require Import
     Classes.Morphisms
     Classes.RelationClasses
     Lists.List
     Relations.Relation_Operators
     Relations.Operators_Properties.
(* end hide *)

Section Permissions.
  (** This entire file is parameterized over some state type. *)
  Context {config : Type}.

  (** * Rely-guarantee permissions *)
  Record perm : Type :=
    {
    (** The rely: the updates this permission allows of others. *)
    rely : config -> config -> Prop;
    rely_PO : PreOrder rely;
    (** The guarantee: the updates that this permission allows. *)
    guar : config -> config -> Prop;
    guar_PO : PreOrder guar;
    (** The precondition on configs. *)
    pre : config -> Prop;
    pre_respects : forall x y, rely x y -> pre x -> pre y;
    }.

  (* begin hide *)
  Hint Unfold rely : core.
  Hint Unfold pre : core.
  Hint Unfold guar : core.
  Hint Resolve pre_respects : core.

  Global Instance rely_is_preorder p : PreOrder (rely p) := rely_PO p.
  Global Instance guar_is_preorder p : PreOrder (guar p) := guar_PO p.
  (* end hide *)

  (** ** Permission ordering *)
  Record lte_perm (p q: perm) : Prop :=
    {
    pre_inc : forall x, pre q x -> pre p x;
    rely_inc : forall x y, rely q x y -> rely p x y;
    guar_inc : forall x y, guar p x y -> guar q x y;
    }.

  (* begin hide *)
  Hint Resolve pre_inc : core.
  Hint Resolve rely_inc : core.
  Hint Resolve guar_inc : core.
  (* end hide *)

  Notation "p <= q" := (lte_perm p q).

  Global Instance lte_perm_is_PreOrder : PreOrder lte_perm.
  Proof.
    constructor; [ constructor; auto | constructor; intros ]; eauto.
  Qed.

  (** Equality of permissions = the symmetric closure of the ordering. *)
  Definition eq_perm p q : Prop := p <= q /\ q <= p.

  Notation "p ≡≡ q" := (eq_perm p q) (at level 50).

  Lemma eq_perm_lte_1 : forall p q, p ≡≡ q -> p <= q.
  Proof. intros p q []. auto. Qed.
  Lemma eq_perm_lte_2 : forall p q, p ≡≡ q -> q <= p.
  Proof. intros p q []. auto. Qed.

  (* begin hide *)
  Hint Unfold eq_perm : core.
  Hint Resolve eq_perm_lte_1 : core.
  Hint Resolve eq_perm_lte_2 : core.
  (* end hide *)

  Global Instance Proper_eq_perm_rely :
    Proper (eq_perm ==> eq ==> eq ==> Basics.flip Basics.impl) rely.
  Proof.
    repeat intro. subst. apply H. auto.
  Qed.

  Global Instance Proper_eq_perm_guar :
    Proper (eq_perm ==> eq ==> eq ==> Basics.flip Basics.impl) guar.
  Proof.
    repeat intro. subst. apply H. auto.
  Qed.

  Global Instance Proper_eq_perm_pre :
    Proper (eq_perm ==> eq ==> Basics.flip Basics.impl) pre.
  Proof.
    repeat intro. subst. apply H. auto.
  Qed.

  Global Instance eq_perm_is_Equivalence : Equivalence eq_perm.
  Proof.
    constructor.
    - split; reflexivity.
    - intros x y []. split; auto.
    - intros x y z [] []. split; etransitivity; eauto.
  Qed.

  Global Instance Proper_eq_perm_lte_perm :
    Proper (eq_perm ==> eq_perm ==> Basics.flip Basics.impl) lte_perm.
  Proof.
    repeat intro. subst. etransitivity; eauto. etransitivity; eauto.
  Qed.

  (** Other lattice definitions. *)
  Program Definition bottom_perm : perm :=
    {|
    pre := fun x => True;
    rely := fun x y => True;
    guar := fun x y => x = y;
    |}.
  Next Obligation.
    constructor; repeat intro; subst; auto.
  Qed.

  Lemma bottom_perm_is_bottom : forall p, bottom_perm <= p.
  Proof.
    constructor; simpl; intros; subst; intuition.
  Qed.

  Program Definition top_perm : perm :=
    {|
    pre := fun x => False;
    rely := fun x y => x = y;
    guar := fun x y => True;
    |}.
  Next Obligation.
    constructor; repeat intro; subst; auto.
  Qed.

  Lemma top_perm_is_top : forall p, p <= top_perm.
  Proof.
    constructor; simpl; repeat intro; subst; intuition.
  Qed.

  Ltac respects := eapply pre_respects; eauto.

  Program Definition join_perm (p q: perm) : perm :=
    {|
    pre := fun x => pre p x /\ pre q x;
    rely := fun x y => rely p x y /\ rely q x y;
    guar  := clos_trans _ (fun x y => (guar p x y) \/ (guar q x y))
    |}.
  Next Obligation.
    constructor; repeat intro.
    - split; reflexivity.
    - destruct H. destruct H0. split; etransitivity; eauto.
  Qed.
  Next Obligation.
    constructor.
    - constructor; left; reflexivity.
    - repeat intro. destruct H, H0.
      + destruct H, H0; econstructor 2; constructor; eauto.
      + econstructor 2. left. apply H. econstructor 2; eauto.
      + econstructor 2; eauto. econstructor 2; eauto. left. assumption.
      + repeat (econstructor 2; eauto).
  Qed.
  Next Obligation.
    split; respects.
  Qed.

  Lemma lte_l_join_perm : forall p q,
      p <= join_perm p q.
  Proof.
    intros. constructor; simpl; auto.
    - intros ? [? _]. auto.
    - intros x y []; auto.
    - constructor; auto.
  Qed.

  Lemma lte_r_join_perm : forall p q,
      q <= join_perm p q.
  Proof.
    intros. constructor; simpl; auto.
    - intros ? [_ ?]. auto.
    - intros x y []; auto.
    - constructor; auto.
  Qed.

  Lemma join_perm_min : forall p q r,
      p <= r ->
      q <= r ->
      join_perm p q <= r.
  Proof.
    intros p q r [] []. constructor; intros; simpl; auto.
    - induction H; auto.
      + destruct H; auto.
      + transitivity y; auto.
  Qed.

  Lemma join_perm_commut' : forall p q,
      join_perm p q <= join_perm q p.
  Proof.
    constructor.
    - intros ? []. split; auto.
    - intros x y []. repeat split; auto.
    - intros. induction H.
      + destruct H; constructor; auto.
      + etransitivity; eauto.
  Qed.

  Lemma join_perm_commut : forall p q,
      join_perm p q ≡≡ join_perm q p.
  Proof.
    split; apply join_perm_commut'.
  Qed.

  Lemma join_perm_assoc : forall p q r,
      join_perm p (join_perm q r) ≡≡ join_perm (join_perm p q) r.
  Proof.
    split; intros.
    {
      constructor.
      - intros x [[? ?] ?]. split; [| split]; auto.
      - intros x y [[] ?].
        repeat split; auto.
      - intros. induction H; try solve [etransitivity; eauto].
        destruct H.
        + constructor. left. constructor. left. auto.
        + induction H; try solve [etransitivity; eauto].
          destruct H.
          * constructor. left. constructor. right. auto.
          * constructor. right. auto.
    }
    {
      constructor.
      - intros x [? [? ?]]. split; [split |]; auto.
      - intros x y [? []].
        repeat split; auto.
      - intros. induction H; try solve [etransitivity; eauto].
        destruct H.
        + induction H; try solve [etransitivity; eauto].
          destruct H.
          * constructor. left. auto.
          * constructor. right. constructor. left. auto.
        + constructor. right. constructor. right. auto.
    }
  Qed.

  Lemma join_perm_idem : forall p, join_perm p p ≡≡ p.
  Proof.
    split; intros.
    - constructor; intros.
      + split; auto.
      + repeat split; auto.
      + induction H; try solve [etransitivity; eauto].
        destruct H; auto.
    - constructor.
      + intros ? [? _]; auto.
      + intros x y []. auto.
      + constructor. auto.
  Qed.

  Definition meet_rely p q := clos_trans _ (fun x y => (rely p x y) \/ (rely q x y)).

  Program Definition meet_perm (p q:perm) : perm :=
    {|
    pre := fun x => pre p x \/ pre q x \/ exists y, (pre p y \/ pre q y) /\ meet_rely p q y x;
    rely := meet_rely p q;
    guar  := fun x y => guar p x y /\ guar q x y;
    |}.
  Next Obligation.
    constructor; repeat intro.
    - constructor. left. reflexivity.
    - econstructor 2; eauto.
  Qed.
  Next Obligation.
    constructor.
    - constructor; reflexivity.
    - intros x y z [] []. split; etransitivity; eauto.
  Qed.
  Next Obligation.
    induction H; auto.
    destruct H0 as [? | [? | [z [? ?]]]].
    - destruct H; try solve [left; respects].
      right; right. exists x. split; auto. constructor 1. auto.
    - destruct H; try solve [right; left; respects].
      right; right. exists x. split; auto. constructor 1. auto.
    - destruct H; right; right; exists z; split; auto;
        econstructor 2; eauto; constructor 1; auto.
  Qed.

  Lemma lte_meet_perm_l : forall p q,
      meet_perm p q <= p.
  Proof.
    intros. constructor; simpl; auto.
    - left; auto.
    - intros x y []; auto.
  Qed.
  Lemma lte_meet_perm_r : forall p q,
      meet_perm p q <= q.
  Proof.
    intros. constructor; simpl; auto.
    - left; auto.
    - intros x y []; auto.
  Qed.
  Lemma meet_perm_max : forall p q r,
      r <= p ->
      r <= q ->
      r <= meet_perm p q.
  Proof.
    intros p q r [] []. constructor; intros; simpl; auto.
    - simpl in H. destruct H as [? | [? | [? [? ?]]]]; auto.
      induction H0.
      + destruct H, H0; respects.
      + apply IHclos_trans1 in H.
        clear IHclos_trans1 IHclos_trans2 H0_.
        induction H0_0; auto.
        destruct H0; respects.
    - induction H.
      + destruct H; auto.
      + etransitivity; eauto.
  Qed.

(* Lemma meet_perm_commut: forall p q, meet_perm p q ≡ meet_perm q p. *)
(* Proof. *)
(*   split; intros. *)
(*   - constructor; intros. *)
(*     + destruct H as [? [? ?]]. *)
(*     + induction H. *)
(*       * destruct H; constructor; auto. *)
(*       * etransitivity; eauto. *)
(*     + destruct H. constructor; auto. *)
(*   - constructor; intros. *)
(*     + induction H. *)
(*       * destruct H; constructor; auto. *)
(*       * etransitivity; eauto. *)
(*     + destruct H. constructor; auto. *)
(* Qed. *)

(* Lemma meet_perm_assoc : forall p q r, *)
(*     eq_perm (meet_perm p (meet_perm q r)) (meet_perm (meet_perm p q) r). *)
(* Proof. *)
(*   split; intros. *)
(*   - constructor; intros. *)
(*     + induction H; try solve [etransitivity; eauto]. *)
(*       destruct H. *)
(*       * induction H; try solve [etransitivity; eauto]. *)
(*         destruct H. *)
(*         -- constructor. left. auto. *)
(*         -- constructor. right. constructor. left. auto. *)
(*       * constructor. right. constructor. right. auto. *)
(*     + destruct H as [? [? ?]]. *)
(*       constructor; auto. constructor; auto. *)
(*   - constructor; intros. *)
(*     + induction H; try solve [etransitivity; eauto]. *)
(*       destruct H. *)
(*       * constructor. left. constructor. left. auto. *)
(*       * induction H; try solve [etransitivity; eauto]. *)
(*         destruct H. *)
(*         -- constructor. left. constructor. right. auto. *)
(*         -- constructor. right. auto. *)
(*     + destruct H as [[? ?] ?]. *)
(*       constructor; auto. constructor; auto. *)
(* Qed. *)

(* Lemma meet_perm_idem : forall p, eq_perm (meet_perm p p) p. *)
(* Proof. *)
(*   split; intros. *)
(*   - constructor; intros. *)
(*     + constructor. left. auto. *)
(*     + destruct H; auto. *)
(*   - constructor; intros. *)
(*     + induction H; try solve [etransitivity; eauto]. *)
(*       destruct H; auto. *)
(*     + constructor; auto. *)
(* Qed. *)

(* Lemma join_perm_absorb : forall p q, eq_perm (join_perm p (meet_perm p q)) p. *)
(* Proof. *)
(*   split; intros. *)
(*   - constructor; intros. *)
(*     + constructor; auto. constructor; auto. *)
(*     + induction H; try solve [etransitivity; eauto]. *)
(*       destruct H; auto. destruct H; auto. *)
(*   - constructor; intros. *)
(*     + destruct H. auto. *)
(*     + constructor. left. auto. *)
(* Qed. *)

(* Lemma meet_perm_absorb : forall p q, eq_perm (meet_perm p (join_perm p q)) p. *)
(* Proof. *)
(*   split; intros. *)
(*   - constructor; intros. *)
(*     + constructor. left. auto. *)
(*     + destruct H. auto. *)
(*   - constructor; intros. *)
(*     + induction H; try solve [etransitivity; eauto]. *)
(*       destruct H; auto. destruct H; auto. *)
(*     + constructor; auto. constructor; auto. *)
(* Qed. *)
  (** ** Separate permissions *)
  Record separate (p q : perm) : Prop :=
    {
    sep_l: forall x y, guar q x y -> rely p x y;
    sep_r: forall x y, guar p x y -> rely q x y;
    }.

  Notation "p ⊥ q" := (separate p q) (at level 50).

  Global Instance separate_symmetric: Symmetric separate.
  Proof.
    intros p q []. constructor; auto.
  Qed.

  Lemma separate_bottom : forall p, p ⊥ bottom_perm.
  Proof.
    constructor; intros; simpl; auto.
    inversion H. reflexivity.
  Qed.

  (* Definition copyable p := forall x y, guar p x y -> rely p x y. *)

  (* Lemma copyable_separate : forall p, copyable p -> p ⊥ p. *)
  (* Proof. *)
  (*   intros. red in H. split; auto. *)
  (* Qed. *)

  (** We can always weaken permissions and retain separateness. *)
  Lemma separate_antimonotone : forall p q r, p ⊥ q -> r <= q -> p ⊥ r.
  Proof.
    intros. constructor.
    - intros. apply H; auto. apply H0; auto.
    - intros. apply H0. apply H; auto.
  Qed.

  Global Instance Proper_eq_perm_separate :
    Proper (eq_perm ==> eq_perm ==> Basics.flip Basics.impl) separate.
  Proof.
    repeat intro.
    eapply separate_antimonotone; eauto. symmetry.
    eapply separate_antimonotone; eauto. symmetry. auto.
  Qed.

  (** ** Separating conjunction for permissions *)
  Program Definition sep_conj_perm (p q: perm) : perm :=
    {|
    pre := fun x => pre p x /\ pre q x /\ p ⊥ q;
    rely := fun x y => rely p x y /\ rely q x y;
    guar := clos_trans _ (fun x y => (guar p x y) \/ (guar q x y))
    |}.
  Next Obligation.
    constructor; repeat intro.
    - split; reflexivity.
    - destruct H, H0.
      split; etransitivity; eauto.
  Qed.
  Next Obligation.
    constructor.
    - constructor; intuition.
    - repeat intro. destruct H, H0.
      + destruct H, H0; econstructor 2; constructor; eauto.
      + econstructor 2. left. apply H. econstructor 2; eauto.
      + econstructor 2; eauto. econstructor 2; eauto. left. assumption.
      + repeat (econstructor 2; eauto).
  Qed.
  Next Obligation.
    split; [respects | split; [respects | auto]].
  Qed.
  Notation "p ** q" := (sep_conj_perm p q) (at level 40).

  Lemma sep_conj_join : forall p q, p ⊥ q -> p ** q ≡≡ join_perm p q.
  Proof.
    split; intros.
    - constructor; auto; intros x []; split; auto.
    - constructor; auto; intros x [? [? ?]]; split; auto.
  Qed.

  Lemma lte_l_sep_conj_perm : forall p q, p <= p ** q.
  Proof.
    intros. constructor; simpl; auto.
    - intros x []; auto.
    - intros x y []; auto.
    - constructor; auto.
  Qed.

  Lemma lte_r_sep_conj_perm : forall p q, q <= p ** q.
  Proof.
    intros. constructor; simpl; auto.
    - intros x [? [? ?]]; auto.
    - intros x y []; auto.
    - constructor; auto.
  Qed.

  Lemma sep_conj_perm_monotone : forall p p' q q',
      p' <= p -> q' <= q -> p' ** q' <= p ** q.
  Proof.
    constructor; intros; simpl.
    - destruct H1 as [? [? ?]]; split; [| split]; eauto.
      eapply separate_antimonotone; eauto.
      symmetry. symmetry in H3. eapply separate_antimonotone; eauto.
    - split.
      + apply H. apply H1.
      + apply H0. apply H1.
    - induction H1.
      + constructor. destruct H1; eauto.
      + econstructor 2; eauto.
  Qed.

  Global Instance Proper_eq_perm_sep_conj_perm :
    Proper (eq_perm ==> eq_perm ==> eq_perm) sep_conj_perm.
  Proof.
    repeat intro. split; apply sep_conj_perm_monotone; auto.
  Qed.

  Lemma sep_conj_perm_bottom' : forall p, p ** bottom_perm <= p.
  Proof.
    constructor; intros.
    - split; [| split]; simpl; intuition. apply separate_bottom.
    - repeat split; auto.
    - induction H.
      + destruct H; auto. inversion H. reflexivity.
      + etransitivity; eauto.
  Qed.

  Lemma sep_conj_perm_bottom : forall p, p ** bottom_perm ≡≡ p.
  Proof.
    split; [apply sep_conj_perm_bottom' | apply lte_l_sep_conj_perm].
  Qed.

  Lemma sep_conj_perm_top' : forall p, p ** top_perm <= top_perm.
  Proof.
    constructor; intros; simpl in *; intuition.
    subst. reflexivity.
  Qed.

  Lemma sep_conj_perm_top : forall p, top_perm ≡≡ p ** top_perm.
  Proof.
    split; [apply lte_r_sep_conj_perm | apply sep_conj_perm_top'].
  Qed.

  Lemma sep_conj_perm_commut' : forall p q, p ** q <= q ** p.
  Proof.
    constructor.
    - intros x [? [? ?]]; simpl; split; [| split]; intuition.
    - intros x y []; repeat split; auto.
    - intros. induction H.
      + destruct H; constructor; auto.
      + etransitivity; eauto.
  Qed.

  Lemma sep_conj_perm_commut : forall p q, p ** q ≡≡ q ** p.
  Proof.
    split; apply sep_conj_perm_commut'.
  Qed.

  Lemma separate_sep_conj_perm_l: forall p q r, p ⊥ q ** r -> p ⊥ q.
  Proof.
    intros. destruct H. constructor; intros.
    - apply sep_l0. constructor. left. auto.
    - apply sep_r0. auto.
  Qed.
  Lemma separate_sep_conj_perm_r: forall p q r, p ⊥ q ** r -> p ⊥ r.
  Proof.
    intros. destruct H. constructor; intros.
    - apply sep_l0. constructor. right. auto.
    - apply sep_r0. auto.
  Qed.
  Lemma separate_sep_conj_perm: forall p q r, p ⊥ q ->
                                         p ⊥ r ->
                                         r ⊥ q ->
                                         p ⊥ q ** r.
  Proof.
    intros. constructor; intros.
    - induction H2.
      + destruct H2; [apply H | apply H0]; auto.
      + etransitivity; eauto.
    - split; [apply H | apply H0]; auto.
  Qed.

  Lemma sep_conj_perm_assoc : forall p q r,
      (p ** q) ** r ≡≡ p ** (q ** r).
  Proof.
    split; intros.
    {
      constructor.
      - intros x [? [[? [? ?]] ?]].
        pose proof (separate_sep_conj_perm_l _ _ _ H3).
        pose proof (separate_sep_conj_perm_r _ _ _ H3).
        split; [split; [| split] | split]; auto.
        symmetry. apply separate_sep_conj_perm; symmetry; auto.
      - intros x y [? [? ?]]. split; [split |]; auto.
      - intros. induction H; try solve [etransitivity; eauto].
        destruct H.
        + induction H; try solve [etransitivity; eauto].
          destruct H.
          * constructor. left. auto.
          * constructor. right. constructor. left. auto.
        + constructor. right. constructor. right. auto.
    }
    {
      constructor.
      - intros x [[? [? ?]] [? ?]]. symmetry in H3.
        pose proof (separate_sep_conj_perm_l _ _ _ H3). symmetry in H4.
        pose proof (separate_sep_conj_perm_r _ _ _ H3). symmetry in H5.
        split; [| split; [split; [| split] |]]; auto.
        apply separate_sep_conj_perm; auto. symmetry; auto.
      - intros x y [[? ?] ?]; simpl; auto.
      - intros. induction H; try solve [etransitivity; eauto].
        destruct H.
        + constructor. left. constructor. left. auto.
        + induction H; try solve [etransitivity; eauto].
          destruct H.
          * constructor. left. constructor. right. auto.
          * constructor. right. auto.
    }
  Qed.

  (** * Permission sets *)
  (** Perms = upwards-closed sets of permissions *)
  Record Perms :=
    {
    in_Perms : perm -> Prop;
    Perms_upwards_closed : forall p1 p2, in_Perms p1 -> p1 <= p2 -> in_Perms p2
    }.
  Notation "p ∈ P" := (in_Perms P p) (at level 60).

  (** ** Permission set ordering *)
  (** Defined as superset. *)
  Definition lte_Perms (P Q : Perms) : Prop :=
    forall p, p ∈ Q -> p ∈ P.
  Notation "P ⊑ Q" := (lte_Perms P Q) (at level 60).

  Global Instance lte_Perms_is_preorder : PreOrder lte_Perms.
  Proof.
    constructor; repeat intro; auto.
  Qed.

  (** Various lattice definitions. *)
  Program Definition top_Perms : Perms :=
    {|
    in_Perms := fun r => False
    |}.

  Lemma top_Perms_is_top : forall P, P ⊑ top_Perms.
  Proof.
    repeat intro. inversion H.
  Qed.

  Program Definition bottom_Perms : Perms :=
    {|
    in_Perms := fun r => True
    |}.

  Lemma bottom_Perms_is_bottom : forall P, bottom_Perms ⊑ P.
  Proof.
    repeat intro. simpl. auto.
  Qed.

  (** The least Perms set containing a given p *)
  Program Definition singleton_Perms p1 : Perms :=
    {|
    in_Perms := fun p2 => p1 <= p2
    |}.
  Next Obligation.
    etransitivity; eassumption.
  Qed.

  Program Definition join_Perms (Ps : Perms -> Prop) : Perms :=
    {|
    in_Perms := fun p => forall P, Ps P -> p ∈ P
    |}.
  Next Obligation.
    eapply Perms_upwards_closed; eauto.
  Qed.
  Lemma lte_join_Perms : forall (Ps : Perms -> Prop) P,
      Ps P ->
      P ⊑ join_Perms Ps.
  Proof.
    repeat intro. apply H0. auto.
  Qed.
  Lemma join_Perms_min : forall (Ps : Perms -> Prop) Q,
      (forall P, Ps P -> P ⊑ Q) ->
      join_Perms Ps ⊑ Q.
  Proof.
    repeat intro.
    eapply H; eauto.
  Qed.

  (** Complete meet of Perms sets = union *)
  Program Definition meet_Perms (Ps : Perms -> Prop) : Perms :=
    {|
    in_Perms := fun p => exists P, Ps P /\ p ∈ P
    |}.
  Next Obligation.
    exists H. split; auto.
    apply (Perms_upwards_closed _ p1); assumption.
  Qed.

  Lemma lte_meet_Perms : forall (Ps : Perms -> Prop) P,
      Ps P ->
      meet_Perms Ps ⊑ P.
  Proof.
    repeat intro. exists P. auto.
  Qed.

  Lemma meet_Perms_max : forall (Ps : Perms -> Prop) Q,
      (forall P, Ps P -> Q ⊑ P) ->
      Q ⊑ meet_Perms Ps.
  Proof.
    repeat intro. destruct H0 as [? [? ?]].
    eapply H; eauto.
  Qed.

  Definition meet_Perms2 P Q : Perms := meet_Perms (fun R => R = P \/ R = Q).

  (** Set equality *)
  Definition eq_Perms (P Q : Perms) : Prop := P ⊑ Q /\ Q ⊑ P.
  Notation "P ≡ Q" := (eq_Perms P Q) (at level 60).

  Global Instance Equivalence_eq_Perms : Equivalence eq_Perms.
  Proof.
    constructor; repeat intro.
    - split; reflexivity.
    - destruct H; split; auto.
    - destruct H, H0. split; etransitivity; eauto.
  Qed.

  Global Instance Proper_eq_Perms_lte_Perms :
    Proper (eq_Perms ==> eq_Perms ==> Basics.flip Basics.impl) lte_Perms.
  Proof.
    do 5 red. intros. etransitivity. apply H. etransitivity. apply H1. apply H0.
  Qed.

  Global Instance Proper_eq_Perms_eq_perm_in_Perms : Proper (eq_Perms ==> eq_perm ==> Basics.flip Basics.impl) in_Perms.
  Proof.
    repeat intro; subst. apply H. eapply Perms_upwards_closed; eauto.
  Qed.

  (** ** Separating conjunction for permission sets *)
  Program Definition sep_conj_Perms (P Q : Perms) : Perms :=
    {|
    in_Perms := fun r => exists p q, p ∈ P /\ q ∈ Q /\ p ** q <= r
    |}.
  Next Obligation.
    exists H, H1. split; [| split]; auto. etransitivity; eauto.
  Qed.
  Notation "P * Q" := (sep_conj_Perms P Q).

  Lemma lte_l_sep_conj_Perms : forall P Q, P ⊑ P * Q.
  Proof.
    intros P Q p' ?. destruct H as [p [q [? [? ?]]]].
    eapply Perms_upwards_closed; eauto.
    etransitivity; eauto. apply lte_l_sep_conj_perm.
  Qed.

  Lemma lte_r_sep_conj_Perms : forall P Q, Q ⊑ P * Q.
  Proof.
    intros P Q q' ?. destruct H as [p [q [? [? ?]]]].
    eapply Perms_upwards_closed; eauto.
    etransitivity; eauto. apply lte_r_sep_conj_perm.
  Qed.

  Lemma sep_conj_Perms_bottom_identity : forall P, bottom_Perms * P ≡ P.
  Proof.
    constructor; repeat intro.
    - exists bottom_perm, p. split; simpl; [auto | split; auto].
      rewrite sep_conj_perm_commut. apply sep_conj_perm_bottom.
    - destruct H as [? [? [_ [? ?]]]].
      eapply (Perms_upwards_closed P); eauto.
      etransitivity; eauto. apply lte_r_sep_conj_perm.
  Qed.

  Lemma sep_conj_Perms_top_absorb : forall P, top_Perms * P ≡ top_Perms.
  Proof.
    constructor; repeat intro.
    - inversion H.
    - destruct H as [? [_ [[] _]]].
  Qed.

  Lemma sep_conj_Perms_monotone : forall P P' Q Q', P' ⊑ P -> Q' ⊑ Q -> P' * Q' ⊑ P * Q.
  Proof.
    repeat intro. destruct H1 as [? [? [? [? ?]]]].
    exists x, x0. auto.
  Qed.

  Lemma sep_conj_Perms_perm: forall P Q p q,
      p ∈ P ->
      q ∈ Q ->
      p ** q ∈ P * Q.
  Proof.
    intros. exists p, q. split; auto. split; auto. reflexivity.
  Qed.

  Lemma sep_conj_Perms_commut : forall P Q, P * Q ≡ Q * P.
  Proof.
    split; repeat intro.
    - destruct H as [q [p' [? [? ?]]]].
      exists p', q. split; [| split]; auto. etransitivity; eauto. apply sep_conj_perm_commut.
    - destruct H as [p' [q [? [? ?]]]].
      exists q, p'. split; [| split]; auto. etransitivity; eauto. apply sep_conj_perm_commut.
  Qed.

  Lemma sep_conj_Perms_assoc : forall P Q R, P * (Q * R) ≡ (P * Q) * R.
  Proof.
    split; repeat intro.
    - rename p into p'. destruct H as [pq [r [? [? ?]]]].
      destruct H as [p [q [? [? ?]]]].
      exists p, (q ** r).
      split; auto. split; auto. apply sep_conj_Perms_perm; auto.
      rewrite <- sep_conj_perm_assoc.
      etransitivity; eauto.
      apply sep_conj_perm_monotone; intuition.
    - rename p into p'. destruct H as [p [qr [? [? ?]]]].
      destruct H0 as [q [r [? [? ?]]]].
      exists (p ** q), r.
      split; auto. apply sep_conj_Perms_perm; auto. split; auto.
      rewrite sep_conj_perm_assoc.
      etransitivity; eauto.
      apply sep_conj_perm_monotone; intuition.
  Qed.

  Lemma sep_conj_Perms_meet_commute : forall (Ps : Perms -> Prop) P,
      (meet_Perms Ps) * P ≡ meet_Perms (fun Q => exists P', Q = P' * P /\ Ps P').
  Proof.
    split; repeat intro.
    - destruct H as [? [[Q [? ?]] ?]].
      subst. destruct H1 as [? [? [? [? ?]]]].
      simpl. exists x, x0. split; [ | split]; auto.
      eexists; split; eauto.
    - destruct H as [? [? [[Q [? ?]] [? ?]]]].
      simpl. eexists. split.
      + exists Q. split; auto.
      + eapply Perms_upwards_closed; eauto.
        simpl. exists x, x0. split; [auto | split; [auto | ]]. reflexivity.
  Qed.

  (** Permission entailment, which we sometimes use instead of ordering. *)
  Definition entails_Perms P Q := Q ⊑ P.
  Notation "P ⊨ Q" := (entails_Perms P Q) (at level 60).

  Global Instance entails_Perms_preorder : PreOrder entails_Perms.
  Proof.
    constructor; repeat intro; auto.
  Qed.

  Global Instance Proper_eq_Perms_entails_Perms :
    Proper (eq_Perms ==> eq_Perms ==> Basics.flip Basics.impl) entails_Perms.
  Proof.
    do 6 red. intros. rewrite H. rewrite H0. auto.
  Qed.

  Global Instance Proper_eq_Perms_sep_conj_Perms :
    Proper (eq_Perms ==> eq_Perms ==> eq_Perms) sep_conj_Perms.
  Proof.
    repeat intro. etransitivity.
    - split; eapply sep_conj_Perms_monotone; try eapply H0; try eapply H.
    - split; eapply sep_conj_Perms_monotone; try eapply H0; try eapply H; reflexivity.
  Qed.

  (** Separating implication, though we won't be using it. *)
  Definition impl_Perms P Q := meet_Perms (fun R => R * P ⊨ Q).

  (** A standard property about separating conjunction and implication. *)
  Lemma adjunction : forall P Q R, P * Q ⊨ R <-> P ⊨ (impl_Perms Q R).
  Proof.
    intros. split; intros.
    - red. red. intros. simpl. exists P. auto.
    - apply (sep_conj_Perms_monotone _ _ Q Q) in H; intuition.
      red. etransitivity; [ | apply H ].
      unfold impl_Perms.
      rewrite sep_conj_Perms_meet_commute.
      apply meet_Perms_max. intros P' [? [? ?]]. subst. auto.
  Qed.

  (* (** * TODO: least fixpoints? *) *)
  (* (** The meet of a TODO *) *)
  (* Program Definition meet_A_Perms {A} (Ps : (A -> Perms) -> Prop) : A -> Perms := *)
  (*   fun a => *)
  (*     {| *)
  (*       in_Perms := fun p => exists P, Ps P /\ p ∈ P a *)
  (*     |}. *)
  (* Next Obligation. *)
  (*   exists H. split; auto. *)
  (*   apply (Perms_upwards_closed _ p1); assumption. *)
  (* Qed. *)

  (* Notation "P -⊑- Q" := (forall a, P a ⊑ Q a) (at level 60). *)
  (* Notation "P -≡- Q" := (P -⊑- Q /\ Q -⊑- P) (at level 60). *)

  (* Lemma lte_meet_A_Perms {A} : forall (Ps : (A -> Perms) -> Prop) P, *)
  (*     Ps P -> *)
  (*     meet_A_Perms Ps -⊑- P. *)
  (* Proof. *)
  (*   repeat intro. exists P. auto. *)
  (* Qed. *)

  (* Lemma meet_A_Perms_max {A} : forall (Ps : (A -> Perms) -> Prop) Q, *)
  (*     (forall P, Ps P -> Q -⊑- P) -> *)
  (*     Q -⊑- meet_A_Perms Ps. *)
  (* Proof. *)
  (*   repeat intro. destruct H0 as [? [? ?]]. *)
  (*   eapply H; eauto. *)
  (* Qed. *)

  (* Definition μ {A : Type} *)
  (*            (F : (A -> Perms) -> A -> Perms) *)
  (*            (Hmon: forall P Q, (P -⊑- Q) -> (F P -⊑- F Q)) : A -> Perms := *)
  (*   meet_A_Perms (fun P => F P -⊑- P). *)

  (* Lemma μ_fixedpoint {A} : forall (F : (A -> Perms) -> A -> Perms) Hmon, *)
  (*     F (μ F Hmon) -≡- (μ F Hmon). *)
  (* Proof. *)
  (*   intros. assert (F (μ F Hmon) -⊑- μ F Hmon). *)
  (*   { *)
  (*     unfold μ. repeat intro. destruct H as (P & ? & ?). *)
  (*     eapply Hmon. 2: { apply H. assumption. } *)
  (*     repeat intro. eexists. split; eauto. *)
  (*   } *)
  (*   split; auto. *)
  (*   unfold μ. repeat intro. simpl. eexists. split. 2: eauto. *)
  (*   apply Hmon. apply H. *)
  (* Qed. *)

  (* Lemma μ_least {A} : forall (F : (A -> Perms) -> A -> Perms) Hmon X, *)
  (*     F X -≡- X -> *)
  (*     μ F Hmon -⊑- X. *)
  (* Proof. *)
  (*   intros. unfold μ. apply lte_meet_A_Perms. apply H. *)
  (* Qed. *)

  (* Lemma μ_induction {A} F (P : A -> Perms) Hmon : *)
  (*   (forall a, F P a ⊑ P a) -> *)
  (*   (forall a, μ F Hmon a ⊑ P a). *)
  (* Proof. *)
  (*   intros Hlte a p Hp. *)
  (*   eexists. split; eauto. *)
  (* Qed. *)
End Permissions.

(* begin hide *)
(* Redefining notations outside the section. *)
Notation "p <= q" := (lte_perm p q).
Notation "p ≡≡ q" := (eq_perm p q) (at level 50).
Notation "p ⊥ q" := (separate p q) (at level 50).
Notation "p ** q" := (sep_conj_perm p q) (at level 40).
Notation "p ∈ P" := (in_Perms P p) (at level 60).
Notation "P ⊑ Q" := (lte_Perms P Q) (at level 60).
Notation "P ≡ Q" := (eq_Perms P Q) (at level 60).
Notation "P * Q" := (sep_conj_Perms P Q).
Notation "P ⊨ Q" := (entails_Perms P Q) (at level 60).
Notation "P -⊑- Q" := (forall a, P a ⊑ Q a) (at level 60).
Notation "P -≡- Q" := (P -⊑- Q /\ Q -⊑- P) (at level 60).

Ltac respects := eapply pre_respects; eauto.

#[ export ] Hint Unfold rely : core.
#[ export ] Hint Unfold pre : core.
#[ export ] Hint Unfold guar : core.
#[ export ] Hint Resolve pre_respects : core.
#[ export ] Hint Resolve pre_inc : core.
#[ export ] Hint Resolve rely_inc : core.
#[ export ] Hint Resolve guar_inc : core.
#[ export ] Hint Unfold eq_perm : core.
#[ export ] Hint Resolve eq_perm_lte_1 : core.
#[ export ] Hint Resolve eq_perm_lte_2 : core.

(* end hide *)


Require Import List Lia.
Import ListNotations.

Require Import Undecidability.CFG.CFP.
Require Import Undecidability.CFG.Util.Facts.

Require Import Undecidability.PCP.PCP.
Require Import Undecidability.PCP.Util.Facts.
Import PCPListNotation.
Require Import Undecidability.PCP.Util.PCP_facts.
Require Import Undecidability.Synthetic.Definitions.

Set Default Goal Selector "!".

Local Hint Rewrite <- app_assoc : list.
Local Hint Rewrite rev_app_distr : list.
Local Hint Resolve in_eq in_or_app incl_nil_l : core.

(* * PCP to CFPI *)
Section PCP_CFPI.

  Variable P : stack nat.

  Definition Sigma := sym P.
  Notation "#" := (fresh Sigma).

  Definition gamma1 (A : stack nat) :=
    map (fun '(x, y) => (x, (x ++ [#] ++ y ++ [#]))) A.
  Definition gamma2 (A : stack nat) :=
    map (fun '(x, y) => (y, (x ++ [#] ++ y ++ [#]))) A.
  Fixpoint gamma (A : stack nat) :=
    match A with
    | [] => []
    | (x, y) :: A => gamma A ++ x ++ [#] ++ y ++ [#]
    end.

  Lemma sigma_gamma1 A :
    sigma # (gamma1 A) = tau1 A ++ [#] ++ gamma A.
  Proof.
    induction A as [ | (x,y) ] ; cbn.
    - reflexivity.
    - unfold gamma1 in IHA. cbn in *.
      rewrite IHA. now simpl_list.
  Qed.

  Lemma sigma_gamma2 A :
    sigma # (gamma2 A) = tau2 A ++ [#] ++ gamma A.
  Proof.
    induction A as [ | (x,y) ] ; cbn.
    - reflexivity.
    - unfold gamma2 in IHA. cbn in *.
      rewrite IHA. now simpl_list.
  Qed.

  Lemma gamma1_spec B C :
    B <<= gamma1 C ->
    exists A, A <<= C /\ gamma1 A = B.
  Proof.
    induction B as [ | (x,y)]; cbn; intros.
    - eauto.
    - assert ((x, y) el gamma1 C) by firstorder. unfold gamma1 in H0.
      eapply in_map_iff in H0 as ((x',y') & ? & ?). inv H0.
      assert (B <<= gamma1 C) as (A & Hi & He) % IHB by firstorder.
      exists ((x, y') :: A). split.
      + auto with datatypes.
      + now subst.
  Qed.

  Lemma gamma2_spec B C :
    B <<= gamma2 C ->
    exists A, A <<= C /\ gamma2 A = B.
  Proof.
    induction B as [ | (x,y)]; cbn; intros.
    - eauto.
    - assert ((x, y) el gamma2 C) by firstorder. unfold gamma2 in H0.
      eapply in_map_iff in H0 as ((x',y') & ? & ?). inv H0.
      assert (B <<= gamma2 C) as (A & Hi & He) % IHB by firstorder.
      exists ((x', x) :: A). split.
      + auto with datatypes.
      + now subst.
  Qed.

  Lemma gamma_inj A1 A2 :
    ~ # el sym A1 -> ~ # el sym A2 ->
    gamma A1 = gamma A2 -> A1 = A2.
  Proof.
    intros H.
    revert A2. induction A1 as [ | (x,y) ]; cbn; intros.
    - destruct A2 as [ | c A2 ]; inv H1; [reflexivity|].
      destruct c, (gamma A2), l; cbn in *; inv H3.
    - destruct A2 as [ | (x',y')]; cbn in H1.
      + destruct (gamma A1), x; inv H1.
      + eapply (f_equal (@rev _)) in H1. repeat (autorewrite with list in H1; cbn in H1). inv H1.
        eapply list_prefix_inv in H3 as [].
        { rewrite rev_eq in H1. subst. assert (x = x').
        * destruct A1 as [ | (x1, y1)], A2 as [ | (x2, y2)]; repeat (cbn in *; autorewrite with list in H2).
          -- rewrite rev_eq in H2. congruence.
          -- exfalso. enough (~ # el rev x). { eapply H1. rewrite H2.
             cbn. simpl_list. cbn. eauto. }
             intros ? % In_rev; eauto.
          -- exfalso. enough (~ # el rev x'). { eapply H1. rewrite <- H2.
             cbn. simpl_list. cbn. eauto. }
             intros ? % In_rev; eauto.
          -- eapply list_prefix_inv in H2 as [].
             --- rewrite rev_eq in H1. congruence.
             --- intros ? % In_rev; eauto.
             --- intros ? % In_rev; eauto.
        * subst. f_equal. eapply app_inv_head in H2. rewrite rev_eq in H2.
          eapply IHA1 in H2; eauto.
          -- intros ?. eapply H. cbn. eauto.
          -- intros ?. eapply H0. cbn. eauto. }
        * intros ? % In_rev. eapply H. cbn. eauto.
        * intros ? % In_rev. eapply H0. cbn. eauto.
  Qed.

End PCP_CFPI.

Theorem reduction :
  PCP ⪯ CFPI.
Proof.
  exists (fun P => (gamma1 P P, gamma2 P P, fresh (sym P))). intros P.
  split.
  - intros (A & Hi & He & H). exists (gamma1 P A), (gamma2 P A). repeat split.
    + clear He H. induction A as [ | [] ]. { firstorder. } intros ? [ <- | ].
      { unfold gamma1. eapply in_map_iff. eexists (_, _). firstorder. } firstorder.
    + clear He H. induction A as [ | [] ]. { firstorder. } intros ? [ <- | ].
      { unfold gamma2. eapply in_map_iff. eexists (_, _). firstorder. } firstorder.
    + destruct A; cbn in *; congruence.
    + destruct A; cbn in *; congruence.
    + now rewrite sigma_gamma1, sigma_gamma2, H.
  - intros (B1 & B2 & (A1 & Hi1 & <-) % gamma1_spec & (A2 & Hi2 & <-) % gamma2_spec & He1 & He2 & H).
    rewrite sigma_gamma1, sigma_gamma2 in H.
    eapply list_prefix_inv in H as [H1 <- % gamma_inj].
    + exists A1. firstorder. destruct A1; cbn in *; firstorder congruence.
    + intros ?. eapply sym_mono in Hi1. eapply Hi1 in H0 as ? % fresh_spec. now apply H0.
    + intros ?. eapply sym_mono in Hi2. eapply Hi2 in H0 as ? % fresh_spec. now apply H0.
    + intros ? % tau1_sym. eapply sym_mono in Hi1. eapply Hi1 in H0 as ? % fresh_spec. now apply H0.
    + intros ? % tau2_sym. eapply sym_mono in Hi2. eapply Hi2 in H0 as ? % fresh_spec. now apply H0.
Qed.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Functor Functor.Functor_Ops.
From Categories Require Import Basic_Cons.Terminal.
From Categories Require Import Cat.Cat Cat.Cat_Iso.

(** In this section we show that if a category C has a terminal object and D is
a category isomorphic to C, then D also has a terminal object. *)
Section Term_IsoCat.
  Context {C D : Category}
          (I : (C ≃≃ D ::> Cat)%isomorphism) (trm : (𝟙_ C)%object).

  Program Definition Term_IsoCat : (𝟙_ D)%object
    :=
      {|
        terminal := ((iso_morphism I) _o)%object trm;
        t_morph :=
          fun c =>
            match
              f_equal (fun w : (D –≻ D)%functor => (w _o)%object c)
                      (right_inverse I)
              in _ = u return
              (u –≻ _)%morphism
            with
              eq_refl => ((iso_morphism I) _a ((t_morph
                                                 trm ((I⁻¹)%morphism _o c)))
                        )%morphism
            end;
        t_morph_unique :=
          fun c f g => _
      |}
  .

  Next Obligation.
  Proof.
    assert (H := f_equal
                   (fun w : (C –≻ C)%functor => (w _o)%object (terminal trm))
                   (left_inverse I)).
    cbn in H.
    cut (
        match H in _ = u return
              (_ –≻ u)%morphism
        with
        | eq_refl => ((I ⁻¹) _a f)%morphism
        end
        =
        match H in _ = u return
              (_ –≻ u)%morphism
        with
        | eq_refl => ((I ⁻¹) _a g)%morphism
        end
    ).
    {
      intros H2.
      destruct H.
      match type of H2 with
        ?A = ?B =>
        assert (((iso_morphism I) _a A) = ((iso_morphism I) _a B))%morphism
          by (rewrite H2; trivial)
      end.
      rewrite <- (Cat_Iso_conv_inv_I_inv_I (Inverse_Isomorphism I) f).
      rewrite <- (Cat_Iso_conv_inv_I_inv_I (Inverse_Isomorphism I) g).
      apply f_equal.
      trivial.
    }
    {
      apply t_morph_unique.
    }
  Qed.

End Term_IsoCat.


(* -*- mode: coq; mode: visual-line -*-  *)

Require Import Basics.Overture Basics.Tactics.
Require Import WildCat.Core.
Require Import WildCat.Equiv.
Require Import WildCat.Induced.
Require Import WildCat.NatTrans.

(** * Wild functor categories *)

(** ** Categories of 0-coherent 1-functors *)

Record Fun01 (A B : Type) `{IsGraph A} `{IsGraph B} := {
  fun01_F : A -> B;
  fun01_is0functor : Is0Functor fun01_F;
}.

Coercion fun01_F : Fun01 >-> Funclass.
Global Existing Instance fun01_is0functor.

Arguments Build_Fun01 A B {isgraph_A isgraph_B} F {fun01_is0functor} : rename.

Definition issig_Fun01 (A B : Type) `{IsGraph A} `{IsGraph B}
  : _  <~> Fun01 A B := ltac:(issig).

(* Note that even if [A] and [B] are fully coherent oo-categories, the objects of our "functor category" are not fully coherent.  Thus we cannot in general expect this "functor category" to itself be fully coherent.  However, it is at least a 0-coherent 1-category, as long as [B] is a 1-coherent 1-category. *)

Global Instance isgraph_fun01 (A B : Type) `{IsGraph A} `{Is1Cat B} : IsGraph (Fun01 A B).
Proof.
  srapply Build_IsGraph.
  intros [F ?] [G ?].
  exact (NatTrans F G).
Defined.

Global Instance is01cat_fun01 (A B : Type) `{IsGraph A} `{Is1Cat B} : Is01Cat (Fun01 A B).
Proof.
  srapply Build_Is01Cat.
  - intros [F ?]; cbn.
    exists (id_transformation F); exact _.
  - intros [F ?] [G ?] [K ?] [gamma ?] [alpha ?]; cbn in *.
    exists (trans_comp gamma alpha); exact _.
Defined.

Global Instance is2graph_fun01 (A B : Type) `{IsGraph A, Is1Cat B}
  : Is2Graph (Fun01 A B).
Proof.
  intros [F ?] [G ?]; apply Build_IsGraph.
  intros [alpha ?] [gamma ?].
  exact (forall a, alpha a $== gamma a).
Defined.

(** In fact, in this case it is automatically also a 0-coherent 2-category and a 1-coherent 1-category, with a totally incoherent notion of 2-cell between 1-coherent natural transformations. *)

Global Instance is1cat_fun01 (A B : Type) `{IsGraph A} `{Is1Cat B} : Is1Cat (Fun01 A B).
Proof.
  srapply Build_Is1Cat.
  - intros [F ?] [G ?]; srapply Build_Is01Cat.
    + intros [alpha ?] a; cbn.
      reflexivity.
    + intros [alpha ?] [gamma ?] [phi ?] nu mu a.
      exact (mu a $@ nu a).
  - intros [F ?] [G ?]; srapply Build_Is0Gpd.
    intros [alpha ?] [gamma ?] mu a.
    exact ((mu a)^$).
  - intros [F ?] [G ?] [K ?] [alpha ?].
    srapply Build_Is0Functor.
    intros [phi ?] [mu ?] f a.
    exact (alpha a $@L f a).
  - intros [F ?] [G ?] [K ?] [alpha ?].
    srapply Build_Is0Functor.
    intros [phi ?] [mu ?] f a.
    exact (f a $@R alpha a).
  - intros [F ?] [G ?] [K ?] [L ?] [alpha ?] [gamma ?] [phi ?] a; cbn.
    srapply cat_assoc.
  - intros [F ?] [G ?] [alpha ?] a; cbn.
    srapply cat_idl.
  - intros [F ?] [G ?] [alpha ?] a; cbn.
    srapply cat_idr.
Defined.

(** It also inherits a notion of equivalence, namely a natural transformation that is a pointwise equivalence.  Note that this is not a "fully coherent" notion of equivalence, since the functors and transformations are not themselves fully coherent. *)

Global Instance hasequivs_fun01 (A B : Type) `{Is01Cat A} `{HasEquivs B}
  : HasEquivs (Fun01 A B).
Proof.
  srapply Build_HasEquivs.
  1:{ intros [F ?] [G ?]. exact (NatEquiv F G). }
  1:{ intros [F ?] [G ?] [alpha ?]; cbn in *.
      exact (forall a, CatIsEquiv (alpha a)). }
  all:intros [F ?] [G ?] [alpha alnat]; cbn in *.
  - exists (fun a => alpha a); assumption.
  - intros a; exact _.
  - intros ?.
    snrapply Build_NatEquiv.
    + intros a; exact (Build_CatEquiv (alpha a)).
    + cbn. refine (is1natural_homotopic alpha _).
      intros a; apply cate_buildequiv_fun.
  - cbn; intros; apply cate_buildequiv_fun.
  - exists (fun a => (alpha a)^-1$).
    intros a b f.
    refine ((cat_idr _)^$ $@ _).
    refine ((_ $@L (cate_isretr (alpha a))^$) $@ _).
    refine (cat_assoc _ _ _ $@ _).
    refine ((_ $@L (cat_assoc_opp _ _ _)) $@ _).
    refine ((_ $@L ((isnat (fun a => alpha a) f)^$ $@R _)) $@ _).
    refine ((_ $@L (cat_assoc _ _ _)) $@ _).
    refine (cat_assoc_opp _ _ _ $@ _).
    refine ((cate_issect (alpha b) $@R _) $@ _).
    exact (cat_idl _).
  - intros; apply cate_issect.
  - intros; apply cate_isretr.
  - intros [gamma ?] r s a; cbn in *.
    refine (catie_adjointify (alpha a) (gamma a) (r a) (s a)).
Defined.

(** ** Categories of 1-coherent 1-functors *)

Record Fun11 (A B : Type) `{Is1Cat A} `{Is1Cat B} :=
{
  fun11_fun : A -> B ;
  is0functor_fun11 : Is0Functor fun11_fun ;
  is1functor_fun11 : Is1Functor fun11_fun
}.

Coercion fun11_fun : Fun11 >-> Funclass.
Global Existing Instance is0functor_fun11.
Global Existing Instance is1functor_fun11.

Arguments Build_Fun11 A B
  {isgraph_A is2graph_A is01cat_A is1cat_A
   isgraph_B is2graph_B is01cat_B is1cat_B}
  F {is0functor_fun11 is1functor_fun11} : rename.

Coercion fun01_fun11 {A B : Type} `{Is1Cat A} `{Is1Cat B}
           (F : Fun11 A B)
  : Fun01 A B.
Proof.
  exists F; exact _.
Defined.

Global Instance isgraph_fun11 {A B : Type} `{Is1Cat A} `{Is1Cat B}
  : IsGraph (Fun11 A B)
  := isgraph_induced fun01_fun11.

Global Instance is01cat_fun11 {A B : Type} `{Is1Cat A} `{Is1Cat B}
  : Is01Cat (Fun11 A B)
  := is01cat_induced fun01_fun11.

Global Instance is2graph_fun11 {A B : Type} `{Is1Cat A, Is1Cat B}
  : Is2Graph (Fun11 A B)
  := is2graph_induced fun01_fun11.

Global Instance is1cat_fun11 {A B :Type} `{Is1Cat A} `{Is1Cat B}
  : Is1Cat (Fun11 A B)
  := is1cat_induced fun01_fun11.

Global Instance hasequivs_fun11 {A B : Type} `{Is1Cat A} `{HasEquivs B}
  : HasEquivs (Fun11 A B)
  := hasequivs_induced fun01_fun11.

(** * Identity functors *)

Definition fun01_id {A} `{IsGraph A} : Fun01 A A
  := Build_Fun01 A A idmap.

Definition fun11_id {A} `{Is1Cat A} : Fun11 A A
  := Build_Fun11 _ _ idmap.

(** * Composition of functors *)

Definition fun01_compose {A B C} `{IsGraph A, IsGraph B, IsGraph C}
  : Fun01 B C -> Fun01 A B -> Fun01 A C
  := fun G F => Build_Fun01 _ _ (G o F).

Definition fun01_postcomp {A B C}
  `{IsGraph A, Is1Cat B, Is1Cat C} (F : Fun11 B C)
  : Fun01 A B -> Fun01 A C
  := fun01_compose (A:=A) F.

(** Warning: [F] needs to be a 1-functor for this to be a 0-functor. *)
Global Instance is0functor_fun01_postcomp {A B C}
  `{IsGraph A, Is1Cat B, Is1Cat C} (F : Fun11 B C)
  : Is0Functor (fun01_postcomp (A:=A) F).
Proof.
  apply Build_Is0Functor.
  intros a b f.
  rapply nattrans_postwhisker.
  exact f.
Defined.

Global Instance is1functor_fun01_postcomp {A B C}
  `{IsGraph A, Is1Cat B, Is1Cat C} (F : Fun11 B C)
  : Is1Functor (fun01_postcomp (A:=A) F).
Proof.
  apply Build_Is1Functor.
  - intros a b f g p x.
    rapply fmap2.
    rapply p.
  - intros f x.
    rapply fmap_id.
  - intros a b c f g x.
    rapply fmap_comp.
Defined.

Definition fun11_fun01_postcomp {A B C}
  `{IsGraph A, Is1Cat B, Is1Cat C} (F : Fun11 B C)
  : Fun11 (Fun01 A B) (Fun01 A C)
  := Build_Fun11 _ _ (fun01_postcomp F).

Definition fun11_compose {A B C} `{Is1Cat A, Is1Cat B, Is1Cat C}
  : Fun11 B C -> Fun11 A B -> Fun11 A C.
Proof.
  intros F G.
  nrapply Build_Fun11.
  rapply (is1functor_compose G F).
Defined.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Functor.
Require Export Category.Structure.BiCCC.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Inductive Obj : Type :=
  | One_    : Obj
  | Prod_   : Obj -> Obj -> Obj
  | Exp_    : Obj -> Obj -> Obj
  | Zero_   : Obj
  | Coprod_ : Obj -> Obj -> Obj.

Fixpoint denote `(o : Obj) :
  ∀ {C : Category}
    {A : @Cartesian C}
    `{@Closed C A}
    `{@Cocartesian C}
    `{@Terminal C}
    `{@Initial C}, C := fun _ _ _ _ _ _ =>
  match o with
  | One_        => 1
  | Prod_ x y   => denote x × denote y
  | Exp_ x y    => denote y ^ denote x
  | Zero_       => 0
  | Coprod_ x y => denote x + denote y
  end.

(* jww (2017-06-21): This describes the morphisms of a magmoid. *)
Inductive Hom : Obj -> Obj -> Type :=
  | Id      : ∀ {a}, Hom a a
  | Compose : ∀ {a b c}, Hom b c -> Hom a b -> Hom a c

  | One'    : ∀ {a}, Hom a One_

  | Exl     : ∀ {a b}, Hom (Prod_ a b) a
  | Exr     : ∀ {a b}, Hom (Prod_ a b) b
  | Fork    : ∀ {a c d}, Hom a c -> Hom a d -> Hom a (Prod_ c d)

  | Curry   : ∀ {a b c}, Hom (Prod_ a b) c -> Hom a (Exp_ b c)
  | Uncurry : ∀ {a b c}, Hom a (Exp_ b c) -> Hom (Prod_ a b) c

  | Zero'   : ∀ {a}, Hom Zero_ a

  | Inl     : ∀ {a b}, Hom a (Coprod_ a b)
  | Inr     : ∀ {a b}, Hom b (Coprod_ a b)
  | Merge   : ∀ {a c d}, Hom c a -> Hom d a -> Hom (Coprod_ c d) a.

Program Fixpoint interp `(c : Hom a b) :
  ∀ {C : Category}
    {A : @Cartesian C}
    `{@Closed C A}
    `{@Cocartesian C}
    `{@Terminal C}
    `{@Initial C}, denote a ~{C}~> denote b := fun _ _ _ _ _ _ =>
  match c with
  | Id          => id
  | Compose f g => interp f ∘ interp g

  | One'        => one

  | Exl         => exl
  | Exr         => exr
  | Fork f g    => fork (interp f) (interp g)

  | Curry f     => curry (interp f)
  | Uncurry f   => uncurry (interp f)

  | Zero'       => zero

  | Inl         => inl
  | Inr         => inr
  | Merge f g   => merge (interp f) (interp g)
  end.

Program Instance AST : Category := {
  obj     := Obj;
  hom     := Hom;
  id      := @Id;
  compose := @Compose;
  homset  := fun _ _ =>
    {| equiv := fun f g =>
         forall {C : Category}
                {A : @Cartesian C}
                `{@Closed C A}
                `{@Cocartesian C}
                `{@Terminal C}
                `{@Initial C},
           interp f ≈ interp g |}
}.
Next Obligation.
  equivalence.
  transitivity (interp y); auto.
Qed.

Program Instance Hom_Terminal : @Terminal AST := {
  terminal_obj := One_;
  one := @One'
}.

Program Instance Hom_Cartesian : @Cartesian AST := {
  product_obj := Prod_;
  fork := @Fork;
  exl  := @Exl;
  exr  := @Exr
}.
Next Obligation. proper; rewrite X, X0; reflexivity. Qed.
Next Obligation.
  split; intros HA.
    split; intros; rewrite HA; cat.
  intros.
  destruct HA as [? ?].
  rewrite <- e, <- e0.
  rewrite fork_comp; cat.
Qed.

Program Instance Hom_Closed : @Closed AST _ := {
  exponent_obj := Exp_;
  exp_iso := fun x y z =>
    {| to   := {| morphism := @Curry x y z |}
     ; from := {| morphism := @Uncurry x y z |} |}
}.
Next Obligation. proper; rewrite X; reflexivity. Qed.
Next Obligation. proper; rewrite X; reflexivity. Qed.

Program Instance Hom_Initial : @Initial AST := {
  terminal_obj := Zero_;
  one := @Zero'
}.

Program Instance Hom_Cocartesian : @Cocartesian AST := {
  product_obj := Coprod_;
  fork := @Merge;
  exl  := @Inl;
  exr  := @Inr
}.
Next Obligation. proper; rewrite X, X0; reflexivity. Qed.
Next Obligation.
  split; intros HA.
    split; intros; rewrite HA; cat.
  intros.
  destruct HA as [? ?].
  rewrite <- e, <- e0.
  rewrite merge_comp; cat.
Qed.

Program Instance interp_proper {x y : Obj}
        {C : Category} {A : @Cartesian C}
        `{@Closed C A} `{@Cocartesian C}
        `{@Terminal C} `{@Initial C} :
  Proper (@equiv _ (@homset AST x y) ==>
                     @equiv _ (@homset C _ _))
         (fun f => @interp x y f C A _ _ _ _).

Require Export Category.Functor.Structure.Terminal.
Require Export Category.Functor.Structure.Cartesian.
Require Export Category.Functor.Structure.Closed.

Section AST.

Context {C : Category}.
Context {A : @Cartesian C}.
Context `{@Closed C A}.
Context `{@Cocartesian C}.
Context `{@Terminal C}.
Context `{@Initial C}.

Global Program Instance AST_Functor : AST ⟶ C := {
  fobj := fun x => denote x;
  fmap := fun _ _ f => interp f
}.

Global Program Instance Hom_TerminalFunctor : TerminalFunctor := {
  map_one := id
}.

Global Program Instance Hom_CartesianFunctor : CartesianFunctor := {
  fobj_prod_iso := _
}.

Global Program Instance Hom_ClosedFunctor : ClosedFunctor := {
  fobj_exp_iso := _
}.

Global Program Instance Hom_InitialFunctor : InitialFunctor AST_Functor := {
  map_one := id
}.

Global Program Instance Hom_CocartesianFunctor : CocartesianFunctor AST_Functor := {
  fobj_prod_iso := _
}.

End AST.


Set Implicit Arguments.

From TLC Require Import LibLN.
Implicit Types x : var.

(** Syntax **)

Inductive dtyp : Set :=
  | dtyp_nat : dtyp
  | dtyp_arrow : dtyp -> dtyp -> dtyp
  | dtyp_unknown : dtyp
  | dtyp_bvar  : nat -> dtyp
  | dtyp_fvar  : var -> dtyp
  | dtyp_all   : dtyp -> dtyp
.

Inductive dtrm : Set :=
  | dtrm_bvar   : nat -> dtrm
  | dtrm_fvar   : var -> dtrm
  | dtrm_nat    : nat -> dtrm
  | dtrm_absann : dtyp -> dtrm -> dtrm
  | dtrm_app    : dtrm -> dtrm -> dtrm
  | dtrm_abs    : dtrm -> dtrm
  | dtrm_let    : dtrm -> dtrm -> dtrm
.

(** Opening up a type binder occuring in a type *)

Fixpoint dopen_tt_rec (K : nat) (U : dtyp) (T : dtyp) {struct T} : dtyp :=
  match T with
  | dtyp_nat         => dtyp_nat
  | dtyp_unknown     => dtyp_unknown
  | dtyp_bvar J      => If K = J then U else (dtyp_bvar J)
  | dtyp_fvar X      => dtyp_fvar X
  | dtyp_arrow T1 T2 => dtyp_arrow (dopen_tt_rec K U T1) (dopen_tt_rec K U T2)
  | dtyp_all T       => dtyp_all (dopen_tt_rec (S K) U T)
  end.

Definition dopen_tt T U := dopen_tt_rec 0 U T.

(** Opening up a term binder occuring in a term *)

Fixpoint dopen_ee_rec (k : nat) (f : dtrm) (e : dtrm) {struct e} : dtrm :=
  match e with
  | dtrm_bvar i       => If k = i then f else (dtrm_bvar i)
  | dtrm_fvar x       => dtrm_fvar x
  | dtrm_nat i        => dtrm_nat i
  | dtrm_absann V e1  => dtrm_absann V (dopen_ee_rec (S k) f e1)
  | dtrm_app e1 e2    => dtrm_app (dopen_ee_rec k f e1) (dopen_ee_rec k f e2)
  | dtrm_abs e1       => dtrm_abs (dopen_ee_rec (S k) f e1)
  | dtrm_let e1 e2    => dtrm_let (dopen_ee_rec k f e1) (dopen_ee_rec (S k) f e2)
  end.

Definition dopen_ee t u := dopen_ee_rec 0 u t.

(** Notation for opening up binders with type or term variables *)

Notation "T 'dopen_tt_var' X" := (dopen_tt T (dtyp_fvar X)) (at level 67).

Notation "t 'dopen_ee_var' x" := (dopen_ee t (dtrm_fvar x)) (at level 67).

(** Types as locally closed pre-types *)

Inductive dtype : dtyp -> Prop :=
  | dtype_nat :
      dtype dtyp_nat
  | dtype_unknown :
      dtype dtyp_unknown
  | dtype_var : forall X,
      dtype (dtyp_fvar X)
  | dtype_arrow : forall T1 T2,
      dtype T1 ->
      dtype T2 ->
      dtype (dtyp_arrow T1 T2)
  | dtype_all : forall L T2,
      (forall X, X \notin L -> dtype (T2 dopen_tt_var X)) ->
      dtype (dtyp_all T2).

(** Terms as locally closed pre-terms *)

Inductive dterm : dtrm -> Prop :=
  | dterm_var : forall x,
      dterm (dtrm_fvar x)
  | dterm_nat : forall i,
      dterm (dtrm_nat i)
  | dterm_absann : forall L V e1,
      dtype V ->
      (forall x, x \notin L -> dterm (e1 dopen_ee_var x)) ->
      dterm (dtrm_absann V e1)
  | dterm_abs : forall L e1,
      (forall x, x \notin L -> dterm (e1 dopen_ee_var x)) ->
      dterm (dtrm_abs e1)
  | dterm_app : forall e1 e2,
      dterm e1 ->
      dterm e2 ->
      dterm (dtrm_app e1 e2)
  | dterm_let : forall L e1 e2,
      dterm e1 ->
      (forall x, x \notin L -> dterm (e2 dopen_ee_var x)) ->
      dterm (dtrm_let e1 e2)
.

(** Environment is an associative list of bindings. *)

Inductive dbind : Set :=
  | dbind_tvar : dbind
  | dbind_typ : dtyp -> dbind
.

Definition denv := LibEnv.env dbind.

Notation "x ~tvar" := (x ~ dbind_tvar)
  (at level 23, left associativity) : env_scope.
Notation "x ~: T" := (x ~ dbind_typ T)
  (at level 23, left associativity) : env_scope.

(** A type T is well formed under environment E *)

Inductive dwft : denv -> dtyp -> Prop :=
  | dwft_nat : forall E,
      ok E ->
      dwft E dtyp_nat
  | dwft_unknown : forall E,
      ok E ->
      dwft E dtyp_unknown
  | dwft_var : forall E x,
      ok E ->
      binds x dbind_tvar E ->
      dwft E (dtyp_fvar x)
  | dwft_arrow : forall E A1 A2,
      dwft E A1 ->
      dwft E A2 ->
      dwft E (dtyp_arrow A1 A2)
  | dwft_all : forall L E A,
      (forall X, X \notin L ->
            dwft (E & X ~tvar) (A dopen_tt_var X)) ->
      dwft E (dtyp_all A)
.

(** A environment E is well-formed if it contains no duplicate bindings and well-foremd types *)

Inductive dokt : denv -> Prop :=
  | dokt_empty :
      dokt empty
  | dokt_tvar : forall E x,
      dokt E -> x # E -> dokt (E & x ~tvar)
  | dokt_typ : forall E x A,
      dokt E -> x # E ->
      dwft E A ->
      dokt (E & x ~: A)
.

(** mono type : contains no unknown type or quantifier *)

Inductive dtyp_mono : dtyp -> Prop :=
  | dtyp_mono_nat:
      dtyp_mono dtyp_nat
  | dtyp_mono_var: forall x,
      dtyp_mono (dtyp_fvar x)
  | dtyp_mono_arrow: forall A B,
      dtyp_mono A ->
      dtyp_mono B ->
      dtyp_mono (dtyp_arrow A B)
.

(** Matching *)

Inductive dmatch : denv -> dtyp -> dtyp -> dtyp -> Prop :=
  | dmatch_all : forall E A A1 A2 tau,
      dtyp_mono tau ->
      dwft E tau ->
      dmatch E (dopen_tt A tau) A1 A2 ->
      dmatch E (dtyp_all A) A1 A2
  | dmatch_arrow : forall E A1 A2,
      dmatch E (dtyp_arrow A1 A2) A1 A2
  | dmatch_unknown : forall E,
      dmatch E dtyp_unknown dtyp_unknown dtyp_unknown
.

(** Subtyping *)

Inductive dsub : denv -> dtyp -> dtyp -> Prop :=
  | dsub_nat : forall E,
      dokt E ->
      dsub E dtyp_nat dtyp_nat
  | dsub_var : forall E x,
      dokt E ->
      binds x dbind_tvar E ->
      dsub E (dtyp_fvar x) (dtyp_fvar x)
  | dsub_unknown : forall E,
      dokt E ->
      dsub E dtyp_unknown dtyp_unknown
  | dsub_fun : forall E A1 A2 B1 B2,
      dsub E B1 A1 ->
      dsub E A2 B2 ->
      dsub E (dtyp_arrow A1 A2) (dtyp_arrow B1 B2)
  | dsub_allL : forall E A B tau,
      dtyp_mono tau ->
      dwft E tau ->
      dsub E (dopen_tt A tau) B ->
      dsub E (dtyp_all A) B
  | dsub_allR : forall L E A B,
      (forall x, x \notin L ->
            dsub (E & x ~tvar) A (B dopen_tt_var x)) ->
      dsub E A (dtyp_all B)
.

(** Consistent Subtyping *)

Inductive dconsub : denv -> dtyp -> dtyp -> Prop :=
  | dconsub_nat : forall E,
      dokt E ->
      dconsub E dtyp_nat dtyp_nat
  | dconsub_var : forall E x,
      dokt E ->
      binds x dbind_tvar E ->
      dconsub E (dtyp_fvar x) (dtyp_fvar x)
  | dconsub_unknown_l : forall E A,
      dokt E ->
      dwft E A ->
      dconsub E dtyp_unknown A
  | dconsub_unknown_r : forall E A,
      dokt E ->
      dwft E A ->
      dconsub E A dtyp_unknown
  | dconsub_fun : forall E A1 A2 B1 B2,
      dconsub E B1 A1 ->
      dconsub E A2 B2 ->
      dconsub E (dtyp_arrow A1 A2) (dtyp_arrow B1 B2)
  | dconsub_allL : forall E A B tau,
      dtyp_mono tau ->
      dwft E tau ->
      dconsub E (dopen_tt A tau) B ->
      dconsub E (dtyp_all A) B
  | dconsub_allR : forall L E A B,
      (forall x, x \notin L ->
            dconsub (E & x ~tvar) A (B dopen_tt_var x)) ->
      dconsub E A (dtyp_all B)
.

(** Typing *)

Inductive dtyping : denv -> dtrm -> dtyp -> Prop :=
  | dtyping_var : forall E x T,
      dokt E ->
      binds x (dbind_typ T) E ->
      dtyping E (dtrm_fvar x) T
  | dtyping_nat : forall E i,
      dokt E ->
      dtyping E (dtrm_nat i) (dtyp_nat)
  | dtyping_absann : forall L E A B e,
      dwft empty A -> (* type annotations are closed *)
      (forall x, x \notin L ->
            dtyping (E & x ~: A) (e dopen_ee_var x) B) ->
      dtyping E (dtrm_absann A e) (dtyp_arrow A B)
  | dtyping_app : forall E e1 e2 A A1 A2 A3,
      dtyping E e1 A ->
      dmatch E A A1 A2 ->
      dtyping E e2 A3 ->
      dconsub E A3 A1 ->
      dtyping E (dtrm_app e1 e2) A2
  | dtyping_abs : forall L E A B e,
      dtyp_mono A ->
      (forall x, x \notin L ->
            dtyping (E & x ~: A) (e dopen_ee_var x) B) ->
      dtyping E (dtrm_abs e) (dtyp_arrow A B)
  | dtyping_gen : forall L E A e,
      (forall a, a \notin L ->
            dtyping (E & a ~tvar) e (A dopen_tt_var a)) ->
      dtyping E e (dtyp_all A)
  | dtyping_let : forall L E A B e1 e2,
      dtyping E e1 A ->
      (forall x, x \notin L ->
            dtyping (E & x ~: A) (e2 dopen_ee_var x) B) ->
      dtyping E (dtrm_let e1 e2) B
.

(** Consistent *)

Inductive dconsist: dtyp -> dtyp -> Prop :=
  | dconsist_refl: forall A,
      dconsist A A
  | dconsist_unknown_r: forall A,
      dconsist A dtyp_unknown
  | dconsist_unknown_l: forall A,
      dconsist dtyp_unknown A
  | dconsist_arrow: forall A1 A2 B1 B2,
      dconsist A1 B1 ->
      dconsist A2 B2 ->
      dconsist (dtyp_arrow A1 A2) (dtyp_arrow B1 B2)
  | dconsist_all: forall A B,
      dconsist A B ->
      dconsist (dtyp_all A) (dtyp_all B)
.


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

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

Class PeirceLaw (L: Language) {minL: MinimumLanguage L} (Gamma: Provable L) := {
  __peirce_law: forall x y, |-- ((x --> y) --> x) --> x
}.

Class ByContradiction (L: Language) {minL: MinimumLanguage L} {negpL: NegLanguage L} (Gamma: Provable L) := {
  __by_contradiction: forall x y, |-- (~~ x --> y) --> (~~ x --> ~~ y) --> x
}.

Class DoubleNegElimination (L: Language) {minL: MinimumLanguage L} {negpL: NegLanguage L} (Gamma: Provable L) := {
  __double_negp_elim: forall x, |-- ~~ (~~ x) --> x
}.

Class ClassicAnalysis (L: Language) {minL: MinimumLanguage L} {negpL: NegLanguage L} (Gamma: Provable L) := {
  __classic_analysis: forall x y, |-- (x --> y) --> (~~ x --> y) --> y
}.

Class ExcludedMiddle (L: Language) {orpL: OrLanguage L} {negpL: NegLanguage L} (Gamma: Provable L) := {
  __excluded_middle: forall x, |-- x || ~~ x
}.

Class ImplyToOr (L: Language) {minL: MinimumLanguage L} {orpL: OrLanguage L} {negpL: NegLanguage L} (Gamma: Provable L) := {
  __impp2orp1: forall x y, |-- (x --> y) --> (~~ x || y)
}.

(************************************************)
(*                                              *)
(*                  PeirceLaw                   *)
(*                /           |\                *)
(*              |/              \               *)
(*  ByContradiction          ClassicAnalysis    *)
(*              \               /|  /|\  |      *)
(*               \|            /     |   |      *)
(*         DoubleNegativeElimination |   |      *)
(*                                   |   |      *)
(*                                   |   |      *)
(*           ------------------------   \|/     *)
(*      ExcludedMiddle <--------  ImplyToOr     *)
(*                                              *)
(*                                              *)
(*                                              *)
(************************************************)

Section ExcludedMiddle2ClassicAnalysis.

Context {L: Language}
        {minL: MinimumLanguage L}
        {orpL: OrLanguage L}
        {negpL: NegLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {orpAX: OrAxiomatization L Gamma}
        {emAX: ExcludedMiddle L Gamma}.

Lemma ExcludedMiddle2ClassicAnalysis: ClassicAnalysis L Gamma.
Proof.
  constructor.
  AddSequentCalculus.
  intros.
  rewrite provable_derivable.
  rewrite <- deduction_theorem.
  rewrite <- deduction_theorem.
  apply deduction_subst1 with (x || ~~ x).
  + do 2 apply deduction_weaken1.
    rewrite <- provable_derivable.
    apply __excluded_middle.
  + apply deduction_orp_elim; rewrite deduction_theorem; solve_assum.
Qed.

End ExcludedMiddle2ClassicAnalysis.

Section ClassicAnalysis2ImplyToOr.

Context {L: Language}
        {minL: MinimumLanguage L}
        {orpL: OrLanguage L}
        {negpL: NegLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {orpGamma: OrAxiomatization L Gamma}
        {inegpGamma: IntuitionisticNegAxiomatization L Gamma}
        {cAX: ClassicAnalysis L Gamma}.

Lemma ClassicAnalysis2ExcludedMiddle: ExcludedMiddle L Gamma.
Proof.
  constructor.
  intros.
  pose proof __classic_analysis x (x || ~~ x).
  pose proof modus_ponens _ _ H (orp_intros1 _ _).
  pose proof modus_ponens _ _ H0 (orp_intros2 _ _).
  auto.
Qed.

Lemma ClassicAnalysis2ImplyToOr: ImplyToOr L Gamma.
Proof.
  pose proof ClassicAnalysis2ExcludedMiddle as EM.
  constructor.
  AddSequentCalculus.
  intros.
  rewrite provable_derivable.
  rewrite <- deduction_theorem.
  apply (deduction_modus_ponens _ (x || ~~ x)).
  + pose proof __excluded_middle x.
    pose proof solve_impp_elim_left (x-->y) _ H.
    rewrite provable_derivable in H0.
    rewrite <- deduction_theorem in H0. apply H0.
  + apply deduction_orp_elim'.
    - rewrite <- deduction_theorem.
      apply deduction_orp_intros2.
      rewrite -> deduction_theorem.
      apply derivable_assum1.
    - rewrite <- deduction_theorem.
      apply deduction_orp_intros1.
      apply derivable_assum1.
Qed.

End ClassicAnalysis2ImplyToOr.

Section ImplyToOr2ExcludedMiddle.

Context {L: Language}
        {minL: MinimumLanguage L}
        {orpL: OrLanguage L}
        {falsepL: FalseLanguage L}
        {negpL: NegLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {orpGamma: OrAxiomatization L Gamma}
        {falsepGamma: FalseAxiomatization L Gamma}
        {inegpGamma: IntuitionisticNegAxiomatization L Gamma}
        {itoAX: ImplyToOr L Gamma}.

Lemma ImplyToOr2ExcludedMiddle: ExcludedMiddle L Gamma.
Proof.
  constructor.
  AddSequentCalculus.
  intros.
  pose proof __impp2orp1 x x.
  rewrite orp_comm_impp in H.
  rewrite <- H.
  rewrite provable_derivable. rewrite <- deduction_theorem.
  solve_assum.
Qed.

End ImplyToOr2ExcludedMiddle.

Section PeirceLaw2ByContradiction.

Context {L: Language}
        {minL: MinimumLanguage L}
        {negpL: NegLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {inegpAX: IntuitionisticNegAxiomatization L Gamma}
        {plAX: PeirceLaw L Gamma}.

Lemma Peirce2ByContradiction: ByContradiction L Gamma.
Proof.
  constructor.
  AddSequentCalculus.
  intros.
  pose proof negp_aux_rule x _ (provable_impp_refl x).
  pose proof __peirce_law x (~~ (x --> x)).
  rewrite H in H0.
  rewrite <- H0 at 3.
  rewrite <- (axiom2 (~~ x) (~~ y) x).
  rewrite <- (axiom2 (~~ x) y (~~ y --> x)).
  apply aux_minimun_rule00.
  apply contradiction_elim2.
Qed.

End PeirceLaw2ByContradiction.

Section ByContradiction2DoubleNegElimination.

Context {L: Language}
        {minL: MinimumLanguage L}
        {negpL: NegLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {bcAX: ByContradiction L Gamma}.

Lemma ByContradiction2DoubleNegElimination:
  DoubleNegElimination L Gamma.
Proof.
  constructor.
  intros.
  pose proof __by_contradiction x (~~ x).
  pose proof modus_ponens _ _ H (provable_impp_refl _).
  rewrite <- H0 at 2.
  apply axiom1.
Qed.

End ByContradiction2DoubleNegElimination.

Section DoubleNegElimination2ClassicAnalysis.

Context {L: Language}
        {minL: MinimumLanguage L}
        {negpL: NegLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {inegpAX: IntuitionisticNegAxiomatization L Gamma}
        {dneAX: DoubleNegElimination L Gamma}.

Lemma DoubleNegElimination2ClassicAnalysis: ClassicAnalysis L Gamma.
Proof.
  constructor.
  intros.
  rewrite <- provable_impp_arg_switch.
  rewrite <- (__double_negp_elim y) at 3.
  rewrite <- contrapositivePN.
  rewrite <- (aux_minimun_theorem04 (~~ y) (~~ (x --> y))).
  rewrite <- contrapositivePP.
  rewrite <- (aux_minimun_theorem02 x y).
  rewrite (contradiction_elim2 y x) at 1.
  rewrite (provable_impp_arg_switch (~~ x) (~~ y) x).
  rewrite <- aux_minimun_theorem00.
  rewrite <- (aux_minimun_theorem04 (~~ x --> x) x).
  AddSequentCalculus.
  rewrite provable_derivable.
  rewrite <- ! deduction_theorem.
  rewrite <- (__double_negp_elim x) at 5.
  apply deduction_contrapositivePN.
  apply (deduction_contradiction_elim _ x).
  + rewrite deduction_theorem.
    solve_assum.
  + solve_assum.
Qed.

End DoubleNegElimination2ClassicAnalysis.

Section ClassicAnalysis2PeirceLaw.

Context {L: Language}
        {minL: MinimumLanguage L}
        {negpL: NegLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {inegpGamma: IntuitionisticNegAxiomatization L Gamma}
        {cAX: ClassicAnalysis L Gamma}.

Lemma ClassicAnalysis2DoubleNegElimination: DoubleNegElimination L Gamma.
Proof.
  constructor.
  intros.
  pose proof __classic_analysis x x.
  pose proof modus_ponens _ _ H (provable_impp_refl _).
  rewrite <- H0 at 2.
  apply contradiction_elim1.
Qed.

Lemma ClassicAnalysis2PeirceLaw: PeirceLaw L Gamma.
Proof.
  pose proof ClassicAnalysis2DoubleNegElimination.
  constructor.
  intros.
  rewrite <- (__double_negp_elim x) at 3.
  rewrite <- (aux_minimun_theorem04 ((x --> y) --> x) (~~ (~~ x))).
  AddSequentCalculus.
  rewrite provable_derivable.
  rewrite <- ! deduction_theorem.
  apply deduction_contrapositivePN.
  apply deduction_contradiction_elim with x; [| solve_assum].
  rewrite ! deduction_theorem.
  rewrite <- provable_derivable.
  rewrite <- provable_impp_trans.
  apply contradiction_elim1.
Qed.

End ClassicAnalysis2PeirceLaw.

(***************************************)
(*   Resuming Axioms of Negation       *)
(***************************************)

Section ByContradiction2IntuitionisticNegAxiomatization.

Context {L: Language}
        {minL: MinimumLanguage L}
        {negpL: NegLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {bcAX: ByContradiction L Gamma}.

Lemma ByContradiction2IntuitionisticNegAxiomatization:
  IntuitionisticNegAxiomatization L Gamma.
Proof.
  pose proof ByContradiction2DoubleNegElimination as double_negp_elim_AX.
  constructor.
  + intros.
    pose proof __by_contradiction (~~ y) x.
    rewrite <- (axiom1 (~~ x) (~~ (~~ y))) in H.
    rewrite <- H.
    rewrite <- provable_impp_trans.
    apply __double_negp_elim.
  + intros.
    rewrite (axiom1 x (~~ y)) at 2.
    rewrite (axiom1 (~~ x) (~~ y)).
    rewrite <- provable_impp_arg_switch.
    apply __by_contradiction.
  + intros.
    pose proof __by_contradiction (~~ (~~ x)) x.
    rewrite <- (axiom1 x (~~ (~~ (~~ x)))) in H.
    rewrite provable_impp_arg_switch in H.
    eapply modus_ponens; [exact H |].
    apply __double_negp_elim.
Qed.

End ByContradiction2IntuitionisticNegAxiomatization.


Require Import
        Coq.Strings.String
        Coq.Vectors.Vector.

Require Import
        Fiat.Common.SumType
        Fiat.Common.BoundedLookup
        Fiat.Common.ilist
        Fiat.Computation
        Fiat.QueryStructure.Specification.Representation.Notations
        Fiat.QueryStructure.Specification.Representation.Heading
        Fiat.QueryStructure.Specification.Representation.Tuple
        Fiat.Narcissus.BinLib.AlignedByteString
        Fiat.Narcissus.BinLib.AlignWord
        Fiat.Narcissus.BinLib.AlignedDecoders
        Fiat.Narcissus.BinLib.AlignedList
        Fiat.Narcissus.BinLib.AlignedSumType
        Fiat.Narcissus.BinLib.Core
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.ComposeOpt
        Fiat.Narcissus.Automation.Solver
        Fiat.Narcissus.Formats.StringOpt
        Fiat.Common.Tactics.HintDbExtra
        Fiat.Common.Tactics.TransparentAbstract
        Fiat.Common.Tactics.CacheStringConstant.

Require Import
        Coq.NArith.NArith
        Recdef.

Require Import Bedrock.Word.

Import Vectors.VectorDef.VectorNotations.
Open Scope string_scope.
Open Scope Tuple_scope.

(* Start Example Derivation. *)

Section Coordinate_Decoder.

Definition Coordinate :=
  @Tuple <"Time" :: N,
          "Latitude" :: Z * N,
          "Longitude" :: Z * N >.

Function N_to_string' (n : N) {wf N.lt n}: string :=
  match n with
  | N0 => EmptyString
  | _ => String.append (N_to_string' (BinNatDef.N.div n 10))%N (String (Ascii.ascii_of_N (48 + BinNatDef.N.modulo n 10))%N EmptyString)
end.
intros; apply N.div_lt; reflexivity.
apply N.lt_wf_0.
Defined.

Definition N_to_string (n : N) :=
  match n with
  | N0 => "0"
  | _ => N_to_string' n
  end.

Goal (N_to_string 10 ="10")%N%string.
  unfold N_to_string;
  repeat first [reflexivity
               | rewrite N_to_string'_equation; simpl].
Qed.

Goal (N_to_string 1030 ="1030")%N%string.
  unfold N_to_string;
  repeat first [reflexivity
               | rewrite N_to_string'_equation; simpl].
Qed.

Fixpoint string_to_N (s : string) : N :=
  match s with
  | EmptyString => 0
  | String c s' => ((Ascii.N_of_ascii c - 48) * 10^(N.of_nat (String.length s'))) + (string_to_N s')
  end%N.

Goal (10 = string_to_N "10")%N%string.
  reflexivity.
Qed.

Goal (1030 = string_to_N "1030")%N%string.
  reflexivity.
Qed.

Goal (0 = string_to_N "0")%N%string.
  reflexivity.
Qed.

Lemma string_length_append :
  forall s s', (String.length (s ++ s') = String.length s + String.length s')%nat.
Proof.
  induction s; simpl; intros; eauto.
Qed.

Lemma N_of_nat_distr :
  forall n n' : nat, (N.of_nat (n + n') = N.of_nat n + N.of_nat n')%N.
Proof.
  induction n; intros; eauto.
  simpl plus.
  rewrite !Nat2N.inj_succ, IHn, N.add_succ_l; reflexivity.
Qed.

Lemma string_to_N_append : forall s s',
    (string_to_N (s ++ s') = (string_to_N s * 10^(N.of_nat (String.length s'))) +
                             (string_to_N s'))%N.
Proof.
  induction s; simpl; intros; eauto.
  rewrite IHs.
  rewrite !N.add_assoc, string_length_append,
  N_of_nat_distr, N.pow_add_r, N.mul_add_distr_r, N.mul_assoc.
  reflexivity.
Qed.

Lemma N_to_string_inv
  : forall n, string_to_N (N_to_string n) = n.
Proof.
  destruct n; simpl.
  - reflexivity.
  - pattern (N.pos p), (N_to_string' (N.pos p)).
    apply N_to_string'_ind; intros; eauto.
    subst.
    rewrite string_to_N_append.
    rewrite H.
    simpl String.length; simpl N.of_nat.
    unfold string_to_N.
    rewrite Ascii.N_ascii_embedding.
    rewrite (N.div_mod' _x 10) at 3.
    simpl N.of_nat.
    replace (10 ^ 1)%N with 10%N by reflexivity.
    rewrite N.mul_comm.
    f_equal.
    generalize (_x mod 10)%N; intro.
    rewrite (Nplus_comm 48), (N.add_sub n), N.mul_1_r, N.add_0_r; reflexivity.
    eapply (N.add_lt_mono_l _ 208 48).
    etransitivity.
    eapply N.mod_bound_pos.
    eapply N.le_0_l.
    reflexivity.
    reflexivity.
Qed.

Definition string_to_Z (s : string) : Z :=
  match s with
  | String "-" s' => BinInt.Z.mul (BinInt.Z.of_N (string_to_N s')) (-1)
  | _ => BinInt.Z.of_N (string_to_N s)
  end.

Definition Z_to_string (z : Z) : string :=
  match z with
  | Zneg _ => String "-" (N_to_string (BinIntDef.Z.abs_N z))
  | _ => (N_to_string (BinIntDef.Z.abs_N z))
  end.

Lemma Z_to_string_inv
  : forall z, string_to_Z (Z_to_string z) = z.
Proof.
  destruct z eqn: ?; simpl.
  - reflexivity.
  - unfold string_to_Z.
    destruct (N_to_string' (N.pos p)) eqn: ?.
Admitted.

Lemma no_space_in_N_to_string
  : forall (n : N) (s1 s2 : string),
    N_to_string n <> (s1 ++ String " " s2)%string.
Proof.
Admitted.

Lemma no_dot_in_Z_to_string
  : forall (z : Z) (s1 s2 : string),
    Z_to_string z <> (s1 ++ String "." s2)%string.
Proof.
Admitted.

Definition newline := Ascii.Ascii false false false false true false true false.

Lemma no_newline_in_N_to_string
  : forall (n : N) (s1 s2 : string),
    N_to_string n <> (s1 ++ String newline s2)%string.
Proof.
Admitted.

Definition Coordinate_format
           (coords : Coordinate) :=
          format_string_with_term_char " " (N_to_string (coords!"Time"))
    ThenC format_string_with_term_char "." (Z_to_string (fst coords!"Latitude"))
    ThenC format_string_with_term_char " " (N_to_string (snd coords!"Latitude"))
    ThenC format_string_with_term_char "." (Z_to_string (fst coords!"Longitude"))
    ThenC format_string_with_term_char newline (N_to_string (snd coords!"Longitude"))
    DoneC.

Definition Coordinate_decoder
  : CorrectDecoderFor (fun _ => True) Coordinate_format.
Proof.
  start_synthesizing_decoder.
  normalize_compose monoid.
  decode_step idtac.
  intros; eapply String_decode_with_term_char_correct.
  decode_step idtac.
  intros; simpl; eapply no_space_in_N_to_string.
  decode_step idtac.
  decode_step idtac.
  intros; eapply String_decode_with_term_char_correct.
  decode_step idtac.
  intros; simpl; eapply no_dot_in_Z_to_string.
  decode_step idtac.
  decode_step idtac.
  intros; eapply String_decode_with_term_char_correct.
  decode_step idtac.
  intros; simpl; eapply no_space_in_N_to_string.
  decode_step idtac.
  decode_step idtac.
  intros; eapply String_decode_with_term_char_correct.
  decode_step idtac.
  intros; simpl; eapply no_dot_in_Z_to_string.
  decode_step idtac.
  decode_step idtac.
  intros; eapply String_decode_with_term_char_correct.
  decode_step idtac.
  intros; simpl; eapply no_newline_in_N_to_string.
  decode_step idtac.
  simpl; intros **; eapply CorrectDecoderinish.
  unfold Domain, GetAttribute, GetAttributeRaw in *; simpl in *;
    (let a' := fresh in
     intros a'; repeat destruct a' as [? a']; unfold Domain, GetAttribute, GetAttributeRaw in *; simpl in *; intros **; intuition;
     repeat
       match goal with
       | H:_ = _
         |- _ => first
                   [ apply decompose_pair_eq in H; (let H1 := fresh in
                                                    let H2 := fresh in
                                                    destruct H as [H1 H2]; simpl in H1; simpl in H2)
                   | rewrite H in * ]
       end).
  destruct prim_fst0, prim_fst1; simpl in *.
  apply (f_equal string_to_N) in H7.
  apply (f_equal string_to_N) in H9.
  apply (f_equal string_to_N) in H11.
  apply (f_equal string_to_Z) in H8.
  apply (f_equal string_to_Z) in H10.
  rewrite N_to_string_inv, Z_to_string_inv in *.
  subst.
  reflexivity.
  unfold GetAttribute, GetAttributeRaw; simpl.
  decide_data_invariant.
  apply (@decides_True' _ proj).
  setoid_rewrite <- BoolFacts.string_dec_bool_true_iff;
    split; intro H5; apply H5.
  setoid_rewrite <- BoolFacts.string_dec_bool_true_iff;
    split; intro H5; apply H5.
  setoid_rewrite <- BoolFacts.string_dec_bool_true_iff;
    split; intro H5; apply H5.
  setoid_rewrite <- BoolFacts.string_dec_bool_true_iff;
    split; intro H5; apply H5.
  setoid_rewrite <- BoolFacts.string_dec_bool_true_iff;
    split; intro H5; apply H5.
  synthesize_cache_invariant.
  repeat optimize_decoder_impl.
Defined.

Definition Coordinate_decoder_impl :=
  Eval simpl in (fst (proj1_sig Coordinate_decoder)).

End Coordinate_Decoder.

Print Coordinate_decoder_impl.


Set Implicit Arguments.

From CFML Require Import WPLib Stdlib.
From TLC Require Import LibListZ.
Generalizable Variables A.

Implicit Types n m: int.
Implicit Types p q : loc.

From Proofs Require Import Refs.

Module Basics.

Lemma example_let_spec : forall n,
  SPEC (example_let n)
    PRE \[]
    POST (fun r => \[r = 2*n]).
Proof using.
  (* TODO: why not let-val ? *)
  (* TODO: xval no subst ?*)
  xcf. (* xlet. xval. xval_nosubst. *)
  xlet. xlet. xval. xsimpl. math.
Qed.

Lemma incr_spec : forall (p:loc) (n:int),
  SPEC (incr p)
    PRE (p ~~> n)
    POSTUNIT (p ~~> (n+1)).
Proof using.
  xcf. xapp. xapp. xsimpl.
Qed.

Hint Extern 1 (RegisterSpec incr) => Provide incr_spec.

Lemma succ_using_incr_spec : forall n,
  SPEC (succ_using_incr n)
    PRE \[]
    POST (fun r => \[r = n+1]).
Proof using.
  xcf. xapp ;=> p.
  xapp. xapp. xsimpl*.
Qed.

Lemma incr_one_of_two_spec :
  forall (p q:loc) (n m:int),
  SPEC (incr_one_of_two p q)
    PRE (p ~~> n \* q ~~> m)
    POSTUNIT (p ~~> (n+1) \* q ~~> m).
Proof using.
  xcf. xapp. xsimpl.
Qed.

Lemma incr_and_ref_spec : forall (p:loc) (n:int),
  SPEC (incr_and_ref p)
    PRE (p ~~> n)
    POST (fun (q:loc) => q ~~> (n+1) \* p ~~> (n+1)).
Proof using.
  xcf. xapp. xapp. xapp. xsimpl.
Qed.

Hint Extern 1 (RegisterSpec (incr_and_ref)) => Provide incr_and_ref_spec.

Lemma incr_and_ref'_spec : forall (p:loc) (n:int),
  SPEC (incr_and_ref p)
    PRE (p ~~> n)
    POST (fun (q:loc) =>
        \exists m, \[m > n] \* q ~~> m \* p ~~> (n+1)).
Proof using.
  xtriple. xapp. intros q. xsimpl. math.
Qed.

Lemma repeat_incr_spec : forall p n m,
  SPEC (repeat_incr p m)
    PRE (p ~~> n)
    POSTUNIT (p ~~> (n + m)).
Proof using.
  intros. gen n. induction_wf IH: (downto 0) m. intros.
  xcf. xif ;=> C.
  { (* then branch *)
    xapp. xapp. { unfold downto. math. } xsimpl. math. }
  { (* else branch *)
    xval. xsimpl.
Abort.

Lemma repeat_incr_spec : forall p n m,
  m >= 0 ->
  SPEC (repeat_incr p m)
    PRE (p ~~> n)
    POSTUNIT (p ~~> (n + m)).
Proof using.
  introv Hm. gen n Hm. induction_wf IH: (downto 0) m. intros.
  xcf. xif; intros C.
  { xapp. xapp. { hnf. math. } { math. }
    xsimpl. math. }
  { xval. xsimpl. math. }
Qed.

Lemma max_nonneg: forall m, m >= 0 -> max 0 m = m.
Proof.
  intros m Hm. rewrite max_r; auto.
  exact antisym_le_int.
Qed.

Lemma max_nonpos: forall m, m <= 0 -> max 0 m = 0.
Proof.
  intros m Hm. rewrite max_l; auto.
  exact antisym_le_int.
Qed.

Lemma repeat_incr'_spec : forall p n m,
  SPEC (repeat_incr p m)
    PRE (p ~~> n)
    POSTUNIT (p ~~> (n + max 0 m)).
Proof using.
  intros. gen n. induction_wf IH: (downto 0) m; intros.
  xcf. xif; intros C.
  { xapp. xapp. { hnf. math. }
    xsimpl. repeat rewrite max_nonneg; math. }
  { xval. xsimpl. rewrite max_nonpos; math. }
Qed.

End Basics.

Module ExoBasic.

  Lemma double_spec : forall n,
  SPEC (double n)
    PRE \[]
    POST (fun m => (* SOLUTION *) \[m = 2 * n] (* /SOLUTION *)).
  Proof using.
    (* SOLUTION *) xcf. xval. xsimpl. math. (* /SOLUTION *)
  Qed.

  Lemma inplace_double_spec : forall p n,
      SPEC (inplace_double p)
           PRE ((* SOLUTION *) p ~~> n (* /SOLUTION *))
           POSTUNIT ((* SOLUTION *) p ~~> (2 * n) (* /SOLUTION *)).
  Proof using.
    (* SOLUTION *) xcf. xapp. xapp. xapp. xsimpl. math. (* /SOLUTION *)
  Qed.

  Lemma decr_and_incr_spec : forall p q n m,
      SPEC (decr_and_incr p q)
           PRE ((* SOLUTION *) p ~~> n \* q ~~> m (* /SOLUTION *))
           POSTUNIT ((* SOLUTION *) p ~~> (n-1) \* q ~~> (m+1) (* /SOLUTION *)).
  Proof using.
    (* SOLUTION *) xcf. xapp. xapp. xsimpl. (* /SOLUTION *)
  Qed.

  Lemma transfer_spec : forall p q n m,
      n >= 0 ->
      SPEC (transfer p q)
           PRE (p ~~> n \* q ~~> m)
           POSTUNIT ((* SOLUTION *) p ~~> 0 \* q ~~> (n + m) (* /SOLUTION *)).
  Proof using.
    introv N. gen m N. induction_wf IH: (downto 0) n. intros.
    (* SOLUTION *)
    xcf. xapp. xif ;=> C.
    { xapp. xapp. xapp. { hnf. math. } { math. }
      xsimpl. math. }
    { xval. xsimpl. math. math. }
    (* /SOLUTION *)
  Qed.

End ExoBasic.

(* ####################################################### *)
(** * Entailment tactic *)

Module XsimplDemo.

(* ******************************************************* *)
(** *** [xpull] to extract from LHS *)

Lemma xpull_demo_hpure : forall H1 H2 n,
  H1 \* \[n = 3] ==> H2.
Proof using.
  intros. xpull. intros Hn.
Abort.

Lemma xpull_demo_hexists : forall H1 H2 p,
  H1 \* \exists (n:int), (p ~~> n) ==> H2.
Proof using.
  intros. xpull. intros n.
Abort.

Lemma xpull_demo_lhs_several : forall H1 H2 H3 H4 p q,
    H1 \* \exists (n:int), (p ~~> n \* \[n > 0] \* H2) \* \[p <> q] \* H3 ==> H4.
Proof using.
  intros. xpull. intros n Hn Hp. (* or [xpull ;=> n Hn Hp] *)
Abort.

(* ******************************************************* *)
(** *** [xsimpl] to cancel out heap predicates from LHS and RHS *)

(** For example, [H2] occurs on both sides, so it can be cancelled out. *)

Lemma xsimpl_demo_cancel_one : forall H1 H2 H3 H4 H5 H6 H7,
  H1 \* H2 \* H3 \* H4 ==> H5 \* H6 \* H2 \* H7.
Proof using.
  intros. xsimpl.
Abort.

(** [xsimpl] can cancel several predicates, here [H2], [H3], and [H4]. *)

Lemma xsimpl_demo_cancel_many : forall H1 H2 H3 H4 H5,
  H1 \* H2 \* H3 \* H4 ==> H4 \* H3 \* H5 \* H2.
Proof using.
  intros. xsimpl.
Abort.

(** If all the pieces get cancelled out, then the goal is discharged. *)

Lemma xsimpl_demo_cancel_all : forall H1 H2 H3 H4,
  H1 \* H2 \* H3 \* H4 ==> H4 \* H3 \* H1 \* H2.
Proof using.
  intros. xsimpl.
Qed.

(** [xsimpl] cancels what remains with the [\GC] from the RHS. *)

Lemma xsimpl_demo_rhs_hgc : forall H1 H2 H3 H4,
  H1 \* H2 \* H3 \* H4 ==> H3 \* H2 \* \GC.
Proof using.
  intros. xsimpl.
Abort.

(* ******************************************************* *)
(** *** [xsimpl] to instantiate pure facts and quantifiers in RHS *)

(** [xsimpl] instantiates existential quantifiers, pure facts,
    and [\Top] in the RHS. *)

Lemma xsimpl_demo_rhs_hpure : forall H1 H2 H3 (n:int),
  H1 ==> H2 \* \[n > 0] \* H3.
Proof using.
  intros. xsimpl.
Abort.

(** For existentials, [xsimpl] introduces an evar. *)

Lemma xsimpl_demo_rhs_hexists : forall H1 H2 H3 H4 (p:loc),
  H1 ==> H2 \* \exists (n:int), (p ~~> n \* H3) \* H4.
Proof using.
  intros. xsimpl. (* here, [p ~~> n] becomes [p ~~> ?x] *)
Abort.

(** The evar often gets subsequently instantiated during cancellation. *)

Lemma xsimpl_demo_rhs_hexists_unify : forall H1 H2 H3 H4 (p:loc),
  H1 \* (p ~~> 3) ==>
  H2 \* \exists (n:int), (p ~~> n \* H3) \* H4.
Proof using.
  intros. xsimpl. (* [p ~~~> n] becomes [p ~~~> ?x],
                     which then cancels out with [p ~~~> 3] *)
Abort.

(* ******************************************************* *)
(** ** The [xchange] tactic *)

(** [xchange] is to entailment what [rewrite] is to equality. *)

(** Assume an entailment goal of the form [H1 \* H2 \* H3 ==> H4].
    Assume an entailment assumption [M], say [H2 ==> H2'].
    Then [xchange M] turns the goal into [H1 \* H2' \* H3 ==> H4],
    effectively replacing [H2] with [H2']. *)

Lemma xchange_demo_base : forall H1 H2 H2' H3 H4,
  H2 ==> H2' ->
  H1 \* H2 \* H3 ==> H4.
Proof using.
  introv M. xchange M. (* Note that freshly produced items appear to the front *)
Abort.

(** The tactic [xchange] can also take as argument equalities.
    Use [xchange M] to exploit the left-to-right direction
    and [xchange <- M] to exploit the right-to-left direction . *)

Lemma xchange_demo_eq : forall H1 H2 H3 H4 H5,
  H1 \* H3 = H5 ->
  H1 \* H2 \* H3 ==> H4.
Proof using.
  introv M. xchange M.
  xchange <- M.
Abort.

(** The tactic [xchanges M] is a shorthand for [xchange M; xsimpl]. *)

End XsimplDemo.