Require Import logic.
Require Import IZF.
Require Import Relation.
Require Import BaseMap.
Require Import Maps.
Require Import BOperation1.
Require Import BOperation2.
Require Import AddMultPower.

(*Preparation*)
Theorem NNIsSubCMonoid : In NN (SubCMonoid NNAdd_CMonoid).
Proof.
cut (In {NN ! PowersetHasOwn NN} (SubCMonoid NNAdd_CMonoid)).
 apply Arrow2Rewrite; hyperreflexivity.
unfold SubCMonoid.
apply SubIdenticalTheorem.
apply IsSubIdenticalTheorem.
split.
 apply IsSubBOperationTheorem.
 intros a b Ina Inb.
 cut (In (%NNAdd [a;b]) NN).
  apply Arrow2Rewrite.
  hyperreflexivity.
  hyperreflexivity.
 apply SetProp.
intros e IsIe'.
assert(IsIe : &&IsIdent NNAdd e).
 generalize IsIe'.
 apply RelRewriteL.
 hyperreflexivity.
assert(Eqe0 : e == (nat_to_NN 0)).
 apply (IsIdentEq NNAdd).
 apply IsIe.
 apply NN0IsIdent.
rewrite Eqe0.
rewrite (DSETEq NN _).
apply (SetProp).
Qed.

Definition NNSubCMonoid := {NN ! NNIsSubCMonoid}.

Theorem NN_NNSubCMonoid : Subset NN NNSubCMonoid.
Proof.
apply ReflexivitySubset2.
hyperreflexivity.
Qed.

Theorem NNSubCMonoid_NN : Subset NN NNSubCMonoid.
Proof.
apply ReflexivitySubset2.
hyperreflexivity.
Qed.

Definition ZZ := FractionCMonoidSet NNAdd_CMonoid NNSubCMonoid.

Definition NNNN_to_ZZ : #(Map (Cartesian NN NN) ZZ) :=
%CombineMap' [%DoubleMap [IdMap ; EmbedMap NN_NNSubCMonoid] ; to_FractionCMonoidSet NNAdd_CMonoid NNSubCMonoid].

Definition NN_to_ZZ : #(Map NN ZZ) := (FractionCMonoidCannProj _ _).

Definition ZZAdd : #(BOperation ZZ) := (FractionCMonoid _ _).

Definition NZ := %Image NN_to_ZZ.

Definition nat_to_ZZ (n : nat) : #ZZ := %NN_to_ZZ (nat_to_NN n).

(* Algebraic Structure of Add *)

Theorem ZZAdd_SGrpCond : Ope_SGrpCond ZZAdd.
Proof.
unfold ZZAdd.
apply FractionCMonoid_Ope_SGrpCond.
Qed.

Theorem ZZAdd_CommCond : Ope_CommCond ZZAdd.
Proof.
unfold ZZAdd.
apply FractionCMonoid_Ope_CommCond.
Qed.

Theorem ZZ0IsIdent : &&IsIdent ZZAdd (nat_to_ZZ 0).
Proof.
unfold ZZAdd.
unfold NN_to_ZZ.
apply FractionCMonoidCannProj_IsIdent.
generalize NN0IsIdent.
apply RelRewriteL.
hyperreflexivity.
Qed.

Theorem ZZAdd_IdentCond : Ope_IdentCond ZZAdd.
Proof.
exists (%NN_to_ZZ (nat_to_NN 0)).
apply ZZ0IsIdent.
Qed.

Theorem ZZAdd_MonoidCond : Ope_MonoidCond ZZAdd.
Proof.
split.
apply ZZAdd_SGrpCond.
apply ZZAdd_IdentCond.
Qed.

(* NNNN_to_ZZ *)
Theorem NNNN_to_ZZ_is_Fraction : forall m n,
%NNNN_to_ZZ [m;n] ==
%(to_FractionCMonoidSet NNAdd_CMonoid NNSubCMonoid) [m ; %(EmbedMap NN_NNSubCMonoid) n].
Proof.
intros m n.
unfold NNNN_to_ZZ.
rewrite CombineMap'Theorem.
apply MapArgEq.
rewrite DoubleMapTheorem.
apply EqualInPair'L.
apply IdMapTheorem.
Qed.

Theorem NN_to_ZZ_is_NNNN_to_ZZ : forall n,
%NN_to_ZZ n ==
%NNNN_to_ZZ [n ; nat_to_NN 0].
Proof.
intro n.
unfold NN_to_ZZ.
rewrite (FractionCMonoidCannProjTheorem NNAdd_CMonoid NNSubCMonoid).
rewrite NNNN_to_ZZ_is_Fraction.
apply MapArgEq.
apply EqualInPair'R.
apply MIdentEq.
generalize NN0IsIdent.
apply IsIdent_StrongCons.
 rewrite EmbedMapEq.
 hyperreflexivity.
apply (TransitivityStrongRel ((SubCMonoid_to_CMonoid NNSubCMonoid){<CMonoid_Ope}){<Map_Rel}).
 apply ReflexivityStrongRel2.
 hyperreflexivity.
apply (StrongSubBOpe _ (NNSubCMonoid){<SubCMonoid_SubOpe}).
Qed.

Theorem ZZIsNNNN : forall (a : #ZZ),
exists m, exists n,
a == %NNNN_to_ZZ [m;n].
Proof.
intro a.
put (FractionCMonoidSetIn _ _ a) Eqa.
destruct Eqa as [m Eqa].
destruct Eqa as [n Eqa].
exists m.
exists n.
rewrite NNNN_to_ZZ_is_Fraction.
apply (TransitivityEq (%(to_FractionCMonoidSet NNAdd_CMonoid NNSubCMonoid) [m;n])).
 apply Eqa.
apply MapArgEq.
apply EqualInPair'R.
rewrite EmbedMapEq.
hyperreflexivity.
Qed.

Theorem NNNN_to_ZZEq : forall a b c d,
%NNNN_to_ZZ [a;b] == %NNNN_to_ZZ [c;d] <->
%NNAdd [a;d] == %NNAdd [c;b].
Proof.
intros a b c d.
split.
 intro HH.
 rewrite NNNN_to_ZZ_is_Fraction in HH.
 rewrite NNNN_to_ZZ_is_Fraction in HH.
 apply (to_FractionCMonoidSetEq NNAdd_CMonoid NNSubCMonoid) in HH.
 destruct HH as [s HH].
 cut (%NNAdd [%NNAdd [a;d] ; s{<SubCMonoid_S}] == %NNAdd [%NNAdd[c;b] ; s{<SubCMonoid_S}]).
  intro EqH.
  apply NNAddRightCancell in EqH.
  apply EqH.
 apply (TransitivityEq (%(NNAdd_CMonoid{<CMonoid_Ope}) [%(NNAdd_CMonoid{<CMonoid_Ope}) [a; (%(EmbedMap NN_NNSubCMonoid) d){<SubCMonoid_S}] ; s{<SubCMonoid_S}])).
  apply MapEqAll.
   apply EqualInPair'L.
   apply MapEqAll.
    apply EqualInPair'R.
    rewrite USETEq.
    rewrite EmbedMapEq.
    hyperreflexivity.
   hyperreflexivity.
  hyperreflexivity.
 rewrite HH.
 apply MapEqAll.
  apply EqualInPair'L.
  apply MapEqAll.
   apply EqualInPair'R.
   rewrite USETEq.
   rewrite EmbedMapEq.
   hyperreflexivity.
  hyperreflexivity.
 hyperreflexivity.

 intro EqN.
 rewrite NNNN_to_ZZ_is_Fraction.
 rewrite NNNN_to_ZZ_is_Fraction.
 apply (to_FractionCMonoidSetEq NNAdd_CMonoid NNSubCMonoid).
 exists (nat_to_NN 0).
 apply (TransitivityEq (%NNAdd [%NNAdd [a;d] ; nat_to_NN 0])).
  apply MapEqAll.
   apply EqualInPair'.
   split.
    apply MapEqAll.
     apply EqualInPair'R.
     rewrite USETEq.
     rewrite EmbedMapEq.
     hyperreflexivity.
    hyperreflexivity.
   hyperreflexivity.
  hyperreflexivity.
 rewrite NNAddTheorem1.
 rewrite EqN.
 apply (TransitivityEq (%NNAdd [%NNAdd [c;b] ; nat_to_NN 0])).
  rewrite NNAddTheorem1.
  hyperreflexivity.
 apply MapEqAll.
  apply EqualInPair'.
  split.
   apply MapEqAll.
    apply EqualInPair'R.
    rewrite USETEq.
    rewrite EmbedMapEq.
    hyperreflexivity.
   hyperreflexivity.
  hyperreflexivity.
 hyperreflexivity.
Qed.

Theorem ZZAddTheorem_NNNN : forall a b c d,
%ZZAdd [%NNNN_to_ZZ [a;b] ; %NNNN_to_ZZ [c;d]] ==
%NNNN_to_ZZ [%NNAdd [a;c] ; %NNAdd [b;d]].
Proof.
intros a b c d.
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (NNNN_to_ZZ_is_Fraction _ _))).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (NNNN_to_ZZ_is_Fraction _ _))).
rewrite (FractionCMonoidTheorem NNAdd_CMonoid NNSubCMonoid).
rewrite NNNN_to_ZZ_is_Fraction.
apply MapArgEq.
apply EqualInPair'.
split.
 hyperreflexivity.
rewrite EmbedMapEq.
apply MapStrong.
 apply (StrongSubBOpe _ (NNSubCMonoid{<SubCMonoid_SubOpe})).
apply EqualInPair'.
split; apply EmbedMapEq.
Qed.

Theorem NNNN_to_ZZ_IsIdent2 : forall (m n : #NN),
m == n ->
&&IsIdent ZZAdd (%NNNN_to_ZZ [m;n]).
Proof.
intros m n Eqmn.
unfold ZZAdd.
apply (RelRewriteR' (NNNN_to_ZZ_is_Fraction _ _)).
apply to_FractionCMonoidSet_Ident2.
rewrite Eqmn.
rewrite EmbedMapEq.
hyperreflexivity.
Qed.

Theorem ZZAdd_IsInverseE_NNNN : forall m n,
&&(%IsInverseE ZZAdd) (%NNNN_to_ZZ [m;n]) (%NNNN_to_ZZ [n;m]).
Proof.
intros m n.
apply IsInverseETheoremL.
 apply ZZAdd_CommCond.
apply (RelRewriteR' (ZZAddTheorem_NNNN _ _ _ _)).
apply NNNN_to_ZZ_IsIdent2.
apply NNAdd_Ope_CommCond.
Qed.

Theorem ZZAdd_InvertCond : Ope_InvertCond ZZAdd.
Proof.
intro x.
put (ZZIsNNNN x) Eqx.
destruct Eqx as [m Eqx].
destruct Eqx as [n Eqx].
apply IsInvertibleTheorem.
exists (%NNNN_to_ZZ [n;m]).
apply (RelRewriteL' Eqx).
apply ZZAdd_IsInverseE_NNNN.
Qed.

Theorem ZZAdd_GrpCond : Ope_GrpCond ZZAdd.
Proof.
split.
apply ZZAdd_MonoidCond.
apply ZZAdd_InvertCond.
Qed.

Theorem ZZAdd_CGrpCond : Ope_CGrpCond ZZAdd.
Proof.
split.
apply ZZAdd_GrpCond.
apply ZZAdd_CommCond.
Qed.

Definition ZZAdd_CGrp := ZZAdd{<Ope_CGrp ! ZZAdd_CGrpCond}.

(* Addition of Integer *)
Definition Minus_of_ZZ : #(Map ZZ ZZ) :=
(MInvert_of_CGrp ZZAdd_CGrp).

Theorem Minus_of_ZZTheorem : forall n,
&&(%IsInverseE ZZAdd) n (%Minus_of_ZZ n).
Proof.
intro n.
generalize (MInvert_of_CGrpTheorem ZZAdd_CGrp n).
apply RelRewriteAll; hyperreflexivity.
Qed.

Theorem DoubleMinus_of_ZZ : forall n,
%Minus_of_ZZ (%Minus_of_ZZ n) == n.
Proof.
intro n.
apply (IsInverseEq_SGrp (ZZAdd_CGrp{<CGrp_SGrp}) (%Minus_of_ZZ n)).
 generalize (Minus_of_ZZTheorem (%Minus_of_ZZ n)).
 apply RelRewriteAll; hyperreflexivity.
apply IsInverseESymCond.
generalize (Minus_of_ZZTheorem n).
apply RelRewriteAll; hyperreflexivity.
Qed.

Theorem Minus_of_ZZDist : forall n m,
%Minus_of_ZZ (%ZZAdd [n;m]) == %ZZAdd [%Minus_of_ZZ n;%Minus_of_ZZ m].
Proof.
intros n m.
apply (TransitivityEq (%Minus_of_ZZ (%(ZZAdd_CGrp{<CGrp_Ope}) [n;m]))).
 hyperreflexivity.
unfold Minus_of_ZZ at 1.
rewrite MInvert_of_CGrpMultTheorem.
hyperreflexivity.
Qed.

Theorem NNNN_to_ZZTheorem : forall n m,
%NNNN_to_ZZ [n;m] ==
%ZZAdd [%NN_to_ZZ n ; %Minus_of_ZZ (%NN_to_ZZ m)].
Proof.
intros n m.
apply (TransitivityEq (%ZZAdd [%NNNN_to_ZZ [n ; nat_to_NN 0] ; %NNNN_to_ZZ [nat_to_NN 0 ; m]])).
 apply SymmetryEq.
 rewrite ZZAddTheorem_NNNN.
 apply MapArgEq.
 apply EqualInPair'.
 split.
 apply NNAddTheorem1.
 rewrite NNAdd_Ope_CommCond.
 apply NNAddTheorem1.
apply MapArgEq.
apply EqualInPair'.
split.
 apply SymmetryEq.
 apply NN_to_ZZ_is_NNNN_to_ZZ.
cut (&&IsIdent ZZAdd (%ZZAdd [%NN_to_ZZ m ; %NNNN_to_ZZ [nat_to_NN 0 ; m] ])).
 intro IsIH.
 apply SymmetryEq.
 apply (TransitivityEq (%ZZAdd [%Minus_of_ZZ (%NN_to_ZZ m) ; %ZZAdd [%NN_to_ZZ m ; %NNNN_to_ZZ [nat_to_NN 0 ; m]]])).
  apply SymmetryEq.
  apply IsRightIdentTheorem.
  apply IsIdent_RightIdent.
  apply IsIH.
 rewrite <- ZZAdd_SGrpCond.
 apply IsLeftIdentTheorem.
 apply IsIdent_LeftIdent.
 apply IsInverseE_IsIdent'.
 apply Minus_of_ZZTheorem.
cut (&&IsIdent ZZAdd (%ZZAdd [%NNNN_to_ZZ [m;nat_to_NN 0] ; %NNNN_to_ZZ [nat_to_NN 0 ; m]])).
 apply RelRewriteR.
 apply MapArgEq.
 apply EqualInPair'L.
 rewrite NN_to_ZZ_is_NNNN_to_ZZ.
 hyperreflexivity.
apply IsInverseE_IsIdent.
apply ZZAdd_IsInverseE_NNNN.
Qed.

Theorem NNAdd_to_ZZAdd_Hom :
&&IsHomomorphism_of_BOpe [NNAdd;ZZAdd] NN_to_ZZ.
Proof.
apply (FractionCMonoidCannProj_Hom NNAdd_CMonoid NNSubCMonoid).
Qed.

Theorem ZZAdd_comm_NNAdd : forall n1 n2,
%NN_to_ZZ (%NNAdd [n1;n2]) ==
%ZZAdd [%NN_to_ZZ n1 ; %NN_to_ZZ n2].
Proof.
put NNAdd_to_ZZAdd_Hom HomH.
put ((proj1 (IsHomomorphism_of_BOpeTheorem _ _ _)) HomH) comm.
apply comm.
Qed.

Definition ZZNext : #(Map ZZ ZZ) :=
%(%Currying ZZAdd) (nat_to_ZZ 1).

Definition ZZPrev : #(Map ZZ ZZ) :=
%(%Currying ZZAdd) (%Minus_of_ZZ (nat_to_ZZ 1)).

Theorem ZZNextTheorem : forall n,
%ZZNext n == %ZZAdd [n ; nat_to_ZZ 1].
Proof.
intro n.
unfold ZZNext.
rewrite CurryingTheorem.
apply ZZAdd_CommCond.
Qed.

Theorem ZZPrevTheorem : forall n,
%ZZPrev n == %ZZAdd [n ; %Minus_of_ZZ (nat_to_ZZ 1)].
Proof.
intro n.
unfold ZZPrev.
rewrite CurryingTheorem.
apply ZZAdd_CommCond.
Qed.

Theorem ZZPrevTheorem2 : forall n,
%ZZPrev n == %Minus_of_ZZ (%ZZNext (%Minus_of_ZZ n)).
Proof.
intro n.
apply SymmetryEq.
rewrite (MapArgEq _ (ZZNextTheorem _)).
rewrite Minus_of_ZZDist.
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (DoubleMinus_of_ZZ _))).
apply SymmetryEq.
rewrite ZZPrevTheorem.
hyperreflexivity.
Qed.

Theorem ZZNext_comm_NNNext_arg : forall n,
%ZZNext (%NN_to_ZZ n) ==
%NN_to_ZZ (%NNNext n).
Proof.
intros n.
unfold ZZNext.
rewrite CurryingTheorem.
rewrite ZZAdd_CommCond.
unfold nat_to_ZZ.
rewrite <- ZZAdd_comm_NNAdd.
apply MapArgEq.
unfold nat_to_NN.
rewrite NNAddTheorem2.
apply MapArgEq.
rewrite NNAddTheorem1.
hyperreflexivity.
Qed.

Theorem ZZNext_comm_NNNext :
%CombineMap' [NN_to_ZZ ; ZZNext] ==
%CombineMap' [NNNext ; NN_to_ZZ].
Proof.
apply MapEquality.
hyperreflexivity.
intros n1 n2 Eqn.
rewrite CombineMap'Theorem.
rewrite CombineMap'Theorem.
rewrite ZZNext_comm_NNNext_arg.
apply MapArgEq.
apply MapArgEq.
apply Eqn.
Qed.

Theorem ZZNext_comb_ZZPrev : forall n,
%ZZNext (%ZZPrev n) == n.
Proof.
intros n.
unfold ZZNext.
rewrite CurryingTheorem.
rewrite ZZAdd_CommCond.
unfold ZZPrev.
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (CurryingTheorem _ _ _))).
rewrite ZZAdd_CommCond.
rewrite <- ZZAdd_SGrpCond.
apply IsLeftIdentTheorem.
apply IsIdent_LeftIdent.
put (Minus_of_ZZTheorem (nat_to_ZZ 1)) InvH.
apply IsInverseETheorem in InvH.
apply (proj1 InvH).
Qed.

