syntax "sdo" num tactic : tactic

syntax "sdo" num tactic : tactic

notation:max "emp" => hempty

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

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

syntax "⟨" term "⟩" : lang

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

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)

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

Heap.heap

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

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]

hProp

def hProp := heap -> Prop

hempty

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

HWand

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

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

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 hempty_inv h :
  emp h → h = ∅

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 hstar_comm H1 H2 :
  H1 ∗ H2 = H2 ∗ H1

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

lemma hstar_hempty_l H :
  emp ∗ H = H

lemma hstar_hempty_r H :
  H ∗ emp = H

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

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

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

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

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

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

lemma himpl_hstar_hpure_l P H H' :
  (P → H ==> H') →
  (⌜P⌝ ∗ H) ==> 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 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

hwandE

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

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

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

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

qwandE

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

qstarE

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

import Mathlib.Data.Finmap

import Mathlib.Algebra.BigOperators.Group.Finset

import SPLean.Common.Heap

import SPLean.Common.Util

import SPLean.Theories.Lang

open Classical

def hProp := heap -> Prop

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

infixr:51 " ==> " => himpl

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

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

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

def hstar (H1 H2 : hProp) : hProp :=
  fun h => exists h1 h2,
    H1 h1 ∧ H2 h2 ∧ Finmap.Disjoint h1 h2 ∧ h = h1 ∪ h2

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

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

notation:max "emp" => hempty

infixr:60 " ~~> " => hsingle

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

  hStar : α → β → γ

infixr:55 " ∗ " => HStar.hStar

@[default_instance]
instance : HStar hProp hProp hProp where
  hStar := hstar

section

open Lean.TSyntax.Compat

end

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

def hwand (H1 H2 : hProp) : hProp :=
  hexists (fun (H0 : hProp) => H0 ∗ hpure ((H1 ∗ H0) ==> H2))

def qwand {A} (Q1 Q2 : A → hProp) : hProp :=
  hforall (fun (x : A) => hwand (Q1 x) (Q2 x))

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

notation (priority := high) "⊤" => htop

def qstar {A} (Q : A → hProp) (H : hProp) : A → hProp :=
  fun x => hstar (Q x) H

instance (A : Type) : HStar (A → hProp) hProp (A → hProp) where
  hStar := qstar

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

  hWand : α → β → γ

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

@[default_instance]
instance : HWand hProp hProp hProp where
  hWand := hwand

instance (α : Type) : HWand (α → hProp) (α → hProp) hProp where
  hWand := qwand

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

:=
by
  srw qwandE ; apply Iff.intro
  { move=> ? x
    srw qstarE hstar_comm
    apply (himpl_hstar_trans_l H (hforall fun x' ↦ Q1 x' -∗ Q2 x'))=>//
    apply (himpl_trans (hforall fun x0 ↦ ((Q1 x0 -∗ Q2 x0) ∗ Q1 x)))
    apply hstar_hforall ; apply himpl_hforall_l
    rw [hstar_comm] ; apply hwand_cancel }
  srw qimpl qstarE => ?
  apply himpl_hforall_r => ?
  sby srw hwand_equiv=> ?


import SPLean.Theories.XChange
import SPLean.Theories.Lang
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 " != " : bop

syntax " != " : bop

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

syntax "⟨" term "⟩" : lang

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

syntax " := " : bop

notation:max "emp" => hempty

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

macro "∃ʰ" xs:Lean.explicitBinders ", " b:term : term => Lea

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

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

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

macro "h∀" xs:Lean.explicitBinders ", " b:term : term => Lea

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

syntax " ++ " : bop

syntax "not" : uop

macro "xpull" : tactic =>

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

  syntax "sdo" num tactic : tactic

macro "xchange" l:term : tactic =>

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

macro "xsimp" : tactic =>

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

  ))

syntax "while" lang  " {"  (ppLine lang) ( " }") : lang

syntax "for" ident " in " "[" lang " : " lang "]" " {"  (ppLine lang) ( " }") : lang

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)

var

abbrev var := String

  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

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)

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 = ∅)

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

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

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))

HWand

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

  hWand : α → β → γ

protect

@[heapSimp]
def protect (x : α) := x

himpl

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

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 null : loc := 0

triple

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

wp

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

