Require Import Coq.Lists.List.

Section List_Remove.

Variable A : Set.
Hypothesis Aeq_dec : forall a b : A, {a = b} + {a <> b}.

Definition list_remove (x : A) (l : list A) : list A :=
  list_rec (fun _ => list A) nil
    (fun (a : A) _ (recl : list A) =>
     match Aeq_dec a x with
     | left _ => recl
     | right _ => a :: recl
     end) l.

Lemma In_list_remove1 :
 forall (a b : A) (l : list A), In a (list_remove b l) -> In a l.
Proof.
intros.
induction l as [| a0 l Hrecl].
elim H.
simpl in H.
induction (Aeq_dec a0 b).
right.
auto.
induction H as [H| H].
simpl in |- *; auto.
right.
auto.
Qed.

Lemma In_list_remove2 :
 forall (a b : A) (l : list A), In a (list_remove b l) -> a <> b.
Proof.
intros.
induction l as [| a0 l Hrecl].
elim H.
simpl in H.
induction (Aeq_dec a0 b).
auto.
induction H as [H| H].
rewrite H in b0.
auto.
auto.
Qed.

Lemma In_list_remove3 :
 forall (a b : A) (l : list A), In a l -> a <> b -> In a (list_remove b l).
Proof.
intros.
induction l as [| a0 l Hrecl].
elim H.
simpl in |- *.
induction H as [H| H].
induction (Aeq_dec a0 b).
elim H0.
transitivity a0; auto.
left.
auto.
induction (Aeq_dec a0 b).
auto.
right.
auto.
Qed.

End List_Remove.

Section No_Duplicate.

Variable A : Set.
Hypothesis Aeq_dec : forall a b : A, {a = b} + {a <> b}.

Definition no_dup (l : list A) : list A :=
  list_rec (fun _ => list A) nil
    (fun (a : A) _ (rec : list A) =>
     match In_dec Aeq_dec a rec with
     | left _ => rec
     | right _ => a :: rec
     end) l.

Lemma no_dup1 : forall (a : A) (l : list A), In a l -> In a (no_dup l).
Proof.
intros.
induction l as [| a0 l Hrecl].
elim H.
simpl in |- *.
induction H as [H| H].
induction (In_dec Aeq_dec a0 (no_dup l)).
rewrite <- H.
auto.
left.
auto.
induction (In_dec Aeq_dec a0 (no_dup l)).
auto.
right.
auto.
Qed.

Lemma no_dup2 : forall (a : A) (l : list A), In a (no_dup l) -> In a l.
Proof.
intros.
induction l as [| a0 l Hrecl].
elim H.
simpl in H.
induction (In_dec Aeq_dec a0 (no_dup l)).
right.
auto.
induction H as [H| H].
left.
auto.
right.
auto.
Qed.

Lemma no_dup3 : forall (k l : list A) (a : A), no_dup k = a :: l -> ~ In a l.
Proof.
intro.
induction k as [| a k Hreck].
intros.
discriminate H.
unfold not in |- *; intros.
simpl in H.
induction (In_dec Aeq_dec a (no_dup k)).
elim Hreck with l a0; auto.
elim b.
inversion H.
rewrite H3.
auto.
Qed.

End No_Duplicate.


From mathcomp Require Import all_ssreflect.

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

(**

----------------------------------------------------------
#
#
** Lesson 4: summary

- generic notations and theories
- interfaces and hierarchies
- parametrizing theories
- the BigOp library (the theories of fold)
- subtypes

Let's start with a lie and then make it true:

#
#
Coq is an object oriented
programming language.
#
#

#
#

----------------------------------------------------------
#
#
** Generic notations and theories

Polymorphism != overloading.

Example: the [==] computable equality

#
#
*)
Check 3 == 4.
Check true == false.
Check [::] == [:: 2; 3; 4].

Eval lazy in 3 == 4.
Eval lazy in true == false.
Eval lazy in [::] == [:: 2; 3; 4].

Check (3, true) == (4, false).
Fail Check (fun x => x) == (fun y => y).

Check [eqType of nat].
Fail Check [eqType of nat -> nat].

Check [eqType of seq nat].
Fail Check [eqType of seq (nat -> nat)].

(**
#
#

We call [eqType] an interface. With some "approximation"
[eqType] is defined as follows:

<<

Module Equality.

Structure type : Type := Pack {
  sort : Type;
  op : sort -> sort -> bool;
  axiom : ∀x y, reflect (x = y) (op x y)
}.

End Equality
>>

#
(notes)
#
This slide corresponds to
section 5.4 of
#the Mathematical Components book#
#

#
#

#
#
#

----------------------------------------------------------
#
#
** Interfaces and hierarchies

Mathematical Components defines a hierarchy
of interfaces. They group notations and
theorems.

# #

Let's use the theory of [eqType]

#
#
*)
About eqxx.
About eq_refl.
Lemma test_eq (*(T : eqType) (x : T)*) :
  (3 == 3) && (true == true) (*&& (x == x)*).
Proof.
rewrite eqxx.
rewrite eqxx.
(* rewrite eqxx. *)
by [].
Qed.
(**
#
#

Interfaces do apply to registered, concrete examples
such as [bool] or [nat]. They can also apply to variables,
as long as their type is "rich" ([eqType] is richer than [Type]).

#
(notes)
#
This slide corresponds to
section 5.5 and 7 of
#the Mathematical Components book#
#

#

#

#
#
#

----------------------------------------------------------
#
#
** Theories over an interface

Interfaces can be used to parametrize an
entire theory

#
#
*)
Module Seq. Section Theory.
Variable T : eqType.
Implicit Type s : seq T.

Fixpoint mem_seq s x :=
  if s is y :: s1
  then (y == x) || mem_seq s1 x
  else false.

(* the infix \in and \notin are generic, not
   just for sequences. *)

Fixpoint uniq s :=
  if s is x :: s1
  then (x \notin s1) && uniq s1
  else true.

Fixpoint undup s :=
  if s is x :: s1 then
    if x \in s1 then undup s1 else x :: undup s1
  else [::].

End Theory. End Seq.

About undup_uniq.

Eval lazy in (undup [::1;3;1;4]).

Lemma test : uniq (undup [::1;3;1;4]).
Proof.
by rewrite undup_uniq.
Qed.

(**
#
#

#
(notes)
#
This slide corresponds to
section 5.6 of
#the Mathematical Components book#
#

#

#

#
#
#

----------------------------------------------------------
#
#
** Generic theories: the BigOp library

The BigOp library is the canonical example
of a generic theory. It it about the
[fold] iterator we studied in lesson 1,
and the many uses it can have.

#
#
*)

Lemma sum_odd_3 :
  \sum_(0 <= i < 6 | odd i) i = 3^2.
Proof.
rewrite unlock /=.
by [].
Qed.

About big_mkcond.
About big_nat_recr.
Lemma sum_odd_3_bis :
  \sum_(0 <= i < 6 | odd i) i = 3^2.
Proof.
rewrite big_mkcond big_nat_recr //= -big_mkcond /=.
Abort.

Lemma prod_odd_3_bis : (* try [maxn/0] and also [maxn/1] *)
  \big[muln/1]_(0 <= i < 6 | odd i) i = 3^2.
Proof.
rewrite big_mkcond big_nat_recr //= -big_mkcond /=.
Abort.

(**
#
#

Most of the lemmas require the operation to be a monoid,
some others to be a commutative monoid.

#
#
*)

About eq_big_perm.

(**
#
#

#
(notes)
#
This slide corresponds to
section 5.7 of
#the Mathematical Components book#
#

#

#

#
#
#

----------------------------------------------------------
#
#
** Sub types

A sub type extends another type by adding a property.
The new type has a richer theory.
The new type inherits the original theory.

Let's define the type of homogeneous tuples

#
#
*)

Module Tup.

Structure tuple_of n T := Tuple {
  tval  :> seq T;
  tsize :  size tval == n
}.
Notation "n .-tuple" := (tuple_of n) : type_scope.

Lemma size_tuple T n (t : n .-tuple T) : size t = n.
Proof. by case: t => s /= /eqP. Qed.

Example seq_on_tuple n (t : n .-tuple nat) :
  size (rev [seq 2 * x | x <- rev t]) = size t.
Proof.
by rewrite map_rev revK size_map.
Undo.
rewrite size_tuple.
Fail rewrite size_tuple.
Abort.

(**
#
#

We instrument Coq to automatically promote
sequences to tuples.

#
#
*)

Lemma rev_tupleP n A (t : n .-tuple A) : size (rev t) == n.
Proof. by rewrite size_rev size_tuple. Qed.
Canonical rev_tuple n A (t : n .-tuple A) := Tuple (rev_tupleP t).

Lemma map_tupleP n A B (f: A -> B) (t: n .-tuple A) : size (map f t) == n.
Proof. by rewrite size_map size_tuple. Qed.
Canonical map_tuple n A B (f: A -> B) (t: n .-tuple A) := Tuple (map_tupleP f t).

Example seq_on_tuple2 n (t : n .-tuple nat) :
  size (rev [seq 2 * x | x <- rev t]) = size t.
Proof. rewrite size_tuple. rewrite size_tuple. by []. Qed.

(**
#
#

Now we the tuple type to form an eqType,
exactly as seq does.

Which is the expected comparison for tuples?

#
#
*)

Lemma p1 : size [:: 1;2] == 2. Proof. by []. Qed.
Lemma p2 : size ([:: 1] ++ [::2]) == 2. Proof. by rewrite cat_cons cat0s. Qed.

Definition t1 := {| tval := [::1;2];        tsize := p1 |}.
Definition t2 := {| tval := [::1] ++ [::2]; tsize := p2 |}.

Lemma tuple_uip : t1 = t2.
Proof.
rewrite /t1 /t2. rewrite /=.
Fail by [].
congr (Tuple _).
Fail by [].
(*About bool_irrelevance.*)
apply: bool_irrelevance.
Qed.

(**
#
#

Given that propositions are expressed (whenever possible)
as booleans we can systematically prove that proofs
of these properties are irrelevant.

As a consequence we can form subtypes and systematically
prove that the projection to the supertype is injective,
that means we can craft an eqType.

#
#
*)

Canonical tuple_subType n T := Eval hnf in [subType for (@tval n T)].
Definition tuple_eqMixin n (T : eqType) := Eval hnf in [eqMixin of n .-tuple T by <:].
Canonical tuple_eqType n (T : eqType) := Eval hnf in EqType (n .-tuple T) (tuple_eqMixin n T).

Check [eqType of 3.-tuple nat].

Example test_eqtype (x y : 3.-tuple nat) : x == y -> True.
Proof.
move=> /eqP H.
Abort.

(**
#
#

Tuples is not the only subtype part of the library.
Another one is ['I_n], the finite type of natural
numbers smaller than n.

#
#
*)
Print ordinal.

About tnth. (* like the safe nth function for vectors *)

End Tup.

(**
#
#

#
(notes)
#
This slide corresponds to
section 6.1 and 6.2 of
#the Mathematical Components book#
#

#

#

#
#
#

----------------------------------------------------------
#
#
** Sum up

- Coq is an object oriented language ;-)

- in the Mathematical Components library [xxType] is an
  interface (eg [eqType] for types with an equality test).
  Notations and theorems are linked to interfaces.
  Interfaces are organized in hierarchies (we just saw a picture,
  how it works can be found in the book).

- subtypes add properties and inherit the theory of the supertype
  thanks to boolean predicates (UIP).
  In some cases the property can be inferred by Coq, letting one apply
  a lemma about the subtype on terms of the supertype.

#
#

*)


(** * sups: finite joins (or supremums), a la ssreflect  *)

(** We define a few operations for manipulating finite supremums or
   intersections. We basically follow the scheme proposed for "bigops"
   in ssreflect, but we simplify it as much as possible since we do
   not need the whole machinery. The two main simplifications are:
   - the fact that we restrict ourselves to the associative,
     commutative, and idempotent operation [cup] of lattices
     (intersections being obtained by working in the dual lattices)
   - the fact that we do not include a "selection" operator *)

Require Import lset lattice.
Require Export ordinal.

Section s.
Context `{L:laws} `{Hl:BSL ≪ l}.

Universe S.

Section i.

Context {I: Type@{S}}.

(** * Supremums *)

(** the unique operator which we define is the following one,
   which intuitively corresponds to [fold_right cup (map f J) bot],
   we redefine it to get a better behaviour with [simpl] *)

(** sup f [j1;...;jn] = f j1 ⊔ ... ⊔ f jn *)
Fixpoint sup (f: I -> X) J :=
  match J with
    | nil => bot
    | cons i J => f i ⊔ sup f J
  end.

(** sup specification *)
Lemma sup_spec f J x: sup f J ≦ x <-> forall i, In i J -> f i ≦ x.
Proof.
  induction J; simpl. split. tauto. intro. lattice.
  rewrite cup_spec, IHJ. clear IHJ. intuition. now subst.
Qed.

(** ** basic facts about [sup] *)
Lemma sup_app f h k: sup f (h++k) ≡ sup f h ⊔ sup f k.
Proof. induction h; simpl. lattice. rewrite IHh. hlattice. Qed.

Lemma sup_singleton f i: sup f (i::nil) ≡ f i.
Proof. simpl. lattice. Qed.

Lemma leq_supx f J x: (forall i, In i J -> f i ≦ x) -> sup f J ≦ x.
Proof. apply sup_spec. Qed.

Lemma leq_xsup f J i: In i J -> f i ≦ sup f J.
Proof. now apply sup_spec. Qed.

Lemma leq_xsup' f J i x: In i J -> x ≦ f i -> x ≦ sup f J.
Proof. intros ? E. rewrite E. now apply leq_xsup. Qed.

