(* generated by Ott 0.10.17 ***locally nameless*** from: F.ott *)

Require Import Metatheory.

(** syntax *)
Definition termvar := var.
Definition typvar := var.

Inductive typ : Set :=
 | typ_var_b : nat -> typ
 | typ_var_f : typvar -> typ
 | typ_arrow : typ -> typ -> typ
 | typ_forall : typ -> typ.

Inductive term : Set :=
 | term_var_b : nat -> term
 | term_var_f : termvar -> term
 | term_abs : typ -> term -> term
 | term_app : term -> term -> term
 | term_gen : term -> term
 | term_inst : term -> typ -> term.

Definition typing_env : Set := list (atom * option typ).

(* EXPERIMENTAL *)

(** opening up abstractions *)
Fixpoint open_typ_wrt_typ_rec (k:nat) (t_5:typ) (t__6:typ) {struct t__6}: typ :=
  match t__6 with
  | (typ_var_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => typ_var_b nat
        | inleft (right _) => t_5
        | inright _ => typ_var_b (nat - 1)
      end
  | (typ_var_f a) => typ_var_f a
  | (typ_arrow t1 t2) => typ_arrow (open_typ_wrt_typ_rec k t_5 t1) (open_typ_wrt_typ_rec k t_5 t2)
  | (typ_forall t) => typ_forall (open_typ_wrt_typ_rec (S k) t_5 t)
end.

Fixpoint open_term_wrt_term_rec (k:nat) (e_5:term) (e__6:term) {struct e__6}: term :=
  match e__6 with
  | (term_var_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => term_var_b nat
        | inleft (right _) => e_5
        | inright _ => term_var_b (nat - 1)
      end
  | (term_var_f x) => term_var_f x
  | (term_abs t e) => term_abs t (open_term_wrt_term_rec (S k) e_5 e)
  | (term_app e1 e2) => term_app (open_term_wrt_term_rec k e_5 e1) (open_term_wrt_term_rec k e_5 e2)
  | (term_gen e) => term_gen (open_term_wrt_term_rec k e_5 e)
  | (term_inst e t) => term_inst (open_term_wrt_term_rec k e_5 e) t
end.

Fixpoint open_term_wrt_typ_rec (k:nat) (t5:typ) (e_5:term) {struct e_5}: term :=
  match e_5 with
  | (term_var_b nat) => term_var_b nat
  | (term_var_f x) => term_var_f x
  | (term_abs t e) => term_abs (open_typ_wrt_typ_rec k t5 t) (open_term_wrt_typ_rec k t5 e)
  | (term_app e1 e2) => term_app (open_term_wrt_typ_rec k t5 e1) (open_term_wrt_typ_rec k t5 e2)
  | (term_gen e) => term_gen (open_term_wrt_typ_rec (S k) t5 e)
  | (term_inst e t) => term_inst (open_term_wrt_typ_rec k t5 e) (open_typ_wrt_typ_rec k t5 t)
end.

Definition open_typ_wrt_typ t_5 t__6 := open_typ_wrt_typ_rec 0 t__6 t_5.

Definition open_term_wrt_term e_5 e__6 := open_term_wrt_term_rec 0 e__6 e_5.

Definition open_term_wrt_typ t5 e_5 := open_term_wrt_typ_rec 0 e_5 t5.

(** terms are locally-closed pre-terms *)
(** definitions *)

(* defns LC_typ *)
Inductive lc_typ : typ -> Prop :=    (* defn lc_typ *)
 | lc_typ_var_f : forall (a:typvar),
     (lc_typ (typ_var_f a))
 | lc_typ_arrow : forall (t1 t2:typ),
     (lc_typ t1) ->
     (lc_typ t2) ->
     (lc_typ (typ_arrow t1 t2))
 | lc_typ_forall : forall (t:typ),
      ( forall a , lc_typ  ( open_typ_wrt_typ t (typ_var_f a) )  )  ->
     (lc_typ (typ_forall t)).

(* defns LC_term *)
Inductive lc_term : term -> Prop :=    (* defn lc_term *)
 | lc_term_var_f : forall (x:termvar),
     (lc_term (term_var_f x))
 | lc_term_abs : forall (t:typ) (e:term),
     (lc_typ t) ->
      ( forall x , lc_term  ( open_term_wrt_term e (term_var_f x) )  )  ->
     (lc_term (term_abs t e))
 | lc_term_app : forall (e1 e2:term),
     (lc_term e1) ->
     (lc_term e2) ->
     (lc_term (term_app e1 e2))
 | lc_term_gen : forall (e:term),
      ( forall a , lc_term  ( open_term_wrt_typ e (typ_var_f a) )  )  ->
     (lc_term (term_gen e))
 | lc_term_inst : forall (e:term) (t:typ),
     (lc_term e) ->
     (lc_typ t) ->
     (lc_term (term_inst e t)).

(** free variables *)
Fixpoint ftv_typ (t_5:typ) : vars :=
  match t_5 with
  | (typ_var_b nat) => {}
  | (typ_var_f a) => {{a}}
  | (typ_arrow t1 t2) => (ftv_typ t1) \u (ftv_typ t2)
  | (typ_forall t) => (ftv_typ t)
end.

Fixpoint fv_term (e_5:term) : vars :=
  match e_5 with
  | (term_var_b nat) => {}
  | (term_var_f x) => {{x}}
  | (term_abs t e) => (fv_term e)
  | (term_app e1 e2) => (fv_term e1) \u (fv_term e2)
  | (term_gen e) => (fv_term e)
  | (term_inst e t) => (fv_term e)
end.

Fixpoint ftv_term (e_5:term) : vars :=
  match e_5 with
  | (term_var_b nat) => {}
  | (term_var_f x) => {}
  | (term_abs t e) => (ftv_typ t) \u (ftv_term e)
  | (term_app e1 e2) => (ftv_term e1) \u (ftv_term e2)
  | (term_gen e) => (ftv_term e)
  | (term_inst e t) => (ftv_term e) \u (ftv_typ t)
end.

(** substitutions *)
Fixpoint tsubst_typ (t_5:typ) (a5:typvar) (t__6:typ) {struct t__6} : typ :=
  match t__6 with
  | (typ_var_b nat) => typ_var_b nat
  | (typ_var_f a) => (if eq_var a a5 then t_5 else (typ_var_f a))
  | (typ_arrow t1 t2) => typ_arrow (tsubst_typ t_5 a5 t1) (tsubst_typ t_5 a5 t2)
  | (typ_forall t) => typ_forall (tsubst_typ t_5 a5 t)
end.

Fixpoint subst_term (e_5:term) (x5:termvar) (e__6:term) {struct e__6} : term :=
  match e__6 with
  | (term_var_b nat) => term_var_b nat
  | (term_var_f x) => (if eq_var x x5 then e_5 else (term_var_f x))
  | (term_abs t e) => term_abs t (subst_term e_5 x5 e)
  | (term_app e1 e2) => term_app (subst_term e_5 x5 e1) (subst_term e_5 x5 e2)
  | (term_gen e) => term_gen (subst_term e_5 x5 e)
  | (term_inst e t) => term_inst (subst_term e_5 x5 e) t
end.

Fixpoint tsubst_term (t5:typ) (a5:typvar) (e_5:term) {struct e_5} : term :=
  match e_5 with
  | (term_var_b nat) => term_var_b nat
  | (term_var_f x) => term_var_f x
  | (term_abs t e) => term_abs (tsubst_typ t5 a5 t) (tsubst_term t5 a5 e)
  | (term_app e1 e2) => term_app (tsubst_term t5 a5 e1) (tsubst_term t5 a5 e2)
  | (term_gen e) => term_gen (tsubst_term t5 a5 e)
  | (term_inst e t) => term_inst (tsubst_term t5 a5 e) (tsubst_typ t5 a5 t)
end.

(** definitions *)

(* defns Jval *)
Inductive pval : term -> Prop :=    (* defn pval *)
 | pval_var : forall (x:termvar),
     pval (term_var_f x)
 | pval_app : forall (e1 e2:term),
     pval e1 ->
     val e2 ->
     pval  ( (term_app e1 e2) )
 | pval_inst : forall (e:term) (t:typ),
     lc_typ t ->
     pval e ->
     pval  ( (term_inst e t) )
with val : term -> Prop :=    (* defn val *)
 | val_pval : forall (e:term),
     pval e ->
     val e
 | val_abs : forall (L:vars) (t:typ) (e:term),
     lc_typ t ->
      ( forall x , x \notin  L  -> val  ( open_term_wrt_term e (term_var_f x) )  )  ->
     val  ( (term_abs t e) )
 | val_gen : forall (L:vars) (e:term),
      ( forall a , a \notin  L  -> val  ( open_term_wrt_typ e (typ_var_f a) )  )  ->
     val  ( (term_gen e) ) .

(* defns Jwf_env_typ *)
Inductive wfenv : typing_env -> Prop :=    (* defn wfenv *)
 | wfenv_empty :
     wfenv  nil
 | wfenv_cons_x : forall (G:typing_env) (x:termvar) (t:typ),
      x  `notin` dom  G  ->
     wftyp G t ->
     wfenv  ( x ~(Some  t ) ++  G )
 | wfenv_cons_a : forall (G:typing_env) (a:typvar),
      a  `notin` dom  G  ->
     wfenv G ->
     wfenv  ( a ~None ++  G )
with wftyp : typing_env -> typ -> Prop :=    (* defn wftyp *)
 | wftyp_var : forall (G:typing_env) (a:typvar),
      binds ( a ) None ( G )  ->
     wfenv G ->
     wftyp G (typ_var_f a)
 | wftyp_arrow : forall (G:typing_env) (t1 t2:typ),
     wftyp G t1 ->
     wftyp G t2 ->
     wftyp G (typ_arrow t1 t2)
 | wftyp_forall : forall (L:vars) (G:typing_env) (t:typ),
      ( forall a , a \notin  L  -> wftyp  ( a ~None ++  G )   ( open_typ_wrt_typ t (typ_var_f a) )  )  ->
     wftyp G (typ_forall t).

(* defns Jwfterm *)
Inductive wfterm : typing_env -> term -> typ -> Prop :=    (* defn wfterm *)
 | wfterm_val : forall (G:typing_env) (x:termvar) (t:typ),
     wfenv G ->
      binds ( x ) (Some ( t )) ( G )  ->
     wfterm G (term_var_f x) t
 | wfterm_app : forall (G:typing_env) (e1 e2:term) (t1 t2:typ),
     wfterm G e1 (typ_arrow t2 t1) ->
     wfterm G e2 t2 ->
     wfterm G (term_app e1 e2) t1
 | wfterm_abs : forall (L:vars) (G:typing_env) (t1:typ) (e:term) (t2:typ),
      ( forall x , x \notin  L  -> wfterm  ( x ~(Some  t1 ) ++  G )   ( open_term_wrt_term e (term_var_f x) )  t2 )  ->
     wfterm G (term_abs t1 e) (typ_arrow t1 t2)
 | wfterm_inst : forall (G:typing_env) (e:term) (t t':typ),
     wftyp G t ->
     wfterm G e (typ_forall t') ->
     wfterm G (term_inst e t)  (open_typ_wrt_typ  t'   t )
 | wfterm_gen : forall (L:vars) (G:typing_env) (e:term) (t:typ),
      ( forall a , a \notin  L  -> wfterm  ( a ~None ++  G )   ( open_term_wrt_typ e (typ_var_f a) )   ( open_typ_wrt_typ t (typ_var_f a) )  )  ->
     wfterm G (term_gen e) (typ_forall t).

(* defns Jred0 *)
Inductive red0 : term -> term -> Prop :=    (* defn red0 *)
 | red0_beta : forall (t:typ) (e1 e2:term),
     lc_typ t ->
     lc_term (term_abs t e1) ->
     lc_term e2 ->
     red0 (term_app  ( (term_abs t e1) )  e2)  (open_term_wrt_term  e1   e2 )
 | red0_beta_t : forall (e:term) (t:typ),
     lc_term (term_gen e) ->
     lc_typ t ->
     red0 (term_inst  ( (term_gen e) )  t)  (open_term_wrt_typ   e    t ) .

(* defns Jred1 *)
Inductive red1 : term -> term -> Prop :=    (* defn red1 *)
 | red1_empty : forall (e e':term),
     red0 e e' ->
     red1 e e'
 | red1_appL : forall (e1 e2 e1':term),
     lc_term e2 ->
     red1 e1 e1' ->
     red1 (term_app e1 e2) (term_app e1' e2)
 | red1_appR : forall (e1 e2 e2':term),
     lc_term e1 ->
     red1 e2 e2' ->
     red1 (term_app e1 e2) (term_app e1 e2')
 | red1_abs : forall (L:vars) (t:typ) (e e':term),
     lc_typ t ->
      ( forall x , x \notin  L  -> red1  ( open_term_wrt_term e (term_var_f x) )   ( open_term_wrt_term e' (term_var_f x) )  )  ->
     red1 (term_abs t e) (term_abs t e')
 | red1_inst : forall (e:term) (t:typ) (e':term),
     lc_typ t ->
     red1 e e' ->
     red1 (term_inst e t) (term_inst e' t)
 | red1_gen : forall (L:vars) (e e':term),
      ( forall a , a \notin  L  -> red1  ( open_term_wrt_typ e (typ_var_f a) )   ( open_term_wrt_typ e' (typ_var_f a) )  )  ->
     red1 (term_gen e) (term_gen e').

(** infrastructure *)

(* additional definitions *)

(* instanciation of tactics *)

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : vars => x) in
  let B := gather_atoms_with (fun x : var => {{ x }}) in
  let D1 := gather_atoms_with (fun x => fv_term x) in
  let D2 := gather_atoms_with (fun x => ftv_typ x) in
  let D3 := gather_atoms_with (fun x => ftv_term x) in
  constr:(A \u B \u D1 \u D2 \u D3).

Hint Constructors pval val wfenv wftyp wfterm red0 red1 lc_typ lc_term.


(* The category of relations, i.e. the objects are sets and the morphisms are relations of sets,
   becomes a dagger category by taking the "opposite" relation.
   Furthermore, we show that it is dagger univalent. In order to do this,
   we show that the of isomorphisms is equivalent to type of dagger isomorphisms.
*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.

Require Import UniMath.CategoryTheory.categories.Relations.

Require Import UniMath.CategoryTheory.DaggerCategories.Categories.
Require Import UniMath.CategoryTheory.DaggerCategories.Unitary.
Require Import UniMath.CategoryTheory.DaggerCategories.Univalence.

Local Open Scope cat.

Section RelationsAsDaggers.

  Definition REL_dagger_structure : dagger_structure REL
    := λ _ _ f y x, f x y.

  Lemma REL_dagger_laws : dagger_laws REL_dagger_structure.
  Proof.
    repeat split ; intro ; intros ; repeat (apply funextsec ; intro) ; cbn.
    - use (invweq (weqeqweqhProp _ _)).
      use weqimplimpl.
      + exact (λ p, ! p).
      + exact (λ p, ! p).
      + apply eqset.
      + apply eqset.
    - use (invweq (weqeqweqhProp _ _)).
      use weqimplimpl.
      + intro p.
        use (factor_through_squash_hProp _ _ p).
        clear p ; intro p.
        apply hinhpr.
        exact (pr1 p ,, pr22 p ,, pr12 p).
      + intro p.
        use (factor_through_squash_hProp _ _ p).
        clear p ; intro p.
        apply hinhpr.
        exact (pr1 p ,, pr22 p ,, pr12 p).
      + apply isapropishinh.
      + apply isapropishinh.
  Qed.

  Definition REL_dagger : dagger REL
    := _ ,, REL_dagger_laws.

End RelationsAsDaggers.

Section DaggerIsosInREL.

  Context (X Y : REL).

  Definition z_iso_REL_equiv_dagger_z_iso
    : z_iso (C := REL) X Y ≃ unitary REL_dagger_structure X Y.
  Proof.
    apply weqfibtototal.
    intro r.
    apply weqimplimpl.
    - intro i.
      unfold is_unitary.
      unfold REL_dagger_structure.

      unfold is_inverse_in_precat.
      cbn.
      split ; do 2 (apply funextsec ; intro).
      + apply unique_image_to_inverse_law_in_REL.
        * apply is_z_iso_in_REL_to_unique_image.
          use (pr2 (is_z_iso_in_REL_simplified _)).
          split.
          -- exact (pr2 (pr1 (is_z_iso_in_REL_simplified r) i)).
          -- exact (pr1 (pr1 (is_z_iso_in_REL_simplified r) i)).
        * exact (is_z_iso_in_REL_to_unique_image _ i).
      + etrans.
        2: {
          use (unique_image_to_inverse_law_in_REL (r := pr1 i)).
          - exact (pr2 (pr1 (is_z_iso_in_REL_simplified _) (pr2 (z_iso_inv (r,,i))))).
          - apply (is_z_iso_in_REL_to_unique_image).
            exact (pr2 (z_iso_inv (r,,i))).
        }

        apply hPropUnivalence.
        * intro px.
          use (factor_through_squash_hProp _ _ px).
          clear px ; intro px.
          apply hinhpr.
          refine (pr1 px ,, _ ,, _) ;
            apply inverse_swap_relation, (pr2 px).
        * intro px.
          use (factor_through_squash_hProp _ _ px).
          clear px ; intro px.
          apply hinhpr.
          refine (pr1 px ,, _ ,, _) ; apply (inverse_swap_relation_iff i _ _), (pr2 px).
    - exact (λ i, _ ,, (i : is_inverse_in_precat _ _)).
    - apply isaprop_is_z_isomorphism.
    - apply isaprop_is_unitary.
  Defined.

End DaggerIsosInREL.

Section UnivalenceOfRelations.

  Lemma is_dagger_univalent_REL : is_univalent_dagger REL_dagger.
  Proof.
    intros X Y.
    use weqhomot.
    - exact (z_iso_REL_equiv_dagger_z_iso X Y ∘ make_weq _ (is_univalent_REL X Y))%weq.
    - intro p ; induction p.
      use unitary_eq.
      do 2 (apply funextsec ; intro).
      apply idpath.
  Qed.

End UnivalenceOfRelations.


Require Import Relations Morphisms.
Require Import Program Coq.Setoids.Setoid.
Require Import Coq.ZArith.BinInt.
Require Import List.

(*
Require Import ZArith.
Open Scope Z_scope.
*)

Require Import Arith.
Require Import Ascii.
Require Import String.
Require Import BinInt.
Require Setoid.
Require Import Le Gt Minus Bool.

Set Implicit Arguments.
Open Scope list_scope.

Delimit Scope Int_scope with I.
Local Open Scope Int_scope.

Delimit Scope string_scope with string.
Local Open Scope string_scope.

Local Open Scope list_scope.

Module Type T.
Fixpoint nat_compare_b (n m: nat) : bool :=
  match n with
    | 0%nat  =>
    match m with
      | 0%nat => true
      | _ => false
    end
    | S x =>
    match m with
      | 0%nat => false
      | S y => nat_compare_b x y
    end
  end.

Fixpoint string_compare_b (s1 s2: string): bool :=
  match s1, s2 with
    | EmptyString,  EmptyString  => true
    | EmptyString,  String a s2' => false
    | String a s1', EmptyString  => false
    | String a s1', String b s2' =>
    match ascii_dec a b with
      | left _  => string_compare_b s1' s2'
      | right _ =>  nat_compare_b (nat_of_ascii a) (nat_of_ascii b)
    end
  end.

Fixpoint nat_compare (n m: nat) : nat :=
  match n with
    | 0%nat  =>
    match m with
      | 0%nat => 0
      | _ => 1
    end
    | S x =>
    match m with
      | 0%nat => 2
      | S y => nat_compare x y
    end
  end.

Fixpoint string_compare (s1 s2: string): nat :=
  match s1, s2 with
    | EmptyString,  EmptyString  => 0
    | EmptyString,  String a s2' => 1
    | String a s1', EmptyString  => 2
    | String a s1', String b s2' =>
    match ascii_dec a b with
      | left _  => string_compare s1' s2'
      | right _ =>  nat_compare (nat_of_ascii a) (nat_of_ascii b)
    end
  end.

End T.


(** *p adic numbers *)

(** By Alvaro Pelayo, Vladimir Voevodsky and Michael A. Warren *)

(** 2012 *)

(** made compatible with the current UniMath library by Ralph Matthes in October 2017 *)

(** Imports *)

Require Import UniMath.PAdics.lemmas.
Require Import UniMath.PAdics.fps.
Require Import UniMath.PAdics.frac.
Require Import UniMath.PAdics.z_mod_p.

Require Import UniMath.NumberSystems.Integers.

Unset Kernel Term Sharing. (** crucial for timely proof-checking, otherwise unbearable *)

(** * I. Several basic lemmas *)

Local Open Scope hz_scope.

Lemma hzqrandnatsummation0r ( m : hz ) ( x : hzneq 0 m )
  ( a : nat -> hz ) ( upper : nat ) :
  hzremaindermod m x ( natsummation0 upper a ) =
  hzremaindermod m x ( natsummation0 upper ( fun n : nat => hzremaindermod m x ( a n ) ) ).
Proof.
  intros.
  induction upper.
  - simpl.
    rewrite hzremaindermoditerated.
    apply idpath.
    - change ( hzremaindermod m x ( natsummation0 upper a + a ( S upper ) ) =
               hzremaindermod m x ( natsummation0 upper
        ( fun n : nat =>
          hzremaindermod m x ( a n ) ) + hzremaindermod m x ( a ( S upper ) ) ) ).
      rewrite hzremaindermodandplus.
      rewrite IHupper.
      rewrite <- ( hzremaindermoditerated m x ( a ( S upper ) ) ).
      rewrite <- hzremaindermodandplus.
      rewrite hzremaindermoditerated.
      apply idpath.
Defined.

Lemma hzqrandnatsummation0q ( m : hz ) ( x : hzneq 0 m )
  ( a : nat -> hz ) ( upper : nat ) :
  hzquotientmod m x ( natsummation0 upper a ) =
  ( natsummation0 upper ( fun n : nat =>
      hzquotientmod m x ( a n ) ) + hzquotientmod m x
        ( natsummation0 upper ( fun n : nat => hzremaindermod m x ( a n ) ) ) ).
Proof.
  intros.
  induction upper.
  - simpl.
    rewrite <- hzqrandremainderq.
    rewrite hzplusr0.
    apply idpath.
  - change ( natsummation0 ( S upper ) a ) with
    ( natsummation0 upper a + a ( S upper ) ).
    rewrite hzquotientmodandplus.
    rewrite IHupper.
    rewrite ( hzplusassoc ( natsummation0 upper ( fun n : nat =>
      hzquotientmod m x ( a n ) ) ) _ ( hzquotientmod m x ( a ( S upper ) ) ) ).
    rewrite ( hzpluscomm ( hzquotientmod m x
      ( natsummation0 upper ( fun n : nat => hzremaindermod m x ( a n ) ) ) )
                         ( hzquotientmod m x ( a ( S upper ) ) ) ).
    rewrite <- ( hzplusassoc ( natsummation0 upper
                                 ( fun n : nat => hzquotientmod m x ( a n ) ) )
                             ( hzquotientmod m x ( a ( S upper ) ) ) _ ).
    change ( natsummation0 upper ( fun n : nat => hzquotientmod m x ( a n ) ) +
             hzquotientmod m x ( a ( S upper ) ) ) with
    ( natsummation0 ( S upper ) ( fun n : nat => hzquotientmod m x ( a n ) ) ).
    rewrite hzqrandnatsummation0r.
    rewrite hzquotientmodandplus.
    rewrite <- hzqrandremainderq.
    rewrite hzplusl0.
    rewrite hzremaindermoditerated.
    rewrite ( hzplusassoc (natsummation0 ( S upper )
                             ( fun n : nat => hzquotientmod m x ( a n ) ) )
       ( hzquotientmod m x ( natsummation0 upper ( fun n : nat =>
                                       hzremaindermod m x ( a n ) ) ) ) _ ).
    rewrite <- ( hzplusassoc ( hzquotientmod m x
      ( natsummation0 upper ( fun n : nat =>
                                     hzremaindermod m x ( a n ) ) ) ) _ _ ).
    rewrite <- hzquotientmodandplus.
    apply idpath.
Defined.

Lemma hzquotientandtimesl ( m : hz ) ( x : hzneq 0 m ) ( a b : hz ) :
  hzquotientmod m x ( a * b ) =
  ( hzquotientmod m x a ) * b +
    hzremaindermod m x a * hzquotientmod m x b +
      hzquotientmod m x ( hzremaindermod m x a * hzremaindermod m x b ).
Proof.
  intros.
  rewrite hzquotientmodandtimes.
  rewrite ( hzmultcomm ( hzremaindermod m x b ) ( hzquotientmod m x a ) ).
  rewrite hzmultassoc.
  rewrite <- ( hzldistr ( hzquotientmod m x b * m ) _ ( hzquotientmod m x a )).
  rewrite ( hzmultcomm _ m ).
  rewrite <- ( hzdivequationmod m x b ).
  rewrite hzplusassoc.
  apply idpath.
Defined.

Lemma hzquotientandfpstimesl ( m : hz ) ( x : hzneq 0 m )
   ( a b : nat -> hz ) ( upper : nat ) :
  hzquotientmod m x ( fpstimes hz a b upper ) =
  natsummation0 upper ( fun i : nat =>
      hzquotientmod m x ( a i ) * b ( sub upper i ) ) +
    hzquotientmod m x ( natsummation0 upper ( fun i : nat =>
      hzremaindermod m x ( a i ) * b ( sub upper i ) ) ).
Proof.
  intros.
  destruct upper as [ | upper].
  - simpl.
    unfold fpstimes.
    simpl.
    rewrite hzquotientandtimesl.
    rewrite hzplusassoc.
    apply ( maponpaths ( fun v : _ =>
              hzquotientmod m x ( a 0%nat ) * b 0%nat + v ) ).
    rewrite ( hzquotientmodandtimes m x
                ( hzremaindermod m x ( a 0%nat ) ) ( b 0%nat ) ).
    rewrite <- hzqrandremainderq.
    rewrite hzmultx0.
    rewrite 2! hzmult0x.
    rewrite hzplusl0.
    rewrite hzremaindermoditerated.
    apply idpath.
  - unfold fpstimes.
    rewrite hzqrandnatsummation0q.
    assert ( forall n : nat, hzquotientmod m x (a n * b ( sub ( S upper ) n)%nat) =
      ( hzquotientmod m x ( a n ) * b ( sub ( S upper ) n ) +
        hzremaindermod m x ( a n ) * hzquotientmod m x ( b ( sub ( S upper ) n ) ) +
        hzquotientmod m x ( hzremaindermod m x ( a n ) *
                            hzremaindermod m x ( b ( sub ( S upper ) n ) ) ) ) ) as f.
    { intro k.
      rewrite hzquotientandtimesl.
      apply idpath.
    }
    rewrite ( natsummationpathsupperfixed _ _ ( fun x0 p => f x0 ) ).
    rewrite ( natsummationplusdistr ( S upper ) ( fun x0 : nat =>
      hzquotientmod m x (a x0) * b ( sub ( S upper ) x0)%nat +
      hzremaindermod m x (a x0) * hzquotientmod m x (b (S upper - x0)%nat) ) ).
    rewrite ( natsummationplusdistr ( S upper ) ( fun x0 : nat =>
                           hzquotientmod m x (a x0) * b (S upper - x0)%nat ) ).
    rewrite 2! hzplusassoc.
    apply ( maponpaths ( fun v => natsummation0 ( S upper ) ( fun i : nat =>
               hzquotientmod m x ( a i ) * b ( sub ( S upper ) i ) ) + v ) ).
    rewrite ( hzqrandnatsummation0q m x ( fun i : nat =>
                    hzremaindermod m x ( a i ) * b ( sub ( S upper ) i ) ) ).
    assert (natsummation0 (S upper) (fun n : nat =>
      hzremaindermod m x (hzremaindermod m x (a n) * b (S upper - n)%nat))=
      natsummation0 ( S upper ) ( fun n : nat =>
             hzremaindermod m x ( a n * b ( sub ( S upper ) n ) ) ) ) as g.
    { apply natsummationpathsupperfixed.
      intros j p.
      rewrite hzremaindermodandtimes.
      rewrite hzremaindermoditerated.
      rewrite <- hzremaindermodandtimes.
      apply idpath.
    }
    rewrite g.
    rewrite <- hzplusassoc.
    assert ( natsummation0 (S upper) (fun x0 : nat =>
      hzremaindermod m x (a x0) * hzquotientmod m x (b (S upper - x0)%nat)) +
      natsummation0 (S upper) (fun x0 : nat =>
         hzquotientmod m x (hzremaindermod m x (a x0) *
                            hzremaindermod m x (b (S upper - x0)%nat))) =
            natsummation0 (S upper) (fun n : nat =>
      hzquotientmod m x (hzremaindermod m x (a n) * b (S upper - n)%nat)) ) as h.
    { rewrite <- ( natsummationplusdistr ( S upper ) ( fun x0 : nat =>
                     hzremaindermod m x ( a x0 ) *
                     hzquotientmod m x ( b ( sub ( S upper ) x0 ) ) ) ).
      apply natsummationpathsupperfixed.
      intros j p.
      rewrite ( hzquotientmodandtimes m x ( hzremaindermod m x ( a j ) )
                                      ( b ( sub ( S upper ) j ) ) ).
      rewrite <- hzqrandremainderq.
      rewrite 2! hzmult0x.
      rewrite hzmultx0.
      rewrite hzplusl0.
      rewrite hzremaindermoditerated.
      apply idpath.
    }
    rewrite h.
    apply idpath.
Defined.

Close Scope hz_scope.

(** * II. The carrying operation and induced equivalence relation on
formal power series *)

(** A lemma that does not depend on a non-zero integer and that used to
    appear where needed below - the point has been marked by a comment. *)

Local Open Scope ring_scope.

Lemma natsummationplusshift { R : commring } ( upper : nat )
  ( f g : nat -> R ) :
  natsummation0 ( S upper ) f + natsummation0 upper g =
  f 0%nat + natsummation0 upper ( fun x : nat => f ( S x ) + g x ).
Proof.
  intros.
  destruct upper.
  - unfold natsummation0.
    simpl.
    apply ( ringassoc1 R ).
  - rewrite (natsummationshift0 ( S upper ) f ).
    rewrite ( ringcomm1 R _ ( f 0%nat ) ).
    rewrite ( ringassoc1 R ).
    rewrite natsummationplusdistr.
    apply idpath.
Defined.

Close Scope hz_scope.

Section carry.

Local Open Scope ring_scope.

Variable m : hz.
Variable is : hzneq 0 m.

Fixpoint precarry ( a : fpscommring hz ) ( n : nat ) : hz :=
  match n with
  | 0%nat => a 0%nat
  | S n => a ( S n ) + hzquotientmod m is ( precarry a n )
  end.

Definition carry : fpscommring hz -> fpscommring hz :=
  fun (a : fpscommring hz) (n : nat) =>
    hzremaindermod m is ( precarry a n ).

(* precarry and carry are as described in the following example:

CASE: mod 3

First we normalize the sequence as we go along:

  5 6 8 4 (13) 2 2 ( remainder 2 mod 3 = 2 ) 4 1 ( remainder 13 mod 3
               = 1, quotient 13 mod 3 = 4 ) 2 2 ( remainder 8 mod 3 =
               2, quotient 8 mod 3 = 2 ) 3 1 ( remainder 10 mod 3 = 1,
               quotient 10 mod 3 = 3 ) 3 0 ( remainder 9 mod 3 = 0,
               quotient 9 mod 3 = 3 ) 2 2 ( remainder 8 mod 3 = 2,
               quotient 8 mod 3 = 2 )

2 2 0 1 2 1 2

Next we first precarry and then carry:

  5 6 8 4 (13) 2 2 4 13 2 8 3 (10) 3 9 2 8

2 8 9 (10) 8 (13) 2 <--- precarried sequence

2 2 0 1 2 1 2 <--- carried sequence *)

Lemma isapropcarryequiv ( a b : fpscommring hz ) :
  isaprop ( carry a = carry b ).
Proof.
  intros.
  apply ( fps hz ).
Defined.

Definition carryequiv0 : hrel ( fpscommring hz ) :=
  fun a b : fpscommring hz => make_hProp _ ( isapropcarryequiv a b ).

Lemma carryequiviseqrel : iseqrel carryequiv0.
Proof.
  split.
  - split.
    + intros a b c i j.
      simpl.
      rewrite i.
      apply j.
    + intros a.
      simpl.
      apply idpath.
  - intros a b i.
    simpl.
    rewrite i.
    apply idpath.
Defined.

Lemma carryandremainder ( a : fpscommring hz ) ( n : nat ) :
  hzremaindermod m is ( carry a n ) = carry a n.
Proof.
  intros.
  unfold carry.
  rewrite hzremaindermoditerated.
  apply idpath.
Defined.

Definition carryequiv : eqrel ( fpscommring hz ) :=
  make_eqrel _ carryequiviseqrel.

Lemma precarryandcarry_pointwise ( a : fpscommring hz ) :
  forall n : nat,
    precarry ( carry a ) n = ( carry a ) n.
Proof.
  intros.
  induction n.
  - exact (idpath _).
  - unfold precarry.
    fold precarry.
    rewrite IHn.
    unfold carry at 2.
    rewrite <- hzqrandremainderq.
    apply hzplusr0.
Defined.

Lemma precarryandcarry ( a : fpscommring hz ) :
  precarry ( carry a ) = carry a.
Proof.
  intros.
  apply funextfun.
  intro n.
  apply precarryandcarry_pointwise.
Defined.

Lemma hzqrandcarryeq ( a : fpscommring hz ) ( n : nat ) :
  carry a n = m * 0 + carry a n.
Proof.
  intros.
  rewrite hzmultx0.
  rewrite hzplusl0.
  apply idpath.
Defined.

Lemma hzqrandcarryineq ( a : fpscommring hz ) ( n : nat ) :
  hzleh 0 ( carry a n ) ×
  hzlth ( carry a n ) ( nattohz ( hzabsval m ) ).
Proof.
  intros.
  split.
  - unfold carry.
    apply ( pr2 ( pr1 ( divalgorithm ( precarry a n ) m is ) ) ).
  - unfold carry.
    apply ( pr2 ( pr1 ( divalgorithm ( precarry a n ) m is ) ) ).
Defined.

Lemma hzqrandcarryq ( a : fpscommring hz ) ( n : nat ) :
  0 = hzquotientmod m is ( carry a n ).
Proof.
  intros.
  apply ( hzqrtestq m is ( carry a n ) 0 ( carry a n ) ).
  split.
  - apply hzqrandcarryeq.
  - apply hzqrandcarryineq.
Defined.

Lemma hzqrandcarryr ( a : fpscommring hz ) ( n : nat ) :
  carry a n = hzremaindermod m is ( carry a n ).
Proof.
  intros.
  apply ( hzqrtestr m is ( carry a n ) 0 ( carry a n ) ).
  split.
  - apply hzqrandcarryeq.
  - apply hzqrandcarryineq.
Defined.

Lemma doublecarry ( a : fpscommring hz ):
  carry ( carry a ) = carry a.
Proof.
  intros.
  assert ( forall n : nat, carry ( carry a ) n =
                    carry a n ) as f.
  { intros.
    induction n.
    - unfold carry.
      simpl.
      apply hzremaindermoditerated.
    - unfold carry.
      simpl.
      change (precarry (fun n0 : nat =>
        hzremaindermod m is (precarry a n0)) n) with
      ( precarry ( carry a ) n ).
      rewrite precarryandcarry.
      rewrite <- hzqrandcarryq.
      rewrite hzplusr0.
      rewrite hzremaindermoditerated.
      apply idpath.
  }
  apply ( funextfun _ _ f ).
Defined.

Lemma carryandcarryequiv ( a : fpscommring hz ) :
  carryequiv ( carry a ) a.
Proof.
  intros.
  simpl.
  rewrite doublecarry.
  apply idpath.
Defined.

Lemma quotientprecarryplus ( a b : fpscommring hz ) ( n : nat ) :
  hzquotientmod m is ( precarry ( a + b ) n ) =
  hzquotientmod m is ( precarry a n ) +
  hzquotientmod m is ( precarry b n ) +
  hzquotientmod m is ( precarry ( carry a + carry b ) n ).
Proof.
  intros.
  induction n.
  - simpl.
    change ( hzquotientmod m is ( a 0%nat + b 0%nat ) =
            hzquotientmod m is (a 0%nat) +
            hzquotientmod m is (b 0%nat) +
            hzquotientmod m is ( hzremaindermod m is ( a 0%nat ) +
                                 hzremaindermod m is ( b 0%nat ) ) ).
    rewrite hzquotientmodandplus.
    apply idpath.
  - change ( hzquotientmod m is ( a ( S n ) + b ( S n ) +
             hzquotientmod m is ( precarry (a + b) n ) ) =
             hzquotientmod m is (precarry a (S n)) +
             hzquotientmod m is (precarry b (S n)) +
             hzquotientmod m is (carry a ( S n ) +
                                 carry b ( S n ) +
                    hzquotientmod m is ( precarry (carry a +
                                                   carry b) n)) ).
    rewrite IHn.
    rewrite ( ringassoc1 hz ( a ( S n ) ) ( b ( S n ) ) _ ).
    rewrite <- ( ringassoc1 hz ( b ( S n ) ) ).
    rewrite ( ringcomm1 hz ( b ( S n ) ) _ ).
    rewrite <- 3! ( ringassoc1 hz ( a ( S n ) ) _ _ ).
    change ( a ( S n ) + hzquotientmod m is ( precarry a n ) ) with
    ( precarry a ( S n ) ).
    set ( pa := precarry a ( S n ) ).
    rewrite ( ringassoc1 hz pa _ ( b ( S n ) ) ).
    rewrite ( ringcomm1 hz _ ( b ( S n ) ) ).
    change ( b ( S n ) + hzquotientmod m is ( precarry b n ) ) with
    ( precarry b ( S n ) ).
    set ( pb := precarry b ( S n ) ).
    set ( ab := precarry ( carry a + carry b ) ).
    rewrite ( ringassoc1 hz ( carry a ( S n ) )
                        ( carry b ( S n ) )
                        ( hzquotientmod m is ( ab n ) ) ).
    rewrite ( hzquotientmodandplus m is ( carry a ( S n ) ) _ ).
    unfold carry at 1.
    rewrite <- hzqrandremainderq.
    rewrite hzplusl0.
    rewrite ( hzquotientmodandplus m is ( carry b ( S n ) ) _ ).
    unfold carry at 1.
    rewrite <- hzqrandremainderq.
    rewrite hzplusl0.
    rewrite ( ringassoc1 hz pa pb _ ).
    rewrite ( hzquotientmodandplus m is pa _ ).
    change (pb + hzquotientmod m is (ab n)) with
           (pb + hzquotientmod m is (ab n))%hz.
    rewrite ( hzquotientmodandplus m is pb ( hzquotientmod m is ( ab n ) ) ).
    rewrite <- 2! ( ringassoc1 hz ( hzquotientmod m is pa ) _ _ ).
    rewrite <- 2! ( ringassoc1 hz ( hzquotientmod m is pa +
                                   hzquotientmod m is pb ) _ ).
    rewrite 2! ( ringassoc1 hz ( hzquotientmod m is pa +
                                hzquotientmod m is pb +
                      hzquotientmod m is (hzquotientmod m is (ab n)) ) _ _ ).
    apply ( maponpaths ( fun x : hz =>
                             hzquotientmod m is pa +
                             hzquotientmod m is pb +
                             hzquotientmod m is (hzquotientmod m is (ab n)) +
                           x ) ).
    unfold carry at 1 2.
    rewrite 2! hzremaindermoditerated.
    change ( precarry b ( S n ) ) with pb.
    change ( precarry a ( S n ) ) with pa.
    apply ( maponpaths ( fun x : hz =>
                           ( hzquotientmod m is (hzremaindermod m is pb +
                  hzremaindermod m is (hzquotientmod m is (ab n)))%hz ) +
                           x ) ).
    apply maponpaths.
    apply ( maponpaths ( fun x : hz => hzremaindermod m is pa + x ) ).
    rewrite ( hzremaindermodandplus m is ( carry b ( S n ) ) _ ).
    unfold carry.
    rewrite hzremaindermoditerated.
    rewrite <- ( hzremaindermodandplus m is ( precarry b ( S n ) ) _ ).
    apply idpath.
Defined.

Lemma carryandplus ( a b : fpscommring hz ) :
  carry ( a + b ) = carry ( carry a + carry b ).
Proof.
  intros.
  assert ( forall n : nat, carry ( a + b ) n =
              ( carry ( carry a + carry b ) n ) ) as f.
  { intros n.
    destruct n.
    - change ( hzremaindermod m is ( a 0%nat + b 0%nat ) =
               hzremaindermod m is ( hzremaindermod m is ( a 0%nat ) +
                                     hzremaindermod m is ( b 0%nat ) ) ).
      rewrite hzremaindermodandplus.
      apply idpath.
    - change ( hzremaindermod m is ( a ( S n ) +
                                     b ( S n ) +
        hzquotientmod m is ( precarry ( a + b ) n ) ) =
               hzremaindermod m is ( hzremaindermod m is ( a ( S n ) +
                              hzquotientmod m is ( precarry a n ) ) +
               hzremaindermod m is ( b ( S n ) +
                              hzquotientmod m is ( precarry b n ) ) +
               hzquotientmod m is ( precarry ( carry a +
                                                    carry b ) n ) ) ).
      rewrite quotientprecarryplus.
      rewrite ( hzremaindermodandplus m is
                                      ( hzremaindermod m is (a (S n) +
                                      hzquotientmod m is (precarry a n)) +
               hzremaindermod m is (b (S n) +
                                    hzquotientmod m is (precarry b n)) ) _ ).
      change (hzremaindermod m is (a (S n) +
                                   hzquotientmod m is (precarry a n)) +
              hzremaindermod m is (b (S n) +
                                   hzquotientmod m is (precarry b n))) with
      (hzremaindermod m is (a (S n) +
                            hzquotientmod m is (precarry a n))%ring +
       hzremaindermod m is (b (S n) +
                            hzquotientmod m is (precarry b n))%ring)%hz.
      + rewrite <- (hzremaindermodandplus m is (a (S n) +
                       hzquotientmod m is (precarry a n)) (b (S n) +
                                       hzquotientmod m is (precarry b n)) ).
        rewrite <- hzremaindermodandplus.
        change ( ((a (S n) +
                   hzquotientmod m is (precarry a n))%ring +
                  (b (S n) +
                   hzquotientmod m is (precarry b n))%ring +
          hzquotientmod m is (precarry (carry a + carry b)%ring n))%hz ) with
                 ((a (S n) +
                   hzquotientmod m is (precarry a n))%ring +
                  (b (S n) +
                   hzquotientmod m is (precarry b n))%ring +
          hzquotientmod m is (precarry (carry a + carry b)%ring n))%ring.
        rewrite <- ( ringassoc1 hz ( a ( S n ) + hzquotientmod m is ( precarry a n ) )
                                  (b (S n) )
                                  ( hzquotientmod m is (precarry b n)) ).
        rewrite ( ringassoc1 hz ( a ( S n ) )
                               (hzquotientmod m is ( precarry a n ) )
                               ( b ( S n ) ) ).
        rewrite ( ringcomm1 hz ( hzquotientmod m is ( precarry a n ) )
                           ( b ( S n ) ) ).
        rewrite <- 3! ( ringassoc1 hz ).
        apply idpath.
  }
  apply ( funextfun _ _ f ).
Defined.

Definition quotientprecarry ( a : fpscommring hz ) : fpscommring hz :=
  fun x : nat => hzquotientmod m is ( precarry a x ).

Lemma quotientandtimesrearrangel ( x y : hz ) :
  hzquotientmod m is ( x * y ) =
  ( hzquotientmod m is x ) * y +
    hzquotientmod m is ( ( hzremaindermod m is x ) * y ).
Proof.
  intros.
  rewrite hzquotientmodandtimes.
  change (hzquotientmod m is x * hzquotientmod m is y * m +
          hzremaindermod m is y * hzquotientmod m is x +
          hzremaindermod m is x * hzquotientmod m is y +
          hzquotientmod m is (hzremaindermod m is x * hzremaindermod m is y))%hz with
  (hzquotientmod m is x * hzquotientmod m is y * m +
   hzremaindermod m is y * hzquotientmod m is x +
   hzremaindermod m is x * hzquotientmod m is y +
   hzquotientmod m is (hzremaindermod m is x * hzremaindermod m is y))%ring.
  rewrite ( ringcomm2 hz ( hzremaindermod m is y ) ( hzquotientmod m is x ) ).
  rewrite ( ringassoc2 hz ).
  rewrite <- ( ringldistr hz ).
  rewrite ( ringcomm2 hz ( hzquotientmod m is y ) m ).
  change (m * hzquotientmod m is y + hzremaindermod m is y)%ring with
         (m * hzquotientmod m is y + hzremaindermod m is y)%hz.
  rewrite <- ( hzdivequationmod m is y ).
  change (hzremaindermod m is x * y)%ring with
         (hzremaindermod m is x * y)%hz.
  rewrite ( hzquotientmodandtimes m is ( hzremaindermod m is x ) y ).
  rewrite hzremaindermoditerated.
  rewrite <- hzqrandremainderq.
  rewrite hzmultx0.
  rewrite 2! hzmult0x.
  rewrite hzplusl0.
  rewrite ( ringassoc1 hz ).
  change (hzquotientmod m is x * y +
          (hzremaindermod m is x *
           hzquotientmod m is y +
           hzquotientmod m is (hzremaindermod m is x *
                               hzremaindermod m is y))%hz) with
  (hzquotientmod m is x * y +
   (hzremaindermod m is x * hzquotientmod m is y +
    hzquotientmod m is (hzremaindermod m is x *
                        hzremaindermod m is y)))%ring.
  apply idpath.
Defined.

(** here used to be shown the lemma [natsummationplusshift] *)

Lemma precarryandtimesl ( a b : fpscommring hz ) ( n : nat ) :
  hzquotientmod m is ( precarry ( a * b ) n ) =
  ( quotientprecarry a * b ) n +
        hzquotientmod m is ( precarry ( carry a  * b ) n ).
Proof.
  intros.
  induction n.
  - unfold precarry.
    change ( ( a * b ) 0%nat ) with ( a 0%nat * b 0%nat ).
    change ( ( quotientprecarry a * b ) 0%nat ) with
    ( hzquotientmod m is ( a 0%nat ) * b 0%nat ).
    rewrite quotientandtimesrearrangel.
    change ( ( carry a * b ) 0%nat ) with
    ( hzremaindermod m is ( a 0%nat ) * b 0%nat ).
    apply idpath.
  - change ( precarry ( a * b ) ( S n ) ) with
    ( ( a * b ) ( S n ) +
      hzquotientmod m is ( precarry ( a * b ) n ) ).
    rewrite IHn.
    rewrite <- ( ringassoc1 hz ).
    assert ( ( ( a * b ) ( S n ) +
               ( quotientprecarry a * b ) n ) =
      ( @op2 ( fpscommring hz ) ( precarry a ) b ) ( S n ) ) as f.
    { change ( ( a * b ) ( S n ) )
     with ( natsummation0 ( S n ) ( fun x : nat => a x * b ( sub ( S n ) x ) ) ).
     change ( ( quotientprecarry a * b ) n ) with
     ( natsummation0 n ( fun x : nat =>
         quotientprecarry a x * b ( sub n x ) ) ).
     rewrite natsummationplusshift.
     change ( ( @op2 ( fpscommring hz ) ( precarry a ) b ) ( S n ) ) with
     ( natsummation0 ( S n ) ( fun x : nat =>
         ( precarry a ) x * b ( sub ( S n ) x ) ) ).
     rewrite natsummationshift0.
     unfold precarry at 2.
     simpl.
     rewrite <- ( ringcomm1 hz ( a 0%nat * b ( S n ) ) _ ).
     apply ( maponpaths ( fun x : hz => a 0%nat * b ( S n ) + x ) ).
     apply natsummationpathsupperfixed.
     intros k j.
     unfold quotientprecarry.
     rewrite ( ringrdistr hz ).
     apply idpath.
    }
    rewrite f.
    rewrite hzquotientmodandplus.
    change ( @op2 ( fpscommring hz ) ( precarry a ) b ) with
    ( fpstimes hz ( precarry a ) b ).
    rewrite ( hzquotientandfpstimesl m is ( precarry a ) b ).
    change ( @op2 ( fpscommring hz ) ( carry a ) b ) with
    ( fpstimes hz ( carry a ) b ) at 1.
    unfold fpstimes at 1.
    unfold carry at 1.
    change (fun n0 : nat =>
              let t' := fun m0 : nat =>
                          b (n0 - m0)%nat in natsummation0 n0 (fun x : nat =>
                     (hzremaindermod m is (precarry a x) * t' x)%ring)) with
    ( carry a * b ).
    change ( ( quotientprecarry a * b ) ( S n ) ) with
    ( natsummation0 ( S n ) ( fun i : nat =>
        hzquotientmod m is ( precarry a i ) * b ( S n - i )%nat ) ).
    rewrite 2! hzplusassoc.
    apply ( maponpaths ( fun v => natsummation0 ( S n ) ( fun i : nat =>
      hzquotientmod m is ( precarry a i ) * b ( S n - i )%nat ) + v ) ).
    change ( precarry ( carry a * b ) ( S n ) ) with
    ( ( carry a * b ) ( S n ) +
      hzquotientmod m is ( precarry ( carry a * b ) n ) ).
    change ((carry a * b) (S n) +
            hzquotientmod m is (precarry (carry a * b) n)) with
    ((carry a * b)%ring (S n) +
     hzquotientmod m is (precarry (carry a * b) n)%ring)%hz.
    rewrite ( hzquotientmodandplus m is
                                   ( ( carry a * b ) ( S n ) )
     ( hzquotientmod m is ( precarry ( carry a * b ) n ) ) ).
    change ( ( carry a * b ) ( S n ) ) with
    ( natsummation0 ( S n ) ( fun i : nat =>
        hzremaindermod m is ( precarry a i ) * b ( S n  - i )%nat ) ).
    rewrite hzplusassoc.
    apply ( maponpaths ( fun v =>
       ( hzquotientmod m is ( natsummation0 ( S n ) ( fun i : nat =>
            hzremaindermod m is
                   ( precarry a i ) * b ( S n - i )%nat ) ) ) + v ) ).
    apply ( maponpaths ( fun v =>
        hzquotientmod m is
           ( hzquotientmod m is
              ( precarry ( carry a * b )%ring n ) ) + v ) ).
    apply maponpaths.
    apply ( maponpaths ( fun v =>
                           v + hzremaindermod m is
    ( hzquotientmod m is ( precarry ( carry a * b )%ring n ) ) ) ).
    unfold fpstimes.
    rewrite hzqrandnatsummation0r.
    rewrite ( hzqrandnatsummation0r m is ( fun i : nat =>
      hzremaindermod m is ( precarry a i ) * b ( S n - i )%nat ) ).
    apply maponpaths.
    apply natsummationpathsupperfixed.
    intros j p.
    change ( hzremaindermod m is
                            (hzremaindermod m is (precarry a j) *
                             b ( sub ( S n ) j)) ) with
    ( hzremaindermod m is
                     (hzremaindermod m is (precarry a j) *
                      b (S n - j)%nat)%hz ).
    rewrite ( hzremaindermodandtimes m is
                ( hzremaindermod m is ( precarry a j ) )
                ( b ( sub ( S n ) j ) ) ).
    rewrite hzremaindermoditerated.
    rewrite <- hzremaindermodandtimes.
    apply idpath.
Defined.

Lemma carryandtimesl ( a b : fpscommring hz ) :
  carry ( a * b ) = carry ( carry a * b ).
Proof.
  intros.
  assert ( forall n : nat, carry ( a * b ) n =
                          carry ( carry a * b ) n ) as f.
  { intros n.
    destruct n.
    - unfold carry at 1 2.
      change ( precarry ( a * b ) 0%nat ) with
      ( a 0%nat * b 0%nat ).
      change ( precarry ( carry a * b ) 0%nat ) with
      ( carry a 0%nat * b 0%nat ).
      unfold carry.
      change (hzremaindermod m is (precarry a 0) * b 0%nat) with
      (hzremaindermod m is (precarry a 0) * b 0%nat )%hz.
      rewrite ( hzremaindermodandtimes m is
        ( hzremaindermod m is ( precarry a 0%nat ) ) ( b 0%nat ) ).
      rewrite hzremaindermoditerated.
      rewrite <- hzremaindermodandtimes.
      change ( precarry a 0%nat ) with ( a 0%nat ).
      apply idpath.
    - unfold carry at 1 2.
      change ( precarry ( a * b ) ( S n ) ) with
      ( ( a * b ) ( S n ) + hzquotientmod m is ( precarry ( a * b ) n ) ).
      rewrite precarryandtimesl.
      rewrite <- ( ringassoc1 hz ).
      rewrite hzremaindermodandplus.
      assert ( hzremaindermod m is
          ( ( a * b ) ( S n ) + ( quotientprecarry a * b ) n ) =
        hzremaindermod m is ( ( carry a * b ) ( S n ) ) ) as g.
      { change ( hzremaindermod m is ( ( natsummation0 ( S n ) ( fun u : nat =>
                                             a u * b ( sub ( S n ) u ) ) ) +
                                       ( natsummation0 n ( fun u : nat =>
                       ( quotientprecarry a ) u * b ( sub n u ) ) ) ) =
                 hzremaindermod m is ( natsummation0 ( S n ) ( fun u : nat =>
                              ( carry a ) u * b ( sub ( S n ) u ) ) ) ).
        rewrite ( natsummationplusshift n ).
        rewrite ( natsummationshift0 n ( fun u : nat =>
                                    carry a u * b ( sub ( S n ) u ) ) ).
        assert ( hzremaindermod m is ( natsummation0 n ( fun x : nat =>
                              a ( S x ) * b ( sub ( S n ) ( S x ) ) +
                              quotientprecarry a x * b ( sub n x ) ) ) =
                 hzremaindermod m is (natsummation0 n ( fun x : nat =>
                   carry a ( S x ) * b ( sub ( S n ) ( S x ) ) ) ) ) as h.
        { rewrite hzqrandnatsummation0r.
          rewrite ( hzqrandnatsummation0r m is ( fun x : nat =>
                          carry a ( S x ) * b ( sub ( S n ) ( S x ) ) ) ).
          apply maponpaths.
          apply natsummationpathsupperfixed.
          intros j p.
          unfold quotientprecarry.
          simpl.
(* the following command takes overly long on Oct. 30, 2017:
          change (a (S j) * b ( sub n j) +
                  hzquotientmod m is (precarry a j) * b ( sub n j)) with
                 (a (S j) * b ( sub n j) +
                  hzquotientmod m is (precarry a j) * b ( sub n j) )%hz.
 *)
          intermediate_path (hzremaindermod m is ((a (S j) * b ( sub n j) +
                   hzquotientmod m is (precarry a j) * b ( sub n j) )%hz)).
          + exact (idpath _).
          + rewrite <- ( hzrdistr ( a ( S j ) )
                                 ( hzquotientmod m is ( precarry a j ) )
                                 ( b ( sub n j ) ) ).
            rewrite hzremaindermodandtimes.
            change ( hzremaindermod m is
                        (hzremaindermod m is (a (S j) +
                         hzquotientmod m is (precarry a j)) *
                           hzremaindermod m is (b ( sub n j))) =
                     hzremaindermod m is (carry a (S j) * b(sub n j)) )%ring.
            rewrite <- ( hzremaindermoditerated m is (a (S j) +
                                         hzquotientmod m is (precarry a j)) ).
            unfold carry.
            rewrite <- hzremaindermodandtimes.
            apply idpath.
        }
        rewrite hzremaindermodandplus.
        rewrite h.
        rewrite <- hzremaindermodandplus.
        unfold carry at 3.
        rewrite ( hzremaindermodandplus m is _
                    ( hzremaindermod m is ( precarry a 0%nat ) *
                                            b ( sub ( S n ) 0%nat ) ) ).
        rewrite hzremaindermodandtimes.
        rewrite hzremaindermoditerated.
        rewrite <- hzremaindermodandtimes.
        change ( precarry a 0%nat ) with ( a 0%nat ).
        rewrite <- hzremaindermodandplus.
        rewrite hzpluscomm.
        apply idpath.
      }
      rewrite g.
      rewrite <- hzremaindermodandplus.
      apply idpath.
  }
  apply ( funextfun _ _ f ).
Defined.

Lemma carryandtimesr ( a b : fpscommring hz ) :
  carry ( a * b ) = carry ( a * carry b ).
Proof.
  intros.
  rewrite ( @ringcomm2 ( fpscommring hz ) ).
  rewrite carryandtimesl.
  rewrite ( @ringcomm2 ( fpscommring hz ) ).
  apply idpath.
Defined.

Lemma carryandtimes ( a b : fpscommring hz ) :
  carry ( a * b ) = carry ( carry a * carry b ).
Proof.
  intros.
  rewrite carryandtimesl.
  rewrite carryandtimesr.
  apply idpath.
Defined.

Lemma ringcarryequiv : @ringeqrel ( fpscommring hz ).
Proof.
  intros.
  split with carryequiv.
  split.
  - split.
    + intros a b c q.
      simpl.
      simpl in q.
      rewrite carryandplus.
      rewrite q.
      rewrite <- carryandplus.
      apply idpath.
    + intros a b c q.
      simpl.
      rewrite carryandplus.
      rewrite q.
      rewrite <- carryandplus.
      apply idpath.
  - split.
    + intros a b c q.
      simpl.
      rewrite carryandtimes.
      rewrite q.
      rewrite <- carryandtimes.
      apply idpath.
    + intros a b c q.
      simpl.
      rewrite carryandtimes.
      rewrite q.
      rewrite <- carryandtimes.
      apply idpath.
Defined.

End carry.

(** ** Some preparation for parts III/IV that does not depend on a prime number *)
(** Those used to appear where needed below, those points have been marked by comments. *)

Lemma commringquotprandop1 { A : commring } ( R : @ringeqrel A ) ( a b : A ) :
  @op1 ( commringquot R ) ( setquotpr ( pr1 R ) a )
                          ( setquotpr ( pr1 R ) b ) =
  setquotpr ( pr1 R ) ( a + b ).
Proof.
  intros.
  change ( @op1 ( commringquot R ) ) with
  ( setquotfun2 R R ( @op1 A )
      ( pr1 ( iscomp2binoptransrel ( pr1 R )
                            ( eqreltrans _ ) ( pr2 R ) ) ) ).
  unfold setquotfun2.
  rewrite setquotuniv2comm.
  apply idpath.
Defined.

Lemma commringquotprandop2 { A : commring } ( R : @ringeqrel A ) ( a b : A ) :
  @op2 ( commringquot R ) ( setquotpr ( pr1 R ) a )
                          ( setquotpr ( pr1 R ) b ) =
  setquotpr ( pr1 R ) ( a * b ).
Proof.
  intros.
  change ( @op2 ( commringquot R ) ) with
  ( setquotfun2 R R ( @op2 A )
       ( pr2 ( iscomp2binoptransrel ( pr1 R )
                             ( eqreltrans _ ) ( pr2 R ) ) ) ).
  unfold setquotfun2.
  rewrite setquotuniv2comm.
  apply idpath.
Defined.

Lemma hzfpstimesnonzero ( a : fpscommring hz ) ( k : nat )
      ( is : neq hz ( a k ) 0%hz ×
             forall m : nat, natlth m k -> a m = 0%hz ) :
  forall k' : nat, forall b : fpscommring hz ,
      forall is' : neq hz ( b k' ) 0%hz ×
              forall m : nat, natlth m k' -> b m = 0%hz,
        ( a * b ) ( k + k' )%nat = a k * b k'.
Proof.
  intros k'.
  induction k'.
  - intros.
    destruct k.
    + simpl.
      apply idpath.
    + rewrite natplusr0.
      change ( natsummation0 k ( fun x : nat =>
               a x * b ( sub ( S k ) x ) ) +
               a ( S k ) * b ( sub ( S k ) ( S k ) ) =
      a ( S k ) * b 0%nat ).
      assert ( natsummation0 k ( fun x : nat =>
                          a x * b ( sub ( S k ) x ) ) =
               natsummation0 k ( fun x : nat => 0%hz ) ) as f.
      { apply natsummationpathsupperfixed.
        intros m i.
        assert ( natlth m ( S k ) ) as i0.
        * apply ( natlehlthtrans _ k _ ).
          -- assumption.
          -- apply natlthnsn.
        * rewrite ( pr2 is m i0 ).
          rewrite hzmult0x.
          apply idpath.
      }
      rewrite f.
      rewrite natsummationae0bottom.
      * rewrite hzplusl0.
        rewrite minusnn0.
        apply idpath.
      * intros m i.
        apply idpath.
  - intros.
    rewrite natplusnsm.
    change ( natsummation0 ( k + k' )%nat ( fun x : nat =>
               a x * b ( sub ( S k + k' ) x ) ) +
               a ( S k + k' )%nat * b ( sub ( S k + k' ) ( S k + k' ) ) =
             a k * b ( S k' ) ).
    set ( b' := fpsshift b ).
    rewrite minusnn0.
    rewrite ( pr2 is' 0%nat ( natlehlthtrans 0 k' ( S k' )
                               ( natleh0n k' ) ( natlthnsn k' ) ) ).
    rewrite hzmultx0.
    rewrite hzplusr0.
    assert ( natsummation0 ( k + k' )%nat ( fun x : nat =>
                           a x * b ( sub ( S k + k' ) x ) ) =
            fpstimes hz a b' ( k + k' )%nat ) as f.
    { apply natsummationpathsupperfixed.
      intros m v.
      change ( S k + k' )%nat with ( S ( k + k' ) ).
      rewrite <- ( pathssminus ( k + k' )%nat m ).
      + apply idpath.
      + apply ( natlehlthtrans _ ( k + k' )%nat _ ).
        * assumption.
        * apply natlthnsn.
    }
    rewrite f.
    apply ( IHk' b' ).
    split.
    + apply is'.
    + intros m v.
      unfold b'.
      unfold fpsshift.
      apply is'.
      assumption.
Defined.

Lemma hzfpstimeswhenzero ( a : fpscommring hz ) ( m k : nat )
      ( is : ( forall m : nat, natlth m k -> a m = 0%hz ) ) :
  forall b : fpscommring hz, forall k' : nat,
      forall is' : ( forall m : nat, natlth m k' -> b m = 0%hz ) ,
        natlth m ( k + k' )%nat -> ( a * b ) m = 0%hz.
Proof.
  revert k is.
  induction m.
  - intros k.
    intros is b k' is' j.
    change ( a 0%nat * b 0%nat = 0%hz ).
    destruct k.
    + rewrite ( is' 0%nat j ).
      rewrite hzmultx0.
      apply idpath.
    + assert ( natlth 0 ( S k ) ) as i.
      { apply ( natlehlthtrans _ k _ ).
        * apply natleh0n.
        * apply natlthnsn.
      }
      rewrite ( is 0%nat i ).
      rewrite hzmult0x.
      apply idpath.
  - intros k is b k' is' j.
    change ( natsummation0 ( S m ) ( fun x : nat =>
                      a x * b ( sub ( S m ) x ) ) =
            0%hz ).
    change ( natsummation0 m ( fun x : nat =>
               a x * b ( sub ( S m ) x ) ) +
               a ( S m ) * b ( sub ( S m ) ( S m ) ) =
             0%hz ).
    assert ( a ( S m ) * b ( sub ( S m ) ( S m ) ) = 0%hz ) as g.
    { destruct k.
      + destruct k'.
        * apply fromempty.
          apply ( negnatgth0n ( S m ) j ).
        * rewrite minusnn0.
          rewrite ( is' 0%nat ( natlehlthtrans 0%nat k' ( S k' )
                                             ( natleh0n k' )
                                             ( natlthnsn k' ) ) ).
          rewrite hzmultx0.
          apply idpath.
      + destruct k'.
        * rewrite natplusr0 in j.
          rewrite ( is ( S m ) j ).
          rewrite hzmult0x.
          apply idpath.
        * rewrite minusnn0.
          rewrite ( is' 0%nat ( natlehlthtrans 0%nat k' ( S k' )
                                             ( natleh0n k' )
                                             ( natlthnsn k' ) ) ).
          rewrite hzmultx0.
          apply idpath.
    }
    rewrite g.
    rewrite hzplusr0.
    set ( b' := fpsshift b ).
    assert ( natsummation0 m ( fun x : nat =>
                                 a x * b ( sub ( S m ) x ) ) =
             natsummation0 m ( fun x : nat =>
                                 a x * b' ( sub m x ) ) ) as f.
    { apply natsummationpathsupperfixed.
      intros n i.
      unfold b'.
      unfold fpsshift.
      rewrite pathssminus.
      + apply idpath.
      + apply ( natlehlthtrans _ m _ ).
        * assumption.
        * apply natlthnsn.
    }
    rewrite f.
    change ( ( a * b' ) m = 0%hz ).
    assert ( natlth m ( k + k' ) ) as one.
    { apply ( istransnatlth _ ( S m ) _ ).
      + apply natlthnsn.
      + assumption.
    }
    destruct k'.
    + assert ( forall m : nat, natlth m 0%nat -> b' m = 0%hz ) as two.
      { intros m0 j0.
        apply fromempty.
        apply ( negnatgth0n m0).
        assumption.
      }
      apply ( IHm k is b' 0%nat two one ).
    + assert ( forall m : nat, natlth m k' -> b' m = 0%hz ) as two.
      { intros m0 j0.
        change ( b ( S m0 ) = 0%hz ).
        apply is'.
        assumption.
      }
      assert ( natlth m ( k + k' )%nat ) as three.
      { rewrite natplusnsm in j.
        apply j.
      }
      apply ( IHm k is b' k' two three ).
Defined.

(** ** Definition of p-adic integers *)

Section A.

Variable p : hz.
Variable is : isaprime p.

Definition commringofpadicints :=
  commringquot ( ringcarryequiv p ( isaprimetoneq0 is ) ).

Definition padicplus := @op1 commringofpadicints.

Definition padictimes := @op2 commringofpadicints.

(** * III. The apartness relation on p-adic integers *)

Definition padicapart0 :
  hrel ( fpscommring hz ) := fun a b =>
    ∃ n : nat, neq _ ( carry p ( isaprimetoneq0 is) a n )
                   ( carry p ( isaprimetoneq0 is) b n ).

Lemma padicapartiscomprel :
  iscomprelrel ( carryequiv p ( isaprimetoneq0 is ) ) padicapart0.
Proof.
  intros a a' b b' i j.
  apply hPropUnivalence.
  - intro k.
    use (hinhuniv _ k).
    intros u.
    destruct u as [ n u ].
    apply total2tohexists.
    split with n.
    rewrite <- i , <- j.
    assumption.
  - intro k.
    use (hinhuniv _ k).
    intros u.
    destruct u as [ n u ].
    apply total2tohexists.
    split with n.
    rewrite i, j.
    assumption.
Defined.

Definition padicapart1 : hrel commringofpadicints :=
  quotrel padicapartiscomprel.

Lemma isirreflpadicapart0 : isirrefl padicapart0.
Proof.
  intros a f.
  simpl in f.
  assert hfalse as x.
  { apply f.
    intros u.
    destruct u as [ n u ].
    apply u.
    apply idpath.
  }
  exact x.
Defined.

Lemma issymmpadicapart0 : issymm padicapart0.
Proof.
  intros a b f.
  use (hinhuniv _ f).
  intros u.
  destruct u as [ n u ].
  apply total2tohexists.
  split with n.
  intros g.
  unfold neq in u.
  apply u.
  rewrite g.
  apply idpath.
Defined.

Lemma iscotranspadicapart0 : iscotrans padicapart0.
Proof.
  intros a b c f.
  use (hinhuniv _ f).
  intro u.
  destruct u as [ n u ].
  intros P j.
  apply j.
  destruct ( isdeceqhz ( carry p ( isaprimetoneq0 is ) a n )
                       ( carry p ( isaprimetoneq0 is ) b n ) )
    as [ l | r ].
  - apply ii2.
    intros Q k.
    apply k.
    split with n.
    intros g.
    unfold neq in u.
    apply u.
    rewrite l, g.
    apply idpath.
  - apply ii1.
    intros Q k.
    apply k.
    split with n.
    intros g.
    apply r.
    assumption.
Defined.

Definition padicapart : apart commringofpadicints.
Proof.
  intros.
  split with padicapart1.
  split.
  - unfold padicapart1.
    apply ( isirreflquotrel padicapartiscomprel
                            isirreflpadicapart0 ).
  - split.
    + apply ( issymmquotrel padicapartiscomprel
                            issymmpadicapart0 ).
    + apply ( iscotransquotrel padicapartiscomprel
                               iscotranspadicapart0 ).
Defined.

Lemma precarryandzero :
  precarry p ( isaprimetoneq0 is ) 0 = @ringunel1 ( fpscommring hz ).
Proof.
  intros.
  assert ( forall n : nat, precarry p ( isaprimetoneq0 is ) 0 n =
                    @ringunel1 (fpscommring hz ) n ) as f.
  { intros n.
    induction n.
    - unfold precarry.
      change ( @ringunel1 ( fpscommring hz ) 0%nat ) with 0%hz.
      apply idpath.
    - change ( ( ( @ringunel1 ( fpscommring hz ) ( S n ) +
        hzquotientmod p ( isaprimetoneq0 is )
           ( precarry p ( isaprimetoneq0 is )
               ( @ringunel1 ( fpscommring hz ) ) n ) ) ) = 0%hz ).
      rewrite IHn.
      change ( @ringunel1 ( fpscommring hz ) n ) with 0%hz.
      change ( @ringunel1 ( fpscommring hz ) ( S n ) ) with 0%hz.
      rewrite hzqrand0q.
      rewrite hzplusl0.
      apply idpath.
  }
  apply ( funextfun _ _ f ).
Defined.

Lemma carryandzero : carry p ( isaprimetoneq0 is ) 0 = 0.
Proof.
  intros.
  unfold carry.
  rewrite precarryandzero.
  assert ( forall n : nat, (fun n : nat =>
    hzremaindermod p (isaprimetoneq0 is)
                     ( @ringunel1 ( fpscommring hz ) n)) n =
    @ringunel1 ( fpscommring hz ) n ) as f.
  { intros n.
    rewrite hzqrand0r.
    unfold carry.
    change ( @ringunel1 ( fpscommring hz)  n ) with 0%hz.
    apply idpath.
  }
  apply ( funextfun _ _ f ).
Defined.

Lemma precarryandone :
  precarry p ( isaprimetoneq0 is ) 1 =
  @ringunel2 ( fpscommring hz ).
Proof.
  intros.
  assert ( forall n : nat, precarry p ( isaprimetoneq0 is ) 1 n =
                    @ringunel2 (fpscommring hz ) n ) as f.
  { intros n.
    induction n.
    - unfold precarry.
      apply idpath.
    - simpl.
      rewrite IHn.
      destruct n.
      + change ( @ringunel2 ( fpscommring hz ) 0%nat ) with 1%hz.
        rewrite hzqrand1q.
        rewrite hzplusr0.
        apply idpath.
      + change ( @ringunel2 ( fpscommring hz ) ( S n ) ) with 0%hz.
        rewrite hzqrand0q.
        rewrite hzplusr0.
        apply idpath.
  }
  apply ( funextfun _ _ f ).
Defined.

Lemma carryandone : carry p ( isaprimetoneq0 is ) 1 = 1.
Proof.
  intros.
  unfold carry.
  rewrite precarryandone.
  assert ( forall n : nat, (fun n : nat =>
    hzremaindermod p (isaprimetoneq0 is)
           ( @ringunel2 ( fpscommring hz ) n)) n =
    @ringunel2 ( fpscommring hz ) n ) as f.
  { intros n.
    destruct n.
    - change ( @ringunel2 ( fpscommring hz ) 0%nat ) with 1%hz.
      rewrite hzqrand1r.
      apply idpath.
    - change ( @ringunel2 ( fpscommring hz ) ( S n ) ) with 0%hz.
      rewrite hzqrand0r.
      apply idpath.
  }
  apply ( funextfun _ _ f ).
Defined.

Lemma padicapartcomputation ( a b : fpscommring hz ) :
    ( pr1 padicapart )
    ( setquotpr ( carryequiv p ( isaprimetoneq0 is ) ) a )
    ( setquotpr ( carryequiv p ( isaprimetoneq0 is ) ) b ) =
                              padicapart0 a b.
Proof.
  intros.
  apply hPropUnivalence.
  - intros i.
    apply i.
  - intro u.
    apply u.
Defined.

Lemma padicapartandplusprecarryl ( a b c : fpscommring hz ) ( n : nat )
  ( x : neq _ ( precarry p ( isaprimetoneq0 is )
                             ( carry p ( isaprimetoneq0 is ) a +
                               carry p ( isaprimetoneq0 is ) b ) n )
            ( ( precarry p ( isaprimetoneq0 is )
                             ( carry p ( isaprimetoneq0 is ) a +
                               carry p ( isaprimetoneq0 is ) c ) ) n ) ) :
  padicapart0 b c.
Proof.
  intros.
  set ( P := fun x : nat =>
    neq hz (precarry p (isaprimetoneq0 is) (carry p (isaprimetoneq0 is) a +
                                            carry p (isaprimetoneq0 is) b) x)
           (precarry p (isaprimetoneq0 is) (carry p (isaprimetoneq0 is) a +
                                            carry p (isaprimetoneq0 is) c) x) ).
  assert ( isdecnatprop P ) as isdec.
  { intros m.
    destruct ( isdeceqhz (precarry p (isaprimetoneq0 is)
                            (carry p (isaprimetoneq0 is) a +
                             carry p (isaprimetoneq0 is) b) m)
                         (precarry p (isaprimetoneq0 is)
                            (carry p (isaprimetoneq0 is) a +
                             carry p (isaprimetoneq0 is) c) m) ) as [ l | r ].
    - apply ii2.
      intros j.
      unfold P in j.
      unfold neq in j.
      apply j.
      assumption.
    - apply ii1.
      assumption.
  }
  set ( leexists := leastelementprinciple n P isdec x ).
  use (hinhuniv _ leexists).
  intro k.
  destruct k as [ k k' ].
  destruct k' as [ k' k'' ].
  destruct k.
  - apply total2tohexists.
    split with 0%nat.
    intros i.
    unfold P in k'. unfold neq in k'. (* crucial *)
    apply k'.
    change (carry p (isaprimetoneq0 is) a 0%nat +
            carry p (isaprimetoneq0 is) b 0%nat =
           (carry p (isaprimetoneq0 is) a 0%nat +
            carry p (isaprimetoneq0 is) c 0%nat) ).
    rewrite i.
    apply idpath.
  - apply total2tohexists.
    split with ( S k ).
    intro i.
    apply ( k'' k ).
    + apply natlthnsn.
    + intro j.
      unfold P in k'. unfold neq in k'. (* crucial *)
      apply k'.
      change ( carry p ( isaprimetoneq0 is ) a ( S k ) +
               carry p ( isaprimetoneq0 is ) b ( S k ) +
               hzquotientmod p ( isaprimetoneq0 is )
                     ( precarry p ( isaprimetoneq0 is )
                            ( carry p ( isaprimetoneq0 is ) a +
                              carry p ( isaprimetoneq0 is ) b ) k ) =
      ( carry p ( isaprimetoneq0 is ) a ( S k ) +
        carry p ( isaprimetoneq0 is ) c ( S k ) +
        hzquotientmod p ( isaprimetoneq0 is )
                      ( precarry p ( isaprimetoneq0 is )
                             ( carry p ( isaprimetoneq0 is ) a +
                               carry p ( isaprimetoneq0 is ) c ) k ) ) ).
      rewrite i.
      rewrite j.
      apply idpath.
Defined.

Lemma padicapartandplusprecarryr ( a b c : fpscommring hz ) ( n : nat )
  ( x : neq _ ( precarry p ( isaprimetoneq0 is )
                         ( carry p ( isaprimetoneq0 is ) b +
                           carry p ( isaprimetoneq0 is ) a ) n )
            ( ( precarry p ( isaprimetoneq0 is )
                         ( carry p ( isaprimetoneq0 is ) c +
                           carry p ( isaprimetoneq0 is ) a ) ) n ) ) :
  padicapart0 b c.
Proof.
  intros.
  rewrite 2! ( ringcomm1 ( fpscommring hz ) _
                        ( carry p ( isaprimetoneq0 is ) a ) ) in x.
  apply ( padicapartandplusprecarryl a b c n x ).
Defined.

(** here used to be shown the lemmas [commringquotprandop1] and
    [commringquotprandop2] *)

Lemma setquotprandpadicplus ( a b : fpscommring hz ) :
  @op1 commringofpadicints
    ( setquotpr ( carryequiv p ( isaprimetoneq0 is ) ) a )
    ( setquotpr ( carryequiv p ( isaprimetoneq0 is ) ) b ) =
  setquotpr ( carryequiv p ( isaprimetoneq0 is ) ) ( a + b ).
Proof.
  intros.
  apply commringquotprandop1.
Defined.

Lemma setquotprandpadictimes ( a b : fpscommring hz ) :
  @op2 commringofpadicints
    ( setquotpr ( carryequiv p ( isaprimetoneq0 is ) ) a )
    ( setquotpr ( carryequiv p ( isaprimetoneq0 is ) ) b ) =
 setquotpr ( carryequiv p ( isaprimetoneq0 is ) ) ( a * b ).
Proof.
  intros.
  apply commringquotprandop2.
Defined.

Lemma padicplusisbinopapart0 ( a b c : fpscommring hz )
  ( u : padicapart0 ( a + b ) ( a + c ) ) :
  padicapart0 b c.
Proof.
  intros.
  use (hinhuniv _ u).
  intros n.
  destruct n as [ n n' ].
  set ( P := fun x : nat => neq hz ( carry p ( isaprimetoneq0 is ) ( a + b) x)
                           ( carry p ( isaprimetoneq0 is ) ( a + c) x) ).
  assert ( isdecnatprop P ) as isdec.
  { intros m.
    destruct ( isdeceqhz ( carry p ( isaprimetoneq0 is ) ( a + b) m)
                         ( carry p ( isaprimetoneq0 is ) ( a + c) m) )
      as [ l | r ].
    - apply ii2.
      intros j.
      unfold P in j. unfold neq in j. (* crucial *)
      apply j.
      assumption.
    - apply ii1.
      assumption.
  }
  set ( le := leastelementprinciple n P isdec n').
  use (hinhuniv _ le).
  intro k.
  destruct k as [ k k' ].
  destruct k' as [ k' k'' ].
  destruct k.
  - apply total2tohexists.
    split with 0%nat.
    intros j.
    unfold P in k'. unfold neq in k'. (* crucial *)
    apply k'.
    unfold carry.
    unfold precarry.
    change ( ( a + b ) 0%nat ) with ( a 0%nat + b 0%nat ).
    change ( ( a + c ) 0%nat ) with ( a 0%nat + c 0%nat ).
    unfold carry in j.
    unfold precarry in j.
    rewrite hzremaindermodandplus.
    rewrite j.
    rewrite <- hzremaindermodandplus.
    apply idpath.
  - destruct ( isdeceqhz ( carry p ( isaprimetoneq0 is ) b ( S k ) )
                         ( carry p ( isaprimetoneq0 is ) c ( S k ) ) )
      as [ l | r ].
    + apply ( padicapartandplusprecarryl a b c k ).
      intros j.
      unfold P in k'. unfold neq in k'.
      apply k'.
      rewrite carryandplus.
      unfold carry at 1.
      change (hzremaindermod p ( isaprimetoneq0 is )
                ( carry p ( isaprimetoneq0 is ) a ( S k ) +
                  carry p ( isaprimetoneq0 is ) b ( S k ) +
                    hzquotientmod p ( isaprimetoneq0 is )
                      ( precarry p ( isaprimetoneq0 is )
                           ( carry p ( isaprimetoneq0 is ) a +
                             carry p ( isaprimetoneq0 is ) b ) k ) ) =
      carry p ( isaprimetoneq0 is ) ( a + c ) ( S k ) ).
      rewrite l.
      rewrite j.
      rewrite ( carryandplus p ( isaprimetoneq0 is ) a c ).
      unfold carry at 5.
      change ( precarry p ( isaprimetoneq0 is )
                        ( carry p ( isaprimetoneq0 is ) a +
                          carry p ( isaprimetoneq0 is ) c ) ( S k ) ) with
      ( carry p ( isaprimetoneq0 is ) a ( S k ) +
        carry p ( isaprimetoneq0 is ) c ( S k ) +
        hzquotientmod p ( isaprimetoneq0 is )
                      ( precarry p ( isaprimetoneq0 is )
                                 ( carry p ( isaprimetoneq0 is ) a +
                                   carry p ( isaprimetoneq0 is ) c ) k ) ).
      apply idpath.
    + apply total2tohexists.
      split with ( S k ).
      assumption.
Defined.

Lemma padicplusisbinopapartl : isbinopapartl padicapart padicplus.
Proof.
  intros.
  unfold isbinopapartl.
  assert ( forall x x' x'' : commringofpadicints,
             isaprop ( pr1 padicapart
                         ( padicplus x x' )
                         ( padicplus x x'' ) ->
                       ( pr1 padicapart x' x'' ) ) ) as int.
  { intros.
    apply impred.
    intros.
    apply ( pr1 padicapart ).
  }
  apply ( setquotuniv3prop _ ( fun x x' x'' =>
                                 make_hProp _ ( int x x' x'' ) ) ).
  intros a b c.
  change (pr1 padicapart
              (padicplus (setquotpr (ringcarryequiv p (isaprimetoneq0 is)) a)
                         (setquotpr (ringcarryequiv p (isaprimetoneq0 is)) b))
              (padicplus (setquotpr (ringcarryequiv p (isaprimetoneq0 is)) a)
                         (setquotpr (ringcarryequiv p (isaprimetoneq0 is)) c)) ->
          pr1 padicapart
              (setquotpr (ringcarryequiv p (isaprimetoneq0 is)) b)
              (setquotpr (ringcarryequiv p (isaprimetoneq0 is)) c)).
  unfold padicplus.
  rewrite 2! setquotprandpadicplus.
  rewrite 2! padicapartcomputation.
  apply padicplusisbinopapart0.
Defined.

Lemma padicplusisbinopapartr : isbinopapartr padicapart padicplus.
Proof.
  intros.
  unfold isbinopapartr.
  intros a b c.
  unfold padicplus.
  rewrite ( @ringcomm1 commringofpadicints b a ).
  rewrite ( @ringcomm1 commringofpadicints c a ).
  apply padicplusisbinopapartl.
Defined.

Lemma padicapartandtimesprecarryl ( a b c : fpscommring hz ) ( n : nat )
  ( x : neq _ ( precarry p ( isaprimetoneq0 is )
                         ( carry p ( isaprimetoneq0 is ) a *
                           carry p ( isaprimetoneq0 is ) b ) n )
            ( ( precarry p ( isaprimetoneq0 is )
                         ( carry p ( isaprimetoneq0 is ) a *
                           carry p ( isaprimetoneq0 is ) c ) ) n ) ) :
  padicapart0 b c.
Proof.
  intros.
  set ( P := fun x : nat =>
               neq hz (precarry p (isaprimetoneq0 is)
                                (carry p (isaprimetoneq0 is) a *
                                 carry p (isaprimetoneq0 is) b) x)
                   (precarry p (isaprimetoneq0 is)
                             (carry p (isaprimetoneq0 is) a *
                              carry p (isaprimetoneq0 is) c) x) ).
  assert ( isdecnatprop P ) as isdec.
  { intros m.
    destruct ( isdeceqhz (precarry p (isaprimetoneq0 is)
                                   (carry p (isaprimetoneq0 is) a *
                                    carry p (isaprimetoneq0 is) b) m)
                         (precarry p (isaprimetoneq0 is)
                                   (carry p (isaprimetoneq0 is) a *
                                    carry p (isaprimetoneq0 is) c) m) )
      as [ l | r ].
    - apply ii2.
      intros j.
      unfold P in j. unfold neq in j.
      apply j.
      assumption.
    - apply ii1.
      assumption.
  }
  set ( leexists := leastelementprinciple n P isdec x ).
  use (hinhuniv _ leexists).
  intro k.
  destruct k as [ k k' ].
  destruct k' as [ k' k'' ].
  induction k.
  - apply total2tohexists.
    split with 0%nat.
    intros i.
    unfold P in k'. unfold neq in k'.
    apply k'.
    change (carry p (isaprimetoneq0 is) a 0%nat *
            carry p(isaprimetoneq0 is) b 0%nat =
            carry p (isaprimetoneq0 is) a 0%nat *
            carry p (isaprimetoneq0 is) c 0%nat ).
    rewrite i.
    apply idpath.
  - set ( Q := ( fun o : nat =>
                   make_hProp ( carry p ( isaprimetoneq0 is ) b o =
                               carry p ( isaprimetoneq0 is ) c o )
                             ( isasethz _ _ ) ) ).
    assert ( isdecnatprop Q ) as isdec'.
    { intro o.
      destruct ( isdeceqhz ( carry p ( isaprimetoneq0 is ) b o )
                           ( carry p ( isaprimetoneq0 is ) c o ) )
        as [ l | r ].
      + apply ii1.
        assumption.
      + apply ii2.
        assumption.
    }
    destruct ( isdecisbndqdec Q isdec' ( S k ) ) as [ l | r ].
    + apply fromempty.
      apply ( k'' k ).
      { apply natlthnsn. }
      intro j.
      unfold P in k'. unfold neq in k'.
      apply k'.
      change ( ( natsummation0 ( S k ) ( fun x : nat =>
                     carry p ( isaprimetoneq0 is ) a x *
                     carry p ( isaprimetoneq0 is ) b ( sub ( S k ) x ) ) ) +
                 hzquotientmod p ( isaprimetoneq0 is )
                               ( precarry p ( isaprimetoneq0 is )
                                          ( carry p ( isaprimetoneq0 is ) a *
                                            carry p ( isaprimetoneq0 is ) b ) k ) =
                (( natsummation0 ( S k ) ( fun x : nat =>
                     carry p ( isaprimetoneq0 is ) a x *
                     carry p ( isaprimetoneq0 is ) c ( sub ( S k ) x ) ) ) +
                 hzquotientmod p ( isaprimetoneq0 is )
                               ( precarry p ( isaprimetoneq0 is )
                                          ( carry p ( isaprimetoneq0 is ) a *
                                            carry p ( isaprimetoneq0 is ) c ) k ) ) ).
      assert ( natsummation0 ( S k ) (fun x0 : nat =>
                   carry p (isaprimetoneq0 is) a x0 *
                   carry p (isaprimetoneq0 is) b ( sub ( S k ) x0)) =
                 natsummation0 ( S k ) (fun x0 : nat =>
                   carry p (isaprimetoneq0 is) a x0 *
                   carry p (isaprimetoneq0 is) c ( sub ( S k ) x0)) ) as f.
      { apply natsummationpathsupperfixed.
        intros m y.
        rewrite ( l ( sub ( S k ) m ) ).
        * apply idpath.
        * apply minusleh.
      }
      rewrite f.
      rewrite j.
      apply idpath.
    + use (hinhuniv _ r).
      intros o.
      destruct o as [ o o' ].
      apply total2tohexists.
      split with o.
      apply o'.
Defined.

Lemma padictimesisbinopapart0 ( a b c : fpscommring hz )
  ( u : padicapart0 ( a * b ) ( a * c ) ) :
  padicapart0 b c.
Proof.
  intros.
  use (hinhuniv _ u).
  intros n.
  destruct n as [ n n' ].
  destruct n.
  - apply total2tohexists.
    split with 0%nat.
    intros j.
    unfold neq in n'.
    apply n'.
    rewrite carryandtimes.
    rewrite ( carryandtimes p ( isaprimetoneq0 is ) a c ).
    change ( hzremaindermod p ( isaprimetoneq0 is )
                            ( carry p ( isaprimetoneq0 is ) a 0%nat *
                              carry p ( isaprimetoneq0 is ) b 0%nat ) =
                            hzremaindermod p ( isaprimetoneq0 is )
                            ( carry p ( isaprimetoneq0 is ) a 0%nat *
                              carry p ( isaprimetoneq0 is ) c 0%nat ) ).
    rewrite j.
    apply idpath.
  - set ( Q := ( fun o : nat =>
                   make_hProp ( carry p ( isaprimetoneq0 is ) b o =
                               carry p ( isaprimetoneq0 is ) c o )
                             ( isasethz _ _ ) ) ).
    assert ( isdecnatprop Q ) as isdec'.
    { intro o.
      destruct ( isdeceqhz ( carry p ( isaprimetoneq0 is ) b o )
                           ( carry p ( isaprimetoneq0 is ) c o ) )
        as [ l | r ].
      + apply ii1.
        assumption.
      + apply ii2.
        assumption.
    }
    destruct ( isdecisbndqdec Q isdec'( S n ) ) as [ l | r ].
    + apply ( padicapartandtimesprecarryl a b c n ).
      intros j.
      apply fromempty.
      unfold neq in n'.
      apply n'.
      rewrite carryandtimes.
      rewrite ( carryandtimes p ( isaprimetoneq0 is ) a c ).
      change ( hzremaindermod p ( isaprimetoneq0 is )
                   ( natsummation0 ( S n ) ( fun x : nat =>
                       carry p ( isaprimetoneq0 is ) a x *
                       carry p ( isaprimetoneq0 is ) b ( sub ( S n ) x ) ) +
                     hzquotientmod p ( isaprimetoneq0 is )
                       ( precarry p ( isaprimetoneq0 is )
                                  ( carry p ( isaprimetoneq0 is ) a *
                                    carry p ( isaprimetoneq0 is ) b ) n ) ) =
               ( hzremaindermod p ( isaprimetoneq0 is )
                   ( natsummation0 ( S n ) ( fun x : nat =>
                       carry p ( isaprimetoneq0 is ) a x *
                       carry p ( isaprimetoneq0 is ) c ( sub ( S n ) x ) ) +
                     hzquotientmod p ( isaprimetoneq0 is )
                       ( precarry p ( isaprimetoneq0 is )
                                  ( carry p ( isaprimetoneq0 is ) a *
                                    carry p ( isaprimetoneq0 is ) c ) n ) ) ) ).
      rewrite j.
      assert ( natsummation0 ( S n ) (fun x0 : nat =>
                   carry p (isaprimetoneq0 is) a x0 *
                   carry p (isaprimetoneq0 is) b ( sub ( S n ) x0)) =
                 natsummation0 ( S n ) (fun x0 : nat =>
                   carry p (isaprimetoneq0 is) a x0 *
                   carry p (isaprimetoneq0 is) c ( sub ( S n ) x0)) ) as f.
      { apply natsummationpathsupperfixed.
        intros m y.
        rewrite ( l ( sub ( S n ) m ) ).
        * apply idpath.
        * apply minusleh.
      }
      rewrite f.
      apply idpath.
    + use (hinhuniv _ r).
      intros k.
      destruct k as [ k k' ].
      apply total2tohexists.
      split with k.
      apply k'.
Defined.

Lemma padictimesisbinopapartl : isbinopapartl padicapart padictimes.
Proof.
  intros.
  unfold isbinopapartl.
  assert ( forall x x' x'' : commringofpadicints,
             isaprop ( pr1 padicapart
                         ( padictimes x x' )
                         ( padictimes x x'' ) ->
          ( pr1 padicapart x' x'' ) ) ) as int.
  {  intros.
     apply impred.
     intros.
     apply ( pr1 padicapart ).
  }
  apply ( setquotuniv3prop _ ( fun x x' x'' =>
                                 make_hProp _ ( int x x' x'' ) ) ).
  intros a b c.
  change (pr1 padicapart
              (padictimes (setquotpr (carryequiv p (isaprimetoneq0 is)) a)
                          (setquotpr (carryequiv p (isaprimetoneq0 is)) b))
              (padictimes (setquotpr (carryequiv p (isaprimetoneq0 is)) a)
                          (setquotpr (carryequiv p (isaprimetoneq0 is)) c)) ->
           pr1 padicapart (setquotpr (carryequiv p (isaprimetoneq0 is)) b)
                          (setquotpr (carryequiv p (isaprimetoneq0 is)) c)).
  unfold padictimes.
  rewrite 2! setquotprandpadictimes.
  rewrite 2! padicapartcomputation.
  intros j.
  apply ( padictimesisbinopapart0 a b c j ).
Defined.

Lemma padictimesisbinopapartr : isbinopapartr padicapart padictimes.
Proof.
  intros.
  unfold isbinopapartr.
  intros a b c.
  unfold padictimes.
  rewrite ( @ringcomm2 commringofpadicints b a ).
  rewrite ( @ringcomm2 commringofpadicints c a ).
  apply padictimesisbinopapartl.
Defined.

Definition acommringofpadicints : acommring.
Proof.
  intros.
  split with commringofpadicints.
  split with padicapart.
  split.
  - split.
    + apply padicplusisbinopapartl.
    + apply padicplusisbinopapartr.
  - split.
    + apply padictimesisbinopapartl.
    + apply padictimesisbinopapartr.
Defined.

(** * IV. The apartness domain of p-adic integers and the Heyting field of p-adic numbers *)

Lemma precarryandzeromultl ( a b : fpscommring hz ) ( n : nat )
  ( x : forall m : nat, natlth m n ->
                 carry p ( isaprimetoneq0 is ) a m = 0%hz ) :
  forall m : nat, natlth m n ->
       precarry p ( isaprimetoneq0 is )
                ( fpstimes hz ( carry p ( isaprimetoneq0 is ) a )
                              ( carry p ( isaprimetoneq0 is ) b ) ) m =
       0%hz.
Proof.
  intros m y.
  induction m.
  - simpl.
    unfold fpstimes.
    simpl.
    rewrite ( x 0%nat y ).
    rewrite hzmult0x.
    apply idpath.
  - change ( natsummation0 ( S m ) ( fun z : nat =>
               ( carry p ( isaprimetoneq0 is ) a z ) *
               ( carry p ( isaprimetoneq0 is ) b ( sub ( S m ) z ) ) ) +
          hzquotientmod p ( isaprimetoneq0 is )
                 ( precarry p ( isaprimetoneq0 is )
                    ( fpstimes hz ( carry p ( isaprimetoneq0 is ) a )
                                  ( carry p ( isaprimetoneq0 is ) b ) ) m ) =
    0%hz ).
    assert ( natlth m n ) as u.
    + apply ( istransnatlth _ ( S m ) _ ).
      { apply natlthnsn. }
      assumption.
    + rewrite ( IHm u ).
      rewrite hzqrand0q.
      rewrite hzplusr0.
      assert ( natsummation0 (S m) (fun z : nat =>
                 carry p (isaprimetoneq0 is) a z *
                 carry p (isaprimetoneq0 is) b ( sub ( S m ) z)) =
               natsummation0 ( S m ) ( fun z : nat => 0%hz ) ) as f.
      { apply natsummationpathsupperfixed.
        intros k v.
        assert ( natlth k n ) as uu.
        * apply ( natlehlthtrans _ ( S m ) _ ); assumption.
        * rewrite ( x k uu ).
          rewrite hzmult0x.
          apply idpath.
      }
      rewrite f.
      rewrite natsummationae0bottom.
      * apply idpath.
      * intros k l.
        apply idpath.
Defined.

Lemma precarryandzeromultr ( a b : fpscommring hz ) ( n : nat )
  ( x : forall m : nat, natlth m n ->
                 carry p ( isaprimetoneq0 is ) b m = 0%hz ) :
  forall m : nat, natlth m n ->
           precarry p ( isaprimetoneq0 is )
                    ( fpstimes hz ( carry p ( isaprimetoneq0 is ) a )
                               ( carry p ( isaprimetoneq0 is ) b ) ) m =
           0%hz.
Proof.
  intros m y.
  change (fpstimes hz (carry p (isaprimetoneq0 is) a)
                   (carry p (isaprimetoneq0 is) b)) with
  ( (carry p (isaprimetoneq0 is) a) *
    (carry p (isaprimetoneq0 is) b)).
  rewrite ( @ringcomm2 ( fpscommring hz )
              ( carry p ( isaprimetoneq0 is ) a )
              ( carry p ( isaprimetoneq0 is ) b ) ).
  apply ( precarryandzeromultl b a n x m y ).
Defined.

(** here used to be shown the lemmas [hzfpstimesnonzero] and
    [hzfpstimeswhenzero], now before part III *)

Lemma precarryandzeromult ( a b : fpscommring hz ) ( k k' : nat )
  ( x : forall m : nat, natlth m k ->
                 carry p ( isaprimetoneq0 is ) a m = 0%hz )
  ( x' : forall m : nat, natlth m k' ->
                  carry p ( isaprimetoneq0 is ) b m = 0%hz ) :
  forall m : nat, natlth m ( k + k' )%nat ->
           precarry p ( isaprimetoneq0 is )
                    ( fpstimes hz ( carry p ( isaprimetoneq0 is ) a )
                                  ( carry p ( isaprimetoneq0 is ) b ) ) m =
  0%hz.
Proof.
  intros m i.
  induction m.
  - apply ( hzfpstimeswhenzero ( carry p ( isaprimetoneq0 is ) a ) 0%nat k x
                               ( carry p ( isaprimetoneq0 is ) b ) k' x' i ).
  - change ( ( ( carry p ( isaprimetoneq0 is ) a ) *
               ( carry p ( isaprimetoneq0 is ) b ) ) ( S m ) +
      hzquotientmod p ( isaprimetoneq0 is )
                ( precarry p ( isaprimetoneq0 is )
                     ( fpstimes hz ( carry p ( isaprimetoneq0 is ) a )
                                   ( carry p ( isaprimetoneq0 is ) b ) ) m ) =
    0%hz ).
    rewrite ( hzfpstimeswhenzero ( carry p ( isaprimetoneq0 is ) a ) ( S m ) k x
                                 ( carry p ( isaprimetoneq0 is ) b ) k' x' i ).
    rewrite hzplusl0.
    assert ( natlth m ( k + k' )%nat ) as one.
    { apply ( istransnatlth _ ( S m ) _ ).
      + apply natlthnsn.
      + assumption.
    }
    rewrite ( IHm one ).
    rewrite hzqrand0q.
    apply idpath.
Defined.

Lemma primedivorcoprime ( a : hz ) :
  hzdiv p a ∨ gcd p a ( isaprimetoneq0 is ) = 1.
Proof.
  intros P i.
  use (hinhuniv _ ( pr2 is
                        ( gcd p a ( isaprimetoneq0 is ) )
                        ( pr1 ( gcdiscommondiv p a ( isaprimetoneq0 is ) ) ) )).
  intro t.
  apply i.
  destruct t as [ t0 | t1 ].
  - apply ii2.
    assumption.
  - apply ii1.
    rewrite <- t1.
    exact ( pr2 ( gcdiscommondiv p a ( isaprimetoneq0 is ) ) ).
Defined.

Lemma primeandtimes ( a b : hz ) ( x : hzdiv p ( a * b ) ) :
  hzdiv p a ∨ hzdiv p b.
Proof.
  intros.
  use (hinhuniv _ ( primedivorcoprime a )).
  intros j. intros P i.
  apply i.
  destruct j as [ j0 | j1 ].
  - apply ii1.
    assumption.
  - apply ii2.
    use (hinhuniv _ x).
    intro u.
    destruct u as [ k u ].
    unfold hzdiv0 in u.
    set ( cd := bezoutstrong a p ( isaprimetoneq0 is ) ).
    destruct cd as [ cd f ].
    destruct cd as [ c d ].
    rewrite j1 in f.
    simpl in f.
    assert ( b = ( b * c + d * k ) * p ) as g.
    { assert ( b = b * 1 ) as g0.
      { rewrite hzmultr1.
        apply idpath. }
      rewrite g0.
      rewrite ( ringrdistr hz ( b * 1 * c ) ( d * k ) p ).
      assert ( b * ( c * p + d * a ) =
               b * 1 * c * p + d * k * p ) as h.
      { rewrite ( ringldistr hz ( c * p ) ( d * a ) b ).
        rewrite hzmultr1.
        rewrite 2! ( @ringassoc2 hz ).
        rewrite ( @ringcomm2 hz k p ).
        change ( p * k )%hz with ( p * k )%ring in u.
        rewrite u.
        rewrite ( @ringcomm2 hz b ( d * a ) ).
        rewrite ( @ringassoc2 hz ).
        apply idpath.
      }
      rewrite <- h.
      rewrite f.
      apply idpath.
    }
    intros Q uu.
    apply uu.
    split with ( b * c + d * k ).
    rewrite ( @ringcomm2 hz _ p ) in g.
    unfold hzdiv0.
    apply pathsinv0.
    assumption.
Defined.

Lemma hzremaindermodprimeandtimes ( a b : hz )
  ( x : hzremaindermod p ( isaprimetoneq0 is ) ( a * b ) = 0 ) :
  hzremaindermod p ( isaprimetoneq0 is ) a = 0 ∨
  hzremaindermod p ( isaprimetoneq0 is ) b = 0.
Proof.
  intros.
  assert ( hzdiv p ( a * b ) ) as i.
  { intros P i'.
    apply i'.
    split with ( hzquotientmod p ( isaprimetoneq0 is ) ( a * b ) ).
    unfold hzdiv0.
    apply pathsinv0.
    rewrite <- ( hzplusr0 (p *
      hzquotientmod p (isaprimetoneq0 is) (a * b)%ring) )%hz.
    change (a * b =
           (p * hzquotientmod p (isaprimetoneq0 is) (a * b)%ring + 0)%ring).
    rewrite <- x.
    change (p * hzquotientmod p (isaprimetoneq0 is) (a * b) +
                hzremaindermod p (isaprimetoneq0 is) a * b) with
    (p * hzquotientmod p (isaprimetoneq0 is) (a * b)%ring +
       ( hzremaindermod p (isaprimetoneq0 is) a * b )%ring )%hz.
    apply ( hzdivequationmod p ( isaprimetoneq0 is ) ( a * b ) ).
  }
  use (hinhuniv _ ( primeandtimes a b i )).
  intro t.
  destruct t as [ t0 | t1 ].
  - use (hinhuniv _ t0).
    intros k.
    destruct k as [ k k' ].
    intros Q j.
    apply j.
    apply ii1.
    apply pathsinv0.
    apply ( hzqrtestr p ( isaprimetoneq0 is ) a k ).
    split.
    + rewrite hzplusr0.
      unfold hzdiv0 in k'.
      rewrite k'.
      apply idpath.
    + split.
      * apply isreflhzleh.
      * rewrite hzabsvalgth0.
        -- apply ( istranshzlth _ 1 _ ).
           ++ apply hzlthnsn.
           ++ apply is.
        -- apply ( istranshzlth _ 1 _ ).
           ++ apply hzlthnsn.
           ++ apply is.
  - use (hinhuniv _ t1).
    intros k.
    destruct k as [ k k' ].
    intros Q j.
    apply j.
    apply ii2.
    apply pathsinv0.
    apply ( hzqrtestr p ( isaprimetoneq0 is ) b k ).
    split.
    + rewrite hzplusr0.
      unfold hzdiv0 in k'.
      rewrite k'.
      apply idpath.
    + split.
      * apply isreflhzleh.
      * rewrite hzabsvalgth0.
        -- apply ( istranshzlth _ 1 _ ).
           ++ apply hzlthnsn.
           ++ apply is.
        -- apply ( istranshzlth _ 1 _ ).
           ++ apply hzlthnsn.
           ++ apply is.
Defined.

Definition padiczero := @ringunel1 commringofpadicints.

Definition padicone := @ringunel2 commringofpadicints.

Lemma padiczerocomputation :
  padiczero =
  setquotpr ( carryequiv p ( isaprimetoneq0 is ) )
            ( @ringunel1 ( fpscommring hz ) ).
Proof.
  intros.
  apply idpath.
Defined.

Lemma padiconecomputation :
  padicone =
  setquotpr ( carryequiv p ( isaprimetoneq0 is ) )
            ( @ringunel2 ( fpscommring hz ) ).
Proof.
  intros.
  apply idpath.
Defined.

Lemma padicintsareintdom ( a b : acommringofpadicints ) :
  a # 0 -> b # 0 -> a * b # 0.
Proof.
  assert ( forall a b : commringofpadicints,
     isaprop ( pr1 padicapart a padiczero ->
               pr1 padicapart b padiczero ->
               pr1 padicapart ( padictimes a b )
                                           padiczero ) ) as int.
  { intros.
    apply impred.
    intros.
    apply impred.
    intros.
    apply ( pr1 padicapart ).
  }
  revert a b.
  apply ( setquotuniv2prop _ ( fun x y =>
                                 make_hProp _ ( int x y ) ) ).
  intros a b.
  change (pr1 padicapart
              (setquotpr (carryequiv p (isaprimetoneq0 is)) a)
              padiczero ->
          pr1 padicapart
              (setquotpr (carryequiv p (isaprimetoneq0 is)) b)
              padiczero ->
          pr1 padicapart
              (padictimes
                  (setquotpr (carryequiv p (isaprimetoneq0 is)) a)
                  (setquotpr (carryequiv p (isaprimetoneq0 is)) b))
              padiczero).
  unfold padictimes.
  rewrite padiczerocomputation.
  rewrite setquotprandpadictimes.
  rewrite 3! padicapartcomputation.
  intros i j.
  use (hinhuniv _ i).
  intros i0.
  destruct i0 as [ i0 i1 ].
  use (hinhuniv _ j).
  intros j0.
  destruct j0 as [ j0 j1 ].
  rewrite carryandzero in i1, j1.
  change ( ( @ringunel1 ( fpscommring hz ) ) i0 ) with 0%hz in i1.
  change ( ( @ringunel1 ( fpscommring hz ) ) j0 ) with 0%hz in j1.
  set ( P := fun x : nat =>
               neq hz ( carry p ( isaprimetoneq0 is ) a x ) 0 ).
  set ( P' := fun x : nat =>
                neq hz ( carry p ( isaprimetoneq0 is ) b x ) 0 ).
  assert ( isdecnatprop P ) as isdec1.
  { intros m.
    destruct ( isdeceqhz ( carry p ( isaprimetoneq0 is ) a m ) 0%hz )
      as [ l | r ].
    - apply ii2.
      intro v.
      unfold P in v. unfold neq in v.
      apply v.
      assumption.
    - apply ii1.
      assumption.
  }
  assert ( isdecnatprop P' ) as isdec2.
  { intros m.
    destruct ( isdeceqhz ( carry p ( isaprimetoneq0 is ) b m ) 0%hz )
      as [ l | r ].
    - apply ii2.
      intro v.
      unfold P' in v. unfold neq in v.
      apply v.
      assumption.
    - apply ii1.
      assumption.
  }
  set ( le1 := leastelementprinciple i0 P isdec1 i1 ).
  set ( le2 := leastelementprinciple j0 P' isdec2 j1 ).
  use (hinhuniv _ le1).
  intro k.
  destruct k as [ k k' ].
  use (hinhuniv _ le2).
  intro o.
  destruct o as [ o o' ].
  apply total2tohexists.
  split with ( k + o )%nat.
  assert ( forall m : nat, natlth m k ->
    carry p ( isaprimetoneq0 is ) a m = 0%hz ) as one.
  { intros m m0.
    destruct ( isdeceqhz ( carry p ( isaprimetoneq0 is ) a m ) 0%hz )
      as [ left0 | right0 ].
    - assumption.
    - apply fromempty.
      apply ( ( pr2 k' ) m m0 ).
      assumption.
  }
  assert ( forall m : nat, natlth m o ->
    carry p ( isaprimetoneq0 is ) b m = 0%hz ) as two.
  { intros m m0.
    destruct ( isdeceqhz ( carry p ( isaprimetoneq0 is ) b m ) 0%hz )
      as [ left0 | right0 ].
    - assumption.
    - apply fromempty.
      apply ( ( pr2 o' ) m m0 ).
      assumption.
  }
  assert ( neq hz ( carry p ( isaprimetoneq0 is ) a k ) 0%hz ×
           forall m : nat, natlth m k ->
                 ( carry p ( isaprimetoneq0 is ) a m ) = 0%hz ) as three.
  { split.
    - apply k'.
    - assumption.
  }
  assert ( neq hz ( carry p ( isaprimetoneq0 is ) b o ) 0%hz ×
           forall m : nat, natlth m o ->
                 ( carry p ( isaprimetoneq0 is ) b m ) = 0%hz ) as four.
  { split.
    - apply o'.
    - assumption.
  }
  set ( f := hzfpstimesnonzero
               ( carry p ( isaprimetoneq0 is ) a ) k three o
               ( carry p ( isaprimetoneq0 is ) b ) four ).
  rewrite carryandzero.
  change ( ( @ringunel1 ( fpscommring hz ) ) ( k + o )%nat ) with 0%hz.
  rewrite carryandtimes.
  destruct k.
  - destruct o.
    + rewrite <- carryandtimes.
      intros v.
      change ( hzremaindermod p ( isaprimetoneq0 is )
                              ( a 0%nat * b 0%nat ) = 0%hz ) in v.
      assert hfalse.
      { use (hinhuniv _ ( hzremaindermodprimeandtimes
                                       ( a 0%nat ) ( b 0%nat ) v )).
        intros t.
        destruct t as [ t0 | t1 ].
        * unfold P in k'. unfold neq in k'.
          apply ( pr1 k' ).
          apply t0.
        * unfold P' in o'. unfold neq in o'.
          apply ( pr1 o' ).
          apply t1.
      }
      assumption.
    + intros v.
      unfold carry at 1 in v.
      change ( 0 + S o )%nat with ( S o ) in v.
      change ( hzremaindermod p
                ( isaprimetoneq0 is )
                  ( ( carry p ( isaprimetoneq0 is ) a *
                      carry p ( isaprimetoneq0 is ) b ) ( S o )
             + hzquotientmod p ( isaprimetoneq0 is )
                           ( precarry p ( isaprimetoneq0 is )
                                ( carry p ( isaprimetoneq0 is ) a *
                                  carry p ( isaprimetoneq0 is ) b ) o ) ) =
      0%hz ) in v.
      change ( 0 + S o )%nat with ( S o) in f.
      rewrite f in v.
      change ( carry p ( isaprimetoneq0 is ) a *
               carry p ( isaprimetoneq0 is ) b ) with
      ( fpstimes hz ( carry p ( isaprimetoneq0 is ) a )
                    ( carry p ( isaprimetoneq0 is ) b ) ) in v.
      rewrite ( precarryandzeromult a b 0%nat ( S o ) ) in v.
      * rewrite hzqrand0q in v.
        rewrite hzplusr0 in v.
        assert hfalse.
        { set (aux :=  hzremaindermodprimeandtimes
                         ( carry p ( isaprimetoneq0 is ) a 0%nat )
                         ( carry p ( isaprimetoneq0 is ) b ( S o ) ) v).
          use (hinhuniv _ aux).
          intros s.
          destruct s as [ l | r ].
          -- unfold P in k'. unfold neq in k'.
             apply k'.
             rewrite hzqrandcarryr.
             assumption.
          -- unfold P' in o'. unfold neq in o'.
             apply o'.
             rewrite hzqrandcarryr.
             assumption.
        }
        assumption.
      * apply one.
      * apply two.
      * apply natlthnsn.
  - intros v.
    unfold carry at 1 in v.
    change ( hzremaindermod p ( isaprimetoneq0 is )
              ( ( carry p ( isaprimetoneq0 is ) a *
                  carry p ( isaprimetoneq0 is ) b ) ( S k + o )%nat +
         hzquotientmod p ( isaprimetoneq0 is )
                       ( precarry p ( isaprimetoneq0 is )
                           ( carry p ( isaprimetoneq0 is ) a *
                             carry p ( isaprimetoneq0 is ) b ) ( k + o )%nat ) ) =
    0%hz ) in v.
    rewrite f in v.
    change ( carry p ( isaprimetoneq0 is ) a *
             carry p ( isaprimetoneq0 is ) b ) with
    ( fpstimes hz ( carry p ( isaprimetoneq0 is ) a )
                  ( carry p ( isaprimetoneq0 is ) b ) ) in v.
    rewrite ( precarryandzeromult a b ( S k ) o ) in v.
    + rewrite hzqrand0q in v.
      rewrite hzplusr0 in v.
      assert hfalse.
      { set (aux := hzremaindermodprimeandtimes
                      ( carry p ( isaprimetoneq0 is ) a ( S k ) )
                      ( carry p ( isaprimetoneq0 is ) b (o ) ) v).
        use (hinhuniv _ aux).
        intros s.
        destruct s as [ l | r ].
        * unfold P in k'. unfold neq in k'.
          apply k'.
          rewrite hzqrandcarryr.
          assumption.
        * unfold P' in o'. unfold neq in o'.
          apply o'.
          rewrite hzqrandcarryr.
          assumption.
      }
      assumption.
    + apply one.
    + apply two.
    + apply natlthnsn.
Defined.

Definition padicintegers : aintdom.
Proof.
  intros.
  split with acommringofpadicints.
  split.
  - change ( pr1 padicapart padicone padiczero ).
    rewrite padiczerocomputation.
    rewrite padiconecomputation.
    rewrite padicapartcomputation.
    apply total2tohexists.
    split with 0%nat.
    unfold carry.
    unfold precarry.
    rewrite hzqrand1r.
    rewrite hzqrand0r.
    apply isnonzerorighz.
  - apply padicintsareintdom.
Defined.

Definition padics : afld := afldfrac padicintegers.

End A.

Close Scope ring_scope.
(** END OF FILE*)


Require Export Setoid Coq.Classes.Morphisms.
Require Import EqDec Computable Util AutoIndTac.
Require Export CSet Containers.SetDecide.

Require Export MapBasics MapLookup MapLookupList MapAgreement MapInjectivity MapUpdate MapAgreeSet MapInverse MapComposition.

Lemma inverse_on_update_lookup_set {X} `{OrderedType X} {Y} `{OrderedType Y} (D:set X) (f:X->Y) g
   `{Proper _ (_eq ==> _eq) f}   x y
  : inverse_on D (f [x <- y]) (g [y <- x])
  -> y ∉ lookup_set f (D\{{x}}).
Proof.
  intros A B. eapply lookup_set_spec in B.
  destruct B as [z]; dcr. cset_tac'; eqs; intuition.
  specialize (A _ H2). lud; intuition. intuition.
Qed.

Lemma lookup_set_update_with_list_in_union {X} `{OrderedType X} {Y} `{OrderedType Y}
  Z Z' f D `{Proper _ (_eq ==> _eq) f}
  : lookup_set (update_with_list Z Z' f) D ⊆ lookup_set f D ∪ of_list Z'.
Proof.
  intros; hnf; intros. eapply lookup_set_spec in H2.
  destruct H2; dcr. decide (a ∈ of_list Z').
  cset_tac; eauto.
  rewrite H4 in n.
  eapply lookup_set_update_not_in_Z' in n. rewrite n in H4.
  eapply union_2. eapply lookup_set_spec; eauto.
  eauto.
Qed.

Lemma lookup_set_update_in_union {X} `{OrderedType X} {Y} `{OrderedType Y}
 f D x y `{Proper _ (_eq ==> _eq) f}
  : lookup_set (f[x <- y]) D ⊆ {y; lookup_set f (D \ singleton x)}.
Proof.
  hnf; intros. eapply lookup_set_spec in H2; destruct H2; dcr; eauto.
  lud.
  - cset_tac; eauto.
  - lset_tac.
Qed.

Lemma lookup_set_update_with_list_in_union_length {X} `{OrderedType X} {Y} `{OrderedType Y}
  Z Z' f D `{Proper _ (_eq ==> _eq) f}
  : length Z = length Z'
    -> lookup_set (update_with_list Z Z' f) D ⊆ (lookup_set f (D \ of_list Z)) ∪ of_list Z'.
Proof.
  intros; hnf; intros. eapply lookup_set_spec in H3.
  destruct H3; dcr. decide (a ∈ of_list Z').
  cset_tac; eauto.
  decide(x ∈ of_list Z).
  exfalso. rewrite H5 in n. eapply n.
  eapply update_with_list_lookup_in; eauto.
  erewrite update_with_list_no_update in H5; eauto.
  eapply union_2. eapply lookup_set_spec; eauto. eexists x.
  split; eauto. cset_tac; eauto. eauto.
Qed.

Lemma inverse_on_update_inverse {X} `{OrderedType X} {Y} `{OrderedType Y}
  D x y ϱ ϱ' `{Proper _ (_eq ==> _eq) ϱ}
  : inverse_on (D\{{x}}) ϱ ϱ'
    -> y ∉ lookup_set ϱ (D\{{x}})
    -> inverse_on D (ϱ [x <- y]) (ϱ' [y <- x]).
Proof.
  intros. hnf; intros.
  lud. exfalso. eapply H3; eauto. eapply lookup_set_spec; eauto.
  eexists x0; cset_tac; eauto.
  exfalso; eauto.
  eapply H2. cset_tac; eauto.
Qed.