From mathcomp Require Import all_ssreflect.
From mathcomp Require Import all_algebra.
From mathcomp Require Import all_fingroup.
From mathcomp Require Import all_real_closed.
From CoqEAL Require Import binetcauchy ssrcomplements mxstructure minor.
From CoqEAL Require Import smith dvdring polydvd.
From CoqEAL Require Import similar perm_eq_image companion closed_poly smith_complements.

(**  This file provides a theory of invariant factors. The main result
     proved here is the similarity between a matrix and its Frobenius
     normal form.

        Frobenius_seq M == The same as the sequence Smith_seq (XI - M) where
                           each polynomial has been divded by their
                           lead coefficient (Hence each polynomial is monic).
    invariant_factors M == The sequence of non-constant polynomials of
                           Frobenius_seq M.
       Frobenius_form M == The block diagonal matrix formed by the
                           companion matrices of the invariant factors of M.
    Frobenius_form_CF M == The block diagonal matrix defined over a closed
                           field formed by the companion matrices of
                           the linear factors of the invariant factors of M.

                                                                              *)

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

Section Frobenius.

Variable F : fieldType.
Local Notation E := {poly F}.
Import GRing.Theory.
Import PolyPriField.
Local Open Scope ring_scope.

Definition Frobenius_seq n (A : 'M[F]_n) :=
  [seq (lead_coef p)^-1 *: p | p : E <- take n (Smith_seq (char_poly_mx A))].

Lemma sorted_Frobenius_seq n (A : 'M[F]_n) :
  sorted (@dvdp _) (Frobenius_seq A).
Proof.
case: n A=> // n A.
have Hp: forall (p : E), ((lead_coef p)^-1 *: p %= p)%P.
  move=> p; have [-> | p0] := eqVneq p 0; first by rewrite scaler0 eqpxx.
  apply/eqpP; exists ((lead_coef p),1).
    by rewrite oner_neq0 andbT lead_coef_eq0.
  rewrite scalerA mulrV ?scale1r //.
  by rewrite unitfE lead_coef_eq0.
suff : sorted (@dvdr _) (Frobenius_seq A).
  by apply: sorted_trans=> x y _ _; rewrite dvdr_dvdp=> ->.
have /mono_sorted it
  : {mono (fun p : {poly F} => (lead_coef p)^-1 *: p) : x y /
   x %| y}.
  by move=> x y; rewrite !dvdr_dvdp (eqp_dvdl _ (Hp x)) (eqp_dvdr _ (Hp y)).
rewrite it.
set s := Smith_seq _.
apply/(sorted_take (@dvdr_trans _))/sorted_Smith.
Qed.

Lemma size_Frobenius_seq n (A : 'M[F]_n) : size (Frobenius_seq A) = n.
Proof.
by rewrite size_map size_Smith_seq // -size_poly_eq0 size_char_poly.
Qed.

Lemma Frobenius_seq_char_poly n (A : 'M[F]_n) :
\prod_(p <- Frobenius_seq A) p = char_poly A.
Proof.
rewrite big_map scaler_prod prodfV.
have Hs m (B : 'M[F]_m): size (take m (Smith_seq (char_poly_mx B))) = m.
  by move: (size_Frobenius_seq B); rewrite size_map.
have Hp1: \prod_(i <- (take n (Smith_seq (char_poly_mx A)))) i = char_poly A.
  case: n A => [A| n A]; first by rewrite big_nil /char_poly det_mx00.
  rewrite -(det_diag_mx_seq (Hs _ A)).
  by rewrite diag_mx_seq_takel det_Smith.
have ->: \prod_(i <- (take n (Smith_seq (char_poly_mx A)))) lead_coef i = 1.
  rewrite lead_coef_prod Hp1.
  by apply/monicP/char_poly_monic.
by rewrite Hp1 invr1 scale1r.
Qed.

Lemma Frobenius_seq_neq0 n (A : 'M[F]_n) p :
   p \in Frobenius_seq A -> p != 0.
Proof.
have Hc := (Frobenius_seq_char_poly A).
have: char_poly A != 0.
  by rewrite -size_poly_eq0 size_char_poly.
rewrite -Hc (big_nth 0) big_mkord.
move/prodf_neq0=> H0 /(nthP 0) [i Hi] <-.
exact: (H0 (Ordinal Hi)).
Qed.

Lemma monic_Frobenius_seq n (A : 'M[F]_n) p:
 p \in Frobenius_seq A -> p \is monic.
Proof.
move=> Hp.
have := Frobenius_seq_neq0 Hp.
move: Hp; rewrite /Frobenius_seq=> /(nthP 0) []i.
rewrite size_map=> Hi; rewrite (nth_map 0) // => <-.
rewrite scaler_eq0 negb_or=> /andP [_ H0].
by apply: monic_leadVMp; rewrite unitfE lead_coef_eq0.
Qed.

Lemma equiv_Frobenius_seq n (A : 'M[F]_n) :
  equivalent (diag_mx_seq n n (Smith_seq (char_poly_mx A)))
     (diag_mx_seq n n (Frobenius_seq A)).
Proof.
rewrite -diag_mx_seq_takel.
apply: eqd_equiv=> // [|i]; first by rewrite size_map.
set s := take _ _.
case: (ltnP i (size s)) => Hi; last by rewrite !nth_default // size_map.
rewrite (nth_map 0) //; apply/eqdP.
exists ((lead_coef s`_i)^-1%:P).
  have Hin: (Frobenius_seq A)`_i \in Frobenius_seq A.
    by rewrite mem_nth // size_map.
  have:= Frobenius_seq_neq0 Hin.
  rewrite (nth_map 0) // scaler_eq0 negb_or=> /andP [Hl _].
  by rewrite rmorph_unit // unitfE.
by rewrite mul_polyC.
Qed.

Definition invariant_factors n (A : 'M[F]_n) :=
  filter (fun p : E => (1 < size p)%N) (Frobenius_seq A).

Lemma invariant_factor_neq0 n (A : 'M[F]_n) :
 forall p, p \in invariant_factors A -> p != 0.
Proof.
by move=> p; rewrite mem_filter; case/andP=> _; exact: Frobenius_seq_neq0.
Qed.

Lemma monic_invariant_factors n (A : 'M[F]_n) :
  forall p, p \in invariant_factors A -> p \is monic.
Proof.
by move=> p; rewrite mem_filter; case/andP=> _; apply: monic_Frobenius_seq.
Qed.

Section dvdp_monic.

Local Open Scope ring_scope.
Import GRing.Theory.
Import PolyPriField.
Variable T : fieldType.

Definition dvdpm (p q : {poly T}) :=
  (p \is monic) && (q \is monic) && (dvdp p q).

Lemma dvdpm_trans : transitive dvdpm.
Proof.
move=> p q r /andP [] /andP [] Hq Hp Hqp /andP [] /andP [] _ Hr Hpr.
apply/andP; split; first by apply/andP.
exact: (dvdp_trans Hqp).
Qed.

Lemma dvdpm_asym : antisymmetric dvdpm.
Proof.
move=> p q /andP [] /andP [] /andP [] Hp Hq Hpq /andP [] _ Hqp.
by apply/eqP; rewrite -eqp_monic // /eqp Hpq.
Qed.

Lemma dvd1pm (p : {poly T}) : p \is monic -> dvdpm 1 p.
Proof.
have H1:= (@monic1 T).
move=> Hp; apply/andP; split; first by apply/andP.
by rewrite dvd1p.
Qed.

End dvdp_monic.

Lemma Frobenius_seqE n (A : 'M[F]_n) : Frobenius_seq A =
  nseq (n - size (invariant_factors A)) 1 ++ invariant_factors A.
Proof.
set m := subn _ _.
have HfA:= (size_Frobenius_seq A).
have Hfrob: sorted (@dvdpm F) (Frobenius_seq A).
  have Hdvd: {in (Frobenius_seq A) &, forall p q, dvdp p q -> dvdpm p q}.
    move=> p q /= /monic_Frobenius_seq Hp /monic_Frobenius_seq Hq H.
    by rewrite /dvdpm Hp Hq H.
  by apply/(sorted_trans Hdvd)/sorted_Frobenius_seq.
have Hst: sorted (@dvdpm F) (nseq m 1 ++ invariant_factors A).
  apply: (@path_sorted _ _ 1); rewrite cat_path; apply/andP; split.
    apply/(pathP 0); rewrite size_nseq=> [][|i] Hi.
      by rewrite nth0 dvd1pm // nth_nseq Hi monic1.
    rewrite -nth_behead nth_nseq (ltn_trans (ltnSn i) Hi) dvd1pm //.
    by rewrite nth_nseq Hi monic1.
  rewrite path_min_sorted; [|apply/allP=>p Hp].
    by rewrite sorted_filter //;first exact: dvdpm_trans.
  rewrite -nth_last nth_nseq size_nseq.
  by case: (m.-1 < m)%N; rewrite dvd1pm //; apply: (monic_invariant_factors Hp).
apply: (sorted_eq (@dvdpm_trans F) (@dvdpm_asym F) Hfrob Hst).
pose a:= fun p : E => (size p <= 1)%N.
have HaC: {in (Frobenius_seq A), (fun p : E => (1 < size p)%N) =1 (predC a)}.
  by move=> p /=; rewrite -ltnNge.
have Hfi: (invariant_factors A) = filter (predC a) (Frobenius_seq A).
  by rewrite -(eq_in_filter HaC).
have Hm: m = size (filter a (Frobenius_seq A)).
  rewrite /m Hfi !size_filter.
  apply/eqP; rewrite -(eqn_add2r (count (predC a) (Frobenius_seq A))).
  by apply/eqP; rewrite subnK ?count_predC // -{2}HfA count_size.
have Hfn: nseq m 1 = filter a (Frobenius_seq A).
  apply: (@eq_from_nth _ 0)=> [|i]; first by rewrite size_nseq.
  rewrite size_nseq => Hi; rewrite nth_nseq Hi.
  have: (filter a (Frobenius_seq A))`_i \in (filter a (Frobenius_seq A)).
    by rewrite mem_nth // -Hm.
  rewrite mem_filter=> /andP [Ha1 Ha2].
  move: (monicP (monic_Frobenius_seq Ha2)).
  by rewrite (size1_polyC Ha1) lead_coefC => ->.
by rewrite perm_sym Hfn Hfi; apply/permPl/perm_filterC.
Qed.

Lemma invf_char_poly n (A : 'M[F]_n) :
\prod_(p <- invariant_factors A) p = char_poly A.
Proof.
rewrite -Frobenius_seq_char_poly Frobenius_seqE.
rewrite big_cat /= (big1_seq (nseq _ _)) ?mul1r // => i.
case/andP=> _ /(nthP 0) [j].
by rewrite size_nseq=> Hj; rewrite nth_nseq Hj=> ->.
Qed.

Lemma dvdp_invf_char_poly m (A : 'M[F]_m) (p : {poly F}) :
p \in (invariant_factors A) -> dvdp p (char_poly A).
Proof.
move=> Hp.
rewrite -invf_char_poly prod_seq_count.
have Hi: p \in undup (invariant_factors A) by rewrite mem_undup.
rewrite (bigD1_seq _ Hi) ?undup_uniq //= dvdp_mulr // dvdp_exp //.
by rewrite -has_count has_pred1.
Qed.

Lemma sorted_invf n (A : 'M[F]_n) : sorted (@dvdp _) (invariant_factors A).
Proof.
have := sorted_Frobenius_seq A.
rewrite Frobenius_seqE.
apply: subseq_sorted.
  exact: dvdp_trans.
exact: suffix_subseq.
Qed.

Lemma sum_size_inv_factors n (A : 'M[F]_n) :
  (\sum_(p <- invariant_factors A) (size p).-1 = n)%N.
Proof.
have {2}->: n = n.+1.-1 by [].
rewrite -(size_char_poly A) -invf_char_poly.
rewrite !(big_nth 0) !big_mkord size_prod=> [|i _]; last first.
  by apply: (@invariant_factor_neq0 _ A); rewrite mem_nth.
rewrite subSKn -sum1_card; apply/eqP.
set s := (\sum_(i in _) 1)%N.
rewrite -(eqn_add2r s) subnK.
  apply/eqP; rewrite -big_split /=; apply: eq_bigr=> i _.
  rewrite addn1 prednK // size_poly_gt0.
  by apply: (@invariant_factor_neq0 _ A); rewrite mem_nth.
apply: leq_sum=> i _; rewrite size_poly_gt0.
by apply: (@invariant_factor_neq0 _ A); rewrite mem_nth.
Qed.

Lemma nnil_inv_factors n (A : 'M_n.+1) : invariant_factors A != [::].
Proof.
apply: contraPneq (sum_size_inv_factors A) => ->.
by rewrite big_nil.
Qed.

Let Smith_block_cpmx  n (A : 'M[F]_n) :=
  let sp := invariant_factors A in
  let size := [seq (size p).-2 | p : E <- sp] in
  let blocks m i := diag_mx_seq m.+1 m.+1 (rcons (nseq m 1) sp`_i) in
  diag_block_mx size blocks.

Let Smith_seq_cpmx n (A : 'M[F]_n) :=
  let sp := invariant_factors A in
  let m := size_sum [seq (size p).-2 | p : E <- sp] in
  diag_mx_seq m.+1 m.+1 (Frobenius_seq A).

Lemma cast_inv n (A : 'M[F]_n.+1) :
  size (Frobenius_seq A) =
  (size_sum [seq (size p).-2 | p : E <- invariant_factors A]).+1.
Proof.
rewrite size_Frobenius_seq -{1}(sum_size_inv_factors A).
rewrite size_sum_big; last first.
  by rewrite -size_eq0 size_map size_eq0 nnil_inv_factors.
rewrite !big_map /=; apply: eq_big_seq=> i.
rewrite mem_filter=> /andP [Hi _].
by rewrite prednK // -subn1 subn_gt0.
Qed.

Lemma equiv_sbc_ssc n (A : 'M[F]_n) :
  equivalent (Smith_block_cpmx A) (Smith_seq_cpmx A).
Proof.
rewrite /Smith_block_cpmx /Smith_seq_cpmx Frobenius_seqE.
have: forall p, p \in invariant_factors A -> (0 < (size p).-1)%N.
  by move=> p; rewrite mem_filter -subn1 subn_gt0=> /andP [].
rewrite -{10}(sum_size_inv_factors A).
case: (invariant_factors A)=> [_|a l].
  by rewrite big_nil diag_mx_seq_nil; exact: equiv_refl.
elim: l a=> /= [a Hp|b l IHl a Hp].
  by rewrite big_cons big_nil addn0 subn1 cats1; exact: equiv_refl.
have IHp : forall p : E, p \in b :: l -> (0 < (size p).-1)%N.
  by move=> p H; apply: Hp; rewrite mem_behead.
have Ha: (0 < (size a).-1)%N by  rewrite Hp // mem_head.
have Hb: (0 < (size b).-1)%N by rewrite IHp // mem_head.
set M := diag_mx_seq _ _ _.
apply: (equiv_trans (equiv_drblockmx M (IHl b IHp))).
rewrite -diag_mx_seq_cat ?size_rcons ?size_nseq //.
set s2 := [seq (size p).-2 | p : E <- (b :: l)].
set k := (\sum_(_ <- _) _)%N.
set m := (\sum_(_ <- _) _)%N.
have Hk: k = (size_sum s2).+1.
  rewrite size_sum_big_cons /k !big_cons !big_map /= prednK //.
  congr (_ + _)%N; apply: eq_big_seq=> i Hi.
  by rewrite (@prednK (size i).-1) // IHp // mem_behead.
have Hltk : (size l < k)%N.
  rewrite /k (eq_big_seq (fun p : E => (size p).-2 + 1)%N).
  rewrite big_split /= addnC (big_nth 0) sum_nat_const_nat.
    by rewrite subn0 muln1 leq_addr.
  by move=> i Hi /=; rewrite addn1 prednK // IHp.
apply/similar_equiv/similar_diag_mx_seq=> //.
  by rewrite !size_cat size_rcons !size_nseq subnK // Hk.
apply/seq.permP=> x /=.
rewrite -cats1 !count_cat /= !count_nseq.
rewrite !addnA addn0 (addnAC _ (x a)) -mulnDr; congr (_ * _ + _ + _ + _)%N.
by rewrite /m big_cons (subnS _ (size l).+1) -{2}(prednK Ha) -addnBA //.
Qed.

Lemma Smith_companion (p : E) : (1 < size p)%N -> p \is monic ->
  equivalent (Smith_form (char_poly_mx (companion_mx p)))
  (diag_mx_seq (size p).-2.+1 (size p).-2.+1 (rcons (nseq (size p).-2 1) p)).
Proof.
move=> Hsp Hmp.
rewrite /Smith_form -diag_mx_seq_takel.
set s := take _ _.
have Hs1: (size p).-2.+1 = size s.
  by rewrite -(size_Frobenius_seq (companion_mx p)) size_map.
have Hs2: (size p).-2.+1 = size (rcons (nseq (size p).-2 1) p).
  by rewrite size_rcons size_nseq.
apply: eqd_equiv=> //; first by rewrite -Hs1 -Hs2.
have := leqnSn (size p).-2.
rewrite -[X in (_ <= X)%N]minnn=> Hop.
have Hsort: sorted %|%R s.
  by apply/(sorted_take (@dvdr_trans _))/sorted_Smith.
have := (equiv_Smith (char_poly_mx (companion_mx p))).
rewrite /Smith_form -diag_mx_seq_takel=> Hsm.
have {Hop Hsort Hsm} := (Smith_gcdr_spec Hop Hsort Hsm).
set d := \big[_/_]_(_<_) _=> H.
have {H} Hd1: d %= 1.
  apply/(eqd_trans H)/andP; split; last by rewrite dvd1r.
  apply: big_gcdr_def; exists (finfun (lift ord0)).
  apply: big_gcdr_def; exists (finfun (lift ord_max)).
  rewrite /minor.minor /minor.submatrix /=.
  set M := \matrix_(_,_) _.
  have Hut: upper_triangular_mx M.
    apply/upper_triangular_mxP => i j Hij.
    rewrite !mxE !ffunE -(inj_eq (@ord_inj _)) lift0 lift_max.
    rewrite !eqn_leq !(leqNgt _ j) ltn_ord subr0.
    by rewrite ltnW // ltnNge Hij !andFb subr0.
  rewrite (det_triangular_mx Hut).
  rewrite (eq_bigr (fun _ => -1)) ?prodr_const ?card_ord; last first.
    move=> i; rewrite !mxE !ffunE -(inj_eq (@ord_inj _)) lift0 lift_max.
    by rewrite eqxx !eqn_leq ltnn (leqNgt _ i) ltn_ord sub0r subr0.
  by apply/dvdrP; exists ((-1)^+ (size p).-2); rewrite -expr2 sqrr_sign.
have Hip: s`_(size p).-2 %= p.
  rewrite eqd_sym in Hd1.
  rewrite -(mul1r s`_(size p).-2) (eqd_ltrans (eqd_mulr _ Hd1)).
   rewrite -{2}(comp_char_polyK Hmp Hsp) /char_poly -det_Smith.
  rewrite /Smith_form -diag_mx_seq_takel.
  rewrite det_diag_mx_seq // eqd_sym (big_nth 0) big_mkord.
  by rewrite -Hs1 big_ord_recr /=.
move/eqd_big_mul1: Hd1 => H i.
case: (ltngtP i (size p).-2) => Hi.
- by rewrite nth_rcons size_nseq Hi nth_nseq Hi (H (Ordinal Hi)).
- by rewrite !nth_default // -?Hs1 // size_rcons size_nseq.
by rewrite nth_rcons size_nseq Hi eqxx ltnn.
Qed.

Definition Frobenius_form n (A : 'M[F]_n) :=
  let sp := invariant_factors A in
  let size := [seq (size p).-2 | p : E <- sp] in
  let blocks n i := [seq companion_mxn n.+1 p | p <- sp]`_i in
   diag_block_mx size blocks.

Lemma Frobenius n (A : 'M[F]_n.+1) :
  similar A (Frobenius_form A).
Proof.
apply/similar_fundamental; rewrite char_diag_block_mx; last first.
  by rewrite -size_eq0 size_map size_eq0 nnil_inv_factors.
apply: (equiv_trans (equiv_Smith (char_poly_mx A))).
rewrite /Smith_form.
apply/(equiv_trans (equiv_Frobenius_seq A))/equiv_sym.
have Hn := size_Frobenius_seq A.
rewrite /equivalent -{2 4 37 38 43 44}Hn cast_inv.
apply: (equiv_trans _ (equiv_sbc_ssc A)).
apply: equiv_diag_block=>[|i]; first by rewrite !size_map.
rewrite size_map=> Hi.
rewrite !(nth_map 0) //.
set C := char_poly_mx _.
apply: (equiv_trans (equiv_Smith C)).
apply: Smith_companion; move: (mem_nth 0 Hi).
  by rewrite mem_filter=> /andP [].
exact: monic_invariant_factors.
Qed.

Lemma Frobenius_unicity n m (A : 'M[F]_n) (B : 'M_m) : similar A B <->
  invariant_factors A = invariant_factors B.
Proof.
split=> [[Hmn H]|H]; rewrite /invariant_factors.
  congr filter; apply: (@eq_from_nth _ 0)=>[|i Hi].
    by rewrite !size_Frobenius_seq.
  have/Frobenius_seq_neq0 := mem_nth 0 Hi.
  rewrite size_Frobenius_seq in Hi.
  rewrite !(nth_map 0) ?size_Smith_seq -?Hmn -?size_poly_eq0 ?size_char_poly //.
  rewrite size_poly_eq0 scaler_eq0 negb_or invr_eq0=> /andP [Hl0 _].
  apply: (scalerI Hl0); rewrite !scalerA mulrV ?unitfE // scale1r.
  apply: eqpfP; rewrite /eqp -!dvdr_dvdp [X in take X]Hmn.
  rewrite Hmn in Hi; rewrite !nth_take //.
  apply: Smith_unicity => //; first exact: sorted_Smith.
  set D := char_poly_mx A.
  rewrite -{3 4 6 7}Hmn.
  apply: (equiv_trans _ (equiv_Smith D)).
  by apply/similar_fundamental/similar_sym.
have/eqP: n = m.
- by rewrite -(sum_size_inv_factors A) -(sum_size_inv_factors B) H.
case: n A H => [A|n A]; case: m B=> [B|m B] H Hmn //.
  exact: similar0.
apply/(similar_trans (Frobenius A))/similar_sym/(similar_trans (Frobenius B)).
rewrite /Frobenius_form H.
exact: similar_refl.
Qed.

Lemma mxminpoly_inv_factors n (A : 'M[F]_n.+1) :
  last 0 (Frobenius_seq A) = mxminpoly A.
Proof.
have Hif: (0 < size (invariant_factors A))%N.
  by rewrite lt0n size_eq0 nnil_inv_factors.
have Hfn: [seq (size p).-2 | p : E <- invariant_factors A] != [::].
  by rewrite -size_eq0 size_map size_eq0 nnil_inv_factors.
apply: mxminpolyP=> [||q HA].
- apply: (@monic_Frobenius_seq _ A).
  by rewrite -nth_last mem_nth // size_Frobenius_seq.
- apply: (similar_horner (similar_sym (Frobenius A))).
  rewrite horner_mx_diag_block //.
  apply/diag_block_mx0=> i; rewrite size_map=> Hi.
  rewrite !(nth_map 0) // Frobenius_seqE last_cat -nth_last.
  rewrite (set_nth_default 0) ?prednK // ?Hif //.
  set p := nth _ _ _.
  apply: (@horner_mx_dvdp _ _ p).
    apply: sorted_leq_nth=> //.
    - exact: dvdp_trans.
    - exact: sorted_invf.
    - by rewrite inE prednK.
    by rewrite -ltnS prednK.
  rewrite -{5}[p]comp_mxminpolyK.
  - exact: mx_root_minpoly.
  - exact: (monic_invariant_factors (mem_nth 0 Hi)).
  move: (mem_nth 0 Hi).
  by rewrite mem_filter -subn_gt0 subn1; case/andP.
move: (similar_horner (Frobenius A) HA).
rewrite horner_mx_diag_block // => /diag_block_mx0=> H.
rewrite Frobenius_seqE last_cat -nth_last (set_nth_default 0) ?prednK //.
move: (H (size (invariant_factors A)).-1).
rewrite size_map !(nth_map 0) ?prednK //.
set p := nth _ _ _=> Hp.
have Hm:= @mem_nth _ 0 (invariant_factors A) (size (invariant_factors A)).-1.
rewrite -[p]comp_mxminpolyK ?dvdr_dvdp.
- exact: (mxminpoly_min (Hp (leqnn _))).
- apply/(@monic_invariant_factors _ A)/Hm.
  by rewrite prednK // mem_filter -subn_gt0 subn1.
move: Hm; rewrite prednK // mem_filter -subn_gt0 subn1=> h.
by case/andP: (h (leqnn _)).
Qed.

End Frobenius.

Section Polynomial.

Local Open Scope ring_scope.
Import GRing.Theory.
Import PolyPriField.

Variable R : closedFieldType.

Lemma similar_poly_inv (p : {poly R}) :
  let sp := linear_factor_seq p in
  let size_seq := [seq (size p).-2 | p : {poly R} <- sp] in
  let blocks n i := companion_mxn n.+1 sp`_i in
  (1 < (size p))%N ->  p \is monic ->
  similar (companion_mx p) (diag_block_mx size_seq blocks).
Proof.
move=> /= Hp1 Hmp.
move: (@coprimep_linear_factor_seq _ p).
move: (@monic_linear_factor_seq _ p).
move: (@size_linear_factor_leq1 _ p).
move: Hmp Hp1 (monic_prod_factor Hmp).
elim: (linear_factor_seq p) {1 2 3 14 16}p.
  move=> p0 Hmp0 Hsp0; rewrite big_nil=> H.
  by rewrite H size_poly1 in Hsp0.
move=> a; case=> [_ p1 _ _ Hp1 _ _ _ | b l IHl p1 Hmp1 Hsp1 Hp1 Hs Hm Hcp] /=.
  rewrite Hp1 big_cons big_nil mulr1.
  by apply: similar_refl.
have Hicp : forall i j : 'I_(size (b :: l)), i != j ->
    coprimep (b :: l)`_i (b :: l)`_j.
  move=> i j H.
  have Hij: (lift ord0 i) != (lift ord0 j).
    by apply/val_eqP=> /lift_inj; apply/eqP.
  by move: (Hcp _ _ Hij); rewrite -!nth_behead.
pose p2:= p1 %/ a.
have Hma: a \is monic by apply: Hm; rewrite mem_head.
have Hsa: (1 < size a)%N by apply: Hs; rewrite mem_head.
have Hp2: p2 = \prod_(x <- (b :: l)) x.
  by rewrite /p2 Hp1 big_cons divr_mulKr // monic_neq0.
have Hml: forall x, x \in (b :: l) -> x \is monic.
  by move=> x Hx; apply: Hm; rewrite mem_behead.
have Hsl: forall x, x \in b :: l -> (1 < size x)%N.
  by move=> x Hx; apply: Hs; rewrite mem_behead.
have {Hs} Hsb: (1 < size b)%N by apply: Hsl; rewrite mem_head.
have {Hm} Hmb: b \is monic by apply: Hml; rewrite mem_head.
have {Hp1} Hp12: p1 = a * p2 by rewrite Hp1 Hp2 big_cons.
have Hmp2: p2 \is monic by rewrite -(monicMl _ Hma) -Hp12.
have sp1gt0 : (0 < size (1%:P : {poly R}))%N by rewrite size_poly1.
have mgt0 (x y : {poly R}) :
        (0 < size x -> 0 < size y -> 0 < size (x * y)%R)%N.
  by move=> sx sy; rewrite size_mul -?size_poly_eq0; move: sx sy;
        case: (size x); case: (size y) => // n1 n2; rewrite ?addnS.
have {Hsb Hmb} Hsp2: (1 < size p2)%N.
  rewrite Hp2 big_cons size_proper_mul.
    rewrite -subn1 -addnBA ?ltn_addr //.
    rewrite big_seq.
    apply: (big_ind (fun (p : {poly R}) => (0 < size p)%N) sp1gt0 mgt0)=> q Hq.
    have: (1 < size q)%N by apply: Hsl; rewrite mem_behead.
    by apply: ltn_trans.
  move/monicP: Hmb => ->; rewrite mul1r lead_coef_eq0 -size_poly_leq0.
  rewrite -ltnNge big_seq.
  apply: (big_ind (fun (p : {poly R}) => (0 < size p)%N) sp1gt0 mgt0)=> q Hq.
  have: (1 < size q)%N by apply: Hsl; rewrite mem_behead.
  by apply: ltn_trans.
move=> {sp1gt0 mgt0}.
apply: (@similar_trans _ _ _ _
           (block_mx (companion_mx a) 0 0 (companion_mx p2))); last first.
  by apply: (similar_drblockmx _ (IHl _ Hmp2 Hsp2 Hp2 Hsl Hml Hicp)).
have {Hp2 Hml Hsl Hcp Hicp IHl} Hcap: coprimep a p2.
  have copa1 : coprimep a 1%P by apply: coprimep1.
  have copaxy (x y : {poly R}) : coprimep a x -> coprimep a y ->
                   coprimep a (x * y)%R.
    by rewrite coprimepMr=> -> ->.
  rewrite Hp2 big_seq.
  apply: (big_ind (fun p => coprimep a p)).
   + by apply: coprimep1.
   + by move=> x y; rewrite coprimepMr => -> ->.
   move=> i iin; move/(nth_index 0): (iin)=> iid.
   move: (iin); rewrite -index_mem -ltnS=> ii_prf.
   set j := Ordinal ii_prf.
   have vi : [:: a, b & l]`_j = i by apply: (nth_index 0 iin).
   by have := Hcp ord0 j isT; rewrite vi /=.
apply/similar_fundamental.
apply: (equiv_trans (equiv_Smith _)).
apply: (equiv_trans (Smith_companion Hsp1 Hmp1)).
rewrite Hp12 char_dblock_mx.
apply: (@equiv_trans _ _ _ _ _ _ _
  (block_mx (diag_mx_seq (size a).-2.+1 (size a).-2.+1
  (rcons (nseq (size a).-2 1) a)) 0 0
  (diag_mx_seq (size p2).-2.+1 (size p2).-2.+1
  (rcons (nseq (size p2).-2 1) p2)))); last first.
  apply: equiv_dgblockmx; apply: equiv_sym; set C := char_poly_mx _ .
    by apply: (equiv_trans (equiv_Smith C)); apply: Smith_companion.
  by apply: (equiv_trans (equiv_Smith C)); apply: Smith_companion.
rewrite -diag_mx_seq_cat ?size_rcons ?size_nseq //.
set M := diag_mx_seq _ _ (_ ++ _).
set sap := (size (a * p2)).-2.+1.
set sa := (size a).-2.+1.
set sp := (size p2).-2.+1.
have Hcast: sap = (sa + sp)%N.
  rewrite /sap /sa /sp size_proper_mul.
    rewrite -!subn1 -addnBA; last by rewrite ltnW.
    rewrite addnC -addnBA; last by rewrite ltnW.
    rewrite -addnBA ?subn_gt0 // addSn addnC !subn1 (@prednK (_.-1)) //.
    by rewrite -subn1 subn_gt0.
  by move/monicP: Hma; move/monicP: Hmp2=> -> ->; rewrite mulr1 oner_eq0.
have HdetM: \det M = p1.
  rewrite det_diag_mx_seq ?size_cat ?size_rcons ?size_nseq //.
  rewrite -!cats1 !big_cat /= !big_cons !big_nil.
  rewrite !big1_seq=> [|i|i]; try by rewrite mem_nseq => /= /andP[] _ /eqP.
  by rewrite !mul1r !mulr1 -Hp12.
have Ho: (sa.-1 < (sa + sp).-1)%N by rewrite prednK // addnS leq_addr.
have HM1: row' (Ordinal Ho) (col' (Ordinal Ho)
            (row' ord_max (col' ord_max  M))) = 1%:M.
  apply/matrixP=> j k; rewrite !mxE !lift_max.
  rewrite nth_cat size_rcons size_nseq.
  case: ifP; rewrite nth_rcons size_nseq.
    rewrite ltnS leq_eqVlt eq_sym (negbTE (neq_bump _ _)) /= => Hb.
    by rewrite Hb nth_nseq Hb eqn_leq !leq_bump2 -eqn_leq.
  move/negbT;rewrite -leqNgt=> Hb.
  have Hb2: (bump (size a).-2 j - (size a).-2.+1 < (size p2).-2)%N.
    rewrite -(ltn_add2r sa _ _.-2) subnK //.
    by rewrite (leq_trans (ltn_ord (lift (Ordinal Ho) j))) // addnC addSn.
  by rewrite Hb2 nth_nseq Hb2 eqn_leq !leq_bump2 -eqn_leq.
apply/equiv_sym/(equiv_trans (equiv_Smith M)).
rewrite /Smith_form -diag_mx_seq_takel.
set s := take _ _.
have Hs1: size s = sap by rewrite Hcast size_Smith_seq // HdetM monic_neq0.
apply: eqd_equiv=> // [|i]; first by rewrite size_rcons size_nseq.
have Hle: (sap.-2 <= sa + sp)%N by rewrite -Hcast -subn2 leq_subr.
have Hsort: sorted (@dvdr _) s.
  by apply/(sorted_take (@dvdr_trans _))/sorted_Smith.
have:= (equiv_Smith M).
rewrite /Smith_form -diag_mx_seq_takel=> Hequiv.
have Hle2: (sap.-2 < minn (sa + sp) (sa + sp))%N
   by rewrite minnn Hcast addnS addSn.
have:= Smith_gcdr_spec Hle2 Hsort Hequiv.
set d2 := \big[_/_]_(_<_) _=> H2.
have {H2} Hd2: d2 %= 1.
  apply/(eqd_trans H2); rewrite /eqd !dvdr_dvdp.
  apply: (coprimepP _ _ Hcap); rewrite -dvdr_dvdp.
  +apply: big_gcdr_def; rewrite Hcast prednK ?addnS ?addSn //.
   exists (finfun (lift (@ord_max (sa + sp).-1))).
   apply: big_gcdr_def.
   exists (finfun (lift (@ord_max (sa + sp).-1))).
   rewrite /minor.minor /minor.submatrix /=.
   rewrite (expand_det_row _ (Ordinal Ho)) (bigD1 (Ordinal Ho)) //=.
   rewrite !mxE !ffunE big1 ?addr0.
     rewrite nth_cat size_rcons size_nseq lift_max /=.
     rewrite ltnS leqnn nth_rcons size_nseq ltnn eqxx.
     rewrite /cofactor exprD -expr2 sqrr_sign mul1r.
     set N:= row' _ _.
     have ->: N = 1%:M.
     by rewrite -HM1; apply/matrixP=> j k; rewrite !mxE !ffunE !lift_max.
   by rewrite det1 mulr1.
   move=> j /negbTE Hj; rewrite !mxE !ffunE.
   by rewrite (inj_eq (@ord_inj _)) (inj_eq (@lift_inj _ _)) eq_sym Hj mul0r.
  have Ho2: (sa .-1 < sa + sp)%N by rewrite prednK // leq_addr.
  apply: big_gcdr_def; rewrite Hcast prednK ?addnS ?addSn //.
  exists (finfun (lift (Ordinal Ho2))).
  apply: big_gcdr_def.
  exists (finfun (lift (Ordinal Ho2))).
  rewrite /minor.minor /minor.submatrix /=.
  have Hom: ((size a).-2 + (size p2).-2 < (size a).-2 + sp)%N by rewrite addnS.
  have Hlom k : lift (Ordinal Hom) k = widen_ord (leq_pred _) k.
    apply: ord_inj=> /=; rewrite /bump leqNgt.
    by rewrite (leq_trans (ltn_ord k)) // addnS leqnn.
  rewrite (expand_det_row _ (Ordinal Hom)).
  rewrite (bigD1 (Ordinal Hom)) //= big1 ?addr0.
    rewrite !mxE !ffunE /= -[X in bump X _]addn0 bumpDl /bump leq0n /=.
    rewrite nth_cat size_rcons size_nseq ltnS add1n {1}addnS.
    rewrite ltnNge leq_addr /= nth_rcons size_nseq.
    rewrite {1 3}addnS !subSS !addKn !ltnn !eqxx.
    rewrite /cofactor exprD -expr2 sqrr_sign mul1r.
    set N:= row' _ _.
    have ->: N = 1%:M.
      rewrite -HM1; apply/matrixP=> j k.
      by rewrite !mxE !ffunE !lift_max !Hlom /=.
    by rewrite det1 mulr1.
  move=> j /negbTE Hj; rewrite !mxE !ffunE (inj_eq (@ord_inj _)).
  by rewrite (inj_eq (@lift_inj _ _)) eq_sym Hj mul0r.
have Hsp: s`_sap.-1 %= p1.
  rewrite eqd_sym in Hd2.
  rewrite -(mul1r s`_sap.-1) (eqd_ltrans (eqd_mulr _ Hd2)).
  rewrite -HdetM -det_Smith /Smith_form -diag_mx_seq_takel det_diag_mx_seq.
    rewrite (big_nth 0) big_mkord Hs1 big_ord_recr /=.
    by apply: eqd_mul=> //; rewrite /d2 prednK // Hcast addnS addSn.
  by rewrite Hs1 Hcast.
move/eqd_big_mul1: Hd2=> H.
have [Hi|Hi|/eqP Hi] := (ltngtP i sap.-1).
  +have Hi2: (i < sap.-2.+1)%N by rewrite prednK // Hcast addnS addSn.
   rewrite nth_rcons size_nseq Hi nth_nseq Hi.
   exact: (H (Ordinal Hi2)).
  by rewrite !nth_default // ?Hs1 // size_rcons size_nseq.
by rewrite nth_rcons size_nseq Hi (eqP Hi) ltnn -Hp12.
Qed.

Definition Frobenius_form_CF n (A : 'M[R]_n) :=
  let fm f s := flatten (map f s) in
  let sp := invariant_factors A in
  let l p := linear_factor_seq p in
  let sc p := [seq (size q).-2 | q : {poly R} <- l p] in
  let size := flatten (map sc sp) in
  let blocks m i :=  companion_mxn m.+1 (fm l sp)`_i in
   diag_block_mx size blocks.

Lemma similar_Frobenius n (A : 'M[R]_n.+1) :
 similar (Frobenius_form A) (Frobenius_form_CF A).
Proof.
rewrite /Frobenius_form /Frobenius_form_CF.
move: (@monic_invariant_factors _ _ A).
have: forall p, p \in (invariant_factors A) -> (1 < size p)%N.
  by move=> p; rewrite mem_filter; case/andP.
case: (invariant_factors A)=>[_ _|a l]; first exact: similar_refl.
elim: l a=> /= [a Hsa Hma |b l IHl a Hs Hm].
  rewrite !cats0; apply: similar_poly_inv.
    by rewrite Hsa // mem_head.
  by rewrite Hma // mem_head.
have IHs: forall p : {poly R}, p \in b :: l -> (1 < size p)%N.
  by move=> p Hp; apply: Hs; rewrite mem_behead.
have IHm: forall p : {poly R}, p \in b :: l -> p \is monic.
  by move=> p HP; apply: Hm; rewrite mem_behead.
have Hsa: (1 < size a)%N by rewrite Hs // mem_head.
have Hma: a \is monic by rewrite Hm // mem_head.
set M := companion_mxn _ _.
apply: (similar_trans (similar_drblockmx M (IHl b IHs IHm))).
apply: (similar_trans (similar_ulblockmx _ (similar_poly_inv Hsa Hma))).
have Hnv: forall p, p \in [:: a, b & l] -> linear_factor_seq p != [::].
  move=> p Hp; rewrite /linear_factor_seq -size_eq0 !size_map size_eq0.
  rewrite /root_seq_uniq; apply: contra_neq; first exact: undup_nil.
  by rewrite -root_seq_nil -ltnNge; apply: Hs.
set s1 := _ ++ _.
set s2 := linear_factor_seq _ ++ _.
have: (linear_factor_seq a) != [::] by rewrite Hnv // mem_head.
have t: s2 != [::].
  have: linear_factor_seq b != [::] by rewrite Hnv // mem_behead // mem_head.
  by rewrite /s2; case: (linear_factor_seq b).
clear -t.
have ->: s1 = [seq (size p).-2 | p : {poly R} <- s2].
  by rewrite /s1 map_cat map_flatten; congr (_ ++ _); rewrite [in LHS]map_comp.
case: (linear_factor_seq a)=> //= c s _.
elim: s c=> [c|c s IHs d] /=.
  case: s2 t => // d s2 _ /=.
  exact: similar_refl.
set M := companion_mxn _ _.
apply: similar_sym.
apply: (similar_trans (similar_drblockmx M (similar_sym (IHs c)))).
rewrite /GRing.zero /= -row_mx_const -col_mx_const block_mxA.
apply/similar_sym/similar_cast.
rewrite col_mx_const row_mx_const.
exact: similar_refl.
Qed.

End Polynomial.


Section ml.
Variables A B:Prop.
Theorem Dm_nor: not (or A B) -> and (not A) (not B).
Proof.
    intro H0.
    split.
    intro H1.
    elim H0.
    left; assumption.
    intro Hb.
    elim H0.
    right; assumption.
Qed.
End ml.

Check Dm_nor.


(***************************************************************************)
(*   This is part of FA_3rdCalculus, it is distributed under the terms     *)
(*         of the GNU Lesser General Public License version 3              *)
(*                (see file LICENSE for more details)                      *)
(*                                                                         *)
(*            Copyright 2020-2022: Yaoshun Fu and Wensheng Yu.             *)
(***************************************************************************)

Require Export DCF.

Definition uni_derivative F f a b :=
  ∃ d, fun_pinc d (O|b-a] /\ unbRecF d (O|b-a] /\ ∃ M, O < M /\
  ∀ x h, x ∈ [a|b] -> (x+h) ∈ [a|b] -> |F(x+h) - F(x) - f(x)·h| ≦ M·|h|·d(|h|).

Corollary Co_der : ∀ {F f d M a b},
  (∀ x h, x ∈ [a|b] -> (x+h) ∈ [a|b] ->
  |F(x+h) - F(x) - f(x)·h| ≦ M·|h|·d(|h|)) ->
  ∀ {p q}, p ∈ [a|b] -> q ∈ [a|b] ->
  |F(q) - F(p) - f(p)·(q-p)| ≦ M·|q-p|·d(|q-p|).
Proof.
  intros. pattern q at 1; rewrite <- (RMi1' _ p). apply H; Simpl_R.
Qed.

Definition uni_derivability F a b := ∃ f, uni_derivative F f a b.

Fact der_lt : ∀ {F f a b}, uni_derivative F f a b -> a < b.
Proof.
  intros. destruct H as [d [_ [H _]]], (H O) as [z [l [H0 _]]], H0, H0.
  apply Theorem182_1. eapply Theorem172; eauto.
Qed.

Fact dersub : ∀ {F f u v a b}, u ∈ [a|b] -> v ∈ [a|b] -> v > u ->
  uni_derivative F f a b -> uni_derivative F f u v.
Proof.
  intros. destruct H2 as [d [H2 [H5 [M [H6]]]]], H2.
  exists d. repeat split; intros.
  - apply H2, (ocisub v u); auto.
  - red; intros. apply H4; auto; apply (ocisub v u); auto.
  - red; intros. destruct (H5 M0) as [z [l [H7]]].
    destruct (Co_T167 z (v-u)), H7, H7.
    + exists z, l; split; auto. split; split; auto.
    + apply Theorem182_1' in H1.
      assert ((v-u) ∈ (O|b-a]).
      { apply (ocisub v u); auto. split; unfold ILE_R; auto. }
      assert (z ∈ (O|b-a]). { split; unfold ILE_R; auto. }
      set (H13:=uneqOP (H2 _ H11)).
      exists (v-u), H13; split.
      * split; unfold ILE_R; auto.
      * eapply Theorem172; right; split; eauto.
        pose proof (H2 _ H11). pose proof (H2 _ H12).
        rewrite Ab3; [| apply Pos'; simpl; auto ].
        rewrite Ab3; [| apply Pos'; simpl; auto ].
        apply LeTi_R2' with (z:=(d z)); Simpl_R.
        rewrite Di_Rt; Simpl_R.
        apply LeTi_R2' with (z:=(d (v-u))); Simpl_R.
  - exists M; split; intros; auto.
    apply (ccisub _ _ H H0) in H7. apply (ccisub _ _ H H0) in H8; auto.
Qed.

Fact derf : ∀ {F f1 f2 a b}, uni_derivative F f1 a b ->
  (∀ x, x ∈ [a|b] -> f1 x = f2 x) -> uni_derivative F f2 a b.
Proof.
  intros. simpl in *. destruct H as [d [H]], H1, H2 as [M [H2]].
  exists d; split; [|split]; auto.
  exists M; split; auto; intros. rewrite <- H0; auto.
Qed.

Fact derF : ∀ {F1 F2 f a b}, uni_derivative F1 f a b ->
  (∀ x, x ∈ [a|b] -> F1 x = F2 x) -> uni_derivative F2 f a b.
Proof.
  intros. destruct H as [d [H]], H1, H2 as [M [H2]].
  exists d; split; [|split]; auto.
  exists M; split; auto; intros. repeat rewrite <- H0; auto.
Qed.

Fact derFf : ∀ {F1 F2 f1 f2 a b},
  uni_derivative F1 f1 a b -> (∀ x, x ∈ [a|b] -> F1 x = F2 x) ->
  (∀ x, x ∈ [a|b] -> f1 x = f2 x) -> uni_derivative F2 f2 a b.
Proof.
  intros. eapply derF in H; eauto. eapply derf in H; eauto.
Qed.

Fact ucderf : ∀ {F f a b}, uni_derivative F f a b -> uniform_continuous f a b.
Proof.
  intros. destruct H as [d [H [H0 [M [H1]]]]]. set (D1:=λ x, 2·M·d(x)).
  set (D:=λ x, match classicT (x=O) with
               | left _ => O | right _ => D1(x) end).
  assert (G1 :2·M > O). { apply Pos; simpl; auto. } destruct H.
  assert (G2 :fun_pinc D1 (O |b-a]).
  { red; split; intros; unfold D.
    - apply Pos; auto.
    - red; intros. apply LeTi_R1'; auto. }
  assert (G3 :unbRecF D1 (O|b-a]).
  { red; intros; unfold D1. destruct (H0 (2·M·M0)) as [z [l [H6]]].
    assert ((2·M·d(z)) > O). { apply Pos; auto. }
    exists z, (uneqOP H5); split; auto.
    apply Theorem203_1' with (Θ:=2·M·d(z)); auto.
    pattern (2·M·d(z)) at 3. rewrite <- Ab3; auto.
    rewrite <- Theorem193; Simpl_R.
    apply Theorem203_1 with (Θ:=d(z)) in H4; auto.
    pattern (d z) at 2 in H4. rewrite <- Ab3 in H4; auto.
    rewrite <- Theorem193, Theorem199 in H4; Simpl_Rin H4.
    rewrite Theorem194, Theorem199, (Theorem194 _ M0); auto. }
  assert (∀ z, z ∈ (O|b-a] -> D z = D1 z).
  { intros. destruct H4, H4.
    unfold D; destruct classicT; auto. EGR e H4. }
  assert (fun_pinc D (O|b-a]).
  { destruct G2. split; [|red]; intros; repeat rewrite H4; auto. }
  assert (unbRecF D (O|b-a]).
  { red; intros. destruct (G3 M0) as [z [l [H8]]].
    exists z. rewrite H4; eauto. } exists D. split; auto. split; auto. intros.
  assert ((x+h+(-h)) ∈ [a|b]). { Simpl_R. }
  pose proof (H2 _ _ H7 H8); pose proof (H2 _ _ H8 H9); Simpl_Rin H11.
  rewrite <- Theorem178 in H11. unfold Minus_R in H11.
  rewrite Theorem180 in H11. Simpl_Rin H11.
  rewrite Theorem181, Theorem197'' in H11. Simpl_Rin H11.
  pose proof (Rle4 H11 H10). Simpl_Rin H12. repeat rewrite Theorem178 in H12.
  unfold D. destruct classicT.
  { destruct h; inversion e; Simpl_R; red; auto. }
  destruct (Theorem170 h); try tauto. apply LeTi_R2 with (z:=|h|); auto.
  rewrite <- Theorem193, Theorem202'. unfold D1.
  rewrite Theorem199, (Theorem194 (d(|h|))).
  rewrite Theorem199, <- (Theorem199 M), R_T2; auto.
Qed.

Fact boundderf : ∀ {F f a b}, uni_derivative F f a b -> bound_ran f a b.
Proof.
  intros. eapply ucbound, ucderf; eauto.
Qed.

Fact lipderF : ∀ {F f a b}, uni_derivative F f a b -> Lipschitz F a b.
Proof.
  intros. pose proof (der_lt H). apply Theorem182_1' in H0.
   destruct (boundderf H) as [A [H1]], H as [d [H [H3 [M [H4]]]]].
  assert (M·d(|b-a|)+A > O).
  { rewrite <- (Theorem175' O), Ab3; auto. apply Theorem189; auto.
    apply Pos; auto. apply H; split; split; red; auto. }
  exists (M·d(|b-a|)+A). split; auto; intros. pose proof (H5 _ _ H7 H8).
  eapply Theorem173 in H9; try apply Ab2'.
  apply LePl_R with (z:=|f(x)·h|) in H9; Simpl_Rin H9.
  rewrite Theorem193, Theorem194, <- Theorem199, <- Theorem201' in H9.
  destruct (classic (h=O)). { subst h. Simpl_R; red; auto. }
  eapply Theorem173; eauto. apply LeTi_R; [apply Theorem170'|].
  apply Theorem191'; [| left; auto]. rewrite Theorem194. apply LeTi_R1'; auto.
  pose proof (ccile1 H7 H8); Simpl_Rin H11. apply Ab8 in H10.
  eapply Co_inc; try apply H; try rewrite (Ab3 (b-a)); auto;
  split; split; red; auto.
Qed.

Fact boundderF : ∀ {F f a b}, uni_derivative F f a b -> bound_ran F a b.
Proof.
  intros. exact (lipbound (lipderF H)).
Qed.

Fact unider : ∀ {F f1 f2 a b}, uni_derivative F f1 a b ->
  uni_derivative F f2 a b -> ∀x, x ∈ [a|b] -> f1 x = f2 x.
Proof.
  intros. pose proof (der_lt H).
  destruct H as [d1 H], H, H3, H4 as [M1 [H4]].
  destruct H0 as [d2 H0], H0, H6, H7 as [M2 [H7]].
  Absurd. apply Ab8' in H9. set (M:= R2max M1 M2). set (d:= maxfun d1 d2).
  assert (M > O). { unfold M. destruct (Pr_max4 M1 M2); now rewrite H10. }
  assert (∀ x h,x ∈ [a|b] -> (x+h) ∈ [a|b] -> h <> O ->
    |f1(x)-f2(x)| ≦ (M+M)· d(|h|)).
  { intros. pose proof (H5 _ _ H11 H12). pose proof (H8 _ _ H11 H12).
    pose proof (Rle4 H14 H15). Simpl_Rin H16. rewrite Theorem178 in H16.
    rewrite <- Theorem202', Theorem193 in H16.
    pose proof (ociabs H11 H12 H13). apply Ab8 in H13.
    destruct H, H0. apply LeTi_R2 with (z:=|h|); auto.
    eapply Theorem173; eauto. repeat rewrite Theorem199, Theorem201'.
    apply Theorem191'; rewrite Theorem199, (Theorem194 _ (|h|)).
    - apply LeTi_R3.
      + left. apply Pos; auto. + left; auto. + apply Pr_max2.
      + apply LeTi_R1'; auto. unfold d. rewrite maxfx. apply Pr_max2.
    - apply LeTi_R3.
      + left. apply Pos; auto. + left; auto. + apply Pr_max3.
      + apply LeTi_R1'; auto. unfold d. rewrite maxfx. apply Pr_max3. }
  assert (∃ h, (x+h) ∈ [a|b] /\ h <> O).
  { pose proof H1. destruct H1, H1, H1.
    - pose proof (ccil H12). exists (a-x); split; Simpl_R.
      apply Theorem182_3' in H1. intro. ELR H15 H1.
    - subst a. pose proof (ccir H12). exists (b-x); split; Simpl_R.
      apply Theorem182_1' in H2. intro. EGR H14 H2. } destruct H12 as [h [H12]].
  assert (fun_pinc d (O|b-a]). { apply fpcp2; auto. }
  assert (unbRecF d (O|b-a]). { apply ubrp2; auto. }
  assert (unbRecF d (O|(|h|)]).
  { red; intros. destruct (H15 M0) as [z1 [l1 [H16]]].
    assert (R2min z1 (|h|) ∈ (O|b-a]).
    { destruct H16, H16. apply Ab8 in H13. split; split.
      - apply R2mgt; auto.
      - eapply Theorem173; eauto. apply Pr_min2. }
    pose proof H18. apply H14 in H18.
    exists (R2min z1 (|h|)), (uneqOP H18). split; auto.
    - destruct H19, H19. split; split; auto. apply Pr_min3.
    - destruct (Co_T167 M0 O) as [G|G].
      { eapply Theorem172; left; split; eauto.
        apply Ab8''. intro. inversion H20. }
      apply Rlt1 in H17. apply Rlt1.
      eapply Theorem172; left; split; eauto. apply LeTi_R1'; auto.
      destruct H14. rewrite Ab3, (Ab3 (d z1)); auto.
      eapply Co_inc; eauto. apply Pr_min2. } set (l1:= uneqOP H9).
  destruct (H16 (((M+M)/(|f1 x - f2 x|)) l1)) as [z [l [H17]]], H17, H17.
  assert (d z > O) as G1.
  { apply H14. destruct (ociabs H1 H12 H13), H20.
    split; split; auto. eapply Theorem173; eauto. }
  assert ((x+z) ∈ [a|b] \/ (x+(-z)) ∈ [a|b]).
  { destruct (Theorem167 h O) as [H20 | [H20| H20]]; try tauto.
    - right. split. split.
      + rewrite Ab3'' in H19; auto.
        destruct H12, H12. eapply Theorem173; eauto.
        unfold Minus_R. rewrite Theorem175, (Theorem175 x). apply LePl_R.
        apply LEminus. Simpl_R.
      + destruct H1, H1. eapply Theorem173; eauto.
        left. apply Theorem188_1 with (Θ:=z); Simpl_R. apply Pl_R; auto.
    - left. rewrite Ab3 in H19; auto. split. split.
      + destruct H1, H1. eapply Theorem173; eauto. left. apply Pl_R; auto.
      + destruct H12, H12. eapply Theorem173; eauto.
        apply Theorem191'; red; auto. }
  assert (z<>O). { intro. EGR H21 H17. }
  assert (-z<>O). { intro. apply H21. apply Theorem183_2'; Simpl_R. }
  destruct H20.
  - pose proof (H11 _ _ H1 H20 H21). rewrite (Ab3 z) in H23; auto.
    apply Theorem203_1 with (Θ:=|f1 x - f2 x|) in H18; Simpl_Rin H18.
    rewrite Theorem194, <- Theorem193, Di_Rt in H18; Simpl_Rin H18.
    apply Rlt1 in H18. rewrite Ab3 in H18; auto. LEGR H23 H18.
  - pose proof (H11 _ _ H1 H20 H22).
    rewrite Theorem178, (Ab3 z) in H23; auto.
    apply Theorem203_1 with (Θ:=|f1 x - f2 x|) in H18; Simpl_Rin H18.
    rewrite Theorem194, <- Theorem193, Di_Rt in H18; Simpl_Rin H18.
    apply Rlt1 in H18. rewrite Ab3 in H18; auto. LEGR H23 H18.
Qed.

Fact derC : ∀ {a b} C, a < b -> uni_derivative (Φ(C)) (Φ(O)) a b.
Proof.
  intros. generalize (fpcp1 a b)(ubrp1 H); intros.
  exists Δ. split; auto. split; auto.
  exists 1; split; [reflexivity|intros]. Simpl_R. apply square_p1.
Qed.

Fact derCx : ∀ {a b} C, a < b -> uni_derivative (λ x, C·x) (Φ(C)) a b.
Proof.
  intros. generalize (fpcp1 a b)(ubrp1 H); intros.
  exists Δ. split; auto. split; auto.
  exists 1; split; [reflexivity|intros].
  rewrite <- Theorem202. Simpl_R. apply square_p1.
Qed.

Fact derfMu : ∀ {a b F f} c, uni_derivative F f a b ->
  uni_derivative (mult_fun c F) (mult_fun c f) a b.
Proof.
  intros. destruct H as [d [H]], H0, H1 as [M [H1]].
  exists d; split; auto. split; auto.
  destruct (classic (c=O)) as [H3 | H3]; unfold mult_fun.
  - subst c; exists M; split; intros; Simpl_R; simpl.
    eapply Theorem173; eauto. apply Theorem170'.
  - exists (|c|·M); split; intros.
    + apply Pos; auto. apply Ab8; auto.
    + pose proof (H2 _ _ H4 H5). rewrite Theorem199.
      repeat rewrite <- Theorem202, Theorem199.
      rewrite Theorem193, <- (Theorem199 M).
      apply LeTi_R'; auto. apply Theorem170'.
Qed.

Fact derf_mi : ∀ {F f a b}, uni_derivative F f a b ->
  uni_derivative (λ x, F(-x)) (λ x, -f(-x)) (-b) (-a).
Proof.
  intros. destruct H as [d [H [H2 [M [H3]]]]].
  exists d; split; Simpl_R; rewrite Theorem175; Simpl_R. split; auto.
  exists M; split; intros; Simpl_R.
  apply ccimi in H1. Simpl_Rin H1. apply ccimi in H4. Simpl_Rin H4.
  pose proof (Co_der H0 H1 H4). Simpl_Rin H5.
  assert (-(x+h) + x = -h).
  { apply Theorem183_2'. rewrite Theorem180; Simpl_R. }
  rewrite H6, Theorem178, <- Theorem197 in H5; auto.
Qed.

Fact derf_cd : ∀ {F f a b} c d l,
  uni_derivative F f a b -> uni_derivative (multfun_pl F c d)
  (mult_fun c (multfun_pl f c d))(((a-d)/c) (uneqOP l))(((b-d)/c) (uneqOP l)).
Proof.
  intros. destruct H as [p [H]], H, H0, H2 as [M [H2]].
  exists (multfun_ p c); repeat apply conj; try red; unfold multfun_; intros.
  - apply ociMu with (d:=c) in H4; auto.
    rewrite Mi_R' in H4; Simpl_Rin H4. apply H; auto.
  - apply ociMu with (d:=c) in H4; apply ociMu with (d:=c) in H5; auto.
    rewrite Mi_R' in H4, H5; Simpl_Rin H4; Simpl_Rin H5.
    apply Theorem203_1 with (Θ:=c) in H6; auto.
    rewrite Theorem194, (Theorem194 _ c) in H6; auto.
  - destruct (H0 M0), H4, H4.
    assert (neq_zero (p (c · (x / c) (uneqOP l)))). { Simpl_R. }
    exists ((x/c) (uneqOP l)), H6; split.
    + apply ociMu'; Simpl_R. rewrite Mi_R'; Simpl_R.
    + apply Rlt1 in H5. apply Rlt1. Simpl_R.
  - exists (c·M); split; intros.
    + apply Pos; auto.
    + apply cciMu, cciMi in H4; apply cciMu, cciMi in H5; auto.
      pose proof (Co_der H3 H4 H5).
      assert (c·(x+h) + d - (c·x + d) = c·h).
      { rewrite Theorem201. rewrite <- Mi_R. Simpl_R. }
      rewrite H7 in H6. unfold multfun_pl, mult_fun.
      rewrite (Theorem194 _ (f(c·x+d))), Theorem199.
      pattern c at 5 6; rewrite <- Ab3; auto.
      rewrite (Theorem194 (|c|)), (Theorem199 M), <- Theorem193; auto.
Qed.

Fact derfmi : ∀ {F f a b}, uni_derivative F f a b ->
  uni_derivative (minus_fun F) (minus_fun f) a b.
Proof.
  intros. pose proof (derfMu (-(1)) H). do 2 rewrite <- mFun; auto.
Qed.

Fact derFPl : ∀ {F G f g a b},
  uni_derivative F f a b -> uni_derivative G g a b ->
  uni_derivative (Plus_Fun F G) (Plus_Fun f g) a b.
Proof.
  intros. destruct H as [d1 H], H, H1, H2 as [M1 [H2]].
  destruct H0 as [d2 H0], H0, H4, H5 as [M2 [H5]]. set (d:=maxfun d1 d2).
  assert (fun_pinc d (O|b-a]). { apply fpcp2; auto. }
  assert (unbRecF d (O|b-a]). { eapply ubrp2; eauto. }
  exists d. split; auto. split; auto.
  exists (M1 + M2); split; intros.
  - destruct M1, M2; simpl; auto; inversion H2; inversion H5.
  - generalize (H3 _ _ H9 H10) (H6 _ _ H9 H10); intros.
    pose proof (Theorem191' H11 H12).
    eapply Theorem173 in H13; try apply Ab2; eauto.
    rewrite Mi_R, <- Theorem201', Mi_R in H13.
    eapply Theorem173; eauto. repeat rewrite Theorem201'.
    apply Theorem191'; apply LeTi_R'; red.
    + destruct M1, h; simpl; tauto.
    + unfold d, maxfun; destruct Rcase; auto.
    + destruct M2, h; simpl; tauto.
    + unfold d, maxfun; destruct Rcase; auto.
Qed.

Fact derFMi : ∀ {F G f g a b},
  uni_derivative F f a b -> uni_derivative G g a b ->
  uni_derivative (Minus_Fun F G) (Minus_Fun f g) a b.
Proof.
  intros. exact (derFPl H (derfmi H0)).
Qed.

Lemma dMupre : ∀ A B C D a b c,
  (A-B)·(C-D)+D·(A-B-a·c)+B·(C-D-b·c) = A·C-B·D-(a·D+B·b)·c.
Proof.
  intros. rewrite (Theorem202 (A-B)), (Theorem194 D), (Theorem202' D (A-B)).
  unfold Minus_R. rewrite <- Theorem186. Simpl_R.
  repeat rewrite Theorem202. repeat rewrite Theorem202'.
  rewrite Mi_R. unfold Minus_R. rewrite <- Theorem186. Simpl_R.
  rewrite (Theorem194 (a·c)). repeat rewrite <- Theorem199.
  rewrite (Theorem194 D), Theorem201'; auto.
Qed.

Fact derFMu : ∀ {F G f g a b},
  uni_derivative F f a b -> uni_derivative G g a b ->
  uni_derivative (Mult_Fun F G) (λ x, (f x)·(G x) + (F x)·(g x)) a b.
Proof.
  intros. pose proof (der_lt H) as K. apply Theorem182_1' in K.
  destruct (lipderF H) as [M1 [H1]], (lipderF H0) as [M2 [H3]].
  destruct (boundderF H) as [A1 [H5]], (boundderF H0) as [A2 [H7]].
  destruct H as [d1 H], H, H9, H10 as [M3 [H10]].
  destruct H0 as [d2 H0], H0, H12, H13 as [M4 [H14]].
  assert (fun_pinc Δ (O|b-a]). { apply fpcp1; auto. }
  assert (unbRecF Δ (O|b-a]). { apply ubrp1, Theorem182_1; auto. }
  pose proof (fpcp2 (fpcp2 H H0) H15) as K2.
  pose proof (ubrp2 (fpcp2 H H0) H15 (ubrp2 H H0 H9 H12) H16) as K3.
  set (d:=maxfun (maxfun d1 d2) Δ) in *. exists d.
  split; auto. split; auto.
  assert (M1·M2 + A2·M3 + A1·M4 > O).
  { generalize (Pos _ _ H1 H3) (Pos _ _ H7 H10) (Pos _ _ H5 H14); intros.
    exact (Theorem189 (Theorem189 H17 H18) H19). }
  exists (M1·M2 + A2·M3 + A1·M4); split; auto; intros.
  destruct (classic (h=O)) as [K4|K4]. { subst h. Simpl_R. red; auto. }
  generalize (H11 _ _ H18 H19) (H13 _ _ H18 H19)
    (H2 _ _ H18 H19) (H4 _ _ H18 H19); intros.
  apply LeTi_R' with (z:=|G x|) in H20; [|apply Theorem170'].
  apply LeTi_R' with (z:=|F x|) in H21; [|apply Theorem170'].
  apply (LeTi_R3 (|G(x+h) - G x|) (M2·|h|)) in H22; auto.
  2:apply Theorem170'. 2: apply Rle3; red; auto; apply Theorem170'.
  rewrite <- Theorem193, Theorem199, (Theorem194 (|h|)) in H22.
  do 2 rewrite <- Theorem199 in H22. clear H23.
  rewrite <- Theorem199, <- Theorem193 in H20, H21.
  rewrite (Theorem199 _ (|h|)), absqu in H22.
  pose proof (Theorem191' H20 H21). eapply Theorem173 in H23; try apply Ab2.
  pose proof (Theorem191' H22 H23). eapply Theorem173 in H24; try apply Ab2.
  rewrite <- Theorem186, dMupre in H24. unfold Mult_Fun.
  eapply Theorem173; eauto. rewrite <- absqu, <- Theorem186.
  pose proof (ociabs H18 H19 K4). apply Ab8 in K4.
  repeat rewrite Theorem201'. apply Theorem191'; [apply Theorem191'|].
  - rewrite <- Theorem199. apply LeTi_R'.
    + left. apply Pos; [apply Pos|]; auto.
    + unfold d. rewrite maxfx. apply Pr_max3.
  - assert (((A2·M3)·|h|)·d1(|h|) ≦ ((A2·M3)·|h|)·d(|h|)).
    { apply LeTi_R'.
      - left. apply Pos; [apply Pos|]; auto.
      - unfold d. rewrite maxfx, maxfx. rewrite Pr_max1'. apply Pr_max2. }
    eapply Theorem173; eauto. apply LeTi_R.
    + left; apply H; auto.
    + rewrite Theorem199. apply LeTi_R1; [|red; auto]. apply Pos; auto.
  - assert (((A1·M4)·|h|)·d2(|h|) ≦ ((A1·M4)·|h|)·d(|h|)).
    { apply LeTi_R'.
      - left. apply Pos; [apply Pos|]; auto.
      - unfold d. rewrite maxfx, maxfx.
        rewrite (Pr_max1 (d1(|h|))), Pr_max1'. apply Pr_max2. }
    eapply Theorem173; eauto. apply LeTi_R.
    + left; apply H0; auto.
    + rewrite Theorem199. apply LeTi_R1; [|red; auto]. apply Pos; auto.
Qed.

Definition fu_seg f i n x1 x2 :=
  match i with
  | 1 => f(x1+(RdiN (x2-x1) n)) - f x1
  | p` => f(x1+(RdiN ((x2-x1)·p`) n)) - f(x1+(RdiN ((x2-x1)·p) n))
  end.

Definition sum_fseg f i n x1 x2 := Cum (λ i, fu_seg f i n x1 x2) i.

Fact fseg0 : ∀ f n x1 x2 m,
  Cum (λ i, fu_seg f i n x1 x2) m = sum_fseg f m n x1 x2.
Proof.
  intros; auto.
Qed.

Fact fseg1 : ∀ f u v i n, fu_seg f i n u v =
  f(u+(RdiN ((v-u)· i) n)) - f(u+(RdiN ((v-u)· (i-1)) n)).
Proof.
  intros. induction i; unfold fu_seg; Simpl_R.
Qed.

Fact fseg2 : ∀ f u v i n,
  sum_fseg f i n u v = f(u+(RdiN ((v-u)·i) n)) - f u.
Proof.
  intros; unfold sum_fseg. induction i; simpl; Simpl_R.
  rewrite IHi, Theorem175, Mi_R, Theorem175, <- Mi_R. Simpl_R.
Qed.

Fact fseg3 : ∀ f u v n, sum_fseg f n n u v = f v - f u.
Proof.
  intros. rewrite fseg2. unfold RdiN. Simpl_R.
Qed.

Lemma rdnle1 : ∀ {i n z}, ILE_N i n -> z > O ->
  O ≦ RdiN (z·(i-1)) n /\ RdiN (z·(i-1)) n ≦ z.
Proof.
  split; intros; red; destruct i; Simpl_R; left.
  - apply RdN1. apply Pos; simpl; auto.
  - unfold RdiN. apply (Theorem203_1' _ _ n); Simpl_R.
    2: reflexivity. rewrite Theorem194, (Theorem194 _ i).
    apply Theorem203_1; auto. pose proof (Nlt_S_ i).
    apply OrderNRlt. eapply Theorem16; eauto.
Qed.

Lemma rdnle2 : ∀ {i n z}, ILE_N i n -> z > O ->
  O ≦ RdiN (z·i) n /\ RdiN (z·i) n ≦ z.
Proof.
  split; intros.
  - left; apply RdN1; apply Pos; simpl; auto.
  - unfold RdiN. apply (LeTi_R2 _ _ n); Simpl_R; [reflexivity|].
    apply LeTi_R1'; auto. apply OrderNRle; auto.
Qed.

Fact rdnin : ∀ {i n u v a b},
  u ∈ [a|b] -> v ∈ [a|b] -> v > u -> ILE_N i n ->
  (u+(RdiN (((v-u)·(i-1))) n)) ∈ [a|b] /\ (u+(RdiN (((v-u)·i)) n)) ∈ [a|b].
Proof.
  intros; destruct H, H, H0, H0.
  apply Theorem182_1' in H1. repeat split.
  - eapply Theorem173; try apply H. apply LeRp1, rdnle1; auto.
  - eapply Theorem173; try apply H4. apply LeRp2, rdnle1; auto.
  - eapply Theorem173; try apply H. apply LeRp1, rdnle2; auto.
  - eapply Theorem173; try apply H4. apply LeRp2, rdnle2; auto.
Qed.

Fact derpos_inc : ∀ {F f a b}, uni_derivative F f a b ->
  (∀ x, x ∈ [a|b] -> f(x) ≧ O) -> fun_inc F [a|b].
Proof.
  intros; red; intros. destruct H as [d [H [H4 [M [H5]]]]].
  destruct (Co_T167 (F x) (F y)); auto. apply Theorem182_3' in H7.
  set (u:=y - x) in *. set (V:=F y - F x) in *.
  assert(∀ n, ∃ i, (ILE_N i n) /\
    F(x+u·(RdiN i n))-F(x+u·(RdiN (i-1) n))≦(RdiN V n)).
  { intros. Absurd. pose proof (not_ex_and _ _ H8). clear H8. cbv beta in H9.
    set (f2:= λ i, fu_seg F i n x y); set (f1:= λ i:Nat, RdiN V n).
    assert (∀ i, (ILE_N i n) -> f1 i < f2 i).
    { intros. apply H9 in H8. do 2 rewrite RdN2 in H8.
      destruct (Co_T167 (f2 i) (f1 i)); auto.
      unfold f1, f2 in H10. rewrite fseg1 in H10. tauto. }
    pose proof (cumlt n H8). unfold f1, f2 in H10.
    rewrite cumcon, fseg0, fseg3 in H10. unfold RdiN in H10; Simpl_Rin H10.
    apply OrdR1 in H10; tauto. }
  assert (|V| > O). { destruct V; inversion H7; auto. }
  destruct (H4 (M·((u/|V|) (uneqOP H9)))) as [r [H10 [H11]]].
  assert (r > O). { destruct H11; tauto. }
  destruct (Archimedes ((u/r) (uneqOP H13))) as [n H14].
  destruct (H8 n) as [i [H16]]. pose proof (Theorem182_1' _ _ H3) as G.
  assert (u·RdiN i n = u·RdiN (i-1)n + u·RdiN 1 n).
  { rewrite <- Theorem201. unfold RdiN. rewrite Di_Rp; Simpl_R. }
  assert (|RdiN V n| ≦ |F(x+u·RdiN (i-1)n + u·RdiN 1 n)
    - F(x+u·RdiN (i-1)n) - f(x+u·RdiN (i-1)n)·(u·RdiN 1 n)|).
  { rewrite Theorem186, <- H17.
    assert (RdiN V n < O).
    { unfold RdiN.  apply (Theorem203_1' _ _ n); Simpl_R. reflexivity. }
    assert (F(x+u·RdiN i n) - F(x+u·RdiN (i-1)n) < O).
    { eapply Theorem172; eauto. }
    assert (O ≦ f(x+u·RdiN (i-1)n)).
    { rewrite RdN2. apply Theorem168, H0, (rdnin H1 H2 H3 H16). }
    assert (O ≦ (u·RdiN 1 n)).
    { rewrite RdN2. left. apply RdN1; Simpl_R. }
    pose proof (Rle3 _ _ H20 H21). rewrite Abope1;[|red|]; auto.
    rewrite <- (Theorem175' (|RdiN V n|)).
    apply Theorem191'; [|apply Theorem170'].
    repeat rewrite Ab3''; auto. apply -> LEminus; auto. }
  assert (|F(x+u·RdiN (i-1)n + u·RdiN 1 n)
    - F(x+u·RdiN (i-1)n) - f(x+u·RdiN (i-1)n)·(u·RdiN 1 n)|
     ≦ M·|(u·RdiN 1 n)|·d(|(u·RdiN 1 n)|)).
  { destruct (rdnin H1 H2 H3 H16). apply H6; repeat rewrite RdN2; auto.
    rewrite Theorem186, RdN3, <- Theorem201; Simpl_R. }
  eapply Theorem173 in H19; eauto.
  assert (M·|(u·RdiN 1 n)|·d(|(u·RdiN 1 n)|) ≦ M·|(u·RdiN 1 n)|·d(r)).
  { assert (RdiN u n > O). { apply RdN1; auto. }
    repeat rewrite RdN2; Simpl_R; apply LeTi_R1'.
    - apply Pos; auto; Simpl_R. rewrite Ab3; auto.
    - apply H; auto.
      + rewrite Ab3; auto. apply (ocisub y x); auto. apply ociDi; auto.
      + rewrite Ab3; [|apply RdN1; auto].
        apply Theorem203_1 with (Θ:=r) in H14; Simpl_Rin H14.
        rewrite Theorem194 in H14. unfold RdiN.
        apply Theorem203_1' with (Θ:=n); Simpl_R. reflexivity. }
  eapply Theorem173 in H20; eauto.
  assert (|V| ≦ M·|u|· d r).
  { rewrite RdN2 in H20; Simpl_Rin H20.
    apply (LeTi_R1 _ _ (|n|)) in H20; [| rewrite Ab3; reflexivity].
    rewrite Theorem199, (Theorem194 (d r)), <-Theorem199 in H20.
    rewrite (Theorem199 M), <- Theorem193, <- Theorem193 in H20.
    unfold RdiN in H20. Simpl_Rin H20. }
  apply Theorem203_1 with (Θ:=|V|) in H12; auto. destruct H.
  rewrite Theorem199, <- Theorem193 in H12. Simpl_Rin H12.
  apply Theorem203_1 with (Θ:=d r) in H12; auto.
  pattern (d r) at 2 in H12. rewrite <- Ab3 in H12; auto.
  rewrite <- Theorem193, Theorem194, <- Theorem199 in H12.
  Simpl_Rin H12. rewrite (Ab3 u) in H21; auto. LEGR H21 H12.
Qed.

Fact derneg_dec : ∀ {F f a b}, uni_derivative F f a b ->
  (∀ x, x ∈ [a|b] -> f(x) ≦ O) -> fun_dec F [a|b].
Proof.
  intros. apply derfmi in H. rewrite (mmFun F). apply inde.
  eapply derpos_inc; eauto; intros.
  unfold minus_fun. apply Theorem168', LEminus; Simpl_R.
Qed.

Fact derpos_sinc : ∀ {F f a b}, uni_derivative F f a b ->
  (∀ x, x ∈ [a|b] -> f(x) > O) -> fun_sinc F [a|b].
Proof.
  intros; red; intros. pose proof H.
  apply derpos_inc in H4; [| intros; red; auto ].
  destruct (H4 _ _ H1 H2 H3); auto.
  assert (∀ u, u ∈ [x | y] -> F x = F u).
  { intros. inversion H6. destruct H7.
    pose proof (ccil H6). pose proof (ccir H6). apply OrdR5.
    - eapply Co_inc; eauto. apply (ccisub x y); auto.
    - rewrite H5. eapply Co_inc; eauto. apply (ccisub x y); auto. }
  assert (uni_derivative F (Φ(O)) x y).
  { apply (derF (derC (F x) H3)); intros; auto. }
  pose proof (dersub H1 H2 H3 H). pose proof (unider H7 H8).
  assert (x ∈ [x | y]). { split; split; red; auto. }
  pose proof (ccisub x y H1 H2 H10).
  apply H9 in H10. apply H0 in H11. ELR H10 H11.
Qed.

Fact derneg_sdec : ∀ {F f a b}, uni_derivative F f a b ->
  (∀ x, x ∈ [a|b] -> f(x) < O) -> fun_sdec F [a|b].
Proof.
  intros. apply derfmi in H. rewrite (mmFun F). apply insde.
  eapply derpos_sinc; eauto; intros. unfold minus_fun.
  apply Theorem183_1'; Simpl_R. apply H0; auto.
Qed.

Corollary derFC : ∀ {F a b}, uni_derivative F (Φ(O)) a b ->
  ∀ {x y}, x ∈ [a|b] -> y ∈ [a|b] -> F x = F y.
Proof.
  intros. pose proof H. eapply derpos_inc in H; [|intros; red; auto].
  eapply derneg_dec in H2; [|intros; red; auto].
  destruct (Theorem167 x y); [subst x; auto|].
  destruct H3; apply OrdR5; auto.
Qed.

Corollary derF2MiC : ∀ {F1 F2 f a b},
  uni_derivative F1 f a b -> uni_derivative F2 f a b ->
  ∀ {x y}, x ∈ [a|b] -> y ∈ [a|b] -> F1# x y = F2# x y.
Proof.
  intros. pose proof (derFMi H H0). unfold Minus_Fun in H3.
  apply (@derf _ _ (Φ(O))) in H3; [|intros; Simpl_R].
  pose proof (derFC H3 H2 H1). apply Theorem182_2' in H4.
  unfold input2Mi. apply Theorem182_2. rewrite Mi_R'; auto.
Qed.

Corollary derVle : ∀ {F G f g a b}, uni_derivative F f a b ->
  uni_derivative G g a b -> F a = G a ->
  (∀ x, x ∈ [a|b] -> f x ≦ g x) -> ∀ x, x ∈ [a|b] -> F x ≦ G x.
Proof.
  intros. pose proof (derFMi H H0).
  assert (∀x, x ∈ [a|b] -> (Minus_Fun f g) x ≦ O).
  { intros. unfold Minus_Fun. apply LePl_R with (z:=g x0); Simpl_R. }
  pose proof (derneg_dec H4 H5). inversion H3.
  destruct H7, H7; [|subst x; red; auto].
  apply Theorem182_1' in H7. pose proof (ccil H3).
  pose proof (H6 a x H9 H3 (Theorem182_1 _ _ H7)).
  unfold Minus_Fun in H10. rewrite H1 in H10. Simpl_Rin H10.
  apply LePl_R with (z:=G x) in H10; Simpl_Rin H10.
Qed.

Theorem derVTpre :∀ {F f a b},
  uni_derivative F f a b -> ∃ u, u ∈ [a|b] /\ F(b) - F(a) ≦ (f u)·(b-a).
Proof.
  intros. Absurd. pose proof (not_ex_and _ _ H0). simpl in H1.
  assert (∀ x, x ∈ [a|b] -> f x · (b-a) < F b - F a).
  { intros. apply H1 in H2.
    destruct (Co_T167 (F(b)-F(a)) (f(x)·(b-a))); tauto. }
  clear H0 H1. rename H2 into H0. pose proof (der_lt H).
  set (G:=λ x, (F b-F a)·x - F(x)·(b-a)). set (g:=λ x, (F b-F a) - f(x)·(b-a)).
  assert (uni_derivative G g a b).
  { apply derFMi; [apply derCx; auto|].
    pose proof (derfMu (b-a) H); unfold mult_fun in H2.
    apply (derFf H2); intros; apply Theorem194. }
  assert (∀ x, x ∈ [a|b] -> g(x) > O).
  { intros. apply Theorem182_1', H0; auto. }
  assert (G a = G b).
  { unfold G. repeat rewrite Theorem202, Theorem202'.
    rewrite Mi_R'. Simpl_R. rewrite Mi_R'. Simpl_R. now rewrite Theorem181. }
  pose proof (derpos_sinc H2 H3).
  assert (a ∈ [a|b]). { split; split; red; auto. } pose proof (ccir H6).
  apply H5 in H1; auto. ELR H4 H1.
Qed.

Theorem derValT :∀ {F f a b},
  uni_derivative F f a b -> ∃ u v, u ∈ [a|b] /\ v ∈ [a|b] /\
  f(u)·(b-a) ≦ F(b) - F(a) /\ F(b) - F(a) ≦ f(v)·(b-a).
Proof.
  intros. destruct (derVTpre H) as [v [H0]], (derVTpre (derfmi H)) as [u [H2]].
  apply LEminus in H3. unfold minus_fun, Minus_R in H3.
  rewrite Theorem180, Theorem197' in H3. Simpl_Rin H3. exists u, v; auto.
Qed.

Theorem Med_der : ∀ {F f a b}, uni_derivative F f a b
  <-> diff_quo_median F f a b /\ uniform_continuous f a b.
Proof.
  repeat split; red; intros.
  - assert (uni_derivative F f u v).
    { eapply dersub; eauto. now apply Theorem182_1. }
    destruct (derValT H2) as [p [q]], H3, H4, H5.
    exists p, q; try repeat apply conj; auto;
    apply LeTi_R2 with (z:=(v-u)); Simpl_R.
  - eapply ucderf; eauto.
  - destruct H, H0 as [d [H0 [H1]]].
    exists d; split; auto. split; auto.
    exists 1; split; intros; try reflexivity; Simpl_R.
    assert (∀u v z, u ∈ [a|b] -> (u+v) ∈ [a|b] -> z ∈ [u|u+v] ->
      v > O -> |F(u+v)-F(u)-f(z)·v| ≦ |v|·d(|v|)).
    { intros. assert (u+v-u > O). { Simpl_R. }
      destruct (H _  _ H9) as [p [q [H10 [H11 [H12]]]]]; auto.
      apply LePl_R with (z:=-f(z)) in H12; Simpl_Rin H12.
      apply LePl_R with (z:=-f(z)) in H13; Simpl_Rin H13.
      pose proof (R2AMge (conj H12 H13)).
      assert (v ∈ (O|b-a]) as G.
      { apply (ocisub (u+v) u); Simpl_R. split; split; red; auto. }
      assert (∀j, j ∈ [u|u+v] -> |f j - f z|≦ d(v)).
      { intros. destruct H0, (classic (j=z)).
        - subst j; Simpl_R. left. apply H0; auto.
        - pose proof (ccile1 H7 H15). Simpl_Rin H18.
          eapply ccisub in H7; eapply ccisub in H15; eauto.
          rewrite <- (RMi1' _ z) in H15. pose proof (H2 _ _ H7 H15).
          Simpl_Rin H19. eapply Theorem173; eauto.
          apply (@Co_inc d ((O|b-a])); auto. eapply ociabs; eauto.
          intro. apply H17, Theorem182_2; auto. }
      assert (R2max (|f p-f z|) (|f q-f z|) ≦ d(v)). { apply R2Mle; auto. }
      eapply Theorem173 in H16; eauto.
      apply LeTi_R1 with (z:=u+v-u) in H16; auto.
      pattern (u+v-u) at 3 in H16. rewrite <- Ab3 in H16; auto.
      rewrite <- Theorem193, Theorem202' in H16; Simpl_Rin H16.
      rewrite (Ab3 v), (Theorem194 v); auto. }
    destruct (Theorem167 h O) as [H6|[H6|H6]].
    + subst h; Simpl_R; red; auto.
    + apply Theorem176_3 in H6; pose proof (ccir' x _ H6).
      pattern x at 3 in H7. rewrite <- (RMi2 _ h) in H7.
      eapply H5 in H7; eauto; Simpl_R. Simpl_Rin H7.
      rewrite <- Theorem178, <- (Theorem178 h). unfold Minus_R.
      rewrite Theorem180, <- Theorem197''. Simpl_R. now rewrite Theorem181.
    + apply H5; auto. apply ccil'; auto.
Qed.

Corollary derconc : ∀ {F f a b}, uni_derivative F f a b ->
  fun_inc f [a|b] -> convexdown F [a|b].
Proof.
  intros. apply Med_der in H. destruct H. eapply medconc; eauto.
Qed.

Corollary derconv : ∀ {F f a b}, uni_derivative F f a b ->
  fun_dec f [a|b] -> convexup F [a|b].
Proof.
  intros. apply Med_der in H. destruct H. eapply medconv; eauto.
Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

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


From Hammer Require Import Hammer.

Require Export Finite_sets.
Require Export Constructive_sets.
Require Export Classical.
Require Export Classical_sets.
Require Export Powerset.
Require Export Powerset_facts.
Require Export Powerset_Classical_facts.
Require Export Gt.
Require Export Lt.

Section Finite_sets_facts.
Variable U : Type.

Lemma finite_cardinal :
forall X:Ensemble U, Finite U X ->  exists n : nat, cardinal U X n.
Proof. hammer_hook "Finite_sets_facts" "Finite_sets_facts.finite_cardinal".
induction 1 as [| A _ [n H]].
exists 0; auto with sets.
exists (S n); auto with sets.
Qed.

Lemma cardinal_finite :
forall (X:Ensemble U) (n:nat), cardinal U X n -> Finite U X.
Proof. hammer_hook "Finite_sets_facts" "Finite_sets_facts.cardinal_finite".
induction 1; auto with sets.
Qed.

Theorem Add_preserves_Finite :
forall (X:Ensemble U) (x:U), Finite U X -> Finite U (Add U X x).
Proof. hammer_hook "Finite_sets_facts" "Finite_sets_facts.Add_preserves_Finite".
intros X x H'.
elim (classic (In U X x)); intro H'0; auto with sets.
rewrite (Non_disjoint_union U X x); auto with sets.
Qed.

Theorem Singleton_is_finite : forall x:U, Finite U (Singleton U x).
Proof. hammer_hook "Finite_sets_facts" "Finite_sets_facts.Singleton_is_finite".
intro x; rewrite <- (Empty_set_zero U (Singleton U x)).
change (Finite U (Add U (Empty_set U) x)); auto with sets.
Qed.

Theorem Union_preserves_Finite :
forall X Y:Ensemble U, Finite U X -> Finite U Y -> Finite U (Union U X Y).
Proof. hammer_hook "Finite_sets_facts" "Finite_sets_facts.Union_preserves_Finite".
intros X Y H; induction H as [|A Fin_A Hind x].
rewrite (Empty_set_zero U Y). trivial.
intros.
rewrite (Union_commutative U (Add U A x) Y).
rewrite <- (Union_add U Y A x).
rewrite (Union_commutative U Y A).
apply Add_preserves_Finite.
apply Hind. assumption.
Qed.

Lemma Finite_downward_closed :
forall A:Ensemble U,
Finite U A -> forall X:Ensemble U, Included U X A -> Finite U X.
Proof. hammer_hook "Finite_sets_facts" "Finite_sets_facts.Finite_downward_closed".
intros A H'; elim H'; auto with sets.
intros X H'0.
rewrite (less_than_empty U X H'0); auto with sets.
intros; elim Included_Add with U X A0 x; auto with sets.
destruct 1 as [A' [H5 H6]].
rewrite H5; auto with sets.
Qed.

Lemma Intersection_preserves_finite :
forall A:Ensemble U,
Finite U A -> forall X:Ensemble U, Finite U (Intersection U X A).
Proof. hammer_hook "Finite_sets_facts" "Finite_sets_facts.Intersection_preserves_finite".
intros A H' X; apply Finite_downward_closed with A; auto with sets.
Qed.

Lemma cardinalO_empty :
forall X:Ensemble U, cardinal U X 0 -> X = Empty_set U.
Proof. hammer_hook "Finite_sets_facts" "Finite_sets_facts.cardinalO_empty".
intros X H; apply (cardinal_invert U X 0); trivial with sets.
Qed.

Lemma inh_card_gt_O :
forall X:Ensemble U, Inhabited U X -> forall n:nat, cardinal U X n -> n > 0.
Proof. hammer_hook "Finite_sets_facts" "Finite_sets_facts.inh_card_gt_O".
induction 1 as [x H'].
intros n H'0.
elim (gt_O_eq n); auto with sets.
intro H'1; generalize H'; generalize H'0.
rewrite <- H'1; intro H'2.
rewrite (cardinalO_empty X); auto with sets.
intro H'3; elim H'3.
Qed.

Lemma card_soustr_1 :
forall (X:Ensemble U) (n:nat),
cardinal U X n ->
forall x:U, In U X x -> cardinal U (Subtract U X x) (pred n).
Proof.
intros X n H'; elim H'.
intros x H'0; elim H'0.
clear H' n X.
intros X n H' H'0 x H'1 x0 H'2.
elim (classic (In U X x0)).
intro H'4; rewrite (add_soustr_xy U X x x0).
elim (classic (x = x0)).
intro H'5.
absurd (In U X x0); auto with sets.
rewrite <- H'5; auto with sets.
intro H'3; try assumption.
cut (S (pred n) = pred (S n)).
intro H'5; rewrite <- H'5.
apply card_add; auto with sets.
red; intro H'6; elim H'6.
intros H'7 H'8; try assumption.
elim H'1; auto with sets.
unfold pred at 2; symmetry .
apply S_pred with (m := 0).
change (n > 0).
apply inh_card_gt_O with (X := X); auto with sets.
apply Inhabited_intro with (x := x0); auto with sets.
red; intro H'3.
apply H'1.
elim H'3; auto with sets.
rewrite H'3; auto with sets.
elim (classic (x = x0)).
intro H'3; rewrite <- H'3.
cut (Subtract U (Add U X x) x = X); auto with sets.
intro H'4; rewrite H'4; auto with sets.
intros H'3 H'4; try assumption.
absurd (In U (Add U X x) x0); auto with sets.
red; intro H'5; try exact H'5.
lapply (Add_inv U X x x0); tauto.
Qed.

Lemma cardinal_is_functional :
forall (X:Ensemble U) (c1:nat),
cardinal U X c1 ->
forall (Y:Ensemble U) (c2:nat), cardinal U Y c2 -> X = Y -> c1 = c2.
Proof.
intros X c1 H'; elim H'.
intros Y c2 H'0; elim H'0; auto with sets.
intros A n H'1 H'2 x H'3 H'5.
elim (not_Empty_Add U A x); auto with sets.
clear H' c1 X.
intros X n H' H'0 x H'1 Y c2 H'2.
elim H'2.
intro H'3.
elim (not_Empty_Add U X x); auto with sets.
clear H'2 c2 Y.
intros X0 c2 H'2 H'3 x0 H'4 H'5.
elim (classic (In U X0 x)).
intro H'6; apply f_equal.
apply H'0 with (Y := Subtract U (Add U X0 x0) x).
elimtype (pred (S c2) = c2); auto with sets.
apply card_soustr_1; auto with sets.
rewrite <- H'5.
apply Sub_Add_new; auto with sets.
elim (classic (x = x0)).
intros H'6 H'7; apply f_equal.
apply H'0 with (Y := X0); auto with sets.
apply Simplify_add with (x := x); auto with sets.
pattern x at 2; rewrite H'6; auto with sets.
intros H'6 H'7.
absurd (Add U X x = Add U X0 x0); auto with sets.
clear H'0 H' H'3 n H'5 H'4 H'2 H'1 c2.
red; intro H'.
lapply (Extension U (Add U X x) (Add U X0 x0)); auto with sets.
clear H'.
intro H'; red in H'.
elim H'; intros H'0 H'1; red in H'0; clear H' H'1.
absurd (In U (Add U X0 x0) x); auto with sets.
lapply (Add_inv U X0 x0 x); [ intuition | apply (H'0 x); apply Add_intro2 ].
Qed.

Lemma cardinal_Empty : forall m:nat, cardinal U (Empty_set U) m -> 0 = m.
Proof. hammer_hook "Finite_sets_facts" "Finite_sets_facts.cardinal_Empty".
intros m Cm; generalize (cardinal_invert U (Empty_set U) m Cm).
elim m; auto with sets.
intros; elim H0; intros; elim H1; intros; elim H2; intros.
elim (not_Empty_Add U x x0 H3).
Qed.

Lemma cardinal_unicity :
forall (X:Ensemble U) (n:nat),
cardinal U X n -> forall m:nat, cardinal U X m -> n = m.
Proof. hammer_hook "Finite_sets_facts" "Finite_sets_facts.cardinal_unicity".
intros; apply cardinal_is_functional with X X; auto with sets.
Qed.

Lemma card_Add_gen :
forall (A:Ensemble U) (x:U) (n n':nat),
cardinal U A n -> cardinal U (Add U A x) n' -> n' <= S n.
Proof. hammer_hook "Finite_sets_facts" "Finite_sets_facts.card_Add_gen".
intros A x n n' H'.
elim (classic (In U A x)).
intro H'0.
rewrite (Non_disjoint_union U A x H'0).
intro H'1; cut (n = n').
intro E; rewrite E; auto with sets.
apply cardinal_unicity with A; auto with sets.
intros H'0 H'1.
cut (n' = S n).
intro E; rewrite E; auto with sets.
apply cardinal_unicity with (Add U A x); auto with sets.
Qed.

Lemma incl_st_card_lt :
forall (X:Ensemble U) (c1:nat),
cardinal U X c1 ->
forall (Y:Ensemble U) (c2:nat),
cardinal U Y c2 -> Strict_Included U X Y -> c2 > c1.
Proof.
intros X c1 H'; elim H'.
intros Y c2 H'0; elim H'0; auto with sets arith.
intro H'1.
elim (Strict_Included_strict U (Empty_set U)); auto with sets arith.
clear H' c1 X.
intros X n H' H'0 x H'1 Y c2 H'2.
elim H'2.
intro H'3; elim (not_SIncl_empty U (Add U X x)); auto with sets arith.
clear H'2 c2 Y.
intros X0 c2 H'2 H'3 x0 H'4 H'5; elim (classic (In U X0 x)).
intro H'6; apply gt_n_S.
apply H'0 with (Y := Subtract U (Add U X0 x0) x).
elimtype (pred (S c2) = c2); auto with sets arith.
apply card_soustr_1; auto with sets arith.
apply incl_st_add_soustr; auto with sets arith.
elim (classic (x = x0)).
intros H'6 H'7; apply gt_n_S.
apply H'0 with (Y := X0); auto with sets arith.
apply sincl_add_x with (x := x0).
rewrite <- H'6; auto with sets arith.
pattern x0 at 1; rewrite <- H'6; trivial with sets arith.
intros H'6 H'7; red in H'5.
elim H'5; intros H'8 H'9; try exact H'8; clear H'5.
red in H'8.
generalize (H'8 x).
intro H'5; lapply H'5; auto with sets arith.
intro H; elim Add_inv with U X0 x0 x; auto with sets arith.
intro; absurd (In U X0 x); auto with sets arith.
intro; absurd (x = x0); auto with sets arith.
Qed.

Lemma incl_card_le :
forall (X Y:Ensemble U) (n m:nat),
cardinal U X n -> cardinal U Y m -> Included U X Y -> n <= m.
Proof. hammer_hook "Finite_sets_facts" "Finite_sets_facts.incl_card_le".
intros; elim Included_Strict_Included with U X Y; auto with sets arith; intro.
cut (m > n); auto with sets arith.
apply incl_st_card_lt with (X := X) (Y := Y); auto with sets arith.
generalize H0; rewrite <- H2; intro.
cut (n = m).
intro E; rewrite E; auto with sets arith.
apply cardinal_unicity with X; auto with sets arith.
Qed.

Lemma G_aux :
forall P:Ensemble U -> Prop,
(forall X:Ensemble U,
Finite U X ->
(forall Y:Ensemble U, Strict_Included U Y X -> P Y) -> P X) ->
P (Empty_set U).
Proof. hammer_hook "Finite_sets_facts" "Finite_sets_facts.G_aux".
intros P H'; try assumption.
apply H'; auto with sets.
clear H'; auto with sets.
intros Y H'; try assumption.
red in H'.
elim H'; intros H'0 H'1; try exact H'1; clear H'.
lapply (less_than_empty U Y); [ intro H'3; try exact H'3 | assumption ].
elim H'1; auto with sets.
Qed.

End Finite_sets_facts.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main.

Local Open Scope morphism_scope.

Section Algebras.
  Context {C : Category} (T : (C –≻ C)%functor).

  (** A T-Algebra in category C for an endo-functor T : C → C is a pair (U, h)
      where U is an object of C and h : T _o U → U is an arrow in C. *)
  Record Algebra : Type :=
    {
      Alg_Carrier : C;
      Constructors : (T _o Alg_Carrier)%object –≻ Alg_Carrier
    }.

  (** A T-Algebra homomorphism from (U, h) to (U', h') is an arrow g : U → U'
such that the following diagram commutes:

#
<pre>

              T _a g
   T _o U ——————————————> T _o U'
     |                      |
     |                      |
     |                      |
   h |                      | h'
     |                      |
     |                      |
     ↓                      ↓
     U ————–——————————————> U
                g
</pre>
#
 *)
  Record Algebra_Hom (alg alg' : Algebra) : Type :=
    {
      Alg_map : (Alg_Carrier alg) –≻ (Alg_Carrier alg');

      Alg_map_com : ((Constructors alg') ∘ (T _a Alg_map)
                     = Alg_map ∘ (Constructors alg))%morphism
    }.

  Arguments Alg_map {_ _} _.
  Arguments Alg_map_com {_ _} _.

  (** Composition of algebra homomorphisms. The algebra maps are simply
      composed. *)
  Program Definition Algebra_Hom_compose
          {alg alg' alg'' : Algebra}
          (h : Algebra_Hom alg alg')
          (h' : Algebra_Hom alg' alg'')
    : Algebra_Hom alg alg''
    :=
      {|
        Alg_map := ((Alg_map h') ∘ (Alg_map h))%morphism
      |}.

  Next Obligation.
  Proof.
    destruct h as [alm almcm]; destruct h' as [alm' almcm']; cbn.
    rewrite F_compose.
    rewrite assoc_sym.
    rewrite almcm'.
    rewrite assoc.
    rewrite almcm.
    auto.
  Qed.

  (** Two algebra maps are equal if their underlying maps are. The commutative
      diagrams are equated with proof irrelevance. *)
  Lemma Algebra_Hom_eq_simplify (alg alg' : Algebra)
        (ah ah' : Algebra_Hom alg alg')
    : (Alg_map ah) = (Alg_map ah') -> ah = ah'.
  Proof.
    intros; destruct ah; destruct ah'; cbn in *.
    ElimEq.
    PIR.
    trivial.
  Qed.

  (** Composition of algebra homomorphisms is associative. *)
  Theorem Algebra_Hom_compose_assoc
          {alg alg' alg'' alg''' : Algebra}
          (f : Algebra_Hom alg alg')
          (g : Algebra_Hom alg' alg'')
          (h : Algebra_Hom alg'' alg''') :
    (Algebra_Hom_compose f (Algebra_Hom_compose g h))
    = (Algebra_Hom_compose (Algebra_Hom_compose f g) h).
  Proof.
    apply Algebra_Hom_eq_simplify; cbn; auto.
  Qed.

  (** The identity algebra homomorphism. *)
  Program Definition Algebra_Hom_id (alg : Algebra) : Algebra_Hom alg alg :=
    {|
      Alg_map := id
    |}.

  (** Identity algebra homomorphism is the left unit of compositon. *)
  Theorem Algebra_Hom_id_unit_left
          {alg alg' : Algebra}
          (f : Algebra_Hom alg alg') :
    (Algebra_Hom_compose f (Algebra_Hom_id alg')) = f.
  Proof.
    apply Algebra_Hom_eq_simplify; cbn; auto.
  Qed.

  (** Identity algebra homomorphism is the right unit of compositon. *)
  Theorem Algebra_Hom_id_unit_right
          {alg alg' : Algebra}
          (f : Algebra_Hom alg alg') :
    (Algebra_Hom_compose (Algebra_Hom_id alg) f) = f.
  Proof.
    apply Algebra_Hom_eq_simplify; cbn; auto.
  Qed.

  (** Algebras of an endo-functor form a category. *)
  Definition Algebra_Cat : Category :=
    {|
      Obj := Algebra;
      Hom := Algebra_Hom;
      compose := @Algebra_Hom_compose;
      assoc := @Algebra_Hom_compose_assoc;
      assoc_sym := fun _ _ _ _ _ _ _ =>
                     eq_sym (@Algebra_Hom_compose_assoc _ _ _ _ _ _ _);
      id := Algebra_Hom_id;
      id_unit_left := @Algebra_Hom_id_unit_left;
      id_unit_right := @Algebra_Hom_id_unit_right
    |}.

End Algebras.

Arguments Alg_Carrier {_ _} _.
Arguments Constructors {_ _} _.
Arguments Algebra_Hom {_ _} _ _.
Arguments Alg_map {_ _ _ _} _.
Arguments Alg_map_com {_ _ _ _} _.
Arguments Algebra_Hom_id {_ _} _.

(** Coalgebras are algebras in the dual category. *)
Section CoAlgebras.
  Context {C : Category}.

  Definition CoAlgebra (T : (C –≻ C)%functor) :=
    @Algebra (C^op) (T^op).

  Definition CoAlgebra_Hom {T : (C –≻ C)%functor} :=
      @Algebra_Hom (C^op) (T^op).

  Definition CoAlgebra_Hom_id {T : (C –≻ C)%functor} :=
    @Algebra_Hom_id  (C^op) (T^op).

  Definition CoAlgebra_Cat (T : (C –≻ C)%functor) :=
    @Algebra_Cat (C^op) (T^op).

End CoAlgebras.


Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import Crypto.Util.ZUtil.Hints.Core.
Local Open Scope Z_scope.

Module N2Z.
  Lemma inj_land n m : Z.of_N (N.land n m) = Z.land (Z.of_N n) (Z.of_N m).
  Proof. destruct n, m; reflexivity. Qed.
  Hint Rewrite inj_land : push_Zof_N.
  Hint Rewrite <- inj_land : pull_Zof_N.

  Lemma inj_lor n m : Z.of_N (N.lor n m) = Z.lor (Z.of_N n) (Z.of_N m).
  Proof. destruct n, m; reflexivity. Qed.
  Hint Rewrite inj_lor : push_Zof_N.
  Hint Rewrite <- inj_lor : pull_Zof_N.

  Lemma inj_shiftl: forall x y, Z.of_N (N.shiftl x y) = Z.shiftl (Z.of_N x) (Z.of_N y).
  Proof.
    intros x y.
    apply Z.bits_inj_iff'; intros k Hpos.
    rewrite Z2N.inj_testbit; [|assumption].
    rewrite Z.shiftl_spec; [|assumption].

    assert ((Z.to_N k) >= y \/ (Z.to_N k) < y)%N as g by (
        unfold N.ge, N.lt; induction (N.compare (Z.to_N k) y); [left|auto|left];
        intro H; inversion H).

    destruct g as [g|g];
    [ rewrite N.shiftl_spec_high; [|apply N2Z.inj_le; rewrite Z2N.id|apply N.ge_le]
    | rewrite N.shiftl_spec_low]; try assumption.

    - rewrite <- N2Z.inj_testbit; f_equal.
        rewrite N2Z.inj_sub, Z2N.id; [reflexivity|assumption|apply N.ge_le; assumption].

    - apply N2Z.inj_lt in g.
        rewrite Z2N.id in g; [symmetry|assumption].
        apply Z.testbit_neg_r; lia.
  Qed.
  Hint Rewrite inj_shiftl : push_Zof_N.
  Hint Rewrite <- inj_shiftl : pull_Zof_N.

  Lemma inj_shiftr: forall x y, Z.of_N (N.shiftr x y) = Z.shiftr (Z.of_N x) (Z.of_N y).
  Proof.
    intros.
    apply Z.bits_inj_iff'; intros k Hpos.
    rewrite Z2N.inj_testbit; [|assumption].
    rewrite Z.shiftr_spec, N.shiftr_spec; [|apply N2Z.inj_le; rewrite Z2N.id|]; try assumption.
    rewrite <- N2Z.inj_testbit; f_equal.
    rewrite N2Z.inj_add; f_equal.
    apply Z2N.id; assumption.
  Qed.
  Hint Rewrite inj_shiftr : push_Zof_N.
  Hint Rewrite <- inj_shiftr : pull_Zof_N.
End N2Z.


Require Export Functor NaturalTransformation.Core.
Require Import Common.

Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.
Set Universe Polymorphism.

Local Open Scope morphism_scope.
Local Open Scope natural_transformation_scope.

Section NaturalTransformations_Equal.
  Context `{Funext}.

  Variable C : PreCategory.
  Variable D : PreCategory.
  Variables F G : Functor C D.

  Local Open Scope equiv_scope.

  Lemma NaturalTransformation_sig
  : { CO : forall x, Morphism D (F x) (G x)
    | forall s d (m : Morphism C s d),
        CO d ∘ F ₁ m = G ₁ m ∘ CO s }
      <~> NaturalTransformation F G.
  Proof.
    let build := constr:(@Build_NaturalTransformation _ _ F G) in
    let pr1 := constr:(@ComponentsOf _ _ F G) in
    let pr2 := constr:(@Commutes _ _ F G) in
    apply (equiv_adjointify (fun u => build u.1 u.2)
                            (fun v => (pr1 v; pr2 v)));
      hnf;
      [ intros []; intros; simpl; expand; f_ap; exact (center _)
      | intros; apply eta_sigma ].
  Defined.

  Global Instance NaturalTransformation_IsHSet : IsHSet (NaturalTransformation F G).
    eapply trunc_equiv'; [ exact NaturalTransformation_sig | ].
    typeclasses eauto.
  Qed.

  Lemma NaturalTransformation_eq' (T U : NaturalTransformation F G)
  : ComponentsOf T = ComponentsOf U
    -> T = U.
  Proof.
    intros.
    destruct T, U; simpl in *.
    path_induction.
    f_ap;
      refine (center _).
  Qed.

  Lemma NaturalTransformation_eq (T U : NaturalTransformation F G)
  : ComponentsOf T == ComponentsOf U
    -> T = U.
  Proof.
    intros.
    apply NaturalTransformation_eq'.
    apply path_forall; assumption.
  Qed.

  Let eq_inv (T U : NaturalTransformation F G) : T = U -> ComponentsOf T == ComponentsOf U
    := (fun H _ => match H with idpath => idpath end).

  Lemma NaturalTransformation_eq_equiv_eisretr (T U : NaturalTransformation F G)
  : Sect (NaturalTransformation_eq T U) (@eq_inv T U).
  Proof.
    repeat intro.
    refine (center _).
  Qed.

  Lemma NaturalTransformation_eq_equiv_eissect (T U : NaturalTransformation F G)
  : Sect (@eq_inv T U) (NaturalTransformation_eq T U).
  Proof.
    repeat intro.
    refine (center _).
  Qed.

  Lemma NaturalTransformation_eq_equiv_eisadj (T U : NaturalTransformation F G)
  : forall x, @NaturalTransformation_eq_equiv_eisretr T U (@eq_inv T U x)
              = ap (@eq_inv T U) (NaturalTransformation_eq_equiv_eissect x).
  Proof.
    repeat intro.
    refine (center _).
  Qed.

  Lemma NaturalTransformation_eq_equiv (T U : NaturalTransformation F G)
  : T = U <~> (ComponentsOf T == ComponentsOf U).
  Proof.
    econstructor; econstructor; exact (@NaturalTransformation_eq_equiv_eisadj T U).
  Defined.
End NaturalTransformations_Equal.

Ltac nt_eq :=
  repeat match goal with
           | _ => intro
           | _ => apply NaturalTransformation_eq; simpl
         end.


Require Coq.Logic.Classical_Prop.
Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_tactics.
Require Import ProofCheckingEuclid.lemma_betweennesspreserved.
Require Import ProofCheckingEuclid.lemma_congruencesymmetric.
Require Import ProofCheckingEuclid.lemma_congruencetransitive.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_collinearitypreserved :
	forall A B C a b c,
	Col A B C ->
	Cong A B a b ->
	Cong A C a c ->
	Cong B C b c ->
	Col a b c.
Proof.
	intros A B C a b c.
	intros Col_A_B_C.
	intros Cong_AB_ab.
	intros Cong_AC_ac.
	intros Cong_BC_bc.

	unfold Col.

	unfold Col in Col_A_B_C.
	destruct Col_A_B_C as [eq_A_B | [eq_A_C | [eq_B_C | [BetS_B_A_C | [BetS_A_B_C | BetS_A_C_B]]]]].
	{
		(* case eq_A_B *)
		assert (Cong A A a b) as Cong_AA_ab by (setoid_rewrite eq_A_B at 2; exact Cong_AB_ab).
		pose proof (lemma_congruencesymmetric _ _ _ _ Cong_AA_ab) as Cong_ab_AA.
		assert (~ neq a b) as eq_a_b.
		{
			intros neq_a_b.

			pose proof (axiom_nocollapse _ _ _ _ neq_a_b Cong_ab_AA) as neq_A_A.
			assert (eq A A) as eq_A_A by (reflexivity).

			contradict eq_A_A.
			exact neq_A_A.
		}
		unfold neq in eq_a_b.
		apply Classical_Prop.NNPP in eq_a_b.
		one_of_disjunct eq_a_b.
	}
	{
		(* case eq_A_C *)
		assert (Cong A A a c) as Cong_AA_ac by (setoid_rewrite eq_A_C at 2; exact Cong_AC_ac).
		pose proof (lemma_congruencesymmetric _ _ _ _ Cong_AA_ac) as Cong_ac_AA.
		assert (~ neq a c) as eq_a_c.
		{
			intros neq_a_c.

			pose proof (axiom_nocollapse _ _ _ _ neq_a_c Cong_ac_AA) as neq_A_A.
			assert (eq A A) as eq_A_A by (reflexivity).

			contradict eq_A_A.
			exact neq_A_A.
		}
		unfold neq in eq_a_c.
		apply Classical_Prop.NNPP in eq_a_c.
		one_of_disjunct eq_a_c.
	}
	{
		(* case eq_B_C *)
		assert (Cong B B b c) as Cong_BB_bc by (setoid_rewrite eq_B_C at 2; exact Cong_BC_bc).
		pose proof (lemma_congruencesymmetric _ _ _ _ Cong_BB_bc) as Cong_bc_BB.
		assert (~ neq b c) as eq_b_c.
		{
			intros neq_b_c.

			pose proof (axiom_nocollapse _ _ B B neq_b_c Cong_bc_BB) as neq_B_B.
			assert (eq B B) as eq_B_B by (reflexivity).

			contradict eq_B_B.
			exact neq_B_B.
		}
		unfold neq in eq_b_c.
		apply Classical_Prop.NNPP in eq_b_c.
		one_of_disjunct eq_b_c.
	}
	{
		(* case BetS_B_A_C *)
		pose proof (cn_congruencereverse a b) as Cong_ab_ba.
		pose proof (cn_congruencereverse A B) as Cong_AB_BA.
		pose proof (lemma_congruencetransitive _ _ _ _ _ _ Cong_AB_ab Cong_ab_ba) as Cong_AB_ba.
		pose proof (lemma_congruencesymmetric _ _ _ _ Cong_AB_BA) as Cong_BA_AB.
		pose proof (lemma_congruencetransitive _ _ _ _ _ _ Cong_BA_AB Cong_AB_ba) as Cong_BA_ba.
		pose proof (
			lemma_betweennesspreserved _ _ _ _ _ _ Cong_BA_ba Cong_BC_bc Cong_AC_ac BetS_B_A_C
		) as BetS_b_a_c.
		one_of_disjunct BetS_b_a_c.
	}
	{
		(* case BetS_A_B_C *)
		pose proof (
			lemma_betweennesspreserved _ _ _ _ _ _ Cong_AB_ab Cong_AC_ac Cong_BC_bc BetS_A_B_C
		) as BetS_a_b_c.
		one_of_disjunct BetS_a_b_c.
	}
	{
		(* case BetS_A_C_B *)
		pose proof (cn_congruencereverse C B) as Cong_CB_BC.
		pose proof (cn_congruencereverse b c) as Cong_bc_cb.
		pose proof (lemma_congruencetransitive _ _ _ _ _ _ Cong_CB_BC Cong_BC_bc) as Cong_CB_bc.
		pose proof (lemma_congruencetransitive _ _ _ _ _ _ Cong_CB_bc Cong_bc_cb) as Cong_CB_cb.
		pose proof (
			lemma_betweennesspreserved _ _ _ _ _ _ Cong_AC_ac Cong_AB_ab Cong_CB_cb BetS_A_C_B
		) as BetS_a_c_b.
		one_of_disjunct BetS_a_c_b.
	}
Qed.

End Euclid.


(** * Projeto: Binary Search Trees (BST) *)

(** Neste projeto estudaremos as árvores de busca binária em um contexto mais formal. Com o intuito de aproveitar o esforço feito para realização do primeiro projeto, aqui o trabalho também poderá ser feito no assistente de provas Coq, mas se você preferir pode implementar a estrutura de árvores de busca binária em sua linguagem de programação preferida e provar as propriedades em papel e lápis.

Este projeto foi adaptado de https://softwarefoundations.cis.upenn.edu/

Leitura recomendada:

    - Capítulo 12 de _Introduction to Algorithms, 3rd Edition_, Cormen, Leiserson, and Rivest, MIT Press 2009. *)

From Coq Require Import String.
From Coq Require Export Arith.
From Coq Require Export Omega.

Notation  "a >=? b" := (Nat.leb b a) (at level 70) : nat_scope.
Notation  "a >? b"  := (Nat.ltb b a) (at level 70) : nat_scope.

(** * Implementação de BST *)

(** Utilizaremos números naturais para representar as chaves em cada nó de nossas BSTs porque os naturais possuem uma ordem total [<=?] com diversos teoremas já provados. *)

Definition key := nat.

(** Definiremos indutivamente árvores cujos elementos têm tipo [V] qualquer. Nesta construção, cada nó da árvore possui uma chave [k] que está relacionada com um valor [v] do tipo [V]. Árvores possuem dois construtores, [E] que representa a árvore vazia, e [T] que recebe os seguintes argumentos:

- [l]: a subárvore à esquerda do nó atual;
- [k]: a chave ligada ao nó atual;
- [v]: o valor associado à chave [k], e;
- [r]: a subárvore à direita do nó atual.

Nesta construção, cada chave se liga a apenas um valor. *)

Inductive tree (V : Type) : Type :=
| E
| T (l : tree V) (k : key) (v : V) (r : tree V).

(* begin hide *)
Arguments E {V}.
Arguments T {V}.
(* end hide *)

(** Um exemplo:

      4 -> "four"
      /        \
     /          \
  2 -> "two"   5 -> "five"
*)

Definition ex_tree : tree string :=
  (T (T E 2 "two" E) 4 "four" (T E 5 "five" E))%string.

(** A árvore vazia [empty_tree] não contém chaves: *)

Definition empty_tree {V : Type} : tree V :=
  E.

(** Uma BST é caracterizada pela seguinte invariante: dado qualquer nó não-vazio com chave [k], todas as chaves da subárvore à esquerda são menores do que [k], e todas as chaves da subárvores à direita são maiores do que [k]. Baseado nesta invariante, construímos a função [bound k t] que retorna [true] quando [k] é uma chave de [t], e [false] caso contrário. *)

Fixpoint bound {V : Type} (x : key) (t : tree V) :=
  match t with
  | E => false
  | T l y v r => if x <? y then bound x l
                else if x >? y then bound x r
                     else true
  end.

(** A função [lookup d k t] retorna o valor ligado à chave [k] em [t], ou retorna
    o valor _default_ [d] quando [k] não é uma chave de [t]. Esta função também é baseada na invariante de BST. *)

Fixpoint lookup {V : Type} (d : V) (x : key) (t : tree V) : V :=
  match t with
  | E => d
  | T l y v r => if x <? y then lookup d x l
                else if x >? y then lookup d x r
                     else v
  end.

(** Assim, se [t] não é uma BST então as funções [bound] e [lookup] podem retornar respostas erradas: *)

Module NotBst.
  Open Scope string_scope.

  (** De fato, considere a seguinte árvore que não é uma BST: *)

  Definition t : tree string :=
    T (T E 5 "five" E) 4 "four" (T E 2 "two" E).

  (** Ela possui uma ocorrência da chave 2, mas em uma posição não esperada pelas funções [bound] e [lookup]: *)

  Example not_bst_bound_wrong :
    bound 2 t = false.
  Proof.
    reflexivity.
  Qed.

  Example not_bst_lookup_wrong :
    lookup "" 2 t <> "two".
  Proof.
    simpl. unfold not. intros contra. discriminate.
  Qed.
End NotBst.

(** A função [insert k v t] insere a chave [k] e o valor [v] na árvore [t], de forma a preservar a invariante de uma BST. *)

Fixpoint insert {V : Type} (x : key) (v : V) (t : tree V) : tree V :=
  match t with
  | E => T E x v E
  | T l y v' r => if x <? y then T (insert x v l) y v' r
                 else if x >? y then T l y v' (insert x v r)
                      else T l x v r
  end.

(** Nossa primeira tarefa será mostrar que a função [insert] de fato preserva esta invariante. Vamos então formalizar a invariante de uma BST. Faremos isto com a ajuda da função [ForallT]: *)

Fixpoint ForallT {V : Type} (P: key -> V -> Prop) (t: tree V) : Prop :=
  match t with
  | E => True
  | T l k v r => P k v /\ ForallT P l /\ ForallT P r
  end.

(** Esta função expressa as condições para que uma árvore satisfaça uma dada propriedade [P]: Se a árvore for vazia então a propriedade é automaticamente satisfeita por vacuidade, e portanto retorna [True]. Quando a árvore não é vazia, e portanto tem a forma [T l k v r] então precisamos que o nó que tem chave [k] e valor [v] satisfaça a propriedade [P], assim como as subárvores à esquerda e à direita.

Agora vamos definir a invariante BST, que é composta de dois construtores:

    - O primeiro, denotado por [BST_E], consiste em um axioma que estabelece que uma árvore vazia é uma BST.

    - O segundo, denotado por [BST_T], consiste na regra que diz que para que uma árvore não vazia [T l x v r] seja uma BST é necessário que todas as chaves da subárvore à esquerda sejam menores do que [x], todas a chaves da subárvore à direita sejam maiores do que [x], e que as subárvores à esquerda e à direita sejam também BSTs: *)

Inductive BST {V : Type} : tree V -> Prop :=
| BST_E : BST E
| BST_T : forall l x v r,
    ForallT (fun y _ => y < x) l ->
    ForallT (fun y _ => y > x) r ->
    BST l ->
    BST r ->
    BST (T l x v r).

(* begin hide *)
Hint Constructors BST.
Ltac inv H := inversion H; clear H; subst.

Inductive reflect (P : Prop) : bool -> Set :=
  | ReflectT :   P -> reflect P true
  | ReflectF : ~ P -> reflect P false.

Theorem iff_reflect : forall P b, (P <-> b = true) -> reflect P b.
Proof.
  intros P b H. destruct b.
  - apply ReflectT. rewrite H. reflexivity.
  - apply ReflectF. rewrite H. intros H'. inversion H'.
Qed.

Theorem reflect_iff : forall P b, reflect P b -> (P <-> b = true).
Proof.
  intros P b H; split.
  - intro H'.
    inv H.
    + reflexivity.
    + contradiction.
  - intro H'; subst.
    inv H; assumption.
Qed.

Lemma eqb_reflect : forall x y, reflect (x = y) (x =? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.eqb_eq.
Qed.

Lemma ltb_reflect : forall x y, reflect (x < y) (x <? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.ltb_lt.
Qed.

Lemma leb_reflect : forall x y, reflect (x <= y) (x <=? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.leb_le.
Qed.

Hint Resolve ltb_reflect leb_reflect eqb_reflect : bdestruct.

Ltac bdestruct X :=
  let H := fresh in let e := fresh "e" in
   evar (e: Prop);
   assert (H: reflect e X); subst e;
    [eauto with bdestruct
    | destruct H as [H|H];
       [ | try first [apply not_lt in H | apply not_le in H]]].
(* end hide *)

(** Let's check that [BST] correctly classifies a couple of example
    trees: *)

Example is_BST_ex :
  BST ex_tree.
Proof.
  unfold ex_tree.
  repeat (constructor; try omega).
Qed.

Example not_BST_ex :
  ~ BST NotBst.t.
Proof.
  unfold NotBst.t. intros contra.
  inv contra. inv H3. omega.
Qed.

(** ** Questão 1: *)
(** A primeira questão consiste em provar que uma árvore vazia (de qualquer tipo) é uma BST. *)

Theorem empty_tree_BST : forall (V : Type),
    BST (@empty_tree V).
Proof.
Admitted.

(** ** Questão 2:  *)
(** A seguir, provaremos que a função [insert] produz uma BST, mas antes prove que a função [insert] preserva qualquer propriedade dos nós: *)

Lemma ForallT_insert : forall (V : Type) (P : key -> V -> Prop) (t : tree V),
    ForallT P t -> forall (k : key) (v : V),
      P k v -> ForallT P (insert k v t).
Proof.

Admitted.

(** ** Questão 3:  *)
(** Prove que ao receber uma BST como argumento, a função [insert] gera uma BST. *)

Theorem insert_BST : forall (V : Type) (k : key) (v : V) (t : tree V),
    BST t -> BST (insert k v t).
Proof.
Admitted.

(** * Correção das funções [lookup] e [bound] *)

(** Qual o comportamento esperado para as funções [lookup] e [bound]? *)

(** Ao procurarmos uma chave na BST vazia com a função [lookup], devemos obter o valor default [d]: *)

Theorem lookup_empty : forall (V : Type) (d : V) (k : key),
    lookup d k empty_tree = d.
Proof.
  auto.
Qed.

(** Se inserirmos a chave [k] e valor [v] na BST [t], então a busca em [insert k v t] com a função [lookup] retorna [v]: *)

Theorem lookup_insert_eq : forall (V : Type) (t : tree V) (d : V) (k : key) (v : V),
    lookup d k (insert k v t) = v.
Proof.
  induction t; intros; simpl.
  - bdestruct (k <? k); try omega; auto.
  - bdestruct (k <? k0); bdestruct (k0 <? k); simpl; try omega; auto.
    + bdestruct (k <? k0); bdestruct (k0 <? k); try omega; auto.
    + bdestruct (k <? k0); bdestruct (k0 <? k); try omega; auto.
    + bdestruct (k0 <? k0); try omega; auto.
Qed.

(** A tática [bdall] a seguir, simplifica esta prova evitando os passos repetitivos *)
Ltac bdestruct_guard :=
  match goal with
  | |- context [ if ?X =? ?Y then _ else _ ] => bdestruct (X =? Y)
  | |- context [ if ?X <=? ?Y then _ else _ ] => bdestruct (X <=? Y)
  | |- context [ if ?X <? ?Y then _ else _ ] => bdestruct (X <? Y)
  end.

Ltac bdall :=
  repeat (simpl; bdestruct_guard; try omega; auto).

Theorem lookup_insert_eq' :
  forall (V : Type) (t : tree V) (d : V) (k : key) (v : V),
    lookup d k (insert k v t) = v.
Proof.
  induction t; intros; bdall.
Qed.

(** ** Questão 4: *)
(** Prove que uma busca de uma chave [k'], via a função [lookup], na BST [insert k v t] com [k] e [k'] distintos retorna o resultado de buscar [k'] em [t]:  *)

Theorem lookup_insert_neq :
  forall (V : Type) (t : tree V) (d : V) (k k' : key) (v : V),
   k <> k' -> lookup d k' (insert k v t) = lookup d k' t.
Proof.
Admitted.

(** ** Questão 5:  *)
(** Enuncie e prove os três teoremas análogos para a função [bound]. *)

Theorem bound_empty : forall (V: Type) (k : key),
    bound k (@empty_tree V) = false.
Proof.
  Admitted.

Theorem bound_insert_eq :
  forall (V : Type) (t : tree V) (k : key) (v : V),
    bound k (insert k v t) = true.
Proof.
  Admitted.

Theorem bound_insert_neq :
  forall (V : Type) (t : tree V) (k k' : key) (v : V),
   k <> k' -> bound k' (insert k v t) = bound k' t.
Proof.
 Admitted.

(** ** Questão 6:  *)
(** A relação esperada entre as funções [bound] e [lookup] é que, se [bound k t] retorna [false] então [lookup d k t] retorna o valor default [d]. Prove este fato dado pelo seguinte teorema: *)

Theorem bound_default :
  forall (V : Type) (k : key) (d : V) (t : tree V),
    bound k t = false ->
    lookup d k t = d.
Proof.
  induction t.
  - admit.
  - Admitted.

(** * Convertendo BSTs em listas *)

From Coq Require Export Lists.List.
Export ListNotations.

(** Podemos converter uma BST em uma lista cujos elementos são pares [(k,v)] contendo a chave [k] e o valor [v]. Se a lista estiver ordenada pelas chaves, então duas árvores representando a mesma BST são convertidas na mesma lista pela função [elements]: *)

Fixpoint elements {V : Type} (t : tree V) : list (key * V) :=
  match t with
  | E => []
  | T l k v r => elements l ++ [(k, v)] ++ elements r
  end.

Example elements_ex :
    elements ex_tree = [(2, "two"); (4, "four"); (5, "five")]%string.
Proof. reflexivity. Qed.

Definition ex_tree' : tree string :=
  (T E 2 "two" (T E 4 "four" (T E 5 "five" E)))%string.

Example elements_ex' :
    elements ex_tree' = [(2, "two"); (4, "four"); (5, "five")]%string.
Proof. reflexivity. Qed.

(** Agora vamos provar que esta transformação possui algumas propriedades interessantes. Por exemplo, dada uma BST [t], uma chave [k] associada a um valor [v] ocorre em [t] se, e somente se o par [(k,v)] é um elemento de [elements t]. Dividiremos esta prova em duas partes: *)

(** ** Questão 7:  *)
(** Prove que a transformação via [elements] é completa, i.e. se uma chave [k] associada a um valor [v] ocorre em [t] então o par [(k,v)] é um elemento de [elements t]: *)

Theorem elements_complete : forall (V : Type) (k : key) (v d : V) (t : tree V),
    BST t ->
    bound k t = true ->
    lookup d k t = v ->
    In (k, v) (elements t).
Proof.
  induction t.
  - intros.
    simpl in H0.
    inv H0.
  - Admitted.

(** Agora vamos provar que a transformação via [elements] é correta, i.e. se o par [(k,v)] é um elemento de [elements t] então a chave [k] ocorre associada a [v] em [t].

A prova da correção exige um pouco mais de trabalho porque enquanto [BST] utiliza o predicado [ForallT] para garantir que todos os nós da árvore satisfazem um determinada propriedade, listas utilizam o predicado [Forall] para isto. Assim, precisamos estabelecer uma relação entre estes predicados. *)

Lemma Forall_app : forall (A: Type) (P : A -> Prop) (l1 l2 : list A),
    Forall P l1 -> Forall P l2 -> Forall P (l1 ++ l2).
Proof.
  induction l1; intros; simpl; auto; inv H; constructor; auto.
Qed.

Definition uncurry {X Y Z : Type} (f : X -> Y -> Z) '(a, b) :=
  f a b.

Hint Transparent uncurry.

(** ** Questão 8:  *)
Lemma elements_preserves_forall : forall (V : Type) (P : key -> V -> Prop) (t : tree V),
    ForallT P t ->
    Forall (uncurry P) (elements t).
Proof.
  induction t.
  - intro.
    simpl.
    apply Forall_nil.
  - intro.
    simpl.
    inv H.
    inv H1.
    apply Forall_app.
    + apply IHt1.
      assumption.
    + apply Forall_cons.
      * unfold uncurry.
        assumption.
      * apply IHt2; assumption.
Qed.

(** ** Questão 9:  *)
Theorem elements_correct : forall (V : Type) (k : key) (v d : V) (t : tree V),
    BST t ->
    In (k, v) (elements t) ->
    bound k t = true /\ lookup d k t = v.
Proof.
  induction t.
  - intros.
    admit.
  - intros.
    simpl in H0.
    inv H.
    apply elements_preserves_forall in H5.
    apply elements_preserves_forall in H6.
    unfold uncurry in *.
    apply in_app_or in H0.
    inv H0.
    + split.
      * simpl.
        bdall.
        ** apply IHt1; assumption.
        ** assert (H': forall x: (key*V), In x (elements t1) -> ((fun '(a, _) => a < k0) x)).
      {
        apply Forall_forall.
        apply H5.
      }
      apply H' in H.
      admit.
    + apply in_inv in H1.
      inv H1.
      * inv H0.
        admit.
      * Admitted.

(** * Uma implementação mais eficiente de [elements] *)

(** ** Questão 10: *)
(** A implementação de [elements] é eficiente? Qual é a complexidade assintótica [elements t] quando [t] é uma árvore balanceada? E quando [t] é desbalanceada? Esta questão deve ser respondida textualmente em detalhes. *)

(** Uma outra forma de transformar uma [BST] em uma lista é dada pela função [elements_tr]: *)

Fixpoint elements_aux {V : Type} (t : tree V)
         (acc : list (key * V)) : list (key * V) :=
  match t with
  | E => acc
  | T l k v r => elements_aux l ((k, v) :: elements_aux r acc)
  end.

Definition elements_tr {V : Type} (t : tree V) : list (key * V) :=
  elements_aux t [].

(** ** Questão 11:  *)
(** Prove que [elements_tr] e [elements] fazem a mesma transformação. *)

Lemma elements_tr_elements : forall (V : Type) (t : tree V),
    elements_tr t = elements t.
Proof.
Admitted.

(** ** Questão 12:  *)
(** Prove que a transformação [elements_tr] é correta utilizando a correção de [elements]. *)

Corollary elements_tr_correct :
  forall (V : Type) (k : key) (v d : V) (t : tree V),
    BST t ->
    In (k, v) (elements_tr t) ->
    bound k t = true /\ lookup d k t = v.
Proof.
Admitted.

(** ** Questão 13:  *)
(** Qual a complexidade assintótica de [elements_tr]? Esta questão deve ser respondida textualmente em detalhes. *)