(*  Title:       Defintion and basics facts about Cantor pairing function
    Author:      Michael Nedzelsky <MichaelNedzelsky at yandex.ru>, 2008
    Maintainer:  Michael Nedzelsky <MichaelNedzelsky at yandex.ru>
*)

header {* Cantor pairing function *}

theory CPair
imports Main
begin

text {*
  We introduce a particular coding @{text "c_pair"} from ordered pairs
  of natural numbers to natural numbers.  See \cite{Rogers} and the
  Isabelle documentation for more information.
*}

subsection {* Pairing function *}

definition
  sf :: "nat \<Rightarrow> nat" where
  sf_def: "sf x = x * (x+1) div 2"

definition
  c_pair :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "c_pair x y = sf (x+y) + x"

lemma sf_at_0: "sf 0 = 0" by (simp add: sf_def)

lemma sf_at_1: "sf 1 = 1" by (simp add: sf_def)

lemma sf_at_Suc: "sf (x+1) = sf x + x + 1"
proof -
  have S1: "sf(x+1) = ((x+1)*(x+2)) div 2" by (simp add: sf_def)
  have S2: "(x+1)*(x+2) = x*(x+1) + 2*(x+1)" by (auto)
  have S2_1: "\<And> x y. x=y \<Longrightarrow> x div 2 = y div 2" by auto
  from S2 have S3: "(x+1)*(x+2) div 2 = (x*(x+1) + 2*(x+1)) div 2" by (rule S2_1)
  have S4: "(0::nat) < 2" by (auto)
  from S4 have S5: "(x*(x+1) + 2*(x+1)) div 2 = (x+1) + x*(x+1) div 2" by simp
  from S1 S3 S5 show ?thesis by (simp add: sf_def)
qed

lemma arg_le_sf: "x \<le> sf x"
proof -
  have "x + x \<le> x*(x + 1)" by simp
  hence "(x + x) div 2 \<le> x*(x+1) div 2" by (rule div_le_mono)
  hence "x \<le> x*(x+1) div 2" by simp
  thus ?thesis by (simp add: sf_def)
qed

lemma sf_mono: "x \<le> y \<Longrightarrow> sf x \<le> sf y"
proof -
  assume A1: "x \<le> y"
  then have "x+1 \<le> y+1" by (auto)
  with A1 have "x*(x+1) \<le> y*(y+1)" by (rule mult_le_mono)
  then have "x*(x+1) div 2 \<le> y*(y+1) div 2" by (rule div_le_mono)
  thus ?thesis by (simp add: sf_def)
qed

lemma sf_strict_mono: "x < y \<Longrightarrow> sf x < sf y"
proof -
  assume A1: "x < y"
  from A1 have S1: "x+1 \<le> y" by simp
  from S1 sf_mono have S2: "sf (x+1) \<le> sf y" by (auto)
  from sf_at_Suc have S3: "sf x < sf (x+1)" by (auto)
  from S2 S3 show ?thesis by (auto)
qed

lemma sf_posI: "x > 0 \<Longrightarrow> sf(x) > 0"
proof -
  assume A1: "x > 0"
  then have "sf(0) < sf(x)" by (rule sf_strict_mono)
  then show ?thesis by simp
qed

lemma arg_less_sf: "x > 1 \<Longrightarrow> x < sf(x)"
proof -
  assume A1: "x > 1"
  let ?y = "x-(1::nat)"
  from A1 have S1: "x = ?y+1" by simp
  from A1 have "?y > 0" by simp
  then have S2: "sf(?y) > 0" by (rule sf_posI)
  have "sf(?y+1) = sf(?y) + ?y + 1" by (rule sf_at_Suc)
  with S1 have "sf(x) = sf(?y) + x" by simp
  with S2  show ?thesis by simp
qed

lemma sf_eq_arg: "sf x = x \<Longrightarrow> x \<le> 1"
proof -
  assume "sf(x) = x"
  then have "\<not> (x < sf(x))" by simp
  then have "(\<not> (x > 1))" by (auto simp add: arg_less_sf)
  then show ?thesis by simp
qed

lemma sf_le_sfD: "sf x \<le> sf y \<Longrightarrow> x \<le> y"
proof -
  assume A1: "sf x \<le> sf y"
  have S1: "y < x \<Longrightarrow> sf y < sf x" by (rule sf_strict_mono)
  have S2: "y < x \<or> x \<le> y" by (auto)
  from A1 S1 S2 show ?thesis by (auto)
qed

lemma sf_less_sfD: "sf x < sf y \<Longrightarrow> x < y"
proof -
  assume A1: "sf x < sf y"
  have S1: "y \<le> x \<Longrightarrow> sf y \<le> sf x" by (rule sf_mono)
  have S2: "y \<le> x \<or> x < y" by (auto)
  from A1 S1 S2 show ?thesis by (auto)
qed

lemma sf_inj: "sf x = sf y \<Longrightarrow> x = y"
proof -
  assume A1: "sf x = sf y"
  have S1: "sf x \<le> sf y \<Longrightarrow> x \<le> y" by (rule sf_le_sfD)
  have S2: "sf y \<le> sf x \<Longrightarrow> y \<le> x" by (rule sf_le_sfD)
  from A1 have S3: "sf x \<le> sf y \<and> sf y \<le> sf x" by (auto)
  from S3 S1 S2 have S4: "x \<le> y \<and> y \<le> x" by (auto)
  from S4 show ?thesis by (auto)
qed

text {* Auxiliary lemmas *}

lemma sf_aux1: "x + y < z \<Longrightarrow> sf(x+y) + x < sf(z)"
proof -
  assume A1: "x+y < z"
  from A1 have S1: "x+y+1 \<le> z" by (auto)
  from S1 have S2: "sf(x+y+1) \<le> sf(z)" by (rule sf_mono)
  have S3: "sf(x+y+1) = sf(x+y) + (x+y)+1" by (rule sf_at_Suc)
  from S3 S2 have S4: "sf(x+y) + (x+y) + 1 \<le> sf(z)" by (auto)
  from S4 show ?thesis by (auto)
qed

lemma sf_aux2: "sf(z) \<le> sf(x+y) + x \<Longrightarrow> z \<le> x+y"
proof -
  assume A1: "sf(z) \<le> sf(x+y) + x"
  from A1 have S1: "\<not> sf(x+y) +x < sf(z)" by (auto)
  from S1 sf_aux1 have S2: "\<not> x+y < z" by (auto)
  from S2 show ?thesis by (auto)
qed

lemma sf_aux3: "sf(z) + m < sf(z+1) \<Longrightarrow> m \<le> z"
proof -
  assume A1: "sf(z) + m < sf(z+1)"
  have S1: "sf(z+1) = sf(z) + z + 1" by (rule sf_at_Suc)
  from A1 S1 have S2: "sf(z) + m < sf(z) + z + 1" by (auto)
  from S2 have S3: "m < z + 1" by (auto)
  from S3 show ?thesis by (auto)
qed

lemma sf_aux4: "(s::nat) < t \<Longrightarrow> (sf s) + s < sf t"
proof -
  assume A1: "(s::nat) < t"
  have "s*(s + 1) + 2*(s+1) \<le> t*(t+1)"
  proof -
    from A1 have S1: "(s::nat) + 1 \<le> t" by (auto)
    from A1 have "(s::nat) + 2 \<le> t+1" by (auto)
    with S1 have "((s::nat)+1)*(s+2) \<le> t*(t+1)" by (rule mult_le_mono)
    thus ?thesis by (auto)
  qed
  then have S1: "(s*(s+1) + 2*(s+1)) div 2 \<le>  t*(t+1) div 2" by (rule div_le_mono)
  have "(0::nat) < 2" by (auto)
  then have "(s*(s+1) + 2*(s+1)) div 2 = (s+1) + (s*(s+1)) div 2" by simp
  with S1 have "(s*(s+1)) div 2 + (s+1) \<le> t*(t+1) div 2" by (auto)
  then have "(s*(s+1)) div 2 + s < t*(t+1) div 2" by (auto)
  thus ?thesis by (simp add: sf_def)
qed

text {* Basic properties of c\_pair function *}

lemma sum_le_c_pair: "x + y \<le> c_pair x y"
proof -
  have "x+y \<le> sf(x+y)" by (rule arg_le_sf)
  thus ?thesis by (simp add: c_pair_def)
qed

lemma arg1_le_c_pair: "x \<le> c_pair x y"
proof -
  have "(x::nat) \<le> x + y" by (simp)
  moreover have "x + y \<le> c_pair x y" by (rule sum_le_c_pair)
  ultimately show ?thesis by (simp)
qed

lemma arg2_le_c_pair: "y \<le> c_pair x y"
proof -
  have "(y::nat) \<le> x + y" by (simp)
  moreover have "x + y \<le> c_pair x y" by (rule sum_le_c_pair)
  ultimately show ?thesis by (simp)
qed

lemma c_pair_sum_mono: "(x1::nat) + y1 < x2 + y2 \<Longrightarrow> c_pair x1 y1 < c_pair x2 y2"
proof -
  assume "(x1::nat) + y1 < x2 + y2"
  hence "sf (x1+y1) + (x1+y1) < sf(x2+y2)" by (rule sf_aux4)
  hence "sf (x1+y1) + x1 < sf(x2+y2) + x2" by (auto)
  thus ?thesis by (simp add: c_pair_def)
qed

lemma c_pair_sum_inj: "c_pair x1 y1 = c_pair x2 y2 \<Longrightarrow> x1 + y1 = x2 + y2"
proof -
  assume A1: "c_pair x1 y1 = c_pair x2 y2"
  have S1: "(x1::nat) + y1 < x2 + y2 \<Longrightarrow> c_pair x1 y1 \<noteq> c_pair x2 y2" by (rule less_not_refl3, rule c_pair_sum_mono, auto)
  have S2: "(x2::nat) + y2 < x1 + y1 \<Longrightarrow> c_pair x1 y1 \<noteq> c_pair x2 y2" by (rule less_not_refl2, rule c_pair_sum_mono, auto)
  from S1 S2 have "(x1::nat) + y1 \<noteq> x2 + y2 \<Longrightarrow> c_pair x1 y1 \<noteq> c_pair x2 y2" by (arith)
  with A1 show ?thesis by (auto)
qed

lemma c_pair_inj: "c_pair x1 y1 = c_pair x2 y2 \<Longrightarrow> x1 = x2 \<and> y1 = y2"
proof -
  assume A1: "c_pair x1 y1 = c_pair x2 y2"
  from A1 have S1: "x1 + y1 = x2 + y2" by (rule c_pair_sum_inj)
  from A1 have S2: "sf (x1+y1) + x1 = sf (x2+y2) + x2" by (unfold c_pair_def)
  from S1 S2 have S3: "x1 = x2" by (simp)
  from S1 S3 have S4: "y1 = y2" by (simp)
  from S3 S4 show ?thesis by (auto)
qed

lemma c_pair_inj1: "c_pair x1 y1 = c_pair x2 y2 \<Longrightarrow> x1 = x2" by (frule c_pair_inj, drule conjunct1)

