(*
Author:  Florian Messner <florian.g.messner@uibk.ac.at>
Author:  Julian Parsert <julian.parsert@gmail.com>
Author:  Jonas Schöpf <jonas.schoepf@uibk.ac.at>
Author:  Christian Sternagel <c.sternagel@gmail.com>
License: LGPL
*)

section \<open>Vectors as Lists of Naturals\<close>

theory List_Vector
  imports Main
begin

(*TODO: move*)
lemma lex_lengthD: "(x, y) \<in> lex P \<Longrightarrow> length x = length y"
  by (auto simp: lexord_lex)

(*TODO: move*)
lemma lexI:
  assumes "length ys = length xs" and "i < length xs"
    and "take i xs = take i ys" and "(xs ! i, ys ! i) \<in> r"
  shows "(xs, ys) \<in> lex r"
proof -
  have "xs = take i xs @ xs ! i # drop (Suc i) xs"
    and "ys = take i ys @ ys ! i # drop (Suc i) ys"
    using assms by (metis id_take_nth_drop)+
  then show ?thesis
    using assms by (auto simp: lex_def lexn_conv)
qed

(*TODO: move*)
lemma lex_take_index:
  assumes "(xs, ys) \<in> lex r"
  obtains i where "length ys = length xs"
    and "i < length xs" and "take i xs = take i ys"
    and "(xs ! i, ys ! i) \<in> r"
proof -
  obtain n us x xs' y ys' where "(xs, ys) \<in> lexn r n" and "length xs = n" and "length ys = n"
    and "xs = us @ x # xs'" and "ys = us @ y # ys'" and "(x, y) \<in> r"
    using assms by (fastforce simp: lex_def lexn_conv)
  then show ?thesis by (intro that [of "length us"]) auto
qed

(*TODO: move*)
lemma mods_with_nats:
  assumes "(v::nat) > w"
    and "(v * b) mod a = (w * b) mod a"
  shows "((v - w) * b) mod a = 0"
  by (metis add_diff_cancel_left' assms left_diff_distrib'
      less_imp_le mod_mult_self1_is_0 mult_le_mono1 nat_mod_eq_lemma)

\<comment> \<open>The 0-vector of length \<open>n\<close>.\<close>
abbreviation zeroes :: "nat \<Rightarrow> nat list"
  where
    "zeroes n \<equiv> replicate n 0"

lemma rep_upd_unit:
  assumes "x = (zeroes n)[i := a]"
  shows "\<forall>j < length x. (j \<noteq> i \<longrightarrow> x ! j = 0) \<and> (j = i \<longrightarrow> x ! j = a)"
  using assms by simp

definition nonzero_iff: "nonzero xs \<longleftrightarrow> (\<exists>x\<in>set xs. x \<noteq> 0)"

lemma nonzero_append [simp]:
  "nonzero (xs @ ys) \<longleftrightarrow> nonzero xs \<or> nonzero ys" by (auto simp: nonzero_iff)

subsection \<open>The Inner Product\<close>

definition dotprod :: "nat list \<Rightarrow> nat list \<Rightarrow> nat" (infixl "\<bullet>" 70)
  where
    "xs \<bullet> ys = (\<Sum>i<min (length xs) (length ys). xs ! i * ys ! i)"

lemma dotprod_code [code]:
  "xs \<bullet> ys = sum_list (map (\<lambda>(x, y). x * y) (zip xs ys))"
  by (auto simp: dotprod_def sum_list_sum_nth lessThan_atLeast0)

lemma dotprod_commute:
  assumes "length xs = length ys"
  shows "xs \<bullet> ys = ys \<bullet> xs"
  using assms by (auto simp: dotprod_def mult.commute)

lemma dotprod_Nil [simp]: "[] \<bullet> [] = 0"
  by (simp add: dotprod_def)

lemma dotprod_1_right [simp]:
  "xs \<bullet> replicate (length xs) 1 = sum_list xs"
  by (induct xs) (simp_all)

lemma dotprod_0_right [simp]:
  "xs \<bullet> zeroes (length xs) = 0"
  by (induct xs) (simp_all)

lemma dotprod_unit [simp]:
  assumes "length a = n"
    and "k < n"
  shows "a \<bullet> (zeroes n)[k := zk] = a ! k * zk"
  using assms by (induct a arbitrary: k n) (auto split: nat.splits)

lemma dotprod_gt0:
  assumes "length x = length y" and "\<exists>i<length y. x ! i > 0 \<and> y ! i > 0"
  shows "x \<bullet> y > 0"
  using assms by (induct x y rule: list_induct2) (fastforce simp: nth_Cons split: nat.splits)+

lemma dotprod_gt0D:
  assumes "length x = length y"
    and "x \<bullet> y > 0"
  shows "\<exists>i<length y. x ! i > 0 \<and> y ! i > 0"
  using assms by (induct x y rule: list_induct2) (auto simp: Ex_less_Suc2)

lemma dotprod_gt0_iff [iff]:
  assumes "length x = length y"
  shows "x \<bullet> y > 0 \<longleftrightarrow> (\<exists>i<length y. x ! i > 0 \<and> y ! i > 0)"
  using assms and dotprod_gt0D and dotprod_gt0 by blast

lemma dotprod_append:
  assumes "length a = length b"
  shows"(a @ x) \<bullet> (b @ y) = a \<bullet> b + x \<bullet> y"
  using assms by (induct a b rule: list_induct2) auto

lemma dotprod_le_take:
  assumes "length a = length b"
    and "k \<le> length a"
  shows"take k a \<bullet> take k b \<le> a \<bullet> b"
  using assms and append_take_drop_id [of k a] and append_take_drop_id [of k b]
  by (metis add_right_cancel leI length_append length_drop not_add_less1 dotprod_append)

lemma dotprod_le_drop:
  assumes "length a = length b"
    and "k \<le> length a"
  shows "drop k a \<bullet> drop k b \<le> a \<bullet> b"
  using assms and append_take_drop_id [of k a] and append_take_drop_id [of k b]
  by (metis dotprod_append length_take order_refl trans_le_add2)

lemma dotprod_is_0 [simp]:
  assumes "length x = length y"
  shows "x \<bullet> y = 0 \<longleftrightarrow> (\<forall>i<length y. x ! i = 0 \<or> y ! i = 0)"
  using assms by (metis dotprod_gt0_iff neq0_conv)

lemma dotprod_eq_0_iff:
  assumes "length x = length a"
    and "0 \<notin> set a"
  shows "x \<bullet> a = 0 \<longleftrightarrow> (\<forall>e \<in> set x. e = 0)"
  using assms by (fastforce simp: in_set_conv_nth)

lemma dotprod_eq_nonzero_iff:
  assumes "a \<bullet> x = b \<bullet> y" and "length x = length a" and "length y = length b"
    and "0 \<notin> set a" and "0 \<notin> set b"
  shows "nonzero x \<longleftrightarrow> nonzero y"
  using assms by (auto simp: nonzero_iff) (metis dotprod_commute dotprod_eq_0_iff neq0_conv)+

lemma eq_0_iff:
  "xs = zeroes n \<longleftrightarrow> length xs = n \<and> (\<forall>x\<in>set xs. x = 0)"
  using in_set_replicate [of _ n 0] and replicate_eqI [of xs n 0] by auto

lemma not_nonzero_iff: "\<not> nonzero x \<longleftrightarrow> x = zeroes (length x)"
  by (auto simp: nonzero_iff replicate_length_same eq_0_iff)

lemma neq_0_iff':
  "xs \<noteq> zeroes n \<longleftrightarrow> length xs \<noteq> n \<or> (\<exists>x\<in>set xs. x > 0)"
  by (auto simp: eq_0_iff)

lemma dotprod_pointwise_le:
  assumes "length as = length xs"
    and "i < length as"
  shows "as ! i * xs ! i \<le> as \<bullet> xs"
proof -
  have "as \<bullet> xs = (\<Sum>i<min (length as) (length xs). as ! i * xs ! i)"
    by (simp add: dotprod_def)
  then show ?thesis
    using assms by (auto intro: member_le_sum)
qed

lemma replicate_dotprod:
  assumes "length y = n"
  shows "replicate n x \<bullet> y = x * sum_list y"
proof -
  have "x * (\<Sum>i<length y.  y ! i) = (\<Sum>i<length y. x * y ! i)"
    using sum_distrib_left by blast
  then show ?thesis
    using assms by (auto simp: dotprod_def sum_list_sum_nth atLeast0LessThan)
qed

subsection \<open>The Pointwise Order on Vectors\<close>

definition  less_eq :: "nat list \<Rightarrow> nat list \<Rightarrow> bool" ("_/ \<le>\<^sub>v _" [51, 51] 50)
  where
    "xs \<le>\<^sub>v ys \<longleftrightarrow> length xs = length ys \<and> (\<forall>i<length xs. xs ! i \<le> ys ! i)"

definition less :: "nat list \<Rightarrow> nat list \<Rightarrow> bool" ("_/ <\<^sub>v _" [51, 51] 50)
  where
    "xs <\<^sub>v ys \<longleftrightarrow> xs \<le>\<^sub>v ys \<and> \<not> ys \<le>\<^sub>v xs"

interpretation order_vec: order less_eq less
  by (standard, auto simp add: less_def less_eq_def dual_order.antisym nth_equalityI) (force)

lemma less_eqI [intro?]: "length xs = length ys \<Longrightarrow> \<forall>i<length xs. xs ! i \<le> ys ! i \<Longrightarrow> xs \<le>\<^sub>v ys"
  by (auto simp: less_eq_def)

