(* Author: Dmitriy Traytel *)

section "Some Useful Regular Operators"

(*<*)
theory Pi_Regular_Operators
imports Pi_Derivatives "HOL-Library.While_Combinator"
begin
(*>*)

primrec REV :: "'a rexp \<Rightarrow> 'a rexp" where
  "REV Zero = Zero"
| "REV Full = Full"
| "REV One = One"
| "REV (Atom a) = Atom a"
| "REV (Plus r s) = Plus (REV r) (REV s)"
| "REV (Times r s) = Times (REV s) (REV r)"
| "REV (Star r) = Star (REV r)"
| "REV (Not r) = Not (REV r)"
| "REV (Inter r s) = Inter (REV r) (REV s)"
| "REV (Pr r) = Pr (REV r)"

lemma REV_REV[simp]: "REV (REV r) = r"
  by (induct r) auto

lemma final_REV[simp]: "final (REV r) = final r"
  by (induct r) auto

lemma REV_PLUS: "REV (PLUS xs) = PLUS (map REV xs)"
  by (induct xs rule: list_singleton_induct) auto

lemma (in alphabet) wf_REV[simp]: "wf n r \<Longrightarrow> wf n (REV r)"
  by (induct r arbitrary: n) auto

lemma (in project) lang_REV[simp]: "lang n (REV r) = rev ` lang n r"
  by (induct r arbitrary: n) (auto simp: image_image rev_map image_set_diff)

context embed
begin

primrec rderiv :: "'a \<Rightarrow> 'b rexp \<Rightarrow> 'b rexp" where
  "rderiv _ Zero = Zero"
| "rderiv _ Full = Full"
| "rderiv _ One = Zero"
| "rderiv a (Atom b) = (if lookup b a then One else Zero)"
| "rderiv a (Plus r s) = Plus (rderiv a r) (rderiv a s)"
| "rderiv a (Times r s) =
    (let rs' = Times r (rderiv a s)
     in if final s then Plus rs' (rderiv a r) else rs')"
| "rderiv a (Star r) = Times (Star r) (rderiv a r)"
| "rderiv a (Not r) = Not (rderiv a r)"
| "rderiv a (Inter r s) = Inter (rderiv a r) (rderiv a s)"
| "rderiv a (Pr r) = Pr (PLUS (map (\<lambda>a'. rderiv a' r) (embed a)))"

primrec rderivs where
  "rderivs [] r = r"
| "rderivs (w#ws) r = rderivs ws (rderiv w r)"

lemma rderivs_snoc: "rderivs (ws @ [w]) r = rderiv w (rderivs ws r)"
  by (induct ws arbitrary: r) auto

lemma rderivs_append: "rderivs (ws @ ws') r = rderivs ws' (rderivs ws r)"
  by (induct ws arbitrary: r) auto

lemma rderiv_lderiv: "rderiv as r = REV (lderiv as (REV r))"
  by (induct r arbitrary: as) (auto simp: Let_def o_def REV_PLUS)

lemma wf_rderiv[simp]: "wf n r \<Longrightarrow> wf n (rderiv w r)"
  unfolding rderiv_lderiv by (rule wf_REV[OF wf_lderiv[OF wf_REV]])

lemma wf_rderivs[simp]: "wf n r \<Longrightarrow> wf n (rderivs ws r)"
  unfolding rderivs_lderivs by (rule wf_REV[OF wf_lderivs[OF wf_REV]])

lemma lang_rderivs: "\<lbrakk>wf n r; wf_word n w\<rbrakk> \<Longrightarrow> lang n (rderivs w r) = rQuots w (lang n r)"
  unfolding rderivs_lderivs rQuots_rev_lQuots by (simp add: lang_lderivs)

corollary rderivs_final:
assumes "wf n r" "wf_word n w"
shows "final (rderivs w r) \<longleftrightarrow> rev w \<in> lang n r"
  using lang_rderivs[OF assms] lang_final[of "rderivs w r" n] by auto

lemma toplevel_summands_REV[simp]: "toplevel_summands (REV r) = REV ` toplevel_summands r"
  by (induct r) auto

lemma ACI_norm_REV: "\<guillemotleft>REV \<guillemotleft>r\<guillemotright>\<guillemotright> = \<guillemotleft>REV r\<guillemotright>"
proof (induct r)
  case (Plus r s)
  show ?case
    using [[unfold_abs_def = false]]
    unfolding REV.simps ACI_norm.simps Plus[symmetric] image_Un[symmetric]
      toplevel_summands.simps(1) toplevel_summands_ACI_norm toplevel_summands_REV
    unfolding toplevel_summands.simps(1)[symmetric] ACI_norm_flatten toplevel_summands_REV
    unfolding ACI_norm_flatten[symmetric] toplevel_summands_ACI_norm
    ..
qed auto

lemma ACI_norm_rderiv: "\<guillemotleft>rderiv as \<guillemotleft>r\<guillemotright>\<guillemotright> = \<guillemotleft>rderiv as r\<guillemotright>"
  unfolding rderiv_lderiv by (metis ACI_norm_REV ACI_norm_lderiv)

lemma ACI_norm_rderivs: "\<guillemotleft>rderivs w \<guillemotleft>r\<guillemotright>\<guillemotright> = \<guillemotleft>rderivs w r\<guillemotright>"
  unfolding rderivs_lderivs by (metis ACI_norm_REV ACI_norm_lderivs)

theorem finite_rderivs: "finite {\<guillemotleft>rderivs xs r\<guillemotright> | xs . True}"
  unfolding rderivs_lderivs
  by (subst ACI_norm_REV[symmetric]) (auto intro: finite_surj[OF finite_lderivs, of _ "\<lambda>r. \<guillemotleft>REV r\<guillemotright>"])

lemma lderiv_PLUS[simp]: "lderiv a (PLUS xs) = PLUS (map (lderiv a) xs)"
  by (induct xs rule: list_singleton_induct) auto

lemma rderiv_PLUS[simp]: "rderiv a (PLUS xs) = PLUS (map (rderiv a) xs)"
  by (induct xs rule: list_singleton_induct) auto

lemma lang_rderiv_lderiv: "lang n (rderiv a (lderiv b r)) = lang n (lderiv b (rderiv a r))"
  by (induct r arbitrary: n a b) (auto simp: Let_def conc_assoc)

lemma lang_lderiv_rderiv: "lang n (lderiv a (rderiv b r)) = lang n (rderiv b (lderiv a r))"
  by (induct r arbitrary: n a b) (auto simp: Let_def conc_assoc)

lemma lang_rderiv_lderivs[simp]: "\<lbrakk>wf n r; wf_word n w; a \<in> \<Sigma> n\<rbrakk> \<Longrightarrow>
  lang n (rderiv a (lderivs w r)) = lang n (lderivs w (rderiv a r))"
  by (induct w arbitrary: n r)
    (auto, auto simp: lang_lderivs lang_lderiv lang_rderiv lQuot_rQuot)

lemma lang_lderiv_rderivs[simp]: "\<lbrakk>wf n r; wf_word n w; a \<in> \<Sigma> n\<rbrakk> \<Longrightarrow>
  lang n (lderiv a (rderivs w r)) = lang n (rderivs w (lderiv a r))"
  by (induct w arbitrary: n r)
    (auto, auto simp: lang_rderivs lang_lderiv lang_rderiv lQuot_rQuot)
