section \<open> Alphabetised Relations \<close>

theory utp_rel
imports
  utp_pred_laws
  utp_healthy
  utp_lift
  utp_tactics
  utp_lift_pretty
begin

text \<open> An alphabetised relation is simply a predicate whose state-space is a product type. In this
  theory we construct the core operators of the relational calculus, and prove a libary of
  associated theorems, based on Chapters 2 and 5 of the UTP book~\cite{Hoare&98}. \<close>

subsection \<open> Relational Alphabets \<close>

text \<open> We set up convenient syntax to refer to the input and output parts of the alphabet, as is
  common in UTP. Since we are in a product space, these are simply the lenses @{term "fst\<^sub>L"} and
  @{term "snd\<^sub>L"}. \<close>

definition in\<alpha> :: "('\<alpha> \<Longrightarrow> '\<alpha> \<times> '\<beta>)" where
[lens_defs]: "in\<alpha> = fst\<^sub>L"

definition out\<alpha> :: "('\<beta> \<Longrightarrow> '\<alpha> \<times> '\<beta>)" where
[lens_defs]: "out\<alpha> = snd\<^sub>L"

lemma in\<alpha>_uvar [simp]: "vwb_lens in\<alpha>"
  by (unfold_locales, auto simp add: in\<alpha>_def)

lemma out\<alpha>_uvar [simp]: "vwb_lens out\<alpha>"
  by (unfold_locales, auto simp add: out\<alpha>_def)

lemma var_in_alpha [simp]: "x ;\<^sub>L in\<alpha> = in_var x"
  by (simp add: fst_lens_def in\<alpha>_def in_var_def)

lemma var_out_alpha [simp]: "x ;\<^sub>L out\<alpha> = out_var x"
  by (simp add: out\<alpha>_def out_var_def snd_lens_def)

lemma drop_pre_inv [simp]: "\<lbrakk> out\<alpha> \<sharp> p \<rbrakk> \<Longrightarrow> \<lceil>\<lfloor>p\<rfloor>\<^sub><\<rceil>\<^sub>< = p"
  by (pred_simp)

lemma usubst_lookup_in_var_unrest [usubst]:
  "in\<alpha> \<sharp>\<^sub>s \<sigma> \<Longrightarrow> \<langle>\<sigma>\<rangle>\<^sub>s (in_var x) = $x"
  by (rel_simp, metis fstI)

lemma usubst_lookup_out_var_unrest [usubst]:
  "out\<alpha> \<sharp>\<^sub>s \<sigma> \<Longrightarrow> \<langle>\<sigma>\<rangle>\<^sub>s (out_var x) = $x\<acute>"
  by (rel_simp, metis sndI)

lemma out_alpha_in_indep [simp]:
  "out\<alpha> \<bowtie> in_var x" "in_var x \<bowtie> out\<alpha>"
  by (simp_all add: in_var_def out\<alpha>_def lens_indep_def fst_lens_def snd_lens_def lens_comp_def)

lemma in_alpha_out_indep [simp]:
  "in\<alpha> \<bowtie> out_var x" "out_var x \<bowtie> in\<alpha>"
  by (simp_all add: in_var_def in\<alpha>_def lens_indep_def fst_lens_def lens_comp_def)

text \<open> The following two functions lift a predicate substitution to a relational one. \<close>

abbreviation usubst_rel_lift :: "'\<alpha> usubst \<Rightarrow> ('\<alpha> \<times> '\<beta>) usubst" ("\<lceil>_\<rceil>\<^sub>s") where
"\<lceil>\<sigma>\<rceil>\<^sub>s \<equiv> \<sigma> \<oplus>\<^sub>s in\<alpha>"

abbreviation usubst_rel_drop :: "('\<alpha> \<times> '\<alpha>) usubst \<Rightarrow> '\<alpha> usubst" ("\<lfloor>_\<rfloor>\<^sub>s") where
"\<lfloor>\<sigma>\<rfloor>\<^sub>s \<equiv> \<sigma> \<restriction>\<^sub>s in\<alpha>"

utp_const usubst_rel_lift usubst_rel_drop

text \<open> The alphabet of a relation then consists wholly of the input and output portions. \<close>

lemma alpha_in_out:
  "\<Sigma> \<approx>\<^sub>L in\<alpha> +\<^sub>L out\<alpha>"
  by (simp add: fst_snd_id_lens in\<alpha>_def lens_equiv_refl out\<alpha>_def)

subsection \<open> Relational Types and Operators \<close>

text \<open> We create type synonyms for conditions (which are simply predicates) -- i.e. relations
  without dashed variables --, alphabetised relations where the input and output alphabet can
  be different, and finally homogeneous relations. \<close>

type_synonym '\<alpha> cond        = "'\<alpha> upred"
type_synonym ('\<alpha>, '\<beta>) urel  = "('\<alpha> \<times> '\<beta>) upred"
type_synonym '\<alpha> hrel        = "('\<alpha> \<times> '\<alpha>) upred"
type_synonym ('a, '\<alpha>) hexpr = "('a, '\<alpha> \<times> '\<alpha>) uexpr"

translations
  (type) "('\<alpha>, '\<beta>) urel" <= (type) "('\<alpha> \<times> '\<beta>) upred"

text \<open> We set up some overloaded constants for sequential composition and the identity in case
  we want to overload their definitions later. \<close>

consts
  useq     :: "'a \<Rightarrow> 'b \<Rightarrow> 'c" (infixr ";;" 61)
  uassigns :: "('a, 'b) psubst \<Rightarrow> 'c" ("\<langle>_\<rangle>\<^sub>a")
  uskip    :: "'a" ("II")

text \<open> We define a specialised version of the conditional where the condition can refer only to
  undashed variables, as is usually the case in programs, but not universally in UTP models.
  We implement this by lifting the condition predicate into the relational state-space with
  construction @{term "\<lceil>b\<rceil>\<^sub><"}. \<close>

definition lift_rcond ("\<lceil>_\<rceil>\<^sub>\<leftarrow>") where
[upred_defs]: "\<lceil>b\<rceil>\<^sub>\<leftarrow> = \<lceil>b\<rceil>\<^sub><"

abbreviation
  rcond :: "('\<alpha>, '\<beta>) urel \<Rightarrow> '\<alpha> cond \<Rightarrow> ('\<alpha>, '\<beta>) urel \<Rightarrow> ('\<alpha>, '\<beta>) urel"
  ("(3_ \<triangleleft> _ \<triangleright>\<^sub>r/ _)" [52,0,53] 52)
  where "(P \<triangleleft> b \<triangleright>\<^sub>r Q) \<equiv> (P \<triangleleft> \<lceil>b\<rceil>\<^sub>\<leftarrow> \<triangleright> Q)"

text \<open> Sequential composition is heterogeneous, and simply requires that the output alphabet
  of the first matches then input alphabet of the second. We define it by lifting HOL's
  built-in relational composition operator (@{term "(O)"}). Since this returns a set, the
  definition states that the state binding $b$ is an element of this set. \<close>

lift_definition seqr::"('\<alpha>, '\<beta>) urel \<Rightarrow> ('\<beta>, '\<gamma>) urel \<Rightarrow> ('\<alpha> \<times> '\<gamma>) upred"
is "\<lambda> P Q b. b \<in> ({p. P p} O {q. Q q})" .

adhoc_overloading
  useq seqr

text \<open> We also set up a homogeneous sequential composition operator, and versions of @{term true}
  and @{term false} that are explicitly typed by a homogeneous alphabet. \<close>

abbreviation seqh :: "'\<alpha> hrel \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" (infixr ";;\<^sub>h" 61) where
"seqh P Q \<equiv> (P ;; Q)"

abbreviation truer :: "'\<alpha> hrel" ("true\<^sub>h") where
"truer \<equiv> true"

abbreviation falser :: "'\<alpha> hrel" ("false\<^sub>h") where
"falser \<equiv> false"

text \<open> We define the relational converse operator as an alphabet extrusion on the bijective
  lens @{term swap\<^sub>L} that swaps the elements of the product state-space. \<close>

abbreviation conv_r :: "('a, '\<alpha> \<times> '\<beta>) uexpr \<Rightarrow> ('a, '\<beta> \<times> '\<alpha>) uexpr" ("_\<^sup>-" [999] 999)
where "conv_r e \<equiv> e \<oplus>\<^sub>p swap\<^sub>L"

text \<open> Assignment is defined using substitutions, where latter defines what each variable should
  map to. This approach, which is originally due to Back~\cite{Back1998}, permits more general
  assignment expressions. The definition of the operator identifies the after state binding, $b'$,
  with the substitution function applied to the before state binding $b$. \<close>

lift_definition assigns_r :: "('\<alpha>,'\<beta>) psubst \<Rightarrow> ('\<alpha>, '\<beta>) urel"
  is "\<lambda> \<sigma> (b, b'). b' = \<sigma>(b)" .

adhoc_overloading
  uassigns assigns_r

text \<open> Relational identity, or skip, is then simply an assignment with the identity substitution:
  it simply identifies all variables. \<close>

definition skip_r :: "'\<alpha> hrel" where
[urel_defs]: "skip_r = assigns_r id\<^sub>s"

adhoc_overloading
  uskip skip_r

text \<open> Non-deterministic assignment, also known as ``choose'', assigns an arbitrarily chosen value
  to the given variable \<close>

definition nd_assign :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> hrel" where
[urel_defs]: "nd_assign x = (\<Sqinter> v \<bullet> assigns_r [x \<mapsto>\<^sub>s \<guillemotleft>v\<guillemotright>])"

text \<open> We set up iterated sequential composition which iterates an indexed predicate over the
  elements of a list. \<close>

definition seqr_iter :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b hrel) \<Rightarrow> 'b hrel" where
[urel_defs]: "seqr_iter xs P = foldr (\<lambda> i Q. P(i) ;; Q) xs II"

text \<open> A singleton assignment simply applies a singleton substitution function, and similarly
  for a double assignment. \<close>

abbreviation assign_r :: "('t \<Longrightarrow> '\<alpha>) \<Rightarrow> ('t, '\<alpha>) uexpr \<Rightarrow> '\<alpha> hrel"
where "assign_r x v \<equiv> \<langle>[x \<mapsto>\<^sub>s v]\<rangle>\<^sub>a"

abbreviation assign_2_r ::
  "('t1 \<Longrightarrow> '\<alpha>) \<Rightarrow> ('t2 \<Longrightarrow> '\<alpha>) \<Rightarrow> ('t1, '\<alpha>) uexpr \<Rightarrow> ('t2, '\<alpha>) uexpr \<Rightarrow> '\<alpha> hrel"
where "assign_2_r x y u v \<equiv> assigns_r [x \<mapsto>\<^sub>s u, y \<mapsto>\<^sub>s v]"

text \<open> We also define the alphabetised skip operator that identifies all input and output variables
  in the given alphabet lens. All other variables are unrestricted. We also set up syntax for it. \<close>

definition skip_ra :: "('\<beta>, '\<alpha>) lens \<Rightarrow>'\<alpha> hrel" where
[urel_defs]: "skip_ra v = ($v\<acute> =\<^sub>u $v)"

text \<open> Similarly, we define the alphabetised assignment operator. \<close>

definition assigns_ra :: "'\<alpha> usubst \<Rightarrow> ('\<beta>, '\<alpha>) lens \<Rightarrow> '\<alpha> hrel" ("\<langle>_\<rangle>\<^bsub>_\<^esub>") where
"\<langle>\<sigma>\<rangle>\<^bsub>a\<^esub> = (\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> skip_ra a)"

text \<open> Assumptions ($c^{\top}$) and assertions ($c_{\bot}$) are encoded as conditionals. An assumption
  behaves like skip if the condition is true, and otherwise behaves like @{term false} (miracle).
  An assertion is the same, but yields @{term true}, which is an abort. They are the same as
  tests, as in Kleene Algebra with Tests~\cite{kozen1997kleene,Armstrong2015}
  (KAT), which embeds a Boolean algebra into a Kleene algebra to represent conditions. \<close>

definition rassume :: "'\<alpha> upred \<Rightarrow> '\<alpha> hrel" ("[_]\<^sup>\<top>") where
[urel_defs]: "rassume c = II \<triangleleft> c \<triangleright>\<^sub>r false"

notation rassume ("?[_]")

utp_lift_notation rassume

definition rassert :: "'\<alpha> upred \<Rightarrow> '\<alpha> hrel" ("{_}\<^sub>\<bottom>") where
[urel_defs]: "rassert c = II \<triangleleft> c \<triangleright>\<^sub>r true"

utp_lift_notation rassert

text \<open> We also encode ``naked'' guarded commands~\cite{Dijkstra75,Morgan90} by composing an
  assumption with a relation. \<close>

definition rgcmd :: "'a upred \<Rightarrow> 'a hrel \<Rightarrow> 'a hrel" ("_ \<longrightarrow>\<^sub>r _" [55, 56] 55) where
[urel_defs]: "rgcmd b P = (rassume b ;; P)"

utp_lift_notation rgcmd (1)

text \<open> We define two variants of while loops based on strongest and weakest fixed points. The former
  is @{term false} for an infinite loop, and the latter is @{term true}. \<close>

definition while_top :: "'\<alpha> cond \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" ("while\<^sup>\<top> _ do _ od") where
[urel_defs]: "while_top b P = (\<nu> X \<bullet> (P ;; X) \<triangleleft> b \<triangleright>\<^sub>r II)"

notation while_top ("while _ do _ od")

utp_lift_notation while_top (1)

definition while_bot :: "'\<alpha> cond \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" ("while\<^sub>\<bottom> _ do _ od") where
[urel_defs]: "while_bot b P = (\<mu> X \<bullet> (P ;; X) \<triangleleft> b \<triangleright>\<^sub>r II)"