lemma c_pair_inj2: "c_pair x1 y1 = c_pair x2 y2 \<Longrightarrow> y1 = y2" by (frule c_pair_inj, drule conjunct2)

lemma c_pair_strict_mono1: "x1 < x2 \<Longrightarrow> c_pair x1 y < c_pair x2 y"
proof -
  assume "x1 < x2"
  then have "x1 + y < x2 + y" by simp
  then show ?thesis by (rule c_pair_sum_mono)
qed

lemma c_pair_mono1: "x1 \<le> x2 \<Longrightarrow> c_pair x1 y \<le> c_pair x2 y"
proof -
  assume A1: "x1 \<le> x2"
  show ?thesis
  proof cases
    assume "x1 < x2"
    then have "c_pair x1 y < c_pair x2 y" by (rule c_pair_strict_mono1)
    then show ?thesis by simp
  next
    assume "\<not> x1 < x2"
    with A1 have "x1 = x2" by simp
    then show ?thesis by simp
  qed
qed

lemma c_pair_strict_mono2: "y1 < y2 \<Longrightarrow> c_pair x y1 < c_pair x y2"
proof -
  assume A1: "y1 < y2"
  from A1 have S1: "x + y1 < x + y2" by simp
  then show ?thesis by (rule c_pair_sum_mono)
qed

lemma c_pair_mono2: "y1 \<le> y2 \<Longrightarrow> c_pair x y1 \<le> c_pair x y2"
proof -
  assume A1: "y1 \<le> y2"
  show ?thesis
  proof cases
    assume "y1 < y2"
    then have "c_pair x y1 < c_pair x y2" by (rule c_pair_strict_mono2)
    then show ?thesis by simp
  next
    assume "\<not> y1 < y2"
    with A1 have "y1 = y2" by simp
    then show ?thesis by simp
  qed
qed

subsection {* Inverse mapping *}

text {*
  @{text "c_fst"} and @{text "c_snd"} are the functions which yield
  the inverse mapping to @{text "c_pair"}.
*}

definition
  c_sum :: "nat \<Rightarrow> nat" where
  "c_sum u = (LEAST z. u < sf (z+1))"

definition
  c_fst :: "nat \<Rightarrow> nat" where
  "c_fst u = u - sf (c_sum u)"

definition
  c_snd :: "nat \<Rightarrow> nat" where
  "c_snd u = c_sum u - c_fst u"

lemma arg_less_sf_at_Suc_of_c_sum: "u < sf ((c_sum u) + 1)"
proof -
  have "u+1 \<le> sf(u+1)" by (rule arg_le_sf)
  hence "u < sf(u+1)" by simp
  thus ?thesis by (unfold c_sum_def, rule LeastI)
qed

lemma arg_less_sf_imp_c_sum_less_arg: "u < sf(x) \<Longrightarrow> c_sum u < x"
proof -
  assume A1: "u < sf(x)"
  then show ?thesis
  proof (cases x)
    assume "x=0"
    with A1 show ?thesis by (simp add: sf_def)
  next
    fix y
    assume A2: "x = Suc y"
    show ?thesis
    proof -
      from A1 A2 have "u < sf(y+1)" by simp
      hence "(Least (%z. u < sf (z+1))) \<le> y" by (rule Least_le)
      hence "c_sum u \<le> y" by (fold c_sum_def)
      with A2 show ?thesis by simp
    qed
  qed
qed

lemma sf_c_sum_le_arg: "u \<ge> sf (c_sum u)"
proof -
  let ?z = "c_sum u"
  from arg_less_sf_at_Suc_of_c_sum have S1: "u < sf (?z+1)" by (auto)
  have S2: "\<not> c_sum u < c_sum u" by (auto)
  from arg_less_sf_imp_c_sum_less_arg S2 have S3: "\<not> u < sf (c_sum u) " by (auto)
  from S3 show ?thesis by (auto)
qed

lemma c_sum_le_arg: "c_sum u \<le> u"
proof -
  have "c_sum u \<le> sf (c_sum u)" by (rule arg_le_sf)
  moreover have "sf(c_sum u) \<le> u" by (rule sf_c_sum_le_arg)
  ultimately show ?thesis by simp
qed

lemma c_sum_of_c_pair [simp]: "c_sum (c_pair x y) = x + y"
proof -
  let ?u = "c_pair x y"
  let ?z = "c_sum ?u"
  have S1: "?u < sf(?z+1)" by (rule arg_less_sf_at_Suc_of_c_sum)
  have S2: "sf(?z) \<le> ?u" by (rule sf_c_sum_le_arg)
  from S1 have S3: "sf(x+y)+x < sf(?z+1)" by (simp add: c_pair_def)
  from S2 have S4: "sf(?z) \<le> sf(x+y) + x" by (simp add: c_pair_def)
  from S3 have S5: "sf(x+y) < sf(?z+1)" by (auto)
  from S5 have S6: "x+y < ?z+1" by (rule sf_less_sfD)
  from S6 have S7: "x+y \<le> ?z" by (auto)
  from S4 have S8: "?z \<le> x+y" by (rule sf_aux2)
  from S7 S8 have S9: "?z = x+y" by (auto)
  from S9 show ?thesis by (simp)
qed

lemma c_fst_of_c_pair[simp]: "c_fst (c_pair x y) = x"
proof -
  let ?u = "c_pair x y"
  have "c_sum ?u = x + y" by simp
  hence "c_fst ?u = ?u - sf(x+y)" by (simp add: c_fst_def)
  moreover have "?u = sf(x+y) + x" by (simp add: c_pair_def)
  ultimately show ?thesis by (simp)
qed

lemma c_snd_of_c_pair[simp]: "c_snd (c_pair x y) = y"
proof -
  let ?u = "c_pair x y"
  have "c_sum ?u = x + y" by simp
  moreover have "c_fst ?u = x" by simp
  ultimately show ?thesis by (simp add: c_snd_def)
qed

lemma c_pair_at_0: "c_pair 0 0 = 0" by (simp add: sf_def c_pair_def)

lemma c_fst_at_0: "c_fst 0 = 0"
proof -
  have "c_pair 0 0 = 0" by (rule c_pair_at_0)
  hence "c_fst 0 = c_fst (c_pair 0 0)" by simp
  thus ?thesis by simp
qed

lemma c_snd_at_0: "c_snd 0 = 0"
proof -
  have "c_pair 0 0 = 0" by (rule c_pair_at_0)
  hence "c_snd 0 = c_snd (c_pair 0 0)" by simp
  thus ?thesis by simp
qed

lemma sf_c_sum_plus_c_fst: "sf(c_sum u) + c_fst u = u"
proof -
  have S1: "sf(c_sum u) \<le> u" by (rule sf_c_sum_le_arg)
  have S2: "c_fst u = u - sf(c_sum u)" by (simp add: c_fst_def)
  from S1 S2 show ?thesis by (auto)
qed

lemma c_fst_le_c_sum: "c_fst u \<le> c_sum u"
proof -
  have S1: "sf(c_sum u) + c_fst u = u" by (rule sf_c_sum_plus_c_fst)
  have S2: "u < sf((c_sum u) + 1)" by (rule arg_less_sf_at_Suc_of_c_sum)
  from S1 S2 sf_aux3 show ?thesis by (auto)
qed

lemma c_snd_le_c_sum: "c_snd u \<le> c_sum u" by (simp add: c_snd_def)

lemma c_fst_le_arg: "c_fst u \<le> u"
proof -
  have "c_fst u \<le> c_sum u" by (rule c_fst_le_c_sum)
  moreover have "c_sum u \<le> u" by (rule c_sum_le_arg)
  ultimately show ?thesis by simp
qed

lemma c_snd_le_arg: "c_snd u \<le> u"
proof -
  have "c_snd u \<le> c_sum u" by (rule c_snd_le_c_sum)
  moreover have "c_sum u \<le> u" by (rule c_sum_le_arg)
  ultimately show ?thesis by simp
qed

lemma c_sum_is_sum: "c_sum u = c_fst u + c_snd u" by (simp add: c_snd_def c_fst_le_c_sum)

lemma proj_eq_imp_arg_eq: "\<lbrakk> c_fst u = c_fst v; c_snd u = c_snd v\<rbrakk> \<Longrightarrow> u = v"
proof -
  assume A1: "c_fst u = c_fst v"
  assume A2: "c_snd u = c_snd v"
  from A1 A2 c_sum_is_sum have S1: "c_sum u = c_sum v" by (auto)
  have S2: "sf(c_sum u) + c_fst u = u" by (rule sf_c_sum_plus_c_fst)
  from A1 S1 S2 have S3: "sf(c_sum v) + c_fst v = u" by (auto)
  from S3 sf_c_sum_plus_c_fst show ?thesis by (auto)
qed

lemma c_pair_of_c_fst_c_snd[simp]: "c_pair (c_fst u) (c_snd u) = u"
proof -
  let ?x = "c_fst u"
  let ?y = "c_snd u"
  have S1: "c_pair ?x ?y = sf(?x + ?y) + ?x" by (simp add: c_pair_def)
  have S2: "c_sum u = ?x + ?y" by (rule c_sum_is_sum)
  from S1 S2 have "c_pair ?x ?y = sf(c_sum u) + c_fst u" by (auto)
  thus ?thesis by (simp add: sf_c_sum_plus_c_fst)
qed

lemma c_sum_eq_arg: "c_sum x = x \<Longrightarrow> x \<le> 1"
proof -
  assume A1: "c_sum x = x"
  have S1: "sf(c_sum x) + c_fst x = x" by (rule sf_c_sum_plus_c_fst)
  from A1 S1 have S2: "sf x + c_fst x = x" by simp
  have S3: "x \<le> sf x" by (rule arg_le_sf)
  from S2 S3 have "sf(x)=x" by simp
  thus ?thesis by (rule sf_eq_arg)
qed

lemma c_sum_eq_arg_2: "c_sum x = x \<Longrightarrow> c_fst x = 0"
proof -
  assume A1: "c_sum x = x"
  have S1: "sf(c_sum x) + c_fst x = x" by (rule sf_c_sum_plus_c_fst)
  from A1 S1 have S2: "sf x + c_fst x = x" by simp
  have S3: "x \<le> sf x" by (rule arg_le_sf)
  from S2 S3 show ?thesis by simp
qed

lemma c_fst_eq_arg: "c_fst x = x \<Longrightarrow> x = 0"
proof -
  assume A1: "c_fst x = x"
  have S1: "c_fst x \<le> c_sum x" by (rule c_fst_le_c_sum)
  have S2: "c_sum x \<le> x" by (rule c_sum_le_arg)
  from A1 S1 S2 have "c_sum x = x" by simp
  then have "c_fst x = 0" by (rule c_sum_eq_arg_2)
  with A1 show ?thesis by simp
qed

lemma c_snd_eq_arg: "c_snd x = x \<Longrightarrow> x \<le> 1"
proof -
  assume A1: "c_snd x = x"
  have S1: "c_snd x \<le> c_sum x" by (rule c_snd_le_c_sum)
  have S2: "c_sum x \<le> x" by (rule c_sum_le_arg)
  from A1 S1 S2 have "c_sum x = x" by simp
  then show ?thesis by (rule c_sum_eq_arg)
