Require Export ZArith List Arith Bool.

Inductive month : Set
  := January | February | March | April | May | June
     | July | August | September | October | November | December.

(* Exercise 6.1
   Define an inductive type for seasons and then use the function
   [month_rec] to define a function that maps every month to the season that
   contains most of its days. *)
Inductive season : Set := Winter | Spring | Summer | Fall.

Check season_rec.
(* season_rec : forall P : season -> Set,
   P Winter -> P Spring -> P Summer -> P Fall
   -> forall s : season, P s *)

Definition is_winter : season -> bool.
  intro s. apply season_rec.
  - (* Winter *) exact true.
  - (* Spring *) exact false.
  - (* Summer *) exact false.
  - (* Fall   *) exact false.
  - exact s.
Defined.

Print is_winter.
(* is_winter : season -> bool
   := fun s : season
      => season_rec (fun _ : season => bool) true false false false s *)

Compute (is_winter Winter). (* = true : bool *)
Compute (is_winter Fall). (* = false : bool *)

Definition season_of_month : month -> season
  := month_rec (fun _ : month => season)
               Winter Winter
               Spring Spring Spring
               Summer Summer Summer
               Fall Fall Fall
               Winter.

Compute (season_of_month December). (* = Winter : season *)
Compute (season_of_month July). (* = Summer : season *)

(* Exercise 6.2
   What are the types of [bool_ind] and [bool_rec] that are
   generated by the Coq system for the type bool? *)
Check bool_ind.
(* bool_ind : forall P : bool -> Prop,
     P true -> P false -> forall b : bool, P b *)

(* 6.1.2 Simple Reasoning and Computing *)
Theorem month_equal (m : month)
 : m=January \/ m=February \/ m=March \/ m=April \/ m=May \/ m=June
   \/ m=July \/ m=August \/  m=September \/ m=October \/ m=November
   \/ m=December.
Proof. destruct m; auto 12. Qed.

(** explicit use of month_ind: *)
Theorem month_equal' (m : month)
 : m=January \/ m=February \/ m=March \/ m=April
   \/ m=May \/ m=June \/ m=July \/ m=August
   \/ m=September \/ m=October \/ m=November \/ m=December.
Proof. pattern m. apply month_ind; auto 12. Qed.

(* Exercise 6.3 Prove in two different ways the following theorem:
   1. Give directly a proof term, with occurences of
      bool_ind, or_introl, or_intror and refl_equal.
   2. Use the following tactics :
      pattern, apply, left, right, and reflexivity. *)
Theorem bool_cases (b : bool) : b = true \/ b = false.
Proof.
  exact (bool_ind (fun c => c = true \/ c = false)
                  (or_introl eq_refl)
                  (or_intror eq_refl) b).
Qed.

Theorem bool_cases' (b : bool) : b = true \/ b = false.
Proof. pattern b. apply bool_ind; [left | right]; reflexivity. Qed.

Theorem bool_cases'' (b : bool) : b = true \/ b = false.
Proof. destruct b; [left | right]; reflexivity. Qed.

(* 6.1.4 Pattern Matching *)
Check (fun b : bool => match b with false => 45 | true => 33 end).
(* fun b : bool => if b then 33 else 45 : bool -> nat *)

Definition month_length (leap : bool) (m : month) : nat
  := match m with
     | January => 31 | February => if leap then 29 else 28
     | March => 31   | April => 30    | May => 31  | June => 30
     | July => 31    | August => 31   | September => 30
     | October => 31 | November => 30 | December => 31
     end.

Definition month_length' (leap : bool)
  := month_rec (fun _ : month => nat)
               31 (if leap then 29 else 28)
               31 30 31 30 31 31 30 31 30 31.

Definition month_length'' (leap : bool) (m : month)
  := match m with
     | February => if leap then 29 else 28
     | April  | June  | September | November => 30
     | _  => 31
     end.

Example month_length_eq1 : month_length = month_length'.
Proof. reflexivity. Qed.

Example month_length_eq2 : month_length = month_length''.
Proof. reflexivity. Qed.

Eval compute in (fun leap => month_length leap November).
(* = fun _ : bool => 30 : bool -> nat *)

Example length_february : month_length false February = 28.
Proof. reflexivity. Qed.

(* Exercise 6.4
   Using the type introduced for seasons in Exercise 6.1 page 139,
   write the function that maps any month to the season
   that contains most of its days, this time
   using the pattern matching construct. *)

Definition season_of_month' (m : month) : season
  := match m with
     | December | January | February => Winter
     | March | April | May => Spring
     | June | July | August => Summer
     | September | October | November => Fall
     end.

Example season_of_month_eq : season_of_month = season_of_month'.
Proof. reflexivity. Qed.

(* Exercise 6.5
   Write the function that maps every month that has an even
   number of days to the boolean value true and the others to false. *)
Definition is_even_days_in_month (leap : bool) (m : month)
  := Nat.even (month_length leap m).

(* Exercise 6.6
   Define the functions associated with the following boolean connectives:
   Notice that these functions are already defined in the standard library
   under the names negb, orb, andb, xorb and Bool.eqb. *)
Definition bool_not (b : bool) : bool := if b then false else true.
Definition bool_or (a b : bool) : bool
  := if a then true else
       if b then true else false.
Definition bool_and (a b : bool) : bool := if a then b else false.
Definition bool_xor (a b : bool) : bool
  := if a then bool_not b else b.
Definition bool_eq (a b : bool) : bool
  := if a then b else bool_not b.

(* Prove the following theorems: *)
Theorem bool_xor_not_eq (b1 b2 : bool)
  : bool_xor b1 b2 = bool_not (bool_eq b1 b2).
Proof. destruct b1, b2; reflexivity. Qed.

Theorem bool_not_and (b1 b2 : bool)
  : bool_not (bool_and b1 b2) = bool_or (bool_not b1) (bool_not b2).
Proof. destruct b1, b2; reflexivity. Qed.

Theorem bool_not_not (b : bool) : bool_not (bool_not b) = b.
Proof. destruct b; reflexivity. Qed.

Theorem bool_tex (b : bool) : bool_or b (bool_not b) = true.
Proof. destruct b; reflexivity. Qed.

Theorem bool_eq_reflect (b1 b2 : bool) : bool_eq b1 b2 = true -> b1 = b2.
Proof.
  destruct b1, b2; simpl; intro H;
    try rewrite H; reflexivity.
Qed.

Theorem bool_eq_reflect2 (b1 b2 : bool) : b1 = b2 -> bool_eq b1 b2 = true.
Proof. intro H. subst b2. destruct b1; reflexivity. Qed.

Theorem bool_not_or (b1 b2 : bool)
  : bool_not (bool_or b1 b2) = bool_and (bool_not b1) (bool_not b2).
Proof. destruct b1, b2; reflexivity. Qed.

Theorem bool_or_and_distr (b1 b2 b3 : bool)
  : bool_or (bool_and b1 b3) (bool_and b2 b3) = bool_and (bool_or b1 b2) b3.
Proof. destruct b1, b2, b3; reflexivity. Qed.

(* 6.1.5 Record Types *)
Open Scope Z_scope.
Inductive plane : Set := point : Z -> Z -> plane.
(*
plane is defined
plane_rect is defined
plane_ind is defined
plane_rec is defined
plane_sind is defined
*)

Check point. (* point : Z -> Z -> plane *)
Check plane_ind.
(* plane_ind : forall P : plane -> Prop,
   (forall z z0 : Z, P (point z z0)) -> forall p : plane, P p *)

Definition abscissa (p : plane) : Z
  := match p with point x y => x end.
Check abscissa. (* abscissa : plane -> Z *)

Reset plane. (* also reset [abscissa] *)

Record plane : Set := point {abscissa : Z; ordinate : Z}.
(*
plane is defined
abscissa is defined
ordinate is defined
*)
Print plane.
(* Record plane : Set := point { abscissa : Z;  ordinate : Z } *)
Check point. (* point : Z -> Z -> plane *)
Check abscissa. (* abscissa : plane -> Z *)
Print abscissa.
(* abscissa : plane -> Z
   := fun p : plane => let (abscissa, _) := p in abscissa *)

(* Exercise 6.7 What is the type of plane_rec? *)
(* Check plane_rec. *)
(* Error: The reference plane_rec was not found in the current environment. *)

(* Exercise 6.8
   Define a function that computes the "Manhattan" distance for
   points of the plane (the Manhattan distance
   is the sum of the absolute values of differences of coordinates). *)
Definition manhattan_distance (p1 p2 : plane) : Z
  := let (x1, y1) := p1 in
     let (x2, y2) := p2 in
     Z.abs (x1 - x2) + Z.abs (y1 - y2).

Check (point 1 2).
Check (point 1 (-2)).

Example manhattan_distance_ex
  : manhattan_distance (point (-1) (-2)) (point 4 2) = 9.
Proof. reflexivity. Qed.

(* 6.1.6 Records with Variants *)
Inductive vehicle : Set
  := bicycle (* [number of seats] *) : nat -> vehicle
   | motorized (* [number of seats, number of wheels] *)
     : nat -> nat -> vehicle.

Check vehicle_ind.
(* vehicle_ind : forall P : vehicle -> Prop,
   (forall n : nat, P (bicycle n)) ->
   (forall n n0 : nat, P (motorized n n0)) -> forall v : vehicle, P v *)

Definition nb_seats (v : vehicle) : nat
  := match v with
     | bicycle n => n
     | motorized n _ => n
     end.

Definition nb_wheels (v : vehicle) : nat
  := match v with
     | bicycle _ => 2
     | motorized _ m => m
     end.

(* Exercise 6.9
   What is the type of [vehicle_rec]? Use this function to define
   an equivalent to [nb_seats]. *)
Check vehicle_rec.
(* vehicle_rec : forall P : vehicle -> Set,
   (forall n : nat, P (bicycle n)) ->
   (forall n n0 : nat, P (motorized n n0)) -> forall v : vehicle, P v *)

Definition nb_seats' : vehicle -> nat
  := vehicle_rec (fun _ : vehicle => nat)
                 (fun n => n)
                 (fun n _ => n).

Example nb_seats_eq : nb_seats = nb_seats'.
Proof. reflexivity. Qed.

(* 6.2 Case-Based Reasoning *)
Open Scope nat_scope.
Theorem at_least_28 (leap : bool) (m : month)
  : 28 <= month_length leap m.
Proof. case m, leap; simpl; auto with arith. Qed.

Theorem at_least_28' (leap : bool) (m : month)
  : 28 <= month_length leap m.
Proof.
  case m, leap; simpl;
    repeat ( try apply le_n; apply le_S ).
Qed.

Print at_least_28.
(* at_least_28 : forall (leap : bool) (m : month), 28 <= month_length leap m
  := fun (leap : bool) (m : month) =>
       match m as m0 return (28 <= month_length leap m0) with
       | January =>
         if leap as b return (28 <= month_length b January)
         then le_S 28 30 (le_S 28 29 (le_S 28 28 (le_n 28)))
         else le_S 28 30 (le_S 28 29 (le_S 28 28 (le_n 28)))
       | February =>
         if leap as b return (28 <= month_length b February)
         then le_S 28 28 (le_n 28)
         else le_n 28
       ...
       end. *)

(* 6.2.2.1 The discriminate Tactic *)
Definition next_month (m : month)
  := match m with
     | January => February  | February => March | March => April
     | April => May         | May => June       | June => July
     | July => August       | August => September
     | September => October | October => November
     | November => December | December => January
     end.

Theorem next_august_then_july (m : month) : next_month m = August -> m = July.
Proof.
  case m; simpl; intros H;
    (reflexivity || discriminate H).
Qed.

(* 6.2.2.2 ** The Inner Workings of discriminate *)
Theorem not_January_eq_February : January <> February.
Proof. discriminate. Qed.

(* not using [discriminate] *)
Theorem not_January_eq_February' : January <> February.
Proof.
  unfold not. intros H.
  change ((fun m : month
           => match m with | January => True | _ => False end)
            February).
  now rewrite <- H.
Qed.

(* not using [change], [rewrite] and [reflexivity] *)
Theorem not_January_eq_February'' : January <> February.
Proof.
  unfold not. intros H.
  pose (f := (fun m : month
              => match m with
                 | January => True
                 | _ => False end)).
  apply (eq_ind (f February) (fun P => P)).
  - apply (eq_ind January f).
    + unfold f. apply I.
    + exact H.
  - unfold f. apply eq_refl.
Qed.

(* Exercise 6.10
   Define a function [is_January] that maps [January] to [True]
   and any other month to [False], using the function [month_rect]. *)
Definition is_January' (m : month) : Prop
  := match m with
     | January => True
     | _ => False
     end.

Definition is_January : month -> Prop
  := month_rect (fun _ => Prop)
                True
                False False False False False False False False
                False False False.

Example is_January_eq : is_January = is_January'.
Proof. reflexivity. Qed.

(* Try to automate applying [month_rect (fun _ => Prop) True]
   to [False] 11 times *)
Definition add_arg_type (A B : Type) : Type := A -> B.
Compute ((add_arg_type Prop) ((add_arg_type Prop) nat)).
(* = Prop -> Prop -> nat : Type *)

Fixpoint iterate (A : Type) (f : A -> A) (n : nat) (a : A) : A
  := match n with
     | O => a
     | S n' => iterate A f n' (f a)
     end.
Compute (iterate nat S 3 O). (* = 3 : nat *)
Compute (iterate Type (add_arg_type Prop) 3 nat).
(* = Prop -> Prop -> Prop -> nat : Type *)

Definition add_n_arg_types (A B : Type) (n : nat) : Type
  := (iterate Type (add_arg_type A) n B).
Compute (add_n_arg_types Prop nat 3).
(* = Prop -> Prop -> Prop -> nat : Type *)
Compute (add_n_arg_types Prop nat 0). (* = nat : Type *)

(* TODO Attempt failed *)
(* Fixpoint repeat_arg (A B : Type) (a : A)
         (n : nat) (f : add_n_arg_types A B n) : B
  := match n with
     | O => f (* The term "f" has type "add_n_arg_types A B n"
                 while it is expected to have type "B". *)
     | S n' => repeat_arg A B a n' (f a)
     end. *)

(* Fixpoint repeat_arg (A B : Type) (a : A)
         (n : nat) (f : add_n_arg_types A B n) : B
  := match n
           return (match n with
                   | O => add_n_arg_types A B n
                   | S n' => add_n_arg_types A B n'
                   end)
     with
     | O => f (* The term "f" has type "add_n_arg_types A B n"
                 while it is expected to have type "add_n_arg_types A B 0". *)
     | S n' => repeat_arg A B a n' (f a)
     end. *)

Reset iterate.

(* Exercise 6.11 *
   Use the same technique to build a proof of [true <> false]. *)
