(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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 Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**
   list.
   Polymorphic lists with some operations.

   @author Olga Caprotti and Martijn Oostdijk
   @version $Revision: 788 $
*)

Require Import Arith.
Require Import ZArith.
Require Import EqNat.

Require Import dec.
Require Import natZ.

(** * Polymorphic lists *)

Inductive list (A : Set) : Set :=
  | Nil : list A
  | Cons : A -> list A -> list A.

(** Length of a list *)

Fixpoint length (A : Set) (l : list A) {struct l} : nat :=
  match l with
  | Nil => 0
  | Cons a r => S (length A r)
  end.

Lemma length_0 : forall (A : Set) (l : list A), length A l = 0 -> l = Nil A.
Proof.
   intros A l. case l.
   reflexivity.
   simpl in |- *. intros. discriminate H.
Qed.

Lemma length_S :
 forall (A : Set) (l : list A) (n : nat),
 length A l = S n ->
 exists h : A, (exists t : list A, l = Cons A h t /\ length A t = n).
Proof.
   intros A l. case l.
   simpl in |- *. intros. discriminate H.
   simpl in |- *. intros h0 t0 n H. injection H. intro.
   split with h0. split with t0. split.
   reflexivity. assumption.
Qed.

(** Map a function over a list *)

Fixpoint map (A B : Set) (f : A -> B) (l : list A) {struct l} :
 list B :=
  match l with
  | Nil => Nil B
  | Cons a r => Cons B (f a) (map A B f r)
  end.

Notation Map := (map _ _) (only parsing).

Lemma map_length :
 forall (A B : Set) (f : A -> B) (l : list A),
 length A l = length B (map A B f l).
Proof.
   simple induction l.
   simpl in |- *. reflexivity.
   simpl in |- *. intros. rewrite H. reflexivity.
Qed.

(** Checks that all members of a list are P *)

Fixpoint alllist (A : Set) (P : A -> Prop) (qlist : list A) {struct qlist} :
 Prop :=
  match qlist with
  | Nil => True
  | Cons m l => P m /\ alllist A P l
  end.

Lemma alllist_dec :
 forall (A : Set) (P : A -> Prop) (l : list A),
 (forall x : A, P x \/ ~ P x) -> alllist A P l \/ ~ alllist A P l.
Proof.
   simple induction l.
   simpl in |- *. left. trivial.
   intros h t IH H. simpl in |- *.
   elim IH. elim (H h).
   left. split. assumption. assumption.
   right. intro. apply H0. elim H2. intros. assumption.
   right. intro. apply H0. elim H1. intros. assumption.
   assumption.
Qed.

(** Checks that some member of a list is P *)

Fixpoint exlist (A : Set) (P : A -> Prop) (qlist : list A) {struct qlist} :
 Prop :=
  match qlist with
  | Nil => False
  | Cons m l => P m \/ exlist A P l
  end.

Lemma exlist_dec :
 forall (A : Set) (P : A -> Prop) (l : list A),
 (forall x : A, P x \/ ~ P x) -> exlist A P l \/ ~ exlist A P l.
Proof.
   simple induction l.
   simpl in |- *. right. intro. assumption.
   intros h t IH H. simpl in |- *.
   elim (H h).
   left. left. assumption.
   elim IH.
   left. right. assumption.
   right. intro. elim H2.
   assumption. assumption.
   assumption.
Qed.

(** Membership *)

Definition inlist (A : Set) (a : A) := exlist A (fun b : A => a = b).

Lemma inlist_head_eq :
 forall (A : Set) (x y : A) (l : list A), x = y -> inlist A x (Cons A y l).
Proof.
   intros. unfold inlist in |- *. simpl in |- *.
   left. assumption.
Qed.

Lemma inlist_head_neq :
 forall (A : Set) (x y : A) (l : list A),
 x <> y -> (inlist A x (Cons A y l) <-> inlist A x l).
Proof.
   intros. unfold inlist in |- *. simpl in |- *.
   split.
   intros. elim H0. intro. elim H. assumption.
   intros. assumption.
   intros. right. assumption.
Qed.

Lemma inlist_tail :
 forall (A : Set) (x y : A) (l : list A),
 inlist A x l -> inlist A x (Cons A y l).
Proof.
   intros. unfold inlist in |- *. simpl in |- *. right. assumption.
Qed.

Lemma inlist_dec :
 forall (A : Set) (x : A) (l : list A),
 (forall a b : A, a = b \/ a <> b) -> inlist A x l \/ ~ inlist A x l.
Proof.
   intros. unfold inlist in |- *.
   apply exlist_dec. exact (H x).
Qed.

(** alllist and exlist behave nicely *)

Theorem alllist_ok :
 forall (A : Set) (P : A -> Prop) (qlist : list A),
 alllist A P qlist <-> (forall q : A, inlist A q qlist -> P q).
Proof.
   split.

   (* -> *)
   elim qlist.
   unfold inlist in |- *. simpl in |- *. intros. elim H0.
   unfold inlist in |- *. simpl in |- *. intros q l IH H. elim H. intros. elim H2.
   intro. rewrite H3. assumption.
   intro. apply IH. assumption. assumption.

   (* <- *)
   elim qlist.
   unfold inlist in |- *. simpl in |- *. intros. trivial.
   unfold inlist in |- *. simpl in |- *. intros q l IH H. split.
   apply H. left. reflexivity.
   apply IH. intros. apply H. right. assumption.
Qed.

Theorem exlist_ok :
 forall (A : Set) (P : A -> Prop) (qlist : list A),
 exlist A P qlist <-> (exists q : A, inlist A q qlist /\ P q).
Proof.
   split.

   (* -> *)
   elim qlist.
   unfold inlist in |- *. simpl in |- *. intros. elim H.
   unfold inlist in |- *. simpl in |- *. intros q l IH H. elim H.
   intro. split with q. split. left. reflexivity. assumption.
   intro. elim IH. intros q1 Hq1. elim Hq1. intros. split with q1.
   split. right. assumption. assumption. assumption.

   (* <- *)
   elim qlist.
   unfold inlist in |- *. simpl in |- *. intros. elim H. intros. elim H0. intros. elim H1.
   unfold inlist in |- *. simpl in |- *. intros q l IH H. elim H.
   intros q1 Hq1. elim Hq1. intros. elim H0.
   intro. left. rewrite <- H2. assumption.
   intro. right. apply IH. split with q1. split. assumption. assumption.
Qed.

(** * Lists of natural numbers. *)

Definition natlist := list nat.

(** Multiply all elements of a natlist *)

Fixpoint product (qlist : natlist) : nat :=
  match qlist with
  | Nil => 1
  | Cons m l => m * product l
  end.

(** Drop the first occurance of q from qlist *)

Fixpoint drop (q : nat) (qlist : natlist) {struct qlist} : natlist :=
  match qlist with
  | Nil => Nil nat
  | Cons q' l => if beq_nat q q' then l else Cons nat q' (drop q l)
  end.

(** Multiply all elements of qlist, except for (first occurance of) q *)

Definition multDrop (q : nat) (l : natlist) := product (drop q l).

Lemma multdrop_cons_eq :
 forall (q : nat) (l : natlist), multDrop q (Cons nat q l) = product l.
Proof.
   unfold multDrop in |- *. simpl in |- *. intros. elim (beq_nat_eq q q). intros.
   rewrite H. reflexivity. reflexivity.
