(*
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 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"
  using assms by (auto simp: antisym_def intro: transD [OF lex_transI])

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) auto

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


(*
Stepwise refinement of the Gale-Shapley algorithm down to executable code.

Author: Tobias Nipkow
*)

section \<open>Part 2: Refinement from lists to arrays\<close>

theory Gale_Shapley2
imports Gale_Shapley1 "Collections.Diff_Array"
begin

text \<open>Refinement from lists to arrays,
resulting in a linear (in the input size, which is \<open>n^2\<close>) time algorithm.\<close>

abbreviation "array \<equiv> new_array"
notation array_get (infixl "!!" 100)
notation array_set ("_[_ ::= _]" [1000,0,0] 900)
abbreviation "list \<equiv> list_of_array"

lemma list_array: "list (array x n) = replicate n x"
by (simp add: new_array_def)

lemma array_get: "a !! i = list a ! i"
by (cases a) simp

context Pref
begin

subsection \<open>Algorithm 7: Arrays\<close>

definition "match_array A a = P\<^sub>a ! a ! (A !! a)"

lemma match_array: "match_array A a = match (list A) a"
by(cases A) (simp add: match_array_def match_def)

lemmas array_abs = match_array array_list_of_set array_get

lemma Gale_Shapley7:
assumes "R = map ranking P\<^sub>b"
shows
"VARS A B M ai a a' b r
 [ai = 0 \<and> A = array 0 n \<and> B = array 0 n \<and> M = array False n]
 WHILE ai < n
 INV { invar1 (list A) (list B) (list M) ai }
 VAR {z = n - ai}
 DO a := ai; b := match_array A a;
  WHILE M !! b
  INV { invar2 (list A) (list B) (list M) ai a \<and> b = match_array A a \<and> z = n-ai }
  VAR {var (list A) {<ai}}
  DO a' := B !! b; r := R ! match_array A a';
     IF r ! a < r ! a'
     THEN B := B[b ::= a]; A := A[a' ::= A !! a' + 1]; a := a'
     ELSE A := A[a ::= A !! a + 1]
     FI;
     b := match_array A a
  OD;
  B := B[b ::= a]; M := M[b ::= True]; ai := ai+1
 OD
 [matching (list A) {<n} \<and> stable (list A) {<n} \<and> opti\<^sub>a (list A)]"
proof (vcg_tc, goal_cases)
  case 1 thus ?case  (* outer invar holds initially *)
   by(auto simp:  pref_match_def P\<^sub>a_set card_distinct match_def list_array index_nth_id prefers_def opti\<^sub>a_def \<alpha>_def cong: conj_cong)
next
  case 2 (* outer invar and b implies inner invar *)
  thus ?case by (auto simp: atLeastLessThanSuc_atLeastAtMost simp flip: atLeastLessThan_eq_atLeastAtMost_diff)
next
  case 3 (* preservation of inner invar *)
  have R: "\<forall>b<n. \<forall>a1<n. \<forall>a2<n. R ! b ! a1 < R ! b ! a2 \<longleftrightarrow> P\<^sub>b ! b \<turnstile> a1 < a2"
    by (simp add: P\<^sub>b_set \<open>R = _\<close> length_P\<^sub>b ranking_iff_pref)
  show ?case
  proof (simp only: mem_Collect_eq prod.case, goal_cases)
    case 1 show ?case using inner_pres[OF R _ _ refl refl refl] 3
      unfolding array_abs by blast
  qed
