Theory Big_StepT_Partial

subsection "Big step Semantics on partial states"

theory Big_StepT_Partial
imports Partial_Evaluation Big_StepT "SepLogAdd/Sep_Algebra_Add"  
    "HOL-Eisbach.Eisbach"
begin


type_synonym lvname = string 
type_synonym pstate_t = "partstate * nat"
type_synonym assnp = "partstate  bool"
type_synonym assn2 = "pstate_t  bool" 

subsubsection ‹helper functions›
     
paragraph ‹restrict›
    
definition restrict where "restrict S s = (%x. if x:S then Some (s x) else None)"
   
lemma restrictI: "xS. s1 x = s2 x  restrict S s1 = restrict S s2"
  unfolding restrict_def by fastforce
    
lemma restrictE: "restrict S s1 = restrict S s2  s1 = s2 on S"
  unfolding restrict_def by (meson option.inject)   
        
lemma dom_restrict[simp]: "dom (restrict S s) = S"
  unfolding restrict_def
  using domIff by fastforce
       
lemma restrict_less_part: "restrict S t  part t"      
  unfolding restrict_def map_le_substate_conv[symmetric] map_le_def part_def apply auto 
  by (metis option.simps(3))
   
paragraph ‹Heap helper functions› 
        
fun lmaps_to_expr :: "aexp  val  assn2" where
  "lmaps_to_expr a v = (%(s,c). dom s = vars a  paval a s = v  c = 0)"
  
fun lmaps_to_expr_x :: "vname  aexp  val  assn2" where
  "lmaps_to_expr_x x a v = (%(s,c). dom s = vars a  {x}  paval a s = v  c = 0)"
      
lemma subState: "x  y  v  dom x  x v = y v" unfolding map_le_substate_conv[symmetric] map_le_def  
  by blast 
       
lemma  fixes ps:: partstate
    and s::state
  assumes "vars a  dom ps" "ps  part s"
  shows emb_update: "emb [x  paval a ps] s = (emb ps s) (x := aval a (emb ps s))"
    using assms
      unfolding emb_def apply auto apply (rule ext)
      apply(case_tac "v=x")
        apply(simp add: paval_aval)
      apply(simp) unfolding part_def apply(case_tac "v  dom ps")
      using subState apply fastforce
      by (simp add: domIff)       
  
lemma paval_aval2: "vars a  dom ps  ps  part s  paval a ps = aval a s"
  apply(induct a) using subState unfolding part_def apply auto  
  by fastforce  
    
lemma  fixes ps:: partstate
    and s::state
  assumes "vars a  dom ps" "ps  part s"
  shows emb_update2: "emb (ps(x  paval a ps)) s = (emb ps s)(x := aval a (emb ps s))"
    using assms
      unfolding emb_def apply auto apply (rule ext)
      apply(case_tac "v=x")
        apply(simp add: paval_aval)
      by (simp)             
     
    
subsubsection "Big step Semantics on partial states"

inductive
  big_step_t_part :: "com × partstate  nat  partstate  bool"  ("_ A _  _" 55)
where
Skip: "(SKIP,s) A Suc 0  s" |
Assign: " vars a  {x}  dom ps; paval a ps = v ; ps' = ps(x  v)   (x ::= a,ps) A Suc 0  ps'" |

Seq: " (c1,s1) A x  s2;  (c2,s2) A y  s3 ; z=x+y   (c1;;c2, s1) A z  s3" |

IfTrue: " vars b  dom ps ; dom ps' = dom ps ; pbval b ps;  (c1,ps) A x  ps'; y=x+1   (IF b THEN c1 ELSE c2, ps) A y  ps'" |
IfFalse: " vars b  dom ps ; dom ps' = dom ps ; ¬ pbval b ps;  (c2,ps) A x  ps'; y=x+1    (IF b THEN c1 ELSE c2, ps) A y  ps'" |
WhileFalse: " vars b  dom s; ¬ pbval b s   (WHILE b DO c,s) A Suc 0  s" |
WhileTrue: " pbval b s1; vars b  dom s1;  (c,s1) A x  s2;  (WHILE b DO c, s2) A y  s3; 1+x+y=z   
           (WHILE b DO c, s1) A z  s3"