Qed.

Lemma multdrop_cons_neq :
 forall (p q : nat) (l : natlist),
 p <> q -> multDrop p (Cons nat q l) = q * multDrop p l.
Proof.
   unfold multDrop in |- *. simpl in |- *. intros. elim (beq_nat_neq p q). intros.
   rewrite H0. simpl in |- *. reflexivity. assumption.
Qed.

Lemma multdrop_mult :
 forall (qlist : natlist) (q : nat),
 inlist nat q qlist -> q * multDrop q qlist = product qlist.
Proof.
   simple induction qlist.
   simpl in |- *. intros. elim H.
   simpl in |- *. intros q1 l IH. intros. elim (eqdec q q1).

   (* case q=q1 *)
   intro. rewrite H0. rewrite multdrop_cons_eq. reflexivity.

   (* case ~q=q1 *)
   intro. rewrite multdrop_cons_neq.
   rewrite <- (IH q). rewrite mult_assoc.
   rewrite (mult_comm q q1). rewrite mult_assoc. reflexivity.
   unfold inlist in H. simpl in H. elim H.
   intro. elim H0. assumption.
   intro. assumption.
   assumption.
Qed.

(** * Lists of integers. *)

Definition Zlist := list Z.

(** allPos checks whether all members of a Zlist are non-negative. *)

Definition allPos : Zlist -> Prop := alllist Z (fun x : Z => (x >= 0)%Z).

(** Multiply all elements of a Zlist *)

Fixpoint zproduct (l : Zlist) : Z :=
  match l with
  | Nil => 1%Z
  | Cons x t => (x * zproduct t)%Z
  end.

Lemma productzproduct :
 forall l : natlist, Z_of_nat (product l) = zproduct (map nat Z Z_of_nat l).
Proof.
   simple induction l.
   simpl in |- *. reflexivity.
   intros h t IH.
   simpl in |- *. rewrite <- IH.
   rewrite Znat.inj_mult.
   reflexivity.
Qed.

Lemma zproductproduct :
 forall l : Zlist, Zabs_nat (zproduct l) = product (map Z nat Zabs_nat l).
Proof.
   simple induction l.
   simpl in |- *. reflexivity.
   intros h t IH.
   simpl in |- *. rewrite abs_mult.
   rewrite IH. reflexivity.
Qed.

(** Drop an element from a Zlist *)

Fixpoint zdrop (x : Z) (l : Zlist) {struct l} : Zlist :=
  match l with
  | Nil => Nil Z
  | Cons h t => if Zeq_bool x h then t else Cons Z h (zdrop x t)
  end.

Lemma zdrop_head_eq :
 forall (x y : Z) (l : Zlist), x = y -> zdrop x (Cons Z y l) = l.
Proof.
   simpl in |- *. intros. elim (zeq_bool_eq x y). intros.
   rewrite H0. reflexivity. assumption.
Qed.

Lemma zdrop_head_neq :
 forall (x y : Z) (l : Zlist),
 x <> y -> zdrop x (Cons Z y l) = Cons Z y (zdrop x l).
Proof.
   simpl in |- *. intros. elim (zeq_bool_neq x y). intros.
   rewrite H0. reflexivity. assumption.
Qed.

Lemma zdrop_length :
 forall (x : Z) (l : Zlist),
 inlist Z x l -> S (length Z (zdrop x l)) = length Z l.
Proof.
   simple induction l.
   unfold inlist in |- *. simpl in |- *. intros. elim H.
   intros h t IH. intros. elim (zeqdec x h).

   (* case x=h *)
   intro. simpl in |- *. elim (zeq_bool_eq x h).
   intros. rewrite H1. reflexivity. assumption.

   (* case x<>h *)
   intro. simpl in |- *. elim (zeq_bool_neq x h).
   intros. rewrite H1. simpl in |- *. rewrite IH. reflexivity.
   elim H. intros. elim H0. assumption. intros. assumption. assumption.
Qed.

Lemma zdrop_neq_inlist :
 forall (x y : Z) (l : Zlist),
 x <> y -> inlist Z x l -> inlist Z x (zdrop y l).
Proof.
   simple induction l.
   intros. elim H0.
   intros h t IH.
   intros. elim (zeqdec x h).
   intro. rewrite zdrop_head_neq.
   apply inlist_head_eq. assumption.
   rewrite <- H1. intro. apply H. symmetry  in |- *. assumption.
   intro. elim (zeqdec y h).
   intro. rewrite zdrop_head_eq.
   elim (inlist_head_neq Z x h t).
   intros. apply H3. assumption.
   assumption. assumption.
   intro. rewrite zdrop_head_neq.
   elim (inlist_head_neq Z x h (zdrop y t)). intros.
   apply H4. apply IH. assumption.
   elim (inlist_head_neq Z x h t). intros.
   apply H5. assumption.
   assumption. assumption. assumption.
Qed.

Lemma zdrop_inlist_weak :
 forall (x y : Z) (l : Zlist), inlist Z x (zdrop y l) -> inlist Z x l.
Proof.
   simple induction l.
   unfold inlist in |- *. simpl in |- *. intro. assumption.
   intros h t IH. intros.
   elim (zeqdec x h).
   intro. rewrite H0. unfold inlist in |- *. simpl in |- *. left. reflexivity.
   intro. elim (zeqdec y h).
   intro. rewrite H1 in H. rewrite zdrop_head_eq in H.
   apply inlist_tail. assumption. reflexivity.
   intro. rewrite zdrop_head_neq in H.
   unfold inlist in H. simpl in H. elim H.
   intro. elim H0. assumption.
   intros. apply inlist_tail. apply IH. assumption.
   assumption.
Qed.

Lemma zdrop_swap :
 forall (x y : Z) (l : Zlist), zdrop x (zdrop y l) = zdrop y (zdrop x l).
Proof.
   simple induction l.
   simpl in |- *. reflexivity.
   intros h t IH.
   elim (zeqdec x h). elim (zeqdec y h).

   (* y=h, x=h *)
   intros. rewrite H. rewrite H0. reflexivity.

   (* y<>h, x=h *)
   intros.
   rewrite (zdrop_head_eq x h t).
   rewrite (zdrop_head_neq y h t).
   rewrite zdrop_head_eq. reflexivity.
   assumption. assumption. assumption.

   elim (zeqdec y h).

   (* y=h, x<>h *)
   intros.
   rewrite (zdrop_head_eq y h).
   rewrite (zdrop_head_neq x h).
   rewrite zdrop_head_eq. reflexivity.
   assumption. assumption. assumption.

   (* y<>h, x<>h *)
   intros.
   rewrite (zdrop_head_neq y h).
   rewrite (zdrop_head_neq x h).
   rewrite (zdrop_head_neq x h).
   rewrite (zdrop_head_neq y h).
   rewrite IH. reflexivity.
   assumption. assumption.
   assumption. assumption.
Qed.

Lemma zdrop_inlist_swap :
 forall (x y : Z) (l : Zlist),
 inlist Z y l -> inlist Z x (zdrop y l) -> inlist Z y (zdrop x l).