qed

end


theory simp_playground
  imports Main
begin

datatype 'a boolexp =
   TRUE
  | FALSE
  | Var 'a
  | Not "'a boolexp"
  | And "'a boolexp" "'a boolexp"
  | Or "'a boolexp" "'a boolexp"
  | Implies "'a boolexp" "'a boolexp"
print_theorems

fun boolexp_eval :: "('a \<Rightarrow> bool) \<Rightarrow> 'a boolexp \<Rightarrow> bool" where
   "boolexp_eval env TRUE = True"
 | "boolexp_eval env FALSE = False"
 | "boolexp_eval env (Var x) = env x"
 | "boolexp_eval env (Not b) = (\<not> (boolexp_eval env b))"
 | "boolexp_eval env (And a b) = ((boolexp_eval env a) \<and> (boolexp_eval env b))"
 | "boolexp_eval env (Or a b) = ((boolexp_eval env a) \<or> (boolexp_eval env b))"
 | "boolexp_eval env (Implies a b) = ((\<not> (boolexp_eval env a)) \<or> (boolexp_eval env b))"

definition env1 where "env1 \<equiv> (\<lambda> x. case x of (0::nat) \<Rightarrow> True | _ \<Rightarrow> False)"

value "boolexp_eval env1 (Not (Var (1::nat)))"

lemma  "boolexp_eval env1 (Not (Var (1::nat))) = True"
  apply (simp only: env1_def)
  apply (simp only: boolexp_eval.simps(4))
  by simp

lemma "A \<longrightarrow> A \<and> B = (if A then B else False)" by simp

end