utp_lift_notation while_bot (1)

text \<open> While loops with invariant decoration (cf. \cite{Armstrong2015}) -- partial correctness. \<close>

definition while_inv :: "'\<alpha> cond \<Rightarrow> '\<alpha> cond \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" ("while _ invr _ do _ od") where
[urel_defs]: "while_inv b p S = while_top b S"

utp_lift_notation while_inv (2)

text \<open> While loops with invariant decoration -- total correctness. \<close>

definition while_inv_bot :: "'\<alpha> cond \<Rightarrow> '\<alpha> cond \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" ("while\<^sub>\<bottom> _ invr _ do _ od" 71) where
[urel_defs]: "while_inv_bot b p S = while_bot b S"

utp_lift_notation while_inv_bot (2)

text \<open> While loops with invariant and variant decorations -- total correctness. \<close>

definition while_vrt ::
  "'\<alpha> cond \<Rightarrow> '\<alpha> cond \<Rightarrow> (nat, '\<alpha>) uexpr \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel"  ("while _ invr _ vrt _ do _ od") where
[urel_defs]: "while_vrt b p v S = while_bot b S"

utp_lift_notation while_vrt (3)

translations
  "?[b]" <= "?[U(b)]"
  "{b}\<^sub>\<bottom>" <= "{U(b)}\<^sub>\<bottom>"
  "while b do P od" <= "while U(b) do P od"
  "while b invr c do P od" <= "while U(b) invr U(c) do P od"

text \<open> We implement a poor man's version of alphabet restriction that hides a variable within
  a relation. \<close>

definition rel_var_res :: "'\<alpha> hrel \<Rightarrow> ('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> hrel" (infix "\<restriction>\<^sub>\<alpha>" 80) where
[urel_defs]: "P \<restriction>\<^sub>\<alpha> x = (\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P)"

subsection \<open> Syntax Translations \<close>

\<comment> \<open> Alternative traditional conditional syntax \<close>

abbreviation (input) rifthenelse ("(if (_)/ then (_)/ else (_)/ fi)")
  where "rifthenelse b P Q \<equiv> P \<triangleleft> b \<triangleright>\<^sub>r Q"

abbreviation (input) rifthen ("(if (_)/ then (_)/ fi)")
  where "rifthen b P \<equiv> rifthenelse b P II"

utp_lift_notation rifthenelse (1 2)
utp_lift_notation rifthen (1)

syntax
  \<comment> \<open> Iterated sequential composition \<close>
  "_seqr_iter" :: "pttrn \<Rightarrow> 'a list \<Rightarrow> '\<sigma> hrel \<Rightarrow> '\<sigma> hrel" ("(3;; _ : _ \<bullet>/ _)" [0, 0, 10] 10)
  \<comment> \<open> Single and multiple assignement \<close>
  "_assignment"     :: "svids \<Rightarrow> uexprs \<Rightarrow> '\<alpha> hrel"  ("'(_') := '(_')")
  "_assignment"     :: "svids \<Rightarrow> uexprs \<Rightarrow> '\<alpha> hrel"  (infixr ":=" 62)
  \<comment> \<open> Non-deterministic assignment \<close>
  "_nd_assign" :: "svids \<Rightarrow> logic" ("_ := *" [62] 62)
  \<comment> \<open> Substitution constructor \<close>
  "_mk_usubst"      :: "svids \<Rightarrow> uexprs \<Rightarrow> '\<alpha> usubst"
  \<comment> \<open> Alphabetised skip \<close>
  "_skip_ra"        :: "salpha \<Rightarrow> logic" ("II\<^bsub>_\<^esub>")

translations
  ";; x : l \<bullet> P" \<rightleftharpoons> "(CONST seqr_iter) l (\<lambda>x. P)"
  "_mk_usubst \<sigma> (_svid_unit x) v" \<rightleftharpoons> "\<sigma>(&x \<mapsto>\<^sub>s v)"
  "_mk_usubst \<sigma> (_svid_list x xs) (_uexprs v vs)" \<rightleftharpoons> "(_mk_usubst (\<sigma>(&x \<mapsto>\<^sub>s v)) xs vs)"
  "_assignment xs vs" => "CONST uassigns (_mk_usubst id\<^sub>s xs vs)"
  "_assignment x v" <= "CONST uassigns (CONST subst_upd id\<^sub>s x v)"
  "_assignment x v" <= "_assignment (_spvar x) v"
  "_assignment x v" <= "_assignment x (_UTP v)"
  "_nd_assign x" => "CONST nd_assign (_mk_svid_list x)"
  "_nd_assign x" <= "CONST nd_assign x"
  "x,y := u,v" <= "CONST uassigns (CONST subst_upd (CONST subst_upd id\<^sub>s (CONST pr_var x) u) (CONST pr_var y) v)"
  "_skip_ra v" \<rightleftharpoons> "CONST skip_ra v"

text \<open> The following code sets up pretty-printing for homogeneous relational expressions. We cannot
  do this via the ``translations'' command as we only want the rule to apply when the input and output
  alphabet types are the same. The code has to deconstruct a @{typ "('a, '\<alpha>) uexpr"} type, determine
  that it is relational (product alphabet), and then checks if the types \emph{alpha} and \emph{beta}
  are the same. If they are, the type is printed as a \emph{hexpr}. Otherwise, we have no match.
  We then set up a regular translation for the \emph{hrel} type that uses this. \<close>

print_translation \<open>
let
fun tr' ctx [ a
            , Const (@{type_syntax "prod"},_) $ alpha $ beta ] =
  if (alpha = beta)
    then Syntax.const @{type_syntax "hexpr"} $ a $ alpha
    else raise Match;