def val_funs (xs:List var) (t:trm) : val :=
  match xs with
  | [] => panic! "function with zero argumets!"
  | x1::xs' => val_fun x1 (trm_funs xs' t)

def trm_funs (xs:List var) (t:trm) : trm :=
  match xs with
  | [] => t
  | x1::xs' => trm_fun x1 (trm_funs xs' t)

def trm_apps (f:trm) (ts:List trm) : trm :=
  match ts with
  | [] => f
  | ti::ts' => trm_apps (trm_app f ti) ts'

def eval_like (t1 t2:trm) : Prop :=
  forall s Q, eval s t1 Q -> eval s t2 Q

abbrev trm_is_val : trm → Prop
  | trm_val _ => true
  | _         => false

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

tohProp

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

ofhProp

abbrev ofhProp (h : val -> hProp) : val -> heap -> Prop := 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))

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_app_arg1' s1 t1 t2 Q1 Q :
  eval s1 t1 Q1 ->
  (forall v1 s2, Q1 v1 s2 -> eval s2 (trm_app v1 t2) Q) ->
  eval s1 (trm_app t1 t2) Q

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

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

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

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

lemma union_singleton_eq_insert (h : state) :
  Finmap.singleton p v ∪ h = h.insert p v

lemma insert_delete_id (h : state) (p : loc) :
  p ∉ h →
  h = (h.insert p v).erase p

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

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