(** [sup] is monotone, w.r.t, both the function [f] and the set [J] *)
Global Instance sup_leq: Proper (pwr leq ==> leq ==> leq) sup.
Proof.
  intros f f' Hf J J' HJ. induction J. apply leq_bx.
  simpl. apply leq_cupx. rewrite Hf. apply leq_xsup. apply HJ. now left.
  apply IHJ. intros j ?. apply HJ. now right.
Qed.

Global Instance sup_weq: Proper (pwr weq ==> weq ==> weq) sup.
Proof. simpl. setoid_rewrite weq_spec. split; apply sup_leq; firstorder. Qed.

Lemma supcup f g J: sup (fun i => f i ⊔ g i) J ≡ sup f J ⊔ sup g J.
Proof. induction J; simpl. lattice. rewrite IHJ. lattice. Qed.

(** refined monotonicity result: the functions have to be pointwise
   comparable only on the elements of [J] *)
Lemma sup_leq' J J' (f f': I -> X):
  J ≦J' -> (forall i, In i J -> f i ≦ f' i) -> sup f J ≦ sup f' J'.
Proof.
  induction J; intros HJ Hf. apply leq_bx.
  simpl. apply leq_cupx.
  rewrite Hf. apply leq_xsup. apply HJ. now left. now left.
  apply IHJ. rewrite <- HJ. clear; firstorder. clear -Hf; firstorder.
Qed.

Lemma sup_weq' J J' (f f': I -> X):
  J ≡J' -> (forall i, In i J -> f i ≡ f' i) -> sup f J ≡ sup f' J'.
Proof. setoid_rewrite weq_spec. split; apply sup_leq'; firstorder. Qed.

(** the sup of empty elements is still empty *)
Lemma sup_b J (f: I -> X) (Hf: forall i, In i J -> f i ≡ bot): sup f J ≡ bot.
Proof.
  apply antisym. 2: apply leq_bx.
  apply leq_supx. intros. now rewrite Hf.
Qed.

End i.

(** ** swapping and reindexing indices *)

