Require Import
  MathClasses.theory.setoids MathClasses.interfaces.abstract_algebra.

Local Existing Instance injective_mor.
Local Existing Instance surjective_mor.

Lemma injective_compose_cancel `{Equiv A} `{Equiv B} `{Equiv C} (f : B → C)
    `{!Injective f} `{!Setoid_Morphism (g : A → B)} `{!Setoid_Morphism (h : A → B)} :
  f ∘ g = f ∘ h → g = h.
Proof.
  pose proof (setoidmor_a g).
  intros E. apply setoids.ext_equiv_applied_iff. intros x.
  apply (injective f). now apply E.
Qed.

Lemma surjective_applied `{Equiv A} `{Equiv B} (f : A → B) `{!Inverse f} `{!Surjective f} x : f (f⁻¹ x) = x.
Proof. firstorder. Qed.

#[global]
Instance inverse_mor `{Bijective A B f} : Setoid_Morphism (f⁻¹).
Proof.
  pose proof (setoidmor_a f). pose proof (setoidmor_b f).
  split; try apply _.
  intros x y E. apply (injective f). now rewrite !(surjective_applied f).
Qed.

Lemma bijective_cancel_left `{Equiv A} `{Equiv B} (f : A → B) `{!Inverse f} `{!Bijective f} x y :
  f x = y → x = f⁻¹ y.
Proof.
  pose proof (setoidmor_b f).
  intros E. apply (injective f). now rewrite (surjective_applied f).
Qed.

Lemma bijective_cancel_inverse_left `{Equiv A} `{Equiv B} (f : A → B) `{!Inverse f} `{!Bijective f} x y :
  f⁻¹ x = y → x = f y.
Proof.
  pose proof (setoidmor_a f). pose proof (setoidmor_b f).
  intros E. now rewrite <-E, (surjective_applied f).
Qed.

Lemma bijective_applied `{Equiv A} `{Equiv B} (f : A → B) `{!Inverse f} `{!Bijective f} x: f⁻¹ (f x) = x.
Proof.
  pose proof (setoidmor_a f). pose proof (setoidmor_b f).
  symmetry. now apply (bijective_cancel_left f).
Qed.

Lemma bijective `{Equiv A} `{Equiv B} (f : A → B) `{!Inverse f} `{!Bijective f} : f⁻¹ ∘ f = id. (* a.k.a. "split-mono" *)
Proof.
  pose proof (setoidmor_a f).
  apply ext_equiv_applied_iff, (bijective_applied f).
Qed.

Lemma injective_ne `{Equiv A} `{Equiv B} `(f : A → B) `{!Injective f} x y :
  x ≠ y → f x ≠ f y.
Proof. intros E1 E2. apply E1. now apply (injective f). Qed.

#[global]
Instance id_inverse {A} : Inverse (@id A) := (@id A).

Global Existing Instance id_morphism.

#[global]
Instance id_injective `{Setoid A} : Injective (@id A).
Proof. split; try apply _. easy. Qed.
#[global]
Instance id_surjective `{Setoid A} : Surjective (@id A).
Proof. split; try apply _. now repeat intro. Qed.
#[global]
Instance id_bijective `{Setoid A} : Bijective (@id A).
Proof. split; try apply _. Qed.

Section compositions.
  Context `{Equiv A} `{Equiv B} `{Equiv C} (g: A → B) (f: B → C) `{!Inverse f} `{!Inverse g}.

  Instance compose_inverse: Inverse (f ∘ g) := g⁻¹ ∘ f⁻¹.

  Instance compose_injective: Injective f → Injective g → Injective (f ∘ g).
  Proof. firstorder. Qed.
  Instance compose_surjective: Surjective f → Surjective g → Surjective (f ∘ g).
  Proof.
    split; try apply _.
    pose proof (setoidmor_b f).
    intros x y E. rewrite <-E.
    change (f (g (g⁻¹ (f⁻¹ x))) = x).
    now rewrite !surjective_applied.
  Qed.
  Instance compose_bijective: Bijective f → Bijective g → Bijective (f ∘ g) := {}.
End compositions.

#[global]
Hint Extern 4 (Inverse (_ ∘ _)) => class_apply @compose_inverse : typeclass_instances.
#[global]
Hint Extern 4 (Injective (_ ∘ _)) => class_apply @compose_injective : typeclass_instances.
#[global]
Hint Extern 4 (Surjective (_ ∘ _)) => class_apply @compose_surjective : typeclass_instances.
#[global]
Hint Extern 4 (Bijective (_ ∘ _)) => class_apply @compose_bijective : typeclass_instances.

Lemma alt_Build_Injective `{Equiv A} `{Equiv B} (f : A → B) `{!Inverse f} :
  Setoid_Morphism f → Setoid_Morphism (f⁻¹) → f⁻¹ ∘ f = id → Injective f.
Proof.
  intros ?? E.
  pose proof (setoidmor_a f). pose proof (setoidmor_b f).
  split; try apply _.
  intros x y F.
  rewrite <-(ext_equiv_applied E x), <-(ext_equiv_applied E y).
  unfold compose. now rewrite F.
Qed.

Lemma alt_Build_Bijective `{Equiv A} `{Equiv B} (f : A → B) `{!Inverse f} :
  Setoid_Morphism f → Setoid_Morphism (f⁻¹) → f⁻¹ ∘ f = id → f ∘ f⁻¹ = id → Bijective f.
Proof.
  intros. split.
   now apply (alt_Build_Injective f).
  split; auto.
Qed.

Definition inverse_inverse `{Inverse A B f} : Inverse (f⁻¹) := f.
#[global]
Hint Extern 4 (Inverse (_ ⁻¹)) => class_apply @inverse_inverse : typeclass_instances.

Lemma flip_bijection `{Bijective A B f} : Bijective (f⁻¹).
Proof. apply alt_Build_Bijective; try apply _. apply (surjective f). apply (bijective f). Qed.

(* We use this instead of making flip_bijection a real instance, because
   otherwise it gets applied too eagerly, resulting in cycles. *)
#[global]
Hint Extern 4 (Bijective (_ ⁻¹)) => apply flip_bijection : typeclass_instances.

Lemma inverse_involutive `(f : A → B) `{!Inverse f} : (f⁻¹)⁻¹ ≡ f.
Proof. reflexivity. Qed.

(* This second version is strictly for manual application. *)
Lemma flip_bijection_back `{Equiv A} `{Equiv B} (f: A → B) `{!Inverse f} : Bijective (f⁻¹) → Bijective f.
Proof. intro. apply (_: Bijective (f⁻¹⁻¹)). Qed.

#[global]
Instance injective_proper `{Equiv A} `{Equiv B} : Proper ((=) ==> (=)) (@Injective A B _ _).
Proof.
  assert (∀ f g : A → B, f = g → Injective f → Injective g) as aux.
   intros f g E ?. pose proof (setoidmor_a f). pose proof (setoidmor_b f). split.
    intros x y ?. apply (injective f).
    now rewrite (ext_equiv_applied E x), (ext_equiv_applied E y).
   rewrite <-E; apply _.
  intros f g; split; intros; eapply aux; eauto.
  pose proof (setoidmor_a g). pose proof (setoidmor_b g). now symmetry.
Qed.