lemma le0 [simp, intro]: "zeroes (length xs) \<le>\<^sub>v xs" by (simp add: less_eq_def)

lemma le_list_update [simp]:
  assumes "xs \<le>\<^sub>v ys" and "i < length ys" and "z \<le> ys ! i"
  shows "xs[i := z] \<le>\<^sub>v ys"
  using assms by (auto simp: less_eq_def nth_list_update)

lemma le_Cons: "x # xs \<le>\<^sub>v y # ys \<longleftrightarrow> x \<le> y \<and> xs \<le>\<^sub>v ys"
  by (auto simp add: less_eq_def nth_Cons split: nat.splits)

lemma zero_less:
  assumes "nonzero x"
  shows "zeroes (length x) <\<^sub>v x"
  using assms and eq_0_iff order_vec.dual_order.strict_iff_order
  by (auto simp: nonzero_iff)

lemma le_append:
  assumes "length xs = length vs"
  shows "xs @ ys \<le>\<^sub>v vs @ ws \<longleftrightarrow> xs \<le>\<^sub>v vs \<and> ys \<le>\<^sub>v ws"
  using assms
  by (auto simp: less_eq_def nth_append)
    (metis add.commute add_diff_cancel_left' nat_add_left_cancel_less not_add_less2)

lemma less_Cons:
  "(x # xs) <\<^sub>v (y # ys) \<longleftrightarrow> length xs = length ys \<and> (x \<le> y \<and> xs <\<^sub>v ys \<or> x < y \<and> xs \<le>\<^sub>v ys)"
  by (simp add: less_def less_eq_def All_less_Suc2) (auto dest: leD)

lemma le_length [dest]:
  assumes "xs \<le>\<^sub>v ys"
  shows "length xs = length ys"
  using assms by (simp add: less_eq_def)

lemma less_length [dest]:
  assumes "x <\<^sub>v y"
  shows "length x = length y"
  using assms by (auto simp: less_def)

lemma less_appendD:
  assumes "xs @ ys <\<^sub>v vs @ ws"
    and "length xs = length vs"
  shows "xs <\<^sub>v vs \<or> ys <\<^sub>v ws"
  by (auto) (metis (no_types, lifting) assms le_append order_vec.order.strict_iff_order)

lemma less_append_cases:
  assumes "xs @ ys <\<^sub>v vs @ ws" and "length xs = length vs"
  obtains "xs <\<^sub>v vs" and "ys \<le>\<^sub>v ws" | "xs \<le>\<^sub>v vs" and "ys <\<^sub>v ws"
  using assms and that
  by (metis le_append less_appendD order_vec.order.strict_implies_order)

lemma less_append_swap:
  assumes "x @ y <\<^sub>v u @ v"
    and "length x = length u"
  shows "y @ x <\<^sub>v v @ u"
  using assms(2, 1)
  by (induct x u rule: list_induct2)
    (auto simp: order_vec.order.strict_iff_order le_Cons le_append le_length)

lemma le_sum_list_less:
  assumes "xs \<le>\<^sub>v ys"
    and "sum_list xs < sum_list ys"
  shows "xs <\<^sub>v ys"
proof -
  have "length xs = length ys" and "\<forall>i<length ys. xs ! i \<le> ys ! i"
    using assms by (auto simp: less_eq_def)
  then show ?thesis
    using \<open>sum_list xs < sum_list ys\<close>
    by (induct xs ys rule: list_induct2)
      (auto simp: less_Cons All_less_Suc2 less_eq_def)
qed

lemma dotprod_le_right:
  assumes "v \<le>\<^sub>v w"
    and "length b = length w"
  shows "b \<bullet> v \<le> b \<bullet> w"
  using assms by (auto simp: dotprod_def less_eq_def intro: sum_mono)

lemma dotprod_pointwise_le_right:
  assumes "length z = length u"
    and "length u = length v"
    and "\<forall>i<length v. u ! i \<le> v ! i"
  shows "z \<bullet> u \<le> z \<bullet> v"
  using assms by (intro dotprod_le_right) (auto intro: less_eqI)

lemma dotprod_le_left:
  assumes "v \<le>\<^sub>v w"
    and "length b = length w"
  shows "v \<bullet> b \<le> w \<bullet> b "
  using assms by (simp add: dotprod_le_right dotprod_commute le_length)

lemma dotprod_le:
  assumes "x \<le>\<^sub>v u" and "y \<le>\<^sub>v v"
    and "length y = length x" and "length v = length u"
  shows "x \<bullet> y \<le> u \<bullet> v"
  using assms by (metis dotprod_le_left dotprod_le_right le_length le_trans)

lemma dotprod_less_left:
  assumes "length b = length w"
    and "0 \<notin> set b"
    and "v <\<^sub>v w"
  shows "v \<bullet> b < w \<bullet> b"
proof -
  have "length v = length w" using assms
    using less_eq_def order_vec.order.strict_implies_order by blast
  then show ?thesis
    using assms
  proof (induct v w arbitrary: b rule: list_induct2)
    case (Cons x xs y ys)
    then show ?case
      by (cases b) (auto simp: less_Cons add_mono_thms_linordered_field dotprod_le_left)
  qed simp
qed

lemma le_append_swap:
  assumes "length y = length v"
    and "x @ y \<le>\<^sub>v w @ v"
  shows "y @ x \<le>\<^sub>v v @ w"
proof -
  have "length w = length x" using assms by auto
  with assms show ?thesis
    by (induct y v arbitrary: x w rule: list_induct2) (auto simp: le_Cons le_append)
qed

lemma le_append_swap_iff:
  assumes "length y = length v"
  shows "y @ x \<le>\<^sub>v v @ w  \<longleftrightarrow> x @ y \<le>\<^sub>v w @ v"
  using assms and le_append_swap
  by (auto) (metis (no_types, lifting) add_left_imp_eq le_length length_append)

lemma unit_less:
  assumes "i < n"
    and "x <\<^sub>v (zeroes n)[i := b]"
  shows "x ! i < b \<and> (\<forall>j<n. j \<noteq> i \<longrightarrow> x ! j = 0)"
proof
  show "x ! i < b"
    using assms less_def by fastforce
next
  have "x \<le>\<^sub>v (zeroes n)[i := b]" by (simp add: assms order_vec.less_imp_le)
  then show "\<forall>j<n. j \<noteq> i \<longrightarrow> x ! j = 0" by (auto simp: less_eq_def)
qed

lemma le_sum_list_mono:
  assumes "xs \<le>\<^sub>v ys"
  shows "sum_list xs \<le> sum_list ys"
  using assms and sum_list_mono [of "[0..<length ys]" "(!) xs" "(!) ys"]
  by (auto simp: less_eq_def) (metis map_nth)

lemma sum_list_less_diff_Ex:
  assumes "u \<le>\<^sub>v y"
    and "sum_list u < sum_list y"
  shows "\<exists>i<length y. u ! i < y ! i"
proof -
  have "length u = length y" and "\<forall>i<length y. u ! i \<le> y ! i"
    using \<open>u \<le>\<^sub>v y\<close> by (auto simp: less_eq_def)
  then show ?thesis
    using \<open>sum_list u < sum_list y\<close>
    by (induct u y rule: list_induct2) (force simp: Ex_less_Suc2 All_less_Suc2)+
qed

lemma less_vec_sum_list_less:
  assumes "v <\<^sub>v w"
  shows "sum_list v < sum_list w"
  using assms
proof -
  have "length v = length w"
    using assms less_eq_def less_imp_le by blast
  then show ?thesis
    using assms
  proof (induct v w rule: list_induct2)
    case (Cons x xs y ys)
    then show ?case
      using length_replicate less_Cons order_vec.order.strict_iff_order by force
  qed simp
qed

definition maxne0 :: "nat list \<Rightarrow> nat list \<Rightarrow> nat"
  where
    "maxne0 x a =
      (if length x = length a \<and> (\<exists>i<length a. x ! i \<noteq> 0)
      then Max {a ! i | i. i < length a \<and> x ! i \<noteq> 0}
      else 0)"

lemma maxne0_le_Max:
  "maxne0 x a \<le> Max (set a)"
  by (auto simp: maxne0_def nonzero_iff in_set_conv_nth) simp

lemma maxne0_Nil [simp]:
  "maxne0 [] as = 0"
  "maxne0 xs [] = 0"
  by (auto simp: maxne0_def)

lemma maxne0_Cons [simp]:
  "maxne0 (x # xs) (a # as) =
    (if length xs = length as then
      (if x = 0 then maxne0 xs as else max a (maxne0 xs as))
    else 0)"
proof -
  let ?a = "a # as" and ?x = "x # xs"
  have eq: "{?a ! i | i. i < length ?a \<and> ?x ! i \<noteq> 0} =
    (if x > 0 then {a} else {}) \<union> {as ! i | i. i < length as \<and> xs ! i \<noteq> 0}"
    by (auto simp: nth_Cons split: nat.splits) (metis Suc_pred)+
  show ?thesis
    unfolding maxne0_def and eq
    by (auto simp: less_Suc_eq_0_disj nth_Cons' intro: Max_insert2)
qed

lemma maxne0_times_sum_list_gt_dotprod:
  assumes "length b = length ys"
  shows "maxne0 ys b * sum_list ys \<ge> b \<bullet> ys"
  using assms
  apply (induct b ys rule: list_induct2)
   apply (auto  simp: max_def ring_distribs add_mono_thms_linordered_semiring(1))
  by (meson leI le_trans mult_less_cancel2 nat_less_le)

lemma max_times_sum_list_gt_dotprod:
  assumes "length b = length ys"
  shows "Max (set b) * sum_list ys \<ge> b \<bullet> ys"
proof -
  have "\<forall> e \<in> set b . Max (set b) \<ge> e" by simp
  then have "replicate (length ys) (Max (set b)) \<bullet> ys \<ge> b \<bullet> ys" (is "?rep \<ge> _")
    by (metis assms dotprod_pointwise_le_right dotprod_commute
        length_replicate nth_mem nth_replicate)
  moreover have "Max (set b) * sum_list ys = ?rep"
    using replicate_dotprod [of ys _ "Max (set b)"] by auto
  ultimately show ?thesis
    by (simp add: assms)
qed

lemma maxne0_mono:
  assumes "y \<le>\<^sub>v x"
  shows "maxne0 y a \<le> maxne0 x a"
proof (cases "length y = length a")
  case True
  have "length y = length x" using assms by (auto)
  then show ?thesis
    using assms and True
  proof (induct y x arbitrary: a rule: list_induct2)
    case (Cons x xs y ys)
    then show ?case by (cases a) (force simp: less_eq_def All_less_Suc2 le_max_iff_disj)+
  qed simp
next
  case False
  then show ?thesis
    using assms by (auto simp: maxne0_def)
qed

lemma all_leq_Max:
  assumes "x \<le>\<^sub>v y"
    and "x \<noteq> []"
  shows "\<forall>xi \<in> set x. xi \<le> Max (set y)"
  by (metis (no_types, lifting) List.finite_set Max_ge_iff
      assms in_set_conv_nth length_0_conv less_eq_def set_empty)

lemma le_not_less_replicate:
  "\<forall>x\<in>set xs. x \<le> b \<Longrightarrow> \<not> xs <\<^sub>v replicate (length xs) b \<Longrightarrow> xs = replicate (length xs) b"
  by (induct xs) (auto simp: less_Cons)

lemma le_replicateI: "\<forall>x\<in>set xs. x \<le> b \<Longrightarrow> xs \<le>\<^sub>v replicate (length xs) b"
  by (induct xs) (auto simp: le_Cons)

lemma le_take:
  assumes "x \<le>\<^sub>v y" and "i \<le> length x" shows "take i x \<le>\<^sub>v take i y"
  using assms by (auto simp: less_eq_def)

lemma wf_less:
  "wf {(x, y). x <\<^sub>v y}"
proof -
  have "wf (measure sum_list)" ..
  moreover have "{(x, y). x <\<^sub>v y} \<subseteq> measure sum_list"
    by (auto simp: less_vec_sum_list_less)
  ultimately show "wf {(x, y). x <\<^sub>v y}"
    by (rule wf_subset)
qed

subsection \<open>Pointwise Subtraction\<close>

definition vdiff :: "nat list \<Rightarrow> nat list \<Rightarrow> nat list" (infixl "-\<^sub>v" 65)
  where
    "w -\<^sub>v v = map (\<lambda>i. w ! i - v ! i) [0 ..< length w]"

lemma vdiff_Nil [simp]: "[] -\<^sub>v [] = []" by (simp add: vdiff_def)

lemma upt_Cons_conv:
  assumes "j < n"
  shows "[j..<n] = j # [j+1..<n]"
  by (simp add: assms upt_eq_Cons_conv)

lemma map_upt_Suc: "map f [Suc m ..< Suc n] = map (f \<circ> Suc) [m ..< n]"
  by (fold list.map_comp [of f "Suc" "[m ..< n]"]) (simp add: map_Suc_upt)

lemma vdiff_Cons [simp]:
  "(x # xs) -\<^sub>v (y # ys) = (x - y) # (xs -\<^sub>v ys)"
  by (simp add: vdiff_def upt_Cons_conv [OF zero_less_Suc] map_upt_Suc del: upt_Suc)

lemma vdiff_alt_def:
  assumes "length w = length v"
  shows "w -\<^sub>v v = map (\<lambda>(x, y). x - y) (zip w v)"
  using assms by (induct rule: list_induct2) simp_all

lemma vdiff_dotprod_distr:
  assumes "length b = length w"
    and "v \<le>\<^sub>v w"
  shows "(w -\<^sub>v v) \<bullet> b = w \<bullet> b - v \<bullet> b"
proof -
  have "length v = length w" and "\<forall>i<length w. v ! i \<le> w ! i"
    using assms less_eq_def by auto
  then show ?thesis
    using \<open>length b = length w\<close>
  proof (induct v w arbitrary: b rule: list_induct2)
    case (Cons x xs y ys)
    then show ?case
      by (cases b) (auto simp: All_less_Suc2 diff_mult_distrib
          dotprod_commute dotprod_pointwise_le_right)
  qed simp
qed

lemma sum_list_vdiff_distr [simp]:
  assumes "v \<le>\<^sub>v u"
  shows "sum_list (u -\<^sub>v v) = sum_list u - sum_list v"
  by (metis (no_types, lifting) assms diff_zero dotprod_1_right
      length_map length_replicate length_upt
      less_eq_def vdiff_def vdiff_dotprod_distr)

lemma vdiff_le:
  assumes "v \<le>\<^sub>v w"
    and "length v = length x"
  shows "v -\<^sub>v x \<le>\<^sub>v w"
  using assms by (auto simp add: less_eq_def vdiff_def)

lemma mods_with_vec:
  assumes "v <\<^sub>v w"
    and "0 \<notin> set b"
    and "length b = length w"
    and "(v \<bullet> b) mod a = (w \<bullet> b) mod a"
  shows "((w -\<^sub>v v) \<bullet> b) mod a = 0"
proof -
  have *: "v \<bullet> b < w \<bullet> b"
    using dotprod_less_left and assms by blast
  have "v \<le>\<^sub>v w"
    using assms by auto
  from vdiff_dotprod_distr [OF assms(3) this]
  have "((w -\<^sub>v v) \<bullet> b) mod a = (w \<bullet> b - v \<bullet> b) mod a "
    by simp
  also have "... = 0 mod a"
    using mods_with_nats [of "v \<bullet> b" "w \<bullet> b" "1" a, OF *] assms by auto
  finally show ?thesis by simp
qed

lemma mods_with_vec_2:
  assumes "v <\<^sub>v w"
    and "0 \<notin> set b"
    and "length b = length w"
    and "(b \<bullet> v) mod a = (b \<bullet> w) mod a"
  shows "(b \<bullet> (w -\<^sub>v v)) mod a = 0"
  by (metis (no_types, lifting) assms diff_zero dotprod_commute
      length_map length_upt less_eq_def order_vec.less_imp_le
      mods_with_vec vdiff_def)

subsection \<open>The Lexicographic Order on Vectors\<close>

abbreviation lex_less_than ("_/ <\<^sub>l\<^sub>e\<^sub>x _" [51, 51] 50)
  where
    "xs <\<^sub>l\<^sub>e\<^sub>x ys \<equiv> (xs, ys) \<in> lex less_than"

definition rlex (infix "<\<^sub>r\<^sub>l\<^sub>e\<^sub>x" 50)
  where
    "xs <\<^sub>r\<^sub>l\<^sub>e\<^sub>x ys \<longleftrightarrow> rev xs <\<^sub>l\<^sub>e\<^sub>x rev ys"

lemma rev_le [simp]:
  "rev xs \<le>\<^sub>v rev ys \<longleftrightarrow> xs \<le>\<^sub>v ys"
proof -
  { fix i assume i: "i < length ys" and [simp]: "length xs = length ys"
      and "\<forall>i < length ys. rev xs ! i \<le> rev ys ! i"
    then have "rev xs ! (length ys - i - 1) \<le> rev ys ! (length ys - i - 1)" by auto
    then have "xs ! i \<le> ys ! i" using i by (auto simp: rev_nth) }
  then show ?thesis by (auto simp: less_eq_def rev_nth)
qed

lemma rev_less [simp]:
  "rev xs <\<^sub>v rev ys \<longleftrightarrow> xs <\<^sub>v ys"
  by (simp add: less_def)

lemma less_imp_lex:
  assumes "xs <\<^sub>v ys" shows "xs <\<^sub>l\<^sub>e\<^sub>x ys"
proof -
  have "length ys = length xs" using assms by auto
  then show ?thesis using assms
    by (induct rule: list_induct2) (auto simp: less_Cons)
qed

lemma less_imp_rlex:
  assumes "xs <\<^sub>v ys" shows "xs <\<^sub>r\<^sub>l\<^sub>e\<^sub>x ys"
  using assms and less_imp_lex [of "rev xs" "rev ys"]
  by (simp add: rlex_def)

lemma lex_not_sym:
  assumes "xs <\<^sub>l\<^sub>e\<^sub>x ys"
  shows "\<not> ys <\<^sub>l\<^sub>e\<^sub>x xs"
proof
  assume "ys <\<^sub>l\<^sub>e\<^sub>x xs"
  then obtain i where "i < length xs" and "take i xs = take i ys"
    and "ys ! i < xs ! i" by (elim lex_take_index) auto
  moreover obtain j where "j < length xs" and "length ys = length xs" and "take j xs = take j ys"
    and "xs ! j < ys ! j" using assms by (elim lex_take_index) auto
  ultimately show False by (metis le_antisym nat_less_le nat_neq_iff nth_take)
qed

lemma rlex_not_sym:
  assumes "xs <\<^sub>r\<^sub>l\<^sub>e\<^sub>x ys"
  shows "\<not> ys <\<^sub>r\<^sub>l\<^sub>e\<^sub>x xs"
proof
  assume ass: "ys <\<^sub>r\<^sub>l\<^sub>e\<^sub>x xs"
  then obtain i where "i < length xs" and "take i xs = take i ys"
    and "ys ! i > xs ! i" using assms lex_not_sym rlex_def by blast
  moreover obtain j where "j < length xs" and "length ys = length xs" and "take j xs = take j ys"
    and "xs ! j > ys ! j" using assms rlex_def ass lex_not_sym by blast
  ultimately show False
    by (metis leD nat_less_le nat_neq_iff nth_take)
qed

lemma lex_trans:
  assumes "x <\<^sub>l\<^sub>e\<^sub>x y" and "y <\<^sub>l\<^sub>e\<^sub>x z"
  shows "x <\<^sub>l\<^sub>e\<^sub>x z"
proof -
  from assms obtain i and j where "length y = length x" and "length z = length x"
     and "i < length x" and "j < length x"
     and "take i x = take i y" and "take j y = take j z"
     and "x ! i < y ! i" and "y ! j < z ! j" by (fastforce elim!: lex_take_index)
  then show ?thesis
    apply (intro lexI [where i = "min i j"])
       apply (auto)
     apply (metis min.commute take_take)
    apply (auto simp: min_def)
     apply (metis dual_order.order_iff_strict dual_order.trans not_le nth_take)
    by (metis not_less nth_take)
qed

lemma rlex_trans:
  assumes "x <\<^sub>r\<^sub>l\<^sub>e\<^sub>x y" and "y <\<^sub>r\<^sub>l\<^sub>e\<^sub>x z"
  shows "x <\<^sub>r\<^sub>l\<^sub>e\<^sub>x z"
  using assms lex_trans rlex_def by blast

lemma lex_append_rightD:
  assumes "xs @ us <\<^sub>l\<^sub>e\<^sub>x ys @ vs" and "length xs = length ys"
    and "\<not> xs <\<^sub>l\<^sub>e\<^sub>x ys"
  shows "ys = xs \<and> us <\<^sub>l\<^sub>e\<^sub>x vs"
  using assms(2,1,3)
  by (induct xs ys rule: list_induct2) simp_all

lemma rlex_Cons:
  "x # xs <\<^sub>r\<^sub>l\<^sub>e\<^sub>x y # ys \<longleftrightarrow> xs <\<^sub>r\<^sub>l\<^sub>e\<^sub>x ys \<or> ys = xs \<and> x < y" (is "?A = ?B")
  by (cases "length ys = length xs")
    (auto simp: rlex_def intro: lex_append_rightI lex_append_leftI dest: lex_append_rightD lex_lengthD)

lemma rlex_irrefl:
  "\<not> x <\<^sub>r\<^sub>l\<^sub>e\<^sub>x x"
  by (induct x) (auto simp: rlex_def dest: lex_append_rightD)

subsection \<open>Code Equations\<close>

fun exists2
  where
    "exists2 d P [] [] \<longleftrightarrow> False"
  | "exists2 d P (x#xs) (y#ys) \<longleftrightarrow> P x y \<or> exists2 d P xs ys"
  | "exists2 d P _ _ \<longleftrightarrow> d"

lemma not_le_code [code_unfold]: "\<not> xs \<le>\<^sub>v ys \<longleftrightarrow> exists2 True (>) xs ys"
  by (induct "True" "(>) :: nat \<Rightarrow> nat \<Rightarrow> bool" xs ys rule: exists2.induct) (auto simp: le_Cons)

end


header {* The Free Group *}

theory "FreeGroups"
imports
   "~~/src/HOL/Algebra/Group"
   "Cancelation"
   "Generators"
begin

text {*
Based on the work in @{theory Cancelation}, the free group is now easily defined
over the set of fully canceled words with the corresponding operations.
*}

subsection {* Inversion *}

text {*
To define the inverse of a word, we first create a helper function that inverts
a single generator, and show that it is self-inverse.
*}

definition inv1 :: "'a g_i \<Rightarrow> 'a g_i"
 where "inv1 = apfst Not"

lemma inv1_inv1: "inv1 \<circ> inv1 = id"
  by (simp add: fun_eq_iff comp_def inv1_def)

lemmas inv1_inv1_simp [simp] = inv1_inv1[unfolded id_def]

lemma snd_inv1: "snd \<circ> inv1 = snd"
  by(simp add: fun_eq_iff comp_def inv1_def)

text {*
The inverse of a word is obtained by reversing the order of the generators and
inverting each generator using @{term inv1}. Some properties of @{term inv_fg}
are noted.
*}

definition inv_fg :: "'a word_g_i \<Rightarrow> 'a word_g_i"
 where "inv_fg l = rev (map inv1 l)"

lemma inv_idemp: "inv_fg (inv_fg l) = l"
  by (auto simp add:inv_fg_def rev_map)

lemma inv_fg_cancel: "normalize (l @ inv_fg l) = []"
proof(induct l rule:rev_induct)
  case Nil thus ?case
    by (auto simp add: inv_fg_def)
next
  case (snoc x xs)
  have "canceling x (inv1 x)" by (simp add:inv1_def canceling_def)
  moreover
  let ?i = "length xs"
  have "Suc ?i < length xs + 1 + 1 + length xs"
    by auto
  moreover
  have "inv_fg (xs @ [x]) = [inv1 x] @ inv_fg xs"
    by (auto simp add:inv_fg_def)
  ultimately
  have "cancels_to_1_at ?i (xs @ [x] @ (inv_fg (xs @ [x]))) (xs @ inv_fg xs)"
    by (auto simp add:cancels_to_1_at_def cancel_at_def nth_append)
  hence "cancels_to_1 (xs @ [x] @ (inv_fg (xs @ [x]))) (xs @ inv_fg xs)"
    by (auto simp add: cancels_to_1_def)
  hence "cancels_to (xs @ [x] @ (inv_fg (xs @ [x]))) (xs @ inv_fg xs)"
    by (auto simp add:cancels_to_def)
  with `normalize (xs @ (inv_fg xs)) = []`
  show "normalize ((xs @ [x]) @ (inv_fg (xs @ [x]))) = []"
    by auto
qed

lemma inv_fg_cancel2: "normalize (inv_fg l @ l) = []"
proof-
  have "normalize (inv_fg l @ inv_fg (inv_fg l)) = []" by (rule inv_fg_cancel)
  thus "normalize (inv_fg l @ l) = []" by (simp add: inv_idemp)
qed

lemma canceled_rev:
  assumes "canceled l"
  shows "canceled (rev l)"
proof(rule ccontr)
  assume "\<not>canceled (rev l)"
  hence "DomainP cancels_to_1 (rev l)" by (simp add: canceled_def)
  then obtain l' where "cancels_to_1 (rev l) l'" by auto
  then obtain i where "cancels_to_1_at i (rev l) l'" by (auto simp add:cancels_to_1_def)
  hence "Suc i < length (rev l)"
    and "canceling (rev l ! i) (rev l ! Suc i)"
    by (auto simp add:cancels_to_1_at_def)
  let ?x = "length l - i - 2"
  from `Suc i < length (rev l)`
  have "Suc ?x < length l" by auto
  moreover
  from `Suc i < length (rev l)`
  have "i < length l" and "length l - Suc i = Suc(length l - Suc (Suc i))" by auto
  hence "rev l ! i = l ! Suc ?x" and "rev l ! Suc i = l ! ?x"
    by (auto simp add: rev_nth map_nth)
  with `canceling (rev l ! i) (rev l ! Suc i)`
  have "canceling (l ! Suc ?x) (l ! ?x)" by auto
  hence "canceling (l ! ?x) (l ! Suc ?x)" by (rule cancel_sym)
  hence "canceling (l ! ?x) (l ! Suc ?x)" by simp
  ultimately
  have "cancels_to_1_at ?x l (cancel_at ?x l)"
    by (auto simp add:cancels_to_1_at_def)
  hence "cancels_to_1 l (cancel_at ?x l)"
    by (auto simp add:cancels_to_1_def)
  hence "\<not>canceled l"
    by (auto simp add:canceled_def)
  with `canceled l` show False by contradiction
qed

lemma inv_fg_closure1:
  assumes "canceled l"
  shows "canceled (inv_fg l)"
unfolding inv_fg_def and inv1_def and apfst_def
proof-
  have "inj Not" by (auto intro:injI)
  moreover
  have "inj_on id (snd ` set l)" by auto
  ultimately
  have "canceled (map (map_prod Not id) l)"
    using `canceled l`
    by -(rule rename_gens_canceled)
  thus "canceled (rev (map (map_prod Not id) l))" by (rule canceled_rev)
qed

subsection {* The definition *}

text {*
Finally, we can define the Free Group over a set of generators, and show that it
is indeed a group.
*}

definition free_group :: "'a set => ((bool * 'a) list) monoid" ("\<F>\<index>")
where
  "\<F>\<^bsub>gens\<^esub> \<equiv> \<lparr>
     carrier = {l\<in>lists (UNIV \<times> gens). canceled l },
     mult = \<lambda> x y. normalize (x @ y),
     one = []
  \<rparr>"

lemma occuring_gens_in_element:
  "x \<in> carrier \<F>\<^bsub>gens\<^esub> \<Longrightarrow> x \<in> lists (UNIV \<times> gens)"
by(auto simp add:free_group_def)

theorem free_group_is_group: "group \<F>\<^bsub>gens\<^esub>"
proof
  fix x y
  assume "x \<in> carrier \<F>\<^bsub>gens\<^esub>" hence x: "x \<in> lists (UNIV \<times> gens)" by
    (rule occuring_gens_in_element)
  assume "y \<in> carrier \<F>\<^bsub>gens\<^esub>" hence y: "y \<in> lists (UNIV \<times> gens)" by
    (rule occuring_gens_in_element)
  from x and y
  have "x \<otimes>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> y \<in> lists (UNIV \<times> gens)"
    by (auto intro!: normalize_preserves_generators simp add:free_group_def append_in_lists_conv)
  thus "x \<otimes>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> y \<in> carrier \<F>\<^bsub>gens\<^esub>"
    by (auto simp add:free_group_def)
next
  fix x y z
  have "cancels_to (x @ y) (normalize (x @ (y::'a word_g_i)))"
   and "cancels_to z (z::'a word_g_i)"
    by auto
  hence "normalize (normalize (x @ y) @ z) = normalize ((x @ y) @ z)"
    by (rule normalize_append_cancel_to[THEN sym])
  also
  have "\<dots> = normalize (x @ (y @ z))" by auto
  also
  have "cancels_to (y @ z) (normalize (y @ (z::'a word_g_i)))"
   and "cancels_to x (x::'a word_g_i)"
    by auto
  hence "normalize (x @ (y @ z)) = normalize (x @ normalize (y @ z))"
    by -(rule normalize_append_cancel_to)
  finally
  show "x \<otimes>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> y \<otimes>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> z =
        x \<otimes>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> (y \<otimes>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> z)"
    by (auto simp add:free_group_def)
next
  show "\<one>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> \<in> carrier \<F>\<^bsub>gens\<^esub>"
    by (auto simp add:free_group_def)
next
  fix x
  assume "x \<in> carrier \<F>\<^bsub>gens\<^esub>"
  thus "\<one>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> \<otimes>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> x = x"
    by (auto simp add:free_group_def)
next
  fix x
  assume "x \<in> carrier \<F>\<^bsub>gens\<^esub>"
  thus "x \<otimes>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> \<one>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> = x"
    by (auto simp add:free_group_def)
next
  show "carrier \<F>\<^bsub>gens\<^esub> \<subseteq> Units \<F>\<^bsub>gens\<^esub>"
  proof (simp add:free_group_def Units_def, rule subsetI)
    fix x :: "'a word_g_i"
    let ?x' = "inv_fg x"
    assume "x \<in> {y\<in>lists(UNIV\<times>gens). canceled y}"
    hence "?x' \<in> lists(UNIV\<times>gens) \<and> canceled ?x'"
      by (auto elim:inv_fg_closure1 simp add:inv_fg_closure2)
    moreover
    have "normalize (?x' @ x) = []"
     and "normalize (x @ ?x') = []"
      by (auto simp add:inv_fg_cancel inv_fg_cancel2)
    ultimately
    have "\<exists>y. y \<in> lists (UNIV \<times> gens) \<and>
                  canceled y \<and>
                  normalize (y @ x) = [] \<and> normalize (x @ y) = []"
      by auto
    with `x \<in> {y\<in>lists(UNIV\<times>gens). canceled y}`
    show "x \<in> {y \<in> lists (UNIV \<times> gens).  canceled y  \<and>
          (\<exists>x. x \<in> lists (UNIV \<times> gens) \<and>
                  canceled x \<and>
                  normalize (x @ y) = [] \<and> normalize (y @ x) = [])}"
      by auto
  qed
qed

lemma inv_is_inv_fg[simp]:
  "x \<in> carrier \<F>\<^bsub>gens\<^esub> \<Longrightarrow> inv\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> x = inv_fg x"
by (rule group.inv_equality,auto simp add:free_group_is_group,auto simp add: free_group_def inv_fg_cancel inv_fg_cancel2 inv_fg_closure1 inv_fg_closure2)

subsection {* The universal property *}

text {* Free Groups are important due to their universal property: Every map of
the set of generators to another group can be extended uniquely to an
homomorphism from the Free Group. *}

definition insert ("\<iota>")
  where "\<iota> g = [(False, g)]"

lemma insert_closed:
  "g \<in> gens \<Longrightarrow> \<iota> g \<in> carrier \<F>\<^bsub>gens\<^esub>"
  by (auto simp add:insert_def free_group_def)

definition (in group) lift_gi
  where "lift_gi f gi = (if fst gi then inv (f (snd gi)) else f (snd gi))"

lemma (in group) lift_gi_closed:
  assumes cl: "f \<in> gens \<rightarrow> carrier G"
      and "snd gi \<in> gens"
  shows "lift_gi f gi \<in> carrier G"
using assms by (auto simp add:lift_gi_def)

definition (in group) lift
  where "lift f w = m_concat (map (lift_gi f) w)"

lemma (in group) lift_nil[simp]: "lift f [] = \<one>"
 by (auto simp add:lift_def)

lemma (in group) lift_closed[simp]:
  assumes cl: "f \<in> gens \<rightarrow> carrier G"
      and "x \<in> lists (UNIV \<times> gens)"
  shows "lift f x \<in> carrier G"
proof-
  have "set (map (lift_gi f) x) \<subseteq> carrier G"
    using `x \<in> lists (UNIV \<times> gens)`
    by (auto simp add:lift_gi_closed[OF cl])
  thus "lift f x \<in> carrier G"
    by (auto simp add:lift_def)
qed

lemma (in group) lift_append[simp]:
  assumes cl: "f \<in> gens \<rightarrow> carrier G"
      and "x \<in> lists (UNIV \<times> gens)"
      and "y \<in> lists (UNIV \<times> gens)"
  shows "lift f (x @ y) = lift f x \<otimes> lift f y"
proof-
  from `x \<in> lists (UNIV \<times> gens)`
  have "set (map snd x) \<subseteq> gens" by auto
  hence "set (map (lift_gi f) x) \<subseteq> carrier G"
    by (induct x)(auto simp add:lift_gi_closed[OF cl])
  moreover
  from `y \<in> lists (UNIV \<times> gens)`
  have "set (map snd y) \<subseteq> gens" by auto
  hence "set (map (lift_gi f) y) \<subseteq> carrier G"
    by (induct y)(auto simp add:lift_gi_closed[OF cl])
  ultimately
  show "lift f (x @ y) = lift f x \<otimes> lift f y"
    by (auto simp add:lift_def m_assoc simp del:set_map foldr_append)
qed

lemma (in group) lift_cancels_to:
  assumes "cancels_to x y"
      and "x \<in> lists (UNIV \<times> gens)"
      and cl: "f \<in> gens \<rightarrow> carrier G"
  shows "lift f x = lift f y"
using assms
unfolding cancels_to_def
proof(induct rule:rtranclp_induct)
  case (step y z)
    from `cancels_to_1\<^sup>*\<^sup>* x y`
    and `x \<in> lists (UNIV \<times> gens)`
    have "y \<in> lists (UNIV \<times> gens)"
      by -(rule cancels_to_preserves_generators, simp add:cancels_to_def)
    hence "lift f x = lift f y"
      using step by auto
    also
    from `cancels_to_1 y z`
    obtain ys1 y1 y2 ys2
      where y: "y = ys1 @ y1 # y2 # ys2"
      and "z = ys1 @ ys2"
      and "canceling y1 y2"
    by (rule cancels_to_1_unfold)
    have "lift f y  = lift f (ys1 @ [y1] @ [y2] @ ys2)"
      using y by simp
    also
    from y and cl and `y \<in> lists (UNIV \<times> gens)`
    have "lift f (ys1 @ [y1] @ [y2] @ ys2)
        = lift f ys1 \<otimes> (lift f [y1] \<otimes> lift f [y2]) \<otimes> lift f ys2"
      by (auto intro:lift_append[OF cl] simp del: append_Cons simp add:m_assoc iff:lists_eq_set)
    also
    from cl[THEN funcset_image]
     and y and `y \<in> lists (UNIV \<times> gens)`
     and `canceling y1 y2`
    have "(lift f [y1] \<otimes> lift f [y2]) = \<one>"
      by (auto simp add:lift_def lift_gi_def canceling_def iff:lists_eq_set)
    hence "lift f ys1 \<otimes> (lift f [y1] \<otimes> lift f [y2]) \<otimes> lift f ys2
           = lift f ys1 \<otimes> \<one> \<otimes> lift f ys2"
      by simp
    also
    from y and `y \<in> lists (UNIV \<times> gens)`
     and cl
     have "lift f ys1 \<otimes> \<one> \<otimes> lift f ys2 = lift f (ys1 @ ys2)"
      by (auto intro:lift_append iff:lists_eq_set)
    also
    from `z = ys1 @ ys2`
    have "lift f (ys1 @ ys2) = lift f z" by simp
    finally show "lift f x = lift f z" .
qed auto

lemma (in group) lift_is_hom:
  assumes cl: "f \<in> gens \<rightarrow> carrier G"
  shows "lift f \<in> hom \<F>\<^bsub>gens\<^esub> G"
proof-
  {
    fix x
    assume "x \<in> carrier \<F>\<^bsub>gens\<^esub>"
    hence "x \<in> lists (UNIV \<times> gens)"
      unfolding free_group_def by simp
    hence "lift f x \<in> carrier G"
     by (induct x, auto simp add:lift_def lift_gi_closed[OF cl])
  }
  moreover
  { fix x
    assume "x \<in> carrier \<F>\<^bsub>gens\<^esub>"
    fix y
    assume "y \<in> carrier \<F>\<^bsub>gens\<^esub>"

    from `x \<in> carrier \<F>\<^bsub>gens\<^esub>` and `y \<in> carrier \<F>\<^bsub>gens\<^esub>`
    have "x \<in> lists (UNIV \<times> gens)" and "y \<in> lists (UNIV \<times> gens)"
      by (auto simp add:free_group_def)

    have "cancels_to (x @ y) (normalize (x @ y))" by simp
    from `x \<in> lists (UNIV \<times> gens)` and `y \<in> lists (UNIV \<times> gens)`
     and lift_cancels_to[THEN sym, OF `cancels_to (x @ y) (normalize (x @ y))`] and cl
    have "lift f (x \<otimes>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> y) = lift f (x @ y)"
      by (auto simp add:free_group_def iff:lists_eq_set)
    also
    from `x \<in> lists (UNIV \<times> gens)` and `y \<in> lists (UNIV \<times> gens)` and cl
    have "lift f (x @ y) = lift f x \<otimes> lift f y"
      by simp
    finally
    have "lift f (x \<otimes>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> y) = lift f x \<otimes> lift f y" .
  }
  ultimately
  show "lift f \<in> hom \<F>\<^bsub>gens\<^esub> G"
    by auto
qed

lemma gens_span_free_group:
shows "\<langle>\<iota> ` gens\<rangle>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> = carrier \<F>\<^bsub>gens\<^esub>"
proof
  interpret group "\<F>\<^bsub>gens\<^esub>" by (rule free_group_is_group)
  show "\<langle>\<iota> ` gens\<rangle>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> \<subseteq> carrier \<F>\<^bsub>gens\<^esub>"
  by(rule gen_span_closed, auto simp add:insert_def free_group_def)

  show "carrier \<F>\<^bsub>gens\<^esub>  \<subseteq> \<langle>\<iota> ` gens\<rangle>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub>"
  proof
    fix x
    show "x \<in> carrier \<F>\<^bsub>gens\<^esub> \<Longrightarrow> x \<in> \<langle>\<iota> ` gens\<rangle>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub>"
    proof(induct x)
    case Nil
      have "one \<F>\<^bsub>gens\<^esub> \<in> \<langle>\<iota> ` gens\<rangle>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub>"
        by simp
      thus "[] \<in> \<langle>\<iota> ` gens\<rangle>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub>"
        by (simp add:free_group_def)
    next
    case (Cons a x)
      from `a # x \<in> carrier \<F>\<^bsub>gens\<^esub>`
      have "x \<in> carrier \<F>\<^bsub>gens\<^esub>"
        by (auto intro:cons_canceled simp add:free_group_def)
      hence "x \<in> \<langle>\<iota> ` gens\<rangle>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub>"
        using Cons by simp
      moreover

      from `a # x \<in> carrier \<F>\<^bsub>gens\<^esub>`
      have "snd a \<in> gens"
        by (auto simp add:free_group_def)
      hence isa: "\<iota> (snd a) \<in> \<langle>\<iota> ` gens\<rangle>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub>"
        by (auto simp add:insert_def intro:gen_gens)
      have "[a] \<in> \<langle>\<iota> ` gens\<rangle>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub>"
      proof(cases "fst a")
        case False
          hence "[a] = \<iota> (snd a)" by (cases a, auto simp add:insert_def)
           with isa show "[a] \<in> \<langle>\<iota> ` gens\<rangle>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub>" by simp
       next
        case True
          from `snd a \<in> gens`
          have "\<iota> (snd a) \<in> carrier \<F>\<^bsub>gens\<^esub>"
            by (auto simp add:free_group_def insert_def)
          with True
          have "[a] = inv\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> (\<iota> (snd a))"
            by (cases a, auto simp add:insert_def inv_fg_def inv1_def)
          moreover
          from isa
          have "inv\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> (\<iota> (snd a)) \<in> \<langle>\<iota> ` gens\<rangle>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub>"
            by (auto intro:gen_inv)
          ultimately
          show "[a] \<in> \<langle>\<iota> ` gens\<rangle>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub>"
            by simp
      qed
      ultimately
      have "mult \<F>\<^bsub>gens\<^esub> [a] x \<in> \<langle>\<iota> ` gens\<rangle>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub>"
        by (auto intro:gen_mult)
      with
      `a # x \<in> carrier \<F>\<^bsub>gens\<^esub>`
      show "a # x \<in> \<langle>\<iota> ` gens\<rangle>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub>" by (simp add:free_group_def)
    qed
  qed
qed

lemma (in group) lift_is_unique:
  assumes "group G"
  and cl: "f \<in> gens \<rightarrow> carrier G"
  and "h \<in> hom \<F>\<^bsub>gens\<^esub> G"
  and "\<forall> g \<in> gens. h (\<iota> g) = f g"
  shows "\<forall>x \<in> carrier \<F>\<^bsub>gens\<^esub>. h x = lift f x"
unfolding gens_span_free_group[THEN sym]
proof(rule hom_unique_on_span[of "\<F>\<^bsub>gens\<^esub>" G])
  show "group \<F>\<^bsub>gens\<^esub>" by (rule free_group_is_group)
next
  show "group G" by fact
next
  show "\<iota> ` gens \<subseteq> carrier \<F>\<^bsub>gens\<^esub>"
    by(auto intro:insert_closed)
next
  show "h \<in> hom \<F>\<^bsub>gens\<^esub> G" by fact
next
  show "lift f \<in> hom \<F>\<^bsub>gens\<^esub> G" by (rule lift_is_hom[OF cl])
next
  from `\<forall>g\<in> gens. h (\<iota> g) = f g` and cl[THEN funcset_image]
  show "\<forall>g\<in> \<iota> ` gens. h g = lift f g"
    by(auto simp add:insert_def lift_def lift_gi_def)
qed

end


(*  Title:      HOL/MicroJava/BV/Semilat.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM

Semilattices.
*)

chapter \<open>Data Flow Analysis Framework \label{cha:bv}\<close>

section \<open>Semilattices\<close>

theory Semilat
imports Main "HOL-Library.While_Combinator"
begin

type_synonym 'a ord    = "'a \<Rightarrow> 'a \<Rightarrow> bool"
type_synonym 'a binop  = "'a \<Rightarrow> 'a \<Rightarrow> 'a"
type_synonym 'a sl     = "'a set \<times> 'a ord \<times> 'a binop"

definition lesub :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool"
  where "lesub x r y \<longleftrightarrow> r x y"

definition lesssub :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool"
  where "lesssub x r y \<longleftrightarrow> lesub x r y \<and> x \<noteq> y"

definition plussub :: "'a \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b \<Rightarrow> 'c"
  where "plussub x f y = f x y"

notation (ASCII)
  "lesub"  ("(_ /<='__ _)" [50, 1000, 51] 50) and
  "lesssub"  ("(_ /<'__ _)" [50, 1000, 51] 50) and
  "plussub"  ("(_ /+'__ _)" [65, 1000, 66] 65)

notation
  "lesub"  ("(_ /\<sqsubseteq>\<^bsub>_\<^esub> _)" [50, 0, 51] 50) and
  "lesssub"  ("(_ /\<sqsubset>\<^bsub>_\<^esub> _)" [50, 0, 51] 50) and
  "plussub"  ("(_ /\<squnion>\<^bsub>_\<^esub> _)" [65, 0, 66] 65)

(* allow \<sub> instead of \<bsub>..\<esub> *)
abbreviation (input)
  lesub1 :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool" ("(_ /\<sqsubseteq>\<^sub>_ _)" [50, 1000, 51] 50)
  where "x \<sqsubseteq>\<^sub>r y == x \<sqsubseteq>\<^bsub>r\<^esub> y"

abbreviation (input)
  lesssub1 :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool" ("(_ /\<sqsubset>\<^sub>_ _)" [50, 1000, 51] 50)
  where "x \<sqsubset>\<^sub>r y == x \<sqsubset>\<^bsub>r\<^esub> y"

abbreviation (input)
  plussub1 :: "'a \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b \<Rightarrow> 'c" ("(_ /\<squnion>\<^sub>_ _)" [65, 1000, 66] 65)
  where "x \<squnion>\<^sub>f y == x \<squnion>\<^bsub>f\<^esub> y"

definition ord :: "('a \<times> 'a) set \<Rightarrow> 'a ord"
where
  "ord r = (\<lambda>x y. (x,y) \<in> r)"

definition order :: "'a ord \<Rightarrow> bool"
where
  "order r \<longleftrightarrow> (\<forall>x. x \<sqsubseteq>\<^sub>r x) \<and> (\<forall>x y. x \<sqsubseteq>\<^sub>r y \<and> y \<sqsubseteq>\<^sub>r x \<longrightarrow> x=y) \<and> (\<forall>x y z. x \<sqsubseteq>\<^sub>r y \<and> y \<sqsubseteq>\<^sub>r z \<longrightarrow> x \<sqsubseteq>\<^sub>r z)"

definition top :: "'a ord \<Rightarrow> 'a \<Rightarrow> bool"
where
  "top r T \<longleftrightarrow> (\<forall>x. x \<sqsubseteq>\<^sub>r T)"

definition acc :: "'a set \<Rightarrow> 'a ord \<Rightarrow> bool"
where
  "acc A r \<longleftrightarrow> wf {(y,x). x \<in> A \<and> y \<in> A \<and> x \<sqsubset>\<^sub>r y}"

definition closed :: "'a set \<Rightarrow> 'a binop \<Rightarrow> bool"
where
  "closed A f \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>A. x \<squnion>\<^sub>f y \<in> A)"

definition semilat :: "'a sl \<Rightarrow> bool"
where
  "semilat = (\<lambda>(A,r,f). order r \<and> closed A f \<and>
                       (\<forall>x\<in>A. \<forall>y\<in>A. x \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y) \<and>
                       (\<forall>x\<in>A. \<forall>y\<in>A. y \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y) \<and>
                       (\<forall>x\<in>A. \<forall>y\<in>A. \<forall>z\<in>A. x \<sqsubseteq>\<^sub>r z \<and> y \<sqsubseteq>\<^sub>r z \<longrightarrow> x \<squnion>\<^sub>f y \<sqsubseteq>\<^sub>r z))"

