section \<open> Scenes \<close>

theory Scenes
  imports Lens_Symmetric
begin

text \<open> Like lenses, scenes characterise a region of a source type. However, unlike lenses, scenes
  do not explicitly assign a view type to this region, and consequently they have just one type
  parameter. This means they can be more flexibly composed, and in particular it is possible to
  show they form nice algebraic structures in Isabelle/HOL. They are mainly of use in characterising
  sets of variables, where, of course, we do not care about the types of those variables and
  therefore representing them as lenses is inconvenient. \<close>

subsection \<open> Overriding Functions \<close>

text \<open> Overriding functions provide an abstract way of replacing a region of an existing source
  with the corresponding region of another source. \<close>

locale overrider =
  fixes F  :: "'s \<Rightarrow> 's \<Rightarrow> 's" (infixl "\<triangleright>" 65)
  assumes
    ovr_overshadow_left: "x \<triangleright> y \<triangleright> z = x \<triangleright> z" and
    ovr_overshadow_right: "x \<triangleright> (y \<triangleright> z) = x \<triangleright> z"
begin
  lemma ovr_assoc: "x \<triangleright> (y \<triangleright> z) = x \<triangleright> y \<triangleright> z"
    by (simp add: ovr_overshadow_left ovr_overshadow_right)
end

locale idem_overrider = overrider +
  assumes ovr_idem: "x \<triangleright> x = x"

declare overrider.ovr_overshadow_left [simp]
declare overrider.ovr_overshadow_right [simp]
declare idem_overrider.ovr_idem [simp]

subsection \<open> Scene Type \<close>

typedef 's scene = "{F :: 's \<Rightarrow> 's \<Rightarrow> 's. overrider F}"
  by (rule_tac x="\<lambda> x y. x" in exI, simp, unfold_locales, simp_all)

setup_lifting type_definition_scene

lift_definition idem_scene :: "'s scene \<Rightarrow> bool" is idem_overrider .

lift_definition region :: "'s scene \<Rightarrow> 's rel"
is "\<lambda> F. {(s\<^sub>1, s\<^sub>2). (\<forall> s. F s s\<^sub>1 = F s s\<^sub>2)}" .

lift_definition coregion :: "'s scene \<Rightarrow> 's rel"
is "\<lambda> F. {(s\<^sub>1, s\<^sub>2). (\<forall> s. F s\<^sub>1 s = F s\<^sub>2 s)}" .

lemma equiv_region: "equiv UNIV (region X)"
  apply (transfer)
  apply (rule equivI)
    apply (rule refl_onI)
     apply (auto)
   apply (rule symI)
   apply (auto)
  apply (rule transI)
  apply (auto)
  done

lemma equiv_coregion: "equiv UNIV (coregion X)"
  apply (transfer)
  apply (rule equivI)
    apply (rule refl_onI)
     apply (auto)
   apply (rule symI)
   apply (auto)
  apply (rule transI)
  apply (auto)
  done

lemma region_coregion_Id:
  "idem_scene X \<Longrightarrow> region X \<inter> coregion X = Id"
  by (transfer, auto, metis idem_overrider.ovr_idem)

lift_definition scene_override :: "'a \<Rightarrow> 'a \<Rightarrow> ('a scene) \<Rightarrow> 'a" ("_ \<oplus>\<^sub>S _ on _" [95,0,96] 95)
is "\<lambda> s\<^sub>1 s\<^sub>2 F. F s\<^sub>1 s\<^sub>2" .

abbreviation (input) scene_copy :: "'a scene \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow> 'a)" ("cp\<^bsub>_\<^esub>") where
"cp\<^bsub>A\<^esub> s \<equiv> (\<lambda> s'. s' \<oplus>\<^sub>S s on A)"

lemma scene_override_idem [simp]: "idem_scene X \<Longrightarrow> s \<oplus>\<^sub>S s on X = s"
  by (transfer, simp)

lemma scene_override_overshadow_left [simp]:
  "S\<^sub>1 \<oplus>\<^sub>S S\<^sub>2 on X \<oplus>\<^sub>S S\<^sub>3 on X = S\<^sub>1 \<oplus>\<^sub>S S\<^sub>3 on X"
  by (transfer, simp)

lemma scene_override_overshadow_right [simp]:
  "S\<^sub>1 \<oplus>\<^sub>S (S\<^sub>2 \<oplus>\<^sub>S S\<^sub>3 on X) on X = S\<^sub>1 \<oplus>\<^sub>S S\<^sub>3 on X"
  by (transfer, simp)

definition scene_equiv :: "'a \<Rightarrow> 'a \<Rightarrow> ('a scene) \<Rightarrow> bool" ("_ \<approx>\<^sub>S _ on _" [65,0,66] 65) where
[lens_defs]: "S\<^sub>1 \<approx>\<^sub>S S\<^sub>2 on X = (S\<^sub>1 \<oplus>\<^sub>S S\<^sub>2 on X = S\<^sub>1)"

lemma scene_equiv_region: "idem_scene X \<Longrightarrow> region X = {(S\<^sub>1, S\<^sub>2). S\<^sub>1 \<approx>\<^sub>S S\<^sub>2 on X}"
  by (simp add: lens_defs, transfer, auto)
     (metis idem_overrider.ovr_idem, metis overrider.ovr_overshadow_right)

lift_definition scene_indep :: "'a scene \<Rightarrow> 'a scene \<Rightarrow> bool" (infix "\<bowtie>\<^sub>S" 50)
is "\<lambda> F G. (\<forall> s\<^sub>1 s\<^sub>2 s\<^sub>3. G (F s\<^sub>1 s\<^sub>2) s\<^sub>3 = F (G s\<^sub>1 s\<^sub>3) s\<^sub>2)" .

lemma scene_indep_override:
  "X \<bowtie>\<^sub>S Y = (\<forall> s\<^sub>1 s\<^sub>2 s\<^sub>3. s\<^sub>1 \<oplus>\<^sub>S s\<^sub>2 on X \<oplus>\<^sub>S s\<^sub>3 on Y = s\<^sub>1 \<oplus>\<^sub>S s\<^sub>3 on Y \<oplus>\<^sub>S s\<^sub>2 on X)"
  by (transfer, auto)

lemma scene_indep_copy:
  "X \<bowtie>\<^sub>S Y = (\<forall> s\<^sub>1  s\<^sub>2. cp\<^bsub>X\<^esub> s\<^sub>1 \<circ> cp\<^bsub>Y\<^esub> s\<^sub>2 = cp\<^bsub>Y\<^esub> s\<^sub>2 \<circ> cp\<^bsub>X\<^esub> s\<^sub>1)"
  by (auto simp add: scene_indep_override comp_def fun_eq_iff)

lemma scene_indep_sym:
  "X \<bowtie>\<^sub>S Y \<Longrightarrow> Y \<bowtie>\<^sub>S X"
  by (transfer, auto)

text \<open> Compatibility is a weaker notion than independence; the scenes can overlap but they must
  agree when they do. \<close>

lift_definition scene_compat :: "'a scene \<Rightarrow> 'a scene \<Rightarrow> bool" (infix "##\<^sub>S" 50)
is "\<lambda> F G. (\<forall> s\<^sub>1 s\<^sub>2. G (F s\<^sub>1 s\<^sub>2) s\<^sub>2 = F (G s\<^sub>1 s\<^sub>2) s\<^sub>2)" .

lemma scene_compat_copy:
  "X ##\<^sub>S Y = (\<forall> s. cp\<^bsub>X\<^esub> s \<circ> cp\<^bsub>Y\<^esub> s = cp\<^bsub>Y\<^esub> s \<circ> cp\<^bsub>X\<^esub> s)"
  by (transfer, auto simp add: fun_eq_iff)

lemma scene_indep_compat [simp]: "X \<bowtie>\<^sub>S Y \<Longrightarrow> X ##\<^sub>S Y"
  by (transfer, auto)

lemma scene_compat_refl: "X ##\<^sub>S X"
  by (transfer, simp)

lemma scene_compat_sym: "X ##\<^sub>S Y \<Longrightarrow> Y ##\<^sub>S X"
  by (transfer, simp)

lemma scene_override_commute_indep:
  assumes "X \<bowtie>\<^sub>S Y"
  shows "S\<^sub>1 \<oplus>\<^sub>S S\<^sub>2 on X \<oplus>\<^sub>S S\<^sub>3 on Y = S\<^sub>1 \<oplus>\<^sub>S S\<^sub>3 on Y \<oplus>\<^sub>S S\<^sub>2 on X"
  using assms
  by (transfer, auto)

instantiation scene :: (type) "{bot, top, uminus, sup, inf}"
begin
  lift_definition bot_scene    :: "'a scene" is "\<lambda> x y. x" by (unfold_locales, simp_all)
  lift_definition top_scene    :: "'a scene" is "\<lambda> x y. y" by (unfold_locales, simp_all)
  lift_definition uminus_scene :: "'a scene \<Rightarrow> 'a scene" is "\<lambda> F x y. F y x"
    by (unfold_locales, simp_all)
  text \<open> Scene union requires that the two scenes are at least compatible. If they are not, the
        result is the bottom scene. \<close>
  lift_definition sup_scene :: "'a scene \<Rightarrow> 'a scene \<Rightarrow> 'a scene"
    is "\<lambda> F G. if (\<forall> s\<^sub>1 s\<^sub>2. G (F s\<^sub>1 s\<^sub>2) s\<^sub>2 = F (G s\<^sub>1 s\<^sub>2) s\<^sub>2) then (\<lambda> s\<^sub>1 s\<^sub>2. G (F s\<^sub>1 s\<^sub>2) s\<^sub>2) else (\<lambda> s\<^sub>1 s\<^sub>2. s\<^sub>1)"
    by (unfold_locales, auto, metis overrider.ovr_overshadow_right)
  definition inf_scene :: "'a scene \<Rightarrow> 'a scene \<Rightarrow> 'a scene" where
    [lens_defs]: "inf_scene X Y = - (sup (- X) (- Y))"
  instance ..
end

abbreviation union_scene :: "'s scene \<Rightarrow> 's scene \<Rightarrow> 's scene" (infixl "\<squnion>\<^sub>S" 65)
where "union_scene \<equiv> sup"

abbreviation inter_scene :: "'s scene \<Rightarrow> 's scene \<Rightarrow> 's scene" (infixl "\<sqinter>\<^sub>S" 70)
where "inter_scene \<equiv> inf"

abbreviation top_scene :: "'s scene" ("\<top>\<^sub>S")
where "top_scene \<equiv> top"

abbreviation bot_scene :: "'s scene" ("\<bottom>\<^sub>S")
where "bot_scene \<equiv> bot"

instantiation scene :: (type) "minus"
begin
  definition minus_scene :: "'a scene \<Rightarrow> 'a scene \<Rightarrow> 'a scene" where
    "minus_scene A B = A \<sqinter>\<^sub>S (- B)"
instance ..
end

lemma bot_idem_scene [simp]: "idem_scene \<bottom>\<^sub>S"
  by (transfer, unfold_locales, simp_all)

lemma top_idem_scene [simp]: "idem_scene \<top>\<^sub>S"
  by (transfer, unfold_locales, simp_all)

lemma uminus_top_scene [simp]: "- \<top>\<^sub>S = \<bottom>\<^sub>S"
  by (transfer, simp)

lemma uminus_bot_scene [simp]: "- \<bottom>\<^sub>S = \<top>\<^sub>S"
  by (transfer, simp)

lemma uminus_scene_twice: "- (- (X :: 's scene)) = X"
  by (transfer, simp)

lemma scene_override_id [simp]: "S\<^sub>1 \<oplus>\<^sub>S S\<^sub>2 on \<top>\<^sub>S = S\<^sub>2"
  by (transfer, simp)

lemma scene_override_unit [simp]: "S\<^sub>1 \<oplus>\<^sub>S S\<^sub>2 on \<bottom>\<^sub>S = S\<^sub>1"
  by (transfer, simp)

lemma scene_override_commute: "S\<^sub>2 \<oplus>\<^sub>S S\<^sub>1 on (- X) = S\<^sub>1 \<oplus>\<^sub>S S\<^sub>2 on X"
  by (transfer, simp)

lemma scene_union_incompat: "\<not> X ##\<^sub>S Y \<Longrightarrow> X \<squnion>\<^sub>S Y = \<bottom>\<^sub>S"
  by (transfer, auto)

lemma scene_override_union: "X ##\<^sub>S Y \<Longrightarrow> S\<^sub>1 \<oplus>\<^sub>S S\<^sub>2 on (X \<squnion>\<^sub>S Y) = (S\<^sub>1 \<oplus>\<^sub>S S\<^sub>2 on X) \<oplus>\<^sub>S S\<^sub>2 on Y"
  by (transfer, auto)

lemma scene_override_inter: "-X ##\<^sub>S -Y \<Longrightarrow> S\<^sub>1 \<oplus>\<^sub>S S\<^sub>2 on (X \<sqinter>\<^sub>S Y) = S\<^sub>1 \<oplus>\<^sub>S S\<^sub>1 \<oplus>\<^sub>S S\<^sub>2 on X on Y"
  by (simp add: inf_scene_def scene_override_commute scene_override_union)

lemma scene_equiv_bot [simp]: "a \<approx>\<^sub>S b on \<bottom>\<^sub>S"
  by (simp add: scene_equiv_def)

lemma scene_equiv_refl [simp]: "idem_scene a \<Longrightarrow> s \<approx>\<^sub>S s on a"
  by (simp add: scene_equiv_def)

lemma scene_equiv_sym [simp]: "idem_scene a \<Longrightarrow> s\<^sub>1 \<approx>\<^sub>S s\<^sub>2 on a \<Longrightarrow> s\<^sub>2 \<approx>\<^sub>S s\<^sub>1 on a"
  by (metis scene_equiv_def scene_override_idem scene_override_overshadow_right)

lemma scene_union_unit [simp]: "X \<squnion>\<^sub>S \<bottom>\<^sub>S = X" "\<bottom>\<^sub>S \<squnion>\<^sub>S X = X"
  by (transfer, simp)+

lemma scene_indep_bot [simp]: "X \<bowtie>\<^sub>S \<bottom>\<^sub>S"
  by (transfer, simp)

text \<open> A unitary scene admits only one element, and therefore top and bottom are the same. \<close>

lemma unit_scene_top_eq_bot: "(\<bottom>\<^sub>S :: unit scene) = \<top>\<^sub>S"
  by (transfer, simp)

lemma idem_scene_union [simp]: "\<lbrakk> idem_scene A; idem_scene B \<rbrakk> \<Longrightarrow> idem_scene (A \<squnion>\<^sub>S B)"
  apply (transfer, auto)
   apply (unfold_locales, auto)
   apply (metis overrider.ovr_overshadow_left)
  apply (metis overrider.ovr_overshadow_right)
  done

lemma scene_union_annhil: "idem_scene X \<Longrightarrow> X \<squnion>\<^sub>S \<top>\<^sub>S = \<top>\<^sub>S"
  by (transfer, simp)

lemma scene_union_pres_compat: "\<lbrakk> A ##\<^sub>S B; A ##\<^sub>S C \<rbrakk> \<Longrightarrow> A ##\<^sub>S (B \<squnion>\<^sub>S C)"
  by (transfer, auto)

lemma scene_indep_pres_compat: "\<lbrakk> A \<bowtie>\<^sub>S B; A \<bowtie>\<^sub>S C \<rbrakk> \<Longrightarrow> A \<bowtie>\<^sub>S (B \<squnion>\<^sub>S C)"
  by (transfer, auto)

lemma scene_indep_self_compl: "A \<bowtie>\<^sub>S -A"
  by (transfer, simp)

lemma scene_compat_self_compl: "A ##\<^sub>S -A"
  by (transfer, simp)

lemma scene_compat_bot [simp]: "a ##\<^sub>S \<bottom>\<^sub>S" "\<bottom>\<^sub>S ##\<^sub>S a"
  by (transfer, simp)+

lemma scene_compat_top [simp]:
  "idem_scene a \<Longrightarrow> a ##\<^sub>S \<top>\<^sub>S"
  "idem_scene a \<Longrightarrow> \<top>\<^sub>S ##\<^sub>S a"
  by (transfer, simp)+

