(* Fsummation.v *)

(* summations on a field *)

Require Import Utf8.
Require Import QArith.
Require Import NPeano.

Require Import Misc.
Require Import Field2.

Set Implicit Arguments.

Fixpoint summation_aux α (r : ring α) b len g :=
  match len with
  | O => 0%K
  | S len₁ => (g b + summation_aux r (S b) len₁ g)%K
  end.

Definition summation α {R : ring α} b e g := summation_aux R b (S e - b) g.

Notation "'Σ' ( i = b , e ) , g" := (summation b e (λ i, (g)))
  (at level 0, i at level 0, b at level 60, e at level 60, g at level 40).

Section theorems_summation.

Variable α : Type.
Variable r : ring α.
Variable f : field r.

Open Scope nat_scope.

Theorem summation_aux_compat : ∀ g h b₁ b₂ len,
  (∀ i, 0 ≤ i < len → (g (b₁ + i)%nat = h (b₂ + i)%nat)%K)
  → (summation_aux r b₁ len g = summation_aux r b₂ len h)%K.
Proof.
intros g h b₁ b₂ len Hgh.
revert b₁ b₂ Hgh.
induction len; intros; [ reflexivity | simpl ].
rewrite IHlen.
 apply rng_add_compat_r.
 assert (0 ≤ 0 < S len) as H.
  split; [ reflexivity | apply Nat.lt_0_succ ].

  apply Hgh in H.
  do 2 rewrite Nat.add_0_r in H; assumption.

 intros i Hi.
 do 2 rewrite Nat.add_succ_l, <- Nat.add_succ_r.
 apply Hgh.
 split; [ apply Nat.le_0_l | idtac ].
 apply lt_n_S.
 destruct Hi; assumption.
Qed.

Theorem summation_compat : ∀ g h b k,
  (∀ i, b ≤ i ≤ k → (g i = h i)%K)
  → (Σ (i = b, k), g i = Σ (i = b, k), h i)%K.
Proof.
intros g h b k Hgh.
apply summation_aux_compat.
intros i (_, Hi).
apply Hgh.
split; [ apply Nat.le_add_r | idtac ].
apply Nat.lt_add_lt_sub_r, le_S_n in Hi.
rewrite Nat.add_comm; assumption.
Qed.

Theorem summation_mul_comm : ∀ g h b k,
  (Σ (i = b, k), g i * h i
   = Σ (i = b, k), h i * g i)%K.
Proof.
intros g h b len.
apply summation_compat; intros i Hi.
apply rng_mul_comm.
Qed.

Theorem all_0_summation_aux_0 : ∀ g b len,
  (∀ i, (b ≤ i < b + len) → (g i = 0)%K)
  → (summation_aux r b len (λ i, g i) = 0)%K.
Proof.
intros g b len H.
revert b H.
induction len; intros; [ reflexivity | simpl ].
rewrite H; [ idtac | split; auto ].
 rewrite rng_add_0_l, IHlen; [ reflexivity | idtac ].
 intros i (Hbi, Hib); apply H.
 rewrite Nat.add_succ_r, <- Nat.add_succ_l.
 split; [ apply Nat.lt_le_incl; auto | auto ].

 rewrite Nat.add_succ_r.
 apply le_n_S, le_plus_l.
Qed.

Theorem all_0_summation_0 : ∀ g i₁ i₂,
  (∀ i, i₁ ≤ i ≤ i₂ → (g i = 0)%K)
  → (Σ (i = i₁, i₂), g i = 0)%K.
Proof.
intros g i₁ i₂ H.
apply all_0_summation_aux_0.
intros i (H₁, H₂).
apply H.
split; [ assumption | idtac ].
destruct (le_dec i₁ (S i₂)) as [H₃| H₃].
 rewrite Nat.add_sub_assoc in H₂; auto.
 rewrite minus_plus in H₂.
 apply le_S_n; auto.

 apply not_le_minus_0 in H₃.
 rewrite H₃, Nat.add_0_r in H₂.
 apply Nat.nle_gt in H₂; contradiction.
Qed.

Theorem summation_aux_succ_last : ∀ g b len,
  (summation_aux r b (S len) g =
   summation_aux r b len g + g (b + len)%nat)%K.
Proof.
intros g b len.
revert b.
induction len; intros.
 simpl.
 rewrite rng_add_0_l, rng_add_0_r, Nat.add_0_r.
 reflexivity.

 remember (S len) as x; simpl; subst x.
 rewrite IHlen.
 simpl.
 rewrite rng_add_assoc, Nat.add_succ_r.
 reflexivity.
Qed.

Theorem summation_aux_rtl : ∀ g b len,
  (summation_aux r b len g =
   summation_aux r b len (λ i, g (b + len - 1 + b - i)%nat))%K.
Proof.
intros g b len.
revert g b.
induction len; intros; [ reflexivity | idtac ].
remember (S len) as x.
rewrite Heqx in |- * at 1.
simpl; subst x.
rewrite IHlen.
rewrite summation_aux_succ_last.
rewrite Nat.add_succ_l, Nat_sub_succ_1.
do 2 rewrite Nat.add_succ_r; rewrite Nat_sub_succ_1.
rewrite Nat.add_sub_swap, Nat.sub_diag; auto.
rewrite rng_add_comm.
apply rng_add_compat_r, summation_aux_compat.
intros; reflexivity.
Qed.

Theorem summation_rtl : ∀ g b k,
  (Σ (i = b, k), g i = Σ (i = b, k), g (k + b - i)%nat)%K.
Proof.
intros g b k.
unfold summation.
rewrite summation_aux_rtl.
apply summation_aux_compat; intros i (Hi, Hikb).
destruct b; simpl.
 rewrite Nat.sub_0_r; reflexivity.

 rewrite Nat.sub_0_r.
 simpl in Hikb.
 eapply Nat.le_lt_trans in Hikb; eauto .
 apply lt_O_minus_lt, Nat.lt_le_incl in Hikb.
 remember (b + (k - b))%nat as x eqn:H .
 rewrite Nat.add_sub_assoc in H; auto.
 rewrite Nat.add_sub_swap in H; auto.
 rewrite Nat.sub_diag in H; subst x; reflexivity.
Qed.

Theorem summation_aux_mul_swap : ∀ a g b len,
  (summation_aux r b len (λ i, a * g i) =
   a * summation_aux r b len g)%K.
Proof.
intros a g b len; revert b.
induction len; intros; simpl.
 rewrite rng_mul_0_r; reflexivity.

 rewrite IHlen, rng_mul_add_distr_l.
 reflexivity.
Qed.

Theorem summation_aux_summation_aux_mul_swap : ∀ g₁ g₂ g₃ b₁ b₂ len,
  (summation_aux r b₁ len
     (λ i, summation_aux r b₂ (g₁ i) (λ j, g₂ i * g₃ i j))
   = summation_aux r b₁ len
       (λ i, g₂ i * summation_aux r b₂ (g₁ i) (λ j, g₃ i j)))%K.
Proof.
intros g₁ g₂ g₃ b₁ b₂ len.
revert b₁ b₂.
induction len; intros; [ reflexivity | simpl ].
rewrite IHlen.
apply rng_add_compat_r.
apply summation_aux_mul_swap.
Qed.

Theorem summation_summation_mul_swap : ∀ g₁ g₂ g₃ k,
  (Σ (i = 0, k), Σ (j = 0, g₁ i), g₂ i * g₃ i j
   = Σ (i = 0, k), g₂ i * Σ (j = 0, g₁ i), g₃ i j)%K.
Proof.
intros g₁ g₂ g₃ k.
apply summation_aux_summation_aux_mul_swap.
Qed.

Theorem summation_only_one_non_0 : ∀ g b v k,
  (b ≤ v ≤ k)
  → (∀ i, (b ≤ i ≤ k) → (i ≠ v) → (g i = 0)%K)
    → (Σ (i = b, k), g i = g v)%K.
Proof.
intros g b v k (Hbv, Hvk) Hi.
unfold summation.
rewrite Nat.sub_succ_l; [ idtac | etransitivity; eassumption ].
remember (k - b) as len.
replace k with (b + len) in * .
 clear k Heqlen.
 revert b v Hbv Hvk Hi.
 induction len; intros.
  simpl.
  rewrite rng_add_0_r.
  replace b with v ; [ reflexivity | idtac ].
  rewrite Nat.add_0_r in Hvk.
  apply Nat.le_antisymm; assumption.

  remember (S len) as x; simpl; subst x.
  destruct (eq_nat_dec b v) as [H₁| H₁].
   subst b.
   rewrite all_0_summation_aux_0.
    rewrite rng_add_0_r; reflexivity.

    intros j (Hvj, Hjv).
    simpl in Hjv.
    apply le_S_n in Hjv.
    apply Hi; [ split; auto; apply Nat.lt_le_incl; auto | idtac ].
    intros H; subst j.
    revert Hvj; apply Nat.nle_succ_diag_l.

   rewrite Nat.add_succ_r, <- Nat.add_succ_l in Hvk.
   rewrite Hi; auto.
    rewrite rng_add_0_l.
    apply IHlen; auto; [ apply Nat_le_neq_lt; auto | idtac ].
    intros j (Hvj, Hjvl) Hjv.
    rewrite Nat.add_succ_l, <- Nat.add_succ_r in Hjvl.
    apply Hi; auto; split; auto.
    apply Nat.lt_le_incl; auto.

    split; auto.
    apply Nat.le_sub_le_add_l.
    rewrite Nat.sub_diag.
    apply Nat.le_0_l.

 subst len.
 eapply Nat.le_trans in Hvk; eauto .
 rewrite Nat.add_sub_assoc; auto.
 rewrite Nat.add_comm.
 apply Nat.add_sub.
Qed.

Theorem summation_shift : ∀ b g k,
  b ≤ k
  → (Σ (i = b, k), g i =
     Σ (i = 0, k - b), g (b + i)%nat)%K.
Proof.
intros b g k Hbk.
unfold summation.
rewrite Nat.sub_0_r.
rewrite Nat.sub_succ_l; [ idtac | assumption ].
apply summation_aux_compat; intros j Hj.
reflexivity.
Qed.

Theorem summation_summation_shift : ∀ g k,
  (Σ (i = 0, k), Σ (j = i, k), g i j =
   Σ (i = 0, k), Σ (j = 0, k - i), g i (i + j)%nat)%K.
Proof.
intros g k.
apply summation_compat; intros i Hi.
unfold summation.
rewrite Nat.sub_0_r.
rewrite Nat.sub_succ_l; [ idtac | destruct Hi; assumption ].
apply summation_aux_compat; intros j Hj.
rewrite Nat.add_0_l; reflexivity.
Qed.

Theorem summation_only_one : ∀ g n, (Σ (i = n, n), g i = g n)%K.
Proof.
intros g n.
unfold summation.
rewrite Nat.sub_succ_l; [ idtac | reflexivity ].
rewrite Nat.sub_diag; simpl.
rewrite rng_add_0_r; reflexivity.
Qed.

Theorem summation_split_last : ∀ g b k,
  (b ≤ S k)
  → (Σ (i = b, S k), g i = Σ (i = b, k), g i + g (S k))%K.
Proof.
intros g b k Hbk.
unfold summation.
rewrite Nat.sub_succ_l; [ idtac | assumption ].
rewrite summation_aux_succ_last.
rewrite Nat.add_sub_assoc; [ idtac | assumption ].
rewrite Nat.add_comm, Nat.add_sub.
reflexivity.
Qed.

Theorem summation_aux_succ_first : ∀ g b len,
  summation_aux r b (S len) g = (g b + summation_aux r (S b) len g)%K.
Proof. reflexivity. Qed.

Theorem summation_split_first : ∀ g b k,
  b ≤ k
  → Σ (i = b, k), g i = (g b + Σ (i = S b, k), g i)%K.
Proof.
intros g b k Hbk.
unfold summation.
rewrite Nat.sub_succ.
rewrite <- summation_aux_succ_first.
rewrite <- Nat.sub_succ_l; [ reflexivity | assumption ].
Qed.

Theorem summation_add_distr : ∀ g h b k,
  (Σ (i = b, k), (g i + h i) =
   Σ (i = b, k), g i + Σ (i = b, k), h i)%K.
Proof.
intros g h b k.
destruct (le_dec b k) as [Hbk| Hbk].
 revert b Hbk.
 induction k; intros.
  destruct b.
   do 3 rewrite summation_only_one; reflexivity.

   unfold summation; simpl; rewrite rng_add_0_r; reflexivity.

  rewrite summation_split_last; [ idtac | assumption ].
  rewrite summation_split_last; [ idtac | assumption ].
  rewrite summation_split_last; [ idtac | assumption ].
  destruct (eq_nat_dec b (S k)) as [H₂| H₂].
   subst b.
   unfold summation; simpl.
   rewrite Nat.sub_diag; simpl.
   do 2 rewrite rng_add_0_l; rewrite rng_add_0_l.
   reflexivity.

   apply Nat_le_neq_lt in Hbk; [ idtac | assumption ].
   apply Nat.succ_le_mono in Hbk.
   rewrite IHk; [ idtac | assumption ].
   do 2 rewrite <- rng_add_assoc.
   apply rng_add_compat_l.
   rewrite rng_add_comm.
   rewrite <- rng_add_assoc.
   apply rng_add_compat_l.
   rewrite rng_add_comm.
   reflexivity.

 unfold summation.
 apply Nat.nle_gt in Hbk.
 replace (S k - b) with O by fast_omega Hbk; simpl.
 rewrite rng_add_0_r; reflexivity.
Qed.

Theorem summation_summation_exch : ∀ g k,
  (Σ (j = 0, k), Σ (i = 0, j), g i j =
   Σ (i = 0, k), Σ (j = i, k), g i j)%K.