definition is_ub :: "('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
where
  "is_ub r x y u \<longleftrightarrow> (x,u)\<in>r \<and> (y,u)\<in>r"

definition is_lub :: "('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
where
  "is_lub r x y u \<longleftrightarrow> is_ub r x y u \<and> (\<forall>z. is_ub r x y z \<longrightarrow> (u,z)\<in>r)"

definition some_lub :: "('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"
where
  "some_lub r x y = (SOME z. is_lub r x y z)"

locale Semilat =
  fixes A :: "'a set"
  fixes r :: "'a ord"
  fixes f :: "'a binop"
  assumes semilat: "semilat (A, r, f)"

lemma order_refl [simp, intro]: "order r \<Longrightarrow> x \<sqsubseteq>\<^sub>r x"
  (*<*) by (unfold order_def) (simp (no_asm_simp)) (*>*)

lemma order_antisym: "\<lbrakk> order r; x \<sqsubseteq>\<^sub>r y; y \<sqsubseteq>\<^sub>r x \<rbrakk> \<Longrightarrow> x = y"
  (*<*) by (unfold order_def) (simp (no_asm_simp)) (*>*)

lemma order_trans: "\<lbrakk> order r; x \<sqsubseteq>\<^sub>r y; y \<sqsubseteq>\<^sub>r z \<rbrakk> \<Longrightarrow> x \<sqsubseteq>\<^sub>r z"
  (*<*) by (unfold order_def) blast (*>*)

