-- SPLean/Theories/SepLog.lean

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

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

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

-- Repository definitions used:
content: syntax "fun" ident+ " => " lang : lang

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

syntax " <= " : bop

syntax " >= " : bop

syntax "not" : uop

syntax " := " : bop

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

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

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

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

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

syntax "alloc" lang " as " ident " in" ppDedent(ppLine lang) : lang

syntax "⟨" term "⟩" : lang

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

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

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

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

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

content: abbrev var := String

content: abbrev loc := Nat

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

content: def hProp := heap -> Prop

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

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

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

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

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

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

content: def null : loc := 0

content: inductive evalbinop : val → val → val → (val->Prop) → Prop where
  | evalbinop_eq : forall v1 v2,
      evalbinop val_eq v1 v2 (fun v => v = val_bool (is_true (v1 = v2)))
  | evalbinop_neq : forall v1 v2,
      evalbinop val_neq v1 v2 (fun v => v = val_bool (is_true (v1 ≠ v2)))
  | evalbinop_add : forall n1 n2,
      evalbinop val_add (val_int n1) (val_int n2)
        (fun v => v = val_int (n1 + n2))
  | evalbinop_addr : forall r₁ r₂,
      evalbinop val_add (val_real r₁) (val_real r₂)
        (fun v => v = val_real (r₁ + r₂))
  | evalbinop_sub : forall n1 n2,
      evalbinop val_sub (val_int n1) (val_int n2)
        (fun v => v = val_int (n1 - n2))
  | evalbinop_subr : forall r1 r2,
      evalbinop val_sub (val_real r1) (val_real r2)
        (fun v => v = val_real (r1 - r2))
  | evalbinop_mul : forall n1 n2,
      evalbinop val_mul (val_int n1) (val_int n2)
        (fun v => v = val_int (n1 * n2))
  | evalbinop_mulr : forall r1 r2,
      evalbinop val_mul (val_real r1) (val_real r2)
        (fun v => v = val_real (r1 * r2))
  | evalbinop_div : forall n1 n2,
      ¬(n2 = 0) →
      evalbinop val_div (val_int n1) (val_int n2)
        (fun v => v = val_int (n1 / n2))
  | evalbinop_divr : forall r1 r2,
      ¬(r2 = 0) →
      evalbinop val_div (val_real r1) (val_real r2)
        (fun v => v = val_real (r1 / r2))
  | evalbinop_mod : forall n1 n2,
      ¬(n2 = 0) →
      evalbinop val_mod (val_int n1) (val_int n2)
        (fun v => v = val_int (n1 % n2))
  | evalbinop_le : forall n1 n2,
      evalbinop val_le (val_int n1) (val_int n2)
        (fun v => v = val_bool (n1 <= n2))
  | evalbinop_ler : forall r1 r2,
      evalbinop val_le (val_real r1) (val_real r2)
        (fun v => v = val_bool (r1 <= r2))
  | evalbinop_lt : forall n1 n2,
      evalbinop val_lt (val_int n1) (val_int n2)
        (fun v => v = val_bool (n1 < n2))
  | evalbinop_ltr : forall r1 r2,
      evalbinop val_lt (val_real r1) (val_real r2)
        (fun v => v = val_bool (r1 < r2))
  | evalbinop_ge : forall n1 n2,
      evalbinop val_ge (val_int n1) (val_int n2)
        (fun v => v = val_bool (n1 >= n2))
  | evalbinop_ger : forall r1 r2,
      evalbinop val_ge (val_real r1) (val_real r2)
        (fun v => v = val_bool (r1 >= r2))
  | evalbinop_gt : forall n1 n2,
      evalbinop val_gt (val_int n1) (val_int n2)
        (fun v => v = val_bool (n1 > n2))
  | evalbinop_gtr : forall r1 r2,
      evalbinop val_gt (val_real r1) (val_real r2)
        (fun v => v = val_bool (r1 > r2))

  
  
  
  
  | evalbinop_ptr_add : forall (p1 : loc) (p2 : Int) n,
      p2 = p1 + n ->
      evalbinop val_ptr_add (val_loc p1) (val_int n)
        (fun v => v = val_loc (Int.natAbs p2))

