theory search
  imports Main
begin

fun liner_search_iter :: "'a \<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> nat option" where
  "liner_search_iter _ [] _ = None"|
  "liner_search_iter x (x0 # xs) idx = (if x=x0 then (Some idx) else (liner_search_iter x xs (idx+1)))"

fun liner_search :: "'a \<Rightarrow> 'a list \<Rightarrow> nat option" where
  "liner_search a xs = liner_search_iter a xs 0"

value "liner_search (5::int) [3, 4::int, 6, 7, 8, 5]"
value "take (3::nat) [a, b, c, d]"
value "nth [1, 2, 3::int] 1"

lemma liner_search_some: "liner_search_iter x xs v = Some vi \<Longrightarrow> \<exists> ui. liner_search_iter x xs u = Some ui"
  proof(induction xs arbitrary: v u)
    case Nil
    then show ?case by auto
  next
    case (Cons a xs)
    then show ?case proof(cases "x = a")
      assume "x=a"
      then have " liner_search_iter x (a # xs) u = Some u"
        by simp
      then show ?case
        by blast
    next
      assume "\<not> x=a"
      then have "liner_search_iter x (a # xs) u = liner_search_iter x xs (u+1)" by simp
      then show ?case
        by (metis Cons.IH Cons.prems liner_search_iter.simps(2))
    qed
  qed

lemma liner_search_none: "liner_search_iter x xs v = None \<Longrightarrow> liner_search_iter x xs u = None"
proof(induction xs)
  case Nil
  then show ?case by auto
next
  case (Cons a xs)
  then show ?case
    by (metis liner_search_some option.exhaust option.simps(2))
qed

lemma "liner_search x xs = None \<Longrightarrow> x \<notin> (set xs)"
  apply(simp)
proof(induction xs)
  case Nil
  then show ?case by auto
next
  case (Cons a xs)
  then have "liner_search_iter x xs 1 = None"
    by (metis add.left_neutral liner_search_iter.simps(2) option.simps(3))
  then have a0: "liner_search_iter x xs 0 = None"
    by (metis liner_search_none)
  then have "x \<noteq> a"
    using Cons.prems by auto
  then show ?case
    using Cons.IH a0 by auto
qed

  (*
lemma "(a # xs) ! idx = xs ! (THE u. (Suc u) = idx)"
  by *)

lemma liner_search_iter_Suc: "liner_search_iter x xs u = Some v \<Longrightarrow> liner_search_iter x xs (Suc u) = Some (Suc v)"
  proof(induction xs arbitrary: u v)
    case Nil
    then show ?case by auto
  next
    case (Cons a xs)
    then show ?case proof(cases "x = a")
      assume "x=a"
      then show ?case
        using Cons.prems by auto
    next
      assume "\<not> x=a"
      then have "liner_search_iter x (a # xs) (Suc u) = liner_search_iter x xs (Suc(Suc u))" by simp
      then show ?case
        by (metis Cons.IH Cons.prems Suc_eq_plus1 \<open>x \<noteq> a\<close> liner_search_iter.simps(2))
    qed
  qed

lemma liner_search_iter_gt0: "Some idx = liner_search_iter x xs 1 \<Longrightarrow> idx > 0"
  proof(induction xs)
    case Nil
    then show ?case by auto
  next
    case (Cons a xs)
    then show ?case proof(cases "x = a")
      assume "x = a"
      then have "liner_search_iter x (a # xs) 1 = Some 1" by simp
      then show ?case
        using Cons.prems by auto
    next
      assume "\<not> x = a"
      then have "liner_search_iter x (a # xs) 1 = liner_search_iter x xs (Suc 1)" by simp

      then show ?case using liner_search_iter_Suc
        by (metis Cons.prems One_nat_def gr0_conv_Suc liner_search_some option.inject)
    qed
  qed