lemma order_less_irrefl [intro, simp]: "order r \<Longrightarrow> \<not> x \<sqsubset>\<^sub>r x"
  (*<*) by (unfold order_def lesssub_def) blast (*>*)

lemma order_less_trans: "\<lbrakk> order r; x \<sqsubset>\<^sub>r y; y \<sqsubset>\<^sub>r z \<rbrakk> \<Longrightarrow> x \<sqsubset>\<^sub>r z"
  (*<*) by (unfold order_def lesssub_def) blast (*>*)

lemma topD [simp, intro]: "top r T \<Longrightarrow> x \<sqsubseteq>\<^sub>r T"
  (*<*) by (simp add: top_def) (*>*)

lemma top_le_conv [simp]: "\<lbrakk> order r; top r T \<rbrakk> \<Longrightarrow> (T \<sqsubseteq>\<^sub>r x) = (x = T)"
  (*<*) by (blast intro: order_antisym) (*>*)

lemma semilat_Def:
"semilat(A,r,f) \<longleftrightarrow> order r \<and> closed A f \<and>
                 (\<forall>x\<in>A. \<forall>y\<in>A. x \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y) \<and>
                 (\<forall>x\<in>A. \<forall>y\<in>A. y \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y) \<and>
                 (\<forall>x\<in>A. \<forall>y\<in>A. \<forall>z\<in>A. x \<sqsubseteq>\<^sub>r z \<and> y \<sqsubseteq>\<^sub>r z \<longrightarrow> x \<squnion>\<^sub>f y \<sqsubseteq>\<^sub>r z)"
  (*<*) by (unfold semilat_def) clarsimp (*>*)