next
  case 4 (* inner invar' and not b implies outer invar *)
  show ?case
  proof (simp only: mem_Collect_eq prod.case, rule conjI, goal_cases)
    case 1 show ?case using 4 inner_to_outer unfolding array_abs by blast
  next
    case 2 thus ?case using 4 by auto
  qed
next
  case 5 (* outer invar and not b ibplies post *)
  thus ?case using pref_match_stable unfolding invAM_def invar1_def by(metis le_neq_implies_less)
qed

subsection \<open>Algorithm 7.1: single-loop variant\<close>

lemma Gale_Shapley7_1:
assumes "R\<^sub>b = map ranking P\<^sub>b"
shows "VARS A B M a a' ai b r
 [ai = 0 \<and> a = 0 \<and> A = array 0 n \<and> B = array 0 n \<and> M = array False n]
 WHILE ai < n
 INV { invar2' (list A) (list B) (list M) ai a }
 VAR {var (list A) ({<ai+1} - {a})}
 DO b := match_array A a;
  IF \<not> M !! b
  THEN B := B[b ::= a]; M := M[b ::= True]; ai := ai + 1; a := ai
  ELSE a' := B !! b; r := R\<^sub>b ! match_array A a';
       IF r ! a < r ! a'
       THEN B := B[b ::= a]; A := A[a' ::= A!!a' + 1]; a := a'
       ELSE A := A[a ::= A!!a + 1]
       FI
  FI
 OD
 [matching (list A) {<n} \<and> stable (list A) {<n} \<and> opti\<^sub>a (list A)]"
proof (vcg_tc, goal_cases)
  case 1 thus ?case
   by(auto simp:  pref_match_def P\<^sub>a_set card_distinct match_def list_array index_nth_id prefers_def opti\<^sub>a_def \<alpha>_def cong: conj_cong)
next
  case 3 thus ?case using pref_match_stable atLeast0_lessThan_Suc[of n] by force
next
  case (2 v A B M a a' ai)
  have R': "M !! match_array A a \<Longrightarrow>
    (R\<^sub>b ! match_array A (B !! match_array A a) ! a < R\<^sub>b ! match_array A (B !! match_array A a) ! (B !! match_array A a)) =
     (P\<^sub>b ! match_array A (B !! match_array A a) \<turnstile> a < B !! match_array A a)"
    using R_iff_P 2 assms by (metis array_abs)
  show ?case
    apply(simp only:mem_Collect_eq prod.case)
    using 2 R' pres2'[of "list A" "list B" "list M" ai a] by (metis array_abs)
qed

end

subsection \<open>Executable functional Code\<close>

definition gs_inner where
"gs_inner P\<^sub>a R M =
  while (\<lambda>(A,B,a,b). M !! b)
    (\<lambda>(A,B,a,b).
      let a' = B !! b;
          r = R !! (P\<^sub>a !! a' !! (A !! a')) in
      let (A, B, a) =
        if r !! a < r !! a'
        then (A[a' ::= A !! a' + 1], B[b ::= a], a')
        else (A[a ::= A !! a + 1], B, a)
      in (A, B, a, P\<^sub>a !! a !! (A !! a)))"

definition gs :: "nat \<Rightarrow> nat array array \<Rightarrow> nat array array
  \<Rightarrow> nat array \<times> nat array \<times> bool array \<times> nat" where
"gs n P\<^sub>a R =
  while (\<lambda>(A,B,M,ai). ai < n)
   (\<lambda>(A,B,M,ai).
     let (A,B,a,b) = gs_inner P\<^sub>a R M (A, B, ai, P\<^sub>a !! ai !! (A !! ai))
     in (A, B[b ::= a], M[b::=True], ai+1))
  (array 0 n, array 0 n, array False n, 0)"

definition gs1 :: "nat \<Rightarrow> nat array array \<Rightarrow> nat array array
  \<Rightarrow> nat array \<times> nat array \<times> bool array \<times> nat \<times> nat"  where
"gs1 n P\<^sub>a R =
  while (\<lambda>(A,B,M,ai,a). ai < n)
   (\<lambda>(A,B,M,ai,a).
     let b = P\<^sub>a !! a !! (A !! a)
     in if \<not> M !! b
        then (A, B[b ::= a], M[b ::= True], ai+1, ai+1)
        else let a' = B !! b;
                 r = R !! (P\<^sub>a !! a' !! (A !! a'))
             in if r !!  a < r !! a'
                then (A[a' ::= A!!a' + 1], B[b ::= a], M, ai, a')
                else (A[a ::= A!!a + 1], B, M, ai, a))
  (array 0 n, array 0 n, array False n, 0, 0)"

definition "pref_array = array_of_list o map array_of_list"

lemma list_list_pref_array: "i < length Pa \<Longrightarrow> list (list (pref_array Pa) ! i) = Pa ! i"
by(simp add: pref_array_def)

fun rk_of_pref :: "nat \<Rightarrow> nat array \<Rightarrow> nat list \<Rightarrow> nat array" where
"rk_of_pref r rs (n#ns) = (rk_of_pref (r+1) rs ns)[n ::= r]" |
"rk_of_pref r rs [] = rs"

definition rank_array1 :: "nat list \<Rightarrow> nat array" where
"rank_array1 P = rk_of_pref 0 (array 0 (length P)) P"

definition rank_array :: "nat list list \<Rightarrow> nat array array" where
"rank_array = array_of_list o map rank_array1"

lemma length_rk_of_pref[simp]: "array_length(rk_of_pref v vs P) = array_length vs"
by(induction P arbitrary: v)(auto)

lemma nth_rk_of_pref:
 "\<lbrakk> length P \<le> array_length rs; i \<in> set P; distinct P; set P \<subseteq> {<array_length rs} \<rbrakk>
 \<Longrightarrow> rk_of_pref r rs P !! i = index P i + r"
by(induction P arbitrary: r i) (auto simp add: array_get_array_set_other)

lemma rank_array1_iff_pref:  "\<lbrakk> set P = {<length P}; i < length P; j < length P \<rbrakk>
 \<Longrightarrow> rank_array1 P !! i < rank_array1 P !! j \<longleftrightarrow> P \<turnstile> i < j"
by(simp add: rank_array1_def prefers_def nth_rk_of_pref card_distinct)

definition Gale_Shapley where
"Gale_Shapley P\<^sub>a P\<^sub>b =
  (if Pref P\<^sub>a P\<^sub>b
   then Some (fst (gs (length P\<^sub>a) (pref_array P\<^sub>a) (rank_array P\<^sub>b)))
   else None)"

definition Gale_Shapley1 where
"Gale_Shapley1 P\<^sub>a P\<^sub>b =
  (if Pref P\<^sub>a P\<^sub>b
   then Some (fst (gs1 (length P\<^sub>a) (pref_array P\<^sub>a) (rank_array P\<^sub>b)))
   else None)"

(*export_code Gale_Shapley_array in SML*)

context Pref
begin

lemma gs_inner:
assumes "R = rank_array P\<^sub>b"
assumes "invar2 (list A) (list B) (list M) ai a" "b = match_array A a"
shows "gs_inner (pref_array P\<^sub>a) R M (A, B, a, b) = (A',B',a',b')
  \<longrightarrow> invar1 (list A') ((list B')[b' := a']) ((list M)[b' := True]) (ai+1)"
unfolding gs_inner_def
proof(rule while_rule2[where
     P = "\<lambda>(A,B,a,b). invar2 (list A) (list B) (list M) ai a \<and> b = match_array A a"
 and r = "measure (\<lambda>(A, B, a, b). Pref.var0 P\<^sub>a (list A) {<n})"], goal_cases)
  case 1
  show ?case using assms unfolding var_def by simp
next
  case inv: (2 s)
  obtain A B a b where s: "s =  (A, B, a, b)"
    using prod_cases4 by blast
  show ?case
  proof(rule, goal_cases)
    case 1
    have *: "a < n" using s inv(1)[unfolded invar2_def] by (auto)
    hence 2: "list A ! a < n" using s inv(1)[unfolded invar2_def]
      apply simp using "*" wf_less_n by presburger
    hence "match (list A) a < n"
      by (metis "*" P\<^sub>a_set atLeast0LessThan lessThan_iff match_def nth_mem)
    from this have **: "list B ! match (list A) a < n" using s inv[unfolded invar2_def]
      apply (simp add: array_abs ran_def) using atLeast0LessThan by blast
    have R: "\<forall>b<n. \<forall>a1<n. \<forall>a2<n. map list (list R) ! b ! a1 < map list (list R) ! b ! a2 \<longleftrightarrow> P\<^sub>b ! b \<turnstile> a1 < a2"
    using rank_array1_iff_pref by(simp add: \<open>R = _\<close> length_P\<^sub>b array_get P\<^sub>b_set rank_array_def)
    have ***: "match (list A) (list B ! b) < length (list R)"  using s inv(1)[unfolded invar2_def]
      using ** by(simp add: \<open>R = _\<close> rank_array_def match_array match_less_n length_P\<^sub>b)
    show ?case
    using inv apply(simp only: s prod.case Let_def split: if_split)
    using inner_pres[OF R _ _ refl refl refl refl refl, of "list A" "list B" "list M" ai a b]
    unfolding invar2_def array_abs
      list_list_pref_array[OF **[unfolded n_def]] list_list_pref_array[OF *[unfolded n_def]] nth_map[OF ***]
    unfolding match_def by presburger
    case 2 show ?case
    using inv apply(simp only: s prod.case Let_def in_measure split: if_split)
    using inner_pres2[OF R _ _ refl refl refl refl refl, of "list A" "list B" "list M" ai a b]
    unfolding invar2_def array_abs
      list_list_pref_array[OF **[unfolded n_def]] list_list_pref_array[OF *[unfolded n_def]] nth_map[OF ***]
    unfolding match_def by presburger
  qed
next
  case 3
  show ?case
  proof (rule, goal_cases)
    case 1 show ?case by(rule inner_to_outer[OF 3[unfolded 1 prod.case array_abs]])
  qed
next
  case 4
  show ?case by simp
qed

lemma gs: assumes "R = rank_array P\<^sub>b"
shows "gs n (pref_array P\<^sub>a) R = (A,B,M,ai) \<longrightarrow> matching (list A) {<n} \<and> stable (list A) {<n} \<and> opti\<^sub>a (list A)"
unfolding gs_def
proof(rule while_rule2[where P = "\<lambda>(A,B,M,ai). invar1 (list A) (list B) (list M) ai"
  and r = "measure(\<lambda>(A,B,M,ai). n - ai)"], goal_cases)
  case 1 show ?case
   by(auto simp: pref_match_def P\<^sub>a_set card_distinct match_def list_array index_nth_id prefers_def opti\<^sub>a_def \<alpha>_def cong: conj_cong)
next
  case (2 s)
  obtain A B M ai where s: "s =  (A, B, M, ai)"
    using prod_cases4 by blast
  have 1: "invar2 (list A) (list B) (list M) ai ai" using 2 s
    by (auto simp: atLeastLessThanSuc_atLeastAtMost simp flip: atLeastLessThan_eq_atLeastAtMost_diff)
  hence "ai < n" by(simp)
  show ?case using 2 s gs_inner[OF \<open>R = _ \<close> 1]
    by (auto simp: array_abs match_def list_list_pref_array[OF \<open>ai < n\<close>[unfolded n_def]]
             simp del: invar1_def split: prod.split)
next
  case 3
  thus ?case using pref_match_stable by auto
next
  case 4
  show ?case by simp
qed

lemma R_iff_P:
assumes "R\<^sub>b = rank_array P\<^sub>b" "invar2' A B M ai a" "ai < n" "M ! match A a"
  "b = match A a" "a' = B ! b"
shows "(list (list R\<^sub>b ! match A a') ! a < list (list R\<^sub>b ! match A a') ! a')
       = (P\<^sub>b ! match A a' \<turnstile> a < a')"
proof -
  have R: "\<forall>b<n. \<forall>a1<n. \<forall>a2<n. R\<^sub>b !! b !! a1 < R\<^sub>b !! b !! a2 \<longleftrightarrow> P\<^sub>b ! b \<turnstile> a1 < a2"
    by (simp add: P\<^sub>b_set \<open>R\<^sub>b = _\<close> length_P\<^sub>b array_of_list_def rank_array_def rank_array1_iff_pref)
  let ?M = "{<ai+1} - {a}"
  have A: "wf A" and M: "?M \<subseteq> {<n}" and as: "a < n" and invAB: "invAB2 A B M ?M"
      using assms(2,3) by auto
  have a': "B ! match A a \<in> ?M"
    using invAB match_less_n[OF A] as \<open>M!match A a\<close> by (metis \<alpha>_Some ranI)
  hence "B ! match A a < n" using M by auto
  thus ?thesis using assms match_less_n R by simp (metis array_get as)
qed

lemma gs1: assumes "R\<^sub>b = rank_array P\<^sub>b"
shows "gs1 n (pref_array P\<^sub>a) R\<^sub>b = (A,B,M,ai,a) \<longrightarrow> matching (list A) {<n} \<and> stable (list A) {<n} \<and> opti\<^sub>a (list A)"
unfolding gs1_def
proof(rule while_rule2[where P = "\<lambda>(A,B,M,ai,a). invar2' (list A) (list B) (list M) ai a"
  and r = "measure(\<lambda>(A,B,M,ai,a). Pref.var P\<^sub>a (list A) ({<ai+1} - {a}))"], goal_cases)
  case 1 show ?case
   by(auto simp: pref_match_def P\<^sub>a_set card_distinct match_def list_array index_nth_id prefers_def opti\<^sub>a_def \<alpha>_def cong: conj_cong)
next
  case (2 s)
  obtain A B M ai a where s: "s =  (A, B, M, ai, a)"
    using prod_cases5 by blast
  have 1: "invar2' (list A) (list B) (list M) ai a" using 2(1) s
    by (auto simp: atLeastLessThanSuc_atLeastAtMost simp flip: atLeastLessThan_eq_atLeastAtMost_diff)
  have "ai < n" using 2(2) s by(simp)
  hence "a < n" using 1 by simp
  hence "match (list A) a < n" using 1 match_less_n by auto
  hence *: "list M ! match (list A) a \<Longrightarrow> list B ! match (list A) a < n"
    using s 1[unfolded invar2'_def] apply (simp add: array_abs ran_def)
    using atLeast0LessThan by blast
  have R': "list M ! match (list A) a \<Longrightarrow>
    (list (list R\<^sub>b ! match (list A) (list B ! match (list A) a)) ! a
     < list (list R\<^sub>b ! match (list A) (list B ! match (list A) a)) ! (list B ! match (list A) a)) =
     (P\<^sub>b ! match (list A) (list B ! match (list A) a) \<turnstile> a < list B ! match (list A) a)"
    using R_iff_P \<open>R\<^sub>b = _\<close> 1 \<open>ai < n\<close> by blast
  show ?case
    using s apply (simp add: Let_def)
    unfolding list_list_pref_array[OF \<open>a < n\<close>[unfolded n_def]] array_abs
    using list_list_pref_array[OF *[unfolded n_def]] (* conditional, cannot unfold :-( *)
      pres2'[OF 1 \<open>ai < n\<close> refl refl refl refl refl] R'
    apply(intro conjI impI) by (auto simp: match_def)
    (* w/o intro too slow because of conditional eqn above *)
next
  case 3 thus ?case using pref_match_stable atLeast0_lessThan_Suc[of n] by force
next
  case 4 show ?case by simp
qed

end

theorem gs: "\<lbrakk> Pref P\<^sub>a P\<^sub>b; n = length P\<^sub>a \<rbrakk> \<Longrightarrow>
 \<exists>A. Gale_Shapley P\<^sub>a P\<^sub>b = Some A
   \<and> Pref.matching P\<^sub>a (list A) {<n} \<and> Pref.stable P\<^sub>a P\<^sub>b (list A) {<n} \<and> Pref.opti\<^sub>a P\<^sub>a P\<^sub>b (list A)"
unfolding Gale_Shapley_def using Pref.gs
by (metis fst_conv surj_pair)

theorem gs1: "\<lbrakk> Pref P\<^sub>a P\<^sub>b; n = length P\<^sub>a \<rbrakk> \<Longrightarrow>
 \<exists>A. Gale_Shapley1 P\<^sub>a P\<^sub>b = Some A
   \<and> Pref.matching P\<^sub>a (list A) {<n} \<and> Pref.stable P\<^sub>a P\<^sub>b (list A) {<n} \<and> Pref.opti\<^sub>a P\<^sub>a P\<^sub>b (list A)"
unfolding Gale_Shapley1_def using Pref.gs1
by (metis fst_conv surj_pair)

text \<open>Two examples from Gusfield and Irving:\<close>

lemma "list_of_array (the (Gale_Shapley
  [[3,0,1,2], [1,2,0,3], [1,3,2,0], [2,0,3,1]] [[3,0,2,1], [0,2,1,3], [0,1,2,3], [3,0,2,1]]))
  = [0,1,0,1]"
by eval

lemma "list_of_array (the (Gale_Shapley
  [[4,6,0,1,5,7,3,2], [1,2,6,4,3,0,7,5], [7,4,0,3,5,1,2,6], [2,1,6,3,0,5,7,4],
   [6,1,4,0,2,5,7,3], [0,5,6,4,7,3,1,2], [1,4,6,5,2,3,7,0], [2,7,3,4,6,1,5,0]]
  [[4,2,6,5,0,1,7,3], [7,5,2,4,6,1,0,3], [0,4,5,1,3,7,6,2], [7,6,2,1,3,0,4,5],
   [5,3,6,2,7,0,1,4], [1,7,4,2,3,5,6,0], [6,4,1,0,7,5,3,2], [6,3,0,4,1,2,5,7]]))
  = [0, 1, 0, 5, 0, 0, 0, 2]"
by eval

end


(*  Title:      HOL/Cardinals/Order_Union.thy
    Author:     Andrei Popescu, TU Muenchen

The ordinal-like sum of two orders with disjoint fields
*)

section {* Order Union *}

theory Order_Union
imports Order_Relation
begin

definition Osum :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel"  (infix "Osum" 60) where
  "r Osum r' = r \<union> r' \<union> {(a, a'). a \<in> Field r \<and> a' \<in> Field r'}"

notation Osum  (infix "\<union>o" 60)

lemma Field_Osum: "Field (r \<union>o r') = Field r \<union> Field r'"
  unfolding Osum_def Field_def by blast

lemma Osum_wf:
assumes FLD: "Field r Int Field r' = {}" and
        WF: "wf r" and WF': "wf r'"
shows "wf (r Osum r')"
unfolding wf_eq_minimal2 unfolding Field_Osum
proof(intro allI impI, elim conjE)
  fix A assume *: "A \<subseteq> Field r \<union> Field r'" and **: "A \<noteq> {}"
  obtain B where B_def: "B = A Int Field r" by blast
  show "\<exists>a\<in>A. \<forall>a'\<in>A. (a', a) \<notin> r \<union>o r'"
  proof(cases "B = {}")
    assume Case1: "B \<noteq> {}"
    hence "B \<noteq> {} \<and> B \<le> Field r" using B_def by auto
    then obtain a where 1: "a \<in> B" and 2: "\<forall>a1 \<in> B. (a1,a) \<notin> r"
    using WF unfolding wf_eq_minimal2 by blast
    hence 3: "a \<in> Field r \<and> a \<notin> Field r'" using B_def FLD by auto
    (*  *)
    have "\<forall>a1 \<in> A. (a1,a) \<notin> r Osum r'"
    proof(intro ballI)
      fix a1 assume **: "a1 \<in> A"
      {assume Case11: "a1 \<in> Field r"
       hence "(a1,a) \<notin> r" using B_def ** 2 by auto
       moreover
       have "(a1,a) \<notin> r'" using 3 by (auto simp add: Field_def)
       ultimately have "(a1,a) \<notin> r Osum r'"
       using 3 unfolding Osum_def by auto
      }
      moreover
      {assume Case12: "a1 \<notin> Field r"
       hence "(a1,a) \<notin> r" unfolding Field_def by auto
       moreover
       have "(a1,a) \<notin> r'" using 3 unfolding Field_def by auto
       ultimately have "(a1,a) \<notin> r Osum r'"
       using 3 unfolding Osum_def by auto
      }
      ultimately show "(a1,a) \<notin> r Osum r'" by blast
    qed
    thus ?thesis using 1 B_def by auto
  next
    assume Case2: "B = {}"
    hence 1: "A \<noteq> {} \<and> A \<le> Field r'" using * ** B_def by auto
    then obtain a' where 2: "a' \<in> A" and 3: "\<forall>a1' \<in> A. (a1',a') \<notin> r'"
    using WF' unfolding wf_eq_minimal2 by blast
    hence 4: "a' \<in> Field r' \<and> a' \<notin> Field r" using 1 FLD by blast
    (*  *)
    have "\<forall>a1' \<in> A. (a1',a') \<notin> r Osum r'"
    proof(unfold Osum_def, auto simp add: 3)
      fix a1' assume "(a1', a') \<in> r"
      thus False using 4 unfolding Field_def by blast
    next
      fix a1' assume "a1' \<in> A" and "a1' \<in> Field r"
      thus False using Case2 B_def by auto
    qed
    thus ?thesis using 2 by blast
  qed
qed

lemma Osum_Refl:
assumes FLD: "Field r Int Field r' = {}" and
        REFL: "Refl r" and REFL': "Refl r'"
shows "Refl (r Osum r')"
using assms
unfolding refl_on_def Field_Osum unfolding Osum_def by blast

lemma Osum_trans:
assumes FLD: "Field r Int Field r' = {}" and
        TRANS: "trans r" and TRANS': "trans r'"
shows "trans (r Osum r')"
proof(unfold trans_def, auto)
  fix x y z assume *: "(x, y) \<in> r \<union>o r'" and **: "(y, z) \<in> r \<union>o r'"
  show  "(x, z) \<in> r \<union>o r'"
  proof-
    {assume Case1: "(x,y) \<in> r"
     hence 1: "x \<in> Field r \<and> y \<in> Field r" unfolding Field_def by auto
     have ?thesis
     proof-
       {assume Case11: "(y,z) \<in> r"
        hence "(x,z) \<in> r" using Case1 TRANS trans_def[of r] by blast
        hence ?thesis unfolding Osum_def by auto
       }
       moreover
       {assume Case12: "(y,z) \<in> r'"
        hence "y \<in> Field r'" unfolding Field_def by auto
        hence False using FLD 1 by auto
       }
       moreover
       {assume Case13: "z \<in> Field r'"
        hence ?thesis using 1 unfolding Osum_def by auto
       }
       ultimately show ?thesis using ** unfolding Osum_def by blast
     qed
    }
    moreover
    {assume Case2: "(x,y) \<in> r'"
     hence 2: "x \<in> Field r' \<and> y \<in> Field r'" unfolding Field_def by auto
     have ?thesis
     proof-
       {assume Case21: "(y,z) \<in> r"
        hence "y \<in> Field r" unfolding Field_def by auto
        hence False using FLD 2 by auto
       }
       moreover
       {assume Case22: "(y,z) \<in> r'"
        hence "(x,z) \<in> r'" using Case2 TRANS' trans_def[of r'] by blast
        hence ?thesis unfolding Osum_def by auto
       }
       moreover
       {assume Case23: "y \<in> Field r"
        hence False using FLD 2 by auto
       }
       ultimately show ?thesis using ** unfolding Osum_def by blast
     qed
    }
    moreover
    {assume Case3: "x \<in> Field r \<and> y \<in> Field r'"
     have ?thesis
     proof-
       {assume Case31: "(y,z) \<in> r"
        hence "y \<in> Field r" unfolding Field_def by auto
        hence False using FLD Case3 by auto
       }
       moreover
       {assume Case32: "(y,z) \<in> r'"
        hence "z \<in> Field r'" unfolding Field_def by blast
        hence ?thesis unfolding Osum_def using Case3 by auto
       }
       moreover
       {assume Case33: "y \<in> Field r"
        hence False using FLD Case3 by auto
       }
       ultimately show ?thesis using ** unfolding Osum_def by blast
     qed
    }
    ultimately show ?thesis using * unfolding Osum_def by blast
  qed
qed

lemma Osum_Preorder:
"\<lbrakk>Field r Int Field r' = {}; Preorder r; Preorder r'\<rbrakk> \<Longrightarrow> Preorder (r Osum r')"
unfolding preorder_on_def using Osum_Refl Osum_trans by blast

lemma Osum_antisym:
assumes FLD: "Field r Int Field r' = {}" and
        AN: "antisym r" and AN': "antisym r'"
shows "antisym (r Osum r')"
proof(unfold antisym_def, auto)
  fix x y assume *: "(x, y) \<in> r \<union>o r'" and **: "(y, x) \<in> r \<union>o r'"
  show  "x = y"
  proof-
    {assume Case1: "(x,y) \<in> r"
     hence 1: "x \<in> Field r \<and> y \<in> Field r" unfolding Field_def by auto
     have ?thesis
     proof-
       have "(y,x) \<in> r \<Longrightarrow> ?thesis"
       using Case1 AN antisym_def[of r] by blast
       moreover
       {assume "(y,x) \<in> r'"
        hence "y \<in> Field r'" unfolding Field_def by auto
        hence False using FLD 1 by auto
       }
       moreover
       have "x \<in> Field r' \<Longrightarrow> False" using FLD 1 by auto
       ultimately show ?thesis using ** unfolding Osum_def by blast
     qed
    }
    moreover
    {assume Case2: "(x,y) \<in> r'"
     hence 2: "x \<in> Field r' \<and> y \<in> Field r'" unfolding Field_def by auto
     have ?thesis
     proof-
       {assume "(y,x) \<in> r"
        hence "y \<in> Field r" unfolding Field_def by auto
        hence False using FLD 2 by auto
       }
       moreover
       have "(y,x) \<in> r' \<Longrightarrow> ?thesis"
       using Case2 AN' antisym_def[of r'] by blast
       moreover
       {assume "y \<in> Field r"
        hence False using FLD 2 by auto
       }
       ultimately show ?thesis using ** unfolding Osum_def by blast
     qed
    }
    moreover
    {assume Case3: "x \<in> Field r \<and> y \<in> Field r'"
     have ?thesis
     proof-
       {assume "(y,x) \<in> r"
        hence "y \<in> Field r" unfolding Field_def by auto
        hence False using FLD Case3 by auto
       }
       moreover
       {assume Case32: "(y,x) \<in> r'"
        hence "x \<in> Field r'" unfolding Field_def by blast
        hence False using FLD Case3 by auto
       }
       moreover
       have "\<not> y \<in> Field r" using FLD Case3 by auto
       ultimately show ?thesis using ** unfolding Osum_def by blast
     qed
    }
    ultimately show ?thesis using * unfolding Osum_def by blast
  qed