Theorem true_is_not_false : true <> false.
Proof. discriminate. Qed.

Theorem true_is_not_false' : true <> false.
Proof.
  intro H.
  change ((fun b : bool => if b then True else False) false).
  now rewrite <- H.
Qed.

(* Exercise 6.12
   For the [vehicle] type (see Sect. 6.1.6), use the same technique
   to build a proof that no [bicycle] is equal to a [motorized] vehicle. *)
Theorem bicycle_is_not_motorized (n m : nat) : bicycle n <> motorized n m.
Proof. discriminate. Qed.

Theorem bicycle_is_not_motorized' (n m : nat) : bicycle n <> motorized n m.
Proof.
  intro H.
  change ((fun v : vehicle
           => match v with
              | bicycle _ => False
              | motorized _ _ => True
              end) (bicycle n)).
  now rewrite H.
Qed.

(* 6.2.3 Injective Constructors *)
Theorem bicycle_eq_seats (x1 y1 : nat) : bicycle x1 = bicycle y1 -> x1 = y1.
Proof. intro H. now injection H. Qed.

(* Simulating injection (for the fun) *)
Theorem bicycle_eq_seats' (x1 y1 : nat) : bicycle x1 = bicycle y1 -> x1 = y1.
Proof.
 intro H.
 change (nb_seats (bicycle x1) = nb_seats (bicycle y1)).
 rewrite H. reflexivity.
Qed.

(* use more primitive tactics *)
Theorem bicycle_eq_seats'' (x1 y1 : nat) : bicycle x1 = bicycle y1 -> x1 = y1.
Proof.
 intro H.
 apply (eq_ind (bicycle x1)
               (fun v : vehicle => nb_seats (bicycle x1) = nb_seats v)
               (eq_refl (nb_seats (bicycle x1)))
               (bicycle y1) H).
Qed.

Section injection_example.
  Variables A B : Set.
  Inductive T : Set := c1 : A -> T | c2 : B -> T.

  Theorem inject_c2 (x y : B) : c2 x = c2 y -> x = y.
  Proof using. intro H. now injection H. Qed.

  Theorem inject_c2' (x y : B) : c2 x = c2 y -> x = y.
  Proof using.
    intro H.
    pose (fun t : T => match t with | c1 a => x | c2 b => b end) as f.
    change (f (c2 x) = f (c2 y)).
    rewrite H. reflexivity.
  Qed.
End injection_example.

(* 6.2.4 Inductive Types and Equality *)

(* Exercise 6.13 **
   This exercise shows a use of discriminate and underlines
   the danger of adding axioms to the system.
   The ''theory'' introduced here proposes a description of rational numbers
   as fractions with a non-zero denominator. An axiom is added to
   indicate that two rational numbers are equal as soon
   as they satisfy a classical arithmetic condition. *)

Require Import Arith.

Record RatPlus : Set
  := mkRat {top : nat; bottom : nat; bottom_condition : bottom <> 0}.

Axiom eq_RatPlus : forall r1 r2 : RatPlus,
    top r1 * bottom r2 = top r2 * bottom r1 -> r1 = r2.

Theorem eq_RatPlus_imp_False : False.
Proof.
  pose (mkRat 1 1 (Nat.neq_succ_0 _)) as r1.
  pose (mkRat 2 2 (Nat.neq_succ_0 _)) as r2.
  assert (r1 = r2) as eq.
  { apply eq_RatPlus. reflexivity. }
  discriminate eq.
Qed.

Reset RatPlus.

(* 6.2.5 * Guidelines for the case Tactic *)
(* solution from authors *)
Theorem next_march_shorter (leap : bool) (m1 m2 : month)
  : next_month m1 = March
    -> month_length leap m1 <= month_length leap m2.
Proof.
  intros H.
  case_eq m1; intro eq; rewrite eq in H; simpl in H;
    try discriminate H.
  case leap, m2; simpl; auto with arith.
Qed.

(* my solution using destruct *)
Theorem next_march_shorter1 (leap : bool) (m1 m2 : month)
  : next_month m1 = March
    -> month_length leap m1 <= month_length leap m2.
Proof.
  intros H. destruct m1; simpl in H; try discriminate H.
  destruct leap, m2; simpl; auto with arith.
Qed.

(* my solution using [case] with delaying [into] *)
Theorem next_march_shorter2 (leap : bool) (m1 m2 : month)
  : next_month m1 = March
    -> month_length leap m1 <= month_length leap m2.
Proof.
  case m1; simpl; intro H; try discriminate H.
  case leap, m2; simpl; auto with arith.
Qed.

(* use generalize *)
Theorem next_march_shorter3 (leap : bool) (m1 m2 : month)
  : next_month m1 = March
    -> month_length leap m1 <= month_length leap m2.
Proof.
  intro H. generalize H. clear H.
  case m1; simpl; intros H; try discriminate H.
  case leap, m2; simpl; auto with arith.
Qed.

(* introduce equality *)
Theorem next_march_shorter4 (leap : bool) (m1 m2 : month)
  : next_month m1 = March
    -> month_length leap m1 <= month_length leap m2.
Proof.
  intro H. generalize (eq_refl m1). pattern m1 at -1.
  case m1; intro eq; rewrite eq in H; simpl in H;
    try discriminate H.
  case leap, m2; simpl; auto with arith.
Qed.

(* how to define own case_eq tactic *)
Ltac caseEq f := generalize (refl_equal f); pattern f at -1; case f.

(* test it *)
Theorem next_march_shorter5 (leap : bool) (m1 m2 : month)
  : next_month m1 = March
    -> month_length leap m1 <= month_length leap m2.
Proof.
  intros H.
  caseEq m1; intro eq; rewrite eq in H; simpl in H;
    try discriminate H.
  case leap, m2; simpl; auto with arith.
Qed.

(* New exercise - On partial functions
 Complete the following development: *)
Section partial_functions.
  Variable P : nat -> Prop.
  Variable f : nat -> option nat.

  Hypothesis f_domain : forall n, P n <-> f n <> None.

  Definition g n : option nat
    := match f (n + 2) with
       | None => None
       | Some y => Some (y + 2)
       end.

  Lemma g_domain : forall n, P (n + 2) <-> g n <> None.
  Proof using f_domain.
    intro n. unfold g. split; intro H.
    - cut (f (n + 2) <> None).
      + intro H'.
        destruct (f (n + 2)) eqn:eq; [discriminate | assumption].
      + apply f_domain, H.
    - apply f_domain.
      destruct (f (n + 2)) eqn:eq; [discriminate | assumption].
  Qed.

End partial_functions.

(* 6.3 Recursive Types *)
Print nat. (* Inductive nat : Set :=  O : nat | S : nat -> nat *)
Check plus. (* Init.Nat.add : nat -> nat -> nat *)
Check plus_O_n. (* plus_O_n : forall n : nat, 0 + n = n *)
Check plus_Sn_m. (* plus_Sn_m : forall n m : nat, S n + m = S (n + m) *)