lemma (in Semilat) orderI [simp, intro]: "order r"
  (*<*) using semilat by (simp add: semilat_Def) (*>*)

lemma (in Semilat) closedI [simp, intro]: "closed A f"
  (*<*) using semilat by (simp add: semilat_Def) (*>*)

lemma closedD: "\<lbrakk> closed A f; x\<in>A; y\<in>A \<rbrakk> \<Longrightarrow> x \<squnion>\<^sub>f y \<in> A"
  (*<*) by (unfold closed_def) blast (*>*)

lemma closed_UNIV [simp]: "closed UNIV f"
  (*<*) by (simp add: closed_def) (*>*)

lemma (in Semilat) closed_f [simp, intro]: "\<lbrakk>x \<in> A; y \<in> A\<rbrakk>  \<Longrightarrow> x \<squnion>\<^sub>f y \<in> A"
  (*<*) by (simp add: closedD [OF closedI]) (*>*)

lemma (in Semilat) refl_r [intro, simp]: "x \<sqsubseteq>\<^sub>r x" by simp

lemma (in Semilat) antisym_r [intro?]: "\<lbrakk> x \<sqsubseteq>\<^sub>r y; y \<sqsubseteq>\<^sub>r x \<rbrakk> \<Longrightarrow> x = y"
  (*<*) by (rule order_antisym) auto (*>*)

