section "Implementation Language"
theory impl_language
  imports Main
    "HOL-Library.Monad_Syntax"
  repliss_sem
begin

text "So far, we have assumed that procedure implementations are given by arbitrary state machines.
Here we define an implementation language using a shallow embedding with the monad syntax package.
"

context begin

datatype ('a,'op, 'any) io =
    WaitLocalStep bool "('a,'op, 'any) io"
  | WaitBeginAtomic "('a,'op, 'any) io"
  | WaitEndAtomic "('a,'op, 'any) io"
  | WaitNewId "'any \<Rightarrow> bool" "'any \<Rightarrow> ('a,'op, 'any) io"
  | WaitDbOperation 'op "'any \<Rightarrow> ('a,'op, 'any) io"
  | WaitReturn "'a"

function (domintros) bind :: "('a, 'op, 'any) io \<Rightarrow> ('a \<Rightarrow> ('b, 'op,'any) io) \<Rightarrow> ('b, 'op,'any) io"  where
  "bind (WaitLocalStep ok n) f = (WaitLocalStep ok (bind n f))"
| "bind (WaitBeginAtomic n) f = (WaitBeginAtomic (bind n f))"
| "bind (WaitEndAtomic n) f = (WaitEndAtomic (bind n f))"
| "bind (WaitNewId P n) f = (WaitNewId P (\<lambda>i.  bind (n i) f))"
| "bind (WaitDbOperation op n) f = (WaitDbOperation op (\<lambda>i.  bind (n i) f))"
| "bind (WaitReturn s) f = (f s)"

  by (pat_completeness, auto)
termination
  using [[show_sorts]]
proof auto
  show "bind_dom (a, b)" for a b
    by (induct a, auto simp add: bind.domintros)
qed

adhoc_overloading Monad_Syntax.bind bind

definition pause :: "(unit,'op,'any) io" where
"pause \<equiv> WaitLocalStep True (WaitReturn ())"

definition beginAtomic :: "(unit,'op,'any) io" where
"beginAtomic \<equiv> WaitBeginAtomic (WaitReturn ())"

definition endAtomic :: "(unit,'op,'any) io" where
"endAtomic \<equiv> WaitEndAtomic (WaitReturn ())"

definition newId :: "('any \<Rightarrow> bool) \<Rightarrow> ('any,'op,'any) io" where
"newId P \<equiv> WaitNewId P (\<lambda>i. WaitReturn i)"

definition call :: "'op \<Rightarrow> ('any,'op,'any) io" where
"call op \<equiv> WaitDbOperation op (\<lambda>i. WaitReturn i)"

definition return :: "'a  \<Rightarrow> ('a,'op, 'any) io" where
"return x \<equiv> WaitReturn x"

definition atomic ::"('a,'op, 'any) io \<Rightarrow> ('a,'op, 'any) io"  where
"atomic f \<equiv> do {
  beginAtomic;
  r \<leftarrow> f;
  endAtomic;
  return r
}"

definition
"skip \<equiv> return undefined"

fun toImpl :: "(('val,'op, 'val) io, 'op, 'val) procedureImpl" where
"toImpl (WaitLocalStep ok n) = LocalStep ok n"
| "toImpl (WaitBeginAtomic n) = BeginAtomic n"
| "toImpl (WaitEndAtomic n) = EndAtomic n"
| "toImpl (WaitNewId P n) = NewId (\<lambda>i. if P i then Some (n i) else None)"
| "toImpl (WaitDbOperation op n) = DbOperation op n"
| "toImpl (WaitReturn v) = Return v"

lemma toImpl_simps[simp]:
"toImpl (newId P) = NewId (\<lambda>i. if P i then Some (return i) else None)"
"toImpl (pause) = LocalStep True (return ())"
"toImpl (beginAtomic) = BeginAtomic (return ())"
"toImpl (endAtomic) = EndAtomic (return ())"
"toImpl (call op ) = DbOperation op  (\<lambda>r. return r)"
"toImpl (return x) = Return x"
  by (auto simp add: newId_def pause_def beginAtomic_def endAtomic_def call_def return_def intro!: ext split: io.splits)

lemma toImpl_bind_simps[simp]:
"\<And>P x. toImpl (newId P \<bind> x) = NewId (\<lambda>i. if P i then Some (x i) else None)"
"\<And> x. toImpl (pause \<bind> x) = LocalStep True (x ())"
"\<And> x. toImpl (beginAtomic \<bind> x) = BeginAtomic (x ())"
"\<And> x. toImpl (endAtomic \<bind> x) = EndAtomic (x ())"
"\<And> x. toImpl (call op  \<bind> x) = DbOperation op  (\<lambda>r. x r)"
  by (auto simp add: newId_def pause_def beginAtomic_def endAtomic_def call_def intro!: ext split: io.splits)

paragraph "Monad Laws"

text "We prove the typical monad laws: identity of return and associativity."

lemma return_left_ident[simp]:
  fixes x and f :: "'a \<Rightarrow> ('b,'op, 'any) io"
  shows "return x \<bind> f = f x"
  by (auto simp add: return_def)

lemma right_ident[simp]:
  fixes m :: "('a,'op, 'any) io"
  shows "(m \<bind> return) = m"
  by (induct m, auto simp add: return_def)

lemma bind_assoc[simp]:
  fixes x :: "('a,'op, 'any) io"
    and y :: "'a \<Rightarrow> ('b,'op, 'any) io"
    and z :: "'b \<Rightarrow> ('c,'op, 'any) io"
  shows "((x \<bind> y) \<bind> z) = (x \<bind> (\<lambda>a. y a \<bind> z))"
  by (induct x, auto)

lemma atomic_simp1[simp]:
"toImpl (atomic f) = BeginAtomic (f \<bind> (\<lambda>r. endAtomic \<bind> (\<lambda>_. return r)))"
  by (auto simp add: atomic_def bind_assoc)

lemma atomic_simp2[simp]:
"toImpl (atomic f \<bind> x) = BeginAtomic (f \<bind> (\<lambda>a. endAtomic \<bind> (\<lambda>b. x a)))"
  by (auto simp add: atomic_def bind_assoc)

end

end


section \<open>Basic Definitions\<close>
theory Sepref_Basic
imports
  "../ds/LLVM_DS_NArray"
  "HOL-Eisbach.Eisbach"
  Refine_Monadic_Add
  "Lib/Sepref_Misc"
  "Lib/Structured_Apply"
  Sepref_Id_Op
begin
no_notation i_ANNOT (infixr ":::\<^sub>i" 10)
no_notation CONST_INTF (infixr "::\<^sub>i" 10)

no_notation pred_K ("\<langle>_\<rangle>")

type_synonym assn = ll_assn

text \<open>
  In this theory, we define the basic concept of refinement
  from a nondeterministic program specified in the
  Isabelle Refinement Framework to an imperative deterministic one
  specified in Imperative/HOL.
\<close>

subsection {* Values on Heap *}
text \<open>We tag every refinement assertion with the tag @{text hn_ctxt}, to
  avoid higher-order unification problems when the refinement assertion
  is schematic.\<close>
definition hn_ctxt :: "('a\<Rightarrow>'c\<Rightarrow>assn) \<Rightarrow> 'a \<Rightarrow> 'c \<Rightarrow> assn"
  \<comment> \<open>Tag for refinement assertion\<close>
  where
  "hn_ctxt P a c \<equiv> P a c"

definition pure :: "('b \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> assn"
  \<comment> \<open>Pure binding, not involving the heap\<close>
  where "pure R \<equiv> (\<lambda>a c. \<up>((c,a)\<in>R))"

lemma pure_app_eq: "pure R a c = \<up>((c,a)\<in>R)" by (auto simp: pure_def)

lemma pure_eq_conv[simp]: "pure R = pure R' \<longleftrightarrow> R=R'"
  unfolding pure_def
  apply (rule iffI)
  apply safe
  apply (meson pure_assn_eq_conv)
  apply (meson pure_assn_eq_conv)
  done

lemma pure_rel_eq_false_iff: "pure R x y = sep_false \<longleftrightarrow> (y,x)\<notin>R"
  by (auto simp: pure_def sep_algebra_simps)

lemma pure_part_pure[simp]: "pure_part (pure R a c) \<longleftrightarrow> (c,a)\<in>R"
  by (simp add: pure_app_eq)

definition is_pure :: "(_ \<Rightarrow> _ \<Rightarrow> assn) \<Rightarrow> bool" where "is_pure P \<equiv> \<exists>P'. \<forall>x x'. P x x'=\<up>(P' x x')"
lemma is_pureI[intro?]:
  assumes "\<And>x x'. P x x' = \<up>(P' x x')"
  shows "is_pure P"
  using assms unfolding is_pure_def by blast

lemma is_pureE:
  assumes "is_pure P"
  obtains P' where "\<And>x x'. P x x' = \<up>(P' x x')"
  using assms unfolding is_pure_def by blast

lemma pure_pure[simp]: "is_pure (pure P)"
  unfolding pure_def by rule blast
lemma pure_hn_ctxt[intro!]: "is_pure P \<Longrightarrow> is_pure (hn_ctxt P)"
  unfolding hn_ctxt_def[abs_def] .

definition the_pure :: "('b \<Rightarrow> 'a \<Rightarrow> assn) \<Rightarrow> ('a \<times> 'b) set"
  where "the_pure P \<equiv> THE P'. \<forall>x x'. P x x'=\<up>((x',x)\<in>P')"

lemma the_pure_pure[simp]: "the_pure (pure R) = R"
  unfolding pure_def the_pure_def
  by (rule theI2[where a=R]) auto

lemma is_pure_alt_def: "is_pure R \<longleftrightarrow> (\<exists>Ri. \<forall>x y. R x y = \<up>((y,x)\<in>Ri))"
  unfolding is_pure_def
  apply auto
  apply (rename_tac P')
  apply (rule_tac x="{(x,y). P' y x}" in exI)
  apply auto
  done

lemma pure_the_pure[simp]: "is_pure R \<Longrightarrow> pure (the_pure R) = R"
  unfolding is_pure_alt_def pure_def the_pure_def
  apply (intro ext)
  apply clarsimp
  apply (rename_tac a c Ri)
  apply (rule_tac a=Ri in theI2)
  apply auto
  done

lemma is_pure_conv: "is_pure R \<longleftrightarrow> (\<exists>R'. R = pure R')"
  unfolding pure_def is_pure_alt_def by force

lemma is_pure_the_pure_id_eq[simp]: "is_pure R \<Longrightarrow> the_pure R = Id \<longleftrightarrow> R=pure Id"
  by (auto simp: is_pure_conv)

lemma is_pure_iff_pure_assn: "is_pure P = (\<forall>x x'. sep_is_pure_assn (P x x'))"
  unfolding is_pure_def
  apply (rule iffI)
  apply auto []
  apply (rule exI[where x="\<lambda>a c. pure_part (P a c)"])
  apply auto
  done

abbreviation "hn_val R \<equiv> hn_ctxt (pure R)"

lemma hn_val_unfold: "hn_val R a b = \<up>((b,a)\<in>R)"
  by (simp add: hn_ctxt_def pure_def)

definition "invalid_assn R x y \<equiv> \<up>(pure_part (R x y))"

abbreviation "hn_invalid R \<equiv> hn_ctxt (invalid_assn R)"

lemma invalidate_clone: "R x y = (invalid_assn R x y ** R x y)"
  unfolding invalid_assn_def
  by (metis (mono_tags, lifting) pure_partI pure_part_pure_eq pure_part_split_conj pure_true_conv sep.add.right_neutral sep_conj_commute sep_is_pure_assn_def)

lemma invalidate_clone': "hn_ctxt R x y = (hn_invalid R x y ** hn_ctxt R x y)"
  unfolding hn_ctxt_def using invalidate_clone .

lemma invalid_pure_recover: "invalid_assn (pure R) x y = pure R x y"
  unfolding invalid_assn_def pure_def by auto

lemma hn_invalidI: "hn_ctxt P x y s \<Longrightarrow> hn_invalid P x y = \<box>"
  by (auto simp: invalid_assn_def hn_ctxt_def pure_partI pure_true_conv)

lemma invalid_assn_cong[cong]:
  assumes "x\<equiv>x'"
  assumes "y\<equiv>y'"
  assumes "R x' y' \<equiv> R' x' y'"
  shows "invalid_assn R x y = invalid_assn R' x' y'"
  using assms unfolding invalid_assn_def
  by simp

subsection \<open>Constraints in Refinement Relations\<close>

definition rdomp :: "('a \<Rightarrow> 'c \<Rightarrow> assn) \<Rightarrow> 'a \<Rightarrow> bool" where
  "rdomp R a \<equiv> \<exists>h c. R a c h"

(*abbreviation "rdom R \<equiv> Collect (rdomp R)"*)

lemma rdomp_ctxt[simp]: "rdomp (hn_ctxt R) = rdomp R"
  by (simp add: hn_ctxt_def[abs_def])

lemma rdomp_pure[simp]: "rdomp (pure R) a \<longleftrightarrow> a\<in>Range R"
  unfolding rdomp_def pure_def by (auto simp: pred_lift_extract_simps)

(*

lemma rdomp_invalid_simp[simp]: "rdomp (invalid_assn P) x = rdomp P x"
  by (auto simp: invalid_assn_def rdomp_def pure_part_def pred_lift_extract_simps)

lemma Range_of_constraint_conv[simp]: "Range (A\<inter>UNIV\<times>C) = Range A \<inter> C"
  by auto

subsection \<open>Heap-Nres Refinement Calculus\<close>

text {* Predicate that expresses refinement. Given a heap
  @{text "\<Gamma>"}, program @{text "c"} produces a heap @{text "\<Gamma>'"} and
  a concrete result that is related with predicate @{text "R"} to some
  abstract result from @{text "m"}*}

definition "hn_refine \<Gamma> c \<Gamma>' R m \<equiv> nofail m \<longrightarrow>
  llvm_htriple \<Gamma> c (\<lambda>r. \<Gamma>' ** (EXS x. R x r ** \<up>(RETURN x \<le> m)))"

lemma hn_refineI[intro?]:
  assumes "nofail m
    \<Longrightarrow> llvm_htriple \<Gamma> c (\<lambda>r. \<Gamma>' ** (EXS x. R x r ** \<up>(RETURN x \<le> m)))"
  shows "hn_refine \<Gamma> c \<Gamma>' R m"
  using assms unfolding hn_refine_def by blast

lemma hn_refineD:
  assumes "hn_refine \<Gamma> c \<Gamma>' R m"
  assumes "nofail m"
  shows "llvm_htriple \<Gamma> c (\<lambda>r. \<Gamma>' ** (EXS x. R x r ** \<up>(RETURN x \<le> m)))"
  using assms unfolding hn_refine_def by blast

lemma hn_refine_preI:
  assumes "\<And>h. \<Gamma> h \<Longrightarrow> hn_refine \<Gamma> c \<Gamma>' R a"
  shows "hn_refine \<Gamma> c \<Gamma>' R a"
  using assms unfolding hn_refine_def
  apply auto
  using htripleI sep_conjD by blast

lemma hn_refine_nofailI:
  assumes "nofail a \<Longrightarrow> hn_refine \<Gamma> c \<Gamma>' R a"
  shows "hn_refine \<Gamma> c \<Gamma>' R a"
  using assms by (auto simp: hn_refine_def)

lemma hn_refine_false[simp]: "hn_refine sep_false c \<Gamma>' R m"
  by rule auto

lemma hnr_FAIL[simp, intro!]: "hn_refine \<Gamma> c \<Gamma>' R FAIL"
  by rule auto

lemma hn_refine_frame:
  assumes "hn_refine P' c Q' R m"
  assumes "P \<turnstile> P' ** F"
  shows "hn_refine P c (Q' ** F) R m"
  using assms
  unfolding hn_refine_def entails_def
  apply clarsimp
  apply (rule cons_rule[where P="P'**F", rotated])
  apply simp
  apply simp
  apply (rule cons_post_rule)
  apply (erule frame_rule)
  apply (auto simp: sep_algebra_simps pred_lift_extract_simps)
  by (metis sep.mult_commute)

lemma hn_refine_frame': "hn_refine \<Gamma> c \<Gamma>' R m \<Longrightarrow> hn_refine (\<Gamma>**F) c (\<Gamma>'**F) R m"
  by (simp add: hn_refine_frame)

lemma hn_refine_cons:
  assumes I: "P\<turnstile>P'"
  assumes R: "hn_refine P' c Q R m"
  assumes I': "Q\<turnstile>Q'"
  assumes R': "\<And>x y. R x y \<turnstile> R' x y"
  shows "hn_refine P c Q' R' m"
  using R unfolding hn_refine_def
  apply clarify
  apply (erule cons_rule)
  using I apply (simp add: entails_def)
  using I' R'
  by (smt entails_def sep_conj_impl)

(*lemma hn_refine_cons:
  assumes I: "P\<Longrightarrow>\<^sub>AP'"
  assumes R: "hn_refine P' c Q R m"
  assumes I': "Q\<Longrightarrow>\<^sub>AQ'"
  assumes R': "\<And>x y. R x y \<Longrightarrow>\<^sub>A R' x y"
  shows "hn_refine P c Q' R' m"
  using R unfolding hn_refine_def
  apply clarsimp
  apply (rule cons_pre_rule[OF I])
  apply (erule cons_post_rule)
  apply (rule ent_star_mono ent_refl I' R' ent_ex_preI ent_ex_postI)+
  done
*)
lemma hn_refine_cons_pre:
  assumes I: "P \<turnstile> P'"
  assumes R: "hn_refine P' c Q R m"
  shows "hn_refine P c Q R m"
  apply (rule hn_refine_cons[OF I R])
  by auto

lemma hn_refine_cons_post:
  assumes R: "hn_refine P c Q R m"
  assumes I: "Q\<turnstile>Q'"
  shows "hn_refine P c Q' R m"
  using assms
  by (rule hn_refine_cons[OF entails_refl _ _ entails_refl])

lemma hn_refine_cons_res:
  "\<lbrakk> hn_refine \<Gamma> f \<Gamma>' R g; \<And>a c. R a c \<turnstile> R' a c \<rbrakk> \<Longrightarrow> hn_refine \<Gamma> f \<Gamma>' R' g"
  by (erule hn_refine_cons[OF entails_refl]) auto

lemma hn_refine_ref:
  assumes LE: "m\<le>m'"
  assumes R: "hn_refine P c Q R m"
  shows "hn_refine P c Q R m'"
  apply rule
  apply (rule cons_post_rule)
  apply (rule hn_refineD[OF R])
  using LE apply (simp add: pw_le_iff)
  by (smt LE order_trans pred_lift_extract_simps(2) sep_conj_commute sep_conj_impl)

lemma hn_refine_cons_complete:
  assumes I: "P\<turnstile>P'"
  assumes R: "hn_refine P' c Q R m"
  assumes I': "Q\<turnstile>Q'"
  assumes R': "\<And>x y. R x y \<turnstile> R' x y"
  assumes LE: "m\<le>m'"
  shows "hn_refine P c Q' R' m'"
  apply (rule hn_refine_ref[OF LE])
  apply (rule hn_refine_cons[OF I R I' R'])
  done

lemma hn_refine_augment_res:
  assumes A: "hn_refine \<Gamma> f \<Gamma>' R g"
  assumes B: "g \<le>\<^sub>n SPEC \<Phi>"
  shows "hn_refine \<Gamma> f \<Gamma>' (\<lambda>a c. R a c ** \<up>(\<Phi> a)) g"
  apply (rule hn_refineI)
  apply (rule cons_post_rule)
  apply (erule A[THEN hn_refineD])
  apply (erule sep_conj_impl, simp)
  apply clarsimp apply (rule exI)
  apply (erule sep_conj_impl, simp)
  using B
  apply (auto simp: pred_lift_extract_simps pw_le_iff pw_leof_iff)
  done

subsection \<open>Product Types\<close>
text \<open>Some notion for product types is already defined here, as it is used
  for currying and uncurrying, which is fundamental for the sepref tool\<close>
definition prod_assn :: "('a1\<Rightarrow>'c1\<Rightarrow>assn) \<Rightarrow> ('a2\<Rightarrow>'c2\<Rightarrow>assn)
  \<Rightarrow> 'a1*'a2 \<Rightarrow> 'c1*'c2 \<Rightarrow> assn" where
  "prod_assn P1 P2 a c \<equiv> case (a,c) of ((a1,a2),(c1,c2)) \<Rightarrow>
  P1 a1 c1 ** P2 a2 c2"

notation prod_assn (infixr "\<times>\<^sub>a" 70)

lemma prod_assn_pure_conv[simp]: "prod_assn (pure R1) (pure R2) = pure (R1 \<times>\<^sub>r R2)"
  by (auto simp: pure_def prod_assn_def pred_lift_extract_simps intro!: ext)

lemma prod_assn_pair_conv[simp]:
  "prod_assn A B (a1,b1) (a2,b2) = (A a1 a2 ** B b1 b2)"
  unfolding prod_assn_def by auto

lemma prod_assn_true[simp]: "prod_assn (\<lambda>_ _. sep_true) (\<lambda>_ _. sep_true) = (\<lambda>_ _. sep_true)"
  by (auto intro!: ext simp: hn_ctxt_def prod_assn_def)

subsection "Convenience Lemmas"

lemma hn_refine_guessI:
  assumes "hn_refine P f P' R f'"
  assumes "f=f_conc"
  shows "hn_refine P f_conc P' R f'"
  \<comment> \<open>To prove a refinement, first synthesize one, and then prove equality\<close>
  using assms by simp

lemma imp_correctI:
  assumes R: "hn_refine \<Gamma> c \<Gamma>' R a"
  assumes C: "a \<le> SPEC \<Phi>"
  shows "llvm_htriple \<Gamma> c (\<lambda>r'. EXS r. \<Gamma>' ** R r r' ** \<up>(\<Phi> r))"
  apply (rule cons_post_rule)
  apply (rule hn_refineD[OF R])
  apply (rule le_RES_nofailI[OF C])
  apply (force simp: sep_algebra_simps pred_lift_extract_simps dest: order_trans[OF _ C])
  done

lemma hnr_pre_ex_conv:
  shows "hn_refine (EXS x. \<Gamma> x) c \<Gamma>' R a \<longleftrightarrow> (\<forall>x. hn_refine (\<Gamma> x) c \<Gamma>' R a)"
  unfolding hn_refine_def
  apply (safe; clarsimp?)
  subgoal by (metis (mono_tags, lifting) cons_rule)
  subgoal premises prems
    supply [vcg_rules] = prems(1)[THEN spec]
    by vcg
  done

lemma hnr_pre_pure_conv:
  shows "hn_refine (\<up>P ** \<Gamma>) c \<Gamma>' R a \<longleftrightarrow> (P \<longrightarrow> hn_refine \<Gamma> c \<Gamma>' R a)"
  unfolding hn_refine_def
  by (auto simp: sep_algebra_simps htriple_extract_pre_pure)

lemma hn_refine_split_post:
  assumes "hn_refine \<Gamma> c \<Gamma>' R a"
  shows "hn_refine \<Gamma> c (\<Gamma>' or \<Gamma>'') R a"
  apply (rule hn_refine_cons_post[OF assms])
  apply (auto simp: entails_def)
  done

lemma hn_refine_post_other:
  assumes "hn_refine \<Gamma> c \<Gamma>'' R a"
  shows "hn_refine \<Gamma> c (\<Gamma>' or \<Gamma>'') R a"
  apply (rule hn_refine_cons_post[OF assms])
  apply (auto simp: entails_def)
  done

subsubsection \<open>Return\<close>

lemma hnr_RETURN_pass:
  "hn_refine (hn_ctxt R x p) (return p) (hn_invalid R x p) R (RETURN x)"
  \<comment> \<open>Pass on a value from the heap as return value\<close>
  apply (subst invalidate_clone')
  apply rule unfolding hn_ctxt_def
  apply vcg
  done

lemma hnr_RETURN_pure:
  assumes "(c,a)\<in>R"
  shows "hn_refine emp (return c) emp (pure R) (RETURN a)"
  \<comment> \<open>Return pure value\<close>
  unfolding hn_refine_def using assms
  supply [simp] = pure_def
  by vcg

subsubsection \<open>Assertion\<close>

lemma hnr_ASSERT:
  assumes "\<Phi> \<Longrightarrow> hn_refine \<Gamma> c \<Gamma>' R c'"
  shows "hn_refine \<Gamma> c \<Gamma>' R (do { ASSERT \<Phi>; c'})"
  using assms
  apply (cases \<Phi>)
  by auto

subsubsection \<open>Bind\<close>
lemma bind_det_aux: "\<lbrakk> RETURN x \<le> m; RETURN y \<le> f x \<rbrakk> \<Longrightarrow> RETURN y \<le> m \<bind> f"
  apply (rule order_trans[rotated])
  apply (rule Refine_Basic.bind_mono)
  apply assumption
  apply (rule order_refl)
  apply simp
  done

definition "MK_FREE R f \<equiv> \<forall>a c. llvm_htriple (R a c) (f c) (\<lambda>_::unit. \<box>)"

lemma MK_FREEI[intro?]: "\<lbrakk>\<And>a c. llvm_htriple (R a c) (f c) (\<lambda>_. \<box>)\<rbrakk> \<Longrightarrow> MK_FREE R f"
  by (auto simp: MK_FREE_def)

lemma MK_FREED: "MK_FREE R f \<Longrightarrow> llvm_htriple (R a c) (f c) (\<lambda>_. \<box>)"
  by (auto simp: MK_FREE_def)

lemma mk_free_pure: "MK_FREE (pure R) (\<lambda>_. return ())"
  apply rule unfolding pure_def
  by vcg

(*
  TODO: Should be synthesized once relations are known
*)
lemma mk_free_is_pure: "is_pure A \<Longrightarrow> MK_FREE A (\<lambda>_. return ())"
  apply rule unfolding pure_def is_pure_def
  by vcg

lemma mk_free_invalid: "MK_FREE (invalid_assn R) (\<lambda>_. return ())"
  apply rule unfolding invalid_assn_def
  by vcg

lemma mk_free_pair:
  assumes "MK_FREE R\<^sub>1 f\<^sub>1"
  assumes "MK_FREE R\<^sub>2 f\<^sub>2"
  shows "MK_FREE (R\<^sub>1\<times>\<^sub>aR\<^sub>2) (\<lambda>(c\<^sub>1,c\<^sub>2). doM {f\<^sub>1 c\<^sub>1; f\<^sub>2 c\<^sub>2})"
  supply [vcg_rules] = assms[THEN MK_FREED]
  apply (rule)
  by vcg

lemma hnr_bind:
  assumes D1: "hn_refine \<Gamma> m' \<Gamma>1 Rh m"
  assumes D2:
    "\<And>x x'. RETURN x \<le> m \<Longrightarrow> hn_refine (hn_ctxt Rh x x' ** \<Gamma>1) (f' x') (\<Gamma>2 x x') R (f x)"
  assumes IMP: "\<And>x x'. \<Gamma>2 x x' \<turnstile> hn_ctxt Rx x x' ** \<Gamma>'"
  assumes MKF: "MK_FREE Rx fr"
  shows "hn_refine \<Gamma> (doM {x\<leftarrow>m'; r \<leftarrow> f' x; fr x; return r}) \<Gamma>' R (m\<bind>f)"
  apply rule
  supply [vcg_rules] = D1[THEN hn_refineD]
  supply [simp] = pw_bind_nofail
  apply vcg
proof goal_cases
  case C: (1 F r s x)
  hence "nofail (f x)" by (simp add: refine_pw_simps pw_le_iff)

  note [vcg_rules] = D2[unfolded hn_ctxt_def, OF \<open>RETURN x \<le> m\<close>, THEN hn_refineD, OF \<open>nofail (f x)\<close>, of r]

  note [vcg_rules] = MKF[THEN MK_FREED]

  have [fri_red_rules]: "is_sep_red (\<Gamma>') \<box> (\<Gamma>2 x x') (Rx x x')" for x x'
    using IMP
    apply (auto simp: is_sep_red_def hn_ctxt_def)
  proof -
    fix Ps :: "llvm_amemory \<Rightarrow> bool" and Qs :: "llvm_amemory \<Rightarrow> bool"
    assume "\<Gamma>' \<and>* Ps \<turnstile> Qs"
    then have f1: "Ps \<and>* \<Gamma>' \<turnstile> Qs"
      by (simp add: sep.mult_commute)
    have "\<Gamma>2 x x' \<turnstile> \<Gamma>' \<and>* Rx x x'"
      by (metis (no_types) IMP hn_ctxt_def sep.mult_commute)
    then have "Ps \<and>* \<Gamma>2 x x' \<turnstile> Qs \<and>* Rx x x'"
      using f1 by (simp add: conj_entails_mono entails_mp)
    then show "\<Gamma>2 x x' \<and>* Ps \<turnstile> Rx x x' \<and>* Qs"
      by (simp add: sep.mult_commute)
  qed

  note [simp] = refine_pw_simps pw_le_iff
  show ?case using C by vcg
qed

text \<open>Version fro manual synthesis, if freeing of bound variable has been inserted manually\<close>
lemma hnr_bind_manual_free:
  assumes D1: "hn_refine \<Gamma> m' \<Gamma>1 Rh m"
  assumes D2:
    "\<And>x x'. RETURN x \<le> m \<Longrightarrow> hn_refine (hn_ctxt Rh x x' ** \<Gamma>1) (f' x') (\<Gamma>') R (f x)"
  shows "hn_refine \<Gamma> (m'\<bind>f') \<Gamma>' R (m\<bind>f)"
  apply rule
  supply [vcg_rules] = D1[THEN hn_refineD]
  supply [simp] = pw_bind_nofail
  apply vcg
proof goal_cases
  case C: (1 F r s x)
  hence "nofail (f x)" by (simp add: refine_pw_simps pw_le_iff)

  note [vcg_rules] = D2[unfolded hn_ctxt_def, OF \<open>RETURN x \<le> m\<close>, THEN hn_refineD, OF \<open>nofail (f x)\<close>, of r]

  note [simp] = refine_pw_simps pw_le_iff
  show ?case using C by vcg
qed

subsubsection \<open>Recursion\<close>

definition "hn_rel P m \<equiv> \<lambda>r. EXS x. \<up>(RETURN x \<le> m) ** P x r"

lemma hn_refine_alt: "hn_refine Fpre c Fpost P m \<equiv> nofail m \<longrightarrow>
  llvm_htriple Fpre c (\<lambda>r. hn_rel P m r ** Fpost)"
  apply (rule eq_reflection)
  unfolding hn_refine_def hn_rel_def
  by (auto simp: sep_conj_commute)

term "Monad.REC  "
find_theorems "Monad.REC"

lemma hnr_RECT:
  assumes S: "\<And>cf af ax px. \<lbrakk>
    \<And>ax px. hn_refine (hn_ctxt Rx ax px ** F) (cf px) (F' ax px) Ry (af ax)\<rbrakk>
    \<Longrightarrow> hn_refine (hn_ctxt Rx ax px ** F) (cB cf px) (F' ax px) Ry (aB af ax)"
  assumes M: "(\<And>x. M.mono_body (\<lambda>f. cB f x))"
  shows "hn_refine
    (hn_ctxt Rx ax px ** F) (Monad.REC cB px) (F' ax px) Ry (RECT aB ax)"
  unfolding RECT_def Monad.REC_def
proof (simp, intro conjI impI)
  assume "trimono aB"
  hence "flatf_mono_ge aB" by (simp add: trimonoD)
  have "\<forall>ax px.
    hn_refine (hn_ctxt Rx ax px ** F) (M.fixp_fun cB px) (F' ax px) Ry
      (flatf_gfp aB ax)"

    apply (rule flatf_ord.fixp_induct[OF _ \<open>flatf_mono_ge aB\<close>])

    apply (rule flatf_admissible_pointwise)
    apply simp

    apply (auto simp: hn_refine_alt) []

    apply clarsimp
    apply (subst M.mono_body_fixp[of cB, OF M])
    apply (rule S)
    apply blast
    done
  thus "hn_refine (hn_ctxt Rx ax px ** F) (M.fixp_fun cB px) (F' ax px) Ry (flatf_gfp aB ax)"
    by simp
qed

subsubsection \<open>Merging\<close>

definition "MERGE \<Gamma>1 f1 \<Gamma>2 f2 \<Gamma>' \<equiv> llvm_htriple \<Gamma>1 f1 (\<lambda>_. \<Gamma>') \<and> llvm_htriple \<Gamma>2 f2 (\<lambda>_. \<Gamma>')"

lemma MERGED:
  assumes "MERGE \<Gamma>1 f1 \<Gamma>2 f2 \<Gamma>'"
  shows "llvm_htriple \<Gamma>1 f1 (\<lambda>_. \<Gamma>')" "llvm_htriple \<Gamma>2 f2 (\<lambda>_. \<Gamma>')"
  using assms by (auto simp: MERGE_def)

lemma MERGEI[intro?]:
  assumes "llvm_htriple \<Gamma>1 f1 (\<lambda>_. \<Gamma>')" "llvm_htriple \<Gamma>2 f2 (\<lambda>_. \<Gamma>')"
  shows "MERGE \<Gamma>1 f1 \<Gamma>2 f2 \<Gamma>'"
  using assms by (auto simp: MERGE_def)

definition "MERGE1 R1 f1 R2 f2 R' \<equiv> \<forall> a c. MERGE (R1 a c) (f1 c) (R2 a c) (f2 c) (R' a c)"

lemma MERGE1I[intro?]:
  assumes "\<And>a c. llvm_htriple (R1 a c) (f1 c) (\<lambda>_. R' a c)"
      and "\<And>a c. llvm_htriple (R2 a c) (f2 c) (\<lambda>_. R' a c)"
  shows "MERGE1 R1 f1 R2 f2 R'"
  using assms by (auto simp: MERGE1_def MERGE_def)

lemma MERGE1D:
  assumes "MERGE1 R1 f1 R2 f2 R'"
  shows "\<And>a c. llvm_htriple (R1 a c) (f1 c) (\<lambda>_. R' a c)"
    and "\<And>a c. llvm_htriple (R2 a c) (f2 c) (\<lambda>_. R' a c)"
  using assms by (auto simp: MERGE1_def MERGE_def)

lemma MERGE_STAR:
  assumes "MERGE1 R1 f1 R2 f2 R'" "MERGE \<Gamma>1 fs1 \<Gamma>2 fs2 \<Gamma>'"
  shows "MERGE (hn_ctxt R1 a c ** \<Gamma>1) (doM {f1 c;fs1}) (hn_ctxt R2 a c ** \<Gamma>2) (doM {f2 c;fs2}) (hn_ctxt R' a c ** \<Gamma>')"
proof -
  note [vcg_rules] = MERGE1D[OF assms(1)] MERGED[OF assms(2)]

  show ?thesis unfolding hn_ctxt_def by rule vcg
qed

lemma MERGE_triv: "MERGE \<Gamma> (return ()) \<Gamma> (return ()) \<Gamma>"
  apply (rule) unfolding FRI_END_def by vcg

lemma MERGE_END: "MERGE FRI_END (return ()) FRI_END (return ()) \<box>"
  apply (rule) unfolding FRI_END_def by vcg

lemma MERGE1_eq: "MERGE1 P (\<lambda>_. return ()) P (\<lambda>_. return ()) P"
  by rule vcg

lemma MERGE1_invalids:
  assumes "MK_FREE R f"
  shows "MERGE1 (invalid_assn R) (\<lambda>_. return ()) R f (invalid_assn R)" (is ?left)
    and "MERGE1 R f (invalid_assn R) (\<lambda>_. return ()) (invalid_assn R)" (is ?right)
proof -
  note [vcg_rules] = MK_FREED[OF assms]

  show ?left
    apply rule
    apply vcg []
    apply (subst invalidate_clone[of R])
    unfolding invalid_assn_def
    by vcg

  show ?right
    apply rule
    apply (subst invalidate_clone[of R])
    unfolding invalid_assn_def
    by vcg

qed

subsection \<open>ML-Level Utilities\<close>
ML \<open>
  signature SEPREF_BASIC = sig
    (* Destroy lambda term, return function to reconstruct. Bound var is replaced by free. *)
    val dest_lambda_rc: Proof.context -> term -> ((term * (term -> term)) * Proof.context)
    (* Apply function under lambda. Bound var is replaced by free. *)
    val apply_under_lambda: (Proof.context -> term -> term) -> Proof.context -> term -> term

    (* 'a nres type *)
    val is_nresT: typ -> bool
    val mk_nresT: typ -> typ
    val dest_nresT: typ -> typ

    (* Make certified == *)
    val mk_cequals: cterm * cterm -> cterm
    (* Make \<Longrightarrow>\<^sub>A *)
    val mk_entails: term * term -> term

    (* Operations on pre-terms *)
    val constrain_type_pre: typ -> term -> term (* t::T *)

    val mk_pair_in_pre: term -> term -> term -> term (* (c,a) \<in> R *)

    val mk_compN_pre: int -> term -> term -> term  (* f o...o g*)

    val mk_curry0_pre: term -> term                (* curry0 f *)
    val mk_curry_pre: term -> term                 (* curry f *)
    val mk_curryN_pre: int -> term -> term         (* curry (...(curry f)...) *)

    val mk_uncurry0_pre: term -> term              (* uncurry0 f *)
    val mk_uncurry_pre: term -> term               (* uncurry f *)
    val mk_uncurryN_pre: int -> term -> term       (* uncurry (...(uncurry f)...) *)

    (* Conversion for hn_refine - term*)
    val hn_refine_conv: conv -> conv -> conv -> conv -> conv -> conv

    (* Conversion on abstract value (last argument) of hn_refine - term *)
    val hn_refine_conv_a: conv -> conv

    (* Conversion on abstract value of hn_refine term in conclusion of theorem *)
    val hn_refine_concl_conv_a: (Proof.context -> conv) -> Proof.context -> conv

    (* Destruct hn_refine term *)
    val dest_hn_refine: term -> term * term * term * term * term
    (* Make hn_refine term *)
    val mk_hn_refine: term * term * term * term * term -> term
    (* Check if given term is Trueprop (hn_refine ...). Use with CONCL_COND'. *)
    val is_hn_refine_concl: term -> bool

    (* Destruct abs-fun, returns RETURN-flag, (f, args) *)
    val dest_hnr_absfun: term -> bool * (term * term list)
    (* Make abs-fun. *)
    val mk_hnr_absfun: bool * (term * term list) -> term
    (* Make abs-fun. Guess RETURN-flag from type. *)
    val mk_hnr_absfun': (term * term list) -> term

    (* Prove permutation of *. To be used with f_tac_conv. *)
    val star_permute_tac: Proof.context -> tactic

    (* Make separation conjunction *)
    val mk_star: term * term -> term
    (* Make separation conjunction from list. "[]" yields "\<box>". *)
    val list_star: term list -> term
    (* Decompose separation conjunction. "\<box>" yields "[]". *)
    val strip_star: term -> term list

    (* Check if true-assertion *)
    val is_true: term -> bool

    (* Check if term is hn_ctxt-assertion *)
    val is_hn_ctxt: term -> bool
    (* Decompose hn_ctxt-assertion *)
    val dest_hn_ctxt: term -> term * term * term
    (* Decompose hn_ctxt-assertion, NONE if term has wrong format *)
    val dest_hn_ctxt_opt: term -> (term * term * term) option

    type phases_ctrl = {
      trace: bool,            (* Trace phases *)
      trace_goals: bool,      (* Trace intermediate goal states *)
      int_res: bool,          (* Stop with intermediate result *)
      start: string option,   (* Start with this phase. NONE: First phase *)
      stop: string option     (* Stop after this phase. NONE: Last phase *)
    }

    (* No tracing or intermediate result, all phases *)
    val dflt_phases_ctrl: phases_ctrl
    (* Tracing, intermediate result, all phases *)
    val dbg_phases_ctrl: phases_ctrl
    (* Tracing, goal-tracing, intermediate result, all phases *)
    val full_dbg_phases_ctrl: phases_ctrl

    val cfg_trace_phase_goals: bool Config.T
    val flag_phases_ctrl: Proof.context -> bool -> phases_ctrl

    (* Name, tactic, expected number of created goals (may be negative for solved goals) *)
    type phase = string * (Proof.context -> tactic') * int

    (* Perform sequence of tactics (tac,n), each expected to create n new goals,
       or solve goals if n is negative.
       Debug-flag: Stop with intermediate state after tactic
       fails or produces less/more goals as expected. *)
    val PHASES': phase list -> phases_ctrl -> Proof.context -> tactic'

  end

  structure Sepref_Basic: SEPREF_BASIC = struct

    fun is_nresT (Type (@{type_name nres},[_])) = true | is_nresT _ = false
    fun mk_nresT T = Type(@{type_name nres},[T])
    fun dest_nresT (Type (@{type_name nres},[T])) = T | dest_nresT T = raise TYPE("dest_nresT",[T],[])

    fun dest_lambda_rc ctxt (Abs (x,T,t)) = let
        val (u,ctxt) = yield_singleton Variable.variant_fixes x ctxt
        val u = Free (u,T)
        val t = subst_bound (u,t)
        val reconstruct = Term.lambda_name (x,u)
      in
        ((t,reconstruct),ctxt)
      end
    | dest_lambda_rc _ t = raise TERM("dest_lambda_rc",[t])

    fun apply_under_lambda f ctxt t = let
      val ((t,rc),ctxt) = dest_lambda_rc ctxt t
      val t = f ctxt t
    in
      rc t
    end

    (* Functions on pre-terms *)
    fun mk_pair_in_pre x y r = Const (@{const_name Set.member}, dummyT) $
      (Const (@{const_name Product_Type.Pair}, dummyT) $ x $ y) $ r

    fun mk_uncurry_pre t = Const(@{const_name uncurry}, dummyT)$t
    fun mk_uncurry0_pre t = Const(@{const_name uncurry0}, dummyT)$t
    fun mk_uncurryN_pre 0 = mk_uncurry0_pre
      | mk_uncurryN_pre 1 = I
      | mk_uncurryN_pre n = mk_uncurry_pre o mk_uncurryN_pre (n-1)

    fun mk_curry_pre t = Const(@{const_name curry}, dummyT)$t
    fun mk_curry0_pre t = Const(@{const_name curry0}, dummyT)$t
    fun mk_curryN_pre 0 = mk_curry0_pre
      | mk_curryN_pre 1 = I
      | mk_curryN_pre n = mk_curry_pre o mk_curryN_pre (n-1)

    fun mk_compN_pre 0 f g = f $ g
      | mk_compN_pre n f g = let
          val g = fold (fn i => fn t => t$Bound i) (n-2 downto 0) g
          val t = Const(@{const_name "Fun.comp"},dummyT) $ f $ g

          val t = fold (fn i => fn t => Abs ("x"^string_of_int i,dummyT,t)) (n-1 downto 1) t
        in
          t
        end

    fun constrain_type_pre T t = Const(@{syntax_const "_type_constraint_"},T-->T) $ t

    local open Conv in
      fun hn_refine_conv c1 c2 c3 c4 c5 ct = case Thm.term_of ct of
        @{mpat "hn_refine _ _ _ _ _"} => let
          val cc = combination_conv
        in
          cc (cc (cc (cc (cc all_conv c1) c2) c3) c4) c5 ct
        end
      | _ => raise CTERM ("hn_refine_conv",[ct])

      val hn_refine_conv_a = hn_refine_conv all_conv all_conv all_conv all_conv

      fun hn_refine_concl_conv_a conv ctxt = Refine_Util.HOL_concl_conv
        (fn ctxt => hn_refine_conv_a (conv ctxt)) ctxt

    end

    (* FIXME: Strange dependency! *)
    val mk_cequals = uncurry SMT_Util.mk_cequals

    val mk_entails = HOLogic.mk_binrel @{const_name "entails"}

    val mk_star = HOLogic.mk_binop @{const_name "sep_conj"}

    fun list_star [] = @{term "\<box>::assn"}
      | list_star [a] = a
      | list_star (a::l) = mk_star (a,list_star l)

    fun strip_star @{mpat "?a**?b"} = strip_star a @ strip_star b
      | strip_star @{mpat "\<box>"} = []
      | strip_star t = [t]

    fun is_true @{mpat "sep_true"} = true | is_true _ = false

    fun is_hn_ctxt @{mpat "hn_ctxt _ _ _"} = true | is_hn_ctxt _ = false
    fun dest_hn_ctxt @{mpat "hn_ctxt ?R ?a ?p"} = (R,a,p)
      | dest_hn_ctxt t = raise TERM("dest_hn_ctxt",[t])

    fun dest_hn_ctxt_opt @{mpat "hn_ctxt ?R ?a ?p"} = SOME (R,a,p)
      | dest_hn_ctxt_opt _ = NONE

    fun strip_abs_args (t as @{mpat "PR_CONST _"}) = (t,[])
      | strip_abs_args @{mpat "?f$?a"} = (case strip_abs_args f of (f,args) => (f,args@[a]))
      | strip_abs_args t = (t,[])

    fun dest_hnr_absfun @{mpat "RETURN$?a"} = (true, strip_abs_args a)
      | dest_hnr_absfun f = (false, strip_abs_args f)

    fun mk_hnr_absfun (true,fa) = Autoref_Tagging.list_APP fa |> (fn a => @{mk_term "RETURN$?a"})
      | mk_hnr_absfun (false,fa) = Autoref_Tagging.list_APP fa

    fun mk_hnr_absfun' fa = let
      val t = Autoref_Tagging.list_APP fa
      val T = fastype_of t
    in
      case T of
        Type (@{type_name nres},_) => t
      | _ => @{mk_term "RETURN$?t"}

    end

    fun dest_hn_refine @{mpat "hn_refine ?P ?c ?Q ?R ?a"} = (P,c,Q,R,a)
      | dest_hn_refine t = raise TERM("dest_hn_refine",[t])

    fun mk_hn_refine (P,c,Q,R,a) = @{mk_term "hn_refine ?P ?c ?Q ?R ?a"}

    val is_hn_refine_concl = can (HOLogic.dest_Trueprop #> dest_hn_refine)

    fun star_permute_tac ctxt = ALLGOALS (
      VCG_Lib.simp_only_tac @{thms sep_conj_empty sep_conj_empty' sep_conj_ac} ctxt)

    type phases_ctrl = {
      trace: bool,
      trace_goals: bool,
      int_res: bool,
      start: string option,
      stop: string option
    }

    val dflt_phases_ctrl = {trace=false,trace_goals=false,int_res=false,start=NONE,stop=NONE}
    val dbg_phases_ctrl = {trace=true,trace_goals=false,int_res=true,start=NONE,stop=NONE}
    val full_dbg_phases_ctrl = {trace=true,trace_goals=true,int_res=true,start=NONE,stop=NONE}

    val cfg_trace_phase_goals = Attrib.setup_config_bool @{binding sepref_trace_phase_goals} (K false)

    fun flag_phases_ctrl ctxt dbg =
      case (Config.get ctxt cfg_trace_phase_goals, dbg) of
        (_, false) => dflt_phases_ctrl
      | (false, true) => dbg_phases_ctrl
      | (true,true) => full_dbg_phases_ctrl

    type phase = string * (Proof.context -> tactic') * int

    local
      fun ph_range phases start stop = let
        fun find_phase name = let
          val i = find_index (fn (n,_,_) => n=name) phases
          val _ = if i<0 then error ("No such phase: " ^ name) else ()
        in
          i
        end

        val i = case start of NONE => 0 | SOME n => find_phase n
        val j = case stop of NONE => length phases - 1 | SOME n => find_phase n

        val phases = take (j+1) phases |> drop i

        val _ = case phases of [] => error "No phases selected, range is empty" | _ => ()
      in
        phases
      end
    in

      fun PHASES' phases ctrl ctxt = let
        val phases = ph_range phases (#start ctrl) (#stop ctrl)
        val phases = map (fn (n,tac,d) => (n,tac ctxt,d)) phases

        fun r [] _ st = Seq.single st
          | r ((name,tac,d)::tacs) i st = let
              val n = Thm.nprems_of st
              val bailout_tac = if #int_res ctrl then all_tac else no_tac
              fun trace_tac msg st = (if #trace ctrl then tracing msg else (); Seq.single st)

              val trace_goal_tac = if #trace_goals ctrl then print_tac ctxt "Proof state" else all_tac

              val trace_start_tac = trace_tac ("Phase " ^ name)
            in
              K trace_goal_tac THEN' K trace_start_tac THEN' IF_EXGOAL (tac)
              THEN_ELSE' (
                fn i => fn st =>
                  (* Bail out if a phase does not solve/create exactly the expected subgoals *)
                  if Thm.nprems_of st = n+d then
                    ((trace_tac "  Done" THEN r tacs i) st)
                  else
                    (trace_tac "*** Wrong number of produced goals" THEN bailout_tac) st

              ,
                K (trace_tac "*** Phase tactic failed" THEN bailout_tac))
            end i st

      in
        r phases
      end

    end

  end

  signature SEPREF_DEBUGGING = sig
    (*************************)
    (* Debugging *)
    (* Centralized debugging mode flag *)
    val cfg_debug_all: bool Config.T

    val is_debug: bool Config.T -> Proof.context -> bool
    val is_debug': Proof.context -> bool

    (* Conversion, trace errors if custom or central debugging flag is activated *)
    val DBG_CONVERSION: bool Config.T -> Proof.context -> conv -> tactic'

    (* Conversion, trace errors if central debugging flag is activated *)
    val DBG_CONVERSION': Proof.context -> conv -> tactic'

    (* Tracing message and current subgoal *)
    val tracing_tac': string -> Proof.context -> tactic'
    (* Warning message and current subgoal *)
    val warning_tac': string -> Proof.context -> tactic'
    (* Error message and current subgoal *)
    val error_tac': string -> Proof.context -> tactic'

    (* Trace debug message *)
    val dbg_trace_msg: bool Config.T -> Proof.context -> string -> unit
    val dbg_trace_msg': Proof.context -> string -> unit

    val dbg_trace: bool Config.T -> Proof.context -> (Proof.context -> string) -> unit
    val dbg_trace': Proof.context -> (Proof.context -> string) -> unit

    val dbg_msg_tac: bool Config.T -> (Proof.context -> int -> thm -> string) -> Proof.context -> tactic'
    val dbg_msg_tac': (Proof.context -> int -> thm -> string) -> Proof.context -> tactic'

    val msg_text: string -> Proof.context -> int -> thm -> string
    val msg_subgoal: string -> Proof.context -> int -> thm -> string
    val msg_from_subgoal: string -> (term -> Proof.context -> string) -> Proof.context -> int -> thm -> string
    val msg_allgoals: string -> Proof.context -> int -> thm -> string

  end

  structure Sepref_Debugging: SEPREF_DEBUGGING = struct

    val cfg_debug_all =
      Attrib.setup_config_bool @{binding sepref_debug_all} (K false)

    fun is_debug cfg ctxt = Config.get ctxt cfg orelse Config.get ctxt cfg_debug_all
    fun is_debug' ctxt = Config.get ctxt cfg_debug_all

    fun dbg_trace cfg ctxt obj =
      if is_debug cfg ctxt then
        tracing ((obj ctxt))
      else ()

    fun dbg_trace' ctxt obj =
      if is_debug' ctxt then
        tracing ((obj ctxt))
      else ()

    fun dbg_trace_msg cfg ctxt msg =
      if is_debug cfg ctxt then
        tracing msg
      else ()
    fun dbg_trace_msg' ctxt msg =
      if is_debug' ctxt then
        tracing msg
      else ()

    fun DBG_CONVERSION cfg ctxt cv i st =
      Seq.single (Conv.gconv_rule cv i st)
      handle e as THM _   => (dbg_trace cfg ctxt (K (@{make_string} e)); Seq.empty)
           | e as CTERM _ => (dbg_trace cfg ctxt (K (@{make_string} e)); Seq.empty)
           | e as TERM _  => (dbg_trace cfg ctxt (K (@{make_string} e)); Seq.empty)
           | e as TYPE _  => (dbg_trace cfg ctxt (K (@{make_string} e)); Seq.empty);

    fun DBG_CONVERSION' ctxt cv i st =
      Seq.single (Conv.gconv_rule cv i st)
      handle e as THM _   => (dbg_trace' ctxt (K (@{make_string} e)); Seq.empty)
           | e as CTERM _ => (dbg_trace' ctxt (K (@{make_string} e)); Seq.empty)
           | e as TERM _  => (dbg_trace' ctxt (K (@{make_string} e)); Seq.empty)
           | e as TYPE _  => (dbg_trace' ctxt (K (@{make_string} e)); Seq.empty);

    local
      fun gen_subgoal_msg_tac do_msg msg ctxt = IF_EXGOAL (fn i => fn st => let
        val t = nth (Thm.prems_of st) (i-1)
        val _ = Pretty.block [Pretty.str msg, Pretty.fbrk, Syntax.pretty_term ctxt t]
          |> Pretty.string_of |> do_msg

      in
        Seq.single st
      end)
    in
      val tracing_tac' = gen_subgoal_msg_tac tracing
      val warning_tac' = gen_subgoal_msg_tac warning
      val error_tac' = gen_subgoal_msg_tac error
    end

    fun dbg_msg_tac cfg msg ctxt =
      if is_debug cfg ctxt then (fn i => fn st => (tracing (msg ctxt i st); Seq.single st))
      else K all_tac
    fun dbg_msg_tac' msg ctxt =
      if is_debug' ctxt then (fn i => fn st => (tracing (msg ctxt i st); Seq.single st))
      else K all_tac

    fun msg_text msg _ _ _ = msg

    fun msg_from_subgoal msg sgmsg ctxt i st =
      case try (nth (Thm.prems_of st)) (i-1) of
        NONE => msg ^ "\n" ^ "Subgoal out of range"
      | SOME t => msg ^ "\n" ^ sgmsg t ctxt

    fun msg_subgoal msg = msg_from_subgoal msg (fn t => fn ctxt =>
      Syntax.pretty_term ctxt t |> Pretty.string_of
    )

    fun msg_allgoals msg ctxt _ st =
      msg ^ "\n" ^ Pretty.string_of (Pretty.chunks (Goal_Display.pretty_goals ctxt st))

  end
\<close>

ML \<open>
  (* Tactics for produced subgoals *)
  infix 1 THEN_NEXT THEN_ALL_NEW_LIST THEN_ALL_NEW_LIST'
  signature STACTICAL = sig
    (* Apply first tactic on this subgoal, and then second tactic on next subgoal *)
    val THEN_NEXT: tactic' * tactic' -> tactic'
    (* Apply tactics to the current and following subgoals *)
    val APPLY_LIST: tactic' list -> tactic'
    (* Apply list of tactics on subgoals emerging from tactic.
      Requires exactly one tactic per emerging subgoal.*)
    val THEN_ALL_NEW_LIST: tactic' * tactic' list -> tactic'
    (* Apply list of tactics to subgoals emerging from tactic, use fallback for additional subgoals. *)
    val THEN_ALL_NEW_LIST': tactic' * (tactic' list * tactic') -> tactic'

  end

  structure STactical : STACTICAL = struct
    infix 1 THEN_WITH_GOALDIFF
    fun (tac1 THEN_WITH_GOALDIFF tac2) st = let
      val n1 = Thm.nprems_of st
    in
      st |> (tac1 THEN (fn st => tac2 (Thm.nprems_of st - n1) st ))
    end

    fun (tac1 THEN_NEXT tac2) i =
      tac1 i THEN_WITH_GOALDIFF (fn d => (
        if d < ~1 then
          (error "THEN_NEXT: Tactic solved more than one goal"; no_tac)
        else
          tac2 (i+1+d)
      ))

    fun APPLY_LIST [] = K all_tac
      | APPLY_LIST (tac::tacs) = tac THEN_NEXT APPLY_LIST tacs

    fun (tac1 THEN_ALL_NEW_LIST tacs) i =
      tac1 i
      THEN_WITH_GOALDIFF (fn d =>
        if d+1 <> length tacs then (
          error "THEN_ALL_NEW_LIST: Tactic produced wrong number of goals"; no_tac
        ) else APPLY_LIST tacs i
      )

    fun (tac1 THEN_ALL_NEW_LIST' (tacs,rtac)) i =
      tac1 i
      THEN_WITH_GOALDIFF (fn d => let
        val _ = if d+1 < length tacs then error "THEN_ALL_NEW_LIST': Tactic produced too few goals" else ();
        val tacs' = tacs @ replicate (d + 1 - length tacs) rtac
      in
        APPLY_LIST tacs' i
      end)

  end

  open STactical
\<close>

end


(*  Title:      HOL/Auth/Guard/Guard_Public.thy
    Author:     Frederic Blanqui, University of Cambridge Computer Laboratory
    Copyright   2002  University of Cambridge

Lemmas on guarded messages for public protocols.
*)

theory Guard_Public imports Guard "../Public" Extensions begin

subsection\<open>Extensions to Theory \<open>Public\<close>\<close>

declare initState.simps [simp del]

subsubsection\<open>signature\<close>

definition sign :: "agent => msg => msg" where
"sign A X == \<lbrace>Agent A, X, Crypt (priK A) (Hash X)\<rbrace>"

lemma sign_inj [iff]: "(sign A X = sign A' X') = (A=A' & X=X')"
by (auto simp: sign_def)

subsubsection\<open>agent associated to a key\<close>

definition agt :: "key => agent" where
"agt K == SOME A. K = priK A | K = pubK A"

lemma agt_priK [simp]: "agt (priK A) = A"
by (simp add: agt_def)

lemma agt_pubK [simp]: "agt (pubK A) = A"
by (simp add: agt_def)

subsubsection\<open>basic facts about \<^term>\<open>initState\<close>\<close>

lemma no_Crypt_in_parts_init [simp]: "Crypt K X \<notin> parts (initState A)"
by (cases A, auto simp: initState.simps)

lemma no_Crypt_in_analz_init [simp]: "Crypt K X \<notin> analz (initState A)"
by auto

lemma no_priK_in_analz_init [simp]: "A \<notin> bad
\<Longrightarrow> Key (priK A) \<notin> analz (initState Spy)"
by (auto simp: initState.simps)

lemma priK_notin_initState_Friend [simp]: "A \<noteq> Friend C
\<Longrightarrow> Key (priK A) \<notin> parts (initState (Friend C))"
by (auto simp: initState.simps)

lemma keyset_init [iff]: "keyset (initState A)"
by (cases A, auto simp: keyset_def initState.simps)

subsubsection\<open>sets of private keys\<close>

definition priK_set :: "key set => bool" where
"priK_set Ks \<equiv> \<forall>K. K \<in> Ks \<longrightarrow> (\<exists>A. K = priK A)"

lemma in_priK_set: "[| priK_set Ks; K \<in> Ks |] ==> \<exists>A. K = priK A"
by (simp add: priK_set_def)

lemma priK_set1 [iff]: "priK_set {priK A}"
by (simp add: priK_set_def)

lemma priK_set2 [iff]: "priK_set {priK A, priK B}"
by (simp add: priK_set_def)

subsubsection\<open>sets of good keys\<close>

definition good :: "key set => bool" where
"good Ks == \<forall>K. K \<in> Ks \<longrightarrow> agt K \<notin> bad"

lemma in_good: "[| good Ks; K \<in> Ks |] ==> agt K \<notin> bad"
by (simp add: good_def)

lemma good1 [simp]: "A \<notin> bad \<Longrightarrow> good {priK A}"
by (simp add: good_def)

lemma good2 [simp]: "[| A \<notin> bad; B \<notin> bad |] ==> good {priK A, priK B}"
by (simp add: good_def)

subsubsection\<open>greatest nonce used in a trace, 0 if there is no nonce\<close>

primrec greatest :: "event list => nat"
where
  "greatest [] = 0"
| "greatest (ev # evs) = max (greatest_msg (msg ev)) (greatest evs)"

lemma greatest_is_greatest: "Nonce n \<in> used evs \<Longrightarrow> n \<le> greatest evs"
apply (induct evs, auto simp: initState.simps)
apply (drule used_sub_parts_used, safe)
apply (drule greatest_msg_is_greatest, arith)
by simp

subsubsection\<open>function giving a new nonce\<close>

definition new :: "event list \<Rightarrow> nat" where
"new evs \<equiv> Suc (greatest evs)"

lemma new_isnt_used [iff]: "Nonce (new evs) \<notin> used evs"
by (clarify, drule greatest_is_greatest, auto simp: new_def)

subsection\<open>Proofs About Guarded Messages\<close>

subsubsection\<open>small hack necessary because priK is defined as the inverse of pubK\<close>

lemma pubK_is_invKey_priK: "pubK A = invKey (priK A)"
by simp

lemmas pubK_is_invKey_priK_substI = pubK_is_invKey_priK [THEN ssubst]

lemmas invKey_invKey_substI = invKey [THEN ssubst]

lemma "Nonce n \<in> parts {X} \<Longrightarrow> Crypt (pubK A) X \<in> guard n {priK A}"
apply (rule pubK_is_invKey_priK_substI, rule invKey_invKey_substI)
by (rule Guard_Nonce, simp+)

subsubsection\<open>guardedness results\<close>

lemma sign_guard [intro]: "X \<in> guard n Ks \<Longrightarrow> sign A X \<in> guard n Ks"
by (auto simp: sign_def)

lemma Guard_init [iff]: "Guard n Ks (initState B)"
by (induct B, auto simp: Guard_def initState.simps)

lemma Guard_knows_max': "Guard n Ks (knows_max' C evs)
==> Guard n Ks (knows_max C evs)"
by (simp add: knows_max_def)

lemma Nonce_not_used_Guard_spies [dest]: "Nonce n \<notin> used evs
\<Longrightarrow> Guard n Ks (spies evs)"
by (auto simp: Guard_def dest: not_used_not_known parts_sub)

lemma Nonce_not_used_Guard [dest]: "[| evs \<in> p; Nonce n \<notin> used evs;
Gets_correct p; one_step p |] ==> Guard n Ks (knows (Friend C) evs)"
by (auto simp: Guard_def dest: known_used parts_trans)

lemma Nonce_not_used_Guard_max [dest]: "[| evs \<in> p; Nonce n \<notin> used evs;
Gets_correct p; one_step p |] ==> Guard n Ks (knows_max (Friend C) evs)"
by (auto simp: Guard_def dest: known_max_used parts_trans)

lemma Nonce_not_used_Guard_max' [dest]: "[| evs \<in> p; Nonce n \<notin> used evs;
Gets_correct p; one_step p |] ==> Guard n Ks (knows_max' (Friend C) evs)"
apply (rule_tac H="knows_max (Friend C) evs" in Guard_mono)
by (auto simp: knows_max_def)

subsubsection\<open>regular protocols\<close>

definition regular :: "event list set \<Rightarrow> bool" where
"regular p \<equiv> \<forall>evs A. evs \<in> p \<longrightarrow> (Key (priK A) \<in> parts (spies evs)) = (A \<in> bad)"

lemma priK_parts_iff_bad [simp]: "[| evs \<in> p; regular p |] ==>
(Key (priK A) \<in> parts (spies evs)) = (A \<in> bad)"
by (auto simp: regular_def)

lemma priK_analz_iff_bad [simp]: "[| evs \<in> p; regular p |] ==>
(Key (priK A) \<in> analz (spies evs)) = (A \<in> bad)"
by auto

lemma Guard_Nonce_analz: "[| Guard n Ks (spies evs); evs \<in> p;
priK_set Ks; good Ks; regular p |] ==> Nonce n \<notin> analz (spies evs)"
apply (clarify, simp only: knows_decomp)
apply (drule Guard_invKey_keyset, simp+, safe)
apply (drule in_good, simp)
apply (drule in_priK_set, simp+, clarify)
apply (frule_tac A=A in priK_analz_iff_bad)
by (simp add: knows_decomp)+

end