(* week-01_functional-programming-in-Coq.v *)
(* YSC3236 2017-2018, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of 27 Aug 2017 *)
(* was: *)
(* Version of 15 Aug 2017 *)

(* ********** *)

(* Your name and e-mail address:
Jeremy Yew
Jeremy.yew@u.yale-nus.edu.sg *)

(* ********** *)

(* ********** *)

Require Import Arith Bool.

Notation "A =n= B" :=
  (beq_nat A B) (at level 70, right associativity).

(* ********** *)

Definition test_add (candidate: nat -> nat -> nat) : bool :=
  (candidate 0 0 =n= 0)
  &&
  (candidate 0 1 =n= 1)
  &&
  (candidate 1 0 =n= 1)
  &&
  (candidate 1 1 =n= 2)
  &&
  (candidate 1 2 =n= 3)
  &&
  (candidate 2 1 =n= 3)
  &&
  (candidate 2 2 =n= 4)
  (* etc. *)
  .

Fixpoint add_v1 (i j : nat) : nat :=
  match i with
    | O => j
    | S i' => S (add_v1 i' j)
  end.

Compute (test_add add_v1).

Fixpoint add_v2 (i j : nat) : nat :=
  match i with
    | O => j
    | S i' => add_v2 i' (S j)
  end.

Compute (test_add add_v2).

Definition add_v3 (i j : nat) : nat :=
  let fix visit n :=
    match n with
      | O => j
      | S n' => S (visit n')
    end
  in visit i.

Compute (test_add add_v3).

Definition test_mul (candidate: nat -> nat -> nat) : bool :=
  (candidate 0 0 =n= 0)
  &&
  (candidate 0 1 =n= 0)
  &&
  (candidate 1 0 =n= 0)
  &&
  (candidate 1 1 =n= 1)
  &&
  (candidate 1 2 =n= 2)
  &&
  (candidate 2 1 =n= 2)
  &&
  (candidate 2 2 =n= 4)
  &&
  (candidate 2 3 =n= 6)
(* etc. *)
.