lemma liner_search_iter_inject: "\<lbrakk>liner_search_iter x xs u = Some w;liner_search_iter x xs v = Some w\<rbrakk> \<Longrightarrow> u = v"
  proof(induction xs arbitrary: w)
    case Nil
    then show ?case by auto
  next
    case (Cons a xs)
    then show ?case proof(cases "x = a")
      assume a0: "x = a"
      then have "liner_search_iter x (a # xs) v = Some v" by simp
      then have "liner_search_iter x (a # xs) u = Some u" using a0 by simp

      then show ?case
        using Cons.prems(1) Cons.prems(2) \<open>liner_search_iter x (a # xs) v = Some v\<close> by auto
    next
      assume a1: "\<not> x = a"
      then have a2: "liner_search_iter x (a # xs) u = liner_search_iter x xs (u+1)" by simp
      then have "liner_search_iter x (a # xs) v = liner_search_iter x xs (v+1)" using a1 by simp
      then have "liner_search_iter x xs (u+1) = Some w"
        using Cons.prems(1) \<open>liner_search_iter x (a # xs) u = liner_search_iter x xs (u + 1)\<close> by auto
      then have b1: "liner_search_iter x xs u = Some (w-1)"
        by (metis One_nat_def add.right_neutral add_Suc_right add_implies_diff liner_search_iter_Suc liner_search_some option.inject)
      then have "liner_search_iter x xs (v+1) = Some w"
        using Cons.prems(2) \<open>liner_search_iter x (a # xs) v = liner_search_iter x xs (v + 1)\<close> by auto
      then have b2: "liner_search_iter x xs v = Some (w-1)"
        by (metis One_nat_def add.right_neutral add_Suc_right add_implies_diff liner_search_iter_Suc liner_search_some option.inject)
      then show ?case using b1 b2
        using Cons.IH by blast
    qed

  qed

lemma "liner_search x xs = Some idx \<Longrightarrow> x = xs ! idx"
  apply(simp)
  proof(induction xs arbitrary: idx)
    case Nil
    then show ?case by auto
  next
    case (Cons a xs)
    then show ?case proof(cases "x = a")
      assume "x = a"
      then show ?thesis
        using Cons.prems by auto
    next
      assume "\<not> x = a"
        then have "Some idx = liner_search_iter x xs 1"
          using Cons.prems by auto
      then have "idx \<noteq> 0"
        by (simp add: liner_search_iter_gt0)
      have "(a # xs) ! idx = xs ! (idx - 1)" using nth_Cons_Suc
        by (simp add: \<open>idx \<noteq> 0\<close> nth_Cons')
      then have " liner_search_iter x xs 0 = Some (idx-1)" using liner_search_iter_inject
      proof -
        have f1: "0 < idx"
          by (simp add: \<open>Some idx = liner_search_iter x xs 1\<close> liner_search_iter_gt0)
        obtain nn :: "nat \<Rightarrow> nat" where
          "(\<not> 0 < idx \<or> idx = Suc (nn idx)) \<and> (0 < idx \<or> (\<forall>n. idx \<noteq> Suc n))"
          by (metis (no_types) gr0_conv_Suc)
        then show ?thesis
          using f1 by (metis One_nat_def Suc_eq_plus1_left \<open>Some idx = liner_search_iter x xs 1\<close> add_left_cancel diff_Suc_Suc diff_zero liner_search_iter_Suc liner_search_some option.inject)
      qed
      then show ?thesis
        using Cons.IH \<open>(a # xs) ! idx = xs ! (idx - 1)\<close> by auto
    qed
qed

value "(5::int) div (2::int)"

function binary_search_iter :: "'a::ord \<Rightarrow> 'a list \<Rightarrow> int \<Rightarrow> int \<Rightarrow> nat option" where
  "binary_search_iter x xs l r = (if l \<le> r then
  (let mid=(l+r) div 2; mid_v=xs ! (nat mid) in
      (if mid_v=x
        then (Some (nat mid))
        else (if mid_v < x
              then (binary_search_iter x xs (mid+1) r)
              else (binary_search_iter x xs l (mid-1))))) else None)"
  by pat_completeness auto
termination apply (relation "measure (\<lambda> (x, xs, l, r). nat (r-l+1))")
    apply auto
  done

value "binary_search_iter (5::int) [1, 2, 3, 4, 5, 6, 7, 8] 0 7"

fun binary_search :: "'a::ord \<Rightarrow> 'a list \<Rightarrow> nat option" where
  bin_Nil: "binary_search _ [] = None"|
  bin_xs: "binary_search x xs = binary_search_iter x xs 0 ((int (length xs))-1)"

value "binary_search (5::int) [1, 3, 4, 6, 7, 8]"
value "binary_search (5::int) [1, 3, 5, 6, 7, 8]"

lemma "\<lbrakk>sorted xs; binary_search x xs=None\<rbrakk> \<Longrightarrow> x \<notin> set xs"
  proof(induction xs)
    case Nil
    then show ?case by auto
  next
    case (Cons a xs)
    assume a0: "sorted xs \<Longrightarrow> binary_search x xs = None \<Longrightarrow> x \<notin> set xs"
      and sorted_a_xs: "sorted (a # xs)"
      and search_a_xs: "binary_search x (a # xs) = None"
    then have "sorted xs" by simp
    then show ?case
        then have
  then show ?case
qed

end


theory Regular
  imports Words
begin

(* Regular Languages *)
type_synonym 'a RegLang = "'a word set"

(* Regular Operations *)
definition concat :: "'a RegLang \<Rightarrow> 'a RegLang \<Rightarrow> 'a RegLang" where
  "concat R S = {u\<cdot>v |u v. u\<in>R & v\<in>S}"

lemma concat_containment: "a \<in> A \<and> b \<in> B \<Longrightarrow> (a \<cdot> b) \<in> (concat A B)"
  by (auto simp add: concat_def)

lemma in_concat_if: "w \<in> (concat A B) \<Longrightarrow> \<exists>a b. w = a\<cdot>b \<and> a \<in> A \<and> b \<in> B "
  by (auto simp add: concat_def)

lemma epsilon_concat_iff: "\<epsilon> \<in> A \<and> \<epsilon> \<in> B \<longleftrightarrow> \<epsilon> \<in> (concat A B)"
  by (auto simp add: concat_def)

lemma epsilon_in_const_iff: "\<epsilon> \<in> {x} \<longleftrightarrow> x = \<epsilon>"
  by auto

primrec pow :: "'a RegLang \<Rightarrow> nat \<Rightarrow> 'a RegLang" where
  "pow s 0 = {\<epsilon>}"|
  "pow s (Suc n) = concat s (pow s n)"

lemma pow_epsilon:"pow {\<epsilon>} n = {\<epsilon>}"
  by (induct n) (auto simp add: in_concat_if epsilon_concat_iff concat_def)

lemma pow_zero_empty: "pow {} 0 = {\<epsilon>}"
  by auto

lemma pow_n_empty: "n > 0 \<Longrightarrow> pow {} n = {}"
  by (induct n) (auto simp add: concat_def)

definition star :: "'a RegLang \<Rightarrow> 'a RegLang" where
  "star R = (\<Union>n. (pow R n))"

lemma epsilon_in_star[simp]: "\<epsilon> \<in> star R"
proof -
  have "\<epsilon> \<in> pow R 0"
    by simp
  then have "EX n. \<epsilon> \<in> pow R n"
    by (rule exI)
  then show ?thesis
    by (auto simp add: star_def)
qed

lemma singleton_set: "{w. (length w) = 1} = {v| a v. v = a#\<epsilon>}"
  by (auto simp add: length_Suc_conv)

lemma epsilon_in_pow:"\<exists>n. \<epsilon> \<in> pow r n"
proof -
  have "\<epsilon> \<in> pow r 0"
    by simp
  thus ?thesis
    by (rule exI)
qed

lemma star_all_pows: "star r = {w|w n. w \<in> pow r n}"
  by (auto simp add: star_def)

lemma pow_not_zero:"n > 0 \<and> w \<in> pow r n \<Longrightarrow> \<exists>m. w \<in> pow r (Suc m)"
  by (induct n) (auto simp add: concat_def)

lemma star_of_epsilon:"star {\<epsilon>} = {\<epsilon>}"
  by (simp add:star_def pow_epsilon)

lemma star_of_empty: "star {} = {\<epsilon>}"
proof
  have "\<forall>x n. x \<in> pow {} n \<longrightarrow> x = \<epsilon>"
    by (metis Regular.pow.simps(1) bot_nat_0.not_eq_extremum empty_iff pow_n_empty singletonD)
  then show  "star {} \<subseteq> {\<epsilon>}"
    by (auto simp add: star_def)
next
  show "{\<epsilon>} \<subseteq> star {}"
    by (simp add: epsilon_in_pow)
qed

lemma concat_trans: "w \<in> r \<longleftrightarrow> a#w \<in> concat {a#\<epsilon>} r"
  by (auto simp add: concat_def)

lemma concat_star_subset: "concat L (star L) \<subseteq> (star L)"
proof
  fix w  assume "w \<in> concat L (star L)"
  then have "w \<in> {w |w n. w \<in> pow L (Suc n)}"
    by (auto simp add: concat_def star_all_pows)
  then have "w \<in> {w |w m. w \<in> pow L m}"
    by blast
  then show "w \<in> (star L)"
    by (simp only: star_all_pows)
qed

lemma concat_star:
  assumes "set ws \<subseteq> R"
  shows "concat_all ws \<in> (star R)"
  using assms
proof (induct ws)
  case Nil
  then show ?case
    by auto
next
  case (Cons a ws)
  then show ?case
    using concat_containment concat_star_subset by force
qed

lemma star_subsumes: "v\<cdot>w \<in> concat {v} (star r) \<and> v \<in> r \<Longrightarrow> v\<cdot>w \<in> (star r)"
  using concat_star_subset concat_containment in_concat_if by blast

lemma star_of_singletons_is_univ: "x \<in> star {v|v a. v = a#\<epsilon>}"
proof (induct x)
  case Nil
  then show ?case by auto
next
  case (Cons a x)
  then have "x \<in> star {uu. \<exists>a v. uu = v \<and> v = a # \<epsilon>}"
    by auto
  then have "x \<in> star {v |v b. v = b#\<epsilon>}"
    by auto
  then have fac1:"a#x \<in> concat {a#\<epsilon>} (star {v |v b. v = b#\<epsilon>})"
    using concat_trans by fastforce
  have fac2: "(a#\<epsilon>) \<in> {v |v b. v = b#\<epsilon>}"
    by simp
  from fac1 fac2 have "a#x \<in> (star {v |v b. v = b#\<epsilon>})"
    using star_subsumes by (metis in_concat_if singletonD)
  then show ?case
    by auto
qed

lemma star_remove_epsilons:
  assumes P: "set ws \<subseteq> R" (is ?P)
  shows "\<exists>wsa. concat_all ws = concat_all wsa \<and> set wsa \<subseteq> R - {\<epsilon>}" (is "\<exists> vs. ?Q vs")
proof
  let ?vs = "filter (\<lambda>u. u \<noteq> \<epsilon>) ws"
  show "?Q ?vs"
    using assms by (induct ws) auto
qed

lemma concat_all_subset_if_pow: "w \<in> pow r n \<Longrightarrow> \<exists>ws. w = concat_all ws \<and> set ws \<subseteq> r"
proof (induct n arbitrary: r  w)
  case 0
  then show ?case
    by (metis Regular.pow.simps(1) concat_all.simps(1) empty_set empty_subsetI singletonD)
next
  case IH:(Suc n)
  then have "w \<in> concat r (pow r n)"
    by force
  then have "\<exists>x y. w = x\<cdot>y \<and> x \<in> r \<and> y \<in> (pow r n)"
    by (force simp add: concat_def)
  then have "\<exists>x y. w = x\<cdot>y \<and> (\<exists>ws. y = concat_all ws \<and> set ws \<subseteq> r)"
    using IH by fastforce
  then have "\<exists>ws. w = concat_all ws \<and> set ws \<subseteq> r"
    by (metis IH.hyps \<open>\<exists>x y. w = x \<cdot> y \<and> x \<in> r \<and> y \<in> pow r n\<close> concat_all.simps(2) insert_subset list.set(2))
  then show ?case
    by simp
qed

lemma star_is_concats: "star R = {concat_all ws|ws. set ws \<subseteq> R}"
proof
  show "star R \<subseteq> {concat_all ws |ws. set ws \<subseteq> R}"
    unfolding star_all_pows
    by (auto simp add: concat_all_subset_if_pow)
next
  have "\<And>ws. set ws \<subseteq> R \<Longrightarrow> \<exists>n. concat_all ws \<in> pow R n"
    by (metis UN_E concat_star star_def)
  then show "{concat_all ws |ws. set ws \<subseteq> R} \<subseteq> star R"
    unfolding star_all_pows by (auto simp add: concat_all_subset_if_pow)
qed

lemma star_rm_epsilon: "star (R-{\<epsilon>}) = star R"
  unfolding star_is_concats by (auto simp add: star_remove_epsilons)

lemma star_if_pow[simp]: "w \<in> pow R n \<Longrightarrow> w \<in> (star R)"
  by (auto simp add: star_def)

(* Derivative of regular languages *)
definition deriv:: "'a \<Rightarrow> 'a RegLang \<Rightarrow> 'a RegLang" where
  "deriv a R = {v |v. (a#v) \<in> R}"

primrec derivw:: "'a word \<Rightarrow> 'a RegLang \<Rightarrow> 'a RegLang" where
  "derivw \<epsilon> R = R" |
  "derivw (a#w) R = derivw w (deriv a R)"

definition null:: "'a RegLang \<Rightarrow> 'a RegLang" where
  "(null L) = (if \<epsilon> \<in> L then {\<epsilon>} else {})"

lemma null_empty[simp]: "null {} = {}"
  by (simp add: Regular.null_def)

lemma null_epsilon[simp]: "null {\<epsilon>} = {\<epsilon>}"
  by (simp add: Regular.null_def)

lemma deriv_empty:"deriv a {} = {}"
  by (simp add: deriv_def)

lemma deriv_const: "deriv a {(b#w)} = (if a = b then {w} else {})"
  by (auto simp add: deriv_def)

lemma deriv_union: "deriv a (l1 \<union> l2) = (deriv a l1) \<union> (deriv a l2)"
  by (auto simp add: deriv_def)

lemma deriv_inter: "deriv a (l1 \<inter> l2) = (deriv a l1) \<inter> (deriv a l2)"
  by (auto simp add: deriv_def)

lemma deriv_concat:"deriv a (concat L R) = (concat (deriv a L) R) \<union> (concat (null L) (deriv a R))"
  unfolding deriv_def concat_def null_def
  apply auto
  by (metis append_eq_Cons_conv)+

lemma pow_not_epsilon_is_succ:"n>0 \<and> w \<in> pow R n \<Longrightarrow> \<exists>m. w \<in> pow R (Suc m)"
  by (induct n) (auto simp add: pow_def)

lemma star_unroll:"star r = (concat r (star r)) \<union> {\<epsilon>}"
proof -
  have "\<And>x n. x \<noteq> \<epsilon> \<Longrightarrow> x \<in> pow r n \<Longrightarrow> \<exists>u v. x = u \<cdot> v \<and> u \<in> r \<and> (\<exists>n. v \<in> pow r n)"
    by (metis Regular.pow.simps(1) Regular.pow.simps(2) bot_nat_0.not_eq_extremum in_concat_if
        pow_not_epsilon_is_succ singletonD)
  moreover
  have "\<And>u v n. u \<in> r \<Longrightarrow> v \<in> pow r n \<Longrightarrow> \<exists>n. u \<cdot> v \<in> pow r n"
    unfolding concat_def star_all_pows using Regular.pow.simps(2) concat_containment by blast
  ultimately
  show ?thesis
    unfolding concat_def star_all_pows by (auto simp add: pow_not_zero concat_def epsilon_in_pow)
qed

lemma deriv_star:"deriv a (star R) = concat (deriv a R) (star R)"
proof -
  have "deriv a (star R) = deriv a (star (R-{\<epsilon>}))" by
      (auto simp only: star_rm_epsilon)
  also have "... = deriv a ((concat (R-{\<epsilon>}) (star (R-{\<epsilon>}))) \<union> {\<epsilon>})"
    by (metis star_unroll)
  also have "... = (deriv a (concat (R-{\<epsilon>}) (star (R-{\<epsilon>})))) \<union> (deriv a {\<epsilon>})"
    by (simp only: deriv_union)
  also have "... = deriv a (concat (R-{\<epsilon>}) (star (R-{\<epsilon>})))"
    by (simp add: deriv_def)
  also have "... = (concat (deriv a (R-{\<epsilon>})) (star (R-{\<epsilon>}))) \<union>
                   (concat (null (R-{\<epsilon>})) (deriv a (star (R-{\<epsilon>}))))"
    by (simp add: deriv_concat)
  also have "... = (concat (deriv a (R-{\<epsilon>})) (star (R-{\<epsilon>}))) \<union> (concat {} (deriv a (star (R-{\<epsilon>}))))"
    by (auto simp add: null_def)
  also have "... =  (concat (deriv a (R-{\<epsilon>})) (star (R-{\<epsilon>})))"
    by (simp add: concat_def)
  also have "... = (concat (deriv a R) (star (R-{\<epsilon>})))"
    by (simp add: deriv_def)
  also have "... = (concat (deriv a R) (star R))"
    by (simp only: star_rm_epsilon)
  finally have "deriv a (star R) = concat (deriv a R) (star R)"
    by simp
  then show ?thesis
    by simp
qed

theorem deriv_correct:"w \<in> deriv a R \<longleftrightarrow> (a#w) \<in> R"
  by (auto simp add: deriv_def)

end


section \<open>Translating terms into Graphs\<close>
text \<open>We define the translation function and its properties.\<close>

theory RuleSemanticsConnection
imports LabeledGraphSemantics RulesAndChains
begin

text \<open>Definition 15.\<close>
fun translation :: "'c allegorical_term \<Rightarrow> ('c, nat) labeled_graph" where
"translation (A_Lbl l) = LG {(l,0,1)} {0,1}" |
"translation (A_Cnv e) = map_graph_fn (translation e) (\<lambda> x. if x<2 then (1-x) else x)" |
"translation (A_Cmp e\<^sub>1 e\<^sub>2)
  = (let G\<^sub>1 = translation e\<^sub>1 ; G\<^sub>2 = translation e\<^sub>2
     in graph_union (map_graph_fn G\<^sub>1 (\<lambda> x. if x=0 then 0 else x+card(vertices G\<^sub>2)-1))
                    (map_graph_fn G\<^sub>2 (\<lambda> x. if x=0 then card (vertices G\<^sub>2) else x)))" |
"translation (A_Int e\<^sub>1 e\<^sub>2)
  = (let G\<^sub>1 = translation e\<^sub>1 ; G\<^sub>2 = translation e\<^sub>2
     in graph_union G\<^sub>1 (map_graph_fn G\<^sub>2 (\<lambda> x. if x<2 then x else x+card(vertices G\<^sub>1)-2)))"

definition inv_translation where
"inv_translation r \<equiv> {0..<card r} = r \<and> {0,1}\<subseteq>r"

lemma inv_translationI4[intro]:
  assumes "finite r" "\<And> x. x < card r \<Longrightarrow> x \<in> r"
  shows "r={0..<card r}"
proof(insert assms,induct "card r" arbitrary:r)
  case (Suc x r)
  let ?r = "r - {x}"
  from Suc have p:"x = card ?r" "finite ?r" by auto
  have p2:"xa < card ?r \<Longrightarrow> xa \<in> ?r" for xa
    using Suc.prems(2)[of xa] Suc.hyps(2) unfolding p(1)[symmetric] by auto
  from Suc.hyps(1)[OF p p2] have "?r={0..<card ?r}".
  with Suc.hyps(2) Suc.prems(1) show ?case
    by (metis atLeast0_lessThan_Suc card_Diff_singleton_if insert_Diff n_not_Suc_n p(1))
qed auto

lemma inv_translationI[intro!]:
assumes "finite r" "\<And> x. x < card r \<Longrightarrow> x \<in> r" "0 \<in> r" "Suc 0 \<in> r"
shows "inv_translation r"
proof -
  from inv_translationI4[OF assms(1,2),symmetric]
  have c:" {0..<card r} = r " by auto
  from assms(3,4) have "{0,1} \<subseteq> r" by auto
  with c inv_translation_def show ?thesis by auto
qed

lemma verts_in_translation_finite[intro]:
"finite (vertices (translation X))"
"finite (edges (translation X))"
"0 \<in> vertices (translation X)"
"Suc 0 \<in> vertices (translation X)"
proof(atomize(full),induction X)
  case (A_Int X1 X2)
  then show ?case by (auto simp:Let_def)
next
  case (A_Cmp X1 X2)
  then show ?case by (auto simp:Let_def)
next
  have [simp]:"{x::nat. x < 2} = {0,1}" by auto
  case (A_Cnv X)
  then show ?case by auto
qed auto

lemma inv_tr_card_min:
  assumes "inv_translation r"
  shows "card r \<ge> 2"
proof -
  note [simp] = inv_translation_def
  have "{0..<x} = r \<Longrightarrow> 2 \<le> x \<longleftrightarrow> 0 \<in> r \<and> 1 \<in> r" for x by auto
  thus ge2:"card r\<ge>2" using assms by auto
qed

lemma verts_in_translation[intro]:
"inv_translation (vertices (translation X))"
proof(induct X)
  { fix r
    assume assms:"inv_translation r"
    note [simp] = inv_translation_def
    from assms have a1:"finite r"
      by (intro card_ge_0_finite) auto
    have [simp]:"{0..<Suc x} = {0..<x} \<union> {x}" for x by auto
    note ge2 = inv_tr_card_min[OF assms]
    from ge2 assms have r0:"r \<inter> {0} = {0}" "r \<inter> {x. x < 2} = {0,1}" by auto
    have [intro!]:"\<And>x. x \<in> r \<Longrightarrow> x < card r"
     and g6:"\<And>x. x < card r \<longleftrightarrow> x \<in> r"
      using assms[unfolded inv_translation_def] atLeastLessThan_iff by blast+
    have g4:"r \<inter> {x. \<not> x < 2} = {2..<card r}"
            "r \<inter> (Collect ((<) 0)) = {1..<card r}" using assms by fastforce+
    have ins:"1 \<in> r" "0 \<in> r" using assms by auto
    have d:"Suc (Suc (card r - 2)) = card r"
      using ge2 One_nat_def Suc_diff_Suc Suc_pred
            numeral_2_eq_2 by presburger
    note ge2 ins g4 g6 r0 d
  } note inv_translationD[simp] = this
  {
    fix a b c
    assume assm:"b \<le> (a::nat)"
    have "(\<lambda>x. x + a - b) ` {b..<c} = {a..<c+a-b}" (is "?lhs = ?rhs")
    proof -
      from assm have "?lhs = (\<lambda>x. x + (a - b)) ` {b..<c}" by auto
      also have "\<dots> = ?rhs"
        unfolding linordered_semidom_class.image_add_atLeastLessThan' using assm by auto
      finally show ?thesis by auto
    qed
  } note e[simp] = this
  { fix r z
    assume a1: "inv_translation z" and a2: "inv_translation r"
    let ?z2 = "card z + card r - 2"
    let ?z1 = "card z + card r - Suc 0"
    from a1 a2
    have le1:"Suc 0 \<le> card r"
      by (metis Suc_leD inv_translationD(1) numerals(2))
    hence le2: "card r \<le> ?z1"
      by (metis Suc_leD a1 inv_translationD(1) numerals(2) ordered_cancel_comm_monoid_diff_class.le_add_diff)
    with le1 have b:"{card r ..< ?z1} \<union> {Suc 0 ..< card r} = {Suc 0 ..< ?z1}"
      by auto
    have a:"(insert (card r) {0..<card z + card r - Suc 0}) = {0..<card z + card r - Suc 0}"
      using le1 le2 a1 a2
      by (metis Suc_leD add_Suc_right atLeastLessThan_iff diff_Suc_Suc insert_absorb inv_translationD(1) linorder_not_less not_less_eq_eq numerals(2) ordered_cancel_comm_monoid_diff_class.le_add_diff)
    from a1 a2
    have "card z + card r - 2 \<ge> card (r::nat set)"
      by (simp add: ordered_cancel_comm_monoid_diff_class.le_add_diff)
    with a2
    have c:"card (r \<union> {card r..<?z2}) = ?z2"
      by (metis atLeast0LessThan card_atLeastLessThan diff_zero inv_translation_def ivl_disj_un_one(2))+
    note a b c
  } note [simp] = this
  have [simp]:"a < x \<Longrightarrow> insert a {Suc a..<x} = {a..<x}" for a x by auto
  { case (A_Int X1 X2)
    let ?v1 = "vertices (translation X1)"
    from A_Int have [simp]:"(insert 0 (insert (Suc 0) (?v1 \<union> x))) = ?v1 \<union> x"
      for x unfolding inv_translation_def by auto
    from A_Int show ?case by (auto simp:Let_def linorder_not_le)
  next
    case (A_Cmp X1 X2)
    hence "2\<le>card (vertices (translation X1))" "2\<le>card (vertices (translation X2))" by auto
    hence "1 \<le>card (vertices (translation X1))" "1\<le>card (vertices (translation X2))"
          "1 < card (vertices (translation X1)) + card (vertices (translation X2)) - 1"
      by auto
    from this A_Cmp
    show ?case by (auto simp:Let_def)
  next
    case (A_Cnv X)
    thus ?case by (auto simp:Let_def)
  }
qed auto

lemma translation_graph[intro]:
"graph (translation X)"
  by (induct X, auto simp:Let_def)

lemma graph_rule_translation[intro]: (* remark at the end of Def 15 *)
"graph_rule (translation X, translation (A_Int X Y))"
  using verts_in_translation_finite[of X] verts_in_translation_finite[of "A_Int X Y"]
        translation_graph[of X] translation_graph[of "A_Int X Y"]
  by (auto simp:Let_def subgraph_def2)

lemma graph_hom_translation[intro]:
  "graph_homomorphism (LG {} {0,1}) (translation X) (Id_on {0,1})"
  using verts_in_translation[of X]
  unfolding inv_translation_def graph_homomorphism_def2 by auto

lemma translation_right_to_left:
  assumes f:"graph_homomorphism (translation e) G f" "(0, x) \<in> f" "(1, y) \<in> f"
  shows "(x, y) \<in> :G:\<lbrakk>e\<rbrakk>"
  using f
proof(induct e arbitrary:f x y)
case (A_Int e\<^sub>1 e\<^sub>2 f x y)
  let ?f\<^sub>1 = "id"
  let ?f\<^sub>2 = "(\<lambda> x. if x < 2 then x else x + card (vertices (translation e\<^sub>1)) - 2)"
  let ?G\<^sub>1 = "translation e\<^sub>1"
  let ?G\<^sub>2 = "translation e\<^sub>2"
  have f1:"(0, x) \<in> on_graph ?G\<^sub>1 ?f\<^sub>1 O f" "(1, y) \<in> on_graph ?G\<^sub>1 ?f\<^sub>1 O f"
   and f2:"(0, x) \<in> on_graph ?G\<^sub>2 ?f\<^sub>2 O f" "(1, y) \<in> on_graph ?G\<^sub>2 ?f\<^sub>2 O f"
    using A_Int.prems(2,3) by (auto simp:BNF_Def.Gr_def relcomp_def)
  from A_Int.prems(1)
  have uni:"graph_homomorphism (graph_union ?G\<^sub>1 (map_graph_fn ?G\<^sub>2 ?f\<^sub>2)) G f"
    by (auto simp:Let_def)
  from graph_homo_union_id(1)[OF uni translation_graph]
  have h1:"graph_homomorphism ?G\<^sub>1 (translation (A_Int e\<^sub>1 e\<^sub>2)) (on_graph ?G\<^sub>1 id)"
    by (auto simp:Let_def graph_homomorphism_def)
  have "graph (map_graph_fn ?G\<^sub>2 ?f\<^sub>2)" by auto
  from graph_homo_union_id(2)[OF uni this]
  have h2:"graph_homomorphism ?G\<^sub>2 (translation (A_Int e\<^sub>1 e\<^sub>2)) (on_graph ?G\<^sub>2 ?f\<^sub>2)"
    by (auto simp:Let_def graph_homomorphism_def)
  from A_Int.hyps(1)[OF graph_homomorphism_composes[OF h1 A_Int.prems(1)] f1]
       A_Int.hyps(2)[OF graph_homomorphism_composes[OF h2 A_Int.prems(1)] f2]
  show ?case by auto
next
  case (A_Cmp e\<^sub>1 e\<^sub>2 f x y)
  let ?f\<^sub>1 =  "(\<lambda> x. if x=0 then 0 else x+card(vertices (translation e\<^sub>2))-1)"
  let ?f\<^sub>2 =  "(\<lambda> x. if x=0 then card (vertices (translation e\<^sub>2)) else x)"
  let ?G\<^sub>1 = "translation e\<^sub>1"
  let ?G\<^sub>2 = "translation e\<^sub>2"
  let ?v = "card (vertices (translation e\<^sub>2))"
  from A_Cmp.prems(1) have "?v \<in> Domain f" by (auto simp:Let_def graph_homomorphism_def)
  then obtain v where v:"(?v,v) \<in> f" by auto
  have f1:"(0, x) \<in> on_graph ?G\<^sub>1 ?f\<^sub>1 O f" "(1, v) \<in> on_graph ?G\<^sub>1 ?f\<^sub>1 O f"
   and f2:"(0, v) \<in> on_graph ?G\<^sub>2 ?f\<^sub>2 O f" "(1, y) \<in> on_graph ?G\<^sub>2 ?f\<^sub>2 O f"
    using A_Cmp.prems(2,3) v by auto
  from A_Cmp.prems(1)
  have uni:"graph_homomorphism (graph_union (map_graph_fn ?G\<^sub>1 ?f\<^sub>1) (map_graph_fn ?G\<^sub>2 ?f\<^sub>2)) G f"
    by (auto simp:Let_def)
  have "graph (map_graph_fn ?G\<^sub>1 ?f\<^sub>1)" by auto
  from graph_homo_union_id(1)[OF uni this]
  have h1:"graph_homomorphism ?G\<^sub>1 (translation (A_Cmp e\<^sub>1 e\<^sub>2)) (on_graph ?G\<^sub>1 ?f\<^sub>1)"
    by (auto simp:Let_def graph_homomorphism_def2)
  have "graph (map_graph_fn ?G\<^sub>2 ?f\<^sub>2)" by auto
  from graph_homo_union_id(2)[OF uni this]
  have h2:"graph_homomorphism ?G\<^sub>2 (translation (A_Cmp e\<^sub>1 e\<^sub>2)) (on_graph ?G\<^sub>2 ?f\<^sub>2)"
    by (auto simp:Let_def graph_homomorphism_def2)
  from A_Cmp.hyps(1)[OF graph_homomorphism_composes[OF h1 A_Cmp.prems(1)] f1]
       A_Cmp.hyps(2)[OF graph_homomorphism_composes[OF h2 A_Cmp.prems(1)] f2]
  show ?case by auto
next
  case (A_Cnv e f x y)
  let ?f = "(\<lambda> x. if x < 2 then 1 - x else x)"
  let ?G = "translation e"
  have i:"graph_homomorphism ?G (map_graph_fn ?G ?f) (on_graph ?G ?f)" using A_Cnv by auto
  have "(0, y) \<in> on_graph ?G ?f O f" "(1, x) \<in> on_graph ?G ?f O f"
    using A_Cnv.prems(3,2) by (auto simp:BNF_Def.Gr_def relcomp_def)
  from A_Cnv.hyps(1)[OF graph_homomorphism_composes[OF i] this] A_Cnv.prems(1)
  show ?case by auto
next
case (A_Lbl l f x y)
  hence "edge_preserving f {(l,0,1)} (edges G)" unfolding graph_homomorphism_def by auto
  with A_Lbl(2,3) show ?case by (auto simp:getRel_def edge_preserving_def)
qed

lemma translation_homomorphism:
  assumes "graph_homomorphism (translation e) G f"
  shows "f `` {0} \<times> f `` {1} \<subseteq> :G:\<lbrakk>e\<rbrakk>" ":G:\<lbrakk>e\<rbrakk> \<noteq> {}"
  using translation_right_to_left[OF assms] assms[unfolded graph_homomorphism_def2]
        verts_in_translation_finite[of e] by auto

text \<open>Lemma 5.\<close>
lemma translation:
  assumes "graph G"
  shows "(x, y) \<in> :G:\<lbrakk>e\<rbrakk> \<longleftrightarrow> (\<exists> f. graph_homomorphism (translation e) G f \<and> (0,x) \<in> f \<and> (1,y) \<in> f)"
(is "?lhs = ?rhs")
proof
  have [dest]:"y + card (vertices (translation (e::'a allegorical_term))) - 2 < 2 \<Longrightarrow> (y::nat) < 2"
    for y e using inv_tr_card_min[OF verts_in_translation,of e] by linarith
  {  fix y fix e::"'a allegorical_term"
     assume "y + card (vertices (translation e)) - 2 \<in> vertices (translation e)"
     hence "y + card (vertices (translation e)) - 2 < card (vertices (translation e))"
       using verts_in_translation[of e,unfolded inv_translation_def] by auto
     hence "y < 2" using inv_tr_card_min[OF verts_in_translation,of e] by auto
  } note [dest!] = this
  {  fix y fix e::"'a allegorical_term"
     assume "y + card (vertices (translation e)) - Suc 0 \<in> vertices (translation e)"
     hence "y + card (vertices (translation e)) - Suc 0 \<in> {0..<card (vertices (translation e))}"
       using verts_in_translation[of e,unfolded inv_translation_def] by simp
     hence "y = 0" using inv_tr_card_min[OF verts_in_translation,of e] by auto
   } note [dest!] = this
   {  fix y fix e::"'a allegorical_term"
     assume "card (vertices (translation e)) \<in> vertices (translation e)"
     hence "card (vertices (translation e)) \<in> {0..<card (vertices (translation e))}"
       using verts_in_translation[of e,unfolded inv_translation_def] by auto
     hence "False" by auto
   } note [dest!] = this
  {  fix y fix e::"'a allegorical_term"
     assume "y + card (vertices (translation e)) \<le> Suc 0"
     hence " card (vertices (translation e)) \<le> Suc 0" by auto
     hence "False" using inv_tr_card_min[OF verts_in_translation[of e]] by auto
   } note [dest!] = this
  assume ?lhs
  then show ?rhs
  proof(induct e arbitrary:x y)
    case (A_Int e\<^sub>1 e\<^sub>2)
    from A_Int have assm:"(x, y) \<in> :G:\<lbrakk>e\<^sub>1\<rbrakk>" "(x, y) \<in> :G:\<lbrakk>e\<^sub>2\<rbrakk>" by auto
    from A_Int(1)[OF assm(1)] obtain f\<^sub>1 where
      f\<^sub>1:"graph_homomorphism (translation e\<^sub>1) G f\<^sub>1" "(0, x) \<in> f\<^sub>1" "(1, y) \<in> f\<^sub>1" by auto
    from A_Int(2)[OF assm(2)] obtain f\<^sub>2 where
      f\<^sub>2:"graph_homomorphism (translation e\<^sub>2) G f\<^sub>2" "(0, x) \<in> f\<^sub>2" "(1, y) \<in> f\<^sub>2" by auto
    from f\<^sub>1 f\<^sub>2 have v:"Domain f\<^sub>1 = vertices (translation e\<^sub>1)" "Domain f\<^sub>2 = vertices (translation e\<^sub>2)"
      unfolding graph_homomorphism_def by auto
    let ?f\<^sub>2 = "(\<lambda> x. if x < 2 then x else x + card (vertices (translation e\<^sub>1)) - 2)"
    let ?tr\<^sub>2 = "on_graph (translation e\<^sub>2) ?f\<^sub>2"
    have inj2:"inj_on ?f\<^sub>2 (vertices (translation e\<^sub>2))" unfolding inj_on_def by auto
    have "(0,0) \<in> ?tr\<^sub>2\<inverse>" "(1,1) \<in> ?tr\<^sub>2\<inverse>" by auto
    from this[THEN relcompI] f\<^sub>2(2,3)
    have zero_one:"(0,x) \<in> ?tr\<^sub>2\<inverse> O f\<^sub>2"
                  "(1,y) \<in> ?tr\<^sub>2\<inverse> O f\<^sub>2" by auto
    { fix yb zb
      assume "(yb + card (vertices (translation e\<^sub>1)) - 2, zb) \<in> f\<^sub>1"
      hence "yb + card (vertices (translation e\<^sub>1)) - 2 \<in> vertices (translation e\<^sub>1)" using v by auto
    } note in_f[dest!] = this
    have d_a:"Domain f\<^sub>1 \<inter>  Domain (?tr\<^sub>2\<inverse> O f\<^sub>2) = {0,1}"
      using zero_one by (auto simp:v)
    have d_b:"Domain (f\<^sub>1 \<inter> ?tr\<^sub>2\<inverse> O f\<^sub>2) = {0,1}"
      using zero_one f\<^sub>1(2,3) by auto
    note cmp2 = graph_homomorphism_composes[OF graph_homo_inv[OF translation_graph inj2] f\<^sub>2(1)]
    have "graph_homomorphism (translation (A_Int e\<^sub>1 e\<^sub>2)) G (f\<^sub>1 \<union> ?tr\<^sub>2\<inverse> O f\<^sub>2)"
      using graph_homo_union[OF f\<^sub>1(1) cmp2 d_a[folded d_b]]
      by (auto simp:Let_def)
    thus ?case using zero_one[THEN UnI2[of _ _ "f\<^sub>1"]] by blast
  next
    case (A_Cmp e\<^sub>1 e\<^sub>2)
    from A_Cmp obtain z where assm:"(x, z) \<in> :G:\<lbrakk>e\<^sub>1\<rbrakk>" "(z, y) \<in> :G:\<lbrakk>e\<^sub>2\<rbrakk>" by auto
    from A_Cmp(1)[OF assm(1)] obtain f\<^sub>1 where
      f\<^sub>1:"graph_homomorphism (translation e\<^sub>1) G f\<^sub>1" "(0, x) \<in> f\<^sub>1" "(1, z) \<in> f\<^sub>1" by auto
    from A_Cmp(2)[OF assm(2)] obtain f\<^sub>2 where
      f\<^sub>2:"graph_homomorphism (translation e\<^sub>2) G f\<^sub>2" "(0, z) \<in> f\<^sub>2" "(1, y) \<in> f\<^sub>2" by auto
    from f\<^sub>1 f\<^sub>2 have v:"Domain f\<^sub>1 = vertices (translation e\<^sub>1)" "Domain f\<^sub>2 = vertices (translation e\<^sub>2)"
      unfolding graph_homomorphism_def by auto
    let ?f\<^sub>1 = "(\<lambda> x. if x=0 then 0 else x+card(vertices (translation e\<^sub>2))-1)"
    let ?f\<^sub>2 = "(\<lambda> x. if x=0 then card (vertices (translation e\<^sub>2)) else x)"
    let ?tr\<^sub>1 = "on_graph (translation e\<^sub>1) ?f\<^sub>1"
    let ?tr\<^sub>2 = "on_graph (translation e\<^sub>2) ?f\<^sub>2"
    have inj1:"inj_on ?f\<^sub>1 (vertices (translation e\<^sub>1))" unfolding inj_on_def by auto
    have inj2:"inj_on ?f\<^sub>2 (vertices (translation e\<^sub>2))" unfolding inj_on_def by auto
    have "(card (vertices (translation e\<^sub>2)),0) \<in> ?tr\<^sub>2\<inverse>" "(1,1) \<in> ?tr\<^sub>2\<inverse>"
         "(0,0) \<in> ?tr\<^sub>1\<inverse>" "(card (vertices (translation e\<^sub>2)),1) \<in> ?tr\<^sub>1\<inverse>" by auto
    from this[THEN relcompI] f\<^sub>2(2,3) f\<^sub>1(2,3)
    have zero_one:"(card (vertices (translation e\<^sub>2)),z) \<in> ?tr\<^sub>1\<inverse> O f\<^sub>1"
                  "(0,x) \<in> ?tr\<^sub>1\<inverse> O f\<^sub>1"
                  "(card (vertices (translation e\<^sub>2)),z) \<in> ?tr\<^sub>2\<inverse> O f\<^sub>2"
                  "(1,y) \<in> ?tr\<^sub>2\<inverse> O f\<^sub>2" by auto
    have [simp]:
        "ye \<in> vertices (translation e\<^sub>2) \<Longrightarrow>
       (if ye = 0 then card (vertices (translation e\<^sub>2)) else ye) =
       (if yd = 0 then 0 else yd + card (vertices (translation e\<^sub>2)) - 1) \<longleftrightarrow> ye = 0 \<and> yd = 1"
        for ye yd using v inv_tr_card_min[OF verts_in_translation,of "e\<^sub>2"]
        by(cases "ye=0";cases "yd=0";auto)
    have d_a:"Domain (?tr\<^sub>1\<inverse> O f\<^sub>1) \<inter>  Domain (?tr\<^sub>2\<inverse> O f\<^sub>2) = {card (vertices (translation e\<^sub>2))}"
      using zero_one by (auto simp:v)
    have d_b:"Domain (?tr\<^sub>1\<inverse> O f\<^sub>1 \<inter> ?tr\<^sub>2\<inverse> O f\<^sub>2) = {card (vertices (translation e\<^sub>2))}"
      using zero_one f\<^sub>1(2,3) by auto
    note cmp1 = graph_homomorphism_composes[OF graph_homo_inv[OF translation_graph inj1] f\<^sub>1(1)]
    note cmp2 = graph_homomorphism_composes[OF graph_homo_inv[OF translation_graph inj2] f\<^sub>2(1)]
    have "graph_homomorphism (translation (A_Cmp e\<^sub>1 e\<^sub>2)) G (?tr\<^sub>1\<inverse> O f\<^sub>1 \<union> ?tr\<^sub>2\<inverse> O f\<^sub>2)"
      unfolding Let_def translation.simps
      by (rule graph_homo_union[OF cmp1 cmp2 d_a[folded d_b]])
    thus ?case using zero_one by blast
  next
    case (A_Cnv e)
    let ?G = "translation (A_Cnv e)"
    from A_Cnv obtain f where
      f:"graph_homomorphism (translation e) G f" "(0, y) \<in> f" "(1, x) \<in> f" by auto
    hence v:"Domain f = vertices (translation e)"
      unfolding graph_homomorphism_def by auto
    define n where "n \<equiv> card (vertices (translation e))"
    from verts_in_translation f inv_tr_card_min[OF verts_in_translation] v(1)
    have n:"vertices (translation e) = {0..<n}" "{0..<n} \<inter> {x. x < 2} = {1,0}"
      "Domain f = {0..<n}" "{0..<n} \<inter> {x. \<not> x < 2} = {2..<n}"
      and n2: "n \<ge> 2"
      by (auto simp:n_def inv_translation_def)
    then have [simp]:"insert (Suc 0) {2..<n} = {1..<n}"
      "insert 0 {Suc 0..<n} = {0..<n}" by auto
    let ?f = "on_graph ?G (\<lambda> x. if x < 2 then 1 - x else x)"
    have h:"graph_homomorphism ?G G (?f O f)"
    proof(rule graph_homomorphism_composes[OF _ f(1)],rule graph_homomorphismI)
      show "vertices ?G = Domain ?f"
        by (auto simp:Domain_int_univ)
      show "?f `` vertices ?G \<subseteq> vertices (translation e)" using n2 by auto
      show "univalent ?f" by auto
      show "edge_preserving ?f (edges (translation (A_Cnv e))) (edges (translation e))"
        by (rule edge_preserving_on_graphI,auto simp: BNF_Def.Gr_def)
    qed (auto intro:assms)
    have xy:"(0, x) \<in> ?f O f" "(1, y) \<in> ?f O f" using n2 f(2,3) n(1,2) by auto
    with h show ?case by auto
  next
    case (A_Lbl l)
    let ?f = "{(0,x),(1,y)}"
    have xy:"x \<in> vertices G" "y \<in> vertices G" using assms A_Lbl by (auto simp:getRel_def)
    have "graph_homomorphism (translation (A_Lbl l)) G ?f \<and> (0, x) \<in> ?f \<and> (1, y) \<in> ?f"
      using assms A_Lbl xy unfolding graph_homomorphism_def2
      by (auto simp:univalent_def getRel_def on_triple_def Image_def graph_union_def insert_absorb)
    then show ?case by auto
  qed
qed (insert translation_right_to_left,auto)

abbreviation transl_rule ::
    "'a sentence \<Rightarrow> ('a, nat) labeled_graph \<times> ('a, nat) labeled_graph" where
"transl_rule R \<equiv> (translation (fst R),translation (snd R))"

text \<open>Lemma 6.\<close>
lemma maintained_holds_iff:
  assumes "graph G"
  shows "maintained (translation e\<^sub>L,translation (A_Int e\<^sub>L e\<^sub>R)) G \<longleftrightarrow> G \<Turnstile> e\<^sub>L \<sqsubseteq> e\<^sub>R" (is "?rhs = ?lhs")
proof
  assume lhs:?lhs
  show ?rhs unfolding maintained_def proof(clarify) fix f
    assume f:"graph_homomorphism (fst (translation e\<^sub>L, translation (A_Int e\<^sub>L e\<^sub>R))) G f"
    then obtain x y where f2:"(0,x) \<in> f" "(1,y) \<in> f" unfolding graph_homomorphism_def
      by (metis DomainE One_nat_def prod.sel(1) verts_in_translation_finite(3,4))
    with f have "(x,y) \<in> :G:\<lbrakk>fst (e\<^sub>L \<sqsubseteq> e\<^sub>R)\<rbrakk>" unfolding translation[OF assms] by auto
    with lhs have "(x,y) \<in> :G:\<lbrakk>snd (e\<^sub>L \<sqsubseteq> e\<^sub>R)\<rbrakk>" by auto
    then obtain g where g: "graph_homomorphism (translation (A_Int e\<^sub>L e\<^sub>R)) G g"
                   and g2: "(0, x) \<in> g" "(1, y) \<in> g" unfolding translation[OF assms] by auto
    have v:"vertices (translation (A_Int e\<^sub>L e\<^sub>R)) = Domain g"
           "vertices (translation e\<^sub>L) = Domain f" using f g
      unfolding graph_homomorphism_def by auto
    from subgraph_subset[of "translation e\<^sub>L" "translation (A_Int e\<^sub>L e\<^sub>R)"]
         graph_rule_translation[of e\<^sub>L e\<^sub>R]
    have dom_sub: "Domain f \<subseteq> Domain g"
      using v unfolding prod.sel by argo
    hence dom_le:"card (Domain f) \<le> card (Domain g)"
      by (metis card.infinite card_mono inv_tr_card_min not_less rel_simps(51) v(1) verts_in_translation)
    have c_f:"card (Domain f) \<ge> 2" using inv_tr_card_min[OF verts_in_translation] v by metis
    from f[unfolded graph_homomorphism_def]
    have ep_f:"edge_preserving f (edges (translation e\<^sub>L)) (edges G)"
     and uni_f:"univalent f" by auto
    let ?f = "(\<lambda>x. if x < 2 then x else x + card (vertices (translation e\<^sub>L)) - 2)"
    define GR where "GR = map_graph_fn (translation e\<^sub>R) ?f"
    from g[unfolded graph_homomorphism_def]
    have "edge_preserving g (edges (translation (A_Int e\<^sub>L e\<^sub>R))) (edges G)"
     and uni_g:"univalent g" by auto
    from edge_preserving_subset[OF subset_refl _ this(1)]
    have ep_g:"edge_preserving g (edges GR) (edges G)" by (auto simp:Let_def GR_def)
    { fix a assume a:"a \<in> vertices (translation e\<^sub>R)"
      hence "?f a \<in> vertices (translation (A_Int e\<^sub>L e\<^sub>R))" by (auto simp:Let_def)
      from this[unfolded v] verts_in_translation[of "A_Int e\<^sub>L e\<^sub>R",unfolded inv_translation_def v]
      have "\<not> a < 2 \<Longrightarrow> a + card (Domain f) - 2 < card (Domain g)" by auto
    } note[intro!] = this
    have [intro!]: " \<not> aa < 2 \<Longrightarrow> card (Domain f) \<le> aa + card (Domain f) - 2" for aa by simp
    from v(2) restrictD[OF translation_graph[of e\<^sub>L]]
    have df[dest]:"xa \<notin> Domain f \<Longrightarrow> (l,xa,xb) \<in> edges (translation e\<^sub>L) \<Longrightarrow> False"
                  "xa \<notin> Domain f \<Longrightarrow> (l,xb,xa) \<in> edges (translation e\<^sub>L) \<Longrightarrow> False"
                  for xa l xb unfolding edge_preserving by auto
    { fix l xa xb ya
      assume assm: "(l,xa,xb) \<in> edges GR"
      with c_f dom_le
      have "xa \<in> {0,1} \<union> {card (Domain f)..<card (Domain g)}"
           "xb \<in> {0,1} \<union> {card (Domain f)..<card (Domain g)}"
        unfolding GR_def v by auto
      hence minb:"xa \<in> {0,1} \<or> xa \<ge> card (Domain f)" "xb \<in> {0,1} \<or> xb \<ge> card (Domain f)"
        by auto
      { fix z xa assume minb:"xa \<in> {0,1} \<or> xa \<ge> card (Domain f)" and z:"(xa,z) \<in> f"
        from z verts_in_translation[of e\<^sub>L,unfolded inv_translation_def v]
        have "xa < card(Domain f)" by auto
        with minb verts_in_translation[of "A_Int e\<^sub>L e\<^sub>R",unfolded inv_translation_def v]
        have x:"xa \<in> {0,1} \<and> xa \<in> Domain g" by auto
        then obtain v where g:"(xa,v) \<in> g" by auto
        consider "xa = 0 \<and> z = x" | "xa = 1 \<and> z = y"
          using x f2[THEN univalentD[OF uni_f]] z by auto
        hence "v = z" using g g2[THEN univalentD[OF uni_g]] by metis
        hence "(xa,z) \<in> g" using g by auto
      }
      note minb[THEN this]
    }
    with f2 g2[THEN univalentD[OF uni_g]]
    have dg:"(l,xa,xb) \<in> edges GR \<Longrightarrow> (xa,ya) \<in> f \<Longrightarrow> (xa,ya) \<in> g"
            "(l,xb,xa) \<in> edges GR \<Longrightarrow> (xa,ya) \<in> f \<Longrightarrow> (xa,ya) \<in> g"
            for xa l xb ya
      unfolding edge_preserving by (auto)
    have "vertices (translation e\<^sub>L) \<subseteq> vertices (translation (A_Int e\<^sub>L e\<^sub>R))"
      by(rule subgraph_subset,insert graph_rule_translation,auto)
    hence subdom:"Domain f \<subseteq> Domain g" unfolding v.
    let ?g = "f \<union> (Id_on (UNIV - Domain f) O g)"
    have [simp]:"Domain ?g = Domain g" using subdom unfolding Domain_Un_eq by auto
    have ih:"graph_homomorphism (translation (A_Int e\<^sub>L e\<^sub>R)) G ?g"
    proof(rule graph_homomorphismI)
      show "?g `` vertices (translation (A_Int e\<^sub>L e\<^sub>R)) \<subseteq> vertices G"
        using g[unfolded graph_homomorphism_def] f[unfolded graph_homomorphism_def]
        by (auto simp: v simp del:translation.simps)
      show "edge_preserving ?g (edges (translation (A_Int e\<^sub>L e\<^sub>R))) (edges G)"
        unfolding Let_def translation.simps graph_union_edges proof
        show "edge_preserving ?g (edges (translation e\<^sub>L)) (edges G)"
          using edge_preserving_atomic[OF ep_f] unfolding edge_preserving by auto
        have "edge_preserving ?g (edges GR) (edges G)"
          using edge_preserving_atomic[OF ep_g] dg unfolding edge_preserving by (auto;blast)
        thus "edge_preserving ?g (edges (map_graph_fn (translation e\<^sub>R) ?f)) (edges G)"
          by (auto simp:GR_def)
        qed
    qed (insert f[unfolded graph_homomorphism_def] g[unfolded graph_homomorphism_def],auto simp:Let_def)
    have ie:"agree_on (translation e\<^sub>L) f ?g" unfolding agree_on_def by (auto simp:v)
    from ie ih show "extensible (translation e\<^sub>L, translation (A_Int e\<^sub>L e\<^sub>R)) G f"
      unfolding extensible_def prod.sel by auto
  qed next
  assume rhs:?rhs
  { fix x y assume "(x,y) \<in> :G:\<lbrakk>e\<^sub>L\<rbrakk>"
    with translation[OF assms] obtain f
      where f:"graph_homomorphism (fst (translation e\<^sub>L, translation (A_Int e\<^sub>L e\<^sub>R))) G f"
              "(0, x) \<in> f" "(1, y) \<in> f" by auto
    with rhs[unfolded maintained_def,rule_format,OF f(1),unfolded extensible_def]
    obtain g where g:"graph_homomorphism (translation (A_Int e\<^sub>L e\<^sub>R)) G g"
                     "agree_on (translation e\<^sub>L) f g" by auto
    hence "(x,y) \<in> :G:\<lbrakk>A_Int e\<^sub>L e\<^sub>R\<rbrakk>" using f unfolding agree_on_def translation[OF assms] by auto
  }
  thus ?lhs by auto
qed

lemma translation_self[intro]:
"(0, 1) \<in> :translation e:\<lbrakk>e\<rbrakk>"
proof(induct e)
  case (A_Int e1 e2)
  let ?f = "(\<lambda>x. if x < 2 then x else x + card (vertices (translation e1)) - 2)"
  have f: "(?f 0,?f 1) \<in>:map_graph_fn (translation e2) ?f:\<lbrakk>e2\<rbrakk>"
    using map_graph_in[OF translation_graph A_Int(2),of ?f] by auto
  let ?G = "graph_union (translation e1) (map_graph_fn (translation e2) ?f)"
  have "{(0,1)} \<subseteq> :(translation e1):\<lbrakk>e1\<rbrakk>" using A_Int by auto
  moreover have "{(0,1)} \<subseteq> :map_graph_fn (translation e2) ?f:\<lbrakk>e2\<rbrakk>" using f by auto
  moreover have ":map_graph_fn (translation e2) ?f:\<lbrakk>e2\<rbrakk> \<subseteq> :?G:\<lbrakk>e2\<rbrakk>" ":translation e1:\<lbrakk>e1\<rbrakk> \<subseteq> :?G:\<lbrakk>e1\<rbrakk>"
    using graph_union_semantics by blast+
  ultimately show ?case by (auto simp:Let_def)
next
  case (A_Cmp e1 e2)
  let ?f1 = "\<lambda>x. if x = 0 then 0 else x + card (vertices (translation e2)) - 1"
  have f1: "(?f1 0,?f1 1) \<in>:map_graph_fn (translation e1) ?f1:\<lbrakk>e1\<rbrakk>"
    using map_graph_in[OF translation_graph A_Cmp(1),of ?f1] by auto
  let ?f2 = "\<lambda>x. if x = 0 then card (vertices (translation e2)) else x"
  have f2: "(?f2 0,?f2 1) \<in>:map_graph_fn (translation e2) ?f2:\<lbrakk>e2\<rbrakk>"
    using map_graph_in[OF translation_graph A_Cmp(2),of ?f2] by auto
  let ?G = "graph_union (map_graph_fn (translation e1) ?f1) (map_graph_fn (translation e2) ?f2)"
  have "{(0,1)} = {(0,card (vertices (translation e2)))} O {(card (vertices (translation e2)),1)}"
    by auto
  also have "{(0,card (vertices (translation e2)))} \<subseteq> :map_graph_fn (translation e1) ?f1:\<lbrakk>e1\<rbrakk>"
    using f1 by auto
  also have ":map_graph_fn (translation e1) ?f1:\<lbrakk>e1\<rbrakk> \<subseteq> :?G:\<lbrakk>e1\<rbrakk>"
    using graph_union_semantics by auto
  also have "{(card (vertices (translation e2)),1)} \<subseteq> :map_graph_fn (translation e2) ?f2:\<lbrakk>e2\<rbrakk>"
    using f2 by auto
  also have ":map_graph_fn (translation e2) ?f2:\<lbrakk>e2\<rbrakk> \<subseteq> :?G:\<lbrakk>e2\<rbrakk>"
    using graph_union_semantics by blast
  also have "(:?G:\<lbrakk>e1\<rbrakk>) O (:?G:\<lbrakk>e2\<rbrakk>) = :translation (A_Cmp e1 e2):\<lbrakk>A_Cmp e1 e2\<rbrakk>"
    by (auto simp:Let_def)
  finally show ?case by auto
next
  case (A_Cnv e)
  from map_graph_in[OF translation_graph this,of "(\<lambda>x. if x < (2::nat) then 1 - x else x)"]
  show ?case using map_graph_in[OF translation_graph] by auto
qed (simp add:getRel_def)

text \<open>Lemma 6 is only used on rules of the form @{term "e\<^sub>L \<sqsubseteq> e\<^sub>R"}.
      The requirement of G being a graph can be dropped for one direction.\<close>
lemma maintained_holds[intro]:
  assumes ":G:\<lbrakk>e\<^sub>L\<rbrakk> \<subseteq> :G:\<lbrakk>e\<^sub>R\<rbrakk>"
  shows "maintained (transl_rule (e\<^sub>L \<sqsubseteq> e\<^sub>R)) G"
proof (cases "graph G")
  case True
  thus ?thesis using assms sentence_iff maintained_holds_iff prod.sel by metis
next
  case False
  thus ?thesis by (auto simp:maintained_def graph_homomorphism_def)
qed

lemma maintained_holds_subset_iff[simp]:
  assumes "graph G"
  shows "maintained (transl_rule (e\<^sub>L \<sqsubseteq> e\<^sub>R)) G \<longleftrightarrow> (:G:\<lbrakk>e\<^sub>L\<rbrakk> \<subseteq> :G:\<lbrakk>e\<^sub>R\<rbrakk>)"
  using assms maintained_holds_iff sentence_iff prod.sel by metis

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_26
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun y :: "'a list => 'a list => 'a list" where
  "y (nil2) y2 = y2"
| "y (cons2 z2 xs) y2 = cons2 z2 (y xs y2)"

fun x :: "Nat => Nat => bool" where
  "x (Z) (Z) = True"
| "x (Z) (S z2) = False"
| "x (S x2) (Z) = False"
| "x (S x2) (S y22) = x x2 y22"

fun elem :: "Nat => Nat list => bool" where
  "elem z (nil2) = False"
| "elem z (cons2 z2 xs) = (if x z z2 then True else elem z xs)"

theorem property0 :
  "((elem z xs) ==> (elem z (y xs ys)))"
  find_proof DInd
  apply (induct arbitrary: ys rule: elem.induct)
  apply auto
  done

theorem property0' :
  "((elem z xs) ==> (elem z (y xs ys)))"
  (*Why induction on "xs"?
    Because "elem" is the only recursive function in the premise, which pattern-matches on the
    second parameter, which is "xs" in this case.
    Furthermore, the innermost recursive function "y" is pattern-matches on the first parameter,
    which is "xs" in this case.*)
  apply(induct xs)
  apply auto
  done

theorem property0 :
  "((elem z xs) ==> (elem z (y xs ys)))"
  apply (induct arbitrary: ys rule: y.induct)
   apply (induct z)
  apply(induct_tac y2)
  nitpick
  oops

end


(*  Title:      HOL/Nitpick_Examples/Induct_Nits.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2009-2011

Examples featuring Nitpick applied to (co)inductive definitions.
*)

section \<open>Examples Featuring Nitpick Applied to (Co)inductive Definitions\<close>

theory Induct_Nits
imports Main
begin

nitpick_params [verbose, card = 1-8, unary_ints,
                sat_solver = MiniSat, max_threads = 1, timeout = 240]

inductive p1 :: "nat \<Rightarrow> bool" where
"p1 0" |
"p1 n \<Longrightarrow> p1 (n + 2)"

coinductive q1 :: "nat \<Rightarrow> bool" where
"q1 0" |
"q1 n \<Longrightarrow> q1 (n + 2)"

lemma "p1 = q1"
nitpick [expect = none]
nitpick [wf, expect = none]
nitpick [non_wf, expect = none]
nitpick [non_wf, dont_star_linear_preds, expect = none]
oops

lemma "p1 \<noteq> q1"
nitpick [expect = potential]
nitpick [wf, expect = potential]
nitpick [non_wf, expect = potential]
nitpick [non_wf, dont_star_linear_preds, expect = potential]
oops

lemma "p1 (n - 2) \<Longrightarrow> p1 n"
nitpick [expect = genuine]
nitpick [non_wf, expect = genuine]
nitpick [non_wf, dont_star_linear_preds, expect = genuine]
oops

lemma "q1 (n - 2) \<Longrightarrow> q1 n"
nitpick [expect = genuine]
nitpick [non_wf, expect = genuine]
nitpick [non_wf, dont_star_linear_preds, expect = genuine]
oops

inductive p2 :: "nat \<Rightarrow> bool" where
"p2 n \<Longrightarrow> p2 n"

coinductive q2 :: "nat \<Rightarrow> bool" where
"q2 n \<Longrightarrow> q2 n"

lemma "p2 = bot"
nitpick [expect = none]
nitpick [dont_star_linear_preds, expect = none]
sorry

lemma "q2 = bot"
nitpick [expect = genuine]
nitpick [dont_star_linear_preds, expect = genuine]
nitpick [wf, expect = quasi_genuine]
oops

lemma "p2 = top"
nitpick [expect = genuine]
nitpick [dont_star_linear_preds, expect = genuine]
oops

lemma "q2 = top"
nitpick [expect = none]
nitpick [dont_star_linear_preds, expect = none]
nitpick [wf, expect = quasi_genuine]
sorry

lemma "p2 = q2"
nitpick [expect = genuine]
nitpick [dont_star_linear_preds, expect = genuine]
oops

lemma "p2 n"
nitpick [expect = genuine]
nitpick [dont_star_linear_preds, expect = genuine]
nitpick [dont_specialize, expect = genuine]
oops

lemma "q2 n"
nitpick [expect = none]
nitpick [dont_star_linear_preds, expect = none]
sorry

lemma "\<not> p2 n"
nitpick [expect = none]
nitpick [dont_star_linear_preds, expect = none]
sorry

lemma "\<not> q2 n"
nitpick [expect = genuine]
nitpick [dont_star_linear_preds, expect = genuine]
nitpick [dont_specialize, expect = genuine]
oops

inductive p3 and p4 where
"p3 0" |
"p3 n \<Longrightarrow> p4 (Suc n)" |
"p4 n \<Longrightarrow> p3 (Suc n)"

coinductive q3 and q4 where
"q3 0" |
"q3 n \<Longrightarrow> q4 (Suc n)" |
"q4 n \<Longrightarrow> q3 (Suc n)"

lemma "p3 = q3"
nitpick [expect = none]
nitpick [non_wf, expect = none]
sorry

lemma "p4 = q4"
nitpick [expect = none]
nitpick [non_wf, expect = none]
sorry

lemma "p3 = top - p4"
nitpick [expect = none]
nitpick [non_wf, expect = none]
sorry

lemma "q3 = top - q4"
nitpick [expect = none]
nitpick [non_wf, expect = none]
sorry

lemma "inf p3 q4 \<noteq> bot"
nitpick [expect = potential]
nitpick [non_wf, expect = potential]
sorry

lemma "inf q3 p4 \<noteq> bot"
nitpick [expect = potential]
nitpick [non_wf, expect = potential]
sorry

lemma "sup p3 q4 \<noteq> top"
nitpick [expect = potential]
nitpick [non_wf, expect = potential]
sorry

lemma "sup q3 p4 \<noteq> top"
nitpick [expect = potential]
nitpick [non_wf, expect = potential]
sorry

end


theory Tutorial
  imports Main
begin

text \<open>This is essentially a clone of \<open>cookbook/src/proofs/finite/Finite.thy\<close> in the cookbook
\<^url>\<open>https://github.com/isabelle-prover/cookbook/blob/master/src/proofs/finite/Finite.thy\<close>.\<close>

section \<open>Lemmas For Proving Finiteness of Sets\<close>

text \<open>In an Isar proof, these two are typically your silver bullets for proving the finiteness
of sets:\<close>
lemmas finite_helpers = finite_imageI finite_subset

text \<open>Some more helpful lemmas:\<close>
lemmas more_finite_helpers = finite_cartesian_product finite_vimageI finite_Un

\<comment> \<open>Example:\<close>
lemma
  "finite {x + y | x y :: nat. x < n \<and> y \<in> {0..3} \<and> x \<noteq> y}" (is "finite ?S")
proof -
  have "?S \<subseteq> (\<lambda>(x, y). x + y) ` ({0..<n} \<times> {0..3})"
    by auto
  also have "finite \<dots>"
    \<comment> \<open>This is just to show what is going on: \<open>by simp\<close> would also do the job.\<close>
    by (intro finite_imageI finite_cartesian_product finite_atLeastLessThan finite_atLeastAtMost)
  finally (finite_subset) show ?thesis .
    \<comment> \<open>Instead of giving @{thm finite_subset} explicitly, we could also have declared it like this:
        \<^verbatim>\<open>lemmas [trans] = finite_subset\<close>.\<close>
qed

text \<open>
  For automated proofs, it can often help to just pass these with the \<^verbatim>\<open>intro\<close> modifier
  to @{method auto} and friends.
  The theorem @{thm finite_imageI} is set up as an default, but it can help to add \<^verbatim>\<open>intro!\<close>.
  Have a look at the example of the end of the file, to see both theorems in action in an
  automated proof.
\<close>

section \<open>Simproc \<^verbatim>\<open>finite_Collect\<close>\<close>
text \<open>
  The simproc \<^verbatim>\<open>finite_Collect\<close> can be used to solve certain finiteness proof oblgations.
  Essentially, the simproc attempts to rewrite set comprehensions to terms that consist
  of applications @{term image}, @{term vimage}, @{term "(\<inter>)"},
  and @{term "(\<times>)"} as far as possible.
  Below is an example from @{theory HOL.Relation}.
\<close>
lemma "finite (r\<inverse>) = finite r"
  unfolding converse_def conversep_iff using [[simproc add: finite_Collect]]
  apply simp \<comment> \<open>The set was rewritten to an application of @{term image}.\<close>
  by (auto elim: finite_imageD simp: inj_on_def)

section \<open>Tuning The Simplifier For Finiteness Proofs\<close>

subsection \<open>Rewriting to Images\<close>
text \<open>
  One useful technique is to rewrite set comprehensions to images of sets under functions as far as
  possible by passing @{thm setcompr_eq_image} or its \<open>n\<close>-ary generalizations to the simplifier.
\<close>

text \<open>Here is the \<open>2\<close>-ary generalization of @{thm setcompr_eq_image}.\<close>
lemma setcompr_eq_image2:
  "{f x y | x y. P x y} = (\<lambda>(x, y). f x y) ` {(x, y). P x y}"
  using setcompr_eq_image[where f = "(\<lambda>(x, y). f x y)" and P = "\<lambda>(x, y). P x y"] by simp

text \<open>In this example, \<^verbatim>\<open>finite_Collect\<close> still does the right thing:\<close>
lemma
  assumes "finite A"
  shows "finite {f x | x. x \<in> A \<and> P x}"
  using assms [[simproc add: finite_Collect]] by simp

text \<open>Here, however, it will produce quite a mess:\<close>
lemma
  assumes "finite (A \<times> B)"
  shows "finite {f x y | x y. x \<in> A \<and> y \<in> B \<and> R x y}"
  using assms [[simproc add: finite_Collect]]
  apply simp
  oops

text \<open>Instead, we use @{thm setcompr_eq_image2} to an image:\<close>
lemma
  assumes "finite (A \<times> B)"
  shows "finite {f x y | x y. x \<in> A \<and> y \<in> B \<and> R x y}"
  using assms
  apply (simp add: setcompr_eq_image2) \<comment> \<open>Looks much better.\<close>
  \<comment> \<open>\<^verbatim>\<open>auto\<close> will apply the following theorems to solve the goal:\<close>
  thm finite_imageI finite_subset[rotated]
  \<comment> \<open>We rotate @{thm finite_subset} to use it as an \<open>elim\<close>-rule\<close>
  apply (auto elim: finite_subset[rotated])
  done

subsection \<open>Finiteness With Context\<close>
text \<open>The theorem @{thm finite_Collect_bounded_ex} (and its obvious \<open>n\<close>-ary generalizations)
can be highly useful for proving finiteness of sets where some of the finiteness theorems
one wants to apply rely on a precondition to hold. Consider the following example:\<close>
lemma
  "finite {s'. \<exists>s. Some s = x \<and> Some s' = g s}" \<comment> \<open>Clearly there is at most one such \<open>s'\<close>.\<close>
proof -
  \<comment> \<open>The statement follows quite immediately from this lemma.\<close>
  have Some_finite: "finite {x. Some x = y}" for y :: "'x option"
    using not_finite_existsD by fastforce
  show ?thesis
    \<comment> \<open>Something like this will not work, however:\<close>
    \<comment> \<open>apply (auto intro: Some_finite)\<close>
    \<comment> \<open>The reason is that we need \<^emph>\<open>context\<close>.
    The argument should go along the lines: there are only finitely such \<open>s\<close>,
    and for each \<open>s\<close> there are only finitely many such \<open>s'\<close>, thus the whole set is finite.\<close>
    apply (subst finite_Collect_bounded_ex) \<comment> \<open>this gives us what we want\<close>
    apply (intro allI impI Some_finite)+
    done
qed

subsection \<open>Advanced Examples Of Proving Finiteness With the Simplifier\<close>

text \<open>The simplifier can sometimes be surprisingly good at solving finiteness goals.
Here is an example:\<close>
lemma
  assumes "finite A" "finite (Collect P)"
  shows "finite {(a,b,c) | a b c. a \<in> A \<and> b < (n :: nat) \<and> P c}"
  using assms [[simproc add: finite_Collect]] by simp

text \<open>This shows what is going on here:\<close>
lemma
  assumes "finite A" "finite (Collect P)"
  shows "finite {(a,b,c) | a b c. a \<in> A \<and> b < (n :: nat) \<and> P c}"
  using [[simproc add: finite_Collect]] apply simp
  apply (intro finite_SigmaI finite_Collect_less_nat assms)
  done

text \<open>A slightly more complicated variant:\<close>
lemma
  assumes "finite A" "finite (Collect P)"
  shows "finite {(d, c, a, b) | a b c d. d < (n :: nat) \<and> P c \<and> (a, b) \<in> A}"
  using assms [[simproc add: finite_Collect]] by simp

text \<open>Here is a more involved example:\<close>
lemma
  fixes n :: nat
  assumes "finite A"
  shows "finite {t. \<exists> a c. a \<in> A \<and> c < n \<and> t = (a,c)}"
  using assms by simp

text \<open>Here is an explanation of what is going on:\<close>
lemma
  fixes n :: nat
  assumes "finite A"
  shows "finite {t. \<exists> a c. a \<in> A \<and> c < n \<and> t = (a,c)}"
  apply simp \<comment> \<open>First the simplifier applies some specific procedures for miniscoping\<close>
  apply (subst finite_Collect_bounded_ex) \<comment> \<open>Now, the context rule comes in\<close>
   apply (subst Collect_mem_eq, rule assms) \<comment> \<open>Solve first subgoal\<close>

  supply [simp del] = finite_Collect_bounded_ex
  apply(intro allI impI)
    \<comment> \<open>The simplifier walks down the propositional connectives using congruence rules\<close>
  apply (subst finite_Collect_bounded_ex) \<comment> \<open>Another application of the congruence rule\<close>
  apply (rule finite_Collect_less_nat) \<comment> \<open>Solve first subgoal\<close>
  apply (simp only: singleton_conv) \<comment> \<open>Rewrite to singleton set\<close>
  apply simp \<comment> \<open>The rest is trivial\<close>
  done

section \<open>Further Pointers\<close>
text \<open>For more examples and an attempt at an proof method for finiteness proof obligations,
see \<^url>\<open>https://github.com/wimmers/isabelle-finite\<close>.
It also contains the \<open>n\<close>-ary generalizations of @{thm setcompr_eq_image}
and @{thm finite_Collect_bounded_ex}.\<close>

end


theory Matrix_Invertable
  imports Jordan_Normal_Form.Determinant
  Smith_Normal_Form.SNF_Missing_Lemmas
begin

lemma invertible_right_inverse1:
  fixes A :: "'a::{semiring_1, comm_ring_1} mat"
  assumes "A \<in> carrier_mat n n"
  shows "invertible_mat A \<longleftrightarrow> (\<exists>B \<in> carrier_mat n n. A * B = 1\<^sub>m n)"
  by (metis (no_types, lifting) Determinant.det_mult assms det_one dvdI
      invertible_iff_is_unit_JNF  inverts_mat_def left_mult_one_mat
      obtain_inverse_matrix one_carrier_mat similar_mat_witD(2) similar_mat_wit_refl)

lemma  invertible_det_nz1:
  fixes A::"'a::field mat"
  assumes "A \<in> carrier_mat n n"
  shows "invertible_mat A \<longleftrightarrow> det A \<noteq> 0"
proof(cases "n=0")
  case True
  then show ?thesis
    using assms invertible_mat_zero by auto
next
  case False
  then show ?thesis
  using invertible_det_nz[untransferred, cancel_card_constraint, of A n]
  assms
  by fast
qed

proposition  cramer1:
  fixes A::"'a::field mat"
  assumes "A \<in> carrier_mat n n"
  assumes "b \<in> carrier_vec n"
  assumes "x \<in> carrier_vec n"
  assumes d0: "det A \<noteq> 0"
  shows "A *\<^sub>v x = b \<longleftrightarrow> x = vec n (\<lambda> k. det (replace_col A b k) / det A)"
proof -
  from d0 obtain B where B: "B \<in> carrier_mat n n" "A * B = 1\<^sub>m n" "B * A = 1\<^sub>m n"
    unfolding invertible_det_nz1[symmetric] invertible_mat_def
    by (meson Determinant.mat_mult_left_right_inverse
        \<open>\<And>n A. A \<in> carrier_mat n n \<Longrightarrow> (Determinant.det A \<noteq> 0) = invertible_mat A\<close> assms(1)
        invertible_right_inverse1)
  have "(A * B) *\<^sub>v b = b"
    by (simp add: B assms(2))
  then have "A *\<^sub>v (B *\<^sub>v b) = b"
    using B(1) assms(1) assms(2) by force
  then have xe: "\<exists>x. A *\<^sub>v x = b"
    by blast
  {
    fix x
    assume x: "A *\<^sub>v x = b"
    assume "x \<in> carrier_vec n"
    have "x = vec n (\<lambda> k. det (replace_col A b k) / det A)"
      unfolding x[symmetric]
      using d0
      by (auto simp: vec_eq_iff cramer_lemma_mat[of A n x] field_simps assms `x \<in> carrier_vec n`)
  }
  with xe show ?thesis
    using \<open>\<And>xa. \<lbrakk>A *\<^sub>v xa = b; xa \<in> carrier_vec n\<rbrakk> \<Longrightarrow>
          xa = Matrix.vec n (\<lambda>k. Determinant.det (replace_col A b k) / Determinant.det A)\<close> assms(3)
    by (metis B(1) \<open>A *\<^sub>v (B *\<^sub>v b) = b\<close> assms(2) mult_mat_vec_carrier)
qed

end


section\<open>Ternary Logic\<close>
theory Ternary
imports Main
begin

text\<open>Kleene logic\<close>

datatype ternaryvalue = TernaryTrue | TernaryFalse | TernaryUnknown
datatype ternaryformula = TernaryAnd ternaryformula ternaryformula
                        | TernaryOr ternaryformula ternaryformula
                        | TernaryNot ternaryformula
                        | TernaryValue ternaryvalue

fun ternary_to_bool :: "ternaryvalue \<Rightarrow> bool option" where
  "ternary_to_bool TernaryTrue = Some True" |
  "ternary_to_bool TernaryFalse = Some False" |
  "ternary_to_bool TernaryUnknown = None"

fun bool_to_ternary :: "bool \<Rightarrow> ternaryvalue" where
  "bool_to_ternary True = TernaryTrue" |
  "bool_to_ternary False = TernaryFalse"

lemma "the \<circ> ternary_to_bool \<circ> bool_to_ternary = id"
  by(simp add: fun_eq_iff, clarify, case_tac x, simp_all)
lemma ternary_to_bool_bool_to_ternary: "ternary_to_bool (bool_to_ternary X) = Some X"
by(cases X, simp_all)
lemma ternary_to_bool_None: "ternary_to_bool t = None \<longleftrightarrow> t = TernaryUnknown"
  by(cases t, simp_all)
lemma ternary_to_bool_SomeE: "ternary_to_bool t = Some X \<Longrightarrow>
  (t = TernaryTrue \<Longrightarrow> X = True \<Longrightarrow> P) \<Longrightarrow> (t = TernaryFalse \<Longrightarrow> X = False \<Longrightarrow> P)  \<Longrightarrow> P"
  by(cases t)(simp)+
lemma ternary_to_bool_Some: "ternary_to_bool t = Some X \<longleftrightarrow>
  (t = TernaryTrue \<and> X = True) \<or> (t = TernaryFalse \<and> X = False)"
  by(cases t, simp_all)
lemma bool_to_ternary_Unknown: "bool_to_ternary t = TernaryUnknown \<longleftrightarrow> False"
by(cases t, simp_all)

fun eval_ternary_And :: "ternaryvalue \<Rightarrow> ternaryvalue \<Rightarrow> ternaryvalue" where
  "eval_ternary_And TernaryTrue TernaryTrue = TernaryTrue" |
  "eval_ternary_And TernaryTrue TernaryFalse = TernaryFalse" |
  "eval_ternary_And TernaryFalse TernaryTrue = TernaryFalse" |
  "eval_ternary_And TernaryFalse TernaryFalse = TernaryFalse" |
  "eval_ternary_And TernaryFalse TernaryUnknown = TernaryFalse" |
  "eval_ternary_And TernaryTrue TernaryUnknown = TernaryUnknown" |
  "eval_ternary_And TernaryUnknown TernaryFalse = TernaryFalse" |
  "eval_ternary_And TernaryUnknown TernaryTrue = TernaryUnknown"  |
  "eval_ternary_And TernaryUnknown TernaryUnknown = TernaryUnknown"

lemma eval_ternary_And_comm: "eval_ternary_And t1 t2 = eval_ternary_And t2 t1"
  by (cases t1 t2 rule: ternaryvalue.exhaust[case_product ternaryvalue.exhaust]) auto

fun eval_ternary_Or :: "ternaryvalue \<Rightarrow> ternaryvalue \<Rightarrow> ternaryvalue" where
  "eval_ternary_Or TernaryTrue TernaryTrue = TernaryTrue" |
  "eval_ternary_Or TernaryTrue TernaryFalse = TernaryTrue" |
  "eval_ternary_Or TernaryFalse TernaryTrue = TernaryTrue" |
  "eval_ternary_Or TernaryFalse TernaryFalse = TernaryFalse" |
  "eval_ternary_Or TernaryTrue TernaryUnknown = TernaryTrue" |
  "eval_ternary_Or TernaryFalse TernaryUnknown = TernaryUnknown" |
  "eval_ternary_Or TernaryUnknown TernaryTrue = TernaryTrue" |
  "eval_ternary_Or TernaryUnknown TernaryFalse = TernaryUnknown" |
  "eval_ternary_Or TernaryUnknown TernaryUnknown = TernaryUnknown"

fun eval_ternary_Not :: "ternaryvalue \<Rightarrow>  ternaryvalue" where
  "eval_ternary_Not TernaryTrue = TernaryFalse" |
  "eval_ternary_Not TernaryFalse = TernaryTrue" |
  "eval_ternary_Not TernaryUnknown = TernaryUnknown"

text\<open>Just to hint that we did not make a typo, we add the truth table for
      the implication and show that it is compliant with @{term "a \<longrightarrow> b \<longleftrightarrow> \<not>a \<or> b"}\<close>
fun eval_ternary_Imp :: "ternaryvalue \<Rightarrow> ternaryvalue \<Rightarrow> ternaryvalue" where
  "eval_ternary_Imp TernaryTrue TernaryTrue = TernaryTrue" |
  "eval_ternary_Imp TernaryTrue TernaryFalse = TernaryFalse" |
  "eval_ternary_Imp TernaryFalse TernaryTrue = TernaryTrue" |
  "eval_ternary_Imp TernaryFalse TernaryFalse = TernaryTrue" |
  "eval_ternary_Imp TernaryTrue TernaryUnknown = TernaryUnknown" |
  "eval_ternary_Imp TernaryFalse TernaryUnknown = TernaryTrue" |
  "eval_ternary_Imp TernaryUnknown TernaryTrue = TernaryTrue" |
  "eval_ternary_Imp TernaryUnknown TernaryFalse = TernaryUnknown" |
  "eval_ternary_Imp TernaryUnknown TernaryUnknown = TernaryUnknown"
lemma "eval_ternary_Imp a b = eval_ternary_Or (eval_ternary_Not a) b"
apply(cases a)
  apply(case_tac [!] b)
        apply(simp_all)
done

lemma eval_ternary_Not_UnknownD: "eval_ternary_Not t = TernaryUnknown \<Longrightarrow> t = TernaryUnknown"
  by (cases t) auto

lemma eval_ternary_DeMorgan:
  "eval_ternary_Not (eval_ternary_And a b) = eval_ternary_Or (eval_ternary_Not a) (eval_ternary_Not b)"
  "eval_ternary_Not (eval_ternary_Or a b) = eval_ternary_And (eval_ternary_Not a) (eval_ternary_Not b)"
  by (cases a b rule: ternaryvalue.exhaust[case_product ternaryvalue.exhaust],auto)+

lemma eval_ternary_idempotence_Not: "eval_ternary_Not (eval_ternary_Not a) = a"
  by (cases a) simp_all

lemma eval_ternary_simps_simple:
  "eval_ternary_And TernaryTrue x = x"
  "eval_ternary_And x TernaryTrue = x"
  "eval_ternary_And TernaryFalse x = TernaryFalse"
  "eval_ternary_And x TernaryFalse = TernaryFalse"
  by(case_tac [!] x)(simp_all)

context
begin
  private lemma bool_to_ternary_simp1: "bool_to_ternary X = TernaryTrue \<longleftrightarrow> X"
    by (metis bool_to_ternary.elims ternaryvalue.distinct(1))
  private lemma bool_to_ternary_simp2:  "bool_to_ternary Y = TernaryFalse \<longleftrightarrow> \<not> Y"
    by (metis bool_to_ternary.elims ternaryvalue.distinct(1))
  private lemma bool_to_ternary_simp3: "eval_ternary_Not (bool_to_ternary X) = TernaryTrue \<longleftrightarrow> \<not> X"
    by (metis (full_types) bool_to_ternary_simp2 eval_ternary_Not.simps(1) eval_ternary_idempotence_Not)
  private

  private lemma bool_to_ternary_simp6: "bool_to_ternary X \<noteq> TernaryUnknown"
    by (metis (full_types) bool_to_ternary.simps(1) bool_to_ternary.simps(2) ternaryvalue.distinct(3) ternaryvalue.distinct(5))

  lemmas bool_to_ternary_simps = bool_to_ternary_simp1 bool_to_ternary_simp2
                                 bool_to_ternary_simp3 bool_to_ternary_simp4
                                 bool_to_ternary_simp5 bool_to_ternary_simp6
end

context
begin
  private lemma bool_to_ternary_pullup1:
    "eval_ternary_Not (bool_to_ternary X) = bool_to_ternary (\<not> X)"
    by(cases X)(simp_all)

  private lemma bool_to_ternary_pullup2:
    "eval_ternary_And (bool_to_ternary X1) (bool_to_ternary X2) = bool_to_ternary (X1 \<and> X2)"
    by (metis bool_to_ternary_simps(1) bool_to_ternary_simps(2) eval_ternary_simps_simple(2) eval_ternary_simps_simple(4))

  private lemma bool_to_ternary_pullup3:
    "eval_ternary_Imp (bool_to_ternary X1) (bool_to_ternary X2) = bool_to_ternary (X1 \<longrightarrow> X2)"
    by (metis bool_to_ternary_simps(1) bool_to_ternary_simps(2) eval_ternary_Imp.simps(1)
        eval_ternary_Imp.simps(2) eval_ternary_Imp.simps(3) eval_ternary_Imp.simps(4))

  private lemma bool_to_ternary_pullup4:
    "eval_ternary_Or (bool_to_ternary X1) (bool_to_ternary X2) = bool_to_ternary (X1 \<or> X2)"
    by (metis (full_types) bool_to_ternary.simps(1) bool_to_ternary.simps(2) eval_ternary_Or.simps(1) eval_ternary_Or.simps(2) eval_ternary_Or.simps(3) eval_ternary_Or.simps(4))

  lemmas bool_to_ternary_pullup = bool_to_ternary_pullup1 bool_to_ternary_pullup2
                                  bool_to_ternary_pullup3 bool_to_ternary_pullup4
end

fun ternary_ternary_eval :: "ternaryformula \<Rightarrow> ternaryvalue" where
  "ternary_ternary_eval (TernaryAnd t1 t2) = eval_ternary_And (ternary_ternary_eval t1) (ternary_ternary_eval t2)" |
  "ternary_ternary_eval (TernaryOr t1 t2) = eval_ternary_Or (ternary_ternary_eval t1) (ternary_ternary_eval t2)" |
  "ternary_ternary_eval (TernaryNot t) = eval_ternary_Not (ternary_ternary_eval t)" |
  "ternary_ternary_eval (TernaryValue t) = t"

lemma ternary_ternary_eval_DeMorgan: "ternary_ternary_eval (TernaryNot (TernaryAnd a b)) =
    ternary_ternary_eval (TernaryOr (TernaryNot a) (TernaryNot b))"
by (simp add: eval_ternary_DeMorgan)

lemma ternary_ternary_eval_idempotence_Not:
  "ternary_ternary_eval (TernaryNot (TernaryNot a)) = ternary_ternary_eval a"
by (simp add: eval_ternary_idempotence_Not)

lemma ternary_ternary_eval_TernaryAnd_comm:
  "ternary_ternary_eval (TernaryAnd t1 t2) = ternary_ternary_eval (TernaryAnd t2 t1)"
by (simp add: eval_ternary_And_comm)

lemma "eval_ternary_Not (ternary_ternary_eval t) = (ternary_ternary_eval (TernaryNot t))" by simp

context
begin
  private lemma eval_ternary_simps_2:
      "eval_ternary_And (bool_to_ternary P) T = TernaryTrue \<longleftrightarrow> P \<and> T = TernaryTrue"
      "eval_ternary_And T (bool_to_ternary P) = TernaryTrue \<longleftrightarrow> P \<and> T = TernaryTrue"
  apply(case_tac [!] P)
     apply(simp_all add: eval_ternary_simps_simple)
  done

  private lemma eval_ternary_simps_3:
      "eval_ternary_And (ternary_ternary_eval x) T = TernaryTrue \<longleftrightarrow>
        ternary_ternary_eval x = TernaryTrue \<and> T = TernaryTrue"
      "eval_ternary_And T (ternary_ternary_eval x) = TernaryTrue \<longleftrightarrow>
        ternary_ternary_eval x = TernaryTrue \<and> T = TernaryTrue"
  apply(case_tac [!] T)
       apply(simp_all add: eval_ternary_simps_simple)
   apply(case_tac [!] "(ternary_ternary_eval x)")
       apply(simp_all)
  done

  lemmas eval_ternary_simps = eval_ternary_simps_simple eval_ternary_simps_2 eval_ternary_simps_3
end

definition ternary_eval :: "ternaryformula \<Rightarrow> bool option" where
  "ternary_eval t = ternary_to_bool (ternary_ternary_eval t)"

subsection\<open>Negation Normal Form\<close>

text\<open>A formula is in Negation Normal Form (NNF) if negations only occur at the atoms (not before and/or)\<close>
inductive NegationNormalForm :: "ternaryformula \<Rightarrow> bool" where
  "NegationNormalForm (TernaryValue v)" |
  "NegationNormalForm (TernaryNot (TernaryValue v))" |
  "NegationNormalForm \<phi> \<Longrightarrow> NegationNormalForm \<psi> \<Longrightarrow> NegationNormalForm (TernaryAnd \<phi> \<psi>)"|
  "NegationNormalForm \<phi> \<Longrightarrow> NegationNormalForm \<psi> \<Longrightarrow> NegationNormalForm (TernaryOr \<phi> \<psi>)"

text\<open>Convert a @{typ ternaryformula} to a  @{typ ternaryformula} in NNF.\<close>
fun NNF_ternary :: "ternaryformula \<Rightarrow> ternaryformula" where
  "NNF_ternary (TernaryValue v) = TernaryValue v" |
  "NNF_ternary (TernaryAnd t1 t2) = TernaryAnd (NNF_ternary t1) (NNF_ternary t2)" |
  "NNF_ternary (TernaryOr t1 t2) = TernaryOr (NNF_ternary t1) (NNF_ternary t2)" |
  "NNF_ternary (TernaryNot (TernaryNot t)) = NNF_ternary t" |
  "NNF_ternary (TernaryNot (TernaryValue v)) = TernaryValue (eval_ternary_Not v)" |
  "NNF_ternary (TernaryNot (TernaryAnd t1 t2)) = TernaryOr (NNF_ternary (TernaryNot t1)) (NNF_ternary (TernaryNot t2))" |
  "NNF_ternary (TernaryNot (TernaryOr t1 t2)) = TernaryAnd (NNF_ternary (TernaryNot t1)) (NNF_ternary (TernaryNot t2))"

lemma NNF_ternary_correct: "ternary_ternary_eval (NNF_ternary t) = ternary_ternary_eval t"
  proof(induction t rule: NNF_ternary.induct)
  qed(simp_all add: eval_ternary_DeMorgan eval_ternary_idempotence_Not)

lemma NNF_ternary_NegationNormalForm: "NegationNormalForm (NNF_ternary t)"
  proof(induction t rule: NNF_ternary.induct)
  qed(auto simp add: eval_ternary_DeMorgan eval_ternary_idempotence_Not intro: NegationNormalForm.intros)

context
begin
  private lemma ternary_lift1: "eval_ternary_Not tv \<noteq> TernaryFalse \<longleftrightarrow> tv = TernaryFalse \<or> tv = TernaryUnknown"
    using eval_ternary_Not.elims by blast
  private lemma ternary_lift2: "eval_ternary_Not tv \<noteq> TernaryTrue \<longleftrightarrow> tv = TernaryTrue \<or> tv = TernaryUnknown"
    using eval_ternary_Not.elims by blast
  private lemma ternary_lift3: "eval_ternary_Not tv = TernaryFalse \<longleftrightarrow> tv = TernaryTrue"
    by (metis eval_ternary_Not.simps(1) eval_ternary_idempotence_Not)
  private lemma ternary_lift4: "eval_ternary_Not tv = TernaryTrue \<longleftrightarrow> tv = TernaryFalse"
    by (metis eval_ternary_Not.simps(1) eval_ternary_idempotence_Not)
  private lemma ternary_lift5: "eval_ternary_Not tv = TernaryUnknown \<longleftrightarrow> tv = TernaryUnknown"
    by (metis eval_ternary_Not.simps(3) eval_ternary_idempotence_Not)

  private lemma ternary_lift6: "eval_ternary_And t1 t2 = TernaryFalse \<longleftrightarrow> t1 = TernaryFalse \<or> t2 = TernaryFalse"
    using eval_ternary_And.elims by blast
  private lemma ternary_lift7: "eval_ternary_And t1 t2 = TernaryTrue \<longleftrightarrow> t1 = TernaryTrue \<and> t2 = TernaryTrue"
    using eval_ternary_And.elims by blast

  lemmas ternary_lift = ternary_lift1 ternary_lift2 ternary_lift3 ternary_lift4 ternary_lift5 ternary_lift6 ternary_lift7
end

context
begin
  private lemma l1: "eval_ternary_Not tv = TernaryTrue \<Longrightarrow> tv = TernaryFalse"
    by (metis eval_ternary_Not.simps(1) eval_ternary_idempotence_Not)
  private lemma l2: "eval_ternary_And t1 t2 = TernaryFalse \<Longrightarrow> t1 = TernaryFalse \<or> t2 = TernaryFalse"
    using eval_ternary_And.elims by blast

  lemmas eval_ternaryD = l1 l2
end

end


theory Finiteness
  imports Main "HOL-Eisbach.Eisbach_Tools"
begin

section \<open>Two Eisbach proof methods for finiteness of sets\<close>
text \<open>
  The first method is intended to act more conservatively (think \<open>safe\<close>), leaving subgoals
  for the user where it couldn't proceed any further.
  The second method is more powerful, acting more in a succeed-or-die manner,
  similarly to \<open>force\<close> and friends.
  The examples in the second section should give a good impression of where these methods
  can help.
\<close>

text \<open>This slot is intended to provide more \<open>intro\<close> theorems for finite sets.\<close>
named_theorems finite

(* Trick from Dan Matichuk on isabelle-users *)
method add_finite_Collect_simproc methods m =
  match termI in H[simproc add: finite_Collect]:_ \<Rightarrow> m

(* Trick from Dan Matichuk on isabelle-users.
   Turns a structured method into a simple one.
*)
method_setup simple_method =
 \<open>Method.text_closure >> (fn m => fn ctxt =>
   let
     val facts = Method.get_facts ctxt
     val insert' = Method.Basic (K (Method.insert facts))
     val m' = Method.Combinator (Method.no_combinator_info, Method.Then, [insert', m])
   in Method.evaluate m' ctxt end)\<close>

method finite_tup =
  match conclusion in
    "finite (_ \<times> _)" \<Rightarrow> \<open>rule finite_cartesian_product; finite_tup\<close> \<bar>
    "finite S" for S :: "(_ * _) set" \<Rightarrow>
      \<open>print_term S, (rule finite_subset[where A = S and B = "fst ` S \<times> snd ` S"]; finite_tup?
        | (rule finite_subset; assumption?; fastforce))\<close> \<bar>
    "finite X" for X \<Rightarrow>
      \<open>print_term X, (simp add: image_def, finite_tup?)?,
                (solves \<open>(rule finite_subset; assumption?; fastforce)\<close>)?\<close> \<bar>
    _ \<Rightarrow> \<open>fastforce simp: image_def\<close>

method finite_search =
  match conclusion in
    "finite (_ \<times> _)" \<Rightarrow> \<open>rule finite_cartesian_product; finite_search\<close> \<bar>
    "finite (_ ` _)" \<Rightarrow> \<open>simp; finite_search | rule finite_imageI; finite_search\<close> \<bar>
    "finite S" for S :: "(_ * _) set" \<Rightarrow>
      \<open>print_term S, (solves \<open>rule finite_subset; auto\<close>
        | rule finite_subset[where A = S and B = "fst ` S \<times> snd ` S"]; finite_tup?)\<close> \<bar>
    "finite (Collect f)" for f \<Rightarrow>
      \<open>print_term f, (add_finite_Collect_simproc simp)?;
        (solves \<open>auto intro: finite\<close>
       | print_term v, simp?, rule finite; (assumption | finite_search)
       | rule finite_imageI; finite_search
       | rule finite_vimageI; finite_search
       | print_term x, rule finite_subset; assumption?; fastforce)\<close> \<bar>
    "finite X" for X \<Rightarrow>
      \<open>print_term X,
        (rule finite; (assumption | finite_search)
       |(simp add: image_def, finite_search?)?,
          (solves \<open>(rule finite_subset; assumption?; fastforce)\<close>)?)\<close> \<bar>
    _ \<Rightarrow> \<open>fastforce simp: image_def\<close>

method finite = simple_method finite_search

section \<open>Tests\<close>

subsection \<open>Counterexamples\<close>

lemma inj_finite_single:
  assumes "inj f"
  shows "finite {y. x = f y}"
using assms Collect_mem_eq Collect_mono_iff infinite_iff_countable_subset inj_eq not_finite_existsD
      rangeI
by fastforce

lemmas inj_finite_single[finite]

text \<open>It's hard to guess the right set\<close>
lemma inj_finite_single':
  assumes "inj f"
  shows "finite {z. f z = x}"
apply (rule finite_subset[of _ "{z. x = f z}"])
apply blast
using assms by finite

(* Due to Lars Hupel *)
definition select :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'a set \<Rightarrow> 'b set" where
  "select f S = {z | z. \<exists>x \<in> S. f x = Some z}"

lemma select_finite:
  assumes "finite S"
  shows "finite (select f S)"
using assms unfolding select_def by finite

lemmas inj_finite_single'[finite]

subsection \<open>Working Examples\<close>

lemma
  assumes "finite A"
  shows "finite {x. x \<in> A \<and> P x}"
using assms by finite_search

lemma collect_pair_finite'[finite]:
  assumes "finite {(x, y). P x y}"
  shows "finite {(x, y) . P x y \<and> R x y}"
using assms by - finite

text \<open>This is what we actually need in this theory\<close>
lemma collect_pair_finite''[finite]:
  assumes "finite {(x, y). P x \<and> Q y}"
  shows "finite {(x, y) . P x \<and> Q y \<and> R x y}"
using assms by - finite

lemma
  assumes "finite (A \<times> B)"
  shows "finite {(x, y) | x y. x \<in> A \<and> y \<in> B \<and> R x y}"
using assms by - finite

lemma finite_imageI'':
  assumes "finite (A \<times> B)"
  shows "finite {f x y | x y. x \<in> A \<and> y \<in> B \<and> R x y}"
using assms by - finite

text \<open>\<open>finite_Collect\<close> can also rewrite to \<open>vimage\<close>\<close>
lemma
  assumes "inj f" "finite S"
  shows "finite {y. \<exists> x \<in> S. x = f y}"
using assms by - finite

lemma
  assumes "inj f" "finite S"
  shows "finite {y. \<exists> x \<in> S. f y = x}"
using assms by - finite

text \<open>Another counter-example\<close>
lemma
  assumes "finite (A \<times> B)"
  shows "finite {f x y | x y. x \<in> A \<and> y \<in> B \<and> R x y \<and> Q x y \<and> T x \<and> TT y}" (is "finite ?S")
proof -
  have "?S = (\<lambda> (x, y). f x y) ` {(x, y). x \<in> A \<and> y \<in> B \<and> R x y \<and> Q x y \<and> T x \<and> TT y}"
  by auto
  also have "finite \<dots>" using assms by - finite
  ultimately show ?thesis by simp
qed

text \<open>
  Easier proof. The problem for our method is that the simproc fails to turn ?S into the form used
  in the proof above.
  Note that the declaration of the \<open>finite\<close> attribute below is the only one that is \<^emph>\<open>necessary\<close> in
  this theory.
\<close>
lemma
  notes finite_imageI''[finite]
  assumes "finite (A \<times> B)"
  shows "finite {f x y | x y. x \<in> A \<and> y \<in> B \<and> R x y \<and> Q x y \<and> T x \<and> TT y}" (is "finite ?S")
using assms by finite

lemma
  assumes "finite A" "finite B"
  shows "finite {(x, y) | x y. x \<in> A \<and> y \<in> B \<and> R y \<and> S x}"
using assms by - finite

lemma
  fixes P Q R :: "'a \<Rightarrow> bool"
  assumes "finite {x. P x \<and> R x}"
  shows "finite {x. P x \<and> Q x \<and> R x}"
using assms by - finite

lemma R:
  assumes "finite A" "A = B"
  shows "finite B"
using assms by finite

lemma pairwise_finiteI:
  assumes "finite {b. \<exists>a. P a b}" (is "finite ?B")
  assumes "finite {a. \<exists>b. P a b}"
  shows "finite {(a,b). P a b}" (is "finite ?C")
using assms by - finite

lemma pairwise_finiteI3:
  assumes "finite {b. \<exists>a c. P a b c}"
  assumes "finite {a. \<exists>b c. P a b c}"
  assumes "finite {c. \<exists>a b. P a b c}"
  shows "finite {(a,b,c). P a b c}" (is "finite ?C")
using assms by - finite

lemma pairwise_finiteI4:
  assumes "finite {b. \<exists>a c d. P a b c d}"
  assumes "finite {a. \<exists>b c d. P a b c d}"
  assumes "finite {c. \<exists>a b d. P a b c d}"
  assumes "finite {d. \<exists>a b c. P a b c d}"
  shows "finite {(a,b,c,d). P a b c d}" (is "finite ?C")
using assms by - finite

lemma finite_ex_and1:
  assumes "finite {b. \<exists>a. P a b}" (is "finite ?A")
  shows "finite {b. \<exists>a. P a b \<and> Q a b}" (is "finite ?B")
using assms by - finite

lemma finite_ex_and2:
  assumes "finite {b. \<exists>a. Q a b}" (is "finite ?A")
  shows "finite {b. \<exists>a. P a b \<and> Q a b}" (is "finite ?B")
using assms by - finite

text \<open>
  This is the only lemma where our methods cannot help us so far due to the fairly
  complex argument that is used in the interactive proof.
\<close>

end


chapter \<open>An Application: Finite Automata\<close>

theory Finite_Automata imports Ordinal
begin

text \<open>The point of this example is that the HF sets are closed under disjoint sums and Cartesian products,
 allowing the theory of finite state machines to be developed without issues of polymorphism
 or any tricky encodings of states.\<close>

record 'a fsm = states :: hf
                init :: hf
                final :: hf
                "next" :: "hf \<Rightarrow> 'a \<Rightarrow> hf \<Rightarrow> bool"

inductive reaches :: "['a fsm, hf, 'a list, hf] \<Rightarrow> bool"
where
    Nil:  "st \<^bold>\<in> states fsm \<Longrightarrow> reaches fsm st [] st"
  | Cons: "\<lbrakk>next fsm st x st''; reaches fsm st'' xs st'; st \<^bold>\<in> states fsm\<rbrakk> \<Longrightarrow> reaches fsm st (x#xs) st'"

declare reaches.intros [intro]
inductive_simps reaches_Nil [simp]:  "reaches fsm st [] st'"
inductive_simps reaches_Cons [simp]: "reaches fsm st (x#xs) st'"

lemma reaches_imp_states: "reaches fsm st xs st' \<Longrightarrow> st \<^bold>\<in> states fsm \<and> st' \<^bold>\<in> states fsm"
  by (induct xs arbitrary: st st', auto)

lemma reaches_append_iff:
     "reaches fsm st (xs@ys) st' \<longleftrightarrow> (\<exists>st''. reaches fsm st xs st'' \<and> reaches fsm st'' ys st')"
  by (induct xs arbitrary: ys st st') (auto simp: reaches_imp_states)

definition accepts :: "'a fsm \<Rightarrow> 'a list \<Rightarrow> bool"  where
  "accepts fsm xs \<equiv> \<exists>st st'. reaches fsm st xs st' \<and> st \<^bold>\<in> init fsm \<and> st' \<^bold>\<in> final fsm"

definition regular :: "'a list set \<Rightarrow> bool" where
  "regular S \<equiv> \<exists>fsm. S = {xs. accepts fsm xs}"

definition Null where
  "Null = \<lparr>states = 0, init = 0, final = 0, next = \<lambda>st x st'. False\<rparr>"

theorem regular_empty:  "regular {}"
  by (auto simp: regular_def accepts_def) (metis hempty_iff simps(2))

abbreviation NullStr where
  "NullStr \<equiv> \<lparr>states = 1, init = 1, final = 1, next = \<lambda>st x st'. False\<rparr>"

theorem regular_emptystr:  "regular {[]}"
  apply (auto simp: regular_def accepts_def)
  apply (rule exI [where x = NullStr], auto)
  apply (case_tac x, auto)
  done

abbreviation SingStr where
  "SingStr a \<equiv> \<lparr>states = \<lbrace>0, 1\<rbrace>, init = \<lbrace>0\<rbrace>, final = \<lbrace>1\<rbrace>, next = \<lambda>st x st'. st=0 \<and> x=a \<and> st'=1\<rparr>"

theorem regular_singstr: "regular {[a]}"
  apply (auto simp: regular_def accepts_def)
  apply (rule exI [where x = "SingStr a"], auto)
  apply (case_tac x, auto)
  apply (case_tac list, auto)
  done

definition Reverse where
  "Reverse fsm = \<lparr>states = states fsm, init = final fsm, final = init fsm,
                  next = \<lambda>st x st'. next fsm st' x st\<rparr>"

lemma Reverse_Reverse_ident [simp]: "Reverse (Reverse fsm) = fsm"
  by (simp add: Reverse_def)

lemma reaches_Reverse_iff [simp]:
     "reaches (Reverse fsm) st (rev xs) st' \<longleftrightarrow> reaches fsm st' xs st"
  by (induct xs arbitrary: st st') (auto simp add: Reverse_def reaches_append_iff reaches_imp_states)

lemma reaches_Reverse_iff2 [simp]:
     "reaches (Reverse fsm) st' xs st \<longleftrightarrow> reaches fsm st (rev xs) st'"
  by (metis reaches_Reverse_iff rev_rev_ident)

lemma [simp]: "final (Reverse fsm) = init fsm"
  by (simp add: Reverse_def)

theorem regular_rev: "regular S \<Longrightarrow> regular (rev ` S)"
  apply (auto simp: regular_def accepts_def)
  apply (rule_tac x="Reverse fsm" in exI, force+)
  done

definition Times where
  "Times fsm1 fsm2 = \<lparr>states = states fsm1 * states fsm2,
                      init = init fsm1 * init fsm2,
                      final = final fsm1 * final fsm2,
                      next = \<lambda>st x st'. (\<exists>st1 st2 st1' st2'. st = \<langle>st1,st2\<rangle> \<and> st' = \<langle>st1',st2'\<rangle> \<and>
                                      next fsm1 st1 x st1' \<and> next fsm2 st2 x st2')\<rparr>"

lemma states_Times [simp]: "states (Times fsm1 fsm2) = states fsm1 * states fsm2"
  by (simp add: Times_def)

lemma init_Times [simp]: "init (Times fsm1 fsm2) = init fsm1 * init fsm2"
  by (simp add: Times_def)

lemma final_Times [simp]: "final (Times fsm1 fsm2) = final fsm1 * final fsm2"
  by (simp add: Times_def)

lemma next_Times: "next (Times fsm1 fsm2) \<langle>st1,st2\<rangle> x st' \<longleftrightarrow>
    (\<exists>st1' st2'. st' = \<langle>st1',st2'\<rangle> \<and> next fsm1 st1 x st1' \<and> next fsm2 st2 x st2')"
  by (simp add: Times_def)

lemma reaches_Times_iff [simp]:
     "reaches (Times fsm1 fsm2) \<langle>st1,st2\<rangle> xs \<langle>st1',st2'\<rangle> \<longleftrightarrow>
      reaches fsm1 st1 xs st1' \<and> reaches fsm2 st2 xs st2'"
apply (induct xs arbitrary: st1 st2 st1' st2', force)
apply (force simp add: next_Times Times_def reaches.Cons)
done

lemma accepts_Times_iff [simp]:
     "accepts (Times fsm1 fsm2) xs \<longleftrightarrow>
      accepts fsm1 xs \<and> accepts fsm2 xs"
  by (force simp add: accepts_def)

theorem regular_Int:
  assumes S: "regular S" and T: "regular T" shows "regular (S \<inter> T)"
proof -
  obtain fsmS fsmT where "S = {xs. accepts fsmS xs}" "T = {xs. accepts fsmT xs}" using S T
    by (auto simp: regular_def)
  hence "S \<inter> T = {xs. accepts (Times fsmS fsmT) xs}"
    by (auto simp: accepts_Times_iff [of fsmS fsmT])
  thus ?thesis
    by (metis regular_def)
qed

definition Plus where
  "Plus fsm1 fsm2 = \<lparr>states = states fsm1 + states fsm2,
                      init = init fsm1 + init fsm2,
                      final = final fsm1 + final fsm2,
                      next = \<lambda>st x st'. (\<exists>st1 st1'. st = Inl st1 \<and> st' = Inl st1' \<and> next fsm1 st1 x st1') \<or>
                                       (\<exists>st2 st2'. st = Inr st2 \<and> st' = Inr st2' \<and> next fsm2 st2 x st2')\<rparr>"

lemma states_Plus [simp]: "states (Plus fsm1 fsm2) = states fsm1 + states fsm2"
  by (simp add: Plus_def)

lemma init_Plus [simp]: "init (Plus fsm1 fsm2) = init fsm1 + init fsm2"
  by (simp add: Plus_def)

lemma final_Plus [simp]: "final (Plus fsm1 fsm2) = final fsm1 + final fsm2"
  by (simp add: Plus_def)

lemma next_Plus1: "next (Plus fsm1 fsm2) (Inl st1) x st' \<longleftrightarrow> (\<exists>st1'. st' = Inl st1' \<and> next fsm1 st1 x st1')"
  by (simp add: Plus_def)

lemma next_Plus2: "next (Plus fsm1 fsm2) (Inr st2) x st' \<longleftrightarrow> (\<exists>st2'. st' = Inr st2' \<and> next fsm2 st2 x st2')"
  by (simp add: Plus_def)

lemma reaches_Plus_iff1 [simp]:
     "reaches (Plus fsm1 fsm2) (Inl st1) xs st' \<longleftrightarrow>
      (\<exists>st1'. st' = Inl st1' \<and> reaches fsm1 st1 xs st1')"
apply (induct xs arbitrary: st1, force)
apply (force simp add: next_Plus1 reaches.Cons)
done

lemma reaches_Plus_iff2 [simp]:
     "reaches (Plus fsm1 fsm2) (Inr st2) xs st' \<longleftrightarrow>
      (\<exists>st2'. st' = Inr st2' \<and> reaches fsm2 st2 xs st2')"
apply (induct xs arbitrary: st2, force)
apply (force simp add: next_Plus2 reaches.Cons)
done

lemma reaches_Plus_iff [simp]:
     "reaches (Plus fsm1 fsm2) st xs st' \<longleftrightarrow>
      (\<exists>st1 st1'. st = Inl st1 \<and> st' = Inl st1' \<and> reaches fsm1 st1 xs st1') \<or>
      (\<exists>st2 st2'. st = Inr st2 \<and> st' = Inr st2' \<and> reaches fsm2 st2 xs st2')"
apply (induct xs arbitrary: st st', auto)
apply (force simp add: next_Plus1 next_Plus2 Plus_def reaches.Cons)
apply (auto simp: Plus_def)
done

lemma accepts_Plus_iff [simp]:
     "accepts (Plus fsm1 fsm2) xs \<longleftrightarrow> accepts fsm1 xs \<or> accepts fsm2 xs"
  by (auto simp: accepts_def) (metis sum_iff)

lemma regular_Un:
  assumes S: "regular S" and T: "regular T" shows "regular (S \<union> T)"
proof -
  obtain fsmS fsmT where "S = {xs. accepts fsmS xs}" "T = {xs. accepts fsmT xs}" using S T
    by (auto simp: regular_def)
  hence "S \<union> T = {xs. accepts (Plus fsmS fsmT) xs}"
    by (auto simp: accepts_Plus_iff [of fsmS fsmT])
  thus ?thesis
    by (metis regular_def)
qed

end