Set Implicit Arguments.
Unset Strict Implicit.

Require Export tactics.

Module Axioms.
Require Import Arith.
Require Import List.

Parameter E : Type.

Notation E1 := (E -> E).
Notation E2 := (E -> E1).
Notation E3 := (E -> E2).
Notation E4 := (E -> E3).
Notation E5 := (E -> E4).
Notation E6 := (E -> E5).
(** thus for example E3 = E -> E -> E -> E **)

Fixpoint En (n : nat) : Type := match n with
  | 0 => E
  | S k => E -> En k
  end.

Notation EP := (E -> Prop).
Notation E2P := (E -> EP).
Notation E3P := (E -> E2P).
Notation E4P := (E -> E3P).

Fixpoint EnP (n : nat) := match n with
  | 0 => Prop
  | S k => E -> EnP k
  end.

Parameter inc : E -> E -> Prop.

Definition sub x y := forall a, inc a x -> inc a y.

Notation "a ∈ b" := (inc a b) (no associativity, at level 98).
Notation "a ∉ b" := (~ inc a b) (no associativity, at level 98).
Notation "a ⊂ b" := (sub a b) (no associativity, at level 98).

Lemma sub_refl : forall x, sub x x.
Proof.
ir;uhg;ir;am.
Qed.

Lemma sub_trans : forall x y, sub x y -> forall z, sub y z -> sub x z.
Proof.
ir;uhg;ir. ap H0;au.
Qed.

Axiom extensionality : forall x y, sub x y -> sub y x -> x=y.

(*** we also need extensionality for general product types ***)

(***) Axiom
        prod_extensionality :
          forall (x : Type) (y : x -> Type) (u v : forall a : x, y a),
          (forall a : x, u a = v a) -> u = v.

Lemma arrow_extensionality :
 forall (x y : Type) (u v : x -> y), (forall a : x, u a = v a) -> u = v.
Proof.
intros x y.
change
  (forall u v : forall a : x, (fun i : x => y) a,
   (forall a : x, u a = v a) -> u = v) in |- *.
intros. apply prod_extensionality. assumption.
Qed.

(*axiom of choice*)

Inductive nonemptyT (t : Type) : Prop :=
    nonemptyT_intro : t -> nonemptyT t.

(***) Parameter chooseT : forall (t : Type) (p : t -> Prop), nonemptyT t -> t.
(***) Axiom
        chooseT_pr :
          forall (t : Type) (p : t -> Prop) (ne : nonemptyT t),
          ex p -> p (chooseT p ne).

Axiom nonemptyE : nonemptyT E.

Definition choose : EP -> E.
ir. ap chooseT. exact X. exact nonemptyE.
Defined.

Lemma choose_pr : forall p, ex p -> p (choose p).
Proof.
ir. uf choose. ap chooseT_pr. am.
Qed.

(*** the following actually follow from the above as was shown in the
standard library but we write them as axioms for brevity **************)

(***) Axiom excluded_middle : forall P : Prop, ~ ~ P -> P.
(***) Axiom proof_irrelevance : forall (P : Prop) (q p : P), p = q.

(*** the following axioms can be obtained from the Ensembles library but we include it here
as an axiom; it is used for convenience, allowing us to replace iff by equality so as to
be able to rewrite using equality of propositions **********************************)

(***) Axiom iff_eq : forall P Q : Prop, (P -> Q) -> (Q -> P) -> P = Q.

(*by_cases*)

Lemma p_or_not_p : forall P : Prop, P \/ ~ P.
Proof.
ir.
eapply excluded_middle.
unfold not in |- *.
ir.
assert P; ap excluded_middle; unfold not in |- * ; au.
Qed.

Definition by_cases_pr (T : Type) (P : Prop) (a : P -> T)
  (b : ~ P -> T) (x : T) :=
  and (forall p : P, a p = x) (forall q : ~ P, b q = x).

Lemma by_cases_exists :
 forall (T : Type) (P : Prop) (a : P -> T) (b : ~ P -> T),
 exists x : T, by_cases_pr a b x.
Proof.
ir. assert (P \/ ~ P). ap p_or_not_p. nin H.
eapply ex_intro with (a H). unfold by_cases_pr in |- *. xd.
ir. assert (H = p). ap proof_irrelevance. rewrite H0. tv.
ir. pose (q H). elim f.
eapply ex_intro with (b H). unfold by_cases_pr in |- *. xd.
ir. pose (H p). elim f.
ir. assert (H = q). ap proof_irrelevance. rewrite H0. tv.
Qed.

Lemma by_cases_nonempty :
 forall (T : Type) (P : Prop) (a : P -> T) (b : ~ P -> T), nonemptyT T.
Proof.
ir.
ir. assert (P \/ ~ P). ap p_or_not_p. nin H.
eapply nonemptyT_intro. exact (a H).
eapply nonemptyT_intro. exact (b H).
Qed.

Definition by_cases (T : Type) (P : Prop) (a : P -> T)
  (b : ~ P -> T) :=
  chooseT (fun x : T => by_cases_pr a b x) (by_cases_nonempty a b).

Lemma by_cases_property :
 forall (T : Type) (P : Prop) (a : P -> T) (b : ~ P -> T),
 by_cases_pr a b (by_cases a b).
Proof.
ir.
cp (by_cases_exists a b).
cp (by_cases_nonempty a b).
cp (chooseT_pr H0 H).
unfold by_cases in |- *.
assert (by_cases_nonempty a b = H0).
ap proof_irrelevance.
rewrite H2.
am.
Qed.

Lemma by_cases_unique :
 forall (T : Type) (P : Prop) (a : P -> T) (b : ~ P -> T) (x : T),
 by_cases_pr a b x -> by_cases a b = x.
Proof.
ir.
cp (by_cases_property a b).
ir. assert (P \/ ~ P). ap p_or_not_p. nin H1.
unfold by_cases_pr in H.  unfold by_cases_pr in H0.  xd.
transitivity (a H1). sy. au. au.
unfold by_cases_pr in H.  unfold by_cases_pr in H0.  xd.
transitivity (b H1). sy. au. au.
Qed.

Lemma by_cases_if :
 forall (T : Type) (P : Prop) (a : P -> T) (b : ~ P -> T) (p : P),
 by_cases a b = a p.
Proof.
ir. eapply by_cases_unique.
unfold by_cases_pr in |- *. xd.
ir. assert (p = p0). ap proof_irrelevance. rewrite H. tv.
ir. cp (q p). elim H.
Qed.

Lemma by_cases_if_not :
 forall (T : Type) (P : Prop) (a : P -> T) (b : ~ P -> T) (q : ~ P),
 by_cases a b = b q.
Proof.
ir. eapply by_cases_unique.
unfold by_cases_pr in |- *. xd.
ir.
cp (q p). elim H.
ir. assert (q = q0). ap proof_irrelevance. rewrite H. tv.
Qed.

(*Paire*)

Parameter doubleton : E2.

Axiom doubleton_pr : forall a b x, inc x (doubleton a b) = (x=a \/ x=b).

Lemma doubleton_or : forall a b x, inc x (doubleton a b) -> x=a\/x=b.
Proof.
ir. wr doubleton_pr. am.
Qed.

Lemma doubleton_inc : forall a b x, (x = a \/ x = b) -> inc x (doubleton a b).
Proof.
ir. rw doubleton_pr. am.
Qed.

Lemma doubleton_l : forall a b, inc a (doubleton a b).
Proof.
ir. rw doubleton_pr;au.
Qed.

Lemma doubleton_r : forall a b, inc b (doubleton a b).
Proof.
ir;rw doubleton_pr;au.
Qed.

Definition singleton a := doubleton a a.

Lemma singleton_inc : forall a, inc a (singleton a).
Proof.
ir. ap doubleton_l.
Qed.

Lemma singleton_eq : forall a x, inc x (singleton a) -> x=a.
Proof.
ir.
apply doubleton_or in H. nin H;am.
Qed.

Lemma singleton_rw : forall a x, inc x (singleton a) = (x=a).
Proof.
ir;ap iff_eq.
ap singleton_eq.
ir;subst. ap singleton_inc.
Qed.

Lemma doubleton_comm : forall a b, doubleton a b = doubleton b a.
Proof.
ir. ap extensionality;uhg;ir.
apply doubleton_or in H;ap doubleton_inc. nin H;au.
apply doubleton_or in H;ap doubleton_inc. nin H;au.
Qed.

Lemma doubleton_eq : forall a b c d, (doubleton a b = doubleton c d) = ((a=c & b=d)\/(a=d & b=c)).
Proof.
ir;ap iff_eq;ir.
assert (inc c (doubleton a b)). rw H. ap doubleton_l.
apply doubleton_or in H0. nin H0;subst.
assert (inc d (doubleton a b)). rw H. ap doubleton_r.

apply doubleton_or in H0;nin H0;subst.
assert (inc b (doubleton a a)).
wr H. ap doubleton_r.
apply singleton_eq in H0. subst. au.
au.

assert (inc d (doubleton a b)).
rw H. ap doubleton_r. apply doubleton_or in H0;nin H0;subst;au.
left. ee. ap singleton_eq.
uf singleton. wr H. ap doubleton_l. tv.

nin H;ee;subst.
tv. ap doubleton_comm.
Qed.

Lemma singleton_inj : forall a b, singleton a = singleton b -> a=b.
Proof.
ir. ap singleton_eq. wr H. ap singleton_inc.
Qed.

Parameter Z :  E -> EP -> E.

Axiom Z_rw : forall a p x, inc x (Z a p) = (inc x a & p x).

Lemma Z_inc : forall a (p:EP) x, inc x a -> p x -> inc x (Z a p).
Proof.
ir. rw Z_rw. ee;am.
Qed.

Lemma Z_all : forall a p x, inc x (Z a p) -> (inc x a & p x).
Proof.
ir;wr Z_rw;am.
Qed.

Lemma Z_sub : forall a p, sub (Z a p) a.
Proof.
ir;uhg;ir. apply Z_all in H. am.
Qed.

Lemma Z_pr : forall a p x, inc x (Z a p) -> p x.
Proof.
ir;eapply Z_all. am.
Qed.

Ltac Ztac :=
  match goal with
  | id1:(inc ?X1 (Z _ _)) |- _ => apply Z_all in id1;nin id1
  |  |- (inc _ (Z _ _)) => ap Z_inc
  | _ => idtac
  end.

Lemma no_total_set : ~ exists x, forall y, inc y x.
Proof.
uhg;ir;nin H.
pose (z := Z x (fun y => ~ inc y y)).
assert (inc z z = ~ inc z z).
ap iff_eq;ir.
ufa z. Ztac. am.
ap Z_inc. ap H. am.

assert (~ inc z z).
uhg;ir. cp H1. rwi H0 H2. au.
ap H1. rw H0. am.
Qed.

Lemma always_other : forall x, exists y, ~ inc y x.
Proof.
ir;ap excluded_middle;uhg;ir.
ap no_total_set.
exists x. ir.
ap excluded_middle;uhg;ir.
ap H. exists y;am.
Qed.

Definition complement a b := Z a (fun x => ~ inc x b).

Lemma use_complement : forall a b x, inc x a -> ~ inc x (complement a b) -> inc x b.
Proof.
ir. ap excluded_middle;uhg;ir.
ap H0. ap Z_inc;am.
Qed.

Parameter union : E1.

Axiom union_rw : forall a x, inc x (union a) = (exists y, inc y a & inc x y).

Notation "⋃" := union.

Lemma union_inc : forall a x, (exists y, inc y a & inc x y) -> inc x (union a).
Proof.
ir;rw union_rw;am.
Qed.

Lemma union_ex : forall a x, inc x (union a) -> (exists y, inc y a & inc x y).
Proof.
ir;wr union_rw;am.
Qed.

Definition union2 a b := union (doubleton a b).

Lemma union2_or : forall a b x, inc x (union2 a b) -> (inc x a \/ inc x b).
Proof.
ir.
apply union_ex in H. nin H;ee. apply doubleton_or in H.
nin H;subst;au.
Qed.

Lemma union2_inc : forall a b x, (inc x a \/ inc x b) -> inc x (union2 a b).
Proof.
ir.
ap union_inc. nin H.
exists a;ee. ap doubleton_l. am.
exists b;ee. ap doubleton_r. am.
Qed.

Lemma union2_l : forall a b, sub a (union2 a b).
Proof.
uhg;ir. ap union_inc. exists a;ee. ap doubleton_l. am.
Qed.

Lemma union2_r : forall a b, sub b (union2 a b).
Proof.
uhg;ir;ap union_inc;exists b;ee;try am;ap doubleton_r.
Qed.

Lemma union2_rw : forall a b x, inc x (union2 a b) = (inc x a \/ inc x b).
Proof.
ir;ap iff_eq. ap union2_or. ap union2_inc.
Qed.

Definition tack_on a b := union2 a (singleton b).

Lemma tack_on_or : forall x y z : E, inc z (tack_on x y) ->
(inc z x \/ z = y).
Proof.
ir. ufi tack_on H. cp (union2_or H). nin H0.
Proof.
ap or_introl; am. ap or_intror. ap singleton_eq; am.
Qed.

Lemma tack_on_inc: forall x y z:E,
(inc z (tack_on x y) ) = (inc z x \/ z = y).
Proof.
ir. ap iff_eq. ir; ap tack_on_or. am. ir.
nin H. uf tack_on. ap union2_l. am.
uf tack_on. ap union2_r. rw H.
ap singleton_inc.
Qed.