declare big_step_t_part.intros [intro]

    
inductive_cases Skip_tE3[elim!]: "(SKIP,s) A x  t"
thm Skip_tE3 
inductive_cases Assign_tE3[elim!]: "(x ::= a,s) A p  t"
thm Assign_tE3
inductive_cases Seq_tE3[elim!]: "(c1;;c2,s1) A p  s3"
thm Seq_tE3
inductive_cases If_tE3[elim!]: "(IF b THEN c1 ELSE c2,s) A x  t"
thm If_tE3
inductive_cases While_tE3[elim]: "(WHILE b DO c,s) A x  t"
thm While_tE3

  
lemmas big_step_t_part_induct = big_step_t_part.induct[split_format(complete)]
  
  
lemma big_step_t3_post_dom_conv: "(c,ps) A t  ps'  dom ps' = dom ps"
apply(induct rule: big_step_t_part_induct) apply (auto simp: sep_disj_fun_def plus_fun_def)
  apply metis   done
      
lemma add_update_distrib: "ps1 x1 = Some y  ps1 ## ps2  vars x2  dom ps1  ps1(x1  paval x2 ps1) + ps2  = (ps1 + ps2)(x1  paval x2 ps1)"
  apply (rule ext)
  apply (auto simp: sep_disj_fun_def plus_fun_def)
  by (metis disjoint_iff_not_equal domI domain_conv)   
  
lemma paval_extend:  "ps1 ## ps2  vars a  dom ps1  paval a (ps1 + ps2) = paval a ps1" 
apply(induct a) apply (auto simp: sep_disj_fun_def domain_conv)
  by (metis domI map_add_comm map_add_dom_app_simps(1) option.sel plus_fun_conv) 
    
lemma pbval_extend: "ps1 ## ps2  vars b  dom ps1  pbval b (ps1 + ps2) = pbval b ps1" 
apply(induct b)  by (auto simp: paval_extend) 
     
    
lemma Framer: "(C, ps1) A m  ps1'  ps1 ## ps2  (C, ps1 + ps2) A m   ps1'+ps2"
proof (induct rule: big_step_t_part_induct)  
  case (Skip s)
  then show ?case by (auto simp: big_step_t_part.Skip)  
