(*  Title:      HOL/ex/LocaleTest2.thy
    Author:     Clemens Ballarin
    Copyright (c) 2007 by Clemens Ballarin

More regression tests for locales.
Definitions are less natural in FOL, since there is no selection operator.
Hence we do them here in HOL, not in the main test suite for locales,
which is FOL/ex/LocaleTest.thy
*)

section {* Test of Locale Interpretation *}

theory LocaleTest2
imports Main GCD
begin

section {* Interpretation of Defined Concepts *}

text {* Naming convention for global objects: prefixes D and d *}

subsection {* Lattices *}

text {* Much of the lattice proofs are from HOL/Lattice. *}

subsubsection {* Definitions *}

locale dpo =
  fixes le :: "['a, 'a] => bool" (infixl "\<sqsubseteq>" 50)
  assumes refl [intro, simp]: "x \<sqsubseteq> x"
    and antisym [intro]: "[| x \<sqsubseteq> y; y \<sqsubseteq> x |] ==> x = y"
    and trans [trans]: "[| x \<sqsubseteq> y; y \<sqsubseteq> z |] ==> x \<sqsubseteq> z"

begin

theorem circular:
  "[| x \<sqsubseteq> y; y \<sqsubseteq> z; z \<sqsubseteq> x |] ==> x = y & y = z"
  by (blast intro: trans)

definition
  less :: "['a, 'a] => bool" (infixl "\<sqsubset>" 50)
  where "(x \<sqsubset> y) = (x \<sqsubseteq> y & x ~= y)"

theorem abs_test:
  "op \<sqsubset> = (%x y. x \<sqsubset> y)"
  by simp

definition
  is_inf :: "['a, 'a, 'a] => bool"
  where "is_inf x y i = (i \<sqsubseteq> x \<and> i \<sqsubseteq> y \<and> (\<forall>z. z \<sqsubseteq> x \<and> z \<sqsubseteq> y \<longrightarrow> z \<sqsubseteq> i))"

definition
  is_sup :: "['a, 'a, 'a] => bool"
  where "is_sup x y s = (x \<sqsubseteq> s \<and> y \<sqsubseteq> s \<and> (\<forall>z. x \<sqsubseteq> z \<and> y \<sqsubseteq> z \<longrightarrow> s \<sqsubseteq> z))"

end

locale dlat = dpo +
  assumes ex_inf: "EX inf. dpo.is_inf le x y inf"
    and ex_sup: "EX sup. dpo.is_sup le x y sup"

begin

definition
  meet :: "['a, 'a] => 'a" (infixl "\<sqinter>" 70)
  where "x \<sqinter> y = (THE inf. is_inf x y inf)"

definition
  join :: "['a, 'a] => 'a" (infixl "\<squnion>" 65)
  where "x \<squnion> y = (THE sup. is_sup x y sup)"

lemma is_infI [intro?]: "i \<sqsubseteq> x \<Longrightarrow> i \<sqsubseteq> y \<Longrightarrow>
    (\<And>z. z \<sqsubseteq> x \<Longrightarrow> z \<sqsubseteq> y \<Longrightarrow> z \<sqsubseteq> i) \<Longrightarrow> is_inf x y i"
  by (unfold is_inf_def) blast

lemma is_inf_lower [elim?]:
  "is_inf x y i \<Longrightarrow> (i \<sqsubseteq> x \<Longrightarrow> i \<sqsubseteq> y \<Longrightarrow> C) \<Longrightarrow> C"
  by (unfold is_inf_def) blast

lemma is_inf_greatest [elim?]:
    "is_inf x y i \<Longrightarrow> z \<sqsubseteq> x \<Longrightarrow> z \<sqsubseteq> y \<Longrightarrow> z \<sqsubseteq> i"
  by (unfold is_inf_def) blast

theorem is_inf_uniq: "is_inf x y i \<Longrightarrow> is_inf x y i' \<Longrightarrow> i = i'"
proof -
  assume inf: "is_inf x y i"
  assume inf': "is_inf x y i'"
  show ?thesis
  proof (rule antisym)
    from inf' show "i \<sqsubseteq> i'"
    proof (rule is_inf_greatest)
      from inf show "i \<sqsubseteq> x" ..
      from inf show "i \<sqsubseteq> y" ..
    qed
    from inf show "i' \<sqsubseteq> i"
    proof (rule is_inf_greatest)
      from inf' show "i' \<sqsubseteq> x" ..
      from inf' show "i' \<sqsubseteq> y" ..
    qed
  qed
qed

theorem is_inf_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> is_inf x y x"
proof -
  assume "x \<sqsubseteq> y"
  show ?thesis
  proof
    show "x \<sqsubseteq> x" ..
    show "x \<sqsubseteq> y" by fact
    fix z assume "z \<sqsubseteq> x" and "z \<sqsubseteq> y" show "z \<sqsubseteq> x" by fact
  qed
qed

lemma meet_equality [elim?]: "is_inf x y i \<Longrightarrow> x \<sqinter> y = i"
proof (unfold meet_def)
  assume "is_inf x y i"
  then show "(THE i. is_inf x y i) = i"
    by (rule the_equality) (rule is_inf_uniq [OF _ `is_inf x y i`])
qed

lemma meetI [intro?]:
    "i \<sqsubseteq> x \<Longrightarrow> i \<sqsubseteq> y \<Longrightarrow> (\<And>z. z \<sqsubseteq> x \<Longrightarrow> z \<sqsubseteq> y \<Longrightarrow> z \<sqsubseteq> i) \<Longrightarrow> x \<sqinter> y = i"
  by (rule meet_equality, rule is_infI) blast+

lemma is_inf_meet [intro?]: "is_inf x y (x \<sqinter> y)"
proof (unfold meet_def)
  from ex_inf obtain i where "is_inf x y i" ..
  then show "is_inf x y (THE i. is_inf x y i)"
    by (rule theI) (rule is_inf_uniq [OF _ `is_inf x y i`])
qed

lemma meet_left [intro?]:
  "x \<sqinter> y \<sqsubseteq> x"
  by (rule is_inf_lower) (rule is_inf_meet)

lemma meet_right [intro?]:
  "x \<sqinter> y \<sqsubseteq> y"
  by (rule is_inf_lower) (rule is_inf_meet)

lemma meet_le [intro?]:
  "[| z \<sqsubseteq> x; z \<sqsubseteq> y |] ==> z \<sqsubseteq> x \<sqinter> y"
  by (rule is_inf_greatest) (rule is_inf_meet)

lemma is_supI [intro?]: "x \<sqsubseteq> s \<Longrightarrow> y \<sqsubseteq> s \<Longrightarrow>
    (\<And>z. x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> s \<sqsubseteq> z) \<Longrightarrow> is_sup x y s"
  by (unfold is_sup_def) blast

lemma is_sup_least [elim?]:
    "is_sup x y s \<Longrightarrow> x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> s \<sqsubseteq> z"
  by (unfold is_sup_def) blast

lemma is_sup_upper [elim?]:
    "is_sup x y s \<Longrightarrow> (x \<sqsubseteq> s \<Longrightarrow> y \<sqsubseteq> s \<Longrightarrow> C) \<Longrightarrow> C"
  by (unfold is_sup_def) blast

theorem is_sup_uniq: "is_sup x y s \<Longrightarrow> is_sup x y s' \<Longrightarrow> s = s'"
proof -
  assume sup: "is_sup x y s"
  assume sup': "is_sup x y s'"
  show ?thesis
  proof (rule antisym)
    from sup show "s \<sqsubseteq> s'"
    proof (rule is_sup_least)
      from sup' show "x \<sqsubseteq> s'" ..
      from sup' show "y \<sqsubseteq> s'" ..
    qed
    from sup' show "s' \<sqsubseteq> s"
    proof (rule is_sup_least)
      from sup show "x \<sqsubseteq> s" ..
      from sup show "y \<sqsubseteq> s" ..
    qed
  qed
qed

theorem is_sup_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> is_sup x y y"
proof -
  assume "x \<sqsubseteq> y"
  show ?thesis
  proof
    show "x \<sqsubseteq> y" by fact
    show "y \<sqsubseteq> y" ..
    fix z assume "x \<sqsubseteq> z" and "y \<sqsubseteq> z"
    show "y \<sqsubseteq> z" by fact
  qed
qed

lemma join_equality [elim?]: "is_sup x y s \<Longrightarrow> x \<squnion> y = s"
proof (unfold join_def)
  assume "is_sup x y s"
  then show "(THE s. is_sup x y s) = s"
    by (rule the_equality) (rule is_sup_uniq [OF _ `is_sup x y s`])
qed

lemma joinI [intro?]: "x \<sqsubseteq> s \<Longrightarrow> y \<sqsubseteq> s \<Longrightarrow>
    (\<And>z. x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> s \<sqsubseteq> z) \<Longrightarrow> x \<squnion> y = s"
  by (rule join_equality, rule is_supI) blast+

lemma is_sup_join [intro?]: "is_sup x y (x \<squnion> y)"
proof (unfold join_def)
  from ex_sup obtain s where "is_sup x y s" ..
  then show "is_sup x y (THE s. is_sup x y s)"
    by (rule theI) (rule is_sup_uniq [OF _ `is_sup x y s`])
qed

lemma join_left [intro?]:
  "x \<sqsubseteq> x \<squnion> y"
  by (rule is_sup_upper) (rule is_sup_join)

lemma join_right [intro?]:
  "y \<sqsubseteq> x \<squnion> y"
  by (rule is_sup_upper) (rule is_sup_join)

lemma join_le [intro?]:
  "[| x \<sqsubseteq> z; y \<sqsubseteq> z |] ==> x \<squnion> y \<sqsubseteq> z"
  by (rule is_sup_least) (rule is_sup_join)

theorem meet_assoc: "(x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)"
proof (rule meetI)
  show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> x \<sqinter> y"
  proof
    show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> x" ..
    show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> y"
    proof -
      have "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> y \<sqinter> z" ..
      also have "\<dots> \<sqsubseteq> y" ..
      finally show ?thesis .
    qed
  qed
  show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> z"
  proof -
    have "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> y \<sqinter> z" ..
    also have "\<dots> \<sqsubseteq> z" ..
    finally show ?thesis .
  qed
  fix w assume "w \<sqsubseteq> x \<sqinter> y" and "w \<sqsubseteq> z"
  show "w \<sqsubseteq> x \<sqinter> (y \<sqinter> z)"
  proof
    show "w \<sqsubseteq> x"
    proof -
      have "w \<sqsubseteq> x \<sqinter> y" by fact
      also have "\<dots> \<sqsubseteq> x" ..
      finally show ?thesis .
    qed
    show "w \<sqsubseteq> y \<sqinter> z"
    proof
      show "w \<sqsubseteq> y"
      proof -
        have "w \<sqsubseteq> x \<sqinter> y" by fact
        also have "\<dots> \<sqsubseteq> y" ..
        finally show ?thesis .
      qed
      show "w \<sqsubseteq> z" by fact
    qed
  qed
qed

theorem meet_commute: "x \<sqinter> y = y \<sqinter> x"
proof (rule meetI)
  show "y \<sqinter> x \<sqsubseteq> x" ..
  show "y \<sqinter> x \<sqsubseteq> y" ..
  fix z assume "z \<sqsubseteq> y" and "z \<sqsubseteq> x"
  then show "z \<sqsubseteq> y \<sqinter> x" ..
qed

theorem meet_join_absorb: "x \<sqinter> (x \<squnion> y) = x"
proof (rule meetI)
  show "x \<sqsubseteq> x" ..
  show "x \<sqsubseteq> x \<squnion> y" ..
  fix z assume "z \<sqsubseteq> x" and "z \<sqsubseteq> x \<squnion> y"
  show "z \<sqsubseteq> x" by fact
qed

theorem join_assoc: "(x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
proof (rule joinI)
  show "x \<squnion> y \<sqsubseteq> x \<squnion> (y \<squnion> z)"
  proof
    show "x \<sqsubseteq> x \<squnion> (y \<squnion> z)" ..
    show "y \<sqsubseteq> x \<squnion> (y \<squnion> z)"
    proof -
      have "y \<sqsubseteq> y \<squnion> z" ..
      also have "... \<sqsubseteq> x \<squnion> (y \<squnion> z)" ..
      finally show ?thesis .
    qed
  qed
  show "z \<sqsubseteq> x \<squnion> (y \<squnion> z)"
  proof -
    have "z \<sqsubseteq> y \<squnion> z"  ..
    also have "... \<sqsubseteq> x \<squnion> (y \<squnion> z)" ..
    finally show ?thesis .
  qed
  fix w assume "x \<squnion> y \<sqsubseteq> w" and "z \<sqsubseteq> w"
  show "x \<squnion> (y \<squnion> z) \<sqsubseteq> w"
  proof
    show "x \<sqsubseteq> w"
    proof -
      have "x \<sqsubseteq> x \<squnion> y" ..
      also have "\<dots> \<sqsubseteq> w" by fact
      finally show ?thesis .
    qed
    show "y \<squnion> z \<sqsubseteq> w"
    proof
      show "y \<sqsubseteq> w"
      proof -
        have "y \<sqsubseteq> x \<squnion> y" ..
        also have "... \<sqsubseteq> w" by fact
        finally show ?thesis .
      qed
      show "z \<sqsubseteq> w" by fact
    qed
  qed
qed

theorem join_commute: "x \<squnion> y = y \<squnion> x"
proof (rule joinI)
  show "x \<sqsubseteq> y \<squnion> x" ..
  show "y \<sqsubseteq> y \<squnion> x" ..
  fix z assume "y \<sqsubseteq> z" and "x \<sqsubseteq> z"
  then show "y \<squnion> x \<sqsubseteq> z" ..
qed

theorem join_meet_absorb: "x \<squnion> (x \<sqinter> y) = x"
proof (rule joinI)
  show "x \<sqsubseteq> x" ..
  show "x \<sqinter> y \<sqsubseteq> x" ..
  fix z assume "x \<sqsubseteq> z" and "x \<sqinter> y \<sqsubseteq> z"
  show "x \<sqsubseteq> z" by fact
qed

theorem meet_idem: "x \<sqinter> x = x"
proof -
  have "x \<sqinter> (x \<squnion> (x \<sqinter> x)) = x" by (rule meet_join_absorb)
  also have "x \<squnion> (x \<sqinter> x) = x" by (rule join_meet_absorb)
  finally show ?thesis .
qed