Theorem ZZPrev_comb_ZZNext : forall n,
%ZZPrev (%ZZNext n) == n.
Proof.
intros n.
unfold ZZPrev.
rewrite CurryingTheorem.
unfold ZZNext.
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (CurryingTheorem _ _ _))).
rewrite <- ZZAdd_SGrpCond.
apply IsLeftIdentTheorem.
apply IsIdent_LeftIdent.
put (Minus_of_ZZTheorem (nat_to_ZZ 1)) InvH.
apply IsInverseETheorem in InvH.
apply (proj2 InvH).
Qed.

Theorem ZZAddTheorem0 : forall z,
%ZZAdd [z ; nat_to_ZZ 0] == z.
Proof.
intro z.
apply IsRightIdentTheorem.
apply IsIdent_RightIdent.
apply ZZ0IsIdent.
Qed.

Theorem ZZAddTheorem1 : forall m n,
%ZZAdd [m ; %ZZNext n] == %ZZNext (%ZZAdd [m;n]).
Proof.
intros m n.
unfold ZZNext at 1.
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (CurryingTheorem _ _ _))).
rewrite <- ZZAdd_SGrpCond.
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (ZZAdd_CommCond _ _))).
rewrite ZZAdd_SGrpCond.
unfold ZZNext.
rewrite CurryingTheorem.
hyperreflexivity.
Qed.

Theorem ZZAddTheorem2 : forall m n,
%ZZAdd [m ; %ZZPrev n] == %ZZPrev (%ZZAdd [m;n]).
Proof.
intros m n.
unfold ZZPrev at 1.
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (CurryingTheorem _ _ _))).
rewrite <- ZZAdd_SGrpCond.
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (ZZAdd_CommCond _ _))).
rewrite ZZAdd_SGrpCond.
unfold ZZPrev.
rewrite CurryingTheorem.
hyperreflexivity.
Qed.

Theorem ZZNextInjection : Map_InjCond ZZNext.
Proof.
intros n m EqH.
apply (TransitivityEq (%ZZPrev (%ZZNext n))).
 apply SymmetryEq.
 apply ZZPrev_comb_ZZNext.
rewrite (MapArgEq _ EqH).
rewrite ZZPrev_comb_ZZNext.
hyperreflexivity.
Qed.

Theorem ZZNextSurjection : Map_SurCond ZZNext.
Proof.
intros n.
exists (%ZZPrev n).
apply ZZNext_comb_ZZPrev.
Qed.

Theorem ZZPrevInjection : Map_InjCond ZZPrev.
Proof.
intros n m EqH.
apply (TransitivityEq (%ZZNext (%ZZPrev n))).
 apply SymmetryEq.
 apply ZZNext_comb_ZZPrev.
rewrite (MapArgEq _ EqH).
rewrite ZZNext_comb_ZZPrev.
hyperreflexivity.
Qed.

Theorem ZZPrevSurjection : Map_SurCond ZZPrev.
Proof.
intros n.
exists (%ZZNext n).
apply ZZPrev_comb_ZZNext.
Qed.

(************************)
(* Representation of ZZ *)
(************************)

Theorem HomNN_RepresentOfFractionCMonoidableSet :
Subset (%Homomorphism_of_BOpe [NNAdd;ZZAdd]) (RepresentOfFractionCMonoidableSet NNAdd_CMonoid (ZZAdd_CGrp{<CGrp_Monoid}) NNSubCMonoid).
Proof.
intros f InfH.
assert(InfM : In f (Map NN ZZ)).
 apply HomBOpe_Map in InfH.
 apply InfH.