(* A first, detailed, proof of associativity of + *)
(* authors' solution *)
Theorem plus_assoc (x y z : nat) : x + (y + z) = (x + y) + z.
Proof.
  induction x as [| x0 IH].
  - simpl. reflexivity.
  - simpl. rewrite IH. reflexivity.
Qed.

(* my variation *)
Theorem plus_assoc' (x y z : nat) : (x + y) + z = x + (y + z).
Proof.
  induction x as [| x' IH]; simpl; [| rewrite IH]; reflexivity.
Qed.

Theorem plus_assoc'' (x y z : nat) : (x + y) + z = x + (y + z).
Proof.
  pattern x.
  apply nat_ind; simpl; [| intros x' IH; rewrite IH]; reflexivity.
Qed.

Theorem plus_n_O (n : nat) : n + 0 = n.
Proof.
  induction n as [| p IH]; try reflexivity.
  simpl. rewrite IH. reflexivity.
Qed.

Theorem plus_n_Sm (n m : nat) : n + (S m) = S (n + m).
Proof.
  induction n as [| p IH]; try reflexivity.
  simpl. rewrite IH. reflexivity.
Qed.

Theorem plus_comm (n m : nat) : n + m = m + n.
Proof.
  induction n as [| p IH].
  - rewrite plus_n_O. reflexivity.
  - simpl. rewrite IH, plus_n_Sm. reflexivity.
Qed.

(* 6.3.3 Recursive Programming *)
Fixpoint mult2 (n : nat) : nat
  := match n with
     | 0 => 0
     | S p => S (S (mult2 p))
     end.

Fixpoint iterate {A : Type} (f : A -> A) (n : nat) (x : A) {struct n} : A
  := match n with
     | O => x
     | S p => f (iterate f p x)
     end.

(* Tail call *)
Fixpoint iterate' {A : Type} (f : A -> A) (n : nat) (x : A) {struct n} : A
  := match n with
     | O => x
     | S p => iterate' f p (f x)
     end.

Theorem iterate_step {A : Type} (f : A -> A) (n : nat) (x : A)
  : iterate f (S n) x = f (iterate f n x).
Proof. reflexivity. Qed.

Theorem iterate'_step {A : Type} (f : A -> A) (n : nat) (x : A)
  : iterate' f (S n) x = iterate' f n (f x).
Proof. reflexivity. Qed.

Theorem iterate_fstep {A : Type} (f : A -> A) (n : nat) (x : A)
  : iterate f n (f x) = f (iterate f n x).
Proof.
  generalize dependent x.
  induction n as [| p IH]; try reflexivity.
  simpl. intro x. now rewrite IH.
Qed.

Theorem iterate'_fstep {A : Type} (f : A -> A) (n : nat) (x : A)
  : iterate' f n (f x) = f (iterate' f n x).
Proof.
  generalize dependent x.
  induction n as [| p IH]; try reflexivity.
  simpl. intro x. apply IH.
Qed.

Theorem iterate_eq {A : Type} (f : A -> A) (n : nat) (x : A)
  : iterate f n x = iterate' f n x.
Proof.
  induction n as [| p IH]; try reflexivity.
  simpl. rewrite IH, iterate'_fstep. reflexivity.
Qed.

Theorem iterate_fixpoint {X : Type} (f : X -> X) (x : X)
  : f x = x -> forall n : nat, iterate f n x = x.
Proof.
  intros H n. induction n as [| n' IH]; try reflexivity.
  simpl. now rewrite IH, H.
Qed.

Theorem iterate_fixpoint1 {X : Type} (f : X -> X) (x y : X)
  : f x = y -> f y = y -> forall n : nat, iterate f (S n) x = y.
Proof.
  intros H0 H n. rewrite iterate_eq. simpl. rewrite H0.
  now rewrite <- iterate_eq, iterate_fixpoint.
Qed.

(* Exercise 6.14
   Reproduce the above discussion for the function mult:
   compile a table describing convertibility
   for simple patterns of the two arguments. *)
Example mult_O_O : 0 * 0 = 0.
Proof. reflexivity. Qed.

Example mult_O_m (m : nat) : 0 * m = 0.
Proof. reflexivity. Qed.

Example mult_Sn_m (n m : nat) : (S n) * m = m + n * m.
Proof. reflexivity. Qed.

Theorem mult_n_O (n : nat) : n * 0 = 0.
Proof.
  induction n as [| p IH]; try reflexivity.
  simpl. assumption.
Qed.

Example mult_n_Sm (n m : nat) : n * (S m) = n + n * m.
Proof.
  induction n as [| p IH]; try reflexivity.
  simpl. rewrite IH. apply eq_S.
  repeat rewrite plus_assoc.
  pattern (m + p). rewrite plus_comm. reflexivity.
Qed.

Theorem mult_comm (n m : nat) : n * m = m * n.
Proof.
  induction n as [| p IH].
  - rewrite mult_n_O. reflexivity.
  - simpl. rewrite IH, mult_n_Sm. reflexivity.
Qed.

(* Exercise 6.15
   Define a function of type [nat -> bool] that only returns [true]
   for numbers smaller than 3, in other terms [S (S (S 0))] *)
Definition smaller_than_three (n : nat) : bool
  := match n with
     | O | S O | S (S O) => true
     | _ => false
     end.

Example zero_is_smaller_than_three : smaller_than_three 0 = true.
Proof. reflexivity. Qed.

Example two_is_smaller_than_three : smaller_than_three 2 = true.
Proof. reflexivity. Qed.

Example three_is_not_smaller_than_three : smaller_than_three 3 = false.
Proof. reflexivity. Qed.

Example fourty_five_is_not_smaller_than_three
  : smaller_than_three 45 = false.
Proof. reflexivity. Qed.

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

Theorem smaller_than_is_ltb (n m : nat) : smaller_than n m = (n <? m).
Proof.
  generalize dependent m.
  induction n as [| n' IHn]; intro m.
  - destruct m as [| m']; reflexivity.
  - destruct m as [| m']; try reflexivity.
    simpl. rewrite IHn.
    destruct (n' <? m') eqn:H; symmetry.
    + apply Nat.ltb_lt, lt_n_S, Nat.ltb_lt, H.
    + apply Nat.ltb_nlt in H. apply Nat.ltb_nlt.
      intro H'. apply H, lt_S_n, H'.
Qed.

Definition smaller_than_three' (n : nat) : bool := smaller_than n 3.

Theorem smaller_than_three_eq (n : nat)
  : smaller_than_three n = smaller_than_three' n.
Proof.
  unfold smaller_than_three'.
  destruct n as [| [| [| [| p]]]]; reflexivity.
Qed.

(* Exercise 6.16
   Define an addition function so that the principal argument is
   second instead of first argument. *)
Fixpoint left_add (n m : nat) {struct m} : nat
  := match m with
     | O => n
     | S p => S (left_add n p)
     end.

Theorem left_add_correct (n m : nat) : left_add n m = n + m.
Proof.
  induction m as [| p IH].
  - rewrite plus_n_O. reflexivity.
  - rewrite plus_n_Sm. simpl.
    rewrite IH. reflexivity.
Qed.

(* Exercise 6.17
   Define a function [sum_f] that takes as arguments a number [n]
   and a function [f] of type [nat -> Z] and returns the sum of
   all values of [f] for the natural numbers
   that are strictly smaller than [n] *)
Fixpoint sum_f (n : nat) (f : nat -> Z) {struct n} : Z
  := match n with
     | O => 0
     | S p => (f p) + sum_f p f
     end.

Example sum_id1 : sum_f 1 Z.of_nat = 0%Z.
Proof. reflexivity. Qed.

Example sum_id3 : sum_f 3 Z.of_nat = 3%Z.
Proof. reflexivity. Qed.

Example sum_id4 : sum_f 4 Z.of_nat = 6%Z.
Proof. reflexivity. Qed.

Require Import Program.Basics.

Example sum_S4 : sum_f 4 (compose Z.of_nat S) = 10%Z.
Proof. reflexivity. Qed.

(* Exercise 6.18
   Define [two_power : nat -> nat] so that [two_power n] is [2^n]. *)
Definition two_power (n : nat) : nat := iterate (Nat.mul 2) n 1.

Example two_power0 : two_power 0 = 1.
Proof. reflexivity. Qed.

Example two_power1 : two_power 1 = 2.
Proof. reflexivity. Qed.

Example two_power3 : two_power 3 = 8.
Proof. reflexivity. Qed.

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

Lemma two_power_Sn (n : nat) : two_power (S n) = 2 * two_power n.
Proof. reflexivity. Qed.

Theorem two_power_eq (n : nat) : two_power n = two_power' n.
Proof.
  induction n as [| p IH]; try reflexivity.
  rewrite two_power_Sn. simpl. now rewrite ?IH.
Qed.

(* 6.3.4 Variations in the Form of Constructors *)
Open Scope Z_scope.
Inductive Z_btree : Set
  := Z_leaf : Z_btree
   | Z_bnode : Z -> Z_btree -> Z_btree -> Z_btree.

Check Z_btree_ind.
(* Z_btree_ind : forall P : Z_btree -> Prop,
   P Z_leaf
   -> (forall (z : Z) (z0 : Z_btree), P z0
      -> forall z1 : Z_btree, P z1 -> P (Z_bnode z z0 z1))
         -> forall z : Z_btree, P z *)

Print positive.
(* Inductive positive : Set
   := xI : positive -> positive
    | xO : positive -> positive
    | xH : positive *)

Check positive_ind.
(* positive_ind : forall P : positive -> Prop,
   (forall p : positive, P p -> P (p~1))
   -> (forall p : positive, P p -> P (p~0))
   -> P 1 -> forall p : positive, P p *)

Print Z.
(* Inductive Z : Set
   :=  Z0 : Z
    | Zpos : positive -> Z
    | Zneg : positive -> Z *)

Fixpoint sum_all_values (t : Z_btree) : Z
  := match t with
     | Z_leaf => 0
     | Z_bnode x t1 t2 => x + sum_all_values t1 + sum_all_values t2
     end.

Example sum_all_values_ex1 : sum_all_values Z_leaf = 0.
Proof. reflexivity. Qed.

Definition zbtree3 := Z_bnode 1 Z_leaf (Z_bnode 2 Z_leaf Z_leaf).
Example sum_all_values_ex2 : sum_all_values zbtree3 = 3.
Proof. reflexivity. Qed.

(* authors' solution *)
Fixpoint zero_present (t : Z_btree) : bool
  := match t with
     | Z_leaf => false
     | Z_bnode 0 t1 t2 => true
     | Z_bnode _ t1 t2 => zero_present t1 || zero_present t2
     end.

Fixpoint zero_present' (t : Z_btree) : bool
  := match t with
     | Z_leaf => false
     | Z_bnode x t1 t2 => (x =? 0) || zero_present' t1 || zero_present' t2
     end.

Example zero_present_ex1 : zero_present Z_leaf = false.
Proof. reflexivity. Qed.

Example zero_present_ex2 : zero_present zbtree3 = false.
Proof. reflexivity. Qed.

Definition zbtree01 := Z_bnode 0 Z_leaf Z_leaf.
Definition zbtree02 := Z_bnode 1 zbtree3 (Z_bnode 2 zbtree01 zbtree3).

Example zero_present_ex3 : zero_present zbtree01 = true.
Proof. reflexivity. Qed.

Example zero_present_ex4 : zero_present zbtree02 = true.
Proof. reflexivity. Qed.

Theorem zero_present_eq (t : Z_btree) : zero_present t = zero_present' t.
Proof.
  induction t as [| x t1 IH1 t2 IH2]; try reflexivity.
  simpl. rewrite IH1, IH2.
  destruct x as [| x_pos | x_neg]; try reflexivity.
Qed.

Open Scope positive_scope.

Fixpoint add_one (x : positive) : positive
  := match x with
     | xH => (xO xH)
     | xO p => xI p
     | xI p => xO (add_one p)
     end.

Example add_one_ex1 : add_one 1 = 2.
Proof. reflexivity. Qed.

Example add_one_ex2 : add_one 2 = 3.
Proof. reflexivity. Qed.

Example add_one_ex3 : add_one 3 = 4.
Proof. reflexivity. Qed.

Example add_one_ex31 : add_one 31 = 32.
Proof. reflexivity. Qed.

Example add_one_ex32 : add_one 32 = 33.
Proof. reflexivity. Qed.

Example add_one_ex33 : add_one 33 = 34.
Proof. reflexivity. Qed.

(* Exercise 6.19
   What is the representation in the type positive
   for numbers 1000, 25, 512? *)
Example pos25 : 25 = xI (xO (xO (xI xH))).
Proof. reflexivity. Qed.

Example pos512 : 512 = xO (xO (xO (xO (xO (xO (xO (xO (xO xH)))))))).
Proof. reflexivity. Qed.

Example pos1000 : 1000 = xO (xO (xO (xI (xO (xI (xI (xI (xI xH)))))))).
Proof. reflexivity. Qed.

Unset Printing Notations.
Check 1000. (* xO (xO (xO (xI (xO (xI (xI (xI (xI xH)))))))) : positive *)
Set Printing Notations.

(* Exercise 6.20
   Build the function [pos_even_bool] of type [positive -> bool]
   that returns the value [true] exactly when the argument is even. *)
Definition pos_even_bool (x : positive) : bool
  := match x with xO _ => true | _ => false end.

Example pos_even_bool_ex1 : pos_even_bool 1 = false.
Proof. reflexivity. Qed.

Example pos_even_bool_ex2 : pos_even_bool 2 = true.
Proof. reflexivity. Qed.

Example pos_even_bool_ex3 : pos_even_bool 3 = false.
Proof. reflexivity. Qed.

Example pos_even_bool_ex24 : pos_even_bool 24 = true.
Proof. reflexivity. Qed.

Example pos_even_bool_ex31 : pos_even_bool 31 = false.
Proof. reflexivity. Qed.

Lemma xI_is_not_even (x : positive) : Nat.even (Pos.to_nat x~1) = false.
Proof.
  rewrite Pos2Nat.inj_xI, <- Nat.add_1_l, Nat.even_add_mul_2. reflexivity.
Qed.

Theorem pos_even_bool_correct (x : positive)
  : pos_even_bool x = Nat.even (Pos.to_nat x).
Proof.
  destruct x as [p | p |]; try reflexivity.
  - rewrite Pos2Nat.inj_xI, <- Nat.add_1_l.
    rewrite Nat.even_add_mul_2. reflexivity.
  - rewrite Pos2Nat.inj_xO.
    pattern (2 * Pos.to_nat p)%nat. rewrite <- Nat.add_0_l.
    rewrite Nat.even_add_mul_2. reflexivity.
Qed.

(* Exercise 6.21
   Build the function [pos_div4] of type [positive -> Z]
   that maps any number [z] to the integer part of [z/4]. *)
Definition N_div2 (z : N) : N
  := match z with
     | Npos (xI p) | Npos (xO p) => Npos p
     | _ => N0
     end.

Example N_div2_ex0 : N_div2 N0 = N0.
Proof. reflexivity. Qed.

Example N_div2_ex1 : N_div2 1 = N0.
Proof. reflexivity. Qed.

Example N_div2_ex2 : N_div2 2 = 1%N.
Proof. reflexivity. Qed.

Example N_div2_ex3 : N_div2 3 = 1%N.
Proof. reflexivity. Qed.

Example N_div2_ex4 : N_div2 4 = 2%N.
Proof. reflexivity. Qed.

Example N_div2_ex20 : N_div2 20 = 10%N.
Proof. reflexivity. Qed.

Example N_div2_ex21 : N_div2 21 = 10%N.
Proof. reflexivity. Qed.

Theorem N_div2_correct (z : N) : N_div2 z = (z / 2)%N.
Proof.
  rewrite <- N.div2_div.
  destruct z as [| z']; reflexivity.
Qed.

Definition pos_div4 (z : positive) : Z
  := Z.of_N (N_div2 (N_div2 (Npos z))).

Example pos_div4_ex1 : pos_div4 1 = Z0.
Proof. reflexivity. Qed.

Example pos_div4_ex2 : pos_div4 2 = Z0.
Proof. reflexivity. Qed.

Example pos_div4_ex3 : pos_div4 3 = Z0.
Proof. reflexivity. Qed.

Example pos_div4_ex4 : pos_div4 4 = 1%Z.
Proof. reflexivity. Qed.

Example pos_div4_ex5 : pos_div4 5 = 1%Z.
Proof. reflexivity. Qed.

Example pos_div4_ex20 : pos_div4 20 = 5%Z.
Proof. reflexivity. Qed.

Example pos_div4_ex21 : pos_div4 23 = 5%Z.
Proof. reflexivity. Qed.

Definition pos_div4' (z : positive) : Z
  := match z with
     | xI (xI p) | xI (xO p) | xO (xI p) | xO (xO p) => Zpos p
     | _ => Z0
     end.

Theorem pos_div4_eq (z : positive) : pos_div4 z = pos_div4' z.
Proof.
  destruct z as [p | p |]; try reflexivity;
    destruct p as [p' | p' |]; reflexivity.
Qed.

Theorem pos_div4_correct (z : positive) : pos_div4 z = Zpos z / 4.
Proof.
  unfold pos_div4. rewrite 2 N_div2_correct.
  rewrite N.div_div; try discriminate. simpl.
  rewrite N2Z.inj_div. reflexivity.
Qed.

(* Exercise 6.22
   Assuming there exists a function [Pos.mul] t that describes the
   multiplication of two [positive] representations and returns
   a [positive] representation, use this function to build
   a function that multiplies numbers of type [Z]
   and returns a value of type [Z]. *)
Definition Z_mul (x y : Z) : Z
  := match x, y with
     | Z0, _ | _, Z0 => Z0
     | Zpos x', Zpos y' | Zneg x', Zneg y' => Zpos (Pos.mul x' y')
     | Zneg x', Zpos y' | Zpos x', Zneg y' => Zneg (Pos.mul x' y')
     end.

Theorem Z_mul_correct (x y : Z) : Z_mul x y = (x * y)%Z.
Proof. reflexivity. Qed.

(* Exercise 6.23
   Build the inductive type that represents the language of
   propositional logic without variables: *)
Inductive L : Set
  := L_and : L -> L -> L
   | L_or : L -> L -> L
   | L_not : L -> L
   | L_impl : L -> L -> L
   | L_True | L_False.

Check (L_and L_True (L_impl (L_not L_True) L_False)).

Fixpoint L_ev (f : L) : bool
  := match f with
     | L_and x y => (L_ev x) && (L_ev y)
     | L_or x y => (L_ev x) || (L_ev y)
     | L_not x => negb (L_ev x)
     | L_impl x y => implb (L_ev x) (L_ev y)
     | L_True => true
     | L_False => false
     end.

Example L_ev_ex : L_ev (L_and L_True (L_impl (L_not L_True) L_False)) = true.
Proof. reflexivity. Qed.

(* Exercise 6.24 *
   Every strictly positive rational number can be obtained in a
   unique manner by a succession of applications of functions N and D on the
   number one, where N and D are defined by the following equations:
   N(x) = 1 + x
   D(x) = 1 / (1 + 1/x)
   We can associate any strictly positive rational number with an element of
   an inductive type with one constructor for one, and two other constructors
   representing the functions N and D. Define this inductive type
   (see the related exercise 6.44). *)
Inductive F : Set
  := one : F (* 1 *)
   | n : F -> F (* 1 + f *)
   | d : F -> F (* 1 / (1 + (1 / f)) *)
.

(* Exercise 6.25
   Define a function [value_present] with the type
   [value_present : Z -> Z_btree -> bool]
   that determines whether an integer appears in a binary tree. *)
Fixpoint value_present (z : Z) (t : Z_btree) {struct t} : bool
  := match t with
     | Z_leaf => false
     | Z_bnode x t1 t2 => (x =? z)%Z || value_present z t1 || value_present z t2
     end.

(* Exercise 6.26
   Define a function [power: Z -> nat -> Z] to compute
   the power of an integer and
   a function [discrete_log : positive -> nat] that maps
   any number [p] to the number [n] such that 2^n <= p < 2^(n+1). *)
Fixpoint power (z : Z) (n : nat) {struct n} : Z
  := match n with
     | O => 1
     | S p => z * power z p
     end.

Example power_ex1 : power 3 3 = 27%Z.
Proof. reflexivity. Qed.

Theorem two_power_is_power (n : nat) : Z.of_nat (two_power n) = power 2 n.
Proof.
  rewrite two_power_eq.
  induction n as [| p IH]; try reflexivity.
  cbv delta [two_power' power] beta iota.
  fold two_power' power.
  rewrite Nat2Z.inj_mul. rewrite IH. reflexivity.
Qed.

Theorem power_correct (z : Z) (n : nat) : power z n = Zpower_nat z n.
Proof.
  induction n as [| p IH]; try reflexivity.
  simpl. rewrite IH. reflexivity.
Qed.

Fixpoint discrete_log (z : positive) : nat
  := match z with
     | xH => O
     | xO p | xI p => S (discrete_log p)
     end.

Example discrete_log_ex1 : discrete_log 1 = 0%nat.
Proof. reflexivity. Qed.

Example discrete_log_ex2 : discrete_log 2 = 1%nat.
Proof. reflexivity. Qed.

Example discrete_log_ex3 : discrete_log 3 = 1%nat.
Proof. reflexivity. Qed.

Example discrete_log_ex4 : discrete_log 4 = 2%nat.
Proof. reflexivity. Qed.

Example discrete_log_ex5 : discrete_log 5 = 2%nat.
Proof. reflexivity. Qed.

Example discrete_log_ex7 : discrete_log 7 = 2%nat.
Proof. reflexivity. Qed.

Example discrete_log_ex8 : discrete_log 8 = 3%nat.
Proof. reflexivity. Qed.

Lemma pos_le_shift (x y : positive) : x <= y -> x~0 <= y~1.
Proof.
  intro H. unfold Pos.le, Pos.compare. simpl.
  apply Pos.compare_cont_Lt_not_Gt. assumption.
Qed.

Lemma pos_lt_shift (y z : positive) : y < z -> y~1 < z~0.
Proof.
  intro H. unfold Pos.lt, Pos.compare. simpl.
  apply Pos.compare_cont_Gt_Lt. assumption.
Qed.

Lemma pos_le_lt_shift (x y z : positive) : x <= y < z -> x~0 <= y~0 < z~0.
Proof.
  intros [Hle Hlt].
  split; [unfold Pos.le | unfold Pos.lt]; unfold Pos.compare; simpl;
    fold Pos.compare; assumption.
Qed.

Lemma pos_le_lt_shift' (x y z : positive) : x <= y < z -> x~0 <= y~1 < z~0.
Proof.
  intros [Hle Hlt].
  split; [apply pos_le_shift | apply pos_lt_shift]; assumption.
Qed.

Theorem discrete_log_correct (z : positive) (n : nat)
  : discrete_log z = n -> shift_nat n 1 <= z < shift_nat (n + 1) 1.
Proof.
  generalize dependent n.
  induction z as [p IH | p IH |]; simpl; intros n H.
  - destruct n as [| n']; try discriminate H.
    apply Nat.succ_inj in H. simpl.
    apply pos_le_lt_shift', IH, H.
  - destruct n as [| n']; try discriminate H.
    apply Nat.succ_inj in H. simpl.
    apply pos_le_lt_shift, IH, H.
  - subst n. simpl. unfold Pos.le, Pos.lt, Pos.compare.
    simpl. split; [discriminate | reflexivity].
Qed.

(* 6.3.5 ** Types with Functional Fields *)
Inductive Z_fbtree : Set
  := Z_fleaf : Z_fbtree
   | Z_fnode : Z -> (bool -> Z_fbtree) -> Z_fbtree.

Definition right_son (t : Z_btree) : Z_btree
  := match t with
     | Z_leaf => Z_leaf
     | Z_bnode a t1 t2 => t2
     end.

Definition fright_son (t : Z_fbtree) : Z_fbtree
  := match t with
     | Z_fleaf => Z_fleaf
     | Z_fnode a f => f false
     end.

Check Z_fbtree_ind.
(* Z_fbtree_ind : forall P : Z_fbtree -> Prop,
   P Z_fleaf
   -> (forall (z : Z) (z0 : bool -> Z_fbtree),
        (forall b : bool, P (z0 b)) -> P (Z_fnode z z0))
   -> forall z : Z_fbtree, P z *)

Fixpoint fsum_all_values (t : Z_fbtree) : Z
  := match t with
     | Z_fleaf => 0
     | Z_fnode z f => z + fsum_all_values (f true) + fsum_all_values (f false)
     end.

(* Exercise 6.27
   Define a function [fzero_present : Z_fbtree -> bool] that maps
   any tree x to true if and only if x contains the value zero. *)
Fixpoint fzero_present (t : Z_fbtree) : bool
  := match t with
     | Z_fleaf => false
     | Z_fnode z f => (z =? 0)%Z || fzero_present (f true) || fzero_present (f false)
     end.

Fixpoint Z_btree_from_f (t : Z_fbtree) : Z_btree
  := match t with
     | Z_fleaf => Z_leaf
     | Z_fnode z f => Z_bnode z (Z_btree_from_f (f true)) (Z_btree_from_f (f false))
     end.

Definition fzero_present' (t : Z_fbtree) : bool := zero_present' (Z_btree_from_f t).

Theorem fzero_present_eq (t : Z_fbtree) : fzero_present t = fzero_present' t.
Proof.
  induction t as [| z f IH]; try reflexivity.
  unfold fzero_present'. simpl. rewrite !IH. reflexivity.
Qed.

(* 6.3.5.2 *** Infinitely Branching Trees *)
Inductive Z_inf_branch_tree : Set
  := Z_inf_leaf : Z_inf_branch_tree
   | Z_inf_node : Z -> (nat -> Z_inf_branch_tree) -> Z_inf_branch_tree.

Fixpoint n_sum_all_values (n : nat) (t : Z_inf_branch_tree) : Z
  := match t with
     | Z_inf_leaf => Z0
     | Z_inf_node z f
       => z + sum_f n (fun x : nat => n_sum_all_values n (f x))
     end.

(* Exercise 6.28 **
   Define a function that checks whether the zero value occurs
   in an infinitely branching tree at a node reachable only
   by indices smaller than a number n. *)

(* authors' solution (fixed) *)
Fixpoint any_true (n : nat) (f : nat -> bool) {struct n} : bool
  := match n with
     | O => false
     | S p => orb (f p) (any_true p f)
     end.

Fixpoint izero_present (n : nat) (t : Z_inf_branch_tree) {struct t} : bool
  := match t with
     | Z_inf_leaf => false
     | Z_inf_node v f
       => match v with
          | Z0 => true
          | _ => any_true n (fun p => izero_present n (f p))
          end
     end.

(* My solution *)
(* do map and reduce (foldl) in one on natural range (from 0 to n, excluding n) *)
Fixpoint mr_range {A : Type} (n : nat) (f : nat -> A)
         (r : A -> A -> A) (a0 : A) {struct n}
  := match n with
     | O => a0
     | S n' => r (mr_range n' f r a0) (f n')
     end.

Definition sum_f' (n : nat) (f : nat -> Z) := mr_range n f Z.add Z0.
Theorem sum_f_eq (n : nat) (f : nat -> Z) : sum_f n f = sum_f' n f.
Proof.
  unfold sum_f'. induction n as [| n' IH]; try reflexivity.
  simpl. rewrite <- IH, Z.add_comm. reflexivity.
Qed.

Definition any_true' (n : nat) (f : nat -> bool) : bool := mr_range n f orb false.
Theorem any_true_eq (n : nat) (f : nat -> bool) : any_true n f = any_true' n f.
Proof.
  unfold any_true'. induction n as [| n' IH]; try reflexivity.
  simpl. rewrite <- IH, orb_comm. reflexivity.
Qed.

Fixpoint inf_zero_present (n : nat) (t : Z_inf_branch_tree) {struct t} : bool
  := match t with
     | Z_inf_leaf => false
     | Z_inf_node z f => (z =? 0)%Z
                         || mr_range n (compose (inf_zero_present n) f) orb false
     end.

Require Import FunctionalExtensionality.

Theorem inf_zero_present_eq (n : nat) (t : Z_inf_branch_tree)
  : izero_present n t = inf_zero_present n t.
Proof.
  induction t as [| z f IH]; try reflexivity.
  simpl. rewrite any_true_eq. unfold any_true', compose.
  destruct z as [| z' | z'] eqn:H; try reflexivity;
    simpl; f_equal; extensionality k; apply IH.
Qed.

(* 6.3.6 Proofs on Recursive Functions *)

(* Exercise 6.29
Redo the proof of theorem [plus_n_0], using only the tactics
[intro], [assumption], [elim], [simpl], [apply], and [reflexivity]. *)
Open Scope nat_scope.
Theorem plus_n_O' (n : nat) : n + 0 = n.
Proof.
  elim n; try reflexivity.
  intros n' IH. simpl. apply eq_S, IH.
Qed.

Theorem plus_n_O'' (n : nat) : n + 0 = n.
Proof.
  elim n; try reflexivity. intros n' IH. simpl.
  apply (eq_ind (n' + 0) (fun t => S (n' + 0) = S t)).
  - apply eq_refl.
  - assumption.
Qed.

(* Exercise 6.30 **
   This exercise uses the types [Z_btree] and [Z_fbtree]
   introduced in Sects. 6.3.4 and 6.3.5.1.
   Define functions :
   [f1 : Z_btree : Z_fbtree]
   [f2 : Z_fbtree : Z_btree]
   that establish the most natural bijection between the two types.

   Prove the following theorem:
   [Theorem f2_f1 : forall t: Z_btree, f2 (f1 t) = t.]

   What is missing to prove the following statement?
   [Theorem f1_f2 : forall t: Z_fbtree, f1 (f2 t) = t.] *)

Fixpoint f1 (t : Z_btree) : Z_fbtree
  := match t with
     | Z_leaf => Z_fleaf
     | Z_bnode z t1 t2 => Z_fnode z (fun b : bool => f1 (if b then t1 else t2))
     end.

Fixpoint f2 (t : Z_fbtree) : Z_btree
  := match t with
     | Z_fleaf => Z_leaf
     | Z_fnode z f => Z_bnode z (f2 (f true)) (f2 (f false))
     end.

(* proove that this functions are bijective *)
Theorem f2_f1 (t : Z_btree) : f2 (f1 t) = t.
Proof.
  induction t as [| z t1 IH1 t2 IH2]; try reflexivity.
  simpl. rewrite IH1, IH2. reflexivity.
Qed.

(* use extensionality *)
Theorem f1_f2 (t : Z_fbtree) : f1 (f2 t) = t.
Proof.
  induction t as [| z f IH]; try reflexivity.
  simpl. f_equal. extensionality b.
  destruct b; rewrite IH; reflexivity.
Qed.

(* Exercise 6.31
   Prove [forall n : nat, (mult2 n) = n + n] (see Sect. 6.3.3) *)
Theorem mult2_to_sum (n : nat) : mult2 n = n + n.
Proof.
  induction n as [| n' IH]; try reflexivity.
  simpl. rewrite IH. rewrite plus_n_Sm. reflexivity.
Qed.

(* Exercise 6.32
   The sum of the first n natural numbers is defined with the following function: *)
Fixpoint sum_n (n : nat) : nat
  := match n with
     | O => O
     | (S p) => n + sum_n p
     end.
(* Show that for each n, we have: [2 * (sum_n n) = n * (n+1)]. *)
Theorem sum_n_eq (n : nat) : 2 * (sum_n n) = n * (n + 1).
Proof.
  induction n as [| n' IH]; try reflexivity.
  simpl (sum_n (S n')). rewrite mult_n_Sm, Nat.mul_add_distr_l, IH.
  ring.
Qed.

(* Exercise 6.33
   Prove the following statement: [n <= sum_n n] *)
Theorem sum_n_gt_n (n : nat) : n <= sum_n n.
Proof.
  induction n as [| n' IH]; simpl.
  - apply Nat.le_refl.
  - apply Peano.le_n_S, Nat.le_add_r.
Qed.

(* 6.3.7 Anonymous Recursive Functions (fix) *)
Definition mult2' : nat -> nat
  := fix f (n : nat) : nat
       := match n with
          | 0 => 0
          | S p => S (S (f p)) end.

Theorem mult2_eq (n : nat) : mult2 n = mult2' n.
Proof. reflexivity. Qed.

(* 6.4 Polymorphic Types *)
(* 6.4.1 Polymorphic Lists *)
Require Import List.
Print list.
(* Inductive list (A : Type) : Type
   := nil : list A
    | cons : A -> list A -> list A *)

Check list_ind.
(* list_ind : forall (A : Type) (P : list A -> Prop),
                P nil
                -> (forall (a : A) (l : list A), P l -> P (a :: l))
                -> forall l : list A, P l *)

Fixpoint app {A : Type} (l m : list A) : list A
  := match l with
     | nil => m
     | cons a l1 => cons a (app l1 m)
     end.

(* Exercise 6.34
   Build a polymorphic function that takes a list as argument
   and returns a list containing the first two elements when they exist. *)
Definition first_two {X : Type} (xs : list X) : list X
  := match xs with
     | x1 :: x2 :: _ => x1 :: x2 :: nil
     | x1 :: nil => x1 :: nil
     | nil => nil
     end.

Example first_two_ex0 : first_two (X := nat) nil = nil.
Proof. reflexivity. Qed.

Example first_two_ex1 : first_two (1 :: nil) = (1 :: nil).
Proof. reflexivity. Qed.

Example first_two_ex2 : first_two (1 :: 2 :: nil) = (1 :: 2 :: nil).
Proof. reflexivity. Qed.

Example first_two_ex3 : first_two (1 :: 2 :: 3 :: nil) = (1 :: 2 :: nil).
Proof. reflexivity. Qed.

(* Exercise 6.35
   Build a function that takes a natural number [n] and a list as
   arguments and returns the list containing the first n elements
   of the list when they exist. *)
Fixpoint first_n {X : Type} (xs : list X) (n : nat) : list X
  := match n, xs with
     | O, _ | _, nil => nil
     | S n', x1 :: xs1  => x1 :: first_n xs1 n'
     end.

Example first_n_ex : first_n (1 :: 2 :: 3 :: 4 :: nil) 3 = (1 :: 2 :: 3 :: nil).
Proof. reflexivity. Qed.

Theorem first_two_is_first_n {X : Type} (xs : list X) : first_two xs = first_n xs 2.
Proof.
  destruct xs as [| x1 [| x2 [| x3 xs3]]]; reflexivity.
Qed.

(* Exercise 6.36
   Build a function that takes a list of integers as argument and
   returns the sum of these numbers. *)
Open Scope Z_scope.
Fixpoint list_sum (xs : list Z) : Z
  := match xs with
     | nil => Z0
     | x1 :: xs1 => x1 + list_sum xs1
     end.

Theorem list_sum_step (x : Z) (xs : list Z) : list_sum (x :: xs) = x + list_sum xs.
Proof. reflexivity. Qed.

Example list_sum_ex : list_sum (1 :: 2 :: 3 :: nil) = 6.
Proof. reflexivity. Qed.

(* Exercise 6.37
   Build a function that takes a natural number n as argument
   and builds a list containing n occurrences of the number one. *)
Fixpoint list_repeat_one (n : nat) : list Z
  := match n with
     | O => nil
     | S n' => 1 :: list_repeat_one n'
     end.

Fixpoint list_repeat {X : Type} (x : X) (n : nat) : list X
  := match n with
     | O => nil
     | S n' => x :: list_repeat x n'
     end.

Theorem list_repeat_one_correct (n : nat) : list_repeat_one n = list_repeat 1 n.
Proof.
  induction n as [| n' IH]; try reflexivity.
  simpl. rewrite IH. reflexivity.
Qed.

Example sum_of_repeat_one (n : nat) : list_sum (list_repeat_one n) = Z.of_nat n.
Proof.
  induction n as [| n' IH]; try reflexivity.
  simpl list_repeat_one. rewrite list_sum_step, Nat2Z.inj_succ.
  unfold Z.succ. rewrite Z.add_comm, IH. reflexivity.
Qed.

(* Exercise 6.38
   Build a function that takes a number n and returns the list
   containing the integers from 1 to n, in this order. *)
Open Scope nat_scope.
Fixpoint list_from_k (k n : nat) : list nat
  := match n with
     | O => nil
     | S n' => k :: list_from_k (S k) n'
     end.

Example list_from_k_ex3 : list_from_k 2 2 = 2 :: 3 :: nil.
Proof. reflexivity. Qed.

Definition list_from_one_to_n (n : nat) : list nat := list_from_k 1 n.

Example list_from_one_to_n_ex0 : list_from_one_to_n 0 = nil.
Proof. reflexivity. Qed.

Example list_from_one_to_n_ex1 : list_from_one_to_n 1 = 1 :: nil.
Proof. reflexivity. Qed.

Example list_from_one_to_n_ex2 : list_from_one_to_n 2 = 1 :: 2 :: nil.
Proof. reflexivity. Qed.

Example list_from_one_to_n_ex3 : list_from_one_to_n 3 = 1 :: 2 :: 3 :: nil.
Proof. reflexivity. Qed.

(* authors' solution *)
Fixpoint iota_iter (n : nat) (ns : list nat) {struct n} : list nat
  := match n with
     | 0 => ns
     | S n' => iota_iter n' (n :: ns)
     end.

Definition iota (n : nat) : list nat := iota_iter n nil.

Example iota_ex0 : iota 0 = nil.
Proof. reflexivity. Qed.

Example iota_ex1 : iota 1 = 1 :: nil.
Proof. reflexivity. Qed.

Example iota_ex2 : iota 2 = 1 :: 2 :: nil.
Proof. reflexivity. Qed.

Example iota_ex3 : iota 3 = 1 :: 2 :: 3 :: nil.
Proof. reflexivity. Qed.

Theorem iota_iter_to_list_from_k1 (k n : nat) : iota_iter k (list_from_k (S k) n) = list_from_k 1 (k + n).
Proof.
  generalize dependent n.
  induction k as [| k' IH]; try reflexivity.
  intro n. simpl iota_iter.
  replace ((S k') :: list_from_k (S (S k')) n)
    with (list_from_k (S k') (S n)) by reflexivity.
  rewrite IH. rewrite Nat.add_succ_r, Nat.add_succ_l.
  reflexivity.
Qed.

Require Import Lia.

Theorem iota_is_list_from_one_to_n (n : nat) : list_from_one_to_n n = iota n.
Proof.
  destruct n as [| n']; try reflexivity.
  unfold iota. simpl.
  replace (S n' :: nil) with (list_from_k (S n') 1) by reflexivity.
  rewrite iota_iter_to_list_from_k1.
  unfold list_from_one_to_n.
  now rewrite Nat.add_1_r.
Qed.

Theorem iota_iter_to_list_from_k2 (k n : nat)
  : iota_iter k (list_from_k (S k) n) = iota_iter (k + n) nil.
Proof.
  generalize dependent n.
  induction k as [| k' IH]; intro n.
  - simpl. fold (list_from_one_to_n n). fold (iota n).
    now rewrite iota_is_list_from_one_to_n.
  - simpl iota_iter.
  replace ((S k') :: list_from_k (S (S k')) n)
    with (list_from_k (S k') (S n)) by reflexivity.
  rewrite IH. rewrite Nat.add_succ_r.
  reflexivity.
Qed.

(* 6.4.2 The option Type *)
Print option.
(* Inductive option (A : Type) : Type
   := Some : A -> option A
    | None : option A *)
Definition pred_option (n : nat) : option nat
  := match n with
     | O => None
     | S n' => Some n'
     end.

Definition pred2_option (n : nat) : option nat
  := match pred_option n with
     | None => None
     | Some p => pred_option p
     end.

(* my attempt to get convenient combinators for [option] type *)
Definition option_map {X Y : Type} (opt_x : option X) (f : X -> Y) : option Y
  := match opt_x with
     | Some x => Some (f x)
     | None => None
     end.

Notation "opt_x '|>' f" := (option_map opt_x f)
                             (at level 65, left associativity).

Example option_map_ex : Some 1 |> S = Some 2.
Proof. reflexivity. Qed.

Definition option_flat_map {X Y : Type} (opt_x : option X) (f : X -> option Y) : option Y
  := match opt_x with
     | Some x => f x
     | None => None
     end.

Notation "opt_x '|>>' f" := (option_flat_map opt_x f)
                              (at level 65, left associativity).

Example option_flat_map_ex0 : Some 0 |>> pred_option = None.
Proof. reflexivity. Qed.

Example option_flat_map_ex1 : Some 1 |>> pred_option = Some 0.
Proof. reflexivity. Qed.

Definition option_get {X : Type} (opt_x : option X) (default : X)
  := match opt_x with
     | Some x => x
     | None => default
     end.

Notation "opt_x '|v' default" := (option_get opt_x default)
                              (at level 65, left associativity).

Example option_get_ex0 : None |v 1 = 1.
Proof. reflexivity. Qed.

Example option_get_ex1 : Some 2 |v 1 = 2.
Proof. reflexivity. Qed.

Example option_helpers_ex : Some 1 |> S |>> pred_option |v 0 = 1.
Proof. reflexivity. Qed.
(* end *)

(* rewrite [pred2_option] using new helpers *)
Definition pred2_option' (n : nat) : option nat
  := pred_option n |>> pred_option.

Theorem pred2_option_eq (n : nat) : pred2_option n = pred2_option' n.
Proof. reflexivity. Qed.

Fixpoint nth_option {X : Type} (n : nat) (xs : list X) {struct xs} : option X
  := match n, xs with
     | _, nil => None
     | O, x1 :: _ => Some x1
     | S n', x1 :: xs1 => nth_option n' xs1
     end.

(* Theorem nth_option_zero {X : Type} (xs : list X) : nth_option 0 xs = None. *)
(* Proof. *)
(*   destruct xs; try reflexivity. simpl. *)

Definition tl_error {X : Type} (xs : list X)
  := match xs with
     | nil => None
     | _ :: xs1 => Some xs1
     end.

Definition nth_option_it {X : Type} (n : nat) (xs : list X) : option X
  := iterate (fun opt_xs => opt_xs |>> tl_error) n (Some xs) |>> @hd_error X.

Theorem nth_option_it_of_nil {X : Type} (n : nat) : nth_option_it n (@nil X) = None.
Proof.
  unfold nth_option_it. destruct n as [| n']; try reflexivity.
  rewrite iterate_fixpoint1 with (y := None); reflexivity.
Qed.

Theorem nth_option_it_step {X : Type} (n : nat) (x : X) (xs : list X)
  : nth_option_it (S n) (x :: xs)  = nth_option_it n xs.
Proof.
  unfold nth_option_it.
  generalize dependent xs.
  generalize dependent x.
  induction n as [| n' IH]; try reflexivity. intros x xs.
  remember (fun opt_xs => opt_xs |>> tl_error) as f eqn:feq.
  rewrite iterate_eq, iterate'_step, iterate_eq, <- iterate_eq.
  rewrite iterate'_step, <- iterate_eq.
  replace (f (Some (x :: xs))) with (Some xs) by (subst f; reflexivity).
  destruct xs as [| x1 xs1].
  - rewrite iterate_fixpoint1 with (y := None); try (subst f; reflexivity).
    replace (f (Some nil)) with (@None (list X)) by (subst f; reflexivity).
    rewrite iterate_fixpoint; subst f; reflexivity.
  - rewrite IH. subst f; reflexivity.
Qed.

Theorem nth_option_it_eq {X : Type} (n : nat) (xs : list X)
  : nth_option n xs = nth_option_it n xs.
Proof.
  generalize dependent xs.
  induction n as [| n' IH]; destruct xs as [| x1 xs1]; try reflexivity.
  - now rewrite nth_option_it_of_nil.
  - rewrite nth_option_it_step. simpl. now rewrite IH.
Qed.

(* Exercise 6.39
   Define the other variant [nth_option']. The arguments are
   given in the same order, but the principal argument is the number [n].
   Prove that both functions always give the same result
   when applied on the same input. *)
Fixpoint nth_option' {X : Type} (n : nat) (xs : list X) {struct n} : option X
  := match n, xs with
     | _, nil => None
     | O, x1 :: _ => Some x1
     | S n', x1 :: xs1 => nth_option' n' xs1
     end.

Theorem nth_option_eq {X : Type} (n : nat) (xs : list X)
  : nth_option n xs = nth_option' n xs.
Proof.
  generalize dependent xs.
  induction n as [| n' IH]; destruct xs as [| x1 xs1]; try reflexivity.
  simpl. apply IH.
Qed.

(* Exercise 6.40 * Prove: *)
Lemma nth_length (X : Set) (n : nat) (xs : list X)
  : nth_option n xs = None <-> length xs <= n.
Proof.
  generalize dependent xs.
  induction n as [| n' IH]; destruct xs as [| x1 xs1]; simpl;
    split; intro H; try reflexivity.
    + discriminate H.
    + inversion H.
    + apply Nat.le_0_l.
    + apply Peano.le_n_S. apply IH, H.
    + apply Peano.le_S_n in H. apply IH, H.
Qed.

(* Exercise 6.41 *
   Define a function that takes as arguments a type A,
   a function of type [A->bool], and a list
   and returns the first element in the list, for which the function is true
   (use the option type). *)
Fixpoint find {X : Type} (P : X -> bool) (xs : list X) : option X
  := match xs with
     | nil => None
     | x1 :: xs1 => if P x1 then Some x1
                  else find P xs1
     end.

Theorem find_correct {X : Type} (P : X -> bool) (xs : list X) : find P xs = List.find P xs.
Proof.
  induction xs as [| x1 xs1 IH]; try reflexivity.
  simpl. now rewrite IH.
Qed.

(* 6.4.3 The Type of Pairs *)

(* Exercise 6.42
   Define two functions with the following type
   [split : forall A B : Type, list (A * B) -> list A * list B]
   [combine : forall A B : Type, list A -> list B -> list (A * B)]
   and the usual behavior (transform a list of pairs into a pair of lists
   containing the same data, and vice-versa, whenever possible)
   Prove a simple theorem relating split and combine. *)
Fixpoint combine {X Y : Type} (xs : list X) (ys : list Y) : list (X * Y)
  := match xs, ys with
     | nil, _ | _, nil => nil
     | x1 :: xs1, y1 :: ys1 => (x1, y1) :: combine xs1 ys1
     end.

Fixpoint split {X Y : Type} (xys : list (X * Y)) : list X * list Y
  := match xys with
     | nil => (nil, nil)
     | (x1, y1) :: xys1 => let s := split xys1
                         in (x1 :: fst s, y1 :: snd s)
     end.

Import ListNotations.

Example combine_ex : combine [1; 2; 3] [4; 5; 6; 7] = [(1, 4); (2, 5); (3, 6)].
Proof. reflexivity. Qed.

Example split_ex : split [(1, 4); (2, 5); (3, 6)] = ([1; 2; 3], [4; 5; 6]).
Proof. reflexivity. Qed.

Theorem split_combine_is_id {X Y : Type} (xs : list X) (ys : list Y)
  : length xs = length ys -> split (combine xs ys) = (xs, ys).
Proof.
  generalize dependent ys.
  induction xs as [| x1 xs1 IH]; intros ys H.
  - simpl in H. symmetry in H. apply length_zero_iff_nil in H.
    subst ys. reflexivity.
  - destruct ys as [| y1 ys1].
    + simpl length in H at 2. apply length_zero_iff_nil in H.
      discriminate H.
    + simpl. simpl in H. apply Nat.succ_inj in H.
      apply IH in H. rewrite !H. reflexivity.
Qed.

Theorem combine_split_is_id {X Y : Type} (xys : list (X * Y))
  : (uncurry combine) (split xys) = xys.
Proof.
  induction xys as [| xy1 xys1 IH]; try reflexivity.
  simpl. destruct xy1 as (x1, y1). simpl.
  unfold uncurry in IH.
  destruct (split xys1) as (xs1, ys1). simpl.
  rewrite IH. reflexivity.
Qed.

(* Authors' theorem *)
Theorem combine_of_split {A B : Type} (l : list (A * B))
  : let (l1, l2) :=  split l
    in combine l1 l2 = l.
Proof.
  induction l; simpl; auto.
  destruct a, (split l). simpl. congruence.
Qed.

(* Exercise 6.43
   Build the type [btree] of polymorphic binary trees.
   Define translation functions from [Z_btree] to [btree Z] and vice versa.
   Prove that they are inverse to each other. *)
Inductive btree (X : Type) : Type
  := bleaf : btree X
   | bnode : X -> btree X -> btree X -> btree X.

Arguments bleaf {X}.
Arguments bnode {X}.

Fixpoint btree_from_Z (t : Z_btree) : btree Z
  := match t with
     | Z_leaf => bleaf
     | Z_bnode z t1 t2 => bnode z (btree_from_Z t1) (btree_from_Z t2)
     end.

Fixpoint btree_to_Z (t : btree Z) : Z_btree
  := match t with
     | bleaf => Z_leaf
     | bnode z t1 t2 => Z_bnode z (btree_to_Z t1) (btree_to_Z t2)
     end.

Theorem Z_btree_conv1 (t : Z_btree) : btree_to_Z (btree_from_Z t) = t.
Proof.
  induction t as [| z t1 IH1 t2 IH2]; [reflexivity|].
  simpl. rewrite IH1, IH2. reflexivity.
Qed.

Theorem Z_btree_conv2 (t : btree Z) : btree_from_Z (btree_to_Z t) = t.
Proof.
  induction t as [| z t1 IH1 t2 IH2]; [reflexivity|].
  simpl. rewrite IH1, IH2. reflexivity.
Qed.

(* Exercise 6.44
   This exercise continues Exercise 6.24 page 169.
   Build the function that takes an element of the type defined
   to represent rational numbers and returns the numerator and denominator
   of the corresponding reduced fraction. *)
Print F.
(* Inductive F : Set :=  one : F | n : F -> F | d : F -> F *)

(* N(x) = 1 + x
   D(x) = 1 / (1 + 1/x) *)

Definition rat_simp (m k : nat) : nat * nat := let d := Nat.gcd m k in (m / d, k / d).
Fixpoint F_to_rat (f : F) : nat * nat (* return [m / k], [k > 0] *)
  := match f with
   | one => (1, 1)
   | n x => let (m, k) := F_to_rat x in (m + k, k)
   | d x =>  let (m, k) := F_to_rat x
            in (uncurry rat_simp) (k, k + m)
   end.

Theorem rat_simp_is_irreducible (m k : nat)
  : let (m', k') := rat_simp m k in Nat.gcd m' k' <= 1.
Proof.
  destruct (rat_simp m k) as (m', k') eqn:eq.
  unfold rat_simp in eq. apply pair_equal_spec in eq.
  destruct eq as (eqm, eqk). subst m' k'.
  destruct (Nat.gcd m k =? 0) eqn:H.
  - apply Nat.eqb_eq in H. rewrite !H. simpl. apply Nat.le_0_1.
  - apply Nat.eqb_neq in H. remember (Nat.gcd m k) as g eqn:eq.
    now rewrite Nat.gcd_div_gcd.
Qed.

Theorem F_to_rat_is_irreducible (f : F)
  : let (m, k) := F_to_rat f in Nat.gcd m k <= 1.
Proof.
  induction f as [| x IH | x IH].
  - simpl. reflexivity.
  - simpl. destruct (F_to_rat x) as (m, k).
    rewrite Nat.gcd_comm, Nat.gcd_add_diag_r, Nat.gcd_comm.
    assumption.
  - simpl. destruct (F_to_rat x) as (m, k).
    apply rat_simp_is_irreducible.
Qed.

(* Exercise 6.45 ***
   The aim of this exercise is to implement a sieve function
   that computes all the prime numbers that are less than a given number.
   The first step is to define a type of comparison values: *)
Inductive cmp : Set := Less | Equal | Greater.

(* Then define the following functions:
   1. [three_way_compare : nat -> nat -> cmp]
   for comparing two natural numbers.

   2. [update_primes : nat -> (list nat * nat) -> (list nat * nat) * bool]
   such that if [k] is a natural number and [l] is a list of pairs [(p,m)]
   such that [m] is the smallest multiple of [p] greater than or equal to [k],
   then [update_primes k l] returns the list of pairs [(p,m')]
   where [m'] is the smallest multiple of [p] strictly greater than [k]
   and a boolean value that is true if one of the [m] was equal to [k].

   3. [prime_sieve : nat -> (list nat * nat)]
   to map a number [k] to the list of pairs [(p,m)]
   where [p] is a prime number smaller or equal to [k]
   and [m] is the smallest multiple of [p] greater than or equal to [k + 1].

   Prove that [prime_sieve] can be used to compute all the prime numbers
   smaller than a given [k]. *)

Fixpoint three_way_compare (n m : nat) : cmp
  := match n, m with
     | O, O => Equal
     | O, S _ => Less
     | S _, O => Greater
     | S n', S m' => three_way_compare n' m'
     end.

Theorem both_true_iff (A B : Prop) : A -> B -> A <-> B.
Proof. intros a b. split; intro H; assumption. Qed.

Theorem both_false_iff (A B : Prop) : ~A -> ~B -> A <-> B.
Proof. intros na nb. split; intro H; contradiction. Qed.

Theorem Equal_is_eq (n m : nat) : three_way_compare n m = Equal <-> n = m.
Proof.
  generalize dependent m.
  induction n as [| n' IH]; intro m; destruct m as [| m']; simpl.
  - apply both_true_iff; reflexivity.
  - apply both_false_iff; [discriminate | apply Nat.neq_0_succ].
  - apply both_false_iff; [discriminate | apply Nat.neq_succ_0].
  - rewrite IH. rewrite Nat.succ_inj_wd. reflexivity.
Qed.

Theorem Less_is_lt (n m : nat) : three_way_compare n m = Less <-> n < m.
Proof.
  generalize dependent m.
  induction n as [| n' IH]; intro m; destruct m as [| m']; simpl.
  - apply both_false_iff; [discriminate | apply Nat.nle_succ_0].
  - apply both_true_iff; [reflexivity | apply Peano.le_n_S, Peano.le_0_n].
  - apply both_false_iff; [discriminate | apply Nat.nle_succ_0].
  - rewrite IH. apply Nat.succ_lt_mono.
Qed.

Theorem Greater_is_gt (n m : nat) : three_way_compare n m = Greater <-> n > m.
Proof.
  generalize dependent m.
  induction n as [| n' IH]; intro m; destruct m as [| m']; simpl.
  - apply both_false_iff; [discriminate | apply gt_irrefl].
  - apply both_false_iff; [discriminate | apply Nat.nlt_0_r].
  - apply both_true_iff; [reflexivity | apply Peano.le_n_S, Peano.le_0_n].
  - rewrite IH. apply Nat.succ_lt_mono.
Qed.

Definition update_prime (k p m : nat) : nat * bool
  := match three_way_compare m k with
     | Equal => (m + p, true)
     | Less => (m + p, false) (* assume that m >= k so it is not possible *)
     | Greater => (m, false)
     end.

Lemma update_prime_m_mult (p m k m' : nat) (is_comp : bool)
  : p <> 0 -> (m mod p =? 0) = true -> update_prime k p m = (m', is_comp)
    -> (m' mod p =? 0) = true.
Proof.
  intros pnz eq0. unfold update_prime.
  destruct (three_way_compare m k);
    intro H; injection H; clear H; intros eq1 eq2.
  - rewrite <- eq2. simpl. rewrite <- (Nat.mul_1_l p) at 1.
    rewrite Nat.mod_add; assumption.
  - rewrite <- eq2. simpl. rewrite <- (Nat.mul_1_l p) at 1.
    rewrite Nat.mod_add; assumption.
  - rewrite <- eq2. assumption.
Qed.

Lemma update_prime_gt_k (p m k m' : nat) (is_comp : bool)
  : p <> 0 -> k <= m -> update_prime k p m = (m', is_comp) -> k < m'.
Proof.
  intros pnz ge eq. unfold update_prime in eq.
  destruct (three_way_compare m k) eqn:cmp;
    injection eq; clear eq; intros eq1 eq2.
  - apply Less_is_lt in cmp. apply le_not_lt in ge.
    contradiction cmp.
  - apply Equal_is_eq in cmp. subst k m'.
    apply Nat.lt_add_pos_r, Nat.neq_0_lt_0, pnz.
  - apply Greater_is_gt in cmp. unfold gt in cmp.
    subst m'. assumption.
Qed.

Lemma update_prime_min (p m k m' : nat) (is_comp : bool)
  : m - p < k -> update_prime k p m = (m', is_comp)
    -> m' - p <= k.
Proof.
  intros lt eq. unfold update_prime in eq.
  destruct (three_way_compare m k) eqn:cmp;
    injection eq; clear eq; intros eq1 eq2; subst m'.
  - apply Less_is_lt in cmp.
    rewrite Nat.add_sub. apply Nat.lt_le_incl, cmp.
  - apply Equal_is_eq in cmp. subst k.
    rewrite Nat.add_sub. apply Nat.le_refl.
  - apply Greater_is_gt in cmp. unfold gt in cmp.
    apply Nat.lt_le_incl, lt.
Qed.

Lemma update_prime_is_comp (p m k m' : nat) (is_comp : bool)
  : update_prime k p m = (m', is_comp) -> is_comp = (m =? k).
Proof.
  intro eq. unfold update_prime in eq.
  destruct (three_way_compare m k) eqn:cmp;
    injection eq; clear eq; intros eq1 eq2; subst m'.
  - apply Less_is_lt in cmp. subst is_comp. symmetry.
    apply Nat.eqb_neq, Nat.lt_neq, cmp.
  - apply Equal_is_eq in cmp. subst k is_comp.
    apply beq_nat_refl.
  - apply Greater_is_gt in cmp. unfold gt in cmp.
    subst is_comp. symmetry. rewrite Nat.eqb_sym.
    apply Nat.eqb_neq, Nat.lt_neq, cmp.
Qed.

Fixpoint update_primes (k : nat) (ps : list (nat * nat)) {struct ps}
  : (list (nat * nat)) * bool
  := match ps with
     | [] => ([], false)
     | (p, m) :: ps0 => let (ps1, is_comp1) := update_primes k ps0 in
                      let (m2, is_comp2) := update_prime k p m in
                      ((p, m2) :: ps1, is_comp1 || is_comp2)
     end.

Example update_primes_ex0 : update_primes 2 [] = ([], false).
Proof. reflexivity. Qed.

Example update_primes_ex1 : update_primes 2 [(2, 2)] = ([(2, 4)], true).
Proof. reflexivity. Qed.

Example update_primes_ex2 : update_primes 5 [(2, 6)] = ([(2, 6)], false).
Proof. reflexivity. Qed.

Example update_primes_ex3 : update_primes 6 [(3, 6)] = ([(3, 9)], true).
Proof. reflexivity. Qed.

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

(* return true if [p k = true] for all [k] such that [n0 < k < n] *)
Fixpoint forallb_in_interval (n0 n : nat) (p : nat -> bool) : bool
  := match n with
     | O => true
     | S n' => if n <=? S n0 then true
              else p n' && forallb_in_interval n0 n' p
     end.

Example forallb_in_interval_ex1
  : forallb_in_interval 3 5 (fun k => k =? 4) = true.
Proof. reflexivity. Qed.

Example forallb_in_interval_ex2
  : forallb_in_interval 3 4 (fun k => false) = true.
Proof. reflexivity. Qed.

Example forallb_in_interval_ex3
  : forallb_in_interval 3 3 (fun k => false) = true.
Proof. reflexivity. Qed.

Example forallb_in_interval_ex4
  : forallb_in_interval 3 2 (fun k => false) = true.
Proof. reflexivity. Qed.

Example forallb_in_interval_ex5
  : forallb_in_interval 2 10 (fun k => (2 <? k) && (k <? 10)) = true.
Proof. reflexivity. Qed.

Example forallb_in_interval_ex6
  : forallb_in_interval 1 10 (fun k => (2 <? k) && (k <? 10)) = false.
Proof. reflexivity. Qed.

Example forallb_in_interval_ex7
  : forallb_in_interval 3 11 (fun k => (2 <? k) && (k <? 10)) = false.
Proof. reflexivity. Qed.

(* return true if [p k = true] for all [k] such that [n0 < k < n] *)
Fixpoint existsb_in_interval (n0 n : nat) (p : nat -> bool) : bool
  := match n with
     | O => false
     | S n' => if n <=? S n0 then false
              else p n' || existsb_in_interval n0 n' p
     end.

Theorem existsb_in_interval_correct
        (n0 n : nat) (f : nat -> bool) (P : nat -> Prop)
  : (forall k : nat, P k <-> f k = true)
    -> (exists k : nat, n0 < k < n /\ P k) <-> (existsb_in_interval n0 n f = true).
Proof.
  intro P_is_f. split; intro H.
  - destruct H as [k [[neq_n0_k neq_k] pk]].
    induction n as [| n' IH].
    + contradict neq_k. apply Nat.nlt_0_r.
    + simpl. apply lt_n_Sm_le in neq_k.
      replace (n' <=? n0) with false.
      2:{ symmetry. apply Nat.leb_gt.
          apply (Nat.lt_le_trans n0 k n'); assumption. }
      pose (le_lt_or_eq k n' neq_k) as neq_k2.
      destruct neq_k2 as [neq_k2 | eq_k].
      * now rewrite (IH neq_k2), orb_true_r.
      * apply P_is_f in pk. subst k. now rewrite pk.
  - induction n as [| n' IH]; simpl in H.
    + discriminate H.
    + destruct (lt_eq_lt_dec n0 n') as [[n0_lt_n | n0_eq_n] | n0_gt_n].
      * replace (n' <=? n0) with false in H.
        2:{ symmetry. apply Nat.leb_gt. assumption. }
        { apply orb_prop in H as [H | H].
          - apply P_is_f in H. exists n'. split; auto with arith.
          - apply IH in H. destruct H as [k [[neq_k1 neq_k2] pk]].
            exists k. split; [| exact pk].
            split; [exact neq_k1| apply Nat.lt_lt_succ_r, neq_k2].
        }
      * subst n'. rewrite Nat.leb_refl in H. discriminate H.
      * replace (n' <=? n0) with true in H.
        2:{ apply Nat.lt_le_incl, Nat.leb_le in n0_gt_n.
            now rewrite n0_gt_n. }
        discriminate H.
Qed.

Definition is_prime (n : nat) : bool
  := negb ((n =? 0) || (n =? 1)
           || existsb_in_interval 1 n (fun k => n mod k =? 0)).

Compute (seq 1 13).
(* = [1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13] : list nat *)

Compute (map is_prime (seq 1 13)).
(* = [1: false; 2: true; 3: true; 4: false; 5: true; 6: false;
      7: true; 8: false; 9: false; 10: false; 11: true;
      12: false; 13: true] : list bool *)

Example is_prime_ex
  : map is_prime (seq 1 13)
    = [false; true; true; false; true; false; true; false; false;
      false; true; false; true].
Proof. reflexivity. Qed.

Theorem prime_is_prime (n : nat) : prime n <-> is_prime n = true.
Proof.
  unfold prime, is_prime.
  rewrite !negb_orb, !andb_true_iff.
  rewrite !negb_true_iff, !Nat.eqb_neq.
  apply and_iff_compat_l. rewrite <- not_true_iff_false.
  apply not_iff_compat. apply existsb_in_interval_correct.
  intro k. rewrite Nat.eqb_eq. reflexivity.
Qed.

(* Check that [ps] is a list of pairs [(p,m)]
   such that [m] is the smallest multiple of [p]
   greater than or equal to [k] *)
Fixpoint is_ps_list (k : nat) (ps : list (nat * nat)) : bool
  := match ps with
     | [] => true
     | (p, m) :: ps' => negb (p =? 0)
                      && (m mod p =? 0)
                      && (k <=? m) && (m - p <? k)
                      && is_ps_list k ps'
     end.

Theorem is_ps_list_step (k p m : nat) (ps : list (nat * nat))
  : is_ps_list k ((p, m) :: ps)
    = negb (p =? 0)
      && (m mod p =? 0)
      && (k <=? m) && (m - p <? k)
      && is_ps_list k ps.
Proof. reflexivity. Qed.

Example is_ps_list_ex1 : is_ps_list 2 [(2, 2)] = true.
Proof. reflexivity. Qed.

Example is_ps_list_ex2 : is_ps_list 5 [(2, 6)] = true.
Proof. reflexivity. Qed.

Example is_ps_list_ex3 : is_ps_list 5 [(2, 5)] = false.
Proof. reflexivity. Qed.

Example is_ps_list_ex4 : is_ps_list 5 [(2, 4)] = false.
Proof. reflexivity. Qed.

(* Returns true if exists pair [(p, m) In ps] such that [m = k].
   It means that one of [p] numbers is divisor of [k] *)
Fixpoint is_composite (k : nat) (ps : list (nat * nat)) : bool
  := match ps with
     | [] => false
     | (p, m) :: ps' => (m =? k) || is_composite k ps'
     end.

Lemma eq_orb_intro_r (a1 a2 b : bool) : a1 = a2 -> a1 || b = a2 || b.
Proof. intro H. now subst a2. Qed.

(* [update_primes k ps] returns the list of pairs [(p,m')]
   where [m'] is the smallest multiple of [p] strictly greater than [k]
   and a boolean value that is true if one of the [m] was equal to [k]. *)
Theorem update_primes_correct (k : nat) (ps : list (nat * nat))
  : is_ps_list k ps = true
    -> let (ps1, is_comp1) := update_primes k ps in
      (is_ps_list (S k) ps1 = true)
      /\ (is_comp1 = is_composite k ps).
Proof.
  generalize dependent k.
  induction ps as [| (p, m) ps' IH]; intros k eq0; simpl; try easy.
  (* get rid of let *)
  destruct (update_primes k ps') as (ps1, is_comp1) eqn:eq1.
  destruct (update_prime k p m) as (m2, is_comp2) eqn:eq2.
  (* destruct [eq0] *)
  simpl in eq0.
  apply andb_prop in eq0. destruct eq0 as [H0 eq0].
  apply andb_prop in H0. destruct H0 as [H0 m_min].
  apply Nat.ltb_lt in m_min.
  apply andb_prop in H0. destruct H0 as [H0 m_ge].
  apply Nat.leb_le in m_ge.
  apply andb_prop in H0. destruct H0 as [pnz m_mult].
  apply negb_true_iff in pnz as pnz'. apply beq_nat_false in pnz'.
  (* use IH *) pose (IH k eq0) as H.
  rewrite eq1 in H. destruct H as [eq3 eq4].
  split.
  - simpl. rewrite eq3. rewrite andb_true_r.
    repeat (apply andb_true_intro; split); try assumption.
    + apply (update_prime_m_mult p m k m2 is_comp2); assumption.
    + pose (update_prime_gt_k p m k m2 _ pnz' m_ge eq2) as m_gt.
      destruct m2 as [| m2'].
      * exfalso. apply (Nat.nlt_0_r k), m_gt.
      * unfold lt in m_gt. apply le_S_n in m_gt.
        apply Nat.leb_le, m_gt.
    + apply Nat.ltb_lt. unfold lt. apply le_n_S.
      apply (update_prime_min p m k m2 _ m_min eq2).
  - subst is_comp1. rewrite orb_comm. apply eq_orb_intro_r.
    exact (update_prime_is_comp p m k m2 is_comp2 eq2).
Qed.

(* to map a number [k] to the list of pairs [(p,m)]
   where [p] is a prime number smaller or equal to [k]
   and [m] is the smallest multiple of [p] greater than or equal to [k + 1]. *)
Fixpoint prime_sieve (k : nat) : list (nat * nat)
  := match k with
     | 0 | 1 => []
     | S k' => let (ps, is_comp) := update_primes k (prime_sieve k') in
              if is_comp then ps else (k, 2*k) :: ps
     end.

Example prime_sieve_ex2 : prime_sieve 2 = [(2, 4)].
Proof. reflexivity. Qed.

Example prime_sieve_ex3 : prime_sieve 3 = [(3, 6); (2, 4)].
Proof. reflexivity. Qed.

Example prime_sieve_ex4 : prime_sieve 4 = [(3, 6); (2, 6)].
Proof. reflexivity. Qed.

Example prime_sieve_1_is_ps_list
  : is_ps_list 2 (prime_sieve 1) = true.
Proof. reflexivity. Qed.

Example prime_sieve_2_is_ps_list
  : is_ps_list 3 (prime_sieve 2) = true.
Proof. reflexivity. Qed.

Example prime_sieve_3_is_ps_list
  : is_ps_list 4 (prime_sieve 3) = true.
Proof. reflexivity. Qed.

Example prime_sieve_4_is_ps_list
  : is_ps_list 5 (prime_sieve 4) = true.
Proof. reflexivity. Qed.

Example prime_sieve_10_is_ps_list
  : is_ps_list 11 (prime_sieve 10) = true.
Proof. reflexivity. Qed.

Theorem prime_sieve_is_ps_list (k : nat)
  : is_ps_list (S k) (prime_sieve k) = true.
Proof.
  induction k as [| k1 IH]; [reflexivity |].
  apply update_primes_correct in IH as H.
  simpl prime_sieve.
  destruct (update_primes (S k1) (prime_sieve k1)) as (ps1, is_comp1) eqn:eq.
  destruct H as [H1 H2].
  destruct k1 as [| k2]; [reflexivity |].
  destruct is_comp1 eqn:Hcomp; [exact H1| ].
  rewrite is_ps_list_step.
  repeat (apply andb_true_intro; split); try auto with arith.
  - replace (S (S k2 + S (S k2 + 0))) with (2 * (S (S k2))) by lia.
    rewrite Nat.mod_mul; auto with arith.
  - apply Nat.leb_le. lia.
  - apply Nat.ltb_lt. lia.
Qed.

Definition get_primes (k : nat) : list nat := map fst (prime_sieve k).

Theorem prime_sieve_Sk_eq (k : nat)
  : snd (update_primes (S k) (prime_sieve k)) = true
    -> prime_sieve (S k) = fst (update_primes (S k) (prime_sieve k)).
Proof.
  simpl (prime_sieve (S k)).
  remember (prime_sieve k) as ps eqn:eq_ps.
  remember (update_primes (S k) ps) as U eqn:eq_U.
  intro H. destruct U as (ps__u, is_comp). simpl in H.
  rewrite H. simpl. destruct k as [| k'].
  - simpl in eq_ps. rewrite eq_ps in eq_U.
    simpl in eq_U. injection eq_U. auto.
  - reflexivity.
Qed.

Theorem prime_sieve_Sk_cons (k : nat)
  : 0 < k
    -> snd (update_primes (S k) (prime_sieve k)) = false
    -> prime_sieve (S k)
      = (S k, 2*(S k)) :: fst (update_primes (S k) (prime_sieve k)).
Proof.
  simpl (prime_sieve (S k)).
  remember (prime_sieve k) as ps eqn:eq_ps.
  remember (update_primes (S k) ps) as U eqn:eq_U.
  intros k_gt H. destruct U as (ps__u, is_comp). simpl in H.
  rewrite H. simpl. destruct k as [| k'].
  - contradict k_gt. apply Nat.nlt_0_r.
  - reflexivity.
Qed.

Theorem update_primes_dont_changes_primes (k : nat) (ps : list (nat * nat))
  : map fst (fst (update_primes k ps)) = map fst ps.
Proof.
  induction ps as [| (p, m) ps1 IH]; [reflexivity|]. simpl.
  destruct (update_primes k ps1) as (ps__u, is_comp1) eqn:eq1.
  simpl in IH.
  destruct (update_prime k p m) as (m', is_comp') eqn:eq'.
  simpl. rewrite IH. reflexivity.
Qed.

Theorem get_primes_Sk_eq (k : nat)
  : snd (update_primes (S k) (prime_sieve k)) = true
    -> get_primes (S k) = get_primes k.
Proof.
  intro H. unfold get_primes. rewrite (prime_sieve_Sk_eq k H).
  rewrite update_primes_dont_changes_primes. reflexivity.
Qed.

Theorem get_primes_Sk_cons (k : nat)
  : 0 < k
    -> snd (update_primes (S k) (prime_sieve k)) = false
    -> get_primes (S k) = (S k) :: get_primes k.
Proof.
  intros k_gt H. unfold get_primes.
  rewrite (prime_sieve_Sk_cons k k_gt H). simpl.
  rewrite update_primes_dont_changes_primes. reflexivity.
Qed.

Theorem is_composite_prop (k : nat) (ps : list (nat * nat))
  : is_ps_list k ps = true -> is_composite k ps = true
    -> exists q : nat, In q (map fst ps) /\ k mod q = 0.
Proof.
  induction ps as [| (p, m) ps1 IH];
    intros psl comp; [discriminate comp|].
  simpl in psl, comp. rewrite !andb_true_iff in psl.
  destruct psl as [[[[pnz p_div] k_lt] k_gt] psl].
  rewrite negb_true_iff, Nat.eqb_neq in pnz.
  rewrite Nat.eqb_eq in p_div. rewrite Nat.leb_le in k_lt.
  rewrite Nat.ltb_lt in k_gt.
  rewrite orb_true_iff in comp.
  destruct comp as [eq | comp].
  - apply Nat.eqb_eq in eq. subst m.
    exists p. simpl. auto.
  - simpl. apply (IH psl) in comp as [q [q_in q_div]].
    exists q. auto.
Qed.

Theorem is_composite_prop_neg (k : nat) (ps : list (nat * nat))
  : is_ps_list k ps = true -> is_composite k ps = false
    -> forall q : nat, In q (map fst ps) -> k mod q <> 0.
Proof.
  induction ps as [| (p, m) ps' IH];
    intros psl ncomp q qin; [contradict qin|].
  simpl in *.
  apply orb_false_elim in ncomp. destruct ncomp as [mnk ncomp'].
  apply Nat.eqb_neq in mnk.
  rewrite !andb_true_iff in psl.
  destruct psl as [[[[pnz m_div_p] k_lt] k_gt] psl'].
  apply negb_true_iff, Nat.eqb_neq in pnz.
  apply Nat.eqb_eq in m_div_p. apply Nat.leb_le in k_lt.
  apply Nat.ltb_lt in k_gt.
  pose (IH psl' ncomp') as IH'.
  destruct qin as [p_is_q | qin'].
  - subst q. intro C.
    apply Nat.mod_divides in C; [| exact pnz].
    destruct C as [s eq_k].
    apply Nat.mod_divides in m_div_p; [| exact pnz].
    destruct m_div_p as [q eq_m]. subst k m.
    apply Nat.neq_0_lt_0 in pnz as p_gt.
    rewrite <- Nat.mul_le_mono_pos_l in k_lt; [|exact p_gt].
    rewrite <- Nat.mul_pred_r in k_gt.
    rewrite <- Nat.mul_lt_mono_pos_l in k_gt; [|exact p_gt].
    apply mnk. rewrite Nat.mul_cancel_l; [|exact pnz].
    destruct q as [| q'].
    + apply le_n_0_eq in k_lt. now subst s.
    + simpl in k_gt. rewrite Nat.le_succ_r in k_lt.
      destruct k_lt as [neq | eq].
      * apply (Nat.lt_le_trans _ _ _ k_gt) in neq.
        contradict neq. apply Nat.lt_irrefl.
      * now subst s.
  - apply IH' in qin' as H. apply H.
Qed.

Theorem update_primes_snd_is_composite (k : nat)
  : snd (update_primes (S k) (prime_sieve k))
    = is_composite (S k) (prime_sieve k).
Proof.
  pose (prime_sieve_is_ps_list k) as H.
  apply update_primes_correct in H.
  destruct (update_primes (S k) (prime_sieve k)) as (ps, is_comp).
  destruct H as [H1 H2]. rewrite <- H2. reflexivity.
Qed.

Theorem in_get_primes_Sk (p k : nat)
  : In p (get_primes (S k))
    -> In p (get_primes k)
      \/ (p = S k /\ forall q : nat, In q (get_primes k) -> p mod q <> 0).
Proof.
  destruct (snd (update_primes (S k) (prime_sieve k))) eqn:eq.
  - apply get_primes_Sk_eq in eq. rewrite eq. auto.
  - destruct k as [| k']; intro H.
    + simpl in *. contradict H.
    + apply (get_primes_Sk_cons (S k')) in eq as T.
      2:{ apply Nat.lt_0_succ. }
      rewrite T in H. simpl in H. destruct H as [H | H].
      * right. split; [auto|]. subst p. clear T.
        rewrite update_primes_snd_is_composite in eq.
        apply is_composite_prop_neg; [apply prime_sieve_is_ps_list | assumption].
      * left. exact H.
Qed.

Theorem get_primes_include_Sk (k p : nat)
  : In p (get_primes k) -> In p (get_primes (S k)).
Proof.
  destruct (snd (update_primes (S k) (prime_sieve k))) eqn:H.
  - rewrite (get_primes_Sk_eq k H). auto.
  - destruct k as [| k'].
    + simpl. auto.
    + pose (Nat.lt_0_succ k') as neq.
      rewrite (get_primes_Sk_cons (S k') neq H).
      intro H'. simpl. right. exact H'.
Qed.

Theorem prime_le_k (k p : nat) : In p (get_primes k) -> 1 < p <= k.
Proof.
  induction k as [| k1 IH]; [contradiction|]. intro H.
  pose (prime_sieve_is_ps_list (S k1)) as psl.
  destruct k1 as [| k2]; [contradict H|].
  apply (in_get_primes_Sk p (S k2)) in H as [H | [H _]].
  - apply IH in H. lia.
  - subst p. lia.
Qed.

Theorem get_primes_prime_head (k : nat)
  : prime k -> In k (get_primes k).
Proof.
  induction k as [| k1 IH]; intro H.
  { simpl in *. unfold prime in H.
    destruct H as [[C _] _]. now apply C. }
  destruct (snd (update_primes (S k1) (prime_sieve k1))) eqn:H1.
  - rewrite (get_primes_Sk_eq k1 H1).
    rewrite update_primes_snd_is_composite in H1.
    apply (is_composite_prop (S k1) _ (prime_sieve_is_ps_list k1)) in H1.
    destruct H1 as [q [q_in q_div]].
    unfold prime in H. destruct H as [[kn0 kn1] H].
    exfalso. apply H. exists q. apply prime_le_k in q_in.
    split; lia.
  - destruct k1 as [| k2].
    { apply prime_is_prime in H. unfold is_prime in H.
      discriminate H. }
    pose (Nat.lt_0_succ k2) as k_gt.
    rewrite (get_primes_Sk_cons (S k2) k_gt H1).
    simpl. now left.
Qed.

Theorem get_primes_div_k (k : nat)
  : 1 < k -> exists p : nat, In p (get_primes k) /\ k mod p = 0.
Proof.
  intro k_gt.
  destruct k as [| k1];
    [contradict k_gt; apply Nat.nlt_0_r|].
  destruct (snd (update_primes (S k1) (prime_sieve k1))) eqn:comp.
  - rewrite (get_primes_Sk_eq k1 comp).
    rewrite update_primes_snd_is_composite in comp.
    apply (is_composite_prop
             (S k1) (prime_sieve k1)
             (prime_sieve_is_ps_list k1)
             comp).
  - apply lt_S_n in k_gt. rewrite (get_primes_Sk_cons k1 k_gt comp).
    simpl. exists (S k1). split.
    + left. reflexivity.
    + apply Nat.mod_same. lia.
Qed.

Lemma get_primes_div' (k n : nat)
  : 1 < n -> exists p : nat, 1 < p <= n /\ In p (get_primes (k + n)) /\ n mod p = 0.
Proof.
  induction k as [| k1 IH]; intro n_gt.
  - simpl. apply get_primes_div_k in n_gt as [p [p_in p_div]].
    exists p. split; [|split]; try assumption.
    apply prime_le_k, p_in.
  - apply IH in n_gt as [p [[p_gt p_lt] [p_in p_div]]].
    clear IH. exists p. split; [auto | split]; [|exact p_div].
    simpl. apply get_primes_include_Sk, p_in.
Qed.

Theorem get_primes_div (k n : nat)
  : 1 < n <= k -> exists p : nat, 1 < p <= n /\ In p (get_primes k) /\ n mod p = 0.
Proof.
  intros [n_gt n_lt]. pose (k - n) as d.
  replace k with (d + n) by lia.
  apply get_primes_div', n_gt.
Qed.

Theorem hd_in {X : Type} (x : X) (xs : list X)
  : hd_error xs = Some x -> In x xs.
Proof.
  intro H. destruct xs as [| x1 xs1].
  - simpl in H. discriminate H.
  - simpl in H. inversion H as [eq]. simpl. left. reflexivity.
Qed.

Theorem get_primes_return_primes (k p : nat)
  : In p (get_primes k) <-> (p <= k /\ prime p).
Proof.
  generalize dependent p.
  induction k as [| k1 IH]; intro p.
  - simpl. split; intro H; try contradiction.
    destruct H as [H1 H2]. apply Nat.le_0_r in H1.
    subst p. rewrite prime_is_prime in H2.
    unfold is_prime in H2. simpl in H2. discriminate H2.
  - split; intro H.
    + apply in_get_primes_Sk in H as H'.
      destruct H' as [H1 | [H1 H2]].
      * apply IH in H1 as [H1 H2]. split; [| exact H2].
        apply Nat.le_le_succ_r, H1.
      * { split.
          - rewrite <- H1. apply Nat.le_refl.
          - subst p. unfold prime. split; [split|].
            + apply Nat.neq_succ_0.
            + intro Hc. rewrite Hc in H. apply H.
            + intros [q [[q_gt q_lt] q_div]]. apply lt_n_Sm_le in q_lt.
              pose (get_primes_div k1 q (conj q_gt q_lt)) as H3.
              destruct H3 as [r [[r_gt r_lt] [r_in r_div]]].
              apply H2 in r_in as r_ndiv.
              rewrite Nat.mod_divide in *|-; try lia.
              apply r_ndiv, (Nat.divide_trans r q (S k1)); assumption.
        }
    + destruct H as [p_lt p_prime].
      apply le_lt_or_eq in p_lt. destruct p_lt as [p_lt | p_eq].
      * apply lt_n_Sm_le in p_lt. apply get_primes_include_Sk.
        apply ((proj2 (IH p)) (conj p_lt p_prime)).
      * subst p. destruct k1 as [| k2] eqn:eq.
        { subst k1. simpl. apply prime_is_prime in p_prime.
          discriminate p_prime. }
        assert (0 < (S k2)) as neq_k by lia.
        apply get_primes_prime_head, p_prime.
Qed.

Theorem get_primes_return_all_primes (k p : nat)
  : p <= k  -> prime p -> In p (get_primes k).
Proof.
  intros p_lt p_prime. apply get_primes_return_primes. auto.
Qed.

(* 6.4.4 The Type of Disjoint Sums *)
Print sum.
(* Inductive sum (A B : Type) : Type
   := inl : A -> A + B
    | inr : B -> A + B *)
Check (sum nat bool).     (* (nat + bool)%type : Set *)
Check (inl bool 4).     (* inl 4 : nat + bool *)
Check (inr nat false). (* inr false : nat + bool *)


(******************************************************************************)
(* Solutions of exercises : Type inference by canonical structures            *)
(******************************************************************************)

From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path.
From mathcomp Require Import choice fintype  tuple finset.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(******************************************************************************)
(* Exercise 5.1.1                                                             *)
(******************************************************************************)

Record zmodule_mixin (T : Type) : Type := ZmoduleMixin {
  zero : T;
  opp : T -> T;
  add : T -> T -> T;
  addA : associative add;
  addC: commutative add;
  addm0 : left_id zero add;
  add0m : left_inverse zero opp add
}.

Record zmodule : Type := Zmodule {
  carrier :> Type;
  spec : zmodule_mixin carrier
}.

Definition bool_zmoduleMixin := ZmoduleMixin addbA addbC addFb addbb.

Definition bool_zmodule := Zmodule bool_zmoduleMixin.

Definition zmadd (Z : zmodule) := add (spec Z).

Notation "x \+ y" :=    (@zmadd _ x y)(at level 50,left associativity).

(* We first need to prove that zmadd is associative and commutative *)
(* The proof consists in breaking successivly the two nested records *)
(*to recover all the ingredients present in the zmodule_mixin. Then *)
(*the goal becomes trivial because the associative and commutative *)
(*requirements were present in the spec. *)
Lemma zmaddA : forall m : zmodule, associative (@zmadd m).
Proof. by case=> Mc []. Qed.

Lemma zmaddC : forall m : zmodule, commutative (@zmadd m).
Proof. by case=> Mc []. Qed.

(* No we can conveniently prove the lemma *)
(* The ssreflect rewrite tactic allows rewrite redex selection by *)
(* pattern, and this is used here to select the occurrence where *)
(* commutativity should be used.*)
Lemma zmaddAC : forall (m : zmodule)(x y z : m), x \+ y \+ z = x \+ z \+ y.
Proof.
by move=> M x y z; rewrite -zmaddA [y \+ _]zmaddC zmaddA.
Qed.

(******************************************************************************)
(* Exercise 5.2.1                                                             *)
(******************************************************************************)

(* Be aware that the Print command shows terms as they are represented *)
(*by the system, which is possibliy syntactically slightly different *)
(*from the definition typed by the user (specially in the case of *)
(*nested pattern matching *)
Print nat_eqType.
Print nat_eqMixin.
Print eqn.
Check @eqnP.

Print bool_eqType.
Print bool_eqMixin.
Print eqb.
Check @eqbP.

(* Look for nat, bool, Equality.sort in the answer of the command: *)
Print Canonical Projections.
(* The equations stored after these declarations are respectively :
[ Equality.sort ? == nat  ] => ? = nat_eqType
[ Equality.sort ? == bool ] => ? = bool_eqType
*)

(******************************************************************************)
(* Exercise 5.2.2                                                             *)
(******************************************************************************)

(* This script uses a complex intro pattern: the apply: (iffP andP) *)
(*tactic breaks the reflect goal into two subgoals for each *)
(*implication, while interpreting the first assumption of each *)
(*generated sugoal with the andP view. Then the [[] | [<- <- ]] // *)
(*intropattern simultaneously describes the introduction operations *)
(*performed on the two subgoals:*)
(*- on the first subgoal the [] casing intropattern splits the *)
(*conjunction hypothesis into two distinct assumptions.*)
(*   - on the second hypothesis the  [<- <- ] is composed of a [] *)
(*casing intropattern and two <- rewrite intropatterns. [] performs an *)
(*injection on the equality, generating two equalities, one for each *)
(*components of the pairs.  Then both equalities are rewritten form *)
(*left to right by <- <-.  This subgoal is now trivial hence closed by *)
(*// *)
Lemma tuto_pair_eqP : forall T1 T2, Equality.axiom (@pair_eq T1 T2).
Proof.
move=> T1 T2 [u1 u2] [v1 v2] /=.
apply: (iffP andP) => [[]|[<- <-]] //.
by do 2!move/eqP->.
Qed.

(******************************************************************************)
(* Exercise 5.3.1                                                             *)
(******************************************************************************)
Section SeqMem.

Variable T : eqType.

Implicit Type s : seq T.
Implicit Types x y : T.

Lemma tuto_in_cons : forall y s x,
  (x \in y :: s) = (x == y) || (x \in s).
Proof. by []. Qed.

(* by [] is an alternative syntax for the done tactic *)
Lemma tuto_in_nil : forall x, (x \in [::]) = false.
Proof. by []. Qed.

Lemma tuto_mem_seq1 : forall x y, (x \in [:: y]) = (x == y).
Proof. by move=> x y; rewrite in_cons orbF. Qed.

(* Here we do not even need to name the elements introduced since they *)
(*will never be used later in the script. We let the system choose *)
(*names using the move=> * tactic. *)
Lemma tuto_mem_head : forall x s, x \in x :: s.
Proof.  by move=> *; exact: predU1l. Qed.

(******************************************************************************)
(* Exercise 5.3.2                                                             *)
(******************************************************************************)

Lemma tuto_mem_cat : forall x s1 s2,
  (x \in s1 ++ s2) = (x \in s1) || (x \in s2).
Proof.
by move=> x s1 s2; elim: s1 => //= y s1 IHs; rewrite !inE /= -orbA -IHs.
Qed.

Lemma tuto_mem_behead: forall s, {subset behead s <= s}.
Proof. move=> [|y s] x //; exact: predU1r. Qed.

Fixpoint tuto_has (a : pred T) s :=
  if s is x :: s' then a x || tuto_has a s' else false.

Lemma tuto_hasP : forall (a : pred T) s,
  reflect (exists2 x, x \in s & a x) (has a s).
Proof.
move=> a; elim=> [|y s IHs] /=; first by right; case.
case ay: (a y); first by left; exists y; rewrite ?mem_head.
apply: (iffP IHs) => [] [x ysx ax]; exists x => //; first exact: mem_behead.
Search _ (_ \in cons _ _).
by move: ysx ax; rewrite in_cons; case/orP=> //; move/eqP->; rewrite ay.
Qed.

(* In fact, the last line of the previous script can be simplified by *)
(*the use of the predU1P view lemma. This is possible since the mem *)
(*function on sequences is exactly programmed as required by the statement *)
(*of predU1P. *)

Lemma tuto_hasP_alt: forall (a : pred T) s,
  reflect (exists2 x, x \in s & a x) (has a s).
Proof.
move=> a; elim=> [|y s IHs] /=; first by right; case.
case ay: (a y); first by left; exists y; rewrite ?mem_head.
apply: (iffP IHs) => [] [x ysx ax]; exists x => //; first exact: mem_behead.
by case: (predU1P ysx) ax => [->|//]; rewrite ay.
Qed.

Fixpoint tuto_all a s := if s is x :: s' then a x && tuto_all a s' else true.

(* We again use predU1P to shortcut the combination of incons and eqP *)
Lemma tuto_allP : forall (a : pred T) s,
    reflect (forall x, x \in s -> a x) (all a s).
Proof.
Proof.
move=> a; elim=> [|x s IHs]; first by left.
rewrite /= andbC; case: IHs => IHs /=.
  apply: (iffP idP) => [Hx y|]; last by apply; exact: mem_head.
  by case/predU1P=> [->|Hy]; auto.
by right; move=> H; case IHs; move=> y Hy; apply H; exact: mem_behead.
Qed.

End SeqMem.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

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

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) : natural
           := match mult_arg0, mult_arg1 with
              | Zero, n => Zero
              | Succ n, m => plus (mult n m) m
              end.

Fixpoint fac (fac_arg0 : natural) : natural
           := match fac_arg0 with
              | Zero => Succ Zero
              | Succ n => mult (fac n) n
              end.

Fixpoint qfac (qfac_arg0 : natural) (qfac_arg1 : natural) : natural
           := match qfac_arg0, qfac_arg1 with
              | Zero, n => n
              | Succ n, m => qfac n (mult m n)
              end.

Lemma plus_succ : forall (x y : natural), plus x (Succ y) = Succ (plus x y).
Proof.
intros.
induction x.
- reflexivity.
- simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_assoc : forall (x y z : natural), plus (plus x y) z = plus x (plus y z).
Proof.
intros.
induction x.
- reflexivity.
- simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_zero : forall (x : natural), plus x Zero = x.
Proof.
intros.
induction x.
- reflexivity.
- simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_commut : forall (x y : natural), plus x y = plus y x.
Proof.
intros.
induction x.
- rewrite plus_zero. reflexivity.
- simpl. rewrite plus_succ. rewrite IHx. reflexivity.
Qed.

Lemma mult_zero : forall (x : natural), mult x Zero = Zero.
Proof.
intros.
induction x.
- reflexivity.
- simpl. rewrite IHx. reflexivity.
Qed.

Lemma mult_succ : forall (x y : natural), plus (mult x y) x = mult x (Succ y).
Proof.
intros.
induction x.
- reflexivity.
- simpl.  rewrite plus_succ. lfind.  rewrite (plus_commut y x). lfind.  rewrite IHx.  rewrite plus_succ.  reflexivity.
Admitted.

Lemma mult_commut : forall (x y : natural), mult x y = mult y x.
Proof.
intros.
induction x.
- rewrite mult_zero. reflexivity.
- simpl. rewrite IHx. rewrite mult_succ. reflexivity.
Qed.

Lemma distrib : forall (x y z : natural), mult (plus x y) z = plus (mult x z) (mult y z).
Proof.
intros.
induction x.
- reflexivity.
- simpl. rewrite IHx. rewrite plus_assoc. rewrite (plus_commut (mult y z) z). rewrite <- plus_assoc. reflexivity.
Qed.

Lemma mult_assoc : forall (x y z : natural), mult (mult x y) z = mult x (mult y z).
Proof.
intros.
induction x.
- reflexivity.
- simpl. rewrite distrib. rewrite IHx. reflexivity.
Qed.

Theorem theorem0 : forall (x : natural) (y : natural), eq (mult (fac x) y) (qfac x y).
Proof.
induction x.
- reflexivity.
- intros. simpl. rewrite <- IHx. rewrite mult_assoc. rewrite (mult_commut x y). reflexivity.
Qed.


Inductive subseq : list nat -> list nat -> Prop :=
| first_case: forall (l2: list nat), subseq [] l2
| second_case: forall (l1 l2: list nat) (x: nat),
    subseq l1 l2  ->
    subseq (x :: l1) (x :: l2)
| third_case: forall (l1 l2: list nat) (x: nat),
    subseq l1 l2 -> subseq l1 (x :: l2).

Theorem subseq_refl : forall (l: list nat),
    subseq l l.
Proof.
  intros.
  induction l as [| h t IH].
  - apply first_case.
  - apply second_case. apply IH.
Qed.

Theorem subseq_app : forall (l1 l2 l3: list nat),
  subseq l1 l2 -> subseq l1 (l2 ++ l3).
Proof.
  intros.
  induction H.
  - apply first_case.
  - simpl. apply second_case. apply IHsubseq.
  - simpl. apply third_case. apply IHsubseq.
Qed.


(**
  Exercícios

  1) Theorem ex1 : forall P Q, P /\ Q -> P.
  2) Theorem ex2 : forall P Q, P /\ Q -> Q.
  3) Theorem ex3 : forall P Q, (P -> Q) -> P -> Q.
  4) Theorem ex4 : forall P Q R, (P \/ Q) -> (P -> R) -> (Q -> R) -> R.

**)

Theorem ex1 : forall P Q, P /\ Q -> P.
Proof.
  intros. destruct H as [H1 H2]. apply H1.
Qed.

Theorem ex2 : forall P Q, P /\ Q -> Q.
Proof.
  intros. destruct H as [H1 H2]. apply H2.
Qed.

Theorem ex3 : forall P Q, (P -> Q) /\ P -> Q.
Proof.
(* Prova aqui *)
Admitted.

Theorem ex4 : forall P Q R, (P \/ Q) -> (P -> R) -> (Q -> R) -> R.
Proof.
(* Prova aqui *)
Admitted.