theory "HOLCF-Join"
imports "~~/src/HOL/HOLCF/HOLCF"
begin

subsubsection {* Binary Joins and compatibility *}

context cpo
begin
definition join :: "'a => 'a => 'a" (infix "\<squnion>" 80) where
  "x \<squnion> y = (if \<exists> z. {x, y} <<| z then lub {x, y} else x)"

definition compatible :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  where "compatible x y = (\<exists> z. {x, y} <<| z)"

lemma compatibleI:
  assumes "x \<sqsubseteq> z"
  assumes "y \<sqsubseteq> z"
  assumes "\<And> a. \<lbrakk> x \<sqsubseteq> a ; y \<sqsubseteq> a \<rbrakk> \<Longrightarrow> z \<sqsubseteq> a"
  shows "compatible x y"
proof-
  from assms
  have "{x,y} <<| z"
    by (auto intro: is_lubI)
  thus ?thesis unfolding compatible_def by (metis)
qed

lemma is_joinI:
  assumes "x \<sqsubseteq> z"
  assumes "y \<sqsubseteq> z"
  assumes "\<And> a. \<lbrakk> x \<sqsubseteq> a ; y \<sqsubseteq> a \<rbrakk> \<Longrightarrow> z \<sqsubseteq> a"
  shows "x \<squnion> y = z"
proof-
  from assms
  have "{x,y} <<| z"
    by (auto intro: is_lubI)
  thus ?thesis unfolding join_def by (metis lub_eqI)
qed

lemma is_join_and_compatible:
  assumes "x \<sqsubseteq> z"
  assumes "y \<sqsubseteq> z"
  assumes "\<And> a. \<lbrakk> x \<sqsubseteq> a ; y \<sqsubseteq> a \<rbrakk> \<Longrightarrow> z \<sqsubseteq> a"
  shows "compatible x y \<and> x \<squnion> y = z"
by (metis compatibleI is_joinI assms)

lemma compatible_sym: "compatible x y \<Longrightarrow> compatible y x"
  unfolding compatible_def by (metis insert_commute)

lemma compatible_sym_iff: "compatible x y \<longleftrightarrow> compatible y x"
  unfolding compatible_def by (metis insert_commute)

lemma join_above1: "compatible x y \<Longrightarrow> x \<sqsubseteq> x \<squnion> y"
  unfolding compatible_def join_def
  apply auto
  by (metis is_lubD1 is_ub_insert lub_eqI)

lemma join_above2: "compatible x y \<Longrightarrow> y \<sqsubseteq> x \<squnion> y"
  unfolding compatible_def join_def
  apply auto
  by (metis is_lubD1 is_ub_insert lub_eqI)

lemma larger_is_join1: "y \<sqsubseteq> x \<Longrightarrow> x \<squnion> y = x"
  unfolding join_def
  by (metis doubleton_eq_iff lub_bin)

lemma larger_is_join2: "x \<sqsubseteq> y \<Longrightarrow> x \<squnion> y = y"
  unfolding join_def
  by (metis is_lub_bin lub_bin)

lemma join_commute:  "compatible x y \<Longrightarrow> x \<squnion> y = y \<squnion> x"
  unfolding compatible_def unfolding join_def by (metis insert_commute)

lemma lub_is_join:
  "{x, y} <<| z \<Longrightarrow> x \<squnion> y = z"
unfolding join_def by (metis lub_eqI)

lemma compatible_refl[simp]: "compatible x x"
  by (rule compatibleI[OF below_refl below_refl])

lemma join_mono:
  assumes "compatible a b"
  and "compatible c d"
  and "a \<sqsubseteq> c"
  and "b \<sqsubseteq> d"
  shows "a \<squnion> b \<sqsubseteq> c \<squnion> d"
proof-
  from assms obtain x y where "{a, b} <<| x" "{c, d} <<| y" unfolding compatible_def by auto
  with assms have "a \<sqsubseteq> y" "b \<sqsubseteq> y" by (metis below.r_trans is_lubD1 is_ub_insert)+
  with `{a, b} <<| x` have "x \<sqsubseteq> y" by (metis is_lub_below_iff is_lub_singleton is_ub_insert)
  moreover
  from `{a, b} <<| x` `{c, d} <<| y` have "a \<squnion> b = x" "c \<squnion> d = y" by (metis lub_is_join)+
  ultimately
  show ?thesis by simp
qed

lemma
  assumes "compatible x y"
  shows join_above1: "x \<sqsubseteq> x \<squnion> y" and join_above2: "y \<sqsubseteq> x \<squnion> y"
proof-
  from assms obtain z where "{x,y} <<| z" unfolding compatible_def by auto
  hence  "x \<squnion> y = z" and "x \<sqsubseteq> z" and "y \<sqsubseteq> z" apply (auto intro: lub_is_join) by (metis is_lubD1 is_ub_insert)+
  thus "x \<sqsubseteq> x \<squnion> y" and "y \<sqsubseteq> x \<squnion> y" by simp_all
qed

lemma
  assumes "compatible x y"
  shows compatible_above1: "compatible x (x \<squnion> y)" and compatible_above2: "compatible y (x \<squnion> y)"
proof-
  from assms obtain z where "{x,y} <<| z" unfolding compatible_def by auto
  hence  "x \<squnion> y = z" and "x \<sqsubseteq> z" and "y \<sqsubseteq> z" apply (auto intro: lub_is_join) by (metis is_lubD1 is_ub_insert)+
  thus  "compatible x (x \<squnion> y)" and  "compatible y (x \<squnion> y)" by (metis below.r_refl compatibleI)+
qed

lemma join_below:
  assumes "compatible x y"
  and "x \<sqsubseteq> a" and "y \<sqsubseteq> a"
  shows "x \<squnion> y \<sqsubseteq> a"
proof-
  from assms obtain z where z: "{x,y} <<| z" unfolding compatible_def by auto
  with assms have "z \<sqsubseteq> a" by (metis is_lub_below_iff is_ub_empty is_ub_insert)
  moreover
  from z have "x \<squnion> y = z" by (rule lub_is_join)
  ultimately show ?thesis by simp
qed

