Require Export bedrock2.Map.Separation.

Require Import Coq.Classes.Morphisms.
Require Import bedrock2.Lift1Prop.
Require Coq.Lists.List.
Require Import coqutil.sanity coqutil.Decidable coqutil.Tactics.destr.
Require Import coqutil.Map.Interface coqutil.Map.Properties.
Require Import coqutil.Tactics.ltac_list_ops.
Import Map.Interface.map Map.Properties.map.

(*TODO: use hintdb or user-provided tactic?
  Study performance implications
*)
Create HintDb ecancel_impl discriminated.
Lemma impl1_refl{T: Type}: forall {P: T -> Prop}, Lift1Prop.impl1 P P.
Proof. intros. reflexivity. Qed.
#[global] Hint Resolve impl1_refl : ecancel_impl.

Lemma iff1_refl{A: Type}(P: A -> Prop): iff1 P P. Proof. reflexivity. Qed.
Lemma iff1_sym{A: Type}{P Q: A -> Prop}: iff1 P Q -> iff1 Q P.
Proof. intros. symmetry. assumption. Qed.

Ltac iff1_syntactic_reflexivity :=
  lazymatch goal with
  | |- iff1 ?x ?y => first [is_evar x | is_evar y | constr_eq x y]
  end;
  exact (iff1_refl _).

Ltac impl1_syntactic_reflexivity :=
  lazymatch goal with
  | |- impl1 ?x ?y => first [is_evar x | is_evar y | constr_eq x y]
  end;
  exact impl1_refl.

Section SepProperties.
  Context {key value} {map : map key value} {ok : ok map}.
  Context {key_eqb: key -> key -> bool} {key_eq_dec: EqDecider key_eqb}.
  Local Open Scope sep_scope.

  Global Instance Proper_sep_iff1 : Proper (@iff1 map ==> iff1 ==> iff1) sep. firstorder idtac. Qed.
  Global Instance Proper_sep_impl1 : Proper (@impl1 map ==> impl1 ==> impl1) sep. firstorder idtac. Qed.

  Ltac t :=
    repeat match goal with
    | _ => progress subst
    | H:_ /\ _ |- _ => destruct H
    | H:exists _, _ |- _ => destruct H
    | H:disjoint (putmany _ _) _ |- _ => eapply disjoint_putmany_l in H; destruct H
    | H:disjoint _ (putmany _ _) |- _ => eapply disjoint_putmany_r in H; destruct H
    | _ => progress intuition idtac
    end.

  Implicit Types (p q r : map -> Prop) (k : key) (v : value) (m : map).

  (* sep and sep *)
  Lemma sep_comm p q : iff1 (p*q) (q*p).
  Proof. cbv [iff1 sep split]; t; eauto 10 using putmany_comm, (fun m1 m2 => proj2 (disjoint_comm m1 m2)). Qed.
  Lemma sep_assoc p q r : iff1 ((p*q)*r) (p*(q*r)).
  Proof. cbv [iff1 sep split]; t; eauto 15 using eq_sym, putmany_assoc, ((fun m1 m2 m3 => proj2 (disjoint_putmany_l m1 m2 m3))), ((fun m1 m2 m3 => proj2 (disjoint_putmany_r m1 m2 m3))). Qed.

  Lemma get_ptsto k v m (H : ptsto k v m) : get m k = Some v.
  Proof. rewrite H, get_put_same; trivial. Qed.
  Lemma get_sep k v R m (H : sep (ptsto k v) R m) : get m k = Some v.
  Proof.
    destruct H as (mk&mR&H&Hp&HR); eapply get_ptsto in Hp; subst.
    destruct (get_split k _ _ _ H) as [[]|[]]; congruence.
  Qed.
  Lemma sep_get k v m (H : get m k = Some v) :
    sep (ptsto k v) (eq (map.remove m k)) m.
  Proof.
    unfold sep. exists (map.put map.empty k v).
    eexists. repeat split.
    - apply map_ext. intros.
      rewrite get_putmany_dec.
      rewrite get_remove_dec.
      destr (key_eqb k k0).
      + subst. rewrite get_put_same. assumption.
      + rewrite get_put_diff by congruence. rewrite get_empty.
        destruct (get m k0); reflexivity.
    - unfold disjoint. intros.
      destr (key_eqb k k0).
      + subst. rewrite get_remove_same in H1. discriminate.
      + rewrite get_put_diff in H0 by congruence. rewrite get_empty in H0. discriminate.
  Qed.
  Lemma sep_put k v m v_old R (H : sep (ptsto k v_old) R m) : sep (ptsto k v) R (put m k v).
  Proof.
    eapply sep_comm in H; eapply sep_comm.
    destruct H as (mR&mk&[Heq Hd]&HR&Hp); cbv [ptsto] in Hp; subst mk; subst m.
    exists mR, (put empty k v); split; [|solve[repeat split; trivial]]; split.
    { eapply map_ext; intro k'; destruct (key_eq_dec k' k); try subst k';
        rewrite ?get_put_same, ?get_put_diff by trivial.
      { erewrite get_putmany_right; trivial. rewrite get_put_same; trivial. }
      { rewrite 2get_putmany_left; trivial. all:rewrite get_put_diff, get_empty; trivial. } }
    { intros k' ? ? ? Hget; intros; destruct (key_eq_dec k' k); try subst k'.
      { eapply Hd; eauto using get_put_same. }
      { rewrite get_put_diff, get_empty in Hget by trivial; inversion Hget. } }
  Qed.

  Lemma sepeq_on_undef_put: forall m addr b,
      map.get m addr = None ->
      (sep (ptsto addr b) (eq m)) (map.put m addr b).
  Proof.
    intros. unfold sep. exists (map.put map.empty addr b). exists m.
    split; [|split; reflexivity].
    apply map.split_undef_put. assumption.
  Qed.

  Lemma sep_on_undef_put: forall m addr b (R: _ -> Prop),
      map.get m addr = None ->
      R m ->
      (sep (ptsto addr b) R) (map.put m addr b).
  Proof.
    intros. unfold sep. exists (map.put map.empty addr b). exists m.
    split; [|split; reflexivity || trivial].
    apply split_undef_put. assumption.
  Qed.

  Lemma sep_eq_putmany (a b : map) (H : disjoint a b)
    : Lift1Prop.iff1 (eq (putmany a b)) (sep (eq a) (eq b)).
  Proof.
    split.
    { intros; subst. eexists _, _; eauto using Properties.map.split_disjoint_putmany. }
    { intros (?&?&(?&?)&?&?); subst; trivial. }
  Qed.

  Lemma iff1_sep_cancel p q1 q2 (H : iff1 q1 q2) : iff1 (p * q1) (p * q2).
  Proof. exact (Proper_sep_iff1 _ _ (reflexivity _) _ _ H). Qed.

  (* More Conntectives *)
  Global Instance Proper_emp_iff : Proper (iff ==> @iff1 map) emp. firstorder idtac. Qed.
  Global Instance Proper_emp_impl : Proper (Basics.impl ==> @impl1 map) emp. firstorder idtac. Qed.

  (* sep and and *)

  Lemma sep_and_l_fwd P Q R m : sep (fun m => P m /\ Q m) R m -> sep P R m /\ sep Q R m.
  Proof. cbv [sep]. intros (?&?&?&(?&?)&?); eauto 10. Qed.
  Lemma sep_and_r_fwd P Q R m : sep R (fun m => P m /\ Q m) m -> sep R P m /\ sep R Q m.
  Proof. cbv [sep]. intros (?&?&?&?&(?&?)); eauto 10. Qed.

  (* sep and emp *)
  Lemma sep_emp_emp P Q : @iff1 map (sep (emp P) (emp Q)) (emp (P /\ Q)).
  Proof. cbv [iff1 sep emp split]; t; intuition eauto 20 using putmany_empty_l, disjoint_empty_l. Qed.
  Lemma sep_comm_emp_r p Q : iff1 (p * emp Q) (emp Q * p). eapply sep_comm. Qed.
  Lemma sep_emp_2 p Q r : iff1 (p * (emp Q * r)) (emp Q * (p * r)).
  Proof. rewrite <-sep_assoc. rewrite (sep_comm p). rewrite sep_assoc. reflexivity. Qed.
  Lemma sep_emp_12 P Q r : iff1 (emp P * (emp Q * r)) (emp (P /\ Q) * r).
  Proof. rewrite <-sep_assoc. rewrite sep_emp_emp. reflexivity. Qed.

  Lemma sep_emp_l a b m : sep (emp a) b m <-> a /\ b m.
  Proof.
    split.
    { intros (?&?&(?&?)&(?&?)&?); subst; rewrite putmany_empty_l; auto. }
    { intros (?&?). exists empty, m.
      cbv [emp]; edestruct split_empty_l; intuition eauto. }
  Qed.
  Lemma sep_emp_r a b m : sep a (emp b) m <-> a m /\ b.
  Proof.
    setoid_rewrite (and_comm _ b).
    setoid_rewrite sep_comm || (etransitivity; [eapply sep_comm|]). (* WHY? *)
    eapply sep_emp_l.
  Qed.
  Lemma sep_emp_True_l p : iff1 (sep (emp True) p) p.
  Proof. intros m; rewrite sep_emp_l; intuition idtac. Qed.
  Lemma sep_emp_True_r p : iff1 (sep p (emp True)) p.
  Proof. intros m; rewrite sep_emp_r; intuition idtac. Qed.

  (* sep and ex1 *)
  Lemma sep_ex1_r {T} p (q:T->_) : iff1 (p * ex1 q) (ex1 (fun h => p * q h)).
  Proof. firstorder idtac. Qed.
  Lemma sep_ex1_l {T} p (q:T->_) : iff1 (ex1 q * p) (ex1 (fun h => q h * p)).
  Proof. rewrite sep_comm. rewrite sep_ex1_r. setoid_rewrite (sep_comm p). reflexivity. Qed.

  (* impl1 and emp *)
  Lemma impl1_l_sep_emp (a:Prop) r c : impl1 (emp a * r) c <-> (a -> impl1 r c).
  Proof. cbv [impl1 emp sep split]; t; rewrite ?putmany_empty_l; eauto 10 using putmany_empty_l, disjoint_empty_l. Qed.
  Lemma impl1_r_sep_emp p b c : (b /\ impl1 p c) -> impl1 p (emp b * c).
  Proof. cbv [impl1 emp sep split]; t; eauto 10 using putmany_empty_l, disjoint_empty_l. Qed.

