theory Refine_Foreach
imports NREST RefineMonadicVCG SepLogic_Misc
begin

text \<open>
  A common pattern for loop usage is iteration over the elements of a set.
  This theory provides the @{text "FOREACH"}-combinator, that iterates over
  each element of a set.
\<close>

subsection \<open>Auxilliary Lemmas\<close>
text \<open>The following lemma is commonly used when reasoning about iterator
  invariants.
  It helps converting the set of elements that remain to be iterated over to
  the set of elements already iterated over.\<close>
lemma it_step_insert_iff:
  "it \<subseteq> S \<Longrightarrow> x\<in>it \<Longrightarrow> S-(it-{x}) = insert x (S-it)" by auto

subsection \<open>Definition\<close>

text \<open>
  Foreach-loops come in different versions, depending on whether they have an
  annotated invariant (I), a termination condition (C), and an order (O).

  Note that asserting that the set is finite is not necessary to guarantee
  termination. However, we currently provide only iteration over finite sets,
  as this also matches the ICF concept of iterators.
\<close>

definition "FOREACH_body f \<equiv> \<lambda>(xs, \<sigma>). do {
  x \<leftarrow> RETURNT( hd xs); \<sigma>'\<leftarrow>f x \<sigma>; RETURNT (tl xs,\<sigma>')
  }"

definition FOREACH_cond where "FOREACH_cond c \<equiv> (\<lambda>(xs,\<sigma>). xs\<noteq>[] \<and> c \<sigma>)"

text \<open>Foreach with continuation condition, order and annotated invariant:\<close>

definition FOREACHoci ("FOREACH\<^sub>O\<^sub>C\<^bsup>_,_\<^esup>") where "FOREACHoci R \<Phi> S c f \<sigma>0 inittime body_time \<equiv> do {
  ASSERT (finite S);
  xs \<leftarrow> SPECT (emb (\<lambda>xs. distinct xs \<and> S = set xs \<and> sorted_wrt R xs) inittime);
  (_,\<sigma>) \<leftarrow> whileIET
    (\<lambda>(it,\<sigma>). \<exists>xs'. xs = xs' @ it \<and> \<Phi> (set it) \<sigma>) (\<lambda>(it,_). length it * body_time)  (FOREACH_cond c) (FOREACH_body f) (xs,\<sigma>0);
  RETURNT \<sigma> }"

text \<open>Foreach with continuation condition and annotated invariant:\<close>
definition FOREACHci ("FOREACH\<^sub>C\<^bsup>_\<^esup>") where "FOREACHci \<equiv> FOREACHoci (\<lambda>_ _. True)"

subsection \<open>Proof Rules\<close>
thm vcg_rules
lemma FOREACHoci_rule:
  assumes IP:
    "\<And>x it \<sigma>. \<lbrakk> c \<sigma>; x\<in>it; it\<subseteq>S; I it \<sigma>; \<forall>y\<in>it - {x}. R x y;
                \<forall>y\<in>S - it. R y x \<rbrakk> \<Longrightarrow> f x \<sigma> \<le> SPECT (emb (I (it-{x})) (enat body_time))"
  assumes FIN: "finite S"
  assumes I0: "I S \<sigma>0"
  assumes II1: "\<And>\<sigma>. \<lbrakk>I {} \<sigma>\<rbrakk> \<Longrightarrow> P \<sigma>"
  assumes II2: "\<And>it \<sigma>. \<lbrakk> it\<noteq>{}; it\<subseteq>S; I it \<sigma>; \<not>c \<sigma>;
                         \<forall>x\<in>it. \<forall>y\<in>S - it. R y x \<rbrakk> \<Longrightarrow> P \<sigma>"
  assumes time_ub: "inittime + enat ((card S) * body_time) \<le> enat overall_time"
  assumes progress_f[progress_rules]: "\<And>a b. progress (f a b)"
  shows "FOREACHoci R I S c f \<sigma>0 inittime body_time \<le> SPECT (emb P (enat overall_time))"
  unfolding FOREACHoci_def
  apply(rule T_specifies_I)
  unfolding FOREACH_body_def FOREACH_cond_def
  apply(vcg'\<open>-\<close> rules:  IP[THEN T_specifies_rev,THEN T_conseq4]  )

  prefer 5 apply auto []
  subgoal using I0 by blast
  subgoal by blast
  subgoal by simp
  subgoal by auto
  subgoal by (metis distinct_append hd_Cons_tl remove1_tl set_remove1_eq sorted_wrt.simps(2) sorted_wrt_append)
  subgoal by (metis DiffD1 DiffD2 UnE list.set_sel(1) set_append sorted_wrt_append)
  subgoal apply (auto simp: Some_le_mm3_Some_conv Some_le_emb'_conv Some_eq_emb'_conv)
      subgoal by (metis append.assoc append.simps(2) append_Nil hd_Cons_tl)
      subgoal by (metis remove1_tl set_remove1_eq)
      subgoal by (simp add: diff_mult_distrib)
      done
  subgoal using time_ub II1 apply (auto simp: Some_le_mm3_Some_conv Some_le_emb'_conv Some_eq_emb'_conv
               )
    subgoal by (simp add: distinct_card)
    subgoal by (metis DiffD1 DiffD2 II2 Un_iff Un_upper2 sorted_wrt_append)
    subgoal by (metis DiffD1 DiffD2 II2 Un_iff sorted_wrt_append sup_ge2)
    subgoal by (metis add_mono diff_le_self distinct_append distinct_card dual_order.trans enat_ord_simps(1) length_append order_mono_setup.refl set_append)
    done
  subgoal by (fact FIN)
  done

lemma FOREACHci_rule :
  assumes IP:
    "\<And>x it \<sigma>. \<lbrakk> x\<in>it; it\<subseteq>S; I it \<sigma>; c \<sigma> \<rbrakk> \<Longrightarrow> f x \<sigma> \<le> SPECT (emb (I (it-{x})) (enat body_time))"
  assumes II1: "\<And>\<sigma>. \<lbrakk>I {} \<sigma>\<rbrakk> \<Longrightarrow> P \<sigma>"
  assumes II2: "\<And>it \<sigma>. \<lbrakk> it\<noteq>{}; it\<subseteq>S; I it \<sigma>; \<not>c \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
  assumes FIN: "finite S"
  assumes I0: "I S \<sigma>0"
  assumes progress_f: "\<And>a b. progress (f a b)"
  assumes "inittime + enat (card S * body_time) \<le> enat overall_time"
  shows "FOREACHci I S c f \<sigma>0 inittime body_time  \<le> SPECT (emb P (enat overall_time))"
  unfolding FOREACHci_def
  by (rule FOREACHoci_rule) (simp_all add: assms)

(* ... *)

text \<open>We define a relation between distinct lists and sets.\<close>
definition [to_relAPP]: "list_set_rel R \<equiv> \<langle>R\<rangle>list_rel O br set distinct"

(*lemma list_set_rel_finite: "(succl, succ) \<in> \<langle>Id\<rangle>list_set_rel \<Longrightarrow> finite succ"
  sorry *)

(* ... *)

subsection \<open>Nres-Fold with Interruption (nfoldli)\<close>
text \<open>
  A foreach-loop can be conveniently expressed as an operation that converts
  the set to a list, followed by folding over the list.

  This representation is handy for automatic refinement, as the complex
  foreach-operation is expressed by two relatively simple operations.
\<close>

text \<open>We first define a fold-function in the nrest-monad\<close>
definition nfoldli where
  "nfoldli l c f s = RECT (\<lambda>D (l,s). (case l of
    [] \<Rightarrow> RETURNT s
    | x#ls \<Rightarrow> if c s then do { s\<leftarrow>f x s; D (ls, s)} else RETURNT s
  )) (l, s)"

lemma nfoldli_simps[simp]:
  "nfoldli [] c f s = RETURNT s"
  "nfoldli (x#ls) c f s =
    (if c s then do { s\<leftarrow>f x s; nfoldli ls c f s} else RETURNT s)"
  unfolding nfoldli_def by (subst RECT_unfold, refine_mono, auto split: nat.split)+

lemma param_nfoldli[param]:
  shows "(nfoldli,nfoldli) \<in>
    \<langle>Ra\<rangle>list_rel \<rightarrow> (Rb\<rightarrow>Id) \<rightarrow> (Ra\<rightarrow>Rb\<rightarrow>\<langle>Rb\<rangle>nrest_rel) \<rightarrow> Rb \<rightarrow> \<langle>Rb\<rangle>nrest_rel"
  apply (intro fun_relI)
