Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div.
Require Import prime fintype paths finfun bigops finset ssralg.
Require Import groups morphisms normal commutators.
Require Import cyclic center pgroups sylow gprod schurzass hall.
Require Import coprime_act nilpotent.

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

Import GroupScope.

Section coprime_comm.
Variable T : finGroupType.

(* same as the following but with weaker assumptions
Lemma comm_center_prod: forall (A G: group T),
  A \subset 'N(G) -> coprime #|[~: G, A]| #|A| -> solvable [~: G, A] ->
  G = [~: G, A] * 'C_G(A) :> set _.
Proof.
move=> A G AsubNG coprime solv.
apply/eqP; rewrite eqEsubset; apply/andP; split.
- apply: sub_gmul; rewrite /=; first by apply:commg_norml.
  - by apply: (subset_trans _ (commg_norml G A)); rewrite /centraliser; apply: subsetIl.
  - rewrite coprime_quotient_cent //=.
    - by rewrite subsetI; apply/andP; split; last by apply: quotient_cents2r.
    - apply/andP; rewrite //=; split; last by apply:commg_norml.
      by rewrite commGC commg_subr //.
    - by rewrite commGC; apply: commg_norml.
- rewrite -{3}mulGid; apply:imset2S; last by apply: subsetIl.
  by rewrite commGC commg_subr //.
Qed.
*)

Lemma comm_center_prod : forall A G : {group T},
  A \subset 'N(G) -> coprime #|G| #|A| -> solvable G ->
  G :=: [~: G, A] * 'C_G(A).
Proof.
move=> A G AsubNG coprime solv.
apply/eqP; rewrite eqEsubset andbC -{3}mulGid imset2S ?subsetIl //; last first.
  by rewrite commGC commg_subr.
rewrite -quotientSK ?commg_norml // coprime_quotient_cent_weak //=; last first.
- by rewrite commGC commg_norml.
- by rewrite [_ <| G]andbC commg_norml commGC commg_subr.
by rewrite subsetI andbC quotient_cents2r /=.
Qed.

Lemma commGAA:   forall A G : {group T},
  A \subset 'N(G) -> coprime #|G| #|A| -> solvable G ->
  [~: G, A] = [~: G, A, A].
Proof.
move=> A G AsubNG coGA solG.
apply/eqP; rewrite eqEsubset; apply/andP; split; last first.
  by rewrite commSg // commg_subl.
rewrite {1}(comm_center_prod AsubNG coGA solG) commMG.
- by rewrite (commG1P (subsetIr _ _)) //= mulg1.
- by rewrite subIset // commg_norml.
by rewrite subIset // orbC cent_sub.
Qed.

Lemma comm_center_triv:   forall A G : {group T},
  A \subset 'N(G) -> coprime #|G| #|A| -> abelian G ->
 [~: G, A] :&: 'C_G(A) = 1.
Proof.
move => A G norm co abel.
have mulGC : @commutative (subg_of G) mulg.
  by case=> x Gx [y Gy]; apply: val_inj; rewrite /= (centsP abel).
pose gTm := ZmodMixin (@mulgA _) mulGC (@mul1g _) (@mulVg _).
pose gTG := ZmodType gTm; hnf in gTG.
have Gval: forall u : gTG, sgval u \in G by exact: valP.
have valM: forall a b : gTG, sgval (a + b)%R = sgval a * sgval b by [].
pose f x y : gTG := subg G (conjg x y).
pose phi y := sgval (\sum_(x \in A) f y x)%R.
have morphic_phi: {in G &, {morph phi : x y / x * y}}.
  move => x y xin yin; rewrite /phi -valM -big_split //=.
  congr (sgval _); apply: eq_bigr => z Az.
  have xz: x ^ z \in G by rewrite memJ_norm //; apply (subsetP norm).
  have yz: y ^ z \in G by rewrite memJ_norm //; apply (subsetP norm).
  by rewrite /f conjMg; apply: val_inj; rewrite /= !subgK //; apply: groupM.
have phia : forall a y, a \in A -> phi (conjg y a) = phi y.
  move=> a y ain; rewrite /phi; apply: sym_eq.
  rewrite (reindex (fun x => a * x))  /=; last first.
    - exists (fun x => a^-1 * x); move => b abin; rewrite //=; first by rewrite mulKg //.
      by rewrite mulKVg //.
    - rewrite (eq_bigl (fun x => x \in A)); last by move => x; rewrite //=; apply: groupMl.
      by congr (sgval _); apply: eq_bigr => x xin; rewrite /f conjgM //.
pose Mphi := Morphism  morphic_phi.
have kerphi: forall c, c \in [~: G, A] -> c \in 'ker Mphi.
  move=>c; move/generatedP; apply {c}.
  apply/subsetP; move=> c; case/imset2P=> x a xin ain -> {c}.
  have xinv : x^-1 \in G by apply:groupVr.
  have xconja: x ^ a \in G by rewrite memJ_norm //; apply: (subsetP norm).
  apply/morphpreP; split; rewrite/commg //=; first by apply: groupM.
  by apply/set1P; rewrite morphic_phi // phia // [phi _](morphV Mphi) // mulVg.
have centr : forall v, v \in 'C_G(A) -> phi v = v^+ #|A|.
  move=> v; rewrite inE; case/andP=> inG; move/centP=> inC.
  pose cphi y := sgval (\sum_(x \in A) (subg G y : gTG))%R.
  have phiv: phi v = cphi v.
    congr (sgval _); apply: eq_bigr => x; rewrite /f => xin.
    by congr subg; rewrite /conjg -{2}(mulKg x v); congr (_ * _); apply: inC.
  rewrite phiv /cphi GRing.sumr_const.
  by case: {+}#|_| => //; elim=> [|n IHn]; rewrite /= subgK ?IHn.
have v1: forall v, v \in G ->  v ^+ #|A| = 1 -> v = 1.
  move => v vin; move/eqP; rewrite -order_dvdn => div.
  have ov1: #[ v ] = 1%nat.
    rewrite /coprime in co; apply/eqP.
    by rewrite -dvdn1 -(eqP co) dvdn_gcd order_dvdG.
  rewrite -(expg1 v) -ov1; apply: expg_order.
  apply/eqP; rewrite eqEsubset; apply/andP; split.
  - apply/subsetP => x; case/setIP=> inco incen; move: (incen).
    rewrite inE; case/andP=> inG ince; apply/set1P; apply: v1; first done.
    by rewrite -centr; last done; apply: (mker (kerphi x inco)).
  - by apply/subsetP => x; move/set1P ->; apply/setIP; split; apply: group1.
Qed.

Theorem comm_center_dir_prod: forall A G : {group T},
  A \subset 'N(G) -> coprime #|G| #|A| -> abelian G ->
  G :=: [~: G, A] \x 'C_G(A).
move=> A G AsubNG coprime abel.
have trI: [~: G, A] :&: 'C_G(A) = 1 by apply: comm_center_triv.
rewrite dprodE //.
- apply: comm_center_prod => //.
  apply: nilpotent_sol; exact: abelian_nil.
apply: subset_trans (centS (subsetIl _ _)); apply: subset_trans abel.
by rewrite commg_subl.
Qed.

Definition stabn (A:{set T}) (G G1:{group T}):=
  (G1 <| G) && (A \subset 'N(G1)) && (A/G1 \subset 'C(G/G1)).

Definition stabn_seq A G s:=
  path (stabn A) G s && (last [1 T]%G (G :: s) == [1 T]%G).

Theorem stabn_seq_cent: forall (A G: {group T}) s,
coprime #|G| #|A| -> solvable G -> stabn_seq A G s -> A \subset 'C(G).
Proof.
move => A G s; rewrite /stabn_seq; move: G.
elim: s => [G1 _ _|G1 t indh G cop solv] /=; first by move/eqP->; rewrite cents1.
rewrite /=. case/andP. case/andP. case /andP. case /andP.
move=> G1nG AnG1 subC ph lh.
have subC1: A \subset 'C(G1).
  apply: indh; last by apply/andP; split.
  - by have G1sG := normal_sub G1nG; rewrite -(LaGrange G1sG) coprime_mull in cop; case/andP: cop.
  - by apply: (solvableS (normal_sub G1nG)).
have lem: G \subset G1 * 'C_G(A).
  rewrite -quotientSK; last by apply:normal_norm.
  by rewrite coprime_quotient_cent_weak // subsetI subxx /= centsC.
have lem2: G1 * 'C_G(A) \subset 'C(A).
  by apply: mul_subG; [rewrite centsC | exact: subsetIr].
by rewrite centsC; apply: (subset_trans lem lem2).
Qed.

(* B+G Prop 1.09 *)
Theorem faithful_cent_fix_nil : forall A G: {group T},
    A \subset 'N(G) -> coprime #|G| #|A| -> nilpotent G ->
  'C_G('C_G(A)) \subset 'C(A) -> G \subset 'C(A).
Proof.
move=> A G subN co nil subC.
suff AsubCNC: A \subset 'C('N_G('C_G(A))).
  apply/setIidPl; symmetry; apply: nilpotent_sub_norm; rewrite ?subsetIl //.
  by rewrite subsetI subsetIl centsC AsubCNC.
suff stab: stabn_seq A 'N_G('C_G(A)) [:: 'C_G(A)%G ; 1%G].
apply: stabn_seq_cent _ _ stab.
  by rewrite -(LaGrange (subsetIl G 'N('C_G(A)))) coprime_mull in co; case/andP: co.
  by apply: nilpotent_sol; apply: (nilpotentS _ nil); rewrite subsetIl.
apply/andP; split; last done.
have AsubNC: A \subset 'N('C_G(A)) by rewrite normsI ?norms_cent ?normG.
rewrite /stabn /= andbT; apply/andP; split.
  rewrite /stabn AsubNC /(_ <| _) subsetIr subsetI subsetIl /= normG /=.
  apply: quotient_cents2r.
  rewrite gen_subG; apply/subsetP=> ax; case/imset2P=> a x Aa Nx ->{ax}.
  case/setIP: Nx => Gx Nx.
  have subCG: 'C_G('C_G(A)) \subset 'C_G(A) by rewrite subsetI subC subsetIl //.
  apply: (subsetP subCG); rewrite inE commgEr groupMr // memJ_norm ?(subsetP subN, groupV) // Gx.
  apply/centP=> y Cy.
  rewrite /commute -mulgA (conjgCV x y) 2!mulgA; congr (_ * _).
  have Cyx: y ^ x^-1 \in 'C_G(A) by rewrite -mem_conjg (normP Nx).
  have Cfixa: forall z, z \in 'C_G(A) -> z ^ a = z.
    by move=> z; case/setIP=> _ Cz; rewrite conjgE (centP Cz) ?mulKg.
  by rewrite -{2}(Cfixa y Cy) -(Cfixa _ Cyx) -!conjMg -conjgC.
rewrite /(_ <| _) sub1G norm1 !subsetT /= quotient_cents2r //.
by rewrite (sameP trivgP commG1P) centsC subsetIr.
Qed.

Lemma not_dvdn_partn1: forall n p,
  0 < n -> prime p -> ~ (p %| n) -> n`_p = 1%N.
Proof.
move=> n p npos pr; move/negP=> nd.
by rewrite p_part lognE npos pr //= (negbTE nd).
Qed.

Lemma divp_pgroup_p: forall G: {group T}, forall p d, 1 < d -> prime p ->
  p.-group G -> d %| #|G| -> pdiv d = p.
Proof.
move=> G p d lt1d pr; move/pgroupP=> pG dG; apply/eqP; apply: pG.
  exact: prime_pdiv.
exact: dvdn_trans (dvdn_pdiv _) dG.
Qed.

Lemma card_pgroup_p: forall (G : {group T}) p,
  prime p -> p.-group G -> #|G| = #|G|`_p.
Proof. by move=> G p _ pG; rewrite part_pnat. Qed.

Lemma dvdn_sub_primes: forall d n: nat, 0 < n ->
  d %| n -> {subset primes d <= primes n}.
Proof.
move=> d n lt0n dvd m; rewrite !mem_primes lt0n; case/and3P=> -> _ /= dvm.
exact: dvdn_trans dvd.

Qed.

Lemma pgroup_coprime: forall A H : {group T}, forall p : nat, prime p ->
  p.-group A ->  ~ p %| #|H| -> coprime #|A| #|H|.
Proof.
move=> A H p pr; case/p_natP=> // k ->; move/negP; rewrite -prime_coprime //.
exact: coprime_expl.
Qed.

Lemma pgroup_quotient_normal_inv : forall A G H : {group T}, forall p : nat,
  prime p -> p.-group A -> A \subset G -> H <| G -> ~ p %| #|H| ->
  forall x, x \in 'N(H) -> x \in G -> coset H x \in 'N(A / H) ->
  x \in 'N_G(A) * H.
Proof.
move=> A G H p pr pg AsubG normH pndvdn x Nx Gx xbin.
suff exz: exists2 z, z \in A * H & A :^ x :=: A :^ z.
  case exz=> z; case/imset2P=> a y ain yin  ->.
  rewrite //= conjsgM (conjsgE _ a) rcoset_id // lcoset_id ?groupVr // => eqyx.
  rewrite -(mulgKV y x) mem_imset2 //.
  have yinG: y \in G by apply: (subsetP (normal_sub normH) _ yin).
  rewrite inE groupM ?groupVr //=.
  by apply/normP; rewrite conjsgM eqyx conjsgK.
rewrite -norm_mulgenEl; last by apply: (subset_trans AsubG (normal_norm normH)).
suff sylowA: p.-Sylow(A <*> H) A.
  apply: (Sylow_trans sylowA).
  suff xnormAH : x \in 'N(A <*> H) by rewrite /= -(normP xnormAH) pHallJ2.
  have nAH : A \subset 'N(H) by apply: subset_trans (normal_norm normH).
  rewrite mulgenC norm_mulgenEr // -quotientK //.
  by rewrite (subsetP (morphpre_norm _ _)) ?mem_morphpre.