Proof.
intros g k.
induction k; [ reflexivity | idtac ].
rewrite summation_split_last; [ idtac | apply Nat.le_0_l ].
rewrite summation_split_last; [ idtac | apply Nat.le_0_l ].
rewrite summation_split_last; [ idtac | apply Nat.le_0_l ].
rewrite IHk.
rewrite summation_only_one.
rewrite rng_add_assoc.
apply rng_add_compat_r.
rewrite <- summation_add_distr.
apply summation_compat; intros i (_, Hi).
rewrite summation_split_last; [ reflexivity | idtac ].
apply Nat.le_le_succ_r; assumption.
Qed.

Theorem summation_aux_ub_add : ∀ g b k₁ k₂,
  (summation_aux r b (k₁ + k₂) g =
   summation_aux r b k₁ g + summation_aux r (b + k₁) k₂ g)%K.
Proof.
intros g b k₁ k₂.
revert b k₁.
induction k₂; intros.
 simpl.
 rewrite Nat.add_0_r, rng_add_0_r; reflexivity.

 rewrite Nat.add_succ_r, <- Nat.add_succ_l.
 rewrite IHk₂; simpl.
 rewrite <- Nat.add_succ_r.
 rewrite rng_add_assoc.
 apply rng_add_compat_r.
 clear k₂ IHk₂.
 revert b.
 induction k₁; intros; simpl.
  rewrite Nat.add_0_r.
  apply rng_add_comm.

  rewrite <- rng_add_assoc.
  rewrite IHk₁.
  rewrite Nat.add_succ_r, <- Nat.add_succ_l; reflexivity.
Qed.

Theorem summation_ub_add : ∀ g k₁ k₂,
  (Σ (i = 0, k₁ + k₂), g i =
   Σ (i = 0, k₁), g i + Σ (i = S k₁, k₁ + k₂), g i)%K.
Proof.
intros g k₁ k₂.
unfold summation.
do 2 rewrite Nat.sub_0_r.
rewrite <- Nat.add_succ_l.
rewrite summation_aux_ub_add; simpl.
rewrite Nat.add_comm, Nat.add_sub; reflexivity.
Qed.

Theorem summation_aux_mul_summation_aux_summation_aux : ∀ g k n,
  (summation_aux r 0 (S k * S n) g =
   summation_aux r 0 (S k)
     (λ i, summation_aux r 0 (S n) (λ j, g (i * S n + j)%nat)))%K.
Proof.
intros g k n.
revert n; induction k; intros.
 simpl; rewrite Nat.add_0_r, rng_add_0_r; reflexivity.

 remember (S n) as x.
 remember (S k) as y.
 simpl; subst x y.
 rewrite Nat.add_comm.
 rewrite summation_aux_ub_add, IHk.
 symmetry; rewrite rng_add_comm.
 symmetry.
 rewrite summation_aux_succ_first.
 rewrite rng_add_shuffle0, rng_add_comm.
 symmetry.
 replace (S k) with (k + 1)%nat by fast_omega.
 rewrite summation_aux_ub_add.
 rewrite <- rng_add_assoc.
 apply rng_add_compat_l.
 simpl.
 rewrite rng_add_comm.
 apply rng_add_compat_l.
 symmetry; rewrite Nat.add_comm; simpl.
 rewrite Nat.add_0_r, rng_add_0_r.
 apply rng_add_compat_l.
 apply summation_aux_compat; intros i Hi; simpl.
 rewrite Nat.add_succ_r; reflexivity.
Qed.

Theorem summation_mul_summation_summation : ∀ g n k,
  (0 < n)%nat
  → (0 < k)%nat
    → (Σ (i = 0, k * n - 1), g i =
       Σ (i = 0, k - 1), Σ (j = 0, n - 1), g (i * n + j)%nat)%K.
Proof.
intros g n k Hn Hk.
unfold summation.
do 2 rewrite Nat.sub_0_r.
destruct n; [ exfalso; revert Hn; apply Nat.lt_irrefl | clear Hn ].
destruct k; [ exfalso; revert Hk; apply Nat.lt_irrefl | clear Hk ].
rewrite Nat.sub_succ, Nat.sub_0_r.
rewrite <- Nat.sub_succ_l, Nat.sub_succ, Nat.sub_0_r.
 rewrite summation_aux_mul_summation_aux_summation_aux.
 apply summation_aux_compat; intros i Hi.
 rewrite Nat.sub_succ, Nat.sub_0_r, Nat.sub_0_r.
 reflexivity.

 simpl; apply le_n_S, Nat.le_0_l.
Qed.

Theorem inserted_0_summation : ∀ g h k n,
  n ≠ O
  → (∀ i, i mod n ≠ O → (g i = 0)%K)
    → (∀ i, (g (n * i)%nat = h i)%K)
      → (Σ (i = 0, k * n), g i = Σ (i = 0, k), h i)%K.
Proof.
intros g h k n Hn Hf Hfg.
destruct k.
 rewrite Nat.mul_0_l.
 apply summation_compat; intros i (_, Hi).
 apply Nat.le_0_r in Hi; subst i.
 rewrite <- Hfg, Nat.mul_0_r; reflexivity.

 destruct n; [ exfalso; apply Hn; reflexivity | clear Hn ].
 replace (S k * S n)%nat with (S k * S n - 1 + 1)%nat.
  rewrite summation_ub_add.
  rewrite summation_mul_summation_summation; try apply Nat.lt_0_succ.
  rewrite Nat_sub_succ_1, Nat.add_comm, summation_only_one.
  simpl; do 2 rewrite Nat.sub_0_r.
  symmetry.
  rewrite <- Nat.add_1_r, summation_ub_add, Nat.add_1_r.
  rewrite summation_only_one, rng_add_comm, <- Hfg.
  symmetry.
  rewrite rng_add_comm.
  apply rng_add_compat; [ symmetry; rewrite Nat.mul_comm; reflexivity |  ].
  apply summation_compat; intros i Hi.
  rewrite summation_only_one_non_0 with (v := 0).
   rewrite Nat.add_0_r, Nat.mul_comm; apply Hfg.

   split; [ reflexivity | apply Nat.le_0_l ].

   intros j Hjn Hj.
   rewrite Hf; [ reflexivity |  ].
   rewrite Nat.add_comm.
   rewrite Nat.mod_add; [  | apply Nat.neq_succ_0 ].
   intros H; apply Hj; clear Hj.
   apply Nat.mod_divides in H; auto.
   destruct H as (c, Hc).
   destruct c.
    rewrite Nat.mul_0_r in Hc; assumption.

    rewrite Hc in Hjn.
    rewrite Nat.mul_comm in Hjn.
    simpl in Hjn.
    destruct Hjn as (_, H).
    apply Nat.nlt_ge in H.
    exfalso; apply H.
    apply le_n_S, Nat.le_add_r.

  rewrite Nat.sub_add; [ apply eq_refl |  ].
  simpl; apply le_n_S, Nat.le_0_l.

Qed.

Theorem summation_add_add_sub : ∀ g b k n,
  (Σ (i = b, k), g i = Σ (i = b + n, k + n), g (i - n)%nat)%K.
Proof.
intros g b k n.
unfold summation.
replace (S (k + n) - (b + n))%nat with (S k - b)%nat by fast_omega.
apply summation_aux_compat.
intros i Hi.
replace (b + n + i - n)%nat with (b + i)%nat by fast_omega.
reflexivity.
Qed.

Theorem summation_succ_succ : ∀ b k g,
  (Σ (i = S b, S k), g i = Σ (i = b, k), g (S i))%K.
Proof.
intros b k g.
unfold summation.
rewrite Nat.sub_succ.
remember (S k - b)%nat as len; clear Heqlen.
revert b.
induction len; intros; [ reflexivity | simpl ].
rewrite IHlen; reflexivity.
Qed.

End theorems_summation.


Inductive rgb : Type :=
| red
| green
| blue.

Inductive color : Type :=
| black
| white
| primary (p : rgb).

Definition monochrome (c : color) : bool :=
match c with
| black => true
| white => true
| primary q => false
end.

Definition isred (c : color) : bool :=
match c with
| black => false
| white => false
| primary red => true
| primary _ => false
end.

Example test_color1:  (monochrome black)  = true.
Proof. simpl. reflexivity.  Qed.

Example test_color2:  (monochrome (primary red))  = false.
Proof. simpl. reflexivity.  Qed.

Example test_color3:  (isred (primary red))  = true.
Proof. simpl. reflexivity.  Qed.

Example test_color4:  (isred black)  = false.
Proof. simpl. reflexivity.  Qed.


(** * SfLib: Software Foundations Library *)

(** Here we collect together several useful definitions and theorems
    from Basics.v, List.v, Poly.v, Ind.v, and Logic.v that are not
    already in the Coq standard library.  From now on we can [Import]
    or [Export] this file, instead of cluttering our environment with
    all the examples and false starts in those files. *)

(** * From the Coq Standard Library *)

Require Omega.   (* needed for using the [omega] tactic *)
Require Export Bool.
Require Export List.
Export ListNotations.
Require Export Arith.
Require Export Arith.EqNat.  (* Contains [beq_nat], among other things *)

(** * From Basics.v *)

Definition admit {T: Type} : T.  Admitted.

Fixpoint ble_nat (n m : nat) : bool :=
  match n with
  | O => true
  | S n' =>
      match m with
      | O => false
      | S m' => ble_nat n' m'
      end
  end.

Theorem andb_true_elim1 : forall b c,
  andb b c = true -> b = true.
Proof.
  intros b c H.
  destruct b.
  - (* b = true *)
    reflexivity.
  - (* b = false *)
    rewrite <- H. reflexivity.  Qed.

Theorem andb_true_elim2 : forall b c,
  andb b c = true -> c = true.
Proof.
(* An exercise in Basics.v *)
Admitted.

Theorem beq_nat_sym : forall (n m : nat),
  beq_nat n m = beq_nat m n.
(* An exercise in Lists.v *)
Admitted.

(** * From Props.v *)

Inductive ev : nat -> Prop :=
  | ev_0 : ev O
  | ev_SS : forall n:nat, ev n -> ev (S (S n)).

(** * From Logic.v *)

Theorem andb_true : forall b c,
  andb b c = true -> b = true /\ c = true.
Proof.
  intros b c H.
  destruct b.
    destruct c.
      apply conj. reflexivity. reflexivity.
      inversion H.
    inversion H.  Qed.

Theorem false_beq_nat: forall n n' : nat,
     n <> n' ->
     beq_nat n n' = false.
Proof.
(* An exercise in Logic.v *)
Admitted.

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
  intros P contra.
  inversion contra.  Qed.

Theorem ev_not_ev_S : forall n,
  ev n -> ~ ev (S n).
Proof.
(* An exercise in Logic.v *)
Admitted.

Theorem ble_nat_true : forall n m,
  ble_nat n m = true -> n <= m.
(* An exercise in Logic.v *)
Admitted.

Theorem ble_nat_false : forall n m,
  ble_nat n m = false -> ~(n <= m).
(* An exercise in Logic.v *)
Admitted.

Inductive appears_in (n : nat) : list nat -> Prop :=
| ai_here : forall l, appears_in n (n::l)
| ai_later : forall m l, appears_in n l -> appears_in n (m::l).

Inductive next_nat (n:nat) : nat -> Prop :=
  | nn : next_nat n (S n).

Inductive total_relation : nat -> nat -> Prop :=
  tot : forall n m : nat, total_relation n m.

Inductive empty_relation : nat -> nat -> Prop := .

(** * From Later Files *)

Definition relation (X:Type) := X -> X -> Prop.