proof goal_cases
  case (1 l l' c c' f f' s s')
  thus ?case
    apply (induct arbitrary: s s')
    apply (simp only: nfoldli_simps True_implies_equals)
    apply parametricity
    apply (simp only: nfoldli_simps True_implies_equals)
    apply (parametricity)
    done
qed

lemma nfoldli_no_ctd[simp]: "\<not>ctd s \<Longrightarrow> nfoldli l ctd f s = RETURNT s"
  by (cases l) auto

lemma nfoldli_append: "nfoldli (l1@l2) ctd f s = nfoldli l1 ctd f s \<bind> nfoldli l2 ctd f"
  by (induction l1 arbitrary: s) simp_all

lemma nfoldli_assert:
  assumes "set l \<subseteq> S"
  shows "nfoldli l c (\<lambda> x s. ASSERT (x \<in> S) \<then> f x s) s = nfoldli l c f s"
  using assms by (induction l arbitrary: s) (auto simp: pw_eq_iff refine_pw_simps)

lemmas nfoldli_assert' = nfoldli_assert[OF order.refl]

definition nfoldliIE :: "('d list \<Rightarrow> 'd list \<Rightarrow> 'a \<Rightarrow>  bool) \<Rightarrow> nat \<Rightarrow> 'd list \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('d \<Rightarrow> 'a \<Rightarrow> 'a nrest) \<Rightarrow> 'a \<Rightarrow> 'a nrest" where
  "nfoldliIE I E l c f s = nfoldli l c f s"

lemma nfoldliIE_rule':
  assumes IS: "\<And>x l1 l2 \<sigma>. \<lbrakk> l0=l1@x#l2; I l1 (x#l2) \<sigma>; c \<sigma> \<rbrakk> \<Longrightarrow> f x \<sigma> \<le> SPECT (emb (I (l1@[x]) l2) (enat body_time))"
  assumes FNC: "\<And>l1 l2 \<sigma>. \<lbrakk> l0=l1@l2; I l1 l2 \<sigma>; \<not>c \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
  assumes FC: "\<And>\<sigma>. \<lbrakk> I l0 [] \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
  shows "lr@l = l0 \<Longrightarrow> I lr l \<sigma> \<Longrightarrow> nfoldliIE I body_time l c f \<sigma> \<le> SPECT (emb P (body_time * length l))"
proof (induct l arbitrary: lr \<sigma>)
  case Nil
  then show ?case by (auto simp: nfoldliIE_def RETURNT_def le_fun_def  Some_le_emb'_conv dest!: FC)
next
  case (Cons a l)
  show ?case
    apply (auto simp add: nfoldliIE_def)
    subgoal
      apply(rule T_specifies_I)
      apply (vcg'\<open>-\<close> rules: IS[THEN T_specifies_rev  , THEN T_conseq4]
                            Cons(1)[unfolded nfoldliIE_def, THEN T_specifies_rev  , THEN T_conseq4])
      unfolding Some_eq_emb'_conv Some_le_emb'_conv
      using Cons(2,3) by auto
    subgoal
      apply(simp add: RETURNT_def le_fun_def Some_le_emb'_conv)
      apply(rule FNC) using Cons(2,3) by auto
    done
qed

lemma nfoldliIE_rule:
  assumes I0: "I [] l0 \<sigma>0"
  assumes IS: "\<And>x l1 l2 \<sigma>. \<lbrakk> l0=l1@x#l2; I l1 (x#l2) \<sigma>; c \<sigma> \<rbrakk> \<Longrightarrow> f x \<sigma> \<le> SPECT (emb (I (l1@[x]) l2) (enat body_time))"
  assumes FNC: "\<And>l1 l2 \<sigma>. \<lbrakk> l0=l1@l2; I l1 l2 \<sigma>; \<not>c \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
  assumes FC: "\<And>\<sigma>. \<lbrakk> I l0 [] \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
  assumes T: "(body_time * length l0) \<le> t"
  shows "nfoldliIE I body_time l0 c f \<sigma>0 \<le> SPECT (emb P t)"
proof -
  have "nfoldliIE I body_time l0 c f \<sigma>0 \<le> SPECT (emb P (body_time * length l0))"
     apply(rule nfoldliIE_rule'[where lr="[]"]) using assms by auto
  also have "\<dots> \<le> SPECT (emb P t)"
    apply(rule SPECT_ub) using T by (auto simp: le_fun_def)
  finally show ?thesis .
qed

lemma nfoldli_refine[refine]:
  assumes "(li, l) \<in> \<langle>S\<rangle>list_rel"
    and "(si, s) \<in> R"
    and CR: "(ci, c) \<in> R \<rightarrow> bool_rel"
    and [refine]: "\<And>xi x si s. \<lbrakk> (xi,x)\<in>S; (si,s)\<in>R; c s \<rbrakk> \<Longrightarrow> fi xi si \<le> \<Down>R (f x s)"
  shows "nfoldli li ci fi si \<le> \<Down> R (nfoldli l c f s)"
  using assms(1,2)
proof (induction arbitrary: si s rule: list_rel_induct)
  case Nil thus ?case by (simp add: RETURNT_refine)
next
  case (Cons xi x li l)
  note [refine] = Cons

  show ?case
    apply (simp add: RETURNT_refine  split del: if_split)
    apply refine_rcg
    using CR Cons.prems by (auto simp: RETURNT_refine  dest: fun_relD)
qed

thm nfoldliIE_rule[THEN T_specifies_rev, THEN T_conseq4,no_vars]

definition "nfoldliIE' I bt l0 f s0 = nfoldliIE I bt l0 (\<lambda>_. True) f s0"

lemma nfoldliIE'_rule:
  assumes
"\<And>x l1 l2 \<sigma>.
    l0 = l1 @ x # l2 \<Longrightarrow>
    I l1 (x # l2) \<sigma> \<Longrightarrow> Some 0 \<le> lst (f x \<sigma>) (emb (I (l1 @ [x]) l2) (enat body_time))"
"I [] l0 \<sigma>0"
"(\<And>\<sigma>. I l0 [] \<sigma> \<Longrightarrow> Some (t + enat (body_time * length l0)) \<le> Q \<sigma>)"
shows "Some t \<le> lst (nfoldliIE' I body_time l0 f \<sigma>0) Q"
  unfolding nfoldliIE'_def
  apply(rule nfoldliIE_rule[where P="I l0 []" and c="\<lambda>_. True" and t="body_time * length l0", THEN T_specifies_rev, THEN T_conseq4])
       apply fact
  subgoal
    apply(rule T_specifies_I) using  assms(1) by auto
  subgoal by auto
    apply simp
   apply simp
  subgoal
    unfolding Some_eq_emb'_conv
    using assms(3) by auto
  done

text \<open>We relate our fold-function to the while-loop that we used in
  the original definition of the foreach-loop\<close>
lemma nfoldli_while: "nfoldli l c f \<sigma>
          \<le>
         (whileIET I E
           (FOREACH_cond c) (FOREACH_body f) (l, \<sigma>) \<bind>
          (\<lambda>(_, \<sigma>). RETURNT \<sigma>))"
proof (induct l arbitrary: \<sigma>)
  case Nil thus ?case
    unfolding whileIET_def
     apply (subst whileT_unfold) by (auto simp: FOREACH_cond_def)
next
  case (Cons x ls)
  show ?case
  proof (cases "c \<sigma>")
    case False thus ?thesis
    unfolding whileIET_def
     apply (subst whileT_unfold)
      unfolding FOREACH_cond_def
      by simp
  next
    case [simp]: True
    from Cons show ?thesis
    unfolding whileIET_def
     apply (subst whileT_unfold)
      unfolding FOREACH_cond_def FOREACH_body_def
      apply clarsimp
      apply (rule  bindT_mono)
      apply simp_all
      done
  qed
qed

lemma rr: "l0 = l1 @ a \<Longrightarrow> a \<noteq> [] \<Longrightarrow> l0 = l1 @ hd a # tl a" by auto

lemma nfoldli_rule:
  assumes I0: "I [] l0 \<sigma>0"
  assumes IS: "\<And>x l1 l2 \<sigma>. \<lbrakk> l0=l1@x#l2; I l1 (x#l2) \<sigma>; c \<sigma> \<rbrakk> \<Longrightarrow> f x \<sigma> \<le> SPECT (emb (I (l1@[x]) l2) (enat body_time))"
  assumes FNC: "\<And>l1 l2 \<sigma>. \<lbrakk> l0=l1@l2; I l1 l2 \<sigma>; \<not>c \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
  assumes FC: "\<And>\<sigma>. \<lbrakk> I l0 [] \<sigma>; c \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
  assumes progressf: "\<And>x y. progress (f x y)"
  shows "nfoldli l0 c f \<sigma>0 \<le> SPECT (emb P (body_time * length l0))"
  apply (rule order_trans[OF nfoldli_while[
          where I="\<lambda>(l2,\<sigma>). \<exists>l1. l0=l1@l2 \<and> I l1 l2 \<sigma>" and E="\<lambda>(l2,\<sigma>). (length l2) * body_time"]])
  unfolding FOREACH_cond_def FOREACH_body_def
  apply(rule T_specifies_I)
  apply(vcg'_step \<open>clarsimp\<close>)
  subgoal  using I0 by auto
  subgoal
    apply(vcg'_step \<open>clarsimp\<close>)
    apply (elim exE conjE)
    subgoal for a b l1
      apply(vcg'_step \<open>clarsimp\<close> rules: IS[THEN T_specifies_rev , THEN T_conseq4 ])
         apply(rule rr) apply simp_all
      apply(auto simp add: Some_le_mm3_Some_conv emb_eq_Some_conv left_diff_distrib')
      apply(rule exI[where x="l1@[hd a]"]) by simp
    done
  subgoal (* progress *)
    supply progressf [progress_rules] by (progress \<open>clarsimp\<close>)
  subgoal
    apply(vcg' \<open>clarsimp\<close>)
    subgoal for a \<sigma>
      apply(cases "c \<sigma>")
      using FC  FNC  by(auto simp add: Some_le_emb'_conv  mult.commute)
    done
  done

definition "LIST_FOREACH' tsl c f \<sigma> \<equiv> do {xs \<leftarrow> tsl; nfoldli xs c f \<sigma>}"

text \<open>This constant is a placeholder to be converted to
  custom operations by pattern rules\<close>
definition "it_to_sorted_list R s to_sorted_list_time
  \<equiv> SPECT (emb (\<lambda>l. distinct l \<and> s = set l \<and> sorted_wrt R l) to_sorted_list_time)"

definition "LIST_FOREACH \<Phi> tsl c f \<sigma>0 bodytime \<equiv> do {
  xs \<leftarrow> tsl;
  (_,\<sigma>) \<leftarrow> whileIET (\<lambda>(it, \<sigma>). \<exists>xs'. xs = xs' @ it \<and> \<Phi> (set it) \<sigma>) (\<lambda>(it, \<sigma>). length it * bodytime)
    (FOREACH_cond c) (FOREACH_body f) (xs, \<sigma>0);
    RETURNT \<sigma>}"

lemma FOREACHoci_by_LIST_FOREACH:
  "FOREACHoci R \<Phi> S c f \<sigma>0 to_sorted_list_time bodytime = do {
    ASSERT (finite S);
    LIST_FOREACH \<Phi> (it_to_sorted_list R S to_sorted_list_time) c f \<sigma>0 bodytime
  }"
  unfolding OP_def FOREACHoci_def LIST_FOREACH_def it_to_sorted_list_def
  by simp
(*

lemma LFO_pre_refine: (* TODO: Generalize! *)
  assumes "(li,l)\<in>\<langle>A\<rangle>list_set_rel"
  assumes "(ci,c)\<in>R \<rightarrow> bool_rel"
  assumes "(fi,f)\<in>A\<rightarrow>R\<rightarrow>\<langle>R\<rangle>nrest_rel"
  assumes "(s0i,s0)\<in>R"
  shows "LIST_FOREACH' (RETURNT li) ci fi s0i \<le> \<Down>R (FOREACHci I l c f s0 0 body_time)"
proof -
  from assms(1) have [simp]: "finite l" by (auto simp: list_set_rel_def br_def)
  show ?thesis
    unfolding   FOREACHci_def unfolding FOREACHoci_by_LIST_FOREACH
    apply simp
    apply (rule LIST_FOREACH_autoref[param_fo, THEN nres_relD])
    using assms
    apply auto
    apply (auto simp: it_to_sorted_list_def nres_rel_def pw_le_iff refine_pw_simps
      list_set_rel_def br_def)
    done
qed
    *)

(*
lemma LFOci_refine: (* TODO: Generalize! *)
  assumes "(li,l)\<in>\<langle>A\<rangle>list_set_rel"
  assumes "\<And>s si. (si,s)\<in>R \<Longrightarrow> ci si \<longleftrightarrow> c s"
  assumes "\<And>x xi s si. \<lbrakk>(xi,x)\<in>A; (si,s)\<in>R\<rbrakk> \<Longrightarrow> fi xi si \<le> \<Down>R (f x s)"
  assumes "(s0i,s0)\<in>R"
  shows "nfoldli li ci fi s0i \<le> \<Down>R (FOREACHci I l c f s0 init_time body_time)"
(*
proof -
  from assms LFO_pre_refine[of li l A ci c R fi f s0i s0] show ?thesis
    unfolding fun_rel_def nres_rel_def LIST_FOREACH'_def
    apply (simp add: pw_le_iff refine_pw_simps)
    apply blast+
    done
qed
*)sorry
*)

end


theory "Ids"
imports Complex_Main
begin
section \<open>Identifier locale\<close>
text \<open>The differential dynamic logic formalization is parameterized by the type of identifiers.
  The identifier type(s) must be finite and have at least 3-4 distinct elements.
  Distinctness is required for soundness of some axioms. \<close>
locale ids =
  fixes vid1 :: "('sz::{finite,linorder})"
  fixes vid2 :: 'sz
  fixes vid3 :: 'sz
  fixes fid1 :: "('sf::finite)"
  fixes fid2 :: 'sf
  fixes fid3 :: 'sf
  fixes pid1 :: "('sc::finite)"
  fixes pid2 :: 'sc
  fixes pid3 :: 'sc
  fixes pid4 :: 'sc
  assumes vne12:"vid1 \<noteq> vid2"
  assumes vne23:"vid2 \<noteq> vid3"
  assumes vne13:"vid1 \<noteq> vid3"
  assumes fne12:"fid1 \<noteq> fid2"
  assumes fne23:"fid2 \<noteq> fid3"
  assumes fne13:"fid1 \<noteq> fid3"
  assumes pne12:"pid1 \<noteq> pid2"
  assumes pne23:"pid2 \<noteq> pid3"
  assumes pne13:"pid1 \<noteq> pid3"
  assumes pne14:"pid1 \<noteq> pid4"
  assumes pne24:"pid2 \<noteq> pid4"
  assumes pne34:"pid3 \<noteq> pid4"
context ids begin
lemma id_simps:
  "(vid1 = vid2) = False" "(vid2 = vid3) = False" "(vid1 = vid3) = False"
  "(fid1 = fid2) = False" "(fid2 = fid3) = False" "(fid1 = fid3) = False"
  "(pid1 = pid2) = False" "(pid2 = pid3) = False" "(pid1 = pid3) = False"
  "(pid1 = pid4) = False" "(pid2 = pid4) = False" "(pid3 = pid4) = False"
  "(vid2 = vid1) = False" "(vid3 = vid2) = False" "(vid3 = vid1) = False"
  "(fid2 = fid1) = False" "(fid3 = fid2) = False" "(fid3 = fid1) = False"
  "(pid2 = pid1) = False" "(pid3 = pid2) = False" "(pid3 = pid1) = False"
  "(pid4 = pid1) = False" "(pid4 = pid2) = False" "(pid4 = pid3) = False"
  using vne12 vne23 vne13 fne12 fne23 fne13 pne12 pne23 pne13 pne14 pne24 pne34 by auto
end
end


theory Protocol
imports
  DistinctList
begin

section{* Protocol Specifications *}

subsection{* Types and Operations *}

subsubsection{* Specification Messages *}

text{*
  We specialize the cryptographic to specification messages by
  providing a type for the literals.
*}

types id = string

datatype varid = AVar id | MVar id

datatype speclit = SConst id
                 | SVar   varid
                 | SNonce id

datatype pattern =

types specmsg = "speclit msg"

text{* Free variables *}
fun FV :: "specmsg \<Rightarrow> varid set"
where
  "FV (Lit (SVar v)) = {v}"
| "FV (Lit _)        = {}"
| "FV (Tup x y)      = FV x \<union> FV y"
| "FV (Enc m k)      = FV m \<union> FV k"
| "FV (Hash m)       = FV m"
| "FV (K a b)        = FV a \<union> FV b"
| "FV (PK a)         = FV a"
| "FV (SK a)         = FV a"

subsubsection{* Roles *}

text{*
  Roles are non-empty lists of unique send and receive steps
  such that no long-term keys are used in message texts and all
  nonce variables are received before they are sent.

  The labels allow to make steps with identical message unique.
  They are currently defaulted to strings, but could be anything.
*}

types lbl = string

datatype rolestep = Send lbl specmsg | Recv lbl specmsg

fun stepMsg :: "rolestep \<Rightarrow> specmsg"
where
  "stepMsg (Send lbl msg) = msg"
| "stepMsg (Recv lbl msg) = msg"

fun sendStep :: "rolestep \<Rightarrow> bool"
where
  "sendStep (Send lbl msg) = True"
| "sendStep (Recv lbl msg) = False"

abbreviation recvStep where "recvStep x \<equiv> \<not>sendStep x"

types "role" = "rolestep list"

fun recv_before_send :: "varid set \<Rightarrow> role \<Rightarrow> bool"
where
  "recv_before_send bound []                = True"
| "recv_before_send bound (Recv _ msg # xs) =
     recv_before_send (bound \<union> FV msg) xs"
| "recv_before_send bound (Send _ msg # xs) =
     ((\<forall> v. MVar v \<in> FV msg \<longrightarrow> MVar v \<in> bound) \<and>
      recv_before_send bound xs)"

locale wf_role =
  distinct_list R for R :: "role" +
  assumes recv_before_send [iff]: "recv_before_send {} R"

subsubsection{* Protocols *}

types proto = "role set"

locale wf_proto =
  fixes P :: proto
  assumes wf_roles: "R \<in> P \<Longrightarrow> wf_role R"

subsection{* Properties *}

subsubsection{* Well-Formed Roles *}

lemma recv_before_sent_distinct_Send_FV:
  "\<lbrakk>  recv_before_send V (R@ Send lbl msg # R');
      distinct (R @ Send lbl msg # R');
      MVar v \<in> FV msg; MVar v \<notin> V
   \<rbrakk> \<Longrightarrow>
   \<exists> lbl' msg'. Recv lbl' msg' \<in> set R \<and> MVar v \<in> FV msg'"
proof(induct R arbitrary: V)
  case (Cons step R) note IH = this show ?case
    proof(cases step)
      case (Send lbl msg) thus ?thesis using IH by auto
    next
      case (Recv lbl msg) thus ?thesis using IH by (auto, fast)
    qed
qed simp

context wf_role
begin

lemma Send_FV:
  assumes Send: "Send lbl msg \<in> set R" (is "?send \<in> set R")
      and FV:   "MVar v \<in> FV msg"
  shows "\<exists> lbl' msg'. listOrd R (Recv lbl' msg') (Send lbl msg) \<and> MVar v \<in> FV msg'"
using Send
proof -
  let ?send = "Send lbl msg"
    and "\<exists> lbl' msg'. ?received lbl' msg'" = ?thesis
  assume "?send \<in> set R" then
  obtain ys zs
    where split: "R = ys @ ?send # zs" by (blast dest!: split_list)
  moreover have "distinct R" and "recv_before_send {} R" by auto
  ultimately obtain lbl' msg' where "Recv lbl' msg' \<in> set ys"
                                and "MVar v \<in> FV msg'"
             by (fastsimp dest!: recv_before_sent_distinct_Send_FV intro!: FV)
  hence "?received lbl' msg'" using split by auto
  thus ?thesis by blast
qed

end

end


theory SeqLock_Lib
  imports Main   Lib_ProofRules AbstractLock_Lib
begin
datatype PC =
  L1
| L2
| L3
| L4

consts t1 :: T
consts t2 :: T
consts glb :: L
consts l :: L

record prog_state =
  pc :: "T \<Rightarrow> PC"
  r :: "T \<Rightarrow> V"
  loc :: "T \<Rightarrow> bool"

record refinement_rel =
  write_rel :: "(L\<times>TS) \<Rightarrow> (L\<times>TS)"

definition
  "update_pc t nv pcf \<equiv> pcf (t := nv)"

definition
  "update_loc t nv pcf \<equiv> pcf (t := nv)"

definition seqLock :: "T \<Rightarrow> prog_state \<Rightarrow> lib_state \<Rightarrow> surrey_state \<Rightarrow> prog_state \<Rightarrow> lib_state \<Rightarrow> surrey_state \<Rightarrow> bool " where
"seqLock t s ls cs s' ls' cs' \<equiv>
(
if (pc s) t = L1
then
    ((ls) (cs) [r s' t \<leftarrow> lib(glb)]\<^sub>t (ls') (cs')) \<and>
    (even (r s' t)  \<longrightarrow> pc s' =  update_pc t L2 (pc s)) \<and>
    (\<not>even(r s' t) \<longrightarrow> pc s' =  pc s) \<and>
    (loc s' t  = loc s t) \<and> (\<forall>tt . tt\<noteq>t \<longrightarrow> r s' tt = r s tt)
    \<and> (\<forall>tt . tt\<noteq>t \<longrightarrow> loc s' tt = loc s tt)
else
if (pc s) t = L2
then
    ((ls) (cs) CAS[lib(glb), loc s' t, (r s t), (r s t + 1)]\<^sub>t (ls') (cs')) \<and>
    (loc s' t \<longrightarrow> pc s' = update_pc t L3 (pc s)) \<and>
    (\<not>loc s' t \<longrightarrow> pc s' = update_pc t L1 (pc s)) \<and>
    (r s' = r s)
    \<and> (\<forall>tt . tt\<noteq>t \<longrightarrow> loc s' tt = loc s tt)
else
False
)"

definition "seqLock_inv t p ls cs  s \<equiv>
    (case p of
          L1 \<Rightarrow> True
        | L2 \<Rightarrow> even (r s t)
        | L3 \<Rightarrow> loc s t \<and> even (r s t)
    )
"

definition seqLock_release :: "T \<Rightarrow> prog_state \<Rightarrow> lib_state \<Rightarrow> surrey_state \<Rightarrow> V \<Rightarrow>  prog_state \<Rightarrow> lib_state \<Rightarrow> surrey_state \<Rightarrow> bool " where
"seqLock_release t s ls cs ver s' ls' cs' \<equiv>
(
if (pc s) t = L1
then
    ((ls) (cs) [lib(glb) :=\<^sup>R (ver + 1)]\<^sub>t (ls') (cs')) \<and>
    pc s' = update_pc t L2 (pc s)
else
if (pc s) t = L2
then
      True
else
False
)"

definition "seqLock_release_inv t p ls cs s \<equiv>
    (case p of
          L1 \<Rightarrow> \<exists> v . ([lib(glb) =\<^sub>t v] ls) \<and> (odd v)
        | L2 \<Rightarrow> True
    )
"

lemma inv:
  assumes "wfs cs"
      and "lib_wfs ls cs"
      and "seqLock t s ls cs s' ls' cs'"
      and "seqLock_inv t (pc s t) ls cs  s"
    shows "seqLock_inv t (pc s' t) ls' cs'  s'"
  using assms
    apply(simp add: seqLock_def seqLock_inv_def update_pc_def)
    apply(case_tac "pc s t", simp_all)
    apply(case_tac "pc s' t", simp_all)
    apply(simp add: update_pc_def )
    apply safe
    apply simp+
              apply auto
    apply(simp_all add: update_pc_def )
  by (meson PC.distinct(3) fun_upd_eqD)

lemma inv_interf:
  assumes "wfs cs"
      and "lib_wfs ls cs"
      and "seqLock t' s ls cs s' ls' cs'"
      and "seqLock_inv t' (pc s t') ls cs  s"
      and "seqLock_inv t (pc s t) ls cs  s"
    shows "seqLock_inv t (pc s' t) ls' cs'  s'"
  using assms
  apply(case_tac "t = t'", simp_all)
   apply (meson assms(3) inv seqLock_inv_def)
    apply(simp add: seqLock_def seqLock_inv_def update_pc_def)
  apply(cases "pc s t'", simp_all)
  apply(cases "pc s t", simp_all)
      apply(cases "pc s' t", simp_all)
        apply(elim conjE)
    apply(simp_all add: update_pc_def )
  apply auto[1]
  apply auto
  apply(cases "pc s t", simp_all)
  apply presburger
  by presburger

(*Proof of refinement*)

(*
cc = concrete client state
ac = abstract client state
al = abstract lock state
cl = concrete lock state
*)

definition "writes_rel_inv al cl rr \<equiv> \<forall> cw . cw\<in>lib_writes_on cl glb \<longrightarrow>
            (\<exists> aw . aw\<in>lib_writes_on al l \<and>
            tst cw = tst aw \<and>
            lib_modView al aw CVARS = lib_modView cl cw CVARS \<and>
            lib_value al aw = lib_value cl cw \<and>
            lib_rel (lib_mods al aw) = lib_rel (lib_mods cl cw) \<and>
            (cw\<in>lib_covered cl \<longrightarrow> aw\<in>lib_covered al)\<and>
            (cw\<notin>lib_covered cl \<longrightarrow> aw\<notin>lib_covered al))"

definition "same_writes al cl rr  \<equiv> tst `lib_writes_on cl glb = tst ` lib_writes_on al l"

definition "thrView_rel al cl t \<equiv> tst (lib_thrView cl t glb) \<ge> tst (lib_thrView al t l)"

definition refinement_rel :: "lib_state \<Rightarrow> lib_state \<Rightarrow> surrey_state \<Rightarrow> surrey_state \<Rightarrow> T \<Rightarrow> refinement_rel \<Rightarrow> bool"
  where "refinement_rel al cl ac cc t rr \<equiv>  writes_rel_inv al cl rr  \<and>
                                               thrView_rel al cl t \<and>
                                               same_writes al cl rr"

lemmas invs =  writes_rel_inv_def thrView_rel_def update_pc_def
                    seqLock_inv_def   even_not_covered_last_def
                     refinement_rel_def

lemma not_acquired_sttutering:
  assumes "wfs cc"
  and "wfs ac"
  and "ac = cc"
  and "lib_wfs al ac"
  and "lib_wfs cl cc"
  and "abslock_invs al l"
  and "refinement_rel al cl ac cc t rr"
  and "pc s t = L2"
  and "loc s' t = False"
  and "seqLock_inv t (pc s t) cl cc  s"
  and "seqLock t s cl cc s' cl' cc'"
  and "al' = al"
  and "ac' = ac"
shows "refinement_rel al' cl' ac' cc' t rr \<and> ac' = cc'"
  using assms
  apply(simp add: refinement_rel_def seqLock_def lib_CAS_step_def)
  apply(elim conjE exE)
  apply(case_tac "lib_value cl (a, b) = r s t", simp_all)
  apply(simp add: lib_read_def all_updates_l)
  apply(intro conjI impI)
  apply(simp add: writes_rel_inv_def)
        apply(intro allI conjI impI)
        apply(simp add: lib_writes_on_def lib_value_def)
        apply(erule_tac x=ba in allE)
        apply(elim conjE, simp)
       apply(simp add: thrView_rel_def ts_oride_def)
       apply (simp_all add: lib_syncing_def)
  apply(simp add: writes_rel_inv_def)
    apply(intro allI conjI impI)
  apply(simp add: lib_writes_on_def)
  apply (metis (no_types, lifting) lib_state.select_convs(4) lib_state.surjective lib_state.update_convs(2) lib_value_def)
  apply(simp add: thrView_rel_def)
   apply(intro allI conjI impI)
   apply(simp add: lib_value_def lib_valid_fresh_ts_def lib_writes_on_def update_pc_def tst_def)
  apply (simp add: lib_visible_writes_def tst_def)
  by(simp add: same_writes_def lib_writes_on_def)

lemma new_state_writes_on: "lib_wfs cl cc \<Longrightarrow> (xc, ts')\<notin>lib_writes_on cl xc \<Longrightarrow> lib_writes_on
        (cl\<lparr>lib_thrView := (lib_thrView cl)
              (t := ts_oride ((lib_thrView cl t)(xc := (xc, ts')))
                     (lib_modView cl (xc, b) LVARS)),
              lib_modView := (lib_modView cl)
                ((xc, ts') := (lib_modView cl (xc, ts'))
                   (CVARS :=
                      ts_oride (thrView cc t)
                       (lib_modView cl (xc, b) CVARS),
                    LVARS :=
                      ts_oride ((lib_thrView cl t)(xc := (xc, ts')))
                       (lib_modView cl (xc, b) LVARS))),
              lib_mods := (lib_mods cl)
                ((xc, ts') :=
                   \<lparr>lib_val = v, lib_rel = bo\<rparr>),
              lib_writes := insert (xc, ts') (lib_writes cl),
              lib_covered := insert (xc, b) (lib_covered cl)\<rparr>)
        xc = lib_writes_on cl xc \<union> {(xc,ts')}"
  apply(simp add: lib_writes_on_def)
  apply(subgoal_tac " {w. fst w = xc \<and> w \<in> lib_writes cl} \<noteq> {}")
  apply(subgoal_tac "finite ( {w. fst w = xc \<and> w \<in> lib_writes cl})")
    apply force
  apply(simp add: lib_wfs_def)
   apply (simp add: lib_writes_on_def var_def)
  apply(simp add: lib_wfs_def)
   apply (simp add: lib_writes_on_def var_def)
  by (metis eq_fst_iff)

lemma refinement_step_lock_acquired:
  assumes "wfs cc"
  and "wfs ac"
  and "ac = cc"
  and "lib_wfs al ac"
  and "lib_wfs cl cc"
  and "abslock_invs al l"
  and "refinement_rel al cl ac cc t rr"
  and "pc s t = L2"
  and "loc s' t = True"
  and "seqLock_inv t (pc s t) cl cc  s"
  and "seqLock t s cl cc s' cl' cc'"
shows "\<exists> al' ac' ver rr' . [ac al t LOCKACQ(l) ac' al' True  ver] \<and> refinement_rel al' cl' ac' cc' t rr' \<and> ac'=cc'"
  using assms
  apply (simp add: refinement_rel_def lock_acquire_step_def)
  apply(simp add: seqLock_def lib_CAS_step_def  invs same_writes_def)
  apply(subgoal_tac "\<exists>tt . (tt::T)\<noteq>t") defer
   apply (metis Zero_not_Suc)
  apply(elim exE)
  apply(elim conjE)
  apply(rotate_tac 14)
  apply(erule_tac x = tt in allE, simp)
  apply(rotate_tac 1)
  apply(elim conjE exE)
  apply(subgoal_tac "a = glb", simp)
   defer
   apply (simp add: a_is_x)
  apply(erule_tac x=glb in allE)
  apply(erule_tac x=b in allE, simp)
  apply(subgoal_tac "(glb, b) \<in> lib_writes_on cl glb", simp)
   defer apply(simp add: lib_visible_writes_def)
  apply(elim exE)
  apply(subgoal_tac "aa = l", simp) defer
  apply (metis (mono_tags, hide_lams) a_is_x abslock_invs_def assms(2)  assms(4) assms(6) even_not_covered_last_def lib_last_in_visible_writes )
  apply(elim conjE)
  apply(case_tac "lib_value cl (glb ,b) = r s t", simp_all)
     apply(case_tac "lib_releasing cl (glb, b)")
  apply(rule_tac x = "if lib_releasing cl (glb,b) then
 al\<lparr>lib_thrView := (lib_thrView al)
          (t := ts_oride ((lib_thrView al t)(l := (l, ts')))
                 (lib_modView al (l, b) LVARS)),
          lib_modView := (lib_modView al)
            ((l, ts') := (lib_modView al (l, ts'))
               (CVARS :=
                  ts_oride (thrView cc t)
                   (lib_modView al (l, b) CVARS),
                LVARS :=
                  ts_oride ((lib_thrView al t)(l := (l, ts')))
                   (lib_modView al (l, b) LVARS))),
          lib_mods := (lib_mods al)
            ((l, ts') :=
               \<lparr>lib_val = Suc (lib_value al (l, b)),
                  lib_rel = True\<rparr>),
          lib_writes := insert (l, ts') (lib_writes al),
          lib_covered := insert (l, b) (lib_covered al)\<rparr>
else  al
       \<lparr>lib_thrView := (lib_thrView al)
          (t := (lib_thrView al t)(l := (l, ts'))),
          lib_modView := (lib_modView al)
            ((l, ts') := (lib_modView al (l, ts'))
               (CVARS := thrView cc t,
                LVARS := (lib_thrView al t)(l := (l, ts')))),
          lib_mods := (lib_mods al)
            ((l, ts') := \<lparr>lib_val = Suc (r s t), lib_rel = True\<rparr>),
          lib_writes := insert (l, ts') (lib_writes al),
          lib_covered := insert (l, b) (lib_covered al)\<rparr>" in exI)
         apply(simp add: lib_update_def lock_acquire_def  all_updates_l)
  apply(intro conjI)
     apply(rule_tac x = "lib_value al (l, b)" in exI)
     apply(rule_tac x = "l" in exI)
      apply(rule_tac x = "b" in exI)
  apply(simp_all add: lib_releasing_def)
      apply(intro conjI)
  apply (metis abslock_invs_def even_not_covered_last_def lib_last_in_visible_writes)
  apply(rule_tac x=ts' in exI, intro conjI)
  using new_ts_is_the_same apply blast
      defer
      apply(simp add: lib_writes_on_def lib_value_def)
      apply(intro allI  impI)
  using assms(7)
               apply(simp add: refinement_rel_def writes_rel_inv_def, elim conjE)
  apply(erule_tac x="glb" in allE)
               apply(erule_tac x="ba" in allE)
      apply(simp add: lib_writes_on_def)
  apply(case_tac "(glb, ba) \<in> lib_writes cl", simp_all)
      apply(elim conjE, intro conjI impI)
  apply blast+
      apply (simp add: lib_value_def)
      apply(intro conjI impI, elim conjE)
              apply (simp add:lib_wfs_def subset_iff)
             apply(elim conjE, simp)
             apply(subgoal_tac "(l, ts') \<notin> lib_writes al")
              apply (simp add:lib_wfs_def subset_iff)
            apply force
  apply (smt Collect_cong tst_eq_writes_on)
  apply linarith+
          apply blast+
    apply(simp add: ts_oride_def lib_writes_on_def lib_visible_writes_def)
    apply(intro conjI impI)
  using assms(7) apply(simp add: refinement_rel_def writes_rel_inv_def)
     apply(elim conjE)
  apply(erule_tac x = glb in allE)
     apply(erule_tac x = b in allE)
     apply(subgoal_tac "lib_modView al (l, b) LVARS l = (l,b) \<and>
            lib_modView cl (glb, b) LVARS glb = (glb, b)")
      apply simp
     apply(simp add: lib_wfs_def)
  apply(subgoal_tac "tst (lib_modView al (l, b) LVARS l) =  tst (lib_modView cl (glb, b) LVARS glb)")
     apply linarith
      apply(subgoal_tac "lib_modView al (l, b) LVARS l = (l,b) \<and>
            lib_modView cl (glb, b) LVARS glb = (glb, b)")
      apply simp
    apply(simp add: lib_wfs_def)
   apply(simp add: lib_writes_on_def)
   apply(subgoal_tac "{w. var w = glb \<and> (w = (glb, ts') \<or> w \<in> lib_writes cl)} = {w. var w = glb \<and> (w \<in> lib_writes cl)} \<union> {(glb, ts')}
\<and> {w. var w = l \<and> (w = (l, ts') \<or> w \<in> lib_writes al)} = {w. var w = l \<and> (w \<in> lib_writes al)} \<union> {(l, ts')}")
    apply simp
   apply(intro conjI)
    apply(subgoal_tac "finite ( {w. var w = glb \<and> w \<in> lib_writes cl})")
  apply(simp add: var_def tst_def)
  using Collect_cong apply auto[1]
  apply (metis lib_wfs_def lib_writes_on_def)
    apply(subgoal_tac "finite ( {w. var w = glb \<and> w \<in> lib_writes cl})")
  apply(simp add: var_def tst_def)
  using Collect_cong apply auto[1]
   apply (metis lib_wfs_def lib_writes_on_def)
  using assms(7)
  apply(simp add:refinement_rel_def writes_rel_inv_def, elim conjE)
    apply(erule_tac x=glb in allE)
  apply(erule_tac x=b in allE, simp)
  apply(elim exE conjE)
  apply(subgoal_tac "ab = l", simp)
   defer
  apply (metis Pair_inject abslock_invs_def even_not_covered_last_def)
   apply(rule_tac x = " al
       \<lparr>lib_thrView := (lib_thrView al)
          (t := (lib_thrView al t)(l := (l, ts'))),
          lib_modView := (lib_modView al)
            ((l, ts') := (lib_modView al (l, ts'))
               (CVARS := thrView cc t,
                LVARS := (lib_thrView al t)(l := (l, ts')))),
          lib_mods := (lib_mods al)
            ((l, ts') := \<lparr>lib_val = Suc (r s t), lib_rel = True\<rparr>),
          lib_writes := insert (l, ts') (lib_writes al),
          lib_covered := insert (l, b) (lib_covered al)\<rparr>" in exI)
         apply(simp add: lib_update_def lock_acquire_def  all_updates_l)
  apply(intro conjI)
   apply(simp_all add: lib_releasing_def)
  apply(intro conjI)
     apply(rule_tac x = "lib_value al (l, b)" in exI)
     apply(rule_tac x = "l" in exI)
      apply(rule_tac x = "b" in exI)
    apply(intro conjI, simp_all)
  apply(intro conjI)
  apply (metis abslock_invs_def even_not_covered_last_def lib_last_in_visible_writes)
  apply(rule_tac x=ts' in exI, intro conjI)
  using new_ts_is_the_same apply blast
      defer
      apply(simp add: lib_writes_on_def lib_value_def)
      apply(intro allI  impI)
  using assms(7)
               apply(simp add: refinement_rel_def writes_rel_inv_def)
  apply(erule_tac x="glb" in allE)
               apply(erule_tac x="ba" in allE)
      apply(simp add: lib_writes_on_def)
  apply(case_tac "(glb, ba) \<in> lib_writes cl", simp_all)
      apply(elim conjE, intro conjI impI)
  apply blast+
      apply (simp add: lib_value_def)
      apply(intro conjI impI, elim conjE)
              apply (simp add:lib_wfs_def subset_iff)
             apply(elim conjE, simp)
             apply(subgoal_tac "(l, ts') \<notin> lib_writes al")
              apply (simp add:lib_wfs_def subset_iff)
            apply force
  apply (smt Collect_cong tst_eq_writes_on)
          apply linarith+
  apply blast
          apply blast
          apply blast
          apply blast
          apply blast
          apply blast
    apply(simp add: ts_oride_def lib_writes_on_def lib_visible_writes_def)
   apply(subgoal_tac "{w. var w = glb \<and> (w = (glb, ts') \<or> w \<in> lib_writes cl)} = {w. var w = glb \<and> (w \<in> lib_writes cl)} \<union> {(glb, ts')}
\<and> {w. var w = l \<and> (w = (l, ts') \<or> w \<in> lib_writes al)} = {w. var w = l \<and> (w \<in> lib_writes al)} \<union> {(l, ts')}")
    apply simp
   apply(intro conjI)
    apply(subgoal_tac "finite ( {w. var w = glb \<and> w \<in> lib_writes cl})")
  apply(simp add: var_def tst_def)
  using Collect_cong apply auto[1]
  apply (metis lib_wfs_def lib_writes_on_def)
    apply(subgoal_tac "finite ( {w. var w = glb \<and> w \<in> lib_writes cl})")
  apply(simp add: var_def tst_def)
  using Collect_cong apply auto[1]
   apply (metis lib_wfs_def lib_writes_on_def)
done

(*************Release Operation Refinement**************)

lemma refinement_step_release:
  assumes "wfs cc"
  and "wfs ac"
  and "ac = cc"
  and "lib_wfs al ac"
  and "lib_wfs cl cc"
  and "abslock_invs al l"
  and "refinement_rel al cl ac cc t rr"
  and "[lib(glb) =\<^sub>t ver] cl"
  and "odd ver"
  and "pc s t = L1"
  and "seqLock_release t s cl cc ver s' cl' cc'"
shows "\<exists> al' ac'  . [ac al t LOCKREL(l) al' ac'] \<and> refinement_rel al' cl' ac' cc' t rr'  \<and>  ac'=cc'"
  using assms
  apply(simp add: seqLock_release_def lock_release_step_def lib_write_step_def refinement_rel_def)
  apply(simp add: lib_write_def  all_updates_l writes_rel_inv_def)
  apply(elim conjE exE)
  apply(rule_tac x = "al
       \<lparr>lib_thrView := (lib_thrView al)
          (t := (lib_thrView al t)(l := (l, ts'))),
          lib_modView := (lib_modView al)
            ((l, ts') := (lib_modView al (l, ts'))
               (CVARS := thrView cc t,
                LVARS := (lib_thrView al t)(l := (l, ts')))),
          lib_mods := (lib_mods al)
            ((l, ts') :=
               \<lparr>lib_val = Suc (lib_value cl (a, b)), lib_rel = True\<rparr>),
          lib_writes := insert (l, ts') (lib_writes al)\<rparr>" in exI)
  apply(intro conjI )
  apply(erule_tac x = a in allE)
     apply(erule_tac x = b in allE)
  apply (simp add: lib_visible_writes_def)
     apply(elim conjE exE)
  apply(subgoal_tac "aa = l", simp)
  apply(rule_tac x = l in exI)
     apply(rule_tac x = b in exI)
  apply(intro conjI)
        apply blast
  apply (meson order.trans thrView_rel_def)
      apply blast
     apply(rule_tac x = ts' in exI)
     apply(intro conjI)
      apply(simp add: same_writes_def lib_writes_on_def lib_valid_fresh_ts_def)
  apply(intro allI impI)
      apply (smt Collect_cong tst_eq_writes_on_not)
      apply(simp add: lock_release_def lib_write_def all_updates_l)
     apply(simp add: lib_writes_on_def)
    apply(intro allI impI)
     apply(simp add: lib_writes_on_def lib_value_def)
    apply(case_tac "ba = ts'", simp_all)
     apply(case_tac "glb = a", simp_all)
  apply(intro conjI impI)
        apply (metis lib_dobs_visible_writes lib_value_def)
       apply(subgoal_tac "(glb, ts') \<notin> lib_writes cl")
  apply(simp add: lib_wfs_def)
  using subset_iff apply auto[1]
  apply(simp add: lib_valid_fresh_ts_def lib_visible_writes_def lib_writes_on_def)
       apply blast
  apply(elim conjE disjE)
       apply(simp add: same_writes_def lib_writes_on_def var_def tst_def lib_visible_writes_def)
       apply(subgoal_tac "(glb, ts') \<notin> lib_writes cl")
        apply(subgoal_tac "ts' \<notin> snd ` {w. fst w = glb \<and> w \<in> lib_writes cl}")
       apply(subgoal_tac "(l, ts') \<notin> lib_writes al")
  apply(simp add: lib_wfs_def)
   apply auto[1]
   apply (simp add: image_iff)
   using imageE apply force
   apply (simp add: fresh_ts_not_in_writes)
   apply blast
   using a_is_x apply blast
     apply blast
   apply(simp add: thrView_rel_def)
   using a_is_x apply blast
   apply(simp add: same_writes_def lib_writes_on_def tst_def var_def lib_visible_writes_def)
   apply(subgoal_tac "finite {w. fst w = glb \<and> w \<in> lib_writes cl}")
    apply(subgoal_tac "finite {w. fst w = l \<and> w \<in> lib_writes al}")
   apply(subgoal_tac "{w. fst w = glb \<and> (w = (glb, ts') \<or> w \<in> lib_writes cl)} =
        {w. fst w = glb \<and> (w \<in> lib_writes cl)} \<union> {(glb,ts')}")
   apply(subgoal_tac "{w. fst w = l \<and> (w = (l, ts') \<or> w \<in> lib_writes al)} =
        {w. fst w = l \<and> ( w \<in> lib_writes al)} \<union> {(l,ts')}")
       apply simp_all
   apply (simp add: writes_ts_rewrite)
   apply (simp add: writes_ts_rewrite)
   apply(simp add: lib_wfs_def lib_writes_on_def)
   using var_def apply auto[1]
   apply(simp add: lib_wfs_def lib_writes_on_def)
   using var_def apply auto[1]
   done

end


theory Refine_Vector_List
  imports
  Ordinary_Differential_Equations.ODE_Auxiliarities
  "../Refinement/Autoref_Misc" (* TODO: what is still needed there? *)
  "../Refinement/Weak_Set"
  "Enclosure_Operations"
begin

subsection \<open>Id on euclidean space, real etc\<close>

consts i_rnv::interface
abbreviation "rnv_rel \<equiv> (Id::('a::real_normed_vector\<times>_) set)"
lemmas [autoref_rel_intf] = REL_INTFI[of rnv_rel i_rnv]

context includes autoref_syntax begin

lemma [autoref_rules]:
  "((=), (=)) \<in> rnv_rel \<rightarrow> rnv_rel \<rightarrow> bool_rel"
  "((\<le>), (\<le>)) \<in> rnv_rel \<rightarrow> rnv_rel \<rightarrow> bool_rel"
  "((<), (<)) \<in> rnv_rel \<rightarrow> rnv_rel \<rightarrow> bool_rel"
  "(min, min) \<in> rnv_rel \<rightarrow> rnv_rel \<rightarrow> rnv_rel"
  "(max, max) \<in> rnv_rel \<rightarrow> rnv_rel \<rightarrow> rnv_rel"
  "((+), (+)) \<in> rnv_rel \<rightarrow> rnv_rel \<rightarrow> rnv_rel"
  "((-), (-)) \<in> rnv_rel \<rightarrow> rnv_rel \<rightarrow> rnv_rel"
  "((/), (/)) \<in> rnv_rel \<rightarrow> rnv_rel \<rightarrow> rnv_rel"
  "((*), (*)) \<in> rnv_rel \<rightarrow> rnv_rel \<rightarrow> rnv_rel"
  "((^), (^)) \<in> rnv_rel \<rightarrow> nat_rel \<rightarrow> rnv_rel"
  "(int, int) \<in> nat_rel \<rightarrow> int_rel"
  "(Float, Float) \<in> int_rel \<rightarrow> int_rel \<rightarrow> Id"
  "(real_of_float, real_of_float) \<in> Id \<rightarrow> rnv_rel"
  "(upto, upto) \<in> int_rel \<rightarrow> int_rel \<rightarrow> \<langle>int_rel\<rangle>list_rel"
  "(upt, upt) \<in> nat_rel \<rightarrow> nat_rel \<rightarrow> \<langle>nat_rel\<rangle>list_rel"
  "(product_lists, product_lists) \<in> \<langle>\<langle>int_rel\<rangle>list_rel\<rangle>list_rel \<rightarrow> \<langle>\<langle>int_rel\<rangle>list_rel\<rangle>list_rel"
  "(floor, floor) \<in> rnv_rel \<rightarrow> int_rel"
  by auto
end

subsection \<open>list vector relation\<close>

definition lv_rel::"(real list \<times> 'a::executable_euclidean_space) set"
  where "lv_rel = br eucl_of_list (\<lambda>xs. length xs = DIM('a))"

lemmas [autoref_rel_intf] = REL_INTFI[of lv_rel i_rnv]

lemma lv_rel_sv[relator_props]: "single_valued lv_rel"
  by (auto simp: lv_rel_def)

context includes autoref_syntax begin

lemma lv_rel_le[autoref_rules]: "(list_all2 (\<lambda>x y. x \<le> y), (\<le>)) \<in> lv_rel \<rightarrow> lv_rel \<rightarrow> bool_rel"
  by (auto simp: lv_rel_def br_def eucl_le[where 'a='a] eucl_of_list_inner list_all2_conv_all_nth
      index_nth_id)
     (metis distinct_Basis_list index_nth_id length_Basis_list nth_Basis_list_in_Basis)

lemma lv_rel_inf[autoref_rules]: "(List.map2 min, inf) \<in> lv_rel \<rightarrow> lv_rel \<rightarrow> lv_rel"
  by (auto simp: lv_rel_def br_def eucl_inf[where 'a='a] eucl_of_list_inner list_all2_conv_all_nth
      index_nth_id inf_real_def
      intro!: euclidean_eqI[where 'a='a])

lemma lv_rel_sup[autoref_rules]: "(List.map2 max, sup) \<in> lv_rel \<rightarrow> lv_rel \<rightarrow> lv_rel"
  by (auto simp: lv_rel_def br_def eucl_sup[where 'a='a] eucl_of_list_inner list_all2_conv_all_nth
      index_nth_id sup_real_def
      intro!: euclidean_eqI[where 'a='a])

lemma lv_rel_add[autoref_rules]: "(List.map2 (+), (+)) \<in> lv_rel \<rightarrow> lv_rel \<rightarrow> lv_rel"
  by (auto simp: lv_rel_def br_def eucl_sup[where 'a='a] eucl_of_list_inner list_all2_conv_all_nth
      index_nth_id sup_real_def algebra_simps
      intro!: euclidean_eqI[where 'a='a])

lemma lv_rel_minus[autoref_rules]: "(List.map2 (-), (-)) \<in> lv_rel \<rightarrow> lv_rel \<rightarrow> lv_rel"
  by (auto simp: lv_rel_def br_def eucl_sup[where 'a='a] eucl_of_list_inner list_all2_conv_all_nth
      index_nth_id sup_real_def algebra_simps
      intro!: euclidean_eqI[where 'a='a])

lemma lv_rel_scaleR[autoref_rules]: "(\<lambda>r. map (scaleR r), scaleR) \<in> rnv_rel \<rightarrow> lv_rel \<rightarrow> lv_rel"
  by (auto simp: lv_rel_def br_def eucl_sup[where 'a='a] eucl_of_list_inner list_all2_conv_all_nth
      index_nth_id sup_real_def
      intro!: euclidean_eqI[where 'a='a])

lemma lv_rel_uminus[autoref_rules]: "(map uminus, uminus) \<in> lv_rel \<rightarrow> lv_rel"
  by (auto simp: lv_rel_def br_def eucl_sup[where 'a='a] eucl_of_list_inner list_all2_conv_all_nth
      index_nth_id sup_real_def
      intro!: euclidean_eqI[where 'a='a])

lemma lv_rel_abs[autoref_rules]: "(map abs, abs) \<in> lv_rel \<rightarrow> lv_rel"
  by (auto simp: lv_rel_def br_def eucl_abs[where 'a='a] eucl_of_list_inner list_all2_conv_all_nth
      index_nth_id sup_real_def
      intro!: euclidean_eqI[where 'a='a])

lemma lv_rel_inner[autoref_rules]: "(inner_lv_rel, (\<bullet>)) \<in> lv_rel \<rightarrow> lv_rel \<rightarrow> rnv_rel"
  by (subst euclidean_inner[abs_def], subst sum_list_Basis_list[symmetric])
    (auto simp: lv_rel_def br_def eucl_of_list_inner sum_list_sum_nth index_nth_id inner_lv_rel_def)

definition "mig_real a b = (if a \<le> 0 \<and> 0 \<le> b \<or> b \<le> 0 \<and> 0 \<le> a then 0 else min (abs a) (abs b))"
definition "mig_componentwise a b = (\<Sum>i\<in>Basis. mig_real (a \<bullet> i) (b \<bullet> i) *\<^sub>R i)"
definition "mig_lv a b = (List.map2 mig_real a b)"
lemma length_mig_lv[simp]: "length (mig_lv a b) = min (length a) (length b)"
  by (auto simp: mig_lv_def)
lemma mig_lv_nth: "mig_real (a ! i) (b ! i) = mig_lv a b ! i" if "i < length a" "i < length b"
  by (auto simp: mig_lv_def that)

lemma mig_real_abs_le: "\<bar>mig_real a b\<bar> \<le> \<bar>x\<bar>" if "x \<in> {a .. b}" for x::real
  using that
  by (auto simp: mig_real_def abs_real_def)

lemma norm_eucl_L2: "norm x = sqrt (\<Sum>i\<in>Basis. (x \<bullet> i)\<^sup>2)"
  unfolding norm_conv_dist by (subst euclidean_dist_l2)  (simp add: L2_set_def)

lemma mig_componentwise_inner_Basis: "mig_componentwise a b \<bullet> i = mig_real (a \<bullet> i) (b \<bullet> i)"
  if "i \<in> Basis"
  using that
  by (auto simp: mig_componentwise_def)

lemma norm_mig_componentwise_le: "norm (mig_componentwise a b) \<le> norm x" if "x \<in> {a .. b}" for
  a::"'a::ordered_euclidean_space"
  apply (rule norm_le_in_cubeI)
  apply (simp add: mig_componentwise_inner_Basis)
  apply (rule mig_real_abs_le)
  using that
  by (auto simp: eucl_le[where 'a='a])

lemma mig_componentwise_autoref[autoref_rules]:
  "(mig_lv, mig_componentwise) \<in> lv_rel \<rightarrow> lv_rel \<rightarrow> lv_rel"
  unfolding lv_rel_def
  by (auto simp: mig_componentwise_def euclidean_eq_iff[where 'a='a] eucl_of_list_inner mig_lv_nth
      br_def)

primrec vecsumlist' where
  "vecsumlist' 0 xs       = []"
| "vecsumlist' (Suc i) xs = sum_list (map hd xs)#vecsumlist' i (map tl xs)"

lemma vecsumlist':
  assumes "\<And>xs. xs \<in> set xss \<Longrightarrow> i \<le> length xs"
  shows "vecsumlist' i xss = map (\<lambda>i. sum_list (map (\<lambda>xs. xs ! i) xss)) [0..<i]"
  using assms
proof (induction i arbitrary: xss)
  case 0
  then show ?case by simp
next
  case (Suc i)
  from Suc.prems have xss_ne: "x \<in> set xss \<Longrightarrow> x \<noteq> []" for x
    by force
  show ?case
    apply simp
    apply (subst Suc.IH)
    subgoal using Suc.prems by force
    apply (auto intro!: nth_equalityI)
    using xss_ne
    apply (auto simp: nth_Cons nth_append o_def split: nat.splits)
    apply (meson hd_conv_nth arg_cong[OF map_cong, where f = sum_list])
    apply (meson hd_conv_nth arg_cong[OF map_cong, where f = sum_list])
    apply (meson Misc.nth_tl arg_cong[OF map_cong, where f = sum_list])
    by (metis (no_types, lifting) Misc.nth_tl Suc_leI le_neq_implies_less map_cong)
qed

lemma inner_sum_list_left: "sum_list xs \<bullet> b = (\<Sum>x\<leftarrow>xs. x \<bullet> b)"
  by (auto simp: sum_list_sum_nth inner_sum_left)

definition [simp]: "DIM_eq (TYPE('a::executable_euclidean_space)) n \<longleftrightarrow> DIM('a) = n"
abbreviation "DIM_precond TYPE('a) n \<equiv> DIM_eq TYPE('a::executable_euclidean_space) n"

lemma DIM_precond_times[autoref_rules_raw]:
  "DIM_precond TYPE('a::executable_euclidean_space\<times>'b::executable_euclidean_space) (D + E)"
  if "DIM_precond TYPE('a::executable_euclidean_space) D"
     "DIM_precond TYPE('b::executable_euclidean_space) E"
  using that by (auto simp: )

lemma [autoref_rules]: "(sum_list, sum_list) \<in> \<langle>rnv_rel\<rangle>list_rel \<rightarrow> rnv_rel"
  by auto

lemma lv_rel_sum_list[autoref_rules]:
  assumes "DIM_precond TYPE('a::executable_euclidean_space) n"
  shows "(vecsumlist' n, sum_list) \<in> \<langle>lv_rel::(real list \<times> 'a) set\<rangle>list_rel \<rightarrow> lv_rel"
proof
  fix xss and XS::"'a list"
  assume xss: "(xss, XS) \<in> \<langle>lv_rel\<rangle>list_rel"
  then have "\<And>xs. xs \<in> set xss \<Longrightarrow> DIM('a) \<le> length xs"
    by (auto simp: lv_rel_def list_rel_def in_set_conv_nth br_def dest!: list_all2_nthD )
  from vecsumlist'[OF this, of xss] assms xss
  show "(vecsumlist' n xss, sum_list XS) \<in> lv_rel"
    apply (auto simp: lv_rel_def br_def)
    apply (auto intro!: euclidean_eqI[where 'a='a] simp: eucl_of_list_inner inner_sum_list_left)
    apply (rule sum_list_nth_eqI)
     apply (auto simp: list_all2_iff list_rel_def in_set_zip Ball_def)
    apply (drule_tac x = "xss ! na" in spec)
    apply (drule_tac x = "XS ! na" in spec)
    apply (auto simp: eucl_of_list_inner)
    done
qed

lemma lv_rel_eq[autoref_rules]: "((=), (=)) \<in> lv_rel \<rightarrow> lv_rel \<rightarrow> bool_rel"
  by (auto simp: lv_rel_def br_def euclidean_eq_iff[where 'a='a] eucl_of_list_inner
      intro!: nth_equalityI)
     (metis distinct_Basis_list index_nth_id length_Basis_list nth_Basis_list_in_Basis)

lemma lv_rel_zero[autoref_rules]:
  assumes "DIM_precond TYPE('a::executable_euclidean_space) n"
  shows "(replicate n 0, 0::'a) \<in> lv_rel"
  using assms
  by (auto simp: lv_rel_def br_def eucl_of_list_inner intro!: euclidean_eqI[where 'a='a])

definition "Basis_list_impl n = (let zs = replicate n 0 in map (\<lambda>i. zs[i:=1]) [0..<n])"
lemma lv_rel_Basis_list[autoref_rules]:
  assumes "DIM_precond (TYPE('a::executable_euclidean_space)) n"
  shows "(Basis_list_impl n, Basis_list::'a list) \<in> \<langle>lv_rel\<rangle>list_rel"
  using assms
  by (auto simp: list_rel_def lv_rel_def eucl_of_list_inner inner_Basis nth_eq_iff_index
      Basis_list_impl_def
      intro!: brI list_all2_all_nthI euclidean_eqI[where 'a='a])

definition "lv_ivl xrs yrs = {zrs. list_all2 (\<le>) xrs zrs \<and> list_all2 (\<le>) zrs yrs}"

lemma lv_relI:
  "length x = DIM('a) \<Longrightarrow> (x, eucl_of_list x::'a::executable_euclidean_space) \<in> lv_rel"
  by (auto simp: lv_rel_def br_def)

lemma eucl_of_list_image_lv_ivl:
  assumes [simp]: "length xrs = DIM('a)" "length yrs = DIM('a)"
  shows "eucl_of_list ` (lv_ivl xrs yrs) =
    {eucl_of_list xrs .. eucl_of_list yrs::'a::executable_euclidean_space}"
  apply (auto simp: list_all2_iff lv_ivl_def eucl_le[where 'a='a] eucl_of_list_inner Ball_def
      in_set_zip)
  apply (metis Basis_list index_less_size_conv length_Basis_list)
   apply (metis Basis_list index_less_size_conv length_Basis_list)
  apply (rule image_eqI)
   apply (rule eucl_of_list_list_of_eucl[symmetric])
  using nth_Basis_list_in_Basis apply fastforce
  done

end

subsection \<open>Specs for Vectors\<close>

context includes autoref_syntax begin

lemma Inf_specs_Inf_spec:
  "(Inf_specs d, Inf_spec::_\<Rightarrow>'a::executable_euclidean_space nres) \<in> \<langle>lv_rel\<rangle>set_rel \<rightarrow> \<langle>lv_rel\<rangle>nres_rel"
  if "d = DIM('a)"
  apply (auto intro!: nres_relI RES_refine simp: Inf_specs_def Inf_spec_def set_rel_def that)
  subgoal for x y s
    apply (rule exI[where x="eucl_of_list s"])
    apply (auto simp: lv_rel_def br_def subset_iff)
    apply (drule bspec, assumption)
    apply auto
    apply (drule bspec, assumption)
    apply auto
    apply (drule bspec, assumption)
    subgoal for c
      using lv_rel_le[where 'a ='a, param_fo, OF lv_relI lv_relI, of s c]
      by auto
    done
  done

lemma Sup_specs_Sup_spec:
  "(Sup_specs d, Sup_spec::_\<Rightarrow>'a::executable_euclidean_space nres) \<in> \<langle>lv_rel\<rangle>set_rel \<rightarrow> \<langle>lv_rel\<rangle>nres_rel"
  if "d = DIM('a)"
 apply (auto intro!: nres_relI RES_refine simp: Sup_specs_def Sup_spec_def set_rel_def that)
  subgoal for x y s
    apply (rule exI[where x="eucl_of_list s"])
    apply (auto simp: lv_rel_def br_def subset_iff)
    apply (drule bspec, assumption)
    apply auto
    apply (drule bspec, assumption)
    apply auto
    apply (drule bspec, assumption)
    subgoal for c
      using lv_rel_le[where 'a ='a, param_fo, OF lv_relI lv_relI, of c s]
      by auto
    done
  done

lemma Sup_inners_Sup_inner: "(Sup_inners, Sup_inner) \<in> \<langle>lv_rel\<rangle>set_rel \<rightarrow> lv_rel \<rightarrow> \<langle>rnv_rel\<rangle>nres_rel"
  unfolding set_rel_sv[OF lv_rel_sv]
  apply (auto intro!: nres_relI RES_refine
      simp: Sup_inners_def Sup_inner_def  plane_ofs_def plane_of_def lv_rel_def br_def)
  subgoal for a b c d
    using lv_rel_inner[where 'a = 'a, param_fo, OF lv_relI lv_relI, of d b]
    by auto
  done

lemma Inf_inners_Inf_inner: "(Inf_inners, Inf_inner) \<in> \<langle>lv_rel\<rangle>set_rel \<rightarrow> lv_rel \<rightarrow> \<langle>rnv_rel\<rangle>nres_rel"
  unfolding set_rel_sv[OF lv_rel_sv]
  apply (auto intro!: nres_relI RES_refine
      simp: Inf_inners_def Inf_inner_def plane_ofs_def plane_of_def lv_rel_def br_def)
  subgoal for a b c d
    using lv_rel_inner[where 'a = 'a, param_fo, OF lv_relI lv_relI, of d b]
    by auto
  done

lemma split_spec_params_split_spec_param:
  "(split_spec_params d, split_spec_param::nat\<Rightarrow>'a::executable_euclidean_space set\<Rightarrow>_) \<in> nat_rel \<rightarrow> \<langle>lv_rel\<rangle>set_rel \<rightarrow> \<langle>\<langle>lv_rel\<rangle>set_rel\<times>\<^sub>r\<langle>lv_rel\<rangle>set_rel\<rangle>nres_rel"
  if "d = DIM('a::executable_euclidean_space)"
  apply (auto intro!: nres_relI RES_refine simp: split_spec_param_def split_spec_params_def env_len_def that)
  unfolding set_rel_sv[OF lv_rel_sv]
  apply (auto intro!: nres_relI RES_refine simp: plane_ofs_def plane_of_def lv_rel_def br_def subset_iff)
  done

lemma reduce_specs_reduce_spec:
  "(reduce_specs d, reduce_spec::_\<Rightarrow>'a::executable_euclidean_space set\<Rightarrow>_) \<in> Id \<rightarrow> \<langle>lv_rel\<rangle>set_rel \<rightarrow> \<langle>\<langle>lv_rel\<rangle>set_rel\<rangle>nres_rel"
  if "d = DIM('a::executable_euclidean_space)"
  apply (auto intro!: nres_relI RES_refine simp: reduce_spec_def reduce_specs_def env_len_def that)
  unfolding set_rel_sv[OF lv_rel_sv]
  apply (auto intro!: nres_relI RES_refine simp: plane_ofs_def plane_of_def lv_rel_def br_def subset_iff)
  done

definition [simp]: "rnv_of_lv x = x"

lemma rnv_of_lv_impl[autoref_rules]: "(hd, rnv_of_lv) \<in> lv_rel \<rightarrow> rnv_rel"
  by (auto simp: lv_rel_def br_def length_Suc_conv)

lemma
  assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) D"
  shows snd_lv_rel[autoref_rules(overloaded)]: "(drop D, snd::('a \<times> _) \<Rightarrow> _) \<in> lv_rel \<rightarrow> lv_rel"
    and fst_lv_rel[autoref_rules(overloaded)]: "(take D, fst::('a \<times> _) \<Rightarrow> _) \<in> lv_rel \<rightarrow> lv_rel"
  using assms by (auto simp: lv_rel_def br_def eucl_of_list_prod)

definition [simp]: "Pair_lv_rel = Pair"

lemma Pair_lv_rel[autoref_rules]:
  assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) D"
  shows "((@), Pair_lv_rel::'a \<Rightarrow> _) \<in> lv_rel \<rightarrow> lv_rel \<rightarrow> lv_rel"
  using assms
  by (auto simp: lv_rel_def br_def intro!: eucl_of_list_eqI)

definition [simp]: "split_lv_rel X = (fst X, snd X)"

schematic_goal split_lv_rel_impl[autoref_rules]:
  assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) D"
  shows "(?r, split_lv_rel::'a\<times>_\<Rightarrow>_) \<in> lv_rel \<rightarrow> lv_rel \<times>\<^sub>r lv_rel"
  unfolding split_lv_rel_def
  by autoref

lemma lv_rel_less[autoref_rules]: "(list_all2 (\<lambda>x y. x < y), eucl_less) \<in> lv_rel \<rightarrow> lv_rel \<rightarrow> bool_rel"
  by (auto simp: lv_rel_def br_def eucl_less_def[where 'a='a] eucl_of_list_inner list_all2_conv_all_nth
      index_nth_id)
     (metis distinct_Basis_list index_nth_id length_Basis_list nth_Basis_list_in_Basis)

lemma list_of_eucl_autoref[autoref_rules]: "(\<lambda>x. x, list_of_eucl) \<in> lv_rel \<rightarrow> \<langle>rnv_rel\<rangle>list_rel"
  by (auto simp: lv_rel_def br_def)

definition [simp]: "op_DIM TYPE('a) = DIM('a::executable_euclidean_space)"
lemma [autoref_op_pat_def]: "DIM('a) \<equiv> OP (op_DIM TYPE('a::executable_euclidean_space))" by simp
lemma op_DIM[autoref_rules]:
  assumes [simplified, symmetric, simp]: "DIM_precond TYPE('a) E"
  shows "(E, (op_DIM TYPE('a::executable_euclidean_space))) \<in> nat_rel"
  using assms
  by auto

end

end


theory SepLog_Automatic
imports "Imperative_HOL_Time.SepAuto"
  "HOL-Eisbach.Eisbach" "SepLog_Misc"   Automatic_Refinement.Automatic_Refinement

begin

subsection \<open>stuff for VCG\<close>

lemma is_hoare_triple: "<P> c <Q> \<Longrightarrow> <P> c <Q>" .

lemma fi_rule:
  assumes CMD: "<P> c <Q>"
  assumes FRAME: "Ps \<Longrightarrow>\<^sub>A P * F"
  shows "<Ps> c <\<lambda>x. Q x * F>"
  apply (rule pre_rule[rotated])
  apply (rule frame_rule)
  apply (rule CMD)
  apply (rule FRAME)
  done

lemma cons_post_rule: "<P> c <Q> \<Longrightarrow> (\<And>x. Q x \<Longrightarrow>\<^sub>A Q' x) \<Longrightarrow> <P> c <Q'>"
  using post_rule by blast

lemma ent_pure_pre_iff[simp]: "(P*\<up>b \<Longrightarrow>\<^sub>A Q) \<longleftrightarrow> (b \<longrightarrow> (P \<Longrightarrow>\<^sub>A Q))"
  unfolding entails_def
  by (auto   )

theorem normalize_rules:
           "\<And>P. (\<And>x. <P x> f <Q>) \<Longrightarrow> <\<exists>\<^sub>Ax. P x> f <Q>"
           "\<And>P. (b \<Longrightarrow> <P> f <Q>) \<Longrightarrow> <P * \<up> b> f <Q>"
           "\<And>P. (b \<Longrightarrow> <emp> f <Q>) \<Longrightarrow> <\<up> b> f <Q>"
  subgoal using pre_ex_rule by force
  subgoal using norm_pre_pure_iff by blast
  subgoal using norm_pre_pure_iff2 by blast
  done

subsection \<open>\<close>

lemma ent_pure_pre_iff_sng[simp]:
  "(\<up>b \<Longrightarrow>\<^sub>A Q) \<longleftrightarrow> (b \<longrightarrow> (emp \<Longrightarrow>\<^sub>A Q))"
  using ent_pure_pre_iff[where P=emp]
  by simp

lemma ent_pure_post_iff[simp]:
  "(P \<Longrightarrow>\<^sub>A Q*\<up>b) \<longleftrightarrow> ((\<forall>h. h\<Turnstile>P \<longrightarrow> b) \<and> (P \<Longrightarrow>\<^sub>A Q))"
  unfolding entails_def
  by (auto)

lemma ent_pure_post_iff_sng[simp]:
  "(P \<Longrightarrow>\<^sub>A \<up>b) \<longleftrightarrow> ((\<forall>h. h\<Turnstile>P \<longrightarrow> b) \<and> (P \<Longrightarrow>\<^sub>A emp))"
  using ent_pure_post_iff[where Q=emp]
  by simp

subsection "Rotate method"

definition gr where "gr A B = A * B"

lemma right_swap: "(A \<Longrightarrow>\<^sub>A B * (C * D)) \<Longrightarrow> (A \<Longrightarrow>\<^sub>A B * (D * C))"
  by (simp add: assn_times_comm)
lemma right_take: "(A \<Longrightarrow>\<^sub>A gr B C * D) \<Longrightarrow> (A \<Longrightarrow>\<^sub>A B * (C * D))"
  by (simp add: gr_def assn_times_assoc)
lemma left_swap: "(B * (C * D) \<Longrightarrow>\<^sub>A A) \<Longrightarrow> (B * (D * C) \<Longrightarrow>\<^sub>A A)"
  by (simp add: assn_times_comm)
lemma left_take: "(gr B C * D \<Longrightarrow>\<^sub>A A) \<Longrightarrow> (B * (C * D) \<Longrightarrow>\<^sub>A A)"
  by (simp add: gr_def assn_times_assoc)

lemma right_move_back: "(A \<Longrightarrow>\<^sub>A B * C) \<Longrightarrow> (A \<Longrightarrow>\<^sub>A C * B)"
  by (simp add: assn_times_comm)
lemma left_move_back: "(B * C \<Longrightarrow>\<^sub>A A) \<Longrightarrow> (C * B \<Longrightarrow>\<^sub>A A)"
  by (simp add: assn_times_comm)
lemma right_move_backt: "(A \<Longrightarrow>\<^sub>t B * C) \<Longrightarrow> (A \<Longrightarrow>\<^sub>t C * B)"
  by (simp add: assn_times_comm)
lemma left_move_backt: "(B * C \<Longrightarrow>\<^sub>t A) \<Longrightarrow> (C * B \<Longrightarrow>\<^sub>t A)"
  by (simp add: assn_times_comm)

thm mult.assoc
method rotater = ( (simp only: mult.assoc)? , rule right_move_back , (simp only: mult.assoc)?  )
method rotatel = ( (simp only: mult.assoc)? , rule left_move_back , (simp only: mult.assoc)?  )

method swapl = ( (simp only: mult.assoc)? ,rule left_swap, (simp only: mult.assoc)?   )
method takel = ( (simp only: mult.assoc)? , rule left_take, (simp only: mult.assoc)?  )

method swapr = ( (simp only: mult.assoc)? , rule right_swap , (simp only: mult.assoc)?  )
method taker = ( (simp only: mult.assoc)? , rule right_take, (simp only: mult.assoc)?  )

method rotatert = ( (simp only: mult.assoc)? , rule right_move_backt , (simp only: mult.assoc)?  )
method rotatelt = ( (simp only: mult.assoc)? , rule left_move_backt , (simp only: mult.assoc)?  )

lemma match_firstt: "A \<Longrightarrow>\<^sub>t B \<Longrightarrow> \<Gamma> * A \<Longrightarrow>\<^sub>t \<Gamma> * B"
  by (simp add: entt_star_mono)

lemma match_restt: "emp \<Longrightarrow>\<^sub>t B \<Longrightarrow> \<Gamma> \<Longrightarrow>\<^sub>t \<Gamma> * B"
  using match_firstt by fastforce

lemma match_first: "A \<Longrightarrow>\<^sub>A B \<Longrightarrow> \<Gamma> * A \<Longrightarrow>\<^sub>A \<Gamma> * B"
  by (simp add: assn_times_comm entails_frame)

lemma match_rest: "emp \<Longrightarrow>\<^sub>A B \<Longrightarrow> \<Gamma> \<Longrightarrow>\<^sub>A \<Gamma> * B"
  using match_first by fastforce

lemma run_and_execute: "(\<forall>\<sigma> t r. run c (Some h) \<sigma> r t \<longrightarrow> \<sigma> \<noteq> None \<and> P (the \<sigma>) r t)
        \<longleftrightarrow> (\<exists>h' t r. execute c h = Some (r, h', t) \<and> P h' r t)"
  apply rule
  subgoal by (metis option.sel run.intros(2) run.intros(3) timeFrame.elims)
  subgoal by (metis (mono_tags) not_None_eq option.sel prod.sel(1) prod.sel(2) run_to_execute)
  done

subsection "Simplifier setup"

lemma is_entails: "P\<Longrightarrow>\<^sub>AQ \<Longrightarrow> P \<Longrightarrow>\<^sub>AQ" .

text {* Used by existential quantifier extraction tactic *}
lemma enorm_exI': (* Incomplete, as chosen x may depend on heap! *)
  "(\<And>x. Z x \<longrightarrow> (P \<Longrightarrow>\<^sub>A Q x)) \<Longrightarrow> (\<exists>x. Z x) \<longrightarrow> (P \<Longrightarrow>\<^sub>A (\<exists>\<^sub>Ax. Q x))"
  by (metis ent_ex_postI)

lemma s: "(\<exists>\<^sub>Ax. Q x) * R = (\<exists>\<^sub>Ax. Q x * R)" by auto
lemma f: "\<up> a * \<up> b = \<up> (a \<and> b)"
  by (simp add: pure_conj)

lemma ent_false: "false \<Longrightarrow>\<^sub>A P" by simp
lemmas solve_ent_preprocess_simps =
  ent_pure_post_iff ent_pure_post_iff_sng ent_pure_pre_iff ent_pure_pre_iff_sng
lemmas ent_refl = entails_triv
lemmas ent_triv = ent_true ent_false
lemmas norm_assertion_simps = assn_one_left  time_credit_add[symmetric] s f

(*
theorem solve_ent_preprocess_simps:
            (?P \<Longrightarrow>\<^sub>A ?Q * \<up> ?b) = ((\<forall>h. h \<Turnstile> ?P \<longrightarrow> ?b) \<and> (?P \<Longrightarrow>\<^sub>A ?Q))
            (?P \<Longrightarrow>\<^sub>A \<up> ?b) = ((\<forall>h. h \<Turnstile> ?P \<longrightarrow> ?b) \<and> (?P \<Longrightarrow>\<^sub>A emp))
            (?P * \<up> ?b \<Longrightarrow>\<^sub>A ?Q) = (?b \<longrightarrow> (?P \<Longrightarrow>\<^sub>A ?Q))
            (\<up> ?b \<Longrightarrow>\<^sub>A ?Q) = (?b \<longrightarrow> (emp \<Longrightarrow>\<^sub>A ?Q)) *)

subsection {* Frame Matcher *}
text {* Given star-lists P,Q and a frame F, this method tries to match
  all elements of Q with corresponding elements of P. The result is a
  partial match, that contains matching pairs and the unmatched content.*}

text {* The frame-matcher internally uses syntactic lists separated by
  star, and delimited by the special symbol @{text "SLN"}, which is defined
  to be @{text "emp"}. *}
definition [simp]: "SLN \<equiv> emp"
lemma SLN_left: "SLN * P = P" by simp
lemma SLN_right: "P * SLN = P" by simp

lemmas SLN_normalize = SLN_right mult.assoc[symmetric, where 'a=assn]
lemmas SLN_strip = SLN_right SLN_left mult.assoc[symmetric, where 'a=assn]

text {* A query to the frame matcher. Contains the assertions
  P and Q that shall be matched, as well as a frame F, that is not
  touched. *}

definition [simp]: "FI_QUERY P Q F \<equiv> P \<Longrightarrow>\<^sub>A Q*F"

abbreviation "fi_m_fst M \<equiv> foldr (( * )) (map fst M) emp"
abbreviation "fi_m_snd M \<equiv> foldr (( * )) (map snd M) emp"
abbreviation "fi_m_match M \<equiv> (\<forall>(p,q)\<in>set M. p \<Longrightarrow>\<^sub>A q)"

text {* A result of the frame matcher. Contains a list of matching pairs,
  as well as the unmatched parts of P and Q, and the frame F.
*}
definition [simp]: "FI_RESULT M UP UQ F \<equiv>
  fi_m_match M \<longrightarrow> (fi_m_fst M * UP \<Longrightarrow>\<^sub>A fi_m_snd M * UQ * F)"

text {* Internal structure used by the frame matcher:
  m contains the matched pairs; p,q the assertions that still needs to be
  matched; up,uq the assertions that could not be matched; and f the frame.
  p and q are SLN-delimited syntactic lists.
*}

definition [simp]: "FI m p q up uq f \<equiv>
  fi_m_match m \<longrightarrow> (fi_m_fst m * p * up \<Longrightarrow>\<^sub>A fi_m_snd m * q * uq * f)"

text {* Initialize processing of query *}
lemma FI_init:
  assumes "FI [] (SLN*P) (SLN*Q) SLN SLN F"
  shows "FI_QUERY P Q F"
  using assms by simp

text {* Construct result from internal representation *}
lemma FI_finalize:
  assumes "FI_RESULT m (p*up) (q*uq) f"
  shows "FI m p q up uq f"
  using assms by (simp add: mult.assoc )

text {* Auxiliary lemma to show that all matching pairs together form
  an entailment. This is required for most applications. *}
lemma fi_match_entails:
  assumes "fi_m_match m"
  shows "fi_m_fst m \<Longrightarrow>\<^sub>A fi_m_snd m"
  using assms apply (induct m)
  apply (simp_all split: prod.split_asm add: ent_star_mono)
  done

text {* Internally, the frame matcher tries to match the first assertion
  of q with the first assertion of p. If no match is found, the first
  assertion of p is discarded. If no match for any assertion in p can be
  found, the first assertion of q is discarded. *}

text {* Match *}
lemma FI_match:
  assumes "p \<Longrightarrow>\<^sub>A q"
  assumes "FI ((p,q)#m) (ps*up) (qs*uq) SLN SLN f"
  shows "FI m (ps*p) (qs*q) up uq f"
  using assms unfolding FI_def
  apply (simp add: mult.assoc)
  by (simp add: mult.left_commute)

text {* No match *}
lemma FI_p_nomatch:
  assumes "FI m ps (qs*q) (p*up) uq f"
  shows "FI m (ps*p) (qs*q) up uq f"
  using assms unfolding FI_def
  by (simp add: mult.assoc)

text {* Head of q could not be matched *}
lemma FI_q_nomatch:
  assumes "FI m (SLN*up) qs SLN (q*uq) f"
  shows "FI m SLN (qs*q) up uq f"
  using assms unfolding FI_def
  by (simp add: mult.assoc)

subsection {* Frame Inference *}
lemma frame_inference_init:
  assumes "FI_QUERY P Q F"
  shows "P \<Longrightarrow>\<^sub>A Q * F"
  using assms by simp

lemma frame_inference_finalize:
  shows "FI_RESULT M F emp F"
  apply simp
  apply rule
  apply (drule fi_match_entails)
  apply (rule ent_star_mono[OF _ ent_refl])
  apply assumption
  done

subsection {* Frame Inference *}

definition [simp]: "TI_QUERY P Q F \<equiv> P = Q + F"
lemma TI_QUERYD: "P = Q + F \<Longrightarrow> TI_QUERY P Q F" by simp

lemma timeframe_inference_init:
  assumes
      "FI_QUERY P Q FH"   (* first do frame inference in order to instatiate schematics! *)
      "TI_QUERY T T' FT"
      "F = FH * $FT"
  shows "P * $T\<Longrightarrow>\<^sub>A (Q * F) * $T'"
  using assms apply (simp add: time_credit_add mult.assoc)
  apply(rotater) apply rotater apply rotatel apply rotatel apply(rule match_first)  apply rotatel apply (rule match_first)
  .

lemma timeframe_inference_init_normalize:
 "emp * $T\<Longrightarrow>\<^sub>A F * $T' \<Longrightarrow> $T\<Longrightarrow>\<^sub>A F * $T'"
  by auto

lemma dollarD: "a = b \<Longrightarrow> $a \<Longrightarrow>\<^sub>A $b"
  by simp

subsection {* Entailment Solver *}
lemma entails_solve_init:
  "FI_QUERY P (Q*$T) true \<Longrightarrow> P \<Longrightarrow>\<^sub>A Q * true * $T"
  "FI_QUERY P Q true \<Longrightarrow> P \<Longrightarrow>\<^sub>A Q * true"
  "FI_QUERY P Q emp \<Longrightarrow> P \<Longrightarrow>\<^sub>A Q"
    apply (simp_all add: mult.assoc )
  by (simp add:  mult.commute)

lemma entails_solve_init_time:
  "FI_QUERY P (Q) true \<Longrightarrow> TI_QUERY T T' FT \<Longrightarrow>  P * $T \<Longrightarrow>\<^sub>A Q * true * $T'"
  apply simp
    by (smt ent_star_mono gc_time le_add1 linordered_field_class.sign_simps(5) linordered_field_class.sign_simps(6) merge_true_star_ctx)

lemma entails_solve_finalize:
  "FI_RESULT M P emp true"
  "FI_RESULT M emp emp emp"
  by (auto simp add: fi_match_entails intro: ent_star_mono)

named_theorems sep_dflt_simps "Seplogic: Default simplification rules for automated solvers"
named_theorems sep_eintros "Seplogic: Intro rules for entailment solver"
named_theorems sep_heap_rules "Seplogic: VCG heap rules"
named_theorems sep_decon_rules "Seplogic: VCG deconstruct rules"

ML \<open>
infix 1 THEN_IGNORE_NEWGOALS

structure Seplogic_Auto =
struct

  (***********************************)
  (*          Method Setup           *)
  (***********************************)

  val dflt_simps_modifiers = [
    Args.$$$ "dflt_simps" -- Scan.option Args.add -- Args.colon
      >> K (Method.modifier (Named_Theorems.add @{named_theorems sep_dflt_simps}) \<^here>),
    Args.$$$ "dflt_simps" -- Scan.option Args.del -- Args.colon
      >> K (Method.modifier (Named_Theorems.del @{named_theorems sep_dflt_simps}) \<^here>)
  ];
  val heap_modifiers = [
    Args.$$$ "heap" -- Scan.option Args.add -- Args.colon
      >> K (Method.modifier (Named_Theorems.add @{named_theorems sep_heap_rules}) \<^here>),
    Args.$$$ "heap" -- Scan.option Args.del -- Args.colon
      >> K (Method.modifier (Named_Theorems.del @{named_theorems sep_heap_rules}) \<^here>)
  ];
  val decon_modifiers = [
    Args.$$$ "decon" -- Scan.option Args.add -- Args.colon
      >> K (Method.modifier (Named_Theorems.add @{named_theorems sep_decon_rules}) \<^here>),
    Args.$$$ "decon" -- Scan.option Args.del -- Args.colon
      >> K (Method.modifier (Named_Theorems.del @{named_theorems sep_decon_rules}) \<^here>)
  ];

  val eintros_modifiers = [
    Args.$$$ "eintros" -- Scan.option Args.add -- Args.colon
      >> K (Method.modifier (Named_Theorems.add @{named_theorems sep_eintros}) \<^here>),
    Args.$$$ "eintros" -- Scan.option Args.del -- Args.colon
      >> K (Method.modifier (Named_Theorems.del @{named_theorems sep_eintros}) \<^here>)
  ];

  val solve_entails_modifiers = dflt_simps_modifiers @ eintros_modifiers;

  val vcg_modifiers =
    heap_modifiers @ decon_modifiers @ dflt_simps_modifiers;

  val sep_auto_modifiers =
    clasimp_modifiers @ vcg_modifiers @ eintros_modifiers;

  (***********************************)
  (*        Custom Tacticals         *)
  (***********************************)

  (* Apply tac1, and then tac2 with an offset such that anything left
     over by tac1 is skipped.

     The typical usage of this tactic is, if a theorem is instantiated
     with another theorem that produces additional goals that should
     be ignored first. Here, it is used in the vcg to ensure that
     frame inference is done before additional premises (that may
     depend on the frame) are discharged.
  *)
  fun (tac1 THEN_IGNORE_NEWGOALS tac2) i st = let
    val np = Thm.nprems_of st
  in
    (tac1 i THEN (fn st' => let val np' = Thm.nprems_of st' in
      if np'<np then tac2 i st'
      else tac2 (i+(np'-np)+1) st'
    end)) st
  end;

  (***********************************)
  (*     Assertion Normalization     *)
  (***********************************)
  (* Find two terms in a list whose key is equal *)
  fun find_similar (key_of:term -> term) (ts:term list) = let
    fun frec _ [] = NONE
    | frec tab (t::ts) = let val k=key_of t in
      if Termtab.defined tab k then
        SOME (the (Termtab.lookup tab k),t)
      else frec (Termtab.update (k,t) tab) ts
    end
  in
    frec Termtab.empty ts
  end;

  (* Perform DFS over term with binary operator opN, threading through
    a state. Atomic terms are transformed by tr. Supports omission of
    terms from the result structure by transforming them to NONE. *)
  fun dfs_opr opN (tr:'state -> term -> ('state*term option))
    d (t as ((op_t as Const (fN,_))$t1$t2)) =
    if fN = opN then let
        val (d1,t1') = dfs_opr opN tr d t1;
        val (d2,t2') = dfs_opr opN tr d1 t2;
      in
        case (t1',t2') of
          (NONE,NONE) => (d2,NONE)
        | (SOME t1',NONE) => (d2,SOME t1')
        | (NONE,SOME t2') => (d2,SOME t2')
        | (SOME t1',SOME t2') => (d2,SOME (op_t$t1'$t2'))
      end
    else tr d t
  | dfs_opr _ tr d t = tr d t;

  (* Replace single occurrence of (atomic) ot in t by nt.
    Returns new term or NONE if nothing was removed. *)
  fun dfs_replace_atomic opN ot nt t = let
    fun tr d t = if not d andalso t=ot then (true,SOME nt) else (d,SOME t);
    val (success,SOME t') = dfs_opr opN tr false t;
  in
    if success then SOME t' else NONE
  end;

  fun assn_simproc_fun ctxt credex = let
    val ([redex],ctxt') = Variable.import_terms true [Thm.term_of credex] ctxt;
    (*val _ = tracing (tr_term redex);*)
    val export = singleton (Variable.export ctxt' ctxt)

    fun mk_star t1 t2 = @{term "( * )::assn \<Rightarrow> _ \<Rightarrow> _"}$t2$t1;

    fun mk_star' NONE NONE = NONE
    | mk_star' (SOME t1) NONE  = SOME t1
    | mk_star' NONE (SOME t2) = SOME t2
    | mk_star' (SOME t1) (SOME t2) = SOME (mk_star t1 t2);

    fun ptrs_key (_$k$_) = k;

    fun remove_term pt t = case
      dfs_replace_atomic @{const_name "Groups.times_class.times"} pt
        @{term emp} t
    of
      SOME t' => t';

    fun normalize t = let

      fun ep_tr (has_true,ps,ts,ptrs) t = case t of
        Const (@{const_name "pure_assn"},_)$_
        => ((has_true,t::ps,ts,ptrs),NONE)
      | Const (@{const_name "sngr_assn"},_)$_$_
        => ((has_true,ps,ts,t::ptrs),SOME t)
      | Const (@{const_name "snga_assn"},_)$_$_
        => ((has_true,ps,ts,t::ptrs),SOME t)
      | Const (@{const_name "timeCredit_assn"},_)$_
        => let val _ = () (* tracing ("aha") *); in ((has_true,ps,t::ts,ptrs),NONE) end
      | Const (@{const_name "top_assn"},_)
        => ((true,ps,ts,ptrs),NONE)
      | (inf_op as Const (@{const_name "and_assn"},_))$t1$t2
        => ((has_true,ps,ts,ptrs),SOME (inf_op$normalize t1$normalize t2))
      | _ => ((has_true,ps,ts,ptrs),SOME t);

      fun normalizer t = case dfs_opr @{const_name "Groups.times_class.times"}
        ep_tr (false,[],[],[]) t
      of
        ((has_true,ps,ts,ptrs),rt) => let val _ = () (* tracing ("aha1") *); in
            ((has_true,rev ps,rev ts,ptrs),rt)end;

      fun normalize_core t = let
        val ((has_true,pures,tis,ptrs),rt) = normalizer t;
        val similar = find_similar ptrs_key ptrs;
        val true_t = if has_true then SOME @{term "top_assn"}
          else NONE;
        val pures' = case pures of
            [] => NONE
          | p::ps => SOME (fold mk_star ps p);
        val tis' = case tis of
            [] => NONE
          | p::ps => SOME (fold mk_star ps p);
      in
        case similar of NONE => the ((mk_star' pures' (mk_star' tis' (mk_star' true_t rt))) )
        | SOME (t1,t2) => let
            val t_stripped = remove_term t1 (remove_term t2 t);
          in mk_star t_stripped (mk_star t1 t2) end
      end;

      fun skip_ex ((exq as Const (@{const_name "ex_assn"},_))$(Abs (n,ty,t))) =
        exq$Abs (n,ty,skip_ex t)
      | skip_ex t = normalize_core t;

      val (bs,t') = strip_abs t;
      val ty = fastype_of1 (map #2 bs,t');
    in
      if ty = @{typ assn} then
        Logic.rlist_abs (bs,skip_ex t')
      else t
    end;

    (*val _ = tracing (tr_term redex);*)
    val (f,terms) = strip_comb redex;
    val nterms = map (fn t => let
        (*val _ = tracing (tr_term t); *)
        val t'=normalize t;
        (*val _ = tracing (tr_term t');*)
      in t' end) terms;
    val new_form = list_comb (f,nterms);

    val res_ss = (put_simpset HOL_basic_ss ctxt addsimps @{thms star_aci});
    val result = Option.map (export o mk_meta_eq) (Arith_Data.prove_conv_nohyps
      [simp_tac res_ss 1] ctxt' (redex,new_form)
    );

  in
    result
  end handle exc =>
    if Exn.is_interrupt exc then Exn.reraise exc
    else
      (tracing ("assn_simproc failed with exception\n:" ^ Runtime.exn_message exc);
        NONE) (* Fail silently *);

  val assn_simproc =
    Simplifier.make_simproc @{context} "assn_simproc"
     {lhss =
      [@{term "h \<Turnstile> P"},
       @{term "P \<Longrightarrow>\<^sub>A Q"},
       @{term "P \<Longrightarrow>\<^sub>t Q"} ,
       @{term "hoare_triple P c Q"} (*,
       @{term "(P::assn) = Q"} *)],
      proc = K assn_simproc_fun};

  (***********************************)
  (*     Default Simplifications     *)
  (***********************************)

  (* Default simplification. MUST contain assertion normalization!
    Tactic must not fail! *)
  fun dflt_tac ctxt = asm_full_simp_tac
    (put_simpset HOL_ss ctxt
      addsimprocs [assn_simproc]
      addsimps @{thms norm_assertion_simps}
      addsimps (Named_Theorems.get ctxt @{named_theorems sep_dflt_simps})
      |> fold Splitter.del_split @{thms if_split}
    );

  (***********************************)
  (*         Frame Matcher           *)
  (***********************************)

  (* Do frame matching
    imp_solve_tac - tactic used to discharge first assumption of match-rule
      cf. lemma FI_match.
  *)
  fun match_frame_tac imp_solve_tac ctxt = let
    (* Normalize star-lists *)
    val norm_tac = simp_tac (
      put_simpset HOL_basic_ss ctxt addsimps @{thms SLN_normalize});

    (* Strip star-lists *)
    val strip_tac =
      simp_tac (put_simpset HOL_basic_ss ctxt addsimps @{thms SLN_strip}) THEN'
      simp_tac (put_simpset HOL_basic_ss ctxt addsimps @{thms SLN_def});

    (* Do a match step *)
    val match_tac = resolve_tac ctxt @{thms FI_match} (* Separate p,q*)
      THEN' SOLVED' imp_solve_tac (* Solve implication *)
      THEN' norm_tac;

    (* Do a no-match step *)
    val nomatch_tac = resolve_tac ctxt @{thms FI_p_nomatch} ORELSE'
      (resolve_tac ctxt @{thms FI_q_nomatch} THEN' norm_tac);
  in
    resolve_tac ctxt @{thms FI_init} THEN' norm_tac
    THEN' REPEAT_DETERM' (FIRST' [
      CHANGED o dflt_tac ctxt,
      (match_tac ORELSE' nomatch_tac)])
    THEN' resolve_tac ctxt @{thms FI_finalize} THEN' strip_tac
  end;

  (***********************************)
  (*         Frame Inference         *)
  (***********************************)

  fun frame_inference_tac ctxt =
    resolve_tac ctxt @{thms frame_inference_init}
    THEN' match_frame_tac (resolve_tac ctxt @{thms ent_refl}) ctxt
    THEN' resolve_tac ctxt @{thms frame_inference_finalize};

  (***********************************)
  (* Nat splitter  powerd by auto2   *)
  (***********************************)

  fun mytac ctxt a b = let   val _ = tracing (Syntax.string_of_term ctxt a);
              val _ = tracing (Syntax.string_of_term ctxt b)
              val _ = tracing ("ole")
      val ths = map snd (SepTimeSteps.split_nat ctxt ([], (a, b)));
      val _ = length ths
      val _ =  let fun print thm = tracing (Thm.string_of_thm ctxt thm)
          in map print ths end
      val ths = map snd (SepTimeSteps.split_nat ctxt ([], (a, b)));
   in
         (if length ths > 0 then  (EqSubst.eqsubst_tac ctxt [1] ths
              THEN' FIRST' [ resolve_tac ctxt @{thms refl},
                             SOLVED' (simp_tac (put_simpset HOL_ss ctxt  addsimps @{thms mult.commute})) ] ) 1  else no_tac) end

  fun split_nat_tac ctxt = Subgoal.FOCUS_PARAMS (fn {context = ctxt, ...} => ALLGOALS (
        SUBGOAL (fn (t, _) => case Logic.strip_imp_concl t of
          @{mpat "Trueprop (?a = ?b + _)"} =>
            mytac ctxt a b
         |  _ => no_tac
        ))
      ) ctxt

  (***********************************)
  (*         Time Frame Inference   *)
  (***********************************)

  fun time_frame_inference_tac ctxt =
  let val _ = tracing "what"
  in
    (fn _ => let val _ = tracing "aha0" in all_tac end)
    THEN'
    TRY o resolve_tac ctxt @{thms timeframe_inference_init_normalize}
    THEN' (fn _ => let val _ = tracing "aha1" in all_tac end)
    THEN'
    resolve_tac ctxt @{thms timeframe_inference_init}
    (* normal frame inference *)
    THEN' match_frame_tac (resolve_tac ctxt @{thms ent_refl}) ctxt
    THEN' resolve_tac ctxt @{thms frame_inference_finalize}
    THEN' (fn _ => let val _ = tracing "aha2" in all_tac end)
    (* time_frame inference *)
    THEN'  TRY o (EqSubst.eqsubst_tac ctxt [0] @{thms One_nat_def[symmetric]} )
    THEN'  TRY o (REPEAT_DETERM' (EqSubst.eqsubst_tac ctxt [0] @{thms Suc_eq_plus1} ))
    THEN' (fn _ => let val _ = tracing "aha" in all_tac end)

    THEN' (resolve_tac ctxt @{thms TI_QUERYD})
    THEN' SOLVED' (split_nat_tac ctxt)

    THEN' resolve_tac ctxt @{thms refl}
end
    ;

  (***********************************)
  (*       Entailment Solver         *)
  (***********************************)

  (* Extract existential quantifiers from entailment goal *)
  fun extract_ex_tac ctxt i st = let
    fun count_ex (Const (@{const_name SepAuto.entails},_)$_$c) =
      count_ex c RS @{thm HOL.mp}
    | count_ex (Const (@{const_name SepAuto.ex_assn},_)$Abs (_,_,t))
      = count_ex t RS @{thm enorm_exI'}
    | count_ex _ = @{thm imp_refl};

    val concl = Logic.concl_of_goal (Thm.prop_of st) i |> HOLogic.dest_Trueprop;
    val thm = count_ex concl;
    val _ = tracing (Thm.string_of_thm ctxt thm);
  in
    (TRY o REPEAT_ALL_NEW (match_tac ctxt @{thms ent_ex_preI}) THEN'
     resolve_tac ctxt [thm]) i st
  end;

  fun atom_solve_tac ctxt =
        FIRST' [ resolve_tac ctxt @{thms ent_refl},
                 SOLVED' ( resolve_tac ctxt @{thms dollarD} THEN'
                             (SELECT_GOAL (auto_tac ctxt))  )
               ]

  (* Solve Entailment *)
  fun solve_entails_tac ctxt = let
    val preprocess_entails_tac =
      dflt_tac ctxt
      THEN' extract_ex_tac ctxt
      THEN' simp_tac
        (put_simpset HOL_ss ctxt addsimps @{thms solve_ent_preprocess_simps});

    val match_entails_tac =
      FIRST' [

      resolve_tac ctxt @{thms entails_solve_init_time}
      THEN' match_frame_tac (atom_solve_tac ctxt)  ctxt
      THEN' resolve_tac ctxt @{thms entails_solve_finalize}
      THEN'  TRY o (EqSubst.eqsubst_tac ctxt [0] @{thms One_nat_def[symmetric]} )
      THEN'  TRY o (REPEAT_DETERM' (EqSubst.eqsubst_tac ctxt [0] @{thms Suc_eq_plus1} ))

      THEN' (resolve_tac ctxt @{thms TI_QUERYD})
      THEN' SOLVED' (split_nat_tac ctxt),

      resolve_tac ctxt @{thms entails_solve_init}
      THEN' match_frame_tac (atom_solve_tac ctxt)  ctxt
      THEN' resolve_tac ctxt @{thms entails_solve_finalize}
       ];
  in
    preprocess_entails_tac
    THEN' (TRY o
      REPEAT_ALL_NEW (match_tac ctxt (rev (Named_Theorems.get ctxt @{named_theorems sep_eintros}))))
    THEN_ALL_NEW (  dflt_tac ctxt THEN'
      TRY o (match_tac ctxt @{thms ent_triv}
        ORELSE' resolve_tac ctxt @{thms ent_refl}
        ORELSE' match_entails_tac))
  end;

  (***********************************)
  (* Verification Condition Generator*)
  (***********************************)

  fun heap_rule_tac ctxt h_thms =
    resolve_tac ctxt h_thms ORELSE' (
    resolve_tac ctxt @{thms fi_rule} THEN' (resolve_tac ctxt h_thms THEN_IGNORE_NEWGOALS
    ( dflt_tac ctxt THEN'  time_frame_inference_tac ctxt) ))

  (* Apply consequence rule if postcondition is not a schematic var *)
  fun app_post_cons_tac ctxt i st =
    case Logic.concl_of_goal (Thm.prop_of st) i |> HOLogic.dest_Trueprop of
      Const (@{const_name hoare_triple},_)$_$_$qt =>
        if is_Var (head_of qt) then no_tac st
        else resolve_tac ctxt @{thms cons_post_rule} i st
    | _ => no_tac st;

  fun vcg_step_tac ctxt = let
    val h_thms = rev (Named_Theorems.get ctxt @{named_theorems sep_heap_rules});
    val d_thms = rev (Named_Theorems.get ctxt @{named_theorems sep_decon_rules});
    val heap_rule_tac = heap_rule_tac ctxt h_thms

  in
    CSUBGOAL (snd #> (FIRST' [
      CHANGED o dflt_tac ctxt,
      REPEAT_ALL_NEW (resolve_tac ctxt @{thms normalize_rules}),
      CHANGED o (FIRST' [resolve_tac ctxt d_thms, heap_rule_tac]
        ORELSE' (app_post_cons_tac ctxt THEN'
          FIRST' [resolve_tac ctxt d_thms, heap_rule_tac]))
    ]))
  end;
  fun vcg_tac ctxt = REPEAT_DETERM' (  vcg_step_tac ctxt)

  (***********************************)
  (*        Automatic Solver         *)
  (***********************************)

  fun sep_autosolve_tac do_pre do_post ctxt = let
    val _ = tracing ("ole")
    val pre_tacs = [
      CHANGED o (clarsimp_tac ctxt),
      CHANGED o (REPEAT_ALL_NEW (match_tac ctxt @{thms ballI allI impI conjI}))
    ];
    val main_tacs = [
      match_tac ctxt @{thms is_hoare_triple} THEN' CHANGED o vcg_tac ctxt,
      match_tac ctxt @{thms is_entails} THEN' CHANGED o solve_entails_tac ctxt
    ];
    val post_tacs = [   SELECT_GOAL (auto_tac ctxt)];
    val tacs = (if do_pre then pre_tacs else [])
      @ main_tacs
      @ (if do_post then post_tacs else []);
  in
    REPEAT_DETERM' (CHANGED o FIRST' tacs)
  end;

end; \<open>struct\<close>

\<close>
method_setup vcgba = {*
  Scan.lift (Args.mode "ss") --
  Method.sections Seplogic_Auto.vcg_modifiers >>
  (fn (ss,_) => fn ctxt => SIMPLE_METHOD' (
  CHANGED o (
    if ss then Seplogic_Auto.vcg_step_tac ctxt
    else Seplogic_Auto.vcg_tac ctxt
  )
)) *} "Seplogic: Verification Condition Generator"

method_setup vcg = {*
  Scan.lift (Args.mode "ss") --
  Method.sections Seplogic_Auto.vcg_modifiers >>
  (fn (ss,_) => fn ctxt => SIMPLE_METHOD' (
  CHANGED o (
    if ss then Seplogic_Auto.vcg_step_tac ctxt
    else Seplogic_Auto.vcg_tac ctxt
  )
)) *} "Seplogic: Verification Condition Generator"

method_setup sep_auto =
  {* Scan.lift (Args.mode "nopre" -- Args.mode "nopost" -- Args.mode "plain")
      --| Method.sections Seplogic_Auto.sep_auto_modifiers >>
  (fn ((nopre,nopost),plain) => fn ctxt => SIMPLE_METHOD' (
    CHANGED o Seplogic_Auto.sep_autosolve_tac
      ((not nopre) andalso (not plain))
      ((not nopost) andalso (not plain)) ctxt
  )) *} "Seplogic: Automatic solver"

method_setup solve_entails = {*
  Method.sections Seplogic_Auto.solve_entails_modifiers >>
  (fn _ => fn ctxt => SIMPLE_METHOD' (
  CHANGED o Seplogic_Auto.solve_entails_tac ctxt
)) *} "Seplogic: Entailment Solver"

method_setup timeframeinf = {*
  Method.sections Seplogic_Auto.solve_entails_modifiers >>
  (fn _ => fn ctxt => SIMPLE_METHOD' (
  CHANGED o Seplogic_Auto.time_frame_inference_tac ctxt
)) *} "Seplogic: Frame Inference with Time Inference"

simproc_setup assn_simproc
  ( "h \<Turnstile> P" | "P\<Longrightarrow>\<^sub>AQ" | "P\<Longrightarrow>\<^sub>tQ" | "(P::assn) = Q" )
  = {*K Seplogic_Auto.assn_simproc_fun*}

lemma " P * $ 0 \<Longrightarrow>\<^sub>A P * true "
  by (solve_entails)

lemma " P * $ 1 \<Longrightarrow>\<^sub>A P * true * $ 1"
  by (solve_entails)

thm enorm_exI'
lemma "QA \<Longrightarrow> (P \<Longrightarrow>\<^sub>A \<exists>\<^sub>Ax. Q x)"
      apply(tactic \<open>IF_EXGOAL (Seplogic_Auto.extract_ex_tac @{context}) 1\<close>)
  oops

lemma "\<And>x. x \<mapsto>\<^sub>a replicate (N * M) 0 * timeCredit_assn ((M * N * 9))  * timeCredit_assn (2) \<Longrightarrow>\<^sub>A x \<mapsto>\<^sub>a replicate (N * M) 0 * timeCredit_assn (Suc (Suc (9 * (N * M))))"
  by (solve_entails)

declare entt_refl' [simp]

lemma "\<And>x. M = 0 \<Longrightarrow> (\<And>j i. c (i, j) = 0) \<Longrightarrow> x \<mapsto>\<^sub>a [] \<Longrightarrow>\<^sub>A \<exists>\<^sub>Al. x \<mapsto>\<^sub>a l * true * \<up> (l = []) "
  apply(sep_auto)
  done

schematic_goal "timeCredit_assn (B* A * 10 + 3) \<Longrightarrow>\<^sub>A ?F1 * timeCredit_assn (B* A + 1)"
  by timeframeinf

(* timeframeinf can solve problems of that form: A * $T \<Longrightarrow>\<^sub>A B * ?F * $T' *)
schematic_goal "\<up> (i < length xs) * a \<mapsto>\<^sub>a xs *  $2  \<Longrightarrow>\<^sub>A a \<mapsto>\<^sub>a xs * ?F * $1"
  by timeframeinf

schematic_goal "A * C * $2  \<Longrightarrow>\<^sub>A A * ?F * $1"
  by timeframeinf

schematic_goal "a \<mapsto>\<^sub>a xs * $ 1 \<Longrightarrow>\<^sub>A a \<mapsto>\<^sub>a xs * ?F24 (xs ! i)   * $ 1"
  by timeframeinf

context begin
  definition "fffa = (10::nat)"

  schematic_goal "(3::nat) + 3 * fffa + 6 * 7 = 1 + ?F"
    apply(tactic \<open>Seplogic_Auto.split_nat_tac @{context} 1\<close>)
    done

  schematic_goal "(2::nat) + 3 * fffa  = 1 + ?F"
    apply(tactic \<open>Seplogic_Auto.split_nat_tac @{context} 1\<close>)
    done
end

thm sep_eintros

lemma ureturn_rule[sep_decon_rules]: "<P> ureturn x <\<lambda>r. P * \<up>(r = x)>"
  apply(rule post_rule)
  apply(rule pre_rule[rotated])
    apply(rule frame_rule[OF return_rule, where R=P] )
  by(auto simp: zero_time)

declare SepAuto.return_rule [sep_heap_rules]
declare bind_rule [sep_decon_rules]

(* sep auto expects pure assertions to be pulled out in the pre condition TODO: is this correct? *)
lemma nth_rule'[sep_heap_rules]: "(i < length xs) \<Longrightarrow> <a \<mapsto>\<^sub>a xs * $ 1 > Array.nth a i <\<lambda>r. a \<mapsto>\<^sub>a xs * \<up> (r = xs ! i)>"
  apply(rule pre_rule[OF _ nth_rule]) by sep_auto

declare new_rule [sep_heap_rules]
thm new_rule
schematic_goal "<timeCredit_assn 1> Array.new 0 0 <?Q8>"
  by(sep_auto simp del: add_Suc One_nat_def)

lemma "A \<Longrightarrow>\<^sub>A A"
  by solve_entails

lemma "A * B \<Longrightarrow>\<^sub>A A * true"
  by solve_entails

lemma "A * B * C \<Longrightarrow>\<^sub>A B * A * true"
  by solve_entails

lemma hand_commute[simp]: "A \<and>\<^sub>A B = B \<and>\<^sub>A A"
using ent_conjE1 ent_conjE2 ent_conjI ent_iffI by auto

lemma and_extract_pure_left_iff[simp]: "\<up>b \<and>\<^sub>A Q = (emp\<and>\<^sub>AQ)*\<up>b"
  by (cases b) auto

lemma and_extract_pure_left_ctx_iff[simp]: "P*\<up>b \<and>\<^sub>A Q = (P\<and>\<^sub>AQ)*\<up>b"
  by (cases b) auto

lemma and_extract_pure_right_iff[simp]: "P \<and>\<^sub>A \<up>b = (emp\<and>\<^sub>AP)*\<up>b"
  by (cases b) (auto simp: hand_commute)

lemma and_extract_pure_right_ctx_iff[simp]: "P \<and>\<^sub>A Q*\<up>b = (P\<and>\<^sub>AQ)*\<up>b"
  by (cases b) auto

lemma "h \<Turnstile> F * \<up> (a' = None) * F' \<Longrightarrow> G" apply simp oops
lemma "true * true = G" apply simp oops
lemma "G * true * F * true = H"  apply (simp )  oops

lemma "$a * $b = $(a+b)"
  by (simp add: time_credit_add)

lemma "$1* \<up>g * G * $2 * $3 *true * F * true * \<up>ff * $4 * $5 = G * F * true * $ 10 * (\<up> g *  $5 * \<up> ff)"
  by (simp add :time_credit_add[symmetric] )

lemma "G * \<up>ff * true *  F   = H"  apply (simp )   oops

lemma "h \<Turnstile> F \<and>\<^sub>A \<up> (a' = None) * F' \<Longrightarrow> G" apply simp oops

lemma "h \<Turnstile> \<up>t * (F \<and>\<^sub>A \<up> (a' = None) * F') * X \<Longrightarrow> G" apply (simp del:  ) oops

lemma p_c[simp]: "\<up> P * \<up> Q = \<up> (P \<and> Q)" using pure_conj by simp

lemma "\<up>a * B * \<up>c \<Longrightarrow>\<^sub>A G" apply (simp add:  del: pure_conj) oops

lemma "\<exists>\<^sub>Ab. \<up> ((b, a) \<in> R) *C *\<up>a \<Longrightarrow>\<^sub>A emp" apply simp oops

declare mod_ex_dist [simp]
declare pure_assn_rule [simp]

thm ent_ex_preI ent_ex_postI

text {* Apply precision rule with frame inference. *}
lemma prec_frame:
  assumes PREC: "precise P"
  assumes M1: "h\<Turnstile>(R1 \<and>\<^sub>A R2)"
  assumes F1: "R1 \<Longrightarrow>\<^sub>A P x p * F1"
  assumes F2: "R2 \<Longrightarrow>\<^sub>A P y p * F2"
  shows "x=y"
  using preciseD[OF PREC] M1 F1 F2
  by (meson mod_and_dist entailsD)

thm false_absorb

lemma upd_rule'[sep_heap_rules]: "i < length xs \<Longrightarrow> <a \<mapsto>\<^sub>a xs * timeCredit_assn 1 > Array.upd i x a <\<lambda>r. a \<mapsto>\<^sub>a xs[i := x] * \<up> (r = a)>"
  apply(rule pre_rule[OF _ upd_rule])
  by solve_entails

lemma "\<And>x. x \<mapsto>\<^sub>a replicate (N * M) 0 * timeCredit_assn ((M * N * 9))  * timeCredit_assn (2) \<Longrightarrow>\<^sub>A x \<mapsto>\<^sub>a replicate (N * M) 0 * timeCredit_assn (Suc (Suc (9 * (N * M))))"
  by (sep_auto)

lemma "\<And>x. x \<mapsto>\<^sub>a replicate (N * M) 0 * timeCredit_assn ((M * N * 9))  * timeCredit_assn (2) \<Longrightarrow>\<^sub>A x \<mapsto>\<^sub>a replicate (N * M) 0 * timeCredit_assn (Suc (Suc (9 * (N * M))))"

  apply(vcg (ss))
  by (sep_auto)

lemma prod_split_rule: "(\<And>a b. x = (a, b) \<Longrightarrow> <P> f a b <Q>) \<Longrightarrow> <P> case x of (a, b) \<Rightarrow> f a b <Q>"
  by(auto split: prod.split)

lemma prod_case_simp[sep_dflt_simps]: "(case (a, b) of (c, d) \<Rightarrow> f c d) = f a b" by simp

lemma Let_rule[sep_decon_rules]: "(\<And>x. x = t \<Longrightarrow> <P> f x <Q>) \<Longrightarrow> <P> Let t f <Q>"
  by simp

lemma If_rule[sep_decon_rules]: "(b \<Longrightarrow> <P> f <Q>) \<Longrightarrow> (\<not> b \<Longrightarrow> <P> g <Q>) \<Longrightarrow> <P> if b then f else g <Q>"
  by auto
lemmas [sep_eintros] = impI conjI exI

    declare make_rule [sep_heap_rules]

lemma "P * $4 \<Longrightarrow>\<^sub>A P * true * $3"
    "P * $3 \<Longrightarrow>\<^sub>A P * true"
    "P * Q *  $(f x * 4 + 3) \<Longrightarrow>\<^sub>A Q * P * true * $(f x * 4)"
    "P * Q *  $(g y * 6 + f x * 4 + 3) \<Longrightarrow>\<^sub>A Q * P * true * $(g y * 2 + f x * 4)"
  by solve_entails+

end