(*<*)
theory CounterExample
imports
  HOLCF
  WorkerWrapper
begin
(*>*)

subsection\<open>Worker/wrapper fusion is partially correct\<close>

text\<open>

We now examine how Gill and Hutton apply their worker/wrapper fusion
rule in the context of the fold/unfold framework.

The key step of those left implicit in the original paper is the use
of the \textsf{fold} rule to justify replacing the worker with the
fused version. Schematically, the fold/unfold framework maintains a
history of all definitions that have appeared during transformation,
and the \textsf{fold} rule treats this as a set of rewrite rules
oriented right-to-left. (The \textsf{unfold} rule treats the current
working set of definitions as rewrite rules oriented left-to-right.)
Hence as each definition @{haskell "f = body"} yields a rule of the form
@{haskell "body\\ \\Longrightarrow\\ f"}, one can always derive @{haskell "f =\\
f"}. Clearly this has dire implications for the preservation of
termination behaviour.

\<^citet>\<open>"Tullsen:PhDThesis"\<close> in his \S3.1.2 observes that the semantic
essence of the \textsf{fold} rule is Park induction:
\begin{center}
  @{thm[mode=Rule] "fix_least"[where F=f]} {\texttt{fix\_least}}
\end{center}
viz that @{haskell "f\\ x = x"} implies only the partially correct @{haskell "fix\\ f
\\sqsubseteq x"}, and not the totally correct @{haskell "fix\\ f = x"}. We use
this characterisation to show that if @{haskell "unwrap"} is non-strict
(i.e. @{haskell "unwrap \\bot \\neq \\bot"}) then there are programs where
worker/wrapper fusion as used by Gill and Hutton need only be
partially correct.

Consider the scenario described in Figure~\ref{fig:ww}. After applying
the worker/wrapper transformation, we attempt to apply fusion by
finding a residual expression @{term "body'"} such that the body of
the worker, i.e. the expression @{term "unwrap oo body oo wrap"}, can
be rewritten as @{term "body' oo unwrap oo wrap"}. Intuitively this is
the semantic form of workers where all self-calls are fusible. Our
goal is to justify redefining @{term "work"} to @{term "fix\<cdot>body'"},
i.e. to establish:
\begin{center}
  @{term "fix\<cdot>(unwrap oo body oo wrap) = fix\<cdot>body'"}
\end{center}
We show that worker/wrapper fusion as proposed by Gill and Hutton is
partially correct using Park induction:

\<close>

lemma fusion_partially_correct:
  assumes wrap_unwrap: "wrap oo unwrap = ID"
  assumes work: "work = fix\<cdot>(unwrap oo body oo wrap)"
  assumes body': "unwrap oo body oo wrap = body' oo unwrap oo wrap"
  shows "fix\<cdot>body' \<sqsubseteq> work"
proof(rule fix_least)
  have "work = (unwrap oo body oo wrap)\<cdot>work"
    using work by (simp add: fix_eq[symmetric])
  also have "... = (body' oo unwrap oo wrap)\<cdot>work"
    using body' by simp
  also have "... = (body' oo unwrap oo wrap)\<cdot>((unwrap oo body oo wrap)\<cdot>work)"
    using work by (simp add: fix_eq[symmetric])
  also have "... = (body' oo unwrap oo wrap oo unwrap oo body oo wrap)\<cdot>work"
    by simp
  also have "... = (body' oo unwrap oo body oo wrap)\<cdot>work"
    using wrap_unwrap by (simp add: assoc_oo)
  also have "... = body'\<cdot>work"
    using work by (simp add: fix_eq[symmetric])
  finally show "body'\<cdot>work = work" by simp
qed

text\<open>

The next section shows the converse does not obtain.

\<close>

subsection\<open>A non-strict @{term "unwrap"} may go awry\<close>

text\<open>

\label{sec:ww-counterexample}

If @{term "unwrap"} is non-strict, then it is possible that the fusion
rule proposed by Gill and Hutton does not preserve termination. To
show this we take a small artificial example. The type @{term "A"} is
not important, but we need access to a non-bottom inhabitant. The
target type @{term "B"} is the non-strict lift of @{term "A"}.

\<close>

domain A = A
domain B = B (lazy "A")

text\<open>

The functions @{term "wrap"} and @{term "unwrap"} that map between
these types are routine. Note that @{term "wrap"} is (necessarily)
strict due to the property @{thm "retraction_strict"}.

\<close>

fixrec wrap :: "B \<rightarrow> A"
where "wrap\<cdot>(B\<cdot>a) = a"

(*<*)
lemma wrap_strict[simp]: "wrap\<cdot>\<bottom> = \<bottom>"
  by fixrec_simp
(*>*)

fixrec unwrap :: "A \<rightarrow> B"
where "unwrap = B"

text\<open>

Discharging the worker/wrapper hypothesis is similarly routine.

\<close>

lemma wrap_unwrap: "wrap oo unwrap = ID"
  by (simp add: cfun_eq_iff)

text\<open>

The candidate computation we transform can be any that uses the
recursion parameter @{term "r"} non-strictly. The following is
especially trivial.

\<close>

fixrec body :: "A \<rightarrow> A"
where "body\<cdot>r = A"

text\<open>

The wrinkle is that the transformed worker can be strict in the
recursion parameter @{term "r"}, as @{term "unwrap"} always lifts it.

\<close>

fixrec body' :: "B \<rightarrow> B"
where "body'\<cdot>(B\<cdot>a) = B\<cdot>A"
(*<*)

lemma body'_strict[simp]: "body'\<cdot>\<bottom> = \<bottom>"
  by fixrec_simp

(*>*)
text\<open>

As explained above, we set up the fusion opportunity:

\<close>

lemma body_body': "unwrap oo body oo wrap = body' oo unwrap oo wrap"
  by (simp add: cfun_eq_iff)

text\<open>

This result depends crucially on @{term "unwrap"} being non-strict.

Our earlier result shows that the proposed transformation is partially
correct:

\<close>

lemma "fix\<cdot>body' \<sqsubseteq> fix\<cdot>(unwrap oo body oo wrap)"
  by (rule fusion_partially_correct[OF wrap_unwrap refl body_body'])

text\<open>

However it is easy to see that it is not totally correct:

\<close>

lemma "\<not> fix\<cdot>(unwrap oo body oo wrap) \<sqsubseteq> fix\<cdot>body'"
proof -
  have l: "fix\<cdot>(unwrap oo body oo wrap) = B\<cdot>A"
    by (subst fix_eq) simp
  have r: "fix\<cdot>body' = \<bottom>"
    by (simp add: fix_strict)
  from l r show ?thesis by simp
qed

text\<open>

This trick works whenever @{term "unwrap"} is not strict. In the
following section we show that requiring @{term "unwrap"} to be strict
leads to a straightforward proof of total correctness.

Note that if we have already established that @{term "wrap oo unwrap =
ID"}, then making @{term "unwrap"} strict preserves this equation:

\<close>

lemma
  assumes "wrap oo unwrap = ID"
  shows "wrap oo strictify\<cdot>unwrap = ID"
proof(rule cfun_eqI)
  fix x
  from assms
  show "(wrap oo strictify\<cdot>unwrap)\<cdot>x = ID\<cdot>x"
    by (cases "x = \<bottom>") (simp_all add: cfun_eq_iff retraction_strict)
qed

text\<open>

From this we conclude that the worker/wrapper transformation itself
cannot exploit any laziness in @{term "unwrap"} under the
context-insensitive assumptions of @{thm [source]
"worker_wrapper_id"}. This is not to say that other program
transformations may not be able to.

\<close>

(*<*)
lemma
  "\<not> strictify\<cdot>unwrap oo body oo wrap = body' oo strictify\<cdot>unwrap oo wrap"
  by (simp add: cfun_eq_iff exI[where x="\<bottom>"])
(*>*)

(*<*)
end
(*>*)


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

chapter \<open>More properties of maps plus map disjuction.\<close>

theory MapExtra
imports Main
begin

text \<open>
  BEWARE: we are not interested in using the @{term "dom x \<inter> dom y = {}"}
  rules from Map for our separation logic proofs. As such, we overwrite the
  Map rules where that form of disjointness is in the assumption conflicts
  with a name we want to use with @{text "\<bottom>"}.\<close>

text \<open>
  A note on naming:
  Anything not involving heap disjuction can potentially be incorporated
  directly into Map.thy, thus uses @{text "m"}.
  Anything involving heap disjunction is not really mergeable with Map, is
  destined for use in separation logic, and hence uses @{text "h"}
\<close>

text \<open>---------------------------------------\<close>
text \<open>Things that should go into Option Type\<close>
text \<open>---------------------------------------\<close>

text \<open>Misc option lemmas\<close>

lemma None_not_eq: "(None \<noteq> x) = (\<exists>y. x = Some y)" by (cases x) auto

lemma None_com: "(None = x) = (x = None)" by fast

lemma Some_com: "(Some y = x) = (x = Some y)" by fast

text \<open>---------------------------------------\<close>
text \<open>Things that should go into Map.thy\<close>
text \<open>---------------------------------------\<close>

text \<open>Map intersection: set of all keys for which the maps agree.\<close>

definition
  map_inter :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> 'a set" (infixl "\<inter>\<^sub>m" 70) where
  "m\<^sub>1 \<inter>\<^sub>m m\<^sub>2 \<equiv> {x \<in> dom m\<^sub>1. m\<^sub>1 x = m\<^sub>2 x}"

text \<open>Map restriction via domain subtraction\<close>

definition
  sub_restrict_map :: "('a \<rightharpoonup> 'b) => 'a set => ('a \<rightharpoonup> 'b)" (infixl "`-"  110)
  where
  "m `- S \<equiv> (\<lambda>x. if x \<in> S then None else m x)"

subsection \<open>Properties of maps not related to restriction\<close>

lemma empty_forall_equiv: "(m = Map.empty) = (\<forall>x. m x = None)"
  by (rule fun_eq_iff)

lemma map_le_empty2 [simp]:
  "(m \<subseteq>\<^sub>m Map.empty) = (m = Map.empty)"
  by (auto simp: map_le_def)

lemma dom_iff:
  "(\<exists>y. m x = Some y) = (x \<in> dom m)"
  by auto

lemma non_dom_eval:
  "x \<notin> dom m \<Longrightarrow> m x = None"
  by auto

lemma non_dom_eval_eq:
  "x \<notin> dom m = (m x = None)"
  by auto

lemma map_add_same_left_eq:
  "m\<^sub>1 = m\<^sub>1' \<Longrightarrow> (m\<^sub>0 ++ m\<^sub>1 = m\<^sub>0 ++ m\<^sub>1')"
  by simp

lemma map_add_left_cancelI [intro!]:
  "m\<^sub>1 = m\<^sub>1' \<Longrightarrow> m\<^sub>0 ++ m\<^sub>1 = m\<^sub>0 ++ m\<^sub>1'"
  by simp

lemma dom_empty_is_empty:
  "(dom m = {}) = (m = Map.empty)"
proof (rule iffI)
  assume a: "dom m = {}"
  { assume "m \<noteq> Map.empty"
    hence "dom m \<noteq> {}"
      by - (subst (asm) empty_forall_equiv, simp add: dom_def)
    hence False using a by blast
  }
  thus "m = Map.empty" by blast
next
  assume a: "m = Map.empty"
  thus "dom m = {}" by simp
qed

lemma map_add_dom_eq:
  "dom m = dom m' \<Longrightarrow> m ++ m' = m'"
  by (rule ext) (auto simp: map_add_def split: option.splits)

lemma map_add_right_dom_eq:
  "\<lbrakk> m\<^sub>0 ++ m\<^sub>1 = m\<^sub>0' ++ m\<^sub>1'; dom m\<^sub>1 = dom m\<^sub>1' \<rbrakk> \<Longrightarrow> m\<^sub>1 = m\<^sub>1'"
  unfolding map_add_def
  by (rule ext, rule ccontr,
      drule_tac x=x in fun_cong, clarsimp split: option.splits,
      drule sym, drule sym, force+)

lemma map_le_same_dom_eq:
  "\<lbrakk> m\<^sub>0 \<subseteq>\<^sub>m m\<^sub>1 ; dom m\<^sub>0 = dom m\<^sub>1 \<rbrakk> \<Longrightarrow> m\<^sub>0 = m\<^sub>1"
  by (simp add: map_le_antisym map_le_def)

subsection \<open>Properties of map restriction\<close>

lemma restrict_map_cancel:
  "(m |` S = m |` T) = (dom m \<inter> S = dom m \<inter> T)"
  by (fastforce intro: set_eqI dest: fun_cong
               simp: restrict_map_def None_not_eq
               split: if_split_asm)

lemma map_add_restricted_self [simp]:
  "m ++ m |` S = m"
  by (auto simp: restrict_map_def map_add_def split: option.splits)

lemma map_add_restrict_dom_right [simp]:
  "(m ++ m') |` dom m' = m'"
  by (rule ext, auto simp: restrict_map_def map_add_def split: option.splits)

lemma restrict_map_UNIV [simp]:
  "m |` UNIV = m"
  by (simp add: restrict_map_def)

lemma restrict_map_dom:
  "S = dom m \<Longrightarrow> m |` S = m"
  by (fastforce simp: restrict_map_def None_not_eq)

lemma restrict_map_subdom:
  "dom m \<subseteq> S \<Longrightarrow> m |` S = m"
  by (fastforce simp: restrict_map_def None_com)

lemma map_add_restrict:
  "(m\<^sub>0 ++ m\<^sub>1) |` S = ((m\<^sub>0 |` S) ++ (m\<^sub>1 |` S))"
  by (force simp: map_add_def restrict_map_def)

lemma map_le_restrict:
  "m \<subseteq>\<^sub>m m' \<Longrightarrow> m = m' |` dom m"
  by (force simp: map_le_def restrict_map_def None_com)

lemma restrict_map_le:
  "m |` S \<subseteq>\<^sub>m m"
  by (auto simp: map_le_def)

lemma restrict_map_remerge:
  "\<lbrakk> S \<inter> T = {} \<rbrakk> \<Longrightarrow> m |` S ++ m |` T = m |` (S \<union> T)"
  by (rule ext, clarsimp simp: restrict_map_def map_add_def
                         split: option.splits)

lemma restrict_map_empty:
  "dom m \<inter> S = {} \<Longrightarrow> m |` S = Map.empty"
  by (fastforce simp: restrict_map_def)

lemma map_add_restrict_comp_right [simp]:
  "(m |` S ++ m |` (UNIV - S)) = m"
  by (force simp: map_add_def restrict_map_def split: option.splits)

lemma map_add_restrict_comp_right_dom [simp]:
  "(m |` S ++ m |` (dom m - S)) = m"
  by (fastforce simp: map_add_def restrict_map_def split: option.splits)

lemma map_add_restrict_comp_left [simp]:
  "(m |` (UNIV - S) ++ m |` S) = m"
  by (subst map_add_comm, auto)

lemma restrict_self_UNIV:
  "m |` (dom m - S) = m |` (UNIV - S)"
  by (fastforce simp: restrict_map_def)

lemma map_add_restrict_nonmember_right:
  "x \<notin> dom m' \<Longrightarrow> (m ++ m') |` {x} = m |` {x}"
  by (rule ext, auto simp: restrict_map_def map_add_def split: option.splits)

lemma map_add_restrict_nonmember_left:
  "x \<notin> dom m \<Longrightarrow> (m ++ m') |` {x} = m' |` {x}"
  by (rule ext, auto simp: restrict_map_def map_add_def split: option.splits)

lemma map_add_restrict_right:
  "x \<subseteq> dom m' \<Longrightarrow> (m ++ m') |` x = m' |` x"
  by (rule ext, auto simp: restrict_map_def map_add_def split: option.splits)

lemma restrict_map_compose:
  "\<lbrakk> S \<union> T = dom m ; S \<inter> T = {} \<rbrakk> \<Longrightarrow> m |` S ++ m |` T = m"
  by (fastforce simp: map_add_def restrict_map_def)

lemma map_le_dom_subset_restrict:
  "\<lbrakk> m' \<subseteq>\<^sub>m m; dom m' \<subseteq> S \<rbrakk> \<Longrightarrow> m' \<subseteq>\<^sub>m (m |` S)"
  by (force simp: restrict_map_def map_le_def)

lemma map_le_dom_restrict_sub_add:
  "m' \<subseteq>\<^sub>m m \<Longrightarrow> m |` (dom m - dom m') ++ m' = m"
  by (metis map_add_restrict_comp_right_dom map_le_iff_map_add_commute map_le_restrict)

lemma subset_map_restrict_sub_add:
  "T \<subseteq> S \<Longrightarrow> m |` (S - T) ++ m |` T = m |` S"
  by (fastforce simp: restrict_map_def map_add_def split: option.splits)

lemma restrict_map_sub_union:
  "m |` (dom m - (S \<union> T)) = (m |` (dom m - T)) |` (dom m - S)"
  by (auto simp: restrict_map_def)

lemma prod_restrict_map_add:
  "\<lbrakk> S \<union> T = U; S \<inter> T = {} \<rbrakk> \<Longrightarrow> m |` (X \<times> S) ++ m |` (X \<times> T) = m |` (X \<times> U)"
  by (auto simp: map_add_def restrict_map_def split: option.splits)

text \<open>---------------------------------------\<close>
text \<open>Things that should NOT go into Map.thy\<close>
text \<open>---------------------------------------\<close>

section \<open>Definitions\<close>

text \<open>Map disjuction\<close>

definition
  map_disj :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> bool" (infix "\<bottom>" 51) where
  "h\<^sub>0 \<bottom> h\<^sub>1 \<equiv> dom h\<^sub>0 \<inter> dom h\<^sub>1 = {}"

declare None_not_eq [simp]

text \<open>Heap monotonicity and the frame property\<close>

definition
  heap_mono :: "(('a \<rightharpoonup> 'b) \<Rightarrow> 'c option) \<Rightarrow> bool" where
  "heap_mono f \<equiv> \<forall>h h' v. h \<bottom> h' \<and> f h = Some v \<longrightarrow> f (h ++ h') = Some v"

lemma heap_monoE:
  "\<lbrakk> heap_mono f ; f h = Some v ; h \<bottom> h' \<rbrakk> \<Longrightarrow> f (h ++ h') = Some v"
  unfolding heap_mono_def by blast

lemma heap_mono_simp:
  "\<lbrakk> heap_mono f ; f h = Some v ; h \<bottom> h' \<rbrakk> \<Longrightarrow> f (h ++ h') = f h"
  by (frule (2) heap_monoE, simp)

definition
  heap_frame :: "(('a \<rightharpoonup> 'b) \<Rightarrow> 'c option) \<Rightarrow> bool" where
  "heap_frame f \<equiv> \<forall>h h' v. h \<bottom> h' \<and> f (h ++ h') = Some v
                           \<longrightarrow> (f h = Some v \<or> f h = None)"

lemma heap_frameE:
  "\<lbrakk> heap_frame f ; f (h ++ h') = Some v ; h \<bottom> h' \<rbrakk>
   \<Longrightarrow> f h = Some v \<or> f h = None"
  unfolding heap_frame_def by fastforce

section \<open>Properties of @{term "sub_restrict_map"}\<close>

lemma restrict_map_sub_add: "h |` S ++ h `- S = h"
  by (fastforce simp: sub_restrict_map_def restrict_map_def map_add_def
               split: option.splits if_split)

section \<open>Properties of map disjunction\<close>

lemma map_disj_empty_right [simp]:
  "h \<bottom> Map.empty"
  by (simp add: map_disj_def)

lemma map_disj_empty_left [simp]:
  "Map.empty \<bottom> h"
  by (simp add: map_disj_def)

lemma map_disj_com:
  "h\<^sub>0 \<bottom> h\<^sub>1 = h\<^sub>1 \<bottom> h\<^sub>0"
  by (simp add: map_disj_def, fast)

lemma map_disjD:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> dom h\<^sub>0 \<inter> dom h\<^sub>1 = {}"
  by (simp add: map_disj_def)

lemma map_disjI:
  "dom h\<^sub>0 \<inter> dom h\<^sub>1 = {} \<Longrightarrow> h\<^sub>0 \<bottom> h\<^sub>1"
  by (simp add: map_disj_def)

subsection \<open>Map associativity-commutativity based on map disjuction\<close>

lemma map_add_com:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 ++ h\<^sub>1 = h\<^sub>1 ++ h\<^sub>0"
  by (drule map_disjD, rule map_add_comm, force)

lemma map_add_left_commute:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 ++ (h\<^sub>1 ++ h\<^sub>2) = h\<^sub>1 ++ (h\<^sub>0 ++ h\<^sub>2)"
  by (simp add: map_add_com map_disj_com)

lemma map_add_disj:
  "h\<^sub>0 \<bottom> (h\<^sub>1 ++ h\<^sub>2) = (h\<^sub>0 \<bottom> h\<^sub>1 \<and> h\<^sub>0 \<bottom> h\<^sub>2)"
  by (simp add: map_disj_def, fast)

lemma map_add_disj':
  "(h\<^sub>1 ++ h\<^sub>2) \<bottom> h\<^sub>0 = (h\<^sub>1 \<bottom> h\<^sub>0 \<and> h\<^sub>2 \<bottom> h\<^sub>0)"
  by (simp add: map_disj_def, fast)

text \<open>
  We redefine @{term "map_add"} associativity to bind to the right, which
  seems to be the more common case.
  Note that when a theory includes Map again, @{text "map_add_assoc"} will
  return to the simpset and will cause infinite loops if its symmetric
  counterpart is added (e.g. via @{text "map_ac_simps"})
\<close>

declare map_add_assoc [simp del]

text \<open>
  Since the associativity-commutativity of @{term "map_add"} relies on
  map disjunction, we include some basic rules into the ac set.
\<close>

lemmas map_ac_simps =
  map_add_assoc[symmetric] map_add_com map_disj_com
  map_add_left_commute map_add_disj map_add_disj'

subsection \<open>Basic properties\<close>

lemma map_disj_None_right:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; x \<in> dom h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>1 x = None"
  by (auto simp: map_disj_def dom_def)

lemma map_disj_None_left:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; x \<in> dom h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0 x = None"
  by (auto simp: map_disj_def dom_def)

lemma map_disj_None_left':
  "\<lbrakk> h\<^sub>0 x = Some y ; h\<^sub>1 \<bottom> h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>1 x = None "
  by (auto simp: map_disj_def)

lemma map_disj_None_right':
  "\<lbrakk> h\<^sub>1 x = Some y ; h\<^sub>1 \<bottom> h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>0 x = None "
  by (auto simp: map_disj_def)

lemma map_disj_common:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; h\<^sub>0 p = Some v ; h\<^sub>1 p = Some v' \<rbrakk> \<Longrightarrow> False"
  by (frule (1) map_disj_None_left', simp)

subsection \<open>Map disjunction and addition\<close>

lemma map_add_eval_left:
  "\<lbrakk> x \<in> dom h ; h \<bottom> h' \<rbrakk> \<Longrightarrow> (h ++ h') x = h x"
  by (auto dest!: map_disj_None_right simp: map_add_def cong: option.case_cong)

lemma map_add_eval_right:
  "\<lbrakk> x \<in> dom h' ; h \<bottom> h' \<rbrakk> \<Longrightarrow> (h ++ h') x = h' x"
  by (auto elim!: map_disjD simp: map_add_comm map_add_eval_left map_disj_com)

lemma map_add_eval_right':
  "\<lbrakk> x \<notin> dom h ; h \<bottom> h' \<rbrakk> \<Longrightarrow> (h ++ h') x = h' x"
  by (clarsimp simp: map_disj_def map_add_def split: option.splits)

lemma map_add_left_dom_eq:
  assumes eq: "h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0' ++ h\<^sub>1'"
  assumes etc: "h\<^sub>0 \<bottom> h\<^sub>1" "h\<^sub>0' \<bottom> h\<^sub>1'" "dom h\<^sub>0 = dom h\<^sub>0'"
  shows "h\<^sub>0 = h\<^sub>0'"
proof -
  from eq have "h\<^sub>1 ++ h\<^sub>0 = h\<^sub>1' ++ h\<^sub>0'" using etc by (simp add: map_ac_simps)
  thus ?thesis using etc
    by (fastforce elim!: map_add_right_dom_eq simp: map_ac_simps)
qed

lemma map_add_left_eq:
  assumes eq: "h\<^sub>0 ++ h = h\<^sub>1 ++ h"
  assumes disj: "h\<^sub>0 \<bottom> h" "h\<^sub>1 \<bottom> h"
  shows "h\<^sub>0 = h\<^sub>1"
proof (rule ext)
  fix x
  from eq have eq': "(h\<^sub>0 ++ h) x = (h\<^sub>1 ++ h) x" by auto
  { assume "x \<in> dom h"
    hence "h\<^sub>0 x = h\<^sub>1 x" using disj by (simp add: map_disj_None_left)
  } moreover {
    assume "x \<notin> dom h"
    hence "h\<^sub>0 x = h\<^sub>1 x" using disj eq' by (simp add: map_add_eval_left')
  }
  ultimately show "h\<^sub>0 x = h\<^sub>1 x" by cases
qed

lemma map_add_right_eq:
  "\<lbrakk>h ++ h\<^sub>0 = h ++ h\<^sub>1; h\<^sub>0 \<bottom> h; h\<^sub>1 \<bottom> h\<rbrakk> \<Longrightarrow> h\<^sub>0 = h\<^sub>1"
  by (rule_tac h=h in map_add_left_eq, auto simp: map_ac_simps)

lemma map_disj_add_eq_dom_right_eq:
  assumes merge: "h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0' ++ h\<^sub>1'" and d: "dom h\<^sub>0 = dom h\<^sub>0'" and
      ab_disj: "h\<^sub>0 \<bottom> h\<^sub>1" and cd_disj: "h\<^sub>0' \<bottom> h\<^sub>1'"
  shows "h\<^sub>1 = h\<^sub>1'"
proof (rule ext)
  fix x
  from merge have merge_x: "(h\<^sub>0 ++ h\<^sub>1) x = (h\<^sub>0' ++ h\<^sub>1') x" by simp
  with d ab_disj cd_disj show  "h\<^sub>1 x = h\<^sub>1' x"
    by - (case_tac "h\<^sub>1 x", case_tac "h\<^sub>1' x", simp, fastforce simp: map_disj_def,
          case_tac "h\<^sub>1' x", clarsimp, simp add: Some_com,
          force simp: map_disj_def, simp)
qed

lemma map_disj_add_eq_dom_left_eq:
  assumes add: "h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0' ++ h\<^sub>1'" and
          dom: "dom h\<^sub>1 = dom h\<^sub>1'" and
          disj: "h\<^sub>0 \<bottom> h\<^sub>1" "h\<^sub>0' \<bottom> h\<^sub>1'"
  shows "h\<^sub>0 = h\<^sub>0'"
proof -
  have "h\<^sub>1 ++ h\<^sub>0 = h\<^sub>1' ++ h\<^sub>0'" using add disj by (simp add: map_ac_simps)
  thus ?thesis using dom disj
    by - (rule map_disj_add_eq_dom_right_eq, auto simp: map_disj_com)
qed

lemma map_add_left_cancel:
  assumes disj: "h\<^sub>0 \<bottom> h\<^sub>1" "h\<^sub>0 \<bottom> h\<^sub>1'"
  shows "(h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0 ++ h\<^sub>1') = (h\<^sub>1 = h\<^sub>1')"
proof (rule iffI, rule ext)
  fix x
  assume "(h\<^sub>0 ++ h\<^sub>1) = (h\<^sub>0 ++ h\<^sub>1')"
  hence "(h\<^sub>0 ++ h\<^sub>1) x = (h\<^sub>0 ++ h\<^sub>1') x" by auto
  hence "h\<^sub>1 x = h\<^sub>1' x" using disj
    by - (cases "x \<in> dom h\<^sub>0",
          simp_all add: map_disj_None_right map_add_eval_right')
  thus "h\<^sub>1 x = h\<^sub>1' x" by auto
qed auto

lemma map_add_lr_disj:
  "\<lbrakk> h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0' ++ h\<^sub>1'; h\<^sub>1 \<bottom> h\<^sub>1'  \<rbrakk> \<Longrightarrow> dom h\<^sub>1 \<subseteq> dom h\<^sub>0'"
  by (clarsimp simp: map_disj_def map_add_def, drule_tac x=x in fun_cong)
     (auto split: option.splits)

subsection \<open>Map disjunction and updates\<close>

lemma map_disj_update_left [simp]:
  "p \<in> dom h\<^sub>1 \<Longrightarrow> h\<^sub>0 \<bottom> h\<^sub>1(p \<mapsto> v) = h\<^sub>0 \<bottom> h\<^sub>1"
  by (clarsimp simp add: map_disj_def, blast)

lemma map_disj_update_right [simp]:
  "p \<in> dom h\<^sub>1 \<Longrightarrow> h\<^sub>1(p \<mapsto> v) \<bottom> h\<^sub>0 = h\<^sub>1 \<bottom> h\<^sub>0"
  by (simp add: map_disj_com)

lemma map_add_update_left:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; p \<in> dom h\<^sub>0 \<rbrakk> \<Longrightarrow> (h\<^sub>0 ++ h\<^sub>1)(p \<mapsto> v) = (h\<^sub>0(p \<mapsto> v) ++ h\<^sub>1)"
  by (drule (1) map_disj_None_right)
     (auto simp: map_add_def cong: option.case_cong)

lemma map_add_update_right:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; p \<in> dom h\<^sub>1  \<rbrakk> \<Longrightarrow> (h\<^sub>0 ++ h\<^sub>1)(p \<mapsto> v) = (h\<^sub>0 ++ h\<^sub>1 (p \<mapsto> v))"
  by (drule (1) map_disj_None_left)
     (auto simp: map_add_def cong: option.case_cong)

subsection \<open>Map disjunction and @{term "map_le"}\<close>

lemma map_le_override [simp]:
  "\<lbrakk> h \<bottom> h' \<rbrakk> \<Longrightarrow> h \<subseteq>\<^sub>m h ++ h'"
  by (auto simp: map_le_def map_add_def map_disj_def split: option.splits)

lemma map_leI_left:
  "\<lbrakk> h = h\<^sub>0 ++ h\<^sub>1 ; h\<^sub>0 \<bottom> h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0 \<subseteq>\<^sub>m h" by auto

lemma map_leI_right:
  "\<lbrakk> h = h\<^sub>0 ++ h\<^sub>1 ; h\<^sub>0 \<bottom> h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>1 \<subseteq>\<^sub>m h" by auto

lemma map_disj_map_le:
  "\<lbrakk> h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0; h\<^sub>0 \<bottom> h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0' \<bottom> h\<^sub>1"
  by (force simp: map_disj_def map_le_def)

lemma map_le_on_disj_left:
  "\<lbrakk> h' \<subseteq>\<^sub>m h ; h\<^sub>0 \<bottom> h\<^sub>1 ; h' = h\<^sub>0 ++ h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0 \<subseteq>\<^sub>m h"
  unfolding map_le_def
  by (rule ballI, erule_tac x=a in ballE, auto simp: map_add_eval_left)+

lemma map_le_on_disj_right:
  "\<lbrakk> h' \<subseteq>\<^sub>m h ; h\<^sub>0 \<bottom> h\<^sub>1 ; h' = h\<^sub>1 ++ h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>0 \<subseteq>\<^sub>m h"
  by (auto simp: map_le_on_disj_left map_ac_simps)

lemma map_le_add_cancel:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>0' ++ h\<^sub>1 \<subseteq>\<^sub>m h\<^sub>0 ++ h\<^sub>1"
  by (auto simp: map_le_def map_add_def map_disj_def split: option.splits)

lemma map_le_override_bothD:
  assumes subm: "h\<^sub>0' ++ h\<^sub>1 \<subseteq>\<^sub>m h\<^sub>0 ++ h\<^sub>1"
  assumes disj': "h\<^sub>0' \<bottom> h\<^sub>1"
  assumes disj: "h\<^sub>0 \<bottom> h\<^sub>1"
  shows "h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0"
unfolding map_le_def
proof (rule ballI)
  fix a
  assume a: "a \<in> dom h\<^sub>0'"
  hence sumeq: "(h\<^sub>0' ++ h\<^sub>1) a = (h\<^sub>0 ++ h\<^sub>1) a"
    using subm unfolding map_le_def by auto
  from a have "a \<notin> dom h\<^sub>1" using disj' by (auto dest!: map_disj_None_right)
  thus "h\<^sub>0' a = h\<^sub>0 a" using a sumeq disj disj'
    by (simp add: map_add_eval_left map_add_eval_left')
qed

lemma map_le_conv:
  "(h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0 \<and> h\<^sub>0' \<noteq> h\<^sub>0) = (\<exists>h\<^sub>1. h\<^sub>0 = h\<^sub>0' ++ h\<^sub>1 \<and> h\<^sub>0' \<bottom> h\<^sub>1 \<and> h\<^sub>0' \<noteq> h\<^sub>0)"
  unfolding map_le_def map_disj_def map_add_def
  using exI[where x="\<lambda>x. if x \<notin> dom h\<^sub>0' then h\<^sub>0 x else None"]
  by (rule iffI, clarsimp)
     (fastforce intro: set_eqI split: option.splits if_split_asm)+

lemma map_le_conv2:
  "h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0 = (\<exists>h\<^sub>1. h\<^sub>0 = h\<^sub>0' ++ h\<^sub>1 \<and> h\<^sub>0' \<bottom> h\<^sub>1)"
  by (case_tac "h\<^sub>0'=h\<^sub>0", insert map_le_conv, auto intro: exI[where x=Map.empty])

subsection \<open>Map disjunction and restriction\<close>

lemma map_disj_comp [simp]:
  "h\<^sub>0 \<bottom> h\<^sub>1 |` (UNIV - dom h\<^sub>0)"
  by (force simp: map_disj_def)

lemma restrict_map_disj:
  "S \<inter> T = {} \<Longrightarrow> h |` S \<bottom> h |` T"
  by (auto simp: map_disj_def restrict_map_def dom_def)

lemma map_disj_restrict_dom [simp]:
  "h\<^sub>0 \<bottom> h\<^sub>1 |` (dom h\<^sub>1 - dom h\<^sub>0)"
  by (force simp: map_disj_def)

lemma restrict_map_disj_dom_empty:
  "h \<bottom> h' \<Longrightarrow> h |` dom h' = Map.empty"
  by (fastforce simp: map_disj_def restrict_map_def)

lemma restrict_map_univ_disj_eq:
  "h \<bottom> h' \<Longrightarrow> h |` (UNIV - dom h') = h"
  by (rule ext, auto simp: map_disj_def restrict_map_def)

lemma restrict_map_disj_dom:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h |` dom h\<^sub>0 \<bottom> h |` dom h\<^sub>1"
  by (auto simp: map_disj_def restrict_map_def dom_def)

lemma map_add_restrict_dom_left:
  "h \<bottom> h' \<Longrightarrow> (h ++ h') |` dom h = h"
  by (rule ext, auto simp: restrict_map_def map_add_def dom_def map_disj_def
                     split: option.splits)

lemma restrict_map_disj_right:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 \<bottom> h\<^sub>1 |` S"
  by (auto simp: map_disj_def)

lemmas restrict_map_disj_both = restrict_map_disj_right restrict_map_disj_left

lemma map_dom_disj_restrict_right:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> (h\<^sub>0 ++ h\<^sub>0') |` dom h\<^sub>1 = h\<^sub>0' |` dom h\<^sub>1"
  by (simp add: map_add_restrict restrict_map_empty map_disj_def)

lemma restrict_map_on_disj:
  "h\<^sub>0' \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 |` dom h\<^sub>0' \<bottom> h\<^sub>1"
  unfolding map_disj_def by auto

lemma restrict_map_on_disj':
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 \<bottom> h\<^sub>1 |` S"
  by (auto simp: map_disj_def map_add_def)

lemma map_le_sub_dom:
  "\<lbrakk> h\<^sub>0 ++ h\<^sub>1 \<subseteq>\<^sub>m h ; h\<^sub>0 \<bottom> h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0 \<subseteq>\<^sub>m h |` (dom h - dom h\<^sub>1)"
  by (rule map_le_override_bothD, subst map_le_dom_restrict_sub_add)
     (auto elim: map_add_le_mapE simp: map_ac_simps)

lemma map_submap_break:
  "\<lbrakk> h \<subseteq>\<^sub>m h' \<rbrakk> \<Longrightarrow> h' = (h' |` (UNIV - dom h)) ++ h"
  by (fastforce split: option.splits
                simp: map_le_restrict restrict_map_def map_le_def map_add_def dom_def)

lemma map_add_disj_restrict_both:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1; S \<inter> S' = {}; T \<inter> T' = {} \<rbrakk>
   \<Longrightarrow> (h\<^sub>0 |` S) ++ (h\<^sub>1 |` T) \<bottom> (h\<^sub>0 |` S') ++ (h\<^sub>1 |` T')"
  by (auto simp: map_ac_simps intro!: restrict_map_disj_both restrict_map_disj)

end


theory Nominal2_Abs
imports "Nominal2_Base"
        "~~/src/HOL/Quotient"
        "~~/src/HOL/Library/Quotient_List"
        "~~/src/HOL/Library/Quotient_Product"
begin

section {* Abstractions *}

fun
  alpha_set
where
  alpha_set[simp del]:
  "alpha_set (bs, x) R f p (cs, y) \<longleftrightarrow>
     f x - bs = f y - cs \<and>
     (f x - bs) \<sharp>* p \<and>
     R (p \<bullet> x) y \<and>
     p \<bullet> bs = cs"

fun
  alpha_res
where
  alpha_res[simp del]:
  "alpha_res (bs, x) R f p (cs, y) \<longleftrightarrow>
     f x - bs = f y - cs \<and>
     (f x - bs) \<sharp>* p \<and>
     R (p \<bullet> x) y"

fun
  alpha_lst
where
  alpha_lst[simp del]:
  "alpha_lst (bs, x) R f p (cs, y) \<longleftrightarrow>
     f x - set bs = f y - set cs \<and>
     (f x - set bs) \<sharp>* p \<and>
     R (p \<bullet> x) y \<and>
     p \<bullet> bs = cs"

lemmas alphas = alpha_set.simps alpha_res.simps alpha_lst.simps

notation
  alpha_set ("_ \<approx>set _ _ _ _" [100, 100, 100, 100, 100] 100) and
  alpha_res ("_ \<approx>res _ _ _ _" [100, 100, 100, 100, 100] 100) and
  alpha_lst ("_ \<approx>lst _ _ _ _" [100, 100, 100, 100, 100] 100)

section {* Mono *}

lemma [mono]:
  shows "R1 \<le> R2 \<Longrightarrow> alpha_set bs R1 \<le> alpha_set bs R2"
  and   "R1 \<le> R2 \<Longrightarrow> alpha_res bs R1 \<le> alpha_res bs R2"
  and   "R1 \<le> R2 \<Longrightarrow> alpha_lst cs R1 \<le> alpha_lst cs R2"
  by (case_tac [!] bs, case_tac [!] cs)
     (auto simp: le_fun_def le_bool_def alphas)

section {* Equivariance *}

lemma alpha_eqvt[eqvt]:
  shows "(bs, x) \<approx>set R f q (cs, y) \<Longrightarrow> (p \<bullet> bs, p \<bullet> x) \<approx>set (p \<bullet> R) (p \<bullet> f) (p \<bullet> q) (p \<bullet> cs, p \<bullet> y)"
  and   "(bs, x) \<approx>res R f q (cs, y) \<Longrightarrow> (p \<bullet> bs, p \<bullet> x) \<approx>res (p \<bullet> R) (p \<bullet> f) (p \<bullet> q) (p \<bullet> cs, p \<bullet> y)"
  and   "(ds, x) \<approx>lst R f q (es, y) \<Longrightarrow> (p \<bullet> ds, p \<bullet> x) \<approx>lst (p \<bullet> R) (p \<bullet> f) (p \<bullet> q) (p \<bullet> es, p \<bullet> y)"
  unfolding alphas
  unfolding permute_eqvt[symmetric]
  unfolding set_eqvt[symmetric]
  unfolding permute_fun_app_eq[symmetric]
  unfolding Diff_eqvt[symmetric]
  unfolding eq_eqvt[symmetric]
  unfolding fresh_star_eqvt[symmetric]
  by (auto simp only: permute_bool_def)

section {* Equivalence *}

lemma alpha_refl:
  assumes a: "R x x"
  shows "(bs, x) \<approx>set R f 0 (bs, x)"
  and   "(bs, x) \<approx>res R f 0 (bs, x)"
  and   "(cs, x) \<approx>lst R f 0 (cs, x)"
  using a
  unfolding alphas
  unfolding fresh_star_def
  by (simp_all add: fresh_zero_perm)

lemma alpha_sym:
  assumes a: "R (p \<bullet> x) y \<Longrightarrow> R (- p \<bullet> y) x"
  shows "(bs, x) \<approx>set R f p (cs, y) \<Longrightarrow> (cs, y) \<approx>set R f (- p) (bs, x)"
  and   "(bs, x) \<approx>res R f p (cs, y) \<Longrightarrow> (cs, y) \<approx>res R f (- p) (bs, x)"
  and   "(ds, x) \<approx>lst R f p (es, y) \<Longrightarrow> (es, y) \<approx>lst R f (- p) (ds, x)"
  unfolding alphas fresh_star_def
  using a
  by (auto simp: fresh_minus_perm)

lemma alpha_trans:
  assumes a: "\<lbrakk>R (p \<bullet> x) y; R (q \<bullet> y) z\<rbrakk> \<Longrightarrow> R ((q + p) \<bullet> x) z"
  shows "\<lbrakk>(bs, x) \<approx>set R f p (cs, y); (cs, y) \<approx>set R f q (ds, z)\<rbrakk> \<Longrightarrow> (bs, x) \<approx>set R f (q + p) (ds, z)"
  and   "\<lbrakk>(bs, x) \<approx>res R f p (cs, y); (cs, y) \<approx>res R f q (ds, z)\<rbrakk> \<Longrightarrow> (bs, x) \<approx>res R f (q + p) (ds, z)"
  and   "\<lbrakk>(es, x) \<approx>lst R f p (gs, y); (gs, y) \<approx>lst R f q (hs, z)\<rbrakk> \<Longrightarrow> (es, x) \<approx>lst R f (q + p) (hs, z)"
  using a
  unfolding alphas fresh_star_def
  by (simp_all add: fresh_plus_perm)

lemma alpha_sym_eqvt:
  assumes a: "R (p \<bullet> x) y \<Longrightarrow> R y (p \<bullet> x)"
  and     b: "p \<bullet> R = R"
  shows "(bs, x) \<approx>set R f p (cs, y) \<Longrightarrow> (cs, y) \<approx>set R f (- p) (bs, x)"
  and   "(bs, x) \<approx>res R f p (cs, y) \<Longrightarrow> (cs, y) \<approx>res R f (- p) (bs, x)"
  and   "(ds, x) \<approx>lst R f p (es, y) \<Longrightarrow> (es, y) \<approx>lst R f (- p) (ds, x)"
apply(auto intro!: alpha_sym)
apply(drule_tac [!] a)
apply(rule_tac [!] p="p" in permute_boolE)
apply(simp_all add: b permute_self)
done

lemma alpha_set_trans_eqvt:
  assumes b: "(cs, y) \<approx>set R f q (ds, z)"
  and     a: "(bs, x) \<approx>set R f p (cs, y)"
  and     d: "q \<bullet> R = R"
  and     c: "\<lbrakk>R (p \<bullet> x) y; R y (- q \<bullet> z)\<rbrakk> \<Longrightarrow> R (p \<bullet> x) (- q \<bullet> z)"
  shows "(bs, x) \<approx>set R f (q + p) (ds, z)"
apply(rule alpha_trans(1)[OF _ a b])
apply(drule c)
apply(rule_tac p="q" in permute_boolE)
apply(simp add: d permute_self)
apply(rotate_tac -1)
apply(drule_tac p="q" in permute_boolI)
apply(simp add: d permute_self permute_eqvt[symmetric])
done

lemma alpha_res_trans_eqvt:
  assumes  b: "(cs, y) \<approx>res R f q (ds, z)"
  and     a: "(bs, x) \<approx>res R f p (cs, y)"
  and     d: "q \<bullet> R = R"
  and     c: "\<lbrakk>R (p \<bullet> x) y; R y (- q \<bullet> z)\<rbrakk> \<Longrightarrow> R (p \<bullet> x) (- q \<bullet> z)"
  shows "(bs, x) \<approx>res R f (q + p) (ds, z)"
apply(rule alpha_trans(2)[OF _ a b])
apply(drule c)
apply(rule_tac p="q" in permute_boolE)
apply(simp add: d permute_self)
apply(rotate_tac -1)
apply(drule_tac p="q" in permute_boolI)
apply(simp add: d permute_self permute_eqvt[symmetric])
done

lemma alpha_lst_trans_eqvt:
  assumes b: "(cs, y) \<approx>lst R f q (ds, z)"
  and     a: "(bs, x) \<approx>lst R f p (cs, y)"
  and     d: "q \<bullet> R = R"
  and     c: "\<lbrakk>R (p \<bullet> x) y; R y (- q \<bullet> z)\<rbrakk> \<Longrightarrow> R (p \<bullet> x) (- q \<bullet> z)"
  shows "(bs, x) \<approx>lst R f (q + p) (ds, z)"
apply(rule alpha_trans(3)[OF _ a b])
apply(drule c)
apply(rule_tac p="q" in permute_boolE)
apply(simp add: d permute_self)
apply(rotate_tac -1)
apply(drule_tac p="q" in permute_boolI)
apply(simp add: d permute_self permute_eqvt[symmetric])
done

lemmas alpha_trans_eqvt = alpha_set_trans_eqvt alpha_res_trans_eqvt alpha_lst_trans_eqvt

section {* General Abstractions *}

fun
  alpha_abs_set
where
  [simp del]:
  "alpha_abs_set (bs, x) (cs, y) \<longleftrightarrow> (\<exists>p. (bs, x) \<approx>set (op=) supp p (cs, y))"

fun
  alpha_abs_lst
where
  [simp del]:
  "alpha_abs_lst (bs, x) (cs, y) \<longleftrightarrow> (\<exists>p. (bs, x) \<approx>lst (op=) supp p (cs, y))"

fun
  alpha_abs_res
where
  [simp del]:
  "alpha_abs_res (bs, x) (cs, y) \<longleftrightarrow> (\<exists>p. (bs, x) \<approx>res (op=) supp p (cs, y))"

notation
  alpha_abs_set (infix "\<approx>abs'_set" 50) and
  alpha_abs_lst (infix "\<approx>abs'_lst" 50) and
  alpha_abs_res (infix "\<approx>abs'_res" 50)

lemmas alphas_abs = alpha_abs_set.simps alpha_abs_res.simps alpha_abs_lst.simps

lemma alphas_abs_refl:
  shows "(bs, x) \<approx>abs_set (bs, x)"
  and   "(bs, x) \<approx>abs_res (bs, x)"
  and   "(cs, x) \<approx>abs_lst (cs, x)"
  unfolding alphas_abs
  unfolding alphas
  unfolding fresh_star_def
  by (rule_tac [!] x="0" in exI)
     (simp_all add: fresh_zero_perm)

lemma alphas_abs_sym:
  shows "(bs, x) \<approx>abs_set (cs, y) \<Longrightarrow> (cs, y) \<approx>abs_set (bs, x)"
  and   "(bs, x) \<approx>abs_res (cs, y) \<Longrightarrow> (cs, y) \<approx>abs_res (bs, x)"
  and   "(ds, x) \<approx>abs_lst (es, y) \<Longrightarrow> (es, y) \<approx>abs_lst (ds, x)"
  unfolding alphas_abs
  unfolding alphas
  unfolding fresh_star_def
  by (erule_tac [!] exE, rule_tac [!] x="-p" in exI)
     (auto simp: fresh_minus_perm)

lemma alphas_abs_trans:
  shows "\<lbrakk>(bs, x) \<approx>abs_set (cs, y); (cs, y) \<approx>abs_set (ds, z)\<rbrakk> \<Longrightarrow> (bs, x) \<approx>abs_set (ds, z)"
  and   "\<lbrakk>(bs, x) \<approx>abs_res (cs, y); (cs, y) \<approx>abs_res (ds, z)\<rbrakk> \<Longrightarrow> (bs, x) \<approx>abs_res (ds, z)"
  and   "\<lbrakk>(es, x) \<approx>abs_lst (gs, y); (gs, y) \<approx>abs_lst (hs, z)\<rbrakk> \<Longrightarrow> (es, x) \<approx>abs_lst (hs, z)"
  unfolding alphas_abs
  unfolding alphas
  unfolding fresh_star_def
  apply(erule_tac [!] exE, erule_tac [!] exE)
  apply(rule_tac [!] x="pa + p" in exI)
  by (simp_all add: fresh_plus_perm)

lemma alphas_abs_eqvt:
  shows "(bs, x) \<approx>abs_set (cs, y) \<Longrightarrow> (p \<bullet> bs, p \<bullet> x) \<approx>abs_set (p \<bullet> cs, p \<bullet> y)"
  and   "(bs, x) \<approx>abs_res (cs, y) \<Longrightarrow> (p \<bullet> bs, p \<bullet> x) \<approx>abs_res (p \<bullet> cs, p \<bullet> y)"
  and   "(ds, x) \<approx>abs_lst (es, y) \<Longrightarrow> (p \<bullet> ds, p \<bullet> x) \<approx>abs_lst (p \<bullet> es, p \<bullet> y)"
  unfolding alphas_abs
  unfolding alphas
  unfolding set_eqvt[symmetric]
  unfolding supp_eqvt[symmetric]
  unfolding Diff_eqvt[symmetric]
  apply(erule_tac [!] exE)
  apply(rule_tac [!] x="p \<bullet> pa" in exI)
  by (auto simp only: fresh_star_permute_iff permute_eqvt[symmetric])

section {* Strengthening the equivalence *}

lemma disjoint_right_eq:
  assumes a: "A \<union> B1 = A \<union> B2"
  and     b: "A \<inter> B1 = {}" "A \<inter> B2 = {}"
  shows "B1 = B2"
using a b
by (metis Int_Un_distrib2 Int_absorb2 Int_commute Un_upper2)

lemma supp_property_res:
  assumes a: "(as, x) \<approx>res (op =) supp p (as', x')"
  shows "p \<bullet> (supp x \<inter> as) = supp x' \<inter> as'"
proof -
  from a have "(supp x - as) \<sharp>* p" by  (auto simp only: alphas)
  then have *: "p \<bullet> (supp x - as) = (supp x - as)"
    by (simp add: atom_set_perm_eq)
  have "(supp x' - as') \<union> (supp x' \<inter> as') = supp x'" by auto
  also have "\<dots> = supp (p \<bullet> x)" using a by (simp add: alphas)
  also have "\<dots> = p \<bullet> (supp x)" by (simp add: supp_eqvt)
  also have "\<dots> = p \<bullet> ((supp x - as) \<union> (supp x \<inter> as))" by auto
  also have "\<dots> = (p \<bullet> (supp x - as)) \<union> (p \<bullet> (supp x \<inter> as))" by (simp add: union_eqvt)
  also have "\<dots> = (supp x - as) \<union> (p \<bullet> (supp x \<inter> as))" using * by simp
  also have "\<dots> = (supp x' - as') \<union> (p \<bullet> (supp x \<inter> as))" using a by (simp add: alphas)
  finally have "(supp x' - as') \<union> (supp x' \<inter> as') = (supp x' - as') \<union> (p \<bullet> (supp x \<inter> as))" .
  moreover
  have "(supp x' - as') \<inter> (supp x' \<inter> as') = {}" by auto
  moreover
  have "(supp x - as) \<inter> (supp x \<inter> as) = {}" by auto
  then have "p \<bullet> ((supp x - as) \<inter> (supp x \<inter> as) = {})" by (simp add: permute_bool_def)
  then have "(p \<bullet> (supp x - as)) \<inter> (p \<bullet> (supp x \<inter> as)) = {}" by (perm_simp) (simp)
  then have "(supp x - as) \<inter> (p \<bullet> (supp x \<inter> as)) = {}" using * by simp
  then have "(supp x' - as') \<inter> (p \<bullet> (supp x \<inter> as)) = {}" using a by (simp add: alphas)
  ultimately show "p \<bullet> (supp x \<inter> as) = supp x' \<inter> as'"
    by (auto dest: disjoint_right_eq)
qed

lemma alpha_abs_res_stronger1_aux:
  assumes asm: "(as, x) \<approx>res (op =) supp p' (as', x')"
  shows "\<exists>p. (as, x) \<approx>res (op =) supp p (as', x') \<and> supp p \<subseteq> (supp x \<inter> as) \<union> (supp x' \<inter> as')"
proof -
  from asm have 0: "(supp x - as) \<sharp>* p'" by  (auto simp only: alphas)
  then have #: "p' \<bullet> (supp x - as) = (supp x - as)"
    by (simp add: atom_set_perm_eq)
  obtain p where *: "\<forall>b \<in> supp x. p \<bullet> b = p' \<bullet> b" and **: "supp p \<subseteq> supp x \<union> p' \<bullet> supp x"
    using set_renaming_perm2 by blast
  from * have a: "p \<bullet> x = p' \<bullet> x" using supp_perm_perm_eq by auto
  from 0 have 1: "(supp x - as) \<sharp>* p" using *
    by (auto simp: fresh_star_def fresh_perm)
  then have 2: "(supp x - as) \<inter> supp p = {}"
    by (auto simp: fresh_star_def fresh_def)
  have b: "supp x = (supp x - as) \<union> (supp x \<inter> as)" by auto
  have "supp p \<subseteq> supp x \<union> p' \<bullet> supp x" using ** by simp
  also have "\<dots> = (supp x - as) \<union> (supp x \<inter> as) \<union> (p' \<bullet> ((supp x - as) \<union> (supp x \<inter> as)))"
    using b by simp
  also have "\<dots> = (supp x - as) \<union> (supp x \<inter> as) \<union> ((p' \<bullet> (supp x - as)) \<union> (p' \<bullet> (supp x \<inter> as)))"
    by (simp add: union_eqvt)
  also have "\<dots> = (supp x - as) \<union> (supp x \<inter> as) \<union> (p' \<bullet> (supp x \<inter> as))"
    using # by auto
  also have "\<dots> = (supp x - as) \<union> (supp x \<inter> as) \<union> (supp x' \<inter> as')" using asm
    by (simp add: supp_property_res)
  finally have "supp p \<subseteq> (supp x - as) \<union> (supp x \<inter> as) \<union> (supp x' \<inter> as')" .
  then
  have "supp p \<subseteq> (supp x \<inter> as) \<union> (supp x' \<inter> as')" using 2 by auto
  moreover
  have "(as, x) \<approx>res (op =) supp p (as', x')" using asm 1 a by (simp add: alphas)
  ultimately
  show "\<exists>p. (as, x) \<approx>res (op =) supp p (as', x') \<and> supp p \<subseteq> (supp x \<inter> as) \<union> (supp x' \<inter> as')" by blast
qed

lemma alpha_abs_res_minimal:
  assumes asm: "(as, x) \<approx>res (op =) supp p (as', x')"
  shows "(as \<inter> supp x, x) \<approx>res (op =) supp p (as' \<inter> supp x', x')"
  using asm unfolding alpha_res by (auto simp: Diff_Int)

lemma alpha_abs_res_abs_set:
  assumes asm: "(as, x) \<approx>res (op =) supp p (as', x')"
  shows "(as \<inter> supp x, x) \<approx>set (op =) supp p (as' \<inter> supp x', x')"
proof -
  have c: "p \<bullet> x = x'"
    using alpha_abs_res_minimal[OF asm] unfolding alpha_res by clarify
  then have a: "supp x - as \<inter> supp x = supp (p \<bullet> x) - as' \<inter> supp (p \<bullet> x)"
    using alpha_abs_res_minimal[OF asm] by (simp add: alpha_res)
  have b: "(supp x - as \<inter> supp x) \<sharp>* p"
    using alpha_abs_res_minimal[OF asm] unfolding alpha_res by clarify
  have "p \<bullet> (as \<inter> supp x) = as' \<inter> supp (p \<bullet> x)"
    by (metis Int_commute asm c supp_property_res)
  then show ?thesis using a b c unfolding alpha_set by simp
qed

lemma alpha_abs_set_abs_res:
  assumes asm: "(as \<inter> supp x, x) \<approx>set (op =) supp p (as' \<inter> supp x', x')"
  shows "(as, x) \<approx>res (op =) supp p (as', x')"
  using asm unfolding alphas by (auto simp: Diff_Int)

lemma alpha_abs_res_stronger1:
  assumes asm: "(as, x) \<approx>res (op =) supp p' (as', x')"
  shows "\<exists>p. (as, x) \<approx>res (op =) supp p (as', x') \<and> supp p \<subseteq> as \<union> as'"
using alpha_abs_res_stronger1_aux[OF asm] by auto

lemma alpha_abs_set_stronger1:
  assumes asm: "(as, x) \<approx>set (op =) supp p' (as', x')"
  shows "\<exists>p. (as, x) \<approx>set (op =) supp p (as', x') \<and> supp p \<subseteq> as \<union> as'"
proof -
  from asm have 0: "(supp x - as) \<sharp>* p'" by  (auto simp only: alphas)
  then have #: "p' \<bullet> (supp x - as) = (supp x - as)"
    by (simp add: atom_set_perm_eq)
  obtain p where *: "\<forall>b \<in> (supp x \<union> as). p \<bullet> b = p' \<bullet> b"
    and **: "supp p \<subseteq> (supp x \<union> as) \<union> p' \<bullet> (supp x \<union> as)"
    using set_renaming_perm2 by blast
  from * have "\<forall>b \<in> supp x. p \<bullet> b = p' \<bullet> b" by blast
  then have a: "p \<bullet> x = p' \<bullet> x" using supp_perm_perm_eq by auto
  from * have "\<forall>b \<in> as. p \<bullet> b = p' \<bullet> b" by blast
  then have zb: "p \<bullet> as = p' \<bullet> as"
    apply(auto simp: permute_set_def)
    apply(rule_tac x="xa" in exI)
    apply(simp)
    done
  have zc: "p' \<bullet> as = as'" using asm by (simp add: alphas)
  from 0 have 1: "(supp x - as) \<sharp>* p" using *
    by (auto simp: fresh_star_def fresh_perm)
  then have 2: "(supp x - as) \<inter> supp p = {}"
    by (auto simp: fresh_star_def fresh_def)
  have b: "supp x = (supp x - as) \<union> (supp x \<inter> as)" by auto
  have "supp p \<subseteq> supp x \<union> as \<union> p' \<bullet> supp x \<union> p' \<bullet> as" using ** using union_eqvt by blast
  also have "\<dots> = (supp x - as) \<union> (supp x \<inter> as) \<union> as \<union> (p' \<bullet> ((supp x - as) \<union> (supp x \<inter> as))) \<union> p' \<bullet> as"
    using b by simp
  also have "\<dots> = (supp x - as) \<union> (supp x \<inter> as) \<union> as \<union>
    ((p' \<bullet> (supp x - as)) \<union> (p' \<bullet> (supp x \<inter> as))) \<union> p' \<bullet> as" by (simp add: union_eqvt)
  also have "\<dots> = (supp x - as) \<union> (supp x \<inter> as) \<union> as \<union> (p' \<bullet> (supp x \<inter> as)) \<union> p' \<bullet> as"
    using # by auto
  also have "\<dots> = (supp x - as) \<union> (supp x \<inter> as) \<union> as \<union> p' \<bullet> ((supp x \<inter> as) \<union> as)" using union_eqvt
    by auto
  also have "\<dots> = (supp x - as) \<union> (supp x \<inter> as) \<union> as \<union> p' \<bullet> as"
    by (metis Int_commute Un_commute sup_inf_absorb)
  also have "\<dots> = (supp x - as) \<union> as \<union> p' \<bullet> as" by blast
  finally have "supp p \<subseteq> (supp x - as) \<union> as \<union> p' \<bullet> as" .
  then have "supp p \<subseteq> as \<union> p' \<bullet> as" using 2 by blast
  moreover
  have "(as, x) \<approx>set (op =) supp p (as', x')" using asm 1 a zb by (simp add: alphas)
  ultimately
  show "\<exists>p. (as, x) \<approx>set (op =) supp p (as', x') \<and> supp p \<subseteq> as \<union> as'" using zc by blast
qed

lemma alpha_abs_lst_stronger1:
  assumes asm: "(as, x) \<approx>lst (op =) supp p' (as', x')"
  shows "\<exists>p. (as, x) \<approx>lst (op =) supp p (as', x') \<and> supp p \<subseteq> set as \<union> set as'"
proof -
  from asm have 0: "(supp x - set as) \<sharp>* p'" by  (auto simp only: alphas)
  then have #: "p' \<bullet> (supp x - set as) = (supp x - set as)"
    by (simp add: atom_set_perm_eq)
  obtain p where *: "\<forall>b \<in> (supp x \<union> set as). p \<bullet> b = p' \<bullet> b"
    and **: "supp p \<subseteq> (supp x \<union> set as) \<union> p' \<bullet> (supp x \<union> set as)"
    using set_renaming_perm2 by blast
  from * have "\<forall>b \<in> supp x. p \<bullet> b = p' \<bullet> b" by blast
  then have a: "p \<bullet> x = p' \<bullet> x" using supp_perm_perm_eq by auto
  from * have "\<forall>b \<in> set as. p \<bullet> b = p' \<bullet> b" by blast
  then have zb: "p \<bullet> as = p' \<bullet> as" by (induct as) (auto)
  have zc: "p' \<bullet> set as = set as'" using asm by (simp add: alphas set_eqvt)
  from 0 have 1: "(supp x - set as) \<sharp>* p" using *
    by (auto simp: fresh_star_def fresh_perm)
  then have 2: "(supp x - set as) \<inter> supp p = {}"
    by (auto simp: fresh_star_def fresh_def)
  have b: "supp x = (supp x - set as) \<union> (supp x \<inter> set as)" by auto
  have "supp p \<subseteq> supp x \<union> set as \<union> p' \<bullet> supp x \<union> p' \<bullet> set as" using ** using union_eqvt by blast
  also have "\<dots> = (supp x - set as) \<union> (supp x \<inter> set as) \<union> set as \<union>
    (p' \<bullet> ((supp x - set as) \<union> (supp x \<inter> set as))) \<union> p' \<bullet> set as" using b by simp
  also have "\<dots> = (supp x - set as) \<union> (supp x \<inter> set as) \<union> set as \<union>
    ((p' \<bullet> (supp x - set as)) \<union> (p' \<bullet> (supp x \<inter> set as))) \<union> p' \<bullet> set as" by (simp add: union_eqvt)
  also have "\<dots> = (supp x - set as) \<union> (supp x \<inter> set as) \<union> set as \<union>
    (p' \<bullet> (supp x \<inter> set as)) \<union> p' \<bullet> set as" using # by auto
  also have "\<dots> = (supp x - set as) \<union> (supp x \<inter> set as) \<union> set as \<union> p' \<bullet> ((supp x \<inter> set as) \<union> set as)"
    using union_eqvt by auto
  also have "\<dots> = (supp x - set as) \<union> (supp x \<inter> set as) \<union> set as \<union> p' \<bullet> set as"
    by (metis Int_commute Un_commute sup_inf_absorb)
  also have "\<dots> = (supp x - set as) \<union> set as \<union> p' \<bullet> set as" by blast
  finally have "supp p \<subseteq> (supp x - set as) \<union> set as \<union> p' \<bullet> set as" .
  then have "supp p \<subseteq> set as \<union> p' \<bullet> set as" using 2 by blast
  moreover
  have "(as, x) \<approx>lst (op =) supp p (as', x')" using asm 1 a zb by (simp add: alphas)
  ultimately
  show "\<exists>p. (as, x) \<approx>lst (op =) supp p (as', x') \<and> supp p \<subseteq> set as \<union> set as'" using zc by blast
qed

lemma alphas_abs_stronger:
  shows "(as, x) \<approx>abs_set (as', x') \<longleftrightarrow> (\<exists>p. (as, x) \<approx>set (op =) supp p (as', x') \<and> supp p \<subseteq> as \<union> as')"
  and   "(as, x) \<approx>abs_res (as', x') \<longleftrightarrow> (\<exists>p. (as, x) \<approx>res (op =) supp p (as', x') \<and> supp p \<subseteq> as \<union> as')"
  and   "(bs, x) \<approx>abs_lst (bs', x') \<longleftrightarrow>
   (\<exists>p. (bs, x) \<approx>lst (op =) supp p (bs', x') \<and> supp p \<subseteq> set bs \<union> set bs')"
apply(rule iffI)
apply(auto simp: alphas_abs alpha_abs_set_stronger1)[1]
apply(auto simp: alphas_abs)[1]
apply(rule iffI)
apply(auto simp: alphas_abs alpha_abs_res_stronger1)[1]
apply(auto simp: alphas_abs)[1]
apply(rule iffI)
apply(auto simp: alphas_abs alpha_abs_lst_stronger1)[1]
apply(auto simp: alphas_abs)[1]
done

lemma alpha_res_alpha_set:
  "(bs, x) \<approx>res op = supp p (cs, y) \<longleftrightarrow> (bs \<inter> supp x, x) \<approx>set op = supp p (cs \<inter> supp y, y)"
  using alpha_abs_set_abs_res alpha_abs_res_abs_set by blast

section {* Quotient types *}

quotient_type
    'a abs_set = "(atom set \<times> 'a::pt)" / "alpha_abs_set"
  apply(rule equivpI)
  unfolding reflp_def refl_on_def symp_def sym_def transp_def trans_def
  by (auto intro: alphas_abs_sym alphas_abs_refl alphas_abs_trans simp only:)

quotient_type
    'b abs_res = "(atom set \<times> 'b::pt)" / "alpha_abs_res"
  apply(rule equivpI)
  unfolding reflp_def refl_on_def symp_def sym_def transp_def trans_def
  by (auto intro: alphas_abs_sym alphas_abs_refl alphas_abs_trans simp only:)

quotient_type
   'c abs_lst = "(atom list \<times> 'c::pt)" / "alpha_abs_lst"
  apply(rule_tac [!] equivpI)
  unfolding reflp_def refl_on_def symp_def sym_def transp_def trans_def
  by (auto intro: alphas_abs_sym alphas_abs_refl alphas_abs_trans simp only:)

quotient_definition
  Abs_set ("[_]set. _" [60, 60] 60)
where
  "Abs_set::atom set \<Rightarrow> ('a::pt) \<Rightarrow> 'a abs_set"
is
  "Pair::atom set \<Rightarrow> ('a::pt) \<Rightarrow> (atom set \<times> 'a)" .

quotient_definition
  Abs_res ("[_]res. _" [60, 60] 60)
where
  "Abs_res::atom set \<Rightarrow> ('a::pt) \<Rightarrow> 'a abs_res"
is
  "Pair::atom set \<Rightarrow> ('a::pt) \<Rightarrow> (atom set \<times> 'a)" .

quotient_definition
  Abs_lst ("[_]lst. _" [60, 60] 60)
where
  "Abs_lst::atom list \<Rightarrow> ('a::pt) \<Rightarrow> 'a abs_lst"
is
  "Pair::atom list \<Rightarrow> ('a::pt) \<Rightarrow> (atom list \<times> 'a)" .

lemma [quot_respect]:
  shows "(op= ===> op= ===> alpha_abs_set) Pair Pair"
  and   "(op= ===> op= ===> alpha_abs_res) Pair Pair"
  and   "(op= ===> op= ===> alpha_abs_lst) Pair Pair"
  unfolding rel_fun_def
  by (auto intro: alphas_abs_refl)

lemma [quot_respect]:
  shows "(op= ===> alpha_abs_set ===> alpha_abs_set) permute permute"
  and   "(op= ===> alpha_abs_res ===> alpha_abs_res) permute permute"
  and   "(op= ===> alpha_abs_lst ===> alpha_abs_lst) permute permute"
  unfolding rel_fun_def
  by (auto intro: alphas_abs_eqvt simp only: Pair_eqvt)

lemma Abs_eq_iff:
  shows "[bs]set. x = [bs']set. y \<longleftrightarrow> (\<exists>p. (bs, x) \<approx>set (op =) supp p (bs', y))"
  and   "[bs]res. x = [bs']res. y \<longleftrightarrow> (\<exists>p. (bs, x) \<approx>res (op =) supp p (bs', y))"
  and   "[cs]lst. x = [cs']lst. y \<longleftrightarrow> (\<exists>p. (cs, x) \<approx>lst (op =) supp p (cs', y))"
  by (lifting alphas_abs)

lemma Abs_eq_iff2:
  shows "[bs]set. x = [bs']set. y \<longleftrightarrow> (\<exists>p. (bs, x) \<approx>set (op=) supp p (bs', y) \<and> supp p \<subseteq> bs \<union> bs')"
  and   "[bs]res. x = [bs']res. y \<longleftrightarrow> (\<exists>p. (bs, x) \<approx>res (op=) supp p (bs', y) \<and> supp p \<subseteq> bs \<union> bs')"
  and   "[cs]lst. x = [cs']lst. y \<longleftrightarrow> (\<exists>p. (cs, x) \<approx>lst (op=) supp p (cs', y) \<and> supp p \<subseteq> set cs \<union> set cs')"
  by (lifting alphas_abs_stronger)

lemma Abs_eq_res_set:
  shows "[bs]res. x = [cs]res. y \<longleftrightarrow> [bs \<inter> supp x]set. x = [cs \<inter> supp y]set. y"
  unfolding Abs_eq_iff alpha_res_alpha_set by rule

lemma Abs_eq_res_supp:
  assumes asm: "supp x \<subseteq> bs"
  shows "[as]res. x = [as \<inter> bs]res. x"
  unfolding Abs_eq_iff alphas
  apply (rule_tac x="0::perm" in exI)
  apply (simp add: fresh_star_zero)
  using asm by blast

lemma Abs_exhausts[cases type]:
  shows "(\<And>as (x::'a::pt). y1 = [as]set. x \<Longrightarrow> P1) \<Longrightarrow> P1"
  and   "(\<And>as (x::'a::pt). y2 = [as]res. x \<Longrightarrow> P2) \<Longrightarrow> P2"
  and   "(\<And>bs (x::'a::pt). y3 = [bs]lst. x \<Longrightarrow> P3) \<Longrightarrow> P3"
  by (lifting prod.exhaust[where 'a="atom set" and 'b="'a"]
              prod.exhaust[where 'a="atom set" and 'b="'a"]
              prod.exhaust[where 'a="atom list" and 'b="'a"])

instantiation abs_set :: (pt) pt
begin

quotient_definition
  "permute_abs_set::perm \<Rightarrow> ('a::pt abs_set) \<Rightarrow> 'a abs_set"
is
  "permute:: perm \<Rightarrow> (atom set \<times> 'a::pt) \<Rightarrow> (atom set \<times> 'a::pt)"
  by (auto intro: alphas_abs_eqvt simp only: Pair_eqvt)

lemma permute_Abs_set[simp]:
  fixes x::"'a::pt"
  shows "(p \<bullet> ([as]set. x)) = [p \<bullet> as]set. (p \<bullet> x)"
  by (lifting permute_prod.simps[where 'a="atom set" and 'b="'a"])

instance
  apply(default)
  apply(case_tac [!] x)
  apply(simp_all)
  done

end

instantiation abs_res :: (pt) pt
begin

quotient_definition
  "permute_abs_res::perm \<Rightarrow> ('a::pt abs_res) \<Rightarrow> 'a abs_res"
is
  "permute:: perm \<Rightarrow> (atom set \<times> 'a::pt) \<Rightarrow> (atom set \<times> 'a::pt)"
  by (auto intro: alphas_abs_eqvt simp only: Pair_eqvt)

lemma permute_Abs_res[simp]:
  fixes x::"'a::pt"
  shows "(p \<bullet> ([as]res. x)) = [p \<bullet> as]res. (p \<bullet> x)"
  by (lifting permute_prod.simps[where 'a="atom set" and 'b="'a"])

instance
  apply(default)
  apply(case_tac [!] x)
  apply(simp_all)
  done

end

instantiation abs_lst :: (pt) pt
begin

quotient_definition
  "permute_abs_lst::perm \<Rightarrow> ('a::pt abs_lst) \<Rightarrow> 'a abs_lst"
is
  "permute:: perm \<Rightarrow> (atom list \<times> 'a::pt) \<Rightarrow> (atom list \<times> 'a::pt)"
  by (auto intro: alphas_abs_eqvt simp only: Pair_eqvt)

lemma permute_Abs_lst[simp]:
  fixes x::"'a::pt"
  shows "(p \<bullet> ([as]lst. x)) = [p \<bullet> as]lst. (p \<bullet> x)"
  by (lifting permute_prod.simps[where 'a="atom list" and 'b="'a"])

instance
  apply(default)
  apply(case_tac [!] x)
  apply(simp_all)
  done

end

lemmas permute_Abs[eqvt] = permute_Abs_set permute_Abs_res permute_Abs_lst

lemma Abs_swap1:
  assumes a1: "a \<notin> (supp x) - bs"
  and     a2: "b \<notin> (supp x) - bs"
  shows "[bs]set. x = [(a \<rightleftharpoons> b) \<bullet> bs]set. ((a \<rightleftharpoons> b) \<bullet> x)"
  and   "[bs]res. x = [(a \<rightleftharpoons> b) \<bullet> bs]res. ((a \<rightleftharpoons> b) \<bullet> x)"
  unfolding Abs_eq_iff
  unfolding alphas
  unfolding supp_eqvt[symmetric] Diff_eqvt[symmetric]
  unfolding fresh_star_def fresh_def
  unfolding swap_set_not_in[OF a1 a2]
  using a1 a2
  by (rule_tac [!] x="(a \<rightleftharpoons> b)" in exI)
     (auto simp: supp_perm swap_atom)

lemma Abs_swap2:
  assumes a1: "a \<notin> (supp x) - (set bs)"
  and     a2: "b \<notin> (supp x) - (set bs)"
  shows "[bs]lst. x = [(a \<rightleftharpoons> b) \<bullet> bs]lst. ((a \<rightleftharpoons> b) \<bullet> x)"
  unfolding Abs_eq_iff
  unfolding alphas
  unfolding supp_eqvt[symmetric] Diff_eqvt[symmetric] set_eqvt[symmetric]
  unfolding fresh_star_def fresh_def
  unfolding swap_set_not_in[OF a1 a2]
  using a1 a2
  by (rule_tac [!] x="(a \<rightleftharpoons> b)" in exI)
     (auto simp: supp_perm swap_atom)

lemma Abs_supports:
  shows "((supp x) - as) supports ([as]set. x)"
  and   "((supp x) - as) supports ([as]res. x)"
  and   "((supp x) - set bs) supports ([bs]lst. x)"
  unfolding supports_def
  unfolding permute_Abs
  by (simp_all add: Abs_swap1[symmetric] Abs_swap2[symmetric])

function
  supp_set  :: "('a::pt) abs_set \<Rightarrow> atom set" and
  supp_res :: "('a::pt) abs_res \<Rightarrow> atom set" and
  supp_lst :: "('a::pt) abs_lst \<Rightarrow> atom set"
where
  "supp_set ([as]set. x) = supp x - as"
| "supp_res ([as]res. x) = supp x - as"
| "supp_lst (Abs_lst cs x) = (supp x) - (set cs)"
apply(simp_all add: Abs_eq_iff alphas_abs alphas)
apply(case_tac x)
apply(case_tac a)
apply(simp)
apply(case_tac b)
apply(case_tac a)
apply(simp)
apply(case_tac ba)
apply(simp)
done

termination
  by lexicographic_order

lemma supp_funs_eqvt[eqvt]:
  shows "(p \<bullet> supp_set x) = supp_set (p \<bullet> x)"
  and   "(p \<bullet> supp_res y) = supp_res (p \<bullet> y)"
  and   "(p \<bullet> supp_lst z) = supp_lst (p \<bullet> z)"
  apply(case_tac x)
  apply(simp)
  apply(case_tac y)
  apply(simp)
  apply(case_tac z)
  apply(simp)
  done

lemma Abs_fresh_aux:
  shows "a \<sharp> [bs]set. x \<Longrightarrow> a \<sharp> supp_set ([bs]set. x)"
  and   "a \<sharp> [bs]res. x \<Longrightarrow> a \<sharp> supp_res ([bs]res. x)"
  and   "a \<sharp> [cs]lst. x \<Longrightarrow> a \<sharp> supp_lst ([cs]lst. x)"
  by (rule_tac [!] fresh_fun_eqvt_app)
     (auto simp only: eqvt_def eqvts_raw)

lemma Abs_supp_subset1:
  assumes a: "finite (supp x)"
  shows "(supp x) - as \<subseteq> supp ([as]set. x)"
  and   "(supp x) - as \<subseteq> supp ([as]res. x)"
  and   "(supp x) - (set bs) \<subseteq> supp ([bs]lst. x)"
  unfolding supp_conv_fresh
  by (auto dest!: Abs_fresh_aux)
     (simp_all add: fresh_def supp_finite_atom_set a)

lemma Abs_supp_subset2:
  assumes a: "finite (supp x)"
  shows "supp ([as]set. x) \<subseteq> (supp x) - as"
  and   "supp ([as]res. x) \<subseteq> (supp x) - as"
  and   "supp ([bs]lst. x) \<subseteq> (supp x) - (set bs)"
  by (rule_tac [!] supp_is_subset)
     (simp_all add: Abs_supports a)

lemma Abs_finite_supp:
  assumes a: "finite (supp x)"
  shows "supp ([as]set. x) = (supp x) - as"
  and   "supp ([as]res. x) = (supp x) - as"
  and   "supp ([bs]lst. x) = (supp x) - (set bs)"
using Abs_supp_subset1[OF a] Abs_supp_subset2[OF a]
  by blast+

lemma supp_Abs:
  fixes x::"'a::fs"
  shows "supp ([as]set. x) = (supp x) - as"
  and   "supp ([as]res. x) = (supp x) - as"
  and   "supp ([bs]lst. x) = (supp x) - (set bs)"
by (simp_all add: Abs_finite_supp finite_supp)

instance abs_set :: (fs) fs
  apply(default)
  apply(case_tac x)
  apply(simp add: supp_Abs finite_supp)
  done

instance abs_res :: (fs) fs
  apply(default)
  apply(case_tac x)
  apply(simp add: supp_Abs finite_supp)
  done

instance abs_lst :: (fs) fs
  apply(default)
  apply(case_tac x)
  apply(simp add: supp_Abs finite_supp)
  done

lemma Abs_fresh_iff:
  fixes x::"'a::fs"
  shows "a \<sharp> [bs]set. x \<longleftrightarrow> a \<in> bs \<or> (a \<notin> bs \<and> a \<sharp> x)"
  and   "a \<sharp> [bs]res. x \<longleftrightarrow> a \<in> bs \<or> (a \<notin> bs \<and> a \<sharp> x)"
  and   "a \<sharp> [cs]lst. x \<longleftrightarrow> a \<in> (set cs) \<or> (a \<notin> (set cs) \<and> a \<sharp> x)"
  unfolding fresh_def
  unfolding supp_Abs
  by auto

lemma Abs_fresh_star_iff:
  fixes x::"'a::fs"
  shows "as \<sharp>* ([bs]set. x) \<longleftrightarrow> (as - bs) \<sharp>* x"
  and   "as \<sharp>* ([bs]res. x) \<longleftrightarrow> (as - bs) \<sharp>* x"
  and   "as \<sharp>* ([cs]lst. x) \<longleftrightarrow> (as - set cs) \<sharp>* x"
  unfolding fresh_star_def
  by (auto simp: Abs_fresh_iff)

lemma Abs_fresh_star:
  fixes x::"'a::fs"
  shows "as \<subseteq> as' \<Longrightarrow> as \<sharp>* ([as']set. x)"
  and   "as \<subseteq> as' \<Longrightarrow> as \<sharp>* ([as']res. x)"
  and   "bs \<subseteq> set bs' \<Longrightarrow> bs \<sharp>* ([bs']lst. x)"
  unfolding fresh_star_def
  by(auto simp: Abs_fresh_iff)

lemma Abs_fresh_star2:
  fixes x::"'a::fs"
  shows "as \<inter> bs = {} \<Longrightarrow> as \<sharp>* ([bs]set. x) \<longleftrightarrow> as \<sharp>* x"
  and   "as \<inter> bs = {} \<Longrightarrow> as \<sharp>* ([bs]res. x) \<longleftrightarrow> as \<sharp>* x"
  and   "cs \<inter> set ds = {} \<Longrightarrow> cs \<sharp>* ([ds]lst. x) \<longleftrightarrow> cs \<sharp>* x"
  unfolding fresh_star_def Abs_fresh_iff
  by auto

section {* Abstractions of single atoms *}

lemma Abs1_eq:
  fixes x y::"'a::fs"
  shows "[{atom a}]set. x = [{atom a}]set. y \<longleftrightarrow> x = y"
  and   "[{atom a}]res. x = [{atom a}]res. y \<longleftrightarrow> x = y"
  and   "[[atom a]]lst. x = [[atom a]]lst. y \<longleftrightarrow> x = y"
unfolding Abs_eq_iff2 alphas
by (auto simp: supp_perm_singleton fresh_star_def fresh_zero_perm)

lemma Abs1_eq_iff_fresh:
  fixes x y::"'a::fs"
  and a b c::"'b::at"
  assumes "atom c \<sharp> (a, b, x, y)"
  shows "[{atom a}]set. x = [{atom b}]set. y \<longleftrightarrow> (a \<leftrightarrow> c) \<bullet> x = (b \<leftrightarrow> c) \<bullet> y"
  and   "[{atom a}]res. x = [{atom b}]res. y \<longleftrightarrow> (a \<leftrightarrow> c) \<bullet> x = (b \<leftrightarrow> c) \<bullet> y"
  and   "[[atom a]]lst. x = [[atom b]]lst. y \<longleftrightarrow> (a \<leftrightarrow> c) \<bullet> x = (b \<leftrightarrow> c) \<bullet> y"
proof -
  have "[{atom a}]set. x = (a \<leftrightarrow> c) \<bullet> ([{atom a}]set. x)"
    by (rule_tac flip_fresh_fresh[symmetric]) (simp_all add: Abs_fresh_iff assms)
  then have "[{atom a}]set. x = [{atom c}]set. ((a \<leftrightarrow> c) \<bullet> x)" by simp
  moreover
  have "[{atom b}]set. y = (b \<leftrightarrow> c) \<bullet> ([{atom b}]set. y)"
    by (rule_tac flip_fresh_fresh[symmetric]) (simp_all add: Abs_fresh_iff assms)
  then have "[{atom b}]set. y = [{atom c}]set. ((b \<leftrightarrow> c) \<bullet> y)" by simp
  ultimately
  show "[{atom a}]set. x = [{atom b}]set. y \<longleftrightarrow> (a \<leftrightarrow> c) \<bullet> x = (b \<leftrightarrow> c) \<bullet> y"
    by (simp add: Abs1_eq)
next
  have "[{atom a}]res. x = (a \<leftrightarrow> c) \<bullet> ([{atom a}]res. x)"
    by (rule_tac flip_fresh_fresh[symmetric]) (simp_all add: Abs_fresh_iff assms)
  then have "[{atom a}]res. x = [{atom c}]res. ((a \<leftrightarrow> c) \<bullet> x)" by simp
  moreover
  have "[{atom b}]res. y = (b \<leftrightarrow> c) \<bullet> ([{atom b}]res. y)"
    by (rule_tac flip_fresh_fresh[symmetric]) (simp_all add: Abs_fresh_iff assms)
  then have "[{atom b}]res. y = [{atom c}]res. ((b \<leftrightarrow> c) \<bullet> y)" by simp
  ultimately
  show "[{atom a}]res. x = [{atom b}]res. y \<longleftrightarrow> (a \<leftrightarrow> c) \<bullet> x = (b \<leftrightarrow> c) \<bullet> y"
    by (simp add: Abs1_eq)
next
  have "[[atom a]]lst. x = (a \<leftrightarrow> c) \<bullet> ([[atom a]]lst. x)"
    by (rule_tac flip_fresh_fresh[symmetric]) (simp_all add: Abs_fresh_iff assms)
  then have "[[atom a]]lst. x = [[atom c]]lst. ((a \<leftrightarrow> c) \<bullet> x)" by simp
  moreover
  have "[[atom b]]lst. y = (b \<leftrightarrow> c) \<bullet> ([[atom b]]lst. y)"
    by (rule_tac flip_fresh_fresh[symmetric]) (simp_all add: Abs_fresh_iff assms)
  then have "[[atom b]]lst. y = [[atom c]]lst. ((b \<leftrightarrow> c) \<bullet> y)" by simp
  ultimately
  show "[[atom a]]lst. x = [[atom b]]lst. y \<longleftrightarrow> (a \<leftrightarrow> c) \<bullet> x = (b \<leftrightarrow> c) \<bullet> y"
    by (simp add: Abs1_eq)
qed

lemma Abs1_eq_iff_all:
  fixes x y::"'a::fs"
  and z::"'c::fs"
  and a b::"'b::at"
  shows "[{atom a}]set. x = [{atom b}]set. y \<longleftrightarrow> (\<forall>c. atom c \<sharp> z \<longrightarrow> atom c \<sharp> (a, b, x, y) \<longrightarrow> (a \<leftrightarrow> c) \<bullet> x = (b \<leftrightarrow> c) \<bullet> y)"
  and   "[{atom a}]res. x = [{atom b}]res. y \<longleftrightarrow> (\<forall>c. atom c \<sharp> z \<longrightarrow> atom c \<sharp> (a, b, x, y) \<longrightarrow> (a \<leftrightarrow> c) \<bullet> x = (b \<leftrightarrow> c) \<bullet> y)"
  and   "[[atom a]]lst. x = [[atom b]]lst. y \<longleftrightarrow> (\<forall>c. atom c \<sharp> z \<longrightarrow> atom c \<sharp> (a, b, x, y) \<longrightarrow> (a \<leftrightarrow> c) \<bullet> x = (b \<leftrightarrow> c) \<bullet> y)"
apply(auto)
apply(simp add: Abs1_eq_iff_fresh(1)[symmetric])
apply(rule_tac ?'a="'b::at" and x="(a, b, x, y, z)" in obtain_fresh)
apply(drule_tac x="aa" in spec)
apply(simp)
apply(subst Abs1_eq_iff_fresh(1))
apply(auto simp: fresh_Pair)[2]
apply(simp add: Abs1_eq_iff_fresh(2)[symmetric])
apply(rule_tac ?'a="'b::at" and x="(a, b, x, y, z)" in obtain_fresh)
apply(drule_tac x="aa" in spec)
apply(simp)
apply(subst Abs1_eq_iff_fresh(2))
apply(auto simp: fresh_Pair)[2]
apply(simp add: Abs1_eq_iff_fresh(3)[symmetric])
apply(rule_tac ?'a="'b::at" and x="(a, b, x, y, z)" in obtain_fresh)
apply(drule_tac x="aa" in spec)
apply(simp)
apply(subst Abs1_eq_iff_fresh(3))
apply(auto simp: fresh_Pair)[2]
done

lemma Abs1_eq_iff:
  fixes x y::"'a::fs"
  and a b::"'b::at"
  shows "[{atom a}]set. x = [{atom b}]set. y \<longleftrightarrow> (a = b \<and> x = y) \<or> (a \<noteq> b \<and> x = (a \<leftrightarrow> b) \<bullet> y \<and> atom a \<sharp> y)"
  and   "[{atom a}]res. x = [{atom b}]res. y \<longleftrightarrow> (a = b \<and> x = y) \<or> (a \<noteq> b \<and> x = (a \<leftrightarrow> b) \<bullet> y \<and> atom a \<sharp> y)"
  and   "[[atom a]]lst. x = [[atom b]]lst. y \<longleftrightarrow> (a = b \<and> x = y) \<or> (a \<noteq> b \<and> x = (a \<leftrightarrow> b) \<bullet> y \<and> atom a \<sharp> y)"
proof -
  { assume "a = b"
    then have "[{atom a}]set. x = [{atom b}]set. y \<longleftrightarrow> (a = b \<and> x = y)" by (simp add: Abs1_eq)
  }
  moreover
  { assume *: "a \<noteq> b" and **: "[{atom a}]set. x = [{atom b}]set. y"
    have #: "atom a \<sharp> [{atom b}]set. y" by (simp add: **[symmetric] Abs_fresh_iff)
    have "[{atom a}]set. ((a \<leftrightarrow> b) \<bullet> y) = (a \<leftrightarrow> b) \<bullet> ([{atom b}]set. y)" by (simp)
    also have "\<dots> = [{atom b}]set. y"
      by (rule flip_fresh_fresh) (simp add: #, simp add: Abs_fresh_iff)
    also have "\<dots> = [{atom a}]set. x" using ** by simp
    finally have "a \<noteq> b \<and> x = (a \<leftrightarrow> b) \<bullet> y \<and> atom a \<sharp> y" using # * by (simp add: Abs1_eq Abs_fresh_iff)
  }
  moreover
  { assume *: "a \<noteq> b" and **: "x = (a \<leftrightarrow> b) \<bullet> y \<and> atom a \<sharp> y"
    have "[{atom a}]set. x = [{atom a}]set. ((a \<leftrightarrow> b) \<bullet> y)" using ** by simp
    also have "\<dots> = (a \<leftrightarrow> b) \<bullet> ([{atom b}]set. y)" by (simp add: permute_set_def assms)
    also have "\<dots> = [{atom b}]set. y"
      by (rule flip_fresh_fresh) (simp add: Abs_fresh_iff **, simp add: Abs_fresh_iff)
    finally have "[{atom a}]set. x = [{atom b}]set. y" .
  }
  ultimately
  show "[{atom a}]set. x = [{atom b}]set. y \<longleftrightarrow> (a = b \<and> x = y) \<or> (a \<noteq> b \<and> x = (a \<leftrightarrow> b) \<bullet> y \<and> atom a \<sharp> y)"
    by blast
next
  { assume "a = b"
    then have "Abs_res {atom a} x = Abs_res {atom b} y \<longleftrightarrow> (a = b \<and> x = y)" by (simp add: Abs1_eq)
  }
  moreover
  { assume *: "a \<noteq> b" and **: "Abs_res {atom a} x = Abs_res {atom b} y"
    have #: "atom a \<sharp> Abs_res {atom b} y" by (simp add: **[symmetric] Abs_fresh_iff)
    have "Abs_res {atom a} ((a \<leftrightarrow> b) \<bullet> y) = (a \<leftrightarrow> b) \<bullet> (Abs_res {atom b} y)" by (simp add: assms)
    also have "\<dots> = Abs_res {atom b} y"
      by (rule flip_fresh_fresh) (simp add: #, simp add: Abs_fresh_iff)
    also have "\<dots> = Abs_res {atom a} x" using ** by simp
    finally have "a \<noteq> b \<and> x = (a \<leftrightarrow> b) \<bullet> y \<and> atom a \<sharp> y" using # * by (simp add: Abs1_eq Abs_fresh_iff)
  }
  moreover
  { assume *: "a \<noteq> b" and **: "x = (a \<leftrightarrow> b) \<bullet> y \<and> atom a \<sharp> y"
    have "Abs_res {atom a} x = Abs_res {atom a} ((a \<leftrightarrow> b) \<bullet> y)" using ** by simp
    also have "\<dots> = (a \<leftrightarrow> b) \<bullet> Abs_res {atom b} y" by (simp add: permute_set_def assms)
    also have "\<dots> = Abs_res {atom b} y"
      by (rule flip_fresh_fresh) (simp add: Abs_fresh_iff **, simp add: Abs_fresh_iff)
    finally have "Abs_res {atom a} x = Abs_res {atom b} y" .
  }
  ultimately
  show "Abs_res {atom a} x = Abs_res {atom b} y \<longleftrightarrow> (a = b \<and> x = y) \<or> (a \<noteq> b \<and> x = (a \<leftrightarrow> b) \<bullet> y \<and> atom a \<sharp> y)"
    by blast
next
  { assume "a = b"
    then have "Abs_lst [atom a] x = Abs_lst [atom b] y \<longleftrightarrow> (a = b \<and> x = y)" by (simp add: Abs1_eq)
  }
  moreover
  { assume *: "a \<noteq> b" and **: "Abs_lst [atom a] x = Abs_lst [atom b] y"
    have #: "atom a \<sharp> Abs_lst [atom b] y" by (simp add: **[symmetric] Abs_fresh_iff)
    have "Abs_lst [atom a] ((a \<leftrightarrow> b) \<bullet> y) = (a \<leftrightarrow> b) \<bullet> (Abs_lst [atom b] y)" by (simp add: assms)
    also have "\<dots> = Abs_lst [atom b] y"
      by (rule flip_fresh_fresh) (simp add: #, simp add: Abs_fresh_iff)
    also have "\<dots> = Abs_lst [atom a] x" using ** by simp
    finally have "a \<noteq> b \<and> x = (a \<leftrightarrow> b) \<bullet> y \<and> atom a \<sharp> y" using # * by (simp add: Abs1_eq Abs_fresh_iff)
  }
  moreover
  { assume *: "a \<noteq> b" and **: "x = (a \<leftrightarrow> b) \<bullet> y \<and> atom a \<sharp> y"
    have "Abs_lst [atom a] x = Abs_lst [atom a] ((a \<leftrightarrow> b) \<bullet> y)" using ** by simp
    also have "\<dots> = (a \<leftrightarrow> b) \<bullet> Abs_lst [atom b] y" by (simp add: assms)
    also have "\<dots> = Abs_lst [atom b] y"
      by (rule flip_fresh_fresh) (simp add: Abs_fresh_iff **, simp add: Abs_fresh_iff)
    finally have "Abs_lst [atom a] x = Abs_lst [atom b] y" .
  }
  ultimately
  show "Abs_lst [atom a] x = Abs_lst [atom b] y \<longleftrightarrow> (a = b \<and> x = y) \<or> (a \<noteq> b \<and> x = (a \<leftrightarrow> b) \<bullet> y \<and> atom a \<sharp> y)"
    by blast
qed

lemma Abs1_eq_iff':
  fixes x::"'a::fs"
  and a b::"'b::at"
  shows "[{atom a}]set. x = [{atom b}]set. y \<longleftrightarrow> (a = b \<and> x = y) \<or> (a \<noteq> b \<and> (b \<leftrightarrow> a) \<bullet> x = y \<and> atom b \<sharp> x)"
  and   "[{atom a}]res. x = [{atom b}]res. y \<longleftrightarrow> (a = b \<and> x = y) \<or> (a \<noteq> b \<and> (b \<leftrightarrow> a) \<bullet> x = y \<and> atom b \<sharp> x)"
  and   "[[atom a]]lst. x = [[atom b]]lst. y \<longleftrightarrow> (a = b \<and> x = y) \<or> (a \<noteq> b \<and> (b \<leftrightarrow> a) \<bullet> x = y \<and> atom b \<sharp> x)"
using assms by (auto simp: Abs1_eq_iff fresh_permute_left)

ML {*
fun alpha_single_simproc thm _ ctxt ctrm =
 let
    val thy = Proof_Context.theory_of ctxt
    val _ $ (_ $ x) $ (_ $ y) = term_of ctrm
    val cvrs = union (op =) (Term.add_frees x []) (Term.add_frees y [])
      |> filter (fn (_, ty) => Sign.of_sort thy (ty, @{sort fs}))
      |> map Free
      |> HOLogic.mk_tuple
      |> Thm.cterm_of thy
    val cvrs_ty = ctyp_of_term cvrs
    val thm' = thm
      |> Drule.instantiate' [NONE, NONE, SOME cvrs_ty] [NONE, NONE, NONE, NONE, SOME cvrs]
  in
    SOME thm'
  end
*}

simproc_setup alpha_set ("[{atom a}]set. x = [{atom b}]set. y") =
  {* alpha_single_simproc @{thm Abs1_eq_iff_all(1)[THEN eq_reflection]} *}

simproc_setup alpha_res ("[{atom a}]res. x = [{atom b}]res. y") =
  {* alpha_single_simproc @{thm Abs1_eq_iff_all(2)[THEN eq_reflection]} *}

simproc_setup alpha_lst ("[[atom a]]lst. x = [[atom b]]lst. y") =
  {* alpha_single_simproc @{thm Abs1_eq_iff_all(3)[THEN eq_reflection]} *}

subsection {* Renaming of bodies of abstractions *}

lemma Abs_rename_set:
  fixes x::"'a::fs"
  assumes a: "(p \<bullet> bs) \<sharp>* x"
  (*and     b: "finite bs"*)
  shows "\<exists>q. [bs]set. x = [p \<bullet> bs]set. (q \<bullet> x) \<and> q \<bullet> bs = p \<bullet> bs"
proof -
  from set_renaming_perm2
  obtain q where *: "\<forall>b \<in> bs. q \<bullet> b = p \<bullet> b" and **: "supp q \<subseteq> bs \<union> (p \<bullet> bs)" by blast
  have ***: "q \<bullet> bs = p \<bullet> bs" using *
    unfolding permute_set_eq_image image_def by auto
  have "[bs]set. x =  q \<bullet> ([bs]set. x)"
    apply(rule perm_supp_eq[symmetric])
    using a **
    unfolding Abs_fresh_star_iff
    unfolding fresh_star_def
    by auto
  also have "\<dots> = [q \<bullet> bs]set. (q \<bullet> x)" by simp
  finally have "[bs]set. x = [p \<bullet> bs]set. (q \<bullet> x)" by (simp add: ***)
  then show "\<exists>q. [bs]set. x = [p \<bullet> bs]set. (q \<bullet> x) \<and> q \<bullet> bs = p \<bullet> bs" using *** by metis
qed

lemma Abs_rename_res:
  fixes x::"'a::fs"
  assumes a: "(p \<bullet> bs) \<sharp>* x"
  (*and     b: "finite bs"*)
  shows "\<exists>q. [bs]res. x = [p \<bullet> bs]res. (q \<bullet> x) \<and> q \<bullet> bs = p \<bullet> bs"
proof -
  from set_renaming_perm2
  obtain q where *: "\<forall>b \<in> bs. q \<bullet> b = p \<bullet> b" and **: "supp q \<subseteq> bs \<union> (p \<bullet> bs)" by blast
  have ***: "q \<bullet> bs = p \<bullet> bs" using *
    unfolding permute_set_eq_image image_def by auto
  have "[bs]res. x =  q \<bullet> ([bs]res. x)"
    apply(rule perm_supp_eq[symmetric])
    using a **
    unfolding Abs_fresh_star_iff
    unfolding fresh_star_def
    by auto
  also have "\<dots> = [q \<bullet> bs]res. (q \<bullet> x)" by simp
  finally have "[bs]res. x = [p \<bullet> bs]res. (q \<bullet> x)" by (simp add: ***)
  then show "\<exists>q. [bs]res. x = [p \<bullet> bs]res. (q \<bullet> x) \<and> q \<bullet> bs = p \<bullet> bs" using *** by metis
qed

lemma Abs_rename_lst:
  fixes x::"'a::fs"
  assumes a: "(p \<bullet> (set bs)) \<sharp>* x"
  shows "\<exists>q. [bs]lst. x = [p \<bullet> bs]lst. (q \<bullet> x) \<and> q \<bullet> bs = p \<bullet> bs"
proof -
  from list_renaming_perm
  obtain q where *: "\<forall>b \<in> set bs. q \<bullet> b = p \<bullet> b" and **: "supp q \<subseteq> set bs \<union> (p \<bullet> set bs)" by blast
  have ***: "q \<bullet> bs = p \<bullet> bs" using * by (induct bs) (simp_all add: insert_eqvt)
  have "[bs]lst. x =  q \<bullet> ([bs]lst. x)"
    apply(rule perm_supp_eq[symmetric])
    using a **
    unfolding Abs_fresh_star_iff
    unfolding fresh_star_def
    by auto
  also have "\<dots> = [q \<bullet> bs]lst. (q \<bullet> x)" by simp
  finally have "[bs]lst. x = [p \<bullet> bs]lst. (q \<bullet> x)" by (simp add: ***)
  then show "\<exists>q. [bs]lst. x = [p \<bullet> bs]lst. (q \<bullet> x) \<and> q \<bullet> bs = p \<bullet> bs" using *** by metis
qed

text {* for deep recursive binders *}

lemma Abs_rename_set':
  fixes x::"'a::fs"
  assumes a: "(p \<bullet> bs) \<sharp>* x"
  (*and     b: "finite bs"*)
  shows "\<exists>q. [bs]set. x = [q \<bullet> bs]set. (q \<bullet> x) \<and> q \<bullet> bs = p \<bullet> bs"
using Abs_rename_set[OF a] by metis

lemma Abs_rename_res':
  fixes x::"'a::fs"
  assumes a: "(p \<bullet> bs) \<sharp>* x"
  (*and     b: "finite bs"*)
  shows "\<exists>q. [bs]res. x = [q \<bullet> bs]res. (q \<bullet> x) \<and> q \<bullet> bs = p \<bullet> bs"
using Abs_rename_res[OF a] by metis

lemma Abs_rename_lst':
  fixes x::"'a::fs"
  assumes a: "(p \<bullet> (set bs)) \<sharp>* x"
  shows "\<exists>q. [bs]lst. x = [q \<bullet> bs]lst. (q \<bullet> x) \<and> q \<bullet> bs = p \<bullet> bs"
using Abs_rename_lst[OF a] by metis

section {* Infrastructure for building tuples of relations and functions *}

fun
  prod_fv :: "('a \<Rightarrow> atom set) \<Rightarrow> ('b \<Rightarrow> atom set) \<Rightarrow> ('a \<times> 'b) \<Rightarrow> atom set"
where
  "prod_fv fv1 fv2 (x, y) = fv1 x \<union> fv2 y"

definition
  prod_alpha :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<times> 'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> bool)"
where
 "prod_alpha = rel_prod"

lemma [quot_respect]:
  shows "((R1 ===> op =) ===> (R2 ===> op =) ===> rel_prod R1 R2 ===> op =) prod_fv prod_fv"
  unfolding rel_fun_def
  unfolding rel_prod_def
  by auto

lemma [quot_preserve]:
  assumes q1: "Quotient3 R1 abs1 rep1"
  and     q2: "Quotient3 R2 abs2 rep2"
  shows "((abs1 ---> id) ---> (abs2 ---> id) ---> map_prod rep1 rep2 ---> id) prod_fv = prod_fv"
  by (simp add: fun_eq_iff Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2])

lemma [mono]:
  shows "A <= B \<Longrightarrow> C <= D ==> prod_alpha A C <= prod_alpha B D"
  unfolding prod_alpha_def
  by auto

lemma [eqvt]:
  shows "p \<bullet> prod_alpha A B x y = prod_alpha (p \<bullet> A) (p \<bullet> B) (p \<bullet> x) (p \<bullet> y)"
  unfolding prod_alpha_def
  unfolding rel_prod_def
  by (perm_simp) (rule refl)

lemma [eqvt]:
  shows "p \<bullet> prod_fv A B (x, y) = prod_fv (p \<bullet> A) (p \<bullet> B) (p \<bullet> x, p \<bullet> y)"
  unfolding prod_fv.simps
  by (perm_simp) (rule refl)

lemma prod_fv_supp:
  shows "prod_fv supp supp = supp"
by (rule ext)
   (auto simp: supp_Pair)

lemma prod_alpha_eq:
  shows "prod_alpha (op=) (op=) = (op=)"
  unfolding prod_alpha_def
  by (auto intro!: ext)

end


section \<open> Alphabet Manipulation \<close>

theory nmap_alphabet
  imports
    nmap_seq
begin

subsection \<open> Preliminaries \<close>

text \<open> Alphabets are simply types that characterise the state-space of an expression. Thus
  the Isabelle type system ensures that predicates cannot refer to variables not in the alphabet
  as this would be a type error. Often one would like to add or remove additional variables, for
  example if we wish to have a predicate which ranges only a smaller state-space, and then
  lift it into a predicate over a larger one. This is useful, for example, when dealing with
  relations which refer only to undashed variables (conditions) since we can use the type system
  to ensure well-formedness.

  In this theory we will set up operators for extending and contracting and alphabet.
  We first set up a theorem attribute for alphabet laws and a tactic. \<close>

named_theorems alpha

method alpha_tac = (simp add: alpha unrest)?

subsection \<open> Alphabet Extrusion \<close>

text \<open> Alter an alphabet by application of a lens that demonstrates how the smaller alphabet
  ($\beta$) injects into the larger alphabet ($\alpha$). This changes the type of the expression
  so it is parametrised over the large alphabet. We do this by using the lens \emph{get}
  function to extract the smaller state binding, and then apply this to the expression.

  We call this "extrusion" rather than "extension" because if the extension lens is bijective
  then it does not extend the alphabet. Nevertheless, it does have an effect because the type
  will be different which can be useful when converting predicates with equivalent alphabets. \<close>

lift_definition aext :: "('a, '\<beta>) uexpr \<Rightarrow> ('\<beta>, '\<alpha>) lens \<Rightarrow> ('a, '\<alpha>) uexpr" (infixr "\<oplus>\<^sub>p" 95)
is "\<lambda> P x b. P (get\<^bsub>x\<^esub> b)" .

update_uexpr_rep_eq_thms

text \<open> Next we prove some of the key laws. Extending an alphabet twice is equivalent to extending
  by the composition of the two lenses. \<close>

lemma aext_twice: "(P \<oplus>\<^sub>p a) \<oplus>\<^sub>p b = P \<oplus>\<^sub>p (a ;\<^sub>L b)"
  by (pred_auto)

text \<open> The bijective @{term "1\<^sub>L"} lens identifies the source and view types. Thus an alphabet
  extension using this has no effect. \<close>

lemma aext_id [simp]: "P \<oplus>\<^sub>p 1\<^sub>L = P"
  by (pred_auto)

text \<open> Literals do not depend on any variables, and thus applying an alphabet extension only
  alters the predicate's type, and not its valuation .\<close>

lemma aext_lit [simp]: "\<guillemotleft>v\<guillemotright> \<oplus>\<^sub>p a = \<guillemotleft>v\<guillemotright>"
  by (pred_auto)

lemma aext_zero [simp]: "0 \<oplus>\<^sub>p a = 0"
  by (pred_auto)

lemma aext_one [simp]: "1 \<oplus>\<^sub>p a = 1"
  by (pred_auto)

lemma aext_numeral [simp]: "numeral n \<oplus>\<^sub>p a = numeral n"
  by (pred_auto)

lemma aext_true [simp]: "true \<oplus>\<^sub>p a = true"
  by (pred_auto)

lemma aext_false [simp]: "false \<oplus>\<^sub>p a = false"
  by (pred_auto)

lemma aext_not [alpha]: "(\<not> P) \<oplus>\<^sub>p x = (\<not> (P \<oplus>\<^sub>p x))"
  by (pred_auto)

lemma aext_and [alpha]: "(P \<and> Q) \<oplus>\<^sub>p x = (P \<oplus>\<^sub>p x \<and> Q \<oplus>\<^sub>p x)"
  by (pred_auto)

lemma aext_or [alpha]: "(P \<or> Q) \<oplus>\<^sub>p x = (P \<oplus>\<^sub>p x \<or> Q \<oplus>\<^sub>p x)"
  by (pred_auto)

lemma aext_imp [alpha]: "(P \<Rightarrow> Q) \<oplus>\<^sub>p x = (P \<oplus>\<^sub>p x \<Rightarrow> Q \<oplus>\<^sub>p x)"
  by (pred_auto)

lemma aext_iff [alpha]: "(P \<Leftrightarrow> Q) \<oplus>\<^sub>p x = (P \<oplus>\<^sub>p x \<Leftrightarrow> Q \<oplus>\<^sub>p x)"
  by (pred_auto)

lemma aext_shAll [alpha]: "(\<^bold>\<forall> x \<bullet> P(x)) \<oplus>\<^sub>p a = (\<^bold>\<forall> x \<bullet> P(x) \<oplus>\<^sub>p a)"
  by (pred_auto)

lemma aext_UINF_ind [alpha]: "(\<Sqinter> x \<bullet> P x) \<oplus>\<^sub>p a =(\<Sqinter> x \<bullet> (P x \<oplus>\<^sub>p a))"
  by (pred_auto)

lemma aext_UINF_mem [alpha]: "(\<Sqinter> x\<in>A \<bullet> P x) \<oplus>\<^sub>p a =(\<Sqinter> x\<in>A \<bullet> (P x \<oplus>\<^sub>p a))"
  by (pred_auto)

text \<open> Alphabet extension distributes through the function liftings. \<close>

lemma aext_uop [alpha]: "uop f u \<oplus>\<^sub>p a = uop f (u \<oplus>\<^sub>p a)"
  by (pred_auto)

lemma aext_bop [alpha]: "bop f u v \<oplus>\<^sub>p a = bop f (u \<oplus>\<^sub>p a) (v \<oplus>\<^sub>p a)"
  by (pred_auto)

lemma aext_trop [alpha]: "trop f u v w \<oplus>\<^sub>p a = trop f (u \<oplus>\<^sub>p a) (v \<oplus>\<^sub>p a) (w \<oplus>\<^sub>p a)"
  by (pred_auto)

lemma aext_qtop [alpha]: "qtop f u v w x \<oplus>\<^sub>p a = qtop f (u \<oplus>\<^sub>p a) (v \<oplus>\<^sub>p a) (w \<oplus>\<^sub>p a) (x \<oplus>\<^sub>p a)"
  by (pred_auto)

lemma aext_plus [alpha]:
  "(x + y) \<oplus>\<^sub>p a = (x \<oplus>\<^sub>p a) + (y \<oplus>\<^sub>p a)"
  by (pred_auto)

lemma aext_minus [alpha]:
  "(x - y) \<oplus>\<^sub>p a = (x \<oplus>\<^sub>p a) - (y \<oplus>\<^sub>p a)"
  by (pred_auto)

lemma aext_uminus [simp]:
  "(- x) \<oplus>\<^sub>p a = - (x \<oplus>\<^sub>p a)"
  by (pred_auto)

lemma aext_times [alpha]:
  "(x * y) \<oplus>\<^sub>p a = (x \<oplus>\<^sub>p a) * (y \<oplus>\<^sub>p a)"
  by (pred_auto)

lemma aext_divide [alpha]:
  "(x / y) \<oplus>\<^sub>p a = (x \<oplus>\<^sub>p a) / (y \<oplus>\<^sub>p a)"
  by (pred_auto)

text \<open> Extending a variable expression over $x$ is equivalent to composing $x$ with the alphabet,
  thus effectively yielding a variable whose source is the large alphabet. \<close>

lemma aext_var [alpha]:
  "var x \<oplus>\<^sub>p a = var (x ;\<^sub>L a)"
  by (pred_auto)

lemma aext_ulambda [alpha]: "((\<lambda> x \<bullet> P(x)) \<oplus>\<^sub>p a) = (\<lambda> x \<bullet> P(x) \<oplus>\<^sub>p a)"
  by (pred_auto)

text \<open> Alphabet extension is monotonic and continuous. \<close>

lemma aext_mono: "P \<sqsubseteq> Q \<Longrightarrow> P \<oplus>\<^sub>p a \<sqsubseteq> Q \<oplus>\<^sub>p a"
  by (pred_auto)

lemma aext_cont [alpha]: "vwb_lens a \<Longrightarrow> (\<Sqinter> A) \<oplus>\<^sub>p a = (\<Sqinter> P\<in>A.  P \<oplus>\<^sub>p a)"
  by (pred_simp)

text \<open> If a variable is unrestricted in a predicate, then the extended variable is unrestricted
  in the predicate with an alphabet extension. \<close>

lemma unrest_aext [unrest]:
  "\<lbrakk> mwb_lens a; x \<sharp> p \<rbrakk> \<Longrightarrow> unrest (x ;\<^sub>L a) (p \<oplus>\<^sub>p a)"
  by (transfer, simp add: lens_comp_def)

text \<open> If a given variable (or alphabet) $b$ is independent of the extension lens $a$, that is, it is
  outside the original state-space of $p$, then it follows that once $p$ is extended by $a$ then
  $b$ cannot be restricted. \<close>

lemma unrest_aext_indep [unrest]:
  "a \<bowtie> b \<Longrightarrow> b \<sharp> (p \<oplus>\<^sub>p a)"
  by pred_auto

subsection \<open> Expression Alphabet Restriction \<close>

text \<open> Restrict an alphabet by application of a lens that demonstrates how the smaller alphabet
  ($\beta$) injects into the larger alphabet ($\alpha$). Unlike extension, this operation
  can lose information if the expressions refers to variables in the larger alphabet. \<close>

lift_definition arestr :: "('a, '\<alpha>) uexpr \<Rightarrow> ('\<beta>, '\<alpha>) lens \<Rightarrow> ('a, '\<beta>) uexpr" (infixr "\<restriction>\<^sub>e" 90)
is "\<lambda> P x b. P (create\<^bsub>x\<^esub> b)" .

update_uexpr_rep_eq_thms

lemma arestr_id [simp]: "P \<restriction>\<^sub>e 1\<^sub>L = P"
  by (pred_auto)

lemma arestr_aext [simp]: "mwb_lens a \<Longrightarrow> (P \<oplus>\<^sub>p a) \<restriction>\<^sub>e a = P"
  by (pred_auto)

text \<open> If an expression's alphabet can be divided into two disjoint sections and the expression
  does not depend on the second half then restricting the expression to the first half is
  loss-less. \<close>

lemma aext_arestr [alpha]:
  assumes "mwb_lens a" "bij_lens (a +\<^sub>L b)" "a \<bowtie> b" "b \<sharp> P"
  shows "(P \<restriction>\<^sub>e a) \<oplus>\<^sub>p a = P"
proof -
  from assms(2) have "1\<^sub>L \<subseteq>\<^sub>L a +\<^sub>L b"
    by (simp add: bij_lens_equiv_id lens_equiv_def)
  with assms(1,3,4) show ?thesis
    apply (auto simp add: id_lens_def lens_plus_def sublens_def lens_comp_def prod.case_eq_if)
    apply (pred_simp)
    apply (metis lens_indep_comm mwb_lens_weak weak_lens.put_get)
    done
qed

lemma arestr_lit [simp]: "\<guillemotleft>v\<guillemotright> \<restriction>\<^sub>e a = \<guillemotleft>v\<guillemotright>"
  by (pred_auto)

lemma arestr_zero [simp]: "0 \<restriction>\<^sub>e a = 0"
  by (pred_auto)

lemma arestr_one [simp]: "1 \<restriction>\<^sub>e a = 1"
  by (pred_auto)

lemma arestr_numeral [simp]: "numeral n \<restriction>\<^sub>e a = numeral n"
  by (pred_auto)

lemma arestr_var [alpha]:
  "var x \<restriction>\<^sub>e a = var (x /\<^sub>L a)"
  by (pred_auto)

lemma arestr_true [simp]: "true \<restriction>\<^sub>e a = true"
  by (pred_auto)

lemma arestr_false [simp]: "false \<restriction>\<^sub>e a = false"
  by (pred_auto)

lemma arestr_not [alpha]: "(\<not> P)\<restriction>\<^sub>ea = (\<not> (P\<restriction>\<^sub>ea))"
  by (pred_auto)

lemma arestr_and [alpha]: "(P \<and> Q)\<restriction>\<^sub>ex = (P\<restriction>\<^sub>ex \<and> Q\<restriction>\<^sub>ex)"
  by (pred_auto)

lemma arestr_or [alpha]: "(P \<or> Q)\<restriction>\<^sub>ex = (P\<restriction>\<^sub>ex \<or> Q\<restriction>\<^sub>ex)"
  by (pred_auto)

lemma arestr_imp [alpha]: "(P \<Rightarrow> Q)\<restriction>\<^sub>ex = (P\<restriction>\<^sub>ex \<Rightarrow> Q\<restriction>\<^sub>ex)"
  by (pred_auto)

subsection \<open> Predicate Alphabet Restriction \<close>

text \<open> In order to restrict the variables of a predicate, we also need to existentially quantify
  away the other variables. We can't do this at the level of expressions, as quantifiers are not
  applicable here. Consequently, we need a specialised version of alphabet restriction for
  predicates. It both restricts the variables using quantification and then removes them
  from the alphabet type using expression restriction. \<close>

definition upred_ares :: "'\<alpha> upred \<Rightarrow> ('\<beta> \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<beta> upred"
where [upred_defs]: "upred_ares P a = (P \<restriction>\<^sub>v a) \<restriction>\<^sub>e a"

syntax
  "_upred_ares" :: "logic \<Rightarrow> salpha \<Rightarrow> logic" (infixl "\<restriction>\<^sub>p" 90)

translations
  "_upred_ares P a" == "CONST upred_ares P a"

lemma upred_aext_ares [alpha]:
  "vwb_lens a \<Longrightarrow> P \<oplus>\<^sub>p a \<restriction>\<^sub>p a = P"
  by (pred_auto)

lemma upred_ares_aext [alpha]:
  "a \<natural> P \<Longrightarrow> (P \<restriction>\<^sub>p a) \<oplus>\<^sub>p a = P"
  by (pred_auto)

lemma upred_arestr_lit [simp]: "\<guillemotleft>v\<guillemotright> \<restriction>\<^sub>p a = \<guillemotleft>v\<guillemotright>"
  by (pred_auto)

lemma upred_arestr_true [simp]: "true \<restriction>\<^sub>p a = true"
  by (pred_auto)

lemma upred_arestr_false [simp]: "false \<restriction>\<^sub>p a = false"
  by (pred_auto)

lemma upred_arestr_or [alpha]: "(P \<or> Q)\<restriction>\<^sub>px = (P\<restriction>\<^sub>px \<or> Q\<restriction>\<^sub>px)"
  by (pred_auto)

subsection \<open> Alphabet Lens Laws \<close>

lemma alpha_in_var [alpha]: "x ;\<^sub>L fst\<^sub>L = in_var x"
  by (simp add: in_var_def)

lemma alpha_out_var [alpha]: "x ;\<^sub>L snd\<^sub>L = out_var x"
  by (simp add: out_var_def)

lemma in_var_prod_lens [alpha]:
  "wb_lens Y \<Longrightarrow> in_var x ;\<^sub>L (X \<times>\<^sub>L Y) = in_var (x ;\<^sub>L X)"
  by (simp add: in_var_def prod_as_plus lens_comp_assoc fst_lens_plus)

lemma out_var_prod_lens [alpha]:
  "wb_lens X \<Longrightarrow> out_var x ;\<^sub>L (X \<times>\<^sub>L Y) = out_var (x ;\<^sub>L Y)"
  apply (simp add: out_var_def prod_as_plus lens_comp_assoc)
  apply (subst snd_lens_plus)
  using comp_wb_lens fst_vwb_lens vwb_lens_wb apply blast
   apply (simp add: alpha_in_var alpha_out_var)
  apply (simp)
  done

subsection \<open> Substitution Alphabet Extension \<close>

text \<open> This allows us to extend the alphabet of a substitution, in a similar way to expressions. \<close>

definition subst_ext :: "'\<alpha> usubst \<Rightarrow> ('\<alpha> \<Longrightarrow> '\<beta>) \<Rightarrow> '\<beta> usubst" (infix "\<oplus>\<^sub>s" 65) where
[upred_defs]: "\<sigma> \<oplus>\<^sub>s x = (\<lambda> s. put\<^bsub>x\<^esub> s (\<sigma> (get\<^bsub>x\<^esub> s)))"

lemma id_subst_ext [usubst]:
  "wb_lens x \<Longrightarrow> id \<oplus>\<^sub>s x = id"
  by pred_auto

lemma apply_subst_ext [alpha]:
  "vwb_lens x \<Longrightarrow> (\<sigma> \<dagger> e) \<oplus>\<^sub>p x = (\<sigma> \<oplus>\<^sub>s x) \<dagger> (e \<oplus>\<^sub>p x)"
  by (pred_auto)

lemma aext_upred_eq [alpha]:
  "((e =\<^sub>u f) \<oplus>\<^sub>p a) = ((e \<oplus>\<^sub>p a) =\<^sub>u (f \<oplus>\<^sub>p a))"
  by (pred_auto)

lemma subst_aext_comp [usubst]:
  "vwb_lens a \<Longrightarrow> (\<sigma> \<oplus>\<^sub>s a) \<circ> (\<rho> \<oplus>\<^sub>s a) = (\<sigma> \<circ> \<rho>) \<oplus>\<^sub>s a"
  by pred_auto

subsection \<open> Substitution Alphabet Restriction \<close>

text \<open> This allows us to reduce the alphabet of a substitution, in a similar way to expressions. \<close>

definition subst_res :: "'\<alpha> usubst \<Rightarrow> ('\<beta> \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<beta> usubst" (infix "\<restriction>\<^sub>s" 65) where
[upred_defs]: "\<sigma> \<restriction>\<^sub>s x = (\<lambda> s. get\<^bsub>x\<^esub> (\<sigma> (create\<^bsub>x\<^esub> s)))"

lemma id_subst_res [usubst]:
  "mwb_lens x \<Longrightarrow> id \<restriction>\<^sub>s x = id"
  by pred_auto

lemma upd_subst_res [alpha]:
  "mwb_lens x \<Longrightarrow> \<sigma>(&x:y \<mapsto>\<^sub>s v) \<restriction>\<^sub>s x = (\<sigma> \<restriction>\<^sub>s x)(&y \<mapsto>\<^sub>s v \<restriction>\<^sub>e x)"
  by (pred_auto)

lemma subst_ext_res [usubst]:
  "mwb_lens x \<Longrightarrow> (\<sigma> \<oplus>\<^sub>s x) \<restriction>\<^sub>s x = \<sigma>"
  by (pred_auto)

lemma unrest_subst_alpha_ext [unrest]:
  "x \<bowtie> y \<Longrightarrow> x \<sharp> (P \<oplus>\<^sub>s y)"
  by (pred_simp robust, metis lens_indep_def)
end