(* Copyright (c) 2012-2015, Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
(** This file defines an axiomatic semantics (in the form of shallow embedding
of a separation logic) for our language. This axiomatic semantics has two
judgments: one for statements and one for expressions. Statement judgment are
sextuples of the shape [Γ\ δ\ R\ J\ T ⊨ₛ {{ P }} s {{ Q }}] where:

- [s] is a statement, and [P] and [Q] are assertions called the pre- and
  postcondition of [s], respectively.
- [R] is a function that gives the returning condition for a return value.
  That means, [R v] has to hold to execute a [return e] where execution of [e]
  yields the value [v].
- [J] is a function that gives the jumping condition for each goto. That means,
  [J l] has to hold to execute a [goto l].
- [T] is a function that gives the jumping condition for each throw.

The assertions [P], [Q], [R], [J] and [T] correspond to the four directions [↘],
[↗], [⇈], [↷] and [↑] in which traversal through a statement can be performed.
We therefore treat the sextuple as a triple [Γ\ Pd ⊨ₚ s] where [Pd] is a
function from directions to assertions such that [Pd ↘ = P], [Pd ↗ = Q],
[Pd (⇈ v) = R v], [P (↷ l) = J l], and [P (↑ n) = T n] *)

(** Expression judgments are quintuples [Γ\ δ\ A ⊨ₑ {{ P }} e {{ Q }}]. As
usual, [P] and [Q] are the pre- and postcondition of [e]. However, whereas the
precondition is just an assertion, the postcondition is a function from values
to assertions. It ensures that if execution of [e] yields a value [v], then
[Q v] holds. The environment [A] can be used to "frame" writable memory that is
being shared by all function calls. *)
Require Export assertions.
Require Import axiomatic_graph.
Local Open Scope nat_scope.
Local Obligation Tactic := idtac.

Ltac simplify_mem_disjoint_hyps :=
  simplify_sep_disjoint_hyps;
  repeat match goal with
  | H : ✓{_} (_ ∪ _) |- _ =>
     rewrite cmap_union_valid in H by auto; destruct H
  end.
Ltac solve_mem_disjoint :=
  repeat match goal with
  | H : ✓{_} _ |- _ => apply cmap_valid_sep_valid in H
  end; solve_sep_disjoint.
Local Hint Extern 1 (_ ## _) => solve_mem_disjoint: core.
Local Hint Extern 1 (## _) => solve_mem_disjoint: core.
Local Hint Extern 1 (sep_valid _) => solve_mem_disjoint: core.
Local Hint Extern 1 (_ ⊆ _) => etransitivity; [eassumption|]: core.
Local Hint Extern 1 (_ ≤ _) => lia: core.

(** ** Directed assertions *)
(** The statement judgment will be of the shape [Γ\ δ\ Pd ⊨ₚ s] where [Pd] is
a function from directions to assertions taking the pre- and post, returning,
and jumping condition together. We generalize this idea slightly, and define
the type [directed A] as functions [direction → A]. *)
Definition directed_pack {K A} (P : A) (Q : A) (R : val K → A)
    (J : labelname → A) (T : nat → A) (C : option Z → A) : direction K → A :=
  direction_rect _ (λ _, A) P Q R J T C.

(** This hideous definition of [fmap] makes [f <$> directed_pack P Q R J]
convertable with [directed_pack (f P) (f Q) (f ∘ R) (f ∘ J)]. *)
#[global] Instance directed_fmap {K} : FMap (direction K →.) := λ A B f Pd d,
  match d with
  | ↘ => f (Pd ↘)
  | ↗ => f (Pd ↗)
  | ⇈ v => f (Pd (⇈ v))
  | ↷ l => f (Pd (↷ l))
  | ↑ n => f (Pd (↑ n))
  | ↓ mx => f (Pd (↓ mx))
  end.

Notation dassert K := (direction K → assert K).
Notation dassert_pack P Q R J T C :=
  (@directed_pack _ (assert _) P%A Q%A R%A J%A T%A C%A).
Definition dassert_pack_top `{Env K}
    (P : assert K) (R : val K → assert K) : dassert K :=
  dassert_pack P (R voidV) R (λ _, False%A) (λ _, False%A) (λ _, False%A).

(** ** The Hoare judgment for statements *)
(** Now the interpretation of the statement Hoare judgment is just taking all
of the previously defined notions together. We require both the program and
the memory to contain no locks at the start. Also, we require all locks to be
released in the end, as each statement that contains an expression always has
a sequence point in the end. *)
Inductive ax_stmt_post' `{Env K} (Pd : dassert K) (s : stmt K) (cmτ : rettype K)
    (Γ : env K) (Δ : memenv K) (δ : funenv K)
    (ρ : stack K) (n : nat) : focus K → mem K → Prop :=
  mk_ax_stmt_post d m :
    direction_out d s → (Γ,Δ) ⊢ d : cmτ →
    mem_locks m = ∅ →
    assert_holds (Pd d) Γ Δ δ ρ n (cmap_erase m) →
    ax_stmt_post' Pd s cmτ Γ Δ δ ρ n (Stmt d s) m.
Program Definition ax_stmt_post `{EnvSpec K} (Pd : dassert K)
    (s : stmt K) (cmτ : rettype K) : ax_assert K := {|
  ax_assert_holds := ax_stmt_post' Pd s cmτ
|}.
Next Obligation.
  intros ??? Pd s cmτ Γ1 Γ2 Δ1 Δ2 δ1 δ2 ρ n n' φ m ????;
    destruct 1 as [d m' ????]; constructor;
    eauto using direction_typed_weaken, assert_weaken, cmap_erase_valid.
Qed.
Next Obligation.
  intros ??? Pd s cmτ Γ Δ δ n ρ φ m m' [d m'' ????] [? p]; inv_rcstep; set_solver.
Qed.
Definition ax_stmt_packed `{EnvSpec K} (Γ : env K) (δ : funenv K)
    (Pd : dassert K) (s : stmt K) : Prop := ∀ Γ' Δ δ' n ρ d m cmτ,
  ✓ Γ' → Γ ⊆ Γ' → δ ⊆ δ' →
  ✓{Γ',Δ} δ' →
  ✓{Γ',Δ} m →
  mem_locks m = ∅ →
  direction_in d s →
  (Γ',Δ,ρ.*2) ⊢ s : cmτ →
  ✓{Δ}* ρ →
  assert_holds (Pd d) Γ' Δ δ' ρ n (cmap_erase m) →
  ax_graph ax_disjoint_cond (ax_stmt_post Pd s cmτ) Γ' δ' Δ ρ n [] (Stmt d s) m.
#[global] Instance: Params (@ax_stmt_packed) 5 := {}.
Notation "Γ \ δ \ P ⊨ₚ s" :=
  (ax_stmt_packed Γ δ P%A s)
  (at level 74, δ at next level, P at next level, s at next level,
   format "Γ \  δ \  P  ⊨ₚ  '[' s ']'") : C_scope.

Definition ax_stmt `{EnvSpec K} (Γ : env K) (δ : funenv K) R J T C P s Q :=
  Γ\ δ\ dassert_pack P Q R J T C ⊨ₚ s.
Definition ax_stmt_top `{EnvSpec K} (Γ : env K) (δ : funenv K) P s Q :=
  Γ\ δ\ dassert_pack_top P Q ⊨ₚ s.
#[global] Instance: Params (@ax_stmt) 5 := {}.
#[global] Instance: Params (@ax_stmt_top) 5 := {}.
Notation "Γ \ δ \ R \ J \ T \ C ⊨ₛ {{ P } } s {{ Q } }" :=
  (ax_stmt Γ δ R%A J%A T%A C%A P%A s Q%A)
  (at level 74, δ at next level, R at next level,
   J at next level, T at next level, C at next level,
   format "Γ \  δ \  R \  J \  T \  C  ⊨ₛ  '[' {{  P  } } '/'  s  '/' {{  Q  } } ']'") : C_scope.
Notation "Γ \ δ ⊨ₛ {{ P } } s {{ Q } }" :=
  (ax_stmt_top Γ δ P%A s%S Q%A)
  (at level 74, δ at next level,
   format "Γ \  δ  ⊨ₛ  '[' {{  P  } } '/'  s  '/' {{  Q  } } ']'") : C_scope.

(** ** The Hoare judgment for expressions *)
(** The interpretation of the expression judgment is defined similarly as the
interpretation of the judgment for statements. At the start, we require both
the expression and the memory to be lock free. In the end, the locks in the
memory should exactly match the annotated locations in the final expression
that remain to be unlocked. The latter is important, as an unlock operation at
a sequence point thereby corresponds to unlocking everything. *)
Inductive ax_expr_frame (K : iType) : iType :=
  InExpr (mf mA : mem K) | InFun (mf : mem K).
Arguments InExpr {_} _ _.
Arguments InFun {_} _.

Inductive ax_expr_cond_frame `{Env K}
     (ρ : stack K) (A : assert K) (Γ : env K)
     (Δ : memenv K) (δ : funenv K) (k : ctx K)
     (n : nat) (φ : focus K) (m m' : mem K) : ax_expr_frame K → Prop :=
  | ax_frame_in_expr mA mf :
     m' = m ∪ mf ∪ mA → ✓{Γ,Δ} mf → ✓{Γ,Δ} mA →
     ## [m; mf; mA] → k = [] → cmap_erased mA → mem_locks mA = ∅ →
     assert_holds A Γ Δ δ ρ n mA →
     ax_expr_cond_frame ρ A Γ Δ δ k n φ m m' (InExpr mf mA)
  | ax_frame_in_fun mf :
     m' = m ∪ mf → ✓{Γ,Δ} mf →
     ## [m; mf] → k ≠ [] →
     ax_expr_cond_frame ρ A Γ Δ δ k n φ m m' (InFun mf).
Inductive ax_expr_cond_unframe `{Env K}
     (ρ : stack K) (A : assert K) (Γ : env K)
     (Δ : memenv K) (δ : funenv K) (k : ctx K)
     (n : nat) (φ : focus K) (m m' : mem K) : ax_expr_frame K → Prop :=
  | ax_unframe_expr_to_expr mA mf :
     m' = m ∪ mf ∪ mA → ## [m; mf; mA] → k = [] →
     ax_expr_cond_unframe ρ A Γ Δ δ k n φ m m' (InExpr mf mA)
  | ax_unframe_fun_to_expr mA mf :
     m' = m ∪ mf ∪ mA → ## [m; mf; mA] → k = [] →
     cmap_erased mA → mem_locks mA = ∅ →
     assert_holds A Γ Δ δ ρ n mA →
     ax_expr_cond_unframe ρ A Γ Δ δ k n φ m m' (InFun mf)
  | ax_unframe_expr_to_fun m'' mA mf :
     m = m'' ∪ mA → m' = m'' ∪ mf ∪ mA → ## [m''; mf; mA] → k ≠ [] →
     ax_expr_cond_unframe ρ A Γ Δ δ k n φ m m' (InExpr mf mA)
  | ax_unframe_fun_to_fun mf :
     m' = m ∪ mf → ## [m; mf] → k ≠ [] →
     ax_expr_cond_unframe ρ A Γ Δ δ k n φ m m' (InFun mf).
Program Definition ax_expr_cond `{EnvSpec K} (ρ : stack K)
    (A : assert K) : ax_frame_cond K (ax_expr_frame K) := {|
  frame := ax_expr_cond_frame ρ A;
  unframe := ax_expr_cond_unframe ρ A
|}.
Next Obligation.
  intros ??? ρ A Γ Δ δ k n φ m m' ??;
    destruct 1; subst; auto using cmap_union_valid_2.
Qed.
Next Obligation.
  intros ??? ρ A Γ Δ δ k n φ m m' ??; destruct 1; subst;
    rewrite ?cmap_union_valid; intuition.
Qed.

Definition ax_expr_invariant `{Env K} (A : assert K)
    (Γ : env K) (Δ : memenv K) (δ : funenv K)
    (ρ : stack K) (n : nat) (m : mem K) := ∃ mA,
  ## [mA; m] ∧ ✓{Γ,Δ} mA ∧ cmap_erased mA ∧ mem_locks mA = ∅ ∧
  assert_holds A Γ Δ δ ρ n mA.
Inductive ax_expr_post' `{Env K} (Q : lrval K → assert K)
    (τlr : lrtype K) (Γ : env K) (Δ : memenv K)
    (δ : funenv K) (ρ : stack K) (n : nat) : focus K → mem K → Prop :=
  mk_ax_expr_post ν Ω m :
    (Γ,Δ) ⊢ ν : τlr →
    mem_locks m = Ω →
    assert_holds (Q ν) Γ Δ δ ρ n (cmap_erase m) →
    ax_expr_post' Q τlr Γ Δ δ ρ n (Expr (%#{Ω} ν)) m.
Program Definition ax_expr_post `{EnvSpec K}
    (Q : lrval K → assert K) (τlr : lrtype K) : ax_assert K := {|
  ax_assert_holds := ax_expr_post' Q τlr
|}.
Next Obligation.
  intros ??? Q τlr Γ1 Γ2 Δ1 Δ2 δ1 δ2 ρ n φ m ?????; destruct 1; constructor;
    eauto using assert_weaken, cmap_erase_valid, lrval_typed_weaken.
Qed.
Next Obligation.
  intros ??? Q τlr Γ Δ δ ρ n φ m m' [d m'' ???] [? p]; inv_rcstep.
Qed.
Definition ax_expr `{EnvSpec K} (Γ : env K) (δ : funenv K) (A P : assert K)
    (e : expr K) (Q : lrval K → assert K) : Prop := ∀ Γ' Δ δ' n ρ m τlr,
  ✓ Γ' → Γ ⊆ Γ' → δ ⊆ δ' →
  ✓{Γ',Δ} δ' →
  ✓{Γ',Δ} m →
  mem_locks m = ∅ →
  (Γ',Δ,ρ.*2) ⊢ e : τlr →
  locks e = ∅ →
  ✓{Δ}* ρ →
  ax_expr_invariant A Γ' Δ δ' ρ n m →
  assert_holds P Γ' Δ δ' ρ n (cmap_erase m) →
  ax_graph (ax_expr_cond ρ A) (ax_expr_post Q τlr) Γ' δ' Δ ρ n [] (Expr e) m.
#[global] Instance: Params (@ax_expr) 5 := {}.
Notation "Γ \ δ \ A ⊨ₑ {{ P } } e {{ Q } }" :=
  (ax_expr Γ δ A%A P%A e Q%A)
  (at level 74, δ at next level, A at next level,
  format "Γ \  δ \  A  ⊨ₑ  '[' {{  P  } } '/'  e  '/' {{  Q  } } ']'") : C_scope.

(** ** Function specifications *)
Inductive fassert (K : Type) `{Env K} := FAssert {
  fcommon : Type;
  fpre : fcommon → list (val K) → assert K;
  fpost : fcommon → list (val K) → val K → assert K;
  fpre_stack_indep c vs : StackIndep (fpre c vs);
  fpost_stack_indep c vs v : StackIndep (fpost c vs v)
}.
Arguments fcommon {_ _} _.
Arguments fpre {_ _} _ _ _.
Arguments fpost {_ _} _ _ _ _.
#[global] Existing Instance fpre_stack_indep.
#[global] Existing Instance fpost_stack_indep.

Inductive ax_fun_post' `{Env K}
    (f : funname) (τ : type K) (P : val K → assert K)
    (Γ : env K) (Δ : memenv K) (δ : funenv K)
    (ρ : stack K) (n : nat) : focus K → mem K → Prop :=
  mk_ax_fun_post v m :
    (Γ,Δ) ⊢ v : τ →
    mem_locks m = ∅ →
    assert_holds (P v) Γ Δ δ ρ n (cmap_erase m) →
    ax_fun_post' f τ P Γ Δ δ ρ n (Return f v) m.
Program Definition ax_fun_post `{EnvSpec K} (f : funname) (τ : type K)
    (P : val K → assert K) : ax_assert K := {|
  ax_assert_holds := ax_fun_post' f τ P
|}.
Next Obligation.
  intros ??? f τ Pf Γ1 Γ2 Δ1 Δ2 δ1 δ2 ρ n n' φ ?????; destruct 1 as [v m];
    constructor; eauto using assert_weaken, cmap_erase_valid, val_typed_weaken.
Qed.
Next Obligation.
  intros ??? f τ Pf Γ Δ δ n ρ φ m m' [v m'' ??] [? p]; inv_rcstep.
Qed.
Program Definition assert_fun `{EnvSpec K} (f : funname)
    (Pf : fassert K) (τs : list (type K)) (τ : type K) : assert K := {|
  assert_holds Γ Δ δ ρ n m :=
    m = ∅ ∧
    Γ !! f = Some (τs,τ) ∧
    ∀ Γ' Δ' δ' n' c vs m',
      Γ ⊆ Γ' → ✓ Γ' → Δ ⇒ₘ Δ' → δ ⊆ δ' → n' ≤ n →
      ✓{Γ',Δ'} δ' →
      ✓{Γ',Δ'} m' →
      mem_locks m' = ∅ →
      (Γ',Δ') ⊢* vs :* τs →
      assert_holds (fpre Pf c vs) Γ' Δ' δ' [] n' (cmap_erase m') →
      ax_graph ax_disjoint_cond
        (ax_fun_post f τ (fpost Pf c vs)) Γ' δ' Δ' [] n' [] (Call f vs) m'
|}.
Next Obligation. naive_solver eauto using lookup_fun_weaken. Qed.

Section axiomatic.
Context `{EnvSpec K}.
Implicit Types Γ : env K.
Implicit Types Δ : memenv K.
Implicit Types δ : funenv K.
Implicit Types m : mem K.
Implicit Types e : expr K.
Implicit Types s : stmt K.

Hint Immediate cmap_valid_memenv_valid: core.
Hint Resolve cmap_empty_valid cmap_erased_empty mem_locks_empty: core.
Hint Resolve cmap_union_valid_2 cmap_erase_valid: core.

#[global] Instance directed_pack_proper `{!@Equivalence A R} :
  Proper (R ==> R ==> pointwise_relation _ R ==> pointwise_relation _ R ==>
    pointwise_relation _ R ==> pointwise_relation _ R ==>
    pointwise_relation _ R) (@directed_pack K A).
Proof. intros ?????????????????? []; simplify_equality'; auto. Qed.
Lemma directed_fmap_spec {A B} (f : A → B) (P : direction K → A) d :
  (@fmap _ (@directed_fmap K) _ _ f P) d = f (P d).
Proof. by destruct d. Qed.
#[global] Instance ax_stmt_packed_proper Γ δ : Proper
  (pointwise_relation _ (≡{Γ,δ}) ==> (=) ==> iff) (ax_stmt_packed Γ δ).
Proof.
  cut (Proper (pointwise_relation _ (≡{Γ,δ}) ==> (=) ==> impl)
              (ax_stmt_packed Γ δ)).
  { intros help. by split; apply help. }
  intros Pd Qd HPQ ?? -> Hax ??????????????????.
  eapply ax_weaken with ax_disjoint_cond (ax_stmt_post Pd _ _) n; eauto.
  { eapply Hax, HPQ; eauto. }
  destruct 2; constructor; auto.
  eapply HPQ; eauto using indexes_valid_weaken, funenv_valid_weaken.
Qed.
Lemma ax_stmt_top_unfold Γ δ P (Q : val _ → assert _) s :
  Γ\ δ ⊨ₛ {{ P }} s {{ Q }} ↔
  Γ\ δ\ Q\ (λ _, False)\ (λ _, False)\ (λ _, False) ⊨ₛ {{ P }} s {{ Q voidV }}.
Proof. done. Qed.
#[global] Instance ax_stmt_proper Γ δ :
  Proper (pointwise_relation _ (≡{Γ,δ}) ==> pointwise_relation _ (≡{Γ,δ}) ==>
     pointwise_relation _ (≡{Γ,δ}) ==> pointwise_relation _ (≡{Γ,δ}) ==>
     (≡{Γ,δ}) ==> (=) ==> (≡{Γ,δ}) ==> iff) (ax_stmt Γ δ).
Proof.
  intros ?? HR ?? HJ ?? HT ?? HC ?? HP ?? -> ?? HQ.
  unfold ax_stmt. by rewrite HR, HJ, HT, HC, HP, HQ.
Qed.
#[global] Instance ax_stmt_top_proper Γ δ :
  Proper ((≡{Γ,δ}) ==> (=) ==> pointwise_relation _ (≡{Γ,δ}) ==> iff)
         (ax_stmt_top Γ δ).
Proof.
  intros ?? HP ?? -> ?? HQ.
  unfold ax_stmt_top, dassert_pack_top. by rewrite HP, HQ.
Qed.

Lemma ax_expr_invariant_emp Γ Δ δ ρ n m :
  ✓{Γ,Δ} m → ax_expr_invariant emp Γ Δ δ ρ n m.
Proof. by eexists ∅; split_and ?; eauto. Qed.
Hint Resolve ax_expr_invariant_emp: core.
Lemma ax_expr_invariant_weaken Γ Δ δ A ρ n1 n2 m1 m2 :
  ✓ Γ → ✓{Δ}* ρ →
  ax_expr_invariant A Γ Δ δ ρ n1 m2 → m1 ⊆ m2 → n2 ≤ n1 →
  ax_expr_invariant A Γ Δ δ ρ n2 m1.
Proof.
  intros ?? (mA&?&?&?&?&?) Hm12.
  exists mA; split_and ?; eauto using assert_weaken.
  by rewrite <-(sep_subseteq_disjoint_le m1) by eauto.
Qed.
Lemma ax_disjoint_expr_compose_diagram Γ ρ A Ek :
  ax_compose_diagram ax_disjoint_cond (ax_expr_cond ρ A) Γ [Ek].
Proof.
  intros Δ δ k n φ a m m' ??; simpl.
  destruct 1; subst; [discriminate_list_equality|].
  exists mf; split_and ?; auto; intros Δ' k' φ' m2 m2' ?? [-> ?].
  constructor; trivial; intro; discriminate_list_equality.
Qed.
Lemma ax_expr_disjoint_compose_diagram Γ ρ k :
  ax_compose_diagram (ax_expr_cond ρ emp%A) ax_disjoint_cond Γ k.
Proof.
  intros Δ δ k' φ n m m' mf ?? (->&?&?); simpl.
  destruct (decide (k' = [])) as [->|].
  * exists (InExpr mf ∅). split.
    { by constructor; rewrite ?sep_right_id by auto;
        eauto using mem_locks_empty, cmap_empty_valid, cmap_erased_empty. }
    intros Δ' k'' φ' m2 m2' ??; inversion 1; subst;
      rewrite ?sep_right_id by auto; auto.
  * exists (InFun mf); split; [by constructor|].
    intros Δ' k'' φ' m2 m2' ??; inversion 1 as [|mA mf' ????? [??]| | ]; subst;
      rewrite ?sep_right_id by auto; auto.
Qed.
Lemma ax_expr_cond_frame_diagram_simple Γ ρ B mf :
  ax_frame_diagram (ax_expr_cond ρ B) (ax_expr_cond ρ B) Γ mf.
Proof.
  intros Δ δ k φ n m m' ??; destruct 4 as [mA mf'|mf']; subst.
  * simplify_mem_disjoint_hyps; exists (InExpr (mf ∪ mf') mA); split.
    { constructor; auto. by rewrite sep_associative by auto. }
    intros Δ' k' φ' m2 m2'.
    inversion 1 as [| |m''|]; intros; simplify_mem_disjoint_hyps; subst.
    + split; auto. apply ax_unframe_expr_to_expr; auto.
      by rewrite sep_associative by auto.
    + split; auto. apply ax_unframe_expr_to_fun with (m'' ∪ mf); auto.
      - by rewrite <-!sep_associative, (sep_commutative mA) by auto.
      - by rewrite sep_associative by auto.
  * simplify_mem_disjoint_hyps; exists (InFun (mf ∪ mf')); split.
    { constructor; auto. by rewrite sep_associative by auto. }
    intros Δ' k' φ' m2 m2'.
    inversion 1 as [|mA| |]; intros; simplify_mem_disjoint_hyps; subst.
    + split; auto. apply ax_unframe_fun_to_expr with mA; auto.
      by rewrite sep_associative by auto.
    + split; auto. apply ax_unframe_fun_to_fun; auto.
      by rewrite sep_associative by auto.
Qed.
#[global] Instance ax_expr_proper Γ δ :
  Proper ((≡{Γ,δ}) ==> (≡{Γ,δ}) ==> (=) ==>
          pointwise_relation _ (≡{Γ,δ}) ==> iff) (ax_expr Γ δ).
Proof.
  cut (Proper ((≡{Γ,δ}) ==> (≡{Γ,δ}) ==> (=) ==>
    pointwise_relation _ (≡{Γ,δ}) ==> impl) (ax_expr Γ δ)).
  { intros help. by split; apply help. }
  intros A1 A2 HA P1 P2 HP ?? -> Q1 Q2 HQ Hax ???????????????? (?&?&?&?&?&?) ?.
  eapply ax_weaken with (ax_expr_cond ρ A1) (ax_expr_post Q1 τlr) n; eauto.
  * apply Hax, HP; eauto.
    econstructor; split_and ?; eauto. apply HA; eauto.
  * destruct 2; constructor; auto.
    apply HA; eauto using indexes_valid_weaken, funenv_valid_weaken.
  * destruct 2; subst; simplify_mem_disjoint_hyps; econstructor; first
     [by eauto|apply HA;eauto using indexes_valid_weaken, funenv_valid_weaken].
  * destruct 2; constructor; auto.
    apply HQ; eauto using indexes_valid_weaken, funenv_valid_weaken.
Qed.
End axiomatic.


From RecordUpdate Require Import RecordSet.
Import RecordSetNotations.

From Perennial.algebra Require Import liftable auth_map.
From Perennial.Helpers Require Import Transitions.
From Perennial.program_proof Require Import disk_prelude.
From Perennial.Helpers Require Import NamedProps Map List range_set.
From Perennial.algebra Require Import log_heap.
From Perennial.program_logic Require Import spec_assert.

From Goose.github_com.mit_pdos.go_nfsd Require Import simple.
From Perennial.program_proof Require Import obj.obj_proof marshal_proof addr_proof crash_lockmap_proof addr.addr_proof buf.buf_proof.
From Perennial.program_proof Require Import jrnl.sep_jrnl_proof jrnl.sep_jrnl_recovery_proof.
From Perennial.program_proof Require Import disk_prelude.
From Perennial.program_proof Require Import disk_lib.
From Perennial.goose_lang.lib Require Import slice.typed_slice into_val.
From Perennial.program_proof.simple Require Import spec invariant common.
From Perennial.goose_lang Require Import crash_modality.

Section stable.
Context `{!heapGS Σ}.
Context `{!simpleG Σ}.

Global Instance is_inode_stable_set_stable γsrc γ':
    IntoCrash ([∗ set] a ∈ covered_inodes, is_inode_stable γsrc γ' a)
              (λ _, ([∗ set] a ∈ covered_inodes, is_inode_stable γsrc γ' a))%I.
Proof. rewrite /IntoCrash. iApply post_crash_nodep. Qed.

Global Instance is_txn_durable_stable γ dinit logm:
    IntoCrash (is_txn_durable γ dinit logm) (λ _, is_txn_durable γ dinit logm).
Proof.
  rewrite /IntoCrash. iNamed 1.
  iDestruct (post_crash_nodep with "Hlogm") as "Hlogm".
  iDestruct (post_crash_nodep with "Hasync_ctx") as "Hasync_ctx".
  iCrash. rewrite /is_txn_durable. iFrame.
Qed.

Lemma is_source_into_crash P P' γsrc:
  (∀ σ, P σ -∗ post_crash (λ hG, P' hG σ)) -∗
  is_source P γsrc -∗ post_crash (λ hG, is_source (P' hG) γsrc).
Proof.
  iIntros "HPwand Hsrc".
  iNamed "Hsrc".
  iDestruct (post_crash_nodep with "Hnooverflow") as "-#Hnooverflow'".
  iDestruct (post_crash_nodep with "Hsrcheap") as "Hsrcheap".
  iDestruct ("HPwand" with "[$]") as "HP".
  iCrash. iExists _. iFrame. eauto.
Qed.

End stable.

Section goose_lang.
Context `{!heapGS Σ}.
Context `{!simpleG Σ}.
Implicit Types (stk:stuckness) (E: coPset).

Context (P1 : SimpleNFS.State → iProp Σ).
Context (P2 : SimpleNFS.State → iProp Σ).

Definition fs_kinds sz : gmap u64 bufDataKind :=
  {[U64 513 := KindInode]} ∪
  gset_to_gmap KindBlock (rangeSet 514 (sz - 514)).

Definition fs_dinit sz : gmap Z Block :=
  gset_to_gmap block0 (list_to_set $ seqZ 513 (sz-513)).

Lemma dom_fs_dinit:
  ∀ sz : Z,
    513 + 1 + (32 - 2) ≤ sz
    → dom (fs_dinit sz) = list_to_set (seqZ 513 (sz - 513)).
Proof.
  intros sz Hsz.
  rewrite /fs_dinit.
  rewrite dom_gset_to_gmap.
  auto with f_equal lia.
Qed.

Lemma dom_fs_kinds:
  ∀ sz : Z,
    513 + 1 + (32 - 2) ≤ sz
    → dom (fs_kinds sz) = list_to_set (U64 <$> seqZ 513 (sz - 513)).
Proof.
  intros sz Hsz.
  rewrite /fs_kinds.
  rewrite dom_union_L dom_singleton_L.
  rewrite dom_gset_to_gmap.
  rewrite /rangeSet.
  replace (seqZ 513 (sz - 513)) with ([513] ++ seqZ 514 (sz - 514)); auto.
  change ([513]) with (seqZ 513 1).
  rewrite <- seqZ_app by lia.
  auto with f_equal lia.
Qed.

Lemma gmap_uncurry_union K1 K2 `{Countable K1} `{Countable K2} A
      (m1 m2: gmap K1 (gmap K2 A)) :
  m1 ##ₘ m2 →
  gmap_uncurry (m1 ∪ m2) = gmap_uncurry m1 ∪ gmap_uncurry m2.
Proof.
  intros.
  apply map_eq; intros.
  rewrite lookup_union.
  destruct i as [i1 i2].
  rewrite !lookup_gmap_uncurry.
  rewrite lookup_union.
  destruct (m1 !! i1) eqn:?;
           destruct (m2 !! i1) eqn:?;
           simpl;
    auto.
  - apply map_disjoint_dom in H1.
    apply elem_of_dom_2 in Heqo.
    apply elem_of_dom_2 in Heqo0.
    set_solver.
  - destruct (g !! i2); simpl; auto.
  - rewrite /union_with /=.
    destruct (g !! i2); simpl; auto.
Qed.

Lemma gmap_uncurry_insert K1 K2 `{Countable K1} `{Countable K2} A
      k (m11: gmap K2 A) (m2: gmap K1 (gmap K2 A)) :
  m2 !! k = None →
  gmap_uncurry (<[k := m11]> m2) = map_fold (λ i2 x, <[(k,i2):=x]>) (gmap_uncurry m2) m11.
Proof.
  rewrite /gmap_uncurry => Hlookup.
  simpl.

  rewrite map_fold_insert_L //; last first.
  intros.
Abort.

Lemma zero_disk_to_inodes γ sz :
  (513 + 1 + (32-2) ≤ sz < 2^49) →
  ([∗ map] a ↦ o ∈ kind_heap0 (fs_kinds sz), durable_mapsto_own γ a o) -∗
  ([∗ set] inum ∈ covered_inodes, is_inode_enc inum (U64 0) (U64 0) (durable_mapsto_own γ)) ∗
  ([∗ list] _ ↦ a ∈ seqZ 513 (32-2), durable_mapsto_own γ (blk2addr (U64 a)) (existT _ (bufBlock block0)))
.
Proof.
  iIntros (Hsz) "Hobjs".
  rewrite /fs_kinds.
  rewrite /kind_heap0.

  rewrite map_fmap_union.
  rewrite gmap_uncurry_union.
  2: {
    admit.
  }
  rewrite map_fmap_singleton.
  rewrite fmap_gset_to_gmap.
  rewrite big_sepM_union.
  2: {
    admit.
  }
  iDestruct "Hobjs" as "[Hinodes Hblocks]".
  rewrite /covered_inodes.
  iSplitL "Hinodes".
  - rewrite /is_inode_enc.
    admit.
  - admit.
Abort.

(* amazingly not in Coq 8.12 *)
Lemma repeat_app {A} n1 n2 (x:A) :
  repeat x (n1+n2)%nat = repeat x n1 ++ repeat x n2.
Proof. induction n1; simpl; congruence. Qed.

(* sz is the actual size of the disk *)
Lemma wpc_Mkfs d sz :
  (513 + 1 + (32-2) ≤ sz < 2^49) →
  {{{ 0 d↦∗ repeat block0 (Z.to_nat sz) ∗ P1 (gset_to_gmap [] (rangeSet 2 (NumInodes-2)))  }}}
    Mkfs (disk_val d) @ ⊤
  {{{ γtxn γsrc (txn:loc), RET #txn;
      let logm0 := Build_async (kind_heap0 (fs_kinds sz)) [] in
      is_txn_durable γtxn (fs_dinit sz) logm0 ∗
      is_source P1 γsrc
    }}}
   {{{ True }}}.
Proof.
  intros Hsz.
  iIntros (Φ Φc) "Hd HΦ".
  replace (Z.to_nat sz) with (513 + (Z.to_nat sz - 513))%nat by lia.
  rewrite repeat_app disk_array_app.
  iDestruct "Hd" as "[Hlog Hd]".
  rewrite repeat_length.
  change (0 + 513%nat) with 513.
  replace (Z.to_nat sz - 513)%nat with (Z.to_nat $ sz - 513) by lia.
  iMod (is_txn_durable_init (fs_dinit sz) (fs_kinds sz) _
          with "[$Hlog $Hd]") as (γ Hkinds) "(Htxn & #Hlb & Hmapstos)".
  { rewrite -> Z2Nat.id by word.
    apply dom_fs_dinit; lia. }
  { rewrite -> Z2Nat.id by word.
    apply dom_fs_kinds; lia. }
  { rewrite /block_bytes.
    rewrite -> !Z2Nat.id by word.
    lia. }
  rewrite /Mkfs.
  wpc_pures.
  { crash_case; auto. }
  iCache (Φc)%I with "HΦ".
  { crash_case; auto. }
  wpc_apply (wpc_MkLog (nroot.@"simple") with "[$Htxn]").
  { solve_ndisj. }
  { solve_ndisj. }
  iSplit.
  { iLeft in "HΦ".
    iIntros "H".
    iApply "HΦ"; auto. }
  iNext.
  iIntros (γ' txn_l) "Hpost".
  iDestruct "Hpost" as "(#Htxn & #Htxn_system & Hcfupd & Hcinv)".
  wpc_pures.
  wpc_frame "HΦ".
  wp_apply (wp_Op__Begin with "[$Htxn $Htxn_system]").
  iIntros (γtxn l).
  iIntros "Hjrnl".
  wp_pures.
  (* the interesting part, reasoning about [inodeInit]; will need to break apart
     Hmapstos and turn it into a bunch of inodes in order to lift them *)
Abort.

Lemma is_source_later_upd P P' γsrc:
  (∀ σ, ▷ P σ -∗ |C={⊤ ∖ ↑N}=> ▷ P σ ∗ ▷ P' σ) -∗
   ▷ is_source P γsrc -∗
   |C={⊤}=> ▷ is_source P' γsrc.
Proof.
  iIntros "Hwand H". iDestruct "H" as (?) "(>?&>%&>#?&?)".
  iSpecialize ("Hwand" with "[$]").
  iMod (cfupd_weaken_mask with "Hwand") as "(HP1&HP2)"; auto.
  iModIntro.
  iNext. iExists _. iFrame "# ∗ %".
Qed.

Lemma crash_upd_src γsrc γ' src:
  dom src = covered_inodes →
  ("Hlmcrash" ∷ ([∗ set] y ∈ covered_inodes, is_inode_stable γsrc γ' y) ∗
  "Hsrcheap" ∷ map_ctx γsrc 1 src) ==∗
  ∃ γsrc',
  map_ctx γsrc 1 src ∗
  map_ctx γsrc' 1 src ∗
  [∗ set] y ∈ covered_inodes, is_inode_stable γsrc' γ' y.
Proof.
  iIntros (Hdom) "H". iNamed "H".
  iMod (map_init ∅) as (γsrc') "H".
  iMod (map_alloc_many src with "H") as "(Hctx&Hmapsto)".
  { intros. rewrite lookup_empty //=. }
  rewrite right_id_L.
  iModIntro. iExists γsrc'.
  rewrite -Hdom -?big_sepM_dom.
  iFrame "Hctx".
  iCombine "Hmapsto Hlmcrash" as "H".
  rewrite -big_sepM_sep.
  iApply (big_sepM_mono_with_inv with "Hsrcheap H").
  iIntros (k v Hlookup) "(Hctx&src&Hstable)".
  iNamed "Hstable".
  iDestruct (map_valid with "[$] [$]") as %Heq.
  subst. iFrame. iExists _. iFrame. rewrite /named. iExactEq "src". f_equal. congruence.
Qed.

Definition fs_cfupd_cancel dinit P :=
  ((|C={⊤}=>
    ∃ γ γsrc logm',
    is_txn_durable γ dinit logm' ∗
    ▷ is_source P γsrc ∗
    [∗ set] a ∈ covered_inodes, is_inode_stable γsrc γ a))%I.

Theorem wpc_Recover γ γsrc d dinit logm :
  {{{
    (∀ σ, ▷ P1 σ -∗ |C={⊤ ∖ ↑N}=> ▷ P1 σ ∗ ▷ P2 σ) ∗
    is_txn_durable γ dinit logm ∗
    ▷ is_source P1 γsrc ∗
    [∗ set] a ∈ covered_inodes, is_inode_stable γsrc γ a
  }}}
    Recover (disk_val d) @ ⊤
  {{{ nfs, RET #nfs;
      init_cancel (∃ γsimp, is_fs P1 γsimp nfs dinit) (fs_cfupd_cancel dinit P2)}}}
  {{{
    ∃ γ' γsrc' logm',
    is_txn_durable γ' dinit logm' ∗
    ▷ is_source P2 γsrc' ∗
    [∗ set] a ∈ covered_inodes, is_inode_stable γsrc' γ' a
  }}}.
Proof using All.
  iIntros (Φ Φc) "(Hshift & Htxndurable & Hsrc & Hstable) HΦ".
  rewrite /Recover.
  iApply wpc_cfupd.
  wpc_pures.
  { iDestruct "HΦ" as "[HΦc _]".
    iMod (is_source_later_upd P1 P2 with "Hshift Hsrc") as "Hsrc".
    iModIntro. iApply "HΦc".
    iExists _, _, _. iFrame. }

  wpc_apply (wpc_MkLog Njrnl with "Htxndurable").
  { solve_ndisj. }
  { solve_ndisj. }

  iSplit.
  { iDestruct "HΦ" as "[HΦc _]". iIntros "H".
    iDestruct "H" as (γ' logm') "Htxndurable".
    iDestruct "Htxndurable" as "(Hdurable&[%Heq|#Hexch])".
    { subst.
      iMod (is_source_later_upd P1 P2 with "[$] Hsrc") as "Hsrc".
      iModIntro. iApply "HΦc". iExists _, _, _.
      iFrame. }
    iMod (is_source_later_upd P1 P2 with "[$] Hsrc") as "Hsrc".
    iIntros "#HC".
    iAssert (|={⊤}=> [∗ set] a ∈ covered_inodes, is_inode_stable γsrc γ' a)%I with "[Hstable]" as ">Hcrash".
    {
      iApply big_sepS_fupd.
      iApply (big_sepS_wand with "Hstable").
      iApply big_sepS_intro. iModIntro. iIntros (? Hin) "H".
      iMod (is_inode_stable_crash with "[$] [$] [$]"); eauto.
    }
    iModIntro.
    iApply "HΦc".
    iExists _, _, _. iFrame.

  }

  iModIntro.
  iIntros (γ' l) "(#Histxn & #Htxnsys & Hcfupdcancel & #Htxncrash)".
  iCache (|C={⊤}=> Φc)%I with "Hshift Hsrc Hstable Hcfupdcancel HΦ".
  { iDestruct "HΦ" as "[HΦc _]". iIntros "#HC".
    iAssert (|={⊤}=> [∗ set] a ∈ covered_inodes, is_inode_stable γsrc γ' a)%I with "[Hstable]" as ">Hcrash".
    {
      iApply big_sepS_fupd.
      iApply (big_sepS_wand with "Hstable").
      iApply big_sepS_intro. iModIntro. iIntros (? Hin) "H".
      iMod (is_inode_stable_crash with "[$] [$] [$]"); eauto.
    }
    rewrite /txn_cfupd_cancel.
    iMod (is_source_later_upd P1 P2 with "[$] Hsrc [$]") as "Hsrc".
    rewrite own_discrete_elim.
    iMod ("Hcfupdcancel" with "[$]") as ">Hcfupdcancel".
    iModIntro.
    iApply "HΦc".
    iDestruct "Hcfupdcancel" as (?) "H".
    iExists _, _, _. iFrame.
  }

  wpc_frame.
  wp_pures.
  (*

  wpc_pures.
  { iDestruct "HΦ" as "[HΦc _]". iIntros "#HC".
    iAssert (|={⊤}=> [∗ set] a ∈ covered_inodes, is_inode_stable γsrc γ' a)%I with "[Hstable]" as ">Hcrash".
    {
      iApply big_sepS_fupd.
      iApply (big_sepS_wand with "Hstable").
      iApply big_sepS_intro. iModIntro. iIntros (? Hin) "H".
      unshelve (iMod (is_inode_stable_crash with "[$] [$] [$]"); eauto).
      { exact O. (* This will go away when we remove the useless k parameter *)  }
    }
    rewrite /txn_cfupd_cancel.
    iMod (is_source_later_upd P1 P2 with "[$] Hsrc [$]") as "Hsrc".
    rewrite own_discrete_elim.
    iMod ("Hcfupdcancel" with "[$]") as ">Hcfupdcancel".
    iModIntro.
    iApply "HΦc".
    iDestruct "Hcfupdcancel" as (?) "H".
    iExists _, _, _. iFrame.
  }
   *)

  wp_apply (wp_MkLockMap).
  iIntros (lm) "Hfree".

  (*
  iMod (inv_alloc N with "Hsrc") as "#Hsrc".
   *)

  (*
  iApply wp_wpc_frame'.
  iSplitL "Hlmcrash Hcfupdcancel HΦ Hsrc Hshift".
  {
    iAssert (fs_cfupd_cancel dinit P2)%I with "[-HΦ]" as "Hcancel".
    { iModIntro.
      rewrite -big_sepS_later.
      iMod "Hlmcrash" as ">Hlmcrash". iMod "Hcfupdcancel" as ">Hcfupdcancel".
      iIntros "#HC".
      iInv "Hsrc" as "Hopen" "Hclose".
      iDestruct "Hopen" as (?) "(>Hsrcheap&>%Hdom&>#Hnooverflow&HP)".
      iMod (crash_upd_src with "[$]") as (γsrc') "(Hsrcheap&Hsrcheap'&Hlmcrash)".
      { eauto. }
      iMod ("Hshift" with "HP HC") as "(HP1&HP2)".
      iMod ("Hclose" with "[HP1 Hsrcheap]") as "_".
      { iNext. iExists _. iFrame "# ∗ %". }
      iDestruct "Hcfupdcancel" as (?) "?".
      iExists γ', γsrc', _. iFrame.
      iModIntro. iNext. iExists _. iFrame "# ∗ %".
    }
    iSplit.
    { iDestruct "HΦ" as "[HΦc _]". iModIntro. iMod ("Hcancel"). iModIntro. by iApply "HΦc". }
    { iNamedAccu. }
  }

   *)
  wp_apply wp_allocStruct; first val_ty.
  iIntros (nfs) "Hnfs".

  iDestruct (struct_fields_split with "Hnfs") as "Hnfs". iNamed "Hnfs".
  iMod (readonly_alloc_1 with "t") as "#Ht".
  iMod (readonly_alloc_1 with "l") as "#Hl".

  (*
  iAssert (is_fs P1 (Build_simple_names γ γ' γsrc ghs) nfs dinit) with "[]" as "Hfs".
  { iExists _, _. iFrame "Ht Hl Histxn Htxnsys Htxncrash Hlm Hsrc". }
   *)
  wp_pures. iModIntro. iNamed 1.
  iRight in "HΦ". iApply "HΦ".
  iApply fupd_init_cancel.
  iMod (inv_alloc N with "Hsrc") as "#Hsrc".
  rewrite /txn_cfupd_cancel.
  iDestruct (alloc_lockMap_init_cancel covered_inodes lm
                                       (is_inode_stable γsrc γ)
                                       (λ a, C -∗ |={⊤}=> is_inode_stable γsrc γ' a)%I
               with "[Hstable] [$]") as "Hcancel".
  {
    iApply (big_sepS_wand with "Hstable").
    iApply big_sepS_intro. iModIntro. iIntros (? Hin) "H".
    iFrame. iModIntro. iIntros "Hstable".
    iMod (is_inode_stable_crash with "[$] [$]"); eauto.
  }
  iApply (init_cancel_wand with "Hcancel [] [Hcfupdcancel Hshift]").
  {
    iDestruct 1 as (ghs) "Hlm".
    iExists (Build_simple_names γ γ' γsrc ghs).
    { iExists _, _. iFrame "Ht Hl Histxn Htxnsys Htxncrash Hsrc". eauto. }
  }

  iIntros "H".
  rewrite /fs_cfupd_cancel.
  iAssert (|C={⊤}=> [∗ set] a ∈ covered_inodes, is_inode_stable γsrc γ' a)%I
    with "[H]" as ">H".
  { iIntros "#HC". iApply big_sepS_fupd.
    iApply (big_sepS_wand with "H"). iApply big_sepS_intro.
    iModIntro. iIntros (??) "H". iMod ("H" with "[$]") as "$". eauto. }
  iEval (rewrite own_discrete_elim) in "Hcfupdcancel".
  iMod ("Hcfupdcancel") as "Hcfupdcancel".
  iIntros "HC". iDestruct "Hcfupdcancel" as ">Hcfupdcancel".
  iInv "Hsrc" as "Hopen" "Hclose".
  iDestruct "Hopen" as (?) "(>Hsrcheap&>%Hdom&>#Hnooverflow&HP)".
  iMod (crash_upd_src with "[$]") as (γsrc') "(Hsrcheap&Hsrcheap'&Hlmcrash)".
  { eauto. }
  iMod ("Hshift" with "HP HC") as "(HP1&HP2)".
  iMod ("Hclose" with "[HP1 Hsrcheap]") as "_".
  { iNext. iExists _. iFrame "# ∗ %". }
  iDestruct "Hcfupdcancel" as (?) "?".
  iExists γ', γsrc', _. iFrame.
  iModIntro. iNext. iExists _. iFrame "# ∗ %".
Qed.

End goose_lang.


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From mathcomp
Require Import path.
Require Import Eqdep.
Require Import Relation_Operators.
From fcsl
Require Import axioms pred prelude ordtype finmap pcm unionmap heap.
From DiSeL
Require Import Freshness State EqTypeX Protocols Worlds NetworkSem Rely.
From DiSeL
Require Import Actions Injection Process Always HoareTriples InferenceRules.
From DiSeL
Require Import InductiveInv StatePredicates.
From DiSeL
Require Import CalculatorProtocol.

Section CalculatorInductiveInv.

Variable l : Label.

Variable f : input -> option nat.
Variable prec : input -> bool.
Hypothesis prec_valid :
  forall i, prec i -> exists v, f i = Some v.

Variable cs: seq nid.
Variable cls : seq nid.
(* All nodes *)
Notation nodes := (cs ++ cls).
(* All nodes are unique *)
Hypothesis Huniq : uniq nodes.

(* Protocol and its transitions *)
Notation cal := (CalculatorProtocol f prec cs cls l).
Notation sts := (snd_trans cal).
Notation rts := (rcv_trans cal).

Definition reqs := cstate.
Notation coh := (coh cal).

Notation loc n d := (getLocal n d).

Lemma nodes_falso z : z \in cs -> z \in cls -> False.
Proof.
move=>H1 H2.
move: (Huniq); rewrite cat_uniq=>/andP[_]/andP[/negP H]_.
by apply: H; apply/hasP; exists z.
Qed.

Definition CalcInv d :=
  forall (C: coh d) n to v args i s',
    n \in cls -> to \in cs ->
    dsoup d = i \\-> (Msg (TMsg resp (v::args)) to n true) \+ s' ->
    f args = Some v.

Notation cal' := (CalculatorProtocol f prec cs cls l).
Notation coh' := (coh cal).
Notation Sinv := (@S_inv cal (fun d _ => CalcInv d)).
Notation Rinv := (@R_inv cal (fun d _ => CalcInv d)).
Notation PI := pf_irr.

Program Definition s1: Sinv (server_send_trans f prec cs cls).
Proof.
move=>this to d msg S b.
move=>/= Hi E G C' n to' v' args' i s1 N1 N2/= Es.
case: (S)=>_[_][C]/hasP[[[me cc]args]]_.
case/andP=>/eqP Z1/andP[/eqP Y]/eqP Z2.
move: (cohVs C')=>V; rewrite joinC/= in Es V.
move: (cancel2 V Es)=>/=; case: ifP.
- move=>_; case. case=>Z3 Z4 Z5 Z6; subst s1 to to' msg.
  by simpl in Y; case: Z2=>->.
move=>_[E1]/=E2 E3; subst to. clear Es V.
by apply: (Hi C n to' v' args' i _ _ _ E2).
Qed.

Program Definition s2: Sinv (client_send_trans prec cs cls).
Proof.
move=>this to d msg S b.
move=>/= Hi E G C' n to' v' args' i s1 N1 N2/= Es.
move: (cohVs C')=>V; rewrite joinC/= in Es V.
move: (cancel2 V Es)=>/=; case: ifP; last first.
- move=>_[E1]/=E2 E3; clear Es V.
  by case: (S)=>_[_]C _; apply: (Hi C n to' v' args' i _ _ _ E2).
move/eqP=>Z; subst i; by case; discriminate.
Qed.

Program Definition r1: Rinv (server_recv_trans prec cs cls).
Proof.
move=>d from this i C m pf Hi F D Hw Et _.
move=> C' n to v args i' s1 N1 N2/=Es.
suff Es' : exists s', dsoup d =
       i' \\-> {| content := {| tag := resp; tms_cont := v :: args |};
                  from := to;  to := n;
                  active := true |} \+ s'.
by case: Es'=>s' Es'; apply: (Hi C n to v args i' _ N1 N2 Es').
case B: (i \in dom (dsoup d)); last first.
by move: dom_find B Es; rewrite /consume_msg; case=>//->_->; exists s1.
move/um_eta: B=>[vm][_]S1.
move: (cohVs C)=>V; rewrite S1 in V.
rewrite S1 joinC consumeUn ?eqxx joinC// in Es.
suff V': valid (i \\-> mark_msg vm \+
                free (cT:=union_mapUMC mid (msg TaggedMessage)) i (dsoup d)).
- move: (cancel2 V' Es); case: ifP=>B.
  - move/eqP:B=>B{S1 V V' Es}; subst i'.
    by case: vm=>????/=; rewrite /mark_msg/=; case; discriminate.
  by case=>_ X2 _; rewrite X2 joinCA in S1; rewrite S1; eexists _.
move: (consume_valid i V).
rewrite /consume_msg/= findUnL// ?domPt inE/= eqxx findPt/=.
by rewrite updUnL/= domPt/=!inE eqxx !updPt/=.
Qed.

Program Definition r2: Rinv (client_recv_trans prec cs cls).
Proof.
move=>d from this i C m pf Hi F D Hw Et _.
move=> C' n to v args i' s1 N1 N2/=Es.
suff Es' : exists s', dsoup d =
       i' \\-> {| content := {| tag := resp; tms_cont := v :: args |};
                  from := to;  to := n;
                  active := true |} \+ s'.
by case: Es'=>s' Es'; apply: (Hi C n to v args i' _ N1 N2 Es').
case B: (i \in dom (dsoup d)); last first.
by move: dom_find B Es; rewrite /consume_msg; case=>//->_->; exists s1.
move/um_eta: B=>[vm][_]S1.
move: (cohVs C)=>V; rewrite S1 in V.
rewrite S1 joinC consumeUn ?eqxx joinC// in Es.
suff V': valid (i \\-> mark_msg vm \+
                free (cT:=union_mapUMC mid (msg TaggedMessage)) i (dsoup d)).
- move: (cancel2 V' Es); case: ifP=>B.
  - move/eqP:B=>B{S1 V V' Es}; subst i'.
    by case: vm=>????/=; rewrite /mark_msg/=; case; discriminate.
  by case=>_ X2 _; rewrite X2 joinCA in S1; rewrite S1; eexists _.
move: (consume_valid i V).
rewrite /consume_msg/= findUnL// ?domPt inE/= eqxx findPt/=.
by rewrite updUnL/= domPt/=!inE eqxx !updPt/=.
Qed.

Definition sts' := [:: SI s1; SI s2].
Definition rts' := [:: RI r1; RI r2].

Program Definition ii := @ProtocolWithInvariant.II _ _ sts' rts' _ _.

Definition cal_with_inv := ProtocolWithIndInv ii.

(**************************************************)
(*
Overall Implementation effort:

1 person-day

*)
(**************************************************)

End CalculatorInductiveInv.


Set Implicit Arguments.

Require Import RandomQC.
Require Import Coq.Strings.String.

Require Import StringOT.
Require Import FSets.FMapAVL.

Module Map := FMapAVL.Make(StringOT).

Record State := MkState
  { maxSuccessTests   : nat
  ; maxDiscardedTests : nat
  ; maxShrinkNo       : nat
  ; computeSize       : nat -> nat -> nat

  ; numSuccessTests   : nat
  ; numDiscardedTests : nat

  ; labels            : Map.t nat

  ; expectedFailure   : bool
  ; randomSeed        : RandomSeed

  ; numSuccessShrinks : nat
  ; numTryShrinks     : nat
  ; stDoAnalysis      : bool
  }.

Definition updTryShrinks (st : State) (f : nat -> nat) : State :=
  match st with
    | MkState mst mdt ms cs nst ndt ls e r nss nts ana =>
      MkState mst mdt ms cs nst ndt ls e r nss (f nts) ana
  end.

Definition updSuccessShrinks (st : State) (f : nat -> nat) : State :=
  match st with
    | MkState mst mdt ms cs nst ndt ls e r nss nts ana =>
      MkState mst mdt ms cs nst ndt ls e r (f nss) nts ana
  end.

Definition updSuccTests st f :=
  match st with
    | MkState mst mdt ms cs nst     ndt ls e r nss nts ana =>
      MkState mst mdt ms cs (f nst) ndt ls e r nss nts ana
  end.

Definition updDiscTests st f :=
  match st with
    | MkState mst mdt ms cs nst ndt     ls e r nss nts ana =>
      MkState mst mdt ms cs nst (f ndt) ls e r nss nts ana
  end.


(** * Data types for the crowdfunding contract *)

Require Import String ZArith Basics.
From ConCert.Embedding Require Import Ast Notations PCUICTranslate Utils.
From ConCert.Embedding.Examples Require Import Prelude SimpleBlockchain.
Require Import List PeanoNat ssrbool.

Import ListNotations.
From MetaCoq.Template Require Import All.

Import MonadNotation.
Import BaseTypes.
Open Scope list.

Import AcornBlockchain.

(** Note that we define the deep embedding (abstract syntax trees) of the data structures and programs using notations. These notations are defined in  [Ast.v] and make use of the "custom entries" feature. *)

(** Brackets like [[\ \]] delimit the scope of data type definitions and like [[| |]] the scope of programs *)

(** Generating names for the data structures  *)
Run TemplateProgram
      (mkNames ["State" ; "mkState"; "balance" ; "donations" ; "owner"; "deadline"; "goal"; "done";
                "Res" ; "Error";
                "Msg"; "Donate"; "GetFunds"; "Claim";
                "Action"; "Transfer"; "Empty" ] "_coq").

Import ListNotations.

(** ** Definitions of data structures for the contract *)

(** The internal state of the contract *)
Definition state_syn : global_dec :=
  [\ record State :=
     mkState { balance : Money ;
       donations : Map;
       owner : Address;
       deadline : Nat;
       done : Bool;
       goal : Money } \].

(** We can print actual AST by switching off the notations *)

Unset Printing Notations.

Print state_syn.
(* state_syn =
    gdInd State O
      (cons
         (rec_constr State
            (cons (pair (nNamed balance) (tyInd Money))
               (cons (pair (nNamed donations) (tyInd Map))
                  (cons (pair (nNamed owner) (tyInd Money))
                     (cons (pair (nNamed deadline) (tyInd Nat))
                        (cons (pair (nNamed goal) (tyInd Money)) nil)))))) nil) true
         : global_dec *)

Set Printing Notations.

(** Unquoting the definition of a record *)
Set Nonrecursive Elimination Schemes.
Make Inductive (global_to_tc state_syn).

(** As a result, we get a new Coq record [State_coq] *)
Print State_coq.

Definition msg_syn :=
  [\ data Msg =
       Donate [_]
     | GetFunds [_]
     | Claim [_] \].

Make Inductive (global_to_tc msg_syn).

(** Custom notations for patterns, projections and constructors *)
Module Notations.

  Notation "'ctx_from' a" := [| {eConst "Ctx_from"} {a} |]
                             (in custom expr at level 0).
  Notation "'ctx_contract_address' a" :=
    [| {eConst "Ctx_contract_address"} {a} |]
      (in custom expr at level 0).
  Notation "'amount' a" := [| {eConst "Ctx_amount"} {a} |]
                             (in custom expr at level 0).

  (** Projections *)
  Notation "'balance' a" :=
    [| {eConst balance} {a} |]
      (in custom expr at level 0).
  Notation "'donations' a" :=
    [| {eConst donations} {a} |]
      (in custom expr at level 0).
  Notation "'owner' a" :=
    [| {eConst owner} {a} |]
      (in custom expr at level 0).
  Notation "'deadline' a" :=
    [| {eConst deadline} {a} |]
      (in custom expr at level 0).
  Notation "'goal' a" :=
    [| {eConst goal} {a} |]
      (in custom expr at level 0).
  Notation "'done' a" :=
    [| {eConst done} {a} |]
      (in custom expr at level 0).

  Notation "'Nil'" := [| {eConstr "list" "nil"} {eTy (tyInd SActionBody)} |]
                      (in custom expr at level 0).

  Notation " x ::: xs" := [| {eConstr "list" "cons"} {eTy (tyInd SActionBody)} {x} {xs} |]
                            ( in custom expr at level 0).

  Notation "[ x ]" := [| {eConstr "list" "cons"} {eTy (tyInd SActionBody)} {x} Nil |]
                        ( in custom expr at level 0,
                          x custom expr at level 1).
  (** Constructors. [Res] is an abbreviation for [Some (st, [action]) : option (State * list ActionBody)] *)

  Definition actions_ty := [! "list" "SimpleActionBody" !].

  Notation "'Result'" := [!"prod" State ("list" "SimpleActionBody") !]
                           (in custom type at level 2).

  Definition mk_res a b := [| {eConstr "option" "Some"}
                                {eTy [! Result !]}
                                 ({eConstr "prod" "pair"} {eTy (tyInd State)}
                                 {eTy actions_ty} {a} {b}) |].
  Notation "'Res' a b" := (mk_res a b)
      (in custom expr at level 2,
          a custom expr at level 4,
          b custom expr at level 4).

  Notation "'mkState' a b" :=
    [| {eConstr State "mkState_coq"} {a} {b} |]
      (in custom expr at level 0,
          a custom expr at level 1,
          b custom expr at level 1).

  Notation "'Transfer' a b" :=
    [| {eConstr SActionBody "Act_transfer"} {b} {a} |]
      (in custom expr at level 0,
          a custom expr at level 1,
          b custom expr at level 1).

  Notation "'Empty'" := (eConstr Action Empty)
                      (in custom expr at level 0).

  (** New global context with the constants defined above (in addition to the ones defined in the Oak's "StdLib") *)

  Definition Σ' :=
    Prelude.Σ ++ [ Prelude.AcornMaybe;
           state_syn;
           msg_syn;
           addr_map_acorn;
           AcornBlockchain.SimpleChainAcorn;
           AcornBlockchain.SimpleContractCallContextAcorn;
           AcornBlockchain.SimpleActionBodyAcorn;
           gdInd "Z" 0 [("Z0", []); ("Zpos", [(None,tyInd "positive")]);
                          ("Zneg", [(None,tyInd "positive")])] false].

  Notation "0 'z'" := (eConstr "Z" "Z0") (in custom expr at level 0).
  End Notations.

Import Prelude.
(** Generating string constants for variable names *)

Run TemplateProgram (mkNames ["c";"s";"e";"m";"v";"dl"; "g"; "chain";
                              "tx_amount"; "bal"; "sender"; "own"; "isdone" ;
                              "accs"; "now";
                               "newstate"; "newmap"; "cond"] "").
(** A shortcut for [if .. then .. else ..]  *)
Notation "'if' cond 'then' b1 'else' b2 : ty" :=
  (eCase (Bool,[]) ty cond
         [(pConstr true_name [],b1);(pConstr false_name [],b2)])
    (in custom expr at level 4,
        cond custom expr at level 4,
        ty custom type at level 4,
        b1 custom expr at level 4,
        b2 custom expr at level 4).

Notation SCtx := "SimpleContractCallContext".


(** Heavily annotated for a tutorial introduction. *)

(** First, import the entire Floyd proof automation system, which includes
 ** the VeriC program logic and the MSL theory of separation logic**)
Require Import VST.floyd.proofauto.

(** Import the [reverse.v] file, which is produced by CompCert's clightgen
 ** from reverse.c.   The file reverse.v defines abbreviations for identifiers
 ** (variable names, etc.) of the C program, such as _head, _reverse.
 ** It also defines "prog", which is the entire abstract syntax tree
 ** of the C program *)
Require Import VST.progs.reverse.

(* The C programming language has a special namespace for struct
** and union identifiers, e.g., "struct foo {...}".  Some type-based operators
** in the program logic need access to an interpretation of this namespace,
** i.e., the meaning of each struct-identifier such as "foo".  The next
** line (which looks identical for any program) builds this
** interpretation, called "CompSpecs" *)
Instance CompSpecs : compspecs. make_compspecs prog. Defined.

(** Calculate the "types-of-global-variables" specification
 ** directly from the program *)
Definition Vprog : varspecs. mk_varspecs prog. Defined.

(** A convenience definition *)
Definition t_struct_list := Tstruct _list noattr.

(** Inductive definition of linked lists *)
Fixpoint listrep (sigma: list val) (x: val) : mpred :=
 match sigma with
 | h::hs =>
    EX y:val,
      data_at Tsh t_struct_list (h,y) x  *  listrep hs y
 | nil =>
    !! (x = nullval) && emp
 end.

Arguments listrep sigma x : simpl never.

(** Whenever you define a new spatial operator, such as
 ** [listrep] here, it's useful to populate two hint databases.
 ** The [saturate_local] hint is a lemma that extracts
 ** pure propositional facts from a spatial fact.
 ** The [valid_pointer] hint is a lemma that extracts a
 ** valid-pointer fact from a spatial lemma.
 **)

Lemma listrep_local_facts:
  forall sigma p,
   listrep sigma p |--
   !! (is_pointer_or_null p /\ (p=nullval <-> sigma=nil)).
Proof.
intros.
revert p; induction sigma;
  unfold listrep; fold listrep; intros; normalize.
apply prop_right; split; simpl; auto. intuition.
entailer!.
split; intro. subst p. destruct H; contradiction. inv H2.
Qed.

Hint Resolve listrep_local_facts : saturate_local.

Lemma listrep_valid_pointer:
  forall sigma p,
   listrep sigma p |-- valid_pointer p.
Proof.
 destruct sigma; unfold listrep; fold listrep;
 intros; normalize.
 auto with valid_pointer.
 apply sepcon_valid_pointer1.
 apply data_at_valid_ptr; auto.
 simpl;  computable.
Qed.

Hint Resolve listrep_valid_pointer : valid_pointer.

(** Specification of the [reverse] function.  It characterizes
 ** the precondition required for calling the function,
 ** and the postcondition guaranteed by the function.
 **)
Definition reverse_spec :=
 DECLARE _reverse
  WITH sigma : list val, p: val
  PRE  [ _p OF (tptr t_struct_list) ]
     PROP ()
     LOCAL (temp _p p)
     SEP (listrep sigma p)
  POST [ (tptr t_struct_list) ]
    EX q:val,
     PROP () LOCAL (temp ret_temp q)
     SEP (listrep(rev sigma) q).

(** The global function spec, characterizing the
 ** preconditions/postconditions of all the functions
 ** that your proved-correct program will call.
 ** Normally you include all the functions here, but
 ** in this tutorial example we include only one. *)
Definition Gprog : funspecs :=
         ltac:(with_library prog [ reverse_spec ]).

(** For each function definition in the C program, prove that the
 ** function-body (in this case, f_reverse) satisfies its specification
 ** (in this case, reverse_spec).
 **)
Lemma body_reverse: semax_body Vprog Gprog
                                    f_reverse reverse_spec.
Proof.
(** The start_function tactic "opens up" a semax_body
 ** proof goal into a Hoare triple. *)
start_function.
(** For each assignment statement, "symbolically execute" it
 ** using the forward tactic *)
forward.  (* w = NULL; *)
forward.  (* v = p; *)
(** To prove a while-loop, you must supply a loop invariant,
 ** in this case (EX s1  PROP(...)LOCAL(...)(SEP(...)).  *)
forward_while
   (EX s1: list val, EX s2 : list val,
    EX w: val, EX v: val,
     PROP (sigma = rev s1 ++ s2)
     LOCAL (temp _w w; temp _v v)
     SEP (listrep s1 w; listrep s2 v)).
(** The forward_while tactic leaves four subgoals,
 ** which we mark with * (the Coq "bullet") *)
* (* Prove that precondition implies loop invariant *)
Exists (@nil val) sigma nullval p.
entailer!.
unfold listrep.
entailer!.
* (* Prove that loop invariant implies typechecking of loop condition *)
entailer!.
* (* Prove that loop body preserves invariant *)
destruct s2 as [ | h r].
 - unfold listrep at 2.
   Intros. subst. contradiction.
 - unfold listrep at 2; fold listrep.
   Intros y.
   forward. (* t = v->tail *)
   forward. (* v->tail = w; *)
   forward. (* w = v; *)
   forward. (* v = t; *)
   (* At end of loop body; reestablish invariant *)
   entailer!.
   Exists (h::s1,r,v,y).
   entailer!.
   + simpl. rewrite app_ass. auto.
   + unfold listrep at 3; fold listrep.
     Exists w. entailer!.
* (* after the loop *)
forward.  (* return w; *)
Exists w; entailer!.
rewrite (proj1 H1) by auto.
unfold listrep at 2; fold listrep.
entailer!.
rewrite <- app_nil_end, rev_involutive.
auto.
Qed.

(** See the file [progs/verif_reverse.v] for an alternate
 ** proof of this function, using a general theory of
 ** list segments.  That file also has proofs of the
 ** sumlist function, the main function, and the
 ** [semax_func] theorem that ties all the functions together
 **)


Require Import Raft.
Require Import CommonDefinitions.
Require Import TraceUtil.

Section AppliedImpliesInputInterface.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Section inner.
    Variables client id : nat.
    Variable i : input.

    Definition correct_entry (e : entry) : Prop :=
      eClient e = client /\
      eId e = id /\
      eInput e = i.

    Definition applied_implies_input_state (net : network) : Prop :=
      exists e,
        correct_entry e /\
        ((exists h, In e (log (nwState net h))) \/
         (exists p entries, In p (nwPackets net) /\
                            mEntries (pBody p) = Some entries /\
                            In e entries)).

  End inner.

  Class applied_implies_input_interface : Prop :=
    {
      applied_implies_input :
        forall client id failed net tr e,
          step_f_star step_f_init (failed, net) tr ->
          eClient e = client ->
          eId e = id ->
          applied_implies_input_state client id (eInput e) net ->
          in_input_trace client id (eInput e) tr
    }.
End AppliedImpliesInputInterface.


(**

This file describes the syntax of an imperative lambda calculus with
pointers, structs and arrays.

Author: Ramon Fernandez I Mir and Arthur Charguéraud.

License: MIT.

*)

Set Implicit Arguments.
Require Export Bind TLCbuffer.
Require Export LibString LibCore LibLogic LibReflect
  LibOption LibRelation LibLogic LibOperation LibEpsilon
  LibMonoid LibSet LibContainer LibListZ LibMap.

Open Scope set_scope.
Open Scope container_scope.

(* ---------------------------------------------------------------------- *)
(** Representation of locations and fields *)

(** [loc] describes base pointers to an allocated block. *)

Definition loc := int.
Definition null : loc := 0%Z.

(** A struct is a map from [field]s. *)

Definition field := var.

(* ---------------------------------------------------------------------- *)
(** Representation of low-level memory constructs  *)

(** We need [size]s for low-level memory accesses and also for arrays.  *)

Definition size := int.

(** Low-level pointers use [offset]s. *)

Definition offset := int.

(** A [word] is the basic memory unit. *)

Inductive word : Type :=
  | word_undef : word
  | word_int : int -> word.

Definition words := list word.

(** Bijection between high-level and low-level memory locations. *)

Definition alpha := map loc loc.

(* ---------------------------------------------------------------------- *)
(** Grammar of types *)

Definition typvar := var.

Inductive typ : Type :=
  | typ_unit : typ
  | typ_int : typ
  | typ_double : typ
  | typ_bool : typ
  | typ_ptr : typ -> typ
  | typ_array : typ -> option size -> typ
  | typ_struct : map field typ -> typ
  | typ_fun : list typ -> typ -> typ
  | typ_var : typvar -> typ.

(** Type of the state *)

Definition phi := map loc typ.
Definition empty_phi : phi := empty.

(** Type of a stack *)

Definition gamma := Ctx.ctx typ.
Definition empty_gamma : gamma := nil.

(* ---------------------------------------------------------------------- *)
(** Contexts *)

(** Type definitions context *)

Definition typdefctx := map typvar typ.

(** Contex holding low-level information about structs and their fields. *)

Definition ll_typdefctx_typvar_sizes := map typvar size.
Definition ll_typdefctx_fields_offsets := map typvar (map field offset).
Definition ll_typdefctx_fields_order := map typvar (list field).

Record ll_typdefctx := make_ll_typdefctx {
  typvar_sizes : ll_typdefctx_typvar_sizes;
  fields_offsets : ll_typdefctx_fields_offsets;
  fields_order : ll_typdefctx_fields_order }.

Notation "'make_ll_typdefctx''" := make_ll_typdefctx.

(* ---------------------------------------------------------------------- *)
(** Syntax of the source language *)

(** High-level pointers are represented using [accesses]. *)

Inductive access : Type :=
  | access_array : typ -> int -> access
  | access_field : typ -> field -> access.

Definition accesses := list access.

(** Values. *)

Inductive val : Type :=
  | val_error : val
  | val_unit : val
  | val_uninitialized : val
  | val_bool : bool -> val
  | val_int : int -> val
  | val_double : int -> val
  | val_abstract_ptr : loc -> accesses -> val
  | val_concrete_ptr : loc -> offset -> val
  | val_array : typ -> list val -> val
  | val_struct : typ -> map field val -> val
  | val_words : list word -> val.

(** Binary operations. *)

Inductive binop : Type :=
  | binop_eq : binop
  | binop_sub : binop
  | binop_add : binop
  | binop_mul : binop
  | binop_div : binop
  | binop_mod : binop
  | binop_ptr_add : binop.

(** Primitive functions. *)

Inductive prim : Type :=
  | prim_binop : binop -> prim
  | prim_get : typ -> prim
  | prim_set : typ -> prim
  | prim_new : typ -> prim
  | prim_new_array : typ -> prim
  | prim_struct_access : typ -> field -> prim
  | prim_array_access : typ -> prim
  | prim_struct_get : typ -> field -> prim
  | prim_array_get : typ -> prim
  | prim_ll_get : typ -> prim
  | prim_ll_set : typ -> prim
  | prim_ll_new : typ -> prim
  | prim_ll_access : typ -> prim.

(** Terms. *)

Inductive trm : Type :=
  | trm_var : var -> trm
  | trm_val : val -> trm
  | trm_if : trm -> trm -> trm -> trm
  | trm_let : bind -> trm -> trm -> trm
  | trm_app : prim -> list trm -> trm
  | trm_while : trm -> trm -> trm
  | trm_for : var -> val -> val -> trm -> trm.

(** Sequence is a special case of let bindings *)

Notation trm_seq := (trm_let bind_anon).

(* ---------------------------------------------------------------------- *)
(** State and stack *)

(** Representation of the state *)

Definition state := map loc val.
Definition empty_state : state := empty.

(** Representation of the stack *)

Definition stack := Ctx.ctx val.
Definition empty_stack : stack := nil.

(* ---------------------------------------------------------------------- *)
(** Inhabited words, values, types and terms *)

Global Instance Inhab_word : Inhab word.
Proof using. apply (Inhab_of_val word_undef). Qed.

Global Instance Inhab_val : Inhab val.
Proof using. apply (Inhab_of_val val_unit). Qed.

Global Instance Inhab_trm : Inhab trm.
Proof using. apply (Inhab_of_val (trm_val val_unit)). Qed.

Global Instance Inhab_typ : Inhab typ.
Proof using. apply (Inhab_of_val typ_unit). Qed.

Hint Extern 1 (Inhab word) => apply Inhab_word.

Hint Extern 1 (Inhab val) => apply Inhab_val.

Hint Extern 1 (Inhab trm) => apply Inhab_trm.

Hint Extern 1 (Inhab typ) => apply Inhab_typ.

(* ---------------------------------------------------------------------- *)
(** Coercions *)

Coercion prim_binop : binop >-> prim.
Coercion trm_val : val >-> trm.
Coercion trm_var : var >-> trm.
Coercion trm_app : prim >-> Funclass.

(* ---------------------------------------------------------------------- *)
(** Implicit types *)

Implicit Types t : trm.
Implicit Types v : val.
Implicit Types l : loc.
Implicit Types b : bool.
Implicit Types x : var.
Implicit Types z : bind.
Implicit Types vs : list val.
Implicit Types ts : list trm.

(* ---------------------------------------------------------------------- *)
(** Auxiliary predicates for the semantics and transformations *)

(** Predicates for values *)

Definition is_basic (v:val) :=
  match v with
  | val_error => True
  | val_unit => True
  | val_uninitialized => True
  | val_bool _ => True
  | val_int _ => True
  | val_double _ => True
  | val_abstract_ptr _ _ => True
  | val_concrete_ptr _ _ => True
  | _ => False
  end.

Definition is_error (v:val) :=
  match v with
  | val_error => True
  | _ => False
  end.

Definition is_bool (v:val) :=
  match v with
  | val_bool _ => True
  | _ => False
  end.

Definition is_ptr (v:val) :=
  match v with
  | val_abstract_ptr _ _ => True
  | _ => False
  end.

Definition is_int (v:val) :=
  match v with
  | val_int _ => True
  | _ => False
  end.

Definition is_struct (v:val) :=
  match v with
  | val_struct _ _ => True
  | _ => False
  end.

Definition is_array (v:val) :=
  match v with
  | val_array _ _ => True
  | _ => False
  end.

(** Predicates on primitive functions. *)

Definition is_struct_op (op:prim) :=
  match op with
  | prim_struct_access _ _ => True
  | prim_struct_get _ _ => True
  | _ => False
  end.

Definition is_array_op (op:prim) :=
  match op with
  | prim_array_access _ => True
  | prim_array_get _ => True
  | _ => False
  end.

(** Predicates on terms. *)

Definition is_val (t:trm) :=
  match t with
  | trm_val _ => True
  | _ => False
  end.

(** Special predicate: Checking if a value can be get from memory, i.e.
    checking if it contains any [val_uninitialized] somewhere. *)

Inductive is_uninitialized : val -> Prop :=
  | is_uninitialized_val_uninitialized :
      is_uninitialized val_uninitialized
  | is_uninitialized_array : forall T a,
      (exists i, index a i /\ is_uninitialized a[i]) ->
      is_uninitialized (val_array T a)
  | is_uninitialized_struct : forall T s,
      (exists f, f \indom s /\ is_uninitialized s[f]) ->
      is_uninitialized (val_struct T s).

(** Same as above but for the low-level equivalent of undefined,
    which is called [word_undef]. *)

Definition is_undef (v:val) :=
  match v with
  | val_words ws => exists i, index ws i /\ ws[i] = word_undef
  | _ => False
  end.


Require Import LiveVerif.LiveVerifLib.
Require Import coqutil.Tactics.syntactic_unify.
Require Import Lia.

Load LiveVerif.

(* TODO support functions that don't access any memory *)
Definition dummy: mem -> Prop := emp True.

Record node := {
  data: word;
  next: word;
}.
Definition node_t(r: node): word -> mem -> Prop := .**/
typedef struct __attribute__ ((__packed__)) {
  uintptr_t data;
  uintptr_t next;
} node_t;
/**.

#[export] Instance spec_of_malloc: fnspec :=                         .**/
uintptr_t malloc(uintptr_t size)                                     /**#
  ghost_args := (R: mem -> Prop);
  requires t m := sep dummy R m;
  ensures t' m' retPtr := t' = t /\ exists anyData,
       <{ * dummy
          * array uintptr \[size] anyData retPtr
          * R }> m'                                                   #**/ /**.
Parameter malloc : function_with_callees.
Parameter malloc_ok : program_logic_goal_for "malloc" malloc.

#[export] Instance spec_of_malloc_node: fnspec :=                    .**/
uintptr_t malloc_node(uintptr_t anything)                                 /**#
  ghost_args := (R: mem -> Prop);
  requires t m := sep dummy R m;
  (* ensures t' m' retPtr := t' = t /\
                          <{ * ex1 (fun x => node x retPtr)
                             * R }> m                               #**/ /**. *)
  ensures t' m' retPtr := t' = t /\ exists x,
                          <{ * dummy
                             * node_t x retPtr
                             * R }> m'                               #**/ /**.
Derive malloc_node SuchThat (fun_correct! malloc_node) As malloc_node_ok. .**/
{ /**. .**/
  uintptr_t r = malloc(2);   /**.
  assert (len anyData = 2) as Hlen by hwlia.

  destruct anyData; [discriminate Hlen | idtac].
  destruct anyData; [discriminate Hlen | idtac].
  destruct anyData; [idtac | simpl in Hlen; lia].

  .**/ return r; /**.
.**/ } /**.

  unfold node_t.
  unfold sepapps.
  simpl.
  unfold sepapp.
  (* TODO: automated memory cast *)
  instantiate (1 := {| data := r0; next := r1 |}).
  unfold array.
  simpl.
  eapply iff1ToEq. cancel.
  unfold seps. unfold iff1. unfold emp. intuition.
Qed.

Fixpoint sll (L : list word) (p : word): mem -> Prop :=
  match L with
  | nil => emp (p = /[0])
  | x::L' => ex1 (fun (q:word) =>
      <{ * uintptr x p
         * uintptr q (p ^+ /[4])
         * sll L' q }>)
  end.

Lemma purify_sll:
  forall L p,
    purify (sll L p) (True).
Proof.
  unfold purify. auto.
Qed.
Hint Resolve purify_sll : purify.

#[export] Instance spec_of_sll_prepend: fnspec := .**/

uintptr_t sll_prepend(uintptr_t p, uintptr_t val) /**#
  ghost_args := (L : list word) (R: mem -> Prop);
  requires t m := <{ * dummy
                     * sll L p
                     * R }> m;
  ensures t' m' res := t' = t /\
       <{ * dummy
          * sll (val::L) res
          * R }> m' #**/ /**.
Derive sll_prepend SuchThat (fun_correct! sll_prepend) As sll_prepend_ok. .**/
{ /**.
  (* TODO: a lot of dummys *)
  (* TODO: should support empty arguments *)
  .**/ uintptr_t r = malloc_node(-123); /**.
  (* set r.data = val *)
  .**/ store(r, val); /**.
  .**/ store(r+4, p); /**.
  .**/ return r; /**.
  (* TODO: all of this should probably be automated *)
  replace ((m4 \*/ (m2 \*/ m3)) \*/ m) with (m \*/ m2 \*/ m3 \*/ m4) in D by admit.
  assert (exists (mm2:mem), m \*/ m2 = mm2) as Hex by admit.
  destruct Hex as [mm2 Hex]. rewrite Hex in D. clear Hex.
  assert (mm2 |= sll (val :: L) r) by admit.
.**/ } /**.
Abort.

End LiveVerif. Comments .**/ //.


Require Import Cosa.Lib.Header.
Require compcert.common.Memdata.
Require Import Cosa.Interaction.Interaction.
Require Import Cosa.Interaction.InteractionLib.
Require Import Cosa.Abstract.Lang.
Require Import Cosa.Abstract.Valuation.
Require Import Cosa.Shape.Graph.
Require Import Cosa.Shape.Summary.
Import List.ListNotations.
Import Coq.Classes.EquivDec.

(** In this file we define the concrete instances of inductive shapes
    we are interested in. *)

Section Schemata.

  Context {name:Type} (γ_name:name -> node -> ℘ Graph.conc).
  Hypothesis valuation_not_fixed_summary : forall α sm f,
    central (belongs_to_summary α sm)
            (fun ν => (ν,f) ∈ γ_name sm α).

  (** In this section we define generic combinators to build inductive
      summaries. *)

  (** [fnf n] is the type of functions taking [n] argument nodes and
      returning a rule. *)
  Fixpoint fnf (n:nat) : Type :=
    match n with
    | 0 => rule name
    | S n => Graph.node -> fnf n
    end
  .

  (** [rule_with_new n] is the type of interaction structures
      requiring [n] new nodes and producing a rule. *)
  Fixpoint rule_with_new {n:nat} : fnf n -> Interaction (℘ node) (rule name) :=
    match n with
    | 0 => fun r => just r
    | S n => fun r => bind with_new (fun α => rule_with_new (r α))
    end
  .

  (** A correction property for [rule_with_new n]: the nodes allowed
      in the generated rule must only contain nodes in a given set and
      the [n] new nodes. *)
  Fixpoint rule_correct {n:nat} : fnf n -> ℘ node -> Prop :=
    match n with
    | 0 => fun r P => sub (Γ:=[node]) (belongs_to_graph (fst r)) P /\
                      sub (Γ:=[node]) (belongs_to_expr (snd r)) P
    | S n => fun r P => forall α, rule_correct (r α) (P ∪ singleton α)
    end
  .

  (* arnaud: déplacer dans extra? *)
  Lemma exists_sigTr (A:Type) (F:A->Type) (P:forall x:A, F x -> Prop) :
    (exists u:{x:A & F x}, (P (projT1 u) (projT2 u))) <->
    (exists (x:A) (y:F x), P x y).
  Proof.
    split.
    - intros [ [ x y ] h ]; simpl in *.
      decompose_concl; eauto.
    - intros [ x [ y h ]].
      eexists (existT _ x y); simpl.
      easy.
  Qed.

  (* arnaud: déplacer dans extra? *)
  Lemma exists_sigT (A:Type) (F:A->Type) (P:{ x:A & F x} -> Prop) :
    (exists u, P u) <->
    (exists (x:A) (y:F x), P (existT _ x y)).
  Proof.
    split.
    - intros [ [ x y ] h ]; simpl in *.
      decompose_concl; eauto.
    - intros [ x [ y h ]].
      eexists (existT _ x y); simpl.
      easy.
  Qed.

  (* arnaud: déplacer dans extra? *)
  Lemma exists_sig (A:Type) (F:A->Prop) (P:{ x:A | F x} -> Prop) :
    (exists u, P u) <->
    (exists (x:A) (y:F x), P (exist _ x y)).
  Proof.
    split.
    - intros [ [ x y ] h ]; simpl in *.
      decompose_concl; eauto.
    - intros [ x [ y h ]].
      eexists (existT _ x y); simpl.
      easy.
  Qed.

  Lemma γ_unfolding_with_new (u:node->unfolding name) (P:℘ node) α :
    γ_unfolding_with γ_name P (fun α => (bind with_new (fun β => u β α))) α =
    Join (fun β => meet (Γ:=[_]) (fun _ => β ∉ P)
                                 (γ_unfolding_with γ_name (fun δ=>δ∈P\/δ=β) (u β) α)).
  Proof.
    double_sub; intros s.
    - unfold γ_unfolding_with; simpl.
      intros [ [ [ β hβ ] h₂ ] [ [ [] r] h₃ ]]; simpl in *.
      decompose_concl; eauto.
    - unfold γ_unfolding_with; simpl.
      intros [ β [ h₁ [ c [ r h₂ ]]]].
      rewrite ?exists_sigT,?exists_sig; simpl.
      eexists; split.
      { eauto. }
      exists (fun _ => c).
      rewrite ?exists_sigT,?exists_sig; simpl.
      decompose_concl; eauto.
      easy.
  Qed.

  (** The properties of [Summary.env] are verified by unfoldings of
      the form [rule_with_new n r] *)

  Obligation Tactic := idtac.
  Definition swap_set (α β :node) (P:℘ node) : ℘ node :=
    fun δ =>
      if      δ == α then P β
      else if δ == β then P α
           else           P δ
  .

  Program Fixpoint swap_com_rec {n:nat} : forall {r:fnf n} {P:℘ node} (α β:node), (rule_with_new r).(Com) P -> (rule_with_new r).(Com) (swap_set α β P) :=
    match n with
    | 0 => fun _ _ _ _ _ => tt
    | S n => fun r P α β c =>
               if proj1_sig (projT1 c) == α then
                 existT _ (exist _ β _) _
               else
                 _
    end.
  Next Obligation.
    intros * <-; simpl in *.
    intros r P α β [ [ δ hδ] c] <- ; simpl in *.
    unfold swap_set.
    rewrite if_eq_refl.
    destruct (β==δ) as [ <- | _ ]; assumption.
  Qed.
  Next Obligation.
    intros ? n <- r P α β [ [δ hδ] c ] <- ; simpl in *; intros _.

  Program Fixpoint swap_com {n:nat} : forall {r:fnf n} {P:℘ node} (α β:node), (rule_with_new r).(Com) P -> α ∉ P -> β ∉ P -> (rule_with_new r).(Com) P:=
    match n with
    | 0 => fun _ _ _ _ _ _ _ => tt
    | S n => fun r P α β c hα hβ =>
               if proj1_sig (projT1 c) == α then
                 existT _ (exist _ β hβ) _
               else
                 _
    end.
  Next Obligation.
    intros * <-; simpl in *.
    intros r P α β [ [ δ hδ ] c ] hα hβ e; simpl in *.
    Print sig.

  Lemma vnf_rule_with_new (n:nat) (r:fnf (S n)) (P:℘ node) (α:node) :
    α ∈ P ->
    (rule_correct (r α) P) ->
    forall f,
      central P
              (fun ν => (ν,f) ∈ γ_unfolding_with γ_name P (fun α => rule_with_new (r α)) α).
  Proof.
    revert r P α.
    induction n as [ | n hn ]; intros r P α.
    - admit.
    - intros h₁ h₂ f; simpl in h₂.
      intros β δ hβ hδ ν h₃; unfold γ_unfolding_with in h₃ |- *; simpl in h₃ |- *.
      destruct h₃ as [ [ [ γ hγ] c] h₃ ]; simpl in c,h₃.
      destruct h₃ as [ [ [] r'] h₃ ]; simpl in h₃.
      rewrite ?exists_sigT,?exists_sig; simpl.
      destruct (β==γ) as [ <- | nβγ ].
      + destruct (β==δ) as [ -> | nβδ ].
        * assert (swap δ δ ν = ν) as e; [|rewrite e;clear e].
          { extensionality x.
            apply swap_self_id. }
          exists δ; exists hδ; exists c.
          rewrite ?exists_sigT,?exists_sig; simpl.
          decompose_concl; eauto.
        *
  Admitted.

End Schemata.

(** spiwack: There are few inductive at the time, until we are able to generate them. *)

Inductive name :=
| List
| ListSegment (β:Graph.node)
.

Local Notation "α ≡ β" := (Lang.Abinop (Cminor.Ocmpu Integers.Ceq) α β) (at level 70).
Local Notation "α ≠ β" := (Lang.Aunop Cminor.Onegint (α≡β)) (at level 70).
Local Notation "0" := (Lang.Aconst (Cminor.Ointconst Int.zero)).
Local Notation "1" := (Lang.Aconst (Cminor.Ointconst Int.one)).

Definition add_chunk (offs:int) (chunk:AST.memory_chunk) : int :=
  Int.add offs (Int.repr (Memdata.size_chunk chunk))
.

Definition def (i:name) (α:node) : Interaction (℘ node) (Summary.rule name) :=
  match i with
  | List =>
    Interaction.pi (Finite.access [
        just (Graph.NodeTree.empty _, (Avar α) ≡ 0) (** empty list *);
        bind with_new (fun β => (** head *)
        bind with_new (fun δ => (** tail *)
            just (NodeTree.set α (Point_to
                    [(Int.zero,{|destination:=(β,Int.zero);size:=AST.Mint32|});
                     (add_chunk (Int.zero) AST.Mint32,{|destination:=(δ,Int.zero);size:=AST.Mint32|})]
                   )
                  (NodeTree.set δ (Summarized List)
                  (NodeTree.empty _)) ,
                  (Avar α) ≠ 0)))
      ])
  | ListSegment β =>
    Interaction.pi (Finite.access [
        just (Graph.NodeTree.empty _, (Avar α) ≡ (Avar β)) (** empty segment *);
        bind with_new (fun γ => (** head *)
        bind with_new (fun δ => (** tail *)
            just (NodeTree.set α (Point_to
                    [(Int.zero,{|destination:=(γ,Int.zero);size:=AST.Mint32|});
                     (add_chunk (Int.zero) AST.Mint32,{|destination:=(δ,Int.zero);size:=AST.Mint32|})]
                   )
                  (NodeTree.set δ (Summarized (ListSegment β))
                  (NodeTree.empty _)) ,
                  (Avar α) ≠ 0)))
      ])
  end
.

(** Segments can be unfolded from the back node. *)
Definition list_segment_backward_unfolding (β α:node) :
   Interaction (℘ node) (Summary.rule name) :=
  Interaction.pi (Finite.access [
      just ( (** backward unfolding can yield identity. *)
        NodeTree.set α (Summarized (ListSegment β))
       (NodeTree.empty _),1 );

      bind with_new (fun γ => (** value *)
      bind with_new (fun δ => (** new end point *)
        just (NodeTree.set α (Summarized (ListSegment δ))
             (NodeTree.set δ (Point_to
                  [(Int.zero,{|destination:=(γ,Int.zero);size:=AST.Mint32|});
                     (add_chunk (Int.zero) AST.Mint32,{|destination:=(β,Int.zero);size:=AST.Mint32|})]
                   )
             (NodeTree.empty _)) ,
             (Avar δ) ≠ 0)))
      ])
.

Definition d : Summary.def :=
  existT _ name def
.

Inductive fb := Forward | Backward.

Definition list_unfoldings (i:name) : { U:Type & U -> unfolding name }:=
  match i with
  | List => existT _ (unit:Type) (fun _ => def List)
  | ListSegment β => existT (fun U => U -> unfolding name) (fb:Type)
                                 (fun d => match d with
                                           | Forward => def (ListSegment β)
                                           | Backward => list_segment_backward_unfolding β
                                           end)
  end
.

(* arnaud: WIP *)
Program Definition env : Summary.env := {|
  defs := d ;
  unfoldings := list_unfoldings
|}.
Next Obligation. (** [defs_local] *)
  unfold valuation_not_fixed_def, Valuation.central.
  (** Reformulate the goal into a form where [lfp_ind] can be applied *)
  cut (sub (Γ:=[names_of d;node;conc])
             (γ d)
             (fun i α s =>
                forall β δ,
                  ~ belongs_to_summary α i β ->
                  ~ belongs_to_summary α i δ ->
                  γ d i α (Valuation.swap β δ (fst s), (snd s)))).
  { simpl; intros h; intros i α f β δ h₁ h₂ ν.
    specialize (h i α (ν,f)); eauto. }
  (** by induction *)
  apply lfp_ind.
  { typeclasses eauto. }
  simpl; intros R h₁ h₂ i α [ν f] h₃ β δ hβ hδ; simpl.
  change (lfp (F_γ d)) with (γ d) in h₁.
  destruct i as [|γ].
  - (** [List] *)
    unfold F_γ,γ_unfolding in h₃.
    rewrite <- γ_fixed_point.
    unfold F_γ,γ_unfolding.
    destruct h₃ as [ P [ εs [ r h₃]]]. exists P.
    destruct h₃ as [ h₃₁ h₃₂ ].
    destruct r as [ [ [[]|] | ] r_plus ].
    * (** ν is of the form cons *)
      simpl in * |-.
      destruct r_plus as [ [] [ [] [] ]].
      destruct (εs (Some None)) as [ [ε hε] ζ₀ ]; simpl in * |-; clear εs.
      destruct (ζ₀ tt) as [ [ζ hζ] id_unit ]; simpl in * |-; clear ζ₀.

    * (** ν is of the form nil *)
  - (** [ListSegment β] *)


Require Import VST.concurrency.conclib.
Require Import VST.floyd.proofauto.
Require Import VST.atomics.general_locks.
Require Import Coq.Sets.Ensembles.
Require Import bst.puretree.
Require Import bst.bst_template_coupling.
Require Import bst.coupling_lib.
Require Import bst.coupling_traverse.
Require Import VST.floyd.library.
Import FashNotation.

(* Specification of lookup function *)
Program Definition lookup_spec :=
  DECLARE _lookup
  ATOMIC TYPE (rmaps.ConstType (val * share * lock_handle * Z * globals * gname * gname))
         OBJ M INVS ∅
  WITH b, sh, lock, x, gv, g, g_root
  PRE [tptr (tptr t_struct_tree_t), tint]
    PROP (writable_share sh;
    and (Z.le Int.min_signed x)(Z.le x Int.max_signed))
    PARAMS (b; Vint (Int.repr x)) GLOBALS (gv)
    SEP  (mem_mgr gv; nodebox_rep g g_root sh lock b) |
  (tree_rep g g_root M)
  POST [tptr Tvoid]
    EX ret: val,
    PROP ()
    LOCAL (temp ret_temp ret)
    SEP (mem_mgr gv; nodebox_rep g g_root sh lock b) |
        (!! (ret = match M !! x with Some v => v | None => nullval end) && tree_rep g g_root M).

Definition Gprog : funspecs :=
    ltac:(with_library prog [acquire_spec; release_spec; makelock_spec;
     surely_malloc_spec; traverse_spec; findnext_spec; lookup_spec]).

(* Proving lookup function satisfies spec *)
Lemma body_lookup: semax_body Vprog Gprog f_lookup lookup_spec.
Proof.
  start_function.
  unfold nodebox_rep, ltree.
  Intros np.
  forward_call (t_struct_pn, gv).
  Intros nb.
  forward.
  forward.
  forward.
  forward.
  set (AS := atomic_shift _ _ _ _ _).
  (* acquire(pn->n->lock); *)
  forward_call acquire_inv_simple (sh, lock, node_lock_inv (Share.split gsh1).1 g np g_root lock).
  {
    set Q1:= fun (b : (bool * ( val * (val * (lock_handle * (share * (gname * node_info))))))%type) =>
              if b.1 then AS else AS.
    (* traverse(pn, x, nullval) *)
    (* we assign value to nullval*)
    forward_call (nb, np, sh, lock, x, nullval, gv, g, g_root, Q1).
    {
      unfold pn_rep_1, node_lock_inv'.
      Exists (default_val t_struct_pn).1.
      unfold node_lock_inv.
      sep_apply self_part_eq.
      assert (lsh2 <> Share.bot).
      { apply readable_not_bot. apply readable_lsh2. }
      auto.
      entailer !.
      rewrite -> 2sepcon_assoc. rewrite sepcon_comm.
      rewrite -> sepcon_assoc; apply sepcon_derives; [|cancel].
      unfold atomic_shift; iIntros "AU"; iAuIntro; unfold atomic_acc; simpl.
      iMod "AU" as (m) "[Hm HClose]".
      iModIntro.
      iExists m.
      iFrame "Hm".
      iSplit; iFrame.
      { by iApply bi.and_elim_l. }
      {
        iDestruct "HClose" as "[HClose _]".
        iIntros (pt) "[H _]".
        iMod ("HClose" with "H") as "H".
        iModIntro.
        unfold Q1.
        destruct (decide (pt.1 = true)). { rewrite e; iFrame. }
        { apply not_true_is_false in n; rewrite n; iFrame. }
      }
    }
    Intros pt.
    destruct pt as (fl & (p1 & (tp & (lock_in & (gsh & (g_in & r)))))).
    simpl in H1, H2.
    destruct fl.
    simpl.
    change emp with seplog.emp.
    - destruct H2.
      forward_if (
          PROP ( )
            LOCAL (temp _v nullval; temp _t'2 Vtrue; temp _t'8 (ptr_of lock);
                   temp _t'7 np; temp _t'9 np; temp _pn__2 nb; gvars gv; temp _t b; temp _x (vint x))
            SEP (Q1 (true, (p1, (tp, (lock_in, (gsh, (g_in, r)))))); mem_mgr gv; emp;
                 node_lock_inv_new gsh g p1 g_in lock_in tp r;
                 data_at Ews t_struct_pn (p1, p1) nb;
                 my_half g_root (Share.split gsh1).2 (Neg_Infinity, Pos_Infinity, None);
                 data_at sh (tptr t_struct_tree_t) np b;
                 field_at sh t_struct_tree_t (DOT _lock) (ptr_of lock) np;
                 lock_inv sh lock
                   (selflock (node_lock_inv_pred (Share.split gsh1).1 g np g_root (ptr_of lock))
                      gsh2 lock);
                 malloc_token Ews t_struct_pn nb)).
      + pose proof (Int.one_not_zero); easy.
      + Intros.
        forward.
        unfold node_lock_inv_new.
        entailer !.
      + rewrite H3.
        unfold node_lock_inv_new, tree_rep_R.
        rewrite -> if_true by auto.
        unfold Q1.
        simpl.
        Intros.
        gather_SEP AS (my_half g_in _ _) (in_tree g _).
        viewshift_SEP 0 (EX y, Q y * (!! (y = nullval) && (in_tree g g_in * my_half g_in gsh r))).
        {
          go_lower.
          apply sync_commit_same.
          intro t.
          unfold tree_rep at 1.
          Intros tg.
          sep_apply node_exist_in_tree; Intros.
          sep_apply (ghost_tree_rep_public_half_ramif _ _ (Neg_Infinity, Pos_Infinity) _ H9).
          Intros r0.
          eapply derives_trans; [|apply ghost_seplog.bupd_intro].
          Exists r0.
          unfold public_half'; cancel.
          apply imp_andp_adjoint.
          Intros.
          apply node_info_incl' in H11 as [].
          eapply derives_trans; [|apply ghost_seplog.bupd_intro].
          rewrite <- wand_sepcon_adjoint.
          eapply derives_trans; [|apply ghost_seplog.bupd_intro].
          simpl.
          simpl in H12.
          Exists nullval; simpl; entailer!.
          - destruct r as [range r2], r0 as [rg ?]; simpl in *; subst.
            rewrite -> range_info_not_in_gmap
              with (rn := rg)(r_root := (Neg_Infinity, Pos_Infinity)); auto.
            eapply key_in_range_incl; eauto.
          - unfold tree_rep. Exists tg. entailer!. iIntros "[[? H] ?]".
            iApply "H". iFrame.
        }
        Intros y.
        subst y.
        (*  (_release2(_t'4); *)
        change emp with seplog.emp.
        forward.
        forward.
        forward_call release_self (gsh2, lock_in,
                    node_lock_inv_pred gsh g p1 g_in (ptr_of lock_in)).
        {
          unfold node_lock_inv_pred at 3, sync_inv.
          Exists r.
          rewrite node_rep_def.
          unfold node_lock_inv, tree_rep_R.
          Exists nullval.
          rewrite -> if_true by auto.
          entailer !.
        }
        forward_call (t_struct_pn, nb, gv).
        { assert_PROP (nb <> nullval) by entailer !. rewrite if_false; auto. cancel. }
        forward.
        unfold nodebox_rep, ltree.
        Exists nullval np.
        entailer !.
    - (* v = pn->p->t->value; *)
      unfold Q1.
      destruct H2 as ( ?  & v2 & g21 & g22 & ?).
      simpl.
      forward_if (
            PROP ( )
                 LOCAL (temp _v v2; temp _t'2 Vfalse; temp _t'8 (ptr_of lock); temp _t'7 np;
                        temp _t'9 np; temp _pn__2 nb; gvars gv; temp _t b; temp _x (vint x))
                 SEP (Q1 (false, (p1, (tp, (lock_in, (gsh, (g_in, r))))));
                    mem_mgr gv; seplog.emp;
                    field_at Ews t_struct_tree_t (DOT _t) tp p1 *
                      malloc_token Ews t_struct_tree_t p1 * in_tree g g_in *
                      (EX (ga gb : gname) (x1 : Z) (v0 pa pb : val) (locka lockb : lock_handle),
                        !! (r.2 = Some (Some (x1, v0, ga, gb))
                            ∧ (Int.min_signed ≤ x1 ≤ Int.max_signed)%Z
                            ∧ is_pointer_or_null pa
                            ∧ is_pointer_or_null pb ∧ tc_val (tptr Tvoid) v0 ∧
                              key_in_range x1 r.1 = true) &&
                          data_at Ews t_struct_tree (vint x1, (v0, (pa, pb))) tp *
                          malloc_token Ews t_struct_tree tp *
                          |> ltree g ga lsh1 gsh1 gsh1 pa locka *
                          |> ltree g gb lsh1 gsh1 gsh1 pb lockb) *
                      my_half g_in gsh r *
                      field_at lsh2 t_struct_tree_t (DOT _lock) (ptr_of lock_in) p1 *
                      |> lock_inv gsh2 lock_in (node_lock_inv gsh g p1 g_in lock_in);
                    data_at Ews t_struct_pn (p1, p1) nb;
                    my_half g_root (Share.split gsh1).2 (Neg_Infinity, Pos_Infinity, None);
                    data_at sh (tptr t_struct_tree_t) np b;
                    field_at sh t_struct_tree_t (DOT _lock) (ptr_of lock) np;
                    lock_inv sh lock (node_lock_inv (Share.split gsh1).1 g np g_root lock);
                    malloc_token Ews t_struct_pn nb)); unfold node_lock_inv_new, tree_rep_R.
      + rewrite -> if_false; auto.
        Intros g1 g2 x1 v p1' p2' l1 l2.
        change emp with seplog.emp.
        forward.
        forward.
        forward.
        Exists g1 g2 x1 v p1' p2' l1 l2.
        unfold Q1.
        entailer !. auto.
      + pose proof Int.one_not_zero; contradiction.
      + Intros g1 g2 x1 v p1' p2' l1 l2.
        change emp with seplog.emp.
        forward.
        forward.
        simpl in H1, H3, H4, H5, H6, H7.
        rewrite H4 in H3.
        injection H3.
        intros. subst x1. subst v2. subst g21. subst g22.
        unfold Q1.
        simpl.
        gather_SEP AS (my_half g_in _ _) (in_tree g _).
        viewshift_SEP 0 ( EX y, Q y * (!!(y = v) && (in_tree g g_in * my_half g_in gsh r))).
        {
          go_lower.
          apply sync_commit_same.
          intro t.
          unfold tree_rep at 1.
          Intros tg.
          sep_apply node_exist_in_tree; Intros.
          sep_apply (ghost_tree_rep_public_half_ramif _ _ (Neg_Infinity, Pos_Infinity) _ H14).
          Intros r0.
          eapply derives_trans; [|apply ghost_seplog.bupd_intro].
          Exists r0.
          unfold public_half'; cancel.
          apply imp_andp_adjoint.
          Intros.
          apply node_info_incl' in H16 as [].
          eapply derives_trans; [|apply ghost_seplog.bupd_intro].
          rewrite <- wand_sepcon_adjoint.
          eapply derives_trans; [|apply ghost_seplog.bupd_intro].
          Exists v; entailer!.
          simpl. entailer !.
          - destruct r as [range r2], r0 as [range0 r0]. simpl in *; subst.
            erewrite range_info_in_gmap; eauto.
          - iIntros "[[[? H] ?] ?]".
            unfold tree_rep. iExists tg. iFrame; iSplit; auto.
            iApply "H"; iFrame.
        }
        Intros y.
        subst y.
        Intros.
        forward_call release_self (gsh2, lock_in,
                    node_lock_inv_pred gsh g p1 g_in (ptr_of lock_in)).
        {
          unfold node_lock_inv, node_lock_inv_pred at 4, sync_inv.
          Exists r.
          rewrite node_rep_def.
          Exists tp.
          unfold tree_rep_R, ltree.
          rewrite -> if_false by auto.
          Exists g1 g2 x v p1' p2' l1 l2.
          entailer !.
          rewrite <- later_sepcon;
            eapply derives_trans;
            [|apply sepcon_derives, derives_refl; apply now_later].
          cancel.
        }
        forward_call (t_struct_pn, nb, gv).
        { assert_PROP (nb <> nullval) by entailer !. rewrite if_false; auto. cancel. }
        forward.
        unfold nodebox_rep, ltree.
        Exists v np.
        entailer !.
  }
Qed.


Require Import List.
Import ListNotations.

Require Export Meta.
Require Export Shared.

(*
======
Types
======
*)

Inductive ty : Type :=
  | TClass : class_id -> ty
  | TInterface : interface_id -> ty
  | TUnit : ty.

(*
============
Expressions
============
*)

Inductive val : Type :=
  | VNull : val
  | VLoc  : loc -> val.

Inductive var : Type :=
  | SV : svar -> var
  | DV : dvar -> var.

Inductive expr : Type :=
  | EVal : val -> expr
  | EVar : var -> expr
  | ENew : class_id -> expr
  | ECall : var -> method_id -> expr -> expr
  | ESelect : var -> field_id -> expr
  | EUpdate : var -> field_id -> expr -> expr
  | ELet : svar -> expr -> expr -> expr
  | ECast : ty -> expr -> expr
  | EPar : expr -> expr -> expr -> expr
  | ELock : var -> expr -> expr
  | ELocked : lock -> expr -> expr
  | EAssert : var -> var -> expr
.

Tactic Notation "expr_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "EVal"
  | Case_aux c "EVar"
  | Case_aux c "ENew"
  | Case_aux c "ECall"
  | Case_aux c "ESelect"
  | Case_aux c "EUpdate"
  | Case_aux c "ELet"
  | Case_aux c "ECast"
  | Case_aux c "EPar"
  | Case_aux c "ELock"
  | Case_aux c "ELocked"
  | Case_aux c "EAssert"
].

Definition econtext := expr -> expr.

Definition ctx_call (x : _) (m : _) : econtext := (fun e => ECall x m e).
Hint Unfold ctx_call.
Definition ctx_update (x : _) (f : _) : econtext := (fun e => EUpdate x f e).
Hint Unfold ctx_update.
Definition ctx_let (x : _) (body : _) : econtext := (fun e => ELet x e body).
Hint Unfold ctx_let.
Definition ctx_cast (t : _) : econtext := (fun e => ECast t e).
Hint Unfold ctx_cast.
Definition ctx_locked (L : _) : econtext := (fun e => ELocked L e).
Hint Unfold ctx_locked.

Inductive is_econtext : econtext -> Prop :=
  | EC_Call :
      forall x m,
        is_econtext (ctx_call x m)
  | EC_Update :
      forall x f,
        is_econtext (ctx_update x f)
  | EC_Let :
      forall x body,
        is_econtext (ctx_let x body)
  | EC_Cast :
      forall t,
        is_econtext (ctx_cast t)
  | EC_Locked :
      forall L,
        is_econtext (ctx_locked L).

Definition isVal (e : expr) : Prop :=
  match e with
    | EVal _ => True
    | _ => False
  end.

Inductive exprStatic : expr -> Prop :=
  | StaticVar : forall x, exprStatic (EVar (SV x))
  | StaticNull : exprStatic (EVal VNull)
  | StaticNew : forall c, exprStatic (ENew c)
  | StaticCall : forall x m arg, exprStatic arg -> exprStatic (ECall (SV x) m arg)
  | StaticSelect : forall x f, exprStatic (ESelect (SV x) f)
  | StaticUpdate : forall x f e, exprStatic e -> exprStatic (EUpdate (SV x) f e)
  | StaticLet : forall x e body, exprStatic e -> exprStatic body -> exprStatic (ELet x e body)
  | StaticPar : forall e1 e2 e3, exprStatic e1 -> exprStatic e2 -> exprStatic e3 -> exprStatic (EPar e1 e2 e3)
  | StaticCast : forall t e, exprStatic e -> exprStatic (ECast t e)
  | StaticLock : forall x e, exprStatic e -> exprStatic (ELock (SV x) e)
  | StaticAssert : forall x y, exprStatic (EAssert (SV x) (SV y))
.

Fixpoint freeVars (e : expr) : list svar :=
  match e with
    | EVar (SV x) => [x]
    | ECall (SV x) _ arg => x :: (freeVars arg)
    | ECall (DV _) _ arg => (freeVars arg)
    | ESelect (SV x) _ => [x]
    | EUpdate (SV x) _ rhs => x :: (freeVars rhs)
    | EUpdate (DV _) _ rhs => freeVars rhs
    | ELet x e body =>
      (freeVars e) ++
      (List.remove id_eq_dec x (freeVars body))
    | EPar e1 e2 e3 => (freeVars e1) ++ (freeVars e2) ++ (freeVars e3)
    | ECast t e => freeVars e
    | ELock (SV x) e => x :: (freeVars e)
    | ELock (DV _) e => freeVars e
    | ELocked _ e => freeVars e
    | EAssert (SV x) (SV y) => [x; y]
    | EAssert (DV _) (SV y) => [y]
    | EAssert (SV x) (DV _) => [x]
    | EAssert (DV _) (DV _) => []
    | _ => nil
  end.

Definition subst_var (x : svar) (y : dvar) (z : var) : var :=
  match z with
    | (SV z) => if id_eq_dec x z then DV y else SV z
    | (DV z) => (DV z)
  end.

Hint Unfold subst_var.

Fixpoint subst (x : svar) (y : dvar) (e : expr) : expr :=
  match e with
    | EVar z => EVar (subst_var x y z)
    | ELet z e' body =>
        ELet z (subst x y e')
             (if id_eq_dec x z then
                body
              else
                (subst x y body))
    | ECall z m arg =>
        ECall (subst_var x y z)
              m (subst x y arg)
    | ESelect z f => ESelect (subst_var x y z) f
    | EUpdate z f rhs =>
        EUpdate (subst_var x y z)
                f (subst x y rhs)
    | EPar e1 e2 e3 =>
        EPar (subst x y e1)
             (subst x y e2)
             (subst x y e3)
    | ECast t e =>
        ECast t (subst x y e)
    | ELock z e =>
        ELock (subst_var x y z) (subst x y e)
    | ELocked L e =>
        ELocked L (subst x y e)
    | EAssert z1 z2 =>
        EAssert (subst_var x y z1) (subst_var x y z2)
    | _ => e
  end.

Fixpoint locks (e : expr) : list lock :=
  match e with
    | ECall _ _ arg => locks arg
    | EUpdate _ _ rhs => locks rhs
    | ELet _ e body => locks e ++ locks body
    | ECast _ e => locks e
    | EPar e1 e2 e3 => locks e1 ++ locks e2 ++ locks e3
    | ELock _ e => locks e
    | ELocked L e => L :: locks e
    | _ => nil
  end.

Definition no_locks (e : expr) : Prop :=
  locks e = nil.

(*
==============
Configuration
==============
*)

(*
------
Stack
------
*)

Definition dvar_map := partial_map dvar val.

(*
------
Locks
------
*)

Inductive lock_status : Type :=
  | LLocked : lock_status
  | LUnlocked : lock_status.

(*
-----
Heap
-----
*)

Definition dyn_fields := partial_map field_id val.

Definition object := (class_id * dyn_fields * lock_status)%type.

Definition heap := list object.

Definition heapExtend (H : heap) (obj : object) := snoc H obj.

Definition heapLookup (H : heap) (l : loc) :=
  nth_error H l.

Fixpoint heapUpdate (H : heap) (l : loc) (obj : object) :=
  match H with
  | nil => nil
  | obj' :: H' =>
    match l with
    | O    => obj :: H'
    | S l' => obj' :: (heapUpdate H' l' obj)
    end
  end.

(*
--------
Threads
--------
*)

Inductive threads :=
  | T_EXN    : list lock -> threads
  | T_Thread : list lock -> expr -> threads
  | T_Async  : threads -> threads -> expr -> threads.

Definition threads_done (thr : threads) :=
  match thr with
    | T_Thread _ (EVal _) => True
    | _ => False
  end.

Definition threads_exn (thr : threads) :=
  match thr with
    | T_EXN _ => True
    | _ => False
  end.

Fixpoint heldLocks (T : threads) :=
  match T with
    | T_EXN Ls => Ls
    | T_Thread Ls _ => Ls
    | T_Async T1 T2 _ => heldLocks T1 ++ heldLocks T2
  end.

Fixpoint leftmost_locks (T : threads) : list lock :=
  match T with
    | T_EXN Ls => Ls
    | T_Thread Ls _ => Ls
    | T_Async T1 _ _ => leftmost_locks T1
  end.

Fixpoint t_locks (T : threads) :=
  match T with
    | T_EXN _ => nil
    | T_Thread _ e => locks e
    | T_Async T1 T2 e => t_locks T1 ++ t_locks T2 ++ locks e
  end.

(*
--------------
Configuration
--------------
*)

Definition configuration := (heap * dvar_map * nat * threads)%type.

Definition cfg_done (cfg : configuration) : Prop :=
  match cfg with
    | (_, _, _, thr) => threads_done thr
  end.

Definition cfg_exn (cfg : configuration) : Prop :=
  match cfg with
    | (_, _, _, thr) => threads_exn thr
  end.

(*
========
Program
========
*)

Inductive fieldDecl : Type :=
  | Field : field_id -> ty -> fieldDecl.

Inductive methodDecl : Type :=
  | Method : method_id -> (svar * ty) -> ty -> expr -> methodDecl.

Inductive classDecl : Type :=
  | Cls : class_id -> interface_id -> list fieldDecl -> list methodDecl -> classDecl.

Inductive methodSig : Type :=
  | MethodSig : method_id -> (svar * ty) -> ty -> methodSig.

Inductive interfaceDecl : Type :=
  | Interface : interface_id -> list methodSig -> interfaceDecl
  | ExtInterface : interface_id -> interface_id -> interface_id -> interfaceDecl.

Definition program := (list classDecl * list interfaceDecl * expr)%type.

Definition classLookup(P : program)(c : class_id) : option classDecl :=
  match P with
    | (cs, _, _) =>
      let c_eq c cls := match cls with
                          | Cls c' _ _ _ => beq_nat c c'
                        end
      in
      find (c_eq c) cs
  end.

Definition interfaceLookup(P : program)(i : interface_id) : option interfaceDecl :=
  match P with
    | (_, ids, _) =>
      let i_eq i intr := match intr with
                          | Interface i' _ => beq_nat i i'
                          | ExtInterface i' _ _ => beq_nat i i'
                        end
      in
      find (i_eq i) ids
  end.

Definition fieldLookup(fs : list fieldDecl)(f : field_id) :=
  let f_eq f fld := match fld with
                     | Field f' _ => beq_nat f f'
                    end
  in
  find (f_eq f) fs.

Definition fields(P : program)(t : ty) :=
  match t with
    | TClass c => match classLookup P c with
                    | Some (Cls _ _ fs _) => Some fs
                    | None => None
                  end
    | _ => None
  end.

Definition methodLookup(ms : list methodDecl)(m : method_id) :=
  let m_eq m mtd := match mtd with
                      | Method m' _ _ _ => beq_nat m m'
                    end
  in
  find (m_eq m) ms.

Definition methods(P : program)(t : ty) :=
  match t with
    | TClass c => match classLookup P c with
                    | Some (Cls _ _ _ ms) => Some ms
                    | None => None
                  end
    | _ => None
  end.

Definition methodSigLookup(ms : list methodSig)(m : method_id) :=
  let m_eq m mtd := match mtd with
                      | MethodSig m' _ _ => beq_nat m m'
                    end
  in
  find (m_eq m) ms.

Definition extractSigs(ms : list methodDecl) :=
  let extract := fun mtd => match mtd with
                              | Method m param t e => MethodSig m param t
                            end
  in
  map extract ms.

Inductive methodSigs(P : program) : ty -> list methodSig -> Prop :=
  | MSigs_Class :
      forall c i fs ms,
        classLookup P c = Some (Cls c i fs ms) ->
        methodSigs P (TClass c) (extractSigs ms)
  | MSigs_Interface :
      forall i msigs,
        interfaceLookup P i = Some (Interface i msigs) ->
        methodSigs P (TInterface i) msigs
  | MSigs_ExtInterface :
      forall i i1 i2 msigs1 msigs2,
        interfaceLookup P i = Some (ExtInterface i i1 i2) ->
        methodSigs P (TInterface i1) msigs1 ->
        methodSigs P (TInterface i2) msigs2 ->
        methodSigs P (TInterface i) (msigs1 ++ msigs2)
  | MSigs_Unit :
      methodSigs P TUnit [].

Fixpoint declsToFields (l : list fieldDecl) :=
  match l with
    | nil => empty
    | fd :: fs =>
      match fd with
        | Field f _ =>
          extend (declsToFields fs) f VNull
      end
  end.