Commit 5cb675da authored by Robbert Krebbers's avatar Robbert Krebbers

Merge branch 'robbert/model'

parents 36f40743 270596d4
Pipeline #25956 canceled with stage
in 1 minute and 15 seconds
......@@ -5,6 +5,7 @@ theories/utils/llist.v
theories/utils/compare.v
theories/utils/contribution.v
theories/utils/group.v
theories/utils/cofe_solver_2.v
theories/channel/proto_model.v
theories/channel/proto.v
theories/channel/channel.v
......
......@@ -174,6 +174,21 @@ Section channel.
by apply iProto_message_proper=> /= -[].
Qed.
Lemma iProto_le_branch a P1 P2 p1 p2 p1' p2' :
(P1 - P1 iProto_le p1 p1') (P2 - P2 iProto_le p2 p2') -
iProto_le (iProto_branch a P1 P2 p1 p2) (iProto_branch a P1 P2 p1' p2').
Proof.
iIntros "H". rewrite /iProto_branch. destruct a.
- iApply iProto_le_send'; iIntros "!>" (b) "HP /=".
iExists b; iSplit; [done|]. destruct b.
+ iDestruct "H" as "[H _]". by iApply "H".
+ iDestruct "H" as "[_ H]". by iApply "H".
- iApply iProto_le_recv'; iIntros "!>" (b) "HP /=".
iExists b; iSplit; [done|]. destruct b.
+ iDestruct "H" as "[H _]". by iApply "H".
+ iDestruct "H" as "[_ H]". by iApply "H".
Qed.
(** ** Specifications of [send] and [recv] *)
Lemma new_chan_spec p :
{{{ True }}}
......
......@@ -39,16 +39,16 @@ Instance action_dual_if_true_recv : ActionDualIf true Recv Send := eq_refl.
Class ProtoNormalize {Σ} (d : bool) (p : iProto Σ)
(pas : list (bool * iProto Σ)) (q : iProto Σ) :=
proto_normalize :
q (iProto_dual_if d p <++>
foldr (iProto_app curry iProto_dual_if) END pas)%proto.
iProto_le (iProto_dual_if d p <++>
foldr (iProto_app curry iProto_dual_if) END pas)%proto q.
Hint Mode ProtoNormalize ! ! ! ! - : typeclass_instances.
Arguments ProtoNormalize {_} _ _%proto _%proto _%proto.
Class ProtoContNormalize {Σ TT} (d : bool) (pc : TT val * iProp Σ * iProto Σ)
(pas : list (bool * iProto Σ)) (qc : TT val * iProp Σ * iProto Σ) :=
proto_cont_normalize x :
(qc x).1.1 = (pc x).1.1
(qc x).1.2 (pc x).1.2
(pc x).1.1 = (qc x).1.1
(pc x).1.2 (qc x).1.2
ProtoNormalize d ((pc x).2) pas ((qc x).2).
Hint Mode ProtoContNormalize ! ! ! ! ! - : typeclass_instances.
......@@ -61,27 +61,27 @@ Section classes.
Implicit Types TT : tele.
Lemma proto_unfold_eq p1 p2 : p1 p2 ProtoUnfold p1 p2.
Proof. rewrite /ProtoNormalize=> Hp d pas q ->. by rewrite Hp. Qed.
Proof. rewrite /ProtoNormalize=> Hp d pas q. by rewrite Hp. Qed.
Global Instance proto_normalize_done p : ProtoNormalize false p [] p | 0.
Proof. by rewrite /ProtoNormalize /= right_id. Qed.
Proof. rewrite /ProtoNormalize /= right_id. iApply iProto_le_refl. Qed.
Global Instance proto_normalize_done_dual p :
ProtoNormalize true p [] (iProto_dual p) | 0.
Proof. by rewrite /ProtoNormalize /= right_id. Qed.
Proof. rewrite /ProtoNormalize /= right_id. iApply iProto_le_refl. Qed.
Global Instance proto_normalize_done_dual_end :
ProtoNormalize (Σ:=Σ) true END [] END | 0.
Proof. by rewrite /ProtoNormalize /= right_id iProto_dual_end. Qed.
Proof. rewrite /ProtoNormalize /= right_id iProto_dual_end. iApply iProto_le_refl. Qed.
Global Instance proto_normalize_dual d p pas q :
ProtoNormalize (negb d) p pas q
ProtoNormalize d (iProto_dual p) pas q.
Proof. rewrite /ProtoNormalize=> ->. by destruct d; rewrite /= ?involutive. Qed.
Proof. rewrite /ProtoNormalize. by destruct d; rewrite /= ?involutive. Qed.
Global Instance proto_normalize_app_l d p1 p2 pas q :
ProtoNormalize d p1 ((d,p2) :: pas) q
ProtoNormalize d (p1 <++> p2) pas q.
Proof.
rewrite /ProtoNormalize=> -> /=. rewrite assoc.
rewrite /ProtoNormalize /=. rewrite assoc.
by destruct d; by rewrite /= ?iProto_dual_app.
Qed.
......@@ -89,19 +89,25 @@ Section classes.
ProtoNormalize d p pas q
ProtoNormalize d' END ((d,p) :: pas) q | 0.
Proof.
rewrite /ProtoNormalize=> -> /=.
rewrite /ProtoNormalize /=.
destruct d'; by rewrite /= ?iProto_dual_end left_id.
Qed.
Global Instance proto_normalize_app_r d p1 p2 pas q :
ProtoNormalize d p2 pas q
ProtoNormalize false p1 ((d,p2) :: pas) (p1 <++> q) | 0.
Proof. by rewrite /ProtoNormalize=> -> /=. Qed.
Proof.
rewrite /ProtoNormalize /= => H.
iApply iProto_le_app; [iApply iProto_le_refl|done].
Qed.
Global Instance proto_normalize_app_r_dual d p1 p2 pas q :
ProtoNormalize d p2 pas q
ProtoNormalize true p1 ((d,p2) :: pas) (iProto_dual p1 <++> q) | 0.
Proof. by rewrite /ProtoNormalize=> -> /=. Qed.
Proof.
rewrite /ProtoNormalize /= => H.
iApply iProto_le_app; [iApply iProto_le_refl|done].
Qed.
Global Instance proto_cont_normalize_O d v P p q pas :
ProtoNormalize d p pas q
......@@ -127,10 +133,52 @@ Section classes.
Proof.
rewrite /ActionDualIf /ProtoContNormalize /ProtoNormalize=> -> H.
destruct d; simpl.
- rewrite iProto_dual_message iProto_app_message.
apply iProto_message_proper; apply tforall_forall=> x /=; apply H.
- rewrite iProto_app_message.
apply iProto_message_proper; apply tforall_forall=> x /=; apply H.
- rewrite iProto_dual_message iProto_app_message. destruct a1; simpl.
+ iApply iProto_le_recv; iIntros (x) "/= Hpc". iExists x.
destruct (H x) as (-> & -> & Hle). iSplit; [done|]. by iFrame "Hpc".
+ iApply iProto_le_send; iIntros (x) "/= Hpc". iExists x.
destruct (H x) as (-> & -> & Hle). iSplit; [done|]. by iFrame "Hpc".
- rewrite iProto_app_message. destruct a1; simpl.
+ iApply iProto_le_send; iIntros (x) "/= Hpc". iExists x.
destruct (H x) as (-> & -> & Hle). iSplit; [done|]. by iFrame "Hpc".
+ iApply iProto_le_recv; iIntros (x) "/= Hpc". iExists x.
destruct (H x) as (-> & -> & Hle). iSplit; [done|]. by iFrame "Hpc".
Qed.
Global Instance proto_normalize_swap {TT1 TT2} d a1
(pc1 : TT1 val * iProp Σ * iProto Σ)
(vP1 : TT1 -t> val * iProp Σ) (vP2 : TT2 -t> val * iProp Σ)
(pc12 : TT1 -t> TT2 -t> iProto Σ)
(pc2 : TT2 -t> val * iProp Σ * iProto Σ) pas :
ActionDualIf d a1 Recv
ProtoContNormalize d pc1 pas (λ.. x1,
(tele_app vP1 x1, iProto_message Send (λ.. x2,
(tele_app vP2 x2, tele_app (tele_app pc12 x1) x2))))
(.. x2, TCEq (tele_app vP2 x2, iProto_message Recv (λ.. x1,
(tele_app vP1 x1, tele_app (tele_app pc12 x1) x2)))
(tele_app pc2 x2))
ProtoNormalize d (iProto_message a1 pc1) pas
(iProto_message Send (tele_app pc2)).
Proof.
(** TODO: This proof contains twice the same subproof. Refactor. *)
rewrite /ActionDualIf /ProtoContNormalize /ProtoNormalize.
rewrite tforall_forall=> ? Hpc1 Hpc2. destruct d, a1; simplify_eq/=.
- rewrite iProto_dual_message iProto_app_message /=.
iApply iProto_le_swap. iIntros (x1 x2) "/= Hpc1 Hpc2 !>".
move: (Hpc1 x1); rewrite {Hpc1} !tele_app_bind /=; intros (->&->&Hpc).
move: (Hpc2 x2); rewrite {Hpc2} TCEq_eq; intros Hpc2.
iExists TT2, TT1, (λ.. x2, (tele_app vP2 x2, tele_app (tele_app pc12 x1) x2)),
(λ.. x1, (tele_app vP1 x1, tele_app (tele_app pc12 x1) x2)), x2, x1.
rewrite /= !tele_app_bind /= -!Hpc2 /=. do 2 (iSplit; [done|]). iFrame.
iSplitR; [done|]. iSplitR; [iApply iProto_le_refl|]. done.
- rewrite iProto_app_message /=.
iApply iProto_le_swap. iIntros (x1 x2) "/= Hpc1 Hpc2 !>".
move: (Hpc1 x1); rewrite {Hpc1} !tele_app_bind /=; intros (->&->&Hpc).
move: (Hpc2 x2); rewrite {Hpc2} TCEq_eq; intros Hpc2.
iExists TT2, TT1, (λ.. x2, (tele_app vP2 x2, tele_app (tele_app pc12 x1) x2)),
(λ.. x1, (tele_app vP1 x1, tele_app (tele_app pc12 x1) x2)), x2, x1.
rewrite /= !tele_app_bind /= -!Hpc2 /=. do 2 (iSplit; [done|]). iFrame.
iSplitR; [done|]. iSplitR; [iApply iProto_le_refl|]. done.
Qed.
Global Instance proto_normalize_branch d a1 a2 P1 P2 p1 p2 q1 q2 pas :
......@@ -139,8 +187,10 @@ Section classes.
ProtoNormalize d (iProto_branch a1 P1 P2 p1 p2) pas
(iProto_branch a2 P1 P2 q1 q2).
Proof.
rewrite /ActionDualIf /ProtoNormalize=> -> -> ->.
destruct d; by rewrite /= -?iProto_app_branch -?iProto_dual_branch.
rewrite /ActionDualIf /ProtoNormalize=> -> H1 H2. destruct d; simpl.
- rewrite !iProto_dual_branch !iProto_app_branch.
iApply iProto_le_branch; iSplit; by iIntros "!> $".
- rewrite !iProto_app_branch. iApply iProto_le_branch; iSplit; by iIntros "!> $".
Qed.
(** Automatically perform normalization of protocols in the proof mode when
......@@ -149,15 +199,17 @@ Section classes.
ProtoNormalize false p1 [] p2
FromAssumption q (c p1) (c p2).
Proof.
rewrite /FromAssumption /ProtoNormalize=> ->.
by rewrite /= right_id bi.intuitionistically_if_elim.
rewrite /FromAssumption /ProtoNormalize /= right_id.
rewrite bi.intuitionistically_if_elim.
iIntros (?) "H". by iApply (iProto_mapsto_le with "H").
Qed.
Global Instance mapsto_proto_from_frame q c p1 p2 :
ProtoNormalize false p1 [] p2
Frame q (c p1) (c p2) True.
Proof.
rewrite /Frame /ProtoNormalize=> ->.
by rewrite /= !right_id bi.intuitionistically_if_elim.
rewrite /Frame /ProtoNormalize /= right_id.
rewrite bi.intuitionistically_if_elim.
iIntros (?) "[H _]". by iApply (iProto_mapsto_le with "H").
Qed.
End classes.
......@@ -177,7 +229,8 @@ Lemma tac_wp_recv `{!chanG Σ, !heapG Σ} {TT : tele} Δ i j K
envs_entails Δ (WP fill K (recv c) {{ Φ }}).
Proof.
rewrite envs_entails_eq /ProtoNormalize /= tforall_forall right_id=> ? Hp HΦ.
rewrite envs_lookup_sound //; simpl. rewrite -Hp.
rewrite envs_lookup_sound //; simpl.
rewrite (iProto_mapsto_le _ _ (iProto_message Recv pc)) -bi.later_intro -Hp left_id.
rewrite -wp_bind. eapply bi.wand_apply; [by eapply recv_spec|f_equiv].
rewrite -bi.later_intro bi_tforall_forall; apply bi.forall_intro=> x.
specialize (HΦ x). destruct (envs_app _ _) as [Δ'|] eqn:HΔ'=> //.
......@@ -261,7 +314,8 @@ Lemma tac_wp_send `{!chanG Σ, !heapG Σ} {TT : tele} Δ neg i js K
envs_entails Δ (WP fill K (send c v) {{ Φ }}).
Proof.
rewrite envs_entails_eq /ProtoNormalize /= right_id texist_exist=> ? Hp [x HΦ].
rewrite envs_lookup_sound //; simpl. rewrite -Hp.
rewrite envs_lookup_sound //; simpl.
rewrite (iProto_mapsto_le _ _ (iProto_message Send pc)) -bi.later_intro -Hp left_id.
rewrite -wp_bind. eapply bi.wand_apply; [by eapply send_spec|f_equiv].
rewrite bi_texist_exist -(bi.exist_intro x).
destruct (envs_split _ _ _) as [[Δ1 Δ2]|] eqn:? => //.
......@@ -351,7 +405,8 @@ Lemma tac_wp_branch `{!chanG Σ, !heapG Σ} Δ i j K
envs_entails Δ (WP fill K (recv c) {{ Φ }}).
Proof.
rewrite envs_entails_eq /ProtoNormalize /= right_id=> ? Hp HΦ.
rewrite envs_lookup_sound //; simpl. rewrite -Hp.
rewrite envs_lookup_sound //; simpl.
rewrite (iProto_mapsto_le _ _ (p1 <{P1}&{P2}> p2)%proto) -bi.later_intro -Hp left_id.
rewrite -wp_bind. eapply bi.wand_apply; [by eapply branch_spec|f_equiv].
rewrite -bi.later_intro; apply bi.forall_intro=> b.
specialize (HΦ b). destruct (envs_app _ _) as [Δ'|] eqn:HΔ'=> //.
......@@ -403,7 +458,8 @@ Lemma tac_wp_select `{!chanG Σ, !heapG Σ} Δ neg i js K
envs_entails Δ (WP fill K (send c #b) {{ Φ }}).
Proof.
rewrite envs_entails_eq /ProtoNormalize /= right_id=> ? Hp HΦ.
rewrite envs_lookup_sound //; simpl. rewrite -Hp.
rewrite envs_lookup_sound //; simpl.
rewrite (iProto_mapsto_le _ _ (p1 <{P1}+{P2}> p2)%proto) -bi.later_intro -Hp left_id.
rewrite -wp_bind. eapply bi.wand_apply; [by eapply select_spec|].
rewrite -assoc; f_equiv.
destruct (envs_split _ _ _) as [[Δ1 Δ2]|] eqn:? => //.
......
This diff is collapsed.
......@@ -35,7 +35,7 @@ The defined functions on the type [proto] are:
all terminations [END] in [p1] with [p2]. *)
From iris.base_logic Require Import base_logic.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import cofe_solver.
From actris.utils Require Import cofe_solver_2.
Set Default Proof Using "Type".
Module Export action.
......@@ -48,34 +48,36 @@ Module Export action.
Canonical Structure actionO := leibnizO action.
End action.
Definition protoOF_helper (V : Type) (PROPn PROP : ofeT) : oFunctor :=
optionOF (actionO * (V -d> ( -n> PROPn) -n> PROP)).
Definition proto_result (V : Type) (PROPn PROP : ofeT) `{!Cofe PROPn, !Cofe PROP} :
solution (protoOF_helper V PROPn PROP) := solver.result _.
Definition proto_auxO (V : Type) (PROP : ofeT) (A : ofeT) : ofeT :=
optionO (prodO actionO (V -d> laterO A -n> PROP)).
Definition proto_auxOF (V : Type) (PROP : ofeT) : oFunctor :=
optionOF (actionO * (V -d> -n> PROP)).
Definition proto_result (V : Type) := result_2 (proto_auxOF V).
Definition proto (V : Type) (PROPn PROP : ofeT) `{!Cofe PROPn, !Cofe PROP} : ofeT :=
proto_result V PROPn PROP.
proto_result V PROPn _ PROP _.
Instance proto_cofe {V} `{!Cofe PROPn, !Cofe PROP} : Cofe (proto V PROPn PROP).
Proof. apply _. Qed.
Lemma proto_iso {V} `{!Cofe PROPn, !Cofe PROP} :
ofe_iso (proto_auxO V PROP (proto V PROP PROPn)) (proto V PROPn PROP).
Proof. apply proto_result. Qed.
Definition proto_fold {V} `{!Cofe PROPn, !Cofe PROP} :
protoOF_helper V PROPn PROP (proto V PROPn PROP) _ -n> proto V PROPn PROP :=
solution_fold (proto_result V PROPn PROP).
proto_auxO V PROP (proto V PROP PROPn) -n> proto V PROPn PROP := ofe_iso_1 proto_iso.
Definition proto_unfold {V} `{!Cofe PROPn, !Cofe PROP} :
proto V PROPn PROP -n> protoOF_helper V PROPn PROP (proto V PROPn PROP) _ :=
solution_unfold (proto_result V PROPn PROP).
proto V PROPn PROP -n> proto_auxO V PROP (proto V PROP PROPn) := ofe_iso_2 proto_iso.
Lemma proto_fold_unfold {V} `{!Cofe PROPn, !Cofe PROP} (p : proto V PROPn PROP) :
proto_fold (proto_unfold p) p.
Proof. apply solution_fold_unfold. Qed.
Proof. apply (ofe_iso_12 proto_iso). Qed.
Lemma proto_unfold_fold {V} `{!Cofe PROPn, !Cofe PROP}
(p : protoOF_helper V PROPn PROP (proto V PROPn PROP) _) :
(p : proto_auxO V PROP (proto V PROP PROPn)) :
proto_unfold (proto_fold p) p.
Proof. apply solution_unfold_fold. Qed.
Proof. apply (ofe_iso_21 proto_iso). Qed.
Definition proto_end {V} `{!Cofe PROPn, !Cofe PROP} : proto V PROPn PROP :=
proto_fold None.
Definition proto_message {V} `{!Cofe PROPn, !Cofe PROP} (a : action)
(pc : V (laterO (proto V PROPn PROP) -n> PROPn) -n> PROP) : proto V PROPn PROP :=
(pc : V laterO (proto V PROP PROPn) -n> PROP) : proto V PROPn PROP :=
proto_fold (Some (a, pc)).
Instance proto_message_ne {V} `{!Cofe PROPn, !Cofe PROP} a n :
......@@ -99,7 +101,7 @@ Instance proto_inhabited {V} `{!Cofe PROPn, !Cofe PROP} :
Lemma proto_message_equivI {SPROP : sbi} {V} `{!Cofe PROPn, !Cofe PROP} a1 a2 pc1 pc2 :
proto_message (V:=V) (PROPn:=PROPn) (PROP:=PROP) a1 pc1 proto_message a2 pc2
@{SPROP} a1 = a2 ( v pc', pc1 v pc' pc2 v pc').
@{SPROP} a1 = a2 ( v p', pc1 v p' pc2 v p').
Proof.
trans (proto_unfold (proto_message a1 pc1) proto_unfold (proto_message a2 pc2) : SPROP)%I.
{ iSplit.
......@@ -120,217 +122,140 @@ Lemma proto_end_message_equivI {SPROP : sbi} {V} `{!Cofe PROPn, !Cofe PROP} a pc
proto_end proto_message (V:=V) (PROPn:=PROPn) (PROP:=PROP) a pc @{SPROP} False.
Proof. by rewrite bi.internal_eq_sym proto_message_end_equivI. Qed.
Definition proto_cont_map
`{!Cofe PROPn, !Cofe PROPn', !Cofe PROP, !Cofe PROP', !Cofe A, !Cofe B}
(gn : PROPn' -n> PROPn) (g : PROP -n> PROP') (h : A -n> B) :
((laterO A -n> PROPn) -n> PROP) -n> (laterO B -n> PROPn') -n> PROP' :=
ofe_morO_map (ofe_morO_map (laterO_map h) gn) g.
(** Append *)
Program Definition proto_app_flipped_aux {V} `{!Cofe PROPn, !Cofe PROP}
(p2 : proto V PROPn PROP) (rec : proto V PROPn PROP -n> proto V PROPn PROP) :
proto V PROPn PROP -n> proto V PROPn PROP := λne p1,
match proto_unfold p1 return _ with
| None => p2
| Some (a, c) => proto_message a (proto_cont_map cid cid rec c)
end.
Next Obligation.
intros V PROPn ? PROP ? rec n p2 p1 p1' Hp.
apply (ofe_mor_ne _ _ proto_unfold) in Hp.
destruct Hp as [[??][??] [-> ?]|]; simplify_eq/=; last done.
f_equiv=> v /=. by f_equiv.
Qed.
Instance proto_app_flipped_aux_contractive {V} `{!Cofe PROPn, !Cofe PROP}
(p2 : proto V PROPn PROP) : Contractive (proto_app_flipped_aux p2).
Proof.
intros n rec1 rec2 Hrec p1. simpl.
destruct (proto_unfold p1) as [[a c]|]; last done.
f_equiv=> v /=. do 2 f_equiv.
intros=> p'. apply Next_contractive. destruct n as [|n]=> //=.
Qed.
Definition proto_app_flipped {V} `{!Cofe PROPn, !Cofe PROP}
(p2 : proto V PROPn PROP) : proto V PROPn PROP -n> proto V PROPn PROP :=
fixpoint (proto_app_flipped_aux p2).
Definition proto_app {V} `{!Cofe PROPn, !Cofe PROP}
(p1 p2 : proto V PROPn PROP) : proto V PROPn PROP := proto_app_flipped p2 p1.
Instance: Params (@proto_app) 5 := {}.
Lemma proto_app_flipped_unfold {V} `{!Cofe PROPn, !Cofe PROP} (p1 p2 : proto V PROPn PROP):
proto_app_flipped p2 p1 proto_app_flipped_aux p2 (proto_app_flipped p2) p1.
Proof. apply (fixpoint_unfold (proto_app_flipped_aux p2)). Qed.
Lemma proto_app_unfold {V} `{!Cofe PROPn, !Cofe PROP} (p1 p2 : proto V PROPn PROP):
proto_app (V:=V) p1 p2 proto_app_flipped_aux p2 (proto_app_flipped p2) p1.
Proof. apply (fixpoint_unfold (proto_app_flipped_aux p2)). Qed.
Lemma proto_app_end_l {V} `{!Cofe PROPn, !Cofe PROP} (p2 : proto V PROPn PROP) :
proto_app proto_end p2 p2.
Proof.
rewrite proto_app_unfold /proto_end /=.
pose proof (proto_unfold_fold (V:=V) (PROPn:=PROPn) (PROP:=PROP) None) as Hfold.
by destruct (proto_unfold (proto_fold None))
as [[??]|] eqn:E; rewrite E; inversion Hfold.
Qed.
Lemma proto_app_message {V} `{!Cofe PROPn, !Cofe PROP} a c (p2 : proto V PROPn PROP) :
proto_app (proto_message a c) p2
proto_message a (proto_cont_map cid cid (proto_app_flipped p2) c).
Proof.
rewrite proto_app_unfold /proto_message /=.
pose proof (proto_unfold_fold (V:=V) (PROPn:=PROPn) (PROP:=PROP) (Some (a, c))) as Hfold.
destruct (proto_unfold (proto_fold (Some (a, c))))
as [[??]|] eqn:E; inversion Hfold as [?? [Ha Hc]|]; simplify_eq/=.
rewrite /proto_message. do 3 f_equiv. intros v=> /=.
apply equiv_dist=> n. f_equiv. by apply equiv_dist.
Qed.
Instance proto_app_ne {V} `{!Cofe PROPn, !Cofe PROP} :
NonExpansive2 (proto_app (V:=V) (PROPn:=PROPn) (PROP:=PROP)).
Proof.
intros n p1 p1' Hp1 p2 p2' Hp2. rewrite /proto_app -Hp1 {p1' Hp1}.
revert p1. induction (lt_wf n) as [n _ IH]=> p1 /=.
rewrite !proto_app_flipped_unfold /proto_app_flipped_aux /=.
destruct (proto_unfold p1) as [[a c]|]; last done.
f_equiv=> v f /=. do 2 f_equiv. intros p. apply Next_contractive.
destruct n as [|n]=> //=. apply IH; first lia; auto using dist_S.
Qed.
Instance proto_app_proper {V} `{!Cofe PROPn, !Cofe PROP} :
Proper (() ==> () ==> ()) (proto_app (V:=V) (PROPn:=PROPn) (PROP:=PROP)).
Proof. apply (ne_proper_2 _). Qed.
Lemma proto_app_end_r {V} `{!Cofe PROPn, !Cofe PROP} (p1 : proto V PROPn PROP) :
proto_app p1 proto_end p1.
Proof.
apply equiv_dist=> n. revert p1. induction (lt_wf n) as [n _ IH]=> p1 /=.
destruct (proto_case p1) as [->|(a & c & ->)].
- by rewrite !proto_app_end_l.
- rewrite !proto_app_message /=. f_equiv=> v c' /=. f_equiv=> p' /=. f_equiv.
apply Next_contractive. destruct n as [|n]=> //=.
apply IH; first lia; auto using dist_S.
Qed.
Lemma proto_app_assoc {V} `{!Cofe PROPn, !Cofe PROP} (p1 p2 p3 : proto V PROPn PROP) :
proto_app p1 (proto_app p2 p3) proto_app (proto_app p1 p2) p3.
Proof.
apply equiv_dist=> n. revert p1. induction (lt_wf n) as [n _ IH]=> p1 /=.
destruct (proto_case p1) as [->|(a & c & ->)].
- by rewrite !proto_app_end_l.
- rewrite !proto_app_message /=. f_equiv=> v c' /=. f_equiv=> p' /=. f_equiv.
apply Next_contractive. destruct n as [|n]=> //=.
apply IH; first lia; auto using dist_S.
Qed.
(** Functor *)
Definition proto_cont_map `{!Cofe PROP, !Cofe PROP', !Cofe A, !Cofe B}
(g : PROP -n> PROP') (rec : B -n> A) :
(laterO A -n> PROP) -n> laterO B -n> PROP' :=
ofe_morO_map (laterO_map rec) g.
Program Definition proto_map_aux {V}
`{!Cofe PROPn, !Cofe PROPn', !Cofe PROP, !Cofe PROP'}
(f : action action) (gn : PROPn' -n> PROPn) (g : PROP -n> PROP')
(rec : proto V PROPn PROP -n> proto V PROPn' PROP') :
(g : PROP -n> PROP')
(rec : proto V PROP' PROPn' -n> proto V PROP PROPn) :
proto V PROPn PROP -n> proto V PROPn' PROP' := λne p,
match proto_unfold p return _ with
| None => proto_end
| Some (a, c) => proto_message (f a) (proto_cont_map gn g rec c)
| Some (a, c) => proto_message a (proto_cont_map g rec c)
end.
Next Obligation.
intros V PROPn ? PROPn' ? PROP ? PROP' ? f g1 g2 rec n p1 p2 Hp.
intros V PROPn ? PROPn' ? PROP ? PROP' ? g rec n p1 p2 Hp.
apply (ofe_mor_ne _ _ proto_unfold) in Hp.
destruct Hp as [[??][??] [-> ?]|]; simplify_eq/=; last done.
f_equiv=> v /=. by f_equiv.
Qed.
Instance proto_map_aux_contractive {V}
`{!Cofe PROPn, !Cofe PROPn', !Cofe PROP, !Cofe PROP'}
(f : action action) (gn : PROPn' -n> PROPn) (g : PROP -n> PROP') :
Contractive (proto_map_aux (V:=V) f gn g).
`{!Cofe PROPn, !Cofe PROPn', !Cofe PROP, !Cofe PROP'} (g : PROP -n> PROP') :
Contractive (proto_map_aux (V:=V) (PROPn:=PROPn) (PROPn':=PROPn') g).
Proof.
intros n rec1 rec2 Hrec p. simpl.
destruct (proto_unfold p) as [[a c]|]; last done.
f_equiv=> v /=. do 2 f_equiv.
intros=> p'. apply Next_contractive. destruct n as [|n]=> //=.
f_equiv=> v p' /=. do 2 f_equiv. apply Next_contractive.
destruct n as [|n]=> //=.
Qed.
Definition proto_map_aux_2 {V}
`{!Cofe PROPn, !Cofe PROPn', !Cofe PROP, !Cofe PROP'}
(gn : PROPn' -n> PROPn) (g : PROP -n> PROP')
(rec : proto V PROPn PROP -n> proto V PROPn' PROP') :
proto V PROPn PROP -n> proto V PROPn' PROP' :=
proto_map_aux g (proto_map_aux gn rec).
Instance proto_map_aux_2_contractive {V}
`{!Cofe PROPn, !Cofe PROPn', !Cofe PROP, !Cofe PROP'}
(gn : PROPn' -n> PROPn) (g : PROP -n> PROP') :
Contractive (proto_map_aux_2 (V:=V) gn g).
Proof.
intros n rec1 rec2 Hrec. rewrite /proto_map_aux_2.
f_equiv. by apply proto_map_aux_contractive.
Qed.
Definition proto_map {V}
`{!Cofe PROPn, !Cofe PROPn', !Cofe PROP, !Cofe PROP'}
(f : action action) (gn : PROPn' -n> PROPn) (g : PROP -n> PROP') :
(gn : PROPn' -n> PROPn) (g : PROP -n> PROP') :
proto V PROPn PROP -n> proto V PROPn' PROP' :=
fixpoint (proto_map_aux f gn g).
fixpoint (proto_map_aux_2 gn g).
Lemma proto_map_unfold {V} `{!Cofe PROPn, !Cofe PROPn', !Cofe PROP, !Cofe PROP'}
(f : action action) (gn : PROPn' -n> PROPn) (g : PROP -n> PROP') p :
proto_map (V:=V) f gn g p proto_map_aux f gn g (proto_map f gn g) p.
Proof. apply (fixpoint_unfold (proto_map_aux f gn g)). Qed.
Lemma proto_map_unfold {V}
`{Hcn:!Cofe PROPn, Hcn':!Cofe PROPn', Hc:!Cofe PROP, Hc':!Cofe PROP'}
(gn : PROPn' -n> PROPn) (g : PROP -n> PROP') p :
proto_map (V:=V) gn g p proto_map_aux g (proto_map g gn) p.
Proof.
apply equiv_dist=> n. revert PROPn Hcn PROPn' Hcn' PROP Hc PROP' Hc' gn g p.
induction (lt_wf n) as [n _ IH]=>
PROPn Hcn PROPn' Hcn' PROP Hc PROP' Hc' gn g p.
etrans; [apply equiv_dist, (fixpoint_unfold (proto_map_aux_2 gn g))|].
apply proto_map_aux_contractive; destruct n as [|n]; [done|]; simpl.
symmetry. apply: IH. lia.
Qed.
Lemma proto_map_end {V} `{!Cofe PROPn, !Cofe PROPn', !Cofe PROP, !Cofe PROP'}
(f : action action) (gn : PROPn' -n> PROPn) (g : PROP -n> PROP') :
proto_map (V:=V) f gn g proto_end proto_end.
(gn : PROPn' -n> PROPn) (g : PROP -n> PROP') :
proto_map (V:=V) gn g proto_end proto_end.
Proof.
rewrite proto_map_unfold /proto_end /=.
pose proof (proto_unfold_fold (V:=V) (PROPn:=PROPn) (PROP:=PROP) None) as Hfold.
by destruct (proto_unfold (proto_fold None))
as [[??]|] eqn:E; rewrite E; inversion Hfold.
by destruct (proto_unfold (proto_fold None)) as [[??]|] eqn:E; inversion Hfold.
Qed.
Lemma proto_map_message {V} `{!Cofe PROPn, !Cofe PROPn', !Cofe PROP, !Cofe PROP'}
(f : action action) (gn : PROPn' -n> PROPn) (g : PROP -n> PROP') a c :
proto_map (V:=V) f gn g (proto_message a c) proto_message (f a) (proto_cont_map gn g (proto_map f gn g) c).
(gn : PROPn' -n> PROPn) (g : PROP -n> PROP') a c :
proto_map (V:=V) gn g (proto_message a c)