lemma join_assoc:
  assumes "compatible x y"
  assumes "compatible x (y \<squnion> z)"
  assumes "compatible y z"
  shows "(x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
  apply (rule is_joinI)
  apply (rule join_mono[OF assms(1) assms(2) below_refl join_above1[OF assms(3)]])
  apply (rule below_trans[OF join_above2[OF assms(3)] join_above2[OF assms(2)]])
  apply (rule join_below[OF assms(2)])
  apply (erule rev_below_trans)
  apply (rule join_above1[OF assms(1)])
  apply (rule join_below[OF assms(3)])
  apply (erule rev_below_trans)
  apply (rule join_above2[OF assms(1)])
  apply assumption
  done

lemma join_idem[simp]: "compatible x y \<Longrightarrow> x \<squnion> (x \<squnion> y) = x \<squnion> y"
  apply (subst join_assoc[symmetric])
  apply (rule compatible_refl)
  apply (erule compatible_above1)
  apply assumption
  apply (subst join_self)
  apply rule
  done

lemma join_bottom[simp]: "x \<squnion> \<bottom> = x" "\<bottom> \<squnion> x = x"
  by (auto intro: is_joinI)

lemma compatible_adm2:
  shows "adm (\<lambda> y. compatible x y)"
proof(rule admI)
  fix Y
  assume c: "chain Y" and "\<forall>i.  compatible x (Y i)"
  hence a: "\<And> i. compatible x (Y i)" by auto
  show "compatible x (\<Squnion> i. Y i)"
  proof(rule compatibleI)
    have c2: "chain (\<lambda>i. x \<squnion> Y i)"
      apply (rule chainI)
      apply (rule join_mono[OF a a below_refl chainE[OF `chain Y`]])
      done
    show "x \<sqsubseteq> (\<Squnion> i. x \<squnion> Y i)"
      by (auto intro: admD[OF _ c2] join_above1[OF a])
    show "(\<Squnion> i. Y i) \<sqsubseteq> (\<Squnion> i. x \<squnion> Y i)"
      by (auto intro: admD[OF _ c] below_lub[OF c2 join_above2[OF a]])
    fix a
    assume "x \<sqsubseteq> a" and "(\<Squnion> i. Y i) \<sqsubseteq> a"
    show "(\<Squnion> i. x \<squnion> Y i) \<sqsubseteq> a"
      apply (rule lub_below[OF c2])
      apply (rule join_below[OF a `x \<sqsubseteq> a`])
      apply (rule below_trans[OF is_ub_thelub[OF c] `(\<Squnion> i. Y i) \<sqsubseteq> a`])
      done
  qed
qed

lemma compatible_adm1: "adm (\<lambda> x. compatible x y)"
  by (subst compatible_sym_iff, rule compatible_adm2)

lemma join_cont1:
  assumes "chain Y"
  assumes compat: "\<And> i. compatible (Y i) y"
  shows "(\<Squnion>i. Y i) \<squnion> y = (\<Squnion> i. Y i \<squnion> y)"
proof-
  have c: "chain (\<lambda>i. Y i \<squnion> y)"
    apply (rule chainI)
    apply (rule join_mono[OF compat compat chainE[OF `chain Y`] below_refl])
    done

  show ?thesis
    apply (rule is_joinI)
    apply (rule lub_mono[OF `chain Y` c join_above1[OF compat]])
    apply (rule below_lub[OF c join_above2[OF compat]])
    apply (rule lub_below[OF c])
    apply (rule join_below[OF compat])
    apply (metis lub_below_iff[OF `chain Y`])
    apply assumption
    done
qed

lemma join_cont2:
  assumes "chain Y"
  assumes compat: "\<And> i. compatible x (Y i)"
  shows "x \<squnion> (\<Squnion>i. Y i) = (\<Squnion> i. x \<squnion> Y i)"
proof-
  have c: "chain (\<lambda>i. x \<squnion> Y i)"
    apply (rule chainI)
    apply (rule join_mono[OF compat compat below_refl chainE[OF `chain Y`]])
    done

  show ?thesis
    apply (rule is_joinI)
    apply (rule below_lub[OF c join_above1[OF compat]])
    apply (rule lub_mono[OF `chain Y` c join_above2[OF compat]])
    apply (rule lub_below[OF c])
    apply (rule join_below[OF compat])
    apply assumption
    apply (metis lub_below_iff[OF `chain Y`])
    done
qed

lemma join_cont12:
  assumes "chain Y" and "chain Z"
  assumes compat: "\<And> i j. compatible (Y i) (Z j)"
  shows "(\<Squnion>i. Y i) \<squnion> (\<Squnion>i. Z i) = (\<Squnion> i. Y i  \<squnion> Z i)"
proof-
  have "(\<Squnion>i. Y i) \<squnion> (\<Squnion>i. Z i) = (\<Squnion>i. Y i \<squnion> (\<Squnion>j. Z j))"
    by (rule join_cont1[OF `chain Y` admD[OF compatible_adm2 `chain Z` compat]])
  also have "... = (\<Squnion>i j. Y i \<squnion> Z j)"
    by (subst join_cont2[OF `chain Z` compat], rule)
  also have "... = (\<Squnion>i. Y i \<squnion> Z i)"
    apply (rule diag_lub)
    apply (rule chainI, rule join_mono[OF compat compat chainE[OF `chain Y`] below_refl])
    apply (rule chainI, rule join_mono[OF compat compat below_refl chainE[OF `chain Z`]])
    done
  finally show ?thesis.
qed

context pcpo
begin
  lemma bot_compatible[simp]:
    "compatible x \<bottom>" "compatible \<bottom> x"
    unfolding compatible_def by (metis insert_commute is_lub_bin minimal)+
end

subsubsection {* Towards meets: Lower bounds *}

context po
begin
definition is_lb :: "'a set => 'a => bool" (infix ">|" 55) where
  "S >| x <-> (\<forall>y\<in>S. x \<sqsubseteq> y)"

lemma is_lbI: "(!!x. x \<in> S ==> l \<sqsubseteq> x) ==> S >| l"
  by (simp add: is_lb_def)

lemma is_lbD: "[|S >| l; x \<in> S|] ==> l \<sqsubseteq> x"
  by (simp add: is_lb_def)