(*
primrec bideriv :: "'a \<Rightarrow> 'a \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp" where
  "bideriv _ _ Zero = Zero"
| "bideriv _ _ One = Zero"
| "bideriv a b (Atom c) = Zero"
| "bideriv a b (Plus r s) = Plus (bideriv a b r) (bideriv a b s)"
| "bideriv a b (Times r s) =
    (let rs' = Times (lderiv a r) (rderiv b s)
     in if final r \<and> final s then Plus (Plus rs' (bideriv a b r)) (bideriv a b s)
        else if final r then Plus rs' (bideriv a b s)
        else if final s then Plus rs' (bideriv a b r)
        else rs')"
| "bideriv a b (Star r) = Plus (bideriv a b r) (TIMES [lderiv a r, Star r, rderiv b r])"
| "bideriv a b (Not r) = Not (bideriv a b r)"
| "bideriv a b (Inter r s) = Inter (bideriv a b r) (bideriv a b s)"
| "bideriv a b (Pr r) = Pr (PLUS (map (\<lambda>b. PLUS (map (\<lambda>a. bideriv a b r) (embed a))) (embed b)))"

lemma wf_bideriv[simp]: "wf n r \<Longrightarrow> wf n (bideriv a b r)"
  by (induct r arbitrary: n a b) (auto simp: maps_def Let_def)

lemma ACI_norm_bideriv_rderiv_lderiv: "\<guillemotleft>bideriv a b r\<guillemotright> = \<guillemotleft>rderiv b (lderiv a r)\<guillemotright>"
  by (induct r arbitrary: a b)
    (auto simp: Let_def maps_def o_def list_all2_map1 list_all2_map2 intro!: ACI_PLUS list_all2_refl)

lemma bideriv_rderiv_lderiv:
  "lang n (bideriv a b r) = lang n (rderiv b (lderiv a r))"
  by (induct r arbitrary: n a b) (auto simp: Let_def)

lemma lang_bideriv:
  "\<lbrakk>wf n r; a \<in> \<Sigma> n; b \<in> \<Sigma> n\<rbrakk> \<Longrightarrow> lang n (bideriv a b r) = biQuot a b (lang n r)"
  by (auto simp: bideriv_rderiv_lderiv lang_lderiv lang_rderiv biQuot_rQuot_lQuot)

lemma ACI_norm_bideriv: "\<guillemotleft>bideriv a b \<guillemotleft>r\<guillemotright>\<guillemotright> = \<guillemotleft>bideriv a b r\<guillemotright>"
  unfolding ACI_norm_bideriv_rderiv_lderiv by (metis ACI_norm_lderiv ACI_norm_rderiv)

fun biderivs where
  "biderivs [] [] r = r"
| "biderivs as [] r = lderivs as r"
| "biderivs [] bs r = rderivs bs r"
| "biderivs (a#as) (b#bs) r = biderivs as bs (bideriv a b r)"

lemma biderivs_rderivs_lderivs: "\<lbrakk>wf n r; wf_word n w1; wf_word n w2\<rbrakk> \<Longrightarrow>
  lang n (biderivs w1 w2 r) = lang n (rderivs w2 (lderivs w1 r))"
  by (induct arbitrary: r rule: biderivs.induct)
    (auto simp: lang_rderivs lang_lderivs bideriv_rderiv_lderiv)

lemma lang_biderivs:
  "\<lbrakk>wf n r; wf_word n w1; wf_word n w2\<rbrakk> \<Longrightarrow> lang n (biderivs w1 w2 r) = biQuots w1 w2 (lang n r)"
  by (auto simp: biderivs_rderivs_lderivs lang_lderivs lang_rderivs biQuots_rQuots_lQuots)

lemma wf_biderivs[simp]: "wf n r \<Longrightarrow> wf n (biderivs w1 w2 r)"
  by (induct arbitrary: r rule: biderivs.induct) auto
*)
definition "biderivs w1 w2 = rderivs w2 o lderivs w1"

lemma lang_biderivs: "\<lbrakk>wf n r; wf_word n w1; wf_word n w2\<rbrakk> \<Longrightarrow>
  lang n (biderivs w1 w2 r) = biQuots w1 w2 (lang n r)"
   unfolding biderivs_def by (auto simp: lang_rderivs lang_lderivs in_lists_conv_set)

lemma wf_biderivs[simp]: "wf n r \<Longrightarrow> wf n (biderivs w1 w2 r)"
  unfolding biderivs_def by simp

corollary biderivs_final:
assumes "wf n r" "wf_word n w1" "wf_word n w2"
shows "final (biderivs w1 w2 r) \<longleftrightarrow> w1 @ rev w2 \<in> lang n r"
  using lang_biderivs[OF assms] lang_final[of "biderivs w1 w2 r" n] by auto

lemma ACI_norm_biderivs: "\<guillemotleft>biderivs w1 w2 \<guillemotleft>r\<guillemotright>\<guillemotright> = \<guillemotleft>biderivs w1 w2 r\<guillemotright>"
  unfolding biderivs_def by (metis ACI_norm_lderivs ACI_norm_rderivs o_apply)

lemma "finite {\<guillemotleft>biderivs w1 w2 r\<guillemotright> | w1 w2 . True}"
proof -
  have "{\<guillemotleft>biderivs w1 w2 r\<guillemotright> | w1 w2 . True} =
    (\<Union>s \<in> {\<guillemotleft>lderivs as r\<guillemotright> | as . True}. {\<guillemotleft>rderivs bs s\<guillemotright> | bs . True})"
    unfolding biderivs_def by (fastforce simp: ACI_norm_rderivs)
  also have "finite \<dots>" by (rule iffD2[OF finite_UN[OF finite_lderivs] ballI[OF finite_rderivs]])
  finally show ?thesis .
qed

end

subsection \<open>Quotioning by the same letter\<close>

definition "fin_cut_same x xs = take (LEAST n. drop n xs = replicate (length xs - n) x) xs"

lemma fin_cut_same_Nil[simp]: "fin_cut_same x [] = []"
  unfolding fin_cut_same_def by simp

lemma Least_fin_cut_same: "(LEAST n. drop n xs = replicate (length xs - n) y) =
  length xs - length (takeWhile (\<lambda>x. x = y) (rev xs))"
  (is "Least ?P = ?min")
proof (rule Least_equality)
  show "?P ?min" by (induct xs rule: rev_induct) (auto simp:  Suc_diff_le replicate_append_same)
next
  fix m assume "?P m"
  have "length xs - m \<le> length (takeWhile (\<lambda>x. x = y) (rev xs))"
  proof (intro length_takeWhile_less_P_nth)
    fix i assume "i < length xs - m"
    hence "rev xs ! i \<in> set (drop m xs)"
      by (induct xs arbitrary: i rule: rev_induct) (auto simp: nth_Cons')
    with \<open>?P m\<close> show "rev xs ! i = y" by simp
  qed simp
  thus "?min \<le> m" by linarith
qed

lemma takeWhile_takes_all: "length xs = m \<Longrightarrow> m \<le> length (takeWhile P xs) \<longleftrightarrow> Ball (set xs) P"
  by hypsubst_thin (induct xs, auto)

lemma fin_cut_same_Cons[simp]: "fin_cut_same x (y # xs) =
  (if fin_cut_same x xs = [] then if x = y then [] else [y] else y # fin_cut_same x xs)"
  unfolding fin_cut_same_def Least_fin_cut_same
  apply auto
  apply (simp add: takeWhile_takes_all)
  apply (simp add: takeWhile_takes_all)
  apply auto
  apply (metis (full_types) Suc_diff_le length_rev length_takeWhile_le take_Suc_Cons)
  apply (simp add: takeWhile_takes_all)
  apply (subst takeWhile_append2)
  apply auto
  apply (simp add: takeWhile_takes_all)
  apply auto
  apply (metis (full_types) Suc_diff_le length_rev length_takeWhile_le take_Suc_Cons)
  done

lemma fin_cut_same_singleton[simp]: "fin_cut_same x (xs @ [x]) = fin_cut_same x xs"
  by (induct xs) auto

lemma fin_cut_same_replicate[simp]: "fin_cut_same x (xs @ replicate n x) = fin_cut_same x xs"
  by (induct n arbitrary: xs)
    (auto simp: replicate_append_same[symmetric] append_assoc[symmetric] simp del: append_assoc)

lemma fin_cut_sameE: "fin_cut_same x xs = ys \<Longrightarrow> \<exists>m. xs = ys @ replicate m x"
  by (induct xs arbitrary: ys) (auto, metis replicate_Suc)

definition "SAMEQUOT a A = {fin_cut_same a x @ replicate m a| x m. x \<in> A}"

lemma SAMEQUOT_mono: "A \<subseteq> B \<Longrightarrow> SAMEQUOT a A \<subseteq> SAMEQUOT a B"
  unfolding SAMEQUOT_def by auto

locale embed2 = embed \<Sigma> wf_atom project lookup embed
  for \<Sigma> :: "nat \<Rightarrow> 'a set"
  and wf_atom :: "nat \<Rightarrow> 'b :: linorder \<Rightarrow> bool"
  and project :: "'a \<Rightarrow> 'a"
  and lookup :: "'b \<Rightarrow> 'a \<Rightarrow> bool"
  and embed :: "'a \<Rightarrow> 'a list" +
  fixes singleton :: "'a \<Rightarrow> 'b"
  assumes wf_singleton[simp]: "a \<in> \<Sigma> n \<Longrightarrow> wf_atom n (singleton a)"
  assumes lookup_singleton[simp]: "lookup (singleton a) a' = (a = a')"
begin

lemma finite_rderivs_same: "finite {\<guillemotleft>rderivs (replicate m a) r\<guillemotright> | m . True}"
  by (auto intro: finite_subset[OF _ finite_rderivs])

lemma wf_word_replicate[simp]: "a \<in> \<Sigma> n \<Longrightarrow> wf_word n (replicate m a)"
  by (induct m) auto

lemma star_singleton[simp]: "star {[x]} = {replicate m x | m . True}"
proof (intro equalityI subsetI)
  fix xs assume "xs \<in> star {[x]}"
  thus "xs \<in> {replicate m x | m . True}" by (induct xs) (auto, metis replicate_Suc)
qed (auto intro: Ball_starI)

definition "samequot a r = Times (flatten PLUS {\<guillemotleft>rderivs (replicate m a) r\<guillemotright> | m . True}) (Star (Atom (singleton a)))"

lemma wf_samequot: "\<lbrakk>wf n r; a \<in> \<Sigma> n\<rbrakk> \<Longrightarrow> wf n (samequot a r)"
  unfolding samequot_def wf.simps wf_flatten_PLUS[OF finite_rderivs_same] by auto

lemma lang_samequot: "\<lbrakk>wf n r; a \<in> \<Sigma> n\<rbrakk> \<Longrightarrow>
   lang n (samequot a r) = SAMEQUOT a (lang n r)"
   unfolding SAMEQUOT_def samequot_def lang.simps lang_flatten_PLUS[OF finite_rderivs_same]
   apply (rule sym)
   apply (auto simp: lang_rderivs)
   apply (intro concI)
   apply auto
   apply (insert fin_cut_sameE[OF refl, of _ a])
   apply (drule meta_spec)
   apply (erule exE)
   apply (intro exI conjI)
   apply (rule refl)
   apply (auto simp: lang_rderivs)
   apply (erule subst)
   apply assumption
   apply (erule concE)
   apply (auto simp: lang_rderivs)
   apply (drule meta_spec)
   apply (erule exE)
   apply (intro exI conjI)
   defer
   apply assumption
   unfolding fin_cut_same_replicate
   apply (erule trans)
   unfolding fin_cut_same_replicate
   apply (rule refl)
   done

fun rderiv_and_add where
  "rderiv_and_add as (_ :: bool, rs) =
    (let
      r = \<guillemotleft>rderiv as (hd rs)\<guillemotright>
    in if r \<in> set rs then (False, rs) else (True, r # rs))"

definition "invar_rderiv_and_add as r brs \<equiv>
  (if fst brs then True else \<guillemotleft>rderiv as (hd (snd brs))\<guillemotright> \<in> set (snd brs)) \<and>
  snd brs \<noteq> [] \<and> distinct (snd brs) \<and>
  (\<forall>i < length (snd brs). snd brs ! i = \<guillemotleft>rderivs (replicate (length (snd brs) - 1 - i) as) r\<guillemotright>)"

lemma invar_rderiv_and_add_init: "invar_rderiv_and_add as r (True, [\<guillemotleft>r\<guillemotright>])"
  unfolding invar_rderiv_and_add_def by auto

lemma invar_rderiv_and_add_step: "invar_rderiv_and_add as r brs \<Longrightarrow> fst brs \<Longrightarrow>
  invar_rderiv_and_add as r (rderiv_and_add as brs)"
  unfolding invar_rderiv_and_add_def by (cases brs) (auto simp:
    Let_def nth_Cons' ACI_norm_rderiv rderivs_snoc[symmetric] neq_Nil_conv replicate_append_same)

lemma rderivs_replicate_mult: "\<lbrakk>\<guillemotleft>rderivs (replicate i as) r\<guillemotright> = \<guillemotleft>r\<guillemotright>; i > 0\<rbrakk> \<Longrightarrow>
  \<guillemotleft>rderivs (replicate (m * i) as) r\<guillemotright> = \<guillemotleft>r\<guillemotright>"
proof (induct m arbitrary: r)
  case (Suc m)
  hence "\<guillemotleft>rderivs (replicate (m * i) as) \<guillemotleft>rderivs (replicate i as) r\<guillemotright>\<guillemotright> = \<guillemotleft>r\<guillemotright>"
    by (auto simp: ACI_norm_rderivs)
  thus ?case by (auto simp: ACI_norm_rderivs replicate_add rderivs_append)
qed simp

lemma rderivs_replicate_mult_rest:
  assumes "\<guillemotleft>rderivs (replicate i as) r\<guillemotright> = \<guillemotleft>r\<guillemotright>" "k < i"
  shows "\<guillemotleft>rderivs (replicate (m * i + k) as) r\<guillemotright> = \<guillemotleft>rderivs (replicate k as) r\<guillemotright>" (is "?L = ?R")
proof -
  have "?L = \<guillemotleft>rderivs (replicate k as) \<guillemotleft>rderivs (replicate (m * i) as) r\<guillemotright>\<guillemotright>"
    by (simp add: ACI_norm_rderivs replicate_add rderivs_append)
  also have "\<guillemotleft>rderivs (replicate (m * i) as) r\<guillemotright> = \<guillemotleft>r\<guillemotright>" using assms
    by (simp add: rderivs_replicate_mult)
  finally show ?thesis by (simp add: ACI_norm_rderivs)
qed

lemma rderivs_replicate_mod:
  assumes "\<guillemotleft>rderivs (replicate i as) r\<guillemotright> = \<guillemotleft>r\<guillemotright>" "i > 0"
  shows "\<guillemotleft>rderivs (replicate m as) r\<guillemotright> = \<guillemotleft>rderivs (replicate (m mod i) as) r\<guillemotright>" (is "?L = ?R")
  by (subst div_mult_mod_eq[symmetric, of m i])
    (intro rderivs_replicate_mult_rest[OF assms(1)] mod_less_divisor[OF assms(2)])

lemma rderivs_replicate_diff: "\<lbrakk>\<guillemotleft>rderivs (replicate i as) r\<guillemotright> = \<guillemotleft>rderivs (replicate j as) r\<guillemotright>; i > j\<rbrakk> \<Longrightarrow>
  \<guillemotleft>rderivs (replicate (i - j) as) (rderivs (replicate j as) r)\<guillemotright> = \<guillemotleft>rderivs (replicate j as) r\<guillemotright>"
  unfolding rderivs_append[symmetric] replicate_add[symmetric] by auto

lemma samequot_wf:
  assumes "wf n r" "while_option fst (rderiv_and_add as) (True, [\<guillemotleft>r\<guillemotright>]) = Some (b, rs)"
  shows "wf n (PLUS rs)"
proof -
  have "\<not> b" using while_option_stop[OF assms(2)] by simp
  from while_option_rule[where P="invar_rderiv_and_add as r",
    OF invar_rderiv_and_add_step assms(2) invar_rderiv_and_add_init]
    have *: "invar_rderiv_and_add as r (b, rs)" by simp
  thus "wf n (PLUS rs)" unfolding invar_rderiv_and_add_def wf_PLUS
    by (auto simp: in_set_conv_nth wf_rderivs[OF assms(1)])
qed

lemma samequot_soundness:
  assumes "while_option fst (rderiv_and_add as) (True, [\<guillemotleft>r\<guillemotright>]) = Some (b, rs)"
  shows "lang n (PLUS rs) = \<Union> (lang n ` {\<guillemotleft>rderivs (replicate m as) r\<guillemotright> | m. True})"
proof -
  have "\<not> b" using while_option_stop[OF assms] by simp
  moreover
  from while_option_rule[where P="invar_rderiv_and_add as r",
    OF invar_rderiv_and_add_step assms invar_rderiv_and_add_init]
    have *: "invar_rderiv_and_add as r (b, rs)" by simp
  ultimately obtain i where i: "i < length rs" and "\<guillemotleft>rderivs (replicate (length rs - Suc i) as) r\<guillemotright> =
       \<guillemotleft>rderivs (replicate (Suc (length rs - Suc 0)) as) r\<guillemotright>" (is "\<guillemotleft>rderivs ?x r\<guillemotright> = _")
    unfolding invar_rderiv_and_add_def by (auto simp: in_set_conv_nth hd_conv_nth ACI_norm_rderiv
      rderivs_snoc[symmetric] replicate_append_same)
  with * have "\<guillemotleft>rderivs ?x r\<guillemotright> = \<guillemotleft>rderivs (replicate (length rs) as) r\<guillemotright>"
    by (auto simp: invar_rderiv_and_add_def)
  with i have cyc: "\<guillemotleft>rderivs (replicate (Suc i) as) (rderivs ?x r)\<guillemotright> = \<guillemotleft>rderivs ?x r\<guillemotright>"
    by (fastforce dest: rderivs_replicate_diff[OF sym])
  { fix m
    have "\<exists>i<length rs. rs ! i = \<guillemotleft>rderivs (replicate m as) r\<guillemotright>"
    proof (cases "m > length rs - Suc i")
      case True
      with i obtain m' where m: "m = m' + length rs - Suc i"
        by atomize_elim (auto intro: exI[of _ "m - (length rs - Suc i)"])
      with i have "\<guillemotleft>rderivs (replicate m as) r\<guillemotright> = \<guillemotleft>rderivs (replicate m' as) (rderivs ?x r)\<guillemotright>"
       unfolding replicate_add[symmetric] rderivs_append[symmetric] by (simp add: add.commute)
      also from cyc have "\<dots> = \<guillemotleft>rderivs (replicate (m' mod (Suc i)) as) (rderivs ?x r)\<guillemotright>"
        by (elim rderivs_replicate_mod) simp
      also from i have "\<dots> = \<guillemotleft>rderivs (replicate (m' mod (Suc i) + length rs - Suc i) as) r\<guillemotright>"
        unfolding rderivs_append[symmetric] replicate_add[symmetric] by (simp add: add.commute)
      also from m i have "\<dots> = \<guillemotleft>rderivs (replicate ((m - (length rs - Suc i)) mod (Suc i) + length rs - Suc i) as) r\<guillemotright>"
        by simp
      also have "\<dots> = \<guillemotleft>rderivs (replicate (length rs - Suc (i - (m - (length rs - Suc i)) mod (Suc i))) as) r\<guillemotright>"
        by (subst Suc_diff_le[symmetric])
          (metis less_Suc_eq_le mod_less_divisor zero_less_Suc, simp add: add.commute)
      finally have "\<exists>j < length rs. \<guillemotleft>rderivs (replicate m as) r\<guillemotright> = \<guillemotleft>rderivs (replicate (length rs - Suc j) as) r\<guillemotright>"
        using i by (metis less_imp_diff_less)
      with * show ?thesis unfolding invar_rderiv_and_add_def by auto
    next
      case False
      with i have "\<exists>j < length rs. m = length rs - Suc j"
        by (induct m)
          (metis diff_self_eq_0 gr_implies_not0 lessI nat.exhaust,
           metis (no_types) One_nat_def Suc_diff_Suc diff_Suc_1 gr0_conv_Suc less_imp_diff_less
             not_less_eq not_less_iff_gr_or_eq)
      with * show ?thesis unfolding invar_rderiv_and_add_def by auto
    qed
  }
  hence "\<Union> (lang n ` {\<guillemotleft>rderivs (replicate m as) r\<guillemotright> |m. True}) \<subseteq> lang n (PLUS rs)"
    by (fastforce simp: in_set_conv_nth intro!: bexI[rotated])
  moreover from * have "lang n (PLUS rs) \<subseteq> \<Union> (lang n ` {\<guillemotleft>rderivs (replicate m as) r\<guillemotright> |m. True})"
    unfolding invar_rderiv_and_add_def by (fastforce simp: in_set_conv_nth)
  ultimately show "lang n (PLUS rs) = \<Union> (lang n ` {\<guillemotleft>rderivs (replicate m as) r\<guillemotright> |m. True})" by blast
qed

lemma length_subset_card: "\<lbrakk>finite X; distinct (x # xs); set (x # xs) \<subseteq> X\<rbrakk> \<Longrightarrow> length xs < card X"
  by (metis card_mono distinct_card impossible_Cons not_le_imp_less order_trans)

lemma samequot_termination:
  assumes "while_option fst (rderiv_and_add as) (True, [\<guillemotleft>r\<guillemotright>]) = None" (is "?cl = None")
  shows "False"
proof -
  let ?D =  "{\<guillemotleft>rderivs (replicate m as) r\<guillemotright> | m . True}"
  let ?f = "\<lambda>(b, rs). card ?D + 1 - length rs + (if b then 1 else 0)"
  have "\<exists>st. ?cl = Some st"
    apply (rule measure_while_option_Some[of "invar_rderiv_and_add as r" _ _ ?f])
     apply (auto simp: invar_rderiv_and_add_init invar_rderiv_and_add_step)
    apply (auto simp: invar_rderiv_and_add_def Let_def neq_Nil_conv in_set_conv_nth
       intro!: diff_less_mono2 length_subset_card[OF finite_rderivs_same, simplified])
      apply auto []
     apply fastforce
    apply (metis Suc_less_eq nth_Cons_Suc)
    done
  with assms show False by auto
qed

definition "samequot_exec a r =
  Times (PLUS (snd (the (while_option fst (rderiv_and_add a) (True, [\<guillemotleft>r\<guillemotright>]))))) (Star (Atom (singleton a)))"

lemma wf_samequot_exec: "\<lbrakk>wf n r; as \<in> \<Sigma> n\<rbrakk> \<Longrightarrow> wf n (samequot_exec as r)"
  unfolding samequot_exec_def
  by (cases "while_option fst (rderiv_and_add as) (True, [\<guillemotleft>r\<guillemotright>])")
    (auto dest: samequot_termination samequot_wf)

lemma samequot_exec_samequot: "lang n (samequot_exec as r) = lang n (samequot as r)"
  unfolding samequot_exec_def samequot_def lang.simps lang_flatten_PLUS[OF finite_rderivs_same]
  by (cases "while_option fst (rderiv_and_add as) (True, [\<guillemotleft>r\<guillemotright>])")
    (auto dest: samequot_termination dest!: samequot_soundness[of _ _ _ _ n] simp del: ACI_norm_lang)

lemma lang_samequot_exec:
  "\<lbrakk>wf n r; as \<in> \<Sigma> n\<rbrakk> \<Longrightarrow> lang n (samequot_exec as r) = SAMEQUOT as (lang n r)"
unfolding samequot_exec_samequot by (rule lang_samequot)

end

subsection \<open>Suffix and Prefix Languages\<close>

definition Suffix :: "'a lang \<Rightarrow> 'a lang" where
  "Suffix L = {w. \<exists>u. u @ w \<in> L}"

definition Prefix :: "'a lang \<Rightarrow> 'a lang" where
  "Prefix L = {w. \<exists>u. w @ u \<in> L}"

lemma Prefix_Suffix: "Prefix L = rev ` Suffix (rev ` L)"
  unfolding Prefix_def Suffix_def
  by (auto simp: rev_append_invert
  intro: image_eqI[of _ rev, OF rev_rev_ident[symmetric]]
         image_eqI[of _ rev, OF rev_append[symmetric]])

definition Root :: "'a lang \<Rightarrow> 'a lang" where
  "Root L = {x . \<exists>n > 0. x ^^ n \<in> L}"

definition Cycle :: "'a lang \<Rightarrow> 'a lang" where
  "Cycle L = {u @ w | u w. w @ u \<in> L}"

context embed
begin

context
fixes n :: nat
begin

definition SUFFIX :: "'b rexp \<Rightarrow> 'b rexp" where
  "SUFFIX r = flatten PLUS {\<guillemotleft>lderivs w r\<guillemotright>| w. wf_word n w}"

lemma finite_lderivs_wf: "finite {\<guillemotleft>lderivs w r\<guillemotright>| w. wf_word n w}"
  by (auto intro: finite_subset[OF _ finite_lderivs])

definition PREFIX :: "'b rexp \<Rightarrow> 'b rexp" where
  "PREFIX r = REV (SUFFIX (REV r))"

lemma wf_SUFFIX[simp]: "wf n r \<Longrightarrow> wf n (SUFFIX r)"
  unfolding SUFFIX_def by (intro iffD2[OF wf_flatten_PLUS[OF finite_lderivs_wf]]) auto

lemma lang_SUFFIX[simp]: "wf n r \<Longrightarrow> lang n (SUFFIX r) = Suffix (lang n r)"
  unfolding SUFFIX_def Suffix_def
  using lang_flatten_PLUS[OF finite_lderivs_wf] lang_lderivs wf_lang_wf_word
  by fastforce

lemma wf_PREFIX[simp]: "wf n r \<Longrightarrow> wf n (PREFIX r)"
  unfolding PREFIX_def by auto

lemma lang_PREFIX[simp]: "wf n r \<Longrightarrow> lang n (PREFIX r) = Prefix (lang n r)"
  unfolding PREFIX_def by (auto simp: Prefix_Suffix)

end

lemma take_drop_CycleI[intro!]: "x \<in> L \<Longrightarrow> drop i x @ take i x \<in> Cycle L"
  unfolding Cycle_def by fastforce

lemma take_drop_CycleI'[intro!]: "drop i x @ take i x \<in> L \<Longrightarrow> x \<in> Cycle L"
  by (drule take_drop_CycleI[of _ _ "length x - i"]) auto

end

(*<*)
end
(*>*)


theory Impl_Uv_Set
imports
  "../../Iterator/Iterator"
  "../Intf/Intf_Set"
  "../../../Native_Word/Uint"
begin

  subsection \<open>Bit-Vectors as Lists of Words\<close>

  subsubsection \<open>Lookup\<close>

  primrec lookup :: "nat \<Rightarrow> ('a::len) word list \<Rightarrow> bool" where
    "lookup _ [] \<longleftrightarrow> False"
  | "lookup n (w#ws)
      \<longleftrightarrow> (if n<LENGTH('a) then bit w n else lookup (n-LENGTH('a)) ws)"

  lemma lookup_append[simp]: "lookup n (w1@w2 :: 'a::len word list)
    \<longleftrightarrow> (
      if n < LENGTH('a) * length w1 then
        lookup n w1
      else lookup (n - LENGTH('a) * length w1) w2)"
    by (induction w1 arbitrary: n) auto

  lemma lookup_zeroes[simp]: "lookup i (replicate n (0::'a::len word)) = False"
    by (induction n arbitrary: i) auto

  subsubsection \<open>Empty\<close>

  definition empty :: "'a::len word list" where "empty = []"

  subsubsection \<open>Set and Reset Bit\<close>

  function single_bit :: "nat \<Rightarrow> ('a::len) word list"
    where "single_bit n = (
      if (n<LENGTH('a)) then
        [set_bit 0 n True]
      else 0#single_bit (n-LENGTH('a)))"
    by pat_completeness auto
  termination
    apply (relation "measure id")
    apply simp
    apply (simp add: not_less less_diff_conv2)
    done

  declare single_bit.simps[simp del]

  lemma lookup_single_bit[simp]: "lookup i ((single_bit n)::'a::len word list) \<longleftrightarrow> i = n"
    apply (induction n arbitrary: i rule: single_bit.induct)
    apply (subst single_bit.simps)
    apply (auto simp add: bit_simps)
    done

  primrec set_bit :: "nat \<Rightarrow> 'a::len word list \<Rightarrow> 'a::len word list" where
    "set_bit i [] = single_bit i"
  | "set_bit i (w#ws) = (
      if i<LENGTH('a) then
        Bit_Operations.set_bit i w # ws
      else
        w # set_bit (i - LENGTH('a)) ws)"

  lemma set_bit_lookup[simp]: "lookup i (set_bit j ws) \<longleftrightarrow> (lookup i ws \<or> i=j)"
    apply (induction ws arbitrary: i j)
     apply (auto simp add: word_size Bit_Operations.bit_set_bit_iff)
    done

  primrec reset_bit :: "nat \<Rightarrow> 'a::len word list \<Rightarrow> 'a::len word list" where
    "reset_bit i [] = []"
  | "reset_bit i (w#ws) = (
      if i<LENGTH('a) then
        unset_bit i w # ws
      else
        w # reset_bit (i - LENGTH('a)) ws)"

  lemma reset_bit_lookup[simp]: "lookup i (reset_bit j ws) \<longleftrightarrow> (lookup i ws \<and> i\<noteq>j)"
    apply (induction ws arbitrary: i j)
    apply (auto simp: word_size bit_unset_bit_iff)
    done

  subsubsection \<open>Binary Operations\<close>

  context
    includes bit_operations_syntax
  begin

  definition
    is_bin_op_impl
    :: "(bool\<Rightarrow>bool\<Rightarrow>bool) \<Rightarrow> ('a::len word \<Rightarrow> 'a::len word \<Rightarrow> 'a::len word) \<Rightarrow> bool"
    where "is_bin_op_impl f g \<equiv>
    (\<forall>w v.  \<forall>i<LENGTH('a). bit (g w v) i \<longleftrightarrow> f (bit w i) (bit v i))"

  definition "is_strict_bin_op_impl f g \<equiv> is_bin_op_impl f g \<and> f False False = False"

  fun binary :: "('a::len word \<Rightarrow> 'a::len word \<Rightarrow> 'a::len word)
    \<Rightarrow> 'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> 'a::len word list"
    where
    "binary f [] [] = []"
  | "binary f [] (w#ws) = f 0 w # binary f [] ws"
  | "binary f (v#vs) [] = f v 0 # binary f vs []"
  | "binary f (v#vs) (w#ws) = f v w # binary f vs ws"

  lemma binary_lookup:
    assumes "is_strict_bin_op_impl f g"
    shows "lookup i (binary g ws vs) \<longleftrightarrow> f (lookup i ws) (lookup i vs)"
    using assms
    apply (induction g ws vs arbitrary: i rule: binary.induct)
    apply (auto simp: is_strict_bin_op_impl_def is_bin_op_impl_def)
    done

  subsection \<open>Abstraction to Sets of Naturals\<close>

  definition "\<alpha> uv \<equiv> {n. lookup n uv}"

  lemma memb_correct: "lookup i ws \<longleftrightarrow> i\<in>\<alpha> ws"
    by (auto simp: \<alpha>_def)

  lemma empty_correct: "\<alpha> empty = {}"
    by (simp add: \<alpha>_def empty_def)

  lemma single_bit_correct: "\<alpha> (single_bit n) = {n}"
    by (simp add: \<alpha>_def)

  lemma insert_correct: "\<alpha> (set_bit i ws) = Set.insert i (\<alpha> ws)"
    by (auto simp add: \<alpha>_def)

  lemma delete_correct: "\<alpha> (reset_bit i ws) = (\<alpha> ws) - {i}"
    by (auto simp add: \<alpha>_def)

  lemma binary_correct:
    assumes "is_strict_bin_op_impl f g"
    shows "\<alpha> (binary g ws vs) = { i . f (i\<in>\<alpha> ws) (i\<in>\<alpha> vs) }"
    unfolding \<alpha>_def
    by (auto simp add: binary_lookup[OF assms])

  fun union :: "'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> 'a::len word list"
    where
    "union [] ws = ws"
  | "union vs [] = vs"
  | "union (v#vs) (w#ws) = (v OR w) # union vs ws"

  lemma union_lookup[simp]:
    fixes vs :: "'a::len word list"
    shows "lookup i (union vs ws) \<longleftrightarrow> lookup i vs \<or> lookup i ws"
    apply (induction vs ws arbitrary: i rule: union.induct)
    apply (auto simp: word_ao_nth)
    done

  lemma union_correct: "\<alpha> (union ws vs) = \<alpha> ws \<union> \<alpha> vs"
    by (auto simp add: \<alpha>_def)

  fun inter :: "'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> 'a::len word list"
    where
    "inter [] ws = []"
  | "inter vs [] = []"
  | "inter (v#vs) (w#ws) = (v AND w) # inter vs ws"

  lemma inter_lookup[simp]:
    fixes vs :: "'a::len word list"
    shows "lookup i (inter vs ws) \<longleftrightarrow> lookup i vs \<and> lookup i ws"
    apply (induction vs ws arbitrary: i rule: inter.induct)
    apply (auto simp: word_ao_nth)
    done

  lemma inter_correct: "\<alpha> (inter ws vs) = \<alpha> ws \<inter> \<alpha> vs"
    by (auto simp add: \<alpha>_def)

  fun diff :: "'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> 'a::len word list"
    where
    "diff [] ws = []"
  | "diff vs [] = vs"
  | "diff (v#vs) (w#ws) = (v AND NOT w) # diff vs ws"

  lemma diff_lookup[simp]:
    fixes vs :: "'a::len word list"
    shows "lookup i (diff vs ws) \<longleftrightarrow> lookup i vs - lookup i ws"
    apply (induction vs ws arbitrary: i rule: diff.induct)
    apply (auto simp: word_ops_nth_size word_size)
    done

  lemma diff_correct: "\<alpha> (diff ws vs) = \<alpha> ws - \<alpha> vs"
    by (auto simp add: \<alpha>_def)

  fun zeroes :: "'a::len word list \<Rightarrow> bool" where
    "zeroes [] \<longleftrightarrow> True"
  | "zeroes (w#ws) \<longleftrightarrow> w=0 \<and> zeroes ws"

  lemma zeroes_lookup: "zeroes ws \<longleftrightarrow> (\<forall>i. \<not>lookup i ws)"
    apply (induction ws)
    apply (auto simp: word_eq_iff)
    by (metis diff_add_inverse2 not_add_less2)

  lemma isEmpty_correct: "zeroes ws \<longleftrightarrow> \<alpha> ws = {}"
    by (auto simp: zeroes_lookup \<alpha>_def)

  fun equal :: "'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> bool" where
    "equal [] [] \<longleftrightarrow> True"
  | "equal [] ws \<longleftrightarrow> zeroes ws"
  | "equal vs [] \<longleftrightarrow> zeroes vs"
  | "equal (v#vs) (w#ws) \<longleftrightarrow> v=w \<and> equal vs ws"

  lemma equal_lookup:
    fixes vs ws :: "'a::len word list"
    shows "equal vs ws \<longleftrightarrow> (\<forall>i. lookup i vs = lookup i ws)"
  proof (induction vs ws rule: equal.induct)
    fix v w and vs ws :: "'a::len word list"
    assume IH: "equal vs ws = (\<forall>i. lookup i vs = lookup i ws)"
    show "equal (v # vs) (w # ws) = (\<forall>i. lookup i (v # vs) = lookup i (w # ws))"
    proof (rule iffI, rule allI)
      fix i
      assume "equal (v#vs) (w#ws)"
      thus "lookup i (v # vs) = lookup i (w # ws)"
        by (auto simp: IH)
    next
      assume "\<forall>i. lookup i (v # vs) = lookup i (w # ws)"
      thus "equal (v # vs) (w # ws)"
        apply (auto simp: word_eq_iff IH)
        apply metis
        apply metis
        apply (drule_tac x="i + LENGTH('a)" in spec)
        apply auto []
        apply (drule_tac x="i + LENGTH('a)" in spec)
        apply auto []
        done
    qed
  qed (auto simp: zeroes_lookup)

  lemma equal_correct: "equal vs ws \<longleftrightarrow> \<alpha> vs = \<alpha> ws"
    by (auto simp: \<alpha>_def equal_lookup)

  fun subseteq :: "'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> bool" where
    "subseteq [] ws \<longleftrightarrow> True"
  | "subseteq vs [] \<longleftrightarrow> zeroes vs"
  | "subseteq (v#vs) (w#ws) \<longleftrightarrow> (v AND NOT w = 0) \<and> subseteq vs ws"

  lemma subseteq_lookup:
    fixes vs ws :: "'a::len word list"
    shows "subseteq vs ws \<longleftrightarrow> (\<forall>i. lookup i vs \<longrightarrow> lookup i ws)"
    apply (induction vs ws rule: subseteq.induct)
    apply simp
    apply (auto simp: zeroes_lookup) []
    apply (auto simp: word_ops_nth_size word_size word_eq_iff)
    by (metis diff_add_inverse2 not_add_less2)

  lemma subseteq_correct: "subseteq vs ws \<longleftrightarrow> \<alpha> vs \<subseteq> \<alpha> ws"
    by (auto simp: \<alpha>_def subseteq_lookup)

  fun subset :: "'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> bool" where
    "subset [] ws \<longleftrightarrow> \<not>zeroes ws"
  | "subset vs [] \<longleftrightarrow> False"
  | "subset (v#vs) (w#ws) \<longleftrightarrow> (if v=w then subset vs ws else subseteq (v#vs) (w#ws))"

  lemma subset_lookup:
    fixes vs ws :: "'a::len word list"
    shows "subset vs ws \<longleftrightarrow> ((\<forall>i. lookup i vs \<longrightarrow> lookup i ws)
      \<and> (\<exists>i. \<not>lookup i vs \<and> lookup i ws))"
    apply (induction vs ws rule: subset.induct)
    apply (simp add: zeroes_lookup)
    apply (simp add: zeroes_lookup) []
    apply (simp add: subseteq_lookup)
    apply safe
    apply simp_all
    apply (auto simp: word_ops_nth_size word_size word_eq_iff)
    done

  lemma subset_correct: "subset vs ws \<longleftrightarrow> \<alpha> vs \<subset> \<alpha> ws"
    by (auto simp: \<alpha>_def subset_lookup)

  fun disjoint :: "'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> bool" where
    "disjoint [] ws \<longleftrightarrow> True"
  | "disjoint vs [] \<longleftrightarrow> True"
  | "disjoint (v#vs) (w#ws) \<longleftrightarrow> (v AND w = 0) \<and> disjoint vs ws"

  lemma disjoint_lookup:
    fixes vs ws :: "'a::len word list"
    shows "disjoint vs ws \<longleftrightarrow> (\<forall>i. \<not>(lookup i vs \<and> lookup i ws))"
    apply (induction vs ws rule: disjoint.induct)
    apply simp
    apply simp
    apply (auto simp: word_ops_nth_size word_size word_eq_iff)
    by (metis diff_add_inverse2 not_add_less2)

  lemma disjoint_correct: "disjoint vs ws \<longleftrightarrow> \<alpha> vs \<inter> \<alpha> ws = {}"
    by (auto simp: \<alpha>_def disjoint_lookup)

subsection \<open>Lifting to Uint\<close>
  type_synonym uint_vector = "uint list"

  lift_definition uv_\<alpha> :: "uint_vector \<Rightarrow> nat set" is \<alpha> .
  lift_definition uv_lookup :: "nat \<Rightarrow> uint_vector \<Rightarrow> bool" is lookup .
  lift_definition uv_empty :: "uint_vector" is empty .
  lift_definition uv_single_bit :: "nat \<Rightarrow> uint_vector" is single_bit .
  lift_definition uv_set_bit :: "nat \<Rightarrow> uint_vector \<Rightarrow> uint_vector" is set_bit .
  lift_definition uv_reset_bit :: "nat \<Rightarrow> uint_vector \<Rightarrow> uint_vector" is reset_bit .
  lift_definition uv_union :: "uint_vector \<Rightarrow> uint_vector \<Rightarrow> uint_vector" is union .
  lift_definition uv_inter :: "uint_vector \<Rightarrow> uint_vector \<Rightarrow> uint_vector" is inter .
  lift_definition uv_diff :: "uint_vector \<Rightarrow> uint_vector \<Rightarrow> uint_vector" is diff .
  lift_definition uv_zeroes :: "uint_vector \<Rightarrow> bool" is zeroes .
  lift_definition uv_equal :: "uint_vector \<Rightarrow> uint_vector \<Rightarrow> bool" is equal .
  lift_definition uv_subseteq :: "uint_vector \<Rightarrow> uint_vector \<Rightarrow> bool" is subseteq .
  lift_definition uv_subset :: "uint_vector \<Rightarrow> uint_vector \<Rightarrow> bool" is subset .
  lift_definition uv_disjoint :: "uint_vector \<Rightarrow> uint_vector \<Rightarrow> bool" is disjoint .

  lemmas uv_memb_correct = memb_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_empty_correct = empty_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_single_bit_correct = single_bit_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_insert_correct = insert_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_delete_correct = delete_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_union_correct = union_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_inter_correct = inter_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_diff_correct = diff_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_isEmpty_correct = isEmpty_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_equal_correct = equal_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_subseteq_correct = subseteq_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_subset_correct = subset_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_disjoint_correct = disjoint_correct[where 'a=dflt_size, Transfer.transferred]

  lemmas [where 'a=dflt_size, Transfer.transferred, code] =
    lookup.simps
    empty_def
    single_bit.simps
    set_bit.simps
    reset_bit.simps
    union.simps
    inter.simps
    diff.simps
    zeroes.simps
    equal.simps
    subseteq.simps
    subset.simps
    disjoint.simps

  end

  hide_const (open) \<alpha> lookup empty single_bit set_bit reset_bit union inter diff zeroes
    equal subseteq subset disjoint

  subsection \<open>Autoref Setup\<close>

  definition uv_set_rel_def_internal:
    "uv_set_rel Rk \<equiv>
      if Rk=nat_rel then br uv_\<alpha> (\<lambda>_. True) else {}"
  lemma uv_set_rel_def:
    "\<langle>nat_rel\<rangle>uv_set_rel \<equiv> br uv_\<alpha> (\<lambda>_. True)"
    unfolding uv_set_rel_def_internal relAPP_def by simp

  lemmas [autoref_rel_intf] = REL_INTFI[of "uv_set_rel" i_set]

  lemma uv_set_rel_sv[relator_props]: "single_valued (\<langle>nat_rel\<rangle>uv_set_rel)"
    unfolding uv_set_rel_def by auto

  lemma uv_autoref[autoref_rules,param]:
    "(uv_lookup,(\<in>)) \<in> nat_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> bool_rel"
    "(uv_empty,{}) \<in> \<langle>nat_rel\<rangle>uv_set_rel"
    "(uv_set_bit,insert) \<in> nat_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel"
    "(uv_reset_bit,op_set_delete) \<in> nat_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel"
    "(uv_union,(\<union>)) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel"
    "(uv_inter,(\<inter>)) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel"
    "(uv_diff,(-)) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel"
    "(uv_zeroes,op_set_isEmpty) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> bool_rel"
    "(uv_equal,(=)) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> bool_rel"
    "(uv_subseteq,(\<subseteq>)) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> bool_rel"
    "(uv_subset,(\<subset>)) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> bool_rel"
    "(uv_disjoint,op_set_disjoint) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> bool_rel"
    by (auto
      simp: uv_set_rel_def br_def
      simp: uv_memb_correct uv_empty_correct uv_insert_correct uv_delete_correct
      simp: uv_union_correct uv_inter_correct uv_diff_correct uv_isEmpty_correct
      simp: uv_equal_correct uv_subseteq_correct uv_subset_correct uv_disjoint_correct)

  export_code
    uv_lookup
    uv_empty
    uv_single_bit
    uv_set_bit
    uv_reset_bit
    uv_union
    uv_inter
    uv_diff
    uv_zeroes
    uv_equal
    uv_subseteq
    uv_subset
    uv_disjoint
  checking SML Scala Haskell? OCaml?

end


(* IsageoCoq2_R1

Highschool1.thy

Version 2.2.0 IsaGeoCoq2_R1, Port part of GeoCoq 3.4.0
Version 2.1.0 IsaGeoCoq2_R1, Port part of GeoCoq 3.4.0
Copyright (C) 2021-2023 Roland Coghetto roland.coghetto ( a t ) cafr-msa2p.be
License: LGPGL

History
Version 1.0.0: IsaGeoCoq
Port part of GeoCoq 3.4.0 (https://geocoq.github.io/GeoCoq/) in Isabelle/Hol (Isabelle2021)

Copyright (C) 2021  Roland Coghetto roland_coghetto (at) hotmail.com

License: LGPL

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
*)

theory Highschool1

imports
  Tarski_Postulate_Parallels

begin

section "Niveau école secondaire - Géométrie neutre, sans dimension"

context Tarski_neutral_dimensionless
begin

(** Existence of the interior bisector of an angle. *)

lemma bisector_existence:
  assumes "A \<noteq> B" and "B \<noteq> C"
  shows "\<exists> E. E InAngle A B C \<and> A B E CongA E B C"
proof (cases "Col A B C")
  case True
  thus ?thesis
  proof (cases "B Out A C")
    case True
    have "C InAngle A B C"
      using assms(1) assms(2) inangle3123 by presburger
    moreover
    have "A B C CongA C B C"
      by (metis between_trivial2 True l11_21_b out2_bet_out)
    ultimately
    show ?thesis
      by blast
  next
    case False
    hence "Bet A B C"
      using True l6_4_2 by blast
    have "A \<noteq> C"
      using False assms(1) out_trivial by blast
    then obtain E where "B E Perp A C"
      using perp_exists by blast
    have "E InAngle A B C"
      by (metis \<open>B E Perp A C\<close> \<open>Bet A B C\<close> assms(1) assms(2) in_angle_line perp_not_eq_1)
    moreover
    have "A B E CongA E B C"
      by (metis True \<open>B E Perp A C\<close> assms(1) assms(2) col_permutation_5
          l11_16 l8_2 not_col_permutation_4 per_col perp_col1 perp_not_eq_1 perp_per_1)
    ultimately
    show ?thesis
      by blast
  qed
next
  case False
  hence "\<not> Col A B C"
    by simp
  obtain C' where "Bet B A C'" and "Cong A C' B C"
    using segment_construction by blast
  obtain A' where "Bet B C A'" and "Cong C A' B A"
    using segment_construction by blast
  obtain I where "I Midpoint A' C'"
    using midpoint_existence by blast
  hence "I \<noteq> B"
    by (metis False bet_col midpoint_bet \<open>Bet B A C'\<close> \<open>Bet B C A'\<close>
        between_inner_transitivity between_symmetry)
  have "Cong B C' A' B"
    by (meson Bet_cases \<open>Bet B A C'\<close> \<open>Cong A C' B C\<close> \<open>Bet B C A'\<close> \<open>Cong C A' B A\<close>
        l2_11_b not_cong_2134 not_cong_3421)
  hence "A' C' B CongA C' A' B"
    by (metis False \<open>Bet B A C'\<close> \<open>Bet B C A'\<close> assms(1) assms(2) bet_col1
        bet_neq12__neq cong_3421 cong_reflexivity l11_51 not_col_permutation_4 not_cong_2134)
  have "C' I B CongA A' I B \<and> C' B I CongA A' B I"
  proof -
    have "Cong I B I B"
      by (simp add: cong_reflexivity)
    hence "(I \<noteq> B \<longrightarrow> (C' I B CongA A' I B \<and> C' B I CongA A' B I))"
      by (metis Cong_cases conga_distinct l11_51 Tarski_neutral_dimensionless.midpoint_cong
          Tarski_neutral_dimensionless_axioms \<open>A' C' B CongA C' A' B\<close>
          \<open>Cong B C' A' B\<close> \<open>I Midpoint A' C'\<close>)
    thus ?thesis
      using \<open>I \<noteq> B\<close> by blast
  qed
  have "I InAngle A B C"
  proof -
    have "A \<noteq> B"
      by (simp add: assms(1))
    moreover
    have "C \<noteq> B"
      using assms(2) by blast
    moreover
    have "I \<noteq> B"
      by (simp add: \<open>I \<noteq> B\<close>)
    moreover
    have "\<exists> X. Bet A X C \<and> (X = B \<or> B Out X I)"
    proof -
      have "Bet A' I C'"
        by (simp add: \<open>I Midpoint A' C'\<close> midpoint_bet)
      hence "\<exists> x1. (Bet I x1 B \<and> Bet A x1 A')"
        using \<open>Bet B A C'\<close> inner_pasch by blast
      then obtain x1 where "Bet I x1 B" and "Bet A x1 A'"
        by blast
      then obtain x2 where  "Bet x1 x2 B" and "Bet C x2 A"
        using \<open>Bet B C A'\<close> inner_pasch by blast
      hence "Bet A x2 C"
        using Bet_cases by blast
      moreover
      have "x2 = B \<or> B Out x2 I"
        by (meson \<open>Bet I x1 B\<close> \<open>Bet x1 x2 B\<close> bet_out_1 between_exchange2)
      ultimately
      show ?thesis
        by blast
    qed
    ultimately
    show ?thesis
      by (simp add: InAngle_def)
  qed
  moreover
  have "A B I CongA I B C"
  proof -
    have "C' B I CongA A' B I"
      using \<open>C' I B CongA A' I B \<and> C' B I CongA A' B I\<close> by blast
    thus ?thesis
      using assms(1) assms(2) bet_out conga_right_comm l11_10 out_trivial
      using \<open>Bet B A C'\<close> \<open>Bet B C A'\<close> \<open>I \<noteq> B\<close> by presburger
  qed
  ultimately
  show ?thesis
    by blast
qed

lemma not_col_bfoot_not_equality:
  assumes "\<not> Col A B C" and
    "Coplanar A B C I" and
    "Col A B H1" and
    (*"Col B C H2" and*)
    "A B I CongA I B C" and
    "A B Perp I H1" and
    "B C Perp I H2"
  shows "H1 \<noteq> B \<and> H2 \<noteq> B"
proof -
  {
    assume "H1 = B"
    hence "Per A B I"
      using assms(5) perp_left_comm perp_per_1 by blast
    have "Col A C B"
    proof -
      have "Coplanar I A C B"
        using assms(2) ncoplanar_perm_11 by blast
      moreover
      have "I \<noteq> B"
        using \<open>H1 = B\<close> assms(5) perp_distinct by blast
      moreover
      have "Per I B C"
        using \<open>Per A B I\<close> assms(4) l11_17 by blast
      hence "Per C B I"
        by (simp add: l8_2)
      ultimately
      show ?thesis
        using \<open>Per A B I\<close> cop_per2__col by blast
    qed
    hence False
      using assms(1) col_permutation_5 by blast
  }
  moreover
  {
    assume "H2 = B"
    hence "Per C B I"
      using assms(6) perp_per_1 by blast
    hence "Per I B C"
      using l8_2 by blast
    have "Col A C B"
    proof -
      have "Coplanar I A C B"
        by (simp add: assms(2) coplanar_perm_19)
      moreover
      have "I \<noteq> B"
        using \<open>H2 = B\<close> assms(6) perp_distinct by presburger
      moreover
      have "Per A B I"
        by (meson \<open>Per I B C\<close> assms(4) l11_17 not_conga_sym)
      ultimately
      show ?thesis
        using \<open>Per C B I\<close> cop_per2__col by blast
    qed
    hence False
      using assms(1) col_permutation_5 by blast
  }
  ultimately show ?thesis by blast
qed

lemma bisector_foot_out_out:
  assumes "\<not> Col A B C" and
    "Coplanar A B C I" and
    "Col B C H2" and
    "A B I CongA I B C" and
    "A B Perp I H1" and
    "B C Perp I H2" and
    "B Out H1 A"
  shows "B Out H2 C"
proof -
  have "Col A B H1"
    using assms(7) col_permutation_2 out_col by blast
  hence "H1 \<noteq> B \<and> H2 \<noteq> B"
    using not_col_bfoot_not_equality assms(1) assms(2) assms(4) assms(5) assms(6) by blast
  hence "Acute H1 B I"
    by (metis l8_16_1 \<open>Col A B H1\<close> assms(5) col_trivial_2 l11_43)
  have "H1 B I CongA I B C"
    by (metis CongA_def Out_def assms(4) assms(7) not_bet_distincts not_conga out2__conga)
  hence "Acute I B C"
    using \<open>Acute H1 B I\<close> acute_conga__acute by blast
  thus ?thesis
    by (meson acute_col_perp__out assms(3) assms(6))
qed

lemma not_col_efoot_not_equality:
  assumes "\<not> Col A B C" and
    "Coplanar A B C I" and
    "Col A B H1" and
    "Col B C H2" and
    "Cong I H1 I H2" and
    "A B Perp I H1" and
    "B C Perp I H2"
  shows "H1 \<noteq> B \<and> H2 \<noteq> B"
proof -
  {
    assume "H1 = B"
    hence "H2 \<noteq> B"
      using assms(1) assms(2) assms(6) assms(7) col_permutation_2 cop_perp2__col
        coplanar_perm_11 perp_comm perp_right_comm by blast
    hence False
      by (metis Cong_cases Perp_cases \<open>H1 = B\<close> acute_not_per assms(4) assms(5)
          assms(7) cong__acute perp_col1 perp_distinct perp_per_1)
  }
  moreover
  {
    assume "H2 = B"
    have "B H1 Perp I H1"
      using \<open>H1 = B \<Longrightarrow> False\<close> assms(3) assms(6) col_trivial_2 perp_col2 by presburger
    hence "Per B H1 I"
      using Perp_cases perp_per_1 by blast
    have "B H1 I CongA H1 B I"
      by (metis Cong_cases \<open>H1 = B \<Longrightarrow> False\<close> \<open>H2 = B\<close> assms(5)
          cong_identity_inv cong_reflexivity l11_51)
    hence "Per H1 B I"
      using \<open>Per B H1 I\<close> l11_17 by blast
    hence False
      using \<open>H1 = B \<Longrightarrow> False\<close> \<open>Per B H1 I\<close> l8_2 l8_7 by blast
  }
  ultimately show ?thesis
    by blast
qed

lemma equality_foot_out_out:
  assumes "\<not> Col A B C" and
    "I InAngle A B C" and
    "Col B C H2" and
    "Cong I H1 I H2" and
    "A B Perp I H1" and
    "B C Perp I H2" and
    "B Out H1 A"
  shows "B Out H2 C"
proof -
  have "H1 \<noteq> B \<and> H2 \<noteq> B"
    by (metis Col_cases cong__acute acute_not_per assms(4) assms(5) assms(7)
        col_trivial_2 l8_16_1 out_col out_diff1)
  have "Cong H1 B H2 B \<and> H1 B I CongA H2 B I \<and> H1 I B CongA H2 I B"
  proof -
    have "B H1 I CongA B H2 I"
      by (metis Col_cases l11_16 \<open>H1 \<noteq> B \<and> H2 \<noteq> B\<close> assms(3) assms(5)
          assms(6) assms(7) col_trivial_2 conga_comm l8_16_1 out_col)
    moreover
    have "Per B H1 I"
      by (metis Col_cases l8_16_1 l8_2 assms(5) assms(7) col_trivial_2 out_col)
    hence "H1 I Le B I"
      using l11_46 by (metis perp_distinct \<open>H1 \<noteq> B \<and> H2 \<noteq> B\<close> assms(5) lt__le)
    ultimately
    show ?thesis
      using assms(4) cong_reflexivity l11_52 not_cong_2143 by blast
  qed
  have "I B TS A C"
    by (metis col_permutation_2 col_permutation_5 out_col perp_not_col2
        assms(2) assms(3) assms(5) assms(6) assms(7) in_angle_two_sides)
  have "B Out H1 H2 \<or> I B TS H1 H2"
  proof -
    have "Coplanar I B H1 H2"
    proof -
      have "\<not> Col A I B"
        using TS_def \<open>I B TS A C\<close> by blast
      moreover
      have "Coplanar A I B H1"
        using assms(5) coplanar_perm_2 perp__coplanar by blast
      moreover
      have "Coplanar A I B H2"
        by (metis not_col_distincts assms(1) assms(2) assms(3) col_cop__cop
            coplanar_perm_6 inangle__coplanar)
      ultimately
      show ?thesis
        using coplanar_trans_1 by blast
    qed
    moreover
    have "I B H1 CongA I B H2"
      by (simp add: \<open>Cong H1 B H2 B \<and> H1 B I CongA H2 B I \<and> H1 I B CongA H2 I B\<close> conga_comm)
    ultimately
    show ?thesis
      using conga_cop__or_out_ts by blast
  qed
  moreover
  {
    assume "B Out H1 H2"
    hence False
      by (metis Col_cases \<open>B Out H1 H2\<close> assms(1) assms(3) assms(7)
          col_trivial_3 l9_19 out_diff2 out_one_side)
  }
  moreover
  {
    assume "I B TS H1 H2"
    have "I B TS A H2"
      by (meson not_col_distincts \<open>I B TS H1 H2\<close> assms(7) l9_5)
    hence "I B OS H2 C"
      using OS_def \<open>I B TS A C\<close> l9_2 by blast
    hence "B I OS H2 C"
      using invert_one_side by blast
    moreover
    have "Col B H2 C"
      using Col_cases assms(3) by blast
    ultimately
    have "B Out H2 C"
      using col_one_side_out by force
  }
  ultimately show ?thesis by blast
qed

(** The points on the bisector of an angle are at equal distances of the two sides. *)

lemma bisector_perp_equality:
  assumes "Coplanar A B C I" and
    "Col B H1 A" and
    "Col B C H2" and
    "A B Perp I H1" and
    "B C Perp I H2" and
    "A B I CongA I B C"
  shows "Cong I H1 I H2"
proof (cases "Col A B C")
  case True
  hence "A B Perp I H2"
    by (metis assms(4) assms(5) col_trivial_3 not_col_permutation_2 perp_col2 perp_not_eq_1)
  have "H1 = H2"
    by (metis col_trivial_2 True \<open>A B Perp I H2\<close> assms(2) assms(3)
        assms(4) assms(5) colx l8_18_uniqueness not_col_permutation_1 perp_not_eq_1)
  thus ?thesis
    by (simp add: cong_reflexivity)
next
  case False
  hence "\<not> Col A B C"
    by blast
  have "Col A B H1"
    using Col_cases assms(2) by blast
  have "Col B C H2"
    by (simp add: assms(3))
  hence "H1 \<noteq> B \<and> H2 \<noteq> B"
    using False \<open>Col A B H1\<close> assms(1) assms(4) assms(5) assms(6)
      not_col_bfoot_not_equality by blast
  show ?thesis
  proof (cases "B Out H1 A")
    case True
    hence "B Out H2 C"
      using False assms(1) assms(3) assms(4) assms(5) assms(6)
        bisector_foot_out_out by blast
    have "\<not> Col I B H1"
      by (metis \<open>Col A B H1\<close> \<open>H1 \<noteq> B \<and> H2 \<noteq> B\<close> assms(4) l6_16_1 perp_not_col2)
    moreover
    have "B H1 I CongA B H2 I"
    proof -
      have "Per B H1 I"
        using \<open>Col A B H1\<close> assms(4) col_trivial_2 l8_16_1 l8_2 by blast
      moreover
      have "Per B H2 I"
        by (meson l8_2 assms(3) assms(5) col_trivial_3 l8_16_1)
      ultimately
      show ?thesis
        by (metis Col_cases Perp_cases \<open>H1 \<noteq> B \<and> H2 \<noteq> B\<close> assms(4) assms(5)
            col_trivial_2 l11_16 l8_16_1)
    qed
    moreover
    have "H1 B I CongA H2 B I"
    proof -
      have "B Out H1 A"
        by (simp add: True)
      moreover
      have "B Out H2 C"
        using \<open>B Out H2 C\<close> by auto
      moreover
      have "A B I CongA I B C"
        by (simp add: assms(6))
      have "B Out I I"
        by (metis \<open>\<not> Col I B H1\<close> bet_out_1 not_bet_distincts not_col_distincts)
      ultimately
      show ?thesis
        by (meson conga_left_comm l11_10 assms(6) conga_comm)
    qed
    hence "I B H1 CongA I B H2"
      using conga_comm by blast
    moreover
    have "Cong I B I B"
      by (simp add: cong_reflexivity)
    ultimately
    show ?thesis
      using l11_50_2 by blast
  next
    case False
    obtain A' where "B Midpoint A A'"
      using symmetric_point_construction by presburger
    hence "Bet A B A'"
      by (simp add: midpoint_bet)
    hence "B Out H1 A'"
      by (metis False Out_def midpoint_distinct_1
          Tarski_neutral_dimensionless.perp_distinct
          Tarski_neutral_dimensionless_axioms \<open>B Midpoint A A'\<close>
          \<open>Col A B H1\<close> \<open>H1 \<noteq> B \<and> H2 \<noteq> B\<close> assms(4) bet_out_1 fourth_point)
    obtain C' where "B Midpoint C C'"
      using symmetric_point_construction by presburger
    hence "Bet C B C'"
      using midpoint_bet by blast
    have "B Out H2 C'"
    proof -
      {
        assume "Col A' B C'"
        hence "Col A B C"
          by (metis Out_def midpoint_distinct_1 \<open>B Midpoint C C'\<close> \<open>B Out H1 A'\<close>
              \<open>Bet A B A'\<close> \<open>Bet C B C'\<close> bet_col col2__eq col_trivial_2)
        hence False
          using \<open>\<not> Col A B C\<close> by auto
      }
      hence "\<not> Col A' B C'"
        by blast
      moreover
      have "Coplanar A' B C' I"
      proof -
        have "Coplanar A B C A'"
          by (simp add: \<open>Bet A B A'\<close> bet__coplanar coplanar_perm_1)
        moreover
        have "Coplanar A B C B"
          using ncop_distincts by blast
        moreover
        have "Coplanar A B C C'"
          by (metis Bet_cases Col_def \<open>Bet C B C'\<close> ncop__ncols)
        ultimately
        show ?thesis
          by (meson \<open>\<not> Col A B C\<close> assms(1) coplanar_pseudo_trans)
      qed
      moreover
      have "Col B C' H2"
        by (metis Col_def \<open>Bet C B C'\<close> \<open>\<not> Col A B C\<close> assms(3) col_transitivity_1 col_trivial_2)
      moreover
      have "A' B I CongA I B C'"
        by (metis conga_right_comm \<open>Bet A B A'\<close> \<open>Bet C B C'\<close> assms(6)
            calculation(1) l11_13 not_col_distincts)
      moreover
      have "A' B Perp I H1"
        by (metis \<open>Bet A B A'\<close> assms(4) bet_col calculation(1) not_col_distincts perp_col2)
      moreover
      have "B C' Perp I H2"
        by (metis Col_cases Col_def \<open>Bet C B C'\<close> assms(5) calculation(1)
            not_col_distincts perp_col)
      ultimately
      show ?thesis
        using \<open>B Out H1 A'\<close> bisector_foot_out_out by blast
    qed
    have "\<not> Col I B H1"
      by (metis perp_not_col2  \<open>Col A B H1\<close> \<open>H1 \<noteq> B \<and> H2 \<noteq> B\<close> assms(4) l6_16_1)
    moreover
    have "B H1 I CongA B H2 I"
      by (metis \<open>Col A B H1\<close> \<open>H1 \<noteq> B \<and> H2 \<noteq> B\<close> assms(3) assms(4) assms(5)
          col_trivial_2 col_trivial_3 conga_comm l11_16 l8_16_1)
    moreover
    have "H1 B I CongA I B H2"
    proof -
      have "A' B I CongA I B C'"
        by (metis l11_13 not_col_distincts \<open>B Midpoint A A'\<close>
            \<open>B Midpoint C C'\<close> \<open>Bet A B A'\<close> \<open>Bet C B C'\<close> \<open>\<not> Col A B C\<close>
            assms(6) conga_right_comm midpoint_distinct_2)
      moreover
      have "B Out H1 A'"
        by (simp add: \<open>B Out H1 A'\<close>)
      moreover
      have "I \<noteq> B"
        using assms(6) conga_diff45 by auto
      hence "B Out I I "
        using out_trivial by blast
      ultimately show ?thesis
        using \<open>B Out H2 C'\<close> l11_10 by blast
    qed
    hence  "I B H1 CongA I B H2"
      using conga_left_comm by presburger
    moreover
    have "Cong I B I B"
      by (simp add: cong_reflexivity)
    ultimately
    show ?thesis
      using l11_50_2 by blast
  qed
qed

(** The points which are at equal distance of the two side of an angle are on the bisector. *)

lemma perp_equality_bisector:
  assumes "\<not> Col A B C" and
    "I InAngle A B C" and
    "Col B H1 A" and
    "Col B H2 C" and
    "A B Perp I H1" and
    "B C Perp I H2" and
    "Cong I H1 I H2"
  shows "A B I CongA I B C"
proof -
  have "H1 \<noteq> B \<and> H2 \<noteq> B"
  proof -
    have "Coplanar A B C I"
      using assms(2) inangle__coplanar ncoplanar_perm_18 by blast
    moreover
    have "Col A B H1"
      by (simp add: assms(3) col_permutation_2)
    ultimately
    show ?thesis
      using not_col_efoot_not_equality assms(1) assms(4) assms(5)
        assms(6) assms(7) col_permutation_5 by blast
  qed
  have "Cong H1 B H2 B \<and> H1 B I CongA H2 B I \<and> H1 I B CongA H2 I B"
  proof -
    have "B H1 I CongA B H2 I"
      by (metis NCol_perm l11_16 \<open>H1 \<noteq> B \<and> H2 \<noteq> B\<close> assms(3) assms(4)
          assms(5) assms(6) col_trivial_3 conga_comm l8_16_1)
    moreover
    have "Cong B I B I"
      by (simp add: cong_reflexivity)
    moreover
    have "Cong H1 I H2 I"
      using Cong_cases assms(7) by auto
    moreover
    have "H1 I Le B I"
      by (metis l11_46 assms(4) assms(6) calculation(1) col_trivial_3
          conga_distinct conga_sym l11_17 l8_16_1 l8_2 lt__le not_col_permutation_5)
    ultimately
    show ?thesis
      using l11_52 by blast
  qed
  show ?thesis
  proof (cases "B Out A H1")
    case True
    have "B Out H2 C"
    proof -
      have "Col B C H2"
        using assms(4) col_permutation_5 by blast
      moreover
      have "B Out H1 A"
        using Out_cases True by auto
      ultimately
      show ?thesis
        using assms(1) assms(2) assms(5) assms(6) assms(7)
          equality_foot_out_out by blast
    qed
    have "A B I CongA C B I"
    proof -
      have "H1 B I CongA H2 B I"
        by (simp add: \<open>Cong H1 B H2 B \<and> H1 B I CongA H2 B I \<and> H1 I B CongA H2 I B\<close>)
      moreover
      have "H1 I B CongA H2 I B"
        by (simp add: \<open>Cong H1 B H2 B \<and> H1 B I CongA H2 B I \<and> H1 I B CongA H2 I B\<close>)
      moreover
      have "Cong H1 B H2 B"
        by (simp add: \<open>Cong H1 B H2 B \<and> H1 B I CongA H2 B I \<and> H1 I B CongA H2 I B\<close>)
      moreover
      have "B \<noteq> I"
        using assms(2) inangle_distincts by blast
      hence "B Out I I"
        using out_trivial by auto
      moreover
      have "B Out A H1"
        by (simp add: True)
      moreover
      have "B Out C H2"
        by (simp add: \<open>B Out H2 C\<close> l6_6)
      moreover
      have "I \<noteq> H1"
        using assms(5) perp_not_eq_2 by auto
      moreover
      have "I \<noteq> H2"
        using assms(6) perp_not_eq_2 by auto
      ultimately show ?thesis
        using l11_10 bet_col not_col_distincts assms(1) assms(2) col_inangle2__out
        by blast
    qed
    thus ?thesis
      using conga_right_comm by blast
  next
    case False
    hence "\<not> B Out A H1"
      by blast
    {
      assume "B Out C H2"
      have "\<not> Col C B A"
        by (simp add: assms(1) not_col_permutation_3)
      moreover
      have "I InAngle C B A"
        by (simp add: assms(2) l11_24)
      moreover
      have "Col B A H1"
        using Col_cases assms(3) by blast
      moreover
      have "Cong I H2 I H1"
        using assms(7) not_cong_3412 by blast
      moreover
      have "C B Perp I H2"
        using Perp_perm assms(6) by blast
      moreover
      have "B A Perp I H1"
        using assms(5) perp_left_comm by blast
      ultimately
      have "B Out H1 A"
        using \<open>B Out C H2\<close> equality_foot_out_out l6_6 by blast
      hence False
        using False Out_cases by blast
    }
    hence "Bet C B H2"
      using Col_cases assms(4) or_bet_out by blast
    moreover
    have "Bet A B H1"
      using False NCol_cases assms(3) or_bet_out by blast
    ultimately
    have "A B I CongA C B I"
      by (metis \<open>Cong H1 B H2 B \<and> H1 B I CongA H2 B I \<and> H1 I B CongA H2 I B\<close>
          assms(2) between_symmetry inangle_distincts l11_13)
    thus ?thesis
      by (meson conga_right_comm)
  qed
qed

(** LOCALISATION: TARSKI_DEV.ANNEXE...*)
lemma col_permut132:
  assumes "Col A B C"
  shows "Col A C B"
  using Col_cases assms by blast

lemma col_permut213:
  assumes "Col A B C"
  shows "Col B A C"
  using Col_perm assms by blast

lemma col_permut231:
  assumes "Col A B C"
  shows "Col B C A"
  using Col_perm assms by blast

lemma col_permut312:
  assumes "Col A B C"
  shows "Col C A B"
  using Col_perm assms by blast

lemma col_permut321:
  assumes "Col A B C"
  shows "Col C B A"
  using Col_perm assms by blast

lemma col123_124__col134:
  assumes "P \<noteq> Q" and
    "Col P Q A" and
    "Col P Q B"
  shows "Col P A B"
  using assms(1) assms(2) assms(3) col_transitivity_1 by blast

lemma col123_124__col234:
  assumes "P \<noteq> Q" and
    "Col P Q A" and
    "Col P Q B"
  shows "Col Q A B"
  using assms(1) assms(2) assms(3) col_transitivity_2 by blast

lemma triangle_mid_par_strict:
  assumes "\<not> Col A B C" and
    "P Midpoint B C" and
    "Q Midpoint A C"
  shows "A B ParStrict Q P"
  using assms(1) assms(2) assms(3) triangle_mid_par by blast

end
end


chapter \<open>Sigma-Formulas and Theorem 2.5\<close>

theory Sigma
imports Predicates
begin

section\<open>Ground Terms and Formulas\<close>

definition ground_aux :: "tm \<Rightarrow> atom set \<Rightarrow> bool"
  where "ground_aux t S \<equiv> (supp t \<subseteq> S)"

abbreviation ground :: "tm \<Rightarrow> bool"
  where "ground t \<equiv> ground_aux t {}"

definition ground_fm_aux :: "fm \<Rightarrow> atom set \<Rightarrow> bool"
  where "ground_fm_aux A S \<equiv> (supp A \<subseteq> S)"

abbreviation ground_fm :: "fm \<Rightarrow> bool"
  where "ground_fm A \<equiv> ground_fm_aux A {}"

lemma ground_aux_simps[simp]:
  "ground_aux Zero S = True"
  "ground_aux (Var k) S = (if atom k \<in> S then True else False)"
  "ground_aux (Eats t u) S = (ground_aux t S \<and> ground_aux u S)"
unfolding ground_aux_def
by (simp_all add: supp_at_base)

lemma ground_fm_aux_simps[simp]:
  "ground_fm_aux Fls S = True"
  "ground_fm_aux (t IN u) S = (ground_aux t S \<and> ground_aux u S)"
  "ground_fm_aux (t EQ u) S = (ground_aux t S \<and> ground_aux u S)"
  "ground_fm_aux (A OR B) S = (ground_fm_aux A S \<and> ground_fm_aux B S)"
  "ground_fm_aux (A AND B) S = (ground_fm_aux A S \<and> ground_fm_aux B S)"
  "ground_fm_aux (A IFF B) S = (ground_fm_aux A S \<and> ground_fm_aux B S)"
  "ground_fm_aux (Neg A) S =  (ground_fm_aux A S)"
  "ground_fm_aux (Ex x A) S = (ground_fm_aux A (S \<union> {atom x}))"
by (auto simp: ground_fm_aux_def ground_aux_def supp_conv_fresh)

lemma ground_fresh[simp]:
  "ground t \<Longrightarrow> atom i \<sharp> t"
  "ground_fm A \<Longrightarrow> atom i \<sharp> A"
unfolding ground_aux_def ground_fm_aux_def fresh_def
by simp_all

section\<open>Sigma Formulas\<close>

text\<open>Section 2 material\<close>

subsection \<open>Strict Sigma Formulas\<close>

text\<open>Definition 2.1\<close>
inductive ss_fm :: "fm \<Rightarrow> bool" where
    MemI:  "ss_fm (Var i IN Var j)"
  | DisjI: "ss_fm A \<Longrightarrow> ss_fm B \<Longrightarrow> ss_fm (A OR B)"
  | ConjI: "ss_fm A \<Longrightarrow> ss_fm B \<Longrightarrow> ss_fm (A AND B)"
  | ExI:   "ss_fm A \<Longrightarrow> ss_fm (Ex i A)"
  | All2I: "ss_fm A \<Longrightarrow> atom j \<sharp> (i,A) \<Longrightarrow> ss_fm (All2 i (Var j) A)"

equivariance ss_fm

nominal_inductive ss_fm
  avoids ExI: "i" | All2I: "i"
by (simp_all add: fresh_star_def)

declare ss_fm.intros [intro]

definition Sigma_fm :: "fm \<Rightarrow> bool"
  where "Sigma_fm A \<longleftrightarrow> (\<exists>B. ss_fm B \<and> supp B \<subseteq> supp A \<and> {} \<turnstile> A IFF B)"

lemma Sigma_fm_Iff: "\<lbrakk>{} \<turnstile> B IFF A; supp A \<subseteq> supp B; Sigma_fm A\<rbrakk> \<Longrightarrow> Sigma_fm B"
  by (metis Sigma_fm_def Iff_trans order_trans)

lemma ss_fm_imp_Sigma_fm [intro]: "ss_fm A \<Longrightarrow> Sigma_fm A"
  by (metis Iff_refl Sigma_fm_def order_refl)

lemma Sigma_fm_Fls [iff]: "Sigma_fm Fls"
  by (rule Sigma_fm_Iff [of _ "Ex i (Var i IN Var i)"]) auto

subsection\<open>Closure properties for Sigma-formulas\<close>

lemma
  assumes "Sigma_fm A" "Sigma_fm B"
    shows Sigma_fm_AND [intro!]: "Sigma_fm (A AND B)"
      and Sigma_fm_OR [intro!]:  "Sigma_fm (A OR B)"
      and Sigma_fm_Ex [intro!]:  "Sigma_fm (Ex i A)"
proof -
  obtain SA SB where "ss_fm SA" "{} \<turnstile> A IFF SA" "supp SA \<subseteq> supp A"
                 and "ss_fm SB" "{} \<turnstile> B IFF SB" "supp SB \<subseteq> supp B"
    using assms by (auto simp add: Sigma_fm_def)
  then show "Sigma_fm (A AND B)"  "Sigma_fm (A OR B)"  "Sigma_fm (Ex i A)"
    apply (auto simp: Sigma_fm_def)
    apply (metis ss_fm.ConjI Conj_cong Un_mono supp_Conj)
    apply (metis ss_fm.DisjI Disj_cong Un_mono fm.supp(3))
    apply (rule exI [where x = "Ex i SA"])
    apply (auto intro!: Ex_cong)
    done
qed

lemma Sigma_fm_All2_Var:
  assumes H0: "Sigma_fm A" and ij: "atom j \<sharp> (i,A)"
  shows "Sigma_fm (All2 i (Var j) A)"
proof -
  obtain SA where SA: "ss_fm SA" "{} \<turnstile> A IFF SA" "supp SA \<subseteq> supp A"
    using H0 by (auto simp add: Sigma_fm_def)
  show "Sigma_fm (All2 i (Var j) A)"
    apply (rule Sigma_fm_Iff [of _ "All2 i (Var j) SA"])
    apply (metis All2_cong Refl SA(2) emptyE)
    using SA ij
    apply (auto simp: supp_conv_fresh subset_iff)
    apply (metis ss_fm.All2I fresh_Pair ss_fm_imp_Sigma_fm)
    done
qed

section\<open>Lemma 2.2: Atomic formulas are Sigma-formulas\<close>

lemma Eq_Eats_Iff:
   assumes [unfolded fresh_Pair, simp]: "atom i \<sharp> (z,x,y)"
   shows "{} \<turnstile> z EQ Eats x y IFF (All2 i z (Var i IN x OR Var i EQ y)) AND x SUBS z AND y IN z"
proof (rule Iff_I, auto)
  have "{Var i IN z, z EQ Eats x y} \<turnstile> Var i IN Eats x y"
    by (metis Assume Iff_MP_left Iff_sym Mem_cong Refl)
  then show "{Var i IN z, z EQ Eats x y} \<turnstile> Var i IN x OR Var i EQ y"
    by (metis Iff_MP_same Mem_Eats_Iff)
next
  show "{z EQ Eats x y} \<turnstile> x SUBS z"
    by (metis Iff_MP2_same Subset_cong [OF Refl Assume] Subset_Eats_I)
next
  show "{z EQ Eats x y} \<turnstile> y IN z"
    by (metis Iff_MP2_same Mem_cong Assume Refl Mem_Eats_I2)
next
  show "{x SUBS z, y IN z, All2 i z (Var i IN x OR Var i EQ y)} \<turnstile> z EQ Eats x y"
       (is "{_, _, ?allHyp} \<turnstile> _")
    apply (rule Eq_Eats_iff [OF assms, THEN Iff_MP2_same], auto)
    apply (rule Ex_I [where x="Var i"])
    apply (auto intro: Subset_D  Mem_cong [OF Assume Refl, THEN Iff_MP2_same])
    done
qed

lemma Subset_Zero_sf: "Sigma_fm (Var i SUBS Zero)"
proof -
  obtain j::name where j: "atom j \<sharp> i"
    by (rule obtain_fresh)
  hence Subset_Zero_Iff: "{} \<turnstile> Var i SUBS Zero IFF (All2 j (Var i) Fls)"
    by (auto intro!: Subset_I [of j] intro: Eq_Zero_D Subset_Zero_D All2_E [THEN rotate2])
  thus ?thesis using j
    by (auto simp: supp_conv_fresh
             intro!: Sigma_fm_Iff [OF Subset_Zero_Iff] Sigma_fm_All2_Var)
qed

lemma Eq_Zero_sf: "Sigma_fm (Var i EQ Zero)"
proof -
  obtain j::name where "atom j \<sharp> i"
    by (rule obtain_fresh)
  thus ?thesis
    by (auto simp add: supp_conv_fresh
             intro!: Sigma_fm_Iff [OF _ _ Subset_Zero_sf] Subset_Zero_D EQ_imp_SUBS)
qed

lemma theorem_sf: assumes "{} \<turnstile> A" shows "Sigma_fm A"
proof -
  obtain i::name and j::name
    where ij: "atom i \<sharp> (j,A)" "atom j \<sharp> A"
    by (metis obtain_fresh)
  show ?thesis
    apply (rule Sigma_fm_Iff [where A = "Ex i (Ex j (Var i IN Var j))"])
    using ij
    apply auto
    apply (rule Ex_I [where x=Zero], simp)
    apply (rule Ex_I [where x="Eats Zero Zero"])
    apply (auto intro: Mem_Eats_I2 assms thin0)
    done
qed

text \<open>The subset relation\<close>
lemma Var_Subset_sf: "Sigma_fm (Var i SUBS Var j)"
proof -
  obtain k::name where k: "atom (k::name) \<sharp> (i,j)"
    by (metis obtain_fresh)
  thus ?thesis
  proof (cases "i=j")
    case True thus ?thesis using k
      by (auto intro!: theorem_sf Subset_I [where i=k])
  next
    case False thus ?thesis using k
      by (auto simp: ss_fm_imp_Sigma_fm Subset.simps [of k] ss_fm.intros)
  qed
qed

lemma Zero_Mem_sf: "Sigma_fm (Zero IN Var i)"
proof -
  obtain j::name where "atom j \<sharp> i"
    by (rule obtain_fresh)
  hence Zero_Mem_Iff: "{} \<turnstile> Zero IN Var i IFF (Ex j (Var j  EQ Zero AND Var j  IN Var i))"
    by (auto intro: Ex_I [where x = Zero]  Mem_cong [OF Assume Refl, THEN Iff_MP_same])
  show ?thesis
    by (auto intro!: Sigma_fm_Iff [OF Zero_Mem_Iff] Eq_Zero_sf)
qed

lemma ijk: "i + k < Suc (i + j + k)"
  by arith

lemma All2_term_Iff_fresh: "i\<noteq>j \<Longrightarrow> atom j' \<sharp> (i,j,A) \<Longrightarrow>
   {} \<turnstile> (All2 i (Var j) A) IFF Ex j' (Var j EQ Var j' AND All2 i (Var j') A)"
apply auto
apply (rule Ex_I [where x="Var j"], auto)
apply (rule Ex_I [where x="Var i"], auto intro: ContraProve Mem_cong [THEN Iff_MP_same])
done

lemma Sigma_fm_All2_fresh:
  assumes "Sigma_fm A" "i\<noteq>j"
    shows "Sigma_fm (All2 i (Var j) A)"
proof -
  obtain j'::name where j': "atom j' \<sharp> (i,j,A)"
    by (metis obtain_fresh)
  show "Sigma_fm (All2 i (Var j) A)"
    apply (rule Sigma_fm_Iff [OF All2_term_Iff_fresh [OF _ j']])
    using assms j'
    apply (auto simp: supp_conv_fresh Var_Subset_sf
                intro!: Sigma_fm_All2_Var Sigma_fm_Iff [OF Extensionality _ _])
    done
qed

lemma Subset_Eats_sf:
  assumes "\<And>j::name. Sigma_fm (Var j IN t)"
      and "\<And>k::name. Sigma_fm (Var k EQ u)"
  shows "Sigma_fm (Var i SUBS Eats t u)"
proof -
  obtain k::name where k: "atom k \<sharp> (t,u,Var i)"
    by (metis obtain_fresh)
  hence "{} \<turnstile> Var i SUBS Eats t u IFF All2 k (Var i) (Var k IN t OR Var k EQ u)"
    apply (auto simp: fresh_Pair intro: Set_MP Disj_I1 Disj_I2)
    apply (force intro!: Subset_I [where i=k] intro: All2_E' [OF Hyp] Mem_Eats_I1 Mem_Eats_I2)
    done
  thus ?thesis
    apply (rule Sigma_fm_Iff)
    using k
    apply (auto intro!: Sigma_fm_All2_fresh simp add: assms fresh_Pair supp_conv_fresh fresh_at_base)
    done
qed

lemma Eq_Eats_sf:
  assumes "\<And>j::name. Sigma_fm (Var j EQ t)"
      and "\<And>k::name. Sigma_fm (Var k EQ u)"
  shows "Sigma_fm (Var i EQ Eats t u)"
proof -
  obtain j::name and k::name and l::name
    where atoms: "atom j \<sharp> (t,u,i)" "atom k \<sharp> (t,u,i,j)" "atom l \<sharp> (t,u,i,j,k)"
    by (metis obtain_fresh)
  hence "{} \<turnstile> Var i EQ Eats t u IFF
              Ex j (Ex k (Var i EQ Eats (Var j) (Var k) AND Var j EQ t AND Var k EQ u))"
    apply auto
    apply (rule Ex_I [where x=t], simp)
    apply (rule Ex_I [where x=u], auto intro: Trans Eats_cong)
    done
  thus ?thesis
    apply (rule Sigma_fm_Iff)
    apply (auto simp: assms supp_at_base)
    apply (rule Sigma_fm_Iff [OF Eq_Eats_Iff [of l]])
    using atoms
    apply (auto simp: supp_conv_fresh fresh_at_base Var_Subset_sf
                intro!: Sigma_fm_All2_Var Sigma_fm_Iff [OF Extensionality _ _])
    done
qed

lemma Eats_Mem_sf:
  assumes "\<And>j::name. Sigma_fm (Var j EQ t)"
      and "\<And>k::name. Sigma_fm (Var k EQ u)"
  shows "Sigma_fm (Eats t u IN Var i)"
proof -
  obtain j::name where j: "atom j \<sharp> (t,u,Var i)"
    by (metis obtain_fresh)
  hence "{} \<turnstile> Eats t u IN Var i IFF
              Ex j (Var j IN Var i AND Var j EQ Eats t u)"
    apply (auto simp: fresh_Pair intro: Ex_I [where x="Eats t u"])
    apply (metis Assume Mem_cong [OF _ Refl, THEN Iff_MP_same] rotate2)
    done
  thus ?thesis
    by (rule Sigma_fm_Iff) (auto simp: assms supp_conv_fresh Eq_Eats_sf)
qed

lemma Subset_Mem_sf_lemma:
  "size t + size u < n \<Longrightarrow> Sigma_fm (t SUBS u) \<and> Sigma_fm (t IN u)"
proof (induction n arbitrary: t u rule: less_induct)
  case (less n t u)
  show ?case
  proof
    show "Sigma_fm (t SUBS u)"
      proof (cases t rule: tm.exhaust)
        case Zero thus ?thesis
          by (auto intro: theorem_sf)
      next
        case (Var i) thus ?thesis using less.prems
          apply (cases u rule: tm.exhaust)
          apply (auto simp: Subset_Zero_sf Var_Subset_sf)
          apply (force simp: supp_conv_fresh less.IH
                       intro: Subset_Eats_sf Sigma_fm_Iff [OF Extensionality])
          done
      next
        case (Eats t1 t2) thus ?thesis using less.IH [OF _ ijk] less.prems
          by (auto intro!: Sigma_fm_Iff [OF Eats_Subset_Iff]  simp: supp_conv_fresh)
             (metis add.commute)
      qed
  next
    show "Sigma_fm (t IN u)"
      proof (cases u rule: tm.exhaust)
        case Zero show ?thesis
          by (rule Sigma_fm_Iff [where A=Fls]) (auto simp: supp_conv_fresh Zero)
      next
        case (Var i) show ?thesis
        proof (cases t rule: tm.exhaust)
          case Zero thus ?thesis using \<open>u = Var i\<close>
            by (auto intro: Zero_Mem_sf)
        next
          case (Var j)
          thus ?thesis using \<open>u = Var i\<close>
            by auto
        next
          case (Eats t1 t2) thus ?thesis using \<open>u = Var i\<close> less.prems
            by (force intro: Eats_Mem_sf Sigma_fm_Iff [OF Extensionality _ _]
                      simp: supp_conv_fresh less.IH [THEN conjunct1])
        qed
      next
        case (Eats t1 t2) thus ?thesis  using  less.prems
          by (force intro: Sigma_fm_Iff [OF Mem_Eats_Iff] Sigma_fm_Iff [OF Extensionality _ _]
                    simp: supp_conv_fresh less.IH)
      qed
  qed
qed

lemma Subset_sf [iff]: "Sigma_fm (t SUBS u)"
  by (metis Subset_Mem_sf_lemma [OF lessI])

lemma Mem_sf [iff]: "Sigma_fm (t IN u)"
  by (metis Subset_Mem_sf_lemma [OF lessI])

text \<open>The equality relation is a Sigma-Formula\<close>
lemma Equality_sf [iff]: "Sigma_fm (t EQ u)"
  by (auto intro: Sigma_fm_Iff [OF Extensionality] simp: supp_conv_fresh)

section\<open>Universal Quantification Bounded by an Arbitrary Term\<close>

lemma All2_term_Iff: "atom i \<sharp> t \<Longrightarrow> atom j \<sharp> (i,t,A) \<Longrightarrow>
                  {} \<turnstile> (All2 i t A) IFF Ex j (Var j EQ t AND All2 i (Var j) A)"
apply auto
apply (rule Ex_I [where x=t], auto)
apply (rule Ex_I [where x="Var i"])
apply (auto intro: ContraProve Mem_cong [THEN Iff_MP2_same])
done

lemma Sigma_fm_All2 [intro!]:
  assumes "Sigma_fm A" "atom i \<sharp> t"
    shows "Sigma_fm (All2 i t A)"
proof -
  obtain j::name where j: "atom j \<sharp> (i,t,A)"
    by (metis obtain_fresh)
  show "Sigma_fm (All2 i t A)"
    apply (rule Sigma_fm_Iff [OF All2_term_Iff [of i t j]])
    using assms j
    apply (auto simp: supp_conv_fresh Sigma_fm_All2_Var)
    done
qed

section \<open>Lemma 2.3: Sequence-related concepts are Sigma-formulas\<close>

lemma OrdP_sf [iff]: "Sigma_fm (OrdP t)"
proof -
  obtain z::name and y::name where "atom z \<sharp> t" "atom y \<sharp> (t, z)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: OrdP.simps)
qed

lemma OrdNotEqP_sf [iff]: "Sigma_fm (OrdNotEqP t u)"
  by (auto simp: OrdNotEqP.simps)

lemma HDomain_Incl_sf [iff]: "Sigma_fm (HDomain_Incl t u)"
proof -
  obtain x::name and y::name and z::name
    where "atom x \<sharp> (t,u,y,z)" "atom y \<sharp> (t,u,z)" "atom z \<sharp> (t,u)"
    by (metis obtain_fresh)
  thus ?thesis
    by auto
qed

lemma HFun_Sigma_Iff:
  assumes "atom z \<sharp> (r,z',x,y,x',y')"  "atom z' \<sharp> (r,x,y,x',y')"
       "atom x \<sharp> (r,y,x',y')"  "atom y \<sharp> (r,x',y')"
       "atom x' \<sharp> (r,y')"  "atom y' \<sharp> (r)"
  shows
  "{} \<turnstile>HFun_Sigma r IFF
         All2 z r (All2 z' r (Ex x (Ex y (Ex x' (Ex y'
             (Var z EQ HPair (Var x) (Var y) AND Var z' EQ HPair (Var x') (Var y')
              AND OrdP (Var x) AND OrdP (Var x') AND
              ((Var x NEQ Var x') OR (Var y EQ Var y'))))))))"
  apply (simp add: HFun_Sigma.simps [OF assms])
  apply (rule Iff_refl All_cong Imp_cong Ex_cong)+
  apply (rule Conj_cong [OF Iff_refl])
  apply (rule Conj_cong [OF Iff_refl], auto)
  apply (blast intro: Disj_I1 Neg_D OrdNotEqP_I)
  apply (blast intro: Disj_I2)
  apply (blast intro: OrdNotEqP_E rotate2)
  done

lemma HFun_Sigma_sf [iff]: "Sigma_fm (HFun_Sigma t)"
proof -
  obtain x::name and y::name and z::name and x'::name and y'::name and z'::name
    where atoms: "atom z \<sharp> (t,z',x,y,x',y')"  "atom z' \<sharp> (t,x,y,x',y')"
       "atom x \<sharp> (t,y,x',y')"  "atom y \<sharp> (t,x',y')"
       "atom x' \<sharp> (t,y')"  "atom y' \<sharp> (t)"
    by (metis obtain_fresh)
  show ?thesis
    by (auto intro!: Sigma_fm_Iff [OF HFun_Sigma_Iff [OF atoms]] simp: supp_conv_fresh atoms)
qed

lemma LstSeqP_sf [iff]: "Sigma_fm (LstSeqP t u v)"
  by (auto simp: LstSeqP.simps)

end