(*  Title:      JinjaDCI/BV/BVExec.thy

    Author:     Tobias Nipkow, Gerwin Klein, Susannah Mansky
    Copyright   2000 TUM, 2020 UIUC

    Based on the Jinja theory BV/BVExec.thy by Tobias Nipkow and Gerwin Klein
*)

section \<open> Kildall for the JVM \label{sec:JVM} \<close>

theory BVExec
imports "../DFA/Abstract_BV" TF_JVM
begin

definition kiljvm :: "jvm_prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty \<Rightarrow>
             instr list \<Rightarrow> ex_table \<Rightarrow> ty\<^sub>i' err list \<Rightarrow> ty\<^sub>i' err list"
where
  "kiljvm P mxs mxl T\<^sub>r is xt \<equiv>
  kildall (JVM_SemiType.le P mxs mxl) (JVM_SemiType.sup P mxs mxl)
          (exec P mxs T\<^sub>r xt is)"

definition wt_kildall :: "jvm_prog \<Rightarrow> cname \<Rightarrow> staticb \<Rightarrow> ty list \<Rightarrow> ty \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow>
                 instr list \<Rightarrow> ex_table \<Rightarrow> bool"
where
  "wt_kildall P C' b Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<equiv>
   0 < size is \<and>
   (let first  = Some ([],(case b of Static \<Rightarrow> [] | NonStatic \<Rightarrow> [OK (Class C')])
                            @(map OK Ts)@(replicate mxl\<^sub>0 Err));
        start  = (OK first)#(replicate (size is - 1) (OK None));
        result = kiljvm P mxs
                   ((case b of Static \<Rightarrow> 0 | NonStatic \<Rightarrow> 1)+size Ts+mxl\<^sub>0)
                     T\<^sub>r is xt start
    in \<forall>n < size is. result!n \<noteq> Err)"

definition wf_jvm_prog\<^sub>k :: "jvm_prog \<Rightarrow> bool"
where
  "wf_jvm_prog\<^sub>k P \<equiv>
  wf_prog (\<lambda>P C' (M,b,Ts,T\<^sub>r,(mxs,mxl\<^sub>0,is,xt)). wt_kildall P C' b Ts T\<^sub>r mxs mxl\<^sub>0 is xt) P"

theorem (in start_context) is_bcv_kiljvm:
  "is_bcv r Err step (size is) A (kiljvm P mxs mxl T\<^sub>r is xt)"
(*<*)
  apply (insert wf)
  apply (unfold kiljvm_def)
  apply (fold r_def f_def step_def_exec)
  apply (rule is_bcv_kildall)
       apply simp apply (rule Semilat.intro)
       apply (fold sl_def2)
       apply (erule semilat_JVM)
      apply simp
      apply blast
     apply (simp add: JVM_le_unfold)
    apply (rule exec_pres_type)
   apply (rule bounded_step)
  apply (erule step_mono)
  done
(*>*)

(* FIXME: move? *)
lemma subset_replicate [intro?]: "set (replicate n x) \<subseteq> {x}"
  by (induct n) auto

lemma in_set_replicate:
  assumes "x \<in> set (replicate n y)"
  shows "x = y"
(*<*)
proof -
  note assms
  also have "set (replicate n y) \<subseteq> {y}" ..
  finally show ?thesis by simp
qed
(*>*)

lemma (in start_context) start_in_A [intro?]:
  "0 < size is \<Longrightarrow> start \<in> list (size is) A"
  using Ts C
(*<*)
  apply (simp add: JVM_states_unfold)
  apply (cases b; force intro!: listI list_appendI dest!: in_set_replicate)
  done
(*>*)

theorem (in start_context) wt_kil_correct:
  assumes wtk: "wt_kildall P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt"
  shows "\<exists>\<tau>s. wt_method P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<tau>s"
(*<*)
proof -
  from wtk obtain res where
    result:   "res = kiljvm P mxs mxl T\<^sub>r is xt start" and
    success:  "\<forall>n < size is. res!n \<noteq> Err" and
    instrs:   "0 < size is"
    by (unfold wt_kildall_def) simp

  have bcv: "is_bcv r Err step (size is) A (kiljvm P mxs mxl T\<^sub>r is xt)"
    by (rule is_bcv_kiljvm)

  from instrs have "start \<in> list (size is) A" ..
  with bcv success result have
    "\<exists>ts\<in>list (size is) A. start [\<sqsubseteq>\<^sub>r] ts \<and> wt_step r Err step ts"
    by (unfold is_bcv_def) blast
  then obtain \<tau>s' where
    in_A: "\<tau>s' \<in> list (size is) A" and
    s:    "start [\<sqsubseteq>\<^sub>r] \<tau>s'" and
    w:    "wt_step r Err step \<tau>s'"
    by blast
  hence wt_err_step: "wt_err_step (sup_state_opt P) step \<tau>s'"
    by (simp add: wt_err_step_def JVM_le_Err_conv)

  from in_A have l: "size \<tau>s' = size is" by simp
  moreover {
    from in_A  have "check_types P mxs mxl \<tau>s'" by (simp add: check_types_def)
    also from w have "\<forall>x \<in> set \<tau>s'. x \<noteq> Err"
      by (auto simp add: wt_step_def all_set_conv_all_nth)
    hence [symmetric]: "map OK (map ok_val \<tau>s') = \<tau>s'"
      by (auto intro!: map_idI simp add: wt_step_def)
    finally  have "check_types P mxs mxl (map OK (map ok_val \<tau>s'))" .
  }
  moreover {
    from s have "start!0 \<sqsubseteq>\<^sub>r \<tau>s'!0" by (rule le_listD) simp
    moreover
    from instrs w l
    have "\<tau>s'!0 \<noteq> Err" by (unfold wt_step_def) simp
    then obtain \<tau>s0 where "\<tau>s'!0 = OK \<tau>s0" by auto
    ultimately
    have "wt_start P C b Ts mxl\<^sub>0 (map ok_val \<tau>s')" using l instrs
      by (unfold wt_start_def)
         (cases b; simp add: lesub_def JVM_le_Err_conv Err.le_def)
  }
  moreover
  from in_A have "set \<tau>s' \<subseteq> A" by simp
  with wt_err_step bounded_step
  have "wt_app_eff (sup_state_opt P) app eff (map ok_val \<tau>s')"
    by (auto intro: wt_err_imp_wt_app_eff simp add: l)
  ultimately
  have "wt_method P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt (map ok_val \<tau>s')"
    using instrs by (simp add: wt_method_def2 check_types_def del: map_map)
  thus ?thesis by blast
qed
(*>*)

theorem (in start_context) wt_kil_complete:
  assumes wtm: "wt_method P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<tau>s"
  shows "wt_kildall P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt"
(*<*)
proof -
  from wtm obtain
    instrs:   "0 < size is" and
    length:   "length \<tau>s = length is" and
    ck_type:  "check_types P mxs mxl (map OK \<tau>s)" and
    wt_start: "wt_start P C b Ts mxl\<^sub>0 \<tau>s" and
    app_eff:  "wt_app_eff (sup_state_opt P) app eff \<tau>s"
    by (simp add: wt_method_def2 check_types_def)

  from ck_type
  have in_A: "set (map OK \<tau>s) \<subseteq> A"
    by (simp add: check_types_def)
  with app_eff in_A bounded_step
  have "wt_err_step (sup_state_opt P) (err_step (size \<tau>s) app eff) (map OK \<tau>s)"
    by - (erule wt_app_eff_imp_wt_err,
          auto simp add: exec_def length states_def)
  hence wt_err: "wt_err_step (sup_state_opt P) step (map OK \<tau>s)"
    by (simp add: length)
  have is_bcv: "is_bcv r Err step (size is) A (kiljvm P mxs mxl T\<^sub>r is xt)"
    by (rule is_bcv_kiljvm)
  moreover from instrs have "start \<in> list (size is) A" ..
  moreover
  let ?\<tau>s = "map OK \<tau>s"
  have less_\<tau>s: "start [\<sqsubseteq>\<^sub>r] ?\<tau>s"
  proof (rule le_listI)
    from length instrs
    show "length start = length (map OK \<tau>s)" by simp
  next
    fix n
    from wt_start have "P \<turnstile> ok_val (start!0) \<le>' \<tau>s!0"
      by (cases b; simp add: wt_start_def)
    moreover from instrs length have "0 < length \<tau>s" by simp
    ultimately have "start!0 \<sqsubseteq>\<^sub>r ?\<tau>s!0"
      by (simp add: JVM_le_Err_conv lesub_def)
    moreover {
      fix n'
      have "OK None \<sqsubseteq>\<^sub>r ?\<tau>s!n"
        by (auto simp add: JVM_le_Err_conv Err.le_def lesub_def
                 split: err.splits)
      hence "\<lbrakk>n = Suc n'; n < size start\<rbrakk> \<Longrightarrow> start!n \<sqsubseteq>\<^sub>r ?\<tau>s!n" by simp
    }
    ultimately
    show "n < size start \<Longrightarrow> start!n \<sqsubseteq>\<^sub>r ?\<tau>s!n" by (cases n, blast+)
  qed
  moreover
  from ck_type length
  have "?\<tau>s \<in> list (size is) A"
    by (auto intro!: listI simp add: check_types_def)
  moreover
  from wt_err have "wt_step r Err step ?\<tau>s"
    by (simp add: wt_err_step_def JVM_le_Err_conv)
  ultimately
  have "\<forall>p. p < size is \<longrightarrow> kiljvm P  mxs mxl T\<^sub>r is xt start ! p \<noteq> Err"
    by (unfold is_bcv_def) blast
  with instrs
  show "wt_kildall P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt" by (unfold wt_kildall_def) simp
qed
(*>*)

theorem jvm_kildall_correct:
  "wf_jvm_prog\<^sub>k P = wf_jvm_prog P"
(*<*)
proof
  let ?\<Phi> = "\<lambda>C M. let (C,b,Ts,T\<^sub>r,(mxs,mxl\<^sub>0,is,xt)) = method P C M in
              SOME \<tau>s. wt_method P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<tau>s"

  \<comment> \<open>soundness\<close>
  assume wt: "wf_jvm_prog\<^sub>k P"
  hence "wf_jvm_prog\<^bsub>?\<Phi>\<^esub> P"
    apply (unfold wf_jvm_prog_phi_def wf_jvm_prog\<^sub>k_def)
    apply (erule wf_prog_lift)
    apply (auto dest!: start_context.wt_kil_correct [OF start_context.intro]
                intro: someI)
    apply (erule sees_method_is_class)
    done
  thus "wf_jvm_prog P" by (unfold wf_jvm_prog_def) fast
next
  \<comment> \<open>completeness\<close>
  assume wt: "wf_jvm_prog P"
  thus "wf_jvm_prog\<^sub>k P"
    apply (unfold wf_jvm_prog_def wf_jvm_prog_phi_def wf_jvm_prog\<^sub>k_def)
    apply (clarify)
    apply (erule wf_prog_lift)
    apply (auto intro!: start_context.wt_kil_complete start_context.intro)
    apply (erule sees_method_is_class)
    done
qed
(*>*)

end


theory IICF_HOL_List
imports "../Intf/IICF_List"
begin

context
begin

private lemma id_take_nth_drop_rl:
  assumes "i<length l"
  assumes "\<And>l1 x l2. \<lbrakk>l=l1@x#l2; i = length l1 \<rbrakk> \<Longrightarrow> P (l1@x#l2)"
  shows "P l"
  apply (subst id_take_nth_drop[OF assms(1)])
  apply (rule assms(2))
  apply (subst id_take_nth_drop[OF assms(1)])
  apply simp
  apply (simp add: assms(1))
  done

private lemma list_set_entails_aux:
  shows "list_assn A l li * A x xi \<Longrightarrow>\<^sub>A list_assn A (l[i := x]) (li[i := xi]) * true"
  apply (rule entails_preI)
  apply (clarsimp)
  apply (cases "i < length l"; cases "i < length li"; (sep_auto dest!: list_assn_aux_eqlen_simp;fail)?)
  apply (erule id_take_nth_drop_rl)
  apply (erule id_take_nth_drop_rl)
  apply (sep_auto simp add: list_update_append)
  done

private lemma list_set_hd_tl_aux:
  "a \<noteq> [] \<Longrightarrow> list_assn R a c \<Longrightarrow>\<^sub>A R (hd a) (hd c) * true"
  "a \<noteq> [] \<Longrightarrow> list_assn R a c \<Longrightarrow>\<^sub>A list_assn R (tl a) (tl c) * true"
  by (cases c; cases a; sep_auto; fail)+

private lemma list_set_last_butlast_aux:
  "a \<noteq> [] \<Longrightarrow> list_assn R a c \<Longrightarrow>\<^sub>A R (last a) (last c) * true"
  "a \<noteq> [] \<Longrightarrow> list_assn R a c \<Longrightarrow>\<^sub>A list_assn R (butlast a) (butlast c) * true"
  by (cases c rule: rev_cases; cases a  rule: rev_cases; sep_auto; fail)+

private lemma swap_decomp_simp[simp]:
  "swap (l1 @ x # c21' @ xa # l2a) (length l1) (Suc (length l1 + length c21')) = l1@xa#c21'@x#l2a"
  "swap (l1 @ x # c21' @ xa # l2a) (Suc (length l1 + length c21')) (length l1) = l1@xa#c21'@x#l2a"
  by (auto simp: swap_def list_update_append nth_append)

private lemma list_swap_aux: "\<lbrakk>i < length l; j < length l\<rbrakk> \<Longrightarrow> list_assn A l li \<Longrightarrow>\<^sub>A list_assn A (swap l i j) (swap li i j) * true"
  apply (subst list_assn_aux_len; clarsimp)
  apply (cases "i=j"; (sep_auto;fail)?)
  apply (rule id_take_nth_drop_rl[where l=l and i=i]; simp)
  apply (rule id_take_nth_drop_rl[where l=l and i=j]; simp)
  apply (erule list_match_lel_lel; simp)
  apply (split_list_according li l; sep_auto)
  apply (split_list_according li l; sep_auto)
  done

private lemma list_rotate1_aux: "list_assn A a c \<Longrightarrow>\<^sub>A list_assn A (rotate1 a) (rotate1 c) * true"
  by (cases a; cases c; sep_auto)

private lemma list_rev_aux: "list_assn A a c \<Longrightarrow>\<^sub>A list_assn A (rev a) (rev c) * true"
  apply (subst list_assn_aux_len; clarsimp)
  apply (induction rule: list_induct2)
  apply sep_auto
  apply sep_auto
  apply (erule ent_frame_fwd, frame_inference)
  apply sep_auto
  done

lemma mod_starE:
  assumes "h \<Turnstile> A*B"
  obtains h1 h2 where "h1\<Turnstile>A" "h2\<Turnstile>B"
  using assms by (auto simp: mod_star_conv)

private lemma CONSTRAINT_is_pureE:
  assumes "CONSTRAINT is_pure A"
  obtains R where "A=pure R"
  using assms by (auto simp: is_pure_conv)

private method solve_dbg =
  ( (elim CONSTRAINT_is_pureE; (simp only: list_assn_pure_conv the_pure_pure)?)?;
    sep_auto
      simp: pure_def hn_ctxt_def invalid_assn_def list_assn_aux_eqlen_simp
      intro!: hn_refineI[THEN hn_refine_preI] hfrefI
      elim!: mod_starE
      intro: list_set_entails_aux list_set_hd_tl_aux list_set_last_butlast_aux
             list_swap_aux list_rotate1_aux list_rev_aux
    ;
    ((rule entails_preI; sep_auto simp: list_assn_aux_eqlen_simp | (parametricity; simp; fail))?)
  )

private method solve = solve_dbg; fail

(* TODO: Establish sepref_import param mechanism that can handle this! *)

lemma HOL_list_empty_hnr_aux: "(uncurry0 (return op_list_empty), uncurry0 (RETURN op_list_empty)) \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a (list_assn A)" by solve
lemma HOL_list_is_empty_hnr[sepref_fr_rules]: "(return \<circ> op_list_is_empty, RETURN \<circ> op_list_is_empty) \<in> (list_assn A)\<^sup>k \<rightarrow>\<^sub>a bool_assn" by solve
lemma HOL_list_prepend_hnr[sepref_fr_rules]: "(uncurry (return \<circ>\<circ> op_list_prepend), uncurry (RETURN \<circ>\<circ> op_list_prepend)) \<in> A\<^sup>d *\<^sub>a (list_assn A)\<^sup>d \<rightarrow>\<^sub>a list_assn A" by solve
lemma HOL_list_append_hnr[sepref_fr_rules]: "(uncurry (return \<circ>\<circ> op_list_append), uncurry (RETURN \<circ>\<circ> op_list_append)) \<in> (list_assn A)\<^sup>d *\<^sub>a A\<^sup>d \<rightarrow>\<^sub>a list_assn A"  by solve
lemma HOL_list_concat_hnr[sepref_fr_rules]: "(uncurry (return \<circ>\<circ> op_list_concat), uncurry (RETURN \<circ>\<circ> op_list_concat)) \<in> (list_assn A)\<^sup>d *\<^sub>a (list_assn A)\<^sup>d \<rightarrow>\<^sub>a list_assn A"  by solve
lemma HOL_list_length_hnr[sepref_fr_rules]: "(return \<circ> op_list_length, RETURN \<circ> op_list_length) \<in> (list_assn A)\<^sup>k \<rightarrow>\<^sub>a nat_assn"  by solve
lemma HOL_list_set_hnr[sepref_fr_rules]: "(uncurry2 (return \<circ>\<circ>\<circ> op_list_set), uncurry2 (RETURN \<circ>\<circ>\<circ> op_list_set)) \<in> (list_assn A)\<^sup>d *\<^sub>a nat_assn\<^sup>k *\<^sub>a A\<^sup>d \<rightarrow>\<^sub>a list_assn A"  by solve
lemma HOL_list_hd_hnr[sepref_fr_rules]: "(return \<circ> op_list_hd, RETURN \<circ> op_list_hd) \<in> [\<lambda>y. y \<noteq> []]\<^sub>a (list_assn R)\<^sup>d \<rightarrow> R"  by solve
lemma HOL_list_tl_hnr[sepref_fr_rules]: "(return \<circ> op_list_tl, RETURN \<circ> op_list_tl) \<in> [\<lambda>y. y \<noteq> []]\<^sub>a (list_assn A)\<^sup>d \<rightarrow> list_assn A"  by solve
lemma HOL_list_last_hnr[sepref_fr_rules]: "(return \<circ> op_list_last, RETURN \<circ> op_list_last) \<in> [\<lambda>y. y \<noteq> []]\<^sub>a (list_assn R)\<^sup>d \<rightarrow> R"  by solve

lemma HOL_list_replicate_hnr[sepref_fr_rules]: "CONSTRAINT is_pure A \<Longrightarrow> (uncurry (return \<circ>\<circ> op_list_replicate), uncurry (RETURN \<circ>\<circ> op_list_replicate)) \<in> nat_assn\<^sup>k *\<^sub>a A\<^sup>k \<rightarrow>\<^sub>a list_assn A" by solve
lemma HOL_list_get_hnr[sepref_fr_rules]: "CONSTRAINT is_pure A \<Longrightarrow> (uncurry (return \<circ>\<circ> op_list_get), uncurry (RETURN \<circ>\<circ> op_list_get)) \<in> [\<lambda>(a, b). b < length a]\<^sub>a (list_assn A)\<^sup>k *\<^sub>a nat_assn\<^sup>k \<rightarrow> A" by solve

(* TODO: Ad-hoc hack! *)
private lemma bool_by_paramE: "\<lbrakk> a; (a,b)\<in>Id \<rbrakk> \<Longrightarrow> b" by simp
private lemma bool_by_paramE': "\<lbrakk> a; (b,a)\<in>Id \<rbrakk> \<Longrightarrow> b" by simp

lemma HOL_list_contains_hnr[sepref_fr_rules]: "\<lbrakk>CONSTRAINT is_pure A; single_valued (the_pure A); single_valued ((the_pure A)\<inverse>)\<rbrakk>
  \<Longrightarrow> (uncurry (return \<circ>\<circ> op_list_contains), uncurry (RETURN \<circ>\<circ> op_list_contains)) \<in> A\<^sup>k *\<^sub>a (list_assn A)\<^sup>k \<rightarrow>\<^sub>a bool_assn"
  apply solve_dbg
  apply (erule bool_by_paramE[where a="_\<in>set _"]) apply parametricity
  apply (erule bool_by_paramE'[where a="_\<in>set _"]) apply parametricity
  done

lemmas HOL_list_empty_hnr_mop = HOL_list_empty_hnr_aux[FCOMP mk_mop_rl0_np[OF mop_list_empty_alt]]
lemmas HOL_list_is_empty_hnr_mop[sepref_fr_rules] = HOL_list_is_empty_hnr[FCOMP mk_mop_rl1_np[OF mop_list_is_empty_alt]]
lemmas HOL_list_prepend_hnr_mop[sepref_fr_rules] = HOL_list_prepend_hnr[FCOMP mk_mop_rl2_np[OF mop_list_prepend_alt]]
lemmas HOL_list_append_hnr_mop[sepref_fr_rules] = HOL_list_append_hnr[FCOMP mk_mop_rl2_np[OF mop_list_append_alt]]
lemmas HOL_list_concat_hnr_mop[sepref_fr_rules] = HOL_list_concat_hnr[FCOMP mk_mop_rl2_np[OF mop_list_concat_alt]]
lemmas HOL_list_length_hnr_mop[sepref_fr_rules] = HOL_list_length_hnr[FCOMP mk_mop_rl1_np[OF mop_list_length_alt]]
lemmas HOL_list_set_hnr_mop[sepref_fr_rules] = HOL_list_set_hnr[FCOMP mk_mop_rl3[OF mop_list_set_alt]]
lemmas HOL_list_hd_hnr_mop[sepref_fr_rules] = HOL_list_hd_hnr[FCOMP mk_mop_rl1[OF mop_list_hd_alt]]
lemmas HOL_list_tl_hnr_mop[sepref_fr_rules] = HOL_list_tl_hnr[FCOMP mk_mop_rl1[OF mop_list_tl_alt]]
lemmas HOL_list_last_hnr_mop[sepref_fr_rules] = HOL_list_last_hnr[FCOMP mk_mop_rl1[OF mop_list_last_alt]]
lemmas HOL_list_butlast_hnr_mop[sepref_fr_rules] = HOL_list_butlast_hnr[FCOMP mk_mop_rl1[OF mop_list_butlast_alt]]
lemmas HOL_list_swap_hnr_mop[sepref_fr_rules] = HOL_list_swap_hnr[FCOMP mk_mop_rl3[OF mop_list_swap_alt]]
lemmas HOL_list_rotate1_hnr_mop[sepref_fr_rules] = HOL_list_rotate1_hnr[FCOMP mk_mop_rl1_np[OF mop_list_rotate1_alt]]
lemmas HOL_list_rev_hnr_mop[sepref_fr_rules] = HOL_list_rev_hnr[FCOMP mk_mop_rl1_np[OF mop_list_rev_alt]]
lemmas HOL_list_replicate_hnr_mop[sepref_fr_rules] = HOL_list_replicate_hnr[FCOMP mk_mop_rl2_np[OF mop_list_replicate_alt]]
lemmas HOL_list_get_hnr_mop[sepref_fr_rules] = HOL_list_get_hnr[FCOMP mk_mop_rl2[OF mop_list_get_alt]]
lemmas HOL_list_contains_hnr_mop[sepref_fr_rules] = HOL_list_contains_hnr[FCOMP mk_mop_rl2_np[OF mop_list_contains_alt]]

lemmas HOL_list_empty_hnr = HOL_list_empty_hnr_aux HOL_list_empty_hnr_mop

end

definition [simp]: "op_HOL_list_empty \<equiv> op_list_empty"
interpretation HOL_list: list_custom_empty "list_assn A" "return []" op_HOL_list_empty
  apply unfold_locales
  apply (sep_auto intro!: hfrefI hn_refineI)
  by simp

schematic_goal
  notes [sepref_fr_rules] = HOL_list_empty_hnr
  shows
  "hn_refine (emp) (?c::?'c Heap) ?\<Gamma>' ?R (do {
    x \<leftarrow> RETURN [1,2,3::nat];
    let x2 = op_list_append x 5;
    ASSERT (length x = 4);
    let x = op_list_swap x 1 2;
    x \<leftarrow> mop_list_swap x 1 2;
    RETURN (x@x)
  })"
    by sepref

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

theory Sep_Tactic_Examples
imports
  "SepDSpec.Sep_Tactic_Helper"
  KHeap_DP
begin

(* Thesis : Automated Tactics for Seperation Logic *)

(* seperation logic *)

(* after we show that addition and disjointedness on our heap obeys certain laws, we get a seperation algebra *)

(* connectives *)

term "P \<and>* Q"

term "P \<longrightarrow>* Q"

lemma frame_rule:
  "\<And>R. \<lbrace>P\<rbrace> f \<lbrace>\<lambda>_. Q\<rbrace> \<Longrightarrow> \<lbrace>P \<and>* R\<rbrace> f \<lbrace>\<lambda>_. Q \<and>* R\<rbrace>"
  oops

lemma
 "\<lbrace><dest \<mapsto>c - \<and>* src \<mapsto>c cap \<and>* R>\<rbrace>
    move_cap cap' src dest
  \<lbrace>\<lambda>_. <dest \<mapsto>c cap'  \<and>* src \<mapsto>c NullCap \<and>* R>\<rbrace>"
  apply (simp add: move_cap_def)
  apply (wp swap_parents_wp set_cap_wp) (* set_cap doesn't apply *)
thm set_cap_wp[no_vars]
   apply (rule hoare_strengthen_post)
    apply (wp set_cap_wp)
   apply (clarsimp simp: sep_conj_ac )
oops

(* tactics we had pre-thesis *)

lemma "(A \<and>* B \<and>* C \<and>* D) s  \<Longrightarrow>  (A \<and>* B \<and>* C \<and>* D) s"
  apply (sep_select 4)
  apply (sep_select_asm 3)
  apply (sep_select 2)
  apply (sep_cancel)
  apply (sep_cancel)
  apply (sep_cancel)
done

(* forward reasoning *)

lemma example_drule:
  "(ptr \<mapsto>o obj) s
  \<Longrightarrow> (ptr \<mapsto>S obj \<and>* ptr \<mapsto>f obj) s"
  by (metis sep_conj_commute sep_map_o_decomp)

lemma sep_drule_example:
  "(ptr \<mapsto>o obj \<and>* A \<and>* B ) s
  \<Longrightarrow> (A \<and>* B \<and>* ptr \<mapsto>f obj \<and>* ptr \<mapsto>S obj) s"
  apply (sep_drule  example_drule)
  apply (sep_solve)
done

(* backwards reasoning *)

lemma example_rule:
  "(ptr \<mapsto>f obj \<and>* ptr \<mapsto>S obj) s
  \<Longrightarrow> (ptr \<mapsto>o obj) s"
  by (metis sep_map_o_decomp)

lemma sep_rule_example: "(ptr \<mapsto>f obj \<and>* A \<and>* B \<and>* ptr \<mapsto>S obj ) s \<Longrightarrow> (ptr \<mapsto>o obj \<and>* A \<and>* B) s"
  apply (sep_rule example_rule)
  apply (sep_solve)
done

(* the state of proving before new stuff *)

lemma swap_cap_wp_old:
  "\<lbrace><dest \<mapsto>c cap \<and>*  src \<mapsto>c cap' \<and>* R>\<rbrace>
    swap_cap cap' src cap dest
   \<lbrace>\<lambda>_.<dest \<mapsto>c cap' \<and>* src \<mapsto>c cap \<and>* R>\<rbrace>"
  apply (clarsimp simp add: swap_cap_def)
  apply (wp swap_parents_wp set_cap_wp)
  apply (rule hoare_chain)
    apply (rule set_cap_wp)
    apply (sep_solve)+
done

lemma move_cap_wp_old:
 "\<lbrace><dest \<mapsto>c - \<and>* src \<mapsto>c cap \<and>* R>\<rbrace>
    move_cap cap' src dest
  \<lbrace>\<lambda>_. <dest \<mapsto>c cap'  \<and>* src \<mapsto>c NullCap \<and>* R>\<rbrace>"
  including no_pre
  apply (simp add: move_cap_def)
  apply (wp swap_parents_wp)
   apply (rule hoare_strengthen_post)
    apply (rule set_cap_wp)
   apply (sep_select 2)
   apply (sep_solve)
  apply (rule hoare_chain)
    apply (rule insert_cap_orphan_wp)
   apply (sep_solve)
  apply (sep_solve)
done

lemma invoke_cnode_rotate2_wp_old:
  "(dest) \<noteq> (rnd) \<Longrightarrow>
  \<lbrace><dest \<mapsto>c cap1 \<and>* src \<mapsto>c cap2 \<and>*
    rnd \<mapsto>c - \<and>* R>\<rbrace>
     invoke_cnode (RotateCall cap1 cap2 dest src rnd)
  \<lbrace>\<lambda>_. <dest \<mapsto>c NullCap \<and>* src \<mapsto>c cap1 \<and>*
    rnd \<mapsto>c cap2 \<and>* R>\<rbrace>"
  including no_pre
  apply (clarsimp simp: invoke_cnode_def)
  apply (wp)
   apply (rule hoare_strengthen_post)
    apply (rule move_cap_wp)
   apply (sep_solve )
  apply (rule hoare_chain)
    apply (rule move_cap_wp)
   apply (sep_select_asm 2, sep_select_asm 3)
   apply (sep_solve)
  apply (sep_solve)
done

(* new sep_select/asm *)

lemma "(A \<and>* B \<and>* C \<and>* D) s  \<Longrightarrow>  (A \<and>* B \<and>* C \<and>* D) s"
  apply (sep_select 4 3 2 1)
  apply (sep_select_asm 4 3 2 1)
  apply (sep_select_asm 2 4)
oops

(* sep_select_pre/post *)

lemma "\<lbrace>A \<and>* B \<and>* C \<and>* D\<rbrace> f \<lbrace>\<lambda>_. A \<and>* B \<and>* C \<and>* D\<rbrace>"
  apply (sep_select_pre 4 1 2 3)
  apply (sep_select_post 3 4 2 1)
  apply (sep_select_post 3 4)
oops

(* can be made to work for arbitrary monads *)

lemma "\<lbrace>A \<and>* B \<and>* C \<and>* D\<rbrace> f \<lbrace>\<lambda>_. A \<and>* B \<and>* C \<and>* D\<rbrace>, \<lbrace>E\<rbrace>"
  apply (sep_select_pre 4 1 2 3)
  apply (sep_select_post 3 4 2 1)
  apply (sep_select_post 3 4)
oops

lemma "\<lbrace>A \<and>* B \<and>* C \<and>* D\<rbrace> f \<lbrace>\<lambda>_. A \<and>* B \<and>* C \<and>* D\<rbrace>, -"
  apply (sep_select_pre 4 1 2 3)
  apply (sep_select_post 3 4 2 1)
  apply (sep_select_post 3 4)
oops

lemma "(P \<and>* (P \<longrightarrow>* Q)) s \<Longrightarrow> Q s"
  apply (sep_mp, assumption )
  done

lemma "P s \<Longrightarrow> (Q \<longrightarrow>* (P \<and>* Q)) s"
  apply (erule sep_curry[rotated])
  apply (assumption)
  done

(* wp tactic testing *)

(* sep_wand approach *)

method_setup debug = \<open>
  Attrib.thms >> (fn _ => fn ctxt =>
   let
     val wp_pre_tac = SELECT_GOAL (NO_CONTEXT_TACTIC ctxt
                      (Method_Closure.apply_method ctxt @{method wp_pre} [] [] [] ctxt []))
   in
     SIMPLE_METHOD' (CHANGED o wp_pre_tac)
   end
)
\<close>

lemma move_cap_wp2:
 "\<lbrace><dest \<mapsto>c - \<and>* src \<mapsto>c cap \<and>* R>\<rbrace>
    move_cap cap' src dest
  \<lbrace>\<lambda>_. <dest \<mapsto>c cap'  \<and>* src \<mapsto>c NullCap \<and>* R>\<rbrace>"
  apply (simp add: move_cap_def)
  apply (sep_wp set_cap_wp swap_parents_wp insert_cap_orphan_wp)+
  apply (sep_solve)
  done

lemma swap_cap_wp2:
  "\<lbrace><dest \<mapsto>c cap \<and>*  src \<mapsto>c cap' \<and>* R>\<rbrace>
    swap_cap cap' src cap dest
   \<lbrace>\<lambda>_.<dest \<mapsto>c cap' \<and>* src \<mapsto>c cap \<and>* R>\<rbrace>"
  apply (clarsimp simp: swap_cap_def)
  apply (sep_wp swap_parents_wp set_cap_wp)+
  apply (sep_solve)
  done

lemma invoke_cnode_rotate2_wp:
  "(dest) \<noteq> (rnd) \<Longrightarrow>
  \<lbrace><dest \<mapsto>c cap1 \<and>* src \<mapsto>c cap2 \<and>*
    rnd \<mapsto>c - \<and>* R>\<rbrace>
     invoke_cnode (RotateCall cap1 cap2 dest src rnd)
  \<lbrace>\<lambda>_. <dest \<mapsto>c NullCap \<and>* src \<mapsto>c cap1 \<and>*
    rnd \<mapsto>c cap2 \<and>* R>\<rbrace>"
  apply (clarsimp simp: invoke_cnode_def)
  apply (sep_wp move_cap_wp)+
  apply (sep_solve)
  done

(* sep_drule/rule *)

lemma sep_rule_example2:
 "\<lbrakk>(ptr \<mapsto>o obj) s; finite (dom (object_slots obj))\<rbrakk> \<Longrightarrow>
   (ptr \<mapsto>E obj \<and>* ptr \<mapsto>f obj \<and>* (\<And>* slot\<in>dom (object_slots obj). (ptr, slot) \<mapsto>s obj)) s"
  apply (subst (asm) sep_map_o_decomp)
  apply (subst (asm) sep_map_S_decomp, simp+)
  apply sep_solve
  done

lemma sep_drule_example2:
 "\<lbrakk>(ptr \<mapsto>f obj \<and>* (\<And>* slot\<in>dom (object_slots obj). (ptr, slot) \<mapsto>s obj) \<and>* ptr \<mapsto>E obj) s;
   finite (dom (object_slots obj))\<rbrakk>
    \<Longrightarrow>
  (ptr \<mapsto>o obj) s"
  by (metis sep_map_S_decomp sep_map_o_decomp)

(* sep_curry *)

lemma sep_drule_example_lemma:
  "\<lbrakk>(H \<and>* Z \<and>* J \<and>* L \<and>* Y \<and>* ptr \<mapsto>f obj \<and>* A \<and>* B \<and>*
    (\<And>* slot\<in>dom (object_slots obj). (ptr, slot) \<mapsto>s obj) \<and>* D \<and>* G \<and>* E \<and>* F \<and>* ptr \<mapsto>E obj ) s;
    finite (dom (object_slots obj))\<rbrakk>
  \<Longrightarrow>
   (D \<and>* G \<and>* E \<and>* F  \<and>* ptr \<mapsto>o obj \<and>* H \<and>* Z \<and>* J \<and>* L \<and>* Y \<and>* A \<and>* B) s"
  apply (sep_drule sep_drule_example2)
   apply assumption
  apply sep_solve
  done

(* sep_back *)

lemma sep_rule_example_lemma:
 "\<lbrakk>(H \<and>* Z \<and>* J \<and>* L \<and>* Y \<and>* ptr \<mapsto>o obj \<and>* A \<and>* B \<and>* D \<and>* G \<and>* E \<and>* F ) s;
  finite (dom (object_slots obj))\<rbrakk> \<Longrightarrow>
  (D \<and>* G \<and>* E \<and>* F  \<and>* ptr \<mapsto>f obj \<and>* H \<and>* Z \<and>* J \<and>* L \<and>* Y \<and>* ptr \<mapsto>E obj \<and>*
   A \<and>* B \<and>* (\<And>* slot\<in>dom (object_slots obj). (ptr, slot) \<mapsto>s obj)) s"
  apply (sep_rule sep_rule_example2)
   apply sep_solve
  apply assumption
  done

(* works even with multiple conjuncts in assumptions and conclusions *)
lemma sep_rule_double_conjunct_example:
  "\<lbrakk>((obj_id, slot) \<mapsto>c cap \<and>* obj_id \<mapsto>f obj) s;
    object_slots obj slot = Some cap\<rbrakk>
  \<Longrightarrow> ((obj_id, slot) \<mapsto>s obj \<and>* obj_id \<mapsto>f obj) s"
  apply (sep_drule sep_map_s_sep_map_c)
   apply assumption
  apply (sep_cancel)+
  done

lemma sep_rule_double_conjunct_lemma:
  "\<lbrakk>(H \<and>* Z \<and>* J \<and>* L \<and>* Y \<and>* obj_id \<mapsto>f obj \<and>* A \<and>* B \<and>* D \<and>* G \<and>* E \<and>* F \<and>* (obj_id, slot) \<mapsto>c cap ) s;
    object_slots obj slot = Some cap\<rbrakk> \<Longrightarrow>
   (D \<and>* G \<and>* E \<and>* F  \<and>*(obj_id, slot) \<mapsto>s obj \<and>* H \<and>* Z \<and>* J \<and>* L \<and>* Y \<and>* A \<and>* B \<and>*  obj_id \<mapsto>f obj) s"
  apply (sep_rule sep_rule_double_conjunct_example)
   apply sep_solve
  apply assumption
  done

(* side-conditions*)

lemma sep_drule_side_condition_lemma:
 "\<lbrakk>(H \<and>* Z \<and>* J \<and>* L \<and>* Y \<and>* obj_id \<mapsto>f obj \<and>* A \<and>* B \<and>* D \<and>* G \<and>* E \<and>* F \<and>* (obj_id, slot) \<mapsto>c cap ) s;
    object_slots obj slot = Some cap\<rbrakk> \<Longrightarrow>
   (D \<and>* G \<and>* E \<and>* F  \<and>*(obj_id, slot) \<mapsto>s obj \<and>* H \<and>* Z \<and>* J \<and>* L \<and>* Y \<and>* A \<and>* B \<and>*  obj_id \<mapsto>f obj) s"
  apply (sep_drule sep_rule_double_conjunct_example, assumption)
  apply (sep_solve)
  done

schematic_goal "(P \<and>* ?A) s \<Longrightarrow> (A \<and>* B \<and>* P) s"
  apply (sep_solve)
  done

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory Sep_ImpI
imports Sep_Provers Sep_Cancel_Set Sep_Tactic_Helpers
begin

lemma sep_wand_lens: "(\<And>s. T s = Q s) \<Longrightarrow> ((P \<longrightarrow>* T) \<and>* R) s \<Longrightarrow> ((P \<longrightarrow>* Q) \<and>* R) s"
  apply (sep_erule_full refl_imp)
  apply (clarsimp simp: sep_impl_def)
  done

lemma sep_wand_lens': "(\<And>s. T s = Q s) \<Longrightarrow> ((T \<longrightarrow>* P) \<and>* R) s \<Longrightarrow> ((Q \<longrightarrow>* P) \<and>* R) s"
  apply (sep_erule_full refl_imp, erule sep_curry[rotated])
  apply (clarsimp)
  apply (erule sep_mp)
  done

(* Removing wands from the conclusions *)

ML {*

fun sep_wand_lens ctxt = resolve_tac ctxt[@{thm sep_wand_lens}]
fun sep_wand_lens' ctxt = resolve_tac ctxt [@{thm sep_wand_lens'}]

fun sep_wand_rule_tac tac ctxt =
  let
    val r = rotator' ctxt
  in
    tac |> r (sep_wand_lens' ctxt) |> r (sep_wand_lens ctxt) |> r (sep_select ctxt)
  end

fun sep_wand_rule_tac' thms ctxt =
  let
    val r = rotator' ctxt
  in
    eresolve_tac ctxt thms |> r (sep_wand_lens ctxt) |> r (sep_select ctxt) |> r (sep_asm_select ctxt)
  end

fun sep_wand_rule_method thms ctxt = SIMPLE_METHOD' (sep_wand_rule_tac thms ctxt)
fun sep_wand_rule_method' thms ctxt = SIMPLE_METHOD' (sep_wand_rule_tac' thms ctxt)

*}

lemma sep_wand_match:
  "(\<And>s. Q s \<Longrightarrow> Q' s)  \<Longrightarrow> (R \<longrightarrow>* R') s    ==>  (Q \<and>* R \<longrightarrow>* Q' \<and>* R') s"
  apply (erule sep_curry[rotated])
  apply (sep_select_asm 1 3)
  apply (sep_drule (direct) sep_mp_frame)
  apply (sep_erule_full refl_imp, clarsimp)
  done

lemma sep_wand_trivial:    "(\<And>s. Q s \<Longrightarrow> Q' s) \<Longrightarrow> R' s            ==>   (Q \<longrightarrow>* Q' \<and>* R') s"
  apply (erule sep_curry[rotated])
  apply (sep_erule_full refl_imp)
  apply (clarsimp)
  done

lemma sep_wand_collapse:  "(P \<and>* Q \<longrightarrow>* R) s \<Longrightarrow> (P \<longrightarrow>* Q \<longrightarrow>* R) s "
  apply (erule sep_curry[rotated])+
  apply (clarsimp simp: sep_conj_assoc)
  apply (erule sep_mp)
 done

lemma sep_wand_match_less_safe:
  assumes drule: " \<And>s. (Q' \<and>* R) s \<Longrightarrow> ((P \<longrightarrow>* R') \<and>* Q' \<and>* R'' ) s "
  shows "(Q' \<and>* R) s \<Longrightarrow> (\<And>s. Q' s \<Longrightarrow> Q s) \<Longrightarrow> ((P \<longrightarrow>* Q \<and>* R') \<and>* R'') s"
  apply (drule drule)
  apply (sep_erule_full refl_imp)
  apply (erule sep_conj_sep_impl)
  apply (clarsimp simp: sep_conj_assoc)
  apply (sep_select_asm 1 3)
  apply (sep_drule (direct) sep_mp_frame, sep_erule_full refl_imp)
  apply (clarsimp)
 done

ML {*
fun sep_match_trivial_tac ctxt =
  let
    fun flip f a b = f b a
    val sep_cancel = flip (sep_apply_tactic ctxt) (SepCancel_Rules.get ctxt |> rev)
    fun f x = x |> rotate_prems ~1 |> (fn x => [x]) |> eresolve0_tac |> sep_cancel
    val sep_thms = map f [@{thm sep_wand_trivial}, @{thm sep_wand_match}]
  in
    sep_wand_rule_tac (resolve0_tac [@{thm sep_rule}] THEN' FIRST' sep_thms) ctxt
  end

fun sep_safe_method ctxt = SIMPLE_METHOD' (sep_match_trivial_tac ctxt)
*}

method_setup sep_safe = {*
  Scan.succeed (sep_safe_method)
*}

end