(* Author: Alexander Maletzky *)

section \<open>Preliminaries\<close>

theory Prelims
  imports Polynomials.Utils Groebner_Bases.General
begin

subsection \<open>Lists\<close>

subsubsection \<open>Sequences of Lists\<close>

lemma list_seq_length_mono:
  fixes seq :: "nat \<Rightarrow> 'a list"
  assumes "\<And>i. (\<exists>x. seq (Suc i) = x # seq i)" and "i < j"
  shows "length (seq i) < length (seq j)"
proof -
  from assms(2) obtain k where "j = Suc (i + k)" using less_iff_Suc_add by auto
  show ?thesis unfolding \<open>j = Suc (i + k)\<close>
  proof (induct k)
    case 0
    from assms(1) obtain x where eq: "seq (Suc i) = x # seq i" ..
    show ?case by (simp add: eq)
  next
    case (Suc k)
    from assms(1) obtain x where "seq (Suc (i + Suc k)) = x # seq (i + Suc k)" ..
    hence eq: "seq (Suc (Suc (i + k))) = x # seq (Suc (i + k))" by simp
    note Suc
    also have "length (seq (Suc (i + k))) < length (seq (Suc (i + Suc k)))" by (simp add: eq)
    finally show ?case .
  qed
qed

corollary list_seq_length_mono_weak:
  fixes seq :: "nat \<Rightarrow> 'a list"
  assumes "\<And>i. (\<exists>x. seq (Suc i) = x # seq i)" and "i \<le> j"
  shows "length (seq i) \<le> length (seq j)"
proof (cases "i = j")
  case True
  thus ?thesis by simp
next
  case False
  with assms(2) have "i < j" by simp
  with assms(1) have "length (seq i) < length (seq j)" by (rule list_seq_length_mono)
  thus ?thesis by simp
qed

lemma list_seq_indexE_length:
  fixes seq :: "nat \<Rightarrow> 'a list"
  assumes "\<And>i. (\<exists>x. seq (Suc i) = x # seq i)"
  obtains j where "i < length (seq j)"
proof (induct i arbitrary: thesis)
  case 0
  have "0 \<le> length (seq 0)" by simp
  also from assms lessI have "... < length (seq (Suc 0))" by (rule list_seq_length_mono)
  finally show ?case by (rule 0)
next
  case (Suc i)
  obtain j where "i < length (seq j)" by (rule Suc(1))
  hence "Suc i \<le> length (seq j)" by simp
  also from assms lessI have "... < length (seq (Suc j))" by (rule list_seq_length_mono)
  finally show ?case by (rule Suc(2))
qed

lemma list_seq_nth:
  fixes seq :: "nat \<Rightarrow> 'a list"
  assumes "\<And>i. (\<exists>x. seq (Suc i) = x # seq i)" and "i < length (seq j)" and "j \<le> k"
  shows "rev (seq k) ! i = rev (seq j) ! i"
proof -
  from assms(3) obtain l where "k = j + l" using nat_le_iff_add by blast
  show ?thesis unfolding \<open>k = j + l\<close>
  proof (induct l)
    case 0
    show ?case by simp
  next
    case (Suc l)
    note assms(2)
    also from assms(1) le_add1 have "length (seq j) \<le> length (seq (j + l))"
      by (rule list_seq_length_mono_weak)
    finally have i: "i < length (seq (j + l))" .
    from assms(1) obtain x where "seq (Suc (j + l)) = x # seq (j + l)" ..
    thus ?case by (simp add: nth_append i Suc)
  qed
qed

corollary list_seq_nth':
  fixes seq :: "nat \<Rightarrow> 'a list"
  assumes "\<And>i. (\<exists>x. seq (Suc i) = x # seq i)" and "i < length (seq j)" and "i < length (seq k)"
  shows "rev (seq k) ! i = rev (seq j) ! i"
proof (rule linorder_cases)
  assume "j < k"
  hence "j \<le> k" by simp
  with assms(1, 2) show ?thesis by (rule list_seq_nth)
next
  assume "k < j"
  hence "k \<le> j" by simp
  with assms(1, 3) have "rev (seq j) ! i = rev (seq k) ! i" by (rule list_seq_nth)
  thus ?thesis by (rule HOL.sym)
next
  assume "j = k"
  thus ?thesis by simp
qed

subsubsection \<open>@{const filter}\<close>

lemma filter_merge_wrt_1:
  assumes "\<And>y. y \<in> set ys \<Longrightarrow> P y \<Longrightarrow> False"
  shows "filter P (merge_wrt rel xs ys) = filter P xs"
  using assms
proof (induct rel xs ys rule: merge_wrt.induct)
  case (1 rel xs)
  show ?case by simp
next
  case (2 rel y ys)
  hence "P y \<Longrightarrow> False" and "\<And>z. z \<in> set ys \<Longrightarrow> P z \<Longrightarrow> False" by auto
  thus ?case by (auto simp: filter_empty_conv)
next
  case (3 rel x xs y ys)
  hence "\<not> P y" and x: "\<And>z. z \<in> set ys \<Longrightarrow> P z \<Longrightarrow> False" by auto
  have a: "filter P (merge_wrt rel xs ys) = filter P xs" if "x = y" using that x by (rule 3(1))
  have b: "filter P (merge_wrt rel xs (y # ys)) = filter P xs" if "x \<noteq> y" and "rel x y"
    using that 3(4) by (rule 3(2))
  have c: "filter P (merge_wrt rel (x # xs) ys) = filter P (x # xs)" if "x \<noteq> y" and "\<not> rel x y"
    using that x by (rule 3(3))
  show ?case by (simp add: a b c \<open>\<not> P y\<close>)
qed

lemma filter_merge_wrt_2:
  assumes "\<And>x. x \<in> set xs \<Longrightarrow> P x \<Longrightarrow> False"
  shows "filter P (merge_wrt rel xs ys) = filter P ys"
  using assms
proof (induct rel xs ys rule: merge_wrt.induct)
  case (1 rel xs)
  thus ?case by (auto simp: filter_empty_conv)
next
  case (2 rel y ys)
  show ?case by simp
next
  case (3 rel x xs y ys)
  hence "\<not> P x" and x: "\<And>z. z \<in> set xs \<Longrightarrow> P z \<Longrightarrow> False" by auto
  have a: "filter P (merge_wrt rel xs ys) = filter P ys" if "x = y" using that x by (rule 3(1))
  have b: "filter P (merge_wrt rel xs (y # ys)) = filter P (y # ys)" if "x \<noteq> y" and "rel x y"
    using that x by (rule 3(2))
  have c: "filter P (merge_wrt rel (x # xs) ys) = filter P ys" if "x \<noteq> y" and "\<not> rel x y"
    using that 3(4) by (rule 3(3))
  show ?case by (simp add: a b c \<open>\<not> P x\<close>)
qed

lemma length_filter_le_1:
  assumes "length (filter P xs) \<le> 1" and "i < length xs" and "j < length xs"
    and "P (xs ! i)" and "P (xs ! j)"
  shows "i = j"
proof -
  have *: thesis if "a < b" and "b < length xs"
    and "\<And>as bs cs. as @ ((xs ! a) # (bs @ ((xs ! b) # cs))) = xs \<Longrightarrow> thesis" for a b thesis
  proof (rule that(3))
    from that(1, 2) have 1: "a < length xs" by simp
    with that(1, 2) have 2: "b - Suc a < length (drop (Suc a) xs)" by simp
    from that(1) \<open>a < length xs\<close> have eq: "xs ! b = drop (Suc a) xs ! (b - Suc a)" by simp
    show "(take a xs) @ ((xs ! a) # ((take (b - Suc a) (drop (Suc a) xs)) @ ((xs ! b) #
                  drop (Suc (b - Suc a)) (drop (Suc a) xs)))) = xs"
      by (simp only: eq id_take_nth_drop[OF 1, symmetric] id_take_nth_drop[OF 2, symmetric])
  qed
  show ?thesis
  proof (rule linorder_cases)
    assume "i < j"
    then obtain as bs cs where "as @ ((xs ! i) # (bs @ ((xs ! j) # cs))) = xs"
      using assms(3) by (rule *)
    hence "filter P xs = filter P (as @ ((xs ! i) # (bs @ ((xs ! j) # cs))))" by simp
    also from assms(4, 5) have "... = (filter P as) @ ((xs ! i) # ((filter P bs) @ ((xs ! j) # (filter P cs))))"
      by simp
    finally have "\<not> length (filter P xs) \<le> 1" by simp
    thus ?thesis using assms(1) ..
  next
    assume "j < i"
    then obtain as bs cs where "as @ ((xs ! j) # (bs @ ((xs ! i) # cs))) = xs"
      using assms(2) by (rule *)
    hence "filter P xs = filter P (as @ ((xs ! j) # (bs @ ((xs ! i) # cs))))" by simp
    also from assms(4, 5) have "... = (filter P as) @ ((xs ! j) # ((filter P bs) @ ((xs ! i) # (filter P cs))))"
      by simp
    finally have "\<not> length (filter P xs) \<le> 1" by simp
    thus ?thesis using assms(1) ..
  qed
qed

lemma length_filter_eq [simp]: "length (filter ((=) x) xs) = count_list xs x"
  by (induct xs, simp_all)

subsubsection \<open>@{const drop}\<close>

lemma nth_in_set_dropI:
  assumes "j \<le> i" and "i < length xs"
  shows "xs ! i \<in> set (drop j xs)"
  using assms
proof (induct xs arbitrary: i j)
  case Nil
  thus ?case by simp
next
  case (Cons x xs)
  show ?case
  proof (cases j)
    case 0
    with Cons(3) show ?thesis by (metis drop0 nth_mem)
  next
    case (Suc j0)
    with Cons(2) Suc_le_D obtain i0 where i: "i = Suc i0" by blast
    with Cons(2) have "j0 \<le> i0" by (simp add: \<open>j = Suc j0\<close>)
    moreover from Cons(3) have "i0 < length xs" by (simp add: i)
    ultimately have "xs ! i0 \<in> set (drop j0 xs)" by (rule Cons(1))
    thus ?thesis by (simp add: i \<open>j = Suc j0\<close>)
  qed
qed

subsubsection \<open>@{const count_list}\<close>

lemma count_list_append [simp]: "count_list (xs @ ys) a = count_list xs a + count_list ys a"
  by (induct xs, simp_all)

lemma count_list_upt [simp]: "count_list [a..<b] x = (if a \<le> x \<and> x < b then 1 else 0)"
proof (cases "a \<le> b")
  case True
  then obtain k where "b = a + k" using le_Suc_ex by blast
  show ?thesis unfolding \<open>b = a + k\<close> by (induct k, simp_all)
next
  case False
  thus ?thesis by simp
qed

subsubsection \<open>@{const sorted_wrt}\<close>

lemma sorted_wrt_upt_iff: "sorted_wrt rel [a..<b] \<longleftrightarrow> (\<forall>i j. a \<le> i \<longrightarrow> i < j \<longrightarrow> j < b \<longrightarrow> rel i j)"
proof (cases "a \<le> b")
  case True
  then obtain k where "b = a + k" using le_Suc_ex by blast
  show ?thesis unfolding \<open>b = a + k\<close>
  proof (induct k)
    case 0
    show ?case by simp
  next
    case (Suc k)
    show ?case
    proof (simp add: sorted_wrt_append Suc, intro iffI allI ballI impI conjI)
      fix i j
      assume "(\<forall>i\<ge>a. \<forall>j>i. j < a + k \<longrightarrow> rel i j) \<and> (\<forall>x\<in>{a..<a + k}. rel x (a + k))"
      hence 1: "\<And>i' j'. a \<le> i' \<Longrightarrow> i' < j' \<Longrightarrow> j' < a + k \<Longrightarrow> rel i' j'"
        and 2: "\<And>x. a \<le> x \<Longrightarrow> x < a + k \<Longrightarrow> rel x (a + k)" by simp_all
      assume "a \<le> i" and "i < j"
      assume "j < Suc (a + k)"
      hence "j < a + k \<or> j = a + k" by auto
      thus "rel i j"
      proof
        assume "j < a + k"
        with \<open>a \<le> i\<close> \<open>i < j\<close> show ?thesis by (rule 1)
      next
        assume "j = a + k"
        from \<open>a \<le> i\<close> \<open>i < j\<close> show ?thesis unfolding \<open>j = a + k\<close> by (rule 2)
      qed
    next
      fix i j
      assume "\<forall>i\<ge>a. \<forall>j>i. j < Suc (a + k) \<longrightarrow> rel i j" and "a \<le> i" and "i < j" and "j < a + k"
      thus "rel i j" by simp
    next
      fix x
      assume "x \<in> {a..<a + k}"
      hence "a \<le> x" and "x < a + k" by simp_all
      moreover assume "\<forall>i\<ge>a. \<forall>j>i. j < Suc (a + k) \<longrightarrow> rel i j"
      ultimately show "rel x (a + k)" by simp
    qed
  qed
next
  case False
  thus ?thesis by simp
qed

subsubsection \<open>@{const insort_wrt} and @{const merge_wrt}\<close>

lemma map_insort_wrt:
  assumes "\<And>x. x \<in> set xs \<Longrightarrow> r2 (f y) (f x) \<longleftrightarrow> r1 y x"
  shows "map f (insort_wrt r1 y xs) = insort_wrt r2 (f y) (map f xs)"
  using assms
proof (induct xs)
  case Nil
  show ?case by simp
next
  case (Cons x xs)
  have "x \<in> set (x # xs)" by simp
  hence "r2 (f y) (f x) = r1 y x" by (rule Cons(2))
  moreover have "map f (insort_wrt r1 y xs) = insort_wrt r2 (f y) (map f xs)"
  proof (rule Cons(1))
    fix x'
    assume "x' \<in> set xs"
    hence "x' \<in> set (x # xs)" by simp
    thus "r2 (f y) (f x') = r1 y x'" by (rule Cons(2))
  qed
  ultimately show ?case by simp
qed

lemma map_merge_wrt:
  assumes "f ` set xs \<inter> f ` set ys = {}"
    and "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set ys \<Longrightarrow> r2 (f x) (f y) \<longleftrightarrow> r1 x y"
  shows "map f (merge_wrt r1 xs ys) = merge_wrt r2 (map f xs) (map f ys)"
  using assms
proof (induct r1 xs ys rule: merge_wrt.induct)
  case (1 uu xs)
  show ?case by simp
next
  case (2 r1 v va)
  show ?case by simp
