(*CompCert imports*)
Require Import AST.
Require Import Events.
Require Import Memory.
Require Import Coqlib.
Require Import Values.
Require Import Maps.
Require Import Integers.
Require Import Axioms.
Require Import Globalenvs.

Require Import mem_lemmas.

(*A value that is (if its a pointer) not dangling wrt m - a condition
 like this will probably be need to imposed on after-external return
 values (and thus also on the values returned by halted)*)
Definition val_valid (v:val) (m:mem):Prop :=
     match v with Vptr b ofs => Mem.valid_block m b | _ => True
     end.

(*In fact val_valid is a slight relaxtion of valid_pointer*)
Lemma valid_ptr_val_valid: forall b ofs m,
    Mem.valid_pointer m b ofs = true -> val_valid (Vptr b (Int.repr ofs)) m.
Proof. intros.
  apply Mem.valid_pointer_nonempty_perm in H. eapply Mem.perm_valid_block. apply H.
Qed.

Lemma extends_valvalid: forall m1 m2 (Ext: Mem.extends m1 m2) v,
        val_valid v m1 <-> val_valid v m2.
Proof. intros.
  split; intros. destruct v; simpl in *; try econstructor.
     eapply (Mem.valid_block_extends _ _ _ Ext). apply H.
  destruct v; simpl in *; try econstructor.
     eapply (Mem.valid_block_extends _ _ _ Ext). apply H.
Qed.

Lemma inject_valvalid: forall j m1 m2 (Inj: Mem.inject j m1 m2) v2 (V:val_valid v2 m2) v1,
             val_inject j v1 v2 -> val_valid v1 m1.
Proof. intros.
  inv H. constructor. constructor. constructor.
     simpl in *. eapply Mem.valid_block_inject_1; eassumption.
     constructor.
Qed.

(*Preservation of val_valid along an injection only holds
  if the LHS value is defined*)
Lemma inject_valvalid_1:
  forall (j : meminj) (m1 m2 : mem),
  Mem.inject j m1 m2 ->
  forall v1 : val,
  val_valid v1 m1 -> forall v2 : val, val_inject j v1 v2 ->
  match v1 with Vundef => True
      | _ => val_valid v2 m2
  end.
Proof. intros.
  destruct v1; trivial.
  inv H1; trivial.
  inv H1; trivial.
  inv H1; trivial.
  inv H1. simpl in *.
  eapply Mem.valid_block_inject_2; eassumption.
Qed.

(*memories that do not contain "dangling pointers"*)
Definition mem_wd m := Mem.inject_neutral (Mem.nextblock m) m.

Lemma align_chunk_0: forall chunk, (align_chunk chunk | 0).
Proof.
  intros chunk. destruct chunk; simpl; apply Z.divide_0_r.
Qed.

Lemma mem_wdI: forall m,
  (forall (b:block) ofs  (R:Mem.perm m b ofs Cur Readable),
    memval_inject  (Mem.flat_inj (Mem.nextblock m))
    (ZMap.get ofs (PMap.get b (Mem.mem_contents m)))
    (ZMap.get ofs (PMap.get b (Mem.mem_contents m)))) -> mem_wd m.
Proof. intros.
  split; intros.
     apply flatinj_E in  H0. destruct H0 as [? [? ?]]; subst. rewrite Zplus_0_r. trivial.
     apply flatinj_E in  H0. destruct H0 as [? [? ?]]; subst. apply align_chunk_0.
     apply flatinj_E in  H0. destruct H0 as [? [? ?]]; subst. rewrite Zplus_0_r.
        apply H. apply H1.
Qed.

Lemma mem_wd_E: forall m, mem_wd m ->  Mem.inject (Mem.flat_inj (Mem.nextblock m)) m m.
Proof. intros. apply Mem.neutral_inject. apply H. Qed.

Lemma meminj_split_flatinjR: forall j m m' (J:Mem.inject j m' m), mem_wd m ->
     j = compose_meminj j (Mem.flat_inj (Mem.nextblock m)).
Proof. intros. apply mem_wd_E in H.
   unfold  compose_meminj.
   apply extensionality. intro b.
   remember (j b).
   destruct o; trivial. destruct p. unfold Mem.flat_inj in *.
   destruct (plt b0 (Mem.nextblock m)).
     rewrite Zplus_0_r. trivial.
   inv J. apply eq_sym in Heqo. specialize (mi_mappedblocks _ _ _ Heqo).
               exfalso. unfold Mem.valid_block in mi_mappedblocks. xomega.
Qed.

Lemma meminj_split_flatinjL: forall j m m' (J:Mem.inject j m m'), mem_wd m ->
     j = compose_meminj (Mem.flat_inj (Mem.nextblock m)) j.
Proof. intros. apply mem_wd_E in H.
   unfold  compose_meminj.
   apply extensionality. intro b.
   unfold Mem.flat_inj in *.
   destruct (plt b (Mem.nextblock m)).
     remember (j b). destruct o. destruct p0.  rewrite Zplus_0_l. trivial. trivial.
  inv J. apply mi_freeblocks. assumption.
Qed.

Lemma mem_wd_inject_splitL: forall j m1 m2
              (J:Mem.inject j m1 m2)  (WD: mem_wd m1),
     Mem.inject (Mem.flat_inj (Mem.nextblock m1)) m1 m1
     /\ j = compose_meminj (Mem.flat_inj (Mem.nextblock m1)) j.
Proof. intros.
    split. apply mem_wd_E. apply WD.
    eapply (meminj_split_flatinjL _ _ _ J WD).
Qed.

Lemma mem_wd_inject_splitR: forall j m1 m2
              (J:Mem.inject j m1 m2)  (WD: mem_wd m2),
     Mem.inject (Mem.flat_inj (Mem.nextblock m2)) m2 m2
     /\ j = compose_meminj j (Mem.flat_inj (Mem.nextblock m2)).
Proof. intros.
    split. apply mem_wd_E. apply WD.
    eapply (meminj_split_flatinjR _ _ _ J WD).
Qed.

(*Preservation of mem_wd by memory operations*)
Lemma mem_wd_empty: mem_wd Mem.empty.
Proof.  apply Mem.empty_inject_neutral. Qed.

Lemma  mem_wd_alloc: forall m b lo hi m' (ALL: Mem.alloc m lo hi = (m',b))
     (WDm: mem_wd m), mem_wd m'.
Proof. intros. unfold mem_wd in *.
  rewrite (Mem.nextblock_alloc _ _ _ _ _ ALL).
  eapply (Mem.alloc_inject_neutral _ _ _ _ _ _ ALL); try omega.
  inv WDm.
         split; intros.
             apply flatinj_E in H. destruct H as [? [? ?]]; subst. rewrite Zplus_0_r. assumption.
             apply flatinj_E in H. destruct H as [? [? ?]]; subst. apply align_chunk_0.
             apply flatinj_E in H. destruct H as [? [? ?]]; subst. rewrite Zplus_0_r.
                 assert (X: Mem.flat_inj (Mem.nextblock m) b1 = Some (b1, 0)).
                     apply flatinj_I. apply (Mem.perm_valid_block _ _ _ _ _ H0).
                  specialize (mi_memval _ _ _ _ X H0). rewrite Zplus_0_r in mi_memval.
                  eapply memval_inject_incr; try eassumption.
                       intros bb; intros.
                        eapply flatinj_mono; try eassumption; xomega.
       xomega.
Qed.

Lemma  mem_wd_drop: forall m b lo hi p m' (DROP: Mem.drop_perm m b lo hi p = Some m')
     (WDm: mem_wd m), Mem.valid_block m b -> mem_wd m'.
Proof. intros. unfold mem_wd in *.
  rewrite (Mem.nextblock_drop _ _ _ _ _ _ DROP).
  eapply (Mem.drop_inject_neutral _ _ _ _ _ _ _ DROP); trivial.
Qed.

