(* week-02_exercises.v *)
(* FPP 2020 - YSC3236 2020-2011, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of 23 Aug 2020 *)

(* ********** *)

(* Your name: Koo Zhengqun
   Your e-mail address: zhengqun.koo@u.nus.edu
   Your student number: A0164207L
 *)

(* Your name: Bobbie Soedirgo
   Your e-mail address: sram-b@comp.nus.edu.sg
   Your student number: A0181001A
 *)

(* Your name: Kuan Wei Heng
   Your e-mail address: kuanwh@u.nus.edu
   Your student number: A0121712X
 *)

(**
 %\title{Functional Programming in Coq}%
 %\author{Bobbie Soedirgo, Koo Zhengqun, Kuan Wei Heng}%
 %\date{\today}%
 %\maketitle%
 %\tableofcontents%
 %\newpage%
 *)

(** * Introduction

This assignment first introduces polymorphic datatypes, terms of those polymorphic datatypes, and polymorphic functions over those polymorphic datatypes.

Then, this assignment introduces polymorphic lambda types, and terms of those polymorphic lambda types.

Then, this assignment introduces polymorphic propositions, and proofs of those polymorphic propositions.

The sheer number of types and proofs in this assignment is significant, since they help students internalize Coq's and Gallina's syntax.

%\newpage%
 *)

(* begin hide *)
Require Import Arith Bool.
(* end hide *)

(* ********** *)

(** * Exercise 1 *)

(* definitions given *)

(* begin hide *)
Inductive polymorphic_binary_tree (V : Type) : Type :=
| PLeaf : V -> polymorphic_binary_tree V
| PNode : polymorphic_binary_tree V -> polymorphic_binary_tree V -> polymorphic_binary_tree V.

Fixpoint eqb_polymorphic_binary_tree (V : Type) (eqb_V : V -> V -> bool) (t1 t2 : polymorphic_binary_tree V) : bool :=
  match t1 with
  | PLeaf _ v1 =>
    match t2 with
    | PLeaf _ v2 =>
      eqb_V v1 v2
    | PNode _ t11 t12 =>
      false
    end
  | PNode _ t11 t12 =>
    match t2 with
    | PLeaf _ v2 =>
      false
    | PNode _ t21 t22 =>
      eqb_polymorphic_binary_tree V eqb_V t11 t21
      &&
      eqb_polymorphic_binary_tree V eqb_V t21 t22
    end
  end.

Definition eqb_binary_tree_of_nats (t1 t2 : polymorphic_binary_tree nat) : bool :=
  eqb_polymorphic_binary_tree nat beq_nat t1 t2.
(* end hide *)

(** ** a
Exhibit a Gallina expression of type [polymorphic_binary_tree (nat * bool)].

Answer:

 *)

Definition tree_nat_bool : polymorphic_binary_tree (nat * bool) :=
  PLeaf (nat * bool) (0, true).

(* begin hide *)
Check (tree_nat_bool : polymorphic_binary_tree (nat * bool)).
(* end hide *)

(** ** b
Exhibit a Gallina expression of type [polymorphic_binary_tree (polymorphic_binary_tree nat)].

Answer:

 *)

Definition tree_tree_nat : polymorphic_binary_tree (polymorphic_binary_tree nat) :=
  PLeaf _ (PLeaf _ 0).

(* begin hide *)
Check (tree_tree_nat : polymorphic_binary_tree (polymorphic_binary_tree nat)).
(* end hide *)

(* ********** *)

(** * Exercise 2 *)

(** ** a
To implement an equality function on binary trees of pairs of nats and bools, we can specialize the polymorphic function
[eqb_polymorphic_binary_tree]. This requires us to produce a witness function to test the equality of pairs of nats and bools.
Instead of constructing it directly, we will first write a more general form to test the equality of pairs
parameterized over the types of the car and cdr, then specialize it for [nat * bool] with the witnesses [beq_a] and [beq_b].
 *)

Definition beq_pair (A B : Type) (beq_a : A -> A -> bool) (beq_b : B -> B -> bool) (p1 p2 : A * B) : bool :=
  let (n1, b1) := p1 in
  let (n2, b2) := p2 in
  beq_a n1 n2 && beq_b b1 b2.

Definition eqb_binary_tree_of_nats_and_bools (t1 t2 : polymorphic_binary_tree (nat * bool)) : bool :=
  eqb_polymorphic_binary_tree (nat * bool) (beq_pair nat bool beq_nat eqb) t1 t2.

(** ** b
For binary trees of binary trees of natural numbers, no new definition is needed to construct the witness function.
 *)

Definition eqb_binary_tree_of_binary_trees_of_nats (t1 t2 : polymorphic_binary_tree (polymorphic_binary_tree nat)) : bool :=
  eqb_polymorphic_binary_tree (polymorphic_binary_tree nat) eqb_binary_tree_of_nats t1 t2.

(* ********** *)

(** * Exercises about types
As in Week 04 of Intro to CS, the accompanying file contains 14 types in need of a program that has this type. Conjure up these programs (aiming for the simplest ones you can think of).

Hint: all these programs only need to have the shape <<(fun ... => e)>>, where:
<<
e ::= tt | x | fun x => e | e e | (e, e) | match e with p => e
p ::= x | (p, p)
>>

Because types are never directly used to construct the program, for each type, we <<intro>> it but do not bind it to an identifier (we bind it to [_], which means we ignore it).

These exercises about types have a great similarity to the exercises about propositions. In fact, each of these numbered exercises (from [a] to [n]) correspond to the corresponding numbered exercises about propositions (from [a] to [n]). This allows us to apply insights from these exercises to the exercises about propositions, and vice versa. So let us start with the insights from these exercises.

Answer:

 *)

Definition ta : forall A : Type, A -> A * A :=
  fun _ a => (a, a).

Definition tb : forall A B : Type, A -> B -> A * B :=
  fun _ _ a b => (a, b).

Definition tc : forall A B : Type, A -> B -> B * A :=
  fun _ _ a b => (b, a).

Check (tt : unit).

Definition td : forall (A : Type), (unit -> A) -> A :=
  fun _ f => f tt.

Definition te : forall A B : Type, (A -> B) -> A -> B :=
  fun _ _ f a => f a.

Definition tf : forall A B : Type, A -> (A -> B) -> B :=
  fun _ _ a f => f a.

(**
We note that [tg] is [fun _ _ _ f a b => f a b]. From lambda calculus, we know that this is eta-equivalent to [fun _ _ _ f => f]. So, we know that [pg] can be proven by doing 4 <<intro>>s, then doing <<exact>> on the 4th <<intro>>ed term.

*)
Definition tg : forall A B C : Type, (A -> B -> C) -> A -> B -> C :=
  fun _ _ _ f a b => f a b.

(**
Keeping in mind that [->] associates to the right, we note when compared to [tg : (A -> B -> C) -> (A -> B -> C)], that the exercise [th : (A -> B -> C) -> (B -> A -> C)] is significant, because [th] tells us that despite what the type [(B -> A -> C)] says, we do not need to apply [B] first followed by [A]. This is especially evident in the way the terms are constructed: both [tg] and [th] construct the term as [f a b]. We shall see a more fundamental reason in the exercises about propositoins.

*)

Definition th : forall A B C : Type, (A -> B -> C) -> B -> A -> C :=
  fun _ _ _ f b a => f a b.

Definition ti : forall A B C D : Type, (A -> C) -> (B -> D) -> A -> B -> C * D :=
  fun _ _ _ _ f g a b => (f a, g b).

Definition tj : forall A B C : Type, (A -> B) -> (B -> C) -> A -> C :=
  fun _ _ _ f g a => g (f a).

Definition tk : forall A B : Type, A * B -> B * A :=
  fun _ _ ab => match ab with (a, b) => (b, a) end.

Definition tl : forall A B C : Type, (A * B -> C) -> A -> B -> C :=
  fun _ _ _ f a b => f (a, b).

Definition tm : forall A B C : Type, (A -> B -> C) -> A * B -> C :=
  fun _ _ _ f ab => match ab with (a, b) => f a b end.

(* NOTE: Is (A * B) * C equivalent to A * B * C? *)
Definition tn : forall A B C : Type, (A * (B * C)) -> (A * B) * C :=
  fun _ _ _ a_bc => match a_bc with (a, (b, c)) => ((a, b), c) end.

(* ********** *)

(** * Exercises about propositions
The accompanying file contains 14 propositions in need of a proof. Conjure up these proofs (aiming for the simplest ones you can think of).

Hint: all these proofs only need to use the following tactics:

<<
intro, intros
destruct
split
exact
apply
>>

Here, we write insights from these exercises that can be applied to the exercises about types.

Answer:

 *)

Proposition pa :
  forall A : Prop,
    A -> A * A.
Proof.
  intros A H_A.
  split.
  - exact H_A.
  - exact H_A.
Qed.

Proposition pb :
  forall A B : Prop,
    A -> B -> A * B.
Proof.
  intros A B H_A H_B.
  split.
  - exact H_A.
  - exact H_B.
Qed.

Proposition pc :
  forall A B : Prop,
    A -> B -> B * A.
Proof.
  intros A B H_A H_B.
  split.
  - exact H_B.
  - exact H_A.
Qed.

Check tt.

Proposition pd :
  forall (A : Prop),
    (unit -> A) -> A.
Proof.
  intros A H_f.
  exact (H_f tt).
Qed.

Proposition pe :
  forall A B : Prop,
    (A -> B) -> A -> B.
Proof.
  intros A B H_f H_A.
  exact (H_f H_A).
Qed.

Proposition pf :
  forall A B : Prop,
    A -> (A -> B) -> B.
Proof.
  intros A B H_A H_f.
  exact (H_f H_A).
Qed.

(**
In proving [pg], we apply the insight of eta-conversion to get a proof that uses less tactics (the <<intros>> tactic is counted as many <<intro>>s).

We note that it is possible to prove both [pg] and [ph] by using the <<intro>> tactic as many times as possible. Then, we note that the hypotheses of [pg] are exactly the same as the hypotheses of [ph] (up to bounded names). This strongly suggests that the two propositions are equivalent. Indeed, we notice that each use of the <<intro>> tactic, to introduce a term as a hypothesis, eliminates the left side of only one implication. This corresponds to partial application of the type function of some arity, whereby the aforementioned introduced term is fixed, producing a type function with smaller arity.

 *)

Proposition pg :
  forall A B C : Prop,
    (A -> B -> C) -> A -> B -> C.
Proof.
  intros A B C H_f H_A H_B.
  exact (H_f H_A H_B).

  Restart.

  intros A B C H_f.
  exact H_f.
Qed.

Proposition ph :
  forall A B C : Prop,
    (A -> B -> C) -> B -> A -> C.
Proof.
  intros A B C H_f H_B H_A.
  exact (H_f H_A H_B).
Qed.

Proposition pi :
  forall A B C D : Prop,
    (A -> C) -> (B -> D) -> A -> B -> C /\ D.
Proof.
  intros A B C D H_f H_g H_A H_B.
  split.
  - exact (H_f H_A).
  - exact (H_g H_B).