Proof.
   simple induction l.
   simpl in |- *. intro H. elim H.
   intros h t IH.
   elim (zeqdec x h). elim (zeqdec y h).

   (* y=h,x=h *)
   intros Hyh Hxh. rewrite Hyh. rewrite Hxh.
   intros. assumption.

   (* y<>h,x=h *)
   intros Hyh Hxh.
   rewrite (zdrop_head_neq y).
   rewrite (zdrop_head_eq x).
   intros. elim (inlist_head_neq Z y h t).
   intros. apply H1. assumption.
   assumption. assumption. assumption.

   elim (zeqdec y h).

   (* y=h,x<>h *)
   intros Hyh Hxh.
   rewrite (zdrop_head_eq y).
   rewrite (zdrop_head_neq x).
   intros. apply inlist_head_eq. assumption.
   assumption. assumption.

   (* y<>h, x<>h *)
   intros Hyh Hxh.
   rewrite (zdrop_head_neq y).
   rewrite (zdrop_head_neq x).
   intros. elim (inlist_head_neq Z y h (zdrop x t)).
   intros. apply H2. apply IH.
   elim (inlist_head_neq Z y h t). intros.
   apply H3. assumption. assumption.
   elim (inlist_head_neq Z x h (zdrop y t)). intros.
   apply H3. assumption.
   assumption. assumption. assumption. assumption.
Qed.

Lemma zdrop_product :
 forall (x : Z) (l : Zlist),
 inlist Z x l -> (x * zproduct (zdrop x l))%Z = zproduct l.
Proof.
   simple induction l.
   simpl in |- *. intro. elim H.
   intros h t IH. elim (zeqdec x h).
   intros. rewrite zdrop_head_eq.
   rewrite H. reflexivity. assumption.
   intros. rewrite zdrop_head_neq.
   simpl in |- *. rewrite Zmult_assoc.
   rewrite Zmult_comm with x h.
   rewrite Zmult_assoc_reverse.
   rewrite IH. reflexivity.
   elim inlist_head_neq with Z x h t. intros.
   apply H1. assumption.
   assumption. assumption.
Qed.

(** Multiply all elements except first occurance of x *)

Definition zmultDrop (x : Z) (l : Zlist) := zproduct (zdrop x l).

Lemma zmultdrop_cons_eq :
 forall (q : Z) (l : Zlist), zmultDrop q (Cons Z q l) = zproduct l.
Proof.
   unfold zmultDrop in |- *. simpl in |- *. intros. elim (zeq_bool_eq q q). intros.
   rewrite H. reflexivity. reflexivity.
Qed.

Lemma zmultdrop_cons_neq :
 forall (p q : Z) (l : Zlist),
 p <> q -> zmultDrop p (Cons Z q l) = (q * zmultDrop p l)%Z.
Proof.
   unfold zmultDrop in |- *. simpl in |- *. intros. elim (zeq_bool_neq p q). intros.
   rewrite H0. simpl in |- *. reflexivity. assumption.
Qed.

Lemma zmultdrop_mult :
 forall (qlist : Zlist) (q : Z),
 inlist Z q qlist -> (q * zmultDrop q qlist)%Z = zproduct qlist.
Proof.
   simple induction qlist.
   simpl in |- *. intros. elim H.
   simpl in |- *. intros q1 l IH. intros. elim (zeqdec q q1).

   (* case q=q1 *)
   intro. rewrite H0. rewrite zmultdrop_cons_eq. reflexivity.

   (* case ~q=q1 *)
   intro. rewrite zmultdrop_cons_neq.
   rewrite <- (IH q). rewrite Zmult_assoc.
   rewrite (Zmult_comm q q1). rewrite Zmult_assoc. reflexivity.
   unfold inlist in H. simpl in H. elim H.
   intro. elim H0. assumption.
   intro. assumption.
   assumption.
Qed.

Lemma multdropzmultdrop :
 forall (q : nat) (qlist : natlist),
 Z_of_nat (multDrop q qlist) =
 zmultDrop (Z_of_nat q) (map nat Z Z_of_nat qlist).
Proof.
   simple induction qlist.
   simpl in |- *. reflexivity.
   intros h t.
   elim (eqdec q h).

   (* q=h *)
   intro H. rewrite H. simpl in |- *.
   rewrite multdrop_cons_eq.
   rewrite zmultdrop_cons_eq.
   rewrite productzproduct.
   intro IH. reflexivity.

   (* ~q=h *)
   intro H. simpl in |- *.
   rewrite multdrop_cons_neq.
   rewrite zmultdrop_cons_neq.
   intro IH. rewrite <- IH.
   rewrite Znat.inj_mult. reflexivity.
   intro. apply H.
   rewrite <- (abs_inj q). rewrite <- (abs_inj h).
   rewrite H0. reflexivity.
   assumption.
Qed.

(** Multiply all elements in list with a *)

Definition mapmult (a : Z) (l : Zlist) := map Z Z (fun x : Z => (a * x)%Z) l.

Lemma mapmult_image :
 forall (a : Z) (l : Zlist) (x : Z),
 inlist Z x l -> inlist Z (a * x)%Z (mapmult a l).
Proof.
   unfold mapmult in |- *. unfold inlist in |- *. simple induction l.
   simpl in |- *. intros. assumption.
   simpl in |- *. intros h t IH. intros. elim H.
   left. rewrite H0. reflexivity.
   right. apply IH. assumption.
Qed.

Lemma mapmult_orig :
 forall (a : Z) (l : Zlist) (y : Z),
 inlist Z y (mapmult a l) -> exists x : Z, inlist Z x l /\ y = (a * x)%Z.
Proof.
   unfold mapmult in |- *. unfold inlist in |- *. simple induction l.
   simpl in |- *. intros. elim H.
   simpl in |- *. intros h t IH. intros.
   elim H.
   intro. split with h. split. left. reflexivity. assumption.
   intro. elim (IH y). intros. elim H1. intros.
   split with x. split. right.
   assumption. assumption. assumption.
Qed.

(** Lift inject_nat and absolu to natlist and Zlist. *)

Lemma abs_inj_list :
 forall l : natlist, map _ _ Zabs_nat (map _ _ Z_of_nat l) = l.
Proof.
   simple induction l.
   simpl in |- *. reflexivity.
   simpl in |- *. intros h t IH.
   rewrite abs_inj. rewrite IH. reflexivity.
Qed.

Lemma inj_abs_pos_list :
 forall l : Zlist, allPos l -> map _ _ Z_of_nat (map _ _ Zabs_nat l) = l.
Proof.
   simple induction l.
   simpl in |- *. intros. reflexivity.
   simpl in |- *. intros h t IH H. elim H. intros.
   rewrite inj_abs_pos. rewrite IH. reflexivity.
   assumption. assumption.
Qed.

Lemma inlist_inj_abs_pos_list :
 forall (q : nat) (l : Zlist),
 allPos l -> inlist nat q (map Z nat Zabs_nat l) -> inlist Z (Z_of_nat q) l.
Proof.
   simple induction l.
   unfold inlist in |- *. simpl in |- *. intros. assumption.
   unfold inlist in |- *. unfold allPos in |- *. simpl in |- *.
   intros h t IH Hp H. elim Hp. elim H.
   left. rewrite H0. rewrite inj_abs_pos. reflexivity.
   intros. assumption.
   right. apply IH. assumption. assumption.
Qed.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma lfind_hyp_test : (@eq bool (eqb (Zero) (Zero)) true).
Admitted.
QuickChick lfind_hyp_test.


