(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** Euclidean Division *)

Require Import NZAxioms NZMulOrder.

(** The first signatures will be common to all divisions over NZ, N and Z *)

Module Type DivMod (Import A : Typ).
 Parameters Inline div modulo : t -> t -> t.
End DivMod.

Module Type DivModNotation (A : Typ)(Import B : DivMod A).
 Infix "/" := div.
 Infix "mod" := modulo (at level 40, no associativity).
End DivModNotation.

Module Type DivMod' (A : Typ) := DivMod A <+ DivModNotation A.

Module Type NZDivSpec (Import A : NZOrdAxiomsSig')(Import B : DivMod' A).
 Declare Instance div_wd : Proper (eq==>eq==>eq) div.
 Declare Instance mod_wd : Proper (eq==>eq==>eq) modulo.
 Axiom div_mod : forall a b, b ~= 0 -> a == b*(a/b) + (a mod b).
 Axiom mod_bound_pos : forall a b, 0<=a -> 0<b -> 0 <= a mod b < b.
End NZDivSpec.

(** The different divisions will only differ in the conditions
    they impose on [modulo]. For NZ, we have only described the
    behavior on positive numbers.
*)

Module Type NZDiv (A : NZOrdAxiomsSig) := DivMod A <+ NZDivSpec A.
Module Type NZDiv' (A : NZOrdAxiomsSig) := NZDiv A <+ DivModNotation A.