rewrite (DSETEq' _ InfM).
apply RepresentOfFractionCMonoidableSetTheorem.
split.
 apply Homomorphism_of_BOpeTheorem.
 generalize InfH.
 apply Arrow2Rewrite.
 hyperreflexivity.
 hyperreflexivity.
intros s InsNNS.
cut (&&IsInvertible ZZAdd (%{f ! InfM} s)).
 apply RelRewriteL.
 hyperreflexivity.
apply ZZAdd_InvertCond.
Qed.

Definition NZMap_to_ZZMap : #(Map (%Homomorphism_of_BOpe [NNAdd;ZZAdd]) (Map ZZ ZZ)) :=
%CombineMap' [EmbedMap HomNN_RepresentOfFractionCMonoidableSet ; RepresentOfFractionCMonoid _ _ _].

Theorem NZMap_to_ZZMapTheorem : forall (f : #(%Homomorphism_of_BOpe [NNAdd;ZZAdd])) m n,
%(%NZMap_to_ZZMap f) (%NNNN_to_ZZ [m;n]) ==
%ZZAdd [%(f{<HomBOpe_Map}) m ; %Minus_of_ZZ (%(f{<HomBOpe_Map}) n)].
Proof.
intros f m n.
unfold NZMap_to_ZZMap.
rewrite (MapEq (CombineMap'Theorem _ _ _ _ _ _)).
rewrite (MapArgEq _ (NNNN_to_ZZ_is_Fraction _ _)).
apply (TransitivityEq (%(ZZAdd_CGrp{<CGrp_Monoid}{<Monoid_Ope}) [%(%(EmbedMap HomNN_RepresentOfFractionCMonoidableSet) f){<RepresentOfFCM_Map} m ; (%Minus_of_ZZ (%(f{<HomBOpe_Map}) n))])).
 apply RepresentOfFractionCMonoidTheorem.
 cut (&&(%IsInverseE ZZAdd) (%(f{<HomBOpe_Map}) n) (%Minus_of_ZZ (%(f{<HomBOpe_Map}) n))).
  apply RelRewriteAll.
    apply MapEqAll.
     rewrite USETEq.
     rewrite EmbedMapEq.
     hyperreflexivity.
    rewrite USETEq.
    rewrite USETEq.
    rewrite EmbedMapEq.
    hyperreflexivity.
   hyperreflexivity.
  apply MapArgEq.
  hyperreflexivity.
 apply Minus_of_ZZTheorem.
apply MapEqAll.
 apply EqualInPair'L.
 apply MapEq.
 rewrite USETEq.
 rewrite USETEq.
 rewrite EmbedMapEq.
 hyperreflexivity.
hyperreflexivity.
Qed.

Theorem NZMap_to_ZZMapEq : forall (f : #(%Homomorphism_of_BOpe [NNAdd;ZZAdd])),
f == %CombineMap' [NN_to_ZZ ; %NZMap_to_ZZMap f].
Proof.
intro f.
unfold NN_to_ZZ.
unfold NZMap_to_ZZMap.
rewrite (USETEq' f HomNN_RepresentOfFractionCMonoidableSet).
rewrite (RepresentOfFractionCMonoidEq _ _ _).
apply MapArgEq.
apply EqualInPair'R.
rewrite CombineMap'Theorem.
apply MapArgEq.
rewrite EmbedMapEq.
hyperreflexivity.
Qed.

(*
Theorem NZMap_to_ZZMapEqWP : forall (f : #(Map NN ZZ)) (cond : In f (%Homomorphism_of_BOpe [NNAdd;ZZAdd])),
f == %CombineMap' [NN_to_ZZ ; %NZMap_to_ZZMap {f ! cond}].
Proof.
intros f cond.
apply (TransitivityEq {f ! cond}).
 hyperreflexivity.
rewrite NZMap_to_ZZMapEq.
hyperreflexivity.
Qed.

Theorem NZMap_to_ZZMapEq_Arg : forall (f : #(%Homomorphism_of_BOpe [NNAdd;ZZAdd])) a,
%(f{<HomBOpe_Map}) a == %(%NZMap_to_ZZMap f) (%NN_to_ZZ a).
Proof.
intros f a.
apply (TransitivityEq (%(%CombineMap' [NN_to_ZZ ; %NZMap_to_ZZMap f]) a)).
 apply MapEq.
 apply (TransitivityEq f).
  hyperreflexivity.
 apply NZMap_to_ZZMapEq.
rewrite CombineMap'Theorem.
hyperreflexivity.
Qed.

Theorem NZMap_to_ZZMapEqWP_Arg : forall (f : #(Map NN ZZ)) (cond : In f (%Homomorphism_of_BOpe [NNAdd;ZZAdd])) a,
%f a == %(%NZMap_to_ZZMap {f ! cond}) (%NN_to_ZZ a).
Proof.
intros f cond a.
apply (TransitivityEq (%(%CombineMap' [NN_to_ZZ ; %NZMap_to_ZZMap {f ! cond}]) a)).
 apply MapEq.
 apply NZMap_to_ZZMapEqWP.
rewrite CombineMap'Theorem.
hyperreflexivity.
Qed.
*)

(*
Theorem NZMap_to_ZZMapEq : forall (f : #(Map NN ZZ)) (g1 g2 : #(Map ZZ ZZ)),
&&IsHomomorphism_of_BOpe [NNAdd;ZZAdd] f ->
&&IsHomomorphism_of_BOpe [ZZAdd;ZZAdd] g1 ->
&&IsHomomorphism_of_BOpe [ZZAdd;ZZAdd] g2 ->
f == %CombineMap' [NN_to_ZZ ; g1] ->
f == %CombineMap' [NN_to_ZZ ; g2] ->
g1 == g2.
Proof.
intros f g1 g2.
intros conf cong1 cong2.
apply (RepresentOfFractionCMonoid_Eq NNAdd_CMonoid (ZZAdd_CGrp{<CGrp_Monoid}) NNSubCMonoid).
 apply HomNN_RepresentOfFractionCMonoidableSet.
 apply Homomorphism_of_BOpeTheorem.
 apply conf.
apply cong1.
apply cong2.
Qed.
*)

Theorem NZMap_to_ZZMapHom : forall (f : #(%Homomorphism_of_BOpe [NNAdd;ZZAdd])),
&&IsHomomorphism_of_BOpe [ZZAdd;ZZAdd] (%NZMap_to_ZZMap f).
Proof.
intros f.
unfold NZMap_to_ZZMap.
apply (RelRewriteR' (CombineMap'Theorem _ _ _ _ _ _)).
generalize (RepresentOfFractionCMonoid_HomBOpe NNAdd_CMonoid (ZZAdd_CGrp{<CGrp_Monoid}) NNSubCMonoid (%(EmbedMap HomNN_RepresentOfFractionCMonoidableSet) f)).
apply RelRewriteAll; hyperreflexivity.
Qed.

Theorem NNNNHomomorphism_to_NNZZHomomorphism:forall (f : #(%Homomorphism_of_BOpe [NNAdd;NNAdd])),
In (%CombineMap' [f{<HomBOpe_Map};NN_to_ZZ]) (%Homomorphism_of_BOpe [NNAdd;ZZAdd]).
Proof.
intros f.
apply Homomorphism_of_BOpeTheorem.
apply (CombIsHomomorphis_of_BOpe NNAdd NNAdd ZZAdd).
apply Homomorphism_of_BOpeTheorem.
apply (SetProp f).
apply NNAdd_to_ZZAdd_Hom.
Qed.

Definition NNMap_to_ZZMap_Cls (f : #(%Homomorphism_of_BOpe [NNAdd;NNAdd])) : #(Map ZZ ZZ) :=
%NZMap_to_ZZMap {_!NNNNHomomorphism_to_NNZZHomomorphism f}.

Theorem NNMap_to_ZZMap_ClsRFun : RFun NNMap_to_ZZMap_Cls.
Proof.
intros f1 f2 Eqf.
unfold NNMap_to_ZZMap_Cls.
apply MapArgEq.
rewrite DSETEq.
rewrite DSETEq.
apply MapArgEq.
apply EqualInPair'L.
apply Eqf.
Qed.

Definition NNMap_to_ZZMap : #(Map (%Homomorphism_of_BOpe [NNAdd;NNAdd]) (Map ZZ ZZ)) :=
MakeMap _ _ _ NNMap_to_ZZMap_ClsRFun.

Theorem NNMap_to_ZZMapEq : forall (f : #(%Homomorphism_of_BOpe [NNAdd;NNAdd])),
%CombineMap' [f{<HomBOpe_Map} ; NN_to_ZZ] == %CombineMap' [NN_to_ZZ ; %NNMap_to_ZZMap f].
Proof.
intro f.
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _(MakeMapTheorem _ _ NNMap_to_ZZMap_Cls NNMap_to_ZZMap_ClsRFun _))).
unfold NNMap_to_ZZMap_Cls.
rewrite <- NZMap_to_ZZMapEq.
rewrite DSETEq.
hyperreflexivity.
Qed.

(*
Theorem NNMap_to_ZZMapEqWP : forall (f : #(Map NN NN)) (cond : In f (%Homomorphism_of_BOpe [NNAdd;NNAdd])),
%CombineMap' [f ; NN_to_ZZ] == %CombineMap' [NN_to_ZZ ; %NNMap_to_ZZMap {f ! cond}].
Proof.
intros f cond.
rewrite <- NNMap_to_ZZMapEq.
hyperreflexivity.
Qed.

Theorem NNMap_to_ZZMapEq_Arg : forall (f : #(%Homomorphism_of_BOpe [NNAdd;NNAdd])) n,
%NN_to_ZZ (%(f{<HomBOpe_Map}) n) ==
%(%NNMap_to_ZZMap f) (%NN_to_ZZ n).
Proof.
intros f n.
apply (TransitivityEq (%(%CombineMap' [f{<HomBOpe_Map} ; NN_to_ZZ]) n)).
 rewrite CombineMap'Theorem.
 hyperreflexivity.
rewrite (MapEq (NNMap_to_ZZMapEq _)).
rewrite CombineMap'Theorem.
hyperreflexivity.
Qed.

Theorem NNMap_to_ZZMapEqWP_Arg : forall (f : #(Map NN NN)) (cond : In f (%Homomorphism_of_BOpe [NNAdd;NNAdd])) a,
%NN_to_ZZ (%f a) ==
%(%NNMap_to_ZZMap {f ! cond}) (%NN_to_ZZ a).
Proof.
intros f cond a.
apply (TransitivityEq (%(%CombineMap' [f ; NN_to_ZZ]) a)).
 rewrite CombineMap'Theorem.
 hyperreflexivity.
rewrite (MapEq (NNMap_to_ZZMapEqWP f cond)).
rewrite CombineMap'Theorem.
hyperreflexivity.
Qed.
*)

Theorem NNMap_to_ZZMapTheorem : forall m n (f : #(%Homomorphism_of_BOpe [NNAdd;NNAdd])),
%(%NNMap_to_ZZMap f) (%NNNN_to_ZZ [m;n]) ==
%ZZAdd [%NN_to_ZZ (%(f{<HomBOpe_Map}) m) ; %Minus_of_ZZ (%NN_to_ZZ (%(f{<HomBOpe_Map}) n))].
Proof.
intros m n f.
unfold NNMap_to_ZZMap.
rewrite (MapEq (MakeMapTheorem _ _ _ _ _)).
unfold NNMap_to_ZZMap_Cls.
rewrite NZMap_to_ZZMapTheorem.
apply (TransitivityEq (%ZZAdd [%(%CombineMap' [f{<HomBOpe_Map} ; NN_to_ZZ]) m ; %Minus_of_ZZ (%(%CombineMap' [f{<HomBOpe_Map} ; NN_to_ZZ]) n)])).
 hyperreflexivity.
apply MapArgEq.
apply EqualInPair'.
split.
rewrite CombineMap'Theorem.
hyperreflexivity.
apply MapArgEq.
rewrite CombineMap'Theorem.
hyperreflexivity.
Qed.

(*
Theorem NNMap_to_ZZMapEq : forall (f : #(Map NN NN)) (g1 g2 : #(Map ZZ ZZ)),
&&IsHomomorphism_of_BOpe [NNAdd;NNAdd] f ->
&&IsHomomorphism_of_BOpe [ZZAdd;ZZAdd] g1 ->
&&IsHomomorphism_of_BOpe [ZZAdd;ZZAdd] g2 ->
%CombineMap' [f ; NN_to_ZZ] == %CombineMap' [NN_to_ZZ ; g1] ->
%CombineMap' [f ; NN_to_ZZ] == %CombineMap' [NN_to_ZZ ; g2] ->
g1 == g2.
Proof.
intros f g1 g2.
intros conf cong1 cong2.
set (%CombineMap' [f;NN_to_ZZ]) as f'.
apply (NZMap_to_ZZMapEq f' g1 g2).
 apply (CombIsHomomorphis_of_BOpe NNAdd NNAdd ZZAdd).
 apply conf.
apply NNAdd_to_ZZAdd_Hom.
apply cong1.
apply cong2.
Qed.
*)

Theorem NNMap_to_ZZMapHom : forall (f : #(%Homomorphism_of_BOpe [NNAdd;NNAdd])),
&&IsHomomorphism_of_BOpe [ZZAdd;ZZAdd] (%NNMap_to_ZZMap f).
Proof.
intro f.
cut (&&IsHomomorphism_of_BOpe [ZZAdd;ZZAdd] (%NZMap_to_ZZMap {_!NNNNHomomorphism_to_NNZZHomomorphism f})).
 apply RelRewriteR.
 unfold NNMap_to_ZZMap.
 rewrite MakeMapTheorem.
 unfold NNMap_to_ZZMap_Cls.
 hyperreflexivity.
apply NZMap_to_ZZMapHom.
Qed.

(*************)
(* PreZZMult *)
(*************)
(*
   PreZZMult1 : #(Map NN (Map NN NN))
   PreZZMult2 : #(Map NN (Map ZZ ZZ))
   PreZZMult3 : #(Map ZZ (Map NN ZZ))
   PreZZMult4 : #(Map ZZ (Map ZZ ZZ))
*)

Definition PreZZMult1 : #(Map NN (Map NN NN)) := %Currying NNMult.

Theorem PreZZMult1Theorem : forall n m,
%(%PreZZMult1 n) m == %NNMult [n;m].
Proof.
intros n m.
unfold PreZZMult1.
rewrite CurryingTheorem.
hyperreflexivity.
Qed.

Theorem PreZZMult1HomCond :
In PreZZMult1 (RistableRMap NN (Map NN NN) (%Homomorphism_of_BOpe [NNAdd;NNAdd])).
Proof.
apply RistableRMapTheorem.
split.
 apply HomBOpe_Map.
intros n.
apply Homomorphism_of_BOpeTheorem.
apply IsHomomorphism_of_BOpeTheorem.
intros a b.
unfold PreZZMult1.
rewrite CurryingTheorem.
rewrite (proj1 (NNAdd_NNMultDistDond _ _ _)).
apply MapArgEq.
apply EqualInPair'.
split.
 rewrite CurryingTheorem.
 hyperreflexivity.

 rewrite CurryingTheorem.
 hyperreflexivity.
Qed.

Definition PreZZMult1Hom : #(Map NN (%Homomorphism_of_BOpe [NNAdd;NNAdd])) :=
%RistrictMapR {_!PreZZMult1HomCond}.

Definition PreZZMult2 : #(Map NN (Map ZZ ZZ)) :=
%CombineMap' [PreZZMult1Hom ; NNMap_to_ZZMap].

Theorem PreZZMult2Theorem : forall n a b,
%(%PreZZMult2 n) (%NNNN_to_ZZ [a;b]) ==
%ZZAdd [%NN_to_ZZ (%(%PreZZMult1 n) a) ; %Minus_of_ZZ (%NN_to_ZZ (%(%PreZZMult1 n) b))].
Proof.
intros n a b.
unfold PreZZMult2.
rewrite (MapEq (CombineMap'Theorem _ _ _ _ _ _)).
rewrite NNMap_to_ZZMapTheorem.
apply MapArgEq.
apply EqualInPair'.
unfold PreZZMult1Hom.
split.
 apply MapArgEq.
 apply MapEq.
 rewrite USETEq.
 apply MapEq.
 apply RistrictMapREq2.
apply MapArgEq.
apply MapArgEq.
apply MapEq.
rewrite USETEq.
apply MapEq.
apply RistrictMapREq2.
Qed.

(*
Theorem PreZZMult2Eq : forall (g1 g2 : #(Map ZZ ZZ)) n,
&&IsHomomorphism_of_BOpe [ZZAdd;ZZAdd] g1 ->
&&IsHomomorphism_of_BOpe [ZZAdd;ZZAdd] g2 ->
%CombineMap' [%PreZZMult1 n ; NN_to_ZZ] == %CombineMap' [NN_to_ZZ ; g1] ->
%CombineMap' [%PreZZMult1 n ; NN_to_ZZ] == %CombineMap' [NN_to_ZZ ; g2] ->
g1 == g2.
Proof.
intros g1 g2 n.
apply NNMap_to_ZZMapEq.
apply Homomorphism_of_BOpeTheorem.
apply RistableRMapTheoremIn.
apply PreZZMult1HomCond.
Qed.
*)
(*
Theorem PreZZMult2_Hom : forall n,
&&IsHomomorphism_of_BOpe [ZZAdd;ZZAdd] (%PreZZMult2 n).
Proof.
intro n.
apply Homomorphism_of_BOpeTheorem.
unfold PreZZMult2.
rewrite CombineMap'Theorem.
put (NNMap_to_ZZMapHom (%PreZZMult1Hom n)) HomH.
apply Homomorphism_of_BOpeTheorem.
apply HomH.
Qed.

Theorem PreZZMult2LeftDist : forall a b c,
%(%PreZZMult2 a) (%ZZAdd [b;c]) ==
%ZZAdd [%(%PreZZMult2 a) b ; %(%PreZZMult2 a) c].
Proof.
intros a b c.
put (PreZZMult2_Hom a) HomH.
put ((proj1 (IsHomomorphism_of_BOpeTheorem _ _ _)) HomH) HomH'.
apply HomH'.
Qed.

Theorem PreZZMult2z1 : forall n,
%(%PreZZMult2 n) (nat_to_ZZ 1) == %NN_to_ZZ n.
Proof.
intro n.
unfold nat_to_ZZ.
rewrite PreZZMult2Theorem.
apply MapArgEq.
unfold nat_to_NN.
rewrite NNMultTheorem1.
hyperreflexivity.
Qed.

Theorem PreZZMult2z0 : forall n,
%(%PreZZMult2 n) (nat_to_ZZ 0) == (nat_to_ZZ 0).
Proof.
intro n.
cut (%ZZAdd [%NN_to_ZZ n ; %(%PreZZMult2 n) (nat_to_ZZ 0)] == %NN_to_ZZ n).
 intro EqH.
 apply (TransitivityEq (%ZZAdd [%ZZAdd[%Minus_of_ZZ (%NN_to_ZZ n) ; %NN_to_ZZ n] ; %(%PreZZMult2 n) (nat_to_ZZ 0)])).
  apply SymmetryEq.
  apply IsLeftIdentTheorem.
  apply IsIdent_LeftIdent.
  generalize (Minus_of_ZZTheorem (%NN_to_ZZ n)).
  intro InvH.
  apply IsInverseETheorem in InvH.
  apply (proj2 InvH).
 rewrite ZZAdd_SGrpCond.
 rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ EqH)).
 apply (TransitivityEq (MIdent_of_CGrp (ZZAdd_CGrp))).
  apply SymmetryEq.
  apply MIdentEq.
  put (Minus_of_ZZTheorem (%NN_to_ZZ n)) InvH.
  apply IsInverseETheorem in InvH.
  apply (proj2 InvH).
 apply MIdentEq.
 generalize ZZ0IsIdent.
 apply RelRewriteAll; hyperreflexivity.
rewrite <- (MapArgEq _ (EqualInPair'L _ _ _ _ _ (PreZZMult2z1 _))).
rewrite <- PreZZMult2LeftDist.
rewrite <- PreZZMult2z1.
apply MapArgEq.
apply IsRightIdentTheorem.
apply IsIdent_RightIdent.
apply ZZ0IsIdent.
Qed.

Theorem PreZZMult2n0 : forall a,
%(%PreZZMult2 (nat_to_NN 0)) a == (nat_to_ZZ 0).
Proof.
intro a.
set (%(@ConstMap ZZ ZZ) (nat_to_ZZ 0)) as Const0.
assert(Map_Eq : (%PreZZMult2 (nat_to_NN 0)) == Const0).
 apply (PreZZMult2Eq _ _ (nat_to_NN 0)).

 apply PreZZMult2_Hom.

 apply IsHomomorphism_of_BOpeTheorem.
 intros n m.
 unfold Const0.
 rewrite ConstMapTheorem.
 rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (ConstMapTheorem _ _))).
 rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (ConstMapTheorem _ _))).
 apply SymmetryEq.
 apply IsLeftIdentTheorem.
 apply IsIdent_LeftIdent.
 apply ZZ0IsIdent.

 apply MapEquality.
  hyperreflexivity.
 intros n m Eqnm.
 rewrite CombineMap'Theorem.
 rewrite CombineMap'Theorem.
 rewrite PreZZMult2Theorem.
 apply MapArgEq.
 unfold PreZZMult1.
 rewrite CurryingTheorem.
 apply MapArgEq.
 apply EqualInPair'R.
 apply Eqnm.

 unfold Const0.
 apply MapEquality.
  hyperreflexivity.
 intros n m Eqnm.
 rewrite CombineMap'Theorem.
 rewrite CombineMap'Theorem.
 rewrite ConstMapTheorem.
 unfold PreZZMult1.
 rewrite (MapArgEq _ (CurryingTheorem _ _ _)).
 apply MapArgEq.
 rewrite NNMult_Ope_CommCond.
 rewrite NNMultTheorem0.
 hyperreflexivity.
rewrite (MapEq Map_Eq).
unfold Const0.
rewrite ConstMapTheorem.
hyperreflexivity.
Qed.

Theorem PreZZMult2Next : forall n m,
%(%PreZZMult2 (%NNNext n)) m == %ZZAdd [%(%PreZZMult2 n) m ; m].
Proof.
intros n m.
set (%CombineMap' [%CartesianDMap [IdMap ; %PreZZMult2 n] ; ZZAdd]) as F.
assert(Eq_Map : %PreZZMult2 (%NNNext n) == F).
 apply (PreZZMult2Eq _ _ (%NNNext n)).

 apply PreZZMult2_Hom.

 apply IsHomomorphism_of_BOpeTheorem.
 intros x y.
 unfold F.
 rewrite CombineMap'Theorem.
 rewrite (MapArgEq _ (CartesianDMapTheorem _ _ _)).
 rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (IdMapTheorem _ _))).
 apply SymmetryEq.
 apply (TransitivityEq (%ZZAdd [%ZZAdd [x;%(%PreZZMult2 n) x] ; %ZZAdd [y;%(%PreZZMult2 n) y]])).
  apply MapArgEq.
  apply EqualInPair'.
  split.
   rewrite CombineMap'Theorem.
   apply MapArgEq.
   rewrite CartesianDMapTheorem.
   apply EqualInPair'L.
   rewrite IdMapTheorem.
   hyperreflexivity.

   rewrite CombineMap'Theorem.
   apply MapArgEq.
   rewrite CartesianDMapTheorem.
   apply EqualInPair'L.
   rewrite IdMapTheorem.
   hyperreflexivity.
 apply (TransitivityEq (%ZZAdd [%ZZAdd [x;y] ; %ZZAdd [%(%PreZZMult2 n) x ; %(%PreZZMult2 n) y]])).
  rewrite ZZAdd_SGrpCond.
  apply SymmetryEq.
  rewrite ZZAdd_SGrpCond.
  apply MapArgEq.
  apply EqualInPair'R.
  rewrite <- ZZAdd_SGrpCond.
  apply SymmetryEq.
  rewrite <- ZZAdd_SGrpCond.
  apply MapArgEq.
  apply EqualInPair'L.
  apply ZZAdd_CommCond.
 apply MapArgEq.
 apply EqualInPair'R.
 apply SymmetryEq.
 apply PreZZMult2LeftDist.

 apply MapEquality.
  hyperreflexivity.
 intros a b Eqab.
 rewrite CombineMap'Theorem.
 rewrite CombineMap'Theorem.
 rewrite PreZZMult2Theorem.
 apply MapArgEq.
 unfold NNMult.
 unfold PreZZMult1.
 rewrite CurryingTheorem.
 apply MapArgEq.
 apply EqualInPair'R.
 apply Eqab.

 unfold F.
 apply MapEquality.
  hyperreflexivity.
 intros a b Eqab.
 rewrite CombineMap'Theorem.
 apply SymmetryEq.
 rewrite CombineMap'Theorem.
 rewrite CombineMap'Theorem.
 rewrite (MapArgEq _ (CartesianDMapTheorem _ _ _)).
 rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (IdMapTheorem _ _))).
 rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (PreZZMult2Theorem _ _))).
 unfold PreZZMult1.
 rewrite (MapArgEq _ (CurryingTheorem _ _ _)).
 apply SymmetryEq.
 rewrite (MapArgEq _ (MapArgEq _ (EqualInPair'R _ _ _ _ _ Eqab))).
 rewrite (MapArgEq _ (NNMult_Ope_CommCond _ _)).
 rewrite (MapArgEq _ (NNMultTheorem2 _ _)).
 put NNAdd_to_ZZAdd_Hom Hom.
 put ((proj1 (IsHomomorphism_of_BOpeTheorem _ _ _)) Hom) Hom'.
 rewrite Hom'.
 rewrite ZZAdd_CommCond.
 apply MapArgEq.
 apply EqualInPair'R.
 apply MapArgEq.
 apply NNMult_Ope_CommCond.
rewrite (MapEq Eq_Map).
unfold F.
rewrite CombineMap'Theorem.
rewrite (MapArgEq _ (CartesianDMapTheorem _ _ _)).
rewrite ZZAdd_CommCond.
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (IdMapTheorem _ _))).
hyperreflexivity.
Qed.
*)

Theorem PreZZMult2RightDist : forall a b c,
%(%PreZZMult2 (%NNAdd [a;b])) c ==
%ZZAdd [%(%PreZZMult2 a) c ; %(%PreZZMult2 b) c].
Proof.
intros a b c.
put (ZZIsNNNN c) Eqc.
destruct Eqc as [m Eqc].
destruct Eqc as [n Eqc].
rewrite (MapArgEq _ Eqc).
rewrite PreZZMult2Theorem.
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (MapArgEq _ (PreZZMult1Theorem _ _)))).
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (MapArgEq _ (NNAdd_NNMultRDistDond _ _ _)))).
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (ZZAdd_comm_NNAdd _ _))).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (MapArgEq _ (MapArgEq _ (PreZZMult1Theorem _ _))))).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (MapArgEq _ (MapArgEq _ (NNAdd_NNMultRDistDond _ _ _))))).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (MapArgEq _ (ZZAdd_comm_NNAdd _ _)))).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (Minus_of_ZZDist _ _))).
apply SymmetryEq.
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (MapArgEq _ Eqc))).
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (PreZZMult2Theorem _ _ _))).
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (MapArgEq _ (EqualInPair'L _ _ _ _ _ (MapArgEq _ (PreZZMult1Theorem _ _)))))).
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (MapArgEq _ (EqualInPair'R _ _ _ _ _ (MapArgEq _ (MapArgEq _ (PreZZMult1Theorem _ _))))))).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (MapArgEq _ Eqc))).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (PreZZMult2Theorem _ _ _))).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (MapArgEq _ (EqualInPair'L _ _ _ _ _ (MapArgEq _ (PreZZMult1Theorem _ _)))))).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (MapArgEq _ (EqualInPair'R _ _ _ _ _ (MapArgEq _ (MapArgEq _ (PreZZMult1Theorem _ _))))))).
rewrite ZZAdd_SGrpCond.
apply SymmetryEq.
rewrite ZZAdd_SGrpCond.
apply MapArgEq.
apply EqualInPair'R.
rewrite <- ZZAdd_SGrpCond.
apply SymmetryEq.
rewrite <- ZZAdd_SGrpCond.
apply MapArgEq.
apply EqualInPair'L.
apply ZZAdd_CommCond.
Qed.

(*
Theorem PreZZMult2Assoc : forall n m,
%CombineMap' [%PreZZMult2 n ; %PreZZMult2 m] == %PreZZMult2 (%NNMult [n;m]).
Proof.
intros n m.
apply (PreZZMult2Eq _ _ (%NNMult [n;m])).

apply (CombIsHomomorphis_of_BOpe ZZAdd ZZAdd ZZAdd);
 apply PreZZMult2_Hom.

apply PreZZMult2_Hom.

apply MapEquality.
 hyperreflexivity.
intros a b Eqab.
rewrite CombineMap'Theorem.
apply SymmetryEq.
rewrite CombineMap'Theorem.
rewrite CombineMap'Theorem.
rewrite (MapArgEq _ (PreZZMult2Theorem _ _)).
rewrite PreZZMult2Theorem.
apply MapArgEq.
apply SymmetryEq.
unfold PreZZMult1.
rewrite CurryingTheorem.
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (NNMult_Ope_CommCond _ _))).
rewrite NNMult_Ope_SGrpCond.
apply MapArgEq.
apply EqualInPair'R.
apply MapArgEq.
apply EqualInPair'R.
apply Eqab.

apply MapEquality.
 hyperreflexivity.
intros a b Eqab.
rewrite CombineMap'Theorem.
apply SymmetryEq.
rewrite CombineMap'Theorem.
rewrite PreZZMult2Theorem.
apply MapArgEq.
apply SymmetryEq.
unfold PreZZMult1.
rewrite CurryingTheorem.
apply MapArgEq.
apply EqualInPair'R.
apply Eqab.
Qed.
*)

Definition PreZZMult3 : #(Map ZZ (Map NN ZZ)) :=
%Currying (%InverseBinaryMap (%Uncurrying PreZZMult2)).

Theorem PreZZMult3Theorem : forall n z,
%(%PreZZMult3 n) z == %(%PreZZMult2 z) n.
Proof.
intros n z.
unfold PreZZMult3.
rewrite CurryingTheorem.
rewrite InverseBinaryMapTheorem.
rewrite UncurryingTheorem.
hyperreflexivity.
Qed.

Theorem PreZZMult3HomCond :
In PreZZMult3 (RistableRMap ZZ (Map NN ZZ) (%Homomorphism_of_BOpe [NNAdd;ZZAdd])).
Proof.
apply RistableRMapTheorem.
split.
 apply HomBOpe_Map.
intros z.
apply Homomorphism_of_BOpeTheorem.
apply IsHomomorphism_of_BOpeTheorem.
intros n m.
rewrite PreZZMult3Theorem.
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (PreZZMult3Theorem _ _))).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (PreZZMult3Theorem _ _))).
apply PreZZMult2RightDist.
Qed.

Definition PreZZMult3Hom : #(Map ZZ (%Homomorphism_of_BOpe [NNAdd;ZZAdd])) :=
%RistrictMapR {_ ! PreZZMult3HomCond}.

Definition PreZZMult4 : #(Map ZZ (Map ZZ ZZ)) :=
%CombineMap' [PreZZMult3Hom ; NZMap_to_ZZMap].

Theorem PreZZMult4Theorem : forall a m n,
%(%PreZZMult4 a) (%NNNN_to_ZZ [m;n]) ==
%ZZAdd [%(%PreZZMult3 a) m ; %Minus_of_ZZ (%(%PreZZMult3 a) n)].
Proof.
intros a m n.
unfold PreZZMult4.
rewrite (MapEq (CombineMap'Theorem _ _ _ _ _ _)).
unfold PreZZMult3Hom.
rewrite NZMap_to_ZZMapTheorem.
apply MapArgEq.
apply EqualInPair'.
split.
 apply MapEq.
 rewrite USETEq.
 apply MapEq.
 apply RistrictMapREq2.
apply MapArgEq.
apply MapEq.
rewrite USETEq.
apply MapEq.
apply RistrictMapREq2.
Qed.

(*
Theorem PreZZMult4Eq : forall (g1 g2 : #(Map ZZ ZZ)) a,
&&IsHomomorphism_of_BOpe [ZZAdd;ZZAdd] g1 ->
&&IsHomomorphism_of_BOpe [ZZAdd;ZZAdd] g2 ->
%PreZZMult3 a == %CombineMap' [NN_to_ZZ ; g1] ->
%PreZZMult3 a == %CombineMap' [NN_to_ZZ ; g2] ->
g1 == g2.
Proof.
intros g1 g2 a.
apply NZMap_to_ZZMapEq.
apply Homomorphism_of_BOpeTheorem.
apply RistableRMapTheoremIn.
apply PreZZMult3HomCond.
Qed.

Theorem PreZZMult4_Hom : forall n,
&&IsHomomorphism_of_BOpe [ZZAdd;ZZAdd] (%PreZZMult4 n).
Proof.
intro n.
apply Homomorphism_of_BOpeTheorem.
unfold PreZZMult4.
rewrite CombineMap'Theorem.
put (NZMap_to_ZZMapHom (%PreZZMult3Hom n)) HomH.
apply Homomorphism_of_BOpeTheorem.
apply HomH.
Qed.

Theorem PreZZMult4LeftDist : forall a b c,
%(%PreZZMult4 a) (%ZZAdd [b;c]) ==
%ZZAdd [%(%PreZZMult4 a) b ; %(%PreZZMult4 a) c].
Proof.
intros a b c.
put (PreZZMult4_Hom a) HomH.
put ((proj1 (IsHomomorphism_of_BOpeTheorem _ _ _)) HomH) HomH'.
apply HomH'.
Qed.

Theorem PreZZMult4_z1 : forall a,
%(%PreZZMult4 a) (nat_to_ZZ 1) == a.
Proof.
intro a.
apply (TransitivityEq (%(%PreZZMult4 a) (%NN_to_ZZ (nat_to_NN 1)))).
 apply MapArgEq.
 hyperreflexivity.
rewrite PreZZMult4Theorem.
rewrite PreZZMult3Theorem.
unfold nat_to_NN.
rewrite PreZZMult2Next.
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (PreZZMult2n0 _))).
apply IsLeftIdentTheorem.
apply IsIdent_LeftIdent.
apply ZZ0IsIdent.
Qed.

Theorem PreZZMult4_z0 : forall a,
%(%PreZZMult4 a) (nat_to_ZZ 0) == (nat_to_ZZ 0).
Proof.
intro a.
apply (TransitivityEq (%(%PreZZMult4 a) (%NN_to_ZZ (nat_to_NN 0)))).
 apply MapArgEq.
 hyperreflexivity.
rewrite PreZZMult4Theorem.
rewrite PreZZMult3Theorem.
rewrite PreZZMult2n0.
hyperreflexivity.
Qed.

Theorem PreZZMult4z1 : forall a,
%(%PreZZMult4 (nat_to_ZZ 1)) a == a.
Proof.
intro a.
assert(Map_Eq : (%PreZZMult4 (nat_to_ZZ 1)) == (@IdMap ZZ)).
 apply (PreZZMult4Eq _ _ (nat_to_ZZ 1)).

 apply PreZZMult4_Hom.

 apply IsHomomorphism_of_BOpeTheorem.
 intros x y.
 rewrite IdMapTheorem.
 apply SymmetryEq.
 rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (IdMapTheorem _ _))).
 rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (IdMapTheorem _ _))).
 hyperreflexivity.

 apply MapEquality.
  hyperreflexivity.
 intros n m Eqnm.
 apply SymmetryEq.
 rewrite CombineMap'Theorem.
 rewrite PreZZMult4Theorem.
 apply MapArgEq.
 apply SymmetryEq.
 apply Eqnm.

 apply MapEquality.
  hyperreflexivity.
 intros n m Eqnm.
 apply SymmetryEq.
 rewrite CombineMap'Theorem.
 rewrite IdMapTheorem.
 apply SymmetryEq.
 rewrite PreZZMult3Theorem.
 rewrite PreZZMult2z1.
 apply MapArgEq.
 apply Eqnm.

rewrite (MapEq Map_Eq).
rewrite IdMapTheorem.
hyperreflexivity.
Qed.

(*
Theorem PreZZMult4z0 : forall a,
%(%PreZZMult4 (nat_to_ZZ 0)) a == (nat_to_ZZ 0).
Proof.
intro a.
apply (TransitivityEq (%(%PreZZMult4 (%NN_to_ZZ (nat_to_NN 0))) a)).
 apply MapArgEq.
 hyperreflexivity.
rewrite PreZZMult4Theorem.
rewrite PreZZMult3Theorem.
rewrite PreZZMult2n0.
hyperreflexivity.
Qed.
*)

Theorem PreZZMult4RightDist : forall a b c,
%(%PreZZMult4 (%ZZAdd [a;b])) c ==
%ZZAdd [%(%PreZZMult4 a) c ; %(%PreZZMult4 b) c].
Proof.
intros a b c.
assert(EqP : %PreZZMult4 (%ZZAdd[a;b]) == %CombineMap' [%CartesianDMap [%PreZZMult4 a ; %PreZZMult4 b] ; ZZAdd]).
 apply (PreZZMult4Eq _ _ (%ZZAdd[a;b])).

 apply PreZZMult4_Hom.

 apply IsHomomorphism_of_BOpeTheorem.
 intros x y.
 rewrite CombineMap'Theorem.
 rewrite (MapArgEq _ (CartesianDMapTheorem _ _ _)).
 apply SymmetryEq.
 apply (TransitivityEq (%ZZAdd [%ZZAdd [%(%PreZZMult4 a) x ; %(%PreZZMult4 b) x] ; %ZZAdd [%(%PreZZMult4 a) y ; %(%PreZZMult4 b) y]])).
  apply MapArgEq.
  apply EqualInPair'.
  split.
   rewrite CombineMap'Theorem.
   rewrite (MapArgEq _ (CartesianDMapTheorem _ _ _)).
   hyperreflexivity.

   rewrite CombineMap'Theorem.
   rewrite (MapArgEq _ (CartesianDMapTheorem _ _ _)).
   hyperreflexivity.
 apply SymmetryEq.
 rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (PreZZMult4LeftDist _ _ _))).
 rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (PreZZMult4LeftDist _ _ _))).
 rewrite ZZAdd_SGrpCond.
 apply SymmetryEq.
 rewrite ZZAdd_SGrpCond.
 apply MapArgEq.
 apply EqualInPair'R.
 rewrite <- ZZAdd_SGrpCond.
 apply SymmetryEq.
 rewrite <- ZZAdd_SGrpCond.
 apply MapArgEq.
 apply EqualInPair'L.
 apply ZZAdd_CommCond.

 apply MapEquality.
  hyperreflexivity.
 intros x y Eqxy.
 apply SymmetryEq.
 rewrite CombineMap'Theorem.
 rewrite PreZZMult4Theorem.
 apply MapArgEq.
 apply SymmetryEq.
 apply Eqxy.

 apply MapEquality.
  hyperreflexivity.
 intros n m Eqnm.
 apply SymmetryEq.
 rewrite CombineMap'Theorem.
 rewrite CombineMap'Theorem.
 rewrite (MapArgEq _ (CartesianDMapTheorem _ _ _)).
 rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (PreZZMult4Theorem _ _))).
 rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (PreZZMult4Theorem _ _))).
 rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (PreZZMult3Theorem _ _))).
 rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (PreZZMult3Theorem _ _))).
 apply SymmetryEq.
 rewrite PreZZMult3Theorem.
 apply (TransitivityEq (%(%PreZZMult2 m) (%ZZAdd [a;b]))).
  apply MapEq.
  apply MapArgEq.
  apply Eqnm.
 apply PreZZMult2LeftDist.