Definition deterministic {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

Inductive multi (X:Type) (R: relation X)
                            : X -> X -> Prop :=
  | multi_refl  : forall (x : X),
                 multi X R x x
  | multi_step : forall (x y z : X),
                    R x y ->
                    multi X R y z ->
                    multi X R x z.
Implicit Arguments multi [[X]].

Theorem multi_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> multi R x y.
Proof.
  intros X R x y r.
  apply multi_step with y. apply r. apply multi_refl.   Qed.

Theorem multi_trans :
  forall (X:Type) (R: relation X) (x y z : X),
      multi R x y  ->
      multi R y z ->
      multi R x z.
Proof.
  (* FILL IN HERE *) Admitted.

(**  Identifiers and polymorphic partial maps. *)

Inductive id : Type :=
  Id : nat -> id.

Theorem eq_id_dec : forall id1 id2 : id, {id1 = id2} + {id1 <> id2}.
Proof.
   intros id1 id2.
   destruct id1 as [n1]. destruct id2 as [n2].
   destruct (eq_nat_dec n1 n2) as [Heq | Hneq].
   - (* n1 = n2 *)
     left. rewrite Heq. reflexivity.
   - (* n1 <> n2 *)
     right. intros contra. inversion contra. apply Hneq. apply H0.
Defined.

Lemma eq_id : forall (T:Type) x (p q:T),
              (if eq_id_dec x x then p else q) = p.
Proof.
  intros.
  destruct (eq_id_dec x x); try reflexivity.
  apply ex_falso_quodlibet; auto.
Qed.

Lemma neq_id : forall (T:Type) x y (p q:T), x <> y ->
               (if eq_id_dec x y then p else q) = q.
Proof.
  (* FILL IN HERE *) Admitted.

Definition partial_map (A:Type) := id -> option A.

Definition empty {A:Type} : partial_map A := (fun _ => None).

Notation "'\empty'" := empty.

Definition extend {A:Type} (Gamma : partial_map A) (x:id) (T : A) :=
  fun x' => if eq_id_dec x x' then Some T else Gamma x'.

Lemma extend_eq : forall A (ctxt: partial_map A) x T,
  (extend ctxt x T) x = Some T.
Proof.
  intros. unfold extend. rewrite eq_id; auto.
Qed.

Lemma extend_neq : forall A (ctxt: partial_map A) x1 T x2,
  x2 <> x1 ->
  (extend ctxt x2 T) x1 = ctxt x1.
Proof.
  intros. unfold extend. rewrite neq_id; auto.
Qed.

Lemma extend_shadow : forall A (ctxt: partial_map A) t1 t2 x1 x2,
  extend (extend ctxt x2 t1) x2 t2 x1 = extend ctxt x2 t2 x1.
Proof with auto.
  intros. unfold extend. destruct (eq_id_dec x2 x1)...
Qed.

(** -------------------- *)

(** * Some useful tactics *)

Tactic Notation "solve_by_inversion_step" tactic(t) :=
  match goal with
  | H : _ |- _ => solve [ inversion H; subst; t ]
  end
  || fail "because the goal is not solvable by inversion.".

Tactic Notation "solve" "by" "inversion" "1" :=
  solve_by_inversion_step idtac.
Tactic Notation "solve" "by" "inversion" "2" :=
  solve_by_inversion_step (solve by inversion 1).
Tactic Notation "solve" "by" "inversion" "3" :=
  solve_by_inversion_step (solve by inversion 2).
Tactic Notation "solve" "by" "inversion" :=
  solve by inversion 1.

(** $Date: 2015-08-10 11:00:14 -0500 (Mon, 10 Aug 2015) $ *)


Require Import Coq.Lists.Streams.
Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Setoids.Setoid.

Section Stream_LE.
  Context { A : Type }.
  Context { Eq Le : relation A }.

  Inductive stream_le_gen `{ PartialOrder A Eq Le} stream_le :
    Stream A -> Stream A -> Prop :=
  | Stream_le : forall h1 h2 t1 t2 ,
      Le h1 h2 ->
      (Eq h1 h2 -> stream_le t1 t2) ->
      stream_le_gen stream_le (Cons h1 t1) (Cons h2 t2).

  CoInductive stream_le `{ PartialOrder A Eq Le } :
    Stream A -> Stream A -> Prop :=
  | Stream_le_fold : forall s1 s2,
      stream_le_gen stream_le s1 s2 -> stream_le s1 s2.
End Stream_LE.

Section Stream_LE_Theorem.
  Variable A : Type.
  Variable Eq Le : relation A.
  Context `{ PartialOrder A Eq Le }.

  Hint Constructors stream_le_gen stream_le.

  Ltac inv_stream_le :=
    match goal with
    | [H: stream_le (Cons _ _) (Cons _ _) |- _ ] =>
      inversion H; subst; clear H
    | [H: stream_le_gen _ _ _ |- _ ] =>
      inversion H; subst; clear H
    end.

  Theorem stream_le_trans : forall (a b c : Stream A),
      stream_le a b ->
      stream_le b c ->
      stream_le a c.
  Proof.
    cofix. constructor.
    destruct a; destruct b; destruct c.
    repeat inv_stream_le. constructor.
    - eapply PreOrder_Transitive; eassumption.
    - intros. rewrite H0 in H5. apply (antisymmetry H4) in H5.
      rewrite H0 in H7. rewrite H5 in H7.
      eapply stream_le_trans; eauto.
      apply H7. apply Equivalence_Reflexive.
  Qed.
End Stream_LE_Theorem.


(* External import(s). *)
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.EqNat.

Inductive identifier: Type :=
  Identifier (i:nat).

Definition id_eqb (i i':identifier): bool :=
  match (i, i') with
  | (Identifier x, Identifier x') => beq_nat x x'
  end.

Lemma id_eqb_refl: forall i i',
  id_eqb i i' = true <-> i = i'.
Proof.
  intros. destruct i, i'; unfold id_eqb; split; intro.
  - apply PeanoNat.Nat.eqb_eq in H.
    congruence.
  - apply PeanoNat.Nat.eqb_eq.
    congruence.
Qed.

Lemma id_eqb_refl_converse: forall i i',
  id_eqb i i' = false <-> i <> i'.
Proof.
  intros. destruct i, i'; unfold id_eqb; split; intro.
  - apply PeanoNat.Nat.eqb_neq in H.
    congruence.
  - apply PeanoNat.Nat.eqb_neq.
    congruence.
Qed.

Lemma id_eqb_sym: forall i i',
  id_eqb i i' = id_eqb i' i.
Proof.
  intros. destruct i, i'; unfold id_eqb.
  apply PeanoNat.Nat.eqb_sym.
Qed.

Lemma id_eqb_equiv_eq: forall i i',
  id_eqb i i' = true <-> i = i'.
Proof.
  intros. destruct i, i'; unfold id_eqb; split; intro.
  - apply PeanoNat.Nat.eqb_eq in H.
    congruence.
  - apply PeanoNat.Nat.eqb_eq.
    congruence.
Qed.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Coq_Cats.Type_Cat.Type_Cat.

(** A cardinality restriction for types is a property that holds for a type
    if and only if it holds for all types isomorphic to it. *)
Record Card_Restriction : Type :=
{
  Card_Rest : Type → Prop;

  Card_Rest_Respect : ∀ (A B : Type),
      (A ≃≃ B ::> Type_Cat)%isomorphism → Card_Rest A → Card_Rest B
}.

Coercion Card_Rest : Card_Restriction >-> Funclass.

(** A type is finite if it is isomorphic to a subset of natural numbers
    less than n for soem natural number n. *)
Program Definition Finite : Card_Restriction :=
  {|
    Card_Rest :=
      fun A => inhabited {n : nat & (A ≃≃ {x : nat | x < n} ::> Type_Cat)%isomorphism}
  |}.

Next Obligation.
Proof.
  destruct H as [[n I]].
  eexists.
  refine (existT _ n (I ∘ (X⁻¹)%isomorphism)%isomorphism).
Qed.


(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

Set Implicit Arguments.

Require Import otp.Crypto.
Require Import otp.RndNat.
Require Import otp.NotationV1.

Definition Bernoulli(r : Rat) : Comp bool :=
  match r with
    | RatIntro n d =>
      v <-$ RndNat d; ret (if (lt_dec v n) then true else false)
  end.

Theorem Bernoulli_correct :
  forall (r : Rat),
    r <= 1 ->
    Pr[Bernoulli r] == r.

  unfold Bernoulli.
  intuition.
  destruct r.

  rewrite RndNat_seq.

  rewrite (sumList_filter_partition (fun z => if (lt_dec z n) then true else false)).
  eapply eqRat_trans.
  eapply ratMult_eqRat_compat.
  eapply eqRat_refl.
  eapply ratAdd_eqRat_compat.

  eapply sumList_all.
  intros.
  destruct ( lt_dec a n).
  simpl.
  destruct ( EqDec_dec bool_EqDec true true).
  eapply eqRat_refl.
  intuition.
  apply filter_In in H0.
  intuition.
  exfalso.
  destruct (lt_dec a n); intuition.

  eapply sumList_0.
  intros.
  apply filter_In in H0.
  intuition.
  destruct (lt_dec a n); simpl in *.
  discriminate.
  destruct (EqDec_dec bool_EqDec false true); intuition.

  rewrite allNatsLt_filter_lt.
  rewrite <- ratAdd_0_r.
  rewrite ratMult_1_r.
  rewrite allNatsLt_length.
  rewrite <- ratMult_num_den.
  eapply eqRat_terms.
  omega.
  unfold posnatMult, posnatToNat, natToPosnat.
  destruct p.
  omega.

  eapply rat_le_1_if; trivial.

Qed.

Theorem Bernoulli_wf :
  forall r,
    well_formed_comp (Bernoulli r).

  intuition.
  unfold Bernoulli.
  destruct r.
  wftac.

Qed.

Theorem Bernoulli_correct_complement :
  forall (r : Rat),
    r <= 1 ->
    evalDist (Bernoulli r) false ==
    ratSubtract 1 r.

  intuition.
  eapply eqRat_trans.
  eapply evalDist_complement.
  eapply Bernoulli_wf.
  eapply ratSubtract_eqRat_compat; intuition.
  eapply Bernoulli_correct.
  trivial.
Qed.


Require Import Relations.
Require Import PreLattice.
Require Import Chains.

Definition per A := { R : relation A | PER R }.

Definition toPER {A} (R: relation A) {E: PER R} : per A :=
  exist PER R E.

Definition coarser {A} (R1 R2: per A) :=
  forall x y, proj1_sig R2 x y -> proj1_sig R1 x y.

Instance coarser_PreOrder {A} : PreOrder (@coarser A).
Proof.
constructor.
+ intros ? ? ? ?. trivial.
+ intros ? ? ? ? ? ? ? ?. auto.
Qed.

Definition intersection A (R1 R2: per A) : per A.
Proof.
destruct R1 as [R1 [Hsym1 Htrans1]].
destruct R2 as [R2 [Hsym2 Htrans2]].
exists (fun x y => R1 x y /\ R2 x y).
constructor.
* intros ? ? [? ?]. split.
    apply Hsym1. trivial.
    apply Hsym2. trivial.
* intros ? ? ? [? ?] [? ?]. split.
    eapply Htrans1. eassumption. trivial.
    eapply Htrans2. eassumption. trivial.
Defined.

Instance PERJoinPreLattice {A} : JoinPreLattice (per A) coarser :=
{ join := intersection A }.
Proof.
* intros [? [? ?]] [? [? ?]] ? ? [? ?]. trivial.
* intros [? [? ?]] [? [? ?]] ? ? [? ?]. trivial.
* intros [? [? ?]] [? [? ?]] [? [? ?]] ? ? ? ? ?.
    unfold coarser in *. simpl in *. split; auto.
Defined.

Definition union A (R1 R2: per A) : per A.
Proof.
destruct R1 as [R1 [Hsym1 Htrans1]].
destruct R2 as [R2 [Hsym2 Htrans2]].
exists (clos_trans A (union A R1 R2)).
constructor.
* intros x y Hxy. induction Hxy.
  - destruct H.
    + apply t_step. left. apply Hsym1. trivial.
    + apply t_step. right. apply Hsym2. trivial.
  - apply (t_trans A (union A R1 R2) z y x); trivial.
* intros x y z Hxy Hyz. generalize dependent z.
  induction Hxy; intros t Hyt.
  - apply (t_trans A (union A R1 R2) x y t).
    + apply t_step. destruct H; [left|right]; assumption.
    + assumption.
  - apply (t_trans A (union A R1 R2) x z t).
    + apply IHHxy1. assumption.
    + assumption.
Defined.

Instance PERMeetPreLattice {A} : MeetPreLattice (per A) coarser :=
{ meet := union A }.
Proof.
* intros [? [? ?]] [? [? ?]] ? ? ?. apply t_step. left. trivial.
* intros [? [? ?]] [? [? ?]] ? ? ?. apply t_step. right. trivial.
* intros [R1 [Hsym1 Htrans1]]
         [R2 [Hsym2 Htrans2]]
         [R3 [Hsym3 Htrans3]] H12 H23 x y Hplus.
  unfold coarser in *; simpl in *. induction Hplus.
  - destruct H; auto.
  - eauto.
Defined.

Definition per_top A : per A.
Proof.
exists (fun _ _ => False). intuition.
Defined.

Instance PERHasTop {A} : HasTop (per A) coarser :=
{ top := per_top A }.
Proof.
unfold per_top. simpl.
intros ? ? ? ?. simpl in *. tauto.
Defined.

Definition per_bottom A : per A.
Proof.
exists (fun _ _ => True). intuition.
Defined.

Instance PERHasBottom {A} : HasBottom (per A) coarser :=
{ bottom := per_bottom A }.
Proof.
unfold per_bottom.
intros ? ? ? ?. simpl in *. trivial.
Defined.

Module FAMILY.

  Definition big_union {A B} (f: A -> per B) : per B.
  Proof.
  exists (fun x y => forall a, proj1_sig (f a) x y).
  constructor.
  * intros x y H a. specialize (H a).
    destruct (f a) as [R [Hsym Htrans]].
    simpl in *. auto.
  * intros x y z Hxy Hyz a.
    specialize (Hxy a). specialize (Hyz a).
    destruct (f a) as [R [Hsym Htrans]].
    simpl in *. eauto.
  Defined.

  Lemma big_union_upper_bound {A B} :
    forall (f: A -> per B),
    forall a, coarser (f a) (big_union f).
  Proof.
  intros f a x y H. auto.
  Qed.

  Lemma big_union_least {A B} :
    forall (f: A -> per B),
    forall (bound: per B),
      (forall a, coarser (f a) bound) ->
      coarser (big_union f) bound.
  Proof.
  intros f bound Hbound x y H a. specialize (Hbound a x y H). trivial.
  Qed.

  Lemma big_union_monotone_zero {A} (zero: per A) (f: per A -> per A):
    monotone f ->
    monotone (fun zero => FAMILY.big_union (fun n => n_iter f n zero)).
  Proof.
    intros Hf R1 R2 HR x y Hxy n.
    unfold FAMILY.big_union in Hxy. simpl in Hxy.
    apply (n_iter_monotone_zero f Hf n R1 R2 HR x y).
    auto.
  Qed.

  Definition big_intersection {A B} (f: A -> per B) : per B.
  Proof.
  exists (clos_trans _ (fun x y => exists a, proj1_sig (f a) x y)).
  constructor.
  * intros x y H. induction H.
    + apply t_step. destruct H as [a H].
      exists a.
      destruct (f a) as [R [HRefl Hsym]].
      simpl in *. auto.
    + apply (t_trans _ _ z y x); auto.
  * intros x y z Hxy Hyz. apply (t_trans _ _ x y z); auto.
  Defined.

  Lemma big_intersection_lower_bound {A B} :
    forall (f: A -> per B),
    forall a, coarser (big_intersection f) (f a).
  Proof.
  intros f a x y H. apply t_step. eauto.
  Qed.

  Lemma big_intersection_greatest {A B} :
    forall (f: A -> per B),
    forall (bound: per B),
      (forall a, coarser bound (f a)) ->
      coarser bound (big_intersection f).
  Proof.
  intros f bound Hbound x y H.
  simpl in H. induction H.
  * destruct H as [a H]. apply (Hbound a _ _ H).
  * destruct bound as [bound [Hrefl Hsym]]. simpl in *. eauto.
  Qed.

  Lemma big_intersection_monotone_zero {A} (zero: per A) (f: per A -> per A):
    monotone f ->
    monotone (fun zero => FAMILY.big_intersection (fun n => n_iter f n zero)).
  Proof.
    intros Hf R1 R2 HR x y Hxy.
    unfold FAMILY.big_intersection in *. simpl in *.
    induction Hxy.
    * apply t_step. destruct H as [n H]. exists n.
      apply (n_iter_monotone_zero f Hf n R1 R2 HR x y). trivial.
    * apply (t_trans _ _ x y z); auto.
  Qed.

End FAMILY.

Module SET.

  Definition big_union {A} (S: per A -> Prop) : per A.
  Proof.
  exists (fun x y => forall R, S R -> proj1_sig R x y).
  constructor.
  * intros x y Hxy R HR. specialize (Hxy R HR).
    destruct R as [R [Hsym Htrans]]. simpl in *. auto.
  * intros x y z Hxy Hyz R HR.
    specialize (Hxy R HR). specialize (Hyz R HR).
    destruct R as [R [Hsym Htrans]]. simpl in *. eauto.
  Defined.

  Lemma big_union_is_sup {A} :
    forall (S: per A -> Prop), is_sup S (big_union S).
  Proof.
  intros S. split.
  * intros R HR x y Runion. apply Runion. trivial.
  * Require Import Classical.
    intros R HR. apply NNPP.
    unfold coarser; simpl. intro H.
    assert (exists x y, proj1_sig R x y /\ exists R, S R /\ ~ proj1_sig R x y)
      as [x [y [Hxy [R' [HR' HR'xy]]]]] by firstorder.
    clear H.
    apply HR'xy. apply HR; trivial.
  Qed.

  Definition big_intersection {A} (S: per A -> Prop) : per A.
  Proof.
  exists (clos_trans _ (fun x y => exists R, S R /\ proj1_sig R x y)).
  constructor.
  * intros x y Hxy. induction Hxy.
    + apply t_step. destruct H as [R [HSR HRxy]].
      exists R. split; trivial.
      destruct R as [R [Hrefl Hsym]]. simpl in *. auto.
    + apply (t_trans _ _ z y x); auto.
  * intros x y z Hxy Hyz. apply (t_trans _ _ x y z); auto.
  Defined.

  Lemma big_intersection_is_inf {A} :
    forall (S: per A -> Prop), is_inf S (big_intersection S).
  Proof.
  intros S. split.
  * intros R HR x y Runion. apply t_step. eauto.
  * intros R HR x y Hxy. unfold big_intersection in Hxy. simpl in Hxy.
    induction Hxy.
    + destruct H as [R' [HSR' HR'xy]].
      apply (HR R' HSR' _ _ HR'xy).
    + destruct R as [R [Hrefl Hsym]]. simpl in *. eauto.
  Qed.

End SET.

Instance PERJoinCompletePreLattice {A} :
  JoinCompletePreLattice (per A) coarser := { }.
Proof.
intros P.
exists (SET.big_union P). apply SET.big_union_is_sup.
Defined.

Instance ERMeetCompletePreLattice {A} :
  MeetCompletePreLattice (per A) coarser := { }.
Proof.
intros P.
exists (SET.big_intersection P). apply SET.big_intersection_is_inf.
Defined.


Require Export TopologicalSpaces.
Require Export Ensembles.
From ZornsLemma Require Import EnsemblesImplicit.
Require Export InteriorsClosures.

Definition open_neighborhood {X:TopologicalSpace}
  (U:Ensemble (point_set X)) (x:point_set X) :=
  open U /\ In U x.

Definition neighborhood {X:TopologicalSpace}
  (N:Ensemble (point_set X)) (x:point_set X) :=
  exists U:Ensemble (point_set X),
    open_neighborhood U x /\ Included U N.

Lemma open_neighborhood_is_neighborhood: forall {X:TopologicalSpace}
  (U:Ensemble (point_set X)) (x:point_set X),
  open_neighborhood U x -> neighborhood U x.
Proof.
intros.
exists U; auto with sets.
Qed.

Lemma neighborhood_interior: forall {X:TopologicalSpace}
  (N:Ensemble (point_set X)) (x:point_set X),
  neighborhood N x -> In (interior N) x.
Proof.
intros.
destruct H.
destruct H.
destruct H.
assert (Included x0 (interior N)).
apply interior_maximal; trivial.
auto with sets.
Qed.

Lemma interior_neighborhood: forall {X:TopologicalSpace}
  (N:Ensemble (point_set X)) (x:point_set X),
  In (interior N) x -> neighborhood N x.
Proof.
intros.
exists (interior N).
repeat split.
apply interior_open.
assumption.
apply interior_deflationary.
Qed.


Require Import QArith.
(* ================================================================== *)
(* ===== Point2D ==================================================== *)
(* ================================================================== *)
Structure Point2D := {
id:> nat;
x:> Q;
y:> Q;
}.
Definition Xp (pt : Point2D) : Q := x pt.
Definition Yp (pt : Point2D) : Q := y pt.
Axiom Point2D_eq: forall (p q : Point2D), eq_nat (id p)(id q) -> p = q.


(* Exercise 82 *)

Require Import BenB.

Variable D : Set.
Variables P Q S T : D -> Prop.
Variable R : D -> D -> Prop.

Theorem exercise_082 : (forall x : D, P x) -> (forall x y z : D, P x /\ P y /\ P z).
Proof.
imp_i a1.
all_i a.
all_i b.
all_i c.
con_i.
all_e (forall x:D, P x) a.
hyp a1.
con_i.
all_e (forall x:D, P x) b.
hyp a1.
all_e (forall x:D, P x) c.
hyp a1.
Qed.


Require Export TopologicalSpaces.
Require Export Nets.
Require Export FilterLimits.
Require Export Continuity.

Local Unset Standard Proposition Elimination Names.
Set Asymmetric Patterns.

Definition compact (X:TopologicalSpace) :=
  forall C:Family (point_set X),
    (forall U:Ensemble (point_set X), In C U -> open U) ->
    FamilyUnion C = Full_set ->
    exists C':Family (point_set X),
      Finite _ C' /\ Included C' C /\
      FamilyUnion C' = Full_set.

Lemma compactness_on_indexed_covers:
  forall (X:TopologicalSpace) (A:Type) (C:IndexedFamily A (point_set X)),
    compact X ->
    (forall a:A, open (C a)) -> IndexedUnion C = Full_set ->
  exists A':Ensemble A, Finite _ A' /\
    IndexedUnion (fun a':{a':A | In A' a'} => C (proj1_sig a')) = Full_set.
Proof.
intros.
pose (cover := ImageFamily C).
destruct (H cover) as [subcover].
intros.
destruct H2.
rewrite H3; apply H0.
unfold cover; rewrite <- indexed_to_family_union; trivial.
destruct H2 as [? []].
destruct (finite_choice _ _
  (fun (U:{U:Ensemble (point_set X) | In subcover U}) (a:A) =>
      proj1_sig U = C a)) as [choice_fun].
apply Finite_ens_type; trivial.
destruct x as [U].
simpl.
apply H3 in i.
destruct i.
exists x; trivial.

exists (Im Full_set choice_fun).
split.
apply FiniteT_img.
apply Finite_ens_type; trivial.
intros; apply classic.
apply Extensionality_Ensembles; split; red; intros.
constructor.
rewrite <- H4 in H6.
destruct H6.
assert (In (Im Full_set choice_fun) (choice_fun (exist _ S H6))).
exists (exist _ S H6).
constructor.
trivial.
exists (exist _ (choice_fun (exist _ S H6)) H8).
simpl.
rewrite <- H5.
simpl.
trivial.
Qed.

Lemma compact_finite_nonempty_closed_intersection:
  forall X:TopologicalSpace, compact X ->
  forall F:Family (point_set X),
    (forall G:Ensemble (point_set X), In F G -> closed G) ->
    (forall F':Family (point_set X), Finite _ F' -> Included F' F ->
     Inhabited (FamilyIntersection F')) ->
    Inhabited (FamilyIntersection F).
Proof.
intros.
apply NNPP; red; intro.
pose (C := [ U:Ensemble (point_set X) | In F (Complement U) ]).
unshelve refine (let H3:=(H C _ _) in _).
intros.
destruct H3.
apply H0 in H3.
apply closed_complement_open; trivial.
apply Extensionality_Ensembles; split; red; intros.
constructor.
apply NNPP; red; intro.
contradiction H2.
exists x.
constructor.
intros.
apply NNPP; red; intro.
contradiction H4.
exists (Complement S).
constructor.
rewrite Complement_Complement; trivial.
exact H6.

destruct H3 as [C' [? [? ?]]].
pose (F' := [G : Ensemble (point_set X) | In C' (Complement G)]).
unshelve refine (let H6 := (H1 F' _ _) in _).
assert (F' = Im C' Complement).
apply Extensionality_Ensembles; split; red; intros.
destruct H6.
exists (Complement x); trivial.
symmetry; apply Complement_Complement.
destruct H6.
constructor.
rewrite H7; rewrite Complement_Complement; trivial.
rewrite H6; apply finite_image.
assumption.

red; intros.
destruct H6.
apply H4 in H6.
destruct H6.
rewrite Complement_Complement in H6; trivial.

destruct H6 as [x0].
destruct H6.
assert (In (FamilyUnion C') x).
rewrite H5; constructor.
destruct H7.
assert (In (Complement S) x).
apply H6.
constructor.
rewrite Complement_Complement; trivial.
contradiction H9.
Qed.

Lemma finite_nonempty_closed_intersection_impl_compact:
  forall X:TopologicalSpace,
  (forall F:Family (point_set X),
    (forall G:Ensemble (point_set X), In F G -> closed G) ->
    (forall F':Family (point_set X), Finite _ F' -> Included F' F ->
     Inhabited (FamilyIntersection F')) ->
    Inhabited (FamilyIntersection F)) ->
  compact X.
Proof.
intros.
red; intros.
apply NNPP; red; intro.
pose (F := [ G:Ensemble (point_set X) | In C (Complement G) ]).
unshelve refine (let H3 := (H F _ _) in _).
intros.
destruct H3.
apply H0; trivial.
intros.
apply NNPP; red; intro.
contradiction H2.
exists [ U:Ensemble (point_set X) | In F' (Complement U) ].
repeat split.
assert ([U:Ensemble (point_set X) | In F' (Complement U)] =
  Im F' Complement).
apply Extensionality_Ensembles; split; red; intros.
destruct H6.
exists (Complement x); trivial.
symmetry; apply Complement_Complement.
constructor.
destruct H6.
rewrite H7; rewrite Complement_Complement; trivial.
rewrite H6; apply finite_image; trivial.

red; intros.
destruct H6.
apply H4 in H6.
destruct H6.
rewrite Complement_Complement in H6; trivial.

apply Extensionality_Ensembles; split; red; intros.
constructor.
apply NNPP; red; intro.
contradiction H5.
exists x.
constructor.
intros.
apply NNPP; red; intro.
contradiction H7.
exists (Complement S).
constructor.
rewrite Complement_Complement; trivial.
exact H9.

destruct H3.
assert (In (FamilyUnion C) x).
rewrite H1; constructor.
destruct H4.
assert (In (Complement S) x).
destruct H3.
apply H3.
constructor.
rewrite Complement_Complement; trivial.
contradiction H6.
Qed.

Lemma compact_impl_filter_cluster_point:
  forall X:TopologicalSpace, compact X ->
    forall F:Filter (point_set X), exists x0:point_set X,
    filter_cluster_point F x0.
Proof.
intros.
pose proof (compact_finite_nonempty_closed_intersection
  _ H [ G:Ensemble (point_set X) | In (filter_family F) G /\
                                   closed G ]) as [x0].
intros.
destruct H0 as [[]]; trivial.
intros.
assert (closed (FamilyIntersection F')).
apply closed_family_intersection.
intros.
apply H1 in H2.
destruct H2 as [[]]; trivial.
assert (In (filter_family F) (FamilyIntersection F')).
clear H2.
induction H0.
rewrite empty_family_intersection.
apply filter_full.
replace (FamilyIntersection (Add A x)) with
  (Intersection (FamilyIntersection A) x).
apply filter_intersection.
apply IHFinite.
auto with sets.
assert (In (Add A x) x) by (right; constructor).
apply H1 in H3.
destruct H3 as [[]]; trivial.
apply Extensionality_Ensembles; split; red; intros.
destruct H3.
constructor.
intros.
destruct H5.
destruct H3.
apply H3; trivial.
destruct H5; trivial.
destruct H3.
constructor.
constructor; intros.
apply H3.
auto with sets.
apply H3.
auto with sets.
apply NNPP; intro.
contradiction (filter_empty _ F).
replace (@Empty_set (point_set X)) with (FamilyIntersection F'); trivial.
apply Extensionality_Ensembles; split; red; intros.
contradiction H4.
exists x; trivial.
destruct H5.

exists x0.
red; intros.
destruct H0.
apply H0.
constructor.
split.
apply filter_upward_closed with S; trivial.
apply closure_inflationary.
apply closure_closed.
Qed.

Lemma filter_cluster_point_impl_compact:
  forall X:TopologicalSpace,
    (forall F:Filter (point_set X), exists x0:point_set X,
      filter_cluster_point F x0) -> compact X.
Proof.
intros.
apply finite_nonempty_closed_intersection_impl_compact.
intros.
unshelve refine (let H2:=_ in let filt := Build_Filter_from_subbasis F H2 in _).
intros.
rewrite indexed_to_family_intersection.
apply H1.
apply FiniteT_img; trivial.
intros; apply classic.
red; intros.
destruct H4.
rewrite H5; apply H3.
assert (filter_subbasis filt F) by apply filter_from_subbasis_subbasis.
destruct (H filt) as [x0].
exists x0.
constructor; intros.
assert (closed S) by (apply H0; trivial).
assert (In (filter_family filt) S).
apply (filter_subbasis_elements _ _ H3); trivial.
pose proof (H4 _ H7).
rewrite closure_fixes_closed in H8; trivial.
Qed.

Lemma ultrafilter_limit_impl_compact:
  forall X:TopologicalSpace,
    (forall U:Filter (point_set X), ultrafilter U ->
      exists x0:point_set X, filter_limit U x0) -> compact X.
Proof.
intros.
apply filter_cluster_point_impl_compact.
intros.
destruct (ultrafilter_extension F) as [U].
destruct H0.
destruct (H _ H1) as [x0].
exists x0.
red; intros.
apply filter_limit_is_cluster_point in H2.
apply H0 in H3.
apply H2; trivial.
Qed.

Lemma compact_impl_net_cluster_point:
  forall X:TopologicalSpace, compact X ->
    forall (I:DirectedSet) (x:Net I X), inhabited (DS_set I) ->
    exists x0:point_set X, net_cluster_point x x0.
Proof.
Require Import FiltersAndNets.
intros.
destruct (compact_impl_filter_cluster_point
  _ H (tail_filter x H0)) as [x0].
exists x0.
apply tail_filter_cluster_point_impl_net_cluster_point with H0.
apply H1.
Qed.

Lemma net_cluster_point_impl_compact: forall X:TopologicalSpace,
  (forall (I:DirectedSet) (x:Net I X), inhabited (DS_set I) ->
    exists x0:point_set X, net_cluster_point x x0) ->
  compact X.
Proof.
intros.
apply filter_cluster_point_impl_compact.
intros.
destruct (H _ (filter_to_net _ F)) as [x0].
cut (inhabited (point_set X)).
intro.
destruct H0 as [x].
exists.
simpl.
apply Build_filter_to_net_DS_set with Full_set x.
apply filter_full.
constructor.
apply NNPP; intro.
contradiction (filter_empty _ F).
replace (@Empty_set (point_set X)) with (@Full_set (point_set X)).
apply filter_full.
apply Extensionality_Ensembles; split; red; intros.
contradiction H0.
exists; exact x.
destruct H1.

exists x0.
apply filter_to_net_cluster_point_impl_filter_cluster_point.
trivial.
Qed.

Require Export SeparatednessAxioms.
Require Export SubspaceTopology.

Lemma compact_closed: forall (X:TopologicalSpace)
  (S:Ensemble (point_set X)), Hausdorff X ->
  compact (SubspaceTopology S) -> closed S.
Proof.
intros.
destruct (classic (Inhabited S)).
assert (closure S = S).
apply Extensionality_Ensembles; split.
red; intros.
destruct (net_limits_determine_topology _ _ H2) as [I0 [y []]].
pose (yS (i:DS_set I0) := exist (fun x:point_set X => In S x) (y i) (H3 i)).
assert (inhabited (point_set (SubspaceTopology S))).
destruct H1.
exists.
exists x0; trivial.
assert (inhabited (DS_set I0)) as HinhI0.
red in H4.
destruct (H4 Full_set) as [i0]; auto with topology.
constructor.
pose proof (compact_impl_net_cluster_point
  (SubspaceTopology S) H0 _ yS HinhI0).
destruct H6 as [[x0]].
apply net_cluster_point_impl_subnet_converges in H6.
destruct H6 as [J [y' []]].
destruct H6.
assert (net_limit (fun j:DS_set J => y (h j)) x0).
apply continuous_func_preserves_net_limits with
  (f:=subspace_inc S) (Y:=X) in H7.
simpl in H7.
assumption.
apply continuous_func_continuous_everywhere.
apply subspace_inc_continuous.
assert (net_limit (fun j:DS_set J => y (h j)) x).
apply subnet_limit with I0 y; trivial.
constructor; trivial.
assert (x = x0).
exact (Hausdorff_impl_net_limit_unique _ H _ _ H10 H9).
rewrite H11; trivial.
destruct (H4 Full_set).
apply open_full.
constructor.
exists; exact x1.
destruct H1.

apply closure_inflationary.
rewrite <- H2; apply closure_closed.

red.
assert (Complement S = Full_set).
apply Extensionality_Ensembles; split; red; intros.
constructor.
red; intro.
contradiction H1; exists x; trivial.
rewrite H2; apply open_full.
Qed.

Lemma closed_compact: forall (X:TopologicalSpace) (S:Ensemble (point_set X)),
  compact X -> closed S -> compact (SubspaceTopology S).
Proof.
intros.
apply net_cluster_point_impl_compact.
intros.
destruct (compact_impl_net_cluster_point _ H
  _ (fun i:DS_set I => subspace_inc _ (x i))) as [x0].
trivial.
assert (In S x0).
rewrite <- (closure_fixes_closed S); trivial.
apply net_cluster_point_in_closure with
  (2:=H2).
destruct H1 as [i0].
exists i0.
intros.
destruct (x j).
simpl.
trivial.
exists (exist _ x0 H3).
red; intros.
red; intros.
destruct (subspace_topology_topology _ _ _ H4) as [V []].
rewrite H7 in H5.
destruct H5.
simpl in H5.
destruct (H2 V H6 H5 i) as [j []]; trivial.
exists j; split; trivial.
rewrite H7.
constructor.
trivial.
Qed.

Lemma compact_image: forall {X Y:TopologicalSpace}
  (f:point_set X->point_set Y),
  compact X -> continuous f -> surjective f -> compact Y.
Proof.
intros.
red; intros.
pose (B := fun U:{U:Ensemble (point_set Y) | In C U} =>
           inverse_image f (proj1_sig U)).
destruct (compactness_on_indexed_covers _ _ B H) as [subcover].
destruct a as [U].
unfold B; simpl.
apply H0.
apply H2; trivial.
apply Extensionality_Ensembles; split; red; intros.
constructor.
assert (In (FamilyUnion C) (f x)).
rewrite H3; constructor.
inversion_clear H5 as [V].
exists (exist _ V H6).
unfold B; simpl.
constructor; trivial.
destruct H4.

exists (Im subcover (@proj1_sig _ (fun U:Ensemble (point_set Y) => In C U))).
repeat split.
apply finite_image; trivial.
red; intros V ?.
destruct H6 as [[U]].
simpl in H7.
congruence.
apply Extensionality_Ensembles; split; red; intros y ?.
constructor.
destruct (H1 y) as [x].
assert (In (IndexedUnion
  (fun a':{a' | In subcover a'} => B (proj1_sig a'))) x).
rewrite H5; constructor.
destruct H8 as [[[U]]].
exists U.
simpl in H8.
exists (exist _ U i); trivial.
unfold B in H8; simpl in H8.
destruct H8.
congruence.
Qed.

Lemma compact_Hausdorff_impl_normal_sep: forall X:TopologicalSpace,
  compact X -> Hausdorff X -> normal_sep X.
Proof.
intros.
assert (T3_sep X).
Require Import ClassicalChoice.
destruct (choice (fun (xy:{xy:point_set X * point_set X |
                  let (x,y):=xy in x <> y})
  (UV:Ensemble (point_set X) * Ensemble (point_set X)) =>
  match xy with | exist (x,y) i =>
    let (U,V):=UV in
  open U /\ open V /\ In U x /\ In V y /\ Intersection U V = Empty_set
  end)) as
[choice_fun].
destruct x as [[x y] i].
destruct (H0 _ _ i) as [U [V]].
exists (U, V); trivial.

pose (choice_fun_U := fun (x y:point_set X)
  (Hineq:x<>y) => fst (choice_fun (exist _ (x,y) Hineq))).
pose (choice_fun_V := fun (x y:point_set X)
  (Hineq:x<>y) => snd (choice_fun (exist _ (x,y) Hineq))).
assert (forall (x y:point_set X) (Hineq:x<>y),
  open (choice_fun_U x y Hineq) /\
  open (choice_fun_V x y Hineq) /\
  In (choice_fun_U x y Hineq) x /\
  In (choice_fun_V x y Hineq) y /\
  Intersection (choice_fun_U x y Hineq) (choice_fun_V x y Hineq) = Empty_set).
intros.
unfold choice_fun_U; unfold choice_fun_V.
pose proof (H1 (exist _ (x,y) Hineq)).
destruct (choice_fun (exist _ (x,y) Hineq)).
exact H2.
clearbody choice_fun_U choice_fun_V; clear choice_fun H1.

split.
apply Hausdorff_impl_T1_sep; trivial.
intros.
pose proof (closed_compact _ _ H H1).
assert (forall y:point_set X, In F y -> x <> y).
intros.
congruence.
pose (cover := fun (y:point_set (SubspaceTopology F)) =>
  let (y,i):=y in inverse_image (subspace_inc F)
                     (choice_fun_V x y (H5 y i))).
destruct (compactness_on_indexed_covers _ _ cover H4) as [subcover].
destruct a as [y i].
apply subspace_inc_continuous.
apply H2.
apply Extensionality_Ensembles; split; red; intros y ?.
constructor.
exists y.
destruct y as [y i].
simpl.
constructor.
simpl.
apply H2.
destruct H6.

exists (IndexedIntersection
  (fun y:{y:point_set (SubspaceTopology F) | In subcover y} =>
    let (y,_):=y in let (y,i):=y in choice_fun_U x y (H5 y i))).
exists (IndexedUnion
  (fun y:{y:point_set (SubspaceTopology F) | In subcover y} =>
    let (y,_):=y in let (y,i):=y in choice_fun_V x y (H5 y i))).
repeat split.
apply open_finite_indexed_intersection.
apply Finite_ens_type; trivial.
destruct a as [[y]].
apply H2.
apply open_indexed_union.
destruct a as [[y]].
apply H2.
destruct a as [[y]].
apply H2.
red; intros y ?.
assert (In (IndexedUnion
  (fun y:{y:point_set (SubspaceTopology F) | In subcover y} =>
    cover (proj1_sig y))) (exist _ y H8)).
rewrite H7; constructor.
remember (exist (In F) y H8) as ysig.
destruct H9 as [[y']].
rewrite Heqysig in H9; clear x0 Heqysig.
simpl in H9.
destruct y' as [y'].
simpl in H9.
destruct H9.
simpl in H9.
exists (exist _ (exist _ y' i0) i).
trivial.

apply Extensionality_Ensembles; split; auto with sets; red; intros y ?.
destruct H8.
destruct H8.
destruct H9.
pose proof (H8 a).
destruct a as [[y]].
replace (@Empty_set (point_set X)) with
  (Intersection (choice_fun_U x y (H5 y i))
                (choice_fun_V x y (H5 y i))).
constructor; trivial.
apply H2.

destruct (choice (fun (xF:{p:point_set X * Ensemble (point_set X) |
                        let (x,F):=p in closed F /\ ~ In F x})
  (UV:Ensemble (point_set X) * Ensemble (point_set X)) =>
  let (p,i):=xF in let (x,F):=p in
  let (U,V):=UV in
  open U /\ open V /\ In U x /\ Included F V /\
  Intersection U V = Empty_set)) as [choice_fun].
destruct x as [[x F] []].
destruct H1.
destruct (H4 x F H2 H3) as [U [V]].
exists (U,V); trivial.

pose (choice_fun_U := fun (x:point_set X) (F:Ensemble (point_set X))
  (HC:closed F) (Hni:~ In F x) =>
  fst (choice_fun (exist _ (x,F) (conj HC Hni)))).
pose (choice_fun_V := fun (x:point_set X) (F:Ensemble (point_set X))
  (HC:closed F) (Hni:~ In F x) =>
  snd (choice_fun (exist _ (x,F) (conj HC Hni)))).
assert (forall (x:point_set X) (F:Ensemble (point_set X))
  (HC:closed F) (Hni:~ In F x),
  open (choice_fun_U x F HC Hni) /\
  open (choice_fun_V x F HC Hni) /\
  In (choice_fun_U x F HC Hni) x /\
  Included F (choice_fun_V x F HC Hni) /\
  Intersection (choice_fun_U x F HC Hni) (choice_fun_V x F HC Hni) =
     Empty_set).
intros.
pose proof (H2 (exist _ (x,F) (conj HC Hni))).
unfold choice_fun_U; unfold choice_fun_V;
  destruct (choice_fun (exist _ (x,F) (conj HC Hni))); trivial.
clearbody choice_fun_U choice_fun_V; clear choice_fun H2.
split.
apply H1.
intros.
pose proof (closed_compact _ _ H H2).
assert (forall x:point_set X, In F x -> ~ In G x).
intros.
intro.
absurd (In Empty_set x).
red; destruct 1.
rewrite <- H5; split; trivial.

pose (cover := fun x:point_set (SubspaceTopology F) =>
  let (x,i):=x in inverse_image (subspace_inc F)
                   (choice_fun_U x G H4 (H7 x i))).
destruct (compactness_on_indexed_covers _ _ cover H6) as [subcover].
destruct a as [x i].
apply subspace_inc_continuous.
apply H3.
apply Extensionality_Ensembles; split; red; intros.
constructor.
exists x.
destruct x.
simpl cover.
constructor.
simpl.
apply H3.
destruct H8.

exists (IndexedUnion
  (fun x:{x:point_set (SubspaceTopology F) | In subcover x} =>
     let (x,i):=proj1_sig x in choice_fun_U x G H4 (H7 x i))).
exists (IndexedIntersection
  (fun x:{x:point_set (SubspaceTopology F) | In subcover x} =>
     let (x,i):=proj1_sig x in choice_fun_V x G H4 (H7 x i))).
repeat split.
apply open_indexed_union.
destruct a as [[x]].
simpl.
apply H3.
apply open_finite_indexed_intersection.
apply Finite_ens_type; trivial.
destruct a as [[x]].
simpl.
apply H3.
intros x ?.
assert (In (@Full_set (point_set (SubspaceTopology F))) (exist _ x H10))
  by constructor.
rewrite <- H9 in H11.
remember (exist _ x H10) as xsig.
destruct H11.
destruct a as [x'].
destruct x' as [x'].
rewrite Heqxsig in H11; clear x0 Heqxsig.
simpl in H11.
destruct H11.
simpl in H11.
exists (exist _ (exist _ x' i0) i).
simpl.
trivial.
destruct a as [x'].
simpl.
destruct x' as [x'].
assert (Included G (choice_fun_V x' G H4 (H7 x' i0))) by apply H3.
auto.

apply Extensionality_Ensembles; split; auto with sets; red; intros.
destruct H10.
destruct H10.
destruct H11.
pose proof (H11 a).
destruct a as [[x']].
simpl in H12.
simpl in H10.
replace (@Empty_set (point_set X)) with (Intersection
  (choice_fun_U x' G H4 (H7 x' i))
  (choice_fun_V x' G H4 (H7 x' i))).
constructor; trivial.
apply H3.
Qed.


Variables A B C : Prop.
Lemma ex4 : ((A /\ B) -> C) -> (A -> B -> C).
Proof.
  intro Ha_and_Hb_implies_Hc.
  intro Ha.
  intro Hb.
  apply Ha_and_Hb_implies_Hc.
  split.
    +
      assumption.
    +
      assumption.
Qed.


From Coqprime Require Import PocklingtonRefl.

Local Open Scope positive_scope.

Lemma primo80 : prime 208870589.
Proof.
 apply (Pocklington_refl
         (Pock_certif 208870589 2 ((211, 1)::(2,2)::nil) 1028)
        ((Proof_certif 211 prime211) ::
         (Proof_certif 2 prime2) ::
          nil)).
 native_cast_no_check (refl_equal true).
Qed.


(**

This file contains formalizations of lists. First over sets as the initial algebra of the list
functor ([List]) and then more generally over any type defined as iterated products ([list]).

Written by: Anders Mörtberg, 2016

*)
Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.Foundations.NaturalNumbers.

Require Import UniMath.Combinatorics.Lists.

Require Import UniMath.MoreFoundations.PartA. (* flip *)
Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.categories.HSET.Limits.
Require Import UniMath.CategoryTheory.categories.HSET.Colimits.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.FunctorAlgebras.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.Chains.All.
Require Import UniMath.CategoryTheory.exponentials.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.

Local Open Scope cat.

(** * Lists as the colimit of a chain given by the list functor: F(X) = 1 + A * X *)
Section lists.

Variable A : HSET.

Local Open Scope cocont_functor_hset_scope.

(** F(X) = 1 + (A * X) *)
Definition L_A : omega_cocont_functor HSET HSET := '1 + 'A * Id.

Let listFunctor : functor HSET HSET := pr1 L_A.

Let is_omega_cocont_listFunctor : is_omega_cocont listFunctor := pr2 L_A.

Lemma listFunctor_Initial :
  Initial (category_FunctorAlg listFunctor).
Proof.
apply (colimAlgInitial InitialHSET is_omega_cocont_listFunctor (ColimCoconeHSET _ _)).
Defined.

(** The type of lists of A's *)
Definition μL_A : HSET :=
  alg_carrier _ (InitialObject listFunctor_Initial).

Definition List : UU := pr1 μL_A.

Let List_mor : HSET⟦listFunctor μL_A,μL_A⟧ :=
  alg_map _ (InitialObject listFunctor_Initial).

Let List_alg : algebra_ob listFunctor :=
  InitialObject listFunctor_Initial.

Definition nil_map : HSET⟦unitHSET,μL_A⟧ :=
  BinCoproductIn1 (BinCoproductsHSET _ _) · List_mor.

Definition nil : List := nil_map tt.

Definition cons_map : HSET⟦(A × μL_A)%set,μL_A⟧ :=
  BinCoproductIn2 (BinCoproductsHSET _ _) · List_mor.

Definition cons : pr1 A → List -> List := λ a l, cons_map (a,,l).

(** Get recursion/iteration scheme:
<<
     x : X           f : A × X -> X
  ------------------------------------
       foldr x f : List A -> X
>>
*)
Definition make_listAlgebra (X : HSET) (x : pr1 X)
  (f : HSET⟦(A × X)%set,X⟧) : algebra_ob listFunctor.
Proof.
set (x' := λ (_ : unit), x).
apply (tpair _ X (sumofmaps x' f) : algebra_ob listFunctor).
Defined.

Definition foldr_map (X : HSET) (x : pr1 X) (f : HSET⟦(A × X)%set,X⟧) :
  algebra_mor _ List_alg (make_listAlgebra X x f).
Proof.
apply (InitialArrow listFunctor_Initial (make_listAlgebra X x f)).
Defined.

(** Iteration/fold *)
Definition foldr (X : HSET) (x : pr1 X)
  (f : pr1 A → pr1 X → pr1 X) : List → pr1 X.
Proof.
apply (foldr_map _ x (λ a, f (pr1 a) (pr2 a))).
Defined.

(* Maybe quantify over "λ _ : unit, x" instead of nil? *)
Lemma foldr_nil (X : hSet) (x : X) (f : pr1 A → X -> X) : foldr X x f nil = x.
Proof.
assert (F := maponpaths (λ x, BinCoproductIn1 (BinCoproductsHSET _ _) · x)
                        (algebra_mor_commutes _ _ _ (foldr_map X x (λ a, f (pr1 a) (pr2 a))))).
apply (toforallpaths _ _ _ F tt).
Qed.

Lemma foldr_cons (X : hSet) (x : X) (f : pr1 A → X -> X)
                 (a : pr1 A) (l : List) :
  foldr X x f (cons a l) = f a (foldr X x f l).
Proof.
assert (F := maponpaths (λ x, BinCoproductIn2 (BinCoproductsHSET _ _) · x)
                        (algebra_mor_commutes _ _ _ (foldr_map X x (λ a, f (pr1 a) (pr2 a))))).
assert (Fal := toforallpaths _ _ _ F (a,,l)).
clear F.
unfold compose in Fal.
simpl in Fal.
apply Fal.
Opaque foldr_map.
Qed. (* This Qed is slow unless foldr_map is Opaque *)
Transparent foldr_map.

(** The induction principle for lists defined using foldr *)
Section list_induction.

Variables (P : List -> UU) (PhSet : ∏ l, isaset (P l)).
Variables (P0 : P nil)
          (Pc : ∏ a l, P l -> P (cons a l)).

Let P' : UU := ∑ l, P l.
Let P0' : P' := (nil,, P0).
Let Pc' : pr1 A  → P' -> P' :=
  λ (a : pr1 A) (p : P'), cons a (pr1 p),,Pc a (pr1 p) (pr2 p).

Definition P'HSET : HSET.
Proof.
apply (tpair _ P').
abstract (apply (isofhleveltotal2 2); [ apply setproperty | intro x; apply PhSet ]).
Defined.

(** This line is crucial for isalghom_pr1foldr to typecheck *)
Opaque is_omega_cocont_listFunctor.

Lemma isalghom_pr1foldr :
  is_algebra_mor listFunctor List_alg List_alg (λ l, pr1 (foldr P'HSET P0' Pc' l)).
Proof.
apply (BinCoproductArrow_eq_cor _ BinCoproductsHSET).
- apply funextfun; intro x; induction x.
  apply (maponpaths pr1 (foldr_nil P'HSET P0' Pc')).
- apply funextfun; intro x; destruct x as [a l].
  apply (maponpaths pr1 (foldr_cons P'HSET P0' Pc' a l)).
Qed.

(* Transparent is_omega_cocont_listFunctor. *)

Definition pr1foldr_algmor : algebra_mor listFunctor List_alg List_alg.
Proof.
  use tpair.
  - exact (λ l, pr1 (foldr P'HSET P0' Pc' l)).
  - hnf. apply isalghom_pr1foldr.
Defined.

Transparent is_omega_cocont_listFunctor.

Lemma pr1foldr_algmor_identity : identity List_alg = pr1foldr_algmor.
Proof.
now rewrite (@InitialEndo_is_identity _ listFunctor_Initial pr1foldr_algmor).
Qed.

(** The induction principle for lists *)
Lemma listInd l : P l.
Proof.
  assert (H : pr1 (foldr P'HSET P0' Pc' l) = l).
  apply (toforallpaths _ _ _ (maponpaths pr1 (!pr1foldr_algmor_identity)) l).
rewrite <- H.
apply (pr2 (foldr P'HSET P0' Pc' l)).
Defined.

End list_induction.

Lemma listIndhProp (P : List → hProp) :
  P nil → (∏ a l, P l → P (cons a l)) → ∏ l, P l.
Proof.
intros Pnil Pcons.
apply listInd; try assumption.
intro l; apply isasetaprop, propproperty.
Defined.

(* This variation is easier to use *)
Lemma listIndProp (P : List → UU) (HP : ∏ l, isaprop (P l)) :
  P nil → (∏ a l, P l → P (cons a l)) → ∏ l, P l.
Proof.
intros Pnil Pcons.
apply listInd; try assumption.
intro l; apply isasetaprop, HP.
Defined.

Local Open Scope nat_scope.

Local Notation "'A'" := (pr1 A).

Definition length : List -> nat := foldr natHSET 0 (λ _ (n : nat), 1 + n).

Definition map (f : A -> A) : List -> List :=
  foldr _ nil (λ (x : A) (xs : List), cons (f x) xs).

Lemma length_map (f : A -> A) : ∏ xs, length (map f xs) = length xs.
Proof.
apply listIndProp.
- intros l; apply isasetnat.
- now unfold map; rewrite foldr_nil.
- simpl; unfold map, length; simpl; intros a l Hl.
  now rewrite !foldr_cons, <- Hl.
Qed.

Definition concatenate : List -> List -> List :=
  λ l l', foldr _ l cons l'.

End lists.

(** Some examples of computations with lists over nat *)
Section nat_examples.

Definition cons_nat a l : List natHSET := cons natHSET a l.

Local Infix "::" := cons_nat.
Local Notation "[]" := (nil natHSET) (at level 0, format "[]").

Definition testlist : List natHSET := 5 :: 2 :: [].

Definition testlistS : List natHSET :=
  map natHSET S testlist.

Definition sum : List natHSET -> nat :=
  foldr natHSET natHSET 0 (λ x y, x + y).

(* None of these compute *)
(* Eval cbn in length _ (nil natHSET). *)
(* Eval vm_compute in length _ testlist. *)
(* Eval vm_compute in length _ testlistS. *)
(* Eval vm_compute in sum testlist. *)
(* Eval vm_compute in sum testlistS. *)

(* All of these compute *)
Goal length _ (nil natHSET) = 0. reflexivity. Qed.
Goal length _ testlist = length _ testlistS. reflexivity. Qed.
Goal sum testlistS = sum testlist + length _ testlist. lazy. reflexivity. Qed.
Goal length _ (concatenate _ testlist testlistS) = length _ testlist + length _ testlistS. reflexivity. Qed.
Goal sum (concatenate _ testlist testlistS) = sum testlistS + sum testlist. reflexivity. Qed.

Goal (∏ l, length _ (2 :: l) = S (length _ l)).
simpl.
intro l.
try apply idpath. (* this doesn't work *)
unfold length, cons_nat.
rewrite foldr_cons. cbn.
apply idpath.
Abort.

(* some experiments: *)

(* Definition const {A B : UU} : A -> B -> A := λ x _, x. *)

(* Eval compute in const 0 (nil natHSET). *)

(* Axiom const' : ∏ {A B : UU}, A -> B -> A. *)

(* Eval compute in const' 0 1. *)
(* Eval compute in const' 0 (nil natHSET). *)

(* Time Eval vm_compute in nil natHSET.  (* This crashes my computer by using up all memory *) *)

End nat_examples.

(** * Equivalence with lists as iterated products *)
Section list.

Lemma isaset_list (A : HSET) : isaset (list (pr1 A)).
Proof.
apply isaset_total2; [apply isasetnat|].
intro n; induction n as [|n IHn]; simpl; [apply isasetunit|].
apply isaset_dirprod; [ apply setproperty | apply IHn ].
Qed.

Definition to_List (A : HSET) : list (pr1 A) -> List A.
Proof.
intros l.
destruct l as [n l].
induction n as [|n IHn].
+ exact (nil A).
+ apply (cons _ (pr1 l) (IHn (pr2 l))).
Defined.

Definition to_list (A : HSET) : List A -> list (pr1 A).
Proof.
apply (foldr A (list (pr1 A),,isaset_list A)).
* apply (0,,tt).
* intros a L; simpl in *.
  apply (tpair _ (S (pr1 L)) (a,,pr2 L)).
Defined.

Lemma to_listK (A : HSET) : ∏ x : list (pr1 A), to_list A (to_List A x) = x.
Proof.
intro l; destruct l as [n l]; unfold to_list, to_List.
induction n as [|n IHn]; simpl.
- rewrite foldr_nil.
  now destruct l.
- rewrite foldr_cons; simpl.
  now rewrite IHn.
Qed.

Lemma to_ListK (A : HSET) : ∏ y : List A, to_List A (to_list A y) = y.
Proof.
apply listIndProp.
* intro l; apply setproperty.
* now unfold to_list; rewrite foldr_nil.
* unfold to_list, to_List; intros a l IH.
  rewrite foldr_cons; simpl.
  apply maponpaths, pathsinv0.
  eapply pathscomp0; [eapply pathsinv0, IH|]; simpl.
  now destruct foldr.
Qed.

(** Equivalence between list and List for A a set *)
Lemma weq_list (A : HSET) : list (pr1 A) ≃ List A.
Proof.
use tpair.
- apply to_List.
- use isweq_iso.
  + apply to_list.
  + apply to_listK.
  + apply to_ListK.
Defined.

(* This doesn't compute: *)
(* Eval compute in (to_list _ testlist). *)

(* This does compute: *)
Goal to_list _ testlist = 2,,5,,2,,tt. reflexivity. Qed.

End list.

(** Alternative version of lists using a more direct proof of omega-cocontinuity. This definition
    has slightly better computational properties. *)
Module AltList.

(* The functor "x * F" is omega_cocont. This is only proved for set at the
   moment as it needs that the category is cartesian closed *)
Section constprod_functor.

Variables (x : hSet).

Definition constprod_functor : functor HSET HSET :=
  BinProduct_of_functors HSET HSET BinProductsHSET (constant_functor HSET HSET x)
                                         (functor_identity HSET).

Lemma omega_cocontConstProdFunctor : is_omega_cocont constprod_functor.
Proof.
intros hF c L ccL HcL cc.
use tpair.
- transparent assert (HX : (cocone hF (funset x HcL))).
  {  use make_cocone.
    * simpl; intro n; apply flip, (curry (Z := λ _,_)), (pr1 cc).
    * abstract (destruct cc as [f hf]; simpl; intros m n e;
                rewrite <- (hf m n e); destruct e; simpl;
                repeat (apply funextfun; intro); apply idpath).
  }
  use tpair.
  + simpl; apply uncurry, flip.
    apply (colimArrow (make_ColimCocone _ _ _ ccL) (funset x HcL)).
    apply HX.
  + cbn.
    destruct cc as [f hf]; simpl; intro n.
    apply funextfun; intro p.
    change p with (pr1 p,,pr2 p).
    assert (XR := colimArrowCommutes (make_ColimCocone hF c L ccL) _ HX n).
    unfold flip, curry, colimIn in *; simpl in *.
    now rewrite <- (toforallpaths _ _ _ (toforallpaths _ _ _ XR (pr2 p)) (pr1 p)).
- abstract (
  intro p; unfold uncurry; simpl; apply subtypePath; simpl;
  [ intro g; apply impred; intro t;
    use (let ff : HSET ⟦(x × dob hF t)%set,HcL⟧ := _ in _);
    [ simpl; apply (pr1 cc)
    | apply (@has_homsets_HSET _ HcL _ ff) ]
  | destruct p as [t p]; simpl;
    apply funextfun; intro xc; destruct xc as [x' c']; simpl;
    use (let g : HSET⟦colim (make_ColimCocone hF c L ccL),
                                funset x HcL⟧ := _ in _);
    [ simpl; apply flip, (curry (Z := λ _,_)), t
    | rewrite <- (colimArrowUnique _ _ _ g); [apply idpath | ];
      destruct cc as [f hf]; unfold is_cocone_mor in p; simpl in *;
      now intro n; simpl; rewrite <- (p n) ]
  ]).
Defined.

End constprod_functor.

(* The functor "x + F" is omega_cocont.
   Assumes that the category has coproducts *)
Section constcoprod_functor.

Variables (C : category) (x : C) (PC : BinCoproducts C).

Definition constcoprod_functor : functor C C :=
  BinCoproduct_of_functors C C PC (constant_functor C C x) (functor_identity C).

Lemma omega_cocontConstCoprodFunctor : is_omega_cocont constcoprod_functor.
Proof.
intros hF c L ccL HcL cc.
use tpair.
- use tpair.
  + eapply BinCoproductArrow.
    * exact (BinCoproductIn1 (PC x (dob hF 0)) · pr1 cc 0).
    * use (let ccHcL : cocone hF HcL := _ in _).
      { use make_cocone.
        - intros n; exact (BinCoproductIn2 (PC x (dob hF n)) · pr1 cc n).
        -   abstract (
            intros m n e; destruct e; simpl;
            destruct cc as [f hf]; simpl in *;
            rewrite <- (hf m _ (idpath _)), !assoc; apply cancel_postcomposition;
            unfold constcoprod_functor; cbn;
            apply pathsinv0; etrans; [apply BinCoproductOfArrowsIn2|]; apply idpath). }
      apply (pr1 (pr1 (ccL HcL ccHcL))).
  + abstract (
    destruct cc as [f hf]; simpl in *;
    simpl; intro n; unfold constcoprod_functor; cbn;
    etrans; [apply precompWithBinCoproductArrow |]; apply pathsinv0, BinCoproductArrowUnique; red in hf;
    [ rewrite id_left; induction n as [|n IHn]; [apply idpath|];
      etrans; [| apply IHn]; unfold constant_functor; simpl; rewrite <- (hf n _ (idpath _)), assoc;
      unfold constant_functor; simpl; apply pathsinv0;
      etrans; [apply cancel_postcomposition; apply BinCoproductOfArrowsIn1 |]; now rewrite id_left
    | rewrite <- (hf n _ (idpath _)); destruct ccL as [t p]; destruct t as [t p0]; simpl in *;
      rewrite p0; simpl; now apply maponpaths, hf]).
- abstract (
      destruct cc as [f hf]; simpl in *;
      intro t; apply subtypePath; simpl;
      [  intro g; apply impred; intro; apply C
       | destruct t as [t p]; destruct ccL as [t0 p0]; unfold is_cocone_mor in *;
         unfold constcoprod_functor; destruct t0 as [t0 p1]; simpl;
         apply BinCoproductArrowUnique;
         [  unfold coconeIn in p; simpl in p;
            rewrite <- (p 0), assoc;
            apply cancel_postcomposition; apply pathsinv0; etrans; [apply  BinCoproductOfArrowsIn1 |]; apply id_left
         |  use (let temp : ∑ x0 : C ⟦ c, HcL ⟧, ∏ v : nat,
                                coconeIn L v · x0 = BinCoproductIn2 (PC x (dob hF v)) · f v := _ in _);
            [ apply (tpair _ (BinCoproductIn2 (PC x c) · t));
              intro n; unfold coconeIn in p; simpl in p; rewrite <- (p n), !assoc;
              apply cancel_postcomposition; apply pathsinv0; etrans; [apply  BinCoproductOfArrowsIn2 |];
              apply idpath|];
            apply (maponpaths pr1 (p0 temp))]]).
Defined.

End constcoprod_functor.

(* Lists as the colimit of a chain given by the list functor: F(X) = 1 + A * X *)
Section lists.

Variable A : HSET.

(* F(X) = A * X *)
Definition stream : functor HSET HSET := constprod_functor1 BinProductsHSET A.

(* F(X) = 1 + (A * X) *)
Definition listFunctor : functor HSET HSET :=
  functor_composite stream (constcoprod_functor _ unitHSET BinCoproductsHSET).

Lemma omega_cocont_listFunctor : is_omega_cocont listFunctor.
Proof.
apply (is_omega_cocont_functor_composite).
- apply omega_cocontConstProdFunctor.
(* If I use this length doesn't compute with vm_compute... *)
(* - apply (omega_cocont_constprod_functor1 _ _ has_homsets_HSET Exponentials_HSET). *)
- apply (omega_cocontConstCoprodFunctor _).
Defined.

Lemma listFunctor_Initial :
  Initial (category_FunctorAlg listFunctor).
Proof.
apply (colimAlgInitial InitialHSET omega_cocont_listFunctor (ColimCoconeHSET _ _)).
Defined.

Definition List : HSET :=
  alg_carrier _ (InitialObject listFunctor_Initial).

Let List_mor : HSET⟦listFunctor List,List⟧ :=
  alg_map _ (InitialObject listFunctor_Initial).

Let List_alg : algebra_ob listFunctor :=
  InitialObject listFunctor_Initial.

Definition nil_map : HSET⟦unitHSET,List⟧.
Proof.
simpl; intro x.
use List_mor.
apply inl.
exact x.
Defined.

Definition nil : pr1 List := nil_map tt.

Definition cons_map : HSET⟦(A × List)%set,List⟧.
Proof.
intros xs.
use List_mor.
exact (inr xs).
Defined.

Definition cons : pr1 A × pr1 List -> pr1 List := cons_map.

(* Get recursion/iteration scheme: *)

(*    x : X           f : A × X -> X *)
(* ------------------------------------ *)
(*       foldr x f : List A -> X *)

Definition make_listAlgebra (X : HSET) (x : pr1 X)
  (f : HSET⟦(A × X)%set,X⟧) : algebra_ob listFunctor.
Proof.
set (x' := λ (_ : unit), x).
apply (tpair _ X (sumofmaps x' f) : algebra_ob listFunctor).
Defined.

Definition foldr_map (X : HSET) (x : pr1 X) (f : HSET⟦(A × X)%set,X⟧) :
  algebra_mor _ List_alg (make_listAlgebra X x f).
Proof.
apply (InitialArrow listFunctor_Initial (make_listAlgebra X x f)).
Defined.

Definition foldr (X : HSET) (x : pr1 X)
  (f : pr1 A × pr1 X -> pr1 X) : pr1 List -> pr1 X.
Proof.
apply (foldr_map _ x f).
Defined.

(* Maybe quantify over "λ _ : unit, x" instead of nil? *)
Lemma foldr_nil (X : hSet) (x : X) (f : pr1 A × X -> X) : foldr X x f nil = x.
Proof.
assert (F := maponpaths (λ x, BinCoproductIn1 (BinCoproductsHSET _ _) · x)
                        (algebra_mor_commutes _ _ _ (foldr_map X x f))).
apply (toforallpaths _ _ _ F tt).
Qed.

Lemma foldr_cons (X : hSet) (x : X) (f : pr1 A × X -> X)
                 (a : pr1 A) (l : pr1 List) :
  foldr X x f (cons (a,,l)) = f (a,,foldr X x f l).
Proof.
assert (F := maponpaths (λ x, BinCoproductIn2 (BinCoproductsHSET _ _) · x)
                        (algebra_mor_commutes _ _ _ (foldr_map X x f))).
apply (toforallpaths _ _ _ F (a,,l)).
Qed.

(* This defines the induction principle for lists using foldr *)
Section list_induction.

Variables (P : pr1 List -> UU) (PhSet : ∏ l, isaset (P l)).
Variables (P0 : P nil)
          (Pc : ∏ (a : pr1 A) (l : pr1 List), P l -> P (cons (a,,l))).

Let P' : UU := ∑ l, P l.
Let P0' : P' := (nil,, P0).
Let Pc' : pr1 A × P' -> P' :=
  λ ap : pr1 A × P', cons (pr1 ap,, pr1 (pr2 ap)),,Pc (pr1 ap) (pr1 (pr2 ap)) (pr2 (pr2 ap)).

Definition P'HSET : HSET.
Proof.
apply (tpair _ P').
abstract (apply (isofhleveltotal2 2); [ apply setproperty | intro x; apply PhSet ]).
Defined.

Lemma isalghom_pr1foldr :
  is_algebra_mor _ List_alg List_alg (λ l, pr1 (foldr P'HSET P0' Pc' l)).
Proof.
apply BinCoproductArrow_eq_cor.
- apply funextfun; intro x; destruct x; apply idpath.
- apply funextfun; intro x; destruct x as [a l].
  apply (maponpaths pr1 (foldr_cons P'HSET P0' Pc' a l)).
Qed.

Definition pr1foldr_algmor : algebra_mor _ List_alg List_alg :=
  tpair _ _ isalghom_pr1foldr.

Lemma pr1foldr_algmor_identity : identity _ = pr1foldr_algmor.
Proof.
now rewrite (@InitialEndo_is_identity _ listFunctor_Initial pr1foldr_algmor).
Qed.

Lemma listInd l : P l.
Proof.
assert (H : pr1 (foldr P'HSET P0' Pc' l) = l).
  apply (toforallpaths _ _ _ (maponpaths pr1 (!pr1foldr_algmor_identity)) l).
rewrite <- H.
apply (pr2 (foldr P'HSET P0' Pc' l)).
Defined.

End list_induction.

Lemma listIndProp (P : pr1 List -> UU) (HP : ∏ l, isaprop (P l)) :
  P nil -> (∏ a l, P l → P (cons (a,, l))) -> ∏ l, P l.
Proof.
intros Pnil Pcons.
apply listInd; try assumption.
intro l; apply isasetaprop, HP.
Defined.

Definition natHSET : HSET.
Proof.
exists nat.
abstract (apply isasetnat).
Defined.

Definition length : pr1 List -> nat :=
  foldr natHSET 0 (λ x, S (pr2 x)).

Definition map (f : pr1 A -> pr1 A) : pr1 List -> pr1 List :=
  foldr _ nil (λ xxs : pr1 A × pr1 List, cons (f (pr1 xxs),, pr2 xxs)).

Lemma length_map (f : pr1 A -> pr1 A) : ∏ xs, length (map f xs) = length xs.
Proof.
apply listIndProp.
- intros l; apply isasetnat.
- apply idpath.
- simpl; unfold map, length; simpl; intros a l Hl.
  simpl.
  now rewrite !foldr_cons, <- Hl.
Qed.

End lists.

(* Some examples of computations with lists over nat *)
Section nat_examples.

Definition cons_nat a l : pr1 (List natHSET) := cons natHSET (a,,l).

Infix "::" := cons_nat.
Notation "[]" := (nil natHSET) (at level 0, format "[]").

Definition testlist : pr1 (List natHSET) := 5 :: 2 :: [].

Definition testlistS : pr1 (List natHSET) :=
  map natHSET S testlist.

Definition sum : pr1 (List natHSET) -> nat :=
  foldr natHSET natHSET 0 (λ xy, pr1 xy + pr2 xy).

(* All of these work *)
(* Eval cbn in length _ (nil natHSET). *)
(* Eval vm_compute in length _ testlist. *)
(* Eval vm_compute in length _ testlistS. *)
(* Eval vm_compute in sum testlist. *)
(* Eval vm_compute in sum testlistS. *)

(* Goal length _ testlist = 2. *)
(* vm_compute. *)
(* Restart. *)
(* cbn. *)
(* Restart. *)
(* compute.  (* does not work when foldr is opaque with "Opaque foldr." *) *)
(* Restart. *)
(* cbv.   (* does not work when foldr is opaque with "Opaque foldr." *) *)
(* Restart. *)
(* native_compute. *)
(* Abort. *)

Goal (∏ l, length _ (2 :: l) = S (length _ l)).
simpl.
intro l.
try apply idpath. (* this doesn't work *)
unfold length, cons_nat.
rewrite foldr_cons. cbn.
apply idpath.
Abort.

End nat_examples.
End AltList.


Parameter A : Type.
Parameter P : A -> Prop.
Parameter Q : A -> Prop.

Definition spec__exist := exists a, P a /\ Q a.
Definition spec__impl  := forall a, P a -> Q a.

Section Exist_Impl.

  Hypothesis P_functional :
    forall a1 a2, P a1 -> P a2 -> a1 = a2.

  Goal spec__exist -> spec__impl.
  Proof.
    cbv.
    intros.
    destruct H as [a' H]; destruct H as [H1 H2].
    rewrite (P_functional a a') by assumption.
    assumption.
  Qed.

End Exist_Impl.

Section Impl_Exist.

  Hypothesis P_total :
    exists a, P a.

  Goal spec__impl -> spec__exist.
  Proof.
    cbv.
    intros.
    destruct P_total as [a H1].
    specialize (H a). exists a.
    split.
    - assumption.
    - apply H.
      assumption.
  Qed.

End Impl_Exist.


Require Import Reals.
Require Import Interval.Interval_tactic.
Require Import Coquelicot.Coquelicot.

Open Scope R_scope.

(* The following are from Definition 12
   from section 2 of the paper. *)

Definition asinh x := ln (x + sqrt (x^2 + 1)).

Definition S := (1/(2 * sqrt 2)) / asinh (1/(2 * sqrt 2)).

Definition K := 2 * (sqrt 3) / S.

Definition h z  := (1 + z^2) / (z * (1 - z^2)).

Definition gU z := (1 + z^2) / (2 * (z ^ 3)).

Definition gL z := (1 + z^2)^2 / (2 * z^3 * (3 - z^2)).

Definition H z := (h z) / K.

Definition GU z := (gU z) / K.

Definition GL z := (gL z) / K.

Notation "x ^ y" := (powerRZ x y).

(* At this point we just copy in things from Maxima,
   using Maxima's grind command.
*)
Definition FU z := -(z^4+6*z^2+4*z+1)/((z+1)*(z^2+1)^2).
Definition FL z := -(z^6+7*z^4+12*z^3-9*z^2-4*z+1)/((z+1)*(z^2+1)*(z^2-2*z-1)*(z^2+2*z-1)).

Definition PHU z := RInt FU 1 z.
Definition fU z := K * (1 - z) * exp (- PHU z).

Definition PHL z := RInt FL 1 z.
Definition fL z := K * (1 - z) * exp (- PHL z).

Definition LB_igd w :=
  2^(7/2)*sqrt(3)*asinh(1/2^(3/2))*w^2*(w^2-3)*(w^4+4*w^2-1)
                                                 /((w^2+1)^2*(w^2-2*w-1)*(w^2+2*w-1)).
Definition LB z := (1/4) * RInt LB_igd z 1.

Definition UB_igd w :=
  2^(7/2)*sqrt(3)*asinh(1/2^(3/2))*w^2*(w^4+4*w^2-1)/(w^2+1)^3.
Definition UB z := (1/4) * RInt UB_igd z 1.

Lemma fU_concavity:
  forall z, 811/1000 <= z <= 1 ->
            -2*(z^8+6*z^6+32*z^4+10*z^2-1)/((z+1)*(z^2+1)^4) < 0.
Proof.
  intros. interval with (i_bisect_diff z).
Qed.

Lemma fL_concavity:
  forall z, 811/1000 <= z <= 1 ->
  -2*(z^12-4*z^10+17*z^8-248*z^6+203*z^4-36*z^2+3)
       /((z+1)*(z^2+1)^2*(z^2-2*z-1)^2*(z^2+2*z-1)^2) > 0.
Proof.
  intros. interval with (i_bisect_diff z).
Qed.

Lemma LB_concavity:
  forall z,
    811/1000 <= z <= 1 ->
    (5*z^8-6*z^6+88*z^4-26*z^2+3) > 0.
Proof.
  intros. interval with (i_bisect_diff z).
Qed.

Lemma UB_concavity:
  forall z,
    811/1000 <= z <= 1 ->
    z^4-10*z^2+1 < 0.
Proof.
  intros. interval with (i_bisect_diff z).
Qed.

(* The above lemmata prove something slightly stronger
   than Lemma 25, namely that the consequents of Lemma
   25 hold when z is in [0.811,1]. We now prove xi > 0.811. *)

(* The following long expression is grind(-factor(expand(FL + 1/(1-z)))).
   It has the same sign as the derivative of fL. *)

Lemma fL_decreasing:
  forall z,
    811/1000 <= z <= 812/1000 ->
    2*z*(z^2-3)*(z^4+4*z^2-1)/((z-1)*(z+1)*(z^2+1)*(z^2-2*z-1)*(z^2+2*z-1)) < 0.
Proof.
  intros. interval with (i_bisect_diff z).
Qed.

(* Since fL is decreasing on [0.811, 0.812], fL - k has at most one root there
   for any real k. fL - fU(sqrt(1/3)) has such a root by the intermediate value theorem.
   Since fL is differentiable, one could prove this constructively without an appeal to IVT.
   We will not do so now. *)

Ltac unfold_defs := unfold fU; unfold PHU; unfold FU;
                    unfold fL; unfold PHL; unfold FL;
                    unfold UB; unfold UB_igd;
                    unfold LB; unfold LB_igd;
                    unfold K; unfold S; unfold asinh.

Lemma fU_xi_bounds:
  686533 / 1000000 < fU(sqrt(1/3)) < 686537 / 1000000.
Proof.
  split; unfold_defs; interval.
Qed.

Lemma fL_xi_bounds:
  fL(8112/10000) > 686537/1000000 /\ fL(8113/10000) < 686533/1000000.
Proof.
  split; unfold_defs; interval.
Qed.

(* Therefore, by the intermediate value theorem,
   there is a unique point xi between 0.8112 and
   0.8113 such that fL(xi) = fU(sqrt(1/3)). *)

(* Now we get bounds on DV. We want a lemma
   of the form DV < TH -> fL(BL(DV)) < fU(sqrt(1/3)).

   We begin by showing it makes sense to consider this,
   since fU(sqrt(1/3)) is in the domain of invertibility of fL
   near 1 (viz., [sqrt(sqrt(5)-2), infty]).
*)

Lemma fU_sqrt_DV_bounds:
  fU(sqrt(1/3)) > sqrt(sqrt(5)-2).
Proof.
  unfold_defs. interval.
Qed.

(* fL(BL(DV)) < fU(sqrt(1/3)) is implied by
   fL(BL(DV)) < 0.686533, since 0.686533 < fU(sqrt(1/3)).

   We show next that fL(x) < 0.686533 is implied by
   x > 0.81127. We can do this just by showing fL(0.81127) < 0.686533,
   since fL is decreasing on [sqrt(sqrt(5)-2), infty).
*)
Lemma fL_DV_bounds:
  fL(81127/100000) < 686533/1000000.
Proof.
  unfold_defs; interval.
Qed.

(* Finally we want some way to imply BL(DV) > 0.81127, which is
   to say (since LB is decreasing on (sqrt(sqrt(5)-2), 1))
   DV < LB(0.81127). If TH < LB(0.81127) we can imply this by
   DV < TH. It suffices to pick TH = 0.15326.
 *)

Lemma DV_bounds:
  15326/100000 < LB(81127/100000).
Proof.
  unfold_defs; interval.
Qed.

(* And finally, now for the bounds on alpha, beta, and gamma.

   For the bound on alpha, we rewrite PHU(xi) - PHL(xi) as
   a single integral, rewriting the integrand. By grinding from
   Maxima, we get that this integrand is as given below. After
   loading pams.mac, the command that gets us the definition below is

   grind(factor(expand(FU - FL)));

 *)

Definition alpha_igd z := 8*z*(z^4+4*z^2-1)/((z^2+1)^2*(z^2-2*z-1)*(z^2+2*z-1)).

(* We can't define alpha, since we haven't defined xi yet.
   So instead we will just derive an upper bound on alpha. *)

Lemma alpha_igd_ineq : forall z, 81127/100000 <= z <= 1 -> (alpha_igd z) < 0.
Proof.
  intros. unfold alpha_igd.
  interval with (i_bisect_diff z).
Qed.

(* Let A(z) be the integral of alpha_igd from 1 to z. Then
   A'(z) = alpha_igd(z). So A is decreasing (on [sqrt(1/3),1]).
   Hence A(xi-eps) is an upper bound on A(xi) for small eps > 0.
   Likewise 1-xi+eps is an upper bound on 1-xi for eps > 0.
   We pick eps = xi - 0.81127. Also, since TH < Theta, 1/TH > 1/Theta.
 *)

Check PI.

Lemma alpha_bound :
  (K * (1 - 81127/100000)/(2*PI*15326/100000))
  * exp (RInt alpha_igd 1 (81127/100000)) < 97/100.
Proof.
  unfold alpha_igd. unfold_defs.
  interval.
Qed.

(* In fact, beta is (2*pi)^2*Theta/fL(xi). So to get an
   upper bound on beta, we get an upper bound on Theta
   and on fL(xi). We begin with an upper bound on Theta.
   Theta is LB(xi). Since LB is decreasing, LB(xi-eps)
   is greater than LB(xi) for eps > 0 small enough.
   So an upper bound on LB(0.8112) is an upper bound
   on Theta.
 *)

Lemma theta_upper_bound :
  LB(8112/10000) < 1562/10000.
Proof.
  unfold_defs. interval.
Qed.

(* Next an upper bound on 1/fL(xi). Since
   fL is decreasing, 1/fL is increasing.
   So 1/fL(xi) < 1/fL(xi+eps).
 *)

Lemma fL_inv_upper_bound :
  1 / (fL (8113/10000)) < 1457/100.
Proof.
  unfold_defs. interval.
Qed.

Lemma beta_bound :
  (2*PI)^2 * (1562/10000) * (1457/1000) > 895/100.
Proof.
  interval.
Qed.

(* Now for gamma. gamma is pi^2*e^(PHU(xi)).
   PHU' is FU. Now, FU is negative on the
   given interval.
 *)

Lemma FU_neg:
  forall z, 811/1000 <= z <= 1 ->
            FU z < 0.
Proof.
  intros. unfold_defs. interval with (i_bisect_diff z).
Qed.

(* Therefore, PHU is a decreasing function there.
   So exp o PHU is likewise a decreasing function.
   So exp(PHU(xi-eps)) > exp(PHU(xi)) for eps > 0.
 *)

Lemma gamma_bound :
  PI^2 * exp(PHU(8112/10000)) < 134/10.
Proof.
  unfold_defs. interval.
Qed.

(* Finally for the slope bound. fU is decreasing,
   so 1/sqrt(fU(x)) is an increasing function of
   x; so 1/sqrt(fU(BU(TH))) < 1/sqrt(fU(BU(TH)+eps))
   for eps > 0 small. Hence if BU(TH) < BB then
   an upper bound on 1/sqrt(fU(BB)) will suffice.

   Now BU(TH) < BB when TH > UB(BB). So now we need
   a lower bound on Theta.
 *)

Lemma theta_lower_bound :
  LB(8113/10000) > 153/1000.
Proof.
  unfold_defs. interval.
Qed.

Lemma BB_bound :
  153/1000 > UB(758/1000).
Proof.
  unfold_defs. interval.
Qed.

(* So BB = 0.758 suffices. Thus finally we arrive
   at the following bound.
 *)

Lemma slope_bound :
  85/10 > 2*PI/sqrt(fU(758/1000)).
Proof.
  unfold_defs. interval.
Qed.


Require Import Coq.Setoids.Setoid Coq.PArith.BinPos Coq.PArith.Pnat.

Set Automatic Introduction.

Section P_of_nat.

  Variables (n: nat) (E: n <> O).

  Lemma P_of_nat: positive.
   apply P_of_succ_nat.
   destruct n as [|p].
    exfalso. apply E. reflexivity.
   exact p.
  Defined.

  Lemma P_of_nat_correct: nat_of_P P_of_nat = n.
   unfold P_of_nat.
   destruct n. exfalso. intuition.
   apply nat_of_P_o_P_of_succ_nat_eq_succ.
  Qed.

End P_of_nat.

Lemma nat_of_P_inj_iff (p q : positive): nat_of_P p = nat_of_P q <-> p = q.
Proof with auto.
 split; intro. apply nat_of_P_inj... subst...
Qed.

Lemma nat_of_P_nonzero (p: positive): nat_of_P p <> 0.
Proof.
 intro H.
 apply Lt.lt_irrefl with 0.
 rewrite <- H at 2.
 apply lt_O_nat_of_P.
Qed.

#[global]
Hint Immediate nat_of_P_nonzero.

Lemma Plt_lt (p q: positive): Pos.lt p q <-> (nat_of_P p < nat_of_P q).
Proof.
 split. apply nat_of_P_lt_Lt_compare_morphism.
 apply nat_of_P_lt_Lt_compare_complement_morphism.
Qed.

Lemma Ple_le (p q: positive): Pos.le p q <-> le (nat_of_P p) (nat_of_P q).
Proof.
 rewrite Pos.le_lteq, Plt_lt, Lt.le_lt_or_eq_iff, nat_of_P_inj_iff.
 reflexivity.
Qed.

Lemma Ple_refl p: Pos.le p p.
Proof. intros. apply Pos.le_lteq. firstorder. Qed.