Lemma free_neutral: forall (thr : block) (m : mem) (lo hi : Z) (b : block) (m' : Mem.mem')
  (FREE: Mem.free m b lo hi = Some m'),
  Mem.inject_neutral thr m -> Mem.inject_neutral thr m'.
Proof. intros. inv H.
  split; intros.
     apply flatinj_E in H. destruct H as [? [? ?]]; subst. rewrite Zplus_0_r. assumption.
     apply flatinj_E in H. destruct H as [? [? ?]]; subst. apply align_chunk_0.
     apply flatinj_E in H. destruct H as [? [? ?]]; subst. rewrite Zplus_0_r.
        assert (X: Mem.flat_inj thr b1 = Some (b1,0)). apply flatinj_I. assumption.
        assert (Y:= Mem.perm_free_3 _ _ _ _ _ FREE _ _ _ _ H0).
         specialize (mi_memval _ _ _ _ X Y). rewrite Zplus_0_r in *.
         rewrite (Mem.free_result _ _ _ _ _ FREE) in *. simpl in *. apply mi_memval.
Qed.

Lemma mem_wd_free: forall m b lo hi m' (WDm: mem_wd m)
  (FREE: Mem.free m b lo hi = Some m'), mem_wd m'.
Proof. intros. unfold mem_wd in *.
  eapply free_neutral. apply FREE.
   rewrite (Mem.nextblock_free _ _ _ _ _ FREE). assumption.
Qed.

Lemma mem_wd_store: forall m b ofs v m' chunk (WDm: mem_wd m)
  (ST: Mem.store chunk m b ofs v = Some m')
  (V: val_valid v m), mem_wd m'.
Proof. intros. unfold mem_wd in *.
  eapply Mem.store_inject_neutral. apply ST.
      rewrite (Mem.nextblock_store _ _ _ _ _ _ ST). assumption.
      assert (X:= Mem.store_valid_access_3 _ _ _ _ _ _ ST).
          rewrite (Mem.nextblock_store _ _ _ _ _ _ ST).
           apply (Mem.valid_access_implies _ _ _ _ _  Nonempty) in X.
                apply Mem.valid_access_valid_block in X. apply X.
            constructor.
      rewrite (Mem.nextblock_store _ _ _ _ _ _ ST).
          destruct v; try solve [constructor].
            econstructor. eapply flatinj_I. apply V.
                          rewrite Int.add_zero. trivial.
Qed.

Lemma extends_memwd:
forall m1 m2 (Ext: Mem.extends m1 m2), mem_wd m2 -> mem_wd m1.
Proof.
  intros. eapply mem_wdI. intros.
  assert (Mem.perm m2 b ofs Cur Readable).
    eapply (Mem.perm_extends _ _ _ _ _ _ Ext R).
  assert (Mem.valid_block m2 b).
     apply (Mem.perm_valid_block _ _ _ _ _ H0).
  destruct Ext. rewrite mext_next.
  assert (Mem.flat_inj (Mem.nextblock m2) b = Some (b,0)).
    apply flatinj_I. apply H1.
  destruct mext_inj. specialize (mi_memval b ofs b 0 (eq_refl _) R).
  rewrite Zplus_0_r in mi_memval.
  destruct H. specialize (mi_memval0 b ofs b 0 H2 H0).
  rewrite Zplus_0_r in mi_memval0.
  remember (ZMap.get ofs (PMap.get b (Mem.mem_contents m1))) as v.
  destruct v. constructor. constructor.
  econstructor.
    eapply flatinj_I. inv mi_memval. inv H4. rewrite Int.add_zero in H6.
      rewrite <- H6 in mi_memval0. simpl in mi_memval0. inversion mi_memval0.
      apply flatinj_E in H4. apply H4.
   rewrite Int.add_zero. reflexivity.
Qed.

Require Import reach.

Inductive valid_genv {F V:Type} (ge:Genv.t F V) (m:mem) : Type :=
  mk_valid_genv :
    (forall b, isGlobalBlock ge b=true -> val_valid (Vptr b Int.zero) m) ->
    (forall b f, Genv.find_funct_ptr ge b = Some f -> val_valid (Vptr b Int.zero) m) ->
    valid_genv ge m.

Lemma valid_genv_alloc: forall {F V:Type} (ge:Genv.t F V) (m m1:mem) lo hi b
    (ALLOC: Mem.alloc m lo hi = (m1,b)) (G: valid_genv ge m), valid_genv ge m1.
Proof. intros. case G; intros. constructor; intros.
  apply (Mem.valid_block_alloc _ _ _ _ _ ALLOC).
  apply (v _ H).
  apply (Mem.valid_block_alloc _ _ _ _ _ ALLOC).
  apply (v0 _ _ H).
Qed.

Lemma valid_genv_store: forall {F V:Type} (ge:Genv.t F V) m m1 b ofs v chunk
    (STORE: Mem.store chunk m b ofs v = Some m1)
     (G: valid_genv ge m), valid_genv ge m1.
Proof. intros. case G; intros. constructor; intros.
  apply (Mem.store_valid_block_1 _ _ _ _ _ _ STORE).
  apply (v0 _ H).
  apply (Mem.store_valid_block_1 _ _ _ _ _ _ STORE).
  apply (v1 _ _ H).
Qed.

Lemma valid_genv_store_zeros: forall {F V:Type} (ge:Genv.t F V) m m1 b y z
    (STORE_ZERO: store_zeros m b y z = Some m1)
    (G: valid_genv ge m), valid_genv ge m1.
Proof. intros. case G; intros. constructor; intros.
  apply Genv.store_zeros_nextblock in STORE_ZERO.
  specialize (v _ H); simpl in *.
  unfold Mem.valid_block in *.
  rewrite STORE_ZERO. apply G; auto.
  specialize (v0 _ _ H); simpl in *.
  apply Genv.store_zeros_nextblock in STORE_ZERO.
  unfold Mem.valid_block in *.
  rewrite STORE_ZERO. auto.
Qed.

Lemma mem_wd_store_zeros: forall m b p n m1
    (STORE_ZERO: store_zeros m b p n = Some m1) (WD: mem_wd m), mem_wd m1.
Proof. intros until n. functional induction (store_zeros m b p n); intros.
  inv STORE_ZERO; tauto.
  apply (IHo _ STORE_ZERO); clear IHo.
      eapply (mem_wd_store m). apply WD. apply e0. simpl; trivial.
  inv STORE_ZERO.
Qed.

Lemma valid_genv_drop: forall {F V:Type} (ge:Genv.t F V) (m m1:mem) b lo hi p
    (DROP: Mem.drop_perm m b lo hi p = Some m1) (G: valid_genv ge m),
    valid_genv ge m1.
Proof. intros. case G; intros. constructor; intros.
  apply (Mem.drop_perm_valid_block_1 _ _ _ _ _ _ DROP).
  apply (v _ H); auto.
  apply (Mem.drop_perm_valid_block_1 _ _ _ _ _ _ DROP).
  apply (v0 _ _ H); auto.
Qed.

Lemma mem_wd_store_init_data: forall {F V} (ge: Genv.t F V) a (b:block) (z:Z)
  m1 m2 (SID:Genv.store_init_data ge m1 b z a = Some m2),
  valid_genv ge m1 -> mem_wd m1 -> mem_wd m2.
Proof. intros F V ge a.
  destruct a; simpl; intros;
      try apply (mem_wd_store _ _ _ _ _ _ H0 SID); simpl; trivial.
   inv SID; trivial.
   remember (Genv.find_symbol ge i) as d.
     destruct d; inv SID.
     eapply (mem_wd_store _ _ _ _ _ _ H0 H2).
    apply eq_sym in Heqd.
    destruct H.
    apply v.
    unfold isGlobalBlock.
    rewrite orb_true_iff.
    unfold genv2blocksBool; simpl.
    apply Genv.find_invert_symbol in Heqd.
    rewrite Heqd; left; auto.
Qed.

Lemma valid_genv_store_init_data:
  forall {F V}  (ge: Genv.t F V) a (b:block) (z:Z) m1 m2
  (SID: Genv.store_init_data ge m1 b z a = Some m2),
  valid_genv ge m1 -> valid_genv ge m2.
Proof. intros F V ge a.
  destruct a; simpl; intros; inv H; constructor;
    try (intros b0 X; eapply Mem.store_valid_block_1 with (b':=b0); eauto;
          apply H0; auto);
    try (intros b0 ? X; eapply Mem.store_valid_block_1 with (b':=b0); eauto;
          eapply H1; eauto);
    try (inv SID; auto).
  intros.
  remember (Genv.find_symbol ge i) as d.
  destruct d; inv H2.
  eapply Mem.store_valid_block_1; eauto.
  apply eq_sym in Heqd.
  eapply H0; eauto.
  revert H2. destruct (Genv.find_symbol ge i); intros; try congruence.
  eapply Mem.store_valid_block_1; eauto.
  eapply H1; eauto.
Qed.

Lemma mem_wd_store_init_datalist: forall {F V} (ge: Genv.t F V) l (b:block)
  (z:Z) m1 m2 (SID: Genv.store_init_data_list ge m1 b z l = Some m2),
  valid_genv ge m1 -> mem_wd m1 -> mem_wd m2.
Proof. intros F V ge l.
  induction l; simpl; intros.
    inv SID. trivial.
  remember (Genv.store_init_data ge m1 b z a) as d.
  destruct d; inv SID; apply eq_sym in Heqd.
  apply (IHl _ _ _ _ H2); clear IHl H2.
     eapply valid_genv_store_init_data. apply Heqd. apply H.
  eapply mem_wd_store_init_data. apply Heqd. apply H. apply H0.
Qed.

Lemma valid_genv_store_init_datalist: forall {F V} (ge: Genv.t F V) l (b:block)
  (z:Z) m1 m2 (SID: Genv.store_init_data_list ge m1 b z l = Some m2),
   valid_genv ge m1 -> valid_genv ge m2.
Proof. intros F V ge l.
  induction l; simpl; intros.
    inv SID. trivial.
  remember (Genv.store_init_data ge m1 b z a) as d.
  destruct d; inv SID; apply eq_sym in Heqd.
  apply (IHl _ _ _ _ H1); clear IHl H1.
     eapply valid_genv_store_init_data. apply Heqd. apply H.
Qed.

Lemma mem_wd_alloc_global: forall  {F V} (ge: Genv.t F V) a m0 m1
   (GA: Genv.alloc_global ge m0 a = Some m1),
   mem_wd m0 -> valid_genv ge m0 -> mem_wd m1.
Proof. intros F V ge a.
destruct a; simpl. intros.
destruct g.
  remember (Mem.alloc m0 0 1) as mm. destruct mm.
    apply eq_sym in Heqmm.
    specialize (mem_wd_alloc _ _ _ _ _ Heqmm). intros.
     eapply (mem_wd_drop _ _ _ _ _  _ GA).
    apply (H1 H).
    apply (Mem.valid_new_block _ _ _ _ _ Heqmm).
remember (Mem.alloc m0 0 (Genv.init_data_list_size (AST.gvar_init v)) ) as mm.
  destruct mm. apply eq_sym in Heqmm.
  remember (store_zeros m b 0 (Genv.init_data_list_size (AST.gvar_init v)))
           as d.
  destruct d; inv GA; apply eq_sym in Heqd.
  remember (Genv.store_init_data_list ge m2 b 0 (AST.gvar_init v)) as dd.
  destruct dd; inv H2; apply eq_sym in Heqdd.
  eapply (mem_wd_drop _ _ _ _ _ _ H3); clear H3.
    eapply (mem_wd_store_init_datalist _ _ _ _ _ _ Heqdd).
    apply (valid_genv_store_zeros _ _ _ _ _ _ Heqd).
    apply (valid_genv_alloc ge _ _ _ _ _ Heqmm H0).
  apply (mem_wd_store_zeros _ _ _ _ _ Heqd).
    apply (mem_wd_alloc _ _ _ _ _ Heqmm H).
  unfold Mem.valid_block.
     apply Genv.store_init_data_list_nextblock in Heqdd.
           rewrite Heqdd. clear Heqdd.
      apply Genv.store_zeros_nextblock in Heqd. rewrite Heqd; clear Heqd.
      apply (Mem.valid_new_block _ _ _ _ _  Heqmm).
Qed.

Lemma valid_genv_alloc_global: forall  {F V} (ge: Genv.t F V) a m0 m1
   (GA: Genv.alloc_global ge m0 a = Some m1),
   valid_genv ge m0 -> valid_genv ge m1.
Proof. intros F V ge a.
destruct a; simpl. intros.
destruct g.
  remember (Mem.alloc m0 0 1) as d. destruct d.
    apply eq_sym in Heqd.
    apply (valid_genv_drop _ _ _ _ _ _ _ GA).
    apply (valid_genv_alloc _ _ _ _ _ _ Heqd H).
remember (Mem.alloc m0 0 (Genv.init_data_list_size (AST.gvar_init v)) )
         as Alloc.
  destruct Alloc. apply eq_sym in HeqAlloc.
  remember (store_zeros m b 0
           (Genv.init_data_list_size (AST.gvar_init v))) as SZ.
  destruct SZ; inv GA; apply eq_sym in HeqSZ.
  remember (Genv.store_init_data_list ge m2 b 0 (AST.gvar_init v)) as Drop.
  destruct Drop; inv H1; apply eq_sym in HeqDrop.
  eapply (valid_genv_drop _ _ _ _ _ _ _ H2); clear H2.
  eapply (valid_genv_store_init_datalist _ _ _ _ _ _ HeqDrop). clear HeqDrop.
  apply (valid_genv_store_zeros _ _ _ _ _ _ HeqSZ).
    apply (valid_genv_alloc _ _ _ _ _ _ HeqAlloc H).
Qed.

Lemma valid_genv_alloc_globals:
   forall F V (ge: Genv.t F V) init_list m0 m
   (GA: Genv.alloc_globals ge m0 init_list = Some m),
   valid_genv ge m0 -> valid_genv ge m.
Proof. intros F V ge l.
induction l; intros; simpl in *.
  inv GA. assumption.
remember (Genv.alloc_global ge m0 a) as d.
  destruct d; inv GA. apply eq_sym in Heqd.
  eapply (IHl  _ _  H1). clear H1.
    apply (valid_genv_alloc_global _ _ _ _ Heqd H).
Qed.

Lemma mem_wd_alloc_globals:
   forall F V (ge: Genv.t F V) init_list m0 m
   (GA: Genv.alloc_globals ge m0 init_list = Some m),
   mem_wd m0 -> valid_genv ge m0 -> mem_wd m.
Proof. intros F V ge l.
induction l; intros; simpl in *.
  inv GA. assumption.
remember (Genv.alloc_global ge m0 a) as d.
  destruct d; inv GA. apply eq_sym in Heqd.
eapply (IHl  _ _  H2).
    apply (mem_wd_alloc_global ge _ _ _ Heqd H H0).
    apply (valid_genv_alloc_global _ _ _ _ Heqd H0).
Qed.

Lemma mem_wd_load: forall m ch b ofs v
  (LD: Mem.load ch m b ofs = Some v)
  (WD : mem_wd m), val_valid v m.
Proof. intros.
  destruct v; simpl; trivial.
  destruct (Mem.load_valid_access _ _ _ _ _ LD) as [Perms Align].
  apply Mem.load_result in LD.
  apply eq_sym in LD. apply decode_val_pointer_inv in LD.
  destruct LD.
  destruct ch; inv H; simpl in *.
  unfold mem_wd in WD. unfold Mem.inject_neutral in WD.
  destruct WD.
  assert (Arith: ofs <= ofs < ofs + 4). omega.
  specialize (Perms _ Arith).
  assert (VB:= Mem.perm_valid_block _ _ _ _ _ Perms).
  assert (Z:= flatinj_I (Mem.nextblock m) b VB).
  specialize (mi_memval _ _ _ _ Z Perms).
  inv H0. rewrite Zplus_0_r in mi_memval. rewrite H1 in mi_memval.
  inversion mi_memval. clear H9. subst.
  apply flatinj_E in H5. apply H5.
Qed.

Lemma mem_wd_storebytes: forall m b ofs bytes m' (WDm: mem_wd m)
  (ST: Mem.storebytes m b ofs bytes = Some m')
  (BytesValid: forall v, In v bytes ->
               memval_inject (Mem.flat_inj (Mem.nextblock m)) v v),
   mem_wd m'.
Proof. intros. apply mem_wdI. intros.
  assert (F: Mem.flat_inj (Mem.nextblock m) b0 = Some (b0, 0)).
        apply flatinj_I.
        apply (Mem.storebytes_valid_block_2 _ _ _ _ _ ST).
        eapply Mem.perm_valid_block; eassumption.
  apply mem_wd_E in WDm.
  assert (P:= Mem.perm_storebytes_2 _ _ _ _ _ ST _ _ _ _ R).
  specialize (Mem.mi_memval _ _ _ (Mem.mi_inj _ _ _ WDm) _ _ _ _ F P).
  rewrite Zplus_0_r.
  intros MVI.
  rewrite (Mem.nextblock_storebytes _ _ _ _ _ ST).
  rewrite (Mem.storebytes_mem_contents _ _ _ _ _ ST).
  remember (eq_block b0 b).
  destruct s; subst; clear Heqs.
  (*case b0=b*)
    rewrite PMap.gss.
    remember (zlt ofs0 ofs) as d.
    destruct d; clear Heqd.
    (*case ofs0 < ofs*)
      rewrite Mem.setN_outside; try (left; assumption).
      assumption.
    (*case ofs0 >= ofs*)
      remember (zlt ofs0 (ofs + (Z.of_nat (length bytes)))) as d.
      destruct d; clear Heqd.
      (*case <*)
        eapply Mem.setN_property.
          apply BytesValid.
          split. omega. apply l.
      (*case >= *)
         rewrite Mem.setN_outside; try (right; assumption).
      assumption.
  (*case b0 <> b*)
    rewrite PMap.gso; trivial.
Qed.

Lemma getN_aux: forall n p c B1 v B2, Mem.getN n p c = B1 ++ v::B2 ->
    v = ZMap.get (p + Z.of_nat (length B1)) c.
Proof. intros n.
  induction n; simpl; intros.
    destruct B1; simpl in *. inv H. inv H.
    destruct B1; simpl in *.
      inv H. rewrite Zplus_0_r. trivial.
      inv H. specialize (IHn _ _ _ _ _ H2). subst.
        rewrite Zpos_P_of_succ_nat.
        remember (Z.of_nat (length B1)) as m. clear Heqm H2. rewrite <- Z.add_1_l.
         rewrite Zplus_assoc. trivial.
Qed.

Lemma getN_range: forall n ofs M bytes1 v bytes2,
  Mem.getN n ofs M = bytes1 ++ v::bytes2 ->
  (length bytes1 < n)%nat.
Proof. intros n.
  induction n; simpl; intros.
    destruct bytes1; inv H.
    destruct bytes1; simpl in *; inv H.
      omega.
    specialize (IHn _ _ _ _ _ H2). omega.
Qed.

Lemma loadbytes_D: forall m b ofs n bytes
      (LD: Mem.loadbytes m b ofs n = Some bytes),
      Mem.range_perm m b ofs (ofs + n) Cur Readable /\
      bytes = Mem.getN (nat_of_Z n) ofs (PMap.get b (Mem.mem_contents m)).
Proof. intros.
  Transparent Mem.loadbytes.
  unfold Mem.loadbytes in LD.
  Opaque Mem.loadbytes.
  remember (Mem.range_perm_dec m b ofs (ofs + n) Cur Readable) as d.
  destruct d; inv LD. auto.
Qed.

Lemma loadbytes_valid: forall m (WD: mem_wd m) b ofs' n bytes
      (LD: Mem.loadbytes m b (Int.unsigned ofs') n = Some bytes)
      v (B: In v bytes),
      memval_inject (Mem.flat_inj (Mem.nextblock m)) v v.
Proof. intros.
  destruct (loadbytes_D _ _ _ _ _ LD) as [Range BB]; subst.
  assert (L:= Mem.loadbytes_length _ _ _ _ _ LD).
  apply In_split in B. destruct B as [bytes1 [bytes2 B]]. subst.
  assert (I: Int.unsigned ofs' <= (Int.unsigned ofs') + Z.of_nat (length bytes1) <
                  Int.unsigned ofs' + n).
    assert (II:= getN_range _ _ _ _ _ _ B).
    clear Range LD B L.
    split. omega.
    assert (Z.of_nat (length bytes1) < Z.of_nat (nat_of_Z n)).
        omega.
    rewrite nat_of_Z_eq in H. omega. clear H.
     unfold nat_of_Z in II.
        destruct n. omega. specialize (Pos2Z.is_pos p); omega.
        rewrite Z2Nat.inj_neg in II. destruct bytes1; simpl in II; inv II.
  specialize (Range _ I).
  assert (F: Mem.flat_inj (Mem.nextblock m) b = Some (b, 0)).
    apply flatinj_I. apply Mem.perm_valid_block in Range. apply Range.
    specialize (Mem.mi_memval _ _ _ WD _ _ _ _ F Range).
    intros. rewrite Zplus_0_r in H.
   apply getN_aux in B. subst. apply H.
Qed.

Lemma freelist_mem_wd: forall l m m'
      (M: Mem.free_list m l = Some m')
      (WD: mem_wd m), mem_wd m'.
Proof. intros l.
  induction l; simpl; intros.
    inv M; trivial.
  destruct a. destruct p.
  remember (Mem.free m b z0 z) as d.
  destruct d; inv M; apply eq_sym in Heqd.
  apply (IHl _ _ H0).
  eapply mem_wd_free; eassumption.
Qed.


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.MinimunLogic.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
  | sepcon : expr -> expr -> expr
  | wand : expr -> expr -> expr
  | emp : expr
  | falsep : expr
  | varp : Var -> expr.

Arguments expr: clear implicits.

Definition expr_eqb {Sigma: PropositionalVariables} (eqb: Var -> Var -> bool): expr Sigma -> expr Sigma -> bool :=
  fix expr_eqb x1 x2 :=
    match x1, x2 with
    | andp y1 z1, andp y2 z2 => andb (expr_eqb y1 y2) (expr_eqb z1 z2)
    | orp y1 z1, orp y2 z2 => andb (expr_eqb y1 y2) (expr_eqb z1 z2)
    | impp y1 z1, impp y2 z2 => andb (expr_eqb y1 y2) (expr_eqb z1 z2)
    | sepcon y1 z1, sepcon y2 z2 => andb (expr_eqb y1 y2) (expr_eqb z1 z2)
    | wand y1 z1, wand y2 z2 => andb (expr_eqb y1 y2) (expr_eqb z1 z2)
    | emp, emp => true
    | falsep, falsep => true
    | varp p, varp q => eqb p q
    | _, _ => false
    end.

Lemma expr_eqb_true {Sigma: PropositionalVariables} (eqb: Var -> Var -> bool):
  (forall p q, eqb p q = true <-> p = q) ->
  (forall x y, expr_eqb eqb x y = true <-> x = y).
Proof.
  intros.
  revert y; induction x; intros; destruct y;
  try solve [split; intros HH; inversion HH].
  + simpl; rewrite Bool.andb_true_iff.
    split; intros.
    - destruct H0.
      rewrite IHx1 in H0; rewrite IHx2 in H1.
      subst; auto.
    - inversion H0; subst.
      rewrite IHx1, IHx2.
      tauto.
  + simpl; rewrite Bool.andb_true_iff.
    split; intros.
    - destruct H0.
      rewrite IHx1 in H0; rewrite IHx2 in H1.
      subst; auto.
    - inversion H0; subst.
      rewrite IHx1, IHx2.
      tauto.
  + simpl; rewrite Bool.andb_true_iff.
    split; intros.
    - destruct H0.
      rewrite IHx1 in H0; rewrite IHx2 in H1.
      subst; auto.
    - inversion H0; subst.
      rewrite IHx1, IHx2.
      tauto.
  + simpl; rewrite Bool.andb_true_iff.
    split; intros.
    - destruct H0.
      rewrite IHx1 in H0; rewrite IHx2 in H1.
      subst; auto.
    - inversion H0; subst.
      rewrite IHx1, IHx2.
      tauto.
  + simpl; rewrite Bool.andb_true_iff.
    split; intros.
    - destruct H0.
      rewrite IHx1 in H0; rewrite IHx2 in H1.
      subst; auto.
    - inversion H0; subst.
      rewrite IHx1, IHx2.
      tauto.
  + simpl; tauto.
  + simpl; tauto.
  + simpl.
    rewrite H.
    split; intros; congruence.
Qed.

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

Instance minL {Sigma: PropositionalVariables}: MinimunLanguage L :=
  Build_MinimunLanguage L impp.

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

Instance sL {Sigma: PropositionalVariables}: SeparationLanguage L :=
  Build_SeparationLanguage L sepcon wand.

Instance s'L {Sigma: PropositionalVariables}: SeparationEmpLanguage L :=
  Build_SeparationEmpLanguage L sL emp.

Definition rank {Sigma: PropositionalVariables}: expr Sigma -> nat :=
  fix rank (x: expr Sigma): nat :=
    match x with
    | andp y z => 1 + rank y + rank z
    | orp y z => 1 + rank y + rank z
    | impp y z => 1 + rank y + rank z
    | sepcon y z => 1 + rank y + rank z
    | wand y z => 1 + rank y + rank z
    | emp => 0
    | falsep => 0
    | varp p => 0
    end.

Definition formula_countable {Sigma: PropositionalVariables}: Countable Var -> Countable (expr Sigma).
  intros.
  assert (forall n, Countable (sig (fun x: expr Sigma => rank x <= n))).
  + induction n.
    - apply (@bijection_Countable _ (Var + unit + unit)%type); [| solve_Countable].
      apply bijection_sym.
      apply (FBuild_bijection _ _ (fun x =>
               match x with
               | inl (inl p) => exist (fun x: expr Sigma => rank x <= 0) (varp p) (le_n 0)
               | inl (inr _) => exist (fun x: expr Sigma => rank x <= 0) emp (le_n 0)
               | inr _ => exist (fun x: expr Sigma => rank x <= 0) falsep (le_n 0)
               end)).
      * hnf; intros.
        destruct a1 as [[? | []] | []], a2 as [[? | []] | []]; inversion H; auto.
      * hnf; intros.
        destruct b as [[] HH]; try solve [inversion HH].
        1: exists (inl (inr tt)); eauto; f_equal; apply proof_irrelevance.
        1: exists (inr tt); eauto; f_equal; apply proof_irrelevance.
        1: exists (inl (inl v)); eauto; f_equal; apply proof_irrelevance.
    - set (s := sig (fun x: expr Sigma => rank x <= n)).
      apply (@injection_Countable _ (s * s + s * s + s * s + s * s + s * s + unit + unit + Var)%type); [| solve_Countable].

      apply (Build_injection _ _ (fun x y =>
        match y with
        | inl (inl (inl (inl (inl (inl (inl (exist _ y _, exist _ z _))))))) => proj1_sig x = andp y z
        | inl (inl (inl (inl (inl (inl (inr (exist _ y _, exist _ z _))))))) => proj1_sig x = orp y z
        | inl (inl (inl (inl (inl (inr (exist _ y _, exist _ z _)))))) => proj1_sig x = impp y z
        | inl (inl (inl (inl (inr (exist _ y _, exist _ z _))))) => proj1_sig x = sepcon y z
        | inl (inl (inl (inr (exist _ y _, exist _ z _)))) => proj1_sig x = wand y z
        | inl (inl (inr _)) => proj1_sig x = emp
        | inl (inr _) => proj1_sig x = falsep
        | inr p => proj1_sig x = varp p
        end)).
      * hnf; intros.
        destruct a as [[y z | y z | y z | y z | y z | | | p] ?H].
        (* 1 *) simpl in H. assert (rank y <= n) by omega. assert (rank z <= n) by omega.
                exists (inl (inl (inl (inl (inl (inl (inl (exist _ y H0, exist _ z H1)))))))); auto.
        (* 2 *) simpl in H. assert (rank y <= n) by omega. assert (rank z <= n) by omega.
                exists (inl (inl (inl (inl (inl (inl (inr (exist _ y H0, exist _ z H1)))))))); auto.
        (* 3 *) simpl in H. assert (rank y <= n) by omega. assert (rank z <= n) by omega.
                exists (inl (inl (inl (inl (inl (inr (exist _ y H0, exist _ z H1))))))); auto.
        (* 4 *) simpl in H. assert (rank y <= n) by omega. assert (rank z <= n) by omega.
                exists (inl (inl (inl (inl (inr (exist _ y H0, exist _ z H1)))))); auto.
        (* 5 *) simpl in H. assert (rank y <= n) by omega. assert (rank z <= n) by omega.
                exists (inl (inl (inl (inr (exist _ y H0, exist _ z H1))))); auto.
        (* 6 *) exists (inl (inl (inr tt))); auto.
        (* 7 *) exists (inl (inr tt)); auto.
        (* 8 *) exists (inr p); auto.
      * hnf; intros.
        destruct a as [[y z | y z | y z | y z | y z | | | p] ?H];
        destruct b1 as [[[[[[[[[y1 ?H] [z1 ?H]] | [[y1 ?H] [z1 ?H]]] | [[y1 ?H] [z1 ?H]]] | [[y1 ?H] [z1 ?H]]] | [[y1 ?H] [z1 ?H]]] |] |] | p1]; try solve [inversion H];
        destruct b2 as [[[[[[[[[y2 ?H] [z2 ?H]] | [[y2 ?H] [z2 ?H]]] | [[y2 ?H] [z2 ?H]]] | [[y2 ?H] [z2 ?H]]] | [[y2 ?H] [z2 ?H]]] |] |] | p2]; try solve [inversion H0].
        (* 1 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 2 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 3 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 4 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 5 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 6 *) destruct u, u0; auto.
        (* 7 *) destruct u, u0; auto.
        (* 8 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
      * hnf; intros.
        destruct b as [[[[[[[[[y ?H] [z ?H]] | [[y ?H] [z ?H]]] | [[y ?H] [z ?H]]] | [[y ?H] [z ?H]]] | [[y ?H] [z ?H]]] |] |] | p];
        destruct a1 as [[y1 z1 | y1 z1 | y1 z1 | y1 z1 | y1 z1 | | | p1] ?H]; try solve [inversion H];
        destruct a2 as [[y2 z2 | y2 z2 | y2 z2 | y2 z2 | y2 z2 | | | p2] ?H]; try solve [inversion H0].
        (* 1 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 2 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 3 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 4 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 5 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
        (* 6 *) f_equal; apply proof_irrelevance.
        (* 7 *) f_equal; apply proof_irrelevance.
        (* 8 *) inversion H; inversion H0; subst; subst; repeat f_equal; apply proof_irrelevance.
  + apply (@injection_Countable _ (sigT (fun n => sig (fun x: expr Sigma => rank x <= n)))); [| solve_Countable; auto].
    apply (FBuild_injection _ _ (fun x0 => existT (fun n => sig (fun x => rank x <= n)) (rank x0) (exist (fun x => rank x <= rank x0) x0 (le_n (rank x0))))).
    hnf; intros.
    simpl in H.
    inversion H; auto.
Qed. (* 9 seconds *)


(**
In this exercise we consider a variant of the previous exercise. We have a
reference which is initially 0 and two threads running in parallel. One thread
increases the value of the reference by 2, whereas the other multiples the
value of the reference by two. An interesting aspect of this exercise is that
the outcome of this program is non-deterministic. Depending on which thread runs
first, the outcome is either 2 or 4.

There is no "fetch-and-multiply" operation in heap_lang, so we use the spin lock
from exercise 3 instead to make both the addition and the multiplication atomic.

Contrary to the earlier exercises, this exercise is nearly entirely open.
*)
From iris.algebra Require Import excl_auth frac_auth.
From iris.base_logic.lib Require Import invariants.
From iris.heap_lang Require Import proofmode notation lib.par.
From exercises Require Import ex_03_spinlock.

Definition parallel_add_mul : expr :=
  let: "r" := ref #0 in
  let: "l" := newlock #() in
  (
    (acquire "l";; "r" <- !"r" + #2;; release "l")
  |||
    (acquire "l";; "r" <- !"r" * #2;; release "l")
  );;
  acquire "l";;
  !"r".

(** In this proof we will make use of Boolean ghost variables. *)
Section proof.
  Context `{!heapG Σ, !spawnG Σ, !inG Σ (excl_authR boolO)}.

  (** The same helping lemmas for ghost variables that we have already seen in
  the previous exercise. *)
  Lemma ghost_var_alloc b :
    ⊢ |==> ∃ γ, own γ (●E b) ∗ own γ (◯E b).
  Proof.
    iMod (own_alloc (●E b ⋅ ◯E b)) as (γ) "[??]".
    - by apply excl_auth_valid.
    - by eauto with iFrame.
  Qed.

  Lemma ghost_var_agree γ b c :
    own γ (●E b) -∗ own γ (◯E c) -∗ ⌜ b = c ⌝.
  Proof.
    iIntros "Hγ● Hγ◯".
    by iDestruct (own_valid_2 with "Hγ● Hγ◯") as %<-%excl_auth_agree_L.
  Qed.

  Lemma ghost_var_update γ b' b c :
    own γ (●E b) -∗ own γ (◯E c) ==∗ own γ (●E b') ∗ own γ (◯E b').
  Proof.
    iIntros "Hγ● Hγ◯".
    iMod (own_update_2 _ _ _ (●E b' ⋅ ◯E b') with "Hγ● Hγ◯") as "[$$]".
    { by apply excl_auth_update. }
    done.
  Qed.

  (** *Difficult exercise*: come up with a suitable invariant and prove the spec
  of [parallel_add_mul]. In this proof, you should use Boolean ghost variables,
  and the rules for those as given above. You are allowed to use any number of
  Boolean ghost variables. *)
  Definition parallel_add_mul_inv (r : loc) (γ1 γ2 : gname) : iProp Σ :=
    (∃ (b1 b2 : bool) (z : Z),
        r ↦ #z ∗
       ⌜match b1, b2 with
        | true,  true  => (z = 2 ∨ z = 4)%Z
        | true,  false => z = 2%Z
        | false, _     => z = 0%Z
        end⌝
       ∗ own γ1 (●E b1) ∗ own γ2 (●E b2)
    )%I.

  Lemma parallel_add_mul_spec :
    {{{ True }}} parallel_add_mul {{{ z, RET #z; ⌜ z = 2%Z ∨ z = 4%Z ⌝ }}}.
  Proof.
    iIntros (Φ) "_ Post".
    unfold parallel_add_mul. wp_alloc r as "Hr". wp_let.
    iMod (ghost_var_alloc false) as (γ1) "[Hγ1● Hγ1◯]".
    iMod (ghost_var_alloc false) as (γ2) "[Hγ2● Hγ2◯]".
    wp_apply (newlock_spec (parallel_add_mul_inv r γ1 γ2) with "[Hr Hγ1● Hγ2●]").
    { iExists false, false, 0%Z. iFrame. simpl. auto. }
    iIntros (l) "#Hl".
    wp_let.
    (* iMod (inv_alloc nroot _ (parallel_add_mul_inv r γ1 γ2) with "[Hγ1● Hγ2●]") as "#Hinvx". *)
    (* { iNext. iExists false, false. iFrame. } *)
    (* wp_bind (_ ||| _)%E. *)
    wp_smart_apply (wp_par (λ _, own γ1 (◯E true)) (λ _, own γ2 (◯E true))
                      with "[Hγ1◯] [Hγ2◯]").
    - wp_bind (acquire _).
      wp_apply (acquire_spec with "Hl"); iIntros "Hr".
      iDestruct "Hr" as (b1 b2 n) "(Hr & Hb & H1 & H2)".
      wp_seq. wp_load. wp_store.
      iDestruct (ghost_var_agree with "H1 Hγ1◯") as %->.
      iDestruct "Hb" as %->.
      iMod (ghost_var_update γ1 true with "H1 Hγ1◯") as "[H1x H1y]".
      wp_apply (release_spec with "[- H1y $Hl]").
      { iExists true, b2, 2%Z. iFrame. iPureIntro. destruct b2; lia. }
        by iIntros.
    - wp_bind (acquire _).
      wp_apply (acquire_spec with "Hl"); iIntros "Hr".
      iDestruct "Hr" as (b1 b2 n) "(Hr & Hb & H1 & H2)".
      wp_seq. wp_load. wp_store.
      iDestruct (ghost_var_agree with "H2 Hγ2◯") as %->.
      iMod (ghost_var_update γ2 true with "H2 Hγ2◯") as "[H1x H1y]".
      wp_apply (release_spec with "[- H1y $Hl]").
      { iExists b1, true, (n * 2)%Z. iFrame.
        destruct b1; iDestruct "Hb" as %->; iPureIntro; lia.
      }
        by iIntros.
    - iIntros (v1 v2) "[H1 H2]".
      iNext.
      wp_seq.
      wp_apply (acquire_spec _ with "Hl"). iIntros "Hr".
      iDestruct "Hr" as  (b1 b2 n) "(Hr & Hb & H1r & H2r)".
      wp_seq; wp_load.
      iApply "Post".
      iDestruct (ghost_var_agree γ1 with "H1r H1") as %->.
      iDestruct (ghost_var_agree γ2 with "H2r H2") as %->.
      auto.
  Qed.
End proof.


Require Import Coq.Program.Equality.
Require Import Coq.Program.Tactics.
Require Export MetaTheory.
Set Implicit Arguments.

(*****************************************************************************)
(* Evaluation context based reduction                                        *)
(*****************************************************************************)

Inductive Ctx : Set :=
  | c_hole
  | c_appfun (c: Ctx) (t: Tm)
  | c_apparg (t: Tm) (v: Value t) (c: Ctx)
  | c_prodl  (c: Ctx) (t: Tm)
  | c_prodr  (t: Tm) (val_t: Value t) (c: Ctx)
  | c_let    (p: Pat) (c: Ctx) (t: Tm).

Fixpoint ctx_app (c : Ctx) (t : Tm) {struct c} : Tm :=
  match c with
    | c_hole           => t
    | c_appfun c' t'   => app (ctx_app c' t) t'
    | c_apparg t' _ c' => app t' (ctx_app c' t)
    | c_prodl c' t'    => prod (ctx_app c' t) t'
    | c_prodr t' _ c'  => prod t' (ctx_app c' t)
    | c_let p c' t'    => lett p (ctx_app c' t) t'
  end.

Inductive red : Tm → Tm → Prop :=
  | E_AppAbs {T11 t12 t2} :
      Value t2 → red (app (abs T11 t12) t2) (substTm X0 t2 t12)
  | E_Let {t1 p t2 t3} :
      Value t1 →
      Match p t1 t2 t3 →
      red (lett p t1 t2) t3
  | E_Ctx {c t t'} :
      red t t' → red (ctx_app c t) (ctx_app c t').

(******************************************************************************)
(* Progress.                                                                  *)
(******************************************************************************)

Lemma local_progress (t : Tm) (U : Ty) (wt: Typing empty t U) :
  Value t ∨ ∃ c t0 t0', red t0 t0' ∧ t = ctx_app c t0.
Proof.
  depind wt; simpl; auto.
  - inversion H.
  - right.
    destruct IHwt1 as [v1|[c1 [s1 [s1' [r1 eq1]]]]]; subst.
    + destruct IHwt2 as [v2|[c2 [s2 [s2' [r2 eq2]]]]]; subst.
      * destruct (can_form_tarr v1 wt1) as [t12 eq_t2]; subst.
        exists c_hole, (app (abs T11 t12) t2), (substTm X0 t2 t12).
        split; auto; apply E_AppAbs; trivial.
      * exists (c_apparg _ v1 c2), s2, s2'; auto.
    + exists (c_appfun c1 t2), s1, s1'; split; trivial.
  - destruct IHwt1 as [v1|[c1 [s1 [s1' [r1 eq_t1]]]]]; subst.
    + destruct IHwt2 as [v2|[c2 [s2 [s2' [r2 eq_t2]]]]]; subst.
      * left; auto.
      * right; exists (c_prodr _ v1 c2), s2, s2'; auto.
    + right; exists (c_prodl c1 t2), s1, s1'; auto.
  - right.
    destruct IHwt1 as [v1|[c1 [s1 [s1' [r1 eq_t1]]]]]; subst.
    + destruct (matching_defined H v1 wt1 t2) as [t3 m].
      exists c_hole, (lett p t1 t2), t3; split; auto using E_Let.
    + exists (c_let p c1 t2), s1, s1'; auto.
Qed.

Lemma progress (t : Tm) (U : Ty) (wt: Typing empty t U) :
  Value t ∨ ∃ t', red t t'.
Proof.
  destruct (local_progress wt) as [val_t|(c & s & s' & r & eq)]; auto.
  right; exists (ctx_app c s'); subst; apply E_Ctx; auto.
Qed.

(******************************************************************************)
(* Preservation.                                                              *)
(******************************************************************************)

Lemma context_replacement {Γ c t t' T}
  (hyp: ∀ T', Typing Γ t T' → Typing Γ t' T') :
  Typing Γ (ctx_app c t) T → Typing Γ (ctx_app c t') T.
Proof.
  intro wt; depind wt; induction c; simpl in *; subst;
    try discriminate; try (inversion x; subst); eauto using Typing.
Qed.

Lemma local_preservation_app {Γ} t12 t2 T11 U :
  Typing Γ (app (abs T11 t12) t2) U → Typing Γ (substTm X0 t2 t12) U.
Proof.
  intro wt; depind wt.
  - inversion wt1; eauto using subst_evar_typing with infra.
Qed.

Lemma local_preservation_lett' {Γ} p t1 t2 U t3 :
  Typing Γ (lett p t1 t2) U → Match p t1 t2 t3 →
  Typing Γ t3 U.
Proof.
  intro wt; dependent destruction wt;
    eauto using local_preservation_lett.
Qed.

Lemma preservation {t t'} (r: red t t') :
  ∀ {Γ T}, Typing Γ t T → Typing Γ t' T.
Proof.
  induction r.
  - eauto using local_preservation_app.
  - eauto using local_preservation_lett'.
  - eauto using context_replacement.
Qed.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Product of Data Structures                                              *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibLogic LibReflect.
Generalizable Variables A B.

(* ********************************************************************** *)
(** * Inhabited *)

Global Instance prod_inhab : forall `{Inhab A, Inhab B}, Inhab (A * B).
Proof using. intros. apply (prove_Inhab (arbitrary, arbitrary)). Qed.

(* ********************************************************************** *)
(** * Comparable *)

Definition prod_compare {A B : Type} `{Comparable A} `{Comparable B} (x y : A * B) :=
  let (x1, x2) := x in let (y1, y2) := y in
  decide (x1 = y1 /\ x2 = y2).

Global Instance prod_comparable : forall A B : Type,
  Comparable A -> Comparable B -> Comparable (A * B).
Proof using.
  introv CA CB. applys comparable_beq (@prod_compare A B _ _). intros x y.
  destruct x; destruct y; simpl; rew_refl; iff H; inverts~ H;
   tryfalse; auto; try congruence.
Qed.

(* ********************************************************************** *)
(** * Structure *)

(** Decomposition as projection *)

Lemma tuple2_from_proj : forall A1 A2 (x:A1*A2),
  (fst x, snd x) = x.
Proof using. intros. destruct~ x. Qed.

(** Structural equality *)

Section Properties.
Variables (A1 A2 A3 A4 : Type).
Lemma eq_prod2 : forall (x1 y1:A1) (x2 y2:A2),
  x1 = y1 -> x2 = y2 -> (x1, x2) = (y1, y2).
Proof using. intros. subst~. Qed.

Lemma eq_prod3 : forall (x1 y1:A1) (x2 y2:A2) (x3 y3:A3),
  x1 = y1 -> x2 = y2 -> x3 = y3 -> (x1, x2, x3) = (y1, y2, y3).
Proof using. intros. subst~. Qed.

Lemma eq_prod4 : forall (x1 y1:A1) (x2 y2:A2) (x3 y3:A3) (x4 y4:A4),
  x1 = y1 -> x2 = y2 -> x3 = y3 -> x4 = y4 -> (x1, x2, x3, x4) = (y1, y2, y3, y4).
Proof using. intros. subst~. Qed.

End Properties.

Hint Immediate eq_prod2 eq_prod3 eq_prod4.

(* ********************************************************************** *)
(** * Operations *)

(** [fst] and [snd] are defined in the standard library *)

Implicit Arguments fst [[A] [B]].
Implicit Arguments snd [[A] [B]].

(* ---------------------------------------------------------------------- *)
(** ** Notation for projections *)

(** N-ary projections are defined as notations and not as
    definitions, which has appeared to be more flexible with
    respect to type inference.
    TODO: investigate the possibility of using definitions. *)

Notation "'proj11' P" := P (at level 69, only parsing).

Notation "'proj21' P" := (proj1 P) (at level 69, only parsing).
Notation "'proj22' P" := (proj2 P) (at level 69, only parsing).

Notation "'proj31' P" := (proj1 P) (at level 69).
Notation "'proj32' P" := (proj1 (proj2 P)) (at level 69).
Notation "'proj33' P" := (proj2 (proj2 P)) (at level 69).

Notation "'proj41' P" := (proj1 P) (at level 69).
Notation "'proj42' P" := (proj1 (proj2 P)) (at level 69).
Notation "'proj43' P" := (proj1 (proj2 (proj2 P))) (at level 69).
Notation "'proj44' P" := (proj2 (proj2 (proj2 P))) (at level 69).

Notation "'proj51' P" := (proj1 P) (at level 69).
Notation "'proj52' P" := (proj1 (proj2 P)) (at level 69).
Notation "'proj53' P" := (proj1 (proj2 (proj2 P))) (at level 69).
Notation "'proj54' P" := (proj1 (proj2 (proj2 (proj2 P)))) (at level 69).
Notation "'proj55' P" := (proj2 (proj2 (proj2 (proj2 P)))) (at level 69).

(*-----------------------------------------------------*)
(** ** Currying *)

Section Currying.
Variables (A1 A2 A3 A4 A5 B : Type).
Definition curry1 f : A1 -> B :=
  f.
Definition curry2 f : A1 -> A2 -> B :=
  fun x1 x2 => f (x1,x2).
Definition curry3 f : A1 -> A2 -> A3 -> B :=
  fun x1 x2 x3 => f (x1,x2,x3).
Definition curry4 f : A1 -> A2 -> A3 -> A4 -> B :=
  fun x1 x2 x3 x4 => f (x1,x2,x3,x4).
Definition curry5 f : A1 -> A2 -> A3 -> A4 -> A5 -> B :=
  fun x1 x2 x3 x4 x5 => f (x1,x2,x3,x4,x5).
End Currying.

(*-----------------------------------------------------*)
(** ** Uncurrying *)

Section Uncurrying.
Variables (A1 A2 A3 A4 A5 B : Type).
Definition uncurry1 f : A1 -> B :=
  f.
Definition uncurry2 f : A1*A2 -> B :=
  fun p => match p with (x1,x2) =>
  f x1 x2 end.
Definition uncurry3 f : A1*A2*A3 -> B :=
  fun p => match p with (x1,x2,x3) =>
  f x1 x2 x3 end.
Definition uncurry4 f : A1*A2*A3*A4 -> B :=
  fun p => match p with (x1,x2,x3,x4) =>
  f x1 x2 x3 x4 end.
Definition uncurry5 f : A1*A2*A3*A4*A5 -> B :=
  fun p => match p with (x1,x2,x3,x4,x5) =>
  f x1 x2 x3 x4 x5 end.
End Uncurrying.

(* ---------------------------------------------------------------------- *)
(** ** Uncurrying for relations *)

(** [uncurrypN] turns a function of type [A1 -> A1 -> .. -> AN -> AN -> B]
    into a function of type [(A1*..*AN) -> (A1*..*AN) -> B]. *)

Section Uncurryp.
Variables (A1 A2 A3 A4 B : Type).
Definition uncurryp1 f : A1 -> A1 -> B :=
  f.
Definition uncurryp2 f : A1*A2 -> A1*A2 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2),(y1,y2) =>
  f x1 y1 x2 y2 end.
Definition uncurryp3 f : A1*A2*A3 -> A1*A2*A3 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3),(y1,y2,y3) =>
  f x1 x2 x3 y1 y2 y3 end.
Definition uncurryp4 f : A1*A2*A3*A4 -> A1*A2*A3*A4 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4),(y1,y2,y3,y4) =>
  f x1 x2 x3 x4 y1 y2 y3 y4 end.
End Uncurryp.

(** Unfolding *)

Tactic Notation "unfold_uncurryp" :=
  unfold uncurryp1, uncurryp2, uncurryp3, uncurryp4.

Tactic Notation "unfolds_uncurryp" :=
  unfold uncurryp1, uncurryp2, uncurryp3, uncurryp4 in *.

(* ---------------------------------------------------------------------- *)
(** ** Inverse projections for relations *)

(* TODO: rename to [unprojpNK] and define also [unprojNK] *)

(** [unprojNK] turns a function of type [AK -> AK -> B]
    into a function of type [(A1*..*AN) -> (A1*..*AN) -> B]. *)

Section Unproj.
Variables (A1 A2 A3 A4 B : Type).
Definition unproj21 f : A1*A2 -> A1*A2 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2),(y1,y2) =>
  f x1 y1 end.
Definition unproj22 f : A1*A2 -> A1*A2 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2),(y1,y2) =>
  f x2 y2 end.
Definition unproj31 f : A1*A2*A3 -> A1*A2*A3 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3),(y1,y2,y3) =>
  f x1 y1 end.
Definition unproj32 f : A1*A2*A3 -> A1*A2*A3 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3),(y1,y2,y3) =>
  f x2 y2 end.
Definition unproj33 f : A1*A2*A3 -> A1*A2*A3 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3),(y1,y2,y3) =>
  f x3 y3 end.
Definition unproj41 f : A1*A2*A3*A4 -> A1*A2*A3*A4 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4),(y1,y2,y3,y4) =>
  f x1 y1 end.
Definition unproj42 f : A1*A2*A3*A4 -> A1*A2*A3*A4 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4),(y1,y2,y3,y4) =>
  f x2 y2 end.
Definition unproj43 f : A1*A2*A3*A4 -> A1*A2*A3*A4 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4),(y1,y2,y3,y4) =>
  f x3 y3 end.
Definition unproj44 f : A1*A2*A3*A4 -> A1*A2*A3*A4 -> B :=
  fun p1 p2 => match p1,p2 with (x1,x2,x3,x4),(y1,y2,y3,y4) =>
  f x4 y4 end.
End Unproj.

Implicit Arguments unproj21 [ A1 B ].
Implicit Arguments unproj22 [ A2 B ].
Implicit Arguments unproj31 [ A1 B ].
Implicit Arguments unproj32 [ A2 B ].
Implicit Arguments unproj33 [ A3 B ].
Implicit Arguments unproj41 [ A1 B ].
Implicit Arguments unproj42 [ A2 B ].
Implicit Arguments unproj43 [ A3 B ].
Implicit Arguments unproj44 [ A4 B ].

(** Unfolding *)

Tactic Notation "unfold_unproj" :=
  unfold unproj21, unproj22, unproj31, unproj32, unproj33,
         unproj41, unproj42, unproj43, unproj44.

Tactic Notation "unfolds_unproj" :=
  unfold unproj21, unproj22, unproj31, unproj32, unproj33,
         unproj41, unproj42, unproj43, unproj44 in *.


(* begin hide *)

Require Import
  Coq.Structures.OrderedTypeEx
  Coq.FSets.FSetAVL
  Coq.Arith.Compare_dec.

Require Import Aniceto.Set.
Require Import Aniceto.Map.

Require Import
  Brenner.Semantics TaskMap PhaserMap Vars Syntax.

Require Import Aniceto.Graphs.Graph.
Require Aniceto.Graphs.Bipartite.Bipartite.
Require Aniceto.Graphs.Bipartite.Cycle.

Set Implicit Arguments.

Module C := Graphs.Bipartite.Cycle.
(* end hide *)

(** * Resource dependency state *)

(** We define an event as a pair of phaser ids and a natural (the phase). *)

Module EVT := PairOrderedType PHID Nat_as_OT.

(* begin hide *)
Module Set_EVT := FSetAVL.Make EVT.
Module Set_EVT_Extra := SetUtil Set_EVT.
Module Map_EVT := FMapAVL.Make EVT.
Module Map_EVT_Extra := MapUtil Map_EVT.
Definition set_event := Set_EVT.t.
(* end hide *)
Definition event := EVT.t.

(** Function [get_phaser] obtains the phaser id in the event. *)

Definition get_phaser (e:event) : phid := fst e.

(** Function [get_phase] obtains the phase number of the event. *)

Definition get_phase (e:event) : nat := snd e.

(** Phases from the same phaser are in a precedes relation. *)

Definition prec (e1:event) (e2:event) :=
  get_phaser e1 = get_phaser e2 /\ get_phase e1 < get_phase e2.

(* begin hide *)

Section StateProps.

Variable s:state.

(* end hide *)

(**

Let [s] be a [state].
We say that a task [t] is waiting for an event [e]
when task [t] is executing an instruction [Await] and
the target phaser is defined in the phaser map. *)

Definition WaitOn (t:tid) (e:event) :=
  exists prg,
  Map_TID.MapsTo t (pcons (await (get_phaser e) (get_phase e)) prg) (get_tasks s) /\
  Map_PHID.In (get_phaser e) (get_phasers s).

(** A task [t] is registered in an event [e] if [t] is registered
    in phaser [get_phaser e] and in phase [get_phase r]; task [t] must
    defined in the taskmap. *)

Definition Registered (t:tid) (e:event) :=
  exists ph,
  Map_PHID.MapsTo (get_phaser e) ph (get_phasers s) /\
  Map_TID.MapsTo t (get_phase e) ph /\ Map_TID.In t (get_tasks s).

Lemma registered_def:
  forall ph e t,
  Map_PHID.MapsTo (get_phaser e) ph (get_phasers s) ->
  Map_TID.MapsTo t (get_phase e) ph ->
  Map_TID.In t (get_tasks s) ->
  Registered t e.
Proof.
  intros.
  unfold Registered.
  exists ph.
  intuition.
Qed.

Lemma registered_in_tasks:
  forall t e,
  Registered t e ->
  Map_TID.In t (get_tasks s).
Proof.
  unfold Registered.
  intros.
  destruct H as (?,(?,(?,?))).
  assumption.
Qed.

(** an event [e] impedes a task [t] this task is registered in a
   event [e'] that precedes [e]; the impeding event must be the target of
   a blocked task. *)

Definition ImpededBy(e:event) (t:tid) :=
  (exists t', WaitOn t' e) /\
  (exists e', Registered t e' /\ prec e' e).

Lemma impeded_by_def:
  forall e t t' e',
  WaitOn t' e ->
  Registered t e' ->
  prec e' e ->
  ImpededBy e t.
Proof.
  unfold ImpededBy.
  intros.
  split.
  - exists t'.
    assumption.
  - exists e'.
    intuition.
Qed.

Lemma impeded_by_in_tasks:
  forall t e,
  ImpededBy e t ->
  Map_TID.In t (get_tasks s).
Proof.
  intros.
  destruct H as (_,(?,(H,_))).
  eauto using registered_in_tasks.
Qed.

End StateProps.

(** We now characterize a deadlocked state.
    Let [AllTasksWaitFor] be a state such that all tasks in the state
    are waiting for an event. *)

Definition AllTasksWaitOn s :=
  forall t, (Map_TID.In t (get_tasks s) -> exists e, WaitOn s t e).

(** Let [AllBlockedRegistered] be a state such that any task waiting for
    an event, that event is also impeding another task in the state. *)

Definition AllImpededBy s :=
  forall t e, WaitOn s t e -> exists t', ImpededBy s e t'.

(** A totally deadlocked state is such that all tasks are waiting for
    events that are impeding a tasks in the task map. *)

Definition TotallyDeadlocked (s:state) :=
  AllTasksWaitOn s /\ AllImpededBy s /\
  exists t, Map_TID.In t (get_tasks s). (* nonempty *)

(* TODO: Now would be a nice time to show that a totally deadlocked state
   does not reduce. For this we need to have a decidable reduction. *)

(** A [Deadlocked] state is such that we can take a partition of the task
    map [tm] and [tm'] such that the state [(get_phasers s, tm)] is
    totally deadlock. *)

Definition Deadlocked (s:state) :=
  exists tm tm',
  Map_TID_Props.Partition (get_tasks s) tm tm' /\
  TotallyDeadlocked ((get_phasers s), tm).

(** A GRG is a bipartite graph that is defined
   from relations [WaitOn] and [ImpededBy]. *)

Notation TEdge s := (Bipartite.AA (WaitOn s) (ImpededBy s)).
Notation REdge s := (Bipartite.BB (WaitOn s) (ImpededBy s)).
Notation TWalk s := (Walk (TEdge s)).
Notation RWalk s := (Walk (REdge s)).
Notation TCycle s := (Cycle (TEdge s)).
Notation RCycle s := (Cycle (REdge s)).
Notation t_edge := (tid * tid) % type.
Notation t_walk := (list t_edge).

(** In WFG an arc from task [t1] to [t2] is read as [t1] waits for [t2].
    In Brenner this means that there exists an event [e] where task
    [t1] is blocked and task [t2] has not arrived at event [e].*)

Lemma tedge_spec:
  forall s (t1 t2:tid),
  TEdge s (t1, t2) <->
  exists e,
  WaitOn s t1 e /\ ImpededBy s e t2.
Proof.
  split.
  + intros.
    simpl in H.
    inversion H.
    subst.
    exists b.
    intuition.
  + intros.
    destruct H as (e, (H1, H2)).
    simpl.
    eauto using Bipartite.aa.
Qed.

(** In an SG an arc from [e1] to [e2] can be read
    as event [e1] happens before event [e2].
    In Brenner, this means that there is a task [t]
    blocked in [e2] and impedes [e1]. Recall the definition
    of [ImpededBy] that states that [t] is registered in
    an event [e'] that precedes [e]; and that event
    [e] is obtained because there exists some task blocked
    in [e] (again by definition). *)

Lemma redge_spec:
  forall s (e1 e2:event),
  REdge s (e1, e2) <->
  exists t,
  ImpededBy s e1 t /\ WaitOn s t e2.
Proof.
  split.
  - intros.
    inversion H.
    subst.
    exists a.
    simpl in *.
    intuition.
  - intros [t (Hi, Hw)].
    simpl.
    eauto using Bipartite.bb.
Qed.

Section Graphs.

Variable s:state.

(** Since the graph is bipartite, then if we have a cycle in the WFG, then
    there exists a cycle in the SG. *)

Theorem wfg_to_sg:
  forall s c,
  TCycle s c ->
  exists c', RCycle s c'.
Proof.
  intros.
  eauto using Cycle.cycle_a_to_b.
Qed.

(** Vice-versa also holds. *)

Theorem sg_to_wfg:
  forall c,
  RCycle s c ->
  exists c', TCycle s c'.
Proof.
  intros.
  eauto using Cycle.cycle_b_to_a.
Qed.

End Graphs.

Section Basic.
  Variable s:state.

(** In our language tasks can only await a single phaser, so
    it is easy to see that the [WaitOn] predicate is actually a function
    from task ids to events. *)

Lemma wait_on_fun:
  forall t e e',
  WaitOn s t e ->
  WaitOn s t e' ->
  e = e'.
Proof.
  intros.
  unfold WaitOn in *.
  destruct H as (p1, (H1, H2)).
  destruct H0 as (p2, (H3, H4)).
  (* MapsTo is functional, so p1 = p2 *)
  assert (Heq:= @Map_TID_Facts.MapsTo_fun _ _ _ _ _
          H1 H3).
  inversion Heq.
  destruct e as (p,n).
  destruct e' as (p', n').
  simpl in *.
  auto.
Qed.

(** We show that any task id in the [WaitOn] is in the task map of [s]. *)

Lemma wait_on_in_tasks:
  forall t e,
  WaitOn s t e ->
  Map_TID.In t (get_tasks s).
Proof.
  intros.
  unfold WaitOn in H.
  destruct H as (p, (H1, H2)).
  apply Map_TID_Extra.mapsto_to_in in H1.
  assumption.
Qed.

Lemma impeded_by_in_phasermap:
  forall e t,
  ImpededBy s e t ->
  Map_PHID.In (elt:=Phaser.phaser) (get_phaser e) (get_phasers s).
Proof.
  intros.
  destruct H as ((t',H),_).
  unfold WaitOn in H.
  destruct H as (_, (_, H)).
  assumption.
Qed.

End Basic.


Load "Example11".

(********************if b then x1 else y1 = if b then x2 else y2 -> if b then t[x1] else t'[y1] = if b then t[x2] else t'[y2]************************)

Theorem Ex12bol_bol: forall (n1 n2 n3 n4 n5 n6 : nat)(b b1 b2:Bool),   (if_then_else_B b (Bvar n1) (Bvar n2)) ## (if_then_else_B b (Bvar n3) (Bvar n4)) ->  (if_then_else_B b [n5:= (Bvar n1)]b1 [n6:= (Bvar n2)]b2)  ##  (if_then_else_B b [n5:= (Bvar n3)]b1  [n6:= (Bvar n4)] b2).
Proof.
intros.
assert (H1:   (if_then_else_B b [n5:= if_then_else_B b (Bvar n1) (Bvar n2)] b1 [n6 := if_then_else_B b (Bvar n1) (Bvar n2)] b2) ## (if_then_else_B b [n5:= (Bvar n1)]b1 [n6:= (Bvar n2)]b2)).
apply Ex9bol_bol1 with  (b1:=b1)(b2:=b2).
rewrite <- H1.
rewrite H.
apply Ex9bol_bol1 with (b1:= b1)(b2:=b2).
Qed.

Theorem Ex12bol_msg: forall (n1 n2 n3 n4 n5 n6 : nat)(b :Bool) (m1 m2 : message),   (if_then_else_B b (Bvar n1) (Bvar n2)) ## (if_then_else_B b (Bvar n3) (Bvar n4)) ->  (if_then_else_M b ((n5:= (Bvar n1))m1) ((n6:= (Bvar n2)) m2))  #  (if_then_else_M b ((n5:= (Bvar n3))m1)  ((n6:= (Bvar n4)) m2)).
Proof.
intros.
pose proof Ex9bol_msg1.
assert (H1:   (if_then_else_M b ((n5:= if_then_else_B b (Bvar n1) (Bvar n2)) m1) ((n6 := if_then_else_B b (Bvar n1) (Bvar n2)) m2)) # (if_then_else_M b ((n5:= (Bvar n1))m1) ((n6:= (Bvar n2))m2))).
apply Ex9bol_msg1 with  (m1:=m1)(m2:=m2).
rewrite <- H1.
rewrite H.
apply Ex9bol_msg1.
Qed.

Theorem Ex12msg_msg: forall (n1 n2 n3 n4 n5 n6 : nat)(b:Bool)(m1 m2: message),  (if_then_else_M b (Mvar n1) (Mvar n2)) # (if_then_else_M b (Mvar n3) (Mvar n4)) ->  ( if_then_else_M b (submsg_msg n5 (Mvar n1) m1)  (submsg_msg n6 (Mvar n2) m2))  # (if_then_else_M b (submsg_msg n5 (Mvar n3) m1)  (submsg_msg n6 (Mvar n4) m2)).
Proof.
intros.
assert (H1:  (if_then_else_M b (submsg_msg n5  (if_then_else_M b (Mvar n1) (Mvar n2)) m1) (submsg_msg n6 (if_then_else_M b (Mvar n1) (Mvar n2)) m2)) # ( if_then_else_M b (submsg_msg n5  (Mvar n1)  m1) (submsg_msg n6 (Mvar n2) m2))).
apply Ex9msg_msg1 .
rewrite <-H1.
rewrite H.
apply Ex9msg_msg1.
Qed.

Theorem Ex12msg_bol: forall (n1 n2 n3 n4 n5 n6 : nat)(b:Bool)(b1 b2: Bool),  (if_then_else_M b (Mvar n1) (Mvar n2)) # (if_then_else_M b (Mvar n3) (Mvar n4)) ->  ( if_then_else_B b  ([[ n5 := (Mvar n1)]] b1)  ( [[ n6 := (Mvar n2)]] b2)) ## (if_then_else_B b ([[ n5 := (Mvar n3)]] b1)  ([[ n6 := (Mvar n4)]] b2)).
Proof.
intros.
assert (H1:  (if_then_else_B b ( [[ n5 := (if_then_else_M b (Mvar n1) (Mvar n2) )]] b1) ([[ n6 := (if_then_else_M b (Mvar n1) (Mvar n2))]] b2)) ## ( if_then_else_B b ( [[ n5 :=  (Mvar n1)]]  b1) ( [[ n6 :=  (Mvar n2)]] b2))).
apply Ex9msg_bol1 .
rewrite <-H1.
rewrite H.
apply Ex9msg_bol1.
Qed.