rewrite (MapEq EqP).
rewrite CombineMap'Theorem.
rewrite (MapArgEq _ (CartesianDMapTheorem _ _ _)).
hyperreflexivity.
Qed.
*)
(************)
(** ZZMult **)
(************)

Definition ZZMultInv : #(BOperation ZZ) :=
%Uncurrying PreZZMult4.

Theorem ZZMultInv_is_PreZZMult4 : forall a b,
%ZZMultInv [a;b] == %(%PreZZMult4 a) b.
Proof.
intros a b.
unfold ZZMultInv.
rewrite UncurryingTheorem.
hyperreflexivity.
Qed.

Definition ZZMult : #(BOperation ZZ) :=
%InverseBinaryMap ZZMultInv.

Theorem ZZMult_is_ZZMultInv : forall a b,
%ZZMult [a;b] == %ZZMultInv [b;a].
Proof.
intros a b.
unfold ZZMult.
apply InverseBinaryMapTheorem.
Qed.

Theorem ZZMultTheorem_NNNN : forall a b c d,
%ZZMult [%NNNN_to_ZZ [a;b] ; %NNNN_to_ZZ [c;d]] ==
%NNNN_to_ZZ [%NNAdd [%NNMult [a;c] ; %NNMult [b;d]] ; %NNAdd [%NNMult [a;d] ; %NNMult [b;c]]].
Proof.
intros a b c d.
rewrite ZZMult_is_ZZMultInv.
rewrite ZZMultInv_is_PreZZMult4.
rewrite PreZZMult4Theorem.
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (PreZZMult3Theorem _ _))).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (MapArgEq _ (PreZZMult3Theorem _ _)))).
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (PreZZMult2Theorem _ _ _))).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (MapArgEq _ (PreZZMult2Theorem _ _ _)))).
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (MapArgEq _ (EqualInPair'L _ _ _ _ _ (MapArgEq _ (PreZZMult1Theorem _ _)))))).
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (MapArgEq _ (EqualInPair'R _ _ _ _ _ (MapArgEq _ (MapArgEq _ (PreZZMult1Theorem _ _))))))).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (MapArgEq _ (MapArgEq _ (EqualInPair'L _ _ _ _ _ (MapArgEq _ (PreZZMult1Theorem _ _))))))).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (MapArgEq _ (MapArgEq _ (EqualInPair'R _ _ _ _ _ (MapArgEq _ (MapArgEq _ (PreZZMult1Theorem _ _)))))))).
apply SymmetryEq.
rewrite NNNN_to_ZZTheorem.
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (ZZAdd_comm_NNAdd _ _))).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (MapArgEq _ (ZZAdd_comm_NNAdd _ _)))).
rewrite ZZAdd_SGrpCond.
apply SymmetryEq.
rewrite ZZAdd_SGrpCond.
apply MapArgEq.
apply EqualInPair'R.
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (Minus_of_ZZDist _ _))).
rewrite <- ZZAdd_SGrpCond.
rewrite ZZAdd_CommCond.
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (DoubleMinus_of_ZZ _))).
apply MapArgEq.
apply EqualInPair'R.
apply SymmetryEq.
rewrite Minus_of_ZZDist.
hyperreflexivity.
Qed.