(*
  Title: Closure and Co-Closure Operators
  Author: Georg Struth
  Maintainer: Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Closure and Co-Closure Operators\<close>

theory Closure_Operators
  imports Galois_Connections

begin

subsection \<open>Closure Operators\<close>

text \<open>Closure and coclosure operators in orders and complete lattices are defined in this section,
and some basic properties are proved. Isabelle infers the appropriate types. Facts are
taken mainly from the Compendium of Continuous Lattices~\<^cite>\<open>"GierzHKLMS80"\<close> and
Rosenthal's book on quantales~\<^cite>\<open>"Rosenthal90"\<close>.\<close>

definition clop :: "('a::order \<Rightarrow> 'a) \<Rightarrow> bool" where
  "clop f = (id \<le> f \<and> mono f \<and> f \<circ> f \<le> f)"

lemma clop_extensive: "clop f \<Longrightarrow> id \<le> f"
  by (simp add: clop_def)

lemma clop_extensive_var: "clop f \<Longrightarrow> x \<le> f x"
  by (simp add: clop_def le_fun_def)

lemma clop_iso: "clop f \<Longrightarrow> mono f"
  by (simp add: clop_def)

lemma clop_iso_var: "clop f \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
  by (simp add: clop_def mono_def)

lemma clop_idem: "clop f \<Longrightarrow> f \<circ> f = f"
  by (simp add: antisym clop_def le_fun_def)

lemma clop_Fix_range: "clop f \<Longrightarrow> (Fix f = range f)"
  by (simp add: clop_idem retraction_prop_fix)

lemma clop_Inf_closed_var:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  shows "clop f \<Longrightarrow> f \<circ> Inf \<circ> (`) f  = Inf \<circ> (`) f"
  unfolding clop_def mono_def comp_def le_fun_def
  by (metis (mono_tags, lifting) antisym id_apply le_INF_iff order_refl)

lemma clop_top:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  shows "clop f \<Longrightarrow> f \<top> = \<top>"
  by (simp add: clop_extensive_var top.extremum_uniqueI)

lemma "clop (f::'a::complete_lattice \<Rightarrow> 'a) \<Longrightarrow> f (\<Squnion>x \<in> X. f x) = (\<Squnion>x \<in> X. f x)" (*nitpick*)
  oops

lemma "clop (f::'a::complete_lattice \<Rightarrow> 'a) \<Longrightarrow> f (f x \<squnion> f y) = f x \<squnion> f y" (*nitpick*)
  oops

lemma  "clop (f::'a::complete_lattice \<Rightarrow> 'a) \<Longrightarrow> f \<bottom> = \<bottom>" (*nitpick *)
  oops

lemma "clop (f::'a set \<Rightarrow> 'a set) \<Longrightarrow> f (\<Squnion>x \<in> X. f x) = (\<Squnion>x \<in> X. f x)" (*nitpick*)
  oops

lemma "clop (f::'a set \<Rightarrow> 'a set) \<Longrightarrow> f (f x \<squnion> f y) = f x \<squnion> f y" (*nitpick*)
  oops

lemma  "clop (f::'a set \<Rightarrow> 'a set) \<Longrightarrow> f \<bottom> = \<bottom>" (*nitpick *)
  oops

lemma clop_closure: "clop f \<Longrightarrow> (x \<in> range f) = (f x = x)"
  by (simp add: clop_idem retraction_prop)

lemma clop_closure_set: "clop f \<Longrightarrow> range f = Fix f"
  by (simp add: clop_Fix_range)

lemma clop_closure_prop: "(clop::('a::complete_lattice_with_dual\<Rightarrow> 'a) \<Rightarrow> bool) (Inf \<circ> \<up>)"
  by (simp add: clop_def mono_def)

lemma clop_closure_prop_var: "clop (\<lambda>x::'a::complete_lattice. \<Sqinter>{y. x \<le> y})"
  unfolding clop_def comp_def le_fun_def mono_def by (simp add: Inf_lower le_Inf_iff)

lemma clop_alt: "(clop f) = (\<forall>x y. x \<le> f y \<longleftrightarrow> f x \<le> f y)"
  unfolding clop_def mono_def le_fun_def comp_def id_def by (meson dual_order.refl order_trans)

text \<open>Finally it is shown that adjoints in a Galois connection yield closure operators.\<close>

lemma clop_adj:
  fixes f :: "'a::order \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> clop (g \<circ> f)"
  by (simp add: adj_cancel2 adj_idem2 adj_iso4 clop_def)

text \<open>Closure operators are monads for posets, and monads arise from adjunctions.
This fact is not formalised at this point. But here is the first step: every function
can be decomposed into a surjection followed by an injection.\<close>

definition "surj_on f Y = (\<forall>y \<in> Y. \<exists>x. y = f x)"

lemma surj_surj_on: "surj f \<Longrightarrow> surj_on f Y"
  by (simp add: surjD surj_on_def)

lemma fun_surj_inj: "\<exists>g h. f = g \<circ> h \<and> surj_on h (range f) \<and> inj_on g (range f)"
proof-
  obtain h where a: "\<forall>x. f x = h x"
    by blast
  then have "surj_on h (range f)"
    by (metis (mono_tags, lifting) imageE surj_on_def)
  then show ?thesis
    unfolding inj_on_def surj_on_def fun_eq_iff using a by auto
qed

text \<open>Connections between downsets, upsets and closure operators are outlined next.\<close>

lemma preorder_clop: "clop (\<Down>::'a::preorder set \<Rightarrow> 'a set)"
  by (simp add: clop_def downset_set_ext downset_set_iso)

lemma clop_preorder_aux: "clop f \<Longrightarrow> (x \<in> f {y} \<longleftrightarrow> f {x} \<subseteq> f {y})"
  by (simp add: clop_alt)

lemma clop_preorder: "clop f \<Longrightarrow> class.preorder (\<lambda>x y. f {x} \<subseteq> f {y}) (\<lambda>x y. f {x} \<subset> f {y})"
  unfolding clop_def mono_def le_fun_def id_def comp_def by standard (auto simp: subset_not_subset_eq)

lemma preorder_clop_dual: "clop (\<Up>::'a::preorder_with_dual set \<Rightarrow> 'a set)"
  by (simp add: clop_def upset_set_anti upset_set_ext)

text \<open>The closed elements of any closure operator over a complete lattice form an Inf-closed set (a Moore family).\<close>

lemma clop_Inf_closed:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  shows  "clop f \<Longrightarrow> Inf_closed_set (Fix f)"
  unfolding clop_def Inf_closed_set_def mono_def le_fun_def comp_def id_def Fix_def
  by (smt Inf_greatest Inf_lower antisym mem_Collect_eq subsetCE)

lemma clop_top_Fix:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  shows  "clop f \<Longrightarrow> \<top> \<in> Fix f"
  by (simp add: clop_Fix_range clop_closure clop_top)

text \<open>Conversely, every Inf-closed subset of a complete lattice is the set of fixpoints of some closure operator.\<close>

lemma Inf_closed_clop:
  fixes X :: "'a::complete_lattice set"
  shows "Inf_closed_set X \<Longrightarrow> clop (\<lambda>y. \<Sqinter>{x \<in> X. y \<le> x})"
  by (smt Collect_mono_iff Inf_superset_mono clop_alt dual_order.trans le_Inf_iff mem_Collect_eq)

lemma Inf_closed_clop_var:
  fixes X :: "'a::complete_lattice set"
  shows "clop f \<Longrightarrow> \<forall>x \<in> X. x \<in> range f \<Longrightarrow> \<Sqinter>X \<in> range f"
  by (metis Inf_closed_set_def clop_Fix_range clop_Inf_closed subsetI)

text \<open>It is well known that downsets and upsets over an ordering form subalgebras of the complete powerset lattice.\<close>

typedef (overloaded) 'a downsets = "range (\<Down>::'a::order set \<Rightarrow> 'a set)"
  by fastforce

setup_lifting type_definition_downsets

typedef (overloaded) 'a upsets = "range (\<Up>::'a::order set \<Rightarrow> 'a set)"
  by fastforce

setup_lifting type_definition_upsets

instantiation downsets :: (order) Inf_lattice
begin

lift_definition Inf_downsets :: "'a downsets set \<Rightarrow> 'a downsets" is "Abs_downsets \<circ> Inf \<circ> (`) Rep_downsets".

lift_definition less_eq_downsets :: "'a downsets \<Rightarrow> 'a downsets \<Rightarrow> bool" is "\<lambda>X Y. Rep_downsets X \<subseteq> Rep_downsets Y".

lift_definition less_downsets :: "'a downsets \<Rightarrow> 'a downsets \<Rightarrow> bool" is "\<lambda>X Y. Rep_downsets X \<subset> Rep_downsets Y".

instance
  apply intro_classes
      apply (transfer, simp)
     apply (transfer, blast)
    apply (simp add: Closure_Operators.less_eq_downsets.abs_eq Rep_downsets_inject)
   apply (transfer, smt Abs_downsets_inverse INF_lower Inf_closed_clop_var Rep_downsets image_iff o_def preorder_clop)
  by transfer (smt comp_def Abs_downsets_inverse Inf_closed_clop_var Rep_downsets image_iff le_INF_iff preorder_clop)

end

instantiation upsets :: (order_with_dual) Inf_lattice
begin

lift_definition Inf_upsets :: "'a upsets set \<Rightarrow> 'a upsets" is "Abs_upsets \<circ> Inf \<circ> (`) Rep_upsets".

lift_definition less_eq_upsets :: "'a upsets \<Rightarrow> 'a upsets \<Rightarrow> bool" is "\<lambda>X Y. Rep_upsets X \<subseteq> Rep_upsets Y".

lift_definition less_upsets :: "'a upsets \<Rightarrow> 'a upsets \<Rightarrow> bool" is "\<lambda>X Y. Rep_upsets X \<subset> Rep_upsets Y".

instance
  apply intro_classes
      apply (transfer, simp)
     apply (transfer, blast)
    apply (simp add: Closure_Operators.less_eq_upsets.abs_eq Rep_upsets_inject)
   apply (transfer, smt Abs_upsets_inverse Inf_closed_clop_var Inf_lower Rep_upsets comp_apply image_iff preorder_clop_dual)
  by transfer (smt comp_def Abs_upsets_inverse Inf_closed_clop_var Inter_iff Rep_upsets image_iff preorder_clop_dual subsetCE subsetI)

end

text \<open>It has already been shown in the section on representations that the map ds, which maps elements of the order to its downset, is an order
embedding. However, the duality between the underlying ordering and the lattices of up- and down-closed sets as categories can probably not be expressed,
as there is no easy access to contravariant functors. \<close>

subsection \<open>Co-Closure Operators\<close>

text \<open>Next, the co-closure (or kernel) operation satisfies dual laws.\<close>

definition coclop :: "('a::order \<Rightarrow> 'a::order) \<Rightarrow> bool" where
  "coclop f = (f \<le> id \<and> mono f \<and> f \<le> f \<circ> f)"

lemma coclop_dual: "(coclop::('a::order_with_dual \<Rightarrow> 'a) \<Rightarrow> bool) = clop \<circ> \<partial>\<^sub>F"
  unfolding coclop_def clop_def id_def mono_def map_dual_def comp_def fun_eq_iff le_fun_def
  by (metis invol_dual_var ord_dual)

lemma coclop_dual_var:
  fixes f :: "'a::order_with_dual \<Rightarrow> 'a"
  shows "coclop f = clop (\<partial>\<^sub>F f)"
  by (simp add: coclop_dual)

lemma clop_dual: "(clop::('a::order_with_dual \<Rightarrow> 'a) \<Rightarrow> bool) = coclop \<circ> \<partial>\<^sub>F"
  by (simp add: coclop_dual comp_assoc map_dual_invol)

lemma clop_dual_var:
  fixes f :: "'a::order_with_dual \<Rightarrow> 'a"
  shows "clop f = coclop (\<partial>\<^sub>F f)"
  by (simp add: clop_dual)

lemma coclop_coextensive: "coclop f \<Longrightarrow> f \<le> id"
  by (simp add: coclop_def)

lemma coclop_coextensive_var: "coclop f \<Longrightarrow> f x \<le> x"
  using coclop_def le_funD by fastforce

lemma coclop_iso: "coclop f \<Longrightarrow> mono f"
  by (simp add: coclop_def)

lemma coclop_iso_var: "coclop f \<Longrightarrow> (x \<le> y \<longrightarrow> f x \<le> f y)"
  by (simp add: coclop_iso monoD)

lemma coclop_idem: "coclop f \<Longrightarrow> f \<circ> f = f"
  by (simp add: antisym coclop_def le_fun_def)

lemma coclop_closure: "coclop f \<Longrightarrow> (x \<in> range f) = (f x = x)"
  by (simp add: coclop_idem retraction_prop)

lemma coclop_Fix_range: "coclop f \<Longrightarrow> (Fix f = range f)"
  by (simp add: coclop_idem retraction_prop_fix)

lemma coclop_idem_var: "coclop f \<Longrightarrow> f (f x) = f x"
  by (simp add: coclop_idem retraction_prop)

lemma coclop_Sup_closed_var:
  fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'a"
  shows "coclop f \<Longrightarrow> f \<circ> Sup \<circ> (`) f  = Sup \<circ> (`) f"
  unfolding coclop_def mono_def comp_def le_fun_def
  by (metis (mono_tags, lifting) SUP_le_iff antisym id_apply order_refl)

lemma Sup_closed_coclop_var:
  fixes X :: "'a::complete_lattice set"
  shows "coclop f \<Longrightarrow> \<forall>x \<in> X. x \<in> range f \<Longrightarrow> \<Squnion>X \<in> range f"
  by (smt Inf.INF_id_eq Sup.SUP_cong antisym coclop_closure coclop_coextensive_var coclop_iso id_apply mono_SUP)

lemma coclop_bot:
  fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'a"
  shows "coclop f \<Longrightarrow> f \<bottom> = \<bottom>"
  by (simp add: bot.extremum_uniqueI coclop_coextensive_var)

lemma "coclop (f::'a::complete_lattice \<Rightarrow> 'a) \<Longrightarrow> f (\<Sqinter>x \<in> X. f x) = (\<Sqinter>x \<in> X. f x)" (*nitpick*)
  oops

lemma "coclop (f::'a::complete_lattice \<Rightarrow> 'a) \<Longrightarrow> f (f x \<sqinter> f y) = f x \<sqinter> f y" (*nitpick*)
  oops

lemma  "coclop (f::'a::complete_lattice \<Rightarrow> 'a) \<Longrightarrow> f \<top> = \<top>" (*nitpick*)
  oops

lemma "coclop (f::'a set \<Rightarrow> 'a set) \<Longrightarrow> f (\<Sqinter>x \<in> X. f x) = (\<Sqinter>x \<in> X. f x)" (*nitpick*)
  oops

lemma "coclop (f::'a set \<Rightarrow> 'a set) \<Longrightarrow> f (f x \<sqinter> f y) = f x \<sqinter> f y" (*nitpick*)
  oops

lemma  "coclop (f::'a set \<Rightarrow> 'a set) \<Longrightarrow> f \<top> = \<top>" (*nitpick *)
  oops

lemma coclop_coclosure: "coclop f \<Longrightarrow> f x = x \<longleftrightarrow> x \<in> range f"
 by (simp add: coclop_idem retraction_prop)

lemma coclop_coclosure_set: "coclop f \<Longrightarrow> range f = Fix f"
  by (simp add: coclop_idem retraction_prop_fix)

lemma coclop_coclosure_prop: "(coclop::('a::complete_lattice \<Rightarrow> 'a) \<Rightarrow> bool) (Sup \<circ> \<down>)"
  by (simp add: coclop_def mono_def)

lemma coclop_coclosure_prop_var: "coclop (\<lambda>x::'a::complete_lattice. \<Squnion>{y. y \<le> x})"
  by (metis (mono_tags, lifting) Sup_atMost atMost_def coclop_def comp_apply eq_id_iff eq_refl mono_def)

lemma coclop_alt: "(coclop f) = (\<forall>x y. f x \<le> y \<longleftrightarrow> f x \<le> f y)"
  unfolding coclop_def mono_def le_fun_def comp_def id_def
  by (meson dual_order.refl order_trans)

lemma coclop_adj:
  fixes f :: "'a::order \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> coclop (f \<circ> g)"
  by (simp add: adj_cancel1 adj_idem1 adj_iso3 coclop_def)

text \<open>Finally, a subset of a complete lattice is Sup-closed if and only if it is the set of fixpoints
of some co-closure operator.\<close>

lemma coclop_Sup_closed:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  shows  "coclop f \<Longrightarrow> Sup_closed_set (Fix f)"
  unfolding coclop_def Sup_closed_set_def mono_def le_fun_def comp_def id_def Fix_def
  by (smt Sup_least Sup_upper antisym_conv mem_Collect_eq subsetCE)

lemma Sup_closed_coclop:
  fixes X :: "'a::complete_lattice set"
  shows "Sup_closed_set X \<Longrightarrow> coclop (\<lambda>y. \<Squnion>{x \<in> X. x \<le> y})"
  unfolding Sup_closed_set_def coclop_def mono_def le_fun_def comp_def
  apply safe
  apply (metis (no_types, lifting) Sup_least eq_id_iff mem_Collect_eq)
  apply (smt Collect_mono_iff Sup_subset_mono dual_order.trans)
  by (simp add: Collect_mono_iff Sup_subset_mono Sup_upper)

subsection \<open>Complete Lattices of Closed Elements\<close>

text \<open>The machinery developed allows showing that the closed elements in a complete
lattice (with respect to some closure operation) form themselves a complete lattice.\<close>

class cl_op = ord +
  fixes cl_op :: "'a \<Rightarrow> 'a"
  assumes clop_ext: "x \<le> cl_op x"
  and clop_iso: "x \<le> y \<Longrightarrow> cl_op x \<le> cl_op y"
  and clop_wtrans: "cl_op (cl_op x) \<le> cl_op x"

class clattice_with_clop = complete_lattice + cl_op

begin

lemma clop_cl_op: "clop cl_op"
  unfolding clop_def le_fun_def comp_def
  by (simp add: cl_op_class.clop_ext cl_op_class.clop_iso cl_op_class.clop_wtrans order_class.mono_def)

lemma clop_idem [simp]: "cl_op \<circ> cl_op = cl_op"
  using clop_ext clop_wtrans order.antisym by auto

lemma clop_idem_var [simp]: "cl_op (cl_op x) = cl_op x"
  by (simp add: order.antisym clop_ext clop_wtrans)

lemma clop_range_Fix: "range cl_op = Fix cl_op"
  by (simp add: retraction_prop_fix)

lemma Inf_closed_cl_op_var:
  fixes X :: "'a set"
  shows "\<forall>x \<in> X. x \<in> range cl_op \<Longrightarrow> \<Sqinter>X \<in> range cl_op"
proof-
  assume h: "\<forall>x \<in> X. x \<in> range cl_op"
  hence "\<forall>x \<in> X. cl_op x = x"
    by (simp add: retraction_prop)
  hence "cl_op (\<Sqinter>X) = \<Sqinter>X"
    by (metis Inf_lower clop_ext clop_iso dual_order.antisym le_Inf_iff)
  thus ?thesis
    by (metis rangeI)
qed

lemma inf_closed_cl_op_var: "x \<in> range cl_op \<Longrightarrow> y \<in> range cl_op \<Longrightarrow> x \<sqinter> y \<in> range cl_op"
  by (smt Inf_closed_cl_op_var UnI1 insert_iff insert_is_Un inf_Inf)

end

typedef (overloaded) 'a::clattice_with_clop cl_op_im = "range (cl_op::'a \<Rightarrow> 'a)"
  by force

setup_lifting type_definition_cl_op_im

lemma cl_op_prop [iff]: "(cl_op (x \<squnion> y) = cl_op y) = (cl_op (x::'a::clattice_with_clop) \<le> cl_op y)"
  by (smt cl_op_class.clop_iso clop_ext clop_wtrans inf_sup_ord(4) le_iff_sup sup.absorb_iff1 sup_left_commute)

lemma cl_op_prop_var [iff]: "(cl_op (x \<squnion> cl_op y) = cl_op y) = (cl_op (x::'a::clattice_with_clop) \<le> cl_op y)"
  by (metis cl_op_prop clattice_with_clop_class.clop_idem_var)

instantiation cl_op_im :: (clattice_with_clop) complete_lattice
begin

lift_definition Inf_cl_op_im :: "'a cl_op_im set \<Rightarrow> 'a cl_op_im" is Inf
  by (simp add: Inf_closed_cl_op_var)

lift_definition Sup_cl_op_im :: "'a cl_op_im set \<Rightarrow> 'a cl_op_im" is "\<lambda>X. cl_op (\<Squnion>X)"
  by simp

lift_definition inf_cl_op_im :: "'a cl_op_im \<Rightarrow> 'a cl_op_im \<Rightarrow> 'a cl_op_im" is inf
  by (simp add: inf_closed_cl_op_var)

lift_definition sup_cl_op_im :: "'a cl_op_im \<Rightarrow> 'a cl_op_im \<Rightarrow> 'a cl_op_im" is "\<lambda>x y. cl_op (x \<squnion> y)"
  by simp

lift_definition less_eq_cl_op_im :: "'a cl_op_im \<Rightarrow> 'a cl_op_im \<Rightarrow> bool" is "(\<le>)".

lift_definition less_cl_op_im :: "'a cl_op_im \<Rightarrow> 'a cl_op_im \<Rightarrow> bool" is "(<)".

lift_definition bot_cl_op_im :: "'a cl_op_im" is "cl_op \<bottom>"
  by simp

lift_definition top_cl_op_im :: "'a cl_op_im" is "\<top>"
  by (simp add: clop_cl_op clop_closure clop_top)

instance
  apply (intro_classes; transfer)
                 apply (simp_all add: less_le_not_le Inf_lower Inf_greatest)
      apply (meson clop_cl_op clop_extensive_var dual_order.trans inf_sup_ord(3))
     apply (meson clop_cl_op clop_extensive_var dual_order.trans sup_ge2)
    apply (metis cl_op_class.clop_iso clop_cl_op clop_closure le_sup_iff)
   apply (meson Sup_upper clop_cl_op clop_extensive_var dual_order.trans)
  by (metis Sup_le_iff cl_op_class.clop_iso clop_cl_op clop_closure)

end

text \<open>This statement is perhaps less useful as it might seem, because it is difficult to make it cooperate with concrete closure operators,
which one would not generally like to define within a type class. Alternatively, a sublocale statement could perhaps be given. It would also
have been nice to prove this statement for Sup-lattices---this would have cut down the number of proof obligations significantly.
But this would require a tighter integration of these structures. A similar statement could have been proved for co-closure operators. But this would
not lead to new insights.\<close>

text \<open>Next I show that for every surjective Sup-preserving function between complete lattices there is a closure operator
such that the set of closed elements is isomorphic to the range of the surjection.\<close>

lemma surj_Sup_pres_id:
  fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual"
  assumes "surj f"
  and "Sup_pres f"
  shows "f \<circ> (radj f) = id"
proof-
  have "f \<stileturn> (radj f)"
    using Sup_pres_ladj assms(2) radj_adj by auto
  thus ?thesis
    using adj_sur_inv assms(1) by blast
qed

lemma surj_Sup_pres_inj:
  fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual"
  assumes "surj f"
  and "Sup_pres f"
  shows "inj (radj f)"
  by (metis assms comp_eq_dest_lhs id_apply injI surj_Sup_pres_id)

lemma surj_Sup_pres_inj_on:
  fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual"
  assumes "surj f"
  and "Sup_pres f"
  shows "inj_on f (range (radj f \<circ> f))"
  by (smt Sup_pres_ladj_aux adj_idem2 assms(2) comp_apply inj_on_def retraction_prop)

lemma surj_Sup_pres_bij_on:
  fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual"
  assumes "surj f"
  and "Sup_pres f"
  shows "bij_betw f (range (radj f \<circ> f)) UNIV"
  unfolding bij_betw_def
  apply safe
    apply (simp add: assms(1) assms(2) surj_Sup_pres_inj_on cong del: image_cong_simp)
   apply auto
  apply (metis (mono_tags) UNIV_I assms(1) assms(2) comp_apply id_apply image_image surj_Sup_pres_id surj_def)
  done

text \<open>Thus the restriction of $f$ to the set of closed elements is indeed a bijection. The final fact
shows that it preserves Sups of closed elements, and hence is an isomorphism of complete lattices.\<close>

lemma surj_Sup_pres_iso:
  fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual"
  assumes "surj f"
  and "Sup_pres f"
  shows "f ((radj f \<circ> f) (\<Squnion>X)) = (\<Squnion>x \<in> X. f x)"
  by (metis assms(1) assms(2) comp_def pointfree_idE surj_Sup_pres_id)

subsection \<open>A Quick Example: Dedekind-MacNeille Completions\<close>

text \<open>I only outline the basic construction. Additional facts about join density, and that the completion yields
the least complete lattice that contains all Sups and Infs of the underlying posets, are left for future consideration.\<close>

abbreviation "dm \<equiv> lb_set \<circ> ub_set"

lemma up_set_prop: "(X::'a::preorder set) \<noteq> {} \<Longrightarrow> ub_set X = \<Inter>{\<up>x |x. x \<in> X}"
  unfolding ub_set_def upset_def upset_set_def by (safe, simp_all, blast)

lemma lb_set_prop: "(X::'a::preorder set) \<noteq> {} \<Longrightarrow> lb_set X = \<Inter>{\<down>x |x. x \<in> X}"
  unfolding lb_set_def downset_def downset_set_def by (safe, simp_all, blast)

lemma dm_downset_var: "dm {x} = \<down>(x::'a::preorder)"
  unfolding lb_set_def ub_set_def downset_def downset_set_def
  by (clarsimp, meson order_refl order_trans)

lemma dm_downset: "dm \<circ> \<eta> = (\<down>::'a::preorder \<Rightarrow> 'a set)"
  using dm_downset_var fun.map_cong by fastforce

lemma dm_inj: "inj ((dm::'a::order set \<Rightarrow> 'a set) \<circ> \<eta>)"
  by (simp add: dm_downset downset_inj)

lemma "clop (lb_set \<circ> ub_set)"
  unfolding clop_def lb_set_def ub_set_def
  apply safe
  unfolding le_fun_def comp_def id_def mono_def
  by auto

end


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

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

datatype Nat = Z | S "Nat"

fun len :: "'a list => Nat" where
  "len (nil2) = Z"
| "len (cons2 y xs) = S (len xs)"

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

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

fun sort :: "Nat list => Nat list" where
  "sort (nil2) = nil2"
| "sort (cons2 y xs) = insort y (sort xs)"

theorem property0 :
  "((len (sort xs)) = (len xs))"
  oops

end


theory Nat_Demo
imports Main
begin

fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"add 0 n = n" |
"add (Suc m) n = Suc(add m n)"

(* Automatic proof. This is what we will focus on first! *)
lemma "add m 0 = m"
  apply(induction m)
  apply(auto)
  done

(* Completely manual proof. You do not need to understand
  all the syntax details etc right now!     *)
thm add.simps(1)
thm refl

lemma "add m 0 = m"
  apply(induction m)
  (* Base case *)
   apply (subst add.simps(1)) (* Rewrite with first equation of add *)
   apply (rule refl) (* Use reflexivity: Syntactically equal terms are actually equal! *)

  (* Induction step *)
  subgoal premises prems for m
    apply (subst add.simps(2)) (* Rewrite with second equation of add *)
    thm prems  (* Diagnostic command to display induction hypothesis (assumption): *)
    apply (subst prems) (* Rewrite with I.H. *)
    apply (rule refl) (* Reflexivity again *)
    done
  done

fun gs :: "nat \<Rightarrow> nat" where
  "gs 0 = 0"
| "gs (Suc n) = Suc n + gs n"

lemma "gs n = n*(n+1) div 2"
  apply (induction n)
  apply auto
  done

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_03
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

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

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 z xs) = S (length xs)"

