Library Merge

Require Export SP.

Module SP_Merge (P X V E B R:DecType) (Ev:Eval E X V V) (BEv:Eval B X V Bool).

Module Export SPM := SPBase P X V E B R Ev BEv.

Ltac Peq := unfold Pid_dec; rewrite Pdec.eqb_refl; simpl.
Ltac Eeq := unfold Expr_dec; rewrite Edec.eqb_refl; simpl.
Ltac Beq := unfold BExpr_dec; rewrite Bdec.eqb_refl; simpl.
Ltac Veq := unfold Var_dec; rewrite Xdec.eqb_refl; simpl.
Ltac Xeq := unfold RecVar_dec; rewrite Rdec.eqb_refl; simpl.

Ltac Pneq H := rewrite <- Pdec.eqb_neq in H; rewrite H.

Section Merge.

Inductive XBehaviour : Type :=
| XEnd : XBehaviour
| XSend : Pid -> Expr -> XBehaviour -> XBehaviour
| XRecv : Pid -> Var -> XBehaviour -> XBehaviour
| XSel : Pid -> Label -> XBehaviour -> XBehaviour
| XBranching : Pid -> option XBehaviour -> option XBehaviour -> XBehaviour
| XCond : BExpr -> XBehaviour -> XBehaviour -> XBehaviour
| XCall : RecVar -> XBehaviour
| XUndefined : XBehaviour
.

Lemma XUndefined_dec : forall B, {B = XUndefined} + {B <> XUndefined}.

Lemma Xmatch_elim : forall B T (X1 X2:T), B <> XUndefined ->
  match B with XUndefined => X1 | _ => X2 end = X2.