lemma is_lb_empty [simp]: "{} >| l"
  unfolding is_lb_def by fast

lemma is_lb_insert [simp]: "(insert x A) >| y = (y \<sqsubseteq> x \<and> A >| y)"
  unfolding is_lb_def by fast

lemma is_lb_downward: "[|S >| l; y \<sqsubseteq> l|] ==> S >| y"
  unfolding is_lb_def by (fast intro: below_trans)

subsubsection {* Greatest lower bounds *}

definition is_glb :: "'a set => 'a => bool" (infix ">>|" 55) where
  "S >>| x <-> S >| x \<and> (\<forall>u. S >| u --> u \<sqsubseteq> x)"

definition glb :: "'a set => 'a" ("\<Sqinter>_" [60]60) where
  "glb S = (THE x. S >>| x)"

text {* access to some definition as inference rule *}

lemma is_glbD1: "S >>| x ==> S >| x"
  unfolding is_glb_def by fast

lemma is_glbD2: "[|S >>| x; S >| u|] ==> u \<sqsubseteq> x"
  unfolding is_glb_def by fast

lemma (in po) is_glbI: "[|S >| x; !!u. S >| u ==> u \<sqsubseteq> x|] ==> S >>| x"
  unfolding is_glb_def by fast

lemma is_glb_above_iff: "S >>| x ==> u \<sqsubseteq> x <-> S >| u"
  unfolding is_glb_def is_lb_def by (metis below_trans)

text {* glbs are unique *}

lemma is_glb_unique: "[|S >>| x; S >>| y|] ==> x = y"
  unfolding is_glb_def is_lb_def by (blast intro: below_antisym)

text {* technical lemmas about @{term glb} and @{term is_glb} *}

lemma is_glb_glb: "M >>| x ==> M >>| glb M"
  unfolding glb_def by (rule theI [OF _ is_glb_unique])

lemma glb_eqI: "M >>| l ==> glb M = l"
  by (rule is_glb_unique [OF is_glb_glb])

lemma is_glb_singleton: "{x} >>| x"
  by (simp add: is_glb_def)

lemma glb_singleton [simp]: "glb {x} = x"
  by (rule is_glb_singleton [THEN glb_eqI])

lemma is_glb_bin: "x \<sqsubseteq> y ==> {x, y} >>| x"
  by (simp add: is_glb_def)

lemma glb_bin: "x \<sqsubseteq> y ==> glb {x, y} = x"
  by (rule is_glb_bin [THEN glb_eqI])

lemma is_glb_maximal: "[|S >| x; x \<in> S|] ==> S >>| x"
  by (erule is_glbI, erule (1) is_lbD)

lemma glb_maximal: "[|S >| x; x \<in> S|] ==> glb S = x"
  by (rule is_glb_maximal [THEN glb_eqI])
end

lemma (in cpo) Meet_insert: "S >>| l \<Longrightarrow> {x, l} >>| l2 \<Longrightarrow> insert x S >>| l2"
  apply (rule is_glbI)
  apply (metis is_glb_above_iff is_glb_def is_lb_insert)
  by (metis is_glb_above_iff is_glb_def is_glb_singleton is_lb_insert)

subsubsection {* Type classes for various kinds of meets *}

text {* Binary, hence finite meets. *}

class Finite_Meet_cpo = cpo +
  assumes binary_meet_exists: "\<exists> l. l \<sqsubseteq> x \<and> l \<sqsubseteq> y \<and> (\<forall> z. z \<sqsubseteq> x \<longrightarrow> z \<sqsubseteq> y \<longrightarrow> z \<sqsubseteq> l)"