theorem meet_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> x \<sqinter> y = x"
proof (rule meetI)
  assume "x \<sqsubseteq> y"
  show "x \<sqsubseteq> x" ..
  show "x \<sqsubseteq> y" by fact
  fix z assume "z \<sqsubseteq> x" and "z \<sqsubseteq> y"
  show "z \<sqsubseteq> x" by fact
qed

theorem meet_related2 [elim?]: "y \<sqsubseteq> x \<Longrightarrow> x \<sqinter> y = y"
  by (drule meet_related) (simp add: meet_commute)

theorem join_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> x \<squnion> y = y"
proof (rule joinI)
  assume "x \<sqsubseteq> y"
  show "y \<sqsubseteq> y" ..
  show "x \<sqsubseteq> y" by fact
  fix z assume "x \<sqsubseteq> z" and "y \<sqsubseteq> z"
  show "y \<sqsubseteq> z" by fact
qed

theorem join_related2 [elim?]: "y \<sqsubseteq> x \<Longrightarrow> x \<squnion> y = x"
  by (drule join_related) (simp add: join_commute)

text {* Additional theorems *}

theorem meet_connection: "(x \<sqsubseteq> y) = (x \<sqinter> y = x)"
proof
  assume "x \<sqsubseteq> y"
  then have "is_inf x y x" ..
  then show "x \<sqinter> y = x" ..
next
  have "x \<sqinter> y \<sqsubseteq> y" ..
  also assume "x \<sqinter> y = x"
  finally show "x \<sqsubseteq> y" .
qed

theorem meet_connection2: "(x \<sqsubseteq> y) = (y \<sqinter> x = x)"
  using meet_commute meet_connection by simp

theorem join_connection: "(x \<sqsubseteq> y) = (x \<squnion> y = y)"
proof
  assume "x \<sqsubseteq> y"
  then have "is_sup x y y" ..
  then show "x \<squnion> y = y" ..
next
  have "x \<sqsubseteq> x \<squnion> y" ..
  also assume "x \<squnion> y = y"
  finally show "x \<sqsubseteq> y" .
qed

theorem join_connection2: "(x \<sqsubseteq> y) = (x \<squnion> y = y)"
  using join_commute join_connection by simp

text {* Naming according to Jacobson I, p.\ 459. *}

lemmas L1 = join_commute meet_commute
lemmas L2 = join_assoc meet_assoc
(*lemmas L3 = join_idem meet_idem*)
lemmas L4 = join_meet_absorb meet_join_absorb

end

locale ddlat = dlat +
  assumes meet_distr:
    "dlat.meet le x (dlat.join le y z) =
    dlat.join le (dlat.meet le x y) (dlat.meet le x z)"

begin

lemma join_distr:
  "x \<squnion> (y \<sqinter> z) = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
  txt {* Jacobson I, p.\ 462 *}
proof -
  have "x \<squnion> (y \<sqinter> z) = (x \<squnion> (x \<sqinter> z)) \<squnion> (y \<sqinter> z)" by (simp add: L4)
  also have "... = x \<squnion> ((x \<sqinter> z) \<squnion> (y \<sqinter> z))" by (simp add: L2)
  also have "... = x \<squnion> ((x \<squnion> y) \<sqinter> z)" by (simp add: L1 meet_distr)
  also have "... = ((x \<squnion> y) \<sqinter> x) \<squnion> ((x \<squnion> y) \<sqinter> z)" by (simp add: L1 L4)
  also have "... = (x \<squnion> y) \<sqinter> (x \<squnion> z)" by (simp add: meet_distr)
  finally show ?thesis .
qed

end

locale dlo = dpo +
  assumes total: "x \<sqsubseteq> y | y \<sqsubseteq> x"

begin

lemma less_total: "x \<sqsubset> y | x = y | y \<sqsubset> x"
  using total
  by (unfold less_def) blast

end

sublocale dlo < dlat
proof
  fix x y
  from total have "is_inf x y (if x \<sqsubseteq> y then x else y)" by (auto simp: is_inf_def)
  then show "EX inf. is_inf x y inf" by blast
next
  fix x y
  from total have "is_sup x y (if x \<sqsubseteq> y then y else x)" by (auto simp: is_sup_def)
  then show "EX sup. is_sup x y sup" by blast
qed

sublocale dlo < ddlat
proof
  fix x y z
  show "x \<sqinter> (y \<squnion> z) = x \<sqinter> y \<squnion> x \<sqinter> z" (is "?l = ?r")
    txt {* Jacobson I, p.\ 462 *}
  proof -
    { assume c: "y \<sqsubseteq> x" "z \<sqsubseteq> x"
      from c have "?l = y \<squnion> z"
        by (metis c (*join_commute*) join_connection2 join_related2 (*meet_commute*) meet_connection meet_related2 total)
      also from c have "... = ?r" by (metis (*c*) (*join_commute*) meet_related2)
      finally have "?l = ?r" . }
    moreover
    { assume c: "x \<sqsubseteq> y | x \<sqsubseteq> z"
      from c have "?l = x"
        by (metis (*antisym*) (*c*) (*circular*) (*join_assoc*)(* join_commute *) join_connection2 (*join_left*) join_related2 meet_connection(* meet_related2*) total trans)
      also from c have "... = ?r"
        by (metis join_commute join_related2 meet_connection meet_related2 total)
      finally have "?l = ?r" . }
    moreover note total
    ultimately show ?thesis by blast
  qed
qed

subsubsection {* Total order @{text "<="} on @{typ int} *}

interpretation int: dpo "op <= :: [int, int] => bool"
  where "(dpo.less (op <=) (x::int) y) = (x < y)"
  txt {* We give interpretation for less, but not @{text is_inf} and @{text is_sub}. *}
proof -
  show "dpo (op <= :: [int, int] => bool)"
    proof qed auto
  then interpret int: dpo "op <= :: [int, int] => bool" .
    txt {* Gives interpreted version of @{text less_def} (without condition). *}
  show "(dpo.less (op <=) (x::int) y) = (x < y)"
    by (unfold int.less_def) auto
qed

thm int.circular
lemma "\<lbrakk> (x::int) \<le> y; y \<le> z; z \<le> x\<rbrakk> \<Longrightarrow> x = y \<and> y = z"
  apply (rule int.circular) apply assumption apply assumption apply assumption done
thm int.abs_test
lemma "(op < :: [int, int] => bool) = op <"
  apply (rule int.abs_test) done

interpretation int: dlat "op <= :: [int, int] => bool"
  where meet_eq: "dlat.meet (op <=) (x::int) y = min x y"
    and join_eq: "dlat.join (op <=) (x::int) y = max x y"
proof -
  show "dlat (op <= :: [int, int] => bool)"
    apply unfold_locales
    apply (unfold int.is_inf_def int.is_sup_def)
    apply arith+
    done
  then interpret int: dlat "op <= :: [int, int] => bool" .
  txt {* Interpretation to ease use of definitions, which are
    conditional in general but unconditional after interpretation. *}
  show "dlat.meet (op <=) (x::int) y = min x y"
    apply (unfold int.meet_def)
    apply (rule the_equality)
    apply (unfold int.is_inf_def)
    by auto
  show "dlat.join (op <=) (x::int) y = max x y"
    apply (unfold int.join_def)
    apply (rule the_equality)
    apply (unfold int.is_sup_def)
    by auto
qed

interpretation int: dlo "op <= :: [int, int] => bool"
  proof qed arith

text {* Interpreted theorems from the locales, involving defined terms. *}

thm int.less_def text {* from dpo *}
thm int.meet_left text {* from dlat *}
thm int.meet_distr text {* from ddlat *}
thm int.less_total text {* from dlo *}

subsubsection {* Total order @{text "<="} on @{typ nat} *}

interpretation nat: dpo "op <= :: [nat, nat] => bool"
  where "dpo.less (op <=) (x::nat) y = (x < y)"
  txt {* We give interpretation for less, but not @{text is_inf} and @{text is_sub}. *}
proof -
  show "dpo (op <= :: [nat, nat] => bool)"
    proof qed auto
  then interpret nat: dpo "op <= :: [nat, nat] => bool" .
    txt {* Gives interpreted version of @{text less_def} (without condition). *}
  show "dpo.less (op <=) (x::nat) y = (x < y)"
    apply (unfold nat.less_def)
    apply auto
    done
qed

interpretation nat: dlat "op <= :: [nat, nat] => bool"
  where "dlat.meet (op <=) (x::nat) y = min x y"
    and "dlat.join (op <=) (x::nat) y = max x y"
proof -
  show "dlat (op <= :: [nat, nat] => bool)"
    apply unfold_locales
    apply (unfold nat.is_inf_def nat.is_sup_def)
    apply arith+
    done
  then interpret nat: dlat "op <= :: [nat, nat] => bool" .
  txt {* Interpretation to ease use of definitions, which are
    conditional in general but unconditional after interpretation. *}
  show "dlat.meet (op <=) (x::nat) y = min x y"
    apply (unfold nat.meet_def)
    apply (rule the_equality)
    apply (unfold nat.is_inf_def)
    by auto
  show "dlat.join (op <=) (x::nat) y = max x y"
    apply (unfold nat.join_def)
    apply (rule the_equality)
    apply (unfold nat.is_sup_def)
    by auto
qed

interpretation nat: dlo "op <= :: [nat, nat] => bool"
  proof qed arith

text {* Interpreted theorems from the locales, involving defined terms. *}

thm nat.less_def text {* from dpo *}
thm nat.meet_left text {* from dlat *}
thm nat.meet_distr text {* from ddlat *}
thm nat.less_total text {* from ldo *}

subsubsection {* Lattice @{text "dvd"} on @{typ nat} *}

interpretation nat_dvd: dpo "op dvd :: [nat, nat] => bool"
  where "dpo.less (op dvd) (x::nat) y = (x dvd y & x ~= y)"
  txt {* We give interpretation for less, but not @{text is_inf} and @{text is_sub}. *}
proof -
  show "dpo (op dvd :: [nat, nat] => bool)"
    proof qed (auto simp: dvd_def)
  then interpret nat_dvd: dpo "op dvd :: [nat, nat] => bool" .
    txt {* Gives interpreted version of @{text less_def} (without condition). *}
  show "dpo.less (op dvd) (x::nat) y = (x dvd y & x ~= y)"
    apply (unfold nat_dvd.less_def)
    apply auto
    done
qed

interpretation nat_dvd: dlat "op dvd :: [nat, nat] => bool"
  where "dlat.meet (op dvd) (x::nat) y = gcd x y"
    and "dlat.join (op dvd) (x::nat) y = lcm x y"
proof -
  show "dlat (op dvd :: [nat, nat] => bool)"
    apply unfold_locales
    apply (unfold nat_dvd.is_inf_def nat_dvd.is_sup_def)
    apply (rule_tac x = "gcd x y" in exI)
    apply auto [1]
    apply (rule_tac x = "lcm x y" in exI)
    apply (auto intro: lcm_dvd1_nat lcm_dvd2_nat lcm_least_nat)
    done
  then interpret nat_dvd: dlat "op dvd :: [nat, nat] => bool" .
  txt {* Interpretation to ease use of definitions, which are
    conditional in general but unconditional after interpretation. *}
  show "dlat.meet (op dvd) (x::nat) y = gcd x y"
    apply (unfold nat_dvd.meet_def)
    apply (rule the_equality)
    apply (unfold nat_dvd.is_inf_def)
    by auto
  show "dlat.join (op dvd) (x::nat) y = lcm x y"
    apply (unfold nat_dvd.join_def)
    apply (rule the_equality)
    apply (unfold nat_dvd.is_sup_def)
    by (auto intro: lcm_dvd1_nat lcm_dvd2_nat lcm_least_nat)
qed

text {* Interpreted theorems from the locales, involving defined terms. *}

thm nat_dvd.less_def text {* from dpo *}
lemma "((x::nat) dvd y & x ~= y) = (x dvd y & x ~= y)"
  apply (rule nat_dvd.less_def) done
thm nat_dvd.meet_left text {* from dlat *}
lemma "gcd x y dvd (x::nat)"
  apply (rule nat_dvd.meet_left) done

subsection {* Group example with defined operations @{text inv} and @{text unit} *}

subsubsection {* Locale declarations and lemmas *}

locale Dsemi =
  fixes prod (infixl "**" 65)
  assumes assoc: "(x ** y) ** z = x ** (y ** z)"

locale Dmonoid = Dsemi +
  fixes one
  assumes l_one [simp]: "one ** x = x"
    and r_one [simp]: "x ** one = x"

begin

definition
  inv where "inv x = (THE y. x ** y = one & y ** x = one)"
definition
  unit where "unit x = (EX y. x ** y = one  & y ** x = one)"

lemma inv_unique:
  assumes eq: "y ** x = one" "x ** y' = one"
  shows "y = y'"
proof -
  from eq have "y = y ** (x ** y')" by (simp add: r_one)
  also have "... = (y ** x) ** y'" by (simp add: assoc)
  also from eq have "... = y'" by (simp add: l_one)
  finally show ?thesis .
qed

lemma unit_one [intro, simp]:
  "unit one"
  by (unfold unit_def) auto

lemma unit_l_inv_ex:
  "unit x ==> \<exists>y. y ** x = one"
  by (unfold unit_def) auto

lemma unit_r_inv_ex:
  "unit x ==> \<exists>y. x ** y = one"
  by (unfold unit_def) auto

lemma unit_l_inv:
  "unit x ==> inv x ** x = one"
  apply (simp add: unit_def inv_def) apply (erule exE)
  apply (rule theI2, fast)
  apply (rule inv_unique)
  apply fast+
  done

lemma unit_r_inv:
  "unit x ==> x ** inv x = one"
  apply (simp add: unit_def inv_def) apply (erule exE)
  apply (rule theI2, fast)
  apply (rule inv_unique)
  apply fast+
  done

lemma unit_inv_unit [intro, simp]:
  "unit x ==> unit (inv x)"
proof -
  assume x: "unit x"
  show "unit (inv x)"
    by (auto simp add: unit_def
      intro: unit_l_inv unit_r_inv x)
qed

lemma unit_l_cancel [simp]:
  "unit x ==> (x ** y = x ** z) = (y = z)"
proof
  assume eq: "x ** y = x ** z"
    and G: "unit x"
  then have "(inv x ** x) ** y = (inv x ** x) ** z"
    by (simp add: assoc)
  with G show "y = z" by (simp add: unit_l_inv)
next
  assume eq: "y = z"
    and G: "unit x"
  then show "x ** y = x ** z" by simp