Fixpoint mul_v1 (i j : nat) : nat :=
  match i with
  | O =>
    O
  | S i' =>
    match j with
    | O =>
      O
    | S j' =>
      i + (mul_v1 i j')
    end
  end.

Compute (test_mul mul_v1).

Definition test_power (candidate: nat -> nat -> nat) : bool :=
  (candidate 0 0 =n= 1)
  &&
  (candidate 1 0 =n= 1)
  &&
  (candidate 2 0 =n= 1)
  &&
  (candidate 0 1 =n= 0)
  &&
  (candidate 0 2 =n= 0)
  &&
  (candidate 0 10 =n= 0)
  &&
  (candidate 1 1 =n= 1)
  &&
  (candidate 1 2 =n= 1)
  &&
  (candidate 1 10 =n= 1)
  &&
  (candidate 2 1 =n= 2)
  &&
  (candidate 2 2 =n= 4)
  &&
  (candidate 2 10 =n= 1024)
  (* etc. *)
  .

  Fixpoint power_v1 (x n : nat) : nat :=
    match n with
    | O =>
      1
    | S n' =>
      match x with
      | O =>
        O
      | S x' =>
        mul_v1 x (power_v1 x n')
      end
    end.

Compute (test_power power_v1).

Definition test_fac (candidate: nat -> nat) : bool :=
  (candidate 0 =n= 1)
  &&
  (candidate 1 =n= 1)
  &&
  (candidate 2 =n= 2)
  &&
  (candidate 3 =n= 6)
  &&
  (candidate 4 =n= 24)
  &&
  (candidate 5 =n= 120)
  &&
  (candidate 6 =n= 720)
  (* etc. *) .

Fixpoint fac_v1 (n : nat) : nat :=
  match n with
  | O =>
    1
  | S n'=>
    n * (fac_v1 n')
  end.

Compute (test_fac fac_v1).

Definition test_fib (candidate: nat -> nat): bool :=
  (candidate 0 =n= 0)
  &&
  (candidate 1 =n= 1)
  &&
  (candidate 2 =n= 1)
  &&
  (candidate 3 =n= 2)
  &&
  (candidate 4 =n= 3)
  &&
  (candidate 5 =n= 5)
  &&
  (candidate 6 =n= 8)
  (* etc. *)
.

Fixpoint fib_v1 (n : nat) : nat :=
  match n with
  | O =>
    O
  | S n' =>
    match n' with
    | O =>
      1
    | S n'' =>
      fib_v1 (n'') + fib_v1 (n')
    end
  end.

Compute (test_fib fib_v1).

Fixpoint fibfib (n : nat) : (nat * nat) :=
  match n with
  | O =>
   (O, S O)
  | S n' =>
    let (fib_n_minus_1, fib_n) := fibfib(n')
    in (fib_n, fib_n_minus_1 + fib_n)
  end.

Fixpoint fib_v2 (n : nat) : nat :=
  let (fib_n, fib_n_plus_1) := fibfib n
  in fib_n.

Compute (test_fib fib_v2).

Definition test_even (candidate: nat -> bool) : bool :=
  (eqb (candidate 0) true)&&
  (eqb (candidate 1) false)&&
  (eqb (candidate 2) true)&&
  (eqb (candidate 3) false)&&
  (eqb (candidate 4) true)&&
  (eqb (candidate 5) false)&&
  (eqb (candidate 1000) true)&&
  (eqb (candidate 1001) false)
  (* etc. *)
  .
Fixpoint even_v1 (n : nat) : bool :=
    match n with
    | O =>
      true
    | S n' =>
      negb (even_v1 n')
    end.

  Compute (test_even even_v1).

Definition test_odd (candidate: nat -> bool) : bool :=
  (eqb (candidate 0) false)&&
  (eqb (candidate 1) true)&&
  (eqb (candidate 2) false)&&
  (eqb (candidate 3) true)&&
  (eqb (candidate 4) false)&&
  (eqb (candidate 5) true)&&
  (eqb (candidate 1000) false)&&
  (eqb (candidate 1001) true)
  (* etc. *)
  .

Fixpoint odd_v1 (n : nat) : bool :=
  match n with
    | O =>
      false
    | S n' =>
      negb (odd_v1 n')
    end.

Compute (test_odd odd_v1).

(* ***** *)

Inductive list_nat : Type :=
  nil_nat : list_nat
| cons_nat : nat -> list_nat -> list_nat.

Fixpoint beq_list_nat (xs ys : list_nat) : bool :=
  match xs with
    nil_nat =>
    match ys with
      nil_nat =>
      true
    | cons_nat y ys' =>
      false
    end
  | cons_nat x xs' =>
    match ys with
      nil_nat =>
      false
    | cons_nat y ys' =>
      (x =n= y) && beq_list_nat xs' ys'
    end
  end.

Notation "A =ns= B" :=
  (beq_list_nat A B) (at level 70, right associativity).

(* ***** *)

Definition test_append (candidate: list_nat -> list_nat -> list_nat) : bool :=
  (candidate nil_nat nil_nat =ns= nil_nat)
  &&
  (candidate nil_nat (cons_nat 10 nil_nat) =ns= (cons_nat 10 nil_nat))
  &&
  (candidate (cons_nat 1 nil_nat) (cons_nat 10 nil_nat) =ns= (cons_nat 1 (cons_nat 10 nil_nat)))
  (* etc. *)
  .

Fixpoint append_v0 (xs ys : list_nat) : list_nat :=
  match xs with
  | nil_nat =>
    ys
  | cons_nat x xs' =>
    cons_nat x (append_v0 xs' ys)
  end.

Compute (test_append append_v0).

(* ***** *)

Definition test_length (candidate: list_nat -> nat) : bool :=
  (candidate nil_nat =n= 0)
  &&
  (candidate (cons_nat 1 nil_nat) =n= 1)
  &&
  (candidate (cons_nat 2 (cons_nat 1 nil_nat)) =n= 2)
  (* etc. *)
  .

Fixpoint length_v0 (xs : list_nat) : nat :=
  match xs with
  | nil_nat =>
    0
  | cons_nat x xs' =>
    S (length_v0 xs')
  end.

Compute (test_length length_v0).

(* ***** *)

Definition test_reverse (candidate : list_nat -> list_nat) : bool :=
 (candidate nil_nat =ns= nil_nat) &&
  (candidate (cons_nat 0 nil_nat) =ns= (cons_nat 0 nil_nat)) &&
  (candidate (cons_nat 0 (cons_nat 1 nil_nat)) =ns= (cons_nat 1 (cons_nat 0 nil_nat))) &&
  (candidate (cons_nat 0 (cons_nat 1 (cons_nat 2 nil_nat))) =ns= (cons_nat 2 (cons_nat 1 (cons_nat 0 nil_nat))))
  (* etc. *)
.

Fixpoint reverse_v0 (xs : list_nat) : list_nat :=
   match xs with
  | nil_nat =>
    nil_nat
  | cons_nat x xs' =>
    append_v0 (reverse_v0 xs') (cons_nat x nil_nat)
  end.

Compute (test_reverse reverse_v0).

(* ***** *)

Inductive list_nat_nat : Type :=
  nil_nat_nat : list_nat_nat
| cons_nat_nat : nat -> nat -> list_nat_nat -> list_nat_nat.

Fixpoint beq_list_nat_nat (xs ys : list_nat_nat) : bool :=
  match xs with
  | nil_nat_nat =>
    match ys with
    | nil_nat_nat =>
      true
    | cons_nat_nat y1 y2 ys' =>
      false
     end
  | cons_nat_nat x1 x2 xs' =>
    match ys with
    | nil_nat_nat =>
      false
    | cons_nat_nat y1 y2 ys' =>
      (x1 =n= y1) && (x2 =n= y2) && beq_list_nat_nat xs' ys'
    end
  end.

Notation "A =nns= B" :=
  (beq_list_nat_nat A B) (at level 70, right associativity).

(* ***** *)

Inductive option_list_nat_nat :=
| None_list_nat_nat : option_list_nat_nat
| Some_list_nat_nat : list_nat_nat -> option_list_nat_nat.

Definition beq_option_list_nat_nat (o1 o2 : option_list_nat_nat) : bool :=
  match o1 with
  | None_list_nat_nat =>
    match o2 with
    | None_list_nat_nat =>
      true
    | Some_list_nat_nat nn2s =>
      false
    end
  | Some_list_nat_nat nn1s =>
    match o2 with
    | None_list_nat_nat =>
      false
    | Some_list_nat_nat nn2s =>
      beq_list_nat_nat nn1s nn2s
    end
   end.

Notation "A =onns= B" :=
  (beq_option_list_nat_nat A B) (at level 70, right associativity).

Definition test_append_nat_nat (candidate: list_nat_nat -> list_nat_nat -> list_nat_nat) : bool :=
  (candidate nil_nat_nat nil_nat_nat =nns= nil_nat_nat)
  &&
  (candidate nil_nat_nat (cons_nat_nat 10 20 nil_nat_nat) =nns= (cons_nat_nat 10 20 nil_nat_nat))
  &&
  (candidate (cons_nat_nat 10 20 nil_nat_nat) (cons_nat_nat 30 40 nil_nat_nat) =nns= (cons_nat_nat 10 20 (cons_nat_nat 30 40 nil_nat_nat)))
  (* etc. *)
  .

Fixpoint append_nat_nat_v0 (xs ys : list_nat_nat) : list_nat_nat :=
  match xs with
  | nil_nat_nat =>
    ys
  | cons_nat_nat x1 x2 xs' =>
    cons_nat_nat x1 x2 (append_nat_nat_v0 xs' ys)
  end.

  Compute (test_append_nat_nat append_nat_nat_v0).

Definition test_scalar_product (candidate : list_nat -> list_nat -> option_list_nat_nat) : bool :=
  ((candidate (cons_nat 1 nil_nat)
              (cons_nat 10 (cons_nat 20 nil_nat)))
   =onns=
   None_list_nat_nat)
  &&
  ((candidate (cons_nat 1 (cons_nat 2 nil_nat))
              (cons_nat 10 nil_nat))
   =onns=
   None_list_nat_nat)
  &&
  ((candidate (cons_nat 1 (cons_nat 2 nil_nat))
              (cons_nat 10 (cons_nat 20 nil_nat)))
   =onns=
   (Some_list_nat_nat (cons_nat_nat 1 10 (cons_nat_nat 2 20 nil_nat_nat))))
  (* etc. *)
.

(* This returns a reversed scalar product.*)
(*
Fixpoint scalar_product_v0 (xs_init ys_init : list_nat) : option_list_nat_nat :=
  let fix visit xs ys a:=
      match xs with
      | nil_nat =>
        match ys with
        | nil_nat =>
          Some_list_nat_nat a
        | cons_nat y ys' =>
          None_list_nat_nat
        end
      | cons_nat x xs' =>
        match ys with
        | nil_nat =>
          None_list_nat_nat
        | cons_nat y ys' =>
          visit  xs' ys' (cons_nat_nat x y a)
        end
      end
  in visit xs_init ys_init nil_nat_nat.

  Compute (test_scalar_product scalar_product_v0).

*)

Fixpoint scalar_product_v2 (xs_init ys_init: list_nat) : option_list_nat_nat :=
  let fix visit xs ys a:=
      match xs with
      | nil_nat =>
        match ys with
        | nil_nat =>
          Some_list_nat_nat a
        | cons_nat y ys' =>
          None_list_nat_nat
        end
      | cons_nat x xs' =>
        match ys with
        | nil_nat =>
          None_list_nat_nat
        | cons_nat y ys' =>
        visit xs' ys' (append_nat_nat_v0 a (cons_nat_nat x y nil_nat_nat))
        end
      end
  in visit xs_init ys_init nil_nat_nat.

Compute test_scalar_product scalar_product_v2.

(*Without accumulator: assumes xs ys are same length OR returns nil_nat when xs and ys are of different length, instead of option type*)
Fixpoint scalar_product_v1 (xs ys: list_nat) : list_nat_nat :=
  match xs with
  | nil_nat =>
    nil_nat_nat
  | cons_nat x xs' =>
    match ys with
    | nil_nat =>
      nil_nat_nat
    | cons_nat y ys' =>
      cons_nat_nat x y (scalar_product_v1 xs' ys')
    end
  end.

Definition test_convolve (candidate : list_nat -> list_nat -> option_list_nat_nat) : bool :=
  ((candidate (cons_nat 1 nil_nat)
              (cons_nat 10 (cons_nat 20 nil_nat)))
   =onns=
   None_list_nat_nat)
  &&
  ((candidate (cons_nat 1 (cons_nat 2 nil_nat))
              (cons_nat 10 nil_nat))
   =onns=
   None_list_nat_nat)
  &&
  ((candidate (cons_nat 1 (cons_nat 2 nil_nat))
              (cons_nat 10 (cons_nat 20 nil_nat)))
   =onns=
   (Some_list_nat_nat (cons_nat_nat 1 20 (cons_nat_nat 2 10 nil_nat_nat))))
  (* etc. *)
  .

  (*Attempted there-and-back-again. Didn't work.*)

(*
Fixpoint convolve_taba (xs ys : list_nat) : list_nat_nat :=
  let fix walk xs k :=
      match xs with
      | nil_nat =>
        k ys nil_nat_nat
      | cons_nat x xs' =>
        let back_again ys r:=
        match ys with
        | nil_nat =>
          nil_nat
        | cons_nat y ys' =>
          k ys' (cons_nat_nat x y r)
        end
        in walk xs' back_again
      end
  in walk xs (fun (n :list_nat) (m : list_nat_nat) => m).
*)
 (* Compute (test_convolve convolve_taba).*)

Fixpoint convolve_v0 (xs ys : list_nat) : option_list_nat_nat :=
    scalar_product_v2 xs (reverse_v0 ys).

  Compute (test_convolve convolve_v0).

(* ********** *)

Inductive binary_tree : Type :=
  Leaf : nat -> binary_tree
| Node : binary_tree -> binary_tree -> binary_tree.

Fixpoint beq_binary_tree (t1 t2 : binary_tree) : bool :=
  match t1 with
    Leaf n1 =>
    match t2 with
      Leaf n2 =>
      n1 =n= n2
    | Node t21 t22 =>
      false
    end
  | Node t11 t12 =>
    match t2 with
      Leaf n2 =>
      false
    | Node t21 t22 =>
      (beq_binary_tree t11 t21) && (beq_binary_tree t12 t22)
    end
  end.

Notation "A =bt= B" :=
  (beq_binary_tree A B) (at level 70, right associativity).

(* ***** *)

Definition test_number_of_leaves (candidate: binary_tree -> nat) : bool :=
  (candidate (Leaf 1) =n= 1)
  &&
  (candidate (Node (Leaf 1) (Leaf 2)) =n= 2)
  (* etc. *)
  .

Fixpoint number_of_leaves_v0 (t : binary_tree) : nat :=
  match t with
    Leaf n =>
    1
  | Node t1 t2 =>
    (number_of_leaves_v0 t1) + (number_of_leaves_v0 t2)
  end.

Compute (test_number_of_leaves number_of_leaves_v0).

(* ***** *)

Definition test_number_of_nodes (candidate: binary_tree -> nat) : bool :=
  (candidate (Leaf 1) =n= 0)
  &&
  (candidate (Node (Leaf 1) (Leaf 2)) =n= 1)&&
  (candidate (Node (Leaf 3) ((Node (Leaf 1) (Leaf 2)))) =n= 2)
  (* etc. *)
  .

Fixpoint number_of_nodes_v0 (t : binary_tree) : nat :=
  match t with
    Leaf n =>
    0
  | Node t1 t2 =>
    1 + (number_of_nodes_v0 t1) + (number_of_nodes_v0 t2)
   end.

Compute (test_number_of_nodes number_of_nodes_v0).

(* ***** *)

Definition test_smallest_leaf (candidate: binary_tree -> nat) : bool :=
  (candidate (Leaf 0) =n= 0)&&
  (candidate (Leaf 1) =n= 1)&&
  (candidate (Node (Leaf 1) (Leaf 2)) =n= 1)&&
  (candidate (Node (Leaf 3) ((Node (Leaf 1) (Leaf 2)))) =n= 1)&&
  (candidate (Node (Node (Leaf 3) ((Node (Leaf 1) (Leaf 2)))) (Leaf 0)) =n= 0)
  (* etc. *)
  .

Fixpoint smallest_leaf_v0 (t : binary_tree) : nat :=
      match t with
      | Leaf n =>
        n
      | Node t1 t2 =>
        min (smallest_leaf_v0 t1) (smallest_leaf_v0 t2)
      end.

Compute (test_smallest_leaf smallest_leaf_v0).

(* ***** *)

Definition test_weight (candidate: binary_tree -> nat) : bool :=
  (candidate (Leaf 0)
   =n= 0)
  &&
  (candidate (Node (Leaf 1) (Leaf 10))
   =n= 11)
  &&
  (candidate (Node (Leaf 1) (Node (Leaf 10) (Leaf 100)))
   =n= 111)
  &&
  (candidate (Node (Node (Leaf 1) (Leaf 10)) (Leaf 100))
   =n= 111)
  &&
  (candidate (Node (Node (Leaf 1) (Leaf 10)) (Node (Leaf 100) (Leaf 1000)))
   =n= 1111)
  (* etc. *)
  .

Fixpoint weight_v0 (t : binary_tree) : nat :=
  match t with
  | Leaf n =>
    n
  | Node t1 t2 =>
    weight_v0 t1 + weight_v0 t2
  end.

Compute (test_weight weight_v0).

(* ***** *)

Definition test_height (candidate: binary_tree -> nat) : bool :=
  (candidate (Leaf 1)
   =n= 0)
  &&
  (candidate (Node (Leaf 1) (Leaf 10))
   =n= 1)
  &&
  (candidate (Node (Leaf 1) (Node (Leaf 10) (Leaf 100)))
   =n= 2)
  &&
  (candidate (Node (Node (Leaf 1) (Leaf 10)) (Leaf 100))
   =n= 2)
  &&
  (candidate (Node (Node (Leaf 1) (Leaf 10)) (Node (Leaf 100) (Leaf 1000)))
   =n= 2)&&
  (candidate (Node (Node (Node (Leaf 1) (Leaf 2)) (Leaf 10)) (Node (Leaf 100) (Leaf 1000)))
   =n= 3)
  (* etc. *)
  .

Fixpoint height_v0 (t : binary_tree) : nat :=
  match t with
  | Leaf n =>
    0
  | Node t1 t2 =>
    S (max (height_v0 t1) (height_v0 t2))
  end.

Compute (test_height height_v0).

(* ***** *)
Definition test_width (candidate: binary_tree -> nat) : bool :=
   (candidate (Leaf 1)
   =n= 1)
  &&
  (candidate (Node (Leaf 1) (Leaf 10))
   =n= 2)
  &&
  (candidate (Node (Leaf 1) (Node (Leaf 10) (Leaf 100)))
   =n= 2)
  &&
  (candidate (Node (Node (Leaf 1) (Leaf 10)) (Leaf 100))
   =n= 2)
  &&
  (candidate (Node (Node (Leaf 1) (Leaf 10)) (Node (Leaf 100) (Leaf 1000)))
   =n= 4)&&
  (candidate (Node (Node (Node (Leaf 1) (Leaf 2)) (Leaf 10)) (Node (Leaf 100) (Leaf 1000)))
   =n= 4)
  (* etc. *)
  .
Fixpoint get_width_v0 (t : binary_tree) (n : nat) : nat :=
  match n with
  | O => (*if n = 0*)
    O
  | S n' =>
    match n' with
    | O => (*if n = 1*)
      match t with
      | Leaf n =>
        S O
      | Node t1 t2 =>
        S O
      end  (*return 1 no matter what, since the width at level 1 is always 1*)
    | S n'' => (*if n > 1*)
      match t with
      | Leaf n => (*no more trees to traverse, i.e. there are no trees that add to the width at level n*)
        O
      | Node t1 t2 =>
        (get_width_v0 t1 n') + (get_width_v0 t2 n')
      end
    end
  end.

Fixpoint width_v0 (t : binary_tree) : nat :=
  let l := S (height_v0 t) (*height + 1 = number of levels*)
  in let fix visit l:=
         match l with
         | O =>
           O
         | S l' =>
           match l' with
           | O => (*if h = 1*)
             S O (*then width = 1*)
           | S l'' => (*if h > 1*)
            max (get_width_v0 t l) (visit l')
           end
         end
     in visit l.

Compute (test_width width_v0).

(* ***** *)

Definition test_flatten (candidate: binary_tree -> list_nat) : bool :=
  (candidate (Leaf 1) =ns= (cons_nat 1 nil_nat))
  &&
  (candidate (Node (Leaf 1) (Leaf 2)) =ns= (cons_nat 1 (cons_nat 2 nil_nat)))
  (* etc. *)
  .

Fixpoint flatten_v0 (t : binary_tree) : list_nat :=
  match t with
  | Leaf n =>
    cons_nat n nil_nat
  | Node t1 t2 =>
    append_v0 (flatten_v0 t1) (flatten_v0 t2)
  end.

Compute (test_flatten flatten_v0).

(* ***** *)

Definition test_swap (candidate: binary_tree -> binary_tree) : bool :=
  (candidate (Leaf 1) =bt= (Leaf 1))
  &&
  (candidate (Node (Leaf 1) (Leaf 2)) =bt= (Node (Leaf 2) (Leaf 1)))
  (* etc. *)
  .

Fixpoint swap_v0 (t : binary_tree) : binary_tree :=
  match t with
  | Leaf n =>
    Leaf n
  | Node t1 t2 =>
    Node (swap_v0 t2) (swap_v0 t1)
  end.

Compute (test_swap swap_v0).

(* ********** *)

(* end of week-01_functional-programming-in-Coq.v *)


Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_tactics.
Require Import ProofCheckingEuclid.lemma_equalitysymmetric.

Section Euclid.

Context `{Ax:euclidean_neutral}.

Lemma lemma_collinear_ABC_BAC :
	forall A B C,
	Col A B C ->
	Col B A C.
Proof.
	intros A B C.
	intros Col_A_B_C.

	unfold Col.

	unfold Col in Col_A_B_C.
	destruct Col_A_B_C as [eq_A_B | [eq_A_C | [eq_B_C | [BetS_B_A_C | [BetS_A_B_C | BetS_A_C_B]]]]].
	{
		(* case eq_A_B *)
		pose proof (lemma_equalitysymmetric _ _ eq_A_B) as eq_B_A.
		one_of_disjunct eq_B_A.
	}
	{
		(* case eq_A_C *)
		one_of_disjunct eq_A_C.
	}
	{
		(* case eq_B_C *)
		one_of_disjunct eq_B_C.
	}
	{
		(* case BetS_B_A_C *)
		one_of_disjunct BetS_B_A_C.
	}
	{
		(* case BetS_A_B_C *)
		one_of_disjunct BetS_A_B_C.
	}
	{
		(* case BetS_A_C_B *)
		pose proof (axiom_betweennesssymmetry _ _ _ BetS_A_C_B) as BetS_B_C_A.
		one_of_disjunct BetS_B_C_A.
	}
Qed.

End Euclid.


Require Export premises.

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

Require Ring.
Require Field.

Module Type RealAxiomType.

Parameter ℝ : Set.

Declare Scope ℝ_scope.
Delimit Scope ℝ_scope with ℝ.
Local Open Scope ℝ_scope.

Parameter R0 : ℝ.
Parameter R1 : ℝ.

(** addition and multiplication *)
Parameter Rplus : ℝ -> ℝ -> ℝ.
Parameter Rmult : ℝ -> ℝ -> ℝ.

(** the corresponding inverse elements *)
Parameter Ropp : ℝ -> ℝ.
Parameter Rinv : ℝ -> ℝ.

Infix "+" := Rplus : ℝ_scope.
Infix "*" := Rmult : ℝ_scope.
Notation "- x" := (Ropp x) : ℝ_scope.
Notation "/ x" := (Rinv x) : ℝ_scope.

(** We'd like to be able to convert natural numbers to Rs, thereby allowing
    ourselves to write numbers like 0, 1, 2, 3... *)

Fixpoint N2R (n : nat) : ℝ :=
    match n with
    | O    => R0
    | 1    => R1
    | S n' => R1 + N2R n'
    end.
Coercion N2R : nat >-> ℝ.

(* ################################################################# *)
(** * The Field Equations *)

Axiom R1_neq_R0 : (1:ℝ) <> (0:ℝ).

(** Addition axioms *)

Axiom Rplus_comm : forall r1 r2 : ℝ, r1 + r2 = r2 + r1.

Axiom Rplus_assoc : forall r1 r2 r3 : ℝ, r1 + r2 + r3 = r1 + (r2 + r3).

Axiom Rplus_opp_r : forall r : ℝ, r + - r = 0.

Axiom Rplus_0_l : forall r : ℝ, 0 + r = r.

(** Multiplicative axioms *)

Axiom Rmult_comm : forall r1 r2:ℝ, r1 * r2 = r2 * r1.

Axiom Rmult_assoc : forall r1 r2 r3:ℝ, r1 * r2 * r3 = r1 * (r2 * r3).

Axiom Rinv_l : forall r:ℝ, r <> 0 -> / r * r = 1.

Axiom Rmult_1_l : forall r:ℝ, 1 * r = r.

Axiom Rmult_plus_distr_l : forall r1 r2 r3:ℝ, r1 * (r2 + r3) = r1 * r2 + r1 * r3.

(* ################################################################# *)
(** * Ordering *)

(** We also impose the standard ordering on real numbers, again by
    means of axioms *)

Parameter Rlt : ℝ -> ℝ -> Prop.

Infix "<" := Rlt : ℝ_scope.

Definition Rgt (r1 r2:ℝ) : Prop := r2 < r1.
Definition Rle (r1 r2:ℝ) : Prop := r1 < r2 \/ r1 = r2.
Definition Rge (r1 r2:ℝ) : Prop := Rgt r1 r2 \/ r1 = r2.

Infix "<=" := Rle : ℝ_scope.
Infix ">=" := Rge : ℝ_scope.
Infix ">" := Rgt : ℝ_scope.

Axiom total_order_T : forall r1 r2 : ℝ, {r1 < r2} + {r1 = r2} + {r1 > r2}.

Axiom Rlt_asym : forall r1 r2 : ℝ, r1 < r2 -> ~ r2 < r1.

Axiom Rlt_trans : forall r1 r2 r3 : ℝ, r1 < r2 -> r2 < r3 -> r1 < r3.

Axiom Rplus_lt_compat_l : forall r r1 r2 : ℝ, r1 < r2 -> r + r1 < r + r2.

Axiom Rmult_lt_compat_l : forall r r1 r2 : ℝ, 0 < r -> r1 < r2 -> r * r1 < r * r2.

(* ################################################################# *)
(** * Completeness *)

(** Not every field corresponds to the real numbers:
    Even the rational numbers (a strict subset of the reals) form a
    field. The last thing we need to "complete" the real numbers is
    the _completeness_ axiom. This states that every bounded set of
    real numbers has a least upper bound, which itself is a real
    number.

    As usual, we will express sets as functions of type [R -> Prop],
    indicating whether the given real number is a member of the
    set. *)

Definition is_upper_bound (E:ℝ -> Prop) (m:ℝ) := forall x:ℝ, E x -> x <= m.

Definition bound (E:ℝ -> Prop) := exists m : ℝ, is_upper_bound E m.

Definition is_lub (E:ℝ -> Prop) (m:ℝ) :=
    is_upper_bound E m /\ (forall b:ℝ, is_upper_bound E b -> m <= b).

Axiom
    completeness :
    forall E:ℝ -> Prop,
        bound E -> (exists x : ℝ, E x) -> { m:ℝ | is_lub E m }.

(* ################################################################# *)
(** * Computations *)

(* ================================================================= *)
(** ** The exp and log functions *)
Parameter RpowN : ℝ -> nat -> ℝ.
Infix "^" := RpowN : ℝ_scope.

Parameter Rsqrt : ℝ -> ℝ.
Notation "√ x" := (Rsqrt x) (at level 0) : ℝ_scope.

End RealAxiomType.

Module RealTheory (Export RealAxiom : RealAxiomType).

Open Scope ℝ_scope.

(** Other basic operations are given in terms of our declared ones *)

Definition Rminus (r1 r2:ℝ) : ℝ := r1 + - r2.
Definition Rdiv (r1 r2:ℝ) : ℝ := r1 * / r2.

Infix "-" := Rminus : ℝ_scope.
Infix "/" := Rdiv : ℝ_scope.

Lemma Rplus_0_r : forall r : ℝ, r + 0 = r.
Proof.
  (* WORKED IN CLASS *)
  intros r.
  rewrite Rplus_comm.
  apply Rplus_0_l.
Qed.

Lemma Rplus_opp_l : forall r, -r + r = 0.
Proof.
  (* WORKED IN CLASS *)
  intros r.
  rewrite Rplus_comm.
  apply Rplus_opp_r.
Qed.

Lemma Ropp_0 : -0 = 0.
Proof.
  rewrite <- (Rplus_0_l (-0)).
  rewrite Rplus_opp_r.
  reflexivity.
Qed.

Lemma Rplus_cancel_l : forall r1 r2 r3, r1 + r2 = r1 + r3 -> r2 = r3.
Proof.
  intros r1 r2 r3 H.
  rewrite <- Rplus_0_l.
  rewrite <- (Rplus_opp_l r1).
  rewrite Rplus_assoc.
  rewrite <- H.
  rewrite <- Rplus_assoc.
  rewrite Rplus_opp_l.
  rewrite Rplus_0_l.
  reflexivity.
Qed.

Lemma R0_unique : forall r1 r2, r1 + r2 = r1 -> r2 = 0.
Proof.
  intros r1 r2 H.
  rewrite <- Rplus_0_r in H.
  eapply Rplus_cancel_l.
  apply H.
Qed.

Lemma Rmult_0_r : forall r, r * 0 = 0.
Proof.
  (* WORKED IN CLASS *)
  intros r.
  apply (@R0_unique (r * 0)).
  rewrite <- Rmult_plus_distr_l.
  rewrite Rplus_0_l.
  reflexivity.
Qed.

Lemma Rmult_plus_distr_r : forall r1 r2 r3:ℝ, (r1 + r2) * r3 = r1 * r3 + r2 * r3.
Proof.
  (* WORKED IN CLASS *)
  intros r1 r2 r3.
  rewrite Rmult_comm.
  rewrite Rmult_plus_distr_l.
  rewrite !(@Rmult_comm r3).
  reflexivity.
Qed.

Lemma Rinv_r : forall r:ℝ, r <> 0 -> r * / r = 1.
Proof.
  (* WORKED IN CLASS *)
  intros. rewrite Rmult_comm.
  apply Rinv_l.
  assumption.
Qed.

(* ================================================================= *)
(** ** The Ring and Field tactics *)

(** We can tell Coq that R forms an algebraic _ring_ and _field_. *)

Export Ring.
Export Field.

Lemma R_Ring_Theory : ring_theory R0 R1 Rplus Rmult Rminus Ropp eq.
Proof.
  constructor.
  (* addition *)
  (* left identity *) apply Rplus_0_l.
  (* commutativity *) apply Rplus_comm.
  (* associativity *) intros; rewrite Rplus_assoc; easy.
  (* multiplication *)
  (* left identity *) apply Rmult_1_l.
  (* commutativity *) apply Rmult_comm.
  (* associativity *) intros; rewrite Rmult_assoc; easy.
  (* distributivity *) apply Rmult_plus_distr_r.
  (* sub = opp *) reflexivity.
  (* additive inverse *) apply Rplus_opp_r.
Defined.

Add Ring RRing : R_Ring_Theory.

Lemma R_Field_Theory : field_theory R0 R1 Rplus Rmult Rminus Ropp Rdiv Rinv eq.
Proof.
  constructor.
  (* ring axioms *) apply R_Ring_Theory.
  (* 0 <> 1 *) apply R1_neq_R0.
  (* div = inv *) reflexivity.
  (* multiplicative inverse *) apply Rinv_l.
Defined.

Add Field RField : R_Field_Theory.

End RealTheory.


From mathcomp.ssreflect Require Import all_ssreflect.
(*From mathcomp.ssreflect Require Import ssrnotation.*)
(*From mathcomp Require Import all_ssreflect.*)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Fixpoint has T (a : T -> bool) (s : seq T) : bool :=
  if s is x :: s' then a x || has a s' else false.
(*
Definition has_prop T (a : T -> bool) (x0 : T) (s : seq T)
  :=
    exists i, i < size s /\ a (nth x0 s i)
                           .*)

Definition is_true (b : bool) : Prop := b = true.
Coercion is_true : bool >-> Sortclass.

Definition bool_Prop_equiv (P : Prop) (b : bool) := b = true <-> P.

Lemma test_bool_Prop_equiv b P : bool_Prop_equiv P b -> P \/ ~P.
Proof.
  case: b; case => hlr hrl.
    by left; apply: hlr.
      by right => hP; move: (hrl hP).
Qed.

Inductive reflect (P : Prop) (b : bool) : Prop :=
| ReflectT (p : P) (e : b = true)
| ReflectF (np : ~P) (e : b = false).


(* -*- mode: coq; mode: visual-line -*- *)
Require Import Basics.
Require Import Types.
Require Import HSet.
Require Import HProp.
Require Import DProp.
Require Import Spaces.Nat.
Require Import Fibrations.
Require Import Factorization.
Require Import EquivalenceVarieties.
Require Import UnivalenceImpliesFunext.
Require Import Truncations.
Require Import Colimits.Quotient.
Import TrM.

Local Open Scope path_scope.
Local Open Scope nat_scope.

(** * Finite sets *)

(** ** Canonical finite sets *)

(** A *finite set* is a type that is merely equivalent to the canonical finite set determined by some natural number.  There are many equivalent ways to define the canonical finite sets, such as [{ k : nat & k < n}]; we instead choose a recursive one. *)

Fixpoint Fin (n : nat) : Type
  := match n with
       | 0 => Empty
       | S n => Fin n + Unit
     end.

Global Instance decidable_fin (n : nat)
: Decidable (Fin n).
Proof.
  destruct n as [|n]; try exact _.
  exact (inl (inr tt)).
Defined.

Global Instance decidablepaths_fin (n : nat)
: DecidablePaths (Fin n).
Proof.
  induction n as [|n IHn]; simpl; exact _.
Defined.

Global Instance contr_fin1 : Contr (Fin 1).
Proof.
  refine (contr_equiv' Unit (sum_empty_l Unit)^-1).
Defined.

Definition fin_empty (n : nat) (f : Fin n -> Empty) : n = 0.
Proof.
  destruct n; [ reflexivity | ].
  elim (f (inr tt)).
Defined.

Fixpoint fin_max (n : nat) : Fin n.+1 :=
  match n with
  | O => inr tt
  | S n' => inl (fin_max n')
  end.

Fixpoint fin_finS_inject (n : nat) : Fin n -> Fin n.+1 :=
  match n with
  | O => Empty_rec
  | S n' =>
    fun i : Fin (S n') =>
      match i with
      | inl i' => inl (fin_finS_inject n' i')
      | inr tt => inr tt
      end
  end.

Lemma isembedding_fin_finS_inject (n : nat) : IsEmbedding (fin_finS_inject n).
Proof.
  apply isembedding_isinj_hset.
  induction n.
  - intro i. elim i.
  - intros [] []; intro p.
    + f_ap. apply IHn. eapply path_sum_inl. exact p.
    + destruct u. elim (inl_ne_inr _ _ p).
    + destruct u. elim (inr_ne_inl _ _ p).
    + destruct u, u0; reflexivity.
Qed.

(** ** Transposition equivalences *)

(** To prove some basic facts about canonical finite sets, we need some standard automorphisms of them.  Here we define some transpositions and prove that they in fact do the desired things. *)

(** *** Swap the last two elements. *)

Definition fin_transpose_last_two (n : nat)
: Fin n.+2 <~> Fin n.+2
  := ((equiv_sum_assoc _ _ _)^-1)
       oE (1 +E (equiv_sum_symm _ _))
       oE (equiv_sum_assoc _ _ _).

Arguments fin_transpose_last_two : simpl nomatch.

Definition fin_transpose_last_two_last (n : nat)
: fin_transpose_last_two n (inr tt) = (inl (inr tt))
  := 1.

Definition fin_transpose_last_two_nextlast (n : nat)
: fin_transpose_last_two n (inl (inr tt)) = (inr tt)
  := 1.

Definition fin_transpose_last_two_rest (n : nat) (k : Fin n)
: fin_transpose_last_two n (inl (inl k)) = (inl (inl k))
  := 1.

(** *** Swap the last element with [k]. *)

Fixpoint fin_transpose_last_with (n : nat) (k : Fin n.+1)
: Fin n.+1 <~> Fin n.+1.
Proof.
  destruct k as [k|].
  - destruct n as [|n].
    + elim k.
    + destruct k as [k|].
      * refine ((fin_transpose_last_two n)
                  oE _
                  oE (fin_transpose_last_two n)).
        refine ((fin_transpose_last_with n (inl k)) +E 1).
      * apply fin_transpose_last_two.
  - exact (equiv_idmap _).
Defined.

Arguments fin_transpose_last_with : simpl nomatch.

Definition fin_transpose_last_with_last (n : nat) (k : Fin n.+1)
: fin_transpose_last_with n k (inr tt) = k.
Proof.
  destruct k as [k|].
  - induction n as [|n IH]; simpl.
    + elim k.
    + destruct k as [k|].
      * simpl. rewrite IH; reflexivity.
      * simpl. apply ap, ap, path_contr.
  - (** We have to destruct [n] since fixpoints don't reduce unless their argument is a constructor. *)
    destruct n; simpl.
    all:apply ap, path_contr.
Qed.

Definition fin_transpose_last_with_with (n : nat) (k : Fin n.+1)
: fin_transpose_last_with n k k = inr tt.
Proof.
  destruct k as [k|].
  - induction n as [|n IH]; simpl.
    + elim k.
    + destruct k as [|k]; simpl.
      * rewrite IH; reflexivity.
      * apply ap, path_contr.
  - destruct n; simpl.
    all:apply ap, path_contr.
Qed.

Definition fin_transpose_last_with_rest (n : nat)
           (k : Fin n.+1) (l : Fin n)
           (notk : k <> inl l)
: fin_transpose_last_with n k (inl l) = (inl l).
Proof.
  destruct k as [k|].
  - induction n as [|n IH]; simpl.
    1:elim k.
    destruct k as [k|]; simpl.
    { destruct l as [l|]; simpl.
      - rewrite IH.
        + reflexivity.
        + exact (fun p => notk (ap inl p)).
      - reflexivity. }
    { destruct l as [l|]; simpl.
      - reflexivity.
      - elim (notk (ap inl (ap inr (path_unit _ _)))). }
  - destruct n; reflexivity.
Qed.

Definition fin_transpose_last_with_last_other (n : nat) (k : Fin n.+1)
: fin_transpose_last_with n (inr tt) k = k.
Proof.
  destruct n; reflexivity.
Qed.

Definition fin_transpose_last_with_invol (n : nat) (k : Fin n.+1)
: fin_transpose_last_with n k o fin_transpose_last_with n k == idmap.
Proof.
  intros l.
  destruct l as [l|[]].
  - destruct k as [k|[]].
    { destruct (dec_paths k l) as [p|p].
      - rewrite p.
        rewrite fin_transpose_last_with_with.
        apply fin_transpose_last_with_last.
      - rewrite fin_transpose_last_with_rest;
          try apply fin_transpose_last_with_rest;
          exact (fun q => p (path_sum_inl _ q)). }
    + rewrite fin_transpose_last_with_last_other.
      apply fin_transpose_last_with_last_other.
  - rewrite fin_transpose_last_with_last.
    apply fin_transpose_last_with_with.
Qed.

(** ** Equivalences between canonical finite sets *)

(** To give an equivalence [Fin n.+1 <~> Fin m.+1] is equivalent to giving an element of [Fin m.+1] (the image of the last element) together with an equivalence [Fin n <~> Fin m].  More specifically, any such equivalence can be decomposed uniquely as a last-element transposition followed by an equivalence fixing the last element.  *)

(** Here is the uncurried map that constructs an equivalence [Fin n.+1 <~> Fin m.+1]. *)
Definition fin_equiv (n m : nat)
           (k : Fin m.+1) (e : Fin n <~> Fin m)
: Fin n.+1 <~> Fin m.+1
  := (fin_transpose_last_with m k)
       oE (e +E 1).

(** Here is the curried version that we will prove to be an equivalence. *)
Definition fin_equiv' (n m : nat)
: ((Fin m.+1) * (Fin n <~> Fin m)) -> (Fin n.+1 <~> Fin m.+1)
  := fun ke => fin_equiv n m (fst ke) (snd ke).

(** We construct its inverse and the two homotopies first as versions using homotopies without funext (similar to [ExtendableAlong]), then apply funext at the end. *)
Definition fin_equiv_hfiber (n m : nat) (e : Fin n.+1 <~> Fin m.+1)
: { kf : (Fin m.+1) * (Fin n <~> Fin m) & fin_equiv' n m kf == e }.
Proof.
  simpl in e.
  refine (equiv_sigma_prod _ _).
  recall (e (inr tt)) as y eqn:p.
  assert (p' := (moveL_equiv_V _ _ p)^).
  exists y.
  destruct y as [y|[]].
  + simple refine (equiv_unfunctor_sum_l
              (fin_transpose_last_with m (inl y) oE e)
              _ _ ; _).
    { intros a. ev_equiv.
      assert (q : inl y <> e (inl a))
        by exact (fun z => inl_ne_inr _ _ (equiv_inj e (z^ @ p^))).
      set (z := e (inl a)) in *.
      destruct z as [z|[]].
      - rewrite fin_transpose_last_with_rest;
        try exact tt; try assumption.
      - rewrite fin_transpose_last_with_last; exact tt. }
    { intros []. ev_equiv.
      rewrite p.
      rewrite fin_transpose_last_with_with; exact tt. }
    intros x. unfold fst, snd; ev_equiv. simpl.
    destruct x as [x|[]]; simpl.
    * rewrite unfunctor_sum_l_beta.
      apply fin_transpose_last_with_invol.
    * refine (fin_transpose_last_with_last _ _ @ p^).
  + simple refine (equiv_unfunctor_sum_l e _ _ ; _).
    { intros a.
      destruct (is_inl_or_is_inr (e (inl a))) as [l|r].
      - exact l.
      - assert (q := inr_un_inr (e (inl a)) r).
        apply moveR_equiv_V in q.
        assert (s := q^ @ ap (e^-1 o inr) (path_unit _ _) @ p').
        elim (inl_ne_inr _ _ s). }
    { intros []; exact (p^ # tt). }
    intros x. unfold fst, snd; ev_equiv. simpl.
    destruct x as [a|[]].
    * rewrite fin_transpose_last_with_last_other.
      apply unfunctor_sum_l_beta.
    * simpl.
      rewrite fin_transpose_last_with_last.
      symmetry; apply p.
Qed.

Definition fin_equiv_inv (n m : nat) (e : Fin n.+1 <~> Fin m.+1)
: (Fin m.+1) * (Fin n <~> Fin m)
  := (fin_equiv_hfiber n m e).1.

Definition fin_equiv_issect (n m : nat) (e : Fin n.+1 <~> Fin m.+1)
: fin_equiv' n m (fin_equiv_inv n m e) == e
  := (fin_equiv_hfiber n m e).2.

Definition fin_equiv_inj_fst (n m : nat)
           (k l : Fin m.+1) (e f : Fin n <~> Fin m)
: (fin_equiv n m k e == fin_equiv n m l f) -> (k = l).
Proof.
  intros p.
  refine (_ @ p (inr tt) @ _); simpl;
  rewrite fin_transpose_last_with_last; reflexivity.
Qed.

Definition fin_equiv_inj_snd (n m : nat)
           (k l : Fin m.+1) (e f : Fin n <~> Fin m)
: (fin_equiv n m k e == fin_equiv n m l f) -> (e == f).
Proof.
  intros p.
  intros x. assert (q := p (inr tt)); simpl in q.
  rewrite !fin_transpose_last_with_last in q.
  rewrite <- q in p; clear q l.
  exact (path_sum_inl _
           (equiv_inj (fin_transpose_last_with m k) (p (inl x)))).
Qed.

(** Now it's time for funext. *)
Global Instance isequiv_fin_equiv `{Funext} (n m : nat)
: IsEquiv (fin_equiv' n m).
Proof.
  refine (isequiv_pathsplit 0 _); split.
  - intros e; exists (fin_equiv_inv n m e).
    apply path_equiv, path_arrow, fin_equiv_issect.
  - intros [k e] [l f]; simpl.
    refine (_ , fun _ _ => tt).
    intros p; refine (_ ; path_ishprop _ _).
    apply (ap equiv_fun) in p.
    apply ap10 in p.
    apply path_prod'.
    + refine (fin_equiv_inj_fst n m k l e f p).
    + apply path_equiv, path_arrow.
      refine (fin_equiv_inj_snd n m k l e f p).
Qed.

Definition equiv_fin_equiv `{Funext} (n m : nat)
: ((Fin m.+1) * (Fin n <~> Fin m)) <~> (Fin n.+1 <~> Fin m.+1)
  := Build_Equiv _ _ (fin_equiv' n m) _.

(** In particular, this implies that if two canonical finite sets are equivalent, then their cardinalities are equal. *)
Definition nat_eq_fin_equiv (n m : nat)
: (Fin n <~> Fin m) -> (n = m).
Proof.
  revert m; induction n as [|n IHn]; induction m as [|m IHm]; intros e.
  - exact idpath.
  - elim (e^-1 (inr tt)).
  - elim (e (inr tt)).
  - refine (ap S (IHn m _)).
    exact (snd (fin_equiv_inv n m e)).
Qed.

(** ** Definition of general finite sets *)

Class Finite (X : Type) :=
  { fcard : nat ;
    merely_equiv_fin : merely (X <~> Fin fcard) }.

Arguments fcard X {_}.
Arguments merely_equiv_fin X {_}.

Definition issig_finite X
: { n : nat & merely (X <~> Fin n) } <~> Finite X.
Proof.
  issig.
Defined.

(** Note that the sigma over cardinalities is not truncated.  Nevertheless, because canonical finite sets of different cardinalities are not isomorphic, being finite is still an hprop.  (Thus, we could have truncated the sigma and gotten an equivalent definition, but it would be less convenient to reason about.) *)
Global Instance ishprop_finite X
: IsHProp (Finite X).
Proof.
  refine (trunc_equiv' _ (issig_finite X)).
  apply ishprop_sigma_disjoint; intros n m Hn Hm.
  strip_truncations.
  refine (nat_eq_fin_equiv n m (Hm oE Hn^-1)).
Defined.

(** ** Preservation of finiteness by equivalences *)

Definition finite_equiv X {Y} (e : X -> Y) `{IsEquiv X Y e}
: Finite X -> Finite Y.
Proof.
  intros ?.
  refine (Build_Finite Y (fcard X) _).
  assert (f := merely_equiv_fin X); strip_truncations.
  apply tr.
  exact (equiv_compose f e^-1).
Defined.

Definition finite_equiv' X {Y} (e : X <~> Y)
: Finite X -> Finite Y
  := finite_equiv X e.

Corollary finite_equiv_equiv X Y
: (X <~> Y) -> (Finite X <~> Finite Y).
Proof.
  intros ?; apply equiv_iff_hprop; apply finite_equiv';
    [ assumption | symmetry; assumption ].
Defined.

Definition fcard_equiv {X Y} (e : X -> Y) `{IsEquiv X Y e}
           `{Finite X} `{Finite Y}
: fcard X = fcard Y.
Proof.
  transitivity (@fcard Y (finite_equiv X e _)).
  - reflexivity.
  - exact (ap (@fcard Y) (path_ishprop _ _)).
Defined.

Definition fcard_equiv' {X Y} (e : X <~> Y)
           `{Finite X} `{Finite Y}
: fcard X = fcard Y
  := fcard_equiv e.

(** ** Simple examples of finite sets *)

(** Canonical finite sets are finite *)
Global Instance finite_fin n : Finite (Fin n)
  := Build_Finite _ n (tr (equiv_idmap _)).

(** This includes the empty set. *)
Global Instance finite_empty : Finite Empty
  := finite_fin 0.

(** The unit type is finite, since it's equivalent to [Fin 1]. *)
Global Instance finite_unit : Finite Unit.
Proof.
  refine (finite_equiv' (Fin 1) _ _); simpl.
  apply sum_empty_l.
Defined.

(** Thus, any contractible type is finite. *)
Global Instance finite_contr X `{Contr X} : Finite X
  := finite_equiv Unit equiv_contr_unit^-1 _.

(** Any decidable hprop is finite, since it must be equivalent to [Empty] or [Unit]. *)
Definition finite_decidable_hprop X `{IsHProp X} `{Decidable X}
: Finite X.
Proof.
  destruct (dec X) as [x|nx].
  - assert (Contr X) by exact (contr_inhabited_hprop X x).
    exact _.
  - refine (finite_equiv Empty nx^-1 _).
Defined.

Hint Immediate finite_decidable_hprop : typeclass_instances.

(** It follows that the propositional truncation of any finite set is finite. *)
Global Instance finite_merely X {fX : Finite X}
: Finite (merely X).
Proof.
  (** As in decidable_finite_hprop, we case on cardinality first to avoid needing funext. *)
  destruct fX as [[|n] e]; refine (finite_decidable_hprop _).
  - right.
    intros x; strip_truncations; exact (e x).
  - left.
    strip_truncations; exact (tr (e^-1 (inr tt))).
Defined.

(** Finite sets are closed under path-spaces. *)
Global Instance finite_paths {X} `{Finite X} (x y : X)
: Finite (x = y).
Proof.
  (** If we assume [Funext], then typeclass inference produces this automatically, since [X] has decidable equality and (hence) is a set, so [x=y] is a decidable hprop.  But we can also deduce it without funext, since [Finite] is an hprop even without funext. *)
  assert (e := merely_equiv_fin X).
  strip_truncations.
  refine (finite_equiv _ (ap e)^-1 _).
  apply finite_decidable_hprop; exact _.
Defined.

(** Finite sets are also closed under successors. *)

Global Instance finite_succ X `{Finite X} : Finite (X + Unit).
Proof.
  refine (Build_Finite _ (fcard X).+1 _).
  pose proof (merely_equiv_fin X).
  strip_truncations; apply tr.
  refine (_ +E 1); assumption.
Defined.

Definition fcard_succ X `{Finite X}
: fcard (X + Unit) = (fcard X).+1
  := 1.

(** ** Decidability *)

(** Like canonical finite sets, finite sets have decidable equality. *)
Global Instance decidablepaths_finite `{Funext} X `{Finite X}
: DecidablePaths X.
Proof.
  assert (e := merely_equiv_fin X).
  strip_truncations.
  refine (decidablepaths_equiv _ e^-1 _).
Defined.

(** However, contrary to what you might expect, we cannot assert that "every finite set is decidable"!  That would be claiming a *uniform* way to select an element from every nonempty finite set, which contradicts univalence. *)

(** One thing we can prove is that any finite hprop is decidable. *)
Global Instance decidable_finite_hprop X `{IsHProp X} {fX : Finite X}
: Decidable X.
Proof.
  (** To avoid having to use [Funext], we case on the cardinality of [X] before stripping the truncation from its equivalence to [Fin n]; if we did things in the other order then we'd have to know that [Decidable X] is an hprop, which requires funext. *)
  destruct fX as [[|n] e].
  - right; intros x.
    strip_truncations; exact (e x).
  - left.
    strip_truncations; exact (e^-1 (inr tt)).
Defined.

(** It follows that if [X] is finite, then its propositional truncation is decidable. *)
Global Instance decidable_merely_finite X {fX : Finite X}
: Decidable (merely X).
Proof.
  exact _.
Defined.

(** From this, it follows that any finite set is *merely* decidable. *)
Definition merely_decidable_finite X `{Finite X}
: merely (Decidable X).
Proof.
  apply O_decidable; exact _.
Defined.

(** ** Induction over finite sets *)

(** Most concrete applications of this don't actually require univalence, but the general version does.  For this reason the general statement is less useful (and less used in the sequel) than it might be. *)
Definition finite_ind_hprop `{Univalence}
           (P : forall X, Finite X -> Type)
           `{forall X (fX:Finite X), IsHProp (P X _)}
           (f0 : P Empty _)
           (fs : forall X (fX:Finite X), P X _ -> P (X + Unit)%type _)
           (X : Type) `{Finite X}
: P X _.
Proof.
  assert (e := merely_equiv_fin X).
  strip_truncations.
  assert (p := transportD Finite P (path_universe e^-1) _).
  refine (transport (P X) (path_ishprop _ _) (p _)).
  generalize (fcard X); intros n.
  induction n as [|n IH].
  - exact f0.
  - refine (transport (P (Fin n.+1)) (path_ishprop _ _) (fs _ _ IH)).
Defined.

(** ** The finite axiom of choice *)

Definition finite_choice {X} `{Finite X} (P : X -> Type)
: (forall x, merely (P x)) -> merely (forall x, P x).
Proof.
  intros f.
  assert (e := merely_equiv_fin X).
  strip_truncations.
  set (P' := P o e^-1).
  assert (f' := (fun x => f (e^-1 x)) : forall x, merely (P' x)).
  refine (Trunc_functor (X := forall x:Fin (fcard X), P' x) (-1) _ _).
  - intros g x; exact (eissect e x # g (e x)).
  - clearbody P'; clear f P e.
    generalize dependent (fcard X); intros n P f.
    induction n as [|n IH].
    + exact (tr (Empty_ind P)).
    + specialize (IH (P o inl) (f o inl)).
      assert (e := f (inr tt)).
      strip_truncations.
      exact (tr (sum_ind P IH (Unit_ind e))).
Defined.

(** ** Constructions on finite sets *)

(** Finite sets are closed under sums, products, function spaces, and equivalence spaces.  There are multiple choices we could make regarding how to prove these facts.  Since we know what the cardinalities ought to be in all cases (since we know how to add, multiply, exponentiate, and take factorials of natural numbers), we could specify those off the bat, and then reduce to the case of canonical finite sets.  However, it's more amusing to instead prove finiteness of these constructions by "finite-set induction", and then *deduce* that their cardinalities are given by the corresponding operations on natural numbers (because they satisfy the same recurrences). *)

(** *** Binary sums *)

Global Instance finite_sum X Y `{Finite X} `{Finite Y}
: Finite (X + Y).
Proof.
  assert (e := merely_equiv_fin Y).
  strip_truncations.
  refine (finite_equiv _ (functor_sum idmap e^-1) _).
  generalize (fcard Y); intros n.
  induction n as [|n IH].
  - refine (finite_equiv _ (sum_empty_r X)^-1 _).
  - refine (finite_equiv _ (equiv_sum_assoc X _ Unit) _).
Defined.

(** Note that the cardinality function [fcard] actually computes.  The same will be true of all the other proofs in this section, though we don't always verify it. *)
Goal fcard (Fin 3 + Fin 4) = 7.
  reflexivity.
Abort.

Definition fcard_sum X Y `{Finite X} `{Finite Y}
: fcard (X + Y) = (fcard X + fcard Y).
Proof.
  refine (_ @ nat_plus_comm _ _).
  assert (e := merely_equiv_fin Y).
  strip_truncations.
  refine (fcard_equiv' (1 +E e) @ _).
  refine (_ @ ap (fun y => (y + fcard X)) (fcard_equiv e^-1)).
  generalize (fcard Y); intros n.
  induction n as [|n IH].
  - refine (fcard_equiv (sum_empty_r X)^-1).
  - refine (fcard_equiv (equiv_sum_assoc _ _ _)^-1 @ _).
    exact (ap S IH).
Defined.

(** *** Binary products *)

Global Instance finite_prod X Y `{Finite X} `{Finite Y}
: Finite (X * Y).
Proof.
  assert (e := merely_equiv_fin Y).
  strip_truncations.
  refine (finite_equiv _ (functor_prod idmap e^-1) _).
  generalize (fcard Y); intros n.
  induction n as [|n IH].
  - refine (finite_equiv _ (prod_empty_r X)^-1 _).
  - refine (finite_equiv _ (sum_distrib_l X _ Unit)^-1 (finite_sum _ _)).
    refine (finite_equiv _ (prod_unit_r X)^-1 _).
Defined.

Definition fcard_prod X Y `{Finite X} `{Finite Y}
: fcard (X * Y) = fcard X * fcard Y.
Proof.
  assert (e := merely_equiv_fin X).
  strip_truncations.
  refine (fcard_equiv' (e *E 1) @ _).
  refine (_ @ ap (fun x => x * fcard Y) (fcard_equiv e^-1)).
  generalize (fcard X); intros n.
  induction n as [|n IH].
  - refine (fcard_equiv (prod_empty_l Y)).
  - refine (fcard_equiv (sum_distrib_r Y (Fin n) Unit) @ _).
    refine (fcard_sum _ _ @ _).
    simpl.
    refine (_ @ nat_plus_comm _ _).
    refine (ap011 plus _ _).
    + apply IH.
    + apply fcard_equiv', prod_unit_l.
  Defined.

(** *** Function types *)

(** Finite sets are closed under function types, and even dependent function types. *)

Global Instance finite_forall `{Funext} {X} (Y : X -> Type)
       `{Finite X} `{forall x, Finite (Y x)}
: Finite (forall x:X, Y x).
Proof.
  assert (e := merely_equiv_fin X).
  strip_truncations.
  simple refine (finite_equiv' _
            (equiv_functor_forall' (P := fun x => Y (e^-1 x)) e _) _); try exact _.
  { intros x; refine (equiv_transport _ _ _ (eissect e x)). }
  set (Y' := Y o e^-1); change (Finite (forall x, Y' x)).
  assert (forall x, Finite (Y' x)) by exact _; clearbody Y'; clear e.
  generalize dependent (fcard X); intros n Y' ?.
  induction n as [|n IH].
  - exact _.
  - refine (finite_equiv _ (equiv_sum_ind Y') _).
    apply finite_prod.
    + apply IH; exact _.
    + refine (finite_equiv _ (@Unit_ind (fun u => Y' (inr u))) _).
      refine (isequiv_unit_ind (Y' o inr)).
Defined.

Definition fcard_arrow `{Funext} X Y `{Finite X} `{Finite Y}
: fcard (X -> Y) = nat_exp (fcard Y) (fcard X).
Proof.
  assert (e := merely_equiv_fin X).
  strip_truncations.
  refine (fcard_equiv (functor_arrow e idmap)^-1 @ _).
  refine (_ @ ap (fun x => nat_exp (fcard Y) x) (fcard_equiv e)).
  generalize (fcard X); intros n.
  induction n as [|n IH].
  - reflexivity.
  - refine (fcard_equiv (equiv_sum_ind (fun (_:Fin n.+1) => Y))^-1 @ _).
    refine (fcard_prod _ _ @ _).
    apply (ap011 mult).
    + assumption.
    + refine (fcard_equiv (@Unit_ind (fun (_:Unit) => Y))^-1).
Defined.

(** [fcard] still computes, despite the funext: *)
Goal forall fs:Funext, fcard (Fin 3 -> Fin 4) = 64.
  reflexivity.
Abort.

(** *** Automorphism types (i.e. symmetric groups) *)

Global Instance finite_aut `{Funext} X `{Finite X}
: Finite (X <~> X).
Proof.
  assert (e := merely_equiv_fin X).
  strip_truncations.
  refine (finite_equiv _
            (equiv_functor_equiv e^-1 e^-1) _).
  generalize (fcard X); intros n.
  induction n as [|n IH].
  - exact _.
  - refine (finite_equiv _ (equiv_fin_equiv n n) _).
Defined.

Definition fcard_aut `{Funext} X `{Finite X}
: fcard (X <~> X) = factorial (fcard X).
Proof.
  assert (e := merely_equiv_fin X).
  strip_truncations.
  refine (fcard_equiv
            (equiv_functor_equiv e^-1 e^-1)^-1 @ _).
  generalize (fcard X); intros n.
  induction n as [|n IH].
  - reflexivity.
  - refine (fcard_equiv (equiv_fin_equiv n n)^-1 @ _).
    refine (fcard_prod _ _ @ _).
    apply ap011.
    + reflexivity.
    + assumption.
Defined.

(** [fcard] still computes: *)
Goal forall fs:Funext, fcard (Fin 4 <~> Fin 4) = 24.
  reflexivity.
Abort.

(** ** Finite sums of natural numbers *)

(** Perhaps slightly less obviously, finite sets are also closed under sigmas. *)

Global Instance finite_sigma {X} (Y : X -> Type)
       `{Finite X} `{forall x, Finite (Y x)}
: Finite { x:X & Y x }.
Proof.
  assert (e := merely_equiv_fin X).
  strip_truncations.
  refine (finite_equiv' _
            (equiv_functor_sigma (equiv_inverse e)
                                 (fun x (y:Y (e^-1 x)) => y)) _).
  (** Unfortunately, because [compose] is currently beta-expanded, [set (Y' := Y o e^-1)] doesn't change the goal. *)
  set (Y' := fun x => Y (e^-1 x)).
  assert (forall x, Finite (Y' x)) by exact _; clearbody Y'; clear e.
  generalize dependent (fcard X); intros n Y' ?.
  induction n as [|n IH].
  - refine (finite_equiv Empty pr1^-1 _).
  - refine (finite_equiv _ (equiv_sigma_sum (Fin n) Unit Y')^-1 _).
    apply finite_sum.
    + apply IH; exact _.
    + refine (finite_equiv _ (equiv_contr_sigma _)^-1 _).
Defined.

(** Amusingly, this automatically gives us a way to add up a family of natural numbers indexed by any finite set.  (We could of course also define such an operation directly, probably using [merely_ind_hset].) *)

Definition finplus {X} `{Finite X} (f : X -> nat) : nat
  := fcard { x:X & Fin (f x) }.

Definition fcard_sigma {X} (Y : X -> Type)
       `{Finite X} `{forall x, Finite (Y x)}
: fcard { x:X & Y x } = finplus (fun x => fcard (Y x)).
Proof.
  set (f := fun x => fcard (Y x)).
  set (g := fun x => merely_equiv_fin (Y x) : merely (Y x <~> Fin (f x))).
  apply finite_choice in g.
  strip_truncations.
  unfold finplus.
  refine (fcard_equiv' (equiv_functor_sigma' (equiv_idmap X) g)).
Defined.

(** The sum of a finite constant family is the product by its cardinality. *)
Definition finplus_const X `{Finite X} n
: finplus (fun x:X => n) = fcard X * n.
Proof.
  transitivity (fcard (X * Fin n)).
  - exact (fcard_equiv' (equiv_sigma_prod0 X (Fin n))).
  - exact (fcard_prod X (Fin n)).
Defined.

(** Closure under sigmas and paths also implies closure under hfibers. *)
Definition finite_hfiber {X Y} (f : X -> Y) (y : Y)
       `{Finite X} `{Finite Y}
: Finite (hfiber f y).
Proof.
  exact _.
Defined.

(** Therefore, the cardinality of the domain of a map between finite sets is the sum of the cardinalities of its hfibers. *)
Definition fcard_domain {X Y} (f : X -> Y) `{Finite X} `{Finite Y}
: fcard X = finplus (fun y => fcard (hfiber f y)).
Proof.
  refine (_ @ fcard_sigma (hfiber f)).
  refine (fcard_equiv' (equiv_fibration_replacement f)).
Defined.

(** In particular, the image of a map between finite sets is finite. *)
Definition finite_image
       {X Y} `{Finite X} `{Finite Y} (f : X -> Y)
: Finite (himage f).
Proof.
  exact _.
Defined.

(** ** Finite products of natural numbers *)

(** Similarly, closure of finite sets under [forall] automatically gives us a way to multiply a family of natural numbers indexed by any finite set.  Of course, if we defined this explicitly, it wouldn't need funext. *)

Definition finmult `{Funext} {X} `{Finite X} (f : X -> nat) : nat
  := fcard (forall x:X, Fin (f x)).

Definition fcard_forall `{Funext} {X} (Y : X -> Type)
       `{Finite X} `{forall x, Finite (Y x)}
: fcard (forall x:X, Y x) = finmult (fun x => fcard (Y x)).
Proof.
  set (f := fun x => fcard (Y x)).
  set (g := fun x => merely_equiv_fin (Y x) : merely (Y x <~> Fin (f x))).
  apply finite_choice in g.
  strip_truncations.
  unfold finmult.
  refine (fcard_equiv' (equiv_functor_forall' (equiv_idmap X) g)).
Defined.

(** The product of a finite constant family is the exponential by its cardinality. *)
Definition finmult_const `{Funext} X `{Finite X} n
: finmult (fun x:X => n) = nat_exp n (fcard X).
Proof.
  refine (fcard_arrow X (Fin n)).
Defined.

(** ** Finite subsets *)

(** Closure under sigmas implies that a detachable subset of a finite set is finite. *)
Global Instance finite_detachable_subset {X} `{Finite X} (P : X -> Type)
       `{forall x, IsHProp (P x)} `{forall x, Decidable (P x)}
: Finite { x:X & P x }.
Proof.
  exact _.
Defined.

(** Conversely, if a subset of a finite set is finite, then it is detachable.  We show first that an embedding between finite subsets has detachable image. *)
Definition detachable_image_finite
           {X Y} `{Finite X} `{Finite Y} (f : X -> Y) `{IsEmbedding f}
: forall y, Decidable (hfiber f y).
Proof.
  intros y.
  assert (ff : Finite (hfiber f y)) by exact _.
  destruct ff as [[|n] e].
  - right; intros u; strip_truncations; exact (e u).
  - left; strip_truncations; exact (e^-1 (inr tt)).
Defined.

Definition detachable_finite_subset {X} `{Finite X}
           (P : X -> Type) `{forall x, IsHProp (P x)}
           {Pf : Finite ({ x:X & P x })}
: forall x, Decidable (P x).
Proof.
  intros x.
  refine (decidable_equiv _ (hfiber_fibration x P)^-1 _).
  refine (detachable_image_finite pr1 x).
  - assumption.                 (** Why doesn't Coq find this? *)
  - apply mapinO_pr1; exact _.  (** Why doesn't Coq find this? *)
Defined.

(** ** Quotients *)

(** The quotient of a finite set by a detachable equivalence relation is finite. *)

Section DecidableQuotients.
  Context `{Univalence} {X} `{Finite X}
          (R : Relation X) `{is_mere_relation X R}
          `{Reflexive _ R} `{Transitive _ R} `{Symmetric _ R}
          {Rd : forall x y, Decidable (R x y)}.

  Global Instance finite_quotient : Finite (Quotient R).
  Proof.
    assert (e := merely_equiv_fin X).
    strip_truncations.
    pose (R' x y := R (e^-1 x) (e^-1 y)).
    assert (is_mere_relation _ R') by exact _.
    assert (Reflexive R') by (intros ?; unfold R'; apply reflexivity).
    assert (Symmetric R') by (intros ? ?; unfold R'; apply symmetry).
    assert (Transitive R') by (intros ? ? ?; unfold R'; apply transitivity).
    assert (R'd : forall x y, Decidable (R' x y))
      by (intros ? ?; unfold R'; apply Rd).
    srefine (finite_equiv' _ (equiv_quotient_functor R' R e^-1 _) _).
    1: by try (intros; split).
    clearbody R'; clear e.
    generalize dependent (fcard X);
      intros n; induction n as [|n IH]; intros R' ? ? ? ? ?.
    - refine (finite_equiv Empty _^-1 _).
      refine (Quotient_rec R' _ Empty_rec (fun x _ _ => match x with end)).
    - pose (R'' x y := R' (inl x) (inl y)).
      assert (is_mere_relation _ R'') by exact _.
      assert (Reflexive R'') by (intros ?; unfold R''; apply reflexivity).
      assert (Symmetric R'') by (intros ? ?; unfold R''; apply symmetry).
      assert (Transitive R'') by (intros ? ? ?; unfold R''; apply transitivity).
      assert (forall x y, Decidable (R'' x y)) by (intros ? ?; unfold R''; apply R'd).
      assert (inlresp := (fun x y => idmap)
                         : forall x y, R'' x y -> R' (inl x) (inl y)).
      destruct (dec (merely {x:Fin n & R' (inl x) (inr tt)})) as [p|np].
      { strip_truncations.
        destruct p as [x r].
        refine (finite_equiv' (Quotient R'') _ _).
        refine (Build_Equiv _ _ (Quotient_functor R'' R' inl inlresp) _).
        apply isequiv_surj_emb.
        - apply BuildIsSurjection.
          refine (Quotient_ind_hprop R' _ _).
          intros [y|[]]; apply tr.
          + exists (class_of R'' y); reflexivity.
          + exists (class_of R'' x); simpl.
            apply qglue, r.
        - apply isembedding_isinj_hset; intros u.
          refine (Quotient_ind_hprop R'' _ _); intros v.
          revert u; refine (Quotient_ind_hprop R'' _ _); intros u.
          simpl; intros q.
          apply qglue; unfold R''.
          exact (related_quotient_paths R' (inl u) (inl v) q). }
      { refine (finite_equiv' (Quotient R'' + Unit) _ _).
        refine (Build_Equiv _ _ (sum_ind (fun _ => Quotient R')
                                        (Quotient_functor R'' R' inl inlresp)
                                        (fun _ => class_of R' (inr tt))) _).
        apply isequiv_surj_emb.
        - apply BuildIsSurjection.
          refine (Quotient_ind_hprop R' _ _).
          intros [y|[]]; apply tr.
          + exists (inl (class_of R'' y)); reflexivity.
          + exists (inr tt); reflexivity.
        - apply isembedding_isinj_hset; intros u.
          refine (sum_ind _ _ _).
          + refine (Quotient_ind_hprop R'' _ _); intros v.
            revert u; refine (sum_ind _ _ _).
            * refine (Quotient_ind_hprop R'' _ _); intros u.
              simpl; intros q.
              apply ap, qglue; unfold R''.
              exact (related_quotient_paths R' (inl u) (inl v) q).
            * intros []; simpl.
              intros q.
              apply related_quotient_paths in q; try exact _.
              apply symmetry in q.
              elim (np (tr (v ; q))).
          + intros []; simpl.
            destruct u as [u|[]]; simpl.
            * revert u; refine (Quotient_ind_hprop R'' _ _); intros u; simpl.
              intros q.
              apply related_quotient_paths in q; try exact _.
              elim (np (tr (u;q))).
            * intros; reflexivity. }
  Defined.

  (** Therefore, the cardinality of [X] is the sum of the cardinalities of its equivalence classes. *)
  Definition fcard_quotient
  : fcard X = finplus (fun z:Quotient R => fcard {x:X & in_class R z x}).
  Proof.
    refine (fcard_domain (class_of R) @ _).
    apply ap, path_arrow; intros z; revert z.
    refine (Quotient_ind_hprop _ _ _); intros x; simpl.
    apply fcard_equiv'; unfold hfiber.
    refine (equiv_functor_sigma' 1 _); intros y; simpl.
    symmetry.
    refine (path_quotient R y x oE _).
    apply equiv_iff_hprop; apply symmetry.
  Defined.

End DecidableQuotients.

(** ** Injections *)

(** An injection between finite sets induces an inequality between their cardinalities. *)
Definition leq_inj_finite `{Funext} {X Y} {fX : Finite X} {fY : Finite Y}
           (f : X -> Y) (i : IsEmbedding f)
: fcard X <= fcard Y.
Proof.
  assert (MapIn (-1)%trunc f) by exact _. clear i.
  destruct fX as [n e]; simpl.
  destruct fY as [m e']; simpl.
  strip_truncations.
  pose (g := e' o f o e^-1).
  assert (MapIn (-1)%trunc g) by (unfold g; exact _).
  clearbody g. clear e e'. generalize dependent m.
  induction n as [|n IHn].
  { intros; exact tt. }
  intros m g ?.
  assert (i : isinj g) by (apply isinj_embedding; exact _).
  destruct m as [|m].
  { elim (g (inr tt)). }
  pose (h := (fin_transpose_last_with m (g (inr tt)))^-1 o g).
  assert (MapIn (-1)%trunc h) by (unfold h; exact _).
  assert (Ha : forall a:Fin n, is_inl (h (inl a))).
  { intros a.
    remember (g (inl a)) as b eqn:p.
    destruct b as [b|[]].
    - assert (q : g (inl a) <> (g (inr tt))).
      { intros r. exact (inl_ne_inr _ _ (i _ _ r)). }
      rewrite p in q; apply symmetric_neq in q.
      assert (r : h (inl a) = inl b).
      { unfold h; apply moveR_equiv_V; symmetry.
        refine (fin_transpose_last_with_rest m (g (inr tt)) b q @ p^). }
      rewrite r; exact tt.
    - assert (q : h (inl a) = g (inr tt)).
      { unfold h; apply moveR_equiv_V; symmetry.
        refine (_ @ p^); apply fin_transpose_last_with_with. }
      rewrite q.
      destruct (is_inl_or_is_inr (g (inr tt))) as [l|r]; try assumption.
      assert (s := inr_un_inr _ r).
      revert s; generalize (un_inr (g (inr tt)) r); intros [] s.
      elim (inl_ne_inr _ _ (i _ _ (p @ s))). }
  assert (Hb : forall b:Unit, is_inr (h (inr b))).
  { intros [].
    assert (q : h (inr tt) = inr tt).
    { unfold h; apply moveR_equiv_V; symmetry.
      apply fin_transpose_last_with_last. }
    rewrite q; exact tt. }
  exact (IHn m (unfunctor_sum_l h Ha)
             (mapinO_unfunctor_sum_l (-1)%trunc h Ha Hb)).
Qed.

(** ** Initial segments of [nat] *)

Definition nat_fin (n : nat) (k : Fin n) : nat.
Proof.
  induction n as [|n nf].
  - contradiction.
  - destruct k as [k|_].
    + exact (nf k).
    + exact n.
Defined.

Definition nat_fin_inl (n : nat) (k : Fin n)
: nat_fin n.+1 (inl k) = nat_fin n k
  := 1.

Definition nat_fin_compl (n : nat) (k : Fin n) : nat.
Proof.
  induction n as [|n nfc].
  - contradiction.
  - destruct k as [k|_].
    + exact (nfc k).+1.
    + exact 0.
Defined.

Definition nat_fin_compl_compl n k
: (nat_fin n k + nat_fin_compl n k).+1 = n.
Proof.
  induction n as [|n IH].
  - contradiction.
  - destruct k as [k|?]; simpl.
    + rewrite nat_plus_comm.
      specialize (IH k).
      rewrite nat_plus_comm in IH.
      exact (ap S IH).
    + rewrite nat_plus_comm; reflexivity.
Qed.

(** ** Enumerations *)

(** A function from [nat] to a finite set must repeat itself eventually. *)
Section Enumeration.
  Context `{Funext} {X} `{Finite X} (e : nat -> X).

  Let er (n : nat) : Fin n -> X
    := fun k => e (nat_fin n k).

  Lemma finite_enumeration_stage (n : nat)
  : IsEmbedding (er n)
    + { n : nat & { k : nat & e n = e (n + k).+1 }}.
  Proof.
    induction n as [|n [IH|IH]].
    - left. intros x.
      apply hprop_inhabited_contr; intros [[] _].
    - destruct (detachable_image_finite (er n) (er n.+1 (inr tt)))
        as [[k p]|ne].
      + right.
        exists (nat_fin n k).
        exists (nat_fin_compl n k).
        rewrite nat_fin_compl_compl.
        exact p.
      + left. intros x.
        apply hprop_allpath.
        intros k l.
        apply path_sigma_hprop.
        destruct k as [[k|[]] p], l as [[l|[]] q]; simpl.
        * apply isinj_embedding in IH.
          apply ap.
          apply IH.
          unfold er in p, q. simpl in p, q.
          exact (p @ q^).
        * refine (Empty_rec (ne _)).
          exists k.
          exact (p @ q^).
        * refine (Empty_rec (ne _)).
          exists l.
          exact (q @ p^).
        * reflexivity.
    - right; exact IH.
  Defined.

  Definition finite_enumeration_repeats
  : { n : nat & { k : nat & e n = e (n + k).+1 }}.
  Proof.
    destruct (finite_enumeration_stage (fcard X).+1) as [p|?].
    - assert (q := leq_inj_finite (er (fcard X).+1) p); simpl in q.
      elim (not_nltn _ q).
    - assumption.
  Defined.

End Enumeration.

Ltac FinIndOn X := repeat
  match type of X with
  | Fin 0 => destruct X
  | Empty => destruct X
  | Unit => destruct X
  | Fin ?n => destruct X as [X|X]
  | ?L + Unit => destruct X as [X|X]
  end.

Ltac FinInd := let X := fresh "X" in intro X; FinIndOn X.


Set Implicit Arguments.

Require Import Coq.Lists.List.
Require Import Coq.ZArith.BinInt.

Require Import HJ.Vars.
Require Import HJ.Phasers.Lang.
Require Import HJ.Phasers.PhaseDiff.

Open Scope Z.

(**

The wait-phase difference [z] is defined for a pair of tasks t1 t2 such
that there exists a phaser ph for which its wait phase difference is [z], [WP(ph,t1) - WP(ph,t2) = z].

A well-formed phaser map respects a few properties:
 * for any task [t] registered in at least a phaser, we have that [t - t = 0]
 * for any two tasks [t1] and [t2], the wait-phase difference for any phaser is the same
   (so the wait-phase difference is a function).

*)

Section DIFF_SUM.

Variable A : Type.
Notation edge := (A * A) % type.
Variable diff: edge -> Z -> Prop.
Variable get_diff: edge -> option Z.
Variable get_diff_spec:
  forall e z,
  get_diff e = Some z <-> diff e z.

Lemma diff_fun:
  forall e z z',
  diff e z ->
  diff e z' ->
  z = z'.
Proof.
  intros.
  rewrite <- get_diff_spec in *.
  rewrite H in H0.
  inversion H0.
  trivial.
Qed.

(**
We say that the sequence of tasks [t1 t2 ... tn] has a sum of [s].

such that there exists a wait phase difference between any task [t_i] and
task [t_{i + 1}], where [1 <= i <= n] and the sum of all wait-phase
differences is [s].

*)
Inductive DiffSum : list edge -> Z -> Prop :=
  | diff_sum_nil:
    DiffSum nil 0
  | diff_sum_pair:
    forall t1 t2 z,
    diff (t1, t2) z ->
    DiffSum ((t1, t2) :: nil) z
  | diff_sum_cons:
    forall t1 t2 t3 w z s,
    DiffSum ((t2, t3) :: w) s ->
    diff (t1, t2) z ->
    DiffSum ((t1, t2) :: (t2, t3) :: w) (z + s).

Lemma diff_sum_nil_z:
  forall z,
  DiffSum nil z ->
  z = 0.
Proof.
  intros.
  inversion H.
  reflexivity.
Qed.

Definition as_z (o:option Z) :=
  match o with
  | Some z => z
  | None => 0
  end.

Definition diff_sum_accum (a:Z) (e:edge) : Z :=
  (as_z (get_diff e)) + a.

Lemma diff_sum_accum_0:
  forall e,
  diff_sum_accum 0 e = as_z (get_diff e).
Proof.
  intros.
  unfold diff_sum_accum.
  intuition.
Qed.

Definition diff_sum (l:list edge) : Z :=
  fold_left diff_sum_accum l 0.

Lemma diff_sum_0: diff_sum nil = 0.
Proof.
  unfold diff_sum.
  auto.
Qed.

Let fold_left_diff_sum_accum:
  forall w z,
  fold_left diff_sum_accum w z = z + fold_left diff_sum_accum w 0.
Proof.
  intros w.
  induction w.
  - intros.
    intuition.
  - intros.
    simpl.
    remember (diff_sum_accum z a) as s.
    rewrite diff_sum_accum_0 in *.
    remember ((as_z (get_diff a))) as s'.
    assert (Hx := IHw s).
    assert (Hy := IHw s').
    rewrite Hx.
    rewrite Hy.
    remember (fold_left diff_sum_accum w 0) as sum.
    unfold diff_sum_accum in Heqs.
    intuition.
Qed.

Lemma diff_sum_unfold:
  forall e w,
  diff_sum (e :: w) = (as_z (get_diff e)) + (diff_sum w).
Proof.
  intros.
  unfold diff_sum.
  simpl.
  remember (diff_sum_accum 0 e).
  unfold diff_sum_accum in Heqz.
  remember (get_diff e) as o.
  assert (as_z o = z). {
    intuition.
  }
  rewrite H in *.
  auto.
Qed.

Theorem diff_sum_spec:
  forall l z,
  DiffSum l z ->
  z = diff_sum l.
Proof.
  intros l.
  induction l.
  + intros; inversion H.
    auto.
  + intros.
    inversion H.
    - subst.
      unfold diff_sum.
      simpl.
      rewrite <- get_diff_spec in H3.
      remember (get_diff (t1, t2)).
      destruct o.
      * inversion H3; subst.
        rewrite diff_sum_accum_0.
        rewrite <- Heqo.
        auto.
      * inversion H3.
    - subst.
      simpl.
      apply IHl in H2; clear IHl H.
      rewrite <- get_diff_spec in H4.
      rewrite diff_sum_unfold.
      rewrite <- H2.
      rewrite H4.
      auto.
Qed.

Definition NegDiff (e:edge) := exists z, diff e z /\ z <= 0.

Lemma diff_sum_le_0:
  forall w z,
  Forall NegDiff w ->
  DiffSum w z ->
  z <= 0.
Proof.
  intros w.
  induction w.
  - intros.
    apply diff_sum_nil_z in H0.
    intuition.
  - intros.
    inversion H0.
    + subst.
      intuition.
      assert (Hin : List.In (t1, t2) ((t1, t2) :: nil)). {
        apply in_eq.
      }
      rewrite Forall_forall in H.
      destruct (H _ Hin) as (z', (?, ?)).
      assert (z' = z). { eauto using diff_fun. }
      intuition.
   + subst. clear H0.
     assert (s <= 0). {
       inversion H; subst.
       auto using IHw.
     }
     assert (z0 <= 0). {
       rewrite Forall_forall in H.
       assert (Hin : List.In (t1, t2) ((t1, t2) :: (t2, t3) :: w0)). {
         apply in_eq.
       }
       destruct (H _ Hin) as (z, (?,?)).
       assert (z0 = z). { eauto using diff_fun. }
       intuition.
    }
    intuition.
Qed.

Definition HasDiff e := exists z, diff e z.

Require Import Aniceto.Graphs.Graph.

Lemma has_diff_to_diff_sum:
  forall w x y,
  Walk2 HasDiff x y w ->
  exists z : Z, DiffSum w z.
Proof.
  intros w.
  induction w.
  - intros. apply walk2_nil_inv in H.
    intuition.
  - intros.
    destruct w.
    + apply walk2_inv_pair in H.
      destruct H as (?, Hd).
      subst.
      unfold HasDiff in *.
      destruct Hd as (z, Hd).
      exists z.
      apply diff_sum_pair.
      auto.
    + apply walk2_inv in H.
      destruct H as (v1, (?, (?, ?))).
      destruct p as (v1', v2).
      assert (v1' = v1). {
        apply walk2_inv_cons in H1.
        destruct H1 as (?, (Heq, ?)).
        inversion Heq.
        reflexivity.
      }
      subst.
      apply IHw in H1.
      subst.
      destruct H1 as (s, Hs).
      unfold HasDiff in *.
      destruct H0 as (z, Hd).
      exists (z + s).
      auto using diff_sum_cons.
Qed.

Lemma neg_diff_to_has_diff:
  forall e,
  NegDiff e ->
  HasDiff e.
Proof.
  intros.
  unfold NegDiff in *.
  unfold HasDiff in *.
  destruct H as (z, (H,_)).
  exists z; auto.
Qed.

Lemma walk2_neg_diff_to_has_diff:
  forall t1 t2 w,
  Walk2 NegDiff t1 t2 w ->
  Walk2 HasDiff t1 t2 w.
Proof.
  intros.
  eauto using walk2_impl, neg_diff_to_has_diff.
Qed.

Inductive TransDiff: A -> A -> Z -> Prop :=
  trans_diff_def:
    forall t1 t2 w z,
    DiffSum w z ->
    Walk2 HasDiff t1 t2 w ->
    TransDiff t1 t2 z.

Lemma diff_to_trans_diff:
  forall t1 t2 z,
  diff (t1, t2) z ->
  TransDiff t1 t2 z.
Proof.
  intros.
  assert (Hw : Walk2 HasDiff t1 t2 ((t1,t2) :: nil)). {
    apply walk2_nil; repeat auto.
    unfold HasDiff; exists z; auto.
  }
  assert (Hd : DiffSum ((t1, t2)::nil) z). { auto using diff_sum_pair. }
  eauto using trans_diff_def.
Qed.

Definition TransDiffFun :=
  forall t1 t2 z z',
  TransDiff t1 t2 z ->
  TransDiff t1 t2 z' ->
  z' = z.

Corollary trans_diff_fun_1 (Hdet : TransDiffFun):
  forall t1 t2 z z',
  TransDiff t1 t2 z ->
  diff (t1, t2) z' ->
  z' = z.
Proof.
  intros.
  apply diff_to_trans_diff in H0.
  eauto using Hdet.
Qed.

Corollary trans_diff_fun_2 (Hdet : TransDiffFun):
  forall t1 t2 z z',
  diff (t1, t2) z ->
  diff (t1, t2) z' ->
  z' = z.
Proof.
  intros.
  apply diff_to_trans_diff in H.
  eauto using trans_diff_fun_1.
Qed.

End DIFF_SUM.
(*
Arguments DiffSum.
Arguments HasDiff.
Arguments NegDiff.
*)
Lemma diff_sum_impl_weak:
  forall {A:Type} (D D': (A*A) -> Z -> Prop) ,
  forall l,
  (forall e z, List.In e l -> D e z -> D' e z) ->
  forall z,
  DiffSum D l z ->
  DiffSum D' l z.
Proof.
  induction l; intros.
  - inversion H0.
    apply diff_sum_nil.
  - inversion H0.
    + subst.
      eauto using diff_sum_pair, in_eq.
    + subst.
      auto using diff_sum_cons, in_eq, in_cons.
Qed.

Lemma diff_sum_impl:
  forall {A:Type} (D D': (A*A) -> Z -> Prop) ,
  (forall e z, D e z -> D' e z) ->
  forall l z,
  DiffSum D l z ->
  DiffSum D' l z.
Proof.
  eauto using diff_sum_impl_weak.
Qed.


Require Export Basic.
Require Export lemma.

(* 函数f在闭区间[a,b]上一致连续 *)
Definition uniform_continuous f (a b:R) :=
  exists d, pos_inc d (0,b-a] /\
  bounded_rec_f d (0,b-a] /\
  (forall x h:R, x ∈ [a,b] /\ (x+h) ∈ [a,b] /\ h<>0 ->
  (Rabs (f(x+h) - f(x))) <= d(Rabs h)).

(* 函数f在闭区间[a,b]上一致可导 *)
Definition uniform_differentiable F (a b:R) :=
  exists d, pos_inc d (0,b-a] /\
  bounded_rec_f d (0,b-a] /\
  exists f M, 0<M /\ forall x h:R, x ∈ [a,b] /\ (x+h) ∈ [a,b] /\ h<>0 ->
  Rabs (F(x+h) - F(x) - f(x)*h) <= M*(Rabs h)*d(Rabs h).

(* 函数f在闭区间[a,b]上强可导 *)
Definition str_differentiable F (a b:R) :=
  exists f M, 0<M /\ forall x h:R, x∈[a,b] /\ (x+h)∈[a,b] ->
  Rabs (F(x+h)-F(x)-f(x)*h) <= M*(h^2).

(* 函数F在闭区间[a,b]上的导数为函数f *)
Definition derivative F f a b :=
  exists d, pos_inc d (0,b-a] /\
  bounded_rec_f d (0,b-a] /\
  exists M:R, 0<M /\ forall x h:R, x ∈ [a,b] /\ (x+h) ∈ [a,b] /\ h<>0 ->
  Rabs (F(x+h) - F(x) - f(x)*h) <= M*(Rabs h)*d(Rabs h).

(* 函数F在闭区间[a,b]上的强可导导数为函数f *)
Definition str_derivative F f (a b:R) :=
  exists M:R, 0<M /\ forall x h:R, x ∈ [a,b] /\ (x+h) ∈ [a,b] ->
  Rabs (F(x+h) - F(x) - f(x)*h) <= M*(h^2).

Theorem strder_deduce_der : forall F f a b,
  a<b -> str_derivative F f a b -> derivative F f a b.
Proof.
  intros.
  unfold str_derivative in H0.
  unfold derivative.
  exists (fun x => x).
  split.
  - unfold pos_inc.
    split; intros.
    unfold In in H1; unfold oc in H1; tauto.
    apply Rlt_le; auto.
  - split.
    + unfold bounded_rec_f; intros.
      assert(exists z : R, z ∈ (0, b - a] /\ z < 1/M).
       { assert(0<b-a).
          { apply Rlt_Rminus; auto. }
         generalize (total_order_T (1/M) (b-a)); intro.
         destruct H3. destruct s.
         - generalize(exist_Rgt_lt 0 (1/M)); intro.
           destruct H3.
           unfold Rdiv; rewrite Rmult_1_l; apply Rinv_0_lt_compat; auto.
           exists x. unfold In; unfold oc.
           destruct H3. repeat split; auto.
           apply Rlt_le; apply Rlt_trans with (r2:=1/M); auto.
         - apply Rinv_0_lt_compat in H1.
           apply exist_Rgt_lt in H1. destruct H1, H1.
           exists x. unfold In; unfold oc.
           repeat split; auto. rewrite <- e; apply Rlt_le.
           unfold Rdiv; rewrite Rmult_1_l; auto.
           unfold Rdiv; rewrite Rmult_1_l; auto.
         - generalize H2; auto.
           apply exist_Rgt_lt in H2. destruct H2, H2.
           exists x. unfold In; unfold oc.
           repeat split; auto. apply Rlt_le; auto.
           apply Rlt_trans with (r2:=b-a); auto. }
        destruct H2, H2.
        exists x. split; auto.
        unfold In in H2; unfold oc in H2.
        destruct H2, H4.
        rewrite Rabs_right. unfold Rdiv; rewrite Rmult_1_l.
        unfold Rdiv in H3; rewrite Rmult_1_l in H3.
        apply Rinv_lt_contravar in H3.
        rewrite Rinv_involutive in H3; auto.
        apply Rgt_not_eq; auto.
        apply Rmult_lt_0_compat; auto.
        apply Rinv_0_lt_compat; auto.
        unfold Rdiv; rewrite Rmult_1_l; apply Rgt_ge.
        apply Rlt_gt; apply Rinv_0_lt_compat; auto.
    + destruct H0, H0. exists x. split; auto.
      intros.
      rewrite Rmult_assoc; rewrite <- Rabs_mult.
      rewrite (Rabs_pos_eq (h*h)).
      simpl in H2.
      rewrite <- (Rmult_1_r (h * h)); rewrite Rmult_assoc.
      apply H1; tauto.
      apply Rlt_le; apply Rsqr_pos_lt; tauto.
Qed.

(* (*强可导唯一*)

Theorem unique_dri : forall F f g a b,
  str_derivative F f a b -> str_derivative F g a b ->
  (forall x, x ∈ [a,b] -> f x = g x).
Proof.
  unfold str_derivative. intros.
  destruct H, H0. rename x0 into M. rename x1 into M1.
  destruct H, H0.
  generalize(classic (f x=g x)); intro.
  destruct H4; auto.
  SearchAbout(_<>_ -> _ _ <>_ _).
  red. *)

(* 设 F(x),G(x)一致(强)可导，并且导数分别是f(x),g(x) *)

(* 对任意常数c，cF(x)一致(强)可导，且其导数分别是cf(x) *)
Theorem Theorem2_1_1 : forall (a b c:R) F f,
  derivative F f a b ->
  derivative (mult_real_f c F) (mult_real_f c f) a b.
Proof.
  intros a b c F f .
  unfold derivative; intro.
  destruct H, H, H0, H1, H1.
  exists x; split; auto. split; auto.
  generalize (total_eq_or_neq c 0); intro. destruct H3.
  - exists x0. split; auto; intros.
    apply H2 in H4. unfold mult_real_f; rewrite H3.
    repeat rewrite Rmult_0_l. unfold Rminus; rewrite Ropp_0;
    repeat rewrite Rplus_0_l; rewrite Rabs_R0.
    apply Rle_trans with (r2:=Rabs(F(x1+h)-F x1-f x1*h)); auto.
    apply Rabs_pos.
  - exists (Rabs c * x0). split.
    apply Rmult_lt_0_compat; auto.
    apply Rabs_pos_lt; auto. intros. apply H2 in H4.
    unfold mult_real_f. rewrite Rmult_assoc.
    rewrite <- Rmult_minus_distr_1_3 with
    (r:=c)(r1:=(F(x1+h)))(r2:=F x1)(r3:=f x1*h).
    rewrite Rabs_mult; repeat rewrite Rmult_assoc; apply Rmult_le_compat_l.
    apply Rabs_pos. repeat rewrite <- Rmult_assoc; apply H4.
Qed.

(* 定义一个选择器，其性质为：
      比较任意两个实数a，b的大小，如果a>b, if_a_gt_b a b 值为true
      如果a<=b, if_a_gt_b a b值为false；且反向推也成立。该性质由公理comp_a_b_Pro定义 *)

Parameter if_a_gt_b : R -> R -> bool.

Axiom comp_a_b_Pro : forall a b, (if_a_gt_b a b = true <-> a > b) /\
  (if_a_gt_b a b = false <-> a <= b).

(* 定义一个函数，该函数在每一点的值，都为函数f1、f2在该点函数值中较大那一个 *)
Definition max_f1_f2 (f1 f2 : R -> R) :=
  fun x:R => if (if_a_gt_b (f1 x)(f2 x)) then (f1 x) else (f2 x).

Lemma existence_f : forall a b f1 f2,
  pos_inc f1 (0,b-a] /\
  (forall r1:R, r1>0 -> exists z1:R, z1 ∈ (0,b-a] /\ r1 < Rabs(1/(f1 z1))) /\
  pos_inc f2 (0,b-a] /\
  (forall r2:R, r2>0 -> exists z2:R, z2 ∈ (0,b-a] /\ r2 < Rabs(1/(f2 z2))) ->
  exists f3, (pos_inc f3 (0,b-a] /\
  (forall r3:R, r3>0 -> exists z3:R, z3 ∈ (0,b-a] /\ r3 < Rabs(1/(f3 z3))) /\
  (forall a:R, f1 a <= f3 a /\ f2 a <= f3 a)).
Proof.
  intros.
  exists (max_f1_f2 f1 f2).
  destruct H, H0, H1. split.
  - unfold pos_inc. unfold pos_inc in H, H1.
    split; intros.
    + destruct H, H1. generalize H3; intros. apply H in H3; apply H1 in H6.
      unfold max_f1_f2; destruct if_a_gt_b; auto.
    + destruct H, H1; generalize H5; intros.
      apply H6 in H5; auto. apply H7 in H8; auto.
      unfold max_f1_f2.
      assert(if_a_gt_b(f1 z1)(f2 z1)=true \/ if_a_gt_b(f1 z1)(f2 z1)=false).
      { destruct if_a_gt_b; auto. }
      destruct H9.
      * rewrite H9; apply comp_a_b_Pro in H9.
        assert(if_a_gt_b(f1 z2)(f2 z2)=true\/if_a_gt_b(f1 z2)(f2 z2)=false).
         { destruct if_a_gt_b; auto. }
        destruct H10. rewrite H10; auto. rewrite H10; apply comp_a_b_Pro in H10.
        eapply Rle_trans. apply H5. apply H10.
      * rewrite H9; apply comp_a_b_Pro in H9.
        assert(if_a_gt_b(f1 z2)(f2 z2)=true\/if_a_gt_b(f1 z2)(f2 z2)=false).
         { destruct if_a_gt_b; auto. }
        destruct H10. rewrite H10; apply comp_a_b_Pro in H10.
        eapply Rle_trans. apply H8. apply Rlt_le; auto.
        rewrite H10; auto.
  - split; intros.
    generalize H3 as r; intro.
    generalize H3 as H4; intro.
    apply H0 in H3; apply H2 in H4. clear H0; clear H2.
    unfold max_f1_f2.
    destruct H3, H0. destruct H4, H3.
    assert(if_a_gt_b(f1 x)(f2 x)=true\/if_a_gt_b(f1 x)(f2 x)=false).
      { destruct if_a_gt_b; auto. }
    assert(if_a_gt_b(f1 x0)(f2 x0)=true\/if_a_gt_b(f1 x0)(f2 x0)=false).
      { destruct if_a_gt_b at 1 2; auto. }
    generalize(classic (exists z3:R, z3 ∈ (0,b-a]/\
    r3 < Rabs (1/(if if_a_gt_b (f1 z3) (f2 z3) then f1 z3 else f2 z3)))); intro.
    destruct H7; auto.
    generalize H7; intro.
    apply not_exist with(x:=x) in H7; auto. apply Rnot_lt_le in H7.
    apply not_exist with(x:=x0) in H8; auto. apply Rnot_lt_le in H8.
    destruct H5.
    + rewrite H5 in H7; apply Rlt_not_le in H2; contradiction.
    + rewrite H5 in H7.
      destruct H6.
      * rewrite H6 in H8.
        unfold pos_inc in H, H1.
        destruct H, H1.
        generalize(H x H0); intro; apply Rinv_0_lt_compat in H11.
        generalize(H x0 H3); intro; apply Rinv_0_lt_compat in H12.
        generalize(H1 x H0); intro; apply Rinv_0_lt_compat in H13.
        generalize(H1 x0 H3); intro; apply Rinv_0_lt_compat in H14.
        unfold Rdiv in H2; rewrite Rmult_1_l in H2; rewrite Rabs_right in H2;
        try apply Rgt_ge; try apply Rlt_inv in H2; auto.
        unfold Rdiv in H4; rewrite Rmult_1_l in H4; rewrite Rabs_right in H4;
        try apply Rgt_ge; try apply Rlt_inv in H4; auto.
        unfold Rdiv in H7; rewrite Rmult_1_l in H7; rewrite Rabs_right in H7;
        try apply Rgt_ge; try apply Rinv_le in H7; auto.
        unfold Rdiv in H8; rewrite Rmult_1_l in H8; rewrite Rabs_right in H8;
        try apply Rgt_ge; try apply Rinv_le in H8; auto.
        clear H11 H12 H13 H14.
        generalize (Rtotal_order x x0); intro.
        destruct H11.
        { generalize H11; intro.
          apply H9 in H11; apply H10 in H12; auto.
          apply Rge_le in H7.
          generalize(Rlt_le_trans (f2 x0)(/r3)(f2 x) H4 H7); intro.
          apply Rlt_not_le in H13; contradiction. }
        destruct H11.
        { rewrite H11 in H5; rewrite H5 in H6.
          generalize Bool.diff_false_true; intro; contradiction. }
        apply Rgt_lt in H11.
        generalize H11; intro.
        apply H9 in H11; apply H10 in H12; auto.
        apply Rge_le in H8.
        generalize(Rlt_le_trans (f1 x)(/r3)(f1 x0) H2 H8); intro.
        apply Rlt_not_le in H13; contradiction.
      * rewrite H6 in H8.
        exists x0; split; auto. rewrite H6; auto.
    + unfold max_f1_f2.
      assert(if_a_gt_b(f1 a0)(f2 a0)=true\/if_a_gt_b(f1 a0)(f2 a0)=false).
      { destruct if_a_gt_b; auto. }
      destruct H3.
      * rewrite H3; apply comp_a_b_Pro in H3.
        split.
        apply Rge_refl.
        apply Rlt_le; auto.
      * rewrite H3; apply comp_a_b_Pro in H3.
        split; auto.
        apply Rge_refl.
Qed.

(* F(x)+G(x)一致(强)可导,且其导数分别是f(x)和g(x) *)
Theorem Theorem2_1_2 : forall F G f g (a b:R),
  derivative F f a b -> derivative G g a b ->
  derivative (plus_Fu F G) (plus_Fu f g) a b.
Proof.
  intros F G f g a b.
  unfold derivative; unfold bounded_rec_f; intros.
  destruct H, H, H1, H2, H2. rename x into d1; rename x0 into M1.
  destruct H0, H0, H4, H5, H5. rename x into d2; rename x0 into M2.
  assert (exists d3, pos_inc d3 (0,b-a] /\ (forall r3:R, r3>0 ->
          exists z3:R, z3 ∈ (0,b-a] /\ r3 < Rabs(1/(d3 z3))) /\
          forall a:R, d1 a <= d3 a /\ d2 a <= d3 a).
   { apply existence_f with (a:=a)(b:=b) (f1:=d1) (f2:=d2).
     split; auto. }
  destruct H7, H7, H8. rename x into d3.
  exists d3; split; auto. split; auto.
  exists (M1 + M2); intros.
  split.
  apply Rplus_lt_0_compat; auto. intros.
    generalize H10; intro.
    apply H3 in H10; apply H6 in H11.
    unfold plus_Fu.
    rewrite Rmult_plus_distr_r with (r1:=(f x))(r2:=(g x))(r3:=h).
    rewrite plus_ab_minus_cd with (a:=F(x+h))(b:=G(x+h))(c:=F x)
                                  (d:=G x)(e:=f x*h)(f:=g x*h).
    assert (Rabs(F(x+h) - F x - f x*h)+Rabs(G(x+h) - G x - g x*h)
            <= M1*(Rabs h)*d1(Rabs h) + M2*(Rabs h)*d2(Rabs h)).
     { apply Rplus_le_compat; auto. }
    apply Rle_abcd with (a:=Rabs(F(x+h)-F x-f x*h+(G(x+h)-G x-g x*h)))
                        (b:=Rabs(F(x+h)-F x-f x*h)+Rabs(G(x+h)-G x-g x*h))
                        (c:=M1*(Rabs h)*d1(Rabs h)+M2*(Rabs h)*d2(Rabs h))
                        (d:=(M1+M2)*(Rabs h)*d3(Rabs h)).
    + apply Rabs_triang.
    + rewrite Rmult_plus_distr_r.
      rewrite Rmult_plus_distr_r.
      apply Rplus_le_compat; apply Rmult_le_compat_l.
      apply Rmult_le_pos. apply Rlt_le; auto. apply Rabs_pos. apply H9.
      apply Rmult_le_pos. apply Rlt_le; auto. apply Rabs_pos. apply H9.
    + auto.
Qed.

Lemma th2' : forall (a b c:R) f, c > 0 -> pos_inc f (0, b-a] ->
  pos_inc (Com_F_c f c) (0, (b/c-a/c)].
Proof.
  intros a b c f C.
  unfold pos_inc; unfold Com_F_c; intro.
  assert ( forall z, z ∈ (0,(b / c - a / c)] ->(c * z) ∈ (0,b-a] ).
   { unfold In; unfold oc; intros.
     rewrite <- Rinv_minus_distr_r in H0.
     unfold Rdiv in H0; destruct H0; split.
     apply Rmult_0_lt_reg in H0; auto.
     apply Rinv_0_lt_compat; auto.
     apply Rlt_x_le with (r:=c); auto. rewrite Rmult_eq_r.
     unfold Rdiv; tauto.
     apply Rgt_not_eq; auto.
     apply Rgt_not_eq; auto. }
  destruct H; split; intros.
  - apply H0 in H2; apply H in H2; auto.
  - apply H0 in H2; apply H0 in H3; apply H1; auto.
    apply Rmult_lt_compat_l; auto.
Qed.

(*F(cx+d)一致（强）可导，且其导数为cf(cx+d)*)
Theorem Theorem2_1_3 : forall F f (a b c d:R),
  c > 0 -> derivative F f a b ->
  derivative (Com_F F c d) (mult_real_f c (Com_F f c d))((a-d)/c)((b-d)/c).
Proof.
intros F f a b c d C.
  unfold derivative; intro.
  destruct H, H, H0, H1, H1. rename x into p; rename x0 into M.
  exists (Com_F_c p c); split.
  apply th2'; auto.
  rewrite Rminus_distr; rewrite R_distr; rewrite Rminus_plus_r; auto.
  split.
  unfold bounded_rec_f; unfold bounded_rec_f in H0; intros.
  apply H0 in H3; destruct H3, H3, H3.
  exists (x/c).
  split.
  - unfold In; unfold oc. split.
    + rewrite <- Rdiv_minus_distr; rewrite Rminus_distr.
      rewrite R_distr; rewrite Rminus_plus_r.
      unfold Rdiv; apply Rmult_lt_0_compat; auto.
      apply Rinv_0_lt_compat; auto.
    + rewrite <- Rdiv_minus_distr; apply Rlt_x_le_reg; auto;
      rewrite Rminus_distr.
      rewrite R_distr; rewrite Rminus_plus_r; auto.
  - unfold Com_F_c. rewrite Rmult_par_inv_eq. rewrite Rmult_eq_r; auto.
    apply Rgt_not_eq; auto.  apply Rgt_not_eq; auto.
  - unfold Com_F; unfold Com_F_c.
    exists (c*M); intros.
    split. apply Rmult_lt_0_compat; auto.
    intros.
    assert ((c*x+d) ∈ [a,b] /\ ((c*x+d)+(c*h)) ∈ [a,b]).
     { unfold In; unfold cc; unfold In in H3; unfold cc in H3.
       destruct H3, H3, H4.
       assert(a<b).
       { unfold Rdiv in H3;
         apply Rmult_lt_reg_r with (r:=/c) in H3; auto.
         unfold Rminus in H3. eapply Rplus_lt_reg_r; apply H3.
         apply Rinv_0_lt_compat; auto. }
       split; split; auto.
       - apply Rplus_le_3_r.
         apply Rinv_le_r with(r:=c); auto.
         rewrite Rmult_eq_r with (r:=c)(r1:=x); auto.
         apply Rgt_not_eq; auto.
       - rewrite Rplus_comm  with (r1:=c*x)(r2:=d).
         rewrite Rplus_assoc; rewrite Rplus_comm. apply Rplus_le_3_r .
         rewrite <- Rmult_plus_distr_l.
         apply Rinv_le_r with (r:=c); auto.
         rewrite Rmult_eq_r. tauto.
         apply Rgt_not_eq; auto. }
    assert((c*x+d) ∈ [a,b] /\ (c*x+d+c*h) ∈ [a,b] /\ c*h<>0).
     { destruct H4. split; auto. split; auto.
       apply Rmult_integral_contrapositive_currified.
       apply Rgt_not_eq; auto. tauto. }
    clear H4; apply H2 in H5.
    unfold mult_real_f; unfold Com_F.
    rewrite Rmult_plus_distr_l.
    rewrite Rplus_assoc with(r1:=(c*x))(r2:=d)(r3:=(c*h)) in H5.
    rewrite Rplus_comm  with (r1:=d)(r2:=c*h) in H5.
    rewrite <- Rplus_assoc in H5.
    rewrite <- Rmult_assoc with(r1:=(f(c*x+d)))(r2:=c)(r3:=h) in H5.
    rewrite Rmult_comm with (r1:=c)(r2:=(f (c*x + d))).
    rewrite Rmult_comm with (r1:=c)(r2:=M).
    rewrite Rabs_mult in H5. rewrite Rabs_right with (r:=c)in H5.
    rewrite Rmult_assoc with(r1:=M)(r2:=c)(r3:=Rabs h); auto.
    unfold Rge; auto.
Qed.

(*可加性*)
Definition additivity (S:R->R->R)(a b:R):=
  forall(w1 w2 w3:R), w1 ∈ [a,b] /\ w2 ∈ [a,b] /\w3 ∈ [a,b] ->
  S w1 w2 + S w2 w3 = S w1 w3.

(*非负性*)
Definition nonnegativity (S:R->R->R)(f:R->R)(a b:R):=
  forall(w1 w2:R), w1 ∈ [a,b] /\ w2 ∈ [a,b] /\ w2 - w1 > 0 ->
  (forall m:R, (forall x:R, x ∈ [w1,w2] -> m <= f x) -> m*(w2-w1) <= S w1 w2) /\
  (forall M:R, (forall x:R, x ∈ [w1,w2] -> M >= f x) -> S w1 w2 <= M*(w2-w1)).

(*积分系统*)
Definition integ_sys (S:R->R->R)(f:R->R)(a b:R) :=
  additivity S a b /\ nonnegativity S f a b.

(*可积*)
Definition integrable (f:R->R)(a b:R) :=
  exists S, integ_sys S f a b /\
  forall S':R->R->R, integ_sys S' f a b -> S = S'.

(* 积分严格不等式 *)
Definition strict_inequal (S:R->R->R)(f:R->R)(a b:R) :=
  integ_sys S f a b ->
  forall w1 w2:R, w1 ∈ [a,b] /\ w2 ∈ [a,b] /\ w2 - w1 > 0 ->
  (forall m:R, (forall x:R, x ∈ [w1,w2] -> m < f x) -> m*(w2 - w1) < S w1 w2) /\
  (forall M:R, (forall x:R, x ∈ [w1,w2] -> M > f x) -> S w1 w2 < M*(w2 - w1)).

Lemma equ_s : forall (S:R->R->R) (f G:R->R) (a b:R),
  integ_sys S f a b ->
  forall y, y ∈ [a,b] -> (forall x :R, x ∈ [a,b] -> G x = S y x) ->
  forall u v:R, u ∈ [a,b] /\ v ∈ [a,b] ->
  S u v = S y v - S y u /\ S y v - S y u  = G v - G u.
Proof.
  intros.
  unfold integ_sys in H; intros.
  destruct H; unfold additivity in H; split.
  - apply Rplus_eq_reg_r with (r:=(S y u)).
    rewrite Rminus_plus_r with (r1:=(S y v)) (r:=(S y u)).
    rewrite Rplus_comm; apply H.
    split; auto.
  - destruct H2; repeat rewrite H1; auto.
Qed.

(* 估值定理 *)
Theorem Valuation_Theorem : forall (S:R->R->R) (f G:R->R)(a b:R),
  integ_sys S f a b ->
  forall y, y ∈ [a,b] -> (forall x:R, x ∈ [a,b] -> G x = S y x) ->
  strict_inequal S f a b ->
  forall u v, u ∈ [a,b] /\ v ∈ [a,b] /\ v - u > 0 ->
  exists x1 x2, x1 ∈ [u,v] /\ x2 ∈ [u,v] /\
  (f x1)*(v-u) <= G(v) - G(u) <= (f x2)*(v-u).
Proof.
  intros.
  unfold strict_inequal in H2.
  generalize H as l; intro.
  apply H2 with (w1:=u)(w2:=v) in H; auto. clear H2.
  destruct H, H3, H4.
  assert (exists x1, x1 ∈ [u,v] /\ (f x1)*(v-u) <= G(v) - G(u)).
   { generalize (classic(exists x1, x1 ∈ [u,v] /\ (f x1)*(v-u) <= G(v) - G(u))).
     intros. destruct H6; auto.
     assert (G v - G u < S u v).
      { generalize (H ((G v - G u)/(v-u))); intros; clear H.
        unfold Rdiv in H7.
        rewrite Rinv_mult_rgt0 with (r1:=(G v - G u))(r:=(v - u))in H7; auto.
        apply H7; intros.
        apply not_exist with (x:=x) in H6. apply Rnot_le_gt in H6.
        apply Rgt_mult in H6; auto. apply H. }
     rewrite H1 in H7; auto. rewrite H1 in H7; auto.
     assert ( S u v = S y v - S y u /\ S y v - S y u = G v - G u).
      { apply equ_s with (f:=f)(a:=a)(b:=b); auto. }
     destruct H8.
     rewrite H8 in H7; apply Rlt_irrefl in H7; contradiction. }
  assert (exists x2, x2 ∈ [u,v] /\ (f x2)*(v-u) >= G(v) - G(u)).
   { generalize (classic(exists x2, x2 ∈ [u,v] /\ (f x2)*(v-u) >= G(v) - G(u))).
     intros. destruct H7; auto.
     assert (G v - G u > S u v).
      { generalize (H2 ((G v - G u)/(v-u))); intros; clear H2.
        unfold Rdiv in H8.
        rewrite Rinv_mult_rgt0 with (r1:=(G v - G u))(r:=(v - u))in H8; auto.
        apply H8; intros.
        apply not_exist with (x:=x) in H7. apply Rnot_ge_lt in H7.
        apply Rlt_mult in H7; auto. apply H2. }
     rewrite H1 in H8; auto. rewrite H1 in H8; auto.
     assert ( S u v = S y v - S y u /\ S y v - S y u = G v - G u).
      { apply equ_s with (f:=f)(a:=a)(b:=b); auto. }
     destruct H9.
     rewrite H9 in H8; apply Rlt_irrefl in H8; contradiction. }
  destruct H6, H6, H7, H7.
  exists x, x0.
  split; auto. split; auto. split; auto.
  apply Rge_le; auto.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (lf1 : natural) : natural := mult lf1 lf1.


Coq < Section Socrates.

Coq < Require Import Classical.

Coq < Variables A B C : Prop.
A is assumed
B is assumed
C is assumed

Coq < Goal (A -> C) /\ (B -> A) -> (B -> C).
1 subgoal

  A : Prop
  B : Prop
  C : Prop
  ============================
   (A -> C) /\ (B -> A) -> B -> C

Unnamed_thm < intros.
1 subgoal

  A : Prop
  B : Prop
  C : Prop
  H : (A -> C) /\ (B -> A)
  H0 : B
  ============================
   C

Unnamed_thm < apply H.
1 subgoal

  A : Prop
  B : Prop
  C : Prop
  H : (A -> C) /\ (B -> A)
  H0 : B
  ============================
   A

Unnamed_thm < elim H.
1 subgoal

  A : Prop
  B : Prop
  C : Prop
  H : (A -> C) /\ (B -> A)
  H0 : B
  ============================
   (A -> C) -> (B -> A) -> A

Unnamed_thm < intro.
1 subgoal

  A : Prop
  B : Prop
  C : Prop
  H : (A -> C) /\ (B -> A)
  H0 : B
  H1 : A -> C
  ============================
   (B -> A) -> A

Unnamed_thm < intro.
1 subgoal

  A : Prop
  B : Prop
  C : Prop
  H : (A -> C) /\ (B -> A)
  H0 : B
  H1 : A -> C
  H2 : B -> A
  ============================
   A

Unnamed_thm < auto.
No more subgoals.

Unnamed_thm < Qed.
intros.
apply H.
elim H.
intro.
intro.
auto.

Unnamed_thm is defined


Require Import rt.util.tactics rt.util.induction.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

Section FixedPoint.

  Lemma iter_fix T (F : T -> T) x k n :
    iter k F x = iter k.+1 F x ->
    k <= n ->
    iter n F x = iter n.+1 F x.
  Proof.
    move => e. elim: n. rewrite leqn0. by move/eqP<-.
    move => n IH. rewrite leq_eqVlt; case/orP; first by move/eqP<-.
    move/IH => /= IHe. by rewrite -!IHe.
  Qed.

  Lemma fun_mon_iter_mon :
    forall (f: nat -> nat) x0 x1 x2,
      x1 <= x2 ->
      f x0 >= x0 ->
      (forall x1 x2, x1 <= x2 -> f x1 <= f x2) ->
      iter x1 f x0 <= iter x2 f x0.
  Proof.
    intros f x0 x1 x2 LE MIN MON.
    revert LE; revert x2; rewrite leq_as_delta; intros delta.
    induction x1; try rewrite add0n.
    {
      induction delta; first by apply leqnn.
      apply leq_trans with (n := iter delta f x0); first by done.
      clear IHdelta.
      induction delta; first by done.
      {
        rewrite 2!iterS; apply MON.
        apply IHdelta.
      }
    }
    {
      rewrite iterS -addn1 -addnA [1 + delta]addnC addnA addn1 iterS.
      by apply MON, IHx1.
    }
  Qed.

  Lemma fun_mon_iter_mon_helper :
    forall T (f: T -> T) (le: rel T) x0 x1,
      reflexive le ->
      transitive le ->
      (forall x2, le x0 (iter x2 f x0)) ->
      (forall x1 x2, le x0 x1 -> le x1 x2 -> le (f x1) (f x2)) ->
      le (iter x1 f x0) (iter x1.+1 f x0).
  Proof.
    intros T f le x0 x1 REFL TRANS MIN MON.
    generalize dependent x0.
    induction x1; first by ins; apply (MIN 1).
    by ins; apply MON; [by apply MIN | by apply IHx1].
  Qed.

  Lemma fun_mon_iter_mon_generic :
    forall T (f: T -> T) (le: rel T) x0 x1 x2,
      reflexive le ->
      transitive le ->
      x1 <= x2 ->
      (forall x1 x2, le x0 x1 -> le x1 x2 -> le (f x1) (f x2)) ->
      (forall x2 : nat, le x0 (iter x2 f x0)) ->
      le (iter x1 f x0) (iter x2 f x0).
  Proof.
    intros T f le x0 x1 x2 REFL TRANS LE MON MIN.
    revert LE; revert x2; rewrite leq_as_delta; intros delta.
    induction delta; first by rewrite addn0; apply REFL.
    apply (TRANS) with (y := iter (x1 + delta) f x0);
      first by apply IHdelta.
    by rewrite addnS; apply fun_mon_iter_mon_helper.
  Qed.

End FixedPoint.

(* In this section, we define some properties of relations
   that are important for fixed-point iterations. *)
Section Relations.

  Context {T: Type}.
  Variable R: rel T.
  Variable f: T -> T.

  Definition monotone (R: rel T) :=
    forall x y, R x y -> R (f x) (f y).

End Relations.

(* In this section we define a fixed-point iteration function
   that stops as soon as it finds the solution. If no solution
   is found, the function returns None. *)
Section Iteration.

  Context {T : eqType}.
  Variable f: T -> T.

  Fixpoint iter_fixpoint max_steps (x: T) :=
    if max_steps is step.+1 then
      let x' := f x in
        if x == x' then
          Some x
        else iter_fixpoint step x'
    else None.

  Section BasicLemmas.

    (* We prove that iter_fixpoint either returns either None
       or Some y, where y is a fixed point. *)
    Lemma iter_fixpoint_cases :
      forall max_steps x0,
        iter_fixpoint max_steps x0 = None \/
        exists y,
          iter_fixpoint max_steps x0 = Some y /\
          y = f y.
    Proof.
      induction max_steps.
      {
        by ins; simpl; destruct (x0 == f x0); left.
      }
      {
        intros x0; simpl.
        destruct (x0 == f x0) eqn:EQ1;
          first by right; exists x0; split; last by apply/eqP.
        by destruct (IHmax_steps (f x0)) as [NONE | FOUND].
      }
    Qed.

    (* We also show that any inductive property P is propagated
       through the fixed-point iteration. *)
    Lemma iter_fixpoint_ind:
      forall max_steps x0 x,
        iter_fixpoint max_steps x0 = Some x ->
        forall P,
          P x0 ->
          (forall x, P x -> P (f x)) ->
          P x.
    Proof.
      induction max_steps; first by done.
      intros x0 x SOME P P0 ALL.
      move: SOME; simpl.
      case EQ: (_ == _).
      {
        move: EQ => /eqP EQ.
        case => SAME; subst.
        by rewrite EQ; apply ALL.
      }
      {
        intros SOME; clear EQ.
        apply (IHmax_steps (f x0) x SOME P); first by apply ALL.
        by apply ALL.
      }
    Qed.

  End BasicLemmas.

  Section RelationLemmas.

    Variable R: rel T.
    Hypothesis H_reflexive: reflexive R.
    Hypothesis H_transitive: transitive R.
    Hypothesis H_monotone: monotone f R.

    Lemma iter_fixpoint_ge_min:
      forall max_steps x0 x1 x,
        iter_fixpoint max_steps x1 = Some x ->
        R x0 x1 ->
        R x1 (f x1) ->
        R x0 x.
    Proof.
      induction max_steps; first by done.
      {
        intros x0 x1 x SOME MIN BOT; simpl in SOME.
        destruct (x1 == f x1) eqn:EQ1;
          first by inversion SOME; subst.
        apply IHmax_steps with (x0 := x0) in SOME; first by done.
        - by apply (@H_transitive x1).
        - by apply H_monotone.
      }
    Qed.

    Lemma iter_fixpoint_ge_bottom:
      forall max_steps x0 x,
        iter_fixpoint max_steps x0 = Some x ->
        R x0 (f x0) ->
        R x0 x.
    Proof.
      intros max_steps x0 x SOME BOT.
      by apply iter_fixpoint_ge_min with (max_steps := max_steps) (x1 := x0).
    Qed.

  End RelationLemmas.

End Iteration.