rewrite pHallE sub_gen ?subsetUl //= norm_mulgenEl; last by apply: (subset_trans AsubG (normal_norm normH)).
have co: coprime #|A| #|H| by apply: (pgroup_coprime pr).
rewrite coprime_cardMg // partn_mul ?muln_gt0 ?cardG_gt0 //=.
rewrite (@not_dvdn_partn1 #|H|); rewrite //=; last by apply: cardG_gt0.
by rewrite muln1; apply/eqP; apply: card_pgroup_p.
Qed.

Lemma pgroup_quotient_normal : forall A G H: {group T}, forall p:nat, prime p ->
    p.-group A -> A \subset G -> H <| G -> ~ p %| #|H| ->
  'N_G(A) / H = 'N_(G / H)(A / H).
move => A G H p pr pgroupA AsubG normH co.
apply/eqP; rewrite eqEsubset subsetI morphimS ?subsetIl //= morphim_norms ?morphimS ?subsetIr //=.
apply/subsetP=> xb; case/setIP; rewrite quotientE; case /morphimP=> x Nx Gx -> xbin.
rewrite -quotient_mulg; apply/imsetP; exists x; rewrite // inE Nx /=.
apply: (pgroup_quotient_normal_inv pr); rewrite //.
Qed.

Lemma pgroup_quotient_central : forall A G H: {group T}, forall p:nat, prime p ->
    p.-group A -> A \subset G -> H <| G -> ~ p %| #|H| ->
  'C_G(A) / H = 'C_(G / H)(A / H).
Proof.
move => A G H p pr pgroupA AsubG normH pndivn.
apply/eqP; rewrite eqEsubset subsetI morphimS ?subsetIl //=.
rewrite morphim_cents ?morphimS ?subsetIr //=.
apply/subsetP=> xb; case/setIP.
rewrite quotientE; case /morphimP=> x Nx Gx -> xbin.
rewrite -quotient_mulg; apply/imsetP; exists x; rewrite // inE Nx /=.
have nHA: A \subset 'N(H) by apply: subset_trans AsubG _; case/andP: normH.
suff subC: coset H @*^-1 'C_(G / H)(A / H) :&: 'N_G(A) \subset 'C_G(A).
  apply: (subsetP (mulSg _ subC)); rewrite group_modr ?in_setI; rewrite ?Nx //=.
  - rewrite inE in_setI xbin -andbA /=; apply/andP; split.
    by apply/imsetP; exists x; rewrite ?in_setI ?Nx.
    by apply: (pgroup_quotient_normal_inv pr); rewrite //; apply: (subsetP (cent_sub _)).
  - have lem: H \subset coset H @*^-1 ('C_G(A) / H).
      by rewrite morphimK ?ker_coset ?mulG_subl ?(subset_trans (subsetIl _ _)) ?normal_norm.
    apply: (subset_trans lem); apply: morphpreS.
    by rewrite subsetI morphimS ?subsetIl ?morphim_cents ?subsetIr.
rewrite subsetI {1}subIset ?subsetIl ?orbT {x Nx Gx xbin}//=.
have co: coprime #|H| #|A| by rewrite coprime_sym; apply: (pgroup_coprime pr).
rewrite (sameP commG1P trivgP) -(coprime_TIg co).
rewrite subsetI commg_subr /= {2}setIA subsetIr andbT.
apply: subset_trans (commSg _ (subsetIl _ _)) _.
by rewrite -quotient_cents2 ?subsetIl // cosetpreK subsetIr.
Qed.

End coprime_comm.


Require Export SystemFR.Judgments.
Require Export SystemFR.AnnotatedTactics.
Require Export SystemFR.ErasedIte.

Lemma annotated_reducible_T_ite:
  forall Θ Γ b t1 t2 T1 T2 x,
    ~(x ∈ fv_context Γ) ->
    ~(x ∈ fv b) ->
    ~(x ∈ fv t1) ->
    ~(x ∈ fv t2) ->
    ~(x ∈ fv T1) ->
    ~(x ∈ fv T2) ->
    ~(x ∈ Θ) ->
    wf t1 0 ->
    wf t2 0 ->
    wf T1 0 ->
    wf T2 0 ->
    subset (fv b) (support Γ) ->
    subset (fv t1) (support Γ) ->
    subset (fv t2) (support Γ) ->
    subset (fv T1) (support Γ) ->
    subset (fv T2) (support Γ) ->
    [[ Θ; Γ ⊨ b : T_bool ]] ->
    [[ Θ; (x, T_equiv b ttrue) :: Γ ⊨ t1 : T1 ]] ->
    [[ Θ; (x, T_equiv b tfalse) :: Γ ⊨ t2 : T2 ]] ->
    [[ Θ; Γ ⊨ ite b t1 t2 : T_ite b T1 T2 ]].
Proof.
  intros; apply open_reducible_T_ite with x;
    repeat step;
    side_conditions.
Qed.


Require Export SystemFR.Untangle.
Require Export SystemFR.InferApp.

Lemma open_subnormwiden_helper:
  forall Θ Γ T1 T1' T2,
    widen T1 T1' ->
    [ Θ; Γ ⊨ T1' <: T2 ] ->
    [ Θ; Γ ⊨ T1  <: T2 ].
Proof.
  intros; eauto using widen_open_subtype, open_subtype_trans.
Qed.

Lemma open_subnormwiden:
  forall Γ T1 T1' T2,
    widen T1 T1' ->
    [ Γ ⊫ T1' <: T2 ] ->
    [ Γ ⊫ T1  <: T2 ].
Proof.
  eauto using open_subnormwiden_helper.
Qed.

Lemma open_subnorm:
  forall Γ T1 T1' T1'' T2 T2' T2'',
    [ Γ ⊫ T1 = T1' ] ->
    [ Γ ⊫ T2 = T2' ] ->
    untangle Γ T1' T1'' ->
    untangle Γ T2' T2'' ->
    [ Γ ⊫ T1'' <: T2'' ] ->
    [ Γ ⊫ T1 <: T2 ].
Proof.
  intros.
  eapply open_subtype_trans; eauto using open_equivalent_subtype.
  eapply open_subtype_trans; eauto using open_equivalent_subtype, untangle_open_equivalent_types.
  eapply open_subtype_trans; eauto.
  eapply open_subtype_trans; eauto using open_equivalent_subtype_back.
  eauto using open_equivalent_subtype_back, untangle_open_equivalent_types.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj15synthconj6 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (mult (mult lv0 (Succ lv1)) lv2) (plus (mult lv1 (mult lv0 lv2)) (mult lv0 lv2))).
Admitted.
QuickChick conj15synthconj6.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Isomorphism.
Require Import Category.Theory.Functor.
Require Import Category.Theory.Natural.Transformation.
Require Import Category.Theory.Adjunction.
Require Import Category.Instance.Fun.
Require Import Category.Instance.Sets.

Generalizable All Variables.

Section KanExtension.

Context {A : Category}.
Context {B : Category}.
Context {F : A ⟶ B}.
Context {C : Category}.

Program Definition Induced : ([B, C]) ⟶ ([A, C]) := {|
  fobj := fun G => G ◯ F;
  fmap := fun _ _ f => {| transform := fun z => transform[f] (F z) |}
|}.
Next Obligation. apply naturality. Qed.
Next Obligation. apply naturality_sym. Qed.

Class RightKan := {
  (* jww (2017-06-09): Rename this to ran_functor, RightKan to Ran, and then a
     coercion from Ran to functor? *)
  Ran : [A, C] ⟶ [B, C];

  ran_adjoint : Induced ⊣ Ran
}.

Class LocalRightKan (X : A ⟶ C) := {
  LocalRan : B ⟶ C;

  ran_transform : LocalRan ◯ F ⟹ X;

  ump_ran (M : B ⟶ C) (μ : M ◯ F ⟹ X) :
    (∃! δ, μ ≈ ran_transform ∙ δ ⊲ F);
}.

(* Wikipedia: "There is also a local definition of 'the Kan extension of a
   given functor F along p' which can exist even if the entire functor defined
   above [global Kan extension] does not. This is a generalization of the fact
   that a particular diagram of shape C can have a limit even if not every
   such diagram does. It is also a special case of the fact discussed at
   adjoint functor that an adjoint functor can fail to exist completely, but
   may still be partially defined. If the local Kan extension of every single
   functor exists for some given p : C → C' and D, then these local Kan
   extensions fit together to define a functor which is the global Kan
   extension." *)

#[export] Program Instance RightKan_to_LocalRightKan {R : RightKan} (X : A ⟶ C) :
  LocalRightKan X := {|
  LocalRan := Ran X;
  ran_transform :=
    let adj_from := from (@adj _ _ _ _ ran_adjoint (Ran X) X) nat_id in
    {| transform  := transform[adj_from]
     ; naturality := naturality[adj_from] |}
|}.
Next Obligation.
  srewrite_r (naturality[from (@adj _ _ _ _ ran_adjoint (Ran X) X) nat_id]).
  reflexivity.
Qed.
Next Obligation.
  exists (to (@adj _ _ _ _ (@ran_adjoint R) M X) μ).
  - intros.
    spose (@from_adj_nat_l _ _ _ _ ran_adjoint) as X0.
    rewrite <- X0; clear X0.
    spose (@iso_from_to _ _ _ (@adj _ _ _ _ ran_adjoint M X) μ x) as X0.
    unfold nat_compose; simpl in *.
    rewrites.
    sapply (proper_morphism (@from _ _ _ (@adj _ _ _ _ ran_adjoint M X))).
    simpl; intros; cat.
  - intros.
    assert (μ ≈ (adj[ran_adjoint])⁻¹ v). {
      intro.
      specialize (X0 x).
      rewrite X0; clear X0.
      srewrite_r (@from_adj_nat_l _ _ _ _ ran_adjoint).
      destruct (adj[ran_adjoint]); simpl in *.
      destruct from; simpl in *.
      apply proper_morphism; simpl.
      now apply nat_id_left.
    }
    clear -X1.
    destruct (adj[ran_adjoint]); simpl in *.
    intros.
    rewrite <- (iso_to_from v).
    destruct to; simpl in *.
    apply proper_morphism.
    simpl.
    now apply X1.
Qed.

Class LeftKan := {
  Lan : [A, C] ⟶ [B, C];

  lan_adjoint : Lan ⊣ Induced
}.

Class LocalLeftKan (X : A ⟶ C) := {
  LocalLan : B ⟶ C;

  lan_transform : X ⟹ LocalLan ◯ F;

  ump_lan (M : B ⟶ C) (ε : X ⟹ M ◯ F) :
    ∃! δ, ε ≈ δ ⊲ F ∙ lan_transform;
}.

#[export] Program Instance LeftKan_to_LocalLeftKan {R : LeftKan} (X : A ⟶ C) :
  LocalLeftKan X := {|
  LocalLan := Lan X;
  lan_transform :=
    let adj_to := to (@adj _ _ _ _ lan_adjoint X (Lan X)) nat_id in
    {| transform  := transform[adj_to]
     ; naturality := naturality[adj_to] |}
|}.
Next Obligation.
  srewrite_r (naturality[to (@adj _ _ _ _ lan_adjoint X (Lan X)) nat_id]).
  reflexivity.
Qed.
Next Obligation.
  exists (from (@adj _ _ _ _ (@lan_adjoint R) X M) ε).
  - intros.
    spose (@to_adj_nat_r _ _ _ _ lan_adjoint) as X0.
    rewrite <- X0; clear X0.
    spose (@iso_to_from _ _ _ (@adj _ _ _ _ lan_adjoint X M) ε x) as X0.
    unfold nat_compose; simpl in *.
    rewrites.
    sapply (proper_morphism (@to _ _ _ (@adj _ _ _ _ lan_adjoint X M))).
    simpl; intros; cat.
  - intros.
    assert (ε ≈ (to adj[lan_adjoint]) v). {
      intro.
      specialize (X0 x).
      rewrite X0; clear X0.
      srewrite_r (@to_adj_nat_r _ _ _ _ lan_adjoint).
      destruct (to adj[lan_adjoint]); simpl in *.
      apply proper_morphism; simpl.
      now apply nat_id_right.
    }
    clear -X1.
    destruct (adj[lan_adjoint]); simpl in *.
    intros.
    rewrite <- (iso_from_to v).
    destruct from; simpl in *.
    apply proper_morphism.
    simpl.
    now apply X1.
Qed.

End KanExtension.

Arguments RightKan {_ _} F _.
Arguments Ran {_ _} F {_ _}.

Arguments LocalRightKan {_ _} F {_} _.
Arguments LocalRan {_ _} F {_} _ {_}.

Arguments LeftKan {_ _} F _.
Arguments Lan {_ _} F {_ _}.

Arguments LocalLeftKan {_ _} F {_} _.
Arguments LocalLan {_ _} F {_} _ {_}.

(** From “All Concepts are Kan Extensions”, by Marina Christina Lehner:

    "A functor preserves a Kan extension when composing then extending is
    equivalent to extending then composing." *)

Definition preserves_left_Kan `(L : E ⟶ F) :=
  ∀ C D (G : C ⟶ E) (K : C ⟶ D)
    `(!LeftKan K E) `(!LeftKan K F), L ◯ Lan K G ≈ Lan K (L ◯ G).

Definition preserves_right_Kan `(R : E ⟶ F) :=
  ∀ C D (G : C ⟶ E) (K : C ⟶ D)
    `(!RightKan K E) `(!RightKan K F), R ◯ Ran K G ≈ Ran K (R ◯ G).

(** "We show that left adjoints preserve left Kan extensions, while right
    adjoints will preserve right adjoints [sic]. These connections with
    adjoints run deeper. We will show an adjoint functor theorem which says
    the existence of an adjoint is conditional on a functor having and
    preserving certain Kan extensions." *)

(** jww (2021-08-07): TODO *)
Theorem left_adjoint_impl `(L : C ⟶ D) :
  ∀ R : D ⟶ C, L ⊣ R ->
  ∀ {E} (G : E ⟶ C) (H : E ⟶ D),
    [[[E,D]]](L ◯ G, H) ≊ [[[E,C]]](G, R ◯ H).
Proof.
  intros.
  simpl.
  isomorphism; simpl.
  - construct.
    + transform.
      * intros.
        apply X; simpl.
        now apply X0.
      * simpl.
        rewrite <- to_adj_nat_l.
        rewrite <- to_adj_nat_r.
        now srewrite (naturality[X0]).
      * simpl.
        rewrite <- to_adj_nat_l.
        rewrite <- to_adj_nat_r.
        now srewrite (naturality[X0]).
    + simpl.
      proper.
      apply to_adj_respects.
      now apply X0.
  - construct.
    + transform.
      * intros.
        apply X; simpl.
        now apply X0.
      * simpl.
        rewrite <- from_adj_nat_l.
        rewrite <- from_adj_nat_r.
        now srewrite (naturality[X0]).
      * simpl.
        rewrite <- from_adj_nat_l.
        rewrite <- from_adj_nat_r.
        now srewrite (naturality[X0]).
    + simpl.
      proper.
      apply from_adj_respects.
      now apply X0.
  - simpl.
    now apply from_adj_comp_law.
  - simpl.
    now apply to_adj_comp_law.
Qed.

Theorem left_adjoints_preserve `(L : C ⟶ D) :
  ∀ R : D ⟶ C, L ⊣ R → preserves_left_Kan L.
Proof.
  intros.
  construct.
  - isomorphism.
    + apply X; simpl.
      rewrite <- fobj_Compose.
      apply LeftKan0; simpl.
      spose (left_adjoint_impl _ _ X G (Lan K (L ◯ G) ◯ K)) as X0.
      transitivity (R ◯ (Lan K (L ◯ G) ◯ K)).
      * apply (to X0); simpl.
        apply LeftKan1; simpl.
        exact nat_id.
      * now apply fun_comp_assoc.
    + rewrite <- fobj_Compose.
      apply LeftKan1; simpl.
      spose (left_adjoint_impl _ _ X G (L ◯ Lan K G ◯ K)) as X0.
      apply X0; simpl; clear X0.
      transitivity (R ◯ L ◯ fobj[Lan _] G ◯ K). {
        apply LeftKan0; simpl.
        transform.
        - intros.
          apply unit.
        - simpl.
          unfold unit.
          rewrite <- to_adj_nat_l.
          rewrite <- to_adj_nat_r.
          rewrite id_left, id_right.
          reflexivity.
        - simpl.
          unfold unit.
          rewrite <- to_adj_nat_l.
          rewrite <- to_adj_nat_r.
          rewrite id_left, id_right.
          reflexivity.
      }
      pose proof (@fun_comp_assoc_sym _ _ _ _ R L (Lan K G ◯ K)).
      pose proof (@fun_comp_assoc_sym _ _ _ _ R (L ◯ Lan K G) K).
      pose proof (@fun_comp_assoc_sym _ _ _ _ (R ◯ L) (Lan K G) K).
      transitivity ((R ◯ L) ◯ ((fobj[Lan _] G) ◯ K)); auto.
      transitivity (R ◯ (L ◯ ((fobj[Lan _] G) ◯ K))); auto.
      transitivity (R ◯ ((L ◯ (fobj[Lan _] G)) ◯ K)).
      * apply whisker_left.
        apply fun_comp_assoc.
      * exact nat_id.
    + simpl.
      admit.
    + simpl.
      admit.
  - simpl.
    admit.
Abort.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2013 Sylvie Boldo
#<br />#
Copyright (C) 2010-2013 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Missing definitions/lemmas *)
Require Export Reals.
Require Export ZArith.
Require Export Fcore_Zaux.

Section Rmissing.

(** About R *)
Theorem Rle_0_minus :
  forall x y, (x <= y)%R -> (0 <= y - x)%R.
Proof.
intros.
apply Rge_le.
apply Rge_minus.
now apply Rle_ge.
Qed.

Theorem Rabs_eq_Rabs :
  forall x y : R,
  Rabs x = Rabs y -> x = y \/ x = Ropp y.
Proof.
intros x y H.
unfold Rabs in H.
destruct (Rcase_abs x) as [_|_].
assert (H' := f_equal Ropp H).
rewrite Ropp_involutive in H'.
rewrite H'.
destruct (Rcase_abs y) as [_|_].
left.
apply Ropp_involutive.
now right.
rewrite H.
now destruct (Rcase_abs y) as [_|_] ; [right|left].
Qed.

Theorem Rabs_minus_le:
  forall x y : R,
  (0 <= y)%R -> (y <= 2*x)%R ->
  (Rabs (x-y) <= x)%R.
Proof.
intros x y Hx Hy.
unfold Rabs; case (Rcase_abs (x - y)); intros H.
apply Rplus_le_reg_l with x; ring_simplify; assumption.
apply Rplus_le_reg_l with (-x)%R; ring_simplify.
auto with real.
Qed.

Theorem Rplus_eq_reg_r :
  forall r r1 r2 : R,
  (r1 + r = r2 + r)%R -> (r1 = r2)%R.
Proof.
intros r r1 r2 H.
apply Rplus_eq_reg_l with r.
now rewrite 2!(Rplus_comm r).
Qed.

Theorem Rplus_le_reg_r :
  forall r r1 r2 : R,
  (r1 + r <= r2 + r)%R -> (r1 <= r2)%R.
Proof.
intros.
apply Rplus_le_reg_l with r.
now rewrite 2!(Rplus_comm r).
Qed.

Theorem Rmult_lt_reg_r :
  forall r r1 r2 : R, (0 < r)%R ->
  (r1 * r < r2 * r)%R -> (r1 < r2)%R.
Proof.
intros.
apply Rmult_lt_reg_l with r.
exact H.
now rewrite 2!(Rmult_comm r).
Qed.

Theorem Rmult_le_reg_r :
  forall r r1 r2 : R, (0 < r)%R ->
  (r1 * r <= r2 * r)%R -> (r1 <= r2)%R.
Proof.
intros.
apply Rmult_le_reg_l with r.
exact H.
now rewrite 2!(Rmult_comm r).
Qed.

Theorem Rmult_eq_reg_r :
  forall r r1 r2 : R, (r1 * r)%R = (r2 * r)%R ->
  r <> 0%R -> r1 = r2.
Proof.
intros r r1 r2 H1 H2.
apply Rmult_eq_reg_l with r.
now rewrite 2!(Rmult_comm r).
exact H2.
Qed.

Theorem Rmult_minus_distr_r :
  forall r r1 r2 : R,
  ((r1 - r2) * r = r1 * r - r2 * r)%R.
Proof.
intros r r1 r2.
rewrite <- 3!(Rmult_comm r).
apply Rmult_minus_distr_l.
Qed.

Lemma Rmult_neq_reg_r: forall  r1 r2 r3:R, (r2 * r1 <> r3 * r1)%R -> r2 <> r3.
intros r1 r2 r3 H1 H2.
apply H1; rewrite H2; ring.
Qed.

Lemma Rmult_neq_compat_r: forall  r1 r2 r3:R, (r1 <> 0)%R -> (r2 <> r3)%R
   -> (r2 *r1 <> r3*r1)%R.
intros r1 r2 r3 H H1 H2.
now apply H1, Rmult_eq_reg_r with r1.
Qed.

Theorem Rmult_min_distr_r :
  forall r r1 r2 : R,
  (0 <= r)%R ->
  (Rmin r1 r2 * r)%R = Rmin (r1 * r) (r2 * r).
Proof.
intros r r1 r2 [Hr|Hr].
unfold Rmin.
destruct (Rle_dec r1 r2) as [H1|H1] ;
  destruct (Rle_dec (r1 * r) (r2 * r)) as [H2|H2] ;
  try easy.
apply (f_equal (fun x => Rmult x r)).
apply Rle_antisym.
exact H1.
apply Rmult_le_reg_r with (1 := Hr).
apply Rlt_le.
now apply Rnot_le_lt.
apply Rle_antisym.
apply Rmult_le_compat_r.
now apply Rlt_le.
apply Rlt_le.
now apply Rnot_le_lt.
exact H2.
rewrite <- Hr.
rewrite 3!Rmult_0_r.
unfold Rmin.
destruct (Rle_dec 0 0) as [H0|H0].
easy.
elim H0.
apply Rle_refl.
Qed.

Theorem Rmult_min_distr_l :
  forall r r1 r2 : R,
  (0 <= r)%R ->
  (r * Rmin r1 r2)%R = Rmin (r * r1) (r * r2).
Proof.
intros r r1 r2 Hr.
rewrite 3!(Rmult_comm r).
now apply Rmult_min_distr_r.
Qed.

Theorem exp_le :
  forall x y : R,
  (x <= y)%R -> (exp x <= exp y)%R.
Proof.
intros x y [H|H].
apply Rlt_le.
now apply exp_increasing.
rewrite H.
apply Rle_refl.
Qed.

Theorem Rinv_lt :
  forall x y,
  (0 < x)%R -> (x < y)%R -> (/y < /x)%R.
Proof.
intros x y Hx Hxy.
apply Rinv_lt_contravar.
apply Rmult_lt_0_compat.
exact Hx.
now apply Rlt_trans with x.
exact Hxy.
Qed.

Theorem Rinv_le :
  forall x y,
  (0 < x)%R -> (x <= y)%R -> (/y <= /x)%R.
Proof.
intros x y Hx Hxy.
apply Rle_Rinv.
exact Hx.
now apply Rlt_le_trans with x.
exact Hxy.
Qed.

Theorem sqrt_ge_0 :
  forall x : R,
  (0 <= sqrt x)%R.
Proof.
intros x.
unfold sqrt.
destruct (Rcase_abs x) as [_|H].
apply Rle_refl.
apply Rsqrt_positivity.
Qed.

Theorem Rabs_le :
  forall x y,
  (-y <= x <= y)%R -> (Rabs x <= y)%R.
Proof.
intros x y (Hyx,Hxy).
unfold Rabs.
case Rcase_abs ; intros Hx.
apply Ropp_le_cancel.
now rewrite Ropp_involutive.
exact Hxy.
Qed.

Theorem Rabs_le_inv :
  forall x y,
  (Rabs x <= y)%R -> (-y <= x <= y)%R.
Proof.
intros x y Hxy.
split.
apply Rle_trans with (- Rabs x)%R.
now apply Ropp_le_contravar.
apply Ropp_le_cancel.
rewrite Ropp_involutive, <- Rabs_Ropp.
apply RRle_abs.
apply Rle_trans with (2 := Hxy).
apply RRle_abs.
Qed.

Theorem Rabs_ge :
  forall x y,
  (y <= -x \/ x <= y)%R -> (x <= Rabs y)%R.
Proof.
intros x y [Hyx|Hxy].
apply Rle_trans with (-y)%R.
apply Ropp_le_cancel.
now rewrite Ropp_involutive.
rewrite <- Rabs_Ropp.
apply RRle_abs.
apply Rle_trans with (1 := Hxy).
apply RRle_abs.
Qed.

Theorem Rabs_ge_inv :
  forall x y,
  (x <= Rabs y)%R -> (y <= -x \/ x <= y)%R.
Proof.
intros x y.
unfold Rabs.
case Rcase_abs ; intros Hy Hxy.
left.
apply Ropp_le_cancel.
now rewrite Ropp_involutive.
now right.
Qed.

Theorem Rabs_lt :
  forall x y,
  (-y < x < y)%R -> (Rabs x < y)%R.
Proof.
intros x y (Hyx,Hxy).
now apply Rabs_def1.
Qed.

Theorem Rabs_lt_inv :
  forall x y,
  (Rabs x < y)%R -> (-y < x < y)%R.
Proof.
intros x y H.
now split ; eapply Rabs_def2.
Qed.

Theorem Rabs_gt :
  forall x y,
  (y < -x \/ x < y)%R -> (x < Rabs y)%R.
Proof.
intros x y [Hyx|Hxy].
rewrite <- Rabs_Ropp.
apply Rlt_le_trans with (Ropp y).
apply Ropp_lt_cancel.
now rewrite Ropp_involutive.
apply RRle_abs.
apply Rlt_le_trans with (1 := Hxy).
apply RRle_abs.
Qed.

Theorem Rabs_gt_inv :
  forall x y,
  (x < Rabs y)%R -> (y < -x \/ x < y)%R.
Proof.
intros x y.
unfold Rabs.
case Rcase_abs ; intros Hy Hxy.
left.
apply Ropp_lt_cancel.
now rewrite Ropp_involutive.
now right.
Qed.

End Rmissing.

Section Z2R.

(** Z2R function (Z -> R) *)
Fixpoint P2R (p : positive) :=
  match p with
  | xH => 1%R
  | xO xH => 2%R
  | xO t => (2 * P2R t)%R
  | xI xH => 3%R
  | xI t => (1 + 2 * P2R t)%R
  end.

Definition Z2R n :=
  match n with
  | Zpos p => P2R p
  | Zneg p => Ropp (P2R p)
  | Z0 => R0
  end.

Theorem P2R_INR :
  forall n, P2R n = INR (nat_of_P n).
Proof.
induction n ; simpl ; try (
  rewrite IHn ;
  rewrite <- (mult_INR 2) ;
  rewrite <- (nat_of_P_mult_morphism 2) ;
  change (2 * n)%positive with (xO n)).
(* xI *)
rewrite (Rplus_comm 1).
change (nat_of_P (xO n)) with (Pmult_nat n 2).
case n ; intros ; simpl ; try apply refl_equal.
case (Pmult_nat p 4) ; intros ; try apply refl_equal.
rewrite Rplus_0_l.
apply refl_equal.
apply Rplus_comm.
(* xO *)
case n ; intros ; apply refl_equal.
(* xH *)
apply refl_equal.
Qed.

Theorem Z2R_IZR :
  forall n, Z2R n = IZR n.
Proof.
intro.
case n ; intros ; simpl.
apply refl_equal.
apply P2R_INR.
apply Ropp_eq_compat.
apply P2R_INR.
Qed.

Theorem Z2R_opp :
  forall n, Z2R (-n) = (- Z2R n)%R.
Proof.
intros.
repeat rewrite Z2R_IZR.
apply Ropp_Ropp_IZR.
Qed.

Theorem Z2R_plus :
  forall m n, (Z2R (m + n) = Z2R m + Z2R n)%R.
Proof.
intros.
repeat rewrite Z2R_IZR.
apply plus_IZR.
Qed.

Theorem minus_IZR :
  forall n m : Z,
  IZR (n - m) = (IZR n - IZR m)%R.
Proof.
intros.
unfold Zminus.
rewrite plus_IZR.
rewrite Ropp_Ropp_IZR.
apply refl_equal.
Qed.

Theorem Z2R_minus :
  forall m n, (Z2R (m - n) = Z2R m - Z2R n)%R.
Proof.
intros.
repeat rewrite Z2R_IZR.
apply minus_IZR.
Qed.

Theorem Z2R_mult :
  forall m n, (Z2R (m * n) = Z2R m * Z2R n)%R.
Proof.
intros.
repeat rewrite Z2R_IZR.
apply mult_IZR.
Qed.

Theorem le_Z2R :
  forall m n, (Z2R m <= Z2R n)%R -> (m <= n)%Z.
Proof.
intros m n.
repeat rewrite Z2R_IZR.
apply le_IZR.
Qed.

Theorem Z2R_le :
  forall m n, (m <= n)%Z -> (Z2R m <= Z2R n)%R.
Proof.
intros m n.
repeat rewrite Z2R_IZR.
apply IZR_le.
Qed.

Theorem lt_Z2R :
  forall m n, (Z2R m < Z2R n)%R -> (m < n)%Z.
Proof.
intros m n.
repeat rewrite Z2R_IZR.
apply lt_IZR.
Qed.

Theorem Z2R_lt :
  forall m n, (m < n)%Z -> (Z2R m < Z2R n)%R.
Proof.
intros m n.
repeat rewrite Z2R_IZR.
apply IZR_lt.
Qed.

Theorem Z2R_le_lt :
  forall m n p, (m <= n < p)%Z -> (Z2R m <= Z2R n < Z2R p)%R.
Proof.
intros m n p (H1, H2).
split.
now apply Z2R_le.
now apply Z2R_lt.
Qed.

Theorem le_lt_Z2R :
  forall m n p, (Z2R m <= Z2R n < Z2R p)%R -> (m <= n < p)%Z.
Proof.
intros m n p (H1, H2).
split.
now apply le_Z2R.
now apply lt_Z2R.
Qed.

Theorem eq_Z2R :
  forall m n, (Z2R m = Z2R n)%R -> (m = n)%Z.
Proof.
intros m n H.
apply eq_IZR.
now rewrite <- 2!Z2R_IZR.
Qed.

Theorem neq_Z2R :
  forall m n, (Z2R m <> Z2R n)%R -> (m <> n)%Z.
Proof.
intros m n H H'.
apply H.
now apply f_equal.
Qed.

Theorem Z2R_neq :
  forall m n, (m <> n)%Z -> (Z2R m <> Z2R n)%R.
Proof.
intros m n.
repeat rewrite Z2R_IZR.
apply IZR_neq.
Qed.

Theorem Z2R_abs :
  forall z, Z2R (Zabs z) = Rabs (Z2R z).
Proof.
intros.
repeat rewrite Z2R_IZR.
now rewrite Rabs_Zabs.
Qed.

End Z2R.

(** Decidable comparison on reals *)
Section Rcompare.

Definition Rcompare x y :=
  match total_order_T x y with
  | inleft (left _) => Lt
  | inleft (right _) => Eq
  | inright _ => Gt
  end.

Inductive Rcompare_prop (x y : R) : comparison -> Prop :=
  | Rcompare_Lt_ : (x < y)%R -> Rcompare_prop x y Lt
  | Rcompare_Eq_ : x = y -> Rcompare_prop x y Eq
  | Rcompare_Gt_ : (y < x)%R -> Rcompare_prop x y Gt.

Theorem Rcompare_spec :
  forall x y, Rcompare_prop x y (Rcompare x y).
Proof.
intros x y.
unfold Rcompare.
now destruct (total_order_T x y) as [[H|H]|H] ; constructor.
Qed.

Global Opaque Rcompare.

Theorem Rcompare_Lt :
  forall x y,
  (x < y)%R -> Rcompare x y = Lt.
Proof.
intros x y H.
case Rcompare_spec ; intro H'.
easy.
rewrite H' in H.
elim (Rlt_irrefl _ H).
elim (Rlt_irrefl x).
now apply Rlt_trans with y.
Qed.

Theorem Rcompare_Lt_inv :
  forall x y,
  Rcompare x y = Lt -> (x < y)%R.
Proof.
intros x y.
now case Rcompare_spec.
Qed.

Theorem Rcompare_not_Lt :
  forall x y,
  (y <= x)%R -> Rcompare x y <> Lt.
Proof.
intros x y H1 H2.
apply Rle_not_lt with (1 := H1).
now apply Rcompare_Lt_inv.
Qed.

Theorem Rcompare_not_Lt_inv :
  forall x y,
  Rcompare x y <> Lt -> (y <= x)%R.
Proof.
intros x y H.
apply Rnot_lt_le.
contradict H.
now apply Rcompare_Lt.
Qed.

Theorem Rcompare_Eq :
  forall x y,
  x = y -> Rcompare x y = Eq.
Proof.
intros x y H.
rewrite H.
now case Rcompare_spec ; intro H' ; try elim (Rlt_irrefl _ H').
Qed.

Theorem Rcompare_Eq_inv :
  forall x y,
  Rcompare x y = Eq -> x = y.
Proof.
intros x y.
now case Rcompare_spec.
Qed.

Theorem Rcompare_Gt :
  forall x y,
  (y < x)%R -> Rcompare x y = Gt.
Proof.
intros x y H.
case Rcompare_spec ; intro H'.
elim (Rlt_irrefl x).
now apply Rlt_trans with y.
rewrite H' in H.
elim (Rlt_irrefl _ H).
easy.
Qed.

Theorem Rcompare_Gt_inv :
  forall x y,
  Rcompare x y = Gt -> (y < x)%R.
Proof.
intros x y.
now case Rcompare_spec.
Qed.

Theorem Rcompare_not_Gt :
  forall x y,
  (x <= y)%R -> Rcompare x y <> Gt.
Proof.
intros x y H1 H2.
apply Rle_not_lt with (1 := H1).
now apply Rcompare_Gt_inv.
Qed.

Theorem Rcompare_not_Gt_inv :
  forall x y,
  Rcompare x y <> Gt -> (x <= y)%R.
Proof.
intros x y H.
apply Rnot_lt_le.
contradict H.
now apply Rcompare_Gt.
Qed.

Theorem Rcompare_Z2R :
  forall x y, Rcompare (Z2R x) (Z2R y) = Zcompare x y.
Proof.
intros x y.
case Rcompare_spec ; intros H ; apply sym_eq.
apply Zcompare_Lt.
now apply lt_Z2R.
apply Zcompare_Eq.
now apply eq_Z2R.
apply Zcompare_Gt.
now apply lt_Z2R.
Qed.

Theorem Rcompare_sym :
  forall x y,
  Rcompare x y = CompOpp (Rcompare y x).
Proof.
intros x y.
destruct (Rcompare_spec y x) as [H|H|H].
now apply Rcompare_Gt.
now apply Rcompare_Eq.
now apply Rcompare_Lt.
Qed.

Theorem Rcompare_plus_r :
  forall z x y,
  Rcompare (x + z) (y + z) = Rcompare x y.
Proof.
intros z x y.
destruct (Rcompare_spec x y) as [H|H|H].
apply Rcompare_Lt.
now apply Rplus_lt_compat_r.
apply Rcompare_Eq.
now rewrite H.
apply Rcompare_Gt.
now apply Rplus_lt_compat_r.
Qed.

Theorem Rcompare_plus_l :
  forall z x y,
  Rcompare (z + x) (z + y) = Rcompare x y.
Proof.
intros z x y.
rewrite 2!(Rplus_comm z).
apply Rcompare_plus_r.
Qed.

Theorem Rcompare_mult_r :
  forall z x y,
  (0 < z)%R ->
  Rcompare (x * z) (y * z) = Rcompare x y.
Proof.
intros z x y Hz.
destruct (Rcompare_spec x y) as [H|H|H].
apply Rcompare_Lt.
now apply Rmult_lt_compat_r.
apply Rcompare_Eq.
now rewrite H.
apply Rcompare_Gt.
now apply Rmult_lt_compat_r.
Qed.

Theorem Rcompare_mult_l :
  forall z x y,
  (0 < z)%R ->
  Rcompare (z * x) (z * y) = Rcompare x y.
Proof.
intros z x y.
rewrite 2!(Rmult_comm z).
apply Rcompare_mult_r.
Qed.

Theorem Rcompare_middle :
  forall x d u,
  Rcompare (x - d) (u - x) = Rcompare x ((d + u) / 2).
Proof.
intros x d u.
rewrite <- (Rcompare_plus_r (- x / 2 - d / 2) x).
rewrite <- (Rcompare_mult_r (/2) (x - d)).
field_simplify (x + (- x / 2 - d / 2))%R.
now field_simplify ((d + u) / 2 + (- x / 2 - d / 2))%R.
apply Rinv_0_lt_compat.
now apply (Z2R_lt 0 2).
Qed.

Theorem Rcompare_half_l :
  forall x y, Rcompare (x / 2) y = Rcompare x (2 * y).
Proof.
intros x y.
rewrite <- (Rcompare_mult_r 2%R).
unfold Rdiv.
rewrite Rmult_assoc, Rinv_l, Rmult_1_r.
now rewrite Rmult_comm.
now apply (Z2R_neq 2 0).
now apply (Z2R_lt 0 2).
Qed.

Theorem Rcompare_half_r :
  forall x y, Rcompare x (y / 2) = Rcompare (2 * x) y.
Proof.
intros x y.
rewrite <- (Rcompare_mult_r 2%R).
unfold Rdiv.
rewrite Rmult_assoc, Rinv_l, Rmult_1_r.
now rewrite Rmult_comm.
now apply (Z2R_neq 2 0).
now apply (Z2R_lt 0 2).
Qed.

Theorem Rcompare_sqr :
  forall x y,
  (0 <= x)%R -> (0 <= y)%R ->
  Rcompare (x * x) (y * y) = Rcompare x y.
Proof.
intros x y Hx Hy.
destruct (Rcompare_spec x y) as [H|H|H].
apply Rcompare_Lt.
now apply Rsqr_incrst_1.
rewrite H.
now apply Rcompare_Eq.
apply Rcompare_Gt.
now apply Rsqr_incrst_1.
Qed.

Theorem Rmin_compare :
  forall x y,
  Rmin x y = match Rcompare x y with Lt => x | Eq => x | Gt => y end.
Proof.
intros x y.
unfold Rmin.
destruct (Rle_dec x y) as [[Hx|Hx]|Hx].
now rewrite Rcompare_Lt.
now rewrite Rcompare_Eq.
rewrite Rcompare_Gt.
easy.
now apply Rnot_le_lt.
Qed.

End Rcompare.

Section Rle_bool.

Definition Rle_bool x y :=
  match Rcompare x y with
  | Gt => false
  | _ => true
  end.

Inductive Rle_bool_prop (x y : R) : bool -> Prop :=
  | Rle_bool_true_ : (x <= y)%R -> Rle_bool_prop x y true
  | Rle_bool_false_ : (y < x)%R -> Rle_bool_prop x y false.

Theorem Rle_bool_spec :
  forall x y, Rle_bool_prop x y (Rle_bool x y).
Proof.
intros x y.
unfold Rle_bool.
case Rcompare_spec ; constructor.
now apply Rlt_le.
rewrite H.
apply Rle_refl.
exact H.
Qed.

Theorem Rle_bool_true :
  forall x y,
  (x <= y)%R -> Rle_bool x y = true.
Proof.
intros x y Hxy.
case Rle_bool_spec ; intros H.
apply refl_equal.
elim (Rlt_irrefl x).
now apply Rle_lt_trans with y.
Qed.

Theorem Rle_bool_false :
  forall x y,
  (y < x)%R -> Rle_bool x y = false.
Proof.
intros x y Hxy.
case Rle_bool_spec ; intros H.
elim (Rlt_irrefl x).
now apply Rle_lt_trans with y.
apply refl_equal.
Qed.

End Rle_bool.

Section Rlt_bool.

Definition Rlt_bool x y :=
  match Rcompare x y with
  | Lt => true
  | _ => false
  end.

Inductive Rlt_bool_prop (x y : R) : bool -> Prop :=
  | Rlt_bool_true_ : (x < y)%R -> Rlt_bool_prop x y true
  | Rlt_bool_false_ : (y <= x)%R -> Rlt_bool_prop x y false.

Theorem Rlt_bool_spec :
  forall x y, Rlt_bool_prop x y (Rlt_bool x y).
Proof.
intros x y.
unfold Rlt_bool.
case Rcompare_spec ; constructor.
exact H.
rewrite H.
apply Rle_refl.
now apply Rlt_le.
Qed.

Theorem negb_Rlt_bool :
  forall x y,
  negb (Rle_bool x y) = Rlt_bool y x.
Proof.
intros x y.
unfold Rlt_bool, Rle_bool.
rewrite Rcompare_sym.
now case Rcompare.
Qed.

Theorem negb_Rle_bool :
  forall x y,
  negb (Rlt_bool x y) = Rle_bool y x.
Proof.
intros x y.
unfold Rlt_bool, Rle_bool.
rewrite Rcompare_sym.
now case Rcompare.
Qed.

Theorem Rlt_bool_true :
  forall x y,
  (x < y)%R -> Rlt_bool x y = true.
Proof.
intros x y Hxy.
rewrite <- negb_Rlt_bool.
now rewrite Rle_bool_false.
Qed.

Theorem Rlt_bool_false :
  forall x y,
  (y <= x)%R -> Rlt_bool x y = false.
Proof.
intros x y Hxy.
rewrite <- negb_Rlt_bool.
now rewrite Rle_bool_true.
Qed.

End Rlt_bool.

Section Req_bool.

Definition Req_bool x y :=
  match Rcompare x y with
  | Eq => true
  | _ => false
  end.

Inductive Req_bool_prop (x y : R) : bool -> Prop :=
  | Req_bool_true_ : (x = y)%R -> Req_bool_prop x y true
  | Req_bool_false_ : (x <> y)%R -> Req_bool_prop x y false.

Theorem Req_bool_spec :
  forall x y, Req_bool_prop x y (Req_bool x y).
Proof.
intros x y.
unfold Req_bool.
case Rcompare_spec ; constructor.
now apply Rlt_not_eq.
easy.
now apply Rgt_not_eq.
Qed.

Theorem Req_bool_true :
  forall x y,
  (x = y)%R -> Req_bool x y = true.
Proof.
intros x y Hxy.
case Req_bool_spec ; intros H.
apply refl_equal.
contradict H.
exact Hxy.
Qed.

Theorem Req_bool_false :
  forall x y,
  (x <> y)%R -> Req_bool x y = false.
Proof.
intros x y Hxy.
case Req_bool_spec ; intros H.
contradict Hxy.
exact H.
apply refl_equal.
Qed.

End Req_bool.

Section Floor_Ceil.

(** Zfloor and Zceil *)
Definition Zfloor (x : R) := (up x - 1)%Z.

Theorem Zfloor_lb :
  forall x : R,
  (Z2R (Zfloor x) <= x)%R.
Proof.
intros x.
unfold Zfloor.
rewrite Z2R_minus.
simpl.
rewrite Z2R_IZR.
apply Rplus_le_reg_r with (1 - x)%R.
ring_simplify.
exact (proj2 (archimed x)).
Qed.

Theorem Zfloor_ub :
  forall x : R,
  (x < Z2R (Zfloor x) + 1)%R.
Proof.
intros x.
unfold Zfloor.
rewrite Z2R_minus.
unfold Rminus.
rewrite Rplus_assoc.
rewrite Rplus_opp_l, Rplus_0_r.
rewrite Z2R_IZR.
exact (proj1 (archimed x)).
Qed.

Theorem Zfloor_lub :
  forall n x,
  (Z2R n <= x)%R ->
  (n <= Zfloor x)%Z.
Proof.
intros n x Hnx.
apply Zlt_succ_le.
apply lt_Z2R.
apply Rle_lt_trans with (1 := Hnx).
unfold Zsucc.
rewrite Z2R_plus.
apply Zfloor_ub.
Qed.

Theorem Zfloor_imp :
  forall n x,
  (Z2R n <= x < Z2R (n + 1))%R ->
  Zfloor x = n.
Proof.
intros n x Hnx.
apply Zle_antisym.
apply Zlt_succ_le.
apply lt_Z2R.
apply Rle_lt_trans with (2 := proj2 Hnx).
apply Zfloor_lb.
now apply Zfloor_lub.
Qed.

Theorem Zfloor_Z2R :
  forall n,
  Zfloor (Z2R n) = n.
Proof.
intros n.
apply Zfloor_imp.
split.
apply Rle_refl.
apply Z2R_lt.
apply Zlt_succ.
Qed.

Theorem Zfloor_le :
  forall x y, (x <= y)%R ->
  (Zfloor x <= Zfloor y)%Z.
Proof.
intros x y Hxy.
apply Zfloor_lub.
apply Rle_trans with (2 := Hxy).
apply Zfloor_lb.
Qed.

Definition Zceil (x : R) := (- Zfloor (- x))%Z.

Theorem Zceil_ub :
  forall x : R,
  (x <= Z2R (Zceil x))%R.
Proof.
intros x.
unfold Zceil.
rewrite Z2R_opp.
apply Ropp_le_cancel.
rewrite Ropp_involutive.
apply Zfloor_lb.
Qed.

Theorem Zceil_glb :
  forall n x,
  (x <= Z2R n)%R ->
  (Zceil x <= n)%Z.
Proof.
intros n x Hnx.
unfold Zceil.
apply Zopp_le_cancel.
rewrite Zopp_involutive.
apply Zfloor_lub.
rewrite Z2R_opp.
now apply Ropp_le_contravar.
Qed.

Theorem Zceil_imp :
  forall n x,
  (Z2R (n - 1) < x <= Z2R n)%R ->
  Zceil x = n.
Proof.
intros n x Hnx.
unfold Zceil.
rewrite <- (Zopp_involutive n).
apply f_equal.
apply Zfloor_imp.
split.
rewrite Z2R_opp.
now apply Ropp_le_contravar.
rewrite <- (Zopp_involutive 1).
rewrite <- Zopp_plus_distr.
rewrite Z2R_opp.
now apply Ropp_lt_contravar.
Qed.

Theorem Zceil_Z2R :
  forall n,
  Zceil (Z2R n) = n.
Proof.
intros n.
unfold Zceil.
rewrite <- Z2R_opp, Zfloor_Z2R.
apply Zopp_involutive.
Qed.

Theorem Zceil_le :
  forall x y, (x <= y)%R ->
  (Zceil x <= Zceil y)%Z.
Proof.
intros x y Hxy.
apply Zceil_glb.
apply Rle_trans with (1 := Hxy).
apply Zceil_ub.
Qed.

Theorem Zceil_floor_neq :
  forall x : R,
  (Z2R (Zfloor x) <> x)%R ->
  (Zceil x = Zfloor x + 1)%Z.
Proof.
intros x Hx.
apply Zceil_imp.
split.
ring_simplify (Zfloor x + 1 - 1)%Z.
apply Rnot_le_lt.
intros H.
apply Hx.
apply Rle_antisym.
apply Zfloor_lb.
exact H.
apply Rlt_le.
rewrite Z2R_plus.
apply Zfloor_ub.
Qed.

Definition Ztrunc x := if Rlt_bool x 0 then Zceil x else Zfloor x.

Theorem Ztrunc_Z2R :
  forall n,
  Ztrunc (Z2R n) = n.
Proof.
intros n.
unfold Ztrunc.
case Rlt_bool_spec ; intro H.
apply Zceil_Z2R.
apply Zfloor_Z2R.
Qed.

Theorem Ztrunc_floor :
  forall x,
  (0 <= x)%R ->
  Ztrunc x = Zfloor x.
Proof.
intros x Hx.
unfold Ztrunc.
case Rlt_bool_spec ; intro H.
elim Rlt_irrefl with x.
now apply Rlt_le_trans with R0.
apply refl_equal.
Qed.

Theorem Ztrunc_ceil :
  forall x,
  (x <= 0)%R ->
  Ztrunc x = Zceil x.
Proof.
intros x Hx.
unfold Ztrunc.
case Rlt_bool_spec ; intro H.
apply refl_equal.
rewrite (Rle_antisym _ _ Hx H).
fold (Z2R 0).
rewrite Zceil_Z2R.
apply Zfloor_Z2R.
Qed.

Theorem Ztrunc_le :
  forall x y, (x <= y)%R ->
  (Ztrunc x <= Ztrunc y)%Z.
Proof.
intros x y Hxy.
unfold Ztrunc at 1.
case Rlt_bool_spec ; intro Hx.
unfold Ztrunc.
case Rlt_bool_spec ; intro Hy.
now apply Zceil_le.
apply Zle_trans with 0%Z.
apply Zceil_glb.
now apply Rlt_le.
now apply Zfloor_lub.
rewrite Ztrunc_floor.
now apply Zfloor_le.
now apply Rle_trans with x.
Qed.

Theorem Ztrunc_opp :
  forall x,
  Ztrunc (- x) = Zopp (Ztrunc x).
Proof.
intros x.
unfold Ztrunc at 2.
case Rlt_bool_spec ; intros Hx.
rewrite Ztrunc_floor.
apply sym_eq.
apply Zopp_involutive.
rewrite <- Ropp_0.
apply Ropp_le_contravar.
now apply Rlt_le.
rewrite Ztrunc_ceil.
unfold Zceil.
now rewrite Ropp_involutive.
rewrite <- Ropp_0.
now apply Ropp_le_contravar.
Qed.

Theorem Ztrunc_abs :
  forall x,
  Ztrunc (Rabs x) = Zabs (Ztrunc x).
Proof.
intros x.
rewrite Ztrunc_floor. 2: apply Rabs_pos.
unfold Ztrunc.
case Rlt_bool_spec ; intro H.
rewrite Rabs_left with (1 := H).
rewrite Zabs_non_eq.
apply sym_eq.
apply Zopp_involutive.
apply Zceil_glb.
now apply Rlt_le.
rewrite Rabs_pos_eq with (1 := H).
apply sym_eq.
apply Zabs_eq.
now apply Zfloor_lub.
Qed.

Theorem Ztrunc_lub :
  forall n x,
  (Z2R n <= Rabs x)%R ->
  (n <= Zabs (Ztrunc x))%Z.
Proof.
intros n x H.
rewrite <- Ztrunc_abs.
rewrite Ztrunc_floor. 2: apply Rabs_pos.
now apply Zfloor_lub.
Qed.

Definition Zaway x := if Rlt_bool x 0 then Zfloor x else Zceil x.

Theorem Zaway_Z2R :
  forall n,
  Zaway (Z2R n) = n.
Proof.
intros n.
unfold Zaway.
case Rlt_bool_spec ; intro H.
apply Zfloor_Z2R.
apply Zceil_Z2R.
Qed.

Theorem Zaway_ceil :
  forall x,
  (0 <= x)%R ->
  Zaway x = Zceil x.
Proof.
intros x Hx.
unfold Zaway.
case Rlt_bool_spec ; intro H.
elim Rlt_irrefl with x.
now apply Rlt_le_trans with R0.
apply refl_equal.
Qed.

Theorem Zaway_floor :
  forall x,
  (x <= 0)%R ->
  Zaway x = Zfloor x.
Proof.
intros x Hx.
unfold Zaway.
case Rlt_bool_spec ; intro H.
apply refl_equal.
rewrite (Rle_antisym _ _ Hx H).
fold (Z2R 0).
rewrite Zfloor_Z2R.
apply Zceil_Z2R.
Qed.

Theorem Zaway_le :
  forall x y, (x <= y)%R ->
  (Zaway x <= Zaway y)%Z.
Proof.
intros x y Hxy.
unfold Zaway at 1.
case Rlt_bool_spec ; intro Hx.
unfold Zaway.
case Rlt_bool_spec ; intro Hy.
now apply Zfloor_le.
apply le_Z2R.
apply Rle_trans with 0%R.
apply Rlt_le.
apply Rle_lt_trans with (2 := Hx).
apply Zfloor_lb.
apply Rle_trans with (1 := Hy).
apply Zceil_ub.
rewrite Zaway_ceil.
now apply Zceil_le.
now apply Rle_trans with x.
Qed.

Theorem Zaway_opp :
  forall x,
  Zaway (- x) = Zopp (Zaway x).
Proof.
intros x.
unfold Zaway at 2.
case Rlt_bool_spec ; intro H.
rewrite Zaway_ceil.
unfold Zceil.
now rewrite Ropp_involutive.
apply Rlt_le.
now apply Ropp_0_gt_lt_contravar.
rewrite Zaway_floor.
apply sym_eq.
apply Zopp_involutive.
rewrite <- Ropp_0.
now apply Ropp_le_contravar.
Qed.

Theorem Zaway_abs :
  forall x,
  Zaway (Rabs x) = Zabs (Zaway x).
Proof.
intros x.
rewrite Zaway_ceil. 2: apply Rabs_pos.
unfold Zaway.
case Rlt_bool_spec ; intro H.
rewrite Rabs_left with (1 := H).
rewrite Zabs_non_eq.
apply (f_equal (fun v => - Zfloor v)%Z).
apply Ropp_involutive.
apply le_Z2R.
apply Rlt_le.
apply Rle_lt_trans with (2 := H).
apply Zfloor_lb.
rewrite Rabs_pos_eq with (1 := H).
apply sym_eq.
apply Zabs_eq.
apply le_Z2R.
apply Rle_trans with (1 := H).
apply Zceil_ub.
Qed.

End Floor_Ceil.

Section Zdiv_Rdiv.

Theorem Zfloor_div :
  forall x y,
  y <> Z0 ->
  Zfloor (Z2R x / Z2R y) = (x / y)%Z.
Proof.
intros x y Zy.
generalize (Z_div_mod_eq_full x y Zy).
intros Hx.
rewrite Hx at 1.
assert (Zy': Z2R y <> R0).
contradict Zy.
now apply eq_Z2R.
unfold Rdiv.
rewrite Z2R_plus, Rmult_plus_distr_r, Z2R_mult.
replace (Z2R y * Z2R (x / y) * / Z2R y)%R with (Z2R (x / y)) by now field.
apply Zfloor_imp.
rewrite Z2R_plus.
assert (0 <= Z2R (x mod y) * / Z2R y < 1)%R.
(* *)
assert (forall x' y', (0 < y')%Z -> 0 <= Z2R (x' mod y') * / Z2R y' < 1)%R.
(* . *)
clear.
intros x y Hy.
split.
apply Rmult_le_pos.
apply (Z2R_le 0).
refine (proj1 (Z_mod_lt _ _ _)).
now apply Zlt_gt.
apply Rlt_le.
apply Rinv_0_lt_compat.
now apply (Z2R_lt 0).
apply Rmult_lt_reg_r with (Z2R y).
now apply (Z2R_lt 0).
rewrite Rmult_1_l, Rmult_assoc, Rinv_l, Rmult_1_r.
apply Z2R_lt.
eapply Z_mod_lt.
now apply Zlt_gt.
apply Rgt_not_eq.
now apply (Z2R_lt 0).
(* . *)
destruct (Z_lt_le_dec y 0) as [Hy|Hy].
rewrite <- Rmult_opp_opp.
rewrite Ropp_inv_permute with (1 := Zy').
rewrite <- 2!Z2R_opp.
rewrite <- Zmod_opp_opp.
apply H.
clear -Hy. omega.
apply H.
clear -Zy Hy. omega.
(* *)
split.
pattern (Z2R (x / y)) at 1 ; rewrite <- Rplus_0_r.
apply Rplus_le_compat_l.
apply H.
apply Rplus_lt_compat_l.
apply H.
Qed.

End Zdiv_Rdiv.

Section pow.

Variable r : radix.

Theorem radix_pos : (0 < Z2R r)%R.
Proof.
destruct r as (v, Hr). simpl.
apply (Z2R_lt 0).
apply Zlt_le_trans with 2%Z.
easy.
now apply Zle_bool_imp_le.
Qed.

(** Well-used function called bpow for computing the power function #β#^e *)
Definition bpow e :=
  match e with
  | Zpos p => Z2R (Zpower_pos r p)
  | Zneg p => Rinv (Z2R (Zpower_pos r p))
  | Z0 => R1
  end.

Theorem Z2R_Zpower_pos :
  forall n m,
  Z2R (Zpower_pos n m) = powerRZ (Z2R n) (Zpos m).
Proof.
intros.
rewrite Zpower_pos_nat.
simpl.
induction (nat_of_P m).
apply refl_equal.
unfold Zpower_nat.
simpl.
rewrite Z2R_mult.
apply Rmult_eq_compat_l.
exact IHn0.
Qed.

Theorem bpow_powerRZ :
  forall e,
  bpow e = powerRZ (Z2R r) e.
Proof.
destruct e ; unfold bpow.
reflexivity.
now rewrite Z2R_Zpower_pos.
now rewrite Z2R_Zpower_pos.
Qed.

Theorem  bpow_ge_0 :
  forall e : Z, (0 <= bpow e)%R.
Proof.
intros.
rewrite bpow_powerRZ.
apply powerRZ_le.
apply radix_pos.
Qed.

Theorem bpow_gt_0 :
  forall e : Z, (0 < bpow e)%R.
Proof.
intros.
rewrite bpow_powerRZ.
apply powerRZ_lt.
apply radix_pos.
Qed.

Theorem bpow_plus :
  forall e1 e2 : Z, (bpow (e1 + e2) = bpow e1 * bpow e2)%R.
Proof.
intros.
repeat rewrite bpow_powerRZ.
apply powerRZ_add.
apply Rgt_not_eq.
apply radix_pos.
Qed.

Theorem bpow_1 :
  bpow 1 = Z2R r.
Proof.
unfold bpow, Zpower_pos. simpl.
now rewrite Zmult_1_r.
Qed.

Theorem bpow_plus1 :
  forall e : Z, (bpow (e + 1) = Z2R r * bpow e)%R.
Proof.
intros.
rewrite <- bpow_1.
rewrite <- bpow_plus.
now rewrite Zplus_comm.
Qed.

Theorem bpow_opp :
  forall e : Z, (bpow (-e) = /bpow e)%R.
Proof.
intros e; destruct e.
simpl; now rewrite Rinv_1.
now replace (-Zpos p)%Z with (Zneg p) by reflexivity.
replace (-Zneg p)%Z with (Zpos p) by reflexivity.
simpl; rewrite Rinv_involutive; trivial.
generalize (bpow_gt_0 (Zpos p)).
simpl; auto with real.
Qed.

Theorem Z2R_Zpower_nat :
  forall e : nat,
  Z2R (Zpower_nat r e) = bpow (Z_of_nat e).
Proof.
intros [|e].
split.
rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ.
rewrite <- Zpower_pos_nat.
now rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P.
Qed.

Theorem Z2R_Zpower :
  forall e : Z,
  (0 <= e)%Z ->
  Z2R (Zpower r e) = bpow e.
Proof.
intros [|e|e] H.
split.
split.
now elim H.
Qed.

Theorem bpow_lt :
  forall e1 e2 : Z,
  (e1 < e2)%Z -> (bpow e1 < bpow e2)%R.
Proof.
intros e1 e2 H.
replace e2 with (e1 + (e2 - e1))%Z by ring.
rewrite <- (Rmult_1_r (bpow e1)).
rewrite bpow_plus.
apply Rmult_lt_compat_l.
apply bpow_gt_0.
assert (0 < e2 - e1)%Z by omega.
destruct (e2 - e1)%Z ; try discriminate H0.
clear.
rewrite <- Z2R_Zpower by easy.
apply (Z2R_lt 1).
now apply Zpower_gt_1.
Qed.

Theorem lt_bpow :
  forall e1 e2 : Z,
  (bpow e1 < bpow e2)%R -> (e1 < e2)%Z.
Proof.
intros e1 e2 H.
apply Zgt_lt.
apply Znot_le_gt.
intros H'.
apply Rlt_not_le with (1 := H).
destruct (Zle_lt_or_eq _ _ H').
apply Rlt_le.
now apply bpow_lt.
rewrite H0.
apply Rle_refl.
Qed.

Theorem bpow_le :
  forall e1 e2 : Z,
  (e1 <= e2)%Z -> (bpow e1 <= bpow e2)%R.
Proof.
intros e1 e2 H.
apply Rnot_lt_le.
intros H'.
apply Zle_not_gt with (1 := H).
apply Zlt_gt.
now apply lt_bpow.
Qed.

Theorem le_bpow :
  forall e1 e2 : Z,
  (bpow e1 <= bpow e2)%R -> (e1 <= e2)%Z.
Proof.
intros e1 e2 H.
apply Znot_gt_le.
intros H'.
apply Rle_not_lt with (1 := H).
apply bpow_lt.
now apply Zgt_lt.
Qed.

Theorem bpow_inj :
  forall e1 e2 : Z,
  bpow e1 = bpow e2 -> e1 = e2.
Proof.
intros.
apply Zle_antisym.
apply le_bpow.
now apply Req_le.
apply le_bpow.
now apply Req_le.
Qed.

Theorem bpow_exp :
  forall e : Z,
  bpow e = exp (Z2R e * ln (Z2R r)).
Proof.
(* positive case *)
assert (forall e, bpow (Zpos e) = exp (Z2R (Zpos e) * ln (Z2R r))).
intros e.
unfold bpow.
rewrite Zpower_pos_nat.
unfold Z2R at 2.
rewrite P2R_INR.
induction (nat_of_P e).
rewrite Rmult_0_l.
now rewrite exp_0.
rewrite Zpower_nat_S.
rewrite S_INR.
rewrite Rmult_plus_distr_r.
rewrite exp_plus.
rewrite Rmult_1_l.
rewrite exp_ln.
rewrite <- IHn.
rewrite <- Z2R_mult.
now rewrite Zmult_comm.
apply radix_pos.
(* general case *)
intros [|e|e].
rewrite Rmult_0_l.
now rewrite exp_0.
apply H.
unfold bpow.
change (Z2R (Zpower_pos r e)) with (bpow (Zpos e)).
rewrite H.
rewrite <- exp_Ropp.
rewrite <- Ropp_mult_distr_l_reverse.
now rewrite <- Z2R_opp.
Qed.

(** Another well-used function for having the logarithm of a real number x to the base #β# *)
Record ln_beta_prop x := {
  ln_beta_val :> Z ;
   _ : (x <> 0)%R -> (bpow (ln_beta_val - 1)%Z <= Rabs x < bpow ln_beta_val)%R
}.

Definition ln_beta :
  forall x : R, ln_beta_prop x.
Proof.
intros x.
set (fact := ln (Z2R r)).
(* . *)
assert (0 < fact)%R.
apply exp_lt_inv.
rewrite exp_0.
unfold fact.
rewrite exp_ln.
apply (Z2R_lt 1).
apply radix_gt_1.
apply radix_pos.
(* . *)
exists (Zfloor (ln (Rabs x) / fact) + 1)%Z.
intros Hx'.
generalize (Rabs_pos_lt _ Hx'). clear Hx'.
generalize (Rabs x). clear x.
intros x Hx.
rewrite 2!bpow_exp.
fold fact.
pattern x at 2 3 ; replace x with (exp (ln x * / fact * fact)).
split.
rewrite Z2R_minus.
apply exp_le.
apply Rmult_le_compat_r.
now apply Rlt_le.
unfold Rminus.
rewrite Z2R_plus.
rewrite Rplus_assoc.
rewrite Rplus_opp_r, Rplus_0_r.
apply Zfloor_lb.
apply exp_increasing.
apply Rmult_lt_compat_r.
exact H.
rewrite Z2R_plus.
apply Zfloor_ub.
rewrite Rmult_assoc.
rewrite Rinv_l.
rewrite Rmult_1_r.
now apply exp_ln.
now apply Rgt_not_eq.
Qed.

Theorem bpow_lt_bpow :
  forall e1 e2,
  (bpow (e1 - 1) < bpow e2)%R ->
  (e1 <= e2)%Z.
Proof.
intros e1 e2 He.
rewrite (Zsucc_pred e1).
apply Zlt_le_succ.
now apply lt_bpow.
Qed.

Theorem bpow_unique :
  forall x e1 e2,
  (bpow (e1 - 1) <= x < bpow e1)%R ->
  (bpow (e2 - 1) <= x < bpow e2)%R ->
  e1 = e2.
Proof.
intros x e1 e2 (H1a,H1b) (H2a,H2b).
apply Zle_antisym ;
  apply bpow_lt_bpow ;
  apply Rle_lt_trans with x ;
  assumption.
Qed.

Theorem ln_beta_unique :
  forall (x : R) (e : Z),
  (bpow (e - 1) <= Rabs x < bpow e)%R ->
  ln_beta x = e :> Z.
Proof.
intros x e1 He.
destruct (Req_dec x 0) as [Hx|Hx].
elim Rle_not_lt with (1 := proj1 He).
rewrite Hx, Rabs_R0.
apply bpow_gt_0.
destruct (ln_beta x) as (e2, Hx2).
simpl.
apply bpow_unique with (2 := He).
now apply Hx2.
Qed.

Theorem ln_beta_opp :
  forall x,
  ln_beta (-x) = ln_beta x :> Z.
Proof.
intros x.
destruct (Req_dec x 0) as [Hx|Hx].
now rewrite Hx, Ropp_0.
destruct (ln_beta x) as (e, He).
simpl.
specialize (He Hx).
apply ln_beta_unique.
now rewrite Rabs_Ropp.
Qed.

Theorem ln_beta_abs :
  forall x,
  ln_beta (Rabs x) = ln_beta x :> Z.
Proof.
intros x.
unfold Rabs.
case Rcase_abs ; intros _.
apply ln_beta_opp.
apply refl_equal.
Qed.

Theorem ln_beta_unique_pos :
  forall (x : R) (e : Z),
  (bpow (e - 1) <= x < bpow e)%R ->
  ln_beta x = e :> Z.
Proof.
intros x e1 He1.
rewrite <- ln_beta_abs.
apply ln_beta_unique.
rewrite 2!Rabs_pos_eq.
exact He1.
apply Rle_trans with (2 := proj1 He1).
apply bpow_ge_0.
apply Rabs_pos.
Qed.

Theorem ln_beta_le_abs :
  forall x y,
  (x <> 0)%R -> (Rabs x <= Rabs y)%R ->
  (ln_beta x <= ln_beta y)%Z.
Proof.
intros x y H0x Hxy.
destruct (ln_beta x) as (ex, Hx).
destruct (ln_beta y) as (ey, Hy).
simpl.
apply bpow_lt_bpow.
specialize (Hx H0x).
apply Rle_lt_trans with (1 := proj1 Hx).
apply Rle_lt_trans with (1 := Hxy).
apply Hy.
intros Hy'.
apply Rlt_not_le with (1 := Rabs_pos_lt _ H0x).
apply Rle_trans with (1 := Hxy).
rewrite Hy', Rabs_R0.
apply Rle_refl.
Qed.

Theorem ln_beta_le :
  forall x y,
  (0 < x)%R -> (x <= y)%R ->
  (ln_beta x <= ln_beta y)%Z.
Proof.
intros x y H0x Hxy.
apply ln_beta_le_abs.
now apply Rgt_not_eq.
rewrite 2!Rabs_pos_eq.
exact Hxy.
apply Rle_trans with (2 := Hxy).
now apply Rlt_le.
now apply Rlt_le.
Qed.

Theorem ln_beta_bpow :
  forall e, (ln_beta (bpow e) = e + 1 :> Z)%Z.
Proof.
intros e.
apply ln_beta_unique.
rewrite Rabs_right.
replace (e + 1 - 1)%Z with e by ring.
split.
apply Rle_refl.
apply bpow_lt.
apply Zlt_succ.
apply Rle_ge.
apply bpow_ge_0.
Qed.

Theorem ln_beta_mult_bpow :
  forall x e, x <> R0 ->
  (ln_beta (x * bpow e) = ln_beta x + e :>Z)%Z.
Proof.
intros x e Zx.
destruct (ln_beta x) as (ex, Ex) ; simpl.
specialize (Ex Zx).
apply ln_beta_unique.
rewrite Rabs_mult.
rewrite (Rabs_pos_eq (bpow e)) by apply bpow_ge_0.
split.
replace (ex + e - 1)%Z with (ex - 1 + e)%Z by ring.
rewrite bpow_plus.
apply Rmult_le_compat_r.
apply bpow_ge_0.
apply Ex.
rewrite bpow_plus.
apply Rmult_lt_compat_r.
apply bpow_gt_0.
apply Ex.
Qed.

Theorem ln_beta_le_bpow :
  forall x e,
  x <> R0 ->
  (Rabs x < bpow e)%R ->
  (ln_beta x <= e)%Z.
Proof.
intros x e Zx Hx.
destruct (ln_beta x) as (ex, Ex) ; simpl.
specialize (Ex Zx).
apply bpow_lt_bpow.
now apply Rle_lt_trans with (Rabs x).
Qed.

Theorem ln_beta_gt_bpow :
  forall x e,
  (bpow e <= Rabs x)%R ->
  (e < ln_beta x)%Z.
Proof.
intros x e Hx.
destruct (ln_beta x) as (ex, Ex) ; simpl.
apply lt_bpow.
apply Rle_lt_trans with (1 := Hx).
apply Ex.
intros Zx.
apply Rle_not_lt with (1 := Hx).
rewrite Zx, Rabs_R0.
apply bpow_gt_0.
Qed.

Theorem bpow_ln_beta_gt :
  forall x,
  (Rabs x < bpow (ln_beta x))%R.
Proof.
intros x.
destruct (Req_dec x 0) as [Zx|Zx].
rewrite Zx, Rabs_R0.
apply bpow_gt_0.
destruct (ln_beta x) as (ex, Ex) ; simpl.
now apply Ex.
Qed.

Theorem ln_beta_le_Zpower :
  forall m e,
  m <> Z0 ->
  (Zabs m < Zpower r e)%Z->
  (ln_beta (Z2R m) <= e)%Z.
Proof.
intros m e Zm Hm.
apply ln_beta_le_bpow.
exact (Z2R_neq m 0 Zm).
destruct (Zle_or_lt 0 e).
rewrite <- Z2R_abs, <- Z2R_Zpower with (1 := H).
now apply Z2R_lt.
elim Zm.
cut (Zabs m < 0)%Z.
now case m.
clear -Hm H.
now destruct e.
Qed.

Theorem ln_beta_gt_Zpower :
  forall m e,
  m <> Z0 ->
  (Zpower r e <= Zabs m)%Z ->
  (e < ln_beta (Z2R m))%Z.
Proof.
intros m e Zm Hm.
apply ln_beta_gt_bpow.
rewrite <- Z2R_abs.
destruct (Zle_or_lt 0 e).
rewrite <- Z2R_Zpower with (1 := H).
now apply Z2R_le.
apply Rle_trans with (bpow 0).
apply bpow_le.
now apply Zlt_le_weak.
apply (Z2R_le 1).
clear -Zm.
zify ; omega.
Qed.

End pow.

Section Bool.

Theorem eqb_sym :
  forall x y, Bool.eqb x y = Bool.eqb y x.
Proof.
now intros [|] [|].
Qed.

Theorem eqb_false :
  forall x y, x = negb y -> Bool.eqb x y = false.
Proof.
now intros [|] [|].
Qed.

Theorem eqb_true :
  forall x y, x = y -> Bool.eqb x y = true.
Proof.
now intros [|] [|].
Qed.

End Bool.

Section cond_Ropp.

Definition cond_Ropp (b : bool) m := if b then Ropp m else m.

Theorem Z2R_cond_Zopp :
  forall b m,
  Z2R (cond_Zopp b m) = cond_Ropp b (Z2R m).
Proof.
intros [|] m.
apply Z2R_opp.
apply refl_equal.
Qed.

Theorem abs_cond_Ropp :
  forall b m,
  Rabs (cond_Ropp b m) = Rabs m.
Proof.
intros [|] m.
apply Rabs_Ropp.
apply refl_equal.
Qed.

Theorem cond_Ropp_Rlt_bool :
  forall m,
  cond_Ropp (Rlt_bool m 0) m = Rabs m.
Proof.
intros m.
apply sym_eq.
case Rlt_bool_spec ; intros Hm.
now apply Rabs_left.
now apply Rabs_pos_eq.
Qed.

Theorem cond_Ropp_involutive :
  forall b x,
  cond_Ropp b (cond_Ropp b x) = x.
Proof.
intros [|] x.
apply Ropp_involutive.
apply refl_equal.
Qed.

Theorem cond_Ropp_even_function :
  forall {A : Type} (f : R -> A),
  (forall x, f (Ropp x) = f x) ->
  forall b x, f (cond_Ropp b x) = f x.
Proof.
now intros A f Hf [|] x ; simpl.
Qed.

Theorem cond_Ropp_odd_function :
  forall (f : R -> R),
  (forall x, f (Ropp x) = Ropp (f x)) ->
  forall b x, f (cond_Ropp b x) = cond_Ropp b (f x).
Proof.
now intros f Hf [|] x ; simpl.
Qed.

Theorem cond_Ropp_inj :
  forall b x y,
  cond_Ropp b x = cond_Ropp b y -> x = y.
Proof.
intros b x y H.
rewrite <- (cond_Ropp_involutive b x), H.
apply cond_Ropp_involutive.
Qed.

Theorem cond_Ropp_mult_l :
  forall b x y,
  cond_Ropp b (x * y) = (cond_Ropp b x * y)%R.
Proof.
intros [|] x y.
apply sym_eq.
apply Ropp_mult_distr_l_reverse.
apply refl_equal.
Qed.

Theorem cond_Ropp_mult_r :
  forall b x y,
  cond_Ropp b (x * y) = (x * cond_Ropp b y)%R.
Proof.
intros [|] x y.
apply sym_eq.
apply Ropp_mult_distr_r_reverse.
apply refl_equal.
Qed.

Theorem cond_Ropp_plus :
  forall b x y,
  cond_Ropp b (x + y) = (cond_Ropp b x + cond_Ropp b y)%R.
Proof.
intros [|] x y.
apply Ropp_plus_distr.
apply refl_equal.
Qed.

End cond_Ropp.


Require Import Format.
Require Import Doc.

Open Scope list_scope.
Require Import ZArith Int.
Require Import Coq.Lists.List.
Require Import String.

Definition cross_general (width: nat) (op: t -> t -> t) (fl1: list t) (fl2: list t) :=
  List.filter
    (fun f => total_width f <=? width)
    (List.concat (map (fun b => map (fun a => op a b) fl1) fl2)).

Definition blank_line := (line "")::nil.

(* Construct document from 'string' using 'above' rule *)
Definition constructDoc (s: string) := (of_string s)::nil.

Definition indentDoc (width: nat) (shift: nat) (fs: list t) :=
  cross_general width (fun _ b => indent' shift b) (empty::nil) fs.

(* Use 'beside' rule for 2 documents. New document ~ n x m *)
Definition besideDoc (width: nat) (fs1: list t) (fs2: list t) :=
  cross_general width add_beside fs1 fs2.

(* Use 'above' rule for 2 documents. New document ~ n x m *)
Definition aboveDoc (width: nat) (fs1: list t) (fs2: list t) :=
   cross_general width add_above fs1 fs2.

(* 'Fill' rule *)
Definition fillDoc (width: nat) (fs1: list t) (fs2: list t) (shift: nat) :=
   cross_general width (fun fs f => add_fill fs f shift) fs1 fs2.

(* Choice operation *)
Definition choiceDoc (fs1: list t) (fs2: list t) :=
    fs1 ++ fs2.

Fixpoint evaluatorTrivial (width: nat) (doc: Doc): list t:=
  match doc with
  | Text s     => constructDoc s
  | Indent n d => indentDoc width n (evaluatorTrivial width d)
  | Beside a b => besideDoc width (evaluatorTrivial width a) (evaluatorTrivial width b)
  | Above a b  => aboveDoc width (evaluatorTrivial width a) (evaluatorTrivial width b)
  | Choice a b => choiceDoc (evaluatorTrivial width a) (evaluatorTrivial width b)
  | Fill a b n => fillDoc width (evaluatorTrivial width a) (evaluatorTrivial width b) n
  end.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)
(* CRing_Homomorphisms.v, v1.0, 28april2004, Bart Kirkels *)

(** printing [+] %\ensuremath+% #+# *)
(** printing [*] %\ensuremath\times% #×# *)
(** printing ['] %\ensuremath.% #.# *)
(** printing [-] %\ensuremath{-}% #−# *)
(** printing [--] %\ensuremath-% #−# *)
(** printing [=] %\ensuremath=% #≡# *)
(** printing [#] %\ensuremath\#% *)
(** printing [0] %\ensuremath{\mathbf0}% #0# *)
(** printing [1] %\ensuremath{\mathbf1}% #1# *)
(** printing phi %\ensuremath{\phi}%  *)

Require Export CoRN.algebra.CRings.
Set Automatic Introduction.

(* Backwards compatibility for Hint Rewrite locality attributes *)
Set Warnings "-unsupported-attributes".

(**
* Ring Homomorphisms
** Definition of Ring Homomorphisms
Let [R] and [S] be rings, and [phi : R -> S].
*)

Section RingHom_Definition.

Variables R S : CRing.

Section RingHom_Preliminary.

Variable phi : CSetoid_fun R S.

Definition fun_pres_plus := forall x y:R, phi (x[+]y) [=] (phi x) [+] (phi y).
Definition fun_pres_mult := forall x y:R, phi (x[*]y) [=] (phi x) [*] (phi y).
Definition fun_pres_unit := (phi ([1]:R)) [=] ([1]:S).

End RingHom_Preliminary.

Record RingHom : Type :=
  {rhmap : CSetoid_fun R S;
   rh1 : fun_pres_plus rhmap;
   rh2 : fun_pres_mult rhmap;
   rh3 : fun_pres_unit rhmap}.

End RingHom_Definition.

Module Export coercions.
  Coercion rhmap : RingHom >-> CSetoid_fun.
End coercions.

(**
** Lemmas on Ring Homomorphisms
Let [R] and [S] be rings and [f] a ring homomorphism from [R] to [S].
*** Axioms on Ring Homomorphisms
*)

Section RingHom_Lemmas.

Variables R S : CRing.

Section RingHom_Axioms.

Variable f : RingHom R S.

Lemma rh_strext : forall x y:R, (f x) [#] (f y) -> x [#] y.
Proof.
 elim f; intuition.
 assert (fun_strext rhmap0); elim rhmap0; intuition.
Qed.

Lemma rh_pres_plus : forall x y:R, f (x[+]y) [=] (f x) [+] (f y).
Proof.
 elim f; auto.
Qed.

Lemma rh_pres_mult : forall x y:R, f (x[*]y) [=] (f x) [*] (f y).
Proof.
 elim f; auto.
Qed.

Lemma rh_pres_unit : (f ([1]:R)) [=] ([1]:S).
Proof.
 elim f; auto.
Qed.

End RingHom_Axioms.

Hint Resolve rh_strext rh_pres_plus rh_pres_mult rh_pres_unit : algebra.

(**
*** Facts on Ring Homomorphisms
*)

Section RingHom_Basics.

Variable f : RingHom R S.

Lemma rh_pres_zero : (f ([0]:R)) [=] ([0]:S).
Proof.
 astepr ((f [0])[-](f [0])).
 astepr ((f ([0][+][0]))[-](f [0])).
 Step_final ((f [0][+]f [0])[-]f [0]).
Qed.

Lemma rh_pres_inv : forall x:R, (f [--]x) [=] [--] (f x).
Proof.
 intro x; apply (cg_cancel_lft S (f x)).
 astepr ([0]:S).
 astepl (f (x[+][--]x)).
 Step_final (f ([0]:R)); try apply rh_pres_zero.
Qed.

Lemma rh_pres_minus : forall x y:R, f (x[-]y) [=] (f x) [-] (f y).
Proof.
 unfold cg_minus.
 intros x y.
 rewrite -> rh_pres_plus.
 rewrite -> rh_pres_inv.
 reflexivity.
Qed.

Lemma rh_apzero : forall x:R, (f x) [#] [0] -> x [#] [0].
Proof.
 intros x X; apply (cg_ap_cancel_rht R x ([0]:R) x).
 astepr x.
 apply (rh_strext f (x[+]x) x).
 astepl ((f x)[+](f x)).
 astepr (([0]:S) [+] (f x)).
 apply (op_rht_resp_ap S (f x) ([0]:S) (f x)).
 assumption.
Qed.

Lemma rh_pres_nring : forall n, (f (nring n:R)) [=] (nring n:S).
Proof.
 induction n.
  apply rh_pres_zero.
 simpl.
 rewrite -> rh_pres_plus;auto with *.
Qed.

End RingHom_Basics.

End RingHom_Lemmas.

#[global]
Hint Resolve rh_strext rh_pres_plus rh_pres_mult rh_pres_unit : algebra.
#[global]
Hint Resolve rh_pres_zero rh_pres_minus rh_pres_inv rh_apzero : algebra.
#[global]
Hint Rewrite rh_pres_zero rh_pres_plus rh_pres_minus rh_pres_inv rh_pres_mult rh_pres_unit : ringHomPush.

Definition RHid R : RingHom R R.
Proof.
 exists (id_un_op R).
   intros x y; apply eq_reflexive.
  intros x y; apply eq_reflexive.
 apply eq_reflexive.
Defined.

Section Compose.

Variable R S T : CRing.
Variable phi : RingHom S T.
Variable psi : RingHom R S.

Lemma RHcompose1 : fun_pres_plus _ _ (compose_CSetoid_fun _ _ _ psi phi).
Proof.
 intros x y.
 simpl.
 repeat rewrite -> rh_pres_plus;reflexivity.
Qed.

Lemma RHcompose2 : fun_pres_mult _ _ (compose_CSetoid_fun _ _ _ psi phi).
Proof.
 intros x y.
 simpl.
 repeat rewrite -> rh_pres_mult; reflexivity.
Qed.

Lemma RHcompose3 : fun_pres_unit _ _ (compose_CSetoid_fun _ _ _ psi phi).
Proof.
 unfold fun_pres_unit.
 simpl.
 repeat rewrite -> rh_pres_unit; reflexivity.
Qed.

Definition RHcompose : RingHom R T := Build_RingHom _ _ _ RHcompose1 RHcompose2 RHcompose3.

End Compose.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)

Require Import ssreflect.
Require Import ssrbool.

Lemma test (a b : bool) (pab : a && b) : b.
have {pab} /= /andP [pa -> //] /= : true && (a && b) := pab.
Qed.


(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

(** * ElGamal.v : Semantic security of the ElGamal encryption scheme *)

Set Implicit Arguments.

Require Import SemGroup.

Module SECURITY_PROOF (GCK : CYCLIC_GROUP_WITH_ORDER).

 Module SEM :=  MAKE_SEM_GROUP GCK.
 Import SEM.

(** ** DDH assumption *)
Section DDH_ASSUMPTION.

 (** The DDH assumption says that any efficient adversary [D] has a negligible
    chance of telling appart triples of the form (g^x, g^y, g^(x * y)) from
    triples of the form (g^x, g^y, g^z), where [x], [y] and [z] are uniformly
    sampled
 *)

 Variables x y z : Var.var T.Nat.
 Variable b : Var.var T.Bool.
 Variable Dname : positive.

 Notation Local D :=
  (Proc.mkP Dname (T.User Tg :: T.User Tg :: T.User Tg :: nil) T.Bool).

 Definition DDH0 :=
  [
   x <$- [0..q-!1];
   y <$- [0..q-!1];
   b <c- D with {g^x, g^y, g^(x *! y)}
  ].

 Definition DDH1 :=
  [
   x <$- [0..q-!1];
   y <$- [0..q-!1];
   z <$- [0..q-!1];
   b <c- D with {g^x, g^y, g^z}
  ].

 Definition DDH_advantage E k (m:Mem.t k) :=
  Uabs_diff (Pr E DDH0 m (EP k b)) (Pr E DDH1 m (EP k b)).

 Axiom DDH_assumption : forall (m:forall k, Mem.t k) E,
  x <> y ->
  x <> z ->
  y <> z ->
  Var.is_local x ->
  Var.is_local y ->
  Var.is_local z ->
  lossless E (proc_body E D) ->
  PPT_proc E D ->
  negligible (fun k => DDH_advantage E (m k)).

End DDH_ASSUMPTION.

Open Scope positive_scope.

(** ** Global Variables *)

(** *** Global variables shared between the adversary, the oracles and the game *)
Definition Gcomm := Vset.empty.

(** Global variable shared between [A] and [A'] *)
Notation g_a := (Var.Gvar T.Nat 1).

Definition Gadv := {{g_a}}.

(** Coin tossed to choose the encrypted message *)
Notation b  := (Var.Gvar T.Bool 2).

(** ** Local variables *)

(** Integer variables *)
Notation x := (Var.Lvar T.Nat 11).
Notation y := (Var.Lvar T.Nat 12).
Notation z := (Var.Lvar T.Nat 13).

(** Group elements *)
Notation alpha    := (Var.Lvar (T.User Tg) 21).
Notation alpha'   := (Var.Lvar (T.User Tg) 22).
Notation beta     := (Var.Lvar (T.User Tg) 23).
Notation gamma    := (Var.Lvar (T.User Tg) 24).
Notation zeta     := (Var.Lvar (T.User Tg) 25).
Notation xalpha   := (Var.Lvar (T.Pair T.Nat (T.User Tg)) 26).
Notation betazeta := (Var.Lvar (T.Pair(T.User Tg) (T.User Tg)) 27).

(** Messages *)
Notation m   := (Var.Lvar (T.Pair (T.User Tg) (T.User Tg)) 31).
Notation mb  := (Var.Lvar (T.User Tg) 32).
Notation mb' := (Var.Lvar (T.User Tg) 33).

(** Bits *)
Notation b' := (Var.Lvar T.Bool 41).
Notation d  := (Var.Lvar T.Bool 42).

(** ** Procedures *)
Notation A  := (Proc.mkP 1 (T.User Tg :: nil) (T.Pair (T.User Tg) (T.User Tg))).
Notation A' := (Proc.mkP 2 (T.User Tg :: T.User Tg :: T.User Tg :: nil) T.Bool).
Notation B  := (Proc.mkP 3 (T.User Tg :: T.User Tg ::T.User Tg :: nil) T.Bool).
Notation KG := (Proc.mkP 4 nil (T.Pair T.Nat (T.User Tg))).
Notation Enc := (Proc.mkP 5 (T.User Tg :: T.User Tg :: nil) (T.Pair (T.User Tg) (T.User Tg))).

Close Scope positive_scope.

(** ** Key Generation *)
Definition KG_params : (var_decl (Proc.targs KG)) := dnil _.

Definition KG_body :=
 [
  x <$- [0..q-!1]
 ].

Definition KG_res := (x | g^x).

(** ** Encryption *)
Definition Enc_params : (var_decl (Proc.targs Enc)) :=
 dcons _ alpha' (dcons _ mb' (dnil _)).

Definition Enc_body :=
 [
  y <$- [0..q-!1]
 ].

Definition Enc_res := (g^y | alpha'^y ** mb').

(** * Games *)

Definition ElGamal : cmd :=
 [
  xalpha <c- KG with {};
  x <- Efst xalpha; alpha <- Esnd xalpha;
  m <c- A with {alpha};
  b <$- {0,1};
  If b then [ mb <- Efst m ] else [ mb <- Esnd m ];
  betazeta <c- Enc with {alpha, mb};
  beta <- Efst betazeta; zeta <- Esnd betazeta;
  b' <c- A' with {alpha, beta, zeta}
 ].

Definition G0 : cmd :=
 [
  x <$- [0..q-!1]; y <$- [0..q-!1];
  m <c- A with {g^x};
  b <$- {0,1};
  If b then [ mb <- Efst m ] else [ mb <- Esnd m ];
  zeta <- g^(x *! y) ** mb;
  b' <c- A' with {g^x, g^y, zeta}
 ].

Definition G1 : cmd :=
 [
  x <$- [0..q-!1]; y <$- [0..q-!1];
  m <c- A with {g^x};
  b <$- {0,1};
  If b then [ mb <- Efst m ] else [ mb <- Esnd m ];
  z <$- [0..q-!1]; zeta <- g^z ** mb;
  b' <c- A' with {g^x, g^y, zeta}
 ].

Definition G2 : cmd :=
 [
  x <$- [0..q-!1]; y <$- [0..q-!1];
  m <c- A with {g^x};
  z <$- [0..q-!1]; zeta <- g^z;
  b' <c- A' with {g^x, g^y, zeta};
  b <$- {0,1}
 ].

(* The adversary for DDH *)
Definition B_params : (var_decl (Proc.targs B)) :=
 dcons _ alpha (dcons _ beta (dcons _ gamma (dnil _))).

Definition B_body :=
 [
  m <c- A with {alpha};
  b <$- {0,1};
  If b then [ mb <- Efst m ] else [ mb <- Esnd m ];
  b' <c- A' with {alpha, beta, gamma ** mb}
 ].

Definition B_res := b =?= b'.

Definition DDH0_B := DDH0 x y   d 3 (* B *).
Definition DDH1_B := DDH1 x y z d 3 (* B *).

Close Scope positive_scope.

(** ** Adversary and proof *)
Section ADVERSARY_AND_PROOF.

 Variable env_adv : env.

 (** *** Specification of the adversary *)
 Definition A_params : var_decl (Proc.targs A) := dcons _ alpha (dnil _).

 Variable A_body : cmd.

 (** [A] returns a pair of messages *)
 Variable A_ret : E.expr (T.Pair (T.User Tg) (T.User Tg)).

 Definition A'_params : var_decl (Proc.targs A') :=
  dcons _ alpha (dcons _ beta (dcons _ zeta (dnil _))).

 Variable A'_body : cmd.

 (** [A'] returns a guess for [b], a boolean *)
 Variable A'_ret : E.expr T.Bool.

 (** The initial environment *)
 Definition E :=
  let Ekg := add_decl env_adv KG KG_params (refl_equal true) KG_body KG_res in
  let Eenc := add_decl Ekg Enc Enc_params (refl_equal true) Enc_body Enc_res in
  let EA' := add_decl Eenc A' A'_params (refl_equal true) A'_body A'_ret in
  add_decl EA' A A_params (refl_equal true) A_body A_ret.

 (** Environment for the DDH adversary *)
 Definition EB := add_decl E B B_params (refl_equal true) B_body B_res.

 (** The set of oracles that can be called by [A] and [A'] (there are none) *)
 Definition PrOrcl := PrSet.empty.

 (** Private procedures, not accessible to the adversary *)
 Definition PrPriv := PrSet.singleton (BProc.mkP B).

 (** The adversary is well-formed in [E], i.e. it only reads or writes
    variables it has access to, and only calls oracles and its own procedures *)
 Hypothesis A_wf  : WFAdv PrOrcl PrPriv Gadv Gcomm E A.
 Hypothesis A'_wf :  WFAdv PrOrcl PrPriv Gadv Gcomm E A'.

 (** The adversary runs in PPT *)
 Hypothesis A_PPT  : PPT_proc EB A.
 Hypothesis A'_PPT : PPT_proc EB A'.

 (** The adversary is lossless (i.e. it always terminates) *)
 Hypothesis A_lossless  : lossless EB A_body.
 Hypothesis A'_lossless : lossless EB A'_body.

 Lemma EqAD : Eq_adv_decl PrOrcl PrPriv E EB.
 Proof.
  unfold Eq_adv_decl, proc_params, proc_body, proc_res; intros.
  generalize (BProc.eqb_spec (BProc.mkP A) (BProc.mkP f)).
  destruct (BProc.eqb (BProc.mkP A) (BProc.mkP f)); intros.
  inversion H1; simpl; auto.
  generalize (BProc.eqb_spec (BProc.mkP A') (BProc.mkP f)).
  destruct (BProc.eqb (BProc.mkP A') (BProc.mkP f)); intros.
  inversion H2; simpl; auto.
  unfold EB.
  repeat rewrite add_decl_other_mk; try tauto.
  intro Heq; apply H0. rewrite <- Heq; trivial.
 Qed.

 Lemma EqADB : Eq_adv_decl PrOrcl PrPriv EB EB.
 Proof.
  unfold Eq_adv_decl; auto.
 Qed.

 Lemma EqOP : Eq_orcl_params PrOrcl E EB.
 Proof.
  unfold Eq_orcl_params; intros; discriminate.
 Qed.

 Lemma A_wf_EB : WFAdv PrOrcl PrPriv Gadv Gcomm EB A.
 Proof.
  unfold EB.
  intros; apply WFAdv_trans with E.
  exact EqOP.
  exact EqAD.
  discriminate.
  discriminate.
  trivial.
 Qed.

 Lemma A'_wf_EB : WFAdv PrOrcl PrPriv Gadv Gcomm EB A'.
 Proof.
  unfold EB.
  intros; apply WFAdv_trans with E.
  exact EqOP.
  exact EqAD.
  discriminate.
  discriminate.
  trivial.
 Qed.

 Definition iEEB :=
  let iKG := add_refl_info KG (empty_info E EB) in
  let iEnc := add_refl_info_O Enc (fv_expr Enc_res) Vset.empty Vset.empty iKG in
  let iA := add_adv_info_false EqAD A_wf iEnc in
  add_adv_info_false EqAD A'_wf iA.

 Definition iEBEB :=
  let iKG := add_refl_info KG (empty_info EB EB) in
  let iEnc := add_refl_info_O Enc (fv_expr Enc_res) Vset.empty Vset.empty iKG in
  let iA := add_adv_info_lossless
   EqADB A_wf_EB (fun _ => A_lossless) (fun _ => A_lossless) iEnc in
  let iA' := add_adv_info_lossless
   EqADB A'_wf_EB (fun _ => A'_lossless) (fun _ => A'_lossless) iA in
  add_refl_info B iA'.

 (** Input variables *)
 Definition I := Gadv.

 Lemma EqObs_G1_bG2 :
  EqObs I EB G1 EB G2 (fv_expr (b =?= b')).
 Proof.
  unfold G1, G2.
  apply EqObs_trans with EB
   [
    x <$- [0..q-!1];
    y <$- [0..q-!1];
    m <c- A with {g ^ x};
    b <$- {0,1};
    If b then [ mb <- Efst (m) ] else [ mb <- Esnd (m) ];
    z <$- [0..q-!1];
    zeta <- g ^ z;
    b' <c- A' with {g ^ x, g ^ y, zeta}
   ].
  eqobs_hd_n iEBEB 5%nat.
  eqobs_tl iEBEB.
  union_mod iEBEB.
  apply mult_uniform; discriminate.

  deadcode iEBEB.
  swap iEBEB.
  eqobs_in iEBEB.
 Qed.

 Lemma claim_1 : forall k (m:Mem.t k),
  Pr EB G1 m (EP k (b =?= b')) == [1/2].
 Proof.
  intros.
  transitivity (Pr EB G2 m (EP k (b =?= b'))).
  apply EqObs_Pr with I; exact EqObs_G1_bG2.
  change G2 with (rev (tail (rev G2)) ++ [b <$- {0,1}]).
  apply Pr_sample_bool; [discriminate | ].
  apply is_lossless_correct with (refl1_info iEBEB); vm_compute; trivial.
 Qed.

 Lemma claim_2a : forall k (m:Mem.t k),
  Pr E ElGamal m (EP k (b =?= b')) == Pr EB DDH0_B m (EP k d).
 Proof.
  unfold ElGamal, DDH0_B, DDH0; intros k m0.
  rewrite Pr_d_eq.
  apply EqObs_Pr with I.
  apply EqObs_trans with EB (G0 ++ [d <- (b =?= b')]).

  (* REMARK: we could use [sinline_l] instead *)
  inline_l iEEB KG.
  inline_l iEEB Enc.
  ep iEEB.
  deadcode iEEB.
  swap iEEB.
  eqobs_in iEEB.

  sinline_r iEBEB B.
  eqobs_in iEBEB.
 Qed.

 Lemma claim_2b : forall k (m:Mem.t k),
  Pr EB G1 m (EP k (b =?= b')) == Pr EB DDH1_B m (EP k d).
 Proof.
  unfold DDH1_B, DDH1; intros.
  rewrite Pr_d_eq.
  apply EqObs_Pr with I.
  sinline_r iEBEB B.
  swap iEBEB.
  eqobs_in iEBEB.
 Qed.

 Definition B_advantage := DDH_advantage x y z d 3 EB.

 Lemma claim_2 : forall k (m:Mem.t k),
  Uabs_diff (Pr E ElGamal m (EP k (b =?= b'))) (Pr EB G1 m (EP k (b =?= b'))) ==
  B_advantage m.
 Proof.
  intros; apply Uabs_diff_morphism.
  apply claim_2a.
  apply claim_2b.
 Qed.

 Lemma claim_3  : forall k m,
  Uabs_diff (Pr E ElGamal m (EP k (b =?= b'))) [1/2] == B_advantage m.
 Proof.
  intros; rewrite <- claim_2, claim_1; trivial.
 Qed.

 Definition pi : PPT_info EB :=
  PPT_add_adv_info (PPT_add_adv_info (PPT_empty_info EB) A'_PPT) A_PPT.

 Lemma ElGamal_semantic_security : forall m,
  negligible (fun k => Uabs_diff (Pr E ElGamal (m k) (EP k (b =?= b'))) [1/2]).
 Proof.
  intro m.
  apply negligible_eq_stable with (fun k => B_advantage (m k)).
  intro; symmetry; apply claim_3.
  apply DDH_assumption; try discriminate; trivial.
  apply is_lossless_correct with (refl1_info iEBEB); vm_compute; trivial.
  PPT_proc_tac pi.
 Qed.

End ADVERSARY_AND_PROOF.

End SECURITY_PROOF.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__10__12.
Require Export lemma__8__3.
Require Export lemma__congruenceflip.
Require Export lemma__congruencesymmetric.
Require Export lemma__layoff.
Require Export lemma__ray5.
Require Export lemma__rightangleNC.
Require Export lemma__sameside2.
Require Export logic.
Require Export proposition__07.
Definition lemma__erectedperpendicularunique : forall A B C E, (euclidean__defs.Per A B C) -> ((euclidean__defs.Per A B E) -> ((euclidean__defs.OS C E A B) -> (euclidean__defs.Out B C E))).
Proof.
intro A.
intro B.
intro C.
intro E.
intro H.
intro H0.
intro H1.
assert (exists D, (euclidean__axioms.BetS A B D) /\ ((euclidean__axioms.Cong A B D B) /\ ((euclidean__axioms.Cong A C D C) /\ (euclidean__axioms.neq B C)))) as H2 by exact H.
destruct H2 as [D H3].
destruct H3 as [H4 H5].
destruct H5 as [H6 H7].
destruct H7 as [H8 H9].
assert (* Cut *) (euclidean__axioms.neq B E) as H10.
- assert (exists X, (euclidean__axioms.BetS A B X) /\ ((euclidean__axioms.Cong A B X B) /\ ((euclidean__axioms.Cong A E X E) /\ (euclidean__axioms.neq B E)))) as H10 by exact H0.
assert (exists X, (euclidean__axioms.BetS A B X) /\ ((euclidean__axioms.Cong A B X B) /\ ((euclidean__axioms.Cong A E X E) /\ (euclidean__axioms.neq B E)))) as __TmpHyp by exact H10.
destruct __TmpHyp as [x H11].
destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
assert (exists X, (euclidean__axioms.BetS A B X) /\ ((euclidean__axioms.Cong A B X B) /\ ((euclidean__axioms.Cong A C X C) /\ (euclidean__axioms.neq B C)))) as H18 by exact H.
assert (exists X, (euclidean__axioms.BetS A B X) /\ ((euclidean__axioms.Cong A B X B) /\ ((euclidean__axioms.Cong A C X C) /\ (euclidean__axioms.neq B C)))) as __TmpHyp0 by exact H18.
destruct __TmpHyp0 as [x0 H19].
destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
exact H17.
- assert (* Cut *) (exists H11, (euclidean__defs.Out B E H11) /\ (euclidean__axioms.Cong B H11 B C)) as H11.
-- apply (@lemma__layoff.lemma__layoff B E B C H10 H9).
-- destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
assert (* Cut *) (B = B) as H16.
--- apply (@logic.eq__refl Point B).
--- assert (* Cut *) (euclidean__axioms.Col A B B) as H17.
---- right.
right.
left.
exact H16.
---- assert (* Cut *) (euclidean__defs.OS C H12 A B) as H18.
----- apply (@lemma__sameside2.lemma__sameside2 A B B C E H12 H1 H17 H14).
----- assert (* Cut *) (euclidean__defs.Per A B H12) as H19.
------ apply (@lemma__8__3.lemma__8__3 A B E H12 H0 H14).
------ assert (* Cut *) (euclidean__axioms.Cong B C B H12) as H20.
------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric B B H12 C H15).
------- assert (* Cut *) (euclidean__axioms.Cong A C A H12) as H21.
-------- apply (@lemma__10__12.lemma__10__12 A B C H12 H H19 H20).
-------- assert (* Cut *) (euclidean__axioms.Cong C A H12 A) as H22.
--------- assert (* Cut *) ((euclidean__axioms.Cong C A H12 A) /\ ((euclidean__axioms.Cong C A A H12) /\ (euclidean__axioms.Cong A C H12 A))) as H22.
---------- apply (@lemma__congruenceflip.lemma__congruenceflip A C A H12 H21).
---------- destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
exact H23.
--------- assert (* Cut *) (euclidean__axioms.Cong C B H12 B) as H23.
---------- assert (* Cut *) ((euclidean__axioms.Cong C B H12 B) /\ ((euclidean__axioms.Cong C B B H12) /\ (euclidean__axioms.Cong B C H12 B))) as H23.
----------- apply (@lemma__congruenceflip.lemma__congruenceflip B C B H12 H20).
----------- destruct H23 as [H24 H25].
destruct H25 as [H26 H27].
exact H24.
---------- assert (* Cut *) (~(A = B)) as H24.
----------- intro H24.
assert (* Cut *) (euclidean__axioms.Col A B C) as H25.
------------ left.
exact H24.
------------ assert (* Cut *) (euclidean__axioms.nCol A B C) as H26.
------------- apply (@lemma__rightangleNC.lemma__rightangleNC A B C H).
------------- apply (@euclidean__tactics.Col__nCol__False A B C H26 H25).
----------- assert (* Cut *) (C = H12) as H25.
------------ apply (@proposition__07.proposition__07 A B C H12 H24 H22 H23 H18).
------------ assert (* Cut *) (euclidean__defs.Out B E C) as H26.
------------- apply (@eq__ind__r euclidean__axioms.Point H12 (fun C0 => (euclidean__defs.Per A B C0) -> ((euclidean__defs.OS C0 E A B) -> ((euclidean__axioms.Cong A C0 D C0) -> ((euclidean__axioms.neq B C0) -> ((euclidean__axioms.Cong B H12 B C0) -> ((euclidean__defs.OS C0 H12 A B) -> ((euclidean__axioms.Cong B C0 B H12) -> ((euclidean__axioms.Cong A C0 A H12) -> ((euclidean__axioms.Cong C0 A H12 A) -> ((euclidean__axioms.Cong C0 B H12 B) -> (euclidean__defs.Out B E C0)))))))))))) with (x := C).
--------------intro H26.
intro H27.
intro H28.
intro H29.
intro H30.
intro H31.
intro H32.
intro H33.
intro H34.
intro H35.
exact H14.

-------------- exact H25.
-------------- exact H.
-------------- exact H1.
-------------- exact H8.
-------------- exact H9.
-------------- exact H15.
-------------- exact H18.
-------------- exact H20.
-------------- exact H21.
-------------- exact H22.
-------------- exact H23.
------------- assert (* Cut *) (euclidean__defs.Out B C E) as H27.
-------------- apply (@lemma__ray5.lemma__ray5 B E C H26).
-------------- exact H27.
Qed.


Require Import String ZArith Lia.
Require Export logic.

(* We need invariants to compute the WP *)
Definition inv_map := insn -> pred.

Search (Z -> Z -> bool).

Fixpoint wp (inv_map : inv_map) (insn : insn) (post : pred) : pred :=
  match insn with
  | Skip => post
  | x :== e => fun f => post (f [x --> eval_expr f e])
  | (i1 ; i2) => wp inv_map i1 (wp inv_map i2 post)
  | If e Then i1 Else i2 =>
    fun f =>
      if Zneq_bool (eval_expr f e) 0
      then wp inv_map i1 post f
      else wp inv_map i2 post f
  | (While e Do body Done) =>
    fun f =>
      let I := inv_map insn in
      (forall g, I g -> eval_expr g e = 0 -> post g)
      /\
      (* anything about eval_expr f e <> 0? *)
      I f
  end.

(* FIXME: this definition... *)
Definition inv_map_correct (inv_map : inv_map) : Prop :=
  forall e body,
    let I := inv_map (While e Do body Done) in
    hoare (fun f => eval_expr f e <> 0 /\ I f) body I.

Theorem wp_sound : forall inv_map post insn,
    inv_map_correct inv_map ->
    hoare (wp inv_map insn post) insn post.
Proof.
Admitted.

Theorem wp_complete : forall inv_map pre post insn,
    inv_map_correct inv_map ->
    hoare pre insn post ->
    forall f, pre f -> wp inv_map insn post f.
Proof.
Admitted.