lemma scene_union_assoc:
  assumes "X ##\<^sub>S Y" "X ##\<^sub>S Z" "Y ##\<^sub>S Z"
  shows "X \<squnion>\<^sub>S (Y \<squnion>\<^sub>S Z) = (X \<squnion>\<^sub>S Y) \<squnion>\<^sub>S Z"
  using assms by (transfer, auto)

lemma scene_inter_indep:
  assumes "idem_scene X" "idem_scene Y" "X \<bowtie>\<^sub>S Y"
  shows "X \<sqinter>\<^sub>S Y = \<bottom>\<^sub>S"
  using assms
  unfolding lens_defs
  apply (transfer, auto)
   apply (metis (no_types, opaque_lifting) idem_overrider.ovr_idem overrider.ovr_assoc overrider.ovr_overshadow_right)
  apply (metis (no_types, opaque_lifting) idem_overrider.ovr_idem overrider.ovr_overshadow_right)
  done

lemma scene_union_indep_uniq:
  assumes "idem_scene X" "idem_scene Y" "idem_scene Z" "X \<bowtie>\<^sub>S Z" "Y \<bowtie>\<^sub>S Z" "X \<squnion>\<^sub>S Z = Y \<squnion>\<^sub>S Z"
  shows "X = Y"
  using assms apply (transfer, simp)
  by (metis (no_types, opaque_lifting) ext idem_overrider.ovr_idem overrider_def)

lemma scene_union_idem: "X \<squnion>\<^sub>S X = X"
  by (transfer, simp)

lemma scene_union_compl: "idem_scene X \<Longrightarrow> X \<squnion>\<^sub>S - X = \<top>\<^sub>S"
  by (transfer, auto)

lemma scene_inter_idem: "X \<sqinter>\<^sub>S X = X"
  by (simp add: inf_scene_def, transfer, auto)

lemma scene_union_commute: "X \<squnion>\<^sub>S Y = Y \<squnion>\<^sub>S X"
  by (transfer, auto)

lemma scene_inter_compl: "idem_scene X \<Longrightarrow> X \<sqinter>\<^sub>S - X = \<bottom>\<^sub>S"
  by (simp add: inf_scene_def, transfer, auto)

lemma scene_demorgan1: "-(X \<squnion>\<^sub>S Y) = -X \<sqinter>\<^sub>S -Y"
  by (simp add: inf_scene_def, transfer, auto)

lemma scene_demorgan2: "-(X \<sqinter>\<^sub>S Y) = -X \<squnion>\<^sub>S -Y"
  by (simp add: inf_scene_def, transfer, auto)

lemma scene_inter_commute: "X \<sqinter>\<^sub>S Y = Y \<sqinter>\<^sub>S X"
  by (simp add: inf_scene_def scene_union_commute)

lemma scene_union_inter_distrib:
  "\<lbrakk> idem_scene x; x \<bowtie>\<^sub>S y; x \<bowtie>\<^sub>S z; y ##\<^sub>S z \<rbrakk> \<Longrightarrow> x \<squnion>\<^sub>S y \<sqinter>\<^sub>S z = (x \<squnion>\<^sub>S y) \<sqinter>\<^sub>S (x \<squnion>\<^sub>S z)"
  apply (simp add: inf_scene_def, transfer)
  apply (auto simp add: fun_eq_iff)
     apply (unfold overrider_def idem_overrider_def idem_overrider_axioms_def)
     apply metis+
  done

lemma idem_scene_uminus [simp]: "idem_scene X \<Longrightarrow> idem_scene (- X)"
  by (simp add: uminus_scene_def idem_scene_def Abs_scene_inverse idem_overrider_axioms_def idem_overrider_def overrider.intro)

lemma scene_minus_cancel: "\<lbrakk> a \<bowtie>\<^sub>S b; idem_scene a; idem_scene b \<rbrakk> \<Longrightarrow> a \<squnion>\<^sub>S (b \<sqinter>\<^sub>S - a) = a \<squnion>\<^sub>S b"
  apply (simp add: lens_defs, transfer, auto simp add: fun_eq_iff)
   apply (metis (mono_tags, lifting) overrider.ovr_overshadow_left)
  apply (metis (no_types, opaque_lifting) idem_overrider.ovr_idem overrider.ovr_overshadow_right)
  done

instantiation scene :: (type) ord
begin
  text \<open> $X$ is a subscene of $Y$ provided that overriding with first $Y$ and then $X$ can
         be rewritten using the complement of $X$. \<close>
  definition less_eq_scene :: "'a scene \<Rightarrow> 'a scene \<Rightarrow> bool" where
  [lens_defs]: "less_eq_scene X Y = (\<forall> s\<^sub>1 s\<^sub>2 s\<^sub>3. s\<^sub>1 \<oplus>\<^sub>S s\<^sub>2 on Y \<oplus>\<^sub>S s\<^sub>3 on X = s\<^sub>1 \<oplus>\<^sub>S (s\<^sub>2 \<oplus>\<^sub>S s\<^sub>3 on X) on Y)"
  definition less_scene :: "'a scene \<Rightarrow> 'a scene \<Rightarrow> bool" where
  [lens_defs]: "less_scene x y = (x \<le> y \<and> \<not> y \<le> x)"
instance ..
end

abbreviation subscene :: "'a scene \<Rightarrow> 'a scene \<Rightarrow> bool" (infix "\<subseteq>\<^sub>S" 55)
where "subscene X Y \<equiv> X \<le> Y"

lemma subscene_refl: "X \<subseteq>\<^sub>S X"
  by (simp add: less_eq_scene_def)

lemma subscene_trans: "\<lbrakk> idem_scene Y; X \<subseteq>\<^sub>S Y; Y \<subseteq>\<^sub>S Z \<rbrakk> \<Longrightarrow> X \<subseteq>\<^sub>S Z"
  by (simp add: less_eq_scene_def, transfer, auto, metis (no_types, opaque_lifting) idem_overrider.ovr_idem)

lemma subscene_antisym: "\<lbrakk> idem_scene Y; X \<subseteq>\<^sub>S Y; Y \<subseteq>\<^sub>S X \<rbrakk> \<Longrightarrow> X = Y"
  apply (simp add: less_eq_scene_def, transfer, auto)
  apply (rule ext)
  apply (rule ext)
  apply (metis (full_types) idem_overrider.ovr_idem overrider.ovr_overshadow_left)
  done

lemma subscene_copy_def:
  assumes "idem_scene X" "idem_scene Y"
  shows "X \<subseteq>\<^sub>S Y = (\<forall> s\<^sub>1 s\<^sub>2. cp\<^bsub>X\<^esub> s\<^sub>1 \<circ> cp\<^bsub>Y\<^esub> s\<^sub>2 = cp\<^bsub>Y\<^esub> (cp\<^bsub>X\<^esub> s\<^sub>1 s\<^sub>2))"
  using assms
  by (simp add: less_eq_scene_def fun_eq_iff, transfer, auto)

lemma subscene_eliminate:
  "\<lbrakk> idem_scene Y; X \<le> Y \<rbrakk> \<Longrightarrow> s\<^sub>1 \<oplus>\<^sub>S s\<^sub>2 on X \<oplus>\<^sub>S s\<^sub>3 on Y = s\<^sub>1 \<oplus>\<^sub>S s\<^sub>3 on Y"
  by (metis less_eq_scene_def scene_override_overshadow_left scene_override_idem)

lemma scene_bot_least: "\<bottom>\<^sub>S \<le> X"
  unfolding less_eq_scene_def by (transfer, auto)

lemma scene_top_greatest: "X \<le> \<top>\<^sub>S"
  unfolding less_eq_scene_def by (transfer, auto)

lemma scene_union_ub: "\<lbrakk> idem_scene Y; X \<bowtie>\<^sub>S Y \<rbrakk> \<Longrightarrow> X \<le> (X \<squnion>\<^sub>S Y)"
  by (simp add: less_eq_scene_def, transfer, auto)
     (metis (no_types, opaque_lifting) idem_overrider.ovr_idem overrider.ovr_overshadow_right)

lemma scene_union_lb: "\<lbrakk> a ##\<^sub>S b; a \<le> c; b \<le> c \<rbrakk> \<Longrightarrow> a \<squnion>\<^sub>S b \<le> c"
  by (simp add: less_eq_scene_def scene_override_union)

lemma scene_union_mono: "\<lbrakk> a \<subseteq>\<^sub>S c; b \<subseteq>\<^sub>S c; a ##\<^sub>S b; idem_scene a; idem_scene b \<rbrakk> \<Longrightarrow> a \<squnion>\<^sub>S b \<subseteq>\<^sub>S c"
  by (simp add: less_eq_scene_def, transfer, auto)

lemma scene_le_then_compat: "\<lbrakk> idem_scene X; idem_scene Y; X \<le> Y \<rbrakk> \<Longrightarrow> X ##\<^sub>S Y"
  unfolding less_eq_scene_def
  by (transfer, auto, metis (no_types, lifting) idem_overrider.ovr_idem overrider_def)

lemma indep_then_compl_in: "A \<bowtie>\<^sub>S B \<Longrightarrow> A \<le> -B"
  unfolding less_eq_scene_def by (transfer, simp)

lemma scene_le_iff_indep_inv:
  "A \<bowtie>\<^sub>S - B \<longleftrightarrow> A \<le> B"
  by (auto simp add: less_eq_scene_def scene_indep_override scene_override_commute)

lift_definition scene_comp :: "'a scene \<Rightarrow> ('a \<Longrightarrow> 'b) \<Rightarrow> 'b scene" (infixl ";\<^sub>S" 80)
is "\<lambda> S X a b. if (vwb_lens X) then put\<^bsub>X\<^esub> a (S (get\<^bsub>X\<^esub> a) (get\<^bsub>X\<^esub> b)) else a"
  by (unfold_locales, auto)

lemma scene_comp_idem [simp]: "idem_scene S \<Longrightarrow> idem_scene (S ;\<^sub>S X)"
  by (transfer, unfold_locales, simp_all)

lemma scene_comp_lens_indep [simp]: "X \<bowtie> Y \<Longrightarrow> (A ;\<^sub>S X) \<bowtie>\<^sub>S (A ;\<^sub>S Y)"
  by (transfer, auto simp add: lens_indep.lens_put_comm lens_indep.lens_put_irr2)

lemma scene_comp_indep [simp]: "A \<bowtie>\<^sub>S B \<Longrightarrow> (A ;\<^sub>S X) \<bowtie>\<^sub>S (B ;\<^sub>S X)"
  by (transfer, auto)

lemma scene_comp_bot [simp]: "\<bottom>\<^sub>S ;\<^sub>S x = \<bottom>\<^sub>S"
  by (transfer, auto)

lemma scene_comp_id_lens [simp]: "A ;\<^sub>S 1\<^sub>L = A"
  by (transfer, auto, simp add: id_lens_def)

lemma scene_union_comp_distl: "a ##\<^sub>S b \<Longrightarrow> (a \<squnion>\<^sub>S b) ;\<^sub>S x = (a ;\<^sub>S x) \<squnion>\<^sub>S (b ;\<^sub>S x)"
  by (transfer, auto simp add: fun_eq_iff)

lemma scene_comp_assoc: "\<lbrakk> vwb_lens X; vwb_lens Y \<rbrakk> \<Longrightarrow> A ;\<^sub>S X ;\<^sub>S Y = A ;\<^sub>S (X ;\<^sub>L Y)"
  by (transfer, auto simp add: lens_comp_def fun_eq_iff)
     (metis comp_vwb_lens lens_comp_def)

lift_definition scene_quotient :: "'b scene \<Rightarrow> ('a \<Longrightarrow> 'b) \<Rightarrow> 'a scene" (infixl "'/\<^sub>S" 80)
is "\<lambda> S X a b. if (vwb_lens X \<and> (\<forall>s\<^sub>1 s\<^sub>2 s\<^sub>3. S (s\<^sub>1 \<triangleleft>\<^bsub>X\<^esub> s\<^sub>2) s\<^sub>3 = s\<^sub>1 \<triangleleft>\<^bsub>X\<^esub> S s\<^sub>2 s\<^sub>3)) then get\<^bsub>X\<^esub> (S (create\<^bsub>X\<^esub> a) (create\<^bsub>X\<^esub> b)) else a"
  by (unfold_locales, auto simp add: lens_create_def lens_override_def)
     (metis (no_types, lifting) overrider.ovr_overshadow_right)

lemma scene_quotient_idem: "idem_scene S \<Longrightarrow> idem_scene (S /\<^sub>S X)"
  by (transfer, unfold_locales, auto simp add: lens_create_def lens_override_def)
     (metis (no_types, lifting) overrider.ovr_overshadow_right)

lemma scene_quotient_indep: "A \<bowtie>\<^sub>S B \<Longrightarrow> (A /\<^sub>S X) \<bowtie>\<^sub>S (B /\<^sub>S X)"
  by (transfer, auto simp add: lens_create_def lens_override_def)

lemma scene_bot_quotient [simp]: "\<bottom>\<^sub>S /\<^sub>S X = \<bottom>\<^sub>S"
  by (transfer, auto)

lemma scene_comp_quotient: "vwb_lens X \<Longrightarrow> (A ;\<^sub>S X) /\<^sub>S X = A"
  by (transfer, auto simp add: fun_eq_iff lens_override_def)

lemma scene_quot_id_lens [simp]: "(A /\<^sub>S 1\<^sub>L) = A"
  by (transfer, simp, simp add: lens_defs)

subsection \<open> Linking Scenes and Lenses \<close>

text \<open> The following function extracts a scene from a very well behaved lens \<close>

lift_definition lens_scene :: "('v \<Longrightarrow> 's) \<Rightarrow> 's scene" ("\<lbrakk>_\<rbrakk>\<^sub>\<sim>") is
"\<lambda> X s\<^sub>1 s\<^sub>2. if (mwb_lens X) then s\<^sub>1 \<oplus>\<^sub>L s\<^sub>2 on X else s\<^sub>1"
  by (unfold_locales, auto simp add: lens_override_def)

lemma vwb_impl_idem_scene [simp]:
  "vwb_lens X \<Longrightarrow> idem_scene \<lbrakk>X\<rbrakk>\<^sub>\<sim>"
  by (transfer, unfold_locales, auto simp add: lens_override_overshadow_left lens_override_overshadow_right)

lemma idem_scene_impl_vwb:
  "\<lbrakk> mwb_lens X; idem_scene \<lbrakk>X\<rbrakk>\<^sub>\<sim> \<rbrakk> \<Longrightarrow> vwb_lens X"
  apply (cases "mwb_lens X")
   apply (transfer, unfold idem_overrider_def overrider_def, auto)
  apply (simp add: idem_overrider_axioms_def override_idem_implies_vwb)
  done

lemma lens_compat_scene: "\<lbrakk> mwb_lens X; mwb_lens Y \<rbrakk> \<Longrightarrow> X ##\<^sub>L Y \<longleftrightarrow> \<lbrakk>X\<rbrakk>\<^sub>\<sim> ##\<^sub>S \<lbrakk>Y\<rbrakk>\<^sub>\<sim>"
  by (auto simp add: lens_scene.rep_eq scene_compat.rep_eq lens_defs)

text \<open> Next we show some important congruence properties \<close>

lemma zero_lens_scene: "\<lbrakk>0\<^sub>L\<rbrakk>\<^sub>\<sim> = \<bottom>\<^sub>S"
  by (transfer, simp)

lemma one_lens_scene: "\<lbrakk>1\<^sub>L\<rbrakk>\<^sub>\<sim> = \<top>\<^sub>S"
  by (transfer, simp)

lemma scene_comp_top_scene [simp]: "vwb_lens x \<Longrightarrow> \<top>\<^sub>S ;\<^sub>S x = \<lbrakk>x\<rbrakk>\<^sub>\<sim>"
  by (transfer, simp add: fun_eq_iff lens_override_def)