qed

lemma unit_inv_inv [simp]:
  "unit x ==> inv (inv x) = x"
proof -
  assume x: "unit x"
  then have "inv x ** inv (inv x) = inv x ** x"
    by (simp add: unit_l_inv unit_r_inv)
  with x show ?thesis by simp
qed

lemma inv_inj_on_unit:
  "inj_on inv {x. unit x}"
proof (rule inj_onI, simp)
  fix x y
  assume G: "unit x"  "unit y" and eq: "inv x = inv y"
  then have "inv (inv x) = inv (inv y)" by simp
  with G show "x = y" by simp
qed

lemma unit_inv_comm:
  assumes inv: "x ** y = one"
    and G: "unit x"  "unit y"
  shows "y ** x = one"
proof -
  from G have "x ** y ** x = x ** one" by (auto simp add: inv)
  with G show ?thesis by (simp del: r_one add: assoc)
qed

end

locale Dgrp = Dmonoid +
  assumes unit [intro, simp]: "Dmonoid.unit (op **) one x"

begin

lemma l_inv_ex [simp]:
  "\<exists>y. y ** x = one"
  using unit_l_inv_ex by simp

lemma r_inv_ex [simp]:
  "\<exists>y. x ** y = one"
  using unit_r_inv_ex by simp

lemma l_inv [simp]:
  "inv x ** x = one"
  using unit_l_inv by simp

lemma l_cancel [simp]:
  "(x ** y = x ** z) = (y = z)"
  using unit_l_inv by simp

lemma r_inv [simp]:
  "x ** inv x = one"
proof -
  have "inv x ** (x ** inv x) = inv x ** one"
    by (simp add: assoc [symmetric] l_inv)
  then show ?thesis by (simp del: r_one)
qed

lemma r_cancel [simp]:
  "(y ** x = z ** x) = (y = z)"
proof
  assume eq: "y ** x = z ** x"
  then have "y ** (x ** inv x) = z ** (x ** inv x)"
    by (simp add: assoc [symmetric] del: r_inv)
  then show "y = z" by simp
qed simp

lemma inv_one [simp]:
  "inv one = one"
proof -
  have "inv one = one ** (inv one)" by (simp del: r_inv)
  moreover have "... = one" by simp
  finally show ?thesis .
qed

lemma inv_inv [simp]:
  "inv (inv x) = x"
  using unit_inv_inv by simp

lemma inv_inj:
  "inj_on inv UNIV"
  using inv_inj_on_unit by simp

lemma inv_mult_group:
  "inv (x ** y) = inv y ** inv x"
proof -
  have "inv (x ** y) ** (x ** y) = (inv y ** inv x) ** (x ** y)"
    by (simp add: assoc l_inv) (simp add: assoc [symmetric])
  then show ?thesis by (simp del: l_inv)
qed

lemma inv_comm:
  "x ** y = one ==> y ** x = one"
  by (rule unit_inv_comm) auto

lemma inv_equality:
     "y ** x = one ==> inv x = y"
  apply (simp add: inv_def)
  apply (rule the_equality)
   apply (simp add: inv_comm [of y x])
  apply (rule r_cancel [THEN iffD1], auto)
  done

end

locale Dhom = prod: Dgrp prod one + sum: Dgrp sum zero
    for prod (infixl "**" 65) and one and sum (infixl "+++" 60) and zero +
  fixes hom
  assumes hom_mult [simp]: "hom (x ** y) = hom x +++ hom y"

begin

lemma hom_one [simp]:
  "hom one = zero"
proof -
  have "hom one +++ zero = hom one +++ hom one"
    by (simp add: hom_mult [symmetric] del: hom_mult)
  then show ?thesis by (simp del: r_one)
qed

end

subsubsection {* Interpretation of Functions *}

interpretation Dfun: Dmonoid "op o" "id :: 'a => 'a"
  where "Dmonoid.unit (op o) id f = bij (f::'a => 'a)"
(*    and "Dmonoid.inv (op o) id" = "inv :: ('a => 'a) => ('a => 'a)" *)
proof -
  show "Dmonoid op o (id :: 'a => 'a)" proof qed (simp_all add: o_assoc)
  note Dmonoid = this
(*
  from this interpret Dmonoid "op o" "id :: 'a => 'a" .
*)
  show "Dmonoid.unit (op o) (id :: 'a => 'a) f = bij f"
    apply (unfold Dmonoid.unit_def [OF Dmonoid])
    apply rule apply clarify
  proof -
    fix f g
    assume id1: "f o g = id" and id2: "g o f = id"
    show "bij f"
    proof (rule bijI)
      show "inj f"
      proof (rule inj_onI)
        fix x y
        assume "f x = f y"
        then have "(g o f) x = (g o f) y" by simp
        with id2 show "x = y" by simp
      qed
    next
      show "surj f"
      proof (rule surjI)
        fix x
        from id1 have "(f o g) x = x" by simp
        then show "f (g x) = x" by simp
      qed
    qed
  next
    fix f
    assume bij: "bij f"
    then
    have inv: "f o Hilbert_Choice.inv f = id & Hilbert_Choice.inv f o f = id"
      by (simp add: bij_def surj_iff inj_iff)
    show "EX g. f o g = id & g o f = id" by rule (rule inv)
  qed
qed

thm Dmonoid.unit_def Dfun.unit_def

thm Dmonoid.inv_inj_on_unit Dfun.inv_inj_on_unit

lemma unit_id:
  "(f :: unit => unit) = id"
  by rule simp

interpretation Dfun: Dgrp "op o" "id :: unit => unit"
  where "Dmonoid.inv (op o) id f = inv (f :: unit => unit)"
proof -
  have "Dmonoid op o (id :: 'a => 'a)" ..
  note Dmonoid = this

  show "Dgrp (op o) (id :: unit => unit)"
apply unfold_locales
apply (unfold Dmonoid.unit_def [OF Dmonoid])
apply (insert unit_id)
apply simp
done
  show "Dmonoid.inv (op o) id f = inv (f :: unit => unit)"
apply (unfold Dmonoid.inv_def [OF Dmonoid])
apply (insert unit_id)
apply simp
apply (rule the_equality)
apply rule
apply rule
apply simp
done
qed

thm Dfun.unit_l_inv Dfun.l_inv

thm Dfun.inv_equality
thm Dfun.inv_equality

end


chapter {* Maximals elements over a set. *}

text {* Maximal elements over a set of elements whose position in a linear order is given by
an auxiliary function. *}

theory MaxByKey
imports Main
begin

context begin

definition max_by_key :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b::linorder) \<Rightarrow> 'a set" where
  -- {* @{term max_by_key} is executable *}
  "max_by_key S f \<equiv> {x \<in> S . f x = Max (f ` S)}"

lemma max_by_key:
  assumes "finite S"
  shows "max_by_key S f = {x \<in> S . \<forall> y \<in> S  . f y \<le> f x}"
  apply (auto simp add:max_by_key_def)
   apply (metis Max.coboundedI assms finite_imageI rev_image_eqI)
  by (metis (mono_tags, hide_lams) Max_eqI assms finite_imageI image_iff)

lemma max_by_key_ordered:
  fixes S::"'a set" and f::"'a \<Rightarrow> 'b::linorder"
  assumes "\<And> x y . \<lbrakk>x \<in> S; y \<in> S; x \<noteq> y\<rbrakk> \<Longrightarrow> f x \<noteq> f y" and "finite S" and "S \<noteq> {}"
  obtains z where "max_by_key S f = {z}"
proof -
  have "Max (f ` S) \<in> f ` S"
    by (metis Max_in assms(2,3) finite_imageI image_is_empty)
  with this obtain z where "f z = Max (f ` S)" and "z \<in> S"
    by (metis imageE)
  have "{x \<in> S . f x = Max (f ` S)} = {z}"
  proof
    show "{z} \<subseteq> {x \<in> S. f x = Max (f ` S)}" using \<open>f z = Max (f ` S)\<close> \<open>z \<in> S\<close> by auto
  next
    show "{x \<in> S. f x = Max (f ` S)} \<subseteq> {z}"
      by (metis (mono_tags, lifting) \<open>f z = Max (f ` S)\<close> \<open>z \<in> S\<close> assms(1) mem_Collect_eq singleton_iff subsetI)
  qed
  thus ?thesis using that by (simp add:max_by_key_def)
qed

lemma max_by_key_ne:
  assumes "S \<noteq> {}" and "finite S"
  shows "max_by_key S f \<noteq> {}" using assms
by (simp add:max_by_key_def) (metis (mono_tags, hide_lams) Max_in finite_imageI image_iff image_is_empty)

export_code max_by_key in SML
value "max_by_key {(1::nat,1),(0,3)} fst"

private
lemma max_by_key_in_and_ge:
  fixes S::"'b set" and x::'b
  assumes "finite S" and "x \<in> S" and "m \<in> max_by_key S f"
  shows "f x \<le> f m" and  "m \<in> S"
   apply (metis (no_types, lifting) assms(1) assms(2) assms(3) max_by_key mem_Collect_eq)
  by (metis (no_types, lifting) CollectD assms(3) max_by_key_def)

private
lemma in_and_ge_is_max_by_key: fixes S :: "'a set" and f :: "'a \<Rightarrow> ('b::linorder)"
assumes "\<And> x . x \<in> S \<Longrightarrow> f x \<le> f m" and "m \<in> S" and "finite S"
shows "m \<in> max_by_key S f" by (smt assms max_by_key mem_Collect_eq)

lemma max_by_key_finite:
  assumes "finite S"
  shows "finite (max_by_key S f)" using assms
  by (simp add:max_by_key[OF assms])

private
lemma max_by_key_lemma:
  assumes "finite S1" and "finite S2"
  shows "max_by_key (max_by_key S1 f \<union> max_by_key S2 f) f = max_by_key (S1 \<union> S2) f"
    (is "?m (?m S1 \<union> ?m S2) = ?m (S1 \<union> S2)")
proof
  have "finite (S1 \<union> S2)" and "finite (max_by_key S1 f \<union> max_by_key S2 f)"
     by (simp add: assms, simp add: assms max_by_key_finite)
  show "?m (?m S1 \<union> ?m S2) \<subseteq> ?m (S1 \<union> S2)"
  proof -
    define lhs where "lhs \<equiv> ?m (?m S1 \<union> ?m S2)"
    have "lhs \<subseteq> (S1 \<union> S2)" by (auto simp add:max_by_key_def lhs_def)
    moreover
    have "f y \<le> f x" if 1:"x \<in> lhs" and "y \<in> S1 \<union> S2" for x y
    proof -
      have 1:"f z \<le> f x" if "z \<in> ?m S1 \<union> ?m S2" for z
        by (metis (no_types, lifting) CollectD 1 assms(1) assms(2) finite_UnI max_by_key max_by_key_finite that lhs_def)
      have 2:"f z \<le> f a" if "z \<in> S1" and "a \<in> ?m S1" for z a
        using assms(1) max_by_key that(1) that(2) by auto
      have 3:"f z \<le> f a" if "z \<in> S2" and "a \<in> ?m S2" for z a
        using assms(2) max_by_key that(1) that(2) by auto
      show ?thesis using that 1 2 3
        by (metis Un_iff all_not_in_conv assms(1) assms(2) max_by_key_ne order_trans)
    qed
    ultimately
    have "lhs \<subseteq> ?m (S1 \<union> S2)" by (auto simp add: max_by_key[OF \<open>finite (S1 \<union> S2)\<close>])
    thus ?thesis by (simp add:lhs_def)
  qed
  show "?m (S1 \<union> S2) \<subseteq> ?m (?m S1 \<union> ?m S2)"
    by (smt Un_iff assms(1) assms(2) finite_UnI max_by_key max_by_key_finite mem_Collect_eq subsetI)
qed

private
lemma f_Union_f_is_f_Union:
  assumes "\<And> S1 S2 . \<lbrakk>finite S1; finite S2\<rbrakk> \<Longrightarrow> f (f S1 \<union> f S2) = f (S1 \<union> S2)"
  and "\<And> S . S \<in> Ss \<Longrightarrow> finite S" and "finite Ss"
  and "\<And> S . finite S \<Longrightarrow> finite (f S)"
shows "f (Union (f ` Ss)) = f (Union Ss)"
proof (cases "Ss = {}")
  case False
  show ?thesis using \<open>finite Ss\<close> and False assms(2-4)
  proof (induct "Ss" rule:finite_ne_induct)
    case (singleton x)
    have "finite x"
      by (metis singleton.prems(1) singletonI)
    show ?case using \<open>finite x\<close> assms(1) by fastforce
  next
    case (insert x F)
    have 1:"f (\<Union>a\<in>F. f a) = f (\<Union>F)"
      by (simp add: insert.hyps(1) insert.hyps(4) insert.prems(1) insert.prems(3))
    have 4:"f (f x \<union> f (\<Union>F)) = f (x \<union> \<Union>F)"
      using assms(1) insert.prems(1) insert.prems(2) by auto
    have "f (\<Union>a\<in>insert x F. f a) = f (f x \<union> (\<Union>a\<in>F . f a))"
      by (metis Union_image_insert)
    also have "... = f (f x \<union> f (\<Union> F))"
      by (metis (no_types, lifting) "1" Un_absorb assms(1) finite_UN_I insert.hyps(1) insert.prems(1) insert.prems(3) insert_iff)
    also have "... = f (\<Union> (insert x F))"
      by (metis "4" Union_insert)
    finally show ?case by assumption
  qed
next
  case True thus ?thesis by simp
qed

lemma max_by_key_subsets:
  assumes "\<And> S . S \<in> Ss \<Longrightarrow> finite S" and "finite Ss"
  shows "max_by_key (\<Union>S\<in>Ss. max_by_key S f) f = max_by_key (Union Ss) f"
  by (metis (no_types, lifting) assms f_Union_f_is_f_Union max_by_key_finite max_by_key_lemma)

end

subsection {* Other properties *}

experiment begin

text {* Used anywhere? *}

lemma Max_Max:
  assumes "finite Xs" and "Union Xs \<noteq> {}" and "\<And> X . X \<in> Xs \<Longrightarrow> X \<noteq> {} \<and> finite X"
  shows "Max (Max ` Xs) = Max (Union Xs)" (is "?A = ?B")
  -- {* Is this of any use? Note that all subsets are required to be non-empty. *}