content: noncomputable def is_true (P : Prop) : Bool :=
  if P then true else false

content: inductive evalunop : prim → val → (val → Prop) → Prop where
  | evalunop_neg : forall b1,
      evalunop val_neg (val_bool b1) (fun v => v = val_bool (¬ b1))
  | evalunop_opp : forall n1,
      evalunop val_opp (val_int n1) (fun v => v = val_int (- n1))
  | evalunop_oppr : forall r1,
      evalunop val_opp (val_real r1) (fun v => v = val_real (- r1))

content: def purepost (s : state) (P : val → Prop) : val → state → Prop :=
  fun v s' => P v ∧ s' = s

content: def read_state (p : loc) (h : state) :=
  match Finmap.lookup p h with
  | some v => v
  | none   => default

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

content: def intersect (s1 s2 : state) := s1 \ (s1 \ s2)

content: def hProp.Disjoint (H₁ H₂ : hProp) :=
  forall h1 h2, H₁ h1 -> H₂ h2 -> h1.Disjoint h2

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

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

content: infixr:55 " ∗ " => HStar.hStar

-- Repository lemmas used:
content: lemma in_read_union_l (h1 h2 : state) (x : loc) :
  x ∈ h1 → read_state x (h1 ∪ h2) = read_state x h1

content: lemma disjoint_insert_l (h1 h2 : state) (x : loc) (v : val) :
  Finmap.Disjoint h1 h2 →
  x ∈ h1 →
  Finmap.Disjoint (Finmap.insert x v h1) h2

content: lemma union_diff_disjoint_r (h₁ h₂ h₃ : state) :
  h₂.Disjoint h₃ →
  (h₁ ∪ h₂) \ h₃ = (h₁ \ h₃) ∪ h₂

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

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

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

content: lemma union_monotone_r (s₃ s₁ s₂ : state) :
  s₁ = s₂ →
  s₁ ∪ s₃ = s₂ ∪ s₃

content: lemma disjoint_update_not_r (h1 h2 : state) (x : loc) (v: val) :
  Finmap.Disjoint h1 h2 →
  x ∉ h2 →
  Finmap.Disjoint (Finmap.insert x v h1) h2

content: lemma evalExact_post_eq :
  Q = Q' →
  evalExact s t Q →
  evalExact s t Q'

content: lemma erase_of_non_mem (h : state) :
  p ∉ h →
  h.erase p = h

content: lemma diff_insert_intersect_id (s₁ s₂ : state) :
  (s₁ \ s₂) ∪ (intersect s₁ s₂) = s₁

content: lemma lookup_intersect (s₁ s₂ : state) :
  p ∈ s₁ ∧ p ∈ s₂ →
  (intersect s₁ s₂).lookup p = s₁.lookup p

content: lemma intersect_disjoint_cancel (s₁ s₂ s₃ : state) :
  s₁.Disjoint s₃ →
  (s₁ ∪ intersect s₂ s₃) \ s₃ = s₁

content: lemma remove_not_in_r (h1 h2 : state) (p : loc) :
  p ∉ h2 →
  (h1 ∪ h2).erase p = h1.erase p ∪ h2

content: lemma disjoint_intersect_r (s₁ s₂ s₃ : state) :
  s₂.Disjoint s₃ →
  (intersect s₁ s₂).Disjoint s₃

content: lemma insert_union (h1 h2 : state) (p : loc) (v : val) :
  p ∉ h1 ∪ h2 →
  (h1 ∪ h2).insert p v = (h1.insert p v) ∪ h2

content: lemma reinsert_erase_union (h1 h2 h3 : state) :
  h3.lookup p = some v →
  p ∉ h2 →
  h3.erase p = h1 ∪ h2 →
  h3 = (h1.insert p v) ∪ h2

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

content: lemma disjoint_disjoint_diff (h₁ h₂ h₃ : state) :
  h₁.Disjoint h₂ →
  (h₁ \ h₃).Disjoint h₂

content: lemma erase_disjoint (h1 h2 : state) (p : loc) :
  h1.Disjoint h2 →
  (h1.erase p).Disjoint h2

-- Local definitions used:
content: abbrev tohProp (h : heap -> Prop) : hProp := h

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