fun t2 :: "Nat => Nat => Nat" where
  "t2 (Z) z = z"
| "t2 (S z2) z = S (t2 z2 z)"

(* This apply-style proof script repeats the proof of "t2 n m = t2 m n" twice,
 * whereas Kei's original proof script caches "t2 n m = t2 m n". *)
theorem property0 :
  "((length (x y z)) = (t2 (length z) (length y)))"
  apply(induct y)
   apply simp
   apply(subgoal_tac "\<And>n m. t2 n m = t2 m n")(*(meta-)universal quantifiers are necessary.*)
    apply fastforce
   apply(induct_tac n)
    apply simp
    apply(induct_tac m)
     apply fastforce+
   apply clarsimp
   apply(case_tac m)
    apply fastforce+
   apply(thin_tac "m = S x2")
   apply(thin_tac "t2 x m = t2 m x")
   apply(induct_tac m)
    apply fastforce+
  apply(case_tac z)
   apply fastforce
  apply(subgoal_tac "\<And>n m. t2 n m = t2 m n")(*(meta-)universal quantifiers are necessary.*)
   apply fastforce
  apply(thin_tac "TIP_prop_03.length (x y z) = t2 (TIP_prop_03.length z) (TIP_prop_03.length y)")
  apply(thin_tac "z = cons2 x21 x22")
  apply(induct_tac n)
   apply simp
   apply(induct_tac m)
    apply fastforce+
  apply clarsimp
  apply(case_tac m)
   apply fastforce+
  apply(thin_tac "m = S x2")
  apply(thin_tac "t2 x m = t2 m x")
  apply(induct_tac m)
   apply fastforce+
  done

lemma swap_t2_aux_1:
  "(\<And>m. t2 n m = t2 m n) \<Longrightarrow> t2 (S n) m = t2 m (S n)"
  apply(induct m)
   apply fastforce+
  done

lemma swap_t2_aux_0:
  "m = t2 m Z"
  apply(induct m)
   apply fastforce+
  done

lemma swap_t2:(*commutative property*)
  "t2 n m = t2 m n"
  apply(induct n arbitrary: m)
   apply clarsimp
   apply(rule swap_t2_aux_0)(*just a nested induction*)
  apply(rule swap_t2_aux_1)(*just a nested induction*)
  apply assumption (*to handle induction hypotheses*)
  done

theorem property:
  "((length (x y z)) = (t2 (length z) (length y)))"
  apply(induct y)
   apply clarsimp
  using swap_t2 apply fastforce (*sledgehammer*)
  apply(cases z)
   apply fastforce
  using swap_t2 apply fastforce (*sledgehammer*)
  done

end


(*  Author:     Tobias Nipkow, TU München

A theory of types extended with a greatest and a least element.
Oriented towards numeric types, hence "\<infinity>" and "-\<infinity>".
*)

theory Extended
  imports Simps_Case_Conv
begin

datatype 'a extended = Fin 'a | Pinf ("\<infinity>") | Minf ("-\<infinity>")

instantiation extended :: (order)order
begin

fun less_eq_extended :: "'a extended \<Rightarrow> 'a extended \<Rightarrow> bool" where
"Fin x \<le> Fin y = (x \<le> y)" |
"_     \<le> Pinf  = True" |
"Minf  \<le> _     = True" |
"(_::'a extended) \<le> _     = False"

case_of_simps less_eq_extended_case: less_eq_extended.simps

definition less_extended :: "'a extended \<Rightarrow> 'a extended \<Rightarrow> bool" where
"((x::'a extended) < y) = (x \<le> y \<and> \<not> y \<le> x)"

instance
  by intro_classes (auto simp: less_extended_def less_eq_extended_case split: extended.splits)

end

instance extended :: (linorder)linorder
  by intro_classes (auto simp: less_eq_extended_case split:extended.splits)

lemma Minf_le[simp]: "Minf \<le> y"
by(cases y) auto
lemma le_Pinf[simp]: "x \<le> Pinf"
by(cases x) auto
lemma le_Minf[simp]: "x \<le> Minf \<longleftrightarrow> x = Minf"
by(cases x) auto
lemma Pinf_le[simp]: "Pinf \<le> x \<longleftrightarrow> x = Pinf"
by(cases x) auto

lemma less_extended_simps[simp]:
  "Fin x < Fin y = (x < y)"
  "Fin x < Pinf  = True"
  "Fin x < Minf  = False"
  "Pinf < h      = False"
  "Minf < Fin x  = True"
  "Minf < Pinf   = True"
  "l    < Minf   = False"
by (auto simp add: less_extended_def)

lemma min_extended_simps[simp]:
  "min (Fin x) (Fin y) = Fin(min x y)"
  "min xx      Pinf    = xx"
  "min xx      Minf    = Minf"
  "min Pinf    yy      = yy"
  "min Minf    yy      = Minf"
by (auto simp add: min_def)

lemma max_extended_simps[simp]:
  "max (Fin x) (Fin y) = Fin(max x y)"
  "max xx      Pinf    = Pinf"
  "max xx      Minf    = xx"
  "max Pinf    yy      = Pinf"
  "max Minf    yy      = yy"
by (auto simp add: max_def)

instantiation extended :: (zero)zero
begin
definition "0 = Fin(0::'a)"
instance ..
end

declare zero_extended_def[symmetric, code_post]

instantiation extended :: (one)one
begin
definition "1 = Fin(1::'a)"
instance ..
end

declare one_extended_def[symmetric, code_post]

instantiation extended :: (plus)plus
begin

text \<open>The following definition of of addition is totalized
to make it asociative and commutative. Normally the sum of plus and minus infinity is undefined.\<close>

fun plus_extended where
"Fin x + Fin y = Fin(x+y)" |
"Fin x + Pinf  = Pinf" |
"Pinf  + Fin x = Pinf" |
"Pinf  + Pinf  = Pinf" |
"Minf  + Fin y = Minf" |
"Fin x + Minf  = Minf" |
"Minf  + Minf  = Minf" |
"Minf  + Pinf  = Pinf" |
"Pinf  + Minf  = Pinf"

case_of_simps plus_case: plus_extended.simps

instance ..

end

instance extended :: (ab_semigroup_add)ab_semigroup_add
  by intro_classes (simp_all add: ac_simps plus_case split: extended.splits)

instance extended :: (ordered_ab_semigroup_add)ordered_ab_semigroup_add
  by intro_classes (auto simp: add_left_mono plus_case split: extended.splits)

instance extended :: (comm_monoid_add)comm_monoid_add
proof
  fix x :: "'a extended" show "0 + x = x" unfolding zero_extended_def by(cases x)auto
qed

instantiation extended :: (uminus)uminus
begin

fun uminus_extended where
"- (Fin x) = Fin (- x)" |
"- Pinf    = Minf" |
"- Minf    = Pinf"

instance ..

end

instantiation extended :: (ab_group_add)minus
begin
definition "x - y = x + -(y::'a extended)"
instance ..
end

lemma minus_extended_simps[simp]:
  "Fin x - Fin y = Fin(x - y)"
  "Fin x - Pinf  = Minf"
  "Fin x - Minf  = Pinf"
  "Pinf  - Fin y = Pinf"
  "Pinf  - Minf  = Pinf"
  "Minf  - Fin y = Minf"
  "Minf  - Pinf  = Minf"
  "Minf  - Minf  = Pinf"
  "Pinf  - Pinf  = Pinf"
by (simp_all add: minus_extended_def)

text\<open>Numerals:\<close>

instance extended :: ("{ab_semigroup_add,one}")numeral ..

lemma Fin_numeral[code_post]: "Fin(numeral w) = numeral w"
  apply (induct w rule: num_induct)
  apply (simp only: numeral_One one_extended_def)
  apply (simp only: numeral_inc one_extended_def plus_extended.simps(1)[symmetric])
  done

lemma Fin_neg_numeral[code_post]: "Fin (- numeral w) = - numeral w"
by (simp only: Fin_numeral uminus_extended.simps[symmetric])

instantiation extended :: (lattice)bounded_lattice
begin

definition "bot = Minf"
definition "top = Pinf"

fun inf_extended :: "'a extended \<Rightarrow> 'a extended \<Rightarrow> 'a extended" where
"inf_extended (Fin i) (Fin j) = Fin (inf i j)" |
"inf_extended a Minf = Minf" |
"inf_extended Minf a = Minf" |
"inf_extended Pinf a = a" |
"inf_extended a Pinf = a"

fun sup_extended :: "'a extended \<Rightarrow> 'a extended \<Rightarrow> 'a extended" where
"sup_extended (Fin i) (Fin j) = Fin (sup i j)" |
"sup_extended a Pinf = Pinf" |
"sup_extended Pinf a = Pinf" |
"sup_extended Minf a = a" |
"sup_extended a Minf = a"

case_of_simps inf_extended_case: inf_extended.simps
case_of_simps sup_extended_case: sup_extended.simps

instance
  by (intro_classes) (auto simp: inf_extended_case sup_extended_case less_eq_extended_case
    bot_extended_def top_extended_def split: extended.splits)
end

end


theory styleShow
  imports Main
begin
(* Cantor's Theorem *)
lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
assume 0: "surj f"
  from 0 have 1: "\<forall>A. \<exists>a. A = f a" by(simp add: surj_def)
  from 1 have 2: "\<exists>a. {x. x \<notin> f x} = f a" by blast
  from 2 show "False" by blast
qed

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
assume "surj f"
  from this have "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  from this show "False" by blast
qed

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
assume "surj f"
  hence "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  thus "False" by blast
qed

(*Exercise 5.1*)
lemma
  assumes T: "\<forall>x y .T x y \<or> T y x"
and A:"\<forall> x y .A x y \<and> A y x \<longrightarrow> x = y"
and TA: "\<forall> x y . T x y \<longrightarrow> A x y"
and "A x y"
shows "T x y"
  using A T TA assms(4) by blast

(*
lemma
  fixes f :: "'a \<Rightarrow> 'a set"
  assumes s: "surj f"
  shows "False"
*)

end


(*  Title:      HOL/Isar_Examples/Group_Context.thy
    Author:     Makarius
*)

section \<open>Some algebraic identities derived from group axioms -- theory context version\<close>

theory Group_Context
imports Main
begin

text \<open>hypothetical group axiomatization\<close>

context
  fixes prod :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixl "**" 70)
    and one :: "'a"
    and inverse :: "'a \<Rightarrow> 'a"
  assumes assoc: "(x ** y) ** z = x ** (y ** z)"
    and left_one: "one ** x = x"
    and left_inverse: "inverse x ** x = one"
begin

text \<open>some consequences\<close>

lemma right_inverse: "x ** inverse x = one"
proof -
  have "x ** inverse x = one ** (x ** inverse x)"
    by (simp only: left_one)
  also have "\<dots> = one ** x ** inverse x"
    by (simp only: assoc)
  also have "\<dots> = inverse (inverse x) ** inverse x ** x ** inverse x"
    by (simp only: left_inverse)
  also have "\<dots> = inverse (inverse x) ** (inverse x ** x) ** inverse x"
    by (simp only: assoc)
  also have "\<dots> = inverse (inverse x) ** one ** inverse x"
    by (simp only: left_inverse)
  also have "\<dots> = inverse (inverse x) ** (one ** inverse x)"
    by (simp only: assoc)
  also have "\<dots> = inverse (inverse x) ** inverse x"
    by (simp only: left_one)
  also have "\<dots> = one"
    by (simp only: left_inverse)
  finally show "x ** inverse x = one" .
qed

lemma right_one: "x ** one = x"
proof -
  have "x ** one = x ** (inverse x ** x)"
    by (simp only: left_inverse)
  also have "\<dots> = x ** inverse x ** x"
    by (simp only: assoc)
  also have "\<dots> = one ** x"
    by (simp only: right_inverse)
  also have "\<dots> = x"
    by (simp only: left_one)
  finally show "x ** one = x" .
qed

lemma one_equality:
  assumes eq: "e ** x = x"
  shows "one = e"
proof -
  have "one = x ** inverse x"
    by (simp only: right_inverse)
  also have "\<dots> = (e ** x) ** inverse x"
    by (simp only: eq)
  also have "\<dots> = e ** (x ** inverse x)"
    by (simp only: assoc)
  also have "\<dots> = e ** one"
    by (simp only: right_inverse)
  also have "\<dots> = e"
    by (simp only: right_one)
  finally show "one = e" .
qed

lemma inverse_equality:
  assumes eq: "x' ** x = one"
  shows "inverse x = x'"
proof -
  have "inverse x = one ** inverse x"
    by (simp only: left_one)
  also have "\<dots> = (x' ** x) ** inverse x"
    by (simp only: eq)
  also have "\<dots> = x' ** (x ** inverse x)"
    by (simp only: assoc)
  also have "\<dots> = x' ** one"
    by (simp only: right_inverse)
  also have "\<dots> = x'"
    by (simp only: right_one)
  finally show "inverse x = x'" .
qed

end

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section "Distinct Proposition"

theory Distinct_Prop  (* part of non-AFP Word_Lib *)
imports
  "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


(*  Title:       Category theory using Isar and Locales
    Author:      Greg O'Keefe, June, July, August 2003
    License: LGPL
*)

section \<open>Categories\<close>

theory Cat
imports "HOL-Library.FuncSet"
begin

subsection \<open>Definitions\<close>

record ('o, 'a) category =
  ob :: "'o set" ("Ob\<index>"  70)
  ar :: "'a set" ("Ar\<index>"  70)
  dom :: "'a \<Rightarrow> 'o" ("Dom\<index> _" [81] 70)
  cod :: "'a \<Rightarrow> 'o" ("Cod\<index> _" [81] 70)
  id :: "'o \<Rightarrow> 'a" ("Id\<index> _" [81] 80)
  comp :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixl "\<bullet>\<index>" 60)