Theorem sup_swap I J (f: I -> J -> X) I' J':
  sup (fun i => sup (fun j => f i j) J') I' ≡
  sup (fun j => sup (fun i => f i j) I') J'.
Proof.
  induction I'; simpl. apply antisym. apply leq_bx. apply leq_supx; trivial.
  now rewrite IHI', supcup.
Qed.

Lemma sup_map I J (f: J -> X) (m: I -> J) I':
  sup f (map m I') = sup (fun i => f (m i)) I'.
Proof. induction I'; simpl; congruence. Qed.

End s.

(** ** notations *)

(** we use "\sup_(i\in l) f" in the general case *)
Notation "\sup_ ( i \in l ) f" := (sup (fun i => f) l)
  (at level 41, f at level 41, i, l at level 50,
    format "'[' \sup_ ( i \in  l ) '/  '  f ']'"): ra_terms.

(** and "\sup_(i<n) f" when [l] is the set of ordinals smaller than [n] *)
Notation "\sup_ ( i < n ) f" := (\sup_(i \in seq n) f)
  (at level 41, f at level 41, i, n at level 50,
    format "'[' \sup_ ( i < n ) '/  '  f ']'"): ra_terms.

(** we shall moreover use the notation [\sum] when the lattice
   operations actually come from a partially ordered monoid (see sum.v) *)

(** ** additional properties *)

(** two "meta" results, to prove that some operation commutes with supremums *)

Lemma f_sup_weq {X: ops} {Y l} {L: laws l Y} `{Hl: CUP ≪ l} (f: X -> Y):
  (f bot ≡ bot) ->
  (forall x y, f (x ⊔ y) ≡ f x ⊔ f y) ->
  forall I J (g: I -> X), f (sup g J) ≡ \sup_(i\in J) f (g i).
Proof.
  intros Hbot Hcup I J g. induction J. apply Hbot.
  simpl. rewrite Hcup. now apply cup_weq.
Qed.

Lemma f_sup_eq {X Y: ops} (f: X -> Y):
  (f bot = bot) ->
  (forall x y, f (x ⊔ y) = f x ⊔ f y) ->
  forall I J (g: I -> X), f (sup g J) = \sup_(i\in J) f (g i).
Proof.
  intros Hbot Hcup I J g. induction J. apply Hbot.
  simpl. rewrite Hcup. congruence.
Qed.

(** same thing, to prove that a predicate is preserved under supremums *)

Lemma P_sup {X: ops} {P: X -> Prop} I J (f: I -> X):
  P bot ->
  (forall x y, P x -> P y -> P (x ⊔ y)) ->
  (forall i, In i J -> P (f i)) ->
  P (sup f J).
Proof.
  intros Hbot Hcup.
  induction J; intro H; simpl. apply Hbot.
  apply Hcup. apply H; now left. apply IHJ. intros. apply H. now right.
Qed.

(** cutting a supremum over ordinals of size [n+m] *)
Lemma sup_cut `{L:laws} `{BSL ≪ l} n m f:
  \sup_(i<n+m) f i ≡ \sup_(i<n) f (lshift i) ⊔ \sup_(i<m) f (rshift i).
Proof. now rewrite seq_cut, sup_app, 2sup_map. Qed.

(** supremums where the indices come from a supremum *)
Lemma sup_sup `{L: laws} `{BSL ≪ l} I (f: I -> X) A (J: A -> list I) h:
  sup f (sup J h) ≡ sup (fun a => sup f (J a)) h.
Proof. induction h. reflexivity. simpl. now rewrite sup_app, IHh. Qed.

(** belonging to a finite union *)
Lemma in_sup A I J (f: I -> list A) a: In a (sup f J) <-> exists i, In i J /\ In a (f i).
Proof.
  induction J; simpl. firstorder.
  rewrite in_app_iff, IHJ. clear. firstorder congruence.
Qed.

(** link between [map] and [sup] *)
Lemma map_sup A I J (f: I -> A): map f J = \sup_(i\in J) [f i].
Proof. induction J; simpl; congruence. Qed.

(** distribution of meets over supremums *)
Lemma capxsup `{laws} `{BSL+CAP ≪ l} I J (f: I -> X) (x: X):
  x ⊓ (\sup_(i\in J) f i) ≡ \sup_(i\in J) (x ⊓ f i).
Proof. apply f_sup_weq. apply capxb. intros; apply capcup. Qed.

Lemma capsupx `{laws} `{BSL+CAP ≪ l} I J (f: I -> X) (x: X):
  (\sup_(i\in J) f i) ⊓ x ≡ \sup_(i\in J) (f i ⊓ x).
Proof. rewrite capC, capxsup. now setoid_rewrite capC at 1. Qed.

(** * Infimum (or intersections) *)

(** obtained for free, by duality *)

Notation inf f l := (@sup (dual _) _ f l).

Notation "\inf_ ( i \in l ) f" := (inf (fun i => f) l)
  (at level 41, f at level 41, i, l at level 50,
    format "'[' \inf_ ( i \in  l ) '/  '  f ']'"): ra_terms.

Notation "\inf_ ( i < n ) f" := (\inf_(i \in seq n) f)
  (at level 41, f at level 41, i, n at level 50,
    format "'[' \inf_ ( i < n ) '/  '  f ']'"): ra_terms.

Section inf.
Context `{laws} `{CAP+TOP ≪ l} {I: Type}.

Global Instance inf_leq:
  Proper (pwr (@leq X) ==> leq --> @leq X) (@sup (dual X) I).
Proof. intros ? ? ? ? ?. now dual @sup_leq. Qed.

Lemma inf_spec (f: I -> X) J (x: X):
  x ≦ \inf_(i\in J) f i <-> forall i, In i J -> x ≦ f i.
Proof. dual @sup_spec. Qed.

Lemma inf_singleton (f: I -> X) i: inf f (i::nil) ≡ f i.
Proof. dual @sup_singleton. Qed.

Lemma leq_xinf (f: I -> X) J x: (forall i, In i J -> x ≦ f i) -> x ≦ inf f J.
Proof. dual @leq_supx. Qed.

Lemma leq_infx (f: I -> X) J i: In i J -> @leq X (inf f J) (f i).
Proof. dual @leq_xsup. Qed.

Lemma leq_infx' (f: I -> X) J i x: In i J -> f i ≦ x -> @leq X (inf f J) x.
Proof. dual @leq_xsup'. Qed.

End inf.


(**
Parts of this file are copied and modified from the Coq Demos
of the lecture Semantics at Saarland University
http://www.ps.uni-saarland.de/courses/sem-ws17/confluence.v
**)

Set Implicit Arguments.
Require Import Morphisms FinFun.

(** Pretty version of inversion *)
Ltac inv H := inversion H; subst; clear H.

Notation "R <<= S" := (forall x y, R x y -> S x y) (at level 70).
Notation "R === S" := (R <<= S /\ S <<= R) (at level 70).

Section ClosureRelations.
  Variables (X: Type) (R: X -> X -> Prop).
  Implicit Types x y z : X.

  Definition functional := forall x y z, R x y -> R x z -> y = z.

  Inductive star : X -> X -> Prop :=
  | starRefl x     : star x x
  | starStep x x' y : R x x' -> star x' y -> star x y.

  Inductive plus : X -> X -> Prop :=
  | plusSingle x y: R x y -> plus x y
  | plusStep x x' y: R x x' -> plus x' y -> plus x y.

  Inductive counted : nat -> X -> X -> Prop :=
  | countedRefl x: counted 0 x x
  | countedStep x x' y n: R x x' -> counted n x' y -> counted (S n) x y.

  Inductive sym: X -> X -> Prop :=
  | symId x y: R x y -> sym x y
  | symInv x y: R y x -> sym x y.

  Hint Constructors star plus counted.

  Lemma star_trans x y z :
    star x y -> star y z -> star x z.
  Proof.
    induction 1; eauto.
  Qed.

  Lemma plus_trans x y z :
    plus x y -> plus y z -> plus x z.
  Proof.
    induction 1; eauto.
  Qed.

  Fact counted_trans x y z m n:
    counted m x y -> counted n y z -> counted (m + n) x z.
  Proof.
    induction 1; cbn; eauto.
  Qed.

  Fact star_exp :
    R <<= star.
  Proof.
    eauto.
  Qed.

  Fact plus_exp :
    R <<= plus.
  Proof.
    eauto.
  Qed.

  Fact counted_exp :
    R === counted 1.
  Proof.
    split; eauto.
    intros x y H; inv H; inv H2; eauto.
  Qed.

  Lemma plus_star : plus <<= star.
  Proof.
    induction 1; eauto.
  Qed.

  Lemma plus_destruct x y: plus x y <-> exists2 x', (R x x') & (star x' y).
  Proof.
    split.
    - induction 1; eauto.
      destruct IHplus; eexists; eauto.
    - intros [? H1 H2]; revert x H1; induction H2; eauto.
  Qed.

  Lemma step_star_plus x y z:
    R x y -> star y z -> plus x z.
  Proof.
    intros H1 H2; apply plus_destruct; eauto.
  Qed.

  Lemma plus_star_step x y z :
    plus x y -> star y z -> plus x z.
  Proof.
    intros [] % plus_destruct ?. eapply plus_destruct.
    eexists; eauto using star_trans.
  Qed.

End ClosureRelations.

Definition equiv X (R: X -> X -> Prop) := star (sym R).

Hint Constructors star plus counted.
Hint Resolve star_trans plus_trans counted_trans star_exp plus_exp counted_exp.

Section Properties.
  Variable X: Type.
  Implicit Types (x y z : X) (R S : X -> X -> Prop).

  Fact star_mono R S :
    R <<= S -> star R <<= star S.
  Proof.
    intros H x y.
    induction 1; eauto.
  Qed.

  Fact plus_mono R S :
    R <<= S -> plus R <<= plus S.
  Proof.
    intros H x y.
    induction 1; eauto.
  Qed.

  Fact star_closure R S :
    PreOrder S -> R <<= S -> star R <<= S.
  Proof.
    intros H1 H2 x y.
    induction 1 as [x|x x' y H4 _ IH].
    - reflexivity.
    - transitivity x'; auto.
  Qed.

  Fact star_idem R :
    star (star R) === star R.
  Proof.
    split.
    - induction 1; eauto.
    - apply star_mono, star_exp.
  Qed.

  Fact plus_idem R :
    plus (plus R) === plus R.
  Proof.
    split; eauto.
    induction 1; eauto.
  Qed.

  Fact plus_fixpoint R :
    plus (star R) === star R.
  Proof.
    split.
    - induction 1; eauto.
    - eauto.
  Qed.

  Fact star_absorbtion R :
    star (plus R) === star R.
  Proof.
    split.
    - induction 1; eauto.
      apply plus_destruct in H. destruct H. eauto.
    - eapply star_mono. eauto.
  Qed.

  Lemma sym_symmetric R x y:
    sym R x y -> sym R y x.
  Proof.
    intros []; eauto using sym.
  Qed.

  Lemma refl_star R x y:
    x = y -> star R x y.
  Proof.
    intros ->; eauto.
  Qed.

  Lemma refl_equiv R x:
    equiv R x x.
  Proof.
    constructor.
  Qed.

  Lemma equiv_trans R x y z:
    equiv R x y -> equiv R y z -> equiv R x z.
  Proof. eapply star_trans. Qed.

  Lemma equiv_symm R x y:
    equiv R x y -> equiv R y x.
  Proof.
    induction 1.
    constructor; eauto.
    eapply star_trans; eauto.
    econstructor 2; eauto using refl_equiv, sym_symmetric.
  Qed.

  Lemma equiv_star R x y:
    star R x y -> equiv R x y.
  Proof.
    induction 1; unfold equiv in *; eauto using sym, star.
  Qed.

End Properties.

(** Strong normalisation *)
Section StrongNormalisation.

  Variables (X A: Type).
  Variables (R: X -> X -> Prop) (S: A -> A -> Prop).

  Definition Normal x := forall y, ~ R x y.
  Definition evaluates s t := star R s t /\ Normal t.

  Inductive SN {X} (R: X -> X -> Prop) : X -> Prop :=
  | SNC x : (forall y, R x y -> SN R y) -> SN R x.

  Lemma SN_ext Q x :
    (forall x y, R x y <-> Q x y) ->
    SN R x <-> SN Q x.
  Proof.
    split; induction 1; econstructor; firstorder.
  Qed.

  Fact SN_unfold x :
    SN R x <-> forall y, R x y -> SN R y.
  Proof.
    split.
    - destruct 1 as [x H]. exact H.
    - intros H. constructor. exact H.
  Qed.

  Fact Normal_SN x :
    Normal x -> SN R x.
  Proof.
    intros H. constructor. intros y H1.
    exfalso. eapply H; eauto.
  Qed.

  Fact Normal_star_stops x:
    Normal x -> forall y, star R x y -> x = y.
  Proof.
    destruct 2; firstorder.
  Qed.

  Fact SN_plus x :
    SN R x <-> SN (plus R) x.
  Proof.
    split.
    - induction 1 as [x _ IH].
      constructor. induction 1; eauto.
      apply IHplus. intros z H1 % plus_exp.
      destruct (IH x' H) as [H2].
      apply H3. eauto.
    - induction 1 as [x _ IH].
      constructor. intros y H1. apply IH. eauto.
  Qed.

  Definition morphism  (f: X -> A) := forall x y, R x  y -> S (f x) (f y).

  Fact SN_morphism f x :
    morphism f -> SN S (f x) -> SN R x.
  Proof.
    intros H H1.
    remember (f x) as a eqn:H2. revert x H2.
    induction H1 as [a _ IH]. intros x ->.
    constructor. intros y H1 % H.
    apply (IH _ H1). reflexivity.
  Qed.

  Fact SN_finite_steps:
     (forall x, (exists y, R x y) \/ Normal x) -> forall x, SN R x -> exists2 y, star R x y & Normal y.
  Proof.
    intros H; induction 1 as [x H1 IH]. destruct (H x) as [[y H2]|].
    + edestruct IH as [z H3 H4]; eauto.
    + eexists; eauto.
  Qed.

End StrongNormalisation.

Section Confluence.

  Variable X: Type.
  Implicit Types (x y z : X) (R S : X -> X -> Prop).

  Definition joinable R x y := exists2 z, R x z & R y z.
  Definition diamond R := forall x y z, R x y -> R x z -> joinable R y z.
  Definition confluent R := diamond (star R).
  Definition semi_confluent R :=
    forall x y z, R x y -> star R x z -> joinable (star R) y z.

  Fact diamond_semi_confluent R :
    diamond R -> semi_confluent R.
  Proof.
    intros H x y1 y2 H1 H2. revert y1 H1.
    induction H2 as [x|x x' y2 H2 _ IH]; intros y1 H1.
    - exists y1; eauto.
    - assert (joinable R y1 x') as [z H3 H4].
      { eapply H; eauto. }
      assert (joinable (star R) z y2) as [u H5 H6].
      { apply IH; auto. }
      exists u; eauto.
  Qed.

  Fact confluent_semi R :
    confluent R <-> semi_confluent R.
  Proof.
    split.
    - intros H x y1 y2 H1 H2.
      eapply H; [|exact H2]. auto.
    - intros H x y1 y2 H1 H2. revert y2 H2.
      induction H1 as [x|x x' y1 H1 _ IH]; intros y2 H2.
      + exists y2; auto.
      + assert (joinable (star R) x' y2) as [z H3 H4].
        { eapply H; eauto. }
        assert (joinable (star R) y1 z) as [u H5 H6].
        { apply IH; auto. }
        exists u; eauto.
  Qed.

  Fact diamond_confluent R :
    diamond R -> confluent R.
  Proof.
    intros H.
    apply confluent_semi, diamond_semi_confluent, H.
  Qed.

  Fact joinable_ext R S x y:
    R === S -> joinable R x y -> joinable S x y.
  Proof.
    firstorder.
  Qed.

  Fact diamond_ext R S:
    R === S -> diamond S -> diamond R.
  Proof.
    intros H1 H2 x y z H3 H4.
    assert (joinable S y z); firstorder.
  Qed.

  Lemma confluence_normal_left R x y z:
    confluent R -> Normal R y ->
    star R x y -> star R x z ->
    star R z y.
  Proof.
    intros H1 H2 H3 H4. destruct (H1 _ _ _ H3 H4) as [x' A B].
    enough (x' = y) by congruence.
    destruct A; eauto; exfalso; eapply H2; eauto.
  Qed.

  Lemma confluence_normal_right R x y z:
    confluent R -> Normal R z ->
    star R x y -> star R x z ->
    star R y z.
  Proof.
    intros H1 H2 H3 H4. destruct (H1 _ _ _ H3 H4) as [x' A B].
    enough (x' = z) by congruence.
    destruct B; eauto; exfalso; eapply H2; eauto.
  Qed.

  Lemma confluence_unique_normal_forms R x y z:
    confluent R -> Normal R y -> Normal R z ->
    star R x y -> star R x z -> y = z.
  Proof.
    intros H1 H2 H3 H4 H5. destruct (H1 _ _ _ H4 H5) as [x' A B].
    destruct A; [destruct B | ]; eauto; exfalso; [ eapply H3 | eapply H2 ];  eauto.
  Qed.

  Lemma church_rosser (R: X -> X -> Prop) s t:
    confluent R -> equiv R s t -> exists v: X, star R s v /\ star R t v.
  Proof.
    induction 2.
    - now (exists x).
    - inv H0.
      + destruct IHstar as [v];  exists v; intuition;  eauto.
      + destruct IHstar; intuition.
        edestruct H.
        eapply H3. econstructor 2; eauto.
        exists x1; split; eauto.
  Qed.

End Confluence.

(** Right-recursive version of star. *)

Inductive starL {X: Type} (R: X -> X -> Prop) (x : X):  X -> Prop :=
| starReflL : starL R x x
| starStepL  y y':  starL R x y -> R y y' -> starL R x y'.

Hint Constructors starL.

Lemma star_starL X (R : X -> X -> Prop) x y :
  starL R x y <-> star R x y .
Proof.
  split.
  - induction 1; auto. induction IHstarL; eauto.
  - induction 1; eauto. clear H0. induction IHstar; eauto.
Qed.

(**  Typeclass Instances **)
Global Instance subrel_star {X} (R : X -> X -> Prop) :
  subrelation (plus R) (star R).
Proof.
  intros ?; eapply plus_star.
Qed.

Global Instance subrel_star_mono {X} (R S: X -> X -> Prop) (H: subrelation R S) :
  subrelation (star R) (star S).
Proof.
  exact (star_mono _ H).
Qed.

Global Instance subrel_plus_mono {X} (R S: X -> X -> Prop) (H: subrelation R S) :
  subrelation (plus R) (plus S).
Proof.
  exact (plus_mono _ H).
Qed.

Global Instance subrel_star_equiv {X} (R: X -> X -> Prop) :
  subrelation (star R) (equiv R).
Proof.
  exact (@equiv_star _ R).
Qed.

Global Instance star_preorder {X} (R: X -> X -> Prop):
  PreOrder (star R).
Proof.
  constructor; hnf; eauto using star_trans.
Qed.

Global Instance star_expansive {X} (R: X -> X -> Prop):
  subrelation R (star R).
Proof.
  intros ?; eapply star_exp.
Qed.

Global Instance plus_expansive {X} (R: X -> X -> Prop):
  subrelation R (plus R).
Proof.
  intros?; eapply plus_exp.
Qed.

Global Instance plus_transitive {X} (R: X -> X -> Prop):
  Transitive (plus R).
Proof.
  intros ?; eapply plus_trans.
Qed.

Global Instance sym_Symmetric {X} (R: X -> X -> Prop):
  Symmetric (sym R).
Proof.
  firstorder using sym_symmetric.
Qed.

Global Instance equiv_Equivalence {X} (R: X -> X -> Prop):
  Equivalence (equiv R).
Proof.
  constructor; try firstorder using refl_equiv, equiv_trans, equiv_symm.
  intros ? ? ? ; eapply equiv_trans.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

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

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

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

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Theorem append_Nil: forall (l: lst), append l Nil = l.
Proof.
  induction l.
  { simpl. f_equal. assumption. }
  { simpl. reflexivity. }
Qed.

Theorem append_assoc:
  forall (l1 l2 l3: lst), append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
  induction l1; induction l2; induction l3; try (simpl; reflexivity).
  - simpl. rewrite <- IHl1. f_equal.
  - simpl. rewrite 2 append_Nil. reflexivity.
  - simpl. lfind.   reflexivity.
Admitted.

Theorem append_rev_Cons:
  forall (l1 l2: lst) (x: natural),
    rev (append l1 (Cons x l2)) = append (rev l2) (Cons x (rev l1)).
Proof.
  induction l1; induction l2; try (simpl; reflexivity).
  { intro. simpl. rewrite IHl1. simpl. rewrite <- append_assoc.
    f_equal. }
  { intro. simpl. rewrite IHl1. simpl. reflexivity. }
Qed.

Theorem rev_append: forall (l1 l2: lst), rev (append l1 l2) = append (rev l2) (rev l1).
Proof.
  induction l1.
  { induction l2.
    { simpl. rewrite append_rev_Cons.
      rewrite <- 2 append_assoc.
      f_equal. }
    { simpl. rewrite append_Nil. reflexivity. }
  }
  { intro. simpl. rewrite append_Nil. reflexivity. }
Qed.

Theorem theorem0 : forall (x : lst), eq (rev (rev x)) x.
Proof.
  induction x.
  { simpl. rewrite rev_append. simpl. f_equal.
    assumption. }
  { simpl. reflexivity. }
Qed.


(* Require Export Field_theory. *)
Require Import ZArith.
Open Scope Z_scope.

Goal forall a b c : Z,
  (a+b+c)^2 =
  a * a + b^2 + c * c + 2 * a * b + 2 * a * c + 2 * b * c.
  intros.
  ring.
Qed.


Theorem andb_eq_orb :
  forall (b c : bool),
  (andb b c = orb b c) ->
  b = c.
Proof.
  intros b c. destruct b eqn: Eb.
  - simpl. destruct c eqn: Ec.
    -- reflexivity.
    -- intros. rewrite <- H. reflexivity.
  - simpl. destruct c eqn: Ec.
    -- intros. rewrite <- H. reflexivity.
    -- intros H. reflexivity.
Qed.


Require Export Iron.Language.SimplePCF.SubstExpExp.
Require Export Iron.Language.SimplePCF.Exp.

(*******************************************************************)
(** Evaluation Contexts. *)
(*  Describes a place in the AST where the subespression there
    is able to take an evaluation step. Each contexts is represented
    by the function that fills it. *)
Inductive exp_ctx : (exp -> exp) -> Prop :=
 | XcTop
   :  exp_ctx (fun x => x)

 | XcApp1
   :  forall x2
   ,  exp_ctx (fun xx => XApp xx x2)

 (* The argument of an application can only step once the
    function has already been evaluated. *)
 | XcApp2
   :  forall v1
   ,  wnfX v1
   -> exp_ctx (fun xx => XApp v1 xx)

 | XcSucc
   :  exp_ctx (fun xx => XSucc   xx)

 | XcPred
   :  exp_ctx (fun xx => XPred   xx)

 | XcIsZero
   :  exp_ctx (fun xx => XIsZero xx)

 | XcIf
   :  forall x2 x3
   ,  exp_ctx (fun xx => XIf xx x2 x3).

Hint Constructors exp_ctx.

(********************************************************************)
(** Single Small Step Evaluation *)
(** The single step rules model the individual transitions that the
    machine can make at runtime. *)
Inductive STEP : exp -> exp -> Prop :=

 | EsContext
   :  forall C x x'
   ,  exp_ctx C
   -> STEP x x'
   -> STEP (C x) (C x')

 (* Function application.
    Substitute the value into the abstraction *)
 | EsLamApp
   : forall t11 x12 v2
   ,  wnfX v2
   -> STEP (XApp   (XLam t11 x12) v2)
           (substX 0 v2 x12)

 (* Fixpoint.
    Substitute the abstraction into itself. *)
 | EsFix
   :  forall t11 x12
   ,  STEP (XFix t11 x12)
           (substX 0 (XFix t11 x12) x12)

 (* Naturals **************************)
 (* Increment the primitive value *)
 | EsSucc
   :  forall n
   ,  STEP (XSucc (XNat n)) (XNat (S n))

 (* If we've got a Zero then just return Zero,
    this way we don't need to worry about negative naturals. *)
 | EsPredZero
   :  STEP (XPred (XNat O)) (XNat O)

 (* If we've got a Succ then return the inner expression. *)
 | EsPredSucc
   :  forall n
   ,  STEP (XPred (XNat (S n))) (XNat n)

 (* Booleans **************************)
 | EsIsZeroTrue
   :  STEP (XIsZero (XNat O)) XTrue

 | EsIsZeroFalse
   :  forall n
   ,  STEP (XIsZero (XNat (S n))) XFalse

 (* Branching *************************)
 (* Take the 'then' branch. *)
 | EsIfThen
   :  forall x2 x3
   ,  STEP (XIf XTrue x2 x3) x2

 (* Take the 'else' branch. *)
 | EsIfElse
   :  forall x2 x3
   ,  STEP (XIf XFalse x2 x3) x3.

Hint Constructors STEP.

(********************************************************************)
(** Multi-step evaluation. *)
(** A sequence of small step transitions.
    As opposed to STEPSL, this version has an append constructor
    ESAppend that makes it easy to join two evaluations together.
    We use this when converting big-step evaluations to small-step. *)
Inductive STEPS : exp -> exp -> Prop :=

 (* After no steps, we get the same exp.
    We need this constructor to match the EVDone constructor
    in the big-step evaluation, so we can convert between big-step
    and multi-step evaluations. *)
 | EsNone
   :  forall x1
   ,  STEPS x1 x1

 (* Take a single step. *)
 | EsStep
   :  forall x1 x2
   ,  STEP  x1 x2
   -> STEPS x1 x2

 (* Combine two evaluations into a third. *)
 | EsAppend
   :  forall x1 x2 x3
   ,  STEPS x1 x2 -> STEPS x2 x3
   -> STEPS x1 x3.

Hint Constructors STEPS.

(* Multi-step evaluation in a context. *)
Lemma steps_context
 :  forall C x1 x1'
 ,  exp_ctx C
 -> STEPS x1 x1'
 -> STEPS (C x1) (C x1').
Proof.
 intros C x1 x1' HC HS.
 induction HS; burn.
Qed.

(********************************************************************)
(** Left linearised multi-step evaluation. *)
(** As opposed to STEPS, this version provides a single step at a time
    and does not have an append constructor. This is convenient
    when converting a small-step evaluations to big-step, via the
    eval_expansion lemma. *)
Inductive STEPSL : exp -> exp -> Prop :=
 | EslNone
   : forall x1
   , STEPSL x1 x1

 | EslCons
   :  forall x1 x2 x3
   ,  STEP   x1 x2 -> STEPSL x2 x3
   -> STEPSL x1 x3.

Hint Constructors STEPSL.

(* Transitivity of left linearised multi-step evaluation.
   We use this when "flattening" a big step evaluation to the
   small step one. *)
Lemma stepsl_trans
 :  forall x1 x2 x3
 ,  STEPSL x1 x2 -> STEPSL x2 x3
 -> STEPSL x1 x3.
Proof.
 intros. induction H; burn.
Qed.

(* Linearise a regular multi-step evaluation.
   This flattens out all the append constructors, leaving us with
   a list of individual transitions. *)
Lemma stepsl_of_steps
 :  forall x1 x2
 ,  STEPS  x1 x2
 -> STEPSL x1 x2.
Proof.
 intros. induction H; burn using stepsl_trans.
Qed.


Require Import Nat List Bool Logic Orders.
Require Import Coq.Sorting.Sorted.
Require Import Coq.Sorting.Permutation.
Require Import Coq.Relations.Relation_Definitions.
Import ListNotations.

Hint Constructors LocallySorted.

Lemma LocallySorted_begin: forall {A:Type} {R:relation A} l x y,
  LocallySorted R (x::l) ->
  R y x ->
  LocallySorted R (y::x::l).
Proof.
  intros; constructor; auto.
Qed.

Lemma LocallySorted_end: forall {A:Type} {R:relation A} l x y,
  LocallySorted R (l ++ [x]) ->
  R x y ->
  LocallySorted R (l ++ [x; y]).
Proof.
  intros.
  induction l; simpl in *.
  - repeat constructor; auto.
  - inversion H. symmetry in H3. apply app_eq_nil in H3; destruct H3. inversion H3.
    rewrite H2 in *.
    apply IHl in H3. change (l ++ [x; y]) with (l ++ [x] ++ [y]) in *.
    rewrite app_assoc in *. rewrite <- H2 in *. simpl in H3.
    change (a::(b::l0) ++ [y]) with (a::b::(l0 ++ [y])).
    constructor; auto.
Qed.

Lemma LocallySorted_sum: forall {A:Type} {R:relation A} a b l l',
  LocallySorted R (l ++ [a]) -> LocallySorted R (b::l') ->
  R a b ->
  LocallySorted R (l ++ [a;b] ++ l').
Proof.
  intros.
  induction l, l'; simpl.
  - repeat constructor; auto.
  - constructor; auto.
  - simpl in H. inversion H. symmetry in H4. apply app_eq_nil in H4. destruct H4. inversion H4.
    subst. rewrite H3 in H4.
    apply IHl in H4. simpl in H4.
    change (l ++ [a;b]) with (l ++ [a] ++ [b]) in *. rewrite app_assoc in *.
    rewrite <- H3 in *.
    change (a0::(b0::l0) ++ [b]) with (a0::b0::(l0 ++ [b])). constructor.
    simpl in H4. auto. auto.
  - simpl in H. inversion H. symmetry in H4. apply app_eq_nil in H4. destruct H4. inversion H4.
    subst. rewrite H3 in H4. apply IHl in H4. simpl in H4.
    change (l ++ a :: b :: a1 :: l') with (l ++ [a] ++ b :: a1 :: l') in *.
    rewrite app_assoc in *. rewrite <- H3 in *.
    simpl in *. constructor; auto.
Qed.

Lemma LocallySorted_hd_relation: forall {A: Type} {R: relation A} l x,
  (forall t, In t l -> R x t) ->
  LocallySorted R l ->
  LocallySorted R (x::l).
Proof.
  intros; generalize dependent l.
  induction l; intros; auto.
  constructor; auto.
  apply H. simpl; auto.
Qed.

Lemma LocallySorted_end_relation: forall {A:Type} {R: relation A} l x,
  Transitive R ->
  (forall t : A, In t l -> R t x) -> LocallySorted R l ->
    LocallySorted R (l ++ [x]).
Proof.
  intros; generalize dependent l;
  induction l; intros; simpl; auto.
  apply LocallySorted_hd_relation; intros;
  apply Sorted_LocallySorted_iff in H1;
  apply Sorted_StronglySorted in H1; auto;
  apply StronglySorted_inv in H1; destruct H1 as [EQ ED];
  rewrite Forall_forall in ED. apply in_app_or in H2. destruct H2; auto.
  - simpl in H1; intuition; subst.
    apply H0. simpl. auto.
  - apply IHl. intros.
    apply H0. simpl. auto.
    apply StronglySorted_Sorted in EQ. apply Sorted_LocallySorted_iff; auto.
Qed.

Definition is_sorting_algo {A: Type} (R: relation A) (f: list A -> list A) :=
  forall l, Permutation l (f l) /\ Sorted R (f l).


Require Import List Lia.
Import ListNotations.

Require Import ssreflect ssrbool ssrfun.

Set Default Goal Selector "!".

(* Generic facts *)

(* duplicates argument *)
Fact copy {A : Type} : A -> A * A.
Proof. done. Qed.

(* transforms a goal (A -> B) -> C into goals A and B -> C *)
Lemma unnest : forall (A B C : Type), A -> (B -> C) -> (A -> B) -> C.
Proof. auto. Qed.

Lemma iter_plus {X: Type} {f: X -> X} {x: X} {n m: nat} : Nat.iter n f (Nat.iter m f x) = Nat.iter (n + m) f x.
Proof. elim: n; [done | by move=> n /= ->]. Qed.

Fact iter_last {X: Type} {f: X -> X} {n x} : Nat.iter n f (f x) = Nat.iter (1+n) f x.
Proof. elim: n x; [done | by move=> n /= + x => ->]. Qed.

(* induction/recursion principle wrt. a decreasing measure f *)
(* example: elim /(measure_rect length) : l. *)
Lemma measure_rect {X : Type} (f : X -> nat) (P : X -> Type) :
  (forall x, (forall y, f y < f x -> P y) -> P x) -> forall (x : X), P x.
Proof.
  exact: (well_founded_induction_type (Wf_nat.well_founded_lt_compat X f _ (fun _ _ => id)) P).
Qed.

(* List facts *)
Lemma Forall_appI {X: Type} {P : X -> Prop} {A B}: Forall P A -> Forall P B -> Forall P (A ++ B).
Proof. move=> ? ?. apply /Forall_app. by constructor. Qed.

Lemma incl_nth_error {X: Type} {Gamma Gamma': list X} :
  incl Gamma Gamma' -> exists ξ, forall x, nth_error Gamma x = nth_error Gamma' (ξ x).
Proof.
  elim: Gamma Gamma'.
  - move=> Gamma' _. exists (fun x => length Gamma').
    move=> [|x] /=; apply /esym; by apply /nth_error_None.
  - move=> x Gamma IH Gamma'. move=> /Forall_forall /Forall_cons_iff.
    move=> [/(@In_nth_error _ _ _) [nx] Hnx /Forall_forall /IH] [ξ Hξ].
    exists (fun y => if y is S y then ξ y else nx). by case.
Qed.

Lemma Forall_seqP {P : nat -> Prop} {m n: nat} :
  Forall P (seq m n) <-> (forall i, m <= i < m + n -> P i).
Proof. rewrite Forall_forall. constructor; move=> H ? ?; apply H; by apply /in_seq. Qed.

Lemma Forall2_consE {X Y: Type} {R: X -> Y -> Prop} {x y l1 l2} :
  Forall2 R (x :: l1) (y :: l2) -> R x y /\ Forall2 R l1 l2.
Proof. move=> H. by inversion H. Qed.

Lemma Forall2_length_eq {X Y: Type} {R: X -> Y -> Prop} {l1 l2} :
  Forall2 R l1 l2 -> length l1 = length l2.
Proof.
  elim: l1 l2.
  - move=> [| ? ?] H; first done. by inversion H.
  - move=> ? ? IH [| ? ?] /= H; inversion H. congr S. by apply: IH.
Qed.

Lemma in_app_l {X: Type} {x: X} {l1 l2: list X} : In x l1 -> In x (l1 ++ l2).
Proof. move=> ?. apply /in_app_iff. by left. Qed.

Lemma in_app_r {X: Type} {x: X} {l1 l2: list X} : In x l2 -> In x (l1 ++ l2).
Proof. move=> ?. apply /in_app_iff. by right. Qed.

(* construct choice function for a list over nat *)
Lemma list_choice {P : nat -> nat -> Prop} {l: list nat} : Forall (fun i : nat => exists n : nat, P i n) l ->
  exists φ, Forall (fun i : nat => P i (φ i)) l.
Proof.
  elim: l; first by exists id.
  move=> k l IH /Forall_cons_iff [[n Hkn]] /IH [φ Hφ].
  exists (fun i => if PeanoNat.Nat.eq_dec i k then n else φ i).
  constructor; first by case: (PeanoNat.Nat.eq_dec k k).
  apply: Forall_impl Hφ => i Hi.
  case: (PeanoNat.Nat.eq_dec i k); [by move=> /= ->|done].
Qed.

Lemma map_id' {X: Type} {f: X -> X} {l: list X} : (forall x, f x = x) -> map f l = l.
Proof. move=> ?. rewrite -[RHS]map_id. by apply: map_ext => ?. Qed.

Lemma is_trueP {b1 b2: bool} : (is_true b1 <-> is_true b2) <-> b1 = b2.
Proof.
  case: b1; case: b2; rewrite /is_true; firstorder done.
Qed.


Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.

Proof.
  intros b c.
  destruct b.
  - simpl. destruct c.
    -- simpl. intros H. reflexivity.
    -- simpl. intros H. rewrite H. reflexivity.
  - simpl. destruct c.
    -- simpl. intros H. reflexivity.
    -- simpl. intros H. rewrite H. reflexivity.
Qed.


From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp Require Import bigenough cauchyreals.

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

Import Order.TTheory GRing.Theory Num.Theory BigEnough.

Local Open Scope ring_scope.

Section ExtraCreals.

Variable F : realFieldType.

Lemma eq_creal_ext (x y : creal F) : x =1 y ->  (x == y)%CR.
Proof.
move=> heq; apply/eq_crealP; exists (fun _ => 0%N) => * /=.
by rewrite heq subrr normr0.
Qed.

Lemma ler_lecr  (x y : creal F) : (forall i, x i <= y i) ->  (x <= y)%CR.
Proof.
move=> heq; apply: (@le_crealP _ 0%N) => j _; exact: heq.
Qed.

Lemma ltcr_add2r (z x y : creal F) : (x < y)%CR -> (x + z < y + z)%CR.
Proof.
move=> lt_xy; pose_big_enough i.
  apply: (@lt_crealP _ (diff lt_xy) i i); rewrite ?diff_gt0 //=.
  by rewrite addrAC ler_add2r diffP.
by close.
Qed.

Lemma ltcr_add2l (z x y : creal F) : (x < y)%CR -> (z + x < z + y)%CR.
Proof.
move=> lt_xy; pose_big_enough i.
  apply: (@lt_crealP _ (diff lt_xy) i i); rewrite ?diff_gt0 //=.
  rewrite -addrA ler_add2l diffP //.
by close.
Qed.

Lemma addr_gtcr0 (x y : creal F) : (0 < x -> 0 < y -> 0 < x + y)%CR.
move=> lt_0x lt_0y.
have := ltcr_add2r y lt_0x; rewrite add_0creal => h.
by apply: lt_creal_trans h.
Qed.

Lemma subcr_eq0  (x y : creal F) : (x - y == 0)%CR <-> (x == y)%CR.
Proof.
split => h.
  rewrite -[y]add_creal0 -h; apply: eq_creal_ext=> i /=; rewrite addrCA subrr.
  by rewrite addr0.
by rewrite h; apply: eq_creal_ext=> i /=; rewrite subrr.
Qed.

Lemma ltcr_mul2r (z x y : creal F) :
  (x < y)%CR -> (0 < z)%CR -> (x * z < y * z)%CR.
Proof.
move=> ltxy lt0z; pose_big_enough i.
  apply: (@lt_crealP _ ((diff ltxy) * (diff lt0z)) i i) => //=.
  - apply: mulr_gt0; exact: diff_gt0.
  rewrite -ler_sub_addl -mulrBl; apply: ler_pmul.
  - by apply: ltW; apply: diff_gt0.
  - by apply: ltW; apply: diff_gt0.
  - by rewrite ler_sub_addl diffP.
  - by rewrite -[X in X <= _]add0r -[0]/((0%:CR)%CR i) diffP.
by close.
Qed.

Lemma mulcrN (x y : creal F) : (x * - y == - (x * y))%CR.
Proof. by apply: eq_creal_ext=> i /=; rewrite mulrN. Qed.

Lemma mulNcr (x y : creal F) : (- x * y == - (x * y))%CR.
Proof. by apply: eq_creal_ext=> i /=; rewrite mulNr. Qed.

Lemma mulcrC (x y : creal F) : (x * y == y * x)%CR.
Proof. by apply: eq_creal_ext=> i /=; rewrite mulrC. Qed.

Lemma mulcrA (x y z : creal F) : (x * (y * z) == x * y * z)%CR.
Proof. by apply: eq_creal_ext=> i /=; rewrite mulrA. Qed.

Lemma addcrC (x y : creal F) : (x + y == y + x)%CR.
Proof. by apply: eq_creal_ext=> i /=; rewrite addrC. Qed.

Lemma addcrA (x y z : creal F) : (x + (y + z) == x + y + z)%CR.
Proof. by apply: eq_creal_ext=> i /=; rewrite addrA. Qed.

Lemma addcrN (x : creal F) : (x - x == 0)%CR.
Proof. by apply: eq_creal_ext=> i /=; rewrite addrN. Qed.

Lemma mulcrDr (x y z : creal F) : (x * (y + z) == x * y + x * z)%CR.
Proof. by apply: eq_creal_ext=> i /=; rewrite mulrDr. Qed.

Lemma mulcrDl (x y z : creal F) : ((y + z) * x == y * x + z * x)%CR.
Proof. by apply: eq_creal_ext=> i /=; rewrite mulrDl. Qed.

Lemma ltcr_mul2l (z x y : creal F) :
  (x < y)%CR -> (0 < z)%CR -> (z * x < z * y)%CR.
Proof. rewrite ![(z * _)%CR]mulcrC; exact: ltcr_mul2r. Qed.

Lemma ltcr_pmul (x1 y1 x2 y2 : creal F) :
      (0 < x1)%CR -> (0 < y2)%CR -> (x1 < y1)%CR -> (x2 < y2)%CR ->
      (x1 * x2 < y1 * y2)%CR.
Proof.
move=> px1 px2 lt1 lt2.
have aux : (x1 * x2 < x1 * y2)%CR by apply: ltcr_mul2l.
by apply: lt_creal_trans aux _; apply: ltcr_mul2r.
Qed.

Lemma mulr_gtcr0 (x y : creal F) : (0 < x -> 0 < y -> 0 < x * y)%CR.
move=> lt_0x lt_0y; pose_big_enough i.
  apply: (@lt_crealP _ ((diff lt_0x) * (diff lt_0y)) i i) => //=.
  - apply: mulr_gt0; exact: diff_gt0.
  rewrite add0r; apply: ler_pmul.
  - by apply: ltW; apply: diff_gt0.
  - by apply: ltW; apply: diff_gt0.
  - by rewrite -[X in X <= _]add0r -[0]/((0%:CR)%CR i) diffP.
  - by rewrite -[X in X <= _]add0r -[0]/((0%:CR)%CR i) diffP.
by close.
Qed.

Lemma cst_crealM (x y : F) : ((x * y)%:CR == x%:CR * y%:CR)%CR.
Proof. by apply: eq_creal_ext=> i /=. Qed.

Lemma cst_crealD (x y : F) : ((x + y)%:CR == x%:CR + y%:CR)%CR.
Proof. by apply: eq_creal_ext=> i /=. Qed.

Lemma cst_crealB (x y : F) : ((x - y)%:CR == x%:CR - y%:CR)%CR.
Proof. by apply: eq_creal_ext=> i /=. Qed.

Lemma cst_crealN (x : F) : ((- x)%:CR == - x%:CR)%CR.
Proof. by apply: eq_creal_ext=> i /=. Qed.

Lemma le_ubound (x : creal F) : (x <= (ubound x)%:CR)%CR.
Proof.
apply: (@le_crealP _ 0%N) => j _ /=.
apply: le_trans (uboundP x j); exact: ler_norm.
Qed.

Lemma lt_ubound (x : creal F) : (x < (ubound x + 1)%:CR)%CR.
Proof.
pose_big_enough i.
  apply: (@lt_crealP _ 1 i i) => //=; rewrite ler_add2r.
  apply: le_trans (uboundP x i); exact: ler_norm.
by close.
Qed.

Lemma ltcr_le_trans (y x z : creal F): (x < y -> y <= z -> x < z)%CR.
Proof.
move=> ltxy leyz; pose_big_enough i.
  have hpos : 0 < diff ltxy / 2%:~R.
    apply: divr_gt0; rewrite ?ltr0Sn //; exact: diff_gt0.
  apply: (@lt_crealP _  ((diff ltxy) / 2%:~R) i i) => //=.
  have -> : x i + diff ltxy / 2%:~R = x i + diff ltxy - diff ltxy / 2%:~R.
    apply/eqP; rewrite eq_sym subr_eq -addrA -mulrDr.
    have <- : 1 = 2%:~R^-1 + 2%:~R^-1 :> F by rewrite [LHS](splitf 2) div1r.
    by rewrite mulr1.
  rewrite ler_subl_addr; apply: le_trans (diffP _ _) _ => //; apply: ltW.
  by apply: le_modP.
by close.
Qed.

Lemma lecr_lt_trans (y x z : creal F): (x <= y)%CR -> (y < z)%CR -> (x < z)%CR.
Proof.
(* We could just use the opposites but we do not have the lemmas... *)
(* Hence we copy paste mutatis mutandis the previous proof *)
move=> lexy ltyz; pose_big_enough i.
  have hpos : 0 < diff ltyz / 2%:~R.
    apply: divr_gt0; rewrite ?ltr0Sn //; exact: diff_gt0.
  apply: (@lt_crealP _  ((diff ltyz) / 2%:~R) i i) => //=.
  apply: le_trans (@diffP _ _ _ ltyz _ _ _) => //; rewrite -ler_subr_addr.
  suff <- : y i + diff ltyz / 2%:~R = y i + diff ltyz - diff ltyz / 2%:~R.
    by apply: ltW; apply: le_modP.
  apply/eqP; rewrite eq_sym subr_eq -addrA -mulrDr.
  have <- : 1 = 2%:~R^-1 + 2%:~R^-1 :> F by rewrite [LHS](splitf 2) div1r.
  by rewrite mulr1.
by close.
Qed.

Lemma lecr_trans (y x z : creal F): (x <= y -> y <= z -> x <= z)%CR.
Proof.
move=> lexy leyz ltzx; apply: (@eq_creal_refl _ z); apply: lt_creal_neq.
by apply: ltcr_le_trans leyz; apply: ltcr_le_trans lexy.
Qed.

Lemma lecr_mulf2r (z : F) (x y : creal F) :
  (x <= y)%CR ->  0 <= z -> (x * z%:CR <= y * z%:CR)%CR.
Proof.
move=> lexy.
rewrite le_eqVlt; case/orP=> [/eqP <- | lt0z]; first by rewrite !mul_creal0.
move => h; apply: lexy.
have aux t : (t == t * z%:CR * z^-1%:CR)%CR.
  rewrite -mulcrA -cst_crealM mulfV ?mul_creal1 //; move: lt0z; rewrite lt0r.
  by case/andP.
rewrite [x]aux {}[y]aux; apply: ltcr_mul2r => //; apply/lt_creal_cst.
by rewrite invr_gt0.
Qed.

Lemma lecr_mulf2l (z : F) (x y : creal F) : (x <= y)%CR ->
  0 <= z -> (z%:CR * x <= z%:CR * y)%CR.
Proof. by rewrite ![(z%:CR * _)%CR]mulcrC; apply: lecr_mulf2r. Qed.

Lemma lecr_lt_add (x y z t : creal F) : (x <= y -> z < t -> x + z < y + t)%CR.
Proof.
move=> lxy lzt; apply: (@lecr_lt_trans (y + z)%CR); last exact: ltcr_add2l.
move/(ltcr_add2l (-z)%CR)=> abs; apply: lxy; move: abs.
by rewrite ![(- z + _)%CR]addcrC -!addcrA addcrN !add_creal0.
Qed.

Lemma ltcr_le_add (x y z t : creal F) : (x < y -> z <= t -> x + z < y + t)%CR.
Proof.
move=> *; rewrite [X in (X < _)%CR]addcrC [X in (_ < X)%CR]addcrC.
by apply: lecr_lt_add.
Qed.

Lemma ltcr_spaddl (y x z : creal F) : (0 < x -> y <= z -> y < x + z)%CR.
Proof. move=> *; rewrite -[y]add_0creal; exact: ltcr_le_add. Qed.

Lemma ltcr_spaddr (y x z : creal F) : (0 < x -> y <= z -> y < z + x)%CR.
Proof. move=> *; rewrite -[y]add_creal0; exact: lecr_lt_add. Qed.

Lemma asympt_eq_creal (x : creal F) (y : nat -> F) :
  {asympt e : i / `|x i - y i| < e} ->  creal_axiom y.
Proof.
case: x => x [mx mxP]; case=> M MP;
exists_big_modulus m F.
  move=> eps i j lt_eps_0 hmi hmj; pose d (k : nat) := x k - y k.
  have -> : y i - y j = d j + (x i - x j) - d i.
    rewrite /d [(_ - _) + _]addrC addrA addrNK opprB addrA [_ - x i]addrC.
    by rewrite addrA addKr addrC.
  suff step1 : `|d j + (x i - x j)| + `|d i| < eps.
    by apply: le_lt_trans step1; rewrite -[`|d i|]normrN; apply: ler_norm_add.
  suff step2 : `|d j| + `|x i - x j| + `|d i| < eps.
    by apply: le_lt_trans step2; rewrite ler_add2r; apply: ler_norm_add.
  have -> : eps = eps / 3%:~R + eps / 3%:~R + eps / 3%:~R.
    rewrite /= in eps lt_eps_0 hmi hmj *.
    rewrite -!mulrDl -[in X in _ = X](mulr1 eps) -!mulrDr -mulrA.
    suff -> : (1 + 1 + 1) / 3%:~R = 1 :> F by rewrite mulr1.
    rewrite -[X in (X + X + X) / _ = _]/(1%:~R) -!rmorphD /= mulfV //.
    by rewrite intr_eq0.
  have heps : 0 < eps / 3%:~R by apply: divr_gt0 => //; rewrite ltr0z.
  apply: ltr_add => //; last exact: MP.
  apply: ltr_add=> //; first by exact: MP.
  by move=> {MP}; apply: mxP.
by close.
Qed.

End ExtraCreals.


(* Suppress some annoying warnings from Coq: *)
Set Warnings "-notation-overridden,-parsing".
Add LoadPath "lf/"
Require Import lists.

(* Polymorphic lists *)
Inductive list (X : Type) : Type :=
  | nil : list X
  | cons : X -> list X -> list X.

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_repeat_1:
  repeat nat 4 2 = cons nat 4 (cons nat 4 (nil nat)).

Proof.
  reflexivity. Qed.

Example test_repeat_2:
  repeat bool false 1 = cons bool false (nil bool).

Proof.
  reflexivity. Qed.

(* Exercise *)
Module MumbleGrumble.

Inductive mumble : Type :=
  | a : mumble
  | b : mumble -> nat -> mumble
  | c : mumble.

Inductive grumble (X : Type) : Type :=
  | d : mumble -> grumble X
  | e : X -> grumble X.

(* Check d (b a 5). *)
Check d mumble (b a 5).
Check d bool (b a 5).
Check e bool true.
Check e mumble (b c 0).
(* Check e bool (b c 0). *)
Check c.

(* Demonstrating type inference *)
Fixpoint repeat' X x count : list X :=
  match count with
    | 0 => nil X
    | S count' => cons X x (repeat' X x count')
  end.

(* and holes *)
Fixpoint repeat'' X x count : list X :=
  match count with
    | 0 => nil _
    | S count' => cons _ x (repeat'' _ x count')
  end.

(* and `Arguments` directive *)
Arguments nil {X}.
Arguments cons {X}.

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

Check repeat.
Check repeat'.
Check repeat''.
Check repeat'''.

(* Reimplementing some standard list functions on the new polymorphic lists *)
Fixpoint app {X : Type} (m n : list X) : list X :=
  match m with
    | nil => n
    | cons h t => cons h (app t n)
  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_rev_1:
  rev (cons 1 (cons 2 nil)) = (cons 2 (cons 1 nil)).

Proof.
  reflexivity. Qed.

Example test_rev_2:
  rev (cons true nil) = cons true nil.

Proof.
  reflexivity. Qed.

Example test_length_1:
  length (cons 1 (cons 2 (cons 3 nil))) = 3.

Proof.
  reflexivity. Qed.

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 *)
Theorem app_nil_r: forall (X : Type), forall l : list X,
  l ++ [] = l.

Proof.
  intros.
  induction l as [| k l' IHl' ].
  - 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.
  induction l as [| k l' IHl' ].
  - simpl. reflexivity.
  - simpl. rewrite <- IHl'. reflexivity.
  Qed.

Lemma app_length: forall (X : Type) (m n : list X),
  length (m ++ n) = length m + length n.

Proof.
  intros.
  induction m as [| l m' IHm' ].
  - simpl. reflexivity.
  - simpl. rewrite -> IHm'. reflexivity.
  Qed.

(* Exercise *)
Theorem rev_app_distr: forall X (m n : list X),
  rev (m ++ n) = rev n ++ rev m.

Proof.
  intros.
  induction m as [| k m' IHm' ].
  - simpl. rewrite -> app_nil_r. reflexivity.
  - simpl. rewrite -> IHm', app_assoc. reflexivity.
  Qed.

(* Exercise *)
Theorem rev_involutive: forall X : Type, forall l : list X,
  rev (rev l) = l.

Proof.
  intros.
  induction l as [| k l' IHl' ].
  - simpl. reflexivity.
  - simpl.
    rewrite -> rev_app_distr.
    simpl. rewrite IHl'.
    reflexivity.
  Qed.

(* Demonstrating polymorphic pairs *)
Inductive prod (X Y : Type) : Type :=
  | pair : X -> Y -> prod X 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 *)
Compute (combine [1;2] [false;false;true;true]).

(* Exercise *)
Fixpoint iter_fst {X Y : Type} (l : list (X * Y))
  : list X :=
  match l with
    | [] => nil
    | p :: t => cons (fst p) (iter_fst t)
  end.

Fixpoint iter_snd {X Y : Type} (l : list (X * Y))
  : list Y :=
  match l with
    | [] => nil
    | p :: t => cons (snd p) (iter_snd t)
  end.

Definition split {X Y : Type} (l : list (X * Y))
  : (list X) * (list Y) := (iter_fst l, iter_snd l).

Example test_split:
  split [(1,false);(2,false)] = ([1;2],[false;false]).

Proof.
  reflexivity. Qed.

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

Check @doit3times.
(* ===> doit3times : forall X : Type, (X -> X) -> X -> X *)
Example test_doit3times: doit3times negb true = false.
Proof. reflexivity. Qed.

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 even [1;2;3;4] = [2;4].
Proof. reflexivity. Qed.
Definition length_is_1 {X : Type} (l : list X) : bool :=
  beq_nat (length l) 1.
Example test_filter2:
    filter length_is_1
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity. Qed.

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

(* Demonstrating anonymous functions *)
Example test_anon_fun':
  doit3times (fun n => n * n) 2 = 256.

Proof.
  reflexivity. Qed.

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

Proof. reflexivity. Qed.

(* Exercise *)
Definition filter_even_gt7 (l : list nat) : list nat :=
  filter (fun x => bgt_nat x 7) (filter even l).

Compute filter_even_gt7  [1;2;6;9;10;3;12;8].

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.

Definition partition {X : Type}
                     (test : X -> bool)
                     (l : list X)
                   : list X * list X :=
  (filter test l, filter (fun x => negb (test x)) l).

Example test_partition1: partition odd [1;2;3;4;5] = ([1;3;5], [2;4]).

Proof.
  reflexivity. Qed.

Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).

Proof.
  reflexivity. Qed.

(* Map *)
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 odd [2;1;2;5] = [false;true;false;true].
Proof. reflexivity. Qed.

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

(* Exercise *)
Lemma map_app_distr:
  forall (X Y : Type) (f: X -> Y) (l: list X) (m: list X),
  map f (l ++ m) = (map f l) ++ (map f m).

Proof.
  intros.
  induction l as [| k l' IHl' ].
  - 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.
  induction l as [| k l' IHl' ].
  - simpl. reflexivity.
  - simpl.
    rewrite -> map_app_distr.
    simpl.
    rewrite -> IHl'.
    reflexivity.
  Qed.

(* Exercise *)
Fixpoint flat_map
  {X Y: Type} (f: X -> list Y) (l: list X)
  : (list Y) :=
  match l with
    | nil => nil
    | 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.

(* Demonstrating 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.

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.

End MumbleGrumble.


Require Import FunInd Arith Lia.

Inductive NETree (A : Type) : Type :=
    | T : A -> Forest A -> NETree A

with Forest (A : Type) : Type :=
    | E : Forest A
    | F : NETree A -> Forest A -> Forest A.

Arguments T {A} _ _.
Arguments E {A}.
Arguments F {A} _ _ .

Function auxT {A : Type} (t : NETree A) (k : nat) (acc : nat)
  : NETree (option nat) * nat :=
match t with
    | T _ f =>
        let
          '(f', acc') := auxF f k acc
        in
          if leb acc' k
          then (T (Some acc') f', S acc')
          else (T None f', acc')
end
with auxF {A : Type} (f : Forest A) (k : nat) (acc : nat)
  : Forest (option nat) * nat :=
match f with
    | E => (E, acc)
    | F t f' =>
        let
          '(t', acc') := auxT t k acc
        in let
          '(f'', acc'') := auxF f' k acc
        in
          (F t' f'', max acc' acc'')
end.

(** An algorithm that colors a tree so that at most k nodes in each
    path are colored. *)
Definition color {A : Type} (k : nat) (t : NETree A) : NETree (option nat) :=
  fst (auxT t k 1).

Definition wut :=
  T 1 (F (T 2 (F (T 5 E) E)) (F (T 3 E) (F (T 4 E) E))).

Lemma specT :
  forall (A : Type) (t : NETree A) (t' : NETree (option nat)) (k acc acc' : nat),
    acc <= k -> auxT t k acc = (t', acc') -> acc' <= S k

with specF :
  forall (A : Type) (f : Forest A) (f' : Forest (option nat))
  (k acc acc' : nat),
    acc <= k -> auxF f k acc = (f', acc') -> acc' <= S k.
Proof.
  destruct t; simpl; intros. case_eq (auxF f k acc); intros.
  case_eq (n <=? k); intro; rewrite H1, H2 in H0;
  inversion H0; subst; clear H0.
    apply leb_complete in H2. apply le_n_S. assumption.
    apply (specF A _ _ _ _ _ H H1).
  destruct f; simpl; intros; inversion H0; subst; clear H0.
    apply le_S. assumption.
    case_eq (auxT n k acc); intros; case_eq (auxF f k acc); intros.
      rewrite H0, H1 in H2. inversion H2; subst; clear H2.
        apply Nat.max_lub; [eapply specT | eapply specF]; eauto.
Qed.

Inductive elem {A : Type} (x : A) : NETree A -> Prop :=
    | elem0 :
        forall (y : A) (f : Forest A),
          x = y \/ elemF x f -> elem x (T y f)

with elemF {A : Type} (x : A) : Forest A -> Prop :=
    | elemF0 :
        forall (t : NETree A) (f : Forest A),
          elem x t \/ elemF x f -> elemF x (F t f).

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

Lemma auxT_spec2 :
  forall (A : Type) (x : option nat) (t : NETree A) (t' : NETree (option nat))
  (k acc acc' : nat),
    acc <= k -> auxT t k acc = (t', acc') -> elem x t' ->
      x = None \/ exists k' : nat, x = Some k' /\ k' <= k

with auxF_spec2 :
  forall (A : Type) (x : option nat) (f : Forest A) (f' : Forest (option nat))
  (k acc acc' : nat),
    acc <= k -> auxF f k acc = (f', acc') -> elemF x f' ->
      x = None \/ exists k' : nat, x = Some k' /\ k' <= k.
Proof.
  destruct t; simpl; intros.
  case_eq (auxF f k acc); intros. rewrite H2 in *.
  case_eq (n <=? k); intros; rewrite H3 in *; inv H0.
    inv H1. destruct H4.
      right. exists n. split; auto. apply leb_complete. assumption.
      eapply auxF_spec2; eauto.
    inv H1. destruct H4.
      left. assumption.
      eapply auxF_spec2; eauto.
  destruct f; simpl; intros; inv H0.
    inv H1.
    case_eq (auxT n k acc); intros; rewrite H0 in *.
    case_eq (auxF f k acc); intros; rewrite H2 in *.
      inv H3. inv H1. destruct H4.
        eapply auxT_spec2; eauto.
        eapply auxF_spec2; eauto.
Qed.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Eqdep_dec.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_list finite.

Set Implicit Arguments.

(* * First order operators and their semantics *)

Inductive fol_bop := fol_conj | fol_disj | fol_imp.
Inductive fol_qop := fol_ex | fol_fa.

Definition fol_bin_sem b :=
  match b with
    | fol_conj => and
    | fol_disj => or
    | fol_imp  => fun A B => A -> B
  end.

Fact fol_bin_sem_ext b A A' B B' :
     (A <-> A') -> (B <-> B') -> (fol_bin_sem b A B <-> fol_bin_sem b A' B').
Proof.
  intros E1 E2; destruct b; simpl; tauto.
Qed.

Fact fol_equiv_sem_ext A A' B B' : (A <-> A') -> (B <-> B') -> (A <-> B) <-> (A' <-> B').
Proof. tauto. Qed.

Fact fol_equiv_ext (P Q : Prop) : P = Q -> P <-> Q.
Proof. intros []; tauto. Qed.

Fact fol_equiv_impl A A' B B' : (A <-> A') -> (B <-> B') -> (A <-> B) -> (A' <-> B').
Proof. tauto. Qed.

Arguments fol_bin_sem b /.

Fact fol_bin_sem_dec b A B :
       { A } + { ~ A } -> { B } + { ~ B }
    -> { fol_bin_sem b A B } + { ~ fol_bin_sem b A B }.
Proof. revert b; intros [] HA HB; simpl; tauto. Qed.

Fact fol_equiv_dec A B :
       { A } + { ~ A } -> { B } + { ~ B }
    -> { A <-> B } + { ~ (A <-> B) }.
Proof. tauto. Qed.

Definition fol_quant_sem X q (P : X -> Prop) :=
  match q with
    | fol_ex => ex P
    | fol_fa => forall x, P x
  end.

Arguments fol_quant_sem X q P /.

Fact fol_quant_sem_ext X q (P Q : X -> Prop) :
        (forall x, P x <-> Q x)
      -> fol_quant_sem q P <-> fol_quant_sem q Q.
Proof.
  revert q; intros [] H; simpl.
  + split; intros (k & ?); exists k; apply H; auto.
  + split; intros ? k; apply H; auto.
Qed.

Notation forall_equiv := (@fol_quant_sem_ext _ fol_fa).
Notation exists_equiv := (@fol_quant_sem_ext _ fol_ex).

Tactic Notation "fol" "equiv" "fa" := apply forall_equiv.
Tactic Notation "fol" "equiv" "ex" := apply exists_equiv.
Tactic Notation "fol" "equiv" "iff" := apply fol_equiv_sem_ext.
Tactic Notation "fol" "equiv" "conj" := apply (fol_bin_sem_ext fol_conj).
Tactic Notation "fol" "equiv" "disj" := apply (fol_bin_sem_ext fol_disj).
Tactic Notation "fol" "equiv" "imp" := apply (fol_bin_sem_ext fol_imp).
Tactic Notation "fol" "equiv" "rel" := apply fol_equiv_ext; f_equal.

Tactic Notation "fol" "equiv" :=
  match goal with
    | |- (forall _, _) <-> (forall _, _) => fol equiv fa
    | |- (exists _, _) <-> (exists _, _) => fol equiv ex
    | |- ( _ <-> _) <-> (_ <-> _) => fol equiv iff
    | |- ( _ \/ _) <-> (_ \/ _) => fol equiv disj
    | |- ( _ /\ _) <-> (_ /\ _) => fol equiv conj
    | |- ( _ -> _) <-> (_ -> _) => fol equiv imp
    | |- ?r _ _ <-> ?r _ _ => fol equiv rel
  end.

Fact forall_list_sem_dec X (P : X -> Prop) (l : list X) :
       (forall x, { P x } + { ~ P x })
    -> { forall x, In x l -> P x } + { ~ forall x, In x l -> P x }.
Proof.
  intros H.
  destruct list_dec with (P := fun x => ~ P x) (Q := P) (l := l)
      as [ (x & H1 & H2) | H1 ].
  + firstorder.
  + right; contradict H2; auto.
  + left; intros x; apply H1; auto.
Qed.

Fact exists_list_sem_dec X (P : X -> Prop) (l : list X) :
       (forall x, { P x } + { ~ P x })
    -> { exists x, In x l /\ P x } + { ~ exists x, In x l /\ P x }.
Proof.
  intros H.
  destruct list_dec with (P := P) (Q := fun x => ~ P x) (l := l)
      as [ (x & H1 & H2) | H1 ]; auto.
  + left; firstorder.
  + right; intros (y & Hy).
    apply (H1 y); tauto.
Qed.

Fact fol_quant_sem_dec X q (P : X -> Prop) :
       finite_t X
    -> (forall x, { P x } + { ~ P x })
    -> { fol_quant_sem q P } + { ~ fol_quant_sem q P }.
Proof.
  intros (lX & HlX).
  revert q; intros [] H; simpl.
  + destruct exists_list_sem_dec with (l := lX) (1 := H); firstorder.
  + destruct forall_list_sem_dec with (l := lX) (1 := H); firstorder.
Qed.


Require Export D.

Theorem ev_sum_not : forall n m, ev n -> ~ ev m -> ~ ev (n + m).
Proof.
  exact FILL_IN_HERE.
Qed.


Require Export GeoCoq.Elements.OriginalProofs.proposition_05.
Require Export GeoCoq.Elements.OriginalProofs.lemma_equalanglesNC.
Require Export GeoCoq.Elements.OriginalProofs.lemma_supplements.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma proposition_05b :
   forall A B C F G,
   isosceles A B C -> BetS A B F -> BetS A C G ->
   CongA C B F B C G.
Proof.
intros.
assert (CongA A B C A C B) by (conclude proposition_05).
assert (eq C C) by (conclude cn_equalityreflexive).
assert (nCol A C B) by (conclude lemma_equalanglesNC).
assert (~ eq B C).
 {
 intro.
 assert (Col A B C) by (conclude_def Col ).
 assert (Col A C B) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (neq C B) by (conclude lemma_inequalitysymmetric).
assert (Out B C C) by (conclude lemma_ray4).
assert (Supp A B C C F) by (conclude_def Supp ).
assert (eq B B) by (conclude cn_equalityreflexive).
assert (Out C B B) by (conclude lemma_ray4).
assert (Supp A C B B G) by (conclude_def Supp ).
assert (CongA C B F B C G) by (conclude lemma_supplements).
close.
Qed.

End Euclid.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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


(** Adapted from "Elements of Set Theory" Chapter 2 **)
(** Coq coding by choukh, May 2020 **)

Require Export ZFC.Lib.Essential.

(*** EST第二章：补集，真子集，集合代数定律 ***)

(** 补集 **)
Definition Complement : set → set → set := λ A B, {x ∊ A | x ∉ B}.
Notation "A - B" := (Complement A B) : set_scope.

Lemma CompI : ∀ A B, ∀x ∈ A, x ∉ B → x ∈ A - B.
Proof. intros A B x Hx H. apply SepI. apply Hx. apply H. Qed.

Lemma CompE : ∀ A B, ∀x ∈ A - B, x ∈ A ∧ x ∉ B.
Proof. intros A B x Hx. apply SepE in Hx. apply Hx. Qed.

Lemma CompNE : ∀ A B x, x ∉ A - B → x ∉ A ∨ x ∈ B.
Proof.
  intros. destruct (classic (x ∈ B)).
  - right. apply H0.
  - left. intros H1. apply H. apply CompI; assumption.
Qed.

Lemma sub_iff_no_comp : ∀ A B, A ⊆ B ↔ A - B = ∅.
Proof.
  split; intros.
  - apply EmptyI. intros x Hx. apply CompE in Hx as [H1 H2].
    apply H2. apply H. apply H1.
  - intros x Hx. apply EmptyE with (A - B) x in H.
    destruct (classic (x ∈ B)). apply H0.
    exfalso. apply H. apply CompI; assumption.
Qed.

Lemma comp_sub : ∀ A B, A - B ⊆ A.
Proof.
  intros A B x Hx. apply CompE in Hx as []; auto.
Qed.
Global Hint Immediate comp_sub : core.

(* 空集的补集是原集合 *)
Lemma comp_empty : ∀ A, A - ∅ = A.
Proof with auto.
  intros. ext Hx.
  - apply SepE1 in Hx...
  - apply SepI... intros H. exfalso0.
Qed.

(* 空集里的补集是空集 *)
Lemma empty_comp : ∀ A, ∅ - A = ∅.
Proof with auto.
  intros. ext Hx.
  - apply SepE in Hx as []. exfalso0.
  - exfalso0.
Qed.

(* 集合加入自身的元素，集合不变 *)
Lemma add_no_member : ∀ A a, a ∈ A → A ∪ {a,} = A.
Proof with auto.
  intros * Ha. ext Hx.
  - apply BUnionE in Hx as []... apply SingE in H. subst...
  - apply BUnionI1...
Qed.

(* 集合除去非自身的元素，集合不变 *)
Lemma remove_no_member : ∀ A a, a ∉ A → A - {a,} = A.
Proof with auto.
  intros * Ha. ext Hx.
  - apply SepE1 in Hx...
  - apply SepI... apply SingNI. intros Heq.
    apply Ha. subst...
Qed.

(* 集合加入一个不是自身的元素再去掉，集合不变 *)
Lemma add_one_member_then_remove : ∀ A a, a ∉ A → (A ∪ {a,}) - {a,} = A.
Proof with auto.
  intros. ext Hx.
  - apply SepE in Hx as [].
    apply BUnionE in H0 as []... exfalso...
  - apply SepI. apply BUnionI1...
    apply SingNI. intros Heq. congruence.
Qed.

(* 集合除去自身的一个元素再放回去，集合不变 *)
Lemma remove_one_member_then_return : ∀ A a, a ∈ A → (A - {a,}) ∪ {a,} = A.
Proof with auto.
  intros. ext Hx.
  - apply BUnionE in Hx as [].
    + apply SepE1 in H0...
    + apply SingE in H0. subst...
  - destruct (classic (x = a)).
    + subst. apply BUnionI2...
    + apply BUnionI1. apply SepI... apply SingNI...
Qed.

(* 从集合中取出一个元素组成单集，它与取完元素后的集合的并等于原集合 *)
Corollary split_one_element : ∀ A a, a ∈ A → A = (A - {a,}) ∪ {a,}.
Proof. intros. symmetry. apply remove_one_member_then_return; auto. Qed.

(** 真子集 **)
Notation "A ⊂ B" := (A ⊆ B ∧ A ≠ B) (at level 70) : set_scope.

Lemma properSub_intro : ∀ A B, B ⊆ A → (∃ a, a ∈ A ∧ a ∉ B) → B ⊂ A.
Proof.
  intros A B Hsub [a [Ha Ha']].
  split. apply Hsub. intros Heq.
  apply Ha'. congruence.
Qed.

Lemma comp_nonempty : ∀ B A, B ⊂ A → ⦿ (A - B).
Proof.
  intros * [Hsub Hnq]. apply EmptyNE.
  intros H0. apply sub_iff_no_comp in H0.
  apply Hnq. apply sub_antisym. apply Hsub. apply H0.
Qed.

(* 并，交，补运算与子集关系构成集合代数，
  类似与自然数的加，乘，减运算与小于等于关系 *)

(** 集合代数定律 **)

(* 二元并交换律 *)
Lemma bunion_comm : ∀ A B, A ∪ B = B ∪ A.
Proof.
  intros. ext.
  - apply BUnionE in H. destruct H.
    + apply BUnionI2. apply H.
    + apply BUnionI1. apply H.
  - apply BUnionE in H. destruct H.
    + apply BUnionI2. apply H.
    + apply BUnionI1. apply H.
Qed.

(* 二元交交换律 *)
Lemma binter_comm : ∀ A B, A ∩ B = B ∩ A.
Proof.
  intros. ext.
  - apply BInterE in H as [H1 H2].
    apply BInterI. apply H2. apply H1.
  - apply BInterE in H as [H1 H2].
    apply BInterI. apply H2. apply H1.
Qed.

(* 二元并结合律 *)
Lemma bunion_assoc : ∀ A B C, A ∪ (B ∪ C) = (A ∪ B) ∪ C.
Proof.
  intros. ext.
  - apply BUnionE in H. destruct H.
    + apply BUnionI1. apply BUnionI1. apply H.
    + apply BUnionE in H. destruct H.
      * apply BUnionI1. apply BUnionI2. apply H.
      * apply BUnionI2. apply H.
  - apply BUnionE in H. destruct H.
    + apply BUnionE in H. destruct H.
      * apply BUnionI1. apply H.
      * apply BUnionI2. apply BUnionI1. apply H.
    + apply BUnionI2. apply BUnionI2. apply H.
Qed.

(* 二元交结合律 *)
Lemma binter_assoc : ∀ A B C, A ∩ (B ∩ C) = (A ∩ B) ∩ C.
Proof.
  intros. ext.
  - apply BInterE in H as [H1 H2].
    apply BInterE in H2 as [H2 H3].
    repeat apply BInterI; auto.
  - apply BInterE in H as [H1 H2].
    apply BInterE in H1 as [H0 H1].
    repeat apply BInterI; auto.
Qed.

(* 交并分配律 *)
Lemma binter_bunion_distr : ∀ A B C,
  A ∩ (B ∪ C) = (A ∩ B) ∪ (A ∩ C).
Proof.
  intros. ext.
  - apply BInterE in H as [H1 H2].
    apply BUnionE in H2. destruct H2.
    + apply BUnionI1. apply BInterI; auto.
    + apply BUnionI2. apply BInterI; auto.
  - apply BUnionE in H. destruct H.
    + apply BInterE in H as [H1 H2].
      apply BInterI. apply H1. apply BUnionI1. apply H2.
    + apply BInterE in H as [H1 H2].
      apply BInterI. apply H1. apply BUnionI2. apply H2.
Qed.

(* 并交分配律 *)
Lemma bunion_binter_distr : ∀ A B C,
  A ∪ (B ∩ C) = (A ∪ B) ∩ (A ∪ C).
Proof.
  intros. ext.
  - apply BUnionE in H. destruct H.
    + apply BInterI; apply BUnionI1; apply H.
    + apply BInterE in H as [H1 H2].
      apply BInterI; apply BUnionI2; auto.
  - apply BInterE in H as [H1 H2].
    apply BUnionE in H1. apply BUnionE in H2.
    destruct H1; destruct H2.
    + apply BUnionI1. apply H.
    + apply BUnionI1. apply H.
    + apply BUnionI1. apply H0.
    + apply BUnionI2. apply BInterI; auto.
Qed.

(* 二元并德摩根定律 *)
Lemma bunion_demorgen : ∀ A B x, x ∉ A ∪ B ↔ x ∉ A ∧ x ∉ B.
Proof.
  intros. split; intros.
  - split; intros.
    + intros HA. apply H. apply BUnionI1. apply HA.
    + intros HB. apply H. apply BUnionI2. apply HB.
  - destruct H as [H1 H2]. intros H.
    apply BUnionE in H. destruct H; auto.
Qed.

(* 并补对偶律 *)
Lemma bunion_comp : ∀ A B C, (A ∪ B) - C = (A - C) ∪ (B - C).
Proof.
  intros. ext.
  - apply CompE in H. destruct H as [H HC].
    apply BUnionE in H. destruct H.
    + apply BUnionI1. apply CompI. apply H. apply HC.
    + apply BUnionI2. apply CompI. apply H. apply HC.
  - apply BUnionE in H. destruct H.
    + apply CompE in H as [HA HC].
      apply CompI. apply BUnionI1. apply HA. apply HC.
    + apply CompE in H as [HB HC].
      apply CompI. apply BUnionI2. apply HB. apply HC.
Qed.

(* 补并对偶律 *)
Lemma comp_bunion : ∀ A B C, C - (A ∪ B) = (C - A) ∩ (C - B).
Proof.
  intros. ext.
  - apply CompE in H as [H1 H2].
    apply bunion_demorgen in H2. destruct H2 as [H2 H3].
    apply BInterI; apply CompI; auto.
  - apply BInterE in H as [H1 H2].
    apply CompE in H1 as [HC HA].
    apply CompE in H2 as [_ HB].
    apply CompI. apply HC. apply bunion_demorgen. auto.
Qed.

(* 二元交德摩根定律 *)
Lemma binter_demorgen : ∀ A B x, x ∉ A ∩ B ↔ x ∉ A ∨ x ∉ B.
Proof.
  intros. split; intros.
  - destruct (classic (x ∈ A)).
    + right. intros HB. apply H.
      apply BInterI; auto.
    + left. apply H0.
  - intros H0. destruct H.
    + apply H. apply BInterE in H0 as [H0 _]. apply H0.
    + apply H. apply BInterE in H0 as [_ H0]. apply H0.
Qed.

(* 交补结合律 *)
Lemma binter_comp : ∀ A B C, (A ∩ B) - C = A ∩ (B - C).
Proof with auto.
  intros. ext.
  - apply CompE in H as [H1 H2].
    apply BInterE in H1 as [H0 H1].
    apply BInterI... apply CompI...
  - apply BInterE in H as [H1 H2].
    apply CompE in H2 as [H2 H3].
    apply CompI... apply BInterI...
Qed.

(* 交补对偶律 *)
Lemma comp_binter : ∀ A B C, C - (A ∩ B) = (C - A) ∪ (C - B).
Proof.
  intros. ext.
  - apply CompE in H as [HC H].
    apply binter_demorgen in H. destruct H.
    + apply BUnionI1. apply CompI. apply HC. apply H.
    + apply BUnionI2. apply CompI. apply HC. apply H.
  - apply BUnionE in H. destruct H.
    + apply CompE in H as [HC HA].
      apply CompI. apply HC. apply binter_demorgen. left. apply HA.
    + apply CompE in H as [HC HB].
      apply CompI. apply HC. apply binter_demorgen. right. apply HB.
Qed.

(* 涉及空集的同一性 *)

Lemma bunion_empty : ∀ A, A ∪ ∅ = A.
Proof.
  intros. ext.
  - apply BUnionE in H. destruct H. apply H. exfalso0.
  - apply BUnionI1. apply H.
Qed.

Lemma binter_empty : ∀ A, A ∩ ∅ = ∅.
Proof.
  intros. apply EmptyI. intros x H.
  apply BInterE in H as [_ H]. exfalso0.
Qed.

(* 涉及全集的同一性 *)

Lemma bunion_parent : ∀ A S, A ⊆ S → A ∪ S = S.
Proof.
  intros. ext.
  - apply BUnionE in H0. destruct H0.
    + apply H in H0. apply H0.
    + apply H0.
  - apply BUnionI2. apply H0.
Qed.

Lemma binter_parent : ∀ A S, A ⊆ S → A ∩ S = A.
Proof.
  intros. ext.
  - apply BInterE in H0 as [H0 _]. apply H0.
  - apply BInterI. apply H0. apply H in H0. apply H0.
Qed.

Lemma bunion_comp_parent : ∀ A S, A ⊆ S → A ∪ (S - A) = S.
Proof.
  intros. ext.
  - apply BUnionE in H0. destruct H0.
    + apply H in H0. apply H0.
    + apply CompE in H0 as [H0 _]. apply H0.
  - destruct (classic (x ∈ A)).
    + apply BUnionI1. apply H1.
    + apply BUnionI2. apply CompI. apply H0. apply H1.
Qed.

Lemma binter_comp_empty : ∀ A S, A ∩ (S - A) = ∅.
Proof.
  intros. apply EmptyI. intros x H.
  apply BInterE in H as [H1 H2].
  apply CompE in H2. destruct H2 as [_ H2]. auto.
Qed.

(* 子集关系的单调性 *)

Lemma sub_mono_bunion : ∀ A B C, A ⊆ B → A ∪ C ⊆ B ∪ C.
Proof.
  intros. intros x Hx. apply BUnionE in Hx. destruct Hx.
  - apply H in H0. apply BUnionI1. apply H0.
  - apply BUnionI2. apply H0.
Qed.

Lemma sub_mono_binter : ∀ A B C, A ⊆ B → A ∩ C ⊆ B ∩ C.
Proof.
  intros. intros x Hx. apply BInterE in Hx as [H1 H2].
  apply H in H1. apply BInterI. apply H1. apply H2.
Qed.

Lemma sub_mono_union : ∀ A B, A ⊆ B → ⋃A ⊆ ⋃B.
Proof.
  intros. intros x Hx. apply UnionAx in Hx as [y [H1 H2]].
  eapply UnionI. apply H in H1. apply H1. apply H2.
Qed.

Lemma sub_mono_cprd : ∀ A B C, A ⊆ B → A × C ⊆ B × C.
Proof with auto.
  intros * H x Hx.
  apply CPrdE1 in Hx as [a [Ha [b [Hb Hx]]]].
  subst x. apply CPrdI...
Qed.

Lemma sub_mono_cprd' : ∀ A B C, A ⊆ B → C × A ⊆ C × B.
Proof with auto.
  intros * H x Hx.
  apply CPrdE1 in Hx as [a [Ha [b [Hb Hx]]]].
  subst x. apply CPrdI...
Qed.

(* 子集关系的反单调性 *)

Lemma sub_amono_comp : ∀ A B C, A ⊆ B → C - B ⊆ C - A.
Proof.
  intros. intros x Hx. apply CompE in Hx as [HC HB].
  apply CompI. apply HC. intros HA.
  apply HB. apply H. apply HA.
Qed.

Lemma sub_amono_inter : ∀ A B, ⦿ A → A ⊆ B → ⋂B ⊆ ⋃A.
Proof.
  intros. intros x Hx. apply InterE in Hx as [_ Hy].
  destruct H as [a Ha]. eapply UnionI. apply Ha.
  apply H0 in Ha. apply Hy in Ha. apply Ha.
Qed.

(* 二元并任意交分配律 *)
Lemma bunion_inter_distr : ∀ A ℬ,
  ⦿ ℬ → A ∪ ⋂ℬ = ⋂{A ∪ X | X ∊ ℬ}.
Proof.
  intros * Hi. ext.
  - apply InterI...
    + destruct Hi as [b Hb]. exists (A ∪ b).
      apply ReplAx... exists b. split; auto.
    + intros y Hy. apply ReplAx in Hy as [z [Hz Hu]]. subst y.
      apply BUnionE in H as [].
      * apply BUnionI1. apply H.
      * apply BUnionI2. apply InterE in H as [_ H].
        apply H. apply Hz.
  - destruct (classic (x ∈ A)) as [HA|HA].
    + apply BUnionI1. apply HA.
    + apply BUnionI2. apply InterI... apply Hi. intros b Hb.
      assert (Hu: A ∪ b ∈ {A ∪ X | X ∊ ℬ}). {
        apply ReplI. apply Hb.
      }
      apply InterE in H as [_ H]...
      apply H in Hu. apply BUnionE in Hu as [].
      * exfalso. apply HA. apply H0.
      * apply H0.
Qed.

(* 二元交任意并的分配律 *)
Lemma binter_union_distr : ∀ A ℬ,
  A ∩ ⋃ℬ = ⋃{A ∩ X | X ∊ ℬ}.
Proof.
  intros. ext.
  - apply BInterE in H as [HA Hu].
    apply UnionAx in Hu as [b [Hb1 Hb2]].
    eapply FUnionI.
    + apply Hb1.
    + apply BInterI; assumption.
  - apply FUnionE in H as [y [H1 H2]].
    apply BInterE in H2 as [H2 H3].
    apply BInterI. apply H2.
    eapply UnionI. apply H1. apply H3.
Qed.

(* 补并德摩根定律 *)
Lemma comp_union_demorgen : ∀ 𝒜 C,
  ⦿ 𝒜 → C - ⋃𝒜 = ⋂{C - X | X ∊ 𝒜}.
Proof.
  intros * [a Ha]. ext.
  - apply CompE in H as [HC HU]. apply InterI.
    + exists (C - a). apply ReplI. apply Ha.
    + intros y Hy. apply ReplAx in Hy as [b [Hb Hc]].
      rewrite <- Hc. apply CompI. apply HC. intros H.
      apply HU. eapply UnionI. apply Hb. apply H.
  - apply InterE in H as [_ H]. apply CompI.
    + assert (C - a ∈ {C - X | X ∊ 𝒜}). {
        apply ReplI. apply Ha.
      }
      apply H in H0. apply CompE in H0 as [HC _]. apply HC.
    + intros HU. apply UnionAx in HU as [b [Hb1 Hb2]].
      assert (C - b ∈ {C - X | X ∊ 𝒜}). {
        apply ReplI. apply Hb1.
      }
      apply H in H0. apply CompE in H0 as [_ Hb3]. auto.
Qed.

(* 经典引理：并非所有都否定，则存在肯定 *)
Lemma quantified_imply_to_and : ∀ (A : Type) (P Q : A → Prop),
  ¬ (∀ a, P a → Q a) → ∃ a, P a ∧ ¬ Q a.
Proof.
  intros.
  apply not_all_ex_not in H as [a H].
  apply imply_to_and in H.
  exists a. apply H.
Qed.

(* x不在𝒜的交集里，则存在𝒜的成员A，x不是A的成员 *)
Lemma not_in_inter_intro : ∀ 𝒜 x, ⦿ 𝒜 → x ∉ ⋂ 𝒜 → ∃A ∈ 𝒜, x ∉ A.
Proof.
  intros * Hi Hx. apply quantified_imply_to_and.
  intros H. apply Hx. apply InterI.
  apply Hi. intros y Hy. apply H. apply Hy.
Qed.

(* 补交德摩根定律 *)
Lemma comp_inter_demorgen : ∀ 𝒜 C,
  ⦿ 𝒜 → C - ⋂𝒜 = ⋃{C - X | X ∊ 𝒜}.
Proof.
  intros * Hi. ext.
  - apply CompE in H as [HC HU].
    apply (not_in_inter_intro _ _ Hi) in HU as [a [Ha1 Ha2]].
    eapply FUnionI. apply Ha1.
    apply CompI. apply HC. apply Ha2.
  - apply FUnionE in H as [y [Hy1 Hy2]].
    apply CompE in Hy2 as [HC Hy2].
    apply CompI. apply HC. intros HU.
    apply InterE in HU as [_ H].
    apply Hy2. apply H. apply Hy1.
Qed.

(* 替代二元并分配律 *)
Lemma repl_bunion_distr : ∀ F A B,
  {F x | x ∊ A ∪ B} = {F x | x ∊ A} ∪ {F x | x ∊ B}.
Proof with auto.
  intros. ext y H.
  - apply ReplAx in H as [x [Hx HFx]].
    apply BUnionE in Hx as [].
    + apply BUnionI1. apply ReplAx. exists x...
    + apply BUnionI2. apply ReplAx. exists x...
  - apply BUnionE in H as [];
    apply ReplAx in H as [x [Hx HFx]];
    apply ReplAx; exists x; split...
    apply BUnionI1... apply BUnionI2...
Qed.

(* 任意并二元并分配律 *)
Lemma union_bunion_distr : ∀ A B, ⋃ (A ∪ B) = ⋃ A ∪ ⋃ B.
Proof with auto.
  intros. ext y H.
  - apply UnionAx in H as [x [Hx HFx]].
    apply BUnionE in Hx as [].
    + apply BUnionI1. apply UnionAx. exists x...
    + apply BUnionI2. apply UnionAx. exists x...
  - apply BUnionE in H as [];
    apply UnionAx in H as [x [Hx HFx]];
    apply UnionAx; exists x; split...
    apply BUnionI1... apply BUnionI2...
Qed.


Require Import Reals Rpower Ranalysis Fourier.

Check MVT_cor1.
(* MVT_cor1 requires us to show that f is derivable, but we also need to
   reason about the derivative at the value c provided by the theorem.

   In order to do this eaisily, we want to use the lemmas
   derive_pt_plus, derive_pt_minus, etc..., but these lemmas
   require our proof of derivability to be constructed in a
   particular way.
*)

(* Two ways to build the proof of derivable so we can use the
   afformentioned lemmas:
    - Interactively => aux_const.
    - Manually => aux_const'.
*)
Lemma aux_const : derivable (fun x => (exp x - (1 +x))%R).
Proof.
  unfold derivable. intros x.
  apply derivable_pt_minus.
  apply derivable_pt_exp.
  apply derivable_pt_plus.
  apply derivable_pt_const.
  apply derivable_pt_id.
Defined. (* Later we'll need to reason about how this proof
            was built, so we end the proof with defined rather
            than Qed. *)

Definition aux_const' x : derivable_pt (fun x => (exp x - (1 +x))%R) x :=
  derivable_pt_minus exp (Rplus 1) x (derivable_pt_exp x)
    (derivable_pt_plus (fun _ : R => 1%R) id x (derivable_pt_const 1 x)
    (derivable_pt_id x)).

(* Really these are the same things, and we can prove it... *)
Lemma aux_eq : aux_const = aux_const'.
Proof.
  auto.
Qed.

(* Proof: If y < 0, then the derivative of this function at y is negative *)
Lemma aux_neg y (H :(y < 0)%R) :
  (derive (fun x => (exp x - (1 + x))%R) aux_const y < 0)%R.
Proof.
  unfold derive, aux_const.
  (* The rewritng here isn't as good as ssreflect's, so we need to
     apply the decomposition manually *)
  rewrite (derive_pt_minus (fun x => exp x) (fun x => (1 + x)%R)).
  rewrite derive_pt_exp.
  rewrite (derive_pt_plus (fun _ : R => 1) id).
  rewrite (derive_pt_const 1).
  rewrite (derive_pt_id).
  apply Rlt_minus.
  rewrite <- exp_0.
  rewrite Rplus_0_l.
  apply exp_increasing; exact H.
Qed.

(* Proof: If 0 <= y, then the derivative of this function at y is positive *)
Lemma aux_pos y (H :(0 <= y)%R) :
  (derive (fun x => (exp x - (1 + x))%R) aux_const y >= 0)%R.
Proof.
  unfold derive, aux_const.
  rewrite (derive_pt_minus (fun x => exp x) (fun x => (1 + x)%R)).
  rewrite derive_pt_exp.
  rewrite (derive_pt_plus (fun _ : R => 1) id).
  rewrite (derive_pt_const 1).
  rewrite (derive_pt_id).
  rewrite Rplus_0_l.
  apply Rge_minus.
  rewrite <- exp_0.
  destruct H.
  left. apply exp_increasing. auto.
  subst. fourier.
Qed.

(* We use the MVT + the above results to show that *)
Lemma ln_Taylor_upper' x : ((1 + x) <= exp x)%R.
Proof.
  apply Rge_le.
  apply Rminus_ge.
  set (f := fun x => (exp x - (1 + x))%R).
  assert (f x = exp x - (1 + x)%R) as H0.
    unfold f. auto.
  rewrite <- H0; clear H0.
  assert (f 0 = 0)%R as H0.
    unfold f. rewrite exp_0, Rplus_0_r.
    apply Rminus_diag_eq; auto.
  rewrite <- H0.
  case_eq (Rtotal_order x 0); intros H.
  {
    left. clear H1.
    apply (MVT_cor1 f x 0 aux_const) in H.
    destruct H as [c [H1 [H2 H3]]].
    rewrite H0, Rminus_0_l, Rminus_0_l in H1.
    rewrite H0.
    assert (x < 0)%R as H4. apply (Rlt_trans x c 0); auto.
    apply Ropp_eq_compat in H1.
    rewrite Ropp_involutive in H1.
    rewrite H1.
    apply Rlt_gt.
    rewrite Ropp_mult_distr_l.
    apply Rmult_lt_0_compat.
    apply Ropp_0_gt_lt_contravar.
    apply Rlt_gt.
    apply aux_neg; auto.
    fourier.
  }
  {
    destruct H as [H | H].
    { intros _; subst; right; auto. }
    intros _.
    apply (MVT_cor1 f 0 x aux_const) in H.
    destruct H as [c [H1 [H2 H3]]].
    rewrite H0, Rminus_0_r, Rminus_0_r in H1.
    rewrite H0.
    assert (0 <= x)%R as H4. fourier.
    rewrite H1.
    apply Rle_ge.
    rewrite <- (Rmult_0_l x).
    apply Rmult_le_compat; try fourier.
    apply Rge_le.
    apply aux_pos.
    left; auto.
  }
Qed.

Lemma ln_Taylor_upper x : (x < 1)%R ->  (ln (1 - x) <= -x)%R.
Proof.
  intros h.
  unfold ln.
  case_eq (Rlt_dec 0 (1-x)); intros h1 h2;
  last by apply False_rec; apply h1; fourier.
  unfold Rln; simpl.
  destruct (ln_exists (1 - x) h1) as [x0 e0].
  apply Rplus_le_reg_l with (r := 1%R).
  unfold Rminus in e0.
  rewrite e0.
  apply ln_Taylor_upper'.
Qed.