Theorem NNMult_to_ZZMult_Hom :
&&IsHomomorphism_of_BOpe [NNMult;ZZMult] NN_to_ZZ.
Proof.
apply IsHomomorphism_of_BOpeTheorem.
intros n m.
apply SymmetryEq.
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (NN_to_ZZ_is_NNNN_to_ZZ _))).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (NN_to_ZZ_is_NNNN_to_ZZ _))).
rewrite ZZMultTheorem_NNNN.
apply (TransitivityEq (%NNNN_to_ZZ [%NNMult[n;m] ; nat_to_NN 0])).
 apply MapArgEq.
 apply EqualInPair'.
 split.
  apply IsRightIdentTheorem.
  apply IsIdent_RightIdent.
  generalize NN0IsIdent.
  apply RelRewriteR.
  rewrite NNMultTheorem0.
  hyperreflexivity.
 apply (TransitivityEq (%NNAdd [nat_to_NN 0 ; nat_to_NN 0])).
  apply MapArgEq.
  apply EqualInPair'.
  split.
  apply NNMultTheorem0.
  rewrite NNMult_Ope_CommCond.
  apply NNMultTheorem0.
 apply IsLeftIdentTheorem.
 apply IsIdent_LeftIdent.
 apply NN0IsIdent.
rewrite <- NN_to_ZZ_is_NNNN_to_ZZ.
hyperreflexivity.
Qed.

Theorem ZZMult_comm_NNMult : forall n1 n2,
%NN_to_ZZ (%NNMult [n1;n2]) ==
%ZZMult [%NN_to_ZZ n1 ; %NN_to_ZZ n2].
Proof.
put NNMult_to_ZZMult_Hom HomH.
put ((proj1 (IsHomomorphism_of_BOpeTheorem _ _ _)) HomH) comm.
apply comm.
Qed.

Theorem ZZMult_CommCond : Ope_CommCond ZZMult.
Proof.
intros a b.
put (ZZIsNNNN a) Eqa.
destruct Eqa as [s Eqa].
destruct Eqa as [t Eqa].
put (ZZIsNNNN b) Eqb.
destruct Eqb as [m Eqb].
destruct Eqb as [n Eqb].
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ Eqa)).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ Eqb)).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ Eqa)).
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ Eqb)).
rewrite ZZMultTheorem_NNNN.
rewrite ZZMultTheorem_NNNN.
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (MapArgEq _ (EqualInPair'L _ _ _ _ _ (NNMult_Ope_CommCond _ _))))).
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (MapArgEq _ (EqualInPair'R _ _ _ _ _ (NNMult_Ope_CommCond _ _))))).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (MapArgEq _ (EqualInPair'L _ _ _ _ _ (NNMult_Ope_CommCond _ _))))).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (MapArgEq _ (EqualInPair'R _ _ _ _ _ (NNMult_Ope_CommCond _ _))))).
apply MapArgEq.
apply EqualInPair'R.
apply NNAdd_Ope_CommCond.
Qed.

Theorem ZZMult_SGrpCond : Ope_SGrpCond ZZMult.
Proof.
intros x y z.
put (ZZIsNNNN x) Eqx.
destruct Eqx as [a Eqx].
destruct Eqx as [b Eqx].
put (ZZIsNNNN y) Eqy.
destruct Eqy as [c Eqy].
destruct Eqy as [d Eqy].
put (ZZIsNNNN z) Eqz.
destruct Eqz as [e Eqz].
destruct Eqz as [f Eqz].
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (MapArgEq _ (EqualInPair'L _ _ _ _ _ Eqx)))).
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (MapArgEq _ (EqualInPair'R _ _ _ _ _ Eqy)))).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ Eqz)).
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ Eqx)).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (MapArgEq _ (EqualInPair'L _ _ _ _ _ Eqy)))).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (MapArgEq _ (EqualInPair'R _ _ _ _ _ Eqz)))).
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (ZZMultTheorem_NNNN _ _ _ _))).
rewrite ZZMultTheorem_NNNN.
apply SymmetryEq.
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (ZZMultTheorem_NNNN _ _ _ _))).
rewrite ZZMultTheorem_NNNN.

apply MapArgEq.
apply EqualInPair'.
split.
 rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (NNAdd_NNMultLDistDond _ _ _))).
 rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (NNAdd_NNMultLDistDond _ _ _))).
 apply SymmetryEq.
 rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (NNAdd_NNMultRDistDond _ _ _))).
 rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (NNAdd_NNMultRDistDond _ _ _))).
 rewrite NNAdd_Ope_SGrpCond.
 rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (NNAdd_Ope_CommCond _ _))).
 rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (NNAdd_Ope_SGrpCond _ _ _))).
 rewrite <- NNAdd_Ope_SGrpCond.
 apply MapArgEq.
 apply EqualInPair'.
 split;
 apply MapArgEq;
 apply EqualInPair';
 split;
 apply NNMult_Ope_SGrpCond.

 rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (NNAdd_NNMultLDistDond _ _ _))).
 rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (NNAdd_NNMultLDistDond _ _ _))).
 apply SymmetryEq.
 rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (NNAdd_NNMultRDistDond _ _ _))).
 rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (NNAdd_NNMultRDistDond _ _ _))).
 rewrite NNAdd_Ope_SGrpCond.
 rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (NNAdd_Ope_CommCond _ _))).
 rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (NNAdd_Ope_SGrpCond _ _ _))).
 rewrite <- NNAdd_Ope_SGrpCond.
 apply MapArgEq.
 apply EqualInPair'.
 split;
 apply MapArgEq;
 apply EqualInPair';
 split;
 apply NNMult_Ope_SGrpCond.
Qed.

Theorem ZZAddMult_DistDond :
Ope2_DistDond ZZAdd ZZMult.
Proof.
apply Dist_LDistCommCond.
 apply ZZMult_CommCond.
intros x y z.
put (ZZIsNNNN x) Eqx.
destruct Eqx as [a Eqx].
destruct Eqx as [b Eqx].
put (ZZIsNNNN y) Eqy.
destruct Eqy as [c Eqy].
destruct Eqy as [d Eqy].
put (ZZIsNNNN z) Eqz.
destruct Eqz as [e Eqz].
destruct Eqz as [f Eqz].
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ Eqx)).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (MapArgEq _ (EqualInPair'L _ _ _ _ _ Eqy)))).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (MapArgEq _ (EqualInPair'R _ _ _ _ _ Eqz)))).
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (MapArgEq _ (EqualInPair'L _ _ _ _ _ Eqx)))).
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (MapArgEq _ (EqualInPair'R _ _ _ _ _ Eqy)))).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (MapArgEq _ (EqualInPair'L _ _ _ _ _ Eqx)))).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (MapArgEq _ (EqualInPair'R _ _ _ _ _ Eqz)))).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (ZZAddTheorem_NNNN _ _ _ _))).
rewrite ZZMultTheorem_NNNN.
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (MapArgEq _ (EqualInPair'L _ _ _ _ _ (NNAdd_NNMultLDistDond _ _ _))))).
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (MapArgEq _ (EqualInPair'R _ _ _ _ _ (NNAdd_NNMultLDistDond _ _ _))))).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (MapArgEq _ (EqualInPair'L _ _ _ _ _ (NNAdd_NNMultLDistDond _ _ _))))).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (MapArgEq _ (EqualInPair'R _ _ _ _ _ (NNAdd_NNMultLDistDond _ _ _))))).
apply SymmetryEq.
rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ (ZZMultTheorem_NNNN _ _ _ _))).
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (ZZMultTheorem_NNNN _ _ _ _))).
rewrite ZZAddTheorem_NNNN.

apply MapArgEq.
apply EqualInPair'.
split.
 rewrite NNAdd_Ope_SGrpCond.
 apply SymmetryEq.
 rewrite NNAdd_Ope_SGrpCond.
 apply MapArgEq.
 apply EqualInPair'R.
 rewrite <- NNAdd_Ope_SGrpCond.
 apply SymmetryEq.
 rewrite <- NNAdd_Ope_SGrpCond.
 apply MapArgEq.
 apply EqualInPair'L.
 apply NNAdd_Ope_CommCond.

 rewrite NNAdd_Ope_SGrpCond.
 apply SymmetryEq.
 rewrite NNAdd_Ope_SGrpCond.
 apply MapArgEq.
 apply EqualInPair'R.
 rewrite <- NNAdd_Ope_SGrpCond.
 apply SymmetryEq.
 rewrite <- NNAdd_Ope_SGrpCond.
 apply MapArgEq.
 apply EqualInPair'L.
 apply NNAdd_Ope_CommCond.
Qed.

Theorem ZZAddMult_LDistDond : Ope2_LDistDond ZZAdd ZZMult.
Proof.
apply Ope2_LDist.
apply Dist_LDist.
apply Ope2_Dist.
apply ZZAddMult_DistDond.
Qed.

Theorem ZZAddMult_RDistDond : Ope2_RDistDond ZZAdd ZZMult.
Proof.
apply Ope2_RDist.
apply Dist_RDist.
apply Ope2_Dist.
apply ZZAddMult_DistDond.
Qed.

Theorem NNAdd_NNMultRDistDond : Ope2_RDistDond NNAdd NNMult.
Proof.
apply Ope2_RDist.
apply Dist_RDist.
apply Ope2_Dist.
apply NNAdd_NNMultDistDond.
Qed.

Theorem ZZMultTheorem1 : forall n,
%ZZMult [n;nat_to_ZZ 1] == n.
Proof.
intro n.
put (ZZIsNNNN n) Eqn.
destruct Eqn as [a Eqn].
destruct Eqn as [b Eqn].
apply (TransitivityEq (%ZZMult [%NNNN_to_ZZ [a;b] ; %NNNN_to_ZZ [nat_to_NN 1 ; nat_to_NN 0]])).
 apply MapArgEq.
 apply EqualInPair'.
 split.
 apply Eqn.
 rewrite <- NN_to_ZZ_is_NNNN_to_ZZ.
 hyperreflexivity.
rewrite ZZMultTheorem_NNNN.
rewrite Eqn.
apply MapArgEq.
apply EqualInPair'.
split.
 apply (TransitivityEq (%NNAdd [a;nat_to_NN 0])).
  apply MapArgEq.
  apply EqualInPair'.
  split.
  apply NNMultTheorem1.
  apply NNMultTheorem0.
 apply IsRightIdentTheorem.
 apply IsIdent_RightIdent.
 apply NN0IsIdent.

 apply (TransitivityEq (%NNAdd [nat_to_NN 0 ; b])).
  apply MapArgEq.
  apply EqualInPair'.
  split.
  apply NNMultTheorem0.
  apply NNMultTheorem1.
 rewrite NNAdd_Ope_CommCond.
 apply NNAddTheorem1.
Qed.

Theorem ZZ1IsIdent : &&IsIdent ZZMult (nat_to_ZZ 1).
Proof.
apply IsIdentTheoremR.
apply ZZMult_CommCond.
apply ZZMultTheorem1.
Qed.

Theorem ZZMultTheorem0 : forall n,
%ZZMult [n ; nat_to_ZZ 0] == nat_to_ZZ 0.
Proof.
intro n.
cut (%ZZAdd [n ; %ZZMult [n;nat_to_ZZ 0]] == n).
 intro EqH.
 apply (TransitivityEq (%ZZAdd [%Minus_of_ZZ n ; %ZZAdd [n ;%ZZMult [n;nat_to_ZZ 0]]])).
  apply SymmetryEq.
  rewrite <- ZZAdd_SGrpCond.
  apply IsLeftIdentTheorem.
  apply IsIdent_LeftIdent.
  apply IsInverseE_IsIdent'.
  apply Minus_of_ZZTheorem.
 rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ EqH)).
 apply (IsIdentEq ZZAdd).
  apply IsInverseE_IsIdent'.
  apply Minus_of_ZZTheorem.
 apply ZZ0IsIdent.
apply (TransitivityEq (%ZZAdd [%ZZMult [n ; nat_to_ZZ 1] ; %ZZMult [n ; nat_to_ZZ 0]])).
 apply MapArgEq.
 apply EqualInPair'L.
 apply SymmetryEq.
 apply ZZMultTheorem1.
rewrite <- ZZAddMult_LDistDond.
apply IsRightIdentTheorem.
apply IsIdent_RightIdent.
generalize ZZ1IsIdent.
apply RelRewriteR.
apply SymmetryEq.
apply ZZAddTheorem0.
Qed.