lemma hwand_hpure_l P H :
  P → (⌜P⌝ -∗ H) = H

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

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_hstar_hpure_r P H H' :
   P →
   (H ==> H') →
   H ==> ⌜P⌝ ∗ H'

lemma himpl_refl H : H ==> H

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

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

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_trans_l H1 H2 H3 H4 :
  H1 ==> H2 →
  H2 ∗ H3 ==> H4 →
  H1 ∗ H3 ==> H4

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 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_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

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 himpl_hforall_r A (J : A → hProp) H :
  (forall x, H ==> J x) →
  H ==> (hforall J)

qwandE

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

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

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 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 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₂

Theories.wp

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

Theories.formula

abbrev formula := (val → hProp) → hProp

Theories.mkstruct

def mkstruct (F : formula) :=
  fun (Q : val -> hProp) ↦ ∃ʰ Q', F Q' ∗ (Q' -∗ Q)

def wpgen_val (v : val) : formula :=
  fun Q ↦ Q v

def wpgen_seq (F1 F2 : formula) : formula :=
  fun Q ↦ F1 (fun _ ↦ F2 Q)

@[simp]
def wpgen_app (t : trm) : formula :=
  fun Q ↦ ∃ʰ H, H ∗ ⌜triple t H Q⌝

Theories.wpgen

def formula_sound (t : trm) (F : formula) : Prop :=
  forall Q, F Q ==> wp t Q

@[simp]
abbrev var_funs (xs:List var) (n:Nat) : Prop :=
     xs.Nodup
  /\ xs.length = n
  /\ xs != []

Theories.ctx

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

Theories.isubst

lemma wp_equiv t H Q :
  (H ==> wp t Q) ↔ triple t H 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 wp_ramified t (Q1 Q2 : val -> hProp) :
  (wp t Q1) ∗ (Q1 -∗ Q2) ==> (wp t Q2)

lemma wp_eval_like t1 t2 Q :
  eval_like t1 t2 →
  wp t1 Q ==> wp t2 Q

lemma wp_val v Q :
  Q v ==> wp (trm_val v) Q

lemma wp_fun x t Q :
  Q (val_fun x t) ==> wp (trm_fun x t) Q

lemma wp_fix f x t Q :
  Q (val_fix f x t) ==> wp (trm_fix f x t) Q

lemma wp_app_fun x v1 v2 t1 Q :
  v1 = val_fun x t1 →
  wp (subst x v2 t1) Q ==> wp (trm_app v1 v2) Q

lemma wp_app_fix f x v1 v2 t1 Q :
  v1 = val_fix f x t1 →
  wp (subst x v2 (subst f v1 t1)) Q ==> wp (trm_app v1 v2) Q

lemma wp_seq t1 t2 Q :
  wp t1 (fun _ ↦ wp t2 Q) ==> wp (trm_seq t1 t2) Q

lemma wp_let x t1 t2 Q :
  wp t1 (fun v ↦ wp (subst x v t2) Q) ==> wp (trm_let x t1 t2) Q

lemma wp_ref x v t Q :
  (h∀ p, (p ~~> v) -∗ wp (subst x p t) (Q ∗ ∃ʰ v', (p ~~> v'))) ==>
  wp (trm_ref x v t) Q

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

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

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

lemma mkstruct_erase Q F :
  F Q ==> mkstruct F Q

lemma mkstruct_monotone F1 F2 Q :
  (forall Q, F1 Q ==> F2 Q) →
  mkstruct F1 Q ==> mkstruct F2 Q

lemma mkstruct_wp t :
  mkstruct (wp t) = wp t

lemma mkstruct_sound t F :
  formula_sound t F →
  formula_sound t (mkstruct F)

lemma wpgen_val_sound v :
  formula_sound (trm_val v) (wpgen_val v)

lemma wpgen_fun_sound x t1 Fof :
  (forall vx, formula_sound (subst x vx t1) (Fof vx)) →
  formula_sound (trm_fun x t1) (wpgen_fun Fof)

lemma wpgen_fix_sound f x t1 Fof :
  (forall vf vx, formula_sound (subst x vx (subst f vf t1)) (Fof vf vx)) →
  formula_sound (trm_fix f x t1) (wpgen_fix Fof)

lemma wpgen_seq_sound F1 F2 t1 t2 :
  formula_sound t1 F1 →
  formula_sound t2 F2 →
  formula_sound (trm_seq t1 t2) (wpgen_seq F1 F2)

lemma wpgen_let_sound F1 F2of x t1 t2 :
  formula_sound t1 F1 →
  (forall v, formula_sound (subst x v t2) (F2of v)) →
  formula_sound (trm_let x t1 t2) (wpgen_let F1 F2of)

lemma wpgen_if_sound F1 F2 t0 t1 t2 :
  formula_sound t1 F1 →
  formula_sound t2 F2 →
  formula_sound (trm_if t0 t1 t2) (wpgen_if t0 F1 F2)

lemma wpgen_app_sound t :
  formula_sound t (wpgen_app t)

lemma wpgen_ref_sound x t1 t2 :
  formula_sound (trm_ref x t1 t2) (wpgen_ref x t1 t2)

lemma wpgen_alloc_sound x t1 t2 :
  formula_sound (trm_alloc x t1 t2) (wpgen_alloc x t1 t2)

lemma wpgen_sound t :
  formula_sound t (wpgen t)

lemma himpl_wpgen_wp t Q :
  wpgen t Q ==> wp t Q

lemma triple_of_wpgen t H Q :
  H ==> wpgen t Q →
  triple t H Q

lemma wp_of_wpgen :
  H ==> wpgen t Q →
  H ==> wp t Q

lemma trms_to_vals_some_equiv ts vs : trms_to_vals ts = some vs → ts = vs.map trm_val

lemma List.toAList_perm {α : Type u} {β : α → Type v} [DecidableEq α]
  (es es' : List (Sigma β)) (hnodup : es.NodupKeys) (hp : es.Perm es') :
  es.toAList.entries.Perm es'.toAList.entries

lemma List.mkAlist_snoc_to_cons [DecidableEq α] (xs : List α) (vs : List β)
    (x : α) (v : β) : x ∉ xs → xs.length = vs.length → xs.Nodup →
    ((xs ++ [x]).mkAlist (vs ++ [v])).entries.Perm (((x :: xs).mkAlist (v :: vs)).entries)

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 AList.erase_empty {α : Type u} {β : α → Type v} [DecidableEq α] (a : α) :
  AList.erase a (∅ : AList β) = ∅

lemma isubst_empty t : isubst ∅ t = t

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

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

lemma isubst_single x v t : isubst (List.mkAlist [x] [v]) t = subst x v t

lemma trm_apps2 :
  trm_apps (trm_app t1 t2) ts = trm_apps t1 (t2::ts)

lemma trm_apps_app :
  trm_apps t1 (ts ++ ts') = trm_apps (trm_apps t1 ts) ts'

lemma trm_funs_app :
  trm_funs (xs ++ xs') t1 = trm_funs xs (trm_funs xs' t1)

lemma eval_like_trm_fun_val_fun x t : eval_like (trm_fun x t) (val_fun x t)

lemma eval_like_val_fun_trm_fun x t : eval_like (val_fun x t) (trm_fun x t)

lemma eval_like_trm_app_left t1 t1' t2 (hsat : ∃ s Q, eval s t1 Q) : eval_like t1 t1' → eval_like (trm_app t1 t2) (trm_app t1' t2)

lemma eval_like_trm_fun_val_fun_app_left (x : var) (t1 t2 : trm) :
  eval_like (trm_app (trm_fun x t1) t2) (trm_app (val_fun x t1) t2)

lemma eval_like_val_fun_trm_fun_app_left (x : var) (t1 t2 : trm) :
  eval_like (trm_app (val_fun x t1) t2) (trm_app (trm_fun x t1) t2)

lemma val_funs_snoc (xs : List var) (x : var) (h : xs ≠ []) (t : trm) :
  val_funs (xs ++ [x]) t = val_funs xs (trm_fun x t)

lemma List.not_nil_snoc {α : Type u} (l : List α) : l ≠ [] → ∃ l' x, l = l' ++ [x]

lemma eval_like_trm_apps_funs_pre (heqv0 : v0 = trm_funs xs t1) :
  eval_like t (trm_apps (val_funs xs t1) ts) ∧  -- NOTE: this part do not require `xs.Nodup`, but anyway
  eval_like (isubst (xs.mkAlist vs) t1) t

lemma eval_like_trm_apps_funs (heqv0 : v0 = trm_funs xs t1) :
  eval_like (isubst (xs.mkAlist vs) t1) (trm_apps (val_funs xs t1) ts)

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

abbrev formula := (val → hProp) → hProp

def mkstruct (F : formula) :=
  fun (Q : val -> hProp) ↦ ∃ʰ Q', F Q' ∗ (Q' -∗ Q)

def wpgen_val (v : val) : formula :=
  fun Q ↦ Q v

def wpgen_fun (Fof : val → formula) : formula :=
  fun Q ↦ h∀ vf, ⌜forall vx Q', Fof vx Q' ==>
    wp (trm_app (trm_val vf) (trm_val vx)) Q'⌝ -∗ Q vf

def wpgen_fix (Fof : val → val → formula) : formula :=
  fun Q ↦ h∀ vf, ⌜forall vx Q', Fof vf vx Q' ==>
    wp (trm_app vf vx) Q'⌝ -∗ Q vf

def wpgen_seq (F1 F2 : formula) : formula :=
  fun Q ↦ F1 (fun _ ↦ F2 Q)

def wpgen_let (F1 : formula) (F2of : val → formula) : formula :=
  fun Q ↦ F1 (fun v ↦ F2of v Q)

def wpgen_if (t : trm) (F1 F2 : formula) : formula :=
  fun Q ↦ ∃ʰ (b : Bool),
    ⌜t = trm_val (val_bool b)⌝ ∗ (if b then F1 Q else F2 Q)

@[simp]
def wpgen_app (t : trm) : formula :=
  fun Q ↦ ∃ʰ H, H ∗ ⌜triple t H Q⌝

def wpgen_ref (x : var) (t1 t2 : trm) : formula :=
  fun Q ↦ ∃ʰ v, ⌜t1 = trm_val v⌝ ∗
    h∀ p, (p ~~> v) -∗ protect (wp (subst x p t2) (fun hv ↦ Q hv ∗ ∃ʰ u, p ~~> u))

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)

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
  )

def formula_sound (t : trm) (F : formula) : Prop :=
  forall Q, F Q ==> wp t Q

section tactics

open Lean Elab Tactic

section xapp

end xapp

end tactics

@[simp]
abbrev var_funs (xs:List var) (n:Nat) : Prop :=
     xs.Nodup
  /\ xs.length = n
  /\ xs != []

@[simp]
def trms_to_vals (ts:List trm) : Option (List val) := do
  match ts with
  | [] => return []
  | (trm_val v) :: ts' => v :: (<- trms_to_vals ts')
  | _ => failure

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)

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

