notation:max "emp" => hempty

syntax "if " lang "then " lang "end " : lang

syntax " := " : bop

syntax "let" ident " := " lang " in" ppDedent(ppLine lang) : lang

syntax "fun" ident+ " => " lang : lang

syntax "⟨" term "⟩" : lang

syntax "⟨" term ":" term "⟩" : lang

notation:max "⌜" P "⌝" => hpure P

macro "h∀" xs:Lean.explicitBinders ", " b:term : term => Lean.expandExplicitBinders ``hforall xs b

macro "∃ʰ" xs:Lean.explicitBinders ", " b:term : term => Lean.expandExplicitBinders ``hexists xs b

macro_rules
  | `([lang| ()])                       => `(trm_val (val_unit))
  | `([lang| $n:num])                   => `(trm_val (val_int $n))
  | `([lang| $t1 $t2])                  => `(trm_app [lang| $t1] [lang| $t2])
  | `([lang| if $t1 then $t2 else $t3]) => `(trm_if [lang| $t1] [lang| $t2] [lang| $t3])
  | `([lang| if $t1 then $t2 end])      => `(trm_if [lang| $t1] [lang| $t2] (trm_val val_unit))
  | `([lang| let $x := $t1:lang in $t2:lang])     =>
    `(trm_let $(%x) [lang| $t1] [lang| $t2])
  | `([lang| ref $x := $t1:lang in $t2:lang])     =>
    `(trm_ref $(%x) [lang| $t1] [lang| $t2])
  | `([lang| alloc $t1:lang as $x in $t2:lang])   =>
    `(trm_alloc $(%x) [lang| $t1] [lang| $t2])
  | `([lang| $t1 ; $t2])                => `(trm_seq [lang| $t1] [lang| $t2])
  | `([lang| fun_ $xs* => $t])             => do
    let xs <- xs.mapM fun x => `(term| $(%x))
    `(trm_funs [ $xs,* ] [lang| $t])
  | `([lang| fun $xs* => $t])             => do
    let xs <- xs.mapM fun x => `(term| $(%x))
    `(val_funs [ $xs,* ] [lang| $t])
  | `([lang| fix_ $f $xs* => $t])    => do
      let xs <- xs.mapM fun x => `(term| $(%x))
      `(trm_fixs $(%f) [ $xs,* ] [lang| $t])
  | `([lang| fix $f $xs* => $t])    => do
      let xs <- xs.mapM fun x => `(term| $(%x))
      `(val_fixs $(%f) [ $xs,* ] [lang| $t])

  | `([lang| free $t])                  => `(trm_val (val_prim val_free) [lang| $t])
  | `([lang| not $t])                   => `(trm_val (val_prim val_not) [lang| $t])

  | `([lang| !$t])                      => `(trm_val val_get [lang| $t])
  | `([lang| $t1 := $t2])               => `(trm_val val_set [lang| $t1] [lang| $t2])
  | `([lang| $t1 + $t2])                => `(trm_val val_add [lang| $t1] [lang| $t2])
  | `([lang| $t1 * $t2])                => `(trm_val val_mul [lang| $t1] [lang| $t2])
  | `([lang| $t1 - $t2])                => `(trm_val val_sub [lang| $t1] [lang| $t2])
  | `([lang| $t1 / $t2])                => `(trm_val val_div [lang| $t1] [lang| $t2])
  | `([lang| $t1 < $t2])                => `(trm_val val_lt [lang| $t1] [lang| $t2])
  | `([lang| $t1 > $t2])                => `(trm_val val_gt [lang| $t1] [lang| $t2])
  | `([lang| $t1 <= $t2])               => `(trm_val val_le [lang| $t1] [lang| $t2])
  | `([lang| $t1 >= $t2])               => `(trm_val val_ge [lang| $t1] [lang| $t2])
  | `([lang| -$t])                      => `(trm_val val_opp [lang| $t])
  | `([lang| $t1 = $t2])                => `(trm_val val_eq [lang| $t1] [lang| $t2])
  | `([lang| $t1 != $t2])               => `(trm_val val_neq [lang| $t1] [lang| $t2])
  | `([lang| $t1 mod $t2])              => `(trm_val val_mod [lang| $t1] [lang| $t2])
  | `([lang| $t1 ++ $t2])               => `(trm_val val_ptr_add [lang| $t1] [lang| $t2])
  | `([lang| ($t)]) => `([lang| $t])
  | `([lang| ⟨$t : $tp⟩]) => `(trm_val (($t : $tp)))
  | `([lang| for $x in [$n1 : $n2] { $t } ]) =>
    `(trm_for $(%x) [lang| $n1] [lang| $n2] [lang| $t])
  | `([lang| while $c:lang { $t:lang } ]) =>
     `(trm_while [lang| $c] [lang| $t] )

macro_rules
  | `([lang| len $p])                => `(trm_val val_array_length [lang| $p])
  | `([lang| $arr[$i] ])              => `(trm_val val_array_get [lang| $arr] [lang| $i])

  | `([lang| $arr[$i] := $v])        => `(trm_app val_array_set [lang| $arr] [lang| $i] [lang| $v])
  | `([lang| mkarr $n:lang $v:lang]) => `(trm_val val_array_make [lang| $n] [lang| $v])

macro_rules | `($x ∗ $y)   => `(binop% HStar.hStar $x $y)

  inductive trm : Type where
    | trm_val   : val -> trm
    | trm_var   : var -> trm
    | trm_fun   : var -> trm -> trm
    | trm_fix   : var -> var -> trm -> trm
    | trm_app   : trm -> trm -> trm
    | trm_seq   : trm -> trm -> trm
    | trm_let   : var -> trm -> trm -> trm
    | trm_if    : trm -> trm -> trm -> trm
    | trm_for   : var -> trm -> trm -> trm -> trm
    | trm_while : trm -> trm -> trm
    | trm_ref   : var → trm → trm → trm
    | trm_alloc : var → trm → trm → trm

  inductive val : Type where
    | val_unit   : val
    | val_bool   : Bool → val
    | val_int    : Int → val
    | val_real   : ℝ → val
    | val_loc    : loc → val
    | val_prim   : prim → val
    | val_fun    : var -> trm -> val
    | val_fix    : var -> var -> trm -> val
    | val_uninit : val
    | val_error : val

prim

inductive prim where

  | val_get : prim
  | val_set : prim

  | val_neg : prim
  | val_opp : prim
  | val_eq : prim
  | val_add : prim
  | val_neq : prim
  | val_sub : prim
  | val_mul : prim
  | val_div : prim
  | val_mod : prim

  | val_le : prim
  | val_lt : prim
  | val_ge : prim
  | val_gt : prim
  | val_ptr_add : prim

var

abbrev var := String

loc

abbrev loc := Nat

hProp

def hProp := heap -> Prop

heap

abbrev heap := Heap.heap val

Heap.heap

abbrev Heap.heap (val : Type) := Finmap (λ _ : loc ↦ val)

eval

inductive eval : state → trm → (val → state → Prop) -> Prop where
  | eval_val : forall s v Q,
      Q v s ->
      eval s (trm_val v) Q
  | eval_fun : forall s x t1 Q,
      Q (val_fun x t1) s ->
      eval s (trm_fun x t1) Q
  | eval_fix : forall s f x t1 Q,
      Q (val_fix f x t1) s ->
      eval s (trm_fix f x t1) Q
  | eval_app_arg1 : forall s1 t1 t2 Q1 Q,
      ¬ trm_is_val t1 ->
      eval s1 t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> eval s2 (trm_app v1 t2) Q) ->
      eval s1 (trm_app t1 t2) Q
  | eval_app_arg2 : forall s1 (v1 : val) t2 Q1 Q,
      ¬ trm_is_val t2 ->
      eval s1 t2 Q1 ->
      (forall v2 s2, Q1 v2 s2 -> eval s2 (trm_app v1 v2) Q) ->
      eval s1 (trm_app v1 t2) Q
  | eval_app_fun : forall s1 v1 (v2 :val) x t1 Q,
      v1 = val_fun x t1 ->
      eval s1 (subst x v2 t1) Q ->
      eval s1 (trm_app v1 v2) Q
  | eval_app_fix : forall s (v1 v2 : val) f x t1 Q,
      v1 = val_fix f x t1 ->
      eval s (subst x v2 (subst f v1 t1)) Q ->
      eval s (trm_app v1 v2) Q
  | eval_seq : forall Q1 s t1 t2 Q,
      eval s t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> eval s2 t2 Q) ->
      eval s (trm_seq t1 t2) Q
  | eval_let : forall Q1 s x t1 t2 Q,
      eval s t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> eval s2 (subst x v1 t2) Q) ->
      eval s (trm_let x t1 t2) Q
  | eval_if : forall s (b : Bool) t1 t2 Q,
      eval s (if b then t1 else t2) Q ->
      eval s (trm_if (val_bool b) t1 t2) Q
  | eval_unop : forall op s v1 P Q,
      evalunop op v1 P ->
      purepostin s P Q ->
      eval s (trm_app op v1) Q
  | eval_binop : forall op s (v1 v2 : val) P Q,
      evalbinop op v1 v2 P ->
      purepostin s P Q ->
      eval s (trm_app (trm_app op v1) v2) Q
  | eval_ref : forall s x t1 t2 (Q Q₁ : val → state → Prop),
    eval s t1 Q₁ →
    (∀ v1 s1, Q₁ v1 s1 → ∀ p ∉ s1,
     eval (s1.insert p v1) (subst x p t2) fun v s ↦ Q v (s.erase p)) →
    eval s (trm_ref x t1 t2) Q
  | eval_get : forall s p Q,
      p ∈ s ->
      Q (read_state p s) s ->
      eval s (trm_app val_get (val_loc p)) Q
  | eval_set : forall s p v Q,
      v = trm_val v' ->
      p ∈ s ->
      Q val_unit (Finmap.insert p v' s) ->
      eval s (trm_app (trm_app val_set (val_loc p)) v) Q
  | eval_alloc_arg : forall s Q₁ Q,
    ¬ trm_is_val t1 →
    eval s t1 Q₁ →
    (∀ v' s', Q₁ v' s' → eval s' (trm_alloc x v' t2) Q) →
    eval s (trm_alloc x t1 t2) Q
  | eval_alloc : forall (sa : state) (n : ℤ) Q,
    n ≥ 0 →
    (∀ (p : loc) (sb : state),
      sb = conseq (make_list n.natAbs val_uninit) p →
      p ≠ null →
      Finmap.Disjoint sa sb →
      eval (sb ∪ sa) (subst x p t2) fun v s ↦ Q v (s \ sb)) →
    eval sa (trm_alloc x n t2) Q

  | eval_for (n₁ n₂ : Int) (Q : val -> state -> Prop) :
    eval s (if (n₁ < n₂) then
               (trm_seq (subst x n₁ t₁) (trm_for x (val_int (n₁ + 1)) n₂ t₁))
            else val_unit) Q ->
    eval s (trm_for x n₁ n₂ t₁) Q
  | eval_while (t₁ t₂ : trm) (Q : val -> state -> Prop) :
    eval s t₁ Q₁ ->
    (∀ s v, Q₁ v s -> eval s (trm_if v (trm_seq t₂ (trm_while t₁ t₂)) val_unit) Q) ->
    eval s (trm_while t₁ t₂) Q

HStar

class HStar (α : Type u) (β : Type v) (γ : outParam (Type w)) where

  hStar : α → β → γ

def make_list {A} (n : Nat) (v : A) : List A :=
  match n with
  | 0      => []
  | n' + 1 => v :: make_list n' v

hrange

def hrange (L : List val) (p : loc) : hProp :=
  match L with
  | []      => emp
  | x :: L' => (p ~~> x) ∗ (hrange L' (p + 1))

def wpgen_alloc (x : var) (t1 t2 : trm) : formula :=
  fun Q ↦ ∃ʰ n : ℤ,
    ⌜n ≥ 0 ∧ t1 = trm_val n⌝ ∗
    h∀ p,
      (hrange (make_list n.natAbs val_uninit) p) -∗
      protect wp (subst x p t2) (Q ∗ ⌜p ≠ null⌝ ∗ ∃ʰ L, ⌜L.length = n⌝ ∗ hrange L p)

wpgen

def wpgen (t : trm) : formula :=
  mkstruct (match t with
  | trm_val v          => wpgen_val v
  | trm_fun x t1       => wpgen_fun (fun v ↦ wp $ subst x v t1)
  | trm_fix f x t1     => wpgen_fix
      (fun vf v => wp $ subst x v $ subst f vf t1)
  | trm_if t0 t1 t2    => wpgen_if t0 (wp t1) (wp t2)
  | trm_seq t1 t2      => wpgen_seq (wp t1) (wp t2)
  | trm_let x t1 t2    => wpgen_let (wp t1) (fun v ↦ wp $ subst x v t2)
  | trm_app _ _        => wpgen_app t

  | trm_ref x t1 t2    => wpgen_ref x t1 t2
  | trm_alloc x t1 t2  => wpgen_alloc x t1 t2
  | _ => wp t
  )

hsingle

def hsingle (p : loc) (v : val) : hProp :=
  fun h => (h = Finmap.singleton p v)

evalExact

inductive evalExact : state → trm → (val → state → Prop) -> Prop where
  | val : forall s v,
      evalExact s (trm_val v) (fun v' s' ↦ v' = v ∧ s' = s)
  | fun : forall s x t1,
      evalExact s (trm_fun x t1) (fun v' s' ↦ v' = val_fun x t1 ∧ s' = s)
  | fix : forall s f x t1,
      evalExact s (trm_fix f x t1) (fun v' s' ↦ v' = val_fix f x t1 ∧ s' = s)
  | app_arg1 : forall s1 t1 t2 Q1 Q,
      ¬ trm_is_val t1 ->
      evalExact s1 t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> evalExact s2 (trm_app v1 t2) Q) ->
      evalExact s1 (trm_app t1 t2) Q
  | app_arg2 : forall s1 (v1 : val) t2 Q1 Q,
      ¬ trm_is_val t2 ->
      evalExact s1 t2 Q1 ->
      (forall v2 s2, Q1 v2 s2 -> evalExact s2 (trm_app v1 v2) Q) ->
      evalExact s1 (trm_app v1 t2) Q
  | app_fun : forall s1 v1 (v2 :val) x t1 Q,
      v1 = val_fun x t1 ->
      evalExact s1 (subst x v2 t1) Q ->
      evalExact s1 (trm_app v1 v2) Q
  | app_fix : forall s (v1 v2 : val) f x t1 Q,
      v1 = val_fix f x t1 ->
      evalExact s (subst x v2 (subst f v1 t1)) Q ->
      evalExact s (trm_app v1 v2) Q
  | seq : forall Q1 s t1 t2 Q,
      evalExact s t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> evalExact s2 t2 Q) ->
      evalExact s (trm_seq t1 t2) Q
  | let : forall Q1 s x t1 t2 Q,
      evalExact s t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> evalExact s2 (subst x v1 t2) Q) ->
      evalExact s (trm_let x t1 t2) Q
  | if : forall s (b : Bool) t1 t2 Q,
      evalExact s (if b then t1 else t2) Q ->
      evalExact s (trm_if (val_bool b) t1 t2) Q
  | unop : forall op s v1 P,
      evalunop op v1 P ->
      evalExact s (trm_app op v1) (purepost s P)
  | binop : forall op s (v1 v2 : val) P,
      evalbinop op v1 v2 P ->
      evalExact s (trm_app (trm_app op v1) v2) (purepost s P)
  | ref : forall s x t1 t2 Q Q₁,
    evalExact s t1 Q₁ →
    (∀ v1 s1, Q₁ v1 s1 → ∀ p ∉ s1,
     evalExact (s1.insert p v1) (subst x p t2) fun v s ↦ Q v (s.erase p)) →
      evalExact s (trm_ref x t1 t2) Q
  | get : forall s p,
      p ∈ s ->
      evalExact s (trm_app val_get (val_loc p))
        (fun v' s' ↦ v' = read_state p s ∧ s' = s)
  | set : forall s p v,
      v = trm_val v' ->
      p ∈ s ->
      evalExact s (trm_app (trm_app val_set (val_loc p)) v)
        (fun v'' s' ↦ v'' = val_unit ∧ s' = s.insert p v')
  | alloc_arg : forall s Q₁ Q,
    ¬ trm_is_val t1 →
    evalExact s t1 Q₁ →
    (∀ v' s', Q₁ v' s' → evalExact s' (trm_alloc x v' t2) Q) →
    evalExact s (trm_alloc x t1 t2) Q
  | alloc : forall (sa : state) (n : ℤ) Q,
    n ≥ 0 →
    (∀ (p : loc) (sb : state),
      sb = conseq (make_list n.natAbs val_uninit) p →
      p ≠ null →
      Finmap.Disjoint sa sb →
      evalExact (sb ∪ sa) (subst x p t2) fun v s ↦ Q v (s \ sb)) →
    evalExact sa (trm_alloc x n t2) Q

  | for (n₁ n₂ : Int) (Q : val -> state -> Prop) :
    evalExact s (if (n₁ < n₂) then
               (trm_seq (subst x n₁ t₁) (trm_for x (val_int (n₁ + 1)) n₂ t₁))
            else val_unit) Q ->
    evalExact s (trm_for x n₁ n₂ t₁) Q
  | while (t₁ t₂ : trm) (Q Q₁ : val -> state -> Prop) :
    evalExact s t₁ Q₁ ->
    (∀ s v, Q₁ v s -> evalExact s (trm_if v (trm_seq t₂ (trm_while t₁ t₂)) val_unit) Q) ->
    evalExact s (trm_while t₁ t₂) Q

