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

end evalProp

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

-- Repository definitions used:
content: notation:max "emp" => hempty

syntax "fun" ident+ " => " lang : 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: macro_rules | `($x ∗ $y)   => `(binop% HStar.hStar $x $y)

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

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

content: def hProp := heap -> Prop

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: 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 hempty : hProp :=
  fun h => (h = ∅)

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

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

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: notation:max "emp" => hempty

content: infixr:60 " ~~> " => hsingle

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

-- Repository lemmas used:
content: lemma hempty_inv h :
  emp h → h = ∅

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

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

-- Local lemmas used:
content: lemma int_eq_sub (l m n : ℤ) :
  l + m = n → l = n - m

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

-- Target theorem and proof:
lemma hrange_eq_conseq (L : List val) (n : ℤ) (p : loc) (s : state) :
  L.length = n →
  hrange L p s →
  s.keys = (conseq (make_list n.natAbs val_uninit) p).keys
:= by
  elim: L n p s=> > ; unfold hrange
  { sby move=> /= <- /= /hempty_inv -> }
  move=> ih > /== /[dup] /int_eq_sub /[dup] hn /ih {}ih  <-
  srw -hn at ih
  move: ih=> /= ih {hn}
  unfold hrange=> ![>] /hsingl_inv ? /ih {}ih ? ->
  unfold conseq make_list
  srw list_inc_natabs=> /== >
  move: ih
  sby srw ?Finset.ext_iff Finmap.mem_keys=> ?