definition
  hom :: "[('o,'a,'m) category_scheme, 'o, 'o] \<Rightarrow> 'a set"
    ("Hom\<index> _ _" [81,81] 80) where
  "hom CC A B = { f. f\<in>ar CC & dom CC f = A & cod CC f = B }"

locale category =
  fixes CC (structure)
  assumes dom_object [intro]:
  "f \<in> Ar \<Longrightarrow> Dom f \<in> Ob"
  and cod_object [intro]:
  "f \<in> Ar \<Longrightarrow> Cod f \<in> Ob"
  and id_left [simp]:
  "f \<in> Ar \<Longrightarrow> Id (Cod f) \<bullet> f = f"
  and id_right [simp]:
  "f \<in> Ar \<Longrightarrow> f \<bullet> Id (Dom f) = f"
  and id_hom [intro]:
  "A \<in> Ob \<Longrightarrow> Id A \<in> Hom A A"
  and comp_types [intro]:
  "\<And>A B C. (comp CC) : (Hom B C) \<rightarrow> (Hom A B) \<rightarrow> (Hom A C)"
  and comp_associative [simp]:
  "f \<in> Ar \<Longrightarrow> g \<in> Ar \<Longrightarrow> h \<in> Ar
  \<Longrightarrow> Cod h = Dom g \<Longrightarrow> Cod g = Dom f
  \<Longrightarrow> f \<bullet> (g \<bullet> h) = (f \<bullet> g) \<bullet> h"

