(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice.
From mathcomp Require Import fintype div tuple bigop ssralg poly polydiv finfun.
From mathcomp Require Import generic_quotient.

From Newtonsums Require Import auxresults valuation revpoly.

(* This file builds the field of fraction of any integral domain. *)
(* The main result of this file is the existence of the field *)
(* and of the tofrac function which is a injective ring morphism from R *)
(* to its fraction field {fraction R} *)

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

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

Reserved Notation "{ 'ratio' T }" (at level 0, format "{ 'ratio'  T }").
Reserved Notation "{ 'fraction' T }" (at level 0, format "{ 'fraction'  T }").
Reserved Notation "{ 'fracpoly' T }" (at level 0, format "{ 'fracpoly'  T }").
Reserved Notation "x %:F" (at level 2, format "x %:F").
Reserved Notation "x %:FP" (at level 2, format "x %:FP").
Reserved Notation "x ^:FP" (at level 2, format "x ^:FP").
Reserved Notation "p \FPo q" (at level 50, format "p  \FPo  q").

Section FracDomain.
Variable R : ringType.

(* ratios are pairs of R, such that the second member is nonzero *)
Inductive ratio := mkRatio { frac :> R * R; _ : frac.2 != 0 }.
Definition ratio_of of phant R := ratio.
Local Notation "{ 'ratio' T }" := (ratio_of (Phant T)).

Canonical ratio_subType := Eval hnf in [subType for frac].
Canonical ratio_of_subType := Eval hnf in [subType of {ratio R}].
Definition ratio_EqMixin := [eqMixin of ratio by <:].
Canonical ratio_eqType := EqType ratio ratio_EqMixin.
Canonical ratio_of_eqType := Eval hnf in [eqType of {ratio R}].
Definition ratio_ChoiceMixin := [choiceMixin of ratio by <:].
Canonical ratio_choiceType := ChoiceType ratio ratio_ChoiceMixin.
Canonical ratio_of_choiceType := Eval hnf in [choiceType of {ratio R}].

Lemma denom_ratioP : forall f : ratio, f.2 != 0. Proof. by case. Qed.

Definition ratio0 := (@mkRatio (0, 1) (oner_neq0 _)).
Definition Ratio x y : {ratio R} := insubd ratio0 (x, y).

Lemma numer_Ratio x y : y != 0 -> (Ratio x y).1 = x.
Proof. by move=> ny0; rewrite /Ratio /insubd insubT. Qed.

Lemma denom_Ratio x y : y != 0 -> (Ratio x y).2 = y.
Proof. by move=> ny0; rewrite /Ratio /insubd insubT. Qed.

Definition RatioK := (numer_Ratio, denom_Ratio).

CoInductive Ratio_spec (n d : R) : {ratio R} -> R -> R -> Type :=
  | RatioNull of d = 0 : Ratio_spec n d ratio0 n 0
  | RatioNonNull (d_neq0 : d != 0) :
    Ratio_spec n d (@mkRatio (n, d) d_neq0) n d.

Lemma RatioP n d : Ratio_spec n d (Ratio n d) n d.
Proof.
rewrite /Ratio /insubd; case: insubP=> /= [x /= d_neq0 hx|].
  have ->: x = @mkRatio (n, d) d_neq0 by apply: val_inj.
  by constructor.
by rewrite negbK=> /eqP hx; rewrite {2}hx; constructor.
Qed.

Lemma Ratio0 x : Ratio x 0 = ratio0.
Proof. by rewrite /Ratio /insubd; case: insubP; rewrite //= eqxx. Qed.

End FracDomain.

Notation "{ 'ratio' T }" := (ratio_of (Phant T)).
Identity Coercion type_fracdomain_of : ratio_of >-> ratio.

Notation "'\n_' x"  := (frac x).1
  (at level 8, x at level 2, format "'\n_' x").
Notation "'\d_' x"  := (frac x).2
  (at level 8, x at level 2, format "'\d_' x").

Module FracField.
Section FracField.

Variable R : idomainType.

Local Notation frac := (R * R).
Local Notation dom := (ratio R).
Local Notation domP := denom_ratioP.

Implicit Types x y z : dom.

(* We define a relation in ratios *)
Local Notation equivf_notation x y := (\n_x * \d_y == \d_x * \n_y).
Definition equivf x y := equivf_notation x y.

Lemma equivfE x y : equivf x y = equivf_notation x y.
Proof. by []. Qed.

Lemma equivf_refl : reflexive equivf.
Proof. by move=> x; rewrite /equivf mulrC. Qed.

Lemma equivf_sym : symmetric equivf.
Proof. by move=> x y; rewrite /equivf eq_sym; congr (_==_); rewrite mulrC. Qed.

Lemma equivf_trans : transitive equivf.
Proof.
move=> [x Px] [y Py] [z Pz]; rewrite /equivf /= mulrC => /eqP xy /eqP yz.
by rewrite -(inj_eq (mulfI Px)) mulrA xy -mulrA yz mulrCA.
Qed.

(* we show that equivf is an equivalence *)
Canonical equivf_equiv := EquivRel equivf equivf_refl equivf_sym equivf_trans.

Definition type := {eq_quot equivf}.
Definition type_of of phant R := type.
Notation "{ 'fraction' T }" := (type_of (Phant T)).

(* we recover some structure for the quotient *)
Canonical frac_quotType := [quotType of type].
Canonical frac_eqType := [eqType of type].
Canonical frac_choiceType := [choiceType of type].
Canonical frac_eqQuotType := [eqQuotType equivf of type].

Canonical frac_of_quotType := [quotType of {fraction R}].
Canonical frac_of_eqType := [eqType of {fraction R}].
Canonical frac_of_choiceType := [choiceType of {fraction R}].
Canonical frac_of_eqQuotType := [eqQuotType equivf of {fraction R}].

(* we explain what was the equivalence on the quotient *)
Lemma equivf_def (x y : ratio R) : x == y %[mod type]
                                    = (\n_x * \d_y == \d_x * \n_y).
Proof. by rewrite eqmodE. Qed.

Lemma equivf_r x : \n_x * \d_(repr (\pi_type x)) =
                                                 \d_x * \n_(repr (\pi_type x)).
Proof. by apply/eqP; rewrite -equivf_def reprK. Qed.

Lemma equivf_l x : \n_(repr (\pi_type x)) * \d_x =
                                                 \d_(repr (\pi_type x)) * \n_x.
Proof. by apply/eqP; rewrite -equivf_def reprK. Qed.

Lemma numer0 x : (\n_x == 0) = (x == (ratio0 R) %[mod_eq equivf]).
Proof. by rewrite eqmodE /= !equivfE // mulr1 mulr0. Qed.

Lemma Ratio_numden : forall x, Ratio \n_x \d_x = x.
Proof.
case=> [[n d] /= nd]; rewrite /Ratio /insubd; apply: val_inj=> /=.
by case: insubP=> //=; rewrite nd.
Qed.

Definition tofrac := lift_embed {fraction R} (fun x : R => Ratio x 1).
Canonical tofrac_pi_morph := PiEmbed tofrac.

Notation "x %:F"  := (@tofrac x).

Implicit Types a b c : type.

Definition addf x y : dom := Ratio (\n_x * \d_y + \n_y * \d_x) (\d_x * \d_y).
Definition add := lift_op2 {fraction R} addf.

Lemma pi_add : {morph \pi : x y / addf x y >-> add x y}.
Proof.
move=> x y; unlock add.
case: piP => x' /eqmodP /eqP eq_x; case: piP => y' /eqmodP /eqP eq_y.
apply/eqmodP/eqP; rewrite /addf /= !RatioK ?mulf_neq0 ?domP //.
rewrite mulrDr mulrDl mulrACA eq_x mulrACA; congr (_ + _).
by rewrite [_ * \d_y']mulrC mulrACA eq_y mulrACA [_ * \d_y]mulrC.
Qed.
Canonical pi_add_morph := PiMorph2 pi_add.

Definition oppf x : dom := Ratio (- \n_x) \d_x.
Definition opp := lift_op1 {fraction R} oppf.
Lemma pi_opp : {morph \pi : x / oppf x >-> opp x}.
Proof.
move=> x; unlock opp; apply/eqmodP; rewrite /= /equivf /oppf /=.
by rewrite !RatioK ?(domP,mulf_neq0) // mulNr mulrN -equivf_r.
Qed.
Canonical pi_opp_morph := PiMorph1 pi_opp.

Definition mulf x y : dom := Ratio (\n_x * \n_y) (\d_x * \d_y).
Definition mul := lift_op2 {fraction R} mulf.

Lemma pi_mul : {morph \pi : x y / mulf x y >-> mul x y}.
Proof.
move=> x y; unlock mul; apply/eqmodP=> /=.
rewrite equivfE /= /addf /= !RatioK ?mulf_neq0 ?domP //.
rewrite mulrAC !mulrA -mulrA equivf_r -equivf_l.
by rewrite mulrA ![_ * \d_y]mulrC !mulrA.
Qed.
Canonical pi_mul_morph := PiMorph2 pi_mul.

Definition invf x : dom := Ratio \d_x \n_x.
Definition inv := lift_op1 {fraction R} invf.

Lemma pi_inv : {morph \pi : x / invf x >-> inv x}.
Proof.
move=> x; unlock inv; apply/eqmodP=> /=; rewrite equivfE /invf eq_sym.
do 2?case: RatioP=> /= [/eqP|];
  rewrite ?mul0r ?mul1r -?equivf_def ?numer0 ?reprK //.
  by move=> hx /eqP hx'; rewrite hx' eqxx in hx.
by move=> /eqP ->; rewrite eqxx.
Qed.
Canonical pi_inv_morph := PiMorph1 pi_inv.

Lemma addA : associative add.
Proof.
elim/quotW=> x; elim/quotW=> y; elim/quotW=> z; rewrite !piE.
rewrite /addf /= !RatioK ?mulf_neq0 ?domP // !mulrDl !mulrA !addrA.
by congr (\pi (Ratio (_ + _ + _) _)); rewrite mulrAC.
Qed.

Lemma addC : commutative add.
Proof.
by elim/quotW=> x; elim/quotW=> y; rewrite !piE /addf addrC [\d__ * _]mulrC.
Qed.

Lemma add0_l : left_id 0%:F add.
Proof.
elim/quotW=> x; rewrite !piE /addf !RatioK ?oner_eq0 //.
by rewrite mul0r mul1r mulr1 add0r Ratio_numden.
Qed.

Lemma addN_l : left_inverse 0%:F opp add.
Proof.
elim/quotW=> x; apply/eqP; rewrite piE /equivf.
rewrite /addf /oppf !RatioK ?(oner_eq0, mulf_neq0, domP) //.
by rewrite mulr1 mulr0 mulNr addNr.
Qed.

(* fractions form an abelian group *)
Definition frac_zmodMixin :=  ZmodMixin addA addC add0_l addN_l.
Canonical frac_zmodType := Eval hnf in ZmodType type frac_zmodMixin.

Lemma mulA : associative mul.
Proof.
elim/quotW=> x; elim/quotW=> y; elim/quotW=> z; rewrite !piE.
by rewrite /mulf !RatioK ?mulf_neq0 ?domP // !mulrA.
Qed.

Lemma mulC : commutative mul.
Proof.
elim/quotW=> x; elim/quotW=> y; rewrite !piE /mulf.
by rewrite [_ * (\d_x)]mulrC [_ * (\n_x)]mulrC.
Qed.

Lemma mul1_l : left_id 1%:F mul.
Proof.
elim/quotW=> x; rewrite !piE /mulf.
by rewrite !RatioK ?oner_eq0 // !mul1r Ratio_numden.
Qed.

Lemma mul_addl : left_distributive mul add.
Proof.
elim/quotW=> x; elim/quotW=> y; elim/quotW=> z; apply/eqP.
rewrite !piE /equivf /mulf /addf !RatioK ?mulf_neq0 ?domP //; apply/eqP.
rewrite !(mulrDr, mulrDl) !mulrA; congr (_ * _ + _ * _).
  rewrite ![_ * \n_z]mulrC -!mulrA; congr (_ * _).
  rewrite ![\d_y * _]mulrC !mulrA; congr (_ * _ * _).
  by rewrite [X in _ = X]mulrC mulrA.
rewrite ![_ * \n_z]mulrC -!mulrA; congr (_ * _).
rewrite ![\d_x * _]mulrC !mulrA; congr (_ * _ * _).
by rewrite -mulrA mulrC [X in X * _] mulrC.
Qed.

Lemma nonzero1 : 1%:F != 0%:F :> type.
Proof. by rewrite piE equivfE !RatioK ?mul1r ?oner_eq0. Qed.

(* fractions form a commutative ring *)
Definition frac_comRingMixin :=
                               ComRingMixin mulA mulC mul1_l mul_addl nonzero1.
Canonical frac_ringType := Eval hnf in RingType type frac_comRingMixin.
Canonical frac_comRingType := Eval hnf in ComRingType type mulC.

Lemma mulV_l : forall a, a != 0%:F -> mul (inv a) a = 1%:F.
Proof.
elim/quotW=> x /=; rewrite !piE.
rewrite /equivf !RatioK ?oner_eq0 // mulr1 mulr0=> nx0.
apply/eqmodP; rewrite /= equivfE.
by rewrite !RatioK ?(oner_eq0, mulf_neq0, domP) // !mulr1 mulrC.
Qed.

Lemma inv0 : inv 0%:F = 0%:F.
Proof.
rewrite !piE /invf !RatioK ?oner_eq0 // /Ratio /insubd.
do 2?case: insubP; rewrite //= ?eqxx ?oner_eq0 // => u _ hu _.
by congr \pi; apply: val_inj; rewrite /= hu.
Qed.

(* fractions form a ring with explicit unit *)
Definition RatFieldUnitMixin := FieldUnitMixin mulV_l inv0.
Canonical frac_unitRingType := Eval hnf in UnitRingType type RatFieldUnitMixin.
Canonical frac_comUnitRingType := [comUnitRingType of type].

Lemma field_axiom : GRing.Field.mixin_of frac_unitRingType.
Proof. exact. Qed.

(* fractions form a field *)
Definition RatFieldIdomainMixin := (FieldIdomainMixin field_axiom).
Canonical frac_idomainType :=
  Eval hnf in IdomainType type (FieldIdomainMixin field_axiom).
Canonical frac_fieldType := FieldType type field_axiom.

End FracField.
End FracField.

Notation "{ 'fraction' T }" := (FracField.type_of (Phant T)).
Notation equivf := (@FracField.equivf _).
Hint Resolve denom_ratioP.

Section Canonicals.

Variable R : idomainType.

(* reexporting the structures *)
Canonical FracField.frac_quotType.
Canonical FracField.frac_eqType.
Canonical FracField.frac_choiceType.
Canonical FracField.frac_zmodType.
Canonical FracField.frac_ringType.
Canonical FracField.frac_comRingType.
Canonical FracField.frac_unitRingType.
Canonical FracField.frac_comUnitRingType.
Canonical FracField.frac_idomainType.
Canonical FracField.frac_fieldType.
Canonical FracField.tofrac_pi_morph.
Canonical frac_of_quotType := Eval hnf in [quotType of {fraction R}].
Canonical frac_of_eqType := Eval hnf  in [eqType of {fraction R}].
Canonical frac_of_choiceType := Eval hnf in [choiceType of {fraction R}].
Canonical frac_of_zmodType := Eval hnf in [zmodType of {fraction R}].
Canonical frac_of_ringType := Eval hnf in [ringType of {fraction R}].
Canonical frac_of_comRingType := Eval hnf in [comRingType of {fraction R}].
Canonical frac_of_unitRingType := Eval hnf in [unitRingType of {fraction R}].
Canonical frac_of_comUnitRingType :=
  Eval hnf in [comUnitRingType of {fraction R}].
Canonical frac_of_idomainType := Eval hnf in [idomainType of {fraction R}].
Canonical frac_of_fieldType := Eval hnf in [fieldType of {fraction R}].

End Canonicals.

Section FracFieldTheory.
Import FracField.

Variable R : idomainType.

Lemma Ratio_numden (x : {ratio R}) : Ratio \n_x \d_x = x.
Proof. exact: FracField.Ratio_numden. Qed.

(* exporting the embeding from R to {fraction R} *)
Local Notation tofrac := (@FracField.tofrac R).
Local Notation "x %:F" := (tofrac x).
Local Notation "x // y" := (x%:F / y%:F) (at level 40).

Lemma tofrac_is_rmorphism: rmorphism tofrac.
Proof.
unlock tofrac; [do ?split] => [p q|p q|]; rewrite [X in _ = X]piE //=.
  by rewrite /addf /oppf /= !RatioK ?oner_eq0 ?mulr1.
by rewrite /mulf !RatioK ?oner_eq0 ?mulr1.
Qed.

Canonical tofrac_additive := Additive tofrac_is_rmorphism.
Canonical tofrac_rmorphism := AddRMorphism tofrac_is_rmorphism.

(* tests *)
Fact tofrac0 : 0%:F = 0. Proof. exact: rmorph0. Qed.
Fact tofracN : {morph tofrac: x / - x}. Proof. exact: rmorphN. Qed.
Fact tofracD : {morph tofrac: x y / x + y}. Proof. exact: rmorphD. Qed.
Fact tofracB : {morph tofrac: x y / x - y}. Proof. exact: rmorphB. Qed.
Fact tofracMn n : {morph tofrac: x / x *+ n}. Proof. exact: rmorphMn. Qed.
Fact tofracMNn n : {morph tofrac: x / x *- n}. Proof. exact: rmorphMNn. Qed.
Fact tofrac1 : 1%:F = 1. Proof. exact: rmorph1. Qed.
Fact tofracM : {morph tofrac: x y  / x * y}. Proof. exact: rmorphM. Qed.
Fact tofracX n : {morph tofrac: x / x ^+ n}. Proof. exact: rmorphX. Qed.

Lemma tofrac_inj : injective tofrac.
Proof.
move=> p q /=; rewrite piE [RHS]piE => /eqmodP /eqP.
by rewrite !RatioK ?oner_eq0 // mulr1 mul1r.
Qed.

Canonical Structure tofrac_injmorphism := InjMorphism tofrac_inj.

Fact mulE (x y : {fraction R}) : x * y = mul x y.
Proof. by []. Qed.

Fact invE (x : {fraction R}) : x ^-1 = inv x.
Proof. by []. Qed.

Lemma fracE (x : {fraction R}) : {y | x = y.1 // y.2 & y.2 != 0}.
Proof.
elim/quotW: x => y; exists y; last exact: denom_ratioP.
rewrite !piE mulrC /=.
set rn := (Ratio \n_y 1).
set dn := (Ratio \d_y 1).
rewrite invE -pi_inv mulE -pi_mul /invf /dn /rn /mulf.
rewrite ?numer_Ratio ?denom_Ratio ?oner_neq0 ?(denom_ratioP y) //.
by rewrite mulr1 mul1r -{1}(Ratio_numden y).
Qed.

Lemma frac_eq0 (p q : R) : (p // q == 0) = (p == 0) || (q == 0).
Proof. by rewrite mulf_eq0 invr_eq0 !rmorph_eq0. Qed.

Lemma frac_neq0 (p q : R) : p != 0 -> q != 0 -> p // q != 0.
Proof. by rewrite frac_eq0 negb_or => -> ->. Qed.

End FracFieldTheory.

Notation tofrac := (@FracField.tofrac _).
Notation "'@'tofrac" := (@FracField.tofrac).
Notation "x %:F" := (@FracField.tofrac _ x).
Notation "x // y" := (x%:F / y%:F) (at level 40).

Notation "{ 'fracpoly' K }" := {fraction {poly K}}.
Definition tofracpoly {K : fieldType} : K -> {fracpoly K} := tofrac \o polyC.

Notation "x %:FP" := (tofracpoly x) : ring_scope.
Local Notation "p ^ f" := (map_poly f p) : ring_scope.
Notation "p ^:FP" := (p ^ (@tofracpoly _)) : ring_scope.

Notation "''XF'" := ('X%:F) : ring_scope.
Notation "''X^+' n" := ('X%:F ^+ n)
 (at level 3, n at level 2, format "''X^+' n") : ring_scope.
Notation "''X^-' n" := ('X%:F ^- n)
 (at level 3, n at level 2, format "''X^-' n") : ring_scope.
Notation "''X^-1'" := ('X%:F)^-1 : ring_scope.

Canonical tofracpoly_is_additive (K : fieldType) :=
  [additive of @tofracpoly K].
Canonical tofracpoly_is_rmorphism (K : fieldType) :=
  [rmorphism of @tofracpoly K].
Canonical tofracpoly_is_injmorphism (K : fieldType) :=
  [injmorphism of @tofracpoly K].

Module RegMorphism.

Section ClassDef.

Variables (R : idomainType) (K : fieldType).

Definition mixin_of (f : R -> K) : Type  :=
  forall x,
  {y : R * R | x = y.1 // y.2 & f y.2 != 0} +
  forall y1 y2, x = y1 // y2 -> f y2 = 0.

Record class_of f : Type := Class {base : rmorphism f; mixin : mixin_of f}.
Local Coercion base : class_of >-> rmorphism.

Structure map (phRS : phant (R -> K)) := Pack {apply; _ : class_of apply}.
Local Coercion apply : map >-> Funclass.
Variables (phRS : phant (R -> K)) (f g : R -> K) (cF : map phRS).

Definition class := let: Pack _ c as cF' := cF return class_of cF' in c.

Definition clone fM of phant_id g (apply cF) & phant_id fM class :=
  @Pack phRS f fM.

Definition pack (fM : mixin_of f) :=
  fun (bF : GRing.RMorphism.map phRS) fA & phant_id (GRing.RMorphism.class bF) fA =>
  Pack phRS (Class fA fM).

Canonical rmorphism := GRing.RMorphism.Pack phRS class.
Canonical additive := GRing.Additive.Pack phRS class.

End ClassDef.

Module Exports.
Notation regular_dec f := (mixin_of f).
Notation regmorphism f := (class_of f).
Coercion base : regmorphism >-> GRing.RMorphism.class_of.
Coercion mixin : regmorphism >-> mixin_of.
Coercion apply : map >-> Funclass.
Notation RegMorphism fM := (pack fM id).
Notation "{ 'regmorphism' fRS }" := (map (Phant fRS))
  (at level 0, format "{ 'regmorphism'  fRS }") : ring_scope.
Notation "[ 'regmorphism' 'of' f 'as' g ]" := (@clone _ _ _ f g _ _ idfun id)
  (at level 0, format "[ 'regmorphism'  'of'  f  'as'  g ]") : form_scope.
Notation "[ 'regmorphism' 'of' f ]" := (@clone _ _ _ f f _ _ id id)
  (at level 0, format "[ 'regmorphism'  'of'  f ]") : form_scope.
Coercion additive : map >-> GRing.Additive.map.
Canonical additive.
Coercion rmorphism : map >-> GRing.RMorphism.map.
Canonical rmorphism.
End Exports.

End RegMorphism.
Include RegMorphism.Exports.

Section EvalInjective.

Variable (R : idomainType) (K : fieldType) (f : {injmorphism R -> K}).

Lemma injective_regular_dec : regular_dec f.
Proof.
move=> x; have [[x1 x2] /= -> x2_neq0] := fracE x.
by left; exists (x1, x2); rewrite //= rmorph_eq0.
Qed.

Canonical injective_is_regmorphism := RegMorphism injective_regular_dec.

End EvalInjective.

Section EvalFrac.

Variables (R : idomainType) (K : fieldType) (f : {regmorphism R -> K}).
Implicit Types (x : {fraction R}).

Definition freprP := RegMorphism.mixin (RegMorphism.class f).

Fact fpole_key : unit. Proof. exact: tt. Qed.
Definition fpole_of (phf: phantom (R -> K) f) := locked_with fpole_key
  (fun x => if freprP x is inr _ then true else false).
Local Notation fpole := (fpole_of (Phantom (R -> K) f)).
Canonical fpole_unlockable := [unlockable fun fpole].

Lemma fpoleP {x} : reflect (forall y1 y2, x = y1 // y2 -> f y2 = 0) (fpole x).
Proof.
rewrite unlock; case: freprP => [[y -> fy2]|]; constructor => //.
by move=> /(_ _ _ erefl); apply/eqP.
Qed.

Definition froot_of (phf: phantom (R -> K) f) x := (fpole x^-1).
Local Notation froot := (froot_of (Phantom (R -> K) f)).

Fact feval_key : unit. Proof. exact: tt. Qed.
(* feval theory *)
Definition feval_of (phf: phantom (R -> K) f) : _ -> K := locked_with feval_key
  (fun x =>
   let frepr x := if freprP x is inl (exist2 y _ _) then y else (0, 0) in
   f (frepr x).1 / f (frepr x).2).
Local Notation feval := (feval_of (Phantom (R -> K) f)).
Canonical feval_unlockable := [unlockable fun feval].

Inductive feval_spec x : {fraction R} ->  bool -> K -> Type :=
| HasPoleEval of fpole x : feval_spec x x true 0
| HasNoPoleEval y1 y2 of f y2 != 0 : feval_spec x (y1 // y2) false (f y1 / f y2).

Lemma fevalP x : feval_spec x x (fpole x) (feval x).
Proof.
rewrite !unlock.
case: freprP => [[y->]|]; rewrite ?rmorph0 ?mul0r; constructor => //.
exact/fpoleP.
Qed.

Lemma fpolePn {x : {fraction R}} :
   reflect (exists2 y, x = y.1 // y.2 & f y.2 != 0) (~~ fpole x).
Proof.
case: fevalP=> [/fpoleP fy2_eq0|y1 y2]; constructor; last by exists (y1, y2).
by move=> [y /fy2_eq0 ->]; rewrite eqxx.
Qed.

Lemma frootP {x} : reflect (forall y1 y2, x = y1 // y2 -> f y1 = 0) (froot x).
Proof.
apply: (equivP fpoleP); pose V := (congr1 (@GRing.inv _)).
by split=> fy0 y1 y2 /V; rewrite ?invrK invf_div; apply: fy0.
Qed.

Lemma frootPn {x} : reflect (exists2 y, x = y.1 // y.2 & (f y.1 != 0))
                            (~~ froot x).
Proof.
apply: (equivP fpolePn); pose V := (congr1 (@GRing.inv _)).
by split=> [] [y /V]; rewrite ?invrK invf_div => ->; exists (y.2, y.1).
Qed.

Lemma fpoleV x : fpole (x ^-1) = froot x. Proof. by []. Qed.

Lemma frootV x : froot (x ^-1) = fpole x.
Proof. by rewrite /froot invrK. Qed.

Lemma froot_div x y : froot (x / y) = fpole (y / x).
Proof. by rewrite /froot invf_div. Qed.

Lemma den_fpole_eq0 (x y : R) : fpole (x // y) -> f y = 0.
Proof. by move=> /fpoleP /(_ x) ->. Qed.

Lemma fpole_fracF (x y : R) : f y != 0 -> fpole (x // y) = false.
Proof. by apply: contraNF => /den_fpole_eq0 ->. Qed.

Lemma fpole_tofrac (x : R) : fpole x%:F = false.
Proof. by rewrite -[x%:F]divr1 fpole_fracF // rmorph1 oner_eq0. Qed.

Lemma fpole0 : fpole 0 = false.
Proof. by rewrite fpole_tofrac. Qed.

Lemma fpole1 : fpole 1 = false.
Proof. by rewrite fpole_tofrac. Qed.

Fact felem_eq0F (x : R) : f x != 0 -> (x == 0) = false.
Proof. by apply: contraNF => /eqP ->; rewrite rmorph0. Qed.

Lemma fpole_frac (x y : R) : y != 0 -> f x != 0 -> fpole (x // y) = (f y == 0).
Proof.
move=> y_neq0 fx_neq0; have [fy_eq0|/fpole_fracF-> //] := altP eqP.
apply/fpoleP => x' y' /eq_divf_mul.
rewrite frac_neq0 // ?felem_eq0F // => /(_ isT).
rewrite -!rmorphM => /tofrac_inj /(congr1 f) /eqP.
by rewrite !rmorphM /= fy_eq0 mulr0 mulf_eq0 (negPf fx_neq0) /= => /eqP.
Qed.

Lemma froot_fracF (x y : R) : f x != 0 -> froot (x // y) = false.
Proof. by rewrite froot_div; apply: fpole_fracF. Qed.

Lemma froot0 : froot 0 = false. Proof. by rewrite /froot invr0 fpole0. Qed.

Lemma num_froot_eq0 (x y : R) : froot (x // y) -> f x = 0.
Proof. by apply: contraTeq => /froot_fracF ->. Qed.

Lemma froot_frac (x y : R) : x != 0 -> f y != 0 -> froot (x // y) = (f x == 0).
Proof. by rewrite froot_div; apply: fpole_frac. Qed.

Lemma froot_tofrac (x : R) : x != 0 -> froot x%:F = (f x == 0).
Proof.
by move=> x_neq0; rewrite -[x%:F]mulr1 -invr1 froot_frac ?rmorph1 ?oner_eq0.
Qed.

Lemma froot1 : froot 1 = false.
Proof. by rewrite froot_tofrac ?rmorph1 ?oner_eq0. Qed.

Lemma fpoleN x : fpole (- x) = fpole x.
Proof.
gen have fpoleN : x / fpole (- x) -> fpole x; last first.
  by apply/idP/idP => ?; apply/fpoleN; rewrite ?opprK.
case: (fevalP x) => // y1 y2 fy2; move=> /(congr1 negb) /= <-.
by rewrite -mulNr -rmorphN fpole_fracF.
Qed.

Lemma frootN x : froot (- x) = froot x.
Proof. by rewrite /froot invrN fpoleN. Qed.

(* Theory of feval *)

Lemma feval_frac (y z : R) : f z != 0 -> feval (y // z) = (f y) / (f z).
Proof.
move=> fz; have := erefl (y // z).
case: {-1}_ _ _ / fevalP fz => //= [/fpoleP /(_ _ _ erefl) /eqP -> //|].
move=> y' z' /= fz' fz /eqP; rewrite eq_divf ?rmorph_eq0 ?felem_eq0F //.
rewrite -!rmorphM rmorph_eq => /eqP eqyz'.
by apply/eqP; rewrite eq_divf // -!rmorphM eqyz'.
Qed.

Lemma feval_neq0P {x} :
    reflect (exists2 y, x = y.1 // y.2 & (f y.1 != 0) && (f y.2 != 0))
            (feval x != 0).
Proof.
apply: (iffP idP) => [|[{x} x -> /andP [fx1 fx2]]]; last first.
  by rewrite feval_frac  // ?mulf_neq0 ?invr_eq0.
case: fevalP => [x_pole|{x} x1 x2 fx2_neq0]; rewrite ?eqxx //.
rewrite mulf_eq0 negb_or invr_eq0 fx2_neq0 andbT => fx1_neq0.
by exists (x1, x2); rewrite //= ?mulf_neq0 ?fx1_neq0.
Qed.

Lemma feval_eq0P {x} :
    reflect (forall y1 y2, x = y1 // y2 -> (f y1 == 0) || (f y2 == 0))
            (feval x == 0).
Proof.
apply: (iffP idP)=> [fx_eq0 y1 y2 x_def|]; last first.
  by move=> Pf; apply/feval_neq0P => [[y /=]] /Pf; rewrite -negb_or => ->.
apply: contraTT fx_eq0; rewrite negb_or => fy1V20.
by apply/feval_neq0P; exists (y1, y2).
Qed.

Lemma fpoleM x y : feval y != 0 -> fpole (x * y) = fpole x.
Proof.
move=> /feval_neq0P=> [[{y} y -> /andP [fy1 fy2]]].
have [|{x} x1 x2 fx2] := fevalP x; last first.
  by rewrite mulf_div -!rmorphM /= fpole_fracF // rmorphM mulf_neq0.
apply: contraTT => /fpolePn [z] /(canRL (mulfK _)) ->; last first.
  by rewrite frac_neq0 ?felem_eq0F // => /(_ isT).
move=> fz2; rewrite invf_div mulf_div -!rmorphM /=.
by rewrite fpole_fracF // rmorphM mulf_neq0.
Qed.

Lemma feval_pole x : fpole x -> feval x = 0.
Proof. by case: fevalP. Qed.

Lemma feval_root  x : froot x -> feval x = 0.
Proof.
case: fevalP => // y1 y2 fy2.
have [-> _|y1_neq0] := eqVneq y1 0; first by rewrite rmorph0 mul0r.
by rewrite froot_frac => // /eqP ->; rewrite mul0r.
Qed.

Lemma feval_tofrac (x : R) : feval (x %:F) = f x.
Proof. by rewrite -[x%:F]divr1 feval_frac ?rmorph1 ?divr1 ?oner_eq0. Qed.

Lemma feval0 : feval 0 = 0. Proof. by rewrite feval_tofrac rmorph0. Qed.
Lemma feval1 : feval 1 = 1. Proof. by rewrite feval_tofrac rmorph1. Qed.

Lemma fevalN : {morph feval : x / - x}.
Proof.
move=> x; have [] := fevalP x; first by rewrite -fpoleN oppr0 => /feval_pole->.
by move=> y1 y2 fy2; rewrite -!mulNr -!rmorphN /= feval_frac.
Qed.

Fact feval_divN0 y z : feval z != 0 -> feval (y / z) = (feval y) / (feval z).
Proof.
case: fevalP; first by rewrite eqxx.
move=> {z} z1 z2 fz2; rewrite mulf_eq0 negb_or invr_eq0 fz2 andbT => fz1.
case: (fevalP y)=> [y_pole|{y} y1 y2 fy2]; rewrite ?mul0r /=; last first.
  rewrite !invfM !invrK ![_^-1 * _]mulrC !mulf_div -?rmorphM /=.
  by rewrite feval_frac //  rmorphM mulf_neq0.
by rewrite feval_pole // fpoleM // invf_div feval_frac ?mulf_neq0 ?invr_eq0.
Qed.

Lemma frootM x y : feval y != 0 -> froot (x * y) = froot x.
Proof.
move=> fy_neq0; rewrite /froot invfM fpoleM //.
by rewrite -div1r feval_divN0 ?feval1 ?div1r ?invr_eq0.
Qed.

Lemma feval_eq0 x : (feval x == 0) = [|| x == 0, froot x | fpole x].
Proof.
rewrite /froot; have [->|] /= := altP (x =P 0); first by rewrite feval0 eqxx.
case: fevalP => [|y1 y2 fy2]; rewrite ?eqxx ?(orbT,orbF) ?invf_div //.
rewrite ?frac_eq0 !mulf_eq0 negb_or invr_eq0 (negPf fy2) orbF.
by move => /andP [y10 y20]; rewrite fpole_frac.
Qed.

Lemma fevalV : {morph feval : x / x^-1}.
Proof.
move=> x; have [fx_eq0|fx_neq0] := eqVneq (feval x) 0.
  apply/eqP; rewrite fx_eq0 invr0 feval_eq0.
  by rewrite invr_eq0 frootV orbA orbAC -orbA -feval_eq0 fx_eq0.
by rewrite -div1r feval_divN0 // feval1 div1r.
Qed.

Lemma feval_N0div y z  : feval y != 0 -> feval (y / z) = (feval y) / (feval z).
Proof. by move=> ?;rewrite -invf_div -feval_divN0 // -fevalV invf_div. Qed.

Lemma fevalD : {in predC fpole &, {morph feval : x y / x + y}}.
Proof.
move=> x y; rewrite !inE.
have [[] // x1 x2 fx2 [] // y1 y2 fy2 _ _] := (fevalP x, fevalP y).
rewrite !addr_div ?unitfE ?rmorph_eq0 ?felem_eq0F -?rmorphM -?rmorphD //=.
by rewrite feval_frac // rmorphM mulf_neq0.
Qed.

Lemma fevalB : {in predC fpole &, {morph feval : x y / x - y}}.
Proof. by move=> x y /= ? ?; rewrite fevalD ?fevalN // inE fpoleN. Qed.

Lemma fevalM : {in predC fpole &, {morph feval : x y / x * y}}.
Proof.
move=> x y; rewrite !inE.
have [[] // x1 x2 fx2 [] // y1 y2 fy2 _ _] := (fevalP x, fevalP y).
by rewrite !mulf_div -!rmorphM /= feval_frac // rmorphM mulf_neq0.
Qed.

Lemma feval_div : {in predC fpole & predC froot, {morph feval : x y / x / y}}.
Proof. by move=> x y /= ? ?; rewrite fevalM ?fevalV // inE fpoleV. Qed.

End EvalFrac.

Notation "f .-pole" := (@fpole_of _ _ _ (Phantom (_ -> _) f))
  (at level 2, format "f .-pole") : ring_scope.
Notation "f .-root" := (@froot_of _ _ _ (Phantom (_ -> _) f))
  (at level 2, format "f .-root") : ring_scope.
Notation "f .-eval" := (@feval_of _ _ _ (Phantom (_ -> _) f))
  (at level 2, format "f .-eval") : ring_scope.

Section EvalFracInj.

Variable (R : idomainType) (K : fieldType) (f : {injmorphism R -> K}).

Lemma inj_fpole (x : {fraction R}) : f.-pole x = false.
Proof.
by apply/fpolePn; have [y] := fracE x; exists y; rewrite ?rmorph_eq0.
Qed.

Lemma injNfpole (x : {fraction R}) : ~~ f.-pole x.
Proof. by rewrite inj_fpole. Qed.
Hint Resolve injNfpole.

Lemma feval_rmorphism : rmorphism f.-eval.
Proof.
split; first by move=> x y; rewrite fevalD ?inE // -fevalN.
by split; [move=> x y; rewrite fevalM ?inE|rewrite feval1].
Qed.

Canonical feval_is_additive := Additive feval_rmorphism.
Canonical feval_is_rmorphism := AddRMorphism feval_rmorphism.

Lemma feval_inj : injective f.-eval.
Proof.
apply: raddf_inj => x /= /eqP; rewrite feval_eq0 /=.
by rewrite inj_fpole [f.-root _]inj_fpole ?orbF => /eqP.
Qed.

Canonical feval_is_injmorphism := InjMorphism feval_inj.

End EvalFracInj.

Section MapFrac.

Variable (R S : idomainType) (f : {injmorphism R -> S}).
Let tofrac_map := [injmorphism of tofrac \o f].
Definition map_frac_of (phf : phantom (R -> S) f) := tofrac_map.-eval.
Local Notation map_frac := (map_frac_of (Phantom (_ -> _) f)).

Canonical map_frac_is_additive := [additive of map_frac].
Canonical map_frac_is_rmorphism := [rmorphism of map_frac].
Canonical map_frac_is_injmorphism := [injmorphism of map_frac].

Lemma map_fracE (x : R) : map_frac (x%:F) = (f x)%:F.
Proof. by rewrite [LHS]feval_tofrac. Qed.

Lemma map_frac_frac (x y : R) : map_frac (x // y) = (f x) // (f y).
Proof. by rewrite fmorph_div /= !map_fracE. Qed.

Lemma map_frac_tofracV (x : R) : map_frac (x%:F^-1) = (f x)%:F^-1.
Proof. by rewrite !fmorphV /= map_fracE. Qed.

End MapFrac.

Notation map_frac f := (map_frac_of (Phantom (_ -> _) f)).
Local Notation "p ^^ f" := (map_frac f p)
   (f at next level, at level 30).
Local Notation "p ^^^ f" := (map_frac (map_poly f) p)
   (f at next level, at level 30).

Section EvalFracPoly.

Variable (K : fieldType) (a: K).

Implicit Types (f g : {fracpoly K}).
Implicit Types (u v p q : {poly K}).

Lemma tofrac_scale (c : K) (p : {poly K}) : (c *: p)%:F = (c%:FP) * (p %:F).
Proof. by rewrite -mul_polyC rmorphM. Qed.

Lemma fracpolyE x :  {y : {poly K} * {poly K}
  | x = y.1 // y.2 & (y.2 != 0) && (coprimep y.1 y.2)}.
Proof.
have [[u v] /= -> v_neq0] := fracE x.
pose u' := u %/ gcdp u v; pose v' := v %/ gcdp u v.
have v'_neq0 : v' != 0 by rewrite dvdp_div_eq0 // dvdp_gcdr.
suff -> : u // v = u' // v'.
  by exists (u',v'); rewrite // v'_neq0 coprimep_div_gcd // v_neq0 orbT.
apply/eqP; rewrite eq_divf ?rmorph_eq0 // -!rmorphM rmorph_eq; apply/eqP.
by rewrite divp_mulA ?dvdp_gcdr // divp_mulAC ?dvdp_gcdl.
Qed.

Lemma fracpoly_eval_regmorphism : regular_dec (horner_eval a).
Proof.
move=> x; have [[u v] /= -> /andP[v_neq0 cuv]] := fracpolyE x.
have [->|u_neq0] := eqVneq u 0.
  by left; exists (0, 1); rewrite /= ?mul0r ?rmorph1 ?oner_eq0.
have [fv_eq0|?] := boolP (horner_eval a v == 0); last by left; exists (u, v).
right=> u' v' /eq_divf_mul; rewrite frac_neq0 -?rmorphM //= => /(_ isT).
move=> /tofrac_inj /(congr1 (horner_eval a)) /eqP.
rewrite !rmorphM /= (eqP fv_eq0) mulr0 mulf_eq0.
rewrite [_ == _]negbTE /=; first by move/eqP.
by apply: coprimep_root fv_eq0; rewrite coprimep_sym.
Qed.

Canonical fracpoly_eval_is_regmorphism :=
  RegMorphism fracpoly_eval_regmorphism.

Notation fppole := ((horner_eval a).-pole).
Notation fproot := ((horner_eval a).-root).
Notation fpeval := ((horner_eval a).-eval).

Lemma coprimep_fpole u v : v != 0 -> coprimep u v ->
  (fppole (u // v)) = (v.[a] == 0).
Proof.
move=> vN0; have [u0|uN0 cuv] := eqVneq u 0.
+ rewrite u0 mul0r fpole0 coprime0p => eqp_v1.
  symmetry; apply/negbTE; have: v %= 1 by [].
  rewrite [v]size1_polyC; last first.
    by have/eqP -> : size v == 1%N => //; rewrite size_poly_eq1.
  by rewrite !hornerC polyC_eqp1.
+ have [va0|?] := altP eqP; last by rewrite fpole_fracF.
  rewrite fpole_frac //= /horner_eval ?va0 ?eqxx //.
  by move/eqP: va0; apply: coprimep_root; rewrite coprimep_sym.
Qed.

Lemma coprimep_froot u v : u != 0 -> v != 0 -> coprimep u v ->
  (fproot (u // v)) = (u.[a] == 0).
Proof. by rewrite froot_div coprimep_sym => u0 v0; exact: coprimep_fpole. Qed.

Lemma coprimep_feval u v : coprimep u v ->
  (fpeval (u // v)) = (u.[a] / v.[a]).
Proof.
have [->|u_neq0] := eqVneq u 0; first by rewrite horner0 !mul0r feval0.
have [->|v_neq0] := eqVneq v 0; first by rewrite horner0 !invr0 !mulr0 feval0.
move=> cuv; have [va0|?] := eqVneq v.[a] 0; last by rewrite feval_frac.
by rewrite feval_pole ?coprimep_fpole ?va0 ?invr0 ?mulr0.
Qed.

Lemma fpeval_tofrac u : fpeval u%:F = u.[a].
Proof. by rewrite -[_%:F]divr1 coprimep_feval ?coprimep1 ?hornerC ?divr1. Qed.

Lemma fppoleM f g : fppole f -> fppole g -> fppole (f * g).
Proof.
have [[f1 f2] /= -> /andP[f2_neq0 cf]] := fracpolyE f.
have [[g1 g2] /= -> /andP[g2_neq0 cg]] := fracpolyE g.
have [->|f1_neq0] := eqVneq f1 0; first by rewrite !mul0r fpole0.
have [->|g1_neq0] := eqVneq g1 0; first by rewrite !mul0r mulr0 fpole0.
rewrite !coprimep_fpole // mulf_div -!rmorphM /= => f2a_eq0 g2a_eq0.
rewrite fpole_frac ?rmorphM //= ?mulf_eq0 ?negb_or ?f2a_eq0 ?f2_neq0 //.
apply/andP; split; [move: f2a_eq0|move: g2a_eq0];
by apply: coprimep_root; rewrite coprimep_sym.
Qed.

Lemma fppoleMF (f g : {fracpoly K}) :
  ~~ fppole f -> ~~ fppole g -> fppole (f * g) = false.
Proof.
have [[f1 f2] /= -> /andP[f2_neq0 cf]] := fracpolyE f.
have [[g1 g2] /= -> /andP[g2_neq0 cg]] := fracpolyE g.
have [->|f1_neq0] := eqVneq f1 0; first by rewrite !mul0r fpole0.
have [->|g1_neq0] := eqVneq g1 0; first by rewrite !mul0r mulr0 fpole0.
rewrite !coprimep_fpole // mulf_div -!rmorphM /= => f2a_eq0 g2a_eq0.
by rewrite fpole_fracF //= rmorphM mulf_eq0 negb_or f2a_eq0.
Qed.

Lemma fppoleX f n : n > 0 -> fppole (f ^+ n) = fppole f.
Proof.
case: n => // n _; elim: n => [|n IHn] //=; rewrite exprS.
have [polef|Npolef] := boolP (fppole f).
  by rewrite fppoleM ?IHn.
by rewrite fppoleMF ?IHn.
Qed.

Lemma fpevalX n : n > 0 -> {morph fpeval : f / f ^+ n}.
Proof.
case: n => // n _; elim: n => [|n IHn] //= f.
have [polef|Npolef] := boolP (fppole f).
  by rewrite !feval_pole ?expr0n ?fppoleX //=.
by rewrite exprS [RHS]exprS fevalM ?inE ?fppoleX //= IHn.
Qed.

Lemma XV_eq0 : ('X^-1 == 0 :> {fracpoly K}) = false.
Proof. by rewrite invr_eq0 rmorph_eq0 polyX_eq0. Qed.

Lemma fppole_XV : (fppole 'X^-1) = (a == 0).
Proof. by rewrite fpoleV froot_tofrac ?polyX_eq0 //= /horner_eval hornerX. Qed.

Lemma fpevalC (c : K) : fpeval (c %:FP) = c.
Proof. by rewrite feval_tofrac [LHS]hornerC. Qed.

End EvalFracPoly.

Notation "a .-fppole" := ((horner_eval a).-pole)
  (at level 2, format "a .-fppole") : ring_scope.
Notation "a .-fproot" := ((horner_eval a).-root)
  (at level 2, format "a .-fproot") : ring_scope.
Notation "a .-fpeval" := ((horner_eval a).-eval)
  (at level 2, format "a .-fpeval") : ring_scope.
Notation "f .<[ a ]>" := (a.-fpeval f)
  (at level 2, left associativity, format "f .<[ a ]>")  : ring_scope.

Section MapPolyFrac.

Variable (K L : fieldType) (f : {injmorphism K -> L}).

Lemma map_fracpolyX : 'XF ^^^ f = 'XF.
Proof. by rewrite map_fracE /= map_polyX. Qed.

Lemma map_fracpolyC (c : K) : (c %:FP) ^^^ f = (f c) %:FP.
Proof. by rewrite map_fracE /= map_polyC. Qed.

Lemma map_fracpolyXV : 'X^-1 ^^^ f = 'X^-1.
Proof. by rewrite map_frac_tofracV /= map_polyX. Qed.

Lemma map_fracpolyXn n : 'X^+n ^^^ f = 'X^+n.
Proof. by rewrite rmorphX /= map_fracpolyX. Qed.

Lemma map_fracpolyXVn n : 'X^-n ^^^ f = 'X^-n.
Proof. by rewrite -!exprVn rmorphX fmorphV /= map_fracpolyX. Qed.

(* TODO: is it general enough? *)
Lemma to_fracpoly_map_f (p : {poly K}) :
  (p ^ f) ^:FP = (p ^:FP) ^ (map_frac (map_poly f)).
Proof.
by rewrite -!map_poly_comp; apply: eq_map_poly => x /=; rewrite map_fracpolyC.
Qed.

End MapPolyFrac.

Section FPEvalMap.

Variables (K1 K2 : fieldType) (f : {injmorphism K1 -> K2}) (a : K1).

Lemma fppole_map (g : {fracpoly K1}) :
  (f a).-fppole (g ^^^ f) = a.-fppole g.
Proof.
have [[p q] -> {g} /=  /andP [q_neq0 cpq]] := fracpolyE g.
have [->|p_neq0] := eqVneq p 0; first by rewrite mul0r !rmorph0 !fpole0.
rewrite fmorph_div /= !map_fracE !coprimep_fpole ?rmorph_eq0 ?coprimep_map //.
by rewrite horner_map rmorph_eq0.
Qed.

Lemma fpeval_map (g : {fracpoly K1}) : (g ^^^ f).<[f a]> = f g.<[a]>.
Proof.
have [[p q] -> {g} /=  /andP [q_neq0 cpq]] := fracpolyE g.
rewrite fmorph_div /= !map_fracE !coprimep_feval ?coprimep_map //.
by rewrite !horner_map fmorph_div.
Qed.

End FPEvalMap.

Section CompFrac.
Variable (K : fieldType).
Implicit Types (g h i : {fracpoly K}).
Implicit Types (p q r : {poly K}).

Definition comp_fracpoly g h := (g ^^^ tofracpoly).<[h]>.
Definition nocomp_fracpoly g h := h.-fppole (g ^^^ tofracpoly).

Lemma horner_map_polyC p q : (p ^ polyC).[q] = p \Po q.
Proof. by []. Qed.

Notation "g \FPo h" := (comp_fracpoly g h) : ring_scope.

Lemma comp_poly_frac p g : p%:F \FPo g = (p ^ tofracpoly).[g].
Proof. by rewrite /comp_fracpoly map_fracE /= feval_tofrac /=. Qed.

Lemma comp_poly_fracE p g : p%:F \FPo g = \sum_(i < size p) (p`_i)%:FP * g ^+ i.
Proof.
rewrite comp_poly_frac horner_coef size_map_poly /=.
by apply: eq_bigr => i _; rewrite coef_map.
Qed.

Lemma comp_fracpolyC (c : K) g : (c %:FP) \FPo g = c %:FP.
Proof. by rewrite comp_poly_frac map_polyC hornerC. Qed.

Lemma comp_fracpoly0 g : 0 \FPo g = 0.
Proof. by rewrite comp_fracpolyC. Qed.

Lemma comp_fracpoly_dflt g h : nocomp_fracpoly g h -> g \FPo h = 0.
Proof. by move=> pole_gh; rewrite [LHS]feval_pole. Qed.

Lemma comp_fracpolyD g h i :
  ~~ nocomp_fracpoly g i -> ~~ nocomp_fracpoly h i ->
  (g + h) \FPo i = (g \FPo i) + (h \FPo i).
Proof. by move=> ??; rewrite /comp_fracpoly !rmorphD /= fevalD. Qed.

Lemma comp_fracpolyN g h :  (- g) \FPo h = - (g \FPo h).
Proof. by rewrite /comp_fracpoly !rmorphN /= fevalN. Qed.

Lemma comp_fracpolyM g h i :
  ~~ nocomp_fracpoly g i -> ~~ nocomp_fracpoly h i ->
  (g * h) \FPo i = (g \FPo i) * (h \FPo i).
Proof. by move=> ??; rewrite /comp_fracpoly !rmorphM /= fevalM. Qed.

Lemma comp_fracpolyXr g : g \FPo ('X %:F) = g.
Proof.
rewrite /comp_fracpoly; have [[p q] -> {g} /= /andP [p2_neq0 cp]] := fracpolyE g.
rewrite !fmorph_div /= !map_fracE coprimep_feval ?coprimep_map //=.
rewrite /tofracpoly !map_poly_comp !horner_map /= !horner_map_polyC.
by rewrite !comp_polyXr.
Qed.

Lemma comp_fracpoly_exp (m : nat) g h : (g ^+ m) \FPo h = (g \FPo h) ^+ m.
Proof.
case: m => [|m]; first by rewrite !expr0 comp_fracpolyC.
by rewrite /comp_fracpoly !rmorphX /= fpevalX.
Qed.

Lemma comp_fracpolyV g h : (g ^-1) \FPo h = (g \FPo h) ^-1.
Proof. by rewrite /comp_fracpoly !fmorphV /= fevalV. Qed.

Lemma comp_fracpoly_div g h i : h \FPo i != 0 ->
  (g / h) \FPo i = (g \FPo i) / (h \FPo i).
Proof. by move=> ?; rewrite /comp_fracpoly !fmorph_div /= feval_divN0. Qed.

Lemma pole_comp_fracpolyPn g h :
  reflect (exists2 c : K, c.-fppole g & h = c%:FP) (nocomp_fracpoly g h).
Proof.
rewrite /nocomp_fracpoly; apply: (iffP idP); last first.
  by move=> [c ? ->]; rewrite fppole_map.
have [[p q] -> {g} /= /andP [q_neq0 cp_pq]] := fracpolyE g.
have [->|p_neq0] := eqVneq p 0; first by rewrite mul0r !rmorph0 fpole0.
rewrite fmorph_div /= !map_fracE coprimep_fpole ?rmorph_eq0 ?coprimep_map //=.
have [[u v] -> {h} /= /andP [v_neq0 cp_uv]] := fracpolyE h => hq.
have H : \sum_(i < size q) q`_i *: u ^+ i * v ^+ ((size q).-1 - i) = 0.
  move: hq.
  rewrite -{1}[q]coefK poly_def rmorph_sum horner_sum /=.
  move/eqP/(congr1 ( *%R^~ ((v ^+ (size q).-1)%:F))); rewrite mul0r mulr_suml.
  rewrite (eq_bigr (fun j => (q`_(nat_of_ord j)
                   *: u ^+j * v ^+((size q).-1 - j))%:F)) => [|j _] ; last first.
    rewrite linearZ hornerZ /= map_polyXn hornerXn expr_div_n.
    rewrite -scalerAl tofrac_scale -mulrA mulrAC rmorphM !rmorphX -mulrA.
    rewrite exprB // ?unitfE ?raddf_eq0 // ; last exact: tofrac_inj.
    by rewrite -ltnS prednK ?ltn_ord // size_poly_gt0.
  move/eqP. rewrite -rmorph_sum raddf_eq0; last exact: tofrac_inj.
  by move/eqP.
have dvdv1 : v %| 1.
  move/(congr1 (fun x => x %% v)) : H.
  rewrite mod0p modp_sumn.
  rewrite -(big_mkord predT (fun j => (q`_j *: u ^+ j * v ^+ (_ - j) %% v))) /=.
  rewrite big_nat_rev big_ltn ?size_poly_gt0 // big_nat.
  rewrite (eq_bigr (fun j => 0)) => [|i /andP [hi1 hi2]]; last first.
    rewrite -modp_mul [X in _ * X]modp_eq0 ?dvdp_exp ?subn_gt0 //; last first.
      rewrite add0n subnS prednK ?subn_gt0 ?leq_subr // leq_subLR -ltnS -addnS.
      by rewrite prednK ?size_poly_gt0 // -[X in X < _]add0n ltn_add2r.
    by rewrite mulr0 mod0p.
  rewrite /= big1 // addr0 !add0n subn1 subnn expr0 mulr1; move/modp_eq0P.
  rewrite dvdp_scaler; last by rewrite -lead_coefE lead_coef_eq0.
  have [->|sq_neq0] := eqVneq (size q).-1 O.
    by rewrite expr0.
  move=> dvdp_vu.
  rewrite -(@coprimep_pexpl _ (size q).-1) in cp_uv; last by rewrite lt0n.
  move/coprimepP/(_ v): cp_uv => cp_uv.
  wlog: / v %= 1 => [H2|]; last by move/andP => [dvdp1 _].
  by rewrite H2 // cp_uv.
have [/andP [valp_gt0 /eqP ->]| /negbTE HF] := boolP ((0 < valp q) && (u == 0)).
  exists 0; rewrite ?mul0r //.
  rewrite coprimep_fpole // horner_coef0.
  move: valp_gt0; rewrite lt0n.
  apply: contraR => *.
  by rewrite valp_eq0.
have dvdu1 : u %| 1.
  move: H.
  rewrite -(big_mkord predT (fun j => q`_j *: u ^+ j * v ^+ (_ - j))).
  rewrite (big_cat_nat _ predT (fun j => q`_j *:
              u ^+ j * v ^+ ((size q).-1 - j)) (leq0n (valp q))) /= ; last first.
    by rewrite ltnW // valp_small.
  rewrite big_nat.
  rewrite (eq_bigr (fun=> 0)) ?big1_eq ?add0r => [|j /andP [_ hi]]; last first.
    by rewrite valp_coef_eq0 // scale0r mul0r.
  rewrite big_nat.
  rewrite (eq_bigr (fun j => (u ^+ (valp q)) * (q`_j *: u ^+ (j - (valp q)) *
                      v ^+ ((size q).-1 - j)))) => [|j /andP [hi _]]; last first.
    rewrite mulrA; congr (_ * _); rewrite -scalerCA -scalerAl -exprD subnKC //.
  rewrite -mulr_sumr; move/eqP; rewrite mulf_eq0.
  rewrite expf_eq0 HF orFb -big_nat big_ltn ?valp_small // subnn expr0 big_nat.
  rewrite (eq_bigr (fun j => u * (q`_j *: u ^+ (j - valp q).-1 *
                     v ^+ ((size q).-1 - j)) )) => [|j /andP [hj _]]; last first.
    rewrite mulrA; congr (_ * _).
    by rewrite -scalerCA -scalerAl -exprS prednK // subn_gt0.
  rewrite -mulr_sumr [X in _ + X]mulrC; move/eqP.
  move/(congr1 (fun x => x %% u)); rewrite mod0p modp_add modp_mull addr0.
  have [->|neq] := eqVneq (valp q) ((size q).-1).
    rewrite subnn expr0 mulr1 modp_scalel.
    move/eqP; rewrite scaler_eq0 -lead_coefE lead_coef_eq0.
    by move/negbTE : q_neq0 -> ; move/eqP/modp_eq0P.
  move/modp_eq0P; rewrite Gauss_dvdpl ?coprimep_pexpr ?subn_gt0 ?valp_small //.
    by rewrite dvdp_scaler ?coef_valp_neq0.
  by rewrite ltn_neqAle neq andTb -ltnS prednK ?valp_small // size_poly_gt0.
rewrite !dvdp1 in dvdu1 dvdv1.
move: hq.
move/size_poly1P : dvdu1 => [c c_neq0 ->].
move/size_poly1P : dvdv1 => [d d_neq0 ->].
move=> hq.
exists (c / d); last by rewrite fmorph_div.
rewrite coprimep_fpole //.
move: hq ; rewrite -rmorph_div /=; last first.
  by rewrite poly_unitE coefC size_polyC d_neq0 unitfE.
rewrite -rmorph_div ?unitfE // horner_map raddf_eq0 //.
exact: (inj_comp (@tofrac_inj _) (@polyC_inj _)).
Qed.

Lemma cst_nocomp_fracpoly g (c : K) : nocomp_fracpoly g (c%:FP) = c.-fppole g.
Proof. by rewrite /nocomp_fracpoly fppole_map. Qed.

Lemma Ncst_nocomp_fracpoly r g : size r > 1 -> ~~ nocomp_fracpoly g r%:F.
Proof.
rewrite /nocomp_fracpoly => r_gt1.
have [[p q] -> {g} /= /andP [p2_neq0 cp]] := fracpolyE g.
have [->|p_neq0] := eqVneq p 0; first by rewrite mul0r !rmorph0 fpole0.
rewrite !fmorph_div /= !map_fracE coprimep_fpole ?rmorph_eq0 ?coprimep_map //=.
rewrite /tofracpoly map_poly_comp /= horner_map /= rmorph_eq0.
rewrite horner_map_polyC -lead_coef_eq0 lead_coef_comp //.
rewrite mulf_neq0 ?expf_eq0 ?lead_coef_eq0 ?negb_and //.
by rewrite -size_poly_eq0 gtn_eqF ?orbT // (leq_trans _ r_gt1).
Qed.

Lemma comp_fracpolyX g : ('X %:F) \FPo g = g.
Proof. by rewrite comp_poly_frac map_polyX hornerX. Qed.

Lemma comp_fracpolyXn (m : nat) g : 'X^+m \FPo g = g ^+ m.
Proof. by rewrite comp_fracpoly_exp /= comp_fracpolyX. Qed.

Lemma comp_fracpoly_XV g : 'X^-1 \FPo g = g ^-1.
Proof. by rewrite comp_fracpolyV comp_fracpolyX. Qed.

Lemma comp_fracpoly_XV_XV : 'X^-1 \FPo 'X^-1 = 'XF.
Proof. by rewrite comp_fracpoly_XV invrK. Qed.

Lemma comp_poly_XV p : p%:F \FPo 'X^-1 = \sum_(i < size p) ((p`_i)%:FP) * 'X^-i.
Proof. by rewrite comp_poly_fracE; apply: eq_bigr => i _; rewrite exprVn. Qed.

Lemma nocomp_polyF p g : nocomp_fracpoly p%:F g = false.
Proof. by rewrite /nocomp_fracpoly map_fracE /= fpole_tofrac. Qed.

Lemma comp_frac_frac p q g : coprimep p q ->
  (p // q \FPo g) = (p%:F \FPo g) / (q%:F \FPo g).
Proof.
move=> cpq; rewrite /comp_fracpoly !fmorph_div /= !map_fracE /=.
by rewrite coprimep_feval ?coprimep_map // !fpeval_tofrac.
Qed.

End CompFrac.

Notation "g \FPo h" := (comp_fracpoly g h) : ring_scope.

Section MoreCompFrac.

Variable  (K L : fieldType) (iota : {injmorphism K -> L}).

Lemma fracpoly_iota_comp_fracpoly (p q : {fracpoly K}) :
  (p \FPo q) ^^^ iota = (p ^^^ iota) \FPo (q ^^^ iota).
Proof.
have [ [ p1 p2 -> /= /andP [p2_neq0 coprime_p1_p2 ] ] ] := fracpolyE p.
rewrite fmorph_div /= !map_fracE !comp_frac_frac // ?fmorph_div ?coprimep_map //.
by rewrite !comp_poly_frac !to_fracpoly_map_f !horner_map.
Qed.

End MoreCompFrac.


(* Considered preliminaries *)
Set Implicit Arguments.
Require Import List Arith Lia Morphisms.
Import ListNotations.
From Undecidability.HOU Require Export std.std.
From Undecidability.HOU Require Import calculus.terms.

Fixpoint sapp {X} (A: list X) (sigma: fin -> X): fin -> X :=
  match A with
  | nil => sigma
  | a :: A => a .: sapp A sigma
  end.

Notation "A .+ sigma" := (sapp A sigma) (at level 67, right associativity).

Lemma sapp_app X (A B: list X) sigma:
  (A ++ B) .+ sigma = A .+ B .+ sigma.
Proof.
  induction A; cbn; eauto.
  f_equal; eauto.
Qed.

Lemma nth_error_sapp X L (x: X) n sigma:
  nth_error L n = Some x -> (L .+ sigma) n = x.
Proof.
  induction L in n |-*; cbn.
  + destruct n; cbn in *;  discriminate.
  + firstorder. destruct n; cbn in *.
    congruence. eauto.
Qed.

Lemma sapp_lt_in X x (A: list X) sigma:
  x < length A -> (A .+ sigma) x ∈ A.
Proof.
  intros H. eapply nth_error_In with (n := x).
  eapply nth_error_lt_Some in H as [a].
  erewrite nth_error_sapp; eauto.
Qed.

Lemma sapp_ge_in X x (A: list X) sigma:
  length A <= x -> sapp A sigma x = sigma (x - length A).
Proof.
  induction A in x |-*.
  - cbn. intros _. destruct x; reflexivity.
  - intros H. destruct x. inv H.
    cbn; rewrite <-IHA; eauto using le_S_n.
Qed.

Lemma ren_plus_base (X: Const): @ren_exp X shift = ren_exp (plus 1).
Proof. reflexivity. Qed.

Lemma ren_comp X delta delta' s:
  @ren_exp X delta (ren_exp delta' s) = ren_exp (delta' >> delta) s.
Proof. asimpl. reflexivity. Qed.

Lemma ren_plus_combine X n m s:
  @ren_exp X (plus n) (ren_exp (plus m) s) = ren_exp (plus (n + m)) s.
Proof.
  rewrite ren_comp. f_equal.
  induction n; cbn; fext; intros; cbn.
  + reflexivity.
  + rewrite <-IHn. reflexivity.
Qed.

Lemma it_up_ren_spec n delta x:
  it n up_ren delta x = if dec2 lt x n then x else n + delta (x - n).
Proof.
  induction n in x, delta |-*; cbn.
  - destruct dec2; intuition idtac; rewrite ?Nat.sub_0_r; lia.
  - destruct x; cbn; destruct dec2; intuition idtac. lia.
    all: unfold funcomp; erewrite IHn.
    all: destruct dec2; intuition idtac; lia.
Qed.

Lemma it_up_ren_lt n delta x:
  x < n -> it n up_ren delta x = x.
Proof.
  intros; rewrite it_up_ren_spec; destruct dec2; intuition easy.
Qed.

Lemma it_up_ren_ge n delta x:
  x >= n -> it n up_ren delta x = n + delta (x - n).
Proof.
  intros; rewrite it_up_ren_spec; destruct dec2; intuition idtac; lia.
Qed.

Lemma it_up_spec X n (sigma: fin -> @exp X) x:
  it n up_exp_exp sigma x =
  if dec2 lt x n then var_exp x else ren_exp (plus n) (sigma (x - n)).
Proof.
  induction n in x, sigma |-*; cbn.
  - asimpl; destruct dec2; [lia|]; now destruct x.
  - destruct x; cbn; destruct dec2; (intuition idtac); [lia| |].
    all: unfold funcomp; erewrite IHn.
    all: destruct dec2; intuition idtac; try lia; now asimpl.
Qed.

Lemma it_up_lt X n (sigma: fin -> @exp X) x:
  x < n -> it n up_exp_exp sigma x = var_exp x.
Proof.
  intros; rewrite it_up_spec; destruct dec2; intuition easy.
Qed.

Lemma it_up_ge X n (sigma: fin -> @exp X) x:
  x >= n -> it n up_exp_exp sigma x = ren_exp (plus n) (sigma (x - n)).
Proof.
  intros; rewrite it_up_spec; destruct dec2; intuition idtac; lia.
Qed.

Lemma it_up_var_sapp X A n delta e:
  (forall x, delta x >= x) -> n = length A  ->
  subst_exp (A .+ var_exp) (ren_exp (it n up_ren delta) e) = subst_exp (A .+ delta >> @var_exp X) e.
Proof.
  intros; subst. asimpl. eapply ext_exp.
  intros; unfold funcomp.
  assert (x < length A \/ x >= length A) as [] by lia.
  + rewrite it_up_ren_lt; eauto.
    eapply nth_error_lt_Some in H0 as [a].
    erewrite !nth_error_sapp; eauto.
  + rewrite it_up_ren_ge; simplify; eauto.
    erewrite !sapp_ge_in; simplify; eauto. lia.
Qed.

Lemma select_variables_subst X S I sigma:
    I ⊆ nats (length S) -> map (subst_exp (S .+ sigma))  (map (@var_exp X) I) = select I S.
Proof.
  intros. rewrite map_map; cbn.  induction I; cbn; eauto.
  destruct (nth_error S a) eqn: H1.
  + rewrite IHI; firstorder.
    f_equal. now eapply nth_error_sapp.
  + exfalso. apply nth_error_None in H1.
    specialize (H a).  mp H; [now left|].
    eapply nats_lt in H. lia.
Qed.

Lemma max_le_left n m:  n <= max n m.
Proof. eauto using Nat.max_lub_l. Qed.

Lemma max_le_right n m: m <= max n m.
Proof. eauto using Nat.max_lub_r. Qed.

#[export] Hint Resolve max_le_left max_le_right : core.

(* finite maps *)
Definition dom X (A: list X) := nats (length A).

Lemma dom_length X (A: list X) : length (dom A) = length A.
Proof. unfold dom; now simplify. Qed.

Lemma dom_map X Y (A: list X) (f: X -> Y): dom (map f A) = dom A.
Proof. unfold dom; now simplify. Qed.

#[export] Hint Rewrite dom_length dom_map: simplify.

Lemma dom_in X x (A: list X):
  x ∈ dom A -> exists y, nth A x = Some y.
Proof.
  now intros ? % nats_lt % nth_error_lt_Some.
Qed.

Lemma dom_nth X x A (y: X):
  nth A x = Some y -> x ∈ dom A.
Proof.
  now intros ? % nth_error_Some_lt % lt_nats.
Qed.

Lemma dom_lt_iff X x (A: list X): x ∈ dom A <-> x < length A.
Proof. split; eauto using nats_lt, lt_nats. Qed.

#[export] Hint Resolve <-dom_lt_iff : core.

Ltac domin H :=
  match type of H with
  | nth _ _ = _ => eapply dom_nth in H as ?
  | _ ∈ dom _ => eapply dom_in in H as [y H]; rewrite ?H
  end.

#[export] Hint Resolve nth_error_In : core.
#[export] Hint Resolve Nat.le_add_l Nat.le_add_r : core.
#[export] Hint Resolve Nat.max_lub : core.
#[export] Hint Resolve Nat.le_succ_diag_r Nat.lt_le_incl : core.

#[export] Hint Rewrite Nat.max_lub_iff Nat.max_0_r Nat.max_0_l: simplify.
#[export] Hint Rewrite Nat.mul_0_r Nat.mul_succ_r Nat.mul_0_l Nat.mul_succ_l: simplify.
#[export] Hint Rewrite Nat.add_succ_r : simplify.

Arguments exp : clear implicits.

Coercion app : exp >-> Funclass.
Notation "'lambda' s" := (lam s) (at level 65, right associativity).

Arguments var_exp {_} _.
Notation var := var_exp.

Notation "A → B" := (arr A B) (at level 65, right associativity).

Coercion typevar : nat >-> type.
Definition alpha : type := 0.

Notation "gamma • s" := (subst_exp gamma s) (at level 69, right associativity).
Notation ren := ren_exp.
Notation up := up_exp_exp.


Require Export P02.

Lemma SearchTree_neglects_color:
  forall c c' t1 k v t2
    (HST: SearchTree (T c t1 k v t2)),
    SearchTree (T c' t1 k v t2).
Proof.
  intros.
  inv HST. inv H. econstructor. econstructor; eassumption.
Qed.

(* You can use SearchTree'_le, expand_range_SearchTree'. *)
Lemma insert_SearchTree: forall x vx s,
    SearchTree s -> SearchTree (insert x vx s).
Proof.
  intros.
  inv H.
  unfold insert. unfold makeBlack.
  destruct (ins x vx s) eqn: Hins.
  { apply empty_tree_SearchTree. }
  { eapply expand_range_SearchTree'
      with (lo' := Z.min (int2Z x) lo) (hi' := Z.max ((int2Z x)+1) hi) in H0; try nia.
    apply ins_SearchTree with (x := x) (vx := vx) in H0; try nia.
    rewrite Hins in H0. eapply SearchTree_neglects_color. econstructor. eassumption.
  }
Qed.


(* Trabajo Práctico 3 *)
(* Gabina Luz Bianchi *)

Section Ejercicio3. (* Necesito la definición de o para el ejrcicio 4 *)
Variable A B C: Set.

Definition apply := fun (A B : Set) (f: A->B) => fun a:A => (f a).
Definition o := fun (A B C : Set) (f: A->B) => fun g: B->C => fun a:A => ( g (f a)).
Definition twice := fun (A : Set) (f: A->A) => fun a:A => (f (f a)).

End Ejercicio3.

Section Ejercicio4.
Variable A: Set.

Definition id := fun (A : Set) (x : A) => x.

(* Prueba 1 *)
Theorem e41 : forall x:A, (o A A A (id A) (id A) x) = (id A x).
Proof.
intros.
compute.
reflexivity.
Save.

(* Prueba 2 *)
Theorem e42 : forall x:A, (o A A A (id A) (id A) x) = (id A x).
Proof.
intros.
cbv delta beta.
reflexivity.
Save.

(* Prueba 3 *)
Theorem e43 : forall x:A, (o A A A (id A) (id A) x) = (id A x).
Proof.
intros.
cbv delta.
simpl.
reflexivity.
Save.

End Ejercicio4.

Section Ejercicio5.

(* 5.1 *)
Definition opI (A : Set) (x : A) := x.

Definition opK (A B: Set) (x : A) (y : B) := x.

Definition opS (A B C : Set) (f : A -> B -> C) (g: A -> B)  (x : A) := ((f x) (g x)).

Check opI.
Check opK.
Check opS.

(* 5.2 *)
(* Para formalizar el siguiente lema, determine los tipos ?1 ... ?8 adecuados *)
Lemma e52 : forall (A B : Set), opS A (B -> A) A (opK A (B -> A)) (opK A B) = (opI A).
Proof.
intros.
compute.
reflexivity.
Save.

End Ejercicio5.

Section Ejercicio10.

Parameter Array : Set -> nat -> Set.
Parameter emptyA : forall X : Set, Array X 0.
Parameter addA : forall (X : Set) (n : nat), X -> Array X n -> Array X (S n).

Parameter Matrix : Set -> nat -> Set.
Parameter emptyM : forall X:Set, Matrix X 0.
Parameter addM : forall (X:Set) (n:nat), Matrix X n -> Array X (n + 1) -> Matrix X (n+1).

Definition A1 := (addA nat 0 1 (emptyA nat)).
Check A1.
Definition M1 := addM nat 0 (emptyM nat) A1. (* matriz de una columna *)
Check M1.
Definition A2 := (addA nat 1 2 ((addA nat 0 2 (emptyA nat)))).
Check A2.
Definition M2 := addM nat 1 M1 A2. (* matriz de dos columnas *)
Check M2.
Definition A3 := addA nat 2 3 (addA nat 1 3 ((addA nat 0 3 (emptyA nat)))).
Check A3.
Definition M3 := addM nat 2 M2 A3. (* matriz de tres columnas *)
Check M3.

End Ejercicio10.

Section Ejercicio11.

Parameter ABNat : forall n : nat, Set.
Parameter emptyAB : ABNat 0.
Parameter addAB : forall n : nat, ABNat n -> ABNat n -> nat -> ABNat (n+1).

Definition BT1 := addAB 0 emptyAB emptyAB 7. (*Árbol binario de altura 1 cuya raíz es 7*)
Check BT1.
Definition BT2 := addAB 1 BT1 BT1 3.
Check BT2.

Parameter ABtype : forall (X: Set) (n : nat), Set.
Parameter emptyABtype : forall X: Set, ABtype X 0.
Parameter addABtype : forall (X: Set) (n : nat), ABtype X n -> ABtype X n -> X -> ABtype X (n+1).
Check addABtype.

End Ejercicio11.

Section Ejercicio15.

Variable U : Set.
Variable e : U.
Variable A B : U -> Prop.
Variable P : Prop.
Variable R : U -> U -> Prop.

Lemma Ej315_1 : (forall x : U, A x -> B x) -> (forall x : U, A x) ->
forall x : U, B x.
Proof.
  intros.
   exact (H x (H0 x)).
Save.

Lemma Ej315_2 : forall x : U, A x -> ~ (forall x : U, ~ A x).
Proof.
  unfold not.
  intros.
  exact (H0 x H).
Save.

Lemma Ej315_3 : (forall x : U, P -> A x) -> P -> forall x : U, A x.
Proof.
    exact (fun (H : forall x : U, P -> A x) (H0 : P) (x : U) => (H x H0)).
Save.

Lemma Ej315_4 : (forall x y : U, R x y) -> forall x : U, R x x.
Proof.
     exact (fun (H :forall x y : U, R x y) (x : U) => (H x x)).
Save.

Lemma Ej315_5 : (forall x y: U, R x y -> R y x) ->
                 forall z : U, R e z -> R z e.
Proof.
     exact (fun (H : forall x y:U, R x y -> R y x) (z : U) => (H e z)).
Save.

End Ejercicio15.


Set Implicit Arguments.
Unset Strict Implicit.

(* Suggested by Pierre Casteran (bug #169) *)
(* Argument 3 is needed to typecheck and should be printed *)
Definition compose (A B C : Set) (f : A -> B) (g : B -> C) (x : A) := g (f x).
Check (compose (C:=nat) S).

(* Better to explicitly display the arguments inferable from a
   position that could disappear after reduction *)
Inductive ex (A : Set) (P : A -> Prop) : Prop :=
    ex_intro : forall x : A, P x -> ex P.
Check (ex_intro (P:=fun _ => True) (x:=0) I).

(* Test for V8 printing of implicit by names *)
Definition d1 y x (h : x = y :>nat) := h.
Definition d2 x := d1 (y:=x).

Print d2.

(* Check maximal insertion of implicit *)

Require Import List.

Open Scope list_scope.

Set Implicit Arguments.
Set Maximal Implicit Insertion.

Definition id (A:Type) (x:A) := x.

Check map id (1::nil).

Definition id' (A:Type) (x:A) := x.

Implicit Arguments id' [[A]].

Check map id' (1::nil).


(* TODO(rei): remove this file? *)
From mathcomp Require Import ssreflect eqtype ssrbool ssrnat fintype seq ssrfun.
From mathcomp Require Import bigop (*groups*) choice.
From mathcomp Require Export ssralg.

Set   Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(*Import GroupScope .*)
Import GRing.Theory .

Local Open Scope ring_scope .

Structure orderb (M : Type) (R : M -> M -> bool) : Type := Orderb {
  reflb    : reflexive R;
  antisymb : antisymmetric R;
  transb   : transitive R
} .

Structure sorderb (M : Type) (R : M -> M -> bool) : Type := SOrderb {
  irreflsb : irreflexive R;
  transsb  : transitive R
} .

Reserved Notation "x <<= y" (at level 70, no associativity) .
Reserved Notation "x <<! y" (at level 70, no associativity) .

Section Compatible .
  Variable R : ringType .

(* assia : I don't like the "compatible" name, turned temp. to lcompat, added rcompat*)
  Definition lcompatible (r : R -> R -> bool) :=
    forall (x y₁ y₂ : R), r 0 x -> r y₁ y₂ -> r (x * y₁) (x * y₂) .

  Definition rcompatible (r : R -> R -> bool) :=
    forall (x y₁ y₂ : R), r 0 x -> r y₁ y₂ -> r (y₁* x) (y₂ * x) .

End Compatible .

(* -------------------------------------------------------------------- *)
Module GOrdered .
  (* ------------------------------------------------------------------ *)
  Module OComRing.

    Record mixin_of (G : GRing.Ring.type) : Type := Mixin {
      leb : G -> G -> bool;
      ltb : G -> G -> bool;
      _   : sorderb  ltb;
      _   : forall x y, leb x y -> forall z, leb (x+z) (y+z);
      _   : forall x y, leb x y = (ltb x y) || (x == y);
      _   : forall x y, (leb x y) || (leb y x);
      _   : lcompatible ltb
    } .

    Record class_of (R : Type) : Type := Class {
      base :> GRing.ComRing.class_of R;
      mixin  :> mixin_of (GRing.Ring.Pack base R)
    } .

    Structure type : Type := Pack {sort :> Type; _ : class_of sort; _ : Type}.

    Definition class cT := let: Pack _ c _ := cT return class_of cT in c.
    Definition unpack K (k : forall T (c : class_of T), K T c) cT :=
      let: Pack T c _ := cT return K _ (class cT) in k _ c.
    Definition repack cT : _ -> Type -> type :=
      let k T c p := p c in unpack k cT.

    Definition pack := let k T c m :=
      Pack (@Class T c m) T in GRing.ComRing.unpack k.

    Definition eqType          cT := Equality.Pack             (class cT) cT.
    Definition choiceType      cT := Choice.Pack               (class cT) cT.
    Definition zmodType        cT := GRing.Zmodule.Pack        (class cT) cT.
    Definition ringType        cT := GRing.Ring.Pack           (class cT) cT.
    Coercion comringType cT := GRing.ComRing.Pack (class cT) cT.

    Definition EtaMixin R leb ltb ltr_sorderb leb_addr leb_ltb_eq leb_total ltb_lcompatible :=
      let _ := @Mixin R leb ltb ltr_sorderb leb_addr leb_ltb_eq leb_total ltb_lcompatible in
        @Mixin (GRing.Ring.Pack (GRing.Ring.class R) R) leb ltb ltr_sorderb leb_addr leb_ltb_eq leb_total ltb_lcompatible.

  End OComRing .

  Canonical Structure OComRing.eqType.
  Canonical Structure OComRing.choiceType.
  Canonical Structure OComRing.zmodType.
  Canonical Structure OComRing.ringType.
  Canonical Structure OComRing.comringType.

  Bind Scope comring_scope with OComRing.sort .

  Definition ltbDef (R : OComRing.type) : R -> R -> bool := OComRing.ltb (OComRing.class R).
  Notation ltb := (@ltbDef _).

  Definition lebDef (R : OComRing.type) : R -> R -> bool := OComRing.leb (OComRing.class R).
  Notation leb := (@lebDef _).

(*  Definition leb R := OComRing.leb (OComRing.class R).*)
(*  Definition ltb R := OComRing.ltb (OComRing.class R).*)

  Local Notation "x <<= y" := (leb x y) .
  Local Notation "x <<! y" := (ltb x y) .

  Definition absrDef (R : OComRing.type) (x : R) :=
    if (ltb x 0) then -x else x .
  Notation absr := (@absrDef _).

  Definition signDef (R : OComRing.type) (x : R) : R :=
  if (0 <<! x) then 1 else (if (x <<! 0) then (-1) else 0) .

  Notation sign := (@signDef _).

(*Definition sign R x :=
  if (@ltb R 0 x) then 1 else (if (@ltb R x 0) then (-1) else (0 : R)) .
*)

  (* -------------------------------------------------------------------- *)
  Section OComringTheory .
    Variable G : OComRing.type .
    Implicit Types x y z : G .

(*
    Notation Local "x <<= y" := (@leb G x y) .
    Notation Local "x <<! y" := (@ltb G x y) .
*)
    (* ------------------------------------------------------------------ *)
    Lemma ltr_sorderb : sorderb (@ltbDef G) .
    Proof . by case G => [T [? []]] . Qed .

    Lemma ltr_irrefl : irreflexive (@ltbDef G).
    Proof . by case ltr_sorderb . Qed .

    Lemma ltr_trans : transitive (@ltbDef G) .
    Proof . by case ltr_sorderb . Qed .

    Lemma ltr_lcompat : lcompatible (@ltbDef G) .
    Proof . by case G => [T [? []]] . Qed .

    Lemma ltr_rcompat : rcompatible (@ltbDef G).
    Proof. by move=> x y z; rewrite mulrC [z * _]mulrC; exact: ltr_lcompat. Qed.

    (* ------------------------------------------------------------------ *)

    Lemma ler_ltreq : forall x y, (x <<= y) = (x <<! y) || (x == y) .
      Proof. by case: G => [T [? []]]. Qed.
(*    Proof .
      move=> x y; rewrite ltr_lerne /negb; case D: (x == y) .
      + by rewrite (eqP D) ler_refl .
      + by rewrite orbF andbT .
    Qed .
*)

    Lemma ler_refl : reflexive (@lebDef G) .
    Proof. by move=> x; rewrite ler_ltreq eqxx orbT. Qed.

    Lemma ler_antisym : forall (x y : G), x <<= y -> y <<= x -> x = y .
    Proof .
      case: ltr_sorderb => h3 h4 x y; rewrite !ler_ltreq.
      case/orP=> hxy; last by move/eqP: hxy.
      case/orP=> hyx; last by move/eqP: hyx.
      by move: (h4 _ _ _ hxy hyx); rewrite (h3 x).
    Qed .

    Lemma ler_trans : transitive (@lebDef G) .
    Proof .
      case: ltr_sorderb=> h1 h2.
      move=> x y z; rewrite !ler_ltreq; case/orP; last first.
        move/eqP->; case/orP; by [move-> | move/eqP->; rewrite eqxx orbT].
      move=> hyx; case/orP; last by move/eqP<-; rewrite hyx.
      by move=> hxz; rewrite (h2 _ _ _ hyx).
    Qed.

    Lemma ler_order : orderb (@lebDef G) .
    Proof .
      constructor.
      - exact: ler_refl.
      - move=> x y; case/andP; exact: ler_antisym.
      - exact: ler_trans.
    Qed.

    Lemma ler_total : forall x y, (x <<= y) || (y <<= x) .
    Proof . by case G => [T [? []]] . Qed .

    Lemma ler_lcompat : lcompatible (@lebDef G) .
    Proof .
      move=> x y z; rewrite !ler_ltreq => px.
      case/orP; last by move/eqP->; rewrite eqxx orbT.
      move=> hyz; case/orP: px => hx; first by rewrite ltr_lcompat.
      by rewrite -(eqP hx) !mul0r eqxx orbT.
    Qed.

    Lemma ler_rcompat : rcompatible (@lebDef G).
    Proof. by move=> x y z; rewrite mulrC [z * _]mulrC; exact: ler_lcompat. Qed.

    Lemma eq_ler : forall x y, (x == y) = (x <<= y) && (y <<= x) .
    Proof .
      move=> x y; apply/idP/idP .
      + by move/eqP => ->; rewrite ler_refl .
      + by case/andP=> Hxy Hyx; rewrite (ler_antisym Hxy Hyx) .
    Qed .

    (* ------------------------------------------------------------------ *)

    Lemma ltr_lerne : forall x y, (x <<! y) = (x <<= y) && (x != y) .
    Proof .
      move=> x y; rewrite ler_ltreq; case e: (x <<! y); rewrite /= ?andbN //.
      by case exy: (x == y) e => //; rewrite (eqP exy) ltr_irrefl.
    Qed .

    Lemma ltr_ne : forall x y, (x <<! y) -> (x != y) .
    Proof. by move=> x y; rewrite ltr_lerne; case/andP. Qed.

    Lemma ltrW : forall x y, x <<! y -> x <<= y .
    Proof . by move=> x y H; rewrite ler_ltreq H . Qed .

    Lemma lerNgtr : forall x y, (x <<= y) = ~~ (y <<! x).
    Proof.
      move=> x y; rewrite ltr_lerne eq_ler; case e: (y <<= x); rewrite ?negbK //=.
      by move: (ler_total x y); rewrite e orbF.
    Qed.

    Lemma ltr_ler_trans :
      forall x y z, x <<! y -> y <<= z -> x <<! z .
    Proof .
      move=> x y z Hxy Hyz; rewrite ltr_lerne; apply/andP; split .
      + by apply ler_trans with y; first apply ltrW .
      + apply/eqP; move=> H; subst z .
        rewrite ltr_lerne in Hxy; case/andP: Hxy => Hxy .
        by rewrite eq_ler Hyz Hxy .
    Qed .

    Lemma ler_ltr_trans : forall x y z,
      x <<= y -> y <<! z -> x <<! z.
    Proof.
      move=> x y z Hxy Hyz; rewrite ltr_lerne; apply/andP; split .
      + by apply ler_trans with y; last apply ltrW .
      + apply/eqP; move=> H; subst z .
        rewrite ltr_lerne in Hyz; case/andP: Hyz => Hyz .
        by rewrite eq_ler Hyz Hxy .
      Qed.
    (* ------------------------------------------------------------------ *)

    Lemma ltrN : forall x y, x <<! y -> ~~ (y <<! x).
    Proof.
      by move=> x y; case e: (y <<! x) => //; move/(ltr_trans e); rewrite ltr_irrefl.
    Qed.

    Lemma ltrNger : forall x y, (x <<! y) = ~~ (y <<= x).
    Proof .
      by move=> x y; rewrite lerNgtr negbK .
    Qed .

    (* ------------------------------------------------------------------ *)
    Lemma lerTl : forall x y, x <<= y -> forall z, x+z <<= y+z .
    Proof . by case G => T [? []] . Qed .

    Lemma lerTr : forall x y, x <<= y -> forall z, z+x <<= z+y .
    Proof .
      by move=> x y Hxy z; rewrite ![z+_]addrC; apply lerTl .
    Qed .

    Lemma lerTlb : forall z x y, (x+z <<= y+z) = (x <<= y) .
    Proof .
      move=> z x y; apply /idP/idP => H; last by apply lerTl .
      rewrite -[x](addr0) -(addrN z) -[y](addr0) -(addrN z) .
      by rewrite !addrA; apply lerTl .
    Qed .

    Lemma lerTrb : forall z x y, (z+x <<= z+y) = (x <<= y) .
    Proof . by move=> z x y; rewrite ![z+_]addrC; apply lerTlb . Qed .

    (* ------------------------------------------------------------------ *)
    Lemma ltrTl : forall x y, x <<! y -> forall z, x+z <<! y+z .
    Proof .
      move=> x y H z; rewrite ltr_lerne; apply/andP; split .
      + by apply lerTl; apply ltrW .
      + rewrite ltr_lerne in H; case/andP: H => _ H .
        by apply/eqP => Hz; rewrite (addIr Hz) eqxx in H .
    Qed .

    Lemma ltrTr : forall x y, x <<! y -> forall z, z+x <<! z+y .
    Proof .
      by move=> x y Hxy z; rewrite ![z+_]addrC; apply ltrTl .
    Qed .

    Lemma ltrTlb : forall z x y, (x+z <<! y+z) = (x <<! y) .
    Proof .
      move=> z x y; apply/idP/idP => H; last by apply ltrTl .
      rewrite -[x](addr0) -(addrN z) -[y](addr0) -(addrN z) .
      by rewrite !addrA; apply ltrTl .
    Qed .

    Lemma ltrTrb : forall z x y, (z+x <<! z+y) = (x <<! y) .
    Proof . by move=> z x y; rewrite ![z+_]addrC; apply ltrTlb . Qed .

    (* ------------------------------------------------------------------ *)
    Lemma lerT :
      forall (x₁ y₁ x₂ y₂ : G), x₁ <<= y₁ -> x₂ <<= y₂ -> x₁ + x₂ <<= y₁ + y₂ .
    Proof .
      move=> x₁ y₁ x₂ y₂ Hx Hy; apply ler_trans with (x₁+y₂) .
      by apply lerTr . by apply lerTl .
    Qed .

    Lemma lerT0 :
      forall (x y : G), 0 <<= x -> 0 <<= y -> 0 <<= x + y .
    Proof .
      by move=> x y Hx Hy; rewrite -[0]addr0; apply lerT .
    Qed .

    Lemma ler0T :
      forall (x y : G), x <<= 0 -> y <<= 0 -> x + y <<= 0.
    Proof .
      by move=> x y Hx Hy; rewrite -[0]add0r; apply lerT .
    Qed .

    Lemma ltrT :
      forall (x₁ y₁ x₂ y₂ : G), x₁ <<! y₁ -> x₂ <<! y₂ -> x₁ + x₂ <<! y₁ + y₂ .
    Proof .
      move=> x₁ y₁ x₂ y₂ H1 H2; apply ltr_ler_trans with (y₁ + x₂) .
      - by apply ltrTl .
      - by apply: lerT; rewrite ?ler_refl //; apply: ltrW.
    Qed .

    Lemma ltr_lerT :
      forall (x₁ y₁ x₂ y₂ : G), x₁ <<! y₁ -> x₂ <<= y₂ -> x₁ + x₂ <<! y₁ + y₂ .
    Proof .
      move=> x₁ y₁ x₂ y₂ H1 H2; apply ltr_ler_trans with (y₁ + x₂) .
      by apply ltrTl . by apply lerTr .
    Qed .

    Lemma ltrT0 :
      forall (x y : G), 0 <<! x -> 0 <<! y -> 0 <<! x + y .
    Proof .
      move=> x y Hx Hy; rewrite -[0]addr0; apply ltrT => //.
    Qed .

    Lemma ltr0T :
      forall (x y : G), x <<! 0 -> y <<! 0 -> x + y <<! 0.
    Proof .
      by move=> x y Hx Hy; rewrite -[0]add0r; apply ltrT .
    Qed .

    (* ------------------------------------------------------------------ *)
    Lemma ler_oppger : forall x y, (-x <<= -y) = (y <<= x) .
    Proof .
      move=> x y; rewrite -(lerTlb x) addNr -(lerTrb y) .
      by rewrite addrA addrN addr0 add0r .
    Qed .

    Lemma le0r_geNr0 : forall x, (0 <<= -x) = (x <<= 0) .
    Proof . by move => x; rewrite -{1}oppr0 ler_oppger . Qed .

      Lemma ger0_leNr0 : forall x, (0 <<= x) = (- x <<= 0).
      Proof. by move=> x; rewrite -{2}oppr0 ler_oppger. Qed.

    Lemma ltr_oppgtr : forall x y, (-x <<! -y) = (y <<! x) .
    Proof .
      move=> x y .
      rewrite !ltr_lerne ler_oppger; case (y <<= x) => //= .
      apply congr1; apply/eqP/eqP => [H|->//] .
      by rewrite -[y]opprK -[x]opprK H .
    Qed .

    Lemma lt0r_gtNr0 : forall x, (0 <<! -x) = (x <<! 0) .
    Proof . by move=> x; rewrite -{1}oppr0 ltr_oppgtr . Qed .

      Lemma gtr0_ltNr0 : forall x, (0 <<! x) = (- x <<! 0).
      Proof. by move=> x; rewrite -[x]opprK lt0r_gtNr0 opprK. Qed.

    Lemma opp_ler_ler0 : forall x, ( -x <<= x) = (0 <<= x).
      Proof.
        move=> x;rewrite -(lerTlb x) addNr.
        case e : (0 <<= x); first by rewrite lerT0 //.
        by apply: negbTE; rewrite lerNgtr negbK ltr0T // ltrNger e.
      Qed.

    Lemma opp_lrr_lrr0 : forall x, ( -x <<! x) = (0 <<! x).
      Proof.
        move=> x;rewrite -(ltrTlb x) addNr.
        case e : (0 <<! x); first by rewrite ltrT0 //.
        by apply: negbTE; rewrite ltrNger negbK ler0T // lerNgtr e.
      Qed.

    Lemma ler_opp_ler0 : forall x, ( x <<= -x) = (x <<= 0).
      Proof.
        move=> x;rewrite -(lerTlb x) addNr.
        case e : (x <<= 0); first by rewrite ler0T //.
        by apply: negbTE; rewrite lerNgtr negbK ltrT0 // ltrNger e.
      Qed.

    Lemma lrr_opp_lrr0 : forall x, ( x <<! -x) = (x <<! 0).
      Proof.
        move=> x;rewrite -(ltrTlb x) addNr.
        case e : (x <<! 0); first by rewrite ltr0T //.
        by apply: negbTE; rewrite ltrNger negbK lerT0 // lerNgtr e.
      Qed.

    (* ------------------------------------------------------------------ *)
    Lemma ler_0_lcompat : forall x y, 0 <<= x -> 0 <<= y -> 0 <<= x * y .
    Proof .
      by move=> x y Hx Hy; rewrite -[0](mulr0 x); apply ler_lcompat .
    Qed .

    Lemma ler_neg0_lcompat : forall x y, x <<= 0 -> y <<= 0 -> 0 <<= x * y .
    Proof .
      move=> x y Hx Hy .
      by rewrite -mulrNN; apply ler_0_lcompat; rewrite le0r_geNr0 .
    Qed .

    Lemma ltr_0_1 : 0 <<! (1 : G) .
    Proof .
      rewrite ltr_lerne /negb eq_sym oner_eq0 andbT .
      case/orP: (ler_total 0 1) => // H .
      by rewrite -[1](mulr1 1); apply ler_neg0_lcompat .
    Qed .

    (* ------------------------------------------------------------------ *)
    Lemma ler_add_0l : forall x y, 0 <<= x -> 0 <<= y -> x+y = 0 -> x = 0 .
    Proof .
      move=> x y Hx Hy; move/(congr1 (+%R^~ -y)) .
      rewrite -addrA addrN addr0 add0r; move=> H; subst x .
      rewrite -ler_oppger oppr0 in Hy .
      by apply/eqP; rewrite eq_ler Hx Hy .
    Qed .

    Lemma ler_add_0r : forall x y, 0 <<= x -> 0 <<= y -> x+y = 0 -> y = 0 .
    Proof .
      move=> x y Hx Hy Hxy; apply ler_add_0l with x => // .
      by rewrite addrC .
    Qed .

    (* ------------------------------------------------------------------ *)
    CoInductive ler_xor_gtr (x y : G) : bool -> bool -> Set :=
    | LerNotGtr of x <<= y : ler_xor_gtr x y true  false
    | GtrNotLer of y <<! x : ler_xor_gtr x y false true  .

    CoInductive ltr_xor_ger (x y : G) : bool -> bool -> Set :=
    | LtrNotGer of x <<! y : ltr_xor_ger x y true  false
    | GerNotLtr of y <<= x : ltr_xor_ger x y false true  .

    Lemma lerP : forall x y, ler_xor_gtr x y (x <<= y) (y <<! x) .
    Proof.
      move=> x y; rewrite ltrNger; case Hxy: (x <<= y); constructor=> // .
      by rewrite ltrNger Hxy .
    Qed.

    Lemma ltrP : forall x y, ltr_xor_ger x y (x <<! y) (y <<= x) .
    Proof .
      move=> x y; rewrite lerNgtr; case Hxy: (x <<! y); constructor=> // .
      by rewrite lerNgtr Hxy .
    Qed .

    CoInductive compare x y : bool -> bool -> bool -> Set :=
    | CompareLt of x <<! y : compare x y true  false false
    | CompareGt of y <<! x : compare x y false true  false
    | CompareEq of x =   y : compare x y false false true  .

    Lemma compareP : forall x y, compare x y (x <<! y) (y <<! x) (x == y) .
    Proof .
      move=> x y; rewrite ltrNger eq_ler andbC ltr_lerne .
      case: ltrP; [by constructor | rewrite ler_ltreq; case: lerP => //=] .
      + by move=> _; move/eqP => ->; rewrite eqxx; constructor .
      + by move=> Hxy _; rewrite (ltr_ne Hxy); constructor .
    Qed .

    Lemma ltrNgtr : forall x y, x <<! y -> ~~(y <<! x) .
    Proof . by move=> x y; case: compareP . Qed .

    (* ------------------------------------------------------------------ *)

    Lemma χ0_ltr : forall n, (0 : G) <<! 1 *+ (n.+1).
      have HnSn : forall n, (n%:R : G) <<! n.+1%:R .
      + by elim=> [|n IH]; [apply ltr_0_1 | rewrite 2!mulrS; apply ltrTr] .
      elim=> [|n IH]; [by apply ltr_0_1 | apply: ltr_trans] .
      by apply IH . by rewrite 2!mulrS; apply ltrTr; apply HnSn .
    Qed .

    Lemma χ0 : forall n, 1 *+ n.+1 != 0 :> G.
    Proof .
      move=> n; case D: (n.+1%:R == 0) => //= .
      by move/eqP: D => D; have H := χ0_ltr n; rewrite D ltr_irrefl in H .
    Qed .

    Lemma sign_posR : forall x, 0 <<! x -> sign x = 1 .
    Proof . by move=> x hx; rewrite /sign hx. Qed.

    Lemma sign_negR : forall x, x <<! 0 -> sign x = -1 .
    Proof . by move=> x hx; rewrite /sign hx (negbTE (ltrN hx)). Qed.

    Lemma sign0 : sign 0 = 0 :> G.
    Proof . by rewrite /sign !ltr_irrefl . Qed .

    Lemma sign0P : forall x, reflect (sign x = 0) (x == 0) .
    Proof .
      move=> x; rewrite /sign; case: (compareP 0 x)=> H; last first.
      + by rewrite -H eqxx; constructor.
      + rewrite (negbTE (ltr_ne H)); constructor.
        by  apply/eqP; rewrite oppr_eq0 nonzero1r.
      + rewrite eq_sym (negbTE (ltr_ne H)); constructor.
        by  apply/eqP; rewrite nonzero1r.
      Qed.

    Lemma sign_codomP :
      forall x, [\/ sign x = 1, sign x = -1 | sign x = 0] .
    Proof .
      move=> x; case: (compareP 0 x) => H; [apply Or31 | apply Or32 | apply Or33] .
      - by apply: sign_posR.
      - by apply: sign_negR.
      - by rewrite -H sign0 .
    Qed .

    (* ------------------------------------------------------------------ *)
    Lemma absr_nneg : forall x, 0 <<= x -> absr x = x .
    Proof .
      move=> x Hx; rewrite /absr ltrNger .

      by case D: (0 <<= x) => //=; rewrite Hx in D .
    Qed .

    Lemma absr_npos : forall x, x <<= 0 -> absr x = -x .
    Proof .
      move=> x Hx; rewrite /absr ltrNger; case Hx': (0 <<= x) => //= .
      have Hx0: x = 0 by apply/eqP; rewrite eq_ler Hx Hx' .
      by rewrite Hx0 oppr0 .
    Qed .

    Lemma absr_neg : forall x, x <<! 0 -> absr x = -x .
    Proof . by move=> x Hx; apply absr_npos; apply ltrW . Qed .

    Lemma absr0 : absr 0 = 0 :> G .
    Proof . by rewrite /absr ltr_irrefl . Qed .

    Lemma absrpos : forall x, 0 <<= absr x .
    Proof .
      move=> x; case: (ltrP x 0) => H .
      + by rewrite absr_neg // le0r_geNr0; apply ltrW .
      + by rewrite absr_nneg.
    Qed .

    Lemma absrK : forall x, absr (absr x) = absr x .
    Proof . by move=> x; rewrite absr_nneg // absrpos . Qed .

    Lemma absr_oppr : forall x, absr(-x) = absr x.
    Proof.
      move=> x.
      case a : (0 <<! x).
        by rewrite (absr_nneg (ltrW a)) absr_npos ?opprK //
             -oppr0 ler_oppger ltrW.
        move: (negbT a); rewrite -lerNgtr => a'; rewrite (absr_npos a').
        by rewrite absr_nneg // -ler_oppger opprK oppr0.
    Qed.

    Lemma absr_sign : forall x , (absr x) = (sign x) * x .
    Proof .
      move=> x; case: (compareP x 0) => h.
      + by rewrite /absr h; move/sign_negR: h=> ->; rewrite mulN1r.
      + by rewrite absr_nneg ?ltrW //; move/sign_posR: h=> ->; rewrite mul1r .
      + by rewrite h sign0 absr0 mul0r.
    Qed .

    Lemma absr_addr :
      forall x y, absr (x + y) <<= (absr x) + (absr y).
      move=> x y; rewrite !absr_sign.
      case: (compareP x 0) => hx.
      - rewrite (sign_negR hx) mulN1r; case: (compareP y 0) => hy.
        + rewrite (sign_negR hy) mulN1r mulr_addr.
          rewrite (_ : sign _ = -1) ?mulN1r ?ler_refl //; apply: sign_negR.
          by apply: ltr0T.
        + rewrite (sign_posR hy) mul1r ; case: (compareP (x + y) 0) => hxy.
          * by rewrite (sign_negR hxy) mulr_addr !mulN1r lerTrb opp_ler_ler0 ltrW.
          * by rewrite (sign_posR hxy) mul1r lerTlb ler_opp_ler0 ltrW.
          * by rewrite hxy sign0 mul0r lerT0 // ?le0r_geNr0 ltrW.
        + by rewrite hy mulr0 !addr0 (sign_negR hx) mulN1r ler_refl.
      - rewrite (sign_posR hx) mul1r;  case: (compareP y 0) => hy.
        + rewrite (sign_negR hy) mulN1r mulr_addr; case: (compareP (x + y) 0) => hxy.
          * by rewrite (sign_negR hxy) !mulN1r lerTlb opp_ler_ler0 ltrW.
          * by rewrite (sign_posR hxy) !mul1r lerTrb ler_opp_ler0 ltrW.
          * by rewrite hxy sign0 !mul0r addr0 lerT0 // ?le0r_geNr0 ltrW.
        + rewrite (sign_posR hy) mul1r (_ : sign _ = 1) ?mul1r ?ler_refl //.
          by apply: sign_posR; apply: ltrT0.
        + by rewrite hy mulr0 !addr0 (sign_posR hx) mul1r ler_refl.
      - by rewrite hx mulr0 !add0r ler_refl.
    Qed.

Lemma absr_lt : forall x y, absr x <<! y -> x <<! y.
Proof.
move=> x y h.
have py : 0 <<! y by apply: (ler_ltr_trans (absrpos x)).
case: (compareP x 0) => h2.
- by rewrite (ltr_trans h2).
- by rewrite -[x]absr_nneg // ltrW.
- by rewrite h2.
Qed.

Lemma absr_le : forall x y, absr x <<= y -> x <<= y.
Proof.
move=> x y h.
have py : 0 <<= y by apply: (ler_trans (absrpos x)).
case: (compareP x 0) => h2.
- by rewrite ltrW // (ltr_ler_trans h2).
- by rewrite -[x]absr_nneg // ltrW.
- by rewrite h2.
Qed.

Lemma lt_absr : forall x y, absr x <<! y -> - y <<! x.
Proof.
move=> x y h.
have py : 0 <<! y by apply: (ler_ltr_trans (absrpos x)).
case: (compareP x 0) => h2.
- by rewrite -[x]opprK ltr_oppgtr -[- x]absr_npos // ltrW.
- by rewrite -[x]opprK -ltr_oppgtr !opprK; apply: ltr_trans py; rewrite -gtr0_ltNr0.
- by rewrite h2 -gtr0_ltNr0.
Qed.

Lemma le_absr : forall x y, absr x <<= y -> - y <<= x.
Proof.
move=> x y h.
have py : 0 <<= y by apply: (ler_trans (absrpos x)).
case: (compareP x 0) => h2.
- by rewrite -[x]opprK ler_oppger -[- x]absr_npos // ltrW.
- by rewrite -[x]opprK -ler_oppger !opprK; apply: ler_trans py; rewrite -ger0_leNr0 ltrW.
- by rewrite h2 -ger0_leNr0.
Qed.

(* ------------------------------------------------------------------ *)
Lemma ler_addl_abs :
  forall x₁ x₂, x₁ <<= x₂ ->
    forall y, (absr y) <<= (x₂ - x₁) ->
      x₁ <<= x₂ + y .
Proof.
move=> x1 x2 hx12 y; move/le_absr. rewrite -(@lerTlb x2) addrC oppr_add opprK.
by rewrite  addrA addrN add0r addrC.
Qed.

    Lemma ler0_addl_abs :
      forall x y, 0 <<= x -> (absr y) <<= x -> 0 <<= x + y .
    Proof .
      by move=> x y Hx Hy; apply ler_addl_abs; last rewrite oppr0 addr0 .
    Qed .
  End OComringTheory .

(*
  Module OField .

    Record class_of (R : Type) : Type := Class {
      base1 :> GRing.Field.class_of R;
      ext :> OComRing.mixin_of (GRing.Field.Pack base1 R)
    } .

(*    Coercion base2 R m := OComRing.Class (@ext R m).*)
    Coercion base2 R m := @OComRing.Class R _ (@ext R m).

    Structure type : Type := Pack {sort :> Type; _ : class_of sort; _ : Type}.

    Definition class cT := let: Pack _ c _ := cT return class_of cT in c.
    Definition unpack K (k : forall T (c : class_of T), K T c) cT :=
      let: Pack T c _ := cT return K _ (class cT) in k _ c.
    Definition repack cT : _ -> Type -> type :=
      let k T c p := p c in unpack k cT.

(* Mixin here ? *)
    Definition pack :=
      let k T c m := Pack (@Class T c m) T in GRing.Field.unpack k.

    Definition eqType          cT := Equality.Pack             (class cT) cT.
    Definition choiceType      cT := Choice.Pack               (class cT) cT.
    Definition zmodType        cT := GRing.Zmodule.Pack        (class cT) cT.
    Definition ringType        cT := GRing.Ring.Pack           (class cT) cT.
    Definition unitRingType    cT := GRing.UnitRing.Pack       (class cT) cT.
    Definition comRingType     cT := GRing.ComRing.Pack (class cT) cT.
    Definition comUnitRingType cT := GRing.ComUnitRing.Pack       (class cT) cT.
    Definition idomainType     cT := GRing.IntegralDomain.Pack (class cT) cT.
    Coercion   fieldType       cT := GRing.Field.Pack (class cT) cT.
    Coercion   oComRingType    cT := OComRing.Pack (class cT) cT.
    Definition oFieldType cT :=
      @OComRing.Pack (fieldType cT) (class cT) cT.

  End OField .

  Canonical Structure OField.eqType.
  Canonical Structure OField.choiceType.
  Canonical Structure OField.zmodType.
  Canonical Structure OField.ringType.
  Canonical Structure OField.comRingType.
  Canonical Structure OField.unitRingType.
  Canonical Structure OField.comUnitRingType.
  Canonical Structure OField.idomainType.
  Canonical Structure OField.fieldType.

  Bind Scope comring_scope with OField.sort .
*)
  Module OField .

    Record class_of (R : Type) : Type := Class {
      base1 :> GRing.Field.class_of R;
      ext :> OComRing.mixin_of (GRing.Field.Pack base1 R)
    } .

    Coercion base2 R m := @OComRing.Class R _ (@ext R m).

    Structure type : Type := Pack {sort :> Type; _ : class_of sort; _ : Type}.

    Definition class cT := let: Pack _ c _ := cT return class_of cT in c.
    Definition unpack K (k : forall T (c : class_of T), K T c) cT :=
      let: Pack T c _ := cT return K _ (class cT) in k _ c.
    Definition repack cT : _ -> Type -> type :=
      let k T c p := p c in unpack k cT.

(* Mixin here ? *)
    Definition pack :=
      let k T c m := Pack (@Class T c m) T in GRing.Field.unpack k.

    Definition eqType          cT := Equality.Pack             (class cT) cT.
    Definition choiceType      cT := Choice.Pack               (class cT) cT.
    Definition zmodType        cT := GRing.Zmodule.Pack        (class cT) cT.
    Definition ringType        cT := GRing.Ring.Pack           (class cT) cT.
    Definition unitRingType    cT := GRing.UnitRing.Pack       (class cT) cT.
    Definition comRingType     cT := GRing.ComRing.Pack (class cT) cT.
    Definition comUnitRingType cT := GRing.ComUnitRing.Pack       (class cT) cT.
    Definition idomainType     cT := GRing.IntegralDomain.Pack (class cT) cT.
    Coercion   fieldType       cT := GRing.Field.Pack (class cT) cT.
    Coercion   oComRingType    cT := OComRing.Pack (class cT) cT.
    Definition oFieldType cT :=
      @OComRing.Pack (fieldType cT) (class cT) cT.

  End OField .

  Canonical Structure OField.eqType.
  Canonical Structure OField.choiceType.
  Canonical Structure OField.zmodType.
  Canonical Structure OField.ringType.
  Canonical Structure OField.comRingType.
  Canonical Structure OField.unitRingType.
  Canonical Structure OField.comUnitRingType.
  Canonical Structure OField.idomainType.
  Canonical Structure OField.fieldType.
  Canonical Structure OField.oComRingType.

Bind Scope ring_scope with OField.sort.

Section OrderedFieldTheory.

    Variable G : OField.type .
    Implicit Types x y : G.

    Lemma ltr_0_lcompat : forall x y, 0 <<! x -> 0 <<! y -> 0 <<! x * y .
    Proof .
      move=> x y Hx Hy; rewrite ltr_lerne; apply/andP; split .
      + by apply ler_0_lcompat; apply ltrW .
      + rewrite eq_sym mulf_eq0 negb_or .
        by rewrite ![_ == 0]eq_sym (ltr_ne Hx) (ltr_ne Hy) .
    Qed .

    Lemma oppreq_0 : forall x, (x == -x) = (x == 0) .
    Proof .
      move=> x; apply/eqP/eqP => [|->]; last by rewrite oppr0 .
      move/(congr1 (+%R x)); rewrite addrN -{1 2}[x](mul1r) -mulr_addl .
      move/eqP; rewrite mulf_eq0; case/orP; last by move/eqP => -> .
      by rewrite (negbTE (χ0 G 1%nat)).
    Qed.

    Lemma sign_pos : forall x, reflect (sign x = 1) (0 <<! x) .
    Proof .
      move=> x; rewrite /sign; case: (compareP 0 x) => h; constructor => //.
      + by apply/eqP; rewrite eq_sym oppreq_0 nonzero1r.
      + by apply/eqP; rewrite eq_sym nonzero1r.
    Qed .

    Lemma sign_neg : forall x, reflect (sign x = -1) (x <<! 0) .
    Proof .
      move=> x; rewrite /sign; case: (compareP 0 x) => _; constructor=> // .
      + apply/eqP; rewrite oppreq_0; exact: nonzero1r .
      + move/(congr1 -%R); rewrite opprK oppr0; move/eqP .
        by rewrite eq_sym (negbTE (nonzero1r _)) .
    Qed .

    Lemma mulr_sign : forall x y, sign (x * y) = (sign x) * (sign y) .
    Proof .
      move=> x y; case: (compareP 0 x) .
      + case: (compareP 0 y) => Hy Hx .
        * by rewrite !sign_posR ?mul1r //; apply ltr_0_lcompat .
        * rewrite [sign x]sign_posR // !sign_negR ?mul1r // .
          rewrite -lt0r_gtNr0 -mulrN; apply ltr_0_lcompat => // .
          by rewrite lt0r_gtNr0 .
        * by rewrite -Hy mulr0 sign0 mulr0 .
      + case: (compareP 0 y) => Hy Hx .
        * rewrite [sign y]sign_posR // !sign_negR ?mulr1 // .
          rewrite -lt0r_gtNr0 -mulNr; apply ltr_0_lcompat => // .
          by rewrite lt0r_gtNr0 .
        * rewrite [sign x]sign_negR // [sign y]sign_negR // .
          rewrite sign_posR; first by rewrite ?mulrNN ?mulr1 .
          by rewrite -mulrNN; apply ltr_0_lcompat; rewrite lt0r_gtNr0 .
        * by rewrite -Hy mulr0 sign0 mulr0 .
      + by move=> <-; rewrite mul0r sign0 mul0r .
    Qed .

    (* ------------------------------------------------------------------ *)

    Lemma invr_ltr : forall x, (0 <<! x^-1) = (0 <<! x) .
    Proof .
      have Hsign : forall x, x != 0 -> sign (x^-1 * x) = 1 .
      + by move=> x Hx; rewrite mulVf // sign_posR // ltr_0_1 .

      have HP: forall x, 0 <<! x -> 0 <<! x^-1 .
      + move=> x Hx; apply/sign_pos; rewrite -(Hsign x) .
        * rewrite mulr_sign -{1}[sign x^-1]mulr1 .
          by congr (_ * _); symmetry; apply/sign_pos .
        * by rewrite eq_sym; apply (ltr_ne Hx) .

      move=> x; apply/idP/idP; last exact: HP .
      by move=> Hx; rewrite -(invrK x); apply HP .
    Qed .

    Lemma ler_Ilcompat_r :
      forall x y₁ y₂, 0 <<! x -> x * y₁ <<= x * y₂ -> y₁ <<= y₂ .
    Proof .
      move=> x y₁ y₂ Hx Hy .
      rewrite -[y₁](mul1r) -[y₂](mul1r) -[1](@mulVf _ x) 1?eq_sym ?(ltr_ne Hx) //.
      by rewrite -!mulrA; apply ler_lcompat => //; apply ltrW; rewrite invr_ltr .
    Qed .

    Lemma ler_Ilcompat_l :
      forall x y₁ y₂, 0 <<! x -> y₁ * x <<= y₂ * x -> y₁ <<= y₂ .
    Proof .
      move=> x y₁ y₂; rewrite mulrC [y₂ * _]mulrC; exact: ler_Ilcompat_r.
    Qed .

    Lemma ltr_Ilcompat_r :
      forall x y₁ y₂, 0 <<! x -> x * y₁ <<! x * y₂ -> y₁ <<! y₂ .
    Proof .
      move=> x y₁ y₂ Hx Hy .
      rewrite -[y₁](mul1r) -[y₂](mul1r) -[1](@mulVf _ x) 1?eq_sym ?(ltr_ne Hx) //.
      by rewrite -!mulrA; apply ltr_lcompat => //; rewrite invr_ltr .
    Qed .

    Lemma ltr_Ilcompat_l :
      forall x y₁ y₂, 0 <<! x -> y₁ * x <<! y₂ * x -> y₁ <<! y₂ .
    Proof .
      move=> x y₁ y₂; rewrite mulrC [y₂ * _]mulrC; exact: ltr_Ilcompat_r.
    Qed .

    Lemma invr1_ltr0_ltr1 : forall x, 0 <<! x -> (x <<! 1) = (1 <<! x^-1).
      Proof.
        move=> x hx; move:(hx); rewrite ltr_lerne eq_sym; case/andP=> hx1 hx2.
        rewrite -{1}(divff hx2) -{1}(mulr1 x); case e: (1 <<! x^-1).
          by rewrite ltr_lcompat.
        by rewrite ltrNger ler_lcompat // lerNgtr e.
      Qed.

    Lemma invr1_ltr0_1ltr : forall x, 0 <<! x -> (1 <<! x) = (x^-1 <<! 1).
      Proof.
        move=> x hx; apply/idP/idP => h1.
          apply: (ltr_Ilcompat_r hx); rewrite divff // ?mulr1 //.
          by move: hx; rewrite ltr_lerne eq_sym; case/andP.
        move:(hx); rewrite -invr_ltr=> hIx; apply: (ltr_Ilcompat_r hIx).
        by rewrite mulr1 mulVf //; move: hx; rewrite ltr_lerne eq_sym; case/andP.
      Qed.

    Lemma invr1_0ltr_ltr1I : forall x, x <<! 0 -> (x <<! -1) = (-1 <<! x^-1).
      Proof.
        move=> x; rewrite -(opprK x).
      rewrite invrN !ltr_oppgtr -lt0r_gtNr0 opprK; exact: invr1_ltr0_1ltr.
      Qed.

    Lemma invr1_0ltr_ltrI1 : forall x, x <<! 0 -> (-1 <<! x) = (x^-1 <<! -1).
      Proof.
        move=> x; rewrite -(opprK x).
      rewrite invrN !ltr_oppgtr -lt0r_gtNr0 opprK; exact: invr1_ltr0_ltr1.
      Qed.

      (* We cannot define a theory of floor since some ordered comring do not have...*)

    (* ------------------------------------------------------------------ *)
    Lemma Ndiscrete01 : exists x : G, (0 <<! x) && (x <<! 1) .
    Proof .
      have H : (0 : G) <<! 1/(1+1).
      + apply ltr_0_lcompat; first exact: ltr_0_1 .
        rewrite invr_ltr; apply: (χ0_ltr _ 1%nat) .
      exists (1/(1+1)); apply/andP; split=> // .
      rewrite -(ltrTlb (-1)) addrN .
      rewrite -{4}[1](@mulfV _ (1+1)); last exact: (χ0 _ 1) .
      rewrite -mulNr -mulr_addl -mulN1r mulr_addr mulN1r .
      by rewrite addrA addrN add0r mulNr -ltr_oppgtr oppr0 opprK .
    Qed .

    Lemma Ndiscrete : forall x z, x <<! z -> exists y, (x <<! y) && (y <<! z) .
    Proof .
      move=> x z Hxz; elim Ndiscrete01=> y; case/andP => Hylow Hyhi .
      exists (y * (z-x) + x); apply/andP; split .
      + rewrite -{1}[x]add0r ltrTlb; apply ltr_0_lcompat => // .
        by rewrite -[0](addrN x) ltrTlb .
      + rewrite -(ltrTlb (-x)) -addrA addrN addr0 .
        rewrite mulrC -{2}[z-x]mulr1; apply ltr_lcompat => // .
        by rewrite -[0](addrN x) ltrTlb .
    Qed .

    Lemma absr_mulr :
      forall x y, absr (x * y) = (absr x) * (absr y) .
    Proof .
      move=> x y; rewrite !absr_sign mulr_sign .
      by rewrite -[_ * x * _]mulrA -[x * (_ * _)]mulrCA !mulrA .
    Qed .

End OrderedFieldTheory.

End GOrdered .

Bind Scope comring_scope with GOrdered.OComRing.sort .

Canonical Structure GOrdered.OComRing.eqType.
Canonical Structure GOrdered.OComRing.choiceType.
Canonical Structure GOrdered.OComRing.zmodType.
Canonical Structure GOrdered.OComRing.ringType.
Canonical Structure GOrdered.OComRing.comringType.

Notation ocomringType  := (GOrdered.OComRing.type) .
Notation OcomringType  := (GOrdered.OComRing.pack) .
Notation OcomringMixin := (GOrdered.OComRing.Mixin) .

Canonical Structure GOrdered.OField.eqType.
Canonical Structure GOrdered.OField.choiceType.
Canonical Structure GOrdered.OField.zmodType.
Canonical Structure GOrdered.OField.ringType.
Canonical Structure GOrdered.OField.comRingType.
Canonical Structure GOrdered.OField.unitRingType.
Canonical Structure GOrdered.OField.comUnitRingType.
Canonical Structure GOrdered.OField.idomainType.
Canonical Structure GOrdered.OField.fieldType.
Canonical Structure GOrdered.OField.oComRingType.

Notation ofieldType  := (GOrdered.OField.type) .
Notation OfieldType  := (GOrdered.OField.pack) .

Notation "x <<= y" := (GOrdered.leb x y) .
Notation "x <<! y" := (GOrdered.ltb x y) .

(* -------------------------------------------------------------------- *)
Module Min .
  Section Defs .
    Variable R : ocomringType .
    Implicit Types x y : R .

    Definition minr x y := if x <<! y then x else y .

    Section MinB .
      Variable I : eqType .
      Variable P : pred I .
      Variable F : I -> R .

      Definition minB (x0 : R) (r : seq I) :=
        if   (filter P r) is x::xs
        then \big[minr/(F x)]_(i <- xs) (F i)
        else x0 .
    End MinB .
  End Defs .
End Min .

Notation minr := (@Min.minr _) .
Notation minB := (@Min.minB _ _) .

Section MinTheory .
  Variable R : ocomringType .

  Import GOrdered .

  Lemma minrC : commutative (@Min.minr R) .
  Proof . by move=> x y; rewrite /minr; case: (compareP x y) . Qed .

  Lemma minrA : associative (@Min.minr R) .
    move=> x y z; rewrite /minr .
    (case: (compareP y z); last (move=> <-));
    (case: (compareP x y); last (move=> <-));
      try solve
        [ by do! (move=> H; rewrite ?H ?(negbTE (ltrNgtr H)) => {H})
        | by rewrite ltr_irrefl ] .
    + by move=> Hxy Hyz; rewrite (ltr_trans Hxy Hyz) .
    + move=> Hyx Hzy; rewrite (negbTE (ltrNgtr Hzy)) .
      by rewrite (negbTE (ltrNgtr (ltr_trans Hzy Hyx))) .
  Qed .

  Lemma minrCA : left_commutative (@Min.minr R) .
  Proof .
    by move=> x y z; rewrite minrA [minr x y]minrC -minrA .
  Qed .

  Lemma minrAC : right_commutative (@Min.minr R) .
  Proof .
    by move=> x y z; rewrite -minrA [minr y z]minrC minrA .
  Qed .

  Lemma minrl : forall (x y : R), minr x y <<= x .
  Proof .
    by move=> x y; rewrite /minr; case: (ltrP x y); rewrite // ler_refl .
  Qed .

  Lemma minrr : forall (x y : R), minr x y <<= y .
  Proof .
    by move=> x y; rewrite minrC; apply minrl .
  Qed .

  Section minB .
    Variable I  : eqType .
    Variable P  : pred I .
    Variable F  : I -> R .
    Variable x0 : R .

    Lemma minB_nil : minB P F x0 [::] = x0 .
    Proof . by [] . Qed .

    Lemma minB_seq1 : forall x, P x -> minB P F x0 [:: x] = (F x) .
    Proof . by move=> x H; rewrite /minB /filter H big_nil . Qed .

    Lemma minB_cons :
      forall x xs, P x -> has P xs
        -> minB P F x0 (x::xs) = minr (F x) (minB P F x0 xs) .
    Proof .
      move=> x xs HPx HPxs; rewrite {1}/minB /= HPx .
      rewrite has_filter in HPxs; move/eqP: HPxs => HPxs .
      rewrite /minB; case D: (filter P xs) => [|z₁ zs] {D HPx} // .
      elim: zs x z₁ => [|z₂ zs IH] x z₁ .
      + by rewrite unlock /= minrC .
      + by rewrite big_cons !IH minrCA .
    Qed .

    Lemma minB_head :
      forall x xs, ~~ (has P xs) ->
        minB P F x0 (x::xs) = (if P x then F x else x0) .
    Proof .
      move=> x xs HPxs; rewrite /minB /= .
      rewrite has_filter negbK in HPxs; rewrite (eqP HPxs) .
      by case (P x); rewrite ?big_nil .
    Qed .

    Lemma minB_tail :
      forall x xs, ~~ (P x) -> minB P F x0 (x::xs) = minB P F x0 xs .
    Proof .
      by move=> x xs HPx; rewrite {1}/minB /= (negbTE HPx) .
    Qed .

    Lemma minB_empty :
      forall xs, ~~ (has P xs) ->  minB P F x0 xs = x0 .
    Proof .
      elim=> [|x xs IH] //= .
      rewrite negb_orb; case/andP=> HPx HPxs .
      by rewrite minB_tail // IH .
    Qed .

    Lemma minBE :
      forall (r : seq I),
        forall z, z \in r -> P z -> minB P F x0 r <<= F z .
    Proof .
      elim=> [|x xs IH] // z Hmem Hpz .
      rewrite in_cons in Hmem; case/orP: Hmem => [|Hz] .
      + move/eqP => <-; case D: (has P xs) .
        * by rewrite minB_cons // minrl .
        * by rewrite minB_head /negb ?D // Hpz ler_refl .
      + have Htail: has P xs by (apply/hasP; exists z) .
        case D: (P x) .
        * rewrite minB_cons //; apply: ler_trans .
          by apply minrr . by apply IH .
        * by rewrite minB_tail /negb ?D //; apply IH .
    Qed .

    Lemma minBP :
      forall d (r : seq I), has P r ->
        exists i,
          let x := nth d r i in
            [/\ (i < size r), P x & (minB P F x0 r = F x)] .
    Proof .
      move=> d; elim=> [|x xs IH] //= H .
      case Dhead: (P x); case Dtail: (has P xs) .
      + rewrite minB_cons // /minr; case: ltrP => _ .
        * by exists 0%N => // .
        * by elim (IH Dtail)=> i [Hsize HPi Hmini]; exists i.+1 .
      + exists 0%N; split=> // .
        by rewrite minB_head ?Dhead //=; apply negbT .
      + elim (IH Dtail)=> i [Hsize HPi Hmini]; exists i.+1 .
        by split=> //=; rewrite minB_tail //; apply negbT .
      + by rewrite Dhead Dtail in H .
    Qed .

    Lemma minBI :
      forall (r : seq I), has P r -> (minB P F x0 r) \in (map F r) .
    Proof .
      move=> r; move/hasP=> [d Hdr HPd]; elim (@minBP d r) .
      + move=> n [Hsize HP Heq]; apply/nthP; exists n .
        * by rewrite size_map .
        * by rewrite Heq -(nth_map d x0) //; reflexivity .
      + by apply/hasP; exists d .
    Qed .

    Lemma min_fall_lt :
      forall (r : seq I) x, has P r
        -> (forall z, z \in r -> P z -> x <<! F z)
        -> x <<! minB P F x0 r .
    Proof .
      elim=> [|x xs IH] // z Hpz H .
      case Dhead: (P x); case Dtail: (has P xs) .
      + rewrite minB_cons // /minr; case: (ltrP (F x)) => D .
        * by apply H => //; rewrite in_cons eqxx .
        * by apply IH => // w Hw HPw; apply H => //; rewrite in_cons Hw orbT .
      + rewrite minB_head /negb ?Dtail // Dhead .
        by apply H => //; rewrite in_cons eqxx .
      + rewrite minB_tail /negb ?Dhead //; apply IH => // .
        by move=> w Hw HPw; apply H => //; rewrite in_cons Hw orbT .
      + by rewrite /= Dhead Dtail in Hpz .
    Qed .

    Lemma min_fall_le :
      forall (r : seq I) x, has P r
        -> (forall z, z \in r -> P z -> x <<= F z)
        -> x <<= minB P F x0 r .
    Proof .
      elim=> [|x xs IH] // z Hpz H .
      case Dhead: (P x); case Dtail: (has P xs) .
      + rewrite minB_cons // /minr; case: (ltrP (F x)) => D .
        * by apply H => //; rewrite in_cons eqxx .
        * by apply IH => // w Hw HPw; apply H => //; rewrite in_cons Hw orbT .
      + rewrite minB_head /negb ?Dtail // Dhead .
        by apply H => //; rewrite in_cons eqxx .
      + rewrite minB_tail /negb ?Dhead //; apply IH => // .
        by move=> w Hw HPw; apply H => //; rewrite in_cons Hw orbT .
      + by rewrite /= Dhead Dtail in Hpz .
    Qed .
  End minB .
End MinTheory .

Notation "\minB_ ( i | P ) F" :=
  (minB (fun i => P%B) (fun i => F) 0 (index_enum _))
  (at level 36, F at level 36, i at level 50) .

Notation "\minB_ ( i \in I | P ) F"
  := (\minB_(i | (i \in I) && P) F)
  (at level 36, F at level 36, i, A at level 50) .