(** ** Natural numbers

    The natural numbers are a motivating example of W-types, and one of the only
    W-types readily available in UniMath. We show that they are an initial
    algebra for a polynomial functor, and satisfy a few other properties.

    Author: Langston Barrett (@siddharthist)
 *)
Require Import UniMath.Foundations.Preamble.
Require Import UniMath.Foundations.PartA.
Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.UnivalenceAxiom.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.categories.Type.Core.
Require Import UniMath.Induction.FunctorAlgebras_legacy.
Require Import UniMath.Induction.PolynomialFunctors.
Require Import UniMath.Induction.W.Core.
Require Import UniMath.Induction.W.Fibered.

Local Notation ℕ := nat.

(** The signature for the nat functor is (bool, [true ↦ empty; false ↦ unit])
    since the naturals have two constructors: one for zero and one for successor.
 *)
Definition nat_functor : functor type_precat type_precat :=
  polynomial_functor bool (bool_rect (λ _, UU) empty unit).

(** The functor deals with functions from ∅ and unit; these lemmas will come in
    handy in several proofs. *)
Lemma eqfromempty {X : UU} (f : empty -> X) : f = fromempty.
Proof. apply proofirrelevancecontr, iscontrfunfromempty. Defined.

Lemma eta_unit {X : UU} (f : unit -> X) : f = λ _, f tt.
Proof. apply funextfun; intro; induction _; reflexivity. Defined.

(** Simplifying the action of the functor on arrows *)

Lemma nat_functor_arr_true {X Y : UU} (f : X -> Y) g :
  (functor_on_morphisms nat_functor) f (true,, g) = (true,, fromempty).
Proof.
  cbn; unfold polynomial_functor_arr; cbn.
  apply maponpaths, eqfromempty.
Defined.

Lemma nat_functor_arr_false {X Y : UU} (f : X -> Y) g :
  (functor_on_morphisms nat_functor) f (false,, g) = (false,, λ _, f (g tt)).
Proof.
  cbn; unfold polynomial_functor_arr; cbn.
  apply maponpaths, eta_unit.
Defined.

(** Here's how to prove two functions from a nat_functor are equal:
    check both cases. *)
Lemma from_nat_functor_eq {X Y : UU} :
  ∏ f g : nat_functor X → Y,
    (f (true,, fromempty) = g (true,, fromempty)) ->
    (∏ h, f (false,, λ _, h tt) = g (false,, λ _, h tt)) -> f = g.
Proof.
  intros f g ? eqfalse.
  apply funextsec; intro pair.
  induction pair as [b bfun].
  induction b.
  - refine (maponpaths (λ z, f (true,, z)) (eqfromempty bfun) @ _).
    refine (_ @ !maponpaths (λ z, g (true,, z)) (eqfromempty bfun)).
    assumption.
  - cbn in eqfalse.
    refine (maponpaths (λ z, f (false,, z)) (eta_unit bfun) @ _).
    refine (_ @ !maponpaths (λ z, g (false,, z)) (eta_unit bfun)).
    apply eqfalse.
Defined.

(** The intuition is that an algebra X for this functor is given by a constant
    x : X and a function X → X. The following equivalence verifies this. *)
Definition nat_functor_equiv :
  ∏ {X : UU}, (X × (X → X)) ≃ (nat_functor X -> X).
Proof.
  intro X.
  use weq_iso.
  * intros dprodpair.
    intros pairfun.
    induction pairfun as [b bfun]; induction b.
    - exact (pr1 dprodpair).
    - exact (pr2 dprodpair (bfun tt)).
  * intro pairfun.
    exact (make_dirprod (pairfun (true,, fromempty))
                       (λ x, pairfun (false,, λ _, x))).
  * reflexivity.
  * intro Y; apply from_nat_functor_eq; reflexivity.
Defined.

(** Using our equivalence, we can consisely define the algebra corresponding to
    ℕ. Any choice of zero results in an isomorphic algebra.
 *)
Definition nat_alg (n : ℕ) : algebra_ob nat_functor :=
  (ℕ,, nat_functor_equiv (make_dirprod n S)).

Definition nat_alg_z : algebra_ob nat_functor := nat_alg 0.

(** We may also define it directly. This will be judgmentally equal
    to [nat_alg_z]. *)
Example nat_alg' : algebra_ob nat_functor.
Proof.
  unfold algebra_ob, nat_functor; cbn; unfold polynomial_functor_obj; cbn.
  refine (ℕ,, λ pair, _).
  induction pair as [b rect].
  induction b; cbn in rect.
  - exact 0.
  - exact (S (rect tt)).
Defined.
Lemma nat_algs_eq : nat_alg_z = nat_alg'. Proof. reflexivity. Defined.

(** An algebra morphism between algebras for the nat functor is a
    function that respects all the relevant structure. *)
Definition make_nat_functor_algebra_mor {X Y : algebra_ob nat_functor} :
  let X' := invmap nat_functor_equiv (pr2 X) in
  let Y' := invmap nat_functor_equiv (pr2 Y) in
  ∏ (f : pr1 X → pr1 Y),
    (f (pr1 X') = (pr1 Y')) × (f ∘ (pr2 X') = (pr2 Y') ∘ f)
  → is_algebra_mor _ X Y f.
Proof.
  intros X' Y' f p.
  apply from_nat_functor_eq.
  + refine (_ @ !maponpaths _ (nat_functor_arr_true f _)).
    refine (pr1 p @ _).
    apply (maponpaths (pr2 Y)), maponpaths.
    reflexivity.
  + intro; apply (eqtohomot (pr2 p)).
Defined.

(** Define the unique algebra morphism out of ℕ *)
Lemma nat_alg_is_preinitial : is_preinitial nat_alg_z.
Proof.
  intro X; pose (x := pr2 X).

  (** X has a "zero" and a "successor", just like ℕ, given by the algebra
      structure. We use these to define the unique morphism ℕ -> X
      by induction. *)
  pose (x0    := x (true,, fromempty)).
  pose (xsucc := (λ y, x (false,, λ _, y)) : pr1 X -> pr1 X).

  (** The recursor for ℕ gets an extra argument of type ℕ, which we don't pass
      to xsucc. Compare to [CategoryTheory.FunctorAlgebras.nat_ob_rec]. *)
  refine ((nat_rect _ x0 (λ _, xsucc)),, _).
  apply make_nat_functor_algebra_mor; split; reflexivity.
Defined.

(** The first projection of the morphism out of ℕ (the actual function)
    is unique. *)
Lemma nat_alg_func_is_unique :
  ∏ X, ∏ (mor : algebra_mor _ nat_alg_z X), pr1 mor = pr1 (nat_alg_is_preinitial X).
Proof.
  intros X mor.
  induction X as [X x]; induction mor as [mor is_mor]; cbn in x.
  cbn in mor.
  apply funextfun; intros n; induction n; cbn.
  - unfold is_algebra_mor in is_mor; cbn in mor, is_mor.
    (** Use the condition that mor is an algebra morphism *)
    refine ((eqtohomot is_mor (true,, fromempty)) @ _).
    apply (maponpaths x).
    apply nat_functor_arr_true.
  - (** Use the condition that mor is an algebra morphism *)
    refine ((eqtohomot is_mor (false,, _)) @ _); cbn.
    apply (maponpaths x).
    unfold polynomial_functor_arr; cbn.
    apply maponpaths.
    apply funextsec; intros ttt; induction ttt.
    apply IHn.
Defined.

(** Since fibered algebras are the "dependent version" of normal algebras,
    we need some kind of "dependent version" of the lemmas above.
 *)
Lemma sec_fromempty {X : UU} {Y : X -> UU}
      (f : ∅ -> X)
      (t : ∏ z : ∅, Y (f z)) : t = λ e, fromempty e.
Proof.
  apply funextsec; intro; induction _.
Defined.

(** A fibered algebra over ℕ consists of a family ℕ → UU, a point x0 : X 0,
    and a function from each X n to X (S n).
 *)
Definition fibered_algebra_nat :
  fibered_alg nat_alg_z ≃ ∑ (X : ∏ n : ℕ, UU), (X 0) × (∏ n, X n → X (S n)).
Proof.
  apply weqfibtototal; intro X; cbn in X.
  use weq_iso.
  - intro x.
    apply make_dirprod.
    + exact (x (true,, fromempty) (λ e, fromempty e)).
    + refine (λ n xn, _).
      unfold fibered_alg in x; cbn in x.
      apply (x (false,, λ _, n) (λ _, xn)).
  - intro x.
    unfold fibered_alg; cbn.
    intros pair from; induction pair as [b bfun].
    induction b; cbn in *.
    + exact (pr1 x).
    + exact (pr2 x (bfun tt) (from tt)).
  - cbn. intro g.
    apply funextsec; intro pair.
    induction pair as [b bfun].
    induction b; cbn; cbn in bfun.
    + apply funextsec; intro z.
      rewrite (sec_fromempty bfun z).
      rewrite (eqfromempty bfun).
      reflexivity.
    + rewrite (eta_unit bfun).
      apply funextsec; intro z.
      apply maponpaths.
      exact (!eta_unit z).
  - reflexivity.
Defined.

(** A section from ℕ consists of a "point" x : ∏ n, X n such that
    x agrees with the function which is a part of the fibered
    algebra (see above).
 *)
