-- SPLean/Theories/HProp.lean

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

-- Repository definitions used:
content: syntax "sdo" num tactic : tactic

content: notation:max "emp" => hempty

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

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

syntax "⟨" term "⟩" : lang

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

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

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: 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: notation "funloc" p "↦" H =>
  fun (r : val) ↦ hexists (fun p ↦ ⌜r = val_loc p⌝ ∗ H)

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

-- Local definitions used:
content: def hProp := heap -> Prop

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

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

content: def hempty : hProp :=
  fun h => (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: def hexists {A} (J : A → hProp) : hProp :=
  fun h => exists x, J x h

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

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

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

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

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

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

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

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

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

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

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

-- Local lemmas used:
content: lemma himpl_trans H2 H1 H3 :
  (H1 ==> H2) → (H2 ==> H3) → (H1 ==> H3)

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

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

content: lemma hempty_inv h :
  emp h → h = ∅

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

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

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

content: lemma hstar_hempty_l H :
  emp ∗ H = H

content: lemma hstar_hempty_r H :
  H ∗ emp = H

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

-- Target theorem and proof:
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=> ?