From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Loc.

Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import MemoryFacts.

Require Import Cover.

Set Implicit Arguments.

Module MemoryReorder.
  Lemma add_add
        mem0 loc1 from1 to1 msg1
        mem1 loc2 from2 to2 msg2
        mem2
        (ADD1: Memory.add mem0 loc1 from1 to1 msg1 mem1)
        (ADD2: Memory.add mem1 loc2 from2 to2 msg2 mem2):
    exists mem1',
      <<ADD1: Memory.add mem0 loc2 from2 to2 msg2 mem1'>> /\
      <<ADD2: Memory.add mem1' loc1 from1 to1 msg1 mem2>> /\
      <<LOCTS: (loc1, to1) <> (loc2, to2)>>.
  Proof.
    exploit (@Memory.add_exists mem0 loc2 from2 to2).
    { i. inv ADD2. inv ADD. eapply DISJOINT.
      etrans; [eapply Memory.add_o; eauto|]. condtac; ss; eauto.
      des. subst. exploit Memory.add_get0; eauto. i. des. congr.
    }
    { inv ADD2. inv ADD. auto. }
    { inv ADD2. inv ADD. eauto. }
    i. des.
    exploit (@Memory.add_exists mem3 loc1 from1 to1).
    { i. revert GET2. erewrite Memory.add_o; eauto. condtac; ss.
      - des. subst. i. inv GET2.
        exploit Memory.add_get0; try exact ADD2; eauto.
        inv ADD2. inv ADD. symmetry. eapply DISJOINT.
        etrans; [eapply Memory.add_o; eauto|]. condtac; ss. des; congr.
      - guardH o. i. inv ADD1. inv ADD. eapply DISJOINT; eauto.
    }
    { inv ADD1. inv ADD. auto. }
    { inv ADD1. inv ADD. eauto. }
    i. des.
    esplits; eauto; cycle 1.
    { ii. inv H.
      exploit Memory.add_get0; try exact ADD2; eauto.
      erewrite Memory.add_o; eauto. condtac; s; i; des; congr.
    }
    cut (mem4 = mem2); [by i; subst; eauto|].
    apply Memory.ext. i.
    setoid_rewrite Memory.add_o; cycle 1; eauto.
    erewrite (@Memory.add_o mem3); eauto. erewrite (@Memory.add_o mem1); eauto.
    repeat (condtac; ss). des. subst.
    exploit Memory.add_get0; try exact ADD1; eauto. i. des.
    exploit Memory.add_get0; try exact ADD2; eauto. i. des.
    congr.
  Qed.

  Lemma add_split_same
        mem0 loc ts1 ts2 ts3 msg2 msg3 mem1 mem2
        (ADD1: Memory.add mem0 loc ts1 ts3 msg3 mem1)
        (SPLIT2: Memory.split mem1 loc ts1 ts2 ts3 msg2 msg3 mem2):
    exists mem1',
      <<ADD1: Memory.add mem0 loc ts1 ts2 msg2 mem1'>> /\
      <<ADD2: Memory.add mem1' loc ts2 ts3 msg3 mem2>>.
  Proof.
    exploit (@Memory.add_exists mem0 loc ts1 ts2 msg2); eauto.
    { i. inv ADD1. inv ADD. hexploit DISJOINT; eauto. i.
      eapply Interval.le_disjoint; eauto. econs; [refl|].
      inv SPLIT2. inv SPLIT. left. auto.
    }
    { inv SPLIT2. inv SPLIT. auto. }
    { inv SPLIT2. inv SPLIT. auto. }
    i. des.
    exploit (@Memory.add_exists mem3 loc ts2 ts3 msg3); eauto.
    { i. revert GET2. erewrite Memory.add_o; eauto. condtac; ss.
      - des. subst. i. inv GET2.
        symmetry. apply Interval.disjoint_imm.
      - i. inv ADD1. inv ADD. hexploit DISJOINT; eauto. i.
        eapply Interval.le_disjoint; eauto. econs; [|refl].
        inv SPLIT2. inv SPLIT. left. auto.
    }
    { inv SPLIT2. inv SPLIT. auto. }
    { inv ADD1. inv ADD. auto. }
    i. des.
    cut (mem4 = mem2); [by i; subst; eauto|].
    apply Memory.ext. i.
    erewrite Memory.add_o; eauto. erewrite Memory.add_o; eauto.
    erewrite (@Memory.split_o mem2); eauto. erewrite (@Memory.add_o mem1); eauto.
    repeat (condtac; ss). des. repeat subst.
    inv SPLIT2. inv SPLIT. exfalso. eapply Time.lt_strorder. eauto.
  Qed.

  Lemma add_split
        mem0 loc1 from1 to1 msg1
        mem1 loc2 ts21 ts22 ts23 msg22 msg23
        mem2
        (ADD1: Memory.add mem0 loc1 from1 to1 msg1 mem1)
        (SPLIT2: Memory.split mem1 loc2 ts21 ts22 ts23 msg22 msg23 mem2):
    (loc1 = loc2 /\ from1 = ts21 /\ to1 = ts23 /\ msg1 = msg23 /\
     exists mem1',
       <<ADD1: Memory.add mem0 loc2 ts21 ts22 msg22 mem1'>> /\
       <<ADD2: Memory.add mem1' loc2 ts22 ts23 msg23 mem2>>) \/
    (<<LOCTS1: (loc1, to1) <> (loc2, ts23)>> /\
     exists mem1',
       <<SPLIT1: Memory.split mem0 loc2 ts21 ts22 ts23 msg22 msg23 mem1'>> /\
       <<ADD2: Memory.add mem1' loc1 from1 to1 msg1 mem2>>).
  Proof.
    exploit Memory.split_get0; eauto. i. des.
    revert GET0. erewrite Memory.add_o; eauto. condtac; ss.
    { des. i. inv GET0. left. splits; eauto.
      eapply add_split_same; eauto.
    }
    guardH o. i. right. splits.
    { ii. inv H. unguardH o. des; congr. }
    exploit (@Memory.split_exists mem0 loc2 ts21 ts22 ts23);
      try by inv SPLIT2; inv SPLIT; eauto.
    i. des.
    exploit (@Memory.add_exists mem3 loc1 from1 to1);
      try by inv ADD1; inv ADD; eauto.
    { i. revert GET3. erewrite Memory.split_o; eauto. repeat condtac; ss.
      - des. subst. i. inv GET3.
        inv ADD1. inv ADD. hexploit DISJOINT; eauto. i. symmetry in H.
        symmetry. eapply Interval.le_disjoint; eauto. econs; [refl|].
        inv SPLIT2. inv SPLIT. left. auto.
      - guardH o0. i. des. inv GET3.
        inv ADD1. inv ADD. hexploit DISJOINT; eauto. i. symmetry in H.
        symmetry. eapply Interval.le_disjoint; eauto. econs; [|refl].
        inv SPLIT2. inv SPLIT. left. auto.
      - guardH o0. i. inv ADD1. inv ADD. eapply DISJOINT; eauto.
    }
    i. des.
    esplits; eauto.
    cut (mem4 = mem2); [by i; subst; eauto|].
    apply Memory.ext. i.
    erewrite Memory.add_o; eauto. erewrite Memory.split_o; eauto.
    setoid_rewrite Memory.split_o; cycle 1; eauto.
    erewrite (@Memory.add_o mem1); eauto.
    repeat (condtac; ss).
    - des. repeat subst.
      exploit Memory.add_get0; try exact ADD1; eauto. i. des.
      exploit Memory.split_get0; try exact SPLIT2; eauto. i. des.
      congr.
    - guardH o0. des. repeat subst. unguardH o. des; congr.
  Qed.

  Lemma add_lower
        mem0 loc1 from1 to1 msg1
        mem1 loc2 from2 to2 msg2 msg2'
        mem2
        (ADD1: Memory.add mem0 loc1 from1 to1 msg1 mem1)
        (LOWER2: Memory.lower mem1 loc2 from2 to2 msg2 msg2' mem2):
    (loc1 = loc2 /\ from1 = from2 /\ to1 = to2 /\ msg1 = msg2 /\
     Memory.add mem0 loc1 from1 to1 msg2' mem2) \/
    (<<LOCTS1: (loc1, to1) <> (loc2, to2)>> /\
     exists mem1',
       <<LOWER1: Memory.lower mem0 loc2 from2 to2 msg2 msg2' mem1'>> /\
       <<ADD2: Memory.add mem1' loc1 from1 to1 msg1 mem2>>).
  Proof.
    exploit Memory.lower_get0; eauto.
    erewrite Memory.add_o; eauto. condtac; ss.
    - des. subst. i. des. inv GET. left. splits; eauto.
      inv ADD1. inv ADD. inv LOWER2. inv LOWER.
      rewrite LocFun.add_add_eq. econs; auto.
      unfold Cell.add in *.
      destruct r, r0. ss. subst.
      unfold LocFun.add. condtac; [|congr]. s.
      rewrite DOMap.add_add_eq. econs; auto.
    - guardH o. i. des. right. splits.
      { ii. inv H. unguardH o. des; congr. }
      exploit (@Memory.lower_exists mem0 loc2 from2 to2);
        try by inv LOWER2; inv LOWER; eauto.
      i. des.
      exploit (@Memory.add_exists mem3 loc1 from1 to1).
      { i. revert GET2. erewrite Memory.lower_o; eauto. condtac; ss.
        - des. subst. i. inv GET2.
          exploit Memory.lower_get0; eauto. i. des.
          inv ADD1. inv ADD. eapply DISJOINT. eauto.
        - guardH o0. i. inv ADD1. inv ADD. eapply DISJOINT; eauto.
      }
      { inv ADD1. inv ADD. auto. }
      { inv ADD1. inv ADD. eauto. }
      i. des.
      esplits; eauto.
      cut (mem4 = mem2); [by i; subst; eauto|].
      apply Memory.ext. i.
      erewrite Memory.add_o; eauto. erewrite Memory.lower_o; eauto.
      setoid_rewrite Memory.lower_o; cycle 1; eauto.
      erewrite (@Memory.add_o mem1); eauto.
      repeat (condtac; ss). des. repeat subst.
      unguardH o. des; congr.
  Qed.

  Lemma add_remove
        mem0 loc1 from1 to1 msg1
        mem1 loc2 from2 to2 msg2
        mem2
        (LOCTS1: (loc1, to1) <> (loc2, to2))
        (ADD1: Memory.add mem0 loc1 from1 to1 msg1 mem1)
        (REMOVE2: Memory.remove mem1 loc2 from2 to2 msg2 mem2):
    exists mem1',
      <<REMOVE1: Memory.remove mem0 loc2 from2 to2 msg2 mem1'>> /\
      <<ADD2: Memory.add mem1' loc1 from1 to1 msg1 mem2>>.
  Proof.
    exploit (@Memory.remove_exists mem0 loc2 from2 to2).
    { hexploit Memory.remove_get0; eauto.
      erewrite Memory.add_o; eauto. condtac; ss; i; des; subst; eauto. congr.
    }
    i. des.
    exploit (@Memory.add_exists mem3 loc1 from1 to1);
      try by inv ADD1; inv ADD; eauto.
    { i. revert GET2. erewrite Memory.remove_o; eauto. condtac; ss.
      inv ADD1. inv ADD. eauto.
    }
    i. des.
    cut (mem4 = mem2); [by i; subst; eauto|].
    apply Memory.ext. i.
    erewrite Memory.add_o; eauto. erewrite Memory.remove_o; eauto.
    erewrite (@Memory.remove_o mem2); eauto. erewrite (@Memory.add_o mem1); eauto.
    repeat (condtac; ss). des. repeat subst. congr.
  Qed.

  Lemma add_remove_same
        mem0 loc1 from1 to1 msg1
        mem1 from2 msg2
        mem2
        (ADD1: Memory.add mem0 loc1 from1 to1 msg1 mem1)
        (REMOVE2: Memory.remove mem1 loc1 from2 to1 msg2 mem2):
    from1 = from2 /\ msg1 = msg2 /\ mem0 = mem2.
  Proof.
    exploit Memory.add_get0; eauto. i. des.
    exploit Memory.remove_get0; eauto. i. des.
    rewrite GET0 in *. inv GET1. splits; auto.
    apply Memory.ext. i.
    erewrite (@Memory.remove_o mem2); eauto. condtac; ss.
    - des. subst. ss.
    - erewrite (@Memory.add_o mem1); eauto. condtac; ss.
  Qed.

  Lemma split_add
        mem0 loc1 ts11 ts12 ts13 msg12 msg13
        mem1 loc2 from2 to2 msg2
        mem2
        (SPLIT1: Memory.split mem0 loc1 ts11 ts12 ts13 msg12 msg13 mem1)
        (ADD2: Memory.add mem1 loc2 from2 to2 msg2 mem2):
    <<LOCTS1: (loc1, ts12) <> (loc2, to2)>> /\
    <<LOCTS2: (loc1, ts13) <> (loc2, to2)>> /\
    exists mem1',
      <<ADD1: Memory.add mem0 loc2 from2 to2 msg2 mem1'>> /\
      <<SPLIT2: Memory.split mem1' loc1 ts11 ts12 ts13 msg12 msg13 mem2>>.
  Proof.
    exploit (@Memory.add_exists mem0 loc2 from2 to2);
      try by inv ADD2; inv ADD; eauto.
    { apply covered_disjoint_get_disjoint. i. rewrite <- split_covered in H; eauto.
      eapply get_disjoint_covered_disjoint; eauto. inv ADD2. inv ADD. auto.
    }
    i. des.
    exploit (@Memory.split_exists mem3 loc1 ts11 ts12 ts13);
      try by inv SPLIT1; inv SPLIT; eauto.
    { erewrite Memory.add_o; eauto. condtac; ss.
      - des. subst.
        hexploit Memory.add_get0; try exact ADD2; eauto. i. des.
        revert GET. erewrite Memory.split_o; eauto. repeat condtac; ss.
      - guardH o. hexploit Memory.split_get0; eauto. i. des. eauto.
    }
    i. des.
    splits.
    { ii. inv H.
      hexploit Memory.add_get0; try exact ADD2; eauto. i. des.
      revert GET. erewrite Memory.split_o; eauto. repeat condtac; ss.
      guardH o0. des; congr.
    }
    { ii. inv H.
      hexploit Memory.add_get0; try exact ADD2; eauto. i. des.
      revert GET. erewrite Memory.split_o; eauto. repeat condtac; ss.
      guardH o. des; congr.
    }
    cut (mem4 = mem2); [by i; subst; eauto|].
    apply Memory.ext. i.
    erewrite Memory.split_o; eauto. erewrite Memory.add_o; eauto.
    erewrite (@Memory.add_o mem2); eauto. erewrite (@Memory.split_o mem1); eauto.
    repeat (condtac; ss).
    - des. repeat subst.
      hexploit Memory.add_get0; try exact ADD2; eauto. i. des.
      revert GET. erewrite Memory.split_o; eauto. repeat condtac; ss.
    - guardH o. des. repeat subst.
      hexploit Memory.add_get0; try exact ADD2; eauto. i. des.
      revert GET. erewrite Memory.split_o; eauto. repeat condtac; ss.
  Qed.

  Lemma split_split
        mem0 loc1 ts11 ts12 ts13 msg12 msg13
        mem1 loc2 ts21 ts22 ts23 msg22 msg23
        mem2
        (LOCTS1: (loc1, ts13) <> (loc2, ts23))
        (SPLIT1: Memory.split mem0 loc1 ts11 ts12 ts13 msg12 msg13 mem1)
        (SPLIT2: Memory.split mem1 loc2 ts21 ts22 ts23 msg22 msg23 mem2):
    (loc1 = loc2 /\ ts21 = ts11 /\ ts23 = ts12 /\
     exists mem1',
       <<SPLIT1: Memory.split mem0 loc2 ts21 ts22 ts13 msg22 msg13 mem1'>> /\
       <<SPLIT2: Memory.split mem1' loc1 ts22 ts12 ts13 msg12 msg13 mem2>>) \/
    ((loc2, ts21, ts23) <> (loc1, ts11, ts12) /\
     exists mem1',
       <<SPLIT1: Memory.split mem0 loc2 ts21 ts22 ts23 msg22 msg23 mem1'>> /\
       <<SPLIT2: Memory.split mem1' loc1 ts11 ts12 ts13 msg12 msg13 mem2>>).
  Proof.
    exploit Memory.split_get0; try exact SPLIT2; eauto. i. des.
    revert GET0. erewrite Memory.split_o; eauto. repeat condtac; ss.
    - i. des. inv GET0. left. splits; auto.
      exploit Memory.split_get0; try exact SPLIT1; eauto. i. des.
      exploit Memory.split_get0; try exact SPLIT2; eauto. i. des.
      revert GET4. erewrite Memory.split_o; eauto. condtac; ss.
      exploit (@Memory.split_exists mem0 loc1 ts21 ts22 ts13);
        try by inv SPLIT2; inv SPLIT; eauto.
      { etrans.
        - inv SPLIT2. inv SPLIT. eauto.
        - inv SPLIT1. inv SPLIT. eauto.
      }
      i. des.
      exploit (@Memory.split_exists mem3 loc1 ts22 ts12 ts13);
        (try by inv SPLIT1; inv SPLIT; eauto);
        (try by inv SPLIT2; inv SPLIT; eauto).
      { erewrite Memory.split_o; eauto. repeat condtac; ss.
        - des. subst. inv x0. inv SPLIT.
          exfalso. eapply Time.lt_strorder. eauto.
        - guardH o. des; congr.
      }
      i. des.
      cut (mem4 = mem2); [by i; subst; eauto|].
      apply Memory.ext. i.
      erewrite Memory.split_o; eauto. erewrite Memory.split_o; eauto.
      erewrite (@Memory.split_o mem2); eauto. erewrite (@Memory.split_o mem1); eauto.
      repeat (condtac; ss).
      + des. repeat subst. inv x1. inv SPLIT.
        exfalso. eapply Time.lt_strorder. eauto.
      + guardH o. des. repeat subst. inv x0. inv SPLIT.
        exfalso. eapply Time.lt_strorder. eauto.
    - guardH o. i. des. inv GET0. congr.
    - guardH o. guardH o0. i. right.
      exploit (@Memory.split_exists mem0 loc2 ts21 ts22 ts23);
        try by inv SPLIT2; inv SPLIT; eauto. i. des.
      exploit (@Memory.split_exists mem3 loc1 ts11 ts12 ts13);
        try by inv SPLIT1; inv SPLIT; eauto.
      { erewrite Memory.split_o; eauto. repeat condtac; ss.
        - des. subst. hexploit Memory.split_get0; try exact SPLIT2; eauto. i. des.
          revert GET3. erewrite Memory.split_o; eauto. repeat condtac; ss.
        - guardH o1. des. subst. unguardH o0. des; congr.
        - guardH o1. guardH o2. hexploit Memory.split_get0; try exact SPLIT1; eauto. i. des. eauto.
      }
      i. des. splits.
      { ii. inv H. unguardH o. des; congr. }
      cut (mem4 = mem2); [by i; subst; eauto|].
      apply Memory.ext. i.
      erewrite Memory.split_o; eauto. erewrite Memory.split_o; eauto.
      erewrite (@Memory.split_o mem2); eauto. erewrite (@Memory.split_o mem1); eauto.
      repeat (condtac; ss).
      + des. repeat subst.
        exploit Memory.split_get0; try exact SPLIT2; eauto. i. des.
        revert GET3. erewrite Memory.split_o; eauto. repeat condtac; ss.
      + guardH o1. des. repeat subst. unguardH o. des; congr.
      + guardH o1. des. repeat subst.
        exploit Memory.split_get0; try exact SPLIT2; eauto. i. des.
        revert GET3. erewrite Memory.split_o; eauto. repeat condtac; ss.
      + guardH o1. guardH o2. des. repeat subst. unguardH o0. des; congr.
  Qed.

  Lemma split_lower_diff
        mem0 loc1 ts11 ts12 ts13 msg12 msg13
        mem1 loc2 from2 to2 msg2 msg2'
        mem2
        (LOCTS1: (loc1, ts13) <> (loc2, to2))
        (SPLIT1: Memory.split mem0 loc1 ts11 ts12 ts13 msg12 msg13 mem1)
        (LOWER2: Memory.lower mem1 loc2 from2 to2 msg2 msg2' mem2):
    (loc1 = loc2 /\ ts11 = from2 /\ ts12 = to2 /\ msg12 = msg2 /\
     Memory.split mem0 loc1 ts11 ts12 ts13 msg2' msg13 mem2) \/
    ((loc1, ts12) <> (loc2, to2) /\
     exists mem1',
        <<LOWER1: Memory.lower mem0 loc2 from2 to2 msg2 msg2' mem1'>> /\
        <<SPLIT2: Memory.split mem1' loc1 ts11 ts12 ts13 msg12 msg13 mem2>>).
  Proof.
    exploit Memory.lower_get0; eauto. i. des.
    revert GET. erewrite Memory.split_o; eauto. repeat condtac; ss.
    - des. subst. i. inv GET. left. splits; auto.
      inv SPLIT1. inv SPLIT. inv LOWER2. inv LOWER.
      rewrite LocFun.add_add_eq. econs; auto.
      unfold Cell.split in *.
      destruct r, r0. ss. subst.
      unfold LocFun.add. condtac; [|congr]. s.
      rewrite DOMap.add_add_eq. econs; auto.
    - guardH o. des. subst. congr.
    - guardH o. guardH o0. i. right.
      exploit (@Memory.lower_exists mem0 loc2 from2 to2);
        try by inv LOWER2; inv LOWER; eauto. i. des.
      exploit (@Memory.split_exists mem3 loc1 ts11 ts12 ts13);
        try by inv SPLIT1; inv SPLIT; eauto.
      { erewrite Memory.lower_o; eauto. condtac; ss.
        - des. subst. congr.
        - guardH o1. hexploit Memory.split_get0; try exact SPLIT1; eauto. i. des. eauto.
      }
      i. des.
      splits.
      { ii. inv H. exploit Memory.split_get0; try exact SPLIT1; eauto. i. des.
        exploit Memory.lower_get0; eauto. i. des. congr.
      }
      cut (mem4 = mem2); [by i; subst; eauto|].
      apply Memory.ext. i.
      erewrite Memory.split_o; eauto. erewrite Memory.lower_o; eauto.
      erewrite (@Memory.lower_o mem2); eauto. erewrite (@Memory.split_o mem1); eauto.
      repeat (condtac; ss).
      + des. repeat subst. congr.
      + guardH o1. des. repeat subst. congr.
  Qed.

  Lemma split_lower_same
        loc
        mem0 ts11 ts12 ts13 msg12 msg13
        mem1 from2 msg2 msg2'
        mem2
        (SPLIT1: Memory.split mem0 loc ts11 ts12 ts13 msg12 msg13 mem1)
        (LOWER2: Memory.lower mem1 loc from2 ts13 msg2 msg2' mem2):
    from2 = ts12 /\ msg13 = msg2 /\
    exists mem1',
      <<LOWER1: Memory.lower mem0 loc ts11 ts13 msg2 msg2' mem1'>> /\
      <<SPLIT2: Memory.split mem1' loc ts11 ts12 ts13 msg12 msg2' mem2>>.
  Proof.
    exploit Memory.lower_get0; eauto. erewrite Memory.split_o; eauto. repeat condtac; ss; cycle 2.
    { clear -o0. des; congr. }
    { des. subst. inv SPLIT1. inv SPLIT. exfalso. eapply Time.lt_strorder. eauto. }
    clear o a COND COND0. i. des. inv GET. splits; ss.
    exploit Memory.split_get0; eauto. i. des.
    exploit (@Memory.lower_exists mem0 loc ts11 ts13);
      try by inv LOWER2; inv LOWER; eauto.
    { inv SPLIT1. inv SPLIT. etrans; eauto. }
    i. des.
    exploit (@Memory.split_exists mem3 loc ts11 from2 ts13);
      try by inv SPLIT1; inv SPLIT; eauto.
    { erewrite Memory.lower_o; eauto. condtac; ss. des; congr. }
    i. des.
    cut (mem4 = mem2); [by i; subst; esplits; eauto|].
    apply Memory.ext. i.
    erewrite Memory.split_o; eauto. erewrite Memory.lower_o; eauto.
    erewrite (@Memory.lower_o mem2); eauto. erewrite (@Memory.split_o mem1); eauto.
    repeat (condtac; ss).
    des. repeat subst. congr.
  Qed.

  Lemma split_remove
        mem0 loc1 ts11 ts12 ts13 msg12 msg13
        mem1 loc2 from2 to2 msg2
        mem2
        (LOCTS1: (loc1, ts12) <> (loc2, to2))
        (LOCTS2: (loc1, ts13) <> (loc2, to2))
        (SPLIT1: Memory.split mem0 loc1 ts11 ts12 ts13 msg12 msg13 mem1)
        (REMOVE2: Memory.remove mem1 loc2 from2 to2 msg2 mem2):
    exists mem1',
      <<REMOVE1: Memory.remove mem0 loc2 from2 to2 msg2 mem1'>> /\
      <<SPLIT2: Memory.split mem1' loc1 ts11 ts12 ts13 msg12 msg13 mem2>>.
  Proof.
    exploit (@Memory.remove_exists mem0 loc2 from2 to2).
    { hexploit Memory.remove_get0; eauto.
      erewrite Memory.split_o; eauto. repeat condtac; ss.
      { des. subst. congr. }
      { guardH o. des. subst. congr. }
      guardH o. guardH o0. i. des. eauto.
    }
    i. des.
    exploit (@Memory.split_exists mem3 loc1 ts11 ts12 ts13);
      try by inv SPLIT1; inv SPLIT; eauto.
    { erewrite Memory.remove_o; eauto. condtac; ss.
      { des. subst. congr. }
      guardH o. hexploit Memory.split_get0; eauto. i. des. eauto.
    }
    i. des.
    cut (mem4 = mem2); [by i; subst; eauto|].
    apply Memory.ext. i.
    erewrite Memory.split_o; eauto. erewrite Memory.remove_o; eauto.
    erewrite (@Memory.remove_o mem2); eauto. erewrite (@Memory.split_o mem1); eauto.
    repeat (condtac; ss).
    - des. repeat subst. congr.
    - guardH o. des. repeat subst. congr.
  Qed.

  Lemma split_remove_same
        mem0 loc1 ts11 ts12 ts13 msg12 msg13
        mem1 from2 msg2
        mem2
        (SPLIT1: Memory.split mem0 loc1 ts11 ts12 ts13 msg12 msg13 mem1)
        (REMOVE2: Memory.remove mem1 loc1 from2 ts13 msg2 mem2):
    from2 = ts12 /\ msg13 = msg2 /\
    exists mem1',
      <<REMOVE1: Memory.remove mem0 loc1 ts11 ts13 msg13 mem1'>> /\
      <<ADD2: Memory.add mem1' loc1 ts11 ts12 msg12 mem2>>.
  Proof.
    exploit Memory.split_get0; eauto. i. des.
    exploit Memory.remove_get0; eauto. i. des.
    rewrite GET3 in *. inv GET2. splits; auto.
    exploit (@Memory.remove_exists mem0 loc1 ts11 ts13 msg13); eauto. i. des.
    exploit (@Memory.add_exists mem3 loc1 ts11 ts12 msg12); eauto.
    { ii. revert GET2.
      erewrite Memory.remove_o; eauto. condtac; ss. i. des; ss.
      exploit Memory.get_disjoint; [exact GET0|exact GET2|..]. i. des.
      { subst. ss. }
      inv LHS. inv RHS. ss.
      apply (x2 x); econs; ss.
      inv SPLIT1. inv SPLIT.
      etrans; try exact TO. econs; ss. }
    { inv SPLIT1. inv SPLIT. ss. }
    { inv SPLIT1. inv SPLIT. ss. }
    i. des. esplits; eauto.
    cut (mem4 = mem2); [i; subst; eauto|].
    apply Memory.ext. i.
    erewrite Memory.add_o; eauto. erewrite Memory.remove_o; eauto.
    erewrite (@Memory.remove_o mem2); eauto. erewrite (@Memory.split_o mem1); eauto.
    repeat (condtac; ss).
    des. subst. congr.
  Qed.

  Lemma lower_add
        mem0 loc1 from1 to1 msg1 msg1'
        mem1 loc2 from2 to2 msg2
        mem2
        (LOWER1: Memory.lower mem0 loc1 from1 to1 msg1 msg1' mem1)
        (ADD2: Memory.add mem1 loc2 from2 to2 msg2 mem2):
    exists mem1',
      <<ADD1: Memory.add mem0 loc2 from2 to2 msg2 mem1'>> /\
      <<LOWER2: Memory.lower mem1' loc1 from1 to1 msg1 msg1' mem2>> /\
      <<LOCTS: (loc1, to1) <> (loc2, to2)>>.
  Proof.
    exploit (@Memory.add_exists mem0 loc2 from2 to2);
      try by inv ADD2; inv ADD; eauto.
    { apply covered_disjoint_get_disjoint. i. rewrite <- lower_covered in H; eauto.
      eapply get_disjoint_covered_disjoint; eauto. inv ADD2. inv ADD. auto.
    }
    i. des.
    exploit (@Memory.lower_exists mem3 loc1 from1 to1);
      try by inv LOWER1; inv LOWER; eauto.
    { erewrite Memory.add_o; eauto. condtac; ss.
      - des. subst. hexploit Memory.lower_get0; eauto. i. des.
        hexploit Memory.add_get0; eauto. i. des. congr.
      - guardH o. hexploit Memory.lower_get0; eauto. i. des. eauto.
    }
    i. des.
    esplits; eauto; cycle 1.
    { ii. inv H.
      exploit Memory.lower_get0; try exact LOWER1; eauto. i. des.
      exploit Memory.add_get0; eauto. i. des. congr.
    }
    cut (mem4 = mem2); [by i; subst; eauto|].
    apply Memory.ext. i.
    erewrite Memory.lower_o; eauto. erewrite Memory.add_o; eauto.
    erewrite (@Memory.add_o mem2); eauto. erewrite (@Memory.lower_o mem1); eauto.
    repeat (condtac; ss). des. repeat subst.
    exploit Memory.add_get0; try exact ADD2; eauto. i. des.
    revert GET. erewrite Memory.lower_o; eauto. condtac; ss.
  Qed.

  Lemma lower_split
        mem0 loc1 from1 to1 msg1 msg1'
        mem1 loc2 ts21 ts22 ts23 msg22 msg23
        mem2
        (LOWER1: Memory.lower mem0 loc1 from1 to1 msg1 msg1' mem1)
        (SPLIT2: Memory.split mem1 loc2 ts21 ts22 ts23 msg22 msg23 mem2):
    exists from1' msg23' mem1',
      <<SPLIT1: Memory.split mem0 loc2 ts21 ts22 ts23 msg22 msg23' mem1'>> /\
      <<LOWER2: Memory.lower mem1' loc1 from1' to1 msg1 msg1' mem2>> /\
      <<FROM1: __guard__ ((loc1, to1, from1', msg1', msg23') = (loc2, ts23, ts22, msg23, msg1) \/
                          ((loc1, to1) <> (loc2, ts23) /\ (from1', msg23') = (from1, msg23)))>>.
  Proof.
    destruct (loc_ts_eq_dec (loc1, to1) (loc2, ts23)); ss.
    - des. subst.
      exploit Memory.split_get0; eauto. i. des.
      revert GET0. erewrite Memory.lower_o; eauto. condtac; ss; cycle 1.
      { des; congr. }
      i. inv GET0.
      exploit (@Memory.split_exists mem0 loc2 ts21 ts22 ts23);
        try by inv SPLIT2; inv SPLIT; eauto.
      { hexploit Memory.lower_get0; eauto. i. des. eauto. }
      i. des.
      exploit (@Memory.lower_exists mem3 loc2 ts22 ts23);
        try by inv LOWER1; inv LOWER; eauto.
      { erewrite Memory.split_o; eauto. repeat condtac; ss.
        ss. des. subst. inv SPLIT2. inv SPLIT.
        exfalso. eapply Time.lt_strorder. eauto.
      }
      { inv SPLIT2. inv SPLIT. auto. }
      i. des.
      esplits; eauto; cycle 1.
      { left. eauto. }
      cut (mem4 = mem2); [by i; subst; eauto|].
      apply Memory.ext. i.
      erewrite Memory.lower_o; eauto. erewrite Memory.split_o; eauto.
      erewrite (@Memory.split_o mem2); eauto. erewrite (@Memory.lower_o mem1); eauto.
      repeat (condtac; ss).
      des. repeat subst.
      revert GET. erewrite Memory.lower_o; eauto. condtac; ss.
    - guardH o.
      exploit Memory.split_get0; eauto. i. des.
      exploit (@Memory.split_exists mem0 loc2 ts21 ts22 ts23);
        try by inv SPLIT2; inv SPLIT; eauto.
      { revert GET0. erewrite Memory.lower_o; eauto. condtac; eauto.
        ss. i. des. inv GET0. unguardH o. des; congr.
      }
      i. des.
      exploit (@Memory.lower_exists mem3 loc1 from1 to1);
        try by inv LOWER1; inv LOWER; eauto.
      { erewrite Memory.split_o; eauto. repeat condtac; ss.
        - des. subst. hexploit Memory.split_get0; eauto.
          hexploit Memory.lower_get0; eauto. i. des. congr.
        - guardH o0. des. subst.
          unguardH o. des; congr.
        - guardH o0. guardH o1. hexploit Memory.lower_get0; eauto. i. des. eauto.
      }
      i. des.
      esplits; eauto; cycle 1.
      { right. splits; eauto. ii. inv H. unguardH o. des; congr. }
      cut (mem4 = mem2); [by i; subst; eauto|].
      apply Memory.ext. i.
      erewrite Memory.lower_o; eauto. erewrite Memory.split_o; eauto.
      erewrite (@Memory.split_o mem2); eauto. erewrite (@Memory.lower_o mem1); eauto.
      repeat (condtac; ss).
      + des. repeat subst.
        revert GET. erewrite Memory.lower_o; eauto. condtac; ss.
      + guardH o0. des. repeat subst. unguardH o. des; congr.
  Qed.

  Lemma lower_lower
        mem0 loc1 from1 to1 msg1 msg1'
        mem1 loc2 from2 to2 msg2 msg2'
        mem2
        (LOWER1: Memory.lower mem0 loc1 from1 to1 msg1 msg1' mem1)
        (LOWER2: Memory.lower mem1 loc2 from2 to2 msg2 msg2' mem2):
    (loc1 = loc2 /\ from1 = from2 /\ to1 = to2 /\ msg1' = msg2 /\
     Memory.lower mem0 loc1 from1 to1 msg1 msg2' mem2) \/
    (<<LOCTS1: (loc1, to1) <> (loc2, to2)>> /\
     exists mem1',
       <<LOWER1: Memory.lower mem0 loc2 from2 to2 msg2 msg2' mem1'>> /\
       <<LOWER2: Memory.lower mem1' loc1 from1 to1 msg1 msg1' mem2>>).
  Proof.
    exploit Memory.lower_get0; eauto. i. des.
    revert GET. erewrite Memory.lower_o; eauto. condtac; ss.
    - des. subst. i. inv GET. left. splits; eauto.
      inv LOWER1. inv LOWER. inv LOWER2. inv LOWER.
      rewrite LocFun.add_add_eq. econs; auto.
      unfold Cell.lower in *.
      destruct r, r0. ss. subst.
      unfold LocFun.add. condtac; [|congr]. s.
      rewrite DOMap.add_add_eq. econs; auto.
      etrans; eauto.
    - guardH o. i. right. splits.
      { ii. inv H. unguardH o. des; congr. }
      exploit (@Memory.lower_exists mem0 loc2 from2 to2);
        try by inv LOWER2; inv LOWER; eauto.
      i. des.
      exploit (@Memory.lower_exists mem3 loc1 from1 to1);
        try by inv LOWER1; inv LOWER; eauto.
      { erewrite Memory.lower_o; eauto. condtac; ss.
        - des. subst. unguardH o. des; congr.
        - guardH o0. hexploit Memory.lower_get0; try exact LOWER1; eauto. i. des. eauto.
      }
      i. des.
      esplits; eauto.
      cut (mem4 = mem2); [by i; subst; eauto|].
      apply Memory.ext. i.
      erewrite Memory.lower_o; eauto. erewrite Memory.lower_o; eauto.
      erewrite (@Memory.lower_o mem2); eauto. erewrite (@Memory.lower_o mem1); eauto.
      repeat (condtac; ss). des. repeat subst.
      unguardH o. des; congr.
  Qed.

  Lemma lower_remove
        mem0 loc1 from1 to1 msg1 msg1'
        mem1 loc2 from2 to2 msg2
        mem2
        (LOCTS1: (loc1, to1) <> (loc2, to2))
        (LOWER1: Memory.lower mem0 loc1 from1 to1 msg1 msg1' mem1)
        (REMOVE2: Memory.remove mem1 loc2 from2 to2 msg2 mem2):
    exists mem1',
      <<REMOVE1: Memory.remove mem0 loc2 from2 to2 msg2 mem1'>> /\
      <<LOWER2: Memory.lower mem1' loc1 from1 to1 msg1 msg1' mem2>>.
  Proof.
    exploit (@Memory.remove_exists mem0 loc2 from2 to2).
    { hexploit Memory.remove_get0; eauto. i. des.
      revert GET. erewrite Memory.lower_o; eauto. condtac; ss.
      { des. subst. congr. }
      eauto.
    }
    i. des.
    exploit (@Memory.lower_exists mem3 loc1 from1 to1);
      try by inv LOWER1; inv LOWER; eauto.
    { erewrite Memory.remove_o; eauto. condtac; ss.
      { des. subst. congr. }
      inv LOWER1. inv LOWER. eauto.
    }
    i. des.
    cut (mem4 = mem2); [by i; subst; eauto|].
    apply Memory.ext. i.
    erewrite Memory.lower_o; eauto. erewrite Memory.remove_o; eauto.
    erewrite (@Memory.remove_o mem2); eauto. erewrite (@Memory.lower_o mem1); eauto.
    repeat (condtac; ss). des. repeat subst. congr.
  Qed.

  Lemma lower_remove_same
        mem0 loc1 from1 to1 msg1 msg1'
        mem1 from2 msg2
        mem2
        (LOWER1: Memory.lower mem0 loc1 from1 to1 msg1 msg1' mem1)
        (REMOVE2: Memory.remove mem1 loc1 from2 to1 msg2 mem2):
    from1 = from2 /\ msg1' = msg2 /\
    <<REMOVE1: Memory.remove mem0 loc1 from1 to1 msg1 mem2>>.
  Proof.
    exploit Memory.lower_get0; eauto. i. des.
    exploit Memory.remove_get0; eauto. i. des.
    rewrite GET1 in *. inv GET0. splits; auto.
    exploit (@Memory.remove_exists mem0 loc1 from1 to1 msg1); eauto. i. des.
    cut (mem3 = mem2); [i; subst; eauto|].
    apply Memory.ext. i.
    erewrite Memory.remove_o; eauto.
    erewrite (@Memory.remove_o mem2); try exact REMOVE2.
    erewrite (@Memory.lower_o mem1); eauto.
    repeat (condtac; ss).
  Qed.

  Lemma remove_add
        mem0 loc1 from1 to1 msg1
        mem1 loc2 from2 to2 msg2
        mem2
        mem1'
        (REMOVE1: Memory.remove mem0 loc1 from1 to1 msg1 mem1)
        (ADD2: Memory.add mem1 loc2 from2 to2 msg2 mem2)
        (ADD1: Memory.add mem0 loc2 from2 to2 msg2 mem1'):
    Memory.remove mem1' loc1 from1 to1 msg1 mem2.
  Proof.
    exploit Memory.remove_get0; try eexact REMOVE1; eauto. i. des.
    exploit (@Memory.remove_exists mem1' loc1 from1 to1 msg1); eauto.
    { erewrite Memory.add_o; eauto. condtac; ss; eauto.
      des. subst. exploit Memory.add_get0; eauto. i. des. congr.
    }
    i. des.
    cut (mem3 = mem2); [by i; subst|].
    apply Memory.ext. i.
    erewrite Memory.remove_o; eauto. erewrite Memory.add_o; eauto.
    erewrite (@Memory.add_o mem2); eauto. erewrite (@Memory.remove_o mem1); eauto.
    repeat (condtac; ss). des. subst. subst.
    exploit Memory.add_get0; try eexact ADD1; eauto. i. des. congr.
  Qed.

  Lemma remove_split
        mem0 loc1 from1 to1 msg1
        mem1 loc2 ts21 ts22 ts23 msg22 msg23
        mem2
        mem1'
        (REMOVE1: Memory.remove mem0 loc1 from1 to1 msg1 mem1)
        (SPLIT2: Memory.split mem1 loc2 ts21 ts22 ts23 msg22 msg23 mem2)
        (SPLIT1: Memory.split mem0 loc2 ts21 ts22 ts23 msg22 msg23 mem1'):
    Memory.remove mem1' loc1 from1 to1 msg1 mem2.
  Proof.
    exploit Memory.remove_get0; try eexact REMOVE1; eauto. i. des.
    exploit Memory.split_get0; try exact SPLIT1; eauto. i. des.
    exploit (@Memory.remove_exists mem1' loc1 from1 to1 msg1); eauto.
    { erewrite Memory.split_o; eauto. repeat condtac; ss.
      - des. subst. congr.
      - guardH o. des. subst. rewrite GET0 in GET0. inv GET0.
        exploit Memory.split_get0; try exact SPLIT2; eauto. i. des.
        revert GET5. erewrite Memory.remove_o; eauto. condtac; ss.
    }
    i. des.
    cut (mem3 = mem2); [by i; subst|].
    apply Memory.ext. i.
    erewrite Memory.remove_o; eauto. erewrite Memory.split_o; eauto.
    erewrite (@Memory.split_o mem2); eauto. erewrite (@Memory.remove_o mem1); eauto.
    repeat (condtac; ss).
    - des; congr.
    - guardH o. des. subst. rewrite GET in GET2. inv GET2.
      exploit Memory.remove_get0; try exact GET1; eauto. i. des.
      revert GET2. erewrite Memory.split_o; eauto. repeat condtac; ss. i. inv GET2.
      inv SPLIT1. inv SPLIT. exfalso. eapply Time.lt_strorder. eauto.
  Qed.

  Lemma remove_lower
        mem0 loc1 from1 to1 msg1
        mem1 loc2 from2 to2 msg2' msg2
        mem2
        mem1'
        (REMOVE1: Memory.remove mem0 loc1 from1 to1 msg1 mem1)
        (LOWER2: Memory.lower mem1 loc2 from2 to2 msg2' msg2 mem2)
        (LOWER1: Memory.lower mem0 loc2 from2 to2 msg2' msg2 mem1'):
    Memory.remove mem1' loc1 from1 to1 msg1 mem2.
  Proof.
    exploit Memory.remove_get0; try eexact REMOVE1; eauto. i. des.
    exploit (@Memory.remove_exists mem1' loc1 from1 to1 msg1); eauto.
    { erewrite Memory.lower_o; eauto. condtac; ss.
      des. subst.
      exploit Memory.lower_get0; try exact LOWER2; eauto. i. des.
      revert GET1. erewrite Memory.remove_o; eauto. condtac; ss.
    }
    i. des.
    cut (mem3 = mem2); [by i; subst|].
    apply Memory.ext. i.
    erewrite Memory.remove_o; eauto. erewrite Memory.lower_o; eauto.
    erewrite (@Memory.lower_o mem2); eauto. erewrite (@Memory.remove_o mem1); eauto.
    repeat (condtac; ss). des. repeat subst.
    exploit Memory.lower_get0; try exact LOWER2; eauto. i. des.
    revert GET1. erewrite Memory.remove_o; eauto. condtac; ss.
  Qed.

  Lemma remove_remove
        promises0 loc1 from1 to1 msg1
        promises1 loc2 from2 to2 msg2
        promises2
        (REMOVE1: Memory.remove promises0 loc1 from1 to1 msg1 promises1)
        (REMOVE2: Memory.remove promises1 loc2 from2 to2 msg2 promises2):
    exists promises1',
      <<REMOVE1: Memory.remove promises0 loc2 from2 to2 msg2 promises1'>> /\
      <<REMOVE2: Memory.remove promises1' loc1 from1 to1 msg1 promises2>>.
  Proof.
    exploit Memory.remove_get0; try apply REMOVE2; eauto. i. des.
    revert GET. erewrite Memory.remove_o; eauto. condtac; ss. guardH o. i.
    exploit Memory.remove_exists; eauto. i. des.
    hexploit Memory.remove_get0; try apply REMOVE1; eauto. i. des.
    exploit (@Memory.remove_exists mem2 loc1 from1 to1 msg1); eauto.
    { erewrite Memory.remove_o; eauto. condtac; ss. des. subst. congr. }
    i. des.
    esplits; eauto.
    cut (mem0 = promises2); [by i; subst|].
    apply Memory.ext. i.
    erewrite Memory.remove_o; eauto. erewrite Memory.remove_o; eauto.
    erewrite (@Memory.remove_o promises2); eauto. erewrite (@Memory.remove_o promises1); eauto.
    repeat (condtac; ss).
  Qed.

  (* Lemmas on promise *)

  Lemma promise_add_remove
        loc1 from1 to1 msg1
        loc2 from2 to2 msg2
        promises0 mem0
        promises1 mem1
        promises2
        (LOCTS1: (loc1, to1) <> (loc2, to2))
        (PROMISE1: Memory.promise promises0 mem0 loc1 from1 to1 msg1 promises1 mem1 Memory.op_kind_add)
        (REMOVE2: Memory.remove promises1 loc2 from2 to2 msg2 promises2):
    exists promises1',
      <<REMOVE1: Memory.remove promises0 loc2 from2 to2 msg2 promises1'>> /\
      <<PROMISE2: Memory.promise promises1' mem0 loc1 from1 to1 msg1 promises2 mem1 Memory.op_kind_add>>.
  Proof.
    inv PROMISE1.
    exploit add_remove; try exact PROMISES; eauto. i. des.
    esplits; eauto.
  Qed.

  Lemma promise_split_remove
        loc1 from1 to1 msg1
        loc2 from2 to2 msg2
        to3 msg3
        promises0 mem0
        promises1 mem1
        promises2
        (LOCTS1: (loc1, to1) <> (loc2, to2))
        (LOCTS2: (loc1, to3) <> (loc2, to2))
        (PROMISE1: Memory.promise promises0 mem0 loc1 from1 to1 msg1 promises1 mem1 (Memory.op_kind_split to3 msg3))
        (REMOVE2: Memory.remove promises1 loc2 from2 to2 msg2 promises2):
    exists promises1',
      <<REMOVE1: Memory.remove promises0 loc2 from2 to2 msg2 promises1'>> /\
      <<PROMISE2: Memory.promise promises1' mem0 loc1 from1 to1 msg1 promises2 mem1 (Memory.op_kind_split to3 msg3)>>.
  Proof.
    inv PROMISE1.
    exploit split_remove; try exact PROMISES; eauto. i. des.
    esplits; eauto. econs; eauto.
  Qed.

  Lemma promise_lower_remove
        loc1 from1 to1 msg0 msg1
        loc2 from2 to2 msg2
        promises0 mem0
        promises1 mem1
        promises2
        (LOCTS1: (loc1, to1) <> (loc2, to2))
        (PROMISE1: Memory.promise promises0 mem0 loc1 from1 to1 msg1 promises1 mem1 (Memory.op_kind_lower msg0))
        (REMOVE2: Memory.remove promises1 loc2 from2 to2 msg2 promises2):
    exists promises1',
      <<REMOVE1: Memory.remove promises0 loc2 from2 to2 msg2 promises1'>> /\
      <<PROMISE2: Memory.promise promises1' mem0 loc1 from1 to1 msg1 promises2 mem1 (Memory.op_kind_lower msg0)>>.
  Proof.
    inv PROMISE1.
    exploit lower_remove; try exact PROMISES; eauto. i. des.
    esplits; eauto.
  Qed.

  Lemma remove_promise
        promises1 loc1 from1 to1 msg1
        promises2 loc2 from2 to2 msg2
        promises3
        mem1 mem3
        kind
        (LE: Memory.le promises1 mem1)
        (REMOVE: Memory.remove promises1 loc1 from1 to1 msg1 promises2)
        (PROMISE: Memory.promise promises2 mem1 loc2 from2 to2 msg2 promises3 mem3 kind):
    exists promises2',
      Memory.promise promises1 mem1 loc2 from2 to2 msg2 promises2' mem3 kind /\
      Memory.remove promises2' loc1 from1 to1 msg1 promises3.
  Proof.
    inv PROMISE.
    - exploit Memory.add_exists_le; eauto. i. des.
      exploit remove_add; eauto.
    - exploit Memory.split_get0; try eexact PROMISES; eauto. i. des.
      revert GET0. erewrite Memory.remove_o; eauto. condtac; ss. i. guardH o.
      exploit Memory.split_exists; try exact GET0; try by inv PROMISES; inv SPLIT; eauto. i. des.
      exploit remove_split; eauto. i.
      esplits; eauto. econs; eauto.
    - exploit Memory.lower_get0; try eexact PROMISES; eauto. i. des.
      revert GET. erewrite Memory.remove_o; eauto. condtac; ss. i. guardH o.
      exploit Memory.lower_exists; try exact GET; try by inv PROMISES; inv LOWER; eauto. i. des.
      exploit remove_lower; eauto. i.
      esplits; eauto.
    - exploit remove_remove; try exact REMOVE; eauto. i. des. eauto.
  Qed.

  Lemma promise_add_promise_split_same
        promises0 mem0 loc ts1 ts2 ts3 msg2 msg3
        promises1 mem1
        promises2 mem2
        (ADD1: Memory.promise promises0 mem0 loc ts1 ts3 msg3 promises1 mem1 Memory.op_kind_add)
        (SPLIT2: Memory.promise promises1 mem1 loc ts1 ts2 msg2 promises2 mem2 (Memory.op_kind_split ts3 msg3)):
    exists promises1' mem1',
      <<ADD1: Memory.promise promises0 mem0 loc ts1 ts2 msg2 promises1' mem1' Memory.op_kind_add>> /\
      <<ADD2: Memory.promise promises1' mem1' loc ts2 ts3 msg3 promises2 mem2 Memory.op_kind_add>>.
  Proof.
    inv ADD1. inv SPLIT2.
    exploit add_split; try exact PROMISES; eauto. i. des; [|congr].
    exploit add_split; try exact MEM; eauto. i. des; [|congr].
    esplits.
    - econs; eauto.
      i. exploit Memory.add_get0; try exact MEM. i. des.
      exploit Memory.add_get1; try exact GET; try exact MEM. i.
      exploit Memory.get_ts; try exact GET1. i. des.
      { subst. inv ADD3. inv ADD. inv TO. }
      exploit Memory.get_ts; try exact x8. i. des.
      { subst. inv ADD0. inv ADD. inv TO. }
      exploit Memory.get_disjoint; [exact GET1|exact x8|..]. i. des.
      { subst. inv ADD0. inv ADD. timetac. }
      destruct (TimeFacts.le_lt_dec ts3 to').
      + apply (x11 ts3); econs; ss; try refl.
        inv ADD3. inv ADD. ss.
      + apply (x11 to'); econs; ss; try refl.
        { etrans; try exact x10. inv ADD0. inv ADD. ss. }
        { econs. ss. }
    - econs; eauto.
      i. revert GET.
      erewrite Memory.add_o; eauto. condtac; ss; eauto.
      i. des. subst. inv GET. inv MEM. inv ADD. timetac.
  Qed.

  Lemma promise_split_promise_split_same
        promises0 mem0 loc ts1 ts2 ts3 ts4 val2 released2 msg3 msg4
        promises1 mem1
        promises2 mem2
        (SPLIT1: Memory.promise promises0 mem0 loc ts1 ts3 msg3 promises1 mem1 (Memory.op_kind_split ts4 msg4))
        (SPLIT2: Memory.promise promises1 mem1 loc ts1 ts2 (Message.concrete val2 released2) promises2 mem2 (Memory.op_kind_split ts3 msg3)):
    exists promises1' mem1',
      <<SPLIT1: Memory.promise promises0 mem0 loc ts1 ts2 (Message.concrete val2 released2) promises1' mem1' (Memory.op_kind_split ts4 msg4)>> /\
      <<SPLIT2: Memory.promise promises1' mem1' loc ts2 ts3 msg3 promises2 mem2 (Memory.op_kind_split ts4 msg4)>>.
  Proof.
    assert (LOCTS: (loc, ts4) <> (loc, ts3)).
    { intro X. inv X. inv SPLIT1. inv MEM. inv SPLIT. timetac. }
    inv SPLIT1. inv SPLIT2.
    exploit split_split; try exact PROMISES; eauto. i. des; [|congr].
    exploit split_split; try exact MEM; eauto. i. des; [|congr].
    esplits.
    - econs; eauto; congr.
    - econs; eauto.
  Qed.

  Lemma promise_lower_promise_split_same
        promises0 mem0 loc ts1 ts2 ts3 msg0 val2 released2 msg3
        promises1 mem1
        promises2 mem2
        (LOWER1: Memory.promise promises0 mem0 loc ts1 ts3 msg3 promises1 mem1 (Memory.op_kind_lower msg0))
        (SPLIT2: Memory.promise promises1 mem1 loc ts1 ts2 (Message.concrete val2 released2) promises2 mem2 (Memory.op_kind_split ts3 msg3)):
    exists promises1' mem1',
      <<SPLIT1: Memory.promise promises0 mem0 loc ts1 ts2 (Message.concrete val2 released2) promises1' mem1' (Memory.op_kind_split ts3 msg0)>> /\
      <<LOWER2: Memory.promise promises1' mem1' loc ts2 ts3 msg3 promises2 mem2 (Memory.op_kind_lower msg0)>>.
  Proof.
    inv LOWER1. inv SPLIT2.
    exploit lower_split; try exact PROMISES; eauto. i. des.
    unguard. des; [|congr]. inv FROM1.
    exploit lower_split; try exact MEM; eauto. i. des.
    unguard. des; [|congr]. inv FROM1.
    esplits.
    - econs; eauto; congr.
    - econs; eauto.
  Qed.
End MemoryReorder.


Require Forcing.

Set Primitive Projections.

Section Sigma.

Variable Obj : Type.
Variable Hom : Obj -> Obj -> Type.

Notation "P ≤ Q" := (forall R, Hom Q R -> Hom P R) (at level 70).
Notation "#" := (fun (R : Obj) (k : Hom _ R) => k).
Notation "f ∘ g" := (fun (R : Obj) (k : Hom _ R) => f R (g R k)) (at level 40).

Forcing Translate sigT using Obj Hom.

Definition sig_rec : forall A (B:A -> Type) P, (forall a:A, B a -> P) -> sigT B -> P :=
  fun A B P f x => match x with existT _ a b => f a b end.

Forcing Translate sig_rec using Obj Hom.

Definition sig_mem A (B:A -> Type) : forall R, sigT B -> (sigT B -> R) -> R:=
  fun R x => sig_rec A B (({x : A & B x} -> R) -> R) (fun a b k => k (existT _ a b)) x.

Forcing Translate sig_mem using Obj Hom.

Forcing Definition sig_rect' : forall A (B:A -> Type) P,
    (forall (a:A) (b: B a), P (existT _ a b)) -> forall (x : sigT B), sig_mem A B _ x P
                                                     using Obj Hom.
intros p A B P H x.
compute. generalize (x p #).
exact (fun x => match x with
        | existTᶠ _ _ _ a b => H p # a b
                end).
(* Universe issue *)
Show Proof.
Abort.

Forcing Definition sig_rect' : forall A (B:A -> Type) P,
    (forall (a:A) (b: B a), P (existT _ a b)) -> forall (x : sigT B), sig_mem A B _ x P
                                                     using Obj Hom.

exact (fun (p : Obj)
   (A : forall p0 : Obj, p ≤ p0 -> forall p1 : Obj, p0 ≤ p1 -> Type)
   (B : forall (p0 : Obj) (α : p ≤ p0),
        (forall (p1 : Obj) (α0 : p0 ≤ p1),
         A p1 (# ∘ (α ∘ (# ∘ (α0 ∘ #)))) p1 #) ->
        forall p1 : Obj, p0 ≤ p1 -> Type)
   (P : forall (p0 : Obj) (α : p ≤ p0),
        (forall (p1 : Obj) (α0 : p0 ≤ p1),
         (fun
            (A0 : forall p2 : Obj,
                  p1 ≤ p2 -> forall p3 : Obj, p2 ≤ p3 -> Type)
            (P : forall (p2 : Obj) (α1 : p1 ≤ p2),
                 (forall (p3 : Obj) (α2 : p2 ≤ p3),
                  A0 p3 (α1 ∘ (# ∘ (α2 ∘ #))) p3 #) ->
                 forall p3 : Obj, p2 ≤ p3 -> Type)
            (p2 : Obj) (α1 : p1 ≤ p2) =>
          sigTᶠ p2
            (fun (p3 : Obj) (α2 : p2 ≤ p3) => A0 p3 (α1 ∘ (α2 ∘ #)))
            (fun (p3 : Obj) (α2 : p2 ≤ p3) => P p3 (α1 ∘ (α2 ∘ #))))
           (fun (p2 : Obj) (α1 : p1 ≤ p2) =>
            A p2 (# ∘ (# ∘ (α ∘ (# ∘ (α0 ∘ (α1 ∘ #)))))))
           (fun (p2 : Obj) (α1 : p1 ≤ p2) =>
            B p2 (# ∘ (α ∘ (# ∘ (α0 ∘ (α1 ∘ #)))))) p1
           #) -> forall p1 : Obj, p0 ≤ p1 -> Type)
   (H : forall (p0 : Obj) (α : p ≤ p0)
          (a : forall (p1 : Obj) (α0 : p0 ≤ p1),
               A p1 (# ∘ (# ∘ (# ∘ (α ∘ (# ∘ (α0 ∘ #)))))) p1 #)
          (b : forall (p1 : Obj) (α0 : p0 ≤ p1),
               B p1 (# ∘ (# ∘ (α ∘ (# ∘ (# ∘ (α0 ∘ #))))))
                 (fun (p2 : Obj) (α1 : p1 ≤ p2) =>
                  a p2 (# ∘ (α0 ∘ (α1 ∘ #)))) p1
                 #),
        P p0 (# ∘ (α ∘ (# ∘ (# ∘ #))))
          (fun (p1 : Obj) (α0 : p0 ≤ p1) =>
           existTᶠ p1
             (fun (p2 : Obj) (α1 : p1 ≤ p2) =>
              A p2 (# ∘ (# ∘ (# ∘ (α ∘ (# ∘ (# ∘ (α0 ∘ (α1 ∘ #)))))))))
             (fun (p2 : Obj) (α1 : p1 ≤ p2) =>
              B p2 (# ∘ (# ∘ (α ∘ (# ∘ (# ∘ (α0 ∘ (α1 ∘ #))))))))
             (fun (p2 : Obj) (α1 : p1 ≤ p2) => a p2 (# ∘ (α0 ∘ (α1 ∘ #))))
             (fun (p2 : Obj) (α1 : p1 ≤ p2) => b p2 (α0 ∘ (α1 ∘ #)))) p0
          #)
   (x : forall (p0 : Obj) (α : p ≤ p0),
        (fun
           (A0 : forall p1 : Obj,
                 p0 ≤ p1 -> forall p2 : Obj, p1 ≤ p2 -> Type)
           (P0 : forall (p1 : Obj) (α0 : p0 ≤ p1),
                 (forall (p2 : Obj) (α1 : p1 ≤ p2),
                  A0 p2 (α0 ∘ (# ∘ (α1 ∘ #))) p2 #) ->
                 forall p2 : Obj, p1 ≤ p2 -> Type)
           (p1 : Obj) (α0 : p0 ≤ p1) =>
         sigTᶠ p1 (fun (p2 : Obj) (α1 : p1 ≤ p2) => A0 p2 (α0 ∘ (α1 ∘ #)))
           (fun (p2 : Obj) (α1 : p1 ≤ p2) => P0 p2 (α0 ∘ (α1 ∘ #))))
          (fun (p1 : Obj) (α0 : p0 ≤ p1) =>
           A p1 (# ∘ (# ∘ (# ∘ (# ∘ (α ∘ (α0 ∘ #)))))))
          (fun (p1 : Obj) (α0 : p0 ≤ p1) =>
           B p1 (# ∘ (# ∘ (# ∘ (α ∘ (α0 ∘ #)))))) p0
          #) =>
 (fun
    x0 : sigTᶠ p
           (fun (p0 : Obj) (α : p ≤ p0) =>
            A p0 (fun (R : Obj) (k : Hom p0 R) => α R k))
           (fun (p0 : Obj) (α : p ≤ p0) =>
            B p0 (fun (R : Obj) (k : Hom p0 R) => α R k)) =>
  match
    x0 as x1
    return
      (match x1 with
       | existTᶠ _ _ _ a b =>
           fun
             k : forall (p0 : Obj) (α : p ≤ p0),
                 (forall (p1 : Obj) (α0 : p0 ≤ p1),
                  sigTᶠ p1
                    (fun (p2 : Obj) (α1 : p1 ≤ p2) =>
                     A p2
                       (fun (R : Obj) (k : Hom p2 R) =>
                        α R (α0 R (α1 R k))))
                    (fun (p2 : Obj) (α1 : p1 ≤ p2)
                       (x2 : forall (p3 : Obj) (α2 : p2 ≤ p3),
                             A p3
                               (fun (R : Obj) (k : Hom p3 R) =>
                                α R (α0 R (α1 R (α2 R k)))) p3
                               #) =>
                     B p2
                       (fun (R : Obj) (k : Hom p2 R) =>
                        α R (α0 R (α1 R k)))
                       (fun (p3 : Obj) (α2 : p2 ≤ p3) =>
                        x2 p3 (fun (R : Obj) (k : Hom p3 R) => α2 R k)))) ->
                 forall p1 : Obj, p0 ≤ p1 -> Type =>
           k p #
             (fun (p0 : Obj) (α : p ≤ p0) =>
              existTᶠ p0 (fun (p1 : Obj) (α0 : p0 ≤ p1) => A p1 (α ∘ α0))
                (fun (p1 : Obj) (α0 : p0 ≤ p1)
                   (x2 : forall (p2 : Obj) (α1 : p1 ≤ p2),
                         A p2
                           (fun (R : Obj) (k0 : Hom p2 R) =>
                            α R (α0 R (α1 R k0))) p2
                           #) =>
                 B p1 (α ∘ α0)
                   (fun (p2 : Obj) (α1 : p1 ≤ p2) =>
                    x2 p2 (fun (R : Obj) (k0 : Hom p2 R) => α1 R k0)))
                (fun (p1 : Obj) (α0 : p0 ≤ p1) => a p1 (α ∘ α0))
                (fun (p1 : Obj) (α0 : p0 ≤ p1) => b p1 (α ∘ α0)))
       end
         (fun (p0 : Obj) (α : p ≤ p0) =>
          P p0 (fun (R : Obj) (k : Hom p0 R) => α R k)) p
         #)
  with
  | existTᶠ _ _ _ a b => H p # a b
  end) (x p #)).
Defined.

End Sigma.


Require compcert.backend.LTL.
Require EventsX.
Require Import LocationsX.

Import Coqlib.
Import Integers.
Import AST.
Import Values.
Import Memory.
Import Globalenvs.
Import EventsX.
Import Smallstep.
Import Locations.
Import Conventions.
Export LTL.

Section WITHCONFIG.
Context `{external_calls_prf: ExternalCalls}.

(** Execution of LTL functions with Asm-style arguments (long long 64-bit integers NOT allowed) *)

Inductive initial_state (lm: locset) (p: LTL.program) (i: ident) (sg: signature) (args: list val) (m: mem): state -> Prop :=
| initial_state_intro
    b
    (Hb: Genv.find_symbol (Genv.globalenv p) i = Some b)
    f
    (Hf: Genv.find_funct_ptr (Genv.globalenv p) b = Some f)
    (Hsig: sg = funsig f)
    (Hargs: args = map (fun pa => Locmap.getpair pa lm) (loc_arguments sg))
  :
      initial_state lm p i sg args m (Callstate nil f lm m)
.

Inductive final_state (lm: locset) (sg: signature): state -> (val * mem) -> Prop :=
| final_state_intro
    rs
    v
    (Hv: v = getpair (loc_result sg) rs)
    (** Callee-save registers *)
    (CALLEE_SAVE: forall r,
       ~ In r destroyed_at_call ->
       rs (R r) = lm (R r))
    m :
    final_state lm sg (Returnstate nil rs m) (v, m)
.

Definition semantics
           (lm: locset)
           (p: LTL.program) (i: ident) (sg: signature) (args: list val) (m: mem) :=
  Semantics (
      LTL.step lm
    ) (initial_state lm p i sg args m) (final_state lm sg) (Genv.globalenv p).

End WITHCONFIG.


Inductive Foo (x := Type) := C : Foo -> Foo.


Require Export Iron.SystemF2Closure.Kind.

(* Type level capabilities *)
Inductive tycap : Type :=
 (* The region capability, also called a 'region handle'.
    When one of these exists in the program we know there is a
    corresponding region in the store. *)
 | TyCapRegion   : nat -> tycap.

Hint Constructors tycap.

(* Check if two capabilities are equal. *)
Fixpoint eq_tycap (tc1 : tycap) (tc2 : tycap) : Prop :=
 match tc1, tc2 with
 | TyCapRegion n1, TyCapRegion n2 => eq_nat n1 n1
 end.


From Coq Require Import
     String
     Fin
     Relations.

From Equations Require Import Equations.

From ITree Require Import
     Indexed.Sum
     Subevent.

From CTree Require Import
     CTree
     Equ
     SBisim
     Core.Utils
     Interp.State.

From ExtLib Require Import
     Maps
     FMapAList
     RelDec
     String
     Monad.

From Coinduction Require Import
     coinduction rel tactics.

From DSL Require Import Vectors.

Import MonadNotation EquNotations SBisimNotations.
Local Open Scope monad_scope.
Local Open Scope string_scope.

Set Implicit Arguments.
Set Contextual Implicit.

(** Some general Sets needed for Systems work *)
Module Type Systems.

  Parameter uid: nat -> Set.      (** Principal *)
  Parameter bytestring: Set.      (** ByteString *)
  Parameter var : Set.            (** binders *)
  Parameter channel: Type -> Set. (** Typed channels *)

  Parameter eqdec_bytestring: RelDec (@eq bytestring).
  Parameter eqdec_var: RelDec (@eq var).
  Parameter eqdec_channel: forall T, RelDec (@eq (channel T)).
  Parameter eqdec_uid: forall t, RelDec (@eq (uid t)).

  Global Existing Instance eqdec_bytestring.
  Global Existing Instance eqdec_var.
  Global Existing Instance eqdec_channel.
  Global Existing Instance eqdec_uid.

  Parameter uid_coerce: forall t, uid t -> fin t.
  Global Coercion uid_coerce: uid >-> fin.
  Parameter fin_coerce: forall t, fin t -> uid t.
  Global Coercion fin_coerce: fin >-> uid.
End Systems.

Module DistrSystem <: Systems.

  Definition uid := fin.

  Definition uid_coerce t (a: uid t) := a.
  Definition fin_coerce t (a: fin t) := a.

  Equations reldec_uid: forall t, fin t -> fin t -> bool :=
    reldec_uid F1 F1 := true;
    reldec_uid (FS i) (FS j) := reldec_uid i j;
    reldec_uid _ _ := false.

  (** Decidable UIDs *)
  Global Instance eqdec_uid: forall t, RelDec (@eq (uid t)) := {
      rel_dec a b := @reldec_uid t a b
    }.

  Definition bytestring := nat.
  Global Instance eqdec_bytestring: RelDec (@eq bytestring) := _.

  Definition var : Set := string.     (** binders *)
  Definition channel(T: Type) := nat. (** Typed channels *)

  Definition eqdec_var: RelDec (@eq var) := _.
  Definition eqdec_channel: forall T, RelDec (@eq (channel T)) :=
    fun T => _.

End DistrSystem.

Module Messaging(S: Systems).
  Import S.

   (** Messages exchagend *)
  Record Msg t := {
      principal: uid t;
      payload: bytestring
    }.

  (** Decidable messages *)
  Global Instance eqdec_msg: forall t, RelDec (@eq (Msg t)) := {
      rel_dec m1 m2 := match m1, m2 with
                         {| principal := u1; payload := p1 |},
                         {| principal := u2; payload := p2 |} =>
                           andb (rel_dec u1 u2) (rel_dec p1 p2)
                       end
    }.

  (** A queue of messages *)
  Definition queue t := list (Msg t).

  (** A task is either running or returned *)
  Inductive Task t (E: Type -> Type)(T: Type) :=
  | Done (r: T)(q: queue t)
  | Running (c: ctree E T)(q: queue t)
  | Blocked (c: ctree E T)(q: queue t).

  (** Network effects *)
  Inductive Net(n: nat): Type -> Type :=
  | Recv: Net n (Msg n)
  | Send : (Msg n) -> Net n unit
  | Broadcast: bytestring -> Net n unit.

  Arguments Send {n}.
  Arguments Recv {n}.
  Arguments Broadcast {n}.

  Definition recv {E n} `{Net n -< E}: ctree E (Msg n) := trigger Recv.
  Definition send {E n} `{Net n -< E}: Msg n -> ctree E unit :=
    fun m => trigger (Send m).
  Definition broadcast {E n} `{Net n -< E}: bytestring -> ctree E unit :=
    fun bs => trigger (Broadcast bs).

  Fixpoint num_done{E A m n}(a: vec m (Task n (Net n +' E) A)): nat :=
    match a with
    | ((Done _ _) :: ts) => S (num_done ts)
    | ((Running _ _) :: ts) => num_done ts
    | ((Blocked _ _) :: ts) => num_done ts
    | [] => 0
    end.

  Fixpoint num_running{E A m n}(a: vec m (Task n E A)): nat :=
    match a with
    | ((Done _ _) :: ts) => num_running ts
    | ((Running _ _) :: ts) => S (num_running ts)
    | ((Blocked _ _) :: ts) => num_running ts
    | [] => 0
    end.

End Messaging.

Module PKI(S: Systems).
  Import S.
  Context {n: nat}.

  Definition Enc (p: uid n) := bytestring.
  Definition Sig (p: uid n) := bytestring.
  Definition Pub (p: uid n) := bytestring.
  Definition Priv (p: uid n) := bytestring.

  Inductive PKI: Type -> Type :=
  | EncPub(p: uid n)(k: Pub p)(plain: bytestring): PKI (Enc p)
  | DecPriv(p: uid n)(k: Priv p)(cipher: Enc p): PKI bytestring
  | SignPriv(p: uid n)(k: Priv p)(plain: bytestring): PKI (Sig p)
  | CheckPub(p: uid n)(k: Pub p)(signed: Sig p): PKI bool.

  Definition encrypt {E} `{PKI -< E} := embed EncPub.
  Definition decrypt {E} `{PKI -< E} := embed DecPriv.
  Definition sign {E} `{PKI -< E} := embed SignPriv.
  Definition check {E} `{PKI -< E} := embed CheckPub.
End PKI.

Module Spawn(S: Systems).
  Import S.

  Inductive spawnE E : Type -> Type :=
  | Spawn : forall T (c: channel T) (t: ctree (spawnE E +' E) T), spawnE E (channel T)
  | Make: forall (T: Type), spawnE E (channel T)
  | Block: forall T (c: channel T), spawnE E T.

  Definition spawn {F E T} `{(spawnE F) -< E} (c: channel T)(t:ctree (spawnE F +' F) T) :=
    trigger (@Spawn F T c t).

  Definition make {F E T} `{(spawnE F) -< E} :=
    trigger (@Make F T).

  Definition block {F E} `{(spawnE F) -< E} {t} (c: channel t) :=
    trigger (@Block F t c).

End Spawn.

Module Storage(S: Systems).
  Import S Monads.

  Definition Map_heap := Map_alist eqdec_var bytestring.
  Global Existing Instance Map_heap.

  Notation heap := (alist var bytestring).
  Notation Storage := (stateE heap).

  Definition load {E} `{stateE heap -< E}(v: var): ctree E (option bytestring) :=
    get >>= fun s => ret (lookup v s).

  Definition store {E} `{Storage -< E}(v: var)(b: bytestring): ctree E unit :=
    get >>= fun s => put (add v b s).

  (** Evaluates, takes a single heap for all agents *)
  Definition run_storage{E R m}(a: vec m (ctree (Storage +' E) R)):
    stateT heap (fun T => vec m (ctree E T)) R :=
    fun st => Vector.map (fun it => run_state it st) a.

End Storage.

Module DistributedSystems(S: Systems).
  Module St := Storage(S).
  Module Mg := Messaging(S).
  Import S Monads St Mg.

  Variable (n: nat).
  Definition proc := ctree (Net n +' Storage) void.

  Definition mkproc{R}(t: ctree (Net n +' Storage) R): proc :=
    CTree.iter (fun _ : unit =>
            _ <- t ;;
            Ret (@inl unit void tt))
         tt.

  Lemma proc_noret: forall (p: proc) x,
      not (p ≅ Ret x).
    intros _ [].
  Defined.

  Lemma mkproc_noret: forall R (t: ctree (Net n +' Storage) R) x,
      not (@mkproc R t ≅ Ret x).
    intros _ _ [].
  Defined.
End DistributedSystems.


Require Import Frap Setoid Classes.Morphisms SepCancel.

Set Implicit Arguments.
Set Asymmetric Patterns.

(** * Shared notations and definitions; main material starts afterward. *)

Notation heap := (fmap nat nat).
Notation locks := (set nat).

Local Hint Extern 1 (_ <= _) => linear_arithmetic : core.
Local Hint Extern 1 (@eq nat _ _) => linear_arithmetic : core.

Ltac simp := repeat (simplify; subst; propositional;
                     try match goal with
                         | [ H : ex _ |- _ ] => invert H
                         end); try linear_arithmetic.

(** * A shared-memory concurrent language with loops *)

Inductive loop_outcome acc :=
| Done (a : acc)
| Again (a : acc).

Definition valueOf {A} (o : loop_outcome A) :=
  match o with
  | Done v => v
  | Again v => v
  end.

Inductive cmd : Set -> Type :=
| Return {result : Set} (r : result) : cmd result
| Fail {result} : cmd result
| Bind {result result'} (c1 : cmd result') (c2 : result' -> cmd result) : cmd result
| Loop {acc : Set} (init : acc) (body : acc -> cmd (loop_outcome acc)) : cmd acc

| Read (a : nat) : cmd nat
| Write (a v : nat) : cmd unit
| Lock (a : nat) : cmd unit
| Unlock (a : nat) : cmd unit
| Alloc (numWords : nat) : cmd nat
| Free (base numWords : nat) : cmd unit

| Par (c1 c2 : cmd unit) : cmd unit.

Notation "x <- c1 ; c2" := (Bind c1 (fun x => c2)) (right associativity, at level 80).
Notation "'for' x := i 'loop' c1 'done'" := (Loop i (fun x => c1)) (right associativity, at level 80).
Infix "||" := Par.

Fixpoint initialize (h : heap) (base numWords : nat) : heap :=
  match numWords with
  | O => h
  | S numWords' => initialize h base numWords' $+ (base + numWords', 0)
  end.

Fixpoint deallocate (h : heap) (base numWords : nat) : heap :=
  match numWords with
  | O => h
  | S numWords' => deallocate (h $- base) (base+1) numWords'
  end.

Inductive step : forall A, heap * locks * cmd A -> heap * locks * cmd A -> Prop :=
| StepBindRecur : forall result result' (c1 c1' : cmd result') (c2 : result' -> cmd result) h l h' l',
  step (h, l, c1) (h', l', c1')
  -> step (h, l, Bind c1 c2) (h', l', Bind c1' c2)
| StepBindProceed : forall (result result' : Set) (v : result') (c2 : result' -> cmd result) h l,
  step (h, l, Bind (Return v) c2) (h, l, c2 v)

| StepLoop : forall (acc : Set) (init : acc) (body : acc -> cmd (loop_outcome acc)) h l,
  step (h, l, Loop init body) (h, l, o <- body init; match o with
                                                     | Done a => Return a
                                                     | Again a => Loop a body
                                                     end)

| StepRead : forall h l a v,
  h $? a = Some v
  -> step (h, l, Read a) (h, l, Return v)
| StepWrite : forall h l a v v',
  h $? a = Some v
  -> step (h, l, Write a v') (h $+ (a, v'), l, Return tt)
| StepAlloc : forall h l numWords a,
  a <> 0
  -> (forall i, i < numWords -> h $? (a + i) = None)
  -> step (h, l, Alloc numWords) (initialize h a numWords, l, Return a)
| StepFree : forall h l a numWords,
  step (h, l, Free a numWords) (deallocate h a numWords, l, Return tt)

| StepLock : forall h l a,
  ~a \in l
  -> step (h, l, Lock a) (h, l \cup {a}, Return tt)
| StepUnlock : forall h l a,
  a \in l
  -> step (h, l, Unlock a) (h, l \setminus {a}, Return tt)

| StepPar1 : forall h l c1 c2 h' l' c1',
  step (h, l, c1) (h', l', c1')
  -> step (h, l, Par c1 c2) (h', l', Par c1' c2)
| StepPar2 : forall h l c1 c2 h' l' c2',
  step (h, l, c2) (h', l', c2')
  -> step (h, l, Par c1 c2) (h', l', Par c1 c2').

Definition trsys_of (h : heap) (l : locks) {result} (c : cmd result) := {|
  Initial := {(h, l, c)};
  Step := step (A := result)
|}.

Module Import S <: SEP.
  Definition hprop := heap -> Prop.
  (* We add the locks to the mix. *)

  Definition himp (p q : hprop) := forall h, p h -> q h.
  Definition heq (p q : hprop) := forall h, p h <-> q h.

  (* Lifting a pure proposition: it must hold, and the heap must be empty. *)
  Definition lift (P : Prop) : hprop :=
    fun h => P /\ h = $0.

  (* Separating conjunction, one of the two big ideas of separation logic.
   * When does [star p q] apply to [h]?  When [h] can be partitioned into two
   * subheaps [h1] and [h2], respectively compatible with [p] and [q].  See book
   * module [Map] for definitions of [split] and [disjoint]. *)
  Definition star (p q : hprop) : hprop :=
    fun h => exists h1 h2, split h h1 h2 /\ disjoint h1 h2 /\ p h1 /\ q h2.

  (* Existential quantification *)
  Definition exis A (p : A -> hprop) : hprop :=
    fun h => exists x, p x h.

  (* Convenient notations *)
  Notation "[| P |]" := (lift P) : sep_scope.
  Infix "*" := star : sep_scope.
  Notation "'exists' x .. y , p" := (exis (fun x => .. (exis (fun y => p)) ..)) : sep_scope.
  Delimit Scope sep_scope with sep.
  Notation "p === q" := (heq p%sep q%sep) (no associativity, at level 70).
  Notation "p ===> q" := (himp p%sep q%sep) (no associativity, at level 70).

  Local Open Scope sep_scope.

  (* And now we prove some key algebraic properties, whose details aren't so
   * important.  The library automation uses these properties. *)

  Lemma iff_two : forall A (P Q : A -> Prop),
    (forall x, P x <-> Q x)
    -> (forall x, P x -> Q x) /\ (forall x, Q x -> P x).
  Proof.
    firstorder.
  Qed.

  Local Ltac t := (unfold himp, heq, lift, star, exis; propositional; subst);
                 repeat (match goal with
                         | [ H : forall x, _ <-> _ |- _  ] =>
                           apply iff_two in H
                         | [ H : ex _ |- _ ] => destruct H
                         | [ H : split _ _ $0 |- _ ] => apply split_empty_fwd in H
                         end; propositional; subst); eauto 15.

  Theorem himp_heq : forall p q, p === q
    <-> (p ===> q /\ q ===> p).
  Proof.
    t.
  Qed.

  Theorem himp_refl : forall p, p ===> p.
  Proof.
    t.
  Qed.

  Theorem himp_trans : forall p q r, p ===> q -> q ===> r -> p ===> r.
  Proof.
    t.
  Qed.

  Theorem lift_left : forall p (Q : Prop) r,
    (Q -> p ===> r)
    -> p * [| Q |] ===> r.
  Proof.
    t.
  Qed.

  Theorem lift_right : forall p q (R : Prop),
    p ===> q
    -> R
    -> p ===> q * [| R |].
  Proof.
    t.
  Qed.

  Local Hint Resolve split_empty_bwd' : core.

  Theorem extra_lift : forall (P : Prop) p,
    P
    -> p === [| P |] * p.
  Proof.
    t.
    apply split_empty_fwd' in H1; subst; auto.
  Qed.

  Theorem star_comm : forall p q, p * q === q * p.
  Proof.
    t.
  Qed.

  Theorem star_assoc : forall p q r, p * (q * r) === (p * q) * r.
  Proof.
    t.
  Qed.

  Theorem star_cancel : forall p1 p2 q1 q2, p1 ===> p2
    -> q1 ===> q2
    -> p1 * q1 ===> p2 * q2.
  Proof.
    t.
  Qed.

  Theorem exis_gulp : forall A p (q : A -> _),
    p * exis q === exis (fun x => p * q x).
  Proof.
    t.
  Qed.

  Theorem exis_left : forall A (p : A -> _) q,
    (forall x, p x ===> q)
    -> exis p ===> q.
  Proof.
    t.
  Qed.

  Theorem exis_right : forall A p (q : A -> _) x,
    p ===> q x
    -> p ===> exis q.
  Proof.
    t.
  Qed.
End S.

Export S.
(* Instantiate our big automation engine to these definitions. *)
Module Import Se := SepCancel.Make(S).

(* ** Some extra predicates outside the set that the engine knows about *)

(* Capturing single-mapping heaps *)
Definition heap1 (a v : nat) : heap := $0 $+ (a, v).
Definition ptsto (a v : nat) : hprop :=
  fun h => h = heap1 a v.

(* Helpful notations, some the same as above *)
Notation "[| P |]" := (lift P) : sep_scope.
Notation emp := (lift True).
Infix "*" := star : sep_scope.
Notation "'exists' x .. y , p" := (exis (fun x => .. (exis (fun y => p)) ..)) : sep_scope.
Delimit Scope sep_scope with sep.
Notation "p === q" := (heq p%sep q%sep) (no associativity, at level 70).
Notation "p ===> q" := (himp p%sep q%sep) (no associativity, at level 70).
Infix "|->" := ptsto (at level 30) : sep_scope.

Fixpoint multi_ptsto (a : nat) (vs : list nat) : hprop :=
  match vs with
  | nil => emp
  | v :: vs' => a |-> v * multi_ptsto (a + 1) vs'
  end%sep.

Infix "|-->" := multi_ptsto (at level 30) : sep_scope.

Fixpoint zeroes (n : nat) : list nat :=
  match n with
  | O => nil
  | S n' => zeroes n' ++ 0 :: nil
  end.

Fixpoint allocated (a n : nat) : hprop :=
  match n with
  | O => emp
  | S n' => (exists v, a |-> v) * allocated (a+1) n'
  end%sep.

Infix "|->?" := allocated (at level 30) : sep_scope.

(** * Finally, the Hoare logic *)

(* The whole thing is parameterized on a map from locks to invariants on their
 * owned state.  The map is a list, with lock [i] getting the [i]th invariant in
 * the list.  Lock numbers at or beyond the list length are forbidden.  Beyond
 * this new wrinkle, the type signature of the predicate is the same. *)

Inductive hoare_triple (linvs : list hprop) : forall {result}, hprop -> cmd result -> (result -> hprop) -> Prop :=

(* First, we have the basic separation-logic rules from before.  The only change
 * is in the threading-through of parameter [linvs]. *)
| HtReturn : forall P {result : Set} (v : result),
    hoare_triple linvs P (Return v) (fun r => P * [| r = v |])%sep
| HtBind : forall P {result' result} (c1 : cmd result') (c2 : result' -> cmd result) Q R,
    hoare_triple linvs P c1 Q
    -> (forall r, hoare_triple linvs (Q r) (c2 r) R)
    -> hoare_triple linvs P (Bind c1 c2) R
| HtLoop : forall {acc : Set} (init : acc) (body : acc -> cmd (loop_outcome acc)) I,
    (forall acc, hoare_triple linvs (I (Again acc)) (body acc) I)
    -> hoare_triple linvs (I (Again init)) (Loop init body) (fun r => I (Done r))
| HtFail : forall {result},
    hoare_triple linvs [| False |]%sep (Fail (result := result)) (fun _ => [| False |])%sep
| HtRead : forall a R,
    hoare_triple linvs (exists v, a |-> v * R v)%sep (Read a) (fun r => a |-> r * R r)%sep
| HtWrite : forall a v',
    hoare_triple linvs (exists v, a |-> v)%sep (Write a v') (fun _ => a |-> v')%sep
| HtAlloc : forall numWords,
    hoare_triple linvs emp%sep (Alloc numWords) (fun r => r |--> zeroes numWords * [| r <> 0 |])%sep
| HtFree : forall a numWords,
    hoare_triple linvs (a |->? numWords)%sep (Free a numWords) (fun _ => emp)%sep

(* Next, how to handle locking: the thread takes ownership of a memory chunk
 * satisfying the lock's invariant. *)
| HtLock : forall a I,
    nth_error linvs a = Some I
    -> hoare_triple linvs emp%sep (Lock a) (fun _ => I)

(* When unlocking, the thread relinquishes ownership of a memory chunk
 * satisfying the lock's invariant. *)
| HtUnlock : forall a I,
    nth_error linvs a = Some I
    -> hoare_triple linvs I (Unlock a) (fun _ => emp)%sep

(* When forking into two threads, divide the (local) heap among them.
 * For simplicity, we never let parallel compositions terminate,
 * so it is appropriate to assign a contradictory overall postcondition. *)
| HtPar : forall P1 c1 Q1 P2 c2 Q2,
    hoare_triple linvs P1 c1 Q1
    -> hoare_triple linvs P2 c2 Q2
    -> hoare_triple linvs (P1 * P2)%sep (Par c1 c2) (fun _ => [| False |])%sep

(* Now we repeat these two structural rules from before. *)
| HtConsequence : forall {result} (c : cmd result) P Q (P' : hprop) (Q' : _ -> hprop),
    hoare_triple linvs P c Q
    -> P' ===> P
    -> (forall r, Q r ===> Q' r)
    -> hoare_triple linvs P' c Q'
| HtFrame : forall {result} (c : cmd result) P Q R,
    hoare_triple linvs P c Q
    -> hoare_triple linvs (P * R)%sep c (fun r => Q r * R)%sep.

Notation "linvs ||- {{ P }} c {{ r ~> Q }}" :=
  (hoare_triple linvs P%sep c (fun r => Q%sep)) (at level 90, c at next level).

Lemma HtStrengthen : forall linvs {result} (c : cmd result) P Q (Q' : _ -> hprop),
    hoare_triple linvs P c Q
    -> (forall r, Q r ===> Q' r)
    -> hoare_triple linvs P c Q'.
Proof.
  simplify.
  eapply HtConsequence; eauto.
  reflexivity.
Qed.

Lemma HtStrengthenFalse : forall linvs {result} (c : cmd result) P (Q' : _ -> hprop),
    hoare_triple linvs P c (fun _ => [| False |])%sep
    -> hoare_triple linvs P c Q'.
Proof.
  simplify.
  eapply HtStrengthen; eauto.
  simplify.
  unfold himp; simplify.
  cases H0.
  tauto.
Qed.

Lemma HtWeaken : forall linvs {result} (c : cmd result) P Q (P' : hprop),
    hoare_triple linvs P c Q
    -> P' ===> P
    -> hoare_triple linvs P' c Q.
Proof.
  simplify.
  eapply HtConsequence; eauto.
  reflexivity.
Qed.

(** * Examples *)

Opaque heq himp lift star exis ptsto.

(* Here comes some automation that we won't explain in detail, instead opting to
 * use examples.  Search for "nonzero" to skip ahead to the first one. *)

Theorem use_lemma : forall linvs result P' (c : cmd result) (Q : result -> hprop) P R,
  hoare_triple linvs P' c Q
  -> P ===> P' * R
  -> hoare_triple linvs P c (fun r => Q r * R)%sep.
Proof.
  simp.
  eapply HtWeaken.
  eapply HtFrame.
  eassumption.
  eauto.
Qed.

Theorem HtRead' : forall linvs a v,
  hoare_triple linvs (a |-> v)%sep (Read a) (fun r => a |-> v * [| r = v |])%sep.
Proof.
  simp.
  apply HtWeaken with (exists r, a |-> r * [| r = v |])%sep.
  eapply HtStrengthen.
  apply HtRead.
  simp.
  cancel; auto.
  subst; cancel.
Qed.

Theorem HtRead'' : forall linvs p P R,
  P ===> (exists v, p |-> v * R v)
  -> hoare_triple linvs P (Read p) (fun r => p |-> r * R r)%sep.
Proof.
  simp.
  eapply HtWeaken.
  apply HtRead.
  assumption.
Qed.

Lemma HtReturn' : forall linvs P {result : Set} (v : result) Q,
    P ===> Q v
    -> hoare_triple linvs P (Return v) Q.
Proof.
  simp.
  eapply HtStrengthen.
  constructor.
  simp.
  cancel.
  subst.
  assumption.
Qed.

Ltac basic := apply HtReturn' || eapply HtWrite || eapply HtAlloc || eapply HtFree
              || (eapply HtLock; simplify; solve [ eauto ])
              || (eapply HtUnlock; simplify; solve [ eauto ]).
Ltac step0 := basic || eapply HtBind || (eapply use_lemma; [ basic | cancel ])
              || (eapply use_lemma; [ eapply HtRead' | solve [ cancel ] ])
              || (eapply HtRead''; solve [ cancel ])
              || (eapply HtStrengthen; [ eapply use_lemma; [ basic | cancel ] | ])
              || (eapply HtConsequence; [ apply HtFail | .. ]).
Ltac step := step0; simp.
Ltac ht := simp; repeat step.
Ltac conseq := simplify; eapply HtConsequence.
Ltac use_IH H := conseq; [ apply H | .. ]; ht.
Ltac loop_inv0 Inv := (eapply HtWeaken; [ apply HtLoop with (I := Inv) | .. ])
                      || (eapply HtConsequence; [ apply HtLoop with (I := Inv) | .. ]).
Ltac loop_inv Inv := loop_inv0 Inv; ht.
Ltac fork0 P1 P2 := apply HtWeaken with (P := (P1 * P2)%sep); [ eapply HtPar | ].
Ltac fork P1 P2 := fork0 P1 P2 || (eapply HtStrengthenFalse; fork0 P1 P2).
Ltac use H := (eapply use_lemma; [ eapply H | cancel ])
              || (eapply HtStrengthen; [ eapply use_lemma; [ eapply H | cancel ] | ]).

Ltac heq := intros; apply himp_heq; split.

(* Fancy theorem to help us rewrite within preconditions and postconditions *)
Local Instance hoare_triple_morphism : forall linvs A,
  Proper (heq ==> eq ==> (eq ==> heq) ==> iff) (@hoare_triple linvs A).
Proof.
  Transparent himp.
  repeat (hnf; intros).
  unfold pointwise_relation in *; intuition subst.

  eapply HtConsequence; eauto.
  rewrite H; reflexivity.
  intros.
  hnf in H1.
  specialize (H1 r _ eq_refl).
  rewrite H1; reflexivity.

  eapply HtConsequence; eauto.
  rewrite H; reflexivity.
  intros.
  hnf in H1.
  specialize (H1 r _ eq_refl).
  rewrite H1; reflexivity.
  Opaque himp.
Qed.

Theorem try_ptsto_first : forall a v, try_me_first (ptsto a v).
Proof.
  simplify.
  apply try_me_first_easy.
Qed.

Local Hint Resolve try_ptsto_first : core.

(** ** The nonzero shared counter *)

(* This program has two threads sharing a numeric counter, which starts out as
 * nonzero and remains that way, since each thread only increments the counter,
 * with the lock held to avoid race conditions. *)

Example incrementer :=
  for i := tt loop
    _ <- Lock 0;
    n <- Read 0;
    _ <- Write 0 (n + 1);
    _ <- Unlock 0;
    if n ==n 0 then
      Fail
    else
      Return (Again tt)
  done.

Definition incrementer_inv := emp%sep.

Theorem incrementers_ok :
    [incrementer_inv] ||- {{emp}} incrementer || incrementer {{_ ~> emp}}.
Proof.
  unfold incrementer, incrementer_inv.
Admitted.

Fixpoint incrementers (n : nat) :=
  match n with
  | O => incrementer
  | S n' => incrementers n' || incrementers n'
  end.

Theorem any_incrementers_ok : forall n,
    [incrementer_inv] ||- {{emp}} incrementers n {{_ ~> emp}}.
Proof.
Admitted.

(** ** Producer-consumer with a linked list *)

(* First, here's a literal repetition of the definition of linked lists from
 * SeparationLogic.v. *)

Fixpoint linkedList (p : nat) (ls : list nat) :=
  match ls with
    | nil => [| p = 0 |]
    | x :: ls' => [| p <> 0 |]
                  * exists p', p |--> [x; p'] * linkedList p' ls'
  end%sep.

Theorem linkedList_null : forall ls,
  linkedList 0 ls === [| ls = nil |].
Proof.
  heq; cases ls; cancel.
Qed.

Theorem linkedList_nonnull : forall p ls,
  p <> 0
  -> linkedList p ls === exists x ls' p', [| ls = x :: ls' |] * p |--> [x; p'] * linkedList p' ls'.
Proof.
  heq; cases ls; cancel; match goal with
                         | [ H : _ = _ :: _ |- _ ] => invert H
                         end; cancel.
Qed.

(* Now let's use linked lists as shared stacks for communication between
 * threads, with a lock protecting each stack.  To start out with, here's a
 * producer-consumer example with just one stack.  The producer is looping
 * pushing the consecutive even numbers to the stack, and the consumer is
 * looping popping numbers and failing if they're odd. *)

Example producer :=
  _ <- for i := 0 loop
    cell <- Alloc 2;
    _ <- Write cell i;
    _ <- Lock 0;
    head <- Read 0;
    _ <- Write (cell+1) head;
    _ <- Write 0 cell;
    _ <- Unlock 0;
    Return (Again (2 + i))
  done;
  Return tt.

Fixpoint isEven (n : nat) : bool :=
  match n with
  | O => true
  | S (S n) => isEven n
  | _ => false
  end.

Example consumer :=
  for i := tt loop
    _ <- Lock 0;
    head <- Read 0;
    if head ==n 0 then
      _ <- Unlock 0;
      Return (Again tt)
    else
      tail <- Read (head+1);
      _ <- Write 0 tail;
      _ <- Unlock 0;
      data <- Read head;
      _ <- Free head 2;
      if isEven data then
        Return (Again tt)
      else
        Fail
  done.

Definition producer_consumer_inv := emp%sep.

Theorem producer_consumer_ok :
  [producer_consumer_inv] ||- {{emp}} producer || consumer {{_ ~> emp}}.
Proof.
  unfold producer_consumer_inv, producer, consumer.
Admitted.

(** ** A length-3 producer-consumer chain *)

(* Here's a variant on the last example.  Now we have three stages.
 * Stage 1: push consecutive even numbers to stack 1.
 * Stage 2: pop from stack 1 and push to stack 1, reusing the memory for the
 *          list node.
 * Stage 3: pop from stack 2 and fail if odd. *)

Example stage1 :=
  _ <- for i := 0 loop
    cell <- Alloc 2;
    _ <- Write cell i;
    _ <- Lock 0;
    head <- Read 0;
    _ <- Write (cell+1) head;
    _ <- Write 0 cell;
    _ <- Unlock 0;
    Return (Again (2 + i))
  done;
  Return tt.

Example stage2 :=
  for i := tt loop
    _ <- Lock 0;
    head <- Read 0;
    if head ==n 0 then
      _ <- Unlock 0;
      Return (Again tt)
    else
      tail <- Read (head+1);
      _ <- Write 0 tail;
      _ <- Unlock 0;

      _ <- Lock 1;
      head' <- Read 1;
      _ <- Write (head+1) head';
      _ <- Write 1 head;
      _ <- Unlock 1;

      Return (Again tt)
  done.

Example stage3 :=
  for i := tt loop
    _ <- Lock 1;
    head <- Read 1;
    if head ==n 0 then
      _ <- Unlock 1;
      Return (Again tt)
    else
      tail <- Read (head+1);
      _ <- Write 1 tail;
      _ <- Unlock 1;
      data <- Read head;
      _ <- Free head 2;
      if isEven data then
        Return (Again tt)
      else
        Fail
  done.

(* Same invariant as before, for each of the two stacks. *)
Definition stages_inv root :=
  (exists ls p, root |-> p * linkedList p ls * [| forallb isEven ls = true |])%sep.

Theorem stages_ok :
  [stages_inv 0; stages_inv 1] ||- {{emp}} stage1 || stage2 || stage3 {{_ ~> emp}}.
Proof.
  unfold stages_inv, stage1, stage2, stage3.
  fork (emp%sep) (emp%sep); ht.
  fork (emp%sep) (emp%sep); ht.

  loop_inv (fun o => [| isEven (valueOf o) = true |]%sep).
  match goal with
  | [ H : r = 0 -> False |- _ ] => erewrite (linkedList_nonnull _ H)
  end.
  cancel.
  simp.
  apply andb_true_iff; propositional.
  cancel.
  cancel.
  cancel.

  loop_inv (fun _ : loop_outcome unit => emp%sep).
  simp.
  cases (r0 ==n 0).
  ht.
  cancel.
  setoid_rewrite (linkedList_nonnull _ n).
  ht.
  apply andb_true_iff in H.
  simp.
  erewrite (linkedList_nonnull _ n).
  cancel.
  simp.
  apply andb_true_iff in H1.
  apply andb_true_iff.
  simp.
  cancel.
  cancel.
  cancel.

  loop_inv (fun _ : loop_outcome unit => emp%sep).
  simp.
  cases (r0 ==n 0).
  ht.
  cancel.
  setoid_rewrite (linkedList_nonnull _ n).
  ht.
  apply andb_true_iff in H.
  simp.
  simp.
  cases (isEven r4); ht.
  cancel.
  cancel.
  simp.
  rewrite Heq in H0.
  simp.
  try equality.
  cancel.
  cancel.
  cancel.
Qed.

(** * Soundness proof *)

Local Hint Resolve himp_refl : core.

Lemma invert_Return : forall linvs {result : Set} (r : result) P Q,
  hoare_triple linvs P (Return r) Q
  -> P ===> Q r.
Proof.
  induct 1; propositional; eauto.

  cancel.

  eauto using himp_trans.

  rewrite IHhoare_triple; eauto.
Qed.

Local Hint Constructors hoare_triple : core.

Lemma invert_Bind : forall linvs {result' result} (c1 : cmd result') (c2 : result' -> cmd result) P Q,
  hoare_triple linvs P (Bind c1 c2) Q
  -> exists R, hoare_triple linvs P c1 R
               /\ forall r, hoare_triple linvs (R r) (c2 r) Q.
Proof.
  induct 1; propositional; eauto.

  invert IHhoare_triple; propositional.
  eexists; propositional.
  eapply HtWeaken.
  eassumption.
  auto.
  eapply HtStrengthen.
  apply H4.
  auto.

  simp.
  exists (fun r => x r * R)%sep.
  propositional.
  eapply HtFrame; eauto.
  eapply HtFrame; eauto.
Qed.

Transparent heq himp lift star exis ptsto.

Lemma invert_Loop : forall linvs {acc : Set} (init : acc) (body : acc -> cmd (loop_outcome acc)) P Q,
    hoare_triple linvs P (Loop init body) Q
    -> exists I, (forall acc, hoare_triple linvs (I (Again acc)) (body acc) I)
                 /\ P ===> I (Again init)
                 /\ (forall r, I (Done r) ===> Q r).
Proof.
  induct 1; propositional; eauto.

  invert IHhoare_triple; propositional.
  exists x; propositional; eauto.
  unfold himp in *; eauto.

  eauto using himp_trans.

  simp.
  exists (fun o => x o * R)%sep; propositional; eauto.
  rewrite H0; eauto.
  rewrite H3; eauto.
Qed.

Opaque heq himp lift star exis ptsto.

Lemma unit_not_nat : unit = nat -> False.
Proof.
  simplify.
  assert (exists x : unit, forall y : unit, x = y).
  exists tt; simplify.
  cases y; reflexivity.
  rewrite H in H0.
  invert H0.
  specialize (H1 (S x)).
  linear_arithmetic.
Qed.

Lemma invert_Read : forall linvs a P Q,
  hoare_triple linvs P (Read a) Q
  -> exists R, (P ===> exists v, a |-> v * R v)%sep
               /\ forall r, a |-> r * R r ===> Q r.
Proof.
  induct 1; simp; eauto.

  apply unit_not_nat in x0; simp.

  apply unit_not_nat in x0; simp.

  apply unit_not_nat in x0; simp.

  apply unit_not_nat in x0; simp.

  apply unit_not_nat in x0; simp.

  eauto 7 using himp_trans.

  exists (fun n => x n * R)%sep; simp.
  rewrite H1.
  cancel.

  rewrite <- H2.
  cancel.
Qed.

Lemma invert_Write : forall linvs a v' P Q,
  hoare_triple linvs P (Write a v') Q
  -> exists R, (P ===> (exists v, a |-> v) * R)%sep
               /\ a |-> v' * R ===> Q tt.
Proof.
  induct 1; simp; eauto.

  symmetry in x0.
  apply unit_not_nat in x0; simp.

  exists emp; simp.
  cancel; auto.
  cancel; auto.

  symmetry in x0.
  apply unit_not_nat in x0; simp.

  eauto 7 using himp_trans.

  exists (x * R)%sep; simp.
  rewrite H1.
  cancel.

  cancel.
  rewrite <- H2.
  cancel.
Qed.

Lemma invert_Alloc : forall linvs numWords P Q,
  hoare_triple linvs P (Alloc numWords) Q
  -> forall r, P * r |--> zeroes numWords * [| r <> 0 |] ===> Q r.
Proof.
  induct 1; simp; eauto.

  apply unit_not_nat in x0; simp.

  cancel.

  apply unit_not_nat in x0; simp.

  apply unit_not_nat in x0; simp.

  apply unit_not_nat in x0; simp.

  apply unit_not_nat in x0; simp.

  rewrite H0; eauto.
  eauto 7 using himp_trans.

  rewrite <- IHhoare_triple.
  cancel.
Qed.

Transparent heq himp lift star exis ptsto.

Lemma zeroes_initialize' : forall h a v,
    h $? a = None
    -> (fun h' : heap => h' = h $+ (a, v)) ===> (fun h' => h' = h) * a |-> v.
Proof.
  unfold himp, star, split, ptsto, disjoint; simp.
  exists h, (heap1 a v).
  propositional.
  maps_equal.
  unfold heap1.
  rewrite lookup_join2.
  simp.
  simp.
  apply lookup_None_dom in H.
  propositional.
  cases (h $? k).
  rewrite lookup_join1; auto.
  eauto using lookup_Some_dom.
  rewrite lookup_join2; auto.
  unfold heap1; simp.
  eauto using lookup_None_dom.
  unfold heap1 in *.
  cases (a ==n a0); simp.
Qed.

Opaque heq himp lift star exis ptsto.

Lemma multi_ptsto_app : forall ls2 ls1 a,
     a |--> ls1 * (a + length ls1) |--> ls2 ===> a |--> (ls1 ++ ls2).
Proof.
  induct ls1; simp; cancel; auto.

  replace (a + 0) with a by linear_arithmetic.
  cancel.

  rewrite <- IHls1.
  cancel.
  replace (a0 + 1 + length ls1) with (a0 + S (length ls1)) by linear_arithmetic.
  cancel.
Qed.

Lemma length_zeroes : forall n,
    length (zeroes n) = n.
Proof.
  induct n; simplify; auto.
  rewrite app_length; simplify.
  linear_arithmetic.
Qed.

Lemma initialize_fresh : forall a' h a numWords,
    a' >= a + numWords
    -> initialize h a numWords $? a' = h $? a'.
Proof.
  induct numWords; simp; auto.
Qed.

Lemma zeroes_initialize : forall numWords a h,
    (forall i, i < numWords -> h $? (a + i) = None)
    -> (fun h' => h' = initialize h a numWords) ===> (fun h' => h' = h) * a |--> zeroes numWords.
Proof.
  induct numWords; simp.

  cancel; auto.
  rewrite <- multi_ptsto_app.
  rewrite zeroes_initialize'.
  erewrite IHnumWords.
  simp.
  rewrite length_zeroes.
  cancel; auto.
  auto.
  rewrite initialize_fresh; auto.
Qed.

Lemma invert_Free : forall linvs a numWords P Q,
  hoare_triple linvs P (Free a numWords) Q
  -> P ===> a |->? numWords * Q tt.
Proof.
  induct 1; simp; eauto.

  symmetry in x0.
  apply unit_not_nat in x0; simp.

  symmetry in x0.
  apply unit_not_nat in x0; simp.

  cancel; auto.

  rewrite H0.
  rewrite IHhoare_triple.
  cancel; auto.

  rewrite IHhoare_triple.
  cancel; auto.
Qed.

Transparent heq himp lift star exis ptsto.

Lemma do_deallocate' : forall a Q h,
    ((exists v, a |-> v) * Q)%sep h
    -> Q (h $- a).
Proof.
  unfold ptsto, star, split, heap1; simp.
  invert H1.
  replace ($0 $+ (a, x1) $++ x0 $- a) with x0; auto.
  maps_equal.
  cases (k ==n a); simp.
  specialize (H a).
  simp.
  cases (x0 $? a); auto.
  exfalso; apply H; equality.
  rewrite lookup_join2; auto.
  apply lookup_None_dom.
  simp.
Qed.

Lemma do_deallocate : forall Q numWords a h,
    (a |->? numWords * Q)%sep h
    -> Q (deallocate h a numWords).
Proof.
  induct numWords; simp.

  unfold star, exis, lift in H; simp.
  apply split_empty_fwd' in H0; simp.

  apply IHnumWords.
  clear IHnumWords.

  apply do_deallocate'.
  Opaque heq himp lift star exis ptsto.
  match goal with
  | [ H : ?P h |- ?Q h ] => assert (P ===> Q) by cancel
  end.
  Transparent himp.
  apply H0; auto.
  Opaque himp.
Qed.

Opaque heq himp lift star exis ptsto.

Lemma invert_Lock : forall linvs a P Q,
  hoare_triple linvs P (Lock a) Q
  -> exists I, nth_error linvs a = Some I
               /\ P * I ===> Q tt.
Proof.
  induct 1; simp; eauto 10.

  symmetry in x0.
  apply unit_not_nat in x0; simp.

  symmetry in x0.
  apply unit_not_nat in x0; simp.

  eexists; simp.
  eauto.
  cancel.

  eexists; simp.
  eauto.
  rewrite H0; eauto using himp_trans.

  eexists; simp.
  eauto.
  rewrite <- H2.
  cancel.
Qed.

Lemma invert_Unlock : forall linvs a P Q,
  hoare_triple linvs P (Unlock a) Q
  -> exists I, nth_error linvs a = Some I
               /\ P ===> Q tt * I.
Proof.
  induct 1; simp; eauto 10.

  symmetry in x0.
  apply unit_not_nat in x0; simp.

  symmetry in x0.
  apply unit_not_nat in x0; simp.

  eexists; simp.
  eauto.
  cancel.

  eexists; simp.
  eauto.
  rewrite <- H1; eauto using himp_trans.

  eexists; simp.
  eauto.
  rewrite H2.
  cancel.
Qed.

Lemma invert_Par : forall linvs c1 c2 P Q,
  hoare_triple linvs P (Par c1 c2) Q
  -> exists P1 P2 Q1 Q2,
      hoare_triple linvs P1 c1 Q1
      /\ hoare_triple linvs P2 c2 Q2
      /\ P ===> P1 * P2.
Proof.
  induct 1; simp; eauto 7.

  symmetry in x0.
  apply unit_not_nat in x0; simp.

  symmetry in x0.
  apply unit_not_nat in x0; simp.

  eauto 8 using himp_trans.

  exists (x * R)%sep, x0, (fun r => x1 r * R)%sep, x2; simp; eauto.
  rewrite H3; cancel.
Qed.

Transparent heq himp lift star exis ptsto.

Definition guarded (P : Prop) (p : hprop) : hprop :=
  fun h => IFF P then p h else emp%sep h.

Infix "===>" := guarded : sep_scope.

Theorem guarded_true : forall (P : Prop) p, P
  -> (P ===> p) === p.
Proof.
  unfold heq, guarded, IF_then_else; simp.
Qed.

Theorem guarded_false : forall (P : Prop) p, ~P
  -> (P ===> p) === emp.
Proof.
  unfold heq, guarded, IF_then_else; simp.
Qed.

Fixpoint bigstar A (P : nat -> A -> hprop) (ls : list A) : hprop :=
  match ls with
  | nil => emp
  | x :: ls' => P 0 x * bigstar (fun n => P (S n)) ls'
  end%sep.

Definition lockChunks (l : locks) (ls : list hprop) :=
  bigstar (fun i I => (~i \in l) ===> I)%sep ls.

Lemma use_himp : forall P Q, P ===> Q
  -> forall h, P h -> Q h.
Proof.
  auto.
Qed.

Lemma ptsto_out : forall h a v p,
    h $? a = Some v
    -> (exists v', a |-> v' * p v')%sep h
    -> (a |-> v * p v)%sep h
       /\ forall v', (a |-> v' * p v)%sep (h $+ (a, v')).
Proof.
  invert 2.
  invert H1.
  simp.

  invert H2.
  unfold split in H0; subst.
  rewrite lookup_join1 in H.
  unfold heap1 in H.
  simplify.
  invert H.
  exists (heap1 a v), x1; simp.
  eauto.
  unfold ptsto.
  eauto.
  unfold heap1; simplify.
  sets.

  invert H2.
  unfold split in H0; subst.
  rewrite lookup_join1 in H.
  unfold heap1 in H.
  simplify.
  invert H.
  exists (heap1 a v'), x1; simp.
  unfold split.
  maps_equal.
  rewrite lookup_join1.
  unfold heap1; simplify; auto.
  unfold heap1; simplify; sets.
  repeat rewrite lookup_join2; auto.
  unfold heap1; simplify; sets.
  unfold heap1; simplify; sets.
  unfold disjoint in *; simp.
  apply (H1 a0); eauto.
  cases (a ==n a0); simp.
  unfold heap1 in *; simplify; equality.
  unfold heap1 in *; simplify; equality.
  unfold ptsto.
  eauto.
  unfold heap1; simplify; sets.
Qed.

Lemma specialize_hprop : forall (p : hprop) h,
    p h
    -> (fun h' => h' = h) ===> p.
Proof.
  unfold himp; equality.
Qed.

Opaque heq himp lift star exis ptsto.

Lemma bigstar_impl : forall A ls (p q : nat -> A -> hprop),
    (forall i x, p i x ===> q i x)
    -> bigstar p ls ===> bigstar q ls.
Proof.
  induct ls; simplify; auto.
  rewrite H.
  rewrite IHls.
  cancel.
  simp.
  eauto.
Qed.

Lemma guarded_impl : forall P Q p,
    (P <-> Q)
    -> (P ===> p) ===> (Q ===> p).
Proof.
  simp.
  excluded_middle P.
  repeat rewrite guarded_true by propositional.
  auto.
  repeat rewrite guarded_false by propositional.
  auto.
Qed.

Lemma lockChunks_lock' : forall l I linvs (f : nat -> nat) a,
    ~f a \in l
    -> nth_error linvs a = Some I
    -> (forall x y, f x = f y -> x = y)
    -> bigstar (fun i I => (~f i \in l) ===> I)%sep linvs ===> I * bigstar (fun i I => (~(f i \in {f a} \cup l)) ===> I)%sep linvs.
Proof.
  induct linvs; simplify.

  cases a; simplify; try unfold error in *; equality.

  cases a0; simplify.
  invert H0.
  rewrite guarded_true by sets.
  rewrite guarded_false by sets.
  cancel.
  apply bigstar_impl.
  simp.
  apply guarded_impl.
  sets.
  apply H1 in H2.
  equality.

  apply (IHlinvs (fun n => f (S n))) in H0; auto.
  rewrite H0.
  cancel.
  apply guarded_impl.
  sets.
  apply H1 in H3.
  equality.
  simp.
  apply H1 in H2.
  equality.
Qed.

Lemma lockChunks_lock : forall a l I linvs,
    ~a \in l
    -> nth_error linvs a = Some I
    -> lockChunks l linvs ===> I * lockChunks ({a} \cup l) linvs.
Proof.
  simp.
  apply lockChunks_lock' with (f := fun n => n); auto.
Qed.

Lemma lockChunks_unlock' : forall l I linvs (f : nat -> nat) a,
    f a \in l
    -> nth_error linvs a = Some I
    -> (forall x y, f x = f y -> x = y)
    -> I * bigstar (fun i I => (~f i \in l) ===> I)%sep linvs ===> bigstar (fun i I => (~(f i \in l \setminus {f a})) ===> I)%sep linvs.
Proof.
  induct linvs; simplify.

  cases a; simplify; try unfold error in *; equality.

  cases a0; simplify.
  invert H0.
  rewrite guarded_false by sets.
  rewrite guarded_true by sets.
  cancel.
  apply bigstar_impl.
  simp.
  apply guarded_impl.
  sets.
  apply H0; propositional.
  apply H1 in H4.
  equality.

  apply (IHlinvs (fun n => f (S n))) in H0; auto.
  rewrite <- H0.
  cancel.
  apply guarded_impl.
  sets.
  apply H2; propositional.
  apply H1 in H5.
  equality.
  simp.
  apply H1 in H2.
  equality.
Qed.

Lemma lockChunks_unlock : forall a l I linvs,
    a \in l
    -> nth_error linvs a = Some I
    -> I * lockChunks l linvs ===> lockChunks (l \setminus {a}) linvs.
Proof.
  simp.
  apply lockChunks_unlock' with (f := fun n => n); auto.
Qed.

Lemma preservation : forall linvs {result} (c : cmd result) h l c' h' l',
    step (h, l, c) (h', l', c')
    -> forall P Q R, hoare_triple linvs P c Q
                     -> (P * R * lockChunks l linvs)%sep h
                     -> exists P', hoare_triple linvs P' c' Q
                                   /\ (P' * R * lockChunks l' linvs)%sep h'.
Proof.
  induct 1; simplify.

  apply invert_Bind in H0; simp.
  eapply IHstep in H0; eauto.
  simp.
  eauto.

  apply invert_Bind in H; simp.
  specialize (invert_Return H); eauto using HtWeaken.

  apply invert_Loop in H; simp.
  eexists; simp.
  econstructor.
  eauto.
  simp.
  cases r.
  apply HtReturn'.
  auto.
  eapply HtStrengthen.
  eauto.
  eauto.
  eapply use_himp; try eassumption.
  rewrite H1.
  eauto.

  apply invert_Read in H0; simp.
  assert ((exists v, a |-> v * (x v * R * lockChunks l' linvs))%sep h').
  eapply use_himp; try eassumption.
  rewrite H0.
  cancel.
  eapply ptsto_out in H2; eauto.
  eexists; simp.
  apply HtReturn'.
  eauto.
  eapply use_himp; try eassumption.
  cancel.

  apply invert_Write in H0; simp.
  assert ((exists v, a |-> v * (x * R * lockChunks l' linvs))%sep h).
  eapply use_himp; try eassumption.
  rewrite H0.
  cancel.
  eapply ptsto_out in H2; eauto.
  propositional.
  eexists; simp.
  apply HtReturn'.
  eauto.
  eapply use_himp; try apply H5.
  cancel.

  apply invert_Alloc with (r := a) in H1.
  eexists; propositional.
  apply HtReturn'.
  eassumption.
  apply use_himp with ((P * R * lockChunks l' linvs) * a |--> zeroes numWords)%sep.
  cancel.
  apply use_himp with ((fun h' => h' = h) * a |--> zeroes numWords)%sep.
  cancel.
  eauto using specialize_hprop.
  eapply use_himp.
  apply zeroes_initialize; auto.
  simp.

  apply invert_Free in H.
  eexists; propositional.
  instantiate (1 := Q tt).
  apply HtReturn'.
  auto.
  apply do_deallocate; simplify.
  change (fun f => (Q tt * lockChunks l' linvs) f)%sep with (Q tt * lockChunks l' linvs)%sep.
  eapply use_himp; try eassumption.
  rewrite H.
  cancel.

  apply invert_Lock in H0.
  simp.
  eexists; propositional.
  apply HtReturn'; auto.
  eapply use_himp; try eassumption.
  rewrite <- H3.
  cancel.
  apply lockChunks_lock; auto.

  apply invert_Unlock in H0.
  simp.
  eexists; propositional.
  apply HtReturn'; auto.
  eapply use_himp; try eassumption.
  rewrite H3.
  cancel.
  rewrite <- lockChunks_unlock; eauto.
  cancel.

  apply invert_Par in H0.
  simp.
  eapply IHstep in H2.
  simp.
  eexists; propositional.
  apply HtStrengthenFalse.
  econstructor.
  eassumption.
  eassumption.
  eapply use_himp; try eassumption.
  cancel.
  eapply use_himp; try eassumption.
  cancel.

  apply invert_Par in H0.
  simp.
  eapply IHstep in H0.
  simp.
  eexists; propositional.
  apply HtStrengthenFalse.
  econstructor.
  eassumption.
  eassumption.
  eapply use_himp; try eassumption.
  cancel.
  eapply use_himp; try eassumption.
  rewrite H4.
  cancel.
Qed.

Definition allLockChunks (linvs : list hprop) := bigstar (fun _ I => I) linvs.

Lemma allLockChunks_lockChunks' : forall linvs (f : nat -> nat),
   bigstar (fun _ I => I) linvs ===> bigstar (fun i I => (~f i \in {}) ===> I) linvs.
Proof.
  induct linvs; simp; auto.

  rewrite guarded_true by sets.
  rewrite IHlinvs.
  cancel.
Qed.

Lemma allLockChunks_lockChunks : forall linvs,
    allLockChunks linvs ===> lockChunks {} linvs.
Proof.
  simp.
  apply allLockChunks_lockChunks' with (f := fun n => n).
Qed.

Lemma hoare_triple_sound' : forall linvs P {result} (c : cmd result) Q,
    hoare_triple linvs P c Q
    -> forall h, (P * allLockChunks linvs)%sep h
    -> invariantFor (trsys_of h {} c)
                    (fun p =>
                       let '(h, l, c) := p in
                       exists P', hoare_triple linvs P' c Q
                                  /\ (P' * lockChunks l linvs)%sep h).
Proof.
  simplify.

  apply invariant_induction; simplify.

  propositional; subst; simplify.
  eexists; propositional.
  eauto.
  eapply use_himp; try eassumption.
  rewrite allLockChunks_lockChunks.
  auto.

  cases s.
  cases p.
  cases s'.
  cases p.
  simp.
  eapply preservation with (R := emp%sep) in H1; eauto.
  simp.
  eexists; propositional; eauto.
  eapply use_himp; try eassumption.
  cancel.
  eapply use_himp; try eassumption.
  cancel.
Qed.

Fixpoint notAboutToFail {result} (c : cmd result) :=
  match c with
  | Fail _ => false
  | Bind _ _ c1 _ => notAboutToFail c1
  | Par c1 c2 => notAboutToFail c1 && notAboutToFail c2
  | _ => true
  end.

Lemma hoare_triple_notAboutToFail : forall linvs P result (c : cmd result) Q,
    hoare_triple linvs P c Q
    -> notAboutToFail c = false
    -> P ===> [| False |].
Proof.
  induct 1; simp; try equality; eauto using himp_trans.

  apply andb_false_iff in H1; propositional.
  rewrite H1; cancel.
  rewrite H1; cancel.

  rewrite H1; cancel.
Qed.

Lemma False_star : forall p,
    [| False |] * p ===> [| False |].
Proof.
  cancel.
Qed.

Theorem hoare_triple_sound : forall linvs P {result} (c : cmd result) Q,
    hoare_triple linvs P c Q
    -> forall h, (P * allLockChunks linvs)%sep h
    -> invariantFor (trsys_of h {} c)
                    (fun p => let '(_, _, c) := p in
                              notAboutToFail c = true).
Proof.
  simplify.

  eapply invariant_weaken.
  eapply hoare_triple_sound'; eauto.
  simp.
  cases s.
  cases p.
  simp.
  cases (notAboutToFail c0); auto.
  eapply hoare_triple_notAboutToFail in Heq; eauto.
  assert ([| False |]%sep f).
  apply use_himp with (x * lockChunks s linvs)%sep.
  rewrite Heq.
  apply False_star.
  assumption.
  invert H2; propositional.
Qed.


(* This file is automatically generated from the OCaml source file
<repository_root>/ml_sources/examples/crdt/oplib/examples/remove_wins_set/remove_wins_set_code.ml *)

From aneris.aneris_lang Require Import ast.
From aneris.aneris_lang.lib Require Import list_code.
From aneris.aneris_lang.lib.vector_clock Require Import vector_clock_code.
From aneris.aneris_lang.lib.serialization Require Import serialization_code.
From aneris.examples.crdt.oplib Require Import oplib_code.

Definition init_st : val := λ: <>, ([], []).

Definition effect_remove_op : val :=
  λ: "v" "vc" "st",
  let: "contents" := Fst "st" in
  let: "removes" := Snd "st" in
  let: "updated_removes" := ("v", "vc") :: "removes" in
  let: "should_keep_in_contents" := λ: "p",
  (if: (Fst "p") = "v"
   then  let: "vc'" := Snd "p" in
         vect_leq "vc" "vc'"
   else  #true) in
  let: "updated_contents" := list_filter "should_keep_in_contents" "contents" in
  ("updated_contents", "updated_removes").

Definition effect_add_op : val :=
  λ: "v" "vc" "st",
  let: "contents" := Fst "st" in
  let: "removes" := Snd "st" in
  let: "permits_add" := λ: "r",
  (if: (Fst "r") = "v"
   then  let: "vc'" := Snd "r" in
         vect_leq "vc'" "vc"
   else  #true) in
  let: "should_add" := list_fold (λ: "p" "r", "p" && ("permits_add" "r"))
                       #true "removes" in
  let: "updated_contents" := (if: "should_add"
   then  ("v", "vc") :: "contents"
   else  "contents") in
  ("updated_contents", "removes").

Definition effect : val :=
  λ: "msg" "st",
  let: "v" := Fst (Fst "msg") in
  let: "vc" := Snd (Fst "msg") in
  let: "_u" := Snd "msg" in
  match: "v" with
    InjL "w" => effect_add_op "w" "vc" "st"
  | InjR "w" => effect_remove_op "w" "vc" "st"
  end.

Definition rws_crdt : val := λ: <>, (init_st, effect).

Definition rws_init val_ser val_deser : val :=
  λ: "addrs" "rid",
  let: "initRes" := oplib_init (sum_ser val_ser val_ser)
                    (sum_deser val_deser val_deser) "addrs" "rid" rws_crdt in
  let: "get_state" := Fst "initRes" in
  let: "update" := Snd "initRes" in
  ("get_state", "update").


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C G Aprime Aprimeprime Bprime Cprime Bprimeprime Bprimeprimeprime : Universe, ((wd_ Aprime Bprimeprime /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Bprime A /\ (wd_ Bprime C /\ (wd_ Aprime B /\ (wd_ Aprime C /\ (wd_ Cprime A /\ (wd_ Cprime B /\ (wd_ Aprimeprime Bprimeprime /\ (wd_ Aprime Bprimeprimeprime /\ (wd_ Aprime Bprime /\ (wd_ Bprime Bprimeprimeprime /\ (wd_ G Aprime /\ (wd_ G Aprimeprime /\ (wd_ G Bprimeprime /\ (wd_ Bprimeprime Bprimeprimeprime /\ (wd_ G Bprimeprimeprime /\ (wd_ Aprime Aprimeprime /\ (wd_ B G /\ (wd_ Bprimeprime B /\ (wd_ A G /\ (wd_ Aprimeprime A /\ (col_ Aprime Bprime Bprimeprimeprime /\ (col_ Aprime Bprimeprime Aprime /\ (col_ G Aprimeprime Aprime /\ (col_ G Bprimeprime Bprimeprimeprime /\ (col_ Bprimeprime B G /\ (col_ Cprime A B /\ (col_ Bprime A C /\ (col_ Aprimeprime A G /\ (col_ Aprime B C /\ col_ A B G))))))))))))))))))))))))))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.