theory tut3sol
imports
Main

begin

locale Geom =
  fixes on :: "'p \<Rightarrow> 'l \<Rightarrow> bool"
  assumes line_on_two_pts: "a \<noteq> b \<Longrightarrow> \<exists>l. on a l \<and> on b l"
  and line_on_two_pts_unique: "\<lbrakk> a \<noteq> b; on a l; on b l; on a m; on b m \<rbrakk> \<Longrightarrow> l = m"
  and two_points_on_line: "\<exists>a b. a \<noteq> b \<and> on a l \<and> on b l"
  and three_points_not_on_line: "\<exists>a b c. a \<noteq> b \<and> a \<noteq> c \<and> b \<noteq> c \<and>
                                    \<not> (\<exists>l. on a l \<and> on b l \<and> on c l)"
begin

(* Not asked for in tutorial: An alternative way of writing Axiom 4 *)
lemma three_points_not_on_line_alt:
  "\<exists>a b c. a \<noteq> b \<and> a \<noteq> c \<and> b \<noteq> c \<and> (\<forall>l. on a l \<and> on b l \<longrightarrow> \<not> on c l)"
proof -
  obtain a b c where distinct: "a \<noteq> b \<and> a \<noteq> c \<and> b \<noteq> c" "\<not> (\<exists>l. on a l \<and> on b l \<and> on c l)"
    using three_points_not_on_line by blast
  then have "\<forall>l. on a l \<and> on b l \<longrightarrow> \<not> on c l"
    by blast
  thus ?thesis using distinct by blast
qed

lemma exists_pt_not_on_line: "\<exists>x. \<not> on x l"
proof -
   obtain a b c where l3: "\<not> (on a l \<and> on b l \<and> on c l)" using three_points_not_on_line by blast
   thus ?thesis by blast
qed

lemma two_lines_through_each_point: "\<exists>l m. on x l \<and> on x m \<and> l \<noteq> m"
proof -
  have "\<exists>z. z \<noteq> x"
  proof (rule ccontr)
    from two_points_on_line obtain a b where ab: "(a::'p) \<noteq> b" by blast
    assume "\<nexists>z. z \<noteq> x" then have univ: "\<forall>z. z = x" by blast
    then have "a = x" "b = x" by auto
    then show False using ab by simp
  qed
  then obtain z where "z \<noteq> x" by blast
  then obtain l where xl: "on x l" and zl: "on z l" using line_on_two_pts by blast
  obtain w where n_wl: "\<not> on w l" using exists_pt_not_on_line by blast
  obtain m where wm: "on x m" and zm: "on w m" using line_on_two_pts xl by force
  then have "l \<noteq> m" using n_wl by blast
  thus ?thesis using wm xl by blast
qed

(* Alternative proof of the above that uses Metis *)
lemma two_lines_through_each_point2: "\<exists>l m. on x l \<and> on x m \<and> l \<noteq> m"
proof -
  obtain z where "z \<noteq> x" using two_points_on_line by metis
  then obtain l where xl: "on x l" and zl: "on z l" using line_on_two_pts by blast
  obtain w where n_wl: "\<not> on w l" using exists_pt_not_on_line by blast
  obtain m where wm: "on x m" and zm: "on w m" using line_on_two_pts xl by force
  then have "l \<noteq> m" using n_wl by blast
  thus ?thesis using wm xl by blast
qed

lemma two_lines_through_each_point2: "\<exists>l m. on x l \<and> on x m \<and> l \<noteq> m"
proof -
  obtain z where "z \<noteq> x" using two_points_on_line by metis
  then obtain l where xl: "on x l" and zl: "on z l" using line_on_two_pts by blast
  obtain w where n_wl: "\<not> on w l" using exists_pt_not_on_line by blast
  obtain m where wm: "on x m" and zm: "on w m" using line_on_two_pts xl by force
  then have "l \<noteq> m" using n_wl by blast
  thus ?thesis using wm xl by blast
qed

lemma two_lines_unique_intersect_pt:
   assumes lm: "l \<noteq> m" and "on x l" and "on x m" and "on y l" and "on y m" shows "x = y"
proof (rule ccontr)
   assume "x \<noteq> y" then have "l = m" using line_on_two_pts_unique assms by simp
   thus "False" using lm by simp
qed

end

(* Not asked for in tutorial: An extension of the locale with a new definition
   using the "in" keyword *)

definition (in Geom)
  collinear :: "'p \<Rightarrow> 'p \<Rightarrow> 'p \<Rightarrow> bool"
  where "collinear a b c \<equiv> \<exists>l. on a l \<and> on b l \<and> on c l"

end


header{*Relations, Families, Ordinals*}

theory Ordinal imports HF
begin

section{*Relations and Functions*}

definition is_hpair :: "hf \<Rightarrow> bool"
  where "is_hpair z = (\<exists>x y. z = \<langle>x,y\<rangle>)"

definition hconverse :: "hf \<Rightarrow> hf"
  where "hconverse(r) = \<lbrace>z. w \<^bold>\<in> r, \<exists>x y. w = \<langle>x,y\<rangle> & z = \<langle>y,x\<rangle>\<rbrace>"

definition hdomain :: "hf \<Rightarrow> hf"
  where "hdomain(r) = \<lbrace>x. w \<^bold>\<in> r, \<exists>y. w = \<langle>x,y\<rangle>\<rbrace>"

definition hrange :: "hf \<Rightarrow> hf"
  where "hrange(r) = hdomain(hconverse(r))"

definition hrelation :: "hf \<Rightarrow> bool"
  where "hrelation(r) = (\<forall>z. z \<^bold>\<in> r \<longrightarrow> is_hpair z)"

definition hrestrict :: "hf \<Rightarrow> hf \<Rightarrow> hf"
  --{* Restrict the relation r to the domain A *}
  where "hrestrict r A = \<lbrace>z \<^bold>\<in> r. \<exists>x \<^bold>\<in> A. \<exists>y. z = \<langle>x,y\<rangle>\<rbrace>"

definition nonrestrict :: "hf \<Rightarrow> hf \<Rightarrow> hf"
  where "nonrestrict r A = \<lbrace>z \<^bold>\<in> r. \<forall>x \<^bold>\<in> A. \<forall>y. z \<noteq> \<langle>x,y\<rangle>\<rbrace>"

definition hfunction :: "hf \<Rightarrow> bool"
  where "hfunction(r) = (\<forall>x y. \<langle>x,y\<rangle> \<^bold>\<in> r \<longrightarrow> (\<forall>y'. \<langle>x,y'\<rangle> \<^bold>\<in> r \<longrightarrow> y=y'))"

definition app :: "hf \<Rightarrow> hf \<Rightarrow> hf"
  where "app f x = (THE y. \<langle>x, y\<rangle> \<^bold>\<in> f)"

lemma hrestrict_iff [iff]:
    "z \<^bold>\<in> hrestrict r A \<longleftrightarrow> z \<^bold>\<in> r & (\<exists> x y. z = \<langle>x, y\<rangle> & x \<^bold>\<in> A)"
  by (auto simp: hrestrict_def)

lemma hrelation_0 [simp]: "hrelation 0"
  by (force simp add: hrelation_def)

lemma hrelation_restr [iff]: "hrelation (hrestrict r x)"
  by (metis hrelation_def hrestrict_iff is_hpair_def)

lemma hrelation_hunion [simp]: "hrelation (f \<squnion> g) \<longleftrightarrow> hrelation f \<and> hrelation g"
  by (auto simp: hrelation_def)

lemma hfunction_restr: "hfunction r \<Longrightarrow> hfunction (hrestrict r x)"
  by (auto simp: hfunction_def hrestrict_def)

lemma hdomain_restr [simp]: "hdomain (hrestrict r x) = hdomain r \<sqinter> x"
  by (force simp add: hdomain_def hrestrict_def)

lemma hdomain_0 [simp]: "hdomain 0 = 0"
  by (force simp add: hdomain_def)

lemma hdomain_ins [simp]: "hdomain (r \<triangleleft> \<langle>x, y\<rangle>) = hdomain r \<triangleleft> x"
  by (force simp add: hdomain_def)

lemma hdomain_hunion [simp]: "hdomain (f \<squnion> g) = hdomain f \<squnion> hdomain g"
  by (simp add: hdomain_def)

lemma hdomain_not_mem [iff]: "\<not> \<langle>hdomain r, a\<rangle> \<^bold>\<in> r"
  by (metis hdomain_ins hinter_hinsert_right hmem_hinsert hmem_not_refl
            hunion_hinsert_right sup_inf_absorb)

lemma app_singleton [simp]: "app \<lbrace>\<langle>x, y\<rangle>\<rbrace> x = y"
  by (simp add: app_def)

lemma app_equality: "hfunction f \<Longrightarrow> \<langle>x, y\<rangle> <: f \<Longrightarrow> app f x = y"
  by (auto simp: app_def hfunction_def intro: the1I2)

lemma app_ins2: "x' \<noteq> x \<Longrightarrow> app (f \<triangleleft> \<langle>x, y\<rangle>) x' = app f x'"
  by (simp add: app_def)

lemma hfunction_0 [simp]: "hfunction 0"
  by (force simp add: hfunction_def)

lemma hfunction_ins: "hfunction f \<Longrightarrow> ~ x <: hdomain f \<Longrightarrow> hfunction (f\<triangleleft> \<langle>x, y\<rangle>)"
  by (auto simp: hfunction_def hdomain_def)

lemma hdomainI: "\<langle>x, y\<rangle> \<^bold>\<in> f \<Longrightarrow> x \<^bold>\<in> hdomain f"
  by (auto simp: hdomain_def)

lemma hfunction_hunion: "hdomain f \<sqinter> hdomain g = 0
            \<Longrightarrow> hfunction (f \<squnion> g) \<longleftrightarrow> hfunction f \<and> hfunction g"
  by (auto simp: hfunction_def) (metis hdomainI hinter_iff hmem_hempty)+

lemma app_hrestrict [simp]: "x \<^bold>\<in> A \<Longrightarrow> app (hrestrict f A) x = app f x"
  by (simp add: hrestrict_def app_def)

section{*Operations on families of sets*}

definition HLambda :: "hf \<Rightarrow> (hf \<Rightarrow> hf) \<Rightarrow> hf"
  where "HLambda A b = RepFun A (\<lambda>x. \<langle>x, b x\<rangle>)"

definition HSigma :: "hf \<Rightarrow> (hf \<Rightarrow> hf) \<Rightarrow> hf"
  where "HSigma A B = (\<Squnion>x\<^bold>\<in>A. \<Squnion>y\<^bold>\<in>B(x). \<lbrace>\<langle>x,y\<rangle>\<rbrace>)"

definition HPi :: "hf \<Rightarrow> (hf \<Rightarrow> hf) \<Rightarrow> hf"
  where "HPi A B = \<lbrace> f \<^bold>\<in> HPow(HSigma A B). A \<le> hdomain(f) & hfunction(f)\<rbrace>"

syntax
  "_PROD"     :: "[pttrn, hf, hf] \<Rightarrow> hf"        ("(3PROD _<:_./ _)" 10)
  "_SUM"      :: "[pttrn, hf, hf] \<Rightarrow> hf"        ("(3SUM _<:_./ _)" 10)
  "_lam"      :: "[pttrn, hf, hf] \<Rightarrow> hf"        ("(3lam _<:_./ _)" 10)

syntax (xsymbols)
  "_PROD"     :: "[pttrn, hf, hf] \<Rightarrow> hf"        ("(3\<Pi>_\<^bold>\<in>_./ _)" 10)
  "_SUM"      :: "[pttrn, hf, hf] \<Rightarrow> hf"        ("(3\<Sigma>_\<^bold>\<in>_./ _)" 10)
  "_lam"      :: "[pttrn, hf, hf] \<Rightarrow> hf"        ("(3\<lambda>_\<^bold>\<in>_./ _)" 10)

syntax (HTML output)
  "_PROD"     :: "[pttrn, hf, hf] \<Rightarrow> hf"        ("(3\<Pi>_\<^bold>\<in>_./ _)" 10)
  "_SUM"      :: "[pttrn, hf, hf] \<Rightarrow> hf"        ("(3\<Sigma>_\<^bold>\<in>_./ _)" 10)
  "_lam"      :: "[pttrn, hf, hf] \<Rightarrow> hf"        ("(3\<lambda>_\<^bold>\<in>_./ _)" 10)

translations
  "PROD x<:A. B" == "CONST HPi A (%x. B)"
  "SUM x<:A. B"  == "CONST HSigma A (%x. B)"
  "lam x<:A. f"  == "CONST HLambda A (%x. f)"

subsection{*Rules for Unions and Intersections of families*}

lemma HUN_iff [simp]: "b \<^bold>\<in> (\<Squnion>x\<^bold>\<in>A. B(x)) \<longleftrightarrow> (\<exists>x\<^bold>\<in>A. b \<^bold>\<in> B(x))"
  by auto

(*The order of the premises presupposes that A is rigid; b may be flexible*)
lemma HUN_I: "\<lbrakk> a \<^bold>\<in> A;  b \<^bold>\<in> B(a) \<rbrakk>  \<Longrightarrow> b \<^bold>\<in> (\<Squnion>x\<^bold>\<in>A. B(x))"
  by auto

lemma HUN_E [elim!]: assumes "b \<^bold>\<in> (\<Squnion>x\<^bold>\<in>A. B(x))" obtains x where "x \<^bold>\<in> A"  "b \<^bold>\<in> B(x)"
  using assms  by blast

lemma HINT_iff: "b \<^bold>\<in> (\<Sqinter>x\<^bold>\<in>A. B(x)) \<longleftrightarrow> (\<forall>x\<^bold>\<in>A. b \<^bold>\<in> B(x)) & A\<noteq>0"
  by (simp add: HInter_def HBall_def) (metis foundation hmem_hempty)

lemma HINT_I: "\<lbrakk> !!x. x \<^bold>\<in> A \<Longrightarrow> b \<^bold>\<in> B(x);  A\<noteq>0 \<rbrakk> \<Longrightarrow> b \<^bold>\<in> (\<Sqinter>x\<^bold>\<in>A. B(x))"
  by (simp add: HINT_iff)

lemma HINT_E: "\<lbrakk> b \<^bold>\<in> (\<Sqinter>x\<^bold>\<in>A. B(x));  a \<^bold>\<in> A \<rbrakk> \<Longrightarrow> b \<^bold>\<in> B(a)"
  by (auto simp: HINT_iff)

subsection{*Generalized Cartesian product*}

lemma HSigmaI [intro!]: "\<lbrakk> a \<^bold>\<in> A;  b \<^bold>\<in> B(a) \<rbrakk>  \<Longrightarrow> \<langle>a,b\<rangle> \<^bold>\<in> HSigma A B"
  by simp

lemmas HSigmaD1 = HSigma_iff [THEN iffD1, THEN conjunct1]
lemmas HSigmaD2 = HSigma_iff [THEN iffD1, THEN conjunct2]

text{*The general elimination rule*}
lemma HSigmaE [elim!]:
  assumes "c \<^bold>\<in> HSigma A B"
  obtains x y where "x \<^bold>\<in> A" "y \<^bold>\<in> B(x)" "c=\<langle>x,y\<rangle>"
  using assms  by (force simp add: HSigma_def)