subsection \<open>Lemmas\<close>

lemma (in category) homI:
  assumes "f \<in> Ar" and "Dom f = A" and "Cod f = B"
  shows "f \<in> Hom A B"
  using assms by (auto simp add: hom_def)

lemma (in category) id_dom_cod:
  assumes "A \<in> Ob"
  shows "Dom (Id A) = A" and "Cod (Id A) = A"
proof-
  from \<open>A \<in> Ob\<close> have 1: "Id A \<in> Hom A A" ..
  then show "Dom (Id A) = A" and "Cod (Id A) = A"
    by (simp_all add: hom_def)
qed

lemma (in category) compI [intro]:
  assumes f: "f \<in> Ar" and g: "g \<in> Ar" and "Cod f = Dom g"
  shows "g \<bullet> f \<in> Ar"
  and "Dom (g \<bullet> f) = Dom f"
  and "Cod (g \<bullet> f) = Cod g"
proof-
  have "f \<in> Hom (Dom f) (Cod f)" using f by (simp add: hom_def)
  with \<open>Cod f = Dom g\<close> have f_homset: "f \<in> Hom (Dom f) (Dom g)" by simp
  have g_homset: "g \<in> Hom (Dom g) (Cod g)" using g by (simp add: hom_def)
  have "(\<bullet>) : Hom (Dom g) (Cod g) \<rightarrow> Hom (Dom f) (Dom g) \<rightarrow> Hom (Dom f) (Cod g)" ..
  from this and g_homset
  have "(\<bullet>) g \<in> Hom (Dom f) (Dom g) \<rightarrow> Hom (Dom f) (Cod g)"
    by (rule funcset_mem)
  from this and f_homset
  have gf_homset: "g \<bullet> f \<in> Hom (Dom f) (Cod g)"
    by (rule funcset_mem)
  thus "g \<bullet> f \<in> Ar"
    by (simp add: hom_def)
  from gf_homset show "Dom (g \<bullet> f) = Dom f" and "Cod (g \<bullet> f) = Cod g"
    by (simp_all add: hom_def)
qed

end


section \<open>Bubblesort\<close>

theory Bubblesort
imports "HOL-Library.Multiset"
begin

text\<open>This is \emph{a} version of bubblesort.\<close>

context linorder
begin

