(* FPP_8b_annotated.v *)
(* was: *)
(* FPP_8b.v *)
(* YSC3236 2018-2019, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of 11 October 2018 *)

(* Paraphernalia: *)

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

Require Import Arith Bool List.

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

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

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

Definition test_even (candidate: nat -> bool) : bool :=
  (candidate 0 =b= true)
    &&
    (candidate 1 =b= false)
    &&
    (candidate 2 =b= true)
    &&
    (candidate 3 =b= false)
    (* etc. *)
.

Definition test_odd (candidate: nat -> bool) : bool :=
  (candidate 0 =b= false)
    &&
    (candidate 1 =b= true)
    &&
    (candidate 2 =b= false)
    &&
    (candidate 3 =b= true)
    (* etc. *)
.

Fixpoint is_odd (n : nat) : bool :=
  match n with
  | 0 => false
  | S n' => is_even n'
  end
with is_even (n : nat) : bool :=
  match n with
  | 0 => true
  | S n' => is_odd n'
  end.

Compute test_odd is_odd.
Compute test_even is_even.

Lemma fold_unfold_is_even_O :
  is_even 0 = true.
Proof.
  fold_unfold_tactic is_even.
Qed.

Lemma fold_unfold_is_even_S :
  forall (n : nat),
    is_even (S n) = is_odd n.
Proof.
  fold_unfold_tactic is_even
  .
Qed.

Lemma fold_unfold_is_odd_O :
  is_odd 0 = false.
Proof.
  fold_unfold_tactic is_odd.
Qed.

Lemma fold_unfold_is_odd_S :
  forall (n : nat),
    is_odd (S n) = is_even n.
Proof.
  fold_unfold_tactic is_odd.
Qed.

Proposition disjunction_is_commutative :
  forall P Q : Prop,
    P \/ Q <-> Q \/ P.
(* O: is the bi-implication really necessary? *)
Proof.
  intros P Q.
  split.

  - intro H_P_or_Q.
    destruct H_P_or_Q as [H_P | H_Q].

    right.
    exact H_P.
    left.
    exact H_Q.

  - intro H_Q_or_P.
    destruct H_Q_or_P as [H_Q | H_P].

    right.
    exact H_Q.
    left.
    exact H_P.
    Show Proof.
Qed.

Lemma n_is_either_even_or_odd :
  forall (n : nat),
    is_even n = true \/ is_odd n = true.