Module Type NZDivProp
 (Import A : NZOrdAxiomsSig')
 (Import B : NZDiv' A)
 (Import C : NZMulOrderProp A).

(** Uniqueness theorems *)

Theorem div_mod_unique :
 forall b q1 q2 r1 r2, 0<=r1<b -> 0<=r2<b ->
  b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2.
Proof.
intros b.
assert (U : forall q1 q2 r1 r2,
            b*q1+r1 == b*q2+r2 -> 0<=r1<b -> 0<=r2 -> q1<q2 -> False).
 intros q1 q2 r1 r2 EQ LT Hr1 Hr2.
 contradict EQ.
 apply lt_neq.
 apply lt_le_trans with (b*q1+b).
 rewrite <- add_lt_mono_l. tauto.
 apply le_trans with (b*q2).
 rewrite mul_comm, <- mul_succ_l, mul_comm.
 apply mul_le_mono_nonneg_l; intuition; try order.
 rewrite le_succ_l; auto.
 rewrite <- (add_0_r (b*q2)) at 1.
 rewrite <- add_le_mono_l. tauto.

intros q1 q2 r1 r2 Hr1 Hr2 EQ; destruct (lt_trichotomy q1 q2) as [LT|[EQ'|GT]].
elim (U q1 q2 r1 r2); intuition.
split; auto. rewrite EQ' in EQ. rewrite add_cancel_l in EQ; auto.
elim (U q2 q1 r2 r1); intuition.
Qed.

Theorem div_unique:
 forall a b q r, 0<=a -> 0<=r<b ->
   a == b*q + r -> q == a/b.
Proof.
intros a b q r Ha (Hb,Hr) EQ.
destruct (div_mod_unique b q (a/b) r (a mod b)); auto.
apply mod_bound_pos; order.
rewrite <- div_mod; order.
Qed.

Theorem mod_unique:
 forall a b q r, 0<=a -> 0<=r<b ->
  a == b*q + r -> r == a mod b.
Proof.
intros a b q r Ha (Hb,Hr) EQ.
destruct (div_mod_unique b q (a/b) r (a mod b)); auto.
apply mod_bound_pos; order.
rewrite <- div_mod; order.
Qed.

Theorem div_unique_exact a b q:
 0<=a -> 0<b -> a == b*q -> q == a/b.
Proof.
 intros Ha Hb H. apply div_unique with 0; nzsimpl; now try split.
Qed.

(** A division by itself returns 1 *)

Lemma div_same : forall a, 0<a -> a/a == 1.
Proof.
intros. symmetry. apply div_unique_exact; nzsimpl; order.
Qed.

Lemma mod_same : forall a, 0<a -> a mod a == 0.
Proof.
intros. symmetry.
apply mod_unique with 1; intuition; try order.
now nzsimpl.
Qed.

(** A division of a small number by a bigger one yields zero. *)

Theorem div_small: forall a b, 0<=a<b -> a/b == 0.
Proof.
intros. symmetry.
apply div_unique with a; intuition; try order.
now nzsimpl.
Qed.

(** Same situation, in term of modulo: *)

Theorem mod_small: forall a b, 0<=a<b -> a mod b == a.
Proof.
intros. symmetry.
apply mod_unique with 0; intuition; try order.
now nzsimpl.
Qed.

(** * Basic values of divisions and modulo. *)

Lemma div_0_l: forall a, 0<a -> 0/a == 0.
Proof.
intros; apply div_small; split; order.
Qed.

Lemma mod_0_l: forall a, 0<a -> 0 mod a == 0.
Proof.
intros; apply mod_small; split; order.
Qed.

Lemma div_1_r: forall a, 0<=a -> a/1 == a.
Proof.
intros. symmetry. apply div_unique_exact; nzsimpl; order'.
Qed.

Lemma mod_1_r: forall a, 0<=a -> a mod 1 == 0.
Proof.
intros. symmetry.
apply mod_unique with a; try split; try order; try apply lt_0_1.
now nzsimpl.
Qed.

Lemma div_1_l: forall a, 1<a -> 1/a == 0.
Proof.
intros; apply div_small; split; auto. apply le_0_1.
Qed.

Lemma mod_1_l: forall a, 1<a -> 1 mod a == 1.
Proof.
intros; apply mod_small; split; auto. apply le_0_1.
Qed.

Lemma div_mul : forall a b, 0<=a -> 0<b -> (a*b)/b == a.
Proof.
intros; symmetry. apply div_unique_exact; trivial.
apply mul_nonneg_nonneg; order.
apply mul_comm.
Qed.

Lemma mod_mul : forall a b, 0<=a -> 0<b -> (a*b) mod b == 0.
Proof.
intros; symmetry.
apply mod_unique with a; try split; try order.
apply mul_nonneg_nonneg; order.
nzsimpl; apply mul_comm.
Qed.

(** * Order results about mod and div *)

(** A modulo cannot grow beyond its starting point. *)

Theorem mod_le: forall a b, 0<=a -> 0<b -> a mod b <= a.
Proof.
intros. destruct (le_gt_cases b a).
apply le_trans with b; auto.
apply lt_le_incl. destruct (mod_bound_pos a b); auto.
rewrite lt_eq_cases; right.
apply mod_small; auto.
Qed.

(* Division of positive numbers is positive. *)

Lemma div_pos: forall a b, 0<=a -> 0<b -> 0 <= a/b.
Proof.
intros.
rewrite (mul_le_mono_pos_l _ _ b); auto; nzsimpl.
rewrite (add_le_mono_r _ _ (a mod b)).
rewrite <- div_mod by order.
nzsimpl.
apply mod_le; auto.
Qed.

Lemma div_str_pos : forall a b, 0<b<=a -> 0 < a/b.
Proof.
intros a b (Hb,Hab).
assert (LE : 0 <= a/b) by (apply div_pos; order).
assert (MOD : a mod b < b) by (destruct (mod_bound_pos a b); order).
rewrite lt_eq_cases in LE; destruct LE as [LT|EQ]; auto.
exfalso; revert Hab.
rewrite (div_mod a b), <-EQ; nzsimpl; order.
Qed.

Lemma div_small_iff : forall a b, 0<=a -> 0<b -> (a/b==0 <-> a<b).
Proof.
intros a b Ha Hb; split; intros Hab.
destruct (lt_ge_cases a b); auto.
symmetry in Hab. contradict Hab. apply lt_neq, div_str_pos; auto.
apply div_small; auto.
Qed.

Lemma mod_small_iff : forall a b, 0<=a -> 0<b -> (a mod b == a <-> a<b).
Proof.
intros a b Ha Hb. split; intros H; auto using mod_small.
rewrite <- div_small_iff; auto.
rewrite <- (mul_cancel_l _ _ b) by order.
rewrite <- (add_cancel_r _ _ (a mod b)).
rewrite <- div_mod, H by order. now nzsimpl.
Qed.

Lemma div_str_pos_iff : forall a b, 0<=a -> 0<b -> (0<a/b <-> b<=a).
Proof.
intros a b Ha Hb; split; intros Hab.
destruct (lt_ge_cases a b) as [LT|LE]; auto.
rewrite <- div_small_iff in LT; order.
apply div_str_pos; auto.
Qed.

(** As soon as the divisor is strictly greater than 1,
    the division is strictly decreasing. *)

Lemma div_lt : forall a b, 0<a -> 1<b -> a/b < a.
Proof.
intros.
assert (0 < b) by (apply lt_trans with 1; auto using lt_0_1).
destruct (lt_ge_cases a b).
rewrite div_small; try split; order.
rewrite (div_mod a b) at 2 by order.
apply lt_le_trans with (b*(a/b)).
rewrite <- (mul_1_l (a/b)) at 1.
rewrite <- mul_lt_mono_pos_r; auto.
apply div_str_pos; auto.
rewrite <- (add_0_r (b*(a/b))) at 1.
rewrite <- add_le_mono_l. destruct (mod_bound_pos a b); order.
Qed.

(** [le] is compatible with a positive division. *)

Lemma div_le_mono : forall a b c, 0<c -> 0<=a<=b -> a/c <= b/c.
Proof.
intros a b c Hc (Ha,Hab).
rewrite lt_eq_cases in Hab. destruct Hab as [LT|EQ];
 [|rewrite EQ; order].
rewrite <- lt_succ_r.
rewrite (mul_lt_mono_pos_l c) by order.
nzsimpl.
rewrite (add_lt_mono_r _ _ (a mod c)).
rewrite <- div_mod by order.
apply lt_le_trans with b; auto.
rewrite (div_mod b c) at 1 by order.
rewrite <- add_assoc, <- add_le_mono_l.
apply le_trans with (c+0).
nzsimpl; destruct (mod_bound_pos b c); order.
rewrite <- add_le_mono_l. destruct (mod_bound_pos a c); order.
Qed.

(** The following two properties could be used as specification of div *)

Lemma mul_div_le : forall a b, 0<=a -> 0<b -> b*(a/b) <= a.
Proof.
intros.
rewrite (add_le_mono_r _ _ (a mod b)), <- div_mod by order.
rewrite <- (add_0_r a) at 1.
rewrite <- add_le_mono_l. destruct (mod_bound_pos a b); order.
Qed.

Lemma mul_succ_div_gt : forall a b, 0<=a -> 0<b -> a < b*(S (a/b)).
Proof.
intros.
rewrite (div_mod a b) at 1 by order.
rewrite (mul_succ_r).
rewrite <- add_lt_mono_l.
destruct (mod_bound_pos a b); auto.
Qed.

(** The previous inequality is exact iff the modulo is zero. *)

Lemma div_exact : forall a b, 0<=a -> 0<b -> (a == b*(a/b) <-> a mod b == 0).
Proof.
intros. rewrite (div_mod a b) at 1 by order.
rewrite <- (add_0_r (b*(a/b))) at 2.
apply add_cancel_l.
Qed.

(** Some additional inequalities about div. *)

Theorem div_lt_upper_bound:
  forall a b q, 0<=a -> 0<b -> a < b*q -> a/b < q.
Proof.
intros.
rewrite (mul_lt_mono_pos_l b) by order.
apply le_lt_trans with a; auto.
apply mul_div_le; auto.
Qed.

Theorem div_le_upper_bound:
  forall a b q, 0<=a -> 0<b -> a <= b*q -> a/b <= q.
Proof.
intros.
rewrite (mul_le_mono_pos_l _ _ b) by order.
apply le_trans with a; auto.
apply mul_div_le; auto.
Qed.

Theorem div_le_lower_bound:
  forall a b q, 0<=a -> 0<b -> b*q <= a -> q <= a/b.
Proof.
intros a b q Ha Hb H.
destruct (lt_ge_cases 0 q).
rewrite <- (div_mul q b); try order.
apply div_le_mono; auto.
rewrite mul_comm; split; auto.
apply lt_le_incl, mul_pos_pos; auto.
apply le_trans with 0; auto; apply div_pos; auto.
Qed.

(** A division respects opposite monotonicity for the divisor *)

Lemma div_le_compat_l: forall p q r, 0<=p -> 0<q<=r ->
    p/r <= p/q.
Proof.
 intros p q r Hp (Hq,Hqr).
 apply div_le_lower_bound; auto.
 rewrite (div_mod p r) at 2 by order.
 apply le_trans with (r*(p/r)).
 apply mul_le_mono_nonneg_r; try order.
 apply div_pos; order.
 rewrite <- (add_0_r (r*(p/r))) at 1.
 rewrite <- add_le_mono_l. destruct (mod_bound_pos p r); order.
Qed.

(** * Relations between usual operations and mod and div *)

Lemma mod_add : forall a b c, 0<=a -> 0<=a+b*c -> 0<c ->
 (a + b * c) mod c == a mod c.
Proof.
 intros.
 symmetry.
 apply mod_unique with (a/c+b); auto.
 apply mod_bound_pos; auto.
 rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order.
 now rewrite mul_comm.
Qed.

Lemma div_add : forall a b c, 0<=a -> 0<=a+b*c -> 0<c ->
 (a + b * c) / c == a / c + b.
Proof.
 intros.
 apply (mul_cancel_l _ _ c); try order.
 apply (add_cancel_r _ _ ((a+b*c) mod c)).
 rewrite <- div_mod, mod_add by order.
 rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order.
 now rewrite mul_comm.
Qed.

Lemma div_add_l: forall a b c, 0<=c -> 0<=a*b+c -> 0<b ->
 (a * b + c) / b == a + c / b.
Proof.
 intros a b c. rewrite (add_comm _ c), (add_comm a).
 intros. apply div_add; auto.
Qed.

(** Cancellations. *)

Lemma div_mul_cancel_r : forall a b c, 0<=a -> 0<b -> 0<c ->
 (a*c)/(b*c) == a/b.
Proof.
 intros.
 symmetry.
 apply div_unique with ((a mod b)*c).
 apply mul_nonneg_nonneg; order.
 split.
 apply mul_nonneg_nonneg; destruct (mod_bound_pos a b); order.
 rewrite <- mul_lt_mono_pos_r; auto. destruct (mod_bound_pos a b); auto.
 rewrite (div_mod a b) at 1 by order.
 rewrite mul_add_distr_r.
 rewrite add_cancel_r.
 rewrite <- 2 mul_assoc. now rewrite (mul_comm c).
Qed.

Lemma div_mul_cancel_l : forall a b c, 0<=a -> 0<b -> 0<c ->
 (c*a)/(c*b) == a/b.
Proof.
 intros. rewrite !(mul_comm c); apply div_mul_cancel_r; auto.
Qed.

Lemma mul_mod_distr_l: forall a b c, 0<=a -> 0<b -> 0<c ->
  (c*a) mod (c*b) == c * (a mod b).
Proof.
 intros.
 rewrite <- (add_cancel_l _ _ ((c*b)* ((c*a)/(c*b)))).
 rewrite <- div_mod.
 rewrite div_mul_cancel_l; auto.
 rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order.
 apply div_mod; order.
 rewrite <- neq_mul_0; intuition; order.
Qed.

Lemma mul_mod_distr_r: forall a b c, 0<=a -> 0<b -> 0<c ->
  (a*c) mod (b*c) == (a mod b) * c.
Proof.
 intros. rewrite !(mul_comm _ c); now rewrite mul_mod_distr_l.
Qed.

(** Operations modulo. *)

Theorem mod_mod: forall a n, 0<=a -> 0<n ->
 (a mod n) mod n == a mod n.
Proof.
 intros. destruct (mod_bound_pos a n); auto. now rewrite mod_small_iff.
Qed.

Lemma mul_mod_idemp_l : forall a b n, 0<=a -> 0<=b -> 0<n ->
 ((a mod n)*b) mod n == (a*b) mod n.
Proof.
 intros a b n Ha Hb Hn. symmetry.
 generalize (mul_nonneg_nonneg _ _ Ha Hb).
 rewrite (div_mod a n) at 1 2 by order.
 rewrite add_comm, (mul_comm n), (mul_comm _ b).
 rewrite mul_add_distr_l, mul_assoc.
 intros. rewrite mod_add; auto.
 now rewrite mul_comm.
 apply mul_nonneg_nonneg; destruct (mod_bound_pos a n); auto.
Qed.

Lemma mul_mod_idemp_r : forall a b n, 0<=a -> 0<=b -> 0<n ->
 (a*(b mod n)) mod n == (a*b) mod n.
Proof.
 intros. rewrite !(mul_comm a). apply mul_mod_idemp_l; auto.
Qed.

Theorem mul_mod: forall a b n, 0<=a -> 0<=b -> 0<n ->
 (a * b) mod n == ((a mod n) * (b mod n)) mod n.
Proof.
 intros. rewrite mul_mod_idemp_l, mul_mod_idemp_r; trivial. reflexivity.
 now destruct (mod_bound_pos b n).
Qed.

Lemma add_mod_idemp_l : forall a b n, 0<=a -> 0<=b -> 0<n ->
 ((a mod n)+b) mod n == (a+b) mod n.
Proof.
 intros a b n Ha Hb Hn. symmetry.
 generalize (add_nonneg_nonneg _ _ Ha Hb).
 rewrite (div_mod a n) at 1 2 by order.
 rewrite <- add_assoc, add_comm, mul_comm.
 intros. rewrite mod_add; trivial. reflexivity.
 apply add_nonneg_nonneg; auto. destruct (mod_bound_pos a n); auto.
Qed.

Lemma add_mod_idemp_r : forall a b n, 0<=a -> 0<=b -> 0<n ->
 (a+(b mod n)) mod n == (a+b) mod n.
Proof.
 intros. rewrite !(add_comm a). apply add_mod_idemp_l; auto.
Qed.

Theorem add_mod: forall a b n, 0<=a -> 0<=b -> 0<n ->
 (a+b) mod n == (a mod n + b mod n) mod n.
Proof.
 intros. rewrite add_mod_idemp_l, add_mod_idemp_r; trivial. reflexivity.
 now destruct (mod_bound_pos b n).
Qed.

Lemma div_div : forall a b c, 0<=a -> 0<b -> 0<c ->
 (a/b)/c == a/(b*c).
Proof.
 intros a b c Ha Hb Hc.
 apply div_unique with (b*((a/b) mod c) + a mod b); trivial.
 (* begin 0<= ... <b*c *)
 destruct (mod_bound_pos (a/b) c), (mod_bound_pos a b); auto using div_pos.
 split.
 apply add_nonneg_nonneg; auto.
 apply mul_nonneg_nonneg; order.
 apply lt_le_trans with (b*((a/b) mod c) + b).
 rewrite <- add_lt_mono_l; auto.
 rewrite <- mul_succ_r, <- mul_le_mono_pos_l, le_succ_l; auto.
 (* end 0<= ... < b*c *)
 rewrite (div_mod a b) at 1 by order.
 rewrite add_assoc, add_cancel_r.
 rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order.
 apply div_mod; order.
Qed.

Lemma mod_mul_r : forall a b c, 0<=a -> 0<b -> 0<c ->
 a mod (b*c) == a mod b + b*((a/b) mod c).
Proof.
 intros a b c Ha Hb Hc.
 apply add_cancel_l with (b*c*(a/(b*c))).
 rewrite <- div_mod by (apply neq_mul_0; split; order).
 rewrite <- div_div by trivial.
 rewrite add_assoc, add_shuffle0, <- mul_assoc, <- mul_add_distr_l.
 rewrite <- div_mod by order.
 apply div_mod; order.
Qed.

(** A last inequality: *)

Theorem div_mul_le:
 forall a b c, 0<=a -> 0<b -> 0<=c -> c*(a/b) <= (c*a)/b.
Proof.
 intros.
 apply div_le_lower_bound; auto.
 apply mul_nonneg_nonneg; auto.
 rewrite mul_assoc, (mul_comm b c), <- mul_assoc.
 apply mul_le_mono_nonneg_l; auto.
 apply mul_div_le; auto.
Qed.

(** mod is related to divisibility *)

Lemma mod_divides : forall a b, 0<=a -> 0<b ->
 (a mod b == 0 <-> exists c, a == b*c).
Proof.
 split.
 intros. exists (a/b). rewrite div_exact; auto.
 intros (c,Hc). rewrite Hc, mul_comm. apply mod_mul; auto.
 rewrite (mul_le_mono_pos_l _ _ b); auto. nzsimpl. order.
Qed.

End NZDivProp.


(** * Perm: Basic Techniques for Comparisons and Permutations *)

(** Consider these algorithms and data structures:
    - sort a sequence of numbers
    - finite maps from numbers to (arbitrary-type) data
    - finite maps from any ordered type to (arbitrary-type) data
    - priority queues: finding/deleting the highest number in a set

    To prove the correctness of such programs, we need to reason about
    comparisons, and about whether two collections have the same
    contents.  In this chapter, we introduce some techniques for
    reasoning about:

    - less-than comparisons on natural numbers, and
    - permutations (rearrangements of lists).

    In later chapters, we'll apply these proof techniques to reasoning
    about algorithms and data structures. *)

Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From Coq Require Import Strings.String.  (* for manual grading *)
From Coq Require Export Bool.Bool.
From Coq Require Export Arith.Arith.
From Coq Require Export Arith.EqNat.
From Coq Require Export Lia.
From Coq Require Export Lists.List.
Export ListNotations.
From Coq Require Export Permutation.

(* ################################################################# *)
(** * The Less-Than Order on the Natural Numbers *)

(** In our proofs about searching and sorting algorithms, we often
    have to reason about the less-than order on natural numbers.
    greater-than. Recall that the Coq standard library contains both
    propositional and Boolean less-than operators on natural numbers.
    We write [x < y] for the proposition that [x] is less than [y]: *)

Locate "_ < _". (* "x < y" := lt x y *)
Check lt : nat -> nat -> Prop.

(** And we write [x <? y] for the computation that returns [true] or
    [false] depending on whether [x] is less than [y]: *)

Locate "_ <? _". (* x <? y  := Nat.ltb x y *)
Check Nat.ltb : nat -> nat -> bool.

(** Operation [<] is a reflection of [<?], as discussed in
    [Logic] and [IndProp]. The [Nat] module has a
    theorem showing how they relate: *)

Check Nat.ltb_lt : forall n m : nat, (n <? m) = true <-> n < m.

(** The [Nat] module contains a synonym for [lt]. *)

Print Nat.lt. (* Nat.lt = lt *)

(** For unknown reasons, [Nat] does not define notations
    for [>?] or [>=?].  So we define them here: *)

Notation  "a >=? b" := (Nat.leb b a)
                          (at level 70) : nat_scope.
Notation  "a >? b"  := (Nat.ltb b a)
                         (at level 70) : nat_scope.

(* ================================================================= *)
(** ** The Lia Tactic *)

(** Reasoning about inequalities by hand can be a little painful. Luckily, Coq
    provides a tactic called [lia] that is quite helpful. *)

Theorem lia_example1:
 forall i j k,
    i < j ->
    ~ (k - 3 <= j) ->
   k > i.
Proof.
  intros.

(** The hard way to prove this is by hand. *)

  (* try to remember the name of the lemma about negation and [<=] *)
  Search (~ _ <= _ -> _).
  apply not_le in H0.
  (* try to remember the name of the transitivity lemma about [>] *)
  Search (_ > _ -> _ > _ -> _ > _).
  apply gt_trans with j.
  apply gt_trans with (k-3).
  (* Is [k] greater than [k-3]? On the integers, sure. But we're working
     with natural numbers, which truncate subtraction at zero. *)
Abort.

Theorem truncated_subtraction: ~ (forall k:nat, k > k - 3).
Proof.
  intros contra.
  (* [specialize] applies a hypothesis to an argument *)
  specialize (contra 0).
  simpl in contra.
  inversion contra.
Qed.

(** Since subtraction is truncated, does [lia_example1] actually hold?
    It does. Let's try again, the hard way, to find the proof. *)

Theorem lia_example1:
 forall i j k,
    i < j ->
    ~ (k - 3 <= j) ->
   k > i.
Proof. (* try again! *)
  intros.
  apply not_le in H0.
  unfold gt in H0.
  unfold gt.
  (* try to remember the name ... *)
  Search (_ < _ -> _ <= _ -> _ < _).
  apply lt_le_trans with j.
  apply H.
  apply le_trans with (k-3).
  Search (_ < _ -> _ <= _).
  apply lt_le_weak.
  auto.
  apply le_minus.
Qed.

(** That was tedious.  Here's a much easier way: *)

Theorem lia_example2:
 forall i j k,
    i < j ->
    ~ (k - 3 <= j) ->
   k > i.
Proof.
  intros.
  lia.
Qed.

(** Lia is a decision procedure for integer linear arithemetic.
    The [lia] tactic was made available by importing [Lia] at the
    beginning of the file.  The tactic
    works with Coq types [Z] and [nat], and these operators: [<] [=] [>]
    [<=] [>=] [+] [-] [~], as well as multiplication by small integer
    literals (such as 0,1,2,3...), and some uses of [\/], [/\], and [<->].

    Lia does not "understand" other operators.  It treats
    expressions such as [f x y] as variables.  That is, it
    can prove [f x y > a * b -> f x y + 3 >= a * b], in the same way it
    would prove [u > v -> u + 3 >= v].
*)

Theorem lia_example_3 : forall (f : nat -> nat -> nat) a b x y,
    f x y > a * b -> f x y + 3 >= a * b.
Proof.
  intros. lia.
Qed.

(* ################################################################# *)
(** * Swapping *)

(** Consider trying to sort a list of natural numbers.  As a small piece of
    a sorting algorithm, we might need to swap the first two elements of a list
    if they are out of order. *)

Definition maybe_swap (al: list nat) : list nat :=
  match al with
  | a :: b :: ar => if a >? b then b :: a :: ar else a :: b :: ar
  | _ => al
  end.

Example maybe_swap_123:
  maybe_swap [1; 2; 3] = [1; 2; 3].
Proof. reflexivity. Qed.

Example maybe_swap_321:
  maybe_swap [3; 2; 1] = [2; 3; 1].
Proof. reflexivity. Qed.

(** Applying [maybe_swap] twice should give the same result as applying it once.
    That is, [maybe_swap] is _idempotent_. *)

Theorem maybe_swap_idempotent: forall al,
    maybe_swap (maybe_swap al) = maybe_swap al.
Proof.
  intros [ | a [ | b al]]; simpl; try reflexivity.
  destruct (b <? a) eqn:Hb_lt_a; simpl.
  - destruct (a <? b) eqn:Ha_lt_b; simpl.
    + (** Now what?  We have a contradiction in the hypotheses: it
          cannot hold that [a] is less than [b] and [b] is less than
          [a].  Unfortunately, [lia] cannot immediately show that
          for us, because it reasons about comparisons in [Prop] not
          [bool]. *)
      Fail lia.
Abort.

(** Of course we could finish the proof by reasoning directly about
    inequalities in [bool].  But this situation is going to occur
    repeatedly in our study of sorting. *)

(** Let's set up some machinery to enable using [lia] on boolean
    tests. *)

(* ================================================================= *)
(** ** Reflection *)

(** The [reflect] type, defined in the standard library (and presented
    in [IndProp]), relates a proposition to a Boolean. That is,
    a value of type [reflect P b] contains a proof of [P] if [b] is
    [true], or a proof of [~ P] if [b] is [false]. *)

Print reflect.

(*
Inductive reflect (P : Prop) : bool -> Set :=
  | ReflectT :   P -> reflect P true
  | ReflectF : ~ P -> reflect P false
 *)

(** The standard library proves a theorem that says if [P] is provable
    whenever [b = true] is provable, then [P] reflects [b]. *)

Check iff_reflect : forall (P : Prop) (b : bool),
    P <-> b = true -> reflect P b.

(** Using that theorem, we can quickly prove that the propositional
    (in)equality operators are reflections of the Boolean
    operators. *)

Lemma eqb_reflect : forall x y, reflect (x = y) (x =? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.eqb_eq.
Qed.

Lemma ltb_reflect : forall x y, reflect (x < y) (x <? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.ltb_lt.
Qed.

Lemma leb_reflect : forall x y, reflect (x <= y) (x <=? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.leb_le.
Qed.

(** Here's an example of how you could use these lemmas.  Suppose you
    have this simple program, [(if a <? 5 then a else 2)], and you
    want to prove that it evaluates to a number smaller than 6.  You
    can use [ltb_reflect] "by hand": *)

Example reflect_example1: forall a,
    (if a <? 5 then a else 2) < 6.
Proof.
  intros a.
  (* The next two lines aren't strictly necessary, but they
     help make it clear what [destruct] does. *)
  assert (R: reflect (a < 5) (a <? 5)) by apply ltb_reflect.
  remember (a <? 5) as guard.
  destruct R as [H|H] eqn:HR.
  * (* ReflectT *) lia.
  * (* ReflectF *) lia.
Qed.

(** For the [ReflectT] constructor, the guard [a <? 5] must be equal
    to [true]. The [if] expression in the goal has already been
    simplified to take advantage of that fact. Also, for [ReflectT] to
    have been used, there must be evidence [H] that [a < 5] holds.
    From there, all that remains is to show [a < 5] entails [a < 6].
    The [lia] tactic, which is capable of automatically proving some
    theorems about inequalities, succeeds.

    For the [ReflectF] constructor, the guard [a <? 5] must be equal
    to [false]. So the [if] expression simplifies to [2 < 6], which is
    immediately provable by [lia]. *)

(** A less didactic version of the above proof wouldn't do the
    [assert] and [remember]: we can directly skip to [destruct]. *)

Example reflect_example1': forall a,
    (if a <? 5 then a else 2) < 6.
Proof.
  intros a. destruct (ltb_reflect a 5); lia.
Qed.

(** But even that proof is a little unsatisfactory. The original expression,
    [a <? 5], is not perfectly apparent from the expression [ltb_reflect a 5]
    that we pass to [destruct]. *)

(** It would be nice to be able to just say something like [destruct
    (a <? 5)] and get the reflection "for free."  That's what we'll
    engineer, next. *)

(* ================================================================= *)
(** ** A Tactic for Boolean Destruction *)

(** We're now going to build a tactic that you'll want to _use_, but
    you won't need to understand the details of how to _build_ it
    yourself.

    Let's put several of these [reflect] lemmas into a Hint database.
    We call it [bdestruct], because we'll use it in our
    boolean-destruction tactic: *)

Hint Resolve ltb_reflect leb_reflect eqb_reflect : bdestruct.

(** Here is the tactic, the body of which you do not need to
    understand.  Invoking [bdestruct] on Boolean expression [b] does
    the same kind of reasoning we did above: reflection and
    destruction.  It also attempts to simplify negations involving
    inequalities in hypotheses. *)

Ltac bdestruct X :=
  let H := fresh in let e := fresh "e" in
   evar (e: Prop);
   assert (H: reflect e X); subst e;
    [eauto with bdestruct
    | destruct H as [H|H];
       [ | try first [apply not_lt in H | apply not_le in H]]].

(** This tactic makes quick, easy-to-read work of our running example. *)

Example reflect_example2: forall a,
    (if a <? 5 then a else 2) < 6.
Proof.
  intros.
  bdestruct (a <? 5);  (* instead of: [destruct (ltb_reflect a 5)]. *)
  lia.
Qed.

(* ================================================================= *)
(** ** Finishing the [maybe_swap] Proof *)

(** Now that we have [bdestruct], we can finish the proof of [maybe_swap]'s
    idempotence. *)

Theorem maybe_swap_idempotent: forall al,
    maybe_swap (maybe_swap al) = maybe_swap al.
Proof.
  intros [ | a [ | b al]]; simpl; try reflexivity.
  bdestruct (a >? b); simpl.
  (** Note how [b < a] is a hypothesis, rather than [b <? a = true]. *)
  - bdestruct (b >? a); simpl.
    + (** [lia] can take care of the contradictory propositional inequalities. *)
      lia.
    + reflexivity.
  - bdestruct (a >? b); simpl.
    + lia.
    + reflexivity.
Qed.

(** When proving theorems about a program that uses Boolean
    comparisons, use [bdestruct] followed by [lia], rather than
    [destruct] followed by application of various theorems about
    Boolean operators. *)

(* ################################################################# *)
(** * Permutations *)

(** Another useful fact about [maybe_swap] is that it doesn't add or
    remove elements from the list: it only reorders them.  That is,
    the output list is a permutation of the input.  List [al] is a
    _permutation_ of list [bl] if the elements of [al] can be
    reordered to get the list [bl].  Note that reordering does not
    permit adding or removing duplicate elements. *)

(** Coq's [Permutation] library has an inductive definition of
    permutations. *)

Print Permutation.

(*
 Inductive Permutation {A : Type} : list A -> list A -> Prop :=
  | perm_nil : Permutation [] []
  | perm_skip : forall (x : A) (l l' : list A),
                Permutation l l' ->
                Permutation (x :: l) (x :: l')
  | perm_swap : forall (x y : A) (l : list A),
                Permutation (y :: x :: l) (x :: y :: l)
  | perm_trans : forall l l' l'' : list A,
                 Permutation l l' ->
                 Permutation l' l'' ->
                 Permutation l l''.
 *)

(** You might wonder, "is that really the right definition?"  And
    indeed, it's important that we get a right definition, because
    [Permutation] is going to be used in our specifications of
    searching and sorting algorithms.  If we have the wrong
    specification, then all our proofs of "correctness" will be
    useless.

    It's not obvious that this is indeed the right specification of
    permutations. (It happens to be, but that's not obvious.) To gain
    confidence that we have the right specification, let's use it
    prove some properties that permutations ought to have. *)

(** **** Exercise: 2 stars, standard (Permutation_properties)

    Think of some desirable properties of the [Permutation] relation
    and write them down informally in English, or a mix of Coq and
    English.  Here are four to get you started:

     - 1. If [Permutation al bl], then [length al = length bl].
     - 2. If [Permutation al bl], then [Permutation bl al].
     - 3. [[1;1]] is NOT a permutation of [[1;2]].
     - 4. [[1;2;3;4]] IS a permutation of [[3;4;2;1]].

   YOUR TASK: Add three more properties. Write them here: *)

(** Now, let's examine all the theorems in the Coq library about
    permutations: *)

Search Permutation.  (* Browse through the results of this query! *)

(** Which of the properties that you wrote down above have already
    been proved as theorems by the Coq library developers?  Answer
    here:

*)
(* Do not modify the following line: *)
Definition manual_grade_for_Permutation_properties : option (nat*string) := None.
(** [] *)

(** Let's use the permutation theorems in the library to prove the
    following theorem. *)

Example butterfly: forall b u t e r f l y : nat,
  Permutation ([b;u;t;t;e;r]++[f;l;y]) ([f;l;u;t;t;e;r]++[b;y]).
Proof.
  intros.
  (** Let's group [[u;t;t;e;r]] together on both sides.  Tactic
      [change t with u] replaces [t] with [u].  Terms [t] and [u] must
      be _convertible_, here meaning that they evalute to the same
      term. *)
  change [b;u;t;t;e;r] with ([b]++[u;t;t;e;r]).
  change [f;l;u;t;t;e;r] with ([f;l]++[u;t;t;e;r]).

  (** We don't actually need to know the list elements in
      [[u;t;t;e;r]].  Let's forget about them and just remember them
      as a variable named [utter]. *)
  remember [u;t;t;e;r] as utter. clear Hequtter.

  (** Likewise, let's group [[f;l]] and remember it as a variable. *)
  change [f;l;y] with ([f;l]++[y]).
  remember [f;l] as fl. clear Heqfl.

  (** Next, let's cancel [fl] from both sides.  In order to do that,
      we need to bring it to the beginning of each list. For the right
      list, that follows easily from the associativity of [++].  *)
  replace ((fl ++ utter) ++ [b;y]) with (fl ++ utter ++ [b;y])
    by apply app_assoc.

  (** But for the left list, we can't just use associativity.
      Instead, we need to reason about permutations and use some
      library theorems. *)
  apply perm_trans with (fl ++ [y] ++ ([b] ++ utter)).
  - replace (fl ++ [y] ++ [b] ++ utter) with ((fl ++ [y]) ++ [b] ++ utter).
    + apply Permutation_app_comm.
    + rewrite <- app_assoc. reflexivity.

  - (** A library theorem will now help us cancel [fl]. *)
    apply Permutation_app_head.

  (** Next let's cancel [utter]. *)
    apply perm_trans with (utter ++ [y] ++ [b]).
    + replace ([y] ++ [b] ++ utter) with (([y] ++ [b]) ++ utter).
      * apply Permutation_app_comm.
      * rewrite app_assoc. reflexivity.
    + apply Permutation_app_head.

      (** Finally we're left with just [y] and [b]. *)
      apply perm_swap.
Qed.

(** That example illustrates a general method for proving permutations
    involving cons [::] and append [++]:

    - Identify some portion appearing in both sides.
    - Bring that portion to the front on each side using lemmas such
      as [Permutation_app_comm] and [perm_swap], with generous use of
      [perm_trans].
    - Use [Permutation_app_head] to cancel an appended head.  You can
      also use [perm_skip] to cancel a single element. *)

(** **** Exercise: 3 stars, standard (permut_example)

    Use the permutation rules in the library to prove the following
    theorem.  The following [Check] commands are a hint about useful
    lemmas.  You don't need all of them, and depending on your
    approach you will find lemmas to be more useful than others. Use
    [Search Permutation] to find others, if you like. *)

Check perm_skip.
Check perm_trans.
Check Permutation_refl.
Check Permutation_app_comm.
Check app_assoc.
Check app_nil_r.
Check app_comm_cons.

Example permut_example: forall (a b: list nat),
  Permutation (5 :: 6 :: a ++ b) ((5 :: b) ++ (6 :: a ++ [])).
Proof.
  intros.
  change (5 :: 6 :: a ++ b) with (5 :: (6 :: a) ++ b).
  change ((5 :: b) ++ 6 :: a ++ []) with (5 :: (b ++ (6 :: a) ++ [])).
  remember (6 :: a) as a'. clear Heqa'.
  rewrite app_nil_r.
  apply perm_skip.
  apply Permutation_app_comm.
Qed.

(** [] *)

(** **** Exercise: 2 stars, standard (not_a_permutation)

    Prove that [[1;1]] is not a permutation of [[1;2]].
    Hints are given as [Check] commands. *)

Check Permutation_cons_inv.
Check Permutation_length_1_inv.

Example not_a_permutation:
  ~ Permutation [1;1] [1;2].
Proof.
  unfold not. intros.
  apply Permutation_cons_inv in H.
  apply Permutation_length_1_inv in H.
  discriminate H.
Qed.
(** [] *)

(* ================================================================= *)
(** ** Correctness of [maybe_swap] *)

(** Now we can prove that [maybe_swap] is a permutation: it reorders
    elements but does not add or remove any. *)

Theorem maybe_swap_perm: forall al,
  Permutation al (maybe_swap al).
Proof.
  (* WORKED IN CLASS *)
  unfold maybe_swap.
  destruct al as [ | a [ | b al]].
  - simpl. apply perm_nil.
  - apply Permutation_refl.
  - bdestruct (b <? a).
    + apply perm_swap.
    + apply Permutation_refl.
Qed.

(** And, we can prove that [maybe_swap] permutes elements such that
    the first is less than or equal to the second. *)

Definition first_le_second (al: list nat) : Prop :=
  match al with
  | a :: b :: _ => a <= b
  | _ => True
  end.

Theorem maybe_swap_correct: forall al,
    Permutation al (maybe_swap al)
    /\ first_le_second (maybe_swap al).
Proof.
  intros. split.
  - apply maybe_swap_perm.
  - (* WORKED IN CLASS *)
    unfold maybe_swap.
    destruct al as [ | a [ | b al]]; simpl; auto.
    bdestruct (a >? b); simpl; lia.
Qed.

(* ################################################################# *)
(** * Summary: Comparisons and Permutations *)

(** To prove correctness of algorithms for sorting and searching,
    we'll reason about comparisons and permutations using the tools
    developed in this chapter.  The [maybe_swap] program is a tiny
    little example of a sorting program.  The proof style in
    [maybe_swap_correct] will be applied (at a larger scale) in
    the next few chapters. *)

(** **** Exercise: 3 stars, standard (Forall_perm)

    To close, we define a utility tactic and lemma.  First, the
    tactic. *)

(** Coq's [inversion H] tactic is so good at extracting
    information from the hypothesis [H] that [H] sometimes becomes
    completely redundant, and one might as well [clear] it from the
    goal.  Then, since the [inversion] typically creates some equality
    facts, why not then [subst] ?  Tactic [inv] does just that. *)

Ltac inv H := inversion H; clear H; subst.

(** Second, the lemma.  You will find [inv] useful in proving it.

    [Forall] is Coq library's version of the [All] proposition defined
    in [Logic], but defined as an inductive proposition rather
    than a fixpoint.  Prove this lemma by induction.  You will need to
    decide what to induct on: [al], [bl], [Permutation al bl], and
    [Forall f al] are possibilities. *)

Theorem Forall_perm: forall {A} (f: A -> Prop) al bl,
  Permutation al bl ->
  Forall f al -> Forall f bl.
Proof.
  intros A f al  bl H__permutation H__forall.
  induction H__permutation.
  - (* nil *) constructor.
  - (* x :: l *)
    inv H__forall.
    auto.
  - (* x :: y :: l *)
    inv H__forall. inv H2.
    auto.
  - (* l -> l' -> l'' *)
    auto.
Qed.

(** [] *)

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


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf2 : natural) (lf1 : natural) : natural := plus lf1 Zero.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf2 : natural) (lf1 : natural) : natural := plus Zero lf1.


Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_s_sumsupp :
	forall A B C D E F X Y Z U V,
	Supp X Y U V Z ->
	CongA A B C X Y U ->
	CongA D E F V Y Z ->
	SumSupp A B C D E F.
Proof.
	intros A B C D E F X Y Z U V.
	intros Supp_XYU_VYZ.
	intros CongA_ABC_XYU.
	intros CongA_DEF_VYZ.
	unfold SumSupp.
	exists X, Y, Z, U, V.
	split.
	exact Supp_XYU_VYZ.
	split.
	exact CongA_ABC_XYU.
	exact CongA_DEF_VYZ.
Qed.

End Euclid.


Require Import HoTT.

Require Import quotient.
Require Import syntax.
Require Import nat_struct.
Require Import cmono_group.
Require Import hit.minus1Trunc.
Require Import hit.unique_choice.

Import Distributive.

Lemma prod_eq_dec : forall A (Ha : DecidablePaths A) B (Hb : DecidablePaths B),
DecidablePaths (A*B).
Proof.
intros.
intros [a b] [c d].
destruct (Ha a c) as [? | H]. destruct (Hb b d) as [? | H].
left. apply ap11;[apply ap|];assumption.
right;intro Hn. apply H;apply (ap snd Hn).
right;intro Hn. apply H;apply (ap fst Hn).
Defined.

Module Relative.
Import GroupOfCMono.

Definition Z := @quotU nat (+).
Instance ZPrering : PreringFull Z.
Proof.
split.
apply (@quotOp nat plus _).
apply (LL_L2 _ (quotPrering nat_LLRRR)).
apply (@quotRel nat (nat_LLRRR:(PlusApart nat))).
apply (@quotRel nat (nat_LLRRR:(PlusLeq nat))).
apply (@quotRel nat (nat_LLRRR:(PlusLt nat))).
Defined.

Instance ZRing : IsRing ZPrering.
Proof.
unfold ZPrering.
change (IsRing (quotPrering nat_LLRRR)).
apply _.
Defined.

Definition z0 := (@ZeroV Z ZPrering ZRing).
Definition z1 := (@OneV Z ZPrering ZRing).

Instance zLeq_prop : @RelationProp Z (<=).
Proof.
red;apply _.
Defined.

Instance zLeq_dec : @Decidable Z (<=).
Proof.
unfold ZPrering. unfold leq. simpl.
apply (@quotrel_dec _ (nat_LLRRR:(PlusLeq nat)));try apply _;simpl.
exact nle_prop.
apply nplus_nle_invariant.
apply nplus_nle_regular.
apply nle_dec.
Defined.

Instance zLeq_total_order : @ConstrTotalOrder Z (<=).
Proof.
split.
apply (@quotrel_poset _ (nat_LLRRR:PlusLeq nat));try apply _.
exact nle_prop. apply nplus_nle_invariant.
apply nplus_nle_regular.
apply nle_total_order.
apply dec_linear_constrlinear. apply _.
apply (@quotrel_linear _ (nat_LLRRR:PlusLeq nat)).
apply constrlinear_linear. apply nle_total_order.
Defined.

Definition zIn : nat*nat -> Z := quotIn (+).

Definition zEquiv : Rel (nat*nat) := equivU (+).

Instance ZRing_set : IsHSet Z := _.

Instance zEquiv_prop : RelationProp zEquiv.
Proof.
red;apply _.
Defined.

Definition z_rect : forall (P : Z -> Type)
(dclass : forall m n, P (zIn (m, n))),
(forall a b a' b' (Hequiv : zEquiv (a,b) (a',b')),
 transport _ (@related_classes_eq _ zEquiv _ _ Hequiv) (dclass a b)
   = (dclass a' b')) ->
forall z, P z.
Proof.
intros P dclass H.
apply quotU_rect with (fun p => match p as p' return (P (quotIn (+) p'))
 with | (a,b) => dclass a b end).
intros.
destruct x, y.
apply H.
Defined.

Definition z_rect' : forall (P : Z -> Type)
(dclass : forall x, P (zIn x)),
(forall a b (Hequiv : zEquiv a b),
 transport _ (@related_classes_eq _ zEquiv _ _ Hequiv) (dclass a)
   = (dclass b)) ->
forall z, P z.
Proof.
apply quotU_rect.
Defined.

Definition z_ind : forall (P : Z -> Type),
(forall a b, IsHProp (P (zIn (a, b)))) ->
(forall a b, P (zIn (a, b))) ->
forall z, P z.
Proof.
intros P Hp Hd. apply quotU_ind.
apply quotU_ind. intros;apply _.
intros [a b]. apply Hp.
simpl. intros [a b];apply Hd.
Defined.

Definition z_ind' : forall P : Z -> Type,
(forall x, IsHProp (P (zIn x))) ->
(forall x, P (zIn x)) ->
forall z, P z.
Proof.
intros P Hp Hd. apply quotU_ind.
apply quotU_ind. intros;apply _.
apply _.
apply Hd.
Defined.

Definition z_ind_contr : forall (P : Z -> Type),
(forall a b, Contr (P (zIn (a, b)))) ->
forall z, Contr (P z).
Proof.
intros P Hd. apply quotU_rect with
 (fun p => match p as p' return (Contr (P (quotIn (+) p'))) with
   | (a,b) => Hd a b end).
intros.
apply hprop_contr.
Defined.

Lemma z_rect_compute : forall (P : Z -> Type)
(dclass : forall m n, P (zIn (m, n))) H a b,
 z_rect P dclass H (zIn (a, b)) = dclass a b.
Proof.
intros. reflexivity.
Defined.

Section NotaSec.
Notation "[ a , b ]" := (zIn (a, b)).

Definition z0_class : [0, 0] = z0 := idpath.
Definition z1_class : [S 0, 0] = z1 := idpath.

Lemma zEquiv_eval : forall a b c d, zEquiv (a,b) (c,d) = (a+d = c+b).
Proof.
intros;reflexivity.
Defined.

Definition zplus_eval : forall a b c d,
[a,b] + [c,d] = [a+c, b+d].
Proof.
intros. reflexivity.
Defined.

Definition zmult_eval : forall a b c d,
[a,b] ° [c,d] = [a°c + b°d, a°d + c°b].
Proof.
intros;reflexivity.
Defined.

Definition zOpp : forall x : Z, Inverse (+) x := ropp.
Definition zOppV : Z -> Z := fun x => inverse_val (zOpp x).
Global Instance zOppP : forall x : Z, IsInverse (+) x (zOppV x) := _.

Lemma zOpp_eval : forall a b, zOppV [a, b] = [b, a].
Proof.
intros;reflexivity.
Defined.

Lemma z_related_classes_eq : forall a b c d, zEquiv (a,b) (c,d) ->
[a, b] = [c, d].
Proof.
intros ? ? ? ?. apply related_classes_eq.
Defined.

Lemma z_classes_eq_related : forall a b, zIn a = zIn b ->
zEquiv a b.
Proof.
apply classes_eq_related.
Defined.

(*
Definition zCanon (z : Z) (x : nat*nat) :=
 (z = zIn x) * minus1Trunc (fst x = 0 \/ snd x = 0).

Definition is_zCanon : forall x, (fst x = 0 \/ snd x = 0) ->
 zCanon (zIn x) x := fun x H => (idpath , min1 H).

Definition zCanon_or : forall z x, zCanon z x -> (fst x = 0 \/ snd x = 0).
Proof.
intros ? ? H.
destruct (eq_nat_dec (fst x) 0) as [? | H']. left. assumption.
right.
eapply minus1Trunc_rect_nondep;[| |apply H].
intros H0. destruct H0. destruct H';assumption. assumption.
apply nat_set.
Defined.

Global Instance zCanon_prop : forall z x, IsHProp (zCanon z x).
Proof.
intros. apply @trunc_prod. apply hprop_allpath;apply quotient_is_set.
apply minus1Trunc_is_prop.
Defined.

Lemma zCanon_atmost : forall z, atmost1P (zCanon z).
Proof.
intros. red. intros [xa xb] [ya yb] Hx Hy.
assert (Heq : quotIn (+) (xa, xb) = quotIn (+) (ya, yb)). path_via z.
symmetry;apply Hx. apply Hy.
apply zCanon_or in Hx;apply zCanon_or in Hy.
simpl in Hx,Hy.
clear z.
apply z_classes_eq_related in Heq. red in Heq;red in Heq;simpl in Heq.
destruct Hx as [Hx | Hx];destruct Hy as [Hy | Hy];
apply inverse in Hx;apply inverse in Hy;destruct Hx,Hy.
apply ap. symmetry. assumption.
symmetry in Heq.
apply nplus_0_0_back in Heq;destruct Heq as [[] []];reflexivity.
apply nplus_0_0_back in Heq;destruct Heq as [[] []];reflexivity.
apply (ap (fun g => (g, 0))).
path_via (xa + 0). apply inverse. apply nplus_0_r.
path_via (ya + 0). apply nplus_0_r.
Defined.

Global Instance zCanonT_prop : forall z, IsHProp (sigT (zCanon z)).
Proof.
intros. apply hprop_inhabited_contr.
intro X. exists X. intro Y.
destruct X as [x Hx];destruct Y as [y Hy].
apply path_sigma with (zCanon_atmost _ _ _ Hx Hy).
apply zCanon_prop.
Defined.

Definition canonT : forall z, sigT (zCanon z).
Proof.
apply z_ind. apply _.
intros.
destruct (nle_linear a b) as [H | H];apply nle_exists in H;destruct H as [k []].
exists (0, k). split.
apply z_related_classes_eq. red;red. simpl.
path_via (k + a). apply commutative;apply nat_issemiring.
apply min1. left;reflexivity.
exists (k,0). split.
apply z_related_classes_eq;red;red;simpl. apply nplus_0_r.
apply min1;right;reflexivity.
Defined.

(*
!!Does not compute!!
Because canonT uses the axiom z_related_classes_eq
*)
Definition z_canon_rect : forall P : Z -> Type,
(forall a, P [a, 0]) ->
(forall b, P [0, b]) ->
forall z, P z.
Proof.
intros ? H H' ?.
destruct (canonT z) as [x Hc].
eapply transport. symmetry;apply (fst Hc).
apply zCanon_or in Hc. destruct x as [a b];simpl in Hc;destruct Hc as [He | He];
apply inverse in He;destruct He;eauto.
Defined.

Lemma Z_repr : forall x : Z, exists p, zIn p = x.
Proof.
apply z_canon_rect;intros;econstructor;reflexivity.
Defined.

*)

Definition eq_z_dec : DecidablePaths Z.
Proof.
red.
assert (forall x y : Z, IsHProp ((x=y) \/ ~ x=y)).
intros. apply hprop_sum. intros;auto.
apply (z_ind' (fun x => forall y, _) _).
intro x. apply z_ind'. apply _.
intro y.

destruct (eq_nat_dec (fst x + snd y) (fst y + snd x)) as [H|H].
left. apply related_classes_eq. assumption.
right;intro H'. apply H.
apply classes_eq_related in H'. assumption.
Defined.

Lemma zLeq_repr : forall x y, zIn x <= zIn y -> quotRelU (+ <=) x y.
Proof.
apply quotRel_repr;try apply _.
exact nle_prop.
apply nplus_nle_invariant.
apply nplus_nle_regular.
Defined.

Lemma repr_zLeq : forall x y, quotRelU (+ <=) x y -> zIn x <= zIn y.
Proof.
apply repr_quotRel.
Defined.

Lemma zApart_repr : forall x y, zIn x # zIn y ->
 quotRelU (+ #) x y.
Proof.
apply quotRel_repr;try apply _.
red;red. unfold rrel;unfold gop;simpl.
intros ? ? ? H H'.
apply H. apply nplus_cancel with z. assumption.
red;red. unfold rrel;unfold gop;simpl.
intros z x y H H'. apply H. destruct H'. reflexivity.
Defined.

Global Instance zApart_prop : @RelationProp Z (#).
Proof.
red;apply _.
Defined.

Global Instance zApart_trivial : @TrivialApart Z (#).
Proof.
red.
assert (forall x y : Z, x#y -> x!=y).
apply (z_ind (fun x => forall y, _ -> _) _).
intros a b. apply (z_ind (fun y => _->_) _).
intros c d.
intros H.
red in H;simpl in H. apply zApart_repr in H.
simpl in H. unfold gop in H.
intro H'.
apply z_classes_eq_related in H'. red in H';red in H';simpl in H'.
auto.

assert (forall x y : Z, x!=y -> x#y).
apply (z_ind (fun x => forall y, _ -> _) _).
intros a b;apply (z_ind (fun y => _ -> _) _).
intros c d.
intros H.
apply repr_quotRel. simpl.
unfold gop;simpl;intro H'.
apply H. apply related_classes_eq. assumption.

intros;split;auto.
Defined.

Global Instance zApart_apart : @Apartness Z apart.
Proof.
apply neq_apart. apply eq_z_dec.
apply zApart_trivial.
Defined.

Lemma zLt_repr : forall x y, (zIn x) < (zIn y) ->
 quotRelU (+ <) x y.
Proof.
apply quotRel_repr;try apply _.
intros x y. apply nle_prop.
red;red. unfold rrel. simpl. unfold gop. change lt with (fun x => leq (S x)).
simpl.
intros z x y H. pattern (S (@plus nat nplus z x)).
apply transport with (z + (S x)). apply nplus_S_r.
apply nplus_nle_invariant;assumption.
red;red. unfold gop;unfold rrel. simpl.
intros z x y H. apply (nplus_nle_regular z). unfold gop;unfold rrel.
simpl. pattern (@plus _ nplus z (S x)). eapply transport;[|apply H].
symmetry. apply nplus_S_r.
Defined.

Lemma repr_zLt : forall x y, quotRelU (+ <) x y -> (zIn x) < (zIn y).
Proof.
apply repr_quotRel.
Defined.

Global Instance zApart_dec : @Decidable Z (#).
Proof.
intros x y.
destruct (eq_z_dec x y).
right. intro H'.
apply zApart_trivial in H'. auto.
left. apply zApart_trivial. assumption.
Defined.

Lemma zLt_iff_not_zLeq : forall x y : Z, x < y <-> ~ y <= x.
Proof.
split;revert y;revert x;
apply (z_ind' (fun x => forall y, _ -> _) _);
intro x;apply (z_ind' (fun y => _ -> _) _);
intro y;
intros H.

- intros H'.
  apply zLt_repr in H;apply zLeq_repr in H'.
  simpl in H,H'.
  eapply nlt_not_nle;[apply H|apply H'].

- apply repr_zLt. apply not_nle_nlt. intro H'.
  apply H;apply repr_zLeq. assumption.
Defined.

Lemma zLeq_by_not : forall {x y : Z}, ~ y <= x -> x <= y.
Proof.
intros. destruct (isconstrlinear x y). assumption. destruct X;assumption.
Defined.

Instance zLt_trans : Transitive (<).
Proof.
apply (@quotrel_trans nat (+ <));try apply _.
intros x y. apply nle_prop.
red;red. unfold rrel. simpl. unfold gop. change lt with (fun x => leq (S x)).
simpl.
intros z x y H. pattern (S (@plus nat nplus z x)).
apply transport with (z + (S x)). apply nplus_S_r.
apply nplus_nle_invariant;assumption.
red;red. unfold gop;unfold rrel. simpl.
intros z x y H. apply (nplus_nle_regular z). unfold gop;unfold rrel.
simpl. pattern (@plus _ nplus z (S x)). eapply transport;[|apply H].
symmetry. apply nplus_S_r.

unfold rrel. simpl.
assert (@RelationProp nat lt). intros x y. apply nle_prop.
apply (@fullpseudo_is_fullposet _ _ _ nat_fullpseudo).
Defined.

Instance zLt_irrefl : Irreflexive (<).
Proof.
red. apply (z_ind (fun x => _ -> _) _).
intros a b. intros. apply zLt_repr in H.
apply nlt_not_nle in H. apply H. apply nle_n.
Defined.

Global Instance zLt_trichotomic : @Trichotomic Z (<).
Proof.
apply quotrel_trichotomic;try apply _.

intros x y. apply nle_prop.
red;red. unfold rrel. simpl. unfold gop. change lt with (fun x => leq (S x)).
simpl.
intros z x y H. pattern (S (@plus nat nplus z x)).
apply transport with (z + (S x)). apply nplus_S_r.
apply nplus_nle_invariant;assumption.
red;red. unfold gop;unfold rrel. simpl.
intros z x y H. apply (nplus_nle_regular z). unfold gop;unfold rrel.
simpl. pattern (@plus _ nplus z (S x)). eapply transport;[|apply H].
symmetry. apply nplus_S_r.

apply (@pseudo_is_strict nat nat_LLRRR). intros x y;apply nle_prop.
apply nat_fullpseudo.
Defined.

Global Instance z_fullpseudoorder : FullPseudoOrder ZPrering.
Proof.
split. split.
apply _.
intros. apply zLt_irrefl with x.
apply zLt_trans with y;assumption.

red. unfold rrel.
intros ? ? H ?.
apply min1. destruct (zLt_trichotomic x z) as [?|[p|H']].
left;assumption. right; destruct p;assumption.
right;eapply zLt_trans. apply H'. apply H.

split;intro H.
destruct (zLt_trichotomic x y) as [H'|H'].
left;assumption.
right. destruct H'. destruct p. apply zApart_apart in H. destruct H.
assumption.
apply zApart_trivial. intro H';destruct H';destruct H as [H|H];
eapply zLt_irrefl;apply H.

split;revert y;revert x.
apply (z_ind' (fun x => forall y, _ -> _) _).
intro x. apply (z_ind' (fun y => _ -> _) _).
intro y.
intros H H';apply zLeq_repr in H;apply zLt_repr in H'.
eapply nle_not_nlt;[apply H|apply H'].

apply (z_ind' (fun x => forall y, _ -> _) _).
intro x. apply (z_ind' (fun y => _ -> _) _).
intro y.
intros H. apply repr_zLeq. apply not_nlt_nle. intro H'.
apply H. apply repr_zLt. assumption.
Defined.

Definition zNat : nat -> Z := fun n => zIn (n, 0).

Definition zNat_quotEmbed : zNat = quotEmbed _ := idpath.

Global Instance zNat_leq_embedding : IsEmbedding (<=) (<=) zNat.
Proof.
split.
red. unfold rrel.
intros;apply repr_quotRel. simpl. change (@gidV nat _ _) with (@ZeroV nat _ _).
unfold gop.
pattern (@plus _ nplus x 0). apply transport with x.
apply inverse. apply nplus_0_r.
apply transport with y.
apply inverse. apply nplus_0_r.
assumption.

red. unfold rrel.
intros. apply zLeq_repr in H.
red in H. simpl in H. unfold gop,rrel in H.
pattern x;apply transport with (x+0).
apply nplus_0_r.
apply transport with (y+0).
apply nplus_0_r.
assumption.
Defined.

(*Nb: means zNat is injective*)
Global Instance zNat_eq_embedding : IsEmbedding (paths) (paths) zNat.
Proof.
split.
red. unfold rrel.
apply ap.

red. unfold rrel.
intros. apply classes_eq_related in H.
red in H. simpl in H.
path_via (x+0). apply inverse;apply nplus_0_r.
path_via (y+0). apply nplus_0_r.
Defined.

Global Instance zNat_neq_embedding : IsEmbedding (#) (#) zNat.
Proof.
split;red;unfold rrel.
intros. apply zApart_trivial. intro H.
apply X. apply zNat_eq_embedding. assumption.

intros;intro H.
apply zApart_repr in X. apply X.
simpl. path_via x.
apply nplus_0_r.
path_via y. apply inverse;apply nplus_0_r.
Defined.

Lemma zLt_iff_zLeq_S : forall x y : Z, x < y <-> z1+x <= y.
Proof.
split;revert y;revert x.
apply (z_ind' (fun x => forall y, _ -> _) _).
intro x. apply (z_ind' (fun y => _ -> _) _).
intro y.
intros H.
change (z1 + zIn x) with (zIn (1%nat + fst x, snd x)).
apply repr_zLeq.
red. simpl. unfold rrel,gop.
change (fst x + snd y < fst y + snd x).
apply zLt_repr in H. assumption.

apply (z_ind' (fun x => forall y, _ -> _) _).
intro x. apply (z_ind' (fun y => _ -> _) _).
intro y.
intros H.
apply repr_zLt. red. unfold gop,rrel.
change (fst (1%nat + fst x, snd x) + snd y <= fst y + snd (1%nat + fst x, snd x)).
apply zLeq_repr.
apply H.
Defined.

Global Instance zNat_lt_embedding : IsEmbedding (<) (<) zNat.
Proof.
split;red;unfold rrel,gop.
intros ? ? H. apply zLt_iff_zLeq_S. change (zNat (1%nat+x) <= zNat y).
apply zNat_leq_embedding. assumption.

intros. apply zLt_iff_zLeq_S in H.
change (1%nat+x <= y). apply zNat_leq_embedding. assumption.
Defined.

Global Instance zNat_plus_morphism : Magma.IsMorphism (+) (+) zNat.
Proof.
eapply transport. symmetry;apply zNat_quotEmbed.
apply quotEmbed_morphism.
Defined.

Global Instance zNat_mult_morphism : Magma.IsMorphism (°) (°) zNat.
Proof.
red;unfold gop.
intros.
apply (ap (class_of _)).
unfold multU. simpl.
change (0 ° 0) with 0.
apply path_prod';apply inverse.
apply nplus_0_r.
path_via (0+0).
apply ap11;[apply ap|];apply nmult_0_r.
Defined.

Global Instance exists_zNat_is_prop : forall z, IsHProp (exists n, zNat n = z).
Proof.
intros. apply hprop_allpath.
intros [n Hn] [m Hm].
destruct Hn.
assert (p:m = n). apply zNat_eq_embedding. assumption.
apply path_sigma' with (inverse p).
apply ZRing_set.
Defined.

Lemma zPlus_0_r : forall x, x + z0 = x.
Proof.
apply right_id. apply id_is_right. apply (@ZeroP Z ZPrering ZRing).
Defined.

Lemma zLeq_exists : forall x y : Z, x <= y <~> exists n, zNat n = y + (zOppV x).
Proof.
intros;apply equiv_iff_hprop;revert y;revert x;
apply (z_ind' (fun x => forall y, _ -> _) _);intro x;
apply (z_ind' (fun y => _ -> _) _);intro y;intro H.

apply zLeq_repr in H. simpl in H. apply nle_exists in H.
exists (H.1). destruct H as [k H].
unfold gop in H. simpl.
apply (@right_cancel Z (+) (zIn x) _). unfold gop.
path_via (zIn y).
apply related_classes_eq. red. simpl. unfold gop.
change (0 + snd x) with (snd x).
eapply concat;[|apply H]. apply inverse;apply associative.
 apply nat_issemiring.
path_via (zIn y + (zOppV (zIn x) + zIn x)).
path_via (zIn y + z0).
apply inverse. apply zPlus_0_r.
apply ap.
apply (id_unique (+)). apply Zero.
apply (zOppP (zIn x)).
apply associative. apply ZRing.

apply repr_zLeq. red;simpl. unfold gop,rrel.
apply exists_nle. exists (H.1).
destruct H as [k H].
simpl.
change (zNat k = zIn (fst y + snd x, snd y + fst x)) in H.
apply classes_eq_related in H.
red in H. simpl in H. unfold gop in H.
path_via (k + (snd y + fst x)).
apply ap. apply commutative. apply nat_issemiring.
etransitivity. apply H.
apply nplus_0_r.
Defined.

Lemma z0_z1_apart : z0 # z1.
Proof.
apply repr_quotRel.
red;simpl. unfold rrel.
intro H;apply inverse in H;apply S_0_neq in H;assumption.
Defined.

Lemma z0_z1_neq : z0 != z1.
Proof.
apply zApart_trivial. apply z0_z1_apart.
Defined.

Definition zAbs : Z -> nat.
Proof.
intros z.
destruct (isconstrlinear z0 z) as [H|H];
exact ((zLeq_exists _ _ H).1).
Defined.

Lemma zAbs_pos_eval : forall n, zAbs (zIn (n, 0)) = n.
Proof.
intros. unfold zAbs.
destruct (isconstrlinear z0 [n, 0]).
destruct (zLeq_exists z0 [n, 0] l).
simpl.
change (zNat x = zNat (n + 0)) in p.
apply zNat_eq_embedding in p.
path_via (n+0). apply nplus_0_r.

destruct (zLeq_exists [n, 0] z0 l).
simpl. change (zNat x = [0, n]) in p.
apply classes_eq_related in p. red in p;simpl in p.
apply nplus_0_0_back in p;destruct p.
path_via 0.
Defined.

Lemma zAbs_neg_eval : forall n, zAbs (zIn (0, n)) = n.
Proof.
intros. unfold zAbs.
destruct (isconstrlinear z0 [0, n]).
destruct (zLeq_exists z0 [0, n] l).
simpl.
change (zNat x = [0, n+0]) in p.
apply classes_eq_related in p. red in p;simpl in p.
apply nplus_0_0_back in p. destruct p.
path_via 0. path_via (n+0). apply nplus_0_r.

destruct (zLeq_exists [0, n] z0 l).
simpl.
change (zNat x = zNat n) in p.
apply zNat_eq_embedding in p. assumption.
Defined.

(*NB: related_classes_eq means it doesn't compute well, so only use it for hprops*)
Lemma z_posneg_ind : forall P : Z -> Type,
(forall z, IsHProp (P z)) ->
(forall n, P [n, 0]) -> (forall n, P [0, n]) ->
forall z, P z.
Proof.
intros ? Hp Hv Hv'.
apply z_ind'. apply _.
intros x.
destruct (isconstrlinear (snd x) (fst x));
apply nle_exists in l;destruct l as [k H].
apply transport with [k, 0].
apply related_classes_eq. red. simpl. path_via (fst x).
apply inverse;apply nplus_0_r.
apply Hv.
apply transport with [0, k].
apply related_classes_eq. red. simpl. path_via (snd x).
path_via (k + fst x). apply commutative. apply nat_issemiring.
apply Hv'.
Defined.

Lemma zAbs_0_back : forall x : Z, 0 = zAbs x -> z0 = x.
Proof.
apply (z_posneg_ind (fun x => _ -> _) _).
intros.
assert (0 = n). path_via (zAbs [n, 0]). apply zAbs_pos_eval.
apply (ap (fun k => [k, 0])). assumption.

intros.
assert (0 = n). path_via (zAbs [0, n]). apply zAbs_neg_eval.
apply (ap (fun k => [0, k])). assumption.
Defined.

Lemma zAbs_zMult : forall a b, zAbs (a°b) = zAbs a ° zAbs b.
Proof.
apply (z_posneg_ind (fun x => forall y, _) _);intro n;
apply (z_posneg_ind (fun y => _) _);intro m;apply (@concat _ _ (n°m)).

- transitivity (zAbs [n°m, 0]).
  apply (ap (fun x => zAbs (class_of _ x))).
  unfold multU. simpl.
  apply path_prod'.
  apply nplus_0_r.
  change (n°0 + m°0 = 0 + 0).
  apply ap11;[apply ap|];apply nmult_0_r.
  apply zAbs_pos_eval.
- apply inverse;apply ap11;[apply ap|];apply zAbs_pos_eval.

- transitivity (zAbs [0, n°m]).
  apply (ap (fun x => zAbs (class_of _ x))).
  unfold multU;simpl.
  apply path_prod'.
  apply (@concat _ _ (n°0)).
  apply nplus_0_r. apply nmult_0_r.
  apply nplus_0_r.
  apply zAbs_neg_eval.
- apply inverse;apply ap11;[apply ap|].
  apply zAbs_pos_eval.
  apply zAbs_neg_eval.

- apply (@concat _ _ (zAbs [0, n°m])).
  apply (ap (fun x => zAbs (class_of _ x))).
  unfold multU;simpl.
  apply path_prod'.
  change (n°0 = 0). apply nmult_0_r.
  change (m°n = n°m). apply nmult_comm.
  apply zAbs_neg_eval.
- apply inverse;apply ap11;[apply ap|].
  apply zAbs_neg_eval.
  apply zAbs_pos_eval.

- apply(@concat _ _ (zAbs [n°m, 0])).
  apply (ap (fun x => zAbs (class_of _ x))).
  unfold multU;simpl;apply path_prod'.
  reflexivity.
  reflexivity.
  apply zAbs_pos_eval.
- apply inverse;apply ap11;[apply ap|];apply zAbs_neg_eval.
Qed.

Global Instance Z_strict_integral : IsStrictIntegral ZPrering.
Proof.
red.
change ZeroV with [0, 0].
intros. apply min1.
apply (ap zAbs) in H.
assert (H' : 0 = zAbs a ° zAbs b).
apply (@concat _ _(zAbs (a°b))).
apply (@concat _ _ (zAbs [0, 0])).
apply inverse;apply zAbs_pos_eval.
apply H.

apply zAbs_zMult.
apply nmult_integral in H'.
clear H. destruct H' as [H|H];[left|right];apply zAbs_0_back;assumption.
Defined.

End NotaSec.

End Relative.


(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat.

(******************************************************************************)
(* We define two combinatorial functions:                                     *)
(*        dyck n == the number of balanced bracket words of length n          *)
(*  gen_dyck m n == the number of balanced bracket word fragments of length n *)
(*                  with m-1 extra closing brackets: dyck n = gen_dyck 1 n    *)
(* These ``Dyck numbers'', are closely related to the well-known Catalan      *)
(* numbers,                                                                   *)
(*            1   /2n\                                                        *)
(*     C_n = --- (    )                                                       *)
(*           n+1  \ n/                                                        *)
(* More precisely, dick n = C_(n/2) if n is even, and 0 if n is odd; the      *)
(* gen_dyck m n are similarly related to the Catalan-Fuss (or Raney) numbers  *)
(* A_{(n+1-m)/2}(2,m); however they are defined using a non-standard          *)
(* recurrence that simplifies the correctness proof of the initial data of    *)
(* the reducibility check. Indeed, Dyck numbers are the only link between the *)
(* initial color and (chromo)gram trees.                                      *)
(******************************************************************************)

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

Fixpoint gen_dyck m n {struct n} :=
  match n, m with
  | 0, 1 => 1
  | n'.+1, m'.+1 => gen_dyck m.+1 n' + gen_dyck m' n'
  | _, _ => 0
  end.

Definition dyck := gen_dyck 1.

Lemma gen_dyck_max m n : n.+1 < m -> gen_dyck m n = 0.
Proof.
elim: n m => [|n IHn] [] //= => [[] // | m lt_n1_m].
by rewrite !IHn // 2?ltnW.
Qed.

Lemma gen_dyck_all_close m : gen_dyck m.+1 m = 1.
Proof. by elim: m => //= m ->; rewrite gen_dyck_max. Qed.

Lemma even_dyck_pos n : 0 < dyck n.*2.
Proof.
rewrite -[n.*2]addn0 /dyck; elim: n {-1}0 => [|n IHn] m.
  by rewrite gen_dyck_all_close.
by rewrite doubleS addSnnS addSn ltn_addr.
Qed.


Section Sets.

  (* Extensional: Enumeration *)
  (* Seen this style of definition before... *)
  Definition Set' (A : Type) := list A.

  (* Intensional: Characteristic 'Function' *)
  Definition Bool_Set (A : Type) := A -> bool.

  (* Definition evens' : Bool_Set nat := evenb. *)

  Definition In_b {A} (a : A) (e : Bool_Set A) : Prop :=
    e a = true.

  Definition Same_Set' {A} (e1 e2 : Bool_Set A) : Prop :=
    forall x, e1 x = e2 x.

  (* How to define Intersection, Union, Subset ? *)
  Definition Union' {A} (e1 e2 : Bool_Set A) : Bool_Set A :=
    fun x => orb (e1 x) (e2 x).

  Definition Intersection' {A} (e1 e2 : Bool_Set A)
    : Bool_Set A :=
    fun x => andb (e1 x) (e2 x).

  Definition Subset' {A} (e1 e2 : Bool_Set A) : Prop :=
    forall x, In_b e1 x -> In_b e2 x.

  (* This encoding of sets means membership is always decideable! *)

End Sets.

Section Fixpoints.

  (* Propositional analogues to definitions from above. *)

  Definition PSet (A : Type) := A -> Prop.

  Definition In {A} (a : A) (e : PSet A) : Prop := e a.
  Notation "x '∈' e" := (In x e) (at level 60).

  Definition Subset {A} (e1 e2 : PSet A) : Prop :=
    forall x, x ∈ e1 -> x ∈ e2.

  Notation "s1 ⊆ s2" := (Subset s1 s2) (at level 60).

  Context {U : Type}. (* The universal set, i.e. our domain of discourse. *)
  Variable F : (PSet U) -> PSet U. (* Our generating function--
  takes a set of Us and builds a new set.*)

  (* A generator function is monotone if it preserves the subset
  relation on its argument. *)
  Definition Monotone_F : Prop :=
    forall (S S' : PSet U),
      S ⊆ S' -> F S ⊆ F S'.

  Definition FClosed (S : PSet U) : Prop := F S ⊆ S.

  Definition FConsistent (S : PSet U) : Prop := S ⊆ F S.

  Definition FixedPoint (S : PSet U) : Prop :=
    S ⊆ F S /\ F S ⊆ S.

  (* The least fixed point of a monotone generator function exists,
   and it is the intersection of all F-closed sets. *)
  Definition LFP : PSet U :=
    fun a => forall S, FClosed S -> S a.

  (* The greatest fixed point of a generator function exists,
   and it is the union of all F-consistent sets. *)
  Definition GFP : PSet U :=
    fun a => exists S, FConsistent S /\ S a.

  Lemma GFP_is_FConsistent
    : Monotone_F -> FConsistent GFP.
  Proof.
    intros F_Monotone.
    unfold FConsistent.
    intros ? ?.
    (* By the definition of GFP, there must be some F-consistent set, X, that contains x *)
    destruct H as [X [? ?] ].
    (* Since X is F-consistent, by definition x is a member of F X. *)
    apply H in H0.
    (* We have now established that F X ⊆ F GFP: *)
    revert x H0; fold (Subset (F X) (F GFP)).
    (* Since F is monotone, it suffices to show that X ⊆ GFP *)
    eapply F_Monotone.
    (* To show X ⊆ GFP, we just need to show that every x in X is in GFP *)
    intros ? ?.
    (* By definition, x is an element of GFP if it is a member of an
    F-consistent set. By assumption, x is in X and F is F-consistent,
    so we're done!*)
    unfold In, GFP.
    eexists X.
    eauto.
  Qed.

  Lemma GFP_is_FClosed
    : Monotone_F -> FClosed GFP.
  Proof.
    intros F_Monotone ? ?.
    (* By our previous lemma, we know that GFP ⊆ F GFP. By monotonicity of
       F, F GFP ⊆ F (F GFP). *)
    assert (F GFP ⊆ F (F GFP)).
    { apply F_Monotone.
      apply GFP_is_FConsistent.
      eassumption. }
    (* By definition, this means F GFP is F-consistent. *)
    assert (FConsistent (F GFP)).
    { intros ? ?.
      apply H0.
      assumption. }
    (* Since F is a member of an F-consistent set, it must be a member
    of GFP.*)
    unfold In, GFP.
    exists (F GFP).
    eauto.
  Qed.

  Theorem GFP_is_FixedPoint
    : Monotone_F -> FixedPoint GFP.
  Proof.
    intro F_Monotone.
    unfold FixedPoint.
    split.
    - apply GFP_is_FConsistent; eauto.
    - apply GFP_is_FClosed; eauto.
  Qed.

  Theorem LFP_is_FClosed
    : Monotone_F -> FClosed LFP.
  Proof.
  Admitted.

  Theorem LFP_is_FConsistent
    : Monotone_F -> FConsistent LFP.
  Proof.
  Admitted.

  Theorem LFP_is_FixedPoint
    : Monotone_F -> FixedPoint LFP.
  Proof.
    intro F_Monotone.
    unfold FixedPoint.
    split.
    - apply LFP_is_FConsistent; eauto.
    - apply LFP_is_FClosed; eauto.
  Qed.

  Lemma Ind
    : forall (Ind : PSet U),
      FClosed Ind -> forall a, LFP a -> Ind a.
  Proof.
    unfold LFP, FClosed; intros; eapply H0; eauto.
  Qed.

  Lemma CoInd
    : forall (Ind : PSet U),
      FConsistent Ind -> forall a, Ind a -> GFP a.
  Proof.
    unfold GFP, FConsistent; intros; eauto.
  Qed.

End Fixpoints.

Inductive isEven : nat -> Prop :=
| isEvenZero : isEven 0
| isEvenSS : forall (n : nat), isEven n -> isEven (S (S n)).

Definition isEven_F : PSet nat -> PSet nat :=
  fun X n => (n = 0) \/ (exists n', X n' /\ n = S (S n')).

Definition isEven' := LFP isEven_F.

Theorem isEven_eqv : forall n,
    isEven n <-> isEven' n.
Proof.
  split; intro.
  - induction H.
    + unfold isEven', LFP.
      intros.
      apply H.
      unfold isEven_F, In; intuition.
    + unfold isEven', LFP.
      intros.
      apply H0.
      unfold isEven_F, In; right.
      eexists; intuition.
      unfold isEven' in IHisEven.
      apply IHisEven in H0; eauto.
  - unfold LFP in H. eapply Ind; try eassumption.
    intros ? ?; unfold In in *.
    destruct H0 as [ | [n' [? ?] ] ]; subst.
    + econstructor.
    + econstructor.
      eassumption.
Qed.

(* Start coinduction chapter from CPDT here. *)

Section stream.
  Context (A : Type).

  CoInductive stream : Type :=
  | Cons : A -> stream -> stream.
End stream.

Arguments Cons {A} _ _.

CoFixpoint zeroes : stream nat := Cons 0 zeroes.

(** We can also define a stream that alternates between [true] and [false]. *)

CoFixpoint trues_falses : stream bool := Cons true falses_trues
with falses_trues : stream bool := Cons false trues_falses.

(** Co-inductive values are fair game as arguments to recursive
functions, and we can use that fact to write a function to take a
finite approximation of a stream. *)

Fixpoint approx {A} (s : stream A) (n : nat) : list A :=
  match n with
    | O => nil
    | S n' =>
      match s with
        | Cons h t => h :: approx t n'
      end
  end.

Eval simpl in approx zeroes 10.

Eval simpl in approx trues_falses 10.

Fail CoFixpoint looper : stream nat := looper.

Section map.
  Variables A B : Type.
  Variable f : A -> B.

  CoFixpoint map (s : stream A) : stream B :=
    match s with
      | Cons h t => Cons (f h) (map t)
    end.
End map.

Section interleave.
  Variable A : Type.

  CoFixpoint interleave (s1 s2 : stream A) : stream A :=
    match s1, s2 with
      | Cons h1 t1, Cons h2 t2 => Cons h1 (Cons h2 (interleave t1 t2))
    end.
End interleave.

Section map'.
  Variables A B : Type.
  Variable f : A -> B.

  Fail CoFixpoint map' (s : stream A) : stream B :=
    match s with
      | Cons h t => interleave (Cons (f h) (map' t)) (Cons (f h) (map' t))
    end.

End map'.

Definition tl A (s : stream A) : stream A :=
  match s with
    | Cons _ s' => s'
  end.

Fail CoFixpoint bad : stream nat := tl _ (Cons 0 bad).

Fail CoFixpoint bad : stream nat := bad.

(** * Infinite Proofs *)

(** Let us say we want to give two different definitions of a stream
of all ones, and then we want to prove that they are equivalent. *)

CoFixpoint ones : stream nat := Cons 1 ones.
Definition ones' := map _ _ S zeroes.

(** The obvious statement of the equality is this: *)

Theorem ones_eq : ones = ones'.

Abort.

Section stream_eq.
  Context {A : Type}.

  CoInductive stream_eq : stream A -> stream A -> Prop :=
  | Stream_eq : forall h t1 t2,
    stream_eq t1 t2
    -> stream_eq (Cons h t1) (Cons h t2).
End stream_eq.

Theorem ones_eq : stream_eq ones ones'.

  cofix ones_eq.

  assumption.

  Undo.
  simpl.

Abort.

(** First, we need to define a function that seems pointless at first glance. *)

Definition frob {A} (s : stream A) : stream A :=
  match s with
    | Cons h t => Cons h t
  end.

(** Next, we need to prove a theorem that seems equally pointless. *)

Theorem frob_eq : forall {A} (s : stream A), s = frob s.
  destruct s; reflexivity.
Qed.

(** But, miraculously, this theorem turns out to be just what we needed. *)

Theorem ones_eq : stream_eq ones ones'.
  cofix ones_eq.

  (** We can use the theorem to rewrite the two streams. *)

  rewrite (frob_eq ones).
  rewrite (frob_eq ones').

  simpl.

  constructor.

  assumption.
Qed.

Require Coq.Setoids.Setoid.

Definition stream_eq_F {A : Type} : PSet (stream A * stream A) -> PSet (stream A * stream A) :=
  fun X s => exists h t1 t2, In (t1, t2) X /\ fst s = (Cons h t1) /\ snd s = (Cons h t2).

Definition stream_eq' {A} := GFP (@stream_eq_F A).

Theorem ones_eq' : stream_eq' (ones, ones').
  unfold stream_eq'.
  eapply CoInd.
  unfold FConsistent, Subset, In.
  intros [t1 t2].
  instantiate (1 := fun s => s = (ones, ones')).
  simpl; intros.
  injection H; intros.
  subst.
  unfold stream_eq_F.
  eexists 1, ones, ones'; intuition.
  simpl; rewrite (frob_eq ones) at 1; reflexivity.
  simpl; rewrite (frob_eq ones') at 1; reflexivity.
  reflexivity.
Qed.


Require Import Coq.Lists.ListSet.
Require Import CpdtTactics.
Require Import List.

Definition set_eq {A} (s t : set A) := forall x, set_In x s <-> set_In x t.
Lemma empty_elim {A} (s : A) : ~ set_In s (empty_set A).
intro.
unfold set_In, empty_set in *.
destruct H.
Qed.

Definition set_disjoint {A} (H : forall x y : A, {x=y} + {x <> y}) (s t : set A) :=
  forall x, ~ (set_In x (set_inter H s t)).

Fixpoint allpairs {A} (xs : list A) : list (A * A) :=
  match xs with
  | nil => nil
  | h :: t =>
    map (fun y => (h,y)) t ++ allpairs t
  end.

Definition set_pairwise_disjoint {A} (H : forall x y : A, {x=y} + {x <> y}) (xs : list (set A)) :=
  fold_left (fun acc p => acc /\ set_disjoint H (fst p) (snd p)) (allpairs xs) True.

  Lemma set_union_assoc {A : Set} {eqA : forall (x y : A), {x = y} + {x <> y}} : forall (s1 s2 s3 : set A),
      set_eq (set_union eqA s1 (set_union eqA s2 s3)) (set_union eqA (set_union eqA s1 s2) s3).
    intros.
    unfold set_eq.
    split.
    intros.
    apply set_union_elim in H; destruct H.
    apply set_union_intro.
    left; apply set_union_intro; left; crush.
    apply set_union_elim in H; destruct H.
    apply set_union_intro; left; apply set_union_intro; right; crush.
    apply set_union_intro; right; crush.
    intros.
    apply set_union_elim in H; destruct H as [H1 | H2]; [apply set_union_elim in H1; destruct H1 | idtac].
    apply set_union_intro; left; crush.
    apply set_union_intro; right; apply set_union_intro; left; crush.
    apply set_union_intro; right; apply set_union_intro; right; crush.
  Qed.

  Lemma set_union_not_in {A : Set} {eqA : forall (x y : A), {x = y} + {x <> y}} : forall (s1 s2 : set A) x,
      ~ (set_In x (set_union eqA s1 s2)) -> (~ set_In x s1) /\ (~ set_In x s2).
    intros.
    split; intro.
    apply H.
    apply set_union_intro; left; crush.
    apply H.
    apply set_union_intro; right; crush.
 Qed.

  Lemma set_union_cong {A : Set} {eqA : forall (x y : A), {x = y} + {x <> y}} : forall (s1 s2 s3 s4 : set A),
      set_eq s1 s2 -> set_eq s3 s4 -> set_eq (set_union eqA s1 s3) (set_union eqA s2 s4).
    intros; unfold set_eq in *.
    intros; split; intros.
    apply set_union_elim in H1; destruct H1.
    apply set_union_intro; left; apply H; crush.
    apply set_union_intro; right; apply H0; crush.

    apply set_union_elim in H1; destruct H1.
    apply set_union_intro; left; apply H; crush.
    apply set_union_intro; right; apply H0; crush.
  Qed.

  Lemma set_union_symm {A : Set} {eqA : forall (x y : A), {x = y} + {x <> y}} : forall (s1 s2 : set A), set_eq (set_union eqA s1 s2) (set_union eqA s2 s1).
    intros.
    unfold set_eq.
    intros; split; intros H; apply set_union_elim in H; destruct H; apply set_union_intro; crush.
  Qed.

  Lemma set_diff_cong {A : Set} {eqA : forall (x y : A), {x = y} + {x <> y}} : forall (s1 s2 s3 s4 : set A),
      set_eq s1 s2 -> set_eq s3 s4 -> set_eq (set_diff eqA s1 s3) (set_diff eqA s2 s4).
    intros.
    unfold set_eq; intros; split; intros G; apply set_diff_iff in G; destruct G; apply set_diff_iff.
    split; [apply H | intro; apply H2; apply H0]; crush.
    split; [apply H | intro; apply H2; apply H0]; crush.
  Qed.

  Lemma set_eq_refl : forall {A : Set} (s : set A), set_eq s s.
    unfold set_eq; crush.
  Qed.

  Lemma set_eq_trans : forall {A : Set} (s1 s2 s3 : set A), set_eq s1 s2 -> set_eq s2 s3 -> set_eq s1 s3.
    intros; unfold set_eq in *.
    split; intros.
    apply H0; apply H; crush.
    apply H; apply H0; crush.
  Qed.