begin

  lemma binary_meet_exists': "\<exists>l. {x, y} >>| l"
    using binary_meet_exists[of x y]
    unfolding is_glb_def is_lb_def
    by auto

  lemma finite_meet_exists:
    assumes "S \<noteq> {}"
    and "finite S"
    shows "\<exists>x. S >>| x"
  using `S \<noteq> {}`
  apply (induct rule: finite_induct[OF `finite S`])
  apply (erule notE, rule refl)[1]
  apply (case_tac "F = {}")
  apply (metis is_glb_singleton)
  apply (metis Meet_insert binary_meet_exists')
  done
end

text {* Meets for finite nonempty sets with a lower bound. *}

class Bounded_Nonempty_Meet_cpo = cpo +
  assumes bounded_nonempty_meet_exists: "S \<noteq> {} \<Longrightarrow> (\<exists>z. S >| z) \<Longrightarrow> \<exists>x. S >>| x"
begin
  lemma nonempty_ub_implies_lub_exists:
  assumes "S <| u"
  assumes "S \<noteq> {}"
  shows "\<exists> z. S <<| z"
  proof-
    have "{u. S <| u} \<noteq> {}" using assms(1) by auto
    hence "\<exists>x. {u. S <| u} >>| x"
      apply (rule bounded_nonempty_meet_exists)
      by (metis CollectE assms(2) equals0I is_lbI is_ub_def)
    then obtain lu where lb: "{u. S <| u} >>| lu" by auto
    hence "S <| lu"
      by (metis is_glb_above_iff is_lb_def is_ub_def mem_Collect_eq)
    hence "S <<| lu"
      by (metis (full_types) is_lubI is_glbD1 is_lb_def lb mem_Collect_eq)
    thus ?thesis ..
  qed

  lemma ub_implies_compatible:
    "x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> compatible x y"
    unfolding compatible_def
    by (rule nonempty_ub_implies_lub_exists, auto)
end

text {* Meets for finite nonempty sets. *}

class Nonempty_Meet_cpo = cpo +
  assumes nonempty_meet_exists: "S \<noteq> {} \<Longrightarrow> \<exists>x. S >>| x"
begin
  lemma ub_implies_lub_exists:
  assumes "S <| u"
  shows "\<exists> z. S <<| z"
  proof-
    have "{u. S <| u} \<noteq> {}" using assms by auto
    from nonempty_meet_exists[OF this]
    obtain lu where lb: "{u. S <| u} >>| lu" by auto
    hence "S <| lu"
      by (metis is_glb_above_iff is_lb_def is_ub_def mem_Collect_eq)
    hence "S <<| lu"
      by (metis (full_types) is_lubI is_glbD1 is_lb_def lb mem_Collect_eq)
    thus ?thesis ..
  qed
end

context Nonempty_Meet_cpo
begin
  subclass Bounded_Nonempty_Meet_cpo
  apply default by (metis nonempty_meet_exists)
end

lemma (in Bounded_Nonempty_Meet_cpo) compatible_down_closed:
    assumes "compatible x y"
    and "z \<sqsubseteq> x"
    shows "compatible z y"
proof-
    from assms(1) obtain ub where "{x, y} <<| ub" by (metis compatible_def)
    hence "{x,y} <| ub" by (metis is_lubD1)
    hence "{z,y} <| ub" using assms(2) by (metis is_ub_insert rev_below_trans)
    thus ?thesis unfolding compatible_def by (metis insert_not_empty nonempty_ub_implies_lub_exists)
qed

lemma (in Bounded_Nonempty_Meet_cpo) compatible_down_closed2:
    assumes "compatible y x"
    and "z \<sqsubseteq> x"
    shows "compatible y z"
proof-
    from assms(1) obtain ub where "{y, x} <<| ub" by (metis compatible_def)
    hence "{y,x} <| ub" by (metis is_lubD1)
    hence "{y,z} <| ub" using assms(2) by (metis is_ub_insert rev_below_trans)
    thus ?thesis unfolding compatible_def by (metis insert_not_empty nonempty_ub_implies_lub_exists)
qed

lemma join_mono':
  assumes  "compatible (c::'a::Bounded_Nonempty_Meet_cpo) d"
  and "a \<sqsubseteq> c"
  and "b \<sqsubseteq> d"
  shows "a \<squnion> b \<sqsubseteq> c \<squnion> d"
  apply (rule join_mono[OF _ assms(1) assms(2) assms(3)])
  by (metis assms(1) assms(2) assms(3) compatible_down_closed2 compatible_sym)

subsubsection {* Bifinite domains with finite nonempty meets have arbitrary nonempty meets. *}

class Finite_Meet_bifinite_cpo = Finite_Meet_cpo + bifinite

lemma is_ub_range:
     "S >| u \<Longrightarrow> Rep_cfun f ` S >| f \<cdot> u"
  apply (rule is_lbI)
  apply (erule imageE)
  by (metis monofun_cfun_arg is_lbD)

lemma (in approx_chain) lub_approx_arg: "(\<Squnion>i. approx i \<cdot> u ) = u"
  by (metis chain_approx lub_ID_reach lub_approx)

instance Finite_Meet_bifinite_cpo \<subseteq> Nonempty_Meet_cpo
proof (default)
  from bifinite obtain approx :: "nat \<Rightarrow> 'a \<rightarrow> 'a" where "approx_chain approx" by auto
  fix S
  assume "(S :: 'a set) \<noteq> {}"
  have "\<And>i. \<exists> l . Rep_cfun (approx i) ` S >>|l"
    apply (rule finite_meet_exists)
    using `S \<noteq> {}` apply auto[1]
    using  finite_deflation.finite_range[OF approx_chain.finite_deflation_approx[OF `approx_chain approx`]]
    by (metis (full_types) image_mono rev_finite_subset top_greatest)
  then obtain Y where Y_is_glb: "\<And>i. Rep_cfun (approx i) ` S >>| Y i" by metis

  have "chain Y"
    apply (rule chainI)
    apply (subst is_glb_above_iff[OF Y_is_glb])
    apply (rule is_lbI)
    apply (erule imageE)
    apply (erule ssubst)
    apply (rule rev_below_trans[OF monofun_cfun_fun[OF chainE[OF approx_chain.chain_approx[OF `approx_chain approx`]]]])
    apply (rule is_lbD[OF is_glbD1[OF Y_is_glb]])
    apply (erule imageI)
    done

  have "S >| Lub Y"
  proof(rule is_lbI, rule lub_below[OF `chain Y`])
    fix x i
    assume "x \<in> S"
    hence "Y i \<sqsubseteq> approx i \<cdot> x"
      by (rule imageI[THEN is_lbD[OF is_glbD1[OF Y_is_glb]]])
    also have "approx i \<cdot> x \<sqsubseteq> x"
      by (rule  approx_chain.approx_below[OF `approx_chain approx`])
    finally
    show "Y i \<sqsubseteq> x".
  qed

  have "S >>| Lub Y"
  proof (rule is_glbI[OF `S >| Lub Y`])
    fix u
    assume "S >| u"
    hence "\<And> i. Rep_cfun (approx i) ` S >| approx i \<cdot> u"
      by (rule is_ub_range)
    hence "\<And> i.  approx i \<cdot> u \<sqsubseteq> Y i"
      by (rule is_glbD2[OF Y_is_glb])
    hence "(\<Squnion>i. approx i \<cdot> u ) \<sqsubseteq> Lub Y"
      by (rule lub_mono[OF
            ch2ch_Rep_cfunL[OF approx_chain.chain_approx[OF `approx_chain approx`]]
            `chain Y`
            ])
    thus "u \<sqsubseteq> Lub Y"
      by (metis approx_chain.lub_approx_arg[OF `approx_chain approx`])
  qed
  thus "\<exists>x. S >>| x"..
qed

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_nat_MSortTDIsSort
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun minus :: "Nat => Nat => Nat" where
  "minus (Z) y = Z"
| "minus (S z) (S y2) = minus z y2"

fun lt :: "Nat => Nat => bool" where
  "lt x (Z) = False"
| "lt (Z) (S z) = True"
| "lt (S n) (S z) = lt n z"

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 y l) = plus (S Z) (length l)"

fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun lmerge :: "Nat list => Nat list => Nat list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if le z x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun take :: "Nat => 'a list => 'a list" where
  "take x y =
   (if le x Z then nil2 else
      (case y of
         nil2 => nil2
         | cons2 z xs => (case x of S x2 => cons2 z (take x2 xs))))"

fun insert :: "Nat => Nat list => Nat list" where
  "insert x (nil2) = cons2 x (nil2)"