next
  case (3 r1 x xs y ys)
  from 3(4) have "f x \<noteq> f y" and 1: "f ` set xs \<inter> f ` set (y # ys) = {}"
    and 2: "f ` set (x # xs) \<inter> f ` set ys = {}" by auto
  from this(1) have "x \<noteq> y" by auto
  have eq2: "map f (merge_wrt r1 xs (y # ys)) = merge_wrt r2 (map f xs) (map f (y # ys))"
    if "r1 x y" using \<open>x \<noteq> y\<close> that 1
  proof (rule 3(2))
    fix a b
    assume "a \<in> set xs"
    hence "a \<in> set (x # xs)" by simp
    moreover assume "b \<in> set (y # ys)"
    ultimately show "r2 (f a) (f b) \<longleftrightarrow> r1 a b" by (rule 3(5))
  qed
  have eq3: "map f (merge_wrt r1 (x # xs) ys) = merge_wrt r2 (map f (x # xs)) (map f ys)"
    if "\<not> r1 x y" using \<open>x \<noteq> y\<close> that 2
  proof (rule 3(3))
    fix a b
    assume "a \<in> set (x # xs)"
    assume "b \<in> set ys"
    hence "b \<in> set (y # ys)" by simp
    with \<open>a \<in> set (x # xs)\<close> show "r2 (f a) (f b) \<longleftrightarrow> r1 a b" by (rule 3(5))
  qed
  have eq4: "r2 (f x) (f y) \<longleftrightarrow> r1 x y" by (rule 3(5), simp_all)
  show ?case by (simp add: eq2 eq3 eq4 \<open>f x \<noteq> f y\<close> \<open>x \<noteq> y\<close>)
qed

subsection \<open>Recursive Functions\<close>

locale recursive =
  fixes h' :: "'b \<Rightarrow> 'b"
  fixes b :: 'b
  assumes b_fixpoint: "h' b = b"
begin

context
  fixes Q :: "'a \<Rightarrow> bool"
  fixes g :: "'a \<Rightarrow> 'b"
  fixes h :: "'a \<Rightarrow> 'a"
begin

function (domintros) recfun_aux :: "'a \<Rightarrow> 'b" where
  "recfun_aux x = (if Q x then g x else h' (recfun_aux (h x)))"
  by pat_completeness auto

lemmas [induct del] = recfun_aux.pinduct

definition dom :: "'a \<Rightarrow> bool"
  where "dom x \<longleftrightarrow> (\<exists>k. Q ((h ^^ k) x))"

lemma domI:
  assumes "\<not> Q x \<Longrightarrow> dom (h x)"
  shows "dom x"
proof (cases "Q x")
  case True
  hence "Q ((h ^^ 0) x)" by simp
  thus ?thesis unfolding dom_def ..
next
  case False
  hence "dom (h x)" by (rule assms)
  then obtain k where "Q ((h ^^ k) (h x))" unfolding dom_def ..
  hence "Q ((h ^^ (Suc k)) x)" by (simp add: funpow_swap1)
  thus ?thesis unfolding dom_def ..
qed

lemma domD:
  assumes "dom x" and "\<not> Q x"
  shows "dom (h x)"
proof -
  from assms(1) obtain k where *: "Q ((h ^^ k) x)" unfolding dom_def ..
  with assms(2) have "k \<noteq> 0" using funpow_0 by fastforce
  then obtain m where "k = Suc m" using nat.exhaust by blast
  with * have "Q ((h ^^ m) (h x))" by (simp add: funpow_swap1)
  thus ?thesis unfolding dom_def ..
qed

lemma recfun_aux_domI:
  assumes "dom x"
  shows "recfun_aux_dom x"
proof -
  from assms obtain k where "Q ((h ^^ k) x)" unfolding dom_def ..
  thus ?thesis
  proof (induct k arbitrary: x)
    case 0
    hence "Q x" by simp
    with recfun_aux.domintros show ?case by blast
  next
    case (Suc k)
    from Suc(2) have "Q ((h ^^ k) (h x))" by (simp add: funpow_swap1)
    hence "recfun_aux_dom (h x)" by (rule Suc(1))
    with recfun_aux.domintros show ?case by blast
  qed
qed

lemma recfun_aux_domD:
  assumes "recfun_aux_dom x"
  shows "dom x"
  using assms
proof (induct x rule: recfun_aux.pinduct)
  case (1 x)
  show ?case
  proof (cases "Q x")
    case True
    with domI show ?thesis by blast
  next
    case False
    hence "dom (h x)" by (rule 1(2))
    thus ?thesis using domI by blast
  qed
qed

corollary recfun_aux_dom_alt: "recfun_aux_dom = dom"
  by (auto dest: recfun_aux_domI recfun_aux_domD)

definition "fun" :: "'a \<Rightarrow> 'b"
  where "fun x = (if recfun_aux_dom x then recfun_aux x else b)"

lemma simps: "fun x = (if Q x then g x else h' (fun (h x)))"
proof (cases "dom x")
  case True
  hence dom: "recfun_aux_dom x" by (rule recfun_aux_domI)
  show ?thesis
  proof (cases "Q x")
    case True
    with dom show ?thesis by (simp add: fun_def recfun_aux.psimps)
  next
    case False
    have "recfun_aux_dom (h x)" by (rule recfun_aux_domI, rule domD, fact True, fact False)
    thus ?thesis by (simp add: fun_def dom False recfun_aux.psimps)
  qed
next
  case False
  moreover have "\<not> Q x"
  proof
    assume "Q x"
    hence "dom x" using domI by blast
    with False show False ..
  qed
  moreover have "\<not> dom (h x)"
  proof
    assume "dom (h x)"
    hence "dom x" using domI by blast
    with False show False ..
  qed
  ultimately show ?thesis by (simp add: recfun_aux_dom_alt fun_def b_fixpoint split del: if_split)
qed

lemma eq_fixpointI: "\<not> dom x \<Longrightarrow> fun x = b"
  by (simp add: fun_def recfun_aux_dom_alt)

lemma pinduct: "dom x \<Longrightarrow> (\<And>x. dom x \<Longrightarrow> (\<not> Q x \<Longrightarrow> P (h x)) \<Longrightarrow> P x) \<Longrightarrow> P x"
  unfolding recfun_aux_dom_alt[symmetric] by (fact recfun_aux.pinduct)

end

end (* recursive *)

interpretation tailrec: recursive "\<lambda>x. x" undefined
  by (standard, fact refl)

subsection \<open>Binary Relations\<close>

lemma almost_full_on_Int:
  assumes "almost_full_on P1 A1" and "almost_full_on P2 A2"
  shows "almost_full_on (\<lambda>x y. P1 x y \<and> P2 x y) (A1 \<inter> A2)" (is "almost_full_on ?P ?A")
proof (rule almost_full_onI)
  fix f :: "nat \<Rightarrow> 'a"
  assume a: "\<forall>i. f i \<in> ?A"
  define g where "g = (\<lambda>i. (f i, f i))"
  from assms have "almost_full_on (prod_le P1 P2) (A1 \<times> A2)" by (rule almost_full_on_Sigma)
  moreover from a have "\<And>i. g i \<in> A1 \<times> A2" by (simp add: g_def)
  ultimately obtain i j where "i < j" and "prod_le P1 P2 (g i) (g j)" by (rule almost_full_onD)
  from this(2) have "?P (f i) (f j)" by (simp add: g_def prod_le_def)
  with \<open>i < j\<close> show "good ?P f" by (rule goodI)
qed

corollary almost_full_on_same:
  assumes "almost_full_on P1 A" and "almost_full_on P2 A"
  shows "almost_full_on (\<lambda>x y. P1 x y \<and> P2 x y) A"
proof -
  from assms have "almost_full_on (\<lambda>x y. P1 x y \<and> P2 x y) (A \<inter> A)" by (rule almost_full_on_Int)
  thus ?thesis by simp
qed

context ord
begin

definition is_le_rel :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
  where "is_le_rel rel = (rel = (=) \<or> rel = (\<le>) \<or> rel = (<))"

lemma is_le_relI [simp]: "is_le_rel (=)" "is_le_rel (\<le>)" "is_le_rel (<)"
  by (simp_all add: is_le_rel_def)

lemma is_le_relE:
  assumes "is_le_rel rel"
  obtains "rel = (=)" | "rel = (\<le>)" | "rel = (<)"
  using assms unfolding is_le_rel_def by blast

end (* ord *)

context preorder
begin

lemma is_le_rel_le:
  assumes "is_le_rel rel"
  shows "rel x y \<Longrightarrow> x \<le> y"
  using assms by (rule is_le_relE, auto dest: less_imp_le)

lemma is_le_rel_trans:
  assumes "is_le_rel rel"
  shows "rel x y \<Longrightarrow> rel y z \<Longrightarrow> rel x z"
  using assms by (rule is_le_relE, auto dest: order_trans less_trans)

lemma is_le_rel_trans_le_left:
  assumes "is_le_rel rel"
  shows "x \<le> y \<Longrightarrow> rel y z \<Longrightarrow> x \<le> z"
  using assms by (rule is_le_relE, auto dest: order_trans le_less_trans less_imp_le)

lemma is_le_rel_trans_le_right:
  assumes "is_le_rel rel"
  shows "rel x y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
  using assms by (rule is_le_relE, auto dest: order_trans less_le_trans less_imp_le)

lemma is_le_rel_trans_less_left:
  assumes "is_le_rel rel"
  shows "x < y \<Longrightarrow> rel y z \<Longrightarrow> x < z"
  using assms by (rule is_le_relE, auto dest: less_le_trans less_imp_le)

lemma is_le_rel_trans_less_right:
  assumes "is_le_rel rel"
  shows "rel x y \<Longrightarrow> y < z \<Longrightarrow> x < z"
  using assms by (rule is_le_relE, auto dest: le_less_trans less_imp_le)

end (* preorder *)

context order
begin

lemma is_le_rel_distinct:
  assumes "is_le_rel rel"
  shows "rel x y \<Longrightarrow> x \<noteq> y \<Longrightarrow> x < y"
  using assms by (rule is_le_relE, auto)

lemma is_le_rel_antisym:
  assumes "is_le_rel rel"
  shows "rel x y \<Longrightarrow> rel y x \<Longrightarrow> x = y"
  using assms by (rule is_le_relE, auto)

end (* order *)

end (* theory *)


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2009         |
            |                   June 2009  (modified)   |
            |                October 2009  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2009         |
            |                  April 2011  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                  April 2016  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory Infra_ren
imports Infra_HOL
begin

(* -------------------------- *
      renaming (Intra_ren)
 * -------------------------- *)

(*
consts
  fun_to_rel :: "('a => 'a) => ('a * 'a) set"  ("<rel>")

defs
  fun_to_rel_def : "<rel> f == {(x, f x)|x. True}"
*)

definition
  fun_to_rel :: "('a => 'a) => ('a * 'a) set"  ("<rel>")
  where
  "<rel> f == {(x, f x)|x. True}"

consts
  diff_fun :: "('x => 'a) set => bool"

(*
consts
  Renaming1_event_fun   :: "'a => 'a => ('a => 'a)"
  Renaming1_channel_fun :: "('x => 'a) => ('x => 'a) => ('a => 'a)"

  Renaming1_event   :: "'a => 'a => ('a * 'a) set"   ("_<-->_" [100,100] 100)

  Renaming1_channel :: "('x => 'a) => ('x => 'a) => ('a * 'a) set"
                                                    ("_<==>_" [100,100] 100)

  Renaming2_event_fun   :: "'a set => 'a => ('a => 'a)"
  Renaming2_channel_fun :: "('x => 'a) => ('x => 'a) => ('a => 'a)"

  Renaming2_event   :: "'a set => 'a => ('a * 'a) set"   ("_<<-_" [100,100] 100)

  Renaming2_channel :: "('x => 'a) => ('x => 'a) => ('a * 'a) set"
                                                    ("_<==_" [100,100] 100)

defs
  Renaming1_event_fun_def : "Renaming1_event_fun a b ==
              (%c. if (c=a) then b else if (c=b) then a else c)"

  Renaming1_channel_fun_def : "Renaming1_channel_fun f g ==
              (%c. if (ALL x y. f x ~= g y)
                   then      if (EX x. f x = c) then g(inv f c)
                        else if (EX x. g x = c) then f(inv g c)
                        else c
                   else c)"

  Renaming1_event_def   : "a<-->b == <rel> (Renaming1_event_fun a b)"

  Renaming1_channel_def : "f<==>g == <rel> (Renaming1_channel_fun f g)"

defs
  Renaming2_event_fun_def : "Renaming2_event_fun A b ==
              (%c. if (c:A) then b else c)"

  Renaming2_channel_fun_def : "Renaming2_channel_fun f g ==
              (%c. if (ALL x y. f x ~= g y)
                   then      if (EX x. f x = c) then g(inv f c)
                        else c
                   else c)"
  Renaming2_event_def   : "A<<-b == <rel> (Renaming2_event_fun A b)"
  Renaming2_channel_def : "f<==g == <rel> (Renaming2_channel_fun f g)"
*)

definition
  Renaming1_event_fun   :: "'a => 'a => ('a => 'a)"
  where
    "Renaming1_event_fun a b ==
              (%c. if (c=a) then b else if (c=b) then a else c)"

definition
  Renaming1_channel_fun :: "('x => 'a) => ('x => 'a) => ('a => 'a)"
  where
  "Renaming1_channel_fun f g ==
              (%c. if (ALL x y. f x ~= g y)
                   then      if (EX x. f x = c) then g(inv f c)
                        else if (EX x. g x = c) then f(inv g c)
                        else c
                   else c)"

definition
  Renaming1_event   :: "'a => 'a => ('a * 'a) set"   ("_<-->_" [100,100] 100)
  where
  "a<-->b == <rel> (Renaming1_event_fun a b)"

definition
  Renaming1_channel :: "('x => 'a) => ('x => 'a) => ('a * 'a) set"
                                                    ("_<==>_" [100,100] 100)
  where "f<==>g == <rel> (Renaming1_channel_fun f g)"

definition
  Renaming2_event_fun   :: "'a set => 'a => ('a => 'a)"
  where
  "Renaming2_event_fun A b ==
              (%c. if (c:A) then b else c)"

definition
  Renaming2_channel_fun :: "('x => 'a) => ('x => 'a) => ('a => 'a)"
  where
  "Renaming2_channel_fun f g ==
              (%c. if (ALL x y. f x ~= g y)
                   then      if (EX x. f x = c) then g(inv f c)
                        else c
                   else c)"

definition
  Renaming2_event   :: "'a set => 'a => ('a * 'a) set"   ("_<<-_" [100,100] 100)
  where
  "A<<-b == <rel> (Renaming2_event_fun A b)"

definition
  Renaming2_channel :: "('x => 'a) => ('x => 'a) => ('a * 'a) set"
                                                    ("_<==_" [100,100] 100)
  where "f<==g == <rel> (Renaming2_channel_fun f g)"

abbreviation
  Renaming2_signle_event :: "'a => 'a => ('a * 'a) set"  ("_<--_" [100,100] 100)
where "a<--b == {a}<<-b"

lemmas Renaming_event_fun_def =
       Renaming1_event_fun_def
       Renaming2_event_fun_def

lemmas Renaming_channel_fun_def =
       Renaming1_channel_fun_def
       Renaming2_channel_fun_def

lemmas Renaming_event_def =
       Renaming1_event_def
       Renaming2_event_def

lemmas Renaming_channel_def =
       Renaming1_channel_def
       Renaming2_channel_def

lemma Renaming_event_fun_commut:
  "Renaming1_event_fun a b = Renaming1_event_fun b a"
apply (simp add: Renaming_event_fun_def)
(* apply (simp add: expand_fun_eq) for Isabelle 2009 *)
apply (simp add: fun_eq_iff)
done

lemma Renaming_event_commut: "(a<-->b) = (b<-->a)"
apply (simp add: Renaming_event_def)
apply (simp add: Renaming_event_fun_commut)
done

lemma Renaming_channel_fun_commut:
  "Renaming1_channel_fun f g = Renaming1_channel_fun g f"
(* apply (simp add: expand_fun_eq) for Isabelle 2009 *)
apply (simp add: fun_eq_iff)
apply (simp add: Renaming_channel_fun_def)
apply (case_tac "(ALL x y. f x ~= g y) & (ALL x y. g x ~= f y)")
apply (force)

apply (subgoal_tac "~(ALL x y. f x ~= g y) & ~(ALL x y. g x ~= f y)")
apply (simp (no_asm_simp))
apply (auto)
apply (rule_tac x="y" in exI)
apply (rule_tac x="x" in exI)
apply (simp)
apply (rule_tac x="y" in exI)
apply (rule_tac x="x" in exI)
apply (simp)
done

lemma Renaming_channel_commut: "(f<==>g) = (g<==>f)"
apply (simp add: Renaming_channel_def)
apply (simp add: Renaming_channel_fun_commut)
done

lemmas Renaming_commut = Renaming_event_commut Renaming_channel_commut

lemma Renaming_channel_fun_f:
   "[| inj f ; ALL x y. f x ~= g y |] ==> Renaming1_channel_fun f g (f x) = g x"
   "[| inj f ; ALL x y. f x ~= g y |] ==> Renaming2_channel_fun f g (f x) = g x"
by (auto simp add: Renaming_channel_fun_def)

lemma Renaming_channel_fun_g:
   "[| inj g ; ALL x y. f x ~= g y |] ==> Renaming1_channel_fun f g (g x) = f x"
by (auto simp add: Renaming_channel_fun_def)

lemma Renaming_channel_fun_h:
   "[| ALL x y. f x ~= g y ; ALL x y. f x ~= h y ; ALL x y. g x ~= h y |]
    ==> Renaming1_channel_fun f g (h x) = h x"
   "[| ALL x y. f x ~= g y ; ALL x y. f x ~= h y |]
    ==> Renaming2_channel_fun f g (h x) = h x"
by (auto simp add: Renaming_channel_fun_def)

lemma Renaming_channel_fun_map_f:
  "[| inj f; ALL x y. f x ~= g y |] ==> Renaming1_channel_fun f g ` f ` X = g ` X"
  "[| inj f; ALL x y. f x ~= g y |] ==> Renaming2_channel_fun f g ` f ` X = g ` X"
apply (simp add: image_def, auto simp add: Renaming_channel_fun_f)+
done

lemma Renaming_channel_fun_map_g:
  "[| inj g; ALL x y. f x ~= g y |] ==> Renaming1_channel_fun f g ` g ` X = f ` X"
apply (simp add: image_def, auto simp add: Renaming_channel_fun_g)
done

lemma Renaming_channel_fun_map_h:
   "[| (ALL x y. f x ~= h y) ;
       (ALL x y. g x ~= h y) ;
       ALL x y. f x ~= g y |]
    ==> Renaming1_channel_fun f g ` h ` X = h ` X"
   "[| (ALL x y. f x ~= h y) ;
       ALL x y. f x ~= g y |]
    ==> Renaming2_channel_fun f g ` h ` X = h ` X"