Definition make_nat_alg_sec :
  ∏ (FA : fibered_alg nat_alg_z),
  let FA' := fibered_algebra_nat FA
  in ∏ (x : ∏ n : ℕ, pr1 FA' n)
       (p1 : x 0 = pr1 (pr2 FA'))
       (p2 : (∏ n, pr2 (pr2 FA') n (x n) = x (S n))),
  algebra_section FA.
Proof.
  intros FA FA' x p1 p2.
  unfold algebra_section.
  refine (x,, _).
  intro pair.
  induction pair as [b bfun].
  induction b; cbn; cbn in bfun.
  - (** They are equal at 0 by hypothesis p1, the rest is noise. *)
    refine (p1 @ _).
    unfold FA', fibered_algebra_nat; cbn.
    rewrite (eqfromempty bfun).
    apply maponpaths.
    apply funextsec.
    intro e; induction e.
  - refine (!p2 (bfun tt) @ _).
    rewrite (eta_unit (bfun)).
    reflexivity.
Defined.

(** Another way to make an algebra section given different starting data. *)
Definition make_nat_alg_sec' {X : ℕ -> UU} {ρ : ∏ n, X n → X (S n)}
           (x : ∏ n : ℕ, X n) (H : ∏ n : ℕ, x (S n) = ρ n (x n)) :
  algebra_section
    (invmap fibered_algebra_nat (X,, (x 0,, ρ))).
Proof.
  refine (x,, _).
  intros pair; induction pair as [b bfun]; induction b.
  - reflexivity.
  - apply H.
Defined.

(** Define the section out of ℕ, prove it's really a section *)
Lemma nat_alg_is_preinitial_sec : is_preinitial_sec nat_alg_z.
Proof.
  intro E. pose (x := pr2 E).
  unfold is_preinitial, algebra_section.
  use make_nat_alg_sec.
  - apply nat_rect.
    + exact (x (true,, fromempty) (empty_rect (pr1 E ∘ fromempty))).
    + intros ? fn.
      refine (x (false,, λ _, n) (λ b : unit, fn)).
  - cbn.
    apply maponpaths.
    apply funextsec; intro e; induction e.
  - reflexivity.
Defined.


Require Import A1_Plan A2_Orientation A4_Droite A7_Tactics .
Require Import B7_Tactics .
Require Import G1_Angles .
Require Import I2_Supplement .
Require Import K1_RightAngle .
Require Import L2_StrictParallelogramm L6_Tactics .
Require Import M1_SuperImposedLines M4_PerpendicularLines M5_Tactics .
Require Import N1_DrawingPerpendicularLines N5_UniqueParallel.

Section PARALLEL_AND_PERPENDICULAR_LINES.

Lemma RightRightEqMLine : forall A B C D : Point, forall Hab : A <> B, forall Hdb : D <> B,
	RightAngle A B C  ->
	RightAngle C B D ->
	EqLine (Ruler A B Hab) (Ruler D B Hdb).
Proof.
	intros.
	step12 Hab.
	since12 (~ Collinear A B C).
	 since12 (~ Collinear C B D).
	  by2Cases1 H1; by2Cases1 H2.
	   since12 (Supplement C B A D B C).
	    from12 H5 (Between A B D).
	   since12 (CongruentAngle A B C D B C).
	    from12 H5 (OpenRay B A D).
	   since12 (CongruentAngle C B A C B D).
	    from12 H5 (OpenRay B A D).
	   since12 (Supplement C B A D B C).
	    from12 H5 (Between A B D).
Qed.

Lemma PerpendicularPerpendicularParallel : forall d1 d2 d3 : Line,
	Perpendicular d1 d2 ->
	Perpendicular d2 d3 ->
	ParallelLines d1 d3.
Proof.
	intros.
	inversion H; inversion H0.
	by3Cases1 A B B0.
	 setStrictParallelogramm11 A B B0 ipattern:(E).
	   DestructSP11 H12.
	   since12 (RightAngle B B0 E).
	  as12 (Supplement B B0 E A B B0).
	    left; step12 H.
	  from12 H0 (RightAngle B B0 C0).
	    setLine0 A B ipattern:(d4).
	   immediate12.
	   since12 (EqLine d1 d4).
	    step12 (A, B).
	    step12 H18.
	      setLine0 E B0 ipattern:(d5).
	     immediate12.
	     setLine0 C0 B0 ipattern:(d6).
	      immediate12.
	      since12 (EqLine d5 d6).
	       unfold d5 in |- *; unfold d6 in |- *; apply (RightRightEqMLine E B0 B).
	        immediate12.
	        immediate12.
	       from12 (B0, C0) (EqLine d3 d6).
	         step12 H22.
	         step12 H21.
	 setStrictParallelogramm11 B0 B A ipattern:(E).
	   since12 (RightAngle B B0 E).
	  as12 (Supplement B B0 E A B B0).
	    left; step12 H.
	  from12 H0 (RightAngle B B0 C0).
	    setLine0 A B ipattern:(d4).
	   immediate12.
	   since12 (EqLine d1 d4).
	    step12 (A, B).
	    step12 H16.
	      setLine0 E B0 ipattern:(d5).
	     immediate12.
	     setLine0 C0 B0 ipattern:(d6).
	      immediate12.
	      since12 (EqLine d5 d6).
	       unfold d5 in |- *; unfold d6 in |- *; apply (RightRightEqMLine E B0 B).
	        immediate12.
	        immediate12.
	       from12 (B0, C0) (EqLine d3 d6).
	         step12 H20.
	         step12 H19.
	 from12 H12 (OnLine d1 B0).
	   since12 (SecantLines d1 d2).
	   from12 H13 (B0 = B).
	   subst.
	   from12 H0 (RightAngle C B C0).
	   setLine0 C0 B ipattern:(d4).
	  immediate12.
	  setLine0 A B ipattern:(d5).
	   immediate12.
	   since12 (EqLine d4 d5).
	    unfold d4 in |- *; unfold d5 in |- *; apply (RightRightEqMLine C0 B C).
	     immediate12.
	     immediate12.
	    from12 (A, B) (EqLine d1 d5).
	      step12 H18.
	      from12 (C0, B) (EqLine d3 d4).
	      step12 H19.
Qed.

Lemma UniquePerpendicular : forall d1 d2 d3 : Line, forall A : Point,
	Perpendicular d1 d3 ->
	Perpendicular d2 d3 ->
	OnLine d1 A ->
	OnLine d2 A ->
	EqLine d1 d2.
Proof.
	intros.
	since12 (ParallelLines d1 d2).
	 apply (PerpendicularPerpendicularParallel d1 d3 d2).
	  immediate12.
	  immediate12.
	 step12 H3.
Qed.

Lemma PerpendicularParallelPerpendicular : forall d1 d2 d3 : Line,
	Perpendicular d1 d2 ->
	ParallelLines d1 d3 ->
	Perpendicular d2 d3.
Proof.
	intros.
	setInterLines d3 d2 ipattern:(A).
	 apply (ParallelSecant d1); immediate12.
	 pose (d4 := PerpendicularUp d2 A Hol0).
	   assert (H1 := PerpendicularUpPerpendicular d2 A Hol0); fold d4 in H1.
	   since12 (ParallelLines d1 d4).
	  apply (PerpendicularPerpendicularParallel d1 d2 d4); immediate12.
	  since12 (OnLine d4 A).
	   apply (PerpendicularUpOnLine d2 A Hol0).
	   since12 (EqLine d3 d4).
	    apply (UniqueParallel d1 d3 d4 A); immediate12.
	    step12 H4.
Qed.

Lemma SecantPerpendicularSecant : forall d1 d2 d3 d4 : Line,
	SecantLines d1 d2 ->
	Perpendicular d1 d3 ->
	Perpendicular d2 d4 ->
	SecantLines d3 d4.
Proof.
	intros.
	contrapose0 H.
	apply (PerpendicularPerpendicularParallel d1 d3 d2 H0).
	apply PerpendicularSym; apply (PerpendicularParallelPerpendicular d4);
	 immediate12.
Qed.

Lemma SecantParallelSecant : forall d1 d2 d3 d4 : Line,
	SecantLines d1 d2 ->
	ParallelLines d1 d3 ->
	ParallelLines d2 d4 ->
	SecantLines d3 d4.
Proof.
	intros.
	contrapose0 H.
	apply (ParallelTrans d1 d3 d2 H0).
	apply (ParallelTrans d3 d4); immediate12.
Qed.

End PARALLEL_AND_PERPENDICULAR_LINES.


Require Import HoTT.
From GR.bicategories Require Import
     bicategory.bicategory_laws
     lax_functor.lax_functor
     lax_transformation.lax_transformation
     lax_transformation.examples.identity
     lax_transformation.examples.composition
     modification.modification.

Section LeftIdentityInv.
  Context `{Univalence}
          {C D : BiCategory}
          {F₁ F₂ : LaxFunctor C D}.
  Variable (η : LaxTransformation F₁ F₂).

  Local Notation left_identity_inv_mod_d
    := (fun (A : C) =>
          left_unit_inv (η A) : (η A ==> compose η (identity_transformation F₂) A)).

  Definition left_identity_inv_is_mod : is_modification left_identity_inv_mod_d.
  Proof.
    intros A B f ; cbn in *.
    unfold bc_whisker_l, bc_whisker_r.
    rewrite !vcomp_assoc.
    rewrite <- (vcomp_left_identity (id₂ (η A))).
    rewrite interchange.
    rewrite !vcomp_assoc.
    rewrite triangle_r.
    rewrite !vcomp_assoc.
    rewrite !(ap (fun z => _ ∘ (_ ∘ (_ ∘ (_ ∘ (_ ∘ z))))) (vcomp_assoc _ _ _)^).
    rewrite assoc_left.
    rewrite vcomp_left_identity.
    rewrite <- !vcomp_assoc.
    rewrite !vcomp_assoc.
    rewrite !(ap (fun z => _ ∘ z) (vcomp_assoc _ _ _)^).
    pose @left_unit_inv_assoc as p.
    unfold bc_whisker_r in p.
    rewrite p ; clear p.
    rewrite !vcomp_assoc.
    rewrite !(ap (fun z => _ ∘ (_ ∘ z)) (vcomp_assoc _ _ _)^).
    rewrite assoc_left.
    rewrite vcomp_left_identity.
    rewrite !vcomp_assoc.
    rewrite <- interchange.
    rewrite left_unit_left.
    rewrite vcomp_left_identity, hcomp_id₂, vcomp_right_identity.
    rewrite <- left_unit_inv_natural.
    rewrite <- !vcomp_assoc.
    rewrite <- left_unit_inv_assoc.
    reflexivity.
  Qed.

  Definition left_identity_inv_modification
    : Modification η (compose η (identity_transformation F₂))
    := Build_Modification left_identity_inv_mod_d left_identity_inv_is_mod.

  Definition left_identity_inv_modification_is_iso
    : iso_modification left_identity_inv_modification.
  Proof.
    intros X ; cbn.
    apply _.
  Qed.

  Definition left_identity_inv_mod
    : IsoModification η (compose η (identity_transformation F₂)).
  Proof.
    make_iso_modification.
    - exact left_identity_inv_modification.
    - exact left_identity_inv_modification_is_iso.
  Defined.
End LeftIdentityInv.


Require Import List.
Require Import Arith.

Fixpoint
  update_primes (k:nat) (l: list (nat*nat)) {struct l} : list (nat*nat)*bool :=
  match l with
  | nil => (nil,false)
  | (p,n)::tl =>
    let (l',b) := update_primes k tl in
    match Nat.compare  k n with
    | Lt => ((p, n)::l', b)
    | Eq => ((p, n+p)::l', true)
    | Gt => ((p, n+p)::l', b)
    end
  end.

Fixpoint prime_sieve (n:nat) : list (nat*nat) :=
  match n with
  | O => nil
  | 1 => nil
  | S k' =>
    let (l', b) := update_primes (S k')(prime_sieve k') in
    if b then l' else ((S k', 2*S k')::l')
  end.

Definition prime_fun (n:nat) : bool :=
  match prime_sieve n with
  | nil => false
  | (p,q)::tl =>
    match Nat.compare p n with
    | Eq => true
    | _ => false
    end
  end.

(** The rest of the file shows that we can prove interesting facts
   about our function using only the notions that have been introduced
   in the book up to chapter 6.  However, an expert user would rather
   also rely on notions that are introduced later, like the inductive
   properties found in chapter 8. *)

Definition divides (p n:nat) := exists q:nat, n = p*q.

Definition prime (n:nat) :=
  (n<>0/\n<>1)/\~(exists k:nat, 1 < k < n /\ divides k n).

Definition all_list(P:nat->nat->Prop) (l:list(nat*nat)):=
 forall (l1 l2:list(nat*nat))(p n:nat),
   l = l1++(p, n)::l2 -> (P p n).

Definition all_first_less_than (k:nat) :=
 all_list (fun p n:nat => p < k).

Definition all_first_prime :=
 all_list (fun p n:nat => prime p).

Definition all_intervals (k:nat) :=
 all_list (fun p n:nat => n-p<k<=n).

Definition all_multiples :=
 all_list (fun p n:nat => exists q:nat, n=p*q).

Definition all_greater_than_one :=
 all_list (fun p n => 1 < p).

Definition all_prime_in_first (k:nat)(l:list (nat*nat)) :=
 forall n:nat, 0 < n < k -> prime n ->
  (exists l1: list (nat*nat),
    (exists l2: list (nat*nat),
      (exists p: nat, l= l1++(n,p)::l2))).

(** A theorem that should be in the general libraries. *)

Theorem mult_lt_reg_l :
  forall m n p, m * n < m * p -> n < p.
Proof.
 intros m n; elim n.
 -  intros p; case p.
  +  repeat (rewrite mult_comm; simpl); auto.
  +  auto with arith.
 -  intros n' Hrec p; case p.
  +  rewrite <- (mult_comm 0); simpl; intros Hlt; elim (lt_n_O (m*S n'));auto.
  + intros p'; repeat rewrite <- mult_n_Sm.
    repeat rewrite <- (plus_comm m).
    intros Hlt; assert (Hlt' : m*n' < m* p').
    *  apply plus_lt_reg_l with m; auto.
    * auto with arith.
Qed.

(** A bunch of generic proofs about the all_list predicate. *)

Theorem all_list_transmit :
 forall (P:nat->nat->Prop)(p:nat*nat)(l:list(nat*nat)),
   all_list P (p::l)-> all_list P l.
Proof.
 intros P fst_elem l H l1 l2 p n Heq.
 unfold all_list in H.
 apply H with (fst_elem::l1) l2; rewrite Heq; auto.
Qed.

Theorem all_list_add :
 forall (P:nat->nat->Prop)(l:list(nat*nat))(p n:nat),
 P p n -> all_list P l -> all_list P ((p,n)::l).
Proof.
 intros P l p n Hp Hal l1; case l1.
 intros l2 p' n' Heq; injection Heq; intros Hl Hn' Hp';
 rewrite <- Hn'; rewrite <- Hp'; auto.

 simpl; clear l1; intros fst_elem l1 l2 p' n' Heq; injection Heq;
 intros Hl Hfst; apply (Hal l1 l2); assumption.
Qed.

Theorem absurd_decompose_list :
 forall (A:Set) (l1 l2:list A) (p:A), nil = l1++p::l2 -> False.
Proof.
 intros A l1; case l1; simpl; intros; discriminate.
Qed.

Theorem all_list_nil :
 forall (P:nat->nat->Prop),
  all_list P nil.
Proof.
 intros P l1 l2 p n Heq; elim (absurd_decompose_list _ _ _ _ Heq).
Qed.

(** As corollaries, we get transmission theorems for the main predicates. *)

Theorem all_intervals_transmit :
 forall (k:nat)(p:nat*nat)(l: list(nat*nat)),
  all_intervals k (p::l) -> all_intervals k l.
Proof.
 intros k; exact (all_list_transmit (fun p n => n-p<k<=n)).
Qed.

Theorem all_multiples_transmit :
 forall (p:nat*nat)(l: list(nat*nat)),
  all_multiples (p::l) -> all_multiples l.
Proof.
 exact (all_list_transmit (fun p n => exists q:nat, n=p*q)).
Qed.

Theorem all_greater_than_one_transmit :
 forall (p:nat*nat)(l: list(nat*nat)),
  all_greater_than_one (p::l) -> all_greater_than_one l.
Proof.
 exact (all_list_transmit (fun p n => 1<p)).
Qed.

Theorem all_first_prime_transmit :
 forall (p:nat*nat)(l:list(nat*nat)),
  all_first_prime(p::l) -> all_first_prime l.
Proof.
 exact (all_list_transmit (fun p n => prime p)).
Qed.

Theorem all_first_less_than_transmit :
 forall k (p:nat*nat)(l: list(nat*nat)),
  all_first_less_than k (p::l) -> all_first_less_than k l.
Proof.
 intros k; exact (all_list_transmit (fun p n => p < k)).
Qed.

(** Theorems about invariants in update_primes *)

Theorem update_primes_all_list_invariant :
 forall (P:nat->nat->nat->Prop),
 (forall k p n:nat, k = n -> P k p n -> P k p (n+p))->
 (forall k p n:nat, n < k -> P k p n -> P k p (n+p))->
 forall (k:nat)(l l':list(nat*nat))(b:bool),
  all_list (P k) l ->
  update_primes k l = (l',b) -> all_list (P k) l'.
Proof.
  intros P Hp2 Hp3 k l; elim l.
  -  simpl; intros Hal l' b Hup; injection Hup; intros Hb Hl';
       rewrite <- Hl'; apply (all_list_nil (P k)).
  -  simpl; intros (p, n) l0 Hrec l' b Hal;
       case_eq (update_primes k l0); intros l'0 b0 Hup0.
     case_eq (Nat.compare k n); intros Htwc Hup; injection Hup;
       intros Hb Hl'; rewrite <- Hl';
         generalize (Hal nil l0 p n (refl_equal _)); intros HPkpn;
           generalize (Hrec l'0 b0 (all_list_transmit (P k) (p,n) l0 Hal) Hup0);
           intros Hal'; apply all_list_add; auto.
     +  apply Hp2;[apply nat_compare_eq;auto| auto].
     + apply Hp3;[apply nat_compare_Gt_gt;auto| auto].
Qed.

(** Now a few proofs about divides and prime *)

Theorem divides_dec_aux :
  forall k n p:nat, n <= k -> divides p n \/ ~divides p n.
Proof.
  intros k; elim k.
  -  intros n p Hle; left; exists 0; rewrite mult_comm; simpl;
       symmetry; apply le_n_O_eq; auto.
  - intros k' Hrec n p Hlt; elim (le_lt_or_eq n (S k')).
    + auto with arith.
    + intros Heq; rewrite Heq.
      case p.
      *  right; intros (q, Heq').
         discriminate Heq'.
      *  intros p'; case_eq (Nat.compare (S p') (S k')); intros Htwc.
         --  assert (H:S p' = S k').
             { apply nat_compare_eq; auto. }
             left; exists 1; rewrite H.
             auto with arith.
         --
           assert (S p' < S k').
           apply nat_compare_Lt_lt; auto.
           elim (Hrec (minus (S k') (S p')) (S p')).
           ++ intros (q, Heq'); left; exists (S q).
              rewrite (le_plus_minus (S p') (S k')).
              ** rewrite Heq'.
                 repeat rewrite (mult_comm (S p')).
                 reflexivity.
              **  auto with arith.
           ++  intros Hndiv; right; intros Hdiv.
               apply Hndiv.
               elim Hdiv.
               intros q; case q.
               **  rewrite mult_comm;  simpl; intros; discriminate.
               **  intros q' Heq'; exists q'.
                   apply plus_reg_l with (S p').
                   rewrite le_plus_minus_r.
                   { rewrite Heq'.
                     rewrite plus_comm; rewrite mult_n_Sm; reflexivity.
                   }
                   auto with arith.
           ++ simpl; apply le_minus.

         -- assert (Hlt': S k' < S p').
            { apply nat_compare_Gt_gt; auto. }
            right; intros Hdiv; elim Hdiv; intros q; case q.
            ++  rewrite mult_comm; simpl; intros; discriminate.
            ++ intros q' Heq'; elim (lt_not_le _ _ Hlt').
               rewrite Heq'.
               rewrite mult_comm; simpl; auto with arith.
    +  trivial.
Qed.

Theorem eq_nat_or :
 forall n m:nat, n=m \/ ~n=m.
Proof.
  decide equality.
Qed.

Theorem prime_dec_aux :
 forall n k:nat,
  (n=0\/n=1)\/
  (exists p:nat, 1<p<k /\ (exists q:nat, n=p*q))\/
  ((n<>0/\n<>1)/\~(exists p:nat, 1<p<k/\ (exists q:nat, n=p*q))).
Proof.
 intros n; elim (eq_nat_or n 1).
 -  auto.
 - intros Hnneq1.
   elim (eq_nat_or n 0).
   +  auto.
   + intros Hnneq0 k; elim k.
    *  right; right; split.
     --   auto.
     -- intros (p, ((_,Hlt0), (q, Heq))).
        elim (lt_n_O p); auto.
    * intros k'; case k'.
     --  intros; right; right; split.
         ++ auto.
         ++ intros (p, ((Hpgt1, Hplt1),_)).
            elim (lt_irrefl 1); apply lt_trans with p;auto.
     -- intros k''; case k''.
        ++ intros; right; right; split; auto; intros (p, ((Hpgt1, Hplt2),_)).
           elim (lt_irrefl p); apply le_lt_trans with 1; auto with arith.
        ++ intros k''' Hrec; case (divides_dec_aux n n (S (S k'''))).
           ** auto with arith.
           ** intros Hdiv; right; left; exists (S (S k'''));
                repeat split; auto with arith.
           **  intros Hndiv; elim Hrec.
               { auto. }
               {  intros Hrec'; elim Hrec'.
                  intros (p, ((Hpgt1, Hplt), Hex));
                    right; left; exists p; repeat split;
                      auto with arith.
                  intros (_, Hnodiv); right; right; split; auto;
                    intros (p, ((Hpgt1, Hplt), Hex)).
                  assert (Hple : p <= S (S k''')).
                  { auto with arith. }
                  elim (le_lt_or_eq _ _ Hple).
                  intros Hplt'.
                  elim Hnodiv; exists p; repeat split; auto with arith.
                  intros Hpeq.
                  elim Hndiv; rewrite <- Hpeq; exact Hex.
               }
Qed.

Theorem prime_dec :
 forall n:nat, (n=0\/n=1)\/(exists p:nat, 1<p<n /\ (exists q:nat, n=p*q))\/
  prime n.
Proof.
 intros n; exact (prime_dec_aux n n).
Qed.

Theorem div_by_prime_aux :
 forall k:nat, forall n:nat, n <= k ->
 1 < n -> (exists p:nat, 1 < p < n /\ (exists q : nat, n=p*q)) ->
 (exists p:nat, 1 < p < n /\ (prime p) /\ (exists q:nat, n=p*q)).
Proof.
 intros k; elim k.
 -  intros n Hle Hlt Hn.
    elim (lt_asym 1 0).
  +  apply lt_le_trans with n; assumption.
  + auto with arith.
 -  intros k' Hrec n Hle Hlt Hn.
    elim (le_lt_or_eq n (S k')).
    +  intros Hle'; apply Hrec; auto with arith.
    + elim Hn; intros p ((Hpgt1, Hpltn),(q,Heq)).
      intros HneqSk'.
      elim (prime_dec p).
    *  intros Hpeq0or1; elim Hpeq0or1.
     --  intros Hpeq0.
         rewrite Hpeq0 in Hpgt1; elim (lt_n_O 1); assumption.
     -- intros Hpeq1;
          rewrite Hpeq1 in Hpgt1; elim (lt_irrefl 1); assumption.
    *  intros Hpdec; elim Hpdec.
       -- intros Hexp.
          elim (Hrec p); auto with arith.
          ++ intros p' ((Hp'gt1,Hp'ltp), (Hpr,(q', Heq'))).
             exists p'.
             split;[split|split]; auto with arith.
             ** apply lt_trans with p; auto with arith.
             **  exists (q' * q).
                 rewrite mult_assoc.
                 rewrite Heq; rewrite Heq'; trivial.
          ++  unfold lt in Hpltn.
              rewrite HneqSk' in Hpltn; auto with arith.
       --  exists p;split;[split|split]; auto with arith.
           exists q; auto with arith.
    + trivial.
Qed.

Theorem div_by_prime :
 forall n:nat, 1 < n -> (exists p:nat, 1 < p < n /\ (exists q : nat, n=p*q)) ->
 (exists p:nat, 1 < p < n /\ (prime p) /\ (exists q:nat, n=p*q)).
Proof.
 intros n; apply (div_by_prime_aux n n).
 auto with arith.
Qed.

(** Now, theorems about update_primes. *)

Theorem update_primes_true_aux :
  forall (k:nat) (l1 l2 l3 l4: list(nat*nat))(b:bool),
    update_primes k l1 = (l2, true) ->
    update_primes k (l3++l1) = (l4, b) -> b=true.
Proof.
  intros k l1 l2 l3; elim l3.
  - simpl; intros l4 b Heq1; rewrite Heq1; intros Heq2; injection Heq2; auto.
  - simpl; intros (p,n) l; case (update_primes k (l++l1)).
    intros l4 b Hrec l4' b'; case (Nat.compare k n).
  + intros Heq1 Heq2; injection Heq2; auto.
  +  intros Heq1 Heq2; injection Heq2.
     intros Heq3 Heq4; rewrite <- Heq3; apply Hrec with l4; auto.
  + intros Heq1 Heq2; injection Heq2.
    intros Heq3 Heq4; rewrite <- Heq3; apply Hrec with l4; auto.
Qed.

Theorem update_primes_true_imp_div :
  forall (k:nat)(l: list (nat*nat)),
    all_first_less_than k l ->
    all_multiples l ->
    all_greater_than_one l ->
    forall l1, update_primes k l = (l1, true) ->
               (exists p:nat, 1< p < k /\ (exists q:nat, k = p*q)).
Proof.
  intros k l; elim l.
  -  simpl; intros; discriminate.
  - intros (p,n) l0 Hrec Haf Ham Hal l1; simpl.
    case_eq (update_primes k l0).
    intros l2 b Hup; case_eq (Nat.compare k n).
    +  intros Htwc Heq; generalize (nat_compare_eq _ _ Htwc).
       intros Hk; exists p; split.
       *  split.
          unfold all_greater_than_one in Hal;
            apply Hal with (nil (A:=nat*nat)) l0 n; auto.
          unfold all_first_less_than in Haf;
            apply Haf with (nil (A:=nat*nat)) l0 n; auto.
       * unfold all_multiples in Ham.
         rewrite Hk; apply Ham with (nil (A:=nat*nat)) l0; auto.
    + intros Htwc Heq; injection Heq; intros Hb Hl1.
      * rewrite Hb in Hup; apply Hrec with l2.
        -- apply all_first_less_than_transmit with (p,n); auto.
        -- apply all_multiples_transmit with (p,n); auto.
        --  apply all_greater_than_one_transmit with (p,n); auto.
        -- auto.

    + intros Htwc Heq; injection Heq; intros Hb Hl1.
      rewrite Hb in Hup; apply Hrec with l2.
      * apply all_first_less_than_transmit with (p,n); auto.
      * apply all_multiples_transmit with (p,n); auto.
      *  apply all_greater_than_one_transmit with (p,n); auto.
      *  auto.
Qed.

Theorem interval_eq :
  forall p q q', p*q'-p < p*q <= p*q' -> q=q'.
Proof.
  intros p; case p.
  -  simpl; intros q q' (Hlt, Hle); elim (lt_irrefl 0);assumption.
  - intros p' q q' (Hlt, Hle).
    apply le_antisym.
    + apply mult_S_le_reg_l with p'; auto.
    + assert (Hlt' : (q' - 1)*S p' < S p' * q).
     { rewrite mult_minus_distr_r.
       rewrite mult_1_l.
       rewrite (mult_comm q').
       assumption.
     }
     rewrite (mult_comm (q' - 1)) in Hlt'.
     generalize (mult_lt_reg_l _ _ _ Hlt').
     case q'; simpl.
     * auto with arith.
       * intros n; rewrite <- minus_n_O; auto with arith.
Qed.

Theorem update_primes_false_imp_prime :
 forall k l l1,
   1 < k ->
   all_multiples l ->
   all_intervals k l ->
   all_prime_in_first k l ->
   update_primes k l = (l1,false) -> prime k.
Proof.
 intros k l l1 Hkgt1 Ham Hai Hap Heq.
 elim (prime_dec k); auto.
 -  intros Hkeq0or1;elim Hkeq0or1.
    + intros Hkeq0.
      rewrite Hkeq0 in Hkgt1; elim (lt_n_O 1); assumption.
    + intros Hkeq1; rewrite Hkeq1 in Hkgt1; elim (lt_irrefl 1); assumption.
- intros Hpdec; elim Hpdec.
  + intros Hexdiv.
    generalize (div_by_prime _ Hkgt1 Hexdiv).
    intros (p, ((Hpgt1,Hpltk), (Hpr, Hex))).
    elim (Hap p); auto.
    *  intros l'1 (l2, (n, Heq')).
       elim Hex; intros q Heq''.
       assert (Hint: n - p < k <= n).
     { unfold all_intervals in Hai.
       apply Hai with l'1 l2.
       auto.
     }
     assert (Hmult : (exists q':nat, n = p*q')).
     {
       unfold all_multiples in Ham.
       apply Ham with l'1 l2.
       auto.
     }
     elim Hmult; intros q' Heq3.
     assert (Heq4: q=q').
     {
       apply interval_eq with p.
       rewrite <- Heq3.
       rewrite <- Heq''.
       assumption.
     }
     assert (false= true).
     {
       case_eq (update_primes k ((p,n)::l2)).
       intros l3 b Hup.
       generalize (update_primes_true_aux k ((p,n)::l2) l3 l'1 l1 false).
       intros H; apply H.
       - generalize Hup.
         simpl.
         case (update_primes k l2).
         intros l5 b2.
         rewrite Heq''; rewrite Heq3; rewrite Heq4.
         rewrite Nat.compare_refl.
         intros Heq5; injection Heq5; intros Heq6 Heq7;
           rewrite Heq6;rewrite Heq7;
             auto with arith.
       -  rewrite <- Heq'.
          assumption.
     }
     discriminate.
    * auto with arith.
  + trivial.
Qed.

(** We can now prove that all properties are invariant. *)

Theorem update_primes_all_multiples :
  forall k l l' b,
    all_multiples l ->
       update_primes k l = (l', b) -> all_multiples l'.
Proof.
 apply (update_primes_all_list_invariant (fun k p n => exists q:nat, n=p*q));
 try (intros k p n Hcomp (q, Heq);exists (S q);rewrite Heq;
 rewrite <- mult_n_Sm; reflexivity).
Qed.

Theorem update_primes_all_first_less_than :
 forall k l l' b,
 all_first_less_than k l ->
 update_primes k l = (l',b) ->
 all_first_less_than k l'.
Proof.
 apply (update_primes_all_list_invariant (fun k p n => p < k)); auto.
Qed.

Theorem update_primes_all_greater_than_one :
 forall k l l' b,
  all_greater_than_one l ->
  update_primes k l = (l',b) ->
  all_greater_than_one l'.
Proof.
 apply (update_primes_all_list_invariant (fun k p n => 1 < p)); auto.
Qed.

Theorem update_primes_all_first_prime :
 forall k l l' b,
  all_first_prime l -> update_primes k l = (l',b) -> all_first_prime l'.
Proof.
 apply (update_primes_all_list_invariant (fun k p n => prime p)); auto.
Qed.

Theorem update_primes_all_intervals :
 forall (k:nat)(l:list(nat*nat)),
   all_intervals k l -> all_greater_than_one l ->
   forall l' b, update_primes k l = (l',b) -> all_intervals (S k) l'.
Proof.
 intros k l; elim l.
 -  simpl; intros Hai Hal l' b Hup; injection Hup;
      intros Hb Hl'; rewrite <- Hl'.
    intros l1 l2 n p Heq; elim (absurd_decompose_list _ _ _ _ Heq).
 -  simpl; intros (p, n) l0 Hrec Hai Hal l' b;
      case_eq (update_primes k l0); intros l'0 b0 Hup0 Hup l1.
    case l1.
    + unfold all_intervals in Hai.
      case_eq (Nat.compare k n); simpl; intros Htwc l2 p' n' Heq;
        rewrite Htwc in Hup; injection Hup; intros Hb Hl';
          rewrite <- Hl' in Heq; injection Heq; intros Hl2 Hn' Hp';
            rewrite <- Hp'; rewrite <- Hn';
              generalize (Hai nil l0 p n (refl_equal _));
              intros (Hlt, Hle);split;
                (generalize (nat_compare_Lt_lt _ _ Htwc) ||
                 generalize (nat_compare_eq _ _ Htwc) ||
                 generalize (nat_compare_Gt_gt _ _ Htwc));
                auto with arith. (* ICI *)
      *  intros Heq2; rewrite Heq2; rewrite plus_comm; rewrite minus_plus;
           auto with arith.
      * intros Heq2; rewrite Heq2; unfold all_greater_than_one in Hal;
          generalize (Hal nil l0 p n (refl_equal _)); intros Hpgt1.
        pattern n at 1; rewrite plus_n_O; rewrite plus_n_Sm;
          apply plus_le_compat; auto with arith.
      * rewrite plus_comm; rewrite minus_plus; auto with arith.
      *  generalize (Hal nil l0 p n (refl_equal _)); intros Hpgt1.
         intros Hkltn; pattern k at 1; rewrite plus_n_O; rewrite plus_n_Sm;
           apply plus_le_compat; auto with arith.
    + generalize (all_intervals_transmit _ _ _ Hai); intros Hai'.
      generalize (all_greater_than_one_transmit _ _ Hal); intros Hal'.
      simpl; clear l1; intros fst_elem l1 l2 p' n' Heq; generalize Hup;
        rewrite Heq.
      case (Nat.compare k n); intros Hup'; injection Hup';
        intros Hb Hl' _; apply (Hrec Hai' Hal' l'0 b0 Hup0 l1 l2); assumption.
Qed.

Theorem all_first_less_than_S :
  forall k l, all_first_less_than k l -> all_first_less_than (S k) l.
Proof.
  intros k l; elim l.
  -  intros Haf l1 l2 p n Heq; elim (absurd_decompose_list _ _ _ _ Heq).
  -  intros (p,n) l0 Hrec Haf l1.
     case l1.
     +  intros l2 p' n' Heq;
          generalize (Haf nil l2 p' n' Heq); intros Hpltk.
        auto with arith.
     + simpl; clear l1; intros fst_elem l1 l2 p' n' Heq.
       injection Heq; intros;
         apply (Hrec (all_first_less_than_transmit _ _ _ Haf) l1 l2 p' n');
         assumption.
Qed.

Theorem all_intervals_add :
 forall (l:list(nat*nat))(k p n:nat),
  n-p < k <= n ->
  all_intervals k l ->
  all_intervals k ((p,n)::l).
Proof.
 intros l k p n Hint Hai l1; case l1.
 - intros l2 p' n' Heq; injection Heq; intros Hl Hn' Hp';
     rewrite <- Hn'; rewrite <- Hp'; auto.
 -  simpl; clear l1; intros fst_elem l1 l2 p' n' Heq; injection Heq;
      intros Hl Hfst; apply (Hai l1 l2); assumption.
Qed.

Theorem all_first_prime_add :
  forall (l:list(nat*nat))(p n:nat),
    prime p ->
    all_first_prime l -> all_first_prime ((p,n)::l).
Proof.
  intros l p n Hlt Haf l1; case l1.
  -  intros l2 p' n' Heq; injection Heq; intros Hl Hn' Hp';
       rewrite <- Hp'; assumption.
  -  simpl; clear l1; intros fst_elem l1 l2 p' n' Heq; injection Heq;
       intros Hl Hfst; apply (Haf l1 l2 p' n' Hl).
Qed.

Theorem all_multiples_add :
  forall l n p,
    (exists q:nat, n=p*q)->
    all_multiples l ->
    all_multiples ((p,n)::l).
Proof.
  intros l n p Hdiv Ham l1; case l1.
  - simpl; intros l2 p' n' Heq; injection Heq;
      intros Hl2 Hn' Hp'; rewrite <- Hn'; rewrite <- Hp';
        assumption.

  - clear l1; simpl; intros fst_elem l1 l2 p' n' Heq; injection Heq;
      intros Hl Hfst; apply (Ham l1 l2); assumption.
Qed.

Theorem all_greater_than_one_add :
  forall l n p,
    1 < p -> all_greater_than_one l ->
    all_greater_than_one ((p,n)::l).
Proof.
  intros l n p Hlt Hal  l1; case l1.
  - simpl; intros l2 p' n' Heq; injection Heq;
      intros Hl2 Hn' Hp'; rewrite <- Hp';
        assumption.
  -  clear l1; simpl; intros fst_elem l1 l2 p' n' Heq; injection Heq;
       intros Hl Hfst; apply (Hal l1 l2 p' n'); assumption.
Qed.

Fixpoint same_first (l1 l2:list(nat*nat)) {struct l1} : bool :=
  match l1, l2 with
    nil, nil => true
  | ((a, _)::l'1), ((b, _)::l'2) =>
    match Nat.compare a b with
    | Eq => same_first l'1 l'2
    | _ => false
    end
  | _, _ => false
  end.

Theorem update_primes_same_first :
  forall k l l' b,
    update_primes k l = (l', b) ->
    forall l1 l2 p n,
      l = l1++(p,n)::l2 ->
      (exists l'1 : list(nat*nat),
          (exists l'2 : list(nat*nat),
              (exists n': nat,
                  l'=l'1++(p,n')::l'2))).
Proof.
  intros k l; elim l.
  - intros l' b Hup l1 l2 p n Heq; elim (absurd_decompose_list _ _ _ _ Heq).

  - intros (p,n) l0 Hrec l' b.
    simpl; case_eq (update_primes k l0); intros l'0 b0 Hup'.
    case (Nat.compare k n); intros Hup; injection Hup;
      intros Hb Hl'; intros l1; (case l1; [simpl; intros l2 p0 n0 Heq;
                                           injection Heq; intros Hl2 Hn0 Hp0; rewrite <- Hl'; rewrite <- Hp0;
                                           exists (nil (A:=nat*nat)); exists l'0 |
                                           clear l1; simpl; intros fst_elem l1 l2 p0 n0 Heq; injection Heq;
                                           intros Hl0 Hfst_elem; rewrite <- Hl';
                                           elim (Hrec l'0 b0 Hup' l1 l2 p0 n0 Hl0); intros l'1 (l'2, (n', Heq2));
                                           rewrite Heq2]).
    +  exists (n+p); reflexivity.
    +  exists ((p,n+p)::l'1); exists l'2; exists n'; reflexivity.
    + exists n; reflexivity.
    +  exists ((p,n)::l'1); exists l'2; exists n'; reflexivity.
    +  exists (n+p); reflexivity.
    + exists ((p,n+p)::l'1); exists l'2; exists n'; reflexivity.
Qed.

Theorem update_primes_all_prime_in_first :
 forall k l l' b,
  all_prime_in_first k l ->
  update_primes k l = (l', b) ->
  all_prime_in_first k l'.
Proof.
 intros k l l' b Hap Hup p Hplek Hpr.
 elim (Hap p Hplek Hpr); intros l'1 (l'2, (n', Heq)).
 apply (update_primes_same_first k l l' b Hup l'1 l'2 p n' Heq).
Qed.

Theorem prime_sieve_invariant :
  forall k l,
    prime_sieve (S k)=l ->
    all_first_less_than (S (S k)) l /\
    all_first_prime l /\
    all_prime_in_first (S (S k)) l /\
    all_intervals (S (S k)) l /\
    all_multiples l /\
    all_greater_than_one l.
Proof.
  intros k; elim k.
  -   simpl; intros l Hl; rewrite <- Hl; clear Hl l.
      split;[idtac | split; [idtac | split;[idtac|split;[idtac|split]]]];
        try (intros l1 l2 p n Heq; elim (absurd_decompose_list _ _ _ _ Heq)).
      intros n Hle1 ((Hnneq0, Hnneq1),_); elim Hnneq1.
      elim Hle1; intros; apply (le_antisym n 1); auto with arith.
  -
    intros k' Hrec l Hps.
    change ((let (l', b) :=
                 update_primes (S (S k')) (prime_sieve (S k')) in
             if b then l' else (S (S k'), 2*S (S k'))::l') = l) in Hps.
    case_eq (update_primes (S (S k')) (prime_sieve (S k'))); intros l' b Heq.
    generalize (Hrec (prime_sieve (S k'))); intros Hrec'.
    assert (Hal: all_first_less_than (S (S k')) l').
    {
      apply update_primes_all_first_less_than with (prime_sieve (S k')) b; auto.
      intuition.
    }
    assert (Hafp: all_first_prime l').
    { apply update_primes_all_first_prime
        with (S (S k')) (prime_sieve (S k')) b; auto.
      intuition.
    }
    assert (Hapf: all_prime_in_first (S (S k')) l').
    { apply update_primes_all_prime_in_first with (prime_sieve (S k')) b; auto.
      intuition.
    }
    assert (Hai : all_intervals (S (S (S k'))) l').
    {
      apply update_primes_all_intervals with (prime_sieve (S k')) b; auto.
      intuition.
      intuition.
    }

    assert (Ham : all_multiples l').
    { apply update_primes_all_multiples
        with (S (S k')) (prime_sieve (S k')) b; auto.
      intuition.
    }
    assert (Ha1 : all_greater_than_one l').
    {
      apply update_primes_all_greater_than_one with (S (S k')) (prime_sieve (S k')) b; auto.
      intuition.
    }
    case_eq b; intros Heqb; rewrite Heqb in Heq; rewrite Heq in Hps.
    + rewrite <- Hps.
      split;[idtac|split;[idtac|split;[idtac|split;[idtac|split;[idtac|idtac]]]]];
        auto.
      * apply all_first_less_than_S; assumption.
      * unfold all_prime_in_first.
        intros n Hint Hpr; unfold all_prime_in_first in Hapf; apply Hapf; auto.
        split.
        -- intuition.
        -- elim Hint.
           intros Hngt0 Hnlek.
           elim (le_lt_or_eq _ _ Hnlek).
           ++ auto with arith; fail.
           ++ intros Hn'; injection Hn'.
              intros Hn; rewrite Hn in Hpr; elim Hpr.
              intros _ Hnex; elim Hnex.
              unfold divides.
              apply update_primes_true_imp_div with (prime_sieve (S k')) l'.
              ** intuition.
              ** intuition.
              ** intuition.
              ** auto.
    + split.
      *
        intros l1; case l1.
        -- simpl; intros l2 p n; rewrite <- Hps; intros Heq2;injection Heq2.
           intros Hl2 Hn Hp; rewrite <- Hp; auto with arith.
        -- intros fst_elem l'1 l2 p n; simpl; rewrite <- Hps; intros Heq2;
             injection Heq2; intros Hl' Hfst_elem.
           assert (Hal' : all_first_less_than (S (S (S k'))) l').
           { apply all_first_less_than_S; auto. }
           apply (Hal' l'1 l2 p n); auto.
      * split.
        -- rewrite <- Hps; apply all_first_prime_add; auto.
           apply update_primes_false_imp_prime with (prime_sieve (S k')) l';
             try tauto.
           auto with arith.
        -- split.
           ++ rewrite <- Hps.
              intros n (Hpos, Hle) Hpr.
              elim (le_lt_or_eq _ _ Hle).
              ** intros Hlt; elim (Hapf n); auto with arith.
                 intros l'1 (l'2, (p, Heq2));
                   exists ((S (S k'), 2*S(S k'))::l'1); exists l'2; exists p.
                 rewrite Heq2;reflexivity.
              ** intros Hn'; injection Hn'; intros Hn.
                 exists (nil (A:=nat*nat)); exists l'; exists (2*S (S k')).
                 rewrite Hn;reflexivity.
           ++ split.
              ** rewrite <- Hps; apply all_intervals_add; auto with arith.
                 split.
                 { simpl.
                   rewrite minus_plus.
                   rewrite <- plus_n_O.
                   auto with arith.
                 }
                 { simpl.
                   repeat rewrite <- plus_n_Sm.
                   auto with arith.
                 }

              ** split.
                 { rewrite <- Hps; apply all_multiples_add; auto with arith.
                   exists 2; rewrite (mult_comm 2); reflexivity. }

                 rewrite <- Hps.
                 apply all_greater_than_one_add; auto with arith.
Qed.

Theorem prime_fun_sound :
  forall k, prime_fun k = true -> prime k.
Proof.
  intros k0; case k0.
  - simpl; intros; discriminate.
  -  intros k; unfold prime_fun.
     case_eq (prime_sieve (S k)).
     +
       intros; discriminate.
     + intros (p,n) l Heq; case_eq (Nat.compare p (S k));
         try(intros; discriminate; fail).
       intros Htwc _.
       assert (Hap:all_first_prime ((p,n)::l)).
       {  generalize (prime_sieve_invariant k ((p,n)::l) Heq); intuition. }
       rewrite <- (nat_compare_eq _ _ Htwc).
       apply (Hap nil l p n); auto.
Qed.

Theorem prime_fun_complete :
  forall k, prime k -> prime_fun k = true.
Proof.
  intros k; case k.
  -  intros ((Hneq0, Hneq1),Hnex); elim Hneq0; auto.
  - intros k'; case k'.
    +  intros ((Hneq0, Hneq1),Hnex); elim Hneq1; auto.
    + intros k'' ((_,_),Hnex); unfold prime_fun.
      assert (Hps: prime_sieve (S (S k'')) =
                   let (l',b) := (update_primes (S (S k'')) (prime_sieve (S k'')))
                   in
                   if b then l' else ((S (S k''), 2*S (S k''))::l')).
      {  auto. }
      rewrite Hps.
      case_eq  (update_primes (S (S k'')) (prime_sieve (S k''))).
      intros l' b; case b; intros Hup.
      *  elim Hnex.
         unfold divides.
         generalize (prime_sieve_invariant k'' (prime_sieve (S k'')));
           intros Hinv.
         apply (update_primes_true_imp_div (S (S k''))
                                           (prime_sieve (S k''))) with l';
           intuition.
      *  rewrite (Nat.compare_refl (S (S k''))); auto.
Qed.


Require Import Coq.ZArith.Int.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List. Import ListNotations.
Require Import PeanoNat.
Require Import Coq.Arith.Arith.

(* Option monad utilities *)
Definition bind{A B: Type} (x : option A) (f : A -> B) :=
  match x with
  | None => None
  | Some x => Some (f x)
  end.

(* Variables are just a nat *)
Definition Var := nat.

(* Registers (infinite) map nats to Z *)
Definition Regs := nat -> Z.

Definition get (var : Var) (r : Regs) := r var.

Definition put (var : Var) v (r : Regs) :=
  fun var' => if var' =? var then v else r var'.

(* Registers are zeroed by default *)
Definition emptyRegs :=
  fun (var' : Var) => Z0.

Inductive Stmt :=
  | SAdd (a b c : Var) (* a = b + c *)
  | SIf (cond : Var) (trueEval falseEval : Stmt) (* if cond == 0 then falseEval else trueEval *)
  | SSeq (s1 s2 : Stmt) (* s1 ; s2 *)
  | SLit (a : Var) (v : Z) (* a = $v *)
  | SNop
  .

Open Scope Z_scope.

Definition inc_eval_log (inc : Z) (res : option (Z * Regs)) :=
  bind res (fun x => ((fst x) + inc, snd x)).

Fixpoint eval_stmt_log (fuel : nat) (s : Stmt) (r : Regs) :=
  match fuel with
  | O => None
  | S f => match s with
           | SAdd a b c => Some (1, put a ((get b r) + (get c r)) r)
           | SIf cond trueEval falseEval => if (Z.eqb (get cond r) 0%Z) then
                                              inc_eval_log 1 (eval_stmt_log f falseEval r)
                                            else
                                              inc_eval_log 1 (eval_stmt_log f trueEval r)
           | SSeq s1 s2 => match eval_stmt_log f s1 r with
                           | None => None
                           | Some (count, r') => inc_eval_log count (eval_stmt_log f s2 r')
                           end
           | SLit a v => Some (1, put a v r)
           | SNop => Some (1, r)
           end
  end.

Close Scope Z_scope.

Definition var_a := 1.
Definition var_b := 2.
Definition var_tmp := 3.

(* Test stmt, loads n into var_a and doubles it *)
Definition eg_double_stmt n :=
  SSeq (SLit var_a n) (SAdd var_a var_a var_a).

Definition eg_double_res n := (eval_stmt_log 5 (eg_double_stmt n) emptyRegs).

Definition eg_double_instructions n := bind (eg_double_res n) fst.
Definition eg_double_regs n := bind (eg_double_res n) snd.
Definition eg_double_val n := bind (eg_double_regs n) (get var_a).

Lemma eg_double_5_correct : eg_double_val 5%Z = Some 10%Z.
Proof. reflexivity. Qed.

Lemma eg_double_neg12_correct : eg_double_val (Z.neg 12) = Some (Z.neg 24).
Proof. reflexivity. Qed.

Inductive Instr :=
  | IAdd (a b c : Var)
  | IJump (pc : nat)
  | IBeqz (a : Var) (pc : nat)
  | IImm (a : Var) (v : Z)
  | INop
  .

Fixpoint compile_stmt (s : Stmt) :=
  match s with
  | SAdd a b c => [IAdd a b c]
  | SIf c t f => match (compile_stmt t) with
                 | t' => match (compile_stmt f) with
                         | f' => [IBeqz c (1 + (length t'))] ++ t' ++ [IJump (length f')] ++ f'
                         end
                 end
  | SSeq s1 s2 => (compile_stmt s1) ++ (compile_stmt s2)
  | SLit a v => [IImm a v]
  | SNop => [INop]
  end.

Record InstrMachineLog := mkInstrMachineLog {
  Iregs : Regs;
  Ipc : nat;
  Icount : Z;
}.

Definition emptyMachineLog := mkInstrMachineLog emptyRegs 0 0.

Definition with_Iregs r m := mkInstrMachineLog r m.(Ipc) m.(Icount).
Definition with_Ipc p m := mkInstrMachineLog m.(Iregs) p m.(Icount).
Definition with_Icount c m := mkInstrMachineLog m.(Iregs) m.(Ipc) c.

Definition inc_count (n : Z) m := with_Icount (m.(Icount) + n) m.
Definition inc_pc p m := with_Ipc ((m.(Ipc) + p)) m.

Definition add_regs a b c m := with_Iregs (put a ((get b m.(Iregs)) + (get c m.(Iregs))) m.(Iregs)) m.
Definition load_imm a v m := with_Iregs (put a v m.(Iregs)) m.

Fixpoint eval_instr_log fuel (m : InstrMachineLog) (instrs : list Instr) pcf : option InstrMachineLog :=
  match fuel with
  | O => None
  | S fuel' => if pcf =? m.(Ipc) then Some m else
                 match nth_error instrs m.(Ipc) with
                 | None => None (* Should never happen *)
                 | Some i => eval_instr_log fuel' (inc_count 1 (
                               match i with
                               | IAdd a b c => inc_pc 1 (add_regs a b c (m))
                               | IJump pc' => inc_pc (pc' + 1) m
                               | IBeqz a pc' => inc_pc (if (Z.eqb (get a m.(Iregs)) 0%Z) then pc' + 1 else 1) m
                               | IImm a v => inc_pc 1 (load_imm a v m)
                               |  INop => inc_pc 1 m
                               end)) instrs pcf
                 end
  end.

Definition get_compiled_result (s: Stmt) (result_var : Var) :=
  let c := compile_stmt s in
    match eval_instr_log 100 emptyMachineLog c ((length c) - 1) with
    | None => None
    | Some m => Some (get result_var m.(Iregs))
    end.

Fixpoint stmt_list_to_stmt l :=
  match l with
  | [] => SNop
  | hd :: tl => SSeq hd (stmt_list_to_stmt tl)
  end.

(* if (a == 5) then b = 500 else b = 100 *)

Definition eg_cond_stmt a := stmt_list_to_stmt
  [
    (SLit var_a a);
    (SLit var_tmp (Z.neg 5));
    (SAdd var_a var_a var_tmp);
    (SIf var_a
      (SLit var_b 100)
      (SLit var_b 500)
    )
  ].

Compute (compile_stmt (eg_cond_stmt 5%Z)).

Lemma eg_cond_5_correct : get_compiled_result (eg_cond_stmt 5%Z) var_b = Some 500%Z.
Proof. reflexivity. Qed.

Lemma eg_cond_neg12_correct : get_compiled_result (eg_cond_stmt (Z.neg 12)) var_b = Some 100%Z.
Proof. reflexivity. Qed.

Lemma inc_log : forall n x countH Hfr,
  inc_eval_log n x = Some (countH, Hfr) ->
  x = Some ((countH - n)%Z, Hfr).
Proof.
intros. unfold inc_eval_log in H.
destruct x.
- inversion H. f_equal. rewrite Z.add_simpl_r. apply surjective_pairing.
- discriminate.
Qed.

Lemma fetch_inst : forall (instsBefore instsAfter : list Instr) x,
  nth_error (instsBefore ++ x :: instsAfter) (length instsBefore) = Some x.
Proof.
induction instsBefore.
- reflexivity.
- auto.
Qed.

Open Scope Z_scope.

Lemma bounded_instrs :
forall (fuelH fuelL: nat) (s : Stmt) countH Hfr Lfr instsBefore instsAfter startCountL endCountL ir,
  eval_stmt_log fuelH s ir = Some (countH, Hfr) ->
  eval_instr_log fuelL
    (mkInstrMachineLog ir (length instsBefore) startCountL)
    (instsBefore ++ compile_stmt s ++ instsAfter)
    (length (instsBefore ++ compile_stmt s))%nat
    = Some (mkInstrMachineLog Lfr (length (instsBefore ++ compile_stmt s))%nat endCountL) ->
  (endCountL - startCountL) < 3 * countH.
Proof.
induction fuelH.
- discriminate.
- destruct s.
  + (* s = SAdd a b c *)
    intros countH Hfr Lfr instsBefore instsAfter startCountL endCountL ir HHi HLo.
    inversion HHi.
    destruct fuelL. discriminate.
    rewrite app_length in HLo. simpl in HLo.
    replace (_ + 1 =? _)%nat with false in HLo.
    2 : { symmetry. rewrite Nat.eqb_neq. omega. }
    replace (nth_error (_) (_)) with (Some (IAdd a b c)) in HLo.
    2 : { symmetry. apply fetch_inst. }
    destruct fuelL. discriminate.
    simpl in HLo.
    replace (_ =? _)%nat with true in HLo.
    2 : { symmetry. rewrite Nat.eqb_eq. reflexivity. }
    inversion HLo. omega.
  + (* s = SIf cond trueEval falseEval *)
    intros countH Hfr Lfr instsBefore instsAfter startCountL endCountL ir HHi HLo.
    simpl in HHi.
    destruct fuelL. discriminate.
    simpl in HLo.
    replace (_ =? _)%nat with false in HLo.
    2 : { symmetry. rewrite Nat.eqb_neq. rewrite app_length. simpl. omega. }
    replace (nth_error _ _) with (Some (IBeqz cond (S (length (compile_stmt s1))))) in HLo.
    2 : { rewrite (
              fetch_inst
              instsBefore
              ((compile_stmt s1 ++ IJump (length (compile_stmt s2)) :: compile_stmt s2) ++ instsAfter)
              (IBeqz cond (S (length (compile_stmt s1))))). f_equal. }
    destruct fuelL. discriminate.
    destruct fuelH. { destruct (get cond ir =? 0). discriminate. discriminate. }
    destruct (get cond ir =? 0) eqn:HCond.
    * (* False condition (s2) *)
      apply (inc_log 1 (eval_stmt_log (S fuelH) s2 ir) countH Hfr) in HHi.
      specialize (
        IHfuelH (S fuelL) s2 (countH - 1) Hfr Lfr
        ((instsBefore ++ [IBeqz cond (1 + (length (compile_stmt s1)))]) ++ (compile_stmt s1) ++ [IJump (length (compile_stmt s2))])
        instsAfter (startCountL + 1) endCountL ir).
      assert (HIneq: endCountL - (startCountL + 1) < 3 * (countH - 1) -> endCountL - startCountL < 3 * countH). omega.
      apply HIneq.
      apply IHfuelH.
      ** apply HHi.
      ** assert(HPc: length
                 (instsBefore ++
                  IBeqz cond (S (length (compile_stmt s1)))
                  :: compile_stmt s1 ++ IJump (length (compile_stmt s2)) :: compile_stmt s2) =
                length
                 (((instsBefore ++ [IBeqz cond (1 + length (compile_stmt s1))]) ++
                  compile_stmt s1 ++ [IJump (length (compile_stmt s2))]) ++ compile_stmt s2)).
         { repeat rewrite <- app_assoc. repeat rewrite app_length.
           f_equal. simpl. rewrite app_length. simpl. reflexivity. }
         rewrite HPc in HLo.
         rewrite <- HLo. repeat rewrite <- app_assoc. f_equal.
         *** unfold inc_count. unfold inc_pc. unfold with_Icount. unfold with_Ipc.
             unfold Iregs. unfold Ipc. unfold Icount. f_equal.
             repeat rewrite app_length. reflexivity.
    * (* True condition (s1) *)
      apply (inc_log 1 (eval_stmt_log (S fuelH) s1 ir) countH Hfr) in HHi.
      admit.
  + (* s = SSeq s1 s2 *)
    admit.
  + (* s = SLit a v *)
    admit.
  + (* s = SNop *)
    admit.
Admitted.


(**
  This formalises Theorem 3.6 from "The Joy of Cryptography" (p. 51).
  It is a simple 2-out-of-2 secret-sharing scheme with perfect security,
  based on XOR.

  It is fairly simple to understand. The hardest part is probably the definition
  of [plus] (XOR), which is not really necessary to understand the proof.

  The final statement ([unconditional_secrecy]) is equivalent to that of the
  books: The scheme achieves perfect secerery with up to two shares
  (non-inclusive).
*)

From Relational Require Import OrderEnrichedCategory GenericRulesSimple.

Set Warnings "-notation-overridden,-ambiguous-paths".
From mathcomp Require Import all_ssreflect all_algebra reals distr realsum
  ssrnat ssreflect ssrfun ssrbool ssrnum eqtype choice seq.
Set Warnings "notation-overridden,ambiguous-paths".

From Mon Require Import SPropBase.
From Crypt Require Import Axioms ChoiceAsOrd SubDistr Couplings
  UniformDistrLemmas FreeProbProg Theta_dens RulesStateProb
  pkg_core_definition choice_type pkg_composition pkg_rhl Package Prelude.

From extructures Require Import ord fset fmap.

Import SPropNotations.

Import PackageNotation.

From Equations Require Import Equations.
Require Equations.Prop.DepElim.

Set Equations With UIP.

Set Bullet Behavior "Strict Subproofs".
Set Default Goal Selector "!".
Set Primitive Projections.

Import Num.Def.
Import Num.Theory.
Import Order.POrderTheory.

Section SecretSharing_example.

Variable (n: nat).

Definition Word_N: nat := 2^n.
Definition Word: choice_type := chFin (mkpos Word_N).

(**
  The first bit is a formalisation of [plus] (XOR).
  It is similar to the definitions in OTP.v and PRF.v, but it has been split
  into lemmas to hopefully be easier to read.
  It is still somewhat unwieldy though.
*)

(**
  Lemmas for the [plus] obligation.
*)
Lemma pow2_inj m:
  (2 ^ m)%N = BinNat.N.to_nat (BinNat.N.pow (BinNums.Npos (BinNums.xO 1%AC)) (BinNat.N.of_nat m)).
Proof.
  elim: m => [// | m IHm].
  rewrite expnSr Nnat.Nat2N.inj_succ BinNat.N.pow_succ_r' Nnat.N2Nat.inj_mul PeanoNat.Nat.mul_comm.
  by apply: f_equal2.
Qed.

Lemma log2_lt_pow2 w m:
  (w.+1 < 2^m)%N ->
  BinNat.N.lt (BinNat.N.log2 (BinNat.N.of_nat w.+1)) (BinNat.N.of_nat m).
Proof.
  move=> H.
  rewrite -BinNat.N.log2_lt_pow2.
  - rewrite /BinNat.N.lt Nnat.N2Nat.inj_compare PeanoNat.Nat.compare_lt_iff -pow2_inj Nnat.Nat2N.id.
    by apply /ltP.
  - rewrite Nnat.Nat2N.inj_succ.
    by apply: BinNat.N.lt_0_succ.
Qed.

#[program] Definition plus (w k: Word): Word :=
  @Ordinal _ (BinNat.N.to_nat (BinNat.N.lxor
    (BinNat.N.of_nat (nat_of_ord w))
    (BinNat.N.of_nat (nat_of_ord k)))) _.
Next Obligation.
  move: w k => [[|w] Hw] [[|k] Hk].
  1-3: by rewrite /= ?Pnat.SuccNat2Pos.id_succ.
  move: (log2_lt_pow2 _ _ Hw) => H1.
  move: (log2_lt_pow2 _ _ Hk) => H2.
  move: (BinNat.N.max_lub_lt _ _ _ H1 H2) => Hm.
  case: (BinNat.N.eq_dec (BinNat.N.lxor (BinNat.N.of_nat w.+1) (BinNat.N.of_nat k.+1)) BinNat.N0) => H0.
  1: by rewrite H0 expn_gt0.
  move: (BinNat.N.log2_lxor (BinNat.N.of_nat w.+1) (BinNat.N.of_nat k.+1)) => Hbound.
  move: (BinNat.N.le_lt_trans _ _ _ Hbound Hm).
  rewrite -BinNat.N.log2_lt_pow2.
  2: by apply BinNat.N.neq_0_lt_0.
  rewrite /BinNat.N.lt Nnat.N2Nat.inj_compare PeanoNat.Nat.compare_lt_iff -pow2_inj.
  by move /ltP.
Qed.

Notation "m ⊕ k" := (plus m k) (at level 70).

(**
  Some lemmas for [plus] itself.
*)
Lemma plus_comm m k:
  (m ⊕ k) = (k ⊕ m).
Proof.
  apply: ord_inj.
  case: m => m ? /=.
  by rewrite BinNat.N.lxor_comm.
Qed.

Lemma plus_assoc m l k:
  ((m ⊕ l) ⊕ k) = (m ⊕ (l ⊕ k)).
Proof.
  apply: ord_inj.
  case: m => m ? /=.
  rewrite !Nnat.N2Nat.id.
  by rewrite BinNat.N.lxor_assoc.
Qed.

Lemma plus_involutive m k:
  (m ⊕ k) ⊕ k = m.
Proof.
  rewrite plus_assoc.
  apply: ord_inj.
  case: m => m ? /=.
  rewrite Nnat.N2Nat.id.
  rewrite BinNat.N.lxor_nilpotent.
  rewrite BinNat.N.lxor_0_r.
  by rewrite Nnat.Nat2N.id.
Qed.

#[local] Open Scope package_scope.

Notation " 'word " := (Word) (in custom pack_type at level 2).
Notation " 'word " := (Word) (at level 2): package_scope.

(**
  We can't use sequences directly in [choice_type] so instead we use a map from
  natural numbers to the type.
*)
Definition chSeq t := chMap 'nat t.

Notation " 'seq t " := (chSeq t) (in custom pack_type at level 2).
Notation " 'seq t " := (chSeq t) (at level 2): package_scope.

(**
  We can't use sets directly in [choice_type] so instead we use a map to units.
  We can then use [domm] to get the domain, which is a set.
*)
Definition chSet t := chMap t 'unit.

Notation " 'set t " := (chSet t) (in custom pack_type at level 2).
Notation " 'set t " := (chSet t) (at level 2): package_scope.

Definition shares: nat := 0.

Definition SHARE_pkg_tt:
  package fset0 [interface]
    [interface #val #[shares]: ('word × 'word) × 'set 'nat → 'seq 'word ] :=
  [package
    #def #[shares] ('(ml, mr, U): ('word × 'word) × 'set 'nat): 'seq 'word {
      if size (domm U) >= 2 then ret emptym
      else
      s0 <$ uniform (2^n) ;;
      let s1 := s0 ⊕ ml in
      let sh := [fmap (0, s0) ; (1, s1)] in
      ret (fmap_of_seq (pmap sh (domm U)))
    }
  ].

Definition SHARE_pkg_ff:
  package fset0 [interface]
    [interface #val #[shares]: ('word × 'word) × 'set 'nat → 'seq 'word ] :=
  [package
    #def #[shares] ('(ml, mr, U): ('word × 'word) × 'set 'nat): 'seq 'word {
      if size (domm U) >= 2 then ret emptym
      else
      s0 <$ uniform (2^n) ;;
      let s1 := s0 ⊕ mr in
      let sh := [fmap (0, s0) ; (1, s1)] in
      ret (fmap_of_seq (pmap sh (domm U)))
    }
  ].

Definition mkpair {Lt Lf E}
  (t: package Lt [interface] E) (f: package Lf [interface] E):
  loc_GamePair E := fun b => if b then {locpackage t} else {locpackage f}.

Definition SHARE := mkpair SHARE_pkg_tt SHARE_pkg_ff.

Lemma SHARE_equiv:
  SHARE true ≈₀ SHARE false.
Proof.
  apply: eq_rel_perf_ind_eq.
  simplify_eq_rel m.
  apply rpost_weaken_rule with eq;
    last by move=> [? ?] [? ?] [].
  case m => [[ml mr] U].
  case: (_ (domm U)) => {U} [|a U] /=.
  1: by apply: rreflexivity_rule.
  case: U => [|b U] /=.
  2: by apply: rreflexivity_rule.
  case: a => [|[|a]] /=.
  1,3: by apply: rreflexivity_rule.
  apply: r_uniform_bij => [|s0].
  1: {
    exists (fun x => x ⊕ (ml ⊕ mr)) => x.
    all: by apply: plus_involutive.
  }
  rewrite plus_assoc plus_involutive.
  by apply: rreflexivity_rule.
Qed.

(**
  This corresponds to Theorem 3.6 from "The Joy of Cryptography".
*)
Theorem unconditional_secrecy LA A:
  ValidPackage LA
    [interface #val #[shares]: ('word × 'word) × 'set 'nat → 'seq 'word ]
    A_export A ->
  Advantage SHARE A = 0%R.
Proof.
  move=> vA.
  rewrite Advantage_E Advantage_sym.
  by rewrite SHARE_equiv ?fdisjoints0.
Qed.

End SecretSharing_example.


Require
  MathClasses.interfaces.naturals MathClasses.theory.naturals MathClasses.implementations.peano_naturals MathClasses.theory.integers.
Require Import
  Coq.ZArith.BinInt Coq.setoid_ring.Ring Coq.Arith.Arith Coq.NArith.NArith Coq.ZArith.ZArith Coq.Numbers.Integer.Binary.ZBinary
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.integers
  MathClasses.implementations.natpair_integers MathClasses.implementations.stdlib_binary_naturals
  MathClasses.interfaces.additional_operations MathClasses.interfaces.orders
  MathClasses.implementations.nonneg_integers_naturals.

(* canonical names: *)
Instance Z_equiv: Equiv Z := eq.
Instance Z_plus: Plus Z := Zplus.
Instance Z_0: Zero Z := 0%Z.
Instance Z_1: One Z := 1%Z.
Instance Z_mult: Mult Z := Zmult.
Instance Z_negate: Negate Z := Zopp.
  (* some day we'd like to do this with [Existing Instance] *)

Instance: Ring Z.
Proof.
  repeat (split; try apply _); repeat intro.
           now apply Zplus_assoc.
          now apply Zplus_0_r.
         now apply Zplus_opp_l.
        now apply Zplus_opp_r.
       now apply Zplus_comm.
      now apply Zmult_assoc.
     now apply Zmult_1_l.
    now apply Zmult_1_r.
   now apply Zmult_comm.
  now apply Zmult_plus_distr_r.
Qed.

(* misc: *)
Instance: ∀ x y : Z, Decision (x = y) := ZArith_dec.Z_eq_dec.

Add Ring Z: (rings.stdlib_ring_theory Z).

(* * Embedding N into Z *)
Instance inject_N_Z: Cast N Z := Z_of_N.

Instance: SemiRing_Morphism Z_of_N.
Proof.
  repeat (split; try apply _).
   exact Znat.Z_of_N_plus.
  exact Znat.Z_of_N_mult.
Qed.

Instance: Injective Z_of_N.
Proof.
  repeat (split; try apply _).
  intros x y E. now apply Znat.Z_of_N_eq_iff.
Qed.

(* SRpair N and Z are isomorphic *)
Definition Npair_to_Z (x : SRpair N) : Z := ('pos x - 'neg x)%mc.

Instance: Proper (=) Npair_to_Z.
Proof.
  intros [xp xn] [yp yn] E; do 2 red in E; unfold Npair_to_Z; simpl in *.
  apply (right_cancellation (+) ('yn + 'xn)); ring_simplify.
  now rewrite <-?rings.preserves_plus, E, commutativity.
Qed.

Instance: SemiRing_Morphism Npair_to_Z.
Proof.
  repeat (split; try apply _).
   intros [xp xn] [yp yn].
   change ('(xp + yp) - '(xn + yn) = 'xp - 'xn + ('yp - 'yn)).
   rewrite ?rings.preserves_plus. ring.
  intros [xp xn] [yp yn].
  change ('(xp * yp + xn * yn) - '(xp * yn + xn * yp) = ('xp - 'xn) * ('yp - 'yn)).
  rewrite ?rings.preserves_plus, ?rings.preserves_mult. ring.
Qed.

Instance: Injective Npair_to_Z.
Proof.
  split; try apply _.
  intros [xp xn] [yp yn] E.
  unfold Npair_to_Z in E. do 2 red. simpl in *.
  apply (injective (cast N Z)).
  rewrite ?rings.preserves_plus.
  apply (right_cancellation (+) ('xp - 'xn)). rewrite E at 1. ring.
Qed.

Instance Z_to_Npair: Inverse Npair_to_Z := λ x,
  match x with
  | Z0 => C 0 0
  | Zpos p => C (Npos p) 0
  | Zneg p => C 0 (Npos p)
  end.

Instance: Surjective Npair_to_Z.
Proof. split; try apply _. intros [|?|?] ? E; now rewrite <-E. Qed.

Instance: Bijective Npair_to_Z := {}.

Instance: SemiRing_Morphism Z_to_Npair.
Proof. change (SemiRing_Morphism (Npair_to_Z⁻¹)). split; apply _. Qed.

Instance: IntegersToRing Z := integers.retract_is_int_to_ring Npair_to_Z.
Instance: Integers Z := integers.retract_is_int Npair_to_Z.

Instance Z_le: Le Z := Zle.
Instance Z_lt: Lt Z := Zlt.

Instance: SemiRingOrder Z_le.
Proof.
  assert (PartialOrder Z_le).
   repeat (split; try apply _).
   exact Zorder.Zle_antisym.
  rapply rings.from_ring_order.
   repeat (split; try apply _).
   intros x y E. now apply Zorder.Zplus_le_compat_l.
  intros x E y F. now apply Zorder.Zmult_le_0_compat.
Qed.

Instance: TotalRelation Z_le.
Proof.
  intros x y.
  destruct (Zorder.Zle_or_lt x y); intuition.
  right. now apply Zorder.Zlt_le_weak.
Qed.

Instance: FullPseudoSemiRingOrder Z_le Z_lt.
Proof.
  rapply semirings.dec_full_pseudo_srorder.
  split.
   intro. split. now apply Zorder.Zlt_le_weak. now apply Zorder.Zlt_not_eq.
  intros [E1 E2]. destruct (Zorder.Zle_lt_or_eq _ _ E1). easy. now destruct E2.
Qed.

(* * Embedding of the Peano naturals into [Z] *)
Instance inject_nat_Z: Cast nat Z := Z_of_nat.

Instance: SemiRing_Morphism Z_of_nat.
Proof.
  repeat (split; try apply _).
   exact Znat.inj_plus.
  exact Znat.inj_mult.
Qed.

(* absolute value *)
Program Instance Z_abs_nat: IntAbs Z nat := λ x,
  match x with
  | Z0 => inl (0:nat)
  | Zpos p => inl (nat_of_P p)
  | Zneg p => inr (nat_of_P p)
  end.
Next Obligation. reflexivity. Qed.
Next Obligation. now rewrite <-(naturals.to_semiring_unique Z_of_nat), Znat.Z_of_nat_of_P. Qed.
Next Obligation. now rewrite <-(naturals.to_semiring_unique Z_of_nat), Znat.Z_of_nat_of_P. Qed.

Program Instance Z_abs_N: IntAbs Z N := λ x,
  match x with
  | Z0 => inl (0:N)
  | Zpos p => inl (Npos p)
  | Zneg p => inr (Npos p)
  end.
Next Obligation. reflexivity. Qed.
Next Obligation. now rewrite <-(naturals.to_semiring_unique Z_of_N). Qed.
Next Obligation. now rewrite <-(naturals.to_semiring_unique Z_of_N). Qed.

(* Efficient nat_pow *)
Program Instance Z_pow: Pow Z (Z⁺) := Z.pow.

Instance: NatPowSpec Z (Z⁺) Z_pow.
Proof.
  split; unfold pow, Z_pow.
    intros x1 y1 E1 [x2 Ex2] [y2 Ey2] E2.
    unfold equiv, sig_equiv in E2.
    simpl in *. now rewrite E1, E2.
   intros. now apply Z.pow_0_r.
  intros x n.
  rewrite rings.preserves_plus, rings.preserves_1.
  rewrite <-(Z.pow_1_r x) at 2. apply Z.pow_add_r.
   auto with zarith.
  now destruct n.
Qed.

Instance Z_Npow: Pow Z N := λ x n, Z.pow x ('n).

Instance: NatPowSpec Z N Z_Npow.
Proof.
  split; unfold pow, Z_Npow.
    solve_proper.
   intros. now apply Z.pow_0_r.
  intros x n.
  rewrite rings.preserves_plus, rings.preserves_1.
  rewrite <-(Z.pow_1_r x) at 2. apply Z.pow_add_r.
   auto with zarith.
  now destruct n.
Qed.

(* Efficient shiftl *)
Program Instance Z_shiftl: ShiftL Z (Z⁺) := Z.shiftl.

Instance: ShiftLSpec Z (Z⁺) Z_shiftl.
Proof.
  apply shiftl_spec_from_nat_pow.
  intros x [n En].
  apply Z.shiftl_mul_pow2.
  now apply En.
Qed.

Instance Z_Nshiftl: ShiftL Z N := λ x n, Z.shiftl x ('n).

Instance: ShiftLSpec Z N Z_Nshiftl.
Proof.
  apply shiftl_spec_from_nat_pow.
  intros x n.
  apply Z.shiftl_mul_pow2.
  now destruct n.
Qed.

Program Instance Z_abs: Abs Z := Zabs.
Next Obligation.
  split; intros E.
   now apply Z.abs_eq.
  now apply Z.abs_neq.
Qed.

Instance Z_div: DivEuclid Z := Zdiv.
Instance Z_mod: ModEuclid Z := Zmod.

Instance: EuclidSpec Z _ _.
Proof.
  split; try apply _.
     exact Z_div_mod_eq_full.
    intros x y Ey. destruct (Z_mod_remainder x y); intuition.
   now intros [].
  now intros [].
Qed.


(* Interface of MetricSpace type with types from the Coqeulicot Hierarchy *)
From mathcomp Require Import all_ssreflect.
From rlzrs Require Import all_rlzrs.
Require Import pointwise reals pseudo_metrics pseudo_metric_spaces metrics metric_spaces standard.
Require Import Reals Psatz Classical ChoiceFacts.
From Coquelicot Require Import Coquelicot.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section infima.
  Local Open Scope metric_scope.
  Implicit Types (A: subset R).

  Definition is_lower_bound A x:= forall a, a \from A -> x <= a.

  Definition lower_bounds A:= make_subset (fun x => is_lower_bound A x).

  Definition is_infimum A x := is_lower_bound A x /\ is_upper_bound (lower_bounds A) x.

  Lemma is_infimum_glb_Rbar A x: is_infimum A x <-> is_glb_Rbar A (Finite x).
  Proof.
    rewrite is_glb_Rbar_correct.
    split => [[lb inf] | [lb inf]].
    - split.
      + case; try by case.
        by move => y [_ Ay]; apply/lb.
      case => //[ y ass | ass].
      + apply/inf => z Az.
        have /=ass' := ass z.
        by apply/ass'.
      suff: (x + 1 <= x) by lra.
      apply/inf => y Ay; have /= ass' := ass (Finite y).
      by exfalso; apply/ass'.
    split => y Ay; first exact/(lb y).
    apply/(inf y); case => // [z [_ ] | []]//.
    exact/Ay.
  Qed.

  Definition mf_infimum:= make_mf is_infimum.

  Lemma inf_sing: mf_infimum \is_singlevalued.
  Proof.
    move => A inf inf' [bnd sup] [bnd' sup'].
    suff: inf <= inf' /\ inf' <= inf by lra.
    by split; [apply/sup' | apply/sup].
  Qed.

  Definition p_infimum A := match Glb_Rbar A with
                        | Finite r => Some r
                        | _ => None
                        end.

  Lemma p_inf_spec: pf2MF p_infimum =~= mf_infimum.
  Proof.
    move => A infA; rewrite /p_infimum /=.
    split => [/= | /is_infimum_glb_Rbar spec]; last by have -> := is_glb_Rbar_unique _ _ spec.
    case spec: (Glb_Rbar A) => [x | | ] // <-.
    apply/is_infimum_glb_Rbar; rewrite -spec.
    exact/Glb_Rbar_correct.
  Qed.

  Definition infimum A := match Glb_Rbar A with
                      | Finite r => r
                      | _ => 0
                      end.

  Notation inf := infimum.

  Lemma inf_icf: infimum \is_choice_for mf_infimum.
  Proof.
    rewrite /infimum => A [infA val].
    rewrite (is_glb_Rbar_unique A infA) //.
    exact/is_infimum_glb_Rbar.
  Qed.

  Definition nonempty A:= exists a, a \from A.

  Definition nonempties := make_subset nonempty.

  Definition bounded_from_below A := exists a, a \from lower_bounds A.

  Definition lower_boundeds:= make_subset bounded_from_below.

  Lemma dom_inf: FunctionalCountableChoice_on R -> dom mf_infimum === lower_boundeds \n nonempties.
  Proof.
    move => choice A; split => [[x [lb inf]] | [[y lb] [x Ax]]].
    - split; first by exists x.
      apply/not_all_not_ex => mty.
      suff: x + 1 <= x by lra.
      by apply/inf => y Ay; exfalso; apply/mty/Ay.
    have := lb x Ax.
    case => [ineq | eq]; last by exists x; split => [ | z lbz]; [rewrite -eq | exact/lbz].
    suff /choice [xn xnprp]:
      forall n, exists (xn: M2PM metric_R), lower_bounds A xn
                           /\
                           exists z, A z /\ d (xn, z) <= /2^n.
    - have xnbnd: forall n, is_lower_bound A (xn n) by move => n; have []:= xnprp n.
      have /(@fchy_lim_eff R_MetricSpace R_cmplt) [infA lmt]:
        (xn: sequence_in (M2PM R_MetricSpace)) \fast_Cauchy.
      + apply cchy_eff_suff => n m nlm.
        have [_ [z [Az dst]]]:= xnprp m.
        have [_ [z' [Az' dst']]]:= xnprp n.
        have := xnbnd n z Az; have := xnbnd m z' Az'.
        by move : dst dst' => /=; split_Rabs; lra.
      exists infA.
      split => [z Az | x' lbx'].
      + apply/lim_inc; last apply lim_cnst; last apply lim_eff_lim; last by apply lmt.
        by move => n; rewrite/cnst; apply/xnbnd.
      apply/cond_leq => eps eg0.
      have /accf_tpmn [N [pos Nle]] : 0 < eps/2 by lra.
      have [_ [z [Az dst]]]:= xnprp N.
      have := lbx' z Az; have := lmt N.
      by move: dst => /=; split_Rabs; lra.
    suff prp: forall n, exists (xn: M2PM metric_R), lower_bounds A xn
                                   /\
                                   exists z, A z /\ d(xn, z) <= (x - y)/2^n.
    - move => n.
      have /accf_tpmn [N [pos Nlxy]]: 0 < /(x - y) by apply/Rinv_0_lt_compat; lra.
      have [xn [xnlb [z [Az dst]]]]:= prp (N + n)%nat.
      exists xn; split => //.
      exists z; split => //.
      have lt: 0 < 2^n by apply pow_lt; lra.
      have lt': 0< 2^N by apply/pow_lt; lra.
      apply/Rle_trans; first exact/dst.
      rewrite pow_add /Rdiv Rinv_mult_distr; try lra.
      rewrite -Rmult_assoc -{2}(Rmult_1_l (/2^n)).
      apply/Rmult_le_compat_r; first by apply/Rlt_le/Rinv_0_lt_compat.
      rewrite -(Rinv_r (2^N)); try lra.
      apply/Rmult_le_compat_r; first by apply/Rlt_le/Rinv_0_lt_compat.
      rewrite -(Rinv_involutive (2^N)); try lra.
      rewrite -(Rinv_involutive (x - y)); try lra.
      by apply/Rinv_le_contravar; lra.
    elim => [ | n [xn [xnlb [z [Az dst]]]]].
    - by exists y; split; last by exists x; split; last by simpl; split_Rabs; lra.
    case: (classic (exists z', A z' /\ d(xn, z') <= (x - y)/2^n.+1)) => [ex | /not_ex_all_not nex].
    - by exists xn.
    exists (xn + (x-y)/2^n.+1).
    split => [z' Az' |].
    - have /not_and_or [nAz' | /Rnot_le_lt dst']:= nex z'; first by exfalso; apply/nAz'.
      by have := xnlb z' Az'; move: dst' => /=; split_Rabs; lra.
    have /not_and_or [nAz | /Rnot_le_lt dst']:= nex z; first by exfalso; apply/nAz.
    exists z; split => //; have xnlz:= xnlb z Az.
    have xn'lz: xn + (x - y) /2^n.+1 <= z.
    - have : 0 < (x - y) /2^n.+1 by apply/Rdiv_lt_0_compat/pow_lt; lra.
      by simpl in dst; move : dst' dst; rewrite [X in _ < X]/=; split_Rabs; lra.
    rewrite /Rdiv (tpmn_half n) in dst.
    by move: xn'lz dst' dst => /=; split_Rabs; lra.
  Qed.

  Lemma inf_spec A: A \from dom mf_infimum -> mf_infimum A (inf A).
  Proof. exact/inf_icf. Qed.

  Lemma inf_eq A r: A \from dom mf_infimum -> mf_infimum A r -> inf A = r.
  Proof.
    move => fd val.
    exact/inf_sing/val/inf_icf.
  Qed.

  Lemma inf_leq A x: A \from dom mf_infimum -> x \from A -> inf A <= x.
  Proof.
    move => Afd xfa.
    have [lb _]:= inf_icf Afd.
    exact/lb.
  Qed.

  Lemma bnds_inf_leq A x: FunctionalCountableChoice_on R ->
                          A \from lower_boundeds -> x \from A -> inf A <= x.
  Proof.
    move => choice bnd elt; apply/inf_leq => //.
    by rewrite dom_inf //; split; last exists x.
  Qed.

  Lemma inf_geq A x: A \from dom mf_infimum -> x \from lower_bounds A -> x <= inf A.
  Proof.
    move => Afd lb.
    have [lbs nf]:= inf_icf Afd.
    exact/nf.
  Qed.

  Lemma ne_inf_geq A x: FunctionalCountableChoice_on R ->
                        A \from nonempties -> x \from lower_bounds A -> x <= inf A.
  Proof. by move => choice ne lb; apply/inf_geq; first by rewrite dom_inf//; split => //; exists x. Qed.

  Lemma inf_approx A infA: mf_infimum A infA ->
                      forall eps, 0 < eps -> exists x, x \from A /\ x <= infA + eps.
  Proof.
    move => [lb nf] eps eg0.
    apply/not_all_not_ex => all.
    have := nf (infA + eps).
    suff: infA + eps <= infA by lra.
    apply/nf => z Az.
    have /not_and_or [nAz | /Rnot_le_lt]:= all z; try lra.
    by exfalso; apply/nAz.
  Qed.
End infima.
Notation inf:= infimum.

Section suprema.
  Implicit Types (A: subset R).
  Local Open Scope metric_scope.
  Definition upper_bounds A:= make_subset (fun x => is_upper_bound A x).

  Definition is_supremum A x := is_upper_bound A x /\ is_lower_bound (upper_bounds A) x.

  Lemma is_supremum_lub_Rbar A x: is_supremum A x <-> is_lub_Rbar A (Finite x).
  Proof.
    rewrite is_lub_Rbar_correct.
    split => [[ub sup] | [ub sup]].
    - split.
      + case; try by case.
        by move => y [_ Ay]; apply/ub.
      case => //[ y ass | ass].
      + apply/sup => z Az.
        have /=ass' := ass z.
        by apply/ass'.
      suff: (x <= x - 1) by lra.
      apply/sup => y Ay; have /= ass' := ass (Finite y).
      by exfalso; apply/ass'.
    split => y Ay; first exact/(ub y).
    apply/(sup y); case => // [z [_ ] | []]//.
    exact/Ay.
  Qed.

  Definition mf_supremum:= make_mf is_supremum.

  Lemma sup_sing: mf_supremum \is_singlevalued.
  Proof.
    move => A sup sup' [bnd inf] [bnd' inf'].
    suff: sup <= sup' /\ sup' <= sup by lra.
    by split; [apply/inf | apply/inf'].
  Qed.

  Definition p_supremum A := match Lub_Rbar A with
                        | Finite r => Some r
                        | _ => None
                        end.

  Lemma p_sup_spec: pf2MF p_supremum =~= mf_supremum.
  Proof.
    move => A supA; rewrite /p_supremum /=.
    split => [/= | /is_supremum_lub_Rbar spec]; last by have -> := is_lub_Rbar_unique _ _ spec.
    case spec: (Lub_Rbar A) => [x | | ] // <-.
    apply/is_supremum_lub_Rbar; rewrite -spec.
    exact/Lub_Rbar_correct.
  Qed.

  Definition supremum A := match Lub_Rbar A with
                      | Finite r => r
                      | _ => 0
                      end.
  Notation sup := supremum.

  Lemma sup_icf: supremum \is_choice_for mf_supremum.
  Proof.
    rewrite /supremum => A [supA val].
    rewrite (is_lub_Rbar_unique A supA) //.
    exact/is_supremum_lub_Rbar.
  Qed.

  Definition bounded_from_above A := upper_bounds A \from nonempties.

  Definition upper_boundeds:= make_subset bounded_from_above.

  Lemma dom_sup: FunctionalCountableChoice_on R -> dom mf_supremum === upper_boundeds \n nonempties.
  Proof.
    move => choice A; split => [[x [ub sup]] | [[y ub] [x Ax]]].
    - split; first by exists x.
      apply/not_all_not_ex => mty.
      suff: x <= x - 1 by lra.
      by apply/sup => y Ay; exfalso; apply/mty/Ay.
    have := ub x Ax.
    case => [ineq | eq]; last by exists x; split => [ | z ubz]; [rewrite eq | exact/ubz].
    suff /choice [xn xnprp]:
      forall n, exists (xn: M2PM metric_R), upper_bounds A xn
                           /\
                           exists z, A z /\ d (xn, z) <= /2^n.
    - have xnbnd: forall n, is_upper_bound A (xn n) by move => n; have []:= xnprp n.
      have /(@fchy_lim_eff R_MetricSpace R_cmplt) [supA lmt]:
        (xn: sequence_in (M2PM R_MetricSpace)) \fast_Cauchy.
      + apply cchy_eff_suff => n m nlm.
        have [_ [z [Az dst]]]:= xnprp m.
        have [_ [z' [Az' dst']]]:= xnprp n.
        have := xnbnd n z Az; have := xnbnd m z' Az'.
        by move : dst dst' => /=; split_Rabs; lra.
      exists supA.
      split => [z Az | x' lbx'].
      + apply/Rge_le/lim_dec/lim_cnst/lim_eff_lim/lmt.
        by move => n; rewrite/cnst; apply/Rle_ge/xnbnd.
      apply/cond_leq => eps eg0.
      have /accf_tpmn [N [pos Nle]] : 0 < eps/2 by lra.
      have [_ [z [Az dst]]]:= xnprp N.
      have := lbx' z Az; have := lmt N.
      by move: dst => /=; split_Rabs; lra.
    suff prp: forall n, exists (xn: M2PM metric_R), upper_bounds A xn
                                   /\
                                   exists z, A z /\ d(xn, z) <= (y - x)/2^n.
    - move => n.
      have /accf_tpmn [N [pos Nlxy]]: 0 < /(y - x) by apply/Rinv_0_lt_compat; lra.
      have [xn [xnlb [z [Az dst]]]]:= prp (N + n)%nat.
      exists xn; split => //.
      exists z; split => //.
      have lt: 0 < 2^n by apply pow_lt; lra.
      have lt': 0< 2^N by apply/pow_lt; lra.
      apply/Rle_trans; first exact/dst.
      rewrite pow_add /Rdiv Rinv_mult_distr; try lra.
      rewrite -Rmult_assoc -{2}(Rmult_1_l (/2^n)).
      apply/Rmult_le_compat_r; first by apply/Rlt_le/Rinv_0_lt_compat.
      rewrite -(Rinv_r (2^N)); try lra.
      apply/Rmult_le_compat_r; first by apply/Rlt_le/Rinv_0_lt_compat.
      rewrite -(Rinv_involutive (2^N)); try lra.
      rewrite -(Rinv_involutive (y - x)); try lra.
      by apply/Rinv_le_contravar; lra.
    elim => [ | n [xn [xnlb [z [Az dst]]]]].
    - by exists y; split; last by exists x; split; last by simpl; split_Rabs; lra.
    case: (classic (exists z', A z' /\ d(xn, z') <= (y - x)/2^n.+1)) => [ex | /not_ex_all_not nex].
    - by exists xn.
    exists (xn - (y - x)/2^n.+1).
    split => [z' Az' |].
    - have /not_and_or [nAz' | /Rnot_le_lt dst']:= nex z'; first by exfalso; apply/nAz'.
      by have := xnlb z' Az'; move: dst' => /=; split_Rabs; lra.
    have /not_and_or [nAz | /Rnot_le_lt dst']:= nex z; first by exfalso; apply/nAz.
    exists z; split => //; have xnlz:= xnlb z Az.
    have xn'lz: z <= xn - (x - y) /2^n.+1.
    - have : 0 < (y - x) /2^n.+1 by apply/Rdiv_lt_0_compat/pow_lt; lra.
      by simpl in dst; move : dst' dst; rewrite [X in _ < X]/=; split_Rabs; lra.
    rewrite /Rdiv (tpmn_half n) in dst.
    by move: xn'lz dst' dst => /=; split_Rabs; lra.
  Qed.

  Lemma sup_spec A: A \from dom mf_supremum -> sup A \from mf_supremum A.
  Proof. exact/sup_icf. Qed.

  Lemma sup_eq A r: A \from dom mf_supremum -> r \from mf_supremum A -> sup A = r.
  Proof.
    move => fd val.
    exact/sup_sing/val/sup_icf.
  Qed.

  Lemma sup_leq A x: A \from dom mf_supremum -> x \from A -> x <= sup A.
  Proof.
    move => Afd xfa.
    have [ub _]:= sup_icf Afd.
    exact/ub.
  Qed.

  Lemma bnds_sup_leq A x: FunctionalCountableChoice_on R ->
                          A \from upper_boundeds -> x \from A -> x <= sup A.
  Proof.
    move => choice bnd elt; apply/sup_leq => //.
    by rewrite dom_sup//; split; last exists x.
  Qed.

  Lemma sup_geq A x: A \from dom mf_supremum -> x \from upper_bounds A -> sup A <= x.
  Proof.
    move => Afd lb.
    have [lbs nf]:= sup_icf Afd.
    exact/nf.
  Qed.

  Lemma ne_sup_geq A x: FunctionalCountableChoice_on R ->
                        A \from nonempties -> x \from upper_bounds A -> sup A <= x.
  Proof. by move => choice ne ub; apply/sup_geq; first by rewrite dom_sup//; split => //; exists x. Qed.

  Lemma sup_approx A supA: supA \from mf_supremum A  ->
                      forall eps, 0 < eps -> exists x, x \from A /\ supA - eps <= x.
  Proof.
    move => [ub nf] eps eg0.
    apply/not_all_not_ex => all.
    have := nf (supA - eps).
    suff: supA <= supA - eps by lra.
    apply/nf => z Az.
    have /not_and_or [nAz | /Rnot_le_lt]:= all z; try lra.
    by exfalso; apply/nAz.
  Qed.
End suprema.