| "insert x (cons2 z xs) =
     (if le x z then cons2 x (cons2 z xs) else cons2 z (insert x xs))"

fun isort :: "Nat list => Nat list" where
  "isort (nil2) = nil2"
| "isort (cons2 y xs) = insert y (isort xs)"

(*fun did not finish the proof*)
function idiv :: "Nat => Nat => Nat" where
  "idiv x y = (if lt x y then Z else S (idiv (minus x y) y))"
  by pat_completeness auto

fun drop :: "Nat => 'a list => 'a list" where
  "drop x y =
   (if le x Z then y else
      (case y of
         nil2 => nil2
         | cons2 z xs1 => (case x of S x2 => drop x2 xs1)))"

(*fun did not finish the proof*)
function msorttd :: "Nat list => Nat list" where
  "msorttd (nil2) = nil2"
| "msorttd (cons2 y (nil2)) = cons2 y (nil2)"
| "msorttd (cons2 y (cons2 x2 x3)) =
     (let k :: Nat = idiv (length (cons2 y (cons2 x2 x3))) (S (S Z))
     in lmerge
          (msorttd (take k (cons2 y (cons2 x2 x3))))
          (msorttd (drop k (cons2 y (cons2 x2 x3)))))"
  by pat_completeness auto

theorem property0 :
  "((msorttd xs) = (isort xs))"
  oops

end


(*
  File: Divides.thy
  Author: Bohua Zhan

  Basics of divisibility and prime numbers.
*)

theory Divides
  imports Nat
begin

section \<open>Divisibility\<close>

definition divides :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "divides(R,a,b) \<longleftrightarrow> (a \<in>. R \<and> b \<in>. R \<and> (\<exists>k\<in>.R. b = a *\<^sub>R k))"

lemma dividesI [resolve]:
  "is_group_raw(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> k \<in>. R \<Longrightarrow> divides(R, a, a *\<^sub>R k)" by auto2
lemma dividesD1 [forward]: "divides(R,a,b) \<Longrightarrow> a \<in>. R \<and> b \<in>. R" by auto2
lemma dividesD2 [backward]: "divides(R,a,b) \<Longrightarrow> \<exists>k\<in>.R. b = a *\<^sub>R k" by auto2
setup {* del_prfstep_thm @{thm divides_def} *}

lemma divides_id [resolve]: "is_semiring(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> divides(R,a,a)"
@proof @have "a = a *\<^sub>R \<one>\<^sub>R" @qed

lemma divides_trans [forward]:
  "is_semiring(R) \<Longrightarrow> divides(R,a,b) \<Longrightarrow> divides(R,b,c) \<Longrightarrow> divides(R,a,c)"
@proof
  @obtain "k\<in>.R" where "b = a *\<^sub>R k"
  @obtain "l\<in>.R" where "c = b *\<^sub>R l"
  @have "c = (a *\<^sub>R k) *\<^sub>R l" @have "c = a *\<^sub>R (k *\<^sub>R l)"
@qed

lemma divides_one [resolve]:
  "is_semiring(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> divides(R,\<one>\<^sub>R,a)"
@proof @have "a = \<one>\<^sub>R *\<^sub>R a" @qed

lemma divides_zero [resolve]:
  "is_semiring(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> divides(R,a,\<zero>\<^sub>R)"
@proof @have "\<zero>\<^sub>R = a *\<^sub>R \<zero>\<^sub>R" @qed

section \<open>Divides on natural numbers\<close>

lemma nat_divides_cancel [forward]:
  "a \<in>. \<nat> \<Longrightarrow> b \<in>. \<nat> \<Longrightarrow> c \<in>. \<nat> \<Longrightarrow> c \<noteq> 0 \<Longrightarrow>
   divides(\<nat>, a *\<^sub>\<nat> c, b *\<^sub>\<nat> c) \<Longrightarrow> divides(\<nat>, a, b)"
@proof
  @obtain "k\<in>.\<nat>" where "b *\<^sub>\<nat> c = a *\<^sub>\<nat> c *\<^sub>\<nat> k"
  @have "a *\<^sub>\<nat> k *\<^sub>\<nat> c = b *\<^sub>\<nat> c"
@qed

lemma nat_le_prod [backward]:
  "a \<in>. \<nat> \<Longrightarrow> k \<in>. \<nat> \<Longrightarrow> k \<noteq> 0 \<Longrightarrow> a \<le>\<^sub>\<nat> a *\<^sub>\<nat> k"
@proof @have "k \<ge>\<^sub>\<nat> 1" @have "a = a *\<^sub>\<nat> 1" @qed

lemma nat_divides_le [forward]:
  "b \<noteq> 0 \<Longrightarrow> divides(\<nat>,a,b) \<Longrightarrow> 1 \<le>\<^sub>\<nat> a \<and> a \<le>\<^sub>\<nat> b"
@proof @obtain "k\<in>.\<nat>" where "b = a *\<^sub>\<nat> k" @qed

definition even :: "i \<Rightarrow> o" where [rewrite]:
  "even(x) \<longleftrightarrow> divides(\<nat>,2,x)"

definition odd :: "i \<Rightarrow> o" where [rewrite]:
  "odd(x) \<longleftrightarrow> (\<not>divides(\<nat>,2,x))"

section \<open>Quotient and Remainder\<close>

lemma quotient_remainder_theorem:
  "m >\<^sub>\<nat> 0 \<Longrightarrow> n \<in> nat \<Longrightarrow> \<exists>q\<in>nat. \<exists>r\<in>nat. n = m *\<^sub>\<nat> q +\<^sub>\<nat> r \<and> 0 \<le>\<^sub>\<nat> r \<and> r <\<^sub>\<nat> m"
@proof
  @strong_induct "n \<in> nat"
  @case "n <\<^sub>\<nat> m"
  @let "n' = n -\<^sub>\<nat> m"
  @have "n' <\<^sub>\<nat> n" @with @have "n' +\<^sub>\<nat> m <\<^sub>\<nat> n +\<^sub>\<nat> m" @end
  @obtain "q\<in>nat" "r\<in>nat" where "n' = m *\<^sub>\<nat> q +\<^sub>\<nat> r" "0 \<le>\<^sub>\<nat> r" "r <\<^sub>\<nat> m"
  @have "n = (m *\<^sub>\<nat> q +\<^sub>\<nat> r) +\<^sub>\<nat> m"
  @have "n = (m *\<^sub>\<nat> (q +\<^sub>\<nat> \<one>\<^sub>\<nat>)) +\<^sub>\<nat> r"