apply (simp add: image_def, auto simp add: Renaming_channel_fun_h)
apply (simp add: image_def, auto simp add: Renaming_channel_fun_h)
done

lemmas Renaming_channel_fun_simp
     = Renaming_channel_fun_map_f
       Renaming_channel_fun_map_g
       Renaming_channel_fun_map_h
       Renaming_channel_fun_f
       Renaming_channel_fun_g
       Renaming_channel_fun_h

(* --- Ren --- *)

lemma pair_in_Renaming_channel_1:
   "[| inj f; inj g; ALL x y. f x ~= g y |]
    ==> (a, g x) : f<==>g = (a = f x)"
apply (simp add: Renaming_channel_def)
apply (simp add: Renaming_channel_fun_def)
apply (simp add: fun_to_rel_def)
apply (auto)
apply (rotate_tac -1)
apply (drule sym)
apply (simp)
apply (simp add: inj_on_def)
apply (fast)
done

lemma pair_in_Renaming_channel_2:
   "[| inj f; inj g; ALL x y. f x ~= g y |] ==> (a, g x) : g<==>f = (a = f x)"
apply (simp add: Renaming_commut)
apply (simp add: pair_in_Renaming_channel_1)
done

lemma pair_in_Renaming1_channel_3:
   "[| inj f; inj g; ALL x y. f x ~= g y |]
    ==> (f x, a) : f<==>g = (a = g x)"
apply (simp add: Renaming_channel_def)
apply (simp add: Renaming_channel_fun_def)
apply (simp add: fun_to_rel_def)
apply (auto)
done

lemma pair_in_Renaming2_channel_3:
   "[| inj f; inj g; ALL x y. f x ~= g y |]
    ==> (f x, a) : f<==g = (a = g x)"
apply (simp add: Renaming_channel_def)
apply (simp add: Renaming_channel_fun_def)
apply (simp add: fun_to_rel_def)
apply (auto)
done

lemmas pair_in_Renaming_channel_3 =
       pair_in_Renaming1_channel_3
       pair_in_Renaming2_channel_3

lemma pair_in_Renaming_channel_4:
   "[| inj f; inj g; ALL x y. f x ~= g y |]
    ==> (f x, a) : g<==>f = (a = g x)"
apply (simp add: Renaming_commut)
apply (simp add: pair_in_Renaming_channel_3)
done

lemma pair_in_Renaming_channel_5:
   "[| inj f; inj g;
       ALL x y. f x ~= g y ;
       ALL x. b ~= f x ;
       ALL x. b ~= g x |] ==> (a, b) : f<==>g = (a = b)"
apply (simp add: Renaming_channel_def)
apply (simp add: Renaming_channel_fun_def)
apply (simp add: fun_to_rel_def)
apply (auto)
done

lemma pair_in_Renaming1_channel_6:
   "[| inj f; inj g;
       ALL x y. f x ~= g y ;
       ALL x. a ~= f x ;
       ALL x. a ~= g x |] ==> (a, b) : f<==>g = (a = b)"
apply (simp add: Renaming_channel_def)
apply (simp add: Renaming_channel_fun_def)
apply (simp add: fun_to_rel_def)
apply (auto)
done

lemma pair_in_Renaming2_channel_6:
   "[| inj f; inj g;
       ALL x y. f x ~= g y ;
       ALL x. a ~= f x |] ==> (a, b) : f<==g = (a = b)"
apply (simp add: Renaming_channel_def)
apply (simp add: Renaming_channel_fun_def)
apply (simp add: fun_to_rel_def)
apply (auto)
done

lemmas pair_in_Renaming_channel_6 =
       pair_in_Renaming1_channel_6
       pair_in_Renaming2_channel_6

lemmas pair_in_Renaming_channel =
       pair_in_Renaming_channel_1
       pair_in_Renaming_channel_2
       pair_in_Renaming_channel_3
       pair_in_Renaming_channel_4
       pair_in_Renaming_channel_5
       pair_in_Renaming_channel_6

(* --- sym --- *)

lemma Renaming_channel_sym_rule:
  "[| inj f ; inj g ; ((b, a) : f<==>g) |] ==> ((a, b) : f<==>g)"
apply (case_tac "~ (ALL x y. f x ~= g y)")
 apply (subgoal_tac "(f<==>g) = <rel> (%c. c)")
 apply (simp add: fun_to_rel_def)
 apply (simp (no_asm_simp) add: Renaming_channel_def Renaming_channel_fun_def)

 apply (simp add: Renaming_channel_def Renaming_channel_fun_def)
 apply (simp add: fun_to_rel_def)
 apply (auto)
done

lemma Renaming_channel_sym:
  "[| inj f ; inj g |] ==> ((b, a) : f<==>g) = ((a, b) : f<==>g)"
apply (rule iffI)
apply (rule Renaming_channel_sym_rule, simp_all)
apply (rule Renaming_channel_sym_rule, simp_all)
done

(* --- inj --- *)

lemma inj_Renaming_channel_fun:
  "[| inj f; inj g |] ==> inj (Renaming1_channel_fun f g)"
apply (case_tac "~ (ALL x y. f x ~= g y)")
 apply (subgoal_tac "Renaming1_channel_fun f g = (%c. c)")
 apply (simp)
 apply (simp (no_asm_simp) add: Renaming_channel_def Renaming_channel_fun_def)
apply (simp add: Renaming_channel_fun_def)
apply (simp (no_asm_simp) add: inj_on_def)
apply (elim add_not_eq_symE)
apply (intro conjI allI impI)
apply (auto)
apply (simp_all add: inj_on_def)
apply (blast)
apply (blast)
done

lemma Renaming_channel_unique:
  "ALL a b c. ((a, b) : f<==>g & (a, c) : f<==>g) --> b=c"
  "ALL a b c. ((a, b) : f<==g & (a, c) : f<==g) --> b=c"
apply (simp add: fun_to_rel_def Renaming_channel_def)
apply (simp add: fun_to_rel_def Renaming_channel_def)
done