lemma scene_comp_lens_scene_indep [simp]: "x \<bowtie> y \<Longrightarrow> \<lbrakk>x\<rbrakk>\<^sub>\<sim> \<bowtie>\<^sub>S a ;\<^sub>S y"
  by (transfer, simp add: lens_indep.lens_put_comm lens_indep.lens_put_irr2 lens_override_def)

lemma lens_scene_override:
  "mwb_lens X \<Longrightarrow> s\<^sub>1 \<oplus>\<^sub>S s\<^sub>2 on \<lbrakk>X\<rbrakk>\<^sub>\<sim> = s\<^sub>1 \<oplus>\<^sub>L s\<^sub>2 on X"
  by (transfer, simp)

lemma lens_indep_scene:
  assumes "vwb_lens X" "vwb_lens Y"
  shows "(X \<bowtie> Y) \<longleftrightarrow> \<lbrakk>X\<rbrakk>\<^sub>\<sim> \<bowtie>\<^sub>S \<lbrakk>Y\<rbrakk>\<^sub>\<sim>"
  using assms
  by (auto, (simp add: scene_indep_override, transfer, simp add: lens_indep_override_def)+)

lemma lens_indep_impl_scene_indep [simp]:
  "(X \<bowtie> Y) \<Longrightarrow> \<lbrakk>X\<rbrakk>\<^sub>\<sim> \<bowtie>\<^sub>S \<lbrakk>Y\<rbrakk>\<^sub>\<sim>"
  by (transfer, auto simp add: lens_indep_comm lens_override_def)

lemma get_scene_override_indep: "\<lbrakk> vwb_lens x; \<lbrakk>x\<rbrakk>\<^sub>\<sim> \<bowtie>\<^sub>S a \<rbrakk> \<Longrightarrow> get\<^bsub>x\<^esub> (s \<oplus>\<^sub>S s' on a) = get\<^bsub>x\<^esub> s"
proof -
  assume a1: "\<lbrakk>x\<rbrakk>\<^sub>\<sim> \<bowtie>\<^sub>S a"
  assume a2: "vwb_lens x"
  then have "\<forall>b ba bb. bb \<oplus>\<^sub>S b \<oplus>\<^sub>S ba on a on \<lbrakk>x\<rbrakk>\<^sub>\<sim> = bb \<oplus>\<^sub>S b on \<lbrakk>x\<rbrakk>\<^sub>\<sim>"
    using a1 by (metis idem_scene_uminus indep_then_compl_in scene_indep_sym scene_override_commute subscene_eliminate vwb_impl_idem_scene)
  then show ?thesis
    using a2 by (metis lens_override_def lens_scene_override mwb_lens_def vwb_lens_mwb weak_lens.put_get)
qed

lemma put_scene_override_indep:
  "\<lbrakk> vwb_lens x; \<lbrakk>x\<rbrakk>\<^sub>\<sim> \<bowtie>\<^sub>S a \<rbrakk> \<Longrightarrow> put\<^bsub>x\<^esub> s v \<oplus>\<^sub>S s' on a = put\<^bsub>x\<^esub> (s \<oplus>\<^sub>S s' on a) v"
  by (transfer, auto)
     (metis lens_override_def mwb_lens_weak vwb_lens_mwb weak_lens.put_get)

lemma get_scene_override_le: "\<lbrakk> vwb_lens x; \<lbrakk>x\<rbrakk>\<^sub>\<sim> \<le> a \<rbrakk> \<Longrightarrow> get\<^bsub>x\<^esub> (s \<oplus>\<^sub>S s' on a) = get\<^bsub>x\<^esub> s'"
  by (metis get_scene_override_indep scene_le_iff_indep_inv scene_override_commute)

lemma put_scene_override_le: "\<lbrakk> vwb_lens x; idem_scene a; \<lbrakk>x\<rbrakk>\<^sub>\<sim> \<le> a \<rbrakk> \<Longrightarrow>  put\<^bsub>x\<^esub> s v \<oplus>\<^sub>S s' on a = s \<oplus>\<^sub>S s' on a"
  by (metis lens_override_idem lens_override_put_right_in lens_scene_override sublens_refl subscene_eliminate vwb_lens_mwb)

lemma put_scene_override_le_distrib:
  "\<lbrakk> vwb_lens x; idem_scene A; \<lbrakk>x\<rbrakk>\<^sub>\<sim> \<le> A \<rbrakk> \<Longrightarrow> put\<^bsub>x\<^esub> (s\<^sub>1 \<oplus>\<^sub>S s\<^sub>2 on A) v = (put\<^bsub>x\<^esub> s\<^sub>1 v) \<oplus>\<^sub>S (put\<^bsub>x\<^esub> s\<^sub>2 v) on A"
  by (metis put_scene_override_indep put_scene_override_le scene_le_iff_indep_inv scene_override_commute)

lemma lens_plus_scene:
  "\<lbrakk> vwb_lens X; vwb_lens Y; X \<bowtie> Y \<rbrakk> \<Longrightarrow> \<lbrakk>X +\<^sub>L Y\<rbrakk>\<^sub>\<sim> = \<lbrakk>X\<rbrakk>\<^sub>\<sim> \<squnion>\<^sub>S \<lbrakk>Y\<rbrakk>\<^sub>\<sim>"
  by (transfer, auto simp add: lens_override_plus lens_indep_override_def lens_indep_overrideI)

lemma subscene_implies_sublens': "\<lbrakk> vwb_lens X; vwb_lens Y \<rbrakk> \<Longrightarrow> \<lbrakk>X\<rbrakk>\<^sub>\<sim> \<le> \<lbrakk>Y\<rbrakk>\<^sub>\<sim> \<longleftrightarrow> X \<subseteq>\<^sub>L' Y"
  by (simp add: lens_defs, transfer, simp add: lens_override_def)

lemma sublens'_implies_subscene: "\<lbrakk> vwb_lens X; vwb_lens Y; X \<subseteq>\<^sub>L' Y \<rbrakk> \<Longrightarrow> \<lbrakk>X\<rbrakk>\<^sub>\<sim> \<le> \<lbrakk>Y\<rbrakk>\<^sub>\<sim>"
  by (simp add: lens_defs, auto simp add: lens_override_def lens_scene_override)

lemma sublens_iff_subscene:
  assumes "vwb_lens X" "vwb_lens Y"
  shows "X \<subseteq>\<^sub>L Y \<longleftrightarrow> \<lbrakk>X\<rbrakk>\<^sub>\<sim> \<le> \<lbrakk>Y\<rbrakk>\<^sub>\<sim>"
  by (simp add: assms sublens_iff_sublens' subscene_implies_sublens')

lemma lens_scene_indep_compl [simp]:
  assumes "vwb_lens x" "vwb_lens y"
  shows "\<lbrakk>x\<rbrakk>\<^sub>\<sim> \<bowtie>\<^sub>S - \<lbrakk>y\<rbrakk>\<^sub>\<sim> \<longleftrightarrow> x \<subseteq>\<^sub>L y"
  by (simp add: assms scene_le_iff_indep_inv sublens_iff_subscene)

lemma lens_scene_comp: "\<lbrakk> vwb_lens X; vwb_lens Y \<rbrakk> \<Longrightarrow> \<lbrakk>X ;\<^sub>L Y\<rbrakk>\<^sub>\<sim> = \<lbrakk>X\<rbrakk>\<^sub>\<sim> ;\<^sub>S Y"
  by (transfer, simp add: fun_eq_iff comp_vwb_lens)
     (simp add: lens_comp_def lens_override_def)

lemma scene_comp_pres_indep: "\<lbrakk> idem_scene a; idem_scene b; a \<bowtie>\<^sub>S \<lbrakk>x\<rbrakk>\<^sub>\<sim> \<rbrakk> \<Longrightarrow> a \<bowtie>\<^sub>S b ;\<^sub>S x"
  by (transfer, auto)
     (metis (no_types, opaque_lifting) lens_override_def lens_override_idem vwb_lens_def wb_lens_weak weak_lens.put_get)

lemma scene_comp_le: "A ;\<^sub>S X \<le> \<lbrakk>X\<rbrakk>\<^sub>\<sim>"
  unfolding less_eq_scene_def by (transfer, auto simp add: fun_eq_iff lens_override_def)

lemma scene_quotient_comp: "\<lbrakk> vwb_lens X; idem_scene A; A \<le> \<lbrakk>X\<rbrakk>\<^sub>\<sim> \<rbrakk> \<Longrightarrow> (A /\<^sub>S X) ;\<^sub>S X = A"
  unfolding less_eq_scene_def
proof (transfer, simp add: fun_eq_iff, safe)
  fix Xa :: "'a \<Longrightarrow> 'b" and Aa :: "'b \<Rightarrow> 'b \<Rightarrow> 'b" and x :: 'b and xa :: 'b
  assume a1: "vwb_lens Xa"
  assume a2: "overrider Aa"
  assume a3: "idem_overrider Aa"
  assume a4: "\<forall>s\<^sub>1 s\<^sub>2 s\<^sub>3. Aa (s\<^sub>1 \<triangleleft>\<^bsub>Xa\<^esub> s\<^sub>2) s\<^sub>3 = s\<^sub>1 \<triangleleft>\<^bsub>Xa\<^esub> Aa s\<^sub>2 s\<^sub>3"
  have "\<And>b. Aa b b = b"
    using a3 by simp
  then have "Aa x (put\<^bsub>Xa\<^esub> src\<^bsub>Xa\<^esub> (get\<^bsub>Xa\<^esub> xa)) = Aa x xa"
    by (metis a2 a4 lens_override_def overrider.ovr_overshadow_right)
  then show "put\<^bsub>Xa\<^esub> x (get\<^bsub>Xa\<^esub> (Aa (create\<^bsub>Xa\<^esub> (get\<^bsub>Xa\<^esub> x)) (create\<^bsub>Xa\<^esub> (get\<^bsub>Xa\<^esub> xa)))) = Aa x xa"
    using a4 a1 by (metis lens_create_def lens_override_def vwb_lens_def wb_lens.get_put wb_lens_weak weak_lens.put_get)
qed

lemma lens_scene_quotient: "\<lbrakk> vwb_lens Y; X \<subseteq>\<^sub>L Y \<rbrakk> \<Longrightarrow> \<lbrakk>X /\<^sub>L Y\<rbrakk>\<^sub>\<sim> = \<lbrakk>X\<rbrakk>\<^sub>\<sim> /\<^sub>S Y"
  by (metis lens_quotient_comp lens_quotient_vwb lens_scene_comp scene_comp_quotient sublens_pres_vwb vwb_lens_def wb_lens_weak)

lemma scene_union_quotient: "\<lbrakk> A ##\<^sub>S B; A \<le> \<lbrakk>X\<rbrakk>\<^sub>\<sim>; B \<le> \<lbrakk>X\<rbrakk>\<^sub>\<sim> \<rbrakk> \<Longrightarrow> (A \<squnion>\<^sub>S B) /\<^sub>S X = (A /\<^sub>S X) \<squnion>\<^sub>S (B /\<^sub>S X)"
  unfolding less_eq_scene_def
  by (case_tac "vwb_lens X"; transfer, auto simp add: lens_create_def lens_override_def)

text \<open> Equality on scenes is sound and complete with respect to lens equivalence. \<close>

lemma lens_equiv_scene:
  assumes "vwb_lens X" "vwb_lens Y"
  shows "X \<approx>\<^sub>L Y \<longleftrightarrow> \<lbrakk>X\<rbrakk>\<^sub>\<sim> = \<lbrakk>Y\<rbrakk>\<^sub>\<sim>"
proof
  assume a: "X \<approx>\<^sub>L Y"
  show "\<lbrakk>X\<rbrakk>\<^sub>\<sim> = \<lbrakk>Y\<rbrakk>\<^sub>\<sim>"
    by (meson a assms lens_equiv_def sublens_iff_subscene subscene_antisym vwb_impl_idem_scene)
next
  assume b: "\<lbrakk>X\<rbrakk>\<^sub>\<sim> = \<lbrakk>Y\<rbrakk>\<^sub>\<sim>"
  show "X \<approx>\<^sub>L Y"
    by (simp add: assms b lens_equiv_def sublens_iff_subscene subscene_refl)
qed

lemma lens_scene_top_iff_bij_lens: "mwb_lens x \<Longrightarrow> \<lbrakk>x\<rbrakk>\<^sub>\<sim> = \<top>\<^sub>S \<longleftrightarrow> bij_lens x"
  apply (transfer)
  apply (auto simp add: fun_eq_iff lens_override_def)
  apply (unfold_locales)
   apply auto
  done

subsection \<open> Function Domain Scene \<close>

lift_definition fun_dom_scene :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b::two) scene" ("fds") is
"\<lambda> A f g. override_on f g A" by (unfold_locales, simp_all add: override_on_def fun_eq_iff)

lemma fun_dom_scene_empty: "fds({}) = \<bottom>\<^sub>S"
  by (transfer, simp)

lemma fun_dom_scene_union: "fds(A \<union> B) = fds(A) \<squnion>\<^sub>S fds(B)"
  by (transfer, auto simp add: fun_eq_iff override_on_def)

lemma fun_dom_scene_compl: "fds(- A) = - fds(A)"
  by (transfer, auto simp add: fun_eq_iff override_on_def)

lemma fun_dom_scene_inter: "fds(A \<inter> B) = fds(A) \<sqinter>\<^sub>S fds(B)"
  by (simp add: inf_scene_def fun_dom_scene_union[THEN sym] fun_dom_scene_compl[THEN sym])

lemma fun_dom_scene_UNIV: "fds(UNIV) = \<top>\<^sub>S"
  by (transfer, auto simp add: fun_eq_iff override_on_def)

lemma fun_dom_scene_indep [simp]:
  "fds(A) \<bowtie>\<^sub>S fds(B) \<longleftrightarrow> A \<inter> B = {}"
  by (transfer, auto simp add: override_on_def fun_eq_iff, meson two_diff)

lemma fun_dom_scene_always_compat [simp]: "fds(A) ##\<^sub>S fds(B)"
  by (transfer, simp add: override_on_def fun_eq_iff)

lemma fun_dom_scene_le [simp]: "fds(A) \<subseteq>\<^sub>S fds(B) \<longleftrightarrow> A \<subseteq> B"
  unfolding less_eq_scene_def
  by (transfer, auto simp add: override_on_def fun_eq_iff, meson two_diff)

text \<open> Hide implementation details for scenes \<close>

lifting_update scene.lifting
lifting_forget scene.lifting

end


section \<open>Terms and Literals\<close>

theory TermsAndLiterals imports Main "HOL-Library.Countable_Set" begin

type_synonym var_sym  = string
type_synonym fun_sym  = string
type_synonym pred_sym = string

datatype fterm =
  Fun fun_sym (get_sub_terms: "fterm list")
| Var var_sym

datatype hterm = HFun fun_sym "hterm list" \<comment> \<open>Herbrand terms defined as in Berghofer's FOL-Fitting\<close>

type_synonym 't atom = "pred_sym * 't list"

datatype 't literal =
  sign: Pos (get_pred: pred_sym) (get_terms: "'t list")
| Neg (get_pred: pred_sym) (get_terms: "'t list")

fun get_atom :: "'t literal \<Rightarrow> 't atom" where
  "get_atom (Pos p ts) = (p, ts)"
| "get_atom (Neg p ts) = (p, ts)"

subsection \<open>Ground\<close>

fun ground\<^sub>t :: "fterm \<Rightarrow> bool" where
  "ground\<^sub>t (Var x) \<longleftrightarrow> False"
| "ground\<^sub>t (Fun f ts) \<longleftrightarrow> (\<forall>t \<in> set ts. ground\<^sub>t t)"

abbreviation ground\<^sub>t\<^sub>s :: "fterm list \<Rightarrow> bool" where
  "ground\<^sub>t\<^sub>s ts \<equiv> (\<forall>t \<in> set ts. ground\<^sub>t t)"

abbreviation ground\<^sub>l :: "fterm literal \<Rightarrow> bool" where
  "ground\<^sub>l l \<equiv> ground\<^sub>t\<^sub>s (get_terms l)"

