(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(***************************************************************************)
(* File: useful.v                                                          *)
(* auteur: alex@sysal.ibp.fr                                               *)
(* date: 19/10/95                                                          *)
(***************************************************************************)
Require Import nothing.

(***************************************************************************)
(* Many useful lemmas                                                      *)
(***************************************************************************)

(***************************************************************************)
(* Distributivity and factorisation of /\ and \/                           *)
(***************************************************************************)
Lemma lem_and_fact :
 forall P0 P1 P2 : Prop, (P0 \/ P1) /\ P2 -> P0 /\ P2 \/ P1 /\ P2.
(* Proof of lem_and_fact                                                   *)
intros; tauto.
Qed.
(* End of proof of lem_and_fact                                            *)

Lemma lem_and_dist :
 forall P0 P1 P2 : Prop, P0 /\ P2 \/ P1 /\ P2 -> (P0 \/ P1) /\ P2.
(* Proof of lem_and_dist                                                   *)
intros; tauto.

Qed.
(* End of proof of lem_and_dist                                            *)

Lemma lem_or_fact :
 forall P0 P1 P2 : Prop, P0 /\ P1 \/ P2 -> (P0 \/ P2) /\ (P1 \/ P2).
(* Proof of lem_or_fact                                                    *)
intros; tauto.

Qed.
(* End of proof of lem_or_fact                                             *)

Lemma lem_or_dist :
 forall P0 P1 P2 : Prop, (P0 \/ P2) /\ (P1 \/ P2) -> P0 /\ P1 \/ P2.
(* Proof of lem_or_dist                                                    *)
intros; tauto.

Qed.
(* End of proof of lem_or_dist                                             *)

(***************************************************************************)
(* Rewriting                                                               *)
(***************************************************************************)
Lemma lem_or_and_conv_l :
 forall a b c d : Prop,
 a /\ b \/ c /\ d -> (a \/ c) /\ (b \/ c) /\ (a \/ d) /\ (b \/ d).
(* Proof                                                                   *)
intros; tauto.
Qed.
(* End of proof                                                            *)

Lemma lem_or_and_conv_r :
 forall a b c d : Prop,
 (a \/ c) /\ (b \/ c) /\ (a \/ d) /\ (b \/ d) -> a /\ b \/ c /\ d.
(* Proof                                                                   *)
intros; tauto.
Qed.
(* End of proof                                                            *)

Lemma lem_and_rew_r :
 forall P Q1 Q2 : Prop, (Q1 <-> Q2) -> (P /\ Q1 <-> P /\ Q2).
(* Proof                                                                   *)
intros; tauto.
Qed.
(* End of proof                                                            *)

Lemma lem_and_rew_l :
 forall P Q1 Q2 : Prop, (Q1 <-> Q2) -> (Q1 /\ P <-> Q2 /\ P).
(* Proof                                                                   *)
intros; tauto.
Qed.
(* End of proof                                                            *)

Lemma lem_and_assoc_l : forall a b c : Prop, (a /\ b) /\ c <-> a /\ b /\ c.
(* Proof                                                                   *)
intros; tauto.
Qed.
(* End of proof                                                            *)

(* Note : le /\ est associatif a droite en CoQ don pas de lemme symmetrique*)

Lemma lem_or_rew_l :
 forall P Q1 Q2 : Prop, (Q1 <-> Q2) -> (Q1 \/ P <-> Q2 \/ P).
(* Proof                                                                   *)
intros; tauto.
Qed.
(* End of proof                                                            *)

Lemma lem_or_rew_r :
 forall P Q1 Q2 : Prop, (Q1 <-> Q2) -> (P \/ Q1 <-> P \/ Q2).
(* Proof                                                                   *)
intros; tauto.
Qed.
(* End of proof                                                            *)

Lemma lem_or_assoc_l : forall a b c : Prop, (a \/ b) \/ c <-> a \/ b \/ c.
(* Proof                                                                   *)
intros; tauto.
Qed.
(* End of proof                                                            *)

(* Note : le \/ est associatif a droite en CoQ don pas de lemme symmetrique*)

Lemma lem_and_rew_lr :
 forall al bl ar br : Prop,
 (al <-> ar) -> (bl <-> br) -> (al /\ bl <-> ar /\ br).
(* Proof                                                                   *)
intros; tauto.
Qed.
(* End of proof                                                            *)

Lemma lem_or_rew_lr :
 forall al bl ar br : Prop,
 (al <-> ar) -> (bl <-> br) -> (al \/ bl <-> ar \/ br).
(* Proof                                                                   *)
intros; tauto.
Qed.
(* End of proof                                                            *)

(***************************************************************************)
(* Symmetry properties                                                     *)
(***************************************************************************)
Lemma lem_iff_sym : forall a b : Prop, (a <-> b) -> (b <-> a).
(* Proof of lem_iff_sym                                                    *)
intros; tauto.
Qed.
(* End of proof of lem_iff_sym                                             *)

Lemma lem_or_sym : forall a b : Prop, a \/ b -> b \/ a.
(* Proof of lem_or_sym                                                     *)
intros.
elim H; clear H; intros.
right; assumption.

left; assumption.

Qed.
(* End of proof of lem_or_sym                                              *)

Lemma lem_and_sym : forall a b : Prop, a /\ b -> b /\ a.
(* Proof of lem_and_sym                                                    *)
intros; tauto.

Qed.
(* End of proof of lem_and_sym                                             *)

(***************************************************************************)
(* Contraction and expansion                                               *)
(***************************************************************************)
Lemma lem_or_expand : forall a : Prop, a -> a \/ a.
(* Proof of lem_or_expand                                                  *)
intros; tauto.

Qed.
(* End of proof of lem_or_expand                                           *)

Lemma lem_and_expand : forall a : Prop, a -> a /\ a.
(* Proof of lem_and_expand                                                 *)
intros; tauto.

Qed.
(* End of proof of lem_and_expand                                          *)

Lemma lem_or_contract : forall a : Prop, a \/ a -> a.
(* Proof of lem_or_contract                                                *)
intros; tauto.

Qed.
(* End of proof of lem_or_contract                                         *)

Lemma lem_and_contract : forall a : Prop, a /\ a -> a.
(* Proof of lem_and_contract                                               *)
intros; tauto.

Qed.
(* End of proof of lem_and_contract                                        *)

(***************************************************************************)
(* Existenciel et unicite                                                  *)
(***************************************************************************)
Definition exUniq (A : Set) (P : A -> Prop) :=
  exists x : A, P x /\ (forall y : A, P y -> x = y).

Notation ExU := (exUniq _) (only parsing).

(***************************************************************************)
(*                     Next : any file you want                            *)
(***************************************************************************)


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation; either version 2.1 of the License, or
(at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

From Coq Require Import Arith Euclid Compare Lia.
From Coqtail Require Export Nle Nk_ind.
Open Scope nat_scope.

(** * Definitions *)
(** Definition of divisibility *)
Inductive Ndivide a b : Prop :=
| Ndivide_intro : forall q, b = q * a -> Ndivide a b.

(** Definition of a quotient *)
Inductive Nquotient a b : nat -> Prop :=
| Nquotient_intro : forall q, b = q * a -> Nquotient a b q.

(** Definition of modulus/remainder *)
Inductive Nmod a b : nat -> Prop :=
| Nmod_intro : forall q r, b = q * a + r -> r < a -> Nmod a b r.

(** Notation *)
Notation "( a | b )" := (Ndivide a b) (at level 0) : nat_scope.

(** Definition of coprimality *)
Definition Nrel_prime p q := forall n, (n | p) -> (n | q) -> n = 1.

(** Definition of primality *)
Definition Nprime p := 1<p /\ (forall n, 1 < n < p -> ~ (n | p)).

(* begin hide *)
Lemma Nprime_intro : forall p, 1 < p -> (forall n, 1 < n < p -> ~(n | p)) -> Nprime p.
intros.
split; auto.
Qed.
(* end hide *)

(** * Basic results on prime numbers *)
(** [0] is not prime *)
Lemma Nnot_prime_0 : ~(Nprime 0).
Proof.
unfold Nprime.
intro.
destruct H.
apply le_Sn_O in H.
exact H.
Qed.

(** [1] is not prime *)
Lemma Nnot_prime_1 : ~(Nprime 1).
Proof.
unfold Nprime.
intro.
destruct H.
apply lt_irrefl in H.
exact H.
Qed.

(** A prime number is greater than or equal to [2] *)
Lemma Nprime_ge_2 : forall (p:nat), Nprime p -> 2<=p.
Proof.
intros.
destruct p.
apply Nnot_prime_0 in H.
contradiction.
destruct p.
apply Nnot_prime_1 in H.
contradiction.
unfold Nprime in H.
destruct H.
auto with arith.
Qed.

(** A composed number is not prime *)
Lemma Ncomposed_not_prime : forall n m, 1 < n -> 1 < m -> ~(Nprime (n * m)).
Proof.
intros.
intro.
destruct H1.
apply H2 with n.
split.
auto with arith.
replace n with (n*1).
destruct n.
apply le_Sn_O in H.
contradiction.
rewrite <- mult_assoc.
apply mult_S_lt_compat_l.
rewrite mult_1_l.
trivial.
auto with arith.
exists m.
ring.
Qed.

(** * Basic properties of divisibility *)
(** Compatibility with addition *)
Lemma Ndiv_plus_compat : forall p a b, (p | a) -> (p | b) -> (p | a + b).
Proof.
intros.
destruct H.
destruct H0.
apply Ndivide_intro with (q+q0).
rewrite H. rewrite H0.
ring.
Qed.

(** Product divisiblity weakening *)
Lemma Nab_div_c : forall a b c, (a * b | c) -> (a | c).
Proof.
intros.
destruct H.
apply Ndivide_intro with (q*b).
rewrite H.
ring.
Qed.

(** A divisor is usually nonzero *)
Lemma Ndiv_non_0 : forall a b, (a | b) -> 1 <= b -> 1 <= a.
Proof.
intros.
destruct a.
destruct H.
rewrite mult_0_r in H.
rewrite H in H0.
exact H0.
auto with arith.
Qed.

(** Any number divides [0] *)
Lemma Ndiv_0 : forall a, (a | 0).
intros.
apply Ndivide_intro with 0.
ring.
Qed.

(** [1] divides any number *)
Lemma Ndiv_1 : forall a, (1 | a).
intros.
apply Ndivide_intro with a.
ring.
Qed.

(** Not divisor implies nonzero *)
Lemma Nnon_div_non_zero : forall a b, ~( a | b) -> b > 0.
intros.
destruct b.
destruct H.
apply Ndiv_0.
auto with arith.
Qed.

(** [n] divides [n] *)
Lemma Ndiv_n_n : forall n, (n|n).
Proof.
intro.
apply Ndivide_intro with 1.
ring.
Qed.

(** * Basic properties of quotient *)
(** Quotient implies divisibility *)
Lemma Nquotient_div : forall a b q, Nquotient a b q -> (a | b).
Proof.
intros.
destruct H.
apply Ndivide_intro with q.
auto.
Qed.

(** Compatibility with order *)
Lemma Nquotient_le_compat : forall a b c q p,
  Nquotient a b q -> Nquotient a c p -> 1 <= b <= c -> q <= p.
Proof.
intros.
assert (1<=a).
apply Ndiv_non_0 with b.
apply Nquotient_div with q.
exact H.
destruct H1.
exact H1.
assert (exists a',a=S a').
destruct a.
apply le_Sn_O in H2.
contradiction.
exists a.
reflexivity.
destruct H3.
destruct H.
destruct H0.
destruct H1.
rewrite H in H4.
rewrite H0 in H4.
rewrite H3 in H4.
apply mult_S_le_reg_l with x.
assert (S x*q=q*S x).
ring.
assert (S x*q0=q0*S x).
ring.
rewrite H5.
rewrite H6.
exact H4.
Qed.

(** * Properties of divisibility *)

(** Transitivity *)
Lemma Ndiv_trans : forall a b c, (a | b) -> (b | c) -> (a | c).
Proof.
intros.
destruct H.
destruct H0.
exists (q*q0).
rewrite H0.
rewrite H.
ring.
Qed.

(** Simplification of addition *)
Lemma Ndiv_plus_simpl : forall a b c, (a | b + c) -> (a | b) -> (a | c).
Proof.
intros.
destruct b.
destruct H.
apply Ndivide_intro with q.
auto with arith.

destruct H.
destruct H0.
apply Ndivide_intro with (q-q0).
assert (q0<=q).
apply Nquotient_le_compat with a (S b) (S b+c).
apply Nquotient_intro. exact H0.
apply Nquotient_intro. exact H.
split.
auto with arith.
auto with arith.
apply Nle_plus in H1.
destruct H1.
rewrite H1.
assert (q0+x-q0=x).
apply minus_plus.
rewrite H2.
rewrite H1 in H.
rewrite H0 in H.
rewrite mult_plus_distr_r in H.
rewrite plus_comm in H.
apply plus_reg_l with (q0*a).
rewrite plus_comm.
rewrite H.
auto with arith.
Qed.

(** Right implification of subtraction *)
Lemma Ndiv_minus_simpl_r : forall a b c, b >= c -> (a | b - c) -> (a | c) -> (a | b).
Proof.
intros.
apply Nle_plus in H.
destruct H.
rewrite H in * |- *.
rewrite minus_plus in H0.
apply Ndiv_plus_compat; auto.
Qed.

(** Left implification of subtraction *)
Lemma Ndiv_minus_simpl_l : forall a b c, b >= c -> (a | b - c) -> (a | b) -> (a | c).
Proof.
intros.
apply Nle_plus in H.
destruct H.
rewrite H in * |- *.
rewrite minus_plus in H0.
rewrite plus_comm in H1.
apply Ndiv_plus_simpl with x; auto.
Qed.

(** Weak compatibility with multiplication *)
Lemma Ndiv_mult_compat : forall a b q, (a | b) -> (a | b * q).
Proof.
intros.
destruct H.
apply Ndivide_intro with (q0*q).
rewrite H.
ring.
Qed.

(** Strong compatibility with multiplication *)
Lemma Ndiv_strong_mult_compat : forall a b q, (a|b) -> (a * q | b * q).
Proof.
intros.
destruct H.
apply Ndivide_intro with (q0).
rewrite H.
ring.
Qed.

(* begin hide *)
Lemma toto : forall a b q, S q * a = S q * b -> a = b.
  induction a.
  intros.
  rewrite mult_0_r in H.
  symmetry in H.
  apply mult_is_O in H.
  destruct H.
  discriminate H.
  auto.
  intros.
  destruct b.
  rewrite mult_0_r in H.
  discriminate H.
  assert (a=b).
  rewrite mult_succ_r in H.
  rewrite mult_succ_r in H.
  assert (S q  + S q * a= S q + S q * b).
  rewrite plus_comm.
  rewrite H.
  ring.
  apply plus_reg_l in H0.
  apply IHa with q.
  auto.
  rewrite H0.
  auto.
Qed.
(* end hide *)

(** Simplification of common factor *)
Lemma Ndiv_mult_simpl : forall a b q, q <> 0 -> (a * q | b * q) -> (a | b).
Proof.
intros.
destruct H0.
destruct q.
contradiction H.
reflexivity.
rewrite mult_assoc in H0.
assert (S q*b=S q*(q0*a)).
rewrite mult_comm.
rewrite H0.
ring.
assert (b=q0*a).
apply toto with q.
rewrite mult_comm.
rewrite H0.
ring.
apply Ndivide_intro with q0.
auto.
Qed.

(** Divisibility implies order *)
Lemma Ndiv_le : forall n p, 0 < p -> (n | p) -> n <= p.
Proof.
intros.
destruct H0.
destruct p.
apply lt_irrefl in H. contradiction.
destruct n.
auto with arith.
destruct q.
simpl in H0.
discriminate H0.
replace (S n) with (1*S n).
rewrite H0.
apply mult_le_compat.
auto with arith.
auto with arith.
rewrite mult_1_l.
trivial.
Qed.

(** Dividable by [0] implies zero *)
Lemma Ndiv_0_n : forall n, (0 | n) -> n = 0.
Proof.
destruct n.
trivial.
intro.
destruct H.
rewrite mult_0_r in H.
discriminate H.
Qed.

(** * Properties of coprimes *)

(** [n] and [n] are usually not coprime *)
Lemma Nnon_rel_prime_n_n : forall n, n <> 1 -> ~(Nrel_prime n n).
Proof.
intro.
intro.
intro.
unfold Nrel_prime in H0.
assert (n=1).
apply H0.
apply Ndiv_n_n.
apply Ndiv_n_n.
contradiction.
Qed.

(** Compatibility with modulus *)
Theorem Nrel_prime_mod : forall a b r, Nrel_prime a b -> Nmod a b r -> Nrel_prime a r.
Proof.
intros.
destruct H0.
unfold Nrel_prime in H.
unfold Nrel_prime.
intros.
assert (n|b).
rewrite H0.
apply Ndiv_plus_compat.
rewrite mult_comm.
apply Ndiv_mult_compat.
auto.
auto.
apply H.
auto.
auto.
Qed.

(** Symmetry *)
Lemma Nrel_prime_sym : forall a b, Nrel_prime a b -> Nrel_prime b a.
Proof.
intros.
intro.
intros.
apply H.
auto.
auto.
Qed.

(** Weakening from primality to coprimality *)
Lemma Nprime_le_rel_prime : forall n p, Nprime p -> 0 < n < p -> Nrel_prime n p.
Proof.
intros.
destruct H0.
destruct H.
intro.
intros.
assert (0<n0).
apply Ndiv_non_0 with n.
auto.
auto with arith.
assert (n0<p).
apply le_trans with (S n).
apply le_n_S.
apply Ndiv_le.
auto with arith.
trivial.
auto.
destruct n0.
apply Ndiv_0_n in H3.
rewrite H3 in H0.
inversion H0.
destruct n0.
trivial.
apply H2 in H4.
contradiction.
split.
auto with arith.
auto.
Qed.

(** A coprime of [0] is [1] *)
Lemma Nrel_prime_0 : forall n, Nrel_prime n 0 -> n = 1.
Proof.
intros.
apply H.
apply Ndiv_n_n.
apply Ndiv_0.
Qed.

(** Any number is coprime with [1] *)
Lemma Nrel_prime_1 : forall n, Nrel_prime n 1.
Proof.
intros.
intro.
intros.
destruct n0.
destruct H0.
rewrite mult_0_r in H0. auto.
apply Ndiv_le in H0.
destruct n0.
auto.
inversion H0.
inversion H2.
auto.
Qed.

(** * Gauss theorem *)
Theorem Ngauss : forall a b c, (a | b * c) -> Nrel_prime a b -> (a | c).
Proof.
apply (nat_strong_ind (fun a =>  forall b c, (a|b*c) -> Nrel_prime a b -> (a|c))).
intros.
destruct H.
rewrite mult_0_r in H.
apply mult_is_O in H.
destruct H.
rewrite H in H0.
apply Nnon_rel_prime_n_n in H0.
contradiction.
auto with arith.
rewrite H.
apply Ndiv_0.

intros.
destruct n.
apply Ndiv_1.

destruct H0.
assert (diveucl b (S (S n))).
apply eucl_dev.
auto with arith.
destruct H2.
assert (diveucl c (S(S n))).
apply eucl_dev.
auto with arith.
destruct H2.
rewrite e in H0.
rewrite e0 in H0.
rewrite mult_plus_distr_l in H0.
rewrite mult_plus_distr_r in H0.
rewrite mult_plus_distr_r in H0.
assert (S (S n)|r*r0).
apply Ndiv_plus_simpl with (q0 *S( S n) * r0).
apply Ndiv_plus_simpl with (r * (q1 * S(S n))).
apply Ndiv_plus_simpl with (q0 * S(S n) * (q1 * S(S n))).
apply Ndivide_intro with q.
rewrite <- H0.
ring.
apply Ndivide_intro with (q0*S(S n)*q1).
ring.
apply Ndivide_intro with (r*q1).
ring.
apply Ndivide_intro with (r0*q0).
ring.
destruct H2.
assert (Nrel_prime (S(S n)) r).
apply Nrel_prime_mod with b.
auto.
apply Nmod_intro with q0.
auto.
auto.
assert (r|q2).
apply H with (S(S n)).
auto with arith.
apply Ndivide_intro with r0.
rewrite mult_comm.
rewrite <- H2.
ring.
apply Nrel_prime_sym.
auto.
assert (S(S n)*r | r*r0).
rewrite H2.
rewrite mult_comm.
apply Ndiv_strong_mult_compat.
auto.
assert (S(S n)|r0).
apply Ndiv_mult_simpl with r.
destruct r.
rewrite plus_0_r in e.
assert (S(S n)|b).
apply Ndivide_intro with q0.
auto.
assert (S(S n)=1).
apply H1.
apply Ndiv_n_n.
auto.
discriminate H7.
auto with arith.
destruct H5.
apply Ndivide_intro with q3.
rewrite mult_comm.
rewrite H5.
ring.
rewrite e0.
apply Ndiv_plus_compat.
rewrite mult_comm.
apply Ndiv_mult_compat.
apply Ndiv_n_n.
auto.
Qed.

(** * Decidability of divisibility *)

(** Algorithm to compute a remainder modulus a number *)
Fixpoint Ndiv_mod_algo (n m:nat) {struct m} : nat :=
match n with
| 0 => 0
| S n' =>
  match m with
  | 0 => 0
  | S m' =>
    let tmp:=S (Ndiv_mod_algo n m') in
    match beq_nat n tmp with
    | true => 0
    | false => tmp
    end
  end
end.

(** Algorithm to decide divisibility *)
Definition Ndiv_algo (n m:nat) : bool :=
  beq_nat (Ndiv_mod_algo n m) 0.

  (* begin hide *)
  Lemma eq_nat_correct : forall n m, n<>m -> false=beq_nat n m.
  Proof.
  intros n.
  induction n.
  destruct m.
  intros.
  contradiction H. reflexivity.
  intros.
  compute. reflexivity.
  induction m.
  compute. reflexivity.
  simpl.
  intros.
  apply IHn.
  auto with arith.
  Qed.
(* end hide *)
(** [m] mod [n] equals [m] if [n] is greater than [m] *)
Lemma Ndiv_mod_l0 : forall n m, m < n -> Ndiv_mod_algo n m = m.
Proof.
induction m.
intros. destruct n. inversion H. compute. trivial.
intros.
destruct n.
inversion H.
simpl.
replace (Ndiv_mod_algo (S n) m) with m.
replace (beq_nat n m) with false.
reflexivity.
apply eq_nat_correct.
intro.
rewrite H0 in H.
apply lt_irrefl in H. contradiction.
symmetry.
apply IHm.
auto with arith.
Qed.

(** Simplification of addition *)
Lemma Ndiv_mod_l1 : forall n m, n > 0 -> Ndiv_mod_algo n (m + n) = Ndiv_mod_algo n m.
Proof.
intros n m. pattern m. apply nat_strong_ind.
intros. simpl.
induction n.
reflexivity.
simpl.
replace (Ndiv_mod_algo (S n) n) with n.
replace (beq_nat n n) with true.
reflexivity. apply beq_nat_refl.
symmetry.
apply Ndiv_mod_l0.
auto with arith.
intros.
induction n.
simpl. reflexivity.
simpl.
replace (Ndiv_mod_algo (S n) (n0+S n)) with (Ndiv_mod_algo (S n) n0); auto.
symmetry.
apply H.
auto with arith.
auto with arith.
Qed.

(** Correctness of divisibility algorithm *)
Theorem Ndiv_algo_correct : forall n m, n > 0 -> (n | m) -> Ndiv_algo n m=true.
Proof.
destruct n.
intros.
inversion H.
intro. pattern m.
apply nat_strong_ind.
intros.
compute. trivial.
intros.
unfold Ndiv_algo.
destruct H1.
destruct q.
simpl in H1.
inversion H1.
rewrite mult_succ_l in H1.
rewrite H1.
rewrite Ndiv_mod_l1.
apply H.
apply le_trans with (q*S n+n).
auto with arith.
rewrite plus_comm in H1.
simpl in H1.
apply eq_add_S in H1.
rewrite H1.
rewrite plus_comm.
auto with arith.
auto with arith.
exists q.
auto.
auto.
Qed.

(* The remainder is a remainder (strong condition) *)
Lemma Ndiv_mod_algo_rem : forall n m r, n > 0 -> Ndiv_mod_algo n m = r -> r < n.
Proof.
induction m.
intros.
destruct n. inversion H. compute in H0. rewrite <- H0. auto with arith.
intros.
destruct n. inversion H.
simpl in H0.
assert (Ndiv_mod_algo (S n) m<(S n)).
apply IHm. auto with arith. auto.
apply le_le_S_eq in H1.
destruct H1.
apply le_S_n in H1.
apply le_lt_n_Sm in H1.
apply lt_S_n in H1.
destruct (beq_nat n (Ndiv_mod_algo (S n) m)).
rewrite <- H0. auto with arith.
rewrite <- H0.
apply lt_n_S. auto.
apply eq_add_S in H1.
rewrite H1 in H0.
rewrite <- beq_nat_refl in H0.
rewrite <- H0.
auto with arith.
Qed.

(* The remainder is lower than or equal to number itself *)
Lemma Ndiv_mod_algo_rem2 : forall n m r, n > 0 -> Ndiv_mod_algo n m = r -> r <= m.
Proof.
induction m.
intros.
destruct n; compute in H0; rewrite <- H0; auto with arith.
intros.
simpl in H0.
destruct n. inversion H.
destruct (beq_nat (S n) (S (Ndiv_mod_algo (S n) m))).
rewrite <- H0. auto with arith.
destruct r.
inversion H0.
apply eq_add_S in H0.
apply le_n_S.
apply IHm.
auto.
auto.
Qed.

(** Completeness of modulus algorithm *)
Theorem Ndiv_mod_algo_complete : forall n m r, n > 0 -> Ndiv_mod_algo n m = r ->
(n | m - r).
Proof.
destruct n.
+ intros; inversion H.
+ intro m; pattern m; apply nat_strong_ind.
  - intros; compute in H0; rewrite <- H0.
    simpl; apply Ndiv_0.
  - intros; simpl in H1; case (lt_eq_lt_dec (S n) n0).
    intros; destruct s.

{ assert (exists d, n0=S n+d) by (apply Nle_plus; auto with arith).
  destruct H2; rewrite H2 in H1.
  assert (Ndiv_mod_algo (S n) (S n+x)=Ndiv_mod_algo (S n) (x+S n)) by (rewrite plus_comm; auto).
rewrite H3 in H1.
clear H3.
rewrite Ndiv_mod_l1 in H1.
rewrite H2.
replace (S (S n+x)) with (S n+S x) by auto with arith.
replace (S n+S x-r) with (S n+(S x-r)).
2: {
apply plus_minus.
replace (r+(S n+(S x-r))) with (S n+r+(S x-r)).
2: {
rewrite plus_assoc.
now auto with arith.
}
assert (S x=r+(S x-r)).
symmetry.
apply le_plus_minus_r.
destruct (beq_nat n (Ndiv_mod_algo (S n) x)).
rewrite <- H1. auto with arith.
destruct r. inversion H1.
apply eq_add_S in H1.
apply le_n_S.
apply Ndiv_mod_algo_rem2 with (S n).
auto with arith.
auto.
rewrite H3.
rewrite plus_assoc.
rewrite minus_plus.
auto.
}
apply Ndiv_plus_compat.
apply Ndiv_n_n.
apply H.
rewrite plus_Snm_nSm in H2.
apply le_trans with (S x+n).
auto with arith.
rewrite plus_comm.
rewrite <- H2.
auto with arith.
auto with arith.
auto.
auto with arith. }

    {
    rewrite <- e in H1.
    replace (Ndiv_mod_algo (S n) (S n)) with (Ndiv_mod_algo (S n) (0+S n)) in H1.
    rewrite Ndiv_mod_l1 in H1.
    simpl in H1; destruct n.
    { simpl in H1; rewrite <- H1; rewrite <- e; simpl; exists 2; ring. }
    { simpl in H1; rewrite <- H1; rewrite e; simpl; rewrite <- minus_n_O; apply Ndiv_n_n. }
    { auto with arith. }
    { simpl. auto. }
    }

    {
    intro;
    replace (Ndiv_mod_algo (S n) n0) with n0 in H1.
    apply le_le_S_eq in l.
    destruct l.
    assert (n<>n0).
    intro. rewrite H3 in H2. apply lt_irrefl in H2. auto.
    apply eq_nat_correct in H3.
    rewrite <- H3 in H1.
    rewrite <- H1.
    rewrite <- minus_diag_reverse.
    apply Ndiv_0.
    apply eq_add_S in H2.
    rewrite H2 in H1.
    rewrite <- beq_nat_refl in H1.
    rewrite <- H1.
    rewrite <- minus_n_O.
    rewrite H2.
    apply Ndiv_n_n.
    symmetry.
    apply Ndiv_mod_l0.
    auto. }
Qed.

(** Completeness of the divisibility algorith *)
Theorem Ndiv_algo_complete : forall n m, n>0 -> Ndiv_algo n m=true -> (n | m).
Proof.
intros.
unfold Ndiv_algo in H0.
symmetry in H0.
apply beq_nat_eq in H0.
replace m with (m-0).
apply Ndiv_mod_algo_complete.
auto.
auto.
auto with arith.
Qed.

(** * Greatest strict divisor *)
(** Algorithm to compute the greatest divisor lower than a number *)
Fixpoint Ngreatest_div_le (n:nat) (p:nat) {struct n}: nat :=
match n with
| 0 | 1 => 1
| S n =>
    if Ndiv_algo (S n) p then (S n)
    else Ngreatest_div_le n p
end.

(** Algorithm to compute the greatest strict divisor of a number *)
Definition Ngreatest_div (p:nat) : nat :=
  Ngreatest_div_le (pred p) p.

(** The greatest divisor is a divisor *)
Lemma Ngreatest_div_le_div : forall p n, p>1 -> (Ngreatest_div_le n p | p).
Proof.
induction n.
intros.
compute. apply Ndiv_1.
intros.
simpl.
destruct n. apply Ndiv_1.
assert(Ndiv_algo (S(S n)) p=true -> (S(S n)|p)).
intros. apply Ndiv_algo_complete. auto with arith. auto.
destruct (Ndiv_algo (S(S n)) p).
apply H0. auto.
auto.
Qed.

(** The greatest strict divisor is a divisor *)
Theorem Ngreatest_div_div : forall p, p > 1 -> (Ngreatest_div p | p).
Proof.
intros.
apply Ngreatest_div_le_div.
auto.
Qed.

(** The greatest divisor lower than a number is a lower than that number *)
Theorem Ngreatest_div_le_le : forall n p, n > 0 -> Ngreatest_div_le n p <= n.
Proof.
intros.
induction n.
inversion H.
simpl.
destruct n.
auto.
destruct (Ndiv_algo (S (S n)) p).
auto.
eapply le_trans.
eapply IHn. auto with arith.
auto with arith.
Qed.

(** The greatest divisor is a monotonous function *)
Theorem Ngreatest_div_le_monotone : forall n n' p,
  n <= n' -> Ngreatest_div_le n p <= Ngreatest_div_le n' p.
Proof.
intros.
induction H.
auto.
eapply le_trans.
eexact IHle.
assert (Ndiv_algo (S m) p=true -> Ngreatest_div_le (S m) p=S m).
intros.
simpl.
destruct m. auto.
rewrite H0. auto.
assert (Ndiv_algo (S m) p=false -> Ngreatest_div_le (S m) p=Ngreatest_div_le m p).
intros.
simpl.
destruct m. compute. auto.
rewrite H1. auto.
destruct (Ndiv_algo (S m) p).
rewrite H0.
destruct m. compute. auto.
eapply le_trans.
eapply Ngreatest_div_le_le. auto with arith.
auto with arith. auto.
rewrite H1. auto. auto.
Qed.

(** The greatest divisor is a the greatest divisor *)
Theorem Ngreatest_div_le_greatest : forall n p q,
  p>1 -> q>=1 -> q<p -> q<=n -> (q | p) -> q <= Ngreatest_div_le n p.
Proof.
intros.
replace q with (Ngreatest_div_le q p).
apply Ngreatest_div_le_monotone. auto.
destruct q.
inversion H0.
simpl.
destruct q.
auto.
apply Ndiv_algo_correct in H3.
rewrite H3. auto. auto with arith.
Qed.

(** The greatest strict divisor is a the greatest strict divisor *)
Theorem Ngreatest_div_greatest : forall p q,
  p>1 -> q>=1 -> q<p -> (q | p) -> q <= Ngreatest_div p.
Proof.
intros.
apply Ngreatest_div_le_greatest; auto.
destruct p. inversion H.
simpl. auto with arith.
Qed.

(** The greatest strict divisor is strict *)
Theorem Ngreatest_div_lt_p : forall n, n > 1 -> Ngreatest_div n < n.
Proof.
intros.
destruct n.
inversion H.
destruct n.
inversion H. inversion H1.
unfold lt.
apply le_n_S.
unfold Ngreatest_div.
replace (pred(S(S n))) with (S n).
apply Ngreatest_div_le_le.
auto with arith.
auto with arith.
Qed.

(** The greatest strict divisor is nonzero *)
Theorem Ngreatest_div_le_1 : forall n, Ngreatest_div n>=1.
Proof.
intros.
destruct n.
compute. auto.
destruct n. compute. auto.
apply Ngreatest_div_greatest.
auto with arith.
auto.
auto with arith.
apply Ndiv_1.
Qed.

(** * Decidability of primality with greatest strict divisor *)
(** Implication of greatest strict divisor on primality *)
Theorem Ngreatest_div_1_prime : forall p, p > 1 -> Ngreatest_div p = 1 -> Nprime p.
Proof.
intro.
destruct p.
intros. inversion H.
destruct p.
intros. inversion H. inversion H2.

intros.
split.
auto.
intros.
intro.
apply Ngreatest_div_greatest in H2.
rewrite H0 in H2.
destruct H1.
assert(1<1).
eapply le_trans.
eapply H1. auto.
inversion H4. inversion H6.
auto with arith.
destruct H1.
auto with arith.
destruct H1.
auto with arith.
Qed.

(** Implication of primality greatest divisor *)
Theorem Nprime_greatest_div_le_1 : forall n p, n<p -> Nprime p -> Ngreatest_div_le n p=1.
Proof.
induction n.
intros.
compute. auto.
intros.
simpl.
destruct n.
auto.
assert(~(Ndiv_algo (S (S n)) p=true)).
intro.
destruct H0.
apply H2 with (S(S n)).
split.
auto with arith. auto.
apply Ndiv_algo_complete.
auto with arith. auto.
destruct (Ndiv_algo (S (S n)) p).
contradiction H1. auto.
apply IHn.
auto with arith.
auto.
Qed.

(** Implication of primality greatest strict divisor *)
Theorem Nprime_greatest_div_1 : forall p, Nprime p -> Ngreatest_div p=1.
Proof.
intros.
apply Nprime_greatest_div_le_1.
destruct H.
inversion H;
auto with arith. auto.
Qed.

(** * Lowest strict divisor *)
(** Algorithm to compute the lowest divisor greater than a number *)
Fixpoint Nleast_div_ge (n p:nat) {struct n} : nat :=
match n with
| 0 => p
| S n =>
    if Ndiv_algo (p-S n) p then p-S n
    else Nleast_div_ge n p
end.

(** Algorithm to compute lowest strict divisor *)
Definition Nleast_div p := Nleast_div_ge (p-2) p.

(** Lowest divisor is a divisor *)
Lemma Nleast_div_ge_div : forall p n, p>1 -> n < p -> (Nleast_div_ge n p | p).
Proof.
induction n.
intros.
compute. apply Ndiv_n_n.
intros.
simpl.
assert (Ndiv_algo (p-S n) p=true -> (p-S n|p)).
apply Ndiv_algo_complete.
unfold gt.
apply (minus_le_compat_r (S (S n)) p (S n)) in H0.
rewrite <- minus_Sn_m in H0.
rewrite <- minus_n_n in H0.
eapply le_trans.
eapply H0. auto. auto.
destruct (Ndiv_algo (p-S n) p).
apply H1. auto.
apply IHn. auto.
auto with arith.
Qed.

(** Lowest divisor is usually greater than [1] *)
Theorem Nleast_div_ge_gt_1 : forall n p, p > 1 -> S n < p -> 1 < Nleast_div_ge n p.
Proof.
induction n.
intros.
compute. auto.
intros.
simpl.
destruct (Ndiv_algo (p-S n) p).
apply (minus_le_compat_r (S(S(S n))) p (S n)) in H0.
rewrite <- minus_Sn_m in H0.
rewrite <- minus_Sn_m in H0.
rewrite <- minus_n_n in H0.
auto. auto. auto.
apply IHn.
auto. auto with arith.
Qed.

(** Lowest strict divisor is greater than [1] *)
Theorem Nleast_div_gt_1 : forall p, p > 1 -> 1 < Nleast_div p.
Proof.
intros.
apply Nleast_div_ge_gt_1.
auto.
unfold lt.
assert(p>=2).
auto with arith.
apply Nle_plus in H0.
destruct H0.
rewrite H0.
rewrite minus_plus.
auto with arith.
Qed.

(** Lowest strict divisor is a divisor *)
Theorem Nleast_div_div : forall p, p>1 -> (Nleast_div p | p).
Proof.
intros.
apply Nleast_div_ge_div.
auto.
auto with arith.
Qed.

(** Lowest divisor greater than a number is greater than that number *)
Theorem Nleast_div_ge_ge : forall n p, n < p -> Nleast_div_ge n p >= p - n.
Proof.
induction n.
intros.
simpl.
rewrite <- minus_n_O.
auto.
intros.
simpl.
destruct (Ndiv_algo (p-S n) p).
auto.
unfold ge.
apply le_trans with (p-n).
apply minus_le_compat_l.
auto.
apply IHn. auto with arith.
Qed.

(** Lowest divisor is a monotonous function *)
Theorem Nleast_div_ge_monotone : forall n n' p,
  n <= n' -> n' < p -> Nleast_div_ge n p >= Nleast_div_ge n' p.
Proof.
intros.
induction H.
auto.
simpl.
destruct (Ndiv_algo (p-S m) p).
apply le_trans with (p-m).
apply minus_le_compat_l.
auto.
apply le_trans with (p-n).
apply minus_le_compat_l.
auto.
apply Nleast_div_ge_ge.
apply le_trans with (S m).
auto with arith.
auto with arith.
apply IHle.
auto with arith.
Qed.

(** Lowest divisor is lowest divisor *)
Theorem Nleast_div_ge_least : forall n p q,
  p > 1 -> q >= 1 -> q < p -> n < p -> q >= p-n -> (q | p) -> Nleast_div_ge n p <= q.
Proof.
intros.
replace q with (Nleast_div_ge (p-q) p).
apply Nleast_div_ge_monotone.
unfold ge in H3.
destruct (le_dec n p).
apply (plus_le_compat_l (p-n) q n) in H3.
rewrite le_plus_minus_r  in H3.
apply (minus_le_compat_r p (n+q) q) in H3.
rewrite plus_comm in H3.
rewrite minus_plus in H3.
auto.
auto.
apply le_trans with p.
apply le_minus.
auto.
auto.

destruct H1.
rewrite <- minus_Sn_m.
rewrite <- minus_n_n.
simpl. rewrite <- minus_n_O.
apply Ndiv_algo_correct in H4.
rewrite H4. auto. auto. auto.

rewrite <- minus_Sn_m.
simpl.
apply Ndiv_algo_correct in H4.
assert(q<=m).
auto with arith.
apply Nle_plus in H5.
destruct H5.
rewrite H5.
rewrite minus_plus.
rewrite plus_comm.
rewrite minus_plus.
rewrite H5 in H4.
rewrite plus_comm.
rewrite H4.
auto. auto. auto with arith.
Qed.

(** Lowest strict divisor is lowest divisor *)
Theorem Nleast_div_least : forall p q,
  p > 1 -> q > 1 -> q < p -> (q | p) -> Nleast_div p <= q.
Proof.
intros.
apply Nleast_div_ge_least.
auto. auto with arith. auto. auto with arith.
apply Nle_plus in H.
destruct H.
rewrite H.
rewrite minus_plus.
rewrite plus_comm.
rewrite minus_plus.
auto.
auto.
Qed.

(** * Decidability of primality with lowest strict divisor *)
(** Implication of lowest strict divisor on primality *)
Theorem Nleast_div_p_prime : forall p, p > 1 -> Nleast_div p = p -> Nprime p.
Proof.
intros.
destruct p.
inversion H.
split.
auto.
intros.
destruct H1.
intro.
apply Nleast_div_least in H3.
rewrite H0 in H3.
assert(n<n).
apply le_trans with (S p).
auto. auto.
apply lt_irrefl in H4. auto.
auto.
auto.
auto.
Qed.

(** Implication of primality on lowest divisor *)
Theorem Nprime_least_div_ge_p : forall n p, S n < p -> Nprime p -> Nleast_div_ge n p = p.
(* fixme: cette preuve est foireuse *)
induction n.
intros.
compute. auto.
intros.
destruct H0.
apply le_le_S_eq in H.
destruct H.
simpl.
assert(~(p-S n|p)).
apply H1.
split.
apply (minus_le_compat_r (S(S(S(S n)))) p (S n)) in H.
rewrite <- minus_Sn_m in H.
rewrite <- minus_Sn_m in H.
rewrite <- minus_Sn_m in H.
rewrite <- minus_n_n in H.
auto with arith.
auto.
auto.
auto with arith.
apply lt_minus.
apply le_trans with (S(S(S n))).
auto with arith. auto.
auto with arith.
auto with arith.
assert (~Ndiv_algo (p-S n) p=true).
intro.
apply H1 with (p-S n).
split.
apply (minus_le_compat_r (S(S(S(S n)))) p (S n)) in H.
rewrite <- minus_Sn_m in H.
rewrite <- minus_Sn_m in H.
rewrite <- minus_Sn_m in H.
rewrite <- minus_n_n in H.
auto with arith.
auto.
auto.
auto.
apply lt_minus.
apply le_trans with (S(S(S(S n)))).
auto. auto. auto with arith.
apply Ndiv_algo_complete.
unfold gt.
apply (minus_le_compat_r (S(S(S(S n)))) p (S n)) in H.
rewrite <- minus_Sn_m in H.
rewrite <- minus_Sn_m in H.
rewrite <- minus_Sn_m in H.
rewrite <- minus_n_n in H.
apply le_trans with 3. auto. auto. auto. auto. auto. auto. auto with arith.

destruct (Ndiv_algo (p-S n) p).
contradiction H3. auto.
apply IHn.
apply le_trans with (S(S(S(S n)))).
auto. auto.
split. auto. auto.

destruct p. inversion H.
destruct p. inversion H.
destruct p. inversion H.
do 3 apply eq_add_S in H.
rewrite H.
unfold Nleast_div_ge.
rewrite <- minus_Sn_m.
rewrite <- minus_Sn_m.
rewrite <- minus_n_n.
assert(~(Ndiv_algo 2 (S(S(S p)))=true)).
intro.
apply H1 with 2.
split. auto. auto with arith.
apply Ndiv_algo_complete. auto. auto.
destruct (Ndiv_algo 2 (S(S(S p)))).
contradiction H2. auto.
fold Nleast_div_ge.
rewrite <- H.
apply IHn.
auto.
split. auto with arith.
rewrite H.
auto.
auto.
auto.
Qed.

(** Implication of primality on lowest strict divisor *)
Theorem Nprime_least_div_p : forall p, Nprime p -> Nleast_div p = p.
Proof.
intros.
apply Nprime_least_div_ge_p.
destruct p.
apply Nnot_prime_0 in H. contradiction.
destruct p.
apply Nnot_prime_1 in H. contradiction.
rewrite minus_Sn_m.
apply le_trans with (S (S p)).
apply lt_n_S.
auto with arith. auto. auto with arith.
auto.
Qed.

(** Lowest strict divisor is prime *)
Theorem Nleast_div_prime : forall p, p>1 -> Nprime (Nleast_div p).
Proof.
intros.
split.
apply Nleast_div_gt_1.
auto.
intros.
intro.
destruct H0.
assert((n|p)).
apply Ndiv_trans with (Nleast_div p).
auto.
apply Nleast_div_div.
auto with arith.
apply Nleast_div_least in H3.
apply lt_irrefl with (Nleast_div p).
apply le_trans with (S n).
auto with arith.
auto.
auto with arith.
auto.
apply le_trans with (Nleast_div p).
auto.
apply Ndiv_le.
destruct p. inversion H.
auto with arith.
apply Nleast_div_div.
auto with arith.
Qed.

(** Lowest strict divisor is greater than [1] *)
Theorem Nleast_div_ge_2 : forall n, n > 1 -> Nleast_div n >= 2.
Proof.
intros.
assert(Nprime (Nleast_div n)).
apply Nleast_div_prime.
auto.
assert(0<=Nleast_div n).
auto with arith.
apply le_le_S_eq in H1.
destruct H1.
apply le_le_S_eq in H1.
destruct H1.
auto.
rewrite <- H1 in H0.
apply Nnot_prime_1 in H0. contradiction.
rewrite <- H1 in H0.
apply Nnot_prime_0 in H0. contradiction.
Qed.

(** Implication of lowest strict divisor on not primality *)
Theorem Nleast_div_lt_p_not_prime : forall n, n > 2 -> (Nleast_div n) < n -> ~(Nprime n).
Proof.
intros.
intro.
assert((Nleast_div n|n)).
apply Nleast_div_div.
auto with arith.
destruct H2.
destruct q.
rewrite mult_0_l in H2.
rewrite H2 in H.
inversion H.
destruct q.
rewrite mult_1_l in H2.
rewrite <- H2 in H0.
apply lt_irrefl in H0.
auto.
apply (Ncomposed_not_prime (S(S q)) (Nleast_div n)).
auto with arith.
apply Nleast_div_gt_1.
auto with arith.
rewrite H2 in H1. auto.
Qed.

(** Every number has a prime divisor *)
Theorem Nhas_prime_divisor : forall n, n > 1 -> exists p, Nprime p /\ (p | n).
Proof.
intros.
exists (Nleast_div n).
split.
apply Nleast_div_prime.
auto.
apply Nleast_div_div.
auto with arith.
Qed.

(** * Gauss theorem (prime formulation) *)
Theorem Ngauss_prime : forall a b c, (a | b * c) -> Nprime a -> (a | c) \/ (a | b).
Proof.
intros.
destruct a.
apply Nnot_prime_0 in H0. contradiction.

assert(Ndiv_algo (S(a)) b=true -> ((S(a))|b)).
intro. apply Ndiv_algo_complete. auto.
auto with arith. auto.
assert(Ndiv_algo (S a) b=false -> Nrel_prime (S a) b).
intro.
assert(~(S a|b)).
intro.
apply Ndiv_algo_correct in H3. rewrite H3 in H2. inversion H2.
auto with arith.
intro.
intros.
destruct n.
destruct H4. rewrite mult_0_r in H4. inversion H4.
destruct n.
auto.
destruct H0.
apply H6 in H4.
contradiction.
split.
auto with arith.
apply Ndiv_le in H4.
apply le_le_S_eq in H4.
destruct H4.
auto.
rewrite H4 in H5.
apply H3 in H5.
contradiction.
auto with arith.
destruct (Ndiv_algo (S a) b).
right.
apply H1.
auto.
left.
apply Ngauss with b.
apply H.
apply H2.
auto.
Qed.

(** * Compatibility of coprimality with multiplication *)
Theorem Nrel_prime_mult_compat : forall p n m,
  Nrel_prime p n -> Nrel_prime p m -> Nrel_prime p (n * m).
Proof.
intros.
intro.
intros.
destruct n0.
destruct H1.
rewrite mult_0_r in H1.
rewrite H1 in H.
destruct H2.
rewrite mult_0_r in H2.
apply mult_is_O in H2.
destruct H2.
rewrite H2 in H.
apply H.
apply Ndiv_n_n.
apply Ndiv_n_n.
rewrite H1 in H0.
rewrite H2 in H0.
apply H0.
apply Ndiv_n_n.
apply Ndiv_n_n.
destruct n0.
auto.

assert(exists pn0, Nprime pn0 /\ (pn0|(S(S n0)))).
apply Nhas_prime_divisor.
auto with arith.
destruct H3.
destruct H3.
assert((x|n*m)).
eapply Ndiv_trans.
eapply H4.
apply H2.
apply Ngauss_prime in H5.
assert(x=1).
destruct H5.
apply H0.
eapply Ndiv_trans. eapply H4. apply H1.
apply H5.
apply H.
eapply Ndiv_trans. eapply H4. apply H1.
apply H5.
rewrite H6 in H3.
apply Nnot_prime_1 in H3.
contradiction.
auto.
Qed.

(** * Primality results *)
(** Not prime implies composed *)
Theorem Nnot_prime_composed : forall n,
  n > 2 -> ~(Nprime n) -> exists p, exists q, p > 1 /\ q > 1 /\ n = p * q.
Proof.
intros.
exists(Nleast_div n).
assert(Nleast_div n|n).
apply Nleast_div_div.
auto with arith.
destruct H1.
exists q.
split.
apply Nleast_div_gt_1. auto with arith.
split.
destruct q.
rewrite mult_0_l in H1.
rewrite H1 in H.
inversion H.
destruct q.
rewrite mult_1_l in H1.
symmetry in H1.
apply Nleast_div_p_prime in H1.
apply H0 in H1. contradiction.
auto with arith.
auto with arith.
rewrite mult_comm. auto.
Qed.

(** A number if either prime or not prime *)
Theorem Nprime_or_not_prime : forall n, (Nprime n) \/ (~(Nprime n)).
Proof.
intros.
destruct n.
right. apply Nnot_prime_0.
destruct n.
right. apply Nnot_prime_1.
destruct n.
left.
apply Nprime_intro.
auto with arith.
intros.
destruct H.
inversion H.
rewrite H1 in H0.
apply lt_irrefl in H0. contradiction.
rewrite <- H2 in H0.
assert(2<2).
apply le_trans with (S m).
auto with arith. auto with arith.
apply lt_irrefl in H3. contradiction.
assert(beq_nat (Nleast_div (S(S(S n)))) (S(S(S n)))=true -> Nprime (S(S(S n)))).
intros.
apply Nleast_div_p_prime.
auto with arith.
apply beq_nat_true.
auto.
assert(beq_nat (Nleast_div (S(S(S n)))) (S(S(S n)))=false -> ~Nprime (S(S(S n)))).
intros.
assert(Nleast_div (S(S(S n)))<>(S(S(S n)))).
apply beq_nat_false.
auto.
apply not_eq in H1.
destruct H1.
apply Nleast_div_lt_p_not_prime.
auto with arith.
auto.
assert(Nleast_div (S(S(S n)))<=S(S(S n))).
apply Ndiv_le.
auto with arith.
apply Nleast_div_div.
auto with arith.
assert(S(S(S n))<S(S(S n))).
eapply le_trans.
eapply H1.
apply H2.
apply lt_irrefl in H3.
intro. auto.

destruct (beq_nat (Nleast_div (S (S (S n)))) (S (S (S n)))).
left. auto.
right. auto.
Qed.

(** A number is either prime or composed *)
Theorem Nprime_or_composed : forall n,
  n > 2 -> (Nprime n) \/ (exists p, exists q, p > 1 /\ q > 1 /\ n=p * q).
Proof.
intros.
assert(Nprime n \/ ~Nprime n).
apply Nprime_or_not_prime.
destruct H0.
left. auto.
right.
apply Nnot_prime_composed.
auto. auto.
Qed.

(** * Relation between lowest strict divisor and greatest strict divisor *)
Theorem Ngreatest_least_div_relation : forall n, n > 2 -> (Ngreatest_div n) * (Nleast_div n)=n.
Proof.
intros.
assert(Nprime n \/ ~Nprime n).
apply Nprime_or_not_prime.
destruct H0.
replace (Ngreatest_div n) with 1.
replace (Nleast_div n) with n.
ring.
symmetry.
apply Nprime_least_div_p. auto.
symmetry.
apply Nprime_greatest_div_1. auto.

assert(Q:~Nprime n).
auto. clear H0.
assert((Ngreatest_div n)*(Nleast_div n)<=n).
assert((Ngreatest_div n)|n).
apply Ngreatest_div_div. auto with arith.
destruct H0.
assert(q|n).
exists (Ngreatest_div n).
rewrite mult_comm. auto.
apply Nleast_div_least in H1.
rewrite H0 at 3.
rewrite mult_comm.
apply mult_le_compat_r.
auto.
auto with arith.
destruct q.
rewrite mult_0_l in H0. rewrite H0 in H. inversion H.
destruct q.
rewrite mult_1_l in H0.
assert(Ngreatest_div n<n).
apply Ngreatest_div_lt_p.
auto with arith.
rewrite <- H0 in H2 at 1.
apply lt_irrefl in H2.
contradiction.
auto with arith.
assert(q<=n).
apply Ndiv_le; auto. destruct n. inversion H. auto with arith.
apply le_le_S_eq in H2.
destruct H2.
auto.
rewrite H2 in H0.
destruct n.
inversion H.
assert(1<=Ngreatest_div (S n)).
apply Ngreatest_div_le_1.
apply le_le_S_eq in H3.
destruct H3.
replace q with (q*1).
rewrite H0.
rewrite H2.
apply mult_S_lt_compat_l.
auto. ring.
symmetry in H3.
apply Ngreatest_div_1_prime in H3.
apply Q in H3. contradiction.
auto with arith.

assert((Ngreatest_div n)*(Nleast_div n)>=n).
assert((Nleast_div n)|n).
apply Nleast_div_div. auto with arith.
destruct H1.
assert(q|n).
exists (Nleast_div n).
rewrite mult_comm. auto.
apply Ngreatest_div_greatest in H2.
unfold ge.
rewrite H1 at 1.
apply mult_le_compat_r.
auto.
auto with arith.
destruct q.
rewrite mult_0_l in H1.
rewrite H1 in H. inversion H.
auto with arith.
apply Ndiv_le in H2.
apply le_le_S_eq in H2.
destruct H2.
auto.
rewrite H2 in H1.
assert(Nleast_div n>=2).
apply Nleast_div_ge_2.
destruct n. inversion H.
auto with arith.
replace q with (q*1).
rewrite H1.
rewrite H2.
destruct n.
inversion H.
apply mult_S_lt_compat_l.
auto. ring.
destruct n.
inversion H.
auto with arith.

apply le_antisym; auto.
Qed.

Lemma div_mod a b : a <> 0 -> (a | b) <-> b mod a = 0.
Proof.
  intros az; split.
  - intros (k, ->). apply Nat.mod_mul, az.
  - intros e. exists (b / a).
    etransitivity. apply (Nat.div_mod _ a), az.
    lia.
Qed.

Lemma eqmod_div m a b : m <> 0 -> a <= b -> a mod m = b mod m <-> (m | b - a).
Proof.
  intros mz l; split.
  - intros e. exists ((b / m) - (a / m)).
    rewrite Nat.mul_comm, Nat.mul_sub_distr_l.
    rewrite (Nat.div_mod a m mz) at 1.
    rewrite (Nat.div_mod b m mz) at 1.
    lia.
  - intros (k, e).
    assert (b = a + k * m) by lia.
    assert (b mod m = (a + k * m) mod m) as -> by congruence.
    rewrite Nat.mod_add; auto.
Qed.

Lemma Nrel_prime_eqmod m a b :
  m <> 0 ->
  a mod m = b mod m ->
  Nrel_prime m a ->
  Nrel_prime m b.
Proof.
  intros mz ab ma x xm xb.
  apply (ma x xm); clear ma.
  destruct (le_lt_dec a b) as [le|lt].
  - rewrite eqmod_div in ab; auto.
    destruct xb as (k & ->).
    destruct xm as (l & ->).
    destruct ab as (m & em).
    exists (k - m * l).
    replace ((k - m * l) * x) with (k * x - m * (l * x)). lia.
    rewrite Nat.mul_sub_distr_r. lia.
  - symmetry in ab.
    rewrite eqmod_div in ab; auto. 2:lia.
    destruct xb as (k & ->).
    destruct xm as (l & ->).
    destruct ab as (m & em).
    exists (m * l + k).
    replace ((m * l + k) * x) with (k * x + m * (l * x)). lia.
    rewrite Nat.mul_add_distr_r. lia.
Qed.

Lemma Ndivide_eqmod m a b :
  m <> 0 ->
  a mod m = b mod m ->
  (m | a) <-> (m | b).
Proof.
  intros mz ab.
  rewrite 2 div_mod; auto.
  split; lia.
Qed.

Lemma Nrel_prime_prime (a p : nat) :
  Nprime p ->
  Nrel_prime a p <-> ~ (p | a).
Proof.
  intros Pp.
  pose proof Nprime_ge_2 _ Pp as p2.
  split; intros ap.
  - intros pa.
    specialize (ap p pa (Ndiv_n_n _)).
    lia.
  - apply Nrel_prime_sym.
    eapply Nrel_prime_eqmod with (a mod p).
    lia.
    now rewrite Nat.mod_mod; lia.
    apply Nrel_prime_sym, Nprime_le_rel_prime; auto.
    split.
    + rewrite (Ndivide_eqmod _ _ (a mod p)) in ap.
      2: lia.
      2: now rewrite Nat.mod_mod; lia.
      enough (0 <> a mod p) by lia.
      intros e. apply ap. rewrite <-e.
      apply Ndiv_0.
    + apply Nat.mod_upper_bound. lia.
Qed.


Require Export List.
Add LoadPath "../../lnt/tense-logic-in-Coq".
Require Import Strong_induction.
Set Implicit Arguments.
Export ListNotations.

Delimit Scope My_scope with M.
Open Scope My_scope.

(**Defintions**)

(*Definitaion of Propositional Variables*)
Parameter PropVars : Set.
Hypothesis Varseq_dec : forall x y:PropVars, {x = y} + {x <> y}.

(*Definition of Propositional Formulas*)
Inductive PropF : Set :=
 | Var : PropVars -> PropF
 | Bot : PropF
 | Imp : PropF -> PropF -> PropF
.

Notation "# P" := (Var P) (at level 1) : My_scope.
Notation "A → B" := (Imp A B) (at level 16, right associativity) : My_scope.
Notation "⊥" := Bot (at level 0)  : My_scope.

(* Defined connectives *)
Notation "¬ A" := (A → ⊥) (at level 1)  : My_scope.
Notation "A ∧ B" := ((A → (B → ⊥)) → ⊥) (at level 15, right associativity) : My_scope.
Notation "A ∨ B" := ((A → ⊥) → B) (at level 15, right associativity) : My_scope.

(* Valuations are maps PropVars -> bool sending ⊥ to false*)
Fixpoint TrueQ v A : bool := match A with
 | # P   => v P
 | ⊥     => false
 | B → C => (negb (TrueQ v B)) || (TrueQ v C)
end.

(* Prove that the defined connectives are correct *)

Lemma def_neg_correct (A: PropF) :
  forall v, TrueQ v (¬ A) = negb (TrueQ v A).
Proof. intros. destruct A.
       simpl. rewrite Bool.orb_false_r. trivial.
       simpl. trivial.
       simpl. rewrite Bool.orb_false_r. trivial.
Qed.

Lemma def_or_correct (A B: PropF) :
  forall v, TrueQ v (A ∨ B) = orb (TrueQ v A) (TrueQ v B).
Proof. intros. simpl. repeat rewrite Bool.orb_false_r.
       rewrite Bool.negb_involutive.
       trivial.
Qed.

Lemma def_and_correct (A B: PropF) :
  forall v, TrueQ v (A ∧ B) = andb (TrueQ v A) (TrueQ v B).
Proof. intros. simpl. repeat rewrite Bool.orb_false_r.
       repeat rewrite Bool.negb_orb.
       repeat rewrite Bool.negb_involutive.
       reflexivity.
Qed.

Fixpoint  weight p :=
    match p with
      | # q' => 0
      | Bot => 0
      | p' → q' => S (max (weight p') (weight q'))
      end.

(*Gentzen's Sequent Calculus*)

Reserved Notation "Γ |- Δ >> n" (at level 80).
Inductive LK : nat -> list PropF -> list PropF -> Prop :=
| LKId  : forall A Γ Δ, In (Var A) Δ -> In (Var A) Γ -> LK 0 Γ Δ
| LKBot : forall Γ Δ,   In ⊥ Γ  -> LK 0 Γ Δ
| LKImpL : forall n m A B Γ1 Γ2 Δ,
              LK n (Γ1++B::Γ2) Δ -> LK m (Γ1++Γ2) (A::Δ)
           -> LK (S (max n m)) (Γ1++A→B::Γ2) Δ
| LKImpR : forall n A B Γ Δ1 Δ2,
              LK n (A::Γ) (Δ1++B::Δ2)
           -> LK (S n) Γ (Δ1++A→B::Δ2)
where "Γ |- Δ >> n" := (LK (n) (Γ) (Δ)) : My_scope.

(**Auxiliary Lemmas**)

Lemma in_elt : forall (A : Type) (a : A) L1 L2, In a (L1 ++ a :: L2).
Proof.
intros.
apply in_app_iff.
right.
simpl.
left.
reflexivity.
Qed.

Lemma cons_eq_app: forall (A : Type) (x y z : list A) (a : A),
  a :: x = y ++ z -> y = [] /\ z = a :: x \/
                         exists (y' : list A), y = a :: y' /\ x = y' ++ z.
Proof.
intros.
destruct y.
 simpl in H. subst. tauto.
 simpl in H. injection H. intros. right. subst. exists y. tauto.
Qed.

Lemma app_eq_app: forall (A : Type) (w x y z : list A),
  w ++ x = y ++ z -> exists (m : list A),
    w = y ++ m /\ z = m ++ x \/ y = w ++ m /\ x = m ++ z.
Proof.
 intro. intro.
 induction w.
    simpl. intros. exists y. rewrite H. tauto.

    intros. simpl in H.
    apply cons_eq_app in H.
    destruct H.  destruct H. rewrite H. simpl.
    exists (a :: w). rewrite H0. simpl. tauto.
    destruct H. destruct H.
    apply IHw in H0. destruct H0. destruct H0. destruct H0.
    rewrite H.  rewrite H0.  rewrite H1.  simpl.
    exists x1. tauto.
    destruct H0. rewrite H.  rewrite H0.  rewrite H1.  simpl.
    exists x1. tauto.
Qed.

Lemma cons_single_app: forall T (A : T) L, A :: L = [A] ++ L.
Proof.
reflexivity.
Qed.

Lemma in_app_comm : forall (A : Type) (a : A) (X Y : list A), In a (X ++ Y) <-> In a (Y ++ X).
Proof.
intros.
induction X.

rewrite app_nil_r.
rewrite app_nil_l.
reflexivity.

rewrite! in_app_iff.
firstorder.
Qed.

Lemma in_cons_comm : forall (A : Type) (a b c: A) (X Y : list A), In a (X ++ b :: c :: Y) <-> In a (X ++ c :: b :: Y).
Proof.
intros.
rewrite! in_app_iff.
simpl.
firstorder.
Qed.

Lemma in_list_eq : forall {A : Type} {l1 l2 l3 : list A} {a : A}, (l1 ++ a :: l2) = l3 -> In a l3.
Proof.
intros.
rewrite <- H.
apply in_app_iff.
right.
apply in_eq.
Qed.

Lemma le_trans: forall a b c, a <= b -> b <= c -> a <= c.
Proof.
intros.
rewrite H.
assumption.
Qed.

Lemma in_app_add: forall (A : Type) (a : A) (L1 L2 : list A), In a L1 -> In a (L1 ++ L2).
Proof.
intros.
induction L2.

rewrite app_nil_r.
assumption.

rewrite cons_single_app.
apply in_app_comm.
simpl.
right.
apply in_app_comm.
assumption.
Qed.

Lemma imp_not_var: forall A B C L1 L2, In (# A) (L1 ++ Imp B C :: L2) -> In (# A) (L1 ++ L2).
Proof.
intros.
apply in_app_comm in H.
simpl in H.
destruct H.

discriminate.
apply in_app_comm.
assumption.
Qed.

Lemma imp_not_bot: forall B C L1 L2, In Bot (L1 ++ Imp B C :: L2) -> In Bot (L1 ++ L2).
Proof.
intros.
apply in_app_comm in H.
simpl in H.
destruct H.

discriminate.
apply in_app_comm.
assumption.
Qed.

Lemma in_double: forall (A : Type) (a : A) B L1 L2 L3, In a (L1 ++ B :: L2 ++ B :: L3) -> In a (L1 ++ B :: L2 ++ L3) .
Proof.
intros.
rewrite in_app_iff in H.
simpl in H.
rewrite or_comm in H.
rewrite or_assoc in H.
destruct H.

subst.
firstorder.

rewrite in_app_comm in H.
rewrite <- app_comm_cons in H.
simpl in H.
rewrite in_app_comm in H.
rewrite or_comm in H.
rewrite in_app_iff.
assumption.
Qed.

(*Sanity Check that Γ1,A,Γ2 |- Δ1,A,Δ2 is Deriavable *)

Lemma Id_extension : forall A Γ Δ, In A Δ -> In A Γ -> exists n, weight A <= n /\ Γ |- Δ >> n.
Proof.
intros A.
induction A.

(*PropVar*)
intros.
exists 0.
split.
apply le_n.
apply (LKId p _ _ H H0).

(*Bot*)
intros.
exists 0.
split.
apply le_n.
apply (LKBot _ _ H0).

(*Imp*)
intros.
simpl.
apply in_split in H.
destruct H as [l1 [l2 Z1]].
apply in_split in H0.
destruct H0 as [l3 [l4 Z2]].
subst.
destruct (IHA1 (A1 :: l3 ++ l4) (A1 :: l1 ++ A2 :: l2) (in_eq A1 _) (in_eq A1 _)) as [a [I1 I2]].
destruct (IHA2 ((A1 :: l3) ++ A2 :: l4) (l1 ++ A2 :: l2) (in_elt A2 _ _) (in_elt A2 _ _)) as [b [I3 I4]].
pose (LKImpL _ _ _ I4 I2) as I5.
exists (S (S (max b a))).
split.

rewrite PeanoNat.Nat.max_comm.
apply (le_n_S _ _ (le_S _ _ (PeanoNat.Nat.max_le_compat _ _ _ _ I3 I1))).

apply (LKImpR _ _ _ I5).
Qed.

(*Proof of Other Structural Inferences*)

Lemma exchange_R:
  forall n Γ E F Δ1 Δ2 (D: LK n Γ (Δ1 ++ E :: F :: Δ2)), LK n Γ (Δ1 ++ F :: E :: Δ2).
Proof.
intros n.
induction n using strong_induction.

(*Base Case*)
intros.
inversion D as [ A ΓT ΔT Suc Ant Height EqS EqA | ΓT ΔT Fal EqS EqA | a b A B ΓA ΓB ΔT L R Height EqS EqA | a A B ΓT ΔA ΔB I Height EqS EqA].

(*Id*)
apply in_cons_comm in Suc.
apply (LKId _ _ _ Suc Ant).

(*Bot*)
apply (LKBot _ _ Fal).

(*Inductive*)
intros.
inversion D as [ A ΓT ΔT Suc Ant Height EqS EqA | ΓT ΔT Fal EqS EqA | a b A B ΓA ΓB ΔT L R Height EqS EqA | a A B ΓT ΔA ΔB I Height EqS EqA].

(*ImpL*)
subst.
pose (H _ (PeanoNat.Nat.le_max_l _ _) _ _ _ _ _ L) as L1.
rewrite app_comm_cons in R.
pose (H _ (PeanoNat.Nat.le_max_r _ _) _ _ _ _ _ R) as R1.
apply (LKImpL _ _ _ L1 R1).

(*ImpR*)
subst.
destruct (app_eq_app _ _ _ _ EqA) as [l [ [Z1 Z2] | [Z1 Z2] ]].

destruct l.

rewrite app_nil_r in Z1.
inversion Z2.
subst.
pose (H _ (le_n _) _ _ _ _ _ I) as I1.
rewrite (cons_single_app F) in *.
rewrite app_assoc in *.
apply (LKImpR _ _ _ I1).

destruct l.

inversion Z2.
subst.
rewrite app_assoc_reverse in I.
pose (H _ (le_n _) _ _ _ _ _ I) as I1.
apply (LKImpR _ _ _ I1).

inversion Z2.
subst.
rewrite app_assoc_reverse in I.
rewrite <- !app_comm_cons in I.
pose (H _ (le_n _) _ _ _ _ _ I) as I1.
rewrite! app_comm_cons in *.
rewrite app_assoc in *.
apply (LKImpR _ _ _ I1).

destruct l.

rewrite app_nil_r in Z1.
inversion Z2.
subst.
pose (H _ (le_n _) _ _ _ _ _ I) as I1.
rewrite (cons_single_app F _).
rewrite (cons_single_app F _) in I1.
rewrite app_assoc in *.
apply (LKImpR _ _ _ I1).

inversion Z2.
subst.
rewrite app_comm_cons in I.
rewrite app_assoc in I.
pose (H _ (le_n _) _ _ _ _ _ I) as I1.
rewrite app_assoc_reverse in *.
apply (LKImpR _ _ _ I1).
Qed.

Lemma exchange_L:
  forall n E F Γ1 Γ2 Δ (D: LK n (Γ1 ++ E :: F :: Γ2) Δ), LK n (Γ1 ++ F :: E :: Γ2) Δ.
Proof.
intro n.
induction n using strong_induction.

(*Base Case*)
intros.
inversion D as [ A ΓT ΔT Suc Ant Height EqS EqA | ΓT ΔT Fal EqS EqA | a b A B ΓA ΓB ΔT L R Height EqS EqA | a A B ΓT ΔA ΔB I Height EqS EqA].

(*Id*)
apply in_cons_comm in Ant.
apply (LKId _ _ _ Suc Ant).

(*Bot*)
apply in_cons_comm in Fal.
apply (LKBot _ _ Fal).

(*Inductive*)
intros.
inversion D as [ A ΓT ΔT Suc Ant Height EqS EqA | ΓT ΔT Fal EqS EqA | a b A B ΓA ΓB ΔT L R Height EqS EqA | a A B ΓT ΔA ΔB I Height EqS EqA].

(*ImpL*)
subst.
destruct (app_eq_app _ _ _ _ EqS) as [l [ [Z1 Z2] | [Z1 Z2] ]].

destruct l.

rewrite app_nil_r in Z1.
inversion Z2.
subst.
pose (H _ (PeanoNat.Nat.le_max_l _ _) _ _ _ _ _ L) as L1.
rewrite (cons_single_app F) in *.
rewrite app_assoc in *.
apply (LKImpL _ _ _ L1 R).

inversion Z2 as [[Z3 Z4]].
destruct l.

inversion Z4.
subst.
rewrite app_assoc_reverse in L.
pose (H _ (PeanoNat.Nat.le_max_l _ _) _ _ _ _ _ L) as L1.
rewrite app_assoc_reverse in R.
apply (LKImpL _ _ _ L1 R).

inversion Z4.
subst.
rewrite app_assoc_reverse in L.
pose (H _ (PeanoNat.Nat.le_max_l _ _) _ _ _ _ _ L) as L1.
rewrite app_assoc_reverse in R.
pose (H _ (PeanoNat.Nat.le_max_r _ _) _ _ _ _ _ R) as R1.
rewrite! app_comm_cons in *.
rewrite app_assoc in *.
apply (LKImpL _ _ _ L1 R1).

destruct l.

rewrite app_nil_r in Z1.
inversion Z2.
subst.
pose (H _ (PeanoNat.Nat.le_max_l _ _) _ _ _ _ _ L) as L1.
rewrite (cons_single_app F) in *.
rewrite app_assoc in *.
apply (LKImpL _ _ _ L1 R).

inversion Z2.
subst.
rewrite app_comm_cons in L.
rewrite app_assoc in L.
pose (H _ (PeanoNat.Nat.le_max_l _ _) _ _ _ _ _ L) as L1.
rewrite app_assoc in R.
pose (H _ (PeanoNat.Nat.le_max_r _ _) _ _ _ _ _ R) as R1.
rewrite app_assoc_reverse in *.
apply (LKImpL _ _ _ L1 R1).

(*ImpR*)
subst.
rewrite app_comm_cons in I.
pose (H _ (le_n _) _ _ _ _ _ I) as I1.
apply (LKImpR _ _ _ I1).
Qed.

(*Strengthening Exchange from Single Elements to Lists*)
(*----------------------------------------------------*)

Lemma move_R_R: forall n Γ A Δ3 Δ2 Δ1,
                LK n Γ (Δ1 ++ A :: Δ2 ++ Δ3) ->
                LK n Γ (Δ1 ++ Δ2 ++ A :: Δ3).
Proof.
intros n Γ A Δ3 Δ2.
induction Δ2.

intros.
assumption.

intros.
rewrite cons_single_app.
rewrite app_assoc_reverse.
rewrite app_assoc.
apply IHΔ2.
rewrite app_assoc_reverse.
apply exchange_R.
assumption.
Qed.

Lemma swap_R:
  forall n Γ Δ2 Δ3 Δ1 Δ4,
    LK n Γ (Δ1 ++ Δ2 ++ Δ3 ++ Δ4) ->
    LK n Γ (Δ1 ++ Δ3 ++ Δ2 ++ Δ4).
Proof.
intros n Γ Δ2 Δ3.
induction Δ2.

intros.
assumption.

intros.
apply move_R_R.
rewrite cons_single_app.
rewrite app_assoc.
rewrite cons_single_app in H.
rewrite app_assoc_reverse in H.
rewrite app_assoc in H.
apply (IHΔ2 _ _ H).
Qed.

Lemma move_R_L:
  forall n Δ A Γ3 Γ2 Γ1,
    LK n (Γ1 ++ A :: Γ2 ++ Γ3) Δ ->
    LK n (Γ1 ++ Γ2 ++ A :: Γ3) Δ.
Proof.
intros n Δ A Γ3 Γ2.
induction Γ2.

intros.
assumption.

intros.
rewrite cons_single_app.
rewrite app_assoc_reverse.
rewrite app_assoc.
apply IHΓ2.
rewrite app_assoc_reverse.
apply exchange_L.
assumption.
Qed.

Lemma swap_L:
  forall n Δ Γ2 Γ3 Γ1 Γ4,
    LK n (Γ1 ++ Γ2 ++ Γ3 ++ Γ4) Δ->
    LK n (Γ1 ++ Γ3 ++ Γ2 ++ Γ4) Δ.
Proof.
intros n Δ Γ2 Γ3.
induction Γ2.

intros.
assumption.
intros.

apply move_R_L.
rewrite cons_single_app in H.
rewrite app_assoc_reverse in H.
rewrite app_assoc in H.

rewrite cons_single_app.
rewrite app_assoc.
apply (IHΓ2 (Γ1 ++ [a]) Γ4 H).
Qed.

(*-----------------------------------------*)
(*Return to Proofs of Structural Inferneces*)

Lemma weakening_R:
  forall n Γ Δ1 Δ2 (D: LK n Γ (Δ1 ++ Δ2)),
    forall W, (LK n Γ (Δ1 ++ W ++ Δ2)).
Proof.
intro n.
induction n using strong_induction.

(*Base Case*)
intros.
inversion D as [ A ΓT ΔT Suc Ant Height EqS EqA | ΓT ΔT Fal EqS EqA | a b A B ΓA ΓB ΔT L R Height EqS EqA | a A B ΓT ΔA ΔB I Height EqS EqA].

(*Id*)
rewrite in_app_comm in Suc.
apply (in_app_add _ _ W) in Suc.
rewrite app_assoc_reverse in Suc.
rewrite in_app_comm in Suc.
rewrite app_assoc_reverse in Suc.
apply (LKId _ _ _ Suc Ant).

(*Bot*)
apply (LKBot _ _ Fal).

(*Inductive*)
intros.
inversion D as [ A ΓT ΔT Suc Ant Height EqS EqA | ΓT ΔT Fal EqS EqA | a b A B ΓA ΓB ΔT L R Height EqS EqA | a A B ΓT ΔA ΔB I Height EqS EqA].

(*ImpL*)
subst.
pose (H _ (PeanoNat.Nat.le_max_l _ _) _ _ _ L W) as L1.
rewrite app_comm_cons in R.
pose (H _ (PeanoNat.Nat.le_max_r _ _) _ _ _ R W) as R1.
apply (LKImpL _ _ _ L1 R1).

(*ImpR*)
subst.
rewrite <- app_nil_r.
rewrite! app_assoc_reverse.
apply swap_R.
rewrite app_assoc.
rewrite <- EqA.
rewrite app_assoc_reverse.
rewrite <- app_nil_r in I.
pose (H _ (le_n _) _ _ _ I W) as I1.
rewrite! app_assoc_reverse in I1.
apply (LKImpR _ _ _ I1).
Qed.

Lemma weakening_L:
    forall n Γ1 Γ2 Δ (D: LK n (Γ1 ++ Γ2) Δ),
      forall W, LK n (Γ1 ++ W ++ Γ2) Δ.
Proof.
intro n.
induction n using strong_induction.

(*Base Case*)
intros.
inversion D as [ A ΓT ΔT Suc Ant Height EqS EqA | ΓT ΔT Fal EqS EqA | a b A B ΓA ΓB ΔT L R Height EqS EqA | a A B ΓT ΔA ΔB I Height EqS EqA].

(*Id*)
rewrite in_app_comm in Ant.
apply (in_app_add _ _ W) in Ant.
rewrite app_assoc_reverse in Ant.
rewrite in_app_comm in Ant.
rewrite app_assoc_reverse in Ant.
apply (LKId _ _ _ Suc Ant).

(*Bot*)
rewrite in_app_comm in Fal.
apply (in_app_add _ _ W) in Fal.
rewrite app_assoc_reverse in Fal.
rewrite in_app_comm in Fal.
rewrite app_assoc_reverse in Fal.
apply (LKBot _ _ Fal).

(*Inductive*)
intros.
inversion D as [ A ΓT ΔT Suc Ant Height EqS EqA | ΓT ΔT Fal EqS EqA | a b A B ΓA ΓB ΔT L R Height EqS EqA | a A B ΓT ΔA ΔB I Height EqS EqA].

(*ImpL*)
subst.
destruct (app_eq_app _ _ _ _ EqS) as [l [ [Z1 Z2] | [Z1 Z2] ]].

subst.
rewrite app_assoc_reverse in L.
pose (H _ (PeanoNat.Nat.le_max_l _ _) _ _ _ L W) as L1.
rewrite app_assoc_reverse in R.
pose (H _ (PeanoNat.Nat.le_max_r _ _) _ _ _ R W) as R1.
rewrite! app_assoc in *.
apply (LKImpL _ _ _ L1 R1).

subst.
pose (H _ (PeanoNat.Nat.le_max_l _ _) _ _ _ L W) as L1.
pose (H _ (PeanoNat.Nat.le_max_r _ _) _ _ _ R W) as R1.
rewrite app_assoc_reverse.
apply swap_L.
rewrite <- Z2.
rewrite app_assoc in *.
apply (LKImpL _ _ _ L1 R1).

(*ImpR*)
subst.
rewrite app_comm_cons in I.
pose (H _ (le_n _) _ _ _ I W) as I1.
apply (LKImpR _ _ _ I1).
Qed.

(* Implication left derives one sequent from two previously derived sequents
   so inversion is split into two lemmas, one for each of the sequents    *)

Lemma inv_ImpL1 :
  forall n E F Γ1 Γ2 Δ (D: LK n (Γ1 ++ E→F :: Γ2) Δ),
    (exists m, m <= n /\ LK m (Γ1 ++ Γ2) (E::Δ)).
Proof.
intros n.
induction n using strong_induction.

(*Base Case*)
intros.
exists 0.
split.

apply le_n.

inversion D as [ A ΓT ΔT Suc Ant Height EqS EqA | ΓT ΔT Fal EqS EqA | a b A B ΓA ΓB ΔT L R Height EqS EqA | a A B ΓT ΔA ΔB I Height EqS EqA].

(*Id*)
apply imp_not_var in Ant.
pose (in_app_add _ Δ [E] Suc) as Suc1.
apply in_app_comm in Suc1.
apply (LKId _ _ _ Suc1 Ant).

(*Bot*)
apply imp_not_bot in Fal.
apply (LKBot _ _ Fal).

(*Inductive*)
intros.
inversion D as [ A ΓT ΔT Suc Ant Height EqS EqA | ΓT ΔT Fal EqS EqA | a b A B ΓA ΓB ΔT L R Height EqS EqA | a A B ΓT ΔA ΔB I Height EqS EqA].

(*ImpL*)
subst.
destruct (app_eq_app _ _ _ _ EqS) as [l [ [Z1 Z2] | [Z1 Z2] ]].

destruct l.

rewrite app_nil_r in Z1.
inversion Z2.
subst.
exists b.
split.

apply (le_S _ _ (PeanoNat.Nat.le_max_r _ _)).

assumption.

inversion Z2.
subst.
rewrite app_assoc_reverse in L.
destruct (H _ (PeanoNat.Nat.le_max_l _ _) _ _ _ _ _ L) as [c [L1 L2]].
rewrite app_assoc_reverse in R.
destruct (H _ (PeanoNat.Nat.le_max_r _ _) _ _ _ _ _ R) as [d [R1 R2]].
exists (S (max c d)).
split.

apply (le_n_S _ _ (PeanoNat.Nat.max_le_compat _ _ _ _ L1 R1)).

pose (exchange_R _ _ [] _ R2) as R3.
rewrite app_assoc in *.
apply (LKImpL _ _ _ L2 R3).

destruct l.

rewrite app_nil_r in Z1.
inversion Z2.
subst.
exists b.
split.

apply (le_S _ _ (PeanoNat.Nat.le_max_r _ _)).

assumption.

inversion Z2.
subst.
rewrite app_comm_cons in L.
rewrite app_assoc in L.
destruct (H _ (PeanoNat.Nat.le_max_l _ _) _ _ _ _ _ L) as [c [L1 L2]].
rewrite app_assoc in R.
destruct (H _ (PeanoNat.Nat.le_max_r _ _) _ _ _ _ _ R) as [d [R1 R2]].
exists (S (max c d)).
split.

apply (le_n_S _ _ (PeanoNat.Nat.max_le_compat _ _ _ _ L1 R1)).

pose (exchange_R _ _ [] _ R2) as R3.
rewrite app_assoc_reverse in *.
apply (LKImpL _ _ _ L2 R3).

(*ImpR*)
subst.
rewrite app_comm_cons in I.
destruct (H _ (le_n _) _ _ _ _ _ I) as [b [I1 I2]].
exists (S b).
split.

apply (le_n_S _ _ I1).

rewrite app_comm_cons in *.
apply (LKImpR _ _ _ I2).
Qed.

Lemma inv_ImpL2:
  forall n E F Γ1 Γ2 Δ (D: LK n (Γ1 ++ (E→F) :: Γ2) Δ),
    (exists m, m <= n /\ LK m (Γ1 ++ F :: Γ2) Δ).
Proof.
intros n.
induction n using strong_induction.

(*Base Case*)
intros.
exists 0.
split.

apply le_n.

inversion D as [ A ΓT ΔT Suc Ant Height EqS EqA | ΓT ΔT Fal EqS EqA | a b A B ΓA ΓB ΔT L R Height EqS EqA | a A B ΓT ΔA ΔB I Height EqS EqA].

(*Id*)
apply imp_not_var in Ant.
apply in_app_comm in Ant.
apply (in_app_add _ _ [F] ) in Ant.
rewrite app_assoc_reverse in Ant.
apply in_app_comm in Ant.
rewrite app_assoc_reverse in Ant.
apply (LKId _ _ _ Suc Ant).

(*Bot*)
apply imp_not_bot in Fal.
apply in_app_comm in Fal.
apply (in_app_add _ _ [F] ) in Fal.
rewrite app_assoc_reverse in Fal.
apply in_app_comm in Fal.
rewrite app_assoc_reverse in Fal.
apply (LKBot _ _ Fal).

(*Inductive*)
intros.
inversion D as [ A ΓT ΔT Suc Ant Height EqS EqA | ΓT ΔT Fal EqS EqA | a b A B ΓA ΓB ΔT L R Height EqS EqA | a A B ΓT ΔA ΔB I Height EqS EqA].

(*ImpL*)
subst.
destruct (app_eq_app _ _ _ _ EqS) as [l [ [Z1 Z2] | [Z1 Z2] ]].

destruct l.

rewrite app_nil_r in Z1.
inversion Z2.
subst.
exists a.
split.

apply (le_S _ _ (PeanoNat.Nat.le_max_l _ _)).

assumption.

inversion Z2.
subst.
rewrite app_assoc_reverse in L.
destruct (H _ (PeanoNat.Nat.le_max_l _ _) _ _ _ _ _ L) as [c [L1 L2]].
rewrite app_assoc_reverse in R.
destruct (H _ (PeanoNat.Nat.le_max_r _ _) _ _ _ _ _ R) as [d [R1 R2]].
exists (S (Nat.max c d)).
split.

apply (le_n_S _ _ (PeanoNat.Nat.max_le_compat _ _ _ _ L1 R1)).

rewrite app_comm_cons in *.
rewrite app_assoc in *.
apply (LKImpL _ _ _ L2 R2).

destruct l.

rewrite app_nil_r in Z1.
inversion Z2.
subst.
exists a.
split.

apply (le_S _ _ (PeanoNat.Nat.le_max_l _ _)).

assumption.

inversion Z2.
subst.
rewrite app_comm_cons in L.
rewrite app_assoc in L.
destruct (H _ (PeanoNat.Nat.le_max_l _ _) _ _ _ _ _ L) as [c [L1 L2]].
rewrite app_assoc in R.
destruct (H _ (PeanoNat.Nat.le_max_r _ _) _ _ _ _ _ R) as [d [R1 R2]].
exists (S (Nat.max c d)).
split.

apply (le_n_S _ _ (PeanoNat.Nat.max_le_compat _ _ _ _ L1 R1)).

rewrite app_assoc_reverse in *.
apply (LKImpL _ _ _ L2 R2).

(*ImpR*)
subst.
rewrite app_comm_cons in I.
destruct (H _ (le_n _) _ _ _ _ _ I) as [b [I1 I2]].
exists (S b).
split.

apply (le_n_S _ _ I1).

apply (LKImpR _ _ _  I2).
Qed.

Lemma inv_ImpR:
  forall n E F Δ1 Δ2 Γ (D : LK n Γ (Δ1++E→F::Δ2)),
   (exists m, m <= n /\ LK m (E::Γ) (Δ1++F::Δ2)).
Proof.
intros n.
induction n using strong_induction.

(*Base Case*)
intros.
subst.
exists 0.
split.

apply le_n.

inversion D as [ A ΓT ΔT Suc Ant Height EqS EqA | ΓT ΔT Fal EqS EqA | a b A B ΓA ΓB ΔT L R Height EqS EqA | a A B ΓT ΔA ΔB I Height EqS EqA].

(*ID*)
apply imp_not_var in Suc.
apply in_app_comm in Suc.
apply (in_app_add _ _ [F] ) in Suc.
rewrite app_assoc_reverse in Suc.
apply in_app_comm in Suc.
rewrite app_assoc_reverse in Suc.
apply (in_app_add _ _ [E]) in Ant.
rewrite in_app_comm in Ant.
apply (LKId _ _ _ Suc Ant).

(*Bot*)
apply (in_app_add Bot Γ [E]) in Fal.
apply in_app_comm in Fal.
apply (LKBot _ _ Fal).

(*Inductive*)
intros.
inversion D as [ A ΓT ΔT Suc Ant Height EqS EqA | ΓT ΔT Fal EqS EqA | a b A B ΓA ΓB ΔT L R Height EqS EqA | a A B ΓT ΔA ΔB I Height EqS EqA].

(*ImpL*)
subst.
destruct (H _ (PeanoNat.Nat.le_max_l _ _) _ _ _ _ _ L) as [c [L1 L2]].
rewrite app_comm_cons in R.
destruct (H _ (PeanoNat.Nat.le_max_r _ _) _ _ _ _ _ R) as [d [R1 R2]].
exists (S (Nat.max c d)).
split.

apply (le_n_S _ _ (PeanoNat.Nat.max_le_compat _ _ _ _ L1 R1)).

rewrite app_comm_cons in L2.
apply (LKImpL _ _ _ L2 R2).

(*ImpR*)
subst.
destruct (app_eq_app _ _ _ _ EqA) as [l [ [Z1 Z2] | [Z1 Z2] ]].

destruct l.

rewrite app_nil_r in Z1.
inversion Z2.
subst.
exists n.
split.

apply (le_S _ _ (le_n _)).

assumption.

inversion Z2.
subst.
rewrite app_assoc_reverse in I.
destruct (H _ (le_n _) _ _ _ _ _ I) as [b [I1 I2]].
exists (S b).
split.

apply (le_n_S _ _ I1).

rewrite <- (app_nil_l (E :: A :: Γ)) in I2.
apply exchange_L in I2.
rewrite app_comm_cons in *.
rewrite app_assoc in *.
apply (LKImpR _ _ _ I2).

destruct l.

rewrite app_nil_r in Z1.
inversion Z2.
subst.
exists n.
split.

apply (le_S _ _ (le_n _)).

assumption.

inversion Z2.
subst.
rewrite app_comm_cons in I.
rewrite app_assoc in I.
destruct (H _ (le_n _) _ _ _ _ _ I) as [b [I1 I2]].
exists (S b).
split.

apply (le_n_S _ _ I1).

rewrite <- (app_nil_l (E :: A :: Γ)) in I2.
apply exchange_L in I2.
rewrite app_assoc_reverse in *.
apply (LKImpR _ _ _ I2).
Qed.

Theorem contraction:
  forall n X,
    (forall Γ1 Γ2 Γ3 Δ (D : (Γ1 ++ X :: Γ2 ++ X :: Γ3) |- Δ >> n),
       exists m, m <= n /\ LK m (Γ1 ++ X :: Γ2 ++ Γ3 ) Δ) /\
    (forall Δ1 Δ2 Δ3 Γ (D : Γ |- Δ1 ++ X :: Δ2 ++ X :: Δ3 >> n),
       exists m, m <= n /\ LK m Γ (Δ1 ++ X :: Δ2 ++ Δ3)).
Proof.
intros n.
induction n using strong_induction.

(*Base Case*)
intros.
split.

(*Left*)
intros.
exists 0.
split.

apply le_n.

inversion D as [ A ΓT ΔT Suc Ant Height EqS EqA | ΓT ΔT Fal EqS EqA | a b A B ΓA ΓB ΔT L R Height EqS EqA | a A B ΓT ΔA ΔB I Height EqS EqA].

(*Id*)
subst.
apply in_double in Ant.
apply (LKId A _ _ Suc Ant).

(*Bot*)
subst.
apply in_double in Fal.
apply (LKBot _ _ Fal).

(*Right*)
intros.
exists 0.
split.

apply le_n.

inversion D as [ A ΓT ΔT Suc Ant Height EqS EqA | ΓT ΔT Fal EqS EqA | a b A B ΓA ΓB ΔT L R Height EqS EqA | a A B ΓT ΔA ΔB I Height EqS EqA].

(*Id*)
apply in_double in Suc.
apply (LKId _ _ _ Suc Ant).

(*Bot*)
apply (LKBot _ _ Fal).

(*Inductive*)
intros.
split.

(*Left*)
intros.
inversion D as [ A ΓT ΔT Suc Ant Height EqS EqA | ΓT ΔT Fal EqS EqA | a b A B ΓA ΓB ΔT L R Height EqS EqA | a A B ΓT ΔA ΔB I Height EqS EqA].

(*ImpL*)
subst.
destruct (app_eq_app _ _ _ _ EqS) as [l [ [Z1 Z2] | [Z1 Z2] ]].

destruct l.

rewrite app_nil_r in Z1.
inversion Z2.
subst.
rewrite app_comm_cons in L.
rewrite app_assoc in L.
destruct (inv_ImpL2 _ _ _ _ L) as [c [L1 L2]].
rewrite app_assoc_reverse in L2.
destruct (H _ (le_trans L1 (PeanoNat.Nat.le_max_l _ _)) B) as [X1 _].
destruct (X1 _ _ _ _ L2) as [d [L3 L4]].
rewrite app_assoc in R.
destruct (inv_ImpL1 _ _ _ _ R) as [e [R1 R2]].
rewrite app_assoc_reverse in R2.
destruct (H _ (le_trans R1 (PeanoNat.Nat.le_max_r _ _)) A) as [_ Y2].
destruct (Y2 [] [] _ _ R2) as [f [R3 R4]].
exists (S (Nat.max d f)).
split.

apply (le_n_S _ _ (PeanoNat.Nat.max_le_compat _ _ _ _ (le_trans L3 L1) (le_trans R3 R1))).

apply (LKImpL _ _ _ L4 R4).

inversion Z2 as [[Z3 Z4]].
subst.
assert (Z5 : In p (l ++ A → B :: ΓB)) by apply (in_list_eq Z4).
apply in_app_iff in Z5.
destruct Z5 as [Z5 | [Z5 | Z5]].

destruct (in_split _ _ Z5) as [l1 [l2 Z3]].
subst.
destruct (H _ (PeanoNat.Nat.le_max_l _ _) p) as [X1 _].
rewrite app_assoc_reverse in L.
rewrite app_comm_cons in L.
rewrite app_assoc_reverse in L.
destruct (X1 _ _ _ _ L) as [c [L1 L2]].
destruct (H _ (PeanoNat.Nat.le_max_r _ _) p) as [Y1 _].
rewrite app_assoc_reverse in R.
rewrite app_comm_cons in R.
rewrite app_assoc_reverse in R.
destruct (Y1 _ _ _ _ R) as [d [R1 R2]].
exists (S (Nat.max c d)).
split.

apply (le_n_S _ _ (PeanoNat.Nat.max_le_compat _ _ _ _ L1 R1)).

rewrite cons_single_app.
apply swap_L.
rewrite <- cons_single_app.
rewrite Z4.
apply move_R_L in L2.
apply move_R_L in R2.
rewrite app_assoc in *.
rewrite app_comm_cons in *.
rewrite app_assoc in *.
apply (LKImpL _ _ _ L2 R2).

subst.
rewrite app_assoc_reverse in L.
destruct (inv_ImpL2 _ _ _ _ L) as [c [L1 L2]].
destruct (H _ (le_trans L1 (PeanoNat.Nat.le_max_l _ _)) B) as [X1 _].
destruct (X1 _ _ _ _ L2) as [d [L3 L4]].
rewrite app_assoc_reverse in R.
destruct (inv_ImpL1 _ _ _ _ R) as [e [R1 R2]].
destruct (H _ (le_trans R1 (PeanoNat.Nat.le_max_r _ _)) A) as [_ Y2].
destruct (Y2 [] [] _ _ R2) as [f [R3 R4]].
exists (S (Nat.max d f)).
split.

apply (le_n_S _ _ (PeanoNat.Nat.max_le_compat _ _ _ _ (le_trans L3 L1) (le_trans R3 R1))).

rewrite cons_single_app.
apply swap_L.
rewrite <- cons_single_app.
rewrite Z4.
apply move_R_L in L4.
rewrite app_assoc in *.
apply (LKImpL _ _ _ L4 R4).

destruct (in_split _ _ Z5) as [l1 [l2 Z1]].
subst.
rewrite app_assoc_reverse in L.
destruct (H _ (PeanoNat.Nat.le_max_l _ _) p) as [X1 _].
rewrite app_comm_cons in L.
rewrite (app_assoc (p :: l)) in L.
destruct (X1 _ _ _ _ L) as [c [L1 L2]].
rewrite app_assoc_reverse in R.
rewrite <- app_comm_cons in R.
rewrite app_assoc in R.
destruct (H _ (PeanoNat.Nat.le_max_r _ _) p) as [Y1 _].
destruct (Y1 _ _ _ _ R) as [d [R1 R2]].
exists (S (Nat.max c d)).
split.

apply (le_n_S _ _ (PeanoNat.Nat.max_le_compat _ _ _ _ L1 R1)).

rewrite cons_single_app.
apply swap_L.
rewrite <- cons_single_app.
rewrite Z4.
apply move_R_L in L2.
apply move_R_L in R2.
rewrite app_assoc_reverse in *.
rewrite app_assoc in *.
apply (LKImpL _ _ _ L2 R2).

destruct l.

rewrite app_nil_r in Z1.
inversion Z2.
subst.
rewrite app_comm_cons in L.
rewrite app_assoc in L.
destruct (inv_ImpL2 _ _ _ _ L) as [c [L1 L2]].
destruct (H _ ((le_trans L1 (PeanoNat.Nat.le_max_l _ _))) B) as [X1 _].
rewrite app_assoc_reverse in L2.
destruct (X1 _ _ _ _ L2) as [d [L3 L4]].
rewrite app_assoc in R.
destruct (inv_ImpL1 _ _ _ _ R) as [e [R1 R2]].
destruct (H _ (le_trans R1 (PeanoNat.Nat.le_max_r _ _)) A) as [_ Y2].
destruct (Y2 [] [] _ _ R2) as [f [R3 R4]].
exists (S (Nat.max d f)).
split.

apply (le_n_S _ _ (PeanoNat.Nat.max_le_compat _ _ _ _ (le_trans L3 L1) (le_trans R3 R1))).

rewrite app_assoc_reverse in R4.
apply (LKImpL _ _ _ L4 R4).

inversion Z2.
subst.
destruct (H _ (PeanoNat.Nat.le_max_l _ _) X) as [X1 _].
rewrite app_comm_cons in L.
rewrite app_assoc in L.
destruct (X1 _ _ _ _ L) as [c [L1 L2]].
destruct (H _ (PeanoNat.Nat.le_max_r _ _) X) as [Y1 _].
rewrite app_assoc in R.
destruct (Y1 _ _ _ _ R) as [d [R1 R2]].
exists (S (Nat.max c d)).
split.

apply (le_n_S _ _ (PeanoNat.Nat.max_le_compat _ _ _ _ L1 R1)).

rewrite app_assoc_reverse in L2.
rewrite app_assoc_reverse in R2.
rewrite app_assoc_reverse.
apply (LKImpL _ _ _ L2 R2).

(*ImpR*)
subst.
destruct (H _ (le_n _) X) as [X1 _].
rewrite app_comm_cons in I.
destruct (X1 _ _ _ _ I) as [b [I1 I2]].
exists (S b).
split.

apply (le_n_S _ _ I1).

apply (LKImpR _ _ _ I2).

(*Right*)
intros.
inversion D as [ A ΓT ΔT Suc Ant Height EqS EqA | ΓT ΔT Fal EqS EqA | a b A B ΓA ΓB ΔT L R Height EqS EqA | a A B ΓT ΔA ΔB I Height EqS EqA].

(*ImpL*)
subst.
destruct (H _ (PeanoNat.Nat.le_max_l _ _) X) as [_ X2].
destruct (X2 _ _ _ _ L) as [c [L1 L2]].
destruct (H _ (PeanoNat.Nat.le_max_r _ _) X) as [_ Y2].
rewrite app_comm_cons in R.
destruct (Y2 _ _ _ _ R) as [d [R1 R2]].
exists (S (Nat.max c d)).
split.

apply (le_n_S _ _ (PeanoNat.Nat.max_le_compat _ _ _ _ L1 R1)).

apply (LKImpL _ _ _ L2 R2).

(*ImpR*)
subst.
destruct (app_eq_app _ _ _ _ EqA) as [l [[Z1 Z2] | [Z1 Z2]]].

destruct l.

rewrite app_nil_r in Z1.
inversion Z2.
subst.
rewrite app_comm_cons in I.
rewrite app_assoc in I.
destruct (inv_ImpR _ _ _ _ I) as [b [I1 I2]].
destruct (H _ I1 A) as [X1 _].
destruct (X1 [] [] _ _ I2) as [c [I3 I4]].
destruct (H _ (le_trans I3 I1) B) as [_ Y2].
rewrite app_assoc_reverse in I4.
destruct (Y2 _ _ _ _ I4) as [d [I5 I6]].
exists (S d).
split.

apply (le_n_S _ _ (le_trans I5 (le_trans I3 I1))).

apply (LKImpR _ _ _ I6).

inversion Z2 as [[Z3 Z4]].
subst.
assert (Z5 : In p (l ++ A → B :: ΔB)) by apply (in_list_eq Z4).
apply in_app_iff in Z5.
destruct Z5 as [Z5 | [Z5 |Z5]].

destruct (in_split _ _ Z5) as [l1 [l2 Z6]].
subst.
rewrite app_assoc_reverse in I.
rewrite <- app_comm_cons in I.
rewrite app_assoc_reverse in I.
destruct (H _ (le_n _) p) as [_ X2].
destruct (X2 _ _ _ _ I) as [b [I1 I2]].
exists (S b).
split.

apply (le_n_S _ _ I1).

rewrite cons_single_app.
apply swap_R.
rewrite <- cons_single_app.
rewrite Z4.
apply move_R_R in I2.
rewrite app_comm_cons in I2.
rewrite! app_assoc in *.
apply (LKImpR _ _ _ I2).

subst.
rewrite app_assoc_reverse in I.
destruct (inv_ImpR _ _ _ _ I) as [b [I1 I2]].
destruct (H _ I1 A) as [X1 _].
destruct (X1 [] [] _ _ I2) as [c [I3 I4]].
destruct (H _ (le_trans I3 I1) B) as [_ Y2].
destruct (Y2 _ _ _ _ I4) as [d [I5 I6]].
exists (S d).
split.

apply (le_n_S _ _ (le_trans I5 (le_trans I3 I1))).

rewrite cons_single_app.
apply swap_R.
rewrite <- cons_single_app.
rewrite Z4.
apply move_R_R in I6.
rewrite app_assoc in *.
apply (LKImpR _ _ _ I6).

destruct (in_split _ _ Z5) as [l1 [l2 Z3]].
subst.
destruct (H _ (le_n _) p) as [_ X2].
rewrite app_assoc_reverse in I.
rewrite app_comm_cons in I.
rewrite <- app_comm_cons in I.
rewrite app_assoc in I.
destruct (X2 _ _ _ _ I) as [b [I1 I2]].
exists (S b).
split.

apply (le_n_S _ _ I1).

rewrite cons_single_app.
apply swap_R.
rewrite <- cons_single_app.
rewrite Z4.
apply move_R_R in I2.
rewrite app_assoc_reverse in I2.
rewrite app_assoc in *.
apply (LKImpR _ _ _ I2).

destruct l.

rewrite app_nil_r in Z1.
inversion Z2.
subst.
rewrite app_comm_cons in I.
rewrite app_assoc in I.
destruct (inv_ImpR _ _ _ _ I) as [b [I1 I2]].
destruct (H _ I1 A) as [X1 _].
destruct (X1 [] [] _ _ I2) as [c [I3 I4]].
destruct (H _ (le_trans I3 I1) B) as [_ Y2].
rewrite app_assoc_reverse in I4.
destruct (Y2 _ _ _ _ I4) as [d [I5 I6]].
exists (S d).
split.

apply (le_n_S _ _ (le_trans I5 (le_trans I3 I1))).

apply (LKImpR _ _ _ I6).

inversion Z2.
subst.
destruct (H _ (le_n _) X) as [_ X2].
rewrite app_comm_cons in I.
rewrite app_assoc in I.
destruct (X2 _ _ _ _ I) as [b [ I1 I2]].
exists (S b).
split.

apply (le_n_S _ _ I1).

rewrite app_assoc_reverse in I2.
rewrite app_assoc_reverse.
apply (LKImpR _ _ _ I2).
Qed.

(*Case Bashing Belonging in Multiple Lists with Known First Value*)
(*Used for Id Case in Cut When Avoiding Contraction*)

Lemma cut_gax:
  forall (A A0 A1 : PropF) (L1 L2 : list PropF),
       In A0 L1 -> In A0 ([A] ++ L2)
    -> In A1 L2 -> In A1 ([A] ++ L1)
    -> In A0 L1 /\ In A0 L2 \/ In A1 L1 /\ In A1 L2.
Proof.
intros.
destruct H0.

destruct H2.

subst.
firstorder.

firstorder.

firstorder.
Qed.

Theorem cut_elimination_no_contraction:
  forall A n m Γ Δ (D : LK n Γ ([A] ++ Δ)) (D1 : LK m ([A] ++ Γ) Δ),
    exists k, Γ |- Δ >> k.
Proof.
intros A.
induction A.

(*PropVar*)
intros n.
induction n using strong_induction.

(*Base Case n*)
intros m.
induction m using strong_induction.

(*Base Case m : n = 0*)
intros.
subst.
exists 0.
inversion D as [ A ΓT ΔT Suc Ant Height EqS EqA | ΓT ΔT Fal EqS EqA | a b A B ΓA ΓB ΔT L R Height EqS EqA | a A B ΓT ΔA ΔB I Height EqS EqA].

(*Id*)
subst.
inversion D1 as [ DA DΓT DΔT DSuc DAnt DHeight DEqS DEqA | DΓT DΔT DFal DEqS DEqA | Da Db DA DB DΓA DΓB DΔT DL DR DHeight DEqS DEqA | Da DA DB DΓT DΔA DΔB DI DHeight DEqS DEqA].

(*Id : Id*)
destruct (cut_gax Ant Suc DSuc DAnt) as [[Ant1 Suc1] | [Ant1 Suc1]].

apply (LKId _ _ _ Suc1 Ant1).

apply (LKId _ _ _ Suc1 Ant1).

(*Id : Bot*)
destruct Suc as [Suc | Suc].

destruct DFal as [DFal | DFal].

discriminate.

apply (LKBot _ _ DFal).

apply (LKId _ _ _ Suc Ant).

(*Bot*)
apply (LKBot _ _ Fal).

(*Inductive m : n = 0*)
intros.
subst.
inversion D1 as [ A ΓT ΔT Suc Ant Height EqS EqA | ΓT ΔT Fal EqS EqA | a b A B ΓA ΓB ΔT L R Height EqS EqA | a A B ΓT ΔA ΔB I Height EqS EqA].

(*ImpL*)
subst.
destruct ΓA.

inversion EqS.

inversion EqS.
subst.
destruct (inv_ImpL2 _ _ _ _ D) as [c [L1 L2]].
inversion L1.
subst.
destruct (H _ (PeanoNat.Nat.le_max_l _ _) _ _ L2 L) as [c L3].
destruct (inv_ImpL1 _ _ _ _ D) as [d [R1 R2]].
inversion R1.
subst.
rewrite cons_single_app in R2.
rewrite <- app_nil_l in R2.
apply swap_R in R2.
destruct (H _ (PeanoNat.Nat.le_max_r _ _) _ _ R2 R) as [d R3].
exists (S (max c d)).
apply (LKImpL _ _ _ L3 R3).

(*ImpR*)
subst.
rewrite app_assoc in D.
destruct (inv_ImpR _ _ _ _ D) as [b [I1 I2]].
inversion I1.
subst.
rewrite cons_single_app in I.
rewrite <- (app_nil_l ( [A] ++ [# p] ++ Γ)) in I.
apply swap_L in I.
destruct (H _ (le_n _) _ _ I2 I) as [c I3].
exists (S c).
apply (LKImpR _ _ _ I3).

(*Inductive n*)
intros.
subst.
inversion D as [ A ΓT ΔT Suc Ant Height EqS EqA | ΓT ΔT Fal EqS EqA | a b A B ΓA ΓB ΔT L R Height EqS EqA | a A B ΓT ΔA ΔB I Height EqS EqA].

(*ImpL*)
subst.
rewrite app_assoc in D1.
destruct (inv_ImpL2 _ _ _ _ D1) as [c [L1 L2]].
destruct (H _ (PeanoNat.Nat.le_max_l _ _) _ _ _ L L2) as [d L3].
destruct (inv_ImpL1 _ _ _ _ D1) as [e [R1 R2]].
rewrite cons_single_app in R.
rewrite <- app_nil_l in R.
apply swap_R in R.
destruct (H _ (PeanoNat.Nat.le_max_r _ _) _ _ _ R R2) as [f R3].
exists (S (max d f)).
apply (LKImpL _ _ _ L3 R3).

(*ImpR*)
destruct ΔA.

inversion EqA.

inversion EqA.
subst.
destruct (inv_ImpR _ _ _ _ D1) as [b [I1 I2]].
rewrite cons_single_app in I2.
rewrite <- (app_nil_l ( [A] ++ [# p] ++ Γ)) in I2.
apply swap_L in I2.
destruct (H _ (le_n _) _ _ _ I I2) as [c I3].
exists (S c).
apply (LKImpR _ _ _ I3).

(*Bot*)
intros n.
induction n using strong_induction.

(*Base Case n*)
intros.
subst.
exists 0.
inversion D as [ A ΓT ΔT Suc Ant Height EqS EqA | ΓT ΔT Fal EqS EqA | a b A B ΓA ΓB ΔT L R Height EqS EqA | a A B ΓT ΔA ΔB I Height EqS EqA].

(*Id*)
destruct Suc as [Suc | Suc].

inversion Suc.

apply (LKId _ _ _ Suc Ant).

(*Bot*)
apply (LKBot _ _ Fal).

(*Inductive n*)
intros.
subst.
inversion D as [ A ΓT ΔT Suc Ant Height EqS EqA | ΓT ΔT Fal EqS EqA | a b A B ΓA ΓB ΔT L R Height EqS EqA | a A B ΓT ΔA ΔB I Height EqS EqA].

(*ImpL*)
subst.
rewrite app_assoc in D1.
destruct (inv_ImpL2 _ _ _ _ D1) as [c [L1 L2]].
destruct (H _ (PeanoNat.Nat.le_max_l _ _) _ _ _ L L2) as [d L3].
destruct (inv_ImpL1 _ _ _ _ D1) as [e [R1 R2]].
rewrite <- app_nil_l in R.
apply exchange_R in R.
destruct (H _ (PeanoNat.Nat.le_max_r _ _) _ _ _ R R2) as [f R3].
exists (S (max d f)).
apply (LKImpL _ _ _ L3 R3).

(*ImpR*)
destruct ΔA.

inversion EqA.

inversion EqA.
subst.
destruct (inv_ImpR _ _ _ _ D1) as [b [I1 I2]].
rewrite <- (app_nil_l ( A :: [Bot] ++ Γ)) in I2.
apply exchange_L in I2.
destruct (H _ (le_n _) _ _ _ I I2) as [c I3].
exists (S c).
apply (LKImpR _ _ _ I3).

(*Imp*)
intros.
subst.
destruct (inv_ImpR _ _ [] _ D) as [a [I1 I2]].
destruct (inv_ImpL1 _ _ [] _ D1) as [b [I3 I4]].
rewrite cons_single_app in I4.
pose (weakening_R _ _ I4 [A2]) as I5.
destruct (IHA1  _ _ _ _ I5 I2) as [c I6].
destruct (inv_ImpL2 _ _ [] _ D1) as [d [I7 I8]].
destruct (IHA2 _ _ _ _ I6 I8) as [e I9].
exists e.
assumption.
Qed.

Theorem cut_elimination_with_contraction:
  forall A n m Γ Δ (D : LK n Γ ([A] ++ Δ)) (D1 : LK m ([A] ++ Γ) Δ),
    exists k, Γ |- Δ >> k.
Proof.
intros A.
induction A.

(*PropVar*)
intros n.
induction n using strong_induction.

(*Base Case n*)
intros.
inversion D as [ A ΓT ΔT Suc Ant Height EqS EqA | ΓT ΔT Fal EqS EqA | a b A B ΓA ΓB ΔT L R Height EqS EqA | a A B ΓT ΔA ΔB I Height EqS EqA].

(*Id*)
destruct Suc as [Suc | Suc].

subst.
rewrite <- Suc in Ant.
destruct (in_split _ _ Ant) as [l1 [l2 Z1]].
subst.
destruct (contraction m #p) as [X1 _].
destruct (X1 [] _ _ _ D1) as [a [I1 I2]].
apply move_R_L in I2.
exists a.
assumption.

exists 0.
apply (LKId _ _ _ Suc Ant).

(*Bot*)
exists 0.
apply (LKBot _ _ Fal).

(*Inductive n*)
intros.
subst.
inversion D as [ A ΓT ΔT Suc Ant Height EqS EqA | ΓT ΔT Fal EqS EqA | a b A B ΓA ΓB ΔT L R Height EqS EqA | a A B ΓT ΔA ΔB I Height EqS EqA].

(*ImpL*)
subst.
rewrite app_assoc in D1.
destruct (inv_ImpL2 _ _ _ _ D1) as [c [L1 L2]].
destruct (H _ (PeanoNat.Nat.le_max_l _ _) _ _ _ L L2) as [d L3].
destruct (inv_ImpL1 _ _ _ _ D1) as [e [R1 R2]].
rewrite cons_single_app in R.
rewrite <- app_nil_l in R.
apply swap_R in R.
destruct (H _ (PeanoNat.Nat.le_max_r _ _) _ _ _ R R2) as [f R3].
exists (S (max d f)).
apply (LKImpL _ _ _ L3 R3).

(*ImpR*)
destruct ΔA.

inversion EqA.

inversion EqA.
subst.
destruct (inv_ImpR _ _ _ _ D1) as [b [I1 I2]].
rewrite cons_single_app in I2.
rewrite <- (app_nil_l ( [A] ++ [# p] ++ Γ)) in I2.
apply swap_L in I2.
destruct (H _ (le_n _) _ _ _ I I2) as [c I3].
exists (S c).
apply (LKImpR _ _ _ I3).

(*Bot*)
intros n.
induction n using strong_induction.

(*Base Case n*)
intros.
subst.
exists 0.
inversion D as [ A ΓT ΔT Suc Ant Height EqS EqA | ΓT ΔT Fal EqS EqA | a b A B ΓA ΓB ΔT L R Height EqS EqA | a A B ΓT ΔA ΔB I Height EqS EqA].

(*Id*)
destruct Suc as [Suc | Suc].

inversion Suc.

apply (LKId _ _ _ Suc Ant).

(*Bot*)
apply (LKBot _ _ Fal).

(*Inductive n*)
intros.
subst.
inversion D as [ A ΓT ΔT Suc Ant Height EqS EqA | ΓT ΔT Fal EqS EqA | a b A B ΓA ΓB ΔT L R Height EqS EqA | a A B ΓT ΔA ΔB I Height EqS EqA].

(*ImpL*)
subst.
rewrite app_assoc in D1.
destruct (inv_ImpL2 _ _ _ _ D1) as [c [L1 L2]].
destruct (H _ (PeanoNat.Nat.le_max_l _ _) _ _ _ L L2) as [d L3].
destruct (inv_ImpL1 _ _ _ _ D1) as [e [R1 R2]].
rewrite <- app_nil_l in R.
apply exchange_R in R.
destruct (H _ (PeanoNat.Nat.le_max_r _ _) _ _ _ R R2) as [f R3].
exists (S (max d f)).
apply (LKImpL _ _ _ L3 R3).

(*ImpR*)
destruct ΔA.

inversion EqA.

inversion EqA.
subst.
destruct (inv_ImpR _ _ _ _ D1) as [b [I1 I2]].
rewrite <- (app_nil_l ( A :: [Bot] ++ Γ)) in I2.
apply exchange_L in I2.
destruct (H _ (le_n _) _ _ _ I I2) as [c I3].
exists (S c).
apply (LKImpR _ _ _ I3).

(*Imp*)
intros.
subst.
destruct (inv_ImpR _ _ [] _ D) as [a [I1 I2]].
destruct (inv_ImpL1 _ _ [] _ D1) as [b [I3 I4]].
rewrite cons_single_app in I4.
pose (weakening_R _ _ I4 [A2]) as I5.
destruct (IHA1  _ _ _ _ I5 I2) as [c I6].
destruct (inv_ImpL2 _ _ [] _ D1) as [d [I7 I8]].
destruct (IHA2 _ _ _ _ I6 I8) as [e I9].
exists e.
assumption.
Qed.


(************ bools ************)
Module Nats.

Inductive nat : Type :=
  | O
  | S (n : nat).

Definition pred (n : nat) : nat :=
  match n with
  | O => O
  | S n' => n'
  end.

Fixpoint plus (a b : nat) :=
  match a with
  | O => b
  | S n' => S(plus n' b)
  end.

Fixpoint minus (a b : nat) :=
  match a,b with
  | O, _ => O
  | _, O => a
  | S a',S b' => minus a' b'
  end.

Fixpoint mult (a b : nat) :=
  match b with
  | O => O
  | S O => a
  | S b' => plus a (mult a b')
  end.

Fixpoint exp (a b : nat) :=
  match b with
  | O => S O
  | S O => a
  | S b' => mult a (exp a b')
  end.

Fixpoint fact (n : nat) :=
  match n with
  | O => O
  | S O => S O
  | S n' => mult n (fact n')
  end.

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

Definition isOdd (n : nat) := negb (isEven n).

Fixpoint eq (a b : nat) :=
  match a with
  | O => match b with
       | O => true
       | _ => false
       end
  | S a' => match b with
       | O => false
       | S (b') => eq a' b'
       end
  end.

Fixpoint isLessOrEqual (a b : nat) :=
  eq (minus a b) O.
Fixpoint isLess (a b : nat) :=
  negb (isLessOrEqual b a).

Compute Nats.plus(S (S (S (S O)))) (S(S(O))).
Compute Nats.minus(S (S (S (S O)))) (S(S(O))).
Compute Nats.mult(S (S (S (S O)))) (S(S(O))).
Compute Nats.exp(S (S (S (S O)))) (S(S(O))).
Compute Nats.fact(S (S (S (S O)))).
Compute isEven (Nats.plus(S (S (S (S O)))) (S(S(O)))).
Compute isOdd (Nats.plus(S (S (S (S O)))) (S(S(O)))).

Notation "x + y" := (plus x y)
                       (at level 50, left associativity)
                       : nat_scope.
Notation "x - y" := (minus x y)
                       (at level 50, left associativity)
                       : nat_scope.
Notation "x * y" := (mult x y)
                       (at level 40, left associativity)
                       : nat_scope.
Notation "x =? y" := (eq x y) (at level 70) : nat_scope.
Notation "x <=? y" := (isLessOrEqual x y) (at level 70) : nat_scope.
Notation "x <? y" := (isLess x y) (at level 70) : nat_scope.

Compute ((S(S O)) * (plus (S O) (S O)) =? S(S(S(S(O))))).
Compute (S(S O)) <=? (S(S(S(S(O))))).
Compute (S(S O)) <=? (S(S(O))).
Compute (S(S O)) <? (S(S(O))).
Compute (S(S O)) <? (S(S(S(O)))).

Compute S(O) + S(S(S(O))).

Check S.
Check pred.
Check Nats.plus.

End Nats.

Theorem neutral : forall n:nat, O + n = n.
Proof. intros n. simpl. reflexivity. Qed.

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

Theorem plusId : forall n m o : nat, n = m -> m = o -> n + m = m + o.
intros n m o H H'. rewrite -> H. rewrite <- H'. reflexivity. Qed.

Theorem multZeroPlus : forall n m : nat, (O + n) * m = n * m.
Proof. intros n m. rewrite neutral. reflexivity. Qed.

Theorem multS1 : forall n m : nat,
  m = S n -> m * (S n) = m * m.
Proof. intros n m H. rewrite H. reflexivity. Qed.

Theorem succZero : forall n : nat, (eq (S n) O) = False.
Proof. intros n. destruct n as [|n'] eqn:E.
  - Abort.

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

Theorem andCommutative : forall a b : bool, andb a b = andb a b.
Proof. intros a b. destruct a eqn:E.
 -destruct b.
    +reflexivity.
    +reflexivity.
 -destruct b.
    +reflexivity.
    +reflexivity.
Qed.

Theorem andb_commutative' :
  forall b c, andb b c = andb c b.
Proof.
  intros [] [].
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.

(* NEXT: More on Notation (Optional) and exercise https://softwarefoundations.cis.upenn.edu/lf-current/Basics.html *)

Theorem andTrueElim: forall b c : bool,
                     andb b c %bool = true -> c = true.
Proof. intros [] [].
  -simpl. reflexivity.
  -intros []. simpl. reflexivity.
  -simpl. reflexivity.
  -intros []. simpl. reflexivity.
Qed.

Theorem identity_fn_applied_twice :
  forall(f : bool -> bool),
  (forall(x : bool), f x = x) ->
  forall(b : bool), f (f b) = b.
Proof. intros f x b. rewrite x. rewrite x. reflexivity. Qed.

Theorem andb_eq_orb :
  forall(b c : bool),
  (andb b c = orb b c) ->
  b = c.
Proof. intros b c. destruct b.
  -simpl. destruct c. reflexivity. easy.
  -simpl. destruct c. easy. easy.

Inductive bin : Type :=
 | Z
 | O (n : bin)
 | I (n : bin).

Fixpoint allOne(m:bin) : bool :=
  match m with
  | Z => true
  | I m' => allOne m'
  | O m' => false
  end.

(* TODO fix incr of binary representation *)
Fixpoint incr(m:bin) : bin :=
  match m with
  | Z   => Z
  | O m' => if allOne m' then I (incr m') else O (incr m')
  | I m' => if allOne m' then I (incr(m')) else I (incr m')
  end.

Compute incr (O Z).
Compute incr (I Z).
Compute incr (I (O Z)).
Compute incr (I (I Z)).


Require Import
  Coq.NArith.NArith MathClasses.implementations.peano_naturals MathClasses.theory.naturals
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.naturals MathClasses.interfaces.orders
  MathClasses.interfaces.additional_operations.

(* canonical names for relations/operations/constants: *)
#[global]
Instance N_equiv : Equiv N := eq.
#[global]
Instance N_0 : Zero N := 0%N.
#[global]
Instance N_1 : One N := 1%N.
#[global]
Instance N_plus : Plus N := Nplus.
#[global]
Instance N_mult : Mult N := Nmult.

(* properties: *)
#[global]
Instance: SemiRing N.
Proof.
  repeat (split; try apply _); repeat intro.
         now apply Nplus_assoc.
        now apply Nplus_0_r.
       now apply Nplus_comm.
      now apply Nmult_assoc.
     now apply Nmult_1_l.
    now apply Nmult_1_r.
   now apply Nmult_comm.
  now apply Nmult_plus_distr_l.
Qed.

#[global]
Instance: ∀ x y : N, Decision (x = y) := N.eq_dec.

#[global]
Instance inject_nat_N: Cast nat N := N_of_nat.
#[global]
Instance inject_N_nat: Cast N nat := nat_of_N.

#[global]
Instance: SemiRing_Morphism nat_of_N.
Proof.
  repeat (split; try apply _); repeat intro.
   now apply nat_of_Nplus.
  now apply nat_of_Nmult.
Qed.

#[global]
Instance: Inverse nat_of_N := N_of_nat.

#[global]
Instance: Surjective nat_of_N.
Proof. constructor. intros x y E. rewrite <- E. now apply nat_of_N_of_nat. now apply _. Qed.

#[global]
Instance: Injective nat_of_N.
Proof. constructor. exact nat_of_N_inj. apply _. Qed.

#[global]
Instance: Bijective nat_of_N := {}.

#[global]
Instance: Inverse N_of_nat := nat_of_N.

#[global]
Instance: Bijective N_of_nat.
Proof. apply jections.flip_bijection. Qed.

#[global]
Instance: SemiRing_Morphism N_of_nat.
Proof. change (SemiRing_Morphism (nat_of_N⁻¹)). split; apply _. Qed.

#[global]
Instance: NaturalsToSemiRing N := retract_is_nat_to_sr N_of_nat.
#[global]
Instance: Naturals N := retract_is_nat N_of_nat.

(* order *)
#[global]
Instance N_le: Le N := N.le.
#[global]
Instance N_lt: Lt N := N.lt.

#[global]
Instance: FullPseudoSemiRingOrder N_le N_lt.
Proof.
  assert (PartialOrder N_le).
   repeat (split; try apply _). exact N.le_antisymm.
  assert (SemiRingOrder N_le).
   split; try apply _.
     intros x y E. exists (Nminus y x).
     symmetry. rewrite commutativity. now apply N.sub_add.
    repeat (split; try apply _); intros.
     now apply N.add_le_mono_l.
    eapply N.add_le_mono_l. eassumption.
   intros. now apply Nle_0.
  assert (TotalRelation N_le).
   intros x y. now apply N.le_ge_cases.
  rapply semirings.dec_full_pseudo_srorder.
  split.
   intro. now apply N.le_neq.
  intros [E1 E2]. now apply N.Private_Tac.le_neq_lt.
Qed.

#[global]
Program Instance: ∀ x y: N, Decision (x ≤ y) := λ y x,
  match N.compare y x with
  | Gt => right _
  | _ => left _
  end.
Next Obligation. now apply not_symmetry. Qed.

#[global]
Instance N_cut_minus: CutMinus N := Nminus.
#[global]
Instance: CutMinusSpec N _.
Proof.
  split; try apply _.
   intros. now apply N.sub_add.
  intros. now apply Nminus_N0_Nle.
Qed.


(* Socrate is a men, all mens are mortal, therefore socrate is mortal *)

Parameter Person:Type.
Parameter Socrate : Person.
Parameter Men Mortal : Person->Prop.

Lemma socrateMortal : Men Socrate /\ (forall P:Person, Men P -> Mortal P) -> Mortal Socrate.
Proof.
	intros.
	destruct H.
	apply H0 in H.
	apply H.
	Show Proof.
Qed.

Definition sym (A:Type) (x y:A) (e:x=y) : y=x :=
	@eq_ind A x (fun a => a=x) eq_refl y e
.

Check eq_ind.
Check sym.

Definition trans (A:Type) (x y z:A) (e1: x=y) (e2 : y=z) : x=z :=
	@eq_ind A y (fun a => x = a) e1 z e2
.

Check trans.

Definition cong (A B:Type) (f: A -> B) (x y :A) (e: x=y) : f x = f y :=
	@eq_ind A x (fun a => f x = f a) eq_refl y e
.
Check cong.

Check eq_rect.

Definition congd (A :Type) (B:A->Type) (f: forall x:A,B x) (x y :A) (e: x=y) : 		(@eq_rect A x B (f x) y e ) = f y
.
Proof.
	destruct e.
	compute.
	reflexivity.
Qed.

Check Prop.
Check Type.
Check Prop -> Prop.
Check forall (P:Prop), P.
Check forall (P:Type), P.

Definition t := Type.
Check t.

Fail Check (forall (P:t), P) : t.
Definition p := Prop.
Check (forall (P:p), P) : p.

Definition conj (A B : Prop) := forall Q:Prop, (A->B->Q)->Q.

Definition conj_i (A B : Prop) (h1 : A) (h2 : B) : conj A B :=
	fun Q f => f h1 h2
.

Check conj_i.

(*exam 2017*)

Definition t1 : { x : nat | x = 3 } :=
	 exist _ 3 eq_refl
.

Eval compute in eq_sym.

Definition eq_sym {A : Type} (x y : A) (e : x = y) : y = x :=
match e in _ = _ return _ with
| eq_refl => eq_refl
end.

Check True.
Check unit.

Check True_ind.
Check unit_ind.

Check and.
Check prod.

Check and_ind.
Check prod_ind.

Check sig.
Check ex.

Check sig_ind.
Check ex_ind.

Example nth : forall A (l : list A),
{n : nat | n < length l} -> A.
Admitted.

(*exam*)

Inductive tree : Type :=
|L : nat -> tree
|N : nat -> tree -> tree -> tree.

Fixpoint mult (t:tree) : nat :=
match t with
|L n => n
|N n ln rn =>
	n * (mult ln) * (mult rn)
end.

Eval compute in (mult (N 2 (L 3) (L 2))).

Fixpoint in0 (t:tree) : Prop :=
match t with
|L 0 => True
|L _ => False
|N 0 _ _ => True
|N _ ln rn => (in0 ln) \/ (in0 rn)
end.

Eval compute in (in0 (N 2 (L 3) (L 2))).
Eval compute in (in0 (N 2 (L 3) (L 0))).

Inductive inO : tree -> Prop :=
| inO_L : inO (L O)
| inO_N l r : inO (N O l r)
| inO_N_l n l r : inO l -> inO (N n l r)
| inO_N_r n l r : inO r -> inO (N n l r).

Eval compute in (in0 (N 2 (L 3) (N 6 (L 0) (L 1)))).
Eval compute in (inO (N 2 (L 3) (N 6 (L 0) (L 1)))).
Eval compute in (inO (N 2 (L 3) (N 6 (L 2) (L 1)))).

Definition unit {A} : A -> option A := Some.
Definition bind {A B} (m : option A) (f : A -> option B) : option B :=
match m with
| Some x => f x
| None => None
end.
Definition raise {A} : option A := None.

Fixpoint mult0 (t : tree) : option nat :=
match t with
| L 0 => raise
| L n => unit n
| N 0 l r => raise
| N n l r =>
	bind (mult0 l) (fun l' =>
	bind (mult0 r) (fun r' =>
		unit (n * l'* r')
	))
end.

Eval compute in (mult (N 2 (L 3) (L 2))).
Eval compute in (mult0 (N 2 (L 3) (L 2))).
Eval compute in (mult0 (N 2 (L 3) (L 0))).

Definition M (A : Type) :=
  forall (C : Type), (A -> C) -> C -> C
.

Definition unit' {A} (a:A) : M A :=
	fun _ f _ => f a
.

Check unit'.

Definition raise' {A} (a:A) : M A :=
	fun _ _ x => x
.

Definition bind' {A B}  ( ma : M A) (f : A -> M B) : M B :=
	fun c sk fk => ma c (fun a => f a c sk fk) fk
.

Check bind'.

Definition catch {A}  (e1 : M A) (e2 : A) : A :=
	e1 A (fun a => a) e2
.

(***)

Parameter epsilon : forall (A:Type), A -> (A -> Prop) -> A.
Axiom epsilon_spec :
forall (A:Type) (a:A), forall P, (exists x, P x) -> P (epsilon A a P).

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

Eval compute in (power2 3).

Definition log2 (n:nat) : nat :=
	epsilon nat n (fun x => n=power2 x) .

Eval compute in (log2 8).

Definition epsilon_bool_subset (P : bool -> Prop) :
(exists x : bool, P x) -> { x : bool | P x }.
Admitted.

(***)

Inductive comparaison : Set :=
|Eq : comparaison
|Lt : comparaison
|Gt : comparaison.

Structure dec_order :=
{
	ord_car : Type;
	ord_rel : ord_car -> ord_car -> Prop;
	ord_compare : forall x y, ;
	ord_rel_compare : ord_car -> ord_car -> Prop;
	ord_irrefl : forall x, not (ord_rel x x)
}.

Eval ord_compare x y