Lemma surjective_proper `{Equiv A} `{Equiv B} (f g : A → B) `{!Inverse f} `{!Inverse g} `{!Surjective g} :
  f = g → f⁻¹ = g⁻¹  → Surjective f.
Proof.
  intros E1 E2.
  pose proof (setoidmor_a g). pose proof (setoidmor_b g).
  split.
   intros ? ? E3. change (f  (f⁻¹ x) = y).
   rewrite <-E3, (ext_equiv_applied E1 _), (ext_equiv_applied E2 _).
   now apply surjective_applied.
  rewrite E1; apply _.
Qed.

Ltac setoid_inject :=
  match goal with
  | E : _ = ?f _ |- _ => apply (injective f) in E
  | E : ?f _ = _ |- _ => apply (injective f) in E
  | E : _ ≡ _ |-  ?G => change (id G); injection E; clear E; intros; unfold id at 1
  end.


(** * Coslice categories

Author: Langston Barrett (@siddharthist), March 2018
*)

(** ** Contents:

- Definition of coslice categories, x/C

*)

Require Import UniMath.Foundations.PartA.
Require Import UniMath.Foundations.PartD.
(* Require Import UniMath.Foundations.Propositions. *)
(* Require Import UniMath.Foundations.Sets. *)
Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.

(** for second construction: *)
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.

Local Open Scope cat.

(** * Definition of coslice categories *)

(** Given a category C and x : obj C. The coslice category x/C is given by:

  - obj x/C: pairs (a,f) where f : x --> a
  - morphisms (a,f) --> (b,g): morphism h : a --> b with
<<
       x
       | \
       |  \
     f |   \  g
       v    \
       a --> b
          h
>>
    where f · h = g

*)
Section coslice_cat_def.

Context (C : category) (x : C).

(** Accessor functions *)
Definition coslicecat_ob := ∑ a, C⟦x,a⟧.
Definition coslicecat_mor (f g : coslicecat_ob) := ∑ h, pr2 f · h = pr2 g.
Definition coslicecat_ob_object (f : coslicecat_ob) : ob C := pr1 f.
Definition coslicecat_ob_morphism (f : coslicecat_ob) : C⟦x, coslicecat_ob_object f⟧ := pr2 f.
Definition coslicecat_mor_morphism {f g : coslicecat_ob} (h : coslicecat_mor f g) :
  C⟦coslicecat_ob_object f, coslicecat_ob_object g⟧ := pr1 h.
Definition coslicecat_mor_comm {f g : coslicecat_ob} (h : coslicecat_mor f g) :
  (coslicecat_ob_morphism f) · (coslicecat_mor_morphism h) =
  (coslicecat_ob_morphism g) := pr2 h.

(** Definitions *)
Definition coslice_precat_ob_mor : precategory_ob_mor :=
  (coslicecat_ob,,coslicecat_mor).

Definition id_coslice_precat (c : coslice_precat_ob_mor) : c --> c :=
  tpair _ _ (id_right (pr2 c)).

Definition comp_coslice_precat {a b c : coslice_precat_ob_mor}
           (f : a --> b) (g : b --> c) : a --> c.
Proof.
  use tpair.
  - exact (coslicecat_mor_morphism f · coslicecat_mor_morphism g).
  - abstract (refine (assoc _ _ _ @ _);
              refine (maponpaths (λ f, f · _) (coslicecat_mor_comm f) @ _);
              refine (coslicecat_mor_comm g)).
Defined.

Definition coslice_precat_data : precategory_data :=
  make_precategory_data _ id_coslice_precat (@comp_coslice_precat).

Lemma is_precategory_coslice_precat_data :
  is_precategory coslice_precat_data.
Proof.
  use make_is_precategory; intros; unfold comp_coslice_precat;
    cbn; apply subtypePairEquality.
  * intro; apply C.
  * apply id_left.
  * intro; apply C.
  * apply id_right.
  * intro; apply C.
  * apply assoc.
  * intro; apply C.
  * apply assoc'.
Defined.

(** that the previous Lemma is defined was done on purpose in 2018 - is it still appropriate? *)

Definition coslice_precat : precategory :=
  (_,,is_precategory_coslice_precat_data).

Lemma has_homsets_coslice_precat : has_homsets (coslice_precat).
Proof.
  intros a b.
  induction a as [a f]; induction b as [b g]; simpl.
  apply (isofhleveltotal2 2); [ apply C | intro h].
  apply isasetaprop; apply C.
Qed.

Definition coslice_cat : category := make_category _ has_homsets_coslice_precat.

End coslice_cat_def.

Section coslice_cat_displayed.

Context (C : category) (x : C).

Definition coslice_cat_disp_ob_mor : disp_cat_ob_mor C.
Proof.
  use make_disp_cat_ob_mor.
  - intro a. exact (x --> a).
  - intros a b f g h. exact (f · h = g).
Defined.

Lemma coslice_cat_disp_id_comp : disp_cat_id_comp C coslice_cat_disp_ob_mor.
Proof.
  split.
  - intros a f.
    apply id_right.
  - intros a1 a2 a3 h h' f1 f2 f3 Hyph Hyph'.
    etrans.
    { apply assoc. }
    etrans.
    { apply cancel_postcomposition, Hyph. }
    exact Hyph'.
Qed.

Definition coslice_cat_disp : disp_cat C.
Proof.
  use tpair.
  - use tpair.
    + exact coslice_cat_disp_ob_mor.
    + exact coslice_cat_disp_id_comp.
  - abstract (split4; intros; [apply C | apply C | apply C | apply isasetaprop; apply C]).
Defined.

Definition coslice_cat_total : category := total_category coslice_cat_disp.

End coslice_cat_displayed.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
Require Import Max Lia.
From mathcomp Require Import ssreflect ssrbool ssrnat seq.
Require Import ssrnat_ext.
Export Max.

Lemma max_lemma1 x1 x2 x3 : x2 <= x1 -> max x2 x3 <= max x1 x3.
Proof.
move=> H.
case: (max_dec x1 x3) => H1.
  case: (max_dec x2 x3) => H2.
    by rewrite H1 H2.
  rewrite H1 H2.
  move: (le_max_r x1 x3) => H0.
  rewrite H1 in H0.
  ssromega.
case: (max_dec x2 x3) => H2.
  rewrite H1 H2.
  move: (le_max_l x1 x3) => H0.
  rewrite H1 in H0.
  ssromega.
by rewrite H1 H2.
Qed.

Lemma max_max a b c d : a <= c -> b <= d -> max a b <= max c d.
Proof.
move=> a_c b_d; case: (max_dec a b) => ->.
- apply (@leq_trans c) => //; by apply/leP/le_max_l.
- apply (@leq_trans d) => //; by apply/leP/le_max_r.
Qed.

Lemma lt_max_inv x1 x2 x3 : max x2 x3 < x1 -> x2 < x1 /\ x3 < x1.
Proof.
move=> H; case: (max_dec x2 x3) => H0.
- move: (le_max_r x2 x3) => H1; ssromega.
- move: (le_max_l x2 x3) => H1; ssromega.
Qed.

Lemma lt_max x1 x2 x3 : x2 < x1 /\ x3 < x1 -> max x2 x3 < x1.
Proof. move=> [H0 H1]. case: (max_dec x2 x3) => H; ssromega. Qed.

Lemma le_max x1 x2 x3 : x2 <= x1 /\ x3 <= x1 -> max x2 x3 <= x1.
Proof.
move=> [H0 H1].
have [H2 | H2] : (x2 >= x3 \/ x3 >= x2)%coq_nat by lia.
- rewrite max_l; ssromega.
- rewrite max_r; ssromega.
Qed.

Lemma le_max_l_trans x y z : x <= z -> x <= max z y.
Proof. move=> H; generalize (le_max_l z y) => ?; ssromega. Qed.

Lemma le_max_r_trans x y z : x <= z -> x <= max y z.
Proof. move=> H; generalize (le_max_r y z) => ?; ssromega. Qed.

Ltac Resolve_le_max :=
  match goal with
    | |- is_true (max ?y ?z <= ?x) =>
      apply le_max; split; [Resolve_le_max | Resolve_le_max]
    | |- is_true (?z <= max ?x ?y) =>
      apply le_max_l_trans; Resolve_le_max
    | |- is_true (?z <= max ?x ?y) =>
      apply le_max_r_trans; Resolve_le_max
    | |- is_true (?z < ?x + (S ?y)) =>
      cut (is_true (z <= x)); [move=> ?; ssromega | Resolve_le_max]
    | _ => ssromega
  end.

Lemma le_max_inv a b n : max a b <= n -> a <= n /\ b <= n.
Proof.
case: (max_dec a b) => max_a_b.
- rewrite max_a_b => H; split; first by [].
  apply (@leq_trans a) => //.
  rewrite -max_a_b; by apply/leP/le_max_r.
- rewrite max_a_b => H; split; last by [].
  apply (@leq_trans b) => //.
  rewrite -max_a_b; by apply/leP/le_max_l.
Qed.

Definition max_list l def := foldl max def l.

Lemma max_list_max_comm : forall a b c, max_list a (max b c) = max b (max_list a c).
Proof. elim => // hd tl IH b c /=; by rewrite 2!IH max_assoc. Qed.

Lemma le_max_list_R : forall l x def, x <= def -> x <= max_list l def.
Proof.
elim=> // h t IH x def x_def /=.
by apply IH, (le_max_l_trans _ h _ x_def).
Qed.

Lemma In_le_max_list : forall l def x, List.In x l -> x <= max_list l def.
Proof.
elim=> // hd tl IH def x /= [-> | H].
by apply/le_max_list_R/leP/le_max_r.
by apply IH.
Qed.

Lemma le_max_list_def : forall l x, x <= max_list l x.
Proof. elim => // hd tl IH x /=; by apply/le_max_list_R/leP/le_max_l. Qed.

Lemma max_list_inv : forall a b n, max_list a b <= n -> b <= n.
Proof. elim => // hd tl IH b n /=; rewrite max_list_max_comm; by case/le_max_inv. Qed.

Lemma max_list_inv2 : forall a b n, max_list a b <= n ->
  forall x, List.In x a -> x <= n.
Proof.
elim => // hd tl IH b n /= H x [] X.
- subst hd.
  rewrite max_comm max_list_max_comm in H.
  by case/le_max_inv : H.
- apply (IH b) => //.
  rewrite max_comm max_list_max_comm in H.
  by case/le_max_inv : H.
Qed.

Lemma lt_max_list l x y z : max_list l y < x -> z < x -> max_list l (max y z) < x.
Proof. move=> H1 H2; rewrite max_comm max_list_max_comm; by apply lt_max. Qed.

Lemma lt_max_list_inv : forall l x def, max_list l def < x -> def < x.
Proof. elim=> // h t IH x def /= /IH; by case/lt_max_inv. Qed.

Lemma lt_max_list_inv2 : forall l x def, max_list l def < x ->
  forall y, List.In y l -> y < x.
Proof.
elim=> // h t IH x def /= H y [].
  move=> ?; subst h.
  rewrite max_comm max_list_max_comm in H.
  by case/lt_max_inv : H.
move=> y_t.
apply IH with def => //.
rewrite max_comm max_list_max_comm in H.
by case/lt_max_inv : H.
Qed.

Lemma max_list_app_inv : forall a b x def, max_list (a ++ b) def < x ->
  max_list a def < x /\ max_list b def < x.
Proof.
elim=> [ | h t IH b x def] /=.
  move=> b x def H; split; last by done.
  move: H; by apply lt_max_list_inv.
case/IH => H1 H2; split; first by assumption.
rewrite max_comm max_list_max_comm in H2.
by case/lt_max_inv : H2.
Qed.

Lemma max_list_app : forall a b x def, max_list a def < x /\ max_list b def < x ->
  max_list (a ++ b) def < x.
Proof.
elim=> /= [b x def [] // | h t IH b x def [H1 H2]].
apply IH.
split => //.
apply lt_max_list => //.
by move/lt_max_list_inv : H1 => /lt_max_inv [].
Qed.

Definition max_lst l := max_list l O.

Ltac Resolve_lt_max :=
  Resolve_lt_max_hypo; Resolve_lt_max_goal
with
  Resolve_lt_max_hypo := match goal with
    | H: is_true (max ?y ?z < ?x)%nat |- _ =>
      generalize (lt_max_inv _ _ _ H); intro X; inversion_clear X; clear H; Resolve_lt_max_hypo
    | H: is_true (max_lst (seq.cat ?y ?z) < ?x)%nat |- _ =>
      generalize (max_list_app_inv _ _ _ _ H); intro X; inversion_clear X; clear H; Resolve_lt_max_hypo
    | H: is_true (max_lst _ < ?x)%nat |- _ => rewrite /max_lst /= in H; Resolve_lt_max_hypo
    | |- _ =>  idtac
  end
with
  Resolve_lt_max_goal := match goal with
    | |- is_true (max ?y ?z < ?x)%nat =>
      apply lt_max; split; [Resolve_lt_max_goal | Resolve_lt_max_goal]
    | |- is_true (max_lst (seq.cat ?y ?z) < ?x)%nat =>
      apply max_list_app; split; [Resolve_lt_max_goal | Resolve_lt_max_goal]
    | |- is_true (max_lst _ < ?x)%nat => rewrite /max_lst /=; Resolve_lt_max_goal
    | |- _ => ssromega || tauto
  end.


(* week-05_mystery-functions.v *)
(* FPP 2019 - YSC3236 2019-2020, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of 10 Sep 2019 *)

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

Require Import Arith Bool.

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

Notation "A =b= B" :=
  (eqb A B) (at level 70, right associativity).

Definition beq_nat_nat (p1 p2 : nat * nat) : bool :=
  match p1 with
  | (n11, n12) =>
    match p2 with
    | (n21, n22) =>
      (n11 =n= n21) && (n12 =n= n22)
    end
  end.
Search (_ + _ = _).
Notation "A =nn= B" :=
  (beq_nat_nat A B) (at level 70, right associativity).

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

Definition specification_of_mystery_function_00 (mf : nat -> nat) :=
  mf 0 = 1 /\ forall i j : nat, mf (S (i + j)) = mf i + mf j.

Proposition there_is_at_most_one_mystery_function_00 :
  forall f g : nat -> nat,
    specification_of_mystery_function_00 f ->
    specification_of_mystery_function_00 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_mystery_function_00.
  intros [H_f_O H_f_S] [H_g_O H_g_S].
  intro n.
  induction n as [ | n' IHn'].

  - rewrite -> H_g_O.
    exact H_f_O.

  - rewrite <- (Nat.add_0_l n').
    rewrite -> (H_f_S 0 n').
    rewrite -> (H_g_S 0 n').
    rewrite -> H_f_O.
    rewrite -> H_g_O.
    rewrite -> IHn'.
    reflexivity.
Qed.

Definition unit_test_for_mystery_function_00a (mf : nat -> nat) :=
  (mf 0 =n= 1) (* etc. *).

Definition unit_test_for_mystery_function_00b (mf : nat -> nat) :=
  (mf 0 =n= 1) && (mf 1 =n= 2) (* etc. *).

Definition unit_test_for_mystery_function_00c (mf : nat -> nat) :=
  (mf 0 =n= 1) && (mf 1 =n= 2) && (mf 2 =n= 3) (* etc. *).

Definition unit_test_for_mystery_function_00d (mf : nat -> nat) :=
  (mf 0 =n= 1) && (mf 1 =n= 2) && (mf 2 =n= 3) && (mf 3 =n= 4)
  (* etc. *).

Definition mystery_function_00 := S.

Definition less_succinct_mystery_function_00 (n : nat) : nat :=
  S n.

Compute (unit_test_for_mystery_function_00d mystery_function_00).

Theorem there_is_at_least_one_mystery_function_00 :
  specification_of_mystery_function_00 mystery_function_00.
Proof.
  unfold specification_of_mystery_function_00, mystery_function_00.
  split.
  - reflexivity.
  - intros i j.
    rewrite -> plus_Sn_m.
    rewrite <- plus_n_Sm.
    reflexivity.
Qed.

Definition mystery_function_00_alt := fun (n : nat) => n + 1.

Theorem there_is_at_least_one_mystery_function_00_alt :
  specification_of_mystery_function_00 mystery_function_00_alt.
Proof.
Abort.

Theorem soundness_of_the_unit_test_function_for_mystery_function_00 :
  forall mf : nat -> nat,
    specification_of_mystery_function_00 mf ->
    unit_test_for_mystery_function_00c mf = true.
Proof.
  unfold specification_of_mystery_function_00.
  unfold unit_test_for_mystery_function_00c.
  intros mf [H_O H_S].
  (* Goal: (mf 0 =n= 1) && (mf 1 =n= 2) && (mf 2 =n= 3) = true *)
  rewrite -> H_O.
  (* Goal: (1 =n= 1) && (mf 1 =n= 2) && (mf 2 =n= 3) = true *)
  rewrite -> (Nat.eqb_refl 1).
  (* Goal: true && (mf 1 =n= 2) && (mf 2 =n= 3) = true *)
  rewrite -> (andb_true_l (mf 1 =n= 2)).
  (* Goal: (mf 1 =n= 2) && (mf 2 =n= 3) = true *)
  (* etc. *)
  Check (Nat.add_1_l 0).
  rewrite <- (Nat.add_1_l 0) at 1.
  Check (plus_Sn_m 0 0).
  rewrite -> (plus_Sn_m 0 0).
  rewrite -> (H_S 0 0).
  rewrite -> H_O.
  rewrite -> (Nat.add_1_l 1).
  Check (Nat.eqb_refl 2).
  rewrite -> (Nat.eqb_refl 2).
  rewrite -> (andb_true_l (mf 2 =n= 3)).
  Check (Nat.add_1_l 1).
  rewrite <- (Nat.add_1_l 1) at 1.
  Check (plus_Sn_m 0 1).
  rewrite -> (plus_Sn_m 0 1).
  rewrite -> (H_S 0 1).
  rewrite -> H_O.
  rewrite <- (Nat.add_1_l 0) at 2.
  Check (plus_Sn_m 0 0).
  rewrite -> (plus_Sn_m 0 0).
  rewrite -> (H_S 0 0).
  rewrite -> H_O.
  rewrite -> (Nat.add_1_l 1).
  rewrite -> (Nat.add_1_l 2).
  exact (Nat.eqb_refl 3).
Qed.

Theorem soundness_of_the_unit_test_function_for_mystery_function_00b :
  forall mf : nat -> nat,
    specification_of_mystery_function_00 mf ->
    unit_test_for_mystery_function_00b mf = true.
Proof.
  unfold specification_of_mystery_function_00,
         unit_test_for_mystery_function_00b.
  intros mf [H_O H_S].
  (* Goal: (mf 0 =n= 1) && (mf 1 =n= 2) = true *)
  rewrite -> H_O.
  (* Goal: (1 =n= 1) && (mf 1 =n= 2) = true *)
  rewrite -> (Nat.eqb_refl 1).
  (* Goal: true && (mf 1 =n= 2) = true *)
  rewrite -> (andb_true_l (mf 1 =n= 2)).
  (* Goal: (mf 1 =n= 2) = true *)
  (* etc. *)
  Check (Nat.add_1_l 0).
  rewrite <- (Nat.add_1_l 0) at 1.
  Check (plus_Sn_m 0 0).
  rewrite -> (plus_Sn_m 0 0).
  rewrite -> (H_S 0 0).
  rewrite -> H_O.
  Check (plus_Sn_m 0 1).
  rewrite -> (plus_Sn_m 0 1).
  Check (Nat.add_1_r 0).
  rewrite -> (Nat.add_1_r 0).
  Check (Nat.eqb_refl 2).
  exact (Nat.eqb_refl 2).
Qed.

Theorem soundness_of_the_unit_test_function_for_mystery_function_00_with_Search :
  forall mf : nat -> nat,
    specification_of_mystery_function_00 mf ->
    unit_test_for_mystery_function_00b mf = true.
Proof.
  unfold specification_of_mystery_function_00,
         unit_test_for_mystery_function_00b.
  intros mf [H_O H_S].

  rewrite -> H_O.
  Search(beq_nat _  _ = true).
  Check (Nat.eqb_refl 1).
  rewrite -> (Nat.eqb_refl 1).
  Search (true && _ = _).
  Check (andb_true_l (mf 1 =n= 2)).
  rewrite -> (andb_true_l (mf 1 =n= 2)).

  Check (Nat.add_1_l 0).
  rewrite <- (Nat.add_1_l 0) at 1.
  Check (plus_Sn_m 0 0).
  rewrite -> (plus_Sn_m 0 0).
  rewrite -> (H_S 0 0).
  rewrite -> H_O.
  Check (plus_Sn_m 0 1).
  rewrite -> (plus_Sn_m 0 1).
  Check (Nat.add_1_r 0).
  rewrite -> (Nat.add_1_r 0).
  Check (Nat.eqb_refl 2).
  exact (Nat.eqb_refl 2).
Qed.

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

(* {SPECIFICATION_OF_MYSTERY_FUNCTION_11} *)
Definition specification_of_mystery_function_11 (mf : nat -> nat) :=
  mf 1 = 1
  /\
  forall i j : nat,
    mf (i + j) = mf i + 2 * i * j + mf j.

Theorem there_is_at_most_one_mystery_function_11:
  forall f g : nat -> nat,
    specification_of_mystery_function_11 f ->
    specification_of_mystery_function_11 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_mystery_function_11.
  intros [H_f_1 H_f_S] [H_g_1 H_g_S].
  intro n.
  induction n as [ | n' IHn'].

  - assert (H_tmp := H_f_S 0 0).
    rewrite -> (Nat.add_0_r 0) in H_tmp.
    rewrite -> (Nat.mul_0_r (2 * 0)) in H_tmp.
    rewrite -> (Nat.add_0_r (f 0)) in H_tmp.
    rewrite <- (Nat.add_0_r (f 0)) in H_tmp at 1.
    (* apply plus_reg_l in H_tmp. *)
    (* Yikes: *)
    Check plus_reg_l.
    Check (plus_reg_l 0 (f 0) (f 0)).
    apply (plus_reg_l 0 (f 0) (f 0)) in H_tmp.
    (* *)
    rewrite <- H_tmp.
    clear H_tmp.
    assert (H_tmp := H_g_S 0 0).
    rewrite -> (Nat.add_0_r 0) in H_tmp.
    rewrite -> (Nat.mul_0_r (2 * 0)) in H_tmp.
    rewrite -> (Nat.add_0_r (g 0)) in H_tmp.
    rewrite <- (Nat.add_0_r (g 0)) in H_tmp at 1.
    apply plus_reg_l in H_tmp.
    rewrite <- H_tmp.
    clear H_tmp.
    reflexivity.

  - Search (S _ = _).
    assert (H_tmp := plus_n_Sm n' 0).
    rewrite -> (Nat.add_0_r n') in H_tmp.
    rewrite -> H_tmp.
    rewrite -> (H_f_S n' 1).
    rewrite -> (H_g_S n' 1).
    rewrite -> IHn'.
    rewrite -> H_f_1.
    rewrite -> H_g_1.
    reflexivity.
Qed.

Definition unit_test_for_mystery_function_11 (mf : nat -> nat) :=
  (mf 0 =n= 0) && (mf 1 =n= 1) && (mf 2 =n= 4) && (mf 3 =n= 9)
(* etc. *).

Definition mystery_function_11 (n : nat) : nat :=
  n * n.

Compute (unit_test_for_mystery_function_11 mystery_function_11).

Theorem there_is_at_least_one_mystery_function_11 :
  specification_of_mystery_function_11 mystery_function_11.
Proof.
  unfold specification_of_mystery_function_11, mystery_function_11.
  split.
  - rewrite -> (Nat.mul_1_r 1).
    reflexivity.

  - intros i j.
    rewrite -> (Nat.mul_add_distr_r i j (i + j)).
    rewrite -> (Nat.mul_add_distr_l i i j).
    rewrite -> (Nat.mul_add_distr_l j i j).
    rewrite -> BinInt.ZL0.
    rewrite -> (Nat.mul_add_distr_r 1 1 i).
    rewrite -> Nat.mul_1_l.
    rewrite -> (Nat.mul_add_distr_r i i j).
    rewrite -> (Nat.mul_comm j i).
    rewrite -> (Nat.add_assoc (i * i + i * j) (i * j) (j * j)).
    rewrite -> (Nat.add_assoc (i * i) (i * j) (i * j)).
    reflexivity.
Qed.

(* ***** *)

Definition specification_of_mystery_function_04 (mf : nat -> nat) :=
  mf 0 = 0
  /\
  forall n' : nat,
    mf (S n') = mf n' + S (2 * n').

Lemma equivalence_of_successor_and_add_one : (* Ahem, Check Nat.add_1_r. *)
  forall n : nat,
    S n = n + 1.
Proof.
  intro n.
  rewrite <- (Nat.add_0_r n) at 1.
  rewrite -> (plus_n_Sm n 0).
  reflexivity.
Qed.

Lemma equivalence_of_times_two_and_add_itself :
  forall n : nat,
    2 * n = n + n.
Proof.
  intro n.
  rewrite -> BinInt.ZL0.
  rewrite -> (Nat.mul_add_distr_r 1 1 n).
  rewrite -> (Nat.mul_1_l n).
  reflexivity.
Qed.

Lemma distributive_law_l_r :
  forall a b c d : nat,
    (a + b) * (c + d) = a * c + a * d + b * c + b * d.
Proof.
  intros a b c d.
  rewrite -> Nat.mul_add_distr_r.
  rewrite -> Nat.mul_add_distr_l.
  rewrite -> (Nat.mul_add_distr_l b c d).
  rewrite -> (Nat.add_assoc (a * c + a * d) (b * c) (b * d)).
  reflexivity.
Qed.

Theorem there_is_at_most_one_mystery_function_04:
  forall f g : nat -> nat,
    specification_of_mystery_function_04 f ->
    specification_of_mystery_function_04 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_mystery_function_04.
  intros [H_f_O H_f_S] [H_g_O H_g_S].
  intro n.
  induction n as [ | n' IHn'].

  - rewrite -> H_g_O.
    exact (H_f_O).

  - rewrite -> (H_f_S n').
    rewrite -> (H_g_S n').
    rewrite -> IHn'.
    reflexivity.
Qed.

Definition unit_test_for_mystery_function_04 (mf : nat -> nat) :=
  (mf 0 =n= 0) && (mf 1 =n= 1) && (mf 2 =n= 4) && (mf 3 =n= 9)
(* etc. *).

Definition mystery_function_04 (n : nat) : nat :=
  n * n.

Compute (unit_test_for_mystery_function_04 mystery_function_04).

Theorem there_is_at_least_one_mystery_function_04 :
  specification_of_mystery_function_04 mystery_function_04.
Proof.
  unfold specification_of_mystery_function_04, mystery_function_04.
  split.
  - rewrite -> (Nat.mul_0_r 0).
    reflexivity.

  - intros n'.
    rewrite -> (equivalence_of_times_two_and_add_itself n').
    rewrite -> equivalence_of_successor_and_add_one.
    rewrite -> (equivalence_of_successor_and_add_one (n' + n')).
    rewrite -> distributive_law_l_r.
    rewrite -> (Nat.mul_1_r n').
    rewrite -> (Nat.mul_1_l n').
    rewrite -> (Nat.mul_1_l 1).
    rewrite -> (Nat.add_assoc (n' * n') (n' + n')  1).
    rewrite -> (Nat.add_assoc (n' * n') n' n').
    reflexivity.
Qed.

(* ***** *)

Definition specification_of_mystery_function_15 (mf : nat -> nat * nat) :=
  mf 0 = (0, 1)
  /\
  forall n' : nat,
    mf (S n') = let (x, y) := mf n'
                in (S x, y * S x).

Theorem there_is_at_most_one_mystery_function_15:
  forall f g : nat -> nat * nat,
    specification_of_mystery_function_15 f ->
    specification_of_mystery_function_15 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_mystery_function_15.
  intros [H_f_O H_f_S] [H_g_O H_g_S].
  intro n.
  induction n as [ | n' IHn'].

  - rewrite -> H_g_O.
    exact (H_f_O).

  - rewrite -> H_f_S.
    rewrite -> H_g_S.
    rewrite -> IHn'.
    reflexivity.
Qed.

Definition unit_test_for_mystery_function_15 (mf : nat -> nat * nat) :=
  (mf 0 =nn= (0, 1)) && (mf 1 =nn= (1, 1)) && (mf 2 =nn= (2, 2)) && (mf 3 =nn= (3, 6)).

(* etc. *)

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

Definition mystery_function_15 (n : nat) : nat * nat :=
  (n, fac n).

Compute (unit_test_for_mystery_function_15 mystery_function_15).

Theorem there_is_at_least_one_mystery_function_15:
  specification_of_mystery_function_15 mystery_function_15.
Proof.
  unfold specification_of_mystery_function_15, mystery_function_15.
  split.
  - unfold fac.
    reflexivity.

  - intro n'.
    unfold fac.
    fold fac.
    reflexivity.
Qed.
    (* ***** *)

Definition specification_of_mystery_function_16 (mf : nat -> nat * nat) :=
  mf 0 = (0, 1)
  /\
  forall n' : nat,
    mf (S n') = let (x, y) := mf n'
                in (y, x + y).

Theorem there_is_at_most_one_mystery_function_16:
  forall f g : nat -> nat * nat,
    specification_of_mystery_function_16 f ->
    specification_of_mystery_function_16 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_mystery_function_16.
  intros [H_f_O H_f_S] [H_g_O H_g_S].
  intro n.
  induction n as [ | n' IHn'].

  - rewrite -> H_g_O.
    exact (H_f_O).

  - rewrite -> H_f_S.
    rewrite -> H_g_S.
    rewrite -> IHn'.
    reflexivity.
Qed.

Definition unit_test_for_mystery_function_16 (mf : nat -> nat * nat) :=
  (mf 0 =nn= (0, 1)) && (mf 1 =nn= (1, 1)) && (mf 2 =nn= (1, 2)) && (mf 3 =nn= (2, 3)).

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

Definition mystery_function_16 (n : nat) : nat * nat :=
  (fib n, fib (S n)).

Compute (unit_test_for_mystery_function_16 mystery_function_16).

Theorem there_is_at_least_one_mystery_function_16:
  specification_of_mystery_function_16 mystery_function_16.
Proof.
  unfold specification_of_mystery_function_16, mystery_function_16.
  split.
  - unfold fib.
    reflexivity.

  - intro n'.
    unfold fib.
    fold fib.
    reflexivity.
Qed.

(* ***** *)

Lemma triple_induction (P : nat -> Prop) :
  P 0 ->
  P 1 ->
  P 2 ->
  (forall n, P n -> P (S n) -> P (S (S n)) -> P (S (S (S n)))) ->
  forall n, P n.
Proof.
  intros H0 H1 H2 Hstep n.
  enough (P n /\ P (S n) /\ P (S (S n))) as [H [H_S H_SS]].
  - exact H.
  - induction n as [ | n [IH IH_S]].
    * exact (conj H0 (conj H1 H2)).
    * destruct IH_S as [IH_S_1 IH_S_2].
      + split.
        ++ exact IH_S_1.
        ++ split.
           +++ exact IH_S_2.
           +++ exact ((Hstep n) IH IH_S_1 IH_S_2).
Qed.

Definition specification_of_mystery_function_17 (mf : nat -> nat) :=
  mf 0 = 0
  /\
  mf 1 = 1
  /\
  mf 2 = 1
  /\
  forall p q : nat,
    mf (S (p + q)) = mf (S p) * mf (S q) + mf p * mf q.

Theorem there_is_at_most_one_mystery_function_17:
  forall f g : nat -> nat,
    specification_of_mystery_function_17 f ->
    specification_of_mystery_function_17 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_mystery_function_17.
  intros [H_f_O [H_f_1 [H_f_2 H_f_S]]] [H_g_O [H_g_1 [H_g_2 H_g_S]]].
  intro n.
  induction n using triple_induction.

  - rewrite -> H_g_O.
    exact (H_f_O).

  - rewrite -> H_g_1.
    exact (H_f_1).

  - rewrite -> H_g_2.
    exact (H_f_2).

  - assert (H_tmp := H_f_S (n + 1) 1).
    Search (2 = 1 + 1).
    rewrite -> (Nat.add_1_r n) in H_tmp.
    rewrite -> (Nat.add_1_r (S n)) in H_tmp.
    rewrite -> H_tmp.
    rewrite -> H_f_2.
    rewrite -> H_f_1.
    clear H_tmp.
    assert (H_tmp := H_g_S (n + 1) 1).
    Search (2 = 1 + 1).
    rewrite -> (Nat.add_1_r n) in H_tmp.
    rewrite -> (Nat.add_1_r (S n)) in H_tmp.
    rewrite -> H_tmp.
    rewrite -> H_g_2.
    rewrite -> H_g_1.
    rewrite -> IHn1.
    rewrite -> IHn0.
    reflexivity.
Qed.

Definition unit_test_for_mystery_function_17 (mf : nat -> nat) :=
  (mf 0 =n= 0) && (mf 1 =n= 1) && (mf 2 =n= 1) && (mf 3 =n= 2)
(* etc. *).

Definition mystery_function_17 (n : nat) : nat :=
  fib n.

Compute (unit_test_for_mystery_function_17 mystery_function_17).

Theorem there_is_at_least_one_mystery_function_17 :
  specification_of_mystery_function_17 mystery_function_17.
Proof.
  unfold specification_of_mystery_function_17, mystery_function_17.
  split.
  { unfold fib.
    reflexivity.
  }
  split.
  { unfold fib.
    reflexivity.
  }
  split.
  { unfold fib.
    exact (Nat.add_0_l 1).
  }
  intros p q.
  induction p as [ | p' IHp'].

  - (* an induction proof *)
Abort.

(* ***** *)

Definition specification_of_mystery_function_18 (mf : nat -> nat) :=
  mf 0 = 0
  /\
  mf 1 = 1
  /\
  mf 2 = 1
  /\
  forall n''' : nat,
    mf n''' + mf (S (S (S n'''))) = 2 * mf (S (S n''')).

Theorem there_is_at_most_one_mystery_function_18:
  forall f g : nat -> nat,
    specification_of_mystery_function_18 f ->
    specification_of_mystery_function_18 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_mystery_function_18.
  intros [H_f_O [H_f_1 [H_f_2 H_f_S]]] [H_g_O [H_g_1 [H_g_2 H_g_S]]].
  intro n.
  induction n using triple_induction.

  - rewrite -> H_g_O.
    exact (H_f_O).

  - rewrite -> H_g_1.
    exact (H_f_1).

  - rewrite -> H_g_2.
    exact (H_f_2).

  - assert (H_tmp := H_f_S n).
    assert (H_tmp2 := H_g_S n).
    rewrite -> IHn1 in H_tmp.
    rewrite <- H_tmp2 in H_tmp.
    rewrite -> IHn in H_tmp.
    Search (_ + _ = _ + _ -> _).
    exact ((plus_reg_l (f (S (S (S n)))) (g (S (S (S n)))) (g n) ) H_tmp).
Qed.

Definition unit_test_for_mystery_function_18 (mf : nat -> nat) :=
  (mf 0 =n= 0) && (mf 1 =n= 1) && (mf 2 =n= 1) && (mf 3 =n= 2)
(* etc. *).

Definition mystery_function_18 (n : nat) : nat :=
  fib n.

Compute (unit_test_for_mystery_function_18 mystery_function_18).

Theorem there_is_at_least_one_mystery_function_18 :
  specification_of_mystery_function_18 mystery_function_18.
Proof.
  unfold specification_of_mystery_function_18, mystery_function_18.
  split.
  { unfold fib.
    reflexivity.
  }
  split.
  { unfold fib.
    reflexivity.
  }
  split.
  { unfold fib.
    exact (Nat.add_0_l 1).
  }
  intro n.
  induction n as [ | n' IHn'].

  - unfold fib. fold fib.
    rewrite -> Nat.add_0_l.
    rewrite -> Nat.add_0_l.
    rewrite -> (Nat.mul_1_r 2).
    symmetry.
    exact BinInt.ZL0.

  - (* an induction proof *)
Abort.

(* ***** *)

Definition specification_of_mystery_function_03 (mf : nat -> nat -> nat) :=
  mf 0 0 = 0
  /\
  (forall i j: nat, mf (S i) j = S (mf i j))
  /\
  (forall i j: nat, S (mf i j) = mf i (S j)).

Theorem there_is_at_most_one_mystery_function_03:
  forall f g : nat -> nat -> nat,
    specification_of_mystery_function_03 f ->
    specification_of_mystery_function_03 g ->
    forall i j : nat,
      f i j = g i j.
Proof.
  intros f g.
  unfold specification_of_mystery_function_03.
  intros [H_f_O [H_f_S  H_f_S']] [H_g_O [H_g_S H_g_S']].
  intro i.
  induction i as [ | i' IHi'].

  - intro j.
    induction j as [ | j' IHj'].

    -- rewrite -> H_g_O.
       exact (H_f_O).
    -- rewrite <- (H_g_S' 0 j').
       rewrite <- (H_f_S' 0 j').
       rewrite <- IHj'.
       reflexivity.
  - intro j.
    rewrite -> (H_f_S i' j).
    rewrite -> (H_g_S i' j).
    rewrite -> IHi'.
    reflexivity.
Qed.

Definition unit_test_for_mystery_function_03 (mf : nat -> nat -> nat) :=
  (mf 0 0 =n= 0) && (mf 0 1 =n= 1) && (mf 1 0 =n= 1) && (mf 1 1 =n= 2) && (mf 1 2 =n= 3) && (mf 2 1 =n= 3) && (mf 2 2 =n= 4).

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

Compute (unit_test_for_mystery_function_03 mystery_function_03).

Ltac fold_unfold_tactic name := intros; unfold name; fold name; reflexivity.

Lemma fold_unfold_mystery_function_03_O :
  forall j : nat,
   mystery_function_03 O j =
    j.
Proof.
  fold_unfold_tactic mystery_function_03.
Qed.

Lemma fold_unfold_mystery_function_03_S :
  forall i' j : nat,
    mystery_function_03 (S i') j =
    mystery_function_03 i' (S j).
Proof.
  fold_unfold_tactic mystery_function_03.
Qed.

Lemma about_mystery_function_03 :
  forall i j : nat,
    mystery_function_03 i (S j) = S (mystery_function_03 i j).
Proof.
  intro i.
  induction i as [ | i' IHi'].

  - intro j.
    rewrite -> (fold_unfold_mystery_function_03_O j).
    exact (fold_unfold_mystery_function_03_O (S j)).

  - intro j.
    rewrite -> (fold_unfold_mystery_function_03_S i' (S j)).
    rewrite -> (fold_unfold_mystery_function_03_S i' j).
    Check (IHi' (S j)).
    exact (IHi' (S j)).
Qed.

Theorem there_is_at_least_one_mystery_function_03:
  specification_of_mystery_function_03 mystery_function_03.
Proof.
  unfold specification_of_mystery_function_03, mystery_function_03.
  split.
  - reflexivity.

  - split.
    -- unfold mystery_function_03.
       fold mystery_function_03.
       exact (about_mystery_function_03).

    -- unfold mystery_function_03.
       fold mystery_function_03.
       symmetry.
       apply (about_mystery_function_03 i j).
Qed.

(* ***** *)

Definition specification_of_mystery_function_42 (mf : nat -> nat) :=
  mf 1 = 42
  /\
  forall i j : nat,
    mf (i + j) = mf i + mf j.

Theorem there_is_at_most_one_mystery_function_42:
  forall f g : nat -> nat,
    specification_of_mystery_function_42 f ->
    specification_of_mystery_function_42 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_mystery_function_42.
  intros [H_f_1 H_f_S] [H_g_1 H_g_S].
  intro n.
  induction n as [ | n' IHn'].
  - assert (H_tmp := H_f_S 0 1).
    Search (0 + _ = _).
    rewrite -> (Nat.add_0_l 1) in H_tmp.
    rewrite -> H_f_1 in H_tmp.
    Search (_ + _ = _).
    rewrite <- (Nat.add_0_l 42) in H_tmp at 1.
    Search (_ + _ = _ + _).
    rewrite -> (Nat.add_cancel_r 0 (f 0) 42) in H_tmp.
    rewrite <- H_tmp.
    clear H_tmp.
    assert (H_tmp := H_g_S 0 1).
    rewrite -> (Nat.add_0_l 1) in H_tmp.
    rewrite -> H_g_1 in H_tmp.
    rewrite <- (Nat.add_0_l 42) in H_tmp at 1.
    rewrite -> (Nat.add_cancel_r 0 (g 0) 42) in H_tmp.
    rewrite <- H_tmp.
    reflexivity.
  - rewrite -> (equivalence_of_successor_and_add_one n').
    rewrite -> (H_f_S n' 1).
    rewrite -> H_f_1.
    rewrite -> (H_g_S n' 1).
    rewrite -> H_g_1.
    rewrite -> IHn'.
    reflexivity.
Qed.

Definition unit_test_for_mystery_function_42 (mf : nat -> nat) :=
  (mf 0 =n= 0) && (mf 1 =n= 42) && (mf 2 =n= 84) && (mf 3 =n= 126).

Definition mystery_function_42 (n : nat) : nat :=
  n * 42.

Compute (unit_test_for_mystery_function_42 mystery_function_42).

Theorem there_is_at_least_one_mystery_function_42:
  specification_of_mystery_function_42 mystery_function_42.
Proof.
  unfold specification_of_mystery_function_42, mystery_function_42.
  split.
  - exact (Nat.mul_1_l 42).

  - intros i j.
    Search ((_ + _) * _ = _ * _ + _ * _).
    exact (Nat.mul_add_distr_r i j 42).
Qed.

(* ***** *)

Definition specification_of_mystery_function_07 (mf : nat -> nat -> nat) :=
  (forall j : nat, mf 0 j = j)
  /\
  (forall i : nat, mf i 0 = i)
  /\
  (forall i j k : nat, mf (i + k) (j + k) = (mf i j) + k).

Theorem there_is_at_most_one_mystery_function_07:
  forall f g : nat -> nat -> nat,
    specification_of_mystery_function_07 f ->
    specification_of_mystery_function_07 g ->
    forall i j : nat,
      f i j = g i j.
Proof.
  intros f g.
  unfold specification_of_mystery_function_07.
  intros [H_f_O_l [H_f_O_r H_f_S]] [H_g_O_l [H_g_O_r H_g_S]].
  intros i.
  induction i as [ | i' IHi'].
  - intro j.
    induction j as [ | j' IHj'].
    -- rewrite -> (H_g_O_l 0).
       exact (H_f_O_l 0).
    -- rewrite -> (H_g_O_l (S j')).
       exact (H_f_O_l (S j')).
  - intro j.
    induction j as [ | j' IHj'].
    -- rewrite -> (H_g_O_r (S i')).
       exact (H_f_O_r (S i')).
    -- rewrite -> (equivalence_of_successor_and_add_one i').
       rewrite -> (equivalence_of_successor_and_add_one j').
       rewrite -> (H_f_S i' j' 1).
       rewrite -> (H_g_S i' j' 1).
       rewrite -> IHi'.
       reflexivity.
  (*
  Restart.

  intros f g.
  unfold specification_of_mystery_function_07.
  intros [H_f_O_l [H_f_O_r H_f_S]] [H_g_O_l [H_g_O_r H_g_S]].
  intros i.
  induction i as [ | i' IHi'].
  - intro j.
    rewrite -> (H_g_O_l).
    exact (H_f_O_l j).
  - intro j.
    assert (H_tmp := H_f_S i' (j-1) 1).
    rewrite <- (equivalence_of_successor_and_add_one i') in H_tmp.
    Search (_ = _ - 1).
    rewrite <- (equivalence_of_successor_and_add_one j) in H_tmp.
    assert (H_tmp' := (IHi' (j - 1))).
    rewrite -> Nat.add_0_r in H_tmp.
    rewrite -> Nat.add_0_r in H_tmp.
    rewrite -> Nat.add_0_r in H_tmp. *)
Qed.

Definition unit_test_for_mystery_function_07 (mf : nat -> nat -> nat) :=
  (mf 0 1 =n= 1) && (mf 1 0 =n= 1) && (mf 2 2 =n= 2) && (mf 2 6 =n= 6).

Definition mystery_function_07 (i j : nat) : nat :=
  Nat.max i j.

Compute (unit_test_for_mystery_function_07 mystery_function_07).

Theorem there_is_at_least_one_mystery_function_07:
  specification_of_mystery_function_07 mystery_function_07.
Proof.
  unfold specification_of_mystery_function_07, mystery_function_07.
  split.
  - intro j.
    exact (Nat.max_0_l j).

  - split.
    -- intro i.
       exact (Nat.max_0_r i).
    -- intros i j k.
       exact (Nat.add_max_distr_r i j k).
Qed.

(* ***** *)

Definition specification_of_mystery_function_08 (mf : nat -> nat -> bool) :=
  (forall j : nat, mf 0 j = true)
  /\
  (forall i : nat, mf (S i) 0 = false)
  /\
  (forall i j : nat, mf (S i) (S j) = mf i j).

Theorem there_is_at_most_one_mystery_function_08:
  forall f g : nat -> nat -> bool,
    specification_of_mystery_function_08 f ->
    specification_of_mystery_function_08 g ->
    forall i j : nat,
      f i j = g i j.
Proof.
  intros f g.
  unfold specification_of_mystery_function_08.
  intros [H_f_O_l [H_f_O_r H_f_S]] [H_g_O_l [H_g_O_r H_g_S]].
  intros i.
  induction i as [ | i' IHi'].
  - intro j.
    induction j as [ | j' IHj'].
    -- rewrite -> (H_g_O_l 0).
       exact (H_f_O_l 0).
    -- rewrite -> (H_g_O_l (S j')).
       exact (H_f_O_l (S j')).
  - intro j.
    induction j as [ | j' IHj'].
    -- rewrite -> (H_g_O_r i').
       exact (H_f_O_r i').
    -- rewrite -> (H_g_S i' j').
       rewrite -> (H_f_S i' j').
       rewrite -> (IHi' j').
       reflexivity.
Qed.

Definition unit_test_for_mystery_function_08 (mf : nat -> nat -> bool) :=
  (mf 0 0 =b= true) && (mf 1 0 =b= false) && (mf 0 1 =b= true) && (mf 2 6 =b= true) && (mf 6 6 =b= true).

Definition mystery_function_08 (i j : nat) : bool :=
  (Nat.min i j) =n= i.

Compute (unit_test_for_mystery_function_08 mystery_function_08).

Theorem there_is_at_least_one_mystery_function_08:
  specification_of_mystery_function_08 mystery_function_08.
Proof.
  unfold specification_of_mystery_function_08, mystery_function_08.
  split.
  - intro j.
    Search (Nat.min 0 _).
    rewrite -> (Nat.min_0_l j).
    Search (beq_nat _ _).
    exact (Nat.eqb_refl 0).

  - split.
    -- intro i.
    rewrite -> (equivalence_of_successor_and_add_one i) at 1.
    rewrite -> (Nat.min_0_r (i + 1)).
    Search (beq_nat _ _).
    assert (H_tmp := (Nat.neq_succ_0 i)).
    Search (_ <> _ -> _).
    apply (Nat.neq_sym (S i) 0) in H_tmp.
    Search (_ =n= _).
    apply (Nat.eqb_neq 0 (S i)).
    exact H_tmp.

    -- intros i j.
       Search(Nat.min).
       Search (beq_nat).
       rewrite <- (Nat.succ_min_distr i j).
       rewrite <- (Nat.add_1_l (Nat.min i j)).
       rewrite <- (Nat.add_1_l i).
       destruct (Nat.lt_ge_cases j i) as [ H_i_greater_j | H_i_smaller_eq_j ].
    * assert (H_tmp := Nat.lt_neq j i).
      assert (H_neq := H_tmp H_i_greater_j).
      clear H_tmp.
      apply Nat.lt_le_incl in H_i_greater_j.
      rewrite -> (Nat.min_r i j).
      ** assert (H_tmp := Nat.lt_neq i j).
         assert (H_tmp2 := (not_eq_S j i)).
         assert (H_neq_S := H_tmp2 H_neq).
         rewrite <- (Nat.add_1_l j) in H_neq_S.
         rewrite <- (Nat.add_1_l i) in H_neq_S.
         assert (H_tmp3 := Nat.eqb_neq (1 + j) (1 + i)).
         destruct H_tmp3 as [_ H_tmp3_right].
         rewrite -> (H_tmp3_right H_neq_S).
         symmetry.
         clear H_tmp2 H_neq_S H_tmp3_right.
         assert (H_tmp2 := Nat.eqb_neq j i).
         destruct H_tmp2 as [_ H_tmp2_right].
         exact (H_tmp2_right H_neq).
      ** exact H_i_greater_j.
    * rewrite -> ((Nat.min_l i j) H_i_smaller_eq_j).
      rewrite -> (Nat.eqb_refl i).
      exact (Nat.eqb_refl (1 + i)).
Qed.

(* ***** *)

Definition specification_of_mystery_function_23 (mf : nat -> nat) :=
  mf 0 = 0
  /\
  mf 1 = 0
  /\
  forall n'' : nat,
    mf (S (S n'')) = S (mf n'').

Lemma zero_or_nonzero :
  forall n : nat,
  (n = 0) \/ (n <> 0).
Proof.
  intro n.
  induction n as [ | n' IHn'].

  - left.
    reflexivity.

  - right.
    exact (Nat.neq_succ_0 n').
Qed.

(* Master Lemma *)

Lemma pair_induction (P : nat -> Prop) :
  P 0 ->
  P 1 ->
  (forall n, P n -> P (S n) -> P (S (S n))) ->
  forall n, P n.
Proof.
  intros H0 H1 Hstep n.
  enough (P n /\ P (S n)) as [H H_S].
  + exact H.
  +  induction n as [ | n' [IHn' IHn'2]].

  * split.
    - exact H0.
    - exact H1.
  * split.
    - exact IHn'2.
    - exact (Hstep n' IHn' IHn'2).
Qed.

Theorem there_is_at_most_one_mystery_function_23:
  forall f g : nat -> nat,
    specification_of_mystery_function_23 f ->
    specification_of_mystery_function_23 g ->
    forall n : nat,
      f n = g n.
Proof.
intros f g.
  unfold specification_of_mystery_function_23.
  intros [H_f_O [H_f_1 H_f_S]] [H_g_O [H_g_1 H_g_S]].
  intro n.
  induction n using pair_induction.

  - rewrite -> H_g_O.
    exact (H_f_O).
  - rewrite -> H_g_1.
    exact H_f_1.
  - rewrite -> (H_f_S n).
    rewrite -> (H_g_S n).
    rewrite -> IHn.
    reflexivity.
Qed.

Definition unit_test_for_mystery_function_23 (mf : nat -> nat) :=
  (mf 0 =n= 0) && (mf 1 =n= 0) && (mf 2 =n= 1) && (mf 3 =n= 1)
(* etc. *).

Definition mystery_function_23 (n : nat) : nat :=
  n / 2.

Compute (unit_test_for_mystery_function_23 mystery_function_23).

Theorem there_is_at_least_one_mystery_function_23:
  specification_of_mystery_function_23 mystery_function_23.
Proof.
  unfold specification_of_mystery_function_23, mystery_function_23.
  split.

 - apply (Nat.div_0_l 2).
   exact (Nat.neq_succ_0 1).
 - split.
   apply (Nat.div_1_l 2).
   * exact Nat.lt_1_2.
   * intro n.
     rewrite <- (Nat.add_1_l n).
     rewrite <- (Nat.add_1_l (1 + n)).
     rewrite -> (Nat.add_assoc 1 1 n).
     rewrite <- BinInt.ZL0.
     rewrite <- (Nat.add_1_l (n / 2)).
     rewrite <- (Nat.mul_1_l 2) at 1.
     rewrite -> (Nat.div_add_l 1 2 n).
     ** reflexivity.
     ** exact (Nat.neq_succ_0 1).
Qed.

(* ***** *)

Definition specification_of_mystery_function_24 (mf : nat -> nat) :=
  mf 0 = 0
  /\
  mf 1 = 1
  /\ forall n'' : nat,
      mf (S (S n'')) = S (mf n'').
(* (n + 1) / 2 *)
(* ***** *)

Theorem there_is_at_most_one_mystery_function_24:
  forall f g : nat -> nat,
    specification_of_mystery_function_24 f ->
    specification_of_mystery_function_24 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_mystery_function_24.
  intros [H_f_O [H_f_1 H_f_S]] [H_g_O [H_g_1 H_g_S]].

  assert (H_n : forall n : nat, f n = g n /\ f (S n) = g (S n)).
  { intro n.
    induction n as [ | n' [IHn' IHSn']].

    - split.

      -- rewrite -> H_f_O.
         rewrite -> H_g_O.
         reflexivity.

      -- rewrite -> H_f_1.
         rewrite -> H_g_1.
         reflexivity.

    - split.

      -- exact IHSn'.

      -- rewrite -> H_f_S.
         rewrite -> H_g_S.
         rewrite -> IHn'.
         reflexivity.
  }
  intro n.
  destruct (H_n n) as [ly _].
  exact ly.
Qed.
(*
  intros f g.
  unfold specification_of_mystery_function_24.
  intros [H_f_O [H_f_1 H_f_S]] [H_g_O [H_g_1 H_g_S]].
  intro n.
  induction n using pair_induction.

  - rewrite -> H_g_O.
    exact (H_f_O).
  - rewrite -> H_g_1.
    exact H_f_1.
  - rewrite -> (H_f_S n).
    rewrite -> (H_g_S n).
    rewrite -> IHn.
    reflexivity.
Qed.
*)

Definition unit_test_for_mystery_function_24 (mf : nat -> nat) :=
  (mf 0 =n= 0) && (mf 1 =n= 1) && (mf 2 =n= 1) && (mf 3 =n= 2)
(* etc. *).

Definition mystery_function_24 (n : nat) : nat :=
  (n + 1) / 2.

Compute (unit_test_for_mystery_function_24 mystery_function_24).

Theorem there_is_at_least_one_mystery_function_24:
  specification_of_mystery_function_24 mystery_function_24.
Proof.
  unfold specification_of_mystery_function_24, mystery_function_24.
  split.

 - apply (Nat.div_0_l 2).
   exact (Nat.neq_succ_0 1).
 - split.
   * rewrite <- BinInt.ZL0.
     exact ((Nat.div_same 2) (Nat.neq_succ_0 1)).
   * intro n.
     rewrite <- (Nat.add_1_l n).
     rewrite <- (Nat.add_1_l (1 + n)).
     rewrite -> (Nat.add_assoc 1 1 n).
     rewrite <- BinInt.ZL0.
     rewrite <- (Nat.add_1_l ((n + 1) / 2)).
     rewrite <- (Nat.mul_1_l 2) at 1.
     rewrite <- (Nat.add_assoc (1 * 2) n 1).
     rewrite -> (Nat.div_add_l 1 2 (n + 1)).
     ** reflexivity.
     ** exact (Nat.neq_succ_0 1).
Qed.

(* ***** *)

Lemma even_or_odd :
  forall m : nat,
  (exists q : nat, m = 2 * q) \/ (exists q : nat, m = S (2 * q)).
Proof.
  intro n.
  induction n as [ | n' [[q H_q] | [q H_q]]].
  - left.
    exists 0.
    rewrite -> (Nat.mul_0_r 2).
    reflexivity.

  - (* left.
    rewrite -> H_q. *)
    (*  exists q0 : nat, S (2 * q) = 2 * q0 we found out that if we choose the left disjunct, we run into an impossibility. *)
    right.
    rewrite -> H_q.
    exists q.
    reflexivity.

  - (* right.
    rewrite -> H_q. *)
    left.
    rewrite -> H_q.
    Search ( 1 + _  = S _).
    exists (S q).
    Search (S _ * _ = _).
    Check (Nat.mul_succ_l 1 q).
    rewrite -> (Nat.mul_succ_l 1 q).
    rewrite -> (Nat.mul_1_l q).
    rewrite -> (Nat.mul_succ_l 1 (S q)).
    rewrite -> (Nat.mul_1_l (S q)).
    Check (plus_Sn_m).
    rewrite <- (plus_Sn_m q q).
    Check (plus_n_Sm).
    rewrite -> (plus_n_Sm (S q) q).
    reflexivity.
Qed.

Definition specification_of_mystery_function_13 (mf : nat -> nat) :=
  (forall q : nat, mf (2 * q) = q)
  /\
  (forall q : nat, mf (S (2 * q)) = q).
(* n / 2  *)

Theorem there_is_at_most_one_mystery_function_13:
  forall f g : nat -> nat,
    specification_of_mystery_function_13 f ->
    specification_of_mystery_function_13 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_mystery_function_13.
  intros [H_f_O H_f_S] [H_g_O H_g_S].
  intro n.
  Check (even_or_odd n).
  destruct (even_or_odd n) as [[q H_q] | [q H_q]].

  - rewrite -> H_q.
    rewrite -> (H_g_O q).
    exact (H_f_O q).

  - rewrite -> H_q.
    rewrite -> (H_g_S q).
    exact (H_f_S q).
Qed.

Definition unit_test_for_mystery_function_13 (mf : nat -> nat) :=
  (mf 0 =n= 0) && (mf 1 =n= 0) && (mf 2 =n= 1) && (mf 3 =n= 1)
(* etc. *).

Definition mystery_function_13 (n : nat) : nat :=
  n / 2.

Compute (unit_test_for_mystery_function_13 mystery_function_13).

Theorem there_is_at_least_one_mystery_function_13:
  specification_of_mystery_function_13 mystery_function_13.
Proof.
  unfold specification_of_mystery_function_13, mystery_function_13.
  split.

  - intro q.
    rewrite -> (Nat.mul_comm 2 q).
    rewrite -> (Nat.div_mul q 2).
    * reflexivity.
    * exact (Nat.neq_succ_0 1).

  - intro q.
    rewrite <- (Nat.add_1_l (2 * q)).
    rewrite <- (Nat.mul_comm q 2).
    rewrite -> (Nat.div_add 1 q 2).
    assert (H_tmp := Nat.div_1_l 2).
    rewrite -> H_tmp.
    * exact (Nat.add_0_l q).
    * exact (Nat.lt_1_2).
    * exact (Nat.neq_succ_0 1).
Qed.

Definition specification_of_mystery_function_25 (mf : nat -> nat) :=
  mf 0 = 0
  /\
  (forall q : nat,
      mf (2 * (S q)) = S (mf (S q)))
  /\
  mf 1 = 0
  /\
  (forall q : nat,
      mf (S (2 * (S q))) = S (mf (S q))).

(* log *)
(* ****** *)

Theorem there_is_at_most_one_mystery_function_25:
  forall f g : nat -> nat,
    specification_of_mystery_function_25 f ->
    specification_of_mystery_function_25 g ->
    forall n : nat,
      f n = g n.
Proof.
(*
intros f g.
  unfold specification_of_mystery_function_25.
  intros [H_f_O [H_f_S [H_f_1 H_f_SS]]] [H_g_O [H_g_S [H_g_1 H_g_SS]]].
  intro n.
  induction n using pair_induction.
  - rewrite -> H_g_O.
    exact H_f_O.
  - rewrite -> H_g_1.
    exact H_f_1.
  - destruct (even_or_odd n) as [[q H_q] | [q H_q]].
      * rewrite -> H_q.
      assert (H_tmp := H_f_S q).
      rewrite <- (Nat.add_1_l (2 * q)) at 1.
      rewrite <- (Nat.add_1_l (1 + (2 * q))) at 1.
      rewrite -> (Nat.add_assoc 1 1 (2 * q)).
      rewrite <- BinInt.ZL0.
      rewrite <- (Nat.add_1_l q) in H_tmp.
      rewrite -> (Nat.mul_add_distr_l 2 1 q) in H_tmp.
      rewrite -> (Nat.mul_1_r 2) in H_tmp.
      rewrite -> H_tmp.
      rewrite -> (Nat.add_1_l q).
      clear H_tmp.
      assert (H_tmp := H_g_S q).
      rewrite <- (Nat.add_1_l (2 * q)) at 1.
      rewrite <- (Nat.add_1_l (1 + (2 * q))) at 1.
      rewrite -> (Nat.add_assoc 1 1 (2 * q)).
      rewrite <- BinInt.ZL0.
      rewrite <- (Nat.add_1_l q) in H_tmp.
      rewrite -> (Nat.mul_add_distr_l 2 1 q) in H_tmp.
      rewrite -> (Nat.mul_1_r 2) in H_tmp.
      rewrite -> H_tmp.
      rewrite -> (Nat.add_1_l q).
      Search (log _).

  induction n using pair_induction.

  - rewrite -> H_g_O.
    exact (H_f_O).
  - rewrite -> H_g_1.
    exact H_f_1.
  - destruct (even_or_odd n) as [[q H_q] | [q H_q]].
    + rewrite -> H_q.
      assert (H_tmp := H_f_S q).
      rewrite <- (Nat.add_1_l (2 * q)) at 1.
      rewrite <- (Nat.add_1_l (1 + (2 * q))) at 1.
      rewrite -> (Nat.add_assoc 1 1 (2 * q)).
      rewrite <- BinInt.ZL0.
      rewrite <- (Nat.add_1_l q) in H_tmp.
      rewrite -> (Nat.mul_add_distr_l 2 1 q) in H_tmp.
      rewrite -> (Nat.mul_1_r 2) in H_tmp.
      rewrite -> H_tmp.
      rewrite -> (Nat.add_1_l q).
      clear H_tmp.
      assert (H_tmp := H_g_S q).
      rewrite <- (Nat.add_1_l (2 * q)) at 1.
      rewrite <- (Nat.add_1_l (1 + (2 * q))) at 1.
      rewrite -> (Nat.add_assoc 1 1 (2 * q)).
      rewrite <- BinInt.ZL0.
      rewrite <- (Nat.add_1_l q) in H_tmp.
      rewrite -> (Nat.mul_add_distr_l 2 1 q) in H_tmp.
      rewrite -> (Nat.mul_1_r 2) in H_tmp.
      rewrite -> H_tmp.
      rewrite -> (Nat.add_1_l q).

      Search ().
      rewrite -> (H_g_O).
      exact (H_f_O q).

    + rewrite -> H_q.
      rewrite -> (H_g_S q).
      exact (H_f_S q).

rewrite -> (H_f_S n).
    rewrite -> (H_g_S n).
    rewrite -> IHn.
    reflexivity.
*)
Abort.

Definition specification_of_mystery_function_20 (mf : nat -> nat -> nat) :=
  (forall j : nat, mf O j = j)
  /\
  (forall i j : nat, mf (S i) j = S (mf i j)).
(* add  *)
(* ****** *)

Theorem there_is_at_most_one_mystery_function_20:
  forall f g : nat -> nat -> nat,
    specification_of_mystery_function_20 f ->
    specification_of_mystery_function_20 g ->
    forall n m: nat,
      f n m = g n m.
Proof.
  intros f g.
  unfold specification_of_mystery_function_20.
  intros [H_f_O H_f_S] [H_g_O H_g_S].
  intro n.
  induction n as [ | n' IHn'].

  - intro m.
    rewrite -> (H_g_O m).
    exact (H_f_O m).

  - intro m.
    rewrite -> (H_f_S n' m).
    rewrite -> (H_g_S n' m).
    rewrite -> (IHn' m).
    reflexivity.
Qed.

Definition unit_test_for_mystery_function_20 (mf : nat -> nat -> nat) :=
  (mf 0 0 =n= 0) && (mf 1 0 =n= 1) && (mf 0 1 =n= 1) && (mf 1 1 =n= 2)
(* etc. *).

Definition mystery_function_20 (n m : nat) : nat :=
  n + m.

Compute (unit_test_for_mystery_function_20 mystery_function_20).

Theorem there_is_at_least_one_mystery_function_20 :
  specification_of_mystery_function_20 mystery_function_20.
Proof.
  unfold specification_of_mystery_function_20, mystery_function_20.
  split.
  - intro j.
    exact (Nat.add_0_l j).

  - intros i j.
    exact (Nat.add_succ_l i j).
Qed.

Definition specification_of_mystery_function_21 (mf : nat -> nat -> nat) :=
  (forall j : nat, mf O j = j)
  /\
  (forall i j : nat, mf (S i) j = mf i (S j)).
(* add *)

Theorem there_is_at_most_one_mystery_function_21:
  forall f g : nat -> nat -> nat,
    specification_of_mystery_function_21 f ->
    specification_of_mystery_function_21 g ->
    forall n m: nat,
      f n m = g n m.
Proof.
  intros f g.
  unfold specification_of_mystery_function_21.
  intros [H_f_O H_f_S] [H_g_O H_g_S].
  intro n.
  induction n as [ | n' IHn'].

  - intro m.
    rewrite -> (H_g_O m).
    exact (H_f_O m).

  - intro m.
    rewrite -> (H_f_S n' m).
    rewrite -> (H_g_S n' m).
    rewrite -> (IHn' (S m)).
    reflexivity.
Qed.

Definition unit_test_for_mystery_function_21 (mf : nat -> nat -> nat) :=
  (mf 0 0 =n= 0) && (mf 1 0 =n= 1) && (mf 0 1 =n= 1) && (mf 1 1 =n= 2)
(* etc. *).

Definition mystery_function_21 (n m : nat) : nat :=
  n + m.

Compute (unit_test_for_mystery_function_21 mystery_function_21).

Theorem there_is_at_least_one_mystery_function_21 :
  specification_of_mystery_function_21 mystery_function_21.
Proof.
  unfold specification_of_mystery_function_21, mystery_function_21.
  split.
  - intro j.
    exact (Nat.add_0_l j).

  - intros i j.
    exact (Nat.add_succ_comm i j).
Qed.

(* ****** *)

Definition specification_of_mystery_function_22 (mf : nat -> nat -> nat) :=
  forall i j : nat,
    mf O j = j
    /\
    mf (S i) j = mf i (S j).
(* add  *)

Theorem there_is_at_most_one_mystery_function_22:
  forall f g : nat -> nat -> nat,
    specification_of_mystery_function_22 f ->
    specification_of_mystery_function_22 g ->
    forall n m: nat,
      f n m = g n m.
Proof.
  intros f g.
  unfold specification_of_mystery_function_22.
  intros H_f H_g.
  intro n.
  induction n as [ | n' IHn'].

  - intro m.
    assert (H_tmp := H_g 0 m).
    destruct H_tmp as [H_g_O _].
    rewrite -> H_g_O.
    assert (H_tmp := H_f 0 m).
    destruct H_tmp as [H_f_O _].
    exact H_f_O.

  - intro m.
    assert (H_tmp := H_g n' m).
    destruct H_tmp as [_ H_g_S].
    rewrite -> H_g_S.
    rewrite <- (IHn' (S m)).
    assert (H_tmp := H_f n' m).
    destruct H_tmp as [_ H_g_f].
    exact H_g_f.
Qed.

Definition unit_test_for_mystery_function_22 (mf : nat -> nat -> nat) :=
  (mf 0 0 =n= 0) && (mf 1 0 =n= 1) && (mf 0 1 =n= 1) && (mf 1 1 =n= 2)
(* etc. *).

Definition mystery_function_22 (n m : nat) : nat :=
  n + m.

Compute (unit_test_for_mystery_function_22 mystery_function_22).

Theorem there_is_at_least_one_mystery_function_22 :
  specification_of_mystery_function_22 mystery_function_22.
Proof.
  unfold specification_of_mystery_function_22, mystery_function_22.
  split.
  - exact (Nat.add_0_l j).

  - exact (Nat.add_succ_comm i j).
Qed.

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

(* Binary trees of natural numbers: *)

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

Definition specification_of_mystery_function_19 (mf : tree -> tree) :=
  (forall n : nat,
     mf (Leaf n) = Leaf n)
  /\
  (forall (n : nat) (t : tree),
     mf (Node (Leaf n) t) = Node (Leaf n) (mf t))
  /\
  (forall t11 t12 t2 : tree,
     mf (Node (Node t11 t12) t2) = mf (Node t11 (Node t12 t2))).

(* You might not manage to prove
   that at most one function satisfies this specification (why?),
   but consider whether the following function does.
   Assuming it does, what does this function do?
   And what is the issue here?
*)

Theorem there_is_at_most_one_mystery_function_19:
  forall f g : tree -> tree,
    specification_of_mystery_function_19 f ->
    specification_of_mystery_function_19 g ->
    forall t: tree,
      f t = g t.
Proof.
  intros f g.
  unfold specification_of_mystery_function_21.
  intros [H_f_O [H_f_S H_f_SS]] [H_g_O [H_g_S H_g_SS]].
  intro t.
  induction t as [ | t' IHt'].

  - rewrite (H_g_O n).
    exact (H_f_O n).

  - (* difficult to proceed *)
Abort.

Fixpoint mystery_function_19_aux (t a : tree) : tree :=
  match t with
  | Leaf n =>
     Node (Leaf n) a
  | Node t1 t2 =>
     mystery_function_19_aux t1 (mystery_function_19_aux t2 a)
  end.

Fixpoint mystery_function_19 (t : tree) : tree :=
  match t with
  | Leaf n =>
     Leaf n
  | Node t1 t2 =>
     mystery_function_19_aux t1 (mystery_function_19 t2)
  end.

Theorem there_is_at_least_one_mystery_function_19 :
  specification_of_mystery_function_19 mystery_function_19.
Proof.
  unfold specification_of_mystery_function_19, mystery_function_19.
  unfold mystery_function_19_aux.
  split.
  - intro n.
    reflexivity.

  - split.
    * reflexivity.
    * reflexivity.
Qed.

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

(* Extra mystery functions: *)

(* ***** *)

Definition specification_of_mystery_function_05 (mf : nat -> nat) :=
  mf 0 = 1
  /\
  forall i j : nat,
    mf (S (i + j)) = 2 * mf i * mf j.

(* ***** *)

Definition specification_of_mystery_function_06 (mf : nat -> nat) :=
  mf 0 = 2
  /\
  forall i j : nat,
    mf (S (i + j)) = mf i * mf j.

(* ***** *)

Definition specification_of_mystery_function_09 (mf : nat -> bool) :=
  mf 0 = false
  /\
  mf 1 = true
  /\
  forall i j : nat,
    mf (i + j) = xorb (mf i) (mf j).

(* ***** *)

Definition specification_of_mystery_function_10 (mf : nat -> bool) :=
  mf 0 = false
  /\
  mf 1 = true
  /\
  forall i j : nat,
    mf (i + j) = (mf i =b= mf j).

(* ***** *)

Definition specification_of_mystery_function_12 (mf : nat -> nat) :=
  mf 1 = 1
  /\
  forall i : nat,
    mf (S (S i)) = (S (S i)) * mf (S i).

(* ***** *)

Definition specification_of_mystery_function_14 (mf : nat -> bool) :=
  (forall q : nat, mf (2 * q) = true)
  /\
  (forall q : nat, mf (S (2 * q)) = false).

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

(* Simple examples of specifications: *)

(* ***** *)

Definition specification_of_the_factorial_function (fac : nat -> nat) :=
  fac 0 = 1
  /\
  forall n' : nat, fac (S n') = S n' * fac n'.

(* ***** *)

Definition specification_of_the_fibonacci_function (fib : nat -> nat) :=
  fib 0 = 0
  /\
  fib 1 = 1
  /\
  forall n'' : nat,
    fib (S (S n'')) = fib n'' + fib (S n'').

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

(* end of week-05_mystery-functions.v *)


Require Export List.
Require Export Lia.
Require Export Morphisms.

Parameter Point : Set.
Parameter eq_dec : forall A B : Point, {A = B} + {~ A = B}.

Definition equivlist (l l':list Point) := forall x, List.In x l <-> List.In x l'.

Ltac simplgen H := simpl in H;generalize H.

Ltac my_inS :=
  intuition;unfold incl in *;unfold equivlist in *;
  repeat match goal with
  |[H : _ |- _] => progress intros
  |[H : _ |- _] => progress intro
  |[H : _ |- _] => progress intuition
  |[H : _ |- _] => split;intuition
  |[H : In _ (?P ::  _ ) |- _] => inversion H;clear H
  |[H : _ = _ |- _] => rewrite <-H
  |[H : In _ nil |- _] => inversion H
  end.

Parameter rk : list Point -> nat.
Parameter rk_compat : forall x x', equivlist x x' -> rk x = rk x'.

Global Instance rk_morph : Proper (equivlist ==> (@Logic.eq nat)) rk.
Proof.
intros;repeat red.
apply rk_compat.
Qed.

(*** Definition Inb ***)
Fixpoint Inb (a:Point) (l:list Point) {struct l} : bool :=
    match l with
      | nil => false
      | b :: m => if (eq_dec b a) then true else Inb a m
    end.

Lemma Inb_aux1 :
forall a l, Inb a l = true -> In a l.
Proof.
my_inS;induction l;my_inS.
- inversion H.
- simplgen H;case_eq(eq_dec a0 a);my_inS.
Qed.

Lemma Inb_aux2 :
forall a l, Inb a l = false -> ~In a l.
Proof.
my_inS;induction l;my_inS.
- rewrite H1 in *;simplgen H;case_eq(eq_dec a a);my_inS.
- simplgen H;case_eq(eq_dec a0 a);my_inS.
Qed.

(*** Definition list_inter ***)
Definition list_inter l1 l2 := filter (fun x : Point => Inb x l2) l1.

Lemma list_inter_split :
forall a l m, In a (list_inter l m) -> In a l /\ In a m.
Proof.
intros.
my_inS;induction l;my_inS.
- simplgen H;unfold list_inter;simpl;case_eq(Inb a0 m);my_inS.
- inversion H.
- simplgen H;unfold list_inter;simpl;case_eq(Inb a0 m);my_inS;apply Inb_aux1;my_inS.
Qed.

Lemma list_inter_closure :
forall a l m, In a m -> In a l -> In a (list_inter l m).
Proof.
my_inS;induction l;my_inS.
- simpl;case_eq(Inb a0 m);my_inS;assert(HH := Inb_aux2 a0 m H0);subst;my_inS.
- simpl;case_eq(Inb a0 m);my_inS.
Qed.

Ltac inv_unif :=
  unfold incl in *; try split; intros;
  repeat match goal with
         | [H : In _ (?P ::  _ ) |- _] => inversion H;clear H
         | [H: _ = _ |- _] => rewrite <- H in *;try solve [contradiction|apply eq_sym in H;contradiction];clear H
         | [H : In _ nil |- _] => inversion H
         | [H : In _ (?L++?M) |- _] => apply in_app_iff in H; destruct H
         | [H :_ |- In _ (?L++?M) ] => apply in_app_iff
         | [H : In _ (list_inter _ _) |- _] => apply list_inter_split in H; destruct H
         | [H : _ |- In _ (list_inter _ _)] => apply list_inter_closure
         end.

Ltac solve_equivlist := first [apply in_eq | apply in_cons ; solve_equivlist].

Ltac my_inO := solve[inv_unif ; first[solve_equivlist | left;solve_equivlist | right;solve_equivlist]].

Parameter matroid1_a  : forall X, rk X >= 0.
Parameter matroid1_b : forall X, rk X <= length X.
Parameter matroid2 : forall X Y, incl X Y -> rk X <= rk Y.
Parameter matroid3 : forall X Y, rk(X ++ Y) + rk(list_inter X Y) <= rk X + rk Y.

(*** Lemmes matroides utiles ***)
Lemma matroid1_b_useful : forall (l : list Point) (m : nat), length l <= m -> rk l <= m.
Proof.
intros.
assert(HH := matroid1_b l).
lia.
Qed.

Lemma matroid3_useful : forall e e' ei : list Point,
 incl ei (list_inter e e') ->
 rk(e ++ e') + rk(ei) <= rk(e) + rk(e').
Proof.
intros.
assert (rk (e ++ e') + rk (list_inter e e') <= rk e + rk e').
apply matroid3.
assert (rk (ei) <= rk (list_inter e e')).
apply matroid2;auto.
lia.
Qed.

Lemma couple_equal : forall A B, rk(A :: B :: nil) = rk(B :: A :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma triple_equal_1 : forall A B C, rk(A :: B :: C :: nil) = rk(A :: C :: B :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma triple_equal_2 : forall A B C, rk(A :: B :: C :: nil) = rk(B :: A :: C :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma triple_equal_3 : forall A B C, rk(A :: B :: C :: nil) = rk(B :: C :: A :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma triple_equal_4 : forall A B C, rk(A :: B :: C :: nil) = rk(C :: A :: B :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma triple_equal_5 : forall A B C, rk(A :: B :: C :: nil) = rk(C :: B :: A :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma rk_triple_max_3 : forall X Y Z : Point, rk(X :: Y :: Z :: nil) <= 3.
Proof.
intros.
apply matroid1_b_useful.
intuition.
Qed.

Lemma rk_quadruple_max_4 : forall W X Y Z : Point,rk(W :: X :: Y :: Z :: nil) <= 4.
Proof.
intros.
apply matroid1_b_useful.
intuition.
Qed.

Lemma quadruple_equal_1 : forall A B C D, rk(A :: B :: C :: D :: nil) = rk(A :: B :: D :: C :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quadruple_equal_2 : forall A B C D, rk(A :: B :: C :: D :: nil) = rk(A :: C :: B :: D :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quadruple_equal_3 : forall A B C D, rk(A :: B :: C :: D :: nil) = rk(A :: C :: D :: B :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quadruple_equal_4 : forall A B C D, rk(A :: B :: C :: D :: nil) = rk(A :: D :: B :: C :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quadruple_equal_5 : forall A B C D, rk(A :: B :: C :: D :: nil) = rk(A :: D :: C :: B :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quadruple_equal_6 : forall A B C D, rk(A :: B :: C :: D :: nil) = rk(B :: A :: C :: D :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quadruple_equal_7 : forall A B C D, rk(A :: B :: C :: D :: nil) = rk(B :: A :: D :: C :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quadruple_equal_8 : forall A B C D, rk(A :: B :: C :: D :: nil) = rk(B :: C :: A :: D :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quadruple_equal_9 : forall A B C D, rk(A :: B :: C :: D :: nil) = rk(B :: C :: D :: A :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quadruple_equal_10 : forall A B C D, rk(A :: B :: C :: D :: nil) = rk(B :: D :: A :: C :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quadruple_equal_11 : forall A B C D, rk(A :: B :: C :: D :: nil) = rk(B :: D :: C :: A :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quadruple_equal_12 : forall A B C D, rk(A :: B :: C :: D :: nil) = rk(C :: A :: B :: D :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quadruple_equal_13 : forall A B C D, rk(A :: B :: C :: D :: nil) = rk(C :: A :: D :: B :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quadruple_equal_14 : forall A B C D, rk(A :: B :: C :: D :: nil) = rk(C :: B :: A :: D :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quadruple_equal_15 : forall A B C D, rk(A :: B :: C :: D :: nil) = rk(C :: B :: D :: A :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quadruple_equal_16 : forall A B C D, rk(A :: B :: C :: D :: nil) = rk(C :: D :: A :: B :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quadruple_equal_17 : forall A B C D, rk(A :: B :: C :: D :: nil) = rk(C :: D :: B :: A :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quadruple_equal_18 : forall A B C D, rk(A :: B :: C :: D :: nil) = rk(D :: A :: B :: C :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quadruple_equal_19 : forall A B C D, rk(A :: B :: C :: D :: nil) = rk(D :: A :: C :: B :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quadruple_equal_20 : forall A B C D, rk(A :: B :: C :: D :: nil) = rk(D :: B :: A :: C :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quadruple_equal_21 : forall A B C D, rk(A :: B :: C :: D :: nil) = rk(D :: B :: C :: A :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quadruple_equal_22 : forall A B C D, rk(A :: B :: C :: D :: nil) = rk(D :: C :: A :: B :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Lemma quadruple_equal_23 : forall A B C D, rk(A :: B :: C :: D :: nil) = rk(D :: C :: B :: A :: nil).
Proof.
intros;apply rk_morph;my_inO.
Qed.

Ltac clear_all_rk :=
repeat match goal with
| H : rk _ = _ |- _ => clear H
| H : rk _ >= _ |- _ => clear H
| H : rk _ <= _ |- _ => clear H
end.

Parameter rk_singleton_ge : forall A, rk (A :: nil)  >= 1.
Parameter rk_couple_ge : forall A B, ~ A = B -> rk(A :: B :: nil) >= 2.
Parameter rk_three_points_on_lines : forall A B, exists C, rk (A :: B :: C :: nil) = 2 /\ rk (B :: C :: nil) = 2 /\ rk (A :: C :: nil) = 2.
Parameter rk_inter : forall A B C D, rk(A :: B :: C :: D :: nil) <= 3 -> exists J : Point, rk(A :: B :: J :: nil) = 2 /\ rk (C :: D :: J :: nil) = 2.
Parameter rk_lower_dim : exists A0 A1 A2 A3, rk( A0 :: A1 :: A2 :: A3 :: nil) = 4.
Parameter rk_upper_dim : forall e, rk(e) <= 4.

Lemma rk_singleton_1 : forall A, rk(A :: nil) <= 1.
Proof.
intros.
apply matroid1_b_useful.
intuition.
Qed.

Lemma rk_singleton : forall A, rk(A :: nil) = 1.
Proof.
intros.
assert(H := rk_singleton_ge A).
assert(HH := rk_singleton_1 A).
lia.
Qed.

Lemma matroid1_b_useful2 : forall (l : list Point) (a : Point), length (a :: l) >= 1 -> rk (a :: l) >= 1.
Proof.
intros.
assert(HH := rk_singleton a).
assert(HH0 := matroid2 (a :: nil) (a :: l)).
assert(HH1 : incl (a :: nil) (a :: l));[my_inO|].
assert(HH2 := HH0 HH1).
lia.
Qed.

Lemma rk_couple_2 : forall A B, rk(A :: B :: nil) <= 2.
Proof.
intros.
apply matroid1_b_useful.
intuition.
Qed.

Lemma rk_couple : forall A B : Point,~ A = B -> rk(A :: B :: nil) = 2.
Proof.
intros.
assert(HH := rk_couple_2 A B).
assert(HH0 := rk_couple_ge A B H).
lia.
Qed.

Lemma rk_triple_3 : forall A B C : Point, rk (A :: B :: C :: nil) <= 3.
Proof.
intros.
apply matroid1_b_useful.
intuition.
Qed.

Lemma couple_rk1 : forall A B, rk(A :: B :: nil) = 2 -> ~ A = B.
Proof.
intros.
intro.
rewrite H0 in H.
assert(HH : equivlist (B :: B :: nil) (B :: nil));[my_inO|].
rewrite HH in H.
assert(HH0 := rk_singleton_1 B).
lia.
Qed.

Lemma couple_rk2 : forall A B, rk(A :: B :: nil) = 1 -> A = B.
Proof.
intros.
case_eq(eq_dec A B).
intros.
assumption.
intros.
assert(HH := rk_couple A B n).
lia.
Qed.

Lemma rule_1 : forall A B AiB, forall MA MB mAiB,
rk(A) <= MA -> rk(B) <= MB -> rk(AiB) >= mAiB -> incl AiB (list_inter A B) ->
rk(A ++ B) <= MA + MB - mAiB.
Proof.
intros.
assert(HH := matroid3_useful A B AiB H2).
lia.
Qed.

Lemma rule_2 : forall A B AiB, forall mAuB mAiB MB,
rk(A ++ B) >= mAuB -> rk(AiB) >= mAiB -> rk(B) <= MB -> incl AiB (list_inter A B) ->
rk(A) >= mAuB + mAiB - MB.
Proof.
intros.
assert(HH := matroid3_useful A B AiB H2).
lia.
Qed.

Lemma rule_3 : forall A B AiB, forall MA MB mAuB,
rk(A) <= MA -> rk(B) <= MB -> rk(A ++ B) >= mAuB -> incl AiB (list_inter A B) ->
rk(AiB) <= MA + MB - mAuB.
Proof.
intros.
assert(HH := matroid3_useful A B AiB H2).
lia.
Qed.

Lemma rule_4 : forall A B AiB, forall mAuB mAiB MA,
rk(A ++ B) >= mAuB -> rk(AiB) >= mAiB -> rk(A) <= MA -> incl AiB (list_inter A B) ->
rk(B) >= mAuB + mAiB - MA.
Proof.
intros.
assert(HH := matroid3_useful A B AiB H2).
lia.
Qed.

Lemma rule_5 : forall A B, forall mA mB,
rk(A) >= mA -> mA >= mB -> incl A B ->
rk(B) >= mA.
Proof.
intros.
assert(HH := matroid2 A B H1).
lia.
Qed.

Lemma rule_6 : forall A B, forall MA MB,
rk(B) <= MB -> MB <= MA -> incl A B ->
rk(A) <= MB.
Proof.
intros.
assert(HH := matroid2 A B H1).
lia.
Qed.

Lemma rule_7 : forall A B, forall mA mB,
rk(B) >= mB -> mB >= mA -> incl B A ->
rk(A) >= mB.
Proof.
intros.
assert(HH := matroid2 B A H1).
lia.
Qed.

Lemma rule_8 : forall A B, forall MA MB,
rk(A) <= MA -> MA <= MB -> incl B A ->
rk(B) <= MA.
Proof.
intros.
assert(HH := matroid2 B A H1).
lia.
Qed.

Parameter rk_pappus : forall A B C D E F G H I,
rk(A :: B :: nil) = 2 -> rk(A :: C :: nil) = 2 -> rk(A :: D :: nil) = 2 ->
rk(A :: E :: nil) = 2 -> rk(A :: F :: nil) = 2 ->
rk(B :: C :: nil) = 2 -> rk(B :: D :: nil) = 2 -> rk(B :: E :: nil) = 2 ->
rk(B :: F :: nil) = 2 ->
rk(C :: D :: nil) = 2 -> rk(C :: E :: nil) = 2 -> rk(C :: F :: nil) = 2 ->
rk(D :: E :: nil) = 2 -> rk(D :: F :: nil) = 2 ->
rk(E :: F :: nil) = 2 ->
rk(A :: B :: C :: nil) = 2 -> rk(D :: E :: F :: nil) = 2 ->
rk(A :: E :: G :: nil) = 2 -> rk(B :: D :: G :: nil) = 2 ->
rk(A :: F :: H :: nil) = 2 -> rk(C :: D :: H :: nil) = 2 ->
rk(B :: F :: I :: nil) = 2 -> rk(C :: E :: I :: nil) = 2 -> rk(G :: H :: I :: nil) = 2.

Ltac rk_couple_triple :=
  match goal with

| H : rk(?A :: ?B :: nil) = 2 |- rk(?A :: ?B :: nil) = 2 => assumption
| H : rk(?B :: ?A :: nil) = 2 |- rk(?A :: ?B :: nil) = 2 => rewrite couple_equal in H;assumption

| H : rk(?A :: ?B :: ?C :: nil) = _ |-  rk(?A :: ?B :: ?C :: nil) = _ => assumption
| H : rk(?A :: ?C :: ?B :: nil) = _ |-  rk(?A :: ?B :: ?C :: nil) = _ => rewrite <-triple_equal_1 in H;assumption
| H : rk(?B :: ?A :: ?C :: nil) = _ |-  rk(?A :: ?B :: ?C :: nil) = _ => rewrite <-triple_equal_2 in H;assumption
| H : rk(?B :: ?C :: ?A :: nil) = _ |-  rk(?A :: ?B :: ?C :: nil) = _ => rewrite <-triple_equal_3 in H;assumption
| H : rk(?C :: ?A :: ?B :: nil) = _ |-  rk(?A :: ?B :: ?C :: nil) = _ => rewrite <-triple_equal_4 in H;assumption
| H : rk(?C :: ?B :: ?A :: nil) = _ |-  rk(?A :: ?B :: ?C :: nil) = _ => rewrite <-triple_equal_5 in H;assumption
end.

Ltac clear_ineg_rk :=
repeat match goal with
| H : rk _ >= _ |- _ => clear H
| H : rk _ <= _ |- _ => clear H
end.

Ltac equalize_pts :=
repeat match goal with
| H : rk (?X0 :: ?X1 :: nil) = 1 |- _ =>
          let HH := fresh in assert(HH := couple_rk2 X0 X1 H);clear H;rewrite HH
end.

Ltac eliminate_hyps :=
repeat match goal with
| H : rk ?X = _, H0 : rk ?X >= _ |- _ => clear H0
| H : rk ?X = _, H0 : rk ?X <= _ |- _ => clear H0
| H : rk ?X >= _, H0 : rk ?X >= _ |- _ => clear H
| H : rk ?X <= _, H0 : rk ?X <= _ |- _ => clear H
| H : rk ?X >= ?Y, H0 : rk ?X <= ?Y |- _ =>  let HH := fresh in assert(HH : rk X = Y) by (lia)
end.

Lemma le_S_sym : forall n m : nat,
n >= S m -> n >= m.
Proof.
intros.
intuition.
Qed.

Lemma eq_to_ge : forall n m : nat,
n = m -> n >= m.
Proof.
intros.
lia.
Qed.

Lemma eq_to_le : forall n m : nat,
n = m -> n <= m.
Proof.
intros.
lia.
Qed.

Lemma eq_le_incl : forall n m, n = m -> n <= m.
Proof.
  intros; lia.
Qed.

Ltac solve_hyps_max H H0 :=
solve[apply matroid1_b_useful;simpl;repeat constructor
|apply rk_upper_dim
|apply eq_le_incl;apply H
|apply eq_le_incl;apply eq_sym;apply H
|apply H0
|apply le_S;apply H0
|apply le_S;apply le_S;apply H0
|apply le_S;apply le_S;apply le_S;apply H0
|lia
].

Ltac solve_hyps_min H H0:=
solve[apply matroid1_b_useful2;simpl;repeat constructor
|apply matroid1_a
|apply eq_le_incl;apply H
|apply eq_le_incl;apply eq_sym;apply H
|apply H0
|apply le_S_sym;apply H0
|apply le_S_sym;apply le_S_sym;apply H0
|apply le_S_sym;apply le_S_sym;apply le_S_sym;apply H0
|lia
].


Require Basic.

Theorem andb_true_elim2 : forall b c : bool,
	andb b c = true -> c = true.
Proof.

	intros b c.

	destruct b.

		(* b - true *)
		simpl.
		intros H.
		rewrite H.
		reflexivity.

		(* b - false *)
		simpl.

		destruct c.

			reflexivity.

			simpl.
			intros H.
			rewrite H.
			reflexivity.

Qed.


Require Import ct13 ct16.

Lemma permutation_split : forall (l : list nat),
  permutation (fst (split nat l) ++ snd (split nat l)) l.
Proof.
div_conq_pair; intros; simpl; try (repeat constructor).
destruct (split nat l); simpl in *; constructor;
apply Permutation_sym,Permutation_cons_app, Permutation_sym; auto.
Defined.


Require Import
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.universal_algebra.

Section contents.
  Variable Sorts: Set.

  Section map_op.
    (* Given maps between two realizations of the sorts, there are maps between the corresponding op_types*)
    Context {A B: Sorts → Type}
      `{∀ a, Equiv (A a)} `{∀ a, Equiv (B a)}
      (ab: ∀ a, A a → B a)
      (ba: ∀ a, B a → A a)
      `{∀ a, Proper ((=) ==> (=)) (ab a)}
      `{∀ a, Proper ((=) ==> (=)) (ba a)}.

    Fixpoint map_op {o: OpType Sorts}: op_type A o → op_type B o :=
      match o return op_type A o → op_type B o with
      | ne_list.one u => ab u
      | ne_list.cons _ _ => λ x y, map_op (x (ba _ y))
      end.

    Global Instance map_op_proper o: Proper ((=) ==> (=)) (@map_op o).
    Proof. unfold equiv. induction o; simpl; firstorder. Qed.
      (* todo: can't we make this nameless? *)
  End map_op.

  (* If the maps between the sorts are eachother's inverse, then so are the two generated op_type maps: *)

  Context {A B: Sorts → Type} {e: ∀ a, Equiv (B a)} `{∀ b, Equivalence (e b)}
   (ab: ∀ a, A a → B a) (ba: ∀ a, B a → A a).

  Arguments ab [a] _.
  Arguments ba [a] _.

  Context `(iso: ∀ a (x: B a), ab (ba x) = x).

  Lemma map_iso o (x: op_type B o) (xproper: Proper (=) x):
    map_op ab ba (map_op ba ab x) = x.
  Proof with auto; try reflexivity.
   induction o; simpl; intros...
   intros x0 y H0.
   change (map_op ab ba (map_op ba ab (x (ab (ba x0)))) = x y).
   transitivity (x (ab (ba x0))).
    apply IHo, xproper...
   apply xproper. rewrite iso, H0...
  Qed.
End contents.


Set Warnings "-notation-overridden".

Require Export Category.
Require Export Functor.
Require Export NaturalTransformation.
Require Export Cat.
Require Export Sets.
Require Export Opposite.
Require Export HomFunctor.

Set Universe Polymorphism.

Class UnitCounitAdjunction
  {C D: Category} (F: Functor C D) (G: Functor D C) := {
  unit: NaturalTransformation (identity_functor C) (G ∘[Cat] F);
  counit: NaturalTransformation (F ∘[Cat] G) (identity_functor D);
  left_identity_law: forall X, counit⟦F[X]⟧ ∘ map[F](unit⟦X⟧) ≈ id[F[X]];
  right_identity_law: forall X, map[G](counit⟦X⟧) ∘ unit⟦G[X]⟧ ≈ id[G[X]]
}.

Definition HomsetAdjunction
  {C D: Category} (F: Functor C D) (G: Functor D C)
  := (HomOp F (identity_functor D))
     ≅[ Sets \ product_category (op C) D ]
     (HomOp (identity_functor C) G).

Definition phi
  {C D: Category} {F: Functor C D} {G: Functor D C}
  (H: HomsetAdjunction F G) {X:Obj[C]} {Y:Obj[D]}
  : Hom[Sets] {| carrier := Hom[D] F[X] Y |} {| carrier := Hom[C] X G[Y] |}
  := left_inverse H ⟦(X,Y)⟧.

Program Instance phi_respects
  {C D: Category} {F: Functor C D} {G: Functor D C}
  (H: HomsetAdjunction F G) {X:Obj[C]} {Y:Obj[D]}
  : Proper (equiv ==> equiv) (phi H (X:=X) (Y:=Y)) :=
  function_respects (left_inverse H ⟦(X,Y)⟧).

Lemma phi_natural
  {C D: Category} {F: Functor C D} {G: Functor D C}
  (H: HomsetAdjunction F G) {X Y X' Y'}
  (f: Hom[product_category (op C) D] (X,Y) (X',Y'))
  : phi H ∘ map[HomOp F (identity_functor D)] f ≈
    map[HomOp (identity_functor C) G] f ∘ phi H.
  Proof. apply (natural[left_inverse H] _ _ f). Qed.

Definition psi
  {C D: Category} {F: Functor C D} {G: Functor D C}
  (H: HomsetAdjunction F G) {X: Obj[C]} {Y: Obj[D]}
  : Hom[Sets] {| carrier := Hom[C] X G[Y] |} {| carrier := Hom[D] F[X] Y |}
  := right_inverse H ⟦(X,Y)⟧.

Lemma psi_natural
  {C D: Category} {F: Functor C D} {G: Functor D C}
  (H: HomsetAdjunction F G) {X Y X' Y'}
  (f: Hom[product_category (op C) D] (X,Y) (X',Y'))
  : psi H ∘ map[HomOp (identity_functor C) G] f ≈
    map[HomOp F (identity_functor D)] f ∘ psi H.
  Proof. apply (natural[right_inverse H] _ _ f). Qed.

Program Instance psi_respects
  {C D: Category} {F: Functor C D} {G: Functor D C}
  (H: HomsetAdjunction F G) {X:Obj[C]} {Y:Obj[D]}
  : Proper (equiv ==> equiv) (psi H (X:=X) (Y:=Y)) :=
  function_respects (right_inverse H ⟦(X,Y)⟧).

Lemma phi_psi_id
  {C D: Category} {F: Functor C D} {G: Functor D C}
  (H: HomsetAdjunction F G) {X:Obj[C]} {Y:Obj[D]}
  : phi H (X:=X) (Y:=Y) ∘ psi H (X:=X) (Y:=Y) ≈ id.
  Proof. unfold phi, psi. rewrite (left_inversion H (X, Y)).
   simplify. Qed.

Lemma psi_phi_id
  {C D: Category} {F: Functor C D} {G: Functor D C}
  (H: HomsetAdjunction F G) {X:Obj[C]} {Y:Obj[D]}
  : psi H (X:=X) (Y:=Y) ∘ phi H (X:=X) (Y:=Y) ≈ id.
  Proof. unfold phi, psi. rewrite (right_inversion H (X, Y)).
   simplify. Qed.

Program Instance from_homset_adjunction
  {C D: Category} (F: Functor C D) (G: Functor D C)
  (H: HomsetAdjunction F G) :
  UnitCounitAdjunction F G :=
{
  unit := {| component := fun X => phi H (id[F[X]]) |};
  counit := {| component := fun Y => psi H (id[G[Y]]) |}
}.
Next Obligation.
  unfold natural. intros X Y f.
  pose proof (phi_natural H (id[X],map[F] f) id[F[X]]) as N.
  simpl in *.
  rewrite (@compose_associative C) in N.
  rewrite (right_identity (phi H id[(F)[X]])) in N.
  rewrite <- N.
  clear N.
  simplify.
  pose proof (phi_natural H (f,id[F[Y]]) id[F[Y]]) as N.
  simpl in *.
  rewrite left_identity in N.
  rewrite left_identity in N.
  rewrite N.
  simplify.
Defined.
Next Obligation.
  unfold natural. intros X Y f.
  pose proof (psi_natural H (map[G] f,id[Y]) id[G[Y]]) as N.
  simpl in *.
  rewrite (@compose_associative D) in N.
  rewrite left_identity in N.
  rewrite <- N.
  clear N.
  simplify.
  pose proof (psi_natural H (id[G[X]],f) id[G[X]]) as N.
  simpl in *.
  rewrite right_identity in N.
  rewrite right_identity in N.
  rewrite N.
  simplify.
Defined.
Next Obligation.
  pose proof (psi_natural H (phi H (id[F[X]]), id[F[X]]) id[G[F[X]]]) as N.
  simpl in N.
  rewrite left_identity in N.
  rewrite <- N.
  simplify.
  apply (psi_phi_id H).
Defined.
Next Obligation.
  pose proof (phi_natural H (id[G[X]], psi H (id[G[X]])) id[F[G[X]]]) as N.
  simpl in N.
  rewrite right_identity in N.
  rewrite right_identity in N.
  rewrite <- N.
  simplify.
  apply (phi_psi_id H).
Defined.

Program Definition to_homset_adjunction
  {C D: Category} (F: Functor C D) (G: Functor D C)
  (H: UnitCounitAdjunction F G)
  : HomsetAdjunction F G.
Proof.
  unfold HomsetAdjunction.
  simple refine (Build_Isomorphism _ _ _ _ _ _).
  - simple refine (@Build_NaturalTransformation _ _ _ _ _ _).
    + intros [X Y].
      simple refine (Build_Function _ _ _ _ _ _).
      intros f.
      simpl in *.
      apply (map[G] f ∘ unit⟦X⟧).
      simplify.
    + unfold natural. simpl.
      intros [X1 X2] [Y1 Y2] [f1 f2] g.
      simpl in *.
      rewrite preserves_composition.
      rewrite compose_associative.
      pose proof (natural[unit] _ _ f1) as P.
      simpl in P.
      rewrite <- P.
      simplify.
 - simple refine (@Build_NaturalTransformation _ _ _ _ _ _).
    + intros [X Y].
      simple refine (Build_Function _ _ _ _ _ _).
      intros f.
      simpl in *.
      apply (counit⟦Y⟧ ∘ map[F] f).
      simplify.
    + unfold natural. simpl.
      intros [X1 X2] [Y1 Y2] [f1 f2] g.
      simpl in *.
      rewrite preserves_composition.
      rewrite preserves_composition.
      rewrite <- compose_associative.
      rewrite <- compose_associative.
      pose proof (natural[@counit _ _ _ _ H] _ _ f2) as P.
      simpl in P.
      rewrite -> P.
      simplify.
  - unfold isomorphic.
    split; simpl; intros [X Y] f; simpl in *;
    rewrite preserves_composition;
    rewrite -> compose_associative.
    + pose proof (natural[unit] _ _ f) as P.
      simpl in P.
      rewrite <- P.
      rewrite <- compose_associative.
      rewrite -> (@right_identity_law _ _ _ _ H Y).
      simplify.
    + pose proof (natural[@counit _ _ _ _ H] _ _ f) as P.
      simpl in P.
      rewrite <- compose_associative.
      rewrite -> P.
      rewrite -> compose_associative.
      rewrite -> (@left_identity_law _ _ _ _ H X).
      simplify.
Qed.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Require int.Int.

(* Why3 assumption *)
Definition unit  := unit.

Parameter t : Type.

Parameter f: t -> t.

Parameter x0: t.

Parameter iter: Z -> t -> t.

Axiom iter_0 : forall (x:t), ((iter 0%Z x) = x).

Axiom iter_s : forall (k:Z) (x:t), (0%Z < k)%Z -> ((iter k
  x) = (iter (k - 1%Z)%Z (f x))).

Axiom iter_1 : forall (x:t), ((iter 1%Z x) = (f x)).

Axiom iter_s2 : forall (k:Z) (x:t), (0%Z < k)%Z -> ((iter k
  x) = (f (iter (k - 1%Z)%Z x))).

Parameter mu: Z.

Parameter lambda: Z.

Axiom mu_range : (0%Z <= mu)%Z.

Axiom lambda_range : (1%Z <= lambda)%Z.

Axiom distinct : forall (i:Z) (j:Z), ((0%Z <= i)%Z /\
  (i < (mu + lambda)%Z)%Z) -> (((0%Z <= j)%Z /\ (j < (mu + lambda)%Z)%Z) ->
  ((~ (i = j)) -> ~ ((iter i x0) = (iter j x0)))).

Axiom cycle : forall (n:Z), (mu <= n)%Z -> ((iter (n + lambda)%Z
  x0) = (iter n x0)).

Axiom cycle_induction : forall (n:Z), (mu <= n)%Z -> forall (k:Z),
  (0%Z <= k)%Z -> ((iter (n + (lambda * k)%Z)%Z x0) = (iter n x0)).

(* Why3 assumption *)
Inductive ref (a:Type) :=
  | mk_ref : a -> ref a.
Implicit Arguments mk_ref.

(* Why3 assumption *)
Definition contents (a:Type)(v:(ref a)): a :=
  match v with
  | (mk_ref x) => x
  end.
Implicit Arguments contents.

Parameter dist: Z -> Z -> Z.

Axiom dist_def : forall (i:Z) (j:Z), (mu <= i)%Z -> ((mu <= j)%Z ->
  ((0%Z <= (dist i j))%Z /\ (((iter (i + (dist i j))%Z x0) = (iter j x0)) /\
  forall (k:Z), (0%Z <= k)%Z -> (((iter (i + k)%Z x0) = (iter j x0)) ->
  ((dist i j) <= k)%Z)))).

(* Why3 assumption *)
Definition rel(t2:t) (t1:t): Prop := exists i:Z, (t1 = (iter i x0)) /\
  ((t2 = (iter (i + 1%Z)%Z x0)) /\ (((1%Z <= i)%Z /\
  (i <= (mu + lambda)%Z)%Z) /\ ((mu <= i)%Z -> ((dist ((2%Z * i)%Z + 2%Z)%Z
  (i + 1%Z)%Z) < (dist (2%Z * i)%Z i))%Z))).

(* Why3 goal *)
Theorem WP_parameter_tortoise_hare : forall (hare:t) (tortoise:t),
  (exists t1:Z, ((1%Z <= t1)%Z /\ (t1 <= (mu + lambda)%Z)%Z) /\
  ((tortoise = (iter t1 x0)) /\ ((hare = (iter (2%Z * t1)%Z x0)) /\
  forall (i:Z), ((1%Z <= i)%Z /\ (i < t1)%Z) -> ~ ((iter i
  x0) = (iter (2%Z * i)%Z x0))))) -> ((~ (tortoise = hare)) ->
  forall (tortoise1:t), (tortoise1 = (f tortoise)) -> forall (hare1:t),
  (hare1 = (f (f hare))) -> (rel tortoise1 tortoise)).
(* YOU MAY EDIT THE PROOF BELOW *)
intuition.
clear H2.
destruct H as (i, (h1, (h2, (h3, h4)))).
red.
exists i; intuition.
subst.
rewrite iter_s2 with (k := (i+1)%Z).
apply f_equal.
ring_simplify (i+1-1)%Z; auto.
omega.
assert (mu1: (mu <= 2*i+2)%Z) by omega.
assert (mu2: (mu <= i+1)%Z) by omega.
generalize (dist_def (2*i+2) (i+1) mu1 mu2)%Z.
intros (d1, (d2, d3)).
clear mu1 mu2.
assert (mu1: (mu <= 2*i)%Z) by omega.
generalize (dist_def (2*i) i mu1 H3)%Z.
intros (d'1, (d'2, d'3)).
apply Zle_lt_trans with (dist (2 * i) i - 1)%Z.
apply d3.
assert (case: (dist (2*i) i = 0 \/ dist (2*i) i > 0)%Z) by omega. destruct case.
rewrite H4 in d'2.
subst.
absurd (iter i x0 = iter (2 * i) x0)%Z; auto.
symmetry.
ring_simplify (2*i+0)%Z in d'2.
auto.
omega.
rewrite iter_s2; try omega.
rewrite iter_s2 with (k:=(i+1)%Z); try omega.
apply f_equal.
ring_simplify (i+1-1)%Z.
ring_simplify (2 * i + 2 + (dist (2 * i) i - 1) - 1)%Z.
auto.
omega.
Qed.


From Coq Require Import Ascii Decimal List NArith String.

Module StringNotations.

Notation "x '::' xs" := (String x xs) : string_scope.
Notation "'[' ']'" := EmptyString : string_scope.
Notation "'[' x ']'" := (String x EmptyString) : string_scope.
Notation "'[' x ';' y ';' .. ';' z ']'" :=
  (String x (String y .. (String z EmptyString) ..)) : string_scope.

End StringNotations.

Import StringNotations.

Fixpoint string_of_uint (n : uint) : string :=
  match n with
  | Nil => ""
  | D0 p => "0" :: string_of_uint p
  | D1 p => "1" :: string_of_uint p
  | D2 p => "2" :: string_of_uint p
  | D3 p => "3" :: string_of_uint p
  | D4 p => "4" :: string_of_uint p
  | D5 p => "5" :: string_of_uint p
  | D6 p => "6" :: string_of_uint p
  | D7 p => "7" :: string_of_uint p
  | D8 p => "8" :: string_of_uint p
  | D9 p => "9" :: string_of_uint p
  end.

Section Natural.

Import ListNotations N.

Definition string_of_N (n : N) : string :=
  string_of_uint (to_uint n).

Open Scope N_scope.

Fixpoint N_compute (ns : list N) : N :=
  match ns with
  | [] => 0
  | p :: ps => p + N_compute ps
  end.

Fixpoint N_format (ns : list N) : string :=
  match ns with
  | [] => ""
  | [p] => string_of_N p
  | p :: ps => "(" ++ string_of_N p ++ " + " ++ N_format ps ++ ")"
  end.

End Natural.

(** Add powers of two. *)

Section Positive.

Import ListNotations Pos.

Open Scope positive_scope.

Fixpoint positive_powers_of_two (n : positive) : list positive :=
  match n with
  | p ~ 1 => 1 :: map xO (positive_powers_of_two p)
  | p ~ 0 => map xO (positive_powers_of_two p)
  | 1 => [1]
  end.

End Positive.

Section Natural.

Import ListNotations N.

Open Scope string_scope.
Open Scope list_scope.
Open Scope N_scope.

Definition N_powers_of_two (n : N) : list N :=
  match n with
  | 0 => []
  | pos p => map pos (positive_powers_of_two p)
  end.

Compute map (fun n : N => N_compute (N_powers_of_two n))
  (map of_nat (seq 0 16)).

Compute map (fun n : N => N_format (N_powers_of_two n))
  (map of_nat (seq 0 16)).

Lemma N_compute_map_double : forall ns : list N,
  N_compute (map double ns) = double (N_compute ns).
Proof.
  intros ns. induction ns as [| p ps IH].
  - reflexivity.
  - cbn [map N_compute]. rewrite IH. rewrite double_add. reflexivity. Qed.

Theorem N_powers_of_two_valid : forall n : N,
  N_compute (N_powers_of_two n) = n.
Proof.
  intros n. destruct n as [| p].
  - reflexivity.
  - cbv [N_powers_of_two]. induction p as [q IH | q IH |].
    + cbn [positive_powers_of_two map N_compute]. rewrite map_map.
      replace (fun x : positive => pos x ~ 0) with
        (fun x : positive => double (pos x)) by reflexivity.
      rewrite <- map_map. rewrite N_compute_map_double.
      rewrite IH. reflexivity.
    + cbn [positive_powers_of_two]. rewrite map_map.
      replace (fun x : positive => pos x ~ 0) with
        (fun x : positive => double (pos x)) by reflexivity.
      rewrite <- map_map. rewrite N_compute_map_double.
      rewrite IH. reflexivity.
    + reflexivity. Qed.

End Natural.

(** Add a power of two and its residue. *)

Section Natural.

Import ListNotations N.

Open Scope string_scope.
Open Scope list_scope.
Open Scope N_scope.

Definition N_power_and_residue (n : N) : list N :=
  if n =? 0 then [] else
  if n =? 1 then [1] else
  let p : N := log2 n in
  if n =? 2 ^ p then [n / 2; n / 2] else
  [n - 2 ^ p; 2 ^ p].

Compute map (fun n : N => N_compute (N_power_and_residue n))
  (map of_nat (seq 0 16)).

Compute map (fun n : N => N_format (N_power_and_residue n))
  (map of_nat (seq 0 16)).

Theorem N_power_and_residue_valid : forall n : N,
  N_compute (N_power_and_residue n) = n.
Proof.
  intros n. cbv [N_power_and_residue].
  destruct (eqb_spec n 0) as [H0 | H0].
  - rewrite H0. reflexivity.
  - destruct (eqb_spec n 1) as [H1 | H1].
    + rewrite H1. reflexivity.
    + destruct (eqb_spec n (2 ^ log2 n)) as [H2 | H2].
      * cbv [N_compute]. ring_simplify.
        destruct (log2 n) as [| p _] using peano_ind.
        -- exfalso. apply H1. apply H2.
        -- pose proof (neq_succ_0 1) as H.
          symmetry. rewrite (div_exact n 2 H). rewrite (mod_divides n 2 H).
          exists (2 ^ p). rewrite <- pow_succ_r'. apply H2.
      * cbv [N_compute]. ring_simplify.
        rewrite (sub_add (2 ^ log2 n) n).
        -- reflexivity.
        -- apply log2_spec. rewrite <- (neq_0_lt_0 n). apply H0. Qed.

End Natural.


From hahn Require Import Hahn.
Require Import Lia.
Require Import AuxRel2.
Require Import AuxDef.
Require Import Basics.
Require Import SetSize.
Import ListNotations.

Section EnumProperties.
  Context {A: Type} (f: nat -> A).

Lemma enum_exact_steps (r : relation A)
      (STEPS: forall i : nat, r (f i) (f (i + 1))):
  forall i d, r ^^ d (f i) (f (i + d)).
Proof using.
  intros. induction d.
  { simpl. rewrite PeanoNat.Nat.add_0_r. vauto. }
  eexists. split; eauto.
  rewrite NPeano.Nat.add_succ_r, <- NPeano.Nat.add_1_r.
  apply STEPS.
Qed.

Lemma enum_steps (r : relation A)
      (STEPS: forall i : nat, r (f i) (f (i + 1))):
  ⟪STEPS: forall i j (LT: i < j), r^+ (f i) (f j) ⟫.
Proof using.
  red. ins. apply PeanoNat.Nat.le_exists_sub in LT. desc. subst j.
  apply ctEE. exists p. split; auto.
  rewrite NPeano.Nat.add_comm, PeanoNat.Nat.add_succ_comm.
  apply enum_exact_steps. auto.
Qed.

Lemma enum_steps_crt (r : relation A) b
  (STEPS : forall i (DOM : NOmega.lt_nat_l i b), r (f i) (f (i + 1))) :
  forall i j (LE : i <= j) (DOM : NOmega.le (NOnum j) b), r^* (f i) (f j).
Proof using.
  destruct b; ins.
  { apply Lt.le_lt_or_eq in LE as [LT | ]; subst.
    2: now apply rt_refl.
    apply inclusion_t_rt. eapply enum_steps; auto. }
  generalize dependent j.
  induction n; ins.
  { assert (i = 0) by lia; subst.
    assert (j = 0) by lia; subst.
    apply rt_refl. }
  apply Lt.le_lt_or_eq in DOM as [LT | ]; subst.
  { apply IHn; auto. lia. }
  apply Lt.le_lt_or_eq in LE as [LT | ]; subst; vauto.
  eapply rt_unit. exists (f n). split.
  { eapply IHn; auto. lia. }
  specialize (STEPS n).
  rewrite NPeano.Nat.add_comm in STEPS.
  apply STEPS. lia.
Qed.

Lemma enum_inj (r : relation A)
      (STEPS: forall i, r (f i) (f (i + 1)))
      (AC: acyclic r):
  forall x y, f x = f y -> x = y.
Proof using.
  ins. forward eapply enum_steps as STEPS'; eauto.
  pose proof (NPeano.Nat.lt_trichotomy x y) as LT.
  des; auto;
    destruct (AC (f x)); [rewrite H at 2| rewrite H at 1];
    specialize (STEPS' _ _ LT); auto.
Qed.

Lemma enumerates_set_bunion (steps: nat -> A) (S: A -> Prop)
  (ENUM: enumerates steps S):
  S ≡₁ ⋃₁ i ∈ flip NOmega.lt_nat_l (set_size S), eq (steps i).
Proof using.
  apply enumeratesE' in ENUM. desc.
  split; unfolder; ins; desc; subst.
  by apply INSET.
Qed.

Lemma enum_steps_inv (r : relation A)
  (STEPS: forall i : nat, r (f (i + 1)) (f i)) :
  forall i j (LT : i < j), r^+ (f j) (f i).
Proof using.
  ins. fold (transp r⁺ (f i) (f j)). apply transp_ct.
  apply enum_steps; auto.
Qed.

Lemma orders_contradiction r1 r2 (S : A -> Prop)
      (ORD1 : is_total S r1)
      (ORD2 : is_total S r2) :
  restr_rel S (r1 \ eq) ≡ restr_rel S (r2 \ eq) \/
  exists x y, S x /\ S y /\ r1 x y /\ r2 y x.
Proof using.
  destruct (classic (restr_rel S (r1 \ eq) ≡ restr_rel S (r2 \ eq)))
    as [| NEQ]; [tauto| right].
  contra AGREE. destruct NEQ.
  apply same_relation_exp_iff. ins.
  destruct (classic (S x /\ S y)) as [[Sx Sy] |].
  2: { unfold restr_rel. split; ins; desc; by destruct H. }
  destruct (classic (x = y)) as [| NEQ].
  { subst. vauto. unfolder. tauto. }
  specialize (ORD1 x Sx y Sy NEQ). specialize (ORD2 x Sx y Sy NEQ).
  apply excluded_middle_or in ORD1, ORD2.
  des; try by vauto.
  all: try by (edestruct AGREE; do 2 eexists; eauto).
  pose proof not_ex_all_not. specialize (H _ _ AGREE).
  unfolder. tauto.
Qed.

Lemma fsupp_dom_enum_general (r: relation A) (S: A -> Prop)
      (STEPS: forall i, r (f (i + 1)) (f i))
      (AC: acyclic r)
      (FSUPP: fsupp (restr_rel (S ∩₁ f ↑₁ set_full) r^+))
      (INF_S': ~ set_finite (f ↓₁ S)):
  False.
Proof using.
  pose proof (proj2 (fin_dom_rel_fsupp _) FSUPP) as FSUPP'.

  forward eapply (@set_infinite_has_element _ _ INF_S')  as [ie1 Ie1].
  specialize (FSUPP' (eq (f ie1))). specialize_full FSUPP'; [by exists [f ie1]; vauto| ].

  eapply set_finite_mori in FSUPP'.
  2: { red. apply set_collect_map with (f := f). }
  apply set_finite_set_collect_inv_inj in FSUPP'.
  2: { ins. eapply enum_inj with (r := transp r); eauto.
       by apply acyclic_transp. }

  destruct INF_S'.
  rewrite <- set_inter_full_r with (s := _ ↓₁ _).
  rewrite set_full_split with (S := ge ie1), set_inter_union_r.
  apply set_finite_union. split.
  { exists (List.seq 0 (ie1 + 1)). ins. unfolder in IN. desc.
    apply in_seq. lia. }

  eapply set_finite_mori; [| by apply FSUPP'].
  red. red. ins. unfolder in H. desc.
  red. eexists. apply seq_eqv_r. split; eauto.
  red. splits; try by vauto.
  eapply enum_steps_inv; eauto. lia.
Qed.

Lemma fsupp_dom_enum (r: relation A)
      (STEPS: forall i, r (f (i + 1)) (f i))
      (AC: acyclic r)
      (FSUPP: fsupp r^+):
  False.
Proof using.
  eapply fsupp_dom_enum_general with (S := set_full); eauto.
  { eapply fsupp_mori; eauto. red. basic_solver. }
  intros FIN. eapply set_infinite_nat.
  eapply set_finite_mori; eauto. basic_solver.
Qed.

Lemma fsupp_inv_inj {B: Type} (g: A -> B) (r: relation A)
      (FSUPP: fsupp (g ↑ r))
      (INJ_S: forall (x y: A) (Rx: dom_rel r x) (Ry: dom_rel r y),
          g x = g y -> x = y):
  fsupp r.
Proof using.
  apply fin_dom_rel_fsupp. ins.
  pose proof (proj2 (fin_dom_rel_fsupp (g ↑ r)) FSUPP).
  eapply set_finite_set_collect_inv_inj.
  2: { ins. eapply INJ_S; eauto; generalize Sx, Sy; basic_solver. }
  rewrite set_collect_dom. eapply set_finite_mori.
  { red. apply dom_rel_mori. apply collect_rel_seq. }
  rewrite collect_rel_eqv. apply H. by apply set_finite_set_collect.
Qed.

(* TODO: rename? *)
Lemma enum_order_contradiction (r r': relation A) (S: A -> Prop)
      (STEPS: forall i, r (f (i + 1)) (f i))
      (INF_S: ~ set_finite (f ↓₁ S))
      (TOTAL': is_total S r')
      (AC: acyclic r)
      (FS': fsupp r')
      (SEQ: r^+ ⨾ r' ⊆ r^+):
  False.
Proof using.
  forward eapply orders_contradiction with (r1 := r^+) (r2 := r') (S := S ∩₁ (f ↑₁ set_full)).
  2: { eapply is_total_mori; eauto; [red| ]; basic_solver. }
  { red. ins. unfolder in IWa. unfolder in IWb. desc. subst. rename y0 into x.
    pose proof (NPeano.Nat.lt_trichotomy x y).
    desf; [right | left].
    all: eapply enum_steps_inv; eauto. }

  intros [EQUIV | CYCLE].
  2: { desc. apply (AC x). apply SEQ. vauto. }

  eapply fsupp_mori in FS'.
  2: { red. etransitivity.
       { apply proj1 in EQUIV. apply EQUIV. }
       basic_solver. }

  eapply fsupp_dom_enum_general; eauto.
  eapply fsupp_mori; eauto. red.
  eapply restr_rel_mori; [reflexivity| ].
  red. ins. split; auto. intros ->. edestruct AC; eauto.
Qed.

End EnumProperties.