abbreviation ground\<^sub>l\<^sub>s :: "fterm literal set \<Rightarrow> bool" where
  "ground\<^sub>l\<^sub>s C \<equiv> (\<forall>l \<in> C. ground\<^sub>l l)"

definition ground_fatoms :: "fterm atom set" where
  "ground_fatoms \<equiv> {a. ground\<^sub>t\<^sub>s (snd a)}"

lemma ground\<^sub>l_ground_fatom:
  assumes "ground\<^sub>l l"
  shows "get_atom l \<in> ground_fatoms"
  using assms unfolding ground_fatoms_def by (induction l) auto

subsection \<open>Auxiliary\<close>

lemma inv_into_f_f:
  assumes "bij_betw f A B"
  assumes "a\<in>A"
  shows "(inv_into A f) (f a) = a"
using assms bij_betw_inv_into_left by metis

lemma f_inv_into_f:
  assumes "bij_betw f A B"
  assumes "b\<in>B"
  shows "f ((inv_into A f) b) = b"
using assms bij_betw_inv_into_right by metis

subsection \<open>Conversions\<close>

subsubsection \<open>Conversions - Terms and Herbrand Terms\<close>

fun fterm_of_hterm :: "hterm \<Rightarrow> fterm" where
  "fterm_of_hterm (HFun p ts) = Fun p (map fterm_of_hterm ts)"

definition fterms_of_hterms :: "hterm list \<Rightarrow> fterm list" where
  "fterms_of_hterms ts \<equiv> map fterm_of_hterm ts"

fun hterm_of_fterm :: "fterm \<Rightarrow> hterm" where
  "hterm_of_fterm (Fun p ts) = HFun p (map hterm_of_fterm ts)"

definition hterms_of_fterms :: "fterm list \<Rightarrow> hterm list" where
"hterms_of_fterms ts \<equiv> map hterm_of_fterm ts"

lemma hterm_of_fterm_fterm_of_hterm[simp]: "hterm_of_fterm (fterm_of_hterm t) = t"
  by (induction t) (simp add: map_idI)

lemma hterms_of_fterms_fterms_of_hterms[simp]: "hterms_of_fterms (fterms_of_hterms ts) = ts"
  unfolding hterms_of_fterms_def fterms_of_hterms_def by (simp add: map_idI)

lemma fterm_of_hterm_hterm_of_fterm[simp]:
  assumes "ground\<^sub>t t"
  shows "fterm_of_hterm (hterm_of_fterm t) = t"
  using assms by (induction t) (auto simp add: map_idI)

lemma fterms_of_hterms_hterms_of_fterms[simp]:
  assumes "ground\<^sub>t\<^sub>s ts"
  shows "fterms_of_hterms (hterms_of_fterms ts) = ts"
  using assms unfolding fterms_of_hterms_def hterms_of_fterms_def by (simp add: map_idI)

lemma ground_fterm_of_hterm:  "ground\<^sub>t (fterm_of_hterm t)"
  by (induction t) (auto simp add: map_idI)

lemma ground_fterms_of_hterms: "ground\<^sub>t\<^sub>s (fterms_of_hterms ts)"
  unfolding fterms_of_hterms_def using ground_fterm_of_hterm by auto

subsubsection \<open>Conversions -  Literals and Herbrand Literals\<close>

fun flit_of_hlit :: "hterm literal \<Rightarrow> fterm literal" where
  "flit_of_hlit (Pos p ts) = Pos p (fterms_of_hterms ts)"
| "flit_of_hlit (Neg p ts) = Neg p (fterms_of_hterms ts)"

fun hlit_of_flit :: "fterm literal \<Rightarrow> hterm literal" where
  "hlit_of_flit (Pos p ts) = Pos p (hterms_of_fterms ts)"
| "hlit_of_flit (Neg p ts) = Neg p (hterms_of_fterms ts)"

lemma ground_flit_of_hlit: "ground\<^sub>l (flit_of_hlit l)"
  by  (induction l)  (simp add: ground_fterms_of_hterms)+

theorem flit_of_hlit_hlit_of_flit [simp]:
  assumes "ground\<^sub>l l"
  shows "flit_of_hlit (hlit_of_flit l) = l"
  using assms by (cases l) auto

lemma sign_flit_of_hlit: "sign (flit_of_hlit l) = sign l" by (cases l) auto

lemma hlit_of_flit_bij: "bij_betw hlit_of_flit {l. ground\<^sub>l l} UNIV"
 unfolding bij_betw_def
proof
  show "inj_on hlit_of_flit {l. ground\<^sub>l l}" using inj_on_inverseI flit_of_hlit_hlit_of_flit
    by (metis (mono_tags, lifting) mem_Collect_eq)
next
  have "\<forall>l. \<exists>l'. ground\<^sub>l l' \<and> l = hlit_of_flit l'"
    using ground_flit_of_hlit hlit_of_flit_flit_of_hlit by metis
  then show "hlit_of_flit ` {l. ground\<^sub>l l} = UNIV" by auto
qed

lemma flit_of_hlit_bij: "bij_betw flit_of_hlit UNIV {l. ground\<^sub>l l}"
 unfolding bij_betw_def inj_on_def
proof
  show "\<forall>x\<in>UNIV. \<forall>y\<in>UNIV. flit_of_hlit x = flit_of_hlit y \<longrightarrow> x = y"
    using ground_flit_of_hlit hlit_of_flit_flit_of_hlit by metis
next
  have "\<forall>l. ground\<^sub>l l \<longrightarrow> (l = flit_of_hlit (hlit_of_flit l))" using hlit_of_flit_flit_of_hlit by auto
  then have "{l. ground\<^sub>l l}  \<subseteq> flit_of_hlit ` UNIV " by blast
  moreover
  have "\<forall>l. ground\<^sub>l (flit_of_hlit l)" using ground_flit_of_hlit by auto
  ultimately show "flit_of_hlit ` UNIV = {l. ground\<^sub>l l}" using hlit_of_flit_flit_of_hlit ground_flit_of_hlit by auto
qed

subsubsection \<open>Conversions - Atoms and Herbrand Atoms\<close>

fun fatom_of_hatom :: "hterm atom \<Rightarrow> fterm atom" where
  "fatom_of_hatom (p, ts) = (p, fterms_of_hterms ts)"

fun hatom_of_fatom :: "fterm atom \<Rightarrow> hterm atom" where
  "hatom_of_fatom (p, ts) = (p, hterms_of_fterms ts)"

lemma ground_fatom_of_hatom: "ground\<^sub>t\<^sub>s (snd (fatom_of_hatom a))"
  by  (induction a) (simp add: ground_fterms_of_hterms)+

theorem hatom_of_fatom_fatom_of_hatom [simp]: "hatom_of_fatom (fatom_of_hatom l) = l"
  by (cases l) auto

theorem fatom_of_hatom_hatom_of_fatom [simp]:
  assumes "ground\<^sub>t\<^sub>s (snd l)"
  shows "fatom_of_hatom (hatom_of_fatom l) = l"
  using assms by (cases l) auto

lemma hatom_of_fatom_bij: "bij_betw hatom_of_fatom ground_fatoms UNIV"
 unfolding bij_betw_def
proof
  show "inj_on hatom_of_fatom ground_fatoms" using inj_on_inverseI fatom_of_hatom_hatom_of_fatom unfolding ground_fatoms_def
    by (metis (mono_tags, lifting) mem_Collect_eq)
next
  have "\<forall>a. \<exists>a'. ground\<^sub>t\<^sub>s (snd a') \<and> a = hatom_of_fatom a'"
    using ground_fatom_of_hatom hatom_of_fatom_fatom_of_hatom by metis
  then show "hatom_of_fatom ` ground_fatoms = UNIV" unfolding ground_fatoms_def by blast
qed

lemma fatom_of_hatom_bij: "bij_betw fatom_of_hatom UNIV ground_fatoms"
 unfolding bij_betw_def inj_on_def
proof
  show "\<forall>x\<in>UNIV. \<forall>y\<in>UNIV. fatom_of_hatom x = fatom_of_hatom y \<longrightarrow> x = y"
    using ground_fatom_of_hatom hatom_of_fatom_fatom_of_hatom by metis
next
  have "\<forall>a. ground\<^sub>t\<^sub>s (snd a) \<longrightarrow> (a = fatom_of_hatom (hatom_of_fatom a))" using hatom_of_fatom_fatom_of_hatom by auto
  then have "ground_fatoms  \<subseteq> fatom_of_hatom ` UNIV " unfolding ground_fatoms_def by blast
  moreover
  have "\<forall>l. ground\<^sub>t\<^sub>s (snd (fatom_of_hatom l))" using ground_fatom_of_hatom by auto
  ultimately show "fatom_of_hatom ` UNIV = ground_fatoms"
    using hatom_of_fatom_fatom_of_hatom ground_fatom_of_hatom unfolding ground_fatoms_def by auto
qed

subsection \<open>Enumerations\<close>

subsubsection \<open>Enumerating Strings\<close>

definition nat_of_string:: "string \<Rightarrow> nat" where
  "nat_of_string \<equiv> (SOME f. bij f)"

definition string_of_nat:: "nat \<Rightarrow> string" where
  "string_of_nat \<equiv> inv nat_of_string"

lemma nat_of_string_bij: "bij nat_of_string"
  proof -
  have "countable (UNIV::string set)" by auto
  moreover
  have "infinite (UNIV::string set)" using infinite_UNIV_listI by auto
  ultimately
  obtain x where "bij (x:: string \<Rightarrow> nat)" using countableE_infinite[of UNIV] by blast
  then show "?thesis" unfolding nat_of_string_def using someI by metis
qed

lemma string_of_nat_bij: "bij string_of_nat" unfolding string_of_nat_def using nat_of_string_bij bij_betw_inv_into by auto

lemma nat_of_string_string_of_nat[simp]: "nat_of_string (string_of_nat n) = n"
  unfolding string_of_nat_def
  using nat_of_string_bij f_inv_into_f[of nat_of_string] by simp

lemma string_of_nat_nat_of_string[simp]: "string_of_nat (nat_of_string n) = n"
  unfolding string_of_nat_def
  using nat_of_string_bij inv_into_f_f[of nat_of_string] by simp

subsubsection \<open>Enumerating Herbrand Atoms\<close>

definition nat_of_hatom:: "hterm atom \<Rightarrow> nat" where
  "nat_of_hatom \<equiv> (SOME f. bij f)"

definition hatom_of_nat:: "nat \<Rightarrow> hterm atom" where
  "hatom_of_nat \<equiv> inv nat_of_hatom"

instantiation hterm :: countable begin
instance by countable_datatype
end

lemma infinite_hatoms: "infinite (UNIV :: ('t atom) set)"
proof -
  let ?diago = "\<lambda>n. (string_of_nat n,[])"
  let ?undiago = "\<lambda>a. nat_of_string (fst a)"
  have "\<forall>n. ?undiago (?diago n) = n" using nat_of_string_string_of_nat by auto
  moreover
  have "\<forall>n. ?diago n \<in> UNIV" by auto
  ultimately show "infinite (UNIV :: ('t atom) set)" using infinity[of ?undiago ?diago UNIV] by simp
qed

lemma nat_of_hatom_bij: "bij nat_of_hatom"
proof -
  let ?S = "UNIV :: (('t::countable) atom) set"
  have "countable ?S" by auto
  moreover
  have "infinite ?S" using infinite_hatoms by auto
  ultimately
  obtain x where "bij (x :: hterm atom \<Rightarrow> nat)" using countableE_infinite[of ?S] by blast
  then have "bij nat_of_hatom" unfolding nat_of_hatom_def using someI by metis
  then show "?thesis" unfolding bij_betw_def inj_on_def unfolding nat_of_hatom_def by simp
qed

lemma hatom_of_nat_bij: "bij hatom_of_nat" unfolding hatom_of_nat_def using nat_of_hatom_bij bij_betw_inv_into by auto

lemma nat_of_hatom_hatom_of_nat[simp]: "nat_of_hatom (hatom_of_nat n) = n"
  unfolding hatom_of_nat_def
  using nat_of_hatom_bij f_inv_into_f[of nat_of_hatom] by simp

lemma hatom_of_nat_nat_of_hatom[simp]: "hatom_of_nat (nat_of_hatom l) = l"
  unfolding hatom_of_nat_def
  using nat_of_hatom_bij inv_into_f_f[of nat_of_hatom _ UNIV] by simp

subsubsection \<open>Enumerating Ground Atoms\<close>

definition fatom_of_nat :: "nat \<Rightarrow> fterm atom" where
  "fatom_of_nat = (\<lambda>n. fatom_of_hatom (hatom_of_nat n))"

definition nat_of_fatom :: "fterm atom \<Rightarrow> nat" where
  "nat_of_fatom = (\<lambda>t. nat_of_hatom (hatom_of_fatom t))"

theorem diag_undiag_fatom[simp]:
  assumes "ground\<^sub>t\<^sub>s ts"
  shows "fatom_of_nat (nat_of_fatom (p,ts)) = (p,ts)"
using assms unfolding fatom_of_nat_def nat_of_fatom_def by auto

theorem undiag_diag_fatom[simp]: "nat_of_fatom (fatom_of_nat n) = n" unfolding fatom_of_nat_def nat_of_fatom_def by auto

lemma fatom_of_nat_bij: "bij_betw fatom_of_nat UNIV ground_fatoms"
  using hatom_of_nat_bij bij_betw_trans fatom_of_hatom_bij hatom_of_nat_bij unfolding fatom_of_nat_def comp_def by blast

lemma ground_fatom_of_nat: "ground\<^sub>t\<^sub>s (snd (fatom_of_nat x))" unfolding fatom_of_nat_def using ground_fatom_of_hatom by auto

lemma nat_of_fatom_bij: "bij_betw nat_of_fatom ground_fatoms UNIV"
   using nat_of_hatom_bij bij_betw_trans hatom_of_fatom_bij hatom_of_nat_bij unfolding nat_of_fatom_def comp_def by blast

end


section Substitution

text \<open>This theory introduces the substitution operation using a locale, and provides two models.\<close>

theory Substitution
  imports Renaming
begin

subsection Definition

locale substitution =
  fixes subst :: "('r,'l,'v) expr \<Rightarrow> 'v \<Rightarrow> ('r,'l,'v) expr \<Rightarrow> ('r,'l,'v) expr"
  assumes
    renaming_distr_subst: "\<R>\<^sub>E \<alpha> \<beta> (subst e x e') = subst (\<R>\<^sub>E \<alpha> \<beta> e) x (\<R>\<^sub>E \<alpha> \<beta> e')" and (* needed in mimicking *)
    subst_introduces_no_rids: "RID\<^sub>E (subst e x e') \<subseteq> RID\<^sub>E e \<union> RID\<^sub>E e'" and
    subst_introduces_no_lids: "LID\<^sub>E (subst e x e') \<subseteq> LID\<^sub>E e \<union> LID\<^sub>E e'"
begin

lemma rid_substE [dest]: "r \<in> RID\<^sub>E (subst (VE v) x e) \<Longrightarrow> r \<notin> RID\<^sub>E e \<Longrightarrow> r \<in> RID\<^sub>V v"
  using subst_introduces_no_rids by fastforce

lemma lid_substE [dest]: "l \<in> LID\<^sub>E (subst (VE v) x e) \<Longrightarrow> l \<notin> LID\<^sub>E e \<Longrightarrow> l \<in> LID\<^sub>V v"
  using subst_introduces_no_lids by fastforce

end (* substitution locale *)

subsection \<open>Trivial model\<close>

fun constant_function :: "('r,'l,'v) expr \<Rightarrow> 'v \<Rightarrow> ('r,'l,'v) expr \<Rightarrow> ('r,'l,'v) expr" where
  "constant_function e x e' = VE (CV Unit)"

lemma constant_function_models_substitution:
  "substitution constant_function" by (auto simp add: substitution_def)

subsection \<open>Example model\<close>

subsubsection Preliminaries

notation set3_val ("\<V>\<^sub>V")
notation set3_expr ("\<V>\<^sub>E")