-- Local lemmas used:
content: lemma frame_eq_rw :
  s.Disjoint h2 →
  (fun v' s' ↦ v' = v ∧ s' = s ∪ h2) =
  (qstar (fun v' s' ↦ v' = v ∧ s' = s) (tohProp (fun h ↦ h = h2)))

content: lemma evalExact_frame_val (v : val) (s h2 : state) :
  s.Disjoint h2 →
  evalExact (s ∪ h2) t (fun v' s' ↦ v' = v ∧ s' = s ∪ h2) →
  evalExact (s ∪ h2) t
    (qstar (fun v' s' ↦ v' = v ∧ s' = s) (tohProp (fun h ↦ h = h2)))

content: lemma purepost_frame :
  s.Disjoint h2 →
  (purepost (s ∪ h2) P) =
  (qstar (purepost s P) (tohProp fun h ↦ h = h2))

content: lemma evalExact_frame_unop_binop :
  s.Disjoint h2 →
  evalExact (s ∪ h2) t (purepost (s ∪ h2) P) →
  evalExact (s ∪ h2) t (qstar (purepost s P) (tohProp fun h ↦ h = h2))

content: lemma read_state_frame :
  s.Disjoint h2 →
  p ∈ s →
  (fun v' s' ↦ v' = read_state p (s ∪ h2) ∧ s' = s ∪ h2 ) =
  (qstar (fun v' s' ↦ v' = read_state p s ∧ s' = s) (tohProp fun h ↦ h = h2))

content: lemma evalExact_frame_get :
  s.Disjoint h2 →
  p ∈ s →
  evalExact (s ∪ h2) t (fun v' s' ↦ v' = read_state p (s ∪ h2) ∧ s' = s ∪ h2 ) →
  evalExact (s ∪ h2) t
    (qstar (fun v' s' ↦ v' = read_state p s ∧ s' = s) (tohProp fun h ↦ h = h2))