(** shallow reflection from a list of predicates for faster cancellation proofs *)
  Fixpoint seps' (xs : list (map -> Prop)) : map -> Prop :=
    match xs with
    | cons x xs => sep x (seps' xs)
    | nil => emp True
    end.
  Remark seps'_fold_right: seps' = List.fold_right sep (emp True). reflexivity. Qed.
  Lemma seps'_iff1_seps xs : iff1 (seps' xs) (seps xs).
  Proof.
    induction xs; [exact (reflexivity _)|].
    destruct xs; [solve[eauto using sep_emp_True_r]|].
    eapply Proper_sep_iff1, IHxs.
    exact (reflexivity _).
  Qed.
  Lemma seps_cons(P: map -> Prop)(Ps: list (map -> Prop)):
    iff1 (seps (P :: Ps)) (sep P (seps Ps)).
  Proof. rewrite <-! seps'_iff1_seps. reflexivity. Qed.
  Lemma seps_app(Ps Qs: list (map -> Prop)):
    iff1 (seps (Ps ++ Qs)) (sep (seps Ps) (seps Qs)).
  Proof.
    induction Ps.
    - simpl. symmetry. apply sep_emp_True_l.
    - rewrite <- List.app_comm_cons. rewrite! seps_cons. rewrite IHPs.
      symmetry. apply sep_assoc.
  Qed.

  Definition hd {T} := Eval cbv delta in @List.hd T.
  Definition tl {T} := Eval cbv delta in @List.tl T.
  Definition firstn {T} := Eval cbv delta in @List.firstn T.
  Definition skipn {T} := Eval cbv delta in @List.skipn T.
  Definition app {T} := Eval cbv delta in @List.app T.

  Local Infix "++" := app. Local Infix "++" := app : list_scope.
  Let nth n xs := hd (emp(map:=map) True) (skipn n xs).
  Let remove_nth n (xs : list (map -> Prop)) :=
    (firstn n xs ++ tl (skipn n xs)).
  Let replace_nth n (P: map -> Prop) (xs : list (map -> Prop)) :=
    (firstn n xs ++ P :: tl (skipn n xs)).

  Lemma seps_nth_to_head n xs : iff1 (sep (nth n xs) (seps (remove_nth n xs))) (seps xs).
  Proof.
    cbv [nth remove_nth].
    pose proof (List.firstn_skipn n xs : (firstn n xs ++ skipn n xs) = xs).
    set (xsr := skipn n xs) in *; clearbody xsr.
    set (xsl := firstn n xs) in *; clearbody xsl.
    subst xs.
    setoid_rewrite <-seps'_iff1_seps.
    destruct xsr.
    { cbn [seps']; rewrite sep_emp_True_l, 2List.app_nil_r; exact (reflexivity _). }
    cbn [hd tl].
    induction xsl; cbn; [exact (reflexivity _)|].
    rewrite <-IHxsl; clear IHxsl.
    rewrite (sep_comm _ (seps' _)), <-(sep_assoc _ (seps' _)), <-(sep_comm _ (_ * seps' _)).
    exact (reflexivity _).
  Qed.

  Lemma cancel_emps_at_indices i j xs ys P Q
        (Hi : nth i xs = emp P)
        (Hj : nth j ys = emp Q)
        (HPQ : P <-> Q)
        (Hrest : iff1 (seps (remove_nth i xs)) (seps (remove_nth j ys)))
    : iff1 (seps xs) (seps ys).
  Proof.
    rewrite <-(seps_nth_to_head i xs), <-(seps_nth_to_head j ys), Hi, Hj, Hrest.
    unfold iff1 in *. intro m. do 2 rewrite sep_emp_l. intuition idtac.
  Qed.

  (* iff1 instead of eq as a hyp would be a more general lemma, but eq is more convenient to use *)
  Lemma cancel_seps_at_indices i j xs ys
        (Hij : nth i xs = nth j ys)
        (Hrest : iff1 (seps (remove_nth i xs)) (seps (remove_nth j ys)))
    : iff1 (seps xs) (seps ys).
  Proof.
    rewrite <-(seps_nth_to_head i xs), <-(seps_nth_to_head j ys), Hij, Hrest.
    exact (reflexivity _).
  Qed.

  (* Analogous to cancel_seps_at_indices, but works with implication rather than eq.
     TODO: If this lemma's dependencies become general enough, should we deprecate cancel_seps_at_indices?
   *)
  Lemma cancel_seps_at_indices_by_implication i j xs ys
        (Hij : Lift1Prop.impl1 (nth i xs) (nth j ys))
        (Hrest : Lift1Prop.impl1 (seps (remove_nth i xs)) (seps (remove_nth j ys)))
    : Lift1Prop.impl1 (seps xs) (seps ys).
  Proof.
    rewrite <-(seps_nth_to_head i xs), <-(seps_nth_to_head j ys).
    rewrite Hij, Hrest.
    exact (reflexivity _).
  Qed.

  Lemma cancel_emp_at_index_l i xs ys
        (Hi : nth i xs = emp True)
        (Hrest : iff1 (seps (remove_nth i xs)) (seps ys))
    : iff1 (seps xs) (seps ys).
  Proof.
    rewrite <-(seps_nth_to_head i xs), Hi, Hrest. exact (sep_emp_True_l _).
  Qed.
  Lemma cancel_emp_at_index_r j xs ys
        (Hj : nth j ys = emp True)
        (Hrest : iff1 (seps xs) (seps (remove_nth j ys)))
    : iff1 (seps xs) (seps ys).
  Proof.
    rewrite <-(seps_nth_to_head j ys), Hj, Hrest, sep_emp_True_l.
    exact (reflexivity _).
  Qed.

  Lemma cancel_emp_at_index_impl j xs ys
        (Hj : nth j ys = emp True)
        (Hrest : impl1 (seps xs) (seps (remove_nth j ys)))
    : impl1 (seps xs) (seps ys).
  Proof.
    rewrite <-(seps_nth_to_head j ys), Hj, Hrest, sep_emp_True_l.
    exact (reflexivity _).
  Qed.

  Lemma extract_emp_in_hyp_at_index i xs m P
        (Hi : nth i xs = emp P)
        (H : seps xs m)
    : P /\ seps (remove_nth i xs) m.
  Proof.
    eapply (seps_nth_to_head i xs) in H. rewrite Hi in H.
    eapply sep_emp_l in H. exact H.
  Qed.

  Lemma extract_emp_in_goal_at_index i xs m P
        (Hi : nth i xs = emp P)
        (NewGoal : seps (remove_nth i xs) m /\ P)
    : seps xs m.
  Proof.
    eapply (seps_nth_to_head i xs). rewrite Hi.
    eapply sep_comm. eapply sep_emp_r. exact NewGoal.
  Qed.

  Lemma extract_emp_in_goal_with_and_at_index i xs m P C
        (Hi : nth i xs = emp P)
        (NewGoal : seps (remove_nth i xs) m /\ P /\ C)
    : seps xs m /\ C.
  Proof.
    destruct NewGoal as (HN & HP & HC). split; [|exact HC].
    eapply (extract_emp_in_goal_at_index i); eauto.
  Qed.

  Lemma replace_nth_sep_remove_nth i P xs :
      iff1 (seps (replace_nth i P xs))
           (sep P (seps (remove_nth i xs))).
  Proof.
    unfold replace_nth, remove_nth.
    rewrite ?seps_app, ?seps_cons.
    rewrite <-?sep_assoc.
    rewrite (sep_comm P).
    reflexivity.
  Qed.

  Lemma extract_ex1_in_hyp_at_index{A : Type} i xs m (P: A -> map -> Prop)
        (Hi : nth i xs = ex1 P)
        (H : seps xs m)
    : exists a, seps (replace_nth i (P a) xs) m.
  Proof.
    eapply (seps_nth_to_head i xs) in H. rewrite Hi in H.
    eapply sep_ex1_l in H. unfold ex1 in H. destruct H as [a H]. exists a.
    eapply replace_nth_sep_remove_nth. exact H.
  Qed.

  Lemma extract_ex1_in_goal_at_index{A : Type} i xs m (P: A -> map -> Prop) a
        (Hi : nth i xs = ex1 P)
        (NewGoal : seps (replace_nth i (P a) xs) m)
    : seps xs m.
  Proof.
    eapply (seps_nth_to_head i xs). rewrite Hi.
    eapply sep_ex1_l. unfold ex1. exists a.
    eapply replace_nth_sep_remove_nth. exact NewGoal.
  Qed.

  Lemma extract_ex1_in_goal_with_and_at_index{A : Type} i xs m (P: A -> map -> Prop) a C
        (Hi : nth i xs = ex1 P)
        (NewGoal : seps (replace_nth i (P a) xs) m /\ C)
    : seps xs m /\ C.
  Proof.
    destruct NewGoal as (HN & HC). split; [|exact HC].
    eapply (extract_ex1_in_goal_at_index i); eauto.
  Qed.
End SepProperties.

Require Import coqutil.Tactics.syntactic_unify coqutil.Tactics.rdelta.

Notation "X '========' 'seps' 'iff' '========' Y" :=
  (Lift1Prop.iff1 (seps X) (seps Y))
    (at  level 200, no associativity,
     format "X '//' '========'  'seps'  'iff'  '========' '//' Y").

Module Tree.
  Inductive Tree(A: Type): Type :=
  | Leaf(a: A)
  | Node(left right: Tree A).
  Arguments Leaf {A} _.
  Arguments Node {A} _ _.
  Section Interp.
    Context {A B: Type}.
    Context (interp_Leaf: A -> B).
    Context (interp_Node: B -> B -> B).
    Fixpoint interp(t: Tree A): B :=
      match t with
      | Leaf a => interp_Leaf a
      | Node t1 t2 => interp_Node (interp t1) (interp t2)
      end.
  End Interp.

  Definition flatten{A: Type}: Tree A -> list A := interp (fun a => cons a nil) (@app A).

  Section WithMap.
    Context {key value} {map : map key value} {ok : ok map}.
    Context {key_eqb: key -> key -> bool} {key_eq_dec: EqDecider key_eqb}.

    Definition to_sep: Tree (map -> Prop) -> map -> Prop := interp (fun x => x) sep.

    Lemma flatten_iff1_to_sep(t : Tree.Tree (map -> Prop)):
      Lift1Prop.iff1 (seps (flatten t)) (to_sep t).
    Proof.
      induction t; [reflexivity|].
      simpl. rewrite seps_app. rewrite IHt1, IHt2. reflexivity.
    Qed.

    Lemma iff1_to_sep_of_iff1_flatten(LHS RHS : Tree (map -> Prop)):
      Lift1Prop.iff1 (seps (flatten LHS)) (seps (flatten RHS)) ->
      Lift1Prop.iff1 (to_sep LHS) (to_sep RHS).
    Proof. rewrite! flatten_iff1_to_sep. exact id. Qed.

    Lemma impl1_to_sep_of_impl1_flatten(LHS RHS : Tree (map -> Prop)):
      Lift1Prop.impl1 (seps (flatten LHS)) (seps (flatten RHS)) ->
      Lift1Prop.impl1 (to_sep LHS) (to_sep RHS).
    Proof. rewrite! flatten_iff1_to_sep. exact id. Qed.

    Lemma flatten_to_sep_with_and(t : Tree.Tree (map -> Prop))(m: map)(C: Prop):
      seps (flatten t) m /\ C -> to_sep t m /\ C.
    Proof.
      intros (H & HC). refine (conj _ HC). eapply flatten_iff1_to_sep. exact H.
    Qed.
  End WithMap.
End Tree.

Ltac reify e :=
  lazymatch e with
  | @sep ?key ?value ?map ?a ?b =>
    let a := reify a in
    let b := reify b in
    uconstr:(@Tree.Node (@map.rep key value map -> Prop) a b)
  | ?a => uconstr:(Tree.Leaf a)
  end.

Ltac reify_goal :=
  lazymatch goal with
  | |- Lift1Prop.iff1 ?LHS ?RHS =>
    let LHS := reify LHS in
    let RHS := reify RHS in
    change (Lift1Prop.iff1 (Tree.to_sep LHS) (Tree.to_sep RHS));
    eapply Tree.iff1_to_sep_of_iff1_flatten
  | |- Lift1Prop.impl1 ?LHS ?RHS =>
    let LHS := reify LHS in
    let RHS := reify RHS in
    change (Lift1Prop.impl1 (Tree.to_sep LHS) (Tree.to_sep RHS));
    eapply Tree.impl1_to_sep_of_impl1_flatten
  end;
  cbv [Tree.flatten Tree.interp app].

(* Given `H: seplogformula m`, first cbvs away all occurrences of `seps` in H,
   and then flattens the formula into a list of sep clauses, resulting in an
   `H: seps [...] m` *)
Ltac flatten_seps_in H :=
  lazymatch type of H with
  | ?nested ?m =>
    let tmem := type of m in
    let E := fresh "E" in
    eassert (@iff1 tmem nested _) as E;
    [ (* from `nested` to `Tree.to_sep tree` *)
      let stars := eval cbv [seps] in nested in
      let tree := reify stars in
      transitivity (Tree.to_sep tree); [
        cbv [seps Tree.to_sep Tree.interp]; iff1_syntactic_reflexivity
      |];
      (* from `Tree.to_sep tree` to `seps (Tree.flatten tree)` *)
      transitivity (seps (Tree.flatten tree)); [
        exact (iff1_sym (Tree.flatten_iff1_to_sep tree))
      |];
      (* from `seps (Tree.flatten tree)` to `seps clauses` *)
      cbv [SeparationLogic.Tree.flatten SeparationLogic.Tree.interp SeparationLogic.app];
      iff1_syntactic_reflexivity
    | let HNew := fresh in pose proof (proj1 (E m) H) as HNew;
      move HNew before H;
      clear E H;
      rename HNew into H ]
  end.

(* Given a goal of shape `seplogformula m`, first cbns away all occurrences of
   `seps` in H, and then flattens the formula into a list of sep clauses, resulting
   in a goal of shape `seps [...] m` *)
Ltac flatten_seps_in_goal :=
  cbv [seps];
  lazymatch goal with
  | |- ?nested ?m /\ ?C =>
      let xs := reify nested in
      change (Tree.to_sep xs m /\ C);
      eapply Tree.flatten_to_sep_with_and
  | |- ?nested ?m =>
      let xs := reify nested in
      change (Tree.to_sep xs m);
      eapply Tree.flatten_iff1_to_sep
  end;
  cbv [Tree.flatten Tree.interp app].

Ltac cancel_emp_l :=
  lazymatch goal with
  | |- Lift1Prop.iff1 (@seps ?K ?V ?M ?LHS) (seps ?RHS) =>
    let i := find_constr_eq LHS constr:(@emp K V M True) in
    simple refine (cancel_emp_at_index_l i LHS RHS _ _);
    cbv [firstn skipn app hd tl];
    [syntactic_exact_deltavar (@eq_refl _ _)|]
  end.

Ltac cancel_emp_r :=
  lazymatch goal with
  | |- Lift1Prop.iff1 (seps ?LHS) (@seps ?K ?V ?M ?RHS) =>
    let j := find_constr_eq RHS constr:(@emp K V M True) in
    simple refine (cancel_emp_at_index_r j LHS RHS _ _);
    cbv [firstn skipn app hd tl];
    [syntactic_exact_deltavar (@eq_refl _ _)|]
  end.

(* TODO: should this eventually subsume the one above?*)
Ltac cancel_emp_impl :=
  lazymatch goal with
  | |- Lift1Prop.impl1 (seps ?LHS) (@seps ?K ?V ?M ?RHS) =>
    let j := find_constr_eq RHS constr:(@emp K V M True) in
    (*TODO: replace lemma*)
    simple refine (cancel_emp_at_index_impl j LHS RHS _ _);
    cbv [firstn skipn app hd tl];
    (*TODO: use more complicated solver here?*)
    [syntactic_exact_deltavar (@eq_refl _ _)|]
  end.

(* leaves two open goals:
   1) equality between left sep clause #i and right sep clause #j
   2) updated main goal *)
Ltac cancel_seps_at_indices i j :=
  lazymatch goal with
  | |- Lift1Prop.iff1 (seps ?LHS) (seps ?RHS) =>
    simple refine (cancel_seps_at_indices i j LHS RHS _ _);
    cbv [firstn skipn app hd tl]
  end.

(* Analogous to cancel_seps_at_indices, but works with implication rather than eq.
   TODO: If this tactic's dependencies become general enough, should we deprecate cancel_seps_at_indices?
 *)
(* leaves two open goals:
   1) implication between left sep clause #i and right sep clause #j
   2) updated main goal *)
