### Introduce cofeT -> cofeT functors, switch to bifunctors.

```This cleans up some ad-hoc stuff and prepares for a generalization
of saved propositions.```
parent dabe846c
 ... ... @@ -50,7 +50,6 @@ algebra/agree.v algebra/dec_agree.v algebra/excl.v algebra/iprod.v algebra/functor.v algebra/upred.v algebra/upred_tactics.v algebra/upred_big_op.v ... ...
 From algebra Require Export cmra. From algebra Require Import functor upred. From algebra Require Import upred. Local Hint Extern 10 (_ ≤ _) => omega. Record agree (A : Type) : Type := Agree { ... ... @@ -180,6 +180,18 @@ Proof. by apply dist_le with n; try apply Hfg. Qed. Program Definition agreeF : iFunctor := {| ifunctor_car := agreeR; ifunctor_map := @agreeC_map |}. Solve Obligations with done. Program Definition agreeRF (F : cFunctor) : rFunctor := {| rFunctor_car A B := agreeR (cFunctor_car F A B); rFunctor_map A1 A2 B1 B2 fg := agreeC_map (cFunctor_map F fg) |}. Next Obligation. intros F A1 A2 B1 B2 n ???; simpl. by apply agreeC_map_ne, cFunctor_ne. Qed. Next Obligation. intros F A B x; simpl. rewrite -{2}(agree_map_id x). apply agree_map_ext=>y. by rewrite cFunctor_id. Qed. Next Obligation. intros F A1 A2 A3 B1 B2 B3 f g f' g' x; simpl. rewrite -agree_map_compose. apply agree_map_ext=>y; apply cFunctor_compose. Qed.
 From algebra Require Export excl. From algebra Require Import functor upred. From algebra Require Import upred. Local Arguments valid _ _ !_ /. Local Arguments validN _ _ _ !_ /. ... ... @@ -240,17 +240,18 @@ Definition authC_map {A B} (f : A -n> B) : authC A -n> authC B := Lemma authC_map_ne A B n : Proper (dist n ==> dist n) (@authC_map A B). Proof. intros f f' Hf [[a| |] b]; repeat constructor; apply Hf. Qed. Program Definition authF (Σ : iFunctor) : iFunctor := {| ifunctor_car := authR ∘ Σ; ifunctor_map A B := authC_map ∘ ifunctor_map Σ Program Definition authRF (F : rFunctor) : rFunctor := {| rFunctor_car A B := authR (rFunctor_car F A B); rFunctor_map A1 A2 B1 B2 fg := authC_map (rFunctor_map F fg) |}. Next Obligation. by intros Σ A B n f g Hfg; apply authC_map_ne, ifunctor_map_ne. by intros F A1 A2 B1 B2 n f g Hfg; apply authC_map_ne, rFunctor_ne. Qed. Next Obligation. intros Σ A x. rewrite /= -{2}(auth_map_id x). apply auth_map_ext=>y; apply ifunctor_map_id. intros F A B x. rewrite /= -{2}(auth_map_id x). apply auth_map_ext=>y; apply rFunctor_id. Qed. Next Obligation. intros Σ A B C f g x. rewrite /= -auth_map_compose. apply auth_map_ext=>y; apply ifunctor_map_compose. intros F A1 A2 A3 B1 B2 B3 f g f' g' x. rewrite /= -auth_map_compose. apply auth_map_ext=>y; apply rFunctor_compose. Qed.
 ... ... @@ -617,3 +617,59 @@ Proof. - intros x y; rewrite !prod_included=> -[??] /=. by split; apply included_preserving. Qed. (** Functors *) Structure rFunctor := RFunctor { rFunctor_car : cofeT → cofeT -> cmraT; rFunctor_map {A1 A2 B1 B2} : ((A2 -n> A1) * (B1 -n> B2)) → rFunctor_car A1 B1 -n> rFunctor_car A2 B2; rFunctor_ne {A1 A2 B1 B2} n : Proper (dist n ==> dist n) (@rFunctor_map A1 A2 B1 B2); rFunctor_id {A B} (x : rFunctor_car A B) : rFunctor_map (cid,cid) x ≡ x; rFunctor_compose {A1 A2 A3 B1 B2 B3} (f : A2 -n> A1) (g : A3 -n> A2) (f' : B1 -n> B2) (g' : B2 -n> B3) x : rFunctor_map (f◎g, g'◎f') x ≡ rFunctor_map (g,g') (rFunctor_map (f,f') x); rFunctor_mono {A1 A2 B1 B2} (fg : (A2 -n> A1) * (B1 -n> B2)) : CMRAMonotone (rFunctor_map fg) }. Existing Instances rFunctor_ne rFunctor_mono. Instance: Params (@rFunctor_map) 5. Definition rFunctor_diag (F: rFunctor) (A: cofeT) : cmraT := rFunctor_car F A A. Coercion rFunctor_diag : rFunctor >-> Funclass. Program Definition constRF (B : cmraT) : rFunctor := {| rFunctor_car A1 A2 := B; rFunctor_map A1 A2 B1 B2 f := cid |}. Solve Obligations with done. Program Definition prodRF (F1 F2 : rFunctor) : rFunctor := {| rFunctor_car A B := prodR (rFunctor_car F1 A B) (rFunctor_car F2 A B); rFunctor_map A1 A2 B1 B2 fg := prodC_map (rFunctor_map F1 fg) (rFunctor_map F2 fg) |}. Next Obligation. by intros F1 F2 A1 A2 B1 B2 n ???; apply prodC_map_ne; apply rFunctor_ne. Qed. Next Obligation. by intros F1 F2 A B [??]; rewrite /= !rFunctor_id. Qed. Next Obligation. intros F1 F2 A1 A2 A3 B1 B2 B3 f g f' g' [??]; simpl. by rewrite !rFunctor_compose. Qed. Program Definition laterRF (F : rFunctor) : rFunctor := {| rFunctor_car A B := rFunctor_car F (laterC A) (laterC B); rFunctor_map A1 A2 B1 B2 fg := rFunctor_map F (prod_map laterC_map laterC_map fg) |}. Next Obligation. intros F A1 A2 B1 B2 n x y [??]. by apply rFunctor_ne; split; apply (contractive_ne laterC_map). Qed. Next Obligation. intros F A B x; simpl. rewrite -{2}[x]rFunctor_id. apply (ne_proper (rFunctor_map F)); split; by intros []. Qed. Next Obligation. intros F A1 A2 A3 B1 B2 B3 f g f' g' x; simpl in *. rewrite -rFunctor_compose. apply (ne_proper (rFunctor_map F)); split; by intros []. Qed.
 ... ... @@ -310,6 +310,47 @@ Instance prodC_map_ne {A A' B B'} n : Proper (dist n ==> dist n ==> dist n) (@prodC_map A A' B B'). Proof. intros f f' Hf g g' Hg [??]; split; [apply Hf|apply Hg]. Qed. (** Functors *) Structure cFunctor := CFunctor { cFunctor_car : cofeT → cofeT -> cofeT; cFunctor_map {A1 A2 B1 B2} : ((A2 -n> A1) * (B1 -n> B2)) → cFunctor_car A1 B1 -n> cFunctor_car A2 B2; cFunctor_ne {A1 A2 B1 B2} n : Proper (dist n ==> dist n) (@cFunctor_map A1 A2 B1 B2); cFunctor_id {A B : cofeT} (x : cFunctor_car A B) : cFunctor_map (cid,cid) x ≡ x; cFunctor_compose {A1 A2 A3 B1 B2 B3} (f : A2 -n> A1) (g : A3 -n> A2) (f' : B1 -n> B2) (g' : B2 -n> B3) x : cFunctor_map (f◎g, g'◎f') x ≡ cFunctor_map (g,g') (cFunctor_map (f,f') x) }. Existing Instances cFunctor_ne. Instance: Params (@cFunctor_map) 5. Definition cFunctor_diag (F: cFunctor) (A: cofeT) : cofeT := cFunctor_car F A A. Coercion cFunctor_diag : cFunctor >-> Funclass. Program Definition idCF : cFunctor := {| cFunctor_car A1 A2 := A2; cFunctor_map A1 A2 B1 B2 f := f.2 |}. Solve Obligations with done. Program Definition constCF (B : cofeT) : cFunctor := {| cFunctor_car A1 A2 := B; cFunctor_map A1 A2 B1 B2 f := cid |}. Solve Obligations with done. Program Definition prodCF (F1 F2 : cFunctor) : cFunctor := {| cFunctor_car A B := prodC (cFunctor_car F1 A B) (cFunctor_car F2 A B); cFunctor_map A1 A2 B1 B2 fg := prodC_map (cFunctor_map F1 fg) (cFunctor_map F2 fg) |}. Next Obligation. by intros F1 F2 A1 A2 B1 B2 n ???; apply prodC_map_ne; apply cFunctor_ne. Qed. Next Obligation. by intros F1 F2 A B [??]; rewrite /= !cFunctor_id. Qed. Next Obligation. intros F1 F2 A1 A2 A3 B1 B2 B3 f g f' g' [??]; simpl. by rewrite !cFunctor_compose. Qed. (** Discrete cofe *) Section discrete_cofe. Context `{Equiv A, @Equivalence A (≡)}. ... ... @@ -390,3 +431,13 @@ Definition laterC_map {A B} (f : A -n> B) : laterC A -n> laterC B := CofeMor (later_map f). Instance laterC_map_contractive (A B : cofeT) : Contractive (@laterC_map A B). Proof. intros [|n] f g Hf n'; [done|]; apply Hf; lia. Qed. Program Definition laterCF : cFunctor := {| cFunctor_car A B := laterC B; cFunctor_map A1 A2 B1 B2 fg := laterC_map (fg.2) |}. Next Obligation. intros F A1 A2 B1 B2 n ? [??]; simpl. by apply (contractive_ne laterC_map). Qed. Next Obligation. by intros A B []. Qed. Next Obligation. by intros A1 A2 A3 B1 B2 B3 f g f' g' []. Qed.
 From algebra Require Export cofe. Record solution (F : cofeT → cofeT → cofeT) := Solution { Record solution (F : cFunctor) := Solution { solution_car :> cofeT; solution_unfold : solution_car -n> F solution_car solution_car; solution_fold : F solution_car solution_car -n> solution_car; solution_unfold : solution_car -n> F solution_car; solution_fold : F solution_car -n> solution_car; solution_fold_unfold X : solution_fold (solution_unfold X) ≡ X; solution_unfold_fold X : solution_unfold (solution_fold X) ≡ X }. ... ... @@ -11,20 +11,13 @@ Arguments solution_unfold {_} _. Arguments solution_fold {_} _. Module solver. Section solver. Context (F : cofeT → cofeT → cofeT). Context `{Finhab : Inhabited (F unitC unitC)}. Context (map : ∀ {A1 A2 B1 B2 : cofeT}, ((A2 -n> A1) * (B1 -n> B2)) → (F A1 B1 -n> F A2 B2)). Arguments map {_ _ _ _} _. Instance: Params (@map) 4. Context (map_id : ∀ {A B : cofeT} (x : F A B), map (cid, cid) x ≡ x). Context (map_comp : ∀ {A1 A2 A3 B1 B2 B3 : cofeT} (f : A2 -n> A1) (g : A3 -n> A2) (f' : B1 -n> B2) (g' : B2 -n> B3) x, map (f ◎ g, g' ◎ f') x ≡ map (g,g') (map (f,f') x)). Context (map_contractive : ∀ {A1 A2 B1 B2}, Contractive (@map A1 A2 B1 B2)). Context (F : cFunctor) `{Finhab : Inhabited (F unitC)}. Context (map_contractive : ∀ {A1 A2 B1 B2}, Contractive (@cFunctor_map F A1 A2 B1 B2)). Notation map := (cFunctor_map F). Fixpoint A (k : nat) : cofeT := match k with 0 => unitC | S k => F (A k) (A k) end. match k with 0 => unitC | S k => F (A k) end. Fixpoint f (k : nat) : A k -n> A (S k) := match k with 0 => CofeMor (λ _, inhabitant) | S k => map (g k,f k) end with g (k : nat) : A (S k) -n> A k := ... ... @@ -38,13 +31,15 @@ Arguments g : simpl never. Lemma gf {k} (x : A k) : g k (f k x) ≡ x. Proof. induction k as [|k IH]; simpl in *; [by destruct x|]. rewrite -map_comp -{2}(map_id _ _ x). by apply (contractive_proper map). rewrite -cFunctor_compose -{2}[x]cFunctor_id. by apply (contractive_proper map). Qed. Lemma fg {k} (x : A (S (S k))) : f (S k) (g (S k) x) ≡{k}≡ x. Proof. induction k as [|k IH]; simpl. - rewrite f_S g_S -{2}(map_id _ _ x) -map_comp. apply (contractive_0 map). - rewrite f_S g_S -{2}(map_id _ _ x) -map_comp. by apply (contractive_S map). - rewrite f_S g_S -{2}[x]cFunctor_id -cFunctor_compose. apply (contractive_0 map). - rewrite f_S g_S -{2}[x]cFunctor_id -cFunctor_compose. by apply (contractive_S map). Qed. Record tower := { ... ... @@ -174,28 +169,28 @@ Proof. - rewrite (ff_tower k (i - S k) X). by destruct (Nat.sub_add _ _ _). Qed. Program Definition unfold_chain (X : T) : chain (F T T) := Program Definition unfold_chain (X : T) : chain (F T) := {| chain_car n := map (project n,embed' n) (X (S n)) |}. Next Obligation. intros X n i Hi. assert (∃ k, i = k + n) as [k ?] by (exists (i - n); lia); subst; clear Hi. induction k as [|k IH]; simpl; first done. rewrite -IH -(dist_le _ _ _ _ (f_tower (k + n) _)); last lia. rewrite f_S -map_comp. rewrite f_S -cFunctor_compose. by apply (contractive_ne map); split=> Y /=; rewrite ?g_tower ?embed_f. Qed. Definition unfold (X : T) : F T T := compl (unfold_chain X). Definition unfold (X : T) : F T := compl (unfold_chain X). Instance unfold_ne : Proper (dist n ==> dist n) unfold. Proof. intros n X Y HXY. by rewrite /unfold (conv_compl n (unfold_chain X)) (conv_compl n (unfold_chain Y)) /= (HXY (S n)). Qed. Program Definition fold (X : F T T) : T := Program Definition fold (X : F T) : T := {| tower_car n := g n (map (embed' n,project n) X) |}. Next Obligation. intros X k. apply (_ : Proper ((≡) ==> (≡)) (g k)). rewrite g_S -map_comp. rewrite g_S -cFunctor_compose. apply (contractive_proper map); split=> Y; [apply embed_f|apply g_tower]. Qed. Instance fold_ne : Proper (dist n ==> dist n) fold. ... ... @@ -204,14 +199,13 @@ Proof. by intros n X Y HXY k; rewrite /fold /= HXY. Qed. Theorem result : solution F. Proof. apply (Solution F T (CofeMor unfold) (CofeMor fold)). - move=> X /=. rewrite equiv_dist; intros n k; unfold unfold, fold; simpl. - move=> X /=. rewrite equiv_dist=> n k; rewrite /unfold /fold /=. rewrite -g_tower -(gg_tower _ n); apply (_ : Proper (_ ==> _) (g _)). trans (map (ff n, gg n) (X (S (n + k)))). { rewrite /unfold (conv_compl n (unfold_chain X)). rewrite -(chain_cauchy (unfold_chain X) n (S (n + k))) /=; last lia. rewrite -(dist_le _ _ _ _ (f_tower (n + k) _)); last lia. rewrite f_S -!map_comp; apply (contractive_ne map); split=> Y. rewrite f_S -!cFunctor_compose; apply (contractive_ne map); split=> Y. + rewrite /embed' /= /embed_coerce. destruct (le_lt_dec _ _); simpl; [exfalso; lia|]. by rewrite (ff_ff _ (eq_refl (S n + (0 + k)))) /= gf. ... ... @@ -221,14 +215,14 @@ Proof. assert (∀ i k (x : A (S i + k)) (H : S i + k = i + S k), map (ff i, gg i) x ≡ gg i (coerce H x)) as map_ff_gg. { intros i; induction i as [|i IH]; intros k' x H; simpl. { by rewrite coerce_id map_id. } rewrite map_comp g_coerce; apply IH. } { by rewrite coerce_id cFunctor_id. } rewrite cFunctor_compose g_coerce; apply IH. } assert (H: S n + k = n + S k) by lia. rewrite (map_ff_gg _ _ _ H). apply (_ : Proper (_ ==> _) (gg _)); by destruct H. - intros X; rewrite equiv_dist=> n /=. rewrite /unfold /= (conv_compl' n (unfold_chain (fold X))) /=. rewrite g_S -!map_comp -{2}(map_id _ _ X). rewrite g_S -!cFunctor_compose -{2}[X]cFunctor_id. apply (contractive_ne map); split => Y /=. + rewrite f_tower. apply dist_S. by rewrite embed_tower. + etrans; [apply embed_ne, equiv_dist, g_tower|apply embed_tower]. ... ...
 From algebra Require Export cmra. From algebra Require Import functor upred. From algebra Require Import upred. Local Arguments validN _ _ _ !_ /. Local Arguments valid _ _ !_ /. ... ... @@ -201,7 +201,9 @@ Definition exclC_map {A B} (f : A -n> B) : exclC A -n> exclC B := Instance exclC_map_ne A B n : Proper (dist n ==> dist n) (@exclC_map A B). Proof. by intros f f' Hf []; constructor; apply Hf. Qed. Program Definition exclF : iFunctor := {| ifunctor_car := exclR; ifunctor_map := @exclC_map |}. Next Obligation. by intros A x; rewrite /= excl_map_id. Qed. Next Obligation. by intros A B C f g x; rewrite /= excl_map_compose. Qed. Program Definition exclF : rFunctor := {| rFunctor_car A B := exclR B; rFunctor_map A1 A2 B1 B2 fg := exclC_map (fg.2) |}. Next Obligation. intros A1 A2 B1 B2 n x1 x2 [??]. by apply exclC_map_ne. Qed. Next Obligation. by intros A B x; rewrite /= excl_map_id. Qed. Next Obligation. by intros A1 A2 A3 B1 B2 B3 *;rewrite /= excl_map_compose. Qed.
 From algebra Require Export cmra option. From prelude Require Export gmap. From algebra Require Import functor upred. From algebra Require Import upred. Section cofe. Context `{Countable K} {A : cofeT}. ... ... @@ -352,17 +352,34 @@ Proof. destruct (_ !! k) eqn:?; simpl; constructor; apply Hf. Qed. Program Definition mapF K `{Countable K} (Σ : iFunctor) : iFunctor := {| ifunctor_car := mapR K ∘ Σ; ifunctor_map A B := mapC_map ∘ ifunctor_map Σ Program Definition mapCF K `{Countable K} (F : cFunctor) : cFunctor := {| cFunctor_car A B := mapC K (cFunctor_car F A B); cFunctor_map A1 A2 B1 B2 fg := mapC_map (cFunctor_map F fg) |}. Next Obligation. by intros K ?? Σ A B n f g Hfg; apply mapC_map_ne, ifunctor_map_ne. by intros K ?? F A1 A2 B1 B2 n f g Hfg; apply mapC_map_ne, cFunctor_ne. Qed. Next Obligation. intros K ?? Σ A x. rewrite /= -{2}(map_fmap_id x). apply map_fmap_setoid_ext=> ? y _; apply ifunctor_map_id. intros K ?? F A B x. rewrite /= -{2}(map_fmap_id x). apply map_fmap_setoid_ext=>y ??; apply cFunctor_id. Qed. Next Obligation. intros K ?? Σ A B C f g x. rewrite /= -map_fmap_compose. apply map_fmap_setoid_ext=> ? y _; apply ifunctor_map_compose. intros K ?? F A1 A2 A3 B1 B2 B3 f g f' g' x. rewrite /= -map_fmap_compose. apply map_fmap_setoid_ext=>y ??; apply cFunctor_compose. Qed. Program Definition mapRF K `{Countable K} (F : rFunctor) : rFunctor := {| rFunctor_car A B := mapR K (rFunctor_car F A B); rFunctor_map A1 A2 B1 B2 fg := mapC_map (rFunctor_map F fg) |}. Next Obligation. by intros K ?? F A1 A2 B1 B2 n f g Hfg; apply mapC_map_ne, rFunctor_ne. Qed. Next Obligation. intros K ?? F A B x. rewrite /= -{2}(map_fmap_id x). apply map_fmap_setoid_ext=>y ??; apply rFunctor_id. Qed. Next Obligation. intros K ?? F A1 A2 A3 B1 B2 B3 f g f' g' x. rewrite /= -map_fmap_compose. apply map_fmap_setoid_ext=>y ??; apply rFunctor_compose. Qed.
 From Coq.QArith Require Import Qcanon. From algebra Require Export cmra. From algebra Require Import functor upred. From algebra Require Import upred. Local Arguments validN _ _ _ !_ /. Local Arguments valid _ _ !_ /. Local Arguments div _ _ !_ !_ /. ... ... @@ -244,17 +244,18 @@ Proof. by exists (Frac q3 b); constructor. Qed. Program Definition fracF (Σ : iFunctor) : iFunctor := {| ifunctor_car := fracR ∘ Σ; ifunctor_map A B := fracC_map ∘ ifunctor_map Σ Program Definition fracRF (F : rFunctor) : rFunctor := {| rFunctor_car A B := fracR (rFunctor_car F A B); rFunctor_map A1 A2 B1 B2 fg := fracC_map (rFunctor_map F fg) |}. Next Obligation. by intros Σ A B n f g Hfg; apply fracC_map_ne, ifunctor_map_ne. by intros F A1 A2 B1 B2 n f g Hfg; apply fracC_map_ne, rFunctor_ne. Qed. Next Obligation. intros Σ A x. rewrite /= -{2}(frac_map_id x). apply frac_map_ext=>y; apply ifunctor_map_id. intros F A B x. rewrite /= -{2}(frac_map_id x). apply frac_map_ext=>y; apply rFunctor_id. Qed. Next Obligation. intros Σ A B C f g x. rewrite /= -frac_map_compose. apply frac_map_ext=>y; apply ifunctor_map_compose. intros F A1 A2 A3 B1 B2 B3 f g f' g' x. rewrite /= -frac_map_compose. apply frac_map_ext=>y; apply rFunctor_compose. Qed.
 From algebra Require Export cmra. (** * Functors from COFE to CMRA *) (* TODO RJ: Maybe find a better name for this? It is not PL-specific any more. *) Structure iFunctor := IFunctor { ifunctor_car :> cofeT → cmraT; ifunctor_map {A B} (f : A -n> B) : ifunctor_car A -n> ifunctor_car B; ifunctor_map_ne {A B} n : Proper (dist n ==> dist n) (@ifunctor_map A B); ifunctor_map_id {A : cofeT} (x : ifunctor_car A) : ifunctor_map cid x ≡ x; ifunctor_map_compose {A B C} (f : A -n> B) (g : B -n> C) x : ifunctor_map (g ◎ f) x ≡ ifunctor_map g (ifunctor_map f x); ifunctor_map_mono {A B} (f : A -n> B) : CMRAMonotone (ifunctor_map f) }. Existing Instances ifunctor_map_ne ifunctor_map_mono. Lemma ifunctor_map_ext (Σ : iFunctor) {A B} (f g : A -n> B) m : (∀ x, f x ≡ g x) → ifunctor_map Σ f m ≡ ifunctor_map Σ g m. Proof. by intros; apply (ne_proper (@ifunctor_map Σ A B)). Qed. (** * Functor combinators *) (** We create a functor combinators for all CMRAs in the algebra directory. These combinators can be used to conveniently construct the global CMRA of the Iris program logic. Note that we have explicitly built in functor composition into these combinators, instead of having a notion of a functor from the category of CMRAs to the category of CMRAs which we can compose. This way we can convenient deal with (indexed) products in a uniform way. *) Program Definition constF (B : cmraT) : iFunctor := {| ifunctor_car A := B; ifunctor_map A1 A2 f := cid |}. Solve Obligations with done. Program Definition prodF (Σ1 Σ2 : iFunctor) : iFunctor := {| ifunctor_car A := prodR (Σ1 A) (Σ2 A); ifunctor_map A B f := prodC_map (ifunctor_map Σ1 f) (ifunctor_map Σ2 f) |}. Next Obligation. by intros Σ1 Σ2 A B n f g Hfg; apply prodC_map_ne; apply ifunctor_map_ne. Qed. Next Obligation. by intros Σ1 Σ2 A [??]; rewrite /= !ifunctor_map_id. Qed. Next Obligation. by intros Σ1 Σ2 A B C f g [??]; rewrite /= !ifunctor_map_compose. Qed.
 From algebra Require Export cmra. From algebra Require Import functor upred. From algebra Require Import upred. (** * Indexed product *) (** Need to put this in a definition to make canonical structures to work. *) ... ... @@ -288,18 +288,34 @@ Instance iprodC_map_ne {A} {B1 B2 : A → cofeT} n : Proper (dist n ==> dist n) (@iprodC_map A B1 B2). Proof. intros f1 f2 Hf g x; apply Hf. Qed. Program Definition iprodF {A} (Σ : A → iFunctor) : iFunctor := {| ifunctor_car B := iprodR (λ x, Σ x B); ifunctor_map B1 B2 f := iprodC_map (λ x, ifunctor_map (Σ x) f); Program Definition iprodCF {C} (F : C → cFunctor) : cFunctor := {| cFunctor_car A B := iprodC (λ c, cFunctor_car (F c) A B); cFunctor_map A1 A2 B1 B2 fg := iprodC_map (λ c, cFunctor_map (F c) fg) |}. Next Obligation. by intros A Σ B1 B2 n f f' ? g; apply iprodC_map_ne=>x; apply ifunctor_map_ne. by intros C F A1 A2 B1 B2 n ?? g; apply iprodC_map_ne=>c; apply cFunctor_ne. Qed. Next Obligation. intros A Σ B g. rewrite /= -{2}(iprod_map_id g). apply iprod_map_ext=> x; apply ifunctor_map_id. intros C F A B g; simpl. rewrite -{2}(iprod_map_id g). apply iprod_map_ext=> y; apply cFunctor_id. Qed. Next Obligation. intros A Σ B1 B2 B3 f1 f2 g. rewrite /= -iprod_map_compose. apply iprod_map_ext=> y; apply ifunctor_map_compose. intros C F A1 A2 A3 B1 B2 B3 f1 f2 f1' f2' g. rewrite /= -iprod_map_compose. apply iprod_map_ext=>y; apply cFunctor_compose. Qed. Program Definition iprodRF {C} (F : C → rFunctor) : rFunctor := {| rFunctor_car A B := iprodR (λ c, rFunctor_car (F c) A B); rFunctor_map A1 A2 B1 B2 fg := iprodC_map (λ c, rFunctor_map (F c) fg) |}. Next Obligation. by intros C F A1 A2 B1 B2 n ?? g; apply iprodC_map_ne=>c; apply rFunctor_ne. Qed. Next Obligation. intros C F A B g; simpl. rewrite -{2}(iprod_map_id g). apply iprod_map_ext=> y; apply rFunctor_id. Qed. Next Obligation. intros C F A1 A2 A3 B1 B2 B3 f1 f2 f1' f2' g. rewrite /= -iprod_map_compose.