lemma xwp_lemma_funs (xs : List _) (vs : List val) :
  t = trm_apps v0 ts ->
  v0 = val_funs xs t1 ->
  trms_to_vals ts = vs ->
  var_funs xs vs.length ->
  H ==> wpgen (isubst (xs.mkAlist vs) t1) Q ->
  triple t H Q :=

:= by
  move=> -> -> ?? h
  srw -wp_equiv ; apply himpl_trans ; apply (wp_of_wpgen h)
  apply wp_eval_like
  apply eval_like_trm_apps_funs=> //


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

macro "xsimp" : tactic =>

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

  ))

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

Heap.heap

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

HWand

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

  hWand : α → β → γ

protect

@[heapSimp]
def protect (x : α) := x

HStar

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

  hStar : α → β → γ

himpl

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

infixr:51 " ==> " => himpl

infixr:55 " ∗ " => HStar.hStar

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

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

lemma himpl_hempty_hwand_same H :
  emp ==> (H -∗ H)

Theories.formula

abbrev formula := (val → hProp) → hProp

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

abbrev formula := (val → hProp) → hProp

section tactics

open Lean Elab Tactic

lemma xapp_simpl_lemma (F : formula) :
  H ==> F Q ->
  H ==> F Q ∗ (Q -∗ protect Q) :=