next
  case (Assign a x ps v ps')
  show ?case apply(rule big_step_t_part.Assign)  
    using Assign 
     apply (auto simp: plus_fun_def)  
    apply(rule ext)
    apply(case_tac "xa=x") 
    subgoal apply auto subgoal using paval_extend[unfolded plus_fun_def] by auto
       unfolding sep_disj_fun_def
       by (metis disjoint_iff_not_equal domI domain_conv) 
   subgoal by auto   
     done
next
  case (IfTrue b ps ps' c1 x y c2)
  then show ?case apply (auto ) apply(subst big_step_t_part.IfTrue)
         apply (auto simp: pbval_extend) 
      subgoal      by (auto simp: plus_fun_def)
      subgoal      by (auto simp: plus_fun_def)
      subgoal      by (auto simp: plus_fun_def) 
          done
next
  case (IfFalse b ps ps' c2 x y c1)
  then show ?case apply (auto ) apply(subst big_step_t_part.IfFalse)
         apply (auto simp: pbval_extend) 
      subgoal      by (auto simp: plus_fun_def)
      subgoal      by (auto simp: plus_fun_def)
      subgoal      by (auto simp: plus_fun_def) 
          done
next
  case (WhileFalse b s c)
  then show ?case apply(subst big_step_t_part.WhileFalse)
      subgoal      by (auto simp: plus_fun_def)
      subgoal      by (auto simp: pbval_extend)
          by auto
next
  case (WhileTrue b s1 c x s2 y s3 z)
  from big_step_t3_post_dom_conv[OF WhileTrue(3)]  have "dom s2 = dom s1" by auto
  with WhileTrue(8) have "s2 ## ps2" unfolding sep_disj_fun_def domain_conv by auto
  with WhileTrue show ?case apply auto apply(subst big_step_t_part.WhileTrue)
      subgoal      by (auto simp: pbval_extend)
      subgoal      by (auto simp: plus_fun_def)
             apply (auto) done
next
  case (Seq c1 s1 x s2 c2 y s3 z)
  from big_step_t3_post_dom_conv[OF Seq(1)]  have "dom s2 = dom s1" by auto
  with Seq(6) have "s2 ## ps2" unfolding sep_disj_fun_def domain_conv by auto
  with Seq show ?case apply (subst big_step_t_part.Seq)
      by auto
qed
   
   
lemma Framer2: "(C, ps1) A m  ps1'  ps1 ## ps2  ps = ps1 + ps2  ps' = ps1'+ps2  (C, ps) A m  ps' "
  using Framer by auto
  
(* connection to bigstep2 *)
   
subsubsection ‹Relation to BigStep Semantic on full states› 
    
lemma paval_aval_part: "paval a (part s) = aval a s"
  apply(induct a) by (auto simp: part_def) 
lemma pbval_bval_part: "pbval b (part s) = bval b s"
  apply(induct b) by (auto simp: paval_aval_part) 
 
    
lemma part_paval_aval: "part (s(x := aval a s)) = (part s)(x  paval a (part s))"
  apply(rule ext)
  apply(case_tac "xa=x")  
    unfolding part_def apply auto by (metis (full_types) domIff map_le_def map_le_substate_conv option.distinct(1) part_def paval_aval2 subsetI) 
       
      
lemma full_to_part: "(C, s)  m  s'   (C, part s) A m  part s' " 
apply(induct rule: big_step_t_induct)
  using Skip apply simp 
       apply (subst Assign)
          using part_paval_aval apply(simp_all add: )
    apply(rule Seq) apply auto
    apply(rule IfTrue) apply (auto simp: pbval_bval_part)
    apply(rule IfFalse) apply (auto simp: pbval_bval_part)
    apply(rule WhileFalse) apply (auto simp: pbval_bval_part)
  apply(rule WhileTrue) apply (auto simp: pbval_bval_part)
  done        
  
lemma part_to_full': "(C, ps) A m  ps'  (C, emb ps s)  m  emb ps' s" 
proof (induct rule: big_step_t_part_induct) 
  case (Assign a x ps v ps')
  have z: "paval a ps = aval a (emb ps s)"
    apply(rule paval_aval_vars) using Assign(1) by auto
  have g :"emb ps' s = (emb ps s)(x:=aval a (emb ps s) )"
    apply(simp only: Assign z[symmetric])
      unfolding emb_def by auto      
  show ?case apply(simp only: g) by(rule big_step_t.Assign)
qed (auto simp: pbval_bval_vars[symmetric])
  
  
lemma part_to_full: "(C, part s) A m  part s'  (C, s)  m  s'"
proof -
  assume "(C, part s) A m  part s'"
  then have "(C, emb (part s) s)  m  emb (part s') s" by (rule part_to_full')
  then show "(C, s)  m  s'" by auto
qed
  
  
lemma part_full_equiv: "(C, s)  m  s'  (C, part s) A m  part s'"
using part_to_full full_to_part by metis    
    
subsubsection ‹more properties›
    
lemma big_step_t3_gt0: "(C, ps) A x  ps'  x > 0"
apply(induct rule: big_step_t_part_induct) apply auto done
        
lemma big_step_t3_same: "(C, ps) A m  ps' ==>  ps = ps' on UNIV - lvars C"
apply(induct rule: big_step_t_part_induct) by (auto simp: sep_disj_fun_def plus_fun_def) 
    
lemma avalDirekt3_correct: " (x ::= N v, ps) A m  ps'  paval' a ps = Some v   (x ::= a, ps) A m  ps'" 
apply(auto) apply(subst Assign) by (auto simp: paval_paval' paval'dom) 
    


  
subsection ‹Partial State›    
  
 
  
(* partialstate and nat is a separation algebra ! *)  
lemma
  fixes h :: "(vname  val option) * nat"
  shows "(P ** Q ** H) h = (Q ** H ** P) h"
  by (simp add: sep_conj_ac)
        
lemma separate_othogonal_commuted': assumes
    "ps n. P (ps,n)  ps = 0"
    "ps n. Q (ps,n)  n = 0"
  shows "(P ** Q) s  P (0,snd s)  Q (fst s,0)"
  using assms unfolding sep_conj_def by force  
   
 
lemma separate_othogonal_commuted: assumes
    "ps n. P (ps,n)  ps = 0"
    "ps n. Q (ps,n)  n = 0"
  shows "(P ** Q) (ps,n)  P (0,n)  Q (ps,0)"
  using assms unfolding sep_conj_def by force  
   
    
lemma separate_othogonal: assumes
    "ps n. P (ps,n)  n = 0"
    "ps n. Q (ps,n)  ps = 0"
  shows "(P ** Q) (ps,n)  P (ps,0)  Q (0,n)"
  using assms unfolding sep_conj_def by force 
    
lemma assumes "  ((λ(s, n). P (s, n)  vars b  dom s) ∧* (λ(s, c). s = 0  c = Suc 0)) (ps, n)"
shows " n'. P (ps, n')  vars b  dom ps  n = Suc n'"
proof -
  from assms obtain x y where " x ## y" and "(ps, n) = x + y" 
      and 2: "(case x of (s, n)  P (s, n)  vars b   dom s)"
      and "(case y of (s, c)  s = 0  c = Suc 0)" 
    unfolding sep_conj_def by blast
  then have "y = (0, Suc 0)" and f: "fst x = ps" and n: "n = snd x + Suc 0" by auto
    
  with 2 have "P (ps, snd x)  vars b  dom ps  n = Suc (snd x)"
    by auto 
  then show ?thesis by simp
qed 
       
    
    
    
subsection ‹Dollar and Pointsto›    
    
definition dollar :: "nat  assn2" ("$") where
  "dollar q = (%(s,c). s = 0  c=q)"
  
  
lemma sep_reorder_dollar_aux:  
    "NO_MATCH ($X) A  ($B ** A) = (A ** $B)"   
    "($X ** $Y) = $(X+Y)"
   apply (auto simp: sep_simplify)
    unfolding dollar_def sep_conj_def sep_disj_prod_def sep_disj_nat_def by auto
     
lemmas sep_reorder_dollar = sep_conj_assoc sep_reorder_dollar_aux

lemma stardiff: assumes "(P ∧* $m) (ps, n)"
  shows  P: "P (ps, n - m)" and "mn" using assms unfolding sep_conj_def dollar_def by auto     

lemma [simp]: "(Q ** $0) = Q" unfolding dollar_def sep_conj_def sep_disj_prod_def sep_disj_nat_def  
  by auto 
  
definition embP :: "(partstate  bool)  partstate × nat  bool" where "embP P = (%(s,n). P s  n = 0)"
  
    
lemma orthogonal_split: assumes "(embP Q ∧* $ n) = (embP P ∧* $ m)"   
  shows "(Q = P  n = m)  Q = (λs. False)  P = (λs. False)"
  using assms unfolding embP_def dollar_def apply (auto intro!: ext)
    unfolding sep_conj_def apply auto unfolding  sep_disj_prod_def  plus_prod_def  
    apply (metis fst_conv snd_conv)+ done
      
(* how to set up case rules *)      
      
lemma F: assumes "(embP Q ∧* $ n) = (embP P ∧* $ m)"   
  obtains (blub) "Q = P" and "n = m" |
          (da)  "Q = (λs. False)" and "P = (λs. False)" 
  using assms orthogonal_split by auto
    
lemma T: assumes "(embP Q ∧* $ n) = (embP P ∧* $ m)"   
  obtains (blub) x::nat where "Q = P" and "n = m" and "x=x" |
          (da)  "Q = (λs. False)" and "P = (λs. False)"
          using assms orthogonal_split by auto
  
  
definition pointsto :: "vname  val  assn2"  ("_  _" [56,51] 56) where
  "v  n = (%(s,c). s = [v  n]  c=0)"
  
(* If you don't mind syntax ambiguity: *)
notation pred_ex (binder "" 10)
  
definition maps_to_ex :: "vname  assn2" ("_  -" [56] 56)
  where "x  -  y. x  y"
        
fun lmaps_to_ex :: "vname set  assn2" where
  "lmaps_to_ex xs = (%(s,c). dom s = xs  c = 0)"
   
  
lemma "(x  -) (s,n)  x  dom s"
  unfolding maps_to_ex_def pointsto_def by auto 
      
fun lmaps_to_axpr :: "bexp  bool  assnp" where
  "lmaps_to_axpr b bv = (%ps. vars b  dom ps  pbval b ps = bv )"
 
definition lmaps_to_axpr' :: "bexp  bool  assnp" where
  "lmaps_to_axpr' b bv = lmaps_to_axpr b bv"
  
   
    
    
subsection ‹Frame Inference›
      
definition Frame where "Frame P Q F     s. (P imp (Q ** F)) s" 
definition Frame' where "Frame' P P' Q F  s. (( P' ** P) imp (Q ** F)) s"  

definition cnv where "cnv x y == x = y"
  
lemma cnv_I: "cnv x x"
  unfolding cnv_def by simp
  
lemma Frame'_conv: "Frame P Q F = Frame' (P ** )  (Q ** ) F" 
  unfolding Frame_def Frame'_def apply auto done     
    
lemma Frame'I: "Frame' (P ** )  (Q ** ) F  cnv F F'  Frame P Q F'" 
  unfolding Frame_def Frame'_def cnv_def apply auto done
    
lemma FrameD: assumes "Frame P Q F" " P s "
  shows "(F ** Q) s"
  using assms unfolding Frame_def by (auto simp: sep_conj_commute)    
    
lemma Frame'_match: "Frame' (P ** P')  Q F  Frame' (x  v ** P) P' (x  v ** Q) F" 
  unfolding Frame_def Frame'_def apply (auto simp: sep_conj_ac)
  by (metis (no_types, opaque_lifting) prod.collapse sep.mult_assoc sep_conj_impl1)   
    
lemma R: assumes "s. (A imp B) s" shows "((A ** $n) imp (B ** $n)) s"    
proof (safe)
  assume "(A ∧* $ n) s"
  then obtain h1 h2 where A: "A h1"  and n: "$n h2" and disj: "h1 ## h2" "s = h1+h2" unfolding sep_conj_def by blast
  from assms A have B: "B h1" by auto    
  show "(B ** $n) s" using B n disj unfolding sep_conj_def by blast
qed 
  
lemma Frame'_matchdollar:  assumes "Frame' (P ** P' ** $(n-m))  Q F" and nm: "nm"
  shows "Frame' ($n ** P) P' ($m ** Q) F" 
 using assms(1) unfolding Frame_def Frame'_def apply (auto simp: sep_conj_ac)  
proof (goal_cases)
  case (1 a b) 
  have g: "((P ∧* P' ∧* $ n) imp (F ∧* Q ∧* $ m)) (a, b)
         (((P ∧* P' ∧* $(n-m)) ** $m) imp ((F ∧* Q) ∧* $ m)) (a, b)" 
    by(simp add: nm sep_reorder_dollar)
  have "((P ∧* P' ∧* $ n) imp (F ∧* Q ∧* $ m)) (a, b)"     
    apply(subst g)
      apply(rule R) using 1(1) by auto
  then have "(P ∧* P' ∧* $ n) (a, b)  (F ∧* Q ∧* $ m) (a, b)"
    by blast  
  then show ?case using 1(2) by auto
qed
                                                            
lemma Frame'_nomatch: " Frame' P (p ** P') (x  v ** Q) F Frame' (p ** P) P' (x  v ** Q) F" 
  unfolding  Frame'_def by (auto simp: sep_conj_ac)   
    
lemma Frame'_nomatchempty: " Frame' P P' (x  v ** Q) F Frame' ( ** P) P' (x  v ** Q) F" 
  unfolding  Frame'_def by (auto simp: sep_conj_ac) 
        
(* this will only be reached after a Frame'_match move, where P' is □ *)    
lemma Frame'_end: " Frame' P   P"
  unfolding  Frame'_def by (auto simp: sep_conj_ac)   
        
schematic_goal "Frame (x  v1 ∧* y  v2)  (x  ?v) ?F"
  apply(rule Frame'I) apply(simp only: sep_conj_assoc)
  apply(rule Frame'_match)
  apply(rule Frame'_end) apply(simp only: sep_conj_ac sep_conj_empty' sep_conj_empty) apply(rule cnv_I) done
    
schematic_goal "Frame (x  v1 ∧* y  v2)  (y  ?v) ?F"
  apply(rule Frame'I) apply(simp only: sep_conj_assoc)
   apply(rule Frame'_end Frame'_match Frame'_nomatchempty Frame'_nomatch; (simp only: sep_conj_assoc)?)+
    apply(simp only: sep_conj_ac sep_conj_empty' sep_conj_empty) apply(rule cnv_I) 
   done
        
method frame_inference_init = (rule Frame'I, (simp only: sep_conj_assoc)?)

method frame_inference_solve = (rule Frame'_matchdollar Frame'_end Frame'_match Frame'_nomatchempty Frame'_nomatch; (simp only: sep_conj_assoc)?)+
  
method frame_inference_cleanup = ( (simp only: sep_conj_ac sep_conj_empty' sep_conj_empty)?; rule cnv_I)
  
  
method frame_inference = (frame_inference_init, (frame_inference_solve; fail), (frame_inference_cleanup; fail))
method frame_inference_debug = (frame_inference_init, frame_inference_solve)
  
subsubsection ‹tests›  
      
schematic_goal "Frame (x  v1 ∧* y  v2)  (y  ?v) ?F"
  by frame_inference
    
schematic_goal "Frame (x  v1 ** P **  ** y  v2 ∧* z  v2 ** Q)  (z  ?v ** y  ?v2) ?F"
  by frame_inference
          
(* with dollar *)

schematic_goal " 1  v  Frame ($ (2 * v) ∧* ''x''  int v) ($ 1 ∧* ''x''  ?d) ?F" 
  apply(rule Frame'I) apply(simp only: sep_conj_assoc) 
   apply(rule  Frame'_matchdollar Frame'_end Frame'_match Frame'_nomatchempty Frame'_nomatch; (simp only: sep_conj_assoc)?)+
  apply (simp only: sep_conj_ac sep_conj_empty' sep_conj_empty)?
  apply (rule cnv_I) done 
    
    
schematic_goal " 0 < v  Frame ($ (2 * v) ∧* ''x''  int v) ($ 1 ∧* ''x''  ?d) ?F"    
    apply frame_inference done
            
subsection ‹Expression evaluation›
      
definition symeval where "symeval P e v  (s n. P (s,n)  paval' e s = Some v)"    
definition symevalb where "symevalb P e v  (s n. P (s,n)  pbval' e s = Some v)"      
      
lemma symeval_c: "symeval P (N v) v"
  unfolding symeval_def apply auto done
      
    
lemma symeval_v: assumes "Frame P (x  v) F"
  shows "symeval P (V x) v"
  unfolding symeval_def apply auto
  apply (drule FrameD[OF assms])  unfolding sep_conj_def pointsto_def  
  apply (auto simp: plus_fun_conv) done
    
lemma symeval_plus: assumes "symeval P e1 v1" "symeval P e2 v2"
  shows "symeval P (Plus e1 e2) (v1+v2)"
  using assms unfolding symeval_def by auto 
    
    
lemma symevalb_c: "symevalb P (Bc v) v"
  unfolding symevalb_def apply auto done
          
lemma symevalb_and: assumes "symevalb P e1 v1" "symevalb P e2 v2"
  shows "symevalb P (And e1 e2) (v1  v2)"
  using assms unfolding symevalb_def  by auto
    
lemma symevalb_not:  assumes "symevalb P e v"
  shows "symevalb P (Not e) (¬ v)"
  using assms unfolding symevalb_def  by auto
    
lemma symevalb_less: assumes "symeval P e1 v1" "symeval P e2 v2"
  shows "symevalb P (Less e1 e2) (v1 < v2)"
  using assms unfolding symevalb_def symeval_def by auto
  
lemmas symeval = symeval_c symeval_v symeval_plus symevalb_c symevalb_and symevalb_not symevalb_less
   
schematic_goal "symevalb ( (x  v1) ** (y  v2) ) (Less (Plus (V x) (V y)) (N 5)) ?g"
  apply(rule symeval | frame_inference)+ done
    
end