Require Export GeoCoq.Elements.OriginalProofs.lemma_parallelcollinear.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_paralleldef2B :
   forall A B C D,
   Par A B C D ->
   TP A B C D.
Proof.
intros.
let Tf:=fresh in
assert (Tf:exists a b c d e, (neq A B /\ neq C D /\ Col A B a /\ Col A B b /\ neq a b /\ Col C D c /\ Col C D d /\ neq c d /\ ~ Meet A B C D /\ BetS a e d /\ BetS c e b)) by (conclude_def Par );destruct Tf as [a[b[c[d[e]]]]];spliter.
assert (neq b a) by (conclude lemma_inequalitysymmetric).
assert (neq e b) by (forward_using lemma_betweennotequal).
assert (~ Meet a b C D).
 {
 intro.
 let Tf:=fresh in
 assert (Tf:exists R, (neq a b /\ neq C D /\ Col a b R /\ Col C D R)) by (conclude_def Meet );destruct Tf as [R];spliter.
 assert (Col b a R) by (forward_using lemma_collinearorder).
 assert (Col B a b) by (conclude lemma_collinear4).
 assert (Col b a B) by (forward_using lemma_collinearorder).
 assert (Col a B R) by (conclude lemma_collinear4).
 assert (Col a B A) by (forward_using lemma_collinearorder).
 assert (Col A B R).
 by cases on (neq a B \/ eq a B).
 {
  assert (Col B R A) by (conclude lemma_collinear4).
  assert (Col A B R) by (forward_using lemma_collinearorder).
  close.
  }
 {
  assert (neq A a) by (conclude cn_equalitysub).
  assert (Col B A a) by (forward_using lemma_collinearorder).
  assert (Col B A b) by (forward_using lemma_collinearorder).
  assert (neq B A) by (conclude lemma_inequalitysymmetric).
  assert (Col A a b) by (conclude lemma_collinear4).
  assert (Col b a A) by (forward_using lemma_collinearorder).
  assert (Col a A R) by (conclude lemma_collinear4).
  assert (Col a A B) by (forward_using lemma_collinearorder).
  assert (neq A a) by (conclude cn_equalitysub).
  assert (neq a A) by (conclude lemma_inequalitysymmetric).
  assert (Col A R B) by (conclude lemma_collinear4).
  assert (Col A B R) by (forward_using lemma_collinearorder).
  close.
  }
(** cases *)
 assert (Meet A B C D) by (conclude_def Meet ).
 contradict.
 }
let Tf:=fresh in
assert (Tf:exists P, (BetS e b P /\ Cong b P e b)) by (conclude lemma_extension);destruct Tf as [P];spliter.
assert (BetS P b e) by (conclude axiom_betweennesssymmetry).
assert (BetS b e c) by (conclude axiom_betweennesssymmetry).
assert (BetS P b c) by (conclude lemma_3_7b).
assert (BetS c b P) by (conclude axiom_betweennesssymmetry).
assert (~ Col a d P).
 {
 intro.
 assert (Col a e d) by (conclude_def Col ).
 assert (Col a d e) by (forward_using lemma_collinearorder).
 assert (neq a d) by (forward_using lemma_betweennotequal).
 assert (Col d P e) by (conclude lemma_collinear4).
 assert (Col e P d) by (forward_using lemma_collinearorder).
 assert (Col e b P) by (conclude_def Col ).
 assert (Col e P b) by (forward_using lemma_collinearorder).
 assert (neq e P) by (forward_using lemma_betweennotequal).
 assert (Col P d b) by (conclude lemma_collinear4).
 assert (Col d P b) by (forward_using lemma_collinearorder).
 assert (Col d P a) by (forward_using lemma_collinearorder).
 assert (~ eq d P).
  {
  intro.
  assert (Col c b P) by (conclude_def Col ).
  assert (Col c b d) by (conclude cn_equalitysub).
  assert (Col b e c) by (conclude_def Col ).
  assert (Col c b e) by (forward_using lemma_collinearorder).
  assert (neq c b) by (forward_using lemma_betweennotequal).
  assert (Col b d e) by (conclude lemma_collinear4).
  assert (Col a e d) by (conclude_def Col ).
  assert (Col d e a) by (forward_using lemma_collinearorder).
  assert (Col d e b) by (forward_using lemma_collinearorder).
  assert (neq e d) by (forward_using lemma_betweennotequal).
  assert (neq d e) by (conclude lemma_inequalitysymmetric).
  assert (Col e a b) by (conclude lemma_collinear4).
  assert (Col a e d) by (conclude_def Col ).
  assert (Col e a d) by (forward_using lemma_collinearorder).
  assert (neq a e) by (forward_using lemma_betweennotequal).
  assert (neq e a) by (conclude lemma_inequalitysymmetric).
  assert (Col a b d) by (conclude lemma_collinear4).
  assert (Meet a b C D) by (conclude_def Meet ).
  contradict.
  }
 assert (Col P b a) by (conclude lemma_collinear4).
 assert (Col P b c) by (conclude_def Col ).
 assert (neq b P) by (forward_using lemma_betweennotequal).
 assert (neq P b) by (conclude lemma_inequalitysymmetric).
 assert (Col b a c) by (conclude lemma_collinear4).
 assert (Col B a b) by (conclude lemma_collinear4).
 assert (Col b a B) by (forward_using lemma_collinearorder).
 assert (Col a b c) by (forward_using lemma_collinearorder).
 assert (eq c c) by (conclude cn_equalityreflexive).
 assert (Meet a b C D) by (conclude_def Meet ).
 contradict.
 }
let Tf:=fresh in
assert (Tf:exists M, (BetS P M d /\ BetS a b M)) by (conclude postulate_Pasch_outer);destruct Tf as [M];spliter.
assert (BetS M b a) by (conclude axiom_betweennesssymmetry).
assert (BetS P b c) by (conclude axiom_betweennesssymmetry).
assert (Col a b M) by (conclude_def Col ).
assert (Col B a b) by (conclude lemma_collinear4).
assert (Col b a B) by (forward_using lemma_collinearorder).
assert (Col b a M) by (forward_using lemma_collinearorder).
assert (neq b a) by (conclude lemma_inequalitysymmetric).
assert (Col a B M) by (conclude lemma_collinear4).
assert (Col a B A) by (forward_using lemma_collinearorder).
assert (Col A B M).
by cases on (neq a B \/ eq a B).
{
 assert (Col B M A) by (conclude lemma_collinear4).
 assert (Col A B M) by (forward_using lemma_collinearorder).
 close.
 }
{
 assert (neq A a) by (conclude cn_equalitysub).
 assert (Col A a b) by (conclude cn_equalitysub).
 assert (Col b a A) by (forward_using lemma_collinearorder).
 assert (Col a A M) by (conclude lemma_collinear4).
 assert (Col a A B) by (forward_using lemma_collinearorder).
 assert (neq a A) by (conclude lemma_inequalitysymmetric).
 assert (Col A M B) by (conclude lemma_collinear4).
 assert (Col A B M) by (forward_using lemma_collinearorder).
 close.
 }
(** cases *)
assert (BetS c b P) by (conclude axiom_betweennesssymmetry).
assert (BetS d M P) by (conclude axiom_betweennesssymmetry).
assert (~ Col A B c).
 {
 intro.
 assert (Meet A B C D) by (conclude_def Meet ).
 contradict.
 }
assert (~ Col A B d).
 {
 intro.
 assert (Meet A B C D) by (conclude_def Meet ).
 contradict.
 }
