From LF Require Export Lists.

(*Cap: POLY
POLYMORPHISM AND HIGHER-ORDER FUNCTIONS*)

(*********1.1: POLYMORPHISM*********)

(******1.1.1: Polymorphic Lists******)

Inductive boollist : Type :=
  | bool_nil
  | bool_cons (b : bool) (l : boollist).

Inductive list (X:Type) : Type :=
  | nil
  | cons (x : X) (l : list X).

Check list : Type -> Type.

Check (nil nat) : list nat.

Check (cons nat 3 (nil nat)) : list nat.

Check nil : forall X : Type, list X.

Check cons : forall X : Type, X -> list X -> list X.

Check (cons nat 2 (cons nat 1 (nil nat)))
      : list nat.

Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat X x count')
  end.

Example test_repeat1 :
  repeat nat 4 2 = cons nat 4 (cons nat 4 (nil nat)).
Proof. reflexivity. Qed.

Example test_repeat2 :
  repeat bool false 1 = cons bool false (nil bool).
Proof. simpl. reflexivity. Qed.

(*Exercise: 2 stars, standard (mumble_grumble)
Consider the following two inductively defined types.*)

Module MumbleGrumble.
Inductive mumble : Type :=
  | a
  | b (x : mumble) (y : nat)
  | c.
Inductive grumble (X:Type) : Type :=
  | d (m : mumble)
  | e (x : X).
(*Which of the following are well-typed elements of grumble X for some type X?
(Add YES or NO to each line.)
d (b a 5)
d mumble (b a 5)
d bool (b a 5)
e bool true
e mumble (b c 0)
e bool (b c 0)
c
 NO, YES, NO, YES, YES, NO*)
End MumbleGrumble.
(* Do not modify the following line: *)
Definition manual_grade_for_mumble_grumble : option (nat*string) := None.

(***1.1.1.1 Type Annotation Inference***)
Fixpoint repeat' X x count : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat' X x count')
  end.
Check repeat'
  : forall X : Type, X -> nat -> list X.
Check repeat
  : forall X : Type, X -> nat -> list X.

(***1.1.1.2 Type Argument Synthesis***)
Fixpoint repeat'' X x count : list X :=
  match count with
  | 0 => nil _
  | S count' => cons _ x (repeat'' _ x count')
  end.

Definition list123 :=
  cons nat 1 (cons nat 2 (cons nat 3 (nil nat))).

Definition list123' :=
  cons _ 1 (cons _ 2 (cons _ 3 (nil _))).

(***1.1.1.3 Implicit Arguments***)
Arguments nil {X}.
Arguments cons {X} _ _.
Arguments repeat {X} x count.

Definition list123'' := cons 1 (cons 2 (cons 3 nil)).

Fixpoint repeat''' {X : Type} (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil
  | S count' => cons x (repeat''' x count')
  end.
(*don't make like this*)
Inductive list' {X:Type} : Type :=
  | nil'
  | cons' (x : X) (l : list').

Fixpoint app {X : Type} (l1 l2 : list X)
             : (list X) :=
  match l1 with
  | nil => l2
  | cons h t => cons h (app t l2)
  end.
Fixpoint rev {X:Type} (l:list X) : list X :=
  match l with
  | nil => nil
  | cons h t => app (rev t) (cons h nil)
  end.
Fixpoint length {X : Type} (l : list X) : nat :=
  match l with
  | nil => 0
  | cons _ l' => S (length l')
  end.
Example test_rev1 :
  rev (cons 1 (cons 2 nil)) = (cons 2 (cons 1 nil)).
Proof. simpl. reflexivity. Qed.
Example test_rev2:
  rev (cons true nil) = cons true nil.
Proof. simpl. reflexivity. Qed.
Example test_length1: length (cons 1 (cons 2 (cons 3 nil))) = 3.
Proof. simpl. reflexivity. Qed.

(***1.1.1.4 Supplying Type Arguments Explicitly***)
Fail Definition mynil := nil.

Definition mynil : list nat := nil.
Check @nil : forall X : Type, list X.
Definition mynil' := @nil nat.

Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

(*Exercise: 2 stars, standard, optional (poly_exercises)
Here are a few simple exercises, just like ones in the Lists chapter,
for practice with polymorphism. Complete the proofs below.*)

Theorem app_nil_r : forall (X:Type), forall l:list X,
  l ++ [] = l.