content: lemma insert_frame :
  s.Disjoint h2 →
  p ∈ s →
  fun v'' s' ↦ v'' = val_unit ∧ s' = Finmap.insert p v' (s ∪ h2) =
  (qstar (fun v'' s' ↦ v'' = val_unit ∧ s' = Finmap.insert p v' s) (tohProp fun h ↦ h = h2))

content: lemma evalExact_frame_set :
  s.Disjoint h2 →
  p ∈ s →
  evalExact (s ∪ h2) t
    (fun v'' s' ↦ v'' = val_unit ∧ s' = Finmap.insert p v' (s ∪ h2)) →
  evalExact (s ∪ h2) t
    (qstar (fun v'' s' ↦ v'' = val_unit ∧ s' = Finmap.insert p v' s) (tohProp fun h ↦ h = h2))

-- Target theorem and proof:
lemma evalExact_frame (h1 h2 : state) t (Q : val → hProp) :
  evalExact h1 t (ofhProp Q) →
  Finmap.Disjoint h1 h2 →
  evalExact (h1 ∪ h2) t (Q ∗ (tohProp (fun h ↦ h = h2)))
:=
by
  simp [ofhProp]
  move=> /== heval
  elim: heval h2
  { move=> > *
    sby apply evalExact_frame_val }
  { move=> > *
    sby apply evalExact_frame_val }
  { move=> > *
    sby apply evalExact_frame_val }
  { move=> ???????? ih1 ?? /ih1 ? ; constructor=>//
    sby move=> ?? ![] }
  { move=> ???????? ih1 ?? /ih1 ? ; apply evalExact.app_arg2=>//
    sby move=> ?? ![] }
  { sby move=> * ; apply evalExact.app_fun }
  { sby move=> * ; apply evalExact.app_fix }
  { move=> ??????? ih1 ih2 ? /ih1 ? ; apply evalExact.seq=>//
    move=> ? s2 ![??? hQ2 *] ; subst s2 hQ2
    sby apply ih2 }
  { move=> ???????? ih1 ih2 ? /ih1 ? ; apply evalExact.let=>//
    move=> ?? ![??? hQ2 ? hU] ; subst hU hQ2
    sby apply ih2}
  { sby move=> * }
  { move=> > ? > *
    apply evalExact_frame_unop_binop=> //
    sby apply evalExact.unop }
  { move=> > ? > *
    apply evalExact_frame_unop_binop=> //
    sby apply evalExact.binop }
  { move=> > ; unfold tohProp
    move=> _ _ ih1 ih2 > /ih1 {}ih1
    apply evalExact.ref
    { apply ih1 }
    move=> {ih1} > ![>] hQ₁ /= -> ? -> p ?
    have eqn:(p ∉ w) := by sdone
    have eqn':((w.insert p v1).Disjoint h2) := by sby apply disjoint_update_not_r
    move: hQ₁ eqn eqn'=> /ih2 /[apply] /[apply] {ih2}
    srw insert_union=> // hq
    apply evalExact_post_eq ; rotate_left ; apply hq
    apply funext=> v ; apply funext=> h ; apply propext=> ⟨|⟩
    { move=> ![>] /= ? -> ? ->
      exists (w_2.erase p), h2=> ⟨//|/==⟩ ⟨|⟩
      apply erase_disjoint=> //
      sby srw remove_not_in_r }
    move=> ![>] /= ? -> ?
    scase: [p ∈ h]
    { move=> ? ; srw erase_of_non_mem=> // []
      exists w_2, h2=> /== ⟨|⟩ //
      sby srw erase_of_non_mem }
    move=> /Finmap.mem_iff [v'] /reinsert_erase_union heq herase
    srw (heq w_2 h2)=> // {heq}
    exists (w_2.insert p v'), h2=> /== ⟨|⟩
    { srw -insert_delete_id=> //
      have eqn:(p ∉ h.erase p) := by apply Finmap.not_mem_erase_self
      move: eqn
      sby srw herase }
    sby apply disjoint_update_not_r }
  { move=> > ? > *
    apply evalExact_frame_get=> //
    sby apply evalExact.get }
  { move=> > [] ? > * * ;
    apply evalExact_frame_set=> //
    sby apply evalExact.set }
  -- { move=> * ; apply eval.eval_free=>//
  --   srw remove_disjoint_union_l ; apply hstar_intro=>//
  --   sby apply disjoint_remove_l }
  { move=> > ??? ih1 ih2 > /ih1 {ih1} ?
    apply evalExact.alloc_arg=> // >
    sby move=> ![>] }
  { unfold tohProp=> > ?? ih > ? ; apply evalExact.alloc=> // >
    move=> /ih /[apply] {}ih /Finmap.disjoint_union_left [] /[dup] /ih {}ih ?
    srw Finmap.Disjoint.symm_iff -Finmap.union_assoc=> ?
    have eqn:((sb ∪ sa).Disjoint h2) := by
      sby srw Finmap.disjoint_union_left
    apply ih in eqn=> {ih} hq ; apply evalExact_post_eq ; rotate_left ; apply hq
    apply funext=> v ; apply funext=> h ; apply propext=> ⟨|⟩
    { move=> ![>] /= ? -> ? ->
      exists (w \ sb), h2=> /== ⟨|⟩ // ⟨|⟩
      { sby apply disjoint_disjoint_diff }
      apply union_diff_disjoint_r
      sby apply Finmap.Disjoint.symm }
    move=> ![>] /= ? -> ? /[dup] heq
    have eqn:((w ∪ h2).Disjoint sb) := by
      { srw -heq ; unfold Finmap.Disjoint=> /== }
    move: eqn=> /Finmap.disjoint_union_left [ ? _]
    move=> /(union_monotone_r (intersect h sb))
    srw diff_insert_intersect_id Finmap.union_assoc [2]Finmap.union_comm_of_disjoint
    rotate_left
    { apply Finmap.Disjoint.symm ; sby apply disjoint_intersect_r }
    srw -Finmap.union_assoc=> ?
    exists (w ∪ intersect h sb), h2=> //== ⟨|⟩
    { sby srw intersect_disjoint_cancel }
    constructor=> //
    srw Finmap.disjoint_union_left ; constructor=> //
    sby apply disjoint_intersect_r }
  { move=> // }
  move=> > ?? ih₁ ih₂ ??; econstructor
  { apply ih₁=> // }
  sby move=> > ![]