lemma Renaming_channel_independ:
   "ALL f1 f2 g1 g2 a b c d d'.
   (inj f1 & inj f2 & inj g1 & inj g2 &
   (ALL x y. f1 x ~= f2 y) &
   (ALL x y. f1 x ~= g1 y) &
   (ALL x y. f1 x ~= g2 y) &
   (ALL x y. f2 x ~= g1 y) &
   (ALL x y. f2 x ~= g2 y) &
   (ALL x y. g1 x ~= g2 y) &
    (a,b) : f1<==>f2 &
    (b,d) : g1<==>g2 &
    (a,c) : g1<==>g2 &
   (c,d') : f1<==>f2)
   --> d = d'"
apply (intro allI impI)
apply (elim conjE exE)
apply (elim add_not_eq_symE)

apply (case_tac "(ALL x. a ~= f1 x) & (ALL x. a ~= f2 x)")
 apply (case_tac "(ALL x. a ~= g1 x) & (ALL x. a ~= g2 x)")
  apply (simp add: pair_in_Renaming_channel)

  apply (elim disjE conjE exE)
  apply (simp add: pair_in_Renaming_channel)
  apply (elim disjE conjE exE)
  apply (simp add: pair_in_Renaming_channel)
  apply (simp add: pair_in_Renaming_channel)
  apply (simp add: pair_in_Renaming_channel)

 apply (case_tac "(ALL x. a ~= g1 x) & (ALL x. a ~= g2 x)")
  apply (simp add: pair_in_Renaming_channel)

  apply (elim disjE conjE exE)
  apply (simp add: pair_in_Renaming_channel)
  apply (simp add: pair_in_Renaming_channel)
  apply (simp add: pair_in_Renaming_channel)

apply (auto)
done

end


header {*Predicates for Terms, Formulas and Substitution*}

theory Coding_Predicates
imports Coding Sigma
begin

declare succ_iff [simp del]

text {*This material comes from Section 3, greatly modified for de Bruijn syntax.*}

section {*Predicates for atomic terms*}

subsection {*Free Variables*}

definition is_Var :: "hf \<Rightarrow> bool" where "is_Var x \<equiv> Ord x \<and> 0 \<^bold>\<in> x"

definition VarP :: "tm \<Rightarrow> fm" where "VarP x \<equiv> OrdP x AND Zero IN x"

lemma VarP_eqvt [eqvt]: "(p \<bullet> VarP x) = VarP (p \<bullet> x)"
  by (simp add: VarP_def)

lemma VarP_fresh_iff [simp]: "a \<sharp> VarP x \<longleftrightarrow> a \<sharp> x"
  by (simp add: VarP_def)

lemma eval_fm_VarP [simp]:  "eval_fm e (VarP x) \<longleftrightarrow> is_Var \<lbrakk>x\<rbrakk>e"
  by (simp add: VarP_def is_Var_def)

lemma VarP_sf [iff]: "Sigma_fm (VarP x)"
  by (auto simp: VarP_def)

lemma VarP_subst [simp]: "(VarP x)(i::=t) = VarP (subst i t x) "
  by (simp add: VarP_def)

lemma VarP_cong: "H \<turnstile> x EQ x' \<Longrightarrow> H \<turnstile> VarP x IFF VarP x'"
  by (rule P1_cong) auto

lemma VarP_HPairE [intro!]: "insert (VarP (HPair x y)) H \<turnstile> A"
  by (auto simp: VarP_def)

lemma is_Var_succ_iff [simp]: "is_Var (succ x) = Ord x"
  by (metis Ord_succ_iff is_Var_def succ_iff zero_in_Ord)

lemma is_Var_q_Var [iff]: "is_Var (q_Var i)"
  by (simp add: q_Var_def)

definition decode_Var :: "hf \<Rightarrow> name"
  where "decode_Var x \<equiv> name_of_nat (nat_of_ord (pred x))"

lemma decode_Var_q_Var [simp]: "decode_Var (q_Var i) = i"
  by (simp add: decode_Var_def q_Var_def)

lemma is_Var_imp_decode_Var: "is_Var x \<Longrightarrow> x = \<lbrakk>\<lceil>Var (decode_Var x)\<rceil>\<rbrakk> e"
  by (simp add: is_Var_def quot_Var decode_Var_def) (metis hempty_iff succ_pred)

lemma is_Var_iff: "is_Var v \<longleftrightarrow> v = succ (ord_of (nat_of_name (decode_Var v)))"
  by (metis eval_tm_ORD_OF eval_tm_SUCC is_Var_imp_decode_Var quot_Var is_Var_succ_iff Ord_ord_of)

lemma decode_Var_inject [simp]: "is_Var v \<Longrightarrow> is_Var v' \<Longrightarrow> decode_Var v = decode_Var v' \<longleftrightarrow> v=v'"
  by (metis is_Var_iff)

subsection {*De Bruijn Indexes*}

definition is_Ind :: "hf \<Rightarrow> bool"
  where "is_Ind x \<equiv> (\<exists>m. Ord m \<and> x = \<langle>htuple 6, m\<rangle>)"

abbreviation Q_Ind :: "tm \<Rightarrow> tm"
  where "Q_Ind k \<equiv> HPair (HTuple 6) k"

nominal_function IndP :: "tm \<Rightarrow> fm"
  where "atom m \<sharp> x \<Longrightarrow>
    IndP x = Ex m (OrdP (Var m) AND x EQ HPair (HTuple 6) (Var m))"
  by (auto simp: eqvt_def IndP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows IndP_fresh_iff [simp]: "a \<sharp> IndP x \<longleftrightarrow> a \<sharp> x"                (is ?thesis1)
    and eval_fm_IndP [simp]:   "eval_fm e (IndP x) \<longleftrightarrow> is_Ind \<lbrakk>x\<rbrakk>e"  (is ?thesis2)
    and IndP_sf [iff]:         "Sigma_fm (IndP x)"                   (is ?thsf)
    and OrdP_IndP_Q_Ind:       "{OrdP x} \<turnstile> IndP (Q_Ind x)"           (is ?thqind)
proof -
  obtain m::name where "atom m \<sharp> x"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis2 ?thsf ?thqind
    by (auto simp: is_Ind_def intro: Ex_I [where x=x])
qed

lemma IndP_Q_Ind: "H \<turnstile> OrdP x \<Longrightarrow> H \<turnstile> IndP (Q_Ind x)"
  by (rule cut1 [OF OrdP_IndP_Q_Ind])

lemma subst_fm_IndP [simp]: "(IndP t)(i::=x) = IndP (subst i x t)"
proof -
  obtain m::name where "atom m \<sharp> (i,t,x)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: IndP.simps [of m])
qed

lemma IndP_cong: "H \<turnstile> x EQ x' \<Longrightarrow> H \<turnstile> IndP x IFF IndP x'"
  by (rule P1_cong) auto

definition decode_Ind :: "hf \<Rightarrow> nat"
  where "decode_Ind x \<equiv> nat_of_ord (hsnd x)"

lemma is_Ind_pair_iff [simp]: "is_Ind \<langle>x, y\<rangle> \<longleftrightarrow> x = htuple 6 \<and> Ord y"
  by (auto simp: is_Ind_def)

subsection {*Various syntactic lemmas*}

lemma eval_Var_q: "\<lbrakk>\<lceil>Var i\<rceil>\<rbrakk> e = q_Var i"
  by (simp add: quot_tm_def q_Var_def)

lemma is_Var_eval_Var [simp]: "is_Var \<lbrakk>\<lceil>Var i\<rceil>\<rbrakk>e"
  by (metis decode_Var_q_Var is_Var_imp_decode_Var is_Var_q_Var)

section {*The predicate @{text SeqCTermP}, for Terms and Constants*}

(*SeqCTerm(s,k,t) \<equiv> LstSeq(s,k,t) \<and> (\<forall>l\<in>k)[s l=0 \<or> Var(s l)\<or>(\<exists>m,n\<in>l)[s l = \<langle>Eats, s m, s n\<rangle>]]*)
definition SeqCTerm :: "bool \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
  where "SeqCTerm vf s k t \<equiv> BuildSeq (\<lambda>u. u=0 \<or> vf \<and> is_Var u) (\<lambda>u v w. u = q_Eats v w) s k t"

nominal_function SeqCTermP :: "bool \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom l \<sharp> (s,k,sl,m,n,sm,sn);  atom sl \<sharp> (s,m,n,sm,sn);
          atom m \<sharp> (s,n,sm,sn);  atom n \<sharp> (s,sm,sn);
          atom sm \<sharp> (s,sn);  atom sn \<sharp> (s)\<rbrakk> \<Longrightarrow>
    SeqCTermP vf s k t =
      LstSeqP s k t AND
      All2 l (SUCC k) (Ex sl (HPair (Var l) (Var sl) IN s AND
               (Var sl EQ Zero OR (if vf then VarP (Var sl) else Fls) OR
                Ex m (Ex n (Ex sm (Ex sn (Var m IN Var l AND Var n IN Var l AND
                       HPair (Var m) (Var sm) IN s AND HPair (Var n) (Var sn) IN s AND
                       Var sl EQ Q_Eats (Var sm) (Var sn))))))))"
  by (auto simp: eqvt_def SeqCTermP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows SeqCTermP_fresh_iff [simp]:
       "a \<sharp> SeqCTermP vf s k t \<longleftrightarrow> a \<sharp> s \<and> a \<sharp> k \<and> a \<sharp> t"  (is ?thesis1)
    and eval_fm_SeqCTermP [simp]:
       "eval_fm e (SeqCTermP vf s k t) \<longleftrightarrow> SeqCTerm vf \<lbrakk>s\<rbrakk>e \<lbrakk>k\<rbrakk>e \<lbrakk>t\<rbrakk>e"    (is ?thesis2)
    and SeqCTermP_sf [iff]:
       "Sigma_fm (SeqCTermP vf s k t)"   (is ?thsf)
    and SeqCTermP_imp_LstSeqP:
      "{ SeqCTermP vf s k t } \<turnstile> LstSeqP s k t"  (is ?thlstseq)
    and SeqCTermP_imp_OrdP [simp]:
      "{ SeqCTermP vf s k t } \<turnstile> OrdP k"  (is ?thord)
proof -
  obtain l::name and sl::name and m::name and n::name and sm::name and sn::name
    where atoms: "atom l \<sharp> (s,k,sl,m,n,sm,sn)"   "atom sl \<sharp> (s,m,n,sm,sn)"
        "atom m \<sharp> (s,n,sm,sn)"   "atom n \<sharp> (s,sm,sn)"
        "atom sm \<sharp> (s,sn)"   "atom sn \<sharp> (s)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thsf ?thlstseq ?thord
    by (auto simp: LstSeqP.simps)
  show ?thesis2 using atoms
    by (simp cong: conj_cong add: LstSeq_imp_Ord SeqCTerm_def BuildSeq_def Builds_def
             HBall_def HBex_def q_Eats_def Fls_def
             Seq_iff_app [of "\<lbrakk>s\<rbrakk>e", OF LstSeq_imp_Seq_succ]
             Ord_trans [of _ _ "succ \<lbrakk>k\<rbrakk>e"])
qed

lemma SeqCTermP_subst [simp]:
      "(SeqCTermP vf s k t)(j::=w) = SeqCTermP vf (subst j w s) (subst j w k) (subst j w t)"
proof -
  obtain l::name and sl::name and m::name and n::name and sm::name and sn::name
    where "atom l \<sharp> (j,w,s,k,sl,m,n,sm,sn)"   "atom sl \<sharp> (j,w,s,m,n,sm,sn)"
          "atom m \<sharp> (j,w,s,n,sm,sn)"   "atom n \<sharp> (j,w,s,sm,sn)"
          "atom sm \<sharp> (j,w,s,sn)"   "atom sn \<sharp> (j,w,s)"
    by (metis obtain_fresh)
  thus ?thesis
    by (force simp add: SeqCTermP.simps [of l _ _ sl m n sm sn])
qed

declare SeqCTermP.simps [simp del]

abbreviation SeqTerm :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
  where "SeqTerm \<equiv> SeqCTerm True"

abbreviation SeqTermP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "SeqTermP \<equiv> SeqCTermP True"

abbreviation SeqConst :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
  where "SeqConst \<equiv> SeqCTerm False"

abbreviation SeqConstP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "SeqConstP \<equiv> SeqCTermP False"

lemma SeqConst_imp_SeqTerm: "SeqConst s k x \<Longrightarrow> SeqTerm s k x"
 by (auto simp: SeqCTerm_def intro: BuildSeq_mono)

lemma SeqConstP_imp_SeqTermP: "{SeqConstP s k t} \<turnstile> SeqTermP s k t"
proof -
  obtain l::name and sl::name and m::name and n::name and sm::name and sn::name
    where "atom l \<sharp> (s,k,t,sl,m,n,sm,sn)"   "atom sl \<sharp> (s,k,t,m,n,sm,sn)"
          "atom m \<sharp> (s,k,t,n,sm,sn)"   "atom n \<sharp> (s,k,t,sm,sn)"
          "atom sm \<sharp> (s,k,t,sn)"   "atom sn \<sharp> (s,k,t)"
    by (metis obtain_fresh)
  thus ?thesis
    apply (auto simp: SeqCTermP.simps [of l s k sl m n sm sn])
    apply (rule Ex_I [where x="Var l"], auto)
    apply (rule Ex_I [where x = "Var sl"], force intro: Disj_I1)
    apply (rule Ex_I [where x = "Var sl"], simp)
    apply (rule Conj_I, blast)
    apply (rule Disj_I2)+
    apply (rule Ex_I [where x = "Var m"], simp)
    apply (rule Ex_I [where x = "Var n"], simp)
    apply (rule Ex_I [where x = "Var sm"], simp)
    apply (rule Ex_I [where x = "Var sn"], auto)
    done
qed

section {*The predicates @{text TermP} and @{text ConstP}*}

subsection {*Definition*}

definition CTerm :: "bool \<Rightarrow> hf \<Rightarrow> bool"
  where "CTerm vf t \<equiv> (\<exists>s k. SeqCTerm vf s k t)"

nominal_function CTermP :: "bool \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom k \<sharp> (s,t); atom s \<sharp> t\<rbrakk> \<Longrightarrow>
    CTermP vf t = Ex s (Ex k (SeqCTermP vf (Var s) (Var k) t))"
  by (auto simp: eqvt_def CTermP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows CTermP_fresh_iff [simp]: "a \<sharp> CTermP vf t \<longleftrightarrow> a \<sharp> t"            (is ?thesis1)
    and eval_fm_CTermP [simp] :"eval_fm e (CTermP vf t) \<longleftrightarrow> CTerm vf \<lbrakk>t\<rbrakk>e"  (is ?thesis2)
    and CTermP_sf [iff]: "Sigma_fm (CTermP vf t)"                      (is ?thsf)
proof -
  obtain k::name and s::name  where "atom k \<sharp> (s,t)" "atom s \<sharp> t"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis2 ?thsf
    by (auto simp: CTerm_def)
qed

lemma CTermP_subst [simp]: "(CTermP vf i)(j::=w) = CTermP vf (subst j w i)"
proof -
  obtain k::name and s::name  where "atom k \<sharp> (s,i,j,w)" "atom s \<sharp> (i,j,w)"
    by (metis obtain_fresh)
  thus ?thesis
    by (simp add: CTermP.simps [of k s])
qed

abbreviation Term :: "hf \<Rightarrow> bool"
  where "Term \<equiv> CTerm True"

abbreviation TermP :: "tm \<Rightarrow> fm"
  where "TermP \<equiv> CTermP True"

abbreviation Const :: "hf \<Rightarrow> bool"
  where "Const \<equiv> CTerm False"

abbreviation ConstP :: "tm \<Rightarrow> fm"
  where "ConstP \<equiv> CTermP False"

subsection {*Correctness: It Corresponds to Quotations of Real Terms*}

lemma wf_Term_quot_dbtm [simp]: "wf_dbtm u \<Longrightarrow> Term \<lbrakk>quot_dbtm u\<rbrakk>e"
by (induct rule: wf_dbtm.induct)
   (auto simp: CTerm_def SeqCTerm_def q_Eats_def intro: BuildSeq_combine BuildSeq_exI)

corollary Term_quot_tm [iff]: fixes t :: tm  shows "Term \<lbrakk>\<lceil>t\<rceil>\<rbrakk>e"
  by (metis quot_tm_def wf_Term_quot_dbtm wf_dbtm_trans_tm)

lemma SeqCTerm_imp_wf_dbtm:
  assumes "SeqCTerm vf s k x"
  shows "\<exists>t::dbtm. wf_dbtm t \<and> x = \<lbrakk>quot_dbtm t\<rbrakk>e"
using assms [unfolded SeqCTerm_def]
proof (induct x rule: BuildSeq_induct)
  case (B x) thus ?case
    by auto (metis ORD_OF.simps(2) Var quot_dbtm.simps(2) is_Var_imp_decode_Var quot_Var)
next
  case (C x y z)
  then obtain tm1::dbtm and tm2::dbtm
    where "wf_dbtm tm1" "y = \<lbrakk>quot_dbtm tm1\<rbrakk>e"
          "wf_dbtm tm2" "z = \<lbrakk>quot_dbtm tm2\<rbrakk>e"
    by blast
  thus ?case
    by (auto simp: wf_dbtm.intros C q_Eats_def intro!: exI [of _ "DBEats tm1 tm2"])
qed

corollary Term_imp_wf_dbtm:
  assumes "Term x" obtains t where "wf_dbtm t" "x = \<lbrakk>quot_dbtm t\<rbrakk>e"
  by (metis assms SeqCTerm_imp_wf_dbtm CTerm_def)

corollary Term_imp_is_tm: assumes "Term x" obtains t::tm where "x = \<lbrakk>\<lceil>t\<rceil>\<rbrakk> e"
  by (metis assms Term_imp_wf_dbtm quot_tm_def wf_dbtm_imp_is_tm)

lemma Term_Var: "Term (q_Var i)"
  using wf_Term_quot_dbtm [of "DBVar i"]
  by (metis Term_quot_tm is_Var_imp_decode_Var is_Var_q_Var)

lemma Term_Eats: assumes x: "Term x" and y: "Term y" shows "Term (q_Eats x y)"
proof -
  obtain t u  where "x = \<lbrakk>quot_dbtm t\<rbrakk>e" "y = \<lbrakk>quot_dbtm u\<rbrakk>e"
    by (metis Term_imp_wf_dbtm x y)
  thus ?thesis using wf_Term_quot_dbtm [of "DBEats t u"] x y
    by (auto simp: q_defs) (metis Eats Term_imp_wf_dbtm quot_dbtm_inject_lemma)
qed

subsection {*Correctness properties for constants*}

lemma Const_imp_Term: "Const x \<Longrightarrow> Term x"
  by (metis SeqConst_imp_SeqTerm CTerm_def)

lemma Const_0: "Const 0"
  by (force simp add: CTerm_def SeqCTerm_def intro: BuildSeq_exI)

lemma ConstP_imp_TermP: "{ConstP t} \<turnstile> TermP t"
proof -
  obtain k::name and s::name  where "atom k \<sharp> (s,t)" "atom s \<sharp> t"
    by (metis obtain_fresh)
  thus ?thesis
    apply auto
    apply (rule Ex_I [where x = "Var s"], simp)
    apply (rule Ex_I [where x = "Var k"], auto intro: SeqConstP_imp_SeqTermP [THEN cut1])
    done
qed

section {*Abstraction over terms*}

definition SeqStTerm :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
where "SeqStTerm v u x x' s k \<equiv>
       is_Var v \<and> BuildSeq2 (\<lambda>y y'. (is_Ind y \<or> Ord y) \<and> y' = (if y=v then u else y))
                (\<lambda>u u' v v' w w'. u = q_Eats v w \<and> u' = q_Eats v' w') s k x x'"

definition AbstTerm :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
where "AbstTerm v i x x' \<equiv> Ord i \<and> (\<exists>s k. SeqStTerm v (q_Ind i) x x' s k)"

subsection {*Defining the syntax: quantified body*}

nominal_function SeqStTermP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom l \<sharp> (s,k,v,i,sl,sl',m,n,sm,sm',sn,sn');
          atom sl \<sharp> (s,v,i,sl',m,n,sm,sm',sn,sn'); atom sl' \<sharp> (s,v,i,m,n,sm,sm',sn,sn');
          atom m \<sharp> (s,n,sm,sm',sn,sn'); atom n \<sharp> (s,sm,sm',sn,sn');
          atom sm \<sharp> (s,sm',sn,sn'); atom sm' \<sharp> (s,sn,sn');
          atom sn \<sharp> (s,sn'); atom sn' \<sharp> s\<rbrakk> \<Longrightarrow>
    SeqStTermP v i t u s k =
      VarP v AND LstSeqP s k (HPair t u) AND
      All2 l (SUCC k) (Ex sl (Ex sl' (HPair (Var l) (HPair (Var sl) (Var sl')) IN s AND
                (((Var sl EQ v AND Var sl' EQ i) OR
                  ((IndP (Var sl) OR Var sl NEQ v) AND Var sl' EQ Var sl)) OR
                Ex m (Ex n (Ex sm (Ex sm' (Ex sn (Ex sn' (Var m IN Var l AND Var n IN Var l AND
                       HPair (Var m) (HPair (Var sm) (Var sm')) IN s AND
                       HPair (Var n) (HPair (Var sn) (Var sn')) IN s AND
                       Var sl EQ Q_Eats (Var sm) (Var sn) AND
                       Var sl' EQ Q_Eats (Var sm') (Var sn')))))))))))"
  by (auto simp: eqvt_def SeqStTermP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows SeqStTermP_fresh_iff [simp]:
      "a \<sharp> SeqStTermP v i t u s k \<longleftrightarrow> a \<sharp> v \<and> a \<sharp> i \<and> a \<sharp> t \<and> a \<sharp> u \<and> a \<sharp> s \<and> a \<sharp> k"  (is ?thesis1)
    and eval_fm_SeqStTermP [simp]:
      "eval_fm e (SeqStTermP v i t u s k) \<longleftrightarrow> SeqStTerm \<lbrakk>v\<rbrakk>e \<lbrakk>i\<rbrakk>e \<lbrakk>t\<rbrakk>e \<lbrakk>u\<rbrakk>e \<lbrakk>s\<rbrakk>e \<lbrakk>k\<rbrakk>e"  (is ?thesis2)
    and SeqStTermP_sf [iff]:
      "Sigma_fm (SeqStTermP v i t u s k)"  (is ?thsf)
    and SeqStTermP_imp_OrdP:
      "{ SeqStTermP v i t u s k } \<turnstile> OrdP k"  (is ?thord)
    and SeqStTermP_imp_VarP:
      "{ SeqStTermP v i t u s k } \<turnstile> VarP v"  (is ?thvar)
    and SeqStTermP_imp_LstSeqP:
      "{ SeqStTermP v i t u s k } \<turnstile> LstSeqP s k (HPair t u)"  (is ?thlstseq)
proof -
  obtain l::name and sl::name and sl'::name and m::name and n::name and
         sm::name and sm'::name and sn::name and sn'::name
    where atoms:
       "atom l \<sharp> (s,k,v,i,sl,sl',m,n,sm,sm',sn,sn')"
       "atom sl \<sharp> (s,v,i,sl',m,n,sm,sm',sn,sn')" "atom sl' \<sharp> (s,v,i,m,n,sm,sm',sn,sn')"
       "atom m \<sharp> (s,n,sm,sm',sn,sn')" "atom n \<sharp> (s,sm,sm',sn,sn')"
       "atom sm \<sharp> (s,sm',sn,sn')" "atom sm' \<sharp> (s,sn,sn')"
       "atom sn \<sharp> (s,sn')" "atom sn' \<sharp> (s)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thsf ?thord ?thvar ?thlstseq
    by (auto intro: LstSeqP_OrdP)
  show ?thesis2 using atoms
    apply (simp add: LstSeq_imp_Ord SeqStTerm_def ex_disj_distrib
             BuildSeq2_def BuildSeq_def Builds_def
             HBall_def q_Eats_def q_Ind_def is_Var_def
             Seq_iff_app [of "\<lbrakk>s\<rbrakk>e", OF LstSeq_imp_Seq_succ]
             Ord_trans [of _ _ "succ \<lbrakk>k\<rbrakk>e"]
             cong: conj_cong)
    apply (rule conj_cong refl all_cong)+
    apply auto
    apply (metis Not_Ord_hpair is_Ind_def)
    done
qed

lemma SeqStTermP_subst [simp]:
      "(SeqStTermP v i t u s k)(j::=w) =
       SeqStTermP (subst j w v) (subst j w i) (subst j w t) (subst j w u) (subst j w s) (subst j w k)"
proof -
  obtain l::name and sl::name and sl'::name and m::name and n::name and
         sm::name and sm'::name and sn::name and sn'::name
    where "atom l \<sharp> (s,k,v,i,w,j,sl,sl',m,n,sm,sm',sn,sn')"
         "atom sl \<sharp> (s,v,i,w,j,sl',m,n,sm,sm',sn,sn')"
         "atom sl' \<sharp> (s,v,i,w,j,m,n,sm,sm',sn,sn')"
         "atom m \<sharp> (s,w,j,n,sm,sm',sn,sn')" "atom n \<sharp> (s,w,j,sm,sm',sn,sn')"
         "atom sm \<sharp> (s,w,j,sm',sn,sn')" "atom sm' \<sharp> (s,w,j,sn,sn')"
         "atom sn \<sharp> (s,w,j,sn')" "atom sn' \<sharp> (s,w,j)"
    by (metis obtain_fresh)
  thus ?thesis
    by (force simp add: SeqStTermP.simps [of l _ _ _ _ sl sl' m n sm sm' sn sn'])
qed

lemma SeqStTermP_cong:
  "\<lbrakk>H \<turnstile> t EQ t'; H \<turnstile> u EQ u'; H \<turnstile> s EQ s'; H \<turnstile> k EQ k'\<rbrakk>
   \<Longrightarrow> H \<turnstile> SeqStTermP v i t u s k IFF SeqStTermP v i t' u' s' k'"
   by (rule P4_cong [where tms="[v,i]"]) (auto simp: fresh_Cons)

declare SeqStTermP.simps [simp del]

subsection {*Defining the syntax: main predicate*}

nominal_function AbstTermP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom s \<sharp> (v,i,t,u,k); atom k \<sharp> (v,i,t,u)\<rbrakk> \<Longrightarrow>
    AbstTermP v i t u =
     OrdP i AND Ex s (Ex k (SeqStTermP v (Q_Ind i) t u (Var s) (Var k)))"
  by (auto simp: eqvt_def AbstTermP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows AbstTermP_fresh_iff [simp]:
      "a \<sharp> AbstTermP v i t u \<longleftrightarrow> a \<sharp> v \<and> a \<sharp> i \<and> a \<sharp> t \<and> a \<sharp> u"  (is ?thesis1)
    and eval_fm_AbstTermP [simp]:
      "eval_fm e (AbstTermP v i t u) \<longleftrightarrow> AbstTerm \<lbrakk>v\<rbrakk>e \<lbrakk>i\<rbrakk>e \<lbrakk>t\<rbrakk>e \<lbrakk>u\<rbrakk>e "  (is ?thesis2)
    and AbstTermP_sf [iff]:
      "Sigma_fm (AbstTermP v i t u)"  (is ?thsf)
proof -
  obtain s::name and k::name where "atom s \<sharp> (v,i,t,u,k)"  "atom k \<sharp> (v,i,t,u)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis2 ?thsf
    by (auto simp: AbstTerm_def q_defs)
qed

lemma AbstTermP_subst [simp]:
      "(AbstTermP v i t u)(j::=w) = AbstTermP (subst j w v) (subst j w i) (subst j w t) (subst j w u)"
proof -
  obtain s::name and k::name  where "atom s \<sharp> (v,i,t,u,w,j,k)"  "atom k \<sharp> (v,i,t,u,w,j)"
    by (metis obtain_fresh)
  thus ?thesis
    by (simp add: AbstTermP.simps [of s _ _ _ _ k])
qed

declare AbstTermP.simps [simp del]

subsection {*Correctness: It Coincides with Abstraction over real terms*}

lemma not_is_Var_is_Ind: "is_Var v \<Longrightarrow> \<not> is_Ind v"
  by (auto simp: is_Var_def is_Ind_def)

lemma AbstTerm_imp_abst_dbtm:
  assumes "AbstTerm v i x x'"
  shows "\<exists>t. x = \<lbrakk>quot_dbtm t\<rbrakk>e \<and>
             x' = \<lbrakk>quot_dbtm (abst_dbtm (decode_Var v) (nat_of_ord i) t)\<rbrakk>e"
proof -
  obtain s k where v: "is_Var v" and i: "Ord i" and sk: "SeqStTerm v (q_Ind i) x x' s k"
    using assms
    by (auto simp: AbstTerm_def SeqStTerm_def)
  from sk [unfolded SeqStTerm_def, THEN conjunct2]
  show ?thesis
  proof (induct x x' rule: BuildSeq2_induct)
    case (B x x') thus ?case using v i
      apply (auto simp: not_is_Var_is_Ind)
      apply (rule_tac [1] x="DBInd (nat_of_ord (hsnd x))" in exI)
      apply (rule_tac [2] x="DBVar (decode_Var v)" in exI)
      apply (case_tac [3] "is_Var x")
      apply (rule_tac [3] x="DBVar (decode_Var x)" in exI)
      apply (rule_tac [4] x=DBZero in exI)
      apply (auto simp: is_Ind_def q_Ind_def is_Var_iff [symmetric])
      apply (metis hmem_0_Ord is_Var_def)
      done
  next
    case (C x x' y y' z z')
    then obtain tm1 and tm2
      where "y = \<lbrakk>quot_dbtm tm1\<rbrakk>e"
              "y' = \<lbrakk>quot_dbtm (abst_dbtm (decode_Var v) (nat_of_ord i) tm1)\<rbrakk>e"
            "z = \<lbrakk>quot_dbtm tm2\<rbrakk>e"
              "z' = \<lbrakk>quot_dbtm (abst_dbtm (decode_Var v) (nat_of_ord i) tm2)\<rbrakk>e"
    by blast
  thus ?case
    by (auto simp: wf_dbtm.intros C q_Eats_def intro!: exI [where x="DBEats tm1 tm2"])
  qed
qed

lemma AbstTerm_abst_dbtm:
     "AbstTerm (q_Var i) (ord_of n) \<lbrakk>quot_dbtm t\<rbrakk>e
                                    \<lbrakk>quot_dbtm (abst_dbtm i n t)\<rbrakk>e"
  by (induct t rule: dbtm.induct)
     (auto simp: AbstTerm_def SeqStTerm_def q_defs intro: BuildSeq2_exI BuildSeq2_combine)

section {*Substitution over terms*}

definition SubstTerm :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
  where "SubstTerm v u x x' \<equiv> Term u \<and> (\<exists>s k. SeqStTerm v u x x' s k)"

subsection {*Defining the syntax*}

nominal_function SubstTermP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom s \<sharp> (v,i,t,u,k); atom k \<sharp> (v,i,t,u)\<rbrakk> \<Longrightarrow>
    SubstTermP v i t u = TermP i AND Ex s (Ex k (SeqStTermP v i t u (Var s) (Var k)))"
  by (auto simp: eqvt_def SubstTermP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows SubstTermP_fresh_iff [simp]:
       "a \<sharp> SubstTermP v i t u \<longleftrightarrow> a \<sharp> v \<and> a \<sharp> i \<and> a \<sharp> t \<and> a \<sharp> u"  (is ?thesis1)
    and eval_fm_SubstTermP [simp]:
       "eval_fm e (SubstTermP v i t u) \<longleftrightarrow> SubstTerm \<lbrakk>v\<rbrakk>e \<lbrakk>i\<rbrakk>e \<lbrakk>t\<rbrakk>e \<lbrakk>u\<rbrakk>e"  (is ?thesis2)
    and SubstTermP_sf [iff]:
       "Sigma_fm (SubstTermP v i t u)"     (is ?thsf)
    and SubstTermP_imp_TermP:
       "{ SubstTermP v i t u } \<turnstile> TermP i"  (is ?thterm)
    and SubstTermP_imp_VarP:
       "{ SubstTermP v i t u } \<turnstile> VarP v"   (is ?thvar)
proof -
  obtain s::name and k::name  where "atom s \<sharp> (v,i,t,u,k)" "atom k \<sharp> (v,i,t,u)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis2 ?thsf ?thterm ?thvar
    by (auto simp: SubstTerm_def intro: SeqStTermP_imp_VarP thin2)
qed

lemma SubstTermP_subst [simp]:
      "(SubstTermP v i t u)(j::=w) = SubstTermP (subst j w v) (subst j w i) (subst j w t) (subst j w u)"
proof -
  obtain s::name and k::name
    where "atom s \<sharp> (v,i,t,u,w,j,k)"  "atom k \<sharp> (v,i,t,u,w,j)"
    by (metis obtain_fresh)
  thus ?thesis
    by (simp add: SubstTermP.simps [of s _ _ _ _ k])
qed

lemma SubstTermP_cong:
  "\<lbrakk>H \<turnstile> v EQ v'; H \<turnstile> i EQ i'; H \<turnstile> t EQ t'; H \<turnstile> u EQ u'\<rbrakk>
   \<Longrightarrow> H \<turnstile> SubstTermP v i t u IFF SubstTermP v' i' t' u'"
  by (rule P4_cong) auto

declare SubstTermP.simps [simp del]

lemma SubstTerm_imp_subst_dbtm:
  assumes "SubstTerm v \<lbrakk>quot_dbtm u\<rbrakk>e x x'"
  shows "\<exists>t. x = \<lbrakk>quot_dbtm t\<rbrakk>e \<and>
             x' = \<lbrakk>quot_dbtm (subst_dbtm u (decode_Var v) t)\<rbrakk>e"
proof -
  obtain s k where v: "is_Var v" and u: "Term \<lbrakk>quot_dbtm u\<rbrakk>e"
               and sk: "SeqStTerm v \<lbrakk>quot_dbtm u\<rbrakk>e x x' s k"
    using assms [unfolded SubstTerm_def]
    by (auto simp: SeqStTerm_def)
  from sk [unfolded SeqStTerm_def, THEN conjunct2]
  show ?thesis
  proof (induct x x' rule: BuildSeq2_induct)
    case (B x x') thus ?case using v
      apply (auto simp: not_is_Var_is_Ind)
      apply (rule_tac [1] x="DBInd (nat_of_ord (hsnd x))" in exI)
      apply (rule_tac [2] x="DBVar (decode_Var v)" in exI)
      apply (case_tac [3] "is_Var x")
      apply (rule_tac [3] x="DBVar (decode_Var x)" in exI)
      apply (rule_tac [4] x=DBZero in exI)
      apply (auto simp: is_Ind_def q_Ind_def is_Var_iff [symmetric])
      apply (metis hmem_0_Ord is_Var_def)
      done
  next
    case (C x x' y y' z z')
    then obtain tm1 and tm2
      where "y = \<lbrakk>quot_dbtm tm1\<rbrakk>e"
              "y' = \<lbrakk>quot_dbtm (subst_dbtm u (decode_Var v) tm1)\<rbrakk>e"
            "z = \<lbrakk>quot_dbtm tm2\<rbrakk>e"
              "z' = \<lbrakk>quot_dbtm (subst_dbtm u (decode_Var v) tm2)\<rbrakk>e"
    by blast
  thus ?case
    by (auto simp: wf_dbtm.intros C q_Eats_def intro!: exI [where x="DBEats tm1 tm2"])
  qed
qed

corollary SubstTerm_imp_subst_dbtm':
  assumes "SubstTerm v y x x'"
  obtains t::dbtm and u::dbtm
  where "y = \<lbrakk>quot_dbtm u\<rbrakk>e"
        "x = \<lbrakk>quot_dbtm t\<rbrakk>e"
        "x' = \<lbrakk>quot_dbtm (subst_dbtm u (decode_Var v) t)\<rbrakk>e"
  by (metis SubstTerm_def SubstTerm_imp_subst_dbtm Term_imp_is_tm assms quot_tm_def)

lemma SubstTerm_subst_dbtm:
  assumes "Term \<lbrakk>quot_dbtm u\<rbrakk>e"
    shows "SubstTerm (q_Var v) \<lbrakk>quot_dbtm u\<rbrakk>e \<lbrakk>quot_dbtm t\<rbrakk>e \<lbrakk>quot_dbtm (subst_dbtm u v t)\<rbrakk>e"
  by (induct t rule: dbtm.induct)
     (auto simp: assms SubstTerm_def SeqStTerm_def q_defs intro: BuildSeq2_exI BuildSeq2_combine)

section {*Abstraction over formulas*}

subsection {*The predicate @{text AbstAtomicP}*}

definition AbstAtomic :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
  where "AbstAtomic v i y y' \<equiv>
            (\<exists>t u t' u'. AbstTerm v i t t' \<and> AbstTerm v i u u' \<and>
             ((y = q_Eq t u \<and> y' = q_Eq t' u') \<or> (y = q_Mem t u \<and> y' = q_Mem t' u')))"

nominal_function AbstAtomicP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom t \<sharp> (v,i,y,y',t',u,u'); atom t' \<sharp> (v,i,y,y',u,u');
          atom u \<sharp> (v,i,y,y',u'); atom u' \<sharp> (v,i,y,y')\<rbrakk> \<Longrightarrow>
    AbstAtomicP v i y y' =
         Ex t (Ex u (Ex t' (Ex u'
           (AbstTermP v i (Var t) (Var t') AND AbstTermP v i (Var u) (Var u') AND
                      ((y EQ Q_Eq (Var t) (Var u) AND y' EQ Q_Eq (Var t') (Var u')) OR
                       (y EQ Q_Mem (Var t) (Var u) AND y' EQ Q_Mem (Var t') (Var u')))))))"
  by (auto simp: eqvt_def AbstAtomicP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows AbstAtomicP_fresh_iff [simp]:
       "a \<sharp> AbstAtomicP v i y y' \<longleftrightarrow> a \<sharp> v \<and> a \<sharp> i \<and> a \<sharp> y \<and> a \<sharp> y'"         (is ?thesis1)
    and eval_fm_AbstAtomicP [simp]:
       "eval_fm e (AbstAtomicP v i y y') \<longleftrightarrow> AbstAtomic \<lbrakk>v\<rbrakk>e \<lbrakk>i\<rbrakk>e \<lbrakk>y\<rbrakk>e \<lbrakk>y'\<rbrakk>e"  (is ?thesis2)
    and AbstAtomicP_sf [iff]: "Sigma_fm (AbstAtomicP v i y y')"              (is ?thsf)
proof -
  obtain t::name and u::name and t'::name  and u'::name
    where "atom t \<sharp> (v,i,y,y',t',u,u')" "atom t' \<sharp> (v,i,y,y',u,u')"
          "atom u \<sharp> (v,i,y,y',u')" "atom u' \<sharp> (v,i,y,y')"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis2 ?thsf
    by (auto simp: AbstAtomic_def q_defs)
qed

lemma AbstAtomicP_subst [simp]:
      "(AbstAtomicP v tm y y')(i::=w) = AbstAtomicP (subst i w v) (subst i w tm) (subst i w y) (subst i w y')"
proof -
  obtain t::name and u::name and t'::name  and u'::name
    where "atom t \<sharp> (v,tm,y,y',w,i,t',u,u')"  "atom t' \<sharp> (v,tm,y,y',w,i,u,u')"
          "atom u \<sharp> (v,tm,y,y',w,i,u')"       "atom u' \<sharp> (v,tm,y,y',w,i)"
    by (metis obtain_fresh)
  thus ?thesis
    by (simp add: AbstAtomicP.simps [of t _ _ _ _ t' u u'])
qed

declare AbstAtomicP.simps [simp del]

subsection {*The predicate @{text AbsMakeForm}*}

definition AbstMakeForm :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
where "AbstMakeForm k y y' i u u' j w w' \<equiv>
      Ord k \<and>
      ((k = i \<and> k = j \<and> y = q_Disj u w \<and> y' = q_Disj u' w') \<or>
       (k = i \<and> y = q_Neg u \<and> y' = q_Neg u') \<or>
       (succ k = i \<and> y = q_Ex u \<and> y' = q_Ex u'))"

definition SeqAbstForm :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
where "SeqAbstForm v i x x' s k \<equiv>
       BuildSeq3 (AbstAtomic v) AbstMakeForm s k i x x'"

nominal_function SeqAbstFormP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom l \<sharp> (s,k,v,sli,sl,sl',m,n,smi,sm,sm',sni,sn,sn');
          atom sli \<sharp> (s,v,sl,sl',m,n,smi,sm,sm',sni,sn,sn');
          atom sl \<sharp> (s,v,sl',m,n,smi,sm,sm',sni,sn,sn');
          atom sl' \<sharp> (s,v,m,n,smi,sm,sm',sni,sn,sn');
          atom m \<sharp> (s,n,smi,sm,sm',sni,sn,sn');
          atom n \<sharp> (s,smi,sm,sm',sni,sn,sn'); atom smi \<sharp> (s,sm,sm',sni,sn,sn');
          atom sm \<sharp> (s,sm',sni,sn,sn'); atom sm' \<sharp> (s,sni,sn,sn');
          atom sni \<sharp> (s,sn,sn'); atom sn \<sharp> (s,sn'); atom sn' \<sharp> (s)\<rbrakk> \<Longrightarrow>
    SeqAbstFormP v i x x' s k =
      LstSeqP s k (HPair i (HPair x x')) AND
      All2 l (SUCC k) (Ex sli (Ex sl (Ex sl' (HPair (Var l) (HPair (Var sli) (HPair (Var sl) (Var sl'))) IN s AND
                (AbstAtomicP v (Var sli) (Var sl) (Var sl') OR
                OrdP (Var sli) AND
                Ex m (Ex n (Ex smi (Ex sm (Ex sm' (Ex sni (Ex sn (Ex sn'
                      (Var m IN Var l AND Var n IN Var l AND
                       HPair (Var m) (HPair (Var smi) (HPair (Var sm) (Var sm'))) IN s AND
                       HPair (Var n) (HPair (Var sni) (HPair (Var sn) (Var sn'))) IN s AND
                       ((Var sli EQ Var smi AND Var sli EQ Var sni AND
                         Var sl EQ Q_Disj (Var sm) (Var sn) AND
                         Var sl' EQ Q_Disj (Var sm') (Var sn')) OR
                        (Var sli EQ Var smi AND
                         Var sl EQ Q_Neg (Var sm) AND Var sl' EQ Q_Neg (Var sm')) OR
                        (SUCC (Var sli) EQ Var smi AND
                         Var sl EQ Q_Ex (Var sm) AND Var sl' EQ Q_Ex (Var sm'))))))))))))))))"
  by (auto simp: eqvt_def SeqAbstFormP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows SeqAbstFormP_fresh_iff [simp]:
       "a \<sharp> SeqAbstFormP v i x x' s k \<longleftrightarrow> a \<sharp> v \<and> a \<sharp> i \<and> a \<sharp> x \<and> a \<sharp> x' \<and> a \<sharp> s \<and> a \<sharp> k"  (is ?thesis1)
    and eval_fm_SeqAbstFormP [simp]:
       "eval_fm e (SeqAbstFormP v i x x' s k) \<longleftrightarrow> SeqAbstForm \<lbrakk>v\<rbrakk>e \<lbrakk>i\<rbrakk>e \<lbrakk>x\<rbrakk>e \<lbrakk>x'\<rbrakk>e \<lbrakk>s\<rbrakk>e \<lbrakk>k\<rbrakk>e" (is ?thesis2)
    and SeqAbstFormP_sf [iff]:
       "Sigma_fm (SeqAbstFormP v i x x' s k)"  (is ?thsf)
proof -
  obtain l::name and sli::name and sl::name and sl'::name and m::name and n::name and
         smi::name and sm::name and sm'::name and sni::name and sn::name and sn'::name
    where atoms:
         "atom l \<sharp> (s,k,v,sli,sl,sl',m,n,smi,sm,sm',sni,sn,sn')"
         "atom sli \<sharp> (s,v,sl,sl',m,n,smi,sm,sm',sni,sn,sn')"
         "atom sl \<sharp> (s,v,sl',m,n,smi,sm,sm',sni,sn,sn')"
         "atom sl' \<sharp> (s,v,m,n,smi,sm,sm',sni,sn,sn')"
         "atom m \<sharp> (s,n,smi,sm,sm',sni,sn,sn')" "atom n \<sharp> (s,smi,sm,sm',sni,sn,sn')"
         "atom smi \<sharp> (s,sm,sm',sni,sn,sn')"
         "atom sm \<sharp> (s,sm',sni,sn,sn')"
         "atom sm' \<sharp> (s,sni,sn,sn')"
         "atom sni \<sharp> (s,sn,sn')" "atom sn \<sharp> (s,sn')" "atom sn' \<sharp> s"
    by (metis obtain_fresh)
  thus ?thesis1 ?thsf
    by (auto intro: LstSeqP_OrdP)
  show ?thesis2 using atoms
    by (force simp add: LstSeq_imp_Ord SeqAbstForm_def
                 BuildSeq3_def BuildSeq_def Builds_def
                 HBall_def HBex_def q_defs AbstMakeForm_def
                 Seq_iff_app [of "\<lbrakk>s\<rbrakk>e", OF LstSeq_imp_Seq_succ]
                 Ord_trans [of _ _ "succ \<lbrakk>k\<rbrakk>e"]
             cong: conj_cong   intro!: conj_cong [OF refl] all_cong)
qed

lemma SeqAbstFormP_subst [simp]:
      "(SeqAbstFormP v u x x' s k)(i::=t) =
       SeqAbstFormP (subst i t v) (subst i t u) (subst i t x) (subst i t x') (subst i t s) (subst i t k)"
proof -
  obtain l::name and sli::name and sl::name and sl'::name and m::name and n::name and
         smi::name and sm::name and sm'::name and sni::name and sn::name and sn'::name
   where "atom l \<sharp> (i,t,s,k,v,sli,sl,sl',m,n,smi,sm,sm',sni,sn,sn')"
         "atom sli \<sharp> (i,t,s,v,sl,sl',m,n,smi,sm,sm',sni,sn,sn')"
         "atom sl \<sharp> (i,t,s,v,sl',m,n,smi,sm,sm',sni,sn,sn')"
         "atom sl' \<sharp> (i,t,s,v,m,n,smi,sm,sm',sni,sn,sn')"
         "atom m \<sharp> (i,t,s,n,smi,sm,sm',sni,sn,sn')"
         "atom n \<sharp> (i,t,s,smi,sm,sm',sni,sn,sn')"
         "atom smi \<sharp> (i,t,s,sm,sm',sni,sn,sn')"
         "atom sm \<sharp> (i,t,s,sm',sni,sn,sn')" "atom sm' \<sharp> (i,t,s,sni,sn,sn')"
         "atom sni \<sharp> (i,t,s,sn,sn')" "atom sn \<sharp> (i,t,s,sn')" "atom sn' \<sharp> (i,t,s)"
    by (metis obtain_fresh)
  thus ?thesis
    by (force simp add: SeqAbstFormP.simps [of l _ _ _ sli sl sl' m n smi sm sm' sni sn sn'])
qed

declare SeqAbstFormP.simps [simp del]

subsection {*Defining the syntax: the main AbstForm predicate*}

definition AbstForm :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
  where "AbstForm v i x x' \<equiv> is_Var v \<and> Ord i \<and> (\<exists>s k. SeqAbstForm v i x x' s k)"

nominal_function AbstFormP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom s \<sharp> (v,i,x,x',k);
          atom k \<sharp> (v,i,x,x')\<rbrakk> \<Longrightarrow>
    AbstFormP v i x x' = VarP v AND OrdP i AND Ex s (Ex k (SeqAbstFormP v i x x' (Var s) (Var k)))"
  by (auto simp: eqvt_def AbstFormP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows AbstFormP_fresh_iff [simp]:
       "a \<sharp> AbstFormP v i x x' \<longleftrightarrow> a \<sharp> v \<and> a \<sharp> i \<and> a \<sharp> x \<and> a \<sharp> x'" (is ?thesis1)
    and eval_fm_AbstFormP [simp]:
       "eval_fm e (AbstFormP v i x x') \<longleftrightarrow> AbstForm \<lbrakk>v\<rbrakk>e \<lbrakk>i\<rbrakk>e \<lbrakk>x\<rbrakk>e \<lbrakk>x'\<rbrakk>e" (is ?thesis2)
    and AbstFormP_sf [iff]:
       "Sigma_fm (AbstFormP v i x x')"    (is ?thsf)
proof -
  obtain s::name and k::name  where "atom s \<sharp> (v,i,x,x',k)" "atom k \<sharp> (v,i,x,x')"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis2 ?thsf
    by (auto simp: AbstForm_def)
qed

lemma AbstFormP_subst [simp]:
     "(AbstFormP v i x x')(j::=t) = AbstFormP (subst j t v) (subst j t i) (subst j t x) (subst j t x')"
proof -
  obtain s::name and k::name  where "atom s \<sharp> (v,i,x,x',t,j,k)" "atom k \<sharp> (v,i,x,x',t,j)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: AbstFormP.simps [of s _ _ _ _ k])
qed

declare AbstFormP.simps [simp del]

subsection {*Correctness: It Coincides with Abstraction over real Formulas*}

lemma AbstForm_imp_Ord: "AbstForm v u x x' \<Longrightarrow> Ord v"
  by (metis AbstForm_def is_Var_def)

lemma AbstForm_imp_abst_dbfm:
  assumes "AbstForm v i x x'"
  shows "\<exists>A. x = \<lbrakk>quot_dbfm A\<rbrakk>e \<and>
             x' = \<lbrakk>quot_dbfm (abst_dbfm (decode_Var v) (nat_of_ord i) A)\<rbrakk>e"
proof -
  obtain s k where v: "is_Var v" and i: "Ord i" and sk: "SeqAbstForm v i x x' s k"
    using assms [unfolded AbstForm_def]
    by auto
  from sk [unfolded SeqAbstForm_def]
  show ?thesis
  proof (induction i x x' rule: BuildSeq3_induct)
    case (B i x x') thus ?case
      apply (auto simp: AbstAtomic_def dest!: AbstTerm_imp_abst_dbtm [where e=e])
      apply (rule_tac [1] x="DBEq ta tb" in exI)
      apply (rule_tac [2] x="DBMem ta tb" in exI)
      apply (auto simp: q_defs)
      done
  next
    case (C i x x' j y y' k z z')
    then obtain A1 and A2
      where "y = \<lbrakk>quot_dbfm A1\<rbrakk>e"
            "y' = \<lbrakk>quot_dbfm (abst_dbfm (decode_Var v) (nat_of_ord j) A1)\<rbrakk>e"
            "z = \<lbrakk>quot_dbfm A2\<rbrakk>e"
            "z' = \<lbrakk>quot_dbfm (abst_dbfm (decode_Var v) (nat_of_ord k) A2)\<rbrakk>e"
    by blast
  with C.hyps show ?case
    apply (auto simp: AbstMakeForm_def)
    apply (rule_tac [1] x="DBDisj A1 A2" in exI)
    apply (rule_tac [2] x="DBNeg A1" in exI)
    apply (rule_tac [3] x="DBEx A1" in exI)
    apply (auto simp: C q_defs)
    done
  qed
qed

lemma AbstForm_abst_dbfm:
  "AbstForm (q_Var i) (ord_of n) \<lbrakk>quot_dbfm fm\<rbrakk>e \<lbrakk>quot_dbfm (abst_dbfm i n fm)\<rbrakk>e"
apply (induction fm arbitrary: n rule: dbfm.induct)
apply (force simp add: AbstForm_def SeqAbstForm_def AbstMakeForm_def AbstAtomic_def
                       AbstTerm_abst_dbtm htuple_minus_1 q_defs simp del: q_Var_def
             intro: BuildSeq3_exI BuildSeq3_combine)+
done

section {*Substitution over formulas*}

subsection {*The predicate @{text SubstAtomicP}*}

definition SubstAtomic :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
  where "SubstAtomic v tm y y' \<equiv>
            (\<exists>t u t' u'. SubstTerm v tm t t' \<and> SubstTerm v tm u u' \<and>
             ((y = q_Eq t u \<and> y' = q_Eq t' u') \<or> (y = q_Mem t u \<and> y' = q_Mem t' u')))"

nominal_function SubstAtomicP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom t \<sharp> (v,tm,y,y',t',u,u');
          atom t' \<sharp> (v,tm,y,y',u,u');
          atom u \<sharp> (v,tm,y,y',u');
          atom u' \<sharp> (v,tm,y,y')\<rbrakk> \<Longrightarrow>
    SubstAtomicP v tm y y' =
         Ex t (Ex u (Ex t' (Ex u'
           (SubstTermP v tm (Var t) (Var t') AND SubstTermP v tm (Var u) (Var u') AND
                      ((y EQ Q_Eq (Var t) (Var u) AND y' EQ Q_Eq (Var t') (Var u')) OR
                       (y EQ Q_Mem (Var t) (Var u) AND y' EQ Q_Mem (Var t') (Var u')))))))"
by (auto simp: eqvt_def SubstAtomicP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows SubstAtomicP_fresh_iff [simp]:
       "a \<sharp> SubstAtomicP v tm y y' \<longleftrightarrow> a \<sharp> v \<and> a \<sharp> tm \<and> a \<sharp> y \<and> a \<sharp> y'"           (is ?thesis1)
    and eval_fm_SubstAtomicP [simp]:
       "eval_fm e (SubstAtomicP v tm y y') \<longleftrightarrow> SubstAtomic \<lbrakk>v\<rbrakk>e \<lbrakk>tm\<rbrakk>e \<lbrakk>y\<rbrakk>e \<lbrakk>y'\<rbrakk>e"  (is ?thesis2)
    and SubstAtomicP_sf [iff]: "Sigma_fm (SubstAtomicP v tm y y')"               (is ?thsf)
proof -
  obtain t::name and u::name and t'::name  and u'::name
    where "atom t \<sharp> (v,tm,y,y',t',u,u')" "atom t' \<sharp> (v,tm,y,y',u,u')"
          "atom u \<sharp> (v,tm,y,y',u')" "atom u' \<sharp> (v,tm,y,y')"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis2 ?thsf
    by (auto simp: SubstAtomic_def q_defs)
qed

lemma SubstAtomicP_subst [simp]:
  "(SubstAtomicP v tm y y')(i::=w) = SubstAtomicP (subst i w v) (subst i w tm) (subst i w y) (subst i w y')"
proof -
  obtain t::name and u::name and t'::name  and u'::name
    where "atom t \<sharp> (v,tm,y,y',w,i,t',u,u')" "atom t' \<sharp> (v,tm,y,y',w,i,u,u')"
          "atom u \<sharp> (v,tm,y,y',w,i,u')" "atom u' \<sharp> (v,tm,y,y',w,i)"
    by (metis obtain_fresh)
  thus ?thesis
    by (simp add: SubstAtomicP.simps [of t _ _ _ _ t' u u'])
qed

lemma SubstAtomicP_cong:
  "\<lbrakk>H \<turnstile> v EQ v'; H \<turnstile> tm EQ tm'; H \<turnstile> x EQ x'; H \<turnstile> y EQ y'\<rbrakk>
   \<Longrightarrow> H \<turnstile> SubstAtomicP v tm x y IFF SubstAtomicP v' tm' x' y'"
  by (rule P4_cong) auto

subsection {*The predicate @{text SubstMakeForm}*}

definition SubstMakeForm :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
  where "SubstMakeForm y y' u u' w w' \<equiv>
          ((y = q_Disj u w \<and> y' = q_Disj u' w') \<or>
           (y = q_Neg u \<and> y' = q_Neg u') \<or>
           (y = q_Ex u \<and> y' = q_Ex u'))"

definition SeqSubstForm :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
  where "SeqSubstForm v u x x' s k \<equiv> BuildSeq2 (SubstAtomic v u) SubstMakeForm s k x x'"

nominal_function SeqSubstFormP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom l \<sharp> (s,k,v,u,sl,sl',m,n,sm,sm',sn,sn');
          atom sl \<sharp> (s,v,u,sl',m,n,sm,sm',sn,sn');
          atom sl' \<sharp> (s,v,u,m,n,sm,sm',sn,sn');
          atom m \<sharp> (s,n,sm,sm',sn,sn'); atom n \<sharp> (s,sm,sm',sn,sn');
          atom sm \<sharp> (s,sm',sn,sn'); atom sm' \<sharp> (s,sn,sn');
          atom sn \<sharp> (s,sn'); atom sn' \<sharp> s\<rbrakk> \<Longrightarrow>
    SeqSubstFormP v u x x' s k =
      LstSeqP s k (HPair x x') AND
      All2 l (SUCC k) (Ex sl (Ex sl' (HPair (Var l) (HPair (Var sl) (Var sl')) IN s AND
                (SubstAtomicP v u (Var sl) (Var sl') OR
                Ex m (Ex n (Ex sm (Ex sm' (Ex sn (Ex sn' (Var m IN Var l AND Var n IN Var l AND
                       HPair (Var m) (HPair (Var sm) (Var sm')) IN s AND
                       HPair (Var n) (HPair (Var sn) (Var sn')) IN s AND
                       ((Var sl EQ Q_Disj (Var sm) (Var sn) AND
                        Var sl' EQ Q_Disj (Var sm') (Var sn')) OR
                        (Var sl EQ Q_Neg (Var sm) AND Var sl' EQ Q_Neg (Var sm')) OR
                        (Var sl EQ Q_Ex (Var sm) AND Var sl' EQ Q_Ex (Var sm')))))))))))))"
by (auto simp: eqvt_def SeqSubstFormP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows SeqSubstFormP_fresh_iff [simp]:
       "a \<sharp> SeqSubstFormP v u x x' s k \<longleftrightarrow> a \<sharp> v \<and> a \<sharp> u \<and> a \<sharp> x \<and> a \<sharp> x' \<and> a \<sharp> s \<and> a \<sharp> k"  (is ?thesis1)
    and eval_fm_SeqSubstFormP [simp]:
       "eval_fm e (SeqSubstFormP v u x x' s k) \<longleftrightarrow>
         SeqSubstForm \<lbrakk>v\<rbrakk>e \<lbrakk>u\<rbrakk>e \<lbrakk>x\<rbrakk>e \<lbrakk>x'\<rbrakk>e \<lbrakk>s\<rbrakk>e \<lbrakk>k\<rbrakk>e" (is ?thesis2)
    and SeqSubstFormP_sf [iff]:
       "Sigma_fm (SeqSubstFormP v u x x' s k)"  (is ?thsf)
    and SeqSubstFormP_imp_OrdP:
       "{ SeqSubstFormP v u x x' s k } \<turnstile> OrdP k"  (is ?thOrd)
    and SeqSubstFormP_imp_LstSeqP:
       "{ SeqSubstFormP v u x x' s k } \<turnstile> LstSeqP s k (HPair x x')"  (is ?thLstSeq)
proof -
  obtain l::name and sl::name and sl'::name and m::name and n::name and
         sm::name and sm'::name and sn::name and sn'::name
    where atoms:
         "atom l \<sharp> (s,k,v,u,sl,sl',m,n,sm,sm',sn,sn')"
         "atom sl \<sharp> (s,v,u,sl',m,n,sm,sm',sn,sn')"
         "atom sl' \<sharp> (s,v,u,m,n,sm,sm',sn,sn')"
         "atom m \<sharp> (s,n,sm,sm',sn,sn')" "atom n \<sharp> (s,sm,sm',sn,sn')"
         "atom sm \<sharp> (s,sm',sn,sn')" "atom sm' \<sharp> (s,sn,sn')"
         "atom sn \<sharp> (s,sn')" "atom sn' \<sharp> (s)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thsf ?thOrd ?thLstSeq
    by (auto intro: LstSeqP_OrdP)
  show ?thesis2 using atoms
    by (force simp add: LstSeq_imp_Ord SeqSubstForm_def
                 BuildSeq2_def BuildSeq_def Builds_def
                 HBall_def HBex_def q_defs SubstMakeForm_def
                 Seq_iff_app [of "\<lbrakk>s\<rbrakk>e", OF LstSeq_imp_Seq_succ]
                 Ord_trans [of _ _ "succ \<lbrakk>k\<rbrakk>e"]
             cong: conj_cong   intro!: conj_cong [OF refl]  all_cong)
qed

lemma SeqSubstFormP_subst [simp]:
      "(SeqSubstFormP v u x x' s k)(i::=t) =
       SeqSubstFormP (subst i t v) (subst i t u) (subst i t x) (subst i t x') (subst i t s) (subst i t k)"
proof -
  obtain l::name and sl::name and sl'::name and m::name and n::name and
         sm::name and sm'::name and sn::name and sn'::name
   where "atom l \<sharp> (s,k,v,u,t,i,sl,sl',m,n,sm,sm',sn,sn')"
         "atom sl \<sharp> (s,v,u,t,i,sl',m,n,sm,sm',sn,sn')"
         "atom sl' \<sharp> (s,v,u,t,i,m,n,sm,sm',sn,sn')"
         "atom m \<sharp> (s,t,i,n,sm,sm',sn,sn')" "atom n \<sharp> (s,t,i,sm,sm',sn,sn')"
         "atom sm \<sharp> (s,t,i,sm',sn,sn')" "atom sm' \<sharp> (s,t,i,sn,sn')"
         "atom sn \<sharp> (s,t,i,sn')" "atom sn' \<sharp> (s,t,i)"
    by (metis obtain_fresh)
  thus ?thesis
    by (force simp add: SeqSubstFormP.simps [of l _ _ _ _ sl sl' m n sm sm' sn sn'])
qed

lemma SeqSubstFormP_cong:
  "\<lbrakk>H \<turnstile> t EQ t'; H \<turnstile> u EQ u'; H \<turnstile> s EQ s'; H \<turnstile> k EQ k'\<rbrakk>
   \<Longrightarrow> H \<turnstile> SeqSubstFormP v i t u s k IFF SeqSubstFormP v i t' u' s' k'"
   by (rule P4_cong [where tms="[v,i]"]) (auto simp: fresh_Cons)

declare SeqSubstFormP.simps [simp del]

subsection {*Defining the syntax: the main SubstForm predicate*}

definition SubstForm :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
where "SubstForm v u x x' \<equiv> is_Var v \<and> Term u \<and> (\<exists>s k. SeqSubstForm v u x x' s k)"

nominal_function SubstFormP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom s \<sharp> (v,i,x,x',k); atom k \<sharp> (v,i,x,x')\<rbrakk> \<Longrightarrow>
    SubstFormP v i x x' =
      VarP v AND TermP i AND Ex s (Ex k (SeqSubstFormP v i x x' (Var s) (Var k)))"
  by (auto simp: eqvt_def SubstFormP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows SubstFormP_fresh_iff [simp]:
       "a \<sharp> SubstFormP v i x x' \<longleftrightarrow> a \<sharp> v \<and> a \<sharp> i \<and> a \<sharp> x \<and> a \<sharp> x'"  (is ?thesis1)
    and eval_fm_SubstFormP [simp]:
       "eval_fm e (SubstFormP v i x x') \<longleftrightarrow> SubstForm \<lbrakk>v\<rbrakk>e \<lbrakk>i\<rbrakk>e \<lbrakk>x\<rbrakk>e \<lbrakk>x'\<rbrakk>e"  (is ?thesis2)
    and SubstFormP_sf [iff]:
       "Sigma_fm (SubstFormP v i x x')"  (is ?thsf)
proof -
  obtain s::name and k::name
    where "atom s \<sharp> (v,i,x,x',k)"  "atom k \<sharp> (v,i,x,x')"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis2 ?thsf
    by (auto simp: SubstForm_def)
qed

lemma SubstFormP_subst [simp]:
     "(SubstFormP v i x x')(j::=t) = SubstFormP (subst j t v) (subst j t i) (subst j t x) (subst j t x')"
proof -
  obtain s::name and k::name  where "atom s \<sharp> (v,i,x,x',t,j,k)" "atom k \<sharp> (v,i,x,x',t,j)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: SubstFormP.simps [of s _ _ _ _ k])
qed

lemma SubstFormP_cong:
  "\<lbrakk>H \<turnstile> v EQ v'; H \<turnstile> i EQ i'; H \<turnstile> t EQ t'; H \<turnstile> u EQ u'\<rbrakk>
   \<Longrightarrow> H \<turnstile> SubstFormP v i t u IFF SubstFormP v' i' t' u'"
  by (rule P4_cong) auto

lemma ground_SubstFormP [simp]: "ground_fm (SubstFormP v y x x') \<longleftrightarrow> ground v \<and> ground y \<and> ground x \<and> ground x'"
  by (auto simp: ground_aux_def ground_fm_aux_def supp_conv_fresh)

declare SubstFormP.simps [simp del]

subsection {*Correctness of substitution over formulas*}

lemma SubstForm_imp_subst_dbfm_lemma:
  assumes "SubstForm v \<lbrakk>quot_dbtm u\<rbrakk>e x x'"
    shows "\<exists>A. x = \<lbrakk>quot_dbfm A\<rbrakk>e \<and>
               x' = \<lbrakk>quot_dbfm (subst_dbfm u (decode_Var v) A)\<rbrakk>e"
proof -
  obtain s k where v: "is_Var v" and u: "Term \<lbrakk>quot_dbtm u\<rbrakk>e"
               and sk: "SeqSubstForm v \<lbrakk>quot_dbtm u\<rbrakk>e x x' s k"
    using assms [unfolded SubstForm_def]
    by blast
  from sk [unfolded SeqSubstForm_def]
  show ?thesis
  proof (induct x x' rule: BuildSeq2_induct)
    case (B x x') thus ?case
      apply (auto simp: SubstAtomic_def elim!: SubstTerm_imp_subst_dbtm' [where e=e])
      apply (rule_tac [1] x="DBEq ta tb" in exI)
      apply (rule_tac [2] x="DBMem ta tb" in exI)
      apply (auto simp: q_defs)
      done
  next
    case (C x x' y y' z z')
    then obtain A and B
      where "y = \<lbrakk>quot_dbfm A\<rbrakk>e" "y' = \<lbrakk>quot_dbfm (subst_dbfm u (decode_Var v) A)\<rbrakk>e"
            "z = \<lbrakk>quot_dbfm B\<rbrakk>e" "z' = \<lbrakk>quot_dbfm (subst_dbfm u (decode_Var v) B)\<rbrakk>e"
    by blast
  with C.hyps show ?case
    apply (auto simp: SubstMakeForm_def)
    apply (rule_tac [1] x="DBDisj A B" in exI)
    apply (rule_tac [2] x="DBNeg A" in exI)
    apply (rule_tac [3] x="DBEx A" in exI)
    apply (auto simp: C q_defs)
    done
  qed
qed

lemma SubstForm_imp_subst_dbfm:
  assumes "SubstForm v u x x'"
   obtains t A where "u = \<lbrakk>quot_dbtm t\<rbrakk>e"
                     "x = \<lbrakk>quot_dbfm A\<rbrakk>e"
                     "x' = \<lbrakk>quot_dbfm (subst_dbfm t (decode_Var v) A)\<rbrakk>e"
proof -
  obtain t where "u = \<lbrakk>quot_dbtm t\<rbrakk>e"
    using assms [unfolded SubstForm_def]
    by (metis Term_imp_wf_dbtm)
  thus ?thesis
    by (metis SubstForm_imp_subst_dbfm_lemma assms that)
qed

lemma SubstForm_subst_dbfm:
  assumes u: "wf_dbtm u"
  shows "SubstForm (q_Var i) \<lbrakk>quot_dbtm u\<rbrakk>e \<lbrakk>quot_dbfm A\<rbrakk>e
                             \<lbrakk>quot_dbfm (subst_dbfm u i A)\<rbrakk>e"
apply (induction A rule: dbfm.induct)
apply (force simp: u SubstForm_def SeqSubstForm_def SubstAtomic_def SubstMakeForm_def
                   SubstTerm_subst_dbtm q_defs simp del: q_Var_def
           intro: BuildSeq2_exI BuildSeq2_combine)+
done

corollary SubstForm_subst_dbfm_eq:
  "\<lbrakk>v = q_Var i; Term ux; ux = \<lbrakk>quot_dbtm u\<rbrakk>e; A' = subst_dbfm u i A\<rbrakk>
   \<Longrightarrow> SubstForm v ux \<lbrakk>quot_dbfm A\<rbrakk>e \<lbrakk>quot_dbfm A'\<rbrakk>e"
  by (metis SubstForm_subst_dbfm Term_imp_is_tm quot_dbtm_inject_lemma quot_tm_def wf_dbtm_iff_is_tm)

section {*The predicate @{text AtomicP}*}

definition Atomic :: "hf \<Rightarrow> bool"
  where "Atomic y \<equiv>\<exists>t u. Term t \<and> Term u \<and> (y = q_Eq t u \<or> y = q_Mem t u)"

nominal_function AtomicP :: "tm \<Rightarrow> fm"
  where "\<lbrakk>atom t \<sharp> (u,y); atom u \<sharp> y\<rbrakk> \<Longrightarrow>
    AtomicP y = Ex t (Ex u (TermP (Var t) AND TermP (Var u) AND
                      (y EQ Q_Eq (Var t) (Var u) OR
                       y EQ Q_Mem (Var t) (Var u))))"
  by (auto simp: eqvt_def AtomicP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows AtomicP_fresh_iff [simp]: "a \<sharp> AtomicP y \<longleftrightarrow> a \<sharp> y"    (is ?thesis1)
    and eval_fm_AtomicP [simp]: "eval_fm e (AtomicP y) \<longleftrightarrow> Atomic\<lbrakk>y\<rbrakk>e"    (is ?thesis2)
    and AtomicP_sf [iff]: "Sigma_fm (AtomicP y)"  (is ?thsf)
proof -
  obtain t::name and u::name  where "atom t \<sharp> (u,y)"  "atom u \<sharp> y"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis2 ?thsf
    by (auto simp: Atomic_def q_defs)
qed

section {*The predicate @{text MakeForm} *}

definition MakeForm :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
  where "MakeForm y u w \<equiv>
         y = q_Disj u w \<or> y = q_Neg u \<or>
         (\<exists>v u'. AbstForm v 0 u u' \<and> y = q_Ex u')"

nominal_function MakeFormP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom v \<sharp> (y,u,w,au); atom au \<sharp> (y,u,w)\<rbrakk> \<Longrightarrow>
    MakeFormP y u w =
      y EQ Q_Disj u w OR y EQ Q_Neg u OR
      Ex v (Ex au (AbstFormP (Var v) Zero u (Var au) AND y EQ Q_Ex (Var au)))"
  by (auto simp: eqvt_def MakeFormP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows MakeFormP_fresh_iff [simp]:
       "a \<sharp> MakeFormP y u w \<longleftrightarrow> a \<sharp> y \<and> a \<sharp> u \<and> a \<sharp> w"  (is ?thesis1)
    and eval_fm_MakeFormP [simp]:
       "eval_fm e (MakeFormP y u w) \<longleftrightarrow> MakeForm \<lbrakk>y\<rbrakk>e \<lbrakk>u\<rbrakk>e \<lbrakk>w\<rbrakk>e"  (is ?thesis2)
    and MakeFormP_sf [iff]:
       "Sigma_fm (MakeFormP y u w)"  (is ?thsf)
proof -
  obtain v::name and au::name  where "atom v \<sharp> (y,u,w,au)"  "atom au \<sharp> (y,u,w)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis2 ?thsf
    by (auto simp: MakeForm_def q_defs)
qed

declare MakeFormP.simps [simp del]

section {*The predicate @{text SeqFormP} *}

(*SeqForm(s,k,t) \<equiv> LstSeq(s,k,t) \<and> (\<forall>n\<in>k)[Atomic (s n) \<or> (\<exists>m,l\<in>n)[MakeForm (s m) (s l) (s n)]]*)
definition SeqForm :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
  where "SeqForm s k y \<equiv> BuildSeq Atomic MakeForm s k y"

nominal_function SeqFormP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom l \<sharp> (s,k,t,sl,m,n,sm,sn); atom sl \<sharp> (s,k,t,m,n,sm,sn);
          atom m \<sharp> (s,k,t,n,sm,sn); atom n \<sharp> (s,k,t,sm,sn);
          atom sm \<sharp> (s,k,t,sn); atom sn \<sharp> (s,k,t)\<rbrakk> \<Longrightarrow>
    SeqFormP s k t =
      LstSeqP s k t AND
      All2 n (SUCC k) (Ex sn (HPair (Var n) (Var sn) IN s AND (AtomicP (Var sn) OR
                Ex m (Ex l (Ex sm (Ex sl (Var m IN Var n AND Var l IN Var n AND
                       HPair (Var m) (Var sm) IN s AND HPair (Var l) (Var sl) IN s AND
                       MakeFormP (Var sn) (Var sm) (Var sl))))))))"
  by (auto simp: eqvt_def SeqFormP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows SeqFormP_fresh_iff [simp]:
       "a \<sharp> SeqFormP s k t \<longleftrightarrow> a \<sharp> s \<and> a \<sharp> k \<and> a \<sharp> t" (is ?thesis1)
    and eval_fm_SeqFormP [simp]:
       "eval_fm e (SeqFormP s k t) \<longleftrightarrow> SeqForm \<lbrakk>s\<rbrakk>e \<lbrakk>k\<rbrakk>e \<lbrakk>t\<rbrakk>e"   (is ?thesis2)
    and SeqFormP_sf [iff]: "Sigma_fm (SeqFormP s k t)"          (is ?thsf)
proof -
  obtain l::name and sl::name and m::name and n::name and sm::name and sn::name
    where atoms: "atom l \<sharp> (s,k,t,sl,m,n,sm,sn)"   "atom sl \<sharp> (s,k,t,m,n,sm,sn)"
        "atom m \<sharp> (s,k,t,n,sm,sn)"   "atom n \<sharp> (s,k,t,sm,sn)"
        "atom sm \<sharp> (s,k,t,sn)"       "atom sn \<sharp> (s,k,t)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thsf
    by auto
  show ?thesis2 using atoms
    by (simp cong: conj_cong add: LstSeq_imp_Ord SeqForm_def BuildSeq_def Builds_def
             HBall_def HBex_def q_defs
             Seq_iff_app [of "\<lbrakk>s\<rbrakk>e", OF LstSeq_imp_Seq_succ]
             Ord_trans [of _ _ "succ \<lbrakk>k\<rbrakk>e"])
qed

lemma SeqFormP_subst [simp]:
      "(SeqFormP s k t)(j::=w) = SeqFormP (subst j w s) (subst j w k) (subst j w t)"
proof -
  obtain l::name and sl::name and m::name and n::name and sm::name and sn::name
    where "atom l \<sharp> (j,w,s,t,k,sl,m,n,sm,sn)"   "atom sl \<sharp> (j,w,s,k,t,m,n,sm,sn)"
        "atom m \<sharp> (j,w,s,k,t,n,sm,sn)"   "atom n \<sharp> (j,w,s,k,t,sm,sn)"
        "atom sm \<sharp> (j,w,s,k,t,sn)"   "atom sn \<sharp> (j,w,s,k,t)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: SeqFormP.simps [of l _ _ _ sl m n sm sn])
qed

section {*The predicate @{text FormP}*}

subsection {*Definition*}

definition Form :: "hf \<Rightarrow> bool"
  where "Form y \<equiv> (\<exists>s k. SeqForm s k y)"

nominal_function FormP :: "tm \<Rightarrow> fm"
  where "\<lbrakk>atom k \<sharp> (s,y); atom s \<sharp> y\<rbrakk> \<Longrightarrow>
    FormP y = Ex k (Ex s (SeqFormP (Var s) (Var k) y))"
  by (auto simp: eqvt_def FormP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows FormP_fresh_iff [simp]: "a \<sharp> FormP y \<longleftrightarrow> a \<sharp> y"              (is ?thesis1)
    and eval_fm_FormP [simp]:   "eval_fm e (FormP y) \<longleftrightarrow> Form \<lbrakk>y\<rbrakk>e"  (is ?thesis2)
    and FormP_sf [iff]:         "Sigma_fm (FormP y)"                 (is ?thsf)
proof -
  obtain k::name and s::name  where k: "atom k \<sharp> (s,y)" "atom s \<sharp> y"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis2 ?thsf
    by (auto simp: Form_def)
qed

lemma FormP_subst [simp]: "(FormP y)(j::=w) = FormP (subst j w y)"
proof -
  obtain k::name and s::name where "atom k \<sharp> (s,j,w,y)"  "atom s \<sharp> (j,w,y)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: FormP.simps [of k s])
qed

subsection {*Correctness: It Corresponds to Quotations of Real Formulas*}

lemma AbstForm_trans_fm:
  "AbstForm (q_Var i) 0 \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e \<lbrakk>quot_dbfm (trans_fm [i] A)\<rbrakk>e"
  by (metis abst_trans_fm ord_of.simps(1) quot_fm_def AbstForm_abst_dbfm)

corollary AbstForm_trans_fm_eq:
  "\<lbrakk>x = \<lbrakk>\<lceil>A\<rceil>\<rbrakk> e;  x' = \<lbrakk>quot_dbfm (trans_fm [i] A)\<rbrakk>e\<rbrakk> \<Longrightarrow> AbstForm (q_Var i) 0 x x'"
  by (metis AbstForm_trans_fm)

lemma wf_Form_quot_dbfm [simp]:
  assumes "wf_dbfm A" shows "Form \<lbrakk>quot_dbfm A\<rbrakk>e"
using assms
proof (induct rule: wf_dbfm.induct)
  case (Mem tm1 tm2)
  hence "Atomic \<lbrakk>quot_dbfm (DBMem tm1 tm2)\<rbrakk>e"
    by (auto simp: Atomic_def quot_Mem q_Mem_def dest: wf_Term_quot_dbtm)
  thus ?case
    by (auto simp: Form_def SeqForm_def BuildSeq_exI)
next
  case (Eq tm1 tm2)
  hence "Atomic \<lbrakk>quot_dbfm (DBEq tm1 tm2)\<rbrakk>e"
    by (auto simp: Atomic_def quot_Eq q_Eq_def dest: wf_Term_quot_dbtm)
  thus ?case
    by (auto simp: Form_def SeqForm_def BuildSeq_exI)
next
  case (Disj A1 A2)
    have "MakeForm \<lbrakk>quot_dbfm (DBDisj A1 A2)\<rbrakk>e \<lbrakk>quot_dbfm A1\<rbrakk>e \<lbrakk>quot_dbfm A2\<rbrakk>e"
      by (simp add: quot_Disj q_Disj_def MakeForm_def)
  thus ?case using Disj
    by (force simp add: Form_def SeqForm_def intro: BuildSeq_combine)
next
  case (Neg A)
    have "\<And>y. MakeForm \<lbrakk>quot_dbfm (DBNeg A)\<rbrakk>e \<lbrakk>quot_dbfm A\<rbrakk>e y"
      by (simp add: quot_Neg q_Neg_def MakeForm_def)
  thus ?case using Neg
    by (force simp add: Form_def SeqForm_def intro: BuildSeq_combine)
next
  case (Ex A i)
  have "\<And>A y. MakeForm \<lbrakk>quot_dbfm (DBEx (abst_dbfm i 0 A))\<rbrakk>e \<lbrakk>quot_dbfm A\<rbrakk>e y"
    by (simp add: quot_Ex q_defs MakeForm_def) (metis AbstForm_abst_dbfm ord_of.simps(1))
  thus ?case using Ex
    by (force simp add: Form_def SeqForm_def intro: BuildSeq_combine)
qed

lemma Form_quot_fm [iff]: fixes A :: fm  shows "Form \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e"
  by (metis quot_fm_def wf_Form_quot_dbfm wf_dbfm_trans_fm)

lemma Atomic_Form_is_wf_dbfm: "Atomic x \<Longrightarrow> \<exists>A. wf_dbfm A \<and> x = \<lbrakk>quot_dbfm A\<rbrakk>e"
proof (auto simp: Atomic_def)
  fix t u
  assume t: "Term t" and  u: "Term u"
  then obtain tm1 and tm2
    where tm1: "wf_dbtm tm1" "t = \<lbrakk>quot_dbtm tm1\<rbrakk>e"
      and tm2: "wf_dbtm tm2" "u = \<lbrakk>quot_dbtm tm2\<rbrakk>e"
      by (metis Term_imp_is_tm quot_tm_def wf_dbtm_trans_tm)+
  thus "\<exists>A. wf_dbfm A \<and> q_Eq t u = \<lbrakk>quot_dbfm A\<rbrakk>e"
    by (auto simp: quot_Eq q_Eq_def)
next
  fix t u
  assume t: "Term t" and  u: "Term u"
  then obtain tm1 and tm2
    where tm1: "wf_dbtm tm1" "t = \<lbrakk>quot_dbtm tm1\<rbrakk>e"
      and tm2: "wf_dbtm tm2" "u = \<lbrakk>quot_dbtm tm2\<rbrakk>e"
      by (metis Term_imp_is_tm quot_tm_def wf_dbtm_trans_tm)+
  thus "\<exists>A. wf_dbfm A \<and> q_Mem t u = \<lbrakk>quot_dbfm A\<rbrakk>e"
    by (auto simp: quot_Mem q_Mem_def)
qed

lemma SeqForm_imp_wf_dbfm:
  assumes "SeqForm s k x"
  shows "\<exists>A. wf_dbfm A \<and> x = \<lbrakk>quot_dbfm A\<rbrakk>e"
using assms [unfolded SeqForm_def]
proof (induct x rule: BuildSeq_induct)
  case (B x) thus ?case
    by (rule Atomic_Form_is_wf_dbfm)
next
  case (C x y z)
  then obtain A B where "wf_dbfm A" "y = \<lbrakk>quot_dbfm A\<rbrakk>e"
                        "wf_dbfm B" "z = \<lbrakk>quot_dbfm B\<rbrakk>e"
    by blast
  thus ?case using C
    apply (auto simp: MakeForm_def dest!: AbstForm_imp_abst_dbfm [where e=e])
    apply (rule exI [where x="DBDisj A B"])
    apply (rule_tac [2] x="DBNeg A" in exI)
    apply (rule_tac [3] x="DBEx (abst_dbfm (decode_Var v) 0 A)" in exI)
    apply (auto simp: q_defs)
    done
qed

lemma Form_imp_wf_dbfm:
  assumes "Form x" obtains A where "wf_dbfm A" "x = \<lbrakk>quot_dbfm A\<rbrakk>e"
  by (metis assms SeqForm_imp_wf_dbfm Form_def)

lemma Form_imp_is_fm: assumes "Form x" obtains A::fm where "x = \<lbrakk>\<lceil>A\<rceil>\<rbrakk> e"
  by (metis assms Form_imp_wf_dbfm quot_fm_def wf_dbfm_imp_is_fm)

lemma SubstForm_imp_subst_fm:
  assumes "SubstForm v \<lbrakk>\<lceil>u\<rceil>\<rbrakk>e x x'" "Form x"
  obtains A::fm where "x = \<lbrakk>\<lceil>A\<rceil>\<rbrakk> e" "x' = \<lbrakk>\<lceil>A(decode_Var v::=u)\<rceil>\<rbrakk> e"
  using assms [unfolded quot_tm_def]
  by (auto simp: quot_fm_def dest!: SubstForm_imp_subst_dbfm_lemma)
     (metis Form_imp_is_fm eval_quot_dbfm_ignore quot_dbfm_inject_lemma quot_fm_def)

lemma SubstForm_unique:
  assumes "is_Var v" and "Term y" and "Form x"
     shows "SubstForm v y x x' \<longleftrightarrow>
            (\<exists>t::tm. y = \<lbrakk>\<lceil>t\<rceil>\<rbrakk>e \<and> (\<exists>A::fm. x = \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e \<and> x' = \<lbrakk>\<lceil>A(decode_Var v::=t)\<rceil>\<rbrakk>e))"
  using assms
  apply (auto elim!: Term_imp_wf_dbtm [where e=e] Form_imp_is_fm [where e=e]
                     SubstForm_imp_subst_dbfm [where e=e])
  apply (auto simp: quot_tm_def quot_fm_def is_Var_iff q_Var_def intro: SubstForm_subst_dbfm_eq)
  apply (metis subst_fm_trans_commute wf_dbtm_imp_is_tm)
  done

lemma SubstForm_quot_unique: "SubstForm (q_Var i) \<lbrakk>\<lceil>t\<rceil>\<rbrakk>e \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e x' \<longleftrightarrow> x' = \<lbrakk>\<lceil>A(i::=t)\<rceil>\<rbrakk> e"
  by (subst SubstForm_unique [where e=e]) auto

lemma SubstForm_quot: "SubstForm \<lbrakk>\<lceil>Var i\<rceil>\<rbrakk>e \<lbrakk>\<lceil>t\<rceil>\<rbrakk>e \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e \<lbrakk>\<lceil>A(i::=t)\<rceil>\<rbrakk>e"
  by (metis SubstForm_quot_unique eval_Var_q)

subsection {*The predicate @{text VarNonOccFormP} (Derived from @{text SubstFormP})*}

definition VarNonOccForm :: "hf \<Rightarrow> hf \<Rightarrow> bool"
where "VarNonOccForm v x \<equiv> Form x \<and> SubstForm v 0 x x"

nominal_function VarNonOccFormP :: "tm \<Rightarrow> tm \<Rightarrow> fm"
  where "VarNonOccFormP v x = FormP x AND SubstFormP v Zero x x"
  by (auto simp: eqvt_def VarNonOccFormP_graph_aux_def)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows VarNonOccFormP_fresh_iff [simp]: "a \<sharp> VarNonOccFormP v y \<longleftrightarrow> a \<sharp> v \<and> a \<sharp> y" (is ?thesis1)
    and eval_fm_VarNonOccFormP [simp]:
       "eval_fm e (VarNonOccFormP v y) \<longleftrightarrow> VarNonOccForm \<lbrakk>v\<rbrakk>e \<lbrakk>y\<rbrakk>e"    (is ?thesis2)
    and VarNonOccFormP_sf [iff]: "Sigma_fm (VarNonOccFormP v y)" (is ?thsf)
proof -
  show ?thesis1 ?thsf ?thesis2
    by (auto simp add: VarNonOccForm_def)
qed

subsection {*Correctness for Real Terms and Formulas*}

lemma VarNonOccForm_imp_dbfm_fresh:
  assumes "VarNonOccForm v x"
  shows "\<exists>A. wf_dbfm A \<and> x = \<lbrakk>quot_dbfm A\<rbrakk>e \<and> atom (decode_Var v) \<sharp> A"
proof -
  obtain A' where A': "wf_dbfm A'" "x = \<lbrakk>quot_dbfm A'\<rbrakk>e" "SubstForm v \<lbrakk>quot_dbtm DBZero\<rbrakk>e x x"
    using assms [unfolded VarNonOccForm_def]
    by auto (metis Form_imp_wf_dbfm)
  then obtain A where "x = \<lbrakk>quot_dbfm A\<rbrakk>e"
                      "x = \<lbrakk>quot_dbfm (subst_dbfm DBZero (decode_Var v) A)\<rbrakk>e"
    by (metis SubstForm_imp_subst_dbfm_lemma)
  thus ?thesis using A'
    by auto (metis fresh_iff_non_subst_dbfm)
qed

corollary VarNonOccForm_imp_fresh:
  assumes "VarNonOccForm v x"  obtains A::fm where "x = \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e" "atom (decode_Var v) \<sharp> A"
  using VarNonOccForm_imp_dbfm_fresh [OF assms, where e=e]
  by (auto simp: quot_fm_def wf_dbfm_iff_is_fm)

lemma VarNonOccForm_dbfm:
  "wf_dbfm A \<Longrightarrow> atom i \<sharp> A \<Longrightarrow> VarNonOccForm (q_Var i) \<lbrakk>quot_dbfm A\<rbrakk>e"
by (auto intro: SubstForm_subst_dbfm_eq [where u=DBZero]
    simp add: VarNonOccForm_def Const_0 Const_imp_Term fresh_iff_non_subst_dbfm [symmetric])

corollary fresh_imp_VarNonOccForm:
  fixes A::fm  shows "atom i \<sharp> A \<Longrightarrow> VarNonOccForm (q_Var i) \<lbrakk>\<lceil>A\<rceil>\<rbrakk>e"
  by (simp add: quot_fm_def wf_dbfm_trans_fm VarNonOccForm_dbfm)

declare VarNonOccFormP.simps [simp del]

end