Proof.
  intro n.
  induction n as [ | n' IHn'].

  - rewrite -> fold_unfold_is_even_O.
    left.
    reflexivity.

  - rewrite -> (fold_unfold_is_even_S (n')).
    rewrite -> (fold_unfold_is_odd_S (n')).
    Check disjunction_is_commutative.
(* O: You are abusing Coq here: apply works for an implication, not a bi-implication.  Mindfully use destruct first. *)
    apply (disjunction_is_commutative (is_odd n' = true) (is_even n' = true)).
    exact IHn'.
Qed.

Lemma n_is_even_implies_successor_of_n_is_odd :
  forall (n : nat),
    is_even n = true ->
    is_odd (S n) = true.
Proof.
  intro n.
  intro H_is_even.
  rewrite -> (fold_unfold_is_odd_S n).
  apply H_is_even.
(* O: You might as well use exact here. *)
Qed.

Lemma n_is_odd_implies_successor_of_n_is_even :
  forall (n : nat),
    is_odd n = true ->
    is_even (S n) = true.
Proof.
  intro n.
  intro H_is_odd.
  rewrite -> (fold_unfold_is_even_S n).
  apply H_is_odd.
Qed.

Lemma evenness_of_additions :
  forall (n m : nat),
    (is_odd n = true ->
     is_odd m = true ->
     is_even (n + m) = true)
    /\
    (is_odd n = true ->
     is_even m = true ->
     is_odd (n + m) = true)
    /\
    (is_even n  = true ->
     is_odd m = true ->
     is_odd (n + m) = true)
    /\
    (is_even n = true ->
     is_even m = true ->
     is_even (n + m) = true).
Proof.
  intro n.
  induction n as [ | n' IHn'].

  - intro m.
    rewrite -> (fold_unfold_is_odd_O).
    rewrite -> (fold_unfold_is_even_O).
    rewrite -> (plus_O_n).
    split.

    * intro H_absurd.
      discriminate H_absurd.

    * split.

    + intro H_absurd.
      discriminate H_absurd.

    + split.

      ** intros H_1 H_2.
         exact H_2.

      ** intros H_1 H_2.
         exact H_2.

  - intro m.
    rewrite -> (fold_unfold_is_even_S).
    rewrite -> (fold_unfold_is_odd_S).
    Search (S _ + _ = _).
    rewrite -> plus_Sn_m.
    rewrite -> (fold_unfold_is_odd_S).
    rewrite -> (fold_unfold_is_even_S).
    split.

    * apply (IHn' m).

    * split.

      ** apply (IHn' m).

      ** split.

      ++ apply (IHn' m).

      ++ apply IHn'.
Qed.

(* O: Wouldn't be more natural to state:
  forall n : nat,
    is_even n = true ->
    forall m : nat,
      is_even (n * m) = true.
   ?
*)

Proposition product_of_even_and_any_number_is_even :
  forall (n m : nat),
    is_even n = true ->
    is_even (n * m) = true.
Proof.
  intro n.
  induction m as [ | m' IHm'].

  - intro H_is_even.
    Search (_ * 0 = 0).
    rewrite -> (Nat.mul_0_r).
    rewrite -> (fold_unfold_is_even_O).
    reflexivity.

  - intro H_is_even.
    Search (_ * S _ = _).
    rewrite -> Nat.mul_succ_r.
    rewrite -> Nat.add_comm.
    Check evenness_of_additions.
    apply (evenness_of_additions n (n * m')).
(* O: Again, you are abusing Coq here.  Mindfully use destruct first. *)
    apply H_is_even.
(* O: How about:
    Check (IHm' H_is_even).
   ?
*)
    apply IHm'. (*Which tells us that if n is even, then n * m' is even. So we need the fact that n is even. *)
    apply H_is_even.
Qed.

Corollary product_of_any_number_and_even_is_even :
  forall (n m : nat),
    is_even m = true ->
    is_even (n * m) = true.
Proof.
  intros n m.
  revert m. (* Will not fall for this again. *)
  induction n as [ | n' IHn'].

  - intro m.
    intro H_is_even.
    rewrite -> (Nat.mul_0_l).
    rewrite -> (fold_unfold_is_even_O).
    reflexivity.

  - intro m.
    intro H_is_even.
    rewrite -> Nat.mul_succ_l.
    rewrite -> Nat.add_comm.
    Check evenness_of_additions.
    apply (evenness_of_additions m (n' * m)).
    apply H_is_even.
    apply IHn'.
    apply H_is_even.
Qed.
(* O: Why is this a corollary?  You have a full-fledged proof.
      A corollary would be to use Nat.nat_comm and then product_of_even_and_any_number_is_even.
*)

Theorem the_product_of_two_consecutive_nat_numbers_is_even :
  forall (n : nat), is_even (mult n (S n)) = true.
Proof.
  intro n.
(* O: How about using n_is_either_even_or_odd here?
  destruct (n_is_either_even_or_odd n) as [H_n | H_n].
*)

  case n as [ | n' IHn'].

  - Search (0 * _ = 0).
    rewrite -> (Nat.mul_0_l 1).
    rewrite -> (fold_unfold_is_even_O).
    reflexivity.

  - Check Nat.mul_succ_l.
    rewrite -> Nat.mul_succ_l.
    rewrite -> Nat.add_succ_r.
    rewrite -> Nat.add_succ_r.
    rewrite -> fold_unfold_is_even_S.
    rewrite -> fold_unfold_is_odd_S.
    rewrite -> Nat.mul_comm.
    Search (S _ * _ = _).
    rewrite -> (Nat.mul_succ_l).
    rewrite -> (Nat.mul_succ_l).
    Abort.


Lemma plus_n_0 : forall n:nat, n = n + 0.
intro n; elim n.
simpl.
auto.
simpl; auto.
Qed.
Print plus_n_0.
Print eq_refl.
Hint Resolve plus_n_0.

Lemma plus_n_S : forall n m : nat, S (n + m) = n + S m.
simple induction n; simpl; auto.
Qed.

Lemma plus_com : forall n m : nat, n+m = m+n.
simple induction m; simpl; auto.
intros m' E; rewrite <- E; auto.
Qed.

Print plus_com.
Print nat_ind.

Definition Is_S (n:nat) := match n with
| 0 => False
| S p => True
end.

Lemma S_Is_S : forall n:nat, Is_S (S n).
simpl; trivial.
Qed.

Lemma no_confusion : forall n:nat, 0 <> S n.
red; intros n H.
change (Is_S 0).
rewrite H; trivial.
simpl; trivial.
Qed.

Theorem plus_id_example : forall n m :nat,
                            n = m -> n+n = m + m.

Proof.
intros.
rewrite -> H.
reflexivity.
Qed.

Theorem plus_id_exercise : forall n m o : nat,
                             n = m -> m = o -> n + m = m + o.
Proof.
intros.
rewrite -> H.
rewrite -> H0.
simpl.
reflexivity.
Qed.

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

Theorem mult_0_plus : forall n m : nat,
(0 + n) * m = n *m.
intros n m.
rewrite -> plus_0_n.
reflexivity. Qed.

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

(*
Theorem plus_1_neq_0_firsttry : forall n : nat,
  beq_nat (n + 1) 0 = false.
*)


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** Decidability results about lists *)

Require Import List Decidable.
Set Implicit Arguments.

Definition decidable_eq A := forall x y:A, decidable (x=y).

Section Dec_in_Prop.
Variables (A:Type)(dec:decidable_eq A).

Lemma In_decidable x (l:list A) : decidable (In x l).
Proof using A dec.
 induction l as [|a l IH].
 - now right.
 - destruct (dec a x).
   + left. now left.
   + destruct IH; simpl; [left|right]; tauto.
Qed.

Lemma incl_decidable (l l':list A) : decidable (incl l l').
Proof using A dec.
 induction l as [|a l IH].
 - left. inversion 1.
 - destruct (In_decidable a l') as [IN|IN].
   + destruct IH as [IC|IC].
     * left. destruct 1; subst; auto.
     * right. contradict IC. intros x H. apply IC; now right.
   + right. contradict IN. apply IN; now left.
Qed.

Lemma NoDup_decidable (l:list A) : decidable (NoDup l).
Proof using A dec.
 induction l as [|a l IH].
 - left; now constructor.
 - destruct (In_decidable a l).
   + right. inversion_clear 1. tauto.
   + destruct IH.
     * left. now constructor.
     * right. inversion_clear 1. tauto.
Qed.

End Dec_in_Prop.

Section Dec_in_Type.
Variables (A:Type)(dec : forall x y:A, {x=y}+{x<>y}).

Definition In_dec := List.In_dec dec. (* Already in List.v *)

Lemma incl_dec (l l':list A) : {incl l l'}+{~incl l l'}.
Proof using A dec.
 induction l as [|a l IH].
 - left. inversion 1.
 - destruct (In_dec a l') as [IN|IN].
   + destruct IH as [IC|IC].
     * left. destruct 1; subst; auto.
     * right. contradict IC. intros x H. apply IC; now right.
   + right. contradict IN. apply IN; now left.
Qed.

Lemma NoDup_dec (l:list A) : {NoDup l}+{~NoDup l}.
Proof using A dec.
 induction l as [|a l IH].
 - left; now constructor.
 - destruct (In_dec a l).
   + right. inversion_clear 1. tauto.
   + destruct IH.
     * left. now constructor.
     * right. inversion_clear 1. tauto.
Qed.

End Dec_in_Type.

(** An extra result: thanks to decidability, a list can be purged
    from redundancies. *)

Lemma uniquify_map A B (d:decidable_eq B)(f:A->B)(l:list A) :
 exists l', NoDup (map f l') /\ incl (map f l) (map f l').
Proof.
 induction l.
 - exists nil. simpl. split; [now constructor | red; trivial].
 - destruct IHl as (l' & N & I).
   destruct (In_decidable d (f a) (map f l')).
   + exists l'; simpl; split; trivial.
     intros x [Hx|Hx]. now subst. now apply I.
   + exists (a::l'); simpl; split.
     * now constructor.
     * intros x [Hx|Hx]. subst; now left. right; now apply I.
Qed.

Lemma uniquify A (d:decidable_eq A)(l:list A) :
 exists l', NoDup l' /\ incl l l'.
Proof.
 destruct (uniquify_map d id l) as (l',H).
 exists l'. now rewrite !map_id in H.
Qed.


From Hammer Require Import Hammer.

Require Import PeanoNat.

Local Open Scope nat_scope.

Notation le_refl := Nat.le_refl.
Notation le_trans := Nat.le_trans.
Notation le_antisym := Nat.le_antisymm.

Hint Resolve le_trans: arith.
Hint Immediate le_antisym: arith.

Notation le_0_n := Nat.le_0_l.
Notation le_Sn_0 := Nat.nle_succ_0.

Lemma le_n_0_eq n : n <= 0 -> 0 = n.
Proof. hammer_hook "Le" "Le.le_n_0_eq".
intros. symmetry. now apply Nat.le_0_r.
Qed.

Theorem le_n_S : forall n m, n <= m -> S n <= S m.
Proof. hammer_hook "Le" "Le.le_n_S".  exact (Peano.le_n_S). Qed.

Theorem le_S_n : forall n m, S n <= S m -> n <= m.
Proof. hammer_hook "Le" "Le.le_S_n".  exact (Peano.le_S_n). Qed.

Notation le_n_Sn := Nat.le_succ_diag_r.
Notation le_Sn_n := Nat.nle_succ_diag_l.

Theorem le_Sn_le : forall n m, S n <= m -> n <= m.
Proof. hammer_hook "Le" "Le.le_Sn_le".  exact (Nat.lt_le_incl). Qed.

Hint Resolve le_0_n le_Sn_0: arith.
Hint Resolve le_n_S le_n_Sn le_Sn_n : arith.
Hint Immediate le_n_0_eq le_Sn_le le_S_n : arith.

Notation le_pred_n := Nat.le_pred_l.
Notation le_pred := Nat.pred_le_mono.

Hint Resolve le_pred_n: arith.

Lemma le_elim_rel :
forall P:nat -> nat -> Prop,
(forall p, P 0 p) ->
(forall p (q:nat), p <= q -> P p q -> P (S p) (S q)) ->
forall n m, n <= m -> P n m.
Proof. hammer_hook "Le" "Le.le_elim_rel".
intros P H0 HS.
induction n; trivial.
intros m Le. elim Le; auto with arith.
Qed.

Notation le_O_n := le_0_n (only parsing).
Notation le_Sn_O := le_Sn_0 (only parsing).
Notation le_n_O_eq := le_n_0_eq (only parsing).


(*
Inductive appears_in {X:Type} (a:X) : list X -> Prop :=
| singleton: appears_in a (cons a nil)
| left: forall l l1, appears_in a l -> appears_in a (l1++l)
| right: forall l l1, appears_in a l -> appears_in a (l++l1).

Example ex1: appears_in 3 [1;3;2;4].
Proof.
  apply (left 3 [3;2;4] [1]).
  apply (right 3 [3] [2;4]).
  apply singleton.
Qed.
*)


Require Export Chap3.

(* Ordered Series *)

Definition asymmetrical {X : Type} (R : relation X) : Prop :=
  forall x y, R x y -> ~(R y x).

Definition transitive {X: Type} (R: relation X) : Prop :=
  forall x y z, R x y -> R y z -> R x z.

Definition connected {X: Type} (R: relation X) : Prop :=
  forall x y, x <> y -> (R x y) /\ (R y x).

Definition aliorelative {X: Type} (R: relation X) : Prop :=
  forall x, ~(R x x).

Inductive square {X: Type} (R: relation X) : relation X :=
  | sq0 : forall x y z, R x y -> R y z -> square R x z.

Inductive diversity {X} : relation X :=
  | dv0 : forall x y, x <> y -> diversity x y.

(* page 33:
It will be seen that an asymmetrical relation is the same thing as
a relation whose square is an aliorelative. It often happens that a
relation is an aliorelative without being asymmetrical, though an
asymmetrical relation is always an aliorelative. For example, “spouse”
is an aliorelative, but is symmetrical, since if x is the spouse of y, y is
the spouse of x. But among transitive relations, all aliorelatives are
asymmetrical as well as vice versa.
 *)
Theorem asy_implies_aliosq :
  forall {X: Type} (R: relation X), asymmetrical R -> aliorelative (square R).
Proof.
  intros.
  unfold aliorelative.
  intros.
  unfold asymmetrical in H.
  intro.
  inversion H0.
  subst.
  apply H in H1.
  apply H1 in H2.
  inversion H2.
Qed.

Theorem aliosq_implies_asy :
  forall {X: Type} (R: relation X), aliorelative (square R) -> asymmetrical R.
Proof.
  intros.
  unfold aliorelative in H.
  unfold asymmetrical.
  intros.
  intro.
  assert (H': square R x x).
  apply sq0 with y; assumption.
  apply H in H'.
  inversion H'.
Qed.

Theorem asy_eqv_aliosq :
  forall {X: Type} (R: relation X), aliorelative (square R) <-> asymmetrical R.
Proof.
  intros.
  split.
  apply aliosq_implies_asy.
  apply asy_implies_aliosq.
Qed.

(* One relation is said to contain or be implied by another if it
holds whenever the other holds.
*)

Definition contains {X} (R Q: relation X) :=
  forall x y, R x y -> Q x y.

(*
From the definitions it will be seen that a transitive relation is one
which is implied by its square, or, as we also say, “contains” its square.
*)

(*
Theorem sqself_imp_trans :
  forall {X: Type} (R: relation X), (R = square R) -> transitive R.
Proof.
  intros.
  unfold transitive.
  intros.
  rewrite H.
  apply sq0 with y; assumption.
Qed.
*)

(* Rectified theorem, this is exactly what the statement is talking *)
Theorem sqself_imp_trans :
  forall {X} (R: relation X), (contains (square R) R) -> transitive R.
Proof.
  intros.
  unfold transitive.
  intros.
  apply H.
  apply sq0 with y; assumption.
Qed.

Theorem trans_imp_sqself :
  forall {X} (R: relation X), transitive R -> (contains (square R) R).
Proof.
  unfold contains.
  intros.
  induction H0.
  unfold transitive in H.
  apply H with y; assumption.
Qed.

(*
A transitive aliorelative is one which contains its square
and is contained in diversity; or, what comes to the same thing, one
whose square implies both it and diversity
*)

Lemma diversity_eqv_aliorelative :
  forall {X} (R: relation X), (contains R diversity) <-> aliorelative R.
Proof.
  intros.
  unfold aliorelative.
  unfold contains.
  split.

  intros. intro.
  apply H in H0.
  inversion H0.
  apply H1. reflexivity.

  intros. intuition.
  apply dv0. intro.
  apply H with y.
  rewrite H1 in H0.
  assumption.
Qed.

Definition transitive_aliorelative {X} (R : relation X) : Prop :=
  contains R (square R) /\ contains R diversity.

Definition transitive_aliorelative' {X} (R : relation X) : Prop :=
  contains (square R) R /\ contains (square R) diversity.

(* continued from above.
—because, when a relation is transitive, asymmetry is equivalent
to being an aliorelative.
*)

Theorem trans_imp_asym_eqv_alio :
  forall {X} (R : relation X), transitive R -> (asymmetrical R <-> aliorelative R).
Proof.
  unfold transitive.
  unfold asymmetrical.
  unfold aliorelative.
  intros.
  split.

  intros. intro.
  apply H0 with x x; assumption.

  intros. intro.
  apply H0 with x.
  apply H with y; assumption.
Qed.

(* A relation is connected when, given any two different terms of its field,
the relation holds between the first and the second or between the second and
the first (not excluding the possibility that both may happen, though both
cannot happen if the relation is asymmetrical).
*)

(* Defined in the beginning as definition of 'connected' *)

(* A relation is serial when it is an aliorelative, transitive,
and connected; or, what is equivalent, when it is asymmetrical,
transitive, and connected.
*)

Definition serial {X} (R : relation X) : Prop :=
  aliorelative R /\ transitive R /\ connected R.
Definition serial' {X} (R : relation X) : Prop :=
  asymmetrical R /\ transitive R /\ connected R.

(*Definition proper_posterity {X} (R : relation X) *)

(* page 36:
The “proper posterity” of x with respect to R consists of
all terms that possess every R-hereditary property possessed by
every term to which x has the relation R.
*)

(* method 1: defining Type
Definition proper_posterity {X} (R : relation X) (x : X) :=
  { y | forall (p : X -> Prop), r_hereditary R p -> R y x }.
*)
(* method 2: defining Prop *)

Definition proper_posterity {X} (R : relation X) (x : X) : X -> Prop :=
  fun y => forall p, r_hereditary R p -> (forall t, R x t -> p t) -> p y.

(*
Definition proper_posterity {X} (R : relation X) (x : X) (y : X) : Prop :=
  r_posterity R y x /\ R y x.
*)

(* A term x is a “proper ancestor” of y with respect to R if y
belongs to the proper posterity of x with respect to R.
*)

Definition proper_ancestor {X} (R : relation X) (x : X) (y : X) : Prop :=
  proper_posterity R y x.

(* It will always be transitive: no matter what sort of relation
   R may be, “R-ancestor” and “proper R-ancestor” are always both transitive.
*)

Theorem r_anc_trans {X} :
  forall R : relation X, transitive (r_ancestor R).
Proof.
  intros.
  unfold transitive. unfold r_ancestor.
  intros.
  apply H0. exact H1.
  apply H. exact H1.
  assumption.
Qed.

Theorem prop_anc_trans {X} :
  forall R : relation X, transitive (proper_ancestor R).
Proof.
  intros.
  unfold transitive. unfold proper_ancestor. unfold proper_posterity.
  intros.

  apply H.
  exact H1.
  intros.
  unfold r_hereditary in H1.
  apply H1 with y.

  apply H0.
  exact H1.
  intros. apply H2. assumption.

  assumption.
Qed.


(*
   Coq Record
   2010_10_21
*)

(****************************************)
(* Inductive を使うコンストラクタの定義 *)
(****************************************)

Inductive zero : Set :=                     (* 0要素 *)
| Zero : zero.
Check zero.                                 (* Set *)
Check zero_rec.
Definition zero0 : zero -> nat :=
  zero_rec (fun z:zero => nat)
  0.
Eval cbv in zero0 (Zero).                   (* 0 *)

Inductive one : Set :=                      (* 1要素 *)
| One : nat -> one.
Check one.                                  (* Set *)
Check one_rec.
Definition one1 : one -> nat :=
  one_rec (fun o:one => nat)
  (fun n:nat => n).
Eval cbv in one1 (One 1).                   (* 1 *)

Inductive two : Set :=                      (* 2要素 *)
| Two : nat -> nat -> two.
Check two.                                  (* Set *)
Check two_rec.
Definition two1 : two -> nat :=             (* 第一要素 *)
  two_rec (fun t:two => nat)
  (fun n m:nat => n).
Eval cbv in two1 (Two 1 2).                 (* 1 *)
Definition two2 : two -> nat :=             (* 第二要素 *)
  two_rec (fun t:two => nat)
  (fun n m:nat => m).
Eval cbv in two2 (Two 1 2).                 (* 2 *)

Inductive o12 : Set :=
| Zero' : o12
| One' : nat -> o12
| Two' : nat -> nat -> o12.

Check o12.                                  (* Set *)
Check o12_rec.

Definition o12012 : o12 -> nat :=
  o12_rec (fun o:o12 => nat)
  0
  (fun n:nat => n)
  (fun n m:nat => m).                       (* 第二要素 *)

Eval cbv in o12012 (Zero').                 (* 0 *)
Eval cbv in o12012 (One' 1).                (* 1 *)
Eval cbv in o12012 (Two' 1 2).              (* 2 *)

Definition o12011 : o12 -> nat :=
  o12_rec (fun o:o12 => nat)
  0
  (fun n:nat => n)
  (fun n m:nat => n).                       (* 第一要素 *)

Eval cbv in o12011 (Zero').                 (* 0 *)
Eval cbv in o12011 (One' 1).                (* 1 *)
Eval cbv in o12011 (Two' 1 2).              (* 1 *)

(*******************************)
(* Record を使うコンストラクタ *)
(*******************************)

Record pair : Set :=
  mkpair {first : nat; second : bool}.

Check pair.                                 (* Set *)
Check mkpair.                               (* nat -> bool -> pair *)
Check mkpair 1 true.                        (* pair *)

(* セレクタは要素名を使えばよい *)
Eval cbv in first (mkpair 1 true).          (* 1 *)
Eval cbv in second (mkpair 1 true).         (* true *)

Check pair_rec.

Definition fst : pair -> nat :=
  pair_rec (fun p:pair => nat)
  (fun n:nat => (fun b:bool => n)).
Definition snd : pair -> bool :=
  pair_rec (fun p:pair => bool)
  (fun n:nat => (fun b:bool => b)).

(* 型の宣言は省略できる。 *)
Definition fst' : pair -> nat :=
  pair_rec (fun p => nat)
  (fun n b => n).
Definition snd' : pair -> bool :=
  pair_rec (fun p => bool)
  (fun n b => b).

Eval cbv in fst (mkpair 1 true).            (* 1 *)
Eval cbv in snd (mkpair 1 true).            (* true *)

(* END *)


Require Import ZArith.
From Bremen.theories.harmony Require Import Letter PitchClass.

Inductive pitch : Set :=
  p : pitchClass -> nat -> pitch.

Notation "PC ' O" := (p PC O) (at level 85, right associativity).

Example C2 := (C # 0) ' 2.
Example Cb4 := (C # - 1) ' 4.

Definition class (x : pitch) : pitchClass :=
  match x with
  | pc ' o => pc
  end.

Definition octave (x : pitch) : nat :=
  match x with
  | pc ' o => o
  end.

Definition sharpen (x : pitch) : pitch :=
  sharpen (class x) ' (octave x).

Definition flatten (x : pitch) : pitch :=
  flatten (class x) ' (octave x).

Definition distance_C0 (x : pitch) : Z :=
 Z.of_nat(PitchClass.upward_distance (C # 0) (class x)) + (Z.of_nat(octave x) * 12).

Definition distance (x y : pitch) : nat :=
  N.to_nat(Z.to_N (Zminus (distance_C0 x) (distance_C0 y))).

Definition enharmonic_eq (x y : pitch) : Prop :=
  distance_C0 x = distance_C0 y.

Notation "X ee= Y" := (enharmonic_eq X Y) (at level 90, right associativity).

Definition halfstep_up (x : pitch) : pitch :=
  match x with
  | B # m ' o => halfstep_up (B # m) ' o + 1
  | l # m ' o => halfstep_up (l # m) ' o
  end.

Notation "> X" := (halfstep_up X) (at level 90, right associativity).

Definition wholestep_up (x : pitch) : pitch :=
  sharpen (> x).

Notation ">> X" := (wholestep_up X) (at level 90, right associativity).

(* pitch-ek távolságára vonatkozó állítások *)
Lemma distance_enharmonic : forall (x y : pitch), distance x y = 0 -> enharmonic_eq x y. Proof. Admitted.
Lemma distance_to_from : forall (x y : pitch), distance x y + distance y x = 0. Proof. Admitted.
Lemma distance_triangle : forall (x y z : pitch), distance x z <= distance x y + distance y z. Proof. Admitted.

(* pitch-ek enharmóniai összefüggései *)
Lemma enharmonic_xx : forall (x : pitch), enharmonic_eq x x. Proof. Admitted.
Lemma enharmonix_xy_yx : forall (x y : pitch), enharmonic_eq x y -> enharmonic_eq y x. Proof. Admitted.
Lemma enharmonic_transitivity : forall (x y z : pitch), (enharmonic_eq x y) /\ (enharmonic_eq y z) -> enharmonic_eq x z.
Proof. Admitted.
Lemma enharmonic_halfstep_up : forall (x y : pitch), enharmonic_eq x y -> enharmonic_eq (halfstep_up x) (halfstep_up y).
Proof. Admitted.


(* (c) Copyright Microsoft Corporation and Inria.                       *)
(* You may distribute this file under the terms of the CeCILL-B license *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq path div choice.
Require Import fintype tuple finfun bigop prime ssralg poly ssrnum ssrint rat.
Require Import polydiv finalg perm zmodp matrix mxalgebra vector.

(******************************************************************************)
(* This file provides various results on divisibility of integers.            *)
(* It defines, for m, n, d : int,                                             *)
(*   (m %% d)%Z == the remainder of the Euclidean division of m by d; this is *)
(*                 the least non-negative element of the coset m + dZ when    *)
(*                 d != 0, and m if d = 0.                                    *)
(*   (m %/ d)%Z == the quotient of the Euclidean division of m by d, such     *)
(*                 that m = (m %/ d)%Z * d + (m %% d)%Z. Since for d != 0 the *)
(*                 remainder is non-negative, (m %/ d)%Z is non-zero for      *)
(*   (d %| m)%Z <=> m is divisible by d; dvdz d is the (collective) predicate *)
(*                 for integers divisible by d, and (d %| m)%Z is actually    *)
(*                 (transposing) notation for m \in dvdz d.                   *)
(* (m = n %[mod d])%Z, (m == n %[mod d])%Z, (m != n %[mod d])%Z               *)
(*                 m and n are (resp. compare, don't compare) equal mod d.    *)
(*     gcdz m n == the (non-negative) greatest common divisor of m and n,     *)
(*                 with gcdz 0 0 = 0.                                         *)
(* coprimez m n <=> m and n are coprime.                                      *)
(*    egcdz m n == the Bezout coefficients of the gcd of m and n: a pair      *)
(*                 (u, v) of coprime integers such that u*m + v*n = gcdz m n. *)
(*                 Alternatively, a Bezoutz lemma states such u and v exist.  *)
(* zchinese m1 m2 n1 n2 == for coprime m1 and m2, a solution to the Chinese   *)
(*                 remainder problem for n1 and n2, i.e., and integer n such  *)
(*                 that n = n1 %[mod m1] and n = n2 %[mod m2].                *)
(*  zcontents p == the contents of p : {poly int}, that is, the gcd of the    *)
(*                 coefficients of p, with the lead coefficient of p,         *)
(* zprimitive p == the primitive part of p : {poly int}, i.e., p divided by   *)
(*                 its contents.                                              *)
(* inIntSpan X v <-> v is an integral linear combination of elements of       *)
(*                 X : seq V, where V is a zmodType. We prove that this is a  *)
(*                 decidable property for Q-vector spaces.                    *)
(* int_Smith_normal_form :: a theorem asserting the existence of the Smith    *)
(*                 normal form for integer matrices.                          *)
(* Note that many of the concepts and results in this file could and perhaps  *)
(* sould be generalized to the more general setting of integral, unique       *)
(* factorization, principal ideal, or Euclidean domains.                      *)
(******************************************************************************)

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

Import GRing.Theory Num.Theory.
Local Open Scope ring_scope.

Definition divz (m d : int) :=
  let: (K, n) := match m with Posz n => (Posz, n) | Negz n => (Negz, n) end in
  sgz d * K (n %/ `|d|)%N.

Definition modz (m d : int) : int := m - divz m d * d.

Definition dvdz d m := (`|d| %| `|m|)%N.

Definition gcdz m n := (gcdn `|m| `|n|)%:Z.

Definition egcdz m n : int * int :=
  if m == 0 then (0, (-1) ^+ (n < 0)%R) else
  let: (u, v) := egcdn `|m| `|n| in (sgz m * u, - (-1) ^+ (n < 0)%R * v%:Z).

Definition coprimez m n := (gcdz m n == 1).

Infix "%/" := divz : int_scope.
Infix "%%" := modz : int_scope.
Notation "d %| m" := (m \in dvdz d) : int_scope.
Notation "m = n %[mod d ]" := (modz m d = modz n d) : int_scope.
Notation "m == n %[mod d ]" := (modz m d == modz n d) : int_scope.
Notation "m <> n %[mod d ]" := (modz m d <> modz n d) : int_scope.
Notation "m != n %[mod d ]" := (modz m d != modz n d) : int_scope.

Lemma divz_nat (n d : nat) : (n %/ d)%Z = (n %/ d)%N.
Proof. by case: d => // d; rewrite /divz /= mul1r. Qed.

Lemma divzN m d : (m %/ - d)%Z = - (m %/ d)%Z.
Proof. by case: m => n; rewrite /divz /= sgzN abszN mulNr. Qed.

Lemma divz_abs m d : (m %/ `|d|)%Z = (-1) ^+ (d < 0)%R * (m %/ d)%Z.
Proof.
by rewrite {3}[d]intEsign !mulr_sign; case: ifP => -> //; rewrite divzN opprK.
Qed.

Lemma div0z d : (0 %/ d)%Z = 0.
Proof.
by rewrite -(canLR (signrMK _) (divz_abs _ _)) (divz_nat 0) div0n mulr0.
Qed.

Lemma divNz_nat m d : (d > 0)%N -> (Negz m %/ d)%Z = - (m %/ d).+1%:Z.
Proof. by case: d => // d _; apply: mul1r. Qed.

Lemma divz_eq m d : m = (m %/ d)%Z * d + (m %% d)%Z.
Proof. by rewrite addrC subrK. Qed.

Lemma modzN m d : (m %% - d)%Z = (m %% d)%Z.
Proof. by rewrite /modz divzN mulrNN. Qed.

Lemma modz_abs m d : (m %% `|d|%N)%Z = (m %% d)%Z.
Proof. by rewrite {2}[d]intEsign mulr_sign; case: ifP; rewrite ?modzN. Qed.

Lemma modz_nat (m d : nat) : (m %% d)%Z = (m %% d)%N.
Proof.
by apply: (canLR (addrK _)); rewrite addrC divz_nat {1}(divn_eq m d).
Qed.

Lemma modNz_nat m d : (d > 0)%N -> (Negz m %% d)%Z = d%:Z - 1 - (m %% d)%:Z.
Proof.
rewrite /modz => /divNz_nat->; apply: (canLR (addrK _)).
rewrite -!addrA -!opprD -!PoszD -opprB mulnSr !addnA PoszD addrK.
by rewrite addnAC -addnA mulnC -divn_eq.
Qed.

Lemma modz_ge0 m d : d != 0 -> 0 <= (m %% d)%Z.
Proof.
rewrite -absz_gt0 -modz_abs => d_gt0.
case: m => n; rewrite ?modNz_nat ?modz_nat // -addrA -opprD subr_ge0.
by rewrite lez_nat ltn_mod.
Qed.

Lemma divz0 m : (m %/ 0)%Z = 0. Proof. by case: m. Qed.
Lemma mod0z d : (0 %% d)%Z = 0. Proof. by rewrite /modz div0z mul0r subrr. Qed.
Lemma modz0 m : (m %% 0)%Z = m. Proof. by rewrite /modz mulr0 subr0. Qed.

Lemma divz_small m d : 0 <= m < `|d|%:Z -> (m %/ d)%Z = 0.
Proof.
rewrite -(canLR (signrMK _) (divz_abs _ _)); case: m => // n /divn_small.
by rewrite divz_nat => ->; rewrite mulr0.
Qed.

Lemma divzMDl q m d : d != 0 -> ((q * d + m) %/ d)%Z = q + (m %/ d)%Z.
Proof.
rewrite neqr_lt -oppr_gt0 => nz_d.
wlog{nz_d} d_gt0: q d / d > 0; last case: d => // d in d_gt0 *.
  move=> IH; case/orP: nz_d => /IH// /(_  (- q)).
  by rewrite mulrNN !divzN -opprD => /oppr_inj.
wlog q_gt0: q m / q >= 0; last case: q q_gt0 => // q _.
  move=> IH; case: q => n; first exact: IH; rewrite NegzE mulNr.
  by apply: canRL (addKr _) _; rewrite -IH ?addNKr.
case: m => n; first by rewrite !divz_nat divnMDl.
have [le_qd_n | lt_qd_n] := leqP (q * d) n.
  rewrite divNz_nat // NegzE -(subnKC le_qd_n) divnMDl //.
  by rewrite -!addnS !PoszD !opprD !addNKr divNz_nat.
rewrite divNz_nat // NegzE -PoszM subzn // divz_nat.
apply: canRL (addrK _) _; congr _%:Z; rewrite addnC -divnMDl // mulSnr.
rewrite -{3}(subnKC (ltn_pmod n d_gt0)) addnA addnS -divn_eq addnAC.
by rewrite subnKC // divnMDl // divn_small ?addn0 // subnSK ?ltn_mod ?leq_subr.
Qed.

Lemma mulzK m d : d != 0 -> (m * d %/ d)%Z = m.
Proof. by move=> d_nz; rewrite -[m * d]addr0 divzMDl // div0z addr0. Qed.

Lemma mulKz m d : d != 0 -> (d * m %/ d)%Z = m.
Proof. by move=> d_nz; rewrite mulrC mulzK. Qed.

Lemma expzB p m n : p != 0 -> (m >= n)%N -> p ^+ (m - n) = (p ^+ m %/ p ^+ n)%Z.
Proof. by move=> p_nz /subnK{2}<-; rewrite exprD mulzK // expf_neq0. Qed.

Lemma modz1 m : (m %% 1)%Z = 0.
Proof. by case: m => n; rewrite (modNz_nat, modz_nat) ?modn1. Qed.

Lemma divn1 m : (m %/ 1)%Z = m. Proof. by rewrite -{1}[m]mulr1 mulzK. Qed.

Lemma divzz d : (d %/ d)%Z = (d != 0).
Proof. by have [-> // | d_nz] := altP eqP; rewrite -{1}[d]mul1r mulzK. Qed.

Lemma ltz_pmod m d : d > 0 -> (m %% d)%Z < d.
Proof.
case: m d => n [] // d d_gt0; first by rewrite modz_nat ltz_nat ltn_pmod.
by rewrite modNz_nat // -lez_addr1 addrAC subrK ger_addl oppr_le0.
Qed.

Lemma ltz_mod m d : d != 0 -> (m %% d)%Z < `|d|.
Proof. by rewrite -absz_gt0 -modz_abs => d_gt0; apply: ltz_pmod. Qed.

Lemma divzMpl p m d : p > 0 -> (p * m %/ (p * d) = m %/ d)%Z.
Proof.
case: p => // p p_gt0; wlog d_gt0: d / d > 0; last case: d => // d in d_gt0 *.
  by move=> IH; case/intP: d => [|d|d]; rewrite ?mulr0 ?divz0 ?mulrN ?divzN ?IH.
rewrite {1}(divz_eq m d) mulrDr mulrCA divzMDl ?mulf_neq0 ?gtr_eqF // addrC.
rewrite divz_small ?add0r // PoszM pmulr_rge0 ?modz_ge0 ?gtr_eqF //=.
by rewrite ltr_pmul2l ?ltz_pmod.
Qed.
Implicit Arguments divzMpl [p m d].

Lemma divzMpr p m d : p > 0 -> (m * p %/ (d * p) = m %/ d)%Z.
Proof. by move=> p_gt0; rewrite -!(mulrC p) divzMpl. Qed.
Implicit Arguments divzMpr [p m d].

Lemma lez_floor m d : d != 0 -> (m %/ d)%Z * d <= m.
Proof. by rewrite -subr_ge0; apply: modz_ge0. Qed.

(* leq_mod does not extend to negative m. *)
Lemma lez_div m d : (`|(m %/ d)%Z| <= `|m|)%N.
Proof.
wlog d_gt0: d / d > 0; last case: d d_gt0 => // d d_gt0.
  by move=> IH; case/intP: d => [|n|n]; rewrite ?divz0 ?divzN ?abszN // IH.
case: m => n; first by rewrite divz_nat leq_div.
by rewrite divNz_nat // NegzE !abszN ltnS leq_div.
Qed.

Lemma ltz_ceil m d : d > 0 -> m < ((m %/ d)%Z + 1) * d.
Proof.
by case: d => // d d_gt0; rewrite mulrDl mul1r -ltr_subl_addl ltz_mod ?gtr_eqF.
Qed.

Lemma ltz_divLR m n d : d > 0 -> ((m %/ d)%Z < n) = (m < n * d).
Proof.
move=> d_gt0; apply/idP/idP.
  by rewrite -lez_addr1 -(ler_pmul2r d_gt0); apply: ltr_le_trans (ltz_ceil _ _).
rewrite -(ltr_pmul2r d_gt0 _ n) //; apply: ler_lt_trans (lez_floor _ _).
by rewrite gtr_eqF.
Qed.

Lemma lez_divRL m n d : d > 0 -> (m <= (n %/ d)%Z) = (m * d <= n).
Proof. by move=> d_gt0; rewrite !lerNgt ltz_divLR. Qed.

Lemma divz_ge0 m d : d > 0 -> ((m %/ d)%Z >= 0) = (m >= 0).
Proof. by case: d m => // d [] n d_gt0; rewrite (divz_nat, divNz_nat). Qed.

Lemma divzMA_ge0 m n p : n >= 0 -> (m %/ (n * p) = (m %/ n)%Z %/ p)%Z.
Proof.
case: n => // [[|n]] _; first by rewrite mul0r !divz0 div0z.
wlog p_gt0: p / p > 0; last case: p => // p in p_gt0 *.
  by case/intP: p => [|p|p] IH; rewrite ?mulr0 ?divz0 ?mulrN ?divzN // IH.
rewrite {2}(divz_eq m (n.+1%:Z * p)) mulrA mulrAC !divzMDl // ?gtr_eqF //.
rewrite [rhs in _ + rhs]divz_small ?addr0 // ltz_divLR // divz_ge0 //.
by rewrite mulrC ltz_pmod ?modz_ge0 ?gtr_eqF ?pmulr_lgt0.
Qed.

Lemma modz_small m d : 0 <= m < d -> (m %% d)%Z = m.
Proof. by case: m d => //= m [] // d; rewrite modz_nat => /modn_small->. Qed.

Lemma modz_mod m d : ((m %% d)%Z = m %[mod d])%Z.
Proof.
rewrite -!(modz_abs _ d); case: {d}`|d|%N => [|d]; first by rewrite !modz0.
by rewrite modz_small ?modz_ge0 ?ltz_mod.
Qed.

Lemma modzMDl p m d : (p * d + m = m %[mod d])%Z.
Proof.
have [-> | d_nz] := eqVneq d 0; first by rewrite mulr0 add0r.
by rewrite /modz divzMDl // mulrDl opprD addrACA subrr add0r.
Qed.

Lemma mulz_modr {p m d} : 0 < p -> p * (m %% d)%Z = ((p * m) %% (p * d))%Z.
Proof.
case: p => // p p_gt0; rewrite mulrBr; apply: canLR (addrK _) _.
by rewrite mulrCA -(divzMpl p_gt0) subrK.
Qed.

Lemma mulz_modl {p m d} : 0 < p -> (m %% d)%Z * p = ((m * p) %% (d * p))%Z.
Proof. by rewrite -!(mulrC p); apply: mulz_modr. Qed.

Lemma modzDl m d : (d + m = m %[mod d])%Z.
Proof. by rewrite -{1}[d]mul1r modzMDl. Qed.

Lemma modzDr m d : (m + d = m %[mod d])%Z.
Proof. by rewrite addrC modzDl. Qed.

Lemma modzz d : (d %% d)%Z = 0.
Proof. by rewrite -{1}[d]addr0 modzDl mod0z. Qed.

Lemma modzMl p d : (p * d %% d)%Z = 0.
Proof. by rewrite -[p * d]addr0 modzMDl mod0z. Qed.

Lemma modzMr p d : (d * p %% d)%Z = 0.
Proof. by rewrite mulrC modzMl. Qed.

Lemma modzDml m n d : ((m %% d)%Z + n = m + n %[mod d])%Z.
Proof. by rewrite {2}(divz_eq m d) -[_ * d + _ + n]addrA modzMDl. Qed.

Lemma modzDmr m n d : (m + (n %% d)%Z = m + n %[mod d])%Z.
Proof. by rewrite !(addrC m) modzDml. Qed.

Lemma modzDm m n d : ((m %% d)%Z + (n %% d)%Z = m + n %[mod d])%Z.
Proof. by rewrite modzDml modzDmr. Qed.

Lemma eqz_modDl p m n d : (p + m == p + n %[mod d])%Z = (m == n %[mod d])%Z.
Proof.
have [-> | d_nz] := eqVneq d 0; first by rewrite !modz0 (inj_eq (addrI p)).
apply/eqP/eqP=> eq_mn; last by rewrite -modzDmr eq_mn modzDmr.
by rewrite -(addKr p m) -modzDmr eq_mn modzDmr addKr.
Qed.

Lemma eqz_modDr p m n d : (m + p == n + p %[mod d])%Z = (m == n %[mod d])%Z.
Proof. by rewrite -!(addrC p) eqz_modDl. Qed.

Lemma modzMml m n d : ((m %% d)%Z * n = m * n %[mod d])%Z.
Proof. by rewrite {2}(divz_eq m d) mulrDl mulrAC modzMDl. Qed.

Lemma modzMmr m n d : (m * (n %% d)%Z = m * n %[mod d])%Z.
Proof. by rewrite !(mulrC m) modzMml. Qed.

Lemma modzMm m n d : ((m %% d)%Z * (n %% d)%Z = m * n %[mod d])%Z.
Proof. by rewrite modzMml modzMmr. Qed.

Lemma modzXm k m d : ((m %% d)%Z ^+ k = m ^+ k %[mod d])%Z.
Proof. by elim: k => // k IHk; rewrite !exprS -modzMmr IHk modzMm. Qed.

Lemma modzNm m d : (- (m %% d)%Z = - m %[mod d])%Z.
Proof. by rewrite -mulN1r modzMmr mulN1r. Qed.

Lemma modz_absm m d : ((-1) ^+ (m < 0)%R * (m %% d)%Z = `|m|%:Z %[mod d])%Z.
Proof. by rewrite modzMmr -abszEsign. Qed.

(** Divisibility **)

Fact dvdz_key d : pred_key (dvdz d). Proof. by []. Qed.
Canonical dvdz_keyed d := KeyedPred (dvdz_key d).

Lemma dvdzE d m : (d %| m)%Z = (`|d| %| `|m|)%N. Proof. by []. Qed.
Lemma dvdz0 d : (d %| 0)%Z. Proof. exact: dvdn0. Qed.
Lemma dvd0z n : (0 %| n)%Z = (n == 0). Proof. by rewrite -absz_eq0 -dvd0n. Qed.
Lemma dvdz1 d : (d %| 1)%Z = (`|d|%N == 1%N). Proof. exact: dvdn1. Qed.
Lemma dvd1z m : (1 %| m)%Z. Proof. exact: dvd1n. Qed.
Lemma dvdzz m : (m %| m)%Z. Proof. exact: dvdnn. Qed.

Lemma dvdz_mull d m n : (d %| n)%Z -> (d %| m * n)%Z.
Proof. by rewrite !dvdzE abszM; apply: dvdn_mull. Qed.

Lemma dvdz_mulr d m n : (d %| m)%Z -> (d %| m * n)%Z.
Proof. by move=> d_m; rewrite mulrC dvdz_mull. Qed.
Hint Resolve dvdz0 dvd1z dvdzz dvdz_mull dvdz_mulr.

Lemma dvdz_mul d1 d2 m1 m2 : (d1 %| m1 -> d2 %| m2 -> d1 * d2 %| m1 * m2)%Z.
Proof. by rewrite !dvdzE !abszM; apply: dvdn_mul. Qed.

Lemma dvdz_trans n d m : (d %| n -> n %| m -> d %| m)%Z.
Proof. by rewrite !dvdzE; apply: dvdn_trans. Qed.

Lemma dvdzP d m : reflect (exists q, m = q * d) (d %| m)%Z.
Proof.
apply: (iffP dvdnP) => [] [q Dm]; last by exists `|q|%N; rewrite Dm abszM.
exists ((-1) ^+ (m < 0)%R * q%:Z * (-1) ^+ (d < 0)%R).
by rewrite -!mulrA -abszEsign -PoszM -Dm -intEsign.
Qed.
Implicit Arguments dvdzP [d m].

Lemma dvdz_mod0P d m : reflect (m %% d = 0)%Z (d %| m)%Z.
Proof.
apply: (iffP dvdzP) => [[q ->] | md0]; first by rewrite modzMl.
by rewrite (divz_eq m d) md0 addr0; exists (m %/ d)%Z.
Qed.
Implicit Arguments dvdz_mod0P [d m].

Lemma dvdz_eq d m : (d %| m)%Z = ((m %/ d)%Z * d == m).
Proof. by rewrite (sameP dvdz_mod0P eqP) subr_eq0 eq_sym. Qed.

Lemma divzK d m : (d %| m)%Z -> (m %/ d)%Z * d = m.
Proof. by rewrite dvdz_eq => /eqP. Qed.

Lemma lez_divLR d m n : 0 < d -> (d %| m)%Z -> ((m %/ d)%Z <= n) = (m <= n * d).
Proof. by move=> /ler_pmul2r <- /divzK->. Qed.

Lemma ltz_divRL d m n : 0 < d -> (d %| m)%Z -> (n < m %/ d)%Z = (n * d < m).
Proof. by move=> /ltr_pmul2r <- /divzK->. Qed.

Lemma eqz_div d m n : d != 0 -> (d %| m)%Z -> (n == m %/ d)%Z = (n * d == m).
Proof. by move=> /mulIf/inj_eq <- /divzK->. Qed.

Lemma eqz_mul d m n : d != 0 -> (d %| m)%Z -> (m == n * d) = (m %/ d == n)%Z.
Proof. by move=> d_gt0 dv_d_m; rewrite eq_sym -eqz_div // eq_sym. Qed.

Lemma divz_mulAC d m n : (d %| m)%Z -> (m %/ d)%Z * n = (m * n %/ d)%Z.
Proof.
have [-> | d_nz] := eqVneq d 0; first by rewrite !divz0 mul0r.
by move/divzK=> {2} <-; rewrite mulrAC mulzK.
Qed.

Lemma mulz_divA d m n : (d %| n)%Z -> m * (n %/ d)%Z = (m * n %/ d)%Z.
Proof. by move=> dv_d_m; rewrite !(mulrC m) divz_mulAC. Qed.

Lemma mulz_divCA d m n :
  (d %| m)%Z -> (d %| n)%Z -> m * (n %/ d)%Z = n * (m %/ d)%Z.
Proof. by move=> dv_d_m dv_d_n; rewrite mulrC divz_mulAC ?mulz_divA. Qed.

Lemma divzA m n p : (p %| n -> n %| m * p -> m %/ (n %/ p)%Z = m * p %/ n)%Z.
Proof.
move/divzK=> p_dv_n; have [->|] := eqVneq n 0; first by rewrite div0z !divz0.
rewrite -{1 2}p_dv_n mulf_eq0 => /norP[pn_nz p_nz] /divzK; rewrite mulrA p_dv_n.
by move/mulIf=> {1} <- //; rewrite mulzK.
Qed.

Lemma divzMA m n p : (n * p %| m -> m %/ (n * p) = (m %/ n)%Z %/ p)%Z.
Proof.
have [-> | nz_p] := eqVneq p 0; first by rewrite mulr0 !divz0.
have [-> | nz_n] := eqVneq n 0; first by rewrite mul0r !divz0 div0z.
by move/divzK=> {2} <-; rewrite mulrA mulrAC !mulzK.
Qed.

Lemma divzAC m n p : (n * p %| m -> (m %/ n)%Z %/ p =  (m %/ p)%Z %/ n)%Z.
Proof. by move=> np_dv_mn; rewrite -!divzMA // mulrC. Qed.

Lemma divzMl p m d : p != 0 -> (d %| m -> p * m %/ (p * d) = m %/ d)%Z.
Proof.
have [-> | nz_d nz_p] := eqVneq d 0; first by rewrite mulr0 !divz0.
by move/divzK=> {1}<-; rewrite mulrCA mulzK ?mulf_neq0.
Qed.

Lemma divzMr p m d : p != 0 -> (d %| m -> m * p %/ (d * p) = m %/ d)%Z.
Proof. by rewrite -!(mulrC p); apply: divzMl. Qed.

Lemma dvdz_mul2l p d m : p != 0 -> (p * d %| p * m)%Z = (d %| m)%Z.
Proof. by rewrite !dvdzE -absz_gt0 !abszM; apply: dvdn_pmul2l. Qed.
Implicit Arguments dvdz_mul2l [p m d].

Lemma dvdz_mul2r p d m : p != 0 -> (d * p %| m * p)%Z = (d %| m)%Z.
Proof. by rewrite !dvdzE -absz_gt0 !abszM; apply: dvdn_pmul2r. Qed.
Implicit Arguments dvdz_mul2r [p m d].

Lemma dvdz_exp2l p m n : (m <= n)%N -> (p ^+ m %| p ^+ n)%Z.
Proof. by rewrite dvdzE !abszX; apply: dvdn_exp2l. Qed.

Lemma dvdz_Pexp2l p m n : `|p| > 1 -> (p ^+ m %| p ^+ n)%Z = (m <= n)%N.
Proof. by rewrite dvdzE !abszX ltz_nat; apply: dvdn_Pexp2l. Qed.

Lemma dvdz_exp2r m n k : (m %| n -> m ^+ k %| n ^+ k)%Z.
Proof. by rewrite !dvdzE !abszX; apply: dvdn_exp2r. Qed.

Fact dvdz_zmod_closed d : zmod_closed (dvdz d).
Proof.
split=> [|_ _ /dvdzP[p ->] /dvdzP[q ->]]; first exact: dvdz0.
by rewrite -mulrBl dvdz_mull.
Qed.
Canonical dvdz_addPred d := AddrPred (dvdz_zmod_closed d).
Canonical dvdz_oppPred d := OpprPred (dvdz_zmod_closed d).
Canonical dvdz_zmodPred d := ZmodPred (dvdz_zmod_closed d).

Lemma dvdz_exp k d m : (0 < k)%N -> (d %| m -> d %| m ^+ k)%Z.
Proof. by case: k => // k _ d_dv_m; rewrite exprS dvdz_mulr. Qed.

Lemma eqz_mod_dvd d m n : (m == n %[mod d])%Z = (d %| m - n)%Z.
Proof.
apply/eqP/dvdz_mod0P=> eq_mn.
  by rewrite -modzDml eq_mn modzDml subrr mod0z.
by rewrite -(subrK n m) -modzDml eq_mn add0r.
Qed.

Lemma divzDl m n d :
  (d %| m)%Z -> ((m + n) %/ d)%Z = (m %/ d)%Z + (n %/ d)%Z.
Proof.
have [-> | d_nz] := eqVneq d 0; first by rewrite !divz0.
by move/divzK=> {1}<-; rewrite divzMDl.
Qed.

Lemma divzDr m n d :
  (d %| n)%Z -> ((m + n) %/ d)%Z = (m %/ d)%Z + (n %/ d)%Z.
Proof. by move=> dv_n; rewrite addrC divzDl // addrC. Qed.

(* Greatest common divisor *)

Lemma gcdzz m : gcdz m m = `|m|%:Z. Proof. by rewrite /gcdz gcdnn. Qed.
Lemma gcdzC : commutative gcdz. Proof. by move=> m n; rewrite /gcdz gcdnC. Qed.
Lemma gcd0z m : gcdz 0 m = `|m|%:Z. Proof. by rewrite /gcdz gcd0n. Qed.
Lemma gcdz0 m : gcdz m 0 = `|m|%:Z. Proof. by rewrite /gcdz gcdn0. Qed.
Lemma gcd1z : left_zero 1 gcdz. Proof. by move=> m; rewrite /gcdz gcd1n. Qed.
Lemma gcdz1 : right_zero 1 gcdz. Proof. by move=> m; rewrite /gcdz gcdn1. Qed.
Lemma dvdz_gcdr m n : (gcdz m n %| n)%Z. Proof. exact: dvdn_gcdr. Qed.
Lemma dvdz_gcdl m n : (gcdz m n %| m)%Z. Proof. exact: dvdn_gcdl. Qed.
Lemma gcdz_eq0 m n : (gcdz m n == 0) = (m == 0) && (n == 0).
Proof. by rewrite -absz_eq0 eqn0Ngt gcdn_gt0 !negb_or -!eqn0Ngt !absz_eq0. Qed.
Lemma gcdNz m n : gcdz (- m) n = gcdz m n. Proof. by rewrite /gcdz abszN. Qed.
Lemma gcdzN m n : gcdz m (- n) = gcdz m n. Proof. by rewrite /gcdz abszN. Qed.

Lemma gcdz_modr m n : gcdz m (n %% m)%Z = gcdz m n.
Proof.
rewrite -modz_abs /gcdz; move/absz: m => m.
have [-> | m_gt0] := posnP m; first by rewrite modz0.
case: n => n; first by rewrite modz_nat gcdn_modr.
rewrite modNz_nat // NegzE abszN {2}(divn_eq n m) -addnS gcdnMDl.
rewrite -addrA -opprD -intS /=; set m1 := _.+1.
have le_m1m: (m1 <= m)%N by exact: ltn_pmod.
by rewrite subzn // !(gcdnC m) -{2 3}(subnK le_m1m) gcdnDl gcdnDr gcdnC.
Qed.

Lemma gcdz_modl m n : gcdz (m %% n)%Z n = gcdz m n.
Proof. by rewrite -!(gcdzC n) gcdz_modr. Qed.

Lemma gcdzMDl q m n : gcdz m (q * m + n) = gcdz m n.
Proof. by rewrite -gcdz_modr modzMDl gcdz_modr. Qed.

Lemma gcdzDl m n : gcdz m (m + n) = gcdz m n.
Proof. by rewrite -{2}(mul1r m) gcdzMDl. Qed.

Lemma gcdzDr m n : gcdz m (n + m) = gcdz m n.
Proof. by rewrite addrC gcdzDl. Qed.

Lemma gcdzMl n m : gcdz n (m * n) = `|n|%:Z.
Proof. by rewrite -[m * n]addr0 gcdzMDl gcdz0. Qed.

Lemma gcdzMr n m : gcdz n (n * m) = `|n|%:Z.
Proof. by rewrite mulrC gcdzMl. Qed.

Lemma gcdz_idPl {m n} : reflect (gcdz m n = `|m|%:Z) (m %| n)%Z.
Proof. by apply: (iffP gcdn_idPl) => [<- | []]. Qed.

Lemma gcdz_idPr {m n} : reflect (gcdz m n = `|n|%:Z) (n %| m)%Z.
Proof. by rewrite gcdzC; apply: gcdz_idPl. Qed.

Lemma expz_min e m n : e >= 0 -> e ^+ minn m n = gcdz (e ^+ m) (e ^+ n).
Proof.
by case: e => // e _; rewrite /gcdz !abszX -expn_min -natz -natrX !natz.
Qed.

Lemma dvdz_gcd p m n : (p %| gcdz m n)%Z = (p %| m)%Z && (p %| n)%Z.
Proof. exact: dvdn_gcd. Qed.

Lemma gcdzAC : right_commutative gcdz.
Proof. by move=> m n p; rewrite /gcdz gcdnAC. Qed.

Lemma gcdzA : associative gcdz.
Proof. by move=> m n p; rewrite /gcdz gcdnA. Qed.

Lemma gcdzCA : left_commutative gcdz.
Proof. by move=> m n p; rewrite /gcdz gcdnCA. Qed.

Lemma gcdzACA : interchange gcdz gcdz.
Proof. by move=> m n p q; rewrite /gcdz gcdnACA. Qed.

Lemma mulz_gcdr m n p : `|m|%:Z * gcdz n p = gcdz (m * n) (m * p).
Proof. by rewrite -PoszM muln_gcdr -!abszM. Qed.

Lemma mulz_gcdl m n p : gcdz m n * `|p|%:Z = gcdz (m * p) (n * p).
Proof. by rewrite -PoszM muln_gcdl -!abszM. Qed.

Lemma mulz_divCA_gcd n m : n * (m %/ gcdz n m)%Z  = m * (n %/ gcdz n m)%Z.
Proof. by rewrite mulz_divCA ?dvdz_gcdl ?dvdz_gcdr. Qed.

(* Not including lcm theory, for now. *)

(* Coprime factors *)

Lemma coprimezE m n : coprimez m n = coprime `|m| `|n|. Proof. by []. Qed.

Lemma coprimez_sym : symmetric coprimez.
Proof. by move=> m n; apply: coprime_sym. Qed.

Lemma coprimeNz m n : coprimez (- m) n = coprimez m n.
Proof. by rewrite coprimezE abszN. Qed.

Lemma coprimezN m n : coprimez m (- n) = coprimez m n.
Proof. by rewrite coprimezE abszN. Qed.

CoInductive egcdz_spec m n : int * int -> Type :=
  EgcdzSpec u v of u * m + v * n = gcdz m n & coprimez u v
     : egcdz_spec m n (u, v).

Lemma egcdzP m n : egcdz_spec m n (egcdz m n).
Proof.
rewrite /egcdz; have [-> | m_nz] := altP eqP.
  by split; [rewrite -abszEsign gcd0z | rewrite coprimezE absz_sign].
have m_gt0 : (`|m| > 0)%N by rewrite absz_gt0.
case: egcdnP (coprime_egcdn `|n| m_gt0) => //= u v Duv _ co_uv; split.
  rewrite !mulNr -!mulrA mulrCA -abszEsg mulrCA -abszEsign.
  by rewrite -!PoszM Duv addnC PoszD addrK.
by rewrite coprimezE abszM absz_sg m_nz mul1n mulNr abszN abszMsign.
Qed.

Lemma Bezoutz m n : {u : int & {v : int | u * m + v * n = gcdz m n}}.
Proof. by exists (egcdz m n).1, (egcdz m n).2; case: egcdzP. Qed.

Lemma coprimezP m n :
  reflect (exists uv, uv.1 * m + uv.2 * n = 1) (coprimez m n).
Proof.
apply: (iffP eqP) => [<-| [[u v] /= Duv]].
  by exists (egcdz m n); case: egcdzP.
congr _%:Z; apply: gcdn_def; rewrite ?dvd1n // => d dv_d_n dv_d_m.
by rewrite -(dvdzE d 1) -Duv [m]intEsg [n]intEsg rpredD ?dvdz_mull.
Qed.

Lemma Gauss_dvdz m n p :
  coprimez m n -> (m * n %| p)%Z = (m %| p)%Z && (n %| p)%Z.
Proof. by move/Gauss_dvd <-; rewrite -abszM. Qed.

Lemma Gauss_dvdzr m n p : coprimez m n -> (m %| n * p)%Z = (m %| p)%Z.
Proof. by rewrite dvdzE abszM => /Gauss_dvdr->. Qed.

Lemma Gauss_dvdzl m n p : coprimez m p -> (m %| n * p)%Z = (m %| n)%Z.
Proof. by rewrite mulrC; apply: Gauss_dvdzr. Qed.

Lemma Gauss_gcdzr p m n : coprimez p m -> gcdz p (m * n) = gcdz p n.
Proof. by rewrite /gcdz abszM => /Gauss_gcdr->. Qed.

Lemma Gauss_gcdzl p m n : coprimez p n -> gcdz p (m * n) = gcdz p m.
Proof. by move=> co_pn; rewrite mulrC Gauss_gcdzr. Qed.

Lemma coprimez_mulr p m n : coprimez p (m * n) = coprimez p m && coprimez p n.
Proof. by rewrite -coprime_mulr -abszM. Qed.

Lemma coprimez_mull p m n : coprimez (m * n) p = coprimez m p && coprimez n p.
Proof. by rewrite -coprime_mull -abszM. Qed.

Lemma coprimez_pexpl k m n : (0 < k)%N -> coprimez (m ^+ k) n = coprimez m n.
Proof. by rewrite /coprimez /gcdz abszX; apply: coprime_pexpl. Qed.

Lemma coprimez_pexpr k m n : (0 < k)%N -> coprimez m (n ^+ k) = coprimez m n.
Proof. by move=> k_gt0; rewrite !(coprimez_sym m) coprimez_pexpl. Qed.

Lemma coprimez_expl k m n : coprimez m n -> coprimez (m ^+ k) n.
Proof. by rewrite /coprimez /gcdz abszX; apply: coprime_expl. Qed.

Lemma coprimez_expr k m n : coprimez m n -> coprimez m (n ^+ k).
Proof. by rewrite !(coprimez_sym m); apply: coprimez_expl. Qed.

Lemma coprimez_dvdl m n p : (m %| n)%N -> coprimez n p -> coprimez m p.
Proof. exact: coprime_dvdl. Qed.

Lemma coprimez_dvdr m n p : (m %| n)%N -> coprimez p n -> coprimez p m.
Proof. exact: coprime_dvdr. Qed.

Lemma dvdz_pexp2r m n k : (k > 0)%N -> (m ^+ k %| n ^+ k)%Z = (m %| n)%Z.
Proof. by rewrite dvdzE !abszX; apply: dvdn_pexp2r. Qed.

Section Chinese.

(***********************************************************************)
(*   The chinese remainder theorem                                     *)
(***********************************************************************)

Variables m1 m2 : int.
Hypothesis co_m12 : coprimez m1 m2.

Lemma zchinese_remainder x y :
  (x == y %[mod m1 * m2])%Z = (x == y %[mod m1])%Z && (x == y %[mod m2])%Z.
Proof. by rewrite !eqz_mod_dvd Gauss_dvdz. Qed.

(***********************************************************************)
(*   A function that solves the chinese remainder problem              *)
(***********************************************************************)

Definition zchinese r1 r2 :=
  r1 * m2 * (egcdz m1 m2).2 + r2 * m1 * (egcdz m1 m2).1.

Lemma zchinese_modl r1 r2 : (zchinese r1 r2 = r1 %[mod m1])%Z.
Proof.
rewrite /zchinese; have [u v /= Duv _] := egcdzP m1 m2.
rewrite -{2}[r1]mulr1 -((gcdz _ _ =P 1) co_m12) -Duv.
by rewrite mulrDr mulrAC addrC (mulrAC r2) !mulrA !modzMDl.
Qed.

Lemma zchinese_modr r1 r2 : (zchinese r1 r2 = r2 %[mod m2])%Z.
Proof.
rewrite /zchinese; have [u v /= Duv _] := egcdzP m1 m2.
rewrite -{2}[r2]mulr1 -((gcdz _ _ =P 1) co_m12) -Duv.
by rewrite mulrAC modzMDl mulrAC addrC mulrDr !mulrA modzMDl.
Qed.

Lemma zchinese_mod x : (x = zchinese (x %% m1)%Z (x %% m2)%Z %[mod m1 * m2])%Z.
Proof.
apply/eqP; rewrite zchinese_remainder //.
by rewrite zchinese_modl zchinese_modr !modz_mod !eqxx.
Qed.

End Chinese.

Section ZpolyScale.

Definition zcontents p :=
  sgz (lead_coef p) * \big[gcdn/0%N]_(i < size p) `|(p`_i)%R|%N.

Lemma sgz_contents p : sgz (zcontents p) = sgz (lead_coef p).
Proof.
rewrite /zcontents mulrC sgzM sgz_id; set d := _%:Z.
have [-> | nz_p] := eqVneq p 0; first by rewrite lead_coef0 mulr0.
rewrite gtr0_sgz ?mul1r // ltz_nat polySpred ?big_ord_recr //= -lead_coefE.
by rewrite gcdn_gt0 orbC absz_gt0 lead_coef_eq0 nz_p.
Qed.

Lemma zcontents_eq0 p : (zcontents p == 0) = (p == 0).
Proof. by rewrite -sgz_eq0 sgz_contents sgz_eq0 lead_coef_eq0. Qed.

Lemma zcontents0 : zcontents 0 = 0.
Proof. by apply/eqP; rewrite zcontents_eq0. Qed.

Lemma zcontentsZ a p : zcontents (a *: p) = a * zcontents p.
Proof.
have [-> | nz_a] := eqVneq a 0; first by rewrite scale0r mul0r zcontents0.
rewrite {2}[a]intEsg mulrCA -mulrA -PoszM big_distrr /= mulrCA mulrA -sgzM.
rewrite -lead_coefZ; congr (_ * _%:Z); rewrite size_scale //.
by apply: eq_bigr => i _; rewrite coefZ abszM.
Qed.

Lemma zcontents_monic p : p \is monic -> zcontents p = 1.
Proof.
move=> mon_p; rewrite /zcontents polySpred ?monic_neq0 //.
by rewrite big_ord_recr /= -lead_coefE (monicP mon_p) gcdn1.
Qed.

Lemma dvdz_contents a p : (a %| zcontents p)%Z = (p \is a polyOver (dvdz a)).
Proof.
rewrite dvdzE abszM absz_sg lead_coef_eq0.
have [-> | nz_p] := altP eqP; first by rewrite mul0n dvdn0 rpred0.
rewrite mul1n; apply/dvdn_biggcdP/(all_nthP 0)=> a_dv_p i ltip /=.
  exact: (a_dv_p (Ordinal ltip)).
exact: a_dv_p.
Qed.

Lemma map_poly_divzK a p :
  p \is a polyOver (dvdz a) -> a *: map_poly (divz^~ a) p = p.
Proof.
move/polyOverP=> a_dv_p; apply/polyP=> i.
by rewrite coefZ coef_map_id0 ?div0z // mulrC divzK.
Qed.

Lemma polyOver_dvdzP a p :
  reflect (exists q, p = a *: q) (p \is a polyOver (dvdz a)).
Proof.
apply: (iffP idP) => [/map_poly_divzK | [q ->]].
  by exists (map_poly (divz^~ a) p).
by apply/polyOverP=> i; rewrite coefZ dvdz_mulr.
Qed.

Definition zprimitive p := map_poly (divz^~ (zcontents p)) p.

Lemma zpolyEprim p : p = zcontents p *: zprimitive p.
Proof. by rewrite map_poly_divzK // -dvdz_contents. Qed.

Lemma zprimitive0 : zprimitive 0 = 0.
Proof.
by apply/polyP=> i; rewrite coef0 coef_map_id0 ?div0z // zcontents0 divz0.
Qed.

Lemma zprimitive_eq0 p : (zprimitive p == 0) = (p == 0).
Proof.
apply/idP/idP=> /eqP p0; first by rewrite [p]zpolyEprim p0 scaler0.
by rewrite p0 zprimitive0.
Qed.

Lemma size_zprimitive p : size (zprimitive p) = size p.
Proof.
have [-> | ] := eqVneq p 0; first by rewrite zprimitive0.
by rewrite {1 3}[p]zpolyEprim scale_poly_eq0 => /norP[/size_scale-> _].
Qed.

Lemma sgz_lead_primitive p : sgz (lead_coef (zprimitive p)) = (p != 0).
Proof.
have [-> | nz_p] := altP eqP; first by rewrite zprimitive0 lead_coef0.
apply: (@mulfI _ (sgz (zcontents p))); first by rewrite sgz_eq0 zcontents_eq0.
by rewrite -sgzM mulr1 -lead_coefZ -zpolyEprim sgz_contents.
Qed.

Lemma zcontents_primitive p : zcontents (zprimitive p) = (p != 0).
Proof.
have [-> | nz_p] := altP eqP; first by rewrite zprimitive0 zcontents0.
apply: (@mulfI _ (zcontents p)); first by rewrite zcontents_eq0.
by rewrite mulr1 -zcontentsZ -zpolyEprim.
Qed.

Lemma zprimitive_id p : zprimitive (zprimitive p) = zprimitive p.
Proof.
have [-> | nz_p] := eqVneq p 0; first by rewrite !zprimitive0.
by rewrite {2}[zprimitive p]zpolyEprim zcontents_primitive nz_p scale1r.
Qed.

Lemma zprimitive_monic p : p \in monic -> zprimitive p = p.
Proof. by move=> mon_p; rewrite {2}[p]zpolyEprim zcontents_monic ?scale1r. Qed.

Lemma zprimitiveZ a p : a != 0 -> zprimitive (a *: p) = zprimitive p.
Proof.
have [-> | nz_p nz_a] := eqVneq p 0; first by rewrite scaler0.
apply: (@mulfI _ (a * zcontents p)%:P).
  by rewrite polyC_eq0 mulf_neq0 ?zcontents_eq0.
by rewrite -{1}zcontentsZ !mul_polyC -zpolyEprim -scalerA -zpolyEprim.
Qed.

Lemma zprimitive_min p a q :
    p != 0 -> p = a *: q ->
  {b | sgz b = sgz (lead_coef q) & q = b *: zprimitive p}.
Proof.
move=> nz_p Dp; have /dvdzP/sig_eqW[b Db]: (a %| zcontents p)%Z.
  by rewrite dvdz_contents; apply/polyOver_dvdzP; exists q.
suffices ->: q = b *: zprimitive p.
  by rewrite lead_coefZ sgzM sgz_lead_primitive nz_p mulr1; exists b.
apply: (@mulfI _ a%:P).
  by apply: contraNneq nz_p; rewrite Dp -mul_polyC => ->; rewrite mul0r.
by rewrite !mul_polyC -Dp scalerA mulrC -Db -zpolyEprim.
Qed.

Lemma zprimitive_irr p a q :
  p != 0 -> zprimitive p = a *: q -> a = sgz (lead_coef q).
Proof.
move=> nz_p Dp; have: p = (a * zcontents p) *: q.
  by rewrite mulrC -scalerA -Dp -zpolyEprim.
case/zprimitive_min=> // b <- /eqP.
rewrite Dp -{1}[q]scale1r scalerA -subr_eq0 -scalerBl scale_poly_eq0 subr_eq0.
have{Dp} /negPf->: q != 0.
  by apply: contraNneq nz_p; rewrite -zprimitive_eq0 Dp => ->; rewrite scaler0.
by case: b a => [[|[|b]] | [|b]] [[|[|a]] | [|a]] //; rewrite mulr0.
Qed.

Lemma zcontentsM p q : zcontents (p * q) = zcontents p * zcontents q.
Proof.
have [-> | nz_p] := eqVneq p 0; first by rewrite !(mul0r, zcontents0).
have [-> | nz_q] := eqVneq q 0; first by rewrite !(mulr0, zcontents0).
rewrite -[zcontents q]mulr1 {1}[p]zpolyEprim {1}[q]zpolyEprim.
rewrite -scalerAl -scalerAr !zcontentsZ; congr (_ * (_ * _)).
rewrite [zcontents _]intEsg sgz_contents lead_coefM sgzM !sgz_lead_primitive.
apply/eqP; rewrite nz_p nz_q !mul1r [_ == _]eqn_leq absz_gt0 zcontents_eq0.
rewrite mulf_neq0 ?zprimitive_eq0 // andbT leqNgt.
apply/negP=> /pdivP[r r_pr r_dv_d]; pose to_r : int -> 'F_r := intr.
have nz_prim_r q1: q1 != 0 -> map_poly to_r (zprimitive q1) != 0.
  move=> nz_q1; apply: contraTneq (prime_gt1 r_pr) => r_dv_q1.
  rewrite -leqNgt dvdn_leq // -(dvdzE r true) -nz_q1 -zcontents_primitive.
  rewrite dvdz_contents; apply/polyOverP=> i /=; rewrite dvdzE /=.
  have /polyP/(_ i)/eqP := r_dv_q1; rewrite coef_map coef0 /=.
  rewrite {1}[_`_i]intEsign rmorphM rmorph_sign /= mulf_eq0 signr_eq0 /=.
  by rewrite -val_eqE /= val_Fp_nat.
suffices{nz_prim_r} /idPn[]: map_poly to_r (zprimitive p * zprimitive q) == 0.
  by rewrite rmorphM mulf_neq0 ?nz_prim_r.
rewrite [_ * _]zpolyEprim [zcontents _]intEsign mulrC -scalerA map_polyZ /=.
by rewrite scale_poly_eq0 -val_eqE /= val_Fp_nat ?(eqnP r_dv_d).
Qed.

Lemma zprimitiveM p q : zprimitive (p * q) = zprimitive p * zprimitive q.
Proof.
have [pq_0|] := eqVneq (p * q) 0.
  rewrite pq_0; move/eqP: pq_0; rewrite mulf_eq0.
  by case/pred2P=> ->; rewrite !zprimitive0 (mul0r, mulr0).
rewrite -zcontents_eq0 -polyC_eq0 => /mulfI; apply; rewrite !mul_polyC.
by rewrite -zpolyEprim zcontentsM -scalerA scalerAr scalerAl -!zpolyEprim.
Qed.

Lemma dvdpP_int p q : p %| q -> {r | q = zprimitive p * r}.
Proof.
case/Pdiv.Idomain.dvdpP/sig2_eqW=> [[c r] /= nz_c Dpr].
exists (zcontents q *: zprimitive r); rewrite -scalerAr.
by rewrite -zprimitiveM mulrC -Dpr zprimitiveZ // -zpolyEprim.
Qed.

Local Notation pZtoQ := (map_poly (intr : int -> rat)).

Lemma size_rat_int_poly p : size (pZtoQ p) = size p.
Proof. by apply: size_map_inj_poly; first exact: intr_inj. Qed.

Lemma rat_poly_scale (p : {poly rat}) :
  {q : {poly int} & {a | a != 0 & p = a%:~R^-1 *: pZtoQ q}}.
Proof.
pose a := \prod_(i < size p) denq p`_i.
have nz_a: a != 0 by apply/prodf_neq0=> i _; exact: denq_neq0.
exists (map_poly numq (a%:~R *: p)), a => //.
apply: canRL (scalerK _) _; rewrite ?intr_eq0 //.
apply/polyP=> i; rewrite !(coefZ, coef_map_id0) // numqK // Qint_def mulrC.
have [ltip | /(nth_default 0)->] := ltnP i (size p); last by rewrite mul0r.
by rewrite [a](bigD1 (Ordinal ltip)) // rmorphM mulrA -numqE -rmorphM denq_int.
Qed.

Lemma dvdp_rat_int p q : (pZtoQ p %| pZtoQ q) = (p %| q).
Proof.
apply/dvdpP/Pdiv.Idomain.dvdpP=> [[/= r1 Dq] | [[/= a r] nz_a Dq]]; last first.
  exists (a%:~R^-1 *: pZtoQ r); rewrite -scalerAl -rmorphM -Dq.
  by rewrite -{2}[a]intz scaler_int rmorphMz -scaler_int scalerK ?intr_eq0.
have [r [a nz_a Dr1]] := rat_poly_scale r1; exists (a, r) => //=.
apply: (map_inj_poly _ _ : injective pZtoQ) => //; first exact: intr_inj.
rewrite -[a]intz scaler_int rmorphMz -scaler_int /= Dq Dr1.
by rewrite -scalerAl -rmorphM scalerKV ?intr_eq0.
Qed.

Lemma dvdpP_rat_int p q :
    p %| pZtoQ q ->
  {p1 : {poly int} & {a | a != 0 & p = a *: pZtoQ p1} & {r | q = p1 * r}}.
Proof.
have{p} [p [a nz_a ->]] := rat_poly_scale p.
rewrite dvdp_scalel ?invr_eq0 ?intr_eq0 // dvdp_rat_int => dv_p_q.
exists (zprimitive p); last exact: dvdpP_int.
have [-> | nz_p] := eqVneq p 0.
  by exists 1; rewrite ?oner_eq0 // zprimitive0 map_poly0 !scaler0.
exists ((zcontents p)%:~R / a%:~R).
  by rewrite mulf_neq0 ?invr_eq0 ?intr_eq0 ?zcontents_eq0.
by rewrite mulrC -scalerA -map_polyZ -zpolyEprim.
Qed.

End ZpolyScale.

(* Integral spans. *)

Lemma int_Smith_normal_form m n (M : 'M[int]_(m, n)) :
  {L : 'M[int]_m & L \in unitmx &
  {R : 'M[int]_n & R \in unitmx &
  {d : seq int | sorted dvdz d &
   M = L *m (\matrix_(i, j) (d`_i *+ (i == j :> nat))) *m R}}}.
Proof.
move: {2}_.+1 (ltnSn (m + n)) => mn.
elim: mn => // mn IHmn in m n M *; rewrite ltnS => le_mn.
have [[i j] nzMij | no_ij] := pickP (fun k => M k.1 k.2 != 0%N); last first.
  do 2![exists 1%:M; first exact: unitmx1]; exists nil => //=.
  apply/matrixP=> i j; apply/eqP; rewrite mulmx1 mul1mx mxE nth_nil mul0rn.
  exact: negbFE (no_ij (i, j)).
do [case: m i => [[]//|m] i; case: n j => [[]//|n] j /=] in M nzMij le_mn *.
wlog Dj: j M nzMij / j = 0; last rewrite {j}Dj in nzMij.
  case/(_ 0 (xcol j 0 M)); rewrite ?mxE ?tpermR // => L uL [R uR [d dvD dM]].
  exists L => //; exists (xcol j 0 R); last exists d => //=.
     by rewrite xcolE unitmx_mul uR unitmx_perm.
  by rewrite xcolE !mulmxA -dM xcolE -mulmxA -perm_mxM tperm2 perm_mx1 mulmx1.
move Da: (M i 0) nzMij => a nz_a.
elim: {a}_.+1 {-2}a (ltnSn `|a|) => // A IHa a leA in m n M i Da nz_a le_mn *.
wlog [j a'Mij]: m n M i Da le_mn / {j | ~~ (a %| M i j)%Z}; last first.
  have nz_j: j != 0 by apply: contraNneq a'Mij => ->; rewrite Da.
  case: n => [[[]//]|n] in j le_mn nz_j M a'Mij Da *.
  wlog{nz_j} Dj: j M a'Mij Da / j = 1; last rewrite {j}Dj in a'Mij.
    case/(_ 1 (xcol j 1 M)); rewrite ?mxE ?tpermR ?tpermD //.
    move=> L uL [R uR [d dvD dM]]; exists L => //.
    exists (xcol j 1 R); first by rewrite xcolE unitmx_mul uR unitmx_perm.
    exists d; rewrite //= xcolE !mulmxA -dM xcolE -mulmxA -perm_mxM tperm2.
    by rewrite perm_mx1 mulmx1.
  have [u [v]] := Bezoutz a (M i 1); set b := gcdz _ _ => Db.
  have{leA} ltA: (`|b| < A)%N.
    rewrite -ltnS (leq_trans _ leA) // ltnS ltn_neqAle andbC.
    rewrite dvdn_leq ?absz_gt0 ? dvdn_gcdl //=.
    by rewrite (contraNneq _ a'Mij) ?dvdzE // => <-; exact: dvdn_gcdr.
  pose t2 := [fun j : 'I_2 => [tuple _; _]`_j : int]; pose a1 := M i 1.
  pose Uul := \matrix_(k, j) t2 (t2 u (- (a1 %/ b)%Z) j) (t2 v (a %/ b)%Z j) k.
  pose U : 'M_(2 + n) := block_mx Uul 0 0 1%:M; pose M1 := M *m U.
  have{nz_a} nz_b: b != 0 by rewrite gcdz_eq0 (negPf nz_a).
  have uU: U \in unitmx.
    rewrite unitmxE det_ublock det1 (expand_det_col _ 0) big_ord_recl big_ord1.
    do 2!rewrite /cofactor [row' _ _]mx11_scalar !mxE det_scalar1 /=.
    rewrite mulr1 mul1r mulN1r opprK -[_ + _](mulzK _ nz_b) mulrDl.
    by rewrite -!mulrA !divzK ?dvdz_gcdl ?dvdz_gcdr // Db divzz nz_b unitr1.
  have{Db} Db: M1 i 0 = b.
    rewrite /M1 -(lshift0 n 1) [U]block_mxEh mul_mx_row row_mxEl.
    rewrite -[M](@hsubmxK _ _ 2) (@mul_row_col _ _ 2) mulmx0 addr0 !mxE /=.
    rewrite big_ord_recl big_ord1 !mxE /= [lshift _ _]((_ =P 0) _) // Da.
    by rewrite [lshift _ _]((_ =P 1) _) // mulrC -(mulrC v).
  have [L uL [R uR [d dvD dM1]]] := IHa b ltA _ _ M1 i Db nz_b le_mn.
  exists L => //; exists (R *m invmx U); last exists d => //.
    by rewrite unitmx_mul uR unitmx_inv.
  by rewrite mulmxA -dM1 mulmxK.
move=> {A leA IHa} IHa; wlog Di: i M Da / i = 0; last rewrite {i}Di in Da.
  case/(_ 0 (xrow i 0 M)); rewrite ?mxE ?tpermR // => L uL [R uR [d dvD dM]].
  exists (xrow i 0 L); first by rewrite xrowE unitmx_mul unitmx_perm.
  exists R => //; exists d; rewrite //= xrowE -!mulmxA (mulmxA L) -dM xrowE.
  by rewrite mulmxA -perm_mxM tperm2 perm_mx1 mul1mx.
without loss /forallP a_dvM0: / [forall j, a %| M 0 j]%Z.
  have [_|] := altP forallP; first exact; rewrite negb_forall => /existsP/sigW.
  by move/IHa=> IH _; apply: IH.
without loss{Da a_dvM0} Da: M / forall j, M 0 j = a.
  pose Uur := col' 0 (\row_j (1 - (M 0 j %/ a)%Z)).
  pose U : 'M_(1 + n) := block_mx 1 Uur 0 1%:M; pose M1 := M *m U.
  have uU: U \in unitmx by rewrite unitmxE det_ublock !det1 mulr1.
  case/(_ (M *m U)) => [j | L uL [R uR [d dvD dM]]].
    rewrite -(lshift0 m 0) -[M](@submxK _ 1 _ 1) (@mulmx_block _ 1 m 1).
    rewrite (@col_mxEu _ 1) !mulmx1 mulmx0 addr0 [ulsubmx _]mx11_scalar.
    rewrite mul_scalar_mx !mxE !lshift0 Da.
    case: splitP => [j0 _ | j1 Dj]; rewrite ?ord1 !mxE // lshift0 rshift1.
    by rewrite mulrBr mulr1 mulrC divzK ?subrK.
  exists L => //; exists (R * U^-1); first by rewrite unitmx_mul uR unitmx_inv.
  by exists d; rewrite //= mulmxA -dM mulmxK.
without loss{IHa} /forallP/(_ (_, _))/= a_dvM: / [forall k, a %| M k.1 k.2]%Z.
  have [_|] := altP forallP; first exact; rewrite negb_forall => /existsP/sigW.
  case=> [[i j] /= a'Mij] _.
  have [|||L uL [R uR [d dvD dM]]] := IHa _ _ M^T j; rewrite ?mxE 1?addnC //.
    by exists i; rewrite mxE.
  exists R^T; last exists L^T; rewrite ?unitmx_tr //; exists d => //.
  rewrite -[M]trmxK dM !trmx_mul mulmxA; congr (_ *m _ *m _).
  by apply/matrixP=> i1 j1; rewrite !mxE eq_sym; case: eqP => // ->.
without loss{nz_a a_dvM} a1: M a Da / a = 1.
  pose M1 := map_mx (divz^~ a) M; case/(_ M1 1)=> // [k|L uL [R uR [d dvD dM]]].
    by rewrite !mxE Da divzz nz_a.
  exists L => //; exists R => //; exists [seq a * x | x <- d].
    case: d dvD {dM} => //= x d; elim: d x => //= y d IHd x /andP[dv_xy /IHd].
    by rewrite [dvdz _ _]dvdz_mul2l ?[_ \in _]dv_xy.
  have ->: M = a *: M1 by apply/matrixP=> i j; rewrite !mxE mulrC divzK ?a_dvM.
  rewrite dM scalemxAl scalemxAr; congr (_ *m _ *m _).
  apply/matrixP=> i j; rewrite !mxE mulrnAr; congr (_ *+ _).
  have [lt_i_d | le_d_i] := ltnP i (size d); first by rewrite (nth_map 0).
  by rewrite !nth_default ?size_map ?mulr0.
rewrite {a}a1 -[m.+1]/(1 + m)%N -[n.+1]/(1 + n)%N in M Da *.
pose Mu := ursubmx M; pose Ml := dlsubmx M.
have{Da} Da: ulsubmx M = 1 by rewrite [_ M]mx11_scalar !mxE !lshift0 Da.
pose M1 := - (Ml *m Mu) + drsubmx M.
have [|L uL [R uR [d dvD dM1]]] := IHmn m n M1; first by rewrite -addnS ltnW.
exists (block_mx 1 0 Ml L).
  by rewrite unitmxE det_lblock det_scalar1 mul1r.
exists (block_mx 1 Mu 0 R).
  by rewrite unitmxE det_ublock det_scalar1 mul1r.
exists (1 :: d); set D1 := \matrix_(i, j) _ in dM1.
  by rewrite /= path_min_sorted // => g _; exact: dvd1n.
rewrite [D in _ *m D *m _](_ : _ = block_mx 1 0 0 D1); last first.
  by apply/matrixP=> i j; do 3?[rewrite ?mxE ?ord1 //=; case: splitP => ? ->].
rewrite !mulmx_block !(mul0mx, mulmx0, addr0) !mulmx1 add0r mul1mx -Da -dM1.
by rewrite addNKr submxK.
Qed.

Definition inIntSpan (V : zmodType) m (s : m.-tuple V) v :=
  exists a : int ^ m, v = \sum_(i < m) s`_i *~ a i.

Lemma dec_Qint_span (vT : vectType rat) m (s : m.-tuple vT) v :
  decidable (inIntSpan s v).
Proof.
have s_s (i : 'I_m): s`_i \in <<s>>%VS by rewrite memv_span ?memt_nth.
have s_Zs a: \sum_(i < m) s`_i *~ a i \in <<s>>%VS.
  by rewrite memv_suml // => i _; rewrite -scaler_int memvZ.
case s_v: (v \in <<s>>%VS); last by right=> [[a Dv]]; rewrite Dv s_Zs in s_v.
pose S := \matrix_(i < m, j < _) coord (vbasis <<s>>) j s`_i.
pose r := \rank S; pose k := (m - r)%N; pose Em := erefl m; pose Ek := erefl k.
have Dm: (m = k + r)%N by rewrite subnK ?rank_leq_row.
have [K kerK]: {K : 'M_(k, m) | map_mx intr K == kermx S}%MS.
  pose B := row_base (kermx S); pose d := \prod_ij denq (B ij.1 ij.2).
  exists (castmx (mxrank_ker S, Em) (map_mx numq (intr d *: B))).
  rewrite /k; case: _ / (mxrank_ker S); set B1 := map_mx _ _.
  have ->: B1 = (intr d *: B).
    apply/matrixP=> i j; rewrite 3!mxE mulrC [d](bigD1 (i, j)) // rmorphM mulrA.
    by rewrite -numqE -rmorphM numq_int.
  suffices nz_d: d%:Q != 0 by rewrite !eqmx_scale // !eq_row_base andbb.
  by rewrite intr_eq0; apply/prodf_neq0 => i _; exact: denq_neq0.
have [L _ [G uG [D _ defK]]] := int_Smith_normal_form K.
pose Gud := castmx (Dm, Em) G; pose G'lr := castmx (Em, Dm) (invmx G).
have{K L D defK kerK} kerGu: map_mx intr (usubmx Gud) *m S = 0.
  pose Kl : 'M[rat]_k:= map_mx intr (lsubmx (castmx (Ek, Dm) (K *m invmx G))).
  have{defK} defK: map_mx intr K = row_mx Kl 0 *m map_mx intr Gud.
    rewrite -[K](mulmxKV uG) -{2}[G](castmxK Dm Em) -/Gud.
    rewrite -[K *m _](castmxK Ek Dm) map_mxM map_castmx.
    rewrite -(hsubmxK (castmx _ _)) map_row_mx -/Kl map_castmx /Em.
    set Kr := map_mx _ _; case: _ / (esym Dm) (map_mx _ _) => /= GudQ.
    congr (row_mx _ _ *m _); apply/matrixP=> i j; rewrite !mxE defK mulmxK //=.
    rewrite castmxE mxE big1 //= => j1 _; rewrite mxE /= eqn_leq andbC.
    by rewrite leqNgt (leq_trans (valP j1)) ?mulr0 ?leq_addr.
  have /row_full_inj: row_full Kl; last apply.
    rewrite /row_full eqn_leq rank_leq_row /= -{1}[k](mxrank_ker S).
    rewrite -(eqmxP kerK) defK map_castmx mxrankMfree; last first.
      case: _ / (Dm); apply/row_freeP; exists (map_mx intr (invmx G)).
      by rewrite -map_mxM mulmxV ?map_mx1.
    by rewrite -mxrank_tr tr_row_mx trmx0 -addsmxE addsmx0 mxrank_tr.
  rewrite mulmx0 mulmxA (sub_kermxP _) // -(eqmxP kerK) defK.
  by rewrite -{2}[Gud]vsubmxK map_col_mx mul_row_col mul0mx addr0.
pose T := map_mx intr (dsubmx Gud) *m S.
have{kerGu} defS: map_mx intr (rsubmx G'lr) *m T = S.
  have: G'lr *m Gud = 1%:M by rewrite /G'lr /Gud; case: _ / (Dm); exact: mulVmx.
  rewrite -{1}[G'lr]hsubmxK -[Gud]vsubmxK mulmxA mul_row_col -map_mxM.
  move/(canRL (addKr _))->; rewrite -mulNmx raddfD /= map_mx1 map_mxM /=.
  by rewrite mulmxDl -mulmxA kerGu mulmx0 add0r mul1mx.
pose vv := \row_j coord (vbasis <<s>>) j v.
have uS: row_full S.
  apply/row_fullP; exists (\matrix_(i, j) coord s j (vbasis <<s>>)`_i).
  apply/matrixP=> j1 j2; rewrite !mxE.
  rewrite -(coord_free _ _ (basis_free (vbasisP _))).
  rewrite -!tnth_nth (coord_span (vbasis_mem (mem_tnth j1 _))) linear_sum.
  by apply: eq_bigr => i _; rewrite !mxE (tnth_nth 0) !linearZ.
have eqST: (S :=: T)%MS by apply/eqmxP; rewrite -{1}defS !submxMl.
case Zv: (map_mx denq (vv *m pinvmx T) == const_mx 1).
  pose a := map_mx numq (vv *m pinvmx T) *m dsubmx Gud.
  left; exists [ffun j => a 0 j].
  transitivity (\sum_j (map_mx intr a *m S) 0 j *: (vbasis <<s>>)`_j).
    rewrite {1}(coord_vbasis s_v); apply: eq_bigr => j _; congr (_ *: _).
    have ->: map_mx intr a = vv *m pinvmx T *m map_mx intr (dsubmx Gud).
      rewrite map_mxM /=; congr (_ *m _); apply/rowP=> i; rewrite 2!mxE numqE.
      by have /eqP/rowP/(_ i) := Zv; rewrite !mxE => ->; rewrite mulr1.
    by rewrite -(mulmxA _ _ S) mulmxKpV ?mxE // -eqST submx_full.
  rewrite (coord_vbasis (s_Zs _)); apply: eq_bigr => j _; congr (_ *: _).
  rewrite linear_sum mxE; apply: eq_bigr => i _.
  by rewrite -scaler_int linearZ [a]lock !mxE ffunE.
right=> [[a Dv]]; case/eqP: Zv; apply/rowP.
have ->: vv = map_mx intr (\row_i a i) *m S.
  apply/rowP=> j; rewrite !mxE Dv linear_sum.
  by apply: eq_bigr => i _; rewrite -scaler_int linearZ !mxE.
rewrite -defS -2!mulmxA; have ->: T *m pinvmx T = 1%:M.
  have uT: row_free T by rewrite /row_free -eqST.
  by apply: (row_free_inj uT); rewrite mul1mx mulmxKpV.
by move=> i; rewrite mulmx1 -map_mxM 2!mxE denq_int mxE.
Qed.


Require Export Lattice.PartialOrder.
Require Import Coq.Sets.Ensembles.

Local Open Scope order_scope.

(** An M-lattice (measure lattice) is partial order relation that has all joins (LUBs) and
a top element. We require the user to provide the bottom element also explicitly. In any
partial order relation with arbitrary joins always has a unique bottom element – namely,
the join of the empty set. *)
Record MLattice : Type :=
  {
    ML_PO :> PartialOrder;
    ML_meets : ∀ (X : Type) (f : X → ML_PO), ⊔ᵍ f;
    ML_top : ML_PO;
    ML_top_top : ∀ (x : ML_PO), x ⊑ ML_top;
    ML_bot : ML_PO;
    ML_bot_bottom : ∀ (x : ML_PO), ML_bot ⊑ x;
(*    (** This is a usual property of real numbers used in the context of metric spaces in
e.g., proof of uniqueness of limits. We require it to be proven for an M-lattice as we
can't prove it constructively in general. Note that its contrapositive is easily provable for
any partial order relation with a bottom element! *)
    ML_strict_bot : ∀ x, (∀ y, ML_bot ⊏ y → x ⊏ y) → x = ML_bot; *)
    (** The subset of distances for which we have to provide constructive approximatons
for limits and such. *)
    ML_appr_cond : ML_PO → Type;
    (** The top element must be in the approximation subset. *)
    ML_appr_top : ML_appr_cond ML_top;
    (** The approximation subset must be all positive. *)
    ML_appr_pos : ∀ x, ML_appr_cond x → ML_bot ⊏ x;
    (** The approximation subset dominate all positive values. *)
    ML_appr_dominate_pos : (∀ x, (∀ y, ML_appr_cond y → x ⊏ y) → x = ML_bot);
    (** This is a dichotomy about the bottom element of a lattice. It states that the
bottom element is either not reachable from a non-bottom element (there is always an
element strictly between them) or there is an element (not necessarily unique) in the
lattice that sits immediately (and strictly) above the bottom element.

We require this as part of the definition of an M-lattice as we can't distinguish
these two cases and we need this distinction to keep proofs (e.g., uniqueness of limits)
constructive. *)
    ML_bottom_dichotomy :
      (∀ x, ML_appr_cond x → {y : ML_PO & ML_appr_cond y & ML_bot ⊏ y ∧ y ⊏ x})
      +
      {ab : ML_PO & ML_appr_cond ab & (∀ x, x ⊏ ab → x = ML_bot)};
    (** All elements are approximatable. This is off course not always constructively
provable, e.g., in bisected spaces. Therefore, we try to avoid it as much as possible.*)
    ML_all_approximatable :
      ∀ x, ML_bot ⊏ x → {b : ML_PO & b ⊑ x & ML_appr_cond b}
  }.

Arguments ML_PO _ : assert.
Arguments ML_meets {_ _} _, _ {_} _.
Arguments ML_top {_}.
Arguments ML_bot {_}.

Definition ApprType (M : MLattice) := {x : M & ML_appr_cond M x}.

Notation "⊤" := ML_top : lattice_scope.
Notation "⊥" := ML_bot : lattice_scope.

Definition Lat_LUB {Lat : MLattice} {X : Type} (f : X → Lat) : ⊔ᵍ f :=
  (ML_meets Lat f).

Definition Lat_LUB_Pair {Lat : MLattice} (x y : Lat) : x ⊔ y :=
  (ML_meets Lat (fun u : bool => if u then x else y)).

Notation "⊔ᵍ Q" := (Lat_LUB Q) : lattice_scope.

Notation "x ⊔ y" := (Lat_LUB_Pair x y) : lattice_scope.

Hint Resolve ML_bot_bottom.

Hint Resolve ML_top_top.

Local Open Scope lattice_scope.

Theorem Top_Unique {Lat : MLattice} (t : Lat) : (∀ x, x ⊑ t) → t = ⊤.
Proof.
  intros H.
  apply PO_ASym; auto.
Qed.

Theorem Bottom_Unique {Lat : MLattice} (b : Lat) : (∀ x, b ⊑ x) → b = ⊥.
Proof.
  intros H.
  apply PO_ASym; auto.
Qed.

Theorem LE_Bottom_Bottom {Lat : MLattice} (b : Lat) : b ⊑ ⊥ → b = ⊥.
Proof.
  intros H.
  apply PO_ASym; auto.
Qed.

Theorem lub_sym {L : MLattice} (a b : L) : (a ⊔ b) = (b ⊔ a) :> L.
Proof.
  apply PO_ASym; apply lub_lst; intros [|];
  apply (lub_ub (fun u : bool => if u then _ else _) _ false) +
  apply (lub_ub (fun u : bool => if u then _ else _) _ true).
Qed.

Theorem lub_bot {L : MLattice} (b : L) : (b ⊔ ⊥) = b :> L.
Proof.
  apply PO_ASym.
  apply lub_lst; intros [|]; trivial.
  apply (lub_ub (fun u : bool => if u then _ else _) _ true).
Qed.


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

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

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

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

Fixpoint double (double_arg0 : natural) : natural
           := match double_arg0 with
              | Zero => Zero
              | Succ n => Succ (Succ (double n))
              end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Lemma lem : forall l1 l2 n, Succ (len (append l1 l2)) = len (append l1 (Cons n l2)).
Proof.
   induction l1.
   - intros. simpl. f_equal. apply IHl1.
   - intros. reflexivity.
Qed.

Theorem theorem0 : forall (x : lst), eq (len (append x x)) (double (len x)).
Proof.
induction x.
   - simpl. rewrite <- IHx. f_equal. rewrite (lem x x n). reflexivity.
   - reflexivity.
Qed.


Extraction Language Haskell.

Section Ejercicio1.

(* 1.1 *)
Lemma predspec : forall n: nat,
  { m: nat | n = 0 /\ m = 0 \/ n = S m }.
Proof.
  intro.
  destruct n;
  [ exists 0; left; split
  | exists n; right
  ]; reflexivity.
Qed.

End Ejercicio1.

(* 1.2 *)
Extraction "predecesor" predspec.

Section Ejercicio2.

Inductive bintree (X: Set) :=
  Empty : bintree X
  | Branch : X -> bintree X -> bintree X -> bintree X.

Inductive mirror (X: Set) : bintree X -> bintree X -> Prop :=
  mirror_empty : mirror X (Empty X) (Empty X)
  | mirror_branch : forall (t11 t12 t21 t22 : bintree X) (x1 x2 : X),
    mirror X t11 t22 -> mirror X t12 t21 ->
      x1 = x2 -> mirror X (Branch X x1 t11 t12) (Branch X x2 t21 t22).

(* 2.1 *)
Lemma MirrorC: forall (A: Set) (t: bintree A),
  { t': bintree A | (mirror A t t') }.
Proof.
  intros.
  induction t.
    exists (Empty A).
    constructor.

    destruct IHt1.
    destruct IHt2.
    exists (Branch A x x1 x0).
    constructor; trivial.
Qed.

(* 2.2 *)
Function inverse (X: Set) (b: bintree X) {struct b}: bintree X :=
  match b with
    Empty => Empty X
    | (Branch e l r) => Branch X e (inverse X r) (inverse X l)
  end.

Hint Constructors mirror.

Lemma MirrorC2: forall (A: Set) (t: bintree A),
{ t' : bintree A | (mirror A t t') }.
Proof.
  intros.
  exists (inverse A t).
  functional induction (inverse A t);
    constructor; trivial.
Qed.

End Ejercicio2.

(* 2.3 *)
Extraction "mirror_function" MirrorC2.

Section Ejercicio3.

(* 3.1 *)
Definition Value := bool.

Inductive BoolExpr: Set :=
  | bbool: bool -> BoolExpr
  | or: BoolExpr -> BoolExpr -> BoolExpr
  | bnot: BoolExpr -> BoolExpr.

Inductive BEval: BoolExpr -> Value -> Prop :=
  | ebool: forall b: bool, BEval (bbool b) (b: Value)
  | eorl: forall e1 e2: BoolExpr,
    BEval e1 true -> BEval (or e1 e2) true
  | eorr: forall e1 e2: BoolExpr,
    BEval e2 true -> BEval (or e1 e2) true
  | eorrl: forall e1 e2: BoolExpr,
    BEval e1 false -> BEval e2 false -> BEval (or e1 e2) false
  | enott: forall e: BoolExpr, BEval e true -> BEval (bnot e) false
  | enotf: forall e: BoolExpr, BEval e false -> BEval (bnot e) true.

Function beval (e : BoolExpr): Value :=
  match e with
    | bbool b => b
    | or e1 e2 =>
    match beval e1, beval e2 with
      | false, false => false
      | _, _ => true
    end
    | bnot e1 => if beval e1 then false else true
  end.

Function sbeval (e : BoolExpr): Value :=
  match e with
    | bbool b => b
    | or e1 e2 =>
    match sbeval e1 with
      | true => true
      | _ => sbeval e2
    end
    | bnot e1 => if sbeval e1 then false else true
  end.

Lemma bevalC: forall e: BoolExpr,
  { b:Value | (BEval e b) }.
Proof.
  intro.
  exists (beval e).
  induction e; simpl.
    constructor.

    case_eq (beval e1); intro.
      constructor.
      rewrite <- H.
      assumption.

      case_eq (beval e2); intro.
      apply eorr.
      rewrite <- H0.
      assumption.

      constructor.
      rewrite <- H.
      assumption.

      rewrite <- H0.
      assumption.

  case_eq (beval e); intro.
    constructor.
    rewrite <- H.
    assumption.

    constructor.
    rewrite <- H.
    assumption.
Qed.

Lemma sbevalC: forall e: BoolExpr,
  { b:Value | (BEval e b) }.
Proof.
  intro.
  exists (sbeval e).
  induction e; simpl.
    constructor.

    case_eq (sbeval e1); intro.
      constructor.
      rewrite <- H.
      assumption.

      case_eq (sbeval e2); intro.
        apply eorr.
        rewrite <- H0.
        assumption.

      constructor.
      rewrite <- H.
      assumption.

      rewrite <- H0.
      assumption.

  case_eq (sbeval e); intro.
    constructor.
    rewrite <- H.
    assumption.

    constructor.
    rewrite <- H.
    assumption.
Qed.

(* 3.2 *)
Hint Constructors BEval.

Lemma bevalC2: forall e: BoolExpr,
  { b:Value | (BEval e b) }.
Proof.
  intro.
  exists (beval e).
  induction e.
    constructor.

    simpl.
    case_eq (beval e1); intro.
      constructor.
      rewrite <- H.
      trivial.

      case_eq (beval e2); intro.
        apply eorr.
        rewrite <- H0.
        trivial.

      constructor.
        rewrite <- H.
        assumption.

        rewrite <- H0.
        assumption.

    simpl.
    case_eq (beval e); intro.
      constructor.
      rewrite <- H.
      assumption.

      constructor.
      rewrite <- H.
      assumption.
Qed.

Lemma sbevalC2: forall e: BoolExpr,
  { b:Value | (BEval e b) }.
Proof.
  intro.
  exists (sbeval e).
  induction e.
    constructor.

    simpl.
    case_eq (sbeval e1); intro.
      constructor.
      rewrite <- H.
      trivial.

      case_eq (sbeval e2); intro.
        apply eorr.
        rewrite <- H0.
        trivial.

      constructor.
        rewrite <- H.
        assumption.

        rewrite <- H0.
        assumption.

    simpl.
    case_eq (sbeval e); intro.
      constructor.
      rewrite <- H.
      assumption.

      constructor.
      rewrite <- H.
      assumption.
Qed.

End Ejercicio3.

(* 3.3 *)
Extract Inductive bool => "Prelude.Bool" [ "Prelude.True" "Prelude.False" ].
Extraction "BEval" bevalC sbevalC.

Section Ejercicio4.

Variable A: Set.

Inductive list: Set :=
  | nil: list
  | cons: A -> list -> list.

Fixpoint append (l1 l2 : list) {struct l1}: list :=
  match l1 with
    | nil => l2
    | cons a l => cons a (append l l2)
  end.

Inductive perm: list -> list -> Prop :=
  | perm_refl: forall l, perm l l
  | perm_cons: forall a l0 l1,
    perm l0 l1-> perm (cons a l0)(cons a l1)
  | perm_app: forall a l,
    perm (cons a l) (append l (cons a nil))
  | perm_trans: forall l1 l2 l3,
    perm l1 l2 -> perm l2 l3 -> perm l1 l3.

Hint Constructors perm.

(* 4.1 *)
Function reverse (l: list) {struct l}: list :=
  match l with
    | nil => nil
    | cons x xs => append (reverse xs) (cons x nil)
  end.

(* 4.2 *)
Lemma Ej6_4: forall l: list, { l2: list | perm l l2 }.
Proof.
  intro.
  functional induction (reverse l);
  [ exists nil
  | destruct IHl0;
    exists (append (cons x nil) x0);
    constructor
  ]; trivial.
Qed.

(* exists reverse l *)
(* perm_trans *)

Lemma Ej6_4': forall l: list, { l2: list | perm l l2 }.
Proof.
  induction l.
    exists nil.
    constructor.

    destruct IHl.
    exists (cons a x).
    constructor.
    trivial.
Qed.

End Ejercicio4.

Section Ejercicio5.

Inductive Le: nat -> nat -> Prop :=
  LeZero: forall m: nat, Le 0 m
  | LeS: forall n m: nat, Le n m -> Le (S n) (S m).

Inductive Le': nat -> nat -> Prop :=
  LeZero': forall n: nat, Le' n n
  | LeS': forall n m: nat, Le' n m -> Le' n (S m).

Inductive Gt: nat -> nat -> Prop :=
  GtZero: forall m: nat, Gt (S m) 0
  | GtS: forall n m: nat, Gt n m -> Gt (S n) (S m).

Inductive Gt': nat -> nat -> Prop :=
  GtZero': forall n: nat, Gt' n n
  | GtS': forall n m: nat, Gt' n m -> Gt' (S n) m.

Function leBool (n m: nat) {struct n}: bool :=
  match n, m with
    0, _ => true
    | S k, 0 => false
    | S k1, S k2 => leBool k1 k2
  end.

(**
Function leBool : nat -> nat -> bool :=
  fun x y =>
    match Le x y with
      | True => true
      | _ => false
    end.
**)

Lemma Le_Gt_dec: forall n m: nat,
  { (Le n m) } + { (Gt n m) }.
Proof.
  intros.
  functional induction (leBool n m).
    left.
    apply LeZero.

    right.
    apply GtZero.

    elim IHb; intro.
      left.
      apply LeS.
      assumption.

      right.
      apply GtS.
      assumption.
Qed.

Require Import Omega.

Lemma le_gt_dec: forall n m: nat,
  { (le n m) } + { (gt n m) }.
Proof.
  intros.
  functional induction (leBool n m).
    left.
    omega.

    right.
    omega.

    destruct IHb.
      left.
      omega.

      right.
      omega.
Qed.

End Ejercicio5.

Section Ejercicio6.

Require Import Omega.
Require Import DecBool.
Require Import Compare_dec.
Require Import Plus.
Require Import Mult.
Require Import NPeano.

Definition spec_res_nat_div_mod (a b: nat) (qr: nat*nat) :=
  match qr with
    (q,r) => (a = b*q + r) /\ r < b
  end.

Definition ltb n m := leb (S n) m.

Lemma nat_div_mod :
  forall a b: nat, not (b = 0)
    -> { qr: nat*nat | spec_res_nat_div_mod a b qr }.
Proof.
  intros.
  induction a.
    exists (0, 0).
    split.
      rewrite mult_0_r.
      rewrite plus_0_r.
      reflexivity.

      elim (zerop b); [ contradiction | trivial ].

    case_eq b; intros.
      contradiction.

      destruct IHa.
      destruct x.
      simpl in s.
      destruct s.
      rewrite H1.
      case_eq (ltb n1 n); intro.
        exists (n0, S n1).
        simpl.
        split.
          rewrite H0.
          simpl.
          trivial.

          unfold ltb in H3.
          apply leb_complete in H3.
          apply le_lt_n_Sm.
          trivial.

        exists (S n0, 0).
        simpl.
        split.
          rewrite H0.
          simpl.
          unfold ltb in H3.
          apply leb_iff_conv in H3.
          rewrite H0 in H2.
          apply lt_le_S in H2.
          apply lt_le_S in H3.
          apply le_S_n in H2.
          apply le_S_n in H3.
          assert (n = n1) by (apply (le_antisym n n1); trivial).
          rewrite H4.
          rewrite mult_succ_r.
          rewrite plus_0_r.
          rewrite plus_assoc.
          trivial.

          apply lt_0_Sn.
Qed.

End Ejercicio6.

Extraction "nat_div_mod" nat_div_mod.

Section Ejercicio7.

Inductive tree (A: Set): Set :=
  | leaf: tree A
  | node: A -> tree A -> tree A -> tree A.

Inductive tree_sub (A: Set) (t: tree A) :tree A -> Prop :=
  | tree_sub1: forall (t': tree A) (x: A),
    tree_sub A t (node A x t t')
  | tree_sub2: forall (t': tree A) (x: A),
    tree_sub A t (node A x t' t).

Theorem well_founded_tree_sub: forall A: Set,
  well_founded (tree_sub A).
Proof.
  unfold well_founded.
  intros.
  induction a;
  constructor;
  intros;
  inversion H;
  trivial.
Qed.

End Ejercicio7.

Section Ejercicio8.

Require Import Inverse_Image.
Require Import Wf_nat.

(**
Inductive BoolExpr : Set :=
  | bbool : bool -> BoolExpr
  | or : BoolExpr -> BoolExpr -> BoolExpr
  | bnot : BoolExpr -> BoolExpr.
**)

(* 8.1 *)
Function size (e: BoolExpr): nat :=
  match e with
    | bbool b => 1
    | or e1 e2 => 1 + size e1 + size e2
    | bnot e => 1 + size e
  end.

Definition elt (e1 e2: BoolExpr) := size e1 < size e2.

(* 8.2 *)
Theorem well_founded_elt: forall A: Set,
  well_founded elt.
Proof.
  unfold well_founded.
  intros.
  induction a;
  constructor;
  intros;
  inversion H;
  apply Acc_inverse_image;
  apply lt_wf.
Qed.

End Ejercicio8.


From Hammer Require Import Hammer.

Set Warnings "-notation-overridden,-parsing".
From LF Require Export IndProp.

Definition relation (X: Type) := X -> X -> Prop.

Print le.

Check le : nat -> nat -> Prop.
Check le : relation nat.

Definition partial_function {X: Type} (R: relation X) :=
forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

Print next_nat.

Check next_nat : relation nat.

Theorem next_nat_partial_function :
partial_function next_nat.
Proof. hammer_hook "Rel" "Rel.next_nat_partial_function".
unfold partial_function.
intros x y1 y2 H1 H2.
inversion H1. inversion H2.
reflexivity.  Qed.

Theorem le_not_a_partial_function :
~ (partial_function le).
Proof. hammer_hook "Rel" "Rel.le_not_a_partial_function".
unfold not. unfold partial_function. intros Hc.
assert (0 = 1) as Nonsense. {
apply Hc with (x := 0).
- apply le_n.
- apply le_S. apply le_n. }
discriminate Nonsense.   Qed.

Definition reflexive {X: Type} (R: relation X) :=
forall a : X, R a a.

Theorem le_reflexive :
reflexive le.
Proof. hammer_hook "Rel" "Rel.le_reflexive".
unfold reflexive. intros n. apply le_n.  Qed.

Definition transitive {X: Type} (R: relation X) :=
forall a b c : X, (R a b) -> (R b c) -> (R a c).

Theorem le_trans :
transitive le.
Proof. hammer_hook "Rel" "Rel.le_trans".
intros n m o Hnm Hmo.
induction Hmo.
-  apply Hnm.
-  apply le_S. apply IHHmo.  Qed.

Theorem lt_trans:
transitive lt.
Proof. hammer_hook "Rel" "Rel.lt_trans".
unfold lt. unfold transitive.
intros n m o Hnm Hmo.
apply le_S in Hnm.
apply le_trans with (a := (S n)) (b := (S m)) (c := o).
apply Hnm.
apply Hmo. Qed.

Theorem lt_trans' :
transitive lt.
Proof. hammer_hook "Rel" "Rel.lt_trans'".

unfold lt. unfold transitive.
intros n m o Hnm Hmo.
induction Hmo as [| m' Hm'o].
Admitted.

Theorem lt_trans'' :
transitive lt.
Proof. hammer_hook "Rel" "Rel.lt_trans''".
unfold lt. unfold transitive.
intros n m o Hnm Hmo.
induction o as [| o'].
Admitted.

Theorem le_Sn_le : forall n m, S n <= m -> n <= m.
Proof. hammer_hook "Rel" "Rel.le_Sn_le".
intros n m H. apply le_trans with (S n).
- apply le_S. apply le_n.
- apply H.
Qed.

Theorem le_S_n : forall n m,
(S n <= S m) -> (n <= m).
Proof. hammer_hook "Rel" "Rel.le_S_n".
Admitted.

Theorem le_Sn_n : forall n,
~ (S n <= n).
Proof. hammer_hook "Rel" "Rel.le_Sn_n".
Admitted.

Definition symmetric {X: Type} (R: relation X) :=
forall a b : X, (R a b) -> (R b a).

Theorem le_not_symmetric :
~ (symmetric le).
Proof. hammer_hook "Rel" "Rel.le_not_symmetric".
Admitted.

Definition antisymmetric {X: Type} (R: relation X) :=
forall a b : X, (R a b) -> (R b a) -> a = b.

Theorem le_antisymmetric :
antisymmetric le.
Proof. hammer_hook "Rel" "Rel.le_antisymmetric".
Admitted.

Theorem le_step : forall n m p,
n < m ->
m <= S p ->
n <= p.
Proof. hammer_hook "Rel" "Rel.le_step".
Admitted.

Definition equivalence {X:Type} (R: relation X) :=
(reflexive R) /\ (symmetric R) /\ (transitive R).

Definition order {X:Type} (R: relation X) :=
(reflexive R) /\ (antisymmetric R) /\ (transitive R).

Definition preorder {X:Type} (R: relation X) :=
(reflexive R) /\ (transitive R).

Theorem le_order :
order le.
Proof. hammer_hook "Rel" "Rel.le_order".
unfold order. split.
-  apply le_reflexive.
- split.
+  apply le_antisymmetric.
+  apply le_trans.  Qed.

Inductive clos_refl_trans {A: Type} (R: relation A) : relation A :=
| rt_step x y (H : R x y) : clos_refl_trans R x y
| rt_refl x : clos_refl_trans R x x
| rt_trans x y z
(Hxy : clos_refl_trans R x y)
(Hyz : clos_refl_trans R y z) :
clos_refl_trans R x z.

Theorem next_nat_closure_is_le : forall n m,
(n <= m) <-> ((clos_refl_trans next_nat) n m).
Proof. hammer_hook "Rel" "Rel.next_nat_closure_is_le".
intros n m. split.
-
intro H. induction H.
+  apply rt_refl.
+
apply rt_trans with m. apply IHle. apply rt_step.
apply nn.
-
intro H. induction H.
+  inversion H. apply le_S. apply le_n.
+  apply le_n.
+
apply le_trans with y.
apply IHclos_refl_trans1.
apply IHclos_refl_trans2. Qed.

Inductive clos_refl_trans_1n {A : Type}
(R : relation A) (x : A)
: A -> Prop :=
| rt1n_refl : clos_refl_trans_1n R x x
| rt1n_trans (y z : A)
(Hxy : R x y) (Hrest : clos_refl_trans_1n R y z) :
clos_refl_trans_1n R x z.

Lemma rsc_R : forall (X:Type) (R:relation X) (x y : X),
R x y -> clos_refl_trans_1n R x y.
Proof. hammer_hook "Rel" "Rel.rsc_R".
intros X R x y H.
apply rt1n_trans with y. apply H. apply rt1n_refl.   Qed.

Lemma rsc_trans :
forall (X:Type) (R: relation X) (x y z : X),
clos_refl_trans_1n R x y  ->
clos_refl_trans_1n R y z ->
clos_refl_trans_1n R x z.
Proof. hammer_hook "Rel" "Rel.rsc_trans".
Admitted.

Theorem rtc_rsc_coincide :
forall (X:Type) (R: relation X) (x y : X),
clos_refl_trans R x y <-> clos_refl_trans_1n R x y.
Proof. hammer_hook "Rel" "Rel.rtc_rsc_coincide".
Admitted.


(* Reflexive_Transitive_Closure stuff, using Type rather than Prop *)

Set Implicit Arguments.
Require Import List.
Import ListNotations.

Require Import gen genT.

(* compare
  https://coq.inria.fr/stdlib/Coq.Relations.Relation_Definitions.html
  https://coq.inria.fr/stdlib/Coq.Relations.Relation_Operators.html
  https://coq.inria.fr/stdlib/Coq.Relations.Operators_Properties.html
  Require Import Coq.Relations.Relation_Definitions.
  Require Import Coq.Relations.Relation_Operators.
  Require Import Coq.Relations.Operators_Properties.
  *)
(* this in genT.v in ../lnt/tense-logic-in-Coq
Definition relationT (A : Type) := A -> A -> Type.
*)

Definition transitiveT W (R : relationT W) :=
  forall (x y z : W), R x y -> R y z -> R x z.
Check transitiveT.

(* see https://coq.inria.fr/stdlib/Coq.Relations.Relation_Operators.html *)
Section Reflexive_ClosureT.
  Variable A : Type.
  Variable R : relationT A.

Inductive clos_reflT (x: A) : A -> Type :=
  | rT_step (y:A) : R x y -> clos_reflT x y
  | rT_refl : clos_reflT x x.

End Reflexive_ClosureT.

Section Reflexive_Transitive_ClosureT.
  Variable A : Type.
  Variable R : relationT A.

Inductive clos_refl_transT (x:A) : A -> Type :=
  | rtT_step (y:A) : R x y -> clos_refl_transT x y
  | rtT_refl : clos_refl_transT x x
  | rtT_trans (y z:A) :
	clos_refl_transT x y -> clos_refl_transT y z -> clos_refl_transT x z.

(* Alternative definition by transitive extension on the left/right *)

Inductive clos_refl_transT_1n (x: A) : A -> Type :=
  | rt1nT_refl : clos_refl_transT_1n x x
  | rt1nT_trans (y z:A) :
       R x y -> clos_refl_transT_1n y z -> clos_refl_transT_1n x z.

Inductive clos_refl_transT_n1 (x: A) : A -> Type :=
  | rtn1T_refl : clos_refl_transT_n1 x x
  | rtn1T_trans (y z:A) :
      R y z -> clos_refl_transT_n1 x y -> clos_refl_transT_n1 x z.

End Reflexive_Transitive_ClosureT.

(* equivalences between above, need to reprove for ...T *)
Lemma clos_rt1n_rtT : forall A R (x y : A),
  clos_refl_transT_1n R x y -> clos_refl_transT R x y.
Proof. intros. induction X. apply rtT_refl.
eapply rtT_trans. apply rtT_step. eassumption. eassumption. Qed.

Lemma clos_rt_rt1nT : forall A R (x y : A),
  clos_refl_transT R x y -> clos_refl_transT_1n R x y.
Proof. intros. induction X.
eapply rt1nT_trans. eassumption. apply rt1nT_refl.
apply rt1nT_refl.
clear X1 X2.  induction IHX1. assumption.
apply IHIHX1 in IHX2. eapply rt1nT_trans ; eassumption. Qed.

Lemma clos_rtn1_rtT : forall A R (x y : A),
  clos_refl_transT_n1 R x y -> clos_refl_transT R x y.
Proof. intros. induction X.  apply rtT_refl.
eapply rtT_trans. eassumption. apply rtT_step. eassumption.  Qed.

Lemma clos_rt_rtn1T : forall A R (x y : A),
  clos_refl_transT R x y -> clos_refl_transT_n1 R x y.
Proof. intros. induction X.
eapply rtn1T_trans. eassumption. apply rtn1T_refl.
apply rtn1T_refl.
clear X1 X2.  induction IHX2. assumption.
eapply rtn1T_trans ; eassumption. Qed.

(*
Lemma clos_rt_rt1n_iffT : forall A R (x y : A),
  clos_refl_transT R x y <-> clos_refl_transT_1n R x y.

Lemma clos_rt_rtn1_iffT : forall A R (x y : A),
  clos_refl_transT R x y <-> clos_refl_transT_n1 R x y.
*)