(** Infrastructure lemmas and tactic definitions for Fsub.

    Authors: Brian Aydemir and Arthur Charguéraud, with help from
    Aaron Bohannon, Jeffrey Vaughan, and Dimitrios Vytiniotis.

    This file contains a number of definitions, tactics, and lemmas
    that are based only on the syntax of the language at hand.  While
    the exact statements of everything here would change for a
    different language, the general structure of this file (i.e., the
    sequence of definitions, tactics, and lemmas) would remain the
    same.

    Table of contents:
      - #Free variables#
      - #Substitution#
      - #The "pick fresh" tactic#
      - #The "pick fresh and apply" tactic#
      - #Properties of opening and substitution#
      - #Local closure is preserved under substitution#
      - #Automation# *)

Require Export LinF_Definitions.

(* ********************************************************************** *)
(** * ## Free variables *)

(** In this section, we define free variable functions.  The functions
    [fv_tt] and [fv_te] calculate the set of atoms used as free type
    variables in a type or expression, respectively.  The function
    [fv_ee] calculates the set of atoms used as free expression
    variables in an expression.  Cases involving binders are
    straightforward since bound variables are indices, not names, in
    locally nameless representation. *)

Fixpoint fv_tt (T : typ) {struct T} : atoms :=
  match T with
  | typ_bvar J => {}
  | typ_fvar X => singleton X
  | typ_arrow K T1 T2 => (fv_tt T1) `union` (fv_tt T2)
  | typ_all K T2 => (fv_tt T2)
  end.

Fixpoint fv_te (e : exp) {struct e} : atoms :=
  match e with
  | exp_bvar i => {}
  | exp_fvar x => {}
  | exp_abs K V e1  => (fv_tt V) `union` (fv_te e1)
  | exp_app e1 e2 => (fv_te e1) `union` (fv_te e2)
  | exp_tabs K e1 => (fv_te e1)
  | exp_tapp e1 V => (fv_tt V) `union` (fv_te e1)
  end.

Fixpoint fv_ee (e : exp) {struct e} : atoms :=
  match e with
  | exp_bvar i => {}
  | exp_fvar x => singleton x
  | exp_abs K V e1 => (fv_ee e1)
  | exp_app e1 e2 => (fv_ee e1) `union` (fv_ee e2)
  | exp_tabs K e1 => (fv_ee e1)
  | exp_tapp e1 V => (fv_ee e1)
  end.

Fixpoint fv_lenv (D : lenv) {struct D} : atoms :=
  match D with
  | nil => {}
  | cons (x, lbind_typ T) l => fv_tt T `union` fv_lenv l
  end.

(* ********************************************************************** *)
(** * ## Substitution *)

(** In this section, we define substitution for expression and type
    variables appearing in types, expressions, and environments.
    Substitution differs from opening because opening replaces indices
    whereas substitution replaces free variables.  The definitions
    below are relatively simple for two reasons.
      - We are using locally nameless representation, where bound
        variables are represented using indices.  Thus, there is no
        need to rename variables to avoid capture.
      - The definitions below assume that the term being substituted
        in, i.e., the second argument to each function, is locally
        closed.  Thus, there is no need to shift indices when passing
        under a binder. *)

Fixpoint subst_tt (Z : atom) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | typ_bvar J => typ_bvar J
  | typ_fvar X => if X == Z then U else T
  | typ_arrow K T1 T2 => typ_arrow K (subst_tt Z U T1) (subst_tt Z U T2)
  | typ_all K T2 => typ_all K (subst_tt Z U T2)
  end.

Fixpoint subst_te (Z : atom) (U : typ) (e : exp) {struct e} : exp :=
  match e with
  | exp_bvar i => exp_bvar i
  | exp_fvar x => exp_fvar x
  | exp_abs K V e1 => exp_abs  K (subst_tt Z U V)  (subst_te Z U e1)
  | exp_app e1 e2 => exp_app  (subst_te Z U e1) (subst_te Z U e2)
  | exp_tabs K e1 => exp_tabs K  (subst_te Z U e1)
  | exp_tapp e1 V => exp_tapp (subst_te Z U e1) (subst_tt Z U V)
  end.

Fixpoint subst_ee (z : atom) (u : exp) (e : exp) {struct e} : exp :=
  match e with
  | exp_bvar i => exp_bvar i
  | exp_fvar x => if x == z then u else e
  | exp_abs K V e1 => exp_abs K V (subst_ee z u e1)
  | exp_app e1 e2 => exp_app (subst_ee z u e1) (subst_ee z u e2)
  | exp_tabs K e1 => exp_tabs K (subst_ee z u e1)
  | exp_tapp e1 V => exp_tapp (subst_ee z u e1) V
  end.

Definition subst_tb (Z : atom) (P : typ) (b : binding) : binding :=
  match b with
  | bind_kn K => bind_kn K
  | bind_typ T => bind_typ (subst_tt Z P T)
  end.

Definition subst_tlb (Z : atom) (P : typ) (b : lbinding) : lbinding :=
  match b with
  | lbind_typ T => lbind_typ (subst_tt Z P T)
  end.

(* ********************************************************************** *)
(** * ## The "[pick fresh]" tactic *)

(** The "[pick fresh]" tactic introduces a fresh atom into the context.
    We define it in two steps.

    The first step is to define an auxiliary tactic [gather_atoms],
    meant to be used in the definition of other tactics, which returns
    a set of atoms in the current context.  The definition of
    [gather_atoms] follows a pattern based on repeated calls to
    [gather_atoms_with].  The one argument to this tactic is a
    function that takes an object of some particular type and returns
    a set of atoms that appear in that argument.  It is not necessary
    to understand exactly how [gather_atoms_with] works.  If we add a
    new inductive datatype, say for kinds, to our language, then we
    would need to modify [gather_atoms].  On the other hand, if we
    merely add a new type, say products, then there is no need to
    modify [gather_atoms]; the required changes would be made in
    [fv_tt]. *)

Ltac gather_atoms :=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
  let C := gather_atoms_with (fun x : exp => fv_te x) in
  let D := gather_atoms_with (fun x : exp => fv_ee x) in
  let E := gather_atoms_with (fun x : typ => fv_tt x) in
  let F := gather_atoms_with (fun x : env => dom x) in
  let G := gather_atoms_with (fun x : lenv => dom x) in
  let H := gather_atoms_with (fun x : lenv => fv_lenv x) in
  constr:(A `union` B `union` C `union` D `union` E `union` F `union` G `union` H).

(** The second step in defining "[pick fresh]" is to define the tactic
    itself.  It is based on the [(pick fresh ... for ...)] tactic
    defined in the [Atom] library.  Here, we use [gather_atoms] to
    construct the set [L] rather than leaving it to the user to
    provide.  Thus, invoking [(pick fresh x)] introduces a new atom
    [x] into the current context that is fresh for "everything" in the
    context. *)

Tactic Notation "pick" "fresh" ident(x) :=
  let L := gather_atoms in (pick fresh x for L).

(* *********************************************************************** *)
(** * ## The "[pick fresh and apply]" tactic *)

(** This tactic is implementation specific only because of its
    reliance on [gather_atoms], which is itself implementation
    specific.  The definition below may be copied between developments
    without any changes, assuming that the other other developments
    define an appropriate [gather_atoms] tactic.  For documentation on
    the tactic on which the one below is based, see the
    [Metatheory] library. *)

Tactic Notation
      "pick" "fresh" ident(atom_name) "and" "apply" constr(lemma) :=
  let L := gather_atoms in
  pick fresh atom_name excluding L and apply lemma.

(* ********************************************************************** *)
(** * ## Properties of opening and substitution *)

(** The following lemmas provide useful structural properties of
    substitution and opening.  While the exact statements are language
    specific, we have found that similar properties are needed in a
    wide range of languages.

    Below, we indicate which lemmas depend on which other lemmas.
    Since [te] functions depend on their [tt] counterparts, a similar
    dependency can be found in the lemmas.

    The lemmas are split into three sections, one each for the [tt],
    [te], and [ee] functions.  The most important lemmas are the
    following:
      - Substitution and opening commute with each other, e.g.,
        [subst_tt_open_tt_var].
      - Opening a term is equivalent to opening the term with a fresh
        name and then substituting for that name, e.g.,
        [subst_tt_intro].

    We keep the sections as uniform in structure as possible.  In
    particular, we state explicitly strengthened induction hypotheses
    even when there are more concise ways of proving the lemmas of
    interest. *)

(* ********************************************************************** *)
(** ** Properties of type substitution in types *)

(** The next lemma is the strengthened induction hypothesis for the
    lemma that follows, which states that opening a locally closed
    term is the identity.  This lemma is not otherwise independently
    useful. *)

Lemma open_tt_rec_type_aux : forall T j V i U,
  i <> j ->
  open_tt_rec j V T = open_tt_rec i U (open_tt_rec j V T) ->
  T = open_tt_rec i U T.
Proof with eauto*.
  induction T; intros j V i U Neq H; simpl in *; inversion H; f_equal...
  Case "typ_bvar".
    destruct (j === n)... destruct (i === n)...
Qed.

(** Opening a locally closed term is the identity.  This lemma depends
    on the immediately preceding lemma. *)

Lemma open_tt_rec_type : forall T U k,
  type T ->
  T = open_tt_rec k U T.
Proof with auto*.
  intros T U k Htyp. revert k.
  induction Htyp; intros k; simpl; f_equal...
  Case "typ_all".
    unfold open_tt in *.
    pick fresh X.
    apply (open_tt_rec_type_aux T2 0 (typ_fvar X))...
Qed.

(** If a name is fresh for a term, then substituting for it is the
    identity. *)

Lemma subst_tt_fresh : forall Z U T,
   Z `notin` fv_tt T ->
   T = subst_tt Z U T.
Proof with auto*.
  induction T; simpl; intro H; f_equal...
  Case "typ_fvar".
    destruct (a == Z)...
    absurd_hyp H; fsetdec.
Qed.

(** Substitution commutes with opening under certain conditions.  This
    lemma depends on the fact that opening a locally closed term is
    the identity. *)

Lemma subst_tt_open_tt_rec : forall T1 T2 X P k,
  type P ->
  subst_tt X P (open_tt_rec k T2 T1) =
    open_tt_rec k (subst_tt X P T2) (subst_tt X P T1).
Proof with auto*.
  intros T1 T2 X P k WP. revert k.
  induction T1; intros K; simpl; f_equal...
  Case "typ_bvar".
    destruct (K === n); subst...
  Case "typ_fvar".
    destruct (a == X); subst... apply open_tt_rec_type...
Qed.

(** The next lemma is a direct corollary of the immediately preceding
    lemma---the index is specialized to zero. *)

Lemma subst_tt_open_tt : forall T1 T2 (X:atom) P,
  type P ->
  subst_tt X P (open_tt T1 T2) = open_tt (subst_tt X P T1) (subst_tt X P T2).
Proof with auto*.
  intros.
  unfold open_tt.
  apply subst_tt_open_tt_rec...
Qed.

(** The next lemma is a direct corollary of the immediately preceding
    lemma---here, we're opening the term with a variable.  In
    practice, this lemma seems to be needed as a left-to-right rewrite
    rule, when stated in its current form. *)

Lemma subst_tt_open_tt_var : forall (X Y:atom) P T,
  Y <> X ->
  type P ->
  open_tt (subst_tt X P T) Y = subst_tt X P (open_tt T Y).
Proof with auto*.
  intros X Y P T Neq Wu.
  unfold open_tt.
  rewrite subst_tt_open_tt_rec...
  simpl.
  destruct (Y == X)...
Qed.

(** The next lemma states that opening a term is equivalent to first
    opening the term with a fresh name and then substituting for the
    name.  This is actually the strengthened induction hypothesis for
    the version we use in practice. *)

Lemma subst_tt_intro_rec : forall X T2 U k,
  X `notin` fv_tt T2 ->
  open_tt_rec k U T2 = subst_tt X U (open_tt_rec k (typ_fvar X) T2).
Proof with auto*.
  induction T2; intros U K Fr; simpl in *; f_equal...
  Case "typ_bvar".
    destruct (K === n)... simpl. destruct (X == X)...
  Case "typ_fvar".
    destruct (a == X)... absurd_hyp Fr; fsetdec.
Qed.

(** The next lemma is a direct corollary of the immediately preceding
    lemma---the index is specialized to zero.  *)

Lemma subst_tt_intro : forall X T2 U,
  X `notin` fv_tt T2 ->
  open_tt T2 U = subst_tt X U (open_tt T2 X).
Proof with auto*.
  intros.
  unfold open_tt.
  apply subst_tt_intro_rec...
Qed.

(* ********************************************************************** *)
(** ** Properties of type substitution in expressions *)

(** This section follows the structure of the previous section.  The
    one notable difference is that we require two auxiliary lemmas to
    show that substituting a type in a locally-closed expression is
    the identity. *)

Lemma open_te_rec_expr_aux : forall e j u i P ,
  open_ee_rec j u e = open_te_rec i P (open_ee_rec j u e) ->
  e = open_te_rec i P e.
Proof with eauto*.
  induction e; intros j u i P H; simpl in *; inversion H; f_equal...
Qed.

Lemma open_te_rec_type_aux : forall e j Q i P,
  i <> j ->
  open_te_rec j Q e = open_te_rec i P (open_te_rec j Q e) ->
  e = open_te_rec i P e.
Proof.
  induction e; intros j Q i P Neq Heq; simpl in *; inversion Heq;
    f_equal; eauto using open_tt_rec_type_aux.
Qed.

Lemma open_te_rec_expr : forall e U k,
  expr e ->
  e = open_te_rec k U e.
Proof with auto*.
  intros e U k WF. revert k.
  induction WF; intros k; simpl; f_equal; auto using open_tt_rec_type;
  try solve [
    unfold open_ee in *;
    pick fresh x;
    eapply open_te_rec_expr_aux with (j := 0) (u := exp_fvar x);
    auto*
  | unfold open_te in *;
    pick fresh X;
    eapply open_te_rec_type_aux with (j := 0) (Q := typ_fvar X);
    auto*
  ].
Qed.

Lemma subst_te_fresh : forall X U e,
  X `notin` fv_te e ->
  e = subst_te X U e.
Proof.
  induction e; simpl; intros; f_equal; auto using subst_tt_fresh.
Qed.

Lemma subst_te_open_te_rec : forall e T X U k,
  type U ->
  subst_te X U (open_te_rec k T e) =
    open_te_rec k (subst_tt X U T) (subst_te X U e).
Proof.
  intros e T X U k WU. revert k.
  induction e; intros K; simpl; f_equal; auto using subst_tt_open_tt_rec.
Qed.

Lemma subst_te_open_te : forall e T X U,
  type U ->
  subst_te X U (open_te e T) = open_te (subst_te X U e) (subst_tt X U T).
Proof with auto*.
  intros.
  unfold open_te.
  apply subst_te_open_te_rec...
Qed.

Lemma subst_te_open_te_var : forall (X Y:atom) U e,
  Y <> X ->
  type U ->
  open_te (subst_te X U e) Y = subst_te X U (open_te e Y).
Proof with auto*.
  intros X Y U e Neq WU.
  unfold open_te.
  rewrite subst_te_open_te_rec...
  simpl.
  destruct (Y == X)...
Qed.

Lemma subst_te_intro_rec : forall X e U k,
  X `notin` fv_te e ->
  open_te_rec k U e = subst_te X U (open_te_rec k (typ_fvar X) e).
Proof.
  induction e; intros U K Fr; simpl in *; f_equal;
    auto using subst_tt_intro_rec.
Qed.

Lemma subst_te_intro : forall X e U,
  X `notin` fv_te e ->
  open_te e U = subst_te X U (open_te e X).
Proof with auto*.
  intros.
  unfold open_te.
  apply subst_te_intro_rec...
Qed.

(* ********************************************************************** *)
(** ** Properties of expression substitution in expressions *)

(** This section follows the structure of the previous two sections. *)

Lemma open_ee_rec_expr_aux : forall e j v u i,
  i <> j ->
  open_ee_rec j v e = open_ee_rec i u (open_ee_rec j v e) ->
  e = open_ee_rec i u e.
Proof with eauto*.
  induction e; intros j v u i Neq H; simpl in *; inversion H; f_equal...
  Case "exp_bvar".
    destruct (j===n)... destruct (i===n)...
Qed.

Lemma open_ee_rec_type_aux : forall e j V u i,
  open_te_rec j V e = open_ee_rec i u (open_te_rec j V e) ->
  e = open_ee_rec i u e.
Proof.
  induction e; intros j V u i H; simpl; inversion H; f_equal; eauto.
Qed.

Lemma open_ee_rec_expr : forall u e k,
  expr e ->
  e = open_ee_rec k u e.
Proof with auto*.
  intros u e k Hexpr. revert k.
  induction Hexpr; intro k; simpl; f_equal; auto*;
  try solve [
    unfold open_ee in *;
    pick fresh x;
    eapply open_ee_rec_expr_aux with (j := 0) (v := exp_fvar x);
    auto*
  | unfold open_te in *;
    pick fresh X;
    eapply open_ee_rec_type_aux with (j := 0) (V := typ_fvar X);
    auto*
  ].
Qed.

Lemma subst_ee_fresh : forall (x: atom) u e,
  x `notin` fv_ee e ->
  e = subst_ee x u e.
Proof with auto*.
  intros x u e; induction e; simpl; intro H; f_equal...
  Case "exp_fvar".
    destruct (a==x)...
    absurd_hyp H; fsetdec.
Qed.

Lemma subst_ee_open_ee_rec : forall e1 e2 x u k,
  expr u ->
  subst_ee x u (open_ee_rec k e2 e1) =
    open_ee_rec k (subst_ee x u e2) (subst_ee x u e1).
Proof with auto*.
  intros e1 e2 x u k WP. revert k.
  induction e1; intros K; simpl; f_equal...
  Case "exp_bvar".
    destruct (K === n); subst...
  Case "exp_fvar".
    destruct (a == x); subst... apply open_ee_rec_expr...
Qed.

Lemma subst_ee_open_ee : forall e1 e2 x u,
  expr u ->
  subst_ee x u (open_ee e1 e2) =
    open_ee (subst_ee x u e1) (subst_ee x u e2).
Proof with auto*.
  intros.
  unfold open_ee.
  apply subst_ee_open_ee_rec...
Qed.

Lemma subst_ee_open_ee_var : forall (x y:atom) u e,
  y <> x ->
  expr u ->
  open_ee (subst_ee x u e) y = subst_ee x u (open_ee e y).
Proof with auto*.
  intros x y u e Neq Wu.
  unfold open_ee.
  rewrite subst_ee_open_ee_rec...
  simpl.
  destruct (y == x)...
Qed.

Lemma subst_te_open_ee_rec : forall e1 e2 Z P k,
  subst_te Z P (open_ee_rec k e2 e1) =
    open_ee_rec k (subst_te Z P e2) (subst_te Z P e1).
Proof with auto*.
  induction e1; intros e2 Z P K; simpl; f_equal...
  Case "exp_bvar".
    destruct (K === n)...
Qed.

Lemma subst_te_open_ee : forall e1 e2 Z P,
  subst_te Z P (open_ee e1 e2) = open_ee (subst_te Z P e1) (subst_te Z P e2).
Proof with auto*.
  intros.
  unfold open_ee.
  apply subst_te_open_ee_rec...
Qed.

Lemma subst_te_open_ee_var : forall Z (x:atom) P e,
  open_ee (subst_te Z P e) x = subst_te Z P (open_ee e x).
Proof with auto*.
  intros.
  rewrite subst_te_open_ee...
Qed.

Lemma subst_ee_open_te_rec : forall e P z u k,
  expr u ->
  subst_ee z u (open_te_rec k P e) = open_te_rec k P (subst_ee z u e).
Proof with auto*.
  induction e; intros P z u K H; simpl; f_equal...
  Case "exp_fvar".
    destruct (a == z)... apply open_te_rec_expr...
Qed.

Lemma subst_ee_open_te : forall e P z u,
  expr u ->
  subst_ee z u (open_te e P) = open_te (subst_ee z u e) P.
Proof with auto*.
  intros.
  unfold open_te.
  apply subst_ee_open_te_rec...
Qed.

Lemma subst_ee_open_te_var : forall z (X:atom) u e,
  expr u ->
  open_te (subst_ee z u e) X = subst_ee z u (open_te e X).
Proof with auto*.
  intros z X u e H.
  rewrite subst_ee_open_te...
Qed.

Lemma subst_ee_intro_rec : forall x e u k,
  x `notin` fv_ee e ->
  open_ee_rec k u e = subst_ee x u (open_ee_rec k (exp_fvar x) e).
Proof with auto*.
  induction e; intros u K Fr; simpl in *; f_equal...
  Case "exp_bvar".
    destruct (K === n)... simpl. destruct (x == x)...
  Case "exp_fvar".
    destruct (a == x)... absurd_hyp Fr; fsetdec.
Qed.

Lemma subst_ee_intro : forall x e u,
  x `notin` fv_ee e ->
  open_ee e u = subst_ee x u (open_ee e x).
Proof with auto*.
  intros.
  unfold open_ee.
  apply subst_ee_intro_rec...
Qed.

(* *********************************************************************** *)
(** * ## Local closure is preserved under substitution *)

(** While these lemmas may be considered properties of substitution, we
    separate them out due to the lemmas that they depend on. *)

(** The following lemma depends on [subst_tt_open_tt_var]. *)

Lemma subst_tt_type : forall Z P T,
  type T ->
  type P ->
  type (subst_tt Z P T).
Proof with auto.
  intros Z P T HT HP.
  induction HT; simpl...
  Case "type_fvar".
    destruct (X == Z)...
  Case "type_all".
    pick fresh Y and apply type_all...
    rewrite subst_tt_open_tt_var...
Qed.

(** The following lemma depends on [subst_tt_type] and
    [subst_te_open_ee_var]. *)

Lemma subst_te_expr : forall Z P e,
  expr e ->
  type P ->
  expr (subst_te Z P e).
Proof with eauto using subst_tt_type.
  intros Z P e He Hp.
  induction He; simpl; auto using subst_tt_type;
  try solve [
    econstructor;
    try instantiate (1 := L `union` singleton Z);
    intros;
    try rewrite subst_te_open_ee_var;
    try rewrite subst_te_open_te_var;
    eauto using subst_tt_type
  ].
Qed.

(** The following lemma depends on [subst_ee_open_ee_var] and
    [subst_ee_open_te_var]. *)

Lemma subst_ee_expr : forall z e1 e2,
  expr e1 ->
  expr e2 ->
  expr (subst_ee z e2 e1).
Proof with auto.
  intros z e1 e2 He1 He2.
  induction He1; simpl; auto;
  try solve [
    econstructor;
    try instantiate (1 := L `union` singleton z);
    intros;
    try rewrite subst_ee_open_ee_var;
    try rewrite subst_ee_open_te_var;
    auto
  ].
  Case "expr_var".
    destruct (x == z)...
Qed.

(* *********************************************************************** *)
(** * ## Automation *)

(** We add as hints the fact that local closure is preserved under
    substitution.  This is part of our strategy for automatically
    discharging local-closure proof obligations. *)

Hint Resolve subst_tt_type subst_te_expr subst_ee_expr.

(** When reasoning about the [binds] relation and [map], we
    occasionally encounter situations where the binding is
    over-simplified.  The following hint undoes that simplification,
    thus enabling [Hint]s from the [Environment] library. *)

Hint Extern 1 (binds _ (?F (subst_tt ?X ?U ?T)) _) =>
  unsimpl (subst_tb X U (F T)).

Hint Extern 1 (binds _ (?F (subst_tt ?X ?U ?T)) _) =>
  unsimpl (subst_tlb X U (F T)).


Require Import
  Coq.Unicode.Utf8
  (* Coq.ZArith.ZArith *)
  (* Coq.Logic.PropExtensionality *)
  (* Hask.Control.Monad *)
  Data.Semigroup
  Data.Monoid
  (* Data.Either *)
  (* Pact.Lib *)
  (* Pact.Ty *)
  (* Pact.Exp *)
  (* Pact.Value *)
  (* Pact.Ren *)
  (* Pact.Sub *)
  (* Pact.SemTy *)
  (* Pact.Lang *)
  (* Pact.Lang.Capability *)
  (* Pact.SemExp *)
  Coq.Classes.RelationClasses
  Coq.Classes.Morphisms
  (* Pact.Ltac *)
.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* Set Equations With UIP. *)

Generalizable All Variables.
Set Primitive Projections.

(* Import ListNotations. *)

Declare Scope hoare_scope.
Declare Scope hoare_scope_ext.

Reserved Infix "\u" (at level 45, right associativity).
Reserved Infix "==>" (at level 55, right associativity).
Reserved Infix "===>" (at level 55, right associativity).
Reserved Infix "\*" (at level 41, right associativity).
Reserved Notation "'\exists' x1 .. xn , H"
  (at level 39, x1 binder, H at level 50, right associativity,
   format "'[' '\exists' '/ '  x1  ..  xn , '/ '  H ']'").
Reserved Notation "'\forall' x1 .. xn , H"
  (at level 39, x1 binder, H at level 50, right associativity,
   format "'[' '\forall' '/ '  x1  ..  xn , '/ '  H ']'").
Reserved Notation "\[ P ]" (at level 0, format "\[ P ]").
Reserved Notation "H1 \-* H2" (at level 43, right associativity).
Reserved Notation "Q1 \--* Q2" (at level 43).

Class HoareLogic (heap : Type) := {
  heap_empty : heap;

  (** In traditional Separation Logic, two heaps are compatible (that is, can
      be composed) if and only if they have disjoint domains, and their
      composition is just their union. *)
  heap_compat : heap → heap → Prop;

  heap_compat_irr {h} :
    h <> heap_empty →
    ¬ heap_compat h h;
  heap_compat_sym {h1 h2} :
    heap_compat h1 h2 →
    heap_compat h2 h1;
  heap_compat_empty_l {h} :
    heap_compat heap_empty h;

  heap_union : heap → heap → heap
    where "X \u Y" := (heap_union X Y) : hoare_scope;

  heap_compat_union_l_eq {h1 h2 h3} :
    heap_compat h1 h2 →
    heap_compat (h1 \u h2) h3 = (heap_compat h1 h3 ∧ heap_compat h2 h3);

  heap_union_empty_l {h} :
    heap_empty \u h = h;
  heap_union_comm {h1 h2} :
    heap_compat h1 h2 →
    h1 \u h2 = h2 \u h1;
  heap_union_assoc {h1 h2 h3} :
    heap_compat h1 h2 →
    heap_compat h2 h3 →
    heap_compat h1 h3 →
    (h1 \u h2) \u h3 = h1 \u (h2 \u h3);

  hprop := heap → Prop;
  himpl (H1 H2 : hprop) : Prop :=
    ∀ h : heap, H1 h → H2 h
    where "H1 ==> H2" := (himpl H1 H2) : hoare_scope;
  qimpl {A} (Q1 Q2 : A → hprop) : Prop :=
    ∀ v : A, Q1 v ==> Q2 v
    where "Q1 ===> Q2" := (qimpl Q1 Q2) : hoare_scope;

  hempty : hprop := λ h, h = heap_empty;

  hstar (H1 H2 : hprop) : hprop :=
    λ h, ∃ h1 h2,
        H1 h1
      ∧ H2 h2
      ∧ heap_compat h1 h2
      ∧ h = h1 \u h2
    where "H1 '\*' H2" := (hstar H1 H2) : hoare_scope;

  hexists {A} (J : A → hprop) : hprop :=
    λ h, ∃ x, J x h
    where "'\exists' x1 .. xn , H" :=
      (hexists (λ x1, .. (hexists (λ xn, H)) ..)) : hoare_scope;

  hforall {A : Type} (J : A → hprop) : hprop :=
    λ h, ∀ x, J x h
    where "'\forall' x1 .. xn , H" :=
      (hforall (λ x1, .. (hforall (λ xn, H)) ..)) : hoare_scope;

  hpure (P : Prop) : hprop :=
    hexists (λ p : P, hempty)
    where "\[ P ]" := (hpure P) : hoare_scope;

  hwand (H1 H2 : hprop) : hprop :=
    hexists (λ H : hprop, H \* (hpure (H1 \* H ==> H2)))
    where "H1 \-* H2" := (hwand H1 H2) : hoare_scope;

  qwand {A} (Q1 Q2 : A → hprop) : hprop :=
    hforall (λ x, hwand (Q1 x) (Q2 x))
    where "Q1 \--* Q2" := (qwand Q1 Q2) : hoare_scope;

  hor (H1 H2 : hprop) : hprop :=
    \exists (b : bool), if b then H1 else H2;

  hand (H1 H2 : hprop) : hprop :=
    \forall (b : bool), if b then H1 else H2;

  htop : hprop :=
    hexists (λ H : hprop, H);
}.

Infix "\u" := heap_union (at level 45, right associativity) : hoare_scope.
Infix "==>" := himpl (at level 55, right associativity) : hoare_scope.
Infix "===>" := qimpl (at level 55, right associativity) : hoare_scope.
Infix "\*" := hstar (at level 41, right associativity) : hoare_scope.
Notation "'\exists' x1 .. xn , H" :=
  (hexists (λ x1, .. (hexists (λ xn, H)) ..))
  (at level 39, x1 binder, H at level 50, right associativity,
   format "'[' '\exists' '/ '  x1  ..  xn , '/ '  H ']'") : hoare_scope.
Notation "'\forall' x1 .. xn , H" :=
  (hforall (λ x1, .. (hforall (λ xn, H)) ..))
  (at level 39, x1 binder, H at level 50, right associativity,
   format "'[' '\forall' '/ '  x1  ..  xn , '/ '  H ']'") : hoare_scope.
Notation "\[ P ]" := (hpure P) (at level 0, format "\[ P ]") : hoare_scope.
Notation "H1 \-* H2" := (hwand H1 H2)
  (at level 43, right associativity) : hoare_scope.
Notation "Q1 \--* Q2" := (qwand Q1 Q2) (at level 43) : hoare_scope.

Notation "\[]" := hempty (at level 0) : hoare_scope.
Notation "Q \*+ H" := (λ x, hstar (Q x) H) (at level 40) : hoare_scope.
Notation "\Top" := htop (at level 0) : hoare_scope.

Delimit Scope hoare_scope with hprop.

Notation "H1 ==+> H2" := (H1%hprop ==> hstar H1%hprop H2%hprop)%hprop
  (at level 55, only parsing) : hoare_scope_ext.

Section Hoare.

Open Scope hoare_scope.

Context `{HL : HoareLogic heap}.

Implicit Types h : heap.
Implicit Types P : Prop.
Implicit Types H : hprop.

(** Properties of entailment *)

Lemma himpl_refl {H} :
  (H ==> H).
Proof. now repeat intro. Qed.

#[local] Hint Resolve himpl_refl : core.

Lemma himpl_trans {H2 H1 H3} :
  (H1 ==> H2) →
  (H2 ==> H3) →
  (H1 ==> H3).
Proof.
  repeat intro.
  now apply H0, H.
Qed.

#[export]
Program Instance himpl_PreOrder : PreOrder himpl.
Next Obligation.
  repeat intro.
  eapply himpl_trans; eauto.
Qed.

Lemma himpl_antisym {H1 H2} :
  (H1 ==> H2) →
  (H2 ==> H1) →
  (H1 = H2).
Proof. Admitted.

(** Additional properties of [himpl] *)

Lemma himpl_forall_trans {H1 H2} :
  (∀ H, H ==> H1 → H ==> H2) →
  (H1 ==> H2).
Proof. Admitted.

Lemma himpl_inv {H1 H2 h} :
  (H1 ==> H2) →
  (H1 h) →
  (H2 h).
Proof. auto. Qed.

(** Properties of entailment for postconditions *)

Lemma qimpl_refl {A} {Q : A → hprop} :
  (Q ===> Q).
Proof. Admitted.

#[local] Hint Resolve qimpl_refl : core.

Lemma qimpl_trans {A} {Q2 Q1 Q3 : A → hprop} :
  (Q1 ===> Q2) →
  (Q2 ===> Q3) →
  (Q1 ===> Q3).
Proof. Admitted.

#[export]
Program Instance qimpl_PreOrder {A} : PreOrder (qimpl (A:=A)).
Next Obligation.
  repeat intro.
  eapply qimpl_trans; eauto.
Qed.

Lemma qimpl_antisym {A} {Q1 Q2 : A → hprop} :
  (Q1 ===> Q2) →
  (Q2 ===> Q1) →
  (Q1 = Q2).
Proof. Admitted.

Lemma heap_compat_sym_eq {h1 h2} :
  heap_compat h1 h2 = heap_compat h2 h1.
Proof. Admitted.

Lemma heap_compat_empty_r {h} :
  heap_compat h heap_empty.
Proof.
  rewrite heap_compat_sym_eq.
  apply heap_compat_empty_l.
Qed.

Lemma heap_union_empty_r {h} :
  h \u heap_empty = h.
Proof. Admitted.

Lemma heap_compat_union_r_eq {h1 h2 h3} :
  heap_compat h2 h3 →
  heap_compat h1 (h2 \u h3) = (heap_compat h1 h2 ∧ heap_compat h1 h3).
Proof. Admitted.

Lemma heap_compat_union_l {h1 h2 h3} :
  heap_compat h1 h2 →
  heap_compat h1 h3 →
  heap_compat h2 h3 →
  heap_compat (h1 \u h2) h3.
Proof. Admitted.

Lemma heap_compat_union_r {h1 h2 h3} :
  heap_compat h1 h2 →
  heap_compat h1 h3 →
  heap_compat h2 h3 →
  heap_compat h1 (h2 \u h3).
Proof. Admitted.

(* ---------------------------------------------------------------------- *)
(* ** Tactic *)

(* Hint Rewrite heap_union_empty_l heap_union_empty_r heap_union_assoc : rew_heaps. *)

(* Tactic Notation "rew_heaps" := *)
(*   autorewrite with rew_heaps. *)
(* Tactic Notation "rew_heaps" "in" hyp(H) := *)
(*   autorewrite with rew_heaps in H. *)
(* Tactic Notation "rew_heaps" "in" "*" := *)
(*   autorewrite with rew_heaps in *. *)

(* ---------------------------------------------------------------------- *)
(* ** Introduction and Inversion Lemmas for Core Heap Predicates *)

(** Core heap predicates *)

Lemma hempty_intro :
  \[] heap_empty.
Proof. Admitted.

Lemma hempty_inv {h} :
  \[] h →
  h = heap_empty.
Proof. Admitted.

Lemma hstar_intro {H1 H2 : hprop} {h1 h2} :
  H1 h1 →
  H2 h2 →
  heap_compat h1 h2 →
  (H1 \* H2) (h1 \u h2).
Proof. Admitted.

Lemma hstar_inv {H1 H2 h} :
  (H1 \* H2) h →
  exists h1 h2, H1 h1 ∧ H2 h2 ∧ heap_compat h1 h2 ∧ h = h1 \u h2.
Proof. Admitted.

Lemma hexists_intro {A} {J : A → hprop} {x h} :
  J x h →
  (hexists J) h.
Proof. Admitted.

Lemma hexists_inv {A} {J : A → hprop} {h} :
  (hexists J) h →
  exists x, J x h.
Proof. Admitted.

Lemma hforall_intro {A} {J : A → hprop} {h} :
  (∀ x, J x h) →
  (hforall J) h.
Proof. Admitted.

Lemma hforall_inv {A} {J : A → hprop} {h} :
  (hforall J) h →
  ∀ x, J x h.
Proof. Admitted.

(** Derived heap predicates *)

Lemma hpure_intro {P} :
  P →
  \[P] heap_empty.
Proof. Admitted.

Lemma hpure_inv {P h} :
  \[P] h →
  P ∧ h = heap_empty.
Proof. Admitted.

(* ---------------------------------------------------------------------- *)
(* ** Proving core properties of operators *)

(** Lemmas from this section should be the last ones to access the
    internal definition of the operators hempty and hstar. *)

Section CoreProperties.

#[local] Hint Resolve heap_compat_empty_l heap_compat_empty_r
  heap_union_empty_l heap_union_empty_r hempty_intro
  heap_compat_union_l heap_compat_union_r : core.

(** Empty is left neutral for star *)

Lemma hstar_hempty_l {H} :
  \[] \* H = H.
Proof. Admitted.

(** Star is commutative *)

Lemma hstar_comm {H1 H2} :
   H1 \* H2 = H2 \* H1.
Proof. Admitted.

(** Star is associative *)

Lemma hstar_assoc {H1 H2 H3} :
  (H1 \* H2) \* H3 = H1 \* (H2 \* H3).
Proof. Admitted.

#[export]
Instance hstar_Semigroup : Semigroup hprop := {|
  mappend := hstar
|}.

#[export]
Program Instance hstar_SemigroupLaws : SemigroupLaws hprop.
Next Obligation.
  symmetry.
  apply hstar_assoc.
Qed.

(** Extrusion of existentials out of star *)

Lemma hstar_hexists {A} {J : A → hprop} {H} :
  (hexists J) \* H = hexists (fun x => (J x) \* H).
Proof. Admitted.

(** Extrusion of foralls out of star *)

Lemma hstar_hforall {H A} {J : A → hprop} :
  (hforall J) \* H ==> hforall (J \*+ H).
Proof. Admitted.

(** The frame property (star on H2) holds for entailment *)

Lemma himpl_frame_l {H2 H1 H1'} :
  H1 ==> H1' →
  (H1 \* H2) ==> (H1' \* H2).
Proof. Admitted.

(** Properties of [hpure] *)

Lemma hstar_hpure_l {P H h} :
  (\[P] \* H) h = (P ∧ H h).
Proof. Admitted.

End CoreProperties.

#[global] Opaque hempty hpure hstar hexists.

(* ---------------------------------------------------------------------- *)
(* ** Properties of [hstar] *)

Lemma hstar_hempty_r {H} :
  H \* \[] = H.
Proof. Admitted.

#[export]
Instance hstar_Monoid : Monoid hprop := {|
  mempty := hempty
|}.

#[export]
Program Instance hstar_MonoidLaws : MonoidLaws hprop.
Next Obligation. apply hstar_hempty_l. Qed.
Next Obligation. apply hstar_hempty_r. Qed.

Lemma himpl_frame_r {H1 H2 H2'} :
  H2 ==> H2' →
  (H1 \* H2) ==> (H1 \* H2').
Proof. Admitted.

Lemma himpl_frame_lr {H1 H1' H2 H2'} :
  H1 ==> H1' →
  H2 ==> H2' →
  (H1 \* H2) ==> (H1' \* H2').
Proof. Admitted.

Lemma himpl_hstar_trans_l {H1 H2 H3 H4} :
  H1 ==> H2 →
  H2 \* H3 ==> H4 →
  H1 \* H3 ==> H4.
Proof. Admitted.

Lemma himpl_hstar_trans_r {H1 H2 H3 H4} :
  H1 ==> H2 →
  H3 \* H2 ==> H4 →
  H3 \* H1 ==> H4.
Proof. Admitted.

(* ---------------------------------------------------------------------- *)
(** Properties of [hpure] *)

Lemma hstar_hpure_r {P H h} :
  (H \* \[P]) h = (H h ∧ P).
Proof. Admitted.

(* backward compatibility *)
Definition hstar_hpure {P H h} := @hstar_hpure_l P H h.

  (* corollary only used for the SL course *)
Lemma hstar_hpure_iff {P H h} :
  (\[P] \* H) h ↔ (P ∧ H h).
Proof. Admitted.

Lemma himpl_hstar_hpure_r {P H H'} :
  P →
  (H ==> H') →
  H ==> (\[P] \* H').
Proof. Admitted.

Lemma hpure_inv_hempty {P h} :
  \[P] h →
  P ∧ \[] h.
Proof. Admitted.

Lemma hpure_intro_hempty {P h} :
  \[] h →
  P →
  \[P] h.
Proof. Admitted.

Lemma himpl_hempty_hpure {P} :
  P →
  \[] ==> \[P].
Proof. Admitted.

Lemma himpl_hstar_hpure_l {P H H'} :
  (P → H ==> H') →
  (\[P] \* H) ==> H'.
Proof. Admitted.

Lemma hempty_eq_hpure_true :
  \[] = \[True].
Proof. Admitted.

Lemma hfalse_hstar_any {H} :
  \[False] \* H = \[False].
Proof. Admitted.

Lemma hpure_eq_hexists_empty {P} :
  \[P] = (\exists (p : P), \[]).
Proof. auto. Qed.

(* ---------------------------------------------------------------------- *)
(** Properties of [hexists] *)

Lemma himpl_hexists_l {A H} {J : A → hprop} :
  (∀ x, J x ==> H) →
  (hexists J) ==> H.
Proof. Admitted.

Lemma himpl_hexists_r {A} {x : A} {H J} :
  (H ==> J x) →
  H ==> (hexists J).
Proof. Admitted.

Lemma himpl_hexists {A} {J1 J2 : A → hprop} :
  J1 ===> J2 →
  hexists J1 ==> hexists J2.
Proof. Admitted.

(* ---------------------------------------------------------------------- *)
(** Properties of [hforall] *)

Lemma himpl_hforall_r {A} {J : A → hprop} {H} :
  (∀ x, H ==> J x) →
  H ==> (hforall J).
Proof. Admitted.

Lemma himpl_hforall_l {A x} {J : A → hprop} {H} :
  (J x ==> H) →
  (hforall J) ==> H.
Proof. Admitted.

Lemma himpl_hforall_l_exists {A} {J : A → hprop} {H} :
  (exists x, J x ==> H) →
  (hforall J) ==> H.
Proof. Admitted.

Lemma himpl_hforall {A} {J1 J2 : A → hprop} :
  J1 ===> J2 →
  hforall J1 ==> hforall J2.
Proof. Admitted.

Lemma hforall_specialize {A} {x : A} {J : A → hprop} :
  (hforall J) ==> (J x).
Proof. Admitted.

(* ---------------------------------------------------------------------- *)
(** Properties of hwand (others are found further in the file) *)

Lemma hwand_eq_hexists {H1 H2} :
  (H1 \-* H2) = (\exists H, H \* \[H1 \* H ==> H2]).
Proof. auto. Qed.

Lemma hwand_equiv {H0 H1 H2} :
  (H0 ==> H1 \-* H2) ↔ (H1 \* H0 ==> H2).
Proof. Admitted.

Lemma himpl_hwand_r {H1 H2 H3} :
  H2 \* H1 ==> H3 →
  H1 ==> (H2 \-* H3).
Proof. Admitted.

Lemma himpl_hwand_r_inv {H1 H2 H3} :
  H1 ==> (H2 \-* H3) →
  H2 \* H1 ==> H3.
Proof. Admitted.

Lemma hwand_cancel {H1 H2} :
  H1 \* (H1 \-* H2) ==> H2.
Proof. Admitted.

Arguments hwand_cancel : clear implicits.

Lemma himpl_hempty_hwand_same {H} :
  \[] ==> (H \-* H).
Proof. Admitted.

Lemma hwand_hempty_l {H} :
  (\[] \-* H) = H.
Proof. Admitted.

Lemma hwand_hpure_l {P H} :
  P →
  (\[P] \-* H) = H.
Proof. Admitted.

Arguments hwand_hpure_l : clear implicits.

Lemma hwand_curry {H1 H2 H3} :
  (H1 \* H2) \-* H3 ==> H1 \-* (H2 \-* H3).
Proof. Admitted.

Lemma hwand_uncurry {H1 H2 H3} :
  H1 \-* (H2 \-* H3) ==> (H1 \* H2) \-* H3.
Proof. Admitted.

Lemma hwand_curry_eq {H1 H2 H3} :
  (H1 \* H2) \-* H3 = H1 \-* (H2 \-* H3).
Proof. Admitted.

(* ---------------------------------------------------------------------- *)
(** Properties of [qwand] *)

Lemma qwand_equiv {H A} {Q1 Q2 : A → hprop} :
  H ==> (Q1 \--* Q2) ↔ (Q1 \*+ H) ===> Q2.
Proof. Admitted.

Lemma himpl_qwand_r {A} {Q1 Q2 : A → hprop} {H} :
  Q1 \*+ H ===> Q2 →
  H ==> (Q1 \--* Q2).
Proof. Admitted.

Arguments himpl_qwand_r [A].

Lemma qwand_specialize {A} {x : A} {Q1 Q2 : A → hprop} :
  (Q1 \--* Q2) ==> (Q1 x \-* Q2 x).
Proof. Admitted.

Arguments qwand_specialize [ A ].

(* ---------------------------------------------------------------------- *)
(** Properties of [htop] *)

Lemma htop_intro {h} :
  \Top h.
Proof. Admitted.

Lemma himpl_htop_r {H} :
  H ==> \Top.
Proof. Admitted.

Lemma htop_eq :
  \Top = (\exists H, H).
Proof. auto. Qed.

Lemma hstar_htop_htop :
  \Top \* \Top = \Top.
Proof. Admitted.

(* ---------------------------------------------------------------------- *)
(* ** Properties of [hor] *)

Lemma hor_eq_exists_bool {H1 H2} :
  hor H1 H2 = \exists (b : bool), if b then H1 else H2.
Proof. auto. Qed.

Lemma hor_sym {H1 H2} :
  hor H1 H2 = hor H2 H1.
Proof. Admitted.

Lemma himpl_hor_r_r {H1 H2} :
  H1 ==> hor H1 H2.
Proof. Admitted.

Lemma himpl_hor_r_l {H1 H2} :
  H2 ==> hor H1 H2.
Proof. Admitted.

Lemma himpl_hor_l {H1 H2 H3} :
  H1 ==> H3 →
  H2 ==> H3 →
  hor H1 H2 ==> H3.
Proof. Admitted.

#[global] Opaque hor.

(* ---------------------------------------------------------------------- *)
(* ** Properties of [hand] *)

Lemma hand_eq_forall_bool {H1 H2} :
  hand H1 H2 = \forall (b : bool), if b then H1 else H2.
Proof. auto. Qed.

Lemma hand_sym {H1 H2} :
  hand H1 H2 = hand H2 H1.
Proof. Admitted.

Lemma himpl_hand_l_r {H1 H2} :
  hand H1 H2 ==> H1.
Proof. Admitted.

Lemma himpl_hand_l_l {H1 H2} :
  hand H1 H2 ==> H2.
Proof. Admitted.

Lemma himpl_hand_r {H1 H2 H3} :
  H3 ==> H1 →
  H3 ==> H2 →
  H3 ==> hand H1 H2.
Proof. Admitted.

#[global] Opaque hand.

(** Experimental tactic [xsimpl_hand] *)

(* Tactic Notation "xsimpl_hand" := *)
(*    xsimpl; try (applys himpl_hand_r; xsimpl). *)

(* ---------------------------------------------------------------------- *)
(* ** Set operators to be opaque *)

#[global] Opaque hempty hpure hstar hexists htop hand hor.

(* ********************************************************************** *)
(* * More properties of the magic wand *)

(* ---------------------------------------------------------------------- *)
(* ** Properties of [hwand] *)

Lemma hwand_eq_hexists_hstar_hpure {H1 H2} :
  (H1 \-* H2) = (\exists H, H \* \[H1 \* H ==> H2]).
Proof. auto. Qed.

Lemma hwand_himpl {H1 H1' H2 H2'} :
  H1' ==> H1 →
  H2 ==> H2' →
  (H1 \-* H2) ==> (H1' \-* H2').
Proof. Admitted.

Lemma hwand_himpl_r {H1 H2 H2'} :
  H2 ==> H2' →
  (H1 \-* H2) ==> (H1 \-* H2').
Proof. Admitted.

Lemma hwand_himpl_l {H1' H1 H2} :
  H1' ==> H1 →
  (H1 \-* H2) ==> (H1' \-* H2).
Proof. Admitted.

Lemma hwand_hpure_r_intro {H1 H2} {P : Prop} :
  (P → H1 ==> H2) →
  H1 ==> (\[P] \-* H2).
Proof. Admitted.

Lemma hstar_hwand {H1 H2 H3} :
  (H1 \-* H2) \* H3 ==> H1 \-* (H2 \* H3).
Proof. Admitted.

Arguments hstar_hwand : clear implicits.

(* ---------------------------------------------------------------------- *)
(* ** Properties of [qwand] *)

Lemma himpl_qwand_hstar_same_r {A} {Q : A → hprop} {H} :
  H ==> Q \--* (Q \*+ H).
Proof. Admitted.

Lemma himpl_qwand_r_inv {H A} {Q1 Q2 : A → hprop} :
  H ==> (Q1 \--* Q2) →
  (Q1 \*+ H) ===> Q2.
Proof. Admitted.

Lemma hstar_qwand {H A} {Q1 Q2 : A → hprop} :
  (Q1 \--* Q2) \* H ==> Q1 \--* (Q2 \*+ H).
Proof. Admitted.

Lemma qwand_cancel {A} {Q1 Q2 : A → hprop} :
  Q1 \*+ (Q1 \--* Q2) ===> Q2.
Proof. Admitted.

Lemma qwand_cancel_part {H A} {Q1 Q2 : A → hprop} :
  H \* ((Q1 \*+ H) \--* Q2) ==> (Q1 \--* Q2).
Proof. Admitted.

Lemma qwand_himpl {A} {Q1 Q1' Q2 Q2' : A → hprop} :
  Q1' ===> Q1 →
  Q2 ===> Q2' →
  (Q1 \--* Q2) ==> (Q1' \--* Q2').
Proof. Admitted.

Lemma qwand_himpl_l {A} {Q1 Q1' Q2 : A → hprop} :
  Q1' ===> Q1 →
  (Q1 \--* Q2) ==> (Q1' \--* Q2).
Proof. Admitted.

Lemma qwand_himpl_r {A} {Q1 Q2 Q2' : A → hprop} :
  Q2 ===> Q2' →
  (Q1 \--* Q2) ==> (Q1 \--* Q2').
Proof. Admitted.

(* ********************************************************************** *)
(* * Tactics for heap entailments *)

(* ---------------------------------------------------------------------- *)
(** Specific cleanup for formulaes *)

Ltac on_formula_pre cont :=
  match goal with
  | |- _ ?H ?Q => cont H
  | |- _ _ ?H ?Q => cont H
  | |- _ _ _ ?H ?Q => cont H
  | |- _ _ _ _ ?H ?Q => cont H
  | |- _ _ _ _ _ ?H ?Q => cont H
  | |- _ _ _ _ _ _ ?H ?Q => cont H
  | |- _ _ _ _ _ _ _ ?H ?Q => cont H
  | |- _ _ _ _ _ _ _ _ ?H ?Q => cont H
  | |- _ _ _ _ _ _ _ _ _ ?H ?Q => cont H
  | |- _ _ _ _ _ _ _ _ _ _ ?H ?Q => cont H
  end.

Ltac on_formula_post cont :=
  match goal with
  | |- _ ?H ?Q => cont Q
  | |- _ _ ?H ?Q => cont Q
  | |- _ _ _ ?H ?Q => cont Q
  | |- _ _ _ _ ?H ?Q => cont Q
  | |- _ _ _ _ _ ?H ?Q => cont Q
  | |- _ _ _ _ _ _ ?H ?Q => cont Q
  | |- _ _ _ _ _ _ _ ?H ?Q => cont Q
  | |- _ _ _ _ _ _ _ _ ?H ?Q => cont Q
  | |- _ _ _ _ _ _ _ _ _ ?H ?Q => cont Q
  | |- _ _ _ _ _ _ _ _ _ _ ?H ?Q => cont Q
  end.

(* Ltac remove_empty_heaps_formula tt := *)
(*   repeat (on_formula_pre ltac:(remove_empty_heaps_from)). *)

(* ---------------------------------------------------------------------- *)
(* ** Tactic [xsimplh] to prove [H h] from [H' h] *)

(** [xsimplh] applies to a goal of the form [H h].
   It looks up for an hypothesis of the form [H' h],
   where [H'] is a heap predicate (whose type is syntactically [hprop]).
   It then turns the goal into [H ==> H'], and calls [xsimpl].

   This tactic is very useful for establishing the soundness of
   Separation Logic derivation rules. It should never be used in
   the verification of concrete programs, since a heap [h] should
   never appear explicitly in such a proof, all the reasoning being
   conducted at the level of heap predicates. *)

(* Ltac xsimplh_core tt := *)
(*   match goal with N: ?H ?h |- _ ?h => *)
(*     match type of H with hprop => *)
(*     applys himpl_inv N; clear N; xsimpl *)
(*   end end. *)

(* Tactic Notation "xsimplh" := xsimplh_core tt. *)
(* Tactic Notation "xsimplh" "~" := xsimplh; auto_tilde. *)
(* Tactic Notation "xsimplh" "*" := xsimplh; auto_star. *)

(* ********************************************************************** *)
(** * Predicate [local] *)

(* ---------------------------------------------------------------------- *)
(* ** Definition of [local] *)

(** Type of characteristic formulae on values of type B *)

Notation "'~~' B + E" := (hprop → (B → hprop) → (E → Prop) → Prop)
  (at level 8, B at next level, E at next level, only parsing) : type_scope.

(** A formula [F] is mklocal (e.g. [F] could be the predicate SL [triple])
    if it is sufficient for establishing [F H Q] to establish that the
    the formula holds on a subheap, in the sense that [F H1 Q1] with
    [H = H1 \* H2] and [Q = Q1 \*+ H2]. *)

Definition local {B E} (F : ~~B+E) : Prop :=
  ∀ H Q Z,
    (H ==> \exists H1 H2 Q1, H1 \* H2 \*
             \[F H1 Q1 Z ∧ Q1 \*+ H2 ===> Q]) →
    F H Q Z.

(** [local_pred S] asserts that [local (S x)] holds for any [x].
    It is useful for describing loop invariants. *)

Definition local_pred {A B E} (S : A → ~~B+E) :=
  ∀ x, local (S x).

(* ---------------------------------------------------------------------- *)
(* ** Properties of [local] *)

(** Remark: for conciseness, we abbreviate names of lemmas,
    e.g. [local_inv_frame] is named [mklocal_conseq_frame]. *)

Section IsLocal.

Variables B E : Type.
Implicit Types (F : ~~B+E).

(** A introduction rule to establish [local], exposing the definition *)

Lemma local_intro {F} :
  (∀ H Q Z,
    (H ==> \exists H1 H2 Q1, H1 \* H2 \*
             \[F H1 Q1 Z ∧ Q1 \*+ H2 ===> Q]) →
    F H Q Z) →
  local F.
Proof. auto. Qed.

(** An elimination rule for [local] *)

Lemma local_elim {F H Q Z} :
  local F →
  (H ==> \exists H1 H2 Q1, H1 \* H2 \* \[F H1 Q1 Z ∧ Q1 \*+ H2 ===> Q]) →
  F H Q Z.
Proof. auto. Qed.

(** An elimination rule for [local] without [htop] *)

Lemma local_elim_frame {F H Q Z} :
  local F →
  (H ==> \exists H1 H2 Q1, H1 \* H2 \* \[F H1 Q1 Z ∧ Q1 \*+ H2 ===> Q]) →
  F H Q Z.
Proof. Admitted.

(** An elimination rule for [local] specialized for no frame, and no [htop] *)

Lemma local_elim_conseq_pre {F H Q Z} :
  local F →
  (H ==> \exists H1, H1 \* \[F H1 Q Z]) →
  F H Q Z.
Proof. Admitted.

(** Weaken and frame properties from [mklocal] *)

Lemma local_conseq_frame {H1 H2 Q1 F H Q Z} :
  local F →
  F H1 Q1 Z →
  H ==> H1 \* H2 →
  Q1 \*+ H2 ===> Q →
  F H Q Z.
Proof. Admitted.

(** Frame rule *)

Lemma local_frame {H2 Q1 Z H1 F} :
  local F →
  F H1 Q1 Z →
  F (H1 \* H2) (Q1 \*+ H2) Z.
Proof. Admitted.

(** Ramified frame rule *)

Lemma local_ramified_frame {Q1 H1 F H Q Z} :
  local F →
  F H1 Q1 Z →
  H ==> H1 \* (Q1 \--* Q) →
  F H Q Z.
Proof. Admitted.

(** Consequence rule *)

Lemma local_conseq {H' Q' F H Q Z} :
  local F →
  F H' Q' Z →
  H ==> H' →
  Q' ===> Q →
  F H Q Z.
Proof. Admitted.

(** Weakening on pre from [mklocal] *)

Lemma local_conseq_pre {H' F H Q Z} :
  local F →
  F H' Q Z →
  H ==> H' →
  F H Q Z.
Proof. Admitted.

(** Weakening on post from [mklocal] *)

Lemma local_conseq_post {Q' F H Q Z} :
  local F →
  F H Q' Z →
  Q' ===> Q →
  F H Q Z.
Proof. Admitted.

(** Extraction of pure facts from [mklocal] *)

Lemma local_hpure {F H P Q Z} :
  local F →
  (P → F H Q Z) →
  F (\[P] \* H) Q Z.
Proof. Admitted.

(** Extraction of existentials from [mklocal] *)

Lemma local_hexists {F A} {J : A → hprop} {Q Z} :
  local F →
  (∀ x, F (J x) Q Z) →
  F (hexists J) Q Z.
Proof. Admitted.

(** Extraction of existentials below a star from [mklocal] *)

Lemma local_hstar_hexists {F H A} {J : A → hprop} {Q Z} :
  local F →
  (∀ x, F ((J x) \* H) Q Z) →
   F (hexists J \* H) Q Z.
Proof. Admitted.

(** Extraction of forall from [mklocal] *)

Lemma local_hforall {A} {x : A} {F} {J : A → hprop} {Q Z} :
  local F →
  F (J x) Q Z →
  F (hforall J) Q Z.
Proof. Admitted.

Lemma local_hforall_exists {F A} {J : A → hprop} {Q Z} :
  local F →
  (exists x, F (J x) Q Z) →
  F (hforall J) Q Z.
Proof. Admitted.

(** Extraction of forall below a star from [mklocal] *)
(* --TODO needed? *)

Lemma local_hstar_hforall_l {F H A} {J : A → hprop} {Q Z} :
  local F →
  (exists x, F ((J x) \* H) Q Z) →
  F (hforall J \* H) Q Z.
Proof. Admitted.

(** Case analysis for [hor] *)

Lemma local_hor {F H1 H2 Q Z} :
  local F →
  F H1 Q Z →
  F H2 Q Z →
  F (hor H1 H2) Q Z.
Proof. Admitted.

(** Left branch for [hand] *)

Lemma local_hand_l {F H1 H2 Q Z} :
  local F →
  F H1 Q Z →
  F (hand H1 H2) Q Z.
Proof. Admitted.

(** Right branch for [hand] *)

Lemma local_hand_r {F H1 H2 Q Z} :
  local F →
  F H2 Q Z →
  F (hand H1 H2) Q Z.
Proof. Admitted.

(** Extraction of heap representation from [mklocal] *)

Lemma local_name_heap {F H Q Z} :
  local F →
  (∀ h, H h → F (λ h', h' = h) Q Z) →
  F H Q Z.
Proof. Admitted.

(** Extraction of pure facts from the precondition under local *)

Lemma local_prop {F H Q P Z} :
  local F →
  (H ==> H \* \[P]) →
  (P → F H Q Z) →
  F H Q Z.
Proof. Admitted.

(** Extraction of proof obligations from the precondition under local *)

Lemma local_hwand_hpure_l {F} {P : Prop} {H Q Z} :
  local F →
  P →
  F H Q Z →
  F (\[P] \-* H) Q Z.
Proof. Admitted.

End IsLocal.

#[global] Opaque local.

(** [xtpull] plays a similar role to [xpull], except that it works on
   goals of the form [F H Q], where [F] is typically a triple predicate
   or a characteristic formula.

   [xtpull] simplifies the precondition [H] as follows:
   - it removes empty heap predicates
   - it pulls pure facts out as hypotheses into the context
   - it pulls existentials as variables into the context.

   At the end, it regeneralizes in the goals the new variables
   from the context, so as to allow the user to introduce them
   by giving appropriate names. *)

(** Lemmas *)

Lemma xtpull_start {B E} {F : ~~B+E} {H Q Z} :
  F (\[] \* H) Q Z →
  F H Q Z.
Proof. Admitted.

Lemma xtpull_keep {B E} {F : ~~B+E} {H1 H2 H3 Q Z} :
  F ((H2 \* H1) \* H3) Q Z →
  F (H1 \* (H2 \* H3)) Q Z.
Proof. Admitted.

Lemma xtpull_assoc {B E} {F : ~~B+E} {H1 H2 H3 H4 Q Z} :
  F (H1 \* (H2 \* (H3 \* H4))) Q Z →
  F (H1 \* ((H2 \* H3) \* H4)) Q Z.
Proof. Admitted.

Lemma xtpull_starify {B E} {F : ~~B+E} {H1 H2 Q Z} :
  F (H1 \* (H2 \* \[])) Q Z →
  F (H1 \* H2) Q Z.
Proof. Admitted.

Lemma xtpull_empty {B E} {F : ~~B+E} {H1 H2 Q Z} :
  (F (H1 \* H2) Q Z) →
  F (H1 \* (\[] \* H2)) Q Z.
Proof. Admitted.

Lemma xtpull_hpure {B E} {F : ~~B+E} {H1 H2 P Q Z} :
  local F →
  (P → F (H1 \* H2) Q Z) →
  F (H1 \* (\[P] \* H2)) Q Z.
Proof. Admitted.

(* Lemma xtpull_id {A} {x X : A} {B E} {F : ~~B+E} {H1 H2 Q Z} : *)
(*   local F → *)
(*   (x = X → F (H1 \* H2) Q Z) → *)
(*   F (H1 \* (x ~> Id X \* H2)) Q Z. *)
(* Proof. Admitted. *)

Lemma xtpull_hexists {B E} {F : ~~B+E} {H1 H2 A} {J : A → hprop} {Q Z} :
  local F →
  (∀ x, F (H1 \* ((J x) \* H2)) Q Z) →
   F (H1 \* (hexists J \* H2)) Q Z.
Proof. Admitted.

(*--------------------------------------------------------*)
(* ** [xtchange] *)

(** [xtchange E] applies to a goal of the form [F H Q]
    and to a lemma [E] of type [H1 ==> H2] or [H1 = H2].
    It replaces the goal with [F H' Q], where [H']
    is computed by replacing [H1] with [H2] in [H].

    The substraction is computed by solving [H ==> H1 \* ?H']
    with [xsimpl]. If you need to solve this implication by hand,
    use [xtchange_no_simpl E] instead.

    [xtchange <- E] is useful when [E] has type [H2 = H1]
      instead of [H1 = H2].

    [xtchange_show E] is useful to visualize the instantiation
    of the lemma used to implement [xtchange].
    *)

(* Lemma used by [xtchange] *)

Lemma xtchange_lemma {H1 H1' H2 B E H Q Z} {F : ~~B+E} :
  local F →
  (H1 ==> H1') →
  (H ==> H1 \* H2) →
  F (H1' \* H2) Q Z →
  F H Q Z.
Proof. Admitted.

(* ********************************************************************** *)
(* * Iterated star *)

(* ---------------------------------------------------------------------- *)
(** Separation commutative monoid [(hstar,hempty)] *)

(* jww (2022-08-10): TODO: Semigroup, Monoid, Commutative Monoid *)
(* Definition sep_monoid := monoid_make hstar hempty. *)

(* ********************************************************************** *)
(* * Weakest-preconditions *)

(* ---------------------------------------------------------------------- *)
(* ** Definition of the weakest precondition for a formula *)

Definition weakestpre {B E : Type}
  (F : ~~ B+E) (Q : B → hprop) (Z : E → Prop) : hprop :=
  \exists (H:hprop), H \* \[F H Q Z].

Lemma weakestpre_eq {B E} {F : ~~B+E} {H Q Z} :
  local F → (* in fact, only requires weaken-pre and extract-hexists rules to hold *)
  F H Q Z = (H ==> weakestpre F Q Z).
Proof. Admitted.

Lemma weakestpre_conseq {B E} {F : ~~B+E} {Q1 Q2 Z} :
  local F →
  Q1 ===> Q2 →
  weakestpre F Q1 Z ==> weakestpre F Q2 Z.
Proof. Admitted.

Lemma weakestpre_conseq_wand {B E} {F : ~~B+E} {Q1 Q2 Z} :
  local F →
  (Q1 \--* Q2) \* weakestpre F Q1 Z ==> weakestpre F Q2 Z.
Proof. Admitted.

Lemma weakestpre_frame {B E} {F : ~~B+E} {H Q Z} :
  local F →
  (weakestpre F Q Z) \* H ==> weakestpre F (Q \*+ H) Z.
Proof. Admitted.

Lemma weakestpre_pre {B E} {F : ~~B+E} {Q Z} :
  local F →
  F (weakestpre F Q Z) Q Z.
Proof. Admitted.

Lemma himpl_weakestpre {B E} {F : ~~B+E} {H Q Z} :
  F H Q Z →
  H ==> weakestpre F Q Z.
Proof. Admitted.

End Hoare.

Require Import
  Pact.Lib
  Pact.Ltac
  Pact.Ty
  Pact.Exp
  Pact.Lang
  Pact.SemTy
  Pact.SemExp.

Section Sep.

Definition heap : Type := PactState.
Definition val  : Ty → Type := Φ.

Context `{HL : HoareLogic heap}.

Definition vprop τ : Type := val τ → hprop.
Definition eprop   : Type := Err → Prop.

Open Scope hoare_scope.

Definition eimpl (Z1 Z2 : Err → Prop) : Prop :=
  ∀ e : Err, Z1 e → Z2 e.

Infix "==!>" := eimpl (at level 55, right associativity) : hoare_scope.

Implicit Type h : heap.
Implicit Type H : hprop.
Implicit Type Z : eprop.
Implicit Type P : Prop.

Import ListNotations.

Definition hoare `(e : Exp SemTy τ) H Q Z : Prop :=
  ∀ h : heap, H h →
    match ⟦e⟧ h : Err + ⟦τ⟧ * heap with
    | inr (v, h') => Q v h'
    | inl err => Z err
    end.

Lemma hoare_conseq {τ} {t : Exp SemTy τ} {H' Q' H Q Z} :
  hoare t H' Q' Z ->
  H ==> H' ->
  Q' ===> Q ->
  hoare t H Q Z.
Proof. Admitted.

Lemma hoare_named_heap {τ} {t : Exp SemTy τ} {H Q Z} :
  (∀ h, H h -> hoare t (λ h', h' = h) Q Z) ->
  hoare t H Q Z.
Proof. Admitted.

(*
Lemma hoare_val : ∀ v H Q,
  H ==> Q v ->
  hoare (trm_val v) H Q.

Lemma hoare_fun : ∀ x t1 H Q,
  H ==> Q (val_fun x t1) ->
  hoare (trm_fun x t1) H Q.

Lemma hoare_let : ∀ z t1 t2 H Q Q1,
  hoare t1 H Q1 ->
  (∀ v, hoare (subst1 z v t2) (Q1 v) Q) ->
  hoare (trm_let z t1 t2) H Q.

Lemma hoare_seq : ∀ t1 t2 H Q H1,
  hoare t1 H (fun r => H1) ->
  hoare t2 H1 Q ->
  hoare (trm_seq t1 t2) H Q.

Lemma hoare_if : ∀ (b:bool) t1 t2 H Q,
  hoare (if b then t1 else t2) H Q ->
  hoare (trm_if b t1 t2) H Q.

Lemma hoare_if_trm : ∀ Q1 t0 t1 t2 H Q,
  hoare t0 H Q1 ->
  (∀ v, hoare (trm_if v t1 t2) (Q1 v) Q) ->
  hoare (trm_if t0 t1 t2) H Q.

Lemma hoare_apps_funs : ∀ xs F vs t1 H Q,
  F = (val_funs xs t1) ->
  var_funs xs (length vs) ->
  hoare (substn xs vs t1) H Q ->
  hoare (trm_apps F vs) H Q.
*)

Definition quadruple {τ} (t : Exp SemTy τ) (H : hprop) (Q : val τ → hprop) Z :=
  ∀ H', hoare t (H \* H') (Q \*+ H') Z.

(* jww (2022-08-10): TODO *)
(* Lemma local_quadruple {τ} (t : Exp SemTy τ) : *)
(*   local (quadruple t). *)

Lemma triple_of_hoare {τ} {t : Exp SemTy τ} {H Q Z} :
  (∀ H', exists Q', hoare t (H \* H') Q' Z ∧ Q' ===> Q \*+ H') →
  quadruple t H Q Z.
Proof. Admitted.

Lemma hoare_of_quadruple {τ} {t : Exp SemTy τ} {H Q Z HF} :
  quadruple t H Q Z →
  hoare t (H \* HF) (fun r => Q r \* HF) Z.
Proof. Admitted.

Lemma quadruple_conseq {τ} {t : Exp SemTy τ} {H' Q' H Q Z} :
  quadruple t H' Q' Z →
  H ==> H' →
  Q' ===> Q →
  quadruple t H Q Z.
Proof. Admitted.

Lemma quadruple_frame {τ} {t : Exp SemTy τ} {H Q Z H'} :
  quadruple t H Q Z →
  quadruple t (H \* H') (Q \*+ H') Z.
Proof. Admitted.

Lemma quadruple_ramified_frame {τ} {t : Exp SemTy τ} {H1 Q1 H Q Z} :
  quadruple t H1 Q1 Z →
  H ==> H1 \* (Q1 \--* Q) →
  quadruple t H Q Z.
Proof. Admitted.

Lemma quadruple_hexists {τ} {t : Exp SemTy τ} {A : Type} {J : A → hprop} {Q Z} :
  (∀ x, quadruple t (J x) Q Z) →
  quadruple t (hexists J) Q Z.
Proof. Admitted.

Lemma quadruple_hforall {A} {x : A} {τ} {t : Exp SemTy τ} {J : A → hprop} {Q Z} :
  quadruple t (J x) Q Z →
  quadruple t (hforall J) Q Z.
Proof. Admitted.

Lemma quadruple_hpure {τ} {t : Exp SemTy τ} {P : Prop} {H Q Z} :
  (P → quadruple t H Q Z) →
  quadruple t (\[P] \* H) Q Z.
Proof. Admitted.

Lemma quadruple_hwand_hpure_l {τ} {t : Exp SemTy τ} {P : Prop} {H Q Z} :
  P →
  quadruple t H Q Z →
  quadruple t (\[P] \-* H) Q Z.
Proof. Admitted.

Lemma quadruple_hor {τ} {t : Exp SemTy τ} {H1 H2 Q Z} :
  quadruple t H1 Q Z →
  quadruple t H2 Q Z →
  quadruple t (hor H1 H2) Q Z.
Proof. Admitted.

Lemma quadruple_hand_l {τ} {t : Exp SemTy τ} {H1 H2 Q Z} :
  quadruple t H1 Q Z →
  quadruple t (hand H1 H2) Q Z.
Proof. Admitted.

Lemma quadruple_hand_r {τ} {t : Exp SemTy τ} {H1 H2 Q Z} :
  quadruple t H2 Q Z →
  quadruple t (hand H1 H2) Q Z.
Proof. Admitted.

Lemma quadruple_conseq_frame {τ} {t : Exp SemTy τ} {H2 H1 Q1 H Q Z} :
  quadruple t H1 Q1 Z →
  H ==> H1 \* H2 →
  Q1 \*+ H2 ===> Q →
  quadruple t H Q Z.
Proof. Admitted.

(*
Lemma quadruple_val {v H Q Z} :
  H ==> Q v →
  quadruple (trm_val v) H Q.
Proof.
  introv M. intros HF. applys hoare_val. { xchanges M. }
Qed.

Lemma quadruple_let {z t1 t2 H Q Q1} :
  quadruple t1 H Q1 →
  (∀ (X:val), quadruple (subst1 z X t2) (Q1 X) Q) →
  quadruple (trm_let z t1 t2) H Q.
Proof.
  introv M1 M2. intros HF. applys hoare_let.
  { applys M1. }
  { intros v. applys* hoare_of_quadruple. }
Qed.

Lemma quadruple_seq {t1 t2 H Q Q1} :
  quadruple t1 H Q1 →
  (∀ (X:val), quadruple t2 (Q1 X) Q) →
  quadruple (trm_seq t1 t2) H Q.
Proof.
  introv M1 M2. applys* quadruple_let. (* BIND intros. rewrite* subst1_anon. *)
Qed.

Lemma quadruple_if {(b:bool) t1 t2 H Q Z} :
  quadruple (if b then t1 else t2) H Q →
  quadruple (trm_if b t1 t2) H Q.
Proof.
  introv M1. intros HF. applys hoare_if. applys M1.
Qed.

Lemma quadruple_if_bool {(b:bool) t1 t2 H Q Z} :
  (b = true → quadruple t1 H Q) →
  (b = false → quadruple t2 H Q) →
  quadruple (trm_if b t1 t2) H Q.
Proof.
  introv M1 M2. applys quadruple_if. case_if*.
Qed.

Lemma quadruple_if_trm {Q1 t0 t1 t2 H Q Z} :
  quadruple t0 H Q1 →
  (∀ v, quadruple (trm_if v t1 t2) (Q1 v) Q) →
  quadruple (trm_if t0 t1 t2) H Q.
Proof.
  introv M1 M2. intros HF. applys* hoare_if_trm.
  { intros v. applys* hoare_of_quadruple. }
Qed.

Lemma quadruple_if_trm' {Q1 t0 t1 t2 H Q, (* not very useful *)
  quadruple t0 H Q1 →
  (∀ (b:bool), quadruple (if b then t1 else t2) (Q1 b) Q) →
  (∀ v, ~ is_val_bool v → (Q1 v) ==> \[False]) →
  quadruple (trm_if t0 t1 t2) H Q.
Proof.
  introv M1 M2 M3. applys* quadruple_if_trm.
  { intros v. tests C: (is_val_bool v).
    { destruct C as (b&E). subst. applys* quadruple_if. }
    { xtchange* M3. xtpull ;=>. false. } }
Qed.

Lemma quadruple_apps_funs {xs F (Vs:vals) t1 H Q Z} :
  F = (val_funs xs t1) →
  var_funs xs (length Vs) →
  quadruple (substn xs Vs t1) H Q →
  quadruple (trm_apps F Vs) H Q.
Proof. introv E N M. intros HF. applys* hoare_apps_funs. Qed.
*)

Definition formula τ := (val τ → hprop) → eprop → hprop.

Definition wp `(t : Exp SemTy τ) : formula τ :=
  weakestpre (quadruple t).

Definition WP : Type := ∀ τ (t : Exp (Φ) τ), formula τ.

Definition formula' (B E : Type) := (B → hprop) → (E → Prop) → hprop.

Declare Scope pred_scope.
Open Scope pred_scope.

Notation "{{ H }} x ← e { Q | Z }" :=
  (hoare e H (λ x, Q) Z) (at level 1, e at next level) : pred_scope.

#[local] Hint Unfold hoare : core.

Theorem hoare_post_true H `(Q : vprop τ) Z e :
  (∀ v s, Q v s) →
  (∀ err, Z err) →
  {{H}} x ← e {Q x|Z}.
Proof.
  unfold hoare; sauto.
Qed.

Theorem hoare_pre_false H `(Q : vprop τ) Z e :
  (∀ s, ¬ (H s)) →
  {{H}} x ← e {Q x|Z}.
Proof.
  autounfold; intros.
  intuition.
Qed.

Ltac heaps :=
  repeat
    match goal with
    | [ H : (_ \* _) _  |- _ ] => destruct H
    | [ H : (\exists _, _) _  |- _ ] => destruct H
    | [ H : \[ _ ] _ |- _ ] => inversion H; subst; clear H
    end; reduce.

Theorem wp_equiv {H} `{e : Exp SemTy τ} {Q : vprop τ} {Z} :
  (H ==> wp e Q Z) ↔ (quadruple e H Q Z).
Proof.
  unfold himpl, wp, weakestpre, quadruple.
  split; repeat intro.
  - heaps.
    specialize (H0 _ H1).
    heaps.
    heaps.
    rewrite heap_compat_union_l_eq in H3; auto.
    reduce.
    rewrite heap_union_empty_r in H1.
    rewrite heap_union_empty_r.
    assert ((x1 \* H') (x2 \u x0))
      by now apply hstar_intro.
    unshelve epose proof (x _ _ H6); auto.
  - repeat eexists; eauto.
    apply heap_compat_empty_r.
    now rewrite heap_union_empty_r.
Qed.

Theorem wp_unique {wp1 wp2 : WP} :
  (∀ H τ (e : Exp SemTy τ) (Q : vprop τ) Z,
     quadruple e H Q Z ↔ H ==> wp1 _ e Q Z) →
  (∀ H τ (e : Exp SemTy τ) (Q : vprop τ) Z,
     quadruple e H Q Z ↔ H ==> wp2 _ e Q Z) →
  wp1 = wp2.
Proof.
  intros.
  extensionality τ.
  extensionality e.
  extensionality Q.
  extensionality Z.
  apply himpl_antisym.
  - destruct (H0 (wp1 τ e Q Z) τ e Q Z) as [H5 H6]; clear H0.
    apply H5; intros.
    apply H.
    reflexivity.
  - destruct (H (wp2 τ e Q Z) τ e Q Z) as [H5 H6]; clear H.
    apply H5; intros.
    apply H0.
    reflexivity.
Qed.

Theorem wp_from_weakest_pre (wp' : WP) :
  (∀ H τ (e : Exp SemTy τ) (Q : vprop τ) Z,
     quadruple e (wp' _ e Q Z) Q Z) →          (* wp_pre *)
  (∀ H τ (e : Exp SemTy τ) (Q : vprop τ) Z,
     quadruple e H Q Z → H ==> wp' _ e Q Z) → (* wp_weakest *)
  (∀ H τ (e : Exp SemTy τ) (Q : vprop τ) Z,
     H ==> wp' _ e Q Z ↔ quadruple e H Q Z).  (* wp_equiv *)
Proof.
  intros M1 M2.
  split; intro M.
  - eapply quadruple_conseq; eauto.
    reflexivity.
  - eapply M2; eauto.
Qed.

Notation "e =====> e'" :=
  (∀ Q Z, wp e Q Z ==> wp e' Q Z) (at level 100, e' at next level) : pred_scope.

Lemma eval_if_trm (t0 : Exp SemTy 𝔹) v0 {τ} (t1 t2 : Exp SemTy τ)
  (v : SemTy τ) s s' s'' :
  t0 ~[s => s']~> v0 →
  If (Lit (LitBool v0)) t1 t2 ~[s' => s'']~> v →
  If t0 t1 t2 ~[s => s'']~> v.
Proof.
  unfold eval.
  intros.
  simp SemExp in *; simpl in *; autounfold in *.
  now rewrite H.
Qed.

Lemma hoare_if H (b : Exp SemTy 𝔹) τ (t1 t2 : Exp SemTy τ)
  (Q' : vprop 𝔹) (Q : vprop τ) Z :
  hoare b H Q' Z →
  (∀ v, hoare (If (Lit (LitBool v)) t1 t2) (Q' v) Q Z) →
  hoare (If b t1 t2) H Q Z.
Proof.
  autounfold.
  repeat intro.
  simp SemExp in *; simpl in *; autounfold in *.
  specialize (H0 _ H2).
  destruct (⟦b⟧ _) eqn:Heqe; auto.
  reduce.
  specialize (H1 _ _ H0).
  simp SemExp in *; simpl in *; autounfold in *.
  exact H1.
Qed.

Lemma quadruple_if H (b : Exp SemTy 𝔹) τ (t1 t2 : Exp SemTy τ)
  (Q' : vprop 𝔹) (Q : vprop τ) Z :
  quadruple b H Q' Z →
  (∀ v, quadruple (If (Lit (LitBool v)) t1 t2) (Q' v) Q Z) →
  quadruple (If b t1 t2) H Q Z.
Proof.
  unfold quadruple.
  intros.
  eapply hoare_if; eauto.
  intros.
  apply H1.
Qed.

Ltac wp r H :=
  intros;
  eapply wp_equiv;
  eapply H; eauto;
  eapply wp_equiv;
  subst; reflexivity.

(* An if statement simply propagates the environment. *)
Corollary wp_if (b : Exp SemTy 𝔹) τ (t1 t2 : Exp SemTy τ) (Q : vprop τ) Z :
  wp b (λ v, wp (If (Lit (LitBool v)) t1 t2) Q Z) Z
    ==> wp (If b t1 t2) Q Z.
Proof.
  unfold wp.
  simpl.
  repeat intro.
  destruct H as [H [HH H0]].
  exists H.
Admitted.
(*
  split; auto.
  eapply quadruple_if; eauto; intros.
  simpl.
  unfold quadruple, hoare in *.
  intros.
  simpl in *.
  reduce.
  specialize (H0 _ _ (conj HH HH)).
  destruct (⟦b⟧ _);
  simp SemExp in *; simpl in *;
  unravel; reduce;
  exact (H3 _ _ (conj H1 H2)).
Qed.
*)

(*
Lemma quadruple_app_fun H `(v : Exp SemTy dom) x `(e : Exp [dom] cod)
  (Q : vprop cod) Z :
  (∀ s, v ~[ s => s ]~> x) →
  quadruple ⟦ (x, tt) ⊨ e ⟧ H Q Z →
  quadruple ⟦APP (LAM e) v⟧ H Q Z.
Proof.
  intros.
  repeat intro.
  specialize (H1 _ _ H2).
  simpl in *.
  erewrite sem_app_lam; eauto.
Qed.

Lemma wp_app_fun `(v : Exp SemTy dom) x `(e : Exp [dom] cod) :
  (∀ s, v ~[ s => s ]~> x) →
  ⟦ (x, tt) ⊨ e ⟧ =====> ⟦APP (LAM e) v⟧.
Proof. wp r quadruple_app_fun. Qed.
*)

(* This encodes a boolean predicate in positive normal form. *)
Inductive Pred : Ty → Set :=
  | P_True : Pred 𝔹
  | P_False : Pred 𝔹
  | P_Eq {τ} : Pred τ → Pred τ → Pred 𝔹
  | P_Or : Pred 𝔹 → Pred 𝔹 → Pred 𝔹
  | P_And : Pred 𝔹 → Pred 𝔹 → Pred 𝔹.

#[local] Hint Constructors Pred : core.

(*
Equations wpc `(e : Exp SemTy τ) {τ'}
  (Q : val τ → state → Pred τ') Z :
  state → Pred τ' :=
  wpc (Lit l) Q Z := Q (SemLit l);
  (* wpc (APP f v) Q Z := wp ⟦APP f v⟧ Q Z; *)
  wpc (Seq e1 e2) Q Z := wpc e1 (λ _, wpc e2 Q Z) Z;
  wpc (If b t e) Q Z :=
    wpc b (λ b', if b' then wpc t Q Z else wpc e Q Z) Z;
  wpc _ Q Z := _.
*)

(*
Equations wpc `(e : Exp SemTy τ) (Q : vprop τ) Z : hprop :=
  wpc (Lit l) Q Z := Q (SemLit l);
  wpc (APP f v) Q Z := wp ⟦APP f v⟧ Q Z;
  wpc (Seq e1 e2) Q Z := wpc e1 (λ _, wpc e2 Q Z) Z;
  wpc (If b t e) Q Z :=
    wpc b (λ b', if b' then wpc t Q Z else wpc e Q Z) Z;
  wpc _ Q Z := _.
*)

End Sep.


Require Import msl.msl_standard.
Require Import share_dec_base.
Require Import share_equation_system.
Require Import base_properties.
Require Import share_dec_interface.

Module Interpreter (sv : SV)
                   (Import es : EQUATION_SYSTEM sv with Module dom := Bool_Domain)
                   (Import bf : BOOL_FORMULA sv) <: INTERPRETER sv es bf.

 Module sys_features := System_Features sv es.
 Import sys_features.

 Class B2F (A B : Type):= Interpret {
  interpret : A -> B
 }.
 Implicit Arguments Interpret [A B].

 Definition v_int := fun (v : var) => varF v.
 Instance b2f_v : B2F _ _ := Interpret v_int.
 Definition b_int := fun b => valF b.
 Instance b2f_b : B2F _ _ := Interpret b_int.
 Definition obj_int := fun (obj : object) =>
  match obj with
  |Vobject v => varF v
  |Cobject c => valF c
  end.
 Instance b2f_obj : B2F _ _ := Interpret obj_int.
 Definition eql_int := fun (eql : equality) =>
  let (obj1,obj2) := eql in
  match (obj1,obj2) with
  |(Cobject c1, Cobject c2) => if bool_dec c1 c2 then valF true else valF false
  |(Vobject v, Cobject c)
  |(Cobject c, Vobject v) => if c then varF v else negF (varF v)
  |_ => orF (andF (interpret obj1) (interpret obj2))
            (andF (negF (interpret obj1)) (negF (interpret obj2)))
  end.
 Instance b2f_eql : B2F _ _ := Interpret eql_int.

 Definition eqn_int := fun (eqn : equation) =>
  match eqn with (obj1,obj2,obj3) =>
  match (obj1,obj2,obj3) with
  |(Cobject c1,Cobject c2, Cobject c3) => if c1 then valF (negb c2 && c3) else
                                           if bool_dec c2 c3 then valF true else valF false
  |(Vobject v1, Vobject v2, Cobject true) => orF (andF (varF v1) (negF (varF v2)))
                                                 (andF (varF v2) (negF (varF v1)))
  |(Vobject v1, Vobject v2, Cobject false) => andF (negF (varF v1)) (negF (varF v2))
  |(Vobject v1, Cobject true, Vobject v2)
  |(Cobject true, Vobject v1, Vobject v2) => andF (negF (varF v1)) (varF v2)
  |(Vobject v1, Cobject false, Vobject v2)
  |(Cobject false, Vobject v1, Vobject v2) => interpret (Vobject v1, Vobject v2)
  |(Vobject v, Cobject c1, Cobject c2)
  |(Cobject c1, Vobject v, Cobject c2) => if c1 then if c2 then negF (varF v) else valF false
                                          else interpret (Vobject v, Cobject c2)
  |(Cobject c1, Cobject c2, Vobject v) => if c1 then if c2 then valF false else varF v
                                          else interpret (Vobject v, Cobject c2)
  |_ => orF (andF (negF (interpret obj1)) (interpret (obj2,obj3)))
            (andF (interpret obj1) (andF (negF (interpret obj2)) (interpret obj3)))
  end
  end.
 Instance b2f_eqn : B2F _ _ := Interpret eqn_int.
 Definition list_int {A} `{@B2F A bF} :=
  fun (l : list A) => fold_right (fun a f => andF (interpret a) f) (valF true) l.
 Instance b2f_list {A} `{@B2F A bF} : B2F _ _:= Interpret list_int.

 Fixpoint fold_right_nodup {A B}(f : B -> A -> A) (a : A) (l : list B) `{EqDec B}:=
 match l with
 |nil => a
 |b::l' => match in_dec eq_dec b l' with
           |left _ => fold_right_nodup f a l'
           |right _ => f b (fold_right_nodup f a l')
           end

 end.

 Definition exF_quan := fun l f => fold_right_nodup exF f l.
 Definition allF_quan := fun l f => fold_right_nodup allF f l.

 Definition ses_int := fun (ses : sat_equation_system) =>
  let f1    := interpret (sat_nzvars ses) in
  let f2    := interpret (sat_equalities ses) in
  let f3    := interpret (sat_equations ses) in
   andF f1 (andF f2 f3).
 Instance b2f_ses : B2F _ _ := Interpret ses_int.

 Definition ies_int := fun (ies : impl_equation_system) =>
  let f1    := interpret (impl_nzvars ies) in
  let f2    := interpret (impl_equalities ies) in
  let f3    := interpret (impl_equations ies) in
   exF_quan (impl_exvars ies) (andF f1 (andF f2 f3)).
 Instance b2f_ies : B2F _ _ := Interpret ies_int.

 Definition is_int := fun (is : impl_system) =>
  let (ies1,ies2) := is in
  let f1 := interpret (ies1) in
  let f2 := interpret (ies2) in
   implF f1 f2.
 Instance b2f_is : B2F _ _ := Interpret is_int.

 Definition vars_interpret_spec (A : Type) `{@B2F A bF} `{varsable A var}:=
  forall a, sublist (vars (interpret a)) (vars a).
 Class vars_interpret_prop (A : Type) `{@B2F A bF} `{varsable A var} := Vars_interpret_prop {
  vars_int : vars_interpret_spec A
 }.

 Instance obj_int_vars : vars_interpret_prop object.
 Proof with try tauto.
  constructor.
  repeat intro. icase a...
 Qed.
 Instance var_vars : varsable var var.
 Proof.
  constructor. intro. apply (X::nil).
 Defined.
 Lemma vars_list_var: forall (l : list var),
  vars l = l.
 Proof with try tauto.
  induction l...
  simpl in *;congruence.
 Qed.
 Instance var_int_vars : vars_interpret_prop var.
 Proof with try tauto.
  constructor.
  repeat intro...
 Qed.
 Instance eql_int_vars : vars_interpret_prop equality.
 Proof with try tauto.
  constructor.
  repeat intro.
  destruct a as [obj1 obj2].
  icase obj1;icase obj2; try icase s0;try icase s1;simpl in *...
 Qed.
 Instance eqn_int_vars : vars_interpret_prop equation.
 Proof with try tauto.
  constructor.
  repeat intro.
  destruct a as [[obj1 obj2] obj3].
  icase obj1;icase obj2;icase obj3;
  try icase s0;try icase s1;try icase s2;simpl in *...
 Qed.
 Instance list_int_vars {A} `{vars_interpret_prop A} : vars_interpret_prop (list A).
 Proof with try tauto.
  constructor.
  induction a;repeat intro;
  simpl...
  repeat rewrite in_app_iff.
  generalize (vars_int a e);intro.
  simpl in H2. rewrite in_app_iff in H2.
  spec IHa e...
 Qed.

 Lemma exF_quan_vars: forall l f v,
  In v (vars (exF_quan l f)) <-> In v (l++vars f).
 Proof with try tauto.
  induction l;intros;unfold exF_quan in *.
  simpl... simpl.
  destruct (in_dec eq_dec a l);split;intros.
  apply IHl in H...
  destruct H;subst...
  apply IHl. rewrite in_app_iff...
  apply IHl...
  simpl in H. destruct H;subst...
  apply IHl in H...
  destruct H;subst...
  simpl...
  rewrite in_app_iff in H...
  destruct H; simpl.
  right. apply IHl. rewrite in_app_iff...
  right. apply IHl. rewrite in_app_iff...
 Qed.

 Lemma allF_quan_vars: forall l f v,
  In v (vars (allF_quan l f)) <-> In v (l++vars f).
 Proof with try tauto.
  induction l;intros;unfold allF_quan in *.
  simpl... simpl.
  destruct (in_dec eq_dec a l);split;intros.
  apply IHl in H...
  destruct H;subst...
  apply IHl. rewrite in_app_iff...
  apply IHl...
  simpl in H. destruct H;subst...
  apply IHl in H...
  destruct H;subst...
  simpl...
  rewrite in_app_iff in H...
  destruct H; simpl.
  right. apply IHl. rewrite in_app_iff...
  right. apply IHl. rewrite in_app_iff...
 Qed.

 Instance ses_int_vars : vars_interpret_prop sat_equation_system.
 Proof with try tauto.
  constructor.
  repeat intro.
  simpl in *.
  destruct a as [l1 l2 l3];simpl in *.
  repeat rewrite in_app_iff in *.
  generalize (vars_int l1 e);intro.
  generalize (vars_int l2 e);intro.
  generalize (vars_int l3 e);intro.
  assert (vars l1 = l1) by apply vars_list_var.
  simpl in *. unfold es.var,var in *.
  rewrite H3 in H0...
 Qed.

 Instance ies_int_vars : vars_interpret_prop impl_equation_system.
 Proof with try tauto.
  constructor.
  repeat intro.
  simpl in *.
  unfold ies_int in H;simpl in H.
  rewrite exF_quan_vars in H.
  destruct a as [l1 l2 l3 l4];simpl in *.
  unfold ies_int in H;simpl in H.
  repeat rewrite in_app_iff in *.
  generalize (vars_int l2 e);intro.
  generalize (vars_int l3 e);intro.
  generalize (vars_int l4 e);intro.
  assert (vars l2 = l2) by apply vars_list_var.
  unfold es.var,var in *.
  rewrite H3 in H0...
 Qed.

 Instance is_int_vars : vars_interpret_prop impl_system.
 Proof with try tauto.
  constructor.
  repeat intro.
  simpl in *.
  unfold is_int.
  destruct a as [ies1 ies2].
  simpl in *.
  repeat rewrite in_app_iff in *.
  generalize (vars_int ies1 e);intro.
  generalize (vars_int ies2 e);intro...
 Qed.

 Definition beval_interpret_spec (A : Type) `{@B2F A bF} `{evalable context A}:=
  forall a rho, rho |= a <-> beval rho (interpret a) = true.

 Class beval_interpret_prop (A : Type) `{@B2F A bF} `{evalable context A} := Beval_interpret_prop {
  beval_int : beval_interpret_spec A
 }.

 Instance v_int_prop : beval_interpret_prop var.
 Proof with (try tauto;try congruence).
  constructor. repeat intro. simpl.
  icase (rho a); split;repeat intro;disc...
 Qed.

 Lemma obj_beval: forall rho obj,
  beval rho (interpret obj) = get rho obj.
 Proof with try tauto.
  intros. icase obj...
 Qed.

 Instance eql_int_prop : beval_interpret_prop equality.
 Proof with firstorder.
  constructor. repeat intro.
  destruct a as [obj1 obj2].
  icase obj1;icase obj2;
  try icase s0;try icase s1; simpl;
  try icase (rho v); try icase (rho v0); simpl...
 Qed.

 Instance eqn_int_prop : beval_interpret_prop equation.
 Proof with firstorder.
  constructor. repeat intro.
  destruct a as [[obj1 obj2] obj3].
  icase obj1;icase obj2;icase obj3;
  try icase s0;try icase s1;try icase s2; simpl;
  try icase (rho v); try icase (rho v0); try icase (rho v1);simpl...
 Qed.

 Instance list_int_prop {A} `{beval_interpret_prop A} : beval_interpret_prop (list A).
 Proof with try tauto.
  constructor. induction a;intros.
  simpl...
  simpl.
  rewrite andb_true_iff.
  spec IHa rho.
  generalize (beval_int a rho);intro...
 Qed.

 Instance ses_int_prop : beval_interpret_prop sat_equation_system.
 Proof with try tauto.
  constructor. repeat intro.
  destruct a as [l1 l2 l3].
  simpl. unfold eval_sat_equation_system;simpl.
  repeat rewrite andb_true_iff.
  generalize (beval_int l1 rho);intro.
  generalize (beval_int l2 rho);intro.
  generalize (beval_int l3 rho);intro...
 Qed.

 (*To make life easier*)
 Lemma upd_id {A B} `{EqDec A}: forall (rho : A -> B) v b,
  rho v = b ->
  upd rho v b = rho.
 Proof with try tauto.
  repeat intro.
  subst. extensionality v'.
  destruct (eq_dec v v'). subst.
  apply upd_eq.
  apply upd_neq...
 Qed.

 Lemma upd_override_not_in {A B} `{EqDec A}: forall (rho rho': A -> B) v b l,
  ~In v l ->
  [l => upd rho' v b]rho = [l => rho']rho.
 Proof with try tauto.
  repeat intro.
  extensionality v'.
  destruct (in_dec eq_dec v' l).
  repeat rewrite override_in...
  rewrite upd_neq... intro;subst...
  repeat rewrite override_not_in...
 Qed.
 (*To make life easier*)

 Lemma exF_quan_beval: forall l f (rho:context),
  beval rho (exF_quan l f) = true <->
  exists rho', beval ([l => rho']rho) f = true.
 Proof with try tauto.
  induction l;intros;unfold exF_quan in *;simpl.
  split;intro. exists rho...
  destruct H...
  destruct (in_dec eq_dec a l).
  rewrite IHl.
  split;intros H; destruct H as [rho' H];exists rho'.
  rewrite upd_id... rewrite override_in...
  rewrite upd_id in H... rewrite override_in...
  simpl. rewrite orb_true_iff.
  generalize (IHl f (upd rho a true));intro.
  generalize (IHl f (upd rho a false));intro.
  split;intro.
  destruct H1.

  apply H in H1.
  destruct H1 as [rho' H1].
  exists (upd rho' a true).
  rewrite upd_eq.
  rewrite<- override_absorb_not_in...
  rewrite upd_override_not_in...

  apply H0 in H1.
  destruct H1 as [rho' H1].
  exists (upd rho' a false).
  rewrite upd_eq.
  rewrite<- override_absorb_not_in...
  rewrite upd_override_not_in...

  destruct H1 as [rho' H1].
  remember (rho' a) as b.
  symmetry in Heqb. destruct b.
  left. apply H. exists rho'.
  rewrite override_absorb_not_in...
  right. apply H0. exists rho'.
  rewrite override_absorb_not_in...
 Qed.

 Lemma allF_quan_beval: forall l f (rho:context),
  beval rho (allF_quan l f) = true <->
  forall rho', beval ([l => rho']rho) f = true.
 Proof with try tauto.
  induction l;intros;unfold allF_quan in *;simpl.
  split;intros...
  destruct (in_dec eq_dec a l).
  rewrite IHl.
  split;intros.
  rewrite upd_id...
  apply H...
  rewrite override_in...
  spec H rho'. rewrite upd_id in H...
  rewrite override_in...

  simpl.
  rewrite andb_true_iff.
  generalize (IHl f (upd rho a true));intro.
  generalize (IHl f (upd rho a false));intro.
  rewrite H. rewrite H0.
  split;intros.
  destruct H1 as [H1 H2].
  spec H1 rho'. spec H2 rho'.
  rewrite<- override_absorb_not_in...
  icase (rho' a).
  split;intros.
  spec H1 (upd rho' a true).
  rewrite<- override_absorb_not_in in H1...
  rewrite upd_eq in H1...
  rewrite upd_override_not_in in H1...
  spec H1 (upd rho' a false).
  rewrite<- override_absorb_not_in in H1...
  rewrite upd_eq in H1...
  rewrite upd_override_not_in in H1...
 Qed.

 Instance ies_int_prop : beval_interpret_prop impl_equation_system.
 Proof with try tauto.
  constructor. repeat intro.
  simpl.
  unfold eval_impl_equation_system,ies_int,e_eval.
  rewrite exF_quan_beval.
  destruct a as [l1 l2 l3 l4];simpl.
  unfold eval_sat_equation_system,ies2ses;simpl.
  generalize (beval_int l2);intro.
  generalize (beval_int l3);intro.
  generalize (beval_int l4);intro...
  split;intro H2;destruct H2 as [rho' H2];exists rho';
  spec H ([l1 =>rho']rho);
  spec H0 ([l1 =>rho']rho);
  spec H1 ([l1 =>rho']rho);
  repeat rewrite andb_true_iff in *...
 Qed.

 Lemma beval_implF_rewrite: forall rho f1 f2,
  beval rho (implF f1 f2) = negb (beval rho f1)|| (beval rho f2).
 Proof.
  intros. simpl.
  icase (beval rho f1);icase (beval rho f2).
 Qed.

 Instance is_int_prop : beval_interpret_prop impl_system.
 Proof with try tauto.
  constructor. repeat intro.
  destruct a as [ies1 ies2].
  unfold interpret,b2f_is,is_int.
  generalize (beval_int ies1 rho);intro.
  generalize (beval_int ies2 rho);intro.
  rewrite beval_implF_rewrite.
  icase (beval rho (interpret ies1));
  icase (beval rho (interpret ies2));simpl;
  split;repeat intro...
  apply H0. apply H1. apply H...
 Qed.

 Lemma exF_quan_In: forall l bf v,
  In v l ->
  not_free v (exF_quan l bf).
 Proof with try tauto.
  induction l;intros;unfold exF_quan in *. inv H.
  simpl.
  destruct (in_dec eq_dec a l).
  apply IHl... destruct H;subst...
  simpl. destruct (eq_dec v a)...
  destruct H;subst... apply IHl...
 Qed.

 Lemma exF_quan_In_iff: forall l bf v,
  not_free v (exF_quan l bf) <-> (In v l \/ not_free v bf).
 Proof with try tauto.
  induction l;intros;unfold exF_quan in *. simpl...
  simpl. destruct (in_dec eq_dec a l).
  rewrite IHl. split;intros...
  destruct H... destruct H;subst...
  simpl. destruct (eq_dec v a);subst...
  rewrite IHl. split;intros...
  destruct H... destruct H;subst...
 Qed.

 Lemma allF_quan_In: forall l bf v,
  In v l ->
  not_free v (allF_quan l bf).
 Proof with try tauto.
  induction l;intros;unfold allF_quan in *. inv H.
  simpl.
  destruct (in_dec eq_dec a l).
  apply IHl... destruct H;subst...
  simpl. destruct (eq_dec v a)...
  destruct H;subst... apply IHl...
 Qed.

 Lemma allF_quan_In_iff: forall l bf v,
  not_free v (allF_quan l bf) <-> (In v l \/ not_free v bf).
 Proof with try tauto.
  induction l;intros;unfold allF_quan in *. simpl...
  simpl. destruct (in_dec eq_dec a l).
  rewrite IHl. split;intros...
  destruct H... destruct H;subst...
  simpl. destruct (eq_dec v a);subst...
  rewrite IHl. split;intros...
  destruct H... destruct H;subst...
 Qed.

 Definition is_free (v : var) (ies : impl_equation_system) : bool :=
   if in_dec eq_dec v (impl_exvars ies) then false else true.

 Lemma is_free_In: forall v ies,
  is_free v ies = true <-> ~In v (impl_exvars ies).
 Proof with try tauto.
  intros. unfold is_free.
  destruct (in_dec eq_dec v (impl_exvars ies))...
  split;intros;disc...
 Qed.

 Definition in_not_free_spec (A : Type) `{@B2F A bF}:=
  forall a v, In v (vars (interpret a)) -> not_free v (interpret a) -> False .
 Class in_not_free_prop (A : Type) `{@B2F A bF} := In_not_free_prop {
  in_not_free : in_not_free_spec A
 }.

 Instance in_not_free_obj: in_not_free_prop object.
 Proof with try tauto.
  constructor. repeat intro.
  icase a... inv H; simpl in H0...
  destruct (eq_dec v v)...
 Qed.

 Instance in_not_free_eql: in_not_free_prop equality.
 Proof with try tauto.
  constructor. repeat intro.
  destruct a.
  icase o;icase o0;
  simpl in *;
  try destruct (eq_dec v v0);
  try destruct (eq_dec v v1);
  subst;
  try icase s0;
  try icase s1;
  subst;simpl in *;firstorder;
  try destruct (@eq_dec var sv.t_eq_dec v0 v0)...
 Qed.

 Instance in_not_free_eqn: in_not_free_prop equation.
 Proof with try tauto.
  constructor. repeat intro.
  destruct a as [[? ?] ?].
  icase o;icase o0;icase o1;
  simpl in *;
  try destruct (eq_dec v v0);
  try destruct (eq_dec v v1);
  try destruct (eq_dec v v2);
  subst;
  try icase s0;
  try icase s1;
  try icase s2;
  subst;simpl in *;firstorder;
  try destruct (@eq_dec var sv.t_eq_dec v0 v0);
  try destruct (@eq_dec var sv.t_eq_dec v1 v1);
  try destruct (@eq_dec var sv.t_eq_dec v2 v2)...
 Qed.

 Instance in_not_free_var: in_not_free_prop var.
 Proof with try tauto.
  constructor.
  repeat intro.
  inv H;simpl in *...
  destruct (eq_dec v v);subst...
 Qed.

 Instance in_not_free_list  {A} `{in_not_free_prop A} : in_not_free_prop (list A).
 Proof with try tauto.
  constructor.
  induction a;intros. inv H1.
  simpl in *. destruct H2.
  rewrite in_app_iff in H1.
  destruct H1.
  apply in_not_free in H2...
  apply IHa with (v:=v)...
 Qed.

 Lemma ies_is_free_equiv: forall v ies,
  In v (vars (interpret ies)) ->
  (is_free v ies = true <-> ~not_free v (interpret ies)).
 Proof with try tauto.
  intros.
  rewrite is_free_In.
  split;repeat intro.
  - apply H0.
    destruct ies as [l1 l2 l3 l4].
    simpl in *. unfold ies_int in H;simpl in H.
    rewrite exF_quan_vars in H.
    rewrite in_app_iff in H.
    destruct H...
    unfold ies_int in H1;simpl in H1.
    rewrite exF_quan_In_iff in H1.
    destruct H1...
    inv H1. inv H3.
    simpl in H.
    repeat rewrite in_app_iff in H.
    destruct H.
    generalize (in_not_free l2 v H H2)...
    destruct H.
    generalize (in_not_free l3 v H H1)...
    generalize (in_not_free l4 v H H4)...

  - apply H0.
    simpl. unfold ies_int.
    apply exF_quan_In...
 Qed.

 Require Import Classical.

 Lemma not_free_ies: forall v (ies : impl_equation_system),
  In v (vars (interpret ies)) ->
  (In v (impl_exvars ies) <-> not_free v (interpret ies)).
 Proof with try tauto.
  intros. apply ies_is_free_equiv in H.
  unfold is_free in *.
  unfold var,es.var in *.
  destruct (in_dec eq_dec v (impl_exvars ies))...
  split;intros...
  destruct (classic (not_free v (interpret ies)))...
  rewrite<- H in H1. inv H1.
 Qed.

End Interpreter.


(** * Bicolano: Semantic domains (interface implementation) *)
(* Hendra : - Modified to suit DEX program (Removed Operand Stack).
            - Removed Reference comparison.
            - Also trim the system to contain only Arithmetic *)

Require Export DEX_ImplemProgramWithMap.
Require Export DEX_Domain.

Ltac caseeq t := generalize (refl_equal t); pattern t at -1 in |- * ; case t.

(** All semantic domains and basic operation are encapsulated in a module signature *)

Module DEX_Dom <: DEX_SEMANTIC_DOMAIN.

 (** We depend on the choices done for program data structures *)
 Module DEX_Prog := DEX_ImplemProgramWithMap.DEX_Make.
 Import DEX_Prog.

Open Scope Z_scope.
 Module SByte <: Numeric.NUMSIZE. Definition power := 7%nat. End SByte.
 Module SShort<: Numeric.NUMSIZE. Definition power := 15%nat. End SShort.
 Module SInt  <: Numeric.NUMSIZE. Definition power := 31%nat. End SInt.

 Module Byte  : Numeric.NUMERIC with Definition power := 7%nat := Numeric.Make SByte.
 Module Short : Numeric.NUMERIC with Definition power := 15%nat := Numeric.Make SShort.
 Module Int   : Numeric.NUMERIC with Definition power := 31%nat := Numeric.Make SInt.

 (** conversion *)
 Definition b2i (b:Byte.t) : Int.t := Int.const (Byte.toZ b).
 Definition s2i (s:Short.t) : Int.t := Int.const (Short.toZ s).
 Definition i2b (i:Int.t) : Byte.t := Byte.const (Int.toZ i).
 Definition i2s (i:Int.t) : Short.t := Short.const (Int.toZ i).
 Definition i2bool (i:Int.t) : Byte.t := Byte.const (Int.toZ i mod 2).

 Inductive DEX_num : Set :=
   | I : Int.t -> DEX_num
   | B : Byte.t -> DEX_num
   | Sh : Short.t -> DEX_num.

 Inductive DEX_value : Set :=
   | Num : DEX_num -> DEX_value.

 Definition init_value (t:DEX_type) : DEX_value :=
    match t with
     | DEX_PrimitiveType _ => Num (I (Int.const 0))
    end.

 (** Domain of local variables *)
 Module Type DEX_REGISTERS.
   Parameter t : Type.
   Parameter get : t-> DEX_Reg -> option DEX_value.
   Parameter update : t -> DEX_Reg -> DEX_value -> t.
   Parameter dom : t -> list DEX_Reg.
   Parameter get_update_new : forall l x v, get (update l x v) x = Some v.
   Parameter get_update_old : forall l x y v,
     x<>y -> get (update l x v) y = get l y.
 End DEX_REGISTERS.

 Module DEX_MapReg <: MAP with Definition key := DEX_Reg := BinNatMap.

 Module DEX_Registers <: DEX_REGISTERS.
   Definition t := DEX_MapReg.t DEX_value.
   Definition get : t -> DEX_Reg -> option DEX_value := @DEX_MapReg.get DEX_value.
   Definition update : t -> DEX_Reg -> DEX_value -> t := @DEX_MapReg.update DEX_value.
   Definition dom : t -> list DEX_Reg := @DEX_MapReg.dom DEX_value.
   Lemma get_update_new : forall l x v, get (update l x v) x = Some v.
   Proof. exact (DEX_MapReg.get_update1 DEX_value). Qed.
   Lemma get_update_old : forall l x y v,
     x<>y -> get (update l x v) y = get l y.
   Proof.
    intros;refine (DEX_MapReg.get_update2 DEX_value _ _ _ _ _).
    intro;apply H;subst;trivial.
  Qed.
  Definition empty := DEX_MapReg.empty DEX_value.
 End DEX_Registers.

 Fixpoint listreg2regs_rec
    (l_ori:DEX_Registers.t) (n:nat) (lv:list DEX_Reg) (l:DEX_Registers.t) {struct n}: DEX_Registers.t :=
   match n with
   | O => l
   | S n =>
     match lv with
     | nil => l
     | h :: t =>
       match DEX_Registers.get l_ori h with
       | None =>
         listreg2regs_rec l_ori n t l
       | Some v =>
         listreg2regs_rec l_ori n t (DEX_Registers.update l (N_toReg n) v)
       end
     end
   end.
 Definition listreg2regs (l_ori:DEX_Registers.t) (n:nat) (lv:list DEX_Reg)
   := listreg2regs_rec l_ori n lv DEX_Registers.empty.

 Fixpoint all_super_classes (p:DEX_Program) (c:DEX_Class) (n:nat) {struct n} : option (list DEX_Class) :=
   match n with
     | O => None
     | S n =>
       match DEX_CLASS.superClass c with
         | None => Some nil
         | Some super_name =>
           match DEX_PROG.class p super_name with
             | None => None
             | Some super =>
               match (all_super_classes p super n) with
                 | None => None
                 | Some l => Some (super::l)
               end
           end
       end
   end.

 Ltac inv H := inversion H; subst; clear H.

 Lemma clos_refl_trans_ind2 :
      forall (A:Type) (R:A -> A -> Prop) (P:A -> A -> Prop),
        (forall x, P x x) ->
        (forall x y z:A, R x y -> clos_refl_trans A R y z -> P y z  -> P x z) ->
        forall x y, clos_refl_trans A R x y -> P x y.
 Proof.
   intros A R P H1 H2.
   assert (forall x y, clos_refl_trans A R x y ->
              forall z, clos_refl_trans A R y z -> P y z -> P x z).
   induction 1; eauto; intros.
   apply IHclos_refl_trans1.
   constructor 3 with z; auto.
   apply IHclos_refl_trans2; auto.
   intros.
   apply H with y; auto.
   constructor 2.
 Qed.

Lemma subclass_left : forall p c1 c2,
  subclass p c1 c2 -> c1=c2 \/ (exists c, direct_subclass p c1 c /\ subclass p c c2).
Proof.
  intros p; unfold subclass; apply clos_refl_trans_ind2; intros; auto.
  destruct H1; subst; auto.
  right; exists z; auto.
  destruct H1 as [c [T1 T2]].
  right; exists y; split; auto.
Qed.

 Definition all_super_classes_correct : forall p n c l,
   all_super_classes p c n = Some l ->
   DEX_PROG.defined_Class p c ->
   forall c', subclass p c c' -> In c' (c::l).
 Proof.
   induction n; simpl.
   intros; discriminate.
   intros c l; case_eq (DEX_CLASS.superClass c).
   intros c' H'.
   case_eq (DEX_PROG.class p c'); try (intros; discriminate).
   intros c'' H''.
   case_eq (all_super_classes p c'' n); try (intros; discriminate).
   intros.
   inv H0.
   destruct (subclass_left _ _ _ H2); auto.
   destruct H0 as [c0 [T1 T2]].
   clear H2.
   inv T1.
   unfold DEX_PROG.defined_Class in *.
   assert (c0 = c'') by congruence.
   assert (c'=DEX_CLASS.name c'') by congruence.
   subst.
   clear H2 H3 H1.
   right; apply (IHn _ _ H H'' _ T2).

   intros.
   destruct (subclass_left _ _ _ H2); auto.
   destruct H3 as [c0 [T1 T2]].
   inv T1.
   congruence.
 Qed.

 Fixpoint all_super_interfaces (p:DEX_Program) (n:nat) {struct n} :
                          DEX_Interface -> option (list DEX_Interface) :=
   match n with
     | O => fun _ => None
     | S n => fun c =>
       List.fold_left
         (fun o iname =>
           match o with
             | None => None
             | Some l =>
               match DEX_PROG.interface p iname with
                 | None => None
                 | Some itf =>
                   match all_super_interfaces p n itf with
                     | None => None
                     | Some l' => Some (itf::l++l')
                   end
               end
           end)
         (DEX_INTERFACE.superInterfaces c)
         (Some (c::nil))
   end.

Lemma subinterface_left : forall p c1 c2,
  subinterface p c1 c2 -> c1=c2 \/ (exists c, direct_subinterface p c1 c /\ subinterface p c c2).
Proof.
  intros p; unfold subinterface; apply clos_refl_trans_ind2; intros; auto.
  destruct H1; subst; auto.
  right; exists z; auto.
  destruct H1 as [c [T1 T2]].
  right; exists y; split; auto.
Qed.

Lemma all_super_interfaces_aux : forall p n l3,
   fold_left
     (fun (o : option (list DEX_Interface)) (iname : DEX_InterfaceName) =>
      match o with
      | Some l6 =>
             match DEX_PROG.interface p iname with
             | Some itf =>
                 match all_super_interfaces p n itf with
                 | Some l' => Some (itf :: l6 ++ l')
                 | None => None (A:=list DEX_Interface)
                 end
             | None => None (A:=list DEX_Interface)
             end
      | None => None (A:=list DEX_Interface)
      end) l3 None=None.
Proof.
  induction l3; simpl; auto.
Qed.

Lemma all_super_interfaces_aux' : forall p n l0 l1 l2,
     fold_left
        (fun (o : option (list DEX_Interface)) (iname : DEX_InterfaceName) =>
         match o with
         | Some l =>
             match DEX_PROG.interface p iname with
             | Some itf =>
                 match all_super_interfaces p n itf with
                 | Some l' => Some (itf :: l ++ l')
                 | None => None (A:=list DEX_Interface)
                 end
             | None => None (A:=list DEX_Interface)
             end
         | None => None (A:=list DEX_Interface)
         end) l0 (Some l1) = Some l2 -> incl l1 l2.
Proof.
  induction l0; simpl.
  intros.
  inversion H; subst; intro; auto.
  destruct (DEX_PROG.interface p a); try (intros; discriminate).
  destruct (all_super_interfaces p n d); try (intros; discriminate).
  intros.
  assert (IH:=IHl0 _ _ H); clear H IHl0.
  repeat intro; apply IH.
  right; auto with datatypes.
  rewrite all_super_interfaces_aux; intros; discriminate.
  rewrite all_super_interfaces_aux; intros; discriminate.
 Qed.

 Definition all_super_interfaces_correct : forall p n c l,
   all_super_interfaces p n c = Some l ->
   DEX_PROG.defined_Interface p c ->
   forall c', subinterface p c c' -> In c' (c::l).
 Proof.
   induction n; simpl.
   intros; discriminate.
   intros.
   destruct (subinterface_left _ _ _ H1); clear H1; auto.
   right; destruct H2 as [c0 [T1 T2]].
   inv T1.
   generalize dependent (Some (c::nil)).
   generalize dependent (DEX_INTERFACE.superInterfaces c).
   induction l0; simpl; intros.
   elim H3.
   destruct o; simpl in H; try discriminate.
   case_eq (DEX_PROG.interface p a); intros.
   rewrite H4 in H.
   case_eq (all_super_interfaces p n d); intros.
   rewrite H5 in H.
   destruct H3; subst.
   unfold DEX_PROG.defined_Interface in *.
   assert (c0=d) by congruence; clear H4; subst.
   generalize (IHn _ _ H5 H2 _ T2).
   assert (T:=all_super_interfaces_aux' _ _ _ _ _ H).
   simpl; intros.
   apply T.
   destruct H3.
   left; auto.
   right; auto with datatypes.
   apply IHl0 with (Some (d :: l1 ++ l2)); auto.
   rewrite H5 in H.
   rewrite all_super_interfaces_aux in H; discriminate.
   rewrite H4 in H.
   rewrite all_super_interfaces_aux in H; discriminate.
   rewrite all_super_interfaces_aux in H; discriminate.
 Qed.

  Definition all_interfaces (p:DEX_Program) (n:nat) (c:DEX_Class) : option (list DEX_Interface) :=
    List.fold_left
    (fun o iname =>
      match o with
        | None => None
        | Some l =>
          match DEX_PROG.interface p iname with
            | None => None
            | Some itf =>
              match all_super_interfaces p n itf with
                | None => None
                | Some l' => Some (itf::l++l')
              end
          end
      end)
    (DEX_CLASS.superInterfaces c)
    (Some nil).

  Lemma all_interfaces_correct : forall p n c l,
    all_interfaces p n c = Some l -> forall i I I',
      In i (DEX_CLASS.superInterfaces c) ->
      DEX_PROG.interface p i = Some I ->
      subinterface p I I' ->
      In I l.
  Proof.
    unfold all_interfaces.
    intros p n c.
    generalize (@nil DEX_Interface).
    generalize (DEX_CLASS.superInterfaces c).
    induction l; simpl.
    intuition.
    intros l0; case_eq (DEX_PROG.interface p a).
    intros i Hi; case_eq (all_super_interfaces p n i); intros.
    destruct H1; subst.
    assert (I0=i) by congruence; subst; clear Hi.
    apply (all_super_interfaces_aux' _ _ _ _ _ H0).
    left; reflexivity.
    eapply IHl ;eauto.
    rewrite all_super_interfaces_aux in H0; discriminate.
    intros.
    rewrite all_super_interfaces_aux in H0; intros; discriminate.
  Qed.

Set Implicit Arguments.

  Inductive DEX_ReturnVal : Set :=
   | Normal : option DEX_value -> DEX_ReturnVal.

 (** Domain of frames *)
 Module Type DEX_FRAME.
   Inductive t : Type :=
      make : DEX_Method -> DEX_PC -> DEX_Registers.t -> t.
 End DEX_FRAME.

 Module DEX_Frame.
   Inductive t : Type :=
      make : DEX_Method -> DEX_PC -> DEX_Registers.t -> t.
 End DEX_Frame.

 (** Domain of call stacks *)
 Module Type DEX_CALLSTACK.
   Definition t : Type := list DEX_Frame.t.
 End DEX_CALLSTACK.

 Module DEX_CallStack.
   Definition t : Type := list DEX_Frame.t.
 End DEX_CallStack.

 (** Domain of states *)
 Module Type DEX_STATE.
   Inductive t : Type :=
      normal : DEX_Frame.t -> DEX_CallStack.t -> t.
   Definition get_sf  (s:t) : DEX_CallStack.t :=
     match s with
       normal _ sf => sf
     end.
   Definition get_m (s:t) : DEX_Method :=
     match s with
       normal (DEX_Frame.make m _ _)_ => m
     end.
 End DEX_STATE.

 Module DEX_State.
  Inductive t : Type :=
      normal : DEX_Frame.t -> DEX_CallStack.t -> t.
   Definition get_sf (s:t) : DEX_CallStack.t :=
     match s with
       normal _ sf => sf
     end.
   Definition get_m (s:t) : DEX_Method :=
     match s with
       normal (DEX_Frame.make m _ _)_ => m
     end.
 End DEX_State.
 (** Some notations *)
 Notation St := DEX_State.normal.
 Notation Fr := DEX_Frame.make.

  (** compatibility between ValKind and value *)
  Inductive compat_ValKind_value : DEX_ValKind -> DEX_value -> Prop :=
    | compat_ValKind_value_int : forall n,
        compat_ValKind_value DEX_Ival (Num (I n)).

  (** [assign_compatible_num source target] holds if a numeric value [source] can be
    assigned to a variable of type [target]. This point is not clear in the JVM spec. *)
  Inductive assign_compatible_num : DEX_num -> DEX_primitiveType -> Prop :=
   | assign_compatible_int_int : forall i, assign_compatible_num (I i) DEX_INT
   | assign_compatible_short_int : forall sh, assign_compatible_num (Sh sh) DEX_INT
   | assign_compatible_byte_int : forall b, assign_compatible_num (B b) DEX_INT
   | assign_compatible_short_short : forall sh, assign_compatible_num (Sh sh) DEX_SHORT
   | assign_compatible_byte_byte : forall b, assign_compatible_num (B b) DEX_BYTE
   | assign_compatible_byte_boolean : forall b, assign_compatible_num (B b) DEX_BOOLEAN.

  (** [assign_compatible h source target] holds if a value [source] can be
    assigned to a variable of type [target] *)
  Inductive assign_compatible (p:DEX_Program) : DEX_value -> DEX_type -> Prop :=
   | assign_compatible_num_val : forall (n:DEX_num) (t:DEX_primitiveType),
       assign_compatible_num n t -> assign_compatible p (*h*) (Num n) (DEX_PrimitiveType t).

  Definition SemCompInt (cmp:DEX_CompInt) (z1 z2: Z) : Prop :=
    match cmp with
      DEX_EqInt =>  z1=z2
    | DEX_NeInt => z1<>z2
    | DEX_LtInt => z1<z2
    | DEX_LeInt => z1<=z2
    | DEX_GtInt => z1>z2
    | DEX_GeInt => z1>=z2
    end.

  Definition SemBinopInt (op:DEX_BinopInt) (i1 i2:Int.t) : Int.t :=
    match op with
    | DEX_AddInt => Int.add i1 i2
    | DEX_AndInt => Int.and i1 i2
    | DEX_DivInt => Int.div i1 i2
    | DEX_MulInt => Int.mul i1 i2
    | DEX_OrInt => Int.or i1 i2
    | DEX_RemInt => Int.rem i1 i2
    | DEX_ShlInt => Int.shl i1 i2
    | DEX_ShrInt => Int.shr i1 i2
    | DEX_SubInt => Int.sub i1 i2
    | DEX_UshrInt => Int.ushr i1 i2
    | DEX_XorInt => Int.xor i1 i2
    end.

End DEX_Dom.