qed

lemma Osum_Partial_order:
"\<lbrakk>Field r Int Field r' = {}; Partial_order r; Partial_order r'\<rbrakk> \<Longrightarrow>
 Partial_order (r Osum r')"
unfolding partial_order_on_def using Osum_Preorder Osum_antisym by blast

lemma Osum_Total:
assumes FLD: "Field r Int Field r' = {}" and
        TOT: "Total r" and TOT': "Total r'"
shows "Total (r Osum r')"
using assms
unfolding total_on_def  Field_Osum unfolding Osum_def by blast

lemma Osum_Linear_order:
"\<lbrakk>Field r Int Field r' = {}; Linear_order r; Linear_order r'\<rbrakk> \<Longrightarrow>
 Linear_order (r Osum r')"
unfolding linear_order_on_def using Osum_Partial_order Osum_Total by blast

lemma Osum_minus_Id1:
assumes "r \<le> Id"
shows "(r Osum r') - Id \<le> (r' - Id) \<union> (Field r \<times> Field r')"
proof-
  let ?Left = "(r Osum r') - Id"
  let ?Right = "(r' - Id) \<union> (Field r \<times> Field r')"
  {fix a::'a and b assume *: "(a,b) \<notin> Id"
   {assume "(a,b) \<in> r"
    with * have False using assms by auto
   }
   moreover
   {assume "(a,b) \<in> r'"
    with * have "(a,b) \<in> r' - Id" by auto
   }
   ultimately
   have "(a,b) \<in> ?Left \<Longrightarrow> (a,b) \<in> ?Right"
   unfolding Osum_def by auto
  }
  thus ?thesis by auto
qed

lemma Osum_minus_Id2:
assumes "r' \<le> Id"
shows "(r Osum r') - Id \<le> (r - Id) \<union> (Field r \<times> Field r')"
proof-
  let ?Left = "(r Osum r') - Id"
  let ?Right = "(r - Id) \<union> (Field r \<times> Field r')"
  {fix a::'a and b assume *: "(a,b) \<notin> Id"
   {assume "(a,b) \<in> r'"
    with * have False using assms by auto
   }
   moreover
   {assume "(a,b) \<in> r"
    with * have "(a,b) \<in> r - Id" by auto
   }
   ultimately
   have "(a,b) \<in> ?Left \<Longrightarrow> (a,b) \<in> ?Right"
   unfolding Osum_def by auto
  }
  thus ?thesis by auto
qed

lemma Osum_minus_Id:
assumes TOT: "Total r" and TOT': "Total r'" and
        NID: "\<not> (r \<le> Id)" and NID': "\<not> (r' \<le> Id)"
shows "(r Osum r') - Id \<le> (r - Id) Osum (r' - Id)"
proof-
  {fix a a' assume *: "(a,a') \<in> (r Osum r')" and **: "a \<noteq> a'"
   have "(a,a') \<in> (r - Id) Osum (r' - Id)"
   proof-
     {assume "(a,a') \<in> r \<or> (a,a') \<in> r'"
      with ** have ?thesis unfolding Osum_def by auto
     }
     moreover
     {assume "a \<in> Field r \<and> a' \<in> Field r'"
      hence "a \<in> Field(r - Id) \<and> a' \<in> Field (r' - Id)"
      using assms Total_Id_Field by blast
      hence ?thesis unfolding Osum_def by auto
     }
     ultimately show ?thesis using * unfolding Osum_def by fast
   qed
  }
  thus ?thesis by(auto simp add: Osum_def)
qed

lemma wf_Int_Times:
assumes "A Int B = {}"
shows "wf(A \<times> B)"
unfolding wf_def using assms by blast

lemma Osum_wf_Id:
assumes TOT: "Total r" and TOT': "Total r'" and
        FLD: "Field r Int Field r' = {}" and
        WF: "wf(r - Id)" and WF': "wf(r' - Id)"