in [(@{type_syntax "uexpr"},tr')]
end
\<close>

translations
  (type) "'\<alpha> hrel" <= (type) "(bool, '\<alpha>) hexpr"

subsection \<open> Relation Properties \<close>

text \<open> We describe some properties of relations, including functional and injective relations. We
  also provide operators for extracting the domain and range of a UTP relation. \<close>

definition ufunctional :: "('a, 'b) urel \<Rightarrow> bool"
where [urel_defs]: "ufunctional R \<longleftrightarrow> II \<sqsubseteq> R\<^sup>- ;; R"

definition uinj :: "('a, 'b) urel \<Rightarrow> bool"
where [urel_defs]: "uinj R \<longleftrightarrow> II \<sqsubseteq> R ;; R\<^sup>-"

definition Pre :: "('\<alpha>, '\<beta>) urel \<Rightarrow> '\<alpha> upred"
where [upred_defs]: "Pre P = \<lfloor>\<exists> $\<^bold>v\<acute> \<bullet> P\<rfloor>\<^sub><"

definition Post :: "('\<alpha>, '\<beta>) urel \<Rightarrow> '\<beta> upred"
where [upred_defs]: "Post P = \<lfloor>\<exists> $\<^bold>v \<bullet> P\<rfloor>\<^sub>>"

utp_const Pre Post

\<comment> \<open> Configuration for UTP tactics. \<close>

update_uexpr_rep_eq_thms \<comment> \<open> Reread @{text rep_eq} theorems. \<close>

subsection \<open> Introduction laws \<close>

lemma urel_refine_ext:
  "\<lbrakk> \<And> s s'. P\<lbrakk>\<guillemotleft>s\<guillemotright>,\<guillemotleft>s'\<guillemotright>/$\<^bold>v,$\<^bold>v\<acute>\<rbrakk> \<sqsubseteq> Q\<lbrakk>\<guillemotleft>s\<guillemotright>,\<guillemotleft>s'\<guillemotright>/$\<^bold>v,$\<^bold>v\<acute>\<rbrakk> \<rbrakk> \<Longrightarrow> P \<sqsubseteq> Q"
  by (rel_auto)

lemma urel_eq_ext:
  "\<lbrakk> \<And> s s'. P\<lbrakk>\<guillemotleft>s\<guillemotright>,\<guillemotleft>s'\<guillemotright>/$\<^bold>v,$\<^bold>v\<acute>\<rbrakk> = Q\<lbrakk>\<guillemotleft>s\<guillemotright>,\<guillemotleft>s'\<guillemotright>/$\<^bold>v,$\<^bold>v\<acute>\<rbrakk> \<rbrakk> \<Longrightarrow> P = Q"
  by (rel_auto)

subsection \<open> Unrestriction Laws \<close>

lemma unrest_iuvar [unrest]: "out\<alpha> \<sharp> $x"
  by (metis fst_snd_lens_indep lift_pre_var out\<alpha>_def unrest_aext_indep)

lemma unrest_ouvar [unrest]: "in\<alpha> \<sharp> $x\<acute>"
  by (metis in\<alpha>_def lift_post_var snd_fst_lens_indep unrest_aext_indep)

lemma unrest_semir_undash [unrest]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  assumes "$x \<sharp> P"
  shows "$x \<sharp> P ;; Q"
  using assms by (rel_auto)

lemma unrest_semir_dash [unrest]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  assumes "$x\<acute> \<sharp> Q"
  shows "$x\<acute> \<sharp> P ;; Q"
  using assms by (rel_auto)

lemma unrest_cond [unrest]:
  "\<lbrakk> x \<sharp> P; x \<sharp> b; x \<sharp> Q \<rbrakk> \<Longrightarrow> x \<sharp> P \<triangleleft> b \<triangleright> Q"
  by (rel_auto)

lemma unrest_lift_rcond [unrest]:
  "x \<sharp> \<lceil>b\<rceil>\<^sub>< \<Longrightarrow> x \<sharp> \<lceil>b\<rceil>\<^sub>\<leftarrow>"
  by (simp add: lift_rcond_def)

lemma unrest_in\<alpha>_var [unrest]:
  "\<lbrakk> mwb_lens x; in\<alpha> \<sharp> (P :: ('a, ('\<alpha> \<times> '\<beta>)) uexpr) \<rbrakk> \<Longrightarrow> $x \<sharp> P"
  by (rel_auto)

lemma unrest_out\<alpha>_var [unrest]:
  "\<lbrakk> mwb_lens x; out\<alpha> \<sharp> (P :: ('a, ('\<alpha> \<times> '\<beta>)) uexpr) \<rbrakk> \<Longrightarrow> $x\<acute> \<sharp> P"
  by (rel_auto)

lemma unrest_pre_out\<alpha> [unrest]: "out\<alpha> \<sharp> \<lceil>b\<rceil>\<^sub><"
  by (transfer, auto simp add: out\<alpha>_def)

lemma unrest_post_in\<alpha> [unrest]: "in\<alpha> \<sharp> \<lceil>b\<rceil>\<^sub>>"
  by (transfer, auto simp add: in\<alpha>_def)

lemma unrest_pre_in_var [unrest]:
  "x \<sharp> p1 \<Longrightarrow> $x \<sharp> \<lceil>p1\<rceil>\<^sub><"
  by (transfer, simp)

lemma unrest_post_out_var [unrest]:
  "x \<sharp> p1 \<Longrightarrow> $x\<acute> \<sharp> \<lceil>p1\<rceil>\<^sub>>"
  by (transfer, simp)

lemma unrest_convr_out\<alpha> [unrest]:
  "in\<alpha> \<sharp> p \<Longrightarrow> out\<alpha> \<sharp> p\<^sup>-"
  by (transfer, auto simp add: lens_defs)

lemma unrest_convr_in\<alpha> [unrest]:
  "out\<alpha> \<sharp> p \<Longrightarrow> in\<alpha> \<sharp> p\<^sup>-"
  by (transfer, auto simp add: lens_defs)

lemma unrest_out_alpha_usubst_rel_lift [unrest]:
  "out\<alpha> \<sharp>\<^sub>s \<lceil>\<sigma>\<rceil>\<^sub>s"
  by (rel_auto)

lemma unrest_in_rel_var_res [unrest]:
  "vwb_lens x \<Longrightarrow> $x \<sharp> (P \<restriction>\<^sub>\<alpha> x)"
  by (simp add: rel_var_res_def unrest)

lemma unrest_out_rel_var_res [unrest]:
  "vwb_lens x \<Longrightarrow> $x\<acute> \<sharp> (P \<restriction>\<^sub>\<alpha> x)"
  by (simp add: rel_var_res_def unrest)

subsection \<open> Substitution laws \<close>

lemma subst_seq_left [usubst]:
  "out\<alpha> \<sharp>\<^sub>s \<sigma> \<Longrightarrow> \<sigma> \<dagger> (P ;; Q) = (\<sigma> \<dagger> P) ;; Q"
  by (rel_simp, (metis (no_types, lifting) Pair_inject surjective_pairing)+)

lemma subst_seq_right [usubst]:
  "in\<alpha> \<sharp>\<^sub>s \<sigma> \<Longrightarrow> \<sigma> \<dagger> (P ;; Q) = P ;; (\<sigma> \<dagger> Q)"
  by (rel_simp, (metis (no_types, lifting) Pair_inject surjective_pairing)+)

text \<open> The following laws support substitution in heterogeneous relations for polymorphically
  typed literal expressions. These cannot be supported more generically due to limitations
  in HOL's type system. The laws are presented in a slightly strange way so as to be as
  general as possible. \<close>

lemma bool_seqr_laws [usubst]:
  fixes x :: "(bool \<Longrightarrow> '\<alpha>)"
  shows
    "\<And> P Q \<sigma>. \<sigma>($x \<mapsto>\<^sub>s true) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P\<lbrakk>true/$x\<rbrakk> ;; Q)"
    "\<And> P Q \<sigma>. \<sigma>($x \<mapsto>\<^sub>s false) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P\<lbrakk>false/$x\<rbrakk> ;; Q)"
    "\<And> P Q \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s true) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P ;; Q\<lbrakk>true/$x\<acute>\<rbrakk>)"
    "\<And> P Q \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s false) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P ;; Q\<lbrakk>false/$x\<acute>\<rbrakk>)"
    by (rel_auto)+

lemma zero_one_seqr_laws [usubst]:
  fixes x :: "(_ \<Longrightarrow> '\<alpha>)"
  shows
    "\<And> P Q \<sigma>. \<sigma>($x \<mapsto>\<^sub>s 0) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P\<lbrakk>0/$x\<rbrakk> ;; Q)"
    "\<And> P Q \<sigma>. \<sigma>($x \<mapsto>\<^sub>s 1) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P\<lbrakk>1/$x\<rbrakk> ;; Q)"
    "\<And> P Q \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s 0) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P ;; Q\<lbrakk>0/$x\<acute>\<rbrakk>)"
    "\<And> P Q \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s 1) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P ;; Q\<lbrakk>1/$x\<acute>\<rbrakk>)"
    by (rel_auto)+

lemma numeral_seqr_laws [usubst]:
  fixes x :: "(_ \<Longrightarrow> '\<alpha>)"
  shows
    "\<And> P Q \<sigma>. \<sigma>($x \<mapsto>\<^sub>s numeral n) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P\<lbrakk>numeral n/$x\<rbrakk> ;; Q)"
    "\<And> P Q \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s numeral n) \<dagger> (P ;; Q) = \<sigma> \<dagger> (P ;; Q\<lbrakk>numeral n/$x\<acute>\<rbrakk>)"
  by (rel_auto)+

lemma usubst_condr [usubst]:
  "\<sigma> \<dagger> (P \<triangleleft> b \<triangleright> Q) = (\<sigma> \<dagger> P \<triangleleft> \<sigma> \<dagger> b \<triangleright> \<sigma> \<dagger> Q)"
  by (rel_auto)

lemma subst_skip_r [usubst]:
  "out\<alpha> \<sharp>\<^sub>s \<sigma> \<Longrightarrow> \<sigma> \<dagger> II = \<langle>\<lfloor>\<sigma>\<rfloor>\<^sub>s\<rangle>\<^sub>a"
  by (rel_simp, (metis (mono_tags, lifting) prod.sel(1) sndI surjective_pairing)+)

lemma subst_pre_skip [usubst]: "\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> II = \<langle>\<sigma>\<rangle>\<^sub>a"
  by (rel_auto)

lemma subst_rel_lift_seq [usubst]:
  "\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> (P ;; Q) = (\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> P) ;; Q"
  by (rel_auto)

lemma subst_rel_lift_comp [usubst]:
  "\<lceil>\<sigma>\<rceil>\<^sub>s \<circ>\<^sub>s \<lceil>\<rho>\<rceil>\<^sub>s = \<lceil>\<sigma> \<circ>\<^sub>s \<rho>\<rceil>\<^sub>s"
  by (rel_auto)

lemma usubst_upd_in_comp [usubst]:
  "\<sigma>(&in\<alpha>:x \<mapsto>\<^sub>s v) = \<sigma>($x \<mapsto>\<^sub>s v)"
  by (simp add: pr_var_def fst_lens_def in\<alpha>_def in_var_def)

lemma usubst_upd_out_comp [usubst]:
  "\<sigma>(&out\<alpha>:x \<mapsto>\<^sub>s v) = \<sigma>($x\<acute> \<mapsto>\<^sub>s v)"
  by (simp add: pr_var_def out\<alpha>_def out_var_def snd_lens_def)

lemma subst_lift_upd [alpha]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "\<lceil>\<sigma>(x \<mapsto>\<^sub>s v)\<rceil>\<^sub>s = \<lceil>\<sigma>\<rceil>\<^sub>s($x \<mapsto>\<^sub>s \<lceil>v\<rceil>\<^sub><)"
  by (simp add: alpha usubst, simp add: pr_var_def fst_lens_def in\<alpha>_def in_var_def)

lemma subst_drop_upd [alpha]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "\<lfloor>\<sigma>($x \<mapsto>\<^sub>s v)\<rfloor>\<^sub>s = \<lfloor>\<sigma>\<rfloor>\<^sub>s(x \<mapsto>\<^sub>s \<lfloor>v\<rfloor>\<^sub><)"
  by pred_simp

lemma subst_lift_pre [usubst]: "\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> \<lceil>b\<rceil>\<^sub>< = \<lceil>\<sigma> \<dagger> b\<rceil>\<^sub><"
  by (metis apply_subst_ext fst_vwb_lens in\<alpha>_def)

lemma unrest_usubst_lift_in [unrest]:
  "x \<sharp> P \<Longrightarrow> $x \<sharp> \<lceil>P\<rceil>\<^sub>s"
  by pred_simp

lemma unrest_usubst_lift_out [unrest]:
  fixes x :: "('a \<Longrightarrow> '\<alpha>)"
  shows "$x\<acute> \<sharp>\<^sub>s \<lceil>P\<rceil>\<^sub>s"
  by pred_simp

lemma subst_lift_cond [usubst]: "\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> \<lceil>s\<rceil>\<^sub>\<leftarrow> = \<lceil>\<sigma> \<dagger> s\<rceil>\<^sub>\<leftarrow>"
  by (rel_auto)

lemma msubst_seq [usubst]: "(P(x) ;; Q(x))\<lbrakk>x\<rightarrow>\<guillemotleft>v\<guillemotright>\<rbrakk> = ((P(x))\<lbrakk>x\<rightarrow>\<guillemotleft>v\<guillemotright>\<rbrakk> ;; (Q(x))\<lbrakk>x\<rightarrow>\<guillemotleft>v\<guillemotright>\<rbrakk>)"
  by (rel_auto)

subsection \<open> Alphabet laws \<close>

lemma aext_cond [alpha]:
  "(P \<triangleleft> b \<triangleright> Q) \<oplus>\<^sub>p a = ((P \<oplus>\<^sub>p a) \<triangleleft> (b \<oplus>\<^sub>p a) \<triangleright> (Q \<oplus>\<^sub>p a))"
  by (rel_auto)

lemma aext_seq [alpha]:
  "wb_lens a \<Longrightarrow> ((P ;; Q) \<oplus>\<^sub>p (a \<times>\<^sub>L a)) = ((P \<oplus>\<^sub>p (a \<times>\<^sub>L a)) ;; (Q \<oplus>\<^sub>p (a \<times>\<^sub>L a)))"
  by (rel_simp, metis wb_lens_weak weak_lens.put_get)

lemma rcond_lift_true [simp]:
  "\<lceil>true\<rceil>\<^sub>\<leftarrow> = true"
  by rel_auto

lemma rcond_lift_false [simp]:
  "\<lceil>false\<rceil>\<^sub>\<leftarrow> = false"
  by rel_auto

no_utp_lift rcond uassigns id seqr useq uskip rcond rassume rassert
  conv_r rgcmd while_top while_bot while_inv while_inv_bot while_vrt

end


(*  Title:      ZF/Constructible/WF_absolute.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section {*Absoluteness of Well-Founded Recursion*}

theory WF_absolute imports WFrec begin

subsection{*Transitive closure without fixedpoints*}

definition
  rtrancl_alt :: "[i,i]=>i" where
    "rtrancl_alt(A,r) ==
       {p \<in> A*A. \<exists>n\<in>nat. \<exists>f \<in> succ(n) -> A.
                 (\<exists>x y. p = <x,y> &  f`0 = x & f`n = y) &
                       (\<forall>i\<in>n. <f`i, f`succ(i)> \<in> r)}"

lemma alt_rtrancl_lemma1 [rule_format]:
    "n \<in> nat
     ==> \<forall>f \<in> succ(n) -> field(r).
         (\<forall>i\<in>n. \<langle>f`i, f ` succ(i)\<rangle> \<in> r) \<longrightarrow> \<langle>f`0, f`n\<rangle> \<in> r^*"
apply (induct_tac n)
apply (simp_all add: apply_funtype rtrancl_refl, clarify)
apply (rename_tac n f)
apply (rule rtrancl_into_rtrancl)
 prefer 2 apply assumption
apply (drule_tac x="restrict(f,succ(n))" in bspec)
 apply (blast intro: restrict_type2)
apply (simp add: Ord_succ_mem_iff nat_0_le [THEN ltD] leI [THEN ltD] ltI)
done

lemma rtrancl_alt_subset_rtrancl: "rtrancl_alt(field(r),r) \<subseteq> r^*"
apply (simp add: rtrancl_alt_def)
apply (blast intro: alt_rtrancl_lemma1)
done

lemma rtrancl_subset_rtrancl_alt: "r^* \<subseteq> rtrancl_alt(field(r),r)"
apply (simp add: rtrancl_alt_def, clarify)
apply (frule rtrancl_type [THEN subsetD], clarify, simp)
apply (erule rtrancl_induct)
 txt{*Base case, trivial*}
 apply (rule_tac x=0 in bexI)
  apply (rule_tac x="\<lambda>x\<in>1. xa" in bexI)
   apply simp_all
txt{*Inductive step*}
apply clarify
apply (rename_tac n f)
apply (rule_tac x="succ(n)" in bexI)
 apply (rule_tac x="\<lambda>i\<in>succ(succ(n)). if i=succ(n) then z else f`i" in bexI)
  apply (simp add: Ord_succ_mem_iff nat_0_le [THEN ltD] leI [THEN ltD] ltI)
  apply (blast intro: mem_asym)
 apply typecheck
 apply auto
done

lemma rtrancl_alt_eq_rtrancl: "rtrancl_alt(field(r),r) = r^*"
by (blast del: subsetI
          intro: rtrancl_alt_subset_rtrancl rtrancl_subset_rtrancl_alt)

definition
  rtran_closure_mem :: "[i=>o,i,i,i] => o" where
    --{*The property of belonging to @{text "rtran_closure(r)"}*}
    "rtran_closure_mem(M,A,r,p) ==
              \<exists>nnat[M]. \<exists>n[M]. \<exists>n'[M].
               omega(M,nnat) & n\<in>nnat & successor(M,n,n') &
               (\<exists>f[M]. typed_function(M,n',A,f) &
                (\<exists>x[M]. \<exists>y[M]. \<exists>zero[M]. pair(M,x,y,p) & empty(M,zero) &
                  fun_apply(M,f,zero,x) & fun_apply(M,f,n,y)) &
                  (\<forall>j[M]. j\<in>n \<longrightarrow>
                    (\<exists>fj[M]. \<exists>sj[M]. \<exists>fsj[M]. \<exists>ffp[M].
                      fun_apply(M,f,j,fj) & successor(M,j,sj) &
                      fun_apply(M,f,sj,fsj) & pair(M,fj,fsj,ffp) & ffp \<in> r)))"

definition
  rtran_closure :: "[i=>o,i,i] => o" where
    "rtran_closure(M,r,s) ==
        \<forall>A[M]. is_field(M,r,A) \<longrightarrow>
         (\<forall>p[M]. p \<in> s \<longleftrightarrow> rtran_closure_mem(M,A,r,p))"

definition
  tran_closure :: "[i=>o,i,i] => o" where
    "tran_closure(M,r,t) ==
         \<exists>s[M]. rtran_closure(M,r,s) & composition(M,r,s,t)"

lemma (in M_basic) rtran_closure_mem_iff:
     "[|M(A); M(r); M(p)|]
      ==> rtran_closure_mem(M,A,r,p) \<longleftrightarrow>
          (\<exists>n[M]. n\<in>nat &
           (\<exists>f[M]. f \<in> succ(n) -> A &
            (\<exists>x[M]. \<exists>y[M]. p = <x,y> & f`0 = x & f`n = y) &
                           (\<forall>i\<in>n. <f`i, f`succ(i)> \<in> r)))"
by (simp add: rtran_closure_mem_def Ord_succ_mem_iff nat_0_le [THEN ltD])

locale M_trancl = M_basic +
  assumes rtrancl_separation:
         "[| M(r); M(A) |] ==> separation (M, rtran_closure_mem(M,A,r))"
      and wellfounded_trancl_separation:
         "[| M(r); M(Z) |] ==>
          separation (M, \<lambda>x.
              \<exists>w[M]. \<exists>wx[M]. \<exists>rp[M].
               w \<in> Z & pair(M,w,x,wx) & tran_closure(M,r,rp) & wx \<in> rp)"

lemma (in M_trancl) rtran_closure_rtrancl:
     "M(r) ==> rtran_closure(M,r,rtrancl(r))"
apply (simp add: rtran_closure_def rtran_closure_mem_iff
                 rtrancl_alt_eq_rtrancl [symmetric] rtrancl_alt_def)
apply (auto simp add: nat_0_le [THEN ltD] apply_funtype)
done

lemma (in M_trancl) rtrancl_closed [intro,simp]:
     "M(r) ==> M(rtrancl(r))"
apply (insert rtrancl_separation [of r "field(r)"])
apply (simp add: rtrancl_alt_eq_rtrancl [symmetric]
                 rtrancl_alt_def rtran_closure_mem_iff)
done

lemma (in M_trancl) rtrancl_abs [simp]:
     "[| M(r); M(z) |] ==> rtran_closure(M,r,z) \<longleftrightarrow> z = rtrancl(r)"
apply (rule iffI)
 txt{*Proving the right-to-left implication*}
 prefer 2 apply (blast intro: rtran_closure_rtrancl)
apply (rule M_equalityI)
apply (simp add: rtran_closure_def rtrancl_alt_eq_rtrancl [symmetric]
                 rtrancl_alt_def rtran_closure_mem_iff)
apply (auto simp add: nat_0_le [THEN ltD] apply_funtype)
done

lemma (in M_trancl) trancl_closed [intro,simp]:
     "M(r) ==> M(trancl(r))"
by (simp add: trancl_def comp_closed rtrancl_closed)

lemma (in M_trancl) trancl_abs [simp]:
     "[| M(r); M(z) |] ==> tran_closure(M,r,z) \<longleftrightarrow> z = trancl(r)"
by (simp add: tran_closure_def trancl_def)

lemma (in M_trancl) wellfounded_trancl_separation':
     "[| M(r); M(Z) |] ==> separation (M, \<lambda>x. \<exists>w[M]. w \<in> Z & <w,x> \<in> r^+)"
by (insert wellfounded_trancl_separation [of r Z], simp)

text{*Alternative proof of @{text wf_on_trancl}; inspiration for the
      relativized version.  Original version is on theory WF.*}
lemma "[| wf[A](r);  r-``A \<subseteq> A |] ==> wf[A](r^+)"
apply (simp add: wf_on_def wf_def)
apply (safe intro!: equalityI)
apply (drule_tac x = "{x\<in>A. \<exists>w. \<langle>w,x\<rangle> \<in> r^+ & w \<in> Z}" in spec)
apply (blast elim: tranclE)
done

lemma (in M_trancl) wellfounded_on_trancl:
     "[| wellfounded_on(M,A,r);  r-``A \<subseteq> A; M(r); M(A) |]
      ==> wellfounded_on(M,A,r^+)"
apply (simp add: wellfounded_on_def)
apply (safe intro!: equalityI)
apply (rename_tac Z x)
apply (subgoal_tac "M({x\<in>A. \<exists>w[M]. w \<in> Z & \<langle>w,x\<rangle> \<in> r^+})")
 prefer 2
 apply (blast intro: wellfounded_trancl_separation')
apply (drule_tac x = "{x\<in>A. \<exists>w[M]. w \<in> Z & \<langle>w,x\<rangle> \<in> r^+}" in rspec, safe)
apply (blast dest: transM, simp)
apply (rename_tac y w)
apply (drule_tac x=w in bspec, assumption, clarify)
apply (erule tranclE)
  apply (blast dest: transM)   (*transM is needed to prove M(xa)*)
 apply blast
done

lemma (in M_trancl) wellfounded_trancl:
     "[|wellfounded(M,r); M(r)|] ==> wellfounded(M,r^+)"
apply (simp add: wellfounded_iff_wellfounded_on_field)
apply (rule wellfounded_on_subset_A, erule wellfounded_on_trancl)
   apply blast
  apply (simp_all add: trancl_type [THEN field_rel_subset])
done

text{*Absoluteness for wfrec-defined functions.*}

(*first use is_recfun, then M_is_recfun*)

lemma (in M_trancl) wfrec_relativize:
  "[|wf(r); M(a); M(r);
     strong_replacement(M, \<lambda>x z. \<exists>y[M]. \<exists>g[M].
          pair(M,x,y,z) &
          is_recfun(r^+, x, \<lambda>x f. H(x, restrict(f, r -`` {x})), g) &
          y = H(x, restrict(g, r -`` {x})));
     \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g))|]
   ==> wfrec(r,a,H) = z \<longleftrightarrow>
       (\<exists>f[M]. is_recfun(r^+, a, \<lambda>x f. H(x, restrict(f, r -`` {x})), f) &
            z = H(a,restrict(f,r-``{a})))"
apply (frule wf_trancl)
apply (simp add: wftrec_def wfrec_def, safe)
 apply (frule wf_exists_is_recfun
              [of concl: "r^+" a "\<lambda>x f. H(x, restrict(f, r -`` {x}))"])
      apply (simp_all add: trans_trancl function_restrictI trancl_subset_times)
 apply (clarify, rule_tac x=x in rexI)
 apply (simp_all add: the_recfun_eq trans_trancl trancl_subset_times)
done

text{*Assuming @{term r} is transitive simplifies the occurrences of @{text H}.
      The premise @{term "relation(r)"} is necessary
      before we can replace @{term "r^+"} by @{term r}. *}
theorem (in M_trancl) trans_wfrec_relativize:
  "[|wf(r);  trans(r);  relation(r);  M(r);  M(a);
     wfrec_replacement(M,MH,r);  relation2(M,MH,H);
     \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g))|]
   ==> wfrec(r,a,H) = z \<longleftrightarrow> (\<exists>f[M]. is_recfun(r,a,H,f) & z = H(a,f))"