Proof.
  intros X. intros l. induction l as [| n l'].
  - simpl. reflexivity.
  - simpl. rewrite IHl'. reflexivity. Qed.
Theorem app_assoc : forall A (l m n:list A),
  l ++ m ++ n = (l ++ m) ++ n.
Proof.
  intros A. intros l m n. induction l as [| n' l'].
  - simpl. reflexivity.
  - simpl. rewrite IHl'. reflexivity. Qed.
Lemma app_length : forall (X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
  intros X. intros l1 l2. induction l1 as [| n l1'].
  - simpl. reflexivity.
  - simpl. rewrite IHl1'. reflexivity. Qed.

(*Exercise: 2 stars, standard, optional (more_poly_exercises)
Here are some slightly more interesting ones...*)

Theorem rev_app_distr: forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros. induction l1.
  - simpl. rewrite app_nil_r. reflexivity.
  - simpl. rewrite IHl1. rewrite app_assoc. reflexivity. Qed.
Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  intros. induction l.
  - simpl. reflexivity.
  - simpl. rewrite rev_app_distr. rewrite IHl. simpl. reflexivity. Qed.

(******1.1.2 Polymorphic Pairs******)
Inductive prod (X Y : Type) : Type :=
| pair (x : X) (y : Y).
Arguments pair {X} {Y} _ _.

Notation "( x , y )" := (pair x y).

Notation "X * Y" := (prod X Y) : type_scope.

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with
  | (x , y) => x
  end.
Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with
  | (x, y) => y
  end.

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y)
           : list (X * Y) :=
  match lx, ly with
  | [], _ => []
  | _, [] => []
  | x :: tx, y :: ty => (x, y) :: (combine tx ty)
  end.

(*Exercise: 1 star, standard, optional (combine_checks)*)
(*Try answering the following questions on paper and checking your answers in Coq:
What is the type of combine (i.e., what does Check @combine print?)
What does
        Compute (combine [1;2] [false;false;true;true]).
print?*)
Check @combine. (*forall X Y : Type, list X -> list Y -> list (X * Y)*)
Compute (combine [1;2] [false;false;true;true]).
(*= [(1, false); (2, false)]
     : list (nat * bool)*)

(*Exercise: 2 stars, standard, especially useful (split)
The function split is the right inverse of combine: it takes a list of pairs
and returns a pair of lists. In many functional languages, it is called unzip.
Fill in the definition of split below. Make sure it passes the given unit test.*)

Fixpoint split {X Y : Type} (l : list (X * Y))
               : (list X) * (list Y):=
  match l with
    | [] => ([],[])
    | (x,y) :: rest => let (xs, ys) := split rest
                       in  (x :: xs, y :: ys)
  end.
Example test_split:
  split [(1,false);(2,false)] = ([1;2],[false;false]).
Proof. simpl. reflexivity. Qed.

(******1.1.3  Polymorphic Options******)
Module OptionPlayground.
Inductive option (X:Type) : Type :=
  | Some (x : X)
  | None.
Arguments Some {X} _.
Arguments None {X}.
End OptionPlayground.

Fixpoint nth_error {X : Type} (l : list X) (n : nat)
                   : option X :=
  match l with
  | nil => None
  | a :: l' => match n with
               | O => Some a
               | S n' => nth_error l' n'
               end
  end.
Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.
Proof. simpl. reflexivity. Qed.
Example test_nth_error2 : nth_error [[1];[2]] 1 = Some [2].
Proof. simpl. reflexivity. Qed.
Example test_nth_error3 : nth_error [true] 2 = None.
Proof. simpl. reflexivity. Qed.

(*Exercise: 1 star, standard, optional (hd_error_poly)
Complete the definition of a polymorphic version of the hd_error
function from the last chapter. Be sure that it passes the unit tests below.*)

Definition hd_error {X : Type} (l : list X) : option X :=
  match l with
  | nil => None
  | h :: t => Some h
  end.

(*Once again, to force the implicit arguments to be explicit,
we can use @ before the name of the function.*)

Check @hd_error : forall X : Type, list X -> option X.
Example test_hd_error1 : hd_error [1;2] = Some 1.
Proof. simpl. reflexivity. Qed.
Example test_hd_error2 : hd_error [[1];[2]] = Some [1].
Proof. simpl. reflexivity. Qed.

(*********1.2: Functions as Data*********)

(******1.2.1: Higher-Order Functions******)

Definition doit3times {X:Type} (f:X->X) (n:X) : X :=
  f (f (f n)).

Check @doit3times : forall X : Type, (X -> X) -> X -> X.
Example test_doit3times: doit3times minustwo 9 = 3.
Proof. simpl. reflexivity. Qed.
Example test_doit3times': doit3times negb true = false.
Proof. simpl. reflexivity. Qed.

(******1.2.2: Filter******)

Fixpoint filter {X:Type} (test: X->bool) (l:list X) : (list X) :=
  match l with
  | [] => []
  | h :: t =>
    if test h then h :: (filter test t)
    else filter test t
  end.

Example test_filter1: filter evenb [1;2;3;4] = [2;4].
Proof. simpl. reflexivity. Qed.
Definition length_is_1 {X : Type} (l : list X) : bool :=
  (length l) =? 1.
Example test_filter2:
    filter length_is_1
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. simpl. reflexivity. Qed.

Definition countoddmembers' (l:list nat) : nat :=
  length (filter oddb l).
Example test_countoddmembers'1: countoddmembers' [1;0;3;1;4;5] = 4.
Proof. simpl. reflexivity. Qed.
Example test_countoddmembers'2: countoddmembers' [0;2;4] = 0.
Proof. simpl. reflexivity. Qed.
Example test_countoddmembers'3: countoddmembers' nil = 0.
Proof. simpl. reflexivity. Qed.

(******1.2.2: Anonymous Functions******)

Example test_anon_fun':
  doit3times (fun n => n * n) 2 = 256.
Proof. simpl. reflexivity. Qed.

Example test_filter2':
    filter (fun l => (length l) =? 1)
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. simpl. reflexivity. Qed.

(*Exercise: 2 stars, standard (filter_even_gt7)
Use filter (instead of Fixpoint) to write a Coq function filter_even_gt7
that takes a list of natural numbers as input and returns a list of just
those that are even and greater than 7.*)
Definition filter_even_gt7 (l : list nat) : list nat:=
  filter (leb 7) (filter evenb l).
Example test_filter_even_gt7_1 :
  filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8].
Proof. reflexivity. Qed.
Example test_filter_even_gt7_2 :
  filter_even_gt7 [5;2;6;19;129] = [].
Proof. reflexivity. Qed.

(*Exercise: 3 stars, standard (partition)
Use filter to write a Coq function partition:
      partition : ∀ X : Type,
                  (X → bool) → list X → list X × list X
Given a set X, a predicate of type X → bool and a list X, partition should
return a pair of lists. The first member of the pair is the sublist of the
original list containing the elements that satisfy the test, and the second
is the sublist containing those that fail the test. The order of elements in
the two sublists should be the same as their order in the original list.*)
Fixpoint filter_not {X:Type} (test: X->bool) (l:list X)
                : (list X) :=
  match l with
  | [] => []
  | h :: t => if test h then filter_not test t
                        else h :: (filter_not test t)
  end.

Definition partition {X : Type}
                     (test : X -> bool)
                     (l : list X)
                   : list X * list X :=
  pair (filter test l) (filter_not test l).
Check @partition.
Example test_partition1: partition oddb [1;2;3;4;5] = ([1;3;5], [2;4]).
Proof. simpl. reflexivity. Qed.
Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
Proof. simpl. reflexivity. Qed.

(******1.2.3: Maps******)
Fixpoint map {X Y: Type} (f:X->Y) (l:list X) : (list Y) :=
  match l with
  | [] => []
  | h :: t => (f h) :: (map f t)
  end.

Example test_map1: map (fun x => plus 3 x) [2;0;2] = [5;3;5].
Proof. reflexivity. Qed.

Example test_map2:
  map oddb [2;1;2;5] = [false;true;false;true].
Proof. reflexivity. Qed.

Example test_map3:
    map (fun n => [evenb n;oddb n]) [2;1;2;5]
  = [[true;false];[false;true];[true;false];[false;true]].
Proof. reflexivity. Qed.

(*Exercise: 3 stars, standard (map_rev)
Show that map and rev commute. You may need to
define an auxiliary lemma.*)
Lemma map_l_n : forall (X Y: Type) (f : X -> Y) (l : list X) (n : X),
  map f l ++ [f n] = map f (l ++ [n]).
Proof.
  intros X Y f l n. induction l as [| s l'].
  - simpl. reflexivity.
  - simpl. rewrite IHl'. reflexivity. Qed.

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
  intros X Y f l. induction l as [| s l'].
  - simpl. reflexivity.
  - simpl. rewrite <- map_l_n. rewrite <- IHl'. reflexivity. Qed.

(*Exercise: 2 stars, standard, especially useful (flat_map)
The function map maps a list X to a list Y using a function
of type X → Y. We can define a similar function, flat_map,
which maps a list X to a list Y using a function f of
type X → list Y. Your definition should work by 'flattening'
the results of f, like so:
        flat_map (fun n ⇒ [n;n+1;n+2]) [1;5;10]
      = [1; 2; 3; 5; 6; 7; 10; 11; 12].*)

Fixpoint flat_map {X Y: Type} (f: X -> list Y) (l: list X)
                   : (list Y):=
  match l with
  | [] => []
  | h :: t => (f h) ++ (flat_map f t)
  end.
Example test_flat_map1:
  flat_map (fun n => [n;n;n]) [1;5;4]
  = [1; 1; 1; 5; 5; 5; 4; 4; 4].
Proof. reflexivity. Qed.
Example test_flat_map2: flat_map (fun n => [n;n+1;n+2]) [1;5;10]
      = [1; 2; 3; 5; 6; 7; 10; 11; 12].
Proof. reflexivity. Qed.

Definition option_map {X Y : Type} (f : X -> Y) (xo : option X)
                      : option Y :=
  match xo with
    | None => None
    | Some x => Some (f x)
  end.

(******1.2.4: Fold******)

Fixpoint fold {X Y: Type} (f: X->Y->Y) (l: list X) (b: Y)
                         : Y :=
  match l with
  | nil => b
  | h :: t => f h (fold f t b)
  end.

Check (fold andb) : list bool -> bool -> bool.
Example fold_example1 :
  fold mult [1;2;3;4] 1 = 24.
Proof. reflexivity. Qed.
Example fold_example2 :
  fold andb [true;true;false;true] true = false.
Proof. reflexivity. Qed.
Example fold_example3 :
  fold app [[1];[];[2;3];[4]] [] = [1;2;3;4].
Proof. reflexivity. Qed.

(******1.2.5: Functions That Construct Functions******)
Definition constfun {X: Type} (x: X) : nat->X :=
  fun (k:nat) => x.
Definition ftrue := constfun true.
Example constfun_example1 : ftrue 0 = true.
Proof. reflexivity. Qed.
Example constfun_example2 : (constfun 5) 99 = 5.
Proof. reflexivity. Qed.

Check plus : nat -> nat -> nat.

Definition plus3 := plus 3.
Check plus3 : nat -> nat.
Example test_plus3 : plus3 4 = 7.
Proof. reflexivity. Qed.
Example test_plus3' : doit3times plus3 0 = 9.
Proof. reflexivity. Qed.
Example test_plus3'' : doit3times (plus 3) 0 = 9.
Proof. reflexivity. Qed.

(*********1.3: Additional Exercises*********)
Module Exercises.

(*Exercise: 2 stars, standard (fold_length)
Many common functions on lists can be implemented in terms of fold.
For example, here is an alternative definition of length:*)

Definition fold_length {X : Type} (l : list X) : nat :=
  fold (fun _ n => S n) l 0.
Example test_fold_length1 : fold_length [4;7;0] = 3.
Proof. reflexivity. Qed.
(*Prove the correctness of fold_length.
(Hint: It may help to know that reflexivity simplifies
expressions a bit more aggressively than simpl does -- i.e.,
 you may find yourself in a situation where simpl does nothing
but reflexivity solves the goal.)*)

Theorem fold_length_correct : forall X (l : list X),
  fold_length l = length l.
Proof.
  intros X l. induction l as [|s l'].
  - simpl. reflexivity.
  - simpl. rewrite <- IHl'. reflexivity. Qed.

(*Exercise: 3 stars, standard (fold_map)
We can also define map in terms of fold. Finish fold_map below.*)

Definition fold_map {X Y: Type} (f: X -> Y) (l: list X) : list Y:=
  fold (fun x lx => [f x] ++ lx) l [].

Example test_fold_map1: fold_map (fun x => plus3 x) [2;0;2] = [5;3;5].
Proof. reflexivity. Qed.
(*Write down a theorem fold_map_correct in Coq stating that fold_map
 is correct, and prove it. (Hint: again, remember that reflexivity
 simplifies expressions a bit more aggressively than simpl.)*)

(*Exercise: 2 stars, advanced (currying)
In Coq, a function f : A → B → C really has the type A → (B → C).
That is, if you give f a value of type A, it will give you
function f' : B → C. If you then give f' a value of type B, it will
return a value of type C. This allows for partial application, as in
plus3. Processing a list of arguments with functions that return functions
is called currying, in honor of the logician Haskell Curry.
Conversely, we can reinterpret the type A → B → C as (A × B) → C.
This is called uncurrying. With an uncurried binary function, both
arguments must be given at once as a pair; there is no partial application.
We can define currying as follows:*)

Definition prod_curry {X Y Z : Type}
  (f : X * Y -> Z) (x : X) (y : Y) : Z := f (x, y).

(*As an exercise, define its inverse, prod_uncurry. Then prove the theorems
below to show that the two are inverses.*)

Definition prod_uncurry {X Y Z : Type}
  (f : X -> Y -> Z) (p : X * Y) : Z:=
  f (fst p) (snd p).
(*As a (trivial) example of the usefulness of currying, we can use it to shorten
one of the examples that we saw above:*)

Example test_map1': map (plus 3) [2;0;2] = [5;3;5].
Proof. reflexivity. Qed.
(*Thought exercise: before running the following commands,
can you calculate the types of prod_curry and prod_uncurry?*)

Check @prod_curry.
Check @prod_uncurry.
Theorem uncurry_curry : forall(X Y Z : Type)
                        (f : X -> Y -> Z)
                        x y,
  prod_curry (prod_uncurry f) x y = f x y.
Proof.
  intros X Y Z f x y. reflexivity. Qed.
Theorem curry_uncurry : forall (X Y Z : Type)
                        (f : (X * Y) -> Z) (p : X * Y),
  prod_uncurry (prod_curry f) p = f p.
Proof.
    intros X Y Z f p. destruct p. reflexivity. Qed.

(*Exercise: 2 stars, advanced (nth_error_informal)
Recall the definition of the nth_error function:*)
   Fixpoint nth_error {X : Type} (l : list X) (n : nat) : option X :=
     match l with
     | [] => None
     | a :: l' => if n =? O then Some a else nth_error l' (pred n)
     end.
(*Write an informal proof of the following theorem:
   forall X l n, length l = n -> @nth_error X l n = None
(* FILL IN HERE *)
(* Do not modify the following line: *)
Definition manual_grade_for_informal_proof : option (nat×string) := None.*)

(*** Church numerals***)
Module Church.
Definition cnat := forall X : Type, (X -> X) -> X -> X.

Definition one : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f x.

Definition two : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => f (f x).

Definition zero : cnat :=
  fun (X : Type) (f : X -> X) (x : X) => x.

Definition three : cnat := @doit3times.
(*Complete the definitions of the following functions. Make sure that the
corresponding unit tests pass by proving them with reflexivity.*)
(*************************
(*Exercise: 1 star, advanced (church_succ)
Successor of a natural number: given a Church numeral n,
the successor succ n is a function that iterates its argument once more than n.*)
Definition succ (n : cnat) : cnat:=
  fun (X : Type) (f : X -> X) (x : X) => f (n X f x).
Example succ_1 : succ zero = one.
Proof. reflexivity. Qed.
Example succ_2 : succ one = two.
Proof. simpl. reflexivity. Qed.
Example succ_3 : succ two = three.
Proof. reflexivity. Qed.

(*Exercise: 1 star, advanced (church_plus)
Addition of two natural numbers:*)
Definition plus (n m : cnat) : cnat:=
  fun (X : Type) (f : X -> X) (x : X) =>(n X f(m X f x)).
Example plus_1 : plus zero one = one.
Proof. reflexivity. Qed.
Example plus_2 : plus two three = plus three two.
Proof. reflexivity. Qed.
Example plus_3 :
  plus (plus two two) three = plus one (plus three three).
Proof. reflexivity. Qed.

(*Exercise: 2 stars, advanced (church_mult)
Multiplication:*)
Definition mult (n m : cnat) : cnat:=
  fun (X : Type) (f : X -> X) (x : X) => (n X (m X f) x).
Example mult_1 : mult one one = one.
Proof. reflexivity. Qed.
Example mult_2 : mult zero (plus three three) = zero.
Proof. reflexivity. Qed.
Example mult_3 : mult two three = plus three three.
Proof. reflexivity. Qed.

(*Exercise: 2 stars, advanced (church_exp)
Exponentiation:
(Hint: Polymorphism plays a crucial role here. However, choosing the
right type to iterate over can be tricky. If you hit a "Universe inconsistency"
error, try iterating over a different type. Iterating over cnat itself is
usually problematic.)*)

Definition exp (n m : cnat) : cnat:=
  fun (X : Type) (f : X -> X) (x : X) => (m (X -> X) (n X) f) x.
Example exp_1 : exp two two = plus two two.
Proof. reflexivity. Qed.
Example exp_2 : exp three zero = one.
Proof. reflexivity. Qed.
Example exp_3 : exp three two = plus (mult two (mult two two)) one.
Proof. reflexivity. Qed. ********************)

End Church.
End Exercises.


(* This file contains  DEFINITIONS of some basic notions related to Finite Partial Orders.
     It also contains some elementary RESULTS on Chains, antichains and finite posets. Following
     is a partial list of these definitions and results.

DEFINITIONS: ---------------------------------------------------------------------------
  1. Record FPO: Defines the notion of Finite Partial orders.

  2. Is_a_chain_in: Defines a chain as a predicate.

  3. Is_an_antichain_in: Defines antichain as a predicate.

  4. Is_the_largest_element_in: Defines the largest element  of a finite poset.

  5. Is_the_smallest_element_in: Defines the smallest element of a finite poset.

  6. Is_a_chain_cover: Defines a chain cover of finite posets.

  7. Is_an_antichain_cover: Defines an antichain cover of finite posets.

  8. Is_a_disjoint_cover: Defines the notion of a disjoint chain cover.

RESULTS on finite posets: --------------------------------------------------------------

0.Lemma NoTwoCommon: A chain and an antichain intersects at atmost one point.

1.Lemma Antichain_exists: In every finite poset there is an antichain.

2.Lemma Chain_exists: In every finite poset there is a chain.

3.Lemma Minimal_element_exists: There exists a minimal element in every finite poset.

4.Lemma Maximal_element_exists: There exists a maximal element in every finite poset.

5.Lemma Minimal_for_every_y: In a finite poset for every element y there exists x such that R x y

6.Lemma Maximal_for_every_x: In a finite poset for every element x there exists y such that R x y

7.Lemma Largest_element_exists: In a totally ordered finite poset there exists a largest element.

8.Lemma Maximal_is_largest:In totally ordered finite posets Maximal element is largest element.

9.Lemma Smallest_element_exists:In a totally ordered finite poset there exists a smallest element

----------------------------------------------------------------------------------------    *)

Require Export PigeonHole.
Require Export BasicFacts.
Require Export Partial_Order .

Section Finite_Chain_Def.

  Variable U:Type.

  Check PO U.
  Print PO.
  Print Finite.

  Record FPO (U : Type) : Type := Definition_of_FPO
  { PO_of :> PO U ;

    FPO_cond : Finite _ (Carrier_of _ PO_of  ) }.

  Variable P :FPO U.
  Let C := @ Carrier_of U P.

  Let R := @Rel_of U P.

  Check FPO.
  Check Carrier_of _ P.

  Lemma Finite_PO: forall (P: FPO U), Finite _ (Carrier_of _ P).
  Proof. intro. apply FPO_cond. Qed.

  Set Implicit Arguments.
  Definition Is_a_chain_in (e: Ensemble U): Prop:=
    (Included U e C /\ Inhabited U e)/\
                (forall x y:U, (Included U (Couple U x y) e)-> R x y \/ R y x).

  Definition Is_an_antichain_in (e: Ensemble U): Prop := (Included U e C /\ Inhabited U e)/\
                (forall x y:U, (Included U (Couple U x y) e)-> (R x y \/ R y x)-> x=y).

 Inductive Is_largest_chain_in (e: Ensemble U): Prop:=
   largest_chain_cond:  Is_a_chain_in e ->
                        (forall (e1: Ensemble U) (n n1:nat),
                        Is_a_chain_in e1 -> cardinal _ e n -> cardinal _ e1 n1 ->
                        n1<= n) -> Is_largest_chain_in e.

 Inductive Is_largest_antichain_in (e: Ensemble U): Prop:=
   largest_antichain_cond:  Is_an_antichain_in e ->
                            (forall (e1: Ensemble U) (n n1: nat),
                              Is_an_antichain_in e1 -> cardinal _ e n ->
                              cardinal _ e1 n1 -> n1<=n ) ->
                              Is_largest_antichain_in e.

 (* ---------------------- MINIMAL AND MAXIMAL ARE ANTICHAINS ------------------------ *)
 (* ---------------------------------------------------------------------------------- *)

Definition Is_a_maximal_element (x:U): Prop:= In _ C x /\  ~(exists y:U, In _ C y /\ x<>y /\ R x y  ).

Definition Is_a_minimal_element (x: U): Prop:= In _ C x /\ ~(exists y:U, In _ C y /\ x<>y /\ R y x ).

Definition Maximal_elements_of: Ensemble U:=
    fun x:U => Is_a_maximal_element x.

Definition Minimal_elements_of: Ensemble U:=
    fun x:U => Is_a_minimal_element x.

Definition Is_the_largest_element_in (U:Type)(FP: FPO U)(y:U): Prop:= let C0:= Carrier_of _ FP in let R0:= Rel_of _ FP in ( In _ C0 y /\ forall x:U, (In _ C0 x -> R0 x y) ).

Definition Is_the_smallest_element_in (U:Type)(FP: FPO U)(x:U): Prop:= let C0:= Carrier_of _ FP in let R0:= Rel_of _ FP in ( In _ C0 x /\ forall y:U, (In _ C0 y -> R0 x y) ).

  (* _________________________ CHAIN COVER AND ANTICHAIN COVER ___________________________  *)

  Inductive Is_a_chain_cover (cover: Ensemble (Ensemble U)): Prop:=
    cover_cond: (forall (e: Ensemble U), In _ cover e -> Is_a_chain_in e)->
                (forall x:U, In _ C x -> (exists e: Ensemble U, In _ cover e /\ In _ e x)) ->
                Is_a_chain_cover cover.

  Inductive Is_an_antichain_cover (cover: Ensemble (Ensemble U)): Prop:=
    AC_cover_cond: (forall (e: Ensemble U), In _ cover e -> Is_an_antichain_in e)->
                (forall x:U, In _ C x -> (exists e: Ensemble U, In _ cover e /\ In _ e x)) ->
                Is_an_antichain_cover cover.

  Lemma NoTwoCommon : forall (X Y : Ensemble U) (x y :U),
                        Is_a_chain_in X -> Is_an_antichain_in Y ->
                        Included U (Couple U x y) X -> Included U (Couple U x y) Y ->
                        x = y.

  Proof. { intros X Y x y. intros chainX antichainY H1 H2.
         assert (H:R x y \/ R y x ). destruct chainX. apply H0.
         assumption.
         destruct antichainY. apply H3.
         assumption. assumption. }  Qed.

  Definition Is_a_disjoint_cover (cover : Ensemble ( Ensemble U)): Prop:=
  Is_a_chain_cover  cover /\ (forall e1 e2 : Ensemble U,
                            (In _ cover e1 /\ In _ cover e2)-> (e1=e2 \/ Disjoint _ e1 e2 )).

  Unset Implicit Arguments.

End Finite_Chain_Def.

 Ltac apply_fpo_def := match goal with
                        |_:_|- Is_largest_chain_in ?P ?e => (eapply largest_chain_cond)
                        |_:_ |- Is_largest_antichain_in ?P ?e => (eapply largest_antichain_cond)
                        |_:_ |- Is_a_chain_cover ?P ?cover => (eapply cover_cond)
                        |_:_ |- Is_an_antichain_cover ?P ?cover => (eapply AC_cover_cond)
                        end.

Section Finite_Chain_Facts.

  Variable U: Type.
  Variable FP: FPO U.

  Let C := @ Carrier_of U FP.

  Let R := @Rel_of U FP.

  Lemma Singleton_is_chain: forall x: U, In _ C x -> Is_a_chain_in FP (Singleton _ x).
  Proof. { intros. unfold Is_a_chain_in. split.
              { split. unfold Included. intros. destruct H0. apply H.
                apply Inhabited_intro with (x:=x). auto with sets. }
              { intros. unfold Included in H0.
                assert (In U (Singleton U x) x0).
                { apply H0. auto with sets. }
                assert (In U (Singleton U x) y).
                { apply H0. auto with sets. }
                destruct H1; destruct H2. left. apply PO_cond2.  }   }  Qed.

  Lemma Singleton_is_antichain: forall x: U, In _ C x -> Is_an_antichain_in FP (Singleton _ x).
    Proof. { intros.  unfold Is_an_antichain_in. split.
              { split. unfold Included. intros. destruct H0. apply H.
                apply Inhabited_intro with (x:=x). auto with sets. }
              { intros. unfold Included in H0.
                assert (In U (Singleton U x) x0).
                { apply H0. auto with sets. }
                assert (In U (Singleton U x) y).
                { apply H0. auto with sets. }
                destruct H2; destruct H3. reflexivity.  }  } Qed.

Lemma Antichain_exists:  exists e: Ensemble U, Is_an_antichain_in FP e.
    Proof.  { assert (T: Inhabited _ C). Print PO. apply PO_cond1.  destruct T.
              exists (Singleton _ x). apply Singleton_is_antichain. auto. }  Qed.

Lemma Chain_exists:  exists e: Ensemble U, Is_a_chain_in FP e.
Proof.  { assert (T: Inhabited _ C). Print PO. apply PO_cond1.  destruct T.
              exists (Singleton _ x). apply Singleton_is_chain. auto.  }  Qed.

Lemma Chain_cover_exists: exists cover: Ensemble (Ensemble U), Is_a_chain_cover FP cover.
Proof. { pose (cover (e: Ensemble U):= exists x: U, In _ C x /\ e = Singleton _ x).
         exists cover.
         Print Is_a_chain_cover. apply cover_cond.
         { intros. unfold In in H. unfold cover in H. destruct H. destruct H.
           rewrite H0. apply Singleton_is_chain.  auto. }
         { intros. exists (Singleton _ x).  split. unfold In. unfold cover. exists x. tauto.
           auto with sets.  }  }  Qed.

Lemma Antichain_cover_exists: exists cover: Ensemble (Ensemble U), Is_an_antichain_cover FP cover.
Proof. { pose (cover (e: Ensemble U):= exists x: U, In _ C x /\ e = Singleton _ x).
         exists cover.
         Print Is_an_antichain_cover. apply AC_cover_cond.
         { intros. unfold In in H. unfold cover in H. destruct H. destruct H.
           rewrite H0. apply Singleton_is_antichain.  auto. }
         { intros. exists (Singleton _ x).  split. unfold In. unfold cover. exists x. tauto.
           auto with sets.  }   }  Qed.

Lemma Minimal_element_exists: forall (P: FPO U), exists x: U, Is_a_minimal_element P x.
Proof. { intros P'.
       pose (C':= Carrier_of _ P').
       pose ( R':= Rel_of _ P' ).
       assert (H: exists n: nat, cardinal _ C' n).
       { apply finite_cardinal. Print FPO. eapply FPO_cond. }

       destruct H as [n' H]. generalize H. unfold C'.  generalize P' as P0.
       generalize n' as n0. clear H. clear P' C' R' n'. intro n0.
       induction n0.
       (* Base Case: n=0 then P0 cannot be  a Poset *)
       { intros. apply cardinal_elim  with (p:= 0) in H.
         assert (H1: Inhabited _ (Carrier_of U P0)). (* since PO_cond1 says so *)
         Print PO. apply PO_cond1. rewrite H in H1.
         inversion H1. inversion H0.  }

       (* Induction Step: When P0 is inhabited. *)
       intros.
       assert (H0: exists x: U, In _ (Carrier_of U P0) x).
       { Print PO. destruct (PO_cond1 _ P0). exists x. tauto.  }
       destruct H0 as [a H0].

       pose (C':= Subtract _ (Carrier_of _ P0) a).
       pose (R0:= Rel_of _ P0).

       assert (T: Carrier_of _ P0 = Add _ C' a).
       { apply Extensionality_Ensembles. unfold C'. auto with sets.  }

       elim (EM (Inhabited _ C')).

       (* CASE1: When C' is non-empty then P' will be the Poset with carrier C' *)
       { intros. Print FPO.
         assert (PS_Finite: Finite _ C').
         { cut (Finite _ (Carrier_of _ P0)).
           intro. eapply Finite_downward_closed.  exact H2. rewrite T.
           auto with sets. apply (FPO_cond _ P0). }

         Print PO.
         pose (P_small:= {| Carrier_of:= C';
                            Rel_of:= Rel_of _ P0;
                            PO_cond1:= H1;
                            PO_cond2:= PO_cond2 _ P0 |}).
         Print FPO.
         pose (S_P0:= {| PO_of:= P_small ; FPO_cond:= PS_Finite |}).

         assert (T0: ~ In _ C' a).
         { unfold C'. intro. inversion H2. apply H4.  auto with sets.  }

         assert (H2: cardinal _ C' n0).
         { rewrite T in H.
           assert (n0 = pred (S n0)).
           { auto with arith. } rewrite H2. eapply card_soustr_1.  rewrite T. tauto.  tauto.  }

         assert (H3: exists x : U, Is_a_minimal_element S_P0 x). (* Using IHn0 *)
         { eapply IHn0. auto.  } destruct H3 as [b H3].

         (* At this point a is an element in P0 and b is in S_P0 *)
         (* Moreover b is a minimal element of S_P0 *)
         (* Either R a b is true or false ; in each case we produce a witness *)
         elim (EM ( R0 a b)).
         (* CASE A: when R0 a b *)
         { (* In this case a is the minimal_element. We prove it by contradiction.
              We assume that a ia not the minimal then there must exists some a0, which
              is smaller than a. by transitivity it must also be smaller than b. Hence
              b canot be the minimal of C' which contradicts H3.  *)
           intro. exists a.  unfold Is_a_minimal_element.
           split.
           { tauto. }
           { intro. (* assuming there is a a0 smaller than a we produce a contradiction *)
            destruct H5 as [a0 H5].
            assert (H6: R0 a0 b). (* Using the transitivity of R0 *)
            { Print Order. cut (Transitive _ R0). intro. eapply H6 with (y:=a); tauto.
              apply PO_cond2. }

            assert (H7: a <> b). (* since b is in C' and a is outside it *)
            { intro. absurd ( In _ C' a). auto. rewrite H7. apply H3. }

            assert (H8: a0 <> b).
            (* otherwise R0 a b and R b a will become true for diffrent a and b *)
            (* this violets the antysymmetricity of R0 *)
            { intro. absurd ( R0 b a). cut (Antisymmetric _ R0).
              intro. intro. apply H7. apply H9; tauto. apply PO_cond2.
              rewrite <- H8. tauto.  }

            assert (H9: In _ C' a0). (* since it is in P0 but not equal to a *)
            { unfold C'. unfold Subtract. unfold Setminus.  unfold In.
              split. tauto. intro. destruct H9.
              absurd (a = a). tauto. reflexivity.  }

            assert (H10: ~ Is_a_minimal_element S_P0 b).
            { intro.  unfold Is_a_minimal_element in H10.
              destruct H10 as [H10 H11]. apply H11.
              exists a0. split. tauto. split. intro. apply H8. symmetry. auto.
              simpl. auto. }

            contradiction. }   }

         (* CASE B: When ~ R0 a b *)
         {  intro.  exists b.
            unfold Is_a_minimal_element.
            rewrite T.
            split.
            { unfold Add.  apply Union_introl. destruct H3. simpl in H3. auto. }
            { intro.  destruct H3. apply H6.
              destruct H5 as [b0 H5].
              assert ( H7: b0<>a).
              { intro. absurd (R0 a b). auto.  rewrite <- H7.   tauto.  }
              assert (H8: In _ C' b0).
              { unfold C'. unfold Subtract. unfold In. unfold Setminus.
                split. rewrite T. tauto. intro. destruct H8. tauto. }

              exists b0.  simpl. tauto.  }      }  }

       (* CASE2: When C' is empty then a is the minimal element. *)
       { intros. exists a. unfold Is_a_minimal_element.  split. auto.
         intro. apply H1. destruct H2 as [b H2]. Print Inhabited.
         apply Inhabited_intro with (x:=b). unfold C'. unfold Subtract. unfold Setminus.
         unfold In.  split. tauto. intro.
         destruct H3. destruct H2 as [H2 H3]. destruct H3 as [H3 H4].
         apply H3. reflexivity.  }   }   Qed.

Lemma Maximal_element_exists:  forall (P: FPO U), exists x: U, Is_a_maximal_element P x.
Proof. { intro P. Print PO.
         pose ( C':= Carrier_of _ P).
         pose ( R'(x:U)(y:U):= (Rel_of _ P) y x ).
         assert (T: Order _ R' ).
         { assert (T1: Order _ (Rel_of _ P)).
           { apply PO_cond2. } Print Order. destruct T1.
           apply Definition_of_order.
           { unfold R'. apply H. }
           { unfold R'. unfold Transitive.  Print Transitive.
             intros. eapply H0. exact H3. auto. }
           { unfold R'. unfold Antisymmetric. intros. apply H1; tauto. }
         }

         pose (PO_P':= {| Carrier_of:= C' ;
                          Rel_of:= R' ;
                          PO_cond1:= (PO_cond1 _ P);
                          PO_cond2:= T |}).

         pose (P':= {| PO_of:= PO_P' ; FPO_cond:= (FPO_cond _ P) |}).

         assert (T1: forall x: U, Is_a_minimal_element P' x -> Is_a_maximal_element P x ).
         { intros. unfold Is_a_maximal_element.
           split. apply H. destruct H as [H H1].
           intro H2. apply H1. destruct H2 as [y H2].
           exists y. simpl. unfold C'. unfold R'. tauto.  }

         assert (H: exists x: U, Is_a_minimal_element P' x).
         { apply Minimal_element_exists.  } destruct H as [x H].

         exists x. auto.   }    Qed.

Lemma Minimal_is_antichain: Is_an_antichain_in FP  (Minimal_elements_of FP).
Proof. { unfold Is_an_antichain_in. split.
         (* Minimal_elements_of is Included in C and is also Inhabited *)
         { split.
           { unfold Included.  intros. unfold Minimal_elements_of in H. unfold In in H.
             destruct H. auto. }
           { unfold Minimal_elements_of.
             assert ( H: exists x: U, Is_a_minimal_element FP x ).
             { eapply Minimal_element_exists. }
             destruct H as [x H].  eapply Inhabited_intro with (x:=x).
             unfold In. auto. } }

         (* No two elements are related in Minimal_elements_of. *)
         { intros.
           assert (H1: Is_a_minimal_element FP x).
           { unfold Included in H. unfold In in H at 2. unfold Minimal_elements_of in H.
             apply H.  auto with sets.  }
           assert (H2: Is_a_minimal_element FP y).
           { unfold Included in H. unfold In in H at 2. unfold Minimal_elements_of in H.
             apply H.  auto with sets.  }

           unfold Is_a_minimal_element in H1. unfold Is_a_minimal_element in H2.
           elim (EM ( x=y )). tauto. intro.
           elim H0.
           { intro.
           absurd (exists y0 : U, In U C y0 /\ y <> y0 /\ R y0 y).
           tauto. exists x. split. tauto. split. intro. apply H3. symmetry. auto. auto. }
           { intro.
           absurd (exists y : U, In U C y /\ x <> y /\ R y x).
           tauto. exists y. split. tauto. split. intro. apply H3. symmetry. auto. auto. }  }    }   Qed.

Lemma Maximal_is_antichain: Is_an_antichain_in FP (Maximal_elements_of FP).
Proof. { unfold Is_an_antichain_in. split.
         (* Maximal_elements_of is Included in C and is also Inhabited *)
         { split.
           { unfold Included.  intros. unfold Maximal_elements_of in H. unfold In in H.
             destruct H. auto. }
           { unfold Maximal_elements_of.
             assert ( H: exists x: U, Is_a_maximal_element FP x ).
             { eapply Maximal_element_exists.  }
             destruct H as [x H].  eapply Inhabited_intro with (x:=x).
             unfold In. auto. } }

         (* No two elements are related in Maximal_elements_of. *)
         { intros.
           assert (H1: Is_a_maximal_element FP x).
           { unfold Included in H. unfold In in H at 2. unfold Maximal_elements_of in H.
             apply H.  auto with sets.  }
           assert (H2: Is_a_maximal_element FP y).
           { unfold Included in H. unfold In in H at 2. unfold Maximal_elements_of in H.
             apply H.  auto with sets.  }

           unfold Is_a_maximal_element in H1. unfold Is_a_maximal_element in H2.
           elim (EM ( x=y )). tauto. intro.
           elim H0. Focus 2.
           intro.
           absurd (exists y0 : U, In U C y0 /\ y <> y0 /\ R y y0).
           tauto. exists x. split. tauto. split. intro. apply H3. symmetry. auto. auto.
           intro.
           absurd (exists y : U, In U C y /\ x <> y /\ R  x y).
           tauto. exists y. split. tauto. split. intro. apply H3. symmetry. auto. auto.   }    }  Qed.

Lemma Minimal_for_every_y: forall y: U, (In _ C y) -> (exists x:U, Is_a_minimal_element FP x /\ R x y ).
Proof. { intros.
         (* We consider the set of all elements Cy which are less than y and in C *)
         (* We show that it form a partial oredr with R as relation *)
         (* Therefore there must exists a minimal_element m in this set Cy *)
         (* This element is less than y i.e R m y and we show that this is also a
            minimal element in C *)
         pose (Cy (x:U):= In _ C x /\ R x y).

         assert (T: Order _ R).
         {apply PO_cond2. }
         destruct T as [T1 T2 T3].

         assert (T4: In _ Cy y).
         {unfold In.  unfold Cy. split. auto. apply T1.  }

         assert (H0: Included _ Cy C).
         { unfold Included. intros. apply H0.  }

         assert (H1: Inhabited _ Cy).
         { Print Inhabited. apply Inhabited_intro with (x:=y). tauto. }

         assert (H2: Finite _ Cy).
         { eapply Finite_downward_closed with (A:=C). apply FPO_cond. auto. }

          pose (P_y:= {| Carrier_of:= Cy;
                            Rel_of:= R;
                            PO_cond1:= H1;
                            PO_cond2:= PO_cond2 _ FP |}).
         pose (FP_y:= {| PO_of:= P_y; FPO_cond:= H2 |}).

         assert (H3:  exists x: U, Is_a_minimal_element FP_y x).
         apply Minimal_element_exists. destruct H3 as [m H3].

         assert (T5: R m y).
         { unfold Is_a_minimal_element in H3. simpl in H3.  apply H3. }

         exists m.
         split.
         { unfold Is_a_minimal_element. unfold C in H0.
           split.
           { apply H0. apply H3. }
           { intro. destruct H4 as [m0 H4].
             assert (H5: R m0 y).
             { eapply T2 with (y:=m); tauto.  }
             assert (H6: In _ Cy m0).
             { unfold In. unfold Cy. tauto. }
             assert (H7: ~ R  m0 m). (* since m is the minimal in Cy and m0 is also in  Cy *)
             { intro. unfold Is_a_minimal_element in H3. destruct H3 as [H3 HT].
               apply HT. exists m0. tauto.  }
             absurd ( R m0 m );tauto.  }  }
         { tauto. }

       } Qed.

Lemma Maximal_for_every_x: forall x:U, (In _ C x) -> (exists y: U, Is_a_maximal_element FP y /\ R x y ).
Proof.  { intros.
         (* We consider the set of all elements Cx which are greater than x and in C *)
         (* We show that it form a partial oredr with R as relation *)
         (* Therefore there must exists a maximal_element m in this set Cx *)
         (* This element is bigger than x i.e R x m  and we show that this is also a
            maximal element in C *)
         pose (Cx (y:U):= In _ C y /\ R x y).

         assert (T: Order _ R).
         {apply PO_cond2. }
         destruct T as [T1 T2 T3].

         assert (T4: In _ Cx x).
         {unfold In.  unfold Cx. split. auto. apply T1.  }

         assert (H0: Included _ Cx C).
         { unfold Included. intros.  apply H0.  }

         assert (H1: Inhabited _ Cx).
         { Print Inhabited. apply Inhabited_intro with (x:=x). tauto. }

         assert (H2: Finite _ Cx).
         { eapply Finite_downward_closed with (A:=C). apply FPO_cond. auto. }

          pose (P_x:= {| Carrier_of:= Cx;
                            Rel_of:= R;
                            PO_cond1:= H1;
                            PO_cond2:= PO_cond2 _ FP |}).
         pose (FP_x:= {| PO_of:= P_x; FPO_cond:= H2 |}).

         assert (H3:  exists x: U, Is_a_maximal_element FP_x x).
         apply Maximal_element_exists. destruct H3 as [m H3].

         assert (T5: R x m ).
         { unfold Is_a_maximal_element in H3. simpl in H3.  apply H3. }

         exists m.
         split.
         { unfold Is_a_maximal_element. unfold C in H0.
           split.
           { apply H0. apply H3. }
           { intro. destruct H4 as [m0 H4].
             assert (H5: R x m0 ).
             { eapply T2 with (y:=m); tauto.  }
             assert (H6: In _ Cx m0).
             { unfold In. unfold Cx. tauto. }
             assert (H7: ~ R m m0). (* since m is the maximal in Cx and m0 is also in  Cx *)
             { intro. unfold Is_a_maximal_element in H3. destruct H3 as [H3 HT].
               apply HT. exists m0. tauto.  }
             absurd ( R  m m0 );tauto.  }  }
         { tauto. }

       } Qed.

 Lemma Every_minimal_has_a_maximal:
    forall x:U, (In _ (Minimal_elements_of FP)  x)->
                (exists y:U, In _  (Maximal_elements_of FP)  y /\ R x y).
 Proof. { intros.
          assert (H1: In _ C x).
          { apply H. }
          assert (H2: exists y: U, Is_a_maximal_element FP y /\ R x y ).
          { apply Maximal_for_every_x. auto. }

          destruct H2 as [y H2].
          exists y. unfold Maximal_elements_of. unfold In. tauto.  } Qed.

  Lemma Every_maximal_has_a_minimal:
      forall y:U, (In _ (Maximal_elements_of FP) y)->
                  (exists x:U, In _ (Minimal_elements_of FP) x /\ R x y).
  Proof.  { intros.
          assert (H1: In _ C y).
          { apply H. }
          assert (H2: exists x: U, Is_a_minimal_element FP x /\ R x y ).
          { apply Minimal_for_every_y. auto. }

          destruct H2 as [x H2].
          exists x. unfold Minimal_elements_of. unfold In. tauto.  } Qed.

  Lemma Exists_pair_xy:
    exists (x y:U), (In _ (Minimal_elements_of FP) x)/\ (In _ (Maximal_elements_of FP) y)/\ R x y.
  Proof. { assert(H: exists x:U, In _ (Minimal_elements_of FP) x ). elim Minimal_is_antichain.
         intros. destruct H as [H H1]. destruct H1.  exists x.
         assumption. destruct H as [x0 H].
         exists x0. elim Every_minimal_has_a_maximal with (x:=x0). intros y0 H1.
         exists y0. split. assumption. assumption. assumption. }
  Qed.

  Lemma Largest_card_same: forall (e1 e2: Ensemble U)(n:nat),
                              Is_largest_antichain_in FP e1 -> Is_largest_antichain_in FP e2 ->
                              (cardinal _ e1 n) -> cardinal _ e2 n.
  Proof. { intros.
           assert (exists m:nat, cardinal _ e2 m).
           { apply finite_cardinal. destruct H0. destruct H0.
             apply Finite_downward_closed with (A:= C). apply FPO_cond.
             tauto. } destruct H2 as [m H2].

           assert (H3: m<=n).
           {  Print Is_largest_antichain_in. destruct H.  eapply H3 with (e2:= e2).
              apply H0. auto. auto.  }

           assert (H4: n<=m).
           { destruct H0. eapply H4 with (e1:= e1). apply H. auto. auto. }

           assert (H5: m=n).
           { auto with arith.  }

           rewrite <- H5. auto. } Qed.

  Lemma Card_same_largest: forall (e1 e2: Ensemble U)(n: nat),
                             Is_largest_antichain_in FP e1 -> Is_an_antichain_in FP e2 ->
                             (cardinal _ e1 n)-> (cardinal _ e2 n)->
                             Is_largest_antichain_in FP e2.
  Proof. { intros.  Print Is_largest_antichain_in.
           apply largest_antichain_cond.
           auto.
           { intros.
             assert (H6: n0=n).
             { eapply cardinal_unicity. exact H4.  auto. }
             rewrite H6.
             destruct H. eapply H7. exact H3. auto. auto.  }   }  Qed.

Lemma Largest_element_exists: Totally_ordered _ FP C ->  exists x: U, Is_the_largest_element_in FP x.
Proof. { intros. destruct H. elim Maximal_element_exists with (P:= FP).
       intro max. intro. exists max.
       assert (Order _ R).
       { apply PO_cond2. }
       destruct H1.
       unfold Is_the_largest_element_in. unfold Is_a_maximal_element in H0.
       split. tauto. intros.
       elim (classic (max = x)).
       { intro. rewrite H5.  apply H1. }
       { intro.
         assert (Rel_of U FP x max \/ Rel_of U FP max x).
         { apply H. unfold C. auto with sets. unfold Included. intros. destruct H6.
           apply H4. apply H0. }
         elim H6. tauto.
         intro. absurd (exists y : U, In U (Carrier_of U FP) y /\ max <> y /\ Rel_of U FP max y).
         apply H0.
         exists x. tauto.   }  } Qed.

Lemma Maximal_is_largest: Totally_ordered _ FP C -> (forall x: U, Is_a_maximal_element FP x ->
                                                            Is_the_largest_element_in FP x).
  Proof.  { intro. intro max. intro.
       assert (Order _ R).
       { apply PO_cond2. }
       destruct H1.
       unfold Is_the_largest_element_in. unfold Is_a_maximal_element in H0.
       split. tauto. intros.
       elim (classic (max = x)).
       { intro. rewrite H5.  apply H1. }
       { intro.
         assert (Rel_of U FP x max \/ Rel_of U FP max x).
         { apply H. unfold C. auto with sets. unfold Included. intros. destruct H6.
           apply H4. apply H0. }
         elim H6. tauto.
         intro. absurd (exists y : U, In U (Carrier_of U FP) y /\ max <> y /\ Rel_of U FP max y).
         apply H0.
         exists x. tauto.   }  } Qed.

Lemma Minimal_is_smallest:  Totally_ordered _ FP C -> (forall x: U, Is_a_minimal_element FP x ->
                                                              Is_the_smallest_element_in FP x).
  Proof.  { intro. intro min. intro.
       assert (Order _ R).
       { apply PO_cond2. }
       destruct H1.
       unfold Is_the_smallest_element_in. unfold Is_a_minimal_element in H0.
       split. tauto. intro x.  intros.
       elim (classic (min = x)).
       { intro. rewrite H5.  apply H1. }
       { intro.
         assert (Rel_of U FP x min \/ Rel_of U FP min x).
         { apply H. unfold C. auto with sets. unfold Included. intros. destruct H6.
           apply H4. apply H0. }
         elim H6.
         intro. absurd (exists y : U, In U (Carrier_of U FP) y /\ min <> y /\ Rel_of U FP y min).
         apply H0.
         exists x. tauto.  tauto. }  } Qed.

Lemma Smallest_element_exists: Totally_ordered _ FP C -> exists x: U, Is_the_smallest_element_in FP x.
Proof.   { intros. destruct H. elim Minimal_element_exists with (P:= FP).
       intro min. intro. exists min.
       assert (Order _ R).
       { apply PO_cond2. }
       destruct H1.
       unfold Is_the_smallest_element_in. unfold Is_a_minimal_element in H0.
       split. tauto. intro x.  intros.
       elim (classic (min = x)).
       { intro. rewrite H5.  apply H1. }
       { intro.
         assert (Rel_of U FP x min \/ Rel_of U FP min x).
         { apply H. unfold C. auto with sets. unfold Included. intros. destruct H6.
           apply H4. apply H0. }
         elim H6.
         intro. absurd (exists y : U, In U (Carrier_of U FP) y /\ min <> y /\ Rel_of U FP y min).
         apply H0.
         exists x. tauto.  tauto. }  } Qed.

End Finite_Chain_Facts.

Hint Resolve NoTwoCommon Singleton_is_chain Singleton_is_antichain :fpo_facts.
Hint Resolve Antichain_exists Chain_exists Chain_cover_exists Antichain_cover_exists: fpo_facts.
Hint Resolve Minimal_element_exists Maximal_element_exists: fpo_facts.
Hint Resolve Minimal_is_antichain Maximal_is_antichain: fpo_facts.
Hint Resolve Minimal_for_every_y Maximal_for_every_x: fpo_facts.
Hint Resolve Largest_card_same Card_same_largest Largest_element_exists: fpo_facts.
Hint Resolve Maximal_is_largest Minimal_is_smallest Smallest_element_exists: fpo_facts.


(** * Sort: Insertion sort *)

(** Sorting can be done in O(N log N) time by various
    algorithms (quicksort, mergesort, heapsort, etc.).  But for
    smallish inputs, a simple quadratic-time algorithm such as
    insertion sort can actually be faster.  And it's certainly easier
    to implement -- and to prove correct. *)

(* ################################################################# *)
(** * Recommended reading *)

(** If you don't already know how insertion sort works, see Wikipedia
    or read any standard textbook; for example:

   Sections 2.0 and 2.1 of _Algorithms, Fourth Edition_,
       by Sedgewick and Wayne, Addison Wesley 2011;  or

   Section 2.1 of _Introduction to Algorithms, 3rd Edition_,
       by Cormen, Leiserson, and Rivest, MIT Press 2009. *)

(* ################################################################# *)
(** * The insertion-sort program *)

(** Insertion sort is usually presented as an imperative program
   operating on arrays.  But it works just as well as a functional
   program operating on linked lists! *)

Require Import Perm.

Fixpoint insert (i:nat) (l: list nat) :=
  match l with
  | nil => i::nil
  | h::t => if i <=? h then i::h::t else h :: insert i t
 end.

Fixpoint sort (l: list nat) : list nat :=
  match l with
  | nil => nil
  | h::t => insert h (sort t)
end.

Example sort_pi: sort [3;1;4;1;5;9;2;6;5;3;5]
                    = [1;1;2;3;3;4;5;5;5;6;9].
Proof. simpl. reflexivity. Qed.

(** What Sedgewick/Wayne and Cormen/Leiserson/Rivest don't acknowlege
    is that the arrays-and-swaps model of sorting is not the only one
    in the world.  We are writing _functional programs_, where our
    sequences are (typically) represented as linked lists, and where
    we do _not_ destructively splice elements into those lists.
    Instead, we build new lists that (sometimes) share structure with
    the old ones.

    So, for example: *)

Eval compute in insert 7 [1; 3; 4; 8; 12; 14; 18].
(* = [1; 3; 4; 7; 8; 12; 14; 18] *)

(** The tail of this list, [12::14::18::nil], is not disturbed or
   rebuilt by the [insert] algorithm.  The nodes [1::3::4::7::_] are
   new, constructed by [insert].  The first three nodes of the old
   list, [1::3::4::_] will likely be garbage-collected, if no other
   data structure is still pointing at them.  Thus, in this typical
   case,
     - Time cost = 4X
     - Space cost = (4-3)Y = Y

   where X and Y are constants, independent of the length of the tail.
   The value Y is the number of bytes in one list node: 2 to 4 words,
   depending on how the implementation handles constructor-tags.
   We write (4-3) to indicate that four list nodes are constructed,
   while three list nodes become eligible for garbage collection.

   We will not _prove_ such things about the time and space cost, but
   they are _true_ anyway, and we should keep them in
   consideration. *)

(* ################################################################# *)
(** * Specification of correctness *)

(** A sorting algorithm must rearrange the elements into a list that
    is totally ordered. *)

Inductive sorted: list nat -> Prop :=
| sorted_nil:
    sorted nil
| sorted_1: forall x,
    sorted (x::nil)
| sorted_cons: forall x y l,
   x <= y -> sorted (y::l) -> sorted (x::y::l).

(** Is this really the right definition of what it means for a list to
    be sorted?  One might have thought that it should go more like this: *)

Definition sorted' (al: list nat) :=
 forall i j, i < j < length al -> nth i al 0 <= nth j al 0.

(** This is a reasonable definition too.  It should be equivalent.
    Later on, we'll prove that the two definitions really are
    equivalent.  For now, let's use the first one to define what it
    means to be a correct sorting algorthm. *)

Definition is_a_sorting_algorithm (f: list nat -> list nat) :=
  forall al, Permutation al (f al) /\ sorted (f al).

(** The result [(f al)] should not only be a [sorted] sequence,
    but it should be some rearrangement (Permutation) of the input sequence. *)
(* ################################################################# *)
(** * Proof of correctness *)

(** **** Exercise: 3 stars  *)
(** Prove the following auxiliary lemma, [insert_perm], which will be
    useful for proving [sort_perm] below.  Your proof will be by
    induction, but you'll need some of the permutation facts from the
    library, so first remind yourself by doing [SearchAbout]. *)

SearchAbout Permutation.

Lemma insert_perm: forall x l, Permutation (x::l) (insert x l).
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars  *)
(** Now prove that sort is a permutation. *)

Theorem sort_perm: forall l, Permutation l (sort l).
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 4 stars  *)
(** This one is a bit tricky.  However, there just a single induction
   right at the beginning, and you do _not_ need to use [insert_perm]
   or [sort_perm]. *)

Lemma insert_sorted:
  forall a l, sorted l -> sorted (insert a l).
Proof.
(* FILL IN HERE *) Admitted.

(** **** Exercise: 2 stars  *)
(** This one is easy.   *)

Theorem sort_sorted: forall l, sorted (sort l).
Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(** Now we wrap it all up.  *)

Theorem insertion_sort_correct:
    is_a_sorting_algorithm sort.
Proof.
  split. apply sort_perm. apply sort_sorted.
Qed.

(* ################################################################# *)
(** * Making sure the specification is right *)

(** It's really important to get the _specification_ right.  You can
    prove that your program satisfies its specification (and Coq will
    check that proof for you), but you can't prove that you have the
    right specification.  Therefore, we take the trouble to write two
    different specifications of sortedness ([sorted] and [sorted']),
    and prove that they mean the same thing.  This increases our
    confidence that we have the right specification, though of course
    it doesn't _prove_ that we do. *)

(** **** Exercise: 4 stars, optional (sorted_sorted')  *)
Lemma sorted_sorted': forall al, sorted al -> sorted' al.

(** Hint: Instead of doing induction on the list [al], do induction
    on the _sortedness_ of [al]. This proof is a bit tricky, so
    you may have to think about how to approach it, and try out
    one or two different ideas.*)

(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, optional (sorted'_sorted)  *)
Lemma sorted'_sorted: forall al, sorted' al -> sorted al.

(** Here, you can't do induction on the sorted'-ness of the list,
    because [sorted'] is not an inductive predicate. *)

Proof.
(* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Proving correctness from the alternate spec *)

(** Depending on how you write the specification of a program, it can
    be _much_ harder or easier to prove correctness.  We saw that the
    predicates [sorted] and [sorted'] are equivalent; but it is really
    difficult to prove correctness of insertion sort directly from
    [sorted'].

    Try it yourself, if you dare!  I managed it, but my proof is quite
    long and complicated.  I found that I needed all these facts:
    - [insert_perm], [sort_perm]
    - [Forall_perm], [Permutation_length]
    - [Permutation_sym], [Permutation_trans]
    - a new lemma [Forall_nth], stated below.

    Maybe you will find a better way that's not so complicated.

    DO NOT USE [sorted_sorted'], [sorted'_sorted], [insert_sorted], or
    [sort_sorted] in these proofs! *)

(** **** Exercise: 3 stars, optional (Forall_nth)  *)
Lemma Forall_nth:
  forall {A: Type} (P: A -> Prop) d (al: list A),
     Forall P al <-> (forall i,  i < length al -> P (nth i al d)).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 4 stars, optional (insert_sorted')  *)
Lemma insert_sorted':
  forall a l, sorted' l -> sorted' (insert a l).
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 4 stars, optional (insert_sorted')  *)
Theorem sort_sorted': forall l, sorted' (sort l).
(* FILL IN HERE *) Admitted.
(** [] *)

(* ================================================================= *)
(** ** The moral of this story *)

(** The proofs of [insert_sorted] and [sort_sorted] were easy; the
    proofs of [insert_sorted'] and [sort_sorted'] were difficult; and
    yet [sorted al <-> sorted' al].  _Different formulations of the
    functional specification can lead to great differences in the
    difficulty of the correctness proofs_.

   Suppose someone required you to prove [sort_sorted'], and never
   mentioned the [sorted] predicate to you.  Instead of proving
   [sort_sorted'] directly, it would be much easier to design a new
   predicate ([sorted]), and then prove [sort_sorted] and
   [sorted_sorted']. *)

(** $Date: 2017-05-18 12:44:19 -0400 (Thu, 18 May 2017) $ *)


Require Import bool.
Require Import nat.

Require Import inductive_prop.
Require Import induction.

Inductive le : nat -> nat -> Prop :=
| le_n : forall (n:nat), le n n
| le_S : forall (n m:nat), le n m -> le n (S m)
.

Notation "n <= m" := (le n m).

Definition lt (n m:nat) : Prop := le (S n) m.

Notation "n < m" := (lt n m).

Lemma le_refl : forall (n:nat), n <= n.
Proof. intros n. apply le_n. Qed.

Lemma le_trans : forall (n m p:nat),
    n <= m -> m <= p -> n <= p.
Proof.
    intros n m p H. revert p. induction H as [n|n m H IH].
    - intros p H'. exact H'.
    - intros p H'. remember (S m) as m' eqn:H0. revert H0 IH H.
        revert n m. induction H' as [p|m' p H' IH'].
        + intros n m Hp IH Hnm. apply IH. rewrite Hp. apply le_S, le_n.
        + intros n m Hm IH Hnm. apply le_S. apply (IH' n m).
            { exact Hm. }
            { exact IH. }
            { exact Hnm. }
Qed.

Lemma le_0_n : forall (n:nat), 0 <= n.
Proof.
    induction n as [|n H].
    - apply le_n.
    - apply le_S. exact H.
Qed.

Lemma n_le_m__Sn_le_Sm : forall (n m:nat),
    n <= m -> S n <= S m.
Proof.
    intros n m H. induction H as [n|n m H IH].
    - apply le_n.
    - apply le_S. exact IH.
Qed.

Lemma Sn_le_Sm__n_le_m : forall (n m:nat),
    S n <= S m -> n <= m.
Proof.
    intros n m H. inversion H as [H0|p H1].
    - apply le_n.
    - apply le_trans with (m := S n).
      +  apply le_S, le_n.
      +  auto.
Qed.

Lemma le_plus_l : forall (n m: nat), n <= n + m.
Proof.
    intros n m. induction m as [|m H].
    - rewrite plus_n_0. apply le_n.
    - rewrite plus_n_Sm. apply le_S. exact H.
Qed.

Lemma plus_lt : forall (n m p:nat),
    n + m < p -> n < p /\ m < p.
Proof.
    intros n m p H. unfold lt in H. split.
    - unfold lt. apply le_trans with (m := S (n + m)).
        + rewrite <- plus_Sn_m. apply le_plus_l.
        + exact H.
    - unfold lt. apply le_trans with (m := S (n + m)).
        + rewrite plus_comm. rewrite <- plus_Sn_m. apply le_plus_l.
        + exact H.
Qed.

Lemma lt_S :  forall (n m:nat), n < m -> n < S m.
Proof.
    intros n m. unfold lt. intros H. apply le_S. exact H.
Qed.

Lemma leb_complete : forall (n m:nat),
    leb n m = true -> n <= m.
Proof.
    induction n as [|n H].
    - intros. apply le_0_n.
    - induction m as[|m H'].
        + simpl. intros H'. inversion H'.
        + simpl. intros H0. apply n_le_m__Sn_le_Sm. apply H. exact H0.
Qed.

Lemma leb_correct : forall (n m:nat),
    n <= m-> leb n m = true.
Proof.
    intros n m. generalize n. clear n. induction m as [|m H].
    - intros n H. inversion H. reflexivity.
    - induction n as [|n H'].
        + intros H'. reflexivity.
        + intros H0. simpl. apply Sn_le_Sm__n_le_m in H0.
            apply H. exact H0.
Qed.

Lemma leb_trans : forall (n m p:nat),
    leb n m = true -> leb m p = true -> leb n p = true.
Proof.
    intros n m p Hnm Hmp. apply leb_correct. apply le_trans with (m:=m).
    - apply leb_complete. exact Hnm.
    - apply leb_complete. exact Hmp.
Qed.

Lemma leb_iff : forall (n m:nat),
    leb n m = true <-> n <= m.
Proof.
    intros n m. split.
    - exact (leb_complete n m).
    - exact (leb_correct n m).
Qed.

Lemma le_n_0 : forall (n:nat), n <= 0 -> n = 0.
Proof. intros n H. inversion H. reflexivity. Qed.

Lemma not_le_Sm_n : forall (n m:nat), n <= m -> ~(S m <= n).
Proof.
  intros n m. revert n. induction m as [|m IH].
  - intros n H H'. apply le_n_0 in H. rewrite H in H'. inversion H'.
  - intros n H H'. remember (S m) as q eqn:H0. destruct H as [|p n].
    + apply (IH n).
      { apply Sn_le_Sm__n_le_m. rewrite <- H0. exact H'. }
      { apply le_n. }
    + apply (IH p).
      { inversion H0 as [H2]. rewrite H2 in H. exact H. }
      { apply le_trans with (m:=S (S n)).
        { apply le_S, le_n. }
        { exact H'. }
      }
Qed.

Lemma not_le_Sn_n : forall (n:nat), ~(S n <= n).
Proof. intro n. apply not_le_Sm_n. apply le_n. Qed.

Lemma le_antisym : forall (n m:nat),
  n <= m -> m <= n -> n = m.
Proof.
  intros n m H. destruct H as [|n p H].
  - intros _. reflexivity.
  - intros H'. exfalso. apply (not_le_Sn_n p).
    apply le_trans with (m:=n).
      + exact H'.
      + exact H.
Qed.

Lemma n_lt_m__Sn_lt_Sm : forall (n m:nat), n < m -> S n < S m.
Proof.
    intros n m H. unfold lt in H. unfold lt. apply n_le_m__Sn_le_Sm. exact H.
Qed.

Lemma Sn_lt_Sm__n_lt_m : forall (n m:nat), S n < S m -> n < m.
Proof.
    intros n m H. unfold lt in H. unfold lt. apply Sn_le_Sm__n_le_m. exact H.
Qed.

Lemma le_lt_dec : forall (n m:nat), {n <= m} + {m < n}.
Proof.
    intros n. induction n as [|n IH].
    - left. apply le_0_n.
    - intros m. revert IH. revert n. induction m as [|m IH].
        + intros n _. right. unfold lt. apply n_le_m__Sn_le_Sm. apply le_0_n.
        + intros n H. destruct (H m) as [H'|H'].
            { left. apply n_le_m__Sn_le_Sm. exact H'. }
            { right. apply n_lt_m__Sn_lt_Sm. exact H'. }
Qed.

Lemma plus_le_compat_l : forall (n m p:nat),
    m <= p -> n + m <= n + p.
Proof.
    intros p. induction p as [|p IH].
    - intros m p H. exact H.
    - intros n m H. simpl. apply n_le_m__Sn_le_Sm. apply IH. exact H.
Qed.

Lemma plus_lt_compat_l : forall (n m p:nat),
    m < p -> n + m < n + p.
Proof.
    intros n m p H. unfold lt in H. unfold lt.
    rewrite <- plus_n_Sm. apply plus_le_compat_l. exact H.
Qed.

Lemma plus_le_compat : forall (n m n' m':nat),
    n <= n' -> m <= m' -> n + m <= n' + m'.
Proof.
    intros n m n' m' Hn Hm. apply le_trans with (m:=n + m').
    - apply plus_le_compat_l. exact Hm.
    - rewrite (plus_comm n m'), (plus_comm n' m'). apply plus_le_compat_l. exact Hn.
Qed.

Lemma plus_lt_compat : forall (n m n' m':nat),
    n < n' -> m < m' -> n + m < n' + m'.
Proof.
    intros n m n' m' Hn Hm. unfold lt in Hn. unfold lt in Hm. unfold lt.
    rewrite <- plus_n_Sm. apply le_trans with (m:=S n + S m).
    - rewrite (plus_comm n (S m)). rewrite (plus_comm (S n) (S m)).
        apply plus_le_compat_l. apply le_S, le_n.
    - apply plus_le_compat.
        + exact Hn.
        + exact Hm.
Qed.

Lemma sum_leq_sum : forall (n m p q:nat),
    n + m <= p + q -> n <= p \/ m <= q.
Proof.
    intros n m p q H.
    assert ({n <= p} + {p < n}) as [H0|H0]. {apply le_lt_dec. }
    - left. exact H0.
    - assert ({m <= q} + {q < m}) as [H1|H1]. {apply le_lt_dec. }
        + right. exact H1.
        + exfalso. assert (p + q < n + m) as H2. apply plus_lt_compat.
            { exact H0. } { exact H1. }
            unfold lt in H2. assert ( S (p + q) <= p + q ) as H3.
            { apply le_trans with (m:=n+m).
                { exact H2. }
                { exact H. } }
            apply (not_le_Sn_n (p + q)). exact H3.
Qed.