Require Import HoTT.Basics HoTT.Types.
Require Import MyTacs MyLemmas Colimits.Diagram Colimits.Colimit Colimits.CoEqualizer Colimits.Colimit_Sigma.

Local Open Scope path_scope.
Generalizable All Variables.

Context `{Funext}.

Section KernelPair.
  Definition KP_diag `(f: A -> B) : diagram coequalizer_graph.
    simple refine (Build_diagram _ _ _).
    - intro x; destruct x.
      exact {a:A & {a':A & f a = f a'}}. exact A.
    - intros i j; destruct i, j; intro H; destruct H. exact pr1. exact (λ w, w.2.1).
  Defined.

  Definition KP_cocone `{f: A -> B} `(q: A -> Q) (Hq: forall x y, f x = f y -> q x = q y)
  : cocone (KP_diag f) Q.
  simple refine (Build_cocone _ _).
  - intros i x; destruct i; simpl in *. exact (q x.1). exact (q x).
  - intros i j g x; destruct i, j, g; simpl in *. reflexivity.
    simple refine (Hq _ _ _). exact x.2.2^.
  Defined.

  Definition KP `(f: A -> B) := colimit (KP_diag f).

  Definition KP_colimit `(f: A -> B) : is_colimit (KP_diag f) (KP f)
    := is_colimit_colimit _.

  Definition kp `{f: A -> B} : A -> KP f :=
    @colim _ (KP_diag f) false.

  Definition kp_eq `{f: A -> B} : forall (a a': A), f a = f a' -> @kp _ _ f a = kp a'.
    intros a a' p.
    etransitivity. exact (@pp _ (KP_diag f) true false true (a; (a'; p))).
    exact (@pp _ (KP_diag f) true false false (a; (a'; p)))^.
  Defined.
End KernelPair.

Section T.
  Definition T_diag (X: Type) : diagram coequalizer_graph.
    simple refine (Build_diagram _ _ _).
    - intro x; destruct x.
      exact (X * X). exact X.
    - intros i j g; destruct i, j, g. exact fst. exact snd.
  Defined.

  Definition T_diag_equiv `(e: X <~> Y) : (T_diag X) ≃ (T_diag Y).
    simple refine (Build_diagram_equiv (Build_diagram_map _ _) _).
    - intros i; destruct i; simpl. exact (functor_prod e e). exact e.
    - intros i j g; destruct i, j, g; reflexivity.
    - intros i; destruct i; simpl. apply isequiv_functor_prod. apply e.
  Defined.

  Definition T_cocone {X: Type} `(f: X -> Y) (Hf: forall x y, f x = f y)
  : cocone (T_diag X) Y.
    simple refine (Build_cocone _ _).
    - intros i x; destruct i; simpl in *. exact (f (fst x)). exact (f x).
    - intros i j g x; destruct i, j, g; simpl in *. reflexivity. apply Hf.
  Defined.

  Definition T_diag_KP_diag {X: Type} : T_diag X ≃ (KP_diag (λ _:X, tt)).
    simple refine (Build_diagram_equiv _ _).
    - simple refine (Build_diagram_map _ _).
      + intros i x; destruct i; simpl in *. exact (fst x; (snd x; 1)). exact x.
      + intros i j g x; destruct i, j, g; reflexivity.
    - intros i; destruct i; simpl.
      + simple refine (isequiv_adjointify (λ x, (x.1, x.2.1)) _ _); intro; simpl.
        2:reflexivity. simple refine (path_sigma' _ 1 (path_sigma' _ 1 _)).
        simpl. apply path_ishprop.
      + apply isequiv_idmap.
  Defined.

  Definition T (X: Type) := colimit (T_diag X).

  Definition T_colimit (X: Type) : is_colimit (T_diag X) (T X)
    := is_colimit_colimit _.

  Definition α {X: Type} : X -> T X :=
    @colim _ (T_diag X) false.

  Definition β {X: Type} : forall x y: X, α x = α y
      := λ x y, (@pp _ (T_diag X) true false true (x,y))
                  @ (@pp _ (T_diag X) true false false (x,y))^.

  Definition T_functor_equiv `(e: X <~> Y) : (T X) <~> (T Y)
    := functoriality_colimit_equiv (T_diag_equiv e) (T_colimit _) (T_colimit _).
End T.

Section KP_Sigma.
  Context {X Y: Type} (f: X -> Y).

  Definition diagram_map_fib_fib_diag : diagram_map (KP_diag f) (sigma_diag (λ y, T_diag (hfiber f y))).
    simple refine (Build_diagram_map _ _).
    - intros i x; destruct i; simpl in *.
      exists (f x.1). exact ((x.1; 1), (x.2.1; x.2.2^)).
      exact (f x; (x; 1)).
    - intros i j g x; destruct i, j, g; simpl in *. reflexivity.
      simple refine (path_sig_hfiber _ _ _). reflexivity.
  Defined.

  Definition diagram_equiv_fib_fib_diag :  diagram_equiv (KP_diag f) (sigma_diag (λ y, T_diag (hfiber f y))).
    simple refine (Build_diagram_equiv diagram_map_fib_fib_diag _).
    intros i; destruct i; simpl.
    - simple refine (isequiv_adjointify _ _ _).
      + intros w. exists (fst w.2).1. exists (snd w.2).1.
        exact ((fst w.2).2 @ (snd w.2).2^).
      + intros [y [[x e] [x' e']]]; simpl.
        destruct e. hott_simpl.
      + intros x; simpl. hott_simpl.
    - simple refine (isequiv_adjointify _ _ _).
      + intros w; exact w.2.1.
      + intros [y [x e]]; simpl. by destruct e.
      + intros x. reflexivity.
  Defined.

  Context `(HQ1: is_colimit (KP_diag f) Q1) {Q2: Y -> Type}
          (HQ2: forall y:Y, is_colimit (T_diag (hfiber f y)) (Q2 y)).

  Definition KP_slicing : Q1 <~> sig Q2.
    simple refine (functoriality_colimit_equiv diagram_equiv_fib_fib_diag HQ1 _).
    apply is_colimit_sigma. assumption.
  Defined.

  Definition KP_lift : Q1 -> Y.
    simple refine (postcompose_cocone_inv HQ1 _).
    simple refine (KP_cocone f (λ x y e, e)).
  Defined.

  Definition KP_cocone_lift_ok : KP_cocone f (λ x y e, e) = postcompose_cocone (precompose_cocone diagram_map_fib_fib_diag (sigma_cocone _ HQ2)) pr1.
    simple refine (path_cocone _ _).
    - intros i x; destruct i; reflexivity.
    - intros i j g x; destruct i, j, g; simpl in *; hott_simpl; unfold path_sigma'.
      + match goal with
          | |- ?ee = ap pr1 (path_sigma ?PP ?uu ?vv ?pp ?qq) =>
                       exact (@pr1_path_sigma _ PP uu vv pp qq)^
        end.
      + rewrite ap_pp.
        match goal with
          | |- ?ee = ?ee2 @ ap pr1 (path_sigma ?PP ?uu ?vv ?pp ?qq) =>
                       change (ee = ee2 @ (path_sigma PP uu vv pp qq)..1);
                       rewrite (@pr1_path_sigma _ PP uu vv pp qq)
        end.
        rewrite concat_p1.
        symmetry; etransitivity.
        exact (ap_compose _ _ _)^. simpl. unfold path_sig_hfiber.
        rewrite ap_V. unfold path_sigma'.
        match goal with
          | |- (ap _ (path_sigma ?PP ?uu ?vv ?pp ?qq))^ = ?ee =>
                       change (((path_sigma PP uu vv pp qq)..1)^ = ee);
                       rewrite (@pr1_path_sigma _ PP uu vv pp qq)
        end. hott_simpl.
  Defined.

  (* Definition KP_slicing_map : Q1 -> sig Q2. *)
  (*   simple refine (postcompose_cocone_inv HQ1 _). *)
  (*   simple refine (precompose_cocone diagram_map_fib_fib_diag _). *)
  (*   simple refine (sigma_cocone _ _). *)
  (*   intros y; apply HQ2. *)
  (* Defined. *)

  (* Definition KP_slicing_map_ok : KP_slicing_map = KP_slicing. *)
  (*   reflexivity. *)
  (* Defined. *)

  Definition KP_lift_slicing : KP_lift = pr1 o KP_slicing.
    simple refine (equiv_inj (postcompose_cocone HQ1) _). apply HQ1.
    unfold KP_lift, postcompose_cocone_inv. rewrite eisretr.
    rewrite KP_cocone_lift_ok. etransitivity. 2:simple refine (postcompose_cocone_comp _ _ _)^.
    apply ap10.
    (* Set Printing Implicit. *)
    simple refine (apD10 _ Y). apply ap.
    cbn. unfold functoriality_colimit. unfold postcompose_cocone_inv; rewrite eisretr.
    reflexivity.
  Defined.

  Definition KP_lift_hfiber (y: Y) : hfiber KP_lift y <~> Q2 y.
    etransitivity. simple refine (equiv_functor_sigma' KP_slicing _).
    exact (λ x, KP_lift (KP_slicing^-1 x) = y).
    intros a. simple refine (equiv_paths _). f_ap.
    exact (eissect KP_slicing a)^.
    etransitivity. simple refine (equiv_functor_sigma_id _).
    exact (λ x, x.1 = y).
    intros w. simple refine (equiv_paths _).
    etransitivity. exact (ap10 KP_lift_slicing _).
    apply ap. apply eisretr.
    { simple refine (equiv_adjointify _ _ _ _).
      - intros w. simple refine (w.2 # w.1.2).
      - intros w. simple refine (exist _ _ _). exists y. exact w. reflexivity.
      - intros w. reflexivity.
      - intros [w e]. destruct e. reflexivity. }
  Defined.
End KP_Sigma.

Section KP_lift_equiv.
  Definition hfiber_KP_lift_equiv `(f: X -> Y) {A: Type} (y: Y) (e: (hfiber f y) <~>  A)
    : {e': hfiber (KP_lift f (KP_colimit f)) y <~> T A & α o e == e' o (λ x: hfiber f y, (kp x.1; x.2))}.
    simple refine (exist _ _ _).
    - etransitivity.
      simple refine (KP_lift_hfiber (Q2 := λ y, T (hfiber f y)) _ _ _ _).
      intros; apply T_colimit.
      simple refine (functoriality_colimit_equiv _ (T_colimit _) (T_colimit _)).
      simple refine (T_diag_equiv _). exact e.
    - intros [x p].
      pose (Te := functoriality_colimit (T_diag_equiv e) (T_colimit _) (T_colimit _)).
      transitivity (Te (α (x; p))). symmetry.
      simple refine (functoriality_colimit_commute (T_diag_equiv e) _ _ false (x; p))^.
      match goal with
      | |- ?AA = _ (transitive_equiv _ _ _ ?ee1 ?ee4) ?xx =>
        change (AA = ee4 (ee1 (kp x; p))); set (e4 := equiv_fun ee4)
      end. unfold KP_lift_hfiber.
      match goal with
      | |- ?AA = e4 (_ (transitive_equiv _ _ _ ?ee1 ?ee2) ?xx) =>
        change (AA = e4 (ee2 (ee1 (kp x; p)))); set (e1 := equiv_fun ee1)
      end.
      match goal with
      | |- ?AA = e4 (_ (transitive_equiv _ _ _ ?ee2 ?ee3) ?xx) =>
        change (AA = e4 (ee3 (ee2 xx))); set (e2 := equiv_fun ee2); set (e3 := equiv_fun ee3)
      end.
      set (sl := equiv_fun (KP_slicing f (KP_colimit f) (λ y0 : Y, T_colimit (hfiber f y0)))) in *.
      symmetry. etransitivity (e4 (e3 (e2 (sl (kp x); _)))). f_ap.
      subst e1.
      etransitivity (e4 (e3 (sl (kp x); _))). f_ap.
      subst e2.
      match goal with
      | |- e4 (e3 (_; ?ppp)) = _ => set (pp := ppp)
      end.
      etransitivity (e4 (transport (λ y0 : Y, T (hfiber f y0)) pp (sl (kp x)).2)). reflexivity.
      clear e3. f_ap. clear e4.
      change (transport (λ y, T (hfiber f y)) pp (α (x; 1)) = α (x;p)).
      etransitivity.
      simple refine (transport_colimit _ (λ y, T_colimit (hfiber f y)) pp false (x; 1)).
      apply β.
  Defined.
End KP_lift_equiv.


From mathcomp Require Import all_ssreflect perm algebra.zmodp.
From mathcomp Require Import zify.

Import Order POrderTheory TotalTheory.

(******************************************************************************)
(*  Definition of some network sorting algorithms                             *)
(*                                                                            *)
(*         `2^ m == 2 ^ n so that                                             *)
(*                  `2^ m.+1 = `2^ m + `2^ m is true by reduction             *)
(*         noT s  == number of T of a sequence of booleans                    *)
(*         noF s  == number of F of a sequence of booleans                    *)
(*       ipred i == i.-1                                                      *)
(*       inext i == i.+1 when possible otherwise i                            *)
(*      isub k i == i - k when k <= i otherwise i                             *)
(*      iadd k i == i.+ k when possible otherwise i                           *)
(*       olift t == odd lift : move n of 'I_m into n.*2.+1 in 'I_(m + m)      *)
(*       elift t == even lift : move n of 'I_m into n.*2 in 'I_(m + m)        *)
(*       olift t == odd lift : move n of 'I_m into n.*2.+1 in 'I_(m + m)      *)
(*       idiv2 t == div2 on I_n : move n of 'I_(m + m) into n./2 in 'I_m      *)
(*       ttake t == take the left part of a (m + n).-tuple                    *)
(*       tdrop t == take the right part of a (m + n).-tuple                   *)
(*       etake t == take the even part of a sequence                          *)
(*      tetake t == take the even part of a (m + m).-tuple                    *)
(*       otake t == take the odd part of a sequence                           *)
(*      totake t == take the odd part of a (m + m).-tuple                     *)
(*      teocat t == build an (m + m).-tuple                                   *)
(*      tmap f t == apply f to the tuple t                                    *)
(*        trev t == get the reverse of a tuple                                *)
(*    leqt t1 t2 == all the elements of t1 are <=%O to their respective       *)
(*                  element in t2                                             *)
(******************************************************************************)

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

(* Missing theorems they should be moved to mathcomo *)
Lemma uphalfE n : uphalf n = n.+1./2.
Proof. by []. Qed.

Lemma leq_half_double m n : (m./2 <= n) = (m <= n.*2.+1).
Proof.
apply/idP/idP => [m2Ln|mLnn]; last first.
  by rewrite -[n](half_bit_double _ true) half_leq.
rewrite -[m](odd_double_half) -add1n.
by apply: leq_add; [case: odd|rewrite leq_double].
Qed.

Lemma gtn_half_double m n : (n < m./2) = (n.*2.+1 < m).
Proof. by rewrite ltnNge leq_half_double -ltnNge. Qed.

Lemma ltn_half_double m n : (m./2 < n) = (m < n.*2).
Proof. by rewrite ltnNge geq_half_double -ltnNge. Qed.

Lemma geq_uphalf_double m n : (m <= uphalf n) = (m.*2 <= n.+1).
Proof. by rewrite uphalfE geq_half_double. Qed.

Lemma gtn_uphalf_double m n : (n < uphalf m) = (n.*2 < m).
Proof. by rewrite uphalfE gtn_half_double. Qed.

Lemma ltn_uphalf m n : (uphalf m < n) = (m.+1 < n.*2).
Proof. by rewrite uphalfE ltn_half_double. Qed.

Lemma half_gtnn n : (n./2 < n) = (n != 0).
Proof.
case: n => // [] [|n] //.
rewrite eqn_leq [n.+2 <= _]leqNgt -[X in _ < X]odd_double_half -addnn addnA.
by rewrite /= [~~ _ + _]addnS addSn !ltnS leq_addl.
Qed.

Section E2.

(* We define an explicte function `2^ n = 2 ^ n so that `2^ n.+1 reduces      *)
(* to `2^ m + `2^ m                                                           *)

Fixpoint e2n m := if m is m1.+1 then e2n m1 + e2n m1 else 1.

Notation "`2^ n" := (e2n n) (at level 40).

Lemma e2nE m : `2^ m = 2 ^ m.
Proof. by elim: m => //= m ->; rewrite expnS mul2n addnn. Qed.

Lemma e2Sn m : `2^ m.+1 = `2^ m + `2^ m.
Proof. by []. Qed.

Lemma e2n_gt0 m : 0 < `2^ m.
Proof. by rewrite e2nE expn_gt0. Qed.

Lemma odd_e2 m : odd (`2^ m) = (m == 0).
Proof. by case: m => //= m; rewrite addnn odd_double. Qed.

Lemma ltn_ne2n n : n < `2^ n.
Proof.
elim: n => // [] [|n] // IH.
apply: leq_ltn_trans (_ : n.+1.*2 < _).
  by rewrite -addnn addnS addSn !ltnS leq_addr.
by rewrite e2Sn addnn ltn_double.
Qed.

Lemma leq_uphalf_e2n n m : n <= `2^ m.+1 -> uphalf n <= `2^ m.
Proof.
rewrite -{1}(odd_double_half n) uphalf_half e2Sn addnn.
by case: odd; rewrite //= ?add1n ?ltn_double // leq_double.
Qed.

Lemma e2n_div2 n : 0 < n -> (`2^ n)./2 = `2^ n.-1.
Proof. by case: n => // n _; rewrite e2Sn addnn doubleK. Qed.

Lemma dvdn_e2n m n : (`2^ m %| `2^ n) = (m <= n).
Proof.
elim: n m => [[|m]//=|n IH [/=|m]].
- rewrite dvdn1.
  by rewrite eqn_leq leqNgt -add1n !addnn leq_double e2n_gt0.
- by rewrite dvd1n.
by rewrite !e2Sn !addnn -!muln2 dvdn_pmul2r // IH.
Qed.

Lemma e2nD m n : `2^ (m + n) = `2^ m * (`2^ n).
Proof.
elim: m => /= [|m IH]; first by rewrite mul1n.
by rewrite !addnn -doubleMl IH.
Qed.

Lemma ltn_e2n m n : (`2^ m < `2^ n) = (m < n).
Proof.
elim: n m => [/= [|m]//|n IH [|m]].
- by rewrite ltnS; case: e2n (e2n_gt0 m.+1).
- by rewrite !e2Sn !addnn (leq_double 1) e2n_gt0.
by rewrite !e2Sn !addnn ltn_double IH.
Qed.

Lemma leq_e2n m n : (`2^ m <= `2^ n) = (m <= n).
Proof.
elim: n m => [/= [|m]//|n IH [|m]].
- by rewrite e2Sn; case: e2n (e2n_gt0 m) => //= n; rewrite addnS.
- rewrite (leq_trans _ (_ : `2^ 1 <= `2^ n.+1)) //.
  by rewrite !e2Sn !addnn (leq_double 1) e2n_gt0.
by rewrite !e2Sn !addnn leq_double IH.
Qed.

End E2.

Notation "`2^ n" := (e2n n) (at level 40).

Section Sorted.

Lemma isorted_consF s : sorted <=%O (false :: s) = sorted <=%O s.
Proof. by elim: s. Qed.

Lemma dsorted_consF s : sorted >=%O (false :: s) = (s == nseq (size s) false).
Proof. by elim: s => // [[]] //= [|[]]. Qed.

Lemma isorted_consT s : sorted <=%O (true :: s) = (s == nseq (size s) true).
Proof. by elim: s => // [[]] //= [|[]]. Qed.

Lemma dsorted_consT s : sorted >=%O (true :: s) = sorted >=%O s.
Proof. by elim: s => //= [[]]. Qed.

Lemma sorted_bool_constl m (s : seq bool) :
  sorted <=%O ((nseq m false) ++ s) = sorted <=%O s.
Proof.
by elim: m => // [] n; rewrite [nseq _.+1 _ ++ _]/= isorted_consF.
Qed.

Lemma sorted_bool_constr m (s : seq bool) :
  sorted <=%O (s ++ (nseq m true)) = sorted <=%O s.
Proof.
elim: s => [|[] s IH].
- by case: m => // m; rewrite [nseq _.+1 _]/= isorted_consT size_nseq eqxx.
- rewrite [(_ :: _) ++ _]/= !isorted_consT size_cat nseqD size_nseq.
  by rewrite eqseq_cat ?eqxx ?andbT ?size_nseq.
by rewrite [(_ :: _) ++ _]/= !isorted_consF.
Qed.

Lemma isorted_boolP (s : seq bool) :
  reflect (exists t,
            let: (j,k) := t in s = nseq j false ++ nseq k true)
          (sorted <=%O s).
Proof.
elim: s => [|[] s IH].
- by apply: (iffP idP) => // _; exists (0,0).
- rewrite isorted_consT; apply: (iffP eqP) => [->|[[[|j] k]]] /=.
  + by exists (0, (size s).+1).
  + by case: k => [|k /= [->]]; rewrite ?size_nseq.
  by case.
rewrite isorted_consF; apply: (iffP IH) => [] [[j k]].
  by move=> ->; exists (j.+1, k).
case: j => /= [|j [->]]; first by case: k.
by exists (j, k).
Qed.

Lemma isorted_bool_nseq (b : bool) k : (sorted <=%O (nseq k b)).
Proof.
case: b; apply/isorted_boolP; first by exists (0, k).
by exists (k, 0); rewrite cats0.
Qed.

Lemma dsorted_boolP (s : seq bool) :
  reflect (exists t,
            let: (j,k) := t in s = nseq j true ++ nseq k false)
          (sorted >=%O s).
Proof.
elim: s => [|[] s IH].
- by apply: (iffP idP) => // _; exists (0,0).
- rewrite dsorted_consT; apply: (iffP IH) => [] [[j k]].
    by move=> ->; exists (j.+1, k).
  case: j => /= [|j [->]]; first by case: k.
  by exists (j, k).
rewrite dsorted_consF; apply: (iffP eqP) => [->|[[[|j] k]]] /=.
- by exists (0, (size s).+1).
- by case: k => [|k /= [->]]; rewrite ?size_nseq.
by case.
Qed.

Lemma dsorted_bool_nseq (b : bool) k : (sorted >=%O (nseq k b)).
Proof.
case: b; apply/dsorted_boolP; first by exists (k, 0); rewrite cats0.
by exists (0, k).
Qed.

Variable d : unit.
Variable A : orderType d.

Lemma tsorted01 n (t : n.-tuple A) : n <= 1 -> sorted <=%O t.
Proof.
case: n t => [|[|//]]; first by do 2 case.
by case => [] [] // a [] // b [] //= i; rewrite !(tnth_nth a) /= andbT.
Qed.

Lemma tsorted2 (t : 2.-tuple A) :
  sorted <=%O t = (tnth t ord0 <= tnth t ord_max)%O.
Proof.
by case: t => [] [] // a [] // b [] //= i; rewrite !(tnth_nth a) /= andbT.
Qed.

Lemma sortedPn (s : seq A) :
  reflect
    (exists2 x, s = x.2.1 ++ [:: x.1.1, x.1.2 & x.2.2] & (x.1.2 < x.1.1)%O)
    (~~ sorted <=%O s).
Proof.
elim: s => [|a [|b s] IH].
- by apply: (iffP idP) => // [[[x1 [[|x x21] x22]]]].
- by apply: (iffP idP) => // [[[x1 [[|x [| y x21]] x22] []]]].
rewrite /= negb_and; case: leP => [aLb | bLa] /=; last first.
  by apply: (iffP idP) => // _; exists ((a, b), ([::], s)).
apply: (iffP IH) => [] [[[x1 x2] [s1 s2]] /= blE x2Lx1] /=.
  by exists ((x1, x2), (a :: s1, s2)) => //=; rewrite blE.
case: s1 blE => [[aE bE lE]|x3 s1 [aE blE]].
  by move: aLb; rewrite aE bE leNgt x2Lx1.
by exists ((x1, x2), (s1, s2)).
Qed.

End Sorted.

Section NoFT.

Definition noT (s : seq bool) := count (fun b => b) s.
Definition noF (s : seq bool) := count (fun b => ~~b) s.

Lemma noT_cat s1 s2 : noT (s1 ++ s2) = noT s1 + noT s2.
Proof. exact: count_cat. Qed.

Lemma noF_cat s1 s2 : noF (s1 ++ s2) = noF s1 + noF s2.
Proof. exact: count_cat. Qed.

Lemma noT_nseq n b : noT (nseq n b) = b * n.
Proof. exact: count_nseq. Qed.

Lemma noF_nseq n b : noF (nseq n b) = ~~b * n.
Proof. exact: count_nseq. Qed.

Definition noE := (noT_cat, noF_cat, noT_nseq, noF_nseq, mul1n, mul0n,
                   add0n, addn0).

Lemma size_noFT s : noF s + noT s = size s.
Proof. by elim: s => // [] [] s; rewrite /= !(addnS, addSn) => ->. Qed.

Lemma isorted_noFT s :
  (sorted <=%O s) = (s == nseq (noF s) false ++ nseq (noT s) true).
Proof.
apply/isorted_boolP/eqP => [[[i j]->]|->]; first by rewrite !noE.
by exists (noF s, noT s).
Qed.

End NoFT.

Section MoreIn.

Definition inext m : 'I_m -> 'I_m :=
  if m is m1.+1 then fun i => inZp (if i == m1 :> nat then i : nat else i.+1)
  else fun i => i.

Lemma val_inext m (i : 'I_m) :
  inext i = if i == m.-1 :> nat then i : nat else i.+1 :> nat.
Proof.
case: m i => [[]//|n i /=].
have:= (ltn_ord i); rewrite ltnS leq_eqVlt.
by case: eqP => [->|_] /= iLn; rewrite modn_small.
Qed.

Definition ipred m : 'I_m -> 'I_m :=
  if m is m1.+1 then fun i => inZp (i.-1) else fun i => i.

Lemma val_ipred m (i : 'I_m) : ipred i = i.-1 :> nat.
Proof.
case: m i => [[]//|n i /=].
by rewrite modn_small // (leq_ltn_trans (leq_pred _) (ltn_ord i)).
Qed.

Definition iadd m k : 'I_m -> 'I_m :=
  if m is m1.+1 then fun i => inZp (if k + i <= m1 then k + i else i)
  else fun i => i.

Lemma val_iadd m (i : 'I_m) k :
  iadd k i = if k + i < m then k + i else i :> nat.
Proof.
case: m i => [[]//|n i /=]; have iLn := ltn_ord i.
by rewrite modn_small ?ltnS //=; case: (leqP (k + i)).
Qed.

Lemma inextE m (i : 'I_m) : inext i = iadd 1 i.
Proof.
apply/val_eqP; rewrite /= val_inext val_iadd.
have := ltn_ord i; rewrite leq_eqVlt => /orP[/eqP iE|iLm].
  by rewrite -[X in X.-1]iE /= eqxx -[X in _ < X]iE ltnn.
rewrite iLm [_ == _.-1]eqn_leq [_.-1 <= _]leqNgt.
by rewrite -[i < _]ltnS prednK ?iLm ?andbF // (ltn_trans _ iLm).
Qed.

Definition isub m k : 'I_m -> 'I_m :=
  if m is m1.+1 then fun i => inZp (if k <= i then i - k else i)
  else fun i => i.

Lemma val_isub m (i : 'I_m) k : isub k i = if k <= i then i - k else i :> nat.
Proof.
case: m i => [[]//|n i /=]; have iLn := ltn_ord i.
rewrite modn_small //=; case: (leqP k) => // _.
apply: leq_ltn_trans _ iLn.
by rewrite -[X in _ <= X]subn0 leq_sub.
Qed.

Lemma split_lshift m i (j : 'I_m) : split (lshift i j) = inl j.
Proof.
case: splitP => [j1 j1E|/= k kE]; first by congr (inl _); apply/val_eqP/eqP.
by have := ltn_ord j; rewrite leqNgt kE ltnS leq_addr.
Qed.

Lemma split_rshift m i (j : 'I_m) : split (rshift i j) = inr j.
Proof.
case: splitP => [j1 j1E|k kE]; last first.
  congr (inr _).
  by apply/val_eqP/eqP; rewrite /= -[k : nat](addKn i) -kE addKn.
by have := ltn_ord j1; rewrite leqNgt -j1E ltnS leq_addr.
Qed.

Definition elift m : 'I_m -> 'I_(m + m) :=
  if m is m1.+1 then fun i => inZp (i.*2) else fun i => i.

Lemma val_elift m (i : 'I_m) : elift i = i.*2 :> nat.
Proof.
case: m i => [[]//|m i].
by rewrite -[LHS]/(i.*2 %% (m.+1 + m.+1)) modn_small // addnn ltn_double.
Qed.

Definition olift m : 'I_m -> 'I_(m + m) :=
  if m is m1.+1 then fun i => inZp (i.*2.+1) else fun i => i.

Lemma val_olift m (i : 'I_m) : olift i = i.*2.+1 :> nat.
Proof.
case: m i => [[]//|m i].
rewrite -[LHS]/(i.*2.+1 %% (m.+1 + m.+1)) modn_small //.
by rewrite addnS addSn !ltnS addnn leq_double -ltnS.
Qed.

Definition idiv2 m : 'I_(m + m) -> 'I_m :=
  if m is m1.+1 then fun i => inZp (i./2) else fun i => i.

Lemma val_idiv2 m (i : 'I_(m + m)) : idiv2 i = i./2 :> nat.
Proof.
case: m i => [[]//|n i /=].
rewrite modn_small // -ltn_double -[X in _ < X]addnn.
rewrite (leq_ltn_trans _ (ltn_ord i)) //.
by rewrite -[X in _ <= X]odd_double_half leq_addl.
Qed.

Lemma oliftK m (i : 'I_m) : idiv2 (olift i) = i.
Proof.
apply/val_eqP; rewrite /= val_idiv2 /= val_olift.
by rewrite -divn2 -muln2 -addn1 divnMDl // addn0.
Qed.

Lemma idiv2K_odd m (i : 'I_(m + m)) : odd i -> olift (idiv2 i) = i.
Proof.
move=> iO.
apply/val_eqP; rewrite /= val_olift /= val_idiv2.
by rewrite -[X in _ == X]odd_double_half iO.
Qed.

Lemma idiv2K_even m (i : 'I_(m + m)) : ~~ odd i -> elift (idiv2 i) = i.
Proof.
move=> iO.
apply/val_eqP; rewrite /= val_elift /= val_idiv2.
by rewrite -[X in _ == X]odd_double_half (negPf iO).
Qed.

Lemma eliftK m (i : 'I_m) : idiv2 (elift i) = i.
Proof.
by apply/val_eqP; rewrite /= val_idiv2 /= val_elift doubleK.
Qed.

End MoreIn.

Section Tuple.

Variable A : eqType.

Lemma ttake_proof m1 m2 : minn m1 (m1 + m2) = m1.
Proof. by rewrite minnC minnE [m1 + m2]addnC addnK [m2 + m1]addnC addnK. Qed.

Lemma tdrop_proof m1 m2 : (m1 + m2) - m1 = m2.
Proof. by rewrite addnC addnK. Qed.

Definition ttake (T : Type) (m1 m2 : nat) (t : (m1 + m2).-tuple T) :=
  tcast (ttake_proof m1 m2) [tuple of take m1 t].

Lemma ttakeE (T : Type) (m1 m2 : nat) (t : (m1 + m2).-tuple T) :
  ttake t = take m1 t :> seq T.
Proof. by rewrite val_tcast. Qed.

Lemma ttakeK m1 m2 (t1 : m1.-tuple A) (t2 : m2.-tuple A) :
  ttake [tuple of t1 ++ t2] = t1.
Proof.
apply/val_eqP => /=.
by rewrite ttakeE take_cat size_tuple ltnn subnn /= take0 cats0.
Qed.

Definition tdrop m1 m2 (t : (m1 + m2).-tuple A) :=
  tcast (tdrop_proof m1 m2) [tuple of drop m1 t].

Lemma tdropE m1 m2 (t : (m1 + m2).-tuple A) : tdrop t = drop m1 t :> seq A.
Proof. by rewrite val_tcast. Qed.

Lemma tdropK m1 m2 (t1 : m1.-tuple A) (t2 : m2.-tuple A) :
  tdrop [tuple of t1 ++ t2] = t2.
Proof.
apply/val_eqP => /=.
by rewrite tdropE drop_cat size_tuple ltnn subnn /= drop0.
Qed.

Lemma cat_ttake_tdrop m (t : (m + m).-tuple A) :
  t = [tuple of ttake t ++ tdrop t].
Proof. by apply/val_eqP; rewrite /= ttakeE tdropE; rewrite cat_take_drop. Qed.

Definition trev (T : Type) m (t : m.-tuple T) := [tuple of rev t].

Fixpoint etake (T : Type) (s : seq T) :=
  if s is a :: s1 then a :: (if s1 is _ :: s2 then etake s2 else [::])
  else [::].

Definition otake (T : Type) (s : seq T) :=
  if s is _ :: s1 then etake s1 else [::].

Lemma etake_cons (T : Type) a (s : seq T) : etake (a :: s) = a :: otake s.
Proof. by []. Qed.

Lemma otake_cons (T : Type) a (s : seq T) : otake (a :: s) = etake s.
Proof. by []. Qed.

Lemma nth_etake (T : Type) a (s : seq T) n : nth a (etake s) n = nth a s n.*2.
Proof.
have [m leMm] := ubnP (size s);
    elim: m s leMm n => [[]//|m IH [|b [|c s]]] HS n.
- by rewrite /= !nth_nil.
- by case: n => [|n]; rewrite //= nth_nil.
rewrite etake_cons otake_cons; case: n => //= n.
rewrite ltnS in HS.
by apply: IH; apply: leq_trans HS => /=.
Qed.

Lemma nth_otake (T : Type) a (s : seq T) n :
  nth a (otake s) n = nth a s n.*2.+1.
Proof.
by case: s; rewrite //= ?nth_nil // => _ s; rewrite nth_etake.
Qed.

Lemma size_etake (T : Type) (s : seq T) : size (etake s) = uphalf (size s).
Proof.
have [n leMn] := ubnP (size s); elim: n s leMn => // n IH [|a [|b s]] //=.
rewrite !ltnS => slLn.
by rewrite IH //= (leq_trans _ slLn).
Qed.

Lemma etake_tupleP m (T : Type) (t : (m + m).-tuple T) : size (etake t) == m.
Proof. by rewrite size_etake size_tuple /= addnn uphalf_double. Qed.
Canonical etake_tuple (T : Type) m (t : (m + m).-tuple T) :=
  Tuple (etake_tupleP t).

Lemma size_otake (T : Type) (s : seq T) : size (otake s) = (size s)./2.
Proof. by case: s => //= a s; rewrite size_etake. Qed.

Lemma otake_tupleP (T : Type) m (t : (m + m).-tuple T) : size (otake t) == m.
Proof. by rewrite size_otake size_tuple addnn doubleK. Qed.
Canonical otake_tuple (T : Type) m (t : (m + m).-tuple T) :=
  Tuple (otake_tupleP t).

Lemma etake_nseq (T : Type) i (a : T) : etake (nseq i a) = nseq (uphalf i) a.
Proof.
have [n leMi] := ubnP i; elim: n i leMi => // n IH [|[|i]] //= iLn.
by rewrite IH // -ltnS (leq_trans _ iLn).
Qed.

Lemma otake_nseq i (T : Type) (a : T) : otake (nseq i a) = nseq i./2 a.
Proof. by case: i => //= i; exact: etake_nseq. Qed.

Lemma etake_cat (T : Type) (s1 s2 : seq T) :
  etake (s1 ++ s2) = etake s1 ++ if odd (size s1) then otake s2 else etake s2.
Proof.
have [n leMs1] := ubnP (size s1).
elim: n s1 leMs1 => // n IH [|a[|b s1]] //= slLn.
by rewrite negbK IH // -ltnS (leq_trans _ slLn).
Qed.

Lemma otake_cat (T : Type) (s1 s2 : seq T) :
  otake (s1 ++ s2) = otake s1 ++ if odd (size s1) then etake s2 else otake s2.
Proof. by case: s1 => // a l; rewrite /= if_neg etake_cat. Qed.

Lemma etake_cat_nseq (T : Type) (a1 a2 : T) m1 m2 :
  etake (nseq m1 a1 ++ nseq m2 a2) =
  nseq (uphalf m1) a1 ++ nseq (~~odd m1 + m2)./2 a2.
Proof.
by rewrite etake_cat !etake_nseq otake_nseq size_nseq; case: (odd m1).
Qed.

Lemma otake_cat_nseq (T : Type) (a1 a2 : T) m1 m2 :
  otake (nseq m1 a1 ++ nseq m2 a2) =
  nseq m1./2 a1 ++ nseq (odd m1 + m2)./2 a2.
Proof.
by rewrite otake_cat !otake_nseq etake_nseq size_nseq; case: (odd m1).
Qed.

Lemma etake_sorted (leA : rel A) (s : seq A) :
  transitive leA -> sorted leA s -> sorted leA (etake s).
Proof.
move=> leA_trans.
have [n leMs] := ubnP (size s).
elim: n s leMs => // k IH [|a [|b [| c s]]] // H1 H2.
rewrite /= in H2; have /and3P[aLb bLc cPs] := H2.
suff : leA a c && sorted leA (etake (c :: s)) by [].
rewrite (leA_trans _ _ _ aLb bLc) // IH //=.
by rewrite /= ltnS in H1; rewrite (leq_ltn_trans _ H1).
Qed.

Lemma otake_sorted (leA : rel A) (s : seq A) :
  transitive leA -> sorted leA s -> sorted leA (otake s).
Proof.
move=> leT_trans; case: s => //= a s sS.
by apply: etake_sorted => //; case: s sS => //= b l /andP[].
Qed.

Lemma eq_size_etake (T :  Type) (s1 s2 : seq T) :
  size s1 = size s2 -> size (etake s1) = size (etake s2).
Proof.
have [k leMl] := ubnP (size s1).
elim: k s1 s2 leMl => // k IH [|a [|b s1]] [|c [|d s2]] //= ss1Lk [] /IH -> //.
by rewrite -ltnS ltnW.
Qed.

Lemma eq_size_otake (T : Type) (s1 s2 : seq T) :
  size s1 = size s2 -> size (otake s1) = size (otake s2).
Proof.
by case: s1; case: s2 => //= b s2 a s1 [] /eq_size_etake.
Qed.

Definition tetake (T : Type) (m : nat) (t : (m + m).-tuple T) :=
  [tuple of etake t].

Definition totake (T : Type) (m : nat) (t : (m + m).-tuple T) :=
  [tuple of otake t].

Lemma tetakeE (T : Type) (m : nat) (t : (m + m).-tuple T) :
  tetake t = etake t :> seq T.
Proof. by []. Qed.

Lemma totakeE (T : Type) (m : nat) (t : (m + m).-tuple T) :
  totake t = otake t :> seq T.
Proof. by []. Qed.

Fixpoint eocat (T : Type) (s1 s2 : seq T) :=
  if s1 is a :: s3 then a :: head a s2 :: eocat s3 (behead s2) else [::].

Lemma size_eocat (T : Type) (s1 s2 : seq T) :
  size (eocat s1 s2) = (size s1 + size s1).
Proof. by elim: s1 s2 => //= a s1 IH s2; rewrite IH addnS. Qed.

Lemma nth_eocat (T : Type) a (s1 s2 : seq T) n :
  size s1 = size s2 ->
  nth a (eocat s1 s2) n = nth a (if odd n then s2 else s1) n./2.
Proof.
elim: s1 s2 n => /= [[]//= n|b s1 IH [//= n|c s2 [|[|n]] //= [Hs]/=]].
  by rewrite if_same !nth_nil.
by rewrite negbK IH; case: odd.
Qed.

Lemma eocat_cat (T : Type) (s1 s2 s3 s4 : seq T) :
  ~~ odd (size s1) -> size s1 = size s3 ->
  eocat (s1 ++ s2) (s3 ++ s4) = eocat s1 s3 ++ eocat s2 s4.
Proof.
have [n leMs1] := ubnP (size s1).
elim: n s1 s3 leMs1 => //= n IH [|a[|b s1]] [|c[|d s3]] //=.
rewrite !ltnS negbK => ss1Ln ss1O [ss1E].
by rewrite IH // (leq_ltn_trans _ ss1Ln).
Qed.

Lemma eocat_etake_otake (T : Type) n (s : seq T) :
  size s = n + n -> eocat (etake s) (otake s) = s.
Proof.
elim: n s =>[[]// | n IH [//|a [|b s]]]; rewrite !addnS //.
by rewrite !(etake_cons, otake_cons) /= => [] [H]; rewrite IH.
Qed.

Lemma etakeK (T : Type) (s1 s2 : seq T) : etake (eocat s1 s2) = s1.
Proof. by elim: s1 s2 => //= a l IH s2; rewrite IH. Qed.

Lemma otakeK (T : Type) (s1 s2 : seq T) :
  size s1 = size s2 -> otake (eocat s1 s2) = s2.
Proof.
elim: s1 s2 => [[]//|a s1 IH [|b s2] //].
by rewrite [eocat _ _]/= otake_cons etake_cons /= => [] [/IH->].
Qed.

Lemma etake_eocat (T : Type) (s1 s2 : seq T) :  etake (eocat s1 s2) = s1.
Proof.
have [n leMs1] := ubnP (size s1).
elim: n s1 leMs1 s2 => // n IH [|a[|b s1]] //= slLn s2.
by rewrite IH // -ltnS (leq_trans _ slLn).
Qed.

Lemma otake_eocat (T : Type) (s1 s2 : seq T) :
  size s1 = size s2 -> otake (eocat s1 s2) = s2.
Proof.
elim: s1 s2 => [|a s1 IH] s2; first by case: s2.
case: s2 => [//|b s2].
by rewrite [eocat _ _]/= otake_cons etake_cons => [] [/IH->].
Qed.

Lemma eocat_nseqD (T : Type) (v : T) a b :
  eocat (nseq a v) (nseq b v) = nseq (a + a) v.
Proof. by elim: a b => // n IH [|b]; rewrite addnS /= ?IH // (IH 0).  Qed.

Lemma eocat_nseq_catD (T : Type) (v1 v2 : T) a b c :
  eocat (nseq a v1 ++ nseq b v2) (nseq a v1 ++ nseq c v2) =
        (nseq (a + a) v1 ++ nseq (b + b) v2).
Proof.
elim: a b c => // [b c | n IH b c]; first by rewrite eocat_nseqD.
by rewrite addnS /= IH.
Qed.

Lemma nseqS (T : Type) a (b : T) : nseq a.+1 b = b :: nseq a b.
Proof. by []. Qed.

Lemma cat_cons (T : Type) (a : T) s1 s2 : (a :: s1) ++ s2 = a :: (s1 ++ s2).
Proof. by []. Qed.

Lemma eocat_cons (T : Type) (a b : T) s1 s2 :
  eocat (a :: s1) (b :: s2) = a :: b :: eocat s1 s2.
Proof. by []. Qed.

Lemma eocat_nseq_catDS (T : Type) (v1 v2 : T) a b :
  eocat (nseq a.+1 v1 ++ nseq b v2) (nseq a v1 ++ nseq b.+1 v2) =
        (nseq (a + a).+1 v1 ++ nseq (b + b).+1 v2).
Proof.
elim: a b => // [b | a IH b].
  by case: b => //= b; rewrite eocat_nseqD [(_ + _)%Nrec]addnS.
by rewrite addnS (nseqS a) (nseqS a.+1) 2!(cat_cons v1) eocat_cons IH.
Qed.

Lemma nth_cat_seqT a b i : nth true (nseq a false ++ nseq b true) i = (a <= i).
Proof.
by rewrite nth_cat !nth_nseq !size_nseq if_same; case: leqP.
Qed.

Lemma nseq_cat_sortedE (s : seq bool) m1 m2 m3 m4 :
  sorted (<=%O) s ->
  perm_eq s (nseq m1 false ++ nseq m2 true ++ nseq m3 false ++ nseq m4 true) ->
  s = nseq (m1 + m3) false ++ nseq (m2 + m4) true.
Proof.
move=> /isorted_boolP[[u v] ->] /allP; set s1 := _ ++ _ => permH.
congr (nseq _ _ ++ nseq _ _).
  have [/permH/=|] := boolP (false \in s1).
    by rewrite !(count_cat, count_nseq) /= !(mul0n, mul1n, addn0, add0n) =>/eqP.
  by rewrite !(mem_cat, mem_nseq) /= eqxx !negb_or /=;
     case: (m1) => [|k1];  case: (m3) => [|k2]; rewrite ?(andbF, andbT) //;
     case: (u).
have [/permH/=|] := boolP (true \in s1).
  by rewrite !(count_cat, count_nseq) /= !(mul0n, mul1n, addn0, add0n) =>/eqP.
by rewrite !(mem_cat, mem_nseq) /= eqxx !negb_or /=;
   case: (m2) => [|k1];  case: (m4) => [|k2]; rewrite ?(andbF, andbT) //;
   case: (v).
Qed.

Lemma take_etakeE (T : Type) (s : seq T) :
  ~~ odd (size s) ->   ~~ odd (size s)./2 ->
  take (size s)./2./2 (etake s) = etake (take (size s)./2 s).
Proof.
move=> H1 H2.
pose s1 := take (size s)./2 s; pose s2 := drop (size s)./2 s.
pose s3 := etake s; pose s4 := otake s.
have lE : s = s1 ++ s2 by rewrite cat_take_drop.
have ss1E : size s1 = (size s)./2 by rewrite size_take half_gtnn; case: size.
rewrite -/s1.
rewrite {2}lE etake_cat ss1E (negPf H2).
rewrite take_cat size_etake ss1E.
by rewrite uphalf_half (negPf H2) /= ltnn subnn take0 cats0.
Qed.

Lemma ttake_etakeE n (t : ((n + n) + (n + n)).-tuple A) :
  ttake (tetake t) = tetake (ttake t).
Proof.
apply/val_eqP; rewrite /= !(ttakeE, tetakeE).
have nnE : n + n = (size t)./2.
  by rewrite size_tuple /= [in RHS]addnn doubleK.
rewrite [X in _ == _ (_ X _)]nnE.
have nE : n = (size t)./2./2.
  by rewrite size_tuple /= !addnn !doubleK.
rewrite [X in take X _]nE take_etakeE //.
  by rewrite size_tuple /= addnn odd_double.
by rewrite -nnE addnn odd_double.
Qed.

Lemma take_otakeE (T : Type) (s : seq T) :
  ~~ odd (size s) ->   ~~ odd (size s)./2 ->
  take (size s)./2./2 (otake s) = otake (take (size s)./2 s).
Proof.
move=> H1 H2.
pose s1 := take (size s)./2 s; pose s2 := drop (size s)./2 s.
pose s3 := etake s; pose s4 := otake s.
have sE : s = s1 ++ s2 by rewrite cat_take_drop.
have ss1E : size s1 = (size s)./2 by rewrite size_take half_gtnn; case: size.
rewrite -/s1.
rewrite {2}sE otake_cat ss1E (negPf H2).
rewrite take_cat size_otake ss1E.
by rewrite ltnn subnn take0 cats0.
Qed.

Lemma ttake_otakeE n (t : ((n + n) + (n + n)).-tuple A) :
  ttake (totake t) = totake (ttake t).
Proof.
apply/val_eqP; rewrite /= !(ttakeE, totakeE).
have nnE : n + n = (size t)./2.
  by rewrite size_tuple /= [in RHS]addnn doubleK.
rewrite [X in _ == _ (_ X _)]nnE.
have nE : n = (size t)./2./2.
  by rewrite size_tuple /= !addnn !doubleK.
rewrite [X in take X _]nE take_otakeE //.
  by rewrite size_tuple /= addnn odd_double.
by rewrite -nnE addnn odd_double.
Qed.

Lemma drop_etakeE (T : Type) (s : seq T) :
  ~~ odd (size s) ->   ~~ odd (size s)./2 ->
  drop (size s)./2./2 (etake s) = etake (drop (size s)./2 s).
Proof.
move=> ssE ss2E.
pose s1 := take (size s)./2 s; pose s2 := drop (size s)./2 s.
pose s3 := etake s; pose s4 := otake s.
have lE : s = s1 ++ s2 by rewrite cat_take_drop.
have ss1E : size s1 = (size s)./2.
  by rewrite size_take half_gtnn; case: size.
rewrite -/s2.
rewrite {2}lE etake_cat ss1E (negPf ss2E).
rewrite drop_cat size_etake ss1E.
by rewrite uphalf_half (negPf ss2E) /= ltnn subnn drop0.
Qed.

Lemma tdrop_etakeE n (t : ((n + n) + (n + n)).-tuple A) :
  tdrop (tetake t) = tetake (tdrop t).
Proof.
apply/val_eqP; rewrite /= !(tdropE, tetakeE).
have nnE : n + n = (size t)./2.
  by rewrite size_tuple /= [in RHS]addnn doubleK.
rewrite [X in _ == _ (_ X _)]nnE.
have nE : n = (size t)./2./2.
  by rewrite size_tuple /= !addnn !doubleK.
rewrite [X in drop X _]nE drop_etakeE //.
  by rewrite size_tuple /= addnn odd_double.
by rewrite -nnE addnn odd_double.
Qed.

Lemma drop_otakeE (T : Type) (s : seq T) :
  ~~ odd (size s) ->   ~~ odd (size s)./2 ->
  drop (size s)./2./2 (otake s) = otake (drop (size s)./2 s).
Proof.
move=> ssE ss2E.
pose s1 := take (size s)./2 s; pose s2 := drop (size s)./2 s.
pose s3 := etake s; pose s4 := otake s.
have sE : s = s1 ++ s2 by rewrite cat_take_drop.
have ss1E : size s1 = (size s)./2.
  by rewrite size_take half_gtnn; case: size.
rewrite -/s2.
rewrite {2}sE otake_cat ss1E (negPf ss2E).
by rewrite drop_cat size_otake ss1E ltnn subnn drop0.
Qed.

Lemma tdrop_otakeE n (t : ((n + n) + (n + n)).-tuple A) :
  tdrop (totake t) = totake (tdrop t).
Proof.
apply/val_eqP; rewrite /= !(tdropE, totakeE).
have nnE : n + n = (size t)./2.
  by rewrite size_tuple /= [in RHS]addnn doubleK.
rewrite [X in _ == _ (_ X _)]nnE.
have nE : n = (size t)./2./2.
  by rewrite size_tuple /= !addnn !doubleK.
rewrite [X in drop X _]nE drop_otakeE //.
  by rewrite size_tuple /= addnn odd_double.
by rewrite -nnE addnn odd_double.
Qed.

Lemma eocat_tupleP (T : Type) m1 m2 (t1 : m1.-tuple T) (t2 : m2.-tuple T) :
  size (eocat t1 t2) == m1 + m1.
Proof. by rewrite size_eocat size_tuple. Qed.
Canonical eocat_tuple (T : Type) m1 m2 (t1 : m1.-tuple T) (t2 : m2.-tuple T) :=
  Tuple (eocat_tupleP t1 t2).

Definition teocat (T : Type) m1 m2 (t1 : m1.-tuple T) (t2 : m2.-tuple T) :=
  [tuple of eocat t1 t2].

Lemma eocat_tetake_totake (T : eqType) n (t : (n + n).-tuple T) :
  t = teocat (tetake t) (totake t).
Proof.
by apply/val_eqP; rewrite /= (@eocat_etake_otake T n) // size_tuple.
Qed.

Lemma tetakeK (T : eqType) (m : nat) (t1 t2 : m.-tuple T) :
  tetake (teocat t1 t2) = t1.
Proof.
by apply/val_eqP; rewrite /= tetakeE /= etake_eocat.
Qed.

Lemma totakeK (T : eqType) (m : nat) (t1 t2 : m.-tuple T) :
  totake (teocat t1 t2) = t2.
Proof.
by apply/val_eqP; rewrite /= totakeE /= otake_eocat // !size_tuple.
Qed.

Lemma sorted_tetake_totake m (t : (m + m).-tuple bool) :
  sorted <=%O (tetake t) ->
  sorted <=%O (totake t) ->
  noF (totake t) <= noF (tetake t) <= (noF (totake t)).+1 ->
  sorted <=%O t.
Proof.
rewrite tetakeE totakeE.
move => /isorted_boolP [[a1 a2] teE] /isorted_boolP [[b1 b2] toE]
        /andP[noFeLnoFo noFoLnoFe].
have : size (tetake t) = size (totake t) by rewrite !size_tuple.
move: noFeLnoFo noFoLnoFe.
rewrite [X in sorted _ (tval X)]eocat_tetake_totake /= {}teE {}toE !noE.
rewrite !(size_cat, size_nseq).
case: (ltngtP a1 b1) => // [a1Lb1 | <-] _ b1La1 a1a2E.
  have b1E : a1 = b1.+1 by case: (ltngtP a1 b1.+1) b1La1 a1Lb1.
  have ->: b2 = a2.+1 by apply: (@addnI a1); rewrite addnS a1a2E b1E.
  rewrite b1E; apply/isorted_boolP; exists (b1.*2.+1, a2.*2.+1).
  by rewrite eocat_nseq_catDS !addnn.
have ->: b2 = a2 by apply: (@addnI a1).
apply/isorted_boolP; exists (a1.*2, a2.*2).
by rewrite eocat_nseq_catD !addnn.
Qed.

(* We develop a true variant of eocat, so that eotcatK holds *)
Fixpoint eotcat (A : Type) (s1 s2 : seq A) :=
  if s1 is a :: s3 then
  if s2 is b :: s4 then a :: b :: eotcat s3 s4
  else [:: a] else [::].

Lemma eotcat_cons (R : Type) a b (s1 s2 : seq R) :
  eotcat (a :: s1) (b :: s2) = a :: b :: eotcat s1 s2.
Proof. by []. Qed.

Lemma eotcatK (T : Type) (s : seq T) : eotcat (etake s) (otake s) = s.
Proof.
have [n leMs] := ubnP (size s).
elim: n s leMs => //= n IH [|a[|b s]] //= sLn.
by rewrite IH // -ltnS ltnW.
Qed.

End Tuple.

Section TMap.
Variable m : nat.
Variables A B : Type.
Variable f : A -> B.

Definition tmap t := [tuple f (tnth t i) | i < m].

Lemma val_tmap t : tmap t = map f t :> seq B.
Proof.
have -> : tmap t = [tuple of [seq f (tnth t i) | i <- ord_tuple m]].
  by apply: eq_from_tnth => i; rewrite !(tnth_map, tnth_ord_tuple).
congr tval.
by apply: eq_from_tnth => i; rewrite !(tnth_map, tnth_ord_tuple).
Qed.

End TMap.

Section LeqT.

Variable d : unit.
Variable A : orderType d.

Definition leqt m (t1 t2 : m.-tuple A) :=
  [forall a : 'I_m, forall b : 'I_m,
    (a <= b) ==> (tnth t1 a <= tnth t1 b)%O ==> (tnth t2 a <= tnth t2 b)%O].

Lemma leqtP m (t1 t2 : m.-tuple A) :
  reflect
  (forall a b : 'I_m, a <= b ->
                (tnth t1 a <= tnth t1 b)%O -> (tnth t2 a <= tnth t2 b)%O)
  (leqt t1 t2).
Proof.
apply: (iffP forallP) => [H a b aLb t1aLt1b|H a].
  by have /forallP/(_ b) := H a; rewrite aLb t1aLt1b.
by apply/forallP=> b; case: leqP => //= aLb; apply/implyP/H.
Qed.

Lemma leqtc m : reflexive (@leqt m).
Proof. by move=>t; apply/leqtP. Qed.

Lemma leqt_trans m : transitive (@leqt m).
Proof.
move=>t2 t1 t3 /leqtP Ht1t2 /leqtP Ht2t3.
apply/leqtP => a b aLb t2aLt2b.
by apply: Ht2t3 => //; apply: Ht1t2.
Qed.

Lemma leqt_sorted m (t1 t2 : m.-tuple A) : sorted (>%O) t1 -> leqt t1 t2.
Proof.
move=> sS; apply/leqtP => a b.
rewrite leq_eqVlt => /orP[/val_eqP->//|aLb].
pose v := tnth t1 a; rewrite leNgt !(tnth_nth v).
by rewrite -DualPOrder.ltEdual lt_sorted_ltn_nth ?(aLb, inE, size_tuple).
Qed.

End LeqT.

Section MinMax.

Lemma minFb x : min false x = false.
Proof. by case: x. Qed.

Lemma minbF x : min x false = false.
Proof. by case: x. Qed.

Lemma maxFb x : max false x = x.
Proof. by case: x. Qed.

Lemma maxbF x : max x false = x.
Proof. by case: x. Qed.

Lemma minTb x : min true x = x.
Proof. by case: x. Qed.

Lemma minbT x : min x true = x.
Proof. by case: x. Qed.

Lemma maxTb x : max true x = true.
Proof. by case: x. Qed.

Lemma maxbT x : max x true = true.
Proof. by case: x. Qed.

Variable m : nat.
Variable d1 d2 : unit.
Variable A : orderType d1.
Variable B : orderType d2.
Variable f : A -> B.

Lemma min_homo :
  {homo f : x y / (x <= y)%O >-> (x <= y)%O} -> {morph f : x y / min x y}.
Proof.
(move=> fH x y; case: (leP (f x)) => [fxLfy|fyLfx]; case: leP => //).
  by rewrite lt_neqAle => /andP[_ /fH]; case: ltgtP fxLfy.
by move=> /fH; case: ltgtP fyLfx.
Qed.

Lemma max_homo :
  {homo f : x y / (x <= y)%O >-> (x <= y)%O} -> {morph f : x y / max x y}.
Proof.
(move=> fH x y; case: (leP (f x)) => [fxLfy|fyLfx]; case: leP => //).
  by rewrite lt_neqAle => /andP[_ /fH]; case: ltgtP fxLfy.
by move=> /fH; case: ltgtP fyLfx.
Qed.

End MinMax.


From Hammer Require Import Hammer.

Set Warnings "-notation-overridden,-parsing".
From LF Require Export Tactics.

Check 3 = 3.

Check forall n m : nat, n + m = m + n.

Check 2 = 2.

Check forall n : nat, n = 2.

Check 3 = 4.

Theorem plus_2_2_is_4 :
2 + 2 = 4.
Proof. hammer_hook "Logic" "Logic.plus_2_2_is_4". reflexivity.  Qed.

Definition plus_fact : Prop := 2 + 2 = 4.
Check plus_fact.

Theorem plus_fact_is_true :
plus_fact.
Proof. hammer_hook "Logic" "Logic.plus_fact_is_true". reflexivity.  Qed.

Definition is_three (n : nat) : Prop :=
n = 3.
Check is_three.

Definition injective {A B} (f : A -> B) :=
forall x y : A, f x = f y -> x = y.

Lemma succ_inj : injective S.
Proof. hammer_hook "Logic" "Logic.succ_inj".
intros n m H. injection H as H1. apply H1.
Qed.

Check @eq.

Example and_example : 3 + 4 = 7 /\ 2 * 2 = 4.

Proof. hammer_hook "Logic" "Logic.and_example".
split.
-  reflexivity.
-  reflexivity.
Qed.

Lemma and_intro : forall A B : Prop, A -> B -> A /\ B.
Proof. hammer_hook "Logic" "Logic.and_intro".
intros A B HA HB. split.
- apply HA.
- apply HB.
Qed.

Example and_example' : 3 + 4 = 7 /\ 2 * 2 = 4.
Proof. hammer_hook "Logic" "Logic.and_example'".
apply and_intro.
-  reflexivity.
-  reflexivity.
Qed.

Example and_exercise :
forall n m : nat, n + m = 0 -> n = 0 /\ m = 0.
Proof. hammer_hook "Logic" "Logic.and_exercise".
Admitted.

Lemma and_example2 :
forall n m : nat, n = 0 /\ m = 0 -> n + m = 0.
Proof. hammer_hook "Logic" "Logic.and_example2".

intros n m H.
destruct H as [Hn Hm].
rewrite Hn. rewrite Hm.
reflexivity.
Qed.

Lemma and_example2' :
forall n m : nat, n = 0 /\ m = 0 -> n + m = 0.
Proof. hammer_hook "Logic" "Logic.and_example2'".
intros n m [Hn Hm].
rewrite Hn. rewrite Hm.
reflexivity.
Qed.

Lemma and_example2'' :
forall n m : nat, n = 0 -> m = 0 -> n + m = 0.
Proof. hammer_hook "Logic" "Logic.and_example2''".
intros n m Hn Hm.
rewrite Hn. rewrite Hm.
reflexivity.
Qed.

Lemma and_example3 :
forall n m : nat, n + m = 0 -> n * m = 0.
Proof. hammer_hook "Logic" "Logic.and_example3".

intros n m H.
assert (H' : n = 0 /\ m = 0).
{ apply and_exercise. apply H. }
destruct H' as [Hn Hm].
rewrite Hn. reflexivity.
Qed.

Lemma proj1 : forall P Q : Prop,
P /\ Q -> P.
Proof. hammer_hook "Logic" "Logic.proj1".
intros P Q [HP HQ].
apply HP.  Qed.

Lemma proj2 : forall P Q : Prop,
P /\ Q -> Q.
Proof. hammer_hook "Logic" "Logic.proj2".
Admitted.

Theorem and_commut : forall P Q : Prop,
P /\ Q -> Q /\ P.
Proof. hammer_hook "Logic" "Logic.and_commut".
intros P Q [HP HQ].
split.
-  apply HQ.
-  apply HP.  Qed.

Theorem and_assoc : forall P Q R : Prop,
P /\ (Q /\ R) -> (P /\ Q) /\ R.
Proof. hammer_hook "Logic" "Logic.and_assoc".
intros P Q R [HP [HQ HR]].
Admitted.

Check and.

Lemma or_example :
forall n m : nat, n = 0 \/ m = 0 -> n * m = 0.
Proof. hammer_hook "Logic" "Logic.or_example".

intros n m [Hn | Hm].
-
rewrite Hn. reflexivity.
-
rewrite Hm. rewrite <- mult_n_O.
reflexivity.
Qed.

Lemma or_intro : forall A B : Prop, A -> A \/ B.
Proof. hammer_hook "Logic" "Logic.or_intro".
intros A B HA.
left.
apply HA.
Qed.

Lemma zero_or_succ :
forall n : nat, n = 0 \/ n = S (pred n).
Proof. hammer_hook "Logic" "Logic.zero_or_succ".

intros [|n].
- left. reflexivity.
- right. reflexivity.
Qed.

Lemma mult_eq_0 :
forall n m, n * m = 0 -> n = 0 \/ m = 0.
Proof. hammer_hook "Logic" "Logic.mult_eq_0".
Admitted.

Theorem or_commut : forall P Q : Prop,
P \/ Q  -> Q \/ P.
Proof. hammer_hook "Logic" "Logic.or_commut".
Admitted.

Module MyNot.

Definition not (P:Prop) := P -> False.

Notation "~ x" := (not x) : type_scope.

Check not.

End MyNot.

Theorem ex_falso_quodlibet : forall (P:Prop),
False -> P.
Proof. hammer_hook "Logic" "Logic.ex_falso_quodlibet".

intros P contra.
destruct contra.  Qed.

Fact not_implies_our_not : forall (P:Prop),
~ P -> (forall (Q:Prop), P -> Q).
Proof. hammer_hook "Logic" "Logic.not_implies_our_not".
Admitted.

Theorem zero_not_one : 0 <> 1.
Proof. hammer_hook "Logic" "Logic.zero_not_one".

unfold not.

intros contra.

discriminate contra.
Qed.

Theorem not_False :
~ False.
Proof. hammer_hook "Logic" "Logic.not_False".
unfold not. intros H. destruct H. Qed.

Theorem contradiction_implies_anything : forall P Q : Prop,
(P /\ ~P) -> Q.
Proof. hammer_hook "Logic" "Logic.contradiction_implies_anything".

intros P Q [HP HNA]. unfold not in HNA.
apply HNA in HP. destruct HP.  Qed.

Theorem double_neg : forall P : Prop,
P -> ~~P.
Proof. hammer_hook "Logic" "Logic.double_neg".

intros P H. unfold not. intros G. apply G. apply H.  Qed.

Definition manual_grade_for_double_neg_inf : option (nat*string) := None.

Theorem contrapositive : forall (P Q : Prop),
(P -> Q) -> (~Q -> ~P).
Proof. hammer_hook "Logic" "Logic.contrapositive".
Admitted.

Theorem not_both_true_and_false : forall P : Prop,
~ (P /\ ~P).
Proof. hammer_hook "Logic" "Logic.not_both_true_and_false".
Admitted.

Definition manual_grade_for_informal_not_PNP : option (nat*string) := None.

Theorem not_true_is_false : forall b : bool,
b <> true -> b = false.
Proof. hammer_hook "Logic" "Logic.not_true_is_false".
intros [] H.
-
unfold not in H.
apply ex_falso_quodlibet.
apply H. reflexivity.
-
reflexivity.
Qed.

Theorem not_true_is_false' : forall b : bool,
b <> true -> b = false.
Proof. hammer_hook "Logic" "Logic.not_true_is_false'".
intros [] H.
-
unfold not in H.
exfalso.
apply H. reflexivity.
-  reflexivity.
Qed.

Lemma True_is_true : True.
Proof. hammer_hook "Logic" "Logic.True_is_true". apply I. Qed.

Module MyIff.

Definition iff (P Q : Prop) := (P -> Q) /\ (Q -> P).

Notation "P <-> Q" := (iff P Q)
(at level 95, no associativity)
: type_scope.

End MyIff.

Theorem iff_sym : forall P Q : Prop,
(P <-> Q) -> (Q <-> P).
Proof. hammer_hook "Logic" "Logic.iff_sym".

intros P Q [HAB HBA].
split.
-  apply HBA.
-  apply HAB.  Qed.

Lemma not_true_iff_false : forall b,
b <> true <-> b = false.
Proof. hammer_hook "Logic" "Logic.not_true_iff_false".

intros b. split.
-  apply not_true_is_false.
-
intros H. rewrite H. intros H'. discriminate H'.
Qed.

Theorem iff_refl : forall P : Prop,
P <-> P.
Proof. hammer_hook "Logic" "Logic.iff_refl".
Admitted.

Theorem iff_trans : forall P Q R : Prop,
(P <-> Q) -> (Q <-> R) -> (P <-> R).
Proof. hammer_hook "Logic" "Logic.iff_trans".
Admitted.

Theorem or_distributes_over_and : forall P Q R : Prop,
P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R).
Proof. hammer_hook "Logic" "Logic.or_distributes_over_and".
Admitted.

From Coq Require Import Setoids.Setoid.

Lemma mult_0 : forall n m, n * m = 0 <-> n = 0 \/ m = 0.
Proof. hammer_hook "Logic" "Logic.mult_0".
split.
- apply mult_eq_0.
- apply or_example.
Qed.

Lemma or_assoc :
forall P Q R : Prop, P \/ (Q \/ R) <-> (P \/ Q) \/ R.
Proof. hammer_hook "Logic" "Logic.or_assoc".
intros P Q R. split.
- intros [H | [H | H]].
+ left. left. apply H.
+ left. right. apply H.
+ right. apply H.
- intros [[H | H] | H].
+ left. apply H.
+ right. left. apply H.
+ right. right. apply H.
Qed.

Lemma mult_0_3 :
forall n m p, n * m * p = 0 <-> n = 0 \/ m = 0 \/ p = 0.
Proof. hammer_hook "Logic" "Logic.mult_0_3".
intros n m p.
rewrite mult_0. rewrite mult_0. rewrite or_assoc.
reflexivity.
Qed.

Lemma apply_iff_example :
forall n m : nat, n * m = 0 -> n = 0 \/ m = 0.
Proof. hammer_hook "Logic" "Logic.apply_iff_example".
intros n m H. apply mult_0. apply H.
Qed.

Lemma four_is_even : exists n : nat, 4 = n + n.
Proof. hammer_hook "Logic" "Logic.four_is_even".
exists 2. reflexivity.
Qed.

Theorem exists_example_2 : forall n,
(exists m, n = 4 + m) ->
(exists o, n = 2 + o).
Proof. hammer_hook "Logic" "Logic.exists_example_2".

intros n [m Hm].
exists (2 + m).
apply Hm.  Qed.

Theorem dist_not_exists : forall (X:Type) (P : X -> Prop),
(forall x, P x) -> ~ (exists x, ~ P x).
Proof. hammer_hook "Logic" "Logic.dist_not_exists".
Admitted.

Theorem dist_exists_or : forall (X:Type) (P Q : X -> Prop),
(exists x, P x \/ Q x) <-> (exists x, P x) \/ (exists x, Q x).
Proof. hammer_hook "Logic" "Logic.dist_exists_or".
Admitted.

Fixpoint In {A : Type} (x : A) (l : list A) : Prop :=
match l with
| [] => False
| x' :: l' => x' = x \/ In x l'
end.

Example In_example_1 : In 4 [1; 2; 3; 4; 5].
Proof. hammer_hook "Logic" "Logic.In_example_1".

simpl. right. right. right. left. reflexivity.
Qed.

Example In_example_2 :
forall n, In n [2; 4] ->
exists n', n = 2 * n'.
Proof. hammer_hook "Logic" "Logic.In_example_2".

simpl.
intros n [H | [H | []]].
- exists 1. rewrite <- H. reflexivity.
- exists 2. rewrite <- H. reflexivity.
Qed.

Lemma In_map :
forall (A B : Type) (f : A -> B) (l : list A) (x : A),
In x l ->
In (f x) (map f l).
Proof. hammer_hook "Logic" "Logic.In_map".
intros A B f l x.
induction l as [|x' l' IHl'].
-
simpl. intros [].
-
simpl. intros [H | H].
+ rewrite H. left. reflexivity.
+ right. apply IHl'. apply H.
Qed.

Lemma In_map_iff :
forall (A B : Type) (f : A -> B) (l : list A) (y : B),
In y (map f l) <->
exists x, f x = y /\ In x l.
Proof. hammer_hook "Logic" "Logic.In_map_iff".
Admitted.

Lemma In_app_iff : forall A l l' (a:A),
In a (l++l') <-> In a l \/ In a l'.
Proof. hammer_hook "Logic" "Logic.In_app_iff".
Admitted.

Fixpoint All {T : Type} (P : T -> Prop) (l : list T) : Prop
. Admitted.

Lemma All_In :
forall T (P : T -> Prop) (l : list T),
(forall x, In x l -> P x) <->
All P l.
Proof. hammer_hook "Logic" "Logic.All_In".
Admitted.

Definition combine_odd_even (Podd Peven : nat -> Prop) : nat -> Prop
. Admitted.

Theorem combine_odd_even_intro :
forall (Podd Peven : nat -> Prop) (n : nat),
(oddb n = true -> Podd n) ->
(oddb n = false -> Peven n) ->
combine_odd_even Podd Peven n.
Proof. hammer_hook "Logic" "Logic.combine_odd_even_intro".
Admitted.

Theorem combine_odd_even_elim_odd :
forall (Podd Peven : nat -> Prop) (n : nat),
combine_odd_even Podd Peven n ->
oddb n = true ->
Podd n.
Proof. hammer_hook "Logic" "Logic.combine_odd_even_elim_odd".
Admitted.

Theorem combine_odd_even_elim_even :
forall (Podd Peven : nat -> Prop) (n : nat),
combine_odd_even Podd Peven n ->
oddb n = false ->
Peven n.
Proof. hammer_hook "Logic" "Logic.combine_odd_even_elim_even".
Admitted.

Check plus_comm.

Lemma plus_comm3 :
forall x y z, x + (y + z) = (z + y) + x.

Proof. hammer_hook "Logic" "Logic.plus_comm3".

intros x y z.
rewrite plus_comm.
rewrite plus_comm.

Abort.

Lemma plus_comm3_take2 :
forall x y z, x + (y + z) = (z + y) + x.
Proof. hammer_hook "Logic" "Logic.plus_comm3_take2".
intros x y z.
rewrite plus_comm.
assert (H : y + z = z + y).
{ rewrite plus_comm. reflexivity. }
rewrite H.
reflexivity.
Qed.

Lemma plus_comm3_take3 :
forall x y z, x + (y + z) = (z + y) + x.
Proof. hammer_hook "Logic" "Logic.plus_comm3_take3".
intros x y z.
rewrite plus_comm.
rewrite (plus_comm y z).
reflexivity.
Qed.

Lemma in_not_nil :
forall A (x : A) (l : list A), In x l -> l <> [].
Proof. hammer_hook "Logic" "Logic.in_not_nil".
intros A x l H. unfold not. intro Hl. destruct l.
- simpl in H. destruct H.
- discriminate Hl.
Qed.

Lemma in_not_nil_42 :
forall l : list nat, In 42 l -> l <> [].
Proof. hammer_hook "Logic" "Logic.in_not_nil_42".

intros l H.
Fail apply in_not_nil.
Abort.

Lemma in_not_nil_42_take2 :
forall l : list nat, In 42 l -> l <> [].
Proof. hammer_hook "Logic" "Logic.in_not_nil_42_take2".
intros l H.
apply in_not_nil with (x := 42).
apply H.
Qed.

Lemma in_not_nil_42_take3 :
forall l : list nat, In 42 l -> l <> [].
Proof. hammer_hook "Logic" "Logic.in_not_nil_42_take3".
intros l H.
apply in_not_nil in H.
apply H.
Qed.

Lemma in_not_nil_42_take4 :
forall l : list nat, In 42 l -> l <> [].
Proof. hammer_hook "Logic" "Logic.in_not_nil_42_take4".
intros l H.
apply (in_not_nil nat 42).
apply H.
Qed.

Lemma in_not_nil_42_take5 :
forall l : list nat, In 42 l -> l <> [].
Proof. hammer_hook "Logic" "Logic.in_not_nil_42_take5".
intros l H.
apply (in_not_nil _ _ _ H).
Qed.

Example lemma_application_ex :
forall {n : nat} {ns : list nat},
In n (map (fun m => m * 0) ns) ->
n = 0.
Proof. hammer_hook "Logic" "Logic.lemma_application_ex".
intros n ns H.
destruct (proj1 _ _ (In_map_iff _ _ _ _ _) H)
as [m [Hm _]].
rewrite mult_0_r in Hm. rewrite <- Hm. reflexivity.
Qed.

Example function_equality_ex1 :
(fun x => 3 + x) = (fun x => (pred 4) + x).
Proof. hammer_hook "Logic" "Logic.function_equality_ex1". reflexivity. Qed.

Example function_equality_ex2 :
(fun x => plus x 1) = (fun x => plus 1 x).
Proof. hammer_hook "Logic" "Logic.function_equality_ex2".

Abort.

Axiom functional_extensionality : forall {X Y: Type}
{f g : X -> Y},
(forall (x:X), f x = g x) -> f = g.

Example function_equality_ex2 :
(fun x => plus x 1) = (fun x => plus 1 x).
Proof. hammer_hook "Logic" "Logic.function_equality_ex2".
apply functional_extensionality. intros x.
apply plus_comm.
Qed.

Print Assumptions function_equality_ex2.

Fixpoint rev_append {X} (l1 l2 : list X) : list X :=
match l1 with
| [] => l2
| x :: l1' => rev_append l1' (x :: l2)
end.

Definition tr_rev {X} (l : list X) : list X :=
rev_append l [].

Lemma tr_rev_correct : forall X, @tr_rev X = @rev X.
Admitted.

Example even_42_bool : evenb 42 = true.
Proof. hammer_hook "Logic" "Logic.even_42_bool". reflexivity. Qed.

Example even_42_prop : exists k, 42 = double k.
Proof. hammer_hook "Logic" "Logic.even_42_prop". exists 21. reflexivity. Qed.

Theorem evenb_double : forall k, evenb (double k) = true.
Proof. hammer_hook "Logic" "Logic.evenb_double".
intros k. induction k as [|k' IHk'].
- reflexivity.
- simpl. apply IHk'.
Qed.

Theorem evenb_double_conv : forall n,
exists k, n = if evenb n then double k
else S (double k).
Proof. hammer_hook "Logic" "Logic.evenb_double_conv".

Admitted.

Theorem even_bool_prop : forall n,
evenb n = true <-> exists k, n = double k.
Proof. hammer_hook "Logic" "Logic.even_bool_prop".
intros n. split.
- intros H. destruct (evenb_double_conv n) as [k Hk].
rewrite Hk. rewrite H. exists k. reflexivity.
- intros [k Hk]. rewrite Hk. apply evenb_double.
Qed.

Theorem eqb_eq : forall n1 n2 : nat,
n1 =? n2 = true <-> n1 = n2.
Proof. hammer_hook "Logic" "Logic.eqb_eq".
intros n1 n2. split.
- apply eqb_true.
- intros H. rewrite H. rewrite <- eqb_refl. reflexivity.
Qed.

Fail Definition is_even_prime n :=
if n = 2 then true
else false.

Example even_1000 : exists k, 1000 = double k.

Proof. hammer_hook "Logic" "Logic.even_1000". exists 500. reflexivity. Qed.

Example even_1000' : evenb 1000 = true.
Proof. hammer_hook "Logic" "Logic.even_1000'". reflexivity. Qed.

Example even_1000'' : exists k, 1000 = double k.
Proof. hammer_hook "Logic" "Logic.even_1000''". apply even_bool_prop. reflexivity. Qed.

Example not_even_1001 : evenb 1001 = false.
Proof. hammer_hook "Logic" "Logic.not_even_1001".

reflexivity.
Qed.

Example not_even_1001' : ~(exists k, 1001 = double k).
Proof. hammer_hook "Logic" "Logic.not_even_1001'".

rewrite <- even_bool_prop.
unfold not.
simpl.
intro H.
discriminate H.
Qed.

Lemma plus_eqb_example : forall n m p : nat,
n =? m = true -> n + p =? m + p = true.
Proof. hammer_hook "Logic" "Logic.plus_eqb_example".

intros n m p H.
rewrite eqb_eq in H.
rewrite H.
rewrite eqb_eq.
reflexivity.
Qed.

Lemma andb_true_iff : forall b1 b2:bool,
b1 && b2 = true <-> b1 = true /\ b2 = true.
Proof. hammer_hook "Logic" "Logic.andb_true_iff".
Admitted.

Lemma orb_true_iff : forall b1 b2,
b1 || b2 = true <-> b1 = true \/ b2 = true.
Proof. hammer_hook "Logic" "Logic.orb_true_iff".
Admitted.

Theorem eqb_neq : forall x y : nat,
x =? y = false <-> x <> y.
Proof. hammer_hook "Logic" "Logic.eqb_neq".
Admitted.

Fixpoint eqb_list {A : Type} (eqb : A -> A -> bool)
(l1 l2 : list A) : bool
. Admitted.

Lemma eqb_list_true_iff :
forall A (eqb : A -> A -> bool),
(forall a1 a2, eqb a1 a2 = true <-> a1 = a2) ->
forall l1 l2, eqb_list eqb l1 l2 = true <-> l1 = l2.
Proof. hammer_hook "Logic" "Logic.eqb_list_true_iff".
Admitted.

Fixpoint forallb {X : Type} (test : X -> bool) (l : list X) : bool :=
match l with
| [] => true
| x :: l' => andb (test x) (forallb test l')
end.

Theorem forallb_true_iff : forall X test (l : list X),
forallb test l = true <-> All (fun x => test x = true) l.
Proof. hammer_hook "Logic" "Logic.forallb_true_iff".
Admitted.

Definition excluded_middle := forall P : Prop,
P \/ ~ P.

Theorem restricted_excluded_middle : forall P b,
(P <-> b = true) -> P \/ ~ P.
Proof. hammer_hook "Logic" "Logic.restricted_excluded_middle".
intros P [] H.
- left. rewrite H. reflexivity.
- right. rewrite H. intros contra. discriminate contra.
Qed.

Theorem restricted_excluded_middle_eq : forall (n m : nat),
n = m \/ n <> m.
Proof. hammer_hook "Logic" "Logic.restricted_excluded_middle_eq".
intros n m.
apply (restricted_excluded_middle (n = m) (n =? m)).
symmetry.
apply eqb_eq.
Qed.

Theorem excluded_middle_irrefutable: forall (P:Prop),
~ ~ (P \/ ~ P).
Proof. hammer_hook "Logic" "Logic.excluded_middle_irrefutable".
Admitted.

Theorem not_exists_dist :
excluded_middle ->
forall (X:Type) (P : X -> Prop),
~ (exists x, ~ P x) -> (forall x, P x).
Proof. hammer_hook "Logic" "Logic.not_exists_dist".
Admitted.

Definition peirce := forall P Q: Prop,
((P->Q)->P)->P.

Definition double_negation_elimination := forall P:Prop,
~~P -> P.

Definition de_morgan_not_and_not := forall P Q:Prop,
~(~P /\ ~Q) -> P\/Q.

Definition implies_to_or := forall P Q:Prop,
(P->Q) -> (~P\/Q).


(*** Coq coding by choukh, Sep 2022 ***)

Require Ch3 Lib.
From Category.Theory Require Natural.Transformation.
From Category.Instance Require Cat Coq Fun Parallel.
Import Lib.

Section Ch6_1.
Import Natural.Transformation.
Context {C D : Category} {F G H J : C ⟶ D}.

Fact nat_id_left (N : F ⟹ G) : nat_id ∙ N ≈ N.
Proof. unfold nat_id; simpl; intros; cat. Qed.

Fact nat_id_right (N : F ⟹ G) : N ∙ nat_id ≈ N.
Proof. unfold nat_id; simpl; intros; cat. Qed.

Fact nat_comp_assoc (M : H ⟹ J) (N : G ⟹ H) (O : F ⟹ G) :
  M ∙ (N ∙ O) ≈ (M ∙ N) ∙ O.
Proof. unfold nat_compose; simpl; intros; cat. Qed.

End Ch6_1.

Section Ch6_1.
Import Fun.
Context {A B C D : Category} (F : C ⟶ D) (G : B ⟶ C) (H : A ⟶ B).

Program Definition funtor_id_left : Id ◯ F ≈ F := _.
Program Definition funtor_id_left_sym : F ≈ Id ◯ F := _.
Program Definition funtor_id_right : F ◯ Id ≈ F := _.
Program Definition funtor_id_right_sym : F ≈ F ◯ Id := _.
Program Definition funtor_comp_assoc : F ◯ (G ◯ H) ≈ (F ◯ G) ◯ H := _.
Program Definition funtor_comp_assoc_sym : (F ◯ G) ◯ H ≈ F ◯ (G ◯ H) := _.

Program Definition fun_id_left : Id ◯ F ⟹ F := {| transform := _ |}.
Program Definition fun_id_left_sym : F ⟹ Id ◯ F := {| transform := _ |}.
Program Definition fun_id_right : F ◯ Id ⟹ F := {| transform := _ |}.
Program Definition fun_id_right_sym : F ⟹ F ◯ Id := {| transform := _ |}.
Program Definition fun_comp_assoc : F ◯ (G ◯ H) ⟹ (F ◯ G) ◯ H := {| transform := _ |}.
Program Definition fun_comp_assoc_sym : (F ◯ G) ◯ H ⟹ F ◯ (G ◯ H) := {| transform := _ |}.

Program Definition nat_λ : F ◯ Id ≅[Fun] F := {|
  to := fun_id_right;
  from := fun_id_right_sym
|}.

Program Definition nat_ρ : Id ◯ F ≅[Fun] F := {|
  to := fun_id_left;
  from := fun_id_left_sym
|}.

Program Definition nat_α : F ◯ (G ◯ H) ≅[Fun] (F ◯ G) ◯ H := {|
  to := fun_comp_assoc;
  from := fun_comp_assoc_sym
|}.

End Ch6_1.

Section Ch6_1_1.
Import Fun.
Context {C D : Category} (F G : C ⟶ D).

(* same as Functor_Setoid_Nat_Iso in lib *)
Theorem natural_iso : F ≅[Fun] G ↔ F ≈ G.
Proof. split.
  - intros []. construct.
    + isomorphism; simpl in *.
      * apply to.
      * apply from.
      * simpl. srewrite iso_to_from. cat.
      * simpl. srewrite iso_from_to. cat.
    + simpl. rewrite <- comp_assoc, (naturality[to]), comp_assoc.
      srewrite iso_from_to. cat.
  - intros [iso eq]. isomorphism; simpl.
    + transform.
      * apply iso.
      * simpl. rewrite eq, !comp_assoc, iso_to_from. cat.
      * simpl. rewrite eq, !comp_assoc, iso_to_from. cat.
    + transform.
      * apply iso.
      * simpl. rewrite eq, <- !comp_assoc, iso_to_from. cat.
      * simpl. rewrite eq, <- !comp_assoc, iso_to_from. cat.
    + simpl. rewrite iso_to_from. cat.
    + simpl. rewrite iso_from_to. cat.
Defined.

End Ch6_1_1.

Section Ch6_3.
Import Ch3 Cat Coq Fun Parallel Opposite.

Notation "⇊" := Parallel.

(* This construction could take 2 minutes to build *)
Program Definition Gph_Iso : [⇊^op, Coq] ≅ Gph := {|
  to := {|
    fobj F := {|
      vertex := F ParX;
      edge := F ParY;
      endpoint b := match b with
        | true => fmap[F] (true; ParOne)
        | false => fmap[F] (false; ParTwo)
        end
    |};
    fmap _ _ f := {|
      αᵥ := f ParX;
      αₑ := f ParY;
      source_morph := f.(naturality);
      target_morph := f.(naturality)
    |};
    fmap_id F := (λ x, F.(fmap_id) x, λ x, F.(fmap_id) x)
  |};
  from := {|
    fobj G := {|
      fobj x := match x with
        | ParX => G.(vertex)
        | ParY => G.(edge)
        end;
      fmap x y f := match x, y with
        | ParX, ParX => id
        | ParY, ParY => id
        | ParX, ParY => False_rect _ (ParHom_Y_X_absurd _ (`2 f))
        | ParY, ParX => match ``f with
          | true  => G.(source)
          | false => G.(target)
          end
        end
    |};
    fmap _ _ f := {|
      transform x := match x with
        | ParX => f.(αᵥ)
        | ParY => f.(αₑ)
        end
    |}
  |};
  iso_to_from := (λ A, {|
    to := {| αᵥ := λ x, x; αₑ := λ x, x |};
    from := {| αᵥ := λ x, x; αₑ := λ x, x |}
  |}; _);
|}.
(* from.fobj.fmap_respects *)
Next Obligation. proper. now destruct e0; destruct e. Defined.
(* from.fobj.fmap_id *)
Next Obligation. destruct x; reflexivity. Defined.
(* from.fobj.fmap_comp *)
Next Obligation. destruct X; dependent destruction X0; reflexivity. Defined.
(* from.fmap.naturality *)
Next Obligation. destruct X; destruct f; simpl; congruence. Defined.
(* from.fmap.naturality_sym *)
Next Obligation. destruct X; destruct f; simpl; congruence. Defined.
(* from.fmap_respects *)
Next Obligation. proper. destruct A; trivial. Defined.
(* from.fmap_id *)
Next Obligation. destruct A; reflexivity. Defined.
(* from.fmap_comp *)
Next Obligation. destruct A; destruct f, g; reflexivity. Defined.
(* iso_to_from.functor_setoid.iso.condition *)
Next Obligation. destruct f; easy. Defined.
(* iso_from_to.functor_setoid *)
Next Obligation. unshelve eexists.
  - (* iso *) intros F. construct.
    + (* to *) transform; simpl.
      * intros []; trivial.
      * (* natuality *)
        destruct F; destruct f; dependent destruction p; simpl.
        1-2:rewrite fmap_id. all:reflexivity.
      * (* natuality_sym *)
        destruct F; destruct f; dependent destruction p; simpl.
        1-2:rewrite fmap_id. all:reflexivity.
    + (* from *) transform; simpl.
      * intros []; trivial.
      * (* natuality *)
        destruct F; destruct f; dependent destruction p; simpl.
        1-2:rewrite fmap_id. all:reflexivity.
      * (* natuality_sym *)
        destruct F; destruct f; dependent destruction p; simpl.
        1-2:rewrite fmap_id. all:reflexivity.
    + (* iso_to_from *)
      destruct F; destruct A; simpl; rewrite fmap_id; reflexivity.
    + (* iso_from_to *) destruct A; reflexivity.
  - intros F G n []; reflexivity.
Defined.

End Ch6_3.