(*
Copyright 2022 Anthony Johnson

Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is furnished
to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in
all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR
THE USE OR OTHER DEALINGS IN THE SOFTWARE.
(*
*)

  This file contains code that proves various theorems from the
  Metamath site (http://us.metamath.org/) in the Coq Proof Assistant
  (https://coq.inria.fr/)
*)

(* http://us.metamath.org/ileuni/mpd.html *)

Theorem mpd : forall P Q R: Prop, ((P -> Q) /\ (P -> (Q -> R))) -> (P -> R).
Proof.
    intros P.
    intros Q.
    intros R.
    intros h1.
    destruct h1.
    intros h2.
    apply H0.
    exact h2.
    apply H.
    exact h2.
Qed.

Print mpd.

Theorem mpd2 : forall P Q R: Prop, ((P -> Q) /\ (P -> (Q -> R))) -> (P -> R).
Proof.
exact (fun (P Q R : Prop) (h1 : (P -> Q) /\ (P -> Q -> R)) => match h1 with
                                                       | conj H H0 => fun h2 : P => H0 h2 (H h2)
                                                       end).
Qed.

(* http://us.metamath.org/ileuni/mpi.html *)
Theorem mpi : forall P Q R:Prop, (Q /\ (P -> (Q -> R))) -> (P -> R).
Proof.
  intros P.
  intros Q.
  intros R.
  intros h1.
  destruct h1.
  intros h2.
  apply H0.
  exact h2.
  exact H.
Qed.

(* http://us.metamath.org/ileuni/mpd.html *)
Theorem mpd2a : forall P Q R:Prop,(P /\ Q /\ (P -> (Q -> R))) -> R.
Proof.
  intros P.
  intros Q.
  intros R.
  intros h1.
  destruct h1.
  destruct H0.
  apply H1.
  apply H.
  apply H0.
Qed.

(* http://us.metamath.org/ileuni/3syl.html *)
Theorem threesly : forall P Q R S:Prop,((P -> Q) /\ (Q -> R) /\ (R -> S)) -> (P -> S) .
Proof.
  intros P Q R S.
  intros h1.
  intros h2.
  destruct h1.
  destruct H0.
  apply H1.
  apply H0.
  apply H.
  exact h2.
Qed.

(* http://us.metamath.org/ileuni/id.html *)
Theorem identity1 : forall P:Prop,P -> P.
Proof.
  intros P.
  intros h.
  exact h.
Qed.

Print identity1.

Eval cbv in (fun (P : Prop) (h : P) => h) True.

(* http://us.metamath.org/ileuni/id.html *)
Theorem identity2 : forall P:Prop,P -> P.
Proof.
  exact (fun (P : Prop) (h : P) => h).
Qed.

(* http://us.metamath.org/ileuni/idd.html *)
Theorem idd : forall P Q:Prop,P -> (Q -> Q).
Proof.
  intros P Q.
  intros H.
  intros H0.
  exact H0.
Qed.

(* http://us.metamath.org/ileuni/a1d.html *)
Theorem ad1 : forall P Q R:Prop,(P -> Q) -> (P -> (R -> Q)).
Proof.
  intros P Q R.
  intros H.
  intros H0.
  intros H1.
  apply H.
  exact H0.
Qed.

Print ad1.

Theorem ad1b : forall P Q R:Prop,(P -> Q) -> (P -> (R -> Q)).
Proof.
  exact (fun (P Q R : Prop) (H : P -> Q) (H0 : P) (_ : R) => H H0).
Qed.

(* http://us.metamath.org/ileuni/2a1d.html *)
Theorem TwoA1D: forall P Q R S:Prop, (P -> Q) -> (P ->(R -> (S -> Q))).
Proof.
  intros P Q R S.
  intros H.
  intros H0.
  intros H1.
  intros H2.
  apply H.
  exact H0.
Qed.

Print TwoA1D.

Theorem TwoA1Db: forall P Q R S:Prop, (P -> Q) -> (P ->(R -> (S -> Q))).
Proof.
  exact (fun (P Q R S : Prop) (H : P -> Q) (H0 : P) (_ : R) (_ : S) => H H0).
Qed.

(* http://us.metamath.org/ileuni/a1i13.html *)
Theorem a1i13: forall P Q R S:Prop, (Q -> S) -> (P -> (Q -> (R -> S))).
Proof.
  intros P Q R S.
  intros H.
  intros H0.
  intros H1.
  intros H2.
  apply H.
  exact H1.
Qed.

Print a1i13.

Theorem a1i13b: forall P Q R S:Prop, (Q -> S) -> (P -> (Q -> (R -> S))).
Proof.
  exact (fun (P Q R S : Prop) (H : Q -> S) (_ : P) (H1 : Q) (_ : R) => H H1).
Qed.

(* http://us.metamath.org/ileuni/jarr.html *)
Theorem jarr: forall P Q R:Prop,(((P -> Q) -> R) -> (Q -> R)).
Proof.
  intros P Q R.
  intros H.
  intros H0.
  apply H.
  intros H1.
  exact H0.
Qed.

Print jarr.

Theorem jarr2: forall P Q R:Prop,(((P -> Q) -> R) -> (Q -> R)).
Proof.
  exact (fun (P Q R : Prop) (H : (P -> Q) -> R) (H0 : Q) => H (fun _ : P => H0)).
Qed.

(* http://us.metamath.org/ileuni/pm2.86i.html *)
Theorem pm268i1: forall P Q R:Prop,(((P -> Q) -> (P -> R)) -> (P -> (Q -> R))).
Proof.
  intros P Q R.
  intros H0.
  intros H1.
  intros H2.
  apply H0.
  intros H3.
  exact H2.
  exact H1.
Qed.

Print pm268i1.

Theorem pm268i1b: forall P Q R:Prop,(((P -> Q) -> (P -> R)) -> (P -> (Q -> R))).
Proof.
  exact (fun (P Q R : Prop) (H0 : (P -> Q) -> P -> R) (H1 : P) (H2 : Q) =>
          H0 (fun _ : P => H2) H1).
Qed.

(* http://us.metamath.org/ileuni/pm2.86d.html *)
(* ⊢ (𝜑 → ((𝜓 → 𝜒) → (𝜓 → 𝜃))) *)
(* ⊢ (𝜑 → (𝜓 → (𝜒 → 𝜃))) *)
Theorem pm286d:
  forall P Q R S:Prop, ((P -> ((Q -> R) -> (Q -> S))) -> (P -> (Q -> (R -> S)))).
Proof.
  intros P Q R S.
  intros H0.
  intros H1.
  intros H2.
  intros H3.
  apply H0.
  exact H1.
  intros H4.
  exact H3.
  exact H2.
Qed.

Print pm286d.

Theorem pm286db:
  forall P Q R S:Prop, ((P -> ((Q -> R) -> (Q -> S))) -> (P -> (Q -> (R -> S)))).
Proof.
  exact (fun (P Q R S : Prop) (H0 : P -> (Q -> R) -> Q -> S)
          (H1 : P) (H2 : Q) (H3 : R) => H0 H1 (fun _ : Q => H3) H2).
Qed.

(* http://us.metamath.org/ileuni/pm2.86.html *)
(* ⊢ (((𝜑 → 𝜓) → (𝜑 → 𝜒)) → (𝜑 → (𝜓 → 𝜒))) *)
Theorem pm286: forall P Q R:Prop,(((P -> Q) -> (P -> R)) -> (P -> (Q -> R))).
Proof.
  intros P Q R.
  intros H0.
  intros H1.
  intros H2.
  apply H0.
  intros H3.
  apply H2.
  apply H1.
Qed.

Print pm286.

Theorem pm286b: forall P Q R:Prop,(((P -> Q) -> (P -> R)) -> (P -> (Q -> R))).
Proof.
  exact (fun (P Q R : Prop) (H0 : (P -> Q) -> P -> R) (H1 : P) (H2 : Q) =>
          H0 (fun _ : P => H2) H1).
Qed.

(* http://us.metamath.org/ileuni/loolin.html *)
(* ⊢ (((𝜑 → 𝜓) → (𝜓 → 𝜑)) → (𝜓 → 𝜑)) *)
Theorem loolin: forall P Q:Prop,(((P -> Q) -> (Q -> P)) -> (Q -> P)).
Proof.
  intros P Q.
  intros H0 H1.
  apply H0.
  intros H2.
  exact H1.
  exact H1.
Qed.

Print loolin.

Theorem loolinb: forall P Q:Prop,(((P -> Q) -> (Q -> P)) -> (Q -> P)).
Proof.
  exact (fun (P Q : Prop) (H0 : (P -> Q) -> Q -> P) (H1 : Q) =>
              H0 (fun _ : P => H1) H1).
Qed.

(* http://us.metamath.org/ileuni/loowoz.html *)
(* ⊢ (((𝜑 → 𝜓) → (𝜑 → 𝜒)) → ((𝜓 → 𝜑) → (𝜓 → 𝜒))) *)
Theorem loowoz: forall P Q R:Prop, (((P -> Q) -> (P -> R)) -> ((P -> Q) -> (P -> R))).
Proof.
  intros P Q R.
  intros H0 H1 H2.
  apply H0.
  intros H3.
  apply H1.
  exact H2.
  exact H2.
Qed.

Print loowoz.

Theorem loowozb: forall P Q R:Prop, (((P -> Q) -> (P -> R)) -> ((P -> Q) -> (P -> R))).
Proof.
  exact (fun (P Q R : Prop) (H0 : (P -> Q) -> P -> R) (H1 : P -> Q) (H2 : P) =>
          H0 (fun _ : P => H1 H2) H2).
Qed.

(* http://us.metamath.org/ileuni/ax-ia1.html *)
(* ⊢ ((𝜑 ∧ 𝜓) → 𝜑) *)
Theorem axia1: forall P Q:Prop,((P /\ Q) -> P).
Proof.
  intros P Q.
  intros H0.
  destruct H0.
  exact H.
Qed.

Print axia1.

Theorem axia1b: forall P Q:Prop,((P /\ Q) -> P).
Proof.
  exact (fun (P Q : Prop) (H0 : P /\ Q) =>
          match H0 with
          | conj x x0 => (fun (H : P) (_ : Q) => H) x x0
          end).
Qed.

(* http://us.metamath.org/ileuni/ax-ia3.html *)
(* ⊢ (𝜑 → (𝜓 → (𝜑 ∧ 𝜓))) *)
Theorem axia3: forall P Q:Prop,(P -> (Q -> (P /\ Q))).
Proof.
  intros P Q.
  intros H0 H1.
  split.
  exact H0.
  exact H1.
Qed.

Print axia3.

Theorem axia3_2: forall P Q:Prop,(P -> (Q -> (P /\ Q))).
Proof.
  exact (
    fun (P Q : Prop) (H0 : P) (H1 : Q) => conj H0 H1
  ).
Qed.

(* http://us.metamath.org/ileuni/simpld.html *)
(* ⊢ (𝜑 → (𝜓 ∧ 𝜒)) *)
(* ⊢ (𝜑 → 𝜓) *)
Theorem simpld: forall P Q R:Prop,(P -> (Q /\ R)) -> (P -> Q).
Proof.
  intros P Q R.
  intros H0.
  intros H1.
  destruct H0.
  exact H1.
  exact H.
Qed.

Print simpld.

Theorem simpld_2: forall P Q R:Prop,(P -> (Q /\ R)) -> (P -> Q).
Proof.
  exact (
    fun (P Q R : Prop) (H0 : P -> Q /\ R) (H1 : P) =>
      let a : Q /\ R := H0 H1 in
        match a with
        | conj x x0 => (fun (H : Q) (_ : R) => H) x x0
        end
  ).
Qed.

(* http://us.metamath.org/ileuni/ex.html *)
(* ⊢ ((𝜑 ∧ 𝜓) → 𝜒) *)
(* ⊢ (𝜑 → (𝜓 → 𝜒)) *)
Theorem ex01: forall P Q R:Prop, (((P /\ Q) -> R) -> (P -> (Q -> R))).
Proof.
  intros P Q R.
  intros H0 H1 H2.
  apply H0; split.
  exact H1.
  exact H2.
Qed.

Print ex01.

Theorem ex01_2: forall P Q R:Prop, (((P /\ Q) -> R) -> (P -> (Q -> R))).
Proof.
  exact (
    fun (P Q R : Prop) (H0 : P /\ Q -> R) (H1 : P) (H2 : Q) => H0 (conj H1 H2)
  ).
Qed.

(*http://us.metamath.org/ileuni/bi1.html*)
(* ⊢ ((𝜑 ↔ 𝜓) → (𝜑 → 𝜓)) *)
Theorem bi1: forall P Q:Prop, ((P <-> Q) -> (P -> Q)).
Proof.
  intros P Q.
  intros H0 H1.
  destruct H0.
  apply H.
  exact H1.
Qed.

Print bi1.

Theorem bi1_02: forall P Q:Prop, ((P <-> Q) -> (P -> Q)).
Proof.
  exact (
    fun (P Q : Prop) (H0 : P <-> Q) (H1 : P) =>
      match H0 with
      | conj x x0 => (fun (H : P -> Q) (_ : Q -> P) => H H1) x x0
      end
  ).
Qed.

(* http://us.metamath.org/ileuni/bi3.html *)
(* ⊢ ((𝜑 → 𝜓) → ((𝜓 → 𝜑) → (𝜑 ↔ 𝜓))) *)
Theorem bi3: forall P Q:Prop, ((P -> Q) -> ((Q -> P) -> (P <-> Q))).
Proof.
  intros P Q.
  intros H0 H1.
  split.
  intros H2.
  apply H0.
  exact H2.
  intros H3.
  apply H1.
  exact H3.
Qed.

Print bi3.

Theorem bi3_02: forall P Q:Prop, ((P -> Q) -> ((Q -> P) -> (P <-> Q))).
Proof.
  exact (
    fun (P Q : Prop) (H0 : P -> Q) (H1 : Q -> P) =>
      conj (fun H2 : P => H0 H2) (fun H3 : Q => H1 H3)
  ).
Qed.

(* http://us.metamath.org/ileuni/impbidd.html *)
(* ⊢ (𝜑 → (𝜓 → (𝜒 → 𝜃))) *)
(* ⊢ (𝜑 → (𝜓 → (𝜃 → 𝜒))) *)
(* ----------------------*)
(* ⊢ (𝜑 → (𝜓 → (𝜒 ↔ 𝜃))) *)
Theorem impidd: forall P Q R S: Prop,((P -> (Q -> (R -> S))) /\ (P -> (Q -> (S -> R)))) -> (P -> (Q -> (R <-> S))).
Proof.
  intros P Q R S.
  intros H0.
  intros H1 H2.
  split.
  destruct H0.
  intros H3.
  apply H.
  exact H1.
  exact H2.
  exact H3.
  intros H4.
  destruct H0.
  apply H0.
  exact H1.
  exact H2.
  exact H4.
Qed.

Print impidd.

Theorem impidd_2: forall P Q R S: Prop,((P -> (Q -> (R -> S))) /\ (P -> (Q -> (S -> R)))) -> (P -> (Q -> (R <-> S))).
Proof.
  exact (
    fun (P Q R S : Prop) (H0 : (P -> Q -> R -> S) /\ (P -> Q -> S -> R))
    (H1 : P) (H2 : Q) =>
  conj
    match H0 with
    | conj x x0 =>
      (fun (H : P -> Q -> R -> S) (_ : P -> Q -> S -> R) (H4 : R) =>
         H H1 H2 H4) x x0
    end
    (fun H4 : S =>
     match H0 with
     | conj x x0 =>
         (fun (_ : P -> Q -> R -> S) (H3 : P -> Q -> S -> R) => H3 H1 H2 H4) x
           x0
     end)
  ).
Qed.

(* http://us.metamath.org/ileuni/impbid21d.html *)
(* ⊢ (𝜓 → (𝜒 → 𝜃)) *)
(* ⊢ (𝜑 → (𝜃 → 𝜒)) *)
(* =================*)
(* ⊢ (𝜑 → (𝜓 → (𝜒 ↔ 𝜃))) *)
Theorem impid21d: forall P Q R S:Prop,((P -> (Q -> R)) /\ (S -> (R -> Q))) -> (S -> (P -> (Q <-> R))).
Proof.
  intros P Q R S.
  intros H0 H1 H2.
  split.
  intros H3.
  destruct H0.
  apply H.
  exact H2.
  exact H3.
  intros H4.
  destruct H0.
  apply H0.
  exact H1.
  exact H4.
Qed.

Print impid21d.

Theorem impid21d_02: forall P Q R S:Prop,((P -> (Q -> R)) /\ (S -> (R -> Q))) -> (S -> (P -> (Q <-> R))).
Proof.
  exact (
    fun (P Q R S : Prop) (H0 : (P -> Q -> R) /\ (S -> R -> Q)) (H1 : S) (H2 : P)
    =>
    conj
      (fun H3 : Q =>
       match H0 with
       | conj x x0 => (fun (H : P -> Q -> R) (_ : S -> R -> Q) => H H2 H3) x x0
       end)
      (fun H4 : R =>
       match H0 with
       | conj x x0 => (fun (_ : P -> Q -> R) (H3 : S -> R -> Q) => H3 H1 H4) x x0
       end)
  ).
Qed.

(* http://us.metamath.org/ileuni/bicomi.html *)
(* ⊢ (𝜑 ↔ 𝜓) *)
(* ===========*)
(* ⊢ (𝜓 ↔ 𝜑) *)
Theorem bicomi: forall P Q: Prop,((P <-> Q) -> (Q <-> P)).
Proof.
  intros P Q.
  intros H0.
  split.
  destruct H0.
  intros H1.
  apply H0.
  exact H1.
  intros H2.
  destruct H0.
  apply H.
  exact H2.
Qed.

Print bicomi.

Theorem bicomi_02: forall P Q: Prop,((P <-> Q) -> (Q <-> P)).
Proof.
   exact (
    fun (P Q : Prop) (H0 : P <-> Q) =>
    conj
      match H0 with
      | conj x x0 => (fun (_ : P -> Q) (H1 : Q -> P) (H2 : Q) => H1 H2) x x0
      end
      (fun H2 : P =>
       match H0 with
       | conj x x0 => (fun (H : P -> Q) (_ : Q -> P) => H H2) x x0
       end)
   ).
Qed.

Check fun (P Q:Prop) (H0 : P <-> Q) =>
        match H0 with
        | conj x x0 => x0
        end.

(* http://us.metamath.org/ileuni/3imtr3i.html *)
(* ⊢ (𝜑 → 𝜓) *)
(* ⊢ (𝜑 ↔ 𝜒) *)
(* ⊢ (𝜓 ↔ 𝜃) *)
(* ------------*)
(* ⊢ (𝜒 → 𝜃) *)
Theorem threeimtr3i: forall P Q R S:Prop,
    ((P  -> Q) /\
     (P <-> R) /\
     (Q <-> S)) -> (R -> S).
Proof.
  intros P Q R S.
  intros H0 H1.
  destruct H0.
  destruct H0.
  apply H2.
  apply H.
  destruct H2.
  destruct H0.
  apply H4.
  exact H1.
Qed.

Print threeimtr3i.

Theorem threeimtr3i_02: forall P Q R S:Prop,
    ((P  -> Q) /\
     (P <-> R) /\
     (Q <-> S)) -> (R -> S).
Proof.
 exact (
  fun (P Q R S : Prop) (H0 : (P -> Q) /\ (P <-> R) /\ (Q <-> S)) (H1 : R) =>
  match H0 with
  | conj x x0 =>
    (fun (H : P -> Q) (H2 : (P <-> R) /\ (Q <-> S)) =>
       match H2 with
       | conj x1 x2 =>
           (fun (H3 : P <-> R) (H4 : Q <-> S) =>
            let H5 : Q -> S :=
              match H4 with
              | conj x3 x4 => (fun (H5 : Q -> S) (_ : S -> Q) => H5) x3 x4
              end in
            H5
              (H
                 match H4 with
                 | conj x3 x4 =>
                     (fun (_ : Q -> S) (_ : S -> Q) =>
                      match H3 with
                      | conj x5 x6 =>
                          (fun (_ : P -> R) (H9 : R -> P) => H9 H1) x5 x6
                      end) x3 x4
                 end)) x1 x2
       end) x x0
  end
 ).
Qed.

(* http://us.metamath.org/ileuni/expd.html *)
(* ⊢ (𝜑 → ((𝜓 ∧ 𝜒) → 𝜃)) *)
(* ---------------------- *)
(* ⊢ (𝜑 → (𝜓 → (𝜒 → 𝜃))) *)
Theorem expd:forall P Q R S:Prop,
  (P -> ((Q /\ R) -> S)) ->
  (P -> (Q -> (R -> S))).
Proof.
  intros P Q R S.
  intros H0 H1 H2 H3.
  apply H0.
  exact H1.
  split.
  exact H2.
  exact H3.
Qed.

Print expd.

(* http://us.metamath.org/ileuni/expd.html *)
(* ⊢ (𝜑 → ((𝜓 ∧ 𝜒) → 𝜃)) *)
(* ---------------------- *)
(* ⊢ (𝜑 → (𝜓 → (𝜒 → 𝜃))) *)
Theorem expd_01:forall P Q R S:Prop,
  (P -> ((Q /\ R) -> S)) ->
  (P -> (Q -> (R -> S))).
Proof.
  exact (
    fun (P Q R S : Prop) (H0 : P -> Q /\ R -> S) (H1 : P) (H2 : Q) (H3 : R) =>
    H0 H1 (conj H2 H3)
  ).
Qed.

(* http://us.metamath.org/ileuni/expdimp.html *)
(* ⊢ (𝜑 → ((𝜓 ∧ 𝜒) → 𝜃)) *)
(* ---------------------- *)
(* ⊢ ((𝜑 ∧ 𝜓) → (𝜒 → 𝜃)) *)
Theorem ileuni:forall P Q R S:Prop,
      (P -> ((Q /\ R) -> S)) ->
      ((P /\ Q) -> (R -> S)).
Proof.
  intros P Q R S.
  intros H0 H1 H2.
  apply H0.
  destruct H1.
  exact H.
  split.
  destruct H1.
  exact H1.
  exact H2.
Qed.

Print ileuni.

Theorem ileuni_02:forall P Q R S:Prop,
      (P -> ((Q /\ R) -> S)) ->
      ((P /\ Q) -> (R -> S)).
Proof.
  exact (
    fun (P Q R S : Prop) (H0 : P -> Q /\ R -> S) (H1 : P /\ Q) (H2 : R) =>
    H0 match H1 with
       | conj x x0 => (fun (H : P) (_ : Q) => H) x x0
       end
      (conj match H1 with
          | conj x x0 => (fun (_ : P) (H3 : Q) => H3) x x0
            end H2)
  ).
Qed.

(* http://us.metamath.org/ileuni/impancom.html *)
(* ⊢ ((𝜑 ∧ 𝜓) → (𝜒 → 𝜃)) *)
(* ---------------------- *)
(* ⊢ ((𝜑 ∧ 𝜒) → (𝜓 → 𝜃)) *)
Theorem impancom: forall P Q R S:Prop,
    ((P /\ Q) -> (R -> S)) ->
    ((P /\ R) -> (Q -> S)).
Proof.
  intros P Q R S.
  intros H0 H1 H2.
  apply H0.
  split.
  destruct H1.
  exact H.
  exact H2.
  destruct H1.
  exact H1.
Qed.

Print impancom.

Theorem impancom_01: forall P Q R S:Prop,
    ((P /\ Q) -> (R -> S)) ->
    ((P /\ R) -> (Q -> S)).
Proof.
  exact (
    fun (P Q R S : Prop) (H0 : P /\ Q -> R -> S) (H1 : P /\ R) (H2 : Q) =>
    H0 (conj match H1 with
           | conj x x0 => (fun (H : P) (_ : R) => H) x x0
             end H2)
      match H1 with
      | conj x x0 => (fun (_ : P) (H3 : R) => H3) x x0
      end
  ).
Qed.

(* http://us.metamath.org/ileuni/pm3.3.html *)
(* ⊢ (((𝜑 ∧ 𝜓) → 𝜒) → (𝜑 → (𝜓 → 𝜒))) *)
Theorem pm33: forall P Q R:Prop,(((P /\ Q) -> R) -> (P -> (Q -> R))).
Proof.
  intros P Q R.
  intros H0 H1 H2.
  apply H0.
  split.
  exact H1.
  exact H2.
Qed.

Print pm33.

Theorem pm33_02: forall P Q R:Prop,(((P /\ Q) -> R) -> (P -> (Q -> R))).
Proof.
  exact (
    fun (P Q R : Prop) (H0 : P /\ Q -> R) (H1 : P) (H2 : Q) => H0 (conj H1 H2)
  ).
Qed.

(* http://us.metamath.org/ileuni/pm3.31.html *)
(* ⊢ ((𝜑 → (𝜓 → 𝜒)) → ((𝜑 ∧ 𝜓) → 𝜒) *)
Theorem pm331: forall P Q R:Prop,((P -> (Q -> R)) -> ((P /\ Q) -> R)).
Proof.
  intros P Q R.
  intros H0.
  intros H1.
  apply H0.
  destruct H1.
  exact H.
  destruct H1.
  exact H1.
Qed.

Print pm331.

Theorem pm331_02: forall P Q R:Prop,((P -> (Q -> R)) -> ((P /\ Q) -> R)).
Proof.
  exact (
    fun (P Q R : Prop) (H0 : P -> Q -> R) (H1 : P /\ Q) =>
    H0 match H1 with
       | conj x x0 => (fun (H : P) (_ : Q) => H) x x0
       end match H1 with
         | conj x x0 => (fun (_ : P) (H2 : Q) => H2) x x0
           end
  ).
Qed.

(* http://us.metamath.org/ileuni/pm3.22.html *)
(* ⊢ ((𝜑 ∧ 𝜓) → (𝜓 ∧ 𝜑)) *)
Theorem pm322: forall P Q:Prop,((P /\ Q) -> (Q /\ P)).
Proof.
  intros P Q.
  intros H0.
  split.
  destruct H0.
  exact H0.
  destruct H0.
  exact H.
Qed.

Print pm322.

Theorem pm322_02: forall P Q:Prop,((P /\ Q) -> (Q /\ P)).
Proof.
exact (
  fun (P Q : Prop) (H0 : P /\ Q) =>
  conj match H0 with
     | conj x x0 => (fun (_ : P) (H1 : Q) => H1) x x0
       end match H0 with
           | conj x x0 => (fun (H : P) (_ : Q) => H) x x0
           end
).
Qed.

(* http://us.metamath.org/ileuni/ancomd.html *)
(* ⊢ (𝜑 → (𝜓 ∧ 𝜒)) *)
(* ================ *)
(* ⊢ (𝜑 → (𝜒 ∧ 𝜓)) *)
Theorem ancomd:forall P Q R:Prop,((P -> (Q /\ R)) -> (P -> (R /\ Q))).
Proof.
  intros P Q R.
  intros H0 H1.
  split.
  destruct H0.
  exact H1.
  exact H0.
  destruct H0.
  exact H1.
  exact H.
Qed.

(* http://us.metamath.org/ileuni/ancomsd.html *)
(* ⊢ (𝜑 → ((𝜓 ∧ 𝜒) → 𝜃)) *)
(* -----------------------*)
(* ⊢ (𝜑 → ((𝜒 ∧ 𝜓) → 𝜃)) *)
Theorem ancomsd:forall P Q R S:Prop,(P -> ((Q /\ R) -> S)) -> (P -> ((R /\ Q) -> S)).
Proof.
  intros P Q R S.
  intros H0 H1 H2.
  apply H0.
  exact H1.
  split.
  destruct H2.
  exact H2.
  destruct H2.
  exact H.
Qed.

Print ancomsd.

Theorem ancomsd_01:forall P Q R S:Prop,(P -> ((Q /\ R) -> S)) -> (P -> ((R /\ Q) -> S)).
Proof.
  exact (
    fun (P Q R S : Prop) (H0 : P -> Q /\ R -> S) (H1 : P) (H2 : R /\ Q) =>
    H0 H1
      (conj match H2 with
          | conj x x0 => (fun (_ : R) (H3 : Q) => H3) x x0
            end match H2 with
                | conj x x0 => (fun (H : R) (_ : Q) => H) x x0
                end)
  ).
Qed.

(* http://us.metamath.org/ileuni/pm3.43i.html *)
(* ⊢ ((𝜑 → 𝜓) → ((𝜑 → 𝜒) → (𝜑 → (𝜓 ∧ 𝜒)))) *)
Theorem pm343i:forall P Q R S:Prop,((P -> Q) -> ((P -> R) -> (P -> (Q /\ R)))).
Proof.
  intros P Q R S.
  intros H0 H1 H2.
  split.
  apply H0.
  exact H2.
  apply H1.
  exact H2.
Qed.

Print pm343i.

Theorem pm343i_02:forall P Q R S:Prop,((P -> Q) -> ((P -> R) -> (P -> (Q /\ R)))).
Proof.
  exact (
    fun (P Q R _ : Prop) (H0 : P -> Q) (H1 : P -> R) (H2 : P) =>
    conj (H0 H2) (H1 H2)
  ).
Qed.
(* ⊢ (𝜑 ↔ (𝜓 ∧ 𝜒)) *)
(* ---------------- *)
(* ⊢ (𝜑 → 𝜓) *)
Theorem simplbi:forall P Q R:Prop,((P <-> (Q /\ R)) -> (P -> Q)).
Proof.
  intros P Q R.
  intros H0 H1.
  destruct H0.
  destruct H.
  exact H1.
  exact H.
Qed.

Print simplbi.

Theorem simplbi_02:forall P Q R:Prop,((P <-> (Q /\ R)) -> (P -> Q)).
Proof.
  exact (
    fun (P Q R : Prop) (H0 : P <-> Q /\ R) (H1 : P) =>
    match H0 with
    | conj x x0 =>
      (fun (H : P -> Q /\ R) (_ : Q /\ R -> P) =>
         let a : Q /\ R := H H1 in
         match a with
         | conj x1 x2 => (fun (H3 : Q) (_ : R) => H3) x1 x2
         end) x x0
    end
  ).
Qed.

(* http://us.metamath.org/ileuni/simprbi.html *)
(* ⊢ (𝜑 ↔ (𝜓 ∧ 𝜒)) *)
(* ---------------- *)
(* ⊢ (𝜑 → 𝜒) *)
Theorem simprbi:forall P Q R:Prop,((P <-> (Q /\ R)) -> (P -> R)).
Proof.
  intros P Q R.
  intros H0 H1.
  destruct H0.
  destruct H.
  exact H1.
  exact H2.
Qed.

Print simprbi.

Theorem simprbi_01:forall P Q R:Prop,((P <-> (Q /\ R)) -> (P -> R)).
Proof.
  exact (
    fun (P Q R : Prop) (H0 : P <-> Q /\ R) (H1 : P) =>
    match H0 with
    | conj x x0 =>
      (fun (H : P -> Q /\ R) (_ : Q /\ R -> P) =>
         let a : Q /\ R := H H1 in
         match a with
         | conj x1 x2 => (fun (_ : Q) (H4 : R) => H4) x1 x2
         end) x x0
    end
  ).
Qed.

(* http://us.metamath.org/ileuni/adantr.html *)
(* ⊢ (𝜑 → 𝜓) *)
(* ⊢ ((𝜑 ∧ 𝜒) → 𝜓) *)
Theorem adantr:forall P Q R:Prop,((P -> R) -> ((P /\ Q) -> R)).
Proof.
  intros P Q R.
  intros H0.
  intros H1.
  apply H0.
  destruct H1.
  exact H.
Qed.

Print adantr.

Theorem adantr_02:forall P Q R:Prop,((P -> R) -> ((P /\ Q) -> R)).
Proof.
  exact (
    fun (P Q R : Prop) (H0 : P -> R) (H1 : P /\ Q) => H0
      match H1 with
      | conj x x0 => (fun (H : P) (_ : Q) => H) x x0
      end
  ).
Qed.

Section proof_of_tripl_impl.
  Variables P Q S:Prop.
  Hypothesis H : ((P -> Q) -> Q) -> Q.
  Hypothesis p : P.

  Lemma Rem : (P -> Q) -> Q.
  Proof (fun H0:P -> Q => H0 p).

  Definition  Rem_f := (fun H0:P -> Q => H0 p).

  Eval cbv in (Rem_f).

End proof_of_tripl_impl.

(* https://cs.stackexchange.com/questions/80590/is-possible-to-prove-undecidability-of-the-halting-problem-in-coq *)
Record bijection A B :=
  {  to   : A -> B
  ; from : B -> A
  ; to_from : forall b, to (from b) = b
  ; from_to : forall a, from (to a) = a
  }.

Theorem cantor :
  bijection nat (nat -> nat) ->
  False.
Proof.
  destruct 1 as [seq index ? ?].
  (* define a function which differs from the nth sequence at the nth index *)
  pose (f := fun n => S (seq n n)).
  (* prove f differs from every sequence *)
  assert (forall n, f <> seq n). {
    unfold not; intros.
    assert (f n = seq n n) by congruence.
    subst f; cbn in H0.
    eapply n_Sn; eauto.
  }
  rewrite <- (to_from0 f) in H.
  apply (H (index f)).
  reflexivity.
Qed.

Print cantor.

Theorem cator_02 : (bijection nat (nat -> nat)) -> False.
Proof.
exact (
  fun H : bijection nat (nat -> nat) =>
  match H with
  | {| to := to; from := from; to_from := to_from; from_to := from_to |} =>
    (fun (seq : nat -> nat -> nat) (index : (nat -> nat) -> nat)
         (to_from0 : forall b : nat -> nat, seq (index b) = b)
         (_ : forall a : nat, index (seq a) = a) =>
       let f := fun n : nat => S (seq n n) in
       let H0 : forall n : nat, f <> seq n :=
         (fun (n : nat) (H0 : f = seq n) =>
          let H1 : f n = seq n n :=
            eq_trans (f_equal (fun f0 : nat -> nat => f0 n) H0)
              (f_equal (seq n) eq_refl) in
          n_Sn (seq n n) (eq_sym H1))
          :
          forall n : nat, f <> seq n in
        let H1 : forall n : nat, seq (index f) <> seq n :=
          eq_ind_r (fun f0 : nat -> nat => forall n : nat, f0 <> seq n) H0
            (to_from0 f) in
        H1 (index f) eq_refl) to from to_from from_to
   end
).
Qed.

(*http://us.metamath.org/ileuni/adantl.html*)
(* ⊢ (𝜑 → 𝜓) *)
(* -----------*)
(* ⊢ ((𝜒 ∧ 𝜑) → 𝜓) *)
Theorem adanl:forall P Q R:Prop, (Q -> R) -> ((P /\ Q) -> R).
Proof.
  intros P Q R.
  intros H0.
  intros H1.
  apply H0.
  destruct H1.
  trivial.
Qed.

Print adanl.

Theorem adanl_01:forall P Q R:Prop, (Q -> R) -> ((P /\ Q) -> R).
Proof.
  exact (
    fun (P Q R : Prop) (H0 : Q -> R) (H1 : P /\ Q) =>
    H0 match H1 with
       | conj x x0 => (fun (_ : P) (H2 : Q) => H2) x x0
       end
  ).
Qed.

(* http://us.metamath.org/ileuni/adantld.html *)
(* ⊢ (𝜑 → (𝜓 → 𝜒))  *)
(* ----------------- *)
(* ⊢ (𝜑 → ((𝜃 ∧ 𝜓) → 𝜒)) *)
Theorem adantld:forall P Q R S:Prop,(P -> (R -> S)) -> (P -> ((Q /\ R) -> S)).
Proof.
  intros P Q R S.
  intros H0.
  intros H1.
  intros H2.
  apply H0.
  exact H1.
  destruct H2.
  trivial.
Qed.

Print adantld.

Theorem adantld_02:forall P Q R S:Prop,(P -> (R -> S)) -> (P -> ((Q /\ R) -> S)).
Proof.
  exact (
    fun (P Q R S : Prop) (H0 : P -> R -> S) (H1 : P) (H2 : Q /\ R) =>
    H0 H1 match H2 with
        | conj x x0 => (fun (_ : Q) (H3 : R) => H3) x x0
          end
  ).
Qed.

(* http://us.metamath.org/ileuni/adantrd.html *)
(* ⊢ (𝜑 → (𝜓 → 𝜒)) *)
(* ---------------- *)
(* ⊢ (𝜑 → ((𝜓 ∧ 𝜃) → 𝜒)) *)
Theorem adantrd:forall P Q R S:Prop,(P -> (Q -> S)) -> (P -> ((Q /\ R) -> S)).
Proof.
  intros P Q R S;intros H0;intros H1;intros H2.
  apply H0.
  exact H1.
  destruct H2.
  trivial.
Qed.

Print adantrd.

Theorem adantrd_02:forall P Q R S:Prop,(P -> (Q -> S)) -> (P -> ((Q /\ R) -> S)).
Proof.
  exact (
    fun (P Q R S : Prop) (H0 : P -> Q -> S) (H1 : P) (H2 : Q /\ R) =>
    H0 H1 match H2 with
        | conj x x0 => (fun (H : Q) (_ : R) => H) x x0
          end
  ).
Qed.

(* http://us.metamath.org/ileuni/impel.html *)
(* ⊢ (P → (Q → S)) *)
(* ⊢ (R → Q) *)
(* ------------------*)
(* ⊢ ((P ∧ R) → S) *)
Theorem impel:forall P Q R S:Prop,((P -> (Q -> S)) /\ (R -> Q)) -> ((P /\ R) -> S).
Proof.
  intros P Q R S.
  intros H0.
  intros H1.
  destruct H0.
  apply H.
  destruct H1.
  exact H1.
  apply H0.
  destruct H1.
  trivial.
Qed.

Print impel.

Theorem impel2:forall P Q R S:Prop,((P -> (Q -> S)) /\ (R -> Q)) -> ((P /\ R) -> S).
Proof.
  exact (
    fun (P Q R S : Prop) (H0 : (P -> Q -> S) /\ (R -> Q)) (H1 : P /\ R) =>
    match H0 with
    | conj x x0 =>
      (fun (H : P -> Q -> S) (H2 : R -> Q) =>
         H match H1 with
           | conj x1 x2 => (fun (H3 : P) (_ : R) => H3) x1 x2
           end
           (H2
              match H1 with
              | conj x1 x2 => (fun (_ : P) (H4 : R) => H4) x1 x2
              end)) x x0
    end
  ).
Qed.

(* http://us.metamath.org/ileuni/mpan9.html *)
(* ⊢ (P → R) *)
(* ⊢ (Q → (R → S)) *)
(* --------------- *)
(* ⊢ ((P ∧ Q) → S) *)
Theorem mpan9:forall P Q R S:Prop,((P -> R) /\ (Q -> (R -> S))) -> ((P /\ Q) -> S).
Proof.
  intros P Q R S.
  intros H0.
  intros H1.
  destruct H0.
  apply H0.
  destruct H1.
  exact H2.
  apply H.
  destruct H1.
  trivial.
Qed.

Print mpan9.

Theorem mpan9_01:forall P Q R S:Prop,((P -> R) /\ (Q -> (R -> S))) -> ((P /\ Q) -> S).
Proof.
  exact (
    fun (P Q R S : Prop) (H0 : (P -> R) /\ (Q -> R -> S)) (H1 : P /\ Q) =>
      match H0 with
      | conj x x0 =>
        (fun (H : P -> R) (H2 : Q -> R -> S) =>
          H2 match H1 with
              | conj x1 x2 => (fun (_ : P) (H4 : Q) => H4) x1 x2
              end
            (H
                match H1 with
                | conj x1 x2 => (fun (H3 : P) (_ : Q) => H3) x1 x2
                end)) x x0
      end
  ).
Qed.

(* http://us.metamath.org/ileuni/syldan.html *)
(* ⊢ ((P ∧ Q) → R) *)
(* ⊢ ((P ∧ R) → S) *)
(* ---------------- *)
(* ⊢ ((P ∧ Q) → S) *)
Theorem syldan:forall P Q R S:Prop,(((P /\ Q) -> R) /\ ((P /\ R) -> S)) -> ((P /\ Q) -> S).
Proof.
  intros P Q R S.
  intros H0.
  intros H1.
  destruct H0.
  apply H0.
  split.
  destruct H1.
  exact H1.
  apply H.
  trivial.
Qed.

Print syldan.

Theorem syldan_02:forall P Q R S:Prop,(((P /\ Q) -> R) /\ ((P /\ R) -> S)) -> ((P /\ Q) -> S).
Proof.
  exact (
    fun (P Q R S : Prop) (H0 : (P /\ Q -> R) /\ (P /\ R -> S)) (H1 : P /\ Q) =>
    match H0 with
    | conj x x0 =>
      (fun (H : P /\ Q -> R) (H2 : P /\ R -> S) =>
         H2
           (conj
              match H1 with
              | conj x1 x2 => (fun (H3 : P) (_ : Q) => H3) x1 x2
              end (H H1))) x x0
    end
  ).
Qed.

(* http://us.metamath.org/ileuni/sylan.html *)
(* ⊢ (P → Q) *)
(* ⊢ ((Q ∧ R) → S) *)
(* ---------------- *)
(* ⊢ ((P ∧ R) → S) *)
Theorem sylan:forall P Q R S:Prop,
  ((P -> Q) /\ ((Q /\ R) -> S)) -> ((P /\ R) -> S).
Proof.
  intros P Q R S.
  intros H0;intros H1.
  destruct H0.
  apply H0.
  split.
  apply H.
  destruct H1.
  exact H1.
  destruct H1.
  trivial.
Qed.

Print sylan.

Theorem sylan_02:forall P Q R S:Prop,
  ((P -> Q) /\ ((Q /\ R) -> S)) -> ((P /\ R) -> S).
Proof.
  exact (
    fun (P Q R S : Prop) (H0 : (P -> Q) /\ (Q /\ R -> S)) (H1 : P /\ R) =>
    match H0 with
    | conj x x0 =>
      (fun (H : P -> Q) (H2 : Q /\ R -> S) =>
         H2
           (conj
              (H
                 match H1 with
                 | conj x1 x2 => (fun (H3 : P) (_ : R) => H3) x1 x2
                 end)
              match H1 with
              | conj x1 x2 => (fun (_ : P) (H4 : R) => H4) x1 x2
              end)) x x0
    end
  ).
Qed.

(* http://us.metamath.org/ileuni/sylanb.html *)
(* ⊢ (P ↔ Q) *)
(* ⊢ ((Q ∧ R) → S) *)
(* ---------------- *)
(* ⊢ ((P ∧ R) → S) *)
Theorem sylanb:
  forall P Q R S:Prop,
  ((P <-> Q) /\
  ((Q /\ R) -> S))
  -> ((P /\ R) -> S).
Proof.
  intros P Q R S.
  intros H0; intros H1.
  destruct H0.
  apply H0.
  split.
  destruct H as (H2 & H3).
  apply H2.
  destruct H1 as (H4 & H5).
  exact H4.
  destruct H1 as (H4 & H5).
  trivial.
Qed.

(* http://us.metamath.org/ileuni/sylanbr.html *)
(* ⊢ (P ↔ Q) *)
(* ⊢ ((P ∧ R) → S) *)
(* ---------------- *)
(* ⊢ ((Q ∧ R) → S) *)
Theorem sylanbr:forall P Q R S:Prop,
  ((P <-> Q) /\
   ((P /\ Q) -> S)) ->
  ((Q /\ R) -> S).
Proof.
  intros P Q R S.
  intros H0 H1.
  destruct H0 as (H2 & H3).
  apply H3.
  split.
  destruct H2 as (H4 & H5).
  apply H5.
  destruct H1 as (H6 & H7).
  trivial.
  destruct H1 as (H6 & H7).
  trivial.
Qed.

Print sylanbr.

Theorem sylanbr_02:forall P Q R S:Prop,
  ((P <-> Q) /\
   ((P /\ Q) -> S)) ->
  ((Q /\ R) -> S).
Proof.
  exact (
    fun (P Q R S : Prop) (H0 : (P <-> Q) /\ (P /\ Q -> S)) (H1 : Q /\ R) =>
    match H0 with
    | conj x x0 =>
      (fun (H2 : P <-> Q) (H3 : P /\ Q -> S) =>
         H3
           (conj
              match H2 with
              | conj x1 x2 =>
                  (fun (_ : P -> Q) (H5 : Q -> P) =>
                   H5
                     match H1 with
                     | conj x3 x4 => (fun (H6 : Q) (_ : R) => H6) x3 x4
                     end) x1 x2
              end
              match H1 with
              | conj x1 x2 => (fun (H6 : Q) (_ : R) => H6) x1 x2
              end)) x x0
    end
  ).
Qed.

(* http://us.metamath.org/ileuni/sylan2.html *)
(* ⊢ (P → Q) *)
(* ⊢ ((R ∧ Q) → S) *)
(* ---------------- *)
(* ⊢ ((R ∧ P) → S) *)
Theorem sylan2:forall P Q R S:Prop,
    ((P -> Q) /\
     ((R /\ Q) -> S)) ->
    ((R /\ P) -> S).
Proof.
  intros P Q R S.
  intros H0 H1.
  destruct H0 as (H2 & H3).
  apply H3.
  split.
  destruct H1 as (H4 & H5).
  trivial.
  apply H2.
  destruct H1 as (H4 & H5).
  exact H5.
Qed.

Print sylan2.

Theorem sylan2_02:forall P Q R S:Prop,
    ((P -> Q) /\
     ((R /\ Q) -> S)) ->
    ((R /\ P) -> S).
Proof.
  exact (
    fun (P Q R S : Prop) (H0 : (P -> Q) /\ (R /\ Q -> S)) (H1 : R /\ P) =>
    match H0 with
    | conj x x0 =>
      (fun (H2 : P -> Q) (H3 : R /\ Q -> S) =>
         H3
           (conj
              match H1 with
              | conj x1 x2 => (fun (H4 : R) (_ : P) => H4) x1 x2
              end
              (H2
                 match H1 with
                 | conj x1 x2 => (fun (_ : R) (H5 : P) => H5) x1 x2
                 end))) x x0
    end
  ).
Qed.

(* http://us.metamath.org/ileuni/sylan2b.html *)
(* ⊢ (P ↔ Q) *)
(* ⊢ ((R ∧ Q) → S) *)
(* ---------------- *)
(* ⊢ ((R ∧ P) → S) *)
Theorem sylan2b:forall P Q R S:Prop,
   ((P <-> Q) /\
    ((R /\ Q) -> S)) ->
   ((R /\ P) -> S).
Proof.
  intros P Q R S.
  intros H0 H1.
  destruct H0 as (H2 & H3).
  apply H3.
  destruct H2 as (H4 & H5).
  split.
  destruct H1 as (H6 & H7).
  exact H6.
  apply H4.
  destruct H1 as (H6 & H7).
  exact H7.
Qed.

Print sylan2b.

Theorem sylan2b_02:forall P Q R S:Prop,
   ((P <-> Q) /\
    ((R /\ Q) -> S)) ->
   ((R /\ P) -> S).
Proof.
  exact (
    fun (P Q R S : Prop) (H0 : (P <-> Q) /\ (R /\ Q -> S)) (H1 : R /\ P) =>
    match H0 with
    | conj x x0 =>
      (fun (H2 : P <-> Q) (H3 : R /\ Q -> S) =>
         H3
           match H2 with
           | conj x1 x2 =>
               (fun (H4 : P -> Q) (_ : Q -> P) =>
                conj
                  match H1 with
                  | conj x3 x4 => (fun (H6 : R) (_ : P) => H6) x3 x4
                  end
                  (H4
                     match H1 with
                     | conj x3 x4 => (fun (_ : R) (H7 : P) => H7) x3 x4
                     end)) x1 x2
           end) x x0
    end
  ).
Qed.

(* http://us.metamath.org/ileuni/sylan2br.html *)
(* ⊢ (P ↔ Q) *)
(* ⊢ ((R ∧ P) → S) *)
(* ---------------- *)
(* ⊢ ((R ∧ Q) → S) *)
Theorem sylan2br:forall P Q R S:Prop,
   ((P <-> Q) /\
    ((R /\ P) -> S)) ->
   ((R /\ Q) -> S).
Proof.
  intros P Q R S.
  intros H0 H1.
  destruct H0 as (H2 & H3).
  apply H3.
  split.
  destruct H1 as (H4 & H5).
  exact H4.
  destruct H2 as (H6 & H7).
  apply H7.
  destruct H1 as (H4 & H5).
  trivial.
Qed.

Print sylan2br.

Theorem sylan2br_01:forall P Q R S:Prop,
   ((P <-> Q) /\
    ((R /\ P) -> S)) ->
   ((R /\ Q) -> S).
Proof.
  exact (
    fun (P Q R S : Prop) (H0 : (P <-> Q) /\ (R /\ P -> S)) (H1 : R /\ Q) =>
    match H0 with
    | conj x x0 =>
      (fun (H2 : P <-> Q) (H3 : R /\ P -> S) =>
         H3
           (conj
              match H1 with
              | conj x1 x2 => (fun (H4 : R) (_ : Q) => H4) x1 x2
              end
              match H2 with
              | conj x1 x2 =>
                  (fun (_ : P -> Q) (H7 : Q -> P) =>
                   H7
                     match H1 with
                     | conj x3 x4 => (fun (_ : R) (H5 : Q) => H5) x3 x4
                     end) x1 x2
              end)) x x0
    end
  ).
Qed.

Print prod.
(*
Inductive prod (A B : Type) : Type :=
   pair : A -> B -> A * B.
*)

Definition add1 : nat -> nat.
intro n.
Show Proof.
apply S.
Show Proof.
apply n. Defined.
Print add1.

(*
From ReductionEffect Require Import PrintingEffect.
Eval cbv in (fun f x => f (f (f x))) (fun x => S (print_id x)) 0.
Eval cbn in (fun f x => f (f (f x))) print_id 0. (* Not so interesting *)
Eval hnf in (fun f x => f (f (f x))) print_id 0. (* Not so interesting *)
Eval simpl in (fun f x => f (f (f x))) (fun x => print_id (1+x) + 1) 0.
Eval cbv in let x := print 3 in let y := print 4 in tt.
*)
Module NatPlayground2.
Fixpoint plus (n : nat) (m : nat) : nat :=
  match n with
  | O => m
  | S n' => S (plus n' m)
  end.

(*
  Eval cbv in (fun f x => (plus 3 2)) (fun x => S (print_id x)) 0.

  End NatPlayground2.
*)
(* detour with https://softwarefoundations.cis.upenn.edu/*)

Inductive day : Type :=
  | monday
  | tuesday
  | wednesday
  | thursday
  | friday
  | saturday
  | sunday.

Definition next_weekday (d:day) : day :=
  match d with
  | monday => tuesday
  | tuesday => wednesday
  | wednesday => thursday
  | thursday => friday
  | friday => monday
  | saturday => monday
  | sunday => monday
  end.

Theorem plus_0_n : forall n : nat,0 + n = n.
Proof.
  intros n.
  simpl.
  reflexivity.
Qed.

Print plus_0_n.

Theorem plus_0_n_02 : forall n : nat,0 + n = n.
Proof.
  exact (
    fun n : nat => eq_refl : 0 + n = n
  ).
Qed.

Theorem plus_O_n' : forall n : nat, 0 + n = n.
Proof.
  intros n. reflexivity. Qed.

Theorem plus_1_l : forall n:nat, 1 + n = S n.
Proof.
    intros n. simpl. reflexivity. Qed.

Theorem mult_0_l : forall n:nat, 0 * n = 0.
  Proof.
    intros n. simpl. reflexivity. Qed.

Theorem plus_2_2_is_4 : 2 + 2 = 4.
Proof.
  reflexivity.
Qed.

Definition plus_claim : Prop := 2 + 2 = 4.
Check plus_claim : Prop.

Theorem plus_claim_is_true : plus_claim.
Proof. reflexivity. Qed.

Definition is_three (n : nat) : Prop :=
  n = 3.
Check is_three : nat -> Prop.

Check @eq : forall A : Type, A -> A -> Prop.

Definition injective {A B} (f : A -> B) :=
  forall x y : A, f x = f y -> x = y.
Lemma succ_inj : injective S.
Proof.
  intros n m H.
  injection H as H1.
  apply H1.
Qed.

Example and_example : 3 + 4 = 7 /\ 2 * 2 = 4.
Proof.
  split.
  Show Proof.
  - reflexivity.
  Show Proof.
  - reflexivity.
  Show Proof.
Qed.

Print and_example.
Print conj.

Lemma and_intro : forall A B : Prop, A -> B -> A /\ B.
Proof.
  intros A B HA HB. split.
  - apply HA.
  - apply HB.
Qed.

Print and_intro.

Example and_example' : 3 + 4 = 7 /\ 2 * 2 = 4.
Proof.
  apply and_intro.
  - (* 3 + 4 = 7 *) reflexivity.
  - (* 2 + 2 = 4 *) reflexivity.
Qed.

Example and_exercise :
  forall n m : nat, n + m = 0 -> n = 0 /\ m = 0.
Proof.
  intros m n.
  induction m.
  split.
  - reflexivity.
  - apply H.
  - intros H0.
Abort.

Theorem add_0_r_firsttry : forall n:nat, n + 0 = n.
Proof.
  intros n.
  simpl.
Abort.

Theorem add_0_r_secondtry : forall n:nat,n + 0 = n.
Proof.
  intros n.
  Show Proof.
  destruct n as [| n'] eqn:E.
  Show Proof.
  - reflexivity.
  Show Proof.
  - simpl.
  Show Proof.
Abort.

Theorem add_0_r : forall n:nat, n + 0 = n.
Proof.
  intros n.
  induction n as [| n' IHn'].
  - (* n = 0 *)
  {
    simpl.
    reflexivity.
  }
  - { (* n = S n' *)
    Show Proof.
    simpl.
    Show Proof.
    rewrite -> IHn'.
    Show Proof.
    reflexivity.
    Show Proof.
  }
Qed.
Print eq_ind_r.
Print add_0_r.
Print nat_ind.
Check (fun n : nat =>
nat_ind (fun n0 : nat => n0 + 0 = n0) (eq_refl : 0 + 0 = 0)
  (fun (n' : nat) (IHn' : n' + 0 = n') =>
   eq_ind_r (fun n0 : nat => S n0 = S n') eq_refl IHn' : S n' + 0 = S n') n).
Check eq_ind_r.
   Check fun n' => S (n' + 0) = S n'.
Check fun (n : nat) (n' : nat) (IHn' : n' + 0 = n) => eq_refl IHn'.

Section eq_ind_r_proof.
   Hypothesis n' : nat.
   Hypothesis n : nat.
   Hypothesis IHn' : n' + 0 = n'.
   Print eq_ind_r.
   Check (fun n0: nat => S n0 = S n').
   Check eq_ind_r.
   Check (fun x:nat => x = x).
   Check eq_ind_r (fun x:nat => x = x).
   Check eq_ind_r (fun n0: nat => S n0 = S n').
   Check eq_ind_r (fun n0: nat => S n0 = S n') eq_refl.
   Check eq_ind_r (fun n0: nat => S n0 = S n') eq_refl IHn'.
   Definition f := eq_ind_r (fun n0: nat => S n0 = S n') eq_refl IHn'.
   Print f.
End eq_ind_r_proof.

Theorem minus_n_n : forall n,
  minus n n = 0.
Proof.
  (* WORKED IN CLASS *)
  intros n.
  induction n as [| n' IHn'].
  - (* n = 0 *)
    simpl. reflexivity.
  - (* n = S n' *)
    simpl. rewrite -> IHn'. reflexivity.
  Qed.

Theorem mul_0_r : forall n:nat,
  n * 0 = 0.
Proof.
  intros n.
  induction n as [| n' IHn'].
  - (* n = 0 *)
    simpl.
    reflexivity.
  - (* n = S n' *)
    simpl.
    rewrite -> IHn'.
    reflexivity.
Qed.

Theorem plus_n_Sm : forall n m : nat,
  S (n + m) = n + (S m).
Proof.
  intros n m.
  induction n as [| n' IHn'].
  - (* n = 0 *)
    simpl.
    reflexivity.
  - (* n = S n*)
    simpl.
    rewrite -> IHn'.
    reflexivity.
Qed.

Theorem add_comm : forall n m : nat,
  n + m = m + n.
Proof.
  intros n m.
  induction n as [| n' IHn'].
  -
  {
    simpl.
    rewrite -> add_0_r.
    reflexivity.
  }
  -
  {
    simpl.
    rewrite -> IHn'.
    rewrite -> plus_n_Sm.
    reflexivity.
  }
Qed.
Print add_comm.

Theorem add_assoc : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof.
  intros n m p.
  induction n as [| n' IHn'].
  - {
    simpl.
    reflexivity.
  }
  - {
    simpl.
    rewrite -> IHn'.
    reflexivity.
  }
Qed.
Print add_assoc.

Theorem plus_O_n : forall n : nat, 0 + n = n.
Proof.
  intros n. simpl. reflexivity. Qed.

Theorem plus_id_example : forall n m:nat,
  n = m ->
  n + n = m + m.
Proof.
  intros n m H.
  rewrite <- H.
  reflexivity.
Qed.

(* SOOMER: KK: plus_id_exercise contains multiple hypotheses, and at
   least one student was confused about this. Maybe we can talk about
   → being right-associative before it. *)
Theorem plus_id_exercise : forall n m o : nat,
   n = m -> m = o -> n + m = m + o.
Proof.
  intros m n o H0 H1.
  rewrite -> H0.
  rewrite -> H1.
  reflexivity.
Qed.

Check mult_n_O.
Check mult_n_Sm.

Theorem mult_n_0_m_0 : forall p q : nat,
  (p * 0) + (q * 0) = 0.
Proof.
  intros p q.
  repeat rewrite <- mult_n_O.
  simpl.
  reflexivity.
Qed.
Print mult_n_0_m_0.

Theorem mult_n_1 : forall p : nat,
  p * 1 = p.
Proof.
  intros p.
  Check mult_n_Sm.
  Check mult_n_O.
  rewrite <- mult_n_Sm.
  rewrite <- mult_n_O.
  simpl.
  reflexivity.
Qed.

Inductive bool : Type :=
  | true
  | false.

Definition negb (b:bool) : bool :=
    match b with
    | true => false
    | false => true
    end.

Definition andb (b1:bool) (b2:bool) : bool :=
    match b1 with
    | true => b2
    | false => false
    end.

Definition orb (b1:bool) (b2:bool) : bool :=
    match b1 with
    | true => true
    | false => b2
    end.

Notation "x && y" := (andb x y).
Notation "x || y" := (orb x y).

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

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

Notation "x =? y" := (eqb x y) (at level 70) : nat_scope.
Notation "x <=? y" := (leb x y) (at level 70) : nat_scope.

Theorem plus_1_neq_0_firsttry : forall n : nat,
  (n + 1) =? 0 = false.
Proof.
  intros n.
  simpl. (* does nothing! *)
Abort.

Theorem plus_1_neq_0 : forall n : nat,
  (n + 1) =? 0 = false.
Proof.
  intros n.
  destruct n as [| n'] eqn:E.
   - {
    simpl.
    reflexivity.
   }
   - {
    simpl.
    reflexivity.
   }
Qed.

Theorem negb_involutive : forall b : bool,
  negb (negb b) = b.
Proof.
  intros b.
  destruct b eqn:E.
  - {
    simpl.
    reflexivity.
  }
  - {
    simpl.
    reflexivity.
  }
Qed.

Theorem andb_commutative : forall b c, andb b c = andb c b.
Proof.
  intros b c.
  destruct b eqn:Eb.
  - {
    destruct c eqn:Ec.
    + {
      simpl.
      reflexivity.
    }
    + {
      simpl.
      reflexivity.
    }
  }
  - {
    destruct c eqn:Ec.
    + {
      simpl.
      reflexivity.
    }
    + {
      simpl.
      reflexivity.
    }
  }
Qed.

Theorem andb3_exchange :
  forall b c d, andb (andb b c) d = andb (andb b d) c.
Proof.
  intros b c d.
  destruct b eqn:Eb.
  - {
    destruct c eqn:Ec.
    + {
      destruct d eqn:Ed.
      * {
        simpl.
        reflexivity.
      }
      * {
        simpl.
        reflexivity.
      }
    }
    + {
      destruct d eqn:Ed.
      * {
        simpl.
        reflexivity.
      }
      * {
        simpl.
        reflexivity.
      }
    }
  }
  - {
    destruct c eqn:Ec.
    + {
      destruct d eqn:Ed.
      * {
        simpl.
        reflexivity.
      }
      * {
        simpl.
        reflexivity.
      }
    }
    + {
      destruct d eqn:Ed.
      * {
        simpl.
        reflexivity.
      }
      * {
        simpl.
        reflexivity.
      }
    }
  }
Qed.

(* http://us.metamath.org/ileuni/sylan2br.html *)
(*
  ⊢ (P → Q)
  ⊢ (R → S)
  ⊢ ((Q ∧ S) → T)
  ----------------
  ⊢ ((P ∧ R) → T)
*)
Theorem sylan2br2 : forall P Q R S T:Prop,
  ((P -> Q) /\
   (R -> S) /\
   ((Q /\ S) -> T)) ->
  ((P /\ R) -> T).
Proof.
  intros P Q R S T.
  intros H0 H1.
  destruct H0.
  destruct H0.
  apply H2.
  split.
  apply H.
  destruct H1.
  exact H1.
  apply H0.
  destruct H1.
  exact H3.
Qed.

(* https://us.metamath.org/ileuni/syl2anr.html *)
(*
  ⊢ (P → Q)
  ⊢ (R → S)
  ⊢ ((Q ∧ S) → T)
  ----------------
  ⊢ ((R ∧ P) → T)
*)
Theorem syl2anr: forall P Q R S T:Prop,
  (
    (P -> Q) /\
    (R -> S) /\
    ((Q /\ S) -> T)
  ) ->
  (
    (R /\ P) -> T
  ).
Proof.
  intros P Q R S T H0 H1.
  destruct H0 as [H2 H3].
  destruct H3 as [H4 H5].
  destruct H1 as [H6 H7].
  apply H5.
  split.
  apply H2.
  exact H7.
  apply H4.
  exact H6.
Qed.

(*
   https://us.metamath.org/ileuni/syl2anb.html
   ⊢ (P <-> Q)
   ⊢ (R <-> S)
   ⊢ ((Q ∧ S) → T)
  -----------------
   ⊢ ((P ∧ R) → T)
*)
Theorem syl2anb3 : forall P Q R S T:Prop,
(
  (P <-> Q) /\
  (R <-> S) /\
  ((Q /\ S) -> T)
)
  ->
(
  ((P /\ R) -> T)
).
Proof.
  intros P Q R S T H0 H1.
  destruct H0 as [H2 H3].
  destruct H3 as [H4 H5].
  apply H5.
  split.
  apply H2.
  destruct H1 as [H6 H7].
  exact H6.
  apply H4.
  destruct H1 as [H6 H7].
  exact H7.
Qed.

(*
  https://us.metamath.org/ileuni/syl2anbr.html]
  ⊢ (P ↔ Q)
  ⊢ (R ↔ S)
  ⊢ ((P ∧ R) → T)
  ----------------
  ⊢ ((Q ∧ S) → T)
*)
Theorem syl2andbr: forall P Q R S T:Prop,
(
  (P <-> Q) /\
  (R <-> S) /\
  ((P /\ R) -> T)
) -> (
  ((Q /\ S) -> T)
).
Proof.
  intros P Q R S T H0 H1.
  destruct H0 as [H2 H3].
  destruct H3 as [H4 H5].
  destruct H1 as [H6 H7].
  apply H5.
  split.
  apply H2.
  exact H6.
  apply H4.
  exact H7.
Qed.

(*
  https://us.metamath.org/ileuni/syland.html
  ⊢ (P → (Q → R))
  ⊢ (P → ((R ∧ S) → T))
  ----------------------
  ⊢ (P → ((Q ∧ S) → T))
*)
Theorem syland : forall P Q R S T:Prop,
(
   (P -> (Q -> R)) /\
   (P -> ((R /\ S) -> T))
)
  ->
(
   (P -> ((Q /\ S) -> T))
).
Proof.
  intros P Q R S T H0 H1 H2.
  destruct H0 as [H3 H4].
  destruct H2 as [H5 H6].
  apply H4.
  apply H1.
  split.
  apply H3.
  exact H1.
  exact H5.
  exact H6.
Qed.

(*
   https://us.metamath.org/ileuni/sylan2d.html
   ⊢ (P → (Q → S))
   ⊢ (P → ((R ∧ S) → T))
   ----------------------
   ⊢ (P → ((R ∧ Q) → T))
*)
Theorem sylan2d : forall P Q R S T:Prop,
(
  (P -> (Q -> S)) /\
  (P -> ((R /\ S) -> T))
) -> (
  (P -> ((R /\ Q) -> T))
).
Proof.
  intros P Q R S T H0 H1 H2.
  destruct H0 as [H3 H4].
  destruct H2 as [H5 H6].
  apply H4.
  exact H1.
  split.
  exact H5.
  apply H3.
  exact H1.
  exact H6.
Qed.

(*
   https://us.metamath.org/ileuni/syl2and.html
   ⊢ (P → (Q → R))
   ⊢ (P → (S → T))
   ⊢ (P → ((R ∧ T) → U))
   ----------------------
   ⊢ (P → ((Q ∧ S) → U))
*)
Theorem syl2and : forall P Q R S T U:Prop,
(
  (P -> (Q -> R)) /\
  (P -> (S -> T)) /\
  (P -> ((R /\ T) -> U))
) -> (
  (P -> ((Q /\ S) -> U))
).
Proof.
  intros P Q R S T U H0 H1 H2.
  destruct H0 as [H3 H4].
  destruct H2 as [H6 H7].
  destruct H4 as [H8 H9].
  apply H9.
  exact H1.
  split.
  apply H3.
  exact H1.
  exact H6.
  apply H8.
  exact H1.
  exact H7.
Qed.

(*
  https://us.metamath.org/ileuni/biimpa.html
  ⊢ (P → (Q ↔ R))
  ----------------------
  ⊢ ((P ∧ Q) → R)
*)
Theorem biimpa : forall P Q R:Prop,
(
  P -> (Q <-> R)
) -> (
  (P /\ Q) -> R
).
Proof.
  intros P Q R H0 H1.
  destruct H1 as [H2 H3].
  apply H0.
  exact H2.
  exact H3.
Qed.

(*
https://us.metamath.org/ileuni/biimpar.html
⊢ (P → (Q ↔ R))
----------------
⊢ ((P ∧ R) → Q)
*)
Theorem biimpar: forall P Q R:Prop,
(
  (P -> (Q <-> R))
) -> (
  ((P /\ R) -> Q)
).
Proof.
  intros P Q R.
  intros H0.
  intros H1.
  destruct H0.
  destruct H1.
  exact H.
  apply H0.
  destruct H1.
  exact H2.
Qed.

Print biimpar.

(*
https://us.metamath.org/ileuni/biimpac.html
⊢ (P → (Q ↔ R))
----------------
⊢ ((Q ∧ P) → R)
*)
Theorem biimpac : forall P Q R:Prop,
(
  (P -> (Q <-> R))
) -> (
  ((Q /\ P) -> R)
).
Proof.
  intros P Q R H0 H1.
  apply H0.
  destruct H1 as [H2 H3].
  exact H3.
  destruct H1 as [H2 H3].
  exact H2.
Qed.

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
  (* WORKED IN CLASS *)
  intros P contra.
  destruct contra.
Qed.

Theorem double_neg : forall P : Prop,
  P -> ~~P.
Proof.
  (* WORKED IN CLASS *)
  intros P H. unfold not. intros G. apply G. apply H. Qed.

(*
https://us.metamath.org/ileuni/ax-in1.html
  ⊢ ((P → ¬P) → ¬P)
*)
Theorem ax_in1 : forall P:Prop,
(
  (P -> ~P)
) -> (
  ~P
).
Proof.
  Show Proof.
  intros P H0.
  Show Proof.
  intros H1.
  Show Proof.
  apply H0.
  Show Proof.
  exact H1.
  Show Proof.
  exact H1.
  Show Proof.
Qed.

Print ax_in1.

Section ax_in1_section.
  Hypothesis P : Prop.
  Hypothesis H0 : P -> ~P.
  Hypothesis H1 : P.
  Definition H2 := (fun H1 => H0 H1 H1).
  Print H2.
  Check H0.
  Check H0 H1.
  Check H0 H1 H1.
  Check (fun H1 => H0 H1 H1).
End ax_in1_section.

Theorem and_elim1 : forall P Q:Prop,
(
  (P /\ Q)
) -> (
  P
).
Proof.
  Show Proof.
  intros P.
  Show Proof.
  intros Q.
  Show Proof.
  intros H0.
  Show Proof.
  destruct H0.
  Show Proof.
  apply H.
  Show Proof.
Qed.

Print and_elim1.
Print conj.

Section conj_explore.
  Hypothesis P : Prop.
  Hypothesis Q : Prop.
  Hypothesis H : P.
  Hypothesis H0 : P /\ Q.
  Check match H0 with
        | conj x x0 => (fun (H : P) (_ : Q) => H) x x0
        end.
  Check match H0 with
        | conj x x0 => conj x0 x
        end.
  Check conj H _.
  Check conj H.
End conj_explore.

Theorem law_of_contradiction : forall (P Q : Prop),
  P /\ ~P -> Q.
Proof.
  Show Proof.
  intros P Q P_and_not_P.
  Show Proof.
  destruct P_and_not_P as [P_holds not_P].
  Show Proof.
  contradiction.
  Show Proof.
Qed.

(*
https://us.metamath.org/ileuni/ax-in2.html
Description: 'Not' elimination
⊢ (¬ P → (P → Q))
*)
Theorem ax_in2 : forall P Q:Prop,
(
  (~P)
  ->
  (P -> Q)
).
Proof.
  Show Proof.
  intros P Q.
  Show Proof.
  intros H0 H1.
  Show Proof.
  contradiction.
  Show Proof.
Qed.
Print ax_in2.

Check False_ind.

Section contra_explore.
  Hypothesis P : Prop.
  Hypothesis Q : Prop.
  Hypothesis H0 : P.
  Hypothesis H1 : ~P.
  Check False_ind.
  Check False_ind P.
  Check (H1 H0).
  Check False_ind P (H1 H0).
End contra_explore.

(*
https://us.metamath.org/ileuni/pm2.01.html
⊢ ((P → ¬P) → ¬P)
*)
Theorem pm2_01 : forall P:Prop,
(
  (P -> ~P)
) -> (
  ~P
).
Proof.
  Show Proof.
  intros P.
  Show Proof.
  intros H0.
  Show Proof.
  intros H1.
  Show Proof.
  apply H0.
  Show Proof.
  exact H1.
  Show Proof.
  exact H1.
  Show Proof.
Qed.

(*
https://us.metamath.org/ileuni/pm2.21.html
⊢ (¬ P → (P → Q))
*)
Theorem pm2_21 : forall P Q : Prop,
(
  ~P
) -> (
  P -> Q
).
Proof.
  Show Proof.
  intros P Q.
  Show Proof.
  intros H0.
  Show Proof.
  intros H1.
  Show Proof.
  contradiction.
  Show Proof.
Qed.
Check pm2_21.

Section contra_explore2.
  Hypothesis P : Prop.
  Hypothesis Q : Prop.
  Hypothesis H0 : ~P.
  Hypothesis H1 : P.
  Check False_ind.
  Check False_ind Q.
  Check (H0 H1).
  Check False_ind Q (H0 H1).
End contra_explore2.

(*
https://us.metamath.org/ileuni/pm2.01d.html
⊢ (P → (Q → ¬Q))
------------------
⊢ (P → ¬Q)
*)
Theorem pm2_01d : forall P Q:Prop,
(
  (P -> (Q -> ~Q))
) -> (
  (P -> ~Q)
).
Proof.
  Show Proof.
  intros P Q.
  Show Proof.
  intros H0.
  Show Proof.
  intros H1.
  Show Proof.
  intros H2.
  Show Proof.
  apply H0.
  Show Proof.
  exact H1.
  Show Proof.
  exact H2.
  Show Proof.
  exact H2.
  Show Proof.
Qed.

(*
https://us.metamath.org/ileuni/pm2.21d.html
⊢ (P → ¬Q)
------------
⊢ (P → (Q → R))
*)
Theorem pm2_21d : forall P Q R:Prop,
(
  (P -> ~Q)
) -> (
  (P -> (Q -> R))
).
Proof.
  intros P Q R.
  intros P_implies_not_Q.
  intros P_holds.
  intros Q_holds.
  Show Proof.
  (*https://www.cs.cornell.edu/courses/cs3110/2018sp/a5/coq-tactics-cheatsheet.html*)
  apply P_implies_not_Q in P_holds as not_Q_holds.
  Show Proof.
  contradiction.
  Show Proof.
    Check False_ind.
Qed.
Print pm2_21d.

(* https://us.metamath.org/ileuni/pm2.21dd.html
⊢ (P → Q)
⊢ (P → ¬Q)
------------
⊢ (P → R)
*)
Theorem pm2_21dd : forall P Q R:Prop,
(
  (P -> Q) /\
  (P -> ~Q)
) -> (
  (P -> R)
).
Proof.
  intros P Q R.
  intros H0.
  Show Proof.
  destruct H0 as [P_implies_Q_holds P_implies_not_Q_holds].
  Show Proof.
  intros P_holds.
  Show Proof.
  apply P_implies_not_Q_holds in P_holds as not_Q_holds.
  Show Proof.
  apply P_implies_Q_holds in P_holds as Q_holds.
  Show Proof.
  contradiction.
  Show Proof.
Qed.

(*
https://us.metamath.org/ileuni/pm2.24.html
⊢ (P → (¬P → Q))
*)
Theorem pm2_24 : forall P Q:Prop,
(P -> (~P -> Q)).
Proof.
  intros P Q.
  intros P_holds.
  Show Proof.
  intros not_P_holds.
  Show Proof.
  contradiction.
  Show Proof.
Qed.

(*
https://us.metamath.org/ileuni/pm2.24d.html
   ⊢ (P → Q)
------------------
⊢ (P → (¬Q → R))
*)
Theorem pm2_24d: forall P Q R:Prop,
(
   P -> Q
) -> (
   P -> (~Q -> R)
).
Proof.
  intros P Q R.
  intros P_implies_Q_holds.
  Show Proof.
  intros P_holds.
  Show Proof.
  intros not_Q_holds.
  Show Proof.
  apply P_implies_Q_holds in P_holds as Q_holds.
  Show Proof.
  contradiction.
  Show Proof.
Qed.

(* Contrapositive
	⊢ (Q → ¬ R))
  ------------------
  ⊢ (R → ¬ Q))
*)
Theorem my_contrapositive: forall Q R:Prop,
(
  Q -> ~R
) -> (
  R -> ~Q
).
Proof.
  intros Q R.
  intros Q_implies_not_R_holds.
  intros R_holds.
  intros Q_holds.
  apply Q_implies_not_R_holds in Q_holds as not_R_holds.
  contradiction.
Qed.

(*https://us.metamath.org/ileuni/con2d.html
	⊢ (P → (Q → ¬ R))
  ------------------
  ⊢ (P → (R → ¬ Q))
*)
Theorem con2d: forall P Q R:Prop,
(
  (P -> (Q -> ~R))
) -> (
  (P -> (R -> ~Q))
).
Proof.
  intros P Q R.
  Show Proof.
  intros H0.
  Show Proof.
  intros P_holds.
  Show Proof.
  apply my_contrapositive.
  Show Proof.
  intros Q_holds.
  Show Proof.
  apply H0 in P_holds as not_R_holds.
  Show Proof.
  apply not_R_holds.
  Show Proof.
  apply Q_holds.
  Show Proof.
Qed.
Print con2d.

(*
https://us.metamath.org/ileuni/mt2d.html
⊢ (P → Q)
⊢ (P → (R → ¬ Q))
------------------
⊢ (P → ¬R)
*)
Theorem mt2d: forall P Q R:Prop,
(
  (P -> Q) /\
  (P -> (R -> ~Q))
) -> (
  (P -> ~R)
).
Proof.
  intros P Q R H0 H1 R_holds.
  destruct H0 as [P_implies_Q P_implies_R_implies_not_Q].
  apply P_implies_Q in H1 as H3.
  apply P_implies_R_implies_not_Q in H1 as H4.
  contradiction.
  exact R_holds.
Qed.

Require Import Classical.

Theorem drinker : forall (A : Set) (r : A -> Prop) (e : A),
  exists x, (r x -> forall y, r y).
Proof.
   intros A r e.
   Show Proof.
Admitted.

Theorem add_0_r_secondtry : forall n:nat,
  n + 0 = n.
Proof.
  intros n.
  Show Proof.
  induction n as [| n' IHn'].
  Show Proof.
  - reflexivity.
  Show Proof.
  - simpl.
  Show Proof.
    rewrite -> IHn'.
    Show Proof.
    reflexivity.
    Show Proof.
Qed.
Print nat_ind.
(* Print eq_ind_r. *)

Section ind_explore.
  Hypothesis P : nat -> Prop.
  Hypothesis f : P 0.
  Hypothesis f0 : forall n:nat, P n -> P (S n).
  Check nat_ind P f f0.

  Definition my_nat_ind := fun (P : nat -> Prop) (f : P 0) (f0 : forall n : nat, P n -> P (S n)) =>
  fix F (n : nat) : P n :=
    match n as n0 return (P n0) with
    | 0 => f
    | S n0 => f0 n0 (F n0)
    end.

  Fixpoint F_my_nat (n : nat) : P n :=
    match n as n0 return (P n0) with
    | 0 => f
    | S n0 => f0 n0 (F_my_nat n0)
    end.

   Print F_my_nat.

   (* coq reference manual page *)
   Hypothesis x:nat.
   Hypothesis H:{1=0}+{1<>0}.
   Check (fun x (H:{x=0}+{x<>0}) =>
   match H with
   | left _ => true
   | right _ => false
   end) 1 H.
   Eval cbv in (fun x (H:{x=0}+{x<>0}) =>
   match H with
   | left _ => true
   | right _ => false
   end) 1 H.
  Check my_nat_ind P f f0.

  Definition fst (A B:Set) (H:A * B) := match H with
  | pair x y => x
  end.

End ind_explore.


Module Exercise1.

(* This exercise was done using MathClasses. I'll stick to mathcomp in the future. *)

Require Import
  MathClasses.interfaces.abstract_algebra
  MathClasses.interfaces.vectorspace
  MathClasses.theory.groups.

Lemma f_equiv' `{Equiv A} `{f : A -> A} :
  f = f -> forall x y, x = y -> f x = f y.
Proof.
  intros.
  f_equiv.
  assumption.
Qed.

Lemma one : forall `{HVS : VectorSpace K V}, forall (u : V), 0 · u = mon_unit.
Proof.
  intros.
  setoid_rewrite <- left_identity.
  setoid_rewrite <- left_inverse with (x := 1 · u).
  setoid_rewrite <- associativity.
  apply f_equiv'.
  { cbv; intros ?? Hxy; now rewrite Hxy. }
  setoid_rewrite <- distribute_r.
  cbv; now group.
Qed.

Lemma two : forall `{HVS : VectorSpace K V}, forall (α : K), α · mon_unit = mon_unit.
Proof.
  intros.
  rewrite <- right_identity.
  rewrite <- (right_inverse (α · mon_unit)) at 2 3.
  rewrite associativity.
  apply (f_equiv' (f := fun v => v & - (α · mon_unit)));
    [ cbv; intros ?? Hxy; now rewrite Hxy |].
  rewrite <- distribute_l.
  pose scalar_mult_proper.
  rewrite left_identity.
  reflexivity.
Qed.

Lemma three : forall `{HVS : VectorSpace K V}, forall (u : V), -1 · u = -u.
Proof.
  intros.
  setoid_rewrite <- right_identity.
  setoid_rewrite <- (right_inverse u).
  setoid_rewrite associativity.
  apply (f_equiv' (f := fun v => v & - u));
    [ cbv; intros ?? Hxy; now rewrite Hxy |].
  rewrite left_inverse.
  rewrite <- (left_identity u (op := (·))) at 2.
  rewrite <- distribute_r.
  pose scalar_mult_proper.
  rewrite left_inverse.
  apply one.
Qed.

End Exercise1.

Module Exercise2.
  Module i.
    (** The exercice statement is simply (translated) :
     Prove that the set K^n with the following operations :
            (x_1, ..., x_n) + (y_1, ..., y_n) = (x_1 + y_1, ..., x_n + y_n)
         and
            λ·(x_1, ..., x_n) = (λ × x_1, ..., λ × x_n)
     is a vector space.

     So I figured that would be the occasion the learn how to properly define Mathclasses structures.
     That's why this Module is so long, apologies. *)

    Require Import
      Coq.Vectors.Vector
      MathClasses.theory.dec_fields
      Field.
    Import VectorNotations.

    Open Scope vector_scope.

    Context F `{DecField F}.
    Add Field F: (stdlib_field_theory F).

    Definition vec := Vector.t F.

    Definition vec_constant {n : nat} (c : F) : vec n := Vector.const c n.

    Instance vec_zero {n : nat} : Zero (vec n) := Vector.const 0 n.

    Instance vec_eq {n : nat} : Equiv (vec n) :=
      fold_right2 (fun α β S => α = β /\ S) True n.

    Instance vec_add {n : nat} : Plus (vec n) :=
      map2 (fun α β => α + β).

    Instance vec_neg {n : nat} : Negate (vec n) :=
      map (fun α => - α).

    Instance vec_scal {n : nat} : ScalarMult F (vec n) :=
      fun α => map (fun β => α * β).

    Instance: forall {n : nat}, Reflexive (vec_eq (n := n)).
    Proof.
      intros n x.
      induction x.
      - simpl. apply I.
      - split; [reflexivity | assumption].
    Qed.

    Lemma vec0_eq_nil : forall v : vec 0, v ≡ [].
    Proof with reflexivity. apply case0... Qed.

    Lemma vec_cons_eq : forall {n : nat} (u v : vec n) (α β : F), (α::u = β::v) <-> α = β /\ u = v.
    Proof. split; intros; assumption. Qed.

    Lemma vec0_eq_proper : Proper (equiv ==> equiv ==> flip impl) (vec_eq (n := 0)).
    Proof.
      repeat intro.
      assert (nil F ≡ nil F) by reflexivity.
      rewrite (vec0_eq_nil x), (vec0_eq_nil x0).
      reflexivity.
    Qed.

    Instance: forall {n : nat}, Symmetric (vec_eq (n := n)).
    Proof.
      intros n u v Heq.
      induction n.
      - pose vec0_eq_proper.
        rewrite (vec0_eq_nil v), (vec0_eq_nil u).
        reflexivity.
      - rewrite (eta u), (eta v) in *.
        apply vec_cons_eq.
        destruct (vec_cons_eq (tl u) (tl v) (hd u) (hd v)) as [Hi _].
        pose proof (Hi Heq) as [Hs_hd Hs_tl].
        split.
        + symmetry.
          exact Hs_hd.
        + apply IHn.
          exact Hs_tl.
    Qed.

    Instance: forall {n : nat}, Transitive (vec_eq (n := n)).
    Proof.
      intros n u v z Heq_uv Heq_vz.
      (* Maybe I'll avoid writing a [vec_eq_ind] function eternally *)
      induction n.
      - pose vec0_eq_proper as Hp.
        rewrite (vec0_eq_nil u), (vec0_eq_nil v) in *.
        exact Heq_vz.
      - rewrite (eta u), (eta v), (eta z) in *.
        destruct (vec_cons_eq (tl u) (tl v) (hd u) (hd v)) as [Hi_uv _].
        destruct (vec_cons_eq (tl v) (tl z) (hd v) (hd z)) as [Hi_vz _].
        pose proof (Hi_uv Heq_uv) as [Hs_hd_uv Hs_tl_uv].
        pose proof (Hi_vz Heq_vz) as [Hs_hd_vz Hs_tl_vz].
        split.
        + transitivity (hd v).
          * exact Hs_hd_uv.
          * exact Hs_hd_vz.
        + apply IHn with (v := (tl v)).
          * exact Hs_tl_uv.
          * exact Hs_tl_vz.
    Qed.

    Instance: forall {n : nat}, Setoid (vec n).
    Proof. split; apply _. Qed.

    Lemma vec0_add_proper : Proper (equiv ==> equiv ==> equiv) (vec_add (n := 0)).
    Proof.
      repeat intro.
      assert (nil F ≡ nil F) by reflexivity.
      rewrite (vec0_eq_nil x),
        (vec0_eq_nil x0),
        (vec0_eq_nil y),
        (vec0_eq_nil y0).
      reflexivity.
    Qed.

    Instance vec_add_commutative {n : nat} : Commutative (vec_add (n := n)).
    Proof.
      intros u v.
      induction n.
      - pose vec0_add_proper as Hp.
        rewrite (case0 (fun v => v = []) I v), (vec0_eq_nil u).
        reflexivity.
      - rewrite (eta u), (eta v) in *.
        split.
        + apply commutativity.
        + apply IHn.
    Qed.

    Instance vec_add_associative {n : nat} : Associative (vec_add (n := n)).
    Proof.
      intros u v z.
      induction n.
      - pose vec0_add_proper as Hp.
        rewrite (vec0_eq_nil v), (vec0_eq_nil u), (vec0_eq_nil z).
        reflexivity.
      - rewrite (eta u), (eta v), (eta z) in *.
        split.
        + apply associativity.
        + apply IHn.
    Qed.

    Lemma vec_add_proper {n : nat} : Proper (equiv ==> equiv ==> equiv) (vec_add (n := n)).
    Proof.
      induction n.
      - apply vec0_add_proper; assumption.
      - intros u v Heq_uv x y Heq_xy.
        rewrite (eta u), (eta v), (eta x), (eta y) in *.
        split; [apply sg_op_proper | apply IHn];
          try apply Heq_uv; try apply Heq_xy.
    Qed.

    Instance: forall {n : nat}, SemiGroup (vec n).
    Proof.
      split.
      apply _.
      apply _.
      apply vec_add_proper.
    Qed.

    Instance: forall {n : nat}, LeftIdentity (vec_add (n := n)) vec_zero.
    Proof.
      intros n v.
      induction n.
      - rewrite (vec0_eq_nil v).
        reflexivity.
      - rewrite (eta v), (eta vec_zero).
        split.
        + group.
        + apply IHn.
    Qed.

    Instance: forall {n : nat}, RightIdentity (vec_add (n := n)) vec_zero.
    Proof.
      intros n v.
      rewrite commutativity.
      apply left_identity.
    Qed.

    Instance: forall {n : nat}, Monoid (vec n).
    Proof. split; apply _. Qed.

    Instance: forall {n : nat}, Proper (equiv ==> equiv) (vec_neg (n := n)).
    Proof.
      intros n u v Heq.
      induction n.
      - rewrite (vec0_eq_nil u), (vec0_eq_nil v).
        reflexivity.
      - rewrite (eta u), (eta v) in *.
        split.
        + apply (negate_proper F).(sm_proper).
          apply Heq.
        + apply IHn.
          apply Heq.
    Qed.

    Instance: forall {n : nat}, Setoid_Morphism (vec_neg (n := n)).
    Proof. split; apply _. Qed.

    Instance: forall {n : nat}, LeftInverse (vec_add (n := n)) (vec_neg (n := n)) vec_zero.
    Proof.
      intros n v.
      induction n.
      - rewrite (vec0_eq_nil v).
        reflexivity.
      - rewrite (eta v) in *.
        split.
        + apply left_inverse.
        + apply IHn.
    Qed.

    Instance: forall {n : nat}, RightInverse (vec_add (n := n)) (vec_neg (n := n)) vec_zero.
    Proof.
      intros n v.
      rewrite commutativity.
      apply left_inverse.
    Qed.

    Instance: forall {n : nat}, Group (vec n).
    Proof. split; apply _. Qed.

    Instance: forall {n : nat}, AbGroup (vec n).
    Proof. split; apply _. Qed.

    Instance: forall {n : nat}, LeftHeteroDistribute (vec_scal (n := n)) (vec_add (n := n)) (vec_add (n := n)).
    Proof.
      intros n α u v.
      induction n.
      - rewrite (vec0_eq_nil u), (vec0_eq_nil v).
        reflexivity.
      - rewrite (eta u), (eta v).
        split.
        + apply distribute_l.
        + apply IHn.
    Qed.

    (* Is there a Lemma I can prove to "automate" this ? Besides using Ltac. *)
    Instance: forall {n : nat}, RightHeteroDistribute (vec_scal (n := n)) (+) (vec_add (n := n)).
    Proof.
      intros n α β v.
      induction n.
      - rewrite (vec0_eq_nil v).
        reflexivity.
      - rewrite (eta v).
        split.
        + apply distribute_r.
        + apply IHn.
    Qed.

    Instance: forall {n : nat}, HeteroAssociative (vec_scal (n := n)) (vec_scal (n := n)) (vec_scal (n := n)) mult.
    Proof.
      intros n α β v.
      induction n.
      - rewrite (vec0_eq_nil v).
        reflexivity.
      - rewrite (eta v).
        split.
        + apply associativity.
        + apply IHn.
    Qed.

    Instance: forall {n : nat}, LeftIdentity (vec_scal (n := n)) 1.
    Proof.
      intros n v.
      induction n.
      - rewrite (vec0_eq_nil v).
        reflexivity.
      - rewrite (eta v).
        split.
        + apply left_identity.
        + apply IHn.
    Qed.

    Instance: forall {n : nat}, Proper (equiv ==> equiv ==> equiv) (vec_scal (n := n)).
    Proof.
      intros n α β Heq_αβ u v Heq_uv.
      induction n.
      - rewrite (vec0_eq_nil u), (vec0_eq_nil v).
        reflexivity.
      - rewrite (eta u), (eta v) in *.
        split.
        + apply sg_op_proper.
          * exact Heq_αβ.
          * apply Heq_uv.
        + apply IHn.
          apply Heq_uv.
    Qed.

    Instance: forall {n : nat}, Module F (vec n).
    Proof. split; apply _. Qed.

    Instance: forall {n : nat}, VectorSpace F (vec n).
    Proof. split; apply _. Qed.
  End i.

End Exercise2.


(* This file is extracted from the TLC library.
   http://github.com/charguer/tlc
   DO NOT EDIT. *)

(**************************************************************************
* TLC: A library for Coq                                                  *
* Epsilon operator                                                        *
**************************************************************************)

Set Implicit Arguments.
From SLF Require Import LibTactics LibLogic LibRelation.
Generalizable Variables A B.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Definition and specification of Hilbert's epsilon operator *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Definition of epsilon *)

(** [epsilon P] where [P] is a predicate over an inhabited type [A],
    returns a value [x] of type [A] that satisfies [P], if there exists
    one such value, else it returns an arbitrary value of type [A]. *)

Definition epsilon_def : forall A {IA:Inhab A} (P:A->Prop),
  { x : A | (exists y, P y) -> P x }.
Proof using.
  intros A IA P. destruct (classicT (exists y, P y)) as [H|H].
  { apply indefinite_description. destruct H as [x H].
    exists x. intros _. apply H. }
  { exists (@arbitrary A IA). intros N. false H. apply N. }
Qed.

Definition epsilon A {IA: Inhab A} (P:A->Prop) : A :=
  sig_val (epsilon_def P).

Lemma pred_epsilon : forall A {IA:Inhab A} (P:A->Prop),
  (exists x, P x) ->
  P (epsilon P).
Proof using. intros. apply~ (sig_proof (epsilon_def P)). Qed.

Opaque epsilon.

(* Remark: the proof term associated with the definition *)

Definition epsilon_def' A {IA:Inhab A} (P:A->Prop) :
  { x : A | (exists y, P y) -> P x } :=
  match classicT (exists y, P y) with
  | left H =>
      indefinite_description
        (let (x,H0) := H in
         ex_intro (fun x0 => (exists y, P y) -> P x0)
                   x
                  (fun N => H0))
  | right H =>
      exist (fun x => (exists y, P y) -> P x)
            arbitrary
            (fun N => False_ind (P arbitrary) (H N))
  end.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Lemmas about epsilon *)

Lemma pred_epsilon_weaken : forall A {IA:Inhab A} (P Q : A->Prop),
  (exists x, P x) ->
  (forall x, P x -> Q x) ->
  Q (epsilon P).
Proof using. introv E M. apply M. apply* pred_epsilon. Qed.

Lemma pred_epsilon_of_val : forall A (x:A) (P:A->Prop) {IA:Inhab A},
  P x ->
  P (epsilon P).
Proof using. intros. apply* pred_epsilon. Qed.

Lemma pred_epsilon_of_val_weaken : forall A (x:A) (P Q:A->Prop) {IA:Inhab A},
  P x ->
  (forall x, P x -> Q x) ->
  Q (epsilon P).
Proof using. introv Px W. apply W. apply* pred_epsilon. Qed.

Lemma epsilon_eq : forall A {IA:Inhab A} (P Q:A->Prop),
  (forall x, P x <-> Q x) ->
  epsilon P = epsilon Q.
Proof using. introv H. fequals. extens*. Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** (Private) tactic [epsilon_find] *)

(** [epsilon_find cont] locates an expression of the form [epsilon P]
    in the goal and invokes the continuation [cont] on [P].

    [epsilon_find_in H cont] is similar but looks for the expression
    only in the hypothesis named [H]. *)

Ltac epsilon_find cont :=
  match goal with
  | |- context [epsilon ?P] => cont P
  | H: context [epsilon ?P] |- _ => cont P
  end.

Ltac epsilon_find_in H cont :=
  match type of H with context [epsilon ?P] => cont P end.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Tactics [epsilon_name] *)

(** [epsilon_name X] assigns a name [X] to an expression of the
    form [epsilon P] that appears in the goal or an hypothesis,
    by calling [set (X := epsilon P)].

    [epsilon_name X in H] assignes a name [X] to an expression of the
    form [epsilon P] that appears in hypothesis [H]. *)

Ltac epsilon_name_core X :=
  epsilon_find ltac:(fun P => sets X: (epsilon P)).

Ltac epsilon_name_in_core X H :=
  epsilon_find_in H ltac:(fun P => sets X: (epsilon P)).

Tactic Notation "epsilon_name" ident(X) :=
  epsilon_name_core X.

Tactic Notation "epsilon_name" ident(X) "in" hyp(H)  :=
  epsilon_name_in_core X H.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Tactics to work with [epsilon] *)

(** [epsilon X] locates an expression of the form [epsilon P] in the goal,
    names [X] this expression (like [epsilon_name X]), then produces
    a subgoal [exists x, P x], and leaves at the head of the main goal
    an hypothesis [P X].

    [epsilon X in H] is similar, but looks for [epsilon P] only in
    hypothesis [H]. *)

Lemma pred_epsilon' : forall A (P:A->Prop) (IA:Inhab A),
  (exists x, P x) ->
  P (epsilon P).
Proof using. intros. applys* pred_epsilon. Qed.

Ltac epsilon_cont X P :=
  let I := fresh "H" X in
  lets I: (>> (@pred_epsilon' _ P) __ __);
    [ | sets X: (epsilon P); revert I ].

Ltac epsilon_core X :=
  epsilon_find ltac:(fun P => epsilon_cont X P).

Ltac epsilon_in_core X H :=
  epsilon_find_in H ltac:(fun P => epsilon_cont X P).

Tactic Notation "epsilon" ident(X) :=
  epsilon_core X.
Tactic Notation "epsilon" ident(X) "in" hyp(H) :=
  epsilon_in_core X H.

Tactic Notation "epsilon" "~" ident(X) :=
  epsilon X; auto_tilde.
Tactic Notation "epsilon" "~" ident(X) "in" hyp(H) :=
  epsilon X in H; auto_tilde.

Tactic Notation "epsilon" "*" ident(X) :=
  epsilon X; auto_star.
Tactic Notation "epsilon" "*" ident(X) "in" hyp(H) :=
  epsilon X in H; auto_star.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Construction of a function from a relation, using [epsilon] *)

(* Given a relation [R] of type [A->B->Prop], [rel_to_fun R] returns a
   function [f] of type [A->B] that satisfies the relation [R], i.e.
   such that [R x (f x)] forall [x] that has an image by [R]. *)

Definition rel_to_fun A `{IB:Inhab B} (R:A->B->Prop) : A -> B :=
  fun (a:A) => epsilon (fun b => R a b).

Section Rel_to_fun.
Context (A B : Type) {IB:Inhab B}.
Implicit Types R : A -> B -> Prop.

(* Every [a] in the domain of [R] is related by [R] with [rel_to_fun a]. *)

Lemma rel_rel_to_fun_of_exists : forall R a,
  (exists b, R a b) ->
  R a (rel_to_fun R a).
Proof using IB. introv [x H]. unfold rel_to_fun. epsilon* y. Qed.

Lemma rel_rel_to_fun_of_rel : forall R a b,
  R a b ->
  R a (rel_to_fun R a).
Proof using IB. intros. applys* rel_rel_to_fun_of_exists. Qed.

Lemma rel_rel_to_fun_of_not_forall : forall R a,
  ~ (forall b, ~ R a b) ->
  R a (rel_to_fun R a).
Proof using IB.
  introv. rew_logic. intros [x H]. applys* rel_rel_to_fun_of_exists.
Qed.

Lemma rel_in_fun_rel_to_fun : forall R,
  functional R ->
  rel_in_fun R (rel_to_fun R).
Proof using IB. unfold rel_in_fun, rel_to_fun. introv M H. epsilon* z. Qed.

(** Reformulation of above *)

Lemma rel_to_fun_eq_of_functional : forall x y R,
  functional R ->
  R x y ->
  rel_to_fun R x = y.
Proof using IB. introv M E. applys* rel_in_fun_rel_to_fun. Qed.

End Rel_to_fun.

(* Remark: in the special case where [R] has type [A->A->Prop],
   one may get away without providing a proof of [Inhab A].

  Definition rel_to_fun' A (R : A -> A -> Prop) (a : A) : A :=
    @rel_to_fun A A (Inhab_of_val a) R a.
*)

(* 2021-08-11 15:24 *)


Require Import List.
Import ListNotations.

Inductive ForallT {A : Type} (P : A -> Type) : list A -> Type :=
| ForallT_nil : ForallT P []
| ForallT_cons (x : A) (l : list A) : P x -> ForallT P l -> ForallT P (x :: l).
Hint Constructors ForallT : core.

Definition fold_ForallT {A R : Type} {P: A -> Type}
    (hnil : R) (hcons : forall (a : A), P a -> R -> R)
    xs (pxs : ForallT P xs): R :=
  ForallT_rect A P (fun _ _ => R) hnil (fun x xs px _ => hcons x px) xs pxs.

Definition fold_ForallT_manual {A R : Type} {P: A -> Type}
  (hnil : R) (hcons : forall (a : A), P a -> R -> R) :
  forall xs, ForallT P xs -> R :=
    fix F xs pxs :=
      match pxs return _ with
      | ForallT_nil _ => hnil
      | ForallT_cons _ x xs px pxs => hcons x px (F xs pxs)
      end.

(** To be able to reuse lemmas on Forall, show that ForallT is equivalent to Forall for predicates in Prop.
    The proof is a bit subtler than you'd think because it can't look into Prop
    to produce proof-relevant part of the result (and that's why I can't inversion until very late.
 *)
Lemma ForallT_Forall {X} (P: X -> Prop) xs: (ForallT P xs -> Forall P xs) * (Forall P xs -> ForallT P xs).
Proof.
  split; (induction xs; intro H; constructor; [|apply IHxs]); inversion H; trivial.
Qed.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Functor.

(** A constant functor maps all objects to a single object and all arrows to identity arrow of that object. *)
Section Const_Func.
  Context (C : Category) {D : Category} (a : @Obj D).

  Program Definition Const_Func : (C –≻ D)%functor :=
    {|
      FO := fun _ => a;
      FA := fun _ _ _ => id a
    |}.

End Const_Func.


Require Import
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.interfaces.orders
  HoTT.Classes.orders.orders
  HoTT.Classes.theory.apartness.

Generalizable Variables A B C R S f g z.

(* If a function between strict partial orders is order preserving (back), we can
  derive that it is strictly order preserving (back) *)
Section strictly_order_preserving.
  Context `{FullPartialOrder A} `{FullPartialOrder B}.

  Global Instance strictly_order_preserving_inj  `{!OrderPreserving (f : A -> B)}
    `{!IsStrongInjective f} :
    StrictlyOrderPreserving f | 20.
  Proof.
  intros x y E.
  apply lt_iff_le_apart in E. apply lt_iff_le_apart.
  destruct E as [E1 E2]. split.
  - apply (order_preserving f);trivial.
  - apply (strong_injective f);trivial.
  Qed.

  Global Instance strictly_order_reflecting_mor `{!OrderReflecting (f : A -> B)}
    `{!StrongExtensionality f} :
    StrictlyOrderReflecting f | 20.
  Proof.
  intros x y E.
  apply lt_iff_le_apart in E. apply lt_iff_le_apart.
  destruct E as [E1 E2]. split.
  - apply (order_reflecting f);trivial.
  - apply (strong_extensionality f);trivial.
  Qed.
End strictly_order_preserving.

(* For structures with a trivial apartness relation
   we have a stronger result of the above *)
Section strictly_order_preserving_dec.
  Context `{FullPartialOrder A} `{!TrivialApart A}
          `{FullPartialOrder B} `{!TrivialApart B}.

  Local Existing Instance strict_po_apart.

  Global Instance dec_strictly_order_preserving_inj
    `{!OrderPreserving (f : A -> B)}
    `{!IsInjective f} :
    StrictlyOrderPreserving f | 19.
  Proof.
  pose proof (dec_strong_injective f).
  apply _.
  Qed.

  Global Instance dec_strictly_order_reflecting_mor
    `{!OrderReflecting (f : A -> B)}
    : StrictlyOrderReflecting f | 19.
  Proof.
  pose proof (dec_strong_morphism f). apply _.
  Qed.
End strictly_order_preserving_dec.

Section pseudo_injective.
  Context `{PseudoOrder A} `{PseudoOrder B}.

  Local Existing Instance pseudo_order_apart.

  Instance pseudo_order_embedding_ext `{!StrictOrderEmbedding (f : A -> B)} :
    StrongExtensionality f.
  Proof.
  intros x y E.
  apply apart_iff_total_lt;apply apart_iff_total_lt in E.
  destruct E; [left | right]; apply (strictly_order_reflecting f);trivial.
  Qed.

  Lemma pseudo_order_embedding_inj `{!StrictOrderEmbedding (f : A -> B)} :
    IsStrongInjective f.
  Proof.
  split;try apply _.
  intros x y E.
  apply apart_iff_total_lt;apply apart_iff_total_lt in E.
  destruct E; [left | right]; apply (strictly_order_preserving f);trivial.
  Qed.
End pseudo_injective.

(* If a function between pseudo partial orders is strictly order preserving (back),
   we can derive that it is order preserving (back) *)
Section full_pseudo_strictly_preserving.
  Context `{FullPseudoOrder A} `{FullPseudoOrder B}.

  Local Existing Instance pseudo_order_apart.

  Lemma full_pseudo_order_preserving `{!StrictlyOrderReflecting (f : A -> B)}
    : OrderPreserving f.
  Proof.
  intros x y E1.
  apply le_iff_not_lt_flip;apply le_iff_not_lt_flip in E1.
  intros E2. apply E1.
  apply (strictly_order_reflecting f).
  trivial.
  Qed.

  Lemma full_pseudo_order_reflecting `{!StrictlyOrderPreserving (f : A -> B)}
    : OrderReflecting f.
  Proof.
  intros x y E1.
  apply le_iff_not_lt_flip;apply le_iff_not_lt_flip in E1.
  intros E2. apply E1.
  apply (strictly_order_preserving f).
  trivial.
  Qed.
End full_pseudo_strictly_preserving.

(* Some helper lemmas to easily transform order preserving instances. *)
Section order_preserving_ops.
  Context `{Le R}.

  Lemma order_preserving_flip {op} `{!Commutative op} `{!OrderPreserving (op z)}
    : OrderPreserving (fun y => op y z).
  Proof.
  intros x y E.
  rewrite 2!(commutativity _ z).
  apply order_preserving;trivial.
  Qed.

  Lemma order_reflecting_flip {op} `{!Commutative op}
    `{!OrderReflecting (op z) }
    : OrderReflecting (fun y => op y z).
  Proof.
  intros x y E.
  apply (order_reflecting (op z)).
  rewrite 2!(commutativity (f:=op) z).
  trivial.
  Qed.

  Lemma order_preserving_nonneg (op : R -> R -> R) `{!Zero R}
    `{forall z, PropHolds (0 ≤ z) -> OrderPreserving (op z)} z
    : 0 ≤ z -> forall x y, x ≤ y -> op z x ≤ op z y.
  Proof.
  auto.
  Qed.

  Lemma order_preserving_flip_nonneg (op : R -> R -> R) `{!Zero R}
    {E:forall z, PropHolds (0 ≤ z) -> OrderPreserving (fun y => op y z)} z
    : 0 ≤ z -> forall x y, x ≤ y -> op x z ≤ op y z.
  Proof.
  apply E.
  Qed.

  Context `{Lt R}.

  Lemma order_reflecting_pos (op : R -> R -> R) `{!Zero R}
    {E:forall z, PropHolds (0 < z) -> OrderReflecting (op z)} z
    : 0 < z -> forall x y, op z x ≤ op z y -> x ≤ y.
  Proof.
  apply E.
  Qed.

  Lemma order_reflecting_flip_pos (op : R -> R -> R) `{!Zero R}
    {E:forall z, PropHolds (0 < z) -> OrderReflecting (fun y => op y z)} z
    : 0 < z -> forall x y, op x z ≤ op y z -> x ≤ y.
  Proof.
  apply E.
  Qed.

End order_preserving_ops.

Section strict_order_preserving_ops.
  Context `{Lt R}.

  Lemma strictly_order_preserving_flip {op} `{!Commutative op}
    `{!StrictlyOrderPreserving (op z)}
    : StrictlyOrderPreserving (fun y => op y z).
  Proof.
  intros x y E.
  rewrite 2!(commutativity _ z).
  apply strictly_order_preserving;trivial.
  Qed.

  Lemma strictly_order_reflecting_flip {op} `{!Commutative op}
    `{!StrictlyOrderReflecting (op z) }
    : StrictlyOrderReflecting (fun y => op y z).
  Proof.
  intros x y E.
  apply (strictly_order_reflecting (op z)).
  rewrite 2!(commutativity (f:=op) z).
  trivial.
  Qed.

  Lemma strictly_order_preserving_pos (op : R -> R -> R) `{!Zero R}
    {E:forall z, PropHolds (0 < z) -> StrictlyOrderPreserving (op z)} z
    : 0 < z -> forall x y, x < y -> op z x < op z y.
  Proof.
  apply E.
  Qed.

  Lemma strictly_order_preserving_flip_pos (op : R -> R -> R) `{!Zero R}
    {E:forall z, PropHolds (0 < z) -> StrictlyOrderPreserving (fun y => op y z)} z
    : 0 < z -> forall x y, x < y -> op x z < op y z.
  Proof.
  apply E.
  Qed.

End strict_order_preserving_ops.

Lemma projected_partial_order `{IsHSet A} {Ale : Le A}
  `{is_mere_relation A Ale} `{Ble : Le B}
  (f : A -> B) `{!IsInjective f} `{!PartialOrder Ble}
  : (forall x y, x ≤ y <-> f x ≤ f y) -> PartialOrder Ale.
Proof.
intros P. repeat split.
- apply _.
- apply _.
- intros x. apply P. apply reflexivity.
- intros x y z E1 E2. apply P.
  transitivity (f y); apply P;trivial.
- intros x y E1 E2. apply (injective f).
  apply (antisymmetry (≤)); apply P;trivial.
Qed.

Lemma projected_total_order `{Ale : Le A} `{Ble : Le B}
  (f : A -> B) `{!TotalRelation Ble}
  : (forall x y, x ≤ y <-> f x ≤ f y) -> TotalRelation Ale.
Proof.
intros P x y.
destruct (total (≤) (f x) (f y)); [left | right]; apply P;trivial.
Qed.

Lemma projected_strict_order `{Alt : Lt A} `{is_mere_relation A lt} `{Blt : Lt B}
  (f : A -> B) `{!StrictOrder Blt}
  : (forall x y, x < y <-> f x < f y) -> StrictOrder Alt.
Proof.
intros P. split.
- apply _.
- intros x E. destruct (irreflexivity (<) (f x)). apply P. trivial.
- intros x y z E1 E2. apply P. transitivity (f y); apply P;trivial.
Qed.

Lemma projected_pseudo_order `{IsApart A} `{Alt : Lt A} `{is_mere_relation A lt}
  `{Apart B} `{Blt : Lt B}
  (f : A -> B) `{!IsStrongInjective f} `{!PseudoOrder Blt}
  : (forall x y, x < y <-> f x < f y) -> PseudoOrder Alt.
Proof.
pose proof (strong_injective_mor f).
intros P. split; try apply _.
- intros x y E. apply (pseudo_order_antisym (f x) (f y)).
  split; apply P,E.
- intros x y E z. apply P in E.
  apply (merely_destruct (cotransitive E (f z)));
  intros [?|?];apply tr; [left | right]; apply P;trivial.
- intros x y; split; intros E.
  + apply (strong_injective f) in E.
    apply apart_iff_total_lt in E.
    destruct E; [left | right]; apply P;trivial.
  + apply (strong_extensionality f).
    apply apart_iff_total_lt.
    destruct E; [left | right]; apply P;trivial.
Qed.

Lemma projected_full_pseudo_order `{IsApart A} `{Ale : Le A} `{Alt : Lt A}
  `{is_mere_relation A le} `{is_mere_relation A lt}
  `{Apart B} `{Ble : Le B} `{Blt : Lt B}
  (f : A -> B) `{!IsStrongInjective f} `{!FullPseudoOrder Ble Blt}
  : (forall x y, x ≤ y <-> f x ≤ f y) -> (forall x y, x < y <-> f x < f y) ->
    FullPseudoOrder Ale Alt.
Proof.
intros P1 P2. split.
- apply _.
- apply (projected_pseudo_order f);assumption.
- intros x y; split; intros E.
  + intros F. destruct (le_not_lt_flip (f y) (f x));[apply P1|apply P2];trivial.
  + apply P1. apply not_lt_le_flip.
    intros F. apply E,P2. trivial.
Qed.

Global Instance id_order_preserving `{PartialOrder A} : OrderPreserving (@id A).
Proof.
red;trivial.
Qed.

Global Instance id_order_reflecting `{PartialOrder A} : OrderReflecting (@id A).
Proof.
red;trivial.
Qed.

Section composition.
  Context {A B C} `{Le A} `{Le B} `{Le C} (f : A -> B) (g : B -> C).

  Instance compose_order_preserving:
    OrderPreserving f -> OrderPreserving g -> OrderPreserving (g ∘ f).
  Proof.
  red;intros. unfold Compose.
  do 2 apply (order_preserving _).
  trivial.
  Qed.

  Instance compose_order_reflecting:
    OrderReflecting f -> OrderReflecting g -> OrderReflecting (g ∘ f).
  Proof.
  intros ?? x y E. unfold Compose in E.
  do 2 apply (order_reflecting _) in E.
  trivial.
  Qed.

  Instance compose_order_embedding:
    OrderEmbedding f -> OrderEmbedding g -> OrderEmbedding (g ∘ f) := {}.
End composition.

#[export]
Hint Extern 4 (OrderPreserving (_ ∘ _)) =>
  class_apply @compose_order_preserving : typeclass_instances.
#[export]
Hint Extern 4 (OrderReflecting (_ ∘ _)) =>
  class_apply @compose_order_reflecting : typeclass_instances.
#[export]
Hint Extern 4 (OrderEmbedding (_ ∘ _)) =>
  class_apply @compose_order_embedding : typeclass_instances.


Require Import PeanoNat.

(*nvalue Data Structure*)
Inductive nvalue (A:Type):Type:=
| default (n:A) : nvalue A
| device (n:nat) (y:A) : nvalue A -> nvalue A.

(*get single device value*)
Fixpoint get {A} (pos:nat) (n:nvalue A):A:=
match n with
| default _ x => x
| device _ i x m => if (pos=?i) then x else (get pos m)
end.

Fixpoint getDefault {A} (n:nvalue A): A :=
match n with
| default _ x => x
| device _ i x m => getDefault m
end.

(*ordered predicate*)
Inductive ordered {A} :nvalue A -> Prop :=
| ordered0 : forall x, ordered (default A x)
| ordered1 : forall a0 b0 b1, ordered ((device A a0 b0 (default A b1)))
| ordered2 : forall a0 a1 m b0 b1, lt a0 a1 -> ordered (device A a1 b1 m) -> ordered ((device A a0 b0 (device A a1 b1 m))).

(*
Fixpoint defaultV {A} (n:nvalue A): A :=
match n with
| default _ x => x
| device _ _ _ m => defaultV m
end.
(*Operation between two nvalues*)
(*A is the type of nvalue, op is the point-wise operation*)
(*nvalues need to be ordered, this is achieved by a properly insertion in the data type*)
(*It's possible to define a pointwise operation on non order nvalues,
but we must to assure that the nvalue don't contains duplicates*)
Fixpoint pointWise {A} (op:A->A->A) (w0:nvalue A) {struct w0}: nvalue A -> nvalue A:=
fix pointWise1 (w1:nvalue A) {struct w1}: nvalue A :=
match w0,w1 with
| default _ x , default _ y => default A (op x y)
| default _ x , device _ a b m  =>  device A a b (pointWise1 m)
| device _ a b m , default _ x  => device A a b (pointWise op  m (default A x))
| device _ a0 b0 m0 , device _ a1 b1 m1  => if (a0=?a1) then device A a0 (op b0 b1) (pointWise op m0 m1)
                                            else (if (a0<?a1) then device A a0 (op b0 (defaultV m1)) (pointWise op m0 (device A a1 b1 m1))
                                            else device A a1 (op (defaultV m0) b1) (pointWise1 m1 ))
end.

(*check*)
Definition int_sum (x:nat) (y:nat) : nat :=  x + y.
Compute(pointWise int_sum (device nat 1 2(device nat 3 5(device nat 5 7(device nat 7 3(default nat 1))))) (device nat 2 2(device nat 4 5(device nat 6 7(device nat 7 3(default nat 2)))))).

Lemma first: ordered (default nat 5).
Proof.
apply ordered0.
Qed.

Lemma second: ordered(device nat 3 5(default nat 4)).
Proof.
apply ordered1.
Qed.

Search lt.
Lemma third: ordered(device nat 2 5(device nat 3 5(default nat 4))).
Proof.
apply ordered2. apply Nat.lt_succ_diag_r. apply ordered1.
Qed.
*)


Require Import Setoid Morphisms Vector.

Class Equiv A := equiv : A -> A -> Prop.
Class Setoid A `{Equiv A} := setoid_equiv:> Equivalence (equiv).

Global Declare Instance vec_equiv {A} `{Equiv A} {n}: Equiv (Vector.t A n).
Global Declare Instance vec_setoid A `{Setoid A} n : Setoid (Vector.t A n).

Global Declare Instance tl_proper1 {A} `{Equiv A} n:
  Proper ((equiv) ==> (equiv))
         (@tl A n).

Lemma test:
  forall {A} `{Setoid A} n (xa ya: Vector.t A (S n)),
    (equiv xa ya) -> equiv (tl xa) (tl ya).
Proof.
  intros A R HA n xa ya Heq.
  setoid_rewrite Heq.
  reflexivity.
Qed.