lemma HSigmaE2 [elim!]:
  assumes "\<langle>a,b\<rangle> \<^bold>\<in> HSigma A B" obtains "a \<^bold>\<in> A" and "b \<^bold>\<in> B(a)"
  using assms  by auto

lemma HSigma_empty1 [simp]: "HSigma 0 B = 0"
  by blast

instantiation hf :: times
begin
definition times_hf where
  "times A B = HSigma A (\<lambda>x. B)"
instance proof qed
end

lemma times_iff [simp]: "\<langle>a,b\<rangle> \<^bold>\<in> A * B \<longleftrightarrow> a \<^bold>\<in> A & b \<^bold>\<in> B"
  by (simp add: times_hf_def)

lemma timesI [intro!]: "\<lbrakk> a \<^bold>\<in> A;  b \<^bold>\<in> B \<rbrakk>  \<Longrightarrow> \<langle>a,b\<rangle> \<^bold>\<in> A * B"
  by simp

lemmas timesD1 = times_iff [THEN iffD1, THEN conjunct1]
lemmas timesD2 = times_iff [THEN iffD1, THEN conjunct2]

text{*The general elimination rule*}
lemma timesE [elim!]:
  assumes c: "c \<^bold>\<in> A * B"
  obtains x y where "x \<^bold>\<in> A" "y \<^bold>\<in> B" "c=\<langle>x,y\<rangle>" using c
  by (auto simp: times_hf_def)

text{*...and a specific one*}
lemma timesE2 [elim!]:
  assumes "\<langle>a,b\<rangle> \<^bold>\<in> A * B" obtains "a \<^bold>\<in> A" and "b \<^bold>\<in> B"
using assms
  by auto

lemma times_empty1 [simp]: "0 * B = (0::hf)"
  by auto

lemma times_empty2 [simp]: "A*0 = (0::hf)"
  by blast

lemma times_empty_iff: "A*B=0 \<longleftrightarrow> A=0 | B=(0::hf)"
  by (auto simp: times_hf_def hf_ext)

instantiation hf :: mult_zero
begin
instance proof qed auto
end

section {*Disjoint Sum*}

instantiation hf :: zero_neq_one
begin

definition
  One_hf_def: "1 = \<lbrace>0\<rbrace>"
instance proof
  qed (auto simp: One_hf_def)
end

instantiation hf :: plus
begin
definition plus_hf where
  "plus A B = (\<lbrace>0\<rbrace> * A) \<squnion> (\<lbrace>1\<rbrace> * B)"
instance proof qed
end

definition Inl :: "hf=>hf" where
     "Inl(a) \<equiv> \<langle>0,a\<rangle>"

definition Inr :: "hf=>hf" where
     "Inr(b) \<equiv> \<langle>1,b\<rangle>"

lemmas sum_defs = plus_hf_def Inl_def Inr_def

lemma Inl_nonzero [simp]:"Inl x \<noteq> 0"
  by (metis Inl_def hpair_nonzero)

lemma Inr_nonzero [simp]:"Inr x \<noteq> 0"
  by (metis Inr_def hpair_nonzero)

text{* Introduction rules for the injections (as equivalences) *}

lemma Inl_in_sum_iff [iff]: "Inl(a) \<^bold>\<in> A+B \<longleftrightarrow> a \<^bold>\<in> A"
  by (auto simp: sum_defs)

lemma Inr_in_sum_iff [iff]: "Inr(b) \<^bold>\<in> A+B \<longleftrightarrow> b \<^bold>\<in> B"
  by (auto simp: sum_defs)

text{*Elimination rule*}

lemma sumE [elim!]:
  assumes u: "u \<^bold>\<in> A+B"
  obtains x where "x \<^bold>\<in> A" "u=Inl(x)" | y where "y \<^bold>\<in> B" "u=Inr(y)" using u
  by (auto simp: sum_defs)

text{* Injection and freeness equivalences, for rewriting *}

lemma Inl_iff [iff]: "Inl(a)=Inl(b) \<longleftrightarrow> a=b"
  by (simp add: sum_defs)

lemma Inr_iff [iff]: "Inr(a)=Inr(b) \<longleftrightarrow> a=b"
  by (simp add: sum_defs)

lemma Inl_Inr_iff [iff]: "Inl(a)=Inr(b) \<longleftrightarrow> False"
  by (simp add: sum_defs)

lemma Inr_Inl_iff [iff]: "Inr(b)=Inl(a) \<longleftrightarrow> False"
  by (simp add: sum_defs)

lemma sum_empty [simp]: "0+0 = (0::hf)"
  by (auto simp: sum_defs)

lemma sum_iff: "u \<^bold>\<in> A+B \<longleftrightarrow> (\<exists>x. x \<^bold>\<in> A & u=Inl(x)) | (\<exists>y. y \<^bold>\<in> B & u=Inr(y))"
  by blast

lemma sum_subset_iff:
  fixes A :: hf shows "A+B \<le> C+D \<longleftrightarrow> A\<le>C & B\<le>D"
  by blast

lemma sum_equal_iff:
  fixes A :: hf shows "A+B = C+D \<longleftrightarrow> A=C & B=D"
  by (auto simp: hf_ext sum_subset_iff)

section{*Ordinals*}

subsection{*Basic Definitions*}

text{*Definition 2.1. We say that x is transitive if every element of x is a subset of x.*}
definition
  Transset  :: "hf \<Rightarrow> bool"  where
    "Transset(x) \<equiv> \<forall>y. y \<^bold>\<in> x \<longrightarrow> y \<le> x"

lemma Transset_sup: "Transset x \<Longrightarrow> Transset y \<Longrightarrow> Transset (x \<squnion> y)"
  by (auto simp: Transset_def)

lemma Transset_inf: "Transset x \<Longrightarrow> Transset y \<Longrightarrow> Transset (x \<sqinter> y)"
  by (auto simp: Transset_def)

lemma Transset_hinsert: "Transset x \<Longrightarrow> y \<le> x \<Longrightarrow> Transset (x \<triangleleft> y)"
  by (auto simp: Transset_def)

text{*In HF, the ordinals are simply the natural numbers. But the definitions are the same
      as for transfinite ordinals.*}
definition
  Ord  :: "hf \<Rightarrow> bool"  where
    "Ord(k)      \<equiv> Transset(k) & (\<forall>x \<^bold>\<in> k. Transset(x))"

subsection {*Definition 2.2 (Successor).*}
definition
  succ  :: "hf \<Rightarrow> hf"  where
    "succ(x)      \<equiv> hinsert x x"

lemma succ_iff [simp]: "x \<^bold>\<in> succ y \<longleftrightarrow> x=y \<or> x \<^bold>\<in> y"
  by (simp add: succ_def)

lemma succ_ne_self [simp]: "i \<noteq> succ i"
  by (metis hmem_ne succ_iff)

lemma succ_notin_self: "~ succ i <: i"
  by (metis hmem_ne succ_iff)

lemma succE [elim?]: assumes "x \<^bold>\<in> succ y" obtains "x=y" | "x \<^bold>\<in> y"
  by (metis assms succ_iff)

lemma hmem_succ_ne: "succ x <: y \<Longrightarrow> x \<noteq> y"
  by (metis hmem_not_refl succ_iff)

lemma hball_succ [simp]: "(\<forall>x \<^bold>\<in> succ k. P x) \<longleftrightarrow> P k & (\<forall>x \<^bold>\<in> k. P x)"
  by (auto simp: HBall_def)

lemma hbex_succ [simp]: "(\<exists>x \<^bold>\<in> succ k. P x) \<longleftrightarrow> P k | (\<exists>x \<^bold>\<in> k. P x)"
  by (auto simp: HBex_def)

lemma One_hf_eq_succ: "1 = succ 0"
  by (metis One_hf_def succ_def)

lemma zero_hmem_one [iff]: "x \<^bold>\<in> 1 \<longleftrightarrow> x = 0"
  by (metis One_hf_eq_succ hmem_hempty succ_iff)

lemma hball_One [simp]: "(\<forall>x\<^bold>\<in>1. P x) = P 0"
  by (simp add: One_hf_eq_succ)

lemma hbex_One [simp]: "(\<exists>x\<^bold>\<in>1. P x) = P 0"
  by (simp add: One_hf_eq_succ)

lemma hpair_neq_succ [simp]: "\<langle>x,y\<rangle> \<noteq> succ k"
  by (auto simp: succ_def hpair_def) (metis hemptyE hmem_hinsert hmem_ne)

lemma hpair_neq_one [simp]: "\<langle>x,y\<rangle> \<noteq> 1"
  by (metis One_hf_eq_succ hpair_neq_succ)

lemma one_neq_hpair [simp]: "1 \<noteq> \<langle>x,y\<rangle>"
  by (metis hpair_neq_one)

lemma hmem_succ: "l \<^bold>\<in> k \<Longrightarrow> l \<^bold>\<in> succ k"
  by (metis succ_iff)

text{*Theorem 2.3.*}
lemma Ord_0 [iff]: "Ord 0"
  by (simp add: Ord_def Transset_def)

lemma Ord_succ: "Ord(k) \<Longrightarrow> Ord(succ(k))"
  by (simp add: Ord_def Transset_def succ_def less_eq_insert2_iff HBall_def)

lemma Ord_1 [iff]: "Ord 1"
  by (metis One_hf_def Ord_0 Ord_succ succ_def)

lemma OrdmemD: "Ord(k) \<Longrightarrow> j \<^bold>\<in> k \<Longrightarrow> j \<le> k"
  by (simp add: Ord_def Transset_def HBall_def)

lemma Ord_trans: "\<lbrakk> i\<^bold>\<in>j;  j\<^bold>\<in>k;  Ord(k) \<rbrakk>  \<Longrightarrow> i\<^bold>\<in>k"
  by (blast dest: OrdmemD)

lemma hmem_0_Ord:
  assumes k: "Ord(k)" and knz: "k \<noteq> 0" shows "0 \<^bold>\<in> k"
  by (metis foundation [OF knz] Ord_trans hempty_iff hinter_iff k)

lemma Ord_in_Ord: "\<lbrakk> Ord(k);  m \<^bold>\<in> k \<rbrakk>  \<Longrightarrow> Ord(m)"
  by (auto simp: Ord_def Transset_def)

subsection{*Induction, Linearity, etc.*}

lemma Ord_induct [consumes 1, case_names step]:
  assumes k: "Ord(k)"
      and step: "!!x.\<lbrakk> Ord(x);  \<And>y. y \<^bold>\<in> x \<Longrightarrow> P(y) \<rbrakk>  \<Longrightarrow> P(x)"
  shows "P(k)"
proof -
  have "\<forall>m \<^bold>\<in> k. Ord(m) \<longrightarrow> P(m)"
    proof (induct k rule: hf_induct)
      case 0 thus ?case  by simp
    next
      case (hinsert a b)
      thus ?case
        by (auto intro: Ord_in_Ord step)
    qed
  thus ?thesis using k
    by (auto intro: Ord_in_Ord step)
qed

text{*Theorem 2.4 (Comparability of ordinals).*}
lemma Ord_linear: "Ord(k) \<Longrightarrow> Ord(l) \<Longrightarrow> k\<^bold>\<in>l | k=l | l\<^bold>\<in>k"
proof (induct k arbitrary: l rule: Ord_induct)
  case (step k)
  note step_k = step
  show ?case using `Ord(l)`
    proof (induct l rule: Ord_induct)
      case (step l)
      thus ?case using step_k
        by (metis Ord_trans hf_equalityI)
    qed
qed

text{*The trichotomy law for ordinals*}
lemma Ord_linear_lt:
  assumes o: "Ord(k)" "Ord(l)"
  obtains (lt) "k\<^bold>\<in>l" | (eq) "k=l" | (gt) "l\<^bold>\<in>k"
by (metis Ord_linear o)

lemma Ord_linear2:
  assumes o: "Ord(k)" "Ord(l)"
  obtains (lt) "k\<^bold>\<in>l" | (ge) "l \<le> k"
by (metis Ord_linear OrdmemD order_eq_refl o)

lemma Ord_linear_le:
  assumes o: "Ord(k)" "Ord(l)"
  obtains (le) "k \<le> l" | (ge) "l \<le> k"
by (metis Ord_linear2 OrdmemD o)

lemma hunion_less_iff [simp]: "\<lbrakk>Ord i; Ord j\<rbrakk> \<Longrightarrow> i \<squnion> j < k \<longleftrightarrow> i<k \<and> j<k"
  by (metis Ord_linear_le le_iff_sup sup.order_iff sup.strict_boundedE)

text{*Theorem 2.5*}
lemma Ord_mem_iff_lt: "Ord(k) \<Longrightarrow> Ord(l) \<Longrightarrow> k\<^bold>\<in>l \<longleftrightarrow> k < l"
  by (metis Ord_linear OrdmemD hmem_not_refl less_hf_def less_le_not_le)

lemma le_succE: "succ i \<le> succ j \<Longrightarrow> i \<le> j"
  by (simp add: less_eq_hf_def) (metis hmem_not_sym)

lemma le_succ_iff: "Ord i \<Longrightarrow> Ord j \<Longrightarrow> succ i \<le> succ j \<longleftrightarrow> i \<le> j"
  by (metis Ord_linear_le Ord_succ le_succE order_antisym)

lemma succ_inject_iff [iff]: "succ i = succ j \<longleftrightarrow> i = j"
  by (metis succ_def hmem_hinsert hmem_not_sym)

lemma mem_succ_iff [simp]: "Ord j \<Longrightarrow> succ i \<^bold>\<in> succ j \<longleftrightarrow> i \<^bold>\<in> j"
  by (metis Ord_in_Ord Ord_mem_iff_lt Ord_succ succ_def less_eq_insert1_iff less_hf_def succ_iff)

lemma Ord_mem_succ_cases:
  assumes "Ord(k)" "l \<^bold>\<in> k"
  shows "succ l = k \<or> succ l \<^bold>\<in> k"
  by (metis assms mem_succ_iff succ_iff)

subsection{*Supremum and Infimum*}

lemma Ord_Union [intro,simp]: "\<lbrakk> !!i. i\<^bold>\<in>A \<Longrightarrow> Ord(i) \<rbrakk>  \<Longrightarrow> Ord(\<Squnion> A)"
  by (auto simp: Ord_def Transset_def) blast

lemma Ord_Inter [intro,simp]: "\<lbrakk> !!i. i\<^bold>\<in>A \<Longrightarrow> Ord(i) \<rbrakk>  \<Longrightarrow> Ord(\<Sqinter> A)"
  apply (case_tac "A=0", auto simp: Ord_def Transset_def)
  apply (force simp add: hf_ext)+
  done

text{*Theorem 2.7. Every set x of ordinals is ordered by the binary relation <.
      Moreover if x = 0 then x has a smallest and a largest element.*}

lemma hmem_Sup_Ords: "\<lbrakk>A\<noteq>0; !!i. i\<^bold>\<in>A \<Longrightarrow> Ord(i)\<rbrakk> \<Longrightarrow> \<Squnion>A \<^bold>\<in> A"
proof (induction A rule: hf_induct)
  case 0 thus ?case  by simp
