(** * Algebra I. Part E. Integral domains and fields. Vladimir Voevodsky. Aug. 2011 - . *)
Require Import UniMath.Algebra.Groups.
(** ** Contents
- Integral domains and fields
 - Integral domains
  - General definitions
  - Computation lemmas for integral domains
  - Multiplicative submonoid of non-zero elements
  - Relations similar to "greater" on integral domains
 - Fields
  - Main definitions
  - Field of fractions of an integral domain with decidable equality
  - Canonical homomorphism to the field of fractions
 - Relations similar to "greater" on field of fractions
  - Description of the field of fractions as the ring of fractions
    with respect to the submonoid of "positive" elements
  - Definition and properties of "greater" on the field of fractions
  - Relations and the canonical homomorphism to the field of fractions
*)

Local Open Scope logic.

(** ** Preamble *)

(** Settings *)

Unset Kernel Term Sharing.

(** Imports *)

Require Export UniMath.Algebra.RigsAndRings.

(** To upstream files *)

(** To one binary operation *)

Lemma islcancelableif {X : hSet} (opp : binop X) (x : X)
      (is : ∏ a b : X, paths (opp x a) (opp x b) -> a = b) : islcancelable opp x.
Proof.
  intros. apply isinclbetweensets.
  - apply (setproperty X).
  - apply (setproperty X).
  - apply is.
Defined.

Lemma isrcancelableif {X : hSet} (opp : binop X) (x : X)
      (is : ∏ a b : X, paths (opp a x) (opp b x) -> a = b) : isrcancelable opp x.
Proof.
  intros. apply isinclbetweensets.
  - apply (setproperty X).
  - apply (setproperty X).
  - apply is.
Defined.

Definition iscancelableif {X : hSet} (opp : binop X) (x : X)
           (isl : ∏ a b : X, paths (opp x a) (opp x b) -> a = b)
           (isr : ∏ a b : X, paths (opp a x) (opp b x) -> a = b) :
  iscancelable opp x := make_dirprod (islcancelableif opp x isl) (isrcancelableif opp x isr).

(** To monoids *)

(** TODO: this has now been upstreamed to BinaryOperations.v, these should be
    expunged. *)

Local Open Scope multmonoid_scope.

Definition linvpair (X : monoid) (x : X) : UU := total2 (λ x' : X, paths (x' * x) 1).

Definition pr1linvpair (X : monoid) (x : X) : linvpair X x -> X := @pr1 _ _.

Definition linvpairxy (X : monoid) (x y : X) (x' : linvpair X x) (y' : linvpair X y) :
  linvpair X (x * y).