Fixpoint Xdepth (B:XBehaviour) : nat :=
match B with
 | XSend p e B' => 1 + Xdepth B'
 | XRecv p x B' => 1 + Xdepth B'
 | XSel p l B' => 1 + Xdepth B'
 | XBranching p mB mB' => 1
                          + (match mB with None => 0 | Some B => Xdepth B end)
                          + (match mB' with None => 0 | Some B => Xdepth B end)
 | XCond b B1 B2 => 1 + Nat.max (Xdepth B1) (Xdepth B2)
 | XCall X => 1
 | XEnd => 1
 | XUndefined => 0
end.

Theorem XBehaviour_ind' :
  forall P:XBehaviour -> Prop,
    P XEnd ->
    (forall p e B, P B -> P (XSend p e B)) ->
    (forall p v B, P B -> P (XRecv p v B)) ->
    (forall p l B, P B -> P (XSel p l B)) ->
    (forall p mB mB', (forall B, mB = Some B -> P B) ->
                      (forall B, mB' = Some B -> P B) ->
                      P (XBranching p mB mB')) ->
    (forall b B1 B2, P B1 -> P B2 -> P (XCond b B1 B2)) ->
    (forall X, P (XCall X)) ->
    P XUndefined ->
    forall B, P B.

Theorem XBehaviour_rec' :
  forall P:XBehaviour -> Type,
    P XEnd ->
    (forall p e B, P B -> P (XSend p e B)) ->
    (forall p v B, P B -> P (XRecv p v B)) ->
    (forall p l B, P B -> P (XSel p l B)) ->
    (forall p mB mB', (forall B, mB = Some B -> P B) ->
                      (forall B, mB' = Some B -> P B) ->
                      P (XBranching p mB mB')) ->
    (forall b B1 B2, P B1 -> P B2 -> P (XCond b B1 B2)) ->
    (forall X, P (XCall X)) ->
    P XUndefined ->
    forall B, P B.

Fixpoint inject (B:Behaviour) : XBehaviour :=
match B with
| End => XEnd
| p ! e; B => XSend p e (inject B)
| p ? v; B => XRecv p v (inject B)
| p (+) l; B => XSel p l (inject B)
| p & None // None => XBranching p None None
| p & Some Bl // None => XBranching p (Some (inject Bl)) None
| p & None // Some Br => XBranching p None (Some (inject Br))
| p & Some Bl // Some Br => XBranching p (Some (inject Bl)) (Some (inject Br))
| If e Then B1 Else B2 => XCond e (inject B1) (inject B2)
| Call X => XCall X
end.

Lemma inject_not_undefined : forall B, inject B <> XUndefined.

Lemma inject_elim : forall B, exists B', inject B = B' /\ B' <> XUndefined.

Lemma inject_match : forall B T (X1 X2:T),
  match inject B with XUndefined => X1 | _ => X2 end = X2.

Lemma inject_inj : forall B B', inject B = inject B' -> B = B'.

Fixpoint Xmerge (B1 B2:XBehaviour) : XBehaviour :=
match B1, B2 with
| XEnd, XEnd => XEnd
| XSend p e B, XSend p' e' B' =>
    if Pid_dec p p' && Expr_dec e e'
    then match Xmerge B B' with XUndefined => XUndefined
                              | _ => XSend p e (Xmerge B B') end
    else XUndefined
| XRecv p v B, XRecv p' v' B' =>
    if Pid_dec p p' && Var_dec v v'
    then match Xmerge B B' with XUndefined => XUndefined
                              | _ => XRecv p v (Xmerge B B') end
    else XUndefined
| XSel p l B, XSel p' l' B' =>
    if Pid_dec p p' && eqb_label l l'
    then match Xmerge B B' with XUndefined => XUndefined
                              | _ => XSel p l (Xmerge B B') end
    else XUndefined
| XBranching p Bl Br, XBranching p' Bl' Br' =>
    if Pid_dec p p'
    then let BL := match Bl with None => Bl'
                               | Some B => match Bl' with None => Bl
                                                        | Some B' => Some (Xmerge B B')
                                           end
                   end
      in let BR := match Br with None => Br'
                               | Some B => match Br' with None => Br
                                                        | Some B' => Some (Xmerge B B')
                                           end
                   end
      in match BL, BR with Some XUndefined, _ => XUndefined
                         | _, Some XUndefined => XUndefined
                         | _, _ => XBranching p BL BR
         end
    else XUndefined
| XCond e B1 B2, XCond e' B1' B2' =>
    if BExpr_dec e e'
    then match Xmerge B1 B1', Xmerge B2 B2' with XUndefined, _ => XUndefined
                                               | _, XUndefined => XUndefined
                                               | Bt, Be => XCond e Bt Be end
    else XUndefined
| XCall X, XCall X' =>
    if RecVar_dec X X' then XCall X else XUndefined
| _, _ => XUndefined
end.

Definition merge B1 B2 := Xmerge (inject B1) (inject B2).

Lemma merge_undefined_or_behaviour : forall B1 B2,
  { merge B1 B2 = XUndefined } + { exists B, merge B1 B2 = inject B }.

Lemma merge_not_undefined : forall B B', merge B B' <> XUndefined ->
  exists B'', merge B B' = inject B''.

Lemma merge_idempotent : forall B, merge B B = inject B.

Lemma Xmerge_comm : forall B B', Xmerge B B' = Xmerge B' B.

Lemma merge_comm : forall B B', merge B B' = merge B' B.

Inversion lemmas about merge.
Lemma merge_inv_End : forall B B', merge B B' = XEnd -> B = End /\ B' = End.

Lemma merge_inv_Send : forall B B' p e X, merge B B' = XSend p e X ->
  exists B1 B1', B = p ! e; B1 /\ B' = p ! e; B1' /\ merge B1 B1' = X.

Lemma merge_inv_Recv : forall B B' p v X, merge B B' = XRecv p v X ->
  exists B1 B1', B = p ? v; B1 /\ B' = p ? v; B1' /\ merge B1 B1' = X.

Lemma merge_inv_Sel : forall B B' p l X, merge B B' = XSel p l X ->
  exists B1 B1', B = p (+) l; B1 /\ B' = p (+) l; B1' /\ merge B1 B1' = X.

Lemma merge_inv_Branching : forall B B' p Bl Br, merge B B' = XBranching p Bl Br ->
  exists Bl' Bl'' Br' Br'', B = p & Bl' // Br' /\ B' = p & Bl'' // Br''
  /\ (Bl = None -> Bl' = None /\ Bl'' = None)
  /\ (Br = None -> Br' = None /\ Br'' = None)
  /\ (forall BL, Bl = Some BL ->
         (Bl' = None -> exists BL'', Bl'' = Some BL'' /\ BL = inject BL'')
      /\ (Bl'' = None -> exists BL', Bl' = Some BL' /\ BL = inject BL')
      /\ (forall BL' BL'', Bl' = Some BL' /\ Bl'' = Some BL'' -> merge BL' BL'' = BL))
  /\ (forall BR, Br = Some BR ->
         (Br' = None -> exists BR'', Br'' = Some BR'' /\ BR = inject BR'')
      /\ (Br'' = None -> exists BR', Br' = Some BR' /\ BR = inject BR')
      /\ (forall BR' BR'', Br' = Some BR' /\ Br'' = Some BR'' -> merge BR' BR'' = BR)).

Lemma merge_inv_Branching_None_None : forall B B' p,
  merge B B' = XBranching p None None ->
  B = p & None // None /\ B' = p & None // None.

Lemma merge_inv_Branching_Some_None : forall B B' p Bl,
  merge B B' = XBranching p (Some Bl) None ->
  (B = p & None // None /\ exists BL, B' = p & Some BL // None /\ Bl = inject BL)
  \/ ((exists BL, B = p & Some BL // None /\ Bl = inject BL) /\ B' = p & None // None)
  \/ exists BL' BL'', B = p & Some BL' // None /\ B' = p & Some BL'' // None
    /\ merge BL' BL'' = Bl.

Lemma merge_inv_Branching_None_Some : forall B B' p Br,
  merge B B' = XBranching p None (Some Br) ->
  (B = p & None // None /\ exists BR, B' = p & None // Some BR /\ Br = inject BR)
  \/ ((exists BR, B = p & None // Some BR /\ Br = inject BR) /\ B' = p & None // None)
  \/ exists BR' BR'', B = p & None // Some BR' /\ B' = p & None // Some BR''
    /\ merge BR' BR'' = Br.

Lemma merge_inv_Cond : forall B B' b Be Bt, merge B B' = XCond b Be Bt ->
  exists Be' Be'' Bt' Bt'', B = Cond b Be' Bt' /\ B' = Cond b Be'' Bt''
    /\ merge Be' Be'' = Be /\ merge Bt' Bt'' = Bt.

Lemma merge_inv_Call : forall B B' X, merge B B' = XCall X ->
  B = Call X /\ B' = Call X.

Collapse an Undefined behaviour.
Fixpoint collapse (B:XBehaviour) : XBehaviour :=
let rec := fun B' => match collapse B' with XUndefined => XUndefined | _ => B end in
match B with
| XSend p e B' => rec B'
| XRecv p x B' => rec B'
| XSel p l B' => rec B'
| XBranching p mB mB' => match mB, mB' with
                         | None, None => B
                         | Some Bl, None => rec Bl
                         | None, Some Br => rec Br
                         | Some Bl, Some Br => match collapse Bl, collapse Br with
                                               | XUndefined, _ => XUndefined
                                               | _, XUndefined => XUndefined
                                               | _, _ => B
                                               end
                         end
| XCond b B1 B2 => match collapse B1, collapse B2 with
                   | XUndefined, _ => XUndefined
                   | _, XUndefined => XUndefined
                   | _, _ => B
                   end
| _ => B
end.

Relationship with inject.
Lemma collapse_inject : forall B, collapse (inject B) = inject B.

Lemma inject_exists : forall B,
  {B' | B = inject B'} -> collapse B <> XUndefined.

Ltac XBeh_case B HB := elim (XUndefined_dec B); intro HB; try rewrite HB; auto;
  rewrite Xmatch_elim; auto.

Elimination lemmas.
Relationship with merge.
Local Ltac prove_this B HB :=
    elim (XUndefined_dec B); intro HB;
    [ rewrite HB; auto | rewrite Xmatch_elim; auto ].

Local Ltac assert_this B B' H :=
  assert ({ collapse B = XUndefined } + { collapse B' = XUndefined });
  [ elim (XUndefined_dec (collapse B)); auto; intros;
    elim (XUndefined_dec (collapse B')); auto; intros;
    do 2 rewrite Xmatch_elim in H; auto; inversion H | idtac].

Lemma collapse_merge : forall B B',
  collapse B = XUndefined -> collapse (Xmerge B B') = XUndefined.

Lemma collapse_merge' : forall B B',
  collapse B' = XUndefined -> collapse (Xmerge B B') = XUndefined.

Lemma Xmerge_idempotent : forall B, collapse B <> XUndefined ->
  Xmerge B B = B.

Inversion lemmas for Xmerge.
Lemma Xmerge_Cond_inv : forall b Bt Bt' Be Be',
  Xmerge Bt Bt' <> XUndefined -> Xmerge Be Be' <> XUndefined ->
  Xmerge (XCond b Bt Be) (XCond b Bt' Be') = XCond b (Xmerge Bt Bt') (Xmerge Be Be').

Lemma Xmerge_inv_Send : forall B1 B2 p e B,
  Xmerge B1 B2 = XSend p e B -> exists B1' B2',
  B1 = XSend p e B1' /\ B2 = XSend p e B2' /\ Xmerge B1' B2' = B.

Lemma Xmerge_inv_Recv : forall B1 B2 p x B,
  Xmerge B1 B2 = XRecv p x B -> exists B1' B2',
  B1 = XRecv p x B1' /\ B2 = XRecv p x B2' /\ Xmerge B1' B2' = B.

Lemma Xmerge_inv_Sel : forall B1 B2 p l B,
  Xmerge B1 B2 = XSel p l B -> exists B1' B2',
  B1 = XSel p l B1' /\ B2 = XSel p l B2' /\ Xmerge B1' B2' = B.

Lemma Xmerge_inv_Branching : forall B B' p Bl Br, Xmerge B B' = XBranching p Bl Br ->
  exists Bl' Bl'' Br' Br'', B = XBranching p Bl' Br' /\ B' = XBranching p Bl'' Br''
  /\ (Bl = None -> Bl' = None /\ Bl'' = None)
  /\ (Br = None -> Br' = None /\ Br'' = None)
  /\ (forall BL, Bl = Some BL ->
         (Bl' = None -> Bl'' = Some BL) /\ (Bl'' = None -> Bl' = Some BL)
      /\ (forall BL' BL'', Bl' = Some BL' /\ Bl'' = Some BL'' -> Xmerge BL' BL'' = BL))
  /\ (forall BR, Br = Some BR ->
         (Br' = None -> Br'' = Some BR) /\ (Br'' = None -> Br' = Some BR)
      /\ (forall BR' BR'', Br' = Some BR' /\ Br'' = Some BR'' -> Xmerge BR' BR'' = BR)).

Lemma Xmerge_inv_inject : forall B1 B2 B, Xmerge B1 B2 = inject B ->
  exists B', B1 = inject B'.

Lemma Xmerge_inv_inject' : forall B1 B2 B, Xmerge B1 B2 = inject B ->
  exists B', B2 = inject B'.

Lemma Xmerge_inv : forall B1 B2 B, Xmerge B1 B2 = inject B ->
  exists B'1 B'2, B1 = inject B'1 /\ B2 = inject B'2 /\ merge B'1 B'2 = inject B.

Lemma Xmerge_inv_XCall : forall B B' X,
  Xmerge B B' = XCall X -> B = XCall X.

End Merge.

End SP_Merge.