Ltac cancel_seps_at_indices_by_implication i j :=
  lazymatch goal with
  | |- Lift1Prop.impl1 (seps ?LHS) (seps ?RHS) =>
    simple refine (cancel_seps_at_indices_by_implication i j LHS RHS _ _);
    cbv [firstn skipn app hd tl]
  end.

(*TODO: performance*)
Ltac find_implication xs y :=
  multimatch xs with
  | cons ?x _ => constr:(O)
  | cons _ ?xs => let i := find_implication xs y in constr:(S i)
  end.

Ltac cancel_step := once (
      let RHS := lazymatch goal with |- Lift1Prop.iff1 _ (seps ?RHS) => RHS end in
      let jy := index_and_element_of RHS in (* <-- multi-success! *)
      let j := lazymatch jy with (?i, _) => i end in
      let y := lazymatch jy with (_, ?y) => y end in
      assert_fails (has_evar y); (* <-- different from ecancel_step *)
      let LHS := lazymatch goal with |- Lift1Prop.iff1 (seps ?LHS) _ => LHS end in
      let i := find_constr_eq LHS y in (* <-- different from ecancel_step *)
      cancel_seps_at_indices i j; [exact eq_refl|]). (* already unified using constr_eq *)

Ltac ecancel_step :=
      let RHS := lazymatch goal with |- Lift1Prop.iff1 _ (seps ?RHS) => RHS end in
      let jy := index_and_element_of RHS in (* <-- multi-success! *)
      let j := lazymatch jy with (?i, _) => i end in
      let y := lazymatch jy with (_, ?y) => y end in
      assert_fails (idtac; let y := rdelta_var y in is_evar y);
      let LHS := lazymatch goal with |- Lift1Prop.iff1 (seps ?LHS) _ => LHS end in
      let i := find_syntactic_unify_deltavar LHS y in (* <-- multi-success! *)
      cancel_seps_at_indices i j; [exact eq_refl|]. (* already unified using syntactic_unify *)