Theorem ZZMultTheoremNext : forall n m,
%ZZMult [n;%ZZNext m] == %ZZAdd [%ZZMult [n;m] ; n].
Proof.
intros n m.
rewrite (MapArgEq _ (EqualInPair'R _ _ _ _ _ (ZZNextTheorem _))).
rewrite ZZAddMult_LDistDond.
apply MapArgEq.
apply EqualInPair'R.
apply ZZMultTheorem1.
Qed.

Theorem ZZMultTheoremMinus : forall n m,
%ZZMult [n ; %Minus_of_ZZ m] ==
%Minus_of_ZZ (%ZZMult [n;m]).
Proof.
intros n m.
cut (%ZZAdd [%ZZMult [n;%Minus_of_ZZ m] ; %ZZMult[n;m]] == nat_to_ZZ 0).
 intro EqH.
 apply (TransitivityEq (%ZZAdd [%ZZAdd [%ZZMult [n;%Minus_of_ZZ m] ; %ZZMult [n;m]] ; %Minus_of_ZZ (%ZZMult [n;m])])).
  apply SymmetryEq.
  rewrite ZZAdd_SGrpCond.
  apply IsRightIdentTheorem.
  apply IsIdent_RightIdent.
  apply IsInverseE_IsIdent.
  apply Minus_of_ZZTheorem.
 rewrite (MapArgEq _ (EqualInPair'L _ _ _ _ _ EqH)).
 apply IsLeftIdentTheorem.
 apply IsIdent_LeftIdent.
 apply ZZ0IsIdent.
rewrite <- ZZAddMult_LDistDond.
apply (TransitivityEq (%ZZMult [n ; nat_to_ZZ 0])).
 apply MapArgEq.
 apply EqualInPair'R.
 apply (IsIdentEq ZZAdd).
  apply IsInverseE_IsIdent'.
  apply Minus_of_ZZTheorem.
 apply ZZ0IsIdent.
apply ZZMultTheorem0.
Qed.

Theorem ZZMult_IdentCond : Ope_IdentCond ZZMult.
Proof.
exists (nat_to_ZZ 1).
apply ZZ1IsIdent.
Qed.

Theorem ZZMult_MonoidCond : Ope_MonoidCond ZZMult.
Proof.
split.
apply ZZMult_SGrpCond.
apply ZZMult_IdentCond.
Qed.

Theorem ZZMult_CMonoidCond : Ope_CMonoidCond ZZMult.
Proof.
split.
apply ZZMult_MonoidCond.
apply ZZMult_CommCond.
Qed.

Theorem ZZAddMult_CRingDond : Ope2_CRingDond ZZAdd ZZMult.
Proof.
split.
apply ZZAdd_CGrpCond.
split.
apply ZZMult_CMonoidCond.
apply ZZAddMult_DistDond.
Qed.

Theorem ZZAddMult_RingDond : Ope2_RingDond ZZAdd ZZMult.
Proof.
apply Ope2_Ring.
apply CRing_Ring.
apply Ope2_CRing.
apply ZZAddMult_CRingDond.
Qed.


Require Export Duals SmallCat.

Set Implicit Arguments.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Section OppositeCategory.
  Definition SmallOppositeFunctor : SpecializedFunctor SmallCat SmallCat.
    refine (Build_SpecializedFunctor SmallCat SmallCat
                                     (fun x => OppositeCategory x : SmallSpecializedCategory _)
                                     (fun _ _ m => OppositeFunctor m)
                                     _
                                     _);
    simpl; abstract functor_eq.
  Defined.

  Definition LocallySmallOppositeFunctor : SpecializedFunctor LocallySmallCat LocallySmallCat.
    refine (Build_SpecializedFunctor LocallySmallCat LocallySmallCat
                                     (fun x => OppositeCategory x : LocallySmallSpecializedCategory _)
                                     (fun _ _ m => OppositeFunctor m)
                                     _
                                     _);
    simpl; abstract functor_eq.
  Defined.
End OppositeCategory.


(* Measure Semantics *)

Require Import Coq.Lists.List.
Require Import Coq.Logic.FunctionalExtensionality.

Require Import Coq.Lists.List.
Require Import Coq.Logic.FunctionalExtensionality.

Require Import LiftedTypes.
Require Import Weights.
Require Import MyReals. (* including times: Weight -> real -> real *)
Require Import Measures.
Require Import Types.   (* including variables and environments *)
Require Import Syntax.

Function den_typeM (t : Otype) : Type :=
  match t with
    | Stype m => (den_Mtype m)
    | Funtype t u => (den_typeM t) -> (lifted (den_typeM u))
    | Meastype m => Measure (den_Mtype m)
  end.

Function strict2 {A B C : Type}
         (d1 : lifted A)
         (d2 : lifted B)
         (f  : A -> B -> lifted C)
         : lifted C
  :=
    (strict d1 (fun a => (strict d2 (fun b => (f a b))))).

(* turn fn u => u into an integrator *)
Definition uniformopM : (den_typeM (Meastype Real_type))
  := fun k => mu_L (fun u => k (unit_real u)).
Hint Unfold uniformopM.

(* Definition distvalM : (den_typeM (Meastype Real_Mtype)) *)
(*   := mu_1. *)
(* Hint Unfold distvalM. *)

Definition returnopM {m : Mtype}
           (v : (den_Mtype m)) : (den_typeM (Meastype m))
  :=
    fun k => k v.
Hint Unfold returnopM.

Definition bindopM
           {o o' : Mtype}
           (mu : (den_typeM (Meastype o)))
           (f :  (den_typeM (Stype o)) ->
                 (lifted (den_typeM (Meastype o'))))
           : (den_typeM (Meastype o'))
  := fun (k : (den_typeM (Stype o')) -> real)
     => mu (fun a => strict0 (f a) (fun mu' => (mu' k))).
Hint Unfold bindopM.

(* Coercion, needed to make den_val typecheck *)
Function coerce_realM (w : real) : (den_typeM (Stype Real_type)) := w.
Hint Unfold coerce_realM.

(* The denotations of values and expressions in the measure semantics *)

Function den_valM {G o} (val : Val G o) (r : (@den_env den_typeM G))
         : (den_typeM o)
  :=
    match val with
    | constexp w => (coerce_realM w)
    | prodval v1 v2 => (den_valM v1 r, den_valM v2 r)
      | varexp var => (apply_env r var)
      | absexp e => (fun val => den_expM e (cons_env val r))
      | uniformval => uniformopM
      | distval v => mu_1 (den_valM v r)
      | bindval s f => bindopM (den_valM s r) (den_valM f r)
      | returnval v => returnopM (den_valM v r)
    end
with
den_expM {G o} (exp : (Exp  G o)) (r : (den_env G)) : (lifted (den_typeM o))
:=
  match exp with
  | valexp val => lift (den_valM val r)
  | prodexp e1 e2 => strict2 (den_expM e1 r) (den_expM e2 r)
                             (fun v1 v2 => (lift (v1, v2)))
  | proj1exp e => strict (den_expM e r) (fun p => (lift (fst p)))
  | proj2exp e => strict (den_expM e r) (fun p => (lift (snd p)))
  | appexp e1 e2 => strict2 (den_expM e1 r) (den_expM e2 r) (fun f a => (f a))
  | returnexp e1 => strict (den_expM e1 r)
                           (fun a => (lift (returnopM a)))
  | bindexp e1 e2 =>  strict2 (den_expM e1 r) (den_expM e2 r)
                              (fun s f => (lift (bindopM s f)))
  end.


Require Export Coq.Lists.List
               Fiat.BinEncoders.NoEnv.Libraries.FixInt.
Require Import Fiat.BinEncoders.NoEnv.Specs
               Fiat.BinEncoders.NoEnv.Libraries.Sig
               Coq.omega.Omega.

Set Implicit Arguments.

Section FixListEncoder.
  Variable (A : Type)
           (B : Type)
           (size : nat)
           (encode_A : A * B -> B)
           (predicate_A : A -> Prop)
           (decoder_A : decoder (fun bundle => predicate_A (fst bundle)) encode_A).

  Definition data_t := { xs : list A | length xs < exp2_nat size }.

  Definition FixList_getlength
             (ls : data_t) : {n : N | (n < exp2 size)%N}.
    refine (exist _ (N_of_nat (length (proj1_sig ls))) _).
    destruct ls as [ xs xs_pf ]. unfold exp2_nat in xs_pf. simpl.
    rewrite <- Nnat.N2Nat.id. rewrite <- N.compare_lt_iff.
    rewrite <- Nnat.Nat2N.inj_compare.
    rewrite <- Compare_dec.nat_compare_lt.
    eauto.
  Defined.

  Definition FixList_predicate (len : {n : N | (n < exp2 size)%N}) (bundle : data_t * B) :=
    FixList_getlength (fst bundle) = len /\
    forall x, In x (proj1_sig (fst bundle)) -> predicate_A x.

  Fixpoint encode' (xs : list A) (ext : B) :=
    match xs with
      | nil => ext
      | x :: xs => encode_A (x, encode' xs ext)
    end.

  Definition FixList_encode (bundle : data_t * B) := encode' (proj1_sig (fst bundle)) (snd bundle).

  Fixpoint decode' (len : nat) (b : B) :=
    match len with
    | O => (nil, b)
    | S size' => let (_data, _bin) := @decode _ _ _ _ decoder_A b in
                 let (_rest, _bin') := decode' size' _bin in
                     (_data :: _rest, _bin')
    end.

  Lemma decode'_length :
    forall len bin, length (fst (decode' len bin)) = len.
  Proof.
    induction len; intuition eauto.
    simpl. destruct (decode bin).
    specialize (IHlen b). destruct (decode' len b). simpl. f_equal. eauto.
  Qed.

  Lemma exp2_nat_nonzero :
    forall size, exp2_nat size <> O.
  Proof.
    assert (forall size, exp2_nat size > O) as lt_pf.
    intro s. unfold exp2_nat. unfold exp2. rewrite positive_N_nat.
    destruct (Pos2Nat.is_succ (exp2' s)). rewrite H. eapply gt_Sn_O.
    intro s. specialize (lt_pf s). omega.
  Qed.

  Definition FixList_decode (len : nat) (b : B) : data_t * B.
    refine (exist _ (fst (decode' (min (pred (exp2_nat size)) len) b)) _, snd (decode' len b)).
    rewrite decode'_length.
    rewrite NPeano.Nat.min_lt_iff.
    left. unfold lt.
    rewrite NPeano.Nat.succ_pred; [ | eapply exp2_nat_nonzero ]; eauto.
  Defined.

  Theorem FixList_encode_decode_correct :
    forall len, encode_decode_correct (FixList_predicate len)
                                      FixList_encode
                                      (FixList_decode (nat_of_N (proj1_sig len))).
  Proof.
    unfold encode_decode_correct, FixList_predicate, FixList_encode, FixList_decode.
    intros [len len_pf] [[data data_pf] ext] pred_pf. simpl.
    assert (min (pred (exp2_nat size)) (N.to_nat len) = N.to_nat len) as pmin.
    rewrite Min.min_r; eauto. eapply NPeano.Nat.lt_le_pred. unfold exp2_nat.
    eapply nat_compare_lt. rewrite <- Nnat.N2Nat.inj_compare. eauto.
    f_equal. eapply sig_equivalence; try rewrite pmin; clear pmin.
    - generalize dependent len. generalize dependent data.
      induction data; intros data_pf len len_pf [psize pin]; simpl in *.
      + inversion psize. eauto.
      + inversion psize.
        assert (length data < exp2_nat size) as data_pf' by omega.
        assert (N.lt (N.pred len) (exp2 size)) as len_pf' by (eapply N.lt_lt_pred; eauto).
        assert ( FixList_getlength
             (exist (fun xs : list A => length xs < exp2_nat size) data
                data_pf') =
           exist (fun n : N => (n < exp2 size)%N) (N.pred len) len_pf' /\
           (forall x : A, In x data -> predicate_A x)) as IHdata_pf.
        split; eauto. eapply sig_equivalence. simpl.
        rewrite <- H0. simpl.
        clear. destruct (length data). eauto. simpl. rewrite Pos.pred_N_succ. eauto.
        specialize (IHdata data_pf' (N.pred len) len_pf' IHdata_pf).
        rewrite <- H0 in IHdata. rewrite Nnat.N2Nat.inj_pred in IHdata.
        destruct (N.to_nat (N.pos (Pos.of_succ_nat (length data)))) eqn: eq.
        inversion eq. rewrite SuccNat2Pos.id_succ in H1. inversion H1.
        simpl in *. rewrite (@decode_correct _ _ _ _ decoder_A); eauto.
        simpl in *. destruct (decode' n (encode' data ext)).
        simpl in *. subst. reflexivity.
    - clear pmin. generalize dependent len. generalize dependent data.
      induction data; intros data_pf len len_pf [psize pin]; simpl in *.
      + inversion psize. eauto.
      + inversion psize.
        assert (length data < exp2_nat size) as data_pf' by omega.
        assert (N.lt (N.pred len) (exp2 size)) as len_pf' by (eapply N.lt_lt_pred; eauto).
        assert ( FixList_getlength
             (exist (fun xs : list A => length xs < exp2_nat size) data
                data_pf') =
           exist (fun n : N => (n < exp2 size)%N) (N.pred len) len_pf' /\
           (forall x : A, In x data -> predicate_A x)) as IHdata_pf.
        split; eauto. eapply sig_equivalence. simpl.
        rewrite <- H0. simpl.
        clear. destruct (length data). eauto. simpl. rewrite Pos.pred_N_succ. eauto.
        specialize (IHdata data_pf' (N.pred len) len_pf' IHdata_pf).
        rewrite <- H0 in IHdata. rewrite Nnat.N2Nat.inj_pred in IHdata.
        destruct (N.to_nat (N.pos (Pos.of_succ_nat (length data)))) eqn: eq.
        inversion eq. rewrite SuccNat2Pos.id_succ in H1. inversion H1.
        simpl in *. rewrite (@decode_correct _ _ _ _ decoder_A); eauto.
        simpl in *. destruct (decode' n (encode' data ext)).
        simpl in *. subst. reflexivity.
  Qed.
End FixListEncoder.

Global Instance FixList_decoder
       (A : Type)
       (B : Type)
       (size : nat)
       (len : {n : N | (n < exp2 size)%N})
       (predicate_A : A -> Prop)
       (encode_A : A * B -> B)
       (decoder_A : decoder (fun bundle => predicate_A (fst bundle)) encode_A)
  : decoder (FixList_predicate predicate_A len)
            (FixList_encode (size:=size) encode_A) :=
  { decode := FixList_decode size predicate_A decoder_A (nat_of_N (proj1_sig len));
    decode_correct := @FixList_encode_decode_correct _ _ _ _ _ _ _ }.

Arguments FixList_predicate / _ _ _ _ _ _.
Arguments FixList.data_t / _ _.


Require Import XR_Rabs.
Require Import XR_Rcase_abs.
Require Import XR_Ropp_0.
Require Import XR_Ropp_le_contravar.
Require Import XR_Ropp_lt_cancel.
Require Import XR_Rlt_le_trans.

Local Open Scope R_scope.

Lemma Rabs_def2 : forall x a:R, Rabs x < a -> x < a /\ - a < x.
Proof.
  intros x y h.
  unfold Rabs in h.
  destruct (Rcase_abs x) as [ hx | hx ].
  {
    split.
    {
      apply Rlt_trans with R0.
      { exact hx. }
      {
        apply Rlt_trans with (-x).
        {
          rewrite <- Ropp_0.
          apply Ropp_lt_contravar.
          exact hx.
        }
        { exact h. }
      }
    }
    {
      apply Ropp_lt_cancel.
      rewrite Ropp_involutive.
      exact h.
    }
  }
  {
    split.
    { exact h. }
    {
      apply Rlt_le_trans with R0.
      {
        apply Rlt_le_trans with (-x).
        {
          apply Ropp_lt_contravar.
          exact h.
        }
        {
          rewrite <- Ropp_0.
          apply Ropp_le_contravar.
          exact hx.
        }
      }
      { exact hx. }
    }
  }
Qed.


Require Import List. Import ListNotations.
Open Scope list_scope.
Require Import db assembly util.

Infix ";" := instr (at level 30, right associativity).
Fixpoint var_inst (i : nat) : BasicBlock := match i with
  | 0 => push EP ;
         push (RC 0) ;
         mov (EP%0) R1 ;
         mov (EP%1) EP ;
         jump None R1
  | S i => mov (EP%2) EP ;
           var_inst i
  end.

(* Assembles deBruijn indices to instructions *)
Fixpoint assemble (t : tm) (k : nat) : Program := match t with
  | var v => [var_inst v]
  | app m n => let ms := assemble m (1+k) in
               let nk := 1+k+length ms in
                push EP ;
                push (RC nk) ;
                jump None (RC (1+k)) ::
                ms ++
                assemble n nk
  | lam b => pop R1 ;
             jump (Some (RW (WR R1), (1+k))) (RC (2+k)) ::
             (*Update*)
             pop R1 ;
             mov (RC k) (R1%0) ;
             mov EP (R1%1) ;
             jump None (RC k) ::
             (*Take*)
             new 3 R2 ;
             mov R1 (R2%0);
             pop (R2%1) ;
             mov EP (R2%2) ;
             mov R2 EP ;
             jump None (3+k) ::
             assemble b (3+k)
  end.


(* from Jason Gross *)

Definition key : unit. exact tt. Qed.
Definition locked A (x:A) : A := match key with tt => x end.
Lemma unlock A x : x = locked A x.
  unfold locked. destruct key. reflexivity.
Defined.
Record total {T} ( P: T -> Type ) := tpair { pr1 : T; pr2 : P pr1 }.
Definition morfun (o:Type) := o -> o -> Type.
Definition category := total morfun.
Definition make_cat := tpair _ morfun.
Parameter o : Type.
Parameter m m' : o -> o -> Type.
Definition C := make_cat o m.
Definition C':= make_cat o m'.
Parameter x : o.
Definition ob (C:category) := pr1 _ C.
Check x : ob C.
Check x : ob C'.
Definition iso {C:category} (a b:ob C) := unit.
Definition funny (a:ob C) (b:ob C') := iso a b.
Definition ob' : category -> Type :=
  locked (category -> Type) (fun C : category => ob C).
Definition iso' {C:category} (a b:ob' C) := unit.
(* Definition funny' (a:ob' C) (b:ob' C') := iso' a b. (* <-- fails, good *) *)
Definition open {C} : ob' C -> ob C.
  unfold ob',locked. destruct key. exact (fun c => c).
Defined.
Definition close {C} : ob C -> ob' C.
  unfold ob',locked. destruct key. exact (fun c => c).
Defined.
Definition iso2' {C:category} (a b:ob' C) := iso (open a) (open b).


Require Import Logic.lib.Coqlib.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.MinimunLogic.ProofTheory.Minimun.
Require Import Logic.MinimunLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.ProofTheory.RewriteClass.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.ProofTheory.RewriteClass.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.

Section WandFrame.

Context {L: Language}
        {minL: MinimunLanguage L}
        {pL: PropositionalLanguage L}
        {sL: SeparationLanguage L}
        {Gamma: ProofTheory L}
        {minAX: MinimunAxiomatization L Gamma}
        {ipGamma: IntuitionisticPropositionalLogic L Gamma}
        {sGamma: SeparationLogic L Gamma}.

Lemma wand_frame_intros: forall (x y: expr),
  |-- x --> (y -* x * y).
Proof.
  intros.
  apply wand_sepcon_adjoint.
  apply provable_impp_refl.
Qed.

Lemma wand_frame_elim: forall (x y: expr),
  |-- x * (x -* y) --> y.
Proof.
  intros.
  apply provable_wand_sepcon_modus_ponens2.
Qed.

Lemma wand_frame_ver: forall (x y z: expr),
  |-- (x -* y) * (y -* z) --> (x -* z).
Proof.
  intros.
  rewrite <- wand_sepcon_adjoint.
  rewrite sepcon_comm, sepcon_assoc.
  rewrite !wand_frame_elim.
  apply provable_impp_refl.
Qed.

Lemma wand_frame_hor: forall (x1 y1 x2 y2: expr),
  |-- (x1 -* y1) * (x2 -* y2) --> (x1 * x2 -* y1 * y2).
Proof.
  intros.
  rewrite <- wand_sepcon_adjoint.
  rewrite sepcon_assoc, (sepcon_comm _ x1), sepcon_assoc.
  rewrite wand_frame_elim.
  rewrite <- sepcon_assoc, (sepcon_comm _ x2).
  rewrite wand_frame_elim.
  apply provable_impp_refl.
Qed.

End WandFrame.


From Hammer Require Import Hammer.

Set Implicit Arguments.

Require Import List.
Require Import Le.
Require Import Lt.
Require Import Plus.
Require Import Arith.
From QuicksortComplexity Require Import monads.
From QuicksortComplexity Require Import util.
From QuicksortComplexity Require Import monoid_monad_trans.
From QuicksortComplexity Require Import sums_and_averages.
Require Import Rbase.
Require Import Fourier.
From QuicksortComplexity Require ne_tree_monad.

Section contents.

Variable m: Monoid.
Variable X: Set.

Definition pick (l: ne_list.L X): MonoidMonadTrans.M m ne_tree_monad.ext X
:= lift (MonoidMonadTrans.T m) ne_tree_monad.ext X (ne_tree_monad.pick l).

Lemma pick_toLower:
ext_eq pick (@ne_tree_monad.pick _ ∘ ne_list.map (pair (monoid_zero m))).
Proof with auto. hammer_hook "monoid_tree_monad" "monoid_tree_monad.pick_toLower".
unfold compose, ext_eq.
unfold pick.
unfold lift.
simpl.
unfold ne_tree_monad.pick.
intros.
unfold compose.
simpl.
repeat rewrite ne_list.map_map...
Qed.

Lemma In_pick_inv (l: ne_list.L X) (r: prod m X):
ne_tree.In r (pick l) -> fst r = monoid_zero m /\ In (snd r) (ne_list.to_plain l).
Proof with auto. hammer_hook "monoid_tree_monad" "monoid_tree_monad.In_pick_inv".
unfold pick.
simpl.
rewrite ne_list.map_map.
intros.
inversion_clear H.
induction l.
simpl in H0.
inversion_clear H0.
rewrite comp_apply in H.
simpl in H.
rewrite comp_apply in H.
inversion_clear H.
simpl.
firstorder.
simpl in H0.
inversion_clear H0.
rewrite comp_apply in H.
simpl in H.
rewrite comp_apply in H.
simpl in H.
inversion_clear H.
simpl.
firstorder.
destruct (IHl H).
firstorder; try right...
Qed.

End contents.


Require Import List.
Import ListNotations.
Require Import Coq.Lists.ListSet.
Require Import Coq.Program.Equality.
Require Import Omega.
Require Import Extraction.

Require Import Unification.
Require Import Streams.
Require Import Language.
Require Import DenotationalSem.
Require Import OperationalSem.

(******************************** States ****************************)

(* Non-terminal state *)
Inductive nt_state : Set :=
    Leaf : forall (theta : subst) (i : nat) (r : list (name * term)), nt_state
  | Sum  : forall (left right : nt_state), nt_state.

(* State *)
Inductive state : Set :=
  Stop    : state
| NTState : forall (st : nt_state), state.

(* Functions on states *)
Fixpoint union (x y : state) : state :=
  match x with
  | Stop       => y
  | NTState sx => match y with
                  | Stop       => x
                  | NTState sy => NTState (Sum sx sy)
                  end
  end.

(* The context is represented as a list zipper *)
Definition context : Set := (list (name * term) * list (name * term)).

Fixpoint push_nt (ctx : context) (st : nt_state) : nt_state :=
  match st with
  | Sum l r        => Sum (push_nt ctx l) (push_nt ctx r)
  | Leaf theta i r => Leaf theta i (concat [fst ctx; r; snd ctx])
  end.

Definition push (ctx : context) (st : state) : state :=
  match st with
  | Stop => Stop
  | NTState st => NTState (push_nt ctx st)
  end.

(* Free variables of nt_state *)
Inductive is_fv_of_nt_state : name -> nt_state -> Prop :=
| isfvnstLeaf  : forall x theta i r
                        (X_FV_R    : Exists (fun p => In x (fv_term (snd p))) r)
                        (X_IN_DOM  : in_subst_dom theta x)
                        (X_IN_VRAN : in_subst_vran theta x), is_fv_of_nt_state x (Leaf theta i r)
| isfvnstSumL  : forall x nst1 nst2 (X_FV : is_fv_of_nt_state x nst1),
                                    is_fv_of_nt_state x (Sum nst1 nst2)
| isfvnstSumR  : forall x nst1 nst2 (X_FV : is_fv_of_nt_state x nst2),
                                    is_fv_of_nt_state x (Sum nst1 nst2).

Hint Constructors is_fv_of_nt_state : core.

Inductive is_fv_of_state : name -> state -> Prop :=
| isfvstC : forall x nst (X_FV_NT_ST : is_fv_of_nt_state x nst),
                         is_fv_of_state x (NTState nst).

Hint Constructors is_fv_of_state : core.

Inductive is_counter_of_nt_state : nat -> nt_state -> Prop :=
| iscnstLeaf  : forall theta i r, is_counter_of_nt_state i (Leaf theta i r)
| iscnstSumL  : forall n nst1 nst2 (ISC : is_counter_of_nt_state n nst1),
                                   is_counter_of_nt_state n (Sum nst1 nst2)
| iscnstSumR  : forall n nst1 nst2 (ISC : is_counter_of_nt_state n nst2),
                                   is_counter_of_nt_state n (Sum nst1 nst2).

Hint Constructors is_counter_of_nt_state : core.

Inductive well_formed_nt_state : nt_state -> Prop :=
| wfLeaf : forall theta r frn
           (DOM_LT_COUNTER  : forall x (X_IN_DOM  : in_subst_dom theta x), x < frn)
           (VRAN_LT_COUNTER : forall x (X_IN_VRAN : in_subst_vran theta x), x < frn)
           (FV_LT_COUNTER   : forall x (X_FV      : Exists (fun p => In x (fv_term (snd p))) r), x < frn),
           well_formed_nt_state (Leaf theta frn r)
| wfSum  : forall nst1 nst2 (WF_L : well_formed_nt_state nst1)
                            (WF_R : well_formed_nt_state nst2),
                            well_formed_nt_state (Sum nst1 nst2).

Hint Constructors well_formed_nt_state : core.

(*********************** One-step unfolding *************************)

Reserved Notation "st |- g ~~> st'" (at level 0).

Inductive os_eval : state -> goal -> state -> Prop :=
  osEnd       : forall g,  Stop |- g ~~> Stop
| osUnifyFail : forall theta i r t1 t2
                        (MGU : mgu (apply_subst theta t1) (apply_subst theta t2) None),
    (NTState (Leaf theta i r)) |- Unify t1 t2 ~~> Stop
| osUnifySucc : forall theta theta' i r t1 t2
                        (MGU : mgu (apply_subst theta t1) (apply_subst theta t2) (Some theta')),
    (NTState (Leaf theta i r)) |- Unify t1 t2 ~~> (NTState (Leaf (compose theta theta') i r))
| osApp       : forall theta i r rel t,
    (NTState (Leaf theta i r)) |- Invoke rel t ~~> (NTState (Leaf theta i (concat [r; [(rel, t)]])))
| osFresh     : forall theta r i g st (H : (NTState (Leaf theta (S i) r)) |- g i ~~> st),
    (NTState (Leaf theta i r)) |- Fresh g ~~> st
| osDisjGoal  : forall theta r i g1 g2 st1 st2
                        (H1 : (NTState (Leaf theta i r)) |- g1 ~~> st1)
                        (H1 : (NTState (Leaf theta i r)) |- g2 ~~> st2),
    (NTState (Leaf theta i r)) |- Disj g1 g2 ~~> (union st1 st2)
| osDisjState : forall st1 st2 st3 st4 g
                        (H1 : (NTState st1) |- g ~~> st3)
                        (H2 : (NTState st2) |- g ~~> st4),
    (NTState (Sum st1 st2)) |- g ~~> (union st3 st4)
| osConj      : forall theta i r g1 g2 st st'
                        (H1 : (NTState (Leaf theta i r)) |- g1 ~~> st)
                        (H2 : st |- g2 ~~> st'),
    (NTState (Leaf theta i r)) |- Conj g1 g2 ~~> st'
where "st |- g ~~> st'" := (os_eval st g st').

Inductive unfold : subst -> nat -> name -> term -> state -> Prop :=
  ufIntro : forall theta i rel term st
                    (H : (NTState (Leaf theta i [])) |- (proj1_sig (Language.Prog rel) term) ~~> st),
    unfold theta i rel term st.

(******************* Angelic semantics itself ***********************)

Inductive label : Set :=
  Step   : label
| Answer : subst -> label.

Inductive selected_app : list (name * term) -> ((name * term) * context) -> Prop :=
  saBase : forall p, selected_app [p] (p, ([], []))
| saHead : forall p ps, selected_app (p :: ps) (p, ([], ps))
| saTail : forall h ps p ps1 ps2 (H : selected_app ps (p, (ps1, ps2))),
    selected_app (h :: ps) (p, (h :: ps1, ps2)).

Reserved Notation "st -- l --> st'" (at level 0).

Inductive ang_eval : state -> label -> state -> Prop :=
  angAnswer     : forall theta i, (NTState (Leaf theta i [])) -- (Answer theta) --> Stop
| angConjUnfold : forall theta i r name term ctx st
                         (Hs : selected_app r ((name, term), ctx))
                         (H  : unfold theta i name term st),
    (NTState (Leaf theta i r)) -- Step --> (push ctx st)
| angDisj       : forall st1 st2 lab (H : (NTState st1) -- lab --> Stop),
    (NTState (Sum st1 st2)) -- lab --> (NTState st2)
| angDisjStep   : forall st1 st2 lab st' (H : (NTState st1) -- lab --> (NTState st')),
    (NTState (Sum st1 st2)) -- lab --> (NTState (Sum st2 st'))
  where "st -- l --> st'" := (ang_eval st l st').


Require Import Coq.Logic.ProofIrrelevance.
Require Import Coq.omega.Omega.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.SeparationLogic.Syntax.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.

Class PropositionalVariables: Type := {
  Var: Type
}.

Inductive expr {Sigma: PropositionalVariables}: Type :=
  | andp : expr -> expr -> expr
  | orp : expr -> expr -> expr
  | impp : expr -> expr -> expr
  | falsep : expr
  | sepcon : expr -> expr -> expr
  | wand : expr -> expr -> expr
  | varp : Var -> expr.

Arguments expr: clear implicits.

Instance L {Sigma: PropositionalVariables}: Language :=
  Build_Language (expr Sigma).

Instance minL {Sigma: PropositionalVariables}: MinimumLanguage L :=
  Build_MinimumLanguage L impp.

Instance pL {Sigma: PropositionalVariables}: PropositionalLanguage L :=
  Build_PropositionalLanguage L andp orp falsep.

Instance sepconL {Sigma: PropositionalVariables}: SepconLanguage L :=
  Build_SepconLanguage L sepcon.

Instance wandL {Sigma: PropositionalVariables}: WandLanguage L :=
  Build_WandLanguage L wand.


From iris.program_logic Require Export weakestpre.
From iris.proofmode Require Export proofmode.
From iris_examples.logrel.stlc Require Export lang typing.
From iris.prelude Require Import options.

Reserved Notation "⟦ τ ⟧" (at level 0, τ at level 70).
Reserved Notation "⟦ τ ⟧ₑ" (at level 0, τ at level 70).
Reserved Notation "⟦ Γ ⟧*" (at level 0, Γ at level 70).

(** interp : is a unary logical relation. *)
Section logrel.
Context `{irisGS stlc_lang Σ}.

Fixpoint interp (τ : type) (w : val) : iProp Σ :=
  match τ with
  | TUnit => ⌜w = UnitV⌝
  | TProd τ1 τ2 => ∃ w1 w2, ⌜w = PairV w1 w2⌝ ∧ ⟦ τ1 ⟧ w1 ∧ ⟦ τ2 ⟧ w2
  | TSum τ1 τ2 =>
     (∃ w1, ⌜w = InjLV w1⌝ ∧ ⟦ τ1 ⟧ w1) ∨ (∃ w2, ⌜w = InjRV w2⌝ ∧ ⟦ τ2 ⟧ w2)
  | TArrow τ1 τ2 => □ ∀ v, ⟦ τ1 ⟧ v → WP App (# w) (# v) {{ ⟦ τ2 ⟧ }}
  end%I
where "⟦ τ ⟧" := (interp τ).

Definition interp_expr (τ : type) (e : expr) : iProp Σ :=
  WP e {{ ⟦ τ ⟧ }}%I.

Global Instance interp_persistent τ v : Persistent (⟦ τ ⟧ v).
Proof. revert v; induction τ=> v /=; apply _. Qed.

Global Instance interp_env_base_persistent Γ vs :
  TCForall Persistent (zip_with (λ τ, ⟦ τ ⟧) Γ vs).
Proof.
  revert vs; induction Γ => vs; simpl; destruct vs; constructor; apply _.
Qed.

Definition interp_env (Γ : list type) (vs : list val) : iProp Σ :=
  (⌜length Γ = length vs⌝ ∗ [∗] zip_with (λ τ, ⟦ τ ⟧) Γ vs)%I.

Notation "⟦ Γ ⟧*" := (interp_env Γ).

Global Instance interp_env_persistent Γ vs :
  Persistent (⟦ Γ ⟧* vs) := _.

Lemma interp_env_nil : ⊢ ⟦ [] ⟧* [].
Proof. iSplit; simpl; auto. Qed.
Lemma interp_env_cons Γ vs τ v :
    ⟦ τ :: Γ ⟧* (v :: vs) ⊣⊢ ⟦ τ ⟧ v ∗ ⟦ Γ ⟧* vs.
  Proof.
    rewrite /interp_env /= (assoc _ (⟦ _ ⟧ _)) -(comm _ ⌜(_ = _)⌝%I) -assoc.
    by apply bi.sep_proper; [apply bi.pure_proper; lia|].
  Qed.

Lemma interp_env_length Γ vs : ⟦ Γ ⟧* vs ⊢ ⌜length Γ = length vs⌝.
Proof. by iIntros "[% ?]". Qed.

Lemma interp_env_Some_l Γ vs x τ :
  Γ !! x = Some τ → ⟦ Γ ⟧* vs ⊢ ∃ v, ⌜vs !! x = Some v⌝ ∧ ⟦ τ ⟧ v.
Proof.
  iIntros (?) "[Hlen HΓ]"; iDestruct "Hlen" as %Hlen.
  destruct (lookup_lt_is_Some_2 vs x) as [v Hv].
  { by rewrite -Hlen; apply lookup_lt_Some with τ. }
  iExists v; iSplit; first done. iApply (big_sepL_elem_of with "HΓ").
  apply elem_of_list_lookup_2 with x.
  rewrite lookup_zip_with; by simplify_option_eq.
Qed.

End logrel.

Notation "⟦ τ ⟧" := (interp τ).
Notation "⟦ τ ⟧ₑ" := (interp_expr τ).
Notation "⟦ Γ ⟧*" := (interp_env Γ).


Require Import init.

Require Export linear_base.
Require Import linear_grade_sum.
Require Import linear_extend.
Require Import linear_transformation_space.
Require Import module_category.

Require Import set.
Require Import unordered_list.
Require Import category_initterm.

(* begin hide *)
Section LinearFree.

Context (F : CRingObj) (V : Type).
Let U := cring_U F.
Let UP := cring_plus F.
Let UZ := cring_zero F.
Let UN := cring_neg F.
Let UPA := cring_plus_assoc F.
Let UPC := cring_plus_comm F.
Let UPZ := cring_plus_lid F.
Let UPN := cring_plus_linv F.
Let UM := cring_mult F.
Let UO := cring_one F.
Let UMA := cring_mult_assoc F.
Let UMC := cring_mult_comm F.
Let UMO := cring_mult_lid F.
Let UMD := cring_ldist F.
Existing Instances UP UZ UN UPA UPC UPZ UPN UM UO UMA UMC UMO UMD.

(* end hide *)
Definition free_linear := grade_sum V (λ _, cring_module F).
Let FV := module_V free_linear.
Let free_plus_class := module_plus free_linear.
Let free_zero := module_zero free_linear.
Let free_neg := module_neg free_linear.
Let free_plus_assoc_class := module_plus_assoc free_linear.
Let free_plus_comm_class := module_plus_comm free_linear.
Let free_plus_lid_class := module_plus_lid free_linear.
Let free_plus_linv_class := module_plus_linv free_linear.
Let free_scalar := module_scalar free_linear.
Let free_scalar_id_class := module_scalar_id free_linear.
Let free_scalar_ldist_class := module_scalar_ldist free_linear.
Let free_scalar_rdist_class := module_scalar_rdist free_linear.
Let free_scalar_comp_class := module_scalar_comp free_linear.
Definition free_grade := grade_sum_grade V (λ _, cring_module F).

Existing Instances free_plus_class free_zero free_neg free_plus_assoc_class
    free_plus_comm_class free_plus_lid_class free_plus_linv_class free_scalar
    free_scalar_id_class free_scalar_ldist_class free_scalar_rdist_class
    free_scalar_comp_class free_grade.

Definition to_free v := single_to_grade_sum V (λ _, cring_module F) (k := v) 1.

Theorem to_free_ex : ∀ (v : V) (x : FV),
    of_grade v x → ∃ α, x = α · to_free v.
Proof.
    intros v x [α x_eq].
    exists α.
    rewrite <- x_eq.
    rewrite <- (mult_rid α) at 1.
    pose (USM := module_scalar (cring_module F)).
    change (α * 1) with (α · 1).
    rewrite (single_to_grade_sum_scalar V (λ _, cring_module F) v α).
    apply f_equal.
    reflexivity.
Qed.

Section FreeExtend.

Context {V2} `{
    VP : Plus V2,
    VZ : Zero V2,
    VN : Neg V2,
    @PlusComm V2 VP,
    @PlusAssoc V2 VP,
    @PlusLid V2 VP VZ,
    @PlusLinv V2 VP VZ VN,

    SM : ScalarMult U V2,
    @ScalarId U V2 UO SM,
    @ScalarLdist U V2 VP SM,
    @ScalarRdist U V2 UP VP SM,
    @ScalarComp U V2 UM SM
}.

Variable f_base : V → V2.
Let f1 (i : V) (v : FV) (H : of_grade i v) := ex_val H · f_base i.

Lemma free_extend_plus_base : linear_extend_plus_base f1.
Proof.
    intros u v i iu iv.
    unfold f1.
    rewrite_ex_val a a_eq.
    rewrite_ex_val b b_eq.
    rewrite_ex_val c c_eq.
    rewrite <- scalar_rdist.
    apply rscalar.
    rewrite <- b_eq, <- c_eq in a_eq.
    rewrite <- single_to_grade_sum_plus in a_eq.
    apply single_to_grade_sum_eq in a_eq.
    exact a_eq.
Qed.
Lemma free_extend_scalar_base : linear_extend_scalar_base f1.
Proof.
    intros a v i iv.
    unfold f1.
    rewrite_ex_val b b_eq.
    rewrite_ex_val c c_eq.
    rewrite scalar_comp.
    apply rscalar.
    rewrite <- c_eq in b_eq.
    rewrite <- single_to_grade_sum_scalar in b_eq.
    apply single_to_grade_sum_eq in b_eq.
    exact b_eq.
Qed.

Definition free_extend := linear_extend f1 : FV → V2.
Let f := free_extend.

Theorem free_extend_plus : ∀ a b, f (a + b) = f a + f b.
Proof.
    apply linear_extend_plus.
    -   exact free_extend_plus_base.
    -   exact free_extend_scalar_base.
Qed.

Theorem free_extend_scalar : ∀ a v, f (a · v) = a · f v.
Proof.
    apply linear_extend_scalar.
    -   exact free_extend_plus_base.
    -   exact free_extend_scalar_base.
Qed.

Theorem free_extend_zero : f 0 = 0.
Proof.
    rewrite <- (scalar_lanni 0).
    rewrite free_extend_scalar.
    apply scalar_lanni.
Qed.

Theorem free_extend_neg : ∀ x, f (-x) = -f x.
Proof.
    intros x.
    rewrite <- scalar_neg_one.
    rewrite free_extend_scalar.
    apply scalar_neg_one.
Qed.

Theorem free_extend_free : ∀ v : V, f (to_free v) = f_base v.
Proof.
    intros v.
    unfold f, free_extend.
    assert (of_grade v (to_free v)) as v_grade.
    {
        exists 1.
        unfold to_free.
        reflexivity.
    }
    rewrite (linear_extend_homo (VG := free_grade)
        f1 free_extend_scalar_base v (to_free v) v_grade).
    unfold f1.
    rewrite_ex_val a aH.
    unfold to_free in aH.
    apply single_to_grade_sum_eq in aH.
    rewrite aH.
    apply scalar_id.
Qed.

End FreeExtend.
Section FreeBilinear.

Context {V2} `{
    VP : Plus V2,
    VZ : Zero V2,
    VN : Neg V2,
    @PlusComm V2 VP,
    @PlusAssoc V2 VP,
    @PlusLid V2 VP VZ,
    @PlusLinv V2 VP VZ VN,

    SM : ScalarMult U V2,
    @ScalarId U V2 UO SM,
    @ScalarLdist U V2 VP SM,
    @ScalarRdist U V2 UP VP SM,
    @ScalarComp U V2 UM SM
}.

Variable op : V → V → V2.

Let TP := linear_func_plus V V2.
Let TZ := linear_func_zero V V2.
Let TN := linear_func_neg V V2.
Let TPC := linear_func_plus_comm V V2.
Let TPA := linear_func_plus_assoc V V2.
Let TPZ := linear_func_plus_lid V V2.
Let TPN := linear_func_plus_linv V V2.
Let TSM := linear_func_scalar V V2.
Let TSMO := linear_func_scalar_id V V2.
Let TSML := linear_func_scalar_ldist V V2.
Let TSMR := linear_func_scalar_rdist V V2.
Let TSMC := linear_func_scalar_comp V V2.
Local Existing Instances TP TZ TN TPC TPA TPZ TPN TSM TSMO TSML TSMR TSMC.

Definition free_bilinear_base := free_extend op.
Definition free_bilinear (v : FV) := free_extend (free_bilinear_base v).
Let f := free_bilinear.

Theorem free_bilinear_ldist : ∀ a b c, f a (b + c) = f a b + f a c.
Proof.
    intros a b c.
    unfold f.
    unfold free_bilinear.
    apply free_extend_plus.
Qed.

Theorem free_bilinear_rdist : ∀ a b c, f (a + b) c = f a c + f b c.
Proof.
    intros a b c.
    unfold f.
    unfold free_bilinear.
    unfold free_bilinear_base.
    rewrite free_extend_plus.
    rewrite (grade_decomposition_eq c).
    remember (grade_decomposition c) as l; clear Heql.
    induction l as [|v l] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        do 3 rewrite free_extend_zero.
        rewrite plus_lid.
        reflexivity.
    }
    rewrite ulist_image_add, ulist_sum_add.
    do 3 rewrite free_extend_plus.
    rewrite IHl; clear IHl.
    do 2 rewrite plus_assoc.
    apply rplus.
    rewrite <- plus_assoc.
    rewrite (plus_comm _ (free_extend (free_extend op b) _)).
    rewrite plus_assoc.
    apply rplus.
    destruct v as [v [x vx]]; cbn.
    apply to_free_ex in vx as [α v_eq]; subst v.
    do 3 rewrite free_extend_scalar.
    rewrite <- scalar_ldist.
    apply f_equal.
    do 3 rewrite free_extend_free.
    unfold plus at 1; cbn.
    reflexivity.
Qed.

Theorem free_bilinear_lscalar : ∀ a u v, f (a · u) v = a · f u v.
Proof.
    intros a u v.
    unfold f, free_bilinear, free_bilinear_base.
    rewrite free_extend_scalar.
    rewrite (grade_decomposition_eq v).
    remember (grade_decomposition v) as l; clear v Heql.
    induction l as [|v l] using ulist_induction.
    {
        rewrite ulist_image_end, ulist_sum_end.
        do 2 rewrite free_extend_zero.
        rewrite scalar_ranni.
        reflexivity.
    }
    rewrite ulist_image_add, ulist_sum_add.
    do 2 rewrite free_extend_plus.
    rewrite IHl; clear IHl.
    rewrite scalar_ldist.
    apply rplus.
    destruct v as [v [x vx]]; cbn.
    apply to_free_ex in vx as [α v_eq]; subst v.
    do 2 rewrite free_extend_scalar.
    rewrite scalar_comp.
    rewrite mult_comm.
    rewrite <- scalar_comp.
    apply f_equal.
    do 2 rewrite free_extend_free.
    unfold scalar_mult at 1; cbn.
    reflexivity.
Qed.

Theorem free_bilinear_rscalar : ∀ a u v, f u (a · v) = a · f u v.
Proof.
    intros a u v.
    unfold f, free_bilinear, free_bilinear_base.
    apply free_extend_scalar.
Qed.

Theorem free_bilinear_lanni : ∀ v, f 0 v = 0.
Proof.
    intros v.
    apply plus_lcancel with (f 0 v).
    rewrite <- free_bilinear_rdist.
    do 2 rewrite plus_rid.
    reflexivity.
Qed.

Theorem free_bilinear_ranni : ∀ v, f v 0 = 0.
Proof.
    intros v.
    apply plus_lcancel with (f v 0).
    rewrite <- free_bilinear_ldist.
    do 2 rewrite plus_rid.
    reflexivity.
Qed.

Theorem free_bilinear_lneg : ∀ u v, f (-u) v = -f u v.
Proof.
    intros u v.
    rewrite <- scalar_neg_one.
    rewrite free_bilinear_lscalar.
    apply scalar_neg_one.
Qed.

Theorem free_bilinear_rneg : ∀ u v, f u (-v) = -f u v.
Proof.
    intros u v.
    rewrite <- scalar_neg_one.
    rewrite free_bilinear_rscalar.
    apply scalar_neg_one.
Qed.

Theorem free_bilinear_free : ∀ u v : V, f (to_free u) (to_free v) = op u v.
Proof.
    intros u v.
    unfold f, free_bilinear, free_bilinear_base.
    do 2 rewrite free_extend_free.
    reflexivity.
Qed.

End FreeBilinear.

Definition free_module := make_module
    F
    FV
    free_plus_class
    free_zero
    free_neg
    free_plus_assoc_class
    free_plus_comm_class
    free_plus_lid_class
    free_plus_linv_class
    free_scalar
    free_scalar_id_class
    free_scalar_ldist_class
    free_scalar_rdist_class
    free_scalar_comp_class
.

Record free_from := make_free_from {
    free_from_module : ModuleObj F;
    free_from_f : V → module_V free_from_module;
}.

Definition free_from_set (f g : free_from)
    (h : cat_morphism (MODULE F)
                      (free_from_module f)
                      (free_from_module g))
    := ∀ x, h (free_from_f f x) = free_from_f g x.

Definition free_from_compose {F G H : free_from}
    (f : set_type (free_from_set G H)) (g : set_type (free_from_set F G))
    := [f|] ∘ [g|].

Lemma free_from_set_compose_in
    {F' G H : free_from} : ∀ (f : set_type (free_from_set G H)) g,
    free_from_set F' H (free_from_compose f g).
Proof.
    intros [f f_eq] [g g_eq].
    unfold free_from_set in *.
    unfold free_from_compose; cbn.
    intros x.
    rewrite g_eq.
    apply f_eq.
Qed.

Lemma free_from_set_id_in : ∀ f : free_from, free_from_set f f 𝟙.
Proof.
    intros f.
    unfold free_from_set.
    intros x.
    cbn.
    reflexivity.
Qed.

Program Instance FREE_FROM : Category := {
    cat_U := free_from;
    cat_morphism f g := set_type (free_from_set f g);
    cat_compose {F G H} f g := [_|free_from_set_compose_in f g];
    cat_id f := [_|free_from_set_id_in f];
}.
Next Obligation.
    apply set_type_eq; cbn.
    apply (@cat_assoc (MODULE F)).
Qed.
Next Obligation.
    apply set_type_eq; cbn.
    apply (@cat_lid (MODULE F)).
Qed.
Next Obligation.
    apply set_type_eq; cbn.
    apply (@cat_rid (MODULE F)).
Qed.

Definition to_free_from := make_free_from free_module to_free.

Theorem free_module_universal : initial to_free_from.
Proof.
    intros [gM g].
    pose (gP := module_plus gM).
    pose (gZ := module_zero gM).
    pose (gN := module_neg gM).
    pose (gPC := module_plus_comm gM).
    pose (gPA := module_plus_assoc gM).
    pose (gPZ := module_plus_lid gM).
    pose (gPN := module_plus_linv gM).
    pose (gSM := module_scalar gM).
    pose (gSMO := module_scalar_id gM).
    pose (gSML := module_scalar_ldist gM).
    pose (gSMR := module_scalar_rdist gM).
    pose (gSMC := module_scalar_comp gM).
    cbn.
    apply singleton_ex; [>split|].
    -   apply ex_set_type.
        exists (make_module_homomorphism _ free_module _
            (free_extend g) (free_extend_plus g) (free_extend_scalar g)).
        unfold free_from_set; cbn.
        apply free_extend_free.
    -   intros [f1 f1_in] [f2 f2_in].
        pose (f1_plus := @module_homo_plus _ _ _ f1).
        pose (f1_scalar := @module_homo_scalar _ _ _ f1).
        pose (f2_plus := @module_homo_plus _ _ _ f2).
        pose (f2_scalar := @module_homo_scalar _ _ _ f2).
        apply set_type_eq; cbn.
        apply module_homomorphism_eq.
        cbn.
        intros v.
        unfold free_from_set in f1_in; cbn in f1_in.
        unfold free_from_set in f2_in; cbn in f2_in.
        pose proof (grade_decomposition_eq v) as v_eq.
        rewrite v_eq; clear v_eq.
        remember (grade_decomposition v) as l.
        clear Heql.
        induction l using ulist_induction.
        +   rewrite ulist_image_end, ulist_sum_end.
            do 2 rewrite module_homo_zero.
            reflexivity.
        +   rewrite ulist_image_add, ulist_sum_add.
            rewrite f1_plus, f2_plus.
            rewrite IHl.
            apply rplus.
            clear v l IHl.
            destruct a as [a [v av]]; cbn.
            apply to_free_ex in av as [α a_eq]; subst a.
            rewrite f1_scalar, f2_scalar.
            apply f_equal.
            rewrite f1_in, f2_in.
            reflexivity.
Qed.
(* begin hide *)

End LinearFree.
(* end hide *)