shows "wf ((r Osum r') - Id)"
proof(cases "r \<le> Id \<or> r' \<le> Id")
  assume Case1: "\<not>(r \<le> Id \<or> r' \<le> Id)"
  have "Field(r - Id) Int Field(r' - Id) = {}"
  using FLD mono_Field[of "r - Id" r]  mono_Field[of "r' - Id" r']
            Diff_subset[of r Id] Diff_subset[of r' Id] by blast
  thus ?thesis
  using Case1 Osum_minus_Id[of r r'] assms Osum_wf[of "r - Id" "r' - Id"]
        wf_subset[of "(r - Id) \<union>o (r' - Id)" "(r Osum r') - Id"] by auto
next
  have 1: "wf(Field r \<times> Field r')"
  using FLD by (auto simp add: wf_Int_Times)
  assume Case2: "r \<le> Id \<or> r' \<le> Id"
  moreover
  {assume Case21: "r \<le> Id"
   hence "(r Osum r') - Id \<le> (r' - Id) \<union> (Field r \<times> Field r')"
   using Osum_minus_Id1[of r r'] by simp
   moreover
   {have "Domain(Field r \<times> Field r') Int Range(r' - Id) = {}"
    using FLD unfolding Field_def by blast
    hence "wf((r' - Id) \<union> (Field r \<times> Field r'))"
    using 1 WF' wf_Un[of "Field r \<times> Field r'" "r' - Id"]
    by (auto simp add: Un_commute)
   }
   ultimately have ?thesis using wf_subset by blast
  }
  moreover
  {assume Case22: "r' \<le> Id"
   hence "(r Osum r') - Id \<le> (r - Id) \<union> (Field r \<times> Field r')"
   using Osum_minus_Id2[of r' r] by simp
   moreover
   {have "Range(Field r \<times> Field r') Int Domain(r - Id) = {}"
    using FLD unfolding Field_def by blast
    hence "wf((r - Id) \<union> (Field r \<times> Field r'))"
    using 1 WF wf_Un[of "r - Id" "Field r \<times> Field r'"]
    by (auto simp add: Un_commute)
   }
   ultimately have ?thesis using wf_subset by blast
  }
  ultimately show ?thesis by blast
qed

lemma Osum_Well_order:
assumes FLD: "Field r Int Field r' = {}" and
        WELL: "Well_order r" and WELL': "Well_order r'"
shows "Well_order (r Osum r')"
proof-
  have "Total r \<and> Total r'" using WELL WELL'
  by (auto simp add: order_on_defs)
  thus ?thesis using assms unfolding well_order_on_def
  using Osum_Linear_order Osum_wf_Id by blast
qed

end