(* TODO: eventually replace ecancel_step? Probably not since implication is too agressive.*)
(*TODO: performance. I've replaced the deltavar stuff with heavier operations  *)
Ltac ecancel_step_by_implication :=
      let RHS := lazymatch goal with |- Lift1Prop.impl1 _ (seps ?RHS) => RHS end in
      let jy := index_and_element_of RHS in (* <-- multi-success! *)
      let j := lazymatch jy with (?i, _) => i end in
      let y := lazymatch jy with (_, ?y) => y end in
      assert_fails (idtac; let y := rdelta_var y in is_evar y);
      let LHS := lazymatch goal with |- Lift1Prop.impl1 (seps ?LHS) _ => LHS end in
      let i := find_implication LHS y in (* <-- multi-success! *)
      cancel_seps_at_indices_by_implication i j; [solve [auto 1 with nocore ecancel_impl]|].

Ltac ecancel_done :=
  cbv [seps];
  syntactic_exact_deltavar
    (@RelationClasses.reflexivity _ _
        (@RelationClasses.Equivalence_Reflexive _ _ (@Equivalence_iff1 _)) _).

(* might be slightly less efficient than ecancel_done because it uses [exact] instead of
   [exact_no_check], but it gives better error messages in case of evar scoping problems,
   because [syntactic_exact_deltavar] calls [unify], which gives no details about evar
   scoping problems, while the [exact] called below does give details *)
Ltac ecancel_done' :=
  cbv [seps];
  match goal with
  | |- iff1 ?x ?y => first [is_evar x | is_evar y | constr_eq x y]
  end;
  exact
    (@RelationClasses.reflexivity _ _
       (@RelationClasses.Equivalence_Reflexive _ _ (@Equivalence_iff1 _)) _).

Ltac cancel_done :=
  lazymatch goal with
  | |- iff1 (seps (cons _ nil)) _ => idtac
  | |- iff1 _ (seps (cons _ nil )) => idtac
  | |- ?g => assert_fails (has_evar g)
  end;
  ecancel_done.

Ltac cancel_seps :=
  repeat cancel_step;
  repeat cancel_emp_l;
  repeat cancel_emp_r;
  repeat cancel_emp_impl;
  try solve [ cancel_done ].

Ltac cancel := reify_goal; cancel_seps.

Ltac ecancel :=
  cancel;
  lazymatch goal with
  | [|- impl1 _ _] =>
     repeat ecancel_step_by_implication;
     (solve [ cbv [seps]; exact impl1_refl ])
  | [|- iff1 _ _] =>
    repeat ecancel_step;
    solve [ ecancel_done ]
  end.

Ltac ecancel_assumption :=
  multimatch goal with
  | |- _ ?m1 =>
    multimatch goal with
    | H: _ ?m2 |- _ =>
      syntactic_unify_deltavar m1 m2;
      refine (Lift1Prop.subrelation_iff1_impl1 _ _ _ _ _ H); clear H;
      solve [ecancel]
    end
  end.

 Ltac ecancel_assumption_impl :=
    multimatch goal with
    | |- ?PG ?m1 =>
      multimatch goal with
      | H: ?PH ?m2
        |- _ =>
        syntactic_unify_deltavar m1 m2;
        (*TODO: can I just revert H?*)
        refine (Morphisms.subrelation_refl Lift1Prop.impl1 PH PG _ m1 H);
        clear H;
        solve[ecancel]
      end
    end.

 (* To use the implication-based ecancel assumption in existing tactics in a proof, add this line:

    Local Ltac ecancel_assumption ::= ecancel_assumption_impl.

    The implication-based tactic should in theory solve a strict superset of goals,
    but its performance may be worse, especially when it fails.
  *)

Ltac use_sep_assumption :=
  match goal with
  | |- _ ?m1 =>
    match goal with
    | H: _ ?m2 |- _ =>
      unify m1 m2;
      refine (Lift1Prop.subrelation_iff1_impl1 _ _ _ _ _ H); clear H
    end
  end.

Ltac seplog :=
  use_sep_assumption;
  cancel;
  try solve [ repeat ecancel_step; cbv [seps]; exact (RelationClasses.reflexivity _) ].

Ltac seprewrite0_in Hrw H :=
  let lemma_lhs := lazymatch type of Hrw with @Lift1Prop.iff1 _ ?lhs _ => lhs end in
  let Psep := lazymatch type of H with ?P _ => P end in
  let mem := lazymatch type of Psep with ?mem -> _ => mem end in
  lazymatch mem with
  | @map.rep _ _ _ => idtac
  | _ => fail "hypothesis must be of form 'P m'"
  end;
  let pf := fresh in
  (* COQBUG(faster use ltac:(...) here if that was multi-success *)
  eassert (@Lift1Prop.iff1 mem Psep (sep lemma_lhs _)) as pf
      by (ecancel || fail "failed to find" lemma_lhs "in" Psep "using ecancel");
  let H' := fresh H in (* rename H into H' (* COGBUG(9937) *) *)
  epose proof (proj1 (Proper_sep_iff1 _ _ Hrw _ _ (RelationClasses.reflexivity _) _) (proj1 (pf _) H)) as H';
  clear H pf; rename H' into H.

Ltac seprewrite_in Hrw H :=
  multimatch constr:(Set) with
  | _ => unshelve
           (let Hrw := open_constr:(Hrw _) in seprewrite_in Hrw H);
         shelve_unifiable
  | _ => seprewrite0_in Hrw H
  end.

(* last side-condition is solved first *)
Ltac seprewrite_in_by Hrw H tac :=
  multimatch constr:(Set) with
  | _ => unshelve
           (let Hrw := open_constr:(Hrw _) in seprewrite_in_by Hrw H tac);
         shelve_unifiable;
         [solve [tac].. | ]
  | _ => seprewrite0_in Hrw H
  end.

(* the same (but slightly different) for rewriting in the goal
   TODO can we do with less duplication, but without unreadable abstraction? *)

Ltac seprewrite0 Hrw :=
  let lemma_lhs := lazymatch type of Hrw with @Lift1Prop.iff1 _ ?lhs _ => lhs end in
  let Psep := lazymatch goal with |- ?P _ => P end in
  let mem := lazymatch type of Psep with ?mem -> _ => mem end in
  lazymatch mem with
  | @map.rep _ _ _ => idtac
  | _ => fail "goal must be of form 'P m'"
  end;
  let pf := fresh in
  (* COQBUG(faster use ltac:(...) here if that was multi-success *)
  eassert (@Lift1Prop.iff1 mem Psep (sep lemma_lhs _)) as pf
      by (ecancel || fail "failed to find" lemma_lhs "in" Psep "using ecancel");
  eapply (fun m => (proj2 (pf m))); clear pf; (* <-- note: proj2 instead of proj1 *)
  eapply (Proper_sep_iff1 _ _ Hrw _ _ (RelationClasses.reflexivity _) _).

Ltac seprewrite Hrw :=
  multimatch constr:(Set) with
  | _ => unshelve
           (let Hrw := open_constr:(Hrw _) in seprewrite Hrw);
         shelve_unifiable
  | _ => seprewrite0 Hrw
  end.

(* last side-condition is solved first *)
Ltac seprewrite_by Hrw tac :=
  multimatch constr:(Set) with
  | _ => unshelve
           (let Hrw := open_constr:(Hrw _) in seprewrite_by Hrw tac);
         shelve_unifiable;
         [solve [tac].. | ]
  | _ => seprewrite0 Hrw
  end.

(* a convenient way to turn iff1 into eq, so that it can be used with our own equality-based
   (rather than Morphism-based) rewriters. *)
Require Import Coq.Logic.PropExtensionality.
Require Import Coq.Logic.FunctionalExtensionality.
Lemma iff1ToEq{T: Type}{P Q: T -> Prop}(H: iff1 P Q): P = Q.
Proof.
  unfold iff1 in *. extensionality x.
  eapply propositional_extensionality.
  eapply H.
Qed.

Ltac is_emp P :=
  lazymatch P with
  | emp _ => constr:(true)
  | _ => constr:(false)
  end.

Ltac is_ex1 P :=
  lazymatch P with
  | ex1 _ => constr:(true)
  | _ => constr:(false)
  end.

Ltac extract_ex1_step_in H :=
  match type of H with
  | seps ?xs _ =>
      lazymatch find_in_list ltac:(is_ex1) xs with
      | (?j, ex1 ?Q) =>
          apply extract_ex1_in_hyp_at_index with (i := j) (P := Q) in H;
          [ cbv [firstn skipn app hd tl] in H
          | cbv [firstn skipn app hd tl]; syntactic_exact_deltavar (@eq_refl _ _) ];
          let name := lazymatch Q with
                      | fun e => _ => fresh e
                      | _ => fresh "e"
                      end in
          destruct H as [name H]
      end
  end.

Ltac extract_emp_step_in H :=
  match type of H with
  | seps ?xs _ =>
      lazymatch find_in_list ltac:(is_emp) xs with
      | (?j, emp ?Q) =>
          apply extract_emp_in_hyp_at_index with (i := j) (P := Q) in H;
          [ cbv [firstn skipn app hd tl] in H
          | cbv [firstn skipn app hd tl]; syntactic_exact_deltavar (@eq_refl _ _) ];
          let name := fresh H "_emp0" in
          destruct H as [name H]
      end
  end.

Ltac extract_ex1_and_emp_in0 H :=
  repeat first [ extract_ex1_step_in H
               | extract_emp_step_in H
               | flatten_seps_in H ].

Ltac extract_ex1_and_emp_in H :=
  extract_ex1_and_emp_in0 H; cbv [seps] in H.

Ltac extract_ex1_and_emp_in_hyps :=
  repeat match goal with
         | H: _ |- _ => progress extract_ex1_and_emp_in H
         end.

Ltac extract_ex1_step_in_goal :=
  match goal with
  | |- seps ?xs _ /\ _ =>
      lazymatch find_in_list ltac:(is_ex1) xs with
      | (?j, ex1 _) =>
          eapply (extract_ex1_in_goal_with_and_at_index j);
          cbv [firstn skipn app hd tl];
          [ syntactic_exact_deltavar (@eq_refl _ _) | ]
      end
  | |- seps ?xs _ =>
      lazymatch find_in_list ltac:(is_ex1) xs with
      | (?j, ex1 _) =>
          eapply (extract_ex1_in_goal_at_index j);
          cbv [firstn skipn app hd tl];
          [ syntactic_exact_deltavar (@eq_refl _ _) | ]
      end
  end.

Ltac extract_emp_step_in_goal :=
  lazymatch goal with
  | |- seps ?xs _ =>
      lazymatch find_in_list_bw ltac:(is_emp) xs with
      | (?j, emp _) =>
          eapply (extract_emp_in_goal_at_index j);
          cbv [firstn skipn app hd tl];
          [ syntactic_exact_deltavar (@eq_refl _ _) | ]
      end
  | |- seps ?xs _  /\ _ =>
      lazymatch find_in_list_bw ltac:(is_emp) xs with
      | (?j, emp _) =>
          eapply (extract_emp_in_goal_with_and_at_index j);
          cbv [firstn skipn app hd tl];
          [ syntactic_exact_deltavar (@eq_refl _ _) | ]
      end
  end.

Ltac extract_ex1_and_emp_in_goal0 :=
  repeat first [extract_ex1_step_in_goal | flatten_seps_in_goal];
  repeat extract_emp_step_in_goal.

Ltac extract_ex1_and_emp_in_goal :=
   extract_ex1_and_emp_in_goal0; cbv [seps].

Section Tests.
  Context {key value} {map : map key value} {ok : ok map}.
  Context {key_eqb: key -> key -> bool} {key_eq_dec: EqDecider key_eqb}.
  Local Open Scope sep_scope.
  Import List.ListNotations.

  Goal forall (a1 a2: key) (v1 v1': value) (m: map)
      (H: (ptsto a1 v1 * ex1 (fun y => emp (0 < y)%nat * ex1 (fun v => ptsto a2 v)))%sep m)
      (OtherH: v1 = v1'),
      (ex1 (fun z => ex1 (fun y => ptsto a2 y) * emp (0 < z)%nat) *
       ptsto a1 v1 * emp (v1 = v1'))%sep m.
  Proof.
    intros.
    extract_ex1_and_emp_in H.
    extract_ex1_and_emp_in_goal.
    eapply sep_comm in H.
    eauto.
    all: fail.
  Abort.

  Goal forall (a1 a2: key) (v1 v1': value) (m: map)
      (H: (ptsto a1 v1 * ex1 (fun y => emp (0 < y)%nat * ex1 (fun v => ptsto a2 v)))%sep m)
      (OtherH: v1 = v1'),
      (ex1 (fun z => ex1 (fun y => ptsto a2 y) * emp (0 < z)%nat) *
       ptsto a1 v1 * emp (v1 = v1'))%sep m /\ v1 = v1'.
  Proof.
    intros.
    extract_ex1_and_emp_in H.
    extract_ex1_and_emp_in_goal.
    eapply sep_comm in H.
    eauto.
    all: fail.
  Abort.
End Tests.


Require Import list_examples.

Definition dealloc_body :=
 (If (Var 0) (Let (Deref (Var 0)) (Lam
   (Seq (Dealloc (Var 1))
        ((Var 2) (Cdr (Var 0))))))
   Nil).

Inductive dealloc_spec : Spec cfg :=
  dealloc_claim : forall l r env, exp_val dealloc_spec
  dealloc_body (r::fix_env (Lam dealloc_body) env)
    (rep_list l r) (fun v => constraint (v = Nil)).

Lemma dealloc_proof : sound lam_step dealloc_spec.
Proof. list_solver. Qed.


Require Import Coqlib.
Require Import Asm.
Require Import PeekTactics.
Require Import UseBasic.
Require Import PeepsLib.
Require Import PregTactics.
Require Import StepIn.
Require Import AsmBits.
Require Import Values.
Require Import ValEq.
Require Import Integers.
Require Import PeepsTactics.

(*TODO: Replace with newer version*)
Ltac prep_r :=
  T0 _destruct state_bits;
    NP0 app_new step_fwd_exec step_fwd; eauto;
  repeat break_and;
  P0 _clear step_through;
  P0 _clear step_fwd;
  P0 _clear current_fn;
  NP app_new mem_eq_match_metadata_r MemEq.mem_eq.

(*from chomp*)
(*xorl  %edx, %edx*)
(*movl  %edx, 0(%ebx,%esi,4)*)
Definition example_addr : addrmode := (Addrmode None None (inl zero)).
Definition peep_xor_to_mov_0_example : code :=
Pxor_r EDX :: Pmov_mr example_addr EDX :: nil.

Section XOR_TO_MOV_0.

  Variable concrete : code.
  Variable r1 : ireg.
  Variable a1 : addrmode.
  Hypothesis a1_r1_neq : ~ (In (IR r1) (use_addr a1)).

  Definition peep_xor_to_mov_0_defs : rewrite_defs :=
    {|
      fnd :=
        Pxor_r r1 ::
               Pmov_mr a1 r1 ::
               nil
      ; rpl :=
          Pnop ::
               Pmov_mi a1 zero ::
                  nil
      ; lv_in := (PC :: (use_addr a1))
      ; lv_out := (PC :: (use_addr a1))
      ; clobbered := IR r1 :: flags
    |}.

  Lemma peep_xor_to_mov_0_selr:
    StepEquiv.step_through_equiv_live (fnd peep_xor_to_mov_0_defs) (rpl peep_xor_to_mov_0_defs) (lv_in peep_xor_to_mov_0_defs) (lv_out peep_xor_to_mov_0_defs).
  Proof.
    prep_l.
    step_l.
    step_l.
    prep_r.
    step_r.

    simpl in H33.
    unfold exec_store_bits in *.
    unfold storev_bits in *.
    repeat (break_match_hyp; try congruence).
    (* prep_exec_instr. *)
    assert (exists
     (rs' : regset) (m' : Memory.Mem.mem) (md'0 : MemoryAxioms.allocator_metadata),
     (forall fn : function,
     exec_instr_bits (env tprog) md' fn (Pmov_mi a1 zero) b
                     (nextinstr rsr) mr = Nxt rs' m' md'0) /\
     (MemBits.store_bits AST.Mint32 mr b0 (Int.unsigned i0) (Vint zero) = Some m') /\
     eval_addrmode_bits (env tprog) md' a1 (nextinstr rsr) = Vptr b0 i0).
    {
      simpl.
      unfold storev_bits in *.
      erewrite eval_addrmode_bits_transf in Heqv.
      2: eauto.
      eapply use_addr_eval_addrmode_bits in Heqv; try congruence.
      simpl_and_clear.
      subst a0.
      rewrite Heqv.
      app MemEq.eq_mem_store Heqo.
      break_and.
      rewrite H34.
      do 3 eexists; split; eauto.
      inv_state.
      eauto.
      subst.
      preg_simpl.
      auto.
      repeat gentle_inv_next.
      subst a0 m1.
      simpl_and_clear.
      subst m0 a.
      intros.
      destruct (preg_eq p r1); try congruence.
      unfold use_addr in H21.
      repeat break_match_hyp; simpl in H21; repeat break_or_reg; try inv_false; preg_simpl;
      apply H13; simpl; auto.
    }
    repeat break_exists.
    repeat break_and.
    rename H38 into Hstr.
    rename H39 into Haddr.
    step_r.
    assert (x5 = md').
    specialize (H21 x3).
    simpl_and_clear.
    subst x5.
    finish_r.
    split.
    intros.
    specialize (H21 x3).
    simpl_and_clear.
    unfold storev_bits in *.
    simpl_match_hyp.
    inv_state.
    repeat break_or_reg.
    - preg_simpl.
      repeat find_rewrite_goal.
      simpl.
      reflexivity.
    - simpl_and_clear.
      repeat gentle_inv_next.
      apply val_eq_nextinstr_nf.
      intros.
      bump H13.
      bump a1_r1_neq.
      copy H21.
      unfold use_addr in H21.
      unfold use_addr in H13.
      repeat break_match;
      simpl in H21;
      simpl in H13;
      repeat break_or_reg;
      preg_simpl;
      apply H33;
      simpl;
      auto.
    - specialize (H21 x3).
      simpl_and_clear.
      unfold storev_bits in *.
      simpl_match_hyp.
      inv_state.
      preg_simpl_hyp Heqo.
      eapply MemEq.eq_mem_store in Heqo; eauto.
      repeat break_exists.
      break_and.
      2: simpl; reflexivity.
      gentle_inv_next.
      subst.
      P0 bump MemBits.store_bits.
      inv Haddr.
      replace (Vzero) with (Vint zero) in *.
      rewrite H38 in H34.
      inv_some.
      auto.
      auto.
  Qed.

  Definition peep_xor_to_mov_0_proofs : rewrite_proofs :=
    {|
      defs := peep_xor_to_mov_0_defs
      ; selr := peep_xor_to_mov_0_selr
    |}.

  Definition peep_peep_xor_to_mov_0 :
    concrete = fnd peep_xor_to_mov_0_defs ->
    StepEquiv.rewrite.
  Proof.
    intros.
    peep_tac_mk_rewrite peep_xor_to_mov_0_defs peep_xor_to_mov_0_proofs.
    peep_tac_pres;
    try solve [
          right;
          apply in_or_app; right;
          apply in_cons;
          apply in_or_app; right;
          simpl; auto 20
        ].
    peep_tac_pres;
    try solve [
          right;
          apply in_or_app; right;
          apply in_cons;
          apply in_or_app; right;
          simpl; auto 20
        ].
  Qed.

End XOR_TO_MOV_0.

Definition peep_xor_to_mov_0_rewrite (c : code) : option StepEquiv.rewrite.
  name peep_peep_xor_to_mov_0 p.
  unfold peep_xor_to_mov_0_defs in p.
  simpl in p.
  specialize (p c).
  do 2 set_code_cons c.
  set_code_nil c.
  set_instr_eq i 0%nat peep_xor_to_mov_0_example.
  set_instr_eq i0 1%nat peep_xor_to_mov_0_example.
  set_ireg_eq rd rs.
  Lemma preg_dec':
    forall p q : preg, {p = q} + {p <> q}.
  Proof.
    intros.
    copy (preg_dec p q).
    auto.
  Qed.
  copy (in_dec preg_dec' rs (use_addr a)).
  inversion H.
  exact None.

  specialize (p _ _ H0 eq_refl). exact (Some p).
Defined.

Definition xor_to_mov_0 (c : code) : list StepEquiv.rewrite :=
  collect (map peep_xor_to_mov_0_rewrite (ParamSplit.matched_pat peep_xor_to_mov_0_example c)).


From iris.algebra Require Import lib.frac_auth numbers auth.
From iris.proofmode Require Import proofmode.
From iris.base_logic.lib Require Export invariants.
From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang.
From iris.heap_lang Require Import proofmode notation.
From iris.prelude Require Import options.

Definition newcounter : val := λ: <>, ref #0.
Definition incr : val := rec: "incr" "l" :=
    let: "n" := !"l" in
    if: CAS "l" "n" (#1 + "n") then #() else "incr" "l".
Definition read : val := λ: "l", !"l".

(** Monotone counter *)
Class mcounterG Σ := MCounterG { mcounter_inG : inG Σ (authR max_natUR) }.
Local Existing Instance mcounter_inG.

Definition mcounterΣ : gFunctors := #[GFunctor (authR max_natUR)].

Global Instance subG_mcounterΣ {Σ} : subG mcounterΣ Σ → mcounterG Σ.
Proof. solve_inG. Qed.

Section mono_proof.
  Context `{!heapGS Σ, !mcounterG Σ} (N : namespace).

  Definition mcounter_inv (γ : gname) (l : loc) : iProp Σ :=
    ∃ n, own γ (● (MaxNat n)) ∗ l ↦ #n.

  Definition mcounter (l : loc) (n : nat) : iProp Σ :=
    ∃ γ, inv N (mcounter_inv γ l) ∧ own γ (◯ (MaxNat n)).

  (** The main proofs. *)
  Global Instance mcounter_persistent l n : Persistent (mcounter l n).
  Proof. apply _. Qed.

  Lemma newcounter_mono_spec :
    {{{ True }}} newcounter #() {{{ l, RET #l; mcounter l 0 }}}.
  Proof.
    iIntros (Φ) "_ HΦ". rewrite /newcounter /=. wp_lam. wp_alloc l as "Hl".
    iMod (own_alloc (● (MaxNat O) ⋅ ◯ (MaxNat O))) as (γ) "[Hγ Hγ']";
      first by apply auth_both_valid_discrete.
    iMod (inv_alloc N _ (mcounter_inv γ l) with "[Hl Hγ]").
    { iNext. iExists 0. by iFrame. }
    iModIntro. iApply "HΦ". rewrite /mcounter; eauto 10.
  Qed.

  Lemma incr_mono_spec l n :
    {{{ mcounter l n }}} incr #l {{{ RET #(); mcounter l (S n) }}}.
  Proof.
    iIntros (Φ) "Hl HΦ". iLöb as "IH". wp_rec.
    iDestruct "Hl" as (γ) "[#? Hγf]".
    wp_bind (! _)%E. iInv N as (c) ">[Hγ Hl]".
    wp_load. iModIntro. iSplitL "Hl Hγ"; [iNext; iExists c; by iFrame|].
    wp_pures. wp_bind (CmpXchg _ _ _).
    iInv N as (c') ">[Hγ Hl]".
    destruct (decide (c' = c)) as [->|].
    - iCombine "Hγ Hγf"
        gives %[?%max_nat_included _]%auth_both_valid_discrete.
      iMod (own_update_2 with "Hγ Hγf") as "[Hγ Hγf]".
      { apply auth_update, (max_nat_local_update _ _ (MaxNat (S c))). simpl. auto. }
      wp_cmpxchg_suc. iModIntro. iSplitL "Hl Hγ".
      { iNext. iExists (S c). rewrite Nat2Z.inj_succ Z.add_1_l. by iFrame. }
      wp_pures. iApply "HΦ". iModIntro. iExists γ; repeat iSplit; eauto.
      iApply (own_mono with "Hγf").
      (* FIXME: FIXME(Coq #6294): needs new unification *)
      apply: auth_frag_mono. by apply max_nat_included, le_n_S.
    - wp_cmpxchg_fail; first (by intros [= ?%Nat2Z.inj]). iModIntro.
      iSplitL "Hl Hγ"; [iNext; iExists c'; by iFrame|].
      wp_pures. iApply ("IH" with "[Hγf] [HΦ]"); last by auto.
      rewrite {3}/mcounter; eauto 10.
  Qed.

  Lemma read_mono_spec l j :
    {{{ mcounter l j }}} read #l {{{ i, RET #i; ⌜j ≤ i⌝ ∧ mcounter l i }}}.
  Proof.
    iIntros (ϕ) "Hc HΦ". iDestruct "Hc" as (γ) "[#Hinv Hγf]".
    rewrite /read /=. wp_lam. iInv N as (c) ">[Hγ Hl]".
    wp_load.
    iCombine "Hγ Hγf"
      gives %[?%max_nat_included _]%auth_both_valid_discrete.
    iMod (own_update_2 with "Hγ Hγf") as "[Hγ Hγf]".
    { apply auth_update, (max_nat_local_update _ _ (MaxNat c)); auto. }
    iModIntro. iSplitL "Hl Hγ"; [iNext; iExists c; by iFrame|].
    iApply ("HΦ" with "[-]"). rewrite /mcounter; eauto 10.
  Qed.
End mono_proof.

(** Counter with contributions *)
Class ccounterG Σ :=
  CCounterG { ccounter_inG : inG Σ (frac_authR natR) }.
Local Existing Instance ccounter_inG.

Definition ccounterΣ : gFunctors :=
  #[GFunctor (frac_authR natR)].

Global Instance subG_ccounterΣ {Σ} : subG ccounterΣ Σ → ccounterG Σ.
Proof. solve_inG. Qed.

Section contrib_spec.
  Context `{!heapGS Σ, !ccounterG Σ} (N : namespace).

  Definition ccounter_inv (γ : gname) (l : loc) : iProp Σ :=
    ∃ n, own γ (●F n) ∗ l ↦ #n.

  Definition ccounter_ctx (γ : gname) (l : loc) : iProp Σ :=
    inv N (ccounter_inv γ l).

  Definition ccounter (γ : gname) (q : frac) (n : nat) : iProp Σ :=
    own γ (◯F{q} n).

  (** The main proofs. *)
  Lemma ccounter_op γ q1 q2 n1 n2 :
    ccounter γ (q1 + q2) (n1 + n2) ⊣⊢ ccounter γ q1 n1 ∗ ccounter γ q2 n2.
  Proof. by rewrite /ccounter frac_auth_frag_op -own_op. Qed.

  Lemma newcounter_contrib_spec (R : iProp Σ) :
    {{{ True }}} newcounter #()
    {{{ γ l, RET #l; ccounter_ctx γ l ∗ ccounter γ 1 0 }}}.
  Proof.
    iIntros (Φ) "_ HΦ". rewrite /newcounter /=. wp_lam. wp_alloc l as "Hl".
    iMod (own_alloc (●F O ⋅ ◯F 0)) as (γ) "[Hγ Hγ']";
      first by apply auth_both_valid_discrete.
    iMod (inv_alloc N _ (ccounter_inv γ l) with "[Hl Hγ]").
    { iNext. iExists 0. by iFrame. }
    iModIntro. iApply "HΦ". rewrite /ccounter_ctx /ccounter; eauto 10.
  Qed.

  Lemma incr_contrib_spec γ l q n :
    {{{ ccounter_ctx γ l ∗ ccounter γ q n }}} incr #l
    {{{ RET #(); ccounter γ q (S n) }}}.
  Proof.
    iIntros (Φ) "[#? Hγf] HΦ". iLöb as "IH". wp_rec.
    wp_bind (! _)%E. iInv N as (c) ">[Hγ Hl]".
    wp_load. iModIntro. iSplitL "Hl Hγ"; [iNext; iExists c; by iFrame|].
    wp_pures. wp_bind (CmpXchg _ _ _).
    iInv N as (c') ">[Hγ Hl]".
    destruct (decide (c' = c)) as [->|].
    - iMod (own_update_2 with "Hγ Hγf") as "[Hγ Hγf]".
      { apply frac_auth_update, (nat_local_update _ _ (S c) (S n)); lia. }
      wp_cmpxchg_suc. iModIntro. iSplitL "Hl Hγ".
      { iNext. iExists (S c). rewrite Nat2Z.inj_succ Z.add_1_l. by iFrame. }
      wp_pures. by iApply "HΦ".
    - wp_cmpxchg_fail; first (by intros [= ?%Nat2Z.inj]).
      iModIntro. iSplitL "Hl Hγ"; [iNext; iExists c'; by iFrame|].
      wp_pures. by iApply ("IH" with "[Hγf] [HΦ]"); auto.
  Qed.

  Lemma read_contrib_spec γ l q n :
    {{{ ccounter_ctx γ l ∗ ccounter γ q n }}} read #l
    {{{ c, RET #c; ⌜n ≤ c⌝ ∧ ccounter γ q n }}}.
  Proof.
    iIntros (Φ) "[#? Hγf] HΦ".
    rewrite /read /=. wp_lam. iInv N as (c) ">[Hγ Hl]". wp_load.
    iCombine "Hγ Hγf" gives % ?%frac_auth_included_total%nat_included.
    iModIntro. iSplitL "Hl Hγ"; [iNext; iExists c; by iFrame|].
    iApply ("HΦ" with "[-]"); rewrite /ccounter; eauto 10.
  Qed.

  Lemma read_contrib_spec_1 γ l n :
    {{{ ccounter_ctx γ l ∗ ccounter γ 1 n }}} read #l
    {{{ RET #n; ccounter γ 1 n }}}.
  Proof.
    iIntros (Φ) "[#? Hγf] HΦ".
    rewrite /read /=. wp_lam. iInv N as (c) ">[Hγ Hl]". wp_load.
    iCombine "Hγ Hγf" gives % <-%frac_auth_agree_L.
    iModIntro. iSplitL "Hl Hγ"; [iNext; iExists c; by iFrame|].
    by iApply "HΦ".
  Qed.
End contrib_spec.


(****************************************************************

   Tactics

 ****************************************************************)

Ltac genc term := generalize term; clear term.

Ltac dest_wp :=
  intros [t1 [t2 [c [Hperm_c1 [Heq_c2 Hperm_w]]]]].

Ltac intro_dest_wp :=
  intros c1 w1 c2 w2; dest_wp.

Ltac eq_subst :=
  match goal with
    |  |- _ = _ -> _ => intro; subst
  end.

Ltac inject_subst :=
  match goal with
    | H: _ = _ |- _ =>
      injection H; repeat eq_subst; clear H
  end.

Ltac inject_subst' eq :=
  injection eq; repeat eq_subst; clear eq.

Set Implicit Arguments.

(* special induction principles *)
Require Import List.
Theorem double_list_induction: forall (A B: Set),
  forall P: list A -> list B -> Prop,
    (forall l1: list A, P l1 nil) ->
    (forall l2: list B, P nil l2) ->
    (forall (a: A)(l1: list A)(b: B)(l2: list B),
      P l1 l2 -> P (a::l1) (b::l2)) ->
    forall (l1: list A)(l2: list B), P l1 l2.
Proof.
  intros A' B P Hl1nil Hnill2 Hcons.
  intro l1; elim l1;
    [apply Hnill2 | clear l1; intros a l1 IHl1].
  intro l2; case l2;
    [apply Hl1nil | clear l2; intros b l2; apply Hcons; apply IHl1].
Qed.

Require Import Huffman.Permutation.
Require Import Huffman.Ordered.

Section lemmas.
  Variable (A: Set).

  Lemma perm_case:
    forall a b (l l1 l2: list A),
      permutation l (a::l1) ->
      permutation l (b::l2) ->
      (exists l',
        permutation l (a::b::l'))\/a=b.
  Proof.
    intros a b l l1 l2 Hperm1 Hperm2.
    generalize
      (permutation_trans _ _ _ _
        (permutation_sym _ _ _ Hperm1) Hperm2).
    intro Hperm; apply permutation_cons_ex in Hperm.
    destruct Hperm as [l3 [l4 [Heq Hperm]]].
    genc Hperm; genc Heq.
    case l3; clear l3; simpl.
    intros; injection Heq; intros; subst b l4; clear Heq.
    right; reflexivity.
    intros c l3 Heq; injection Heq; intros; subst c; clear Heq.
    left; exists (l3++l4).
    apply (permutation_trans _ _ _ _ Hperm1).
    apply permutation_skip; assumption.
  Qed.

  Lemma perm_2_1:
    forall a b (l l1 l2: list A),
      a <> b ->
      permutation l (a::l1) ->
      permutation l (b::l2) ->
      exists l',
        permutation l (a::b::l').
  Proof.
    intros.
    generalize (perm_case H0 H1).
    intros [Hperm | Heq].
    assumption.
    elim H; assumption.
  Qed.

  Lemma NoDup_neq:
    forall l: list A,
    (forall t1 t2 l',
      permutation l (t1::t2::l') -> t1<>t2) ->
    NoDup l.
  Proof.
    intro l; elim l; clear l.
    intros; apply NoDup_nil.
    intros; apply NoDup_cons.
    genc H0; genc H; case l; clear l.
    simpl; tauto.
    simpl; intros b l; intros.
    intros [Heq | HIn]; subst.
    elim (H0 a a l (permutation_refl _ _)); reflexivity.
    cut (exists l', permutation l (a::l')).
    intros [l' Hperm].
    cut (permutation (a::b::l) (a::a::b::l')).
    intro Hperm'.
    elim (H0 a a (b::l') Hperm'); reflexivity.
    apply permutation_skip.
    apply permutation_trans with (b::a::l').
    apply permutation_skip; assumption.
    apply permutation_swap.
    clear H H0.
    genc HIn; genc a; elim l.
    simpl; intros; contradiction.
    simpl; intros b' l' IH a [Heq | HIn]; subst.
    exists l'; apply permutation_refl.
    destruct (IH _ HIn) as [l'' Hperm].
    exists (b'::l'').
    apply permutation_trans with (b'::a::l'').
    apply permutation_skip; assumption.
    apply permutation_swap.
    apply H.
    intros; eapply H0.
    apply permutation_trans with (a::t1::t2::l').
    apply permutation_skip; assumption.
    apply permutation_trans with (t1::a::t2::l').
    apply permutation_swap.
    apply permutation_skip; apply permutation_swap.
  Qed.

  Lemma cons_to_app:
    forall x (l: list A),
      x::l = (x::nil)++l.
  Proof.
    simpl; reflexivity.
  Qed.

  Lemma perm_app_in:
    forall (t: A) l l1 l2,
      permutation (t::l) (l1++l2) ->
      In t l1\/In t l2.
  Proof.
    intros t l l1; genc l; genc t.
    elim l1; clear l1; simpl.
    intros; right.
    apply (permutation_in _ _ _ _ H); simpl; left; reflexivity.
    intros a l1 IH t l l2 Hperm.
    apply permutation_cons_ex in Hperm.
    destruct Hperm as [l3 [l4 [Heq Hperm]]].
    genc Hperm; genc Heq.
    case l3; clear l3; simpl.
    intros; injection Heq; intros; subst t l4; clear Heq.
    left; left; reflexivity.
    intros t' l3; intros; injection Heq; intros; subst t'; clear Heq.
    cut (permutation (t::l3++l4) (l1++l2)).
    intro Hperm'.
    destruct (IH _ _ _ Hperm').
    left; right; assumption.
    right; assumption.
    rewrite H.
    rewrite (app_comm_cons l3).
    rewrite (cons_to_app t l4).
    rewrite app_assoc.
    apply permutation_app_comp; auto.
    rewrite (cons_to_app t l3); auto.
  Qed.

  Lemma in_to_perm:
    forall x (l: list A),
      In x l -> exists l', permutation l (x::l').
  Proof.
    intros x l HIn.
    apply in_split in HIn.
    destruct HIn as [l1 [l2 Heq]];
      subst l; exists (l1++l2).
    rewrite cons_to_app.
    rewrite app_comm_cons.
    rewrite app_assoc.
    apply permutation_app_comp; auto.
    rewrite (cons_to_app x l1); auto.
  Qed.
End lemmas.

Section OrderedLemmas.
  Variable (A: Set)(f: A -> nat)(order: A -> A -> Prop).
  Hypothesis
    (order_refl: forall x, order x x)
    (order_trans: forall x y z, order x y -> order y z -> order x z)
    (order_dec: forall x y, {order x y}+{order y x}).

  Lemma ordered_in_ordered:
    forall x l,
      ordered order l ->
      (forall y, In y l -> order x y) ->
      ordered order (x::l).
  Proof.
    intros x l Hord; generalize x; clear x.
    elim Hord; clear Hord l.
    intros; apply ordered_one.
    simpl; intros x z IH.
    apply ordered_cons.
    apply IH; left; reflexivity.
    apply ordered_one.
    intros a b l Horder Hord IH x HIn_order.
    repeat apply ordered_cons.
    apply HIn_order; simpl; left; reflexivity.
    assumption.
    assumption.
  Qed.

  Lemma ordered_app_cons:
    forall a l1 l2,
      ordered order (l1++a::l2) -> ordered order (l1++l2).
  Proof.
    intros a l1; generalize a; clear a.
    elim l1; clear l1.
    simpl; apply ordered_inv.
    simpl; intros a l1 IH b l2 Hord.
    inversion Hord; subst a0.
    elim (app_cons_not_nil _ _ _ H1).
    generalize H0 Hord IH; clear H0 Hord IH.
    case l1; clear l1.
    simpl.
    intro.
    injection H0; intros; subst b0 l; clear H0.
    apply (ordered_skip _ _ order_trans) with b;
      apply ordered_cons; assumption.
    intros c l1 Heq; injection Heq; intros; subst b0 l; clear Heq.
    simpl.
    apply ordered_cons; [assumption | apply (IH b _ H2)].
  Qed.

  Lemma ordered_app_l:
    forall l1 l2,
      ordered order (l1++l2) -> ordered order l1.
  Proof.
    intros l1 l2; generalize l1; clear l1.
    elim l2; clear l2.
    intro l1; rewrite app_nil_r; tauto.
    intros a l2 IH l1 Hord.
    apply ordered_app_cons in Hord; apply (IH _ Hord).
  Qed.

  Lemma ordered_app_r:
    forall l1 l2,
      ordered order (l1++l2) -> ordered order l2.
  Proof.
    intro l1; elim l1; clear l1; simpl.
    tauto.
    intros a l1 IH l2 Hord.
    apply IH.
    apply ordered_inv in Hord.
    assumption.
  Qed.

  Lemma ordered_head:
    forall x l l',
      ordered order l ->
      l = x::l' ->
      forall y, In y l -> order x y.
  Proof.
    intros x l l' Hord;
      generalize x l';
        clear x l'.
    elim Hord; clear Hord l.
    intros; contradiction.
    simpl.
    intros a x l' Heq y [Heq' | F];
      [injection Heq; intros; subst; subst | contradiction].
    apply order_refl.
    intros a b l Horder Hordered IH x l' Heq.
    simpl.
    intros y [Heq' | [Heq' | HIn]]; subst;
      injection Heq; intros; subst.
    apply order_refl.
    assumption.
    apply (order_trans Horder).
    apply IH with l;
      [reflexivity | simpl; right; assumption].
  Qed.

  Lemma ordered_app_head_l:
    forall x l l1 l2,
      ordered order (l1++l2) ->
      x::l = l1++l2 ->
      forall y, In y l1 -> order x y.
  Proof.
    intros x l l1;
      generalize x l;
        clear x l.
    elim l1; clear l1.
    simpl; intros; contradiction.
    intros a1 l1 IH x l l2 Hordered Heq.
    injection Heq; intros; subst x l; clear Heq.
    simpl in H1; destruct H1 as [Heq | HIn].
    subst y; apply order_refl.
    induction l1.
    contradiction.
    simpl in IH.
    apply order_trans with a.
    inversion Hordered; assumption.
    simpl in Hordered.
    apply ordered_inv in Hordered.
    apply (IH _ _ _ Hordered (eq_refl _)).
    simpl in HIn; assumption.
  Qed.

  Lemma ordered_app_head_r:
    forall x l l1 l2,
      ordered order (l1++l2) ->
      x::l = l1++l2 ->
      forall y, In y l2 -> order x y.
  Proof.
    intros x l l1 l2;
      generalize x l l1;
        clear x l l1.
    elim l2; clear l2.
    simpl; intros; contradiction.
    intros a2 l2 IH x l l1 Hordered Heq.
    rewrite (cons_to_app a2 _) in Hordered.
    rewrite (cons_to_app a2 _) in Heq.
    rewrite app_assoc in Hordered.
    rewrite app_assoc in Heq.
    generalize (IH _ _ _ Hordered Heq).
    intro H.
    simpl; intros y [Heq' | HIn]; subst.
    apply (ordered_app_head_l _ _ Hordered Heq).
    rewrite in_app_iff; right; simpl; left; reflexivity.
    apply H; assumption.
  Qed.

  Lemma ordered_app_order_aux:
    forall a l1 l2,
      ordered order (l1++a::l2) ->
      forall x, In x l1 -> order x a.
  Proof.
    intros a l1; generalize a; clear a.
    elim l1; clear l1.
    simpl; intros; contradiction.
    simpl.
    intros a1 l1 IH a l2 Hordered x [Heq | HIn].
    subst.
    apply (ordered_trans _ _ order_trans x _ _ Hordered).
    apply in_app_iff; right; simpl; left; reflexivity.
    generalize HIn; clear HIn.
    apply ordered_inv in Hordered.
    apply (IH _ _ Hordered).
  Qed.

  Lemma ordered_insert:
    forall a l,
      ordered order l ->
      exists l1, exists l2,
        l = (l1++l2)/\
        ordered order (l1++a::l2).
  Proof.
    intros a l Hord; generalize a; clear a.
    elim Hord; clear Hord l.
    intro a; exists nil, nil; repeat split; simpl.
    apply ordered_one.
    intros a b;
      case (order_dec a b); intro Hord.
    exists (a::nil), nil; repeat split; simpl.
    apply ordered_cons; [assumption | apply ordered_one].
    exists nil, (a::nil); repeat split; simpl.
    apply ordered_cons; [assumption | apply ordered_one].
    intros a b l Horder Hordered IH c.
    destruct (IH c) as [l1 [l2 [Heq Hordered']]].
    clear IH.
    generalize Heq Hordered'.
    clear Heq Hordered'.
    case l1; clear l1; simpl.
    intros; subst.
    case (order_dec a c); intro Hord.
    exists (a::nil), (b::l); simpl; split.
    reflexivity.
    apply ordered_cons; assumption.
    exists nil, (a::b::l); simpl; split.
    reflexivity.
    repeat apply ordered_cons; assumption.
    intros b' l1; intros; injection Heq; intros; subst b' l.
    exists (a::b::l1), l2; simpl; split.
    reflexivity.
    apply ordered_cons; assumption.
  Qed.

  Lemma ordered_perm_ex:
    forall l,
      exists l', permutation l l'/\ordered order l'.
  Proof.
    intro l; elim l; clear l.
    exists nil; split.
    apply permutation_nil.
    apply ordered_nil.
    intros a l [l' [Hperm Hord]].
    destruct (ordered_insert a Hord) as [l1 [l2 [Heq Hord']]].
    subst.
    exists (l1++a::l2); split.
    apply permutation_trans with (a::l1++l2).
    apply permutation_skip; assumption.
    rewrite (cons_to_app a l2); rewrite app_assoc.
    rewrite app_comm_cons.
    apply permutation_app_comp.
    rewrite (cons_to_app a l1); apply permutation_app_swap.
    apply permutation_refl.
    assumption.
  Qed.
End OrderedLemmas.

Section NoDup.
  Variable A: Set.
  Lemma NoDup_inv:
    forall (a: A) l,
      NoDup (a::l) -> NoDup l.
  Proof.
    intros a l Hnd; inversion Hnd; subst; assumption.
  Qed.

  Lemma NoDup_perm:
    forall (l1 l2: list A),
      permutation l1 l2 ->
      NoDup l1 -> NoDup l2.
  Proof.
    intros l1 l2 Hperm; elim Hperm; clear Hperm l1 l2.
    tauto.
    intros.
    apply NoDup_cons.
    inversion H1; subst.
    intro HIn; apply H4.
    apply permutation_sym in H.
    apply (permutation_in _ _ _ _ H); assumption.
    apply NoDup_inv in H1.
    apply H0; assumption.
    intros a b l Hnd;
      repeat apply NoDup_cons.
    inversion Hnd; subst.
    inversion H2; subst.
    simpl; intro HIn.
    destruct HIn as [Heq | HIn]; subst.
    apply H1; simpl; left; reflexivity.
    apply H3; assumption.
    inversion Hnd; subst.
    intro HIn; apply H1; simpl; right; assumption.
    repeat apply NoDup_inv in Hnd; assumption.
    intros; tauto.
  Qed.

  Lemma NoDup_app_inv_l:
    forall l1 l2: list A,
      NoDup (l1++l2) -> NoDup l1.
  Proof.
    intro l1; elim l1; clear l1.
    simpl; intros; apply NoDup_nil.
    simpl; intros; apply NoDup_cons.
    inversion H0; subst.
    intro HIn; apply H3; apply in_app_iff;
      left; assumption.
    apply (H l2); apply NoDup_inv in H0; assumption.
  Qed.

  Lemma NoDup_app_inv_r:
    forall l1 l2: list A,
      NoDup (l1++l2) -> NoDup l2.
  Proof.
    intro l1; elim l1; clear l1.
    simpl; tauto.
    simpl; intros.
    apply H; apply NoDup_inv in H0; assumption.
  Qed.
End NoDup.


Require Import Omega.
Require Import RelationClasses.

From sflib Require Import sflib.

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

Require Import Time.
Require Import Event.
From PromisingLib Require Import Language.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Thread.
Require Import Configuration.
Require Import Progress.

Require Import MemoryRel.
Require Import SmallStep.

Set Implicit Arguments.

(* NOTE: `race_rw` requires two *distinct* threads to have a race.
 * However, C/C++ acknowledges intra-thread races.  For example,
 * according to the Standard, `f(x=1, x)` is RW-racy on `x`, since the
 * order of evaluation of the arguments is unspecified.  We currently
 * ignore this aspect of the race semantics.
 *)

Inductive Configuration_program_event c tid e : Prop :=
| configuration_program_event_intro lang st st' lc
    (TH: IdentMap.find tid c.(Configuration.threads) = Some (existT _ lang st, lc))
    (STATE: lang.(Language.step) e st st').
Hint Constructors Configuration_program_event.

Inductive race_condition e1 e2 ord1 ord2 : Prop :=
| race_condition_rw loc val1 val2
    (EVENT1: ProgramEvent.is_reading e1 = Some (loc, val1, ord1))
    (EVENT2: ProgramEvent.is_writing e2 = Some (loc, val2, ord2))
| race_condition_ww loc val1 val2
    (EVENT1: ProgramEvent.is_writing e1 = Some (loc, val1, ord1))
    (EVENT2: ProgramEvent.is_writing e2 = Some (loc, val2, ord2))
.
Hint Constructors race_condition.

Inductive race (c:Configuration.t) (ord1 ord2:Ordering.t): Prop :=
| race_intro
    tid1 e1
    tid2 e2
    (TID: tid1 <> tid2)
    (PROEVT1: Configuration_program_event c tid1 e1)
    (PROEVT2: Configuration_program_event c tid2 e2)
    (RACE: race_condition e1 e2 ord1 ord2)
.
Hint Constructors race.

Definition pf_racefree (c1:Configuration.t): Prop :=
  forall c2 ordr ordw
    (STEPS: rtc (small_step_all false) c1 c2)
    (RACE: race c2 ordr ordw),
    <<ORDR: Ordering.le Ordering.acqrel ordr>> /\
    <<ORDW: Ordering.le Ordering.acqrel ordw>>.

Lemma pf_racefree_steps
      c1 c2
      (FREE: pf_racefree c1)
      (STEPS: rtc (small_step_all false) c1 c2):
  pf_racefree c2.
Proof.
  ii. eapply FREE, RACE. etrans; eauto.
Qed.

Lemma small_step_to_program_step_writing
      c1 c2 e tid loc ord from ts val rel withprm
      (STEP: small_step withprm tid e c1 c2)
      (EVENT: ThreadEvent.is_writing e = Some (loc, from, ts, val, rel, ord)):
  exists (pe : ProgramEvent.t),
  <<EVENT: Configuration_program_event c1 tid pe >> /\
  <<WRITE: ProgramEvent.is_writing pe = Some (loc, val, ord) >>.
Proof.
  inv STEP. inv STEP0; inv STEP; ss.
  inv LOCAL; inv EVENT; eauto 10.
Qed.

Lemma small_step_to_program_step_reading
      c1 c2 e tid loc ord ts val rel withprm
      (STEP: small_step withprm tid e c1 c2)
      (EVENT: ThreadEvent.is_reading e = Some (loc, ts, val, rel, ord)):
  exists (pe : ProgramEvent.t),
  <<EVENT: Configuration_program_event c1 tid pe >> /\
  <<WRITE: ProgramEvent.is_reading pe = Some (loc, val, ord) >>.
Proof.
  inv STEP. inv STEP0; inv STEP; ss.
  inv LOCAL; inv EVENT; eauto 10.
Qed.