From Coq Require Import
     Arith.PeanoNat
     Lists.List
     Lists.ListSet
     Morphisms
     NArith.NArith
     Numbers.DecimalString
     RelationClasses
     Setoid
     Strings.BinaryString
     Strings.HexString
     Strings.String
     Vectors.Fin
     ZArith.ZArith.

Import StringSyntax.

From ExtLib Require Import
     Core.RelDec
     Data.Map.FMapAList
     Data.Monads.ListMonad
     Structures.Maps
     Structures.Monads.

From bbv Require Import Word.
Import Word.Notations.

From ITree Require Import
     Events.MapDefault
     Events.Nondeterminism
     Events.StateFacts
     ITree
     ITreeFacts.

Import ITreeNotations.
Import ListNotations.
Import MonadNotation.
Import Monads.

Local Open Scope list.
Local Open Scope itree_scope.
(* Local Open Scope string. *)
(* Local Open Scope monad_scope. *)

(* The [sum1] types with automatic application of commutativity and
   associativity are prone to infinite instance resolution loops.
   This bounds the instance search depth: *)
Typeclasses eauto := 5.

Require Import Decision.

Infix "--->" := implb (at level 51, right associativity) : bool_scope.

Definition newline : string := "
".

Section Showable.
  Class Showable A := { show : A -> string }.

  Local Open Scope string_scope.

  #[global] Instance showable_uint : Showable Decimal.uint :=
    { show := NilEmpty.string_of_uint }.

  #[global] Instance showable_nat : Showable nat :=
    { show := fun n => show (Nat.to_uint n) }.

  Variant hex_nat := Hex : nat -> hex_nat.

  #[global] Instance showable_hex_nat : Showable hex_nat :=
    { show := fun '(Hex n) => HexString.of_nat n }.

  #[global] Instance showable_int : Showable Decimal.int :=
    { show := NilEmpty.string_of_int }.

  #[global] Instance showable_Z : Showable Z :=
    { show := fun z => NilEmpty.string_of_int (Z.to_int z)%Z }.

  #[global] Instance showable_word : forall sz, Showable (word sz) :=
    { show := fun w => HexString.of_N (wordToN w) }.

  #[global] Instance showable_list : forall T, Showable T -> Showable (list T) :=
    { show := fun ts =>
                "[" ++ String.concat "; " (List.map show ts) ++ "]"
    }.
End Showable.

Variant debugE : Type -> Type :=
| Debug : string -> debugE unit.

Section List.
  Fixpoint list_forall_suffixb {T} (f : list T -> bool) (l : list T) : bool :=
    f l && match l with
           | nil => true
           | _::l => list_forall_suffixb f l
           end.

  Fixpoint list_replace_nth {T} (n : nat) (x : T) (l : list T) : list T :=
    match n, l with
    | O, _::t => x::t
    | S n, h::t => h::list_replace_nth n x t
    | _, _ => nil
    end.

  Fixpoint list_remove_nth {T} (n : nat) (l : list T) : list T :=
    match n, l with
    | O, _::t => t
    | S n, h::t => h::list_remove_nth n t
    | _, _ => nil
    end.

  Fixpoint list_nth {A} (l : list A) (f : Fin.t (List.length l)) : A :=
  match l return Fin.t (List.length l) -> A with
  | [] => Fin.case0 _ (* unreachable *)
  | h::tl => fun f =>
    match f in Fin.t (S n) return List.length tl = n -> A with
    | F1 => fun _ => h
    | FS fs => fun pf => list_nth tl (eq_rect_r Fin.t fs pf)
    end eq_refl
  end f.

  Fixpoint list_find_index {A} (l : list A) (p : A -> bool) : option (Fin.t (List.length l)) :=
    match l with
    | [] => None
    | h::tl =>
      if p h then Some F1
      else match list_find_index tl p with
           | Some f => Some (FS f)
           | None => None
           end
    end.

  Example list_find_index_0 :
    option_map (fun f => proj1_sig (Fin.to_nat f))
               (list_find_index [1; 2; 3] (fun n => n =? 1)) = Some 0%nat.
  Proof. intros. reflexivity. Qed.

  Example list_find_index_1 :
    option_map (fun f => proj1_sig (Fin.to_nat f))
               (list_find_index [1; 2; 3] (fun n => n =? 2)) = Some 1%nat.
  Proof. intros. reflexivity. Qed.

  Example list_find_index_miss :
    option_map (fun f => proj1_sig (Fin.to_nat f))
               (list_find_index [1; 2; 3] (fun n => n =? 0)) = None.
  Proof. intros. reflexivity. Qed.

  Lemma list_find_index_empty : forall A p, @list_find_index A [] p = None.
  Proof. intros. reflexivity. Qed.
End List.

Section Tree.
  Inductive tree (N L : Type) : Type :=
  | TLeaf : L -> tree N L
  | TNode : N -> list (tree N L) -> tree N L.
  #[global] Arguments TLeaf {N L}.
  #[global] Arguments TNode {N L}.

  Fixpoint tree_map_in_context {N L N' L' : Type}
           (fn : list N' -> N -> list (tree N L) -> N')
           (fl : list N' -> L -> L')
           (pref : list N') (t : tree N L)
    : tree N' L' :=
    match t with
    | TNode n ts =>
      let n := fn pref n ts in
      TNode n (List.map (tree_map_in_context fn fl (n::pref)) ts)
    | TLeaf l => TLeaf (fl pref l)
    end.

  Definition tree_map {N L N' L' : Type} (fn : N -> N') (fl : L -> L')
    : tree N L -> tree N' L' :=
    tree_map_in_context (fun _ n _ => fn n) (fun _ l => fl l) [].

  Fixpoint tree_to_list_preorder {N L : Type} (t : tree N L) : list (N + L) :=
    match t with
    | TNode n ts =>
      (inl n) :: List.concat (List.map tree_to_list_preorder ts)
    | TLeaf l => [inr l]
    end.
End Tree.

Definition id_t := nat.

Definition resum_it {E F} `{E -< F} : itree E ~> itree F :=
  fun _ it => translate subevent it.
(* Alternatively: fun _ it => interp (fun _ e => trigger e) it. *)

Section WrapEvent.
  Variant wrapE E T : Type -> Type :=
  | Wrap : forall A, E A -> T -> wrapE E T A.
  #[global] Arguments Wrap {E T A}.

  Definition wrap_event_in_it (E : Type -> Type) {T : Type} (t : T) {F}
    : itree (E +' F) ~> itree (wrapE E T +' F) :=
    fun _ it =>
      let handle_E : E ~> itree (wrapE E T) := fun _ e => trigger (Wrap e t) in
      let h := bimap handle_E (id_ F) in
      interp h it.

  Definition map_wrap_event_in_it (E : Type -> Type) {T U : Type} (f : T -> U) {F}
    : itree (wrapE E T +' F) ~> itree (wrapE E U +' F) :=
    fun _ it =>
      let handle_WE : wrapE E T ~> itree (wrapE E U) := fun _ '(Wrap e t) => trigger (Wrap e (f t)) in
      let h := bimap handle_WE (id_ F) in
      interp h it.
End WrapEvent.

Section Nondet.
  Variant chooseE (T : Type) : Type -> Type :=
  | Choose : string -> list T -> chooseE T T.
  #[global] Arguments Choose {T}.

  Definition nondet {E T} `{chooseE nat -< E} description
    : ktree E (list T) (option T) :=
    fun l =>
      n <- trigger (Choose description (List.seq 0 (List.length l)))
      ;; ret (List.nth_error l n).
End Nondet.

Section Scheduler.
  (* [StartExc] starts exclusive execution of the issuing itree, untill it issues
   [EndExc]. *)
  Variant schedulerE (S : Type) : Type -> Type :=
  | Spawn : S -> schedulerE S unit
  | Kill : S -> schedulerE S unit
  | StartExc : schedulerE S unit
  | EndExc : schedulerE S unit.
  #[global] Arguments Spawn {S}.
  #[global] Arguments Kill {S}.
  #[global] Arguments StartExc {S}.
  #[global] Arguments EndExc {S}.

  Definition exclusive_block {E R S F}
             `{schedulerE S -< F} `{E -< F}
             (b : itree E R)
    : itree F R :=
    'tt <- trigger StartExc
    ;; r <- resum_it _ b
    ;; 'tt <- trigger EndExc
    ;; ret r.

  Context {E : Type -> Type} {S I R R' : Type} `{RelDec S (@eq S)}.

  Variable description : string.
  Variable spawn : ktree (schedulerE S +' E) S R.
  Variable hash_next : itree (schedulerE S +' E) R -> I.
  Variable fold_results : R' -> R -> R'.

  CoFixpoint scheduler
             (acc_result : R')
             (its : alist S (itree (schedulerE S +' E) R))
             (exclusive : option S)
    : itree (chooseE (S * I) +' E) R' :=
    match its with
    | [] => Ret acc_result
    | (id, it)::_ =>
      id <- match exclusive with
           | Some id => Ret id
           | None =>
             let es := List.map (fun '(id, it) => (id, hash_next it)) its in
             '(id, _) <- trigger (Choose description es)
             ;; ret id
           end
      ;; let it := match lookup id its with
                   | Some it => it
                   | None => it (* FIXME: error? *)
                   end in
         match observe it with
         | RetF r =>
           let its := Maps.remove id its in
           Tau (scheduler (fold_results acc_result r) its None)
         | TauF it =>
           let its := Maps.add id it its in
           Tau (scheduler acc_result its exclusive)
         | @VisF _ _ _ X o k =>
           match o with
           | inl1 o' =>
             match o' in schedulerE _ Y
                   return X = Y -> itree (chooseE (S * I) +' E) R' with
             | Spawn id' =>
               fun pf =>
                 let it := k (eq_rect_r (fun T => T) tt pf) in
                 let its := Maps.add id' (spawn id') (Maps.add id it its) in
                 Tau (scheduler acc_result its exclusive)
             | Kill id' =>
               fun pf =>
                 let it := k (eq_rect_r (fun T => T) tt pf) in
                 let its := Maps.add id it its in
                 let its := Maps.remove id' its in
                 let exclusive := if rel_dec id id' then
                                    (* A thread just killed itslef *)
                                    None
                                  else exclusive in
                 Tau (scheduler acc_result its exclusive)
             | StartExc =>
               fun pf =>
                 let it := k (eq_rect_r (fun T => T) tt pf) in
                 let its := Maps.add id it its in
                 Tau (scheduler acc_result its (Some id))
             | EndExc =>
               fun pf =>
                 let it := k (eq_rect_r (fun T => T) tt pf) in
                 let its := Maps.add id it its in
                 Tau (scheduler acc_result its None)
             end eq_refl
           | inr1 o' =>
             Vis (inr1 o') (fun x => let its := Maps.add id (k x) its in
                                  scheduler acc_result its exclusive)
           end
         end
    end.
End Scheduler.

Section Slices.
  Class Slice (T : Type) := { start : T -> nat;
                              size : T -> nat;
                              sub_slice : T -> nat -> nat -> option T }.

  Instance slice_prod_r {T S} `{Slice S} : Slice (T * S) :=
    { start := fun '(_, s) => start s;
      size := fun '(_, s) => size s;
      sub_slice := fun '(v, s) start size =>
                     match sub_slice s start size with
                     | Some s' => Some (v, s')
                     | None => None
                     end }.

  (* [is_sub_slice m n] is [true] iff [m] is contained in [n]. *)
  Definition contained {S S'} `{Slice S} `{Slice S'}
             (m : S) (n : S') : bool :=
    isTrue ((start n <= start m) /\ (start m + size m <= start n + size n))%nat.

  Definition non_empty_intersection {S S'} `{Slice S} `{Slice S'}
             (m : S) (n : S') : bool :=
    isTrue (start m < start n + size n /\
            start n < start m + size m)%nat.

  Definition reads_from_slcs_helper_helper {S S'} `{Slice S} `{Slice S'}
             (slc : S) (uslc : S')
    : option (option (S * list S')) :=
    if non_empty_intersection slc uslc then
      let slc'_start := max (start slc) (start uslc) in
      let slc'_end := min ((start slc) + (size slc)) ((start uslc) + (size uslc)) in
      match sub_slice slc slc'_start (slc'_end - slc'_start) with
      | Some slc' =>

        match
            (if decide (start uslc < start slc')%nat then
               match sub_slice uslc (start uslc) ((start slc') - (start uslc)) with
               | Some s => Some [s]
               | None => None
               end
            else Some nil),
            (if decide (slc'_end < (start uslc) + (size uslc))%nat then
               match sub_slice uslc slc'_end ((start uslc) + (size uslc) - slc'_end) with
               | Some s => Some [s]
               | None => None
               end
            else Some nil)
        with
        | Some uslcs1, Some uslcs2 => Some (Some (slc', uslcs1 ++ uslcs2))
        | _, _ => None
        end
      | None => None
      end
    else
      Some None.

  Fixpoint reads_from_slcs_helper {S S'} `{Slice S} `{Slice S'}
           (slc : S)
           (uslcs : list S')
           (acc_rf : list S)
           (acc_uslcs : list S')
    : option (list S * list S') :=
    match uslcs with
    | uslc::uslcs =>
      match reads_from_slcs_helper_helper slc uslc with
      | Some (Some (slc', uslcs')) =>
        reads_from_slcs_helper slc uslcs (slc'::acc_rf) (uslcs' ++ acc_uslcs)
      | Some None =>
        reads_from_slcs_helper slc uslcs acc_rf (uslc::acc_uslcs)
      | None => None
      end
    | nil => Some (acc_rf, acc_uslcs)
    end.

  Fixpoint reads_from_slcs {S S'} `{Slice S} `{Slice S'}
           (slcs : list S)
           (uslcs : list S')
           (rf : list S)
    : option (list S * list S') :=
    match slcs with
    | slc::slcs =>
      match reads_from_slcs_helper slc uslcs rf [] with
      | Some (rf', uslcs') => reads_from_slcs slcs uslcs' rf'
      | None => None
      end
    | nil => Some (rf, uslcs)
    end.
End Slices.


Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From Coq Require Import Strings.String.  (* for manual grading *)
From Coq Require Export Bool.Bool.
From Coq Require Export Arith.Arith.
From Coq Require Export Arith.EqNat.
From Coq Require Export Lia.
From Coq Require Export Lists.List.
Export ListNotations.
From VFA Require Import Perm.
From VFA Require Import Maps.
From VFA Require Import Sort.
From VFA Require Import SearchTree.

Module Type Table.
  Parameter table : Type.
  Definition key := nat.
  Parameter V : Type.
  Parameter default : V.
  Parameter empty : table.
  Parameter get : key -> table -> V.
  Parameter set : key -> V -> table -> table.
  Axiom get_empty_default : forall (k : key), get k empty = default.
  Axiom get_set_same : forall (k : key) (v : V) (t : table), get k (set k v t) = v.
  Axiom get_set_other : forall (k k' : key) (v : V) (t : table), k <> k' -> get k' (set k v t) = get k' t.
End Table.

Module Type ValType.
  Parameter V : Type.
  Parameter default : V.
End ValType.

Module FunTable (VT : ValType) <: Table.
  Definition V := VT.V.
  Definition default := VT.default.
  Definition key := nat.
  Definition table := key -> V.
  Definition empty : table := fun _ => default.
  Definition get (k : key) (t : table) : V := t k.
  Definition set (k : key) (v : V) (t : table) : table :=
    fun k' => if k =? k' then v else t k'.
  Theorem get_empty_default: forall (k : key),
      get k empty = default.
  Proof. intros. unfold get, empty. reflexivity. Qed.

  Theorem get_set_same: forall (k : key) (v : V) (t : table),
      get k (set k v t) = v.
  Proof. intros. unfold get, set. bdall. Qed.

  Theorem get_set_other: forall (k k' : key) (v : V) (t : table),
      k <> k' -> get k' (set k v t) = get k' t.
  Proof. intros. unfold get, set. bdall. Qed.
End FunTable.

Module StringVal.
  Definition V := string.
  Definition default := ""%string.
End StringVal.

Module FunTableExamples.
  Module StringFunTable := FunTable StringVal.
  Import StringFunTable.
  Open Scope string_scope.

  Example ex1 : get 0 empty = "".
  Proof. reflexivity. Qed.

  Example ex2 : get 0 (set 0 "A" empty) = "A".
  Proof. reflexivity. Qed.

  Example ex3 : get 1 (set 0 "A" empty) = "".
  Proof. reflexivity. Qed.
End FunTableExamples.

Module NatFunTableExamples.
  Module NatVal.
    Definition V := nat.
    Definition default := 0.
  End NatVal.

  Module NatFunTable := FunTable NatVal.
  Import NatFunTable.

  Example ex1 : get 0 empty = 0.
  Proof. reflexivity. Qed.

  Example ex2 : get 0 (set 0 1 empty) = 1.
  Proof. reflexivity. Qed.

  Example ex3 : get 1 (set 0 1 empty) = 0.
  Proof. reflexivity. Qed.
End NatFunTableExamples.

Module ListsTable (VT : ValType) <: Table.
  Definition V := VT.V.
  Definition default := VT.default.
  Definition key := nat.
  Definition table := list (key * V).
  Definition empty : table := [].
  Fixpoint get (k : key) (t : table) : V :=
    match t with
    | [] => default
    | (k', v) :: t' => if k =? k' then v else get k t'
    end.

  Definition set (k : key) (v : V) (t : table) : table :=
    (k, v) :: t.

  Theorem get_empty_default: forall (k : key),
      get k empty = default.
  Proof. reflexivity. Qed.

  Theorem get_set_same: forall (k : key) (v : V) (t : table),
      get k (set k v t) = v.
  Proof. intros. simpl. rewrite Nat.eqb_refl. reflexivity. Qed.

  Theorem get_set_other: forall (k k' : key) (v : V) (t : table),
      k <> k' -> get k' (set k v t) = get k' t.
  Proof. intros. simpl.
    bdestruct (k' =? k).
    - exfalso. auto.
    - reflexivity.
  Qed.
End ListsTable.

Module StringListsTableExamples.
  Module StringListsTable := ListsTable StringVal.
  Import StringListsTable.
  Open Scope string_scope.
  Example ex1 : get 0 empty = "".
  Proof. reflexivity. Qed.
  Example ex2 : get 0 (set 0 "A" empty) = "A".
  Proof. reflexivity. Qed.
  Example ex3 : get 1 (set 0 "A" empty) = "".
  Proof. reflexivity. Qed.
End StringListsTableExamples.

Module TreeTable (VT : ValType) <: Table.
  Definition V := VT.V.
  Definition default := VT.default.
  Definition key := nat.
  Definition table := tree V.
  Definition empty : table := @empty_tree V.
  Definition get (k : key) (t: table) : V := lookup default k t.
  Definition set (k : key) (v : V) (t : table) : table := insert k v t.

  Theorem get_empty_default: forall (k : key),
      get k empty = default.
  Proof.
    apply lookup_empty. Qed.

  Theorem get_set_same: forall (k : key) (v : V) (t : table),
      get k (set k v t) = v.
  Proof.
    intros. unfold get, set. apply lookup_insert_eq. Qed.

  Theorem get_set_other: forall (k k' : key) (v : V) (t : table),
      k <> k' -> get k' (set k v t) = get k' t.
  Proof.
    intros. unfold get, set. apply lookup_insert_neq. assumption. Qed.
End TreeTable.

(* The : syntax makes the module type opaque: only what is revealed
    in the type is available for code outside the module to use.
    The <: syntax, however, makes the module type transparent: the module must
    conform to the type, but everything about the module is still revealed. *)

(* Module TreeETableEncapsulated (VT : ValType) : (ETable
    with Definition V := VT.V
    with Definition default := VT.default). *)

Definition even_nat := {x : nat | Nat.Even x}.

Print ex. (* Sigma type for Prop *)
Print sigT. (* Sigma for Type *)
Print sig.

Definition search_tree (V : Type) := {t : tree V | BST t}.

Module SearchTreeTable (VT : ValType) <: Table.
  Definition V := VT.V.
  Definition default := VT.default.
  Definition key := nat.
  Definition table := search_tree V.
  Definition empty : table := @exist (tree V) BST E (empty_tree_BST V).
  Definition get (k : key) (t : table) : V :=
    match t with
    | exist _ t' pt => lookup default k t'
    end.

  Definition set (k : key) (v : V) (t : table) : table :=
    match t with
    | exist _ t' pt => exist BST (insert k v t') (insert_BST V k v t' pt)
    end.

  Theorem get_empty_default: forall (k : key),
      get k empty = default.
  Proof. reflexivity. Qed.

  Theorem get_set_same: forall (k : key) (v : V) (t : table),
      get k (set k v t) = v.
  Proof. intros. unfold get, set. simpl. destruct t. rewrite lookup_insert_eq. reflexivity. Qed.

  Theorem get_set_other: forall (k k' : key) (v : V) (t : table),
      k <> k' -> get k' (set k v t) = get k' t.
  Proof.
    intros. unfold get, set. destruct t.
    apply lookup_insert_neq.
    assumption.
  Qed.
End SearchTreeTable.

Definition vector (X : Type) :=
  { '(xs, n) : list X * nat | length xs = n }.

Example a_vector : vector nat.
Proof.
  exists (1::2::3::[], 3).
  reflexivity.
Qed.

Definition vector_cons {X : Type} (x : X) (v : vector X) : vector X.
Proof.
  intros.
  destruct v.
  destruct x0.
  exists (x :: l, S n).
  simpl. rewrite y. reflexivity.
Defined.

Definition list_of_vector {X : Type} (v : vector X) : list X :=
  fst (proj1_sig v).

Theorem vector_cons_correct : forall (X : Type) (x : X) (v : vector X),
    list_of_vector (vector_cons x v) = x :: (list_of_vector v).
Proof.
  intros.
  destruct v.
  destruct x0.
  unfold list_of_vector.
  simpl. (* Defined. is important for simpl !!! *)
  reflexivity.
Qed.

Definition vector_app {X : Type} (v1 v2 : vector X) : vector X.
Proof.
  intros.
  destruct v1, v2.
  destruct x, x0.
  exists (l ++ l0, n + n0).
  rewrite app_length.
  rewrite y, y0.
  reflexivity.
Defined.

Theorem vector_app_correct : forall (X : Type) (v1 v2 : vector X),
    list_of_vector (vector_app v1 v2) = list_of_vector v1 ++ list_of_vector v2.
Proof.
  intros.
  destruct v1, v2.
  destruct x, x0.
  unfold list_of_vector.
  simpl.
  reflexivity.
Qed.

Module Type ETableSubset.
  Include Table.
  Parameter bound : key -> table -> bool.
  Parameter elements : table -> list (key * V).
  Axiom bound_empty : forall (k : key),
      bound k empty = false.
  Axiom bound_set_same : forall (k : key) (v : V) (t : table),
      bound k (set k v t) = true.
  Axiom bound_set_other : forall (k k' : key) (v : V) (t : table),
      k <> k' -> bound k' (set k v t) = bound k' t.
  Axiom elements_complete : forall (k : key) (v : V) (t : table),
      bound k t = true ->
      get k t = v ->
      In (k, v) (elements t).
  Axiom elements_correct : forall (k : key) (v : V) (t : table),
      In (k, v) (elements t) ->
      bound k t = true /\ get k t = v.
End ETableSubset.

Module TreeETableSubset (VT : ValType) <: ETableSubset.
  Definition V := VT.V.
  Definition default := VT.default.
  Definition key := nat.
  Definition table := { t : tree V | BST t }.
  Definition empty : table.
  Proof.
    apply (exist _ empty_tree).
    apply empty_tree_BST.
  Defined.

  Definition get (k : key) (t : table) : V :=
    lookup default k (proj1_sig t).

  Definition set (k : key) (v : V) (t : table) : table.
  Proof.
    destruct t as [t Ht].
    apply (exist _ (insert k v t)).
    apply insert_BST. assumption.
  Defined.

  Definition bound (k : key) (t : table) : bool :=
    SearchTree.bound k (proj1_sig t).

  Definition elements (t : table) : list (key * V) :=
    elements (proj1_sig t).

  Theorem get_empty_default: forall (k : key),
      get k empty = default.
  Proof.
    apply lookup_empty.  Qed.

  Theorem get_set_same: forall (k : key) (v : V) (t : table),
      get k (set k v t) = v.
  Proof.
    intros. unfold get, set.
    destruct t as [t Hbst]. simpl.
    apply lookup_insert_eq.
  Qed.

  Theorem get_set_other: forall (k k' : key) (v : V) (t : table),
      k <> k' -> get k' (set k v t) = get k' t.
  Proof.
    intros. unfold get, set.
    destruct t as [t Hbst]. simpl.
    apply lookup_insert_neq. assumption.
  Qed.

  Theorem bound_empty : forall (k : key),
      bound k empty = false.
  Proof. reflexivity. Qed.

  Theorem bound_set_same : forall (k : key) (v : V) (t : table),
      bound k (set k v t) = true.
  Proof.
    intros k v t. unfold bound, set.
    destruct t as [t Hbst]. simpl in *.
    induction t; inv Hbst; bdall.
  Qed.

  Theorem bound_set_other : forall (k k' : key) (v : V) (t : table),
      k <> k' -> bound k' (set k v t) = bound k' t.
  Proof.
    intros k k' v t Hneq. unfold bound, set.
    destruct t as [t Hbst]. simpl in *.
    apply bound_insert_neq; auto.
  Qed.

  Theorem elements_complete : forall (k : key) (v : V) (t : table),
      bound k t = true ->
      get k t = v ->
      In (k, v) (elements t).
  Proof.
    intros k v t Hbound Hlookup.
    pose proof SearchTree.elements_complete as Hcomplete. (* !!! *)
    unfold elements_complete_spec in Hcomplete.
    apply Hcomplete with default; try assumption.
  Qed.

  Theorem elements_correct : forall (k : key) (v : V) (t : table),
      In (k, v) (elements t) ->
      bound k t = true /\ get k t = v.
  Proof.
    intros k v t. simpl. intros Hin.
    pose proof SearchTree.elements_correct as Hcorrect.
    unfold elements_correct_spec in Hcorrect.
    apply Hcorrect; try assumption.
    destruct t as [t Hbst]. simpl. assumption.
  Qed.
End TreeETableSubset.


Require Export SimrelDefinition.
Require Export InitMemRel.

Section SIMREL_INIT_MEM.
  Context `{Hmem: BaseMemoryModel}.
  Context {D1 D2: layerdata}.
  Context {F1 F2 V: Type}.

  Definition simrel_newfun_ok ng b (i: ident) :=
    b = true /\ simrel_not_new_glbl ng i.

  Class InitMemSimrel ng b (RM: _ -> _ -> _ -> _ -> rel (mwd D1) (mwd D2)) :=
    {
      (** Starting point *)
      initmem_simrel_empty :>
        Monotonic Mem.empty (RM 1%positive nil 0 0);

      (** No definition *)
      initmem_simrel_none i:
        simrel_not_new_glbl ng i ->
        Monotonic
          alloc_none
          (RM i nil 0 0 ++> option_le (RM (Pos.succ i) nil 0 0));

      (** New function *)
      initmem_simrel_none_fun i:
        simrel_newfun_ok ng b i ->
        Related
          alloc_none
          alloc_fun
          (RM i nil 0 0 ++> option_le (RM (Pos.succ i) nil 0 0));

      (** New variable *)
      initmem_simrel_none_var i (v: globvar V):
        simrel_newvar_ok ng b i (gvar_init v) ->
        Genv.init_data_list_valid find_symbol 0 (gvar_init v) = true ->
        InitMemNewVariableProps
          (simrel_fundef_rel (F1:=F1) (F2:=F2) b)
          (simrel_vardef_rel (V:=V) ng b)
          RM i v;

      (** Both functions *)
      initmem_simrel_fun i:
        Monotonic
          alloc_fun
          (RM i nil 0 0 ++> option_le (RM (Pos.succ i) nil 0 0));

      (** Both variables *)
      initmem_simrel_var i (v: globvar V):
        simrel_not_new_glbl ng i ->
        InitMemVariableProps
          (simrel_fundef_rel (F1:=F1) (F2:=F2) b)
          (simrel_vardef_rel (V:=V) ng b)
          RM i v v
    }.

  Global Instance initmem_simrel_rel ng b RM:
    InitMemSimrel ng b RM ->
    InitMemRelations
      (simrel_fundef_rel (F1:=F1) (F2:=F2) b)
      (simrel_vardef_rel (V:=V) ng b)
      RM.
  Proof.
    assert
      (forall i,
         simrel_vardef_rel (V:=V) ng b i None None ->
         simrel_not_new_glbl ng i)
      as Hvar_none.
    {
      intros i Hi.
      inversion Hi.
      assumption.
    }

    assert
      (forall i f2,
         simrel_fundef_rel (F1:=F1) (F2:=F2) b i None (Some f2) ->
         simrel_vardef_rel (V:=V) ng b i None None ->
         simrel_newfun_ok ng b i)
      as Hnew_fun.
    {
      intros i f2 Hf Hv.
      red.
      inversion Hf; clear Hf; subst.
      inversion Hv; clear Hv; subst.
      eauto.
    }

    assert
      (forall i v,
         simrel_fundef_rel (F1:=F1) (F2:=F2) b i None None ->
         simrel_vardef_rel (V:=V) ng b i None (Some v) ->
         simrel_newvar_ok ng b i (gvar_init v))
      as Hnew_var.
    {
      intros i v Hf Hv.
      red.
      inversion Hv; clear Hv; subst; eauto.
    }

    assert
      (forall i v,
         simrel_fundef_rel (F1:=F1) (F2:=F2) b i None None ->
         simrel_vardef_rel (V:=V) ng b i None (Some v) ->
         Genv.init_data_list_valid find_symbol 0 (gvar_init v) = true)
      as Hnew_var'.
    {
      intros i v Hf Hv.
      inversion Hv; clear Hv; subst; eauto.
    }

    assert
      (forall i v1 v2,
         simrel_vardef_rel (V:=V) ng b i (Some v1) (Some v2) ->
         v1 = v2)
      as Hvar_eq.
    {
      intros i v1 v2 Hv.
      inversion Hv.
      reflexivity.
    }

    assert
      (forall i v1 v2,
         simrel_vardef_rel (V:=V) ng b i (Some v1) (Some v2) ->
         simrel_not_new_glbl ng i)
      as Hvar.
    {
      intros i v1 v2 Hv.
      inversion Hv; eauto.
    }

    intros H.
    destruct H.
    split; intros; eauto.
    - intros f1 f2 Hf.
      destruct Hf; congruence.
    - intros v1 v2 Hv.
      destruct Hv as [ | | ]; congruence.
    - assert (v1 = v2) by eauto; subst; eauto.
  Qed.

  Global Instance genv_init_mem_simrel_withnextblock R RM:
    InitMemSimrel
      (simrel_new_glbl R)
      (simrel_undef_matches_values_bool R)
      RM ->
    subrel
      (RM glob_threshold nil 0 0 /\ req glob_threshold @@ Mem.nextblock)
      (rexists w, match_mem R w) ->
    Monotonic
      (Genv.init_mem (F:=_) (V:=V))
      (simrel_program_rel (F1:=F1) (F2:=F2) R ++>
       option_le ((rexists w, match_mem R w) /\
                  (req glob_threshold @@ Mem.nextblock))).
  Proof.
    intros HR HRM.
    solve_monotonic.
  Qed.

  Lemma genv_init_mem_simrel R RM:
    InitMemSimrel
      (simrel_new_glbl R)
      (simrel_undef_matches_values_bool R)
      RM ->
    subrel
      (RM glob_threshold nil 0 0 /\ req glob_threshold @@ Mem.nextblock)
      (rexists w, match_mem R w) ->
    Monotonic
      (Genv.init_mem (F:=_) (V:=V))
      (simrel_program_rel (F1:=F1) (F2:=F2) R ++>
       option_le (rexists w, match_mem R w)).
  Proof.
    intros HR HRM.
    solve_monotonic.
  Qed.
End SIMREL_INIT_MEM.


Require Export VST.msl.ghost.
Require Import VST.msl.shares.
Require Import VST.msl.sepalg_generators.
Require Import VST.msl.iter_sepcon.
Require Import VST.msl.ghost_seplog.
Require Import VST.veric.mpred.
Require Import VST.veric.shares.
Require Import VST.veric.own.
Require Import VST.veric.compcert_rmaps.

(* Lemmas about ghost state and common instances *)

Notation "|==> P" := (own.bupd P) (at level 99, P at level 200): pred.

Section ghost.

Local Open Scope pred.

Context {RA: Ghost}.

Lemma own_op' : forall g a1 a2 pp,
  own g a1 pp * own g a2 pp = EX a3 : _, !!(join a1 a2 a3 /\ valid a3) && own g a3 pp.
Proof.
  intros.
  apply pred_ext.
  - eapply derives_trans, prop_andp_left; [apply andp_right, derives_refl; apply ghost_valid_2|].
    intros (a3 & ? & ?); apply exp_right with a3, prop_andp_right; auto.
    erewrite <- ghost_op by eauto; apply derives_refl.
  - apply exp_left; intro; apply prop_andp_left; intros [].
    erewrite ghost_op by eauto; apply derives_refl.
Qed.

Lemma own_op_gen : forall g a1 a2 a3 pp, (valid_2 a1 a2 -> join a1 a2 a3) ->
  own g a1 pp * own g a2 pp = !!(valid_2 a1 a2) && own g a3 pp.
Proof.
  intros; apply pred_ext.
  - eapply derives_trans, prop_andp_left; [apply andp_right, derives_refl; apply ghost_valid_2|].
    intro; erewrite <- ghost_op by eauto.
    apply prop_andp_right; auto.
  - apply prop_andp_left; intro.
    erewrite ghost_op by eauto; apply derives_refl.
Qed.

End ghost.

#[export] Hint Resolve Share.nontrivial : share.

Section Reference.
(* One common kind of PCM is one in which a central authority has a reference copy, and clients pass around
   partial knowledge. When a client recovers all pieces, it can gain full knowledge. *)
(* This is related to the snapshot PCM, but the snapshots aren't duplicable. *)

Global Program Instance pos_PCM (P : Ghost) : Ghost := { G := option (share * G);
  valid a := match a with Some (sh, _) => sh <> Share.bot | _ => True end;
  Join_G a b c := match a, b, c with
  | Some (sha, a'), Some (shb, b'), Some (shc, c') =>
      sha <> Share.bot /\ shb <> Share.bot /\ sepalg.join sha shb shc /\ join a' b' c'
  | Some (sh, a), None, Some c' | None, Some (sh, a), Some c' => c' = (sh, a)
  | None, None, None => True
  | _, _, _ => False
  end }.
Next Obligation.
repeat split; intros; intro X; decompose [and] X; congruence.
Qed.
Next Obligation.
repeat split; intros; intro X; decompose [and] X; congruence.
Qed.
Next Obligation.
repeat split; intros; intro X; decompose [and] X; congruence.
Qed.
Next Obligation.
repeat split; intros; intro X; decompose [and] X; congruence.
Qed.
Next Obligation.
apply fsep_sep.
exists (fun _ => None); auto.
intros [[]|]; constructor.
Defined.
Next Obligation.
constructor.
  - intros [[]|] [[]|] [[]|] [[]|]; unfold join; simpl; auto; try contradiction; try congruence.
    intros (? & ? & ? & ?) (? & ? & ? & ?); f_equal; f_equal; eapply join_eq; eauto.
  - intros [[]|] [[]|] [[]|] [[]|] [[]|]; try contradiction; unfold join; simpl;
      intros; decompose [and] H; decompose [and] H0;
      repeat match goal with H : (_, _) = (_, _) |- _ => inv H end;
      try solve [eexists (Some _); split; auto; simpl; auto]; try solve [exists None; split; auto].
    + destruct (join_assoc H2 H6) as (sh' & ? & ?), (join_assoc H5 H9) as (a' & ? & ?).
      exists (Some (sh', a')); repeat (split; auto).
      intro; subst.
      apply join_Bot in H8 as []; auto.
    + exists (Some (s2, g2)); auto.
  - intros [[]|] [[]|] [[]|]; try contradiction; unfold join; auto.
    intros (? & ? & ? & ?); split; auto; split; auto; split; apply join_comm; auto.
  - intros [[]|] [[]|] [[]|] [[]|]; try contradiction; intros H1 H2; try solve [inv H1; reflexivity || inv H2; reflexivity].
    destruct H1 as (? & ? & ? & ?), H2 as (? & ? & ? & ?); f_equal; f_equal; eapply join_positivity; eauto.
Qed.
(*Next Obligation.
  hnf.
  destruct a as [[]|]; auto.
Qed.
Next Obligation.
  exists None; hnf; auto.
Qed.*)
Next Obligation.
destruct a as [[]|]; destruct b as [[]|]; destruct c as [[]|]; try trivial;
unfold join in *; try contradiction.
- decompose [and] H; assumption.
- congruence.
Qed.

Definition completable {P : Ghost} (a: @G (pos_PCM P)) r := exists x, join a x (Some (Share.top, r)).

Local Obligation Tactic := idtac.

Global Program Instance ref_PCM (P : Ghost) : Ghost :=
{ valid a := valid (fst a) /\ match snd a with Some r => completable (fst a) r | None => True end;
  Join_G a b c := @Join_G (pos_PCM P) (fst a) (fst b) (fst c) /\
    @psepalg.Join_lower _ (psepalg.Join_discrete _) (snd a) (snd b) (snd c) }.
Next Obligation.
  intros P; apply sepalg_generators.Sep_prod; try apply _.
  apply fsep_sep, _.
Defined.
Next Obligation.
  intros P; apply sepalg_generators.Perm_prod; typeclasses eauto.
Qed.
(*Next Obligation.
  intros; hnf.
  split; [apply (@core2_unit (pos_PCM P)) | constructor].
Qed.
Next Obligation.
  intros; reflexivity.
Qed.
Next Obligation.
  intros; exists (None, None); hnf.
  split; constructor.
Qed.*)
Next Obligation.
  intros P ??? [? J] []; split; [eapply join_valid; eauto|].
  destruct a, b, c; simpl in *; inv J; auto.
  + destruct o1; auto.
    destruct H1.
    destruct (join_assoc H H1) as (? & ? & ?); eexists; eauto.
  + inv H2.
Qed.

End Reference.

#[global] Program Instance exclusive_PCM A : Ghost :=
  { valid a := True; Join_G := Join_lower (Join_discrete A) }.
(*Next Obligation.
Proof.
  eexists; constructor.
Qed.*)

Definition excl {A} g a : mpred := own(RA := exclusive_PCM A) g (Some a) NoneP.

Lemma exclusive_update : forall {A} (v v' : A) p, excl p v |-- |==> excl p v'.
Proof.
  intros; apply ghost_update.
  intros ? (? & ? & _).
  exists (Some v'); split; simpl; auto; inv H; constructor.
  inv H1.
Qed.

Local Obligation Tactic := idtac.

#[global] Program Instance prod_PCM (GA GB: Ghost): Ghost := { G := @G GA * @G GB;
  valid a := valid (fst a) /\ valid (snd a); Join_G := Join_prod _ _ _ _ }.
Next Obligation.
  intros GA GB ??? [] []; split; eapply join_valid; eauto.
Defined.

(* Can we use Santiago and Qinxiang's paper to simplify this? *)
Class PCM_order `{P : Ghost} (ord : G -> G -> Prop) := { ord_preorder :> PreOrder ord;
  ord_lub : forall a b c, ord a c -> ord b c -> {c' | join a b c' /\ ord c' c};
  join_ord : forall a b c, join a b c -> ord a c /\ ord b c; ord_join : forall a b, ord b a -> join a b a }.

(*Class lub_ord {A} (ord : A -> A -> Prop) := { lub_ord_refl :> RelationClasses.Reflexive ord;
  lub_ord_trans :> RelationClasses.Transitive ord;
  has_lub : forall a b c, ord a c -> ord b c -> exists c', ord a c' /\ ord b c' /\
    forall d, ord a d -> ord b d -> ord c' d }.

Global Instance ord_PCM `{lub_ord} : Ghost := { Join_G a b c := ord a c /\ ord b c /\
  forall c', ord a c' -> ord b c' -> ord c c' }.
Proof.
  -
  - intros ??? (? & ? & ?); eauto.
  - intros ????? (? & ? & Hc) (? & ? & He).
    destruct (has_lub b d e) as (c' & ? & ? & Hlub); try solve [etransitivity; eauto].
    exists c'; repeat split; auto.
    + etransitivity; eauto.
    + apply Hlub; auto; transitivity c; auto.
    + intros.
      apply He.
      * apply Hc; auto; etransitivity; eauto.
      * etransitivity; eauto.
Defined.

Global Instance ord_PCM_ord `{lub_ord} : PCM_order ord.
Proof.
  constructor.
  - apply lub_ord_refl.
  - apply lub_ord_trans.
  - intros ??? Ha Hb.
    destruct (has_lub _ _ _ Ha Hb) as (c' & ? & ? & ?).
    exists c'; simpl; eauto.
  - simpl; intros; tauto.
  - intros; simpl.
    repeat split; auto.
    reflexivity.
Defined.*)

(* Instances of ghost state *)
Section Snapshot.
(* One common kind of PCM is one in which a central authority has a reference copy, and clients pass around
   partial knowledge. *)

Context `{ORD : PCM_order}.

Lemma join_refl : forall (v : G), join v v v.
Proof.
  intros. apply ord_join; reflexivity.
Qed.

Lemma join_compat : forall v1 v2 v' v'', join v2 v' v'' -> ord v1 v2 -> exists v0, join v1 v' v0 /\ ord v0 v''.
Proof.
  intros.
  destruct (join_ord _ _ _ H).
  destruct (ord_lub v1 v' v'') as (? & ? & ?); eauto.
  etransitivity; eauto.
Qed.

Lemma join_ord_eq : forall a b, ord a b <-> exists c, join a c b.
Proof.
  split.
  - intros; exists b.
    apply ord_join in H.
    apply join_comm; auto.
  - intros (? & H); apply join_ord in H; tauto.
Qed.

(* The master-snapshot PCM in the RCU paper divides the master into shares, which is useful for having both
   an authoritative writer and an up-to-date invariant. *)

Global Program Instance snap_PCM : Ghost :=
  { valid _ := True; Join_G a b c := sepalg.join (fst a) (fst b) (fst c) /\
      if eq_dec (fst a) Share.bot then if eq_dec (fst b) Share.bot then join (snd a) (snd b) (snd c)
        else ord (snd a) (snd b) /\ snd c = snd b else snd c = snd a /\
          if eq_dec (fst b) Share.bot then ord (snd b) (snd a) else snd c = snd b }.
Next Obligation.
  exists (fun '(sh, a) => (Share.bot, a)); repeat intro.
  + destruct t; constructor; auto; simpl.
    rewrite eq_dec_refl.
    if_tac; [apply join_refl | split; auto].
    reflexivity.
  + destruct a, c, H as [? Hj].
    assert (join_sub g g0) as [].
    { if_tac in Hj. if_tac in Hj.
      eexists; eauto.
      destruct Hj; simpl in *; subst.
      apply join_ord_eq; auto.
      destruct Hj; simpl in *; subst.
      apply join_sub_refl. }
    eexists (_, _). split; simpl.
    * apply join_bot_eq.
    * rewrite !eq_dec_refl; eauto.
  + destruct a; reflexivity.
Defined.
Next Obligation.
  constructor.
  - intros ???? [? Hjoin1] [? Hjoin2].
    assert (fst z = fst z') by (eapply join_eq; eauto).
    destruct z, z'; simpl in *; subst; f_equal.
    destruct (eq_dec (fst x) Share.bot); [|destruct Hjoin1, Hjoin2; subst; auto].
    destruct (eq_dec (fst y) Share.bot); [|destruct Hjoin1, Hjoin2; subst; auto].
    eapply join_eq; eauto.
  - intros ????? [Hsh1 Hjoin1] [Hsh2 Hjoin2].
    destruct (sepalg.join_assoc Hsh1 Hsh2) as [sh' []].
    destruct (eq_dec (fst b) Share.bot) eqn: Hb.
    + assert (fst d = fst a) as Hd.
      { eapply sepalg.join_eq; eauto.
        rewrite e0; apply join_bot_eq. }
      rewrite Hd in Hsh1, Hsh2, Hjoin2.
      assert (sh' = fst c) as Hc.
      { eapply sepalg.join_eq; eauto.
        rewrite e0; apply bot_join_eq. }
      subst sh'.
      destruct (eq_dec (fst c) Share.bot) eqn: Hc1.
      * destruct (eq_dec (fst a) Share.bot) eqn: Ha.
        -- destruct (join_assoc Hjoin1 Hjoin2) as [c' []].
            destruct a, b, c; simpl in *; subst.
           exists (Share.bot, c'); split; split; rewrite ?eq_dec_refl; auto.
        -- destruct Hjoin1 as [Hc' ?]; rewrite Hc' in Hjoin2.
           destruct Hjoin2, (ord_lub (snd b) (snd c) (snd a)) as [c' []]; eauto.
           destruct b, c; simpl in *; subst.
           exists (Share.bot, c'); split; split; rewrite ?eq_dec_refl, ?Ha; auto.
      * exists c.
        destruct (eq_dec (fst a) Share.bot) eqn: Ha; try solve [split; split; auto].
        -- destruct Hjoin2.
           apply join_ord in Hjoin1; destruct Hjoin1.
           destruct b; simpl in *; subst.
           split; split; rewrite ?Ha, ?Hc1, ?eq_dec_refl; auto; split; auto; etransitivity; eauto.
        -- destruct Hjoin2 as [He1 He2].
           destruct Hjoin1 as [Hd' ?]; rewrite He2, Hd' in He1; split; split; rewrite ?e0, ?He2, ?He1, ?Ha, ?Hc1, ?eq_dec_refl, ?Hd'; auto.
    + exists (sh', snd b); simpl.
      destruct (eq_dec (fst d) Share.bot).
      { rewrite e0 in Hsh1; apply join_Bot in Hsh1; destruct Hsh1; contradiction. }
      destruct (eq_dec sh' Share.bot) eqn: Hn'.
      { subst; apply join_Bot in H; destruct H; contradiction. }
      assert (snd d = snd b) as Hd by (destruct (eq_dec (fst a) Share.bot); tauto).
      rewrite Hd in Hjoin1, Hjoin2; destruct Hjoin2 as [He Hjoin2]; rewrite He in Hjoin2; split; split; simpl; rewrite ?Hb, ?Hn', ?Hd, ?He; auto.
  - intros ??? []; split; [apply join_comm; auto|].
    if_tac; if_tac; auto; tauto.
  - intros ???? [? Hjoin1] [? Hjoin2].
    assert (fst a = fst b) by (eapply join_positivity; eauto).
    destruct (eq_dec (fst a) Share.bot), a, a', b, b'; simpl in *; subst; f_equal.
    + rewrite eq_dec_refl in Hjoin2.
      apply join_Bot in H0 as []; subst.
      apply join_Bot in H as []; subst.
      rewrite !eq_dec_refl in Hjoin1, Hjoin2.
      eapply join_positivity; eauto.
    + destruct Hjoin1; auto.
Defined.
Next Obligation.
  auto.
Defined.

Definition ghost_snap (a : @G P) p := own p (Share.bot, a) NoneP.

Lemma ghost_snap_join : forall v1 v2 p v, join v1 v2 v ->
  (ghost_snap v1 p * ghost_snap v2 p = ghost_snap v p)%pred.
Proof.
  intros; symmetry; apply ghost_op.
  split; simpl; rewrite ?eq_dec_refl; auto.
Qed.

Lemma prop_derives : forall (P Q : Prop), (P -> Q) -> !!P |-- !!Q.
Proof.
  repeat intro; simpl in *; auto.
Qed.

Lemma ghost_snap_conflict : forall v1 v2 p, ghost_snap v1 p * ghost_snap v2 p |-- !!(joins v1 v2).
Proof.
  intros; eapply derives_trans; [apply ghost_valid_2|].
  apply prop_derives.
  intros ((?, a) & (? & Hj) & _); simpl in Hj.
  rewrite !eq_dec_refl in Hj.
  exists a; auto.
Qed.

Lemma ghost_snap_join' : forall v1 v2 p,
  (ghost_snap v1 p * ghost_snap v2 p = EX v : _, !!(join v1 v2 v) && ghost_snap v p)%pred.
Proof.
  intros; apply pred_ext.
  - eapply derives_trans, prop_andp_left; [apply andp_right, derives_refl; apply ghost_snap_conflict|].
    intros [v]; apply exp_right with v; apply prop_andp_right; auto.
    erewrite ghost_snap_join; eauto.
  - apply exp_left; intro v; apply prop_andp_left; intro.
    erewrite ghost_snap_join; eauto.
Qed.

Definition ghost_master sh (a : @G P) p := own p (sh, a) NoneP.

Lemma snap_master_join : forall v1 sh v2 p, sh <> Share.bot ->
  (ghost_snap v1 p * ghost_master sh v2 p = !!(ord v1 v2) && ghost_master sh v2 p)%pred.
Proof.
  intros; setoid_rewrite own_op'.
  apply pred_ext.
  - apply exp_left; intro a3; apply prop_andp_left.
    destruct a3 as (sh', ?); intros ([Hsh Hj] & _); simpl in *.
    apply bot_identity in Hsh; subst sh'.
    rewrite eq_dec_refl in Hj.
    destruct (eq_dec sh Share.bot); [contradiction|].
    destruct Hj; subst; apply prop_andp_right; auto.
  - apply prop_andp_left; intro.
    apply exp_right with (sh, v2), prop_andp_right; auto.
    split; simpl; auto.
    split; simpl; rewrite ?eq_dec_refl.
    + apply bot_join_eq.
    + if_tac; auto; contradiction.
Qed.

Corollary snaps_master_join : forall lv sh v2 p, sh <> Share.bot ->
  (fold_right sepcon emp (map (fun v => ghost_snap v p) lv) * ghost_master sh v2 p =
  !!(Forall (fun v1 => ord v1 v2) lv) && ghost_master sh v2 p)%pred.
Proof.
  induction lv; simpl; intros.
  - rewrite emp_sepcon, prop_true_andp; auto.
  - rewrite sepcon_comm, <-sepcon_assoc, (sepcon_comm (ghost_master _ _ _)), snap_master_join; auto.
    apply pred_ext.
    + rewrite sepcon_andp_prop1; apply prop_andp_left; intro.
      rewrite sepcon_comm, IHlv by auto.
      apply prop_andp_left; intro; apply prop_andp_right; auto.
    + apply prop_andp_left; intros Hall.
      inv Hall.
      rewrite prop_true_andp; auto.
      rewrite sepcon_comm, IHlv by auto.
      apply prop_andp_right; auto.
Qed.

Lemma master_update : forall v v' p, ord v v' -> ghost_master Tsh v p |-- |==> ghost_master Tsh v' p.
Proof.
  intros; apply ghost_update.
  intros ? (x & Hj & _); simpl in Hj.
  exists (Tsh, v'); simpl; split; auto.
  destruct Hj as [Hsh Hj]; simpl in *.
  apply join_Tsh in Hsh as []; destruct c, x; simpl in *; subst.
  split; auto; simpl.
  fold share in *; destruct (eq_dec Tsh Share.bot); [contradiction Share.nontrivial|].
  destruct Hj as [? Hc']; subst.
  rewrite !eq_dec_refl in Hc' |- *; split; auto.
  etransitivity; eauto.
Qed.

Lemma master_init : forall (a : @G P), exists g', joins (Tsh, a) g'.
Proof.
  intros; exists (Share.bot, a), (Tsh, a); simpl.
  split; auto; simpl.
  apply join_refl.
Qed.

Hint Resolve bupd_intro : ghost.

Lemma make_snap : forall (sh : share) v p, ghost_master sh v p |-- |==> ghost_snap v p * ghost_master sh v p.
Proof.
  intros.
  destruct (eq_dec sh Share.bot).
  - subst; setoid_rewrite ghost_snap_join; [|apply join_refl]; auto with ghost.
  - rewrite snap_master_join by auto.
    rewrite prop_true_andp by reflexivity; apply bupd_intro.
Qed.

Lemma ghost_snap_forget : forall v1 v2 p, ord v1 v2 -> ghost_snap v2 p |-- |==> ghost_snap v1 p.
Proof.
  intros; apply ghost_update.
  intros (shc, c) [(shx, x) [[? Hj] _]]; simpl in *.
  rewrite eq_dec_refl in Hj.
  assert (shx = shc) by (eapply sepalg.join_eq; eauto); subst.
  unfold share in Hj; destruct (eq_dec shc Share.bot); subst.
  - destruct (join_compat _ _ _ _ Hj H) as [x' []].
    exists (Share.bot, x'); simpl; split; auto; split; auto; simpl.
    rewrite !eq_dec_refl; auto.
  - destruct Hj; subst.
    exists (shc, c); simpl; split; auto; split; auto; simpl.
    rewrite eq_dec_refl; if_tac; [contradiction|].
    split; auto.
    etransitivity; eauto.
Qed.

Lemma ghost_snap_choose : forall v1 v2 p, ghost_snap v1 p * ghost_snap v2 p |-- |==> ghost_snap v1 p.
Proof.
  intros.
  setoid_rewrite own_op'.
  apply exp_left; intro v'; apply prop_andp_left; intros [H ?].
  destruct v', H as [Hsh Hj]; apply bot_identity in Hsh; simpl in *; subst.
  rewrite !eq_dec_refl in Hj.
  apply ghost_snap_forget.
  rewrite join_ord_eq; eauto.
Qed.

Lemma master_share_join : forall sh1 sh2 sh v p, sepalg.join sh1 sh2 sh ->
  (ghost_master sh1 v p * ghost_master sh2 v p = ghost_master sh v p)%pred.
Proof.
  intros; symmetry; apply ghost_op; split; auto; simpl.
  if_tac; if_tac; try split; auto; try reflexivity; apply join_refl.
Qed.

Lemma unreadable_bot : ~readable_share Share.bot.
Proof.
  unfold readable_share, nonempty_share, sepalg.nonidentity.
  rewrite Share.glb_bot; auto.
Qed.

Lemma master_inj : forall sh1 sh2 v1 v2 p, readable_share sh1 -> readable_share sh2 ->
  ghost_master sh1 v1 p * ghost_master sh2 v2 p |-- !!(v1 = v2).
Proof.
  intros.
  eapply derives_trans; [apply ghost_valid_2|].
  apply prop_derives; intros ((?, ?) & [[? Hj] _]); simpl in Hj.
  fold share in *.
  destruct (eq_dec sh1 Share.bot); [subst; contradiction unreadable_bot|].
  destruct (eq_dec sh2 Share.bot); [subst; contradiction unreadable_bot|].
  destruct Hj; subst; auto.
Qed.

Lemma master_share_join' : forall sh1 sh2 sh v1 v2 p, readable_share sh1 -> readable_share sh2 ->
  sepalg.join sh1 sh2 sh ->
  (ghost_master sh1 v1 p * ghost_master sh2 v2 p = !!(v1 = v2) && ghost_master sh v2 p)%pred.
Proof.
  intros; apply pred_ext.
  - eapply derives_trans; [apply andp_right, derives_refl; apply master_inj; auto|].
    apply prop_andp_left; intros; subst.
    apply prop_andp_right; auto.
    erewrite master_share_join; eauto.
  - apply prop_andp_left; intro; subst.
    erewrite master_share_join; eauto.
Qed.

(* useful when we only want to deal with full masters *)
Definition ghost_master1 a p := ghost_master Tsh a p.

Lemma snap_master_join1 : forall v1 v2 p,
  (ghost_snap v1 p * ghost_master1 v2 p = !!(ord v1 v2) && ghost_master1 v2 p)%pred.
Proof.
  intros; apply snap_master_join, Share.nontrivial.
Qed.

Lemma snap_master_update1 : forall v1 v2 p v', ord v2 v' ->
  ghost_snap v1 p * ghost_master1 v2 p |-- |==> ghost_snap v' p * ghost_master1 v' p.
Proof.
  intros; rewrite !snap_master_join1.
  apply prop_andp_left; intro.
  rewrite prop_true_andp by reflexivity.
  apply master_update; auto.
Qed.

End Snapshot.

#[global] Hint Resolve bupd_intro : ghost.

Section Discrete.

#[global] Program Instance discrete_PCM (A : Type) : Ghost := { valid a := True;
  Join_G := Join_equiv A }.
Next Obligation.
  auto.
Defined.

Context {A : Type}.

Global Instance discrete_order : PCM_order(P := discrete_PCM A) eq.
Proof.
  constructor; intros.
  - typeclasses eauto.
  - exists c; subst; split; hnf; auto.
  - inv H; auto.
  - subst; hnf; auto.
Defined.

End Discrete.


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 O E Eprime Eprimeprime A B C Bprime Bprimeprime : Universe, ((wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ B O /\ (wd_ A O /\ (wd_ C O /\ (wd_ O Eprimeprime /\ (wd_ E Eprimeprime /\ (wd_ Eprime A /\ (wd_ Bprime C /\ (wd_ B E /\ (wd_ Bprime Eprime /\ (wd_ E Bprime /\ (wd_ Eprime B /\ (wd_ B Bprime /\ (wd_ B Bprimeprime /\ (wd_ B Eprimeprime /\ (wd_ Bprimeprime E /\ (wd_ Bprimeprime Eprimeprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O Eprime Bprime /\ (col_ O Eprimeprime Bprimeprime /\ (col_ Eprime Bprime C /\ col_ A Bprime C))))))))))))))))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.