abbreviation rename_vars_val :: "('v \<Rightarrow> 'v) \<Rightarrow> ('r,'l,'v) val \<Rightarrow> ('r,'l,'v) val" ("\<R>\<V>\<^sub>V") where
  "\<R>\<V>\<^sub>V \<zeta> \<equiv> map_val id id \<zeta>"

abbreviation rename_vars_expr :: "('v \<Rightarrow> 'v) \<Rightarrow> ('r,'l,'v) expr \<Rightarrow> ('r,'l,'v) expr" ("\<R>\<V>\<^sub>E") where
  "\<R>\<V>\<^sub>E \<zeta> \<equiv> map_expr id id \<zeta>"

lemma var_renaming_preserves_size: (* for termination proof *)
  fixes
    v :: "('r,'l,'v) val" and
    e :: "('r,'l,'v) expr" and
    \<alpha> :: "'r \<Rightarrow> 'r'" and
    \<beta> :: "'l \<Rightarrow> 'l'" and
    \<zeta> :: "'v \<Rightarrow> 'v'"
  shows
  "size (map_val \<alpha> \<beta> \<zeta> v) = size v"
  "size (map_expr \<alpha> \<beta> \<zeta> e) = size e"
proof -
  have "(\<forall>(\<alpha> :: 'r \<Rightarrow> 'r') (\<beta> :: 'l \<Rightarrow> 'l') (\<zeta> :: 'v \<Rightarrow> 'v'). size (map_val \<alpha> \<beta> \<zeta> v) = size v) \<and>
        (\<forall>(\<alpha> :: 'r \<Rightarrow> 'r') (\<beta> :: 'l \<Rightarrow> 'l') (\<zeta> :: 'v \<Rightarrow> 'v'). size (map_expr \<alpha> \<beta> \<zeta> e) = size e)"
    by (induct rule: val_expr.induct) auto
  thus
    "size (map_val \<alpha> \<beta> \<zeta> v) = size v"
    "size (map_expr \<alpha> \<beta> \<zeta> e) = size e"
    by auto
qed

subsubsection Definition

function
  nat_subst\<^sub>V :: "('r,'l,nat) expr \<Rightarrow> nat \<Rightarrow> ('r,'l,nat) val \<Rightarrow> ('r,'l,nat) expr" and
  nat_subst\<^sub>E :: "('r,'l,nat) expr \<Rightarrow> nat \<Rightarrow> ('r,'l,nat) expr \<Rightarrow> ('r,'l,nat) expr"
  where
  "nat_subst\<^sub>V e x (CV const) = VE (CV const)"
| "nat_subst\<^sub>V e x (Var x') = (if x = x' then e else VE (Var x'))"
| "nat_subst\<^sub>V e x (Loc l) = VE (Loc l)"
| "nat_subst\<^sub>V e x (Rid r) = VE (Rid r)"
| "nat_subst\<^sub>V e x (Lambda y e') = VE (
  if x = y then
    Lambda y e'
  else
    let z = Suc (Max (\<V>\<^sub>E e' \<union> \<V>\<^sub>E e)) in
    Lambda z (nat_subst\<^sub>E e x (\<R>\<V>\<^sub>E (id(y := z)) e')))"
| "nat_subst\<^sub>E e x (VE v') = nat_subst\<^sub>V e x v'"
| "nat_subst\<^sub>E e x (Apply l r) = Apply (nat_subst\<^sub>E e x l) (nat_subst\<^sub>E e x r)"
| "nat_subst\<^sub>E e x (Ite e1 e2 e3) = Ite (nat_subst\<^sub>E e x e1) (nat_subst\<^sub>E e x e2) (nat_subst\<^sub>E e x e3)"
| "nat_subst\<^sub>E e x (Ref e') = Ref (nat_subst\<^sub>E e x e')"
| "nat_subst\<^sub>E e x (Read e') = Read (nat_subst\<^sub>E e x e')"
| "nat_subst\<^sub>E e x (Assign l r) = Assign (nat_subst\<^sub>E e x l) (nat_subst\<^sub>E e x r)"
| "nat_subst\<^sub>E e x (Rfork e') = Rfork (nat_subst\<^sub>E e x e')"
| "nat_subst\<^sub>E e x (Rjoin e')  = Rjoin (nat_subst\<^sub>E e x e')"
  by pat_completeness auto
termination
  by (relation "measure (\<lambda>x. case x of Inl (e,x,v) \<Rightarrow> size v | Inr (e,x,e') \<Rightarrow> size e')")
     (auto simp add: var_renaming_preserves_size(2))

subsubsection \<open>Proof obligations\<close>

lemma nat_subst\<^sub>E_distr:
  fixes e :: "('r,'l,nat) expr"
  shows "\<R>\<^sub>E \<alpha> \<beta> (nat_subst\<^sub>E e x e') = nat_subst\<^sub>E (\<R>\<^sub>E \<alpha> \<beta> e) x (\<R>\<^sub>E \<alpha> \<beta> e')"
proof -
  fix v' :: "('r,'l,nat) val"
  have
    "(\<forall>\<alpha> \<beta> x e \<zeta>. \<R>\<^sub>E \<alpha> \<beta> (nat_subst\<^sub>V e x (\<R>\<V>\<^sub>V \<zeta> v')) = nat_subst\<^sub>V (\<R>\<^sub>E \<alpha> \<beta> e) x (\<R>\<^sub>V \<alpha> \<beta> (\<R>\<V>\<^sub>V \<zeta> v'))) \<and>
     (\<forall>\<alpha> \<beta> x e \<zeta>. \<R>\<^sub>E \<alpha> \<beta> (nat_subst\<^sub>E e x (\<R>\<V>\<^sub>E \<zeta> e')) = nat_subst\<^sub>E (\<R>\<^sub>E \<alpha> \<beta> e) x (\<R>\<^sub>E \<alpha> \<beta> (\<R>\<V>\<^sub>E \<zeta> e')))"
    by (induct rule: val_expr.induct) (auto simp add: expr.set_map(3) fun.map_ident)
  hence "\<R>\<^sub>E \<alpha> \<beta> (nat_subst\<^sub>E e x (\<R>\<V>\<^sub>E id e')) = nat_subst\<^sub>E (\<R>\<^sub>E \<alpha> \<beta> e) x (\<R>\<^sub>E \<alpha> \<beta> (\<R>\<V>\<^sub>E id e'))" by blast
  thus ?thesis by simp
qed

lemma nat_subst\<^sub>E_introduces_no_rids:
  fixes e' :: "('r,'l,nat) expr"
  shows "RID\<^sub>E (nat_subst\<^sub>E e x e') \<subseteq> RID\<^sub>E e \<union> RID\<^sub>E e'"
proof -
  fix v' :: "('r,'l,nat) val"
  have
    "(\<forall>x e. \<forall>\<zeta>. RID\<^sub>E (nat_subst\<^sub>V e x (\<R>\<V>\<^sub>V \<zeta> v')) \<subseteq> RID\<^sub>E e \<union> RID\<^sub>V (\<R>\<V>\<^sub>V \<zeta> v')) \<and>
     (\<forall>x e. \<forall>\<zeta>. RID\<^sub>E (nat_subst\<^sub>E e x (\<R>\<V>\<^sub>E \<zeta> e')) \<subseteq> RID\<^sub>E e \<union> RID\<^sub>E (\<R>\<V>\<^sub>E \<zeta> e'))"
    by (induct rule: val_expr.induct) (auto 0 4 simp add: expr.set_map(1))
  hence "RID\<^sub>E (nat_subst\<^sub>E e x (\<R>\<V>\<^sub>E id e')) \<subseteq> RID\<^sub>E e \<union> RID\<^sub>E (\<R>\<V>\<^sub>E id e')" by blast
  thus ?thesis by simp
qed

lemma nat_subst\<^sub>E_introduces_no_lids:
  fixes e' :: "('r,'l,nat) expr"
  shows "LID\<^sub>E (nat_subst\<^sub>E e x e') \<subseteq> LID\<^sub>E e \<union> LID\<^sub>E e'"
proof -
  fix v' :: "('r,'l,nat) val"
  have
    "(\<forall>x e. \<forall>\<zeta>. LID\<^sub>E (nat_subst\<^sub>V e x (\<R>\<V>\<^sub>V \<zeta> v')) \<subseteq> LID\<^sub>E e \<union> LID\<^sub>V (\<R>\<V>\<^sub>V \<zeta> v')) \<and>
     (\<forall>x e. \<forall>\<zeta>. LID\<^sub>E (nat_subst\<^sub>E e x (\<R>\<V>\<^sub>E \<zeta> e')) \<subseteq> LID\<^sub>E e \<union> LID\<^sub>E (\<R>\<V>\<^sub>E \<zeta> e'))"
    by (induct rule: val_expr.induct) (auto 0 4 simp add: expr.set_map(2))
  hence "LID\<^sub>E (nat_subst\<^sub>E e x (\<R>\<V>\<^sub>E id e')) \<subseteq> LID\<^sub>E e \<union> LID\<^sub>E (\<R>\<V>\<^sub>E id e')" by blast
  thus ?thesis by simp
qed

lemma nat_subst\<^sub>E_models_substitution: "substitution nat_subst\<^sub>E"
  by (simp add: nat_subst\<^sub>E_distr nat_subst\<^sub>E_introduces_no_lids nat_subst\<^sub>E_introduces_no_rids substitution_def)

end


theory Concrete_Semantics_7_3
  imports Main "~~/src/HOL/IMP/Com" "HOL-IMP.Star" "HOL-IMP.Big_Step"
begin
(* 7.3 Small-Step Semantics *)

inductive
  small_step :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>" 55)
where
Assign:   "(x ::= a,s) \<rightarrow> (SKIP, s(x := aval a s))" |
Seq1:     "(SKIP;;c, s) \<rightarrow> (c, s)"|
Seq2:     "(c\<^sub>1,s) \<rightarrow> (c\<^sub>1',s') \<Longrightarrow> (c\<^sub>1;;c2,s) \<rightarrow> (c\<^sub>1';;c2,s')" |
IfTrue:   "bval b s  \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<rightarrow> (c\<^sub>1, s)" |
IfFalse:  "\<not>bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<rightarrow> (c\<^sub>2, s)" |
While:    "(WHILE b DO c,s) \<rightarrow>
              (IF b THEN c;; WHILE b DO c ELSE SKIP, s)"

(* abbreviation "\<rightarrow>*":: "com * state \<Rightarrow> com * state \<Rightarrow> bool" where
"x \<rightarrow>* y \<equiv> star small_step x y" *)

abbreviation
  small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
  where "x \<rightarrow>* y == star small_step x y"

code_pred small_step .

values "{(c',map t [''x'',''y'',''z'']) |c' t.
   (''x'' ::= V ''z'';; ''y'' ::= V ''x'',
    <''x'' := 3, ''y'' := 7, ''z'' := 5>) \<rightarrow>* (c',t)}"

lemmas small_step_induct = small_step.induct[split_format(complete)]

(*why simp is needed?
Where simp is used? *)
declare small_step.intros[simp,intro]

inductive_cases SkipE[elim!]: "(SKIP,s) \<rightarrow> ct"
thm SkipE
inductive_cases AssignE[elim!]: "(x::=a,s) \<rightarrow> ct"
thm AssignE
inductive_cases SeqE[elim]: "(c1;;c2,s) \<rightarrow> ct"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<rightarrow> ct"
inductive_cases WhileE[elim]: "(WHILE b DO c, s) \<rightarrow> ct"

lemma deterministic:
  "\<lbrakk>cs \<rightarrow> cs'; cs \<rightarrow> cs''\<rbrakk> \<Longrightarrow> cs'' = cs'"
  apply(induction arbitrary:cs'' rule: small_step.induct)
       apply(blast+)
  done

(* not 'star.induct' *)
lemma star_seq2: "(c1,s) \<rightarrow>* (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow>* (c1';;c2,s')"
proof(induction rule: star_induct)
  case (refl x)
  then show ?case by simp
next
  case (step x y z)
  then show ?case
    by (meson Seq2 star.simps)

qed

lemma seq_comp:
  "\<lbrakk> (c1,s1) \<rightarrow>* (SKIP,s2); (c2,s2) \<rightarrow>* (SKIP,s3) \<rbrakk>
   \<Longrightarrow> (c1;;c2, s1) \<rightarrow>* (SKIP,s3)"
  by (meson Seq1 star.step star_seq2 star_trans)

lemma big_to_small:
  "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* (SKIP,t)"
proof(induction rule: big_step.induct)
  case (Skip s)
  then show ?case
    by simp
next
  case (Assign x a s)
  then show ?case
    by blast
next
  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
  then show ?case
    by (meson Seq1 star_seq2 star_step1 star_trans)
next
  case (IfTrue b s c\<^sub>1 t c\<^sub>2)
  then show ?case
    by (meson small_step.IfTrue star.step)
next
  case (IfFalse b s c\<^sub>2 t c\<^sub>1)
  then show ?case
    by (meson small_step.IfFalse star.step)
next
  case (WhileFalse b s c)
  then show ?case
    by (metis star.step star_step1 small_step.IfFalse small_step.While)
    (* by (meson While small_step.IfFalse star.simps) *)
next
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
  then show ?case
    by (metis (no_types, lifting) While seq_comp small_step.IfTrue star.simps)
qed

lemma small1_big_continue:
  "cs \<rightarrow> cs' \<Longrightarrow> cs' \<Rightarrow> t \<Longrightarrow> cs \<Rightarrow> t"
  proof(induction arbitrary: t rule: small_step.induct)
case (Assign x a s)
  then show ?case
    by auto
next
case (Seq1 c s)
  then show ?case
    by auto
next
  case (Seq2 c\<^sub>1 s c\<^sub>1' s' c2)
  then show ?case
    by blast
next
  case (IfTrue b s c\<^sub>1 c\<^sub>2)
  then show ?case
    by (simp add: big_step.IfTrue)
next
  case (IfFalse b s c\<^sub>1 c\<^sub>2)
  then show ?case
    by (simp add: big_step.IfFalse)
next
  case (While b c s)
  then show ?case
    by (simp add: while_unfold)
qed

lemma small_to_big:
  "cs \<rightarrow>* (SKIP,t) \<Longrightarrow> cs \<Rightarrow> t"
proof(induction cs "(SKIP, t)"rule: star.induct)
  case refl
  then show ?case
    by (simp add: Skip)
next
  case (step x y)
  then show ?case
    using small1_big_continue by auto
qed

theorem big_iff_small:
  "cs \<Rightarrow> t = cs \<rightarrow>* (SKIP,t)"

  using big_to_small small_to_big by blast

definition final :: "com * state \<Rightarrow> bool"where
"final cs \<longleftrightarrow> \<not>(\<exists> cs'. cs \<rightarrow> cs')"

lemma finalD: "final (c,s) \<Longrightarrow> c = SKIP"
proof(induction c)
  case SKIP
  then show ?case
    by simp
next
  case (Assign x1 x2)
  then show ?case
    using final_def by auto
next
  case (Seq c1 c2)
  then show ?case
    using final_def by auto
next
  case (If x1 c1 c2)
  then show ?case
    by (meson final_def small_step.IfFalse small_step.IfTrue)
next
  case (While x1 c)
  then show ?case
    using final_def by auto
qed

lemma big_iff_small_termination:
  "(\<exists>t. cs \<Rightarrow> t) \<longleftrightarrow> (\<exists>cs'. cs \<rightarrow>* cs' \<and> final cs')"
proof(induction cs)
case (Pair a b)
  then show ?case
    by (metis (full_types) Concrete_Semantics_7_3.SkipE big_to_small finalD final_def old.prod.exhaust small_to_big)
qed

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
header {* \isaheader{DFS Implementation by Hashset} *}
theory Exploration_DFS
imports Exploration
begin
text_raw {*\label{thy:Exploration_Example}*}

text {*
  This theory implements the DFS-algorithm by using a hashset to remember the
  explored states. It illustrates how to use data refinement with the Isabelle Collections
  Framework in a realistic, non-trivial application.
*}

subsection "Definitions"
-- {*
  The concrete algorithm uses a hashset (@{typ [source] "'q hs"}) and a worklist.
*}
type_synonym 'q hs_dfs_state = "'q hs \<times> 'q list"

-- {* The loop terminates on empty worklist *}
definition hs_dfs_cond :: "'q hs_dfs_state \<Rightarrow> bool"
  where "hs_dfs_cond S == let (Q,W) = S in W\<noteq>[]"

-- {* Refinement of a DFS-step, using hashset operations *}
definition hs_dfs_step
  :: "('q::hashable \<Rightarrow> 'q ls) \<Rightarrow> 'q hs_dfs_state \<Rightarrow> 'q hs_dfs_state"
  where "hs_dfs_step post S == let
    (Q,W) = S;
    \<sigma>=hd W
  in
    ls.iteratei (post \<sigma>) (\<lambda>_. True) (\<lambda>x (Q,W).
      if hs.memb x Q then
        (Q,W)
      else (hs.ins x Q,x#W)
      )
      (Q, tl W)
  "

-- {* Convert post-function to relation *}
definition hs_R :: "('q \<Rightarrow> 'q ls) \<Rightarrow> ('q\<times>'q) set"
  where "hs_R post == {(q,q'). q'\<in>ls.\<alpha> (post q)}"

-- {* Initial state: Set of initial states in discovered set and on worklist *}
definition hs_dfs_initial :: "'q::hashable hs \<Rightarrow> 'q hs_dfs_state"
  where "hs_dfs_initial \<Sigma>i == (\<Sigma>i,hs.to_list \<Sigma>i)"

-- {* Abstraction mapping to abstract-DFS state *}
definition hs_dfs_\<alpha> :: "'q::hashable hs_dfs_state \<Rightarrow> 'q dfs_state"
  where "hs_dfs_\<alpha> S == let (Q,W)=S in (hs.\<alpha> Q,W)"

(*-- {* Additional invariant on concrete level: The hashset invariant must hold *}
definition hs_dfs_invar_add :: "'q::hashable hs_dfs_state set"
  where "hs_dfs_invar_add == { (Q,W). hs_invar Q }"*)

-- {* Combined concrete and abstract level invariant *}
definition hs_dfs_invar
  :: "'q::hashable hs \<Rightarrow> ('q \<Rightarrow> 'q ls) \<Rightarrow> 'q hs_dfs_state set"
  where "hs_dfs_invar \<Sigma>i post ==
    { s. (hs_dfs_\<alpha> s) \<in> dfs_invar (hs.\<alpha> \<Sigma>i) (hs_R post) }"

-- "The deterministic while-algorithm"
definition "hs_dfs_dwa \<Sigma>i post == \<lparr>
  dwa_cond = hs_dfs_cond,
  dwa_step = hs_dfs_step post,
  dwa_initial = hs_dfs_initial \<Sigma>i,
  dwa_invar = hs_dfs_invar \<Sigma>i post
\<rparr>"

-- "Executable DFS-search. Given a set of initial states, and a successor
      function, this function performs a DFS search to return the set of
      reachable states."
definition "hs_dfs \<Sigma>i post
  == fst (while hs_dfs_cond (hs_dfs_step post) (hs_dfs_initial \<Sigma>i))"

subsection "Refinement"

text {* We first show that a concrete step implements its abstract specification, and preserves the
  additional concrete invariant *}
lemma hs_dfs_step_correct:
  (*assumes [simp]: "hs_invar Q"
                  "!!s. ls_invar (post s)"*)
  assumes ne: "hs_dfs_cond (Q,W)"
  shows "(hs_dfs_\<alpha> (Q,W),hs_dfs_\<alpha> (hs_dfs_step post (Q,W)))
         \<in>dfs_step (hs_R post)" (is ?T1)
        (*"(hs_dfs_step post (Q,W)) \<in> hs_dfs_invar_add" (is ?T2)*)
proof -

  from ne obtain \<sigma> Wtl where
    [simp]: "W=\<sigma>#Wtl"
    by (cases W) (auto simp add: hs_dfs_cond_def)

  have G: "let (Q',W') = hs_dfs_step post (Q,W) in
    hs.invar Q' \<and> (\<exists>Wn.
      distinct Wn
      \<and> set Wn = ls.\<alpha> (post \<sigma>) - hs.\<alpha> Q
      \<and> W'=Wn@Wtl
      \<and> hs.\<alpha> Q'=ls.\<alpha> (post \<sigma>) \<union> hs.\<alpha> Q)"
    apply (simp add: hs_dfs_step_def)
    apply (rule_tac
      I="\<lambda>it (Q',W'). hs.invar Q' \<and> (\<exists>Wn.
           distinct Wn
           \<and> set Wn = (ls.\<alpha> (post \<sigma>) - it) - hs.\<alpha> Q
           \<and> W'=Wn@Wtl
           \<and> hs.\<alpha> Q'=(ls.\<alpha> (post \<sigma>) - it) \<union> hs.\<alpha> Q)"
      in ls.iterate_rule_P)
    apply simp
    apply simp
    apply (force split: split_if_asm simp add: hs.correct)
    apply force
    done
  from G show ?T1
    apply (cases "hs_dfs_step post (Q, W)")
    apply (auto simp add: hs_R_def hs_dfs_\<alpha>_def intro!: dfs_step.intros)
    done
  (*from G show ?T2
    apply (cases "hs_dfs_step post (Q, W)")
    apply (auto simp add: hs_dfs_invar_add_def)
    done*)
qed

-- "Prove refinement"
theorem hs_dfs_pref_dfs:
  (*assumes [simp]: "hs_invar \<Sigma>i"
  assumes [simp]: "!!q. ls_invar (post q)"*)
  shows "wa_precise_refine
    (det_wa_wa (hs_dfs_dwa \<Sigma>i post))
    (dfs_algo (hs.\<alpha> \<Sigma>i) (hs_R post))
    hs_dfs_\<alpha>"
  apply (unfold_locales)
  apply (auto simp add: det_wa_wa_def hs_dfs_dwa_def hs_dfs_\<alpha>_def
                        hs_dfs_cond_def dfs_algo_def dfs_cond_def) [1]
  apply (auto simp add: det_wa_wa_def hs_dfs_dwa_def dfs_algo_def
                        hs_dfs_invar_def (*hs_dfs_invar_add_def *)
              intro!: hs_dfs_step_correct(1)) [1]
  apply (auto simp add: det_wa_wa_def hs_dfs_dwa_def hs_dfs_\<alpha>_def
                        hs_dfs_cond_def dfs_algo_def dfs_cond_def
                        hs_dfs_invar_def hs_dfs_step_def hs_dfs_initial_def
                        hs.to_list_correct
              intro: dfs_initial.intros
  ) [3]
  done

    -- "Show that concrete algorithm is a while-algo"
theorem hs_dfs_while_algo:
  assumes finite[simp]: "finite ((hs_R post)\<^sup>* `` hs.\<alpha> \<Sigma>i)"
  shows "while_algo (det_wa_wa (hs_dfs_dwa \<Sigma>i post))"
proof -
  interpret ref: wa_precise_refine
    "(det_wa_wa (hs_dfs_dwa \<Sigma>i post))"
    "(dfs_algo (hs.\<alpha> \<Sigma>i) (hs_R post))"
    "hs_dfs_\<alpha>"
    using hs_dfs_pref_dfs .
  show ?thesis
    apply (rule ref.wa_intro[where addi=UNIV])
    apply (simp add: dfs_while_algo)
    apply (simp add: det_wa_wa_def hs_dfs_dwa_def hs_dfs_invar_def dfs_algo_def)

    apply (auto simp add: det_wa_wa_def hs_dfs_dwa_def) [1]
    apply simp
    done
qed

-- "Show that concrete algo is a deterministic while-algo"
theorems hs_dfs_det_while_algo = det_while_algo_intro[OF hs_dfs_while_algo]

  -- "Transferred correctness theorem"
theorems hs_dfs_invar_final =
  wa_precise_refine.transfer_correctness[OF
     hs_dfs_pref_dfs dfs_invar_final]

  -- "The executable implementation is correct"
theorem hs_dfs_correct:
  assumes finite[simp]: "finite ((hs_R post)\<^sup>* `` hs.\<alpha> \<Sigma>i)"
  shows "hs.\<alpha> (hs_dfs \<Sigma>i post) = (hs_R post)\<^sup>*``hs.\<alpha> \<Sigma>i" (is ?T1)
proof -
  from hs_dfs_det_while_algo[OF finite] interpret
    dwa: det_while_algo "(hs_dfs_dwa \<Sigma>i post)" .

  have
    LC: "(while hs_dfs_cond (hs_dfs_step post) (hs_dfs_initial \<Sigma>i)) = dwa.loop"
    by (unfold dwa.loop_def) (simp add: hs_dfs_dwa_def)

  have "?T1 (*\<and> ?T2*)"
    apply (unfold hs_dfs_def)
    apply (simp only: LC)
    apply (rule dwa.while_proof)
    apply (case_tac s)
    using hs_dfs_invar_final[of \<Sigma>i "post"] (*[of id, simplified]*)
    apply (auto simp add: det_wa_wa_def hs_dfs_dwa_def
                          dfs_\<alpha>_def hs_dfs_\<alpha>_def) [1]
    done
  thus ?T1  by auto
qed

subsection "Code Generation"
export_code hs_dfs in SML module_name DFS
export_code hs_dfs in OCaml module_name DFS
export_code hs_dfs in Haskell module_name DFS

end


theory Reaching_Definitions imports Bit_Vector_Framework begin

\<comment> \<open>We encode the Reaching Definitions analysis into Datalog. First we define the analysis, then
    we encode the analysis directly into Datalog and prove the encoding correct. Hereafter we
    encode it into Datalog again, but this time using our Bit-Vector Framework locale. We also prove
    this encoding correct. This latter encoding is described in our submission. \<close>

section \<open>Reaching Definitions\<close>

type_synonym ('n,'v) def = "'v * 'n option * 'n"

type_synonym ('n,'v) analysis_assignment = "'n \<Rightarrow> ('n,'v) def set"

subsection \<open>What is defined on a path\<close>

fun def_action :: "'v action \<Rightarrow> 'v set" where
  "def_action (x ::= a) = {x}"
| "def_action (Bool b) = {}"
| "def_action Skip = {}"

abbreviation def_edge :: "('n,'v) edge \<Rightarrow> 'v set" where
  "def_edge == \<lambda>(q1, \<alpha>, q2). def_action \<alpha>"

definition def_of :: "'v \<Rightarrow> ('n,'v) edge \<Rightarrow> ('n,'v) def" where
  "def_of == (\<lambda>x (q1, \<alpha>, q2). (x, Some q1, q2))"

definition def_var :: "('n,'v) edge list \<Rightarrow> 'v \<Rightarrow> 'n \<Rightarrow> ('n,'v) def" where
  "def_var \<pi> x start = (if (\<exists>e \<in> set \<pi>. x \<in> def_edge e)
                        then (def_of x (last (filter (\<lambda>e. x \<in> def_edge e) \<pi>)))
                        else (x, None, start))"

definition def_path :: "('n list \<times> 'v action list) \<Rightarrow> 'n \<Rightarrow> ('n,'v) def set" where
  "def_path \<pi> start = ((\<lambda>x. def_var (LTS.transition_list \<pi>) x start) ` UNIV)"

section \<open>Reaching Definitions in Datalog\<close>

\<comment> \<open>Direct encoding of Reaching Definitions into Datalog.\<close>

datatype ('n,'v) RD_elem =
  RD_Node 'n
  | RD_Var 'v
  | Questionmark

datatype RD_var =
  the_\<u>
  | the_\<v>
  | the_\<w>

datatype RD_pred =
  the_RD
  | the_VAR

abbreviation Cst\<^sub>R\<^sub>D\<^sub>N :: "'n \<Rightarrow> (RD_var, ('n, 'v) RD_elem) id" where
  "Cst\<^sub>R\<^sub>D\<^sub>N q == Cst (RD_Node q)"

fun Cst\<^sub>R\<^sub>D\<^sub>N_Q :: "'n option \<Rightarrow> (RD_var, ('n, 'v) RD_elem) id" where
  "Cst\<^sub>R\<^sub>D\<^sub>N_Q (Some q) = Cst (RD_Node q)"
| "Cst\<^sub>R\<^sub>D\<^sub>N_Q None = Cst Questionmark"

abbreviation Cst\<^sub>R\<^sub>D\<^sub>V :: "'v \<Rightarrow> (RD_var, ('n, 'v) RD_elem) id" where
  "Cst\<^sub>R\<^sub>D\<^sub>V v == Cst (RD_Var v)"

abbreviation RD_Cls :: "(RD_var, ('n, 'v) RD_elem) id list \<Rightarrow> (RD_pred, RD_var, ('n, 'v) RD_elem) rh list \<Rightarrow> (RD_pred, RD_var, ('n, 'v) RD_elem) clause" ("RD\<langle>_\<rangle> :- _ .") where
  "RD\<langle>args\<rangle> :- ls. \<equiv> Cls the_RD args ls"

abbreviation VAR_Cls :: "'v \<Rightarrow> (RD_pred, RD_var, ('n, 'v) RD_elem) clause" ("VAR\<langle>_\<rangle> :-.") where
  "VAR\<langle>x\<rangle> :-. == Cls the_VAR [Cst\<^sub>R\<^sub>D\<^sub>V x] []"

abbreviation RD_lh :: "(RD_var, ('n, 'v) RD_elem) id list \<Rightarrow> (RD_pred, RD_var, ('n, 'v) RD_elem) lh" ("RD\<langle>_\<rangle>.") where
  "RD\<langle>args\<rangle>. \<equiv> (the_RD, args)"

abbreviation VAR_lh :: "'v \<Rightarrow> (RD_pred, RD_var, ('n, 'v) RD_elem) lh" ("VAR\<langle>_\<rangle>.") where
  "VAR\<langle>x\<rangle>. \<equiv> (the_VAR, [Cst\<^sub>R\<^sub>D\<^sub>V x])"

abbreviation "RD == PosLit the_RD"
abbreviation "VAR == PosLit the_VAR"

abbreviation \<u> :: "(RD_var, 'a) id" where
  "\<u> == Var the_\<u>"

abbreviation \<v> :: "(RD_var, 'a) id" where
  "\<v> == Var the_\<v>"

abbreviation \<w> :: "(RD_var, 'a) id" where
  "\<w> == Var the_\<w>"

fun ana_edge :: "('n, 'v) edge \<Rightarrow> (RD_pred, RD_var, ('n,'v) RD_elem) clause set" where
  "ana_edge (q\<^sub>o, x ::= a, q\<^sub>s) =
     {
        RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N q\<^sub>s, \<u>, \<v>, \<w>]\<rangle> :-
          [
            RD[Cst\<^sub>R\<^sub>D\<^sub>N q\<^sub>o, \<u>, \<v>, \<w>],
            \<u> \<^bold>\<noteq> (Cst\<^sub>R\<^sub>D\<^sub>V x)
          ].
        ,
        RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N q\<^sub>s, Cst\<^sub>R\<^sub>D\<^sub>V x, Cst\<^sub>R\<^sub>D\<^sub>N q\<^sub>o, Cst\<^sub>R\<^sub>D\<^sub>N q\<^sub>s]\<rangle> :- [].
     }"
| "ana_edge (q\<^sub>o, Bool b, q\<^sub>s) =
     {
       RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N q\<^sub>s, \<u>, \<v>, \<w>]\<rangle> :-
         [
           RD[Cst\<^sub>R\<^sub>D\<^sub>N q\<^sub>o, \<u>, \<v>, \<w>]
         ].
     }"
| "ana_edge (q\<^sub>o, Skip, q\<^sub>s) =
     {
       RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N q\<^sub>s, \<u>, \<v>, \<w>]\<rangle> :-
         [
           RD[Cst\<^sub>R\<^sub>D\<^sub>N q\<^sub>o, \<u>, \<v>, \<w>]
         ].
     }"

definition ana_entry_node :: "'n \<Rightarrow> (RD_pred, RD_var, ('n,'v) RD_elem) clause set" where
  "ana_entry_node start =
     {
       RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N start, \<u>, Cst Questionmark, Cst\<^sub>R\<^sub>D\<^sub>N start]\<rangle> :-
         [
           VAR[\<u>]
         ].
     }"

fun ana_RD :: "('n, 'v) program_graph \<Rightarrow> (RD_pred, RD_var, ('n,'v) RD_elem) clause set" where
  "ana_RD (es,start,end) = \<Union>(ana_edge ` es) \<union> ana_entry_node start"

definition var_contraints :: "(RD_pred, RD_var, ('n,'v) RD_elem) clause set" where
  "var_contraints = VAR_Cls ` UNIV"

type_synonym ('n,'v) quadruple = "'n *'v * 'n option * 'n"

fun summarizes_RD :: "(RD_pred,('n,'v) RD_elem) pred_val \<Rightarrow> ('n,'v) program_graph \<Rightarrow> bool" where
  "summarizes_RD \<rho> (es, start, end) =
    (\<forall>\<pi> x q1 q2.
       \<pi> \<in> LTS.path_with_word_from es start \<longrightarrow>
       (x, q1, q2) \<in> def_path \<pi> start \<longrightarrow>
       \<rho> \<Turnstile>\<^sub>l\<^sub>h RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N (LTS.end_of \<pi>), Cst\<^sub>R\<^sub>D\<^sub>V x, Cst\<^sub>R\<^sub>D\<^sub>N_Q q1, Cst\<^sub>R\<^sub>D\<^sub>N q2]\<rangle>.)"

lemma def_var_x: "fst (def_var ts x start) = x"
  unfolding def_var_def by (simp add: case_prod_beta def_of_def)

lemma last_def_transition:
  assumes "length ss = length w"
  assumes "x \<in> def_action \<alpha>"
  assumes "(x, q1, q2) \<in> def_path (ss @ [s, s'], w @ [\<alpha>]) start"
  shows "Some s = q1 \<and> s' = q2"
proof -
  obtain y where y_p: "(x, q1, q2) = def_var (transition_list (ss @ [s], w) @ [(s, \<alpha>, s')]) y start"
    by (metis (no_types, lifting) assms(1) assms(3) def_path_def imageE transition_list_reversed_simp)
  show ?thesis
  proof (cases "y = x")
    case True
    then show ?thesis
      using assms y_p unfolding def_var_def def_of_def by auto
  next
    case False
    then show ?thesis
      by (metis y_p def_var_x fst_conv)
  qed
qed

lemma not_last_def_transition:
  assumes "length ss = length w"
  assumes "x \<notin> def_action \<alpha>"
  assumes "(x, q1, q2) \<in> def_path (ss @ [s, s'], w @ [\<alpha>]) start"
  shows "(x, q1, q2) \<in> def_path (ss @ [s], w) start"
proof -
  obtain y where y_p: "(x, q1, q2) = def_var (transition_list (ss @ [s], w) @ [(s, \<alpha>, s')]) y start"
    by (metis (no_types, lifting) assms(1) assms(3) def_path_def imageE transition_list_reversed_simp)
  have " (x, q1, q2) \<in> range (\<lambda>x. def_var (transition_list (ss @ [s], w)) x start)"
  proof (cases "y = x")
    case True
    then show ?thesis
      using assms y_p unfolding def_var_def def_of_def by auto
  next
    case False
    then show ?thesis
      by (metis y_p def_var_x fst_conv)
  qed
  then show ?thesis
    by (simp add: def_path_def)
qed

theorem RD_sound':
  assumes "(ss,w) \<in> LTS.path_with_word_from es start"
  assumes "(x,q1,q2) \<in> def_path (ss,w) start"
  assumes "\<rho> \<Turnstile>\<^sub>d\<^sub>l (var_contraints \<union> ana_RD (es, start, end))"
  shows "\<rho> \<Turnstile>\<^sub>l\<^sub>h RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N (LTS.end_of (ss, w)), Cst\<^sub>R\<^sub>D\<^sub>V x, Cst\<^sub>R\<^sub>D\<^sub>N_Q q1, Cst\<^sub>R\<^sub>D\<^sub>N q2]\<rangle>."
  using assms
proof (induction rule: LTS.path_with_word_from_induct_reverse[OF assms(1)])
  case (1 s)
  have "VAR\<langle>x\<rangle> :-. \<in> var_contraints"
    unfolding var_contraints_def by auto
  from assms(3) this have "\<rho> \<Turnstile>\<^sub>c\<^sub>l\<^sub>s VAR\<langle>x\<rangle> :-."
    unfolding solves_program_def by auto
  then have "\<forall>y. \<lbrakk>(VAR\<langle>x\<rangle> :-.)\<rbrakk>\<^sub>c\<^sub>l\<^sub>s \<rho> y"
    unfolding solves_cls_def by auto
  then have x_sat: "[RD_Var x] \<in> \<rho> the_VAR"
    by auto

  have "RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N start, \<u>, Cst Questionmark, Cst\<^sub>R\<^sub>D\<^sub>N start]\<rangle> :-
         [
           VAR[\<u>]
         ]. \<in> ana_RD (es, start, end)"
    by (simp add: ana_entry_node_def)
  then have "\<rho> \<Turnstile>\<^sub>c\<^sub>l\<^sub>s RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N start, \<u>, Cst Questionmark, Cst\<^sub>R\<^sub>D\<^sub>N start]\<rangle> :- [VAR [\<u>]] ."
    using assms(3) unfolding solves_program_def by auto
  then have "\<forall>\<sigma>. \<lbrakk>RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N start, \<u>, Cst Questionmark, Cst\<^sub>R\<^sub>D\<^sub>N start]\<rangle> :- [VAR [\<u>]] .\<rbrakk>\<^sub>c\<^sub>l\<^sub>s \<rho> \<sigma>"
    unfolding solves_cls_def by metis
  then have "\<lbrakk>RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N start, \<u>, Cst Questionmark, Cst\<^sub>R\<^sub>D\<^sub>N start]\<rangle> :- [VAR [\<u>]] .\<rbrakk>\<^sub>c\<^sub>l\<^sub>s \<rho> (\<lambda>v. RD_Var x)"
    by presburger
  then have "[RD_Var x] \<in> \<rho> the_VAR \<longrightarrow> [RD_Node start, RD_Var x, Questionmark, RD_Node start] \<in> \<rho> the_RD"
    by simp
  then have "[RD_Node start, RD_Var x, Questionmark, RD_Node start] \<in> \<rho> the_RD"
    using x_sat by auto

  from this 1 show ?case
    unfolding LTS.LTS.end_of_def def_path_def def_var_def LTS.start_of_def by auto
next
  case (2 ss s w \<alpha> s')
  from 2(1) have len: "length ss = length w"
    using LTS.path_with_word_length by force
  show ?case
  proof(cases "x \<in> def_action \<alpha>")
    case True
    then have sq: "Some s = q1 \<and> s' = q2" using 2(5)
      using last_def_transition[of ss w x \<alpha> q1 q2 s s'] len by auto
    from True have "\<exists>e. (s,x ::= e,s') \<in> es"
      using "2.hyps"(2) by (cases \<alpha>) auto
    then have "RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N q2, Cst\<^sub>R\<^sub>D\<^sub>V x, Cst\<^sub>R\<^sub>D\<^sub>N_Q q1, Cst\<^sub>R\<^sub>D\<^sub>N q2]\<rangle> :- []. \<in> ana_RD (es, start, end)"
      using True ana_RD.simps sq by fastforce
    then have "\<rho> \<Turnstile>\<^sub>c\<^sub>l\<^sub>s RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N q2, Cst\<^sub>R\<^sub>D\<^sub>V x, Cst\<^sub>R\<^sub>D\<^sub>N_Q q1, Cst\<^sub>R\<^sub>D\<^sub>N q2]\<rangle> :- [] ."
      using 2(6) unfolding solves_program_def by auto
    then have "\<rho> \<Turnstile>\<^sub>l\<^sub>h RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N q2, Cst\<^sub>R\<^sub>D\<^sub>V x, Cst\<^sub>R\<^sub>D\<^sub>N_Q q1, Cst\<^sub>R\<^sub>D\<^sub>N q2]\<rangle>."
      using solves_lh_lh by metis
    then show ?thesis
      by (simp add: LTS.end_of_def sq)
  next
    case False
    then have x_is_def: "(x, q1, q2) \<in> def_path (ss @ [s], w) start" using 2(5)
      using not_last_def_transition len by force
    then have "\<rho> \<Turnstile>\<^sub>l\<^sub>h RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N (LTS.end_of (ss @ [s], w)), Cst\<^sub>R\<^sub>D\<^sub>V x, Cst\<^sub>R\<^sub>D\<^sub>N_Q q1, Cst\<^sub>R\<^sub>D\<^sub>N q2]\<rangle>."
    proof -
      have "(ss @ [s], w) \<in> LTS.path_with_word es"
        using 2(1) by auto
      moreover
      have "\<rho> \<Turnstile>\<^sub>d\<^sub>l (var_contraints \<union> ana_RD (es, start, end))"
        using 2(6) by auto
      moreover
      have "LTS.start_of (ss @ [s], w) = start"
        using "2.hyps"(1) by auto
      moreover
      have "(x, q1, q2) \<in> def_path (ss @ [s], w) start"
        using x_is_def by auto
      ultimately
      show "\<rho> \<Turnstile>\<^sub>l\<^sub>h RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N (LTS.end_of (ss @ [s], w)), Cst\<^sub>R\<^sub>D\<^sub>V x, Cst\<^sub>R\<^sub>D\<^sub>N_Q q1, Cst\<^sub>R\<^sub>D\<^sub>N q2]\<rangle>."
        using 2(3) by auto
    qed
    then have ind: "\<rho> \<Turnstile>\<^sub>l\<^sub>h RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N s, Cst\<^sub>R\<^sub>D\<^sub>V x, Cst\<^sub>R\<^sub>D\<^sub>N_Q q1, Cst\<^sub>R\<^sub>D\<^sub>N q2]\<rangle>."
      by (simp add: LTS.end_of_def)
    define \<mu> where "\<mu> = undefined(the_\<u> := Cst\<^sub>R\<^sub>D\<^sub>V x, the_\<v> := Cst\<^sub>R\<^sub>D\<^sub>N_Q q1, the_\<w> := Cst\<^sub>R\<^sub>D\<^sub>N q2)"
    show ?thesis
    proof (cases \<alpha>)
      case (Asg y e)
      have xy: "x \<noteq> y"
        using False Asg by auto
      then have xy': "\<rho> \<Turnstile>\<^sub>r\<^sub>h (Cst\<^sub>R\<^sub>D\<^sub>V x \<^bold>\<noteq> Cst\<^sub>R\<^sub>D\<^sub>V y)"
        by auto
      have "(s, y ::= e, s') \<in> es"
        using "2.hyps"(2) Asg by auto
      then have "RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N s', \<u>, \<v>, \<w>]\<rangle> :-
          [
            RD[Cst\<^sub>R\<^sub>D\<^sub>N s, \<u>, \<v>, \<w>],
            \<u> \<^bold>\<noteq> (Cst\<^sub>R\<^sub>D\<^sub>V y)
          ]. \<in> ana_RD (es,start,end)"
        unfolding ana_RD.simps by force
      from this False have "\<rho> \<Turnstile>\<^sub>c\<^sub>l\<^sub>s RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N s', \<u>, \<v>, \<w>]\<rangle> :- [RD [Cst\<^sub>R\<^sub>D\<^sub>N s, \<u>, \<v>, \<w>], \<u> \<^bold>\<noteq> Cst\<^sub>R\<^sub>D\<^sub>V y] ."
        by (meson "2.prems"(3) UnCI solves_program_def)
      moreover have "(RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N s', \<u>, \<v>, \<w>]\<rangle> :-
          [
            RD[Cst\<^sub>R\<^sub>D\<^sub>N s, \<u>, \<v>, \<w>],
            \<u> \<^bold>\<noteq> (Cst\<^sub>R\<^sub>D\<^sub>V y)
          ].) \<cdot>\<^sub>c\<^sub>l\<^sub>s \<mu> = RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N s', Cst\<^sub>R\<^sub>D\<^sub>V x, Cst\<^sub>R\<^sub>D\<^sub>N_Q q1, Cst\<^sub>R\<^sub>D\<^sub>N q2]\<rangle> :- [RD [Cst\<^sub>R\<^sub>D\<^sub>N s,  Cst\<^sub>R\<^sub>D\<^sub>V x, Cst\<^sub>R\<^sub>D\<^sub>N_Q q1, Cst\<^sub>R\<^sub>D\<^sub>N q2], Cst\<^sub>R\<^sub>D\<^sub>V x \<^bold>\<noteq> Cst\<^sub>R\<^sub>D\<^sub>V y] ."
        unfolding \<mu>_def by auto
      ultimately
      have "\<rho> \<Turnstile>\<^sub>c\<^sub>l\<^sub>s RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N s', Cst\<^sub>R\<^sub>D\<^sub>V x, Cst\<^sub>R\<^sub>D\<^sub>N_Q q1, Cst\<^sub>R\<^sub>D\<^sub>N q2]\<rangle>
                    :- [RD [Cst\<^sub>R\<^sub>D\<^sub>N s, Cst\<^sub>R\<^sub>D\<^sub>V x, Cst\<^sub>R\<^sub>D\<^sub>N_Q q1, Cst\<^sub>R\<^sub>D\<^sub>N q2], Cst\<^sub>R\<^sub>D\<^sub>V x \<^bold>\<noteq> Cst\<^sub>R\<^sub>D\<^sub>V y] ."
        unfolding solves_cls_def by (metis substitution_lemma_cls)
      then have "\<rho> \<Turnstile>\<^sub>c\<^sub>l\<^sub>s RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N s', Cst\<^sub>R\<^sub>D\<^sub>V x, Cst\<^sub>R\<^sub>D\<^sub>N_Q q1, Cst\<^sub>R\<^sub>D\<^sub>N q2]\<rangle>
                         :- [RD [Cst\<^sub>R\<^sub>D\<^sub>N s, Cst\<^sub>R\<^sub>D\<^sub>V x, Cst\<^sub>R\<^sub>D\<^sub>N_Q q1, Cst\<^sub>R\<^sub>D\<^sub>N q2]] ."
        using xy' by (simp add: prop_inf_last_from_cls_rh_to_cls)
      then have "\<rho> \<Turnstile>\<^sub>c\<^sub>l\<^sub>s RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N s', Cst\<^sub>R\<^sub>D\<^sub>V x, Cst\<^sub>R\<^sub>D\<^sub>N_Q q1, Cst\<^sub>R\<^sub>D\<^sub>N q2]\<rangle> :- [] ."
        using ind by (metis meaning_cls.simps modus_ponens_rh solves_cls_def solves_lh.simps)
      then have "\<rho> \<Turnstile>\<^sub>l\<^sub>h RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N s', Cst\<^sub>R\<^sub>D\<^sub>V x, Cst\<^sub>R\<^sub>D\<^sub>N_Q q1, Cst\<^sub>R\<^sub>D\<^sub>N q2]\<rangle>."
        using solves_lh_lh by metis
      then show ?thesis
        by (simp add: LTS.end_of_def)
    next
      case (Bool b)
      have "(s, Bool b, s') \<in> es"
        using "2.hyps"(2) Bool by auto
      then have "RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N s', \<u>, \<v>, \<w>]\<rangle> :-
         [
           RD[Cst\<^sub>R\<^sub>D\<^sub>N s, \<u>, \<v>, \<w>]
         ]. \<in> ana_RD (es,start,end)"
        unfolding ana_RD.simps by force
      then have "\<rho> \<Turnstile>\<^sub>c\<^sub>l\<^sub>s RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N s', \<u>, \<v>, \<w>]\<rangle> :- [RD [Cst\<^sub>R\<^sub>D\<^sub>N s, \<u>, \<v>, \<w>]] ."
        by (meson "2.prems"(3) UnCI solves_program_def)
      moreover have "(RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N s', \<u>, \<v>, \<w>]\<rangle> :- [RD[Cst\<^sub>R\<^sub>D\<^sub>N s, \<u>, \<v>, \<w>]].) \<cdot>\<^sub>c\<^sub>l\<^sub>s \<mu> =
                     RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N s', Cst\<^sub>R\<^sub>D\<^sub>V x, Cst\<^sub>R\<^sub>D\<^sub>N_Q q1, Cst\<^sub>R\<^sub>D\<^sub>N q2]\<rangle> :- [RD[Cst\<^sub>R\<^sub>D\<^sub>N s, Cst\<^sub>R\<^sub>D\<^sub>V x, Cst\<^sub>R\<^sub>D\<^sub>N_Q q1, Cst\<^sub>R\<^sub>D\<^sub>N q2]]."
        unfolding \<mu>_def by auto
      ultimately have "\<rho> \<Turnstile>\<^sub>c\<^sub>l\<^sub>s RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N s', Cst\<^sub>R\<^sub>D\<^sub>V x, Cst\<^sub>R\<^sub>D\<^sub>N_Q q1, Cst\<^sub>R\<^sub>D\<^sub>N q2]\<rangle>
                               :- [RD [Cst\<^sub>R\<^sub>D\<^sub>N s, Cst\<^sub>R\<^sub>D\<^sub>V x, Cst\<^sub>R\<^sub>D\<^sub>N_Q q1, Cst\<^sub>R\<^sub>D\<^sub>N q2]] ."
        by (metis substitution_lemma)
      then have "\<rho> \<Turnstile>\<^sub>l\<^sub>h RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N s', Cst\<^sub>R\<^sub>D\<^sub>V x, Cst\<^sub>R\<^sub>D\<^sub>N_Q q1, Cst\<^sub>R\<^sub>D\<^sub>N q2]\<rangle>."
        using ind
        by (meson prop_inf_only)
      then show ?thesis
        by (simp add: LTS.end_of_def)
    next
      case Skip
      have "(s, Skip, s') \<in> es"
        using "2.hyps"(2) Skip by auto
      then have "RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N s', \<u>, \<v>, \<w>]\<rangle> :-
         [
           RD[Cst\<^sub>R\<^sub>D\<^sub>N s, \<u>, \<v>, \<w>]
         ]. \<in> ana_RD (es,start,end)"
        unfolding ana_RD.simps by force
      then have "\<rho> \<Turnstile>\<^sub>c\<^sub>l\<^sub>s RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N s', \<u>, \<v>, \<w>]\<rangle> :- [RD [Cst\<^sub>R\<^sub>D\<^sub>N s, \<u>, \<v>, \<w>]] ."
        by (meson "2.prems"(3) UnCI solves_program_def)
      moreover
      have "(RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N s', \<u>, \<v>, \<w>]\<rangle> :- [RD [Cst\<^sub>R\<^sub>D\<^sub>N s, \<u>, \<v>, \<w>]] .) \<cdot>\<^sub>c\<^sub>l\<^sub>s \<mu> =
            RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N s', Cst\<^sub>R\<^sub>D\<^sub>V x, Cst\<^sub>R\<^sub>D\<^sub>N_Q q1, Cst\<^sub>R\<^sub>D\<^sub>N q2]\<rangle>  :- [RD [Cst\<^sub>R\<^sub>D\<^sub>N s, Cst\<^sub>R\<^sub>D\<^sub>V x, Cst\<^sub>R\<^sub>D\<^sub>N_Q q1, Cst\<^sub>R\<^sub>D\<^sub>N q2]]."
        unfolding \<mu>_def by auto
      ultimately
      have "\<rho> \<Turnstile>\<^sub>c\<^sub>l\<^sub>s RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N s', Cst\<^sub>R\<^sub>D\<^sub>V x, Cst\<^sub>R\<^sub>D\<^sub>N_Q q1, Cst\<^sub>R\<^sub>D\<^sub>N q2]\<rangle>
                    :- [RD [Cst\<^sub>R\<^sub>D\<^sub>N s, Cst\<^sub>R\<^sub>D\<^sub>V x, Cst\<^sub>R\<^sub>D\<^sub>N_Q q1, Cst\<^sub>R\<^sub>D\<^sub>N q2]] ."
        by (metis substitution_lemma)
      from modus_ponens_rh[OF this ind] have "\<rho> \<Turnstile>\<^sub>l\<^sub>h RD\<langle>[Cst\<^sub>R\<^sub>D\<^sub>N s', Cst\<^sub>R\<^sub>D\<^sub>V x, Cst\<^sub>R\<^sub>D\<^sub>N_Q q1, Cst\<^sub>R\<^sub>D\<^sub>N q2]\<rangle>."
        .
      then show ?thesis
        by (simp add: LTS.end_of_def)
    qed
  qed
qed

theorem RD_sound:
  assumes "\<rho> \<Turnstile>\<^sub>d\<^sub>l (var_contraints \<union> ana_RD pg)"
  shows "summarizes_RD \<rho> pg"
  using assms RD_sound' by (cases pg) force

section \<open>Reaching Definitions as Bit-Vector Framework analysis\<close>

\<comment> \<open>Encoding of Reaching Definitions into Datalog using the Bit-Vector Framework.\<close>

locale analysis_RD = finite_program_graph pg
  for pg :: "('n::finite,'v::finite) program_graph" +
  assumes "finite edge_set"
begin

interpretation LTS edge_set .

definition analysis_dom_RD :: "('n,'v) def set" where
  "analysis_dom_RD = UNIV \<times> UNIV \<times> UNIV"

fun kill_set_RD :: "('n,'v) edge \<Rightarrow> ('n,'v) def set" where
  "kill_set_RD (q\<^sub>o, x ::= a, q\<^sub>s) = {x} \<times> UNIV \<times> UNIV"
| "kill_set_RD (q\<^sub>o, Bool b, q\<^sub>s) = {}"
| "kill_set_RD (v, Skip, vc) = {}"

fun gen_set_RD :: "('n,'v) edge \<Rightarrow> ('n,'v) def set" where
  "gen_set_RD (q\<^sub>o, x ::= a, q\<^sub>s) = {x} \<times> {Some q\<^sub>o} \<times> {q\<^sub>s}"
| "gen_set_RD (q\<^sub>o, Bool b, q\<^sub>s) = {}"
| "gen_set_RD (v, Skip, vc) = {} "

definition d_init_RD :: " ('n,'v) def set" where
  "d_init_RD = (UNIV \<times> {None} \<times> {start})"

lemma finite_analysis_dom_RD: "finite analysis_dom_RD"
  by auto

lemma d_init_RD_subset_analysis_dom_RD:
  "d_init_RD \<subseteq> analysis_dom_RD"
  unfolding d_init_RD_def analysis_dom_RD_def by auto

lemma gen_RD_subset_analysis_dom: "gen_set_RD e \<subseteq> analysis_dom_RD"
  unfolding analysis_dom_RD_def by auto

lemma kill_RD_subset_analysis_dom: "kill_set_RD e \<subseteq> analysis_dom_RD"
  unfolding analysis_dom_RD_def by auto

interpretation fw_may: analysis_BV_forward_may pg analysis_dom_RD kill_set_RD gen_set_RD d_init_RD
  using analysis_BV_forward_may_def analysis_RD_axioms analysis_RD_def
    d_init_RD_subset_analysis_dom_RD finite_analysis_dom_RD gen_RD_subset_analysis_dom
    kill_RD_subset_analysis_dom analysis_BV_forward_may_axioms.intro finite_program_graph_def
  by metis

lemma def_var_def_edge_S_hat:
  assumes "def_var \<pi> x start \<in> R"
  assumes "x \<notin> def_edge t"
  shows "def_var \<pi> x start \<in> fw_may.S_hat t R"
proof -
  define q1 where "q1 = fst t"
  define \<alpha> where "\<alpha> = fst (snd t)"
  define q2 where "q2 = snd (snd t)"
  have t_def: "t = (q1, \<alpha>, q2)"
    by (simp add: \<alpha>_def q1_def q2_def)

  from assms(2) have x_not_def: "x \<notin> def_edge (q1, \<alpha>, q2)"
    unfolding t_def by auto

  have "def_var \<pi> x start \<in> fw_may.S_hat (q1, \<alpha>, q2) R"
  proof (cases \<alpha>)
    case (Asg y exp)
    then show ?thesis
      by (metis (no_types, lifting) DiffI Un_iff assms(1) x_not_def def_action.simps(1) def_var_x fw_may.S_hat_def kill_set_RD.simps(1) mem_Sigma_iff old.prod.case prod.collapse)
  next
    case (Bool b)
    then show ?thesis
      by (simp add: fw_may.S_hat_def assms(1))
  next
    case Skip
    then show ?thesis
      by (simp add: fw_may.S_hat_def assms(1))
  qed
  then show ?thesis
    unfolding t_def by auto
qed

lemma def_var_S_hat_edge_list: "(def_var \<pi>) x start \<in> fw_may.S_hat_edge_list \<pi> d_init_RD"
proof (induction \<pi> rule: rev_induct)
  case Nil
  then show ?case
    unfolding def_var_def d_init_RD_def by auto
next
  case (snoc t \<pi>)
  then show ?case
  proof (cases "x \<in> def_edge t")
    case True
    then have "def_var (\<pi> @[t]) x start = def_var [t] x start"
      by (simp add: def_var_def)
    moreover
    have "fw_may.S_hat_edge_list (\<pi> @ [t]) d_init_RD = fw_may.S_hat t (fw_may.S_hat_edge_list \<pi> d_init_RD)"
      unfolding fw_may.S_hat_edge_list_def2 by simp
    moreover
    obtain q1 \<alpha> q2 where t_split: "t = (q1, \<alpha>, q2)"
      using prod_cases3 by blast
    moreover
    have "def_var [t] x start \<in> fw_may.S_hat t (fw_may.S_hat_edge_list \<pi> d_init_RD)"
      unfolding fw_may.S_hat_def def_var_def def_of_def using True t_split by (cases \<alpha>) auto
    ultimately
    show ?thesis by auto
  next
    case False
    obtain q1 \<alpha> q2 where t_split: "t = (q1, \<alpha>, q2)"
      using prod_cases3 by blast
    from False have "def_var (\<pi> @ [t]) x start = def_var \<pi> x start"
      by (simp add: def_var_def)
    moreover
    from snoc.IH have "def_var \<pi> x start \<in> fw_may.S_hat t (fw_may.S_hat_edge_list \<pi> d_init_RD)"
      by (simp add: False def_var_def_edge_S_hat)
    then have "def_var \<pi> x start \<in> fw_may.S_hat_edge_list (\<pi> @ [t]) d_init_RD"
      unfolding fw_may.S_hat_edge_list_def2 by simp
    ultimately
    show ?thesis
      using snoc by auto
  qed
qed

lemma last_overwrites:
  "def_var (\<pi> @ [(q1, x ::= exp, q2)]) x start = (x, Some q1, q2)"
proof -
  have "x \<in> def_edge (q1, x ::= exp, q2)"
    by auto
  then have "\<exists>e\<in>set (\<pi> @ [(q1, x ::= exp, q2)]). x \<in> def_edge e"
    by auto
  have "def_var (\<pi> @ [(q1, x ::= exp, q2)]) x start = def_of x (last (filter (\<lambda>e. x \<in> def_edge e) (\<pi> @ [(q1, x ::= exp, q2)])))"
    unfolding def_var_def by auto
  also
  have "... = def_of x (q1, x ::= exp, q2)"
    by auto
  also
  have "... = (x, Some q1, q2)"
    unfolding def_of_def by auto
  finally
  show ?thesis
    .
qed

lemma S_hat_edge_list_last: "fw_may.S_hat_edge_list (\<pi> @ [e]) d_init_RD = fw_may.S_hat e (fw_may.S_hat_edge_list \<pi> d_init_RD)"
  using fw_may.S_hat_edge_list_def2 foldl_conv_foldr by simp

lemma def_var_if_S_hat: "(x,q1,q2) \<in> fw_may.S_hat_edge_list \<pi> d_init_RD \<Longrightarrow> (x,q1,q2) = (def_var \<pi>) x start"
proof (induction \<pi> rule: rev_induct)
  case Nil
  then show ?case
    by (metis append_is_Nil_conv d_init_RD_def def_var_def in_set_conv_decomp fw_may.S_hat_edge_list.simps(1) list.distinct(1) mem_Sigma_iff singletonD)
next
  case (snoc e \<pi>)

  from snoc(2) have "(x, q1, q2) \<in> fw_may.S_hat e (fw_may.S_hat_edge_list \<pi> d_init_RD)"
    using S_hat_edge_list_last by blast

  then have "(x, q1, q2) \<in> fw_may.S_hat_edge_list \<pi> d_init_RD - kill_set_RD e \<or> (x, q1, q2) \<in> gen_set_RD e"
    unfolding fw_may.S_hat_def by auto
  then show ?case
  proof
    assume a: "(x, q1, q2) \<in> fw_may.S_hat_edge_list \<pi> d_init_RD - kill_set_RD e"
    then have "(x, q1, q2) = def_var \<pi> x start"
      using snoc by auto
    moreover
    from a have "(x, q1, q2) \<notin> kill_set_RD e"
      by auto
    then have "def_var (\<pi> @ [e]) x start = def_var \<pi> x start"
    proof -
      assume def_not_kill: "(x, q1, q2) \<notin> kill_set_RD e"
      obtain q q' \<alpha> where "e = (q, \<alpha>, q')"
        by (cases e) auto
      then have "x \<notin> def_edge e"
        using def_not_kill by (cases \<alpha>) auto
      then show ?thesis
        by (simp add: def_var_def)
    qed
    ultimately
    show ?case
      by auto
  next
    assume a: "(x, q1, q2) \<in> gen_set_RD e"
    obtain q q' \<alpha> where "e = (q, \<alpha>, q')"
      by (cases e) auto
    then have "\<exists>exp theq1. e = (theq1, x ::= exp, q2) \<and> q1 = Some theq1"
      using a by (cases \<alpha>) auto
    then obtain exp theq1 where exp_theq1_p: "e = (theq1, x ::= exp, q2) \<and> q1 = Some theq1"
      by auto
    then have "(x, q1, q2) = def_var (\<pi> @ [(theq1, x ::= exp, q2)]) x start"
      using last_overwrites[of \<pi> theq1 x exp q2] by auto
    then show ?case
      using exp_theq1_p by auto
  qed
qed

lemma def_var_UNIV_S_hat_edge_list: "(\<lambda>x. def_var \<pi> x start) ` UNIV = fw_may.S_hat_edge_list \<pi> d_init_RD"
proof (rule; rule)
  fix x
  assume "x \<in> range (\<lambda>x. def_var \<pi> x start)"
  then show "x \<in> fw_may.S_hat_edge_list \<pi> d_init_RD"
    using def_var_S_hat_edge_list by blast
next
  fix x
  assume "x \<in> fw_may.S_hat_edge_list \<pi> d_init_RD"
  then show "x \<in> range (\<lambda>x. def_var \<pi> x start)"
    by (metis def_var_if_S_hat prod.collapse range_eqI)
qed

lemma def_path_S_hat_path: "def_path \<pi> start = fw_may.S_hat_path \<pi> d_init_RD"
  using fw_may.S_hat_path_def def_path_def def_var_UNIV_S_hat_edge_list by metis

definition summarizes_RD :: "(pred, ('n,'v,('n,'v) def) cst) pred_val \<Rightarrow> bool" where
  "summarizes_RD \<rho> \<longleftrightarrow> (\<forall>\<pi> d. \<pi> \<in> path_with_word_from start \<longrightarrow> d \<in> def_path \<pi> start \<longrightarrow>
                        \<rho> \<Turnstile>\<^sub>l\<^sub>h may\<langle>[Cst\<^sub>N (end_of \<pi>), Cst\<^sub>E d]\<rangle>.)"

theorem RD_sound:
  assumes "\<rho> \<Turnstile>\<^sub>l\<^sub>s\<^sub>t fw_may.ana_pg_fw_may s_BV"
  shows "summarizes_RD \<rho>"
  using assms def_path_S_hat_path fw_may.sound_ana_pg_fw_may unfolding fw_may.summarizes_fw_may_def summarizes_RD.simps
  using edge_set_def in_mono edge_set_def start_def start_def summarizes_RD_def by fastforce

end

end