lemma (in Semilat) trans_r [trans, intro?]: "\<lbrakk>x \<sqsubseteq>\<^sub>r y; y \<sqsubseteq>\<^sub>r z\<rbrakk> \<Longrightarrow> x \<sqsubseteq>\<^sub>r z"
  (*<*) by (auto intro: order_trans) (*>*)

lemma (in Semilat) ub1 [simp, intro?]: "\<lbrakk> x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> x \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y"
  (*<*) by (insert semilat) (unfold semilat_Def, simp) (*>*)

lemma (in Semilat) ub2 [simp, intro?]: "\<lbrakk> x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> y \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y"
  (*<*) by (insert semilat) (unfold semilat_Def, simp) (*>*)

lemma (in Semilat) lub [simp, intro?]:
  "\<lbrakk> x \<sqsubseteq>\<^sub>r z; y \<sqsubseteq>\<^sub>r z; x \<in> A; y \<in> A; z \<in> A \<rbrakk> \<Longrightarrow> x \<squnion>\<^sub>f y \<sqsubseteq>\<^sub>r z"
  (*<*) by (insert semilat) (unfold semilat_Def, simp) (*>*)

lemma (in Semilat) plus_le_conv [simp]:
  "\<lbrakk> x \<in> A; y \<in> A; z \<in> A \<rbrakk> \<Longrightarrow> (x \<squnion>\<^sub>f y \<sqsubseteq>\<^sub>r z) = (x \<sqsubseteq>\<^sub>r z \<and> y \<sqsubseteq>\<^sub>r z)"
  (*<*) by (blast intro: ub1 ub2 lub order_trans) (*>*)