@qed

section \<open>Prime\<close>

definition prime :: "i \<Rightarrow> o" where [rewrite]:
  "prime(p) \<longleftrightarrow> (p >\<^sub>\<nat> 1 \<and> (\<forall>m. divides(\<nat>,m,p) \<longrightarrow> m = 1 \<or> m = p))"

lemma primeD1 [forward]: "prime(p) \<Longrightarrow> p >\<^sub>\<nat> 1" by auto2
lemma primeD2 [forward]: "prime(p) \<Longrightarrow> divides(\<nat>,m,p) \<Longrightarrow> m = 1 \<or> m = p" by auto2
setup {* del_prfstep_thm_eqforward @{thm prime_def} *}

lemma prime_odd_nat: "prime(p) \<Longrightarrow> p >\<^sub>\<nat> 2 \<Longrightarrow> odd(p)" by auto2

lemma exists_prime [resolve]: "\<exists>p. prime(p)"
@proof
  @have "prime(2)" @with @have "2 \<noteq> 0" @end
@qed

lemma prime_factor_nat: "n \<in> nat \<Longrightarrow> n \<noteq> 1 \<Longrightarrow> \<exists>p. divides(\<nat>,p,n) \<and> prime(p)"
@proof
  @strong_induct "n \<in> nat"
  @case "prime(n)" @with @have "divides(\<nat>,n,n)" @end
  @case "n = \<zero>\<^sub>\<nat>" @with
    @obtain q where "prime(q)"
    @have "divides(\<nat>,q,0)"
  @end
@qed

end


theory Matching
imports
  Main
  Parity
  "../Graph_Theory/Graph_Theory"
begin

type_synonym label = nat
(*
section {* Definitions *}
*)
definition disjoint_arcs :: "('a, 'b) pre_digraph => 'b \<Rightarrow> 'b \<Rightarrow> bool" where
  "disjoint_arcs G e1 e2 = (
     tail G e1 \<noteq> tail G e2 \<and> tail G e1 \<noteq> head G e2 \<and>
     head G e1 \<noteq> tail G e2 \<and> head G e1 \<noteq> head G e2)"

definition matching :: "('a, 'b) pre_digraph \<Rightarrow> 'b set \<Rightarrow> bool" where
  "matching G M = (M \<subseteq> arcs G \<and> (\<forall>e1 \<in> M. \<forall>e2 \<in> M. e1 \<noteq> e2 \<longrightarrow> disjoint_arcs G e1 e2))"

definition OSC :: "('a, 'b) pre_digraph \<Rightarrow> ('a \<Rightarrow> label) \<Rightarrow> bool" where
  "OSC G L = (
     \<forall>e \<in> arcs G.
       L (tail G e) = 1 \<or> L (head G e) = 1 \<or>
       L (tail G e) = L (head G e) \<and> L (tail G e) \<ge> 2)"

definition weight:: "label set \<Rightarrow> (label \<Rightarrow> nat) \<Rightarrow> nat" where
  "weight LV f \<equiv> f 1 + (\<Sum>i\<in>LV. (f i) div 2)"

definition N :: "'a set \<Rightarrow> ('a \<Rightarrow> label) \<Rightarrow> label \<Rightarrow> nat" where
  "N V L i \<equiv> card {v \<in> V. L v = i}"

locale matching_locale = digraph +
  fixes maxM :: "'b set"
  fixes L :: "'a \<Rightarrow> label"
  assumes matching: "matching G maxM"
  assumes OSC: "OSC G L"
  assumes weight: "card maxM = weight {i \<in> L ` verts G. i > 1} (N (verts G) L)"

sublocale matching_locale \<subseteq> digraph ..

context matching_locale begin

definition degree :: "'a \<Rightarrow> nat" where
  "degree v \<equiv> card {e \<in> arcs G. tail G e = v \<or> head G e = v}"

definition edge_as_set :: "'b \<Rightarrow> 'a set" where
  "edge_as_set e \<equiv> {tail G e, head G e}"

definition matched :: "'b set \<Rightarrow> 'a \<Rightarrow> bool" where
  "matched M v \<equiv> v \<in> \<Union> (edge_as_set ` M)"

definition free :: "'b set \<Rightarrow> 'a \<Rightarrow> bool" where
  "free M v \<equiv> \<not> matched M v"

definition matching_i :: "nat \<Rightarrow> 'b set \<Rightarrow> 'b set" where
  "matching_i i M \<equiv> {e \<in> M. i=1 \<and> (L (tail G e) = i \<or> L (head G e) = i)
  \<or> i>1 \<and> L (tail G e) = i \<and> L (head G e) = i}"

definition V_i:: "nat \<Rightarrow> 'b set \<Rightarrow> 'a set" where
  "V_i i M \<equiv> \<Union> (edge_as_set ` matching_i i M)"

definition endpoint_inV :: "'a set \<Rightarrow> 'b \<Rightarrow> 'a" where
  "endpoint_inV V e \<equiv>  if tail G e \<in> V then tail G e else head G e"

definition relevant_endpoint :: "'b \<Rightarrow> 'a" where
  "relevant_endpoint e \<equiv> if L (tail G e) = 1 then tail G e else head G e"
(*
section {* Lemmas *}
*)

lemma definition_of_range:
  "endpoint_inV V1 ` matching_i 1 M =
  { v. \<exists> e \<in> matching_i 1 M. endpoint_inV V1 e = v }" by auto

lemma matching_i_arcs_as_sets:
  "edge_as_set ` matching_i i M =
  { e1. \<exists> e \<in> matching_i i M. edge_as_set e = e1}" by auto

lemma matching_disjointness:
  assumes "matching G M"
  assumes "e1 \<in> M"
  assumes "e2 \<in> M"
  assumes "e1 \<noteq> e2"
  shows  "edge_as_set e1 \<inter> edge_as_set e2 = {}"
  using assms
  by (auto simp add: edge_as_set_def disjoint_arcs_def matching_def)