next
  case (hinsert x A)
  show ?case
    proof (cases A rule: hf_cases)
      case 0 thus ?thesis by simp
    next
      case (hinsert y A')
      hence UA: "\<Squnion>A \<^bold>\<in> A"
        by (metis hinsert.IH(2) hinsert.prems(2) hinsert_nonempty hmem_hinsert)
      hence "\<Squnion>A \<le> x | x \<le> \<Squnion>A"
        by (metis Ord_linear2 OrdmemD hinsert.prems(2) hmem_hinsert)
      thus ?thesis
        by (metis HUnion_hinsert UA le_iff_sup less_eq_insert1_iff order_refl sup.commute)
    qed
qed

lemma hmem_Inf_Ords: "\<lbrakk>A\<noteq>0; !!i. i\<^bold>\<in>A \<Longrightarrow> Ord(i)\<rbrakk> \<Longrightarrow> \<Sqinter>A \<^bold>\<in> A"
proof (induction A rule: hf_induct)
  case 0 thus ?case  by simp
next
  case (hinsert x A)
  show ?case
    proof (cases A rule: hf_cases)
      case 0 thus ?thesis by auto
    next
      case (hinsert y A')
      hence IA: "\<Sqinter>A \<^bold>\<in> A"
        by (metis hinsert.IH(2) hinsert.prems(2) hinsert_nonempty hmem_hinsert)
      hence "\<Sqinter>A \<le> x | x \<le> \<Sqinter>A"
        by (metis Ord_linear2 OrdmemD hinsert.prems(2) hmem_hinsert)
      thus ?thesis
        by (metis HInter_hinsert IA hmem_hempty hmem_hinsert inf_absorb2 le_iff_inf)
    qed
qed

lemma Ord_pred: "\<lbrakk>Ord(k); k \<noteq> 0\<rbrakk> \<Longrightarrow> succ(\<Squnion>k) = k"
by (metis (full_types) HUnion_iff Ord_in_Ord Ord_mem_succ_cases hmem_Sup_Ords hmem_ne succ_iff)

lemma Ord_cases [cases type: hf, case_names 0 succ]:
  assumes Ok: "Ord(k)"
  obtains "k = 0" | l where "Ord l" "succ l = k"
by (metis Ok Ord_in_Ord Ord_pred succ_iff)

lemma Ord_induct2 [consumes 1, case_names 0 succ, induct type: hf]:
  assumes k: "Ord(k)"
      and P: "P 0" "\<And>k. Ord k \<Longrightarrow> P k \<Longrightarrow> P (succ k)"
  shows "P k"
using k
proof (induction k rule: Ord_induct)
  case (step k) thus ?case
    by (metis Ord_cases P hmem_succ_self)
qed

lemma Ord_succ_iff [iff]: "Ord (succ k) = Ord k"
  by (metis Ord_in_Ord Ord_succ less_eq_insert1_iff order_refl succ_def)

lemma Ord_Sup_succ_eq [simp]: "Ord k \<Longrightarrow> \<Squnion>(succ k) = k"
  by (metis Ord_pred Ord_succ_iff succ_inject_iff hinsert_nonempty succ_def)

lemma Ord_lt_succ_iff_le: "Ord k \<Longrightarrow> Ord l \<Longrightarrow> k < succ l \<longleftrightarrow> k \<le> l"
  by (metis Ord_mem_iff_lt Ord_succ_iff less_le_not_le order_eq_iff succ_iff)

lemma zero_in_Ord: "Ord k \<Longrightarrow> k=0 \<or> 0 \<^bold>\<in> k"
  by (induct k) auto

lemma hpair_neq_Ord: "Ord k \<Longrightarrow> \<langle>x,y\<rangle> \<noteq> k"
  by (cases k) auto

lemma hpair_neq_Ord': assumes k: "Ord k" shows "k \<noteq> \<langle>x,y\<rangle>"
  by (metis k hpair_neq_Ord)

lemma Not_Ord_hpair [iff]: "~ Ord \<langle>x,y\<rangle>"
  by (metis hpair_neq_Ord)

lemma is_hpair [simp]: "is_hpair \<langle>x,y\<rangle>"
  by (force simp add: is_hpair_def)

lemma Ord_not_hpair: "Ord x \<Longrightarrow> \<not> is_hpair x"
  by (metis Not_Ord_hpair is_hpair_def)

lemma zero_in_succ [simp,intro]: "Ord i \<Longrightarrow> 0 \<^bold>\<in> succ i"
  by (metis succ_iff zero_in_Ord)

subsection{*Converting Between Ordinals and Natural Numbers*}

fun ord_of :: "nat \<Rightarrow> hf"
  where
   "ord_of 0 = 0"
 | "ord_of (Suc k) = succ (ord_of k)"

lemma Ord_ord_of [simp]: "Ord (ord_of k)"
  by (induct k, auto)

lemma ord_of_inject [iff]: "ord_of i = ord_of j \<longleftrightarrow> i=j"
proof (induct i arbitrary: j)
  case 0 show ?case
    by (metis Zero_neq_Suc hempty_iff hmem_succ_self ord_of.elims)
next
  case (Suc i) show ?case
    by (cases j) (auto simp: Suc)
qed

lemma ord_of_minus_1: "n > 0 \<Longrightarrow> ord_of n = succ (ord_of (n - 1))"
  by (metis Suc_diff_1 ord_of.simps(2))

definition nat_of_ord :: "hf \<Rightarrow> nat"
  where "nat_of_ord x = (THE n. x = ord_of n)"

lemma nat_of_ord_ord_of [simp]: "nat_of_ord (ord_of n) = n"
  by (auto simp: nat_of_ord_def)

lemma nat_of_ord_0 [simp]: "nat_of_ord 0 = 0"
  by (metis (mono_tags) nat_of_ord_ord_of ord_of.simps(1))

lemma ord_of_nat_of_ord [simp]: "Ord x \<Longrightarrow> ord_of (nat_of_ord x) = x"
  apply (erule Ord_induct2, simp)
  apply (metis nat_of_ord_ord_of ord_of.simps(2))
  done

lemma nat_of_ord_inject: "Ord x \<Longrightarrow> Ord y \<Longrightarrow> nat_of_ord x = nat_of_ord y \<longleftrightarrow> x = y"
  by (metis ord_of_nat_of_ord)

lemma nat_of_ord_succ [simp]: "Ord x \<Longrightarrow> nat_of_ord (succ x) = Suc (nat_of_ord x)"
  by (metis nat_of_ord_ord_of ord_of.simps(2) ord_of_nat_of_ord)

section{*Sequences and Ordinal Recursion*}

text{*Definition 3.2 (Sequence).*}

definition Seq :: "hf \<Rightarrow> hf \<Rightarrow> bool"
  where "Seq s k \<longleftrightarrow> hrelation s & hfunction s & k \<le> hdomain s"

lemma Seq_0 [iff]: "Seq 0 0"
  by (auto simp: Seq_def hrelation_def hfunction_def)

lemma Seq_succ_D: "Seq s (succ k) \<Longrightarrow> Seq s k"
  by (simp add: Seq_def succ_def)

lemma Seq_Ord_D: "Seq s k \<Longrightarrow> l \<^bold>\<in> k \<Longrightarrow> Ord k \<Longrightarrow> Seq s l"
  by (auto simp: Seq_def intro: Ord_trans)

lemma Seq_restr: "Seq s (succ k) \<Longrightarrow> Seq (hrestrict s k) k"
  by (simp add: Seq_def hfunction_restr succ_def)

lemma Seq_Ord_restr: "\<lbrakk>Seq s k; l \<^bold>\<in> k; Ord k\<rbrakk> \<Longrightarrow> Seq (hrestrict s l) l"
  by (auto simp: Seq_def hfunction_restr intro: Ord_trans)

lemma Seq_ins: "\<lbrakk>Seq s k; ~ k <: hdomain s\<rbrakk> \<Longrightarrow> Seq (s \<triangleleft> \<langle>k, y\<rangle>) (succ k)"
  by (auto simp: Seq_def hrelation_def succ_def hfunction_def hdomainI)

definition insf :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf"
  where "insf s k y \<equiv> nonrestrict s \<lbrace>k\<rbrace> \<triangleleft> \<langle>k, y\<rangle>"

lemma hfunction_insf: "hfunction s \<Longrightarrow> hfunction (insf s k y)"
  by (auto simp: insf_def hfunction_def nonrestrict_def hmem_not_refl)

lemma Seq_succ_iff: "Seq s (succ k) \<longleftrightarrow> Seq s k \<and> (\<exists>y. \<langle>k, y\<rangle> <: s)"
  apply (auto simp: Seq_def hdomain_def)
  apply (metis hfst_conv, blast)
  done

lemma nonrestrictD: "a \<^bold>\<in> nonrestrict s X \<Longrightarrow> a \<^bold>\<in> s"
  by (auto simp: nonrestrict_def)

lemma hpair_in_nonrestrict_iff [simp]: "\<langle>a,b\<rangle> \<^bold>\<in> nonrestrict s X \<longleftrightarrow> \<langle>a,b\<rangle> \<^bold>\<in> s \<and> \<not> a \<^bold>\<in> X"
  by (auto simp: nonrestrict_def)

lemma app_nonrestrict_Seq: "Seq s k \<Longrightarrow> ~ z <: X \<Longrightarrow> app (nonrestrict s X) z = app s z"
  by (auto simp: Seq_def nonrestrict_def app_def)

lemma app_insf_Seq: "Seq s k \<Longrightarrow> app (insf s k y) k = y"
  by (metis Seq_def hfunction_insf app_equality hmem_hinsert insf_def)

lemma app_insf2_Seq: "Seq s k \<Longrightarrow> k' \<noteq> k \<Longrightarrow> app (insf s k y) k' = app s k'"
  by (simp add: app_nonrestrict_Seq insf_def app_ins2)

lemma app_insf_Seq_if: "Seq s k \<Longrightarrow> app (insf s k y) k' = (if k' = k then y else app s k')"
  by (metis app_insf2_Seq app_insf_Seq)

lemma Seq_imp_eq_app: "\<lbrakk>Seq s d; \<langle>x,y\<rangle> \<^bold>\<in> s\<rbrakk> \<Longrightarrow> app s x = y"
  by (metis Seq_def app_equality)

lemma Seq_iff_app: "\<lbrakk>Seq s d; x \<^bold>\<in> d\<rbrakk> \<Longrightarrow> \<langle>x,y\<rangle> \<^bold>\<in> s \<longleftrightarrow> app s x = y"
  by (auto simp: Seq_def hdomain_def app_equality)

lemma Exists_iff_app: "Seq s d \<Longrightarrow> x \<^bold>\<in> d \<Longrightarrow> (\<exists>y. \<langle>x, y\<rangle> \<^bold>\<in> s & P y) = P (app s x)"
  by (metis Seq_iff_app)

definition ord_rec_Seq :: "hf \<Rightarrow> (hf \<Rightarrow> hf) \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
  where
   "ord_rec_Seq T G s k y \<longleftrightarrow>
        (Seq s k & y = G (app s (\<Squnion>k)) & app s 0 = T &
                   (\<forall>n. succ n \<^bold>\<in> k \<longrightarrow> app s (succ n) = G (app s n)))"

lemma Seq_succ_insf:
  assumes s: "Seq s (succ k)"  shows "\<exists> y. s = insf s k y"
proof -
  obtain y where y: "\<langle>k, y\<rangle> <: s" by (metis Seq_succ_iff s)
  hence yuniq: "\<forall> y'. \<langle>k, y'\<rangle> <: s \<longrightarrow> y' = y" using s
    by (simp add: Seq_def hfunction_def)
  { fix z
    assume z: "z <: s"
    then obtain u v where uv: "z = \<langle>u, v\<rangle>" using s
      by (metis Seq_def hrelation_def is_hpair_def)
    hence "z <: insf s k y"
      by (metis hemptyE hmem_hinsert hpair_in_nonrestrict_iff insf_def yuniq z)
  }
  note left2right = this
  show ?thesis
    proof
      show "s = insf s k y"
        by (rule hf_equalityI) (metis hmem_hinsert insf_def left2right nonrestrictD y)
    qed
qed

lemma ord_rec_Seq_succ_iff:
  assumes k: "Ord k" and knz: "k \<noteq> 0"
  shows "ord_rec_Seq T G s (succ k) z \<longleftrightarrow> (\<exists> s' y. ord_rec_Seq T G s' k y & z = G y & s = insf s' k y)"
proof
  assume os: "ord_rec_Seq T G s (succ k) z"
  show "\<exists>s' y. ord_rec_Seq T G s' k y \<and> z = G y \<and> s = insf s' k y"
    apply (rule_tac x=s in exI)  using os k knz
    apply (auto simp: Seq_insf ord_rec_Seq_def app_insf_Seq app_insf2_Seq
                          hmem_succ_ne hmem_ne hmem_Sup_ne Seq_succ_iff hmem_0_Ord)
    apply (metis Ord_pred)
    apply (metis Ord_pred Seq_succ_iff Seq_succ_insf app_insf_Seq)
    done
next
  assume ok: "\<exists>s' y. ord_rec_Seq T G s' k y \<and> z = G y \<and> s = insf s' k y"
  thus "ord_rec_Seq T G s (succ k) z" using ok k knz
    by (auto simp: ord_rec_Seq_def app_insf_Seq_if hmem_ne hmem_succ_ne Seq_insf)
qed

lemma ord_rec_Seq_functional:
   "Ord k \<Longrightarrow> k \<noteq> 0 \<Longrightarrow> ord_rec_Seq T G s k y \<Longrightarrow> ord_rec_Seq T G s' k y' \<Longrightarrow> y' = y"
proof (induct k arbitrary: y y' s s' rule: Ord_induct2)
  case 0 thus ?case
    by (simp add: ord_rec_Seq_def)
next
  case (succ k) show ?case
    proof (cases "k=0")
      case True thus ?thesis using succ
        by (auto simp: ord_rec_Seq_def)
    next
      case False
      thus ?thesis using succ
        by (auto simp: ord_rec_Seq_succ_iff)
    qed
qed

definition ord_recp :: "hf \<Rightarrow> (hf \<Rightarrow> hf) \<Rightarrow> (hf \<Rightarrow> hf) \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
  where
   "ord_recp T G H x y =
    (if x=0 then y = T
     else
       if Ord(x) then \<exists> s. ord_rec_Seq T G s x y
       else y = H x)"

lemma ord_recp_functional: "ord_recp T G H x y \<Longrightarrow> ord_recp T G H x y' \<Longrightarrow> y' = y"
  by (auto simp: ord_recp_def ord_rec_Seq_functional split: split_if_asm)

lemma ord_recp_succ_iff:
  assumes k: "Ord k" shows "ord_recp T G H (succ k) z \<longleftrightarrow> (\<exists>y. z = G y & ord_recp T G H k y)"
proof (cases "k=0")
  case True thus ?thesis
    by (simp add: ord_recp_def ord_rec_Seq_def) (metis Seq_0 Seq_insf app_insf_Seq)
next
  case False
  thus ?thesis using k
    by (auto simp: ord_recp_def ord_rec_Seq_succ_iff)
qed

definition ord_rec :: "hf \<Rightarrow> (hf \<Rightarrow> hf) \<Rightarrow> (hf \<Rightarrow> hf) \<Rightarrow> hf \<Rightarrow> hf"
  where
   "ord_rec T G H x = (THE y. ord_recp T G H x y)"

lemma ord_rec_0 [simp]: "ord_rec T G H 0 = T"
  by (simp add: ord_recp_def ord_rec_def)

lemma ord_recp_total: "\<exists>y. ord_recp T G H x y"
proof (cases "Ord x")
  case True thus ?thesis
  proof (induct x rule: Ord_induct2)
    case 0 thus ?case
      by (simp add: ord_recp_def)
  next
    case (succ x) thus ?case
      by (metis ord_recp_succ_iff)
  qed
next
  case False thus ?thesis
    by (auto simp: ord_recp_def)
qed

lemma ord_rec_succ [simp]:
  assumes k: "Ord k" shows "ord_rec T G H (succ k) = G (ord_rec T G H k)"
proof -
  from ord_recp_total [of T G H k]
  obtain y where "ord_recp T G H k y" by auto
  thus ?thesis using k
    apply (simp add: ord_rec_def ord_recp_succ_iff)
    apply (rule theI2)
    apply (auto dest: ord_recp_functional)
    done
qed

lemma ord_rec_non [simp]: "~ Ord x \<Longrightarrow> ord_rec T G H x = H x"
  by (metis Ord_0 ord_rec_def ord_recp_def the_equality)

end


(* Author: Max P.L. Haslbeck, Bohua Zhan
*)

theory MergeSort
  imports "Auto2_HOL.Auto2_Main"
begin

section \<open>Simple functional version\<close>

fun merge_list :: "('a::linorder) list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "merge_list xs ys = (
     if xs = [] then ys else if ys = [] then xs
     else if last xs \<ge> last ys then merge_list (butlast xs) ys @ [last xs]
     else merge_list xs (butlast ys) @ [last ys])"
setup \<open>add_rewrite_rule @{thm merge_list.simps}\<close>

lemma merge_list_simps' [rewrite]:
  "merge_list [] ys = ys"
  "merge_list xs [] = xs"
  "merge_list (xs @ [x]) (ys @ [y]) =
    (if x \<ge> y then merge_list xs (ys @ [y]) @ [x]
               else merge_list (xs @ [x]) ys @ [y])" by auto2+
setup \<open>del_prfstep_thm @{thm merge_list.simps}\<close>

lemma merge_list_length [rewrite]:
  "length (merge_list xs ys) = length xs + length ys"
@proof @fun_induct "merge_list xs ys"
  @case "xs = []" @case "ys = []"
  @have "xs = butlast xs @ [last xs]"
  @have "ys = butlast ys @ [last ys]"
@qed

lemma merge_list_correct_mset [rewrite]:
  "mset (merge_list xs ys) = mset xs + mset ys"
@proof @fun_induct "merge_list xs ys"
  @case "xs = []" @case "ys = []"
  @have "xs = butlast xs @ [last xs]"
  @have "ys = butlast ys @ [last ys]"
@qed

lemma merge_list_correct_set [rewrite]:
  "set (merge_list xs ys) = set xs \<union> set ys"
@proof
  @have "set (merge_list xs ys) = set_mset (mset (merge_list xs ys))"
@qed

lemma merge_list_sorted [forward]:
  "sorted xs \<Longrightarrow> sorted ys \<Longrightarrow> sorted (merge_list xs ys)"
@proof @fun_induct "merge_list xs ys"
  @case "xs = []" @case "ys = []"
  @have "xs = butlast xs @ [last xs]"
  @have "ys = butlast ys @ [last ys]"
@qed

fun merge_sort_fun :: "'a::linorder list \<Rightarrow> 'a list" where
  "merge_sort_fun xs =
     (let n = length xs in
      (if n \<le> 1 then xs
       else
        let as = take (n div 2) xs;
            bs = drop (n div 2) xs;
            as' = merge_sort_fun as;
            bs' = merge_sort_fun bs;
            r = merge_list as' bs'
        in r))"

lemma sort_length_le1 [rewrite]: "length xs \<le> 1 \<Longrightarrow> sort xs = xs"
@proof
  @case "xs = []" @have "xs = hd xs # tl xs" @case "tl xs = []"
@qed

lemma mergesort_fun_correct [rewrite]:
  "merge_sort_fun xs = sort xs"
@proof @fun_induct "merge_sort_fun xs"
  @unfold "merge_sort_fun xs"
  @case "length xs \<le> 1"
  @let "l1 = length xs div 2"
  @have "mset (take l1 xs) + mset (drop l1 xs) = mset xs" @with
    @have "take l1 xs @ drop l1 xs = xs"
  @end
@qed

lemma mergesort_fun_length [rewrite]:
  "length (merge_sort_fun xs) = length xs" by auto2

section \<open>Actual functional version\<close>

function mergeinto_fun :: "nat \<Rightarrow> nat \<Rightarrow> 'a::linorder list \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "mergeinto_fun 0 0 a b c = c"
| "mergeinto_fun (Suc la) 0 a b c = list_update (mergeinto_fun la 0 a b c) la (a ! la)"
| "mergeinto_fun 0 (Suc lb) a b c = list_update (mergeinto_fun 0 lb a b c) lb (b ! lb)"
| "mergeinto_fun (Suc la) (Suc lb) a b c =
    (if a ! la \<ge> b ! lb then
       list_update (mergeinto_fun la (Suc lb) a b c) (Suc (la+lb)) (a ! la)
     else
       list_update (mergeinto_fun (Suc la) lb a b c) (Suc (la+lb)) (b ! lb))"
by pat_completeness auto
termination by (relation "Wellfounded.measure (\<lambda>(la, lb, a, b, c). la + lb)") auto

setup \<open>fold add_rewrite_rule @{thms mergeinto_fun.simps}\<close>

lemma mergeinto_fun_length [rewrite]:
  "length (mergeinto_fun la lb a b c) = length c"
@proof @fun_induct "mergeinto_fun la lb a b c" @qed

lemma mergeinto_fun_to_merge_list_induct [backward]:
  "length c = length a + length b \<Longrightarrow>
  la \<le> length a \<Longrightarrow> lb \<le> length b \<Longrightarrow>
  take (la + lb) (mergeinto_fun la lb a b c) = merge_list (take la a) (take lb b)"
@proof @fun_induct "mergeinto_fun la lb a b c" @with
  @subgoal "(la = Suc la, lb = Suc lb, a = a, b = b, c = c)"
    @have "Suc (la + Suc lb) \<le> length c" @with
      @have "Suc (la + lb) < length c"
    @end
    @case "a ! la \<ge> b ! lb"
  @endgoal @end
@qed

lemma mergeinto_fun_to_merge_list [rewrite]:
  "length c = length a + length b \<Longrightarrow>
   mergeinto_fun (length a) (length b) a b c = merge_list a b"
@proof
  @let "res = mergeinto_fun (length a) (length b) a b c"
  @have "take (length a + length b) res = merge_list (take (length a) a) (take (length b) b)"
@qed

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsection \<open>Symmetric\<close>
theory SBinary_Relations_Symmetric
  imports
    Pairs
begin

definition "symmetric D R \<equiv> \<forall>x y \<in> D. \<langle>x, y\<rangle> \<in> R \<longrightarrow> \<langle>y, x\<rangle> \<in> R"

lemma symmetricI [intro]:
  assumes "\<And>x y. x \<in> D \<Longrightarrow> y \<in> D \<Longrightarrow> \<langle>x, y\<rangle> \<in> R \<Longrightarrow> \<langle>y, x\<rangle> \<in> R"
  shows "symmetric D R"
  using assms unfolding symmetric_def by blast

lemma symmetricD:
  assumes "symmetric D R"
  and "x \<in> D" "y \<in> D"
  and "\<langle>x, y\<rangle> \<in> R"
  shows "\<langle>y, x\<rangle> \<in> R"
  using assms unfolding symmetric_def by blast

end


section \<open>Parity by counting inversions abstractly\<close>

theory Parity_Inversions
imports Parity_Swap
begin

text \<open>The recursive definition of parity is equivalent to the evenness of the number of
      inversions, expressed abstractly.\<close>

definition
  inversions :: "nat list \<Rightarrow> (nat \<times> nat) set"
where
  "inversions xs \<equiv> {(i,j). j < length xs \<and> i < j \<and> xs ! i > xs ! j}"

lemma inversions_example:
  "inversions [0,2,4,3,1] = {(1,4),(2,3),(2,4),(3,4)}"
  unfolding inversions_def
  apply (intro equalityI subsetI; clarsimp)
  apply (case_tac b; clarsimp; rename_tac b)+
  done

lemma map_prod_comprehension:
  "map_prod f g ` {(i,j). P i j} = {(f i, g j) | i j. P i j}"
  by blast

lemma inj_on_same_card: "inj_on f (Collect P) \<Longrightarrow> card {f i | i. P i} = card {i. P i}"
  by (rule bij_betw_same_card[of f, symmetric]) (auto simp: bij_betw_def)

lemma set_prod_empty: "(\<And>i j. \<not> P i j) \<Longrightarrow> {(i,j). P i j} = {}"
  by blast

lemma prod_split: "(x,y) = z \<Longrightarrow> x = fst z \<and> y = snd z"
  by auto

lemma inversions_nil [simp]: "inversions [] = {}"
  by (simp add: inversions_def)

lemma inversions_cons:
  "inversions (x # ys) = {(0, Suc j) | j. j < length ys \<and> x > ys ! j}
                       \<union> map_prod Suc Suc ` inversions ys"
  by (auto simp add: inversions_def map_prod_comprehension less_Suc_eq_0_disj)

lemma inversions_subset: "inversions xs \<subseteq> {0 ..< length xs} \<times> {0 ..< length xs}"
  by (rule subsetI; clarsimp simp: inversions_def)

lemma inversions_finite [simp]: "finite (inversions xs)"
  by (rule finite_subset[OF inversions_subset]; simp)

lemma card_inversions_cons [simp]:
  "card (inversions (x # ys)) = length [y \<leftarrow> ys. x > y] + card (inversions ys)"
  apply (subst inversions_cons)
  apply (subst card_Un_disjoint)
     apply auto[3]
  apply (subst card_image)
   apply (metis inj_Suc inj_eq inj_onI prod.inj_map)
  apply simp
  apply (subst inj_on_same_card)
   apply (meson Pair_inject Suc_inject inj_onI)
  apply (simp add: length_filter_conv_card)
  done

lemma parity: "parity = even \<circ> card \<circ> inversions" (is "?p = ?i")
  proof (rule ext)
    fix xs show "?p xs = ?i xs" by (induct xs) auto
  qed

end


(*  Title:      CCL/Gfp.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

section {* Greatest fixed points *}

theory Gfp
imports Lfp
begin

definition
  gfp :: "['a set\<Rightarrow>'a set] \<Rightarrow> 'a set" where -- "greatest fixed point"
  "gfp(f) == Union({u. u <= f(u)})"

(* gfp(f) is the least upper bound of {u. u <= f(u)} *)

lemma gfp_upperbound: "A <= f(A) \<Longrightarrow> A <= gfp(f)"
  unfolding gfp_def by blast

lemma gfp_least: "(\<And>u. u <= f(u) \<Longrightarrow> u <= A) \<Longrightarrow> gfp(f) <= A"
  unfolding gfp_def by blast

lemma gfp_lemma2: "mono(f) \<Longrightarrow> gfp(f) <= f(gfp(f))"
  by (rule gfp_least, rule subset_trans, assumption, erule monoD,
    rule gfp_upperbound, assumption)

lemma gfp_lemma3: "mono(f) \<Longrightarrow> f(gfp(f)) <= gfp(f)"
  by (rule gfp_upperbound, frule monoD, rule gfp_lemma2, assumption+)

lemma gfp_Tarski: "mono(f) \<Longrightarrow> gfp(f) = f(gfp(f))"
  by (rule equalityI gfp_lemma2 gfp_lemma3 | assumption)+

(*** Coinduction rules for greatest fixed points ***)

(*weak version*)
lemma coinduct: "\<lbrakk>a: A;  A <= f(A)\<rbrakk> \<Longrightarrow> a : gfp(f)"
  by (blast dest: gfp_upperbound)

lemma coinduct2_lemma: "\<lbrakk>A <= f(A) Un gfp(f); mono(f)\<rbrakk> \<Longrightarrow> A Un gfp(f) <= f(A Un gfp(f))"
  apply (rule subset_trans)
   prefer 2
   apply (erule mono_Un)
  apply (rule subst, erule gfp_Tarski)
  apply (erule Un_least)
  apply (rule Un_upper2)
  done

(*strong version, thanks to Martin Coen*)
lemma coinduct2: "\<lbrakk>a: A; A <= f(A) Un gfp(f); mono(f)\<rbrakk> \<Longrightarrow> a : gfp(f)"
  apply (rule coinduct)
   prefer 2
   apply (erule coinduct2_lemma, assumption)
  apply blast
  done

(***  Even Stronger version of coinduct  [by Martin Coen]
         - instead of the condition  A <= f(A)
                           consider  A <= (f(A) Un f(f(A)) ...) Un gfp(A) ***)

lemma coinduct3_mono_lemma: "mono(f) \<Longrightarrow> mono(\<lambda>x. f(x) Un A Un B)"
  by (rule monoI) (blast dest: monoD)

lemma coinduct3_lemma:
  assumes prem: "A <= f(lfp(\<lambda>x. f(x) Un A Un gfp(f)))"
    and mono: "mono(f)"
  shows "lfp(\<lambda>x. f(x) Un A Un gfp(f)) <= f(lfp(\<lambda>x. f(x) Un A Un gfp(f)))"
  apply (rule subset_trans)
   apply (rule mono [THEN coinduct3_mono_lemma, THEN lfp_lemma3])
  apply (rule Un_least [THEN Un_least])
    apply (rule subset_refl)
   apply (rule prem)
  apply (rule mono [THEN gfp_Tarski, THEN equalityD1, THEN subset_trans])
  apply (rule mono [THEN monoD])
  apply (subst mono [THEN coinduct3_mono_lemma, THEN lfp_Tarski])
  apply (rule Un_upper2)
  done

lemma coinduct3:
  assumes 1: "a:A"
    and 2: "A <= f(lfp(\<lambda>x. f(x) Un A Un gfp(f)))"
    and 3: "mono(f)"
  shows "a : gfp(f)"
  apply (rule coinduct)
   prefer 2
   apply (rule coinduct3_lemma [OF 2 3])
  apply (subst lfp_Tarski [OF coinduct3_mono_lemma, OF 3])
  using 1 apply blast
  done

subsection {* Definition forms of @{text "gfp_Tarski"}, to control unfolding *}

lemma def_gfp_Tarski: "\<lbrakk>h == gfp(f); mono(f)\<rbrakk> \<Longrightarrow> h = f(h)"
  apply unfold
  apply (erule gfp_Tarski)
  done

lemma def_coinduct: "\<lbrakk>h == gfp(f); a:A; A <= f(A)\<rbrakk> \<Longrightarrow> a: h"
  apply unfold
  apply (erule coinduct)
  apply assumption
  done

lemma def_coinduct2: "\<lbrakk>h == gfp(f); a:A; A <= f(A) Un h; mono(f)\<rbrakk> \<Longrightarrow> a: h"
  apply unfold
  apply (erule coinduct2)
   apply assumption
  apply assumption
  done

lemma def_coinduct3: "\<lbrakk>h == gfp(f); a:A; A <= f(lfp(\<lambda>x. f(x) Un A Un h)); mono(f)\<rbrakk> \<Longrightarrow> a: h"
  apply unfold
  apply (erule coinduct3)
   apply assumption
  apply assumption
  done

(*Monotonicity of gfp!*)
lemma gfp_mono: "\<lbrakk>mono(f); \<And>Z. f(Z) <= g(Z)\<rbrakk> \<Longrightarrow> gfp(f) <= gfp(g)"
  apply (rule gfp_upperbound)
  apply (rule subset_trans)
   apply (rule gfp_lemma2)
   apply assumption
  apply (erule meta_spec)
  done

end


theory Bipartite_Graphs imports Undirected_Graph_Walks
begin

section \<open>Bipartite Graphs \<close>

text \<open>An introductory library for reasoning on bipartite graphs.\<close>

subsection \<open>Bipartite Set Up \<close>
text \<open>All "edges", i.e. pairs, between any two sets \<close>
definition all_bi_edges :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a edge set" where
"all_bi_edges X Y \<equiv> mk_edge ` (X \<times> Y)"

lemma all_bi_edges_alt:
  assumes "X \<inter> Y = {}"
  shows "all_bi_edges X Y = {e . card e = 2 \<and> e \<inter> X \<noteq> {} \<and> e \<inter> Y \<noteq> {}}"
  unfolding all_bi_edges_def
proof (intro subset_antisym subsetI)
  fix e assume "e \<in> mk_edge ` (X \<times> Y)"
  then obtain v1 v2 where "e = { v1, v2}" and  "v1 \<in> X" and "v2 \<in> Y"
    by auto
  then show "e \<in> {e. card e = 2 \<and> e \<inter> X \<noteq> {} \<and> e \<inter> Y \<noteq> {}}" using assms
    using card_2_iff by blast
next
  fix e' assume assm: "e' \<in> {e. card e = 2 \<and> e \<inter> X \<noteq> {} \<and> e \<inter> Y \<noteq> {}}"
  then obtain v1 where v1in: "v1 \<in> e'" and "v1 \<in> X"
    by blast
  moreover obtain v2 where v2in: "v2 \<in> e'" and "v2 \<in> Y" using assm by blast
  then have ne: "v1 \<noteq> v2"
    using assms calculation(2) by blast
  have "card e' = 2" using assm by blast
  have "{v1, v2} \<subseteq> e'" using v1in v2in by blast
  then have "e' = {v1, v2}" using assm v1in v2in
    by (metis (no_types, opaque_lifting) \<open>card e' = 2\<close> card_2_iff' insertCI ne subsetI subset_antisym)
  then show "e' \<in> mk_edge ` (X \<times> Y)"
    by (simp add: \<open>v2 \<in> Y\<close> calculation(2) in_mk_edge_img)
qed

lemma all_bi_edges_alt2:  "all_bi_edges X Y = {{x, y} | x y. x \<in> X \<and> y \<in> Y }"
  unfolding all_bi_edges_def
proof (intro subset_antisym subsetI)
  fix x assume "x \<in> mk_edge ` (X \<times> Y)"
  then obtain a b where "(a, b) \<in> (X \<times> Y)" and xeq: "x = mk_edge (a, b) " by blast
  then show "x \<in> {{x, y} |x y. x \<in> X \<and> y \<in> Y}"
    by auto
next
  fix x assume "x \<in> {{x, y} |x y. x \<in> X \<and> y \<in> Y}"
  then obtain a b where xeq: "x = {a, b}" and "a \<in> X" and "b \<in> Y"
    by blast
  then have "(a, b) \<in> (X \<times> Y)" by auto
  then show "x \<in> mk_edge ` (X \<times> Y)"  using in_mk_edge_img xeq by metis
qed

lemma all_bi_edges_wf: "e \<in> all_bi_edges X Y \<Longrightarrow> e \<subseteq> X \<union> Y"
  by (auto simp add: all_bi_edges_alt2)

lemma all_bi_edges_2: "X \<inter> Y = {} \<Longrightarrow> e \<in> all_bi_edges X Y \<Longrightarrow> card e = 2"
  using card_2_iff by (auto simp add: all_bi_edges_alt2)

lemma all_bi_edges_main: "X \<inter> Y = {} \<Longrightarrow> all_bi_edges X Y \<subseteq> all_edges (X \<union> Y)"
  unfolding  all_edges_def using all_bi_edges_wf all_bi_edges_2 by blast

lemma all_bi_edges_finite: "finite X \<Longrightarrow> finite Y \<Longrightarrow> finite (all_bi_edges X Y)"
  by (simp add: all_bi_edges_def)

lemma all_bi_edges_not_ssX: "X \<inter> Y = {} \<Longrightarrow> e \<in> all_bi_edges X Y \<Longrightarrow> \<not> e \<subseteq> X"
  by (auto simp add: all_bi_edges_alt)

lemma all_bi_edges_sym: "all_bi_edges X Y = all_bi_edges Y X"
  by (auto simp add: all_bi_edges_alt2)

lemma all_bi_edges_not_ssY: "X \<inter> Y = {} \<Longrightarrow> e \<in> all_bi_edges X Y \<Longrightarrow> \<not> e \<subseteq> Y"
  by (auto simp add: all_bi_edges_alt)

lemma card_all_bi_edges:
  assumes "finite X" "finite Y"
  assumes "X \<inter> Y = {}"
  shows "card (all_bi_edges X Y) = card X * card Y"
proof -
  have "card (all_bi_edges X Y) = card (X \<times> Y)"
    unfolding all_bi_edges_def using inj_on_mk_edge assms card_image by blast
  thus ?thesis using card_cartesian_product by auto
qed

lemma (in sgraph) all_edges_between_bi_subset: "mk_edge ` all_edges_between X Y \<subseteq> all_bi_edges X Y"
  by (auto simp: all_edges_between_def all_bi_edges_def)

subsection \<open> Bipartite Graph Locale \<close>

text \<open>For reasoning purposes, it is useful to explicitly label the two sets of vertices as X and Y.
These are parameters in the locale\<close>

locale bipartite_graph = graph_system +
  fixes X Y :: "'a set"
  assumes partition: "partition_on V {X, Y}"
  assumes ne: "X \<noteq> Y"
  assumes edge_betw: "e \<in> E \<Longrightarrow> e \<in> all_bi_edges X Y"
begin

lemma part_intersect_empty: "X \<inter> Y = {}"
  using partition_onD2 partition disjointD ne
  by blast

lemma X_not_empty: "X \<noteq> {}"
  using partition partition_onD3 by auto

lemma Y_not_empty: "Y \<noteq> {}"
  using partition partition_onD3 by auto

lemma XY_union: "X \<union> Y = V"
  using partition partition_onD1 by auto

lemma card_edges_two: "e \<in> E \<Longrightarrow> card e = 2"
  using edge_betw all_bi_edges_alt part_intersect_empty by auto

lemma partitions_ss: "X \<subseteq> V" "Y \<subseteq> V"
  using XY_union by auto

end

text \<open> By definition, we say an edge must be between X and Y, i.e. contains two vertices \<close>
sublocale bipartite_graph \<subseteq> sgraph
  using card_edges_two by (unfold_locales)

context bipartite_graph
begin

abbreviation "density \<equiv> edge_density X Y"

lemma bipartite_sym: "bipartite_graph V E Y X"
  using partition ne edge_betw all_bi_edges_sym
  by (unfold_locales) (auto simp add: insert_commute)

lemma X_verts_not_adj:
  assumes "x1 \<in> X" "x2 \<in> X"
  shows "\<not> vert_adj x1 x2"
proof (rule ccontr, simp add: vert_adj_def)
  assume "{x1, x2} \<in> E"
  then have "\<not> {x1, x2} \<subseteq> X"
    using all_bi_edges_not_ssX edge_betw part_intersect_empty by auto
  then show False using assms by auto
qed

lemma Y_verts_not_adj:
  assumes "y1 \<in> Y" "y2 \<in> Y"
  shows "\<not> vert_adj y1 y2"
proof -
  interpret sym: bipartite_graph V E Y X using bipartite_sym by simp
  show ?thesis using sym.X_verts_not_adj
    by (simp add: assms(1) assms(2))
qed

lemma X_vert_adj_Y: "x \<in>X \<Longrightarrow> vert_adj x y \<Longrightarrow> y \<in> Y"
  using X_verts_not_adj XY_union vert_adj_imp_inV by blast

lemma Y_vert_adj_X: "y \<in>Y \<Longrightarrow> vert_adj y x \<Longrightarrow> x \<in> X"
  using Y_verts_not_adj XY_union vert_adj_imp_inV by blast

lemma neighbors_ss_eq_neighborhoodX: "v \<in> X \<Longrightarrow> neighborhood v = neighbors_ss v Y"
  unfolding neighborhood_def neighbors_ss_def
  by(auto simp add: X_vert_adj_Y vert_adj_imp_inV)

lemma neighbors_ss_eq_neighborhoodY: "v \<in> Y \<Longrightarrow> neighborhood v = neighbors_ss v X"
  unfolding neighborhood_def neighbors_ss_def
  by(auto simp add: Y_vert_adj_X vert_adj_imp_inV)

lemma neighborhood_subset_oppX: "v \<in> X \<Longrightarrow> neighborhood v \<subseteq> Y"
  using neighbors_ss_eq_neighborhoodX neighbors_ss_def by auto

lemma neighborhood_subset_oppY: "v \<in> Y \<Longrightarrow> neighborhood v \<subseteq> X"
  using neighbors_ss_eq_neighborhoodY neighbors_ss_def by auto

lemma degree_neighbors_ssX: "v \<in> X \<Longrightarrow> degree v = card (neighbors_ss v Y)"
  using neighbors_ss_eq_neighborhoodX alt_deg_neighborhood by auto

lemma degree_neighbors_ssY: "v \<in> Y \<Longrightarrow> degree v = card (neighbors_ss v X)"
  using neighbors_ss_eq_neighborhoodY alt_deg_neighborhood by auto

definition is_bicomplete:: "bool" where
"is_bicomplete \<equiv> E = all_bi_edges X Y"

lemma edge_betw_indiv:
  assumes "e \<in> E"
  obtains x y where "x \<in> X \<and> y \<in> Y \<and> e = {x, y}"
proof -
  have "e \<in> {{x, y} | x y. x \<in> X \<and> y \<in> Y }"
    using edge_betw all_bi_edges_alt2 assms by blast
  thus ?thesis
    using that by auto
qed

lemma edges_between_equals_edge_set: "mk_edge ` (all_edges_between X Y) = E"
  by (simp add: all_edges_between_set, intro subset_antisym subsetI, auto) (metis edge_betw_indiv)

text \<open> Lemmas for reasoning on walks and paths in a bipartite graph \<close>
lemma walk_alternates:
  assumes "is_walk w"
  assumes "Suc i < length w" "i \<ge> 0"
  shows "w ! i \<in> X \<longleftrightarrow> w ! (i + 1) \<in> Y"
proof -
  have "{w ! i, w ! (i +1)} \<in> E" using is_walk_index assms by auto
  then show ?thesis
    using X_vert_adj_Y not_vert_adj Y_vert_adj_X vert_adj_sym by blast
qed

text \<open>A useful reasoning pattern to mimic "wlog" statements for properties that are symmetric
is to interpret the symmetric bipartite graph and then directly apply the lemma proven earlier\<close>
lemma walk_alternates_sym:
  assumes "is_walk w"
  assumes "Suc i < length w" "i \<ge> 0"
  shows "w ! i \<in> Y \<longleftrightarrow> w ! (i + 1) \<in> X"
proof -
  interpret sym: bipartite_graph V E Y X using bipartite_sym by simp
  show ?thesis using sym.walk_alternates assms by simp
qed

lemma walk_length_even:
  assumes "is_walk w"
  assumes "hd w \<in> X" and "last w \<in> X"
  shows "even (walk_length w)"
  using assms
proof (induct "length w" arbitrary: w rule: nat_induct2)
  case 0
  then show ?case by (auto simp add: is_walk_def)
next
  case 1
  then have "walk_length w = 0" using walk_length_conv by auto
  then show ?case by simp
next
  case (step n)
  then show ?case proof (cases "n = 0")
    case True
    then have "length w = 2" using step by simp
    then have "hd w \<in> X \<Longrightarrow> last w \<in> Y" using walk_alternates hd_conv_nth last_conv_nth
      by (metis add_0 add_diff_cancel_right' less_2_cases_iff list.size(3) nat_1_add_1 step.prems(1)
          zero_le zero_neq_numeral)
    then show ?thesis
      using part_intersect_empty step.prems(2) step.prems(3) by blast
  next
    case False
    have IH: "(\<And>w. n = length w \<Longrightarrow> is_walk w \<Longrightarrow> hd w \<in> X \<Longrightarrow> last w \<in> X \<Longrightarrow> even (walk_length w))"
      using step by simp
    obtain w1 w2 where weq: "w = w1@w2" and w1: "w1 = take n w" and w2: "w2 = drop n w"
      by simp
    then have ne: "w1 \<noteq> []" using False is_walk_not_empty2 step.prems(1) by fastforce
    then have w1_walk: "is_walk w1" using w1 is_walk_take False
      by (metis nat_le_linear neq0_conv step.prems(1) take_all)
    have hdw1: "hd w1 \<in> X" using step ne weq by auto
    then have w1n: "length w1 = n" using step length_take w1 by auto
    then have "length w2 = 2" using step length_drop
      by (simp add: w2)
    have "last w = w ! (n + 1)" using step last_conv_nth is_walk_not_empty
      by (metis add.left_commute diff_add_inverse nat_1_add_1)
    then have "w ! n \<in> Y" using step by (simp add: walk_alternates_sym)
    then have "w ! (n - 1) \<in> X" using False walk_alternates step by simp
    then have "last w1 \<in> X" using step last_conv_nth[of w1] ne w1n
      by (metis last_list_update list_update_id take_update_swap w1)
    then have "even (walk_length w1)" using w1_walk w1n hdw1 IH[of w1] by simp
    then have "even (walk_length w1 + 2)" by simp
    then show ?thesis using walk_length_conv weq step
      by (simp add: False w1n)
  qed
qed

lemma walk_length_even_sym:
  assumes "is_walk w"
  assumes "hd w \<in> Y"
  assumes "last w \<in> Y"
  shows "even (walk_length w)"
proof -
  interpret sym: bipartite_graph V E Y X using bipartite_sym by simp
  show ?thesis using sym.walk_length_even assms by auto
qed

lemma walk_length_odd:
  assumes "is_walk w"
  assumes "hd w \<in> X" and "last w \<in> Y"
  shows "odd (walk_length w)"
  using assms
proof (cases "length w \<ge> 2")
  case True
  then have hdin: "hd (tl w) \<in> Y" using walk_alternates hd_conv_nth
    by (metis (mono_tags, lifting) Suc_1 Suc_less_eq2 assms(1) assms(2) is_walk_not_empty2 is_walk_tl
        le_neq_implies_less le_numeral_extra(3) length_greater_0_conv less_Suc_eq nth_tl
        numeral_1_eq_Suc_0 numerals(1) plus_nat.add_0)
  have w: "is_walk (tl w)" using assms True is_walk_tl by auto
  have last: "last (tl w) \<in> Y" using assms(3) by (simp add: is_walk_not_empty last_tl w)
  then have ev: "even (walk_length (tl w))" using hdin w  walk_length_even_sym[of "tl w"] by auto
  then have "walk_length w = walk_length (tl w) + 1" using True walk_length_conv by auto
  then show ?thesis using ev by simp
next
  case False
  have "length w \<noteq> 0" using is_walk_not_empty assms by simp
  then have "length w = 1" using False by linarith
  then have "hd w = last w"
    using \<open>length w \<noteq> 0\<close> hd_conv_nth last_conv_nth by fastforce
  then have "hd w \<in> X \<Longrightarrow> last w \<notin> Y" using part_intersect_empty by auto
  then show ?thesis using assms by simp
qed

lemma walk_length_odd_sym:
  assumes "is_walk w"
  assumes "hd w \<in> Y" and "last w \<in> X"
  shows "odd (walk_length w)"
proof -
  interpret sym: bipartite_graph V E Y X using bipartite_sym by simp
  show ?thesis using assms sym.walk_length_odd by simp
qed

lemma walk_length_even_iff:
  assumes "is_walk w"
  shows "even (walk_length w) \<longleftrightarrow> (hd w \<in> X \<and> last w \<in> X) \<or> (hd w \<in> Y \<and> last w \<in> Y)"
proof (intro iffI)
  assume ev: "even (walk_length w)"
  show "hd w \<in> X \<and> last w \<in> X \<or> hd w \<in> Y \<and> last w \<in> Y"
  proof (rule ccontr)
    assume "\<not> ((hd w \<in> X \<and> last w \<in> X) \<or> (hd w \<in> Y \<and> last w \<in> Y))"
    then have "(hd w \<notin> X \<or> last w \<notin> X) \<and> (hd w \<notin> Y \<or> last w \<notin> Y)" by simp
    then have "(hd w \<in> Y \<or> last w \<in> Y) \<and> (hd w \<in> X \<or> last w \<in> X)" using part_intersect_empty
      using XY_union assms is_walk_wf_hd is_walk_wf_last by auto
    then have split: "(hd w \<in> X \<and> last w \<in> Y) \<or> (hd w \<in> Y \<and> last w \<in> X)"
      using part_intersect_empty by auto
    have o1: "(hd w \<in> X \<and> last w \<in> Y) \<Longrightarrow> odd (walk_length w)" using walk_length_odd assms by auto
    have "(hd w \<in> Y \<and> last w \<in> X) \<Longrightarrow> odd (walk_length w)" using walk_length_odd_sym assms by auto
    then show False using split ev o1 by auto
  qed
next
  show "(hd w \<in> X \<and> last w \<in> X) \<or> (hd w \<in> Y \<and> last w \<in> Y) \<Longrightarrow> even (walk_length w)"
    using walk_length_even walk_length_even_sym assms by auto
qed

lemma walk_length_odd_iff:
  assumes "is_walk w"
  shows "odd (walk_length w) \<longleftrightarrow> (hd w \<in> X \<and> last w \<in> Y) \<or> (hd w \<in> Y \<and> last w \<in> X)"
proof (intro iffI)
  assume o: "odd (walk_length w)"
  show "(hd w \<in> X \<and> last w \<in> Y) \<or> (hd w \<in> Y \<and> last w \<in> X)"
  proof (rule ccontr)
    assume "\<not> ((hd w \<in> X \<and> last w \<in> Y) \<or> (hd w \<in> Y \<and> last w \<in> X))"
    then have "(hd w \<notin> X \<or> last w \<notin> Y) \<and> (hd w \<notin> Y \<or> last w \<notin> X)" by simp
    then have "(hd w \<in> Y \<or> last w \<in> X) \<and> (hd w \<in> X \<or> last w \<in> Y)" using part_intersect_empty
      using XY_union assms is_walk_wf_hd is_walk_wf_last by auto
    then have split: "(hd w \<in> X \<and> last w \<in> X) \<or> (hd w \<in> Y \<and> last w \<in> Y)"
      using part_intersect_empty by auto
    have e1: "(hd w \<in> X \<and> last w \<in> X) \<Longrightarrow> even (walk_length w)" using walk_length_even assms by auto
    have "(hd w \<in> Y \<and> last w \<in> Y) \<Longrightarrow> even (walk_length w)" using walk_length_even_sym assms by auto
    then show False using split o e1 by auto
  qed
next
  show "(hd w \<in> X \<and> last w \<in> Y) \<or> (hd w \<in> Y \<and> last w \<in> X) \<Longrightarrow> odd (walk_length w)"
    using walk_length_odd walk_length_odd_sym assms by auto
qed

text \<open> Classic basic theorem that a bipartite graph must not have any cycles with an odd length \<close>
lemma no_odd_cycles:
  assumes "is_walk w"
  assumes "odd (walk_length w)"
  shows "\<not> is_cycle w"
proof -
  have "(hd w \<in> X \<and> last w \<in> Y) \<or> (hd w \<in> Y \<and> last w \<in> X)" using assms walk_length_odd_iff by auto
  then have "hd w \<noteq> last w" using part_intersect_empty by auto
  thus ?thesis using is_cycle_def is_closed_walk_def by simp
qed

end

text \<open> A few properties rely on cardinality definitions that require the vertex sets to be finite \<close>

locale fin_bipartite_graph = bipartite_graph + fin_graph_system
begin

lemma fin_bipartite_sym: "fin_bipartite_graph V E Y X"
  by (intro_locales) (simp add: bipartite_sym bipartite_graph.axioms(2))

lemma partitions_finite: "finite X" "finite Y"
  using partitions_ss finite_subset finV by auto

lemma card_edges_between_set: "card (all_edges_between X Y) = card E"
proof -
  have "card (all_edges_between X Y) = card (mk_edge ` (all_edges_between X Y))"
    using inj_on_mk_edge using partitions_finite card_image
    by (metis inj_on_mk_edge part_intersect_empty)
  then show ?thesis by (simp add: edges_between_equals_edge_set)
qed

lemma density_simp: "density = card (E) / ((card X) * (card Y))"
  unfolding edge_density_def using card_edges_between_set by auto

lemma edge_size_degree_sumY: "card E = (\<Sum>y \<in> Y . degree y)"
proof -
  have "(\<Sum>y \<in> Y . degree y) = (\<Sum>y \<in> Y . card(neighbors_ss y X))"
    using degree_neighbors_ssY by (simp)
  also have "... = card (all_edges_between X Y)"
    using card_all_edges_betw_neighbor
    by (metis card_all_edges_between_commute partitions_finite(1) partitions_finite(2))
  finally show ?thesis
    by (simp add: card_edges_between_set)
qed

lemma edge_size_degree_sumX: "card E = (\<Sum>y \<in> X . degree y)"
proof -
  interpret sym: fin_bipartite_graph V E Y X
    using fin_bipartite_sym by simp
  show ?thesis using sym.edge_size_degree_sumY by simp
qed

end
end


(* Author: Tobias Nipkow *)

section \<open>Association List Update and Deletion\<close>

theory AList_Upd_Del
imports Sorted_Less
begin

abbreviation "sorted1 ps \<equiv> sorted(map fst ps)"

text\<open>Define own \<open>map_of\<close> function to avoid pulling in an unknown
amount of lemmas implicitly (via the simpset).\<close>

hide_const (open) map_of

fun map_of :: "('a*'b)list \<Rightarrow> 'a \<Rightarrow> 'b option" where
"map_of [] = (\<lambda>x. None)" |
"map_of ((a,b)#ps) = (\<lambda>x. if x=a then Some b else map_of ps x)"

text \<open>Updating an association list:\<close>

fun upd_list :: "'a::linorder \<Rightarrow> 'b \<Rightarrow> ('a*'b) list \<Rightarrow> ('a*'b) list" where
"upd_list x y [] = [(x,y)]" |
"upd_list x y ((a,b)#ps) =
  (if x < a then (x,y)#(a,b)#ps else
  if x = a then (x,y)#ps else (a,b) # upd_list x y ps)"

fun del_list :: "'a::linorder \<Rightarrow> ('a*'b)list \<Rightarrow> ('a*'b)list" where
"del_list x [] = []" |
"del_list x ((a,b)#ps) = (if x = a then ps else (a,b) # del_list x ps)"

subsection \<open>Lemmas for \<^const>\<open>map_of\<close>\<close>

lemma map_of_ins_list: "map_of (upd_list x y ps) = (map_of ps)(x := Some y)"
by(induction ps) auto

lemma map_of_append: "map_of (ps @ qs) x =
  (case map_of ps x of None \<Rightarrow> map_of qs x | Some y \<Rightarrow> Some y)"
by(induction ps)(auto)

lemma map_of_None: "sorted (x # map fst ps) \<Longrightarrow> map_of ps x = None"
by (induction ps) (fastforce simp: sorted_lems sorted_wrt_Cons)+

lemma map_of_None2: "sorted (map fst ps @ [x]) \<Longrightarrow> map_of ps x = None"
by (induction ps) (auto simp: sorted_lems)

lemma map_of_del_list: "sorted1 ps \<Longrightarrow>
  map_of(del_list x ps) = (map_of ps)(x := None)"
by(induction ps) (auto simp: map_of_None sorted_lems fun_eq_iff)

lemma map_of_sorted_Cons: "sorted (a # map fst ps) \<Longrightarrow> x < a \<Longrightarrow>
   map_of ps x = None"
by (simp add: map_of_None sorted_Cons_le)

lemma map_of_sorted_snoc: "sorted (map fst ps @ [a]) \<Longrightarrow> a \<le> x \<Longrightarrow>
  map_of ps x = None"
by (simp add: map_of_None2 sorted_snoc_le)

lemmas map_of_sorteds = map_of_sorted_Cons map_of_sorted_snoc
lemmas map_of_simps = sorted_lems map_of_append map_of_sorteds

subsection \<open>Lemmas for \<^const>\<open>upd_list\<close>\<close>

lemma sorted_upd_list: "sorted1 ps \<Longrightarrow> sorted1 (upd_list x y ps)"
apply(induction ps)
 apply simp
apply(case_tac ps)
 apply auto
done

lemma upd_list_sorted: "sorted1 (ps @ [(a,b)]) \<Longrightarrow>
  upd_list x y (ps @ (a,b) # qs) =
    (if x < a then upd_list x y ps @ (a,b) # qs
    else ps @ upd_list x y ((a,b) # qs))"
by(induction ps) (auto simp: sorted_lems)

text\<open>In principle, @{thm upd_list_sorted} suffices, but the following two
corollaries speed up proofs.\<close>

corollary upd_list_sorted1: "\<lbrakk> sorted (map fst ps @ [a]); x < a \<rbrakk> \<Longrightarrow>
  upd_list x y (ps @ (a,b) # qs) =  upd_list x y ps @ (a,b) # qs"
by (auto simp: upd_list_sorted)

corollary upd_list_sorted2: "\<lbrakk> sorted (map fst ps @ [a]); a \<le> x \<rbrakk> \<Longrightarrow>
  upd_list x y (ps @ (a,b) # qs) = ps @ upd_list x y ((a,b) # qs)"
by (auto simp: upd_list_sorted)

lemmas upd_list_simps = sorted_lems upd_list_sorted1 upd_list_sorted2

text\<open>Splay trees need two additional \<^const>\<open>upd_list\<close> lemmas:\<close>

lemma upd_list_Cons:
  "sorted1 ((x,y) # xs) \<Longrightarrow> upd_list x y xs = (x,y) # xs"
by (induction xs) auto

lemma upd_list_snoc:
  "sorted1 (xs @ [(x,y)]) \<Longrightarrow> upd_list x y xs = xs @ [(x,y)]"
by(induction xs) (auto simp add: sorted_mid_iff2)

subsection \<open>Lemmas for \<^const>\<open>del_list\<close>\<close>

lemma sorted_del_list: "sorted1 ps \<Longrightarrow> sorted1 (del_list x ps)"
apply(induction ps)
 apply simp
apply(case_tac ps)
apply (auto simp: sorted_Cons_le)
done

lemma del_list_idem: "x \<notin> set(map fst xs) \<Longrightarrow> del_list x xs = xs"
by (induct xs) auto

lemma del_list_sorted: "sorted1 (ps @ (a,b) # qs) \<Longrightarrow>
  del_list x (ps @ (a,b) # qs) =
    (if x < a then del_list x ps @ (a,b) # qs
     else ps @ del_list x ((a,b) # qs))"
by(induction ps)
  (fastforce simp: sorted_lems sorted_wrt_Cons intro!: del_list_idem)+

text\<open>In principle, @{thm del_list_sorted} suffices, but the following
corollaries speed up proofs.\<close>

corollary del_list_sorted1: "sorted1 (xs @ (a,b) # ys) \<Longrightarrow> a \<le> x \<Longrightarrow>
  del_list x (xs @ (a,b) # ys) = xs @ del_list x ((a,b) # ys)"
by (auto simp: del_list_sorted)

lemma del_list_sorted2: "sorted1 (xs @ (a,b) # ys) \<Longrightarrow> x < a \<Longrightarrow>
  del_list x (xs @ (a,b) # ys) = del_list x xs @ (a,b) # ys"
by (auto simp: del_list_sorted)

lemma del_list_sorted3:
  "sorted1 (xs @ (a,a') # ys @ (b,b') # zs) \<Longrightarrow> x < b \<Longrightarrow>
  del_list x (xs @ (a,a') # ys @ (b,b') # zs) = del_list x (xs @ (a,a') # ys) @ (b,b') # zs"
by (auto simp: del_list_sorted sorted_lems)

lemma del_list_sorted4:
  "sorted1 (xs @ (a,a') # ys @ (b,b') # zs @ (c,c') # us) \<Longrightarrow> x < c \<Longrightarrow>
  del_list x (xs @ (a,a') # ys @ (b,b') # zs @ (c,c') # us) = del_list x (xs @ (a,a') # ys @ (b,b') # zs) @ (c,c') # us"
by (auto simp: del_list_sorted sorted_lems)

lemma del_list_sorted5:
  "sorted1 (xs @ (a,a') # ys @ (b,b') # zs @ (c,c') # us @ (d,d') # vs) \<Longrightarrow> x < d \<Longrightarrow>
   del_list x (xs @ (a,a') # ys @ (b,b') # zs @ (c,c') # us @ (d,d') # vs) =
   del_list x (xs @ (a,a') # ys @ (b,b') # zs @ (c,c') # us) @ (d,d') # vs"
by (auto simp: del_list_sorted sorted_lems)

lemmas del_list_simps = sorted_lems
  del_list_sorted1
  del_list_sorted2
  del_list_sorted3
  del_list_sorted4
  del_list_sorted5

text\<open>Splay trees need two additional \<^const>\<open>del_list\<close> lemmas:\<close>

lemma del_list_notin_Cons: "sorted (x # map fst xs) \<Longrightarrow> del_list x xs = xs"
by(induction xs)(fastforce simp: sorted_wrt_Cons)+

lemma del_list_sorted_app:
  "sorted(map fst xs @ [x]) \<Longrightarrow> del_list x (xs @ ys) = xs @ del_list x ys"
by (induction xs) (auto simp: sorted_mid_iff2)

end


theory Kyber_spec
imports Main "HOL-Computational_Algebra.Computational_Algebra"
  "HOL-Computational_Algebra.Polynomial_Factorial"
  "Berlekamp_Zassenhaus.Poly_Mod"
  "Berlekamp_Zassenhaus.Poly_Mod_Finite_Field"

begin
section \<open>Type Class for Factorial Ring $\mathbb{Z}_q[x]/(x^n+1)$.\<close>
text \<open>The Kyber algorithms work over the quotient ring $\mathbb{Z}_q[x]/(x^n+1)$
where $q$ is a prime with $q\equiv 1 \mod 4$ and $n$ is a power of $2$.
We encode this quotient ring as a type. In order to do so, we first look at the
finite field $\mathbb{Z}_q$ implemented by \<open>('a::prime_card) mod_ring\<close>.
Then we define polynomials using the constructor \<open>poly\<close>.
For factoring out $x^n+1$, we define an equivalence relation on the polynomial ring
$\mathbb{Z}_q[x]$ via the modulo operation with modulus $x^n+1$.
Finally, we build the quotient of the equivalence relation using the construction
\<open>quotient_type\<close>.\<close>
text \<open>The module $\mathbb{Z}_q[x]/(x^n+1)$ was formalized with help from Manuel Eberl.\<close>

text \<open>Modulo relation between two polynomials. \<close>
lemma of_int_mod_ring_eq_0_iff:
  "(of_int n :: ('n :: {finite, nontriv} mod_ring)) = 0 \<longleftrightarrow>
    int (CARD('n)) dvd n"
  by transfer auto

lemma of_int_mod_ring_eq_of_int_iff:
  "(of_int n :: ('n :: {finite, nontriv} mod_ring)) = of_int m \<longleftrightarrow>
    [n = m] (mod (int (CARD('n))))"
  by transfer (auto simp: cong_def)

definition mod_poly_rel :: "nat \<Rightarrow> int poly \<Rightarrow> int poly \<Rightarrow> bool" where
  "mod_poly_rel m p q \<longleftrightarrow>
    (\<forall>n. [poly.coeff p n = poly.coeff q n] (mod (int m)))"

lemma mod_poly_rel_altdef:
  "mod_poly_rel CARD('n :: nontriv) p q \<longleftrightarrow>
    (of_int_poly p) = (of_int_poly q :: 'n mod_ring poly)"
  by (auto simp: poly_eq_iff mod_poly_rel_def
    of_int_mod_ring_eq_of_int_iff)

definition mod_poly_is_unit :: "nat \<Rightarrow> int poly \<Rightarrow> bool" where
  "mod_poly_is_unit m p \<longleftrightarrow> (\<exists>r. mod_poly_rel m (p * r) 1)"

lemma mod_poly_is_unit_altdef:
  "mod_poly_is_unit CARD('n :: nontriv) p \<longleftrightarrow>
    (of_int_poly p :: 'n mod_ring poly) dvd 1"
proof
  assume "mod_poly_is_unit CARD('n) p"
  thus "(of_int_poly p :: 'n mod_ring poly) dvd 1"
    by (auto simp: mod_poly_is_unit_def dvd_def mod_poly_rel_altdef
      of_int_poly_hom.hom_mult)
next
  assume "(of_int_poly p :: 'n mod_ring poly) dvd 1"
  then obtain q where q: "(of_int_poly p :: 'n mod_ring poly) * q = 1"
    by auto
  also have "q = of_int_poly (map_poly to_int_mod_ring q)"
    by (simp add: of_int_of_int_mod_ring poly_eqI)
  also have "of_int_poly p * \<dots> =
      of_int_poly (p * map_poly to_int_mod_ring q)"
    by (simp add: of_int_poly_hom.hom_mult)
  finally show "mod_poly_is_unit CARD('n) p"
    by (auto simp: mod_poly_is_unit_def mod_poly_rel_altdef)
qed

definition mod_poly_irreducible :: "nat \<Rightarrow> int poly \<Rightarrow> bool" where
  "mod_poly_irreducible m Q \<longleftrightarrow>
     \<not>mod_poly_rel m Q 0 \<and>
     \<not>mod_poly_is_unit m Q \<and>
        (\<forall>a b. mod_poly_rel m Q (a * b) \<longrightarrow>
               mod_poly_is_unit m a \<or> mod_poly_is_unit m b)"

lemma of_int_poly_to_int_poly: "of_int_poly (to_int_poly p) = p"
  by (simp add: of_int_of_int_mod_ring poly_eqI)

lemma mod_poly_irreducible_altdef:
  "mod_poly_irreducible CARD('n :: nontriv) p \<longleftrightarrow>
    irreducible (of_int_poly p :: 'n mod_ring poly)"
proof
  assume "irreducible (of_int_poly p :: 'n mod_ring poly)"
  thus "mod_poly_irreducible CARD('n) p"
    by (auto simp: mod_poly_irreducible_def mod_poly_rel_altdef
    mod_poly_is_unit_altdef irreducible_def of_int_poly_hom.hom_mult)
next
  assume *: "mod_poly_irreducible CARD('n) p"
  show "irreducible (of_int_poly p :: 'n mod_ring poly)"
    unfolding irreducible_def
  proof (intro conjI impI allI)
    fix a b assume ab: "(of_int_poly p :: 'n mod_ring poly) = a * b"
    have "of_int_poly (map_poly to_int_mod_ring a *
      map_poly to_int_mod_ring b) =
      of_int_poly (map_poly to_int_mod_ring a) *
      (of_int_poly (map_poly to_int_mod_ring b) :: 'n mod_ring poly)"
      by (simp add: of_int_poly_hom.hom_mult)
    also have "\<dots> = a * b"
      by (simp add: of_int_poly_to_int_poly)
    also have "\<dots> = of_int_poly p"
      using ab by simp
    finally have "(of_int_poly p :: 'n mod_ring poly) =
      of_int_poly (to_int_poly a * to_int_poly b)" ..
    hence "of_int_poly (to_int_poly a) dvd (1 :: 'n mod_ring poly) \<or>
           of_int_poly (to_int_poly b) dvd (1 :: 'n mod_ring poly)"
      using * unfolding mod_poly_irreducible_def mod_poly_rel_altdef
        mod_poly_is_unit_altdef by blast
    thus "(a dvd (1 :: 'n mod_ring poly)) \<or>
      (b dvd (1 :: 'n mod_ring poly))"
      by (simp add: of_int_poly_to_int_poly)
  qed (use * in \<open>auto simp: mod_poly_irreducible_def
    mod_poly_rel_altdef mod_poly_is_unit_altdef\<close>)
qed

text \<open>Type class for quotient ring $\mathbb{Z}_q[x]/(p)$.
  The polynomial p is represented as \<open>qr_poly'\<close> (an polynomial over the integers).\<close>

class qr_spec = prime_card +
  fixes qr_poly' :: "'a itself \<Rightarrow> int poly"
  assumes not_dvd_lead_coeff_qr_poly':
      "\<not>int CARD('a) dvd lead_coeff (qr_poly' TYPE('a))"
  and deg_qr'_pos : "degree (qr_poly' TYPE('a)) > 0"

text \<open>\<open>qr_poly\<close> is the respective polynomial in $\mathbb{Z}_q[x]$.\<close>
definition qr_poly :: "'a :: qr_spec mod_ring poly" where
  "qr_poly = of_int_poly (qr_poly' TYPE('a))"

text \<open>Functions to get the degree of the polynomials to be factored out.\<close>
definition (in qr_spec) deg_qr :: "'a itself \<Rightarrow> nat" where
  "deg_qr _ = degree (qr_poly' TYPE('a))"

lemma degree_qr_poly':
  "degree (qr_poly' TYPE('a :: qr_spec)) = deg_qr (TYPE('a))"
  by (simp add: deg_qr_def)

lemma degree_of_int_poly':
  assumes "of_int (lead_coeff p) \<noteq> (0 :: 'a :: ring_1)"
  shows "degree (of_int_poly p :: 'a poly) = degree p"
proof (intro antisym)
  show "degree (of_int_poly p) \<le> degree p"
    by (intro degree_le) (auto simp: coeff_eq_0)
  show "degree (of_int_poly p :: 'a poly) \<ge> degree p"
    using assms by (intro le_degree) auto
qed

lemma degree_qr_poly:
  "degree (qr_poly :: 'a :: qr_spec mod_ring poly) = deg_qr (TYPE('a))"
  unfolding qr_poly_def
  using not_dvd_lead_coeff_qr_poly'[where ?'a = 'a]
  by (subst degree_of_int_poly')
     (auto simp: of_int_mod_ring_eq_0_iff degree_qr_poly')

lemma deg_qr_pos : "deg_qr TYPE('a :: qr_spec) > 0"
by (metis deg_qr'_pos degree_qr_poly')

text \<open>The factor polynomial is non-zero.\<close>
lemma qr_poly_nz [simp]: "qr_poly \<noteq> 0"
  using deg_qr_pos[where ?'a = 'a] by (auto simp flip: degree_qr_poly)

text \<open>Thus, when factoring out $p$, it has no effect on the neutral element $1$.\<close>
lemma one_mod_qr_poly [simp]:
  "1 mod (qr_poly :: 'a :: qr_spec mod_ring poly) = 1"
proof -
  have "2 ^ 1 \<le> (2 ^ deg_qr TYPE('a) :: nat)"
    using deg_qr_pos[where ?'a = 'a]
    by (intro power_increasing) auto
  thus ?thesis
    by (intro mod_eqI[where q = 0])
       (auto simp: euclidean_size_poly_def degree_qr_poly)
qed

text \<open>We define a modulo relation for polynomials modulo a polynomial $p=$\<open>qr_poly\<close>.\<close>
definition qr_rel :: "'a :: qr_spec mod_ring poly \<Rightarrow> 'a mod_ring poly \<Rightarrow> bool" where
  "qr_rel P Q \<longleftrightarrow> [P = Q] (mod qr_poly)"

lemma equivp_qr_rel: "equivp qr_rel"
  by (intro equivpI sympI reflpI transpI)
     (auto simp: qr_rel_def cong_sym intro: cong_trans)

text \<open>Using this equivalence relation, we can define the quotient ring as a \<open>quotient_type\<close>.\<close>
quotient_type (overloaded) 'a qr = "'a :: qr_spec mod_ring poly" / qr_rel
  by (rule equivp_qr_rel)

text \<open>Defining the conversion functions.\<close>
lift_definition to_qr :: "'a :: qr_spec mod_ring poly \<Rightarrow> 'a qr"
  is "\<lambda>x. (x :: 'a mod_ring poly)" .

lift_definition of_qr :: "'a qr \<Rightarrow> 'a :: qr_spec mod_ring poly"
  is "\<lambda>P::'a mod_ring poly. P mod qr_poly"
  by (simp add: qr_rel_def cong_def)

text \<open>Simplification lemmas on conversion functions.\<close>
lemma of_qr_to_qr: "of_qr (to_qr (x)) = x mod qr_poly"
  apply (auto simp add: of_qr_def to_qr_def)
  by (metis of_qr.abs_eq of_qr.rep_eq)

lemma to_qr_of_qr: "to_qr (of_qr (x)) = x"
  apply (auto simp add: of_qr_def to_qr_def)
  by (metis (mono_tags, lifting) Quotient3_abs_rep Quotient3_qr
    Quotient3_rel cong_def qr_rel_def mod_mod_trivial)

lemma eq_to_qr: "x = y \<Longrightarrow> to_qr x = to_qr y" by auto

text \<open>Type class instantiation for \<open>qr\<close> (quotient ring).\<close>
instantiation qr :: (qr_spec) comm_ring_1
begin

lift_definition zero_qr :: "'a qr" is "0" .

lift_definition one_qr :: "'a qr" is "1" .

lift_definition plus_qr :: "'a qr \<Rightarrow> 'a qr \<Rightarrow> 'a qr"
  is "(+)"
  unfolding qr_rel_def using cong_add by blast

lift_definition uminus_qr :: "'a qr \<Rightarrow> 'a qr"
  is "uminus"
  unfolding qr_rel_def  using cong_minus_minus_iff by blast

lift_definition minus_qr :: "'a qr \<Rightarrow> 'a qr \<Rightarrow> 'a qr"
  is "(-)"
  unfolding qr_rel_def using cong_diff by blast

lift_definition times_qr :: "'a qr \<Rightarrow> 'a qr \<Rightarrow> 'a qr"
  is "(*)"
  unfolding qr_rel_def using cong_mult by blast

instance
proof
  show "0 \<noteq> (1 :: 'a qr)"
    by transfer (simp add: qr_rel_def cong_def)
qed (transfer; simp add: qr_rel_def algebra_simps; fail)+

end

lemma of_qr_0 [simp]: "of_qr 0 = 0"
  and of_qr_1 [simp]: "of_qr 1 = 1"
  and of_qr_uminus [simp]: "of_qr (-p) = -of_qr p"
  and of_qr_add [simp]: "of_qr (p + q) = of_qr p + of_qr q"
  and of_qr_diff [simp]: "of_qr (p - q) = of_qr p - of_qr q"
  by (transfer; simp add: poly_mod_add_left poly_mod_diff_left; fail)+

lemma to_qr_0 [simp]: "to_qr 0 = 0"
  and to_qr_1 [simp]: "to_qr 1 = 1"
  and to_qr_uminus [simp]: "to_qr (-p) = -to_qr p"
  and to_qr_add [simp]: "to_qr (p + q) = to_qr p + to_qr q"
  and to_qr_diff [simp]: "to_qr (p - q) = to_qr p - to_qr q"
  and to_qr_mult [simp]: "to_qr (p * q) = to_qr p * to_qr q"
  by (transfer'; simp; fail)+

lemma to_qr_of_nat [simp]: "to_qr (of_nat n) = of_nat n"
  by (induction n) auto

lemma to_qr_of_int [simp]: "to_qr (of_int n) = of_int n"
  by (induction n) auto

lemma of_qr_of_nat [simp]: "of_qr (of_nat n) = of_nat n"
  by (induction n) auto

lemma of_qr_of_int [simp]: "of_qr (of_int n) = of_int n"
  by (induction n) auto

lemma of_qr_eq_0_iff [simp]: "of_qr p = 0 \<longleftrightarrow> p = 0"
  by transfer (simp add: qr_rel_def cong_def)

lemma to_qr_eq_0_iff:
  "to_qr p = 0 \<longleftrightarrow> qr_poly dvd p"
  by transfer (auto simp: qr_rel_def cong_def)

text \<open>Some more lemmas that will probably be useful.\<close>

lemma to_qr_eq_iff [simp]:
  "to_qr P = (to_qr Q :: 'a :: qr_spec qr) \<longleftrightarrow> [P = Q] (mod qr_poly)"
  by transfer (auto simp: qr_rel_def)

text \<open>Reduction modulo $x^n + 1$ is injective on polynomials of degree less than $n$
  in particular, this means that \<open>card(QR(q^n)) = q^n\<close>. \<close>
lemma inj_on_to_qr:
  "inj_on
     (to_qr :: 'a :: qr_spec mod_ring poly \<Rightarrow> 'a qr)
     {P. degree P < deg_qr TYPE('a)}"
  by (intro inj_onI) (auto simp: cong_def mod_poly_less
      simp flip: degree_qr_poly)

text \<open>Characteristic of quotient ring is exactly q.\<close>

lemma of_int_qr_eq_0_iff [simp]:
  "of_int n = (0 :: 'a :: qr_spec qr) \<longleftrightarrow> int (CARD('a)) dvd n"
proof -
  have "of_int n = (0 :: 'a qr) \<longleftrightarrow> (of_int n :: 'a mod_ring poly) = 0"
    by (smt (z3) of_qr_eq_0_iff of_qr_of_int)
  also have "\<dots> \<longleftrightarrow> (of_int n :: 'a mod_ring) = 0"
    by (simp add: of_int_poly)
  also have "\<dots> \<longleftrightarrow> int (CARD('a)) dvd n"
    by (simp add: of_int_mod_ring_eq_0_iff)
  finally show ?thesis .
qed

lemma of_int_qr_eq_of_int_iff:
  "of_int n = (of_int m :: 'a :: qr_spec qr) \<longleftrightarrow>
    [n = m] (mod (int (CARD('a))))"
  using of_int_qr_eq_0_iff[of "n - m", where ?'a = 'a]
  by (simp del: of_int_qr_eq_0_iff add: cong_iff_dvd_diff)

lemma of_nat_qr_eq_of_nat_iff:
  "of_nat n = (of_nat m :: 'a :: qr_spec qr) \<longleftrightarrow>
    [n = m] (mod CARD('a))"
  using of_int_qr_eq_of_int_iff[of "int n" "int m"]
  by (simp add: cong_int_iff)

lemma of_nat_qr_eq_0_iff [simp]:
  "of_nat n = (0 :: 'a :: qr_spec qr) \<longleftrightarrow> CARD('a) dvd n"
  using of_int_qr_eq_0_iff[of "int n"] by simp

section \<open>Specification of Kyber\<close>
text \<open>
We now define a locale for the specification parameters of Kyber as in \cite{kyber}.
The specifications use the parameters:

\begin{tabular}{r l}
$n$ & $=256 = 2^{n'}$\\
$n'$ & $= 8$\\
$q$ & $= 7681$ or $3329$\\
$k$ & $= 3$\\
\end{tabular}

It is important, that $q$ is a prime with the property $q\equiv 1\mod 4$.
\<close>

locale kyber_spec =
fixes "type_a" :: "('a :: qr_spec) itself"
  and "type_k" :: "('k ::finite) itself"
  and n q::int and k n'::nat
assumes
n_powr_2: "n = 2 ^ n'" and
n'_gr_0: "n' > 0" and
q_gr_two: "q > 2" and
q_mod_4: "q mod 4 = 1" and
q_prime : "prime q" and
CARD_a: "int (CARD('a :: qr_spec)) = q" and
CARD_k: "int (CARD('k :: finite)) = k" and
qr_poly'_eq: "qr_poly' TYPE('a) = Polynomial.monom 1 (nat n) + 1"

begin
text \<open>Some properties of the modulus q.\<close>

lemma q_nonzero: "q \<noteq> 0"
using kyber_spec_axioms kyber_spec_def by (smt (z3))

lemma q_gt_zero: "q>0"
using kyber_spec_axioms kyber_spec_def by (smt (z3))

lemma q_gt_two: "q>2"
using kyber_spec_axioms kyber_spec_def by (smt (z3))

lemma q_odd: "odd q"
using kyber_spec_axioms kyber_spec_def
 prime_odd_int by blast

lemma nat_q: "nat q = q"
using q_gt_zero by force

text \<open>Some properties of the degree n.\<close>

lemma n_gt_1: "n > 1"
using kyber_spec_axioms kyber_spec_def
  by (simp add: n'_gr_0 n_powr_2)

lemma n_nonzero: "n \<noteq> 0"
using n_gt_1 by auto

lemma n_gt_zero: "n>0"
using n_gt_1 by auto

lemma nat_n: "nat n = n"
using n_gt_zero by force

text \<open>Properties in the ring \<open>'a qr\<close>. A good representative has degree up to n.\<close>
lemma deg_mod_qr_poly:
  assumes "degree x < deg_qr TYPE('a)"
  shows "x mod (qr_poly :: 'a mod_ring poly) = x"
using mod_poly_less[of x qr_poly] unfolding deg_qr_def
by (metis assms degree_qr_poly)

lemma of_qr_to_qr':
  assumes "degree x < deg_qr TYPE('a)"
  shows "of_qr (to_qr x) = (x ::'a mod_ring poly)"
using deg_mod_qr_poly[OF assms] of_qr_to_qr[of x] by simp

lemma deg_qr_n:
  "deg_qr TYPE('a) = n"
unfolding deg_qr_def using qr_poly'_eq n_gt_1
by (simp add: degree_add_eq_left degree_monom_eq)

lemma deg_of_qr:
  "degree (of_qr (x ::'a qr)) < deg_qr TYPE('a)"
by (metis deg_qr_pos degree_0 degree_qr_poly degree_mod_less'
  qr_poly_nz of_qr.rep_eq)

definition to_module :: "int \<Rightarrow> 'a qr" where
  "to_module x = to_qr (Poly [of_int_mod_ring x ::'a mod_ring])"

lemma to_qr_smult_to_module:
  "to_qr (Polynomial.smult a p) = (to_qr (Poly [a])) * (to_qr p)"
by (metis Poly.simps(1) Poly.simps(2) mult.left_neutral
  mult_smult_left smult_one to_qr_mult)

lemma of_qr_to_qr_smult:
  "of_qr (to_qr (Polynomial.smult a p)) =
  Polynomial.smult a (of_qr (to_qr p))"
by (simp add: mod_smult_left of_qr_to_qr)

end
end


(*<*)
theory Propositional_Logic
imports Abstract_Completeness
begin
(*>*)

section {* Toy instantiation: Propositional Logic *}

datatype fmla = Atom nat | Neg fmla | Conj fmla fmla

primrec max_depth where
  "max_depth (Atom _) = 0"
| "max_depth (Neg \<phi>) = Suc (max_depth \<phi>)"
| "max_depth (Conj \<phi> \<psi>) = Suc (max (max_depth \<phi>) (max_depth \<psi>))"

lemma max_depth_0: "max_depth \<phi> = 0 = (\<exists>n. \<phi> = Atom n)"
  by (cases \<phi>) auto

lemma max_depth_Suc: "max_depth \<phi> = Suc n = ((\<exists>\<psi>. \<phi> = Neg \<psi> \<and> max_depth \<psi> = n) \<or>
  (\<exists>\<psi>1 \<psi>2. \<phi> = Conj \<psi>1 \<psi>2 \<and> max (max_depth \<psi>1) (max_depth \<psi>2) = n))"
  by (cases \<phi>) auto

abbreviation "atoms \<equiv> smap Atom nats"
abbreviation "depth1 \<equiv>
  sinterleave (smap Neg atoms) (smap (case_prod Conj) (sproduct atoms atoms))"

abbreviation "sinterleaves \<equiv> fold sinterleave"

fun extendLevel where "extendLevel (belowN, N) =
  (let Next = sinterleaves
    (map (smap (case_prod Conj)) [sproduct belowN N, sproduct N belowN, sproduct N N])
    (smap Neg N)
  in (sinterleave belowN N, Next))"

lemma extendLevel_step:
  "\<lbrakk>sset belowN = {\<phi>. max_depth \<phi> < n};
    sset N = {\<phi>. max_depth \<phi> = n}; st = (belowN, N)\<rbrakk> \<Longrightarrow>
  \<exists>belowNext Next. extendLevel st = (belowNext, Next) \<and>
     sset belowNext = {\<phi>. max_depth \<phi> < Suc n} \<and> sset Next = {\<phi>. max_depth \<phi> = Suc n}"
  by (auto simp: sset_sinterleave sset_sproduct stream.set_map
    image_iff max_depth_Suc)

lemma sset_atoms: "sset atoms = {\<phi>. max_depth \<phi> < 1}"
  by (auto simp: stream.set_map max_depth_0)

lemma sset_depth1: "sset depth1 = {\<phi>. max_depth \<phi> = 1}"
  by (auto simp: sset_sinterleave sset_sproduct stream.set_map
    max_depth_Suc max_depth_0 max_def image_iff)

lemma extendLevel_Nsteps:
  "\<lbrakk>sset belowN = {\<phi>. max_depth \<phi> < n}; sset N = {\<phi>. max_depth \<phi> = n}\<rbrakk> \<Longrightarrow>
  \<exists>belowNext Next. (extendLevel ^^ m) (belowN, N) = (belowNext, Next) \<and>
     sset belowNext = {\<phi>. max_depth \<phi> < n + m} \<and> sset Next = {\<phi>. max_depth \<phi> = n + m}"
proof (induction m arbitrary: belowN N n)
  case (Suc m)
  then obtain belowNext Next where "(extendLevel ^^ m) (belowN, N) = (belowNext, Next)"
    "sset belowNext = {\<phi>. max_depth \<phi> < n + m}" "sset Next = {\<phi>. max_depth \<phi> = n + m}"
    by blast
  thus ?case unfolding funpow.simps o_apply add_Suc_right
    by (intro extendLevel_step[of belowNext _ Next])
qed simp

corollary extendLevel:
  "\<exists>belowNext Next. (extendLevel ^^ m) (atoms, depth1) = (belowNext, Next) \<and>
     sset belowNext = {\<phi>. max_depth \<phi> < 1 + m} \<and> sset Next = {\<phi>. max_depth \<phi> = 1 + m}"
  by (rule extendLevel_Nsteps) (auto simp: sset_atoms sset_depth1)

definition "fmlas = sinterleave atoms (smerge (smap snd (siterate extendLevel (atoms, depth1))))"

lemma fmlas_UNIV: "sset fmlas = (UNIV :: fmla set)"
proof (intro equalityI subsetI UNIV_I)
  fix \<phi>
  show "\<phi> \<in> sset fmlas"
  proof (cases "max_depth \<phi>")
    case 0 thus ?thesis unfolding fmlas_def sset_sinterleave stream.set_map
      by (intro UnI1) (auto simp: max_depth_0)
  next
    case (Suc m) thus ?thesis using extendLevel[of m]
    unfolding fmlas_def sset_smerge sset_siterate sset_sinterleave stream.set_map
      by (intro UnI2) (auto, metis (mono_tags) mem_Collect_eq)
  qed
qed

datatype rule = Idle | Ax nat | NegL fmla | NegR fmla | ConjL fmla fmla | ConjR fmla fmla

abbreviation "mkRules f \<equiv> smap f fmlas"
abbreviation "mkRulePairs f \<equiv> smap (case_prod f) (sproduct fmlas fmlas)"

definition rules where
  "rules = Idle ##
     sinterleaves [mkRules NegL, mkRules NegR, mkRulePairs ConjL, mkRulePairs ConjR]
     (smap Ax nats)"

lemma rules_UNIV: "sset rules = (UNIV :: rule set)"
  unfolding rules_def by (auto simp: sset_sinterleave sset_sproduct stream.set_map
    fmlas_UNIV image_iff) (metis rule.exhaust)

type_synonym state = "fmla fset * fmla fset"

fun eff' :: "rule \<Rightarrow> state \<Rightarrow> state fset option" where
  "eff' Idle (\<Gamma>, \<Delta>) = Some {|(\<Gamma>, \<Delta>)|}"
| "eff' (Ax n) (\<Gamma>, \<Delta>) =
    (if Atom n |\<in>| \<Gamma> \<and> Atom n |\<in>| \<Delta> then Some {||} else None)"
| "eff' (NegL \<phi>) (\<Gamma>, \<Delta>) =
    (if Neg \<phi> |\<in>| \<Gamma> then Some {|(\<Gamma> |-| {| Neg \<phi> |}, finsert \<phi> \<Delta>)|} else None)"
| "eff' (NegR \<phi>) (\<Gamma>, \<Delta>) =
    (if Neg \<phi> |\<in>| \<Delta> then Some {|(finsert \<phi> \<Gamma>, \<Delta> |-| {| Neg \<phi> |})|} else None)"
| "eff' (ConjL \<phi> \<psi>) (\<Gamma>, \<Delta>) =
    (if Conj \<phi> \<psi> |\<in>| \<Gamma>
    then Some {|(finsert \<phi> (finsert \<psi> (\<Gamma> |-| {| Conj \<phi> \<psi> |})), \<Delta>)|}
    else None)"
| "eff' (ConjR \<phi> \<psi>) (\<Gamma>, \<Delta>) =
    (if Conj \<phi> \<psi> |\<in>| \<Delta>
    then Some {|(\<Gamma>, finsert \<phi> (\<Delta> |-| {| Conj \<phi> \<psi> |})), (\<Gamma>, finsert \<psi> (\<Delta> |-| {| Conj \<phi> \<psi> |}))|}
    else None)"

abbreviation "Disj \<phi> \<psi> \<equiv> Neg (Conj (Neg \<phi>) (Neg \<psi>))"
abbreviation "Imp \<phi> \<psi> \<equiv> Disj (Neg \<phi>) \<psi>"
abbreviation "Iff \<phi> \<psi> \<equiv> Conj (Imp \<phi> \<psi>) (Imp \<psi> \<phi>)"

definition "thm1 \<equiv> ({|Conj (Atom 0) (Neg (Atom 0))|}, {||})"

declare Stream.smember_code [code del]

interpretation RuleSystem "\<lambda>r s ss. eff' r s = Some ss" rules UNIV
  by unfold_locales (auto simp: rules_UNIV intro: exI[of _ Idle])

interpretation PersistentRuleSystem "\<lambda>r s ss. eff' r s = Some ss" rules UNIV
proof (unfold_locales, unfold enabled_def per_def rules_UNIV, clarsimp)
  fix r \<Gamma> \<Delta> ss r' \<Gamma>' \<Delta>' ss'
  assume "r' \<noteq> r" "eff' r (\<Gamma>, \<Delta>) = Some ss" "eff' r' (\<Gamma>, \<Delta>) = Some ss'" "(\<Gamma>', \<Delta>') |\<in>| ss'"
  then show "\<exists>sl. eff' r (\<Gamma>', \<Delta>') = Some sl"
    by (cases r r' rule: rule.exhaust[case_product rule.exhaust]) (auto split: if_splits)
qed

definition "rho \<equiv> i.fenum rules"
definition "propTree \<equiv> i.mkTree eff' rho"

export_code propTree thm1 in Haskell module_name PropInstance (* file "." *)

(*<*)
end
(*>*)