lemma (in Semilat) le_iff_plus_unchanged:
  assumes "x \<in> A" and "y \<in> A"
  shows "x \<sqsubseteq>\<^sub>r y \<longleftrightarrow> x \<squnion>\<^sub>f y = y" (is "?P \<longleftrightarrow> ?Q")
(*<*)
proof
  assume ?P
  with assms show ?Q by (blast intro: antisym_r lub ub2)
next
  assume ?Q
  then have "y = x \<squnion>\<^bsub>f\<^esub> y" by simp
  moreover from assms have "x \<sqsubseteq>\<^bsub>r\<^esub> x \<squnion>\<^bsub>f\<^esub> y" by simp
  ultimately show ?P by simp
qed
(*>*)

lemma (in Semilat) le_iff_plus_unchanged2:
  assumes "x \<in> A" and "y \<in> A"
  shows "x \<sqsubseteq>\<^sub>r y \<longleftrightarrow> y \<squnion>\<^sub>f x = y" (is "?P \<longleftrightarrow> ?Q")
(*<*)
proof
  assume ?P
  with assms show ?Q by (blast intro: antisym_r lub ub1)
next
  assume ?Q
  then have "y = y \<squnion>\<^bsub>f\<^esub> x" by simp
  moreover from assms have "x \<sqsubseteq>\<^bsub>r\<^esub> y \<squnion>\<^bsub>f\<^esub> x" by simp
  ultimately show ?P by simp
qed
(*>*)

lemma (in Semilat) plus_assoc [simp]:
  assumes a: "a \<in> A" and b: "b \<in> A" and c: "c \<in> A"
  shows "a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c) = a \<squnion>\<^sub>f b \<squnion>\<^sub>f c"