Proof.
  intros. split with ((pr1 y') * (pr1 x')).
  rewrite (assocax _ _ _ (x * y)).
  rewrite (pathsinv0 (assocax _ _ x y)).
  rewrite (pr2 x').
  rewrite (lunax _ y).
  rewrite (pr2 y').
  apply idpath.
Defined.

Definition lcanfromlinv (X : monoid) (a b c : X) (c' : linvpair X c) (e : paths (c * a) (c * b)) :
  a = b.
Proof.
  intros.
  set (e' := maponpaths (λ x : X, (pr1 c') * x) e). simpl in e'.
  rewrite (pathsinv0 (assocax X _ _ _)) in e'.
  rewrite (pathsinv0 (assocax X _ _ _)) in e'.
  rewrite (pr2 c') in e'.
  rewrite (lunax X a) in e'.
  rewrite (lunax X b) in e'.
  apply e'.
Defined.

Definition rinvpair (X : monoid) (x : X) : UU := total2 (λ x' : X, paths (x * x') 1).

Definition pr1rinvpair (X : monoid) (x : X) : rinvpair X x -> X := @pr1 _ _.

Definition rinvpairxy (X : monoid) (x y : X) (x' : rinvpair X x) (y' : rinvpair X y) :
  rinvpair X (x * y).
Proof.
  intros. split with ((pr1 y') * (pr1 x')).
  rewrite (assocax _ x y _).
  rewrite (pathsinv0 (assocax _ y _ _)).
  rewrite (pr2 y').
  rewrite (lunax _ _).
  rewrite (pr2 x').
  apply idpath.
Defined.

Definition rcanfromrinv (X : monoid) (a b c : X) (c' : rinvpair X c) (e : paths (a * c ) (b * c)) :
  a = b.
Proof.
  intros.
  set (e' := maponpaths (λ x : X, x * (pr1 c')) e). simpl in e'.
  rewrite (assocax X _ _ _)  in e'.
  rewrite (assocax X _ _ _) in e'.
  rewrite (pr2 c') in e'.
  rewrite (runax X a) in e'.
  rewrite (runax X b) in e'.
  apply e'.
Defined.

Lemma pathslinvtorinv (X : monoid) (x : X) (x' : linvpair X x) (x'' : rinvpair X x) :
  paths (pr1 x') (pr1 x'').
Proof.
  intros. destruct (runax X (pr1 x')). (*unfold p.*)
  destruct (pr2 x'').
  set (int := x * pr1 x'').
  rewrite <- (lunax X (pr1 x'')).
  destruct (pr2 x').  (*unfold p1.*)
  unfold int.
  apply (pathsinv0 (assocax X _ _ _)).
Defined.

Definition invpair (X : monoid) (x : X) : UU :=
  total2 (λ x' : X, dirprod (paths (x' * x) 1) (paths (x * x') 1)).

Definition pr1invpair (X : monoid) (x : X) : invpair X x -> X := @pr1 _ _.

Definition invtolinv (X : monoid) (x : X) (x' : invpair X x) : linvpair X x :=
  tpair _ (pr1 x') (pr1 (pr2 x')).

Definition invtorinv (X : monoid) (x : X) (x' : invpair X x) : rinvpair X x :=
  tpair _ (pr1 x') (pr2 (pr2 x')).

Lemma isapropinvpair (X : monoid) (x : X) : isaprop (invpair X x).
Proof.
  intros. apply invproofirrelevance. intros x' x''.
  apply (invmaponpathsincl
           _ (isinclpr1 _ (λ a, isapropdirprod _ _ (setproperty X _ _) (setproperty X _ _)))).
  apply (pathslinvtorinv X x (invtolinv X x x') (invtorinv X x x'')).
Defined.

Definition invpairxy (X : monoid) (x y : X) (x' : invpair X x) (y' : invpair X y) :
  invpair X (x * y).
Proof.
  intros. split with ((pr1 y') * (pr1 x')). split.
  - apply (pr2 (linvpairxy _ x y (invtolinv _ x x') (invtolinv _ y y'))).
  - apply (pr2 (rinvpairxy _ x y (invtorinv _ x x') (invtorinv _ y y'))).
Defined.

(** To groups *)

Lemma grfrompathsxy (X : gr) {a b : X} (e : a = b) : paths (op a (grinv X b)) (unel X).
Proof.
  intros.
  set (e' := maponpaths (λ x : X, op x (grinv X b)) e). simpl in e'.
  rewrite (grrinvax X _) in e'. apply e'.
Defined.

Lemma grtopathsxy (X : gr) {a b : X} (e : paths (op a (grinv X b)) (unel X) ) : a = b .
Proof.
  intros.
  set (e' := maponpaths (λ x, op x b) e). simpl in e'.
  rewrite (assocax X) in e'. rewrite (grlinvax X) in e'.
  rewrite (lunax X) in e'. rewrite (runax X) in e'.
  apply e'.
Defined.

(** To rigs *)

Definition multlinvpair (X : rig) (x : X) : UU := linvpair (rigmultmonoid X) x.

Definition multrinvpair (X : rig) (x : X) : UU := rinvpair (rigmultmonoid X) x.

Definition multinvpair (X : rig) (x : X) : UU := invpair (rigmultmonoid X) x.

Definition rigneq0andmultlinv (X : rig) (n m : X) (isnm : ((n * m) != 0)%rig) :
  n != 0%rig.
Proof.
  intros. intro e. rewrite e in isnm.
  rewrite (rigmult0x X) in isnm.
  destruct (isnm (idpath _)).
Defined.

Definition rigneq0andmultrinv (X : rig) (n m : X) (isnm : ((n * m) != 0)%rig) :
  m != 0%rig.
Proof.
  intros. intro e. rewrite e in isnm. rewrite (rigmultx0 _) in isnm.
  destruct (isnm (idpath _)).
Defined.

(** To rings *)

Local Open Scope ring_scope.

Definition ringneq0andmultlinv (X : ring) (n m : X) (isnm : ((n * m) != 0)) : n != 0.
Proof.
  intros. intro e. rewrite e in isnm.
  rewrite (ringmult0x X) in isnm.
  destruct (isnm (idpath _)).
Defined.

Definition ringneq0andmultrinv (X : ring) (n m : X) (isnm : ((n * m) != 0)) : m != 0.
Proof.
  intros. intro e. rewrite e in isnm.
  rewrite (ringmultx0 _) in isnm.
  destruct (isnm (idpath _)).
Defined.

Definition ringpossubmonoid (X : ring) {R : hrel X} (is1 : isringmultgt X R) (is2 : R 1 0) :
  @submonoid (ringmultmonoid X).
Proof.
  intros. split with (λ x, R x 0). split.
  - intros x1 x2. apply is1. apply (pr2 x1). apply (pr2 x2).
  - apply is2.
Defined.

Lemma isinvringmultgtif (X : ring) {R : hrel X} (is0 : @isbinophrel X R) (is1 : isringmultgt X R)
      (nc : neqchoice R) (isa : isasymm R) : isinvringmultgt X R.
Proof.
  intros. split.
  - intros a b rab0 ra0.
    assert (int : b != 0).
    {
      intro e. rewrite e in rab0. rewrite (ringmultx0 X _) in rab0.
      apply (isa _ _ rab0 rab0).
    }
    destruct (nc _ _ int) as [ g | l ].
    + apply g.
    + set (int' := ringmultgt0lt0 X is0 is1 ra0 l).
      destruct (isa _ _ rab0 int').
  - intros a b rab0 rb0.
    assert (int : a != 0).
    {
      intro e. rewrite e in rab0. rewrite (ringmult0x X _) in rab0.
      apply (isa _ _ rab0 rab0).
    }
    destruct (nc _ _ int) as [ g | l ].
    + apply g.
    + set (int' := ringmultlt0gt0 X is0 is1 l rb0).
      destruct (isa _ _ rab0 int').
Defined.

(** ** Standard Algebraic Structures (cont.) Integral domains and Fileds.

Some of the notions considered in this section were introduced in C. Mulvey "Intuitionistic algebra
and representations of rings". See also P.T. Johnstone "Rings, fields and spectra". We only
consider here the strongest ("geometric") forms of the conditions of integrality and of being a
field. In particular all our fileds have decidable equality and p-adic numbers or reals are not
fileds in the sense of the definitions considered here. *)

Local Open Scope ring_scope.

(** *** Integral domains *)

(** **** General definitions *)

Lemma isnonzerolinvel (X : ring) (is : isnonzerorig X) (x : X) (x' : multlinvpair X x) :
  ((pr1 x') != 0).
Proof.
  intros.
  apply (negf (maponpaths (λ a : X, a * x))).
  assert (e := pr2 x'). change (paths (pr1 x' * x) 1) in e.
  change (neg (paths (pr1 x' * x) (0 * x))). rewrite e.
  rewrite (ringmult0x X _). apply is.
Defined.

Lemma isnonzerorinvel (X : ring) (is : isnonzerorig X) (x : X) (x' : multrinvpair X x) :
  ((pr1 x') != 0).
Proof.
  intros.
  apply (negf (maponpaths (λ a : X, x * a))).
  assert (e := pr2 x'). change (paths (x * pr1 x') 1) in e.
  change (neg (paths (x * pr1 x') (x * 0))).
  rewrite e. rewrite (ringmultx0 X _). apply is.
Defined.

Lemma isnonzerofromlinvel (X : ring) (is : isnonzerorig X) (x : X) (x' : multlinvpair X x) :
  x != 0.
Proof.
  intros. apply (negf (maponpaths (λ a : X, (pr1 x') * a))).
  assert (e := pr2 x'). change (paths (pr1 x' * x) 1) in e.
  change (neg (paths (pr1 x' * x) ((pr1 x') * 0))).
  rewrite e. rewrite (ringmultx0 X _). apply is.
Defined.

Lemma isnonzerofromrinvel (X : ring) (is : isnonzerorig X) (x : X) (x' : multrinvpair X x) :
  x != 0.
Proof.
  intros. apply (negf (maponpaths (λ a : X, a * (pr1 x')))).
  assert (e := pr2 x'). change (paths (x * pr1 x') 1) in e.
  change (neg (paths (x * pr1 x') (0 * (pr1 x')))).
  rewrite e. rewrite (ringmult0x X _). apply is.
Defined.

Definition isintdom (X : commring) : UU :=
  dirprod (isnonzerorig X) (∏ (a1 a2 : X), (a1 * a2 = 0) -> (a1 = 0) ∨ (a2 = 0)).

Lemma isapropisintdom (X : commring) : isaprop (isintdom X).
Proof.
  use isapropdirprod.
  - apply propproperty.
  - use impred. intros x1. use impred. intros x2. use impred. intros H.
    use propproperty.
Defined.
Opaque isapropisintdom.

Definition intdom : UU := total2 (λ X : commring, isintdom X).

Definition pr1intdom : intdom -> commring := @pr1 _ _.
Coercion pr1intdom : intdom >-> commring.

Definition nonzeroax (X : intdom) : neg (@paths X 1 0) := pr1 (pr2 X).

Definition intdomax (X : intdom) :
  ∏ (a1 a2 : X), (a1 * a2) = 0 -> (a1 = 0) ∨ (a2 = 0) := pr2 (pr2 X).

(** **** (X = Y) ≃ (ringiso X Y)
   We use the following composition

                            (X = Y) ≃ (pr1 X = pr1 Y)
                                    ≃ (ringiso X Y)

  where the second weak equivalence is given by univalence for commrings, [commring_univalence].
*)

Definition intdom_univalence_weq1 (X Y : intdom) : (X = Y) ≃ (pr1 X = pr1 Y).
Proof.
  use subtypeInjectivity.
  intros w. use isapropisintdom.
Defined.
Opaque intdom_univalence_weq1.

Definition intdom_univalence_weq2 (X Y : intdom) : (pr1 X = pr1 Y) ≃ (ringiso X Y) :=
  commring_univalence (pr1 X) (pr1 Y).

Definition intdom_univalence_map (X Y : intdom) : (X = Y) -> (ringiso X Y).
Proof.
  intros e. induction e. exact (idrigiso X).
Defined.

Lemma intdom_univalence_isweq (X Y : intdom) : isweq (intdom_univalence_map X Y).
Proof.
  use isweqhomot.
  - exact (weqcomp (intdom_univalence_weq1 X Y) (intdom_univalence_weq2 X Y)).
  - intros e. induction e. use weqcomp_to_funcomp_app.
  - use weqproperty.
Defined.
Opaque intdom_univalence_isweq.

Definition intdom_univalence (X Y : intdom) : (X = Y) ≃ (ringiso X Y).
Proof.
  use make_weq.
  - exact (intdom_univalence_map X Y).
  - exact (intdom_univalence_isweq X Y).
Defined.
Opaque intdom_univalence.

(** **** Computational lemmas for integral domains *)

Lemma intdomax2l (X : intdom) (x y : X) (is : paths (x * y) 0) (ne : x != 0) : y = 0.
Proof.
  intros.
  set (int := intdomax X _ _ is). generalize ne.
  assert (int' : isaprop (x != 0 -> y = 0)).
  {
    apply impred. intro.
    apply (setproperty X _ _).
  }
  generalize int. simpl.
  apply (@hinhuniv _ (make_hProp _ int')).
  intro ene. destruct ene as [ e'' | ne' ].
  - destruct (ne e'').
  - intro. apply ne'.
Defined.

Lemma intdomax2r (X : intdom) (x y : X) (is : paths (x * y) 0) (ne : y != 0) : x = 0.
Proof.
  intros.
  set (int := intdomax X _ _ is). generalize ne.
  assert (int' : isaprop (y != 0 -> x = 0)).
  {
    apply impred. intro.
    apply (setproperty X _ _).
  }
  generalize int. simpl. apply (@hinhuniv _ (make_hProp _ int')).
  intro ene. destruct ene as [ e'' | ne' ].
  - intro. apply e''.
  - destruct (ne ne').
Defined.

Definition intdomneq0andmult (X : intdom) (n m : X) (isn : n != 0)
           (ism : m != 0) : ((n * m) != 0).
Proof.
  intros. intro e. destruct (ism (intdomax2l X n m e isn )).
Defined.

Lemma intdomlcan (X : intdom) : ∏ (a b c : X), c != 0 -> paths (c * a) (c * b) -> a = b.
Proof.
  intros a b c ne e.
  apply (@grtopathsxy X a b). change (paths (a - b) 0).
  assert (e' := grfrompathsxy X e). change (paths ((c * a) - (c * b)) 0) in e'.
  rewrite (pathsinv0 (ringrmultminus X _ _)) in e'.
  rewrite (pathsinv0 (ringldistr X _ _ c)) in e'.
  set (int := intdomax X _ _ e'). generalize ne.
  assert (int' : isaprop (c != 0 -> paths (a - b) 0)).
  {
    apply impred. intro.
    apply (setproperty X _ _).
  }
  generalize int. simpl. apply (@hinhuniv _ (make_hProp _ int')).
  intro ene. destruct ene as [ e'' | ne' ].
  - destruct (ne e'').
  - intro. apply ne'.
Defined.
Opaque intdomlcan.

Lemma intdomrcan (X : intdom) : ∏ (a b c : X), c != 0 -> paths (a * c) (b * c) -> a = b.
Proof.
  intros a b c ne e. apply (@grtopathsxy X a b). change (paths (a - b) 0).
  assert (e' := grfrompathsxy X e). change (paths ((a * c) - (b * c)) 0) in e'.
  rewrite (pathsinv0 (ringlmultminus X _ _)) in e'.
  rewrite (pathsinv0 (ringrdistr X _ _ c)) in e'.
  set (int := intdomax X _ _ e'). generalize ne.
  assert (int' : isaprop (c != 0 -> paths (a - b) 0)).
  {
    apply impred. intro.
    apply (setproperty X _ _).
  }
  generalize int. simpl. apply (@hinhuniv _ (make_hProp _ int')).
  intro ene. destruct ene as [ e'' | ne' ].
  - intro. apply e''.
  - destruct (ne ne').
Defined.
Opaque intdomrcan.

Lemma intdomiscancelable (X : intdom) (x : X) (is : x != 0) : iscancelable (@op2 X) x.
Proof.
  intros. apply iscancelableif.
  - intros a b. apply (intdomlcan X a b x is).
  - intros a b. apply (intdomrcan X a b x is).
Defined.

(** **** Multiplicative submonoid of non-zero elements *)

Definition intdomnonzerosubmonoid (X : intdom) : @subabmonoid (ringmultabmonoid X).
Proof.
  intros. split with (λ x : X, make_hProp _ (isapropneg (x = 0))). split.
  - intros a b. simpl in *. intro e.
    set (int := intdomax X (pr1 a) (pr1 b) e). clearbody int. generalize int.
    apply toneghdisj. apply (make_dirprod (pr2 a) (pr2 b)).
  - simpl. apply (nonzeroax X).
Defined.

(** **** Relations similar to "greater" on integral domains *)

Definition intdomnonzerotopos (X : intdom) (R : hrel X) (is0 : @isbinophrel X R)
           (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R)
           (x : intdomnonzerosubmonoid X) : ringpossubmonoid X is1 is2.
Proof.
  intros. destruct (nc (pr1 x) 0 (pr2 x)) as [ g | l ].
  - apply (tpair _ (pr1 x) g).
  - split with (- (pr1 x)). simpl.
    apply ringtogt0.
    + apply is0.
    + rewrite (ringminusminus X _). apply l.
Defined.

(** *** Ring units (i.e. multilicatively invertible elements) *)

(** *** Fields *)

(** **** Main definitions *)

Definition isafield (X : commring) : UU :=
  (isnonzerorig X) × (∏ x : X, (multinvpair X x) ⨿ (x = 0)).

Lemma isapropisafield (X : commring) : isaprop (isafield X).
Proof.
  use isofhleveltotal2.
  - apply propproperty.
  - intros H.
    use impred. intros x. use isapropcoprod.
    + use isapropinvpair.
    + use setproperty.
    + intros H' e. use H.
      use (pathscomp0
             _ (@multx0_is_l X (@op1 X) (@op2 X) (dirprod_pr1 (ringop1axs X)) (ringop2axs X)
                             (ringdistraxs X) (pr1 H'))).
      use (pathscomp0 _ (maponpaths (λ y : X , op2 (pr1 H') y) e)).
      exact (! dirprod_pr1 (pr2 H')).
Defined.
Opaque isapropisafield.

Definition fld : UU := total2 (λ X : commring, isafield X).

Definition make_fld (X : commring) (is : isafield X) : fld := tpair _ X is.

Definition pr1fld : fld -> commring := @pr1 _ _.

Definition fldtointdom (X : fld) : intdom.
Proof.
  split with (pr1 X). split with (pr1 (pr2 X)).
  intros a1 a2. destruct (pr2 (pr2 X) a1) as [ a1' | e0 ].
  - intro e12. rewrite (pathsinv0 (ringmultx0 (pr1 X) a1)) in e12.
    set (e2 := lcanfromlinv _ _ _ _ (invtolinv _ _ a1') e12).
    apply (hinhpr (ii2 e2)).
  - intro e12. apply (hinhpr (ii1 e0)).
Defined.
Coercion fldtointdom : fld >-> intdom.

Definition fldchoice {X : fld} (x : X) : (multinvpair X x) ⨿ (x = 0) := pr2 (pr2 X) x.

Definition fldmultinvpair (X : fld) (x : X) (ne : x != 0) : multinvpair X x.
Proof.
  intros. destruct (fldchoice x) as [ ne0 | e0 ].
  - apply ne0.
  - destruct (ne e0).
Defined.

Definition fldmultinv {X : fld} (x : X) (ne : x != 0) : X := pr1 (fldmultinvpair X x ne).

(** **** (X = Y) ≃ (ringiso X Y)
   We use the following composition

                                (X = Y) ≃ (pr1 X = pr1 Y)
                                        ≃ (ringiso X Y)

   where the second weak equivalence is given by univalence for commrings, [commring_univalence].
*)

Definition fld_univalence_weq1 (X Y : fld) : (X = Y) ≃ (pr1 X = pr1 Y).
Proof.
  use subtypeInjectivity.
  intros w. use isapropisafield.
Defined.
Opaque fld_univalence_weq1.

Definition fld_univalence_weq2 (X Y : fld) : (pr1 X = pr1 Y) ≃ (ringiso X Y) :=
  commring_univalence (pr1 X) (pr1 Y).

Definition fld_univalence_map (X Y : fld) : (X = Y) -> (ringiso X Y).
Proof.
  intros e. induction e. exact (idrigiso X).
Defined.

Lemma fld_univalence_isweq (X Y : fld) : isweq (fld_univalence_map X Y).
Proof.
  use isweqhomot.
  - exact (weqcomp (fld_univalence_weq1 X Y) (fld_univalence_weq2 X Y)).
  - intros e. induction e. use weqcomp_to_funcomp_app.
  - use weqproperty.
Defined.
Opaque fld_univalence_isweq.

Definition fld_univalence (X Y : fld) : (X = Y) ≃ (ringiso X Y).
Proof.
  use make_weq.
  - exact (fld_univalence_map X Y).
  - exact (fld_univalence_isweq X Y).
Defined.
Opaque fld_univalence.

(** **** Field of fractions of an integral domain with decidable equality *)

Definition fldfracmultinvint (X : intdom) (is : isdeceq X)
           (xa : dirprod X (intdomnonzerosubmonoid X)) : dirprod X (intdomnonzerosubmonoid X).
Proof.
  intros. destruct (is (pr1 xa) 0) as [ e0 | ne0 ].
  - apply (make_dirprod 1 (tpair (λ x, x != 0) 1 (nonzeroax X))).
  - apply (make_dirprod (pr1 (pr2 xa)) (tpair (λ x, x != 0) (pr1 xa) ne0)).
Defined.

(** Note: we choose a strange from the mathematicians perspective approach to the definition of the
multiplicative inverse on non-zero elements of a field due to the current, somewhat less than
satisfactory, situation with computational behavior of our construction of set-quotients. The
particular problem is that the weak equivalence between "quotient of subtype" and "subtype of a
quotient" is not isomorphism in the syntactic category. This can be corrected by extension of the
type system with tfc-terms. See discussion in hSet.v *)

Lemma fldfracmultinvintcomp (X : intdom) (is : isdeceq X) :
  iscomprelrelfun (eqrelcommringfrac X (intdomnonzerosubmonoid X))
                  (eqrelcommringfrac X (intdomnonzerosubmonoid X))
                  (fldfracmultinvint X is).
Proof.
  intros. intros xa1 xa2.
  set (x1 := pr1 xa1). set (aa1 := pr2 xa1). set (a1 := pr1 aa1).
  set (x2 := pr1 xa2). set (aa2 := pr2 xa2). set (a2 := pr1 aa2).
  simpl. apply hinhfun. intro t2. unfold fldfracmultinvint.
  destruct (is (pr1 xa1) 0) as [ e1 | ne1 ].
  - destruct (is (pr1 xa2) 0) as [ e2 | ne2 ].
    + simpl. split with (tpair (λ x, x != 0) 1 (nonzeroax X)).
      apply idpath.
    +  simpl. set (aa0 := pr1 t2). set (a0 := pr1 aa0).
       assert (e := pr2 t2). change (paths (x1 * a2 * a0) (x2 * a1 * a0)) in e.
       change (x1 = 0) in e1. rewrite e1 in e. rewrite (ringmult0x X _) in e.
       rewrite (ringmult0x X _) in e.
       assert (e' := intdomax2r X _ _ (pathsinv0 e) (pr2 aa0)).
       assert (e'' := intdomax2r X _ _ e' (pr2 aa1)).
       destruct (ne2 e'').
  - destruct (is (pr1 xa2) 0) as [ e2 | ne2 ].
    + simpl. set (aa0 := pr1 t2). set (a0 := pr1 aa0).
      assert (e := pr2 t2). change (paths (x1 * a2 * a0) (x2 * a1 * a0)) in e.
      change (x2 = 0) in e2. rewrite e2 in e. rewrite (ringmult0x X _) in e.
      rewrite (ringmult0x X _) in e.
      assert (e' := intdomax2r X _ _  e (pr2 aa0)).
      assert (e'' := intdomax2r X _ _ e' (pr2 aa2)).
      destruct (ne1 e'').
    + simpl. set (aa0 := pr1 t2). set (a0 := pr1 aa0).
      assert (e := pr2 t2). split with aa0.
      change (paths (a1 * x2 * a0) (a2 * x1 * a0)).
      change (paths (x1 * a2 * a0) (x2 * a1 * a0)) in e.
      rewrite (ringcomm2 X a1 x2). rewrite (ringcomm2 X a2 x1).
      apply (pathsinv0 e).
Defined.
Opaque fldfracmultinvintcomp.

Definition fldfracmultinv0 (X : intdom) (is : isdeceq X)
           (x : commringfrac X (intdomnonzerosubmonoid X)) :
  commringfrac X (intdomnonzerosubmonoid X) := setquotfun _ _ _ (fldfracmultinvintcomp X is) x.

Lemma nonzeroincommringfrac (X : commring) (S : @submonoid (ringmultmonoid X)) (xa : dirprod X S)
      (ne : (setquotpr (eqrelcommringfrac X S) xa !=
             setquotpr _ (make_dirprod 0 (unel S)))%type) : (pr1 xa != 0).
Proof.
  intros. set (x := pr1 xa). set (aa := pr2 xa).
  assert (e' := negf (weqpathsinsetquot (eqrelcommringfrac X S) _ _) ne).
  simpl in e'. generalize e'.
  apply negf. intro e. apply hinhpr. split with (unel S).
  change (paths (x * 1 * 1) (0 * (pr1 aa) * 1)). rewrite e.
  repeat rewrite (ringmult0x X _).
  apply idpath.
Defined.
Opaque nonzeroincommringfrac.

Lemma zeroincommringfrac (X : intdom) (S : @submonoid (ringmultmonoid X))
      (is : ∏ s : S, (pr1 s != 0)) (x : X) (aa : S)
      (e : paths (setquotpr (eqrelcommringfrac X S) (make_dirprod x aa))
                 (setquotpr _ (make_dirprod 0 (unel S)))) : x = 0.
Proof.
  intros.
  set (e' := invweq (weqpathsinsetquot _ _ _) e). simpl in e'. generalize e'.
  apply (@hinhuniv _ (make_hProp _ (setproperty X _ _))).
  intro t2. simpl.
  set (aa0 := pr1 t2). set (a0 := pr1 aa0). set (a := pr1 aa).
  assert (e2 := pr2 t2). simpl in e2.
  change (paths (x * 1 * a0) (0 * a * a0)) in e2.
  rewrite (ringmult0x X _) in e2.
  rewrite (ringmult0x X _) in e2.
  rewrite (ringrunax2 X _) in e2.
  apply (intdomax2r X x a0 e2 (is aa0)).
Defined.
Opaque zeroincommringfrac.

Lemma isdeceqfldfrac (X : intdom) (is : isdeceq X) :
  isdeceq (commringfrac X (intdomnonzerosubmonoid X)).
Proof.
  intros. apply isdeceqcommringfrac.
  - intro a. apply isrcancelableif.
    intros b0 b1 e. apply (intdomrcan X _ _ (pr1 a) (pr2 a) e).
  - apply is.
Defined.

Lemma islinvinfldfrac (X : intdom) (is : isdeceq X) (x : commringfrac X (intdomnonzerosubmonoid X))
      (ne : x != 0) : paths ((fldfracmultinv0 X is x) * x) 1.
Proof.
  revert x ne.
  assert (int : ∏ x0, isaprop (x0 != 0 -> paths ((fldfracmultinv0 X is x0) * x0) 1)).
  {
    intro x0.
    apply impred. intro.
    apply (setproperty (commringfrac X (intdomnonzerosubmonoid X)) (fldfracmultinv0 X is x0 * x0) _).
  }
  apply (setquotunivprop _ (λ x0, make_hProp _ (int x0))).
  simpl. intros xa ne.
  change (paths (setquotpr (eqrelcommringfrac X (intdomnonzerosubmonoid X))
                           (make_dirprod ((pr1 (fldfracmultinvint X is xa)) * (pr1 xa))
                                        (@op (intdomnonzerosubmonoid X)
                                             (pr2 (fldfracmultinvint X is xa)) (pr2 xa))))
                (setquotpr _ (make_dirprod 1 (tpair _ 1 (nonzeroax X))))).
  apply (weqpathsinsetquot). unfold fldfracmultinvint. simpl.
  destruct (is (pr1 xa) 0 ) as [ e0 | ne0' ].
  - destruct (nonzeroincommringfrac X (intdomnonzerosubmonoid X) xa ne e0).
  - apply hinhpr.
    split with (tpair (λ a, a != 0) 1 (nonzeroax X)).
    set (x := (pr1 xa) : X). set (aa := pr2 xa). set (a := (pr1 aa) : X).
    simpl. change (paths (a * x * 1  * 1) (1 * (x * a) * 1)).
    rewrite (ringcomm2 X a x). repeat rewrite (ringrunax2 X _). rewrite (ringlunax2 X _).
    apply idpath.
Defined.
Opaque islinvinfldfrac.

Lemma isrinvinfldfrac (X : intdom) (is : isdeceq X) (x : commringfrac X (intdomnonzerosubmonoid X))
      (ne : x != 0) : paths (x * (fldfracmultinv0 X is x)) 1.
Proof.
  intros. rewrite (ringcomm2 _ _ _). apply islinvinfldfrac. apply ne.
Defined.

Definition fldfrac (X : intdom) (is : isdeceq X) : fld.
Proof.
  intros. split with (commringfrac X (intdomnonzerosubmonoid X)). split.
  - intro e.
    set (e' := zeroincommringfrac X (intdomnonzerosubmonoid X)
                                 (λ a : (intdomnonzerosubmonoid X), pr2 a) 1
                                 (unel (intdomnonzerosubmonoid X)) e).
    apply (nonzeroax X e').
  - intro x. destruct (isdeceqfldfrac X is x 0) as [ e | ne ].
    apply (ii2 e). apply ii1. split with (fldfracmultinv0 X is x). split.
    + apply (islinvinfldfrac X is x ne) .
    + apply (isrinvinfldfrac X is x ne).
Defined.

(** **** Canonical homomorphism to the field of fractions *)

Definition tofldfrac (X : intdom) (is : isdeceq X) (x : X) : fldfrac X is :=
  setquotpr _ (make_dirprod x (tpair (λ x, x != 0) 1 (nonzeroax X))).

Definition isbinop1funtofldfrac (X : intdom) (is : isdeceq X) :
  @isbinopfun X (fldfrac X is) (tofldfrac X is) := isbinop1funtocommringfrac X _.

Lemma isunital1funtofldfrac (X : intdom) (is : isdeceq X) : (tofldfrac X is 0) = 0.
Proof.
  intros. apply idpath.
Defined.

Definition isaddmonoidfuntofldfrac (X : intdom) (is : isdeceq X) :
  @ismonoidfun X (fldfrac X is) (tofldfrac X is) :=
  make_dirprod (isbinop1funtofldfrac X is) (isunital1funtofldfrac X is).

Definition tofldfracandminus0 (X : intdom) (is : isdeceq X) (x : X) :
  paths (tofldfrac X is (- x)) (- tofldfrac X is x) :=
  tocommringfracandminus0 _ _ x.

Definition tofldfracandminus (X : intdom) (is : isdeceq X) (x y : X) :
  paths (tofldfrac X is (x - y)) (tofldfrac X is x - tofldfrac X is y) :=
  tocommringfracandminus _ _ x y.

Definition isbinop2funtofldfrac (X : intdom) (is : isdeceq X) :
  @isbinopfun (ringmultmonoid X) (ringmultmonoid (fldfrac X is)) (tofldfrac X is) :=
  isbinopfuntoabmonoidfrac (ringmultabmonoid X) (intdomnonzerosubmonoid X).
Opaque isbinop2funtofldfrac.

Lemma isunital2funtofldfrac (X : intdom) (is : isdeceq X) : (tofldfrac X is 1) = 1.
Proof.
  intros. apply idpath.
Defined.
Opaque isunital2funtofldfrac.

Definition ismultmonoidfuntofldfrac (X : intdom) (is : isdeceq X) :
  @ismonoidfun (ringmultmonoid X) (ringmultmonoid (fldfrac X is)) (tofldfrac X is) :=
  make_dirprod (isbinop2funtofldfrac X is) (isunital2funtofldfrac X is).

Definition isringfuntofldfrac (X : intdom) (is : isdeceq X) :
  @isringfun X (fldfrac X is) (tofldfrac X is) :=
  make_dirprod (isaddmonoidfuntofldfrac X is) (ismultmonoidfuntofldfrac X is).

Definition isincltofldfrac (X : intdom) (is : isdeceq X) : isincl (tofldfrac X is) :=
  isincltocommringfrac X (intdomnonzerosubmonoid X)
                      (λ x : _, pr2 (intdomiscancelable X (pr1 x) (pr2 x))).

(** *** Relations similar to "greater" on fields of fractions

Our approach here is slightly different from the tranditional one used for example in Bourbaki
Algebra II, Ch. VI, Section 2 where one starts with a total ordering on a ring and extends it to
its field of fractions. This situation woud be exemplified by the extension of "greater or equal"
from integers to rationals. We have chosen to use instead as our archetypical example the extension
of "greater" from integers to rationals. There is no particular difference between the two choices
for types with decidable equality but in the setting of general rings in constructive mathematics
the relations such as "greater" appear to be more fundamental than relations such as "greater or
equal". For example, "greater or equal" on constructive real numbers can be obtained from "greater"
but not vice versa. *)

(** **** Description of the field of fractions as the ring of fractions with respect to the submonoid of "positive" elements *)

Definition weqfldfracgtint_f (X : intdom) {R : hrel X} (is0 : @isbinophrel X R)
           (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R)
           (xa : dirprod X (intdomnonzerosubmonoid X)) : dirprod X (ringpossubmonoid X is1 is2).
Proof.
  intros. destruct (nc (pr1 (pr2 xa)) 0 (pr2 (pr2 xa))) as [ g | l ].
  - apply (make_dirprod (pr1 xa) (tpair _ (pr1 (pr2 xa)) g)).
  - split with (- (pr1 xa)). split with (- (pr1 (pr2 xa))).
    simpl. apply (ringfromlt0 X is0 l).
Defined.

Lemma weqfldfracgtintcomp_f (X : intdom) {R : hrel X} (is0 : @isbinophrel X R)
      (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R) :
  iscomprelrelfun (eqrelcommringfrac X (intdomnonzerosubmonoid X))
                  (eqrelcommringfrac X (ringpossubmonoid X is1 is2))
                  (weqfldfracgtint_f X is0 is1 is2 nc).
Proof.
  intros. intros xa1 xa2. simpl.
  set (x1 := pr1 xa1). set (aa1 := pr2 xa1). set (a1 := pr1 aa1).
  set (x2 := pr1 xa2). set (aa2 := pr2 xa2). set (a2 := pr1 aa2).
  apply hinhfun. intro t2. split with (tpair (λ x, R x 0) 1 is2).
  set (aa0 := pr1 t2). set (a0 := pr1 aa0).
  assert (e := pr2 t2). change (paths (x1 * a2 * a0) (x2 * a1 * a0)) in e.
  unfold weqfldfracgtint_f.
  destruct (nc (pr1 (pr2 xa1)) 0 (pr2 (pr2 xa1))) as [ g1 | l1 ].
  - destruct (nc (pr1 (pr2 xa2)) 0 (pr2 (pr2 xa2))) as [ g2 | l2 ].
    + simpl. rewrite (ringrunax2 X _). rewrite (ringrunax2 X _).
      apply (intdomrcan X _ _ _ (pr2 aa0) e).
    + simpl. rewrite (ringrunax2 X _). rewrite (ringrunax2 X _).
      rewrite (ringrmultminus X _ _). rewrite (ringlmultminus X _ _).
      apply (maponpaths (λ x : X, - x)).
      apply (intdomrcan X _ _ _ (pr2 aa0) e).
  - destruct (nc (pr1 (pr2 xa2)) 0 (pr2 (pr2 xa2))) as [ g2 | l2 ].
    + simpl. rewrite (ringrunax2 X _). rewrite (ringrunax2 X _).
      rewrite (ringrmultminus X _ _). rewrite (ringlmultminus X _ _).
      apply (maponpaths (λ x : X, - x)).
      apply (intdomrcan X _ _ _ (pr2 aa0) e).
    + simpl. rewrite (ringrunax2 X _). rewrite (ringrunax2 X _).
      rewrite (ringrmultminus X _ _). rewrite (ringlmultminus X _ _).
      rewrite (ringrmultminus X _ _). rewrite (ringlmultminus X _ _).
      apply (maponpaths (λ x : X, - - x)).
      apply (intdomrcan X _ _ _ (pr2 aa0) e).
Defined.
Opaque weqfldfracgtintcomp_f.

Definition weqfldfracgt_f (X : intdom) (is : isdeceq X) {R : hrel X} (is0 : @isbinophrel X R)
           (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R) :
  fldfrac X is -> commringfrac X (ringpossubmonoid X is1 is2) :=
  setquotfun _ _ _ (weqfldfracgtintcomp_f X is0 is1 is2 nc).

Definition weqfldfracgtint_b (X : intdom) {R : hrel X} (is1 : isringmultgt X R) (is2 : R 1 0)
           (ir : isirrefl R) (xa : dirprod X (ringpossubmonoid X is1 is2)) :
  dirprod X (intdomnonzerosubmonoid X) :=
  make_dirprod (pr1 xa) (tpair _ (pr1 (pr2 xa)) (rtoneq ir (pr2 (pr2 xa)))).

Lemma weqfldfracgtintcomp_b (X : intdom) {R : hrel X} (is1 : isringmultgt X R) (is2 : R 1 0)
      (ir : isirrefl R) : iscomprelrelfun (eqrelcommringfrac X (ringpossubmonoid X is1 is2))
                                          (eqrelcommringfrac X (intdomnonzerosubmonoid X))
                                          (weqfldfracgtint_b X is1 is2 ir).
Proof.
  intros. intros xa1 xa2. simpl. apply hinhfun. intro t2.
  split with (tpair _ (pr1 (pr1 t2)) (rtoneq ir (pr2 (pr1 t2)))).
  apply (pr2 t2).
Defined.

Definition weqfldfracgt_b (X : intdom) (is : isdeceq X) {R : hrel X} (is1 : isringmultgt X R)
           (is2 : R 1 0) (ir : isirrefl R) :
  commringfrac X (ringpossubmonoid X is1 is2) -> fldfrac X is :=
  setquotfun _ _ _ (weqfldfracgtintcomp_b X is1 is2 ir).

Definition weqfldfracgt (X : intdom) (is : isdeceq X) {R : hrel X} (is0 : @isbinophrel X R)
           (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R) (ir : isirrefl R) :
  weq (fldfrac X is) (commringfrac X (ringpossubmonoid X is1 is2)).
Proof.
  intros.
  set (f := weqfldfracgt_f X is is0 is1 is2 nc).
  set (g := weqfldfracgt_b X is is1 is2 ir).
  split with f.
  assert (egf : ∏ a, paths (g (f a)) a).
  {
    unfold fldfrac. simpl.
    apply (setquotunivprop _ (λ a, make_hProp _ (isasetsetquot _ (g (f a)) a))).
    intro xa. simpl.
    change (paths (setquotpr (eqrelcommringfrac X (intdomnonzerosubmonoid X))
                             (weqfldfracgtint_b
                                X is1 is2 ir (weqfldfracgtint_f X is0 is1 is2 nc xa)))
                  (setquotpr (eqrelcommringfrac X (intdomnonzerosubmonoid X)) xa)).
    apply (weqpathsinsetquot). simpl. apply hinhpr.
    split with (tpair (λ x, x != 0) 1 (nonzeroax X)). simpl.
    unfold weqfldfracgtint_f.
    destruct (nc (pr1 (pr2 xa)) 0 (pr2 (pr2 xa))) as [ g' | l' ].
    - simpl. apply idpath.
    - simpl.
      rewrite (ringrmultminus X _ _). rewrite (ringlmultminus X _ _).
      apply idpath.
  }
  assert (efg : ∏ a, paths (f (g a)) a).
  {
    unfold fldfrac. simpl.
    apply (setquotunivprop _ (λ a, make_hProp _ (isasetsetquot _ (f (g a)) a))).
    intro xa. simpl.
    change (paths (setquotpr _ (weqfldfracgtint_f
                                  X is0 is1 is2 nc (weqfldfracgtint_b X is1 is2 ir xa)))
                  (setquotpr (eqrelcommringfrac X (ringpossubmonoid X is1 is2)) xa)).
    apply weqpathsinsetquot. simpl. apply hinhpr.
    split with (tpair (λ x, R x 0) 1 is2).
    unfold weqfldfracgtint_f. unfold weqfldfracgtint_b. simpl.
    set (int := nc (pr1 (pr2 xa)) 0 (rtoneq ir (pr2 (pr2 xa))) ).
    change (nc (pr1 (pr2 xa)) 0 (rtoneq ir (pr2 (pr2 xa)))) with int.
    destruct int as [ g' | l' ].
    - simpl. apply idpath.
    - simpl.
      rewrite (ringrmultminus X _ _). rewrite (ringlmultminus X _ _).
      apply idpath.
  }
  apply (isweq_iso _ _ egf efg).
Defined.

Lemma isringfunweqfldfracgt_b (X : intdom) (is : isdeceq X) {R : hrel X} (is1 : isringmultgt X R)
      (is2 : R 1 0) (ir : isirrefl R) : isringfun (weqfldfracgt_b X is is1 is2 ir).
Proof.
  intros.
  set (g :=  weqfldfracgt_b X is is1 is2 ir).
  set (g0 := weqfldfracgtint_b X is1 is2 ir).
  split.
  - split.
    + unfold isbinopfun.
      change (∏ x x' : commringfrac X (ringpossubmonoid X is1 is2),
                       paths (g (x + x')) ((g x) + (g x'))).
      apply (setquotuniv2prop
               _ (λ x x' : commringfrac X (ringpossubmonoid X is1 is2),
                    make_hProp _ (setproperty (fldfrac X is) (g (x + x')) ((g x) + (g x'))))).
      intros xa1 xa2.
      change (paths (setquotpr (eqrelcommringfrac X (intdomnonzerosubmonoid X))
                               (g0 (commringfracop1int X (ringpossubmonoid X is1 is2) xa1 xa2)))
                    (setquotpr (eqrelcommringfrac X (intdomnonzerosubmonoid X))
                               (commringfracop1int X (intdomnonzerosubmonoid X) (g0 xa1) (g0 xa2)))).
      apply (maponpaths (setquotpr _)).
      unfold g0. unfold weqfldfracgtint_b. unfold commringfracop1int. simpl.
      apply (pathsdirprod).
      * apply idpath.
      * destruct xa1 as [ x1 aa1 ]. destruct xa2 as [ x2 aa2 ]. simpl.
        destruct aa1 as [ a1 ia1 ]. destruct aa2 as [ a2 ia2 ]. simpl.
        apply (invmaponpathsincl
                 (@pr1 _ _) (isinclpr1 _ (λ a, (isapropneg (a = 0))))
                 (tpair _ (a1 * a2) (rtoneq ir (is1 a1 a2 ia1 ia2)))
                 (make_carrier (λ x : pr1 X, make_hProp (x = 0 -> empty) (isapropneg (x = 0)))
                              (a1 * a2) (fun e : paths (a1 * a2) 0 =>
                                           toneghdisj (make_dirprod (rtoneq ir ia1) (rtoneq ir ia2))
                                                      (intdomax X a1 a2 e))) (idpath _)).
    + change (paths (setquotpr (eqrelcommringfrac X (intdomnonzerosubmonoid X))
                               (g0 (make_dirprod 0 (tpair _ 1 is2))))
                    (setquotpr _ (make_dirprod 0 (tpair _ 1 (nonzeroax X))))).
      apply (maponpaths (setquotpr _)).
      unfold g0. unfold weqfldfracgtint_b. simpl.
      apply pathsdirprod.
      * apply idpath.
      * apply (invmaponpathsincl (@pr1 _ _) (isinclpr1 _ (λ a, (isapropneg (a = 0))))
                                 (tpair _ 1 (rtoneq ir is2)) (tpair _  1 (nonzeroax X))).
        simpl. apply idpath.
  - split.
    + unfold isbinopfun.
      change (∏ x x' : commringfrac X (ringpossubmonoid X is1 is2),
                       paths (g (x * x')) ((g x) * (g x'))).
      apply (setquotuniv2prop
               _ (λ x x' : commringfrac X (ringpossubmonoid X is1 is2),
                    make_hProp _ (setproperty (fldfrac X is) (g (x * x')) ((g x) * (g x'))))).
      intros xa1 xa2.
      change (paths (setquotpr (eqrelcommringfrac X (intdomnonzerosubmonoid X))
                               (g0 (commringfracop2int X (ringpossubmonoid X is1 is2) xa1 xa2)))
                    (setquotpr (eqrelcommringfrac X (intdomnonzerosubmonoid X))
                               (commringfracop2int X (intdomnonzerosubmonoid X) (g0 xa1) (g0 xa2)))).
      apply (maponpaths (setquotpr _)).
      unfold g0. unfold weqfldfracgtint_b.
      unfold commringfracop2int. unfold abmonoidfracopint. simpl.
      apply (pathsdirprod).
      * apply idpath.
      * destruct xa1 as [ x1 aa1 ]. destruct xa2 as [ x2 aa2 ]. simpl.
        destruct aa1 as [ a1 ia1 ]. destruct aa2 as [ a2 ia2 ]. simpl.
        apply (invmaponpathsincl
                 (@pr1 _ _)
                 (isinclpr1 _ (λ a, (isapropneg (a = 0))))
                 (tpair _ (a1 * a2) (rtoneq ir (is1 a1 a2 ia1 ia2)))
                 (make_carrier (λ x : pr1 X, make_hProp (x = 0 -> empty) (isapropneg (x = 0)))
                              (a1 * a2) (fun e : paths (a1 * a2) 0 =>
                                           toneghdisj (make_dirprod (rtoneq ir ia1) (rtoneq ir ia2))
                                                      (intdomax X a1 a2 e))) (idpath _)).
    + change (paths (setquotpr (eqrelcommringfrac X (intdomnonzerosubmonoid X))
                               (g0 (make_dirprod 1 (tpair _ 1 is2))))
                    (setquotpr _ (make_dirprod 1 (tpair _ 1 (nonzeroax X))))).
      apply (maponpaths (setquotpr _)).
      unfold g0. unfold weqfldfracgtint_b. simpl.
      apply pathsdirprod.
      * apply idpath.
      * apply (invmaponpathsincl (@pr1 _ _) (isinclpr1 _ (λ a, (isapropneg (a = 0))))
                                 (tpair _ 1 (rtoneq ir is2)) (tpair _ 1 (nonzeroax X))).
        simpl. apply idpath.
Defined.
Opaque isringfunweqfldfracgt_b.

Lemma isringfunweqfldfracgt_f (X : intdom) (is : isdeceq X) {R : hrel X} (is0 : @isbinophrel X R)
      (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R) (ir : isirrefl R) :
  isringfun (weqfldfracgt_f X is is0 is1 is2 nc).
Proof.
  intros. unfold weqfldfracgt_f.
  set (int := make_ringiso (invweq (weqfldfracgt X is is0 is1 is2 nc ir))
                         (isringfunweqfldfracgt_b X is is1 is2 ir)).
  change (@isringfun (fldfrac X is) (commringfrac X (ringpossubmonoid X is1 is2)) (invmap int)).
  apply isringfuninvmap.
Defined.
Opaque isringfunweqfldfracgt_f.

(** **** Definition and properties of "greater" on the field of fractions *)

Definition fldfracgt (X : intdom) (is : isdeceq X) {R : hrel X} (is0 : @isbinophrel X R)
           (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R) : hrel (fldfrac X is) :=
  λ a b, commringfracgt X (ringpossubmonoid X is1 is2) is0 is1 (λ c r, r)
                        (weqfldfracgt_f X is is0 is1 is2 nc a)
                        (weqfldfracgt_f X is is0 is1 is2 nc b).

Lemma isringmultfldfracgt (X : intdom) (is : isdeceq X) {R : hrel X} (is0 : @isbinophrel X R)
      (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R) (ir : isirrefl R) :
  isringmultgt (fldfrac X is) (fldfracgt X is is0 is1 is2 nc).
Proof.
  intros.
  refine (ringmultgtandfun (ringfunconstr (isringfunweqfldfracgt_f X is is0 is1 is2 nc ir)) _ _).
  apply isringmultcommringfracgt.
Defined.
Opaque isringmultfldfracgt.

Lemma isringaddfldfracgt (X : intdom) (is : isdeceq X) {R : hrel X} (is0 : @isbinophrel X R)
      (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R) (ir : isirrefl R) :
  @isbinophrel (fldfrac X is) (fldfracgt X is is0 is1 is2 nc).
Proof.
  intros.
  refine (ringaddhrelandfun (ringfunconstr (isringfunweqfldfracgt_f X is is0 is1 is2 nc ir)) _ _).
  apply isringaddcommringfracgt.
Defined.
Opaque isringaddfldfracgt.

Lemma istransfldfracgt (X : intdom) (is : isdeceq X) {R : hrel X} (is0 : @isbinophrel X R)
      (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R) (isr : istrans R) :
  istrans (fldfracgt X is is0 is1 is2 nc).
Proof.
  intros. intros a b c. unfold fldfracgt.
  apply istransabmonoidfracrel.
  apply isr.
Defined.
Opaque istransfldfracgt.

Lemma isirreflfldfracgt (X : intdom) (is : isdeceq X) {R : hrel X} (is0 : @isbinophrel X R)
      (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R) (isr : isirrefl R) :
  isirrefl (fldfracgt X is is0 is1 is2 nc).
Proof.
  intros. intros a. unfold fldfracgt .
  apply isirreflabmonoidfracrel.
  apply isr.
Defined.
Opaque isirreflfldfracgt.

Lemma isasymmfldfracgt (X : intdom) (is : isdeceq X) {R : hrel X} (is0 : @isbinophrel X R)
      (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R) (isr : isasymm R) :
  isasymm (fldfracgt X is is0 is1 is2 nc).
Proof.
  intros. intros a b. unfold fldfracgt .
  apply isasymmabmonoidfracrel.
  apply isr.
Defined.
Opaque isasymmfldfracgt.

Lemma iscotransfldfracgt (X : intdom) (is : isdeceq X) {R : hrel X} (is0 : @isbinophrel X R)
      (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R) (isr : iscotrans R) :
  iscotrans (fldfracgt X is is0 is1 is2 nc).
Proof.
  intros. intros a b c. unfold fldfracgt .
  apply iscotransabmonoidfracrel.
  apply isr.
Defined.
Opaque iscotransfldfracgt.

Lemma isantisymmnegfldfracgt  (X : intdom) (is : isdeceq X) {R : hrel X} (is0 : @isbinophrel X R)
      (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R) (ir : isirrefl R)
      (isr : isantisymmneg R) : isantisymmneg (fldfracgt X is is0 is1 is2 nc).
Proof.
  intros.
  assert (int : isantisymmneg (commringfracgt X (ringpossubmonoid X is1 is2) is0 is1 (λ c r, r))).
  {
    unfold commringfracgt.
    apply (isantisymmnegabmonoidfracrel
             (ringmultabmonoid X) (ringpossubmonoid X is1 is2)
             (ispartbinopcommringfracgt X (ringpossubmonoid X is1 is2) is0 is1
                                       (fun (c : X) (r : (ringpossubmonoid X is1 is2) c) => r))).
    apply isr.
  }
  intros a b n1 n2. set (e := int _ _ n1 n2).
  apply (invmaponpathsweq (weqfldfracgt X is is0 is1 is2 nc ir)  _ _ e).
Defined.
Opaque isantisymmnegfldfracgt.

Definition isdecfldfracgt (X : intdom) (is : isdeceq X) {R : hrel X} (is0 : @isbinophrel X R)
           (is1 : isringmultgt X R) (is2 : R 1 0) (nc : neqchoice R) (isa : isasymm R)
           (isr : isdecrel R) : isdecrel (fldfracgt X is is0 is1 is2 nc).
Proof.
  intros. unfold fldfracgt. intros a b. apply isdecabmonoidfracrel.
  - apply (pr1 (isinvringmultgtaspartinvbinophrel X R is0)).
    apply isinvringmultgtif.
    + apply is0.
    + apply is1.
    + apply nc.
    + apply isa.
  - apply isr.
Defined.

(** **** Relations and the canonical homomorphism to the field of fractions *)

Definition iscomptofldfrac (X : intdom) (is : isdeceq X) {L : hrel X} (is0 : @isbinophrel X L)
           (is1 : isringmultgt X L) (is2 : L 1 0) (nc : neqchoice L) (isa : isasymm L) :
  iscomprelrelfun L (fldfracgt X is is0 is1 is2 nc) (tofldfrac X is).
Proof.
  intros. intros x1 x2 l.
  assert (int := iscomptocommringfrac X (ringpossubmonoid X is1 is2) is0 is1 (λ c r, r)).
  simpl in int. unfold fldfracgt. unfold iscomprelrelfun in int.
  assert (ee : ∏ x : X, paths (tocommringfrac X (ringpossubmonoid X is1 is2) x)
                              (weqfldfracgt_f X is is0 is1 is2 nc (tofldfrac X is x))).
  {
    intros x.
    change (tocommringfrac X (ringpossubmonoid X is1 is2) x)
    with (setquotpr (eqrelcommringfrac X (ringpossubmonoid X is1 is2))
                    (make_dirprod x (tpair (λ a, L a 0) _ is2))).
    change (weqfldfracgt_f X is is0 is1 is2 nc (tofldfrac X is x))
    with (setquotpr (eqrelcommringfrac X (ringpossubmonoid X is1 is2))
                    (weqfldfracgtint_f
                       X is0 is1 is2 nc
                       (make_dirprod x (tpair (λ a, a != 0) 1 (nonzeroax X))))).
    apply (maponpaths (setquotpr (eqrelcommringfrac X (ringpossubmonoid X is1 is2)))).
    unfold weqfldfracgtint_f. simpl.
    destruct (nc 1 0 (nonzeroax X) ) as [ l' | nl ].
    - apply pathsdirprod.
      + apply idpath.
      + apply (invmaponpathsincl _ (isinclpr1 _ (λ a, (pr2 (L a 0))))).
        apply idpath.
    - destruct (isa _ _ is2 nl).
  }
  assert (int' := int x1 x2).
  rewrite (ee x1) in int'. rewrite (ee x2) in int'.
  apply int'. apply l.
Defined.
Opaque iscomptofldfrac.

(* End of the file *)


(** * normalisation: generic normalisation procedure and associated tactics *)

Require Import kleene syntax powerfix.

Set Implicit Arguments.

Section n.
Variables (s t: positive -> positive).
Notation expr := (expr s t).
Local Arguments weq {_} _ _: simpl never.
Local Arguments leq {_} _ _: simpl never.
Local Hint Extern 0 (_ ≪ _) => solve_lower || solve_lower': typeclass_instances.
Ltac fold_expr l := ra_fold (expr_ops s t l).

(** * normalisation procedure

   We normalise expressions in such a way that:
   - sums are flattened, left-associated, ordered (without duplicates),
     and without bottom or top elements
   - intersections are simply cleaned w.r.t bottom and top elements
   - products are left-associated, and possibly distributed over sums
     (specified using a boolean parameter)
   - unit and annihilators are ruled out as much as possible
   - strict iterations and Kleene stars do not contain inner iterations
   - converses are pushed to the leaves

   Some additional simplifications are possible, we plan to integrate
   them lazily, on demand.

   The normalisation function is defined in such a way that
   - the level of the resulting expression cannot increase w.r.t. the
     level of the initial one, and
   - it yields an expression which is equal to the starting one,
     *at the level of that expression*
   (in particular unions cannot be used to simplify lonely iterations)
*)

(** ** normalising sums *)

Fixpoint insert_pls n m (x: expr n m): expr n m -> expr n m :=
  match x with
    | e_zer _ _ => fun y => y
    | e_top _ _ => fun y => top
    | e_pls x z => fun y =>
      match cmp y z with
        | Lt => insert_pls x y+z
        | Gt => x+z+y
        | Eq => x+z
      end
    | x => fun y =>
      match cmp x y with
        | Lt => x+y
        | Gt => y+x
        | Eq => y
      end
  end%ast.

Fixpoint pls' n m (y: expr n m): expr n m -> expr n m :=
  match y with
    | e_zer _ _ => fun x => x
    | e_top _ _ => fun y => top
    | e_pls y z => fun x => insert_pls (pls' y x) z
    | y => fun x => insert_pls x y
  end%ast.

Lemma insert_pls_level n m (x y: expr n m): e_level (insert_pls x y) ≪ CUP+e_level x+e_level y.
Proof.
  induction x; simpl; try case cmp_spec;
    simpl e_level; intros; try solve_lower'.
  rewrite IHx1. solve_lower'.
Qed.

Lemma insert_pls_pls: forall l n m (x y: expr n m) {Hl: CUP+e_level x ≪ l},
  insert_pls x y ==_[l] y+x.
Proof.
  assert (D: forall n m (x y: expr n m) l, CUP+e_level x ≪ l ->
    y+x ==_[l] match cmp x y with Lt => x+y | Gt => y+x | Eq => y end).
   intros. case cmp_spec; intros; try subst; lattice.

  intros; symmetry; induction x; simpl e_level in *; try (apply D; solve_lower).
   lattice.
   lattice.
   simpl insert_pls. case cmp_spec; intros.
    subst. lattice.
    fold_expr l. rewrite <- IHx1 by solve_lower'. lattice.
    lattice.
Qed.

Lemma pls'_level n m (x y: expr n m): e_level (pls' x y) ≪ CUP+e_level x+e_level y.
Proof.
  induction x; simpl pls'; simpl e_level;
    rewrite ?insert_pls_level, ?IHx1, ?IHx; solve_lower'.
Qed.

Lemma pls'pls: forall l n m (x y: expr n m) {Hl: CUP+e_level x+e_level y ≪ l},
  pls' x y ==_[l] x+y.
Proof.
  induction x; simpl e_level; simpl pls'; intros y Hl;
    try (subst; now rewrite insert_pls_pls by solve_lower').
  lattice.
  lattice.
  rewrite insert_pls_pls, IHx1 by (rewrite ?pls'_level; solve_lower'). lattice.
Qed.

Lemma pls'x0_level n m (x: expr n m): e_level (pls' x 0) ≪ e_level x.
Proof. induction x; try reflexivity. simpl. now rewrite insert_pls_level, IHx1. Qed.

Lemma pls'x0 n m (x: expr n m) l `{CUP+e_level x ≪ l}: pls' x 0 ==_[l] x.
Proof.
  induction x; try reflexivity. simpl pls'. simpl e_level in *.
  rewrite insert_pls_pls, IHx1. apply cupC. solve_lower'.
  rewrite pls'x0_level. solve_lower'.
Qed.

(** ** normalising intersections
  we simply remove zeros and tops
  (TODO: normalise like for sums, distribute over sums) *)

Definition cap' n m (x y: expr n m) :=
  if is_top x then y
  else if is_top y then x
  else if is_zer x ||| is_zer y then e_zer _ _
  else e_cap x y.

Lemma cap'cap l n m (x y: expr n m) {Hl: CAP+e_level x+e_level y ≪ l}:
  cap' x y ==_[l] x ∩ y.
Proof.
  symmetry. unfold cap'. revert Hl.
  case is_top_spec. intros. apply captx.
  case is_top_spec. intros. apply capxt.
  case is_zer_spec. intros. apply capbx.
  case is_zer_spec. intros. apply capxb.
  reflexivity.
Qed.

Lemma cap'_level n m (x y: expr n m): e_level (cap' x y) ≪ CAP+e_level x+e_level y.
Proof.
  unfold cap'.
  case is_top_spec. solve_lower'.
  case is_top_spec. solve_lower'.
  case is_zer_spec. solve_lower'.
  case is_zer_spec; solve_lower'.
Qed.

(** ** normalising products
    (without ones or zeros, left associative, and possibly distributed
    over sums) *)

(** whether we distribute the products over sums is controlled by the
   following parameter *)
Variable distribute: bool.

Ltac case_distribute :=
  match goal with |- context[distribute] => case distribute | _ => idtac end.

(* [dot_l x y ≡ x⋅y] *)
Fixpoint dot_l n m (x: expr n m): forall p, expr m p -> expr n p :=
  match x in syntax.expr _ _ n m return forall p, expr m p -> expr n p with
    | e_zer _ _ => fun p y => 0
    | e_one _ => fun p y => y
    | e_pls x1 x2 => fun p y =>
      if distribute then pls' (dot_l x1 y) (dot_l x2 y)
      else (x1+x2)⋅y
    | x => fun p y => x ⋅ y
  end%ast.

(* [dot_r y x ≡ x⋅y] *)
Fixpoint dot_r m p (y: expr m p): forall n, expr n m -> expr n p :=
  match y in syntax.expr _ _ m p return forall n, expr n m -> expr n p with
    | e_zer _ _ => fun n x => 0
    | e_one _ => fun n x => x
    | e_pls y1 y2 => fun n x =>
      if distribute then pls' (dot_r y1 x) (dot_r y2 x)
      else dot_l x (y1+y2)
    | e_dot y z => fun n x => dot_l (dot_r y x) z
    | y => fun n x => dot_l x y
  end%ast.

Definition dot' n m p (x: expr n m) (y: expr m p) := dot_r y x.

Lemma dot_l_level n m p (x: expr n m) (y: expr m p):
  e_level (dot_l x y) ≪ e_level x + e_level y.
Proof.
  revert p y.
  induction x; intros q z; simpl dot_l; case_distribute; simpl e_level;
    rewrite ?pls'_level, ?IHx1, ?IHx2; solve_lower'.
Qed.

Lemma dot_r_level n m p (x: expr n m) (y: expr m p):
  e_level (dot_r y x) ≪ e_level x + e_level y.
Proof.
  revert n x.
  induction y; intros q z; simpl dot_r; case_distribute; simpl e_level;
    rewrite ?pls'_level, ?dot_l_level, ?IHy1, ?IHy2; solve_lower'.
Qed.

Lemma dot'_level n m p (x: expr n m) (y: expr m p):
  e_level (dot' x y) ≪ e_level x + e_level y.
Proof. apply dot_r_level. Qed.

Lemma dot_l_weq l n m p (x: expr n m) (y: expr m p) {Hl: e_level x + e_level y ≪ l}:
  x⋅y ==_[l] dot_l x y.
Proof.
  revert p y Hl.
  induction x; intros q z Hl; simpl dot_l; case_distribute; simpl e_level in Hl; try reflexivity.
   apply dot0x.
   apply dot1x.
   now rewrite dotplsx, pls'pls, <-IHx1, <-IHx2 by (rewrite ?dot_l_level; solve_lower').
Qed.

Lemma dot'dot l n m p (x: expr n m) (y: expr m p) {Hl: e_level y+e_level x ≪ l}:
  dot' x y ==_[l] x⋅y.
Proof.
  symmetry. unfold dot'. revert n x Hl.
  induction y; simpl e_level; intros q z Hl; simpl dot_r; case_distribute;
    try reflexivity; try (apply dot_l_weq; solve_lower').
   apply dotx0.
   apply dotx1.
   now rewrite dotxpls, pls'pls, <-IHy1, <-IHy2 by (rewrite ?dot_r_level; solve_lower').
   now rewrite <-dot_l_weq, <-IHy1, dotA by (rewrite ?dot_r_level; solve_lower').
Qed.

(** ** normalising converses
    by pushing them down towards the leaves *)

Fixpoint cnv' n m (x: expr n m): expr m n :=
  match x with
    | e_zer _ _ => 0
    | e_top _ _ => top
    | e_one _ => 1
    | e_pls x y => cnv' x + cnv' y
    | e_cap x y => cnv' x ∩ cnv' y
    | e_neg x => ! cnv' x                        (* TODO: normalise complements *)
    | e_dot x y => dot' (cnv' y) (cnv' x) (* we need to reverse parentheses *)
    | e_ldv x y => e_rdv (cnv' x) (cnv' y)     (* TODO: normalise residuals? *)
    | e_rdv x y => e_ldv (cnv' x) (cnv' y)
    | e_itr x => (cnv' x)^+
    | e_str x => (cnv' x)^*
    | e_cnv x => x
    | e_var a => (e_var a)°
  end%ast.

Lemma cnv'_level n m (x: expr n m): e_level (cnv' x) ≪ CNV+e_level x.
Proof.
  induction x; simpl cnv'; simpl e_level;
    rewrite ?dot'_level, ?pls'_level, ?cap'_level, ?IHx1, ?IHx2, ?IHx; solve_lower'.
Qed.

Lemma cnv'cnv l n m (x: expr n m) {Hl: CNV+e_level x ≪ l}: cnv' x ==_[l] x°.
Proof.
  symmetry. induction x; simpl cnv'; simpl e_level in Hl;
  rewrite ?dot'dot, ?e_str' by (rewrite ?cnv'_level; solve_lower').
  apply cnv0.
  apply cnvtop.
  apply cnv1.
  rewrite cnvpls. apply cup_weq; [apply IHx1|apply IHx2]; solve_lower'.
  rewrite cnvcap. apply cap_weq; [apply IHx1|apply IHx2]; solve_lower'.
  rewrite cnvneg. apply neg_weq, IHx. solve_lower'.
  rewrite cnvdot. apply dot_weq; [apply IHx2|apply IHx1]; solve_lower'.
  rewrite cnvitr. apply itr_weq, IHx. solve_lower'.
  rewrite cnvstr. apply str_weq, IHx. solve_lower'.
  apply cnv_invol.
  rewrite cnvldv. apply rdv_weq; [apply IHx1|apply IHx2]; solve_lower'.
  rewrite cnvrdv. apply ldv_weq; [apply IHx1|apply IHx2]; solve_lower'.
  reflexivity.
Qed.

(** ** removing toplevel iterations in an iterated sum  *)

Fixpoint remove n m (x: expr n m): expr n m :=
  match x with
    | e_itr x => x
    | e_pls x y => pls' (remove x) (remove y)
    | x => x
  end.

Definition itr' n (x: expr n n): expr n n :=
  (if is_zer x then 0
  else if is_top x then top
  else (remove x)^+)%ast.

Definition str' n (x: expr n n): expr n n :=
  (if is_zer x then 1
  else if is_top x then top
  else (remove x)^*)%ast.

Lemma remove_level n m (x: expr n m): e_level (remove x) ≪ e_level x.
Proof. induction x; cbn; rewrite ?pls'_level; solve_lower'. Qed.

Lemma itr'_level n (x: expr n n): e_level (itr' x) ≪ STR+e_level x.
Proof.
  unfold itr'.
  case is_zer_spec. reflexivity.
  case is_top_spec. solve_lower'.
  cbn. now rewrite remove_level.
Qed.

Lemma str'_level n (x: expr n n): e_level (str' x) ≪ STR+e_level x.
Proof.
  unfold str'.
  case is_zer_spec. reflexivity.
  case is_top_spec. solve_lower'.
  cbn. now rewrite remove_level.
Qed.

Lemma remove_spec_dep l n m (x: expr n m):
  forall (H: n=m) {Hl: STR+e_level x ≪ l}, (cast H eq_refl (remove x))^+ ==_[l] (cast H eq_refl x)^+.
Proof.
  induction x; cbn; trivial; intros H Hl.
  - subst. cbn. rewrite itr_pls_itr, pls'pls by (rewrite 2remove_level; solve_lower').
    rewrite <-(IHx1 eq_refl), <-(IHx2 eq_refl) by solve_lower'. simpl cast. apply itr_pls_itr.
  - now rewrite 2cast_eq, itr_invol.
Qed.

Lemma remove_spec l n (x: expr n n) {Hl: STR+e_level x ≪ l}:
  (remove x)^+ ==_[l] x^+.
Proof. apply (remove_spec_dep _ eq_refl). Qed.

Lemma itr'itr l n (x: expr n n) {Hl: STR+e_level x ≪ l}:
  itr' x ==_[l] x^+.
Proof.
  symmetry. unfold itr'. revert Hl.
  case is_zer_spec. intros. apply itr0.
  case is_top_spec. intros. apply itrtop.
  intros. symmetry. now apply remove_spec.
Qed.

Lemma remove_spec_dep' l n m (x: expr n m): forall (H: n=m) {Hl: STR+e_level x ≪ l},
  (cast H eq_refl (remove x))^* ==_[l] (cast H eq_refl x)^*.
Proof.
  induction x; cbn; trivial; intros H Hl.
  - subst. simpl cast. rewrite str_pls_str.
    rewrite <-(IHx1 eq_refl), <-(IHx2 eq_refl) by solve_lower'.
    simpl cast. rewrite <-str_pls_str. apply str_weq. apply pls'pls.
    rewrite 2remove_level; solve_lower'.
  - rewrite 2cast_eq. apply antisym.
    apply str_leq. apply itr_ext.
    apply str_ind_l1. apply str_refl. now rewrite itr_str_l, str_cons, str_trans.
Qed.

Lemma remove_spec' l n (x: expr n n) {Hl: STR+e_level x ≪ l}:
  (remove x)^* ==_[l] x^*.
Proof. apply (remove_spec_dep' _ eq_refl). Qed.

Lemma str'str l n (x: expr n n) {Hl: STR+e_level x ≪ l}:
  str' x ==_[l] x^*.
Proof.
  symmetry. unfold str'. revert Hl.
  case is_zer_spec. intros. apply str0.
  case is_top_spec. intros. apply strtop.
  intros. symmetry. now apply remove_spec'.
Qed.

(** ** global normalisation function *)

Fixpoint norm n m (x: expr n m): expr n m :=
  match x with
    | e_zer _ _ => 0
    | e_top _ _ => top
    | e_one _ => 1
    | e_pls x y => pls' (norm x) (norm y)
    | e_cap x y => cap' (norm x) (norm y)
    | e_neg x => e_neg (norm x)
    | e_dot x y => dot' (norm x) (norm y)
    | e_ldv x y => e_ldv (norm x) (norm y)
    | e_rdv x y => e_rdv (norm x) (norm y)
    | e_itr x => itr' (norm x)
    | e_str x => str' (norm x)
    | e_cnv x => cnv' (norm x)
    | e_var a => e_var a
  end%ast.

Lemma norm_level n m (x: expr n m): e_level (norm x) ≪ e_level x.
Proof.
  induction x; simpl norm; simpl e_level;
    rewrite ?dot'_level, ?pls'_level, ?cap'_level, ?cnv'_level,
      ?itr'_level, ?str'_level, ?IHx1, ?IHx2, ?IHx; solve_lower'.
Qed.

Lemma norm_weq l n m (x: expr n m) {Hl: e_level x ≪ l}: norm x ==_[l] x.
Proof.
  induction x; simpl norm; simpl e_level in Hl; try reflexivity;
    rewrite ?pls'pls, ?cap'cap, ?dot'dot, ?itr'itr, ?str'str, ?cnv'cnv, ?e_str'
      by (rewrite ?norm_level; solve_lower').
  apply cup_weq; [apply IHx1|apply IHx2]; solve_lower'.
  apply cap_weq; [apply IHx1|apply IHx2]; solve_lower'.
  apply neg_weq, IHx. solve_lower'.
  apply dot_weq; [apply IHx1|apply IHx2]; solve_lower'.
  apply itr_weq, IHx. solve_lower'.
  apply str_weq, IHx. solve_lower'.
  apply cnv_weq, IHx. solve_lower'.
  apply ldv_weq; [apply IHx1|apply IHx2]; solve_lower'.
  apply rdv_weq; [apply IHx1|apply IHx2]; solve_lower'.
Qed.

(** * partial decision procedure for expressions containment [<==]

   The following function tries to prove [x ≦ y], for some
   expressions [x] and [y].
   - this function always terminates, but using powerfix allows us to
     write a clean code, without bothering about termination
   - this algorithm is not complete, of course.
   - like for syntactic comparison ([syntax.expr_compare]), we need to
     generalise the function to work on distinct expression types *)

Definition expr_leq := powerfix 100
  (fun leq tt n m (x: expr n m) p q (y: expr p q) =>
    let leq {n m} x {p q} y := leq tt n m x p q y in
    match x,y with
      | e_zer _ _, _
      | _, e_top _ _
      | e_one _, e_one _
      | e_one _, e_str _ => true
      | e_one _, e_itr y => leq x y
      | e_var a, e_var b => eqb a b
      | e_pls x x', _ => leq x y &&& leq x' y
      | _, e_cap y y' =>  leq x y &&& leq x y'
      | e_cap x x', _ => leq x y ||| leq x' y
      | _, e_pls y y' =>  leq x y ||| leq x y'
      | @e_dot _ _ _ _ u _ x x', @e_dot _ _ _ _ v _ y y' (* split using one? *)
      | @e_ldv _  _ _ u _ _ y x', @e_ldv _ _ _ v _ _ x y' (* ldv_spec in the other cases? *)
      | @e_rdv _ _ _ u _ _ y x', @e_rdv _ _ _ v _ _ x y' => eqb u v &&& leq x y &&& leq x' y'
      | e_one _, e_ldv x y
      | e_one _, e_rdv x y
      | e_neg y, e_neg x
      | e_itr x, e_itr y
      | e_itr x, e_str y
      | e_str x, e_str y
      | e_cnv x, e_cnv y => leq x y
      | _,_ => false
    end) (fun _ _ _ _ _ _ _ => false) tt.

Lemma expr_leq_correct_dep l: forall n m (x: expr n m) p q (y: expr p q),
  forall Hnp: n=p, forall Hmq: m=q,
  expr_leq x y = true ->
  e_level x + e_level y ≪ l ->
  cast Hnp Hmq x <==_[l] y.
Proof.
  (* TODO: this proof could be factorised, using a more appropriate
     case disjunction, it's not that easy to setup, however *)
  unfold expr_leq. apply powerfix_invariant. 2: discriminate.
  intros leq IH n m x p q y Hnp Hmq H Hl.
  (** FIXME : subst here causes an effect leak *)
  destruct x; simpl e_level in Hl; repeat match goal with [ H : ?m = ?n |- _ ] => rewrite H in *; clear H end.
  - rewrite cast_eq. lattice.
  - destruct y; simpl e_level in Hl; try discriminate H.
    + now rewrite cast_eq.
    + apply leq_xcup. apply lorb_spec in H as [H|H];
      apply (IH _ _ _ _ _ _ eq_refl eq_refl) in H; auto; solve_lower'.
    + apply landb_spec in H as [H1 H2]. apply leq_xcap; apply IH; trivial; solve_lower'.
  - destruct y; simpl e_level in Hl; try discriminate H; try subst.
    + subst. rewrite cast_eq. lattice.
    + now rewrite cast_eq.
    + subst. apply leq_xcup. apply lorb_spec in H as [H|H];
      apply (IH _ _ _ _ _ _ eq_refl eq_refl) in H; auto; solve_lower'.
    + apply landb_spec in H as [H1 H2]. apply leq_xcap; apply IH; trivial; solve_lower'.
    + rewrite <-itr_ext. apply IH. assumption. solve_lower'.
    + rewrite cast_eq. apply str_refl.
    + subst. rewrite cast_eq. apply ldv_spec. rewrite dotx1.
      apply (IH _ _ _ _ _ _ eq_refl eq_refl H); solve_lower'.
    + subst. rewrite cast_eq. apply rdv_spec. rewrite dot1x.
      apply (IH _ _ _ _ _ _ eq_refl eq_refl H); solve_lower'.
  - destruct y; simpl e_level in Hl; try discriminate H; try subst;
    try (apply landb_spec in H as [H1 H2]; apply leq_cupx;
          [ apply (IH _ _ _ _ _ _ eq_refl eq_refl H1); solve_lower'
          | apply (IH _ _ _ _ _ _ eq_refl eq_refl H2); solve_lower' ]).
    lattice.
  - destruct y; simpl e_level in Hl; try discriminate H; try subst;
    try (rewrite cast_eq; apply leq_capx; apply lorb_spec in H as [H|H];
        (apply (IH _ _ _ _ _ _ eq_refl eq_refl) in H; [auto |solve_lower'])).
    lattice.
    rewrite cast_eq. apply landb_spec in H as [H1 H2].
     apply (IH _ _ _ _ _ _ eq_refl eq_refl) in H1; [|solve_lower'].
     apply (IH _ _ _ _ _ _ eq_refl eq_refl) in H2; [|solve_lower'].
     hlattice.
  - destruct y; simpl e_level in Hl; try discriminate H; try subst.
    + lattice.
    + apply leq_xcup. apply lorb_spec in H as [H|H];
      apply (IH _ _ _ _ _ _ eq_refl eq_refl) in H; auto; solve_lower'.
    + apply landb_spec in H as [H1 H2]. apply leq_xcap; apply IH; trivial; solve_lower'.
    + rewrite cast_eq. apply neg_leq.
      apply (IH _ _ _ _ _ _ eq_refl eq_refl H). solve_lower'.
  - destruct y; simpl e_level in Hl; try discriminate H; try subst.
    + lattice.
    + apply leq_xcup. apply lorb_spec in H as [H|H];
      apply (IH _ _ _ _ _ _ eq_refl eq_refl) in H; auto; solve_lower'.
    + apply landb_spec in H as [H1 H2]. apply leq_xcap; apply IH; trivial; solve_lower'.
    + rewrite cast_eq. apply landb_spec in H as [H' H]. apply landb_spec in H as [H1 H2].
      revert H'. case eqb_spec. 2: discriminate. intros ? _. subst.
      apply dot_leq.
       apply (IH _ _ _ _ _ _ eq_refl eq_refl H1); solve_lower'.
       apply (IH _ _ _ _ _ _ eq_refl eq_refl H2); solve_lower'.
  - destruct y; simpl e_level in Hl; try discriminate H; try subst.
    + lattice.
    + subst. apply leq_xcup. apply lorb_spec in H as [H|H];
      apply (IH _ _ _ _ _ _ eq_refl eq_refl) in H; auto; solve_lower'.
    + apply landb_spec in H as [H1 H2]. apply leq_xcap; apply IH; trivial; solve_lower'.
    + rewrite cast_eq. apply itr_leq.
      apply (IH _ _ _ _ _ _ eq_refl eq_refl H); solve_lower'.
    + rewrite cast_eq. rewrite itr_str_l, <-(str_cons y).
      apply (IH _ _ _ _ _ _ eq_refl eq_refl) in H. 2: solve_lower'.
      simpl cast in H. now rewrite H.
  - destruct y; simpl e_level in Hl; try discriminate H; try subst.
    + lattice.
    + subst. apply leq_xcup. apply lorb_spec in H as [H|H];
      apply (IH _ _ _ _ _ _ eq_refl eq_refl) in H; auto; solve_lower'.
    + apply landb_spec in H as [H1 H2]. apply leq_xcap; apply IH; trivial; solve_lower'.
    + rewrite cast_eq. apply str_leq.
      apply (IH _ _ _ _ _ _ eq_refl eq_refl H); solve_lower'.
  - destruct y; simpl e_level in Hl; try discriminate H; try subst.
    + lattice.
    + apply leq_xcup. apply lorb_spec in H as [H|H];
      apply (IH _ _ _ _ _ _ eq_refl eq_refl) in H; auto; solve_lower'.
    + apply landb_spec in H as [H1 H2]. apply leq_xcap; apply IH; trivial; solve_lower'.
    + rewrite cast_eq. apply cnv_leq.
      apply (IH _ _ _ _ _ _ eq_refl eq_refl H); solve_lower'.
  - destruct y; simpl e_level in Hl; try discriminate H; try subst.
    + lattice.
    + apply leq_xcup. apply lorb_spec in H as [H|H];
      apply (IH _ _ _ _ _ _ eq_refl eq_refl) in H; auto; solve_lower'.
    + apply landb_spec in H as [H1 H2]. apply leq_xcap; apply IH; trivial; solve_lower'.
    + rewrite cast_eq. apply landb_spec in H as [H' H]. apply landb_spec in H as [H1 H2].
      revert H'. case eqb_spec. 2: discriminate. intros ? _. subst.
      apply ldv_leq.
       apply (IH _ _ _ _ _ _ eq_refl eq_refl H1); solve_lower'.
       apply (IH _ _ _ _ _ _ eq_refl eq_refl H2); solve_lower'.
  - destruct y; simpl e_level in Hl; try discriminate H; try subst.
    + lattice.
    + apply leq_xcup. apply lorb_spec in H as [H|H];
      apply (IH _ _ _ _ _ _ eq_refl eq_refl) in H; auto; solve_lower'.
    + apply landb_spec in H as [H1 H2]. apply leq_xcap; apply IH; trivial; solve_lower'.
    + rewrite cast_eq. apply landb_spec in H as [H' H]. apply landb_spec in H as [H1 H2].
      revert H'. case eqb_spec. 2: discriminate. intros ? _. subst.
      apply rdv_leq.
       apply (IH _ _ _ _ _ _ eq_refl eq_refl H1); solve_lower'.
       apply (IH _ _ _ _ _ _ eq_refl eq_refl H2); solve_lower'.
  - destruct y; simpl e_level in Hl; try discriminate H; subst.
    + lattice.
    + apply leq_xcup. apply lorb_spec in H as [H|H]; eapply IH in H; eauto; solve_lower'.
    + apply landb_spec in H as [H1 H2]. apply leq_xcap; apply IH; trivial; solve_lower'.
    + apply eqb_eq in H. subst. now rewrite cast_eq.
Qed.

(** correctness of the comparison function *)
Corollary expr_leq_correct l n m (x y: expr n m):
  expr_leq x y = true ->
  e_level x + e_level y ≪ l ->
  x <==_[l] y.
Proof. apply (expr_leq_correct_dep x y eq_refl eq_refl). Qed.

(** * Associated tactics *)

(** parametrised (in)equality tests, where we decide to check for an
   equality or an inequality depending on the Boolean [b]. This helps
   to factorise tactics code. *)

Definition expr_leq_or_weq (b: bool) n m (x y: expr n m) :=
  if b then expr_leq x y else eqb x y.

Lemma expr_leq_or_weq_correct b l n m (x y: expr n m):
  e_level x + e_level y ≪ l ->
  expr_leq_or_weq b x y -> @leq_or_weq b (expr_lattice_ops _ _ l _ _) x y.
Proof.
  intros Hl H. destruct b. apply expr_leq_correct; assumption.
  apply eqb_eq in H as <-. reflexivity.
Qed.

End n.

(** normalisation lemma, suited for use with reification ; we use two
   "let-in" constructs to make it possible to isolate computations of
   the normal forms (using vm_compute) from the unfolding of the
   interpretation function (using "unfold" selectively) *)

Lemma ra_normalise d b `{L: laws} f' (f: positive -> Pack X f')
  n m (x y: expr _ _ n m) (Hl: e_level x + e_level y ≪ l):
  (let x' := norm d x in let y' := norm d y in packed_eval f x' <=[b]= packed_eval f y') ->
  packed_eval f x <=[b]= packed_eval f y.
Proof.
  unfold packed_eval. intro H.
  eapply leq_or_weq_weq; [symmetry.. | eassumption];
    (eapply norm_weq; [ | eassumption]); solve_lower'.
Qed.

(** reflexivity-by-normalisation lemma, suited for use with
   reification *)

Lemma ra b `{L: laws} f' (f: positive -> Pack X f')
  n m (x y: expr _ _ n m) (Hl: e_level x + e_level y ≪ l):
  expr_leq_or_weq b (norm true x) (norm true y) = true -> packed_eval f x <=[b]= packed_eval f y.
Proof.
  intro H. apply (ra_normalise true b). assumption.
  intros x' y'. subst x' y'. eapply expr_leq_or_weq_correct in H.
  destruct b; apply (H _ L).
  now rewrite 2norm_level.
Qed.

(** ** [ra]: solve goals by normalisation.

   In case of an inequality, the above comparison function is used, so
   that [apply antisym; ra] might solve goals which are
   not solved by [ra]. (e.g., [a+a^*+b^* ≡ b+a^*+b^*]) *)

Ltac ra :=
  let go h L tac :=
    ra_reify h;
    let lhs:=fresh "lhs" in
    let rhs:=fresh "rhs" in
    intros ? ? ? ? lhs rhs;
    apply (@ra _ _ _ L _ _ _ _ lhs rhs);
    [ tac || fail "RelationAlgebra: invalid reification (please report)" |
      close_by_reflection true || fail "not provable by relation algebra normalisation" ]
  in
  intros; catch_rel;
  let L:=fresh "L" in intro L;
  let l:=match type of L with laws ?l _ => l end in
  lazymatch goal with
  | H: ?h ≪ l |- _ => go h L ltac:(rewrite <- H; reflexivity)
  | _ => go l L ltac:(reflexivity || destruct l; reflexivity)
  end.

(* (* vm_compute in value of h, even in presence of evars [DOES NOT WORK] *) *)
(* Ltac evm_compute h := *)
(*   (has_evar h;  *)
(*     idtac "warning: there are evar, cannot use vm_compute"; *)
(*       compute in (value of h)) *)
(*   || vm_compute in (value of h). *)

(** ** [ra_normalise/simpl]: normalise the current goal *)

Ltac ra_normalise_ distribute :=
  let go h L tac :=
    ra_reify h;
    let tenv:=fresh "tenv" in
    let env:=fresh "env" in
    let src:=fresh "src" in
    let tgt:=fresh "tgt" in
    let lhs:=fresh "lhs" in
    let rhs:=fresh "rhs" in
    intros ? ? ? ? lhs rhs;
    apply (@ra_normalise distribute _ _ _ L _ _ _ _ lhs rhs);
    [ tac; reflexivity || fail "RelationAlgebra: invalid reification (please report)" |
      let lhs':=fresh "lhs'" in
      let rhs':=fresh "rhs'" in
      intros lhs' rhs';
      vm_compute in (value of lhs'), (value of rhs');
      unfold sigma_add in env, tenv;
      unfold lhs', rhs', packed_eval, eval, val, src, tgt, env, tenv, sigma_get;
      unfold leq_or_weq;
      clear tenv env src tgt lhs rhs lhs' rhs' L ]
  in
  catch_rel;
  let L:=fresh "L" in intro L;
  let l:=match type of L with laws ?l _ => l end in
  lazymatch goal with
  | H: ?h ≪ l |- _ => go h L ltac:(rewrite <- H; reflexivity)
  | _ => go l L ltac:(reflexivity || destruct l; reflexivity)
  end.

(** [ra_normalise] distribut products over sums, while [ra_simpl] does not *)

Ltac ra_simpl := ra_normalise_ false.
Ltac ra_normalise := ra_normalise_ true.


(** * Equations satisfied by the quotient 1-model

Let Σ be an epi 1-signature.
Let R be a 1-model of Σ and (α_i : R → S_i)_i be a (possibly large) family of
1-model morphisms.

Then we can construct the quotient 1-model R' (see
quotienrepslice) which is defined as R'(X) = R(X) / ~
and x ~ y iff for all i, α_i(x) = α_i(y)

In this file, we show that if each S_i satisfies the same family of soft
equations, then it is also the case for R'.

- Definition of the soft condition [isSoft]
- Definition of a soft equation [soft_equation]
- Definition of an elementary equation [elementary_equation]
- The quotient model as a 2-model [R'_model_equations]

*)
Require Import UniMath.Foundations.PartD.

Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.Monads.LModules.
Require Import UniMath.CategoryTheory.SetValuedFunctors.
Require Import UniMath.CategoryTheory.HorizontalComposition.
Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.categories.HSET.All.

Require Import UniMath.Foundations.Sets.
Require Import UniMath.CategoryTheory.Epis.
Require Import UniMath.CategoryTheory.EpiFacts.
Require Import Modules.Prelims.EpiComplements.

Require Import Modules.Prelims.lib.
Require Import Modules.Prelims.quotientmonad.
Require Import Modules.Prelims.quotientmonadslice.
Require Import Modules.Signatures.Signature.
Require Import Modules.Signatures.PreservesEpi.
Require Import Modules.Signatures.ModelCat.

Require Import Modules.SoftEquations.quotientrepslice.
Require Import Modules.SoftEquations.SignatureOver.
Require Import Modules.SoftEquations.Equation.
Require Import Modules.SoftEquations.SignatureOverDerivation.

(** Notation for 1-model morphism *)
Local Notation  "R →→ S" := (rep_fiber_mor R S) (at level 6).

Section QuotientRep.

  Local Notation MOD Mon := (category_LModule Mon SET).
Local Notation MONAD := (Monad SET).
Local Notation SIG := (signature SET).

  (** We fix a 1-signature Sig *)
Context {Sig : SIG}.
  (** Sig must be an epi-signature, i.e. preserves epimorphicity of natural
      transformations *)
Context (epiSig : sig_preservesNatEpiMonad Sig).

(** Definition of a soft Sig-module

It is a soft module Σ such that for any model R, and any family of model morphisms
(f_j : R --> d_j), the following triangle can be completed in the category
of natural transformations (from Σ(S) to Σ(d_j)):

<<<
           Σ(f_j)
    Σ(R) ----------->  Σ(d_j)
     |
     |
     |
 Σ(π)|
     |
     V
    Σ(S)

>>>

where π : R -> S is the canonical projection (S is R quotiented by the family (f_j)_j

 *)
  Definition isSoft (OSig : signature_over Sig) :=
    ∏ (R : model Sig) (R_epi : preserves_Epi R)(SigR_epi : preserves_Epi (Sig R))
      (J : UU)(d : J -> (model Sig))(f : ∏ j, R →→ (d j))
      X (x y : (OSig R X : hSet)) (pi := projR_rep Sig epiSig  R_epi SigR_epi d f),
    (∏ j, (# OSig (f j))%sigo X x  = (# OSig (f j))%sigo X y )
      -> (# OSig pi X x)%sigo =
        (# OSig pi X y)%sigo  .

  Local Notation REP := (model Sig).

  (** Some examples of soft Sig-modules: the tautological soft module assigning
      a 1-model to itsefl.
    *)
  Lemma isSoft_tauto : isSoft (tautological_signature_over Sig).
  Proof.
    red; cbn.
    intros.
    apply rel_eq_projR.
    assumption.
  Defined.

  Local Notation BC := BinCoproductsHSET.
  Local Notation T := TerminalHSET.

  (** Derivative of a soft Sig-module is soft *)
  Lemma isSoft_derivative {OSig} (soft : isSoft OSig)
    : isSoft (signature_over_deriv (C := SET) BC T OSig).
  Proof.
    red; cbn.
    intros R J d f X x y h.
    use soft.
    (* use h. *)
  Defined.

  (** Any finite derivative of the tautological soft Sig-module is soft *)
  Corollary isSoft_finite_deriv_tauto n :
    isSoft (signature_over_deriv_n Sig BC T (tautological_signature_over Sig) n).
  Proof.
    induction n.
    - apply isSoft_tauto.
    - apply isSoft_derivative.
      apply IHn.
  Qed.

  Local Notation σ := source_equation.
  Local Notation τ := target_equation.

  (** An epi Sig-module is a module M which preserves the epimorphicity
      in the category of natural transformations *)
  Definition isEpi_overSig (M : signature_over Sig) :=
        ∏ R S (f : R →→ S),
                   isEpi (C := [SET, SET]) (f : nat_trans _ _) ->
                   isEpi (C := [SET, SET]) (# M f : nat_trans _ _)%sigo.

  Definition isEpi_sig_isEpi_overSig (S : signature _) (h : sig_preservesNatEpiMonad S) :
    isEpi_overSig (sig_over_from_sig _ S) := h.

  (** An equation is soft if the source is an epi Sig-module
      and the target is soft *)
  Definition isSoft_eq (e : equation Sig) :=
    isSoft (τ e) × isEpi_overSig (σ e).

  (** A soft equation is an equation where the source is an epi Sig-module
      and the target is soft *)
  Definition soft_equation :=
    ∑ (e : equation Sig), isSoft_eq e.

  Coercion eq_from_soft_equation (e : soft_equation) : equation Sig := pr1 e.

  Definition soft_equation_isSoft (e : soft_equation) : isSoft (τ e) :=
    pr1 (pr2 e).

  Definition soft_equation_isEpi (e : soft_equation) : isEpi_overSig (σ e) :=
    pr2 (pr2 e).

  (** Back to the proof *)

  (** Consider a 1-model R with a family of 1-model morphisms (ff_j :  R -> d_j)_j *)
  Context {R : REP}.
  (** implied by the axiom of choice *)
  Context (R_epi : preserves_Epi R).
  Context (SigR_epi : preserves_Epi (Sig R)).

  Context {J : UU} (d : J -> REP)
            (ff : ∏ (j : J), R →→ (d j)).

  (** R' is the 1-model R quotiented by the following relation on R(X):
         x ~ y iff ff_j(x) = ff_j(y) for all j *)
  Let R' : REP := R'_model Sig epiSig R_epi SigR_epi d ff.
  (** The canonical projection R -> R' as a 1-model morphism *)
  Let projR : rep_fiber_mor R R' := projR_rep  Sig epiSig R_epi SigR_epi d ff.

  Local Notation π := projR.
  Local Notation Θ := tautological_LModule.

  (** If all the d_j satisifes the same soft equation, then it is the case
      of the quotient R' *)
  Lemma R'_satisfies_eq (e : soft_equation)
        (deq : ∏ j, satisfies_equation e (d j))
    : satisfies_equation e  R'.
  Proof.
    red.
    apply LModule_Mor_equiv; [apply homset_property|].
    apply (soft_equation_isEpi e _ _ projR).
    {  apply isEpi_projR. }
    etrans ; [apply signature_over_Mor_ax  |].
    etrans ; [ | apply pathsinv0; apply signature_over_Mor_ax  ].
    apply nat_trans_eq; [apply homset_property |].
    intro X.
    apply funextfun.
    intro x.
    apply soft_equation_isSoft.
    intro j.
    do 2 rewrite comp_cat_comp.
    use (toforallpaths _ _ _ _ x).
    do 2 rewrite nat_trans_comp_pointwise'.
    use (toforallpaths _ _ _ _ X).
    rewrite <- (signature_over_Mor_ax _ (halfeq1 e)).
    rewrite <- (signature_over_Mor_ax _ (halfeq2 e)).
    apply maponpaths.
    apply (cancel_precomposition  [SET,SET]).
    repeat apply maponpaths.
    apply deq.
  Qed.

  (** Thus, if all the d_j satisfy the same family of soft equations, then it is
       also the case of R' *)
  Definition R'_satisfies_all_equations {O : UU} (e : O -> soft_equation)
    (deq : ∏ j, satisfies_all_equations_hp e  (d j))
    : satisfies_all_equations_hp e R'
    := fun o => R'_satisfies_eq (e o) (fun j => deq j o).

  (** R' can be thus given the structure of a 2-model *)
  Definition R'_model_equations {O : UU} (e : O -> soft_equation)
    (deq : ∏ j, satisfies_all_equations_hp e (d j))
    : model_equations e
    := R' ,, R'_satisfies_all_equations e deq.

  (** ** Definition of elementary equations
   *)
  Local Notation θ := (tautological_signature_over Sig).
  Local Notation "M ^( n )" := (signature_over_deriv_n Sig BC T M n) (at level 6).

  (** An elementary equation

The source is an epi-Sig-module and the target a finite derivative of the tautological signature

   *)
  Definition elementary_equation : UU :=
    ∑ (S1 : signature_over Sig)(n : nat), isEpi_overSig S1 × half_equation S1 (θ ^(n)) × half_equation S1 (θ ^(n)).

  (** The Sig-module source of a soft equation *)
  Definition source_elem_eq (e : elementary_equation) : signature_over Sig :=
    pr1 e.
  (** The Sig-module target of a soft equation *)
  Definition target_elem_eq (e : elementary_equation) : nat :=
    pr1 (pr2 e).

  Local Notation σ' := source_elem_eq.
  Local Notation τ' := target_elem_eq.

  Definition source_elem_epiSig (e : elementary_equation) : isEpi_overSig (σ' e) :=
    pr1 (pr2 (pr2 e)).

  Definition half_elem_eqs (e : elementary_equation) :
    half_equation (σ' e) (θ ^(τ' e)) ×
    half_equation (σ' e) (θ ^(τ' e))
    :=
    pr2 (pr2 (pr2 e)).

  (** Helper to build a soft equation *)
  Definition mk_soft_equation {A B : signature_over Sig} (heq  : half_equation A B × half_equation A B)
             (hA : isEpi_overSig A) (hB : isSoft B) : soft_equation :=
    tpair isSoft_eq (A ,, B ,, heq) (hB ,, hA).

  Coercion soft_equation_from_elementary_equation (e : elementary_equation) : soft_equation :=
    mk_soft_equation (half_elem_eqs e)  (source_elem_epiSig e)
                     (isSoft_finite_deriv_tauto (target_elem_eq e)).

End QuotientRep.

Definition soft_equation_choice (choice : AxiomOfChoice.AxiomOfChoice_surj) (S : signature SET)
            (** S preserves epimorphisms of monads *)
           (isEpi_sig : sig_preservesNatEpiMonad S)
         : UU :=
  soft_equation isEpi_sig.

Identity Coercion forget_choice : soft_equation_choice >-> soft_equation.


Require Export Iron.Language.SystemF2Data.Exp.Base.
Require Export Iron.Language.SystemF2Data.Exp.Alt.
Require Export Iron.Language.SystemF2Data.Exp.Operator.LiftTX.

(* Lift expression indices in expressions *)
Fixpoint liftXX (n:  nat) (d:  nat) (xx: exp) {struct xx} : exp :=
 match xx with
    |  XVar ix
    => if le_gt_dec d ix
        (* index was pointing into env, lift it across new elems *)
        then XVar (ix + n)
        (* index was locally bound, leave it be *)
        else xx

    |  XLAM x
    => XLAM (liftXX n d x)

    |  XAPP x t
    => XAPP (liftXX n d x) t

    |  XLam t1 x1
    => XLam t1 (liftXX n (S d) x1)

    |  XApp x1 x2
    => XApp   (liftXX n d x1) (liftXX n d x2)

    |  XCon dc ts xs
    => XCon dc ts (map (liftXX n d) xs)

    |  XCase x alts
    => XCase (liftXX n d x) (map (liftXA n d) alts)

    |  XPrim p xs
    => XPrim p (map (liftXX n d) xs)

    |  XLit l
    => XLit l
    end

 with liftXA (n: nat) (d: nat) (aa: alt) {struct aa}:=
  match aa with
  (* When we enter into the right of an alternative, a new type
     is pushed onto the environment for each of the arguments
     of the data constructor. We need to increase the current
     binding depth by the number of arguments. *)
  |  AAlt (DataCon tag arity) x
  => AAlt (DataCon tag arity) (liftXX n (d + arity) x)
  end.

(* Data constructor of an alternative is unchanged by lifting. *)
Lemma dcOfAlt_liftXA
 : forall n d a
 , dcOfAlt (liftXA n d a) = dcOfAlt a.
Proof.
 intros. destruct a. destruct d0. auto.
Qed.
Hint Rewrite dcOfAlt_liftXA : global.

(* Lifting an expression by zero places is indentity. *)
Lemma liftXX_zero
 : forall d x
 , liftXX 0 d x = x.
Proof.
 intros. gen d.
 induction x using exp_mutind with
  (PA := fun a => forall d
      ,  liftXA 0 d a = a);
  intros; simpl; try burn.

 - Case "XCon".
   nforall.
   rewrite (map_ext_in (liftXX 0 d) id); auto.
   rewrite map_id; auto.

 - Case "XCase".
   nforall.
   rewrite (map_ext_in (liftXA 0 d) id); auto.
   rewrite map_id. burn.

 - Case "XPrim".
   nforall.
   rewrite (map_ext_in (liftXX 0 d) id); auto.
   rewrite map_id; auto.

 - Case "XAlt".
   destruct dc. burn.
Qed.
Hint Rewrite liftXX_zero : global.

(* Commutativity of lifting. *)
Lemma liftXX_comm
 : forall n m x d
 , liftXX n d (liftXX m d x)
 = liftXX m d (liftXX n d x).
Proof.
 intros. gen d.
 induction x using exp_mutind with
  (PA := fun a => forall d
      ,  liftXA n d (liftXA m d a)
      =  liftXA m d (liftXA n d a));
  try (solve [intros; simpl; f_equal; rewritess; eauto]).

 - Case "XVar".
   repeat (simple; lift_cases; intros); f_equal; try omega; burn.

 - Case "XCon".
   snorm. f_equal.
   lists.
   rewrite (map_ext_in
    (fun x0 => liftXX n d (liftXX m d x0))
    (fun x0 => liftXX m d (liftXX n d x0))); burn.

 - Case "XCase".
   snorm. f_equal.
   + auto.
   + lists.
     rewrite (map_ext_in
      (fun a1 => liftXA n d (liftXA m d a1))
      (fun a1 => liftXA m d (liftXA n d a1))); burn.

 - Case "XPrim".
   snorm. f_equal.
   lists.
   rewrite (map_ext_in
    (fun x0 => liftXX n d (liftXX m d x0))
    (fun x0 => liftXX m d (liftXX n d x0))); burn.

 - Case "XAlt".
   snorm.
   destruct dc. snorm. f_equal. auto.
Qed.

(* When consecutively lifting an expression, we can lift by one
   more place in the first lifting and but one less in the second. *)
Lemma liftXX_succ
 : forall n m d x
 , liftXX (S n) d (liftXX m     d x)
 = liftXX n     d (liftXX (S m) d x).
Proof.
 intros. gen d.
 induction x using exp_mutind with
  (PA := fun a => forall d
      ,  liftXA (S n) d (liftXA  m    d a)
      =  liftXA n     d (liftXA (S m) d a));
  try (solve [intros; simpl; f_equal; rewritess; eauto]).

 - Case "XVar".
   repeat (simple; lift_cases; intros); f_equal; try omega; burn.

 - Case "XCon".
   snorm. f_equal.
   lists.
   rewrite (map_ext_in
    (fun x0 => liftXX (S n) d (liftXX m d x0))
    (fun x0 => liftXX n d (liftXX (S m) d x0))); burn.

 - Case "XCase".
   snorm. f_equal.
   + auto.
   + lists.
     rewrite (map_ext_in
      (fun x1 => liftXA (S n) d (liftXA m d x1))
      (fun x1 => liftXA n d (liftXA (S m) d x1))); burn.

 - Case "XPrim".
   snorm. f_equal.
   lists.
   rewrite (map_ext_in
    (fun x0 => liftXX (S n) d (liftXX m d x0))
    (fun x0 => liftXX n d (liftXX (S m) d x0))); burn.

 - Case "XAlt".
   snorm.
   destruct dc; snorm; f_equal; auto.
Qed.
Hint Rewrite liftXX_succ : global.

(* We can collapse two consecutive lifting expressions by lifting
   just onces by the sum of the places, provided the lifting
   occurs at depth zero. *)
Lemma liftXX_plus
 : forall n m x
 , liftXX n 0 (liftXX m 0 x) = liftXX (n + m) 0 x.
Proof.
 intros. gen n.
 induction m; intros.
 - burn.
 - intros.
   rrwrite (n + S m = S n + m).
   rewrite liftXX_comm.
   rewrite <- IHm.
   rewrite liftXX_comm.
   burn.
Qed.


Module minimal_Gallina_introduction.

Variable x : Prop.
Variables A B : Prop.
Variable t2 : Prop.

Check A -> B : Prop.
(* NB: holds thanks to the rule Prod-Prop *)

Check (fun y => y -> y) : Prop -> Prop.
Definition t1_oops := fun y => y -> y.
Check t1_oops.
Definition t1 := fun y : Prop => y -> y.
Check t1.
Check (t1 t2) : Prop.

Check (Prop -> Prop) -> B.
(* NB: Prop -> Prop has type a sort -> ok *)
Fail Check (fun y : Prop => y -> y) -> B.
(* NB: (fun y : Prop => y -> y) has type Prop -> Prop, which is not a sort -> NG *)

End minimal_Gallina_introduction.

From Ssreflect Require Import ssreflect.

Module propositions_as_types_example.

Lemma hilbertS (A B C : Prop) :
  (A -> B -> C) -> (A -> B) -> A -> C.
Show Proof.
move=> H1.
Show Proof. (* observe the effect of move=> on the proof-term *)
move=> H2.
move=> H3.
Show Proof.
cut B. (* NB: this is a traditional Coq tactic, seldom used in practice but corresponds well to modus ponens *)
Show Proof.
cut A.
Show Proof.
assumption.
assumption.
Show Proof.
cut A.
assumption.
assumption.
Show Proof.
Qed.

Definition hilbertS_proof :=
  fun (A B C : Prop) (H1 : A -> B -> C) (H2 : A -> B) (H3 : A) =>
    (fun H : B => (fun H0 : A => H1 H0) H3 H) ((fun H : A => H2 H) H3).

Lemma hilbertS_direct_proof (A B C : Prop) :
  (A -> B -> C) -> (A -> B) -> A -> C.
exact (hilbertS_proof A B C).
Qed.

Lemma hilbertS_in_practice (A B C : Prop) :
  (A -> B -> C) -> (A -> B) -> A -> C.
move=> H1.
move=> H2.
move=> H3.
apply H1.
exact H3.
apply H2.
exact H3.
Show Proof.
Qed.

Definition hilbertS_in_practice_proof :=
  fun (A B C : Prop) (H1 : A -> B -> C) (H2 : A -> B) (H3 : A) =>
    H1 H3 (H2 H3).

Goal hilbertS_proof = hilbertS_in_practice_proof.
reflexivity.
Qed.

End propositions_as_types_example.

Module move_and_apply_tactics.

Lemma modus_ponens : forall P Q : Prop, (P -> Q) -> P -> Q.
Show Proof.
move=> P.
move: P.
move=> P Q PQ p.
move: PQ.
apply.
done.
Qed.

Goal forall P Q : Prop, (forall R : Prop, R -> Q) -> P -> Q.
Proof.
move=> P Q rq p.
Fail apply rq.
apply: rq p.
(*
compare with:
refine (rq _ _).
exact p.
*)
Qed.

(* a note an unification *)
Variable A : Prop.
Variable op : A -> A -> A.
Local Notation "a + b" := (op a b). (* left associative *)
Hypothesis opA : forall a b c, a + (b + c) = a + b + c.
Check opA.
Variable lt : A -> A -> Prop.
Local Notation "a < b" := (lt a b).
Hypothesis lt_addr : forall m n p, m < n -> m < n + p.

Goal forall a b c d,
  a < b ->
  a < b + c + d.
move=> a b c d.
Fail apply lt_addr.
(* Error: Impossible to unify "b + c" with "b". *)
(* match m<->a, n<->b, p<->d and thus b + c<->n !!! *)
rewrite -opA.
apply lt_addr.
Qed.

Goal False.
evar (x : nat).
have : (2 + x = 4 + 5)%nat.
  rewrite /x.
  apply refl_equal.
rewrite /= in x *.
Abort.

End move_and_apply_tactics.

Lemma exo0 : forall P : Prop, P -> P.
Proof.
Admitted.

Lemma exo1 : forall P Q : Prop, P -> (P -> Q) -> Q.
Proof.
Admitted.

Lemma exo2 : forall P : Prop, (P -> P) -> P -> P.
Proof.
(* NB: pove using the modus ponens lemma *)
Admitted.

(* transitivity of implication *)
Lemma exo3 P Q R : (P -> Q) -> (Q -> R) -> P -> R.
Proof.
Admitted.

Section logical_connectives.

Print True.
Check True.
Check I.

Goal True.
apply: I.
Qed.

Print False.

Goal True -> False.
case.
Show Proof.
Abort.

Check False_ind.

Goal False -> 1 = 0.
move=> p.
exact: (False_ind (1 = 0) p).
Qed.

Goal False -> 1 = 0.
case.
Qed.

Print and.
Check conj I I.
Print and_ind.
Print and_rect.

Goal forall P Q, P /\ Q -> Q /\ P.
move=> P Q.
case.
Show Proof.
move=> p q.
split.
exact q.
exact p.
Qed.

Print or.
Check or_ind.

Check (or_intror False I).
About or_intror.
Check (@or_intror False True I).
Check (@or_intror False _ I).
Check (@or_intror _ _ I).
Check (@or_intror _ _ I) :  False \/ True.

Goal forall A B, A \/ B -> B \/ A.
move=> A B.
case => [a | b].
  right.
  exact.
left.
exact b.
Qed.

End logical_connectives.

Lemma exo4 : False \/ True.
Proof.
Abort.

Lemma exo5 : forall A B C : Prop, A /\ B <-> B /\ A.
Proof.
move=> A B C.
Locate "<->".
Print iff.
(* (A /\ B -> B /\ A) /\ (B /\ A -> A /\ B) *)
Abort.

Lemma exo6 (A B C : Prop) : A /\ B /\ C ->
  (A /\ B) /\ C.
Proof.
Abort.

Lemma exo7 (A B : Prop) : (A -> B) -> (~B -> ~A).
Proof.
(* ~ A =def= A -> False *)
Abort.

Section Set_Prop.

Check nat.

Goal 0 = 1 -> False.
move=> abs.
discriminate.
Qed.

(* case analysis of Prop proofs forbidden on sorts Set and Types *)

Goal (exists n : nat, True) -> nat.
Fail case.
(*  Error: Case analysis on sort Set is not allowed for inductive definition ex *)
Abort.
About ex.

Goal forall A B : Prop, A \/ B -> nat.
move=> A B.
Fail case.
Abort.

(* case analysis of Prop proofs ok on sort Set when only one constructor *)

Goal 0 = 1 -> nat.
move=> abs.
discriminate.
Show Proof.
Qed.

Goal forall n m : nat, n = m /\ n <> m -> nat.
move=> n m.
case => nm nm'.
exact O.
Qed.

Print sum.
Print sumbool.
Print sumor.

(* case analysis of Type proofs ok on any sorts *)

About sig.
Goal {n : nat | True} -> nat.
case.
move=> m _.
exact m.
Qed.

End Set_Prop.

Section product_formation.

(* NB: hierarchy *)
Check Prop.
Check Set.
Set Printing Universes.
Check Type.
Unset Printing Universes.

(* rule Prop <= Set: *)
Variables P0 P1 : Prop.
Check P0 -> P1 : Set.
Check P0 : Set.
(* rule Prop <= Type: *)
Check P0 : Type.
(* NB: rule Set <= Type: *)
Variable S0 : Set.
Check S0 : Type.

(* rule Prod-Prop: *)
Check P1 -> P1 : Prop.
Check (S0 -> P0) : Prop.
Variable T0 : Type.
Check (T0 -> P0) : Prop.

Check (True -> True).
Check (forall x : nat, 0 <= x).
Check (forall x : nat, x = x) : Set.
Check (forall A : Prop, A -> A).
Check nat -> Prop.
Check (forall P : nat -> Prop, P O -> exists n : nat , P n) : Prop.

(* rule Prod-Set: *)
Check (P0 -> S0) : Set.
Fail Check (P0 -> S0) : Prop.
Variable S1 : Set.
Check (S1 -> S0) : Set.
Fail Check (T0 -> S0) : Set.

Check (nat -> nat).
Fail Check (forall A : Set, A -> A) : Set.

(* rule Prod-Type: *)

Check (Prop -> Prop) : Type.
Check (Set -> Set) : Type.
Check (forall A : Set, A -> A) : Type.
Check (nat -> Prop) : Type.
Check ((Prop -> Prop) -> Prop) : Type.
Check (forall P : nat -> Prop, Prop) : Type.

End product_formation.


From Coq Require Import Unicode.Utf8.

Theorem plus_one_r' : ∀ n:nat,
  n + 1 = S n.
Proof.
    apply nat_ind.
    reflexivity.
    intros.
    simpl.
    rewrite <- H.
    reflexivity.
    Qed.

Inductive booltree : Type :=
    | bt_empty
    | bt_leaf (b : bool)
    | bt_branch (b : bool) (t1 t2 : booltree).


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

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 2.1 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 GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Nnat.
Require Import Arith.
Require Export Ring.
Require Import Rsequence_def.
Require Import Reals.
Require Import Setoid.

Open Scope Rseq_scope.

Add Morphism Rseq_plus with signature Rseq_eq ==> Rseq_eq ==> Rseq_eq as Rseq_plus_Rseq_eq_compat.
(*Add Morphism Rseq_plus : Rseq_plus_Rseq_eq_compat.*)
Proof.
unfold Rseq_eq, Rseq_plus.
intros Un Vn Huv Xn Yn Hxy n.
rewrite Huv.
rewrite Hxy.
reflexivity.
Qed.

Add Morphism Rseq_minus with signature Rseq_eq ==> Rseq_eq ==> Rseq_eq as Rseq_minus_Rseq_eq_compat.
(* Add Morphism Rseq_minus : Rseq_minus_Rseq_eq_compat. *)
Proof.
unfold Rseq_eq, Rseq_minus.
intros Un Vn Huv Xn Yn Hxy n.
rewrite Huv.
rewrite Hxy.
reflexivity.
Qed.

Add Morphism Rseq_mult with signature Rseq_eq ==> Rseq_eq ==> Rseq_eq as Rseq_mult_Rseq_eq_compat.
(*Add Morphism Rseq_mult : Rseq_mult_Rseq_eq_compat.*)
Proof.
unfold Rseq_eq, Rseq_mult.
intros Un Vn Huv Xn Yn Hxy n.
rewrite Huv.
rewrite Hxy.
reflexivity.
Qed.

Add Morphism Rseq_opp with signature Rseq_eq ==> Rseq_eq as Rseq_opp_Rseq_eq_compat.
(*Add Morphism Rseq_mult : Rseq_mult_Rseq_eq_compat.*)
Proof.
intros x y H i.
unfold Rseq_eq, Rseq_opp.
rewrite H.
trivial.
Qed.

Lemma Rseq_setoid_theory : Setoid_Theory Rseq Rseq_eq.
Proof.
constructor; unfold Rseq_eq.
unfold Reflexive; trivial.
unfold Symmetric; auto.
unfold Transitive; intros x y z H1 H2 n;
 rewrite H1; rewrite H2; reflexivity.
Qed.

Lemma Rseq_ring_theory : @ring_theory Rseq (0%R) (1%R) Rseq_plus Rseq_mult Rseq_minus Rseq_opp Rseq_eq.
Proof.
  constructor; unfold Rseq_plus, Rseq_mult, Rseq_minus, Rseq_eq, Rseq_constant, Rseq_opp;
intros; ring.
Qed.

Add Setoid Rseq Rseq_eq Rseq_setoid_theory as Rseq_eq_setoid.

Add Ring Rseq_Ring : Rseq_ring_theory(abstract).


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

(* ** FRACTRAN reduces to Diophantine logic *)

Require Import List.

From Undecidability.Synthetic Require Import Undecidability.
Require Import Undecidability.Synthetic.ReducibilityFacts.

From Undecidability.Shared.Libs.DLW
   Require Import utils_tac pos vec.

From Undecidability.FRACTRAN
  Require Import FRACTRAN MM_FRACTRAN.

From Undecidability.H10.Fractran Require Import fractran_dio.
From Undecidability.H10.Dio      Require Import dio_elem dio_single dio_logic.

Set Implicit Arguments.

(* A diophantine logic satisfiability question is given
    a diophantine logic formula f and a valuation for the
    parameters. Is the formula valid ? *)

Definition DIO_LOGIC_PROBLEM :=
  (dio_formula * (nat -> nat))%type.

Definition DIO_LOGIC_SAT (p : DIO_LOGIC_PROBLEM) :=
  let (f,ν) := p in df_pred f ν.

Theorem FRACTRAN_HALTING_DIO_LOGIC_SAT : FRACTRAN_HALTING ⪯ DIO_LOGIC_SAT.
Proof.
  apply reduces_dependent; exists.
  intros (l & x).
  destruct FRACTRAN_HALTING_on_diophantine
    with (ll := l) (x := fun _ : nat -> nat => x) as (f & Hf); simpl.
  + dio_rel_auto.
  + exists (f, fun _ => x); unfold DIO_LOGIC_SAT; rewrite Hf; tauto.
Qed.

(* An elementary diophantine problem is a list of elementary diophantine
    constraints and a valuation for the parameters. The question is whether
    there exists a valuation for the variables that satisfies all the constraints
    simultaneously *)

Definition DIO_ELEM_PROBLEM :=
  (list dio_constraint * (nat -> nat))%type.

Definition DIO_ELEM_SAT (p : DIO_ELEM_PROBLEM) :=
  let (l,v) := p in exists φ, Forall (dc_eval φ v) l.

Theorem DIO_LOGIC_ELEM_SAT : DIO_LOGIC_SAT ⪯  DIO_ELEM_SAT.
Proof.
  apply reduces_dependent; exists.
  intros (A,v).
  destruct (dio_formula_elem A) as (l & _ & _ & Hl).
  exists (l,v); apply Hl.
Qed.

Definition DIO_SINGLE_PROBLEM :=
  (dio_single nat nat * (nat -> nat))%type.

Definition DIO_SINGLE_SAT (p : DIO_SINGLE_PROBLEM) :=
  let (E,φ) := p in dio_single_pred E φ.

Theorem DIO_ELEM_SINGLE_SAT : DIO_ELEM_SAT ⪯ DIO_SINGLE_SAT.
Proof.
  apply reduces_dependent; exists.
  intros (l,v).
  destruct (dio_elem_equation l) as (E & _ & HE).
  exists (E,v).
  unfold DIO_ELEM_SAT, DIO_SINGLE_SAT.
  rewrite <- HE; tauto.
Qed.