assert (OS c d A B) by (conclude_def OS ).
assert (~ Meet A B c d).
 {
 intro.
 let Tf:=fresh in
 assert (Tf:exists R, (neq A B /\ neq c d /\ Col A B R /\ Col c d R)) by (conclude_def Meet );destruct Tf as [R];spliter.
 assert (Col D c d) by (conclude lemma_collinear4).
 assert (Col D C c) by (forward_using lemma_collinearorder).
 assert (Col D C d) by (forward_using lemma_collinearorder).
 assert (neq D C) by (conclude lemma_inequalitysymmetric).
 assert (Col C c d) by (conclude lemma_collinear4).
 assert (Col c d C) by (forward_using lemma_collinearorder).
 assert (Col c d D) by (forward_using lemma_collinearorder).
 assert (Col C D R) by (conclude lemma_collinear5).
 assert (Meet A B C D) by (conclude_def Meet ).
 contradict.
 }
assert (TP A B c d) by (conclude_def TP ).
assert (eq C C) by (conclude cn_equalityreflexive).
assert (Col C D C) by (conclude_def Col ).
assert (Col c d C) by (conclude lemma_collinear5).
assert (~ ~ TP A B C D).
 {
 intro.
 assert (neq D C) by (conclude lemma_inequalitysymmetric).
 assert (~ neq C d).
  {
  intro.
  assert (TP A B C d) by (conclude lemma_parallelcollinear).
  assert (TP A B d C) by (forward_using lemma_tarskiparallelflip).
  assert (Col d C D) by (forward_using lemma_collinearorder).
  assert (TP A B D C) by (conclude lemma_parallelcollinear).
  assert (TP A B C D) by (forward_using lemma_tarskiparallelflip).
  contradict.
  }
 assert (TP A B c C) by (conclude cn_equalitysub).
 assert (Col c C D) by (forward_using lemma_collinearorder).
 assert (TP A B D C) by (conclude lemma_parallelcollinear).
 assert (TP A B C D) by (forward_using lemma_tarskiparallelflip).
 contradict.
 }
close.
Qed.

End Euclid.


From iris.bi Require Export bi.
From iris.proofmode Require Import tactics.
From iris Require Import options.

(* The sections add extra BI assumptions, which is only picked up with "Type"*. *)
Set Default Proof Using "Type*".