Definition inter  : E -> E.
intros a.
ap Z. exact (union a).
ir. exact (forall x', inc x' a -> inc X x').
Defined.

Notation "⋂" := inter.

Definition emptyset : E.
exact (choose (fun x => forall y, ~ inc y x)).
Defined.

Notation "∅" := emptyset.

Lemma emptyset_empty : forall x, ~ inc x emptyset.
Proof.
uf emptyset. ap choose_pr.
destruct nonemptyE.
exists (complement X X).
ir. uhg;ir;ufa complement;Ztac.
au.
Qed.

Lemma emptyset_sub_all : forall x, sub emptyset x.
Proof.
ir;uhg;ir. apply emptyset_empty in H. elim H.
Qed.

Lemma empty_emptyset : forall x, (forall y, inc y x -> False) -> x = emptyset.
Proof.
ir;ap extensionality.
uhg;ir. elim (H a H0).
ap emptyset_sub_all.
Qed.

Lemma emptyset_sub_is : forall x, sub x emptyset -> x = emptyset.
Proof.
ir;ap extensionality. am. ap emptyset_sub_all.
Qed.

Lemma union_empty : union emptyset = emptyset.
Proof.
ap empty_emptyset. ir.
apply union_ex in H;nin H;ee. apply emptyset_empty with x;am.
Qed.

Definition nonempty x := exists y, inc y x.

Lemma nonempty_not_emptyset_rw : forall x, nonempty x = (x<> emptyset).
Proof.
uf nonempty. ir;ap iff_eq;ir.
uhg;ir;subst. nin H.
apply emptyset_empty in H. am.
ap excluded_middle;uhg;ir.
ap H. ap empty_emptyset. ir. ap H0. exists y;am.
Qed.

Lemma inter_empty : inter emptyset  = emptyset.
Proof.
ap emptyset_sub_is. eapply sub_trans. ap Z_sub.
rw union_empty. ap sub_refl.
Qed.

Lemma inter_rw : forall a, nonempty a -> forall x, inc x (inter a) = (forall y, inc y a -> inc x y).
Proof.
ir. uf inter.
ap iff_eq;ir.
apply Z_all in H0;nin H0.
apply union_ex in H0;nin H0;ee.
ap H2. am.

ap Z_inc. ap union_inc. nin H.
exists x0. ee. am. au.
am.
Qed.

Lemma inter_inc : forall a, nonempty a -> forall x, (forall y, inc y a -> inc x y) ->
inc x (inter a).
Proof.
ir;rw inter_rw. am. am.
Qed.

Lemma inter_all : forall a x, inc x (inter a) -> forall y, inc y a -> inc x y.
Proof.
ir.
apply Z_all in H. ee.
au.
Qed.

Definition inter2 a b := inter (doubleton a b).

Lemma inter2_rw : forall a b x, inc x (inter2 a b) = (inc x a & inc x b).
Proof.
ir. uf inter2. rw inter_rw.
ap iff_eq;ir.
ee;ap H. ap doubleton_l. ap doubleton_r.
apply doubleton_or in H0. nin H0;subst;am.
econstructor. ap doubleton_l.
Qed.

Lemma inter2_inc : forall a b x, inc x a -> inc x b -> inc x (inter2 a b).
Proof.
ir. rw inter2_rw. ee;am.
Qed.

Lemma inter2_and : forall a b x, inc x (inter2 a b) -> (inc x a & inc x b).
Proof.
ir. wr inter2_rw. am.
Qed.

Parameter powerset : E1.

Axiom powerset_rw : forall a x, inc x (powerset a) = sub x a.

Lemma powerset_sub : forall a x, inc x (powerset a) -> sub x a.
Proof.
ir. wr powerset_rw. am.
Qed.

Lemma powerset_inc : forall a x, sub x a -> inc x (powerset a).
Proof.
ir;rw powerset_rw;am.
Qed.

Lemma singleton_union : forall x, union (singleton x) = x.
Proof.
ir. ap extensionality;uhg;ir.
apply union_ex in H;nin H;ee. apply singleton_eq in H. subst. am.
ap union_inc. exists x. ee. ap singleton_inc. am.
Qed.

(*
Tuples
tuples are defined by a function create : list E -> E injective
a n-tuple is some x s.t. exists l, length l = n & x = create l
a pair is a 2-tuple
a relation is a set of pairs. for r relation, R r x y = inc (pair x y) r
a function is a functional relation
product a b = Im2 pair a b
then functions a -> b are subsets of product a b
if a is a tuple a1 ... an, we want pair (create (x1 ... xn)) y to be a tuple
then the function would be both a relation and a set of n+1-tuples
this makes defining morphisms later much easier :
 a morphism on a signature between 2 structures (= assignements for the structure)
is a function preserving relations, and therefore passes for the structure's functions

then we have:
0-tuple : [] -> emptyset
1-tuple : x -> ??
2-tuple : x y -> pair x y
forall n, n+1-tuple : (x)n y -> pair (x)n y

pair x y = pair (x)1 y
so 1-tuple = identity ? not possible :
      (x)1 = create [x] = x = create [x1 ; ... ; xn] even when x is n-tuple

maybe looking at product sets instead
() -> emptyset(or something)
(x) -> ??
(x*y) -> product x y = Im2 pair x y
(x1*...*xn*xn+1) -> product (x1...xn) xn+1
forall x ntuple y set, pair x y is n+1 tuple
(n>=1) n=0 -> no restr -> 1-tuple can be anything

so give up on full injectivity of create, only injective for same-length lists
*)

Definition adjoin a b := doubleton (singleton a) (doubleton a b).

Lemma adjoin_eq : forall a b c d, adjoin a b = adjoin c d -> (a=c & b=d).
Proof.
ir. ufi adjoin H;ufi singleton H.
repeat rwi doubleton_eq H.
nin H;ee;nin H;nin H0;ee;subst;au.
Qed.

Fixpoint create_tuple (l : list E) := match l with
  | nil => emptyset
  | x::nil => x
  | x::tl => adjoin (create_tuple tl) x
  end.

Lemma adjoin_nonempty : forall a b, nonempty (adjoin a b).
Proof.
ir. econstructor. ap doubleton_l.
Qed.

Lemma create_tuple_eq : forall l, l<>nil -> forall l',
length l = length l' -> create_tuple l = create_tuple l' -> l=l'.
Proof.
intros l Hl;nin l;ir;nin l';simpl in *;tv.
inversion H. inversion H.
inversion H;subst. clear H.
destruct l;destruct l'.
subst;tv.
inversion H2. inversion H2.
apply adjoin_eq in H0. ee.
subst. ap uneq. ap IHl. uhg;ir. inversion H0.
am.
am.
Qed.

Definition pair a b := create_tuple (b::a::nil).

Inductive is_pair : E -> Prop :=
  | pair_is_pair : forall a b, is_pair (pair a b).

Lemma pair_eq_l : forall a b c d, pair a b = pair c d -> a=c.
Proof.
ir. apply create_tuple_eq in H.
inversion H;au.
uhg;ir. inversion H0.
tv.
Qed.

Lemma pair_eq_r : forall a b c d, pair a b = pair c d -> b=d.
Proof.
ir. apply create_tuple_eq in H. inversion H;subst.
tv.
uhg;ir;inversion H0. tv.
Qed.

Lemma pair_eq : forall a b c d, pair a b = pair c d -> (a=c & b=d).
Proof.
ir. apply create_tuple_eq in H;inversion H;subst. au.
uhg;ir;inversion H0. tv.
Qed.

Lemma pair_adjoin_eq : pair=adjoin.
Proof.
reflexivity.
Qed.

Lemma tuple_pair_S : forall l, l<>nil -> forall x,
create_tuple (x::l) = pair (create_tuple l) x.
Proof.
ir. simpl. destruct l. nin H;tv.
tv.
Qed.

(*
To prove that we made the right decisions we need to define
arbitrary-arity relations, and how they are related to functions
see (some other file, not yet decided)
*)

Notation J := pair.

Definition unicity (T : Type) (p : T -> Prop) := (forall y, p y -> forall y', p y' -> y=y').

Definition is_functional (r:E2P) := forall x, ex (r x) & (unicity (r x)).

Parameter replacement : E2P -> E1.

Axiom replacement_rw : forall r, is_functional r ->
forall x y, inc y (replacement r x) = exists x0, inc x0 x & r x0 y.

Lemma replacement_pr : forall r, is_functional r ->
forall x y, inc y (replacement r x) <-> exists x0, inc x0 x & r x0 y.
Proof.
ir. rw replacement_rw;au. split;ir;am.
Qed.

Lemma replacement_ex : forall r, is_functional r ->
forall x y, inc y (replacement r x) -> exists x0, inc x0 x & r x0 y.
Proof.
intros r H x y;eapply replacement_pr;am.
Qed.

Lemma replacement_inc : forall r, is_functional r ->
forall x y, (exists x0, inc x0 x & r x0 y) ->
inc y (replacement r x).
Proof.
intros r H x y;ap replacement_pr. am.
Qed.

Definition unique_choose (p : EP) : E.
ap union.
ap replacement.
ir. ap p. ap X0.
exact (singleton emptyset).
Defined.

Lemma unique_choose_pr : forall p, ex p ->
(unicity p) ->
p (unique_choose p).
Proof.
ir.
uf unique_choose.
assert (is_functional (fun _ X0 : E => p X0)).
uhg;ir;ee;ir. nin H;econstructor;am.
au.
cp (replacement_pr H1 (singleton emptyset)).
simpl in H2.
assert (forall y, inc y (replacement (fun _ X0 : E => p X0) (singleton ∅)) <->
p y).
ir;split;ir. apply H2 in H3. nin H3;am.
ap H2. exists emptyset. ee. ap singleton_inc. am.
nin H.
eapply eq_ind.
ap H.
ap extensionality;uhg;ir.
ap union_inc. econstructor. ee.
ap H3. ap H. am.
apply union_ex in H4;nin H4;ee.
apply H3 in H4.
eapply eq_ind. am.
au.
Qed.

Definition pr1 x := unique_choose (fun a => exists b, x = pair a b).
Definition pr2 x := unique_choose (fun b => exists a, x = pair a b).

(*
Definition pr1 x := choose (fun a => exists b, x = pair a b).
Definition pr2 x := choose (fun b => exists a, x = pair a b).
*)

Notation P := pr1.
Notation Q := pr2.

Lemma pr1_pr : forall a b, pr1 (pair a b) = a.
Proof.
ir. assert (exists b', J a b = J (P (J a b)) b'). uf P. ap unique_choose_pr.
exists a;exists b;tv.
uhg;ir. nin H;nin H0. apply pair_eq in H;apply pair_eq in H0;ee;subst;tv.
nin H. apply pair_eq in H;ee;au.
Qed.

Lemma pr2_pr : forall a b, pr2 (pair a b) = b.
Proof.
ir. assert (exists a', J a b = J a' (Q (J a b))). uf Q. ap unique_choose_pr.
exists b;exists a;tv.
uhg;ir. nin H;nin H0. apply pair_eq in H;apply pair_eq in H0;ee;subst;tv.
nin H. apply pair_eq in H;ee;au.
Qed.

Ltac clpr := repeat (first [rw pr1_pr | rw pr2_pr]).

Ltac clpri H := repeat (first [rwi pr1_pr H | rwi pr2_pr H]).

Lemma pair_recov : forall x, is_pair x -> x = pair (P x) (Q x).
Proof.
ir. nin H.  clpr. tv.
Qed.

Definition Im f x := replacement (fun a b => b = f a) x.

Lemma Im_rw : forall f a y, inc y (Im f a) = (exists x, inc x a & y = f x).
Proof.
ir. uf Im. rw replacement_rw.
tv. uhg;ir;ee.
exists (f x);tv.
uhg;ir;subst;au.
Qed.

Lemma Im_inc : forall f a x, inc x a -> inc (f x) (Im f a).
Proof.
ir.
rw Im_rw. exists x;ee;au.
Qed.

Lemma Im_show_inc : forall f a y, (exists x, inc x a & y = f x) -> inc y (Im f a).
Proof.
ir. rw Im_rw. am.
Qed.

Lemma Im_ex : forall f a y, inc y (Im f a) -> exists x, inc x a & y = f x.
Proof.
ir. wr Im_rw. am.
Qed.
(*note: getting replacement from Im uses choice, but Im from replacement
doesn't*)

Definition Im2 (f : E2) (x y : E) := union (Im (fun a => Im (fun b => f a b) y) x).

Lemma Im2_rw : forall f x y z, inc z (Im2 f x y) = exists a, exists b, inc a x & inc b y & z = f a b.
Proof.
ir;ap iff_eq;ir.
apply union_ex in H. nin H. ee.
apply Im_ex in H;nin H. ee.
subst. apply Im_ex in H0;nin H0;ee. subst. exists x1;exists x0;ee;au.
nin H;nin H;ee;subst.
ap union_inc. econstructor. ee.
ap Im_inc. am. ap Im_inc. am.
Qed.

Lemma Im2_ex : forall f x y z, inc z (Im2 f x y) -> exists a, exists b, inc a x & inc b y & z=f a b.
Proof.
ir. wr Im2_rw. am.
Qed.

Lemma Im2_inc : forall f x y a b, inc a x -> inc b y -> inc (f a b) (Im2 f x y).
Proof.
ir. rw Im2_rw. exists a;exists b;ee;au.
Qed.

Lemma Im2_show_inc : forall f x y z, (exists a, exists b, inc a x & inc b y & z = f a b) ->
inc z (Im2 f x y).
Proof.
ir;rw Im2_rw;au.
Qed.

Definition product := Im2 pair.

Lemma product_pair_inc : forall a b x y, inc x a -> inc y b ->
inc (pair x y) (product a b).
Proof.
ap Im2_inc.
Qed.

Lemma product_pair_pr : forall a b x y, inc (pair x y) (product a b) ->
(inc x a & inc y b).
Proof.
ir. apply Im2_ex in H. nin H;nin H.
nin H;nin H0.
apply pair_eq in H1;ee;subst;am.
Qed.

Lemma product_inc : forall a b x, is_pair x -> inc (P x) a -> inc (Q x) b ->
inc x (product a b).
Proof.
ir. nin H. clpri H0. clpri H1.
ap product_pair_inc;am.
Qed.

Lemma product_pr : forall a b x, inc x (product a b) ->
(is_pair x & inc (P x) a & inc (Q x) b).
Proof.
ir.
apply Im2_ex in H. nin H;nin H.
ee; subst;clpr. ap pair_is_pair. am. am.
Qed.

Lemma product_rw : forall a b x, inc x (product a b) = (is_pair x & inc (P x) a & inc (Q x) b).
Proof.
ir;ap iff_eq.
ap product_pr.
ir;ap product_inc;am.
Qed.

Lemma product_pair_rw : forall a b x y, inc (J x y) (product a b) = (inc x a & inc y b).
Proof.
ir;ap iff_eq.
ap product_pair_pr.
ir;ap product_pair_inc;am.
Qed.

Lemma product_emptyset_r : forall x, product x emptyset = emptyset.
Proof.
ir;ap empty_emptyset;ir.
apply product_pr in H;ee. edestruct emptyset_empty;am.
Qed.

Lemma product_emptyset_l : forall x,  product emptyset x = emptyset.
Proof.
ir;ap empty_emptyset;ir.
apply product_pr in H;ee. edestruct emptyset_empty;am.
Qed.

(* some basic utility stuff *)
Lemma extensionality_rw : forall x y, (forall a, inc a x  = inc a y) -> x = y.
Proof.
ir;ap extensionality;uhg;ir;first [ rw H | wr H ];am.
Qed.

Lemma inter_sub : forall x y, inc y x -> sub (inter x) y.
Proof.
ir. uhg;ir. eapply inter_all. am. am.
Qed.

Definition rep x := choose (fun y => inc y x).

Lemma rep_inc : forall x, nonempty x -> inc (rep x) x.
Proof.
ir. uf rep. ap choose_pr. am.
Qed.

Lemma inter2_l : forall a b, sub (inter2 a b) a.
Proof.
uhg;ir. apply inter2_and in H;am.
Qed.

Lemma inter2_r : forall a b, sub (inter2 a b) b.
Proof.
uhg;ir;apply inter2_and in H;am.
Qed.

Lemma inter2_comm : forall a b, inter2 a b = inter2 b a.
Proof.
ir. uf inter2. rw doubleton_comm. tv.
Qed.

Lemma union2_comm : forall a b, union2 a b = union2 b a.
Proof.
ir. uf union2. rw doubleton_comm. tv.
Qed.

Parameter nNum : E.

Axiom emptyset_N : inc emptyset nNum.

Definition oS x := tack_on x x.

Lemma oS_inc : forall x y, inc y (oS x) = (inc y x \/ y=x).
Proof.
ir. uf oS. ap tack_on_inc.
Qed.

Axiom oS_nNum : forall n, inc n nNum -> inc (oS n) nNum.

Parameter nNum_rect : forall P : E -> Type,
       P emptyset -> (forall n : E, inc n nNum -> P n -> P (oS n)) -> forall n : E, inc n nNum -> P n.

Axiom nNum_rect_0 : forall (P : E -> Type) (H0 : P emptyset) IH, nNum_rect H0 IH emptyset_N = H0.

Axiom nNum_rect_S : forall (P : E -> Type) (H0 : P emptyset) IH n (Hn : inc n nNum), nNum_rect H0 IH (oS_nNum Hn) = IH n Hn (nNum_rect H0 IH Hn).

Lemma nNum_destruct : forall x, inc x nNum -> (x = emptyset \/ exists y, inc y nNum & x = oS y).
Proof.
ap nNum_rect.
au. ir.
right. eau.
Qed.

Lemma eq_dec : forall x y:E, {x=y} + {x<>y}.
Proof.
ir. apply by_cases with (x=y);ir.
left. am. right. am.
Qed.

Lemma eq_dec_if : forall x T (a b : T), (if eq_dec x x then a else b) = a.
Proof.
ir. destruct (eq_dec x x). tv. nin n;au.
Qed.

Lemma eq_dec_if_not : forall x y, x<>y -> forall T (a b : T), (if eq_dec x y then a else b) = b.
Proof.
ir. destruct (eq_dec x y). nin e;au. nin H;au.
tv.
Qed.

Lemma P_dec : forall P, {P}+{~P}.
Proof.
ir. apply by_cases with P;ir.
left. am. right. am.
Qed.

Lemma P_dec_if : forall P : Prop, P -> forall T (a b :T), (if P_dec P then a else b) = a.
Proof.
ir. nin (P_dec P).
tv. nin b0;am.
Qed.

Lemma P_dec_if_not : forall P, ~P -> forall T (a b : T), (if P_dec P then a else b) = b.
Proof.
ir. nin (P_dec P).
nin H;am. tv.
Qed.

Lemma Im_uneq : forall f g x, (forall y, inc y x -> f y = g y) -> Im f x = Im g x.
Proof.
ir;ap extensionality;uhg;ir.
apply Im_ex in H0;nin H0;ee;subst. ap Im_show_inc;exists x0;ee. am.
ap H;am.
apply Im_ex in H0;nin H0;ee;subst. ap Im_show_inc;exists x0;ee. am.
symmetry;ap H;am.
Qed.

Ltac Im_nin H := apply Im_ex in H;nin H;nin H.

Ltac Im_incw x := ap Im_show_inc;exists x.

Ltac union_nin H := apply union_ex in H;nin H;nin H.

Lemma sub_complement : forall a b c, sub b c -> sub (complement a c) (complement a b).
Proof.
uhg;ir. apply Z_all in H0;ee;ap Z_inc.
am. uhg;ir;au.
Qed.

Lemma Im_sub : forall f a b, sub a b -> sub (Im f a) (Im f b).
Proof.
ir. uhg;ir. Im_nin H0. subst. ap Im_inc;au.
Qed.

Lemma complement_complement_id : forall s x, sub x s -> complement s (complement s x) = x.
Proof.
ir. ap extensionality;uhg;ir.
apply Z_all in H0;ee. eapply use_complement. am. am.
ap Z_inc. au. uhg;ir. apply Z_all in H1;ee. au.
Qed.

Fixpoint nNat n := match n with
  | 0 => emptyset
  | S k => oS (nNat k)
  end.

Lemma nNat_nNum : forall n, inc (nNat n) nNum.
Proof.
nin n. ap emptyset_N.
simpl. ap oS_nNum. am.
Qed.

Lemma nNum_nNat : forall n, inc n nNum -> exists n', n = nNat n'.
Proof.
ap nNum_rect;ir.
exists 0. tv.
nin H0;subst.
exists (S x). tv.
Qed.

Definition nIm (f : nat -> E) := Im (fun n => f (chooseT (fun x => n = nNat x) (nonemptyT_intro 0))) nNum.

Lemma nNum_transitiveT : forall n, inc n nNum -> forall m, inc m n -> inc m nNum.
Proof.
ap (nNum_rect (P := fun n => forall m, inc m n -> inc m nNum));ir.
apply emptyset_empty in H;nin H.
rwi oS_inc H1;nin H1.
ap H0;am.
subst;am.
Qed.

Lemma oS_N_inj : forall n, inc n nNum -> forall n', oS n = oS n' -> n=n'.

Proof.
assert (forall n, inc n nNum -> forall n', inc n' nNum -> inc n n' -> sub n n').
intros n Hn. pose (p := fun n' => inc n n' -> sub n n').
assert (forall n', inc n' nNum -> p n');try am.
ap nNum_rect;uf p;ir.
edestruct emptyset_empty;am.
ufi oS H1. rwi tack_on_inc H1.
nin H1. apply sub_trans with n0. au.
uhg;ir;uf oS;rw tack_on_inc;au.
subst. uhg;ir;uf oS;rw tack_on_inc;au.

assert (forall n, inc n nNum -> inc n n -> False).
pose (p := fun n => inc n n -> False). assert (forall n, inc n nNum -> p n);try am.
ap nNum_rect;uf p;ir. eapply emptyset_empty;am.
ufi oS H2;rwi tack_on_inc H2;nin H2. apply H in H2.
ap H1. ap H2. rw tack_on_inc;au.
ap oS_nNum. am. am.
ap H1. wr H2. rw tack_on_inc. rw H2. au.

assert (forall n, inc n nNum -> forall n', inc n' nNum -> inc n n' -> inc n' n -> False).
ir.
apply H0 with n;au.
apply H with n';au.

intros n H2 n' H4.
assert (inc n' nNum).
eapply nNum_transitiveT. ap oS_nNum. am.
rw H4;rw oS_inc;au.
assert (inc (n) (oS n')).
wr H4. uf oS;rw tack_on_inc;au.
ufi oS H5;rwi tack_on_inc H5;nin H5;au.
assert (inc n' (oS n)). rw H4.
uf oS;rw tack_on_inc;au.
ufi oS H6;rwi tack_on_inc H6;nin H6;au.
ap False_rect. eauto.
Qed.

Lemma nNat_inj : forall n n', nNat n = nNat n' -> n=n'.
Proof.
intros n. nin n;ir.
destruct n'. tv.
simpl in H. edestruct emptyset_empty.
rw H. uf oS;rw tack_on_inc;right;au.
destruct n'.
simpl in*. edestruct emptyset_empty.
wr H. uf oS;rw tack_on_inc;au.
simpl in H.
apply oS_N_inj in H. ap uneq. au.
ap nNat_nNum.
Qed.

Lemma nIm_rw : forall f x, inc x (nIm f) = exists n, x = f n.
Proof.
ir. uf nIm. rw Im_rw. ap iff_eq;ir.
nin H;ee. subst. econstructor. reflexivity.
nin H. subst.
exists (nNat x0). ee. ap nNat_nNum.
ap uneq.
ap nNat_inj.
ap chooseT_pr. exists x0. tv.
Qed.

Lemma nIm_ex : forall f x, inc x (nIm f) -> exists n, x = f n.
Proof.
ir. wr nIm_rw. am.
Qed.

Lemma nIm_show_inc : forall f x, (exists n, x = f n) -> inc x (nIm f).
Proof.
ir;rw nIm_rw;am.
Qed.

Lemma nIm_inc : forall f n, inc (f n) (nIm f).
Proof.
ir;ap nIm_show_inc. exists n;tv.
Qed.

Lemma union_Im : forall f x y, inc y (union (Im f x)) = exists a, inc a x & inc y (f a).
Proof.
ir;ap iff_eq;ir.
union_nin H. Im_nin H;subst.
exists x1;ee;am.
nin H;ee. ap union_inc. exists (f x0);ee.
ap Im_inc. am. am.
Qed.

Lemma Im_emptyset : forall f, Im f emptyset = emptyset.
Proof.
ir. ap empty_emptyset;ir.
Im_nin H. eapply emptyset_empty;am.
Qed.

Definition nNum_rec (x0 : E) (Sf : E2) (x : E) := by_cases
(fun H : inc x nNum => nNum_rect (P := fun y => E) x0 (fun n Hn xn => Sf n xn)  H)
(fun _ : ~inc x nNum => x0).

Lemma nNum_rec_0 : forall x0 Sf, nNum_rec x0 Sf emptyset = x0.
Proof.
uf nNum_rec;ir.
erewrite by_cases_if.
rw nNum_rect_0. tv.
Qed.

Lemma nNum_rec_S : forall x0 Sf n, inc n nNum -> nNum_rec x0 Sf (oS n) =
Sf n (nNum_rec x0 Sf n).
Proof.
ir. uf nNum_rec. erewrite by_cases_if.
rw nNum_rect_S. erewrite by_cases_if. reflexivity.
Existential 1 := H.
Qed.

Definition nNum_repeat : E1 -> E -> E -> E.
intros f n x0.
ap nNum_rec. exact x0.
intros n' xn'.
ap f. exact xn'.
exact n.
Defined.

Lemma nNum_repeat_0 : forall f x0, nNum_repeat f emptyset x0 = x0.
Proof.
ir. uf nNum_repeat. rw nNum_rec_0. tv.
Qed.

Lemma nNum_repeat_S : forall f x0 n, inc n nNum -> nNum_repeat f (oS n) x0 =
f (nNum_repeat f n x0).
Proof.
ir. uf nNum_repeat. ap nNum_rec_S. am.
Qed.

Fixpoint nat_repeat (f : E1) (n : nat) (x0 : E) := match n with
  | 0 => x0
  | S k => f (nat_repeat f k x0)
  end.

Lemma union2_emptyset_l : forall x, union2 emptyset x = x.
Proof.
ir;ap extensionality;uhg;ir.
apply union2_or in H;nin H. edestruct emptyset_empty;am.
am.
ap union2_r. am.
Qed.

Lemma union2_emptyset_r : forall x, union2 x emptyset = x.
Proof.
ir. rw union2_comm. ap union2_emptyset_l.
Qed.

Lemma tack_on_Im : forall f x y, Im f (tack_on x y) = tack_on (Im f x) (f y).
Proof.
ir. ap extensionality_rw;ir.
rw Im_rw. rw tack_on_inc. rw Im_rw.
ap iff_eq;ir;nin H;ee;subst.
rwi tack_on_inc H;nin H;subst.
left. exists x0;ee;au.
au.
nin H;ee;subst. exists x0;ee;au.
rw tack_on_inc;au.
exists y;ee;au. rw tack_on_inc;au.
Qed.

Lemma tack_on_union : forall x y, union (tack_on x y) = union2 (union x) y.
Proof.
ir;ap extensionality;uhg;ir.
union_nin H. rwi tack_on_inc H. nin H.
ap union2_l. ap union_inc;econstructor;ee.
am. am.
subst. ap union2_r. am.
apply union2_or in H;ap union_inc.
rwi union_rw H.
nin H;try nin H;ee.
exists x0;ee. rw tack_on_inc;au. am.
exists y;ee;au. rw tack_on_inc;au.
Qed.

Lemma union2_tack_on_r : forall x y z, union2 x (tack_on y z) = tack_on (union2 x y) z.
Proof.
ir;ap extensionality_rw;ir. rw union2_rw.
rw tack_on_inc. rw tack_on_inc. rw union2_rw.
ap iff_eq;ap or_assoc.
Qed.

Lemma oS_sub : forall x, sub x (oS x).
Proof.
uhg;ir;rw oS_inc;au.
Qed.

Lemma not_empty_nonempty : forall x, x<>emptyset -> nonempty x.
Proof.
ir;ap excluded_middle;uhg;ir;ap H;ap empty_emptyset;ir.
ap H0;exists y;am.
Qed.

Lemma nonempty_not_empty : forall x, nonempty x -> x<>emptyset.
Proof.
uhg;ir. subst. nin H. eapply emptyset_empty;am.
Qed.

Notation "{ fx | x ∈ a }" := (Im (fun x => fx) a).

Lemma product_ex : forall a b x, inc x (product a b) -> exists xa, exists xb, x = J xa xb & inc xa a & inc xb b.
Proof.
ir. apply product_pr in H. ee. nin H.
clpri H0;clpri H1. exists a0;exists b0;ee;au.
Qed.

Ltac product_nin H := apply product_ex in H;nin H;nin H;ee.

Ltac emptyset_nin H := destruct (emptyset_empty H).

Ltac emptyset_auto := match goal with
  | id1:(inc _ emptyset) |- _ => emptyset_nin id1
  end.

End Axioms. Export Axioms.


(** *Formal Power Series *)

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

(** January 2011 *)

(** made compatible with the current UniMath library again by Benedikt Ahrens in 2014
    and by Ralph Matthes in 2017 *)

(** Imports *)

Require Import UniMath.PAdics.lemmas.
Require Import UniMath.Algebra.RigsAndRings.
Require Import UniMath.NumberSystems.Integers.

(** ** I. Summation in a commutative ring *)

Local Open Scope ring_scope.

Definition natsummation0 { R : commring } ( upper : nat ) ( f : nat -> R ) : R.
Proof.
  revert f.
  induction upper.
  - intros. exact ( f 0%nat ).
  - intros. exact ( IHupper f + f ( S upper ) ).
Defined.

Lemma natsummationpathsupperfixed { R : commring } { upper : nat }
  ( f f' : nat -> R ) ( p : forall x : nat, natleh x upper -> f x = f' x ):
  natsummation0 upper f = natsummation0 upper f'.
Proof.
  revert f f' p. induction upper.
  - intros f f' p. simpl. apply p. apply isreflnatleh.
  - intros. simpl.
    rewrite ( IHupper f f' ).
    + rewrite ( p ( S upper ) ).
      * apply idpath.
      * apply isreflnatleh.
    + intros x p'. apply p.
      apply ( istransnatleh(m := upper) ).
      * assumption.
      * apply natlthtoleh. apply natlthnsn.
Defined.

(* Here we consider summation of functions which are, in a fixed
interval, 0 for all but either the first or last value. *)

Lemma natsummationae0bottom { R : commring } { f : nat -> R }
  ( upper : nat ) ( p : forall x : nat, natlth 0 x -> f x = 0 ) :
  natsummation0 upper f = f 0%nat.
Proof.
  revert p. induction upper.
  - auto.
  - intro p.  simpl.
    rewrite IHupper.
    + rewrite ( p ( S upper ) ).
      * rewrite ( ringrunax1 R ).
        apply idpath.
      * apply ( natlehlthtrans _ upper _ ).
        -- apply natleh0n.
        -- apply natlthnsn.
    + assumption.
Defined.

Lemma natsummationae0top { R : commring } { f : nat -> R } ( upper : nat )
  ( p : forall x : nat, natlth x upper -> f x = 0 ) :
  natsummation0 upper f = f upper.
Proof.
  revert p. induction upper.
  - auto.
  - intro p.
    assert ( natsummation0 upper f = natsummation0 ( R := R ) upper ( fun x : nat => 0 ) ) as g.
    { apply natsummationpathsupperfixed.
      intros m q.
      apply p.
      exact ( natlehlthtrans m upper ( S upper ) q ( natlthnsn upper ) ).
    }
    simpl. rewrite g.
    assert ( natsummation0 ( R := R ) upper ( fun _ : nat => 0 ) = 0 ) as g'.
    { set ( g'' := fun x : nat => ringunel1 ( X := R ) ).
      assert ( forall x : nat, natlth 0 x -> g'' x = 0 ) as q0.
      { intros k pp. apply idpath. }
      exact ( natsummationae0bottom upper q0 ).
    }
    rewrite g'. rewrite ( ringlunax1 R ).
    apply idpath.
Defined.

Lemma natsummationshift0 { R : commring } ( upper : nat ) ( f : nat -> R ) :
  natsummation0 ( S upper ) f =
  ( natsummation0 upper ( fun x : nat => f ( S x ) ) + f 0%nat ).
Proof.
  revert f. induction upper.
  - intros f. simpl.
    set (H:=pr2 R). simpl in H.
    set (H1:=pr1 H).
    set (H2:=pr1 H1).
    set (H3:=pr1 H2).
    set (H4:=pr2 H3).
    simpl in H4.
    apply H4.
  - intros.
    change ( natsummation0 ( S upper ) f + f ( S ( S upper ) ) =
             ( natsummation0 upper ( fun x : nat => f ( S x ) ) + f ( S ( S upper ) ) + f 0%nat ) ).
    rewrite IHupper.
    rewrite 2! ( ringassoc1 R ).
    rewrite ( ringcomm1 R ( f 0%nat ) _ ).
    apply idpath.
Defined.

Lemma natsummationshift { R : commring } ( upper : nat ) ( f : nat -> R )
  { i : nat } ( p : natleh i upper ) :
  natsummation0 ( S upper ) f =
  natsummation0 upper ( funcomp ( natcoface i ) f ) + f i.
Proof.
  revert f i p. induction upper.
  - intros f i p.
    destruct i.
    + unfold natcoface. simpl.
      set (H:=pr2 R). simpl in H.
      set (H1:=pr1 H).
      set (H2:=pr1 H1).
      set (H3:=pr1 H2).
      set (H4:=pr2 H3).
      simpl in H4.
      apply H4.
    + apply fromempty.
      exact ( negnatlehsn0 i p ).
  - intros f i p. destruct i.
    + apply natsummationshift0.
    + destruct ( natlehchoice ( S i ) ( S upper ) p ) as [ h | k ].
      * change ( natsummation0 ( S upper ) f + f ( S ( S upper ) ) =
                 natsummation0 ( S upper ) ( funcomp ( natcoface ( S i ) ) f ) + f ( S i ) ).
        rewrite ( IHupper f ( S i ) ).
        -- simpl. unfold natcoface at 3.
           rewrite 2! ( ringassoc1 R ).
           rewrite ( ringcomm1 R _ ( f ( S i ) ) ).
           simpl.
           rewrite ( natgehimplnatgtbfalse i upper ).
           ++ apply idpath.
           ++ apply p.
        -- apply natlthsntoleh. assumption.
      * simpl.
        assert ( natsummation0 upper ( funcomp ( natcoface ( S i ) ) f ) =
                 natsummation0 upper f ) as h.
        { apply natsummationpathsupperfixed.
          intros m q. unfold natcoface.
          assert ( natlth m ( S i ) ) as q'.
          { apply ( natlehlthtrans _ upper ).
            -- assumption.
            -- rewrite k. apply natlthnsn.
          }
          unfold natlth in q'.
          unfold funcomp. rewrite q'. apply idpath.
        }
        rewrite <- h. unfold natcoface at 3. simpl.
        rewrite ( natgehimplnatgtbfalse i upper ).
        -- rewrite 2! ( ringassoc1 R ).
           rewrite ( ringcomm1 R ( f ( S ( S upper ) ) ) ).
           rewrite k. apply idpath.
        -- apply p.
Defined.

Lemma natsummationplusdistr { R : commring } ( upper : nat ) ( f g : nat -> R ) :
  natsummation0 upper ( fun x : nat => f x + g x ) =
  natsummation0 upper f + natsummation0 upper g.
Proof.
  revert f g. induction upper.
  - auto.
  - intros f g. simpl.
    rewrite <- ( ringassoc1 R _ ( natsummation0 upper g ) _ ).
    rewrite ( ringassoc1 R ( natsummation0 upper f ) ).
    rewrite ( ringcomm1 R _ ( natsummation0 upper g ) ).
    rewrite <- ( ringassoc1 R ( natsummation0 upper f ) ).
    rewrite <- ( IHupper f g ).
    rewrite ( ringassoc1 R ).
    apply idpath.
Defined.

Lemma natsummationtimesdistr { R : commring } ( upper : nat ) ( f : nat -> R ) ( k : R ) :
  k * ( natsummation0 upper f ) = natsummation0 upper ( fun x : nat => k * f x ).
Proof.
  revert f k. induction upper.
  - auto.
  - intros f k. simpl.
    rewrite <- IHupper.
    rewrite <- ( ringldistr R ).
    apply idpath.
Defined.

Lemma natsummationtimesdistl { R : commring } ( upper : nat ) ( f : nat -> R ) ( k : R ) :
  natsummation0 upper f * k = natsummation0 upper ( fun x : nat => f x * k ).
Proof.
  revert f k. induction upper.
  - auto.
  - intros f k. simpl.
    rewrite <- IHupper.
    rewrite ( ringrdistr R ).
    apply idpath.
Defined.

Lemma natsummationsswapminus { R : commring } { upper n : nat } ( f : nat -> R )
  ( q : natleh n upper ) :
  natsummation0 ( S ( sub upper n ) ) f =
  natsummation0 ( sub ( S upper ) n ) f.
Proof.
  revert n f q. induction upper.
  - intros n f q. destruct n.
    + auto.
    + apply fromempty.
      exact ( negnatlehsn0 n q ).
  - intros n f q. destruct n.
    + auto.
    + change ( natsummation0 ( S ( sub upper n ) ) f =
               natsummation0 ( sub ( S upper ) n ) f ).
      apply IHupper.
      apply q.
Defined.

(** The following lemma asserts that
$\sum^{n}_{k=0}\sum^{k}_{l=0}f(l,k-l)=\sum^{n}_{k=0}\sum^{n-k}_{l=0}f(k,l)$
*)

Lemma natsummationswap { R : commring } ( upper : nat ) ( f : nat -> nat -> R ) :
  natsummation0 upper ( fun i : nat => natsummation0 i (fun j : nat => f j ( sub i j ) ) ) =
  natsummation0 upper ( fun k : nat => natsummation0 ( sub upper k ) ( fun l : nat => f k l ) ).
Proof.
  revert f. induction upper.
  - auto.
  - intros f.
    change ( natsummation0 upper (fun i : nat => natsummation0
  i (fun j : nat => f j ( sub i j ))) + natsummation0 ( S upper ) (
  fun j : nat => f j ( sub ( S upper ) j ) ) = natsummation0
  upper (fun k : nat => natsummation0 (S upper - k) (fun l : nat => f
  k l)) + natsummation0 ( sub ( S upper ) ( S upper ) ) ( fun l :
  nat => f ( S upper ) l ) ).
    change ( natsummation0 upper (fun i :
  nat => natsummation0 i (fun j : nat => f j ( sub i j))) + (
  natsummation0 upper ( fun j : nat => f j ( sub ( S upper ) j ) ) +
  f ( S upper ) ( sub ( S upper ) ( S upper ) ) ) = natsummation0
  upper (fun k : nat => natsummation0 (S upper - k) (fun l : nat => f
  k l)) + natsummation0 ( sub ( S upper ) ( S upper ) ) ( fun l :
  nat => f ( S upper ) l ) ).
  assert ( natsummation0 upper (fun k : nat => natsummation0 ( S (
  sub upper k ) ) (fun l : nat => f k l)) = natsummation0 upper
  (fun k : nat => natsummation0 (sub ( S upper ) k) (fun l : nat =>
  f k l)) ) as A.
  { apply natsummationpathsupperfixed.
    intros n q.
    apply natsummationsswapminus.
    exact q. }
  rewrite <- A.
  change ( fun k : nat => natsummation0 (S ( sub upper k)) (fun l : nat => f
  k l) ) with ( fun k : nat => natsummation0 ( sub upper k ) ( fun l
  : nat => f k l ) + f k ( S ( sub upper k ) ) ).
  rewrite ( natsummationplusdistr upper _ ( fun k : nat => f k ( S ( sub upper
                                                                      k ) ) ) ).
  rewrite IHupper.
  rewrite minusnn0.
  rewrite ( ringassoc1 R).
  assert ( natsummation0 upper ( fun j : nat => f j ( sub ( S
  upper ) j ) ) = natsummation0 upper ( fun k : nat => f k ( S (
  sub upper k ) ) ) ) as g.
  { apply natsummationpathsupperfixed.
    intros m q.
    rewrite pathssminus.
    + apply idpath.
    + apply ( natlehlthtrans _ upper ).
      * assumption.
      * apply natlthnsn.
  }
  rewrite g.
  apply idpath.
Defined.

(** * II. Reindexing along functions i : nat -> nat which are
automorphisms of the interval of summation.*)

Definition isnattruncauto ( upper : nat ) ( i : nat -> nat ) :=
  ( forall x : nat, natleh x upper ->
    ∑ (y : nat), natleh y upper ×
      ( i y = x  × forall z : nat, natleh z upper -> i z = x -> y = z ) ) ×
  forall x : nat, natleh x upper -> natleh ( i x ) upper.

Lemma nattruncautoisinj { upper : nat } { i : nat -> nat }
  ( p : isnattruncauto upper i ) { n m : nat } ( n' : natleh n upper )
  ( m' : natleh m upper ) :
  i n = i m -> n = m.
Proof.
  intros h.
  assert ( natleh ( i m ) upper ) as q.
  { apply (pr2 p). assumption. }
  set ( x := pr1 p ( i m ) q ).
  set ( v := pr1 x ).
  set ( w := pr1 ( pr2 x ) ).
  set ( y := pr1 ( pr2 ( pr2 x ) ) ).
  change ( pr1 x ) with v in w, y.
  assert ( v = n ) as a.
  { apply (pr2 (pr2 (pr2 x))).
    (*apply ( pr2 x).*)
    - assumption.
    - assumption.
  }
  rewrite <- a.
  apply (pr2 (pr2 ( pr2 x))).
  - assumption.
  - apply idpath.
Defined.

Definition nattruncautopreimage { upper : nat } { i : nat -> nat }
  ( p : isnattruncauto upper i ) { n : nat } ( n' : natleh n upper ) : nat :=
  pr1 ( pr1 p n n' ).

Definition nattruncautopreimagepath { upper : nat } { i : nat -> nat }
  ( p : isnattruncauto upper i ) { n : nat } ( n' : natleh n upper ) :
  i ( nattruncautopreimage p n' ) = n := pr1 ( pr2 ( pr2 ( pr1 p n n' ) ) ).

Definition nattruncautopreimageineq { upper : nat } { i : nat -> nat }
  ( p : isnattruncauto upper i ) { n : nat } ( n' : natleh n upper ) :
  natleh ( nattruncautopreimage p n' ) upper :=
  pr1 ( pr2 ( pr1 p n n' ) ).

Definition nattruncautopreimagecanon { upper : nat } { i : nat -> nat }
  ( p : isnattruncauto upper i ) { n : nat } ( n' : natleh n upper )
  { m : nat } ( m' : natleh m upper ) ( q : i m = n ) :
  nattruncautopreimage p n' = m := pr2 ( pr2 ( pr2 ( pr1 p n n' ) ) ) m m' q.

Definition nattruncautoinv { upper : nat } { i : nat -> nat }
  ( p : isnattruncauto upper i ) : nat -> nat.
Proof.
  intros n.
  destruct ( natgthorleh n upper ) as [ l | r ].
  - exact n.
  - exact ( nattruncautopreimage p r ).
Defined.

Lemma nattruncautoinvisnattruncauto { upper : nat } { i : nat -> nat }
  ( p : isnattruncauto upper i ) : isnattruncauto upper ( nattruncautoinv p ).
Proof.
  intros. split.
  - intros n n'. split with ( i n ). split.
    + apply (pr2 p). assumption.
    + split.
      * unfold nattruncautoinv.
        destruct ( natgthorleh ( i n ) upper ) as [ l | r ].
        -- apply fromempty.
           apply ( isirreflnatlth ( i n ) ).
           apply ( natlehlthtrans _ upper ).
           ++ apply (pr2 p). assumption.
           ++ assumption.
        -- apply ( nattruncautoisinj p ).
           ++ apply ( nattruncautopreimageineq ).
           ++ assumption.
           ++ apply ( nattruncautopreimagepath p r ).
      * intros m x v. unfold nattruncautoinv in v.
        destruct ( natgthorleh m upper ) as [ l | r ].
        -- apply fromempty.
           apply ( isirreflnatlth upper ).
           apply ( natlthlehtrans _ m ); assumption.
        -- rewrite <- v.
           apply ( nattruncautopreimagepath p r ).
  - intros x X. unfold nattruncautoinv.
    destruct ( natgthorleh x upper ) as [ l | r ].
    * assumption.
    * apply ( nattruncautopreimageineq p r ).
Defined.

Definition truncnattruncauto { upper : nat } { i : nat -> nat }
  ( p : isnattruncauto ( S upper ) i ) : nat -> nat.
Proof.
  intros n.
  destruct ( natlthorgeh ( i n ) ( S upper ) ) as [ l | r ].
  - exact ( i n ).
  - destruct ( natgehchoice _ _ r ) as [ a | b ].
    + exact ( i n ).
    + destruct ( isdeceqnat n ( S upper ) ) as [ h | k ].
      * exact ( i n ).
      * exact ( i ( S upper ) ).
Defined.

Lemma truncnattruncautobound { upper : nat } ( i : nat -> nat )
  ( p : isnattruncauto ( S upper ) i ) ( n : nat ) ( q : natleh n upper ) :
  natleh ( truncnattruncauto p n ) upper.
Proof.
  intros. unfold truncnattruncauto.
  destruct ( natlthorgeh ( i n ) ( S upper) ) as [ l | r ].
  - apply natlthsntoleh. assumption.
  - destruct ( natgehchoice ( i n ) ( S upper ) ) as [ l' | r' ].
    + apply fromempty.
      apply ( isirreflnatlth ( i n ) ).
      apply ( natlehlthtrans _ ( S upper ) ).
      * apply (pr2 p).
        apply natlthtoleh.
        apply ( natlehlthtrans _ upper ).
        -- assumption.
        -- apply natlthnsn.
      * assumption.
    + destruct ( isdeceqnat n ( S upper ) ) as [ l'' | r'' ].
      * apply fromempty.
        apply ( isirreflnatlth upper ).
        apply ( natlthlehtrans _ ( S upper ) ).
        -- apply natlthnsn.
        -- rewrite <- l''.
           assumption.
      * assert ( natleh ( i ( S upper ) ) ( S upper ) ) as aux.
        { apply (pr2 p). apply isreflnatleh. }
        destruct ( natlehchoice _ _ aux ) as [ l''' | r''' ].
        -- apply natlthsntoleh. assumption.
        -- apply fromempty.
           apply r''.
           apply ( nattruncautoisinj p ).
           ++ apply natlthtoleh.
              apply ( natlehlthtrans _ upper ).
              ** assumption.
              ** apply natlthnsn.
           ++ apply isreflnatleh.
           ++ rewrite r'. rewrite r'''. apply idpath.
Defined.

Lemma truncnattruncautoisinj { upper : nat } { i : nat -> nat }
  ( p : isnattruncauto ( S upper ) i ) { n m : nat }
  ( q : natleh n upper ) ( r : natleh m upper ) :
  truncnattruncauto p n = truncnattruncauto p m -> n = m.
Proof.
  intros s.
  apply ( nattruncautoisinj p ).
  - apply natlthtoleh.
    apply ( natlehlthtrans _ upper ).
    + assumption.
    + apply natlthnsn.
  - apply natlthtoleh.
    apply ( natlehlthtrans _ upper ).
    + assumption.
    + apply natlthnsn.
  - unfold truncnattruncauto in s.
    destruct ( natlthorgeh ( i n ) ( S upper ) ) as [ a0 | a1 ].
    + destruct ( natlthorgeh ( i m ) ( S upper ) ) as [ b0 | b1 ].
      * assumption.
      * apply fromempty.
        assert ( i m = S upper ) as f0.
        { destruct ( natgehchoice ( i m ) ( S upper ) b1 ) as [ l | l' ].
          -- apply fromempty.
             apply ( isirreflnatlth ( S upper ) ).
             apply ( natlehlthtrans _ ( i n ) ).
             ++ rewrite s. assumption.
             ++ assumption.
          -- assumption.
        }
        destruct (natgehchoice ( i m ) ( S upper ) b1 ) as [ a00 | a10 ].
        -- apply (isirreflnatgth ( S upper ) ).
           rewrite f0 in a00.
           assumption.
        -- destruct ( isdeceqnat m ( S upper ) ) as [ a000 | a100 ].
           ++ rewrite s in a0. rewrite f0 in a0.
              apply ( isirreflnatlth ( S upper ) ).
              assumption.
           ++ assert ( i m = n ) as f1.
              { apply ( nattruncautoisinj p ).
                ** rewrite f0.
                   apply isreflnatleh.
                ** apply natlthtoleh.
                   apply ( natlehlthtrans _ upper ).
                   --- assumption.
                   --- apply natlthnsn.
                ** rewrite f0. rewrite s. apply idpath.
              }
              apply ( isirreflnatlth upper ).
              apply ( natlthlehtrans _ n ).
              ** rewrite <- f1, f0.
                 apply natlthnsn.
              ** assumption.
    + destruct ( natgehchoice ( i n ) ( S upper ) a1 ) as [ a00 | a01 ].
      * apply fromempty.
        apply ( isirreflnatlth ( S upper ) ).
        apply ( natlthlehtrans _ ( i n ) ).
        -- assumption.
        -- apply ( pr2 p ).
           apply natlthtoleh.
           apply ( natlehlthtrans _ upper ).
           ++ assumption.
           ++ apply natlthnsn.
      * destruct ( natlthorgeh ( i m ) ( S upper ) ) as [ b0 | b1 ].
        -- destruct ( isdeceqnat n ( S upper ) ) as [ a000 | a001 ].
           ++ assumption.
           ++ assert ( S upper = m ) as f0.
              { apply ( nattruncautoisinj p ).
                ** apply isreflnatleh.
                ** apply natlthtoleh.
                   apply ( natlehlthtrans _ upper ).
                   --- assumption.
                   --- apply natlthnsn.
                ** assumption.
              }
              apply fromempty.
              apply a001. rewrite f0.
              apply fromempty.
              apply ( isirreflnatlth ( S upper ) ).
              apply ( natlehlthtrans _ upper ).
              ** rewrite f0. assumption.
              ** apply natlthnsn.
        -- destruct ( natgehchoice ( i m ) ( S upper ) b1 ) as [ b00 | b01 ].
           ++ apply fromempty.
              apply ( isirreflnatlth ( i m ) ).
              apply ( natlehlthtrans _ ( S upper ) ).
              ** apply (pr2 p).
                 apply ( natlthtoleh ).
                 apply ( natlehlthtrans _ upper ).
                 --- assumption.
                 --- apply natlthnsn.
              ** assumption.
           ++ rewrite b01. rewrite a01. apply idpath.
Defined.

Lemma truncnattruncautoisauto { upper : nat } { i : nat -> nat }
  ( p : isnattruncauto ( S upper ) i ) :
  isnattruncauto upper ( truncnattruncauto p ).
Proof.
  intros. split.
  - intros n q.
    assert ( natleh n ( S upper ) ) as q'.
    { apply natlthtoleh.
      apply ( natlehlthtrans _ upper ).
      + assumption.
      + apply natlthnsn.
    }
    destruct ( isdeceqnat ( nattruncautopreimage p q' ) ( S upper ) ) as [ i0 | i1 ].
    + split with ( nattruncautopreimage p ( isreflnatleh ( S upper ) ) ).
      split.
      * assert ( natleh ( nattruncautopreimage p ( isreflnatleh ( S upper ) ) )
                        ( S upper ) ) as aux by apply nattruncautopreimageineq.
        destruct ( natlehchoice _ _ aux ) as [ l | r ].
        -- apply natlthsntoleh.
           assumption.
        -- assert ( n = S upper ) as f0.
           { rewrite <- ( nattruncautopreimagepath p q' ).
             rewrite i0.
             rewrite <- r.
             rewrite ( nattruncautopreimagepath p ( isreflnatleh ( S upper) ) ).
             rewrite r.
             apply idpath.
           }
           apply fromempty.
           apply ( isirreflnatlth ( S upper ) ).
           apply ( natlehlthtrans _ upper ).
           ++ rewrite <- f0. assumption.
           ++ apply natlthnsn.
      * split.
        -- apply ( nattruncautoisinj p ).
           ++ apply natlthtoleh.
              apply ( natlehlthtrans _ upper ).
              ** apply truncnattruncautobound.
                 destruct ( natlehchoice _ _ ( nattruncautopreimageineq p
                                   ( isreflnatleh ( S upper ) ) ) ) as [ l | r].
                 --- apply natlthsntoleh. assumption.
                 --- apply fromempty.
                     assert ( S upper = n ) as f0.
                     { rewrite <- ( nattruncautopreimagepath p ( isreflnatleh ( S upper ) ) ).
                       rewrite r.
                       rewrite <- i0.
                       rewrite ( nattruncautopreimagepath p q' ).
                       apply idpath.
                     }
                     apply ( isirreflnatlth ( S upper ) ).
                     apply ( natlehlthtrans _ upper ).
                     +++ rewrite f0. assumption.
                     +++ apply natlthnsn.
              ** apply natlthnsn.
           ++ assumption.
           ++ unfold truncnattruncauto.
              destruct ( isdeceqnat ( nattruncautopreimage p
                               (isreflnatleh ( S upper ) ) ) ) as [ l | r ].
              ** apply fromempty.
                 assert ( S upper = n ) as f0.
                 { rewrite <- ( nattruncautopreimagepath p (isreflnatleh ( S upper ) ) ).
                   rewrite l.
                   rewrite <- i0.
                   rewrite ( nattruncautopreimagepath p q' ).
                   apply idpath.
                 }
                 apply ( isirreflnatlth ( S upper ) ).
                 apply ( natlehlthtrans _ upper ).
                 --- rewrite f0. assumption.
                 --- apply natlthnsn.
              ** destruct ( natlthorgeh ( i ( nattruncautopreimage p
                     ( isreflnatleh ( S upper ) ) ) ) ( S upper ) ) as [ l' | r' ].
                 --- apply fromempty.
                     apply ( isirreflnatlth ( S upper ) ).
                     rewrite ( nattruncautopreimagepath p ) in l'.
                     assumption.
                 --- destruct ( natgehchoice _ _ r' ) as [ l'' | r'' ].
                     +++ apply fromempty.
                         apply ( isirreflnatlth ( S upper ) ).
                         rewrite ( nattruncautopreimagepath p ) in l''.
                         assumption.
                     +++ rewrite <- i0.
                         rewrite ( nattruncautopreimagepath p q' ).
                         apply idpath.
        -- intros x X y.
           apply ( nattruncautoisinj p ).
           ++ apply nattruncautopreimageineq.
           ++ apply natlthtoleh.
              apply ( natlehlthtrans _ upper ).
              ** assumption.
              ** apply natlthnsn.
           ++ unfold truncnattruncauto in y.
              destruct ( natlthorgeh ( i x ) ( S upper ) ) as [ l | r ].
              ** assert ( S upper = x ) as f0.
                 { apply ( nattruncautoisinj p ).
                   --- apply isreflnatleh.
                   --- apply natlthtoleh.
                       apply ( natlehlthtrans _ upper ).
                       +++ assumption.
                       +++ apply natlthnsn.
                   --- rewrite <- i0.
                       rewrite y.
                       rewrite ( nattruncautopreimagepath p q' ).
                       apply idpath.
                 }
                 apply fromempty.
                 apply ( isirreflnatlth ( S upper ) ).
                 apply ( natlehlthtrans _ upper ).
                 --- rewrite f0. assumption.
                 --- apply natlthnsn.
               ** destruct ( isdeceqnat x ( S upper ) ) as [ l' | r' ].
                 --- apply fromempty.
                     apply ( isirreflnatlth ( S upper ) ).
                     apply ( natlehlthtrans _ upper ).
                     +++ rewrite <- l'. assumption.
                     +++ apply natlthnsn.
                 --- destruct ( natgehchoice _ _ r ) as [ l'' | r'' ].
                     +++ apply fromempty.
                         apply ( isirreflnatlth n ).
                         apply ( natlehlthtrans _ ( S upper ) ).
                         *** assumption.
                         *** rewrite <- y. assumption.
                     +++ rewrite ( nattruncautopreimagepath p _ ).
                         rewrite r''.
                         apply idpath.
    + split with ( nattruncautopreimage p q' ).
      split.
      * destruct ( natlehchoice _ _ ( nattruncautopreimageineq p q' ) ) as [ l | r ].
        -- apply natlthsntoleh. assumption.
        -- apply fromempty.
           apply i1.
           assumption.
      * split.
        -- unfold truncnattruncauto.
           destruct ( natlthorgeh ( i ( nattruncautopreimage p q' ) )
                                             ( S upper ) ) as [ l | r ].
           ++ apply nattruncautopreimagepath.
           ++ destruct ( natgehchoice _ _ r ) as [ l' | r' ].
              ** apply nattruncautopreimagepath.
              ** apply fromempty.
                 apply ( isirreflnatlth ( S upper ) ).
                 apply ( natlehlthtrans _ upper ).
                 --- rewrite <- r'.
                     rewrite ( nattruncautopreimagepath p q' ).
                     assumption.
                 --- apply natlthnsn.
        -- intros x X y. apply ( nattruncautoisinj p ).
           ++ set (H:=pr1 p). simpl in H.
              set (H1:=pr2 p). simpl in H1.
              set (H2:=H n q').
              apply (pr2 H2).
              (* apply ( pr1 p ). *)
           ++ apply natlthtoleh.
              apply ( natlehlthtrans _ upper ).
              ** assumption.
              ** apply natlthnsn.
           ++ rewrite ( nattruncautopreimagepath p q' ).
              unfold truncnattruncauto in y.
              destruct ( natlthorgeh ( i x ) ( S upper ) ) as [ l | r ].
              ** rewrite y. apply idpath.
              ** destruct ( isdeceqnat x ( S upper ) ) as [ l' | r' ].
                 --- apply fromempty.
                     apply ( isirreflnatlth ( S upper ) ).
                     apply ( natlehlthtrans _ upper ).
                     +++ rewrite <- l'. assumption.
                     +++ apply natlthnsn.
                 --- destruct ( natgehchoice _ _ r ).
                     +++ rewrite y. apply idpath.
                     +++ apply fromempty.
                         apply i1.
                         apply ( nattruncautoisinj p ).
                         *** apply ( nattruncautopreimageineq p ).
                         *** apply isreflnatleh.
                         *** rewrite ( nattruncautopreimagepath p q' ).
                             rewrite y.
                             apply idpath.
  - apply truncnattruncautobound.
Defined.

Definition truncnattruncautoinv { upper : nat } { i : nat -> nat }
  ( p : isnattruncauto ( S upper ) i ) : nat -> nat :=
  nattruncautoinv ( truncnattruncautoisauto p ).

Lemma precompwithnatcofaceisauto { upper : nat } ( i : nat -> nat )
  ( p : isnattruncauto ( S upper ) i )
  ( bound : natlth 0 ( nattruncautopreimage p ( isreflnatleh ( S upper ) ) ) ) :
  isnattruncauto upper (funcomp ( natcoface ( nattruncautopreimage p
                                       ( isreflnatleh ( S upper ) ) ) ) i ).
Proof.
  intros.
  set ( v := nattruncautopreimage p ( isreflnatleh ( S upper ) ) ).
  change ( nattruncautopreimage p ( isreflnatleh ( S upper ) ) ) with v in bound.
  unfold isnattruncauto.
  split.
  - intros m q.
    unfold funcomp.
    assert ( natleh m ( S upper ) ) as aaa.
    { apply natlthtoleh.
      apply natlehlthtrans with ( m := upper).
      + assumption.
      + exact ( natlthnsn upper ).
    }
    set ( m' := nattruncautopreimage p aaa ).
    destruct ( natlthorgeh m' v ) as [ l | r ].
    + (* CASE m' < v *) split with m'. split.
      * apply natlthsntoleh.
        apply ( natlthlehtrans _ v ).
        -- assumption.
        -- apply ( nattruncautopreimageineq p _ ).
      * split.
        -- unfold natcoface.
           rewrite l.
           apply ( nattruncautopreimagepath p aaa ).
        -- intros n j w.
           assert ( natcoface v n = m' ) as f0.
           { apply pathsinv0.
             apply ( nattruncautopreimagecanon p aaa ).
             ++ apply natcofaceleh. assumption.
             ++ assumption.
           }
           rewrite <- f0.
           destruct ( natgthorleh v n ) as [ l' | r' ].
           ++ unfold natcoface.
              rewrite l'.
              apply idpath.
           ++ apply fromempty.
              apply ( isirreflnatlth v ).
              apply ( natlehlthtrans _ n ).
              ** assumption.
              ** apply ( istransnatlth _ ( S n ) ).
                 { apply natlthnsn. }
                 unfold natcoface in f0.
                 rewrite ( natgehimplnatgtbfalse v n r' ) in f0.
                 rewrite f0.
                 assumption.
    + (* CASE v <= m' *) set ( j := nattruncautopreimagepath p aaa ).
      change ( nattruncautopreimage p aaa ) with m' in j.
      set ( m'' := sub m' 1 ).
      assert ( natleh m'' upper ) as a0.
      { destruct ( natlthorgeh 0 m' ) as [ h | h' ].
        * rewrite <- ( minussn1 upper ).
          apply minus1leh.
          -- assumption.
          -- apply ( natlehlthtrans _ upper ).
             ++ apply natleh0n.
             ++ apply natlthnsn.
          -- apply nattruncautopreimageineq.
        * destruct ( natgehchoice 0 m' h' ) as [ k | k' ].
          -- apply fromempty.
             apply ( negnatgth0n m' k ).
          -- unfold m''.
             rewrite <- k'.
             apply natleh0n.
      }
      destruct ( natgehchoice m' v r ) as [ l' | r' ].
      * assert ( natleh v m'' ) as a2.
        { apply natlthsntoleh.
          unfold m''.
          rewrite pathssminus.
          -- rewrite minussn1.
             assumption.
          -- destruct ( natlehchoice 0 m' ( natleh0n m' ) ) as [ k | k' ].
             ++ assumption.
             ++ apply fromempty.
                apply ( negnatgth0n v ).
                rewrite k'.
                assumption.
        }
        assert ( i ( natcoface v m'' ) = m ) as a1.
        { unfold natcoface.
          rewrite ( natgehimplnatgtbfalse v m'' a2 ).
          unfold m''.
          rewrite pathssminus.
          -- rewrite minussn1.
             assumption.
          -- destruct ( natlehchoice 0 m' ( natleh0n m' ) ) as [ k | k' ].
             ++ assumption.
             ++ apply fromempty.
                apply ( negnatgth0n v ).
                rewrite k'.
                assumption.
        }
        split with m''. split.
        -- assumption.
        -- split.
           ++ assumption.
           ++ intros n s t.
              assert ( natcoface v n = natcoface v m'' ) as g.
              { assert ( natcoface v n = m' ) as g0.
                { apply pathsinv0.
                  apply ( nattruncautopreimagecanon p aaa ).
                  ** apply natcofaceleh.
                     assumption.
                  ** assumption.
                }
                assert ( natcoface v m'' = m' ) as g1.
                { unfold m'.
                  unfold nattruncautopreimage.
                  apply pathsinv0.
                  apply ( nattruncautopreimagecanon p aaa ).
                  ** apply natcofaceleh. assumption.
                  ** assumption.
                }
                rewrite g0, g1.
                apply idpath.
              }
              change ( idfun _ m'' = idfun _ n ).
              rewrite <- ( natcofaceretractisretract v ).
              simpl.
              rewrite g.
              apply idpath.
      * apply fromempty.
        apply ( isirreflnatlth ( S upper ) ).
        apply ( natlehlthtrans _ upper ).
        -- assert ( S upper = m ) as g.
           { rewrite <- ( nattruncautopreimagepath p ( isreflnatleh ( S upper ) ) ).
             change ( i v = m ).
             rewrite <- j.
             rewrite r'.
             apply idpath.
           }
           rewrite g.
           assumption.
        -- apply natlthnsn.
  - intros x X.
    assert ( natleh ( i ( natcoface v x ) ) ( S upper ) ) as a0.
    { apply (pr2 p).
      apply natcofaceleh.
      assumption.
    }
    destruct ( natlehchoice _ _ a0 ) as [ l | r ].
    + apply natlthsntoleh.
      assumption.
    + assert ( v = natcoface v x ) as g.
      { unfold v.
        apply ( nattruncautopreimagecanon p ( isreflnatleh ( S upper ) ) ).
        * unfold natcoface.
          -- destruct ( natgthorleh v x ) as [ a | b ].
             ++ unfold v in a.
                rewrite a.
                apply natlthtoleh.
                apply ( natlehlthtrans _ upper ).
                ** assumption.
                ** apply natlthnsn.
             ++ unfold v in b.
                rewrite ( natgehimplnatgtbfalse _ x b ).
                assumption.
        * assumption.
      }
      apply fromempty.
      destruct ( natgthorleh v x ) as [ a | b ].
      * unfold natcoface in g.
        rewrite a in g.
        apply ( isirreflnatlth x ).
        rewrite g in a.
        assumption.
      * unfold natcoface in g.
        rewrite ( natgehimplnatgtbfalse v x b ) in g.
        apply ( isirreflnatlth x ).
        apply ( natlthlehtrans _ ( S x ) ).
        -- apply natlthnsn.
        -- rewrite <- g.
           assumption.
Defined.

Lemma nattruncautocompstable { R : commring } { upper : nat }
  ( i j : nat -> nat ) ( p : isnattruncauto upper i ) ( p' : isnattruncauto upper j ) :
  isnattruncauto upper ( funcomp j i ).
Proof.
  intros.
  split.
  - intros n n'.
    split with ( nattruncautopreimage p' ( nattruncautopreimageineq p n' ) ).
    split.
    + apply ( nattruncautopreimageineq p' ).
    + split.
      * simpl.
        rewrite ( nattruncautopreimagepath p' _ ).
        rewrite ( nattruncautopreimagepath p _ ).
        apply idpath.
      * intros x X y.
        simpl in y.
        apply ( nattruncautoisinj p' ).
        -- apply nattruncautopreimageineq.
        -- assumption.
        -- apply ( nattruncautoisinj p ).
           ++ apply (pr2 p').
              apply nattruncautopreimageineq.
           ++ apply (pr2 p') . assumption.
           ++ rewrite ( nattruncautopreimagepath p' ).
              rewrite ( nattruncautopreimagepath p ).
              rewrite y.
              apply idpath.
  - intros x X.
    apply (pr2 p).
    apply (pr2 p').
    assumption.
Defined.

Definition nattruncreverse ( upper : nat ) : nat -> nat.
Proof.
  intros n.
  destruct ( natgthorleh n upper ) as [ h | k ].
  - exact n.
  - exact ( sub upper n ).
Defined.

Definition nattruncbottomtopswap ( upper : nat ) : nat -> nat.
Proof.
  intros n.
  destruct ( isdeceqnat 0%nat n ) as [ h | k ].
  - exact upper.
  - destruct ( isdeceqnat upper n ) as [ l | r ].
    + exact ( 0%nat ).
    + exact n.
Defined.

Lemma nattruncreverseisnattruncauto ( upper : nat ) :
  isnattruncauto upper ( nattruncreverse upper ).
Proof.
  intros.
  unfold isnattruncauto.
  split.
  - intros m q.
    set ( m' := sub upper m ).
    assert ( natleh m' upper ) as a0 by apply minusleh.
    assert ( nattruncreverse upper m' = m ) as a1.
    { unfold nattruncreverse.
      + destruct ( natgthorleh m' upper ).
        * apply fromempty.
          apply isirreflnatlth with ( n := m' ).
          apply natlehlthtrans with ( m := upper ).
          -- assumption.
          -- assumption.
        * unfold m'.
          rewrite doubleminuslehpaths.
          -- apply idpath.
          -- assumption.
    }
    split with m'. split.
    + assumption.
    + split.
      * assumption.
      * intros n qq u.
        unfold m'.
        rewrite <- u.
        unfold nattruncreverse.
        destruct ( natgthorleh n upper ) as [ l | r ].
        -- apply fromempty.
           apply ( isirreflnatlth n ).
           apply ( natlehlthtrans _ upper ).
           ++ assumption.
           ++ assumption.
        -- rewrite doubleminuslehpaths.
           ++ apply idpath.
           ++ assumption.
  - intros x X.
    unfold nattruncreverse.
    destruct ( natgthorleh x upper ) as [ l | r ].
    + assumption.
    + apply minusleh.
Defined.

Lemma nattruncbottomtopswapselfinv ( upper n : nat ) :
  nattruncbottomtopswap upper ( nattruncbottomtopswap upper n ) = n.
Proof.
  intros.
  unfold nattruncbottomtopswap.
  destruct ( isdeceqnat upper n ) as [ i | e ].
  - destruct ( isdeceqnat 0%nat n ) as [i0 | _ ].
    + destruct ( isdeceqnat 0%nat upper ) as [ i1 | e1 ].
      * rewrite <- i0. rewrite <- i1. apply idpath.
      * apply fromempty.
        apply e1.
        rewrite i.
        rewrite i0.
        apply idpath.
    + destruct ( isdeceqnat 0%nat 0%nat ) as [ _ | e1 ].
      * assumption.
      * apply fromempty.
        apply e1.
        auto.
  - destruct ( isdeceqnat 0%nat n ) as [i0 | e0 ].
    + destruct ( isdeceqnat 0%nat upper ) as [ i1 | _ ].
      * rewrite <- i0. rewrite i1. apply idpath.
      * destruct ( isdeceqnat upper upper ) as [ _ | e2 ].
        -- assumption.
        -- apply fromempty.
           apply e2.
           auto.
    + destruct ( isdeceqnat 0%nat n ) as [ i1 | _ ].
      * apply fromempty.
        apply e0.
        assumption.
      * destruct ( isdeceqnat upper n ) as [ i2 | _ ].
        -- apply fromempty.
           apply e.
           assumption.
        -- apply idpath.
Defined.

Lemma nattruncbottomtopswapbound ( upper n : nat ) ( p : natleh n upper ) :
  natleh (nattruncbottomtopswap upper n ) upper.
Proof.
  intros.
  unfold nattruncbottomtopswap.
  destruct (isdeceqnat 0%nat n).
  - auto. (* does not seem to do anything *)
    destruct ( isdeceqnat upper n ). (* logically not needed *)
    + apply isreflnatleh.
    + apply isreflnatleh.
  - destruct ( isdeceqnat upper n ).
    + apply natleh0n.
    + assumption.
Defined.

Lemma nattruncbottomtopswapisnattruncauto ( upper : nat ) :
  isnattruncauto upper ( nattruncbottomtopswap upper ).
Proof.
  intros.
  unfold isnattruncauto. split.
  - intros m p.
    set ( m' := nattruncbottomtopswap upper m ).
    assert ( natleh m' upper ) as a0.
    { apply nattruncbottomtopswapbound. assumption. }
    assert (nattruncbottomtopswap upper m' = m) as a1 by
          apply nattruncbottomtopswapselfinv.
    split with m'. split.
    + assumption.
    + split.
      * assumption.
      * intros k q u. unfold m'.
        rewrite <- u.
        rewrite nattruncbottomtopswapselfinv.
        apply idpath.
  - intros n p. apply nattruncbottomtopswapbound. assumption.
Defined.

Lemma isnattruncauto0S { upper : nat } { i : nat -> nat }
  ( p : isnattruncauto (S upper) i ) ( j : i 0%nat = S upper ) :
  isnattruncauto upper ( funcomp S i ).
Proof.
  intros.
  unfold isnattruncauto.
  split.
  - intros m q.
    set ( v := nattruncautopreimage p (natlthtoleh m (S upper)
               (natlehlthtrans m upper (S upper) q (natlthnsn upper)))).
    destruct ( isdeceqnat 0%nat v ) as [ i0 | i1 ].
    + apply fromempty.
      apply ( isirreflnatlth ( i 0%nat ) ).
      apply ( natlehlthtrans _ upper ).
      * rewrite i0.
        unfold v.
        rewrite nattruncautopreimagepath.
        assumption.
      * rewrite j.
        apply natlthnsn.
    + assert ( natlth 0 v ) as aux.
      { destruct ( natlehchoice _ _ ( natleh0n v ) ).
        * assumption.
        * apply fromempty.
          apply i1.
          assumption.
      }
      split with ( sub v 1 ).
      split.
      * rewrite <- ( minussn1 upper ).
        apply ( minus1leh aux ( natlehlthtrans _ _ _ ( natleh0n upper )
                ( natlthnsn upper ) ) ( nattruncautopreimageineq p
                 ( natlthtoleh m ( S upper ) ( natlehlthtrans m upper ( S upper ) q
                   ( natlthnsn upper ) ) ) ) ).
      * split.
        -- simpl.
           rewrite pathssminus.
           ++ rewrite minussn1.
              apply nattruncautopreimagepath.
           ++ assumption.
        -- intros n uu k.
           simpl in k.
           rewrite <- ( minussn1 n ).
           assert ( v = S n ) as f.
           { apply ( nattruncautopreimagecanon p _ ); assumption. }
           rewrite f.
           apply idpath.
  - intros x X.
    unfold funcomp.
    assert ( natleh ( i ( S x ) ) ( S upper ) ) as aux.
    + apply (pr2 p).
      assumption.
    + destruct ( natlehchoice _ _ aux ) as [ h | k ].
      * apply natlthsntoleh.
        assumption.
      * apply fromempty.
        assert ( 0%nat = S x ) as ii.
        { apply ( nattruncautoisinj p ).
          -- apply natleh0n.
          -- assumption.
          -- rewrite j.
             rewrite k.
             apply idpath.
        }
        apply ( isirreflnatlth ( S x ) ).
        apply ( natlehlthtrans _ x ).
        -- rewrite <- ii.
           apply natleh0n.
        -- apply natlthnsn.
Defined.

(* The following lemma says that we may reindex sums along
automorphisms of the interval over which the finite summation is being
taken. *)

Lemma natsummationreindexing { R : commring } { upper : nat }
  ( i : nat -> nat ) ( p : isnattruncauto upper i ) ( f : nat -> R ) :
  natsummation0 upper f = natsummation0 upper (funcomp i f ).
Proof.
  revert i p f.
  induction upper.
  - intros. simpl.
    assert ( 0%nat = i 0%nat ) as f0.
    { destruct ( natlehchoice ( i 0%nat ) 0%nat ( pr2 p 0%nat ( isreflnatleh 0%nat ) ) )
        as [ h | k ].
      + apply fromempty.
        exact ( negnatlthn0 ( i 0%nat ) h ).
      + rewrite k.
        apply idpath.
    }
    rewrite <- f0.
    apply idpath.
  - intros. simpl ( natsummation0 ( S upper ) f ).
    set ( j := nattruncautopreimagepath p ( isreflnatleh ( S upper ) ) ).
    set ( v := nattruncautopreimage p ( isreflnatleh ( S upper ) ) ).
    change ( nattruncautopreimage p ( isreflnatleh ( S upper ) ) ) with v in j.
    destruct ( natlehchoice 0%nat v ( natleh0n v ) ) as [ h | p0 ] .
    + set ( aaa := nattruncautopreimageineq p ( isreflnatleh ( S upper ) ) ).
      change ( nattruncautopreimage p ( isreflnatleh ( S upper ) ) ) with v in aaa.
      destruct ( natlehchoice v ( S upper ) aaa ) as [ l | r ].
      * rewrite ( IHupper ( funcomp ( natcoface v ) i ) ).
        -- change ( funcomp ( funcomp ( natcoface v ) i ) f ) with
               ( funcomp ( natcoface v ) ( funcomp i f ) ).
           assert ( f ( S upper ) = ( funcomp i f ) v ) as f0.
           { simpl. rewrite j. apply idpath. }
           rewrite f0.
           assert ( natleh v upper ) as aux.
           { apply natlthsntoleh. assumption. }
           rewrite ( natsummationshift upper ( funcomp i f ) aux ).
           apply idpath.
        -- apply precompwithnatcofaceisauto.
           assumption.
      *  rewrite ( IHupper ( funcomp ( natcoface v ) i ) ).
         -- assert ( natsummation0 upper ( funcomp ( funcomp ( natcoface v ) i) f ) =
                    natsummation0 upper ( funcomp i f ) ) as f0.
            { apply natsummationpathsupperfixed.
              intros x X. simpl. unfold natcoface.
              assert ( natlth x v ) as a0.
              { apply ( natlehlthtrans _ upper ).
                ++ assumption.
                ++ rewrite r.
                   apply natlthnsn.
              }
              rewrite a0.
              apply idpath.
            }
            rewrite f0.
            assert ( f ( S upper ) = funcomp i f ( S upper ) ) as f1.
            { simpl.
              rewrite <- r.
              rewrite j.
              rewrite <- r.
              apply idpath.
            }
            rewrite f1.
            apply idpath.
         -- apply precompwithnatcofaceisauto.
            assumption.
    + rewrite natsummationshift0.
      simpl.
      rewrite p0.
      rewrite j.
      assert ( i 0%nat = S upper ) as j'.
      { rewrite p0.
        rewrite j.
        apply idpath. }
      rewrite ( IHupper ( funcomp S i ) ( isnattruncauto0S p j' ) ).
      apply idpath.
Defined.

(** * III. Formal Power Series *)

Definition seqson ( A : UU ) := nat -> A.

Lemma seqsonisaset ( A : hSet ) : isaset ( seqson A ).
Proof.
  intros.
  unfold seqson.
  change ( isofhlevel 2 ( nat -> A ) ).
  apply impredfun.
  apply (pr2 A).
Defined.

Definition isasetfps ( R : commring ) : isaset ( seqson R ) :=
  seqsonisaset R.

Definition fps ( R : commring ) : hSet := make_hSet _ ( isasetfps R ).

Definition fpsplus ( R : commring ) : binop ( fps R ) :=
  fun v w n => ( ( v n ) + ( w n ) ).

Definition fpstimes ( R : commring ) : binop ( fps R ) :=
  fun s t n => natsummation0 n ( fun x : nat => s x * t ( sub n x ) ).

(* SOME TESTS OF THE SUMMATION AND FPSTIMES DEFINITIONS: *)

Local Definition test0 : seqson hz.
Proof.
  intro n.
  induction n.
  - exact 0.
  - exact ( nattohz ( S n ) ).
Defined.

(* Eval lazy in ( hzabsval ( natsummation0 1 test0 ) ). *)

Local Definition test1 : seqson hz.
Proof.
  intro n.
  induction n.
  - exact ( 1 + 1 ).
  - exact ( ( 1 + 1 ) * IHn ).
Defined.

(*
Eval lazy in ( hzabsval ( fpstimes hz test0 test1 0%nat ) ).

Eval lazy in ( hzabsval ( fpstimes hz test0 test1 1%nat ) ).

Eval lazy in ( hzabsval ( fpstimes hz test0 test1 2%nat ) ).

Eval lazy in ( hzabsval ( fpstimes hz test0 test1 3%nat ) ).

Eval lazy in ( hzabsval ( fpstimes hz test0 test1 4%nat ) ).
*)

Definition fpszero ( R : commring ) : fps R := fun n : nat => 0.

Definition fpsone ( R : commring ) : fps R.
Proof.
  intros. intro n.
  destruct n.
  - exact 1.
  - exact 0.
Defined.

Definition fpsminus ( R : commring ) : fps R -> fps R :=
  fun s n => - ( s n ).

Lemma ismonoidopfpsplus ( R : commring ) :
  ismonoidop ( fpsplus R ).
Proof.
  intros.
  unfold ismonoidop.
  split.
  - unfold isassoc.
    intros s t u.
    unfold fpsplus.
    (* This is a hack which should work immediately without such a workaround! *)
    change ( (fun n : nat => s n + t n + u n) = (fun n : nat => s n + (t n + u n)) ).
    apply funextfun.
    intro n.
    set ( H := pr2 R ).
    set ( H1 := pr1 H ).
    set ( H2 := pr1 H1 ).
    set ( H3 := pr1 H2 ).
    set ( H4 := pr1 H3 ).
    set ( H5 := pr1 H4 ).
    set ( H6 := pr1 H5 ).
    apply H6.
    (*  apply R. *)
  - unfold isunital.
    assert ( isunit ( fpsplus R ) ( fpszero R ) ) as a.
    { unfold isunit.
      split.
      + unfold islunit.
        intro s.
        unfold fpsplus.
        unfold fpszero.
        change ( (fun n : nat => 0 + s n) = s ).
        apply funextfun.
        intro n.
        apply ringlunax1.
      + unfold isrunit.
        intro s.
        unfold fpsplus.
        unfold fpszero.
        change ( (fun n : nat => s n + 0) = s ).
        apply funextfun.
        intro n.
        apply ringrunax1.
    }
    exact ( tpair ( fpszero R ) a ).
Defined.

Lemma isgropfpsplus ( R : commring ) : isgrop ( fpsplus R ).
Proof.
  intros.
  unfold isgrop.
  assert ( invstruct ( fpsplus R ) ( ismonoidopfpsplus R ) ) as a.
  { unfold invstruct.
    assert ( isinv (fpsplus R) (unel_is (ismonoidopfpsplus R)) ( fpsminus R ) ) as b.
    { unfold isinv.
      split.
      - unfold islinv.
        intro s.
        unfold fpsplus.
        unfold fpsminus.
        unfold unel_is.
        simpl.
        unfold fpszero.
        apply funextfun.
        intro n.
        exact ( ringlinvax1 R ( s n ) ).
      - unfold isrinv.
        intro s.
        unfold fpsplus.
        unfold fpsminus.
        unfold unel_is.
        simpl.
        unfold fpszero.
        apply funextfun.
        intro n.
        exact ( ringrinvax1 R ( s n ) ).
    }
    exact ( tpair ( fpsminus R ) b ).
  }
  exact ( tpair ( ismonoidopfpsplus R ) a ).
Defined.

Lemma iscommfpsplus ( R : commring ) : iscomm ( fpsplus R ).
Proof.
  intros.
  unfold iscomm.
  intros s t.
  unfold fpsplus.
  change ((fun n : nat => s n + t n) = (fun n : nat => t n + s n) ).
  apply funextfun.
  intro n.
  set (H1:= pr2 (pr1 (pr1 (pr1 (pr2 R))))).
  apply H1.
  (* apply R. *)
Defined.

Lemma isassocfpstimes ( R : commring ) : isassoc (fpstimes R).
Proof.
  intros.
  unfold isassoc.
  intros s t u.
  unfold fpstimes.
  assert ( (fun n : nat => natsummation0 n (fun x : nat =>
                        natsummation0 ( sub n x) (fun x0 : nat =>
                          s x * ( t x0 * u ( sub ( sub n x ) x0) )))) =
           (fun n : nat => natsummation0 n (fun x : nat =>
                          s x * natsummation0 ( sub n x) (fun x0 : nat =>
                                  t x0 * u ( sub ( sub n x ) x0)))) ) as A.
  { apply funextfun.
    intro n.
    apply natsummationpathsupperfixed.
    intros.
    rewrite natsummationtimesdistr.
    apply idpath.
  }
  rewrite <- A.
  assert ( (fun n : nat => natsummation0 n (fun x : nat =>
                        natsummation0 ( sub n x) (fun x0 : nat =>
                          s x * t x0 * u ( sub ( sub n x ) x0 )))) =
          (fun n : nat => natsummation0 n (fun x : nat =>
                             natsummation0 ( sub n x) (fun x0 : nat =>
                          s x * ( t x0 * u ( sub ( sub n x ) x0) )))) ) as B.
  { apply funextfun.
    intro n.
    apply maponpaths.
    apply funextfun.
    intro m.
    apply maponpaths.
    apply funextfun.
    intro x.
    apply R.
  }
  assert ( (fun n : nat => natsummation0 n (fun x : nat =>
                        natsummation0 x (fun x0 : nat =>
                          s x0 * t ( sub x x0 ) * u ( sub n x )))) =
           (fun n : nat => natsummation0 n (fun x : nat =>
                        natsummation0 ( sub n x) (fun x0 : nat =>
                          s x * t x0 * u ( sub ( sub n x ) x0 )))) ) as C.
  { apply funextfun.
    intro n.
    set ( f := fun x : nat => ( fun x0 : nat => s x * t x0 * u ( sub ( sub n x ) x0 ) ) ).
    assert ( natsummation0 n ( fun x : nat =>
              natsummation0 x ( fun x0 : nat => f x0 ( sub x x0 ) ) ) =
             natsummation0 n ( fun x : nat =>
              natsummation0 ( sub n x ) ( fun x0 : nat => f x x0 ) ) ) as D
    by apply natsummationswap.
    unfold f in D.
    assert ( natsummation0 n ( fun x : nat =>
               natsummation0 x ( fun x0 : nat =>
                 s x0 * t ( sub x x0 ) * u ( sub n x ) ) ) =
             natsummation0 n ( fun x : nat =>
               natsummation0 x ( fun x0 : nat =>
                 s x0 * t ( sub x x0 ) *
                   u ( sub ( sub n x0 ) ( sub x x0 ) ) ) ) ) as E.
    { apply natsummationpathsupperfixed.
      intros k p.
      apply natsummationpathsupperfixed.
      intros l q.
      rewrite ( natdoubleminus p q ).
      apply idpath.
    }
    rewrite E, D.
    apply idpath.
  }
  rewrite <- B. rewrite <- C.
  assert ( (fun n : nat => natsummation0 n (fun x : nat =>
              natsummation0 x (fun x0 : nat =>
                s x0 * t ( sub x x0)) * u ( sub n x))) =
           (fun n : nat => natsummation0 n (fun x : nat =>
              natsummation0 x (fun x0 : nat =>
                s x0 * t ( sub x x0) * u ( sub n x)))) ) as D.
  { apply funextfun.
    intro n.
    apply maponpaths.
    apply funextfun.
    intro m.
    apply natsummationtimesdistl.
  }
  rewrite <- D.
  apply idpath.
Defined.

Lemma natsummationandfpszero ( R : commring ) :
  forall m : nat, natsummation0 m ( fun x : nat => fpszero R x ) = @ringunel1 R.
Proof.
  intros m.
  induction m.
  - apply idpath.
  - simpl.
    rewrite IHm.
    rewrite ( ringlunax1 R ).
    apply idpath.
Defined.

Lemma ismonoidopfpstimes ( R : commring ) : ismonoidop ( fpstimes R ).
Proof.
  intros.
  unfold ismonoidop.
  split.
  - apply isassocfpstimes.
  - split with ( fpsone R).
    split.
    + intro s.
      unfold fpstimes.
      change ( ( fun n : nat => natsummation0 n ( fun x : nat =>
                   fpsone R x * s ( sub n x ) ) ) = s ).
      apply funextfun.
      intro n.
      destruct n.
      * simpl.
        rewrite ( ringlunax2 R ).
        apply idpath.
      * rewrite natsummationshift0.
        rewrite ( ringlunax2 R).
        rewrite minus0r.
        assert ( natsummation0 n ( fun x : nat =>
                   fpsone R ( S x ) * s ( sub n x ) ) =
                 natsummation0 n ( fun x : nat =>
                   fpszero R x ) ) as f.
        { apply natsummationpathsupperfixed.
          intros m m'.
          rewrite ( ringmult0x R ).
          apply idpath.
        }
        change ( natsummation0 n ( fun x : nat => fpsone R
                   ( S x ) * s ( sub n x ) ) + s ( S n ) = s ( S n ) ).
        rewrite f.
        rewrite natsummationandfpszero.
        apply ( ringlunax1 R ).
    + intros s.
      unfold fpstimes.
      change ( ( fun n : nat => natsummation0 n
                   ( fun x : nat => s x * fpsone R ( sub n x ) ) ) = s ).
      apply funextfun.
      intro n.
      destruct n.
      * simpl.
        rewrite ( ringrunax2 R ).
        apply idpath.
      * change ( natsummation0 n ( fun x : nat =>
          s x * fpsone R ( sub ( S n ) x ) ) + s ( S n ) * fpsone R ( sub n n ) =
          s ( S n ) ).
        rewrite minusnn0.
        rewrite ( ringrunax2 R ).
        assert ( natsummation0 n ( fun x : nat => s x * fpsone R ( sub ( S n ) x )) =
             ( natsummation0 n ( fun x : nat => fpszero R x ) ) ) as f.
        { apply natsummationpathsupperfixed.
          intros m m'.
          rewrite <- pathssminus.
          -- rewrite ( ringmultx0 R ).
             apply idpath.
          -- apply ( natlehlthtrans _ n ).
             ++ assumption.
             ++ apply natlthnsn.
        }
        rewrite f.
        rewrite natsummationandfpszero.
        apply ( ringlunax1 R ).
Defined.

Lemma iscommfpstimes ( R : commring ) ( s t : fps R ) :
  fpstimes R s t = fpstimes R t s.
Proof.
  intros.
  unfold fpstimes.
  change ( ( fun n : nat => natsummation0 n (fun x : nat => s x * t ( sub n x) ) ) =
           ( fun n : nat => natsummation0 n (fun x : nat => t x * s ( sub n x) ) ) ).
  apply funextfun.
  intro n.
  assert ( natsummation0 n ( fun x : nat => s x * t ( sub n x ) ) =
           natsummation0 n ( fun x : nat => t ( sub n x ) * s x ) ) as a0.
  { apply maponpaths.
    apply funextfun.
    intro m.
    apply R.
  }
  assert ( ( natsummation0 n ( fun x : nat => t ( sub n x ) * s x ) ) =
             natsummation0 n ( funcomp ( nattruncreverse n )
                         ( fun x : nat => t x * s ( sub n x ) ) ) ) as a1.
  { apply natsummationpathsupperfixed.
    intros m q.
    unfold funcomp.
    unfold nattruncreverse.
    destruct (natgthorleh m n ).
    - apply fromempty.
      apply isirreflnatlth with ( n := n ).
      apply natlthlehtrans with ( m := m ).
      + apply h.
      + assumption.
    - apply maponpaths.
      apply maponpaths.
      apply pathsinv0.
      apply doubleminuslehpaths.
      assumption.
  }
  assert ( natsummation0 n ( funcomp ( nattruncreverse n )
                                 ( fun x : nat => t x * s ( sub n x ) ) ) =
           natsummation0 n ( fun x : nat => t x * s ( sub n x ) ) ) as a2.
  { apply pathsinv0.
    apply natsummationreindexing.
    apply nattruncreverseisnattruncauto.
  }
  exact ( pathscomp0 a0 ( pathscomp0 a1 a2 ) ).
Defined.

Lemma isldistrfps ( R : commring ) ( s t u : fps R ) :
  fpstimes R s ( fpsplus R t u ) =
  fpsplus R ( fpstimes R s t ) ( fpstimes R s u ).
Proof.
  intros.
  unfold fpstimes.
  unfold fpsplus.
  change ((fun n : nat => natsummation0 n (fun x : nat =>
             s x * (t (sub n x) + u ( sub n x)))) =
          (fun n : nat => natsummation0 n (fun x : nat => s x * t (sub n x)) +
                     natsummation0 n (fun x : nat => s x * u (sub n x)))).
  apply funextfun.
  intro upper.
  assert ( natsummation0 upper ( fun x : nat =>
             s x * ( t ( sub upper x ) + u ( sub upper x ) ) ) =
           natsummation0 upper ( fun x : nat =>
             ( ( s x * t ( sub upper x ) ) +
               ( s x * u ( sub upper x ) ) ) ) ) as a0.
  { apply maponpaths.
    apply funextfun.
    intro n.
    apply R.
  }
  assert ( natsummation0 upper ( fun x : nat =>
               ( ( s x * t ( sub upper x ) ) +
                 ( s x * u ( sub upper x ) ) ) ) =
            natsummation0 upper ( fun x : nat => s x * t ( sub upper x ) ) +
            natsummation0 upper ( fun x : nat => s x * u ( sub upper x ) ) ) as a1
  by apply natsummationplusdistr.
  exact ( pathscomp0 a0 a1 ).
Defined.

Lemma isrdistrfps ( R : commring ) ( s t u : fps R ) :
  fpstimes R ( fpsplus R t u ) s =
  fpsplus R ( fpstimes R t s ) ( fpstimes R u s ).
Proof.
  intros.
  unfold fpstimes.
  unfold fpsplus.
  change ((fun n : nat => natsummation0 n (fun x : nat => (t x + u x) * s ( sub n x ))) =
          (fun n : nat => natsummation0 n (fun x : nat => t x * s ( sub n x ) ) +
                     natsummation0 n (fun x : nat => u x * s ( sub n x ) ) ) ).
  apply funextfun.
  intro upper.
  assert ( natsummation0 upper ( fun x : nat =>
             ( t x + u x ) * s ( sub upper x ) ) =
           natsummation0 upper ( fun x : nat =>
               ( t x * s ( sub upper x ) ) +
               ( u x * s ( sub upper x ) ) ) ) as a0.
  { apply maponpaths.
    apply funextfun.
    intro n.
    apply R.
  }
  assert ( natsummation0 upper ( fun x : nat =>
               ( ( t x * s ( sub upper x ) ) +
                 ( u x * s ( sub upper x ) ) ) ) =
           natsummation0 upper ( fun x : nat => t x * s ( sub upper x ) ) +
           natsummation0 upper ( fun x : nat => u x * s ( sub upper x ) ) ) as a1
  by apply natsummationplusdistr.
  exact ( pathscomp0 a0 a1 ).
Defined.

Definition fpsring ( R : commring ) :=
  make_setwith2binop ( make_hSet ( seqson R ) ( isasetfps R ) )
                    ( make_dirprod ( fpsplus R ) ( fpstimes R ) ).

Theorem fpsiscommring ( R : commring ) : iscommring ( fpsring R ).
Proof.
  unfold iscommring.
  unfold iscommringops.
  split.
  - unfold isringops.
    split.
    + split.
      * unfold isabgrop.
        -- split.
           ++ exact ( isgropfpsplus R ).
           ++ exact ( iscommfpsplus R ).
      * exact ( ismonoidopfpstimes R ).
    + unfold isdistr.
      * split.
        -- unfold isldistr.
           intros.
           apply ( isldistrfps R ).
        -- unfold isrdistr.
           intros.
           apply ( isrdistrfps R ).
  - unfold iscomm.
    intros.
    apply ( iscommfpstimes R ).
Defined.

Definition fpscommring ( R : commring ) : commring :=
  make_commring ( fpsring R ) ( fpsiscommring R ).

Definition fpsshift { R : commring } ( a : fpscommring R ) : fpscommring R :=
  fun n : nat => a ( S n ).

Lemma fpsshiftandmult { R : commring } ( a b : fpscommring R )
  ( p : b 0%nat = 0 ) :
  forall n : nat, ( a * b ) ( S n ) = ( a * ( fpsshift b ) ) n.
Proof.
  intros.
  induction n.
  - change ( a * b ) with ( fpstimes R a b ).
    change ( a * fpsshift b ) with ( fpstimes R a ( fpsshift b ) ).
    unfold fpstimes.
    unfold fpsshift.
    simpl.
    rewrite p.
    rewrite ( ringmultx0 R ).
    rewrite ( ringrunax1 R ).
    apply idpath.
  - change ( a * b ) with ( fpstimes R a b ).
    change ( a * fpsshift b ) with ( fpstimes R a ( fpsshift b ) ).
    unfold fpsshift.
    unfold fpstimes.
    change ( natsummation0 (S (S n)) (fun x : nat => a x * b (sub ( S (S n) ) x)) ) with
    ( natsummation0 ( S n ) ( fun x : nat =>
          a x * b ( sub ( S ( S n ) ) x ) ) +
          a ( S ( S n ) ) * b ( sub ( S ( S n ) ) ( S ( S n ) ) ) ).
    rewrite minusnn0.
    rewrite p.
    rewrite ( ringmultx0 R ).
    rewrite ringrunax1.
    apply natsummationpathsupperfixed.
    intros x j.
    apply maponpaths.
    apply maponpaths.
    rewrite pathssminus.
    + apply idpath.
    + apply ( natlehlthtrans _ ( S n ) _ ).
      * assumption.
      * apply natlthnsn.
Defined.

(** * IV. Apartness relation on formal power series *)

Lemma apartbinarysum0 ( R : acommring ) ( a b : R ) ( p : a + b # 0 ) :
  a # 0 ∨ b # 0.
Proof.
  intros. intros P s.
  use ( hinhuniv _ ( acommring_acotrans R ( a + b ) a 0 p ) ).
  intro k.
  destruct k as [ l | r ].
  - apply s.
    apply ii2.
    assert ( a + b # a ) as l' by apply l.
    assert ( ( a + b ) # ( a + 0 ) ) as l''.
    { rewrite ringrunax1.
      assumption. }
    apply ( pr1 ( acommring_aadd R ) a b 0 ).
    assumption.
  - apply s.
    apply ii1.
    assumption.
Defined.

Lemma apartnatsummation0 ( R : acommring ) ( upper : nat )
  ( f : nat -> R ) ( p : ( natsummation0 upper f ) # 0 ) :
  ∃ n : nat, natleh n upper × f n # 0.
Proof.
  revert f p. induction upper.
  - simpl.
    intros. intros P s.
    apply s.
    split with 0%nat.
    split.
    + apply idpath.
    + assumption.
  - intros. intros P s.
    simpl in p.
    use ( hinhuniv _ (apartbinarysum0 R _ _ p ) ).
    intro k.
    destruct k as [ l | r ].
    + use ( hinhuniv _ (IHupper f l ) ).
      intro k.
      destruct k as [ n ab ].
      destruct ab as [ a b ].
      apply s.
      split with n.
      split.
      * apply ( istransnatleh( m := upper ) ).
        -- assumption.
        -- apply natlthtoleh.
           apply natlthnsn.
      * assumption.
    + apply s.
      split with ( S upper ).
      split.
      * apply isreflnatleh.
      * assumption.
Defined.

Definition fpsapart0 ( R : acommring ) : hrel ( fpscommring R ) :=
  fun s t : fpscommring R => ∃ n : nat, s n # t n.

Definition fpsapart ( R : acommring ) : apart ( fpscommring R ).
Proof.
  intros.
  split with ( fpsapart0 R ).
  split.
  - intros s f.
    assert ( hfalse ) as i.
    { use (hinhuniv _ f).
      intro k.
      destruct k as [ n p ].
      apply (acommring_airrefl R ( s n ) p).
    }
    apply i.
  - split.
    + intros s t p P j.
      use (hinhuniv _ p).
      intro k.
      destruct k as [ n q ].
      apply j.
      split with n.
      apply ( acommring_asymm R ( s n ) ( t n ) q ).
    + intros s t u p P j.
      use (hinhuniv _ p).
      intro k.
      destruct k as [ n q ].
      use ( hinhuniv _ (acommring_acotrans R ( s n ) ( t n ) ( u n ) q ) ).
      intro l.
      destruct l as [ l | r ].
      * apply j.
        apply ii1.
        intros v V.
        apply V.
        split with n.
        assumption.
      * apply j.
        apply ii2.
        intros v V.
        apply V.
        split with n.
        assumption.
Defined.

Lemma fpsapartisbinopapartplusl ( R : acommring ) :
  isbinopapartl ( fpsapart R ) ( @op1 ( fpscommring R ) ).
Proof.
  intros. intros a b c p. intros P s.
  use (hinhuniv _ p).
  intro k.
  destruct k as [ n q ].
  apply s.
  change ( ( a + b ) n ) with ( ( a n ) + ( b n ) ) in q.
  change ( ( a + c ) n ) with ( ( a n ) + ( c n ) ) in q.
  split with n.
  apply ( pr1 ( acommring_aadd R ) ( a n ) ( b n ) ( c n ) q ).
Defined.

Lemma fpsapartisbinopapartplusr ( R : acommring ) :
  isbinopapartr ( fpsapart R ) ( @op1 ( fpscommring R ) ).
Proof.
  intros. intros a b c p.
  rewrite ( ringcomm1 ( fpscommring R ) ) in p.
  rewrite ( ringcomm1 ( fpscommring R ) c ) in p.
  apply ( fpsapartisbinopapartplusl _ a b c ).
  assumption.
Defined.

Lemma fpsapartisbinopapartmultl ( R : acommring ) :
  isbinopapartl ( fpsapart R ) ( @op2 ( fpsring R ) ).
Proof.
  intros. intros a b c p. intros P s.
  use (hinhuniv _ p).
  intro k.
  destruct k as [ n q ].
  change ( ( a * b ) n ) with
    ( natsummation0 n ( fun x : nat => a x * b ( sub n x ) ) ) in q.
  change ( ( a * c ) n ) with
    ( natsummation0 n ( fun x : nat => a x * c ( sub n x ) ) ) in q.
  assert ( natsummation0 n ( fun x : nat => ( a x * b ( sub n x ) -
                                         ( a x * c ( sub n x ) ) ) ) # 0 ) as q'.
  { assert ( natsummation0 n ( fun x : nat => ( a x * b ( sub n x ) ) ) -
             natsummation0 n ( fun x : nat => ( a x * c ( sub n x ) ) ) # 0 ) as q''.
    { apply aaminuszero. assumption. }
    assert ( (fun x : nat => a x * b (sub n x) - a x * c ( sub n x)) =
             (fun x : nat => a x * b ( sub n x) + ( - 1%ring ) *
                      ( a x * c ( sub n x)) ) ) as i.
    { apply funextfun.
      intro x.
      apply maponpaths.
      rewrite <- ( ringmultwithminus1 R ).
      apply idpath.
    }
    rewrite i.
    rewrite natsummationplusdistr.
    rewrite <- ( natsummationtimesdistr n ( fun x : nat => a x * c ( sub n x ) )
                                       ( - 1%ring ) ).
    rewrite ( ringmultwithminus1 R ).
    assumption.
  }
  use ( hinhuniv _ ( apartnatsummation0 R n _ q' ) ).
  intro k.
  destruct k as [ m g ].
  destruct g as [ g g' ].
  apply s.
  split with ( sub n m ).
  apply ( pr1 ( acommring_amult R ) ( a m )
              ( b ( sub n m ) ) ( c ( sub n m ) ) ).
  apply aminuszeroa.
  assumption.
Defined.

Lemma fpsapartisbinopapartmultr ( R : acommring ) :
  isbinopapartr ( fpsapart R ) ( @op2 ( fpsring R ) ).
Proof.
  intros. intros a b c p.
  rewrite ( ringcomm2 ( fpscommring R ) ) in p.
  rewrite ( ringcomm2 ( fpscommring R ) c ) in p.
  apply ( fpsapartisbinopapartmultl _ a b c ).
  assumption.
Defined.

Definition acommringfps ( R : acommring ) : acommring.
Proof.
  intros.
  split with ( fpscommring R ).
  split with ( fpsapart R ).
  split.
  - split.
    + apply ( fpsapartisbinopapartplusl R).
    + apply ( fpsapartisbinopapartplusr R ).
  - split.
    + apply ( fpsapartisbinopapartmultl R ).
    + apply ( fpsapartisbinopapartmultr R ).
Defined.

Definition isacommringapartdec ( R : acommring ) :=
  isapartdec ( pr1 ( pr2 R ) ).

Lemma leadingcoefficientapartdec ( R : aintdom ) ( a : fpscommring R )
  ( is : isacommringapartdec R ) ( p : a 0%nat # 0 ) :
  forall n : nat, forall b : fpscommring R, ( b n # 0 ) ->
      acommringapartrel ( acommringfps R ) ( a * b ) 0.
Proof.
  intros n.
  induction n.
  - intros b q. intros P s.
    apply s.
    split with 0%nat.
    change ( ( a * b ) 0%nat ) with ( ( a 0%nat ) * ( b 0%nat ) ).
    apply R; assumption.
  - intros b q.
    destruct ( is ( b 0%nat ) 0 ) as [ left | right ].
    + intros P s.
      apply s.
      split with 0%nat.
      change ( ( a * b ) 0%nat ) with ( ( a 0%nat ) * ( b 0%nat ) ).
      apply R; assumption.
    + assert ( acommringapartrel ( acommringfps R )
                                  ( a * ( fpsshift b ) ) 0 ) as j.
      { apply IHn.
        unfold fpsshift.
        assumption. }
      use (hinhuniv _ j).
      intro k.
      destruct k as [ k i ].
      intros P s.
      apply s.
      rewrite <- ( fpsshiftandmult a b right k ) in i.
      split with ( S k ).
      assumption.
Defined.

Lemma apartdecintdom0 ( R : aintdom ) ( is : isacommringapartdec R ) :
  forall n : nat, forall a b : fpscommring R, ( a n # 0 ) ->
      acommringapartrel ( acommringfps R ) b 0 ->
      acommringapartrel ( acommringfps R ) ( a * b ) 0.
Proof.
  intros n.
  induction n.
  - intros a b p q.
    use (hinhuniv _ q).
    intros k.
    destruct k as [ k k0 ].
    apply ( leadingcoefficientapartdec R a is p k ).
    assumption.
  - intros a b p q.
    destruct ( is ( a 0%nat ) 0 ) as [ left | right ].
    + use (hinhuniv _ q).
      intros k.
      destruct k as [ k k0 ].
      apply ( leadingcoefficientapartdec R a is left k ).
      assumption.
    + assert ( acommringapartrel ( acommringfps R ) ( ( fpsshift a ) * b ) 0 ) as i.
      { apply IHn.
        * unfold fpsshift.
          assumption.
        * assumption.
      }
      use (hinhuniv _ i).
      intros k.
      destruct k as [ k k0 ].
      intros P s.
      apply s.
      split with ( S k ).
      rewrite ringcomm2.
      rewrite fpsshiftandmult.
      * rewrite ringcomm2.
        assumption.
      * assumption.
Defined.

Theorem apartdectoisaintdomfps ( R : aintdom )
  ( is : isacommringapartdec R ) : aintdom.
Proof.
  revert is.
  split with ( acommringfps R ).
  split.
  - intros P s.
    apply s.
    split with 0%nat.
    change ( @ringunel1 ( fpscommring R ) 0%nat ) with ( @ringunel1 R ).
    change ( @ringunel2 R # ( @ringunel1 R ) ).
    apply R.
  - intros a b p q.
    use (hinhuniv _ p).
    intro n.
    destruct n as [ n n0 ].
    apply ( apartdecintdom0 R is n); assumption.
Defined.

Close Scope ring_scope.

(** END OF FILE *)