(* Adapted from https://github.com/Eelis/hybrid (although the construction is standard) *)

Require Import Vector.
Require Import FCF.

Set Implicit Arguments.

Inductive bnat: nat -> Set :=
  | bO n: bnat (S n)
  | bS n: bnat n -> bnat (S n).

Fixpoint to_nat n (b: bnat n): nat :=
  match b with
  | bO _ => 0%nat
  | bS x => S (to_nat x)
  end.

(* stolen from coq-ext-lib *)

Fixpoint bnat_from_nat_raw (m n : nat) {struct m} : n < m -> bnat m :=
match n as n, m as m return n < m -> bnat m with
 | 0, 0 => fun pf => @False_rect _ (lt_eq_false pf)
 | 0, S m => fun _ => bO m
 | S n, 0 => fun pf => @False_rect _ (lt_n_0 _ pf)
 | S n, S m => fun pf => bS (@bnat_from_nat_raw m n (lt_S_n _ _ pf))
end.

Definition bnat_mod_nat (N n : nat) := (* N -> n -> n mod N as bnat (S N) *)
let pfz := not_eq_sym (O_S N) in
@bnat_from_nat_raw (S N) (n mod (S N)) (Nat.mod_upper_bound n (S N) pfz).

Section alt_rect.

  Variables
    (P: forall n: nat, bnat (S n) -> Type)
    (Pz: forall p, P (bO p))
    (Ps: forall n (b: bnat (S n)), P b -> P (bS b)).

  Let R (n: nat): bnat n -> Type :=
    match n with
    | O => fun _ => False
    | S _ => @P _
    end.

  Fixpoint RS (n : nat): forall (b : bnat n), R b -> R (bS b) :=
    match n return forall (b : bnat n), R b -> R (bS b) with
    | O => fun x f => False_rect _ f
    | S n' => fun x f => Ps f
    end.

  Definition bnat_Srect (n: nat) (nb: bnat (S n)): P nb
    := bnat_rect R Pz RS nb.

End alt_rect.

Lemma bnat_cases n (x: bnat (S n)): { p | x = bS p } + { x = bO n }.
  revert n x.
  apply bnat_Srect; [right | left; exists b]; reflexivity.
Defined.

Lemma bnat_0: bnat 0 -> False.
Proof with auto.
  cut (forall n, bnat n -> n <> 0%nat).
    intros H H0. apply (H _ H0)...
  induction 1; intro; discriminate.
Qed.

Require Import List.

Definition bnat_bound n (b: bnat n): nat := n.

Lemma bnat_bound_lt n (b : bnat n) : @to_nat n b < @bnat_bound n b.
induction n.
exfalso.
apply bnat_0; auto.

dependent inversion b; subst.
unfold to_nat, bnat_bound.
apply lt_0_Sn.

simpl.
unfold bnat_bound.
apply lt_n_S.
apply IHn.
Qed.

Definition pred n (b: bnat n): option (bnat (Peano.pred (bnat_bound b))) :=
  match b return option (bnat (Peano.pred (bnat_bound b))) with
  | bO _ => None
  | bS y => Some y
  end.

Require Import util.

Lemma eq_bS_inv n (x y: bnat n): bS x = bS y -> x = y.
Proof with auto.
  intros.
  apply option_eq_inv.
  replace (Some x) with (pred (bS x))...
  replace (Some y) with (pred (bS y))...
  rewrite H...
Qed.

Definition all_bnats := fix F (n: nat): list (bnat n) :=
  match n with
  | O => nil
  | S m => bO m :: map (@bS m) (F m)
  end.

Global Instance bnats n: ExhaustiveList (bnat n) := { exhaustive_list := all_bnats n }.
Proof with auto.
  dependent induction n; intro x.
    elimtype False. apply bnat_0...
  destruct (bnat_cases x) as [[p e] | e]; subst; [right | left]...
Defined.

(* below used to give decidable equality on bnat; can be simplified using https://github.com/tchajed/deptacs *)
Lemma tonat_sound {N : nat} (o1 o2 : bnat N) : to_nat o1 = to_nat o2 -> o1 = o2.
intros.
dependent induction o1.
dependent destruction o2.
auto.
discriminate.
dependent destruction o2.
discriminate.
inversion H.
apply IHo1 in H1.
subst.
auto.
Qed.

Definition eqb_bnat {N : nat} (o1 o2 : bnat N) := eqb (to_nat o1) (to_nat o2).

Lemma eqb_bnat_refl {N : nat} (o : bnat N) : eqb_bnat o o = true.
unfold eqb_bnat.
apply eqb_leibniz.
auto.
Qed.

Lemma eqb_bnat_sound {N : nat} (o1 o2 : bnat N) : eqb_bnat o1 o2 = true -> o1 = o2.
intuition.
unfold eqb_bnat in H.
rewrite eqb_leibniz in H.
apply tonat_sound.
auto.
Qed.

Instance bnat_eqdec {N : nat} : EqDec (bnat N) := {eqb := eqb_bnat}.
intuition.
apply eqb_bnat_sound.
auto.

subst.
apply eqb_bnat_refl.
Qed.

(* arithmetic *)
Definition bnat_add {N : nat} (a b : bnat (S N)) := bnat_mod_nat N ((to_nat a) + (to_nat b)).
Definition bnat_mult {N : nat} (a b : bnat (S N)) := bnat_mod_nat N ((to_nat a) * (to_nat b)).

Definition bd_vec (n q : nat) := Vector.t (bnat q) n.

Fixpoint bnv_dot {n q : nat} (v w : bd_vec n (S q)) :=
Vector.fold_left2 (fun (acc a b : bnat (S q)) => bnat_add acc (bnat_mult a b)) (bO q) v w.

Fixpoint bnv_add {n q : nat} (v w : bd_vec n (S q)) :=
Vector.map2 (fun a b => bnat_add a b) v w.

Global Instance eqbv : forall {n q : nat}, EqDec (bd_vec n q).
unfold bd_vec.
intros.
apply Vector_EqDec.
apply bnat_eqdec.
Defined.

Fixpoint from_natlist (N : nat) (xs : list nat) :=
let bxs := map (fun n => bnat_mod_nat N n) xs in
Vector.of_list bxs.

(* example of vector arithmetic *)

Definition v := from_natlist 4 (1 :: 2 :: 0 :: nil)%nat.
Definition w := from_natlist 4 (2 :: 4 :: 1 :: nil)%nat.
Compute bnv_dot v w.
(* = bO 4
     : bnat 5 (ie, 0 mod 5) *)
Compute Vector.to_list (bnv_add v w).
(* = [bS (bS (bS (bO 1))); bS (bO 3); bS (bO 3)] (ie, [3, 1, 1]) *)


(* This file is distributed under the terms of the MIT License, also
   known as the X11 Licence.  A copy of this license is in the README
   file that accompanied the original distribution of this file.

   Based on code written by:
     Brian Aydemir
     Arthur Charg\'eraud *)

(** Lemmas and tactics for working with and solving goals related to
    non-membership in finite sets.  The main tactic of interest here
    is [solve_notin].

    Implicit arguments are declared by default in this library. *)

Require Import Coq.FSets.FSetInterface.

Require Import Metalib.CoqFSetDecide.

(* *********************************************************************** *)
(** * Implementation *)

Module Notin_fun
  (E : DecidableType) (Import X : FSetInterface.WSfun E).

Module Import D := CoqFSetDecide.WDecide_fun E X.

(* *********************************************************************** *)
(** * Facts about set non-membership *)

Section Lemmas.

Variables x y  : elt.
Variable  s s' : X.t.

Lemma notin_empty_1 :
  ~ In x empty.
Proof. fsetdec. Qed.

Lemma notin_add_1 :
  ~ In y (add x s) ->
  ~ E.eq x y.
Proof. fsetdec. Qed.

Lemma notin_add_1' :
  ~ In y (add x s) ->
  x <> y.
Proof. fsetdec. Qed.

Lemma notin_add_2 :
  ~ In y (add x s) ->
  ~ In y s.
Proof. fsetdec. Qed.

Lemma notin_add_3 :
  ~ E.eq x y ->
  ~ In y s ->
  ~ In y (add x s).
Proof. fsetdec. Qed.

Lemma notin_singleton_1 :
  ~ In y (singleton x) ->
  ~ E.eq x y.
Proof. fsetdec. Qed.

Lemma notin_singleton_1' :
  ~ In y (singleton x) ->
  x <> y.
Proof. fsetdec. Qed.

Lemma notin_singleton_2 :
  ~ E.eq x y ->
  ~ In y (singleton x).
Proof. fsetdec. Qed.

Lemma notin_remove_1 :
  ~ In y (remove x s) ->
  E.eq x y \/ ~ In y s.
Proof. fsetdec. Qed.

Lemma notin_remove_2 :
  ~ In y s ->
  ~ In y (remove x s).
Proof. fsetdec. Qed.

Lemma notin_remove_3 :
  E.eq x y ->
  ~ In y (remove x s).
Proof. fsetdec. Qed.

Lemma notin_remove_3' :
  x = y ->
  ~ In y (remove x s).
Proof. fsetdec. Qed.

Lemma notin_union_1 :
  ~ In x (union s s') ->
  ~ In x s.
Proof. fsetdec. Qed.

Lemma notin_union_2 :
  ~ In x (union s s') ->
  ~ In x s'.
Proof. fsetdec. Qed.

Lemma notin_union_3 :
  ~ In x s ->
  ~ In x s' ->
  ~ In x (union s s').
Proof. fsetdec. Qed.

Lemma notin_inter_1 :
  ~ In x (inter s s') ->
  ~ In x s \/ ~ In x s'.
Proof. fsetdec. Qed.

Lemma notin_inter_2 :
  ~ In x s ->
  ~ In x (inter s s').
Proof. fsetdec. Qed.

Lemma notin_inter_3 :
  ~ In x s' ->
  ~ In x (inter s s').
Proof. fsetdec. Qed.

Lemma notin_diff_1 :
  ~ In x (diff s s') ->
  ~ In x s \/ In x s'.
Proof. fsetdec. Qed.

Lemma notin_diff_2 :
  ~ In x s ->
  ~ In x (diff s s').
Proof. fsetdec. Qed.

Lemma notin_diff_3 :
  In x s' ->
  ~ In x (diff s s').
Proof. fsetdec. Qed.

End Lemmas.

(* *********************************************************************** *)
(** * Hints *)

Hint Resolve
  @notin_empty_1 @notin_add_3 @notin_singleton_2 @notin_remove_2
  @notin_remove_3 @notin_remove_3' @notin_union_3 @notin_inter_2
  @notin_inter_3 @notin_diff_2 @notin_diff_3.

(* *********************************************************************** *)
(** * Tactics for non-membership *)

(** [destruct_notin] decomposes all hypotheses of the form [~ In x s]. *)

Ltac destruct_notin :=
  match goal with
    | H : In ?x ?s -> False |- _ =>
      change (~ In x s) in H;
      destruct_notin
    | |- In ?x ?s -> False =>
      change (~ In x s);
      destruct_notin
    | H : ~ In _ empty |- _ =>
      clear H;
      destruct_notin
    | H : ~ In ?y (add ?x ?s) |- _ =>
      let J1 := fresh "NotInTac" in
      let J2 := fresh "NotInTac" in
      pose proof H as J1;
      pose proof H as J2;
      apply notin_add_1 in H;
      apply notin_add_1' in J1;
      apply notin_add_2 in J2;
      destruct_notin
    | H : ~ In ?y (singleton ?x) |- _ =>
      let J := fresh "NotInTac" in
      pose proof H as J;
      apply notin_singleton_1 in H;
      apply notin_singleton_1' in J;
      destruct_notin
    | H : ~ In ?y (remove ?x ?s) |- _ =>
      let J := fresh "NotInTac" in
      apply notin_remove_1 in H;
      destruct H as [J | J];
      destruct_notin
    | H : ~ In ?x (union ?s ?s') |- _ =>
      let J := fresh "NotInTac" in
      pose proof H as J;
      apply notin_union_1 in H;
      apply notin_union_2 in J;
      destruct_notin
    | H : ~ In ?x (inter ?s ?s') |- _ =>
      let J := fresh "NotInTac" in
      apply notin_inter_1 in H;
      destruct H as [J | J];
      destruct_notin
    | H : ~ In ?x (diff ?s ?s') |- _ =>
      let J := fresh "NotInTac" in
      apply notin_diff_1 in H;
      destruct H as [J | J];
      destruct_notin
    | _ =>
      idtac
  end.

(** [solve_notin] decomposes hypotheses of the form [~ In x s] and
    then tries some simple heuristics for solving the resulting
    goals. *)

Ltac solve_notin :=
  intros;
  destruct_notin;
  repeat first [ apply notin_union_3
               | apply notin_add_3
               | apply notin_singleton_2
               | apply notin_empty_1
               ];
  auto;
  try tauto;
  fail "Not solvable by [solve_notin]; try [destruct_notin]".

(* *********************************************************************** *)
(** * Examples and test cases *)

(** These examples and test cases are not meant to be exhaustive. *)

Lemma test_solve_notin_1 : forall x E F G,
  ~ In x (union E F) ->
  ~ In x G ->
  ~ In x (union E G).
Proof. solve_notin. Qed.

Lemma test_solve_notin_2 : forall x y E F G,
  ~ In x (union E (union (singleton y) F)) ->
  ~ In x G ->
  ~ In x (singleton y) /\ ~ In y (singleton x).
Proof. split. solve_notin. solve_notin. Qed.

Lemma test_solve_notin_3 : forall x y,
  ~ E.eq x y ->
  ~ In x (singleton y) /\ ~ In y (singleton x).
Proof. split. solve_notin. solve_notin. Qed.

Lemma test_solve_notin_4 : forall x y E F G,
  ~ In x (union E (union (singleton x) F)) ->
  ~ In y G.
Proof. solve_notin. Qed.

Lemma test_solve_notin_5 : forall x y E F,
  ~ In x (union E (union (singleton y) F)) ->
  ~ In y E ->
  ~ E.eq y x /\ ~ E.eq x y.
Proof. split. solve_notin. solve_notin. Qed.

Lemma test_solve_notin_6 : forall x y E,
  ~ In x (add y E) ->
  ~ E.eq x y /\ ~ In x E.
Proof. split. solve_notin. solve_notin. Qed.

Lemma test_solve_notin_7 : forall x,
  ~ In x (singleton x) ->
  False.
Proof. solve_notin. Qed.

End Notin_fun.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq path div.
Require Import fintype tuple finfun bigop prime finset.

(******************************************************************************)
(* This files contains the definition of:                                     *)
(*   'C(n, m) == the binomial coeficient n choose m.                          *)
(*     n ^_ m == the falling (or lower) factorial of n with m terms, i.e.,    *)
(*               the product n * (n - 1) * ... * (n - m + 1).                 *)
(*               Note that n ^_ m = 0 if m > n, and 'C(n, m) = n ^_ m %/ m/!. *)
(*                                                                            *)
(* In additions to the properties of these functions, we prove a few seminal  *)
(* results such as triangular_sum, Wilson and Pascal; their proofs are good   *)
(* examples of how to manipulate expressions with bigops.                     *)
(******************************************************************************)

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

(** More properties of the factorial **)

Lemma fact_smonotone m n : 0 < m -> m < n -> m`! < n`!.
Proof.
case: m => // m _; elim: n m => // n IHn [|m] lt_m_n.
  by rewrite -[_.+1]muln1 leq_mul ?fact_gt0.
by rewrite ltn_mul ?IHn.
Qed.

Lemma fact_prod n : n`! = \prod_(1 <= i < n.+1) i.
Proof.
elim: n => [|n IHn] //; first by rewrite big_nil.
by apply sym_equal; rewrite factS IHn // !big_add1 big_nat_recr //= mulnC.
Qed.

Lemma logn_fact p n : prime p -> logn p n`! = \sum_(1 <= k < n.+1) n %/ p ^ k.
Proof.
move=> p_prime; transitivity (\sum_(1 <= i < n.+1) logn p i).
  rewrite big_add1; elim: n => /= [|n IHn]; first by rewrite logn1 big_geq.
  by rewrite big_nat_recr // -IHn /= factS mulnC lognM ?fact_gt0.
transitivity (\sum_(1 <= i < n.+1) \sum_(1 <= k < n.+1) (p ^ k %| i)).
  apply: eq_big_nat => i /andP[i_gt0 le_i_n]; rewrite logn_count_dvd //.
  rewrite -!big_mkcond (big_nat_widen _ _ n.+1) 1?ltnW //; apply: eq_bigl => k.
  by apply: andb_idr => /dvdn_leq/(leq_trans (ltn_expl _ (prime_gt1 _)))->.
by rewrite exchange_big_nat; apply: eq_bigr => i _; rewrite divn_count_dvd.
Qed.

Theorem Wilson p : p > 1 -> prime p = (p %| ((p.-1)`!).+1).
Proof.
have dFact n: 0 < n -> (n.-1)`! = \prod_(0 <= i < n | i != 0) i.
  move=> n_gt0; rewrite -big_filter fact_prod; symmetry; apply: congr_big => //.
  rewrite /index_iota subn1 -[n]prednK //=; apply/all_filterP.
  by rewrite all_predC has_pred1 mem_iota.
move=> lt1p; have p_gt0 := ltnW lt1p.
apply/idP/idP=> [pr_p | dv_pF]; last first.
  apply/primeP; split=> // d dv_dp; have: d <= p by apply: dvdn_leq.
  rewrite orbC leq_eqVlt => /orP[-> // | ltdp].
  have:= dvdn_trans dv_dp dv_pF; rewrite dFact // big_mkord.
  rewrite (bigD1 (Ordinal ltdp)) /=; last by rewrite -lt0n (dvdn_gt0 p_gt0).
  by rewrite orbC -addn1 dvdn_addr ?dvdn_mulr // dvdn1 => ->.
pose Fp1 := Ordinal lt1p; pose Fp0 := Ordinal p_gt0.
have ltp1p: p.-1 < p by [rewrite prednK]; pose Fpn1 := Ordinal ltp1p.
case eqF1n1: (Fp1 == Fpn1); first by rewrite -{1}[p]prednK -1?((1 =P p.-1) _).
have toFpP m: m %% p < p by rewrite ltn_mod.
pose toFp := Ordinal (toFpP _); pose mFp (i j : 'I_p) := toFp (i * j).
have Fp_mod (i : 'I_p) : i %% p = i by apply: modn_small.
have mFpA: associative mFp.
  by move=> i j k; apply: val_inj; rewrite /= modnMml modnMmr mulnA.
have mFpC: commutative mFp by move=> i j; apply: val_inj; rewrite /= mulnC.
have mFp1: left_id Fp1 mFp by move=> i; apply: val_inj; rewrite /= mul1n.
have mFp1r: right_id Fp1 mFp by move=> i; apply: val_inj; rewrite /= muln1.
pose mFpLaw := Monoid.Law mFpA mFp1 mFp1r.
pose mFpM := Monoid.operator (@Monoid.ComLaw _ _ mFpLaw mFpC).
pose vFp (i : 'I_p) := toFp (egcdn i p).1.
have vFpV i: i != Fp0 -> mFp (vFp i) i = Fp1.
  rewrite -val_eqE /= -lt0n => i_gt0; apply: val_inj => /=.
  rewrite modnMml; case: egcdnP => //= _ km -> _; rewrite {km}modnMDl.
  suffices: coprime i p by move/eqnP->; rewrite modn_small.
  rewrite coprime_sym prime_coprime //; apply/negP=> /(dvdn_leq i_gt0).
  by rewrite leqNgt ltn_ord.
have vFp0 i: i != Fp0 -> vFp i != Fp0.
  move/vFpV=> inv_i; apply/eqP=> vFp0.
  by have:= congr1 val inv_i; rewrite vFp0 /= mod0n.
have vFpK: {in predC1 Fp0, involutive vFp}.
  move=> i n0i; rewrite /= -[vFp _]mFp1r -(vFpV _ n0i) mFpA.
  by rewrite vFpV (vFp0, mFp1).
have le_pmFp (i : 'I_p) m: i <= p + m.
  by apply: leq_trans (ltnW _) (leq_addr _ _).
have eqFp (i j : 'I_p): (i == j) = (p %| p + i - j).
  by rewrite -eqn_mod_dvd ?(modnDl, Fp_mod).
have vFpId i: (vFp i == i :> nat) = xpred2 Fp1 Fpn1 i.
  symmetry; have [->{i} | /eqP ni0] := i =P Fp0.
    by rewrite /= -!val_eqE /= -{2}[p]prednK //= modn_small //= -(subnKC lt1p).
  rewrite 2!eqFp -Euclid_dvdM //= -[_ - p.-1]subSS prednK //.
  have lt0i: 0 < i by rewrite lt0n.
  rewrite -addnS addKn -addnBA // mulnDl -{2}(addn1 i) -subn_sqr.
  rewrite addnBA ?leq_sqr // mulnS -addnA -mulnn -mulnDl.
  rewrite -(subnK (le_pmFp (vFp i) i)) mulnDl addnCA.
  rewrite -[1 ^ 2]/(Fp1 : nat) -addnBA // dvdn_addl.
    by rewrite Euclid_dvdM // -eqFp eq_sym orbC /dvdn Fp_mod eqn0Ngt lt0i.
  by rewrite -eqn_mod_dvd // Fp_mod modnDl -(vFpV _ ni0) eqxx.
suffices [mod_fact]: toFp (p.-1)`! = Fpn1.
  by rewrite /dvdn -addn1 -modnDml mod_fact addn1 prednK // modnn.
rewrite dFact //; rewrite ((big_morph toFp) Fp1 mFpM) //; first last.
- by apply: val_inj; rewrite /= modn_small.
- by move=> i j; apply: val_inj; rewrite /= modnMm.
rewrite big_mkord (eq_bigr id) => [|i _]; last by apply: val_inj => /=.
pose ltv i := vFp i < i; rewrite (bigID ltv) -/mFpM [mFpM _ _]mFpC.
rewrite (bigD1 Fp1) -/mFpM; last by rewrite [ltv _]ltn_neqAle vFpId.
rewrite [mFpM _ _]mFp1 (bigD1 Fpn1) -?mFpA -/mFpM; last first.
  rewrite -lt0n -ltnS prednK // lt1p.
  by rewrite [ltv _]ltn_neqAle vFpId eqxx orbT eq_sym eqF1n1.
rewrite (reindex_onto vFp vFp) -/mFpM => [|i]; last by do 3!case/andP; auto.
rewrite (eq_bigl (xpredD1 ltv Fp0)) => [|i]; last first.
  rewrite andbC -!andbA -2!negb_or -vFpId orbC -leq_eqVlt.
  rewrite andbA -ltnNge; symmetry; case: (altP eqP) => [->|ni0].
    by case: eqP => // E; rewrite ?E !andbF.
  by rewrite vFpK //eqxx vFp0.
rewrite -{2}[mFp]/mFpM -[mFpM _ _]big_split -/mFpM.
by rewrite big1 ?mFp1r //= => i /andP[]; auto.
Qed.

(** The falling factorial *)

Fixpoint ffact_rec n m := if m is m'.+1 then n * ffact_rec n.-1 m' else 1.

Definition falling_factorial := nosimpl ffact_rec.

Notation "n ^_ m" := (falling_factorial n m)
  (at level 30, right associativity) : nat_scope.

Lemma ffactE : falling_factorial = ffact_rec. Proof. by []. Qed.

Lemma ffactn0 n : n ^_ 0 = 1. Proof. by []. Qed.

Lemma ffact0n m : 0 ^_ m = (m == 0). Proof. by case: m. Qed.

Lemma ffactnS n m : n ^_ m.+1 = n * n.-1 ^_ m. Proof. by []. Qed.

Lemma ffactSS n m : n.+1 ^_ m.+1 = n.+1 * n ^_ m. Proof. by []. Qed.

Lemma ffactn1 n : n ^_ 1 = n. Proof. exact: muln1. Qed.

Lemma ffactnSr n m : n ^_ m.+1 = n ^_ m * (n - m).
Proof.
elim: n m => [|n IHn] [|m] //=; first by rewrite ffactn1 mul1n.
by rewrite !ffactSS IHn mulnA.
Qed.

Lemma ffact_gt0 n m : (0 < n ^_ m) = (m <= n).
Proof. by elim: n m => [|n IHn] [|m] //=; rewrite ffactSS muln_gt0 IHn. Qed.

Lemma ffact_small n m : n < m -> n ^_ m = 0.
Proof. by rewrite ltnNge -ffact_gt0; case: posnP. Qed.

Lemma ffactnn n : n ^_ n = n`!.
Proof. by elim: n => [|n IHn] //; rewrite ffactnS IHn. Qed.

Lemma ffact_fact n m : m <= n -> n ^_ m * (n - m)`! = n`!.
Proof.
by elim: n m => [|n IHn] [|m] //= le_m_n; rewrite ?mul1n // -mulnA IHn.
Qed.

Lemma ffact_factd n m : m <= n -> n ^_ m = n`! %/ (n - m)`!.
Proof. by move/ffact_fact <-; rewrite mulnK ?fact_gt0. Qed.

(** Binomial coefficients *)

Fixpoint binomial_rec n m :=
  match n, m with
  | n'.+1, m'.+1 => binomial_rec n' m + binomial_rec n' m'
  | _, 0 => 1
  | 0, _.+1 => 0
  end.

Definition binomial := nosimpl binomial_rec.

Notation "''C' ( n , m )" := (binomial n m)
  (at level 8, format "''C' ( n ,  m )") : nat_scope.

Lemma binE : binomial = binomial_rec. Proof. by []. Qed.

Lemma bin0 n : 'C(n, 0) = 1. Proof. by case: n. Qed.

Lemma bin0n m : 'C(0, m) = (m == 0). Proof. by case: m. Qed.

Lemma binS n m : 'C(n.+1, m.+1) = 'C(n, m.+1) + 'C(n, m). Proof. by []. Qed.

Lemma bin1 n : 'C(n, 1) = n.
Proof. by elim: n => //= n IHn; rewrite binS bin0 IHn addn1. Qed.

Lemma bin_gt0 m n : (0 < 'C(m, n)) = (n <= m).
Proof.
elim: m n => [|m IHm] [|n] //.
by rewrite binS addn_gt0 !IHm orbC ltn_neqAle andKb.
Qed.

Lemma leq_bin2l m1 m2 n : m1 <= m2 -> 'C(m1, n) <= 'C(m2, n).
Proof.
elim: m1 m2 n => [m2 | m1 IHm [|m2] //] [|n] le_m12; rewrite ?bin0 //.
by rewrite !binS leq_add // IHm.
Qed.

Lemma bin_small n m : n < m -> 'C(n, m) = 0.
Proof. by rewrite ltnNge -bin_gt0; case: posnP. Qed.

Lemma binn n : 'C(n, n) = 1.
Proof. by elim: n => [|n IHn] //; rewrite binS bin_small. Qed.

Lemma mul_Sm_binm m n : m.+1 * 'C(m, n) = n.+1 * 'C(m.+1, n.+1).
Proof.
elim: m n => [|m IHm] [|n] //; first by rewrite bin0 bin1 muln1 mul1n.
by rewrite mulSn {2}binS mulnDr addnCA !IHm -mulnDr.
Qed.

Lemma bin_fact m n : n <= m -> 'C(m, n) * (n`! * (m - n)`!) = m`!.
Proof.
move/subnKC; move: (m - n) => m0 <-{m}.
elim: n => [|n IHn]; first by rewrite bin0 !mul1n.
by rewrite -mulnA mulnCA mulnA -mul_Sm_binm -mulnA IHn.
Qed.

(* In fact the only exception is n = 0 and m = 1 *)
Lemma bin_factd n m : 0 < n -> 'C(n, m)  = n`! %/ (m`! * (n - m)`!).
Proof.
move=> n_gt0; have [/bin_fact <-|lt_n_m] := leqP m n.
  by rewrite mulnK // muln_gt0 !fact_gt0.
by rewrite bin_small // divnMA !divn_small ?fact_gt0 // fact_smonotone.
Qed.

Lemma bin_ffact n m : 'C(n, m) * m`! = n ^_ m.
Proof.
apply/eqP; have [lt_n_m | le_m_n] := ltnP n m.
  by rewrite bin_small ?ffact_small.
by rewrite -(eqn_pmul2r (fact_gt0 (n - m))) ffact_fact // -mulnA bin_fact.
Qed.

Lemma bin_ffactd n m : 'C(n, m) = n ^_ m %/ m`!.
Proof. by rewrite -bin_ffact mulnK ?fact_gt0. Qed.

Lemma bin_sub n m : m <= n -> 'C(n, n - m) = 'C(n, m).
Proof.
move=> le_m_n; apply/eqP; move/eqP: (bin_fact (leq_subr m n)).
by rewrite subKn // -(bin_fact le_m_n) !mulnA mulnAC !eqn_pmul2r // fact_gt0.
Qed.

Lemma binSn n : 'C(n.+1, n) = n.+1.
Proof. by rewrite -bin_sub ?leqnSn // subSnn bin1. Qed.

Lemma bin2 n : 'C(n, 2) = (n * n.-1)./2.
Proof.
by case: n => //= n; rewrite -{3}[n]bin1 mul_Sm_binm mul2n half_double.
Qed.

Lemma bin2odd n : odd n -> 'C(n, 2) = n * n.-1./2.
Proof. by case: n => // n oddn; rewrite bin2 -!divn2 muln_divA ?dvdn2. Qed.

Lemma prime_dvd_bin k p : prime p -> 0 < k < p -> p %| 'C(p, k).
Proof.
move=> p_pr /andP[k_gt0 lt_k_p]; have def_p := ltn_predK lt_k_p.
have: p %| p * 'C(p.-1, k.-1) by rewrite dvdn_mulr.
by rewrite -def_p mul_Sm_binm def_p prednK // Euclid_dvdM // gtnNdvd.
Qed.

Lemma triangular_sum n : \sum_(0 <= i < n) i = 'C(n, 2).
Proof.
elim: n => [|n IHn]; first by rewrite big_geq.
by rewrite big_nat_recr // IHn binS bin1.
Qed.

Lemma textbook_triangular_sum n : \sum_(0 <= i < n) i = 'C(n, 2).
Proof.
rewrite bin2; apply: canRL half_double _.
rewrite -addnn {1}big_nat_rev -big_split big_mkord /= ?add0n.
rewrite (eq_bigr (fun _ => n.-1)); first by rewrite sum_nat_const card_ord.
by case: n => [|n] [i le_i_n] //=; rewrite subSS subnK.
Qed.

Theorem Pascal a b n :
  (a + b) ^ n = \sum_(i < n.+1) 'C(n, i) * (a ^ (n - i) * b ^ i).
Proof.
elim: n => [|n IHn]; rewrite big_ord_recl muln1 ?big_ord0 //.
rewrite expnS {}IHn /= mulnDl !big_distrr /= big_ord_recl muln1 subn0.
rewrite !big_ord_recr /= !binn !subnn bin0 !subn0 !mul1n -!expnS -addnA.
congr (_ + _); rewrite addnA -big_split /=; congr (_ + _).
apply: eq_bigr => i _; rewrite mulnCA (mulnA a) -expnS subnSK //=.
by rewrite (mulnC b) -2!mulnA -expnSr -mulnDl.
Qed.
Definition expnDn := Pascal.

Lemma Vandermonde k l i :
  \sum_(j < i.+1) 'C(k, j) * 'C(l, i - j) = 'C(k + l , i).
Proof.
pose f k i := \sum_(j < i.+1) 'C(k, j) * 'C(l, i - j).
suffices{k i} fxx k i: f k.+1 i.+1 = f k i.+1 + f k i.
  elim: k i => [i | k IHk [|i]]; last by rewrite -/(f _ _) fxx /f !IHk -binS.
    by rewrite big_ord_recl big1_eq addn0 mul1n subn0.
  by rewrite big_ord_recl big_ord0 addn0 !bin0 muln1.
rewrite {}/f big_ord_recl (big_ord_recl (i.+1)) !bin0 !mul1n.
rewrite -addnA -big_split /=; congr (_ + _).
by apply: eq_bigr => j _ ; rewrite -mulnDl.
Qed.

Lemma subn_exp m n k :
  m ^ k - n ^ k = (m - n) * (\sum_(i < k) m ^ (k.-1 -i) * n ^ i).
Proof.
case: k => [|k]; first by rewrite big_ord0.
rewrite mulnBl !big_distrr big_ord_recl big_ord_recr /= subn0 muln1.
rewrite subnn mul1n -!expnS subnDA; congr (_ - _); apply: canRL (addnK _) _.
congr (_ + _); apply: eq_bigr => i _.
by rewrite (mulnCA n) -expnS mulnA -expnS subnSK /=.
Qed.

Lemma predn_exp m k : (m ^ k).-1 = m.-1 * (\sum_(i < k) m ^ i).
Proof.
rewrite -!subn1 -{1}(exp1n k) subn_exp; congr (_ * _).
symmetry; rewrite (reindex_inj rev_ord_inj); apply: eq_bigr => i _ /=.
by rewrite -subn1 -subnDA exp1n muln1.
Qed.

Lemma dvdn_pred_predX n e : (n.-1 %| (n ^ e).-1)%N.
Proof. by rewrite predn_exp dvdn_mulr. Qed.

Lemma modn_summ I r (P : pred I) F d :
  \sum_(i <- r | P i) F i %% d = \sum_(i <- r | P i) F i %[mod d].
Proof.
by apply/eqP; elim/big_rec2: _ => // i m n _; rewrite modnDml eqn_modDl.
Qed.

(* Combinatorial characterizations. *)

Section Combinations.

Implicit Types T D : finType.

Lemma card_uniq_tuples T n (A : pred T) :
  #|[set t : n.-tuple T | all A t & uniq t]| = #|A| ^_ n.
Proof.
elim: n A => [|n IHn] A.
  by rewrite (@eq_card1 _ [tuple]) // => t; rewrite [t]tuple0 inE.
rewrite -sum1dep_card (partition_big (@thead _ _) A) /= => [|t]; last first.
  by case/tupleP: t => x t; do 2!case/andP.
transitivity (#|A| * #|A|.-1 ^_ n)%N; last by case: #|A|.
rewrite -sum_nat_const; apply: eq_bigr => x Ax.
rewrite (cardD1 x) [x \in A]Ax /= -(IHn [predD1 A & x]) -sum1dep_card.
rewrite (reindex (fun t : n.-tuple T => [tuple of x :: t])) /=; last first.
  pose ttail (t : n.+1.-tuple T) := [tuple of behead t].
  exists ttail => [t _ | t /andP[_ /eqP <-]]; first exact: val_inj.
  by rewrite -tuple_eta.
apply: eq_bigl=> t; rewrite Ax theadE eqxx andbT /= andbA; congr (_ && _).
by rewrite all_predI all_predC has_pred1 andbC.
Qed.

Lemma card_inj_ffuns_on D T (R : pred T) :
  #|[set f : {ffun D -> T} in ffun_on R | injectiveb f]| = #|R| ^_ #|D|.
Proof.
rewrite -card_uniq_tuples.
have bijFF: {on (_ : pred _), bijective (@Finfun D T)}.
  by exists val => // x _; apply: val_inj.
rewrite -(on_card_preimset (bijFF _)); apply: eq_card => t.
rewrite !inE -(codom_ffun (Finfun t)); congr (_ && _); apply: negb_inj.
by rewrite -has_predC has_map enumT has_filter -size_eq0 -cardE.
Qed.

Lemma card_inj_ffuns D T :
  #|[set f : {ffun D -> T} | injectiveb f]| = #|T| ^_ #|D|.
Proof.
rewrite -card_inj_ffuns_on; apply: eq_card => f.
by rewrite 2!inE; case: ffun_onP => // [].
Qed.

Lemma card_draws T k : #|[set A : {set T} | #|A| == k]| = 'C(#|T|, k).
Proof.
have [ltTk | lekT] := ltnP #|T| k.
  rewrite bin_small // eq_card0 // => A.
  by rewrite inE eqn_leq andbC leqNgt (leq_ltn_trans (max_card _)).
apply/eqP; rewrite -(eqn_pmul2r (fact_gt0 k)) bin_ffact // eq_sym.
rewrite -sum_nat_dep_const -{1 3}(card_ord k) -card_inj_ffuns -sum1dep_card.
pose imIk (f : {ffun 'I_k -> T}) := f @: 'I_k.
rewrite (partition_big imIk (fun A => #|A| == k)) /= => [|f]; last first.
  by move/injectiveP=> inj_f; rewrite card_imset ?card_ord.
apply/eqP; apply: eq_bigr => A /eqP cardAk.
have [f0 inj_f0 im_f0]: exists2 f, injective f & f @: 'I_k = A.
  rewrite -cardAk; exists enum_val; first exact: enum_val_inj.
  apply/setP=> a; apply/imsetP/idP=> [[i _ ->] | Aa]; first exact: enum_valP.
  by exists (enum_rank_in Aa a); rewrite ?enum_rankK_in.
rewrite (reindex (fun p : {ffun _} => [ffun i => f0 (p i)])) /=; last first.
  pose ff0' f i := odflt i [pick j | f i == f0 j].
  exists (fun f => [ffun i => ff0' f i]) => [p _ | f].
    apply/ffunP=> i; rewrite ffunE /ff0'; case: pickP => [j | /(_ (p i))].
      by rewrite ffunE (inj_eq inj_f0) => /eqP.
    by rewrite ffunE eqxx.
  rewrite -im_f0 => /andP[/injectiveP injf /eqP im_f].
  apply/ffunP=> i; rewrite !ffunE /ff0'; case: pickP => [y /eqP //|].
  have /imsetP[j _ eq_f0j_fi]: f i \in f0 @: 'I_k by rewrite -im_f mem_imset.
  by move/(_ j)=> /eqP[].
rewrite -ffactnn -card_inj_ffuns -sum1dep_card; apply: eq_bigl => p.
apply/andP/injectiveP=> [[/injectiveP inj_f0p _] i j eq_pij | inj_p].
  by apply: inj_f0p; rewrite !ffunE eq_pij.
set f := finfun _.
have injf: injective f by move=> i j; rewrite !ffunE => /inj_f0; apply: inj_p.
split; first exact/injectiveP.
rewrite eqEcard card_imset // cardAk card_ord leqnn andbT -im_f0.
by apply/subsetP=> x /imsetP[i _ ->]; rewrite ffunE mem_imset.
Qed.

Lemma card_ltn_sorted_tuples m n :
  #|[set t : m.-tuple 'I_n | sorted ltn (map val t)]| = 'C(n, m).
Proof.
have [-> | n_gt0] := posnP n; last pose i0 := Ordinal n_gt0.
  case: m => [|m]; last by apply: eq_card0; case/tupleP=> [[]].
  by apply: (@eq_card1 _ [tuple]) => t; rewrite [t]tuple0 inE.
rewrite -{12}[n]card_ord -card_draws.
pose f_t (t : m.-tuple 'I_n) := [set i in t].
pose f_A (A : {set 'I_n}) := [tuple of mkseq (nth i0 (enum A)) m].
have val_fA (A : {set 'I_n}) : #|A| = m -> val (f_A A) = enum A.
  by move=> Am; rewrite -[enum _](mkseq_nth i0) -cardE Am.
have inc_A (A : {set 'I_n}) : sorted ltn (map val (enum A)).
  rewrite -[enum _](eq_filter (mem_enum _)).
  rewrite -(eq_filter (mem_map val_inj _)) -filter_map.
  by rewrite (sorted_filter ltn_trans) // unlock val_ord_enum iota_ltn_sorted.
rewrite -!sum1dep_card (reindex_onto f_t f_A) /= => [|A]; last first.
  by move/eqP=> cardAm; apply/setP=> x; rewrite inE -(mem_enum (mem A)) -val_fA.
apply: eq_bigl => t; apply/idP/idP=> [inc_t|]; last first.
  by case/andP; move/eqP=> t_m; move/eqP=> <-; rewrite val_fA.
have ft_m: #|f_t t| = m.
  rewrite cardsE (card_uniqP _) ?size_tuple // -(map_inj_uniq val_inj).
  exact: (sorted_uniq ltn_trans ltnn).
rewrite ft_m eqxx -val_eqE val_fA // -(inj_eq (inj_map val_inj)) /=.
apply/eqP; apply: (eq_sorted_irr ltn_trans ltnn) => // y.
by apply/mapP/mapP=> [] [x t_x ->]; exists x; rewrite // mem_enum inE in t_x *.
Qed.

Lemma card_sorted_tuples m n :
  #|[set t : m.-tuple 'I_n.+1 | sorted leq (map val t)]| = 'C(m + n, m).
Proof.
set In1 := 'I_n.+1; pose x0 : In1 := ord0.
have add_mnP (i : 'I_m) (x : In1) : i + x < m + n.
  by rewrite -ltnS -addSn -!addnS leq_add.
pose add_mn t i := Ordinal (add_mnP i (tnth t i)).
pose add_mn_nat (t : m.-tuple In1) i := i + nth x0 t i.
have add_mnC t: val \o add_mn t =1 add_mn_nat t \o val.
  by move=> i; rewrite /= (tnth_nth x0).
pose f_add t := [tuple of map (add_mn t) (ord_tuple m)].
rewrite -card_ltn_sorted_tuples -!sum1dep_card (reindex f_add) /=.
  apply: eq_bigl => t; rewrite -map_comp (eq_map (add_mnC t)) map_comp.
  rewrite enumT unlock val_ord_enum -{1}(drop0 t).
  have [m0 | m_gt0] := posnP m.
    by rewrite {2}m0 /= drop_oversize // size_tuple m0.
  have def_m := subnK m_gt0; rewrite -{2}def_m addn1 /= {1}/add_mn_nat.
  move: 0 (m - 1) def_m => i k; rewrite -{1}(size_tuple t) => def_m.
  rewrite (drop_nth x0) /=; last by rewrite -def_m leq_addl.
  elim: k i (nth x0 t i) def_m => [|k IHk] i x /=.
    by rewrite add0n => ->; rewrite drop_size.
  rewrite addSnnS => def_m; rewrite -addSn leq_add2l -IHk //.
  by rewrite (drop_nth x0) // -def_m leq_addl.
pose sub_mn (t : m.-tuple 'I_(m + n)) i : In1 := inord (tnth t i - i).
exists (fun t => [tuple of map (sub_mn t) (ord_tuple m)]) => [t _ | t].
  apply: eq_from_tnth => i; apply: val_inj.
  by rewrite /sub_mn !(tnth_ord_tuple, tnth_map) addKn inord_val.
rewrite inE /= => inc_t; apply: eq_from_tnth => i; apply: val_inj.
rewrite tnth_map tnth_ord_tuple /= tnth_map tnth_ord_tuple.
suffices [le_i_ti le_ti_ni]: i <= tnth t i /\ tnth t i <= i + n.
  by rewrite /sub_mn inordK ?subnKC // ltnS leq_subLR.
pose y0 := tnth t i; rewrite (tnth_nth y0) -(nth_map _ (val i)) ?size_tuple //.
case def_e: (map _ _) => [|x e] /=; first by rewrite nth_nil ?leq_addr.
rewrite def_e in inc_t; split.
  case: {-2}i; rewrite /= -{1}(size_tuple t) -(size_map val) def_e.
  elim=> //= j IHj lt_j_t; apply: leq_trans (pathP (val i) inc_t _ lt_j_t).
  by rewrite ltnS IHj 1?ltnW.
move: (_ - _) (subnK (valP i)) => k /=.
elim: k {-2}(val i) => /= [|k IHk] j def_m; rewrite -ltnS -addSn.
  by rewrite [j.+1]def_m -def_e (nth_map y0) ?ltn_ord // size_tuple -def_m.
rewrite (leq_trans _ (IHk _ _)) -1?addSnnS //; apply: (pathP _ inc_t).
rewrite -ltnS (leq_trans (leq_addl k _)) // -addSnnS def_m.
by rewrite -(size_tuple t) -(size_map val) def_e.
Qed.

Lemma card_partial_ord_partitions m n :
  #|[set t : m.-tuple 'I_n.+1 | \sum_(i <- t) i <= n]| = 'C(m + n, m).
Proof.
symmetry; set In1 := 'I_n.+1; pose x0 : In1 := ord0.
pose add_mn (i j : In1) : In1 := inord (i + j).
pose f_add (t : m.-tuple In1) := [tuple of scanl add_mn x0 t].
rewrite -card_sorted_tuples -!sum1dep_card (reindex f_add) /=.
  apply: eq_bigl => t; rewrite -[\sum_(i <- t) i]add0n.
  transitivity (path leq x0 (map val (f_add t))) => /=; first by case: map.
  rewrite -{1 2}[0]/(val x0); elim: {t}(val t) (x0) => /= [|x t IHt] s.
    by rewrite big_nil addn0 -ltnS ltn_ord.
  rewrite big_cons addnA IHt /= val_insubd ltnS.
  have [_ | ltn_n_sx] := leqP (s + x) n; first by rewrite leq_addr.
  rewrite -(leq_add2r x) leqNgt (leq_trans (valP x)) //=.
  by rewrite leqNgt (leq_trans ltn_n_sx) ?leq_addr.
pose sub_mn (i j : In1) := Ordinal (leq_ltn_trans (leq_subr i j) (valP j)).
exists (fun t : m.-tuple In1 => [tuple of pairmap sub_mn x0 t]) => /= t inc_t.
  apply: val_inj => /=; have{inc_t}: path leq x0 (map val (f_add t)).
    by move: inc_t; rewrite inE /=; case: map.
  rewrite [map _ _]/=; elim: {t}(val t) (x0) => //= x t IHt s.
  case/andP=> le_s_sx /IHt->; congr (_ :: _); apply: val_inj => /=.
  move: le_s_sx; rewrite val_insubd.
  case le_sx_n: (_ < n.+1); first by rewrite addKn.
  by case: (val s) le_sx_n; rewrite ?ltn_ord.
apply: val_inj => /=; have{inc_t}: path leq x0 (map val t).
  by move: inc_t; rewrite inE /=; case: map.
elim: {t}(val t) (x0) => //= x t IHt s /andP[le_s_sx inc_t].
suffices ->: add_mn s (sub_mn s x) = x by rewrite IHt.
by apply: val_inj; rewrite /add_mn /= subnKC ?inord_val.
Qed.

Lemma card_ord_partitions m n :
  #|[set t : m.+1.-tuple 'I_n.+1 | \sum_(i <- t) i == n]| = 'C(m + n, m).
Proof.
symmetry; set In1 := 'I_n.+1; pose x0 : In1 := ord0.
pose f_add (t : m.-tuple In1) := [tuple of sub_ord (\sum_(x <- t) x) :: t].
rewrite -card_partial_ord_partitions -!sum1dep_card (reindex f_add) /=.
  by apply: eq_bigl => t; rewrite big_cons /= addnC (sameP maxn_idPr eqP) maxnE.
exists (fun t : m.+1.-tuple In1 => [tuple of behead t]) => [t _|].
  exact: val_inj.
case/tupleP=> x t; rewrite inE /= big_cons => /eqP def_n.
by apply: val_inj; congr (_ :: _); apply: val_inj; rewrite /= -{1}def_n addnK.
Qed.

End Combinations.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Sebastien Hinderer, 2004-04-20
- Frederic Blanqui, 2005-02-25
- Adam Koprowski, 2008-01-30

useful definitions and lemmas about integers
*)

Set Implicit Arguments.

From CoLoR Require Import LogicUtil.
From Coq Require Export ZArith.
From Coq Require Import Lia.

(***********************************************************************)
(** decidability of equality *)

Local Open Scope positive_scope.

Fixpoint beq_pos x y :=
  match x, y with
    | xI x', xI y' => beq_pos x' y'
    | xO x', xO y' => beq_pos x' y'
    | xH, xH => true
    | _, _ => false
  end.

Lemma beq_pos_ok : forall x y, beq_pos x y = true <-> x = y.

Proof.
induction x; destruct y; simpl; intros; try (intuition; discr).
rewrite IHx. intuition. subst. refl. inversion H. refl.
rewrite IHx. intuition. subst. refl. inversion H. refl.
Qed.

Local Open Scope Z_scope.

Definition beq_Z x y :=
  match x, y with
    | Z0, Z0 => true
    | Zpos x', Zpos y' => beq_pos x' y'
    | Zneg x', Zneg y' => beq_pos x' y'
    | _, _ => false
  end.

Lemma beq_Z_ok : forall x y, beq_Z x y = true <-> x = y.

Proof.
  intros [] []; simpl; split.
  1-2: reflexivity.
  1-6, 9-14: discriminate.
  all: rewrite beq_pos_ok; intros H; inversion H; reflexivity.
Qed.

(***********************************************************************)
(** simplification *)

Lemma zeql : forall x,
  match x with
    | Z0 => 0
    | Zpos y' => Zpos y'
    | Zneg y' => Zneg y'
  end = x.

Proof. intro. destruct x; refl. Qed.

Lemma zeqr : forall x,
  x = match x with
        | Z0 => 0
        | Zpos y' => Zpos y'
        | Zneg y' => Zneg y'
      end.

Proof. intro. destruct x; refl. Qed.

(***********************************************************************)
(** inequalities *)

Lemma pos_lt : forall x y : Z, 0 <= y-x-1 -> x < y.

Proof. intros. lia. Qed.

Lemma pos_le : forall x y : Z, 0 <= y-x -> x <= y.

Proof. intros. lia. Qed.

(***********************************************************************)
(** power *)

Fixpoint power (x : Z) (n : nat) : Z :=
  match n with
    | O => 1
    | S n' => x * power x n'
  end.

Infix "^" := power.

Lemma power_plus : forall x n1 n2, power x (n1+n2) = power x n1 * power x n2.

Proof. induction n1; intros; simpl. apply zeqr. rewrite IHn1. ring. Qed.

Lemma power_one : forall n, power 1 n = 1.

Proof. induction n; simpl. refl. rewrite IHn. refl. Qed.

Lemma power_succ : forall x n, power x (S n) = x * power x n.

Proof. refl. Qed.

Lemma power_mult : forall x n1 n2, power x (n1*n2) = power (power x n1) n2.

Proof.
induction n1; induction n2; intros. refl. rewrite power_one. refl.
rewrite mult_0_r. refl. rewrite power_succ, <- IHn2, <- mult_n_Sm. simpl.
rewrite !power_plus. simpl. ring.
Qed.

Lemma pos_power : forall x n, 0 <= x -> 0 <= power x n.

Proof.
induction n; intros; simpl. lia. apply Zmult_le_0_compat. hyp.
apply IHn. hyp.
Qed.

Lemma spos_power : forall x n, 0 < x -> 0 < power x n.

Proof.
induction n; intros; simpl. lia. apply Zmult_lt_O_compat. hyp.
apply IHn. hyp.
Qed.

Lemma power_le_compat : forall x y n, 0<=x -> x<=y -> power x n <= power y n.

Proof.
induction n; intros; simpl. lia. apply Zmult_le_compat. hyp.
apply IHn; hyp. hyp. apply pos_power. hyp.
Qed.

(***********************************************************************)
(** positive integers *)

Definition is_pos z :=
  match z with
    | Zpos _ => true
    | _ => false
  end.

Lemma is_pos_ok : forall z, is_pos z = true <-> z > 0.

Proof. destruct z; simpl; intuition; discr. Qed.

(***********************************************************************)
(** non-negative integers *)

Definition is_not_neg z :=
  match z with
    | Zneg _ => false
    | _ => true
  end.

Lemma is_not_neg_ok : forall z, is_not_neg z = true <-> 0 <= z.

Proof. destruct z; simpl; intuition; discr. Qed.

Notation pos := (fun z => 0 <= z).
Notation D := (sig pos).
Notation val := (@proj1_sig Z pos).
Notation inj := (@exist Z pos _).

Lemma Zero_in_D : pos 0.

Proof. simpl. lia. Qed.

Notation D0 := (inj Zero_in_D).

Lemma pos_power_val : forall x n, pos (power (val x) n).

Proof. intros. destruct x. apply pos_power. hyp. Qed.

Definition Dlt x y := Z.lt (val x) (val y).
Definition Dle x y := Z.le (val x) (val y).

From CoLoR Require Import RelUtil.

Definition Dgt := transp Dlt.
Definition Dge := transp Dle.

From Coq Require Import Zwf Wellfounded.

Lemma well_founded_Dlt : well_founded Dlt.

Proof.
unfold Dlt. apply wf_incl with (R2 := (fun x y : D => Zwf 0 (val x) (val y))).
unfold inclusion, Zwf. intros (x,Hx) (y,Hy). simpl. intuition lia.
apply (wf_inverse_image D Z (Zwf 0) val). apply Zwf_well_founded.
Qed.

From CoLoR Require Import SN.

Lemma WF_Dgt : WF Dgt.

Proof. apply wf_transp_WF. apply well_founded_Dlt. Qed.

Lemma power_Dlt_compat : forall x y n,
  Dlt x y -> Dlt (inj (pos_power_val x (S n))) (inj (pos_power_val y (S n))).

Proof.
intros x y. destruct x. destruct y. unfold Dlt. simpl.
induction n; simpl; intros. lia. ded (IHn H).
apply Z.le_lt_trans with (m := x * (x0 * power x0 n)). apply Zmult_le_compat_l.
lia. hyp. apply Zmult_gt_0_lt_compat_r. apply Z.lt_gt.
apply Zmult_lt_O_compat. lia. apply spos_power. lia. hyp.
Qed.

Lemma trans_Dgt : transitive Dgt.

Proof. intros [x hx] [y hy] [z hz]. unfold Dgt, Dlt, transp. simpl. lia. Qed.

Lemma trans_Dge : transitive Dge.

Proof. intros [x hx] [y hy] [z hz]. unfold Dge, Dle, transp. simpl. lia. Qed.

Lemma refl_Dge : reflexive Dge.

Proof. intros [x hs]. unfold Dge, Dle, transp. simpl. refl. Qed.

(***********************************************************************)
(** max *)

Lemma Zmax_gub : forall m n k, m >= k -> n >= k -> Z.max m n >= k.

Proof. intros. apply Z.max_case; hyp. Qed.

Lemma elim_Zmax_l : forall x y z, x <= y -> x <= Z.max y z.

Proof. intros. eapply Z.le_trans. apply H. apply Z.le_max_l. Qed.

Lemma elim_lt_Zmax_l : forall x y z, x < y -> x < Z.max y z.

Proof. intros. eapply Z.lt_le_trans. eexact H. apply Z.le_max_l. Qed.

Lemma elim_Zmax_r : forall x y z, x <= z -> x <= Z.max y z.

Proof. intros. eapply Z.le_trans. apply H. apply Z.le_max_r. Qed.

Lemma elim_lt_Zmax_r : forall x y z, x < z -> x < Z.max y z.

Proof. intros. rewrite Z.max_comm. apply elim_lt_Zmax_l. hyp. Qed.

Lemma Zmax_l : forall x y, x >= y -> Z.max x y = x.

Proof.
intros. unfold Z.max.
destruct (Dcompare_inf (x ?= y)) as [[xy | xy] | xy]; rewrite xy; try refl.
assert (x < y). hyp. lia.
Qed.

Lemma Zmax_r : forall x y, y >= x -> Z.max x y = y.

Proof. intros. rewrite Z.max_comm. apply Zmax_l. hyp. Qed.

Lemma Zmax_ge_compat : forall x y x' y',
  x >= x' -> y >= y' -> Z.max x y >= Z.max x' y'.

Proof.
intros. destruct (Zmax_irreducible_inf x' y'); rewrite e; unfold ge.
rewrite Z.max_comm. apply Z.le_ge. apply elim_Zmax_r. lia.
apply Z.le_ge. apply elim_Zmax_r. lia.
Qed.

Lemma Zmax_gt_compat : forall x y x' y',
  x > x' -> y > y' -> Z.max x y > Z.max x' y'.

Proof.
intros. destruct (Z_ge_dec x y); destruct (Z_ge_dec x' y');
  do 2 first
    [ rewrite Zmax_r; [idtac | lia]
    | rewrite Zmax_l; [idtac | lia]
    | idtac ]; lia.
Qed.

(***********************************************************************)
(** orders *)

Lemma Zge_refl : forall k, k >= k.

Proof. intros. lia. Qed.


(*
 * Unique.v
 * Wolf Honore
 *
 * Defines an interface for a generator of unique values.
 *)

Require Import Le.
Require Import List.
Require Import Max.

Module Type UNIQUE.

  Parameter t : Set.

  Parameter init : list t.
  Parameter new : list t -> list t * t.
  Parameter eq : forall (u1 u2 : t), {u1 = u2} + {u1 <> u2}.

  Definition is_unique (us : list t) : Prop := NoDup us.

  Hypothesis init_unique : is_unique init.

  Hypothesis new_spec : forall u us us',
    is_unique us ->
    new us = (us', u) ->
    In u us' /\ is_unique us'.

End UNIQUE.

Module NatUnique <: UNIQUE.

  Definition t := nat.

  Definition maximum (us : list t) := fold_right max 0 us.

  Definition init := @nil t.

  Definition new (us : list t) :=
    let u := S (maximum us) in
    (u :: us, u).

  Definition eq : forall (u1 u2 : t), {u1 = u2} + {u1 <> u2}.
    decide equality.
  Defined.

  Definition is_unique (us : list t) : Prop := NoDup us.

  Lemma maximum_ge : forall u us,
    In u us -> u <= maximum us.
  Proof.
    induction us; intros; inversion H; subst; simpl.
    - destruct (max_dec u (maximum us)); rewrite e.
      + constructor.
      + rewrite <- e. apply le_max_l.
    - apply IHus in H0.
      destruct (max_dec a (maximum us)); rewrite e.
      + assert (maximum us <= a).
        { rewrite <- e. apply le_max_r. }
        apply le_trans with (m := maximum us); assumption.
      + assumption.
  Qed.

  Lemma init_unique : is_unique init.
  Proof. constructor. Qed.

  Lemma new_spec : forall u us us',
    is_unique us ->
    new us = (us', u) ->
    In u us' /\ is_unique us'.
  Proof.
    unfold new, is_unique; intros.
    inversion H0; subst.
    split.
    - simpl; left; reflexivity.
    - destruct us.
      + constructor; auto.
      + constructor; [| assumption].
        unfold not; intros.
        apply maximum_ge in H1.
        apply le_Sn_n in H1; assumption.
  Qed.

End NatUnique.


Require Import prosa.util.ssromega prosa.util.tactics.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

(** We define a few simple operations on
    lists. Namely first, last, and max. *)
Definition max0 := foldl maxn 0.
Definition first0 := head 0.
Definition last0 := last 0.

(** Additional lemmas about last0. *)
Section Last0.

  (** Let [xs] be a non-empty sequence and [x] be an arbitrary element,
     then we prove that [last0 (x::xs) = last0 xs]. *)
  Lemma last0_cons:
    forall x xs,
      xs <> [::] ->
      last0 (x::xs) = last0 xs.
  Proof.
    induction xs; first by done.
    intros ?; by unfold last0.
  Qed.

  (** Similarly, let [xs_r] be a non-empty sequence and [xs_l] be an sequence,
     we prove that [last0 (xs_l ++ xs_r) = last0 xs_r]. *)
  Lemma last0_cat:
    forall xs_l xs_r,
      xs_r <> [::] ->
      last0 (xs_l ++ xs_r) = last0 xs_r.
  Proof.
    clear; induction xs_l; intros ? NEQ.
    - by done.
    - simpl; rewrite last0_cons.
      apply IHxs_l; by done.
      intros C; apply: NEQ.
        by destruct xs_l.
  Qed.

  (** We also prove that [last0 xs = xs [| size xs -1 |] ]. *)
  Lemma last0_nth:
    forall xs,
      last0 xs = nth 0 xs (size xs).-1.
  Proof. by intros; rewrite nth_last. Qed.

  (** We prove that for any non-empty sequence [xs] there is a sequence [xsh]
      such that [xsh ++ [::last0 x] = [xs]]. *)
  Lemma last0_ex_cat:
    forall x xs,
      xs <> [::] ->
      last0 xs = x ->
      exists xsh, xsh ++ [::x] = xs.
  Proof.
    clear; intros ? ? NEQ LAST.
    induction xs; first by done.
    destruct xs.
    - exists [::]; by compute in LAST; subst a.
    - feed_n 2 IHxs; try by done.
      destruct IHxs as [xsh EQ].
      exists (a::xsh).
        by simpl; rewrite EQ.
  Qed.

  (** We prove that if [x] is the last element of a sequence [xs] and
      [x] satisfies a predicate, then [x] remains the last element in
      the filtered sequence. *)
  Lemma last0_filter:
    forall x xs (P : nat -> bool),
      xs <> [::] ->
      last0 xs = x ->
      P x ->
      last0 [seq x <- xs | P x] = x.
  Proof.
    clear; intros ? ? ? NEQ LAST PX.
    destruct (last0_ex_cat x xs NEQ LAST) as [xsh EQ]; subst xs.
    rewrite filter_cat last0_cat.
    all:rewrite //= PX //=.
  Qed.

End Last0.

(** Additional lemmas about max0. *)
Section Max0.

  (** We prove that [max0 (x::xs)] is equal to [max {x, max0 xs}]. *)
  Lemma max0_cons: forall x xs, max0 (x :: xs) = maxn x (max0 xs).
  Proof.
    have L: forall s x xs, foldl maxn s (x::xs) = maxn x (foldl maxn s xs).
    { clear; intros.
      generalize dependent s; generalize dependent x.
      induction xs.
      { by intros; rewrite maxnC. }
      { intros; simpl in *.
          by rewrite maxnC IHxs [maxn s a]maxnC IHxs maxnA [maxn s x]maxnC.
      }
    }
      by intros; unfold max; apply L.
  Qed.

  (** Next, we prove that if all the numbers of a seq [xs] are equal to
     a constant [k], then [max0 xs = k]. *)
  Lemma max0_of_uniform_set:
    forall k xs,
      size xs > 0 ->
      (forall x, x \in xs -> x = k) ->
      max0 xs = k.
  Proof.
    clear; intros ? ? SIZE ALL.
    induction xs; first by done.
    destruct xs. unfold max0; simpl; rewrite max0n; apply ALL. by rewrite in_cons; apply/orP; left.
    rewrite max0_cons.
    rewrite IHxs.
    - by rewrite [a]ALL; [ rewrite maxnn | rewrite in_cons; apply/orP; left].
    - by done.
    - intros; apply ALL.
      move: H; rewrite in_cons; move => /orP [/eqP EQ | IN].
      + by subst x; rewrite !in_cons; apply/orP; right; apply/orP; left.
      + by rewrite !in_cons; apply/orP; right; apply/orP; right.
  Qed.

  (** We prove that no element in a sequence [xs] is greater than [max0 xs]. *)
  Lemma in_max0_le:
    forall xs x, x \in xs -> x <= max0 xs.
  Proof.
    induction xs; first by intros ?.
    intros x; rewrite in_cons; move => /orP [/eqP EQ | IN]; subst.
    - by rewrite !max0_cons leq_maxl.
    - apply leq_trans with (max0 xs); first eauto.
      rewrite max0_cons.
        by apply leq_maxr.
  Qed.

  (** We prove that for a non-empty sequence [xs], [max0 xs ∈ xs]. *)
  Lemma max0_in_seq:
    forall xs,
      xs <> [::] ->
      max0 xs \in xs.
  Proof.
    clear; induction xs; first by done.
    intros _; destruct xs.
    - destruct a; simpl. by done. by rewrite /max0 //= max0n in_cons eq_refl.
    - rewrite max0_cons.
      move: (leq_total a (max0 (n::xs))) => /orP [LE|LE].
      + rewrite maxnE subnKC // in_cons; apply/orP; right. apply IHxs. by done.
      + rewrite maxnE. move: LE; rewrite -subn_eq0; move => /eqP EQ; rewrite EQ addn0.
          by rewrite in_cons; apply/orP; left.
  Qed.

  (** Next we prove that one can remove duplicating element from the
      head of a sequence. *)
  Lemma max0_2cons_eq:
    forall x xs,
      max0 (x::x::xs) = max0 (x::xs).
  Proof.
    intros; rewrite !max0_cons.
      by rewrite maxnA maxnn.
  Qed.

  (** We prove that one can remove the first element of a sequence if
      it is not greater than the second element of this sequence. *)
  Lemma max0_2cons_le:
    forall x1 x2 xs,
      x1 <= x2 ->
      max0 (x1::x2::xs) = max0 (x2::xs).
  Proof.
    intros; rewrite !max0_cons.
    rewrite maxnA.
    rewrite [maxn x1 x2]maxnE subnKC //.
  Qed.

  (** We prove that [max0] of a sequence [xs]
      is equal to [max0] of sequence [xs] without 0s. *)
  Lemma max0_rem0:
    forall xs,
      max0 ([seq x <- xs | 0 < x]) = max0 xs.
  Proof.
    induction xs; first by done.
    simpl; destruct a; simpl.
    - by rewrite max0_cons max0n.
    - by rewrite !max0_cons IHxs.
  Qed.

  (** Note that the last element is at most the max element. *)
  Lemma last_of_seq_le_max_of_seq:
    forall xs, last0 xs <= max0 xs.
  Proof.
    intros xs.
    have EX: exists len, size xs <= len.
    { exists (size xs). by done. }
    move: EX => [len LE].
    generalize dependent xs.
    induction len.
    { by intros; move: LE; rewrite leqn0 size_eq0; move => /eqP EQ; subst. }
    intros ? SIZE.
    move: SIZE; rewrite leq_eqVlt; move => /orP [/eqP EQ| LE]; last first.
    { by apply IHlen. }
    destruct xs as [ | x1 xs]; first by inversion EQ.
    destruct xs as [ | x2 xs]. by rewrite /max leq_max; apply/orP; right.
    have F1: last0 [:: x1, x2 & xs] = last0 [:: x2 & xs] by done.
    rewrite F1 max0_cons; clear F1.
    rewrite leq_max; apply/orP; right.
    apply IHlen.
    move: EQ => /eqP; simpl; rewrite eqSS; move => /eqP EQ.
      by subst.
  Qed.

  (** Let's introduce the notion of the nth element of a sequence. *)
  Notation "xs [| n |]" := (nth 0 xs n) (at level 30).

  (** If any element of a sequence [xs] is less-than-or-equal-to
      the corresponding element of a sequence [ys], then max of
      [xs] is less-than-or-equal-to max of [ys]. *)
  Lemma max_of_dominating_seq:
    forall (xs ys : seq nat),
      (forall n, xs[|n|] <= ys[|n|]) ->
      max0 xs <= max0 ys.
  Proof.
    intros xs ys.
    have EX: exists len, size xs <= len /\ size ys <= len.
    { exists (maxn (size xs) (size ys)).
        by split; rewrite leq_max; apply/orP; [left | right].
    }
    move: EX => [len [LE1 LE2]].
    generalize dependent xs; generalize dependent ys.
    induction len; intros.
    { by move: LE1 LE2; rewrite !leqn0 !size_eq0; move => /eqP E1 /eqP E2; subst. }
    { destruct xs, ys; try done.
      { have L: forall xs, (forall n, xs [| n |] = 0) -> max0 xs = 0.
        { clear; intros.
          induction xs; first by done.
          rewrite max0_cons.
          apply/eqP; rewrite eqn_leq; apply/andP; split; last by done.
          rewrite geq_max; apply/andP; split.
          - by specialize (H 0); simpl in H; rewrite H.
          - rewrite leqn0; apply/eqP; apply: IHxs.
              by intros; specialize (H n.+1); simpl in H.
        }
        rewrite L; first by done.
        intros; specialize (H n0).
          by destruct n0; simpl in *; apply/eqP; rewrite -leqn0.
      }
      { rewrite !max0_cons.
        rewrite geq_max; apply/andP; split.
        + rewrite leq_max; apply/orP; left.
            by specialize (H 0); simpl in H.
        + rewrite leq_max; apply/orP; right.
          apply IHlen; try (by rewrite ltnS in LE1, LE2).
            by intros; specialize (H n1.+1); simpl in H.
      }
    }
  Qed.

End Max0.

(* Additional lemmas about rem for lists. *)
Section RemList.

  (* We prove that if [x] lies in [xs] excluding [y], then [x] also lies in [xs]. *)
  Lemma rem_in:
    forall (T: eqType) (x y: T) (xs: seq T),
      x \in rem y xs -> x \in xs.
  Proof.
    clear; intros.
    induction xs; simpl in H.
    { by rewrite in_nil in H. }
    { rewrite in_cons; apply/orP.
      destruct (a == y) eqn:EQ.
      { by move: EQ => /eqP EQ; subst a; right. }
      { move: H; rewrite in_cons; move => /orP [/eqP H | H].
        - by subst a; left.
        - by right; apply IHxs.
      }
    }
  Qed.

  (* We prove that if we remove an element [x] for which [P x] from
     a filter, then the size of the filter decreases by [1]. *)
  Lemma filter_size_rem:
    forall (T: eqType) (x:T) (xs: seq T) (P: T -> bool),
      (x \in xs) ->
      P x ->
      size [seq y <- xs | P y] = size [seq y <- rem x xs | P y] + 1.
  Proof.
    clear; intros.
    induction xs; first by inversion H.
    move: H; rewrite in_cons; move => /orP [/eqP H | H]; subst.
    { by simpl; rewrite H0 -[X in X = _]addn1 eq_refl. }
    { specialize (IHxs H); simpl in *.
      case EQab: (a == x); simpl.
      { move: EQab => /eqP EQab; subst.
          by rewrite H0 addn1. }
      { case Pa: (P a); simpl.
        - by rewrite IHxs !addn1.
        - by rewrite IHxs.
      }
    }
  Qed.

End RemList.

(* Additional lemmas about sequences. *)
Section AdditionalLemmas.

  (* First, we show that if [n > 0], then [nth (x::xs) n = nth xs (n-1)]. *)
  Lemma nth0_cons:
    forall x xs n,
      n > 0 ->
      nth 0 (x :: xs) n = nth 0 xs n.-1.
  Proof. by intros; destruct n. Qed.

  (* We prove that a sequence [xs] of size [n.+1] can be destructed
     into a sequence [xs_l] of size [n] and an element [x] such that
     [x = xs ++ [::x]]. *)
  Lemma seq_elim_last:
    forall {X : Type} (n : nat) (xs : seq X),
      size xs = n.+1 ->
      exists x xs__c, xs = xs__c ++ [:: x] /\ size xs__c = n.
  Proof.
    intros ? ? ? SIZE.
    revert xs SIZE; induction n; intros.
    - destruct xs; first by done.
      destruct xs; last by done.
      exists x, [::]; split; by done.
    - destruct xs; first by done.
      specialize (IHn xs).
      feed IHn; first by simpl in SIZE; apply eq_add_S in SIZE.
      destruct IHn as [x__n [xs__n [EQ__n SIZE__n]]].
      subst xs.
      exists x__n, (x :: xs__n); split; first by done.
      simpl in SIZE; apply eq_add_S in SIZE.
      rewrite size_cat in SIZE; simpl in SIZE; rewrite addn1 in SIZE; apply eq_add_S in SIZE.
        by apply eq_S.
  Qed.

  (* Next, we prove that [x ∈ xs] implies that [xs] can be split
     into two parts such that [xs = xsl ++ [::x] ++ [xsr]]. *)
  Lemma in_cat:
    forall {X : eqType} (x : X) (xs : list X),
      x \in xs -> exists xsl xsr, xs = xsl ++ [::x] ++ xsr.
  Proof.
    intros ? ? ? SUB.
    induction xs; first by done.
    move: SUB; rewrite in_cons; move => /orP [/eqP EQ|IN].
    - by subst; exists [::], xs.
    - feed IHxs; first by done.
      clear IN; move: IHxs => [xsl [xsr EQ]].
        by subst; exists (a::xsl), xsr.
  Qed.

  (* We prove that for any two sequences [xs] and [ys] the fact that [xs] is a sub-sequence
     of [ys] implies that the size of [xs] is at most the size of [ys]. *)
  Lemma subseq_leq_size:
    forall {X : eqType} (xs ys: seq X),
      uniq xs ->
      (forall x, x \in xs -> x \in ys) ->
      size xs <= size ys.
  Proof.
    clear; intros ? ? ? UNIQ SUB.
    have EXm: exists m, size ys <= m; first by exists (size ys).
    move: EXm => [m SIZEm].
    move: SIZEm UNIQ SUB; move: xs ys.
    induction m; intros.
    { move: SIZEm; rewrite leqn0 size_eq0; move => /eqP SIZEm; subst ys.
      destruct xs; first by done.
      specialize (SUB s).
        by feed SUB; [rewrite in_cons; apply/orP; left | done].
    }
    { destruct xs as [ | x xs]; first by done.
      move: (@in_cat _ x ys) => Lem.
      feed Lem; first by apply SUB; rewrite in_cons; apply/orP; left.
      move: Lem => [ysl [ysr EQ]]; subst ys.
      rewrite !size_cat; simpl; rewrite -addnC add1n addSn ltnS -size_cat.
      eapply IHm.
      - move: SIZEm; rewrite !size_cat; simpl; move => SIZE.
          by rewrite add1n addnS ltnS addnC in SIZE.
      - by move: UNIQ; rewrite cons_uniq; move => /andP [_ UNIQ].
      - intros a IN.
        destruct (a == x) eqn: EQ.
        { exfalso.
          move: EQ UNIQ; rewrite cons_uniq; move => /eqP EQ /andP [NIN UNIQ].
            by subst; move: NIN => /negP NIN; apply: NIN.
        }
        { specialize (SUB a).
          feed SUB; first by rewrite in_cons; apply/orP; right.
          clear IN; move: SUB; rewrite !mem_cat; move => /orP [IN| /orP [IN|IN]].
          - by apply/orP; right.
          - exfalso.
              by  move: IN; rewrite in_cons; move => /orP [IN|IN]; [rewrite IN in EQ | ].
          - by apply/orP; left.
        }
    }
  Qed.

  (* We prove that if no element of a sequence [xs] satisfies
     a predicate [P], then [filter P xs] is equal to an empty
     sequence. *)
  Lemma filter_in_pred0:
    forall {X : eqType} (xs : seq X) P,
      (forall x, x \in xs -> ~~ P x) ->
      filter P xs = [::].
  Proof.
    intros X xs P F.
    induction xs.
    - by done.
    - simpl; rewrite IHxs; last first.
      + intros; apply F.
          by rewrite in_cons; apply/orP; right.
      + destruct (P a) eqn:EQ; last by done.
        move: EQ => /eqP; rewrite eqb_id -[P a]Bool.negb_involutive; move => /negP T.
        exfalso; apply: T.
          by apply F; apply/orP; left.
  Qed.

End AdditionalLemmas.

(** Function [rem] from [ssreflect] removes only the first occurrence of
    an element in a sequence.  We define function [rem_all] which
    removes all occurrences of an element in a sequence. *)
Fixpoint rem_all {X : eqType} (x : X) (xs : seq X) :=
  match xs with
  | [::] => [::]
  | a :: xs =>
    if a == x then rem_all x xs else a :: rem_all x xs
  end.

(** Additional lemmas about [rem_all] for lists. *)
Section RemAllList.

  (** First we prove that [x ∉ rem_all x xs]. *)
  Lemma nin_rem_all:
    forall {X : eqType} (x : X) (xs : seq X),
      ~ (x \in rem_all x xs).
  Proof.
    intros ? ? ? IN.
    induction xs.
    - by simpl in IN.
    - apply IHxs.
      simpl in IN.
      destruct (a == x) eqn:EQ; first by done.
      move: IN; rewrite in_cons; move => /orP [/eqP EQ2 | IN]; last by done.
      subst; exfalso.
        by rewrite eq_refl in EQ.
  Qed.

  (** Next we show that [rem_all x xs ⊆ xs].  *)
  Lemma in_rem_all:
    forall {X : eqType} (a x : X) (xs : seq X),
      a \in rem_all x xs -> a \in xs.
  Proof.
    intros X a x xs IN.
    induction xs.
    - by done.
    - simpl in IN.
      destruct (a0 == x) eqn:EQ.
      + by rewrite in_cons; apply/orP; right; eauto.
      + move: IN; rewrite in_cons; move => /orP [EQ2|IN].
        * by rewrite in_cons; apply/orP; left.
        * by rewrite in_cons; apply/orP; right; auto.
  Qed.

  (** If an element [x1] is smaller than any element of
      a sequence [xs], then [rem_all x xs = xs]. *)
  Lemma rem_lt_id:
    forall x xs,
      (forall y, y \in xs -> x < y) ->
      rem_all x xs = xs.
  Proof.
    intros ? ? MIN; induction xs.
    - by simpl.
    - simpl.
      have -> : (a == x) = false.
      { apply/eqP/eqP; rewrite neq_ltn; apply/orP; right.
          by apply MIN; rewrite in_cons; apply/orP; left.
      }
      rewrite IHxs //.
      intros; apply: MIN.
        by rewrite in_cons; apply/orP; right.
  Qed.

End RemAllList.

(** To have a more intuitive naming, we introduce the definition of
    [range a b] which is equal to [index_iota a b.+1]. *)
Definition range (a b : nat) := index_iota a b.+1.

(** Additional lemmas about [index_iota] and [range] for lists. *)
Section IotaRange.

  (** First we prove that [index_iota a b = a :: index_iota a.+1 b]
      for [a < b]. *)
  Remark index_iota_lt_step:
    forall a b,
      a < b ->
      index_iota a b = a :: index_iota a.+1 b.
  Proof.
    intros ? ? LT; unfold index_iota.
    destruct b; first by done.
    rewrite ltnS in LT.
      by rewrite subSn //.
  Qed.

  (** We prove that one can remove duplicating element from the
      head of a sequence by which [range] is filtered. *)
  Lemma range_filter_2cons:
    forall x xs k,
      [seq ρ <- range 0 k | ρ \in x :: x :: xs] =
      [seq ρ <- range 0 k | ρ \in x :: xs].
  Proof.
    intros.
    apply eq_filter; intros ?.
    repeat rewrite in_cons.
      by destruct (x0 == x), (x0 \in xs).
  Qed.

  (** Consider [a], [b], and [x] s.t. [a ≤ x < b],
      then filter of [iota_index a b] with predicate
      [(? == x)] yields [::x]. *)
  Lemma index_iota_filter_eqx:
    forall x a b,
      a <= x < b ->
      [seq ρ <- index_iota a b | ρ == x] = [::x].
  Proof.
    intros ? ? ?.
    have EX : exists k, b - a <= k.
    { exists (b-a); now simpl. } destruct EX as [k BO].
    revert x a b BO.
    induction k.
    { move => x a b BO /andP [GE LT]; exfalso.
      move: BO; rewrite leqn0 subn_eq0; move => BO.
        by ssromega.
    }
    { move => x a b BO /andP [GE LT].
      destruct a.
      { destruct b; first by done.
        rewrite index_iota_lt_step //; simpl.
        destruct (0 == x) eqn:EQ.
        - move: EQ => /eqP EQ; subst x.
          rewrite filter_in_pred0 //.
            by intros x; rewrite mem_index_iota -lt0n; move => /andP [T1 _].
        - by apply IHk; ssromega.
      }
      rewrite index_iota_lt_step; last by ssromega.
      simpl; destruct (a.+1 == x) eqn:EQ.
      - move: EQ => /eqP EQ; subst x.
        rewrite filter_in_pred0 //.
        intros x; rewrite mem_index_iota; move => /andP [T1 _].
          by rewrite neq_ltn; apply/orP; right.
      - by rewrite IHk //; ssromega.
    }
  Qed.

  (** As a corollary we prove that filter of [iota_index a b]
      with predicate [(_ ∈ [::x])] yields [::x]. *)
  Corollary index_iota_filter_singl:
    forall x a b,
      a <= x < b ->
      [seq ρ <- index_iota a b | ρ \in [:: x]] = [::x].
  Proof.
    intros ? ? ? NEQ.
    rewrite -{2}(index_iota_filter_eqx _ a b) //.
    apply eq_filter; intros ?.
      by repeat rewrite in_cons; rewrite in_nil Bool.orb_false_r.
  Qed.

  (** Next we prove that if an element [x] is not in a sequence [xs],
      then [iota_index a b] filtered with predicate [(_ ∈ xs)] is
      equal to [iota_index a b] filtered with predicate [(_ ∈ rem_all
      x xs)]. *)
  Lemma index_iota_filter_inxs:
    forall a b x xs,
      x < a ->
      [seq ρ <- index_iota a b | ρ \in xs] =
      [seq ρ <- index_iota a b | ρ \in rem_all x xs].
  Proof.
    intros a b x xs LT.
    apply eq_in_filter.
    intros y; rewrite mem_index_iota; move => /andP [LE GT].
    induction xs as [ | y' xs]; first by done.
    rewrite in_cons IHxs; simpl; clear IHxs.
    destruct (y == y') eqn:EQ1, (y' == x) eqn:EQ2; auto.
    - exfalso.
      move: EQ1 EQ2 => /eqP EQ1 /eqP EQ2; subst.
        by ssromega.
    - move: EQ1 => /eqP EQ1; subst.
        by rewrite in_cons eq_refl.
    - by rewrite in_cons EQ1.
  Qed.

  (** We prove that if an element [x] is a min of a sequence [xs],
      then [iota_index a b] filtered with predicate [(_ ∈ x::xs)] is
      equal to [x :: iota_index a b] filtered with predicate [(_ ∈
      rem_all x xs)]. *)
  Lemma index_iota_filter_step:
    forall x xs a b,
      a <= x < b ->
      (forall y, y \in xs -> x <= y) ->
      [seq ρ <- index_iota a b | ρ \in x :: xs] =
      x :: [seq ρ <- index_iota a b | ρ \in rem_all x xs].
  Proof.
    intros x xs a b B MIN.
    have EX : exists k, b - a <= k.
    { exists (b-a); now simpl. } destruct EX as [k BO].
    revert x xs a b B MIN BO.
    induction k; move => x xs a b /andP [LE GT] MIN BO.
    - by move_neq_down BO; ssromega.
    - move: LE; rewrite leq_eqVlt; move => /orP [/eqP EQ|LT].
      + subst.
        rewrite index_iota_lt_step //.
        replace ([seq ρ <- x :: index_iota x.+1 b | ρ \in x :: xs])
          with (x :: [seq ρ <- index_iota x.+1 b | ρ \in x :: xs]); last first.
        { simpl; replace (@in_mem nat x (@mem nat (seq_predType nat_eqType) (x::xs))) with true.
          all: by auto; rewrite in_cons eq_refl.
        }
        rewrite (index_iota_filter_inxs _ _ x) //; simpl.
        rewrite eq_refl.
        replace (@in_mem nat x (@mem nat (seq_predType nat_eqType) (@rem_all nat_eqType x xs))) with false; last first.
        apply/eqP; rewrite eq_sym eqbF_neg. apply/negP; apply nin_rem_all.
        reflexivity.
      + rewrite index_iota_lt_step //; last by ssromega.
        replace ([seq ρ <- a :: index_iota a.+1 b | ρ \in x :: xs])
          with ([seq ρ <- index_iota a.+1 b | ρ \in x :: xs]); last first.
        { simpl; replace (@in_mem nat a (@mem nat (seq_predType nat_eqType) (@cons nat x xs))) with false; first by done.
          apply/eqP; rewrite eq_sym eqbF_neg.
          apply/negP; rewrite in_cons; intros C; move: C => /orP [/eqP C|C].
          - by subst; rewrite ltnn in LT.
          - by move_neq_down LT; apply MIN.
        }
        replace ([seq ρ <- a :: index_iota a.+1 b | ρ \in rem_all x xs])
          with ([seq ρ <- index_iota a.+1 b | ρ \in rem_all x xs]); last first.
        { simpl; replace (@in_mem nat a (@mem nat (seq_predType nat_eqType) (@rem_all nat_eqType x xs))) with false; first by done.
          apply/eqP; rewrite eq_sym eqbF_neg; apply/negP; intros C.
          apply in_rem_all in C.
            by move_neq_down LT; apply MIN.
        }
          by rewrite IHk //; ssromega.
  Qed.

  (** For convenience, we define a special case of
      lemma [index_iota_filter_step] for [a = 0] and [b = k.+1]. *)
  Corollary range_iota_filter_step:
    forall x xs k,
      x <= k ->
      (forall y, y \in xs -> x <= y) ->
      [seq ρ <- range 0 k | ρ \in x :: xs] =
      x :: [seq ρ <- range 0 k | ρ \in rem_all x xs].
  Proof.
    intros x xs k LE MIN.
      by apply index_iota_filter_step; auto.
  Qed.

  (** We prove that if [x < a], then [x < (filter P (index_iota a
      b))[idx]] for any predicate [P]. *)
  Lemma iota_filter_gt:
    forall x a b idx P,
      x < a ->
      idx < size ([seq x <- index_iota a b | P x]) ->
      x < nth 0 [seq x <- index_iota a b | P x] idx.
  Proof.
    clear; intros ? ? ? ? ?.
    have EX : exists k, b - a <= k.
    { exists (b-a); now simpl. } destruct EX as [k BO].
    revert x a b idx P BO; induction k.
    - move => x a b idx P BO LT1 LT2.
      move: BO; rewrite leqn0; move => /eqP BO.
        by rewrite /index_iota BO in LT2; simpl in LT2.
    - move => x a b idx P BO LT1 LT2.
      case: (leqP b a) => [N|N].
      + move: N; rewrite -subn_eq0; move => /eqP EQ.
          by rewrite /index_iota EQ //= in LT2.
      + rewrite index_iota_lt_step; last by done.
        simpl in *; destruct (P a) eqn:PA.
        * destruct idx; simpl; first by done.
          apply IHk; try ssromega.
            by rewrite index_iota_lt_step // //= PA //= in LT2.
        * apply IHk; try ssromega.
            by rewrite index_iota_lt_step // //= PA //= in LT2.
  Qed.

End IotaRange.


Require Export XR_R.
Require Export XR_Rlt.
Require Export XR_Rle.
Require Export XR_Rtotal_order.

Implicit Type r : R.
Local Open Scope R_scope.

Lemma Rlt_or_le : forall r1 r2, r1 < r2 \/ r2 <= r1.
Proof.
intros x y.
destruct (Rtotal_order x y) as [ hxy | [ heq | hyx ] ].
{ left. exact hxy. }
{ subst y. right. unfold "<=". right. reflexivity. }
{ right. unfold "<=". left. exact hyx. }
Qed.


From mathcomp Require Import ssreflect.
Require Import collect_operator.
Require Import direct_product.
Require Import mapping.
Require Import inverse_mapping.

Definition InjectionGraph {U:Type} (F:TypeOfDirectProduct U) :=
  forall (x x' y:U), <|x,y|> ∈ F /\ <|x',y|> ∈ F -> x = x'.

Definition SurjectionGraph {U:Type} (F:TypeOfDirectProduct U) (R:Collection U) :=
  forall (y:U), y ∈ R -> exists x:U, <|x,y|> ∈ F.

Definition BijectionGraph {U:Type} (F:TypeOfDirectProduct U) (R:Collection U) :=
  InjectionGraph F /\ SurjectionGraph F R.

Section MappingMorphism.
  Variable U:Type.

  Theorem not_injection_graph:
    forall (f:U -> U) (X Y:Collection U) (F:TypeOfDirectProduct U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      ~ InjectionGraph F -> exists x x' y:U, x <> x' /\ <|x,y|> ∈ F /\ <|x',y|> ∈ F.
  Proof.
    move => f X Y F Hf HF HNIF.
    unfold InjectionGraph in HNIF.
    apply (DeMorganNotForall_Triple_Open) in HNIF.
    case HNIF => [x [x' [y H]]].
    apply not_imply_to_and in H.
    apply and_comm in H.
    exists x.
    exists x'.
    exists y.
    trivial.
  Qed.

  Theorem compound_injection_graph_is_injection_graph:
    forall (f g:U -> U) (X Y Z:Collection U) (F G:TypeOfDirectProduct U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      InjectionGraph F ->
      MappingFunction g Y Z ->
      G = GraphOfFunction g Y Z ->
      InjectionGraph G ->
      InjectionGraph (G ⊙ F).
  Proof.
    move => f g X Y Z F G Hf HF HFI Hg HG HGI.
    move => x x' z [H0 H1].
    inversion H0 as [Z0 [x0 [z0 [HZ0 HC0]]]].
    inversion HC0 as [y0 [HF0 HG0]].
    inversion H1 as [Z1 [x1 [z1 [HZ1 HC1]]]].
    inversion HC1 as [y1 [HF1 HG1]].
    apply ordered_pair_to_and in HZ0.
    inversion HZ0 as [HZ00 HZ01].
    apply ordered_pair_to_and in HZ1.
    inversion HZ1 as [HZ10 HZ11].
    rewrite -HZ00 in HF0.
    rewrite -HZ10 in HF1.
    rewrite -HZ01 in HG0.
    rewrite -HZ11 in HG1.
    suff: y0 = y1.
    move => H'.
    rewrite -H' in HF1.
    apply (HFI x x' y0).
    split; trivial.
    apply (HGI y0 y1 z).
    split; trivial.
  Qed.

  Theorem compound_surjection_graph_is_surjection_graph:
    forall (f g:U -> U) (X Y Z:Collection U) (F G:TypeOfDirectProduct U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      SurjectionGraph F Y ->
      MappingFunction g Y Z ->
      G = GraphOfFunction g Y Z ->
      SurjectionGraph G Z ->
      SurjectionGraph (G ⊙ F) Z.
  Proof.
    move => f g X Y Z F G Hf HF HFS Hg HG HGS z HzZ.
    apply HGS in HzZ.
    inversion HzZ as [y HZG].
    rewrite HG in HZG.
    inversion HZG as [YZ' [y0 [z0 [HYZ [Hzgy]]]]].
    apply ordered_pair_in_direct_product_iff_in_and in H.
    inversion H.
    apply HFS in H1.
    inversion H1 as [x].
    exists x.
    split.
    exists x.
    exists z.
    split.
    reflexivity.
    exists y0.
    split.
    trivial.
    rewrite H0 in HYZ.
    apply ordered_pair_to_and in HYZ.
    inversion HYZ.
    rewrite H5.
    rewrite HG.
    split.
    exists y0.
    exists z0.
    split.
    reflexivity.
    split.
    trivial.
    apply ordered_pair_in_direct_product_iff_in_and.
    assumption.
  Qed.

  Theorem compound_graph_is_injection_to_source_graph_is_injection:
    forall (f g:U -> U) (X Y Z:Collection U) (F G:TypeOfDirectProduct U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      MappingFunction g Y Z ->
      G = GraphOfFunction g Y Z ->
      InjectionGraph (G ⊙ F) ->
      InjectionGraph F.
  Proof.
    move => f g X Y Z F G Hf HF Hg HG HGFI x x' y [HF0 HF1].
    unfold InjectionGraph in HGFI.
    have L1: y ∈ Y.
    rewrite HF in HF0.
    inversion HF0 as [Z0 [x0 [y0 [HZ0 [Hyfx HXY]]]]].
    rewrite HZ0 in H.
    rewrite H in HXY.
    apply ordered_pair_in_direct_product_iff_in_and in HXY.
    apply HXY.
    have L2: exists z : U, z = g y /\ z ∈ Z.
    apply Hg in L1.
    trivial.
    inversion L2 as [z].
    apply (HGFI x x' z).
    split; split; [exists x|exists x']; exists z; split.
    reflexivity.
    exists y.
    split;[trivial|
           rewrite HG;split;exists y;exists z;split;[reflexivity|split;[apply H|apply ordered_pair_in_direct_product_iff_in_and;split;[trivial|apply H]]]].
    reflexivity.
    exists y.
    split;[trivial|
           rewrite HG;split;exists y;exists z;split;[reflexivity|split;[apply H|apply ordered_pair_in_direct_product_iff_in_and;split;[trivial|apply H]]]].
  Qed.

  Theorem compound_graph_is_surjection_to_destination_graph_is_surjection:
    forall (f g:U -> U) (X Y Z:Collection U) (F G:TypeOfDirectProduct U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      SurjectionGraph F Y ->
      MappingFunction g Y Z ->
      G = GraphOfFunction g Y Z ->
      SurjectionGraph (G ⊙ F) Z ->
      SurjectionGraph G Z.
  Proof.
    move => f g X Y Z F G Hf HF HFS Hg HG HGS z HzZ.
    apply HGS in HzZ.
    inversion HzZ as [x].
    inversion H.
    inversion H0 as [x' [z']].
    inversion H2.
    inversion H4 as [y'].
    inversion H5.
    apply ordered_pair_to_and in H3.
    inversion H3.
    exists y'.
    rewrite H9.
    assumption.
  Qed.

  Theorem compound_graph_is_source_identity_graph_to_injection:
    forall (f g:U -> U) (X Y:Collection U) (F G:TypeOfDirectProduct U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      MappingFunction g Y X ->
      G = GraphOfFunction g Y X ->
      G ⊙ F = GraphOfIdentity X ->
      InjectionGraph F.
  Proof.
    move => f g X Y F G Hf HF Hg HG H.
    move => x x' y [HF0 HF1].
    have Hgf: forall x:U, x ∈ X -> x = (g ◦ f) x.
    move => x0 Hx0X.
    apply (mapping_compound_function_iff_singleton_image U f g X Y X F G x0 x0); trivial.
    rewrite H.
    apply image_singleton_domain_of_graph_of_identity_eq_singleton_domain.
    trivial.
    have L1: forall x z z' : U,
        x ∈ X -> {|z|} = 𝕴𝖒( G ⊙ F, {|x|}) -> {|z'|} = 𝕴𝖒( G ⊙ F, {|x|}) -> z = z'.
    apply (compound_function_value_unique U f g X Y X F G).
    trivial.
    trivial.
    move :(L1 x x x') => L2.
    have L3: x ∈ X.
    rewrite HF in HF0.
    inversion HF0 as [Z0 [x0 [y0 []]]].
    inversion H1.
    rewrite -H0 in H4.
    apply ordered_pair_in_direct_product_iff_in_and in H4.
    apply H4.
    apply L2.
    trivial.
    rewrite H.
    apply image_singleton_domain_of_graph_of_identity_eq_singleton_domain.
    trivial.
    apply (singleton_image_of_compound_graph_iff_ordered_pair_in_compound_graph U f g X Y X F G x x'); trivial.
    split.
    exists x.
    exists x'.
    split;[reflexivity|exists y].
    split;[trivial|].
    rewrite HG.
    split.
    exists y.
    exists x'.
    split.
    reflexivity.
    rewrite HF in HF1.
    inversion HF1 as [Z1 [x1 [y1]]].
    inversion H0 as [Heq1 [Hyfx1 Hxy1]].
    apply ordered_pair_to_and in Heq1.
    inversion Heq1 as [Heq1x Heq1y].
    rewrite -Heq1x -Heq1y in Hyfx1.
    rewrite -Heq1x in Hxy1.
    rewrite -Heq1y in Hxy1.
    split.
    rewrite Hyfx1.
    apply Hgf.
    apply ordered_pair_in_direct_product_iff_in_and in Hxy1.
    apply Hxy1.
    apply ordered_pair_in_direct_product_trans.
    assumption.
  Qed.

  Theorem compound_graph_is_source_identity_graph_to_injection_2:
    forall (f g:U -> U) (X Y:Collection U) (F G:TypeOfDirectProduct U),
      MappingFunction f X Y /\ F = GraphOfFunction f X Y ->
      MappingFunction g Y X /\ G = GraphOfFunction g Y X ->
      G ⊙ F = GraphOfIdentity X ->
      InjectionGraph F.
  Proof.
    move => f g X Y F G HF HG H.
    inversion HF.
    inversion HG.
    apply (compound_graph_is_source_identity_graph_to_injection f g X Y F G);trivial.
  Qed.

  Theorem compound_graph_is_source_identity_graph_to_surjection:
    forall (f g:U -> U) (X Y:Collection U) (F G:TypeOfDirectProduct U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      MappingFunction g Y X ->
      G = GraphOfFunction g Y X ->
      G ⊙ F = GraphOfIdentity X ->
      SurjectionGraph G X.
  Proof.
    move => f g X Y F G Hf HF Hg HG H x HxX.
    have Hgf: forall x:U, x ∈ X -> x = (g ◦ f) x.
    move => x0 Hx0X.
    apply (mapping_compound_function_iff_singleton_image U f g X Y X F G x0 x0);trivial.
    rewrite H.
    apply image_singleton_domain_of_graph_of_identity_eq_singleton_domain.
    trivial.
    have L1: exists y : U, y = f x /\ y ∈ Y.
    apply Hf.
    trivial.
    inversion L1 as [y [Hyfx HyY]].
    exists y.
    rewrite HG.
    split.
    exists y.
    exists x.
    split;[reflexivity|split].
    rewrite Hyfx.
    apply Hgf.
    trivial.
    apply ordered_pair_in_direct_product_iff_in_and.
    split;trivial.
  Qed.

  Theorem compound_graph_is_source_identity_graph_to_injection_and_surjection:
    forall (f g:U -> U) (X Y:Collection U) (F G:TypeOfDirectProduct U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      MappingFunction g Y X ->
      G = GraphOfFunction g Y X ->
      G ⊙ F = GraphOfIdentity X ->
      InjectionGraph F /\ SurjectionGraph G X.
  Proof.
    move => f g X Y F G Hf HF Hg HG H.
    split; [apply (compound_graph_is_source_identity_graph_to_injection f g X Y F G)|
            apply (compound_graph_is_source_identity_graph_to_surjection f g X Y F G)];
    trivial.
  Qed.

  Theorem mutally_compound_function_is_idenitify_to_bijection_function:
    forall (f g:U -> U) (X Y:Collection U) (F G:TypeOfDirectProduct U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      MappingFunction g Y X ->
      G = GraphOfFunction g Y X ->
      G ⊙ F = GraphOfIdentity X /\ F ⊙ G = GraphOfIdentity Y ->
      BijectionGraph F Y /\ BijectionGraph G X.
  Proof.
    move => f g X Y F G Hf HF Hg HG [HGFX HFGY].
    split.
    split;[apply (compound_graph_is_source_identity_graph_to_injection f g X Y F G)|
           apply (compound_graph_is_source_identity_graph_to_surjection g f Y X G F)];trivial.
    split;[apply (compound_graph_is_source_identity_graph_to_injection g f Y X G F)|
           apply (compound_graph_is_source_identity_graph_to_surjection f g X Y F G)];trivial.
  Qed.

  Theorem compound_graph_is_mutally_identity_graph_to_invertible_function_left:
    forall (f g:U -> U) (X Y:Collection U) (F G:TypeOfDirectProduct U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      MappingFunction g Y X ->
      G = GraphOfFunction g Y X ->
      G ⊙ F = GraphOfIdentity X /\ F ⊙ G = GraphOfIdentity Y ->
      G = F ^-1.
  Proof.
    move => f g X Y F G Hf HF Hg HG [HGFX HFGY].
    have Hgf: forall x:U, x ∈ X -> x = (g ◦ f) x.
    move => x HxX.
    apply (mapping_compound_function_iff_singleton_image U f g X Y X F G x x);trivial.
    rewrite HGFX.
    apply image_singleton_domain_of_graph_of_identity_eq_singleton_domain; trivial.
    have Hfg: forall y:U, y ∈ Y -> y = (f ◦ g) y.
    move => y HyY.
    apply (mapping_compound_function_iff_singleton_image U g f Y X Y G F y y);trivial.
    rewrite HFGY.
    apply image_singleton_domain_of_graph_of_identity_eq_singleton_domain; trivial.
    apply mutally_included_to_eq; split => Z H.
    +rewrite HG in H.
     inversion H as [Z0 [y [x [HZ0 [Hxeqgy HyYxX]]]]].
     rewrite HZ0 in H0.
     rewrite -H0.
     split.
     rewrite HF.
     split.
     exists x.
     exists y.
     split;[reflexivity|split].
     apply ordered_pair_in_direct_product_to_in_and in HyYxX.
     inversion HyYxX.
     rewrite Hxeqgy.
     apply Hfg in H1.
     trivial.
     apply ordered_pair_in_direct_product_trans.
     assumption.
    +inversion H.
     rewrite HF in H0.
     inversion H0 as [Z0 [x0 [y0 [HZ0 [Hyeqfx HxXyY]]]]].
     rewrite H2 in HZ0.
     apply ordered_pair_to_and in HZ0.
     inversion HZ0.
     rewrite -H3 -H4 in Hyeqfx.
     rewrite -H3 -H4 in HxXyY.
     apply ordered_pair_in_direct_product_to_in_and in HxXyY.
     inversion HxXyY as [HxX HyY].
     rewrite HG.
     split.
     exists y.
     exists x.
     split;[reflexivity|split].
     rewrite Hyeqfx.
     apply Hgf in HxX.
     trivial.
     apply in_and_to_ordered_pair_in_direct_product.
     apply and_comm.
     assumption.
  Qed.

  Theorem compound_graph_is_mutally_identity_graph_to_invertible_function_right:
    forall (f g:U -> U) (X Y:Collection U) (F G:TypeOfDirectProduct U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      MappingFunction g Y X ->
      G = GraphOfFunction g Y X ->
      G ⊙ F = GraphOfIdentity X /\ F ⊙ G = GraphOfIdentity Y ->
      F = G ^-1.
  Proof.
    move => f g X Y F G Hf HF Hg HG [HGFX HFGY].
    have Hgf: forall x:U, x ∈ X -> x = (g ◦ f) x.
    move => x HxX.
    apply (mapping_compound_function_iff_singleton_image U f g X Y X F G x x);trivial.
    rewrite HGFX.
    apply image_singleton_domain_of_graph_of_identity_eq_singleton_domain; trivial.
    have Hfg: forall y:U, y ∈ Y -> y = (f ◦ g) y.
    move => y HyY.
    apply (mapping_compound_function_iff_singleton_image U g f Y X Y G F y y);trivial.
    rewrite HFGY.
    apply image_singleton_domain_of_graph_of_identity_eq_singleton_domain; trivial.
    apply mutally_included_to_eq; split => Z H.
    +rewrite HF in H.
     inversion H as [Z0 [x [y [HZ0 [Hxeqgy HxXyY]]]]].
     rewrite HZ0 in H0.
     rewrite -H0.
     split.
     rewrite HG.
     split.
     exists y.
     exists x.
     split;[reflexivity|split].
     rewrite Hxeqgy.
     apply ordered_pair_in_direct_product_to_in_and in HxXyY.
     inversion HxXyY.
     apply Hgf in H1.
     trivial.
     apply ordered_pair_in_direct_product_trans.
     assumption.
    +inversion H as [y x].
     rewrite HG in H0.
     inversion H0 as [Z0 [y0 [x0 [HZ0 [Hxeqgy HyYxX]]]]].
     rewrite H2 in HZ0.
     apply ordered_pair_to_and in HZ0.
     inversion HZ0.
     rewrite -H3 -H4 in Hxeqgy.
     rewrite -H3 -H4 in HyYxX.
     rewrite HF.
     split.
     exists x.
     exists y.
     split;[reflexivity|split].
     rewrite Hxeqgy.
     apply ordered_pair_in_direct_product_to_in_and in HyYxX.
     inversion HyYxX.
     apply Hfg in H5.
     trivial.
     apply ordered_pair_in_direct_product_trans.
     assumption.
  Qed.

  Theorem compound_graph_is_mutally_identity_graph_to_invertible_function:
    forall (f g:U -> U) (X Y:Collection U) (F G:TypeOfDirectProduct U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      MappingFunction g Y X ->
      G = GraphOfFunction g Y X ->
      G ⊙ F = GraphOfIdentity X /\ F ⊙ G = GraphOfIdentity Y ->
      G = F ^-1 /\ F = G ^-1.
  Proof.
    move => f g X Y F G Hf HF Hg HG HId.
    split;[apply (compound_graph_is_mutally_identity_graph_to_invertible_function_left f g X Y)|
           apply (compound_graph_is_mutally_identity_graph_to_invertible_function_right f g X Y)];trivial.
  Qed.

  Theorem invertible_mapping_to_exists_invertible_graph:
    forall (f:U -> U) (X Y:Collection U) (F:TypeOfDirectProduct U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      InvertibleMapping f X Y F ->
      exists G:TypeOfDirectProduct U, G = F ^-1 /\ F = G ^-1.
  Proof.
    move => f X Y F HF Hf HGI.
    inversion HGI as [g [G [Hg [HG HId]]]].
    exists G.
    apply (compound_graph_is_mutally_identity_graph_to_invertible_function f g X Y);trivial.
  Qed.

  Theorem injection_graph_to_compound_self_inverse_graph_eq_identity_graph:
    forall (f:U -> U) (X Y:Collection U) (F:TypeOfDirectProduct U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      InjectionGraph F ->
      (F ^-1) ⊙ F = GraphOfIdentity X.
  Proof.
    move => f X Y F Hf HF HFI.
    apply mutally_included_to_eq.
    split => Z H;
               inversion H as [Z0 [x [x']]];
               inversion H0 as [HZ].
    +inversion H2 as [y].
     split.
     exists x.
     exists x'.
     split;[trivial|].
     ++split.
       apply sym_eq.
       apply: (HFI x x' y).
       inversion H3.
       inversion H5.
       apply ordered_pair_swap in H6.
       rewrite -H6.
       split;assumption.
     ++inversion H3.
       inversion H5.
       apply ordered_pair_swap in H6.
       rewrite H6 in H7.
       rewrite HF in H4.
       rewrite HF in H7.
       inversion H4 as [Z1 [x1 [y1]]].
       inversion H8.
       inversion H11.
       rewrite -H10 in H13.
       apply ordered_pair_in_direct_product_to_in_and in H13.
       inversion H13.
       inversion H7 as [Z2 [x2 [y2]]].
       inversion H16.
       inversion H19.
       rewrite -H18 in H21.
       apply ordered_pair_in_direct_product_to_in_and in H21.
       inversion H21.
       apply ordered_pair_in_direct_product_iff_in_and.
       split; assumption.
    +inversion H2.
     split.
     exists x.
     exists x'.
     split.
     trivial.
     apply ordered_pair_in_direct_product_iff_in_and in H4.
     inversion H4.
     apply Hf in H5.
     apply Hf in H6.
     inversion H4.
     inversion H5 as [y].
     inversion H9.
     exists y.
     split;[rewrite HF;split|split; rewrite HF; split].
     exists x.
     exists y.
     split;[reflexivity|split;[trivial|apply ordered_pair_in_direct_product_iff_in_and;split;trivial]].
     inversion H6 as [y0].
     inversion H12.
     rewrite H3 in H13.
     exists x'.
     exists y0.
     split;[rewrite H10 H13;reflexivity|
            split;[rewrite H3;trivial|
                   apply ordered_pair_in_direct_product_iff_in_and;
                   split;
                   trivial]].
  Qed.

  Theorem surjection_graph_to_compound_self_inverse_graph_eq_identity_graph:
    forall (f:U -> U) (X Y:Collection U) (F:TypeOfDirectProduct U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      SurjectionGraph F Y ->
      F ⊙ (F ^-1) = GraphOfIdentity Y.
  Proof.
    move => f X Y F Hf HF HFS.
    apply mutally_included_to_eq.
    split => Z H.
    inversion H as [Z0 [y [y' [HZ0 [x [HF0 HF1]]]]]].
    rewrite HZ0 in H0.
    rewrite -H0.
    inversion HF0.
    apply ordered_pair_swap in H1.
    rewrite H1 in H2.
    rewrite HF in HF1.
    rewrite HF in H2.
    inversion HF1 as [Z1 [x1 [y1 [Heq1 [Hyeqfx1]]]]].
    rewrite Heq1 in H4.
    rewrite H4 in H3.
    apply ordered_pair_to_and in H4.
    inversion H4.
    rewrite H5 H6 in Hyeqfx1.
    inversion H2 as [Z2 [x2 [y2 [Heq2 [Hyeqfx2]]]]].
    rewrite Heq2 in H8.
    rewrite H8 in H7.
    apply ordered_pair_to_and in H8.
    inversion H8.
    rewrite H9 H10 in Hyeqfx2.
    rewrite Hyeqfx1 Hyeqfx2.
    apply ordered_pair_in_graph_of_identity.
    rewrite -Hyeqfx1.
    apply ordered_pair_in_direct_product_to_in_and in H3.
    apply H3.
    inversion H as [Z0 [y [y' [HZ0 [HId]]]]].
    rewrite HZ0 in H1.
    rewrite -H1.
    split.
    exists y.
    exists y'.
    split;[reflexivity|].
    apply ordered_pair_in_direct_product_to_in_and in H0.
    inversion H0.
    apply HFS in H2.
    apply HFS in H3.
    inversion H2 as [x].
    inversion H3 as [x'].
    exists x.
    split.
    split.
    trivial.
    rewrite HId.
    trivial.
  Qed.

  Theorem bijection_graph_to_compound_self_inverse_graph_eq_identity_graph:
    forall (f:U -> U) (X Y:Collection U) (F:TypeOfDirectProduct U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      BijectionGraph F Y ->
      (F ^-1) ⊙ F = GraphOfIdentity X /\ F ⊙ (F ^-1) = GraphOfIdentity Y.
  Proof.
    move => f X Y F Hf HF [HIF HSF].
    split;[apply (injection_graph_to_compound_self_inverse_graph_eq_identity_graph f X Y F)|
           apply (surjection_graph_to_compound_self_inverse_graph_eq_identity_graph f X Y F)];trivial.
  Qed.

  Theorem outer_of_composite_function_is_injection_to_inner_is_unique:
    forall (f0 f1 g:U -> U) (X Y Z:Collection U) (F0 F1 G:TypeOfDirectProduct U),
      MappingFunction f0 X Y ->
      F0 = GraphOfFunction f0 X Y ->
      MappingFunction f1 X Y ->
      F1 = GraphOfFunction f1 X Y ->
      MappingFunction g Y Z ->
      G = GraphOfFunction g Y Z ->
      InjectionGraph G -> (G ⊙ F0 = G ⊙ F1 -> F0 = F1).
  Proof.
    move => f0 f1 g X Y Z F0 F1 G Hf0 HF0 Hf1 HF1 Hg HG HIG Heq.
    have Heqfg: forall x:U, x ∈ X -> (g ◦ f0) x = (g ◦ f1) x.
    apply (compound_graph_eq_iff_compound_function_eq U f0 f1 g g X Y Z F0 F1 G G);trivial.
    apply (function_eq_to_graph_of_function_eq U f0 f1 X Y F0 F1);trivial.
    move => x HxX.
    have Heqfgx: (g ◦ f0) x = (g ◦ f1) x.
    apply Heqfg.
    trivial.
    unfold InjectionGraph in HIG.
    apply (HIG (f0 x) (f1 x) ((g ◦ f0) x)).
    split;rewrite HG;split.
    exists (f0 x).
    exists ((g ◦ f0) x).
    split;[reflexivity|split;[reflexivity|]].
    apply Hf0 in HxX.
    inversion HxX as [y' [Hy'f0x Hy'Y]].
    rewrite Hy'f0x in Hy'Y.
    apply in_and_to_ordered_pair_in_direct_product.
    split.
    trivial.
    apply Hg in Hy'Y.
    inversion Hy'Y as [z' [Hzgf0x Hz'Z]].
    rewrite Hzgf0x in Hz'Z.
    trivial.
    exists (f1 x).
    exists ((g ◦ f0) x).
    split;[reflexivity|split;[rewrite Heqfgx;reflexivity|]].
    apply Hf1 in HxX.
    inversion HxX as [y' [Hy'f1x Hy'Y]].
    rewrite Hy'f1x in Hy'Y.
    apply in_and_to_ordered_pair_in_direct_product.
    split;trivial.
    apply Hg in Hy'Y.
    inversion Hy'Y as [z' [Hzgf1x Hz'Z]].
    rewrite Hzgf1x in Hz'Z.
    rewrite Heqfgx.
    trivial.
  Qed.

  Theorem injection_graph_has_inversible_graph:
    forall (f:U -> U) (X Y:Collection U) (F:TypeOfDirectProduct U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      (InjectionGraph F -> (exists g:U->U, exists G:TypeOfDirectProduct U,
                                 (MappingFunction g Y X /\ G = GraphOfFunction g Y X) ->
                                 G ⊙ F = GraphOfIdentity X) \/ X = `Ø`).
  Proof.
    move => f X Y F Hf HF HIF.
    suff:  X = `Ø` \/ X <> `Ø`.
    case => HX.
    right.
    trivial.
    left.
    apply not_empty_collection_to_exists_element_in_collection in HX.
    inversion HX as [x HxX].
    move: (fun _:U => x) => g.
    exists g.
    exists (F ^-1).
    case =>[Hg HG].
    apply (injection_graph_to_compound_self_inverse_graph_eq_identity_graph f X Y);trivial.
    apply LawOfExcludedMiddle.
  Qed.

  Goal forall (f:U -> U) (X Y:Collection U) (F:TypeOfDirectProduct U),
      MappingFunction f X Y ->
      F = GraphOfFunction f X Y ->
      (((exists g:U->U, exists G:TypeOfDirectProduct U,
              MappingFunction g Y X /\
              G = GraphOfFunction g Y X /\
              G ⊙ F = GraphOfIdentity X) \/ X = `Ø`) -> InjectionGraph F).
  Proof.
    move => f X Y F Hf HF [H|H].
    inversion H as [g [G [Hg [HG HGF]]]].
    apply (compound_graph_is_source_identity_graph_to_injection f g X Y F G);trivial.
    move => x x' y.
    rewrite HF.
    move => [HF0 HF1].
    inversion HF0 as [Z0 [x0' [y0' [Heq0 [Hyfx0 HxXyY0]]]]].
    rewrite Heq0 in H0.
    rewrite H0 in HxXyY0.
    inversion HF1 as [Z1 [x1' [y1' [Heq1 [Hyfx1 HxXyY1]]]]].
    rewrite Heq1 in H1.
    rewrite H1 in HxXyY1.
    apply ordered_pair_in_direct_product_to_in_and in HxXyY0.
    inversion HxXyY0 as [HxX HyY0].
    apply ordered_pair_in_direct_product_to_in_and in HxXyY1.
    inversion HxXyY1 as [Hx'X HyY1].
    rewrite H in HxX.
    rewrite H in Hx'X.
    apply DoubleNegativeElimination.
    move => Hxx'.
    move: HxX.
    apply noone_in_empty.
  Qed.

End MappingMorphism.