lemma expand_set_containment:
  assumes "matching G M"
  assumes "e \<in> M"
  shows "e \<in> arcs G"
  using assms
  by (auto simp add:matching_def)

theorem injectivity:
  assumes is_m: "matching G M"
  assumes e1_in_M1: "e1 \<in> matching_i 1 M"
      and e2_in_M1: "e2 \<in> matching_i 1 M"
  assumes diff: "(e1 \<noteq> e2)"
  shows "endpoint_inV {v \<in> V. L v = 1} e1 \<noteq> endpoint_inV {v \<in> V. L v = 1} e2"
proof -
  from e1_in_M1 have "e1 \<in> M" by (auto simp add: matching_i_def)
  moreover
  from e2_in_M1 have "e2 \<in> M" by (auto simp add: matching_i_def)
  ultimately
  have disjoint_edge_sets: "edge_as_set e1 \<inter> edge_as_set e2 = {}"
    using diff is_m matching_disjointness by fast
  then show ?thesis by (auto simp add: edge_as_set_def endpoint_inV_def)
qed
(*
subsection {* @text{"|M1| \<le> n1"} *}
*)
lemma card_M1_le_NVL1:
  assumes "matching G M"
  shows "card (matching_i 1 M) \<le> N (verts G) L 1"
proof -
  let ?f = "endpoint_inV {v \<in> verts G. L v = 1}"
  let ?A = "matching_i 1 M"
  let ?B = "{v \<in> verts G. L v = 1}"
  have "inj_on ?f ?A" using assms injectivity
    unfolding inj_on_def by blast
  moreover have "?f ` ?A \<subseteq> ?B"
  proof -
    {
      fix e assume "e \<in> matching_i 1 M"
      hence "e \<in> arcs G"
        using assms by (auto simp add: matching_def matching_i_def)
      with `e \<in> matching_i 1 M`
      have "endpoint_inV {v \<in> verts G. L v = 1} e \<in> {v \<in> verts G. L v = 1}"
        using assms
        by (auto simp add: endpoint_inV_def matching_i_def intro: tail_in_verts head_in_verts)
    }
    then show ?thesis using assms definition_of_range by blast
  qed
  moreover have "finite ?B" by simp
  ultimately show ?thesis unfolding N_def by (rule card_inj_on_le)
qed

lemma edge_as_set_inj_on_Mi:
  assumes "matching G M"
  shows "inj_on edge_as_set (matching_i i M)"
  using assms
  unfolding inj_on_def edge_as_set_def matching_def
    disjoint_arcs_def matching_i_def
  by blast

lemma card_edge_as_set_Mi_twice_card_partitions:
  assumes "matching G M \<and> i > 1"
  shows "2 * card (edge_as_set`matching_i i M)
  = card (V_i i M)" (is "2 * card ?C = card ?Vi")
proof -
  from assms have 1: "finite (\<Union> ?C)"
    by (auto simp add: matching_def
      matching_i_def edge_as_set_def finite_subset)
  show ?thesis unfolding V_i_def
  proof (rule card_partition)
    show "finite ?C" using 1 by (rule finite_UnionD)
  next
    show "finite (\<Union> ?C)" using 1 .
  next
    fix c assume "c \<in> ?C" then show "card c = 2"
    proof (rule imageE)
      fix x
      assume 2: "c = edge_as_set x" and 3: "x \<in> matching_i i M"
      with assms have "x \<in> arcs G"
        unfolding matching_i_def matching_def by blast
      then have "tail G x \<noteq> head G x" using assms 3 by (metis no_loops)
      with 2 show ?thesis by (auto simp add: edge_as_set_def)
    qed
  next
    fix x1 x2
    assume 4: "x1 \<in> ?C" and 5: "x2 \<in> ?C" and 6: "x1 \<noteq> x2"
    {
      fix e1 e2
      assume 7: "x1 = edge_as_set e1" "e1 \<in> matching_i i M"
        "x2 = edge_as_set e2" "e2 \<in> matching_i i M"
      from assms have "matching G M" by simp
      moreover
      from 7 assms have "e1 \<in> M" and "e2 \<in> M"
        by (simp_all add: matching_i_def)
      moreover from 6 7 have "e1 \<noteq> e2" by blast
      ultimately have "x1 \<inter> x2 = {}" unfolding 7
        by (rule matching_disjointness)
    }
    with 4 5 show "x1 \<inter> x2 = {}" by clarsimp
  qed
qed

lemma card_Mi_twice_card_Vi:
  assumes "matching G M \<and> i > 1"
  shows "2 * card (matching_i i M) = card (V_i i M)"
proof -
  show ?thesis
    by (metis assms card_edge_as_set_Mi_twice_card_partitions
      edge_as_set_inj_on_Mi card_image)
qed

lemma card_Mi_le_floor_div_2_Vi:
  assumes "matching G M \<and> i > 1"
  shows "card (matching_i i M) \<le> (card (V_i i M)) div 2"
  using card_Mi_twice_card_Vi[OF assms]
  by arith

lemma card_Vi_le_NVLi:
  assumes "i>1 \<and> matching G M"
  shows "card (V_i i M) \<le> N (verts G) L i"
  unfolding N_def
proof (rule card_mono)
  show "finite {v \<in> verts G. L v = i}" using assms
    by (simp add: matching_def)
next
  let ?A = "edge_as_set ` matching_i i M"
  let ?C = "{v \<in> verts G. L v = i}"
  show "V_i i M \<subseteq> ?C" using assms unfolding V_i_def
  proof (intro Union_least)
    fix X assume "X \<in> ?A"
    with assms have "\<exists>x \<in> matching_i i M. edge_as_set x = X"
      by (simp add: matching_i_arcs_as_sets)
    with assms show "X \<subseteq> ?C"
      unfolding matching_def
        matching_i_def edge_as_set_def by (blast intro: tail_in_verts head_in_verts)
  qed
qed

lemma card_Mi_le_floor_div_2_NVLi:
  assumes "matching G M \<and> i > 1"
  shows "card (matching_i i M) \<le> (N (verts G) L i) div 2"
