(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div order.
From mathcomp Require Import ssralg ssrnum ssrint rat intdiv.
From Coq Require Import Morphisms Setoid.
From fourcolor Require Import real realsyntax.

(******************************************************************************)
(*   This file establishes basic arithmetic/order/setoid properties of the    *)
(* abstract real numbers specified in real.v.                                 *)
(*   We also define a few additional operations in a Real.structure R:        *)
(*                      intR R m == injection of m : int and a : rat into R.  *)
(*                      ratR R a    (made locally into coercions for fixed R) *)
(*                       floor x == the largest integral y <= x.              *)
(*                   floor_set x == the singleton set {floor x}.              *)
(*                      range1 x == the unit interval [x, x+1).               *)
(* We use 'R' as the suffix standing for real arguments, since 'r' is already *)
(* used in the MathComp library for generic ring arguments.                   *)
(*   This file provides support for classical reasoning though theorem        *)
(* reals_classic : Real.model -> excluded_middle.                             *)
(*   We have general support for relational rewriting of real expressions in  *)
(* the Real.eq setoid; the theory is developped using extended_sup and        *)
(* extended_inv instead of sup and inv because the latter are only partially  *)
(* defined, making it impossible to have unconditional context lemmas.        *)
(******************************************************************************)

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

Import Order.TTheory GRing.Theory Num.Theory.
Hint Resolve iff_refl : core.
Local Open Scope real_scope.

Local Notation "m %:Z" := m%:Z%R%N (only parsing).
Local Notation "a %:Q" := a%:Q%R%N (only parsing).

Section RealOperations.

Variable R : Real.structure.

Definition min x y : R := IF x <= y then x else y.

Definition max x y : R := IF x >= y then x else y.

Definition intR m : R := match m with Posz n => n%:R | Negz n => - n.+1%:R end.

Definition ratR (a : rat) :=
  if a \is a Qint then intR (numq a) else intR (numq a) / intR (denq a).

Inductive floor_set x : Real.set R :=
  FloorSet m of intR m <= x : floor_set x (intR m).

Definition floor x : R := sup (floor_set x).

Definition range1 x : Real.set R := fun y => x <= y < x + 1.

End RealOperations.

Arguments min {R} x y.
Arguments max {R} x y.
Arguments floor_set {R} x.
Arguments floor {R} x.
Arguments range1 {R} x.

Section RealLemmas.

Variable R : Real.model.
Implicit Types x y z : R.
Implicit Type E : Real.set R.
Implicit Type m d : int.
Implicit Types n p : nat.
Implicit Types a b : rat.

Let intRR := intR R.
Local Coercion intRR : int >-> Real.val.
Let ratRR := ratR R.
Local Coercion ratRR : rat >-> Real.val.
Local Notation Rtype := (Real.val (Real.model_structure R)) (only parsing).
Local Notation eqR :=(@Real.eq (Real.model_structure R)) (only parsing).
Local Notation eqRset := (pointwise_relation Rtype iff).

(*********************************************************)
(**     Comparisons and the least upper bound axioms     *)
(*********************************************************)

Lemma leRR x : x <= x.
Proof. exact: (Real.le_reflexive R). Qed.
Hint Resolve leRR : core.

Lemma leR_trans x y z : x <= y -> y <= z -> x <= z.
Proof. exact: (Real.le_transitive R). Qed.

(* Lemmas supporting the extended sup require the excluded middle. *)
Lemma real_sup_ub E : Real.has_sup E -> Real.ub E (Real.sup E).
Proof. exact: (Real.sup_upper_bound R). Qed.

Lemma real_sup_total E x : Real.has_sup E -> Real.down E x \/ Real.sup E <= x.
Proof. exact: (Real.sup_total R). Qed.

Lemma leR_total x y : x <= y \/ y <= x.
Proof.
have ubEy: Real.has_sup {z | z = y} by split; exists y => // _ ->.
have [[_ ->] | leEyx] := real_sup_total x ubEy; first by left.
right; apply: leR_trans leEyx; apply: real_sup_ub => //; exists y => _ ->.
Qed.

Lemma eqR_le2 x y : x == y <-> x <= y <= x. Proof. by []. Qed.

Lemma eqR_le x y : x == y -> x <= y. Proof. by case. Qed.

Lemma gtR_neq x y : x > y -> x != y. Proof. by move=> gtxy []. Qed.

Lemma ltR_neq x y : x < y -> x != y. Proof. by move=> ltxy []. Qed.

Lemma ltR_total x y : x != y -> x < y \/ y < x.
Proof.
by case: (leR_total x y) => leyx neq_xy; [left | right] => lexy; case: neq_xy.
Qed.

Lemma ltRW x y : x < y -> x <= y. Proof. by have [] := leR_total x y. Qed.
Hint Resolve ltRW : core.

Lemma leR_lt_trans x y z : x <= y -> y < z -> x < z.
Proof. by move=> lexy ltyz lezx; have:= leR_trans lezx lexy. Qed.

Lemma ltR_le_trans x y z : x < y -> y <= z -> x < z.
Proof. by move=> ltxy leyz lezx; have:= leR_trans leyz lezx. Qed.

Lemma ltR_trans x y z : x < y -> y < z -> x < z.
Proof. by move/ltRW; apply: leR_lt_trans. Qed.

(**********************************************************)
(**      The setoid structure                             *)
(**********************************************************)

Lemma eqR_refl x : x == x. Proof. by []. Qed.
Hint Resolve eqR_refl : core.

Lemma eqR_congr x y : x = y -> x == y. Proof. by move->. Qed.

Lemma eqR_sym x y : x == y -> y == x. Proof. by case. Qed.
Hint Immediate eqR_sym : core.

Lemma eqR_trans x y z : x == y -> y == z -> x == z.
Proof. by move=> [lexy leyx] [/(leR_trans lexy)lexz /leR_trans/(_ leyx)]. Qed.

Add Parametric Relation : R eqR
  reflexivity proved by eqR_refl
  symmetry proved by eqR_sym
  transitivity proved by eqR_trans
  as real_equality.

Instance leR_Proper : Proper (eqR ==> eqR ==> iff) Real.le.
Proof.
move=> x1 x2 [lex12 lex21] y1 y2 [ley12 ley21].
by split=> [/(leR_trans lex21) | /(leR_trans lex12)] /leR_trans; apply.
Qed.

(**********************************************************)
(**       Addition                                        *)
(**********************************************************)

Lemma addRC x y : x + y == y + x.
Proof. exact: (Real.add_commutative R). Qed.

Instance addR_Proper : Proper (eqR ==> eqR ==> eqR) Real.add.
Proof.
move=> x1 x2 Dx y1 y2 Dy; apply: (@eqR_trans _ (x1 + y2)).
  by split; apply: (Real.add_monotone R); rewrite Dy.
by rewrite -!(addRC y2); split; apply: (Real.add_monotone R); rewrite Dx.
Qed.

Lemma addRA x y z : x + (y + z) == x + y + z.
Proof. exact: (Real.add_associative R). Qed.

Lemma addRCA x y z : x + (y + z) ==  y + (x + z).
Proof. by rewrite !addRA (addRC x). Qed.

Lemma addRAC x y z : x + y + z ==  x + z + y.
Proof. by rewrite -!addRA (addRC y). Qed.

Lemma addRACA x1 y1 x2 y2 : x1 + y1 + (x2 + y2)== x1 + x2 + (y1 + y2).
Proof. by rewrite !addRA (addRAC x1). Qed.

Lemma add0R x : 0 + x == x.
Proof. exact: (Real.add_zero_left R). Qed.

Lemma addR0 x : x + 0 == x.
Proof. by rewrite addRC add0R. Qed.

Lemma subRR x : x - x == 0.
Proof. exact: (Real.add_opposite_right R). Qed.

Lemma addRK x y : x + y - y == x.
Proof. by rewrite -addRA subRR addR0. Qed.

Lemma subRK x y : x - y + y == x.
Proof. by rewrite addRAC addRK. Qed.

Lemma addKR x y : - x + (x + y) == y.
Proof. by rewrite addRCA addRA subRR add0R. Qed.

Lemma addRI x y z : x + y == x + z -> y == z.
Proof. by move=> Dxy; rewrite -(addKR x y) Dxy addKR. Qed.

Lemma addIR x y z : y + x == z + x -> y == z.
Proof. by rewrite -!(addRC x); apply: addRI. Qed.

Lemma oppRK x : - - x == x.
Proof. by apply: (@addIR (- x)); rewrite addRC !subRR. Qed.

Lemma oppRD x y : - (x + y) == - x - y.
Proof. by apply: (@addRI (x + y)); rewrite subRR addRCA addRK addRC subRR. Qed.

Lemma oppRB x y : - (x - y) == y - x.
Proof. by rewrite oppRD oppRK addRC. Qed.

Lemma oppR0 : - (0 : R) == 0.
Proof. by apply: (@addRI 0); rewrite subRR add0R. Qed.

Lemma leR_add2l x y z : x + y <= x + z <-> y <= z.
Proof.
split=> leyz; last exact: (Real.add_monotone R).
by rewrite -(addKR x y) -(addKR x z); apply: (Real.add_monotone R).
Qed.

Lemma leR_add2r x y z : y + x <= z + x <-> y <= z.
Proof. by rewrite -!(addRC x); apply: leR_add2l. Qed.

Lemma subR_ge0 x y : 0 <= y - x <-> x <= y.
Proof. by rewrite -(leR_add2r x) subRK add0R. Qed.

Lemma subR_le0 x y : x - y <= 0 <-> x <= y.
Proof. by rewrite -subR_ge0 oppRB add0R subR_ge0. Qed.

Lemma leR_opp2 x y : - x <= - y <-> y <= x.
Proof. by rewrite -subR_ge0 oppRK addRC subR_ge0. Qed.

Lemma oppR_inj x y : - x == - y -> x == y.
Proof. by rewrite /eqR !leR_opp2 => /eqR_sym. Qed.

Instance oppR_Proper : Proper (eqR ==> eqR) Real.opp.
Proof. by move=> x1 x2 Dx; apply: oppR_inj; rewrite !oppRK. Qed.

(**********************************************************)
(**       Multiplication                                  *)
(**********************************************************)

Lemma mulRC x y : x * y == y * x.
Proof. exact: (Real.mul_commutative R). Qed.

Lemma mulRDr x y z : x * (y + z) == x * y + x * z.
Proof. exact: (Real.mul_distributive_right R). Qed.

Lemma mulRDl x y z : (y + z) * x == y * x + z * x.
Proof. by rewrite -!(mulRC x) -mulRDr. Qed.

Instance mulR_Proper : Proper (eqR ==> eqR ==> eqR) Real.mul.
Proof.
have posMr x y z : 0 <= x -> y == z -> x * y == x * z.
  by move=> pos_x [lex2 ley1]; split; apply: (Real.mul_monotone R).
suffices allMr x y z: y == z -> x * y == x * z.
  by move=> x1 x2 Dx _ y /allMr->; rewrite -!(mulRC y) allMr.
move/posMr=> Dy; have [/Dy // | x_le0] := leR_total 0 x.
have{x_le0} nx_ge0: 0 <= - x by rewrite -oppR0 leR_opp2.
by apply: (@addIR (- x * y)); rewrite -mulRDl !Dy -?mulRDl ?subRR.
Qed.

Lemma mulRA x y z : x * (y * z) == x * y * z.
Proof. exact: (Real.mul_associative R). Qed.

Lemma mulRCA x y z : x * (y * z) == y * (x * z).
Proof. by rewrite !mulRA (mulRC x). Qed.

Lemma mulRAC x y z : x * y * z == x * z * y.
Proof. by rewrite -!mulRA (mulRC y). Qed.

Lemma mulRACA x1 y1 x2 y2 : x1 * y1 * (x2 * y2) == x1 * x2 * (y1 * y2).
Proof. by rewrite !mulRA (mulRAC x1). Qed.

Lemma mul0R x : 0 * x == 0.
Proof. by apply (@addRI (0 * x)); rewrite -mulRDl !addR0. Qed.

Lemma mulR0 x : x * 0 == 0.
Proof. by rewrite mulRC mul0R. Qed.

Lemma mulRN x y : x * - y == - (x * y).
Proof. by apply (@addRI (x * y)); rewrite -mulRDr !subRR mulR0. Qed.

Lemma mulNR x y : - x * y == - (x * y).
Proof. by rewrite mulRC mulRN mulRC. Qed.

Lemma mul1R x : 1 * x == x.
Proof. exact: (Real.mul_one_left R). Qed.

Lemma mulR1 x : x * 1 == x.
Proof. by rewrite mulRC mul1R. Qed.

Lemma mul2R x : 2 * x == x + x.
Proof. by rewrite mulRDl !mul1R. Qed.

Lemma mulN1R x : - 1 * x == - x.
Proof. by rewrite mulNR mul1R. Qed.

Lemma mulRN1 x : x * - 1 == - x.
Proof. by rewrite mulRN mulR1. Qed.

(* Properties of 1 (finally!) *)

Lemma neqR10 : (1 : R) != 0.
Proof. exact: (Real.one_nonzero R). Qed.

Lemma ltR01 : (0 : R) < 1.
Proof.
case/ltR_total: neqR10 => // lt10 le10; case: lt10.
have{le10} le0N1: (0 : R) <= -1 by rewrite -oppR0 leR_opp2.
by have:= Real.mul_monotone R le0N1 le0N1; rewrite mulR0 mulN1R oppRK.
Qed.
Hint Resolve ltR01 : core.

Lemma ltRS x : x < x + 1.
Proof. by rewrite -subR_le0 (addRC x) addRK. Qed.
Arguments ltRS x : clear implicits.

Lemma ltPR x : x - 1 < x.
Proof. by rewrite -subR_le0 oppRB addRCA subRR addR0. Qed.
Arguments ltPR x : clear implicits.

Lemma ltR02 : (0 : R) < 2.
Proof. exact: ltR_trans ltR01 (ltRS 1). Qed.
Hint Resolve ltR02 : core.
Let leR02 : 0 <= 2 := ltRW ltR02.

(* Excluded middle and minimality of sup follow from the properties of 2! *)

Lemma reals_classic : excluded_middle.
Proof.
move=> P; have supE: Real.has_sup {x | x = 0 \/ P /\ x = 2 :> R}.
  by split; [exists 0; left | exists 2 => x [->|[_ ->]]].
have [[x [-> /ltR01 // | []]] | leE1] := real_sup_total 1 supE; first by left.
by right=> haveP; apply/(leR_lt_trans leE1 (ltRS 1))/real_sup_ub; last right.
Qed.

Lemma real_sup_le_ub E x : Real.has_sup E -> Real.ub E x -> Real.sup E <= x.
Proof.
set y := Real.sup E => supE leEx; pose z := (x + y) * Real.inv 2.
have le2M := Real.mul_monotone R leR02.
have mul2inv: 2 * Real.inv 2 == 1 := Real.mul_inverse_right R (gtR_neq ltR02).
have{mul2inv} D2z: 2 * z == x + y by rewrite mulRCA mul2inv mulR1.
have [[t /leEx-letx lezt] | leyz] := real_sup_total z supE.
  by have /le2M := leR_trans lezt letx; rewrite D2z mul2R leR_add2l.
by have /le2M := leyz; rewrite D2z mul2R leR_add2r.
Qed.

(* Deciding comparisons. *)

Lemma leR_eqVlt x y : x <= y <-> x == y \/ x < y.
Proof.
split=> [lexy | [-> | /ltRW] //].
by have [|/ltR_total[]//] := reals_classic (x == y); [left | right].
Qed.

Lemma ltR_neqAle x y : x < y <-> x != y /\ x <= y.
Proof.
by rewrite (leR_eqVlt x y); split=> [ltxy|[neqxy []]//]; split; [case | right].
Qed.

(* Properties of the conditional. *)

Section SelectR.

Variables (P : Prop) (x y : R).
Let decP := reals_classic P.
Let E := Real.select_set P x y.

Inductive selectR_spec : Real.set R := SelectRSpec z of E z : selectR_spec z.

Lemma IFR_cases : selectR_spec (IF P then x else y).
Proof.
have [z Ez]: Real.nonempty E.
  by have [haveP | notP] := decP; [exists x; left | exists y; right].
have Dz t: E t <-> t == z.
  by case: Ez => -[defP ->]; do [split=> [[][]|]; last by [left | right]].
have le_E_z: Real.ub E z by move=> _ /Dz->.
have supE: Real.has_sup E by split; exists z.
by split; apply/Dz; split; [apply: real_sup_le_ub | apply: real_sup_ub].
Qed.

Lemma IFR_then : P -> (IF P then x else y) == x.
Proof. by move=> haveP; case: IFR_cases => z [][]. Qed.

Lemma IFR_else : ~ P -> (IF P then x else y) == y.
Proof. by move=> notP; case: IFR_cases => z [][]. Qed.

End SelectR.

Instance IFR_Proper : Proper (iff ==> eqR ==> eqR ==> eqR) Real.select.
Proof.
move=> P1 P2 defP x1 x2 Dx y1 y2 Dy.
by case: IFR_cases => _ [][/defP-defP2 ->]; case: IFR_cases => _ [][? ->].
Qed.

(* Inverse and division. *)

Lemma invRE x : x != 0 -> x^-1 == Real.inv x.
Proof. exact: IFR_else. Qed.

Lemma divRR x : x != 0 -> x / x == 1.
Proof.
move=> nzx; case: x^-1 / IFR_cases => _ [][_ ->] //.
exact: (Real.mul_inverse_right R) nzx.
Qed.

Lemma pmulKR x y : x > 0 -> x^-1 * (x * y) == y.
Proof. by move=> /gtR_neq-x_nz; rewrite mulRCA mulRA (divRR x_nz) mul1R. Qed.

Lemma pmulRI x y z : x > 0 -> x * y == x * z -> y == z.
Proof. by move=> x_gt0 Dxy; rewrite -(pmulKR y x_gt0) Dxy pmulKR. Qed.

Lemma pmulIR x y z : x > 0 -> y * x == z * x -> y == z.
Proof. by rewrite -!(mulRC x); apply: pmulRI. Qed.

Local Notation leMl x_gt0 := (Real.mul_monotone R (ltRW x_gt0)).

Lemma invR_gt0 x : x > 0 -> x^-1 > 0.
Proof.
by move=> x_gt0 /(leMl x_gt0); rewrite (divRR (gtR_neq x_gt0)) mulR0 => /ltR01.
Qed.

Lemma leR_pmul2l x y z : x > 0 -> (x * y <= x * z <-> y <= z).
Proof.
move=> x_gt0; have invx_gt0: x^-1 > 0 by apply: invR_gt0.
by split=> [/(leMl invx_gt0) | /(leMl x_gt0)//]; rewrite !pmulKR.
Qed.

Lemma leR_pmul2r x y z : x > 0 -> (y * x <= z * x <-> y <= z).
Proof. by move=> x_gt0; rewrite -!(mulRC x); apply: leR_pmul2l x_gt0. Qed.

Lemma pmulR_rle0 x y : x > 0 -> (x * y <= 0 <-> y <= 0).
Proof. by move=> x_gt0; rewrite -(leR_pmul2l y 0 x_gt0) mulR0. Qed.

Lemma mulR_gt0 x y : x > 0 -> y > 0 -> x * y > 0.
Proof. by move=> xgt0 /(pmulR_rle0 _ xgt0). Qed.

Lemma mulRI x y z : x != 0 -> x * y == x * z -> y == z.
Proof.
move=> nz_x /(mulR_Proper (eqR_refl x^-1)).
by rewrite -!(mulRCA x) !mulRA divRR ?mul1R.
Qed.

Lemma mulIR x y z : x != 0 -> y * x == z * x -> y == z.
Proof. by rewrite -!(mulRC x); apply: mulRI. Qed.

Instance invR_Proper : Proper (eqR ==> eqR) Real.extended_inv.
Proof.
move=> x1 x2 Dx; have [x2_0 | nzx2] := reals_classic (x2 == 0).
  by rewrite ![_^-1]IFR_then ?Dx.
by apply: (mulRI nzx2); rewrite divRR // -Dx divRR // Dx.
Qed.

Lemma invR0 : (0 : R)^-1 == 0. Proof. exact: IFR_then. Qed.

Lemma invR1 : (1^-1 : R) == 1.
Proof. by have:= divRR neqR10; rewrite mul1R. Qed.

Lemma invRM x y : (x * y)^-1 == x^-1 / y.
Proof.
have [-> | nzx] := reals_classic (x == 0); first by rewrite !(invR0, mul0R).
have [-> | nzy] := reals_classic (y == 0); first by rewrite !(invR0, mulR0).
have nzxy: x * y != 0 by rewrite -(mulR0 x) => /(mulRI nzx).
by apply/(mulRI nzxy); rewrite mulRACA !divRR ?mulR1.
Qed.

Lemma invRN x : (- x)^-1 == - x^-1.
Proof.
have [-> | nz_x] := reals_classic (x == 0); first by rewrite !(oppR0, invR0).
have nz_negx: - x != 0 by rewrite -oppR0 => /oppR_inj.
by apply/(mulRI nz_negx); rewrite mulRN -mulNR oppRK !divRR.
Qed.

Lemma leR_pinv2 x y : x > 0 -> y > 0 -> (x^-1 <= y^-1 <-> y <= x).
Proof.
move=> xgt0 ygt0; rewrite -(leR_pmul2r _ _ xgt0).
by rewrite -(leR_pmul2r _ _ ygt0) -!mulRA pmulKR // (mulRC x) pmulKR.
Qed.

Lemma invR_neq0 x : x != 0 -> x^-1 != 0.
Proof. by move=> nz_x vx0; case: neqR10; rewrite -(divRR nz_x) vx0 mulR0. Qed.

Lemma invRK x : x^-1^-1 == x.
Proof.
have [-> | nz_x] := reals_classic (x == 0); first by rewrite !invR0.
by have nz_vx := invR_neq0 nz_x; apply/(mulIR nz_vx); rewrite mulRC !divRR.
Qed.

(**********************************************************)
(**      The least upper bound and derived operations.    *)
(**********************************************************)

Lemma supRE E : Real.has_sup E -> sup E == Real.sup E.
Proof. exact: IFR_then. Qed.

Lemma sup_ub E : Real.has_ub E -> Real.ub E (sup E).
Proof.
move=> ubE x Ex; have supE: Real.has_sup E by split; first by exists x.
by rewrite supRE //; apply: real_sup_ub.
Qed.

Lemma ge_sup_ub E x : Real.has_ub E -> sup E <= x -> Real.ub E x.
Proof. by move/sup_ub=> ubE leEx y /ubE-leyE; apply: leR_trans leEx. Qed.

Lemma sup_le_ub E x : Real.nonempty E -> Real.ub E x -> sup E <= x.
Proof.
move=> hasE leEx; have supE: Real.has_sup E by split; last exists x.
by rewrite supRE //; apply: real_sup_le_ub.
Qed.

Lemma sup_sup E : Real.has_sup E -> forall x, Real.ub E x <-> sup E <= x.
Proof.
by case=> hasE ubE x; split; [apply: sup_le_ub | apply: ge_sup_ub].
Qed.

Lemma sup_total E x : Real.nonempty E -> Real.down E x \/ sup E <= x.
Proof.
move=> hasE; have [|ubEx] := reals_classic (Real.down E x); first by left.
by right; apply: sup_le_ub => // y Ey; apply/ltRW=> lexy; case: ubEx; exists y.
Qed.

Instance nonempty_Proper : Proper (eqRset ==> iff) Real.nonempty.
Proof. by move=> E F defE; rewrite /Real.nonempty; setoid_rewrite defE. Qed.

Instance ub_Proper : Proper (eqRset ==> eqR ==> iff) Real.ub.
Proof. by move=> E F defE x1 x2 Dx; split=> ub_x y /defE/ub_x; rewrite Dx. Qed.

Instance down_Proper : Proper (eqRset ==> eqR ==> iff) Real.down.
Proof.
by move=> E F defE x1 x2 Dx; split=> -[y /defE]; rewrite (Dx, =^~ Dx); exists y.
Qed.

Instance has_ub_Proper : Proper (eqRset ==> iff) Real.has_ub.
Proof. by move=> E F dE; split=> -[y]; exists y; rewrite (dE, =^~ dE). Qed.

Instance has_sup_Proper : Proper (eqRset ==> iff) Real.has_sup.
Proof. by move=> E F dE; rewrite /Real.has_sup dE. Qed.

Instance sup_Proper : Proper (eqRset ==> eqR) sup.
Proof.
move=> E F eqEF; have [supE | trivE] := reals_classic (Real.has_sup E).
  by split; rewrite -sup_sup // (eqEF, =^~ eqEF) ?sup_sup // -eqEF.
by rewrite ![sup _]IFR_else -?eqEF.
Qed.

Lemma nonempty_Rdown E : Real.nonempty (Real.down E) <-> Real.nonempty E.
Proof. by split=> [[_ [x Ex _]] | [x Ex]]; do 2?exists x. Qed.

Lemma ub_Rdown E : eqRset (Real.ub (Real.down E)) (Real.ub E).
Proof.
move=> z; split=> leEz x => [Ex | [y Ey lexy]]; first by apply: leEz; exists x.
exact/(leR_trans lexy)/leEz.
Qed.

Lemma has_ub_Rdown E : Real.has_ub (Real.down E) <-> Real.has_ub E.
Proof. by rewrite /Real.has_ub; setoid_rewrite ub_Rdown. Qed.

Lemma has_sup_Rdown E : Real.has_sup (Real.down E) <-> Real.has_sup E.
Proof. by rewrite /Real.has_sup nonempty_Rdown has_ub_Rdown. Qed.

Lemma sup_Rdown E : sup (Real.down E) == sup E.
Proof.
have [supE | trivE] := reals_classic (Real.has_sup E).
  rewrite /eqR -!sup_sup ?has_sup_Rdown // (ub_Rdown _ _) sup_sup //.
  by split=> //; rewrite -(ub_Rdown _ _) sup_sup // has_sup_Rdown.
by do 2!case: (sup _) / IFR_cases => ? [][]//; rewrite has_sup_Rdown // => _ ->.
Qed.

(* Min and max.                                                         *)

Section MinMaxReal.

Variable x y : R.

Lemma leR_minl : min x y <= x.
Proof. by case: (min x y) / IFR_cases => _ [][lemx ->] //; apply/ltRW. Qed.

Lemma leR_minr : min x y <= y.
Proof. by case: (min x y) / IFR_cases => _ [][lemy ->]. Qed.
Hint Resolve leR_minl leR_minr : core.

Lemma ltR_min z : z < min x y <-> z < x /\ z < y.
Proof.
case: (min x y) / IFR_cases => _ [[lexy]|[ltyx]] ->.
  by split=> [ltzx|[]//]; split=> //; apply: ltR_le_trans ltzx lexy.
by split=> [ltzy|[]//]; split=> //; apply: ltR_trans ltzy ltyx.
Qed.

Lemma leR_min z : z <= min x y <-> z <= x /\ z <= y.
Proof.
split=> [lezm | [lezx lezy]]; first by split; apply: leR_trans lezm _.
by case: (min x y) / IFR_cases => _ [] [_ ->].
Qed.

Lemma leR_maxl : x <= max x y.
Proof. by case: (max x y) / IFR_cases => _ [][ltxm ->]//; apply/ltRW. Qed.

Lemma leR_maxr : y <= max x y.
Proof. by case: (max x y) / IFR_cases => _ [][leym ->]. Qed.
Hint Resolve leR_maxl leR_maxr : core.

Lemma ltR_max z : max x y < z <-> x < z /\ y < z.
Proof.
case: (max x y) / IFR_cases => _ [[leyx]|[ltxy]] ->.
  by split=> [ltxz | []//]; split=> //; apply: leR_lt_trans leyx ltxz.
by split=> [ltyz | []//]; split=> //; apply: ltR_trans ltxy ltyz.
Qed.

Lemma leR_max z : max x y <= z <-> x <= z /\ y <= z.
Proof.
split=> [lemz | [lexz leyz]]; first by split; apply: leR_trans lemz.
by case: (max x y) / IFR_cases => _ [] [_ ->].
Qed.

End MinMaxReal.

Instance min_Proper : Proper (eqR ==> eqR ==> eqR) min.
Proof. by move=> x1 x2 Dx y1 y2 Dy; rewrite /min Dx Dy. Qed.

Instance max_Proper : Proper (eqR ==> eqR ==> eqR) max.
Proof. by move=> x1 x2 Dx y1 y2 Dy; rewrite /max Dx Dy. Qed.

(**********************************************************)
(** Properties of the injections from N, Z, and Q into R  *)
(**********************************************************)

Lemma intRS n : n.+1 == n + 1.
Proof. by case: n => [|n] /=; rewrite ?add0R // addRC. Qed.

Lemma ltR0Sn n : 0 < n.+1.
Proof. by elim: n => // n IHn; apply: ltR_trans IHn _; apply: ltRS. Qed.
Arguments ltR0Sn n : clear implicits.

Lemma leR0n n : 0 <= n.
Proof. by case: n => // n; apply/ltRW/ltR0Sn. Qed.
Hint Resolve ltR0Sn leR0n : core.

Lemma intRN m : (- m)%R == - m.
Proof. by case: m => [[|n]|n]; rewrite ?oppR0 ?oppRK. Qed.

Lemma intRD1 m : (m + 1)%R == m + 1.
Proof.
case: m => [n|[|n]]; [by rewrite addrC intRS | by rewrite addRC subRR |].
by rewrite /= subn1 oppRD subRK.
Qed.

Lemma intRD m1 m2 : (m1 + m2)%R == m1 + m2.
Proof.
suffices intRDn m n: (m + n)%R == m + n.
  by case: m2 => // n; rewrite -[m1]opprK NegzE -opprD !(intRN, intRDn) oppRD.
elim: n => [|n IHn]; first by rewrite addr0 addR0.
by rewrite -addn1 PoszD addrA !intRD1 IHn addRA.
Qed.

Lemma intRB m1 m2 : (m1 - m2)%R == m1 - m2.
Proof. by rewrite intRD intRN. Qed.

Lemma intRB1 m : (m - 1)%R == m - 1.
Proof. exact: intRB. Qed.

Lemma intRM m1 m2 : (m1 * m2)%R == m1 * m2.
Proof.
suffices intMn m n: (m * n)%R == m * n.
  by case: m2 => n; rewrite ?NegzE ?mulrN ?intRN ?mulRN intMn.
rewrite -mulrzz -pmulrn; elim: n => [|n IHn]; first by rewrite mulR0.
by rewrite mulrS (PoszD 1%N) !intRD mulRDr mulR1 -IHn.
Qed.

Lemma intR_addbit m : m == (m %% 2%N)%Z + 2 * (m %/ 2%N)%Z.
Proof. by rewrite {1}(divz_eq m 2%:Z) mulRC addRC intRD intRM. Qed.

Lemma intR_leP m1 m2 : reflect (m1 <= m2) (m1 <= m2)%R.
Proof.
apply: (equivP idP); rewrite -subr_ge0 -subR_ge0 -intRB.
by case: (m2 - m1)%R => n; split; rewrite // -oppR0 leR_opp2 => /ltR0Sn.
Qed.

Lemma intR_ltP m1 m2 : reflect (m1 < m2) (m1 + 1 <= m2)%R.
Proof. by rewrite lez_addr1 ltNge; apply: (iffP idP) => /intR_leP. Qed.

(* Embedding the rationals.                                                  *)

Lemma ratRE a : ratRR a == numq a / denq a.
Proof.
by rewrite /ratRR /ratR unfold_in; case: eqP => // ->; rewrite invR1 mulR1.
Qed.

Lemma ratR_eq a : {r | a = (r.1%:Q / r.2.+1%:Q)%R & a * r.2.+1 == r.1}.
Proof.
have [d Dd] := denqP a; exists (numq a, d); rewrite -Dd ?divq_num_den //=.
by rewrite ratRE mulRAC mulRC (mulRC (numq a)) pmulKR ?Dd.
Qed.

Lemma ratR_leP a1 a2 : reflect (a1 <= a2) (a1 <= a2)%R.
Proof.
have [[r1 {3}-> Dr1] [r2 {3}-> Dr2]] := (ratR_eq a1, ratR_eq a2).
rewrite ler_pdivl_mulr ?ltr0Sn // mulrAC ler_pdivr_mulr ?ltr0Sn //.
rewrite -!intrM ler_int /=; apply: (equivP (intR_leP _ _)).
by rewrite !intRM -Dr1 -Dr2 mulRAC !leR_pmul2r.
Qed.

Lemma ratR_ltP a1 a2 : reflect (a1 < a2) (a1 < a2)%R.
Proof. by rewrite ltNge; apply: (iffP idP) => /ratR_leP. Qed.

Lemma ratR_lt0P a : reflect (0 < a) (0 < a)%R. Proof. exact: (ratR_ltP 0). Qed.

Lemma ratRz m : m%:Q = m :> R.
Proof. by rewrite /ratRR /ratR rpred_int numq_int. Qed.

Lemma ratR0 : 0%:Q = 0 :> R. Proof. by []. Qed.
Lemma ratR1 : 1%:Q = 1 :> R. Proof. by []. Qed.
Lemma ratR2 : 2%:Q = 2 :> R. Proof. by []. Qed.

Lemma ratRN a : (- a)%R == - a.
Proof. by rewrite !ratRE numqN denqN intRN mulNR. Qed.

Lemma ratRMn a n : (a * n%:Q)%R == a * n.
Proof.
have [[r1 Da Dr1] [r2 Dan Dr2]] := (ratR_eq a, ratR_eq (a * n%:Q)).
apply/(pmulIR (ltR0Sn r2.2))/(pmulIR (ltR0Sn r1.2)).
rewrite {}Dr2 -2!(mulRAC _ r1.2.+1) {}Dr1 -!intRM -!ratRz !intrM.
apply/eqR_congr/(congr1 ratRR)/(canRL (divfK _)); first by rewrite intr_eq0.
by rewrite mulrAC -{}Dan {}Da  mulrAC divfK ?intr_eq0.
Qed.

Lemma ratRD a1 a2 : (a1 + a2)%R == a1 + a2.
Proof.
have [[r1 {2}-> Dr1] [r2 {2}-> Dr2]] := (ratR_eq a1, ratR_eq a2).
apply/(pmulIR (ltR0Sn r2.2))/(pmulIR (ltR0Sn r1.2)).
rewrite !mulRDl (mulRAC a1) Dr1 Dr2 -!ratRMn !mulrDl mulrAC !divfK ?intr_eq0 //.
by rewrite -!intrM -intrD ratRz intRD !intRM.
Qed.

Lemma ratRM a1 a2 : (a1 * a2)%R == a1 * a2.
Proof.
have [[r1 {2}-> Dr1] [r2 {2}-> Dr2]] := (ratR_eq a1, ratR_eq a2).
apply/(pmulIR (ltR0Sn r1.2))/(pmulIR (ltR0Sn r2.2)).
rewrite -2!ratRMn (mulRAC a1) -mulRA {}Dr1 {}Dr2 -mulrA mulrACA.
by rewrite !divfK ?intr_eq0 // -intrM ratRz intRM.
Qed.

Lemma ratR_pinv a : (0 < a)%R -> a^-1%R == a^-1.
Proof.
move=> a_gt0; have aR_gt0: 0 < a by rewrite -ratR0; apply/ratR_ltP.
apply: (pmulIR aR_gt0); rewrite -ratRM mulRC (divRR (gtR_neq aR_gt0)).
by rewrite mulVf ?ratR1 ?gt_eqF.
Qed.

(* The floor function                                                   *)

Fact ub_floor_set x : Real.ub (floor_set x) x.
Proof. by move=> y [m]. Qed.
Hint Resolve ub_floor_set : core.

Fact has_ub_floor_set x : Real.has_ub (floor_set x).
Proof. by exists x. Qed.
Hint Resolve has_ub_floor_set : core.

Let has_floor_max x : Real.nonempty (floor_set x) -> x < floor x + 1.
Proof.
move=> has_x0 le_xx.
have inc_lex m (lemx : m <= x): (m + 1)%R <= x.
  by apply: leR_trans le_xx; rewrite intRD1 leR_add2r; apply: sup_ub.
have [[_ [m]] | ] := sup_total (floor x - 1) has_x0; last exact: ltPR.
do 2!move/inc_lex; rewrite -/intRR -{2}[m](addrK 1%R) intRB1 leR_add2r => lem2x.
by case/leR_lt_trans/(_ (ltRS _)); rewrite -intRD1; apply: sup_ub.
Qed.

Fact nonempty_floor_set x : Real.nonempty (floor_set x).
Proof.
have [le0x | lex0] := leR_total 0 x; first by exists 0%N.
have ub_nx0: Real.has_sup (floor_set (- x)).
  by split=> //; exists 0%N; split; rewrite -leR_opp2 oppRK oppR0.
have [[_ [m _] lexm] | /ltPR//] := sup_total (floor (- x) - 1) (proj1 ub_nx0).
pose m1 := (m + 1)%R; pose m2 := (m1 + 1)%R.
exists (- m2)%R; split; move: lexm; rewrite -/intRR -(addRK m 1) leR_add2r.
rewrite -{2}(oppRK x) intRN leR_opp2 -{2}(subRK (- x) 1) !intRD1 leR_add2r.
apply/leR_trans/ltRW; rewrite -(leR_add2r 1) subRK.
by apply: has_floor_max; case: ub_nx0.
Qed.
Hint Resolve nonempty_floor_set : core.

Lemma has_sup_floor_set x : Real.has_sup (floor_set x). Proof. by []. Qed.
Hint Resolve has_sup_floor_set : core.

Instance floor_Proper : Proper (eqR ==> eqR) floor.
Proof.
move=> x1 x2 Dx; apply: sup_Proper => y.
by split=> -[m int_m_x]; split; rewrite (Dx, =^~ Dx).
Qed.

Instance range1_Proper : Proper (eqR ==> eqR ==> iff) range1.
Proof. by move=> x1 x2 Dx y1 y2 Dy; rewrite /range1 Dx Dy. Qed.

Lemma range1_floor x : range1 (floor x) x.
Proof. by split; [apply: sup_le_ub | apply: has_floor_max]. Qed.

Lemma int_floor x : exists m : int, floor x == m.
Proof.
case: (range1_floor x); set y := floor x => leyx ltxy1; pose h2 : R := 2^-1.
have h2gt0: 0 < h2 by apply: invR_gt0.
have lty2y: y - h2 < y by rewrite -subR_ge0 addRC addKR -oppR0 leR_opp2.
have [[_ [m lemx] ley2m] | //] := sup_total (y - h2) (nonempty_floor_set x).
rewrite -/intRR in lemx ley2m; exists m; split; last exact: sup_ub.
pose m2 := m + h2; have leym2: y <= m2 by rewrite -(leR_add2r (- h2)) addRK.
apply: sup_le_ub => // _ [m1 lem1x]; rewrite -(leR_add2r 1) -!intRD1.
apply/intR_leP/intR_ltP; have:= h2gt0; rewrite -(leR_add2l m2) addR0.
rewrite -addRA -mul2R (divRR (gtR_neq ltR02)) -(intRD1 m).
exact/leR_lt_trans/(ge_sup_ub _ leym2).
Qed.

Lemma range1z_inj x m1 m2 : range1 m1 x -> range1 m2 x -> m1 = m2.
Proof.
move=> [m1x x_m1] [m2x x_m2].
wlog suffices: m1 m2 m1x {x_m1 m2x} x_m2 / (m1 <= m2)%R.
  by move=> IH; apply/eqP; rewrite eq_le !IH.
rewrite -(ler_add2r 1); apply/intR_ltP.
by rewrite intRD1; apply: leR_lt_trans x_m2.
Qed.

Lemma range1zz m : range1 m m.
Proof. by split; rewrite // -intRD1; apply/intR_ltP. Qed.

Lemma range1z_floor m x : range1 m x <-> floor x == m.
Proof.
gen have IHm: m / floor x == m -> range1 m x.
  by move <-; apply: range1_floor.
split=> [int_m_x|/IHm//]; have [m1 Dm1] := int_floor x.
by rewrite -(range1z_inj (IHm m1 Dm1) int_m_x).
Qed.

Lemma floor_znat m : floor m == m.
Proof. by rewrite -(range1z_floor m m); apply: range1zz. Qed.

Lemma find_range1z x : exists m : int, range1 m x.
Proof.
by have [m Dm] := int_floor x; exists m; case: (range1z_floor m x); auto.
Qed.

Lemma ratR_dense x y : x < y -> exists2 a : rat, x < a & a < y.
Proof.
move=> ltxy; pose z := y - x; have z_gt0: z > 0 by rewrite subR_le0.
have [[d|n] [ledv ltvd1]] := find_range1z z^-1; last first.
  case: ltvd1; apply: ltRW; apply: leR_lt_trans (invR_gt0 z_gt0).
  by rewrite NegzE intRN intRS oppRD subRK -subR_ge0 add0R oppRK.
set d1 : R := d.+1; have d1gt0: d1 > 0 by apply: ltR0Sn.
have [m [lemx ltxm1]] := find_range1z (d1 * x).
exists ((m + 1)%:Q / d.+1%:Q)%R; rewrite -(leR_pmul2r _ _ d1gt0) -ratRMn.
  by rewrite divfK ?intr_eq0 // mulRC ratRz intRD1.
rewrite divfK ?intr_eq0 // ratRz intRD1.
rewrite -(addKR x y) addRC -addRA -/z mulRC mulRDr -(divRR (gtR_neq z_gt0)).
move: lemx; rewrite -(leR_add2r (d1 * z)); apply: ltR_le_trans.
by rewrite leR_add2l mulRC leR_pmul2l // /d1 intRS.
Qed.

Instance imageR_Proper (S : Real.structure) :
  Proper
    (pointwise_relation S eqR ==> pointwise_relation S iff ==> eqR ==> iff)
  Real.image.
Proof.
move=> f1 f2 Df E1 E2 defE y1 y2 Dy.
by split=> -[x /defE-Ex Dfx]; exists x => //; rewrite (Df, =^~Df) -Dfx Dy.
Qed.

End RealLemmas.

Arguments neqR10 R _ : clear implicits.
Arguments ltR01 R _ : clear implicits.
Arguments ltR02 R _ : clear implicits.
Arguments ltRS {R} x _.
Arguments ltPR {R} x _.
Arguments ltR0Sn R n _ : clear implicits.
Arguments intR_leP {R m1 m2}.
Arguments intR_ltP {R m1 m2}.
Arguments ratR_leP {R a1 a2}.
Arguments ratR_ltP {R a1 a2}.

Hint Resolve eqR_refl leRR ltRW : core.

Existing Instance real_equality.
Existing Instance real_equality_Transitive.
Existing Instance real_equality_Symmetric.
Existing Instance real_equality_Reflexive.
Existing Instance real_equality_relation.
Existing Instance leR_Proper.
Existing Instance addR_Proper.
Existing Instance oppR_Proper.
Existing Instance mulR_Proper.
Existing Instance invR_Proper.
Existing Instance IFR_Proper.
Existing Instance nonempty_Proper.
Existing Instance ub_Proper.
Existing Instance has_ub_Proper.
Existing Instance has_sup_Proper.
Existing Instance sup_Proper.
Existing Instance min_Proper.
Existing Instance max_Proper.
Existing Instance range1_Proper.
Existing Instance floor_Proper.
Existing Instance imageR_Proper.


Require Export syntax sos reductions.

(** * Classic Hoare logic deductive system. This proof systems is used to handle the [atomic] command, since this one does not admit parallel constructions. *)

Inductive triple (G:Env) : assrt -> stmt -> assrt -> Prop :=
| triple_Skip:
  forall P,
    triple G P skip P
| triple_Assgn :
  forall v a P,
    (forall s, G s (upd s v (aeval s a))) ->
    triple G (assg_subs v a P) (v ::= a) P
| triple_If:
  forall P c1 c2 Q b,
    triple G (([⊤]b)[∧]P) c1 Q ->
    triple G (([⊥]b)[∧]P) c2 Q ->
    triple G P (ifb b then c1 else c2 fi) Q
| triple_Sequence:
  forall c1 c2 P K Q,
    triple G P c1 K ->
    triple G K c2 Q ->
    triple G P (c1;c2) Q
| triple_Conseq:
  forall P P' Q Q' G' c,
    (assrtImp P P') ->
    (assrtImp Q' Q) ->
    (rstImp G' G) ->
    triple G' P' c Q' ->
    triple G P c Q
| triple_Loop :
  forall P b c,
    triple G (([⊤]b)[∧](P)) c P ->
    triple G P (while b do c end) (([⊥]b)[∧]P).

(**  * Deductive system for the rely/guarantee principle *)
Inductive triple_rg (R G:StR) : assrt -> stmt -> assrt -> Prop :=
| RSkip:
  forall (P Q:assrt),
    Reflexive G ->
    stable R P ->
    stable R Q ->
    P[→]Q ->
    triple_rg R G P skip Q
| RAsgn :
  forall v a P Q,
    stable R P ->
    stable R Q ->
    (forall s, G s (upd s v (aeval s a))) ->
    (forall s, P s -> Q (upd s v (aeval s a))) ->
    triple_rg R G P (v ::= a) Q
| RWait :
  forall (P Q:assrt) c b,
    Reflexive G ->
    stable R ([⊤]b) ->
    (forall x y, star _ G x y -> G x y) ->
    stable R P ->
    stable R Q ->
    (*G_val P c G Q -> *)
    triple G P c Q ->
    triple_rg R G P (wait b do c end) Q
| RIf:
  forall P c1 c2 Q b,
    Reflexive G ->
    stable R (assrtT b) ->
    stable R (assrtF b) ->
    stable R P ->
    triple_rg R G (([⊤]b)[∧]P) c1 Q ->
    triple_rg R G (([⊥]b)[∧]P) c2 Q ->
    triple_rg R G P (ifb b then c1 else c2 fi) Q
| RSequence:
  forall c1 c2 P K Q,
    Reflexive G ->
    triple_rg R G P c1 K ->
    triple_rg R G K c2 Q ->
    triple_rg R G P (c1;c2) Q
| RConseq:
  forall (R' G':Env) P P' Q Q' c,
    triple_rg R' G' P' c Q' ->
    assrtImp P P' ->
    assrtImp Q' Q ->
    rstImp R R' ->
    rstImp G' G ->
    triple_rg R G P c Q
| RLoop :
  forall P b c,
    Reflexive G ->
    stable R (assrtT b) ->
    stable R (assrtF b) ->
    stable R P ->
    triple_rg R G (([⊤]b)[∧](P)) c P ->
    triple_rg R G P (while b do c end) (([⊥]b)[∧]P)
| RConcur :
 forall (Rl Rr Gl Gr:StR) P Q1 Q2 Q cr cl,
   Reflexive Gl ->
   Reflexive Gr ->
   rstImp R (rstAnd Rl Rr) ->
   rstImp (rstOr Gl Gr) G ->
   rstImp (rstOr Rl Gl) Rr ->
   rstImp (rstOr Rr Gr) Rl ->
   (assrtAnd Q1 Q2)[→]Q ->
   stable (rstOr Rr Gr) Q1 ->
   stable (rstOr Rl Gl) Q2 ->
   stable (rstOr Rr Gr) P ->
   stable (rstOr Rl Gl) P ->
   triple_rg Rl Gl P cl Q1 ->
   triple_rg Rr Gr P cr Q2 ->
   triple_rg R G P (par cl with cr end) Q.

Notation "{{  R  , G  }}  ⊢  {{  P  }}  c {{  Q  }}" :=
  (triple_rg R G P c Q)(at level 40).

Notation "{{  R  , G  }}  ⊧  {{  P  }}  c {{  Q  }}" :=
  (HG_val R G P c Q)(at level 40).


(* In this file we prove the forward and backward directions of Dilworth's
   decomposition theorem. Forward direction is proved in Section DilworthA
   and the backward direction is proved in Section DilworthB.
   1. Theorem DilworthA: It states the forward implication of Dilworth's Thm.
   2. Theorem DilworthB: States the backward implication of Dilworth's Thm.

   DilworthA and DilworthB are used to prove the main statement of Dilworth's
   Thm in the File FiniteDilworth.v  *)

Require Export FPO_Facts2.

Section DilworthA.
  Variable U: Type.

Definition DilworthA_statement:=
  fun (P: FPO U)=>forall (n m :nat)(cv: Ensemble (Ensemble U))(a: Ensemble U),
               Is_a_chain_cover P cv -> Is_an_antichain_in P a ->
               cardinal _  cv n -> cardinal _  a m ->
               ~(m > n).

Theorem DilworthA: forall (P: FPO U), DilworthA_statement P.
Proof. {  intro P. unfold DilworthA_statement.
        intros n m cv la. intros.  intro.
        pose (R:= fun (x:U) (y: Ensemble U) => In _ y x).
        assert (H4: (exists (x y: U) (z: Ensemble U) ,
                        In _ la x /\ In _ la y /\ In _ cv z /\ x<>y /\ (R x z /\ R y z))).
        { apply Pigeon_Relation with
          (U:= U) (V:= Ensemble U) (A:= la) (B:= cv) (R:=R) (m:=n) (n:=m).
          { destruct H.  intro x. intro. unfold R. apply H4. apply H0. tauto. }
          { auto. }
          { auto. }
          { auto. }
        }

        destruct H4 as [x H4]. destruct H4 as [y H4]. destruct H4 as [chain H4].
        destruct H4 as [ H4a H4]. destruct H4 as [ H4b H4]. destruct H4 as [ H4c H4].
        destruct H4 as [ H4d H4]. unfold R in H4.
        assert (H5: Is_a_chain_in P chain). { destruct H. apply H. auto. }
        assert (H6: x = y). { apply NoTwoCommon with (P:= P)(X:=chain)(Y:= la).
          auto. auto. unfold Included; intros; destruct H6; tauto.
          unfold Included; intros; destruct H6; tauto. }
        absurd (x=y);tauto.  }  Qed.

End DilworthA.

Section DilworthB.

Variable U : Type.

Definition PO_Above_Carrier (P: FPO U) (e: Ensemble U): Ensemble U:=
  fun x: U =>( (Inhabited _ e /\ Included _ e (Carrier_of _ P))-> (In _ (Carrier_of _ P) x /\
              exists y:U, In _ e y /\ Rel_of _ P y x)) /\ In _ (Carrier_of _ P) x .

Definition PO_Below_Carrier (P: FPO U)(e : Ensemble U): Ensemble U :=
    fun x: U =>( (Inhabited _ e /\ Included _ e (Carrier_of _ P))-> (In _ (Carrier_of _ P) x /\
              exists y:U, In _ e y /\ Rel_of _ P x y)) /\ In _ (Carrier_of _ P) x .

Lemma la_in_P_Above: forall (P: FPO U)(la: Ensemble U), Is_an_antichain_in P la ->
                                                       Included _ la (PO_Above_Carrier P la).
Proof. {
intros. unfold Included. intro. intro. unfold In.  unfold PO_Above_Carrier.
split. split. destruct H. destruct H as [Ha H]. unfold Included in Ha.
apply Ha. assumption.  exists x. split. assumption.  assert (H2: Order U (Rel_of U P)).
apply PO_cond2. destruct H2. unfold Reflexive in H2. apply H2.

destruct H. destruct H as [Ha H]. unfold Included in Ha.
apply Ha. assumption. } Qed.

Lemma la_in_P_Below: forall (P: FPO U)(la: Ensemble U), Is_an_antichain_in P la ->
                                                       Included _ la (PO_Below_Carrier P la).
Proof. {
    intros. unfold Included. intro. intro. unfold In.  unfold PO_Below_Carrier.
split. split. destruct H. destruct H as [Ha H]. unfold Included in Ha.
apply Ha. assumption.  exists x. split. assumption.  assert (H2: Order U (Rel_of U P)).
apply PO_cond2. destruct H2. unfold Reflexive in H2. apply H2.

destruct H. destruct H as [Ha H]. unfold Included in Ha.
apply Ha. assumption. } Qed.

Lemma Inhabited_Above_Carrier:
      forall (P: FPO U)(e: Ensemble U), Inhabited U (PO_Above_Carrier P e).
Proof. {
    intros. elim (EM (Inhabited _ e /\ Included _ e (Carrier_of _ P))).
   Focus 2.
    intro. Print Inhabited. assert (H1: Inhabited _ (Carrier_of _ P)).
   apply PO_cond1. destruct H1. apply Inhabited_intro with (x:=x).
   unfold In. unfold PO_Above_Carrier.
   split.
   apply or_to_imply . left. assumption. assumption.
   intro. destruct H. destruct H. exists x. unfold In.  unfold PO_Above_Carrier.
   split.
   intro. split. apply H0. assumption. exists x. split. assumption.
   assert (H2: Order U (Rel_of U P)). apply PO_cond2. destruct H2. apply H2.

   apply H0. assumption.  } Qed.

 Lemma Finite_Above_Carrier:
   forall (P: FPO U)(e: Ensemble U),  Finite U ( PO_Above_Carrier P e).
 Proof. {
   intros. apply Finite_downward_closed with (A:= Carrier_of _ P).
   apply FPO_cond. unfold Included. intros. unfold In in H. unfold PO_Above_Carrier in H.
   apply H.  } Qed.

 Definition PO_Above (P: FPO U) (e: Ensemble U): FPO U :=
   {| PO_of := {| Carrier_of := (PO_Above_Carrier P e);
      Rel_of := Rel_of _ P ;
      PO_cond1:= Inhabited_Above_Carrier P e;
      PO_cond2:= PO_cond2 _ P |};
      FPO_cond:= Finite_Above_Carrier P e|}.
 Check PO_Above.

 Lemma Inhabited_Below_Carrier:
   forall (P: FPO U)(e: Ensemble U), Inhabited U (PO_Below_Carrier P e).
 Proof. {
     intros. elim (EM (Inhabited _ e /\ Included _ e (Carrier_of _ P))).
     Focus 2.
   intro. Print Inhabited. assert (H1: Inhabited _ (Carrier_of _ P)).
   Print PO. apply PO_cond1. destruct H1. apply Inhabited_intro with (x:=x).
   unfold In. unfold PO_Below_Carrier.
   split.
   apply or_to_imply . left. assumption. assumption.
   intro. destruct H. destruct H. exists x. unfold In.  unfold PO_Below_Carrier.
   split.
   intro. split. apply H0. assumption. exists x. split. assumption.
   assert (H2: Order U (Rel_of U P)). apply PO_cond2. destruct H2. apply H2.

   apply H0. assumption.  } Qed.

 Lemma Finite_Below_Carrier:
   forall (P: FPO U)(e: Ensemble U), Finite U ( PO_Below_Carrier P e).
 Proof. {
   intros. apply Finite_downward_closed with (A:= Carrier_of _ P).
   apply FPO_cond. unfold Included. intros. unfold In in H. unfold PO_Below_Carrier in H.
   apply H.  } Qed.

 Definition PO_Below (P: FPO U) (e: Ensemble U): FPO U :=
   {| PO_of := {| Carrier_of := (PO_Below_Carrier P e);
      Rel_of := Rel_of _ P ;
      PO_cond1:= Inhabited_Below_Carrier P e;
      PO_cond2:= PO_cond2 _ P |};
      FPO_cond:= Finite_Below_Carrier P e
   |}.
 Check PO_Above.

(* the following two lemma helps us give a macro for expression "PO_Above P a" later in
    the proofs. It helps us extract a name P_Above such that "P_Above = PO_Above P a" *)
 Lemma exists_above: forall (P: FPO U)(e: Ensemble U ),
                     exists (p1:FPO U), p1 = PO_Above P e.
   Proof. intros. exists (PO_Above P e). reflexivity. Qed.
 Lemma exists_below: forall (P: FPO U)(e: Ensemble U),
                     exists (p1:FPO U), p1 = PO_Below P e.
 Proof. intros. exists (PO_Below P e). reflexivity. Qed.

 Lemma Above_or_Below_la:  forall (P: FPO U) (la: Ensemble U),
     Is_largest_antichain_in P la ->
     (forall x:U, In _ (Carrier_of _ P) x ->
             (exists y: U, In _ la y /\ ( (Rel_of _ P) x y \/ (Rel_of _ P) y x))).

   Proof. { intros P la. intro.
            pose (C:= Carrier_of _ P).
            pose (R:= Rel_of _ P).
            assert (T: exists n:nat, cardinal _ la n).
            { apply finite_cardinal. eapply Finite_downward_closed with (A:= C).
              apply FPO_cond. apply H.  } destruct T as [n T].

            assert (forall x:U, In _ C x -> (exists y: U, In _ la y /\ ( R x y \/ R y x))).
            { destruct H.  intros.
              elim ( classic ( exists y : U, In U la y /\ (R x y \/ R y x) )).
              {tauto. }
              { intro.
                assert (H3: forall y: U, In _ la y -> ~ ( R x y \/ R y x)).
                { assert ( forall y: U, ~ (In U la y /\ (R x y \/ R y x))).
                  { apply Negation8. apply H2. }
                  intro y. cut ( ~ In _ la y \/ ~ ( R x y \/ R y x)). tauto.
                  cut ( ~ (In U la y /\ (R x y \/ R y x))). tauto.  auto.  }
                assert (Ha3: forall y: U, In _ la y -> ~ (R y x \/ R x y )).
                { intros. intro. assert ( R x y \/ R y x). tauto. generalize H6.
                  apply H3. auto.  }
                assert (H4: ~ In _ la x).
                { intro. apply H2. exists x. split. auto. left.  apply PO_cond2. }

                pose (la':= Add _ la x).
                assert (H5: cardinal _ la' (S n)).
                { eapply card_add; tauto.  }

                assert (H6: Is_an_antichain_in P la').
                { unfold Is_an_antichain_in.
                  split.
                  { split.  unfold Included. intros.
                    unfold la' in H6. destruct H6. unfold Is_an_antichain_in in H.
                    apply H. auto. destruct H6. apply H1.
                    eapply Inhabited_intro with (x:=x). unfold la'. unfold In.
                    unfold Add. apply Union_intror. Print Singleton.
                    auto with sets.  }
                  { intros x0 y0. intros. unfold Included in H6.
                    assert (H8: In _ la' x0).
                    { apply H6. auto with sets.  }
                    assert (H9: In _ la' y0).
                    { apply H6. auto with sets.  }
                    unfold la' in H8.  unfold la' in H9.
                    unfold In in H8. unfold In in H9. unfold Add in H8. unfold Add in H9.
                    destruct H8; destruct H9.
                    { apply H. unfold Included. intros.
                      destruct H10; auto with sets. tauto. }
                    { destruct H9. absurd (Rel_of U P x0 x \/ Rel_of U P x x0).

                      unfold R in Ha3. eapply Ha3. auto. tauto.  }
                    { destruct H8. absurd (Rel_of U P x x1 \/ Rel_of U P x1 x).
                      apply H3. auto. auto. }
                    { destruct H8; destruct H9. reflexivity. }     } }

           assert (H7: S n <= n).
           { eapply H0 with (e1:= la');tauto.  }
           assert (H8: n <= S n).
           { auto with arith. }
           assert (H9: S n = n ). auto with arith.
           assert (S n <> n).
           { auto with arith. }
           absurd ( S n = n);tauto. }   }
            unfold C in H0. unfold R in H0. exact H0.  } Qed.

Lemma P_Above_or_P_Below:
  forall (P: FPO U) (la: Ensemble U), Is_largest_antichain_in P la ->
               (Carrier_of _ P) =  Union _ (PO_Above_Carrier P la ) (PO_Below_Carrier P la).
Proof. { intros. apply Extensionality_Ensembles.  unfold Same_set.
       pose (C:= Carrier_of _ P).
       pose (R:= Rel_of _ P).
       assert (T: exists n:nat, cardinal _ la n).
       { apply finite_cardinal. eapply Finite_downward_closed with (A:= C).
         apply FPO_cond. apply H.  } destruct T as [n T].

       assert (forall x:U, In _ C x -> (exists y: U, In _ la y /\ ( R x y \/ R y x))).
       { unfold C. unfold R. apply Above_or_Below_la.   auto. }

       split.
       { unfold Included. intros.
         assert (H2:  (exists y: U, In _ la y /\ ( R x y \/ R y x))).
         { apply H0.  auto. } destruct H2 as [y H2]. destruct H2 as [H2 H3].
         elim H3.
         { intro. apply Union_intror. unfold In. unfold PO_Below_Carrier.
           split.
           { intro. split.  auto. exists y; tauto.  }
           { tauto. } }
         { intro. apply Union_introl. unfold In. unfold PO_Above_Carrier.
           split.
           { intro. split.  auto. exists y; tauto.  }
           { tauto. } }  }
       { unfold Included. intros. destruct H1. unfold In in H1.
         unfold PO_Above_Carrier in H1. apply H1. unfold In in H1.
         unfold PO_Below_Carrier in H1. apply H1. }    }  Qed.

Lemma No_smaller_element_Above : forall (P: FPO U) (la: Ensemble U) (x a: U),
                                     Is_largest_antichain_in P la ->
                                     In _ (Carrier_of _ (PO_Above P la)) x ->
                                     (In _ la a /\  Rel_of _ P x a ) -> x=a .
Proof. { intros. unfold In in H0. simpl in H0.  unfold PO_Above_Carrier in H0.
        destruct H0.
        assert  (In U (Carrier_of U P) x /\ (exists y : U, In U la y /\ Rel_of U P y x)).
        apply H0. split. apply H. apply H. destruct H3. destruct H4 as [y H4].
        assert (Order _ (Rel_of _ P)).
        { apply PO_cond2. } destruct H5.
        assert (Rel_of _ P y a).
        { Print Transitive. eapply H6 with (y:=x);tauto.   }
        destruct H. unfold Is_an_antichain_in in H. destruct H.
        assert (y=a).
        { apply H10. unfold Included. intros. destruct H11;tauto. left. auto.  }
        assert (Rel_of _ P a x /\ Rel_of _ P x a).
        { rewrite H11 in H4. tauto. }
        apply H7;tauto. } Qed.

Lemma No_bigger_element_Below : forall (P: FPO U)(la: Ensemble U) (x a: U),
                                     Is_largest_antichain_in P la ->
                                     In _ (Carrier_of _ (PO_Below P la)) x ->
                                     (In _ la a /\  Rel_of _ P a x ) -> x=a .
Proof.  { intros. unfold In in H0. simpl in H0.  unfold PO_Below_Carrier in H0.
        destruct H0.
        assert  (In U (Carrier_of U P) x /\ (exists y : U, In U la y /\ Rel_of U P x y)).
        apply H0. split. apply H. apply H. destruct H3. destruct H4 as [y H4].
        assert (Order _ (Rel_of _ P)).
        { apply PO_cond2. } destruct H5.
        assert (Rel_of _ P a y).
        { Print Transitive. eapply H6 with (y:=x);tauto.   }
        destruct H. unfold Is_an_antichain_in in H. destruct H.
        assert (y=a).
        { apply H10. unfold Included. intros. destruct H11;tauto. right. auto.  }
        assert (Rel_of _ P a x /\ Rel_of _ P x a).
        { rewrite H11 in H4. tauto. }
        apply H7;tauto. } Qed.

Lemma PO_Below_inside_P: forall (P: FPO U) (la: Ensemble U ),
                             Is_an_antichain_in  P la -> (la <> (Maximal_elements_of  P))->
                             Inside _ (PO_Below P la) P.
Proof. {
    intros P la H. intro CASE1b.
    assert(H0: True). auto.
    assert(AlwaysTrue: Inhabited U la /\ Included U la (Carrier_of U P)).
    split. destruct H. apply H. destruct H. apply H.

elim exists_above with (P:=P) (e :=la). (* We wish to say let P_Above:= (PO_Above P la)*)
intros P_Above. intro H1.
elim exists_below with (P:=P) (e :=la).
intros P_Below. intro H2. (* at this point we have P_Above and P_Below with  desired property *)

unfold Inside.
split.
Focus 2.
* simpl. reflexivity.
  unfold Strict_Included. split.
  unfold Included.  intros. destruct H3. assumption.

(* WE need to prove that there is some x in P which is not present in P_Below *)
(* For this we use the fact that la <> Maximal_elements_of. *)
apply Not_equal_sets in CASE1b.

elim CASE1b.
  - intro. (* 1st_HalfCASE: when there is a y in la and not present in Maximal *)
  destruct H3 as [y H3]. (* we have a y from la but not in maximal *)
  destruct H3 as [H3a H3b].
  unfold In in H3b. unfold Maximal_elements_of in H3b.

assert(H4: In U (Carrier_of _ P) y). destruct H. destruct H.
unfold Included in H. apply H. assumption.

(* We wish to  prove the positive of following fact *)
(* Infact if following doesnot happen then y must be a maximal element which contradicts*)
(* Following claim says that there is some x greater than  y and not equal to y *)
assert (H3: exists x: U, In _ (Carrier_of _ P) x /\ y<>x /\ (Rel_of _ P)  y x ).
{ elim (EM ( exists x: U, In _ (Carrier_of _ P) x /\ y<>x /\ (Rel_of _ P)  y x )).
Focus 2.
intro. absurd (Is_a_maximal_element  P y). assumption.
unfold Is_a_maximal_element. (* apply maximal_element_cond. *) split.  assumption.
intro. elim H3. destruct H5 as [x H5]. exists x. assumption.
trivial. }
(* at this point we have H3 as a crucial fact *)
(* this helps us get a point x0 strictly above y *)
(* we can have a point x0 above y and not equal to y
   using this we proceed to prove that it (i.e, x0) doesnot belong to P_Below *)
(* we prove this using contradiction *)
destruct H3 as [x0 H3]. (* *)
assert (H5: ~ In _ (PO_Below_Carrier P la) x0 ).
intro. unfold In in H5. destruct H5. destruct H5. clear H6.
apply AlwaysTrue. clear H6. destruct H7 as [y0 H6].
destruct H3 as [H3c H3]. destruct H3 as [H3d H3].
destruct H6 as [H6a H6].
assert ( H7: Rel_of U P  y y0).  (* we prove that y R y0 using transitivity *)
assert (H8: Order U (Rel_of U P)).
apply PO_cond2. destruct H8. apply H8 with (y:= x0).
assumption. assumption.
(* now using antichain condition H we prove that y0= y *)
destruct H.
assert (H9: y0 = y). apply H8. unfold Included. intros.
destruct H9. assumption. assumption. right. assumption.
(* now we prove R  x0 y by rewriting *)
assert (H10: Rel_of U P x0 y ). rewrite <- H9. assumption.
(*using antisymmetricity we prove that y= x0 because y R x0 and x0 R y are true *)
assert (H11: Order U (Rel_of U P )).
apply PO_cond2. destruct H11. assert (H14: y= x0).
apply H13. assumption. assumption. (*now we have contradiction as x0<>y and x0=y *)
absurd (y=x0). assumption. assumption.
(* here we already proved that x0 is not in P_Below *)
(* Moreover we know that x0 is in P *)
(* hence we can prove that P_Below is not same as P using Lemma Sets_not_equal *)

(* Which proves that P_Below is strictly included in P *)
apply (Sets_not_equal). right. exists x0. split.
 assumption. destruct H3 as [H3c H3]. assumption.

           (* the 1st_halfCASE is OVER HERE *)
  - intro.  (* 2nd HalfCASE when y belongs to Maximal but not to la *)
    destruct H3 as [y H3]. destruct H3 as [H3a H3b].
    assert (H4: ~ In _ (PO_Below_Carrier P la) y). intro.
    (* assuming y belongs to P_Below we produce contradiction *)
    destruct H3. destruct H3. clear H4. apply AlwaysTrue. clear H4. destruct H5 as [x H4].
    destruct H4 as [H4a H4b].
    { elim (EM (x=y)). (* we produce contradiction in both cases *)
    Focus 2.
    intro. (*CASE x<>y   in this case we prove y is not maximal *)
    destruct H3a.
    assert (H6a: (exists y0 : U, In U (Carrier_of U P) y0 /\ y <> y0 /\ Rel_of U P y y0)).
    exists x.
    split. destruct H. destruct H.  unfold Included in H. apply H. assumption.
    split. intro. symmetry in H7. elim H4.  assumption. assumption.
    (* In this case H6 and H6a are contradictory *)
    elim H6. assumption.
    intro. (*CASE x=y in this case since x belongs la hence y belongs la which contradicts H3b*)
    rewrite H4 in H4a. elim H3b. assumption.  }
    (* here we could prove that y is not in P_Above, hence it is strictIncluded in P  *)
    apply (Sets_not_equal). right. exists y.
    split.  simpl. assumption.
    destruct H3a. assumption.   } Qed.

Lemma PO_Above_inside_P: forall (P: FPO U) (la: Ensemble U),
                           Is_an_antichain_in  P la -> (la <> (Minimal_elements_of  P))->
                           Inside  _ (PO_Above P la) P.
Proof. {
    intros P la H. intro CASE1b.
         assert(H0: True). auto.
         assert(AlwaysTrue: Inhabited U la /\ Included U la (Carrier_of U P)).
         split. destruct H. apply H. destruct H. apply H.

elim exists_above with (P:=P) (e :=la). (* We wish to say let P_Above:= (PO_Above P la)*)
intros P_Above. intro H1.
elim exists_below with (P:=P) (e :=la).
intros P_Below. intro H2. (* at this point we have P_Above and P_Below with  desired property *)
unfold Inside. split.
 Focus 2.   simpl. reflexivity.
unfold Strict_Included. split.
unfold Included.  intros. destruct H3. assumption.

(* WE need to prove that there is some x in P which is not present in P_Above *)
(* For this we use the fact that la <> Minimal_elements_of. *)
apply Not_equal_sets in CASE1b.

elim CASE1b. intro. (* 1st_HalfCASE: when there is a y in la and not present in Minimal *)
destruct H3 as [y H3]. (* we have a y from la but not in minimal *)
destruct H3 as [H3a H3b].
unfold In in H3b. unfold Minimal_elements_of in H3b.

assert(H4: In U (Carrier_of _ P) y). destruct H. destruct H.
unfold Included in H. apply H. assumption.

(* We wish to  prove the positive of following fact *)
(* Infact if following doesnot happen then y must be a minimal element which contradicts*)
(* Following claim says that there is some x less than y and not equal to y *)
assert (H3: exists x: U, In _ (Carrier_of _ P) x /\ y<>x /\ (Rel_of _ P) x y ).
{ elim (EM ( exists x: U, In _ (Carrier_of _ P) x /\ y<>x /\ (Rel_of _ P) x y)).
  Focus 2.
intro. absurd (Is_a_minimal_element  P y). assumption.
unfold Is_a_minimal_element. split. (* apply minimal_element_cond. *) assumption.
intro. elim H3. destruct H5 as [x H5]. exists x. assumption.
trivial. }
(* at this point we have H3 as a crucial fact *)
(* this helps us get a point x0 strictly below y *)
(* we can have a point x0 below y and not equal to y
   using this we proceed to prove that it (i.e, x0) doesnot belong to P_Above *)
(* we prove this using contradiction *)
destruct H3 as [x0 H3]. (* *)
assert (H5: ~ In _ (PO_Above_Carrier P la) x0 ).
intro. unfold In in H5. destruct H5. destruct H5. clear H6.
assumption. clear H6. destruct H7 as [y0 H6].
destruct H3 as [H3c H3]. destruct H3 as [H3d H3].
destruct H6 as [H6a H6].
assert ( H7: Rel_of U P y0 y).  (* we prove that y0 R y using transitivity *)
assert (H8: Order U (Rel_of U P)).
apply PO_cond2. destruct H8. apply H8 with (y:= x0).
assumption. assumption.
(* now using antichain condition H we prove that y0= y *)
destruct H.
assert (H9: y0 = y). apply H8. unfold Included. intros.
destruct H9. assumption. assumption. left. assumption.
(* now we prove R y x0 by rewriting *)
assert (H10: Rel_of U P y x0 ). rewrite <- H9. assumption.
(*using antisymmetricity we prove that y= x0 because y R x0 and x0 R y are true *)
assert (H11: Order U (Rel_of U P )).
apply PO_cond2. destruct H11. assert (H14: y= x0).
apply H13. assumption. assumption. (*now we have contradiction as x0<>y and x0=y *)
absurd (y=x0). assumption. assumption.
(* here we already proved that x0 is not in P_Above *)
(* Moreover we know that x0 is in P *)
(* hence we can prove that P_Above is not same as P using Lemma Sets_not_equal *)

(* Which proves that P_Above is strictly included in P *)
apply (Sets_not_equal). right. exists x0. split.
 assumption. destruct H3 as [H3c H3]. assumption.

 (* the 1st_halfCASE is OVER HERE *)
 intro.  (* 2nd HalfCASE when y belongs to Minimal but not to la *)
destruct H3 as [y H3]. destruct H3 as [H3a H3b].
assert (H4: ~ In _ (PO_Above_Carrier P la) y). intro.
(* assuming y belongs to P_Above we produce contradiction *)
destruct H3. destruct H3. assumption. clear H4. destruct H5 as [x H4]. destruct H4 as [H4a H4b].
{ elim (EM (x=y)). (* we produce contradiction in both cases *)
  Focus 2.
  intro. (*CASE x<>y   in this case we prove y is not minimal *)
destruct H3a.
assert (H6a: (exists y0 : U, In U (Carrier_of U P) y0 /\ y <> y0 /\ Rel_of U P y0 y)).
exists x.
split. destruct H. destruct H.  unfold Included in H. apply H. assumption.
split. intro. symmetry in H7. elim H4.  assumption. assumption.
(* In this case H6 and H6a are contradictory *)
elim H6. assumption.
intro. (*CASE x=y in this case since x belongs la hence y belongs la which contradicts H3b*)
rewrite H4 in H4a. elim H3b. assumption.  }
(* here we could prove that y is not in P_Above, hence it is strictIncluded in P  *)
apply (Sets_not_equal). right. exists y.
split.  simpl. assumption.
destruct H3a. assumption.  } Qed.

  Inductive Chain_Joined (c1 c2 : Ensemble (Ensemble U))(la: Ensemble U)(e: Ensemble U):Prop:=
  Entry_cond: (exists (e1 e2: Ensemble U)(a: U), In _ la a /\ In _ c1 e1 /\ In _ c2 e2 /\
              In _ e1 a /\ In _ e2 a /\ e = Union _ e1 e2) -> Chain_Joined c1 c2 la e.

  Definition P_remains_A (P: FPO U)(A: Ensemble U)(proof1: Inhabited _ A)(proof2: Finite _ A):
       FPO U :=  {| PO_of:= {| Carrier_of :=  A;
               Rel_of := Rel_of _ P;
               PO_cond1 := proof1;
               PO_cond2 := PO_cond2 _ P |};
               FPO_cond := proof2
            |}.
  Lemma exists_P_small:
       forall (P: FPO U)(A: Ensemble U)(proof1: Inhabited _ A)(proof2: Finite _ A),
       exists (P_small: FPO U), P_small = P_remains_A P A proof1 proof2.
  Proof. {
      intros. exists (P_remains_A P A proof1 proof2).
            reflexivity. } Qed.

 Definition DilworthB_statement:= fun (P: FPO U)=> forall (m: nat),
                 (exists (a: Ensemble U ), Is_largest_antichain_in  P a /\ cardinal _  a m) ->
                 (exists (cv: Ensemble (Ensemble U)), Is_a_chain_cover P cv /\
                      cardinal _ cv m).

 Theorem DilworthB: forall (P: FPO U), DilworthB_statement P.
 Proof. {

    (* We will prove the result by well founded induction on the set of all partial order.
       To use the well founded induction we first need to prove that the Inside relation is
       well founded on PO U.  This is claimed by Lemma Inside_is_WF *)
    Check well_founded_ind.
    apply well_founded_ind with (R:= Inside U ).
         apply Inside_is_WF.
         intros P IH.
         unfold DilworthB_statement.
         intros m . intros.

         assert(H98: Order _ (Rel_of _ P)).
         Print FPO. apply PO_cond2.

      (* We will break the proof in two cases. First one is when Minimal_Elements and
     Maximal_Elements are not the carrier of the largest anntichain la.
     Second case is when either Minimal_elements_of or Maximal_elements_of is the
      carrier of largest antichain la. *)

         elim( EM (forall (la: Ensemble U),
                     (Is_largest_antichain_in P la)->
                     (la = Maximal_elements_of  P \/ la = Minimal_elements_of  P))).
         Focus 2.

 -   intro CASE1Before.

         assert (CASE1: exists la: Ensemble U, Is_largest_antichain_in  P la /\
                ~( la = Maximal_elements_of  P \/ la = Minimal_elements_of  P)).
         { apply Negation3. apply CASE1Before. }

         destruct CASE1 as [la CASE1]. destruct H as [la' H99]. destruct CASE1 as [H CASE1].

         assert(H0: cardinal U la m).
         { Check Largest_card_same.
         apply Largest_card_same with (e1:= la')(FP:=P).
         apply H99. assumption. apply H99. }

  (* CASE1: ~(la = Maximal_elements_of \/ la = Minimal_elements_of)  *)

  elim exists_above with (P:=P) (e :=la). (* We wish to say let P_Above:= (PO_Above P la)*)
  intros P_Above. intro.
  elim exists_below with (P:=P) (e :=la).
  intros P_Below. intro. (* at this point we have P_Above and P_Below with  desired property *)

  assert (CASE1a: la <> Maximal_elements_of  P /\ la <> Minimal_elements_of  P).
  { split. intro. rewrite H3 in CASE1. elim CASE1. left. reflexivity.
  intro. elim CASE1. right. assumption. }
  destruct CASE1a as [CASE1a CASE1b]. (* we know here that la <> Maximal and la <> Minimal *)

  (* We need to prove that P_Above and P_Below is Inside P *)
   assert(HInside: Inside _ P_Above P /\ Inside _ P_Below P ).
   { destruct H.

   (* We shall first  prove "Inside P_Above P" *)
   split. rewrite H1. apply PO_Above_inside_P. assumption. assumption.
   (* We now prove that "Inside P_Below P" *)
   rewrite H2.  apply PO_Below_inside_P. assumption.
   assumption. }
   destruct HInside as [HInside1 HInside2].

 (*Since P_Above and P_Below are Inside P we can use IH to obtain chain_cover c1 and c2 for
  P_Above and P_Below . This is done in the following steps. In doing so we claim that la is
  the largest antichain of P_Above and P_Below. This we need to prove seperately.  *)

   unfold DilworthB_statement in IH.

  (* Following steps extracts a chain cover c1 for P_Above *)
    assert(IH1: exists cv : Ensemble (Ensemble U),
              Is_a_chain_cover  P_Above cv /\ cardinal (Ensemble U) cv m).
     { apply IH. assumption. exists la. split.

    (* WE need to prove that la is the largest antichain of P_Above before we can extract c1.*)
      (*GOAL1: Is_largest_antichain_in _ P_Above la *)
      apply  Largest_antichain_remains with (P2:= P).
        (*SubGoal: Inside P_Above P *) assumption.
        (*SubGoal: Included U la (Carrier_of U P_Above )*)
        rewrite H1. simpl. apply la_in_P_Above.                  (* CHAIN COVER :: C1 *)
        destruct H. assumption.  assumption.
        (*GOAL2: cardinal U la m *)
        assumption. }
    destruct IH1 as [c1 IH1]. destruct IH1 as [IH1a IH1b].
  (* c1 exracted at this point *)

  (*Following steps extracts a chain cover c2 for P_Below *)
    assert(IH2: exists cv : Ensemble (Ensemble U),
         Is_a_chain_cover  P_Below cv /\ cardinal (Ensemble U) cv m).
     { apply IH. assumption. exists la. split.

    (*GOAL1: Is_largest_antichain_in _ P_Below la *)
     apply  Largest_antichain_remains with (P2:= P).
     (*SubGoal: Inside P_Below P *) assumption.
     (*SubGoal: Included U la (Carrier_of U P_Below )*)
     rewrite H2. simpl. apply la_in_P_Below.                     (* CHAIN COVER :: C2 *)
     destruct H. assumption.  assumption.
     (*GOAL2: cardinal U la m *)  assumption. }
    destruct IH2 as [c2 IH2]. destruct IH2 as [IH2a IH2b].
  (*c2 extracted at this point *)

     (* SHORTHAND "cover" for Chain_joined c1 c2 la *)
     pose (cover:= Chain_Joined c1 c2 la). assert (H3: True). auto.
(*  elim exists_cover with (c1:=c1)(c2:=c2)(la:=la).              (* COVER == Chain_joined  *)
  intro cover. intro H3. *)

 (* importent facts about c1, c2 and la *)
  (* every chain in c1 passes through some element of la *)
   assert (Hc1: forall (e: Ensemble U), In _ c1 e -> (exists a:U, In _ la a /\ In _ e a) ).
     { apply Bijection_Relation with (n:=m).
     destruct IH1a.
     intros.
     assert(H7:In U (Carrier_of U P_Above) x ).
          Check la_in_P_Above.
          assert(H8: Included U la (PO_Above_Carrier P la)).
                 apply la_in_P_Above. apply H.
                 rewrite H1. apply H8. assumption.
     apply H5. assumption. (* bijection property *)
     intros.   (*This will be true. Otherwise two antichain element will lie on same chain *)
     apply NoTwoCommon with (P:=P)(X:=b)(Y:=la).
     repeat (destruct  H4). destruct H5. destruct H6. destruct H7.
     assert(H9: Is_a_chain_in  P_Above b). Print Is_a_chain_cover.
           destruct IH1a as [IH1aA IH1a]. apply IH1aA. assumption.
     apply Chain_remains with (P1:= P_Above). rewrite H1.
     apply PO_Above_inside_P. apply H. assumption. assumption. apply H.
     unfold Included. intros. destruct H5. apply H4. apply H4.
     unfold Included. intros. destruct H5. apply H4. apply H4. assumption.
     assumption. }
  (* Hc1 prooved *)

  (* every chain in c2 passes through some element of la *)
  assert (Hc2: forall (e: Ensemble U), In _ c2 e -> (exists a:U, In _ la a /\ In _ e a) ).
     { apply Bijection_Relation with (n:=m).
     destruct IH2a.
     intros.
     assert(H7:In U (Carrier_of U P_Below) x ).
           Check la_in_P_Below.
           assert(H8: Included U la (PO_Below_Carrier P la)).
                  apply la_in_P_Below. apply H.
                  rewrite H2. apply H8. assumption.
     apply H5. assumption. (* bijection property *)
     intros.   (*This will be true. Otherwise two antichain element will lie on same chain *)
     apply NoTwoCommon with (P:=P)(X:=b)(Y:=la).
     repeat (destruct  H4). destruct H5. destruct H6. destruct H7.
     assert(H9: Is_a_chain_in  P_Below b). Print Is_a_chain_cover.
            destruct IH2a as [IH2aA IH2a]. apply IH2aA. assumption.
     apply Chain_remains with (P1:= P_Below). rewrite H2.
     apply PO_Below_inside_P. apply H. assumption. assumption. apply H.
     unfold Included. intros. destruct H5. (apply H4). apply H4.
     unfold Included. intros. destruct H5. apply H4. apply H4. assumption.
  assumption. }
  (* Hc2 prooved *)

 exists cover.

  (* We need to prove that cover is a chain cover for the whole P *)
  (* PROOF IDEA: We need to prove that for every element of P there is a chain in cover.
                 every chain in cover is made up of e1 a e2 where e1 is a chain from c1,
                 "a" is an element of la and e2 is from c2. Thus for every element of P
                 we extract these three component and proove that it lies in "cover" using
                 definition of cover  *)
  assert (Above_or_Below:
           (Carrier_of _ P) =  Union _ (PO_Above_Carrier P la ) (PO_Below_Carrier P la)).
      { apply P_Above_or_P_Below. apply H. }

  assert (H3a: Is_a_chain_cover  P cover ).

      { apply cover_cond.

    - (* Goal1: every e in cover is a chain carrier *)
      destruct IH1a as [IH1aA IH1a].
      destruct IH2a as [IH2aA IH2a].
      intros e He. unfold cover in He. (* rewrite H3 in He. *) destruct He.
      destruct H4 as [e1 H4]. destruct H4 as [e2 H4]. destruct H4 as [a H4].
      destruct H4 as [H4a H4]. destruct H4 as [H4b H4]. destruct H4 as [H4c H4].
      assert(H5: e = Union U e1 e2). apply H4.
      assert(T1A: Is_a_chain_in  P_Above e1 ). apply IH1aA. assumption.
      assert(T1B: Is_a_chain_in  P e1 ).
             apply Chain_remains with (P1:= P_Above). assumption. assumption.
      assert(T2A: Is_a_chain_in  P_Below e2). apply IH2aA. assumption.
      assert(T2B: Is_a_chain_in  P e2).
             apply Chain_remains with (P1:= P_Below). assumption. assumption.
      assert(T1: Included _ e1 (Carrier_of _ P_Above)). apply T1A.
      assert(T2: Included _ e2 (Carrier_of _ P_Below)). apply T2A.

      unfold Is_a_chain_in. split.
      + (*SubgoalA: Included U e (Carrier_of U P) /\ Inhabited U e *)

      split. (* Subgoal1: e is included in P *)
             assert(H6a: Included _ e1 (Carrier_of U P)).  apply T1B.
             assert(H6b: Included _ e2 (Carrier_of U P)). apply T2B.
             rewrite H5.  unfold Included.  intros. destruct H6.
             apply H6a. assumption. apply H6b. assumption.

             (* Subgoal2: Inhabited e *)
             apply Inhabited_intro with (x:=a). rewrite H5. apply Union_introl.
             apply H4.

       + (* SubgoalB: every e in cover is a chain *)

         intros.
         assert(H7: In _ e x ). apply H6. apply Couple_l.
         assert(H8: In _ e y ). apply H6. apply Couple_r.
         rewrite H5 in H7. rewrite H5 in H8.
         destruct H7. destruct H8.
         (* Case1: when both x and x0 belong to e1 *)
            { assert(H9: Is_a_chain_in  P_Above e1). apply T1A.
             destruct H9. rewrite H1 in H10. simpl in H10. apply H10.
             unfold Included. intros. destruct H11. assumption. assumption. }
         (* Case2: when x in e1 and x0 in e2 *)

            { assert(H9: Rel_of U P a x).
               assert(H10: Rel_of U P a x \/ Rel_of U P x a).
               assert(H11:  Is_a_chain_in P e1). apply T1B.
                     destruct H11 as [H11 H11a]. apply H11a. unfold Included.
                     intros. destruct H9. apply H4. assumption.
               elim H10.
               trivial.
               intro H11.
               assert(H11a: x= a).
                  apply No_smaller_element_Above with (P:=P) (la:=la).
                  assumption. rewrite <- H1. apply T1. assumption.
                  repeat (try split ; assumption).
               rewrite H11a. apply H98.

            assert(H10: Rel_of U P x0 a).
               assert(H10: Rel_of U P a x0 \/ Rel_of U P x0 a).
               assert(H11: Is_a_chain_in  P e2). apply T2B.
                     destruct H11 as [H11 H11a]. apply H11a. unfold Included.
                     intros. destruct H10. apply H4. assumption.
               elim H10.
               intro H11.
               assert(H11a: x0 = a).
                  apply No_bigger_element_Below with (P:=P) (la:=la).
                  assumption. rewrite <- H2. apply T2. assumption.
                  repeat (try split ; assumption).
               rewrite H11a. apply H98.
               trivial.

             right. destruct H98. unfold Transitive in H12. apply H12 with (y:=a).
             assumption. assumption. }
             destruct H8.
         (* Case3: when x in e2 and x0 in e1 *)
             { assert(H9: Rel_of U P a x0).
                 assert(H10: Rel_of U P a x0 \/ Rel_of U P x0 a).
                 assert(H11: Is_a_chain_in   P e1). apply T1B.
                     destruct H11 as [H11 H11a]. apply H11a. unfold Included.
                     intros. destruct H9. apply H4. assumption.
                 elim H10.
                 trivial.
                 intro H11.
                 assert(H11a: x0= a).
                     apply No_smaller_element_Above with (P:=P) (la:=la).
                     assumption. rewrite <- H1. apply T1. assumption.
                     repeat (try split ; assumption).
                 rewrite H11a. apply H98.

             assert(H10: Rel_of U P x a).
                  assert(H10: Rel_of U P a x \/ Rel_of U P x a).
                  assert(H11: Is_a_chain_in   P e2). apply T2B.
                     destruct H11 as [H11 H11a]. apply H11a. unfold Included.
                     intros. destruct H10. apply H4. assumption.
                  elim H10.
                  intro H11.
                  assert(H11a: x = a).
                      apply No_bigger_element_Below with (P:=P) (la:=la).
                      assumption. rewrite <- H2. apply T2. assumption.
                      repeat (try split ; assumption).
                  rewrite H11a. apply H98.
                  trivial.

            left. destruct H98. unfold Transitive in H12. apply H12 with (y:=a).
            assumption. assumption. }

         (* Case4: when both x and x0 belongs to  e2  *)
             { assert(H9: Is_a_chain_in  P_Below e2). apply IH2aA. assumption.
             destruct H9. rewrite H2 in H10. simpl in H10. apply H10.
             unfold Included. intros. destruct H11. assumption. assumption. }
      (* Goal1 completed here *)

     - (* Goal2: every x in P lies on some e in cover *)
        intros x Hx.  rewrite Above_or_Below in Hx.
         destruct Hx.
         (* CaseA: H4 : When x lies in P_Above  *)
         assert(T1: exists (e1: Ensemble U), In _ c1 e1 /\ In _ e1 x).
              apply IH1a. rewrite H1. simpl. assumption.
         destruct T1 as [e1 T1].
         assert(T2: exists a:U, In _ la a /\ In _ e1 a ).
              apply Hc1. apply T1.
         destruct T2 as [a T2].
         assert(T3: exists  (e2:Ensemble U), In _ c2 e2 /\ In _ e2 a).
              apply IH2a. rewrite H2. simpl.
              assert(Temp: Included _ la (PO_Below_Carrier P la) ).
                    apply la_in_P_Below. apply H.
              apply Temp. apply T2.
         destruct T3 as [e2 T3].
         exists (Union _ e1 e2).
         split. (* Subgoal : e1 U e2 is in cover *)
              unfold cover. (* rewrite H3. *) unfold In. apply Entry_cond.
              exists e1. exists e2. exists a. split.
              apply T2. split. apply T1. split. apply T3. split.
              apply T2. split. apply T3. reflexivity.
               (*Subgoal: x belongs to e1 U e2 *)
              apply Union_introl. apply T1.

         (* CaseB: H4: When x lies in P_Below  *)
         assert(T1: exists (e2: Ensemble U), In _ c2 e2 /\ In _ e2 x).
              apply IH2a. rewrite H2. simpl. assumption.
         destruct T1 as [e2 T1].
         assert( T2: exists a:U, In _ la a /\ In _ e2 a).
              apply Hc2. apply T1.
         destruct T2 as [a T2].
         assert(T3: exists (e1: Ensemble U), In _ c1 e1 /\ In _ e1 a).
              apply IH1a. rewrite H1. simpl.
              assert(Temp: Included _ la (PO_Above_Carrier P la)).
                    apply la_in_P_Above. apply H.
                    apply Temp. apply T2.
         destruct T3 as [e1 T3].
         exists (Union _ e1 e2).
         split. (* Subgoal: e1 U e2 is in cover *)
              unfold cover (* rewrite H3. *). unfold In. apply Entry_cond.
              exists e1. exists e2. exists a.
              repeat (split ; try (apply T2); try (apply T1); try (apply T3)).
              (* Subgoal: x belongs to e1 U e2 *)
              apply Union_intror. apply T1.
       (* Goal2 completed here *)
       }

  split.
   apply H3a.

    (* We need to prove that cardinality of cover is m *)
   (* We prove this by contradiction. we will assume that cardinality of cover is n .
      and assuming m<>n we will produce a contradiction. But before we can say that let
      cardinality    of cover be n we need to prove that cover is finite. *)
    assert (HF: Finite _ cover).
     { (*we can prove this by proving that cover is included in the power set of P and P is
     finite hence any subset of its power set is also finite *)
     (* For now we assume it *)
      assert (CoverIncluded: Included _ cover (Power_set _ (Carrier_of _ P))).
      { unfold Included.
      destruct IH1a as [IH1aA IH1a].
      destruct IH2a as [IH2aA IH2a].
      intros e He. unfold cover in He. destruct He.
      destruct H4 as [e1 H4]. destruct H4 as [e2 H4]. destruct H4 as [a H4].
      destruct H4 as [H4a H4]. destruct H4 as [H4b H4]. destruct H4 as [H4c H4].
         assert(H5: e = Union U e1 e2). apply H4.
         assert(T1A: Is_a_chain_in   P_Above e1 ). apply IH1aA. assumption.
         assert(T1B: Is_a_chain_in   P e1 ).
             apply Chain_remains with (P1:= P_Above). assumption. assumption.
         assert(T2A: Is_a_chain_in   P_Below e2). apply IH2aA. assumption.
         assert(T2B: Is_a_chain_in   P e2).
             apply Chain_remains with (P1:= P_Below). assumption. assumption.
         assert(T1: Included _ e1 (Carrier_of  _ P_Above)). apply T1A.
         assert(T2: Included _ e2 (Carrier_of  _ P_Below)). apply T2A.

      assert(H88: Included U e (Carrier_of U P)).
            { assert(H6a: Included _ e1 (Carrier_of U P)).  apply T1B.
             assert(H6b: Included _ e2 (Carrier_of U P)). apply T2B.
             rewrite H5.  unfold Included.  intros. destruct H6.
             apply H6a. assumption. apply H6b. assumption. }

      apply Definition_of_Power_set. apply H88. }

      apply Finite_downward_closed with (A:= Power_set U (Carrier_of U P)).
      apply Power_set_finite. apply FPO_cond.
      assumption. }

    elim finite_cardinal with (U:=Ensemble U)(X:= cover).
     intro n. intro H4. (*At this point we have assumed n to be cardinality of cover *)

    (* We prove that m<>n is not posiible and hence using EM we have m=n proved *)
     elim (EM (m=n)).
     Focus 2.
    intro.
    (*CASE  m<>n:  In this case either m<n or m>n . When m>n  antichain elements are more
        in number than the number of chains in a chain cover "cover". This contradicts
        Theorem DilworthA. *)

        assert (H6: m<n \/ m>n).
        apply  (Not_equal_means_lt_or_gt). assumption.

        elim H6.
        (* SubCASE m<n: we need a proof here*)
        intro H7.
        (* Here if chains in cover is more than elements in la then two chains e1 and e2
           will pass through same element a (where a:la ). *)
        assert (H8: exists (e1 e2 : Ensemble U)(a: U), In _ cover e1 /\ In _ cover e2 /\ In _ la a /\
                                                  e1 <> e2 /\ (In _ e1 a /\ In _ e2 a )).
        { apply Pigeon_Relation with (n:=n) (m:=m).
          { intros e He. unfold cover in He. destruct He.
            destruct H8 as [e1 H8]; destruct H8 as [e2 H8]; destruct H8 as [a H8].
            exists a.   split. apply H8. replace e with (Union U e1 e2). apply Union_intror.
            apply H8. symmetry. apply H8. }
          assumption. assumption. assumption.

        }
        destruct H8 as [e1 H8]. destruct H8 as [e2 H8].
        destruct H8 as [a H8].
        destruct H8 as [H8a H8]. destruct H8 as [H8b H8].
        destruct H8 as [H8c H8]. destruct H8 as [H8d H8].

        unfold cover in H8a, H8b.

        assert (He2: Is_a_chain_in  P e2 ). {
          destruct H3a. apply H9.  unfold cover.  assumption.  }
        assert (He1: Is_a_chain_in   P e1 ). {
          destruct H3a. apply H9.  unfold cover.  assumption.  }

        destruct H8a. destruct H9 as [e1u H9]. destruct H9 as [e1d H9]. destruct H9 as [a1 H9].

        destruct H8b. destruct H10 as [e2u H10]. destruct H10 as [e2d H10].
        destruct H10 as [a2 H10].

        assert(Ha_a1: a = a1 ). {
          assert (THe1: In _ e1 a1).
          { replace e1 with ( Union U e1u e1d ). apply Union_intror.  apply H9.
            symmetry. apply H9. }
          apply NoTwoCommon with (P:= P) (X:= e1) (Y:=la).  assumption.
          apply H.
          { unfold Included. intros. destruct H11. apply H8. assumption. }
          { unfold Included. intros. destruct H11. apply H8c. apply H9.  }
           }

        assert (Ha_a2: a = a2 ). {
           assert (THe1: In _ e2 a2).
          { replace e2 with ( Union U e2u e2d ). apply Union_intror.  apply H10.
            symmetry. apply H10. }
          apply NoTwoCommon with (P:= P) (X:= e2) (Y:=la).  assumption.
          apply H.
          { unfold Included. intros. destruct H11. apply H8. assumption. }
          { unfold Included. intros. destruct H11. apply H8c. apply H10. }
          }

        assert (H12: True). { tauto. }
        assert (H11: e1u = e2u ).
        { assert
            (TH11: (forall (x y: Ensemble U)(a: U), ( In _ c1 x /\ In _ c1 y /\ In _ la a /\
                                                 In _ x a /\ In _ y a )-> x= y)).
          { apply Bijection_Relation1 with (n:= m);
            repeat (assumption).

            { intros. apply IH1a. rewrite H1. apply la_in_P_Above. apply H. assumption. }
            { intros. apply NoTwoCommon with (X:= b) (Y:= la) (P:= P).
              apply Chain_remains with (P1:= P_Above). assumption.
              destruct IH1a. apply H13. apply H11. apply H.
              unfold Included.  intros. destruct H13. apply H11. apply H11.
              unfold Included.  intros. destruct H13. apply H11. apply H11. }

          }
          symmetry. apply TH11 with (a:=a). rewrite <- Ha_a1 in H9 . rewrite <- Ha_a2 in H10.
          repeat (try(split); try (solve [ apply H9 |apply H10 ])) . }

        clear H12.

        assert (H12: e1d = e2d ).
        { assert
            (TH12: (forall (x y: Ensemble U)(a: U), ( In _ c2 x /\ In _ c2 y /\ In _ la a /\
                                                 In _ x a /\ In _ y a )-> x= y)).
          { apply Bijection_Relation1 with (n:= m);
            repeat (assumption).

            { intros. apply IH2a. rewrite H2. apply la_in_P_Below. apply H. assumption. }
            { intros. apply NoTwoCommon with (X:= b) (Y:= la) (P:= P).
              apply Chain_remains with (P1:= P_Below). assumption.
              destruct IH2a. apply H13. apply H12. apply H.
              unfold Included.  intros. destruct H13. apply H12. apply H12.
              unfold Included.  intros. destruct H13. apply H12. apply H12. }

          }
          symmetry. apply TH12 with (a:=a). rewrite <- Ha_a1 in H9 . rewrite <- Ha_a2 in H10.
          repeat (try (split); try ( solve [apply H9 | apply H10])).
        }

         assert (H13: e1 = e2 ).
         { replace e1 with (Union U e1u e1d) .
          replace e2 with (Union U e2u e2d) .
          rewrite H11. rewrite H12.  reflexivity.
          symmetry. apply H10 . symmetry. apply H9.  }

        absurd ( e1 = e2). { assumption. } { assumption. }

        intro.
        (* SubCASE m>n: this is not possible due to DilworthA. We prove that ~(m>n). *)
        assert(H7b: ~(m>n)).
        { Check DilworthA.
        apply DilworthA with (P:=P)(m:=m)(n:=n)(cv:=cover)(a:=la).
        assumption. destruct H. assumption. assumption. assumption. }
        absurd(m>n). assumption.  assumption.

     intro.
    (*CASE m=n: A simple rewrite will do *)
    { rewrite H5. assumption. }

    (* Goal: Finite _ cover. *) assumption. (* Already prooved as HF *)

   (* ====================================================================================== *)
                                (* CASE 2 BEGINS HERE *)
   (* ====================================================================================== *)
 -  intro CASE2Before.
     destruct H as [la H].
     destruct H as [H H0].

(* CASE2: when la= Maximal_elements_of \/ Minimal_elements_of *)
     assert (CASE2: la = Maximal_elements_of  P \/ la= Minimal_elements_of  P ).
     { apply CASE2Before. assumption. }

     elim Exists_pair_xy with (U:=U)(FP:=P).
     intro x0. intros.
     destruct H1 as [y0 H1].

     elim (EM (Inhabited _ (Setminus _ (Carrier_of _ P) (Couple _ x0 y0)))).
     Focus 2.

    (* trivial case ::  In this case {x0 y0} is the only chain in chain cover and chain
        cover has size 1. we need to show that size of la is also 1  *)
     intro TrivialCase.
     exists (Singleton _ (Couple _ x0 y0) ).

     assert(H2: Carrier_of U P = Couple U x0 y0).
        {  apply Extensionality_Ensembles. split. {
             elim (EM(Included U (Carrier_of U P) (Couple U x0 y0))).
             Focus 2. intro T1.
         absurd(Inhabited U (Setminus U (Carrier_of U P) (Couple U x0 y0))).
         assumption. unfold Included in T1.
         assert(T2: exists x : U, In U (Carrier_of U P) x /\ ~ In U (Couple U x0 y0) x).
               apply Negation3. assumption.
         destruct T2. apply Inhabited_intro with (x:=x).
         unfold Setminus. unfold In. simpl. apply H2.
         trivial. }
         unfold Included. intros. destruct H2. apply H1. apply H1. }
         (* Prooved H2 ----- *)

     split.
    * (* Goal {{x0, y0}} is a chain cover *)
      { Print Is_a_chain_cover.
        apply cover_cond. intros. destruct H3.
      - (*Subgoal {x0, y0} is a chain carrier *)
       unfold Is_a_chain_in . split.  split.
        { rewrite H2. unfold Included. trivial. }
        { apply Inhabited_intro with (x:=x0). apply Couple_l. }
        (* every element in cover is a chain *)
        { intros x y H3. unfold Included in H3.
          assert (H4: In U (Couple U x0 y0) x /\ In U (Couple U x0 y0) y).
           { split. apply H3. apply Couple_l. apply H3. apply Couple_r. }
          destruct H4. destruct H4. destruct H5.
          destruct H98 as [H98a H98b H98c].
          left. apply H98a. left. apply H1. destruct H5.
          right. apply H1. left. apply H98. }

       - (* Subgoal: for every element in there is a chain in {{ x0, y0}} *)
         { intros. rewrite H2 in H3.
         destruct H3. exists (Couple U x0 y0).
         split. apply In_singleton. apply Couple_l.
         exists (Couple U x0 y0). split. apply In_singleton.
         apply Couple_r. }
       }

      (* Prooved Goal: {{x0, y0}} is a chain cover *)

     * (* Goal : m=1, and hence cardinality of {{x0, y0}} is one and *)
       assert(H3: m=1). {
       assert(T1: Included _ la (Couple U x0 y0)).
            rewrite <- H2. apply H.

       assert(TF2: m < 2). {
       elim (EM (x0 = y0)). Focus 2.

           intro T2a. (* Case: when x0<>y0 *)
           assert(T3: cardinal _ (Couple U x0 y0) (S 1)).
           apply Couple_card_2. assumption.

           assert(T4: Strict_Included _ la (Couple U x0 y0)). {
              split.  assumption.
              elim (EM ( In _ la x0)). Focus 2.
              intro T4. apply Sets_not_equal. right. exists x0. split.
              assumption. apply Couple_l.
              intro t4. apply Sets_not_equal. right. exists y0. split.
              intro. destruct H. destruct H. absurd (x0=y0).
              assumption. apply H5. unfold Included.
              intros. destruct H6. assumption. assumption. left. apply H1.
              apply Couple_r. }

           apply incl_st_card_lt with (U:=U)(X:= la)(Y:= (Couple U x0 y0)).
           assumption. apply T3. apply T4.

           intro T2b. (* Case : when x0= y0 *)
           assert(T3: cardinal _ (Couple U x0 y0) 1). {
              apply Couple_card_1. assumption. }
           assert(T4: m <=1). {
                   apply incl_card_le with (U:=U)(X:= la)(Y:= (Couple U x0 y0)).
                   assumption. assumption. assumption. }
           apply le_lt_n_Sm.
           assumption.  }

       assert(TF3: m>0). {
              apply inh_card_gt_O with (U:=U) (X:= la).
              apply H. assumption. }

       apply Middle_num. split. unfold gt in TF3. apply TF3. apply TF2. }

       rewrite H3.
       Check Singleton_card. apply (Singleton_card).

     (* Non trivial case: *)
       intro Nontrivial.

       assert(H80: Strict_Included _ (Setminus U (Carrier_of U P) (Couple U x0 y0))
                                   (Carrier_of U P)). {
       unfold Strict_Included.
       split. unfold Included. unfold Setminus. unfold In. intros. apply H2.
       apply Sets_not_equal. right. exists x0. split. unfold In. unfold Setminus.
       apply or_not_and. right.
       assert(Temp: In U (Couple U x0 y0) x0). apply Couple_l.
       intro. absurd(In U (Couple U x0 y0) x0). assumption. assumption.
       (*Subgoal: In U (Carrier_of U P) x0 *)
       destruct H1. destruct H1. apply H1. }

       assert (Finite_small: Finite _ (Setminus U (Carrier_of U P) (Couple U x0 y0))). {
       apply Finite_downward_closed with (A:= Carrier_of U P).
       Print FPO. apply FPO_cond. apply H80. }

       (* P_small represents P minus {x0, y0} *)
       elim exists_P_small with (P:=P)(A:= (Setminus U (Carrier_of U P) (Couple U x0 y0)))
                                      (proof1:= Nontrivial)(proof2:= Finite_small).
       intro P_small. intro H2.

       assert(H80a: Inside _ P_small P). {
       unfold Inside.
       split. rewrite H2. simpl. apply H80. rewrite H2. simpl.
       reflexivity. }

    (* At this point we have proof of the fact that P_small is finite and inhabited. *)

    (* We wish to extract a chain cover for P_small using induction hypothesis *)
       assert(IH1: DilworthB_statement P_small). {
       apply IH.
       (* Goal: Inside P_small P *)
       apply H80a. }

       unfold DilworthB_statement in IH1.

       (* NOTE: We need a lemma that says every FPO has a largest antichain *)
       (* Lemma exists_largest_antichain confirms this *)
       assert(H81: exists (m0:nat) (a: Ensemble U), Is_largest_antichain_in  P_small a /\
                                                    cardinal U a m0). {
       apply  exists_largest_antichain. }

       destruct H81 as [m0 H81].
       assert(H82:  exists cv : Ensemble (Ensemble U),Is_a_chain_cover  P_small cv /\
                                                      cardinal (Ensemble U) cv m0). {
       apply IH1. assumption. }
       destruct H82 as [cv_small H82].

     (* chain cover for P_small extracted at this point as cv_small *)
       destruct H81 as [la0 H81].

   (* PROOF IDEA AHEAD: At this point we have a chain cover cv_small of size m0 for P_small.
      We will  show that that cv_small added with {x0 y0} will cover the whole P. Moreover
      we show that cardinality of the (cv_small+ {x0, y0}) is m. We know that card of
      (cv_small+ {x0, y0}) is m0+1. So we need to prove that m0+1= m. For this we prove
      two things (FACT2: m0 <> m) and (FACT1: m0<= m). Then this implies m0 < m (FACT3).
      which in turn implies m0+1 <= m (FACT4). At this point we also prove that
      (FACT5: ~(m0+1 < m)), because size of chain cover cannot be less than largest antichain
      size using DilworthA. Hence FACT4 and FACT5 gives us (FACT6: m0+1= m) *)

       exists (Add _ cv_small (Couple _ x0 y0) ).
       assert(H83: Is_a_chain_cover  P (Add (Ensemble U) cv_small (Couple U x0 y0))). {
       apply cover_cond.
           (*Subgoal: every e in (cv_small + {x0, y0}) is a chain *)
            intros. destruct H3. apply Chain_remains with (P1:= P_small).
            assumption. destruct H82 as [H82a H82b]. destruct H82a as [H82a1 H82a2].
            apply H82a1. apply H3.
            destruct H3.
            (* SubSubGoal: Couple U x0 y0 is a chain carrier *)
            unfold Is_a_chain_in . split.
             split. unfold Included. intros. destruct H3.
            apply H1. apply H1. apply Inhabited_intro with x0. apply Couple_l.
            intros. assert(H3a: In _ (Couple U x0 y0) x /\ In _ (Couple U x0 y0) y).
            split. apply H3. apply Couple_l. apply H3. apply Couple_r.
            destruct H3a.  destruct H4. destruct H5.
            left. apply H98. left. apply H1.
            destruct H5. right. apply H1. left. apply H98.

            intros.
            (* Subgoal: For every element x in P there is a chain in chain cover that contain x
                 We prove this by assuming two cases. Whether or not  x belongs to {x0 y0}   *)
            elim (EM(In _ (Couple U x0 y0) x)). Focus 2.  intro CaseA.
            (* CaseA: ~ In U (Couple U x0 y0) x*)
             (* In this case x is in P_small hence there is a chain e in in cv_small that contain
                x. this chain is also present in (cv_small + {x0, y0})*)
                assert( CaseA1: In U (Carrier_of U P_small) x). rewrite H2.
                simpl. unfold In. unfold Setminus. split. assumption. assumption.

                assert(ExistE: exists e: Ensemble U, In _ cv_small  e
                                                     /\ In U e x ).
                      destruct H82 as [H82a H82b]. apply H82a. assumption.

                destruct ExistE as [e ExistE]. exists e. split.
                unfold Add. apply Union_introl. apply ExistE. apply ExistE.
            (* CaseB: In U (Couple U x0 y0) x *)
                (* In this case {x0, y0} is the chain that is in P and contains x *)
                intro CaseB.
                exists (Couple U x0 y0).
                split. unfold Add. apply Union_intror. apply In_singleton. apply CaseB. }

              (* Proof of assertion H83 completes here. This will be useful in many places *)
       split.

      * (* Goal1: cv_small + {x0,y0} is a chain cover. *)
        apply H83.

      * (*Goal2: cardinal of (cv_small + {x0,y0} ) is m *)

       assert(Fact0: cardinal _ (Add (Ensemble U) cv_small (Couple U x0 y0)) (S m0) ). {
       apply card_add. apply H82.
          (* Subgoal:  ~ In (Ensemble U) cv_small (Couple U x0 y0) *)
          (* We prove this by contradiction . if {x0, y0} is in cv_small then it must be
             included in P_small . However this contradicts with definition of P_small *)
             intro Temp1. destruct H82 as [H82a H82b]. destruct H82a as [H82a1 H28a2].
             assert(Temp2: Is_a_chain_in  P_small (Couple U x0 y0)). apply H82a1.
                assumption. destruct Temp2. destruct H3. rewrite H2 in H3. simpl in H3.
                unfold Included in H3.
                absurd (In _ (Couple U x0 y0) x0).
                apply H3. apply Couple_l. apply Couple_l. }

       assert(Fact1: m0<= m ). {
       (* This should be true because m is the size of largest antichain of P and m0 is size
          of an antichain of P_small which is also an antichain of P. *)
           assert(H81a: Is_an_antichain_in  P la0 ).
           apply Antichain_not_changed2 with (P1:= P_small).
           apply H80a. apply H81. apply H81.
           Print Is_largest_antichain_in . destruct H.
           apply H3 with (e1:= la0). assumption. assumption. apply H81. }

       assert(Fact2: m0<> m ). {
       (* This should be true. Because if m0=m then la0 also becomes a largest antichain
          of P. Moreover, la0 is not Maximal or minimal because of the abscence of x0 and
          y0. thus there is a largest antichain la0 in P other than Maximal or Minimal. This
          contradicts the hypothesis CASE2Before.  *)
          intro.

          assert(Ha: Is_largest_antichain_in  P la0).
          apply Card_same_largest with (e1:=la)(n:=m).
          assumption. apply Antichain_not_changed2 with (P1:= P_small).
          apply H80a. apply H81. apply H81. assumption. rewrite <- H3. apply H81.

          assert(NotCase2: ~(la0 = Maximal_elements_of  P) /\ ~(la0 = Minimal_elements_of  P)).
          split.

          (* SubGoal: la0 <> Maximal_elements_of *)
          apply Sets_not_equal.
          right. exists y0.
             split. destruct H81 as [H81a H81b].
             destruct H81a. destruct H4.
             (* SubSubGoal1: ~ In U la0 y0 *)
             intro.
                assert(H8: In U (Carrier_of U P_small) y0).
                destruct H4. apply H4. assumption.
                absurd (In U (Carrier_of U P_small) y0). rewrite H2. simpl.
                unfold Setminus. unfold In. apply or_not_and.
                right. assert(H8a: (Couple U x0 y0) y0). apply Couple_r.
                intro H8b. absurd (Couple U x0 y0 y0). assumption. assumption.
                assumption.
              (*SubSubGoal2: In U (Maximal_elements_of U P) y0 *)
              apply H1.

          (* SubGoal: la0 <> Minimal_elements_of *)
          apply Sets_not_equal.
          right. exists x0.
             split. destruct H81 as [H81a H81b].
             destruct H81a. destruct H4.
             (* SubSubGoal1: ~ In U la0 x0 *)
             intro.
                assert(H8: In U (Carrier_of U P_small) x0).
                destruct H4. apply H4. assumption.
                absurd (In U (Carrier_of U P_small) x0). rewrite H2. simpl.
                unfold Setminus. unfold In. apply or_not_and.
                right. assert(H8a: (Couple U x0 y0) x0). apply Couple_l.
                intro H8b. absurd (Couple U x0 y0 x0). assumption. assumption.
                assumption.
              (*SubSubGoal2: In U (Maximal_elements_of U P) x0 *)
              apply H1.

          absurd (la0 = Maximal_elements_of  P \/ la0 = Minimal_elements_of  P).
          apply and_not_or. assumption. apply CASE2Before. assumption. }

       assert(Fact3: m0 < m ). {
          assert(Fact1a: m0< m \/ m0 =m ).
          apply le_lt_or_eq. assumption.
          elim Fact1a. trivial.
          intro. absurd(m0=m). assumption. assumption. }

       assert(Fact4: S m0 <= m).
       apply Fact3.

       assert(Fact5: ~(S m0 < m)). {
       Check DilworthA.
       Print DilworthA_statement.
       assert(H84: DilworthA_statement _ P).
       apply DilworthA. unfold DilworthA_statement in H84.
       apply H84 with (cv:=(Add (Ensemble U) cv_small (Couple U x0 y0)))(a:=la).
       assumption. apply H. apply Fact0. assumption. }

       assert(Fact6: S m0 = m). {
          assert(Fact4a: S m0 < m \/ S m0 = m).
          apply le_lt_or_eq. assumption.
          elim Fact4a. intro. absurd( S m0 < m). assumption. assumption. trivial. }

    rewrite <- Fact6. assumption.

 (* CASE2: Over Here *) }

Qed.

End DilworthB.