nitpick[verbose, card 'a = 2, card "'a option" = 3, expect=none]
proof -
  have 0:"finite (Union Xs)" using assms(1,3) by auto
  hence 1:"?B \<in> Union Xs"
    by (metis Max_in assms(2))
  have "finite (Max ` Xs)" by (metis assms(1) finite_imageI)
  moreover have "Max ` Xs \<noteq> {}" using assms(2) by (metis Sup_empty image_is_empty)
  ultimately have 3:"?A \<in> (Max ` Xs)" and "\<And> x . x \<in> Max ` Xs \<Longrightarrow> x \<le> ?A"
    by (metis Max_in, metis Max_ge \<open>finite (Max ` Xs)\<close>)
  show ?thesis by (smt 1 3 Max_ge Max_mono Sup_upper UnionE 0 antisym assms(1,3) finite_imageI image_iff)
qed

lemma Max_bot:"\<lbrakk>finite (S::'b::{linorder,order_bot} set); S \<noteq> {}; s \<in> S; Max S = bot\<rbrakk> \<Longrightarrow> s = bot"
by (metis Max.coboundedI bot.extremum_uniqueI)

end

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

chapter "Distinct Proposition"

theory Distinct_Prop  (* part of non-AFP Word_Lib *)
imports
  "Word_Lib/HOL_Lemmas"
  "HOL-Library.Prefix_Order"
begin

primrec
  distinct_prop :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a list \<Rightarrow> bool)"
where
  "distinct_prop P [] = True"
| "distinct_prop P (x # xs) = ((\<forall>y\<in>set xs. P x y) \<and> distinct_prop P xs)"

primrec
  distinct_sets :: "'a set list \<Rightarrow> bool"
where
  "distinct_sets [] = True"
| "distinct_sets (x#xs) = (x \<inter> \<Union> (set xs) = {} \<and> distinct_sets xs)"

lemma distinct_prop_map:
  "distinct_prop P (map f xs) = distinct_prop (\<lambda>x y. P (f x) (f y)) xs"
  by (induct xs) auto

lemma distinct_prop_append:
  "distinct_prop P (xs @ ys) =
    (distinct_prop P xs \<and> distinct_prop P ys \<and> (\<forall>x \<in> set xs. \<forall>y \<in> set ys. P x y))"
  by (induct xs arbitrary: ys) (auto simp: conj_comms ball_Un)

lemma distinct_prop_distinct:
  "\<lbrakk> distinct xs; \<And>x y. \<lbrakk> x \<in> set xs; y \<in> set xs; x \<noteq> y \<rbrakk> \<Longrightarrow> P x y \<rbrakk> \<Longrightarrow> distinct_prop P xs"
  by (induct xs) auto

lemma distinct_prop_True [simp]:
  "distinct_prop (\<lambda>x y. True) xs"
  by (induct xs, auto)

lemma distinct_prefix:
  "\<lbrakk> distinct xs; ys \<le> xs \<rbrakk> \<Longrightarrow> distinct ys"
  apply (induct xs arbitrary: ys; clarsimp)
  apply (case_tac ys; clarsimp)
  by (fastforce simp: less_eq_list_def dest: set_mono_prefix)

lemma distinct_sets_prop:
  "distinct_sets xs = distinct_prop (\<lambda>x y. x \<inter> y = {}) xs"
  by (induct xs) auto

lemma distinct_take_strg:
  "distinct xs \<longrightarrow> distinct (take n xs)"
  by simp

lemma distinct_prop_prefixE:
  "\<lbrakk> distinct_prop P ys; prefix xs ys \<rbrakk> \<Longrightarrow> distinct_prop P xs"
  apply (induct xs arbitrary: ys; clarsimp)
  apply (case_tac ys; clarsimp)
  by (fastforce dest: set_mono_prefix)

lemma distinct_sets_union_sub:
  "\<lbrakk>x \<in> A; distinct_sets [A,B]\<rbrakk> \<Longrightarrow> A \<union> B - {x} = A - {x} \<union> B"
  by (auto simp: distinct_sets_def)

lemma distinct_sets_append:
  "distinct_sets (xs @ ys) \<Longrightarrow> distinct_sets xs \<and> distinct_sets ys"
  apply (subst distinct_sets_prop)+
  apply (subst (asm) distinct_sets_prop)
  apply (subst (asm) distinct_prop_append)
  apply clarsimp
  done

lemma distinct_sets_append1:
  "distinct_sets (xs @ ys) \<Longrightarrow> distinct_sets xs"
  by (drule distinct_sets_append, simp)

lemma distinct_sets_append2:
  "distinct_sets (xs @ ys) \<Longrightarrow> distinct_sets ys"
  by (drule distinct_sets_append, simp)

lemma distinct_sets_append_Cons:
  "distinct_sets (xs @ a # ys) \<Longrightarrow> distinct_sets (xs @ ys)"
  apply (subst distinct_sets_prop)+
  apply (subst (asm) distinct_sets_prop)
  apply (subst distinct_prop_append)
  apply (subst (asm) distinct_prop_append)
  apply clarsimp
  done

lemma distinct_sets_append_Cons_disjoint:
  "distinct_sets (xs @ a # ys) \<Longrightarrow>  a \<inter> \<Union> (set xs) = {} "
  apply (subst (asm) distinct_sets_prop)
  apply (subst (asm) distinct_prop_append)
  apply (subst Int_commute)
  apply (subst Union_disjoint)
  apply clarsimp
  done

lemma distinct_prop_take:
  "\<lbrakk>distinct_prop P xs; i < length xs\<rbrakk> \<Longrightarrow> distinct_prop P (take i xs)"
  by (metis take_is_prefix distinct_prop_prefixE)

lemma distinct_sets_take:
  "\<lbrakk>distinct_sets xs; i < length xs\<rbrakk> \<Longrightarrow> distinct_sets (take i xs)"
  by (simp add: distinct_sets_prop distinct_prop_take)

lemma distinct_prop_take_Suc:
  "\<lbrakk>distinct_prop P xs; i < length xs\<rbrakk> \<Longrightarrow> distinct_prop P (take (Suc i) xs)"
  by (metis distinct_prop_take not_less take_all)

lemma distinct_sets_take_Suc:
  "\<lbrakk>distinct_sets xs; i < length xs\<rbrakk> \<Longrightarrow> distinct_sets (take (Suc i) xs)"
  by (simp add: distinct_sets_prop distinct_prop_take_Suc)

lemma distinct_prop_rev:
  "distinct_prop P (rev xs) = distinct_prop (\<lambda>y x. P x y) xs"
  by (induct xs) (auto simp: distinct_prop_append)

lemma distinct_sets_rev [simp]:
  "distinct_sets (rev xs) = distinct_sets xs"
  apply (unfold distinct_sets_prop)
  apply (subst distinct_prop_rev)
  apply (subst Int_commute)
  apply clarsimp
  done

lemma distinct_sets_drop:
  "\<lbrakk>distinct_sets xs; i < length xs\<rbrakk> \<Longrightarrow> distinct_sets (drop i xs)"
  apply (cases "i=0", simp)
  apply (subst distinct_sets_rev [symmetric])
  apply (subst rev_drop)
  apply (subst distinct_sets_take, simp_all)
  done

lemma distinct_sets_drop_Suc:
  "\<lbrakk>distinct_sets xs; i < length xs\<rbrakk> \<Longrightarrow> distinct_sets (drop (Suc i) xs)"
  apply (subst distinct_sets_rev [symmetric])
  apply (subst rev_drop)
  apply (subst distinct_sets_take, simp_all)
  done

lemma distinct_sets_take_nth:
  "\<lbrakk>distinct_sets xs; i < length xs; x \<in> set (take i xs)\<rbrakk> \<Longrightarrow> x \<inter> xs ! i = {}"
  apply (drule (1) distinct_sets_take_Suc)
  apply (subst (asm) take_Suc_conv_app_nth, assumption)
  apply (unfold distinct_sets_prop)
  apply (subst (asm) distinct_prop_append)
  apply clarsimp
  done

lemma distinct_sets_drop_nth:
  "\<lbrakk>distinct_sets xs; i < length xs; x \<in> set (drop (Suc i) xs)\<rbrakk> \<Longrightarrow> x \<inter> xs ! i = {}"
  apply (drule (1) distinct_sets_drop)
  apply (subst (asm) drop_Suc_nth, assumption)
  apply fastforce
  done

lemma distinct_sets_append_distinct:
  "\<lbrakk>x \<in> set xs; y \<in> set ys; distinct_sets (xs @ ys)\<rbrakk> \<Longrightarrow> x \<inter> y = {}"
  unfolding distinct_sets_prop by (clarsimp simp: distinct_prop_append)

lemma distinct_sets_update:
 "\<lbrakk>a \<subseteq> xs ! i; distinct_sets xs; i < length xs\<rbrakk> \<Longrightarrow> distinct_sets (xs[i := a])"
  apply (subst distinct_sets_prop)
  apply (subst (asm) distinct_sets_prop)
  apply (subst upd_conv_take_nth_drop, simp)
  apply (subst distinct_prop_append)
  apply (intro conjI)
    apply (erule (1) distinct_prop_take)
   apply (rule conjI|clarsimp)+
    apply (fold distinct_sets_prop)
    apply (drule (1) distinct_sets_drop)
    apply (subst (asm) drop_Suc_nth, assumption)
    apply fastforce
   apply (drule (1) distinct_sets_drop)
   apply (subst (asm) drop_Suc_nth, assumption)
   apply clarsimp
  apply clarsimp
  apply (rule conjI)
   apply (drule (2) distinct_sets_take_nth)
   apply blast
  apply clarsimp
  apply (thin_tac "P \<subseteq> Q" for P Q)
  apply (subst (asm) id_take_nth_drop, assumption)
  apply (drule distinct_sets_append_Cons)
  apply (erule (2) distinct_sets_append_distinct)
  done

lemma distinct_sets_map_update:
  "\<lbrakk>distinct_sets (map f xs); i < length xs; f a \<subseteq> f(xs ! i)\<rbrakk>
  \<Longrightarrow> distinct_sets (map f (xs[i := a]))"
  by (metis distinct_sets_update length_map map_update nth_map)

lemma Union_list_update:
  "\<lbrakk>i < length xs; distinct_sets (map f xs)\<rbrakk>
  \<Longrightarrow> (\<Union>x\<in>set (xs [i := a]). f x) = (\<Union>x\<in>set xs. f x) - f (xs ! i) \<union> f a"
  apply (induct xs arbitrary: i; clarsimp)
  apply (case_tac i; (clarsimp, fastforce))
  done

lemma fst_enumerate:
  "i < length xs \<Longrightarrow> fst (enumerate n xs ! i) = i + n"
  by (metis add.commute fst_conv nth_enumerate_eq)

lemma snd_enumerate:
  "i < length xs \<Longrightarrow> snd (enumerate n xs ! i) = xs ! i"
  by (metis nth_enumerate_eq snd_conv)

lemma enumerate_member:
  assumes "i < length xs"
  shows "(n + i, xs ! i) \<in> set (enumerate n xs)"
proof -
  have pair_unpack: "\<And>a b x. ((a, b) = x) = (a = fst x \<and> b = snd x)" by fastforce
  from assms have "(n + i, xs ! i) = enumerate n xs ! i"
    by (auto simp: fst_enumerate snd_enumerate pair_unpack)
  with assms show ?thesis by simp
qed

lemma distinct_prop_nth:
  "\<lbrakk> distinct_prop P ls; n < n'; n' < length ls \<rbrakk> \<Longrightarrow> P (ls ! n) (ls ! n')"
  apply (induct ls arbitrary: n n'; simp)
  apply (case_tac n'; simp)
  apply (case_tac n; simp)
  done

end


(*
  File: Interval.thy
  Author: Bohua Zhan

  Intervals.
*)

theory Interval
  imports OrderRel
begin

section \<open>Intervals\<close>  (* Bourbaki III.1.13 *)

definition closed_interval :: "[i, i, i] \<Rightarrow> i" where [rewrite]:
  "closed_interval(R,a,b) = {x \<in>. R. a \<le>\<^sub>R x \<and> x \<le>\<^sub>R b}"
setup {* register_wellform_data ("closed_interval(R,a,b)", ["a \<in>. R", "b \<in>. R"]) *}

lemma closed_interval_subset [resolve]: "closed_interval(R,a,b) \<subseteq> carrier(R)" by auto2
lemma closed_interval_iff [rewrite]: "raworder(R) \<Longrightarrow> x \<in> closed_interval(R,a,b) \<longleftrightarrow> (a \<le>\<^sub>R x \<and> x \<le>\<^sub>R b)" by auto2
lemma closed_interval_I1 [typing2]: "preorder(R) \<Longrightarrow> a \<le>\<^sub>R b \<Longrightarrow> a \<in> closed_interval(R,a,b)" by auto2
lemma closed_interval_I2 [typing2]: "preorder(R) \<Longrightarrow> a \<le>\<^sub>R b \<Longrightarrow> b \<in> closed_interval(R,a,b)" by auto2
setup {* del_prfstep_thm @{thm closed_interval_def} *}

definition open_interval :: "[i, i, i] \<Rightarrow> i" where [rewrite]:
  "open_interval(R,a,b) = {x \<in>. R. a <\<^sub>R x \<and> x <\<^sub>R b}"
setup {* register_wellform_data ("open_interval(R,a,b)", ["a \<in>. R", "b \<in>. R"]) *}

lemma open_interval_subset [resolve]: "open_interval(R,a,b) \<subseteq> carrier(R)" by auto2
lemma open_interval_iff [rewrite]: "raworder(R) \<Longrightarrow> x \<in> open_interval(R,a,b) \<longleftrightarrow> (a <\<^sub>R x \<and> x <\<^sub>R b)" by auto2
lemma open_interval_eq_str [rewrite]:
  "eq_str_order(X,Y) \<Longrightarrow> a \<in>. X \<Longrightarrow> b \<in>. X \<Longrightarrow> open_interval(X,a,b) = open_interval(Y,a,b)" by auto2
setup {* del_prfstep_thm @{thm open_interval_def} *}

definition closed_open_interval :: "[i, i, i] \<Rightarrow> i" where [rewrite]:
  "closed_open_interval(R,a,b) = {x \<in>. R. a \<le>\<^sub>R x \<and> x <\<^sub>R b}"
setup {* register_wellform_data ("closed_open_interval(R,a,b)", ["a \<in>. R", "b \<in>. R"]) *}

lemma closed_open_interval_subset [resolve]: "closed_open_interval(R,a,b) \<subseteq> carrier(R)" by auto2
lemma closed_open_interval_iff [rewrite]: "raworder(R) \<Longrightarrow> x \<in> closed_open_interval(R,a,b) \<longleftrightarrow> (a \<le>\<^sub>R x \<and> x <\<^sub>R b)" by auto2
setup {* del_prfstep_thm @{thm closed_open_interval_def} *}

definition open_closed_interval :: "[i, i, i] \<Rightarrow> i" where [rewrite]:
  "open_closed_interval(R,a,b) = {x \<in>. R. a <\<^sub>R x \<and> x \<le>\<^sub>R b}"
setup {* register_wellform_data ("open_closed_interval(R,a,b)", ["a \<in>. R", "b \<in>. R"]) *}

lemma open_closed_interval_subset [resolve]: "open_closed_interval(R,a,b) \<subseteq> carrier(R)" by auto2
lemma open_closed_interval_iff [rewrite]: "raworder(R) \<Longrightarrow> x \<in> open_closed_interval(R,a,b) \<longleftrightarrow> (a <\<^sub>R x \<and> x \<le>\<^sub>R b)" by auto2
setup {* del_prfstep_thm @{thm open_closed_interval_def} *}

definition le_interval :: "[i, i] \<Rightarrow> i" where [rewrite]:
  "le_interval(R,a) = {x \<in>. R. x \<le>\<^sub>R a}"
setup {* register_wellform_data ("le_interval(R,a)", ["a \<in>. R"]) *}

lemma le_interval_subset [resolve]: "le_interval(R,a) \<subseteq> carrier(R)" by auto2
lemma le_intervalI [typing2]: "raworder(R) \<Longrightarrow> x \<le>\<^sub>R a \<Longrightarrow> x \<in> le_interval(R,a)" by auto2
lemma le_interval_iff [rewrite]: "raworder(R) \<Longrightarrow> x \<in> le_interval(R,a) \<longleftrightarrow> x \<le>\<^sub>R a" by auto2
setup {* del_prfstep_thm @{thm le_interval_iff} *}

definition less_interval :: "[i, i] \<Rightarrow> i" where [rewrite]:
  "less_interval(R,a) = {x \<in>. R. x <\<^sub>R a}"
setup {* register_wellform_data ("less_interval(R,a)", ["a \<in>. R"]) *}

lemma less_interval_subset [resolve]: "less_interval(R,a) \<subseteq> carrier(R)" by auto2
lemma less_intervalI [typing2]: "raworder(R) \<Longrightarrow> x <\<^sub>R a \<Longrightarrow> x \<in> less_interval(R,a)" by auto2
lemma less_interval_iff [rewrite]: "raworder(R) \<Longrightarrow> x \<in> less_interval(R,a) \<longleftrightarrow> x <\<^sub>R a" by auto2
lemma less_interval_eq_str [rewrite]:
  "eq_str_order(X,Y) \<Longrightarrow> a \<in>. X \<Longrightarrow> less_interval(X,a) = less_interval(Y,a)" by auto2
setup {* del_prfstep_thm @{thm less_interval_def} *}

definition ge_interval :: "[i, i] \<Rightarrow> i" where [rewrite]:
  "ge_interval(R,a) = {x \<in>. R. x \<ge>\<^sub>R a}"
setup {* register_wellform_data ("ge_interval(R,a)", ["a \<in>. R"]) *}

lemma ge_interval_subset [resolve]: "ge_interval(R,a) \<subseteq> carrier(R)" by auto2
lemma ge_intervalI [typing2]: "raworder(R) \<Longrightarrow> x \<ge>\<^sub>R a \<Longrightarrow> x \<in> ge_interval(R,a)" by auto2
lemma ge_interval_iff [rewrite]: "raworder(R) \<Longrightarrow> x \<in> ge_interval(R,a) \<longleftrightarrow> x \<ge>\<^sub>R a" by auto2
setup {* del_prfstep_thm @{thm ge_interval_def} *}

definition greater_interval :: "[i, i] \<Rightarrow> i" where [rewrite]:
  "greater_interval(R,a) = {x \<in>. R. x >\<^sub>R a}"
setup {* register_wellform_data ("greater_interval(R,a)", ["a \<in>. R"]) *}

lemma greater_interval_subset [resolve]: "greater_interval(R,a) \<subseteq> carrier(R)" by auto2
lemma greater_intervalI [typing2]: "raworder(R) \<Longrightarrow> x >\<^sub>R a \<Longrightarrow> x \<in> greater_interval(R,a)" by auto2
lemma greater_interval_iff [rewrite]: "raworder(R) \<Longrightarrow> x \<in> greater_interval(R,a) \<longleftrightarrow> x >\<^sub>R a" by auto2
lemma greater_interval_eq_str [rewrite]:
  "eq_str_order(X,Y) \<Longrightarrow> a \<in>. X \<Longrightarrow> greater_interval(X,a) = greater_interval(Y,a)" by auto2
setup {* del_prfstep_thm @{thm greater_interval_def} *}

section \<open>Intersection of intervals\<close>

lemma open_interval_inter [rewrite]:
  "linorder(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> b \<in>. R \<Longrightarrow> c \<in>. R \<Longrightarrow> d \<in>. R \<Longrightarrow>
   open_interval(R,a,b) \<inter> open_interval(R,c,d) = open_interval(R,max(R,a,c),min(R,b,d))" by auto2

lemma open_less_interval_inter [rewrite]:
  "linorder(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> b \<in>. R \<Longrightarrow> c \<in>. R \<Longrightarrow>
   open_interval(R,a,b) \<inter> less_interval(R,c) = open_interval(R,a,min(R,b,c))" by auto2

lemma open_greater_interval_inter [rewrite]:
  "linorder(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> b \<in>. R \<Longrightarrow> c \<in>. R \<Longrightarrow>
   open_interval(R,a,b) \<inter> greater_interval(R,c) = open_interval(R,max(R,a,c),b)" by auto2

lemma less_open_interval_inter [rewrite]:
  "linorder(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> b \<in>. R \<Longrightarrow> c \<in>. R \<Longrightarrow>
   less_interval(R,c) \<inter> open_interval(R,a,b) = open_interval(R,a,min(R,b,c))" by auto2

lemma less_less_interval_inter [rewrite]:
  "linorder(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> b \<in>. R \<Longrightarrow>
   less_interval(R,a) \<inter> less_interval(R,b) = less_interval(R,min(R,a,b))" by auto2

lemma lesss_greater_interval_inter [rewrite]:
  "linorder(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> b \<in>. R \<Longrightarrow>
   less_interval(R,a) \<inter> greater_interval(R,b) = open_interval(R,b,a)" by auto2

lemma greater_open_interval_inter [rewrite]:
  "linorder(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> b \<in>. R \<Longrightarrow> c \<in>. R \<Longrightarrow>
   greater_interval(R,c) \<inter> open_interval(R,a,b) = open_interval(R,max(R,a,c),b)" by auto2

lemma greater_less_interval_inter [rewrite]:
  "linorder(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> b \<in>. R \<Longrightarrow>
   greater_interval(R,b) \<inter> less_interval(R,a) = open_interval(R,b,a)" by auto2

lemma greater_greater_interval_inter [rewrite]:
  "linorder(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> b \<in>. R \<Longrightarrow>
   greater_interval(R,a) \<inter> greater_interval(R,b) = greater_interval(R,max(R,a,b))" by auto2

section \<open>Union of intervals\<close>

lemma open_closed_open_union [rewrite]:
  "linorder(X) \<Longrightarrow> a <\<^sub>X b \<Longrightarrow> b <\<^sub>X c \<Longrightarrow>
   open_closed_interval(X,a,b) \<union> closed_open_interval(X,b,c) = open_interval(X,a,c)" by auto2

section \<open>Complement of intervals\<close>

lemma order_ge_compl [rewrite]:
  "linorder(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> carrier(R) \<midarrow> ge_interval(R,a) = less_interval(R,a)" by auto2

lemma order_greater_compl [rewrite]:
  "linorder(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> carrier(R) \<midarrow> greater_interval(R,a) = le_interval(R,a)" by auto2

lemma order_less_compl [rewrite]:
  "linorder(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> carrier(R) \<midarrow> less_interval(R,a) = ge_interval(R,a)" by auto2

lemma order_le_compl [rewrite]:
  "linorder(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> carrier(R) \<midarrow> le_interval(R,a) = greater_interval(R,a)" by auto2

lemma ge_compl_is_less' [forward]:
  "linorder(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> S \<subseteq> carrier(R) \<Longrightarrow> carrier(R) \<midarrow> S = ge_interval(R,a) \<Longrightarrow>
   S = less_interval(R,a)"
@proof @have "S = carrier(R) \<midarrow> (carrier(R) \<midarrow> S)" @qed

section \<open>Inclusion results on intervals\<close>

lemma open_interval_contain [backward]:
  "order(R) \<Longrightarrow> a \<ge>\<^sub>R c \<Longrightarrow> b \<le>\<^sub>R d \<Longrightarrow> open_interval(R,a,b) \<subseteq> open_interval(R,c,d)" by auto2

lemma closed_open_sub_open [backward]:
  "linorder(X) \<Longrightarrow> p <\<^sub>X a \<Longrightarrow> closed_open_interval(X,a,q) \<subseteq> open_interval(X,p,q)" by auto2

lemma closed_open_sub_less [resolve]:
  "linorder(X) \<Longrightarrow> closed_open_interval(X,a,p) \<subseteq> less_interval(X,p)" by auto2

lemma closed_open_sub_greater [backward]:
  "linorder(X) \<Longrightarrow> q <\<^sub>X a \<Longrightarrow> closed_open_interval(X,a,p) \<subseteq> greater_interval(X,q)" by auto2

lemma open_closed_sub_open [backward]:
  "linorder(X) \<Longrightarrow> a <\<^sub>X q \<Longrightarrow> open_closed_interval(X,p,a) \<subseteq> open_interval(X,p,q)" by auto2

lemma open_closed_sub_greater [resolve]:
  "linorder(X) \<Longrightarrow> open_closed_interval(X,p,a) \<subseteq> greater_interval(X,p)" by auto2

lemma open_closed_sub_less [backward]:
  "linorder(X) \<Longrightarrow> a <\<^sub>X q \<Longrightarrow> open_closed_interval(X,p,a) \<subseteq> less_interval(X,q)" by auto2

section \<open>Intervals on suborder\<close>

lemma less_interval_suborder [rewrite]:
  "linorder(X) \<Longrightarrow> A \<subseteq> carrier(X) \<Longrightarrow> x \<in> A \<Longrightarrow>
   less_interval(suborder(X,A),x) = A \<inter> less_interval(X,x)" by auto2

lemma greater_interval_suborder [rewrite]:
  "linorder(X) \<Longrightarrow> A \<subseteq> carrier(X) \<Longrightarrow> x \<in> A \<Longrightarrow>
   greater_interval(suborder(X,A),x) = A \<inter> greater_interval(X,x)" by auto2

lemma open_interval_suborder [rewrite]:
  "linorder(X) \<Longrightarrow> A \<subseteq> carrier(X) \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow>
   open_interval(suborder(X,A),x,y) = A \<inter> open_interval(X,x,y)" by auto2

section \<open>Other results\<close>

(* Intervals with one boundary are distinct *)
lemma less_interval_neq [backward]:
  "linorder(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> b \<in>. R \<Longrightarrow> a \<noteq> b \<Longrightarrow> less_interval(R,a) \<noteq> less_interval(R,b)"
@proof @case "a <\<^sub>R b" @qed

(* Ordering on less_interval. *)
definition less_interval_rel :: "[i, i] \<Rightarrow> i" where [rewrite]:
  "less_interval_rel(R,x) = suborder(R,less_interval(R,x))"
setup {* register_wellform_data ("less_interval_rel(R,x)", ["x \<in>. R"]) *}

lemma less_interval_rel_trans [rewrite]:
  "linorder(R) \<Longrightarrow> y <\<^sub>R x \<Longrightarrow> less_interval_rel(less_interval_rel(R,x),y) = less_interval_rel(R,y)" by auto2

lemma less_interval_rel_eq_trans [forward]:
  "linorder(R) \<Longrightarrow> linorder(S) \<Longrightarrow> x \<in>. S \<Longrightarrow> y \<le>\<^sub>R x \<Longrightarrow>
   less_interval_rel(R,x) = less_interval_rel(S,x) \<Longrightarrow>
   y\<in>.S \<and> less_interval_rel(R,y) = less_interval_rel(S,y)"
@proof
  @case "y \<noteq> x" @with
    @have "less_interval_rel(less_interval_rel(R,x),y) = less_interval_rel(R,y)" @end
@qed

section \<open>Intervals inherit a number of order properties\<close>

lemma dense_order_closed_interval:
  "linorder(R) \<Longrightarrow> dense_order(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> b \<in>. R \<Longrightarrow> S = suborder(R,closed_interval(R,a,b)) \<Longrightarrow>
   dense_order(S)"
@proof
  @have "\<forall>x y. x <\<^sub>S y \<longrightarrow> (\<exists>z. x <\<^sub>S z \<and> z <\<^sub>S y)" @with
    @obtain z where "x <\<^sub>R z \<and> z <\<^sub>R y" @have "x <\<^sub>S z" @end
@qed
setup {* add_forward_prfstep_cond @{thm dense_order_closed_interval} [with_term "?S"] *}

lemma linear_continuum_closed_interval:
  "linear_continuum(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> b \<in>. R \<Longrightarrow> S = suborder(R,closed_interval(R,a,b)) \<Longrightarrow>
   linear_continuum(S)"
@proof
  @have "\<forall>T. T \<noteq> \<emptyset> \<longrightarrow> upper_bound(S,T) \<noteq> \<emptyset> \<longrightarrow> has_sup(S,T)" @with
    @have "has_sup(R,T)"
    @have "has_sup(S,T) \<and> sup(S,T) = sup(R,T)"
  @end
@qed

setup {* add_forward_prfstep_cond @{thm linear_continuum_closed_interval} [with_term "?S"] *}

end


(* A simple comment *)

theory week01A_demo imports Main
begin

text \<open>This is also a comment but it generates nice \LaTeX-text!\<close>

text \<open>
 Note that free variables (eg @{term x}),
 bound variables (eg @{term "\<lambda>n. n"}) and
 constants (eg @{term Suc}) are displayed differently.
\<close>

term "x"
term "Suc x"
term "Succ x"
term "Suc x = Succ y"
term "\<lambda>x. x"

text \<open>To display more types inside terms:\<close>
declare [[show_types]]
term "Suc x = Succ y"

text \<open>To switch off again:\<close>
declare [[show_types=false]]
term "Suc x = Succ y"

text \<open>0 and + are overloaded:\<close>

prop "n + n = 0"
prop "(n::nat) + n = 0"
prop "(n::int) + n = 0"
prop "n + n = Suc m"

text\<open>A bound variable:\<close>
term "\<lambda>x. x v"
term "\<lambda>x. Suc x < y"
prop "map (\<lambda>n. Suc n + 1) [0, 1] = [2, 3]"

text \<open>Terms must be type correct!\<close>
term "Suc n = True"

text \<open>Displaying theorems, schematic variables\<close>

thm conjI
text \<open>Schematic variables have question marks and can be instantiated:\<close>
thm conjI [where ?Q = "x"]
thm impI
thm disjE

text \<open>
  You can use \texttt{term}, \texttt{prop} and \texttt{thm} in \LaTeX
  sections, too!  The lemma conjI is: @{thm conjI}. Nicer version,
  without schematic variables: @{thm conjI [no_vars]}.
\<close>

thm conjI [no_vars]

text \<open>Finding theorems\<close>

text \<open>Searching for constants/functions:\<close>
find_theorems "map"

text \<open>A list of search criteria finds thms that match all of them:\<close>
find_theorems "map" "zip"

text \<open>To search for patterns, use underscore:\<close>
find_theorems "_ + _ = _ - _"
find_theorems "_ + _" "_ < _" "Suc"

text \<open>Searching for theorem names:\<close>
find_theorems name: "conj"

text \<open>They can all be combined, theorem names include the theory name:\<close>
find_theorems "_ \<and> _" name: "HOL." -name: "conj"

text \<open>Stating theorems and a first proof\<close>

lemma "A \<longrightarrow> A"
  \<comment> \<open>a single line comment\<close>
  \<comment> \<open>note the goals window\<close>
  apply (rule impI)
  apply assumption
  done

text \<open>
  A proof is a list of {\tt apply} statements, terminated by {\tt done}.

  {\tt apply} takes a proof method as argument (assumption, rule,
  etc.). It needs parentheses when the method consists of more than
  one word.
\<close>

text \<open>Isabelle doesn't care if you call it lemma, theorem or corollary\<close>

theorem "A \<longrightarrow> A"
  apply (rule impI)
  apply assumption
  done

corollary "A \<longrightarrow> A"
  apply (rule impI)
  apply assumption
  done

text \<open>You can give it a name, too\<close>

lemma mylemma: "A \<longrightarrow> A" by (rule impI)

text \<open>Abandoning a proof\<close>

lemma "P = NP"
  \<comment> \<open>this is too hard\<close>
  oops

text \<open>Isabelle forgets the lemma and you cannot use it later\<close>

text \<open>Faking a proof\<close>

lemma "P \<noteq> NP"
  \<comment> \<open>have an idea, will show this later\<close>
  sorry

text \<open>
  {\tt sorry} only works interactively (and in {\em quick-and-dirty-mode}),
  and Isabelle keeps track of what you have faked.
\<close>

text \<open>Proof styles\<close>

\<comment> \<open>automatic\<close>
theorem Cantor: "\<exists>S. S \<notin> range (f :: 'a \<Rightarrow> 'a set)" by best

\<comment> \<open>exploring, but unstructured\<close>
theorem Cantor': "\<exists>S. S \<notin> range (f :: 'a \<Rightarrow> 'a set)"
  apply (rule_tac x = "{x. x \<notin> f x}" in exI)
  apply (rule notI)
  apply clarsimp
  apply blast
  done

\<comment> \<open>structured, explaining\<close>
theorem Cantor'': "\<exists>S. S \<notin> range (f :: 'a \<Rightarrow> 'a set)"
proof
  let ?S = "{x. x \<notin> f x}"
  show "?S \<notin> range f"
  proof
    assume "?S \<in> range f"
    then obtain y where fy: "?S = f y" ..
    show False
    proof cases
      assume yin: "y \<in> ?S"
      hence "y \<notin> f y" by simp
      hence "y \<notin> ?S"  by(simp add:fy)
      thus False using yin by contradiction
    next
      assume yout: "y \<notin> ?S"
      hence "y \<in> f y" by simp
      hence "y \<in> ?S"  by(simp add:fy)
      thus False using yout by contradiction
    qed
  qed
qed

find_theorems "Suc (Suc _)"
find_theorems "(_ + _) + _ = _ + (_ + _)"

end


(*
Author:  Akihisa Yamada (2018-2021)
License: LGPL (see file COPYING.LESSER)
*)
section \<open> Completeness of Relations \<close>

text \<open>Here we formalize various order-theoretic completeness conditions.\<close>

theory Complete_Relations
  imports Binary_Relations
begin

subsection \<open>Completeness Conditions\<close>

text \<open>Order-theoretic completeness demands certain subsets of elements to admit suprema or infima.\<close>

definition complete ("_-complete"[999]1000) where
 "CC-complete A r \<equiv> \<forall>X \<subseteq> A. X \<in> CC \<longrightarrow> (\<exists>s. extreme_bound A r X s)"

lemmas completeI = complete_def[unfolded atomize_eq, THEN iffD2, rule_format]
lemmas completeD = complete_def[unfolded atomize_eq, THEN iffD1, rule_format]

lemma complete_cmono: "CC \<subseteq> DD \<Longrightarrow> DD-complete \<le> CC-complete"
  by (force simp: complete_def)

lemma complete_empty[simp]: "CC-complete {} r \<longleftrightarrow> {} \<notin> CC" by (auto simp: complete_def)

text \<open>
A related set $\tp{A,\SLE}$ is called \emph{topped} if there is a ``top'' element $\top \in A$,
a greatest element in $A$.
Note that there might be multiple tops if $(\SLE)$ is not antisymmetric.\<close>

definition "extremed A r \<equiv> \<exists>e. extreme A r e"

lemma extremed_imp_ex_bound: "extremed A r \<Longrightarrow> X \<subseteq> A \<Longrightarrow> \<exists>b \<in> A. bound X r b"
  by (auto simp: extremed_def)

context
  fixes less_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>" 50)
begin

text\<open>Toppedness can be also seen as a completeness condition,
since it is equivalent to saying that the universe has a supremum.\<close>

lemma extremed_iff_UNIV_complete: "extremed A (\<sqsubseteq>) \<longleftrightarrow> {A}-complete A (\<sqsubseteq>)" (is "?l \<longleftrightarrow> ?r")
proof
  assume ?l
  then obtain e where "extreme A (\<sqsubseteq>) e" by (auto simp: extremed_def)
  then have "extreme_bound A (\<sqsubseteq>) A e" by auto
  then show ?r by (auto intro!: completeI)
next
  assume ?r
  from completeD[OF this] obtain s where "extreme_bound A (\<sqsubseteq>) A s" by auto
  then have "extreme A (\<sqsubseteq>) s" by auto
  then show ?l by (auto simp: extremed_def)
qed

text \<open>The dual notion of topped is called ``pointed'', equivalently ensuring a supremum
of the empty set.\<close>

lemma pointed_iff_empty_complete: "extremed A (\<sqsubseteq>) \<longleftrightarrow> {{}}-complete A (\<sqsubseteq>)\<^sup>-"
  by (auto simp: complete_def extremed_def)

end

text \<open>One of the most well-studied notion of completeness would be the semilattice condition:
every pair of elements $x$ and $y$ has a supremum $x \sqcup y$
(not necessarily unique if the underlying relation is not antisymmetric).\<close>

definition "pair_complete \<equiv> {{x,y} |. x y :: 'a}-complete"

lemma pair_completeI:
  assumes "\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> \<exists>s. extreme_bound A r {x,y} s"
  shows "pair_complete A r"
  using assms by (auto simp: pair_complete_def complete_def)

lemma pair_completeD:
  assumes "pair_complete A r"
  shows "x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> \<exists>s. extreme_bound A r {x,y} s"
   by (intro completeD[OF assms[unfolded pair_complete_def]], auto)

context
  fixes less_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>" 50)
begin

lemma pair_complete_imp_directed:
  assumes comp: "pair_complete A (\<sqsubseteq>)" shows "directed A (\<sqsubseteq>)"
proof
  fix x y :: 'a
  assume "x \<in> A" "y \<in> A"
  with pair_completeD[OF comp this] show "\<exists>z \<in> A. x \<sqsubseteq> z \<and> y \<sqsubseteq> z" by auto
qed

end

lemma (in connex) pair_complete: "pair_complete A (\<sqsubseteq>)"
proof (safe intro!: pair_completeI)
  fix x y
  assume x: "x \<in> A" and y: "y \<in> A"
  then show "\<exists>s. extreme_bound A (\<sqsubseteq>) {x, y} s"
  proof (cases rule:comparable_cases)
    case le
    with x y show ?thesis by (auto intro!: exI[of _ y])
  next
    case ge
    with x y show ?thesis by (auto intro!: exI[of _ x])
  qed
qed

text \<open>The next one assumes that every nonempty finite set has a supremum.\<close>

abbreviation "finite_complete \<equiv> {X. finite X \<and> X \<noteq> {}}-complete"

lemma finite_complete_le_pair_complete: "finite_complete \<le> pair_complete"
  by (unfold pair_complete_def, rule complete_cmono, auto)

text \<open>The next one assumes that every nonempty bounded set has a supremum.
It is also called the Dedekind completeness.\<close>

abbreviation "conditionally_complete A r \<equiv> {X. \<exists>b \<in> A. bound X r b \<and> X \<noteq> {}}-complete A r"

lemma conditionally_complete_imp_nonempty_imp_ex_extreme_bound_iff_ex_bound:
  assumes comp: "conditionally_complete A r"
  assumes "X \<subseteq> A" and "X \<noteq> {}"
  shows "(\<exists>s. extreme_bound A r X s) \<longleftrightarrow> (\<exists>b\<in>A. bound X r b)"
  using assms by (auto 0 4 intro!:completeD[OF comp])

text \<open>The $\omega$-completeness condition demands a supremum for an $\omega$-chain,
  $a_1 \sqsubseteq a_2 \sqsubseteq \dots$.
  We model $\omega$-chain as the range of a monotone map $f : i \mapsto a_i$.\<close>

definition "omega_complete A r \<equiv> {range f | f :: nat \<Rightarrow> 'a. monotone (\<le>) r f}-complete A r"

lemma (in transitive) local_chain:
  assumes CA: "range C \<subseteq> A"
  shows "(\<forall>i::nat. C i \<sqsubseteq> C (Suc i)) \<longleftrightarrow> monotone (<) (\<sqsubseteq>) C"
proof (intro iffI allI monotoneI)
  fix i j :: nat
  assume loc: "\<forall>i. C i \<sqsubseteq> C (Suc i)" and ij: "i < j"
  have "C i \<sqsubseteq> C (i+k+1)" for k
  proof (induct k)
    case 0
    from loc show ?case by auto
  next
    case (Suc k)
    also have "C (i+k+1) \<sqsubseteq> C (i+k+Suc 1)" using loc by auto
    finally show ?case using CA by auto
  qed
  from this[of "j-i-1"] ij show "C i \<sqsubseteq> C j" by auto
next
  fix i
  assume "monotone (<) (\<sqsubseteq>) C"
  then show "C i \<sqsubseteq> C (Suc i)" by (auto dest: monotoneD)
qed

text\<open>\emph{Directed completeness} is an important notion in domain theory~\<^cite>\<open>"abramski94"\<close>,
asserting that every nonempty directed set has a supremum.
Here, a set $X$ is \emph{directed} if any pair of two elements in $X$ has a bound in $X$.\<close>

definition "directed_complete A r \<equiv> {X. directed X r \<and> X \<noteq> {}}-complete A r"

lemma monotone_directed_complete:
  assumes comp: "directed_complete A r"
  assumes fI: "f ` I \<subseteq> A" and dir: "directed I ri" and I0: "I \<noteq> {}" and mono: "monotone_on I ri r f"
  shows "\<exists>s. extreme_bound A r (f ` I) s"
  apply (rule completeD[OF comp[unfolded directed_complete_def], OF fI])
  using monotone_directed_image[OF mono dir] I0 by auto

text \<open>The next one is quite complete, only the empty set may fail to have a supremum.
The terminology follows \<^cite>\<open>"Bergman2015"\<close>,
although there it is defined more generally depending on a cardinal $\alpha$
such that a nonempty set $X$ of cardinality below $\alpha$ has a supremum.\<close>

abbreviation "semicomplete \<equiv> {X. X \<noteq> {}}-complete"

lemma semicomplete_nonempty_imp_extremed:
  "semicomplete A r \<Longrightarrow> A \<noteq> {} \<Longrightarrow> extremed A r"
  unfolding extremed_iff_UNIV_complete
  using complete_cmono[of "{A}" "{X. X \<noteq> {}}"]
  by auto

lemma connex_dual_semicomplete: "semicomplete {C. connex C r} (\<supseteq>)"
proof (intro completeI, elim CollectE)
  fix X
  assume "X \<subseteq> {C. connex C r}" and "X \<noteq> {}"
  then have "connex (\<Inter>X) r" by (auto simp: connex_def)
  then have "extreme_bound {C. connex C r} (\<supseteq>) X (\<Inter> X)" by auto
  then show "\<exists>S. extreme_bound {C. connex C r} (\<supseteq>) X S" by auto
qed

subsection \<open>Pointed Ones\<close>

text \<open>The term `pointed' refers to the dual notion of toppedness, i.e., there is a global least element.
  This serves as the supremum of the empty set.\<close>

lemma complete_union: "(CC \<union> CC')-complete A r \<longleftrightarrow> CC-complete A r \<and> CC'-complete A r"
  by (auto simp: complete_def)

lemma pointed_directed_complete:
  "{X. directed X r}-complete A r \<longleftrightarrow> directed_complete A r \<and> extremed A r\<^sup>-"
proof-
  have [simp]: "{X. directed X r \<and> X \<noteq> {} \<or> X = {}} = {X. directed X r}" by auto
  show ?thesis
    by (auto simp: directed_complete_def pointed_iff_empty_complete complete_union[symmetric] Un_def)
qed

text \<open>``Bounded complete'' refers to pointed conditional complete,
but this notion is just the dual of semicompleteness. We prove this later.\<close>

abbreviation "bounded_complete A r \<equiv> {X. \<exists>b\<in>A. bound X r b}-complete A r"

subsection \<open>Relations between Completeness Conditions\<close>

context
  fixes less_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>" 50)
begin

interpretation less_eq_notations.

text \<open>Pair-completeness implies that the universe is directed. Thus, with directed completeness
implies toppedness.\<close>

proposition directed_complete_pair_complete_imp_extremed:
  assumes dc: "directed_complete A (\<sqsubseteq>)" and pc: "pair_complete A (\<sqsubseteq>)" and A: "A \<noteq> {}"
  shows "extremed A (\<sqsubseteq>)"
proof-
  have "\<exists>s. extreme_bound A (\<sqsubseteq>) A s"
    apply (rule completeD[OF dc[unfolded directed_complete_def]])
    using pair_complete_imp_directed[OF pc] A by auto
  then obtain t where "extreme_bound A (\<sqsubseteq>) A t" by auto
  then have "\<forall>x \<in> A. x \<sqsubseteq> t" and "t \<in> A" by auto
  then show ?thesis by (auto simp: extremed_def)
qed

text \<open>Semicomplete is conditional complete and topped.\<close>

proposition semicomplete_iff_conditionally_complete_extremed:
  assumes A: "A \<noteq> {}"
  shows "semicomplete A (\<sqsubseteq>) \<longleftrightarrow> conditionally_complete A (\<sqsubseteq>) \<and> extremed A (\<sqsubseteq>)" (is "?l \<longleftrightarrow> ?r")
proof (intro iffI)
  assume r: "?r"
  then have cc: "conditionally_complete A (\<sqsubseteq>)" and e: "extremed A (\<sqsubseteq>)" by auto
  show ?l
  proof (intro completeI, unfold mem_Collect_eq)
    fix X
    assume X: "X \<subseteq> A" and "X \<noteq> {}"
    with extremed_imp_ex_bound[OF e X]
    show "\<exists>s. extreme_bound A (\<sqsubseteq>) X s" by (auto intro!: completeD[OF cc X])
  qed
next
  assume l: ?l
  with semicomplete_nonempty_imp_extremed[OF l] A
  show ?r by (auto intro!: completeI dest: completeD)
qed

proposition complete_iff_pointed_semicomplete:
  "UNIV-complete A (\<sqsubseteq>) \<longleftrightarrow> semicomplete A (\<sqsubseteq>) \<and> extremed A (\<sqsupseteq>)" (is "?l \<longleftrightarrow> ?r")
  by (unfold pointed_iff_empty_complete complete_union[symmetric] Un_def, auto)

text \<open>Conditional completeness only lacks top and bottom to be complete.\<close>

proposition complete_iff_conditionally_complete_extremed_pointed:
  "UNIV-complete A (\<sqsubseteq>) \<longleftrightarrow> conditionally_complete A (\<sqsubseteq>) \<and> extremed A (\<sqsubseteq>) \<and> extremed A (\<sqsupseteq>)"
  unfolding complete_iff_pointed_semicomplete
  apply (cases "A = {}")
   apply (auto intro!: completeI dest: extremed_imp_ex_bound)[1]
  unfolding semicomplete_iff_conditionally_complete_extremed
  apply (auto intro:completeI)
  done

text \<open>If the universe is directed, then every pair is bounded, and thus has a supremum.
  On the other hand, supremum gives an upper bound, witnessing directedness.\<close>

proposition conditionally_complete_imp_pair_complete_iff_directed:
  assumes comp: "conditionally_complete A (\<sqsubseteq>)"
  shows "pair_complete A (\<sqsubseteq>) \<longleftrightarrow> directed A (\<sqsubseteq>)" (is "?l \<longleftrightarrow> ?r")
proof(intro iffI)
  assume ?r
  then show ?l
    by (auto intro!: pair_completeI completeD[OF comp] elim: directedE)
next
  assume pc: ?l
  show ?r
  proof (intro directedI)
    fix x y assume "x \<in> A" and "y \<in> A"
    with pc obtain z where "extreme_bound A (\<sqsubseteq>) {x,y} z" by (auto dest: pair_completeD)
    then show "\<exists>z\<in>A. x \<sqsubseteq> z \<and> y \<sqsubseteq> z" by auto
  qed
qed

end

text \<open>Following is a new generalization of (weak) chain-completeness:\<close>
abbreviation "well_complete A r \<equiv> {X. well_related_set X r}-complete A r"

subsection \<open>Duality of Completeness Conditions\<close>

text \<open>Conditional completeness is symmetric.\<close>

context fixes less_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>" 50)
begin

interpretation less_eq_notations.

lemma conditionally_complete_dual:
  assumes comp: "conditionally_complete A (\<sqsubseteq>)" shows "conditionally_complete A (\<sqsupseteq>)"
proof (intro completeI, elim CollectE)
  fix X assume XA: "X \<subseteq> A"
  define B where [simp]: "B \<equiv> {b\<in>A. bound X (\<sqsupseteq>) b}"
  assume bound: "\<exists>b\<in>A. bound X (\<sqsupseteq>) b \<and> X \<noteq> {}"
  with in_mono[OF XA] have B: "B \<subseteq> A" and "\<exists>b \<in> A. bound B (\<sqsubseteq>) b" and "B \<noteq> {}" by auto
  from comp[THEN completeD, OF B] this
  obtain s where "s \<in> A" and "extreme_bound A (\<sqsubseteq>) B s" by auto
  with in_mono[OF XA] show "\<exists>s. extreme_bound A (\<sqsupseteq>) X s" by (intro exI[of _ s] extremeI, auto)
qed

text \<open>Full completeness is symmetric.\<close>

lemma complete_dual:
  "UNIV-complete A (\<sqsubseteq>) \<Longrightarrow> UNIV-complete A (\<sqsupseteq>)"
  apply (unfold complete_iff_conditionally_complete_extremed_pointed)
  using conditionally_complete_dual by auto

text \<open>Now we show that bounded completeness is the dual of semicompleteness.\<close>

lemma pointed_conditionally_complete_iff_bounded_complete:
  assumes A: "A \<noteq> {}"
  shows "conditionally_complete A (\<sqsubseteq>) \<and> extremed A (\<sqsupseteq>) \<longleftrightarrow> bounded_complete A (\<sqsubseteq>)"
  apply (unfold pointed_iff_empty_complete)
  apply (fold complete_union)
  apply (unfold Un_def)
  apply (rule arg_cong[of _ _ "\<lambda>CC. CC-complete A (\<sqsubseteq>)"])
  using A by auto

proposition bounded_complete_iff_dual_semicomplete:
  "bounded_complete A (\<sqsubseteq>) \<longleftrightarrow> semicomplete A (\<sqsupseteq>)"
proof (cases "A = {}")
  case True
  then show ?thesis by auto
next
  case False
  then show ?thesis
    apply (fold pointed_conditionally_complete_iff_bounded_complete[OF False])
    apply (unfold semicomplete_iff_conditionally_complete_extremed)
    using Complete_Relations.conditionally_complete_dual by auto
qed

end

lemmas connex_bounded_complete = connex_dual_semicomplete[folded bounded_complete_iff_dual_semicomplete]

subsection \<open>Completeness Results Requiring Order-Like Properties\<close>

text \<open>Above results hold without any assumption on the relation.
This part demands some order-like properties.\<close>

text \<open>It is well known that in a semilattice, i.e., a pair-complete partial order,
every finite nonempty subset of elements has a supremum.
We prove the result assuming transitivity, but only that.\<close>

lemma (in transitive) pair_complete_iff_finite_complete:
  "pair_complete A (\<sqsubseteq>) \<longleftrightarrow> finite_complete A (\<sqsubseteq>)" (is "?l \<longleftrightarrow> ?r")
proof (intro iffI completeI, elim CollectE conjE)
  fix X
  assume pc: ?l
  show "finite X \<Longrightarrow> X \<subseteq> A \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Ex (extreme_bound A (\<sqsubseteq>) X)"
  proof (induct X rule: finite_induct)
  case empty
    then show ?case by auto
  next
    case (insert x X)
    then have x: "x \<in> A" and X: "X \<subseteq> A" by auto
    show ?case
    proof (cases "X = {}")
      case True
      obtain x' where "extreme_bound A (\<sqsubseteq>) {x,x} x'" using pc[THEN pair_completeD, OF x x] by auto
      with True show ?thesis by (auto intro!: exI[of _ x'])
    next
      case False
      with insert obtain b where b: "extreme_bound A (\<sqsubseteq>) X b" by auto
      with pc[THEN pair_completeD] x obtain c where c: "extreme_bound A (\<sqsubseteq>) {x,b} c" by auto
      from c have cA: "c \<in> A" and xc: "x \<sqsubseteq> c" and bc: "b \<sqsubseteq> c" by auto
      from b have bA: "b \<in> A" and bX: "bound X (\<sqsubseteq>) b" by auto
      show ?thesis
      proof (intro exI extreme_boundI)
        fix xb assume xb: "xb \<in> insert x X"
        from bound_trans[OF bX bc X bA cA] have "bound X (\<sqsubseteq>) c".
        with xb xc show "xb \<sqsubseteq> c" by auto
      next
        fix d assume "bound (insert x X) (\<sqsubseteq>) d" and dA: "d \<in> A"
        with b have "bound {x,b} (\<sqsubseteq>) d" by auto
        with c show "c \<sqsubseteq> d" using dA by auto
      qed (fact cA)
    qed
  qed
qed (insert finite_complete_le_pair_complete, auto)

text \<open>Gierz et al.~\<^cite>\<open>"gierz03"\<close> showed that a directed complete partial order is semicomplete
if and only if it is also a semilattice.
We generalize the claim so that the underlying relation is only transitive.\<close>

proposition(in transitive) semicomplete_iff_directed_complete_pair_complete:
  "semicomplete A (\<sqsubseteq>) \<longleftrightarrow> directed_complete A (\<sqsubseteq>) \<and> pair_complete A (\<sqsubseteq>)" (is "?l \<longleftrightarrow> ?r")
proof (intro iffI)
  assume l: ?l
  then show ?r by (auto simp: directed_complete_def intro!: completeI pair_completeI completeD[OF l])
next
  assume ?r
  then have dc: "directed_complete A (\<sqsubseteq>)" and pc: "pair_complete A (\<sqsubseteq>)" by auto
  with pair_complete_iff_finite_complete have fc: "finite_complete A (\<sqsubseteq>)" by auto
  show ?l
  proof (intro completeI, elim CollectE)
    fix X assume XA: "X \<subseteq> A"
    have 1: "directed {x. \<exists>Y \<subseteq> X. finite Y \<and> Y \<noteq> {} \<and> extreme_bound A (\<sqsubseteq>) Y x} (\<sqsubseteq>)" (is "directed ?B _")
    proof (intro directedI)
      fix a b assume a: "a \<in> ?B" and b: "b \<in> ?B"
      from a obtain Y where Y: "extreme_bound A (\<sqsubseteq>) Y a" "finite Y" "Y \<noteq> {}" "Y \<subseteq> X" by auto
      from b obtain B where B: "extreme_bound A (\<sqsubseteq>) B b" "finite B" "B \<noteq> {}" "B \<subseteq> X" by auto
      from XA Y B have AB: "Y \<subseteq> A" "B \<subseteq> A" "finite (Y \<union> B)" "Y \<union> B \<noteq> {}" "Y \<union> B \<subseteq> X" by auto
      with fc[THEN completeD] have "Ex (extreme_bound A (\<sqsubseteq>) (Y \<union> B))" by auto
      then obtain c where c: "extreme_bound A (\<sqsubseteq>) (Y \<union> B) c" by auto
      show "\<exists>c \<in> ?B. a \<sqsubseteq> c \<and> b \<sqsubseteq> c"
      proof (intro bexI conjI)
        from Y B c show "a \<sqsubseteq> c" and "b \<sqsubseteq> c" by (auto simp: extreme_bound_iff)
        from AB c show "c \<in> ?B" by (auto intro!: exI[of _ "Y \<union> B"])
      qed
    qed
    have B: "?B \<subseteq> A" by auto
    assume "X \<noteq> {}"
    then obtain x where xX: "x \<in> X" by auto
    with fc[THEN completeD, of "{x}"] XA
    obtain x' where "extreme_bound A (\<sqsubseteq>) {x} x'" by auto
    with xX have x'B: "x' \<in> ?B" by (auto intro!: exI[of _ "{x}"] extreme_boundI)
    then have 2: "?B \<noteq> {}" by auto
    from dc[unfolded directed_complete_def, THEN completeD, of ?B] 1 2
    obtain b where b: "extreme_bound A (\<sqsubseteq>) ?B b" by auto
    then have bA: "b \<in> A" by auto
    show "Ex (extreme_bound A (\<sqsubseteq>) X)"
    proof (intro exI extreme_boundI UNIV_I)
      fix x
      assume xX: "x \<in> X"
      with XA fc[THEN completeD, of "{x}"]
      obtain c where c: "extreme_bound A (\<sqsubseteq>) {x} c" by auto
      then have cA: "c \<in> A" and xc: "x \<sqsubseteq> c" by auto
      from c xX have cB: "c \<in> ?B" by (auto intro!: exI[of _ "{x}"] extreme_boundI)
      with b have bA: "b \<in> A" and cb: "c \<sqsubseteq> b" by auto
      from xX XA cA bA trans[OF xc cb]
      show "x \<sqsubseteq> b" by auto text\<open> Here transitivity is needed. \<close>
    next
      fix x
      assume xA: "x \<in> A" and Xx: "bound X (\<sqsubseteq>) x"
      have "bound ?B (\<sqsubseteq>) x"
      proof (intro boundI UNIV_I, clarify)
        fix c Y
        assume "finite Y" and YX: "Y \<subseteq> X" and "Y \<noteq> {}" and c: "extreme_bound A (\<sqsubseteq>) Y c"
        from YX Xx have "bound Y (\<sqsubseteq>) x" by auto
        with c xA show "c \<sqsubseteq> x" by auto
      qed
      with b xA show "b \<sqsubseteq> x" by auto
    qed (fact bA)
  qed
qed

text\<open>The last argument in the above proof requires transitivity,
but if we had reflexivity then $x$ itself is a supremum of $\set{x}$
(see @{thm reflexive.extreme_bound_singleton}) and so $x \SLE s$ would be immediate.
Thus we can replace transitivity by reflexivity,
but then pair-completeness does not imply finite completeness.
We obtain the following result.\<close>

proposition (in reflexive) semicomplete_iff_directed_complete_finite_complete:
  "semicomplete A (\<sqsubseteq>) \<longleftrightarrow> directed_complete A (\<sqsubseteq>) \<and> finite_complete A (\<sqsubseteq>)" (is "?l \<longleftrightarrow> ?r")
proof (intro iffI)
  assume l: ?l
  then show ?r by (auto simp: directed_complete_def intro!: completeI pair_completeI completeD[OF l])
next
  assume ?r
  then have dc: "directed_complete A (\<sqsubseteq>)" and fc: "finite_complete A (\<sqsubseteq>)" by auto
  show ?l
  proof (intro completeI, elim CollectE)
    fix X assume XA: "X \<subseteq> A"
    have 1: "directed {x. \<exists>Y \<subseteq> X. finite Y \<and> Y \<noteq> {} \<and> extreme_bound A (\<sqsubseteq>) Y x} (\<sqsubseteq>)" (is "directed ?B _")
    proof (intro directedI)
      fix a b assume a: "a \<in> ?B" and b: "b \<in> ?B"
      from a obtain Y where Y: "extreme_bound A (\<sqsubseteq>) Y a" "finite Y" "Y \<noteq> {}" "Y \<subseteq> X" by auto
      from b obtain B where B: "extreme_bound A (\<sqsubseteq>) B b" "finite B" "B \<noteq> {}" "B \<subseteq> X" by auto
      from XA Y B have AB: "Y \<subseteq> A" "B \<subseteq> A" "finite (Y \<union> B)" "Y \<union> B \<noteq> {}" "Y \<union> B \<subseteq> X" by auto
      with fc[THEN completeD] have "Ex (extreme_bound A (\<sqsubseteq>) (Y \<union> B))" by auto
      then obtain c where c: "extreme_bound A (\<sqsubseteq>) (Y \<union> B) c" by auto
      show "\<exists>c \<in> ?B. a \<sqsubseteq> c \<and> b \<sqsubseteq> c"
      proof (intro bexI conjI)
        from Y B c show "a \<sqsubseteq> c" and "b \<sqsubseteq> c" by (auto simp: extreme_bound_iff)
        from AB c show "c \<in> ?B" by (auto intro!: exI[of _ "Y \<union> B"])
      qed
    qed
    have B: "?B \<subseteq> A" by auto
    assume "X \<noteq> {}"
    then obtain x where xX: "x \<in> X" by auto
    with XA have "extreme_bound A (\<sqsubseteq>) {x} x"
      by (intro extreme_bound_singleton, auto)
    with xX have xB: "x \<in> ?B" by (auto intro!: exI[of _ "{x}"])
    then have 2: "?B \<noteq> {}" by auto
    from dc[unfolded directed_complete_def, THEN completeD, of ?B] B 1 2
    obtain b where b: "extreme_bound A (\<sqsubseteq>) ?B b" by auto
    then have bA: "b \<in> A" by auto
    show "Ex (extreme_bound A (\<sqsubseteq>) X)"
    proof (intro exI extreme_boundI UNIV_I)
      fix x
      assume xX: "x \<in> X"
      with XA have x: "extreme_bound A (\<sqsubseteq>) {x} x" by (intro extreme_bound_singleton, auto)
      from x xX have cB: "x \<in> ?B" by (auto intro!: exI[of _ "{x}"])
      with b show "x \<sqsubseteq> b" by auto
    next
      fix x
      assume Xx: "bound X (\<sqsubseteq>) x" and xA: "x \<in> A"
      have "bound ?B (\<sqsubseteq>) x"
      proof (intro boundI UNIV_I, clarify)
        fix c Y
        assume "finite Y" and YX: "Y \<subseteq> X" and "Y \<noteq> {}" and c: "extreme_bound A (\<sqsubseteq>) Y c"
        from YX Xx have "bound Y (\<sqsubseteq>) x" by auto
        with YX XA xA c show "c \<sqsubseteq> x" by auto
      qed
      with xA b show "b \<sqsubseteq> x" by auto
    qed (fact bA)
  qed
qed

subsection \<open>Relating to Classes\<close>

(* HOL.Conditionally_Complete_Lattices imports choice.

text \<open>Isabelle's class @{class conditionally_complete_lattice} satisfies @{const conditionally_complete}.
The other direction does not hold, since for the former,
@{term "Sup {}"} and @{term "Inf {}"} are arbitrary even if there are top or bottom elements.\<close>

lemma (in conditionally_complete_lattice) "conditionally_complete UNIV (\<le>)"
proof (intro completeI, elim CollectE)
  fix X :: "'a set"
  assume "\<exists>b\<in>UNIV. bound X (\<le>) b \<and> X \<noteq> {}"
  then have bdd:"bdd_above X" and X0: "X \<noteq> {}" by (auto 0 3)
  from cSup_upper[OF _ bdd] cSup_least[OF X0]
  have "supremum X (Sup X)" by (intro extremeI boundI, auto)
  then show "\<exists>s. least {b \<in> UNIV. bound X (\<le>) b} s" by auto
qed
*)
text \<open>Isabelle's class @{class complete_lattice} is @{term "UNIV-complete"}.\<close>

lemma (in complete_lattice) "UNIV-complete UNIV (\<le>)"
  by (auto intro!: completeI Sup_upper Sup_least Inf_lower Inf_greatest)

subsection \<open>Set-wise Completeness\<close>

lemma directed_sets_directed_complete:
  assumes cl: "\<forall>DC. DC \<subseteq> AA \<longrightarrow> (\<forall>X\<in>DC. directed X r) \<longrightarrow> (\<Union>DC) \<in> AA"
  shows "{DC. directed DC (\<subseteq>)}-complete {X \<in> AA. directed X r} (\<subseteq>)"
proof (intro completeI, safe)
  fix XX
  assume ch: "XX \<subseteq> {X \<in> AA. directed X r}" and dir: "directed XX (\<subseteq>)"
  with cl have "(\<Union>XX) \<in> AA" by auto
  moreover have "directed (\<Union>XX) r"
  proof (intro directedI, elim UnionE)
    fix x y X Y assume xX: "x \<in> X" and X: "X \<in> XX" and yY: "y \<in> Y" and Y: "Y \<in> XX"
    from directedD[OF dir X Y]
    obtain Z where "X \<subseteq> Z" "Y \<subseteq> Z" and Z: "Z \<in> XX" by auto
    with ch xX yY have "directed Z r" "x \<in> Z" "y \<in> Z" by auto
    then obtain z where "z \<in> Z" "r x z \<and> r y z" by (auto elim:directedE)
    with Z show "\<exists>z\<in>\<Union> XX. r x z \<and> r y z" by auto
  qed
  ultimately have "extreme_bound {X \<in> AA. directed X r} (\<subseteq>) XX (\<Union>XX)" by auto
  then show "Ex (extreme_bound {X \<in> AA. directed X r} (\<subseteq>) XX)" by auto
qed

lemma connex_directed_Un:
  assumes ch: "CC \<subseteq> {C. connex C r}" and dir: "directed CC (\<subseteq>)"
  shows "connex (\<Union>CC) r"
proof (intro connexI, elim UnionE)
  fix x y X Y assume xX: "x \<in> X" and X: "X \<in> CC" and yY: "y \<in> Y" and Y: "Y \<in> CC"
  from directedD[OF dir X Y]
  obtain Z where "X \<subseteq> Z" "Y \<subseteq> Z" "Z \<in> CC" by auto
  with xX yY ch have "x \<in> Z" "y \<in> Z" "connex Z r" by auto
  then show "r x y \<or> r y x" by (auto elim:connexE)
qed

lemma connex_directed_complete: "{DC. directed DC (\<subseteq>)}-complete {C. connex C r} (\<subseteq>)"
  by (intro completeI, force dest!: connex_directed_Un)

end


(*******************************************************************************

  Project: IsaNet

  Author:  Tobias Klenze, ETH Zurich <tobias.klenze@inf.ethz.ch>
  Version: JCSPaper.1.0
  Isabelle Version: Isabelle2021-1

  Copyright (c) 2022 Tobias Klenze
  Licence: Mozilla Public License 2.0 (MPL) / BSD-3-Clause (dual license)

*******************************************************************************)

section \<open>Abstract XOR\<close>
theory "Abstract_XOR"
  imports
    "HOL.Finite_Set" "HOL-Library.FSet" "Message"
(*the latter half of this theory uses msgterm. If split it off, we have to add
  declare fmember_iff_member_fset[simp]
in order to show the first half*)
begin

(******************************************************************************)
subsection\<open>Abstract XOR definition and lemmas\<close>
(******************************************************************************)

text\<open>We model xor as an operation on finite sets (fset). @{term "{||}"} is defined as the identity element.\<close>

text\<open>xor of two fsets is the symmetric difference\<close>
definition xor :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset" where
  "xor xs ys = (xs |\<union>| ys) |-| (xs |\<inter>| ys)"

lemma xor_singleton:
  "xor xs {| z |} = (if z |\<in>| xs then xs |-| {| z |} else finsert z xs)"
  "xor {| z |} xs = (if z |\<in>| xs then xs |-| {| z |} else finsert z xs)"
  by (auto simp add: xor_def)

(*auto loops with this rule declared intro!. We could alternatively try using safe instead of auto*)
declare finsertCI[rule del]
declare finsertCI[intro]

lemma xor_assoc: "xor (xor xs ys) zs = xor xs (xor ys zs)"
  by (auto simp add: xor_def)

lemma xor_commut: "xor xs ys = xor ys xs"
  by (auto simp add: xor_def)

lemma xor_self_inv: "\<lbrakk>xor xs ys = zs; xs = ys\<rbrakk> \<Longrightarrow> zs = {||}"
  by (auto simp add: xor_def)

lemma xor_self_inv': "xor xs xs = {||}"
  by (auto simp add: xor_def)

lemma xor_self_inv''[dest!]: "xor xs ys = {||} \<Longrightarrow> xs = ys"
  by (auto simp add: xor_def)

lemma xor_identity1[simp]: "xor xs {||} = xs"
  by (auto simp add: xor_def)

lemma xor_identity2[simp]: "xor {||} xs = xs"
  by (auto simp add: xor_def)

lemma xor_in: "z |\<in>| xs \<Longrightarrow> z |\<notin>| (xor xs {| z |})"
  by (auto simp add: xor_singleton)

lemma xor_out: "z |\<notin>| xs \<Longrightarrow> z |\<in>| (xor xs {| z |})"
  by (auto simp add: xor_singleton)

lemma xor_elem1[dest]: "\<lbrakk>x \<in> fset (xor X Y); x |\<notin>| X\<rbrakk> \<Longrightarrow> x |\<in>| Y"
  by(auto simp add: xor_def)

lemma xor_elem2[dest]: "\<lbrakk>x \<in> fset (xor X Y); x |\<notin>| Y\<rbrakk> \<Longrightarrow> x |\<in>| X"
  by(auto simp add: xor_def)

lemma xor_finsert_self: "xor (finsert x xs) {|x|} = xs - {| x |}"
  by(auto simp add: xor_def)

(******************************************************************************)
subsection\<open>Lemmas refering to XOR and msgterm\<close>
(******************************************************************************)

lemma FS_contains_elem:
  assumes "elem = f (FS zs_s)" "zs_s = xor zs_b {| elem |}" "\<And> x. size (f x) > size x"
  shows "elem \<in> fset zs_b"
  using assms(1)
  apply(auto simp add: xor_def)
  using FS_mono assms notin_fset xor_singleton(1)
  by (metis)

lemma FS_is_finsert_elem:
  assumes "elem = f (FS zs_s)" "zs_s = xor zs_b {| elem |}" "\<And> x. size (f x) > size x"
  shows "zs_b = finsert elem zs_s"
  using assms FS_contains_elem finsert_fminus xor_singleton(1) FS_mono
  by (metis FS_mono)

lemma FS_update_eq:
  assumes "xs = f (FS (xor zs {|xs|}))"
      and "ys = g (FS (xor zs {|ys|}))"
      and "\<And> x. size (f x) > size x"
      and "\<And> x. size (g x) > size x"
    shows "xs = ys"
proof(rule ccontr)
  assume elem_neq: "xs \<noteq> ys"
  obtain zs_s1 zs_s2 where zs_defs:
    "zs_s1 = xor zs {|xs|}" "zs_s2 = xor zs {|ys|}" by simp
  have elems_contained_zs: "xs \<in> fset zs" "ys \<in> fset zs"
    using assms FS_contains_elem by blast+
  then have elems_elem: "ys |\<in>| zs_s1" "xs |\<in>| zs_s2"
    using elem_neq by(auto simp add: xor_def zs_defs)
  have zs_finsert: "finsert xs zs_s2 = zs_s2" "finsert ys zs_s1 = zs_s1"
    using elems_elem by fastforce+
  have f1: "\<forall>m f fa. \<not> sum fa (fset (finsert (m::msgterm) f)) < (fa m::nat)"
    by (simp add: sum.insert_remove)
  from assms(1-2) have "size xs > size (f (FS {| ys |}))" "size ys > size (g (FS {| xs |}))"
    apply(simp_all add: zs_defs[symmetric])
    using zs_finsert f1 by (metis (no_types) add_Suc_right assms(3-4) dual_order.strict_trans
        less_add_Suc1 msgterm.size(17) not_less_eq size_fset_simps)+
  then show False using assms(3,4) elems_elem
    by (metis add.right_neutral add_Suc_right f1 less_add_Suc1 msgterm.size(17) not_less_eq
              not_less_iff_gr_or_eq order.strict_trans size_fset_simps)
qed

declare fminusE[rule del]
declare finsertCI[rule del]
(*add back the removed rules without !*)
declare fminusE[elim]
declare finsertCI[intro]

(*currently not needed*)
lemma fset_size_le:
  assumes "x \<in> fset xs"
  shows "size x < Suc (\<Sum>x\<in>fset xs. Suc (size x))"
proof-
  have "size x \<le> (\<Sum>x\<in>fset xs. size x)" using assms
    by (auto intro: member_le_sum)
  moreover have "(\<Sum>x\<in>fset xs. size x) < (\<Sum>x\<in>fset xs. Suc (size x))"
    by (metis assms empty_iff finite_fset lessI sum_strict_mono)
  ultimately show ?thesis by auto
qed

text\<open>We can show that xor is a commutative function.\<close>
(*not needed*)
locale abstract_xor
begin
sublocale comp_fun_commute xor
  by(auto simp add: comp_fun_commute_def xor_def)

end
end