(** This proves that in an affine BI (i.e., a BI that enjoys [P ∗ Q ⊢ P]), the
classical excluded middle ([P ∨ ¬P]) axiom makes the separation conjunction
trivial, i.e., it gives [P -∗ P ∗ P] and [P ∧ Q -∗ P ∗ Q].

Our proof essentially follows the structure of the proof of Theorem 3 in
https://scholar.princeton.edu/sites/default/files/qinxiang/files/putting_order_to_the_separation_logic_jungle_revised_version.pdf *)
Module affine_em. Section affine_em.
  Context `{!BiAffine PROP}.
  Context (em : ∀ P : PROP, ⊢ P ∨ ¬P).
  Implicit Types P Q : PROP.

  Lemma sep_dup P : P -∗ P ∗ P.
  Proof.
    iIntros "HP". iDestruct (em P) as "[HP'|HnotP]".
    - iFrame "HP HP'".
    - iExFalso. by iApply "HnotP".
  Qed.

  Lemma and_sep P Q : P ∧ Q -∗ P ∗ Q.
  Proof.
    iIntros "HPQ". iDestruct (sep_dup with "HPQ") as "[HPQ HPQ']".
    iSplitL "HPQ".
    - by iDestruct "HPQ" as "[HP _]".
    - by iDestruct "HPQ'" as "[_ HQ]".
  Qed.
End affine_em. End affine_em.

(** This proves that the combination of Löb induction [(▷ P → P) ⊢ P] and the
classical excluded-middle [P ∨ ¬P] axiom makes the later operator trivial, i.e.,
it gives [▷ P] for any [P], or equivalently [▷ P ≡ True]. *)
Module löb_em. Section löb_em.
  Context `{!BiLöb PROP}.
  Context (em : ∀ P : PROP, ⊢ P ∨ ¬P).
  Implicit Types P : PROP.

  Lemma later_anything P : ⊢@{PROP} ▷ P.
  Proof.
    iDestruct (em (▷ False)%I) as "#[HP|HnotP]".
    - iNext. done.
    - iExFalso. iLöb as "IH". iSpecialize ("HnotP" with "IH"). done.
  Qed.
End löb_em. End löb_em.

(** This proves that we need the ▷ in a "Saved Proposition" construction with
name-dependent allocation. *)
Module savedprop. Section savedprop.
  Context `{BiAffine PROP}.
  Implicit Types P : PROP.

  Context (bupd : PROP → PROP).
  Notation "|==> Q" := (bupd Q)
    (at level 99, Q at level 200, format "|==>  Q") : bi_scope.

  Hypothesis bupd_intro : ∀ P, P ⊢ |==> P.
  Hypothesis bupd_mono : ∀ P Q, (P ⊢ Q) → (|==> P) ⊢ |==> Q.
  Hypothesis bupd_trans : ∀ P, (|==> |==> P) ⊢ |==> P.
  Hypothesis bupd_frame_r : ∀ P R, (|==> P) ∗ R ⊢ |==> (P ∗ R).

  Context (ident : Type) (saved : ident → PROP → PROP).
  Hypothesis sprop_persistent : ∀ i P, Persistent (saved i P).
  Hypothesis sprop_alloc_dep :
    ∀ (P : ident → PROP), ⊢ (|==> ∃ i, saved i (P i)).
  Hypothesis sprop_agree : ∀ i P Q, saved i P ∧ saved i Q ⊢ □ (P ↔ Q).

  (** We assume that we cannot update to false. *)
  Hypothesis consistency : ¬(⊢ |==> False).

  Instance bupd_mono' : Proper ((⊢) ==> (⊢)) bupd.
  Proof. intros P Q ?. by apply bupd_mono. Qed.
  Instance elim_modal_bupd p P Q : ElimModal True p false (|==> P) P (|==> Q) (|==> Q).
  Proof.
    by rewrite /ElimModal bi.intuitionistically_if_elim
      bupd_frame_r bi.wand_elim_r bupd_trans.
  Qed.

  (** A bad recursive reference: "Assertion with name [i] does not hold" *)
  Definition A (i : ident) : PROP := (∃ P, □ ¬ P ∗ saved i P)%I.

  Lemma A_alloc : ⊢ |==> ∃ i, saved i (A i).
  Proof. by apply sprop_alloc_dep. Qed.

  Lemma saved_NA i : saved i (A i) ⊢ ¬ A i.
  Proof.
    iIntros "#Hs #HA". iPoseProof "HA" as "HA'".
    iDestruct "HA'" as (P) "[HNP HsP]". iApply "HNP".
    iDestruct (sprop_agree i P (A i) with "[]") as "#[_ HP]".
    { eauto. }
    iApply "HP". done.
  Qed.

  Lemma saved_A i : saved i (A i) ⊢ A i.
  Proof.
    iIntros "#Hs". iExists (A i). iFrame "Hs".
    iIntros "!>". by iApply saved_NA.
  Qed.

  Lemma contradiction : False.
  Proof using All.
    apply consistency.
    iMod A_alloc as (i) "#H".
    iPoseProof (saved_NA with "H") as "HN".
    iApply bupd_intro. iApply "HN". iApply saved_A. done.
  Qed.
End savedprop. End savedprop.

(** This proves that we need the ▷ when opening invariants. *)
Module inv. Section inv.
  Context `{BiAffine PROP}.
  Implicit Types P : PROP.

  (** Assumptions *)
  (** We have the update modality (two classes: empty/full mask) *)
  Inductive mask := M0 | M1.
  Context (fupd : mask → PROP → PROP).
  Arguments fupd _ _%I.
  Hypothesis fupd_intro : ∀ E P, P ⊢ fupd E P.
  Hypothesis fupd_mono : ∀ E P Q, (P ⊢ Q) → fupd E P ⊢ fupd E Q.
  Hypothesis fupd_fupd : ∀ E P, fupd E (fupd E P) ⊢ fupd E P.
  Hypothesis fupd_frame_l : ∀ E P Q, P ∗ fupd E Q ⊢ fupd E (P ∗ Q).
  Hypothesis fupd_mask_mono : ∀ P, fupd M0 P ⊢ fupd M1 P.

  (** We have invariants *)
  Context (name : Type) (inv : name → PROP → PROP).
  Arguments inv _ _%I.
  Hypothesis inv_persistent : ∀ i P, Persistent (inv i P).
  Hypothesis inv_alloc : ∀ P, P ⊢ fupd M1 (∃ i, inv i P).
  Hypothesis inv_fupd :
    ∀ i P Q R, (P ∗ Q ⊢ fupd M0 (P ∗ R)) → (inv i P ∗ Q ⊢ fupd M1 R).

  (* We have tokens for a little "two-state STS": [start] -> [finish].
     state. [start] also asserts the exact state; it is only ever owned by the
     invariant.  [finished] is duplicable. *)
  (* Posssible implementations of these axioms:
     * Using the STS monoid of a two-state STS, where [start] is the
       authoritative saying the state is exactly [start], and [finish]
       is the "we are at least in state [finish]" typically owned by threads.
     * Ex () +_## ()
  *)
  Context (gname : Type).
  Context (start finished : gname → PROP).

  Hypothesis sts_alloc : ⊢ fupd M0 (∃ γ, start γ).
  Hypotheses start_finish : ∀ γ, start γ ⊢ fupd M0 (finished γ).

  Hypothesis finished_not_start : ∀ γ, start γ ∗ finished γ ⊢ False.

  Hypothesis finished_dup : ∀ γ, finished γ ⊢ finished γ ∗ finished γ.

  (** We assume that we cannot update to false. *)
  Hypothesis consistency : ¬ (⊢ fupd M1 False).

  (** Some general lemmas and proof mode compatibility. *)
  Lemma inv_fupd' i P R : inv i P ∗ (P -∗ fupd M0 (P ∗ fupd M1 R)) ⊢ fupd M1 R.
  Proof.
    iIntros "(#HiP & HP)". iApply fupd_fupd. iApply inv_fupd; last first.
    { iSplit; first done. iExact "HP". }
    iIntros "(HP & HPw)". by iApply "HPw".
  Qed.

  Instance fupd_mono' E : Proper ((⊢) ==> (⊢)) (fupd E).
  Proof. intros P Q ?. by apply fupd_mono. Qed.
  Instance fupd_proper E : Proper ((⊣⊢) ==> (⊣⊢)) (fupd E).
  Proof.
    intros P Q; rewrite !bi.equiv_spec=> -[??]; split; by apply fupd_mono.
  Qed.

  Lemma fupd_frame_r E P Q : fupd E P ∗ Q ⊢ fupd E (P ∗ Q).
  Proof. by rewrite comm fupd_frame_l comm. Qed.

  Global Instance elim_fupd_fupd p E P Q :
    ElimModal True p false (fupd E P) P (fupd E Q) (fupd E Q).
  Proof.
    by rewrite /ElimModal bi.intuitionistically_if_elim
      fupd_frame_r bi.wand_elim_r fupd_fupd.
  Qed.

  Global Instance elim_fupd0_fupd1 p P Q :
    ElimModal True p false (fupd M0 P) P (fupd M1 Q) (fupd M1 Q).
  Proof.
    by rewrite /ElimModal bi.intuitionistically_if_elim
      fupd_frame_r bi.wand_elim_r fupd_mask_mono fupd_fupd.
  Qed.

  Global Instance exists_split_fupd0 {A} E P (Φ : A → PROP) :
    FromExist P Φ → FromExist (fupd E P) (λ a, fupd E (Φ a)).
  Proof.
    rewrite /FromExist=>HP. apply bi.exist_elim=> a.
    apply fupd_mono. by rewrite -HP -(bi.exist_intro a).
  Qed.

  (** Now to the actual counterexample. We start with a weird form of saved propositions. *)
  Definition saved (γ : gname) (P : PROP) : PROP :=
    (∃ i, inv i (start γ ∨ (finished γ ∗ □ P)))%I.
  Global Instance saved_persistent γ P : Persistent (saved γ P) := _.

  Lemma saved_alloc (P : gname → PROP) : ⊢ fupd M1 (∃ γ, saved γ (P γ)).
  Proof.
    iIntros "". iMod (sts_alloc) as (γ) "Hs".
    iMod (inv_alloc (start γ ∨ (finished γ ∗ □ (P γ)))%I with "[Hs]") as (i) "#Hi".
    { auto. }
    iApply fupd_intro. by iExists γ, i.
  Qed.

  Lemma saved_cast γ P Q : saved γ P ∗ saved γ Q ∗ □ P ⊢ fupd M1 (□ Q).
  Proof.
    iIntros "(#HsP & #HsQ & #HP)". iDestruct "HsP" as (i) "HiP".
    iApply (inv_fupd' i). iSplit; first done.
    iIntros "HaP". iAssert (fupd M0 (finished γ)) with "[HaP]" as "> Hf".
    { iDestruct "HaP" as "[Hs | [Hf _]]".
      - by iApply start_finish.
      - by iApply fupd_intro. }
    iDestruct (finished_dup with "Hf") as "[Hf Hf']".
    iApply fupd_intro. iSplitL "Hf'"; first by eauto.
    (* Step 2: Open the Q-invariant. *)
    iClear (i) "HiP ". iDestruct "HsQ" as (i) "HiQ".
    iApply (inv_fupd' i). iSplit; first done.
    iIntros "[HaQ | [_ #HQ]]".
    { iExFalso. iApply finished_not_start. by iFrame. }
    iApply fupd_intro. iSplitL "Hf".
    { iRight. by iFrame. }
    by iApply fupd_intro.
  Qed.

  (** And now we tie a bad knot. *)
  Notation not_fupd P := (□ (P -∗ fupd M1 False))%I.
  Definition A i : PROP := (∃ P, not_fupd P ∗ saved i P)%I.
  Global Instance A_persistent i : Persistent (A i) := _.

  Lemma A_alloc : ⊢ fupd M1 (∃ i, saved i (A i)).
  Proof. by apply saved_alloc. Qed.

  Lemma saved_NA i : saved i (A i) ⊢ not_fupd (A i).
  Proof.
    iIntros "#Hi !> #HA". iPoseProof "HA" as "HA'".
    iDestruct "HA'" as (P) "#[HNP Hi']".
    iMod (saved_cast i (A i) P with "[]") as "HP".
    { eauto. }
    by iApply "HNP".
  Qed.

  Lemma saved_A i : saved i (A i) ⊢ A i.
  Proof.
    iIntros "#Hi". iExists (A i). iFrame "#".
    by iApply saved_NA.
  Qed.

  Lemma contradiction : False.
  Proof using All.
    apply consistency. iIntros "".
    iMod A_alloc as (i) "#H".
    iPoseProof (saved_NA with "H") as "HN".
    iApply "HN". iApply saved_A. done.
  Qed.
End inv. End inv.

(** This proves that if we have linear impredicative invariants, we can still
drop arbitrary resources (i.e., we can "defeat" linearity).
We assume [cinv_alloc] without any bells or whistles.
Moreover, we also have an accessor that gives back the invariant token
immediately, not just after the invariant got closed again.

The assumptions here match the proof rules in Iron, save for the side-condition
that the invariant must be "uniform".  In particular, [cinv_alloc] delays
handing out the [cinv_own] token until after the invariant has been created so
that this can match Iron by picking [cinv_own γ := fcinv_own γ 1 ∗
fcinv_cancel_own γ 1]. This means [cinv_own] is not "uniform" in Iron terms,
which is why Iron does not suffer from this contradiction.

This also loosely matches VST's locks with stored resource invariants.
There, the stronger variant of the "unlock" rule (see Aquinas Hobor's PhD thesis
"Oracle Semantics", §4.7, p. 88) also permits putting the token of a lock
entirely into that lock.
*)
Module linear. Section linear.
  Context {PROP: bi}.
  Implicit Types P : PROP.

  (** Assumptions. *)
  (** We have the mask-changing update modality (two classes: empty/full mask) *)
  Inductive mask := M0 | M1.
  Context (fupd : mask → mask → PROP → PROP).
  Arguments fupd _ _ _%I.
  Hypothesis fupd_intro : ∀ E P, P ⊢ fupd E E P.
  Hypothesis fupd_mono : ∀ E1 E2 P Q, (P ⊢ Q) → fupd E1 E2 P ⊢ fupd E1 E2 Q.
  Hypothesis fupd_fupd : ∀ E1 E2 E3 P, fupd E1 E2 (fupd E2 E3 P) ⊢ fupd E1 E3 P.
  Hypothesis fupd_frame_l : ∀ E1 E2 P Q, P ∗ fupd E1 E2 Q ⊢ fupd E1 E2 (P ∗ Q).

  (** We have cancelable invariants. (Really they would have fractions at
  [cinv_own] but we do not need that. They would also have a name matching
  the [mask] type, but we do not need that either.) *)
  Context (gname : Type) (cinv : gname → PROP → PROP) (cinv_own : gname → PROP).
  Hypothesis cinv_alloc : ∀ E P,
    ▷ P -∗ fupd E E (∃ γ, cinv γ P ∗ cinv_own γ).
  Hypothesis cinv_acc : ∀ P γ,
    cinv γ P -∗ cinv_own γ -∗ fupd M1 M0 (▷ P ∗ cinv_own γ ∗ (▷ P -∗ fupd M0 M1 emp)).

  (** Some general lemmas and proof mode compatibility. *)
  Instance fupd_mono' E1 E2 : Proper ((⊢) ==> (⊢)) (fupd E1 E2).
  Proof. intros P Q ?. by apply fupd_mono. Qed.
  Instance fupd_proper E1 E2 : Proper ((⊣⊢) ==> (⊣⊢)) (fupd E1 E2).
  Proof.
    intros P Q; rewrite !bi.equiv_spec=> -[??]; split; by apply fupd_mono.
  Qed.

  Lemma fupd_frame_r E1 E2 P Q : fupd E1 E2 P ∗ Q ⊢ fupd E1 E2 (P ∗ Q).
  Proof. by rewrite comm fupd_frame_l comm. Qed.

  Global Instance elim_fupd_fupd p E1 E2 E3 P Q :
    ElimModal True p false (fupd E1 E2 P) P (fupd E1 E3 Q) (fupd E2 E3 Q).
  Proof.
    by rewrite /ElimModal bi.intuitionistically_if_elim
      fupd_frame_r bi.wand_elim_r fupd_fupd.
  Qed.

  (** Counterexample: now we can make any resource disappear. *)
  Lemma leak P : P -∗ fupd M1 M1 emp.
  Proof.
    iIntros "HP".
    iMod ((cinv_alloc _ True%I) with "[//]") as (γ) "[Hinv Htok]".
    iMod (cinv_acc with "Hinv Htok") as "(Htrue & Htok & Hclose)".
    iApply "Hclose". done.
  Qed.
End linear. End linear.


(** This file provides the unbounded fractional authoritative camera: a version
of the fractional authoritative camera that can be used with fractions [> 1].

Most of the reasoning principles for this version of the fractional
authoritative cameras are the same as for the original version. There are two
difference:

- We get the additional rule that can be used to allocate a "surplus", i.e.
  if we have the authoritative element we can always increase its fraction
  and allocate a new fragment.

<<
✓ (a ⋅ b) → ●U_p a ~~> ●U_(p + q) (a ⋅ b) ⋅ ◯U_q b
>>

- We no longer have the [◯U_1 a] is an exclusive fragmental element. That is,
  while [◯F{1} a ⋅ ◯F{q} b] is vacuously false, [◯U_1 a ⋅ ◯U_q2 b] is not.
*)
From iris.algebra Require Export auth frac updates local_updates.
From iris.algebra Require Import ufrac proofmode_classes.
From iris.prelude Require Import options.

Definition ufrac_authR (A : cmra) : cmra :=
  authR (optionUR (prodR ufracR A)).
Definition ufrac_authUR (A : cmra) : ucmra :=
  authUR (optionUR (prodR ufracR A)).

(** Note in the signature of [ufrac_auth_auth] and [ufrac_auth_frag] we use
[q : Qp] instead of [q : ufrac]. This way, the API does not expose that [ufrac]
is used internally. This is quite important, as there are two canonical camera
instances with carrier [Qp], namely [fracR] and [ufracR]. When writing things
like [ufrac_auth_auth q a ∧ ✓ q] we want Coq to infer the type of [q] as [Qp]
such that the [✓] of the default [fracR] camera is used, and not the [✓] of
the [ufracR] camera. *)
Definition ufrac_auth_auth {A : cmra} (q : Qp) (x : A) : ufrac_authR A :=
  ● (Some (q : ufracR,x)).
Definition ufrac_auth_frag {A : cmra} (q : Qp) (x : A) : ufrac_authR A :=
  ◯ (Some (q : ufracR,x)).

Typeclasses Opaque ufrac_auth_auth ufrac_auth_frag.

Global Instance: Params (@ufrac_auth_auth) 2 := {}.
Global Instance: Params (@ufrac_auth_frag) 2 := {}.

Notation "●U_ q a" := (ufrac_auth_auth q a) (at level 10, q at level 9, format "●U_ q  a").
Notation "◯U_ q a" := (ufrac_auth_frag q a) (at level 10, q at level 9, format "◯U_ q  a").

Section ufrac_auth.
  Context {A : cmra}.
  Implicit Types a b : A.

  Global Instance ufrac_auth_auth_ne q : NonExpansive (@ufrac_auth_auth A q).
  Proof. solve_proper. Qed.
  Global Instance ufrac_auth_auth_proper q : Proper ((≡) ==> (≡)) (@ufrac_auth_auth A q).
  Proof. solve_proper. Qed.
  Global Instance ufrac_auth_frag_ne q : NonExpansive (@ufrac_auth_frag A q).
  Proof. solve_proper. Qed.
  Global Instance ufrac_auth_frag_proper q : Proper ((≡) ==> (≡)) (@ufrac_auth_frag A q).
  Proof. solve_proper. Qed.

  Global Instance ufrac_auth_auth_discrete q a : Discrete a → Discrete (●U_q a).
  Proof. intros. apply auth_auth_discrete; [apply Some_discrete|]; apply _. Qed.
  Global Instance ufrac_auth_frag_discrete q a : Discrete a → Discrete (◯U_q a).
  Proof. intros. apply auth_frag_discrete; apply Some_discrete; apply _. Qed.

  Lemma ufrac_auth_validN n a p : ✓{n} a → ✓{n} (●U_p a ⋅ ◯U_p a).
  Proof. by rewrite auth_both_validN. Qed.
  Lemma ufrac_auth_valid p a : ✓ a → ✓ (●U_p a ⋅ ◯U_p a).
  Proof. intros. by apply auth_both_valid_2. Qed.

  Lemma ufrac_auth_agreeN n p a b : ✓{n} (●U_p a ⋅ ◯U_p b) → a ≡{n}≡ b.
  Proof.
    rewrite auth_both_validN=> -[/Some_includedN [[_ ? //]|Hincl] _].
    move: Hincl=> /pair_includedN=> -[/ufrac_included Hincl _].
    by destruct (irreflexivity (<)%Qp p).
  Qed.
  Lemma ufrac_auth_agree p a b : ✓ (●U_p a ⋅ ◯U_p b) → a ≡ b.
  Proof.
    intros. apply equiv_dist=> n. by eapply ufrac_auth_agreeN, cmra_valid_validN.
  Qed.
  Lemma ufrac_auth_agree_L `{!LeibnizEquiv A} p a b : ✓ (●U_p a ⋅ ◯U_p b) → a = b.
  Proof. intros. by eapply leibniz_equiv, ufrac_auth_agree. Qed.

  Lemma ufrac_auth_includedN n p q a b : ✓{n} (●U_p a ⋅ ◯U_q b) → Some b ≼{n} Some a.
  Proof. by rewrite auth_both_validN=> -[/Some_pair_includedN [_ ?] _]. Qed.
  Lemma ufrac_auth_included `{!CmraDiscrete A} q p a b :
    ✓ (●U_p a ⋅ ◯U_q b) → Some b ≼ Some a.
  Proof. rewrite auth_both_valid_discrete=> -[/Some_pair_included [_ ?] _] //. Qed.
  Lemma ufrac_auth_includedN_total `{!CmraTotal A} n q p a b :
    ✓{n} (●U_p a ⋅ ◯U_q b) → b ≼{n} a.
  Proof. intros. by eapply Some_includedN_total, ufrac_auth_includedN. Qed.
  Lemma ufrac_auth_included_total `{!CmraDiscrete A, !CmraTotal A} q p a b :
    ✓ (●U_p a ⋅ ◯U_q b) → b ≼ a.
  Proof. intros. by eapply Some_included_total, ufrac_auth_included. Qed.

  Lemma ufrac_auth_auth_validN n q a : ✓{n} (●U_q a) ↔ ✓{n} a.
  Proof.
    rewrite auth_auth_dfrac_validN Some_validN. split.
    - by intros [?[]].
    - intros. by split.
  Qed.
  Lemma ufrac_auth_auth_valid q a : ✓ (●U_q a) ↔ ✓ a.
  Proof. rewrite !cmra_valid_validN. by setoid_rewrite ufrac_auth_auth_validN. Qed.

  Lemma ufrac_auth_frag_validN n q a : ✓{n} (◯U_q a) ↔ ✓{n} a.
  Proof.
    rewrite auth_frag_validN. split.
    - by intros [??].
    - by split.
  Qed.
  Lemma ufrac_auth_frag_valid q a : ✓ (◯U_q a) ↔ ✓ a.
  Proof.
    rewrite auth_frag_valid. split.
    - by intros [??].
    - by split.
  Qed.

  Lemma ufrac_auth_frag_op q1 q2 a1 a2 : ◯U_(q1+q2) (a1 ⋅ a2) ≡ ◯U_q1 a1 ⋅ ◯U_q2 a2.
  Proof. done. Qed.

  Lemma ufrac_auth_frag_op_validN n q1 q2 a b :
    ✓{n} (◯U_q1 a ⋅ ◯U_q2 b) ↔ ✓{n} (a ⋅ b).
  Proof. by rewrite -ufrac_auth_frag_op ufrac_auth_frag_validN. Qed.
  Lemma ufrac_auth_frag_op_valid q1 q2 a b :
    ✓ (◯U_q1 a ⋅ ◯U_q2 b) ↔ ✓ (a ⋅ b).
  Proof. by rewrite -ufrac_auth_frag_op ufrac_auth_frag_valid. Qed.

  Global Instance ufrac_auth_is_op q q1 q2 a a1 a2 :
    IsOp q q1 q2 → IsOp a a1 a2 → IsOp' (◯U_q a) (◯U_q1 a1) (◯U_q2 a2).
  Proof. by rewrite /IsOp' /IsOp=> /leibniz_equiv_iff -> ->. Qed.

  Global Instance ufrac_auth_is_op_core_id q q1 q2 a :
    CoreId a → IsOp q q1 q2 → IsOp' (◯U_q a) (◯U_q1 a) (◯U_q2 a).
  Proof.
    rewrite /IsOp' /IsOp=> ? /leibniz_equiv_iff ->.
    by rewrite -ufrac_auth_frag_op -core_id_dup.
  Qed.

  Lemma ufrac_auth_update p q a b a' b' :
    (a,b) ~l~> (a',b') → ●U_p a ⋅ ◯U_q b ~~> ●U_p a' ⋅ ◯U_q b'.
  Proof.
    intros. apply: auth_update.
    apply: option_local_update. by apply: prod_local_update_2.
  Qed.

  Lemma ufrac_auth_update_surplus p q a b :
   ✓ (a ⋅ b) → ●U_p a ~~> ●U_(p+q) (a ⋅ b) ⋅ ◯U_q b.
  Proof.
    intros Hconsistent. apply: auth_update_alloc.
    intros n m; simpl; intros [Hvalid1 Hvalid2] Heq.
    split.
    - split; by apply cmra_valid_validN.
    - rewrite pair_op Some_op Heq comm.
      destruct m; simpl; [rewrite left_id | rewrite right_id]; done.
  Qed.
End ufrac_auth.

Definition ufrac_authURF (F : rFunctor) : urFunctor :=
  authURF (optionURF (prodRF (constRF ufracR) F)).

Global Instance ufrac_authURF_contractive F :
  rFunctorContractive F → urFunctorContractive (ufrac_authURF F).
Proof. apply _. Qed.

Definition ufrac_authRF (F : rFunctor) : rFunctor :=
  authRF (optionURF (prodRF (constRF ufracR) F)).

Global Instance ufrac_authRF_contractive F :
  rFunctorContractive F → rFunctorContractive (ufrac_authRF F).
Proof. apply _. Qed.