fun bubble_min where
  "bubble_min [] = []" |
  "bubble_min [x] = [x]" |
  "bubble_min (x#xs) =
    (case bubble_min xs of y#ys
        \<Rightarrow> if x>y then y#x#ys else x#y#ys)"

lemma size_bubble_min: "size(bubble_min xs) = size xs"
by(induction xs rule: bubble_min.induct) (auto split: list.split)

lemma bubble_min_eq_Nil_iff[simp]: "bubble_min xs = [] \<longleftrightarrow> xs = []"
by (metis length_0_conv size_bubble_min)

lemma bubble_minD_size: "bubble_min (xs) = ys \<Longrightarrow> size xs = size ys"
by(auto simp: size_bubble_min)

function (sequential) bubblesort where
"bubblesort []  = []" |
"bubblesort [x] = [x]" |
"bubblesort xs  = (case bubble_min xs of y#ys \<Rightarrow> y # bubblesort ys)"
by pat_completeness auto

termination bubblesort
apply(relation "measure size")
apply simp
apply (auto simp: size_bubble_min dest!: bubble_minD_size
        split: list.splits if_splits)
done

value "bubblesort [3::nat,5,7,39,15,1,2,20]"

lemma mset_bubble_min: "mset (bubble_min xs) = mset xs"
apply(induction xs rule: bubble_min.induct)
  apply simp
 apply simp
apply (auto split: list.split)
done

lemma bubble_minD_mset:
  "bubble_min (xs) = ys \<Longrightarrow> mset xs = mset ys"
by(auto simp: mset_bubble_min)

lemma mset_bubblesort:
  "mset (bubblesort xs) = mset xs"
apply(induction xs rule: bubblesort.induct)
  apply simp
 apply simp
by(auto split: list.splits if_splits dest: bubble_minD_mset)

lemma set_bubblesort: "set (bubblesort xs) = set xs"
by(rule mset_bubblesort[THEN mset_eq_setD])

lemma bubble_min_min: "bubble_min xs = y#ys \<Longrightarrow> z \<in> set ys \<Longrightarrow> y \<le> z"
apply(induction xs arbitrary: y ys z rule: bubble_min.induct)
  apply simp
 apply simp
apply (fastforce split: list.splits if_splits dest!: sym[of "a#b" for a b])
done

lemma sorted_bubblesort: "sorted(bubblesort xs)"
apply(induction xs rule: bubblesort.induct)
  apply simp
 apply simp
apply (fastforce simp: set_bubblesort split: list.split if_splits dest: bubble_min_min)
done

end

end


(*  Title:      HOL/UNITY/ListOrder.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge

Lists are partially ordered by Charpentier's Generalized Prefix Relation
   (xs,ys) : genPrefix(r)
     if ys = xs' @ zs where length xs = length xs'
     and corresponding elements of xs, xs' are pairwise related by r

Also overloads <= and < for lists!
*)

section \<open>The Prefix Ordering on Lists\<close>

theory ListOrder
imports Main
begin

inductive_set
  genPrefix :: "('a * 'a)set => ('a list * 'a list)set"
  for r :: "('a * 'a)set"
 where
   Nil:     "([],[]) \<in> genPrefix(r)"

 | prepend: "[| (xs,ys) \<in> genPrefix(r);  (x,y) \<in> r |] ==>
             (x#xs, y#ys) \<in> genPrefix(r)"

 | append:  "(xs,ys) \<in> genPrefix(r) ==> (xs, ys@zs) \<in> genPrefix(r)"

instantiation list :: (type) ord
begin

definition
  prefix_def:        "xs <= zs \<longleftrightarrow>  (xs, zs) \<in> genPrefix Id"

definition
  strict_prefix_def: "xs < zs  \<longleftrightarrow>  xs \<le> zs \<and> \<not> zs \<le> (xs :: 'a list)"

instance ..

(*Constants for the <= and >= relations, used below in translations*)

end

definition Le :: "(nat*nat) set" where
    "Le == {(x,y). x <= y}"

definition  Ge :: "(nat*nat) set" where
    "Ge == {(x,y). y <= x}"

abbreviation
  pfixLe :: "[nat list, nat list] => bool"  (infixl "pfixLe" 50)  where
  "xs pfixLe ys == (xs,ys) \<in> genPrefix Le"

abbreviation
  pfixGe :: "[nat list, nat list] => bool"  (infixl "pfixGe" 50)  where
  "xs pfixGe ys == (xs,ys) \<in> genPrefix Ge"

subsection\<open>preliminary lemmas\<close>

lemma Nil_genPrefix [iff]: "([], xs) \<in> genPrefix r"
by (cut_tac genPrefix.Nil [THEN genPrefix.append], auto)

lemma genPrefix_length_le: "(xs,ys) \<in> genPrefix r \<Longrightarrow> length xs <= length ys"
by (erule genPrefix.induct, auto)

lemma cdlemma:
     "[| (xs', ys') \<in> genPrefix r |]
      ==> (\<forall>x xs. xs' = x#xs \<longrightarrow> (\<exists>y ys. ys' = y#ys & (x,y) \<in> r & (xs, ys) \<in> genPrefix r))"
apply (erule genPrefix.induct, blast, blast)
apply (force intro: genPrefix.append)
done

(*As usual converting it to an elimination rule is tiresome*)
lemma cons_genPrefixE [elim!]:
     "[| (x#xs, zs) \<in> genPrefix r;
         !!y ys. [| zs = y#ys;  (x,y) \<in> r;  (xs, ys) \<in> genPrefix r |] ==> P
      |] ==> P"
by (drule cdlemma, simp, blast)

lemma Cons_genPrefix_Cons [iff]:
     "((x#xs,y#ys) \<in> genPrefix r) = ((x,y) \<in> r \<and> (xs,ys) \<in> genPrefix r)"
by (blast intro: genPrefix.prepend)

subsection\<open>genPrefix is a partial order\<close>

lemma refl_genPrefix: "refl r ==> refl (genPrefix r)"
apply (unfold refl_on_def, auto)
apply (induct_tac "x")
prefer 2 apply (blast intro: genPrefix.prepend)
apply (blast intro: genPrefix.Nil)
done

lemma genPrefix_refl [simp]: "refl r \<Longrightarrow> (l,l) \<in> genPrefix r"
by (erule refl_onD [OF refl_genPrefix UNIV_I])

lemma genPrefix_mono: "r<=s ==> genPrefix r <= genPrefix s"
apply clarify
apply (erule genPrefix.induct)
apply (auto intro: genPrefix.append)
done

(** Transitivity **)

(*A lemma for proving genPrefix_trans_O*)
lemma append_genPrefix:
     "(xs @ ys, zs) \<in> genPrefix r \<Longrightarrow> (xs, zs) \<in> genPrefix r"
  by (induct xs arbitrary: zs) auto

(*Lemma proving transitivity and more*)
lemma genPrefix_trans_O:
  assumes "(x, y) \<in> genPrefix r"
  shows "\<And>z. (y, z) \<in> genPrefix s \<Longrightarrow> (x, z) \<in> genPrefix (r O s)"
  apply (atomize (full))
  using assms
  apply induct
    apply blast
   apply (blast intro: genPrefix.prepend)
  apply (blast dest: append_genPrefix)
  done

lemma genPrefix_trans:
  "(x, y) \<in> genPrefix r \<Longrightarrow> (y, z) \<in> genPrefix r \<Longrightarrow> trans r
    \<Longrightarrow> (x, z) \<in> genPrefix r"
  apply (rule trans_O_subset [THEN genPrefix_mono, THEN subsetD])
   apply assumption
  apply (blast intro: genPrefix_trans_O)
  done

lemma prefix_genPrefix_trans:
  "[| x<=y;  (y,z) \<in> genPrefix r |] ==> (x, z) \<in> genPrefix r"
apply (unfold prefix_def)
apply (drule genPrefix_trans_O, assumption)
apply simp
done

lemma genPrefix_prefix_trans:
  "[| (x,y) \<in> genPrefix r;  y<=z |] ==> (x,z) \<in> genPrefix r"
apply (unfold prefix_def)
apply (drule genPrefix_trans_O, assumption)
apply simp
done

lemma trans_genPrefix: "trans r ==> trans (genPrefix r)"
by (blast intro: transI genPrefix_trans)

(** Antisymmetry **)

lemma genPrefix_antisym:
  assumes 1: "(xs, ys) \<in> genPrefix r"
    and 2: "antisym r"
    and 3: "(ys, xs) \<in> genPrefix r"
  shows "xs = ys"
  using 1 3
proof induct
  case Nil
  then show ?case by blast
next
  case prepend
  then show ?case using 2 by (simp add: antisym_def)
next
  case (append xs ys zs)
  then show ?case
    apply -
    apply (subgoal_tac "length zs = 0", force)
    apply (drule genPrefix_length_le)+
    apply (simp del: length_0_conv)
    done
qed

lemma antisym_genPrefix: "antisym r ==> antisym (genPrefix r)"
  by (blast intro: antisymI genPrefix_antisym)

subsection\<open>recursion equations\<close>

lemma genPrefix_Nil [simp]: "((xs, []) \<in> genPrefix r) = (xs = [])"
  by (induct xs) auto

lemma same_genPrefix_genPrefix [simp]:
    "refl r \<Longrightarrow> ((xs@ys, xs@zs) \<in> genPrefix r) = ((ys,zs) \<in> genPrefix r)"
  by (induct xs) (simp_all add: refl_on_def)

lemma genPrefix_Cons:
     "((xs, y#ys) \<in> genPrefix r) =
      (xs=[] | (\<exists>z zs. xs=z#zs & (z,y) \<in> r & (zs,ys) \<in> genPrefix r))"
  by (cases xs) auto

lemma genPrefix_take_append:
     "[| refl r;  (xs,ys) \<in> genPrefix r |]
      ==>  (xs@zs, take (length xs) ys @ zs) \<in> genPrefix r"
apply (erule genPrefix.induct)
apply (frule_tac [3] genPrefix_length_le)
apply (simp_all (no_asm_simp) add: diff_is_0_eq [THEN iffD2])
done

lemma genPrefix_append_both:
     "[| refl r;  (xs,ys) \<in> genPrefix r;  length xs = length ys |]
      ==>  (xs@zs, ys @ zs) \<in> genPrefix r"
apply (drule genPrefix_take_append, assumption)
apply simp
done

(*NOT suitable for rewriting since [y] has the form y#ys*)
lemma append_cons_eq: "xs @ y # ys = (xs @ [y]) @ ys"
by auto

lemma aolemma:
     "[| (xs,ys) \<in> genPrefix r;  refl r |]
      ==> length xs < length ys \<longrightarrow> (xs @ [ys ! length xs], ys) \<in> genPrefix r"
apply (erule genPrefix.induct)
  apply blast
 apply simp
txt\<open>Append case is hardest\<close>
apply simp
apply (frule genPrefix_length_le [THEN le_imp_less_or_eq])
apply (erule disjE)
apply (simp_all (no_asm_simp) add: neq_Nil_conv nth_append)
apply (blast intro: genPrefix.append, auto)
apply (subst append_cons_eq, fast intro: genPrefix_append_both genPrefix.append)
done

lemma append_one_genPrefix:
     "[| (xs,ys) \<in> genPrefix r;  length xs < length ys;  refl r |]
      ==> (xs @ [ys ! length xs], ys) \<in> genPrefix r"
by (blast intro: aolemma [THEN mp])

(** Proving the equivalence with Charpentier's definition **)

lemma genPrefix_imp_nth:
    "i < length xs \<Longrightarrow> (xs, ys) \<in> genPrefix r \<Longrightarrow> (xs ! i, ys ! i) \<in> r"
  apply (induct xs arbitrary: i ys)
   apply auto
  apply (case_tac i)
   apply auto
  done

lemma nth_imp_genPrefix:
  "length xs <= length ys \<Longrightarrow>
     (\<forall>i. i < length xs \<longrightarrow> (xs ! i, ys ! i) \<in> r) \<Longrightarrow>
     (xs, ys) \<in> genPrefix r"
  apply (induct xs arbitrary: ys)
   apply (simp_all add: less_Suc_eq_0_disj all_conj_distrib)
  apply (case_tac ys)
   apply (force+)
  done

lemma genPrefix_iff_nth:
     "((xs,ys) \<in> genPrefix r) =
      (length xs <= length ys & (\<forall>i. i < length xs \<longrightarrow> (xs!i, ys!i) \<in> r))"
apply (blast intro: genPrefix_length_le genPrefix_imp_nth nth_imp_genPrefix)
done

subsection\<open>The type of lists is partially ordered\<close>

declare refl_Id [iff]
        antisym_Id [iff]
        trans_Id [iff]

lemma prefix_refl [iff]: "xs <= (xs::'a list)"
by (simp add: prefix_def)

lemma prefix_trans: "!!xs::'a list. [| xs <= ys; ys <= zs |] ==> xs <= zs"
apply (unfold prefix_def)
apply (blast intro: genPrefix_trans)
done

lemma prefix_antisym: "!!xs::'a list. [| xs <= ys; ys <= xs |] ==> xs = ys"
apply (unfold prefix_def)
apply (blast intro: genPrefix_antisym)
done

lemma prefix_less_le_not_le: "!!xs::'a list. (xs < zs) = (xs <= zs & \<not> zs \<le> xs)"
by (unfold strict_prefix_def, auto)

instance list :: (type) order
  by (intro_classes,
      (assumption | rule prefix_refl prefix_trans prefix_antisym
                     prefix_less_le_not_le)+)

(*Monotonicity of "set" operator WRT prefix*)
lemma set_mono: "xs <= ys ==> set xs <= set ys"
apply (unfold prefix_def)
apply (erule genPrefix.induct, auto)
done

(** recursion equations **)

lemma Nil_prefix [iff]: "[] <= xs"
by (simp add: prefix_def)

lemma prefix_Nil [simp]: "(xs <= []) = (xs = [])"
by (simp add: prefix_def)

lemma Cons_prefix_Cons [simp]: "(x#xs <= y#ys) = (x=y & xs<=ys)"
by (simp add: prefix_def)

lemma same_prefix_prefix [simp]: "(xs@ys <= xs@zs) = (ys <= zs)"
by (simp add: prefix_def)

lemma append_prefix [iff]: "(xs@ys <= xs) = (ys <= [])"
by (insert same_prefix_prefix [of xs ys "[]"], simp)

lemma prefix_appendI [simp]: "xs <= ys ==> xs <= ys@zs"
apply (unfold prefix_def)
apply (erule genPrefix.append)
done

lemma prefix_Cons:
   "(xs <= y#ys) = (xs=[] | (\<exists>zs. xs=y#zs \<and> zs <= ys))"
by (simp add: prefix_def genPrefix_Cons)

lemma append_one_prefix:
  "[| xs <= ys; length xs < length ys |] ==> xs @ [ys ! length xs] <= ys"
apply (unfold prefix_def)
apply (simp add: append_one_genPrefix)
done

lemma prefix_length_le: "xs <= ys ==> length xs <= length ys"
apply (unfold prefix_def)
apply (erule genPrefix_length_le)
done

lemma splemma: "xs<=ys ==> xs~=ys --> length xs < length ys"
apply (unfold prefix_def)
apply (erule genPrefix.induct, auto)
done

lemma strict_prefix_length_less: "xs < ys ==> length xs < length ys"
apply (unfold strict_prefix_def)
apply (blast intro: splemma [THEN mp])
done

lemma mono_length: "mono length"
by (blast intro: monoI prefix_length_le)

(*Equivalence to the definition used in Lex/Prefix.thy*)
lemma prefix_iff: "(xs <= zs) = (\<exists>ys. zs = xs@ys)"
apply (unfold prefix_def)
apply (auto simp add: genPrefix_iff_nth nth_append)
apply (rule_tac x = "drop (length xs) zs" in exI)
apply (rule nth_equalityI)
apply (simp_all (no_asm_simp) add: nth_append)
done

lemma prefix_snoc [simp]: "(xs <= ys@[y]) = (xs = ys@[y] | xs <= ys)"
apply (simp add: prefix_iff)
apply (rule iffI)
 apply (erule exE)
 apply (rename_tac "zs")
 apply (rule_tac xs = zs in rev_exhaust)
  apply simp
 apply clarify
 apply (simp del: append_assoc add: append_assoc [symmetric], force)
done

lemma prefix_append_iff:
     "(xs <= ys@zs) = (xs <= ys | (\<exists>us. xs = ys@us & us <= zs))"
apply (rule_tac xs = zs in rev_induct)
 apply force
apply (simp del: append_assoc add: append_assoc [symmetric], force)
done

(*Although the prefix ordering is not linear, the prefixes of a list
  are linearly ordered.*)
lemma common_prefix_linear:
  fixes xs ys zs :: "'a list"
  shows "xs <= zs \<Longrightarrow> ys <= zs \<Longrightarrow> xs <= ys | ys <= xs"
  by (induct zs rule: rev_induct) auto

subsection\<open>pfixLe, pfixGe: properties inherited from the translations\<close>

(** pfixLe **)

lemma refl_Le [iff]: "refl Le"
by (unfold refl_on_def Le_def, auto)

lemma antisym_Le [iff]: "antisym Le"
by (unfold antisym_def Le_def, auto)

lemma trans_Le [iff]: "trans Le"
by (unfold trans_def Le_def, auto)

lemma pfixLe_refl [iff]: "x pfixLe x"
by simp

lemma pfixLe_trans: "[| x pfixLe y; y pfixLe z |] ==> x pfixLe z"
by (blast intro: genPrefix_trans)

lemma pfixLe_antisym: "[| x pfixLe y; y pfixLe x |] ==> x = y"
by (blast intro: genPrefix_antisym)

lemma prefix_imp_pfixLe: "xs<=ys ==> xs pfixLe ys"
apply (unfold prefix_def Le_def)
apply (blast intro: genPrefix_mono [THEN [2] rev_subsetD])
done

lemma refl_Ge [iff]: "refl Ge"
by (unfold refl_on_def Ge_def, auto)

lemma antisym_Ge [iff]: "antisym Ge"
by (unfold antisym_def Ge_def, auto)

lemma trans_Ge [iff]: "trans Ge"
by (unfold trans_def Ge_def, auto)

lemma pfixGe_refl [iff]: "x pfixGe x"
by simp

lemma pfixGe_trans: "[| x pfixGe y; y pfixGe z |] ==> x pfixGe z"
by (blast intro: genPrefix_trans)

lemma pfixGe_antisym: "[| x pfixGe y; y pfixGe x |] ==> x = y"
by (blast intro: genPrefix_antisym)

lemma prefix_imp_pfixGe: "xs<=ys ==> xs pfixGe ys"
apply (unfold prefix_def Ge_def)
apply (blast intro: genPrefix_mono [THEN [2] rev_subsetD])
done

end