proof -
  from assms have "card (V_i i M) \<le> (N (verts G) L i)"
    by (simp add: card_Vi_le_NVLi)
  then have "card (V_i i M) div 2 \<le> (N (verts G) L i) div 2"
    by simp
  moreover from assms have
    "card (matching_i i M) \<le> card (V_i i M) div 2"
    by (intro card_Mi_le_floor_div_2_Vi)
  ultimately show ?thesis by auto
qed

lemma card_M_le_sum_card_Mi:
assumes "matching G M" and "OSC G L"
shows "card M \<le> (\<Sum> i \<in> L`verts G. card (matching_i i M))"
  (is "card _ \<le> ?CardMi")
proof -
  let ?UnMi = "\<Union>x \<in> L`verts G. matching_i x M"
  from assms have 1: "finite ?UnMi"
    by (auto simp add: matching_def matching_i_def finite_subset)
  {
    fix e assume e_inM: "e \<in> M"
    let ?v = "relevant_endpoint e"
    have 1: "e \<in> matching_i (L ?v) M" using assms e_inM
      proof cases
        assume "L (tail G e) = 1"
        thus ?thesis using assms e_inM
          by (simp add: relevant_endpoint_def matching_i_def)
      next
        assume a: "L (tail G e) \<noteq> 1"
        have "L (tail G e) = 1 \<or> L (head G e) = 1
          \<or>  (L (tail G e) = L (head G e) \<and> L (tail G e) >1)"
          using assms e_inM unfolding OSC_def
          by (auto intro: expand_set_containment)
        thus ?thesis using assms e_inM a
          by (auto simp add: relevant_endpoint_def matching_i_def)
      qed
      have 2: "?v \<in> verts G" using assms e_inM
        by (auto simp add: matching_def relevant_endpoint_def intro: tail_in_verts head_in_verts)
      then have "\<exists> v \<in> verts G. e \<in> matching_i (L v) M" using assms 1 2
        by (intro bexI)
    }
    with assms have "M \<subseteq> ?UnMi" by (auto)
    with assms and 1 have "card M \<le> card ?UnMi" by (intro card_mono)
    moreover from assms have "card ?UnMi = ?CardMi"
    proof (intro card_UN_disjoint)
      show "finite (L`verts G)" by simp
    next
      show "\<forall>i\<in>L`verts G. finite (matching_i i M)" using assms
        using finite_arcs
        unfolding matching_def matching_i_def
        by (blast intro: finite_subset finite_arcs)
    next
      show "\<forall>i \<in> L`verts G. \<forall>j \<in> L`verts G. i \<noteq> j \<longrightarrow>
        matching_i i M \<inter> matching_i j M = {}" using assms
        by (auto simp add: matching_i_def)
    qed
  ultimately show ?thesis by simp
qed

theorem card_M_le_weight_NVLi:
  assumes "matching G M" and "OSC G L"
  shows "card M \<le> weight {i \<in> L ` verts G. i > 1} (N (verts G) L)" (is "_ \<le> ?W")
proof -
  let ?M01 = "\<Sum>i| i \<in> L ` verts G \<and> (i=1 \<or> i=0). card (matching_i i M)"
  let ?Mgr1 = "\<Sum>i| i \<in> L ` verts G \<and> 1 < i. card (matching_i i M)"
  let ?Mi = "\<Sum> i\<in>L ` verts G. card (matching_i i M)"
  have "card M \<le> ?Mi" using assms by (rule card_M_le_sum_card_Mi)
  moreover
  have "?Mi \<le> ?W"
  proof -
    let ?A = "{i \<in> L ` verts G. i = 1 \<or> i = 0}"
    let ?B = "{i \<in> L ` verts G. 1 < i}"
    let ?g = "\<lambda> i. card (matching_i i M)"
    let ?set01 = "{ i. i : L ` verts G & (i = 1 | i = 0)}"
    have a: "L ` verts G = ?A \<union> ?B" using assms by auto
    have b: "setsum ?g (?A \<union> ?B) = setsum ?g ?A + setsum ?g ?B"
      by (auto intro: setsum.union_disjoint)
    have 1: "?Mi = ?M01+ ?Mgr1" using assms a b by simp
    moreover
    have 0: "card (matching_i 0 M) = 0" using assms
      by (simp add: matching_i_def)
      have 2: "?M01 \<le> N (verts G) L 1"
      proof cases
        assume a: "1 \<in> L ` verts G"
        have "?M01 = card (matching_i 1 M)"
        proof cases
          assume b: "0 \<in> L ` verts G"
          with a assms have  "?set01 = {0, 1}" by blast
          thus ?thesis using assms 0 by simp
        next
          assume b: "0 \<notin> L ` verts G"
          with a have "?set01 = {1}" by (auto simp del:One_nat_def)
          thus ?thesis by simp
        qed
        thus ?thesis using assms a
          by (simp del: One_nat_def, intro card_M1_le_NVL1)
      next
        assume a: "1 \<notin> L ` verts G"
        show ?thesis
        proof cases
          assume b: "0 \<in> L ` verts G"
          with a assms have  "?set01 = {0}" by (auto simp del:One_nat_def)
          thus ?thesis using assms 0 by auto
        next
          assume b: "0 \<notin> L ` verts G"
          with a have "?set01 = {}" by (auto simp del:One_nat_def)
            then have "?M01 = (\<Sum>i\<in>{}. card (matching_i i M))" by auto
            thus ?thesis by simp
          qed
        qed
      moreover
      have 3: "?Mgr1 \<le> (\<Sum>i|i\<in>L ` verts G \<and> 1 < i. N (verts G) L i div 2)"
        using assms
        by (intro setsum_mono card_Mi_le_floor_div_2_NVLi, simp)
    ultimately
    show ?thesis using 1 2 3 assms by (simp add: weight_def)
  qed
  ultimately show ?thesis by simp
qed
(*
section {* Final Theorem *}
*)
theorem maximum_cardinality_matching:
  "matching G M' \<longrightarrow> card M' \<le> card maxM"
  using card_M_le_weight_NVLi OSC matching weight
  by simp

end

end