Qed.

Proposition pj :
  forall A B C : Prop,
    (A -> B) -> (B -> C) -> A -> C.
Proof.
  intros A B C H_f H_g H_A.
  exact (H_g (H_f H_A)).
Qed.

Proposition pk :
  forall A B : Prop,
    A /\ B -> B /\ A.
Proof.
  intros A B.
  intros [H_A H_B].
  split.
  - exact H_B.
  - exact H_A.
Qed.

Proposition pl :
  forall A B C : Prop,
    (A /\ B -> C) -> A -> B -> C.
Proof.
  intros A B C.
  intros H_A_and_B_imp_C H_A H_B.
  exact (H_A_and_B_imp_C (conj H_A H_B)).
Qed.

Proposition pm :
  forall A B C : Prop,
    (A -> B -> C) -> A /\ B -> C.
Proof.
  intros A B C.
  intros H_A_imp_B_imp_C [H_A H_B].
  apply H_A_imp_B_imp_C.
  exact H_A.
  exact H_B.
Qed.

Proposition pn :
  forall A B C : Prop,
    (A /\ (B /\ C)) -> (A /\ B) /\ C.
Proof.
  intros A B C.
  intros [H_A [H_B H_C]].
  exact (conj (conj H_A H_B) H_C).
Qed.

(*** week-01_fixpoints.ml *)
(* FPP 2020 - YSC3236 2020-2011, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of 20 Aug 2020, with an attuned definition of infinite_self_composition *)
(* was: *)
(* Version of 19 Aug 2020 *)
(* was: *)
(* Version of 18 Aug 2020 *)

(* ********** *)

(** <<
let rec infinite_self_composition s =
  fun v -> s (infinite_self_composition s) v;;
>> *)

(* ********** *)

(** * Exercise 8 of <<week-01_fixpoints.ml>> *)

(** <<
let test_fib candidate =
  (candidate 0 = 0) &&
  (candidate 1 = 1) &&
  (candidate 2 = 1) &&
  (candidate 3 = 2) &&
  (candidate 4 = 3) &&
  (candidate 5 = 5) &&
  (let n = Random.int 20
   in candidate n = (candidate (n - 1)) + (candidate (n - 2)))
  (* etc. *);;
>>

<<
let test_rev candidate =
  (candidate [] = []) &&
  (candidate [0] = [0]) &&
  (candidate [0; 1] = [1; 0]) &&
  (let vs = [0; 1; 2; 3; 4; 5]
   in candidate (candidate vs) = vs)
  (* etc. *);;
>>

<<
let test_concat candidate =
  (candidate [] [] = []) &&
  (candidate [0] [] = [0]) &&
  (candidate [] [0] = [0]) &&
  (candidate [0; 1; 2] [3; 4; 5] = [0; 1; 2; 3; 4; 5])
  (* etc. *);;
>>

<<
(* Fibonacci *)
let foo n =
  assert (n >= 0);
  infinite_self_composition (fun foo n ->
    if n = 0 then 0 else
    if n = 1 then 1 else
    foo (n - 1) + foo (n - 2)
    ) n;;

let () = assert (test_fib foo);;
>>

<<
(* Reverse list *)
let bar vs =
  infinite_self_composition (fun bar vs ->
    match vs with
    | [] -> []
    | v :: vs' -> bar vs' @ [v]
    ) vs;;

let () = assert (test_rev bar);;
>>

<<
(* Reverse list, but using cons ("::") instead of
the list concatenation operator ("@") *)
let baz vs =
  infinite_self_composition (fun baz vs a ->
    match vs with
    | [] -> a
    | v :: vs' -> baz vs' (v :: a)
    ) vs [];;

let () = assert (test_rev baz);;
>>

<<
(* List concatenation *)
let yip vs ws =
  infinite_self_composition (fun yip vs ws ->
    match vs with
    | [] -> ws
    | v :: vs' -> v :: yip vs' ws
    ) vs ws;;

let () = assert (test_concat yip);;
>>

<<
(* Bonus: Reverse list, but with yip *)
let quux vs =
  infinite_self_composition (fun quux vs ->
    match vs with
    | [] -> []
    | v :: vs' -> yip (quux vs') [v]
    ) vs;;

let () = assert (test_rev quux);;
>> *)

(* ********** *)

(* end of week-01_fixpoints.ml *)

(** * Exercise 12
Prove that disjunction distributes over conjunction on the left and right.

 *)

(** ** Distributes on the left: Given incomplete proof
Prove that disjunction distributes over conjunction on the left.

 *)

Proposition disjunction_distributes_over_conjunction_on_the_left :
  forall A B C : Prop,
    A \/ (B /\ C) <-> (A \/ B) /\ (A \/ C).
Proof.
  intros A B C.
  split.

  - intros [H_A | [H_B H_C]].

    + split.

      * left.
        exact H_A.

      * left.
        exact H_A.

    + split.

      * right.
        exact H_B.

      * right.
        exact H_C.