apply (frule wfrec_replacement', assumption+)
apply (simp cong: is_recfun_cong
           add: wfrec_relativize trancl_eq_r
                is_recfun_restrict_idem domain_restrict_idem)
done

theorem (in M_trancl) trans_wfrec_abs:
  "[|wf(r);  trans(r);  relation(r);  M(r);  M(a);  M(z);
     wfrec_replacement(M,MH,r);  relation2(M,MH,H);
     \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g))|]
   ==> is_wfrec(M,MH,r,a,z) \<longleftrightarrow> z=wfrec(r,a,H)"
by (simp add: trans_wfrec_relativize [THEN iff_sym] is_wfrec_abs, blast)

lemma (in M_trancl) trans_eq_pair_wfrec_iff:
  "[|wf(r);  trans(r); relation(r); M(r);  M(y);
     wfrec_replacement(M,MH,r);  relation2(M,MH,H);
     \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g))|]
   ==> y = <x, wfrec(r, x, H)> \<longleftrightarrow>
       (\<exists>f[M]. is_recfun(r,x,H,f) & y = <x, H(x,f)>)"
apply safe
 apply (simp add: trans_wfrec_relativize [THEN iff_sym, of concl: _ x])
txt{*converse direction*}
apply (rule sym)
apply (simp add: trans_wfrec_relativize, blast)
done

subsection{*M is closed under well-founded recursion*}

text{*Lemma with the awkward premise mentioning @{text wfrec}.*}
lemma (in M_trancl) wfrec_closed_lemma [rule_format]:
     "[|wf(r); M(r);
        strong_replacement(M, \<lambda>x y. y = \<langle>x, wfrec(r, x, H)\<rangle>);
        \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g)) |]
      ==> M(a) \<longrightarrow> M(wfrec(r,a,H))"
apply (rule_tac a=a in wf_induct, assumption+)
apply (subst wfrec, assumption, clarify)
apply (drule_tac x1=x and x="\<lambda>x\<in>r -`` {x}. wfrec(r, x, H)"
       in rspec [THEN rspec])
apply (simp_all add: function_lam)
apply (blast intro: lam_closed dest: pair_components_in_M)
done

text{*Eliminates one instance of replacement.*}
lemma (in M_trancl) wfrec_replacement_iff:
     "strong_replacement(M, \<lambda>x z.
          \<exists>y[M]. pair(M,x,y,z) & (\<exists>g[M]. is_recfun(r,x,H,g) & y = H(x,g))) \<longleftrightarrow>
      strong_replacement(M,
           \<lambda>x y. \<exists>f[M]. is_recfun(r,x,H,f) & y = <x, H(x,f)>)"
apply simp
apply (rule strong_replacement_cong, blast)
done

text{*Useful version for transitive relations*}
theorem (in M_trancl) trans_wfrec_closed:
     "[|wf(r); trans(r); relation(r); M(r); M(a);
       wfrec_replacement(M,MH,r);  relation2(M,MH,H);
        \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g)) |]
      ==> M(wfrec(r,a,H))"
apply (frule wfrec_replacement', assumption+)
apply (frule wfrec_replacement_iff [THEN iffD1])
apply (rule wfrec_closed_lemma, assumption+)
apply (simp_all add: wfrec_replacement_iff trans_eq_pair_wfrec_iff)
done

subsection{*Absoluteness without assuming transitivity*}
lemma (in M_trancl) eq_pair_wfrec_iff:
  "[|wf(r);  M(r);  M(y);
     strong_replacement(M, \<lambda>x z. \<exists>y[M]. \<exists>g[M].
          pair(M,x,y,z) &
          is_recfun(r^+, x, \<lambda>x f. H(x, restrict(f, r -`` {x})), g) &
          y = H(x, restrict(g, r -`` {x})));
     \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g))|]
   ==> y = <x, wfrec(r, x, H)> \<longleftrightarrow>
       (\<exists>f[M]. is_recfun(r^+, x, \<lambda>x f. H(x, restrict(f, r -`` {x})), f) &
            y = <x, H(x,restrict(f,r-``{x}))>)"
apply safe
 apply (simp add: wfrec_relativize [THEN iff_sym, of concl: _ x])
txt{*converse direction*}
apply (rule sym)
apply (simp add: wfrec_relativize, blast)
done

text{*Full version not assuming transitivity, but maybe not very useful.*}
theorem (in M_trancl) wfrec_closed:
     "[|wf(r); M(r); M(a);
        wfrec_replacement(M,MH,r^+);
        relation2(M,MH, \<lambda>x f. H(x, restrict(f, r -`` {x})));
        \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g)) |]
      ==> M(wfrec(r,a,H))"
apply (frule wfrec_replacement'
               [of MH "r^+" "\<lambda>x f. H(x, restrict(f, r -`` {x}))"])
   prefer 4
   apply (frule wfrec_replacement_iff [THEN iffD1])
   apply (rule wfrec_closed_lemma, assumption+)
     apply (simp_all add: eq_pair_wfrec_iff func.function_restrictI)
done

end


\<^marker>\<open>creator "Maximilian P. L. Haslbeck"\<close>
\<^marker>\<open>contributor "Peter Lammich"\<close>
section \<open>Data Refinement\<close>
theory Data_Refinement
imports NREST  NREST_Type_Classes
begin

paragraph \<open>Summary\<close>
text \<open>This theory introduces data refinement.\<close>

subsection \<open>Definition\<close>

definition conc_fun  ("\<Down>") where
  "conc_fun R m \<equiv> case m of FAILi \<Rightarrow> FAILT | REST X \<Rightarrow> REST (\<lambda>c. Sup {X a| a. (c,a)\<in>R})"

definition abs_fun ("\<Up>") where
  "abs_fun R m \<equiv> case m of FAILi \<Rightarrow> FAILT
    | REST X \<Rightarrow> if dom X\<subseteq>Domain R then REST (\<lambda>a. Sup {X c| c. (c,a)\<in>R}) else FAILT"

lemma
  conc_fun_FAIL[simp]: "\<Down>R FAILT = FAILT" and
  conc_fun_RES: "\<Down>R (REST X) = REST (\<lambda>c. Sup {X a| a. (c,a)\<in>R})"
  unfolding conc_fun_def by (auto split: nrest.split)

lemma
  abs_fun_FAIL[simp]: "\<Up>R FAILT = FAILT" and
  abs_fun_RES: "\<Up>R (REST X) = (if dom X\<subseteq>Domain R then REST (\<lambda>a. Sup {X c| c. (c,a)\<in>R}) else FAILT)"
  unfolding abs_fun_def by (auto split: nrest.split)

lemma conc_fun_spec_ne_FAIL[simp]: "\<Down>R (SPECT M) \<noteq> FAILT" by (simp add: conc_fun_RES)

text \<open>a counter example\<close>
notepad begin
  \<^cancel>\<open>
  fix m m' :: "bool \<Rightarrow> ( (string,enat) acost) option" and R co x
  assume m: "m = [ True \<mapsto> acostC ((\<lambda>_. 0)(''a'':=2,''b'':=2)) ]"

  assume m': "m' = [ True \<mapsto> acostC ((\<lambda>_. 0)(''a'':=1,''b'':=2)), False \<mapsto> acostC ((\<lambda>_. 0)(''a'':=2,''b'':=1))]"
  assume "m \<le> (\<lambda>c. Sup {m' a |a. (c, a) \<in> R})"
        "m x = Some co"
  assume R_def: "R = {(True,False), (True,True)}"
  have i: "(\<lambda>c. Sup {m' a |a. (c, a) \<in> R}) = [ True \<mapsto> acostC ((\<lambda>_. 0)(''a'':=2,''b'':=2)) ]"
    apply (rule ext)
    subgoal for c
      apply(cases c)
      subgoal unfolding R_def m' apply auto unfolding Sup_option_def apply auto
        unfolding Sup_acost_def apply auto apply(rule ext) sorry
      subgoal unfolding R_def by (simp add: bot_option_def)
      done
    done
  have "m \<le> (\<lambda>c. Sup {m' a |a. (c, a) \<in> R})"
    unfolding i m by simp
  have "\<exists>x'. (x, x') \<in> R \<and> (\<exists>c'\<ge>co. m' x' = Some c')"
    sorry
\<close>
end

lemma SupSup_2: "Sup {m a |a. (c, a) \<in> R O S} =  Sup {m a |a b. (b,a)\<in>S \<and> (c,b)\<in>R }"
proof -
  have i: "\<And>a. (c,a) \<in> R O S \<longleftrightarrow> (\<exists>b. (b,a)\<in>S \<and> (c,b)\<in>R)" by auto
  have "Sup {m a |a. (c, a) \<in> R O S} = Sup {m a |a. (\<exists>b. (b,a)\<in>S \<and> (c,b)\<in>R)}"
      unfolding i by auto
    also have "...  = Sup {m a |a b. (b,a)\<in>S \<and> (c,b)\<in>R}" by auto
    finally show ?thesis .
  qed

lemma
  fixes m :: "'a \<Rightarrow> ('c::complete_lattice) option"
  shows SupSup: "Sup {Sup {m aa |aa. P a aa c} |a. Q a c} = Sup {m aa |a aa. P a aa c \<and> Q a c}"
  apply(rule antisym)
   subgoal apply(rule Sup_least)
     by (auto intro: Sup_subset_mono)
   subgoal
     unfolding Sup_le_iff apply auto
     by (smt Sup_upper Sup_upper2 mem_Collect_eq)
   done