hempty

def hempty : hProp :=
  fun h => (h = ∅)

subst

def subst (y : var) (v' : val) (t : trm) : trm :=

  let if_y_eq x t1 t2 := if x = y then t1 else t2
  match t with
  | trm_val v          => trm_val v
  | trm_var x          => if_y_eq x (trm_val v') t
  | trm_fun x t1       => trm_fun x (if_y_eq x t1 (subst y v' t1))
  | trm_fix f x t1     => trm_fix f x (if_y_eq f t1 (if_y_eq x t1 (subst y v' t1)))
  | trm_app t1 t2      => trm_app (subst y v' t1) (subst y v' t2)
  | trm_seq t1 t2      => trm_seq (subst y v' t1) (subst y v' t2)
  | trm_let x t1 t2    => trm_let x (subst y v' t1) (if_y_eq x t2 (subst y v' t2))
  | trm_if t0 t1 t2    => trm_if (subst y v' t0) (subst y v' t1) (subst y v' t2)
  | trm_for x t1 t2 t3 => trm_for x (subst y v' t1) (subst y v' t2) (if_y_eq x t3 (subst y v' t3))
  | trm_while t1 t2    => trm_while (subst y v' t1) (subst y v' t2)
  | trm_ref x t1 t2    => trm_ref x (subst y v' t1) (if_y_eq x t2 (subst y v' t2))
  | trm_alloc x t1 t2  => trm_alloc x (subst y v' t1) (if_y_eq x t2 (subst y v' t2))

def null : loc := 0

HWand

class HWand (α : Type u) (β : Type v) (γ : outParam (Type w)) where

  hWand : α → β → γ

hpure

def hpure (P : Prop) : hProp :=
  hexists (fun (_ : P) => emp)

hexists

def hexists {A} (J : A → hProp) : hProp :=
  fun h => exists x, J x h

himpl

abbrev himpl (H1 H2 : hProp) : Prop :=
  forall h, H1 h -> H2 h

conseq

def conseq {B : Type} (vs : List B) (l : Nat) : Finmap (fun _ : Nat ↦ B) :=
  match vs with
  | [] => ∅
  | v :: vs' => (Finmap.singleton l v) ∪ (conseq vs' (l + 1))

purepostin

def purepostin (s : state) (P : val → Prop) (Q : val → state → Prop) : Prop :=

  forall v, P v → Q v s

state

abbrev state := Finmap (λ _ : loc ↦ val)

qimpl

def qimpl {A} (Q1 Q2 : A → hProp) : Prop :=
  forall (v:A), Q1 v ==> Q2 v

hforall

def hforall {A} (J : A → hProp) : hProp :=
  fun h => forall x, J x h

infixr:51 " ==> " => himpl

infixr:51 " ===> " => qimpl

notation:max "emp" => hempty

infixr:60 " ~~> " => hsingle

infixr:55 " ∗ " => HStar.hStar

notation:max "⌜" P "⌝" => hpure P

infixr:55 " -∗ " => HWand.hWand

fun

notation "funloc" p "↦" H =>
  fun (r : val) ↦ hexists (fun p ↦ ⌜r = val_loc p⌝ ∗ H)

lemma eval_conseq s t Q1 Q2 :
  eval s t Q1 →
  Q1 ===> Q2 →
  eval s t Q2

lemma hpure_inv P h :
  ⌜P⌝ h →
  P ∧ h = ∅

lemma hwand_inv h1 h2 H1 H2 :
  (H1 -∗ H2) h2 →
  H1 h1 →
  Finmap.Disjoint h1 h2 →
  H2 (h1 ∪ h2)

lemma hrange_eq_conseq (L : List val) (n : ℤ) (p : loc) (s : state) :
  L.length = n →
  hrange L p s →
  s.keys = (conseq (make_list n.natAbs val_uninit) p).keys

lemma hseg_eq_hrange L p (k : Nat) :
  hseg L p k = hrange L (p + 1 + k)

lemma hrange_intro L p :
  (hrange L p) (conseq L p)

lemma int_eq_sub (l m n : ℤ) :
  l + m = n → l = n - m

lemma list_inc_natabs {α : Type} (L : List α) :
  ((L.length : ℤ) + 1).natAbs = (L.length : ℤ).natAbs + 1

lemma nonneg_eq_abs (n : Int) :
  0 ≤ n → n.natAbs = n

lemma neg_mul_abs (n : Int) :
  n < 0 → -1 * n = n.natAbs

lemma triple_abs (i : Int) :
  triple [lang| val_abs i]
    emp
    (fun r ↦ ⌜r = val_int i.natAbs⌝)

lemma add_Int.natAbs i j :
  0 <= i - j → j + Int.natAbs (i - j) = i

lemma hseg_focus (i j : Int) L p (v : 0 <= i - j ∧ i - j < L.length) :
  0 <= i - j ∧ i - j < L.length →
  hseg L p j ==>
  hcell L[(i - j).natAbs]! p i
    ∗ (h∀ w, hcell w p i -∗ hseg (L.set (i - j).natAbs w) p j)

lemma harray_focus i L p (v : 0 <= i ∧ i < L.length) :
  0 <= i ∧ i < L.length →
  harray L p ==>
  hcell L[Int.natAbs i]! p i
    ∗ (h∀ w, hcell w p i -∗ harray (L.set (Int.natAbs i) w) p)

lemma natabs_eq (a : Nat) :
  a = (Int.ofNat a).natAbs

lemma set_nth_same (A : Type) (IA : Inhabited A) (n : Nat) (l : List A) :
  n < l.length → l.set n l[n]! = l

lemma harray_focus_read i L p :
  0 <= i ∧ i < L.length →
  harray L p ==>
  hcell L[Int.natAbs i]! p i ∗ (hcell L[Int.natAbs i]! p i -∗ harray L p)

lemma hforall_inv A (J : A → hProp) h :
  (hforall J) h → forall x, J x h

lemma hexists_inv A (J : A → hProp) h :
  (hexists J) h → exists x, J x h

lemma diff_disjoint_eq (s₁ s₂ s₃ : state) :
  s₁.Disjoint s₂ →
  s₂.keys = s₃.keys →
  (s₁ ∪ s₂) \ s₃  = s₁

lemma lookup_diff (h₁ h₂ : state) :
  p ∉ h₂ →
  (h₁ \ h₂).lookup p = h₁.lookup p

lemma lookup_diff_none (h₁ h₂ : state) :
  p ∈ h₂ →
  (h₁ \ h₂).lookup p = none

theorem diff_non_mem (h₁ h₂ : state) :
  p ∈ h₂ → p ∉ h₁ \ h₂

triple

abbrev triple (t : trm) (H : hProp) (Q : val → hProp) : Prop :=
  forall s, H s → eval s t Q

lemma triple_alloc (n : Int) :
  n ≥ 0 →
  (∀ (p : loc), triple (subst x p t)
    (H ∗ ⌜p ≠ null⌝ ∗ hrange (make_list n.natAbs val_uninit) p)
    (Q ∗ ⌜p ≠ null⌝  ∗ ∃ʰ L, ⌜L.length = n⌝ ∗ hrange L p) ) →
  triple (trm_alloc x n t) H Q

lemma hstar_comm H1 H2 :
  H1 ∗ H2 = H2 ∗ H1

lemma hstar_assoc H1 H2 H3 :
  (H1 ∗ H2) ∗ H3 = H1 ∗ (H2 ∗ H3)

lemma hstar_comm_assoc (H1 H2 H3 : hProp) :
  H1 ∗ H2 ∗ H3 = H2 ∗ H1 ∗ H3

lemma hwand_cancel H1 H2 :
  H1 ∗ (H1 -∗ H2) ==> H2

lemma himpl_trans H2 H1 H3 :
  (H1 ==> H2) → (H2 ==> H3) → (H1 ==> H3)

lemma himpl_hstar_hpure_l P H H' :
  (P → H ==> H') →
  (⌜P⌝ ∗ H) ==> H'

lemma hforall_specialize A (x : A) (J : A → hProp) :
  (hforall J) ==> (J x)

lemma himpl_frame_r H1 H2 H2' :
  H2 ==> H2' →
  (H1 ∗ H2) ==> (H1 ∗ H2')

lemma finite_state' n (s : state) :
  ∃ p, p ≠ null ∧
    Finmap.Disjoint s (conseq (make_list n val_uninit) p)

lemma conseq_nil B (l : Nat) :
  conseq ([] : List B) l = ∅

lemma conseq_cons B (l : Nat) (v : B) (vs : List B) :
  conseq (v :: vs) l = (Finmap.singleton l v) ∪ (conseq vs (l + 1))

lemma disjoint_single_conseq B l l' L (v : B) :
  (l < l') ∨ (l ≥ l' + L.length) →
  Finmap.Disjoint (Finmap.singleton l v) (conseq L l')

lemma union_difference_id (h₁ h₂ : state) :
  h₁.Disjoint h₂ →
  (h₁ ∪ h₂) \ h₂ = h₁

lemma hstar_hempty_l H :
  emp ∗ H = H

lemma hstar_hempty_r H :
  H ∗ emp = H

lemma himpl_refl H : H ==> H

lemma hstar_intro (H1 H2 : hProp) h1 h2 :
  H1 h1 →
  H2 h2 →
  Finmap.Disjoint h1 h2 →
  (H1 ∗ H2) (h1 ∪ h2)

lemma hstar_inv (H1 H2 : hProp) h:
  (H1 ∗ H2) h →
  exists h1 h2, H1 h1 ∧ H2 h2 ∧ Finmap.Disjoint h1 h2 ∧ h = h1 ∪ h2

lemma qstar_simp (Q1 : α -> hProp) :
  (Q1 ∗ H) x = Q1 x ∗ H

lemma himpl_hexists_l A H (J : A → hProp) :
  (forall x, J x ==> H) → (hexists J) ==> H

lemma himpl_hexists_r A (x : A) H (J : A → hProp) :
  (H ==> J x) →
  H ==> (hexists J)

lemma triple_conseq t H' Q' H Q :
  triple t H' Q' →
  H ==> H'→
  Q' ===> Q →
  triple t H Q

lemma triple_frame t H (Q : val -> hProp) H' :
  triple t H Q →
  triple t (H ∗ H') (Q ∗ H')

lemma triple_hpure t P H Q :
  (P → triple t H Q) →
  triple t (⌜P⌝ ∗ H) Q

lemma triple_hexists t A (J : A → hProp) Q :
  (forall x, triple t (J x) Q) →
  triple t (hexists J) Q

lemma hwand_equiv H0 H1 H2 :
  (H0 ==> H1 -∗ H2) ↔ (H1 ∗ H0 ==> H2)

lemma himpl_hwand_r H1 H2 H3 :
  H2 ∗ H1 ==> H3 →
  H1 ==> (H2 -∗ H3)

lemma himpl_hwand_r_inv H1 H2 H3 :
  H1 ==> (H2 -∗ H3) →
  H2 ∗ H1 ==> H3

lemma hwand_hempty_l H :
  (emp -∗ H) = H

lemma himpl_hforall_r A (J : A → hProp) H :
  (forall x, H ==> J x) →
  H ==> (hforall J)

lemma himpl_hforall_l A (x : A) (J : A → hProp) H :
  (J x ==> H) →
  (hforall J) ==> H

Theories.wp

def wp (t : trm) (Q : val → hProp) : hProp :=
  fun s ↦ eval s t Q

lemma mem_conseq :
  x ∈ conseq L p → p ≤ x

lemma hrange_of_conseq :
  (hrange L p) (conseq L p)

import Lean

import Mathlib.Data.Finmap

import Mathlib.Data.List.Indexes

import SPLean.Common.State

import SPLean.Common.Util

import SPLean.Theories.HProp

import SPLean.Theories.XSimp

import SPLean.Theories.XChange

import SPLean.Theories.SepLog

import SPLean.Theories.WPUtil

open trm val prim

namespace Theories

def wp (t : trm) (Q : val → hProp) : hProp :=
  fun s ↦ eval s t Q

lemma wp_alloc x (n : ℤ) t Q :
  n ≥ 0 →
  (h∀ p, (hrange (make_list n.natAbs val_uninit) p) -∗
    wp (subst x p t) (Q ∗ ⌜p ≠ null⌝ ∗ ∃ʰ L, ⌜L.length = n⌝ ∗ hrange L p)) ==>
  wp (trm_alloc x n t) Q :=

:=
by
  move=> ? h /hforall_inv hwp
  apply eval.eval_alloc=> // > *
  apply (eval_conseq _ _ (Q ∗ ⌜p ≠ null⌝ ∗ ∃ʰ L, ⌜↑L.length = n⌝ ∗ hrange L p))
  { move: (hwp p)=> /(hwand_inv sb)
    srw Finmap.Disjoint.symm_iff=> {}hwp
    apply hwp=> // ; subst sb
    apply hrange_of_conseq }
  move=> > s ![>] ? ![>] /hpure_inv [_ ->] /==
  move=> /hexists_inv [L] ![>] /hpure_inv [? ->] /== ? _ -> _ -> ? ->
  srw diff_disjoint_eq=> // ; subst sb
  sby apply hrange_eq_conseq


import SPLean.Theories.XChange
import Mathlib.Data.List.Indexes
import SPLean.Theories.XSimp
import SPLean.Theories.SepLog
import Mathlib.Data.Finmap
import SPLean.Common.State
import SPLean.Theories.HProp
import SPLean.Common.Util
import Lean
import SPLean.Theories.WPUtil

syntax "if " lang "then " lang "end " : lang

syntax " := " : bop

syntax "let" ident " := " lang " in" ppDedent(ppLine lang) : lang

syntax "fun" ident+ " => " lang : lang

syntax "⟨" term "⟩" : lang

syntax "⟨" term ":" term "⟩" : lang

macro "xsimp" : tactic =>

macro "xsimp" : tactic =>
  `(tactic| (
    xsimp_start
    repeat xsimp_step
    try rev_pure
    try hide_mvars
    try hsimp
    rotate_left

  ))

  syntax "sdo" num tactic : tactic

notation:max "emp" => hempty

notation:max "⌜" P "⌝" => hpure P

syntax " <= " : bop

macro "xchange" l:term : tactic =>

macro "xchange" l:term : tactic =>
  `(tactic| (xchange_core $l; xsimp))

macro_rules
  | `(term| {| $seq |}) => `(withMainContext do evalTactic $ <- `(tacticSeq| $seq))

macro_rules
  | `([lang| ()])                       => `(trm_val (val_unit))
  | `([lang| $n:num])                   => `(trm_val (val_int $n))
  | `([lang| $t1 $t2])                  => `(trm_app [lang| $t1] [lang| $t2])
  | `([lang| if $t1 then $t2 else $t3]) => `(trm_if [lang| $t1] [lang| $t2] [lang| $t3])
  | `([lang| if $t1 then $t2 end])      => `(trm_if [lang| $t1] [lang| $t2] (trm_val val_unit))
  | `([lang| let $x := $t1:lang in $t2:lang])     =>
    `(trm_let $(%x) [lang| $t1] [lang| $t2])
  | `([lang| ref $x := $t1:lang in $t2:lang])     =>
    `(trm_ref $(%x) [lang| $t1] [lang| $t2])
  | `([lang| alloc $t1:lang as $x in $t2:lang])   =>
    `(trm_alloc $(%x) [lang| $t1] [lang| $t2])
  | `([lang| $t1 ; $t2])                => `(trm_seq [lang| $t1] [lang| $t2])
  | `([lang| fun_ $xs* => $t])             => do
    let xs <- xs.mapM fun x => `(term| $(%x))
    `(trm_funs [ $xs,* ] [lang| $t])
  | `([lang| fun $xs* => $t])             => do
    let xs <- xs.mapM fun x => `(term| $(%x))
    `(val_funs [ $xs,* ] [lang| $t])
  | `([lang| fix_ $f $xs* => $t])    => do
      let xs <- xs.mapM fun x => `(term| $(%x))
      `(trm_fixs $(%f) [ $xs,* ] [lang| $t])
  | `([lang| fix $f $xs* => $t])    => do
      let xs <- xs.mapM fun x => `(term| $(%x))
      `(val_fixs $(%f) [ $xs,* ] [lang| $t])

  | `([lang| free $t])                  => `(trm_val (val_prim val_free) [lang| $t])
  | `([lang| not $t])                   => `(trm_val (val_prim val_not) [lang| $t])

  | `([lang| !$t])                      => `(trm_val val_get [lang| $t])
  | `([lang| $t1 := $t2])               => `(trm_val val_set [lang| $t1] [lang| $t2])
  | `([lang| $t1 + $t2])                => `(trm_val val_add [lang| $t1] [lang| $t2])
  | `([lang| $t1 * $t2])                => `(trm_val val_mul [lang| $t1] [lang| $t2])
  | `([lang| $t1 - $t2])                => `(trm_val val_sub [lang| $t1] [lang| $t2])
  | `([lang| $t1 / $t2])                => `(trm_val val_div [lang| $t1] [lang| $t2])
  | `([lang| $t1 < $t2])                => `(trm_val val_lt [lang| $t1] [lang| $t2])
  | `([lang| $t1 > $t2])                => `(trm_val val_gt [lang| $t1] [lang| $t2])
  | `([lang| $t1 <= $t2])               => `(trm_val val_le [lang| $t1] [lang| $t2])
  | `([lang| $t1 >= $t2])               => `(trm_val val_ge [lang| $t1] [lang| $t2])
  | `([lang| -$t])                      => `(trm_val val_opp [lang| $t])
  | `([lang| $t1 = $t2])                => `(trm_val val_eq [lang| $t1] [lang| $t2])
  | `([lang| $t1 != $t2])               => `(trm_val val_neq [lang| $t1] [lang| $t2])
  | `([lang| $t1 mod $t2])              => `(trm_val val_mod [lang| $t1] [lang| $t2])
  | `([lang| $t1 ++ $t2])               => `(trm_val val_ptr_add [lang| $t1] [lang| $t2])
  | `([lang| ($t)]) => `([lang| $t])
  | `([lang| ⟨$t : $tp⟩]) => `(trm_val (($t : $tp)))
  | `([lang| for $x in [$n1 : $n2] { $t } ]) =>
    `(trm_for $(%x) [lang| $n1] [lang| $n2] [lang| $t])
  | `([lang| while $c:lang { $t:lang } ]) =>
     `(trm_while [lang| $c] [lang| $t] )

macro_rules
  | `([lang| len $p])                => `(trm_val val_array_length [lang| $p])
  | `([lang| $arr[$i] ])              => `(trm_val val_array_get [lang| $arr] [lang| $i])

  | `([lang| $arr[$i] := $v])        => `(trm_app val_array_set [lang| $arr] [lang| $i] [lang| $v])
  | `([lang| mkarr $n:lang $v:lang]) => `(trm_val val_array_make [lang| $n] [lang| $v])

macro_rules | `($x ∗ $y)   => `(binop% HStar.hStar $x $y)

  inductive trm : Type where
    | trm_val   : val -> trm
    | trm_var   : var -> trm
    | trm_fun   : var -> trm -> trm
    | trm_fix   : var -> var -> trm -> trm
    | trm_app   : trm -> trm -> trm
    | trm_seq   : trm -> trm -> trm
    | trm_let   : var -> trm -> trm -> trm
    | trm_if    : trm -> trm -> trm -> trm
    | trm_for   : var -> trm -> trm -> trm -> trm
    | trm_while : trm -> trm -> trm
    | trm_ref   : var → trm → trm → trm
    | trm_alloc : var → trm → trm → trm

  inductive val : Type where
    | val_unit   : val
    | val_bool   : Bool → val
    | val_int    : Int → val
    | val_real   : ℝ → val
    | val_loc    : loc → val
    | val_prim   : prim → val
    | val_fun    : var -> trm -> val
    | val_fix    : var -> var -> trm -> val
    | val_uninit : val
    | val_error : val

prim

inductive prim where

  | val_get : prim
  | val_set : prim

  | val_neg : prim
  | val_opp : prim
  | val_eq : prim
  | val_add : prim
  | val_neq : prim
  | val_sub : prim
  | val_mul : prim
  | val_div : prim
  | val_mod : prim

  | val_le : prim
  | val_lt : prim
  | val_ge : prim
  | val_gt : prim
  | val_ptr_add : prim

var

abbrev var := String

loc

abbrev loc := Nat

hProp

def hProp := heap -> Prop

heap

abbrev heap := Heap.heap val

Heap.heap

abbrev Heap.heap (val : Type) := Finmap (λ _ : loc ↦ val)

eval

inductive eval : state → trm → (val → state → Prop) -> Prop where
  | eval_val : forall s v Q,
      Q v s ->
      eval s (trm_val v) Q
  | eval_fun : forall s x t1 Q,
      Q (val_fun x t1) s ->
      eval s (trm_fun x t1) Q
  | eval_fix : forall s f x t1 Q,
      Q (val_fix f x t1) s ->
      eval s (trm_fix f x t1) Q
  | eval_app_arg1 : forall s1 t1 t2 Q1 Q,
      ¬ trm_is_val t1 ->
      eval s1 t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> eval s2 (trm_app v1 t2) Q) ->
      eval s1 (trm_app t1 t2) Q
  | eval_app_arg2 : forall s1 (v1 : val) t2 Q1 Q,
      ¬ trm_is_val t2 ->
      eval s1 t2 Q1 ->
      (forall v2 s2, Q1 v2 s2 -> eval s2 (trm_app v1 v2) Q) ->
      eval s1 (trm_app v1 t2) Q
  | eval_app_fun : forall s1 v1 (v2 :val) x t1 Q,
      v1 = val_fun x t1 ->
      eval s1 (subst x v2 t1) Q ->
      eval s1 (trm_app v1 v2) Q
  | eval_app_fix : forall s (v1 v2 : val) f x t1 Q,
      v1 = val_fix f x t1 ->
      eval s (subst x v2 (subst f v1 t1)) Q ->
      eval s (trm_app v1 v2) Q
  | eval_seq : forall Q1 s t1 t2 Q,
      eval s t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> eval s2 t2 Q) ->
      eval s (trm_seq t1 t2) Q
  | eval_let : forall Q1 s x t1 t2 Q,
      eval s t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> eval s2 (subst x v1 t2) Q) ->
      eval s (trm_let x t1 t2) Q
  | eval_if : forall s (b : Bool) t1 t2 Q,
      eval s (if b then t1 else t2) Q ->
      eval s (trm_if (val_bool b) t1 t2) Q
  | eval_unop : forall op s v1 P Q,
      evalunop op v1 P ->
      purepostin s P Q ->
      eval s (trm_app op v1) Q
  | eval_binop : forall op s (v1 v2 : val) P Q,
      evalbinop op v1 v2 P ->
      purepostin s P Q ->
      eval s (trm_app (trm_app op v1) v2) Q
  | eval_ref : forall s x t1 t2 (Q Q₁ : val → state → Prop),
    eval s t1 Q₁ →
    (∀ v1 s1, Q₁ v1 s1 → ∀ p ∉ s1,
     eval (s1.insert p v1) (subst x p t2) fun v s ↦ Q v (s.erase p)) →
    eval s (trm_ref x t1 t2) Q
  | eval_get : forall s p Q,
      p ∈ s ->
      Q (read_state p s) s ->
      eval s (trm_app val_get (val_loc p)) Q
  | eval_set : forall s p v Q,
      v = trm_val v' ->
      p ∈ s ->
      Q val_unit (Finmap.insert p v' s) ->
      eval s (trm_app (trm_app val_set (val_loc p)) v) Q
  | eval_alloc_arg : forall s Q₁ Q,
    ¬ trm_is_val t1 →
    eval s t1 Q₁ →
    (∀ v' s', Q₁ v' s' → eval s' (trm_alloc x v' t2) Q) →
    eval s (trm_alloc x t1 t2) Q
  | eval_alloc : forall (sa : state) (n : ℤ) Q,
    n ≥ 0 →
    (∀ (p : loc) (sb : state),
      sb = conseq (make_list n.natAbs val_uninit) p →
      p ≠ null →
      Finmap.Disjoint sa sb →
      eval (sb ∪ sa) (subst x p t2) fun v s ↦ Q v (s \ sb)) →
    eval sa (trm_alloc x n t2) Q

  | eval_for (n₁ n₂ : Int) (Q : val -> state -> Prop) :
    eval s (if (n₁ < n₂) then
               (trm_seq (subst x n₁ t₁) (trm_for x (val_int (n₁ + 1)) n₂ t₁))
            else val_unit) Q ->
    eval s (trm_for x n₁ n₂ t₁) Q
  | eval_while (t₁ t₂ : trm) (Q : val -> state -> Prop) :
    eval s t₁ Q₁ ->
    (∀ s v, Q₁ v s -> eval s (trm_if v (trm_seq t₂ (trm_while t₁ t₂)) val_unit) Q) ->
    eval s (trm_while t₁ t₂) Q

HStar

class HStar (α : Type u) (β : Type v) (γ : outParam (Type w)) where

  hStar : α → β → γ

subst

def subst (y : var) (v' : val) (t : trm) : trm :=

  let if_y_eq x t1 t2 := if x = y then t1 else t2
  match t with
  | trm_val v          => trm_val v
  | trm_var x          => if_y_eq x (trm_val v') t
  | trm_fun x t1       => trm_fun x (if_y_eq x t1 (subst y v' t1))
  | trm_fix f x t1     => trm_fix f x (if_y_eq f t1 (if_y_eq x t1 (subst y v' t1)))
  | trm_app t1 t2      => trm_app (subst y v' t1) (subst y v' t2)
  | trm_seq t1 t2      => trm_seq (subst y v' t1) (subst y v' t2)
  | trm_let x t1 t2    => trm_let x (subst y v' t1) (if_y_eq x t2 (subst y v' t2))
  | trm_if t0 t1 t2    => trm_if (subst y v' t0) (subst y v' t1) (subst y v' t2)
  | trm_for x t1 t2 t3 => trm_for x (subst y v' t1) (subst y v' t2) (if_y_eq x t3 (subst y v' t3))
  | trm_while t1 t2    => trm_while (subst y v' t1) (subst y v' t2)
  | trm_ref x t1 t2    => trm_ref x (subst y v' t1) (if_y_eq x t2 (subst y v' t2))
  | trm_alloc x t1 t2  => trm_alloc x (subst y v' t1) (if_y_eq x t2 (subst y v' t2))

qimpl

def qimpl {A} (Q1 Q2 : A → hProp) : Prop :=
  forall (v:A), Q1 v ==> Q2 v

himpl

abbrev himpl (H1 H2 : hProp) : Prop :=
  forall h, H1 h -> H2 h

step

inductive step : state → trm → state → trm → Prop where

  | step_seq_ctx : forall s1 s2 t1 t1' t2,
      step s1 t1 s2 t1' →
      step s1 (trm_seq t1 t2) s2 (trm_seq t1' t2)
  | step_let_ctx : forall s1 s2 x t1 t1' t2,
      step s1 t1 s2 t1' →
      step s1 (trm_let x t1 t2) s2 (trm_let x t1' t2)
  | step_app_arg_1 : forall s1 s2 t1 t1' t2,
      step s1 t1 s2 t1' →
      step s1 (trm_app t1 t2) s2 (trm_app t1' t2)
  | step_app_arg2 : forall s1 s2 v1 t2 t2',
      step s1 t2 s2 t2' →
      step s1 (trm_app v1 t2) s2 (trm_app v1 t2')

  | step_fun : forall s x t1,
      step s (trm_fun x t1) s (val_fun x t1)
  | step_fix : forall s f x t1,
      step s (trm_fix f x t1) s (val_fix f x t1)
  | step_app_fun : forall s v1 v2 x t1,
      v1 = val_fun x t1 →
      v2 = trm_val v2' →
      step s (trm_app v1 v2) s (subst x v2' t1)
  | step_app_fix : forall s v1 v2 f x t1,
      v1 = val_fix f x t1 →
      v2 = trm_val v2' →
      step s (trm_app v1 v2) s (subst x v2' (subst f v1 t1))
  | step_if : forall s b t1 t2,
      step s (trm_if (val_bool b) t1 t2) s (if b then t1 else t2)
  | step_seq : forall s t2 v1,
      step s (trm_seq v1 t2) s t2
  | step_let : forall s x t2 v1,
      v1 = trm_val v1' →
      step s (trm_let x v1 t2) s (subst x v1' t2)

  | step_neg : forall s b,
      step s (trm_app val_neg (val_bool b)) s (val_bool (¬ b))
  | step_opp : forall s n,
      step s (trm_app val_opp (val_int n)) s (val_int (- n))

  | step_eq : forall s v1 v2,
      step s (trm_app (trm_app val_eq v1) v2) s (val_bool (is_true (v1 = v2)))
  | step_neq : forall s v1 v2,
      step s (trm_app (trm_app val_neq v1) v2) s (val_bool (is_true (v1 ≠ v2)))
  | step_add : forall s n1 n2,
      step s (trm_app (trm_app val_add (val_int n1)) (val_int n2)) s
        (val_int (n1 + n2))
  | step_sub : forall s n1 n2,
      step s (trm_app (trm_app val_sub (val_int n1)) (val_int n2)) s
        (val_int (n1 - n2))
  | step_mul : forall s n1 n2,
      step s (trm_app (trm_app val_mul (val_int n1)) (val_int n2)) s
        (val_int (n1 * n2))
  | step_div : forall s n1 n2,
      n2 ≠ 0 →
      step s (trm_app (trm_app val_div (val_int n1)) (val_int n2)) s
        (n1 / n2)
  | step_mod : forall s n1 n2,
      n2 ≠ 0 →
      step s (trm_app (trm_app val_mod (val_int n1)) (val_int n2)) s
        (n1 % n2)
  | step_le : forall s n1 n2,
      step s (trm_app (trm_app val_le (val_int n1)) (val_int n2)) s
        (val_bool (n1 <= n2))
  | step_lt : forall s n1 n2,
      step s (trm_app (trm_app val_lt (val_int n1)) (val_int n2)) s
        (val_bool (n1 < n2))
  | step_ge : forall s n1 n2,
      step s (trm_app (trm_app val_ge (val_int n1)) (val_int n2)) s
        (val_bool (n1 >= n2))
  | step_gt : forall s n1 n2,
      step s (trm_app (trm_app val_gt (val_int n1)) (val_int n2)) s
        (val_bool (n1 > n2))
  | step_ptr_add : forall s p1 p2 n,
      (p2:ℤ) = (p1:loc) + n →
      step s (trm_app (trm_app val_ptr_add (val_loc p1)) (val_int n)) s
        (val_loc (Int.toNat p2))

  | step_ref : forall s v p,
      ¬ p ∈ s →
      v = trm_val v' →
      step s (trm_app val_ref v) (Finmap.insert p v' s) (val_loc p)
  | step_get : forall s p,
      p ∈ s →
      step s (trm_app val_get (val_loc p)) s (read_state p s)
  | step_set : forall s p v,
      p ∈ s ->
      v = trm_val v' →
      step s (trm_app (trm_app val_set (val_loc p)) v)
        (Finmap.insert p v' s) val_unit
  | step_free : forall s p,
      p ∈ s →
      step s (trm_app val_free (val_loc p)) (Finmap.erase p s) val_unit

syntax ident : lang

HWand

class HWand (α : Type u) (β : Type v) (γ : outParam (Type w)) where

  hWand : α → β → γ

purepostin

def purepostin (s : state) (P : val → Prop) (Q : val → state → Prop) : Prop :=

  forall v, P v → Q v s

state

abbrev state := Finmap (λ _ : loc ↦ val)

tohProp

abbrev tohProp (h : heap -> Prop) : hProp := h

ofhProp

abbrev ofhProp (h : val -> hProp) : val -> heap -> Prop := h

hforall

def hforall {A} (J : A → hProp) : hProp :=
  fun h => forall x, J x h

hempty

def hempty : hProp :=
  fun h => (h = ∅)

hpure

def hpure (P : Prop) : hProp :=
  hexists (fun (_ : P) => emp)

hexists

def hexists {A} (J : A → hProp) : hProp :=
  fun h => exists x, J x h

infixr:51 " ==> " => himpl

infixr:51 " ===> " => qimpl

notation:max "emp" => hempty

infixr:55 " ∗ " => HStar.hStar

notation:max "⌜" P "⌝" => hpure P

infixr:55 " -∗ " => HWand.hWand

fun

notation "funloc" p "↦" H =>
  fun (r : val) ↦ hexists (fun p ↦ ⌜r = val_loc p⌝ ∗ H)

lemma eval_conseq s t Q1 Q2 :
  eval s t Q1 →
  Q1 ===> Q2 →
  eval s t Q2

qstarE

lemma qstarE α (Q1 : α → hProp)  (H : hProp):
  Q1 ∗ H = fun x => Q1 x ∗ H

lemma eval_frame (h1 h2 : state) t (Q : val -> hProp) :
  eval h1 t (ofhProp Q) →
  Finmap.Disjoint h1 h2 →
  eval (h1 ∪ h2) t (Q ∗ (tohProp (fun h ↦ h = h2)))

lemma qwand_cancel A (Q1 Q2 : A → hProp) :
  Q1 ∗ (Q1 -∗ Q2) ===> Q2

lemma qwand_equiv H A (Q1 Q2 : A → hProp) :
  H ==> (Q1 -∗ Q2) ↔ (Q1 ∗ H) ===> Q2

lemma hstar_hforall A (J : A → hProp) H :
  (hforall J) ∗ H ==> hforall (J ∗ H)

lemma hstar_comm H1 H2 :
  H1 ∗ H2 = H2 ∗ H1

lemma hprop_op_comm (op : hProp → hProp → hProp) :
  (forall H1 H2, op H1 H2 ==> op H2 H1) →
  (forall H1 H2, op H1 H2 = op H2 H1)

lemma himpl_antisym H1 H2:
  (H1 ==> H2) → (H2 ==> H1) → (H1 = H2)

lemma hstar_inv (H1 H2 : hProp) h:
  (H1 ∗ H2) h →
  exists h1 h2, H1 h1 ∧ H2 h2 ∧ Finmap.Disjoint h1 h2 ∧ h = h1 ∪ h2

lemma himpl_hstar_trans_l H1 H2 H3 H4 :
  H1 ==> H2 →
  H2 ∗ H3 ==> H4 →
  H1 ∗ H3 ==> H4

lemma himpl_hforall_l A (x : A) (J : A → hProp) H :
  (J x ==> H) →
  (hforall J) ==> H

lemma himpl_hforall_r A (J : A → hProp) H :
  (forall x, H ==> J x) →
  H ==> (hforall J)

lemma hwand_equiv H0 H1 H2 :
  (H0 ==> H1 -∗ H2) ↔ (H1 ∗ H0 ==> H2)

lemma hstar_assoc H1 H2 H3 :
  (H1 ∗ H2) ∗ H3 = H1 ∗ (H2 ∗ H3)

lemma himpl_hstar_hpure_l P H H' :
  (P → H ==> H') →
  (⌜P⌝ ∗ H) ==> H'

lemma hstar_hpure_l P H h :
  (⌜P⌝ ∗ H) h = (P ∧ H h)

lemma hstar_hempty_l H :
  emp ∗ H = H

lemma hempty_inv h :
  emp h → h = ∅

lemma hstar_hexists A (J : A → hProp) H :
  (hexists J) ∗ H = hexists (fun x => (J x) ∗ H)

lemma himpl_hempty_hpure P :
  P → emp ==> ⌜P⌝

lemma himpl_hexists_r A (x : A) H (J : A → hProp) :
  (H ==> J x) →
  H ==> (hexists J)

hwandE

lemma hwandE :
  H1 -∗ H2 = hexists (fun H0 => H0 ∗ hpure ((H1 ∗ H0) ==> H2))

lemma himpl_frame_r H1 H2 H2' :
  H2 ==> H2' →
  (H1 ∗ H2) ==> (H1 ∗ H2')

lemma hstar_hempty_r H :
  H ∗ emp = H

lemma himpl_hexists_l A H (J : A → hProp) :
  (forall x, J x ==> H) → (hexists J) ==> H

qwandE

lemma qwandE α (Q1 Q2 : α → hProp) :
  Q1 -∗ Q2 = hforall (fun x => (Q1 x) -∗ (Q2 x))

lemma hwand_cancel H1 H2 :
  H1 ∗ (H1 -∗ H2) ==> H2

lemma himpl_hwand_r_inv H1 H2 H3 :
  H1 ==> (H2 -∗ H3) →
  H2 ∗ H1 ==> H3

lemma himpl_trans H2 H1 H3 :
  (H1 ==> H2) → (H2 ==> H3) → (H1 ==> H3)

lemma himpl_trans_r H2 H1 H3:
  H2 ==> H3 → H1 ==> H2 → H1 ==> H3

Theories.wp

lemma wp_conseq t Q1 Q2 :
  Q1 ===> Q2 →
  wp t Q1 ==> wp t Q2

lemma wp_frame t H Q :
  (wp t Q) ∗ H ==> wp t (Q ∗ H)

lemma wp_ramified t (Q1 Q2 : val -> hProp) :
  (wp t Q1) ∗ (Q1 -∗ Q2) ==> (wp t Q2)

lemma wp_conseq_frame t H (Q1 Q2 : val -> hProp) :
  Q1 ∗ H ===> Q2 →
  (wp t Q1) ∗ H ==> (wp t Q2)

import Lean

import Mathlib.Data.Finmap

import Mathlib.Data.List.Indexes

import SPLean.Common.State

import SPLean.Common.Util

import SPLean.Theories.HProp

import SPLean.Theories.XSimp

import SPLean.Theories.XChange

import SPLean.Theories.SepLog

import SPLean.Theories.WPUtil

open trm val prim

namespace Theories

def wp (t : trm) (Q : val → hProp) : hProp :=
  fun s ↦ eval s t Q

section tactics

open Lean Elab Tactic

section xapp

end xapp

end tactics

open AList

section funs_fixs_eval_like

variable (xs : List var) (vs : List val) (t : trm) (v0 : trm)
  (heqt : t = trm_apps v0 ts)
  (hconv : trms_to_vals ts = vs)
  (hform : var_funs xs vs.length)   -- NOTE: can be relaxed to `vs.length ≤ xs.length`

variable (f : var) (hf : f ∉ xs)

end funs_fixs_eval_like

end Theories

open Theories

open Lean.Elab.Tactic in

lemma xfor_lemma (z n : ℤ) (x : var) (I : ℤ -> hProp) :
  z <= n ->
  (H ==> H' ∗ I z) ->
  (∀ i, z <= i -> i < n -> I i ==> wp (subst x i F1) (fun _ => I (i + 1))) ->
  ((fun _ => I n ∗ H') ===> Q) ->
  H ==> wp (trm_for x z n F1) Q :=

:= by
  move=> ? hini hstep hfin
  xchange hini
  apply himpl_trans_r; apply wp_conseq_frame=> //
  xsimp
  move: z hfin {hini}=> z; apply Int.le_induction_down
  { move=> ?? ??
    constructor=> /==;constructor; aesop }
  move=> j ? ih step hfin
  move=> ??;
  constructor=> /==; srw if_pos; rotate_left; omega
  constructor
  { apply step <;> try omega
    sdone }
  move=> _ > ?; apply ih=> // *
  apply step <;> omega


syntax "fun" ident+ " => " lang : lang

syntax "fun" ident+ " => " lang : lang

syntax "if " lang "then " lang "end " : lang

syntax " := " : bop

syntax "let" ident " := " lang " in" ppDedent(ppLine lang) : lang

syntax "⟨" term "⟩" : lang

syntax "⟨" term ":" term "⟩" : lang

macro_rules
  | `([lang| ()])                       => `(trm_val (val_unit))
  | `([lang| $n:num])                   => `(trm_val (val_int $n))
  | `([lang| $t1 $t2])                  => `(trm_app [lang| $t1] [lang| $t2])
  | `([lang| if $t1 then $t2 else $t3]) => `(trm_if [lang| $t1] [lang| $t2] [lang| $t3])
  | `([lang| if $t1 then $t2 end])      => `(trm_if [lang| $t1] [lang| $t2] (trm_val val_unit))
  | `([lang| let $x := $t1:lang in $t2:lang])     =>
    `(trm_let $(%x) [lang| $t1] [lang| $t2])
  | `([lang| ref $x := $t1:lang in $t2:lang])     =>
    `(trm_ref $(%x) [lang| $t1] [lang| $t2])
  | `([lang| alloc $t1:lang as $x in $t2:lang])   =>
    `(trm_alloc $(%x) [lang| $t1] [lang| $t2])
  | `([lang| $t1 ; $t2])                => `(trm_seq [lang| $t1] [lang| $t2])
  | `([lang| fun_ $xs* => $t])             => do
    let xs <- xs.mapM fun x => `(term| $(%x))
    `(trm_funs [ $xs,* ] [lang| $t])
  | `([lang| fun $xs* => $t])             => do
    let xs <- xs.mapM fun x => `(term| $(%x))
    `(val_funs [ $xs,* ] [lang| $t])
  | `([lang| fix_ $f $xs* => $t])    => do
      let xs <- xs.mapM fun x => `(term| $(%x))
      `(trm_fixs $(%f) [ $xs,* ] [lang| $t])
  | `([lang| fix $f $xs* => $t])    => do
      let xs <- xs.mapM fun x => `(term| $(%x))
      `(val_fixs $(%f) [ $xs,* ] [lang| $t])

  | `([lang| free $t])                  => `(trm_val (val_prim val_free) [lang| $t])
  | `([lang| not $t])                   => `(trm_val (val_prim val_not) [lang| $t])

  | `([lang| !$t])                      => `(trm_val val_get [lang| $t])
  | `([lang| $t1 := $t2])               => `(trm_val val_set [lang| $t1] [lang| $t2])
  | `([lang| $t1 + $t2])                => `(trm_val val_add [lang| $t1] [lang| $t2])
  | `([lang| $t1 * $t2])                => `(trm_val val_mul [lang| $t1] [lang| $t2])
  | `([lang| $t1 - $t2])                => `(trm_val val_sub [lang| $t1] [lang| $t2])
  | `([lang| $t1 / $t2])                => `(trm_val val_div [lang| $t1] [lang| $t2])
  | `([lang| $t1 < $t2])                => `(trm_val val_lt [lang| $t1] [lang| $t2])
  | `([lang| $t1 > $t2])                => `(trm_val val_gt [lang| $t1] [lang| $t2])
  | `([lang| $t1 <= $t2])               => `(trm_val val_le [lang| $t1] [lang| $t2])
  | `([lang| $t1 >= $t2])               => `(trm_val val_ge [lang| $t1] [lang| $t2])
  | `([lang| -$t])                      => `(trm_val val_opp [lang| $t])
  | `([lang| $t1 = $t2])                => `(trm_val val_eq [lang| $t1] [lang| $t2])
  | `([lang| $t1 != $t2])               => `(trm_val val_neq [lang| $t1] [lang| $t2])
  | `([lang| $t1 mod $t2])              => `(trm_val val_mod [lang| $t1] [lang| $t2])
  | `([lang| $t1 ++ $t2])               => `(trm_val val_ptr_add [lang| $t1] [lang| $t2])
  | `([lang| ($t)]) => `([lang| $t])
  | `([lang| ⟨$t : $tp⟩]) => `(trm_val (($t : $tp)))
  | `([lang| for $x in [$n1 : $n2] { $t } ]) =>
    `(trm_for $(%x) [lang| $n1] [lang| $n2] [lang| $t])
  | `([lang| while $c:lang { $t:lang } ]) =>
     `(trm_while [lang| $c] [lang| $t] )

macro_rules
  | `([lang| len $p])                => `(trm_val val_array_length [lang| $p])
  | `([lang| $arr[$i] ])              => `(trm_val val_array_get [lang| $arr] [lang| $i])

  | `([lang| $arr[$i] := $v])        => `(trm_app val_array_set [lang| $arr] [lang| $i] [lang| $v])
  | `([lang| mkarr $n:lang $v:lang]) => `(trm_val val_array_make [lang| $n] [lang| $v])

  inductive trm : Type where
    | trm_val   : val -> trm
    | trm_var   : var -> trm
    | trm_fun   : var -> trm -> trm
    | trm_fix   : var -> var -> trm -> trm
    | trm_app   : trm -> trm -> trm
    | trm_seq   : trm -> trm -> trm
    | trm_let   : var -> trm -> trm -> trm
    | trm_if    : trm -> trm -> trm -> trm
    | trm_for   : var -> trm -> trm -> trm -> trm
    | trm_while : trm -> trm -> trm
    | trm_ref   : var → trm → trm → trm
    | trm_alloc : var → trm → trm → trm

  inductive val : Type where
    | val_unit   : val
    | val_bool   : Bool → val
    | val_int    : Int → val
    | val_real   : ℝ → val
    | val_loc    : loc → val
    | val_prim   : prim → val
    | val_fun    : var -> trm -> val
    | val_fix    : var -> var -> trm -> val
    | val_uninit : val
    | val_error : val

prim

inductive prim where

  | val_get : prim
  | val_set : prim

  | val_neg : prim
  | val_opp : prim
  | val_eq : prim
  | val_add : prim
  | val_neq : prim
  | val_sub : prim
  | val_mul : prim
  | val_div : prim
  | val_mod : prim

  | val_le : prim
  | val_lt : prim
  | val_ge : prim
  | val_gt : prim
  | val_ptr_add : prim

var

abbrev var := String

loc

abbrev loc := Nat

subst

def subst (y : var) (v' : val) (t : trm) : trm :=

  let if_y_eq x t1 t2 := if x = y then t1 else t2
  match t with
  | trm_val v          => trm_val v
  | trm_var x          => if_y_eq x (trm_val v') t
  | trm_fun x t1       => trm_fun x (if_y_eq x t1 (subst y v' t1))
  | trm_fix f x t1     => trm_fix f x (if_y_eq f t1 (if_y_eq x t1 (subst y v' t1)))
  | trm_app t1 t2      => trm_app (subst y v' t1) (subst y v' t2)
  | trm_seq t1 t2      => trm_seq (subst y v' t1) (subst y v' t2)
  | trm_let x t1 t2    => trm_let x (subst y v' t1) (if_y_eq x t2 (subst y v' t2))
  | trm_if t0 t1 t2    => trm_if (subst y v' t0) (subst y v' t1) (subst y v' t2)
  | trm_for x t1 t2 t3 => trm_for x (subst y v' t1) (subst y v' t2) (if_y_eq x t3 (subst y v' t3))
  | trm_while t1 t2    => trm_while (subst y v' t1) (subst y v' t2)
  | trm_ref x t1 t2    => trm_ref x (subst y v' t1) (if_y_eq x t2 (subst y v' t2))
  | trm_alloc x t1 t2  => trm_alloc x (subst y v' t1) (if_y_eq x t2 (subst y v' t2))

fun

notation "funloc" p "↦" H =>
  fun (r : val) ↦ hexists (fun p ↦ ⌜r = val_loc p⌝ ∗ H)

theorem List.getElem_append_left{α : Type u_1} {l₁ l₂ : List α} {i : Nat} (hn : i < l₁.length) :\n(l₁ ++ l₂)[i] = l₁[i]

Theories.ctx

abbrev ctx := AList (fun _ : var ↦ val)

Theories.isubst

lemma AList.erase_insert_cancel {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (b : β a) (l : AList β) :
    (AList.erase a (AList.insert a b l)).entries.Perm (AList.erase a l).entries

lemma AList.erase_insert_swap {α : Type u} {β : α → Type v} [DecidableEq α] (a a' : α) (b : β a) (l : AList β) :
  a ≠ a' → (AList.erase a' (AList.insert a b l)).entries.Perm (AList.insert a b (AList.erase a' l)).entries

lemma AList.erase_noop {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (l : AList β) :
    a ∉ l → (AList.erase a l).entries.Perm l.entries

lemma AList.erase_twice {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) (l : AList β) :
    (AList.erase a (AList.erase a l)).entries.Perm (AList.erase a l).entries

lemma isubst_perm {al al'} t (hp : al.entries.Perm al'.entries) :
  isubst al t = isubst al' t

import Lean

import Mathlib.Data.Finmap

import Mathlib.Data.List.Indexes

import SPLean.Common.State

import SPLean.Common.Util

import SPLean.Theories.HProp

import SPLean.Theories.XSimp

import SPLean.Theories.XChange

import SPLean.Theories.SepLog

import SPLean.Theories.WPUtil

open trm val prim

namespace Theories

section tactics

open Lean Elab Tactic

section xapp

end xapp

end tactics

open AList

abbrev ctx := AList (fun _ : var ↦ val)

def isubst (E : ctx) (t : trm) : trm :=
  match t with
  | trm_val v =>
      v
  | trm_var x =>
      match lookup x E with
      | none   => t
      | some v => v
  | trm_fun x t1 =>
      trm_fun x (isubst (erase x E) t1)
  | trm_fix f x t1 =>
      trm_fix f x (isubst (erase x (erase f E)) t1)
  | trm_if t0 t1 t2 =>
      trm_if (isubst E t0) (isubst E t1) (isubst E t2)
  | trm_seq t1 t2 =>
      trm_seq (isubst E t1) (isubst E t2)
  | trm_let x t1 t2 =>
      trm_let x (isubst E t1) (isubst (erase x E) t2)
  | trm_ref x t1 t2 =>
      trm_ref x (isubst E t1) (isubst (erase x E) t2)
  | trm_alloc x t1 t2 =>
      trm_alloc x (isubst E t1) (isubst (erase x E) t2)
  | trm_app t1 t2 =>
      trm_app (isubst E t1) (isubst E t2)
  | trm_for x n1 n2 t =>
      trm_for x (isubst E n1) (isubst E n2) (isubst (erase x E) t)
  | trm_while c t =>
      trm_while (isubst E c) (isubst E t)

lemma isubst_insert (al : ctx) x v t :
  isubst (al.insert x v) t = subst x v (isubst (al.erase x) t) :=

:= by
  move: al
  induction t using (subst.induct x v)=> >
  all_goals (simp [isubst, subst]=> //)
  all_goals (split_ands=> //)
  all_goals ((try split_ifs=> //) <;> (try subst_eqs))
  all_goals (try srw (fun t => isubst_perm t (AList.erase_twice x al)))
  all_goals (try srw (fun v t => isubst_perm t (AList.erase_insert_cancel x v al)))
  all_goals (try solve
    | srw (fun x' hneq v t => isubst_perm t (AList.erase_insert_swap x x' v al hneq)) <;>
      (try solve | aesop) ; -- `aesop` does autorewrite here
      (try simp [*])
      apply congrArg ; srw AList.erase_erase)
  all_goals (try apply isubst_perm)
  { rename_i x' ; by_cases h : x' = x
    { subst x' ; simp [subst] }
    { srw AList.lookup_insert_ne // AList.lookup_erase_ne //
      scase: (lookup x' al)=> //=
      simp [subst, h] } }
  { apply AList.perm_erase
    trans ; apply AList.erase_insert_cancel ; symm ; apply AList.erase_twice }
  { srw [2]AList.erase_erase [1]AList.erase_erase
    apply AList.perm_erase
    trans ; apply AList.erase_insert_cancel ; symm ; apply AList.erase_twice }
  { rename_i ih ha hb
    srw [3]AList.erase_erase [2]AList.erase_erase -ih
    apply isubst_perm
    trans
    on_goal 2=> apply AList.erase_insert_swap ; aesop
    apply AList.perm_erase
    apply AList.erase_insert_swap ; aesop }


loc

abbrev loc := Nat

kmerge

lemma List.kerase_noterased {α : Type u} {β : α → Type v} [DecidableEq α] (l : List (Sigma β))
  (a a' : α) (hneq : a ≠ a') (b : β a) : ⟨a, b⟩ ∈ l ↔ ⟨a, b⟩ ∈ List.kerase a' l

lemma kmerge_mem2 (l₁ l₂ : List (Sigma (fun _ : loc => val))) (nd₁ : l₁.NodupKeys) (nd₂ : l₂.NodupKeys) -- necessary
    (a : Sigma (fun _ : loc => val)) : a ∈ (kmerge l₁ l₂) ↔
      if a.1 ∈ l₁.keys
      then (if a.1 ∈ l₂.keys then Option.merge (· + ·) (l₁.dlookup a.1) (l₂.dlookup a.1) = .some a.2 else a ∈ l₁)
      else a ∈ l₂

lemma kmerge_NodupKeys (l₁ l₂ : List (Sigma (fun _ : loc => val))) (nd₁ : l₁.NodupKeys) (nd₂ : l₂.NodupKeys) : (kmerge l₁ l₂).NodupKeys

import Lean

import Mathlib.Data.Finmap

import Mathlib.Algebra.Group.Basic

import Mathlib.Algebra.BigOperators.Group.Finset

import Mathlib.Algebra.BigOperators.Intervals

import Mathlib.Data.Int.Interval

import Mathlib.Order.Interval.Finset.Basic

import Batteries.Data.List.Perm

import Ssreflect.Lang

open Classical

abbrev loc := Nat

section Option.merge

variable {α : Type u} (f : α → α → α)

end Option.merge

open PartialCommMonoid (valid)

section

variable {val : Type} [PartialCommMonoid val] -- [Inhabited val]

local notation "heap" => Heap.heap val

private def kmerge1 (l : loc) (v : val) (l₂ : List (Sigma (fun _ : loc => val))) : val :=
  match l₂.dlookup l with
  | .some v' => v + v'
  | _ => v

@[simp]
def kmerge : List (Sigma (fun _ : loc => val)) → List (Sigma (fun _ : loc => val)) → List (Sigma (fun _ : loc => val))
  | [], l₂ => l₂
  | s :: l₁, l₂ =>
    (if s.1 ∈ l₂.keys then
      ⟨s.1, kmerge1 s.1 s.2 l₂⟩ :: kmerge l₁ (l₂.kerase s.1)
    else s :: kmerge l₁ l₂)

theorem Perm.kmerge {l₁ l₂ l₃ l₄ : List (Sigma (fun _ : loc => val))} (nd₁ : l₁.NodupKeys) /- nd₁ is necessary -/ (nd₃ : l₃.NodupKeys)
    (p₁₂ : l₁.Perm l₂) (p₃₄ : l₃.Perm l₄) : (kmerge l₁ l₃).Perm $ kmerge l₂ l₄ :=

:= by
  have nd₂ := nd₁
  rw [List.perm_nodupKeys p₁₂] at nd₂
  have nd₄ := nd₃
  rw [List.perm_nodupKeys p₃₄] at nd₄
  rw [List.perm_ext_iff_of_nodup] <;> try (apply List.NodupKeys.nodup ; apply kmerge_NodupKeys=> //)
  move=> [] l v
  srw !kmerge_mem2 // (List.perm_dlookup _ nd₁ nd₂ p₁₂) // (List.perm_dlookup _ nd₃ nd₄ p₃₄)
  dsimp [List.keys]
  srw (List.Perm.mem_iff (List.Perm.map Sigma.fst p₁₂)) (List.Perm.mem_iff (List.Perm.map Sigma.fst p₃₄)) (List.Perm.mem_iff p₁₂) (List.Perm.mem_iff p₃₄)


heap

abbrev heap := Heap.heap val

  inductive val : Type where
    | val_unit   : val
    | val_bool   : Bool → val
    | val_int    : Int → val
    | val_real   : ℝ → val
    | val_loc    : loc → val
    | val_prim   : prim → val
    | val_fun    : var -> trm -> val
    | val_fix    : var -> var -> trm -> val
    | val_uninit : val
    | val_error : val

prim

inductive prim where

  | val_get : prim
  | val_set : prim

  | val_neg : prim
  | val_opp : prim
  | val_eq : prim
  | val_add : prim
  | val_neq : prim
  | val_sub : prim
  | val_mul : prim
  | val_div : prim
  | val_mod : prim

  | val_le : prim
  | val_lt : prim
  | val_ge : prim
  | val_gt : prim
  | val_ptr_add : prim

  inductive trm : Type where
    | trm_val   : val -> trm
    | trm_var   : var -> trm
    | trm_fun   : var -> trm -> trm
    | trm_fix   : var -> var -> trm -> trm
    | trm_app   : trm -> trm -> trm
    | trm_seq   : trm -> trm -> trm
    | trm_let   : var -> trm -> trm -> trm
    | trm_if    : trm -> trm -> trm -> trm
    | trm_for   : var -> trm -> trm -> trm -> trm
    | trm_while : trm -> trm -> trm
    | trm_ref   : var → trm → trm → trm
    | trm_alloc : var → trm → trm → trm

scoped instance : PartialCommMonoid val where
  add := add
  add_assoc := by admit /- proof elided -/

add

@[simp]
abbrev add : val -> val -> val
  | .val_int i, .val_int j => val.val_int (i + j)
  | _, _ => val.val_unit

evalExact

inductive evalExact : state → trm → (val → state → Prop) -> Prop where
  | val : forall s v,
      evalExact s (trm_val v) (fun v' s' ↦ v' = v ∧ s' = s)
  | fun : forall s x t1,
      evalExact s (trm_fun x t1) (fun v' s' ↦ v' = val_fun x t1 ∧ s' = s)
  | fix : forall s f x t1,
      evalExact s (trm_fix f x t1) (fun v' s' ↦ v' = val_fix f x t1 ∧ s' = s)
  | app_arg1 : forall s1 t1 t2 Q1 Q,
      ¬ trm_is_val t1 ->
      evalExact s1 t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> evalExact s2 (trm_app v1 t2) Q) ->
      evalExact s1 (trm_app t1 t2) Q
  | app_arg2 : forall s1 (v1 : val) t2 Q1 Q,
      ¬ trm_is_val t2 ->
      evalExact s1 t2 Q1 ->
      (forall v2 s2, Q1 v2 s2 -> evalExact s2 (trm_app v1 v2) Q) ->
      evalExact s1 (trm_app v1 t2) Q
  | app_fun : forall s1 v1 (v2 :val) x t1 Q,
      v1 = val_fun x t1 ->
      evalExact s1 (subst x v2 t1) Q ->
      evalExact s1 (trm_app v1 v2) Q
  | app_fix : forall s (v1 v2 : val) f x t1 Q,
      v1 = val_fix f x t1 ->
      evalExact s (subst x v2 (subst f v1 t1)) Q ->
      evalExact s (trm_app v1 v2) Q
  | seq : forall Q1 s t1 t2 Q,
      evalExact s t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> evalExact s2 t2 Q) ->
      evalExact s (trm_seq t1 t2) Q
  | let : forall Q1 s x t1 t2 Q,
      evalExact s t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> evalExact s2 (subst x v1 t2) Q) ->
      evalExact s (trm_let x t1 t2) Q
  | if : forall s (b : Bool) t1 t2 Q,
      evalExact s (if b then t1 else t2) Q ->
      evalExact s (trm_if (val_bool b) t1 t2) Q
  | unop : forall op s v1 P,
      evalunop op v1 P ->
      evalExact s (trm_app op v1) (purepost s P)
  | binop : forall op s (v1 v2 : val) P,
      evalbinop op v1 v2 P ->
      evalExact s (trm_app (trm_app op v1) v2) (purepost s P)
  | ref : forall s x t1 t2 Q Q₁,
    evalExact s t1 Q₁ →
    (∀ v1 s1, Q₁ v1 s1 → ∀ p ∉ s1,
     evalExact (s1.insert p v1) (subst x p t2) fun v s ↦ Q v (s.erase p)) →
      evalExact s (trm_ref x t1 t2) Q
  | get : forall s p,
      p ∈ s ->
      evalExact s (trm_app val_get (val_loc p))
        (fun v' s' ↦ v' = read_state p s ∧ s' = s)
  | set : forall s p v,
      v = trm_val v' ->
      p ∈ s ->
      evalExact s (trm_app (trm_app val_set (val_loc p)) v)
        (fun v'' s' ↦ v'' = val_unit ∧ s' = s.insert p v')
  | alloc_arg : forall s Q₁ Q,
    ¬ trm_is_val t1 →
    evalExact s t1 Q₁ →
    (∀ v' s', Q₁ v' s' → evalExact s' (trm_alloc x v' t2) Q) →
    evalExact s (trm_alloc x t1 t2) Q
  | alloc : forall (sa : state) (n : ℤ) Q,
    n ≥ 0 →
    (∀ (p : loc) (sb : state),
      sb = conseq (make_list n.natAbs val_uninit) p →
      p ≠ null →
      Finmap.Disjoint sa sb →
      evalExact (sb ∪ sa) (subst x p t2) fun v s ↦ Q v (s \ sb)) →
    evalExact sa (trm_alloc x n t2) Q

  | for (n₁ n₂ : Int) (Q : val -> state -> Prop) :
    evalExact s (if (n₁ < n₂) then
               (trm_seq (subst x n₁ t₁) (trm_for x (val_int (n₁ + 1)) n₂ t₁))
            else val_unit) Q ->
    evalExact s (trm_for x n₁ n₂ t₁) Q
  | while (t₁ t₂ : trm) (Q Q₁ : val -> state -> Prop) :
    evalExact s t₁ Q₁ ->
    (∀ s v, Q₁ v s -> evalExact s (trm_if v (trm_seq t₂ (trm_while t₁ t₂)) val_unit) Q) ->
    evalExact s (trm_while t₁ t₂) Q

valid

@[simp]
abbrev valid : val -> Prop
  | .val_int _ => True
  | _ => False

PartialCommMonoid

scoped instance inst : PartialCommMonoidWRT val add valid where
  validE := by admit /- proof elided -/

AddCommMonoidWRT

class AddCommMonoidWRT (α : Type) (add' : semiOutParam $ α -> α -> α) extends AddCommMonoid α where
  addE : (· + ·) = add'

add

@[simp]
abbrev add : val -> val -> val
  | .val_bool i, .val_bool j => val.val_bool (i || j)
  | _, _ => val.val_unit

valid

@[simp]
abbrev valid : val -> Prop
  | .val_bool _ => True
  | _ => False

add

@[simp]
abbrev add : val -> val -> val
  | .val_real i, .val_real j => val.val_real (i + j)
  | _, _ => val.val_unit

valid

@[simp]
abbrev valid : val -> Prop
  | .val_real _ => True
  | _ => False

theorem List.getElem_append_left{α : Type u_1} {l₁ l₂ : List α} {i : Nat} (hn : i < l₁.length) :\n(l₁ ++ l₂)[i] = l₁[i]

loc

abbrev loc := Nat

var

abbrev var := String

validInter

import Lean

import Mathlib.Data.Finmap

import Mathlib.Algebra.Group.Basic

import Mathlib.Algebra.BigOperators.Group.Finset

import Mathlib.Algebra.BigOperators.Intervals

import Mathlib.Data.Int.Interval

import Mathlib.Order.Interval.Finset.Basic

import Batteries.Data.List.Perm

import Ssreflect.Lang

open Classical

abbrev loc := Nat

abbrev var := String

section Option.merge

variable {α : Type u} (f : α → α → α)

end Option.merge

abbrev Heap.heap (val : Type) := Finmap (λ _ : loc ↦ val)

class PartialCommMonoid (α : Type) extends AddCommSemigroup α where
  valid : α -> Prop
  valid_add : ∀ x, valid (x + y) -> valid x
  add_valid : ∀ x y, valid x -> valid y -> valid (x + y)

open PartialCommMonoid (valid)

section

variable {val : Type} [PartialCommMonoid val] -- [Inhabited val]

local notation "heap" => Heap.heap val

private def kmerge1 (l : loc) (v : val) (l₂ : List (Sigma (fun _ : loc => val))) : val :=
  match l₂.dlookup l with
  | .some v' => v + v'
  | _ => v

@[simp]
def kmerge : List (Sigma (fun _ : loc => val)) → List (Sigma (fun _ : loc => val)) → List (Sigma (fun _ : loc => val))
  | [], l₂ => l₂
  | s :: l₁, l₂ =>
    (if s.1 ∈ l₂.keys then
      ⟨s.1, kmerge1 s.1 s.2 l₂⟩ :: kmerge l₁ (l₂.kerase s.1)
    else s :: kmerge l₁ l₂)

noncomputable def AList.merge (h₁ h₂ : AList (fun _ : loc => val)) :  AList (fun _ : loc => val) :=
  ⟨kmerge h₁.entries h₂.entries, by admit /- proof elided -/
    ⟩

noncomputable def Heap.add (h₁ h₂ : heap) : heap :=
  Finmap.liftOn₂ h₁ h₂ (fun h₁ h₂ => (h₁.merge h₂).toFinmap) (by admit /- proof elided -/
    )

infixr:55 " +ʰ " => Heap.add

def validInter (h₁ h₂ : heap) : Prop :=
  ∀ l ∈ h₁, l ∈ h₂ -> ((h₁ +ʰ h₂).lookup l).any (valid (α := val))

infixr:55 " ⊥ʰ " => validInter

lemma validInter_hop_distr_l (h₁ h₂ h₃ : heap) :
  (h₁ +ʰ h₂) ⊥ʰ h₃ -> (h₁ ⊥ʰ h₃ ∧ h₂ ⊥ʰ h₃) :=

:= by
  simp [validInter]
  move=> h ⟨|⟩ l /[tac (specialize h l)]-- | [] h1 h2 l [] /[tac (specialize h1 l; specialize h2 l)] ⟩
  all_goals (move=> /[dup] hin1 /[swap] /[dup] hin2)
  all_goals (srw [1]Finmap.mem_iff=> []v3 hv3 ; srw Finmap.mem_iff=> []v hv)
  all_goals (srw hv hv3 at h ⊢)
  all_goals (dsimp [Option.merge]; try solve
    | aesop)
  { move: h; scase: (Finmap.lookup l h₂)=> > //==
    all_goals (simp [Option.merge]=> //)
    srw add_assoc (add_comm _ v3) -add_assoc
    have hq := fun y => PartialCommMonoid.valid_add (v + v3) (y := y)
    aesop }
  { move: h; scase: (Finmap.lookup l h₁)=> > //==
    all_goals (simp [Option.merge]=> //)
    srw add_assoc [1]add_comm
    have hq := fun y => PartialCommMonoid.valid_add (v + v3) (y := y)
    aesop }


notation:max "emp" => hempty

syntax "fun" ident+ " => " lang : lang

syntax "⟨" term "⟩" : lang

syntax "⟨" term ":" term "⟩" : lang

macro "xsimp" : tactic =>

macro "xsimp" : tactic =>
  `(tactic| (
    xsimp_start
    repeat xsimp_step
    try rev_pure
    try hide_mvars
    try hsimp
    rotate_left

  ))

macro "xif" : tactic => do

macro "xif" : tactic => do
  `(tactic|
  (xseq_xlet_if_needed; xstruct_if_needed; apply xif_lemma))

macro "xif" : tactic => `(tactic| (xwp; xif))

syntax " := " : bop

macro "xstruct" : tactic => do

macro "xstruct" : tactic => do
  `(tactic| apply xstruct_lemma)

macro "xval" : tactic => do

macro "xval" : tactic => do
  `(tactic| (xstruct_if_needed; apply xval_lemma))

macro "xval" : tactic => `(tactic| (xwp; xval))

macro "xapp" : tactic =>

macro "xapp" : tactic =>
  `(tactic|
    (xapp_nosubst;
     try xapp_try_subst
     first
       | done
       | all_goals try srw wp_equiv
         all_goals try subst_vars))

notation:max "⌜" P "⌝" => hpure P

macro "xwp" : tactic =>

macro "xwp" : tactic =>
  `(tactic|
    (intros
     first | apply xwp_lemma_fix; rfl
           | apply xwp_lemma_fun; rfl))

macro "xwp" : tactic =>
  `(tactic|
    (intros
     try srw trm_apps1
     srw ?trm_apps2
     first

           | (apply xwp_lemma_funs; rfl; rfl; rfl; sdone)=> //
           | apply wp_of_wpgen
     all_goals try simp [wpgen, subst, isubst, subst, trm_apps, AList.lookup, List.dlookup]))

macro "xseq" : tactic => do

macro "xseq" : tactic => do
  `(tactic| (xstruct_if_needed; apply xseq_lemma))

macro "xchange" l:term : tactic =>

macro "xchange" l:term : tactic =>
  `(tactic| (xchange_core $l; xsimp))

macro "∃ʰ" xs:Lean.explicitBinders ", " b:term : term => Lean.expandExplicitBinders ``hexists xs b

macro "xpull" : tactic =>

macro "xpull" : tactic =>
  `(tactic| (
    xpull_start
    repeat' xsimp_step
    try rev_pure
    hsimp
  ))

macro_rules
  | `([lang| ()])                       => `(trm_val (val_unit))
  | `([lang| $n:num])                   => `(trm_val (val_int $n))
  | `([lang| $t1 $t2])                  => `(trm_app [lang| $t1] [lang| $t2])
  | `([lang| if $t1 then $t2 else $t3]) => `(trm_if [lang| $t1] [lang| $t2] [lang| $t3])
  | `([lang| if $t1 then $t2 end])      => `(trm_if [lang| $t1] [lang| $t2] (trm_val val_unit))
  | `([lang| let $x := $t1:lang in $t2:lang])     =>
    `(trm_let $(%x) [lang| $t1] [lang| $t2])
  | `([lang| ref $x := $t1:lang in $t2:lang])     =>
    `(trm_ref $(%x) [lang| $t1] [lang| $t2])
  | `([lang| alloc $t1:lang as $x in $t2:lang])   =>
    `(trm_alloc $(%x) [lang| $t1] [lang| $t2])
  | `([lang| $t1 ; $t2])                => `(trm_seq [lang| $t1] [lang| $t2])
  | `([lang| fun_ $xs* => $t])             => do
    let xs <- xs.mapM fun x => `(term| $(%x))
    `(trm_funs [ $xs,* ] [lang| $t])
  | `([lang| fun $xs* => $t])             => do
    let xs <- xs.mapM fun x => `(term| $(%x))
    `(val_funs [ $xs,* ] [lang| $t])
  | `([lang| fix_ $f $xs* => $t])    => do
      let xs <- xs.mapM fun x => `(term| $(%x))
      `(trm_fixs $(%f) [ $xs,* ] [lang| $t])
  | `([lang| fix $f $xs* => $t])    => do
      let xs <- xs.mapM fun x => `(term| $(%x))
      `(val_fixs $(%f) [ $xs,* ] [lang| $t])

  | `([lang| free $t])                  => `(trm_val (val_prim val_free) [lang| $t])
  | `([lang| not $t])                   => `(trm_val (val_prim val_not) [lang| $t])

  | `([lang| !$t])                      => `(trm_val val_get [lang| $t])
  | `([lang| $t1 := $t2])               => `(trm_val val_set [lang| $t1] [lang| $t2])
  | `([lang| $t1 + $t2])                => `(trm_val val_add [lang| $t1] [lang| $t2])
  | `([lang| $t1 * $t2])                => `(trm_val val_mul [lang| $t1] [lang| $t2])
  | `([lang| $t1 - $t2])                => `(trm_val val_sub [lang| $t1] [lang| $t2])
  | `([lang| $t1 / $t2])                => `(trm_val val_div [lang| $t1] [lang| $t2])
  | `([lang| $t1 < $t2])                => `(trm_val val_lt [lang| $t1] [lang| $t2])
  | `([lang| $t1 > $t2])                => `(trm_val val_gt [lang| $t1] [lang| $t2])
  | `([lang| $t1 <= $t2])               => `(trm_val val_le [lang| $t1] [lang| $t2])
  | `([lang| $t1 >= $t2])               => `(trm_val val_ge [lang| $t1] [lang| $t2])
  | `([lang| -$t])                      => `(trm_val val_opp [lang| $t])
  | `([lang| $t1 = $t2])                => `(trm_val val_eq [lang| $t1] [lang| $t2])
  | `([lang| $t1 != $t2])               => `(trm_val val_neq [lang| $t1] [lang| $t2])
  | `([lang| $t1 mod $t2])              => `(trm_val val_mod [lang| $t1] [lang| $t2])
  | `([lang| $t1 ++ $t2])               => `(trm_val val_ptr_add [lang| $t1] [lang| $t2])
  | `([lang| ($t)]) => `([lang| $t])
  | `([lang| ⟨$t : $tp⟩]) => `(trm_val (($t : $tp)))
  | `([lang| for $x in [$n1 : $n2] { $t } ]) =>
    `(trm_for $(%x) [lang| $n1] [lang| $n2] [lang| $t])
  | `([lang| while $c:lang { $t:lang } ]) =>
     `(trm_while [lang| $c] [lang| $t] )

macro_rules
  | `([lang| len $p])                => `(trm_val val_array_length [lang| $p])
  | `([lang| $arr[$i] ])              => `(trm_val val_array_get [lang| $arr] [lang| $i])

  | `([lang| $arr[$i] := $v])        => `(trm_app val_array_set [lang| $arr] [lang| $i] [lang| $v])
  | `([lang| mkarr $n:lang $v:lang]) => `(trm_val val_array_make [lang| $n] [lang| $v])

macro_rules
  | `({ $P }[$t:lang]{$v, $Q}) => `(triple [lang| $t] $P (fun $v => $Q))
  | `({ $P }[$t:lang]{$Q})     => `(triple [lang| $t] $P (fun _ => $Q))
  | `(WP[$t:lang]{$v, $Q})     => `(wp [lang| $t] (fun $v => $Q))
  | `(WP[$t:lang]{$Q})         => `(wp [lang| $t] (fun _ => $Q))

macro_rules
  | `(tactic| xstep $(t)? ) => `(tactic| (xwp; xapp $(t)?))

macro_rules | `($x ∗ $y)   => `(binop% HStar.hStar $x $y)

  inductive trm : Type where
    | trm_val   : val -> trm
    | trm_var   : var -> trm
    | trm_fun   : var -> trm -> trm
    | trm_fix   : var -> var -> trm -> trm
    | trm_app   : trm -> trm -> trm
    | trm_seq   : trm -> trm -> trm
    | trm_let   : var -> trm -> trm -> trm
    | trm_if    : trm -> trm -> trm -> trm
    | trm_for   : var -> trm -> trm -> trm -> trm
    | trm_while : trm -> trm -> trm
    | trm_ref   : var → trm → trm → trm
    | trm_alloc : var → trm → trm → trm

  inductive val : Type where
    | val_unit   : val
    | val_bool   : Bool → val
    | val_int    : Int → val
    | val_real   : ℝ → val
    | val_loc    : loc → val
    | val_prim   : prim → val
    | val_fun    : var -> trm -> val
    | val_fix    : var -> var -> trm -> val
    | val_uninit : val
    | val_error : val

prim

inductive prim where

  | val_get : prim
  | val_set : prim

  | val_neg : prim
  | val_opp : prim
  | val_eq : prim
  | val_add : prim
  | val_neq : prim
  | val_sub : prim
  | val_mul : prim
  | val_div : prim
  | val_mod : prim

  | val_le : prim
  | val_lt : prim
  | val_ge : prim
  | val_gt : prim
  | val_ptr_add : prim

var

abbrev var := String

loc

abbrev loc := Nat

hProp

def hProp := heap -> Prop

heap

abbrev heap := Heap.heap val

Heap.heap

abbrev Heap.heap (val : Type) := Finmap (λ _ : loc ↦ val)

eval

inductive eval : state → trm → (val → state → Prop) -> Prop where
  | eval_val : forall s v Q,
      Q v s ->
      eval s (trm_val v) Q
  | eval_fun : forall s x t1 Q,
      Q (val_fun x t1) s ->
      eval s (trm_fun x t1) Q
  | eval_fix : forall s f x t1 Q,
      Q (val_fix f x t1) s ->
      eval s (trm_fix f x t1) Q
  | eval_app_arg1 : forall s1 t1 t2 Q1 Q,
      ¬ trm_is_val t1 ->
      eval s1 t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> eval s2 (trm_app v1 t2) Q) ->
      eval s1 (trm_app t1 t2) Q
  | eval_app_arg2 : forall s1 (v1 : val) t2 Q1 Q,
      ¬ trm_is_val t2 ->
      eval s1 t2 Q1 ->
      (forall v2 s2, Q1 v2 s2 -> eval s2 (trm_app v1 v2) Q) ->
      eval s1 (trm_app v1 t2) Q
  | eval_app_fun : forall s1 v1 (v2 :val) x t1 Q,
      v1 = val_fun x t1 ->
      eval s1 (subst x v2 t1) Q ->
      eval s1 (trm_app v1 v2) Q
  | eval_app_fix : forall s (v1 v2 : val) f x t1 Q,
      v1 = val_fix f x t1 ->
      eval s (subst x v2 (subst f v1 t1)) Q ->
      eval s (trm_app v1 v2) Q
  | eval_seq : forall Q1 s t1 t2 Q,
      eval s t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> eval s2 t2 Q) ->
      eval s (trm_seq t1 t2) Q
  | eval_let : forall Q1 s x t1 t2 Q,
      eval s t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> eval s2 (subst x v1 t2) Q) ->
      eval s (trm_let x t1 t2) Q
  | eval_if : forall s (b : Bool) t1 t2 Q,
      eval s (if b then t1 else t2) Q ->
      eval s (trm_if (val_bool b) t1 t2) Q
  | eval_unop : forall op s v1 P Q,
      evalunop op v1 P ->
      purepostin s P Q ->
      eval s (trm_app op v1) Q
  | eval_binop : forall op s (v1 v2 : val) P Q,
      evalbinop op v1 v2 P ->
      purepostin s P Q ->
      eval s (trm_app (trm_app op v1) v2) Q
  | eval_ref : forall s x t1 t2 (Q Q₁ : val → state → Prop),
    eval s t1 Q₁ →
    (∀ v1 s1, Q₁ v1 s1 → ∀ p ∉ s1,
     eval (s1.insert p v1) (subst x p t2) fun v s ↦ Q v (s.erase p)) →
    eval s (trm_ref x t1 t2) Q
  | eval_get : forall s p Q,
      p ∈ s ->
      Q (read_state p s) s ->
      eval s (trm_app val_get (val_loc p)) Q
  | eval_set : forall s p v Q,
      v = trm_val v' ->
      p ∈ s ->
      Q val_unit (Finmap.insert p v' s) ->
      eval s (trm_app (trm_app val_set (val_loc p)) v) Q
  | eval_alloc_arg : forall s Q₁ Q,
    ¬ trm_is_val t1 →
    eval s t1 Q₁ →
    (∀ v' s', Q₁ v' s' → eval s' (trm_alloc x v' t2) Q) →
    eval s (trm_alloc x t1 t2) Q
  | eval_alloc : forall (sa : state) (n : ℤ) Q,
    n ≥ 0 →
    (∀ (p : loc) (sb : state),
      sb = conseq (make_list n.natAbs val_uninit) p →
      p ≠ null →
      Finmap.Disjoint sa sb →
      eval (sb ∪ sa) (subst x p t2) fun v s ↦ Q v (s \ sb)) →
    eval sa (trm_alloc x n t2) Q

  | eval_for (n₁ n₂ : Int) (Q : val -> state -> Prop) :
    eval s (if (n₁ < n₂) then
               (trm_seq (subst x n₁ t₁) (trm_for x (val_int (n₁ + 1)) n₂ t₁))
            else val_unit) Q ->
    eval s (trm_for x n₁ n₂ t₁) Q
  | eval_while (t₁ t₂ : trm) (Q : val -> state -> Prop) :
    eval s t₁ Q₁ ->
    (∀ s v, Q₁ v s -> eval s (trm_if v (trm_seq t₂ (trm_while t₁ t₂)) val_unit) Q) ->
    eval s (trm_while t₁ t₂) Q

HStar

class HStar (α : Type u) (β : Type v) (γ : outParam (Type w)) where

  hStar : α → β → γ

hpure

def hpure (P : Prop) : hProp :=
  hexists (fun (_ : P) => emp)

hexists

def hexists {A} (J : A → hProp) : hProp :=
  fun h => exists x, J x h

hempty

def hempty : hProp :=
  fun h => (h = ∅)

himpl

abbrev himpl (H1 H2 : hProp) : Prop :=
  forall h, H1 h -> H2 h

qimpl

def qimpl {A} (Q1 Q2 : A → hProp) : Prop :=
  forall (v:A), Q1 v ==> Q2 v

purepostin

def purepostin (s : state) (P : val → Prop) (Q : val → state → Prop) : Prop :=

  forall v, P v → Q v s

state

abbrev state := Finmap (λ _ : loc ↦ val)

tohProp

abbrev tohProp (h : heap -> Prop) : hProp := h

ofhProp

abbrev ofhProp (h : val -> hProp) : val -> heap -> Prop := h

infixr:51 " ==> " => himpl

infixr:51 " ===> " => qimpl

notation:max "emp" => hempty

infixr:55 " ∗ " => HStar.hStar

notation:max "⌜" P "⌝" => hpure P

fun

notation "funloc" p "↦" H =>
  fun (r : val) ↦ hexists (fun p ↦ ⌜r = val_loc p⌝ ∗ H)

lemma eval_conseq s t Q1 Q2 :
  eval s t Q1 →
  Q1 ===> Q2 →
  eval s t Q2

qstarE

lemma qstarE α (Q1 : α → hProp)  (H : hProp):
  Q1 ∗ H = fun x => Q1 x ∗ H

lemma eval_frame (h1 h2 : state) t (Q : val -> hProp) :
  eval h1 t (ofhProp Q) →
  Finmap.Disjoint h1 h2 →
  eval (h1 ∪ h2) t (Q ∗ (tohProp (fun h ↦ h = h2)))

lemma hstar_comm H1 H2 :
  H1 ∗ H2 = H2 ∗ H1

lemma hprop_op_comm (op : hProp → hProp → hProp) :
  (forall H1 H2, op H1 H2 ==> op H2 H1) →
  (forall H1 H2, op H1 H2 = op H2 H1)

lemma himpl_antisym H1 H2:
  (H1 ==> H2) → (H2 ==> H1) → (H1 = H2)

lemma hstar_inv (H1 H2 : hProp) h:
  (H1 ∗ H2) h →
  exists h1 h2, H1 h1 ∧ H2 h2 ∧ Finmap.Disjoint h1 h2 ∧ h = h1 ∪ h2

lemma himpl_trans H2 H1 H3 :
  (H1 ==> H2) → (H2 ==> H3) → (H1 ==> H3)

Theories.wp

def wp (t : trm) (Q : val → hProp) : hProp :=
  fun s ↦ eval s t Q

lemma wp_conseq t Q1 Q2 :
  Q1 ===> Q2 →
  wp t Q1 ==> wp t Q2

lemma wp_frame t H Q :
  (wp t Q) ∗ H ==> wp t (Q ∗ H)

lemma xwhile_inv_basic_lemma (I : Bool -> α -> hProp) R
  -- (F1 F2 : formula)
  :
  WellFounded R ->
  -- structural F1 ->
  -- structural F2 ->
  (H ==> H' ∗ ∃ʰ b a, I b a) ->
  (∀ b X, I b X ==> wp F1 (fun bv => I b X ∗ ⌜bv = b⌝)) ->
  (∀ X, I true X ==> wp F2 (fun _ => ∃ʰ b X', ⌜R X' X⌝ ∗ I b X')) ->
  H ==> wp (trm_while F1 F2) (fun _ => H' ∗ ∃ʰ a, I false a) :=

:= by
  move=> wf hini hf1 hf2
  xchange hini=> b sR
  move: b
  apply WellFounded.induction wf sR=> X ih []
  -- apply eval.eval_while
  -- unfold wpgen_while ; unfold_let ; xstruct ; xsimp=> [] sR hstep; rename_i wfR
  -- frame H' out, using `structural`?
  { xchange hf1
    apply himpl_trans;  rotate_left
    { srw hstar_comm; apply wp_frame }
    xsimp
    apply himpl_trans; rotate_left
    { move=> ? H
      apply eval.eval_while; apply H
      move=> > // }
    apply wp_conseq=> ? /=; xpull
    xwp; xif=> // _; xwp; xval; xsimp }
  -- move: sR
  -- apply himpl_trans;  rotate_left
  -- { srw hstar_comm; apply wp_frame }
  -- xsimp
  apply himpl_trans; rotate_left
  { move=> ? H
    apply eval.eval_while; apply H
    move=> > // }
  xchange hf1
  apply himpl_trans; apply wp_frame

  apply wp_conseq=> ? /==; srw qstarE /=; xpull
  xwp; xif=> // _
  xwp; xseq; xapp hf2=> // ?? /ih;
  srw [2]hstar_comm //; sapply


theorem List.getElem_append_left{α : Type u_1} {l₁ l₂ : List α} {i : Nat} (hn : i < l₁.length) :\n(l₁ ++ l₂)[i] = l₁[i]

loc

abbrev loc := Nat

private def kmerge1 (l : loc) (v : val) (l₂ : List (Sigma (fun _ : loc => val))) : val :=
  match l₂.dlookup l with
  | .some v' => v + v'
  | _ => v

kmerge

@[simp]
def kmerge : List (Sigma (fun _ : loc => val)) → List (Sigma (fun _ : loc => val)) → List (Sigma (fun _ : loc => val))
  | [], l₂ => l₂
  | s :: l₁, l₂ =>
    (if s.1 ∈ l₂.keys then
      ⟨s.1, kmerge1 s.1 s.2 l₂⟩ :: kmerge l₁ (l₂.kerase s.1)
    else s :: kmerge l₁ l₂)

lemma List.kerase_noterased {α : Type u} {β : α → Type v} [DecidableEq α] (l : List (Sigma β))
  (a a' : α) (hneq : a ≠ a') (b : β a) : ⟨a, b⟩ ∈ l ↔ ⟨a, b⟩ ∈ List.kerase a' l

lemma Option.merge_assoc (h : Associative f) (a b c : Option α) :
  Option.merge f (Option.merge f a b) c = Option.merge f a (Option.merge f b c)

@[simp]
lemma kmerge_mem (l₁ : List (Sigma (fun _ : loc => val))) : l ∈ (kmerge l₁ l₂).keys ↔ l ∈ l₁.keys ∨ l ∈ l₂.keys

lemma kmerge_mem2 (l₁ l₂ : List (Sigma (fun _ : loc => val))) (nd₁ : l₁.NodupKeys) (nd₂ : l₂.NodupKeys) -- necessary
    (a : Sigma (fun _ : loc => val)) : a ∈ (kmerge l₁ l₂) ↔
      if a.1 ∈ l₁.keys
      then (if a.1 ∈ l₂.keys then Option.merge (· + ·) (l₁.dlookup a.1) (l₂.dlookup a.1) = .some a.2 else a ∈ l₁)
      else a ∈ l₂

lemma kmerge_dlookup (l₁ l₂ : List (Sigma (fun _ : loc => val))) (nd₁ : l₁.NodupKeys) (nd₂ : l₂.NodupKeys)
    (a : loc) : (kmerge l₁ l₂).dlookup a = Option.merge (· + ·) (l₁.dlookup a) (l₂.dlookup a)

lemma kmerge_NodupKeys (l₁ l₂ : List (Sigma (fun _ : loc => val))) (nd₁ : l₁.NodupKeys) (nd₂ : l₂.NodupKeys) : (kmerge l₁ l₂).NodupKeys

lemma kmerge_assoc_perm (l₁ l₂ l₃ : List (Sigma (fun _ : loc => val))) (nd₁ : l₁.NodupKeys) (nd₂ : l₂.NodupKeys) (nd₃ : l₃.NodupKeys) :
  (kmerge (kmerge l₁ l₂) l₃).Perm $ (kmerge l₁ (kmerge l₂ l₃)) :=

:= by
  apply List.lookup_ext <;> try (repeat'(apply kmerge_NodupKeys=> //))
  move=> l v
  (srw !kmerge_dlookup=> //) <;> try (repeat'(apply kmerge_NodupKeys=> //))
  rw [Option.merge_assoc]=> // ; apply add_assoc


heap

abbrev heap := Heap.heap val

  inductive val : Type where
    | val_unit   : val
    | val_bool   : Bool → val
    | val_int    : Int → val
    | val_real   : ℝ → val
    | val_loc    : loc → val
    | val_prim   : prim → val
    | val_fun    : var -> trm -> val
    | val_fix    : var -> var -> trm -> val
    | val_uninit : val
    | val_error : val

prim

inductive prim where

  | val_get : prim
  | val_set : prim

  | val_neg : prim
  | val_opp : prim
  | val_eq : prim
  | val_add : prim
  | val_neq : prim
  | val_sub : prim
  | val_mul : prim
  | val_div : prim
  | val_mod : prim

  | val_le : prim
  | val_lt : prim
  | val_ge : prim
  | val_gt : prim
  | val_ptr_add : prim

  inductive trm : Type where
    | trm_val   : val -> trm
    | trm_var   : var -> trm
    | trm_fun   : var -> trm -> trm
    | trm_fix   : var -> var -> trm -> trm
    | trm_app   : trm -> trm -> trm
    | trm_seq   : trm -> trm -> trm
    | trm_let   : var -> trm -> trm -> trm
    | trm_if    : trm -> trm -> trm -> trm
    | trm_for   : var -> trm -> trm -> trm -> trm
    | trm_while : trm -> trm -> trm
    | trm_ref   : var → trm → trm → trm
    | trm_alloc : var → trm → trm → trm

scoped instance : PartialCommMonoid val where
  add := add
  add_assoc := by admit /- proof elided -/

add

@[simp]
abbrev add : val -> val -> val
  | .val_int i, .val_int j => val.val_int (i + j)
  | _, _ => val.val_unit

evalExact

inductive evalExact : state → trm → (val → state → Prop) -> Prop where
  | val : forall s v,
      evalExact s (trm_val v) (fun v' s' ↦ v' = v ∧ s' = s)
  | fun : forall s x t1,
      evalExact s (trm_fun x t1) (fun v' s' ↦ v' = val_fun x t1 ∧ s' = s)
  | fix : forall s f x t1,
      evalExact s (trm_fix f x t1) (fun v' s' ↦ v' = val_fix f x t1 ∧ s' = s)
  | app_arg1 : forall s1 t1 t2 Q1 Q,
      ¬ trm_is_val t1 ->
      evalExact s1 t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> evalExact s2 (trm_app v1 t2) Q) ->
      evalExact s1 (trm_app t1 t2) Q
  | app_arg2 : forall s1 (v1 : val) t2 Q1 Q,
      ¬ trm_is_val t2 ->
      evalExact s1 t2 Q1 ->
      (forall v2 s2, Q1 v2 s2 -> evalExact s2 (trm_app v1 v2) Q) ->
      evalExact s1 (trm_app v1 t2) Q
  | app_fun : forall s1 v1 (v2 :val) x t1 Q,
      v1 = val_fun x t1 ->
      evalExact s1 (subst x v2 t1) Q ->
      evalExact s1 (trm_app v1 v2) Q
  | app_fix : forall s (v1 v2 : val) f x t1 Q,
      v1 = val_fix f x t1 ->
      evalExact s (subst x v2 (subst f v1 t1)) Q ->
      evalExact s (trm_app v1 v2) Q
  | seq : forall Q1 s t1 t2 Q,
      evalExact s t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> evalExact s2 t2 Q) ->
      evalExact s (trm_seq t1 t2) Q
  | let : forall Q1 s x t1 t2 Q,
      evalExact s t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> evalExact s2 (subst x v1 t2) Q) ->
      evalExact s (trm_let x t1 t2) Q
  | if : forall s (b : Bool) t1 t2 Q,
      evalExact s (if b then t1 else t2) Q ->
      evalExact s (trm_if (val_bool b) t1 t2) Q
  | unop : forall op s v1 P,
      evalunop op v1 P ->
      evalExact s (trm_app op v1) (purepost s P)
  | binop : forall op s (v1 v2 : val) P,
      evalbinop op v1 v2 P ->
      evalExact s (trm_app (trm_app op v1) v2) (purepost s P)
  | ref : forall s x t1 t2 Q Q₁,
    evalExact s t1 Q₁ →
    (∀ v1 s1, Q₁ v1 s1 → ∀ p ∉ s1,
     evalExact (s1.insert p v1) (subst x p t2) fun v s ↦ Q v (s.erase p)) →
      evalExact s (trm_ref x t1 t2) Q
  | get : forall s p,
      p ∈ s ->
      evalExact s (trm_app val_get (val_loc p))
        (fun v' s' ↦ v' = read_state p s ∧ s' = s)
  | set : forall s p v,
      v = trm_val v' ->
      p ∈ s ->
      evalExact s (trm_app (trm_app val_set (val_loc p)) v)
        (fun v'' s' ↦ v'' = val_unit ∧ s' = s.insert p v')
  | alloc_arg : forall s Q₁ Q,
    ¬ trm_is_val t1 →
    evalExact s t1 Q₁ →
    (∀ v' s', Q₁ v' s' → evalExact s' (trm_alloc x v' t2) Q) →
    evalExact s (trm_alloc x t1 t2) Q
  | alloc : forall (sa : state) (n : ℤ) Q,
    n ≥ 0 →
    (∀ (p : loc) (sb : state),
      sb = conseq (make_list n.natAbs val_uninit) p →
      p ≠ null →
      Finmap.Disjoint sa sb →
      evalExact (sb ∪ sa) (subst x p t2) fun v s ↦ Q v (s \ sb)) →
    evalExact sa (trm_alloc x n t2) Q

  | for (n₁ n₂ : Int) (Q : val -> state -> Prop) :
    evalExact s (if (n₁ < n₂) then
               (trm_seq (subst x n₁ t₁) (trm_for x (val_int (n₁ + 1)) n₂ t₁))
            else val_unit) Q ->
    evalExact s (trm_for x n₁ n₂ t₁) Q
  | while (t₁ t₂ : trm) (Q Q₁ : val -> state -> Prop) :
    evalExact s t₁ Q₁ ->
    (∀ s v, Q₁ v s -> evalExact s (trm_if v (trm_seq t₂ (trm_while t₁ t₂)) val_unit) Q) ->
    evalExact s (trm_while t₁ t₂) Q

valid

@[simp]
abbrev valid : val -> Prop
  | .val_int _ => True
  | _ => False

PartialCommMonoid

class PartialCommMonoid (α : Type) extends AddCommSemigroup α where
  valid : α -> Prop
  valid_add : ∀ x, valid (x + y) -> valid x
  add_valid : ∀ x y, valid x -> valid y -> valid (x + y)

scoped instance inst : PartialCommMonoidWRT val add valid where
  validE := by admit /- proof elided -/

AddCommMonoidWRT

class AddCommMonoidWRT (α : Type) (add' : semiOutParam $ α -> α -> α) extends AddCommMonoid α where
  addE : (· + ·) = add'

add

@[simp]
abbrev add : val -> val -> val
  | .val_bool i, .val_bool j => val.val_bool (i || j)
  | _, _ => val.val_unit

valid

@[simp]
abbrev valid : val -> Prop
  | .val_bool _ => True
  | _ => False

add

@[simp]
abbrev add : val -> val -> val
  | .val_real i, .val_real j => val.val_real (i + j)
  | _, _ => val.val_unit

valid

@[simp]
abbrev valid : val -> Prop
  | .val_real _ => True
  | _ => False

theorem List.getElem_append_left{α : Type u_1} {l₁ l₂ : List α} {i : Nat} (hn : i < l₁.length) :\n(l₁ ++ l₂)[i] = l₁[i]

loc

abbrev loc := Nat

var

abbrev var := String

Heap.heap

abbrev Heap.heap (val : Type) := Finmap (λ _ : loc ↦ val)

private def kmerge1 (l : loc) (v : val) (l₂ : List (Sigma (fun _ : loc => val))) : val :=
  match l₂.dlookup l with
  | .some v' => v + v'
  | _ => v

kmerge

@[simp]
def kmerge : List (Sigma (fun _ : loc => val)) → List (Sigma (fun _ : loc => val)) → List (Sigma (fun _ : loc => val))
  | [], l₂ => l₂
  | s :: l₁, l₂ =>
    (if s.1 ∈ l₂.keys then
      ⟨s.1, kmerge1 s.1 s.2 l₂⟩ :: kmerge l₁ (l₂.kerase s.1)
    else s :: kmerge l₁ l₂)

AList.merge

noncomputable def AList.merge (h₁ h₂ : AList (fun _ : loc => val)) :  AList (fun _ : loc => val) :=
  ⟨kmerge h₁.entries h₂.entries, by admit /- proof elided -/
    ⟩

Heap.add

noncomputable def Heap.add (h₁ h₂ : heap) : heap :=
  Finmap.liftOn₂ h₁ h₂ (fun h₁ h₂ => (h₁.merge h₂).toFinmap) (by admit /- proof elided -/
    )

validInter

def validInter (h₁ h₂ : heap) : Prop :=
  ∀ l ∈ h₁, l ∈ h₂ -> ((h₁ +ʰ h₂).lookup l).any (valid (α := val))

lemma Option.merge_none_l (a : Option α) : Option.merge f none a = a

lemma Option.merge_assoc (h : Associative f) (a b c : Option α) :
  Option.merge f (Option.merge f a b) c = Option.merge f a (Option.merge f b c)

lemma validInter_assoc_r (h₁ h₂ h₃ : heap) :
  h₂ ⊥ʰ h₃ -> h₁ ⊥ʰ (h₂ +ʰ h₃) -> (h₁ +ʰ h₂) ⊥ʰ h₃ :=

:= by
  simp [validInter]
  move=> h1' h2' l /[swap] hin3 /[tac (have h1 := (fun H => h1' _ H hin3) ; have h2 := (fun H => h2' _ H (Or.intro_right _ hin3)) ; clear h1' h2')] [ hin1 | hin2 ]
  { rw [Option.merge_assoc, h2]=> //
    apply add_assoc }
  { rcases h : Finmap.lookup l h₁
    { rw [Option.merge_none_l] ; aesop }
    { srw h at h2 ; rw [Option.merge_assoc, h2] ; apply Finmap.mem_of_lookup_eq_some at h=> //
      apply add_assoc } }


import Mathlib.Data.Finmap
import SPLean.Common.State
import SPLean.Theories.HProp
import SPLean.Common.Util
import Mathlib.Data.Multiset.Nodup
import SPLean.Theories.XSimp
import Mathlib.Data.Finset.Basic

notation:max "emp" => hempty

syntax "fun" ident+ " => " lang : lang

macro_rules
  | `([lang| ()])                       => `(trm_val (val_unit))
  | `([lang| $n:num])                   => `(trm_val (val_int $n))
  | `([lang| $t1 $t2])                  => `(trm_app [lang| $t1] [lang| $t2])
  | `([lang| if $t1 then $t2 else $t3]) => `(trm_if [lang| $t1] [lang| $t2] [lang| $t3])
  | `([lang| if $t1 then $t2 end])      => `(trm_if [lang| $t1] [lang| $t2] (trm_val val_unit))
  | `([lang| let $x := $t1:lang in $t2:lang])     =>
    `(trm_let $(%x) [lang| $t1] [lang| $t2])
  | `([lang| ref $x := $t1:lang in $t2:lang])     =>
    `(trm_ref $(%x) [lang| $t1] [lang| $t2])
  | `([lang| alloc $t1:lang as $x in $t2:lang])   =>
    `(trm_alloc $(%x) [lang| $t1] [lang| $t2])
  | `([lang| $t1 ; $t2])                => `(trm_seq [lang| $t1] [lang| $t2])
  | `([lang| fun_ $xs* => $t])             => do
    let xs <- xs.mapM fun x => `(term| $(%x))
    `(trm_funs [ $xs,* ] [lang| $t])
  | `([lang| fun $xs* => $t])             => do
    let xs <- xs.mapM fun x => `(term| $(%x))
    `(val_funs [ $xs,* ] [lang| $t])
  | `([lang| fix_ $f $xs* => $t])    => do
      let xs <- xs.mapM fun x => `(term| $(%x))
      `(trm_fixs $(%f) [ $xs,* ] [lang| $t])
  | `([lang| fix $f $xs* => $t])    => do
      let xs <- xs.mapM fun x => `(term| $(%x))
      `(val_fixs $(%f) [ $xs,* ] [lang| $t])

  | `([lang| free $t])                  => `(trm_val (val_prim val_free) [lang| $t])
  | `([lang| not $t])                   => `(trm_val (val_prim val_not) [lang| $t])

  | `([lang| !$t])                      => `(trm_val val_get [lang| $t])
  | `([lang| $t1 := $t2])               => `(trm_val val_set [lang| $t1] [lang| $t2])
  | `([lang| $t1 + $t2])                => `(trm_val val_add [lang| $t1] [lang| $t2])
  | `([lang| $t1 * $t2])                => `(trm_val val_mul [lang| $t1] [lang| $t2])
  | `([lang| $t1 - $t2])                => `(trm_val val_sub [lang| $t1] [lang| $t2])
  | `([lang| $t1 / $t2])                => `(trm_val val_div [lang| $t1] [lang| $t2])
  | `([lang| $t1 < $t2])                => `(trm_val val_lt [lang| $t1] [lang| $t2])
  | `([lang| $t1 > $t2])                => `(trm_val val_gt [lang| $t1] [lang| $t2])
  | `([lang| $t1 <= $t2])               => `(trm_val val_le [lang| $t1] [lang| $t2])
  | `([lang| $t1 >= $t2])               => `(trm_val val_ge [lang| $t1] [lang| $t2])
  | `([lang| -$t])                      => `(trm_val val_opp [lang| $t])
  | `([lang| $t1 = $t2])                => `(trm_val val_eq [lang| $t1] [lang| $t2])
  | `([lang| $t1 != $t2])               => `(trm_val val_neq [lang| $t1] [lang| $t2])
  | `([lang| $t1 mod $t2])              => `(trm_val val_mod [lang| $t1] [lang| $t2])
  | `([lang| $t1 ++ $t2])               => `(trm_val val_ptr_add [lang| $t1] [lang| $t2])
  | `([lang| ($t)]) => `([lang| $t])
  | `([lang| ⟨$t : $tp⟩]) => `(trm_val (($t : $tp)))
  | `([lang| for $x in [$n1 : $n2] { $t } ]) =>
    `(trm_for $(%x) [lang| $n1] [lang| $n2] [lang| $t])
  | `([lang| while $c:lang { $t:lang } ]) =>
     `(trm_while [lang| $c] [lang| $t] )

macro_rules
  | `([lang| len $p])                => `(trm_val val_array_length [lang| $p])
  | `([lang| $arr[$i] ])              => `(trm_val val_array_get [lang| $arr] [lang| $i])

  | `([lang| $arr[$i] := $v])        => `(trm_app val_array_set [lang| $arr] [lang| $i] [lang| $v])
  | `([lang| mkarr $n:lang $v:lang]) => `(trm_val val_array_make [lang| $n] [lang| $v])

macro_rules | `($x ∗ $y)   => `(binop% HStar.hStar $x $y)

HStar

class HStar (α : Type u) (β : Type v) (γ : outParam (Type w)) where

  hStar : α → β → γ

hsingle

def hsingle (p : loc) (v : val) : hProp :=
  fun h => (h = Finmap.singleton p v)

hProp

def hProp := heap -> Prop

heap

abbrev heap := Heap.heap val

  inductive val : Type where
    | val_unit   : val
    | val_bool   : Bool → val
    | val_int    : Int → val
    | val_real   : ℝ → val
    | val_loc    : loc → val
    | val_prim   : prim → val
    | val_fun    : var -> trm -> val
    | val_fix    : var -> var -> trm -> val
    | val_uninit : val
    | val_error : val

prim

inductive prim where

  | val_get : prim
  | val_set : prim

  | val_neg : prim
  | val_opp : prim
  | val_eq : prim
  | val_add : prim
  | val_neq : prim
  | val_sub : prim
  | val_mul : prim
  | val_div : prim
  | val_mod : prim

  | val_le : prim
  | val_lt : prim
  | val_ge : prim
  | val_gt : prim
  | val_ptr_add : prim

  inductive trm : Type where
    | trm_val   : val -> trm
    | trm_var   : var -> trm
    | trm_fun   : var -> trm -> trm
    | trm_fix   : var -> var -> trm -> trm
    | trm_app   : trm -> trm -> trm
    | trm_seq   : trm -> trm -> trm
    | trm_let   : var -> trm -> trm -> trm
    | trm_if    : trm -> trm -> trm -> trm
    | trm_for   : var -> trm -> trm -> trm -> trm
    | trm_while : trm -> trm -> trm
    | trm_ref   : var → trm → trm → trm
    | trm_alloc : var → trm → trm → trm

var

abbrev var := String

loc

abbrev loc := Nat

evalExact

inductive evalExact : state → trm → (val → state → Prop) -> Prop where
  | val : forall s v,
      evalExact s (trm_val v) (fun v' s' ↦ v' = v ∧ s' = s)
  | fun : forall s x t1,
      evalExact s (trm_fun x t1) (fun v' s' ↦ v' = val_fun x t1 ∧ s' = s)
  | fix : forall s f x t1,
      evalExact s (trm_fix f x t1) (fun v' s' ↦ v' = val_fix f x t1 ∧ s' = s)
  | app_arg1 : forall s1 t1 t2 Q1 Q,
      ¬ trm_is_val t1 ->
      evalExact s1 t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> evalExact s2 (trm_app v1 t2) Q) ->
      evalExact s1 (trm_app t1 t2) Q
  | app_arg2 : forall s1 (v1 : val) t2 Q1 Q,
      ¬ trm_is_val t2 ->
      evalExact s1 t2 Q1 ->
      (forall v2 s2, Q1 v2 s2 -> evalExact s2 (trm_app v1 v2) Q) ->
      evalExact s1 (trm_app v1 t2) Q
  | app_fun : forall s1 v1 (v2 :val) x t1 Q,
      v1 = val_fun x t1 ->
      evalExact s1 (subst x v2 t1) Q ->
      evalExact s1 (trm_app v1 v2) Q
  | app_fix : forall s (v1 v2 : val) f x t1 Q,
      v1 = val_fix f x t1 ->
      evalExact s (subst x v2 (subst f v1 t1)) Q ->
      evalExact s (trm_app v1 v2) Q
  | seq : forall Q1 s t1 t2 Q,
      evalExact s t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> evalExact s2 t2 Q) ->
      evalExact s (trm_seq t1 t2) Q
  | let : forall Q1 s x t1 t2 Q,
      evalExact s t1 Q1 ->
      (forall v1 s2, Q1 v1 s2 -> evalExact s2 (subst x v1 t2) Q) ->
      evalExact s (trm_let x t1 t2) Q
  | if : forall s (b : Bool) t1 t2 Q,
      evalExact s (if b then t1 else t2) Q ->
      evalExact s (trm_if (val_bool b) t1 t2) Q
  | unop : forall op s v1 P,
      evalunop op v1 P ->
      evalExact s (trm_app op v1) (purepost s P)
  | binop : forall op s (v1 v2 : val) P,
      evalbinop op v1 v2 P ->
      evalExact s (trm_app (trm_app op v1) v2) (purepost s P)
  | ref : forall s x t1 t2 Q Q₁,
    evalExact s t1 Q₁ →
    (∀ v1 s1, Q₁ v1 s1 → ∀ p ∉ s1,
     evalExact (s1.insert p v1) (subst x p t2) fun v s ↦ Q v (s.erase p)) →
      evalExact s (trm_ref x t1 t2) Q
  | get : forall s p,
      p ∈ s ->
      evalExact s (trm_app val_get (val_loc p))
        (fun v' s' ↦ v' = read_state p s ∧ s' = s)
  | set : forall s p v,
      v = trm_val v' ->
      p ∈ s ->
      evalExact s (trm_app (trm_app val_set (val_loc p)) v)
        (fun v'' s' ↦ v'' = val_unit ∧ s' = s.insert p v')
  | alloc_arg : forall s Q₁ Q,
    ¬ trm_is_val t1 →
    evalExact s t1 Q₁ →
    (∀ v' s', Q₁ v' s' → evalExact s' (trm_alloc x v' t2) Q) →
    evalExact s (trm_alloc x t1 t2) Q
  | alloc : forall (sa : state) (n : ℤ) Q,
    n ≥ 0 →
    (∀ (p : loc) (sb : state),
      sb = conseq (make_list n.natAbs val_uninit) p →
      p ≠ null →
      Finmap.Disjoint sa sb →
      evalExact (sb ∪ sa) (subst x p t2) fun v s ↦ Q v (s \ sb)) →
    evalExact sa (trm_alloc x n t2) Q

  | for (n₁ n₂ : Int) (Q : val -> state -> Prop) :
    evalExact s (if (n₁ < n₂) then
               (trm_seq (subst x n₁ t₁) (trm_for x (val_int (n₁ + 1)) n₂ t₁))
            else val_unit) Q ->
    evalExact s (trm_for x n₁ n₂ t₁) Q
  | while (t₁ t₂ : trm) (Q Q₁ : val -> state -> Prop) :
    evalExact s t₁ Q₁ ->
    (∀ s v, Q₁ v s -> evalExact s (trm_if v (trm_seq t₂ (trm_while t₁ t₂)) val_unit) Q) ->
    evalExact s (trm_while t₁ t₂) Q

hempty

def hempty : hProp :=
  fun h => (h = ∅)

state

abbrev state := Finmap (λ _ : loc ↦ val)

def make_list {A} (n : Nat) (v : A) : List A :=
  match n with
  | 0      => []
  | n' + 1 => v :: make_list n' v

conseq

def conseq {B : Type} (vs : List B) (l : Nat) : Finmap (fun _ : Nat ↦ B) :=
  match vs with
  | [] => ∅
  | v :: vs' => (Finmap.singleton l v) ∪ (conseq vs' (l + 1))

notation:max "emp" => hempty

infixr:60 " ~~> " => hsingle

infixr:55 " ∗ " => HStar.hStar

lemma hempty_inv h :
  emp h → h = ∅

lemma hsingl_inv p v h :
  (p ~~> v) h →
  h = Finmap.singleton p v

hrange

lemma int_eq_sub (l m n : ℤ) :
  l + m = n → l = n - m

lemma list_inc_natabs {α : Type} (L : List α) :
  ((L.length : ℤ) + 1).natAbs = (L.length : ℤ).natAbs + 1

import Mathlib.Data.Finmap

import Mathlib.Data.Finset.Basic

import Mathlib.Data.Multiset.Nodup

import SPLean.Common.State

import SPLean.Common.Util

import SPLean.Theories.HProp

import SPLean.Theories.XSimp

open trm val prim

notation "funloc" p "↦" H =>
  fun (r : val) ↦ hexists (fun p ↦ ⌜r = val_loc p⌝ ∗ H)

section evalProp

end evalProp

def hrange (L : List val) (p : loc) : hProp :=
  match L with
  | []      => emp
  | x :: L' => (p ~~> x) ∗ (hrange L' (p + 1))

lemma hrange_eq_conseq (L : List val) (n : ℤ) (p : loc) (s : state) :
  L.length = n →
  hrange L p s →
  s.keys = (conseq (make_list n.natAbs val_uninit) p).keys :=

:= by
  elim: L n p s=> > ; unfold hrange
  { sby move=> /= <- /= /hempty_inv -> }
  move=> ih > /== /[dup] /int_eq_sub /[dup] hn /ih {}ih  <-
  srw -hn at ih
  move: ih=> /= ih {hn}
  unfold hrange=> ![>] /hsingl_inv ? /ih {}ih ? ->
  unfold conseq make_list
  srw list_inc_natabs=> /== >
  move: ih
  sby srw ?Finset.ext_iff Finmap.mem_keys=> ?


scoped instance : PartialCommMonoid val where
  add := add
  add_assoc := by admit /- proof elided -/

add

@[simp]
abbrev add : val -> val -> val
  | .val_int i, .val_int j => val.val_int (i + j)
  | _, _ => val.val_unit

valid

@[simp]
abbrev valid : val -> Prop
  | .val_int _ => True
  | _ => False

PartialCommMonoid

class PartialCommMonoid (α : Type) extends AddCommSemigroup α where
  valid : α -> Prop
  valid_add : ∀ x, valid (x + y) -> valid x
  add_valid : ∀ x y, valid x -> valid y -> valid (x + y)

scoped instance inst : PartialCommMonoidWRT val add valid where
  validE := by admit /- proof elided -/

AddCommMonoidWRT

class AddCommMonoidWRT (α : Type) (add' : semiOutParam $ α -> α -> α) extends AddCommMonoid α where
  addE : (· + ·) = add'

add

@[simp]
abbrev add : val -> val -> val
  | .val_bool i, .val_bool j => val.val_bool (i || j)
  | _, _ => val.val_unit

valid

@[simp]
abbrev valid : val -> Prop
  | .val_bool _ => True
  | _ => False

add

@[simp]
abbrev add : val -> val -> val
  | .val_real i, .val_real j => val.val_real (i + j)
  | _, _ => val.val_unit

valid

@[simp]
abbrev valid : val -> Prop
  | .val_real _ => True
  | _ => False

theorem List.getElem_append_left{α : Type u_1} {l₁ l₂ : List α} {i : Nat} (hn : i < l₁.length) :\n(l₁ ++ l₂)[i] = l₁[i]

loc

abbrev loc := Nat

var

abbrev var := String

Heap.heap

abbrev Heap.heap (val : Type) := Finmap (λ _ : loc ↦ val)

private def kmerge1 (l : loc) (v : val) (l₂ : List (Sigma (fun _ : loc => val))) : val :=
  match l₂.dlookup l with
  | .some v' => v + v'
  | _ => v

kmerge

@[simp]
def kmerge : List (Sigma (fun _ : loc => val)) → List (Sigma (fun _ : loc => val)) → List (Sigma (fun _ : loc => val))
  | [], l₂ => l₂
  | s :: l₁, l₂ =>
    (if s.1 ∈ l₂.keys then
      ⟨s.1, kmerge1 s.1 s.2 l₂⟩ :: kmerge l₁ (l₂.kerase s.1)
    else s :: kmerge l₁ l₂)

AList.merge

noncomputable def AList.merge (h₁ h₂ : AList (fun _ : loc => val)) :  AList (fun _ : loc => val) :=
  ⟨kmerge h₁.entries h₂.entries, by admit /- proof elided -/
    ⟩

Heap.add

noncomputable def Heap.add (h₁ h₂ : heap) : heap :=
  Finmap.liftOn₂ h₁ h₂ (fun h₁ h₂ => (h₁.merge h₂).toFinmap) (by admit /- proof elided -/
    )

validInter

def validInter (h₁ h₂ : heap) : Prop :=
  ∀ l ∈ h₁, l ∈ h₂ -> ((h₁ +ʰ h₂).lookup l).any (valid (α := val))

lemma Option.merge_none_r (a : Option α) : Option.merge f a none = a

lemma Option.merge_assoc (h : Associative f) (a b c : Option α) :
  Option.merge f (Option.merge f a b) c = Option.merge f a (Option.merge f b c)

lemma validInter_assoc_l (h₁ h₂ h₃ : heap) :
  h₁ ⊥ʰ h₂ -> (h₁ +ʰ h₂) ⊥ʰ h₃ -> h₁ ⊥ʰ (h₂ +ʰ h₃) :=

:= by
  simp [validInter]
  move=> h1 h2 l hin1 /[tac (specialize h1 _ hin1 ; specialize h2 _ (Or.intro_left _ hin1))] [ hin2 | hin3 ]
  { rcases h : Finmap.lookup l h₃
    { rw [Option.merge_none_r] ; aesop }
    { srw h at h2 ; rw [← Option.merge_assoc, h2] ; apply Finmap.mem_of_lookup_eq_some at h=> //
      apply add_assoc } }
  { rw [← Option.merge_assoc, h2]=> //
    apply add_assoc }