:= by move=> hh; apply himpl_trans ; apply hh ; xsimp


import SPLean.Theories.XChange
import SPLean.Theories.Lang
import SPLean.Theories.WP1
import SPLean.Theories.XSimp
import SPLean.Theories.SepLog
import SPLean.Common.State
import SPLean.Theories.HProp
import SPLean.Common.Util

notation:max "emp" => hempty

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

syntax " >= " : bop

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

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

syntax " := " : bop

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

syntax " ++ " : bop

macro "hsimp" : tactic => `(tactic| (simp only [heapSimp]; try dsimp))

syntax " <= " : bop

macro "h∀" xs:Lean.explicitBinders ", " b:term : term => Lean.expandExplicitBinders ``hforall 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)

hseg

def hseg (L : List val) (p : loc) (j : Int) : hProp :=
  match L with
  | []      => emp
  | x :: L' => (hcell x p j) ∗ (hseg L' p (j + 1))

hcell

def hcell (v : val) (p : loc) (i : Int) : hProp :=
  ((p + 1 + (Int.natAbs i)) ~~> v) ∗ ⌜i >= 0⌝

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

Heap.heap

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

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

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 = ∅)

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))

HWand

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

  hWand : α → β → γ

himpl

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

hforall

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

infixr:51 " ==> " => himpl

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 hstar_comm_assoc (H1 H2 H3 : hProp) :
  H1 ∗ H2 ∗ H3 = H2 ∗ H1 ∗ H3

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

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

lemma hseg_cons v p j L :
  hseg (v :: L) p j = hcell v p j ∗ hseg L p (j + 1)

lemma hseg_app L1 L2 p j :
  hseg (L1 ++ L2) p j =
  hseg L1 p j ∗ hseg L2 p (j + L1.length)

lemma list_cons_length (A : Type) (x : A) (L : List A) :
  (x :: L).length = 1 + L.length

lemma list_middle_inv (A : Type) (n : Nat) (l : List A) :
  n < l.length →
  exists (x : A) (l1 l2 : List A),
    l = l1 ++ x :: l2 ∧ l1.length = n

lemma nth_app_r {A : Type} (_ : Inhabited A) n (l1 l2 : List A) :
  n ≥ l1.length →
  (l1 ++ l2)[n]! = l2[n - l1.length]!

lemma nth_middle (A : Type) (IA : Inhabited A) (n : Nat)
  (l1 l2 : List A) (x : A) :
  n = l1.length → (l1 ++ x :: l2)[n]! = x

lemma update_middle (A : Type) (_ : Inhabited A) (n : Nat)
  (l1 l2 : List A) (x v : A) :
  n = l1.length → (l1 ++ x :: l2).set n v = (l1.concat v) ++ l2

import SPLean.Common.State

import SPLean.Theories.XSimp

import SPLean.Theories.XChange

import SPLean.Common.Util

import SPLean.Theories.SepLog

import SPLean.Theories.WP1

import SPLean.Theories.Lang

open val trm prim

open Theories

lemma hseg_focus_relative (k : Nat) L p j (v : 0 <= k ∧ k < L.length):
  hseg L p j ==>
  hcell L[k]! p (j + k)
    ∗ (h∀ w, hcell w p (j + k) -∗ hseg (L.set k w) p j) :=

:= by
  move: v=> [] ? /list_middle_inv ![> ?] hlen
  move: (Eq.symm hlen) => /nth_middle hmid
  subst L ; srw (hmid _ w_2 w) hseg_app hseg_cons hlen -hstar_comm_assoc
  apply himpl_frame_r
  apply himpl_hforall_r => ?
  move: (Eq.symm hlen) => /(update_middle val _ k w_1 w_2 w) hset
  srw hset ?List.concat_append ?hseg_app ?hseg_cons ?hlen
  { sby xsimp }
  sdone


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

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

syntax " := " : bop

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

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

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

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])

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 : α → β → γ

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

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

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)

hexists

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

infixr:51 " ==> " => himpl

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

infixr:60 " ~~> " => hsingle

infixr:55 " ∗ " => HStar.hStar

lemma disjoint_single (h : state) :
  p ∉ h →
  h.Disjoint (Finmap.singleton p v)

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

lemma union_singleton_eq_erase (h h' : state) :
  h.Disjoint (Finmap.singleton p v) →
  h' = h ∪ Finmap.singleton p v →
  h = h'.erase p

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

lemma hsingle_intro p v :
  (p ~~> v) (Finmap.singleton p v)

lemma insert_eq_union_single (h : state) :
  p ∉ h →
  h.insert p v = h ∪ (Finmap.singleton p v)

triple

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

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

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

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

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

section evalProp

end evalProp

lemma triple_ref (v : val) :
  (forall (p : loc), triple (subst x p t2) (H ∗ (p ~~> v)) (Q ∗ ∃ʰ v, p ~~> v)) →
  triple (trm_ref x (trm_val v) t2) H Q :=

:=
by
  move=> htriple h ?
  apply eval.eval_ref
  { sby apply (eval.eval_val h v (fun v' h' ↦ v' = v ∧ h' = h)) }
  move=> > [->->] > ?
  move: (htriple p)=> /triple_conseq {}htriple
  have eqn:(triple (subst x p t2) (H ∗ p ~~> v) fun v s ↦ Q v (s.erase p)) := by
    apply htriple=> //
    move=> > h /= ![>] ? /hexists_inv [v'] /hsingl_inv ->
    sby move=> /union_singleton_eq_erase /[apply] <-
  move=> {htriple}
  apply eqn
  exists h, Finmap.singleton p v
  move=> ⟨//|⟩ ⟨|⟩
  apply hsingle_intro=> ⟨|⟩
  apply disjoint_single=>//
  sby apply insert_eq_union_single=> //


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

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 "∃ʰ" 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)

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

Heap.heap

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

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 = ∅)

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

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

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

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

state

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

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))

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

purepostin

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

  forall v, P v → Q v s

infixr:51 " ==> " => himpl

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

notation:max "emp" => hempty

infixr:60 " ~~> " => hsingle

infixr:55 " ∗ " => HStar.hStar

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

lemma hempty_inv h :
  emp h → h = ∅

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

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

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 conseq_cons B (l : Nat) (v : B) (vs : List B) :
  conseq (v :: vs) l = (Finmap.singleton l v) ∪ (conseq vs (l + 1))

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

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

lemma hpure_inv P h :
  ⌜P⌝ h →
  P ∧ 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₂

hrange

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

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

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 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

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

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

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 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 :=

:= by
  move=> ? htriple h ?
  apply eval.eval_alloc=> // > *
  move: (htriple p)=> /triple_conseq {}htriple
  specialize (htriple (H ∗ ⌜p ≠ null⌝ ∗ hrange (make_list n.natAbs val_uninit) p))
  specialize (htriple (fun v s ↦ Q v (s \ sb)))
  have eqn:(triple (subst x p t)
    (H ∗ ⌜p ≠ null⌝ ∗ hrange (make_list n.natAbs val_uninit) p)
    fun v s ↦ Q v (s \ sb)) := by
    { apply htriple=> // {htriple}
      move=> > s ![>] ? ![>] /hpure_inv [] _ ->
      move=> /hexists_inv [L] ![>] /hpure_inv [] ? -> ? _
      move=> /== -> _ -> ? ->
      srw diff_disjoint_eq=> //
      subst sb ; sby apply hrange_eq_conseq }
  move=> {htriple}
  apply eqn
  exists h, sb=> ⟨//|⟩ ⟨|⟩
  { exists ∅, sb => ⟨//|/==⟩ ⟨|⟩
    subst sb ; apply hrange_intro
    sdone }
  constructor=> //
  sby srw Finmap.union_comm_of_disjoint Finmap.Disjoint.symm_iff