lemma
  fixes m :: "'a \<Rightarrow> ('c::complete_lattice) option"
  shows
    SupSup_1: "Sup {Sup {m aa |aa. (a, aa) \<in> S} |a. (c, a) \<in> R} = Sup {m aa |a aa. (a,aa)\<in>S \<and> (c,a)\<in>R}"
  by(rule SupSup)

lemma project_acost_conc_fun_commute[refine_pw_simps]: "project_acost b (\<Down>R m) = \<Down>R (project_acost b m)"
  unfolding project_acost_def conc_fun_def
  apply(cases m)
  subgoal by simp
  subgoal
    supply *[simp] = continuous_option'[OF continuous_the_acost, THEN continuousD]
    apply simp
    apply(rule ext)
    apply(rule arg_cong[where f=Sup])
    by auto
  done

(*
lemma conc_fun_RES_sv: "single_valued R \<Longrightarrow>
  \<Down>R (REST X) = REST (\<lambda>c. if c\<in>Dom R then Some (X Sup {X a| a. (c,a)\<in>R})"
*)

lemma nrest_Rel_mono:
  fixes A :: "('a,'b::{complete_lattice,monoid_add}) nrest"
  shows "A \<le> B \<Longrightarrow> \<Down> R A \<le> \<Down> R B"
  unfolding conc_fun_def
  apply (auto split: nrest.split simp: le_fun_def)
  by (smt complete_lattice_class.Sup_mono mem_Collect_eq)

declare nrest_Rel_mono[trans]

lemma pw_conc_nofail[refine_pw_simps]:
  "nofailT (\<Down>R S) = nofailT S"
  by (cases S) (auto simp: conc_fun_RES)

lemma "single_valued A \<Longrightarrow> single_valued B \<Longrightarrow> single_valued (A O B)"
  by (simp add: single_valued_relcomp)

lemma Sup_enatoption_less2: " Sup X = Some \<infinity> \<Longrightarrow> (\<exists>x. Some x \<in> X \<and> enat t < x)"
  using Sup_enat_less2
  by (metis Sup_option_def in_these_eq option.distinct(1) option.sel)

lemma pw_conc_inres[refine_pw_simps]:
  "inresT (\<Down>R S') s t = (nofailT S'
  \<longrightarrow> ((\<exists>s'. (s,s')\<in>R \<and> inresT S' s' t) \<comment> \<open> \<and> (\<forall>s' t'. (s,s')\<in>R \<longrightarrow> inresT S' s' t' \<longrightarrow> t' \<le> t )\<close> ))"
  apply (cases S')
  subgoal by simp
  subgoal  for m'
    apply rule
    subgoal
      apply (auto simp: conc_fun_RES  )
      subgoal for t'
        apply(cases t')
         apply auto
        subgoal for n apply(auto dest!: Sup_finite_enat)
          subgoal for a apply(rule exI[where x=a]) apply auto
            apply(rule exI[where x="enat n"]) by auto
          done
        subgoal apply(drule Sup_enatoption_less2[where t=t])
          apply auto subgoal for x a apply(rule exI[where x=a]) apply auto
            apply(rule exI[where x=x]) by auto
          done
        done
      done
    subgoal
      apply (auto simp: conc_fun_RES)
      by (smt Sup_upper dual_order.trans le_some_optE mem_Collect_eq)
    done
  done

lemma bindT_conc_refine':
  fixes R' :: "('a\<times>'b) set" and R::"('c\<times>'d) set"
  assumes R1: "M \<le> \<Down> R' M'"
  assumes R2: "\<And>x x' t . \<lbrakk> (x,x')\<in>R'; inresT M x t; inresT M' x' t;
    nofailT M; nofailT M'
  \<rbrakk> \<Longrightarrow> f x \<le> \<Down> R (f' x')"
  shows "bindT M (\<lambda>x. f x) \<le> \<Down> R (bindT M' (\<lambda>x'. f' x'))"
  using assms
  apply (simp add: pw_le_iff refine_pw_simps)
  by blast

lemma bindT_conc_acost_refine:
  fixes M :: "(_,(_,enat)acost) nrest"
    and R' :: "('a\<times>'b) set" and R::"('c\<times>'d) set"
  assumes R1: "M \<le> \<Down> R' M'"
  assumes R2: "\<And>x x' t . \<lbrakk> (x,x')\<in>R';
    nofailT M; nofailT M'
  \<rbrakk> \<Longrightarrow> f x \<le> \<Down> R (f' x')"
  shows "bindT M (\<lambda>x. f x) \<le> \<Down> R (bindT M' (\<lambda>x'. f' x'))"
  using assms
  apply (simp add: pw_acost_le_iff refine_pw_simps)
  by metis

lemma bindT_conc_acost_refine':
  fixes M :: "(_,(_,enat)acost) nrest"
    and R' :: "('a\<times>'b) set" and R::"('c\<times>'d) set"
  assumes R1: "M \<le> \<Down> R' M'"
  assumes R2: "\<And>x x' t b. \<lbrakk> (x,x')\<in>R'; \<exists>t b. inresT (project_acost b M) x t; \<exists>t b. inresT (project_acost b M') x' t;
    nofailT M; nofailT M'
  \<rbrakk> \<Longrightarrow> f x \<le> \<Down> R (f' x')"
  shows "bindT M (\<lambda>x. f x) \<le> \<Down> R (bindT M' (\<lambda>x'. f' x'))"
  using assms
  apply (simp add: pw_acost_le_iff refine_pw_simps)
  by metis

lemma "(x,x')\<in>R \<Longrightarrow> (RETURNT x ::(_,'a::{nonneg,order,complete_lattice,monoid_add}) nrest ) \<le> \<Down>R (RETURNT x')"
  unfolding conc_fun_def RETURNT_def apply (auto simp: le_fun_def)
proof -
  consider "{uu:: 'a option. \<exists>a. (a = x' \<longrightarrow> uu = Some 0) \<and> (a \<noteq> x' \<longrightarrow> uu = None \<and> (x, a) \<in> R)} = { Some 0, None}"
    | "{uu:: 'a option. \<exists>a. (a = x' \<longrightarrow> uu = Some 0) \<and> (a \<noteq> x' \<longrightarrow> uu = None \<and> (x, a) \<in> R)} = { Some 0}"
    by auto
  then show " Sup {uu:: 'a option. \<exists>a. (a = x' \<longrightarrow> uu = Some 0) \<and> (a \<noteq> x' \<longrightarrow> uu = None \<and> (x, a) \<in> R)} \<ge> Some 0"
    apply cases by simp_all
qed

(*
experiment
begin

lemma bindT_refine'':
  fixes R' :: "('a\<times>'b) set" and R::"('c\<times>'d) set"
  assumes R1: "M \<le> \<Down> R' M'"
  assumes R2: "\<And>x x' t . \<lbrakk> (x,x')\<in>R'
  \<rbrakk> \<Longrightarrow> f x \<le> \<Down> R (f' x')"
  shows "bindT M (\<lambda>x. f x) \<le> \<Down> R (bindT M' (\<lambda>x'. f' x'))"
  sorry

lemma bindT_mono_under_timerefine:
  fixes R :: "('a \<Rightarrow> ('a, enat) acost)"
  assumes wfR: "wfR R"
  shows "m \<le> timerefine R m' \<Longrightarrow> (\<And>x. f x \<le> timerefine R (f' x)) \<Longrightarrow> bindT m f \<le> timerefine R (bindT m' f')"
  apply(rule order.trans) defer apply(subst timerefine_bindT_ge) using assms apply simp apply simp
  apply(rule bindT_mono_f2) by simp_all

thm bindT_refine'' bindT_mono_under_timerefine

lemma
  assumes "wfR tR" and sv: "single_valued R" and sv: "single_valued R'"
  assumes R1: "M \<le> (timerefine tR (\<Down> R'  M'))"
  assumes R2: "\<And>x x' t . \<lbrakk> (x,x')\<in>R' \<rbrakk> \<Longrightarrow> f x \<le> (timerefine tR ( \<Down> R  (f' x')))"
  shows "bindT M (\<lambda>x. f x) \<le> (timerefine tR (\<Down> R  (bindT M' (\<lambda>x'. f' x'))))"
  apply(subst datarefine_timerefine_commute[symmetric, OF assms(1,2)])

  apply(rule order.trans)
   defer apply(rule nrest_Rel_mono) apply(subst timerefine_bindT_ge[OF assms(1)]) apply simp
  apply(rule bindT_refine''[where R'=R'])
  apply(rule order.trans[OF R1])
   apply(subst datarefine_timerefine_commute[  OF assms(1,3)]) apply simp
  apply(rule order.trans[OF R2]) apply simp
  apply(subst datarefine_timerefine_commute[  OF assms(1,2)]) apply simp
  done

lemma
  assumes "wfR tR"
  assumes R1: "M \<le> (\<Down> R'(timerefine tR   M'))"
  assumes R2: "\<And>x x' t . \<lbrakk> (x,x')\<in>R' \<rbrakk> \<Longrightarrow> f x \<le> ( \<Down> R (timerefine tR  (f' x')))"
  shows "bindT M (\<lambda>x. f x) \<le> (\<Down> R (timerefine tR   (bindT M' (\<lambda>x'. f' x'))))"
  apply(rule order.trans)
   defer apply(rule nrest_Rel_mono) apply(subst timerefine_bindT_ge[OF assms(1)]) apply simp
  apply(rule bindT_refine''[where R'=R'])
  apply(rule R1)
  apply(rule R2) by simp

end *)

subsection \<open>Interaction with monadic operators\<close>

lemma conc_fun_consume:
  fixes M :: "('c, (_,enat) acost ) nrest"
  shows "\<Down>R (consume M t) = consume (\<Down>R M) t"
  apply(clarsimp simp add: consume_def conc_fun_def comp_def split: nrest.splits)
  apply(rule ext)
  apply(subst conc_fun_consume_aux[symmetric, simplified])
  apply(rule arg_cong[where f=Sup])
  by auto

lemma consume_refine_easy:
  fixes M :: "('e, ('b, enat) acost) nrest"
  shows "\<lbrakk>t \<le> t'; M \<le> \<Down> R (   M')\<rbrakk> \<Longrightarrow> NREST.consume M t \<le> \<Down>R (  (NREST.consume M' t'))"
  apply(subst conc_fun_consume)
  apply(rule consume_mono) by auto

lemma build_rel_SPEC_conv:
  fixes T :: "_ \<Rightarrow> ((_,enat)acost)"
  assumes "\<And>x. T (\<alpha> x) = T' x"
  shows "\<Down>(br \<alpha> I) (SPEC \<Phi> T) = SPEC (\<lambda>x. I x \<and> \<Phi> (\<alpha> x)) T'"
  using assms by (auto simp: br_def pw_acost_eq_iff refine_pw_simps SPEC_def)

subsection \<open>Examples\<close>

experiment
begin
  definition Rset where "Rset = { (c,a)| c a. set c = a}"

  lemma "RETURNT [1,2,3] \<le> \<Down>Rset (RETURNT {1,2,3})"
    unfolding conc_fun_def RETURNT_def Rset_def
    apply simp unfolding le_fun_def by auto

  lemma "RETURNT [1,2,3] \<le> \<Down>Rset (RETURNT {1,2,3})"
    unfolding conc_fun_def RETURNT_def Rset_def
    apply simp unfolding le_fun_def by auto

  definition Reven where "Reven = { (c,a)| c a. even c = a}"

  lemma "RETURNT 3 \<le> \<Down>Reven (RETURNT False)"
    unfolding conc_fun_def RETURNT_def Reven_def
    apply simp unfolding le_fun_def by auto

  lemma "m \<le> \<Down>Id m"
    unfolding conc_fun_def RETURNT_def
    apply (cases m) by auto

  lemma "m \<le> \<Down>{} m \<longleftrightarrow> (m=FAILT \<or> m = SPECT bot)"
    unfolding conc_fun_def RETURNT_def
    apply (cases m) apply auto by (metis bot.extremum dual_order.antisym le_funI)

end

lemma abs_fun_simps[simp]:
  "\<Up>R FAILT = FAILT"
  "dom X\<subseteq>Domain R \<Longrightarrow> \<Up>R (REST X) = REST (\<lambda>a. Sup {X c| c. (c,a)\<in>R})"
  "\<not>(dom X\<subseteq>Domain R) \<Longrightarrow> \<Up>R (REST X) = FAILT"
  unfolding abs_fun_def by (auto  split: nrest.split)

term single_valued

context fixes R assumes SV: "single_valued R" begin

lemma
  fixes m :: "'b \<Rightarrow> enat option"
  shows
  Sup_sv: "(c, a') \<in> R \<Longrightarrow>  Sup {m a| a. (c,a) \<in> R} = m a'"
proof -
  assume "(c,a') \<in> R"
  with SV have singleton: "{m a| a. (c,a) \<in> R} = {m a'}" by(auto dest: single_valuedD)
  show ?thesis unfolding singleton by simp
qed

lemma indomD: " M c = Some y \<Longrightarrow> dom M \<subseteq> Domain R \<Longrightarrow> (\<exists>a. (c,a)\<in>R)"
  by auto
(*
lemma conc_abs_swap: "m' \<le> \<Down>R m \<longleftrightarrow> \<Up>R m' \<le> m"
  apply rule
  subgoal (* <-- *)
  unfolding conc_fun_def abs_fun_def using SV
  apply (auto split: nrest.splits)
  subgoal for M M'
    apply (auto simp add: le_fun_def)
    sorry (* by (smt Sup_least antisym le_cases mem_Collect_eq single_valuedD)  *)
  subgoal
    by (smt Collect_cong Domain.DomainI domI domIff empty_Sup empty_def le_map_dom_mono set_rev_mp)
  done

  subgoal (* \<longrightarrow> *)
    unfolding conc_fun_def abs_fun_def using SV
    apply(auto split: nrest.splits if_splits)
    apply (auto simp add: le_fun_def)
    subgoal for M M' c
      apply(cases "M c = None")
       apply auto apply(frule indomD) apply simp
      apply(auto) sorry(*
      apply(simp only: Sup_sv)

      by (me tis (mono_tags, lifting) Sup_le_iff mem_Collect_eq) *)
    done
  done

lemma
  fixes m :: "'b \<Rightarrow> enat option"
  shows
  Inf_sv: "(c, a') \<in> R \<Longrightarrow>  Inf {m a| a. (c,a) \<in> R} = m a'"
proof -
  assume "(c,a') \<in> R"
  with SV have singleton: "{m a| a. (c,a) \<in> R} = {m a'}" by(auto dest: single_valuedD)
  show ?thesis unfolding singleton by simp
qed

lemma ac_galois: "galois_connection (\<Up>R) (\<Down>R)"
  apply (unfold_locales)
  by (rule conc_abs_swap)
*)

lemma Sup_some_svD:
  fixes m :: "'b \<Rightarrow> enat option"
  shows "Sup {m a |a. (c, a) \<in> R} = Some t' \<Longrightarrow> (\<exists>a. (c,a)\<in>R \<and> m a = Some t')"
  using SV by (smt Sup_le_iff dual_order.antisym less_eq_option_Some_None
                    mem_Collect_eq order_refl single_valued_def)

end

lemma pw_abs_nofail[refine_pw_simps]:
  "nofailT (\<Up>R M) \<longleftrightarrow> (nofailT M \<and> (\<forall>x. (\<exists>t. inresT M x t) \<longrightarrow> x\<in>Domain R))"
  apply (cases M)
  apply simp
  apply (auto simp: abs_fun_simps abs_fun_def)
  by (metis zero_enat_def zero_le)

(*
lemma pw_abs_inre:
  "inresT (\<Up>R M) a t \<longleftrightarrow> (nofailT (\<Up>R M) \<longrightarrow> (\<exists>c. inresT M c t \<and> (c,a)\<in>R))"
  apply (cases M)
  apply simp
  apply (auto simp: abs_fun_def)
  done*)

(*
lemma pw_conc_inres:
  "inresT (\<Down>R S') s t = (nofailT S'
  \<longrightarrow> (\<exists>s'. (s,s')\<in>R \<and> inresT S' s' t))"
  apply (cases S')
  subgoal by simp
  subgoal  for m'
    apply rule
    subgoal
      apply (auto simp: conc_fun_RES) sorry
    subgoal
      apply (auto simp: conc_fun_RES) sorry
    done
  oops *)

lemma sv_the: "single_valued R \<Longrightarrow> (c,a) \<in> R \<Longrightarrow> (THE a. (c, a) \<in> R) = a"
  by (simp add: single_valued_def the_equality)

lemma conc_fun_RES_sv:
  fixes X :: "'b \<Rightarrow> enat option"
  assumes SV: "single_valued R"
  shows "\<Down>R (REST X) = REST (\<lambda>c. if c\<in>Domain R then X (THE a. (c,a)\<in>R) else None )"
  unfolding conc_fun_def
  apply(auto split: nrest.split)
  apply(rule ext)
  apply auto
  subgoal using  SV  by (auto simp: Sup_sv sv_the)
  subgoal by (smt Collect_cong Domain.DomainI empty_Sup empty_def)
  done

lemma conc_fun_mono[simp, intro!]:
  shows "mono ((\<Down>R)::('b, enat) nrest \<Rightarrow> ('a, enat) nrest)"
  apply rule
  apply (simp add: pw_le_iff)
  by (auto simp: refine_pw_simps)

lemma conc_fun_R_mono:
  fixes M :: "(_,enat) nrest"
  assumes "R \<subseteq> R'"
  shows "\<Down>R M \<le> \<Down>R' M"
  using assms
  by (auto simp: pw_le_iff refine_pw_simps)

lemma conc_fun_chain:
  fixes M :: "(_,enat) nrest"
  shows "\<Down>R (\<Down>S M) = \<Down>(R O S) M"
  apply(cases M)
  subgoal by simp
  apply simp
  apply(simp only: conc_fun_RES)
  apply auto apply (rule ext)  unfolding SupSup_1 SupSup_2 by meson

lemma conc_fun_complete_lattice_chain:
  fixes M :: "(_,'b::{complete_lattice,monoid_add}) nrest"
  shows "\<Down>R (\<Down>S M) = \<Down>(R O S) M"
  apply(cases M)
  subgoal by simp
  apply simp
  apply(simp only: conc_fun_RES)
  apply auto apply (rule ext)  unfolding SupSup_1 SupSup_2 by meson

lemma conc_fun_chain_sv:
  fixes M :: "(_,enat) nrest"
  assumes SVR: "single_valued R" and SVS: "single_valued S"
  shows "\<Down>R (\<Down>S M) = \<Down>(R O S) M"
  apply(cases M)
  subgoal by simp
  apply simp
  using SVS apply(simp only: conc_fun_RES_sv)
  using SVR apply(simp only: conc_fun_RES_sv)
  using single_valued_relcomp[OF SVR SVS] apply(simp only: conc_fun_RES_sv)
  apply (auto split: nrest.split)
  apply (rule ext) apply auto
    apply(auto simp add: sv_the)
  apply(subst sv_the) by auto

lemma conc_Id[simp]: "\<Down>Id = id"
  unfolding conc_fun_def [abs_def] by (auto split: nrest.split)

lemma conc_fun_fail_iff[simp]:
  fixes S :: "(_,enat) nrest"
  shows
  "\<Down>R S = FAILT \<longleftrightarrow> S=FAILT"
  "FAILT = \<Down>R S \<longleftrightarrow> S=FAILT"
  by (auto simp add: pw_eq_iff refine_pw_simps)

lemma conc_trans[trans]:
  fixes B :: "(_,'a::{complete_lattice,monoid_add}) nrest"
  assumes A: "C \<le> \<Down>R B" and B: "B \<le> \<Down>R' A"
  shows "C \<le> \<Down>R (\<Down>R' A)"
  apply(rule order.trans)
  apply(rule A)
  apply(rule nrest_Rel_mono)
  apply(rule B)
  done
(*
lemma conc_trans[trans]:
  fixes B :: "(_,enat) nrest"
  assumes A: "C \<le> \<Down>R B" and B: "B \<le> \<Down>R' A"
  shows "C \<le> \<Down>R (\<Down>R' A)"
  using assms by (fastforce simp: pw_le_iff refine_pw_simps)

lemma conc_acost_trans[trans]:
  fixes B :: "(_,(_,enat) acost) nrest"
  assumes A: "C \<le> \<Down>R B" and B: "B \<le> \<Down>R' A"
  shows "C \<le> \<Down>R (\<Down>R' A)"
  using assms by (fastforce simp: pw_acost_le_iff refine_pw_simps)
*)

lemma conc_trans_sv:
  fixes B :: "(_,enat) nrest"
  assumes SV: "single_valued R" "single_valued R'"
    and A: "C \<le> \<Down>R B" and B: "B \<le> \<Down>R' A"
  shows "C \<le> \<Down>R (\<Down>R' A)"
  using assms by (fastforce simp: pw_le_iff refine_pw_simps)

text \<open>WARNING: The order of the single statements is important here!\<close>
lemma conc_trans_additional[trans]:
  assumes "single_valued R"
  shows
  "\<And>(A::(_,enat) nrest) B C. A\<le>\<Down>R  B \<Longrightarrow> B\<le>    C \<Longrightarrow> A\<le>\<Down>R  C"
  "\<And>(A::(_,enat) nrest) B C. A\<le>\<Down>Id B \<Longrightarrow> B\<le>\<Down>R  C \<Longrightarrow> A\<le>\<Down>R  C"
  "\<And>(A::(_,enat) nrest) B C. A\<le>\<Down>R  B \<Longrightarrow> B\<le>\<Down>Id C \<Longrightarrow> A\<le>\<Down>R  C"

  "\<And>(A::(_,enat) nrest) B C. A\<le>\<Down>Id B \<Longrightarrow> B\<le>\<Down>Id C \<Longrightarrow> A\<le>    C"
  "\<And>(A::(_,enat) nrest) B C. A\<le>\<Down>Id B \<Longrightarrow> B\<le>    C \<Longrightarrow> A\<le>    C"
  "\<And>(A::(_,enat) nrest) B C. A\<le>    B \<Longrightarrow> B\<le>\<Down>Id C \<Longrightarrow> A\<le>    C"
  using assms conc_trans[where R=R and R'=Id]
  by (auto intro: order_trans)

lemma RETURNT_refine:
  assumes "(x,x')\<in>R"
  shows "RETURNT x \<le> \<Down>R (RETURNT x')"
  using assms
  by (auto simp: RETURNT_def conc_fun_RES le_fun_def Sup_upper)

(*
thm bindT_refine'
lemma bindT_refine'2:
  fixes R' :: "('a\<times>'b) set" and R::"('c\<times>'d) set"
  assumes R1: "M \<le> \<Down> R' M'"
  assumes R2: "\<And>x x' t . \<lbrakk> (x,x')\<in>R'; inresT M x t; inresT M' x' t;
    nofailT M; nofailT M'
  \<rbrakk> \<Longrightarrow> f x \<le> \<Down> R (f' x')"
  shows "bindT M (\<lambda>x. f x) \<le> \<Down> R (bindT M' (\<lambda>x'. f' x'))"
  using assms
  apply (simp add: pw_le_iff refine_pw_simps)
  by blast*)

lemma bindT_refine:
  fixes R' :: "('a\<times>'b) set" and R::"('c\<times>'d) set" and M :: "(_,enat) nrest"
  assumes R1: "M \<le> \<Down> R' M'"
  assumes R2: "\<And>x x'. \<lbrakk> (x,x')\<in>R' \<rbrakk>
    \<Longrightarrow> f x \<le> \<Down> R (f' x')"
  shows "bindT M (\<lambda>x. f x) \<le> \<Down> R (bind M' (\<lambda>x'. f' x'))"
  apply (rule bindT_conc_refine') using assms by auto

subsection \<open>WHILET refine\<close>

lemma RECT_refine:
  assumes M: "mono2 body"
  assumes R0: "(x,x')\<in>R"
  assumes RS: "\<And>f f' x x'. \<lbrakk> \<And>x x'. (x,x')\<in>R \<Longrightarrow> f x \<le>\<Down>S (f' x'); (x,x')\<in>R \<rbrakk>
    \<Longrightarrow> body f x \<le>\<Down>S (body' f' x')"
  shows "RECT (\<lambda>f x. body f x) x \<le>\<Down>S (RECT (\<lambda>f' x'. body' f' x') x')"
  unfolding RECT_flat_gfp_def
  apply (clarsimp simp add: M)
  apply (rule flatf_fixp_transfer[where
        fp'="flatf_gfp body"
    and B'=body
    and P="\<lambda>x x'. (x',x)\<in>R",
    OF _ _ flatf_ord.fixp_unfold[OF M[THEN trimonoD_flatf_ge]] R0])
  apply simp
  apply (simp add: trimonoD_flatf_ge)
  by (rule RS)

lemma WHILET_refine:
  fixes f :: "_ \<Rightarrow> (_,enat) nrest"
  assumes R0: "(x,x')\<in>R"
  assumes COND_REF: "\<And>x x'. \<lbrakk> (x,x')\<in>R \<rbrakk> \<Longrightarrow> b x = b' x'"
  assumes STEP_REF:
    "\<And>x x'. \<lbrakk> (x,x')\<in>R; b x; b' x' \<rbrakk> \<Longrightarrow> f x \<le> \<Down>R (f' x')"
  shows "whileT b f x \<le> \<Down>R (whileT b' f' x')"
  unfolding whileT_def apply(rule RECT_refine)
    subgoal by(refine_mono)
     apply (fact R0)
    by(auto simp: COND_REF STEP_REF RETURNT_refine intro: bindT_refine[where R'=R])

lemma SPECT_refines_conc_fun':
  assumes a: "\<And>m c.  M = SPECT m
          \<Longrightarrow> c \<in> dom n \<Longrightarrow> (\<exists>a. (c,a)\<in>R \<and> n c \<le> m a)"
  shows "SPECT n \<le> \<Down> R M"
proof -
  show ?thesis
    unfolding conc_fun_def apply (auto split: nrest.split)
    subgoal for m unfolding le_fun_def apply auto
    proof -
      fix c
      assume m: "M = SPECT m"
      show "n c \<le> Sup {m a |a. (c, a) \<in> R} "
      proof (cases "c \<in> dom n")
        case True
        with m a obtain a where k: "(c,a)\<in>R" "n c \<le> m a" by blast
        show ?thesis apply(rule  Sup_upper2) using k by auto
      next
        case False
        then show ?thesis
          by (simp add: domIff)
      qed
    qed
    done
qed

lemma SPECT_refines_conc_fun:
  assumes a: "\<And>m c. (\<exists>a. (c,a)\<in>R \<and> n c \<le> m a)"
  shows "SPECT n \<le> \<Down> R (SPECT m)"
  apply(rule SPECT_refines_conc_fun') using a by auto

lemma SPECT_refines_conc_fun_sv:
  assumes "single_valued R"
    and a: "dom n \<subseteq> Domain R"
    and "\<And>c. c \<in> dom n \<Longrightarrow> n c \<le> (THE a. (c,a)\<in>R)"
  shows "SPECT n \<le> \<Down> R (SPECT m)"
  apply(rule SPECT_refines_conc_fun') using a
  using indomD[OF assms(1) _ a] domIff
  oops

lemma conc_fun_br: "\<Down> (br \<alpha> I1) (SPECT (emb I2 t))
        = (SPECT (emb (\<lambda>x. I1 x \<and> I2 (\<alpha> x)) t))"
  unfolding conc_fun_RES  apply auto apply(rule ext)
      by (auto simp: emb'_def br_def bot_option_def Sup_option_def)

subsection \<open>Relators\<close>

definition nrest_rel where
  nrest_rel_def_internal: "nrest_rel R \<equiv> {(c,a).  c \<le> \<Down>R  a}"

lemma nrest_rel_def: "\<langle>R\<rangle>nrest_rel \<equiv> {(c,a). c \<le> \<Down>R  a}"
  by (simp add: nrest_rel_def_internal relAPP_def)

lemma nrest_relD: "(c,a)\<in>\<langle>R\<rangle>nrest_rel \<Longrightarrow> c \<le> \<Down>R  a" by (simp add: nrest_rel_def)
lemma nrest_relI: "c \<le>\<Down>R a \<Longrightarrow> (c,a)\<in>\<langle>R\<rangle>nrest_rel" by (simp add: nrest_rel_def)

lemma nrest_rel_comp:
 "\<langle>A\<rangle>nrest_rel O \<langle>B\<rangle>nrest_rel = \<langle>A O B\<rangle>nrest_rel"
  by (auto simp: nrest_rel_def conc_fun_complete_lattice_chain[symmetric] conc_trans)

lemma pw_nrest_rel_iff: "(a,b)\<in>\<langle>A\<rangle>nrest_rel \<longleftrightarrow> nofailT (\<Down> A b)\<longrightarrow>  nofailT a \<and> (\<forall>x t. inresT a x t \<longrightarrow> inresT (\<Down> A b) x t)"
  by (simp add: pw_le_iff nrest_rel_def)

find_theorems project_acost abs_fun

lemma pw_acost_nrest_rel_iff: "(a,b)\<in>\<langle>A\<rangle>nrest_rel \<longleftrightarrow> nofailT (\<Down> A b) \<longrightarrow> nofailT a
         \<and> (\<forall>x c t. inresT (project_acost c a) x t \<longrightarrow> inresT (\<Down> A (project_acost c b)) x t)"
  by (auto simp add: pw_acost_le_iff nrest_rel_def project_acost_conc_fun_commute)

lemma param_RETURNT[param]:
  "(RETURNT,RETURNT) \<in> R \<rightarrow> \<langle>R\<rangle>nrest_rel"
  by (auto simp: nrest_rel_def RETURNT_refine)

lemma param_RETURN[param]:
  "(RETURNT,RETURNT) \<in> R \<rightarrow> \<langle>R\<rangle>nrest_rel"
  by (auto simp: nrest_rel_def RETURNT_refine)

lemma param_bind[param]:
  "(bind,bind) \<in> \<langle>Ra\<rangle>nrest_rel \<rightarrow> (Ra\<rightarrow>\<langle>Rb\<rangle>nrest_rel) \<rightarrow> (\<langle>Rb\<rangle>nrest_rel:: (('a, (_,enat)acost) nrest \<times> ('c, _) nrest) set)"
  by (auto simp: nrest_rel_def intro: bindT_conc_acost_refine' dest: fun_relD)

lemma param_ASSERT_bind[param]:
  fixes f :: "(_,_) nrest"
  shows
 "\<lbrakk>
    (\<Phi>,\<Psi>) \<in> bool_rel;
    \<lbrakk> \<Phi>; \<Psi> \<rbrakk> \<Longrightarrow> (f,g)\<in>\<langle>R\<rangle>nrest_rel
  \<rbrakk> \<Longrightarrow> (doN { ASSERT \<Phi>; f}, doN {ASSERT \<Psi>; g}) \<in> \<langle>R\<rangle>nrest_rel"
  by (auto intro: nrest_relI)

definition continuous2 :: "_ \<Rightarrow> ('a::{Sup} \<Rightarrow> 'b::{Sup}) \<Rightarrow> bool"  where
  "continuous2 P f \<longleftrightarrow> (\<forall>A. P A \<longrightarrow> Sup (f ` A) = f (Sup A) )"

definition "attains_sup' m m' RR \<equiv>
  \<forall>r M' M. m=SPECT M \<longrightarrow> m'=SPECT M' \<longrightarrow> r\<in>dom M \<longrightarrow> (\<exists>a. (r,a)\<in>RR) \<longrightarrow> Sup {M' a| a. (r,a)\<in>RR} \<in> {M' a| a. (r,a)\<in>RR}"

lemma
  fixes A :: "enat set"
  shows "Sup A  \<in> A \<Longrightarrow> Sup ( (\<lambda>a. a * c) ` A) \<in> (\<lambda>a. a * c) ` A"
  by (metis enat_mult_cont imageI)

lemma plus_continuous_if_attains_sup:
  fixes x y h
  defines "g \<equiv> \<lambda>f::_\<Rightarrow>enat. f x + f y"
  assumes "Sup A \<in> A"
  shows "g (Sup A) = (SUP f\<in>A. g f)"
  unfolding assms
  apply(rule antisym)
  subgoal
    apply(rule Sup_upper)
    using assms(2) by blast
  subgoal
    by (simp add: enat_add_cont')
  done

lemma plus_continuous_if_attains_sup':
  fixes x y h
  defines "g \<equiv> \<lambda>f::_\<Rightarrow>enat. f x + h f y"
  assumes "Sup A \<in> A" and
    h_mono: "\<And>f f' y. f\<le>f' \<Longrightarrow> h f y \<le> h f' y"
  shows "g (Sup A) = (SUP f\<in>A. g f)"
  unfolding assms
  apply(rule antisym)
  subgoal
    apply(rule Sup_upper)
    using assms(2) by blast
  subgoal
    apply(auto intro!: Sup_least add_mono Sup_upper)
    apply(rule h_mono) apply(intro Sup_upper) .
  done

lemma
  fixes S
  defines "g \<equiv> \<lambda>f::_\<Rightarrow>enat. sum f S"
  assumes "Sup A \<in> A"
  shows "finite S \<Longrightarrow> g (Sup A) = (SUP f\<in>A. g f)"
  unfolding assms
  apply(induct S rule: finite_induct)
  subgoal using assms(2) apply auto
    using SUP_bot_conv(1) by fastforce
  subgoal using assms(2) apply simp
    apply(subst plus_continuous_if_attains_sup'[symmetric, OF assms(2)])
    subgoal apply(rule sum_mono) by (simp add: le_fun_def)
    by simp
  done

(*
lemma
  fixes R :: "'a \<Rightarrow> ('b, enat) acost"
  assumes "wfR'' R"
  shows "continuous2 (\<lambda>cm. finite {x. the_acost cm x \<noteq> 0})
           ( \<lambda>cm.  (acostC (\<lambda>cc. Sum_any (\<lambda>ac. the_acost cm ac * the_acost (R ac) cc))))"
  unfolding continuous2_def
  apply clarsimp
  sorry

lemma continuous_if_wfR'':
  fixes R :: "'a \<Rightarrow> ('b, enat) acost"
  assumes "wfR'' R"
  shows "continuous ( \<lambda>cm.  (acostC (\<lambda>cc. Sum_any (\<lambda>ac. the_acost cm ac * the_acost (R ac) cc))))"
  apply(rule continuousI)
proof -
  fix A :: "('a, enat) acost set"
  have "Sup A \<in> A" sorry
  have "\<And>ac. the_acost (Sup A) ac = (SUP a\<in>A. (the_acost a ac))"
    unfolding Sup_acost_def by simp
  have pf: "\<And>g a. (SUP f\<in>A. the_acost f a) * g = (SUP f\<in>A. the_acost f a * g)"
    by (simp add: enat_mult_cont')

  show "acostC (\<lambda>cc. \<Sum>ac. the_acost (Sup A) ac * the_acost (R ac) cc)
        = (SUP cm\<in>A. acostC (\<lambda>cc. \<Sum>ac. the_acost cm ac * the_acost (R ac) cc))"
    unfolding Sup_acost_def
    apply simp
    apply(subst pf)
    sorry
qed
  (* TODO: investigate *)
  oops

thm timerefine_conc_fun_le2[OF continuous_if_wfR'', unfolded timerefine_alt4[symmetric]]

lemma timerefine_conc_fun_le2:
  assumes "continuous E"
  shows "timerefine' E (\<Down> R C) = \<Down>R (timerefine' E C)"
  unfolding timerefine'_def conc_fun_def
  apply(auto split: nrest.splits option.splits simp: fun_eq_iff)
  subgoal
    by (smt Sup_bot_conv(1) bot_option_def mem_Collect_eq)
  subgoal premises p for x2 x2a x2b x x2c
  proof -
    have "Sup {x2b a |a. (x, a) \<in> R} = Sup {map_option E (x2 a) |a. (x, a) \<in> R}"
      apply(rule arg_cong[where f=Sup])
      using p(3)[rule_format] p(4)
      apply auto
      subgoal by (smt map_option_eq_Some option.exhaust)
      subgoal by (metis not_None_eq option.simps(8) option.simps(9))
      done
    also have "\<dots> = map_option E (Sup {x2 a |a. (x, a) \<in> R})"
      apply(subst continuous_map_option[OF assms, THEN continuousD] )
      apply(rule arg_cong[where f=Sup])
      by auto
    also have "\<dots> = map_option E (Some x2c)"
      using p(2)[rule_format, of x, unfolded p(4)] by simp
    also have "\<dots> = Some (E x2c)" by simp
    finally show "Some (E x2c) = Sup {x2b a |a. (x, a) \<in> R}"  by simp
  qed
  done

*)
end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Agent
  imports "HOL-Nominal.Nominal"
begin

lemma pt_id:
  fixes x :: 'a
    and a :: 'x

  assumes pt: "pt TYPE('a) TYPE('x)"
  and     at: "at TYPE('x)"
  shows "[(a, a)] \<bullet> x = x"
proof -
  have "x = ([]::'x prm) \<bullet> x"
    by(simp add: pt1[OF pt])
  also have "[(a, a)] \<bullet> x = ([]::'x prm) \<bullet> x"
    by(simp add: pt3[OF pt] at_ds1[OF at])
  finally show ?thesis by simp
qed

lemma pt_swap:
  fixes x :: 'a
  and a :: 'x
  and b :: 'x

  assumes pt: "pt TYPE('a) TYPE('x)"
  and     at: "at TYPE('x)"

  shows "[(a, b)] \<bullet> x = [(b, a)] \<bullet> x"
proof -
  show ?thesis by(simp add: pt3[OF pt] at_ds5[OF at])
qed

atom_decl name

lemmas name_fresh_abs = fresh_abs_fun_iff[OF pt_name_inst, OF at_name_inst, OF fs_name1]
lemmas name_bij = at_bij[OF at_name_inst]
lemmas name_supp_abs = abs_fun_supp[OF pt_name_inst, OF at_name_inst, OF fs_name1]
lemmas name_abs_eq = abs_fun_eq[OF pt_name_inst, OF at_name_inst]
lemmas name_supp = at_supp[OF at_name_inst]
lemmas name_calc = at_calc[OF at_name_inst]
lemmas name_fresh_fresh = pt_fresh_fresh[OF pt_name_inst, OF at_name_inst]
lemmas name_fresh_left = pt_fresh_left[OF pt_name_inst, OF at_name_inst]
lemmas name_fresh_right = pt_fresh_right[OF pt_name_inst, OF at_name_inst]
lemmas name_id[simp] = pt_id[OF pt_name_inst, OF at_name_inst]
lemmas name_swap_bij[simp] = pt_swap_bij[OF pt_name_inst, OF at_name_inst]
lemmas name_swap = pt_swap[OF pt_name_inst, OF at_name_inst]
lemmas name_rev_per = pt_rev_pi[OF pt_name_inst, OF at_name_inst]
lemmas name_per_rev = pt_pi_rev[OF pt_name_inst, OF at_name_inst]
lemmas name_exists_fresh = at_exists_fresh[OF at_name_inst, OF fs_name1]
lemmas name_perm_compose = pt_perm_compose[OF pt_name_inst, OF at_name_inst]

nominal_datatype pi = PiNil                  ("\<zero>")
                    | Output name name pi    ("_{_}._" [120, 120, 110] 110)
                    | Tau pi                 ("\<tau>._" [120] 110)
                    | Input name "\<guillemotleft>name\<guillemotright> pi" ("_<_>._" [120, 120, 110] 110)
                    | Match name name pi     ("[_\<frown>_]_" [120, 120, 110] 110)
                    | Mismatch name name pi  ("[_\<noteq>_]_" [120, 120, 110] 110)
                    | Sum pi pi              (infixr "\<oplus>" 90)
                    | Par pi pi              (infixr "\<parallel>" 85)
                    | Res "\<guillemotleft>name\<guillemotright> pi"        ("<\<nu>_>_" [100, 100] 100)
                    | Bang pi                ("!_" [110] 110)

lemmas name_fresh[simp] = at_fresh[OF at_name_inst]

lemma alphaInput:
  fixes a :: name
  and   x :: name
  and   P :: pi
  and   c :: name

  assumes A1: "c \<sharp> P"

  shows "a<x>.P = a<c>.([(x, c)] \<bullet> P)"
proof(cases "x = c")
  assume "x=c"
  thus ?thesis by(simp)
next
  assume "x \<noteq> c"
  with A1 show ?thesis
    by(simp add: pi.inject alpha name_fresh_left name_calc)
qed

lemma alphaRes:
  fixes a :: name
  and   P :: pi
  and   c :: name

  assumes A1: "c \<sharp> P"

  shows "<\<nu>a>P = <\<nu>c>([(a, c)] \<bullet> P)"
proof(cases "a=c")
  assume "a=c"
  thus ?thesis by simp
next
  assume "a \<noteq> c"
  with A1 show ?thesis
    by(simp add: pi.inject alpha fresh_left name_calc)
qed

(*Substitution*)

definition subst_name :: "name \<Rightarrow> name \<Rightarrow> name \<Rightarrow> name"   ("_[_::=_]" [110, 110, 110] 110)
where
  "a[b::=c] \<equiv> if (a = b) then c else a"

declare subst_name_def[simp]

lemma subst_name_eqvt[eqvt]:
  fixes p :: "name prm"
  and   a :: name
  and   b :: name
  and   c :: name

  shows "p \<bullet> (a[b::=c]) = (p\<bullet> a)[(p \<bullet> b)::=(p \<bullet> c)]"
by(auto simp add: at_bij[OF at_name_inst])

nominal_primrec (freshness_context: "(c::name, d::name)")
  subs :: "pi \<Rightarrow> name \<Rightarrow> name \<Rightarrow> pi" ("_[_::=_]" [100,100,100] 100)
where
  "\<zero>[c::=d] = \<zero>"
| "\<tau>.(P)[c::=d] = \<tau>.(P[c::=d])"
| "a{b}.P[c::=d] = (a[c::=d]){(b[c::=d])}.(P[c::=d])"
| "\<lbrakk>x \<noteq> a; x \<noteq> c; x \<noteq> d\<rbrakk> \<Longrightarrow> (a<x>.P)[c::=d] = (a[c::=d])<x>.(P[c::=d])"
| "[a\<frown>b]P[c::=d] = [(a[c::=d])\<frown>(b[c::=d])](P[c::=d])"
| "[a\<noteq>b]P[c::=d] = [(a[c::=d])\<noteq>(b[c::=d])](P[c::=d])"
| "(P \<oplus> Q)[c::=d] = (P[c::=d]) \<oplus> (Q[c::=d])"
| "(P \<parallel> Q)[c::=d] = (P[c::=d]) \<parallel> (Q[c::=d])"
| "\<lbrakk>x \<noteq> c; x \<noteq> d\<rbrakk> \<Longrightarrow> (<\<nu>x>P)[c::=d] = <\<nu>x>(P[c::=d])"
| "!P[c::=d] = !(P[c::=d])"
apply(simp_all add: abs_fresh)
apply(finite_guess)+
by(fresh_guess)+

lemma forget:
  fixes a :: name
  and   P :: pi
  and   b :: name

  assumes "a \<sharp> P"

  shows "P[a::=b] = P"
using assms
by(nominal_induct P avoiding: a b rule: pi.strong_induct)
  (auto simp add: name_fresh_abs)

lemma fresh_fact2[rule_format]:
  fixes P :: pi
  and   a :: name
  and   b :: name

  assumes "a \<noteq> b"

  shows "a \<sharp> P[a::=b]"
using assms
by(nominal_induct P avoiding: a b rule: pi.strong_induct)
  (auto simp add: name_fresh_abs)

lemma subst_identity[simp]:
  fixes P :: pi
  and   a :: name

  shows "P[a::=a] = P"
by(nominal_induct P avoiding: a rule: pi.strong_induct) auto

lemma renaming:
  fixes P :: pi
  and   a :: name
  and   b :: name
  and   c :: name

  assumes "c \<sharp> P"

  shows "P[a::=b] = ([(c, a)] \<bullet> P)[c::=b]"
using assms
by(nominal_induct P avoiding: a b c rule: pi.strong_induct)
  (auto simp add: name_calc name_fresh_abs)

lemma fresh_fact1:
  fixes P :: pi
  and   a :: name
  and   b :: name
  and   c :: name

  assumes "a \<sharp> P"
  and     "a \<noteq> c"

  shows "a \<sharp> P[b::=c]"
using assms
by(nominal_induct P avoiding: a b c rule: pi.strong_induct)
  (auto simp add: name_fresh_abs)

lemma eqvt_subs[eqvt]:
  fixes p :: "name prm"
  and   P :: pi
  and   a :: name
  and   b :: name

  shows "p \<bullet> (P[a::=b]) = (p \<bullet> P)[(p \<bullet> a)::=(p \<bullet> b)]"
by(nominal_induct P avoiding: a b rule: pi.strong_induct)
  (auto simp add: name_bij)

lemma substInput[simp]:
  fixes x :: name
  and   b :: name
  and   c :: name
  and   a :: name
  and   P :: pi

  assumes "x \<noteq> b"
  and     "x \<noteq> c"

  shows "(a<x>.P)[b::=c] = (a[b::=c])<x>.(P[b::=c])"
proof -
  obtain y::name where"y \<noteq> a" and "y \<sharp> P" and "y \<noteq> b" and "y \<noteq> c"
    by(generate_fresh "name") (auto simp add: fresh_prod)
  from \<open>y \<sharp> P\<close> have "a<x>.P = a<y>.([(x, y)] \<bullet> P)" by(simp add: alphaInput)
  moreover have "(a[b::=c])<x>.(P[b::=c]) = (a[b::=c])<y>.(([(x, y)] \<bullet> P)[b::=c])" (is "?LHS = ?RHS")
  proof -
    from \<open>y \<sharp> P\<close> \<open>y \<noteq> c\<close> have "y \<sharp> P[b::=c]" by(rule fresh_fact1)
    hence "?LHS = (a[b::=c])<y>.([(x, y)] \<bullet> (P[b::=c]))" by(simp add: alphaInput)
    moreover with \<open>x \<noteq> b\<close> \<open>x \<noteq> c\<close> \<open>y \<noteq> b\<close> \<open>y \<noteq> c\<close> have "\<dots> = ?RHS"
      by(auto simp add: eqvt_subs name_calc)
    ultimately show ?thesis by simp
  qed
  ultimately show ?thesis using \<open>y \<noteq> a\<close> \<open>y \<noteq> b\<close> \<open>y \<noteq> c\<close> by simp
qed

lemma injPermSubst:
  fixes P :: pi
  and   a :: name
  and   b :: name

  assumes "b \<sharp> P"

  shows "[(a, b)] \<bullet> P = P[a::=b]"
using assms
by(nominal_induct P avoiding: a b rule: pi.strong_induct)
  (auto simp add: name_calc name_fresh_abs)

lemma substRes2:
  fixes P :: pi
  and   a :: name
  and   b :: name

  assumes "b \<sharp> P"

  shows "<\<nu>a>P = <\<nu>b>(P[a::=b])"
proof(case_tac "a = b")
  assume "a = b"
  thus ?thesis by auto
next
  assume "a \<noteq> b"
  moreover with \<open>b \<sharp> P\<close> show ?thesis
    apply(simp add: pi.inject abs_fun_eq[OF pt_name_inst, OF at_name_inst])
    apply auto
    apply(simp add: renaming)
    apply(simp add: pt_swap[OF pt_name_inst, OF at_name_inst])
    apply(simp add: renaming)
    apply(simp add: pt_fresh_left[OF pt_name_inst, OF at_name_inst])
    by(force simp add: at_calc[OF at_name_inst])
qed

lemma freshRes:
  fixes P :: pi
  and   a :: name

  shows "a \<sharp> <\<nu>a>P"
by(simp add: name_fresh_abs)

lemma substRes3:
  fixes P :: pi
  and   a :: name
  and   b :: name

  assumes "b \<sharp> P"

  shows "(<\<nu>a>P)[a::=b] = <\<nu>b>(P[a::=b])"
proof -
  have "(<\<nu>a>P)[a::=b] = <\<nu>a>P"
    using freshRes by(simp add: forget)
  thus ?thesis using \<open>b \<sharp> P\<close> by(simp add: substRes2)
qed

lemma suppSubst:
  fixes P :: pi
  and   a :: name
  and   b :: name

  shows "supp(P[a::=b]) \<subseteq> insert b ((supp P) - {a})"
apply(nominal_induct P avoiding: a b rule: pi.strong_induct,
      simp_all add: pi.supp name_supp_abs name_supp supp_prod)
by(blast)+

(******** Sequential substitution *******)

primrec seqSubs :: "pi \<Rightarrow> (name \<times> name) list \<Rightarrow> pi" ("_[<_>]" [100,100] 100) where
  "P[<[]>] = P"
| "P[<(x#\<sigma>)>] = (P[(fst x)::=(snd x)])[<\<sigma>>]"

primrec seq_subst_name :: "name \<Rightarrow> (name \<times> name) list \<Rightarrow> name" where
  "seq_subst_name a [] = a"
| "seq_subst_name a (x#\<sigma>) = seq_subst_name (a[(fst x)::=(snd x)]) \<sigma>"

lemma freshSeqSubstName:
  fixes x :: name
  and   a :: name
  and   s :: "(name \<times> name) list"

  assumes "x \<noteq> a"
  and     "x \<sharp> s"

  shows "x \<noteq> seq_subst_name a s"
using assms
apply(induct s arbitrary: a)
apply simp
apply(case_tac "aa = fst(a)")
by (force simp add: fresh_list_cons fresh_prod)+

lemma seqSubstZero[simp]:
  fixes \<sigma> :: "(name \<times> name) list"

  shows "\<zero>[<\<sigma>>] = \<zero>"
by(induct \<sigma>, auto)

lemma seqSubstTau[simp]:
  fixes P :: pi
  and   \<sigma> :: "(name \<times> name) list"

  shows "(\<tau>.(P))[<\<sigma>>] = \<tau>.(P[<\<sigma>>])"
by(induct \<sigma> arbitrary: P, auto)

lemma seqSubstOutput[simp]:
  fixes a :: name
  and   b :: name
  and   P :: pi
  and   \<sigma> :: "(name \<times> name) list"

  shows "(a{b}.P)[<\<sigma>>] = (seq_subst_name a \<sigma>){(seq_subst_name b \<sigma>)}.(P[<\<sigma>>])"
by(induct \<sigma> arbitrary: a b P, auto)

lemma seqSubstInput[simp]:
  fixes a :: name
  and   x :: name
  and   P :: pi
  and   \<sigma> :: "(name \<times> name) list"

  assumes "x \<sharp> \<sigma>"

  shows "(a<x>.P)[<\<sigma>>] = (seq_subst_name a \<sigma>)<x>.(P[<\<sigma>>])"
using assms
by(induct \<sigma> arbitrary: a x P) (auto simp add: fresh_list_cons fresh_prod)

lemma seqSubstMatch[simp]:
  fixes a :: name
  and   b :: name
  and   P :: pi
  and   \<sigma> :: "(name \<times> name) list"

  shows "([a\<frown>b]P)[<\<sigma>>] = [(seq_subst_name a \<sigma>)\<frown>(seq_subst_name b \<sigma>)](P[<\<sigma>>])"
by(induct \<sigma> arbitrary: a b P, auto)

lemma seqSubstMismatch[simp]:
  fixes a :: name
  and   b :: name
  and   P :: pi
  and   \<sigma> :: "(name \<times> name) list"

  shows "([a\<noteq>b]P)[<\<sigma>>] = [(seq_subst_name a \<sigma>)\<noteq>(seq_subst_name b \<sigma>)](P[<\<sigma>>])"
by(induct \<sigma> arbitrary: a b P, auto)

lemma seqSubstSum[simp]:
  fixes P :: pi
  and   Q :: pi
  and   \<sigma> :: "(name \<times> name) list"

  shows "(P \<oplus> Q)[<\<sigma>>] = (P[<\<sigma>>]) \<oplus> (Q[<\<sigma>>])"
by(induct \<sigma> arbitrary: P Q , auto)

lemma seqSubstPar[simp]:
  fixes P :: pi
  and   Q :: pi
  and   \<sigma> :: "(name \<times> name) list"

  shows "(P \<parallel> Q)[<\<sigma>>] = (P[<\<sigma>>]) \<parallel> (Q[<\<sigma>>])"
by(induct \<sigma> arbitrary: P Q, auto)

lemma seqSubstRes[simp]:
  fixes x :: name
  and   P :: pi
  and   \<sigma> :: "(name \<times> name) list"

  assumes "x \<sharp> \<sigma>"

  shows "(<\<nu>x>P)[<\<sigma>>] = <\<nu>x>(P[<\<sigma>>])"
using assms
by(induct \<sigma> arbitrary: x P) (auto simp add: fresh_list_cons fresh_prod)

lemma seqSubstBang[simp]:
  fixes P :: pi
  and   s :: "(name \<times> name) list"

  shows "(!P)[<\<sigma>>] = !(P[<\<sigma>>])"
by(induct \<sigma> arbitrary: P, auto)

lemma seqSubstEqvt[eqvt, simp]:
  fixes P :: pi
  and   \<sigma> :: "(name \<times> name) list"
  and   p :: "name prm"

  shows "p \<bullet> (P[<\<sigma>>]) = (p \<bullet> P)[<(p \<bullet> \<sigma>)>]"
by(induct \<sigma> arbitrary: P, auto simp add: eqvt_subs)

lemma seqSubstAppend[simp]:
  fixes P  :: pi
  and   \<sigma>  :: "(name \<times> name) list"
  and   \<sigma>' :: "(name \<times> name) list"

  shows "P[<(\<sigma>@\<sigma>')>] = (P[<\<sigma>>])[<\<sigma>'>]"
by(induct \<sigma> arbitrary: P, auto)

lemma freshSubstChain[intro]:
  fixes P :: pi
  and   \<sigma> :: "(name \<times> name) list"
  and   a :: name

  assumes "a \<sharp> P"
  and     "a \<sharp> \<sigma>"

  shows "a \<sharp> P[<\<sigma>>]"
using assms
by(induct \<sigma> arbitrary: a P, auto simp add: fresh_list_cons fresh_prod fresh_fact1)

end