Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e389m21_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e194m33_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e255m765_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


(** Truncated polynomial, i.e. polynom mod X^n *)
(******************************************************************************)
(*       Copyright (C) 2019 Florent Hivert <florent.hivert@lri.fr>            *)
(*                                                                            *)
(*  Distributed under the terms of the GNU General Public License (GPL)       *)
(*                                                                            *)
(*    This code 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.                                *)
(*                                                                            *)
(*  The full text of the GPL is available at:                                 *)
(*                                                                            *)
(*                  http://www.gnu.org/licenses/                              *)
(******************************************************************************)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice.
From mathcomp Require Import fintype div tuple finfun bigop finset fingroup.
From mathcomp Require Import perm ssralg poly polydiv mxpoly binomial bigop.
From mathcomp Require Import finalg zmodp matrix mxalgebra polyXY ring_quotient.
From mathcomp Require Import generic_quotient.

Require Import auxresults.

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

Import GRing.
Local Open Scope ring_scope.

Module ComAlgebra.

Section ClassDef.

Variable R : ringType. (* Should this be comRingType ? *)

Record class_of (T : Type) : Type := Class {
  base : Algebra.class_of R T;
  mixin : commutative (Ring.mul base)
}.
Definition base2 R m := ComRing.Class (@mixin R m).
Local Coercion base : class_of >-> Algebra.class_of.
Local Coercion base2 : class_of >-> ComRing.class_of.

Structure type (phR : phant R) := Pack {sort; _ : class_of sort}.
Local Coercion sort : type >-> Sortclass.
Variable (phR : phant R) (T : Type) (cT : type phR).
Definition class := let: Pack _ c as cT' := cT return class_of cT' in c.
Let xT := let: Pack T _ := cT in T.
Notation xclass := (class : class_of xT).

Definition pack :=
  fun bT b & phant_id (@Algebra.class R phR bT) (b : Algebra.class_of R T) =>
  fun mT m & phant_id (ComRing.mixin (ComRing.class mT)) m =>
  Pack (Phant R) (@Class T b m).

Definition eqType := @Equality.Pack cT xclass.
Definition choiceType := @Choice.Pack cT xclass.
Definition zmodType := @Zmodule.Pack cT xclass.
Definition ringType := @Ring.Pack cT xclass.
Definition comRingType := @ComRing.Pack cT xclass.
Definition lmodType := @Lmodule.Pack R phR cT xclass.
Definition lalgType := @Lalgebra.Pack R phR cT xclass.
Definition algType := @Algebra.Pack R phR cT xclass.
Definition lmod_comRingType := @Lmodule.Pack R phR comRingType xclass.
Definition lalg_comRingType := @Lalgebra.Pack R phR comRingType xclass.
Definition alg_comRingType := @Algebra.Pack R phR comRingType xclass.

End ClassDef.

Module Exports.
Coercion base : class_of >-> Algebra.class_of.
Coercion base2 : class_of >-> ComRing.class_of.
Coercion sort : type >-> Sortclass.
Bind Scope ring_scope with sort.
Coercion eqType : type >-> Equality.type.
Canonical eqType.
Coercion choiceType : type >-> Choice.type.
Canonical choiceType.
Coercion zmodType : type >-> Zmodule.type.
Canonical zmodType.
Coercion ringType : type >-> Ring.type.
Canonical ringType.
Coercion comRingType : type >-> ComRing.type.
Canonical comRingType.
Coercion lmodType : type >-> Lmodule.type.
Canonical lmodType.
Coercion lalgType : type >-> Lalgebra.type.
Canonical lalgType.
Coercion algType : type >-> Algebra.type.
Canonical algType.
Canonical lmod_comRingType.
Canonical lalg_comRingType.
Canonical alg_comRingType.

Notation comAlgType R := (type (Phant R)).
Notation "[ 'comAlgType' R 'of' T ]" := (@pack _ (Phant R) T _ _ id _ _ id)
  (at level 0, format "[ 'comAlgType'  R  'of'  T ]") : form_scope.
End Exports.

End ComAlgebra.
Import ComAlgebra.Exports.

Section Tests.

Variable R : comRingType.
Let polyCA := [comAlgType R of {poly R}].

Variable A : comAlgType R.

Example test (c : R) (x y : A) : x * (c *: y) = y * (c *: x).
Proof. by rewrite mulrC -scalerAl scalerAr. Qed.

End Tests.

Module ComUnitAlgebra.

Section ClassDef.

Variable R : ringType. (* Should this be comRingType ? *)

Record class_of (T : Type) : Type := Class {
  base : ComAlgebra.class_of R T;
  mixin : GRing.UnitRing.mixin_of (Ring.Pack base)
}.
Definition base2 R m := UnitAlgebra.Class (@mixin R m).
Local Coercion base : class_of >-> ComAlgebra.class_of.
Local Coercion base2 : class_of >-> UnitAlgebra.class_of.

Structure type (phR : phant R) := Pack {sort; _ : class_of sort}.
Local Coercion sort : type >-> Sortclass.
Variable (phR : phant R) (T : Type) (cT : type phR).
Definition class := let: Pack _ c as cT' := cT return class_of cT' in c.
Let xT := let: Pack T _ := cT in T.
Notation xclass := (class : class_of xT).

Definition pack :=
  fun bT b & phant_id (@Algebra.class R phR bT) (b : ComAlgebra.class_of R T) =>
  fun mT m & phant_id (UnitRing.mixin (UnitRing.class mT)) m =>
  Pack (Phant R) (@Class T b m).

Definition eqType := @Equality.Pack cT xclass.
Definition choiceType := @Choice.Pack cT xclass.
Definition zmodType := @Zmodule.Pack cT xclass.
Definition ringType := @Ring.Pack cT xclass.
Definition unitRingType := @UnitRing.Pack cT xclass.
Definition comRingType := @ComRing.Pack cT xclass.
Definition lmodType := @Lmodule.Pack R phR cT xclass.
Definition lalgType := @Lalgebra.Pack R phR cT xclass.
Definition algType := @Algebra.Pack R phR cT xclass.
Definition comAlgType := @ComAlgebra.Pack R phR cT xclass.
Definition unitAlgType := @UnitAlgebra.Pack R phR cT xclass.
Definition lmod_unitRingType := @Lmodule.Pack R phR unitRingType xclass.
Definition lalg_unitRingType := @Lalgebra.Pack R phR unitRingType xclass.
Definition alg_unitRingType := @Algebra.Pack R phR unitRingType xclass.

Definition comUnitRingType := @ComUnitRing.Pack cT xclass.

End ClassDef.

Module Exports.
Coercion base : class_of >-> Algebra.class_of.
Coercion base2 : class_of >-> ComRing.class_of.
Coercion sort : type >-> Sortclass.
Bind Scope ring_scope with sort.
Coercion eqType : type >-> Equality.type.
Canonical eqType.
Coercion choiceType : type >-> Choice.type.
Canonical choiceType.
Coercion zmodType : type >-> Zmodule.type.
Canonical zmodType.
Coercion ringType : type >-> Ring.type.
Canonical ringType.
Coercion comRingType : type >-> ComRing.type.
Canonical comRingType.
Coercion lmodType : type >-> Lmodule.type.
Canonical lmodType.
Coercion lalgType : type >-> Lalgebra.type.
Canonical lalgType.
Coercion algType : type >-> Algebra.type.
Canonical algType.
Canonical lmod_comRingType.
Canonical lalg_comRingType.
Canonical alg_comRingType.

Notation comAlgType R := (type (Phant R)).
Notation "[ 'comAlgType' R 'of' T ]" := (@pack _ (Phant R) T _ _ id _ _ id)
  (at level 0, format "[ 'comAlgType'  R  'of'  T ]") : form_scope.
End Exports.

End ComAlgebra.
Import ComAlgebra.Exports.


(** * Results about Topology *)
(** Author: Catherine LELAY. Jan 2016 - *)
(** Based on Bourbaki *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Export UniMath.Topology.Filters.
Require Import UniMath.Algebra.Groups.
Require Import UniMath.Algebra.DivisionRig.
Require Import UniMath.Algebra.ConstructiveStructures.

Section Open.

Context {X : UU}.
Context (O : (X → hProp) → hProp).

Definition isSetOfOpen_union :=
  ∏ P : (X → hProp) → hProp,
    (∏ A : X → hProp, P A → O A) → O (union P).
Lemma isaprop_isSetOfOpen_union :
  isaprop isSetOfOpen_union.
Proof.
  apply (impred_isaprop _ (λ _, isapropimpl _ _ (propproperty _))).
Qed.
Definition isSetOfOpen_finite_intersection :=
  ∏ (P : Sequence (X → hProp)), (∏ m, O (P m)) → O (finite_intersection P).
Lemma isaprop_isSetOfOpen_finite_intersection :
  isaprop isSetOfOpen_finite_intersection.
Proof.
  apply (impred_isaprop _ (λ _, isapropimpl _ _ (propproperty _))).
Qed.

Definition isSetOfOpen_htrue :=
  O (λ _, htrue).

Definition isSetOfOpen_and :=
  ∏ A B, O A → O B → O (λ x, A x ∧ B x).
Lemma isaprop_isSetOfOpen_and :
  isaprop isSetOfOpen_and.
Proof.
  apply impred_isaprop ; intros A.
  apply impred_isaprop ; intros B.
  apply isapropimpl, isapropimpl.
  now apply propproperty.
Qed.

Lemma isSetOfOpen_hfalse :
  isSetOfOpen_union
  → O (λ _ : X, hfalse).
Proof.
  intros H0.
  rewrite <- union_hfalse.
  apply H0.
  intro.
  apply fromempty.
Qed.

Lemma isSetOfOpen_finite_intersection_htrue :
  isSetOfOpen_finite_intersection
  → isSetOfOpen_htrue.
Proof.
  intro H0.
  unfold isSetOfOpen_htrue.
  rewrite <- finite_intersection_htrue.
  apply H0.
  intros m.
  induction (nopathsfalsetotrue (pr2 m)).
Qed.

Lemma isSetOfOpen_finite_intersection_and :
  isSetOfOpen_finite_intersection
  → isSetOfOpen_and.
Proof.
  intros H0 A B Ha Hb.
  rewrite <- finite_intersection_and.
  apply H0.
  intros m ; simpl.
  induction m as [m Hm].
  now induction m.
Qed.
Lemma isSetOfOpen_finite_intersection_carac :
  isSetOfOpen_htrue
  → isSetOfOpen_and
  → isSetOfOpen_finite_intersection.
Proof.
  intros Htrue Hpair L.
  apply (pr2 (finite_intersection_hProp O)).
  split.
  - exact Htrue.
  - exact Hpair.
Qed.

Definition isSetOfOpen :=
  isSetOfOpen_union × isSetOfOpen_finite_intersection.

End Open.

Definition isTopologicalSpace (X : hSet) :=
  ∑ O : (X → hProp) → hProp, isSetOfOpen O.
Definition TopologicalSpace := ∑ X : hSet, isTopologicalSpace X.

Definition make_TopologicalSpace (X : hSet) (O : (X → hProp) → hProp)
           (is : isSetOfOpen_union O)
           (is0 : isSetOfOpen_htrue O)
           (is1 : isSetOfOpen_and O) : TopologicalSpace :=
  (X,,O,,is,,(isSetOfOpen_finite_intersection_carac _ is0 is1)).

Definition pr1TopologicatSpace : TopologicalSpace → hSet := pr1.
Coercion pr1TopologicatSpace : TopologicalSpace >-> hSet.

Definition isOpen {T : TopologicalSpace} : (T → hProp) → hProp := pr1 (pr2 T).
Definition Open {T : TopologicalSpace} :=
  ∑ O : T → hProp, isOpen O.
Definition pr1Open {T : TopologicalSpace} : Open → (T → hProp) := pr1.
Coercion pr1Open : Open >-> Funclass.

Section Topology_pty.

Context {T : TopologicalSpace}.

Lemma isOpen_union :
  ∏ P : (T → hProp) → hProp,
    (∏ A : T → hProp, P A → isOpen A)
    → isOpen (union P).
Proof.
  apply (pr1 (pr2 (pr2 T))).
Qed.
Lemma isOpen_finite_intersection :
  ∏ (P : Sequence (T → hProp)),
    (∏ m , isOpen (P m))
    → isOpen (finite_intersection P).
Proof.
  apply (pr2 (pr2 (pr2 T))).
Qed.

Lemma isOpen_hfalse :
  isOpen (λ _ : T, hfalse).
Proof.
  apply isSetOfOpen_hfalse.
  intros P H.
  now apply isOpen_union.
Qed.
Lemma isOpen_htrue :
  isOpen (λ _ : T, htrue).
Proof.
  rewrite <- finite_intersection_htrue.
  apply isOpen_finite_intersection.
  intros m.
  induction (nopathsfalsetotrue (pr2 m)).
Qed.
Lemma isOpen_and :
  ∏ A B : T → hProp,
    isOpen A → isOpen B → isOpen (λ x : T, A x ∧ B x).
Proof.
  apply isSetOfOpen_finite_intersection_and.
  intros P Hp.
  apply isOpen_finite_intersection.
  apply Hp.
Qed.
Lemma isOpen_or :
  ∏ A B : T → hProp,
    isOpen A → isOpen B → isOpen (λ x : T, A x ∨ B x).
Proof.
  intros A B Ha Hb.
  rewrite <- union_or.
  apply isOpen_union.
  intros C.
  apply hinhuniv.
  apply sumofmaps ; intros ->.
  - exact Ha.
  - exact Hb.
Qed.

End Topology_pty.

(** ** Neighborhood *)

Section Neighborhood.

Context {T : TopologicalSpace}.

Definition neighborhood (x : T) : (T → hProp) → hProp :=
  λ P : T → hProp, ∃ O : Open, O x × (∏ y : T, O y → P y).

Lemma neighborhood_isOpen (P : T → hProp) :
  (∏ x, P x → neighborhood x P) <-> isOpen P.
Proof.
  split.
  - intros Hp.
    assert (H : ∏ A : T → hProp, isaprop (∏ y : T, A y → P y)).
    { intros A.
      apply impred_isaprop.
      intro y.
      apply isapropimpl.
      apply propproperty. }
    set (Q := λ A : T → hProp, isOpen A ∧ (make_hProp (∏ y : T, A y → P y) (H A))).
    assert (X : P = (union Q)).
    { apply funextfun.
      intros x.
      apply hPropUnivalence.
      - intros Px.
        generalize (Hp _ Px).
        apply hinhfun.
        intros A.
        exists (pr1 A) ; split.
        + split.
          * apply (pr2 (pr1 A)).
          * exact (pr2 (pr2 A)).
        + exact (pr1 (pr2 A)).
      - apply hinhuniv.
        intros A.
        apply (pr2 (pr1 (pr2 A))).
        exact (pr2 (pr2 A)). }
    rewrite X.
    apply isOpen_union.
    intros A Ha.
    apply (pr1 Ha).
  - intros Hp x Px.
    apply hinhpr.
    exists (P,,Hp).
    split.
    + exact Px.
    + intros y Py.
      exact Py.
Qed.

Lemma neighborhood_imply :
  ∏ (x : T) (P Q : T → hProp),
    (∏ y : T, P y → Q y) → neighborhood x P → neighborhood x Q.
Proof.
  intros x P Q H.
  apply hinhfun.
  intros O.
  exists (pr1 O).
  split.
  - apply (pr1 (pr2 O)).
  - intros y Hy.
    apply H.
    apply (pr2 (pr2 O)).
    exact Hy.
Qed.
Lemma neighborhood_forall :
  ∏ (x : T) (P : T → hProp),
    (∏ y, P y) → neighborhood x P.
Proof.
  intros x P H.
  apply hinhpr.
  exists ((λ _ : T, htrue),,isOpen_htrue).
  split.
  - reflexivity.
  - intros y _.
    now apply H.
Qed.
Lemma neighborhood_and :
  ∏ (x : T) (A B : T → hProp),
    neighborhood x A → neighborhood x B → neighborhood x (λ y, A y ∧ B y).
Proof.
  intros x A B.
  apply hinhfun2.
  intros Oa Ob.
  exists ((λ x, pr1 Oa x ∧ pr1 Ob x) ,, isOpen_and _ _ (pr2 (pr1 Oa)) (pr2 (pr1 Ob))).
  simpl.
  split.
  - split.
    + apply (pr1 (pr2 Oa)).
    + apply (pr1 (pr2 Ob)).
  - intros y Hy.
    split.
    + apply (pr2 (pr2 Oa)).
      apply (pr1 Hy).
    + apply (pr2 (pr2 Ob)).
      apply (pr2 Hy).
Qed.
Lemma neighborhood_point :
  ∏ (x : T) (P : T → hProp),
    neighborhood x P → P x.
Proof.
  intros x P.
  apply hinhuniv.
  intros O.
  apply (pr2 (pr2 O)).
  apply (pr1 (pr2 O)).
Qed.

Lemma neighborhood_neighborhood :
  ∏ (x : T) (P : T → hProp),
    neighborhood x P
    → ∃ Q : T → hProp, neighborhood x Q
                        × ∏ y : T, Q y → neighborhood y P.
Proof.
  intros x P.
  apply hinhfun.
  intros Q.
  exists (pr1 Q).
  split.
  - apply (pr2 (neighborhood_isOpen _)).
    + apply (pr2 (pr1 Q)).
    + apply (pr1 (pr2 Q)).
  - intros y Qy.
    apply hinhpr.
    exists (pr1 Q).
    split.
    + exact Qy.
    + exact (pr2 (pr2 Q)).
Qed.

End Neighborhood.

Definition locally {T : TopologicalSpace} (x : T) : Filter T.
Proof.
  simple refine (make_Filter _ _ _ _ _).
  - apply (neighborhood x).
  - abstract (intros A B ;
              apply neighborhood_imply).
  - abstract (apply (pr2 (neighborhood_isOpen _)) ;
              [ apply isOpen_htrue |
                apply tt]).
  - abstract (intros A B ;
              apply neighborhood_and).
  - abstract (intros A Ha ;
              apply hinhpr ;
              exists x ;
              now apply neighborhood_point in Ha).
Defined.

(** ** Base of Neighborhood *)

Definition is_base_of_neighborhood {T : TopologicalSpace} (x : T) (B : (T → hProp) → hProp) :=
  (∏ P : T → hProp, B P → neighborhood x P)
    × (∏ P : T → hProp, neighborhood x P → ∃ Q : T → hProp, B Q × (∏ t : T, Q t → P t)).

Definition base_of_neighborhood {T : TopologicalSpace} (x : T) :=
  ∑ (B : (T → hProp) → hProp), is_base_of_neighborhood x B.
Definition pr1base_of_neighborhood {T : TopologicalSpace} (x : T) :
  base_of_neighborhood x → ((T → hProp) → hProp) := pr1.
Coercion pr1base_of_neighborhood : base_of_neighborhood >-> Funclass.

Section base_default.

Context {T : TopologicalSpace} (x : T).

Definition base_default : (T → hProp) → hProp :=
  λ P : T → hProp, isOpen P ∧ P x.

Lemma base_default_1 :
  ∏ P : T → hProp, base_default P → neighborhood x P.
Proof.
  intros P Hp.
  apply hinhpr.
  exists (P,,(pr1 Hp)) ; split.
  - exact (pr2 Hp).
  - intros. assumption.
Qed.
Lemma base_default_2 :
  ∏ P : T → hProp, neighborhood x P → ∃ Q : T → hProp, base_default Q × (∏ t : T, Q t → P t).
Proof.
  intros P.
  apply hinhfun.
  intros Q.
  exists (pr1 Q).
  repeat split.
  - exact (pr2 (pr1 Q)).
  - exact (pr1 (pr2 Q)).
  - exact (pr2 (pr2 Q)).
Qed.

End base_default.

Definition base_of_neighborhood_default {T : TopologicalSpace} (x : T) : base_of_neighborhood x.
Proof.
  exists (base_default x).
  split.
  - now apply base_default_1.
  - now apply base_default_2.
Defined.

Definition neighborhood' {T : TopologicalSpace} (x : T) (B : base_of_neighborhood x) : (T → hProp) → hProp :=
  λ P : T → hProp, ∃ O : T → hProp, B O × (∏ t : T, O t → P t).

Lemma neighborhood_equiv {T : TopologicalSpace} (x : T) (B : base_of_neighborhood x) :
  ∏ P, neighborhood' x B P <-> neighborhood x P.
Proof.
  split.
  - apply hinhuniv.
    intros O.
    generalize ((pr1 (pr2 B)) (pr1 O) (pr1 (pr2 O))).
    apply neighborhood_imply.
    exact (pr2 (pr2 O)).
  - intros Hp.
    generalize (pr2 (pr2 B) P Hp).
    apply hinhfun.
    intros O.
    exists (pr1 O).
    exact (pr2 O).
Qed.

(** ** Some topologies *)

(** *** Topology from neighborhood *)

Definition isNeighborhood {X : UU} (B : X → (X → hProp) → hProp) :=
  (∏ x, isfilter_imply (B x))
    × (∏ x, isfilter_htrue (B x))
    × (∏ x, isfilter_and (B x))
    × (∏ x P, B x P → P x)
    × (∏ x P, B x P → ∃ Q, B x Q × ∏ y, Q y → B y P).

Lemma isNeighborhood_neighborhood {T : TopologicalSpace} :
  isNeighborhood (neighborhood (T := T)).
Proof.
  repeat split.
  - intros x A B.
    apply (neighborhood_imply x).
  - intros x.
    apply (pr2 (neighborhood_isOpen _)).
    + exact (isOpen_htrue (T := T)).
    + apply tt.
  - intros A B.
    apply neighborhood_and.
  - intros x P.
    apply neighborhood_point.
  - intros x P.
    apply neighborhood_neighborhood.
Qed.

Section TopologyFromNeighborhood.

Context {X : hSet}.
Context (N : X → (X → hProp) → hProp).
Context (Himpl : ∏ x, isfilter_imply (N x))
        (Htrue : ∏ x, isfilter_htrue (N x))
        (Hand : ∏ x, isfilter_and (N x))
        (Hpt : ∏ x P, N x P → P x)
        (H : ∏ x P, N x P → ∃ Q, N x Q × ∏ y, Q y → N y P).

Definition topologyfromneighborhood (A : X → hProp) :=
  ∏ x : X, A x → N x A.
Lemma isaprop_topologyfromneighborhood :
  ∏ A, isaprop (topologyfromneighborhood A).
Proof.
  intros A.
  apply impred_isaprop ; intros x ;
  apply isapropimpl, propproperty.
Qed.

Lemma topologyfromneighborhood_open :
  isSetOfOpen_union
   (λ A : X → hProp,
          make_hProp (topologyfromneighborhood A)
                    (isaprop_topologyfromneighborhood A)).
Proof.
  intros L Hl x.
  apply hinhuniv.
  intros A.
  apply Himpl with (pr1 A).
  - intros y Hy.
    apply hinhpr.
    now exists (pr1 A), (pr1 (pr2 A)).
  - apply Hl.
    + exact (pr1 (pr2 A)).
    + exact (pr2 (pr2 A)).
Qed.

End TopologyFromNeighborhood.

Definition TopologyFromNeighborhood {X : hSet}
  (N : X → (X → hProp) → hProp)
  (H : isNeighborhood N)
  : TopologicalSpace.
Proof.
  use make_TopologicalSpace.
  - apply X.
  - intros A.
    simple refine (make_hProp _ _).
    + apply (topologyfromneighborhood N A).
    + apply isaprop_topologyfromneighborhood.
  - apply topologyfromneighborhood_open.
    apply (pr1 H).
  - intros x _.
    apply (pr1 (pr2 H)).
  - intros A B Ha Hb x Hx.
    apply (pr1 (pr2 (pr2 H))).
    + now apply Ha, (pr1 Hx).
    + now apply Hb, (pr2 Hx).
Defined.

Lemma TopologyFromNeighborhood_correct {X : hSet}
  (N : X → (X → hProp) → hProp)
  (H : isNeighborhood N)
  : ∏ (x : X) (P : X → hProp),
    N x P <-> neighborhood (T := TopologyFromNeighborhood N H) x P.
Proof.
  split.
  - intros Hx.
    apply hinhpr.
    simple refine (tpair _ _ _).
    + simple refine (tpair _ _ _).
      * intros y.
        apply (N y P).
      * simpl ; intros y Hy.
        generalize (pr2 (pr2 (pr2 (pr2 H))) _ _ Hy).
        apply hinhuniv.
        intros Q.
        apply (pr1 H) with (2 := pr1 (pr2 Q)).
        exact (pr2 (pr2 Q)).
    + split ; simpl.
      * exact Hx.
      * intros y.
        now apply (pr1 (pr2 (pr2 (pr2 H)))).
  - apply hinhuniv.
    intros O.
    apply (pr1 H) with (pr1 (pr1 O)).
    + apply (pr2 (pr2 O)).
    + simple refine (pr2 (pr1 O) _ _).
      exact (pr1 (pr2 O)).
Qed.

Lemma isNeighborhood_isPreFilter {X : hSet} N :
  isNeighborhood N -> ∏ x : X, isPreFilter (N x).
Proof.
  intros Hn x.
  split.
  - apply (pr1 Hn).
  - apply isfilter_finite_intersection_carac.
    + apply (pr1 (pr2 Hn)).
    + apply (pr1 (pr2 (pr2 Hn))).
Qed.
Lemma isNeighborhood_isFilter {X : hSet} N :
  isNeighborhood N -> ∏ x : X, isFilter (N x).
Proof.
  intros Hn x.
  split.
  - apply isNeighborhood_isPreFilter, Hn.
  - intros A Fa.
    apply hinhpr.
    exists x.
    apply ((pr1 (pr2 (pr2 (pr2 Hn)))) _ _ Fa).
Qed.

(** *** Generated Topology *)

Section topologygenerated.

Context {X : hSet} (O : (X → hProp) → hProp).

Definition topologygenerated :=
  λ (x : X) (A : X → hProp),
  (∃ L : Sequence (X → hProp), (∏ n, O (L n)) × (finite_intersection L x) × (∏ y, finite_intersection L y → A y)).

Lemma topologygenerated_imply :
  ∏ x : X, isfilter_imply (topologygenerated x).
Proof.
  intros x A B H.
  apply hinhfun.
  intros L.
  exists (pr1 L).
  repeat split.
  - exact (pr1 (pr2 L)).
  - exact (pr1 (pr2 (pr2 L))).
  - intros y Hy.
    apply H, (pr2 (pr2 (pr2 L))), Hy.
Qed.

Lemma topologygenerated_htrue :
  ∏ x : X, isfilter_htrue (topologygenerated x).
Proof.
  intros x.
  apply hinhpr.
  exists nil.
  repeat split; intros n; induction (nopathsfalsetotrue (pr2 n)).
Qed.

Lemma topologygenerated_and :
  ∏ x : X, isfilter_and (topologygenerated x).
Proof.
  intros x A B.
  apply hinhfun2.
  intros La Lb.
  exists (concatenate (pr1 La) (pr1 Lb)).
  repeat split.
  - simpl ; intro.
    apply (coprod_rect (λ x, O (coprod_rect _ _ _ x))) ; intros m.
    + rewrite coprod_rect_compute_1.
      exact (pr1 (pr2 La) _).
    + rewrite coprod_rect_compute_2.
      exact (pr1 (pr2 Lb) _).
  - simpl ; intro.
    apply (coprod_rect (λ y, (coprod_rect (λ _ : stn (length (pr1 La)) ⨿ stn (length (pr1 Lb)), X → hProp) (λ j : stn (length (pr1 La)), (pr1 La) j)
       (λ k : stn (length (pr1 Lb)), (pr1 Lb) k) y) x)) ; intros m.
    + rewrite coprod_rect_compute_1.
      exact (pr1 (pr2 (pr2 La)) _).
    + rewrite coprod_rect_compute_2.
      exact (pr1 (pr2 (pr2 Lb)) _).
  - apply (pr2 (pr2 (pr2 La))).
    intros n.
    simpl in X0.
    unfold concatenate' in X0.
    specialize (X0 (weqfromcoprodofstn_map (length (pr1 La)) (length (pr1 Lb)) (ii1 n))).
    now rewrite (weqfromcoprodofstn_eq1 _ _) , coprod_rect_compute_1 in X0.
  - apply (pr2 (pr2 (pr2 Lb))).
    intros n.
    simpl in X0.
    unfold concatenate' in X0.
    specialize (X0 (weqfromcoprodofstn_map (length (pr1 La)) (length (pr1 Lb)) (ii2 n))).
    now rewrite (weqfromcoprodofstn_eq1 _ _), coprod_rect_compute_2 in X0.
Qed.

Lemma topologygenerated_point :
  ∏ (x : X) (P : X → hProp), topologygenerated x P → P x.
Proof.
  intros x P.
  apply hinhuniv.
  intros L.
  apply (pr2 (pr2 (pr2 L))).
  exact (pr1 (pr2 (pr2 L))).
Qed.

Lemma topologygenerated_neighborhood :
∏ (x : X) (P : X → hProp),
 topologygenerated x P
 → ∃ Q : X → hProp,
    topologygenerated x Q × (∏ y : X, Q y → topologygenerated y P).
Proof.
  intros x P.
  apply hinhfun.
  intros L.
  exists (finite_intersection (pr1 L)).
  split.
  - apply hinhpr.
    exists (pr1 L).
    repeat split.
    + exact (pr1 (pr2 L)).
    + exact (pr1 (pr2 (pr2 L))).
    + intros. assumption.
  - intros y Hy.
    apply hinhpr.
    exists (pr1 L).
    repeat split.
    + exact (pr1 (pr2 L)).
    + exact Hy.
    + exact (pr2 (pr2 (pr2 L))).
Qed.

End topologygenerated.

Definition TopologyGenerated {X : hSet} (O : (X → hProp) → hProp) : TopologicalSpace.
Proof.
  simple refine (TopologyFromNeighborhood _ _).
  - apply X.
  - apply topologygenerated, O.
  - repeat split.
    + apply topologygenerated_imply.
    + apply topologygenerated_htrue.
    + apply topologygenerated_and.
    + apply topologygenerated_point.
    + apply topologygenerated_neighborhood.
Defined.

Lemma TopologyGenerated_included {X : hSet} :
  ∏ (O : (X → hProp) → hProp) (P : X → hProp),
    O P → isOpen (T := TopologyGenerated O) P.
Proof.
  intros O P Op.
  apply neighborhood_isOpen.
  intros x Hx.
  apply TopologyFromNeighborhood_correct.
  apply hinhpr.
  exists (singletonSequence P).
  repeat split.
  - induction n as [n Hn].
    exact Op.
  - intros n ;
    induction n as [n Hn].
    exact Hx.
  - intros y Hy.
    now apply (Hy (0%nat,,paths_refl _)).
Qed.
Lemma TopologyGenerated_smallest {X : hSet} :
  ∏ (O : (X → hProp) → hProp) (T : isTopologicalSpace X),
    (∏ P : X → hProp, O P → pr1 T P)
    → ∏ P : X → hProp, isOpen (T := TopologyGenerated O) P → pr1 T P.
Proof.
  intros O T Ht P Hp.
  apply (neighborhood_isOpen (T := (X,,T))).
  intros x Px.
  generalize (Hp x Px) ; clear Hp.
  apply hinhfun.
  intros L.
  simple refine (tpair _ _ _).
  - simple refine (tpair _ _ _).
    + apply (finite_intersection (pr1 L)).
    + apply (isOpen_finite_intersection (T := X,,T)).
      intros m.
      apply Ht.
      apply (pr1 (pr2 L)).
  - split.
    + exact (pr1 (pr2 (pr2 L))).
    + exact (pr2 (pr2 (pr2 L))).
Qed.

(** *** Product of topologies *)

Section topologydirprod.

Context (U V : TopologicalSpace).

Definition topologydirprod :=
  λ (z : U × V) (A : U × V → hProp),
  (∃ (Ax : U → hProp) (Ay : V → hProp),
      (Ax (pr1 z) × isOpen Ax)
        × (Ay (pr2 z) × isOpen Ay)
        × (∏ x y, Ax x → Ay y → A (x,,y))).

Lemma topologydirprod_imply :
  ∏ x : U × V, isfilter_imply (topologydirprod x).
Proof.
  intros x A B H.
  apply hinhfun.
  intros AB.
  exists (pr1 AB), (pr1 (pr2 AB)) ; split ; [ | split].
  - exact (pr1 (pr2 (pr2 AB))).
  - exact (pr1 (pr2 (pr2 (pr2 AB)))).
  - intros x' y' Hx' Hy'.
    now apply H, (pr2 (pr2 (pr2 (pr2 AB)))).
Qed.

Lemma topologydirprod_htrue :
  ∏ x : U × V, isfilter_htrue (topologydirprod x).
Proof.
  intros z.
  apply hinhpr.
  exists (λ _, htrue), (λ _, htrue).
  repeat split.
  - apply isOpen_htrue.
  - apply isOpen_htrue.
Qed.

Lemma topologydirprod_and :
  ∏ x : U × V, isfilter_and (topologydirprod x).
Proof.
  intros z A B.
  apply hinhfun2.
  intros A' B'.
  exists (λ x, pr1 A' x ∧ pr1 B' x), (λ y, pr1 (pr2 A') y ∧ pr1 (pr2 B') y).
  repeat split.
  - apply (pr1 (pr1 (pr2 (pr2 A')))).
  - apply (pr1 (pr1 (pr2 (pr2 B')))).
  - apply isOpen_and.
    + apply (pr2 (pr1 (pr2 (pr2 A')))).
    + apply (pr2 (pr1 (pr2 (pr2 B')))).
  - apply (pr1 (pr1 (pr2 (pr2 (pr2 A'))))).
  - apply (pr1 (pr1 (pr2 (pr2 (pr2 B'))))).
  - apply isOpen_and.
    + apply (pr2 (pr1 (pr2 (pr2 (pr2 A'))))).
    + apply (pr2 (pr1 (pr2 (pr2 (pr2 B'))))).
  - apply (pr2 (pr2 (pr2 (pr2 A')))).
    + apply (pr1 X).
    + apply (pr1 X0).
  - apply (pr2 (pr2 (pr2 (pr2 B')))).
    + apply (pr2 X).
    + apply (pr2 X0).
Qed.

Lemma topologydirprod_point :
  ∏ (x : U × V) (P : U × V → hProp), topologydirprod x P → P x.
Proof.
  intros xy A.
  apply hinhuniv.
  intros A'.
  apply (pr2 (pr2 (pr2 (pr2 A')))).
  - exact (pr1 (pr1 (pr2 (pr2 A')))).
  - exact (pr1 (pr1 (pr2 (pr2 (pr2 A'))))).
Qed.

Lemma topologydirprod_neighborhood :
  ∏ (x : U × V) (P : U × V → hProp),
    topologydirprod x P
    → ∃ Q : U × V → hProp,
      topologydirprod x Q
                      × (∏ y : U × V, Q y → topologydirprod y P).
Proof.
  intros xy P.
  apply hinhfun.
  intros A'.
  exists (λ z, pr1 A' (pr1 z) ∧ pr1 (pr2 A') (pr2 z)).
  split.
  - apply hinhpr.
    exists (pr1 A'), (pr1 (pr2 A')).
    split.
    + exact (pr1 (pr2 (pr2 A'))).
    + split.
      * exact (pr1 (pr2 (pr2 (pr2 A')))).
      * intros x' y' Ax' Ay'.
        now split.
  - intros z Az.
    apply hinhpr.
    exists (pr1 A'), (pr1 (pr2 A')).
    repeat split.
    + exact (pr1 Az).
    + exact (pr2 (pr1 (pr2 (pr2 A')))).
    + exact (pr2 Az).
    + exact (pr2 (pr1 (pr2 (pr2 (pr2 A'))))).
    + exact (pr2 (pr2 (pr2 (pr2 A')))).
Qed.

End topologydirprod.

Definition TopologyDirprod (U V : TopologicalSpace) : TopologicalSpace.
Proof.
  simple refine (TopologyFromNeighborhood _ _).
  - apply (U × V)%set.
  - apply topologydirprod.
  - repeat split.
    + apply topologydirprod_imply.
    + apply topologydirprod_htrue.
    + apply topologydirprod_and.
    + apply topologydirprod_point.
    + apply topologydirprod_neighborhood.
Defined.

Definition locally2d {T S : TopologicalSpace} (x : T) (y : S) : Filter (T × S) :=
  FilterDirprod (locally x) (locally y).

Lemma locally2d_correct {T S : TopologicalSpace} (x : T) (y : S) :
  ∏ P : T × S → hProp, locally2d x y P <-> locally (T := TopologyDirprod T S) (x,,y) P.
Proof.
  intros P.
  split ; apply hinhuniv.
  - intros A.
    apply TopologyFromNeighborhood_correct.
    generalize (pr1 (pr2 (pr2 A))) (pr1 (pr2 (pr2 (pr2 A)))).
    apply hinhfun2.
    intros Ox Oy.
    exists (pr1 Ox), (pr1 Oy).
    repeat split.
    + exact (pr1 (pr2 Ox)).
    + exact (pr2 (pr1 Ox)).
    + exact (pr1 (pr2 Oy)).
    + exact (pr2 (pr1 Oy)).
    + intros x' y' Hx' Hy'.
      apply (pr2 (pr2 (pr2 (pr2 A)))).
      * now apply (pr2 (pr2 Ox)).
      * now apply (pr2 (pr2 Oy)).
  - intros O.
    generalize (pr2 (pr1 O) _ (pr1 (pr2 O))).
    apply hinhfun.
    intros A.
    exists (pr1 A), (pr1 (pr2 A)).
    repeat split.
    + apply (pr2 (neighborhood_isOpen _)).
      * exact (pr2 (pr1 (pr2 (pr2 A)))).
      * exact (pr1 (pr1 (pr2 (pr2 A)))).
    + apply (pr2 (neighborhood_isOpen _)).
      * exact (pr2 (pr1 (pr2 (pr2 (pr2 A))))).
      * exact (pr1 (pr1 (pr2 (pr2 (pr2 A))))).
    + intros x' y' Ax' Ay'.
      apply (pr2 (pr2 O)).
      now apply (pr2 (pr2 (pr2 (pr2 A)))).
Qed.

(** *** Topology on a subtype *)

Section topologysubtype.

Context {T : TopologicalSpace} (dom : T → hProp).

Definition topologysubtype :=
  λ (x : ∑ x : T, dom x) (A : (∑ x0 : T, dom x0) → hProp),
  ∃ B : T → hProp,
    (B (pr1 x) × isOpen B) × (∏ y : ∑ x0 : T, dom x0, B (pr1 y) → A y).

Lemma topologysubtype_imply :
  ∏ x : ∑ x : T, dom x, isfilter_imply (topologysubtype x).
Proof.
  intros x A B H.
  apply hinhfun.
  intros A'.
  exists (pr1 A').
  split.
  - exact (pr1 (pr2 A')).
  - intros y Hy.
    now apply H, (pr2 (pr2 A')).
Qed.

Lemma topologysubtype_htrue :
  ∏ x : ∑ x : T, dom x, isfilter_htrue (topologysubtype x).
Proof.
  intros x.
  apply hinhpr.
  exists (λ _, htrue).
  repeat split.
  now apply isOpen_htrue.
Qed.

Lemma topologysubtype_and :
  ∏ x : ∑ x : T, dom x, isfilter_and (topologysubtype x).
Proof.
  intros x A B.
  apply hinhfun2.
  intros A' B'.
  exists (λ x, pr1 A' x ∧ pr1 B' x).
  repeat split.
  - exact (pr1 (pr1 (pr2 A'))).
  - exact (pr1 (pr1 (pr2 B'))).
  - apply isOpen_and.
    + exact (pr2 (pr1 (pr2 A'))).
    + exact (pr2 (pr1 (pr2 B'))).
  - apply (pr2 (pr2 A')), (pr1 X).
  - apply (pr2 (pr2 B')), (pr2 X).
Qed.

Lemma topologysubtype_point :
  ∏ (x : ∑ x : T, dom x) (P : (∑ x0 : T, dom x0) → hProp),
    topologysubtype x P → P x.
Proof.
  intros x A.
  apply hinhuniv.
  intros B.
  apply (pr2 (pr2 B)), (pr1 (pr1 (pr2 B))).
Qed.

Lemma topologysubtype_neighborhood :
  ∏ (x : ∑ x : T, dom x) (P : (∑ x0 : T, dom x0) → hProp),
    topologysubtype x P
    → ∃ Q : (∑ x0 : T, dom x0) → hProp,
      topologysubtype x Q
       × (∏ y : ∑ x0 : T, dom x0, Q y → topologysubtype y P).
Proof.
  intros x A.
  apply hinhfun.
  intros B.
  exists (λ y : ∑ x : T, dom x, pr1 B (pr1 y)).
  split.
  - apply hinhpr.
    exists (pr1 B).
    split.
    + exact (pr1 (pr2 B)).
    + intros.
      assumption.
  - intros y By.
    apply hinhpr.
    exists (pr1 B).
    repeat split.
    + exact By.
    + exact (pr2 (pr1 (pr2 B))).
    + exact (pr2 (pr2 B)).
Qed.

End topologysubtype.

Definition TopologySubtype {T : TopologicalSpace}
  (dom : T → hProp)
  : TopologicalSpace.
Proof.
  simple refine (TopologyFromNeighborhood _ _).
  - exact (carrier_subset dom).
  - apply topologysubtype.
  - repeat split.
    + apply topologysubtype_imply.
    + apply topologysubtype_htrue.
    + apply topologysubtype_and.
    + apply topologysubtype_point.
    + apply topologysubtype_neighborhood.
Defined.

(** ** Limits in a Topological Set *)

Section locally_base.

Context {T : TopologicalSpace} (x : T) (base : base_of_neighborhood x).

Lemma locally_base_imply :
  isfilter_imply (neighborhood' x base).
Proof.
  intros A B H Ha.
  apply (pr2 (neighborhood_equiv _ _ _)).
  eapply neighborhood_imply.
  - exact H.
  - eapply neighborhood_equiv.
    exact Ha.
Qed.
Lemma locally_base_htrue :
  isfilter_htrue (neighborhood' x base).
Proof.
  apply (pr2 (neighborhood_equiv _ _ _)).
  apply (pr2 (neighborhood_isOpen _)).
  - apply isOpen_htrue.
  - apply tt.
Qed.
Lemma locally_base_and :
  isfilter_and (neighborhood' x base).
Proof.
  intros A B Ha Hb.
  apply (pr2 (neighborhood_equiv _ _ _)).
  eapply neighborhood_and.
  - eapply neighborhood_equiv, Ha.
  - eapply neighborhood_equiv, Hb.
Qed.

End locally_base.

Definition locally_base {T : TopologicalSpace} (x : T) (base : base_of_neighborhood x) : Filter T.
Proof.
  simple refine (make_Filter _ _ _ _ _).
  - apply (neighborhood' x base).
  - apply locally_base_imply.
  - apply locally_base_htrue.
  - apply locally_base_and.
  - intros A Ha.
    apply neighborhood_equiv in Ha.
    apply neighborhood_point in Ha.
    apply hinhpr.
    now exists x.
Defined.

(** *** Limit of a filter *)

Definition is_filter_lim {T : TopologicalSpace} (F : Filter T) (x : T) :=
  filter_le F (locally x).
Definition ex_filter_lim  {T : TopologicalSpace} (F : Filter T) :=
  ∃ (x : T), is_filter_lim F x.

Definition is_filter_lim_base {T : TopologicalSpace} (F : Filter T) (x : T) base :=
  filter_le F (locally_base x base).
Definition ex_filter_lim_base  {T : TopologicalSpace} (F : Filter T) :=
  ∃ (x : T) base, is_filter_lim_base F x base.

Lemma is_filter_lim_base_correct {T : TopologicalSpace} (F : Filter T) (x : T) base :
  is_filter_lim_base F x base <-> is_filter_lim F x.
Proof.
  split.
  - intros Hx P HP.
    apply (pr2 (neighborhood_equiv _ base _)) in HP.
    apply Hx.
    exact HP.
  - intros Hx P HP.
    apply neighborhood_equiv in HP.
    apply Hx.
    exact HP.
Qed.
Lemma ex_filter_lim_base_correct {T : TopologicalSpace} (F : Filter T) :
  ex_filter_lim_base F <-> ex_filter_lim F.
Proof.
  split.
  - apply hinhfun.
    intros x.
    exists (pr1 x).
    eapply is_filter_lim_base_correct.
    exact (pr2 (pr2 x)).
  - apply hinhfun.
    intros x.
    exists (pr1 x), (base_of_neighborhood_default (pr1 x)).
    apply (pr2 (is_filter_lim_base_correct _ _ _)).
    exact (pr2 x).
Qed.

(** *** Limit of a function *)

Definition is_lim {X : UU} {T : TopologicalSpace} (f : X → T) (F : Filter X) (x : T) :=
  filterlim f F (locally x).

Definition ex_lim {X : UU} {T : TopologicalSpace} (f : X → T) (F : Filter X) :=
  ∃ (x : T), is_lim f F x.

Definition is_lim_base {X : UU} {T : TopologicalSpace} (f : X → T) (F : Filter X) (x : T) base :=
  filterlim f F (locally_base x base).
Definition ex_lim_base {X : UU} {T : TopologicalSpace} (f : X → T) (F : Filter X) :=
  ∃ (x : T) base, is_lim_base f F x base.

Lemma is_lim_base_correct {X : UU} {T : TopologicalSpace} (f : X → T) (F : Filter X) (x : T) base :
  is_lim_base f F x base <-> is_lim f F x.
Proof.
  split.
  - intros Hx P HP.
    apply Hx, (pr2 (neighborhood_equiv _ _ _)).
    exact HP.
  - intros Hx P HP.
    eapply Hx, neighborhood_equiv.
    exact HP.
Qed.
Lemma ex_lim_base_correct {X : UU} {T : TopologicalSpace} (f : X → T) (F : Filter X) :
  ex_lim_base f F <-> ex_lim f F.
Proof.
  split.
  - apply hinhfun.
    intros x.
    exists (pr1 x).
    eapply is_lim_base_correct.
    exact (pr2 (pr2 x)).
  - apply hinhfun.
    intros x.
    exists (pr1 x), (base_of_neighborhood_default (pr1 x)).
    apply (pr2 (is_lim_base_correct _ _ _ _)).
    exact (pr2 x).
Qed.

(** *** Continuity *)

Definition continuous_at {U V : TopologicalSpace} (f : U → V) (x : U) :=
  is_lim f (locally x) (f x).

Definition continuous_on {U V : TopologicalSpace} (dom : U → hProp) (f : ∏ (x : U), dom x → V) :=
  ∏ (x : U) (Hx : dom x),
    ∃ H,
      is_lim (λ y : (∑ x : U, dom x), f (pr1 y) (pr2 y)) (FilterSubtype (locally x) dom H) (f x Hx).
Definition continuous {U V : TopologicalSpace} (f : U → V) :=
  ∏ x : U, continuous_at f x.

Lemma isaprop_continuous (x y : TopologicalSpace)
  (f : x → y)
  : isaprop (continuous (λ x0 : x,  f x0)).
Proof.
  do 3 (apply impred_isaprop; intro).
  apply propproperty.
Qed.

Definition continuous_base_at {U V : TopologicalSpace} (f : U → V) (x : U) base_x base_fx :=
  is_lim_base f (locally_base x base_x) (f x) base_fx.

(** *** Continuity for 2 variable functions *)

Definition continuous2d_at {U V W : TopologicalSpace} (f : U → V → W) (x : U) (y : V) :=
  is_lim (λ z : U × V, f (pr1 z) (pr2 z)) (FilterDirprod (locally x) (locally y)) (f x y).
Definition continuous2d {U V W : TopologicalSpace} (f : U → V → W) :=
  ∏ (x : U) (y : V), continuous2d_at f x y.

Definition continuous2d_base_at {U V W : TopologicalSpace} (f : U → V → W)
           (x : U) (y : V) base_x base_y base_fxy :=
  is_lim_base (λ z : U × V, f (pr1 z) (pr2 z))
              (FilterDirprod (locally_base x base_x) (locally_base y base_y))
              (f x y) base_fxy.

(** *** Continuity of basic functions *)

Lemma continuous_comp {X : UU} {U V : TopologicalSpace}
  (f : X → U) (g : U → V) (F : Filter X) (l : U)
  : is_lim f F l → continuous_at g l →
    is_lim (funcomp f g) F (g l).
Proof.
  apply filterlim_comp.
Qed.

Lemma continuous_funcomp {X Y Z : TopologicalSpace} (f : X → Y) (g : Y → Z) :
  continuous f → continuous g →
  continuous (funcomp f g).
Proof.
  intros Hf Hg x.
  refine (continuous_comp _ _ _ _ _ _).
  - apply Hf.
  - apply Hg.
Qed.

Lemma continuous2d_comp {X : UU} {U V W : TopologicalSpace}
  (f : X → U) (g : X → V)
  (h : U → V → W)
  (F : Filter X)
  (lf : U) (lg : V)
  : is_lim f F lf → is_lim g F lg → continuous2d_at h lf lg →
    is_lim (λ x, h (f x) (g x)) F (h lf lg).
Proof.
  intros Hf Hg.
  apply (filterlim_comp (λ x, (f x ,, g x))).
  intros P.
  apply hinhuniv.
  intros Hp.
  generalize (filter_and F _ _ (Hf _ (pr1 (pr2 (pr2 Hp)))) (Hg _ (pr1 (pr2 (pr2 (pr2 Hp)))))).
  apply (filter_imply F).
  intros x Hx.
  apply (pr2 (pr2 (pr2 (pr2 Hp)))).
  - exact (pr1 Hx).
  - exact (pr2 Hx).
Qed.

Lemma continuous_tpair {U V : TopologicalSpace} :
  continuous2d (W := TopologyDirprod U V) (λ (x : U) (y : V), (x,,y)).
Proof.
  intros x y P.
  apply hinhuniv.
  intros O.
  simple refine (filter_imply _ _ _ _ _).
  - exact (pr1 O).
  - exact (pr2 (pr2 O)).
  - generalize (pr2 (pr1 O) _ (pr1 (pr2 O))).
    apply hinhfun.
    intros Ho.
    exists (pr1 Ho), (pr1 (pr2 Ho)).
    repeat split.
    + apply (pr2 (neighborhood_isOpen _)).
      * exact (pr2 (pr1 (pr2 (pr2 Ho)))).
      * exact (pr1 (pr1 (pr2 (pr2 Ho)))).
    + apply (pr2 (neighborhood_isOpen _)).
      * exact (pr2 (pr1 (pr2 (pr2 (pr2 Ho))))).
      * exact (pr1 (pr1 (pr2 (pr2 (pr2 Ho))))).
    + exact (pr2 (pr2 (pr2 (pr2 Ho)))).
Qed.
Lemma continuous_pr1 {U V : TopologicalSpace} :
  continuous (U := TopologyDirprod U V) (λ (xy : U × V), pr1 xy).
Proof.
  intros xy P.
  apply hinhuniv.
  intros O.
  simple refine (filter_imply _ _ _ _ _).
  - exact (pr1 (pr1 O)).
  - exact (pr2 (pr2 O)).
  - apply hinhpr.
    use tpair.
    + use tpair.
      * apply (λ xy : U × V, pr1 O (pr1 xy)).
      * intros xy' Oxy.
        apply hinhpr.
        exists (pr1 O), (λ _, htrue).
        repeat split.
        ** exact Oxy.
        ** exact (pr2 (pr1 O)).
        ** exact isOpen_htrue.
        ** intros.
           assumption.
    + repeat split.
      * exact (pr1 (pr2 O)).
      * intros. assumption.
Qed.
Lemma continuous_pr2 {U V : TopologicalSpace} :
  continuous (U := TopologyDirprod U V) (λ (xy : U × V), pr2 xy).
Proof.
  intros xy P.
  apply hinhuniv.
  intros O.
  simple refine (filter_imply _ _ _ _ _).
  - exact (pr1 (pr1 O)).
  - exact (pr2 (pr2 O)).
  - apply hinhpr.
    use tpair.
    + use tpair.
      * apply (λ xy : U × V, pr1 O (pr2 xy)).
      * intros xy' Oxy.
        apply hinhpr.
        exists (λ _, htrue), (pr1 O).
        repeat split.
        ** exact isOpen_htrue.
        ** exact Oxy.
        ** exact (pr2 (pr1 O)).
        ** intros. assumption.
    + repeat split.
      * exact (pr1 (pr2 O)).
      * intros. assumption.
Qed.

(** ** Topology in algebraic structures *)

Definition isTopological_monoid (X : monoid) (is : isTopologicalSpace X) :=
  continuous2d (U := (pr11 X) ,, is)
               (V := (pr11 X) ,, is)
               (W := (pr11 X) ,, is)
               BinaryOperations.op.
Definition Topological_monoid :=
  ∑ (X : monoid) (is : isTopologicalSpace X), isTopological_monoid X is.

Definition isTopological_gr (X : gr) (is : isTopologicalSpace X) :=
  isTopological_monoid X is
    × continuous (U := (pr11 X) ,, is)
                 (V := (pr11 X) ,, is)
                 (grinv X).
Definition Topological_gr :=
  ∑ (X : gr) is, isTopological_gr X is.

Definition isTopological_rig (X : rig) (is : isTopologicalSpace X) :=
  isTopological_monoid (rigaddabmonoid X) is
  × isTopological_monoid (rigmultmonoid X) is.
Definition Topological_rig :=
  ∑ (X : rig) is, isTopological_rig X is.

Definition isTopological_ring (X : ring) (is : isTopologicalSpace X) :=
  isTopological_gr (ringaddabgr X) is
  × isTopological_monoid (rigmultmonoid X) is.
Definition Topological_ring :=
  ∑ (X : ring) is, isTopological_ring X is.

Definition isTopological_DivRig (X : DivRig) (is : isTopologicalSpace X) :=
  isTopological_rig (pr1 X) is
  × continuous_on (U := (pr111 X) ,, is)
                  (V := (pr111 X) ,, is)
                  (λ x : X, make_hProp (x != 0%dr) (isapropneg _)) (λ x Hx, invDivRig (x,,Hx)).
Definition Topological_DivRig :=
  ∑ (X : DivRig) is, isTopological_DivRig X is.

Definition isTopological_fld (X : fld) (is : isTopologicalSpace X) :=
  isTopological_ring (pr1 X) is
  × continuous_on (U := (pr111 X) ,, is)
                  (V := (pr111 X) ,, is)
                  (λ x : X, make_hProp (x != 0%ring) (isapropneg _))
                  fldmultinv.
Definition Topological_fld :=
  ∑ (X : fld) is, isTopological_fld X is.

Definition isTopological_ConstructiveDivisionRig
  (X : ConstructiveDivisionRig)
  (is : isTopologicalSpace X)
  := isTopological_rig X is
       × continuous_on (U := (pr111 X) ,, is)
                       (V := (pr111 X) ,, is)
                       (λ x : X, (x ≠ 0)%CDR)
                       CDRinv.

Definition Topological_ConstructiveDivisionRig :=
  ∑ (X : ConstructiveDivisionRig) is, isTopological_ConstructiveDivisionRig X is.

Definition isTopological_ConstructiveField
  (X : ConstructiveField)
  (is : isTopologicalSpace X)
  := isTopological_ring X is
       × continuous_on (U := (pr111 X) ,, is)
                       (V := (pr111 X) ,, is)
                       (λ x : X, (x ≠ 0)%CF)
                       CFinv.

Definition Topological_ConstructiveField :=
  ∑ (X : ConstructiveField) is, isTopological_ConstructiveField X is.


Require Import CoRN.algebra.RSetoid.
Require Import CoRN.metric2.Metric.
Require Import CoRN.metric2.UniformContinuity.
Require Import
  Coq.Program.Program MathClasses.misc.workaround_tactics
  CoRN.model.totalorder.QposMinMax
  CoRN.model.totalorder.QMinMax Coq.QArith.Qround Coq.QArith.Qabs
  CoRN.util.Qdlog CoRN.stdlib_omissions.Q
  CoRN.reals.fast.CRexp CoRN.reals.fast.CRstreams CoRN.reals.fast.CRAlternatingSum
  CoRN.reals.fast.Compress CoRN.reals.fast.CRpower
  CoRN.metric2.MetricMorphisms CoRN.reals.faster.ARAlternatingSum MathClasses.interfaces.abstract_algebra
  MathClasses.orders.minmax MathClasses.theory.nat_pow MathClasses.theory.int_pow.
Require Export
  CoRN.reals.faster.ARArith.

Section ARexp.
Context `{AppRationals AQ}.

Section exp_small_neg.
Context {a : AQ} (Pa : -1 ≤ a ≤ 0).

(*
Split the stream
  (-a)^i / i!
up into the streams
  (-a)^i    and    i!
because we do not have exact division
*)
Definition ARexpStream (px : positive*(AQ*AQ)) : AQ*AQ
  := (fst (snd px) * a, snd (snd px) * ZtoAQ (Zpos (fst px))).

Lemma AQexp_small_neg_prf : -1 ≤ ('a : Q) ≤ 0.
Proof.
  split.
   now apply rings.preserves_ge_negate1.
  now apply semirings.preserves_nonpos.
Qed.

(*
The ARInfAltSum function computes the infinite alternating sum
and takes care of:
- Computing the length of the partial sum
- Computing the precision of the approximate division
*)
Lemma expStream_pos : ∀ x : positive * (AQ * AQ),
    0 < snd (snd x) → 0 < snd (ARexpStream x).
Proof.
  intros. unfold ARexpStream. simpl.
  assert (AQtoQ 0 == 0).
  apply rings.preserves_0.
  destruct aq_strict_order_embed.
  apply strict_order_embedding_reflecting.
  rewrite rings.preserves_mult, rings.preserves_0.
  apply (Qle_lt_trans _ (AQtoQ (snd (snd x)) * 0)).
  rewrite Qmult_0_r. apply Qle_refl.
  apply Qmult_lt_l.
  rewrite <- H6. apply strict_order_embedding_preserving, H5.
  pose proof AQtoQ_ZtoAQ.
  unfold cast in H7. rewrite H7.
  reflexivity.
Qed.

Lemma AQ0_lt_1 : 0 < 1.
Proof.
  destruct aq_strict_order_embed.
  apply strict_order_embedding_reflecting.
  rewrite rings.preserves_0, rings.preserves_1.
  reflexivity.
Qed.

Lemma expStream_correct : ∀ p : positive,
    Str_pth _ (CRexp.expStream (AQtoQ a)) p (1%positive, 1%Q)
    == let (_, r) := iterate _ (fS ARexpStream) p (1%positive, (1, 1)) in
       AQtoQ (fst r) / AQtoQ (snd r).
Proof.
  apply Pos.peano_ind.
  - unfold Str_pth. simpl.
    rewrite Qmult_1_l, Qmult_1_r.
    rewrite rings.mult_1_l, rings.mult_1_l.
    pose proof (AQtoQ_ZtoAQ 1).
    unfold cast in H5. rewrite H5.
    unfold stdlib_rationals.inject_Z_Q, inject_Z.
    unfold Qdiv. rewrite Qmult_1_r. reflexivity.
  - intros. unfold Str_pth.
    rewrite iterate_succ, iterate_succ.
    unfold Str_pth in H5.
    pose proof (fS_fst ARexpStream p (1,1)).
    pose proof (expStream_fst (AQtoQ a) p).
    destruct (iterate _ (CRexp.expStream (AQtoQ a)) p (1%positive, 1%Q)) as [u v].
    destruct (iterate (positive * (AQ * AQ)) (fS ARexpStream) p (1%positive, (1, 1))).
    unfold snd in H5 at 1. simpl.
    unfold fst in H6. subst p0.
    rewrite H5. unfold fst in H7. clear H5 v.
    subst u.
    assert (forall i j : AQ, AQtoQ (i*j) == AQtoQ i * AQtoQ j).
    { intros. rewrite rings.preserves_mult. reflexivity. }
    rewrite H5, H5. unfold Qdiv.
    rewrite Qinv_mult_distr.
    pose proof (AQtoQ_ZtoAQ).
    unfold cast in H6. rewrite H6.
    unfold stdlib_rationals.inject_Z_Q, inject_Z.
    setoid_replace (/ (Z.pos (Pos.succ p) # 1))%Q with (1#Pos.succ p).
    ring. reflexivity.
Qed.

Definition AQexp_small_neg : AR
  := 1+ AltSeries ARexpStream expStream_pos
                  positive (CRexp.expStream (AQtoQ a))
                  (1,1) (xH,1) expStream_correct _
                  (expStream_alt AQexp_small_neg_prf)
                  AQ0_lt_1 (expStream_zl AQexp_small_neg_prf).

Lemma AQexp_small_neg_correct
  : 'AQexp_small_neg = rational_exp_small_neg AQexp_small_neg_prf.
Proof.
  unfold AQexp_small_neg, rational_exp_small_neg.
  rewrite ARtoCR_preserves_plus.
  rewrite ARtoCR_preserves_1.
  rewrite <- CRplus_translate.
  apply ucFun2_wd. reflexivity.
  apply AltSeries_correct.
Qed.

End exp_small_neg.

(*
Implement the range reduction
  exp(x) = exp(x/2) ^ 2
*)
Fixpoint ARpower_2_iter (n : nat) (x : AR) : AR :=
  match n with
  | O => x
  | S p => ARpower_N_bounded 2 1 (ARcompress (ARpower_2_iter p x))
  end.

Lemma ARpower_2_iter_wd : forall (n : nat) (x y : AR),
    x = y -> ARpower_2_iter n x = ARpower_2_iter n y.
Proof.
  induction n.
  - intros. exact H5.
  - intros. simpl. apply Cmap_wd. reflexivity.
    pose proof ARcompress_correct.
    simpl in H6.
    rewrite H6, H6.
    apply IHn, H5.
Qed.

Lemma AQexp_neg_bounded_correct : ∀ (n : nat) a (abound : -1 ≤ a * (1 ≪ (-1)) ^ n ≤ 0),
    a ≤ 0 ->
    ' ARpower_2_iter n (AQexp_small_neg abound) = rational_exp (' a).
Proof.
  induction n.
  - intros. simpl.
    rewrite AQexp_small_neg_correct.
    rewrite rational_exp_small_neg_correct.
    rewrite rational_exp_correct.
    apply CRIR.IRasCR_wd, Exponential.Exp_wd.
    apply Q_in_CReals.inj_Q_wd.
    rewrite rings.preserves_mult.
    unfold pow. simpl.
    rewrite rings.preserves_1, Qmult_1_r.
    reflexivity.
  - intros a abound aneg.
    change (ARpower_2_iter (S n) (AQexp_small_neg abound))
      with (ARpower_N_bounded 2 1 (ARcompress (ARpower_2_iter n (AQexp_small_neg abound)))).
    rewrite ARcompress_correct.
    rewrite ARtoCR_preserves_power_N_bounded.
    assert (-1 ≤ a * (1 ≪ (-1)) * (1 ≪ (-1)) ^ n ≤ 0) as abound_shift.
    { setoid_replace (a * 1 ≪ (-1) * (1 ≪ (-1)) ^ n )
        with (a * (1 ≪ (-1)) ^ S n). exact abound.
      unfold pow at 2. simpl.
      rewrite (rings.mult_assoc a). reflexivity. }
    specialize (IHn _ abound_shift).
    setoid_replace (' ARpower_2_iter n (AQexp_small_neg abound))
      with (' ARpower_2_iter n (AQexp_small_neg abound_shift)).
    rewrite IHn. clear IHn.
    transitivity (CRpower_N_bounded 2 (1#1)%Qpos (rational_exp (' (a ≪ (-1))))).
    + apply Cmap_wd.
      setoid_replace ('1 : Qpos) with (1#1)%Qpos.
      reflexivity.
      rewrite AQposAsQpos_preserves_1. reflexivity.
      setoid_replace (' (a * 1 ≪ (-1))) with (' (a ≪ (-1))).
      reflexivity. rewrite aq_shift_opp_1.
      rewrite rings.preserves_mult.
      rewrite aq_shift_opp_1.
      apply Qmult_comp. reflexivity.
      rewrite rings.preserves_1. reflexivity.
    + rewrite aq_shift_opp_1.
      apply rational_exp_square.
      now apply semirings.preserves_nonpos.
    + apply (order_reflecting (cast AQ Q)).
      rewrite rings.preserves_mult.
      rewrite rings.preserves_0.
      rewrite <- (Qmult_0_l (' (1 ≪ (-1)))).
      apply Qmult_le_compat_r.
      apply (order_preserving (cast AQ Q)) in aneg.
      rewrite rings.preserves_0 in aneg.
      exact aneg.
      rewrite aq_shift_opp_1.
      rewrite rings.preserves_1. discriminate.
    + apply ARpower_2_iter_wd.
      apply (injective (cast AR CR)).
      rewrite AQexp_small_neg_correct, AQexp_small_neg_correct.
      apply rational_exp_small_neg_wd.
      setoid_replace (' (a * (1 ≪ (-1)) ^ S n))
        with (' (a * 1 ≪ (-1) * (1 ≪ (-1)) ^ n)).
      reflexivity.
      unfold pow at 1. simpl.
      rewrite (rings.mult_assoc a). reflexivity.
Qed.

Section exp_neg.
Context {a : AQ} (Pa : a ≤ 0).

Lemma AQexp_neg_bound_correct : -2 ^ Z.to_nat (Z.log2_up (Qceiling(-'a))) ≤ a.
Proof.
  apply (order_reflecting (cast AQ Q)).
  rewrite rings.preserves_negate.
  rewrite preserves_nat_pow.
  rewrite rings.preserves_2.
  rewrite <-(int_pow_nat_pow (f:=Z_of_nat)).
  assert ('a <= 0)%Q as H5.
  { apply (order_preserving (cast AQ Q)) in Pa.
    rewrite rings.preserves_0 in Pa. exact Pa. }
  pose proof (rational_exp_bound_power_2 H5).
  rewrite Qpower.Zpower_Qpower in H6.
  apply H6.
  apply Nat2Z.is_nonneg.
Qed.

Lemma power_2_improve_bound_correct : forall (n:nat),
    -2 ^ n ≤ a ->
    -1 ≤ a*(1 ≪ (-1))^n ≤ 0.
Proof.
  intros.
  assert ('a <= 0)%Q as aneg.
  { apply (order_preserving (cast AQ Q)) in Pa.
    rewrite rings.preserves_0 in Pa. exact Pa. }
  pose proof (CRexp.power_2_improve_bound_correct n aneg) as H6.
  assert ('(-1) <= '(a * (1 ≪ (-1)) ^ n) <= '0
          -> -1 ≤ a * (1 ≪ (-1)) ^ n ≤ 0).
  { intros. split; apply (order_reflecting (cast AQ Q)); apply H7. }
  apply H7. clear H7.
  rewrite rings.preserves_mult.
  rewrite rings.preserves_negate.
  rewrite rings.preserves_1.
  rewrite rings.preserves_0.
  rewrite preserves_nat_pow.
  rewrite <-(int_pow_nat_pow (f:=Z_of_nat)).
  rewrite (aq_shift_correct 1 (-1)).
  rewrite rings.preserves_1.
  rewrite Qmult_1_l. apply H6. clear H6.
  apply (order_preserving (cast AQ Q)) in H5.
  refine (Qle_trans _ _ _ _ H5).
  rewrite rings.preserves_negate.
  rewrite preserves_nat_pow.
  rewrite <-(int_pow_nat_pow (f:=Z_of_nat)).
  rewrite Qpower.Zpower_Qpower.
  rewrite rings.preserves_2.
  apply Qle_refl. apply Nat2Z.is_nonneg.
Qed.

Definition AQexp_neg : AR
  := ARpower_2_iter
       (Z.to_nat (Z.log2_up (Qceiling(-'a))))
       (AQexp_small_neg
          (power_2_improve_bound_correct _ (AQexp_neg_bound_correct))).

Lemma AQexp_neg_correct: 'AQexp_neg = rational_exp ('a).
Proof.
  apply AQexp_neg_bounded_correct, Pa.
Qed.

(* We could use a number closer to 1/exp 1, for example 11 $ -5, but in practice this seems
    to make it slower. *)
Program Definition AQexp_inv_pos_bound : AQ₊ := ((1 ≪ (-2)) ^ Z.abs_N (Qfloor ('a)))↾_.
Next Obligation. solve_propholds. Qed.

Lemma AQexp_inv_pos_bound_correct :
  '(cast (AQ₊) Q AQexp_inv_pos_bound) ≤ rational_exp ('a).
Proof.
  change (cast Q CR (cast AQ Q ((1 ≪ (-2)) ^ Z.abs_N (Qfloor ('a)))) ≤ rational_exp ('a)).
  rewrite preserves_nat_pow.
  rewrite aq_shift_opp_2.
  rewrite rings.preserves_1, rings.mult_1_l.
  rewrite <-(int_pow_nat_pow (f:=cast N Z)).
  rewrite Z_of_N_abs, Z.abs_neq.
   apply (rational_exp_lower_bound (1#4)).
    now apply semirings.preserves_nonpos.
   apply CRpos_nonNeg.
   now CRsign.CR_solve_pos (1#1)%Qpos.
  change (Qfloor ('a) ≤ 0).
  apply (order_reflecting (cast Z Q)).
  transitivity ('a : Q).
   now apply Qfloor_le.
  now apply semirings.preserves_nonpos.
Qed.
End exp_neg.

Lemma AQexp_prf1 {a : AQ} (pA : 0 ≤ a) : -a ≤ 0.
Proof. now apply rings.flip_nonneg_negate. Qed.

Lemma AQexp_prf2 {a : AQ} (pA : ¬0 ≤ a) : a ≤ 0.
Proof. now apply orders.le_flip. Qed.

(*
Extend it to the full domain.
*)
Definition AQexp (a : AQ) : AR :=
  match decide_rel (≤) 0 a with
  | left Pa => ARinv_pos (AQexp_inv_pos_bound (a:=-a)) (AQexp_neg (AQexp_prf1 Pa))
  | right Pa => AQexp_neg (AQexp_prf2 Pa)
  end.

Lemma AQexp_correct a : 'AQexp a = rational_exp ('a).
Proof.
  unfold AQexp.
  case (decide_rel _); intros.
   rewrite ARtoCR_preserves_inv_pos.
   rewrite AQexp_neg_correct.
   rewrite rings.preserves_negate.
   apply rational_exp_opp.
    now apply semirings.preserves_nonneg.
   posed_rewrite <-(rings.preserves_negate (f:=cast AQ Q)).
   apply (AQexp_inv_pos_bound_correct (a:=-a)).
   now apply rings.flip_nonneg_negate.
  apply AQexp_neg_correct.
Qed.

Local Obligation Tactic := idtac.
Program Definition ARexp_bounded_uc (z : Z) := unary_complete_uc
  QPrelengthSpace (cast AQ Q_as_MetricSpace) (λ x, AQexp (('z) ⊓ x)) (exp_bound_uc z) _.
Next Obligation.
  intros.
  change ('AQexp ((' z) ⊓ x) = exp_bound_uc z (' x)).
  rewrite AQexp_correct, aq_preserves_min, AQtoQ_ZtoAQ.
  reflexivity.
Qed.

Definition ARexp_bounded (z : Z) := Cbind AQPrelengthSpace (ARexp_bounded_uc z).

Lemma ARtoCR_preserves_exp_bounded z x : 'ARexp_bounded z x = exp_bounded z ('x).
Proof. apply (preserves_unary_complete_fun QPrelengthSpace _ (λ x, AQexp (('z) ⊓ x))). Qed.

Definition ARexp (x : AR) : AR
  := ARexp_bounded (Qceiling ('approximate x (Qpos2QposInf (1#1)) + (1#1))) x.

Lemma ARtoCR_preserves_exp x : 'ARexp x = exp ('x).
Proof. unfold ARexp. apply ARtoCR_preserves_exp_bounded. Qed.
End ARexp.


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

(* Instantiation of the Ring tactic for the binary integers of ZArith *)

Require Export LegacyArithRing.
Require Export ZArith_base.
Require Import Eqdep_dec.
Require Import LegacyRing.

Definition Zeq (x y:Z) :=
  match (x ?= y)%Z with
  | Datatypes.Eq => true
  | _ => false
  end.

Lemma Zeq_prop : forall x y:Z, Is_true (Zeq x y) -> x = y.
  intros x y H; unfold Zeq in H.
  apply Zcompare_Eq_eq.
  destruct (x ?= y)%Z; [ reflexivity | contradiction | contradiction ].
Qed.

Definition ZTheory : Ring_Theory Zplus Zmult 1%Z 0%Z Zopp Zeq.
  split; intros; eauto with zarith.
  apply Zeq_prop; assumption.
Qed.

(* NatConstants and NatTheory are defined in Ring_theory.v *)
Add Legacy Ring Z Zplus Zmult 1%Z 0%Z Zopp Zeq ZTheory
 [ Zpos Zneg 0%Z xO xI 1%positive ].