(*<*)
proof -
  from a b have ab: "a \<squnion>\<^sub>f b \<in> A" ..
  from this c have abc: "(a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c \<in> A" ..
  from b c have bc: "b \<squnion>\<^sub>f c \<in> A" ..
  from a this have abc': "a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c) \<in> A" ..

  show ?thesis
  proof
    show "a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c) \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c"
    proof -
      from a b have "a \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f b" ..
      also from ab c have "\<dots> \<sqsubseteq>\<^sub>r \<dots> \<squnion>\<^sub>f c" ..
      finally have "a<": "a \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c" .
      from a b have "b \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f b" ..
      also from ab c have "\<dots> \<sqsubseteq>\<^sub>r \<dots> \<squnion>\<^sub>f c" ..
      finally have "b<": "b \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c" .
      from ab c have "c<": "c \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c" ..
      from "b<" "c<" b c abc have "b \<squnion>\<^sub>f c \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c" ..
      from "a<" this a bc abc show ?thesis ..
    qed
    show "(a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)"
    proof -
      from b c have "b \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f c" ..
      also from a bc have "\<dots> \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f \<dots>" ..
      finally have "b<": "b \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)" .
      from b c have "c \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f c" ..
      also from a bc have "\<dots> \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f \<dots>" ..
      finally have "c<": "c \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)" .
      from a bc have "a<": "a \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)" ..
      from "a<" "b<" a b abc' have "a \<squnion>\<^sub>f b \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)" ..
      from this "c<" ab c abc' show ?thesis ..
    qed
  qed
qed
(*>*)

lemma (in Semilat) plus_com_lemma:
  "\<lbrakk>a \<in> A; b \<in> A\<rbrakk> \<Longrightarrow> a \<squnion>\<^sub>f b \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f a"
(*<*)
proof -
  assume a: "a \<in> A" and b: "b \<in> A"
  from b a have "a \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f a" ..
  moreover from b a have "b \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f a" ..
  moreover note a b
  moreover from b a have "b \<squnion>\<^sub>f a \<in> A" ..
  ultimately show ?thesis ..
qed
(*>*)

lemma (in Semilat) plus_commutative:
  "\<lbrakk>a \<in> A; b \<in> A\<rbrakk> \<Longrightarrow> a \<squnion>\<^sub>f b = b \<squnion>\<^sub>f a"
  (*<*) by(blast intro: order_antisym plus_com_lemma) (*>*)

lemma is_lubD:
  "is_lub r x y u \<Longrightarrow> is_ub r x y u \<and> (\<forall>z. is_ub r x y z \<longrightarrow> (u,z) \<in> r)"
  (*<*) by (simp add: is_lub_def) (*>*)

lemma is_ubI:
  "\<lbrakk> (x,u) \<in> r; (y,u) \<in> r \<rbrakk> \<Longrightarrow> is_ub r x y u"
  (*<*) by (simp add: is_ub_def) (*>*)

lemma is_ubD:
  "is_ub r x y u \<Longrightarrow> (x,u) \<in> r \<and> (y,u) \<in> r"
  (*<*) by (simp add: is_ub_def) (*>*)

lemma is_lub_bigger1 [iff]:
  "is_lub (r^* ) x y y = ((x,y)\<in>r^* )"
(*<*)
  by (unfold is_lub_def is_ub_def) blast
(*>*)

lemma is_lub_bigger2 [iff]:
  "is_lub (r^* ) x y x = ((y,x)\<in>r^* )"
(*<*)
  by (unfold is_lub_def is_ub_def) blast
(*>*)

lemma extend_lub:
  assumes "single_valued r"
    and "is_lub (r\<^sup>*) x y u"
    and "(x', x) \<in> r"
  shows "\<exists>v. is_lub (r\<^sup>*) x' y v"
(*<*)
proof (cases "(y, x) \<in> r\<^sup>*")
  case True show ?thesis
  proof (cases "(y, x') \<in> r\<^sup>*")
    case True with \<open>(y, x) \<in> r\<^sup>*\<close> show ?thesis by blast
  next
    case False with True assms show ?thesis
      by (unfold is_lub_def is_ub_def) (blast elim: converse_rtranclE dest: single_valuedD)
  qed
next
  case False
  from assms have "(x', u) \<in> r\<^sup>*" and "(y, u) \<in> r\<^sup>*"
    by (auto simp add: is_lub_def is_ub_def)
  moreover from False assms have "\<And>z. (x', z) \<in> r\<^sup>* \<Longrightarrow> (y, z) \<in> r\<^sup>* \<Longrightarrow> (u, z) \<in> r\<^sup>*"
    by (unfold is_lub_def is_ub_def) (blast intro: rtrancl_into_rtrancl
      converse_rtrancl_into_rtrancl elim: converse_rtranclE dest: single_valuedD)
  ultimately have "is_lub (r\<^sup>*) x' y u"
    by (unfold is_lub_def is_ub_def) blast
  then show ?thesis ..
qed
(*>*)

lemma single_valued_has_lubs:
  assumes "single_valued r"
    and in_r: "(x, u) \<in> r\<^sup>*" "(y, u) \<in> r\<^sup>*"
  shows "\<exists>z. is_lub (r\<^sup>*) x y z"
(*<*)
using in_r proof (induct arbitrary: y rule: converse_rtrancl_induct)
  case base then show ?case by (induct rule: converse_rtrancl_induct)
    (blast, blast intro: converse_rtrancl_into_rtrancl)
next
  case step with \<open>single_valued r\<close> show ?case by (blast intro: extend_lub)
qed
(*>*)

lemma some_lub_conv:
  "\<lbrakk> acyclic r; is_lub (r^* ) x y u \<rbrakk> \<Longrightarrow> some_lub (r^* ) x y = u"
(*<*)
apply (simp only: some_lub_def is_lub_def)
apply (rule someI2)
 apply (simp only: is_lub_def)
apply (blast intro: antisymD dest!: acyclic_impl_antisym_rtrancl)
done
(*>*)

lemma is_lub_some_lub:
  "\<lbrakk> single_valued r; acyclic r; (x,u)\<in>r^*; (y,u)\<in>r^* \<rbrakk>
  \<Longrightarrow> is_lub (r^* ) x y (some_lub (r^* ) x y)"
  (*<*) by (fastforce dest: single_valued_has_lubs simp add: some_lub_conv) (*>*)

subsection\<open>An executable lub-finder\<close>

definition exec_lub :: "('a * 'a) set \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a binop"
where
  "exec_lub r f x y = while (\<lambda>z. (x,z) \<notin> r\<^sup>*) f y"

lemma exec_lub_refl: "exec_lub r f T T = T"
by (simp add: exec_lub_def while_unfold)

lemma acyclic_single_valued_finite:
 "\<lbrakk>acyclic r; single_valued r; (x,y) \<in> r\<^sup>*\<rbrakk>
  \<Longrightarrow> finite (r \<inter> {a. (x, a) \<in> r\<^sup>*} \<times> {b. (b, y) \<in> r\<^sup>*})"
(*<*)
apply(erule converse_rtrancl_induct)
 apply(rule_tac B = "{}" in finite_subset)
  apply(simp only:acyclic_def)
  apply(blast intro:rtrancl_into_trancl2 rtrancl_trancl_trancl)
 apply simp
apply(rename_tac x x')
apply(subgoal_tac "r \<inter> {a. (x,a) \<in> r\<^sup>*} \<times> {b. (b,y) \<in> r\<^sup>*} =
                   insert (x,x') (r \<inter> {a. (x', a) \<in> r\<^sup>*} \<times> {b. (b, y) \<in> r\<^sup>*})")
 apply simp
apply(blast intro:converse_rtrancl_into_rtrancl
            elim:converse_rtranclE dest:single_valuedD)
done
(*>*)

lemma exec_lub_conv:
  "\<lbrakk> acyclic r; \<forall>x y. (x,y) \<in> r \<longrightarrow> f x = y; is_lub (r\<^sup>*) x y u \<rbrakk> \<Longrightarrow>
  exec_lub r f x y = u"
(*<*)
apply(unfold exec_lub_def)
apply(rule_tac P = "\<lambda>z. (y,z) \<in> r\<^sup>* \<and> (z,u) \<in> r\<^sup>*" and
               r = "(r \<inter> {(a,b). (y,a) \<in> r\<^sup>* \<and> (b,u) \<in> r\<^sup>*})^-1" in while_rule)
    apply(blast dest: is_lubD is_ubD)
   apply(erule conjE)
   apply(erule_tac z = u in converse_rtranclE)
    apply(blast dest: is_lubD is_ubD)
   apply(blast dest:rtrancl_into_rtrancl)
  apply(rename_tac s)
  apply(subgoal_tac "is_ub (r\<^sup>*) x y s")
   prefer 2 apply(simp add:is_ub_def)
  apply(subgoal_tac "(u, s) \<in> r\<^sup>*")
   prefer 2 apply(blast dest:is_lubD)
  apply(erule converse_rtranclE)
   apply blast
  apply(simp only:acyclic_def)
  apply(blast intro:rtrancl_into_trancl2 rtrancl_trancl_trancl)
 apply(rule finite_acyclic_wf)
  apply simp
  apply(erule acyclic_single_valued_finite)
   apply(blast intro:single_valuedI)
  apply(simp add:is_lub_def is_ub_def)
 apply simp
 apply(erule acyclic_subset)
 apply blast
apply simp
apply(erule conjE)
apply(erule_tac z = u in converse_rtranclE)
 apply(blast dest: is_lubD is_ubD)
apply(blast dest:rtrancl_into_rtrancl)
done
(*>*)

lemma is_lub_exec_lub:
  "\<lbrakk> single_valued r; acyclic r; (x,u):r^*; (y,u):r^*; \<forall>x y. (x,y) \<in> r \<longrightarrow> f x = y \<rbrakk>
  \<Longrightarrow> is_lub (r^* ) x y (exec_lub r f x y)"
  (*<*) by (fastforce dest: single_valued_has_lubs simp add: exec_lub_conv) (*>*)

end