(** ** Distributes on the left: Completed proof
Prove that disjunction distributes over conjunction on the left.

 *)

  - intros [[H_A | H_B] [H_A' | H_C]].
    + left. exact H_A.
    + left. exact H_A.
    + left. exact H_A'.
    + right.
      exact (conj H_B H_C).
Qed.

(** ** Distributes on the right
Prove that disjunction distributes over conjunction on the right.

 *)

Proposition disjunction_distributes_over_conjunction_on_the_right :
  forall A B C : Prop,
    (B /\ C) \/ A <-> (B \/ A) /\ (C \/ A).
Proof.
  intros A B C.
  split.
  - intros [[H_B H_C] | H_A].
    + split.
      * left. exact H_B.
      * left. exact H_C.
    + split.
      * right. exact H_A.
      * right. exact H_A.
  - intros [[H_B | H_A] [H_C | H_A']].
    + left. exact (conj H_B H_C).
    + right. exact H_A'.
    + right. exact H_A.
    + right. exact H_A.
Qed.

(** * Exercise 13
Prove that conjunction distributes over disjunction on the left and on the right.

 *)

Proposition conjunction_distributes_over_disjunction_on_the_left :
  forall A B C : Prop,
    A /\ (B \/ C) <-> (A /\ B) \/ (A /\ C).
Proof.
  intros A B C.
  split.
  - intros [H_A [H_B | H_C]].
    + left. exact (conj H_A H_B).
    + right. exact (conj H_A H_C).
  - intros [[H_A H_B] | [H_A H_C]].
    + split.
      * exact H_A.
      * left. exact H_B.
    + split.
      * exact H_A.
      * right. exact H_C.
Qed.

Proposition conjunction_distributes_over_disjunction_on_the_right :
  forall A B C : Prop,
    (A \/ B) /\ C <-> (A /\ C) \/ (B /\ C).
Proof.
  intros A B C.
  split.
  - intros [[H_A | H_B] H_C].
    + left. exact (conj H_A H_C).
    + right. exact (conj H_B H_C).
  - intros [[H_A H_C] | [H_B H_C']].
    + split.
      * left. exact H_A.
      * exact H_C.
    + split.
      * right. exact H_B.
      * exact H_C'.
Qed.

(* ********** *)

(** * Conclusion
By the Curry-Howard correspondence, proofs are terms, and propositions are types.

Polymorphism is a significant constraint in this assignment. Because of polymorphism, a term cannot know which of the possible types it is building up to, as in %\href{http://ecee.colorado.edu/ecen5533/fall11/reading/free.pdf}{Wadler}%, which says:
"Say that [r] is a function of type $r : \forall X. X^* \rightarrow X^*$. Here [X] is a type variable, and $X^*$ is the type “list of [X]”. [r] must work on lists of [X] for any type [X]. Since [r] is provided with no operations on values of type [X], all it can do is rearrange such lists, independent of the values contained in them."

Concretely, there is only one solution to exercise [tk]. But if one considers integer-specific types, then alternative solutions are allowed, such as this:

 *)

(* begin hide *)
Require Import BinInt.
Include BinIntDef.Z.
(* end hide *)

Definition tk_int (p : Z * Z) : (Z * Z) :=
  match p with (a, b) =>
               let a := Z.sub b a in
               let b := Z.sub b a in
               let a := Z.add a b in
               (a, b)
  end.

(**
We can write unit tests after defining equality on pairs of integers.

 *)

Definition beq_int_pair (p q : Z * Z) : bool :=
  match p with (a, b) =>
               match q with (c, d) =>
                            eqb a c && eqb b d
               end
  end.

Notation "A =zp= B" :=
  (beq_int_pair A B) (at level 70, right associativity).

Definition test_tk (candidate : (Z * Z) -> (Z * Z)) : bool :=
  ((candidate (Z0,succ Z0)) =zp= (succ Z0,Z0)) &&
  ((candidate (succ Z0,Z0)) =zp= (Z0,succ Z0)) &&
  ((candidate (Z0,succ (succ Z0))) =zp= (succ (succ Z0),Z0)) &&
  ((candidate (succ (succ Z0),Z0)) =zp= (Z0,succ (succ Z0))).

(**
Both the polymorphic [tk] and non-polymorphic [tk_int] pass the unit tests.

 *)

Compute test_tk (tk Z Z).
Compute test_tk tk_int.

(**
As we have seen, only a small amount of term-building operators can be used to manipulate terms that belong to a polymorphic type, because polymorphic types contain less information. For example, we cannot construct [tk] with [tk_int], because the polymorphic type may not be of type int. We do not know which type the polymorphic type is.

Correspondingly, only a small amount of Coq tactics can be used to construct a proof that has only polymorphic types in its assumption.

 *)

(* end of week-02_exercises.v *)


From Equations Require Import Equations.
From Coq Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import ssrnat eqtype seq path order bigop prime.
From favssr Require Import prelude.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import Order.POrderTheory.
Import Order.TotalTheory.
Open Scope order_scope.

Section InsertionSort.
Context {disp : unit} {T : orderType disp}.
Implicit Types (xs ys : seq T).

(* Definition *)

Fixpoint insort x xs :=
  if xs is y :: xs' then
    if x <= y then x :: y :: xs' else y :: insort x xs'
    else [:: x].

Fixpoint isort xs :=
  if xs is x :: xs' then insort x (isort xs') else [::].

(* Functional Correctness *)

Lemma perm_insort x xs : perm_eq (insort x xs) (x :: xs).
Proof.
elim: xs=>//= y xs IH; case: (_ <= _)=>//.
rewrite -(perm_cons y) in IH.
apply: perm_trans; first by exact: IH.
by apply/permP=>/=?; rewrite addnCA.
Qed.

Lemma perm_isort xs : perm_eq (isort xs) xs.
Proof.
elim: xs=>//= x xs IH.
apply: perm_trans; first by apply: perm_insort.
by rewrite perm_cons.
Qed.

Lemma sorted_insort a xs : sorted <=%O (insort a xs) = sorted <=%O xs.
Proof.
elim: xs=>//= x xs IH.
case H: (_ <= _)=>/=; first by rewrite H.
rewrite !le_path_sortedE (perm_all _ (perm_insort _ _)) /= IH.
suff: x <= a by move=>->.
by rewrite leNgt lt_neqAle H andbF.
Qed.

Lemma sorted_isort xs : sorted <=%O (isort xs).
Proof. by elim: xs=>//= x xs; rewrite sorted_insort. Qed.

(* Time complexity *)

Fixpoint T_insort x xs : nat :=
  if xs is y :: xs' then
    (if x <= y then 0 else T_insort x xs').+1
    else 1.

Fixpoint T_isort xs : nat :=
  if xs is x :: xs' then (T_isort xs' + T_insort x (isort xs')).+1 else 1.

Lemma T_insort_size x xs : T_insort x xs <= (size xs).+1.
Proof.
elim: xs=>//=y xs IH.
by case: (x <= y).
Qed.

(* This seems to be unused *)
Lemma size_insort x xs : size (insort x xs) = (size xs).+1.
Proof. by move/perm_size: (perm_insort x xs). Qed.

Lemma size_isort xs : size (isort xs) = size xs.
Proof. by move/perm_size: (perm_isort xs). Qed.

Lemma T_isort_size xs : T_isort xs <= (size xs).+1 ^ 2.
Proof.
elim: xs=>// x xs IH.
rewrite -addn1 sqrnD /= -addn1 -!addnA.
apply: leq_add=>//; rewrite exp1n muln1 addnC leq_add2l.
apply: leq_trans; first by exact: T_insort_size.
by rewrite size_isort; apply: leq_pmull.
Qed.

(* Exercise 2.1 *)

Lemma isort_beh (f : seq T -> seq T) xs :
  perm_eq (f xs) xs -> sorted <=%O (f xs) -> f xs = isort xs.
Proof.
Admitted.

(* Exercise 2.2.1 *)

Lemma T_isort_optimal xs : sorted <=%O xs -> T_isort xs = (2 * size xs).+1.
Proof.
Admitted.

End InsertionSort.

Section InsertionSortNat.

(* uphalf_addn from prelude might come in handy here *)
(* Exercise 2.2.2 *)
Lemma T_isort_worst n : T_isort (rev (iota 0 n)) = uphalf ((n.+1)*(n.+2)).
Proof.
Admitted.

End InsertionSortNat.

Section QuickSort.
Context {disp : unit} {T : orderType disp}.
Implicit Types (xs ys : seq T).

(* Definition *)

Equations? quicksort xs : seq T by wf (size xs) lt :=
quicksort [::]    => [::];
quicksort (x::xs) => quicksort (filter (< x) xs) ++ [:: x] ++
                     quicksort (filter (>= x) xs).
Proof. all: by rewrite size_filter /=; apply/ssrnat.ltP/count_size. Qed.

(* Functional Correctness *)

Lemma perm_quicksort xs : perm_eq (quicksort xs) xs.
Proof.
apply_funelim (quicksort xs)=>//=x {}xs Hl Hg.
rewrite perm_catC cat_cons perm_cons perm_sym -(perm_filterC (>= x)) perm_sym.
apply: perm_cat=>//.
rewrite (eq_in_filter (a2 := < x)) //= =>y _.
by rewrite ltNge.
Qed.

Lemma sorted_quicksort xs : sorted <=%O (quicksort xs).
Proof.
apply_funelim (quicksort xs)=>//= x {}xs Hl Hg.
have Hx : sorted <=%O [:: x] by [].
move: (merge_sorted le_total Hx Hg)=>{Hx}/=.
rewrite allrel_merge; last first.
- by rewrite allrel1l (perm_all _ (perm_quicksort _)) filter_all.
move/(merge_sorted le_total Hl); rewrite allrel_merge //=.
apply/allrelP=>y z.
rewrite (perm_mem (perm_quicksort _) y) inE
  (perm_mem (perm_quicksort _) z) !mem_filter /=.
case/andP=>Hy _; case/orP=>[/eqP ->|/andP [Hz _]];
rewrite le_eqVlt; apply/orP; right=>//.
by apply/lt_le_trans/Hz.
Qed.

(* Exercise 2.3 *)

Equations? quicksort2 xs ys : seq T by wf (size xs) lt :=
quicksort2 xs ys => ys. (* FIXME *)
Proof.
Qed.

Lemma quick2_quick xs ys : quicksort2 xs ys = quicksort xs ++ ys.
Proof.
Admitted.

(* Exercise 2.4 *)

(* TODO rewrite in one pass? *)
Definition partition3 x xs : seq T * seq T * seq T :=
  (filter (< x) xs, filter (pred1 x) xs, filter (> x) xs).

Equations? quicksort3 xs : seq T by wf (size xs) lt :=
quicksort3 [::]    => [::];
quicksort3 (x::xs) with inspect (partition3 x xs) => {
  | (ls, es, gs) eqn: eq => quicksort3 ls ++ x :: es ++ quicksort3 gs
}.
Proof. all: by apply/ssrnat.ltP; rewrite size_filter; apply: count_size. Qed.

(* this is the main part *)
Lemma quick_filter_ge x xs :
  quicksort (filter (>= x) xs) = filter (pred1 x) xs ++ quicksort (filter (> x) xs).
Proof.
Admitted.

Lemma quick3_quick xs : quicksort3 xs = quicksort xs.
Proof.
Admitted.

(* Exercise 2.5.1 *)

(* TODO move to basics? *)
Fixpoint T_mapfilter {A} (ta : A -> nat) (s : seq A) : nat :=
  if s is x :: s' then ta x + T_mapfilter ta s' + 1 else 1.

Lemma T_mapfilter_size {A} (xs : seq A) ta :
  T_mapfilter ta xs = \sum_(x<-xs) (ta x) + size xs + 1.
Proof.
elim: xs=>/=; first by rewrite big_nil.
by move=>x xs ->; rewrite big_cons -(addn1 (size _)) !addnA.
Qed.

Equations? T_quicksort xs : nat by wf (size xs) lt :=
T_quicksort [::]    => 1;
T_quicksort (x::xs) => T_quicksort (filter (< x) xs) +
                       T_quicksort (filter (>= x) xs) +
                       2 * T_mapfilter (fun => 1%N) xs + 1.
Proof. all: by apply/ssrnat.ltP; rewrite size_filter; apply: count_size. Qed.

(* FIXME replace these with concrete numbers *)
Parameters (a b c : nat).

Lemma quicksort_quadratic xs :
  sorted <=%O xs -> T_quicksort xs = a * size xs ^ 2 + b * size xs + c.
Proof.
Admitted.

(* Exercise 2.5.2 *)

Lemma quicksort_worst xs :
  T_quicksort xs <= a * size xs ^ 2 + b * size xs + c.
Proof.
Admitted.

End QuickSort.

Section TopDownMergeSort.
Context {disp : unit} {T : orderType disp}.
Implicit Types (xs ys : seq T).

(* reusing `merge` from mathcomp.path *)

Equations? msort xs : seq T by wf (size xs) lt :=
msort [::]  => [::];
msort [::x] => [::x];
msort xs    => let n := size xs in
               merge <=%O (msort (take n./2 xs))
                          (msort (drop n./2 xs)).
Proof.
all: apply/ssrnat.ltP.
- by rewrite size_take /= !ltnS !half_le.
by rewrite size_drop /= /leq subSS subnAC subnn.
Qed.

(* Functional Correctness *)

Lemma perm_msort xs : perm_eq (msort xs) xs.
Proof.
funelim (msort xs)=>//=.
rewrite perm_merge -{3}(cat_take_drop (size l)./2 (s0::l)) -cat_cons.
by apply: perm_cat.
Qed.

Lemma sorted_msort xs : sorted <=%O (msort xs).
Proof. by funelim (msort xs)=>//=; apply: merge_sorted. Qed.

(* Running Time Analysis *)

Fixpoint C_merge xs :=
  if xs is x :: xs' then
    let fix C_merge_xs ys :=
      if ys is y :: ys' then
        (if x <= y then C_merge xs' ys else C_merge_xs ys').+1
      else 0 in
    C_merge_xs
  else fun => 0.

Equations? C_msort xs : nat by wf (size xs) lt :=
C_msort [::]  => 0;
C_msort [::x] => 0;
C_msort xs    => let n := (size xs) in
                 let ys := take n./2 xs in
                 let zs := drop n./2 xs in
                 C_msort ys + C_msort zs + C_merge (msort ys) (msort zs).
Proof.
all: apply/ssrnat.ltP.
- by rewrite size_take /= !ltnS !half_le.
by rewrite size_drop /= /leq subSS subnAC subnn.
Qed.

Lemma C_merge_leq xs ys : (C_merge xs ys <= size xs + size ys)%N.
Proof.
elim: xs ys=>//= x xs IH1; elim=>//= y ys IH2.
case: ifP=>_.
- rewrite -addn1 -!(addn1 (size _)) addnA leq_add2r addnAC.
  apply: leq_trans; first by apply: IH1.
  by rewrite addn1 addnS.
by rewrite addnS ltnS; apply: IH2.
Qed.

Lemma C_msort_leq xs k: size xs = 2^k -> (C_msort xs <= k * 2^k)%N.
Proof.
elim: k xs=>/=.
- by move=>xs; rewrite expn0 =>/size1 [x] ->; simp C_msort.
move=>k IH xs H.
have Hs1 : (size xs > 1)%N by rewrite H -{1}(expn0 2); apply: ltn_exp2l.
case: (size2 Hs1)=> x[y][ys] He; rewrite He /= in H *; simp C_msort=>/=.
have Hp : (size ys)./2.+1 = ((size ys).+2)./2 by rewrite -addn2 halfD andbF /= addn1.
have Ht : size (x :: take (size ys)./2 (y :: ys)) = 2^k.
- by rewrite /= size_take /= ltnS half_le Hp H expnS mul2n half_double.
have Hd : size (drop (size ys)./2 (y :: ys)) = 2^k.
- rewrite size_drop /= subSn; last by apply: half_le.
  by rewrite half_subn uphalf_half -addnS Hp H expnS mul2n half_double odd2 H oddX.
apply: leq_trans;
  first by exact: (leq_add (leq_add (IH _ Ht) (IH _ Hd)) (C_merge_leq _ _)).
rewrite !(perm_size (perm_msort _)) Ht Hd.
by rewrite !addnn -!muln2 -mulnA -!expnSr -{3}(addn1 k) mulnDl mul1n.
Qed.

(* Exercise 2.6 *)

Fixpoint halve {A: Type} (xs ys zs : seq A) : seq A * seq A :=
  ([::],[::]). (* FIXME *)

Equations? msort2 xs : seq T by wf (size xs) lt :=
msort2 [::]  => [::];
msort2 [::x] => [::x];
msort2 xs with inspect (halve xs [::] [::]) := {
  | (ys1, ys2) eqn: eq => merge <=%O (msort2 ys1) (msort2 ys2)
}.
Proof.
all: apply/ssrnat.ltP.
(* FIXME *)
- by [].
by [].
Qed.

Lemma perm_msort2 xs : perm_eq (msort2 xs) xs.
Proof.
Admitted.

Lemma sorted_msort2 xs : sorted <=%O (msort2 xs).
Proof.
Admitted.

End TopDownMergeSort.

Section BottomUpMergeSort.
Context {disp : unit} {T : orderType disp}.
Implicit Types (xs ys : seq T).

Equations merge_adj : seq (seq T) -> seq (seq T) :=
merge_adj [::]          => [::];
merge_adj [::xs]        => [::xs];
merge_adj (xs::ys::zss) => merge <=%O xs ys :: merge_adj zss.

Lemma size_merge_adj xss : size (merge_adj xss) = uphalf (size xss).
Proof. by funelim (merge_adj xss)=>//=; congr S. Qed.

Equations? merge_all (xss : seq (seq T)) : seq T by wf (size xss) lt :=
merge_all [::]   => [::];
merge_all [::xs] => xs;
merge_all xss    => merge_all (merge_adj xss).
Proof. by apply/ssrnat.ltP; rewrite size_merge_adj /= !ltnS; apply: uphalf_le. Qed.

Definition msort_bu xs : seq T :=
  merge_all (map (fun x => [::x]) xs).

(* Functional Correctness *)

Lemma perm_merge_adj xss : perm_eq (flatten (merge_adj xss)) (flatten xss).
Proof.
funelim (merge_adj xss)=>//=.
rewrite catA; apply: perm_cat=>//.
by rewrite perm_merge.
Qed.

Lemma perm_merge_all xss : perm_eq (merge_all xss) (flatten xss).
Proof.
funelim (merge_all xss)=>//=; first by rewrite cats0.
by apply/(perm_trans H)/perm_merge_adj.
Qed.

Lemma perm_msort_bu xs : perm_eq (msort_bu xs) xs.
Proof.
rewrite /msort_bu; apply: (perm_trans (perm_merge_all _)).
by rewrite flatten_map1 map_id.
Qed.

Lemma sorted_merge_adj xss :
  all (sorted <=%O) xss -> all (sorted <=%O) (merge_adj xss).
Proof.
funelim (merge_adj xss)=>//= /and3P [Hs1 Hs2] /H ->; rewrite andbT.
by apply: merge_sorted.
Qed.

Lemma sorted_merge_all xss :
  all (sorted <=%O) xss -> sorted <=%O (merge_all xss).
Proof.
funelim (merge_all xss)=>//=; first by rewrite andbT.
move: H; simp merge_adj=>/= H.
case/and3P=>Hs1 Hs2 Hs; apply/H/andP.
by split; [apply: merge_sorted | apply: sorted_merge_adj].
Qed.

Lemma sorted_msort_bu xs : sorted <=%O (msort_bu xs).
Proof.
rewrite /msort_bu; apply: sorted_merge_all; rewrite all_map.
by elim: xs.
Qed.

(* Running Time Analysis *)

Equations C_merge_adj : seq (seq T) -> nat :=
C_merge_adj [::]          => 0;
C_merge_adj [::xs]        => 0;
C_merge_adj (xs::ys::zss) => C_merge xs ys + C_merge_adj zss.

Equations? C_merge_all (xss : seq (seq T)) : nat by wf (size xss) lt :=
C_merge_all [::]   => 0;
C_merge_all [::xs] => 0;
C_merge_all xss    => C_merge_adj xss + C_merge_all (merge_adj xss).
Proof. by apply/ssrnat.ltP; rewrite size_merge_adj /= !ltnS; apply: uphalf_le. Qed.

Definition C_msort_bu xs : nat :=
  C_merge_all (map (fun x => [::x]) xs).

Lemma merge_adj_sizes xss m :
  ~~ odd (size xss) -> all (fun xs => size xs == m) xss ->
  all (fun xs => size xs == m.*2) (merge_adj xss).
Proof.
funelim (merge_adj xss)=>//=; rewrite negbK=>Ho /and3P [/eqP Hx /eqP Hy Ha]; apply/andP.
split; last by rewrite (H _ Ho Ha).
by rewrite size_merge size_cat Hx Hy addnn.
Qed.

Lemma C_merge_adj_leq xss m :
  all (fun xs => size xs == m) xss -> C_merge_adj xss <= m * size xss.
Proof.
funelim (C_merge_adj xss)=>//= /and3P [/eqP Hx /eqP Hy Ha].
rewrite -add2n mulnDr muln2 -addnn; apply/leq_add/H=>//.
by rewrite -{1}Hx -Hy; apply: C_merge_leq.
Qed.

Lemma C_merge_all_leq xss m k :
  all (fun xs => size xs == m) xss -> size xss = 2 ^ k ->
  C_merge_all xss <= m * k * 2^k.
Proof.
funelim (C_merge_all xss)=>//= /and3P [/eqP Hx /eqP Hy Ha] Hs.
move: H; simp merge_adj C_merge_adj=>/= H. (* slow for some reason *)
have [k0 Hk] : { k0 | k = k0.+1 } by move: Hs; case: k=>//=k0 _; exists k0.
have He : ~~ odd (size l1) by rewrite odd2 Hs oddX Hk.
rewrite Hk expnS mulnS mulnDl in Hs *; apply: leq_add.
- rewrite -Hs -addn2 mulnDr addnC.
  apply: leq_add; first by apply: C_merge_adj_leq.
  by rewrite muln2 -addnn -{1}Hx -Hy; apply: C_merge_leq.
rewrite mulnCA !mulnA mul2n; apply: H.
- apply/andP; split; last by apply: merge_adj_sizes.
  by rewrite size_merge size_cat Hx Hy addnn.
apply/eqP; rewrite size_merge_adj -addn1 -(eqn_pmul2r (m:=2)) // mulnDl muln2.
have -> : (uphalf (size l1)).*2 = size l1
  by rewrite -[in RHS](odd_double_half (size l1)) uphalf_half (negbTE He).
by rewrite addn2 mulnC Hs.
Qed.

Lemma C_msort_bu_leq xs k : size xs = 2^k -> C_msort_bu xs <= k * 2^k.
Proof.
move=>H; rewrite -(mul1n (_ * _)) mulnA; apply: C_merge_all_leq.
- by rewrite all_map; elim: {H}xs.
by rewrite size_map.
Qed.

End BottomUpMergeSort.

Section NaturalMergeSort.
Context {disp : unit} {T : orderType disp}.
Implicit Types (xs ys : seq T) (xss : seq (seq T)).

Fixpoint runs_fix a xs : seq (seq T) :=
  if xs is b::bs
    then if b < a then desc b [:: a] bs else asc b (cons a) bs
    else [::[::a]]
with asc x (xd : seq T -> seq T) ys : seq (seq T) :=
  if ys is y::ys'
    then if x <= y then asc y (xd \o cons x) ys' else xd [::x] :: runs_fix y ys'
    else [:: xd [::x]]
with desc x xs ys : seq (seq T) :=
  if ys is y::ys'
     then if y < x then desc y (x :: xs) ys' else (x :: xs) :: runs_fix y ys'
     else [:: (x :: xs)].

Definition runs xs : seq (seq T) :=
  if xs is x::xs' then runs_fix x xs' else [::].

Definition nmsort xs := merge_all (runs xs).

(* Functional Correctness *)

Definition is_dlist (xd : seq T -> seq T) :=
  forall ps qs, xd (ps ++ qs) = xd ps ++ qs.

Lemma perm_runs_asc_desc x xs ys xd :
     perm_eq (flatten (runs_fix x ys)) (x :: ys)
  /\ perm_eq (flatten (desc x xs ys)) (x::xs ++ ys)
  /\ (is_dlist xd ->
       perm_eq (flatten (asc x xd ys)) (x :: xd [::] ++ ys)).
Proof.
elim: ys x xs xd=>/=.
- move=>x xs xd; do!split=>//.
  by move=>H; move: (H [::] [::x])=>/=; rewrite !cats0=>->; rewrite perm_catC.
move=>b bs IH x xs xd; do!split.
- case: ifP=>_.
  - apply: perm_trans; first by case: (IH b [::x] xd)=>_ [+ _]; apply.
    by move: (perm_catCA [::b] [::x] bs)=>/=->.
  apply: perm_trans; first by case: (IH b [::x] (cons x))=>_ [_] /=; apply.
  by move: (perm_catCA [::b] [::x] bs)=>/=->.
- case: ifP=>_.
  - apply: perm_trans; first by case: (IH b (x::xs) xd)=>_ [+ _]; apply.
    by move: (perm_catCA [::b] (x::xs) bs)=>/=->.
  rewrite /= -!cat_cons perm_cat2l.
  by case: (IH b xs xd)=>+ _; apply.
move=>H; case: ifP=>_.
- apply: perm_trans.
  - case: (IH b xs (xd \o cons x))=>_ [_] /=; apply=>ps qs.
    by rewrite /= -cat_cons; apply: H.
  move: (H [::] [::x])=>/=->; move: (perm_catCA [::b] (xd [::] ++ [::x]) bs)=>/=->.
  by rewrite -cat_cons perm_cat2r perm_catC.
move: (H [::] [::x])=>/=->; rewrite -cat_cons.
apply: perm_cat; first by rewrite perm_catC.
by case: (IH b xs xd)=>+ _; apply.
Qed.

Lemma perm_runs xs : perm_eq (flatten (runs xs)) xs.
Proof.
case: xs=>//=x xs.
by case: (perm_runs_asc_desc x [::] xs id).
Qed.

Lemma perm_nmsort xs : perm_eq (nmsort xs) xs.
Proof.
rewrite /nmsort; apply/perm_trans/perm_runs.
by apply: perm_merge_all.
Qed.

Lemma sorted_runs_asc_desc x xs ys xd :
     all (sorted <=%O) (runs_fix x ys)
  /\ (sorted <=%O xs -> all (>= x) xs -> all (sorted <=%O) (desc x xs ys))
  /\ (is_dlist xd -> sorted <=%O (xd [::]) -> all (<= x) (xd [::]) ->
      all (sorted <=%O) (asc x xd ys)).
Proof.
elim: ys x xs xd=>/=.
- move=>x xs xd; do!split.
  - by move=>Hs Ha; rewrite andbT le_path_sortedE; apply/andP.
  move=>Hd Hs Ha; rewrite andbT; move: (Hd [::] [::x])=>/=->.
  rewrite cats1; apply: sorted_rcons=>//; exact: le_trans.
move=>b ys IH x xs xd; do!split.
- case: ifP=>Ho.
  - case: (IH b [::x] id)=>_ [+ _]; apply=>//.
    by rewrite all_seq1 le_eqVlt Ho orbT.
  case: (IH b xs (cons x))=>_ [_]; apply=>//.
  by rewrite all_seq1 /= leNgt; apply/negbT.
- move=>Hs Ha; case: ifP=>Ho /=.
  - case: (IH b (x::xs) id)=>_ [+ _]; apply=>/=.
    - by rewrite le_path_sortedE; apply/andP.
    rewrite le_eqVlt Ho orbT /=; apply/sub_all/Ha=>z.
    by apply/le_trans; rewrite le_eqVlt Ho orbT.
  rewrite le_path_sortedE Ha Hs /=.
  by case: (IH b xs xd)=>+ _; apply.
move=>Hd Hs Ha; case: ifP=>Ho /=.
- case: (IH b xs (xd \o cons x))=>_ [_] /=; apply.
  - by move=>ps qs /=; rewrite -cat_cons; apply: Hd.
  - move: (Hd [::] [::x])=>/=->.
    by rewrite cats1; apply: sorted_rcons=>//; exact: le_trans.
  move: (Hd [::] [::x])=>/=->.
  rewrite cats1 all_rcons /= Ho /=.
  by apply/sub_all/Ha=>z /= Hx; apply/le_trans/Ho.
apply/andP; split.
- move: (Hd [::] [::x])=>/=->.
  by rewrite cats1; apply: sorted_rcons=>//; exact: le_trans.
by case: (IH b xs id)=>+ _; apply.
Qed.

Lemma sorted_runs xs : all (sorted <=%O) (runs xs).
Proof. by case: xs=>//=x xs; case: (sorted_runs_asc_desc x [::] xs id). Qed.

Lemma sorted_nmsort xs : sorted <=%O (nmsort xs).
Proof. by rewrite /nmsort; apply/sorted_merge_all/sorted_runs. Qed.

(* Running Time Analysis *)

Fixpoint C_runs_fix a xs : nat :=
  if xs is b::bs
    then (if b < a then C_desc b bs else C_asc b bs).+1
    else 0
with C_asc a xs : nat :=
  if xs is b::bs
    then (if a <= b then C_asc b bs else C_runs_fix b bs).+1
    else 0
with C_desc a xs : nat :=
  if xs is b::bs
     then (if b < a then C_desc b bs else C_runs_fix b bs).+1
     else 0.

Definition C_runs xs : nat :=
  if xs is x::xs' then C_runs_fix x xs' else 0.

Definition C_nmsort xs : nat :=
  C_runs xs + C_merge_all (runs xs).

Lemma C_merge_adj_flat xss : C_merge_adj xss <= size (flatten xss).
Proof.
funelim (C_merge_adj xss)=>//=; rewrite catA !size_cat.
by apply: leq_add=>//; apply: C_merge_leq.
Qed.

Lemma merge_adj_flat xss :
  size (flatten (merge_adj xss)) = size (flatten xss).
Proof.
funelim (merge_adj xss)=>//=.
by rewrite catA !size_cat H size_merge size_cat.
Qed.

Lemma C_merge_adj_log2 xss :
  C_merge_all xss <= size (flatten xss) * up_log 2 (size xss).
Proof.
funelim (C_merge_all xss)=>//=; move: H; simp C_merge_adj merge_adj.
rewrite /= !size_cat merge_adj_flat size_merge_adj size_merge size_cat =>IH.
rewrite up_log2S //= mulnS !addnA; apply: leq_add=>//.
by apply/leq_add/C_merge_adj_flat/C_merge_leq.
Qed.

Lemma size_runs_asc_desc x xs ys xd :
      size (flatten (runs_fix x ys)) = (size ys).+1
  /\  size (flatten (desc x xs ys)) = (size xs + size ys).+1
  /\ (is_dlist xd ->
      size (flatten (asc x xd ys)) = (size (xd [::]) + size ys).+1).
Proof.
elim: ys x xs xd=>/=.
- move=>x xs xd; do!split; first by rewrite cats0 addn0.
  by move=>H; move: (H [::] [::x])=>/=; rewrite !cats0=>->; rewrite size_cat addn0 /= addn1.
move=>b bs IH x xs xd; do!split.
- case: ifP=>_.
  - by case: (IH b [::x] id)=>_ [+ _]; rewrite /= addnC addn1.
  case: (IH b [::x] (cons x))=>_ [_] /=; rewrite /= addnC addn1; apply.
  by move=>??; rewrite cat_cons.
- case: ifP=>_ /=.
  - by case: (IH b (x::xs) id)=>_ [+ _]; rewrite /= addSnnS.
  by case: (IH b xs xd)=>+ _; rewrite size_cat=>->.
move=>H; case: ifP=>_ /=.
- case: (IH b xs (xd \o cons x))=>_ [_] /=.
  move: (H [::] [::x])=>/=->; rewrite size_cat /= addnAC -addnA addn1; apply.
  by move=>?? /=; rewrite -cat_cons; apply: H.
move: (H [::] [::x])=>/=->; rewrite !size_cat /=.
by case: (IH b xs xd)=>+ _; rewrite addnAC addn1=>->.
Qed.

Lemma size_runs xs : size (flatten (runs xs)) = size xs.
Proof. by case: xs=>//=x xs; case: (size_runs_asc_desc x [::] xs id). Qed.

Lemma size_runs_asc_desc_leq x xs ys xd :
      (size (runs_fix x ys) <= (size ys).+1)%N
  /\  (size (desc x xs ys) <= (size ys).+1)%N
  /\ (is_dlist xd ->
      (size (asc x xd ys) <= (size ys).+1)%N).
Proof.
elim: ys x xs xd=>//= b bs IH x xs xd; do!split.
- case: ifP=>_.
  - by apply: leqW; case: (IH b [::x] id)=>_ [+ _].
  apply: leqW; case: (IH b [::x] (cons x))=>_ [_]; apply.
  by move=>??; rewrite cat_cons.
- case: ifP=>_ /=.
  - by apply: leqW; case: (IH b (x::xs) id)=>_ [+ _].
  by rewrite ltnS; case: (IH b xs xd)=>+ _ /=.
move=>H; case: ifP=>_ /=.
- apply: leqW; case: (IH b xs (xd \o cons x))=>_ [_] /=; apply.
  by move=>?? /=; rewrite -cat_cons; apply: H.
by rewrite ltnS; case: (IH b xs xd)=>+ _.
Qed.

Lemma size_runs_leq xs : (size (runs xs) <= size xs)%N.
Proof. by case: xs=>//=x xs; case: (size_runs_asc_desc_leq x [::] xs id). Qed.

Lemma C_size_runs_asc_desc_leq x ys :
     (C_runs_fix x ys <= size ys)%N
  /\ (C_desc x ys <= size ys)%N
  /\ (C_asc x ys <= size ys)%N.
Proof.
elim: ys x=>//=b bs IH x.
by do!split; case: ifP=>_; rewrite ltnS; case: (IH b)=>+ [].
Qed.

Lemma C_size_runs_leq xs : (C_runs xs <= (size xs).-1)%N.
Proof. by case: xs=>//=x xs; case: (C_size_runs_asc_desc_leq x xs). Qed.

Lemma C_merge_runs_leq xs n :
  size xs = n -> (C_merge_all (runs xs) <= n * up_log 2 n)%N.
Proof.
move=>H; apply: leq_trans; first by apply: C_merge_adj_log2.
rewrite size_runs H leq_mul2l; apply/orP.
case: n H=>[H|n H]; first by left.
right; apply: leq_up_log; rewrite -H.
by apply: size_runs_leq.
Qed.

Lemma C_nmsort_leq xs n :
  size xs = n -> (C_nmsort xs <= n + n * up_log 2 n)%N.
Proof.
move=>H; rewrite /C_nmsort; apply/leq_add/C_merge_runs_leq=>//.
apply: leq_trans; first by apply: C_size_runs_leq.
by rewrite H; exact: leq_pred.
Qed.

End NaturalMergeSort.

Section Stability.
Context {disp : unit} {T : eqType} {K : orderType disp}.
Implicit Types (xs ys : seq T).

(* Definition *)

Fixpoint insort_key (f : T -> K) x xs : seq T :=
  if xs is y :: xs' then
    if f x <= f y then x :: y :: xs' else y :: insort_key f x xs'
    else [:: x].

Fixpoint isort_key f xs :=
  if xs is x :: xs' then insort_key f x (isort_key f xs') else [::].

Lemma perm_insort_key f x xs : perm_eq (insort_key f x xs) (x :: xs).
Proof.
elim: xs=>//= y xs IH; case: (_ <= _)=>//.
rewrite -(perm_cons y) in IH.
apply: perm_trans; first by exact: IH.
by apply/permP=>/=?; rewrite addnCA.
Qed.

Lemma perm_isort_key f xs : perm_eq (isort_key f xs) xs.
Proof.
elim: xs=>//= x xs IH.
apply: perm_trans; first by apply: perm_insort_key.
by rewrite perm_cons.
Qed.

Lemma sorted_insort_key f a xs :
  sorted <=%O (map f (insort_key f a xs)) = sorted <=%O (map f xs).
Proof.
elim: xs=>//= x xs IH.
case H: (_ <= _)=>/=; first by rewrite H.
rewrite !le_path_sortedE !all_map (perm_all _ (perm_insort_key _ _ _)) /= IH.
suff: f x <= f a by move=>->.
by rewrite leNgt lt_neqAle H andbF.
Qed.

Lemma sorted_isort_key f xs : sorted <=%O (map f (isort_key f xs)).
Proof. by elim: xs=>//=x xs; rewrite sorted_insort_key. Qed.

Lemma insort_key_cons f a xs :
  all (fun x => f a <= f x) xs -> insort_key f a xs = a :: xs.
Proof. by case: xs=>//=x xs /andP [-> _]. Qed.

Lemma filter_not_insort_key (p : pred T) f x xs :
  ~~ p x -> filter p (insort_key f x xs) = filter p xs.
Proof.
move/negbTE=>Hp; elim: xs=>/=; first by rewrite Hp.
move=>y xs IH; case: ifP=>_ /=; first by rewrite Hp.
by rewrite IH.
Qed.

Lemma filter_insort_key (p : pred T) f x xs :
  sorted <=%O (map f xs) -> p x ->
  filter p (insort_key f x xs) = insort_key f x (filter p xs).
Proof.
move/[swap]=>Hp; elim: xs=>/=; first by rewrite Hp.
move=>y xs IH; rewrite le_path_sortedE =>/andP [Ha Hs].
case: ifP=>Hf /=.
- rewrite Hp; case: ifP=>/=; first by rewrite Hf.
  rewrite insort_key_cons // all_filter.
  rewrite all_map in Ha; apply/sub_all/Ha.
  by move=>z /= Hf2; apply/implyP=>_; apply/le_trans/Hf2.
by case: ifP=>/=; rewrite (IH Hs) // Hf.
Qed.

Lemma isort_key_stable f k xs :
  filter (fun y => f y == k) (isort_key f xs) = filter (fun y => f y == k) xs.
Proof.
elim: xs=>//=x xs IH; case: ifP; last first.
- by move/negbT=>Hk; rewrite filter_not_insort_key.
move=>Hk; rewrite filter_insort_key //; last by apply: sorted_isort_key.
rewrite IH insort_key_cons // all_filter (eq_in_all (a2:=predT)) ?all_predT //.
by move=>z _ /=; apply/implyP; move/eqP: Hk=>->/eqP->.
Qed.

End Stability.


Require Export P07.

(** Hint: You may need to first state and prove some lemma about snoc and rev. *)
Theorem rev_involutive : forall l : natlist,
  rev (rev l) = l.
Proof.
  exact FILL_IN_HERE.
Qed.


Require Import
  HoTT.Classes.interfaces.abstract_algebra.

(** If [B] is a (bounded) lattice, then so is [A -> B], pointwise.
    This relies on functional extensionality. *)
Section contents.
  Context `{Funext}.

  Context {A B : Type}.
  Context `{BJoin : Join B}.
  Context `{BMeet : Meet B}.
  Context `{BBottom : Bottom B}.
  Context `{BTop : Top B}.

  Global Instance bot_fun : Bottom (A -> B)
    := fun _ => ⊥.

  Global Instance top_fun : Top (A -> B)
    := fun _ => ⊤.

  Global Instance join_fun : Join (A -> B) :=
    fun (f g : A -> B) (a : A) => (f a) ⊔ (g a).

  Global Instance meet_fun : Meet (A -> B) :=
    fun (f g : A -> B) (a : A) => (f a) ⊓ (g a).

  (** Try to solve some of the lattice obligations automatically *)
  Create HintDb lattice_hints.
  #[local]
  Hint Resolve
       associativity
       absorption
       commutativity | 1 : lattice_hints.
  Local Ltac reduce_fun := compute; intros; apply path_forall; intro.

  Global Instance lattice_fun `{!IsLattice B} : IsLattice (A -> B).
  Proof.
    repeat split; try apply _; reduce_fun.
    1,4: apply associativity.
    1,3: apply commutativity.
    1,2: apply binary_idempotent.
    1,2: apply absorption.
  Defined.

  Instance boundedjoinsemilattice_fun
   `{!IsBoundedJoinSemiLattice B} :
    IsBoundedJoinSemiLattice (A -> B).
  Proof.
    repeat split; try apply _; reduce_fun.
    * apply associativity.
    * apply left_identity.
    * apply right_identity.
    * apply commutativity.
    * apply binary_idempotent.
  Defined.

  Instance boundedmeetsemilattice_fun
   `{!IsBoundedMeetSemiLattice B} :
    IsBoundedMeetSemiLattice (A -> B).
  Proof.
    repeat split; try apply _; reduce_fun.
    * apply associativity.
    * apply left_identity.
    * apply right_identity.
    * apply commutativity.
    * apply binary_idempotent.
  Defined.

  Global Instance boundedlattice_fun
   `{!IsBoundedLattice B} : IsBoundedLattice (A -> B).
  Proof.
    repeat split; try apply _; reduce_fun; apply absorption.
  Defined.
End contents.

#[export]
  Hint Resolve
       associativity
       absorption
       commutativity | 1 : lattice_hints.


Require Import HoTT.

Lemma lem_prop: forall A B, ~(A * B) -> IsHProp A -> IsHProp B -> IsHProp (A + B).
intros A B H H0 H1.
apply ishprop_sum; auto.
Qed.

Lemma merely_functorial: forall P Q, (P -> Q) -> merely P -> merely Q.
  intros P Q H.
  apply Trunc_rec.
  intro H0.
  apply tr.
  auto.
Defined.

Theorem thm7_2_2:
  forall X: Type, forall R: X -> X -> hProp,
  (forall x y, R x y -> x = y) -> IsHSet X.
Admitted.

Section ex_7_1.
  Proposition ex_7_1_q1: (forall A, merely A -> A) -> forall X, IsHSet X.
  Proof.
    intros H X.
    apply (thm7_2_2 X (fun x y => merely (x = y))).
    intros x y.
    apply H.
  Qed.
  Goal (forall A B (f: A -> B), (forall b, merely (hfiber f b)) -> (forall b, hfiber f b))
        -> forall X, IsHSet X.
  Proof.
    intros H X.
    apply ex_7_1_q1.
    intros A H0.
    generalize (H A Unit (fun _ => tt)); intro H1.
    unfold hfiber in H1.
    apply H1.
    induction b.
    apply merely_functorial with (P := A); auto.
    intro a.
    exists a.
    auto.
    exact tt.
  Qed.
End ex_7_1.

Section ex_7_7.
  Definition GLEM m n := forall (A: TruncType n),
    Trunc m (A + ~A).
  Definition LEM := forall (A: hProp), A + ~A.
  Goal forall m, GLEM (-1) m.+1 <-> LEM.
    induction m.
    split.
    intros H A.
    generalize (H A).
    intro H0.
    assert (IsHProp (A + ~A)).
    apply lem_prop.
    intro H1; destruct H1; auto.
  Admitted.
End ex_7_7.


(* Exercise 125 *)

Require Import BenB.

Variables A B C D : Prop.

(* Peirce's law *)

Theorem exercise_125 : ((A -> B) -> A) -> A.
Proof.
imp_i a1.
neg_e' (A) a2.
hyp a2.
imp_e (A -> B).
hyp a1.
imp_i a3.
neg_e A.
hyp a2.
hyp a3.
Qed.


(***********************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
(*   \VV/  *************************************************************)
(*    //   *      This file is distributed under the terms of the      *)
(*         *       GNU Lesser General Public License Version 2.1       *)
(***********************************************************************)

Require Import FSets FMaps Arith Min Compare_dec NArith Nnat Pnat Ndec.
Import Morphisms.

Set Implicit Arguments.
Unset Standard Proposition Elimination Names.
Open Scope N_scope.

Module Type S.

  Declare Module E : OrderedType.
  Definition elt := E.t.

  Parameter t : Type. (** the abstract type of sets *)

  Parameter empty : t.
  (** The empty set. *)

  Parameter multi : elt -> t -> N.
  (** [multi t s] gives the multiplicity of [t] in the multiset [s]. *)

  Parameter update : elt -> N -> t -> t.
  (** [update x m s] returns a multiset identical to [s], except that
    multiplicity of [x] is now [m] *)

  Parameter union : t -> t -> t.

  Parameter inter : t -> t -> t.

  Parameter diff : t -> t -> t.

  Parameter equal : t -> t -> bool.

  Parameter subset : t -> t -> bool.

  Parameter fold : forall A : Type, (elt -> positive -> A -> A) -> t -> A -> A.
  (** [fold] encounters only elements with non-null multiplicity *)

  Parameter elements : t -> list (elt * positive).
  (** [elements] returns the list of elements with non-null multiplicity *)

  (** Logical predicates *)
  Definition Equal s s' := forall a : elt, multi a s = multi a s'.
  Definition Subset s s' := forall a : elt, multi a s <= multi a s'.
  Definition Empty s := forall a : elt, multi a s = 0.

  Notation "s [=] t" := (Equal s t) (at level 70, no associativity).
  Notation "s [<=] t" := (Subset s t) (at level 70, no associativity).

  Section Spec.

  Variable s s' s'' : t.
  Variable x y : elt.
  Variable n : N.
  Variable p : positive.

  (** Specification of [equal] *)
  Parameter equal_1 : s[=]s' -> equal s s' = true.
  Parameter equal_2 : equal s s' = true ->s[=]s'.

  (** Specification of [subset] *)
  Parameter subset_1 : s[<=]s' -> subset s s' = true.
  Parameter subset_2 : subset s s' = true -> s[<=]s'.

  (** Specification of [empty] *)
  Parameter empty_1 : Empty empty.

  (** Specification of [update] *)
  Parameter update_1 : E.eq x y -> multi y (update x n s) = n.
  Parameter update_2 : ~E.eq x y -> multi y (update x n s) = multi y s.

  (** Specification of [union] *)
  Parameter union_1 : multi x (union s s') = multi x s + multi x s'.

  (** Specification of [inter] *)
  Parameter inter_1 : multi x (inter s s') = Nmin (multi x s) (multi x s').

  (** Specification of [diff] *)
  Parameter diff_1 : multi x (diff s s') = multi x s - multi x s'.

  (** Specification of [fold] *)
  Parameter fold_1 : forall (A : Type) (i : A) (f : elt -> positive -> A -> A),
      fold f s i = fold_left (fun a p => f (fst p) (snd p) a) (elements s) i.

  Definition eq_pair (p p':elt*positive) :=
    E.eq (fst p) (fst p') /\ (snd p) = (snd p').

  Definition lt_pair (p p':elt*positive) := E.lt (fst p) (fst p').

  (** Specification of [elements] *)
  Parameter elements_1 : multi x s = Npos p -> InA eq_pair (x,p) (elements s).
  Parameter elements_2 : InA eq_pair (x,p) (elements s) -> multi x s = Npos p.
  Parameter elements_3 : sort lt_pair (elements s).

  End Spec.

End S.

Module Multi (X:OrderedType)(M:FMapInterface.S with Module E:=X)
 <: S with Module E:=X.

 Module E := X.

 Definition elt:=E.t.

 Definition t := M.t positive.
 Definition empty := M.empty positive.
 Definition multi x t := match M.find x t with
  | None => 0
  | Some p => Npos p
 end.

 Definition update x n s := match n with
  | N0 => M.remove x s
  | Npos p => M.add x p s
 end.

 Definition union := M.map2
   (fun o o' =>
      match o,o' with
        | None, None => None
        | None, Some p => Some p
        | Some p, None => Some p
        | Some p, Some p' => Some (Pplus p p')
      end).

 Definition inter := M.map2
   (fun o o' =>
      match o,o' with
        | Some p, Some p' => Some (Pmin p p')
        | _, _ => None
      end).

 Definition diff := M.map2
   (fun o o' =>
      match o,o' with
        | None, _ => None
        | Some p, None => Some p
        | Some p, Some p' => match Pcompare p p' Eq with
            | Lt | Eq => None
            | Gt => Some (Pminus p p')
          end
      end).

 Definition fold := @M.fold positive.

 Definition elements := @M.elements positive.

 Definition equal := M.equal Peqb.

 Definition subset s s' := equal (diff s s') empty.

 Definition Equal s s' := forall a : elt, multi a s = multi a s'.
 Definition Subset s s' := forall a : elt, multi a s <= multi a s'.
 Definition Empty s := forall a : elt, multi a s = 0.

 Notation "s [=] t" := (Equal s t) (at level 70, no associativity).
 Notation "s [<=] t" := (Subset s t) (at level 70, no associativity).

  Module F := FMapFacts.Facts(M).

  Section Spec.

  Variable s s' s'' : t.
  Variable x y : elt.
  Variable n : N.
  Variable p : positive.

  (** Specification of [empty] *)
  Lemma empty_1 : Empty empty.
  Proof.
  unfold Empty, empty, multi; intros.
  rewrite F.empty_o; auto.
  Qed.

  (** Specification of [update] *)
  Lemma update_1 : E.eq x y -> multi y (update x n s) = n.
  Proof.
  unfold update, multi; intros.
  destruct n.
  rewrite F.remove_eq_o; auto.
  rewrite F.add_eq_o; auto.
  Qed.

  Lemma update_2 : ~E.eq x y -> multi y (update x n s) = multi y s.
  Proof.
  unfold update, multi; intros.
  destruct n.
  rewrite F.remove_neq_o; auto.
  rewrite F.add_neq_o; auto.
  Qed.

  (** Specification of [union] *)
  Lemma union_1 : multi x (union s s') = multi x s + multi x s'.
  Proof.
  unfold union, multi; intros.
  rewrite F.map2_1bis; auto.
  destruct (M.find x s); destruct (M.find x s'); auto.
  Qed.

  (** Specification of [inter] *)
  Lemma inter_1 : multi x (inter s s') = Nmin (multi x s) (multi x s').
  Proof.
  unfold inter, multi; intros.
  rewrite F.map2_1bis; auto.
  destruct (M.find x s); destruct (M.find x s'); auto.
  unfold Nmin, Pmin, Nle.
  simpl.
  destruct (Pos.compare p0 p1); auto.
  Qed.

  (** Specification of [diff] *)
  Lemma diff_1 : multi x (diff s s') = multi x s - multi x s'.
  Proof.
  unfold diff, multi; intros.
  rewrite F.map2_1bis; auto.
  destruct (M.find x s); destruct (M.find x s'); auto.
  simpl.
  case_eq (Pcompare p0 p1 Eq); intro H.
  apply Pcompare_Eq_eq in H. rewrite H. now rewrite Pminus_mask_diag.
  now rewrite (Pminus_mask_Lt p0 p1 H).
  pose proof (Pminus_mask_Gt p0 p1 H) as H1. unfold Pminus.
  destruct H1 as [h [H1 _]]; now rewrite H1.
  Qed.

  (** Specification of [fold] *)
  Lemma fold_1 : forall (A : Type) (i : A) (f : elt -> positive -> A -> A),
      fold f s i = fold_left (fun a p => f (fst p) (snd p) a) (elements s) i.
  Proof.
  intros; unfold fold, elements.
  apply M.fold_1.
  Qed.

  Definition eq_pair (p p':elt*positive) :=
    E.eq (fst p) (fst p') /\ (snd p) = (snd p').

  Definition lt_pair (p p':elt*positive) := E.lt (fst p) (fst p').

  (** Specification of [elements] *)
  Lemma elements_1 : multi x s = Npos p -> InA eq_pair (x,p) (elements s).
  Proof.
  unfold multi, elements; intros.
  apply (@M.elements_1 positive).
  apply M.find_2.
  destruct (M.find x s); congruence || discriminate.
  Qed.

  Lemma elements_2 : InA eq_pair (x,p) (elements s) -> multi x s = Npos p.
  Proof.
  unfold multi, elements; intros.
  assert (H0:=@M.elements_2 positive _ _ _ H).
  rewrite F.find_mapsto_iff in H0; rewrite H0; auto.
  Qed.

  Lemma elements_3 : sort lt_pair (elements s).
  Proof.
  apply (@M.elements_3 positive).
  Qed.

  (** Specification of [equal] *)
  Lemma equal_1 : s[=]s' -> equal s s' = true.
  Proof.
  unfold equal, Equal, multi; intros.
  apply M.equal_1.
  unfold M.Equivb, Cmp; intros.
  split; intros.
  generalize (H k); clear H; intros H.
  unfold M.In.
  split; intros (e,He); exists e; rewrite F.find_mapsto_iff in *.
   rewrite He in H; simpl in *.
   destruct (M.find k s'); auto; discriminate || congruence.
   rewrite He in H; simpl in *.
   destruct (M.find k s); auto; discriminate || congruence.
  rewrite F.find_mapsto_iff in *.
  generalize (H k); clear H.
  rewrite H0; rewrite H1; simpl.
  inversion 1; subst; apply Peqb_correct.
  Qed.

  Lemma equal_2 : equal s s' = true ->s[=]s'.
  Proof.
  unfold equal, Equal, multi; intros.
  generalize (M.equal_2 H); clear H; intros H.
  destruct H.
  unfold Cmp in *.
  case_eq (M.find a s); case_eq (M.find a s'); simpl; intros; auto.
  assert (H3:=H0 a p1 p0).
  do 2 rewrite F.find_mapsto_iff in H3.
  f_equal.
  apply Peqb_complete; auto.
  assert (M.In a s) by (exists p0; apply M.find_2; auto).
  rewrite H in H3.
  destruct H3; rewrite F.find_mapsto_iff in H3; congruence.
  assert (M.In a s') by (exists p0; apply M.find_2; auto).
  rewrite <- H in H3.
  destruct H3; rewrite F.find_mapsto_iff in H3; congruence.
  Qed.

  End Spec.

  (** Specification of [subset] *)
  Lemma subset_1 : forall s s', s[<=]s' -> subset s s' = true.
  Proof.
  unfold subset, Subset; intros.
  apply equal_1.
  red; intros.
  rewrite diff_1.
  rewrite empty_1.
  apply <- Nminus_N0_Nle; auto.
  Qed.

  Lemma subset_2 : forall s s', subset s s' = true -> s[<=]s'.
  Proof.
  unfold subset, Subset; intros.
  assert (H0:=equal_2 H a).
  rewrite diff_1 in H0.
  rewrite empty_1 in H0.
  apply -> Nminus_N0_Nle; auto.
  Qed.

End Multi.

(* Example : A multiset on elements in type N *)

Module Ma := FMapList.Make N_as_OT.
Module Mu := Multi N_as_OT Ma.

Definition mens1 := Mu.update 2 7 (Mu.update 3 5 (Mu.empty)).
Definition mens2 := Mu.update 1 4 (Mu.update 3 6 (Mu.empty)).

Eval compute in Mu.elements (Mu.union mens1 mens2).

(* Example: total multiplicity *)

Definition fmu := fun (_:Ma.key) p s => (Npos p) + s.

Definition total_multi s := Mu.fold fmu s 0.

Module Import NP := FMapFacts.Properties Ma.
Import NP.F.
Module Import NP' := FMapFacts.OrdProperties Ma.

Lemma fmu_compat : Proper (eq==>eq==>eq==>eq) fmu.
Proof.
 repeat red; intros; subst; auto.
Qed.

Lemma fmu_transp : transpose_neqkey eq fmu.
Proof.
 red; intros.
 unfold fmu; do 2 rewrite Nplus_assoc; f_equal; apply Nplus_comm; auto.
Qed.
Hint Resolve fmu_compat fmu_transp.

Lemma total_multi_union:
 forall s s', total_multi (Mu.union s s') = total_multi s + total_multi s'.
Proof.
unfold total_multi, Mu.fold.
induction s using map_induction; intros.
rewrite elements_Empty in H.
rewrite (@fold_Equal _ (Mu.union s s') s' _ (@eq N)); auto.
rewrite (Ma.fold_1 s); rewrite H; auto.
 red; intros; unfold Mu.union; rewrite map2_1bis; auto.
 rewrite (elements_o s); rewrite H; simpl.
 destruct (Ma.find y s'); auto.

replace (Ma.fold fmu s2 0) with (fmu x e (Ma.fold fmu s1 0))
 by (symmetry; apply fold_Add; auto).
unfold fmu at 2; simpl @snd.
rewrite <- Nplus_assoc.
rewrite <- IHs1.
case_eq (Ma.find x s'); intros.
(* x may appear in s' hence in (Mu.union s1 s'). In this case we introduce
   artificially (Ma.remove x (Mu.union s1 s')) and reason in two steps. *)
set (u:=Ma.remove x (Mu.union s1 s')).
replace (Ma.fold fmu (Mu.union s2 s') 0) with (fmu x (Pplus e p) (Ma.fold fmu u 0));
 [ | symmetry; apply fold_Add; auto ].
replace (Ma.fold fmu (Mu.union s1 s') 0) with (fmu x p (Ma.fold fmu u 0));
 [ | symmetry; apply fold_Add; auto ].
unfold fmu at 1 3; rewrite Nplus_assoc; f_equal.
unfold u; apply Ma.remove_1; auto.
unfold u, Mu.union; red; intros; rewrite add_o; rewrite remove_o.
rewrite map2_1bis; auto.
(* destruct (eq_dec x y); auto. ----> Not_found *)
destruct (P.F.eq_dec x y); auto.
compute in e0; subst; rewrite H1; auto.
rewrite not_find_mapsto_iff in H; rewrite H; auto.
unfold u; apply Ma.remove_1; auto.
unfold u, Mu.union; red; intros; rewrite add_o; rewrite remove_o.
do 2 (rewrite map2_1bis; auto).
rewrite H0; rewrite add_o.
destruct (P.F.eq_dec x y); auto.
compute in e0; subst; rewrite H1; auto.
(* simple situation where x isn't in s' *)
change (Nplus (Npos e)) with (fmu x e).
apply fold_Add; auto.
rewrite not_find_mapsto_iff; rewrite not_find_mapsto_iff in H.
unfold Mu.union; rewrite map2_1bis; auto; rewrite H1; rewrite H; auto.
red; intros; unfold Mu.union; rewrite add_o.
do 2 (rewrite map2_1bis; auto).
rewrite H0; rewrite add_o.
destruct (P.F.eq_dec x y); auto.
compute in e0; subst; rewrite H1; auto.
Qed.

Lemma total_multi_update: forall s x n,
 total_multi (Mu.update x n s) + Mu.multi x s  = total_multi s + n.
Proof.
unfold total_multi, Mu.fold.
induction s using map_induction; intros.

rewrite elements_Empty in H.
unfold Mu.multi.
rewrite elements_o; rewrite H; simpl.
unfold Mu.update; destruct n.
do 2 rewrite Nplus_0_r.
apply fold_Equal with (eqA:=@eq _); auto.
 red; intros; rewrite remove_o; rewrite elements_o; rewrite H; simpl.
 destruct (P.F.eq_dec x y); auto.
rewrite Nplus_0_r; rewrite Nplus_comm.
change (Nplus (Npos p)) with (fmu x p).
apply fold_Add with (eqA:=@eq _); auto.
 rewrite not_find_mapsto_iff; rewrite elements_o; rewrite H; auto.
 red; auto.

rename x0 into y; rename H into A1; rename H0 into A2.
replace (Ma.fold fmu s2 0) with (fmu x e (Ma.fold fmu s1 0))
 by (symmetry; apply fold_Add; auto).
unfold fmu at 2; rewrite <- Nplus_assoc.
rewrite <- (IHs1 y n); clear IHs1; rewrite Nplus_assoc.
destruct (P.F.eq_dec x y) as [E|E].
(* x=y *)
compute in E; subst y.
replace (Mu.multi x s2) with (Npos e).
replace (Mu.multi x s1) with 0.
rewrite Nplus_0_r; rewrite Nplus_comm; f_equal.
apply fold_Equal with (eqA:=@eq _); eauto.
red; intros; unfold Mu.update; destruct n.
do 2 rewrite remove_o; rewrite A2; rewrite add_o.
destruct (P.F.eq_dec x y); auto.
do 2 rewrite add_o; rewrite A2; rewrite add_o.
destruct (P.F.eq_dec x y); auto.
unfold Mu.multi; rewrite not_find_mapsto_iff in A1; rewrite A1; auto.
unfold Mu.multi.
rewrite A2; rewrite add_o.
destruct (P.F.eq_dec x x) as [_|H]; [ auto | elim H; ME.order ].
(* x<>y *)
replace (Mu.multi y s2) with (Mu.multi y s1).
f_equal.
change (Nplus (Npos e)) with (fmu x e).
apply fold_Add; auto.
rewrite not_find_mapsto_iff; rewrite not_find_mapsto_iff in A1.
assert (y<>x) by (contradict E; auto).
generalize (Mu.update_2 s1 n H).
unfold Mu.multi; rewrite A1.
destruct (Ma.find x (Mu.update y n s1)); intros; discriminate || auto.
red; intros; rewrite add_o.
unfold Mu.update; destruct n;
 rewrite ?remove_o, ?add_o, A2, ?remove_o, ?add_o;
 destruct P.F.eq_dec; destruct P.F.eq_dec; auto; congruence.
unfold Mu.multi; rewrite A2, add_o.
destruct (P.F.eq_dec x y) as [H|_]; [ elim E; auto | auto ].
Qed.


Require Export TopologicalSpaces.
Require Import WeakTopology.

Section Subspace.

Variable X:TopologicalSpace.
Variable A:Ensemble X.

Definition SubspaceTopology : TopologicalSpace :=
  WeakTopology1 (proj1_sig (P:=fun x:X => In A x)).

Definition subspace_inc :
  SubspaceTopology -> X :=
  proj1_sig (P:=fun x:X => In A x).

Lemma subspace_inc_continuous:
  @continuous SubspaceTopology X (@proj1_sig _ _).
Proof.
apply weak_topology1_makes_continuous_func.
Qed.

Lemma subspace_continuous_char (Y : TopologicalSpace)
      (f : Y -> SubspaceTopology) :
  continuous f <->
  continuous (compose subspace_inc f).
Proof.
  apply weak_topology1_continuous_char.
Qed.

Lemma subspace_open_char: forall U:Ensemble {x: X | In A x},
  @open SubspaceTopology U <-> exists V:Ensemble X,
  open V /\ U = inverse_image subspace_inc V.
Proof.
apply weak_topology1_topology.
Qed.

Lemma subspace_closed_char: forall U:Ensemble {x: X | In A x},
  @closed SubspaceTopology U <-> exists V:Ensemble X,
  closed V /\ U = inverse_image subspace_inc V.
Proof.
apply weak_topology1_topology_closed.
Qed.

Lemma subspace_closure U :
  closure U = inverse_image subspace_inc (closure (Im U subspace_inc)).
Proof.
  apply Extensionality_Ensembles; split; red; intros.
  - constructor.
    apply continuous_closure.
    { apply subspace_inc_continuous. }
    apply Im_def.
    assumption.
  - destruct H.
    unfold closure in H.
    constructor. intros.
    destruct H0. destruct H0.
    rewrite subspace_closed_char in H0.
    destruct H0 as [V []].
    subst. constructor.
    destruct H.
    apply H. repeat split; try assumption.
    intros ? ?. inversion H2; subst; clear H2.
    apply H1. assumption.
Qed.

End Subspace.

Arguments SubspaceTopology {X}.
Arguments subspace_inc {X}.

(* Every set is dense in its closure. *)
Lemma dense_in_closure {X:TopologicalSpace} (A : Ensemble X) :
  dense (inverse_image (subspace_inc (closure A)) A).
Proof.
  apply Extensionality_Ensembles; split; red; intros.
  { constructor. }
  destruct x.
  rewrite subspace_closure.
  constructor. simpl.
  rewrite inverse_image_image_surjective_locally.
  { assumption. }
  intros.
  unshelve eexists (exist _ y _).
  2: { reflexivity. }
  apply closure_inflationary.
  assumption.
Qed.

(* If the subspace [F] is closed in [X], then its [subspace_inc] is a
   closed map. *)
Lemma subspace_inc_takes_closed_to_closed
  (X : TopologicalSpace) (F:Ensemble X) :
  closed F ->
  forall G:Ensemble (SubspaceTopology F),
  closed G -> closed (Im G (subspace_inc F)).
Proof.
intros.
red in H0.
rewrite subspace_open_char in H0.
destruct H0 as [U []].
replace (Im G (subspace_inc F)) with
  (Intersection F (Complement U)).
{ apply closed_intersection2; trivial.
  red. now rewrite Complement_Complement. }
apply Extensionality_Ensembles; split; red; intros.
- destruct H2.
  exists (exist _ x H2); trivial.
  apply NNPP. intro.
  change (In (Complement G) (exist (In F) x H2)) in H4.
  rewrite H1 in H4.
  now destruct H4.
- destruct H2 as [[y]].
  subst y0.
  constructor; trivial.
  intro.
  absurd (In (Complement G) (exist _ y i)).
  + now intro.
  + now rewrite H1.
Qed.


Require Import Arith. (* arith database for tactics *)

Theorem example_for_intuition:
  forall n p q : nat, n <= p \/ n <= q -> n <= p \/ n <= S q.
Proof.
  intros n p q. intuition. (* auto with arith. will also work *)
Qed.

(* intuition = intuition auto with * *)


Inductive listn : nat -> Set :=
  | niln : listn 0
  | consn : forall n : nat, nat -> listn n -> listn (S n).

Inductive empty : forall n : nat, listn n -> Prop :=
    intro_empty : empty 0 niln.

Parameter
  inv_empty : forall (n a : nat) (l : listn n), ~ empty (S n) (consn n a l).

Type
  (fun (n : nat) (l : listn n) =>
   match l in (listn n) return (empty n l \/ ~ empty n l) with
   | niln => or_introl (~ empty 0 niln) intro_empty
   | consn n O y as b => or_intror (empty (S n) b) (inv_empty n 0 y)
   | consn n a y as b => or_intror (empty (S n) b) (inv_empty n a y)
   end).

Type
  (fun (n : nat) (l : listn n) =>
   match l in (listn n) return (empty n l \/ ~ empty n l) with
   | niln => or_introl (~ empty 0 niln) intro_empty
   | consn n O y => or_intror (empty (S n) (consn n 0 y)) (inv_empty n 0 y)
   | consn n a y => or_intror (empty (S n) (consn n a y)) (inv_empty n a y)
   end).

Type
  (fun (n : nat) (l : listn n) =>
   match l in (listn n) return (empty n l \/ ~ empty n l) with
   | niln => or_introl (~ empty 0 niln) intro_empty
   | consn O a y as b => or_intror (empty 1 b) (inv_empty 0 a y)
   | consn n a y as b => or_intror (empty (S n) b) (inv_empty n a y)
   end).


Require Export XR_INR.
Require Export XR_IZR.

Local Open Scope R_scope.

Lemma INR_IZR_INZ : forall n:nat, INR n = IZR (Z.of_nat n).
Proof.
  intro n.
  induction n as [ | n hin ].
  {
    simpl.
    reflexivity.
  }
  {
    simpl.
    rewrite SuccNat2Pos.id_succ.
    reflexivity.
  }
Qed.


Require Import Utf8.
Require Import Coq.Program.Basics Setoid RelationClasses ProofIrrelevance FunctionalExtensionality.

(* Note : Remember to use eq_rect for equality between morphisms
  if necessary *)
Import EqNotations.

(* identity is unique, not sure if composition is, so I'll leave it as a parameter *)

Class Category
  (obj : Type)
  (hom : obj -> obj -> Type)
  (comp : forall {A B C} (f : hom B C) (g : hom A B), hom A C) := {
  cid : forall A, hom A A;

  idLeft: forall {A B} (f: hom A B), comp (cid B) f = f;
  idRight: forall {A B} (f : hom B A), comp f (cid B) = f;
  compAssoc: forall {A B C D} (f : hom A B) (g : hom B C) (h : hom C D),
    comp h (comp g f) = comp (comp h g) f
}.

Generalizable Variables obj hom comp.

Definition homOp `{Category} := hom.
Definition compOp `{Category obj hom comp} := comp.

Notation "a --> b" := (homOp a b).
Notation "1" := (cid _).
Notation "f '•' g" := (compOp _ _ _ f g) (at level 50).

(*** Dualization *)
Instance Dual `(Category obj hom comp) : Category obj (fun A B => B --> A)
  (fun {A B C} f g => comp _ _ _ g f):= {}.
Proof.
  - intros. apply 1.
  - intros A B f. simpl. apply idRight.
  - intros A B f. apply idLeft.
  - intros A B C D f g h. simpl. rewrite compAssoc. reflexivity.
Defined.

(* If we don't remove this typclass instance search might not terminate *)
Remove Hints Dual : typeclass_instances.

Notation "C ¯" := (Dual C) (at level 20, left associativity).

(** EXAMPLES **)

Instance Category_Set : Category Type (fun A B => A -> B)
  (fun A B C f g => compose f g) := {}.
  - intros. apply X.
  - intros. reflexivity.
  - intros. reflexivity.
  - intros. unfold compose. reflexivity.
Defined.

Class Poset {A : Type} (R : relation A) := {
  Poset_Reflexive :> Reflexive R;
  Poset_Transitive :> Transitive R;
  Poset_Antisymmetric :> Antisymmetric A eq R;
}.

Instance Category_Poset (A : Type) (lt : relation A) (P : Poset lt) : Category A
  (fun (a1 a2 : A) => lt a1 a2)
  (fun (a1 a2 a3 : A) p1 p2 => @transitivity A lt (Poset_Transitive) a1 a2 a3 p2 p1)
  := {}.
  - apply reflexivity.
  - intros; apply proof_irrelevance.
  - intros; apply proof_irrelevance.
  - intros; apply proof_irrelevance.
Defined.


Require Export GeoCoq.Elements.OriginalProofs.lemma_betweennotequal.
Require Export GeoCoq.Elements.OriginalProofs.lemma_localextension.
Require Export GeoCoq.Elements.OriginalProofs.lemma_congruencesymmetric.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_betweennesspreserved :
   forall A B C a b c,
   Cong A B a b -> Cong A C a c -> Cong B C b c -> BetS A B C ->
   BetS a b c.
Proof.
intros.
assert (neq A B) by (forward_using lemma_betweennotequal).
assert (neq a b) by (conclude axiom_nocollapse).
assert (neq B C) by (forward_using lemma_betweennotequal).
assert (neq b c) by (conclude axiom_nocollapse).
let Tf:=fresh in
assert (Tf:exists d, (BetS a b d /\ Cong b d b c)) by (conclude lemma_localextension);destruct Tf as [d];spliter.
assert (Cong b c b d) by (conclude lemma_congruencesymmetric).
assert (Cong b c B C) by (conclude lemma_congruencesymmetric).
assert (Cong b d B C) by (conclude cn_congruencetransitive).
assert (Cong B C b d) by (conclude lemma_congruencesymmetric).
assert (Cong C C c d) by (conclude axiom_5_line).
assert (Cong c d C C) by (conclude lemma_congruencesymmetric).
assert (~ neq c d).
 {
 intro.
 assert (neq C C) by (conclude axiom_nocollapse).
 assert (eq C C) by (conclude cn_equalityreflexive).
 contradict.
 }
assert (BetS a b c) by (conclude cn_equalitysub).
close.
Qed.

End Euclid.