(*  Title:      HOL/Equiv_Relations.thy
    Author:     Lawrence C Paulson, 1996 Cambridge University Computer Laboratory
*)

section \<open>Equivalence Relations in Higher-Order Set Theory\<close>

theory Equiv_Relations
  imports Groups_Big
begin

subsection \<open>Equivalence relations -- set version\<close>

definition equiv :: "'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> bool"
  where "equiv A r \<longleftrightarrow> refl_on A r \<and> sym r \<and> trans r"

lemma equivI: "refl_on A r \<Longrightarrow> sym r \<Longrightarrow> trans r \<Longrightarrow> equiv A r"
  by (simp add: equiv_def)

lemma equivE:
  assumes "equiv A r"
  obtains "refl_on A r" and "sym r" and "trans r"
  using assms by (simp add: equiv_def)

text \<open>
  Suppes, Theorem 70: \<open>r\<close> is an equiv relation iff \<open>r\<inverse> O r = r\<close>.

  First half: \<open>equiv A r \<Longrightarrow> r\<inverse> O r = r\<close>.
\<close>

lemma sym_trans_comp_subset: "sym r \<Longrightarrow> trans r \<Longrightarrow> r\<inverse> O r \<subseteq> r"
  unfolding trans_def sym_def converse_unfold by blast

lemma refl_on_comp_subset: "refl_on A r \<Longrightarrow> r \<subseteq> r\<inverse> O r"
  unfolding refl_on_def by blast

lemma equiv_comp_eq: "equiv A r \<Longrightarrow> r\<inverse> O r = r"
  unfolding equiv_def
  by (iprover intro: sym_trans_comp_subset refl_on_comp_subset equalityI)

text \<open>Second half.\<close>

lemma comp_equivI:
  assumes "r\<inverse> O r = r" "Domain r = A"
  shows "equiv A r"
proof -
  have *: "\<And>x y. (x, y) \<in> r \<Longrightarrow> (y, x) \<in> r"
    using assms by blast
  show ?thesis
    unfolding equiv_def refl_on_def sym_def trans_def
    using assms by (auto intro: *)
qed

subsection \<open>Equivalence classes\<close>

lemma equiv_class_subset: "equiv A r \<Longrightarrow> (a, b) \<in> r \<Longrightarrow> r``{a} \<subseteq> r``{b}"
  \<comment> \<open>lemma for the next result\<close>
  unfolding equiv_def trans_def sym_def by blast

theorem equiv_class_eq: "equiv A r \<Longrightarrow> (a, b) \<in> r \<Longrightarrow> r``{a} = r``{b}"
  by (intro equalityI equiv_class_subset; force simp add: equiv_def sym_def)

lemma equiv_class_self: "equiv A r \<Longrightarrow> a \<in> A \<Longrightarrow> a \<in> r``{a}"
  unfolding equiv_def refl_on_def by blast

lemma subset_equiv_class: "equiv A r \<Longrightarrow> r``{b} \<subseteq> r``{a} \<Longrightarrow> b \<in> A \<Longrightarrow> (a, b) \<in> r"
  \<comment> \<open>lemma for the next result\<close>
  unfolding equiv_def refl_on_def by blast

lemma eq_equiv_class: "r``{a} = r``{b} \<Longrightarrow> equiv A r \<Longrightarrow> b \<in> A \<Longrightarrow> (a, b) \<in> r"
  by (iprover intro: equalityD2 subset_equiv_class)

lemma equiv_class_nondisjoint: "equiv A r \<Longrightarrow> x \<in> (r``{a} \<inter> r``{b}) \<Longrightarrow> (a, b) \<in> r"
  unfolding equiv_def trans_def sym_def by blast

lemma equiv_type: "equiv A r \<Longrightarrow> r \<subseteq> A \<times> A"
  unfolding equiv_def refl_on_def by blast

lemma equiv_class_eq_iff: "equiv A r \<Longrightarrow> (x, y) \<in> r \<longleftrightarrow> r``{x} = r``{y} \<and> x \<in> A \<and> y \<in> A"
  by (blast intro!: equiv_class_eq dest: eq_equiv_class equiv_type)

lemma eq_equiv_class_iff: "equiv A r \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> r``{x} = r``{y} \<longleftrightarrow> (x, y) \<in> r"
  by (blast intro!: equiv_class_eq dest: eq_equiv_class equiv_type)

subsection \<open>Quotients\<close>

definition quotient :: "'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> 'a set set"  (infixl "'/'/" 90)
  where "A//r = (\<Union>x \<in> A. {r``{x}})"  \<comment> \<open>set of equiv classes\<close>

lemma quotientI: "x \<in> A \<Longrightarrow> r``{x} \<in> A//r"
  unfolding quotient_def by blast

lemma quotientE: "X \<in> A//r \<Longrightarrow> (\<And>x. X = r``{x} \<Longrightarrow> x \<in> A \<Longrightarrow> P) \<Longrightarrow> P"
  unfolding quotient_def by blast

lemma Union_quotient: "equiv A r \<Longrightarrow> \<Union>(A//r) = A"
  unfolding equiv_def refl_on_def quotient_def by blast

lemma quotient_disj: "equiv A r \<Longrightarrow> X \<in> A//r \<Longrightarrow> Y \<in> A//r \<Longrightarrow> X = Y \<or> X \<inter> Y = {}"
  unfolding quotient_def equiv_def trans_def sym_def by blast

lemma quotient_eqI:
  assumes "equiv A r" "X \<in> A//r" "Y \<in> A//r" and xy: "x \<in> X" "y \<in> Y" "(x, y) \<in> r"
  shows "X = Y"
proof -
  obtain a b where "a \<in> A" and a: "X = r `` {a}" and "b \<in> A" and b: "Y = r `` {b}"
    using assms by (auto elim!: quotientE)
  then have "(a,b) \<in> r"
      using xy \<open>equiv A r\<close> unfolding equiv_def sym_def trans_def by blast
  then show ?thesis
    unfolding a b by (rule equiv_class_eq [OF \<open>equiv A r\<close>])
qed

lemma quotient_eq_iff:
  assumes "equiv A r" "X \<in> A//r" "Y \<in> A//r" and xy: "x \<in> X" "y \<in> Y"
  shows "X = Y \<longleftrightarrow> (x, y) \<in> r"
proof
  assume L: "X = Y"
  with assms show "(x, y) \<in> r"
    unfolding equiv_def sym_def trans_def by (blast elim!: quotientE)
next
  assume \<section>: "(x, y) \<in> r" show "X = Y"
    by (rule quotient_eqI) (use \<section> assms in \<open>blast+\<close>)
qed

lemma eq_equiv_class_iff2: "equiv A r \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> {x}//r = {y}//r \<longleftrightarrow> (x, y) \<in> r"
  by (simp add: quotient_def eq_equiv_class_iff)

lemma quotient_empty [simp]: "{}//r = {}"
  by (simp add: quotient_def)

lemma quotient_is_empty [iff]: "A//r = {} \<longleftrightarrow> A = {}"
  by (simp add: quotient_def)

lemma quotient_is_empty2 [iff]: "{} = A//r \<longleftrightarrow> A = {}"
  by (simp add: quotient_def)

lemma singleton_quotient: "{x}//r = {r `` {x}}"
  by (simp add: quotient_def)

lemma quotient_diff1: "inj_on (\<lambda>a. {a}//r) A \<Longrightarrow> a \<in> A \<Longrightarrow> (A - {a})//r = A//r - {a}//r"
  unfolding quotient_def inj_on_def by blast

subsection \<open>Refinement of one equivalence relation WRT another\<close>

lemma refines_equiv_class_eq: "R \<subseteq> S \<Longrightarrow> equiv A R \<Longrightarrow> equiv A S \<Longrightarrow> R``(S``{a}) = S``{a}"
  by (auto simp: equiv_class_eq_iff)

lemma refines_equiv_class_eq2: "R \<subseteq> S \<Longrightarrow> equiv A R \<Longrightarrow> equiv A S \<Longrightarrow> S``(R``{a}) = S``{a}"
  by (auto simp: equiv_class_eq_iff)

lemma refines_equiv_image_eq: "R \<subseteq> S \<Longrightarrow> equiv A R \<Longrightarrow> equiv A S \<Longrightarrow> (\<lambda>X. S``X) ` (A//R) = A//S"
   by (auto simp: quotient_def image_UN refines_equiv_class_eq2)

lemma finite_refines_finite:
  "finite (A//R) \<Longrightarrow> R \<subseteq> S \<Longrightarrow> equiv A R \<Longrightarrow> equiv A S \<Longrightarrow> finite (A//S)"
  by (erule finite_surj [where f = "\<lambda>X. S``X"]) (simp add: refines_equiv_image_eq)

lemma finite_refines_card_le:
  "finite (A//R) \<Longrightarrow> R \<subseteq> S \<Longrightarrow> equiv A R \<Longrightarrow> equiv A S \<Longrightarrow> card (A//S) \<le> card (A//R)"
  by (subst refines_equiv_image_eq [of R S A, symmetric])
    (auto simp: card_image_le [where f = "\<lambda>X. S``X"])

subsection \<open>Defining unary operations upon equivalence classes\<close>

text \<open>A congruence-preserving function.\<close>

definition congruent :: "('a \<times> 'a) set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
  where "congruent r f \<longleftrightarrow> (\<forall>(y, z) \<in> r. f y = f z)"

lemma congruentI: "(\<And>y z. (y, z) \<in> r \<Longrightarrow> f y = f z) \<Longrightarrow> congruent r f"
  by (auto simp add: congruent_def)

lemma congruentD: "congruent r f \<Longrightarrow> (y, z) \<in> r \<Longrightarrow> f y = f z"
  by (auto simp add: congruent_def)

abbreviation RESPECTS :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> bool"  (infixr "respects" 80)
  where "f respects r \<equiv> congruent r f"

lemma UN_constant_eq: "a \<in> A \<Longrightarrow> \<forall>y \<in> A. f y = c \<Longrightarrow> (\<Union>y \<in> A. f y) = c"
  \<comment> \<open>lemma required to prove \<open>UN_equiv_class\<close>\<close>
  by auto

lemma UN_equiv_class:
  assumes "equiv A r" "f respects r" "a \<in> A"
  shows "(\<Union>x \<in> r``{a}. f x) = f a"
  \<comment> \<open>Conversion rule\<close>
proof -
  have \<section>: "\<forall>x\<in>r `` {a}. f x = f a"
    using assms unfolding equiv_def congruent_def sym_def by blast
  show ?thesis
    by (iprover intro: assms UN_constant_eq [OF equiv_class_self \<section>])
qed

lemma UN_equiv_class_type:
  assumes r: "equiv A r" "f respects r" and X: "X \<in> A//r" and AB: "\<And>x. x \<in> A \<Longrightarrow> f x \<in> B"
  shows "(\<Union>x \<in> X. f x) \<in> B"
  using assms unfolding quotient_def
  by (auto simp: UN_equiv_class [OF r])

text \<open>
  Sufficient conditions for injectiveness.  Could weaken premises!
  major premise could be an inclusion; \<open>bcong\<close> could be
  \<open>\<And>y. y \<in> A \<Longrightarrow> f y \<in> B\<close>.
\<close>

lemma UN_equiv_class_inject:
  assumes "equiv A r" "f respects r"
    and eq: "(\<Union>x \<in> X. f x) = (\<Union>y \<in> Y. f y)"
    and X: "X \<in> A//r" and Y: "Y \<in> A//r"
    and fr: "\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> f x = f y \<Longrightarrow> (x, y) \<in> r"
  shows "X = Y"
proof -
  obtain a b where "a \<in> A" and a: "X = r `` {a}" and "b \<in> A" and b: "Y = r `` {b}"
    using assms by (auto elim!: quotientE)
  then have "\<Union> (f ` r `` {a}) = f a" "\<Union> (f ` r `` {b}) = f b"
    by (iprover intro: UN_equiv_class [OF \<open>equiv A r\<close>] assms)+
  then have "f a = f b"
    using eq unfolding a b by (iprover intro: trans sym)
  then have "(a,b) \<in> r"
    using fr \<open>a \<in> A\<close> \<open>b \<in> A\<close> by blast
  then show ?thesis
    unfolding a b by (rule equiv_class_eq [OF \<open>equiv A r\<close>])
qed

subsection \<open>Defining binary operations upon equivalence classes\<close>

text \<open>A congruence-preserving function of two arguments.\<close>

definition congruent2 :: "('a \<times> 'a) set \<Rightarrow> ('b \<times> 'b) set \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> bool"
  where "congruent2 r1 r2 f \<longleftrightarrow> (\<forall>(y1, z1) \<in> r1. \<forall>(y2, z2) \<in> r2. f y1 y2 = f z1 z2)"

lemma congruent2I':
  assumes "\<And>y1 z1 y2 z2. (y1, z1) \<in> r1 \<Longrightarrow> (y2, z2) \<in> r2 \<Longrightarrow> f y1 y2 = f z1 z2"
  shows "congruent2 r1 r2 f"
  using assms by (auto simp add: congruent2_def)

lemma congruent2D: "congruent2 r1 r2 f \<Longrightarrow> (y1, z1) \<in> r1 \<Longrightarrow> (y2, z2) \<in> r2 \<Longrightarrow> f y1 y2 = f z1 z2"
  by (auto simp add: congruent2_def)

text \<open>Abbreviation for the common case where the relations are identical.\<close>
abbreviation RESPECTS2:: "('a \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> bool"  (infixr "respects2" 80)
  where "f respects2 r \<equiv> congruent2 r r f"

lemma congruent2_implies_congruent:
  "equiv A r1 \<Longrightarrow> congruent2 r1 r2 f \<Longrightarrow> a \<in> A \<Longrightarrow> congruent r2 (f a)"
  unfolding congruent_def congruent2_def equiv_def refl_on_def by blast

lemma congruent2_implies_congruent_UN:
  assumes "equiv A1 r1" "equiv A2 r2" "congruent2 r1 r2 f" "a \<in> A2"
  shows "congruent r1 (\<lambda>x1. \<Union>x2 \<in> r2``{a}. f x1 x2)"
  unfolding congruent_def
proof clarify
  fix c d
  assume cd: "(c,d) \<in> r1"
  then have "c \<in> A1" "d \<in> A1"
    using \<open>equiv A1 r1\<close> by (auto elim!: equiv_type [THEN subsetD, THEN SigmaE2])
  with assms show "\<Union> (f c ` r2 `` {a}) = \<Union> (f d ` r2 `` {a})"
  proof (simp add: UN_equiv_class congruent2_implies_congruent)
    show "f c a = f d a"
      using assms cd unfolding congruent2_def equiv_def refl_on_def by blast
  qed
qed

lemma UN_equiv_class2:
  "equiv A1 r1 \<Longrightarrow> equiv A2 r2 \<Longrightarrow> congruent2 r1 r2 f \<Longrightarrow> a1 \<in> A1 \<Longrightarrow> a2 \<in> A2 \<Longrightarrow>
    (\<Union>x1 \<in> r1``{a1}. \<Union>x2 \<in> r2``{a2}. f x1 x2) = f a1 a2"
  by (simp add: UN_equiv_class congruent2_implies_congruent congruent2_implies_congruent_UN)

lemma UN_equiv_class_type2:
  "equiv A1 r1 \<Longrightarrow> equiv A2 r2 \<Longrightarrow> congruent2 r1 r2 f
    \<Longrightarrow> X1 \<in> A1//r1 \<Longrightarrow> X2 \<in> A2//r2
    \<Longrightarrow> (\<And>x1 x2. x1 \<in> A1 \<Longrightarrow> x2 \<in> A2 \<Longrightarrow> f x1 x2 \<in> B)
    \<Longrightarrow> (\<Union>x1 \<in> X1. \<Union>x2 \<in> X2. f x1 x2) \<in> B"
  unfolding quotient_def
  by (blast intro: UN_equiv_class_type congruent2_implies_congruent_UN
                   congruent2_implies_congruent quotientI)

lemma UN_UN_split_split_eq:
  "(\<Union>(x1, x2) \<in> X. \<Union>(y1, y2) \<in> Y. A x1 x2 y1 y2) =
    (\<Union>x \<in> X. \<Union>y \<in> Y. (\<lambda>(x1, x2). (\<lambda>(y1, y2). A x1 x2 y1 y2) y) x)"
  \<comment> \<open>Allows a natural expression of binary operators,\<close>
  \<comment> \<open>without explicit calls to \<open>split\<close>\<close>
  by auto

lemma congruent2I:
  "equiv A1 r1 \<Longrightarrow> equiv A2 r2
    \<Longrightarrow> (\<And>y z w. w \<in> A2 \<Longrightarrow> (y,z) \<in> r1 \<Longrightarrow> f y w = f z w)
    \<Longrightarrow> (\<And>y z w. w \<in> A1 \<Longrightarrow> (y,z) \<in> r2 \<Longrightarrow> f w y = f w z)
    \<Longrightarrow> congruent2 r1 r2 f"
  \<comment> \<open>Suggested by John Harrison -- the two subproofs may be\<close>
  \<comment> \<open>\<^emph>\<open>much\<close> simpler than the direct proof.\<close>
  unfolding congruent2_def equiv_def refl_on_def
  by (blast intro: trans)

lemma congruent2_commuteI:
  assumes equivA: "equiv A r"
    and commute: "\<And>y z. y \<in> A \<Longrightarrow> z \<in> A \<Longrightarrow> f y z = f z y"
    and congt: "\<And>y z w. w \<in> A \<Longrightarrow> (y,z) \<in> r \<Longrightarrow> f w y = f w z"
  shows "f respects2 r"
proof (rule congruent2I [OF equivA equivA])
  note eqv = equivA [THEN equiv_type, THEN subsetD, THEN SigmaE2]
  show "\<And>y z w. \<lbrakk>w \<in> A; (y, z) \<in> r\<rbrakk> \<Longrightarrow> f y w = f z w"
    by (iprover intro: commute [THEN trans] sym congt elim: eqv)
  show "\<And>y z w. \<lbrakk>w \<in> A; (y, z) \<in> r\<rbrakk> \<Longrightarrow> f w y = f w z"
    by (iprover intro: congt elim: eqv)
qed

subsection \<open>Quotients and finiteness\<close>

text \<open>Suggested by Florian Kammüller\<close>

lemma finite_quotient:
  assumes "finite A" "r \<subseteq> A \<times> A"
  shows "finite (A//r)"
    \<comment> \<open>recall @{thm equiv_type}\<close>
proof -
  have "A//r \<subseteq> Pow A"
    using assms unfolding quotient_def by blast
  moreover have "finite (Pow A)"
    using assms by simp
  ultimately show ?thesis
    by (iprover intro: finite_subset)
qed

lemma finite_equiv_class: "finite A \<Longrightarrow> r \<subseteq> A \<times> A \<Longrightarrow> X \<in> A//r \<Longrightarrow> finite X"
  unfolding quotient_def
  by (erule rev_finite_subset) blast

lemma equiv_imp_dvd_card:
  assumes "finite A" "equiv A r" "\<And>X. X \<in> A//r \<Longrightarrow> k dvd card X"
  shows "k dvd card A"
proof (rule Union_quotient [THEN subst])
  show "k dvd card (\<Union> (A // r))"
    apply (rule dvd_partition)
    using assms
    by (auto simp: Union_quotient dest: quotient_disj)
qed (use assms in blast)

lemma card_quotient_disjoint:
  assumes "finite A" "inj_on (\<lambda>x. {x} // r) A"
  shows "card (A//r) = card A"
proof -
  have "\<forall>i\<in>A. \<forall>j\<in>A. i \<noteq> j \<longrightarrow> r `` {j} \<noteq> r `` {i}"
    using assms by (fastforce simp add: quotient_def inj_on_def)
  with assms show ?thesis
    by (simp add: quotient_def card_UN_disjoint)
qed

subsection \<open>Projection\<close>

definition proj :: "('b \<times> 'a) set \<Rightarrow> 'b \<Rightarrow> 'a set"
  where "proj r x = r `` {x}"

lemma proj_preserves: "x \<in> A \<Longrightarrow> proj r x \<in> A//r"
  unfolding proj_def by (rule quotientI)

lemma proj_in_iff:
  assumes "equiv A r"
  shows "proj r x \<in> A//r \<longleftrightarrow> x \<in> A"
    (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?rhs
  then show ?lhs by (simp add: proj_preserves)
next
  assume ?lhs
  then show ?rhs
    unfolding proj_def quotient_def
  proof clarsimp
    fix y
    assume y: "y \<in> A" and "r `` {x} = r `` {y}"
    moreover have "y \<in> r `` {y}"
      using assms y unfolding equiv_def refl_on_def by blast
    ultimately have "(x, y) \<in> r" by blast
    then show "x \<in> A"
      using assms unfolding equiv_def refl_on_def by blast
  qed
qed

lemma proj_iff: "equiv A r \<Longrightarrow> {x, y} \<subseteq> A \<Longrightarrow> proj r x = proj r y \<longleftrightarrow> (x, y) \<in> r"
  by (simp add: proj_def eq_equiv_class_iff)

(*
lemma in_proj: "\<lbrakk>equiv A r; x \<in> A\<rbrakk> \<Longrightarrow> x \<in> proj r x"
unfolding proj_def equiv_def refl_on_def by blast
*)

lemma proj_image: "proj r ` A = A//r"
  unfolding proj_def[abs_def] quotient_def by blast

lemma in_quotient_imp_non_empty: "equiv A r \<Longrightarrow> X \<in> A//r \<Longrightarrow> X \<noteq> {}"
  unfolding quotient_def using equiv_class_self by fast

lemma in_quotient_imp_in_rel: "equiv A r \<Longrightarrow> X \<in> A//r \<Longrightarrow> {x, y} \<subseteq> X \<Longrightarrow> (x, y) \<in> r"
  using quotient_eq_iff[THEN iffD1] by fastforce

lemma in_quotient_imp_closed: "equiv A r \<Longrightarrow> X \<in> A//r \<Longrightarrow> x \<in> X \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> y \<in> X"
  unfolding quotient_def equiv_def trans_def by blast

lemma in_quotient_imp_subset: "equiv A r \<Longrightarrow> X \<in> A//r \<Longrightarrow> X \<subseteq> A"
  using in_quotient_imp_in_rel equiv_type by fastforce

subsection \<open>Equivalence relations -- predicate version\<close>

text \<open>Partial equivalences.\<close>

definition part_equivp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
  where "part_equivp R \<longleftrightarrow> (\<exists>x. R x x) \<and> (\<forall>x y. R x y \<longleftrightarrow> R x x \<and> R y y \<and> R x = R y)"
    \<comment> \<open>John-Harrison-style characterization\<close>

lemma part_equivpI: "\<exists>x. R x x \<Longrightarrow> symp R \<Longrightarrow> transp R \<Longrightarrow> part_equivp R"
  by (auto simp add: part_equivp_def) (auto elim: sympE transpE)

lemma part_equivpE:
  assumes "part_equivp R"
  obtains x where "R x x" and "symp R" and "transp R"
proof -
  from assms have 1: "\<exists>x. R x x"
    and 2: "\<And>x y. R x y \<longleftrightarrow> R x x \<and> R y y \<and> R x = R y"
    unfolding part_equivp_def by blast+
  from 1 obtain x where "R x x" ..
  moreover have "symp R"
  proof (rule sympI)
    fix x y
    assume "R x y"
    with 2 [of x y] show "R y x" by auto
  qed
  moreover have "transp R"
  proof (rule transpI)
    fix x y z
    assume "R x y" and "R y z"
    with 2 [of x y] 2 [of y z] show "R x z" by auto
  qed
  ultimately show thesis by (rule that)
qed

lemma part_equivp_refl_symp_transp: "part_equivp R \<longleftrightarrow> (\<exists>x. R x x) \<and> symp R \<and> transp R"
  by (auto intro: part_equivpI elim: part_equivpE)

lemma part_equivp_symp: "part_equivp R \<Longrightarrow> R x y \<Longrightarrow> R y x"
  by (erule part_equivpE, erule sympE)

lemma part_equivp_transp: "part_equivp R \<Longrightarrow> R x y \<Longrightarrow> R y z \<Longrightarrow> R x z"
  by (erule part_equivpE, erule transpE)

lemma part_equivp_typedef: "part_equivp R \<Longrightarrow> \<exists>d. d \<in> {c. \<exists>x. R x x \<and> c = Collect (R x)}"
  by (auto elim: part_equivpE)

text \<open>Total equivalences.\<close>

definition equivp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
  where "equivp R \<longleftrightarrow> (\<forall>x y. R x y = (R x = R y))" \<comment> \<open>John-Harrison-style characterization\<close>

lemma equivpI: "reflp R \<Longrightarrow> symp R \<Longrightarrow> transp R \<Longrightarrow> equivp R"
  by (auto elim: reflpE sympE transpE simp add: equivp_def)

lemma equivpE:
  assumes "equivp R"
  obtains "reflp R" and "symp R" and "transp R"
  using assms by (auto intro!: that reflpI sympI transpI simp add: equivp_def)

lemma equivp_implies_part_equivp: "equivp R \<Longrightarrow> part_equivp R"
  by (auto intro: part_equivpI elim: equivpE reflpE)

lemma equivp_equiv: "equiv UNIV A \<longleftrightarrow> equivp (\<lambda>x y. (x, y) \<in> A)"
  by (auto intro!: equivI equivpI [to_set] elim!: equivE equivpE [to_set])

lemma equivp_reflp_symp_transp: "equivp R \<longleftrightarrow> reflp R \<and> symp R \<and> transp R"
  by (auto intro: equivpI elim: equivpE)

lemma identity_equivp: "equivp (=)"
  by (auto intro: equivpI reflpI sympI transpI)

lemma equivp_reflp: "equivp R \<Longrightarrow> R x x"
  by (erule equivpE, erule reflpE)

lemma equivp_symp: "equivp R \<Longrightarrow> R x y \<Longrightarrow> R y x"
  by (erule equivpE, erule sympE)

lemma equivp_transp: "equivp R \<Longrightarrow> R x y \<Longrightarrow> R y z \<Longrightarrow> R x z"
  by (erule equivpE, erule transpE)

lemma equivp_rtranclp: "symp r \<Longrightarrow> equivp r\<^sup>*\<^sup>*"
  by(intro equivpI reflpI sympI transpI)(auto dest: sympD[OF symp_rtranclp])

lemmas equivp_rtranclp_symclp [simp] = equivp_rtranclp[OF symp_symclp]

lemma equivp_vimage2p: "equivp R \<Longrightarrow> equivp (vimage2p f f R)"
  by(auto simp add: equivp_def vimage2p_def dest: fun_cong)

lemma equivp_imp_transp: "equivp R \<Longrightarrow> transp R"
  by(simp add: equivp_reflp_symp_transp)

subsection \<open>Equivalence closure\<close>

definition equivclp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "equivclp r = (symclp r)\<^sup>*\<^sup>*"

lemma transp_equivclp [simp]: "transp (equivclp r)"
  by(simp add: equivclp_def)

lemma reflp_equivclp [simp]: "reflp (equivclp r)"
  by(simp add: equivclp_def)

lemma symp_equivclp [simp]: "symp (equivclp r)"
  by(simp add: equivclp_def)

lemma equivp_evquivclp [simp]: "equivp (equivclp r)"
  by(simp add: equivpI)

lemma tranclp_equivclp [simp]: "(equivclp r)\<^sup>+\<^sup>+ = equivclp r"
  by(simp add: equivclp_def)

lemma rtranclp_equivclp [simp]: "(equivclp r)\<^sup>*\<^sup>* = equivclp r"
  by(simp add: equivclp_def)

lemma symclp_equivclp [simp]: "symclp (equivclp r) = equivclp r"
  by(simp add: equivclp_def symp_symclp_eq)

lemma equivclp_symclp [simp]: "equivclp (symclp r) = equivclp r"
  by(simp add: equivclp_def)

lemma equivclp_conversep [simp]: "equivclp (conversep r) = equivclp r"
  by(simp add: equivclp_def)

lemma equivclp_sym [sym]: "equivclp r x y \<Longrightarrow> equivclp r y x"
  by(rule sympD[OF symp_equivclp])

lemma equivclp_OO_equivclp_le_equivclp: "equivclp r OO equivclp r \<le> equivclp r"
  by(rule transp_relcompp_less_eq transp_equivclp)+

lemma rtranlcp_le_equivclp: "r\<^sup>*\<^sup>* \<le> equivclp r"
  unfolding equivclp_def by(rule rtranclp_mono)(simp add: symclp_pointfree)

lemma rtranclp_conversep_le_equivclp: "r\<inverse>\<inverse>\<^sup>*\<^sup>* \<le> equivclp r"
  unfolding equivclp_def by(rule rtranclp_mono)(simp add: symclp_pointfree)

lemma symclp_rtranclp_le_equivclp: "symclp r\<^sup>*\<^sup>* \<le> equivclp r"
  unfolding symclp_pointfree
  by(rule le_supI)(simp_all add: rtranclp_conversep[symmetric] rtranlcp_le_equivclp rtranclp_conversep_le_equivclp)

lemma r_OO_conversep_into_equivclp:
  "r\<^sup>*\<^sup>* OO r\<inverse>\<inverse>\<^sup>*\<^sup>* \<le> equivclp r"
  by(blast intro: order_trans[OF _ equivclp_OO_equivclp_le_equivclp] relcompp_mono rtranlcp_le_equivclp rtranclp_conversep_le_equivclp del: predicate2I)

lemma equivclp_induct [consumes 1, case_names base step, induct pred: equivclp]:
  assumes a: "equivclp r a b"
    and cases: "P a" "\<And>y z. equivclp r a y \<Longrightarrow> r y z \<or> r z y \<Longrightarrow> P y \<Longrightarrow> P z"
  shows "P b"
  using a unfolding equivclp_def
  by(induction rule: rtranclp_induct; fold equivclp_def; blast intro: cases elim: symclpE)

lemma converse_equivclp_induct [consumes 1, case_names base step]:
  assumes major: "equivclp r a b"
    and cases: "P b" "\<And>y z. r y z \<or> r z y \<Longrightarrow> equivclp r z b \<Longrightarrow> P z \<Longrightarrow> P y"
  shows "P a"
  using major unfolding equivclp_def
  by(induction rule: converse_rtranclp_induct; fold equivclp_def; blast intro: cases elim: symclpE)

lemma equivclp_refl [simp]: "equivclp r x x"
  by(rule reflpD[OF reflp_equivclp])

lemma r_into_equivclp [intro]: "r x y \<Longrightarrow> equivclp r x y"
  unfolding equivclp_def by(blast intro: symclpI)

lemma converse_r_into_equivclp [intro]: "r y x \<Longrightarrow> equivclp r x y"
  unfolding equivclp_def by(blast intro: symclpI)

lemma rtranclp_into_equivclp: "r\<^sup>*\<^sup>* x y \<Longrightarrow> equivclp r x y"
  using rtranlcp_le_equivclp[of r] by blast

lemma converse_rtranclp_into_equivclp: "r\<^sup>*\<^sup>* y x \<Longrightarrow> equivclp r x y"
  by(blast intro: equivclp_sym rtranclp_into_equivclp)

lemma equivclp_into_equivclp: "\<lbrakk> equivclp r a b; r b c \<or> r c b \<rbrakk> \<Longrightarrow> equivclp r a c"
  unfolding equivclp_def by(erule rtranclp.rtrancl_into_rtrancl)(auto intro: symclpI)

lemma equivclp_trans [trans]: "\<lbrakk> equivclp r a b; equivclp r b c \<rbrakk> \<Longrightarrow> equivclp r a c"
  using equivclp_OO_equivclp_le_equivclp[of r] by blast

hide_const (open) proj

end


theory Prop
  imports Main
begin

section {* Prop *}
subsection {* From Boolean Functions to Propositions *}

(* abbreviation "even n \<equiv> (n mod 2 = 0)" *)

subsection {* Inductively Defined Propositions *}

inductive ev where
  ev_0: "ev 0"
  | ev_SS: "ev n \<Longrightarrow> ev (Suc (Suc n))"

(* Exercise: 1 star (double_even) *)

fun double where
  "double n = n + n"
theorem double_even: "\<forall>n. ev (double n)"
apply auto by (induct_tac n, simp, rule ev_0, simp, rule ev_SS, simp)

subsubsection {* Discussion: Computational vs. Inductive Definitions *}

(* Exercise: 1 star (ev__even) *)

theorem ev_even: "\<forall>n :: nat. ev n \<longrightarrow> even n"
apply auto by (erule ev.induct, auto)

(* Exercise: 1 star (l_fails) *)
(* Exercise: 2 stars (ev_sum) *)

theorem ev_sum: "\<forall>n m. ev n \<longrightarrow> ev m \<longrightarrow> ev (n+m)"
apply auto by (erule ev.induct, auto simp add: ev_SS)

subsubsection {* Example *}
subsubsection {* Inference Rules *}

(* Exercise: 1 star (varieties_of_beauty) *)

inductive beautiful :: "nat \<Rightarrow> bool" where
  b_0: "beautiful 0"
  | b_3: "beautiful 3"
  | b_5: "beautiful 5"
  | b_sum: "\<lbrakk> beautiful n; beautiful m \<rbrakk> \<Longrightarrow> beautiful (n + m)"

theorem three_is_beautiful: "beautiful 3" using b_3 by simp
theorem eight_is_beautiful: "beautiful 8" using beautiful.b_sum [of 3 5] b_3 b_5 by simp
theorem beautiful_plus_eight: "\<forall>n. beautiful n \<longrightarrow> beautiful (8 + n)"
apply auto by (rule, auto simp add: eight_is_beautiful)

(* Exercise: 2 stars (b_times2) *)
theorem b_times2: "\<forall>n. beautiful n \<longrightarrow> beautiful (2 * n)" by (simp add: mult_2 b_sum)

(* Exercise: 3 stars (b_timesm) *)
theorem b_timesm: "\<forall>n m. beautiful n \<longrightarrow> beautiful (m * n)"
apply auto by (induct_tac m, auto simp add: b_0 b_sum)

subsubsection {* Induction Over Evidence *}

inductive gorgeous :: "nat \<Rightarrow> bool" where
  g_0: "gorgeous 0"
  | g_plus3: "gorgeous n \<Longrightarrow> gorgeous (3+n)"
  | g_plus5: "gorgeous n \<Longrightarrow> gorgeous (5+n)"

(* Exercise: 1 star (gorgeous_tree) *)
(* Exercise: 1 star (gorgeous_plus13) *)

theorem gorgeous_plus13: "\<forall>n :: nat. gorgeous n \<longrightarrow> gorgeous (13+n)"
proof auto
  fix n :: nat assume "gorgeous n"
  hence "gorgeous (3 + n)" using g_plus3 by simp
  hence "gorgeous (8 + n)" using g_plus5 [of "3 + n"] by simp
  thus "gorgeous (13 + n)" using g_plus5 [of "8 + n"] by simp
qed

theorem gorgeous_beautiful: "\<forall>n :: nat. gorgeous n \<longrightarrow> beautiful n"
apply auto by (erule gorgeous.induct, auto simp add: b_0 b_3 b_5 b_sum)

(* Exercise: 2 stars (gorgeous_sum) *)

theorem gorgeous_sum: "\<forall>n m :: nat. gorgeous n \<longrightarrow> gorgeous m \<longrightarrow> gorgeous (n + m)"
apply auto apply (erule gorgeous.induct, simp)
apply (fastforce simp add: add.assoc g_plus3)
apply (fastforce simp add: add.assoc g_plus5)
done

(* Exercise: 3 stars, advanced (beautiful__gorgeous) *)

theorem beautiful_gorgeous: "\<forall>n :: nat. beautiful n \<longrightarrow> gorgeous n"
apply auto apply (erule beautiful.induct, rule)
using g_plus3 [OF g_0] apply simp
using g_plus5 [OF g_0] apply simp
apply (simp add: gorgeous_sum)
done

(* Exercise: 3 stars, optional (g_times2) *)

lemma helper_g_times2: "\<forall>x y z :: nat. x + (z + y) = z + x + y" by simp

theorem g_times2: "\<forall>n. gorgeous n \<longrightarrow> gorgeous (2 * n)"
by (auto simp add: mult_2 gorgeous_sum)

subsubsection {* Inversion on Evidence *}

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

theorem ev_minus2: "\<forall>n. ev n \<longrightarrow> ev (pred (pred n))"
apply auto by (erule ev.induct, auto simp add: ev_0)

(* Exercise: 1 star, optional (ev_minus2_n) *)

theorem SSev_even: "ev (Suc (Suc n)) \<Longrightarrow> ev n"
using ev_minus2 by fastforce

subsubsection {* inversion revisited *}

(* Exercise: 1 star (inversion_practice) *)
theorem SSSSev_even: "\<forall>n. ev (Suc (Suc (Suc (Suc n)))) \<longrightarrow> ev n"
using SSev_even by fastforce

theorem even5_nonsense: "ev 5 \<longrightarrow> 2 + 2 = 9"
using SSSSev_even apply simp
using One_nat_def ev.simps
by (metis inc.simps Suc_eq_numeral Suc_numeral add_One numeral_One old.nat.distinct(2))

(* Exercise: 3 stars, advanced (ev_ev__ev) *)
lemma ev_in: "ev n \<Longrightarrow> n mod 2 = 0"
by (erule ev.inducts, simp add: ev.simps, simp)

lemma ev_destruct: "ev n \<Longrightarrow> n = 0 \<or> (\<exists>m. n = Suc (Suc m) \<and> ev m)"
  apply (induct rule: ev.induct, simp, simp)
  done

theorem ev_ev_ev: "ev n \<Longrightarrow> ev (n+m) \<Longrightarrow> ev m"
  apply (induct rule: ev.induct, simp, simp)
  using SSev_even by blast

(* Exercise: 3 stars, optional (ev_plus_plus) *)
theorem ev_plus_plus : "\<forall>n m p. ev (n+m) \<longrightarrow> ev (n+p) \<longrightarrow> ev (m+p)"
apply auto
apply (erule_tac ev.cases, auto)
proof -
  fix n :: nat and m :: nat and p :: nat and na :: nat
  assume a1: "ev (n + p)"
  assume a2: "n + m = Suc (Suc na)"
  assume a3: "ev na"
  have "\<And>x\<^sub>1. ev (x\<^sub>1 + x\<^sub>1)" using double_even by auto
  hence "\<And>x\<^sub>1. ev (x\<^sub>1 + (n + (x\<^sub>1 + p)))" using a1 by (metis (no_types) ev_ev_ev helper_g_times2)
  thus "ev (m + p)" using a2 a3 by (metis ev.ev_SS ev_ev_ev helper_g_times2)
qed

subsection {* Additional Exercises *}

(* Exercise: 4 stars (palindromes) *)
inductive_set pal :: "('a list) set" where
  pal_nil: "[] \<in> pal"
  | pal_singleton: "[x] \<in> pal"
  | pal_cons: "l \<in> pal \<Longrightarrow> x # (l @ [x]) \<in> pal"

theorem pal_app: "(l @ rev l) \<in> pal"
proof (induct_tac l, auto, rule pal_nil)
  fix a and list :: "'a list"
  assume "list @ rev list \<in> pal"
  thus "a # list @ rev list @ [a] \<in> pal"
    using pal_cons [of "list @ rev list" a] by auto
qed

theorem pal_palindrome: "l \<in> pal \<Longrightarrow> l = rev l"
apply (erule pal.cases)
apply (simp, simp)
proof simp
  fix l :: "'a list" and la x assume "l = x # la @ [x]" "la \<in> pal"
  show "la = rev la"
    by (rule pal.inducts [OF `la \<in> pal`], auto)
qed

(* Exercise: 5 stars, optional (palindrome_converse) *)
lemma nat_inducts_all:
  "\<And>P n. P 0 \<Longrightarrow> (\<And>n :: nat. (\<And>m :: nat. m \<le> n \<Longrightarrow> P m) \<Longrightarrow> P (Suc n)) \<Longrightarrow> P n"
proof-
  fix P and n :: nat
  assume a: "P 0" "\<And>n :: nat. (\<And>m :: nat. m \<le> n \<Longrightarrow> P m) \<Longrightarrow> P (Suc n)"
  show "P n"
    proof (rule nat_less_induct)
      fix na
      assume a2: "\<forall>m<na. P m"
      show "P na"
        apply (cases na, simp, rule a(1), simp, rule a(2))
        using a2 by simp
    qed
qed

lemma induct_by_length:
  fixes l :: "'a list"
  assumes P_0: "P []"
  and P_step: "\<And>l n. length l = Suc n \<Longrightarrow> (\<And>la. length la \<le> n \<Longrightarrow> P la) \<Longrightarrow> P l"
  shows "P l"
using nat_inducts_all [of "\<lambda>k. \<forall>l. length l = k \<longrightarrow> P l"] apply rule
proof (simp, rule P_0, auto)
  fix n and x :: "'a list"
  assume h: "\<And>m. m \<le> n \<Longrightarrow> \<forall>x. length x = m \<longrightarrow> P x" "length x = Suc n"
  hence "\<And>la. length la \<le> n \<Longrightarrow> P la" by simp
  thus "P x" using P_step [OF h(2)] by simp
qed

theorem palindrome_converse: "l = rev l \<Longrightarrow> l \<in> pal"
using induct_by_length [of "\<lambda>l. l = rev l \<longrightarrow> l \<in> pal"] apply rule
proof (auto, rule)
  fix la :: "'a list" and n
  assume "l = rev l"
  and a: "length la = Suc n" "\<And>la :: 'a list. length la \<le> n \<Longrightarrow> la = rev la \<longrightarrow> la \<in> pal" "la = rev la"
  from a(1) obtain x xs where xxs: "la = x # xs" using neq_Nil_conv [of la] by auto
  from a(3) have 1: "last la = x" using xxs by simp

  have 2: "(la = [x]) \<or> (\<exists>ys. la = x # ys @ [x])"
    using xxs 1 by (metis append_Cons append_butlast_last_id butlast.simps(2) list.distinct(1))

  have "la = [x] \<Longrightarrow> la \<in> pal"
    by (simp, rule)
  moreover have "\<exists>ys. la = x # ys @ [x] \<Longrightarrow> la \<in> pal"
    proof-
      assume "\<exists>ys. la = x # ys @ [x]"
      then obtain ys where ys: "la = x # ys @ [x]" by auto
      have "rev ys = ys" using a(3) by (simp add: ys)
      have "length ys \<le> n"
        using a(1) by (simp add: ys)
      thus "la \<in> pal"
        using a(2) [OF `length ys \<le> n`]
        by (simp add: `rev ys = ys` ys, rule_tac pal_cons, simp)
    qed
  ultimately
    show "la \<in> pal" by (metis 2)
qed

fun init where
  "init [] = []"
  | "init [x] = []"
  | "init (x # xs) = x # init xs"

lemma init_length: "\<And>x. length (init (x # xs)) = length xs"
by (induct xs, simp, simp)

fun cut1 where
  "cut1 [] = []"
  | "cut1 [x] = []"
  | "cut1 xs = init (tl xs)"

lemma cut1_length: "length l \<le> Suc n \<Longrightarrow> length (cut1 l) \<le> n"
apply (rule cut1.cases [of l], simp, simp, simp)
by (simp add: init_length)

lemma cut1_head_last: "cut1 (x # l @ [x]) = l"
proof-
  have "cut1 (x # l @ [x]) = init (l @ [x])" by (cases l, auto)
  also have "\<dots> = l"
    proof (induct l, auto)
      fix a l
      assume a: "init (l @ [x]) = l"
      have 1: "l @ [x] = hd (l @ [x]) # tl (l @ [x])" by (cases l, auto)
      hence "init (a # l @ [x]) = a # init (l @ [x])"
        using init.simps(3) [of a "hd (l @ [x])" "tl (l @ [x])"] by simp
      thus "init (a # l @ [x]) = a # l"
        by (simp add: a)
    qed
  finally show ?thesis by simp
qed

lemma rev_cut1': "l \<in> pal \<Longrightarrow> cut1 l = rev (cut1 l)"
using induct_by_length [of "\<lambda>l. l \<in> pal \<longrightarrow> cut1 l = rev (cut1 l)"] apply rule
proof auto
  fix la :: "'a list" and n
  assume "l \<in> pal"
  and a: "length la = Suc n" "(\<And>la :: 'a list. length la \<le> n \<Longrightarrow> la \<in> pal \<longrightarrow> cut1 la = rev (cut1 la))" "la \<in> pal"
  have 1: "(\<exists>x. la = [x]) \<or> (\<exists>x xs. la = x # xs @ [x])"
    apply (rule pal.cases [OF a(3)])
    using a(1) by auto

  have "(\<exists>x. la = [x]) \<Longrightarrow> cut1 la = rev (cut1 la)" by auto
  moreover have "(\<exists>x xs. la = x # xs @ [x]) \<Longrightarrow> cut1 la = rev (cut1 la)"
    proof-
      assume "\<exists>x xs. la = x # xs @ [x]"
      then obtain x xs where xxs: "la = x # xs @ [x]" by auto
      have 1: "xs \<in> pal"
        apply (rule pal.cases [OF a(3)])
        using a(1) xxs by auto
      show ?thesis
        by (simp add: xxs cut1_head_last, rule pal_palindrome, rule 1)
    qed
  ultimately
    show "cut1 la = rev (cut1 la)" using 1 by auto
qed

lemma rev_cut1: "l = rev l \<Longrightarrow> cut1 l = rev (cut1 l)"
by (rule rev_cut1', simp add: palindrome_converse)

lemma cut_append: "\<And>x l2. \<lbrakk> l = x # l2; l2 \<noteq> [] \<rbrakk> \<Longrightarrow> hd l # (cut1 l) @ [last l] = l"
apply (induct l, auto) by (fastforce simp add: neq_Nil_conv)

lemma rev_pal_length: "\<And>l. \<lbrakk> length l \<le> n; l = rev l \<rbrakk> \<Longrightarrow> l \<in> pal"
proof (induct n, simp, rule pal_nil)
  fix n and l :: "'a list"
  assume hyp: "(\<And>(l :: 'a list). length l \<le> n \<Longrightarrow> l = rev l \<Longrightarrow> l \<in> pal)" and "length l \<le> Suc n" "l = rev l"
  have "l = [] \<Longrightarrow> l \<in> pal" by (simp, rule pal_nil)
  moreover have "\<And>x. l = [x] \<Longrightarrow> l \<in> pal" by (simp, rule pal_singleton)
  moreover have "\<And>x l2. \<lbrakk> l = x # l2; l2 \<noteq> [] \<rbrakk> \<Longrightarrow> l \<in> pal"
    proof -
      fix x l2
      assume "l = x # l2" "l2 \<noteq> []"
      have "length (cut1 l) \<le> n" using cut1_length [OF `length l \<le> Suc n`] by simp
      moreover have "cut1 l = rev (cut1 l)" using rev_cut1 [OF `l = rev l`] by simp
      ultimately
        have "cut1 l \<in> pal" using hyp [of "cut1 l"] by simp
        moreover have "hd l = last l"
          using `l = rev l` apply (subst last_rev [symmetric]) by (auto simp add: `l = x # l2`)
        ultimately
          have "hd l # cut1 l @ [last l] \<in> pal" using pal_cons by simp
          moreover have "l = hd l # cut1 l @ [last l]" using cut_append [OF `l = x # l2` `l2 \<noteq> []`] by simp
          ultimately show "l \<in> pal" by simp
    qed
  ultimately show "l \<in> pal" by (metis list.exhaust)
qed

theorem pal_converse: "l = rev l \<Longrightarrow> l \<in> pal"
using rev_pal_length [of l "length l"] by simp

(* Exercise: 4 stars, advanced (subsequence) *)
inductive subseq :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  subseq_nil: "subseq [] []"
  | subseq_cons: "subseq xs ys \<Longrightarrow> subseq xs (y # ys)"
  | subseq_cons_both: "subseq xs ys \<Longrightarrow> subseq (x # xs) (x # ys)"

abbreviation is_subseq_of ("_ {subseq of} _") where
  "is_subseq_of xs ys \<equiv> subseq xs ys"

theorem subseq_reflexive: "subseq xs xs"
apply (induct xs) by (rule subseq_nil, rule subseq_cons_both, simp)

lemma subseq_empty: "[] {subseq of} xs"
apply (induct xs) by (rule subseq_nil, rule subseq_cons, simp)

lemma subseq_app': "ys {subseq of} xs \<Longrightarrow> ys {subseq of} (xs' @ xs)"
apply (induct xs') by (simp, simp, rule subseq_cons, simp)

theorem subseq_app: "\<lbrakk> l1 {subseq of} l2; l1 {subseq of} l3 \<rbrakk> \<Longrightarrow> l1 {subseq of} (l2 @ l3)"
by (auto simp add: subseq_app')

lemma subseq_empty_of: "xs {subseq of} [] \<Longrightarrow> xs = []"
by (erule subseq.cases, simp+)

(*
lemma subseq_split_l:
  "l1 {subseq of} (l2 @ l3) \<Longrightarrow> \<exists>l4. \<exists>l5. (l4 {subseq of} l2) & (l5 {subseq of} l3) & (l1 = l4 @ l5)"
sorry

theorem subseq_trans: "\<And>l1 l3. \<lbrakk> l1 {subseq of} l2; l2 {subseq of} l3 \<rbrakk> \<Longrightarrow> l1 {subseq of} l3"
apply (induct l2)
  using subseq_empty_of apply fastforce
proof -
  fix a l2 l1 l3
  assume hyp: "\<And>l1 l3 :: 'a list. l1 {subseq of} l2 \<Longrightarrow> l2 {subseq of} l3 \<Longrightarrow> l1 {subseq of} l3"
  and 1: "l1 {subseq of} (a # l2)" "(a # l2) {subseq of} l3"
  obtain l4 l5 where
    l45: "l4 {subseq of} [a]" "l5 {subseq of} l2" "l1 = l4 @ l5"
    using subseq_split_l [of l1 "[a]" l2] by (fastforce simp add: 1(1))
  have "l5 {subseq of} l3"
    using hyp [OF l45(2)]

  show "l1 {subseq of} l3"
*)

(* Exercise: 2 stars, optional (R_provability) *)
inductive R where
  c1: "R 0 []"
  | c2: "R n l \<Longrightarrow> R (Suc n) (n # l)"
  | c3: "R (Suc n) l \<Longrightarrow> R n l"

lemma R_2: "R 2 [1,0]"
by (metis (no_types) One_nat_def R.simps Suc_1)

lemma R_1: "R 1 [1,2,1,0]"
by (metis R_2 Suc_1 c2 c3)

(*
"R 6 [3,2,1,0] \<Longrightarrow> False"
unprovable
*)

subsection {* Relations *}

inductive le :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
  le_n: "le n n"
  | le_S: "le n m \<Longrightarrow> le n (Suc m)"

theorem test_le1: "le 3 3" by (rule le_n)
theorem test_le2: "le 3 6"
proof -
  have "le 3 (Suc (Suc (Suc 3)))" by (rule le_S, rule le_S, rule le_S, rule le_n)
  thus ?thesis by simp
qed

theorem test_le3: "le 2 1 \<Longrightarrow> 2 + 2 = 5"
proof -
  assume "le 2 1" hence "le (Suc 1) 1" by (simp add: numeral_eq_Suc)
  hence False by (metis One_nat_def Suc_eq_numeral le.cases numeral_One old.nat.distinct(2))
  thus "2 + 2 = 5" by meson
qed

fun lt where
  "lt n m = le (Suc n) m"

inductive square_of where
  sq: "square_of n (n * n)"
inductive next_nat where
  nn: "next_nat n (Suc n)"
inductive next_even where
  ne_1: "ev (Suc n) \<Longrightarrow> next_even n (Suc n)"
  | ne_2: "ev (Suc (Suc n)) \<Longrightarrow> next_even n (Suc (Suc n))"

(* Exercise: 2 stars (total_relation) *)
inductive total_relation where
  lt: "n < m \<Longrightarrow> total_relation n m"
  | gte: "n \<ge> m \<Longrightarrow> total_relation n m"

(* Exercise: 2 stars (empty_relation) *)
inductive empty_relation where
  empty_r: "\<lbrakk> n < m; m > n \<rbrakk> \<Longrightarrow> empty_relation n m"

(* Exercise: 2 stars, optional (le_exercises) *)
lemma le_Suc: "le m n \<Longrightarrow> \<exists>a :: nat. n = m + a"
by (rule le.inducts, auto)

lemma Suc_le: "\<And>n. n = m + a \<Longrightarrow> le m n"
apply (induct a, simp, rule le_n) by (simp add: le_S)

lemma le_trans: "\<And>m n o'. le m n \<Longrightarrow> le n o' \<Longrightarrow> le m o'"
proof -
  fix m n o' assume "le m n" "le n o'"
  then obtain a b where "n = m + a" "o' = n + b" by (metis le_Suc)
  thus "le m o'" using Suc_le [of o' m "a + b"] by simp
qed

theorem le_0_n: "le 0 n"
by (induct n, rule le_n, rule le_S, simp)

theorem n_le_m_Sn_le_Sm: "le n m \<Longrightarrow> le (Suc n) (Suc m)"
using Suc_le le_Suc by (metis add_Suc)

theorem Sn_le_Sm_n_le_m: "le (Suc n) (Suc m) \<Longrightarrow> le n m"
using Suc_le le_Suc by (metis Prop.le_trans Prop.pred.simps(2) le.cases le_S le_n)

theorem le_plus_l: "le a (a+b)"
by (induct b, auto, rule, rule, simp)

theorem plus_lt: "le (n1 + n2) m \<Longrightarrow> le n1 m \<and> le n2 m"
using Suc_le le_Suc by (metis Prop.le_trans add.commute)

theorem lt_S: "le n m \<Longrightarrow> le n (Suc m)" by (rule, simp)
theorem ble_nat_true: "n \<le> m \<Longrightarrow> le n m" using Suc_le [of m n "m - n"] by simp
theorem le_ble_nat: "le n m \<Longrightarrow> n \<le> m" using le_Suc [of n m] by fastforce
theorem ble_nat_true_trans: "n = m \<Longrightarrow> m = o' \<Longrightarrow> n = o'" by simp

(* Exercise: 2 stars, optional (ble_nat_false) *)
theorem ble_nat_false: "\<not> (n \<le> m) \<Longrightarrow> \<not> (le n m)" using le_ble_nat by auto

(* Exercise: 3 stars (R_provability2) *)
inductive R' where
  c1: "R' 0 0 0"
  | c2: "R' l m n \<Longrightarrow> R' (Suc l) m (Suc n)"
  | c3: "R' l m n \<Longrightarrow> R' l (Suc m) (Suc n)"
  | c4: "R' (Suc l) (Suc m) (Suc (Suc n)) \<Longrightarrow> R' l m n"
  | c5: "R' l m n \<Longrightarrow> R' m l n"

lemma R'_112: "R' 1 1 2"
by (metis One_nat_def R'.c1 R'.c2 R'.c3 Suc_1)

(*
"R' 2 2 6"
unprovable
*)

(* Exercise: 3 stars, optional (R_fact) *)
fun sum_le where
  "sum_le l m n = ((l + m) = n)"

theorem R'_sumle: "R' l m n \<Longrightarrow> sum_le l m n"
by (erule R'.inducts, auto)

theorem sumle_R': "\<And>m n. sum_le l m n \<Longrightarrow> R' l m n"
proof (induct l, auto)
  fix n show "R' 0 n n"
  by (induct n, rule c1, rule c3, simp)
next
  fix l m n
  assume hyp: "\<And>m n. l + m = n \<Longrightarrow> R' l m n"
  show "R' (Suc l) m (Suc (l + m))" by (rule c2, rule hyp, simp)
qed

subsection {* Programming with Propositions Revisited *}

end


theory MyCalc imports Main
begin

(* For the second part of the workshop, let's have a look at a more typical
   task that might arise in software verification. *)

(* Here's a very simple four-function calculator language
   (something like this might be useful e.g. in modeling expressions in a larger language *)

datatype calc =
  N nat
  | Add calc calc
  | Sub calc calc
  | Mul calc calc
  | Div calc calc (* normal natural-number division; that is, round down *)

(*
  We give a semantics to this language by showing how it maps into computation in
  Isabelle. We call this a _denotational semantics_ because it maps (or _denotes_)
  that mathematical meaning of calc expressions directly into Isabelle's logic.

  Note that we can only get away with this because calc is a language of terminating
  programs. If we wanted to express nonterminating programs, we would need to deal with the
  fact that Isabelle functions (generally) need to terminate in order to be convenient to
  reason about. There are several standard ways to do this, one of the most common being
  to give nonterminating interpreters an extra "fuel" argument (usually a natural number)
  that decreases with each iteration, establishing termination.
*)

fun calcD :: "calc \<Rightarrow> nat" where
"calcD (N n) = n"
| "calcD (Add c1 c2) = calcD c1 + calcD c2"
| "calcD (Sub c1 c2) = calcD c1 - calcD c2"
| "calcD (Mul c1 c2) = calcD c1 * calcD c2"
| "calcD (Div c1 c2) = divide_nat_inst.divide_nat (calcD c1) (calcD c2)"

(* We can run some computations in this language if we like *)
value "calcD (Add (Add (N 1) (N 1)) (Mul (N 4) (N 10)))"

(* Now that we have a semantics of this language in Isabelle - a system amenable to proofs -
   there are some interesting things we can do. For instance, we might notice that some
   programs can be simplified according to arithmetic identities. For instance,
   (Add (N 0) x) = x
   for any calc expression x.
   Let's define a program transformation capturing this "insight."
*)

fun calc_simplify_addzero :: "calc \<Rightarrow> calc" where
"calc_simplify_addzero (N n) = N n"
| "calc_simplify_addzero (Add (N n) c2) =
    (if n = 0 then calc_simplify_addzero c2
     else Add (N n) (calc_simplify_addzero c2))"
| "calc_simplify_addzero (Add c1 c2) =
    Add (calc_simplify_addzero c1) (calc_simplify_addzero c2)"
| "calc_simplify_addzero (Sub c1 c2) =
    Sub (calc_simplify_addzero c1) (calc_simplify_addzero c2)"
| "calc_simplify_addzero (Mul c1 c2) =
    Mul (calc_simplify_addzero c1) (calc_simplify_addzero c2)"
| "calc_simplify_addzero (Div c1 c2) =
    Div (calc_simplify_addzero c1) (calc_simplify_addzero c2)"

value "calc_simplify_addzero (Add (N 1) (Add (N 0) (N 1)))"

(* Exercise: will this transformation ever yield programs that still contain expressions
   of the form (Add (N 0) x)? When does this happen? How can we fix this?
*)

(* Next, we'd like to show this transformation is correct. Fortunately it's quite clear
   what we mean by that in this case - the semantics of the program
   (i.e., the result of running calcD) should be the same before and after the
   transformation. Let's capture this in a lemma and try to prove it. *)

lemma calc_simplify_addzero_correct :
  "calcD c = calcD (calc_simplify_addzero c)"
proof(induction c)
case (N x)
  then show ?case by auto
next
  (* the interesting case, of course. *)
  case (Add c1 c2)
  show ?case
  (* this way of expressing the proof is rather pedantic and longer than it needs to be -
     trying to cut it down might be an interesting exercise (bonus points for not using
     apply-style tactics in doing so. *)
  proof(cases c1)
    case (N x1)
    show ?thesis
    proof(cases "x1 = 0")
      case True
      then show ?thesis using Add N by(auto)
    next
      case False
      then show ?thesis using Add N by(auto)
    qed
  next
    case Add' : (Add x21 x22) (* we can name our cases - useful for avoiding collisions *)
    then show ?thesis using Add by auto
  next
    case (Sub x31 x32)
    then show ?thesis using Add by auto
  next
    case (Mul x41 x42)
    then show ?thesis using Add by auto
  next
    case (Div x51 x52)
    then show ?thesis using Add by auto
  qed
next
  case (Sub c1 c2)
  then show ?case by auto
next
  case (Mul c1 c2)
  then show ?case by auto
next
  case (Div c1 c2)
  then show ?case by auto
qed

(* Exercise : can you prove the transformation corresponding to the identity
   "1 * x = x"?
*)

(* Exercise : what about "a * b + c * b = (a + c) * b?
*)

end


theory "norm" imports Main begin

(*
 * L1 norm
 * The sum of absolute values of each component.
 *)
fun L1_norm :: "int*int\<Rightarrow>int" where
  "L1_norm (z1, z2) = abs z1 + abs z2"

(* Prove that L1 is nonnegative. *)
theorem L1_norm_is_non_negative : "L1_norm zz \<ge> 0"
  apply (cases zz)
  by simp

theorem L1_norm_is_non_negative' : "L1_norm zz \<ge> 0"
  by (smt L1_norm.elims)    (* Sledgehammer *)

theorem L1_norm_is_non_negative'' :
  fixes "zz" :: "int*int"
  shows "0 \<le> L1_norm zz"
proof (cases zz)  (* \<And>a b. zz = (a, b) \<Longrightarrow> 0 \<le> L1_norm zz *)
  fix a b
  assume H : "zz = (a, b)"
  have "0 \<le> L1_norm (a, b)" by simp
  thus "0 \<le> L1_norm zz" using H by simp  (* thus = from this show *)
qed

end


theory MyList
  imports Main
begin
(* My efforts to formalize
   http://hackage.haskell.org/package/base-4.12.0.0/docs/Data-List.html
*)

datatype 'a List =
  Nil
  | Cons (head : 'a) (tail : "'a List")

fun append :: "'a List \<Rightarrow> 'a List \<Rightarrow> 'a List" where
  appendNil: "append Nil ys = ys" |
  appendCon: "append (Cons x xs) ys = Cons x (append xs ys)"

lemma append_associative [simp] : "append xs (append ys zs) = append (append xs ys) zs"
  apply (induction xs)
   apply auto
  done

fun map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a List \<Rightarrow> 'b List" where
   mapNil: "map f Nil = Nil" |
   mapCon: "map f (Cons x xs) = Cons (f x) (map f xs)"

lemma append_map [simp] : "append (map f xs) (map f ys) = map f (append xs ys)"
  apply (induction xs)
   apply auto
  done

fun rev :: "'a List \<Rightarrow> 'a List" where
  "rev Nil = Nil " |
  "rev (Cons x xs) = append (rev xs) (Cons x Nil)"

lemma append_Nil[simp] : "append xs Nil = xs"
  apply (induction xs)
   apply auto
  done

lemma rev_append[simp] : "rev (append xs ys) = append (rev ys) (rev xs)"
  apply (induction xs)
   apply auto
  done

lemma rev_rev_identity[simp]: "rev (rev xs) = xs"
  apply (induction xs)
   apply auto
  done

(* Snoc List where we add in the Last *)
datatype 'a SList =
    SNil
    | SCons (stail : "'a SList") (shead : 'a)

(* Let's Write a function which convert List <-> SList *)
fun list_to_snoc :: "'a List \<Rightarrow> 'a SList" where
  "list_to_snoc Nil = SNil" |
  "list_to_snoc (Cons x xs) = SCons (list_to_snoc xs) x"

lemma compute_simp : "list_to_snoc (Cons 1 (Cons 2 (Cons 3 Nil))) =
                      (SCons (SCons (SCons SNil 3) 2) 1)"
  by simp

fun snoc_to_list :: "'a SList \<Rightarrow> 'a List" where
  "snoc_to_list SNil = Nil" |
  "snoc_to_list (SCons xs x) = Cons x (snoc_to_list xs)"

lemma snoc_cons_id : "snoc_to_list (list_to_snoc xs) = xs"
  apply (induction xs)
   apply auto
  done

lemma cons_snoc_identity : "list_to_snoc (snoc_to_list xs) = xs"
  apply (induction xs)
   apply auto
  done

fun intersperse :: "'a \<Rightarrow> 'a List \<Rightarrow> 'a List" where
  "intersperse _ Nil = Nil" |
  "intersperse x (Cons y Nil) = (Cons y Nil)" |
  "intersperse x (Cons y ys) = Cons y (Cons x (intersperse x ys))"

lemma map_intersperse: "map f (intersperse a xs) = intersperse (f a) (map f xs)"
  apply (induction xs)
  subgoal by simp
  subgoal for x xs (* something like intros in Coq *)
    apply (cases xs) (* something like case in Coq *)
     apply simp_all
    done
  done

lemma map_intersperse1 : "map f (intersperse a xs) = intersperse (f a) (map f xs)"
  apply (induction xs rule: intersperse.induct)
    apply auto
  done

lemma map_intersperse3: "map f (intersperse a xs) = intersperse (f a) (map f xs)"
proof (induction xs)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  then show ?case by (cases xs) simp_all
qed

fun intercalate :: "'a List \<Rightarrow> ('a List) List \<Rightarrow> 'a List" where
  "intercalate _ Nil = Nil" |
  "intercalate x (Cons y Nil) = (Cons y Nil)" |
  "intercalate x (Cons y ys) = append (append y x) (intercalate x ys)"


(*<*)
theory fun0 imports Main begin
(*>*)

text\<open>
\subsection{Definition}
\label{sec:fun-examples}

Here is a simple example, the \rmindex{Fibonacci function}:
\<close>

fun fib :: "nat \<Rightarrow> nat" where
"fib 0 = 0" |
"fib (Suc 0) = 1" |
"fib (Suc(Suc x)) = fib x + fib (Suc x)"

text\<open>\noindent
This resembles ordinary functional programming languages. Note the obligatory
\isacommand{where} and \isa{|}. Command \isacommand{fun} declares and
defines the function in one go. Isabelle establishes termination automatically
because \<^const>\<open>fib\<close>'s argument decreases in every recursive call.

Slightly more interesting is the insertion of a fixed element
between any two elements of a list:
\<close>

fun sep :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"sep a []     = []" |
"sep a [x]    = [x]" |
"sep a (x#y#zs) = x # a # sep a (y#zs)"

text\<open>\noindent
This time the length of the list decreases with the
recursive call; the first argument is irrelevant for termination.

Pattern matching\index{pattern matching!and \isacommand{fun}}
need not be exhaustive and may employ wildcards:
\<close>

fun last :: "'a list \<Rightarrow> 'a" where
"last [x]      = x" |
"last (_#y#zs) = last (y#zs)"

text\<open>
Overlapping patterns are disambiguated by taking the order of equations into
account, just as in functional programming:
\<close>

fun sep1 :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"sep1 a (x#y#zs) = x # a # sep1 a (y#zs)" |
"sep1 _ xs       = xs"

text\<open>\noindent
To guarantee that the second equation can only be applied if the first
one does not match, Isabelle internally replaces the second equation
by the two possibilities that are left: \<^prop>\<open>sep1 a [] = []\<close> and
\<^prop>\<open>sep1 a [x] = [x]\<close>.  Thus the functions \<^const>\<open>sep\<close> and
\<^const>\<open>sep1\<close> are identical.

Because of its pattern matching syntax, \isacommand{fun} is also useful
for the definition of non-recursive functions:
\<close>

fun swap12 :: "'a list \<Rightarrow> 'a list" where
"swap12 (x#y#zs) = y#x#zs" |
"swap12 zs       = zs"

text\<open>
After a function~$f$ has been defined via \isacommand{fun},
its defining equations (or variants derived from them) are available
under the name $f$\<open>.simps\<close> as theorems.
For example, look (via \isacommand{thm}) at
@{thm[source]sep.simps} and @{thm[source]sep1.simps} to see that they define
the same function. What is more, those equations are automatically declared as
simplification rules.

\subsection{Termination}

Isabelle's automatic termination prover for \isacommand{fun} has a
fixed notion of the \emph{size} (of type \<^typ>\<open>nat\<close>) of an
argument. The size of a natural number is the number itself. The size
of a list is its length. For the general case see \S\ref{sec:general-datatype}.
A recursive function is accepted if \isacommand{fun} can
show that the size of one fixed argument becomes smaller with each
recursive call.

More generally, \isacommand{fun} allows any \emph{lexicographic
combination} of size measures in case there are multiple
arguments. For example, the following version of \rmindex{Ackermann's
function} is accepted:\<close>

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

text\<open>The order of arguments has no influence on whether
\isacommand{fun} can prove termination of a function. For more details
see elsewhere~\<^cite>\<open>bulwahnKN07\<close>.

\subsection{Simplification}
\label{sec:fun-simplification}

Upon a successful termination proof, the recursion equations become
simplification rules, just as with \isacommand{primrec}.
In most cases this works fine, but there is a subtle
problem that must be mentioned: simplification may not
terminate because of automatic splitting of \<open>if\<close>.
\index{*if expressions!splitting of}
Let us look at an example:
\<close>

fun gcd :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"gcd m n = (if n=0 then m else gcd n (m mod n))"

text\<open>\noindent
The second argument decreases with each recursive call.
The termination condition
@{prop[display]"n ~= (0::nat) ==> m mod n < n"}
is proved automatically because it is already present as a lemma in
HOL\@.  Thus the recursion equation becomes a simplification
rule. Of course the equation is nonterminating if we are allowed to unfold
the recursive call inside the \<open>else\<close> branch, which is why programming
languages and our simplifier don't do that. Unfortunately the simplifier does
something else that leads to the same problem: it splits
each \<open>if\<close>-expression unless its
condition simplifies to \<^term>\<open>True\<close> or \<^term>\<open>False\<close>.  For
example, simplification reduces
@{prop[display]"gcd m n = k"}
in one step to
@{prop[display]"(if n=0 then m else gcd n (m mod n)) = k"}
where the condition cannot be reduced further, and splitting leads to
@{prop[display]"(n=0 --> m=k) & (n ~= 0 --> gcd n (m mod n)=k)"}
Since the recursive call \<^term>\<open>gcd n (m mod n)\<close> is no longer protected by
an \<open>if\<close>, it is unfolded again, which leads to an infinite chain of
simplification steps. Fortunately, this problem can be avoided in many
different ways.

The most radical solution is to disable the offending theorem
@{thm[source]if_split},
as shown in \S\ref{sec:AutoCaseSplits}.  However, we do not recommend this
approach: you will often have to invoke the rule explicitly when
\<open>if\<close> is involved.

If possible, the definition should be given by pattern matching on the left
rather than \<open>if\<close> on the right. In the case of \<^term>\<open>gcd\<close> the
following alternative definition suggests itself:
\<close>

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

text\<open>\noindent
The order of equations is important: it hides the side condition
\<^prop>\<open>n ~= (0::nat)\<close>.  Unfortunately, not all conditionals can be
expressed by pattern matching.

A simple alternative is to replace \<open>if\<close> by \<open>case\<close>,
which is also available for \<^typ>\<open>bool\<close> and is not split automatically:
\<close>

fun gcd2 :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"gcd2 m n = (case n=0 of True \<Rightarrow> m | False \<Rightarrow> gcd2 n (m mod n))"

text\<open>\noindent
This is probably the neatest solution next to pattern matching, and it is
always available.

A final alternative is to replace the offending simplification rules by
derived conditional ones. For \<^term>\<open>gcd\<close> it means we have to prove
these lemmas:
\<close>

lemma [simp]: "n \<noteq> 0 \<Longrightarrow> gcd m n = gcd n (m mod n)"
apply(simp)
done

text\<open>\noindent
Simplification terminates for these proofs because the condition of the \<open>if\<close> simplifies to \<^term>\<open>True\<close> or \<^term>\<open>False\<close>.
Now we can disable the original simplification rule:
\<close>

declare gcd.simps [simp del]

text\<open>
\index{induction!recursion|(}
\index{recursion induction|(}

\subsection{Induction}
\label{sec:fun-induction}

Having defined a function we might like to prove something about it.
Since the function is recursive, the natural proof principle is
again induction. But this time the structural form of induction that comes
with datatypes is unlikely to work well --- otherwise we could have defined the
function by \isacommand{primrec}. Therefore \isacommand{fun} automatically
proves a suitable induction rule $f$\<open>.induct\<close> that follows the
recursion pattern of the particular function $f$. We call this
\textbf{recursion induction}. Roughly speaking, it
requires you to prove for each \isacommand{fun} equation that the property
you are trying to establish holds for the left-hand side provided it holds
for all recursive calls on the right-hand side. Here is a simple example
involving the predefined \<^term>\<open>map\<close> functional on lists:
\<close>

lemma "map f (sep x xs) = sep (f x) (map f xs)"

txt\<open>\noindent
Note that \<^term>\<open>map f xs\<close>
is the result of applying \<^term>\<open>f\<close> to all elements of \<^term>\<open>xs\<close>. We prove
this lemma by recursion induction over \<^term>\<open>sep\<close>:
\<close>

apply(induct_tac x xs rule: sep.induct)

txt\<open>\noindent
The resulting proof state has three subgoals corresponding to the three
clauses for \<^term>\<open>sep\<close>:
@{subgoals[display,indent=0]}
The rest is pure simplification:
\<close>

apply simp_all
done

text\<open>\noindent The proof goes smoothly because the induction rule
follows the recursion of \<^const>\<open>sep\<close>.  Try proving the above lemma by
structural induction, and you find that you need an additional case
distinction.

In general, the format of invoking recursion induction is
\begin{quote}
\isacommand{apply}\<open>(induct_tac\<close> $x@1 \dots x@n$ \<open>rule:\<close> $f$\<open>.induct)\<close>
\end{quote}\index{*induct_tac (method)}%
where $x@1~\dots~x@n$ is a list of free variables in the subgoal and $f$ the
name of a function that takes $n$ arguments. Usually the subgoal will
contain the term $f x@1 \dots x@n$ but this need not be the case. The
induction rules do not mention $f$ at all. Here is @{thm[source]sep.induct}:
\begin{isabelle}
{\isasymlbrakk}~{\isasymAnd}a.~P~a~[];\isanewline
~~{\isasymAnd}a~x.~P~a~[x];\isanewline
~~{\isasymAnd}a~x~y~zs.~P~a~(y~\#~zs)~{\isasymLongrightarrow}~P~a~(x~\#~y~\#~zs){\isasymrbrakk}\isanewline
{\isasymLongrightarrow}~P~u~v%
\end{isabelle}
It merely says that in order to prove a property \<^term>\<open>P\<close> of \<^term>\<open>u\<close> and
\<^term>\<open>v\<close> you need to prove it for the three cases where \<^term>\<open>v\<close> is the
empty list, the singleton list, and the list with at least two elements.
The final case has an induction hypothesis:  you may assume that \<^term>\<open>P\<close>
holds for the tail of that list.
\index{induction!recursion|)}
\index{recursion induction|)}
\<close>
(*<*)
end
(*>*)


chapter {* R2: Razonamiento sobre programas en Isabelle/HOL *}

theory R2_Razonamiento_automatico_sobre_programas
imports Main
begin

declare [[names_short]]

text {* ---------------------------------------------------------------
  Ejercicio 1.1. Definir la función
     sumaImpares :: nat \<Rightarrow> nat
  tal que (sumaImpares n) es la suma de los n primeros números
  impares. Por ejemplo,
     sumaImpares 5  =  25
  ------------------------------------------------------------------ *}

fun sumaImpares :: "nat \<Rightarrow> nat" where
  "sumaImpares 0 = 0"
| "sumaImpares n = ((n*2)-1) + sumaImpares(n-1)"

value "sumaImpares 5 = 25"

text {* ---------------------------------------------------------------
  Ejercicio 1.2. Demostrar que
     sumaImpares n = n*n
  ------------------------------------------------------------------- *}

lemma "sumaImpares n = n*n"
apply (induct n)
apply auto
done

text {* ---------------------------------------------------------------
  Ejercicio 2.1. Definir la función
     sumaPotenciasDeDosMasUno :: nat \<Rightarrow> nat
  tal que
     (sumaPotenciasDeDosMasUno n) = 1 + 2^0 + 2^1 + 2^2 + ... + 2^n.
  Por ejemplo,
     sumaPotenciasDeDosMasUno 3  =  16
  ------------------------------------------------------------------ *}

fun sumaPotenciasDeDosMasUno :: "nat \<Rightarrow> nat" where
  "sumaPotenciasDeDosMasUno 0 = 2"
| "sumaPotenciasDeDosMasUno n = 2^n + sumaPotenciasDeDosMasUno(n-1)"

value "sumaPotenciasDeDosMasUno 3 = 16"

text {* ---------------------------------------------------------------
  Ejercicio 2.2. Demostrar que
     sumaPotenciasDeDosMasUno n = 2^(n+1)
  ------------------------------------------------------------------- *}

lemma "sumaPotenciasDeDosMasUno n = 2^(n+1)"
by (induct n) auto

text {* ---------------------------------------------------------------
  Ejercicio 3.1. Definir la función
     copia :: nat \<Rightarrow> 'a \<Rightarrow> 'a list
  tal que (copia n x) es la lista formado por n copias del elemento
  x. Por ejemplo,
     copia 3 x = [x,x,x]
  ------------------------------------------------------------------ *}

fun copia :: "nat \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "copia 0 x = []"
| "copia n x = [x] @ copia (n-1) x"

value "copia 3 x = [x,x,x]"

text {* ---------------------------------------------------------------
  Ejercicio 3.2. Definir la función
     todos :: ('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool
  tal que (todos p xs) se verifica si todos los elementos de xs cumplen
  la propiedad p. Por ejemplo,
     todos (\<lambda>x. x>(1::nat)) [2,6,4] = True
     todos (\<lambda>x. x>(2::nat)) [2,6,4] = False
  Nota: La conjunción se representa por \<and>
  ----------------------------------------------------------------- *}

fun todos :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  "todos p [] = True"
| "todos p (x#xs) = (p x \<and> todos p xs)"

value "todos (\<lambda>x. x>(1::nat)) [2,6,4] = True"
value "todos (\<lambda>x. x>(2::nat)) [2,6,4] = False"

text {* ---------------------------------------------------------------
  Ejercicio 3.3. Demostrar que todos los elementos de (copia n x) son
  iguales a x.
  ------------------------------------------------------------------- *}

lemma "todos (\<lambda>y. y=x) (copia n x)"
by (induct n) auto

text {* ---------------------------------------------------------------
  Ejercicio 4.1. Definir, recursivamente y sin usar (@), la función
     amplia :: 'a list \<Rightarrow> 'a \<Rightarrow> 'a list
  tal que (amplia xs y) es la lista obtenida añadiendo el elemento y al
  final de la lista xs. Por ejemplo,
     amplia [d,a] t = [d,a,t]
  ------------------------------------------------------------------ *}

fun amplia :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "amplia [] y = [y]"
| "amplia (x#xs) y = x # amplia xs y"

value "amplia [d,a] t = [d,a,t]"

text {* ---------------------------------------------------------------
  Ejercicio 4.2. Demostrar que
     amplia xs y = xs @ [y]
  ------------------------------------------------------------------- *}

lemma "amplia xs y = xs @ [y]"
apply (induct xs)
apply auto
done

end


theory P19 imports Main begin

primrec sum :: "nat list \<Rightarrow> nat" where
"sum [] = 0"
| "sum (x # xs) = x + sum xs"

lemma sum_foldr: "sum xs = foldr (+) xs 0"
  apply (induct xs)
   apply auto
  done

lemma length_foldr: "length xs = foldr (\<lambda> x res. 1 + res) xs 0"
  apply (induct xs)
   apply auto
  done

lemma "sum (map (\<lambda> x. x + 3) xs) = foldr (\<lambda>x y. x + y + 3) xs 0"
  apply (induct xs)
   apply auto
  done

lemma "foldr g (map f xs) a = foldr (\<lambda>x y. (g (f x) y)) xs a"
  apply (induct xs)
   apply auto
  done

primrec rev_acc :: "['a list, 'a list] \<Rightarrow> 'a list" where
"rev_acc [] ys = ys"
| "rev_acc (x#xs) ys = (rev_acc xs (x#ys))"

lemma none: "rev_acc xs ys = (rev_acc xs []) @ ys"
proof (induct xs arbitrary: ys)
case Nil
  then show ?case by simp
next
  case (Cons a xs)
  then show ?case
    by (metis append.left_neutral append_Cons append_assoc rev_acc.simps(2))
qed

lemma rev_acc_foldl: "rev_acc xs a = foldl (\<lambda> ys x. x # ys) a xs"
proof (induct xs arbitrary: a)
case Nil
  then show ?case by simp
next
  case (Cons x xs)
  then show ?case by simp
qed

lemma sum_append [simp]: "sum (xs @ ys) = sum xs + sum ys"
  apply (induct xs arbitrary: ys)
   apply auto
  done

(* The defnition part is from the solution as I cbb *)
definition
left_neutral :: "['a \<Rightarrow> 'b \<Rightarrow> 'b, 'a] \<Rightarrow> bool" where
"left_neutral f a == (\<forall> x. (f a x = x))"

definition
assoc :: "['a \<Rightarrow> 'a \<Rightarrow> 'a] \<Rightarrow> bool" where
"assoc f == (\<forall> x y z. f (f x y) z = f x (f y z))"

lemma foldr_append:
"\<lbrakk> left_neutral f a; assoc f \<rbrakk> \<Longrightarrow> foldr f (xs @ ys) a = f (foldr f xs a)(foldr f ys a)"
  apply (induct xs)
   apply (auto simp add: left_neutral_def assoc_def)
  done

fun prod :: "nat list \<Rightarrow> nat" where
 "(prod xs) = (foldr (*) xs 1)"

lemma "prod (xs @ ys) = prod xs * prod ys"
  apply (simp add: prod_def)
  apply (metis List.foldr_append One_nat_def
        P19.foldr_append assoc_def left_neutral_def mult.commute
        mult.left_commute nat_mult_1)
  done

end


(*
    $Id: sol.thy,v 1.4 2011/06/28 18:11:37 webertj Exp $
    Author: Tobias Nipkow
*)

header {* Power, Sum *}

(*<*) theory sol imports Main begin (*>*)

subsubsection {* Power *}

text {* Define a primitive recursive function $pow~x~n$ that
computes $x^n$ on natural numbers. *}

primrec pow :: "nat => nat => nat" where
  "pow x 0       = Suc 0"
| "pow x (Suc n) = x * pow x n"

text {* Prove the well known equation $x^{m \cdot n} = (x^m)^n$: *}

theorem pow_mult: "pow x (m * n) = pow (pow x m) n"
(*<*) oops (*>*)

text {* Hint: prove a suitable lemma first.  If you need to appeal to
associativity and commutativity of multiplication: the corresponding
simplification rules are named @{text mult_ac}. *}

lemma pow_add: "pow x (m + n) = pow x m * pow x n"
  apply (induct n)
  apply auto
done

theorem pow_mult: "pow x (m * n) = pow (pow x m) n"
  apply (induct n)
  apply (auto simp add: pow_add)
done

subsubsection {* Summation *}

text {* Define a (primitive recursive) function $sum~ns$ that sums a list
of natural numbers: $sum [n_1, \dots, n_k] = n_1 + \cdots + n_k$. *}

primrec sum :: "nat list => nat" where
  "sum []     = 0"
| "sum (x#xs) = x + sum xs"

text {* Show that $sum$ is compatible with $rev$. You may need a lemma. *}

lemma sum_append: "sum (xs @ ys) = sum xs + sum ys"
  apply (induct xs)
  apply auto
done

theorem sum_rev: "sum (rev ns) = sum ns"
  apply (induct ns)
  apply (auto simp add: sum_append)
done

text {* Define a function $Sum~f~k$ that sums $f$ from $0$ up to $k-1$:
$Sum~f~k = f~0 + \cdots + f(k - 1)$. *}

primrec Sum :: "(nat => nat) => nat => nat" where
  "Sum f 0       = 0"
| "Sum f (Suc n) = Sum f n + f n"

text {* Show the following equations for the pointwise summation of functions.
Determine first what the expression @{text whatever} should be. *};

theorem "Sum (%i. f i + g i) k = Sum f k + Sum g k"
  apply (induct k)
  apply auto
done

theorem "Sum f (k + l) = Sum f k + Sum (%i. f (k + i)) l"
  apply (induct l)
  apply auto
done

text {* What is the relationship between @{term sum} and @{text Sum}?
Prove the following equation, suitably instantiated. *}

theorem "Sum f k = sum whatever"
(*<*) oops (*>*)

text {* Hint: familiarize yourself with the predefined functions @{term map}
and @{term"[i..<j]"} on lists in theory List. *}

theorem "Sum f k = sum (map f [0..<k])"
  apply (induct k)
  apply (auto simp add: sum_append)
done

(*<*) end (*>*)


(*  Authors:    Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge
*)

section {* Equivalence Relations in Higher-Order Set Theory *}

theory Equiv_Relations
imports Groups_Big Relation
begin

subsection {* Equivalence relations -- set version *}

definition equiv :: "'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> bool" where
  "equiv A r \<longleftrightarrow> refl_on A r \<and> sym r \<and> trans r"

lemma equivI:
  "refl_on A r \<Longrightarrow> sym r \<Longrightarrow> trans r \<Longrightarrow> equiv A r"
  by (simp add: equiv_def)

lemma equivE:
  assumes "equiv A r"
  obtains "refl_on A r" and "sym r" and "trans r"
  using assms by (simp add: equiv_def)

text {*
  Suppes, Theorem 70: @{text r} is an equiv relation iff @{text "r\<inverse> O
  r = r"}.

  First half: @{text "equiv A r ==> r\<inverse> O r = r"}.
*}

lemma sym_trans_comp_subset:
    "sym r ==> trans r ==> r\<inverse> O r \<subseteq> r"
  by (unfold trans_def sym_def converse_unfold) blast

lemma refl_on_comp_subset: "refl_on A r ==> r \<subseteq> r\<inverse> O r"
  by (unfold refl_on_def) blast

lemma equiv_comp_eq: "equiv A r ==> r\<inverse> O r = r"
  apply (unfold equiv_def)
  apply clarify
  apply (rule equalityI)
   apply (iprover intro: sym_trans_comp_subset refl_on_comp_subset)+
  done

text {* Second half. *}

lemma comp_equivI:
    "r\<inverse> O r = r ==> Domain r = A ==> equiv A r"
  apply (unfold equiv_def refl_on_def sym_def trans_def)
  apply (erule equalityE)
  apply (subgoal_tac "\<forall>x y. (x, y) \<in> r --> (y, x) \<in> r")
   apply fast
  apply fast
  done

subsection {* Equivalence classes *}

lemma equiv_class_subset:
  "equiv A r ==> (a, b) \<in> r ==> r``{a} \<subseteq> r``{b}"
  -- {* lemma for the next result *}
  by (unfold equiv_def trans_def sym_def) blast

theorem equiv_class_eq: "equiv A r ==> (a, b) \<in> r ==> r``{a} = r``{b}"
  apply (assumption | rule equalityI equiv_class_subset)+
  apply (unfold equiv_def sym_def)
  apply blast
  done

lemma equiv_class_self: "equiv A r ==> a \<in> A ==> a \<in> r``{a}"
  by (unfold equiv_def refl_on_def) blast

lemma subset_equiv_class:
    "equiv A r ==> r``{b} \<subseteq> r``{a} ==> b \<in> A ==> (a,b) \<in> r"
  -- {* lemma for the next result *}
  by (unfold equiv_def refl_on_def) blast

lemma eq_equiv_class:
    "r``{a} = r``{b} ==> equiv A r ==> b \<in> A ==> (a, b) \<in> r"
  by (iprover intro: equalityD2 subset_equiv_class)

lemma equiv_class_nondisjoint:
    "equiv A r ==> x \<in> (r``{a} \<inter> r``{b}) ==> (a, b) \<in> r"
  by (unfold equiv_def trans_def sym_def) blast

lemma equiv_type: "equiv A r ==> r \<subseteq> A \<times> A"
  by (unfold equiv_def refl_on_def) blast

theorem equiv_class_eq_iff:
  "equiv A r ==> ((x, y) \<in> r) = (r``{x} = r``{y} & x \<in> A & y \<in> A)"
  by (blast intro!: equiv_class_eq dest: eq_equiv_class equiv_type)

theorem eq_equiv_class_iff:
  "equiv A r ==> x \<in> A ==> y \<in> A ==> (r``{x} = r``{y}) = ((x, y) \<in> r)"
  by (blast intro!: equiv_class_eq dest: eq_equiv_class equiv_type)

subsection {* Quotients *}

definition quotient :: "'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> 'a set set"  (infixl "'/'/" 90) where
  "A//r = (\<Union>x \<in> A. {r``{x}})"  -- {* set of equiv classes *}

lemma quotientI: "x \<in> A ==> r``{x} \<in> A//r"
  by (unfold quotient_def) blast

lemma quotientE:
  "X \<in> A//r ==> (!!x. X = r``{x} ==> x \<in> A ==> P) ==> P"
  by (unfold quotient_def) blast

lemma Union_quotient: "equiv A r ==> Union (A//r) = A"
  by (unfold equiv_def refl_on_def quotient_def) blast

lemma quotient_disj:
  "equiv A r ==> X \<in> A//r ==> Y \<in> A//r ==> X = Y | (X \<inter> Y = {})"
  apply (unfold quotient_def)
  apply clarify
  apply (rule equiv_class_eq)
   apply assumption
  apply (unfold equiv_def trans_def sym_def)
  apply blast
  done

lemma quotient_eqI:
  "[|equiv A r; X \<in> A//r; Y \<in> A//r; x \<in> X; y \<in> Y; (x,y) \<in> r|] ==> X = Y"
  apply (clarify elim!: quotientE)
  apply (rule equiv_class_eq, assumption)
  apply (unfold equiv_def sym_def trans_def, blast)
  done

lemma quotient_eq_iff:
  "[|equiv A r; X \<in> A//r; Y \<in> A//r; x \<in> X; y \<in> Y|] ==> (X = Y) = ((x,y) \<in> r)"
  apply (rule iffI)
   prefer 2 apply (blast del: equalityI intro: quotient_eqI)
  apply (clarify elim!: quotientE)
  apply (unfold equiv_def sym_def trans_def, blast)
  done

lemma eq_equiv_class_iff2:
  "\<lbrakk> equiv A r; x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> ({x}//r = {y}//r) = ((x,y) : r)"
by(simp add:quotient_def eq_equiv_class_iff)

lemma quotient_empty [simp]: "{}//r = {}"
by(simp add: quotient_def)

lemma quotient_is_empty [iff]: "(A//r = {}) = (A = {})"
by(simp add: quotient_def)

lemma quotient_is_empty2 [iff]: "({} = A//r) = (A = {})"
by(simp add: quotient_def)

lemma singleton_quotient: "{x}//r = {r `` {x}}"
by(simp add:quotient_def)

lemma quotient_diff1:
  "\<lbrakk> inj_on (%a. {a}//r) A; a \<in> A \<rbrakk> \<Longrightarrow> (A - {a})//r = A//r - {a}//r"
apply(simp add:quotient_def inj_on_def)
apply blast
done

subsection {* Defining unary operations upon equivalence classes *}

text{*A congruence-preserving function*}

definition congruent :: "('a \<times> 'a) set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"  where
  "congruent r f \<longleftrightarrow> (\<forall>(y, z) \<in> r. f y = f z)"

lemma congruentI:
  "(\<And>y z. (y, z) \<in> r \<Longrightarrow> f y = f z) \<Longrightarrow> congruent r f"
  by (auto simp add: congruent_def)

lemma congruentD:
  "congruent r f \<Longrightarrow> (y, z) \<in> r \<Longrightarrow> f y = f z"
  by (auto simp add: congruent_def)

abbreviation
  RESPECTS :: "('a => 'b) => ('a * 'a) set => bool"
    (infixr "respects" 80) where
  "f respects r == congruent r f"

lemma UN_constant_eq: "a \<in> A ==> \<forall>y \<in> A. f y = c ==> (\<Union>y \<in> A. f(y))=c"
  -- {* lemma required to prove @{text UN_equiv_class} *}
  by auto

lemma UN_equiv_class:
  "equiv A r ==> f respects r ==> a \<in> A
    ==> (\<Union>x \<in> r``{a}. f x) = f a"
  -- {* Conversion rule *}
  apply (rule equiv_class_self [THEN UN_constant_eq], assumption+)
  apply (unfold equiv_def congruent_def sym_def)
  apply (blast del: equalityI)
  done

lemma UN_equiv_class_type:
  "equiv A r ==> f respects r ==> X \<in> A//r ==>
    (!!x. x \<in> A ==> f x \<in> B) ==> (\<Union>x \<in> X. f x) \<in> B"
  apply (unfold quotient_def)
  apply clarify
  apply (subst UN_equiv_class)
     apply auto
  done

text {*
  Sufficient conditions for injectiveness.  Could weaken premises!
  major premise could be an inclusion; bcong could be @{text "!!y. y \<in>
  A ==> f y \<in> B"}.
*}

lemma UN_equiv_class_inject:
  "equiv A r ==> f respects r ==>
    (\<Union>x \<in> X. f x) = (\<Union>y \<in> Y. f y) ==> X \<in> A//r ==> Y \<in> A//r
    ==> (!!x y. x \<in> A ==> y \<in> A ==> f x = f y ==> (x, y) \<in> r)
    ==> X = Y"
  apply (unfold quotient_def)
  apply clarify
  apply (rule equiv_class_eq)
   apply assumption
  apply (subgoal_tac "f x = f xa")
   apply blast
  apply (erule box_equals)
   apply (assumption | rule UN_equiv_class)+
  done

subsection {* Defining binary operations upon equivalence classes *}

text{*A congruence-preserving function of two arguments*}

definition congruent2 :: "('a \<times> 'a) set \<Rightarrow> ('b \<times> 'b) set \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> bool" where
  "congruent2 r1 r2 f \<longleftrightarrow> (\<forall>(y1, z1) \<in> r1. \<forall>(y2, z2) \<in> r2. f y1 y2 = f z1 z2)"

lemma congruent2I':
  assumes "\<And>y1 z1 y2 z2. (y1, z1) \<in> r1 \<Longrightarrow> (y2, z2) \<in> r2 \<Longrightarrow> f y1 y2 = f z1 z2"
  shows "congruent2 r1 r2 f"
  using assms by (auto simp add: congruent2_def)

lemma congruent2D:
  "congruent2 r1 r2 f \<Longrightarrow> (y1, z1) \<in> r1 \<Longrightarrow> (y2, z2) \<in> r2 \<Longrightarrow> f y1 y2 = f z1 z2"
  using assms by (auto simp add: congruent2_def)

text{*Abbreviation for the common case where the relations are identical*}
abbreviation
  RESPECTS2:: "['a => 'a => 'b, ('a * 'a) set] => bool"
    (infixr "respects2" 80) where
  "f respects2 r == congruent2 r r f"

lemma congruent2_implies_congruent:
    "equiv A r1 ==> congruent2 r1 r2 f ==> a \<in> A ==> congruent r2 (f a)"
  by (unfold congruent_def congruent2_def equiv_def refl_on_def) blast

lemma congruent2_implies_congruent_UN:
  "equiv A1 r1 ==> equiv A2 r2 ==> congruent2 r1 r2 f ==> a \<in> A2 ==>
    congruent r1 (\<lambda>x1. \<Union>x2 \<in> r2``{a}. f x1 x2)"
  apply (unfold congruent_def)
  apply clarify
  apply (rule equiv_type [THEN subsetD, THEN SigmaE2], assumption+)
  apply (simp add: UN_equiv_class congruent2_implies_congruent)
  apply (unfold congruent2_def equiv_def refl_on_def)
  apply (blast del: equalityI)
  done

lemma UN_equiv_class2:
  "equiv A1 r1 ==> equiv A2 r2 ==> congruent2 r1 r2 f ==> a1 \<in> A1 ==> a2 \<in> A2
    ==> (\<Union>x1 \<in> r1``{a1}. \<Union>x2 \<in> r2``{a2}. f x1 x2) = f a1 a2"
  by (simp add: UN_equiv_class congruent2_implies_congruent
    congruent2_implies_congruent_UN)

lemma UN_equiv_class_type2:
  "equiv A1 r1 ==> equiv A2 r2 ==> congruent2 r1 r2 f
    ==> X1 \<in> A1//r1 ==> X2 \<in> A2//r2
    ==> (!!x1 x2. x1 \<in> A1 ==> x2 \<in> A2 ==> f x1 x2 \<in> B)
    ==> (\<Union>x1 \<in> X1. \<Union>x2 \<in> X2. f x1 x2) \<in> B"
  apply (unfold quotient_def)
  apply clarify
  apply (blast intro: UN_equiv_class_type congruent2_implies_congruent_UN
    congruent2_implies_congruent quotientI)
  done

lemma UN_UN_split_split_eq:
  "(\<Union>(x1, x2) \<in> X. \<Union>(y1, y2) \<in> Y. A x1 x2 y1 y2) =
    (\<Union>x \<in> X. \<Union>y \<in> Y. (\<lambda>(x1, x2). (\<lambda>(y1, y2). A x1 x2 y1 y2) y) x)"
  -- {* Allows a natural expression of binary operators, *}
  -- {* without explicit calls to @{text split} *}
  by auto

lemma congruent2I:
  "equiv A1 r1 ==> equiv A2 r2
    ==> (!!y z w. w \<in> A2 ==> (y,z) \<in> r1 ==> f y w = f z w)
    ==> (!!y z w. w \<in> A1 ==> (y,z) \<in> r2 ==> f w y = f w z)
    ==> congruent2 r1 r2 f"
  -- {* Suggested by John Harrison -- the two subproofs may be *}
  -- {* \emph{much} simpler than the direct proof. *}
  apply (unfold congruent2_def equiv_def refl_on_def)
  apply clarify
  apply (blast intro: trans)
  done

lemma congruent2_commuteI:
  assumes equivA: "equiv A r"
    and commute: "!!y z. y \<in> A ==> z \<in> A ==> f y z = f z y"
    and congt: "!!y z w. w \<in> A ==> (y,z) \<in> r ==> f w y = f w z"
  shows "f respects2 r"
  apply (rule congruent2I [OF equivA equivA])
   apply (rule commute [THEN trans])
     apply (rule_tac [3] commute [THEN trans, symmetric])
       apply (rule_tac [5] sym)
       apply (rule congt | assumption |
         erule equivA [THEN equiv_type, THEN subsetD, THEN SigmaE2])+
  done

subsection {* Quotients and finiteness *}

text {*Suggested by Florian Kammüller*}

lemma finite_quotient: "finite A ==> r \<subseteq> A \<times> A ==> finite (A//r)"
  -- {* recall @{thm equiv_type} *}
  apply (rule finite_subset)
   apply (erule_tac [2] finite_Pow_iff [THEN iffD2])
  apply (unfold quotient_def)
  apply blast
  done

lemma finite_equiv_class:
  "finite A ==> r \<subseteq> A \<times> A ==> X \<in> A//r ==> finite X"
  apply (unfold quotient_def)
  apply (rule finite_subset)
   prefer 2 apply assumption
  apply blast
  done

lemma equiv_imp_dvd_card:
  "finite A ==> equiv A r ==> \<forall>X \<in> A//r. k dvd card X
    ==> k dvd card A"
  apply (rule Union_quotient [THEN subst [where P="\<lambda>A. k dvd card A"]])
   apply assumption
  apply (rule dvd_partition)
     prefer 3 apply (blast dest: quotient_disj)
    apply (simp_all add: Union_quotient equiv_type)
  done

lemma card_quotient_disjoint:
 "\<lbrakk> finite A; inj_on (\<lambda>x. {x} // r) A \<rbrakk> \<Longrightarrow> card(A//r) = card A"
apply(simp add:quotient_def)
apply(subst card_UN_disjoint)
   apply assumption
  apply simp
 apply(fastforce simp add:inj_on_def)
apply simp
done

subsection {* Projection *}

definition proj where "proj r x = r `` {x}"

lemma proj_preserves:
"x \<in> A \<Longrightarrow> proj r x \<in> A//r"
unfolding proj_def by (rule quotientI)

lemma proj_in_iff:
assumes "equiv A r"
shows "(proj r x \<in> A//r) = (x \<in> A)"
apply(rule iffI, auto simp add: proj_preserves)
unfolding proj_def quotient_def proof clarsimp
  fix y assume y: "y \<in> A" and "r `` {x} = r `` {y}"
  moreover have "y \<in> r `` {y}" using assms y unfolding equiv_def refl_on_def by blast
  ultimately have "(x,y) \<in> r" by blast
  thus "x \<in> A" using assms unfolding equiv_def refl_on_def by blast
qed

lemma proj_iff:
"\<lbrakk>equiv A r; {x,y} \<subseteq> A\<rbrakk> \<Longrightarrow> (proj r x = proj r y) = ((x,y) \<in> r)"
by (simp add: proj_def eq_equiv_class_iff)

(*
lemma in_proj: "\<lbrakk>equiv A r; x \<in> A\<rbrakk> \<Longrightarrow> x \<in> proj r x"
unfolding proj_def equiv_def refl_on_def by blast
*)

lemma proj_image: "(proj r) ` A = A//r"
unfolding proj_def[abs_def] quotient_def by blast

lemma in_quotient_imp_non_empty:
"\<lbrakk>equiv A r; X \<in> A//r\<rbrakk> \<Longrightarrow> X \<noteq> {}"
unfolding quotient_def using equiv_class_self by fast

lemma in_quotient_imp_in_rel:
"\<lbrakk>equiv A r; X \<in> A//r; {x,y} \<subseteq> X\<rbrakk> \<Longrightarrow> (x,y) \<in> r"
using quotient_eq_iff[THEN iffD1] by fastforce

lemma in_quotient_imp_closed:
"\<lbrakk>equiv A r; X \<in> A//r; x \<in> X; (x,y) \<in> r\<rbrakk> \<Longrightarrow> y \<in> X"
unfolding quotient_def equiv_def trans_def by blast

lemma in_quotient_imp_subset:
"\<lbrakk>equiv A r; X \<in> A//r\<rbrakk> \<Longrightarrow> X \<subseteq> A"
using assms in_quotient_imp_in_rel equiv_type by fastforce

subsection {* Equivalence relations -- predicate version *}

text {* Partial equivalences *}

definition part_equivp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
  "part_equivp R \<longleftrightarrow> (\<exists>x. R x x) \<and> (\<forall>x y. R x y \<longleftrightarrow> R x x \<and> R y y \<and> R x = R y)"
    -- {* John-Harrison-style characterization *}

lemma part_equivpI:
  "(\<exists>x. R x x) \<Longrightarrow> symp R \<Longrightarrow> transp R \<Longrightarrow> part_equivp R"
  by (auto simp add: part_equivp_def) (auto elim: sympE transpE)

lemma part_equivpE:
  assumes "part_equivp R"
  obtains x where "R x x" and "symp R" and "transp R"
proof -
  from assms have 1: "\<exists>x. R x x"
    and 2: "\<And>x y. R x y \<longleftrightarrow> R x x \<and> R y y \<and> R x = R y"
    by (unfold part_equivp_def) blast+
  from 1 obtain x where "R x x" ..
  moreover have "symp R"
  proof (rule sympI)
    fix x y
    assume "R x y"
    with 2 [of x y] show "R y x" by auto
  qed
  moreover have "transp R"
  proof (rule transpI)
    fix x y z
    assume "R x y" and "R y z"
    with 2 [of x y] 2 [of y z] show "R x z" by auto
  qed
  ultimately show thesis by (rule that)
qed

lemma part_equivp_refl_symp_transp:
  "part_equivp R \<longleftrightarrow> (\<exists>x. R x x) \<and> symp R \<and> transp R"
  by (auto intro: part_equivpI elim: part_equivpE)

lemma part_equivp_symp:
  "part_equivp R \<Longrightarrow> R x y \<Longrightarrow> R y x"
  by (erule part_equivpE, erule sympE)

lemma part_equivp_transp:
  "part_equivp R \<Longrightarrow> R x y \<Longrightarrow> R y z \<Longrightarrow> R x z"
  by (erule part_equivpE, erule transpE)

lemma part_equivp_typedef:
  "part_equivp R \<Longrightarrow> \<exists>d. d \<in> {c. \<exists>x. R x x \<and> c = Collect (R x)}"
  by (auto elim: part_equivpE)

text {* Total equivalences *}

definition equivp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
  "equivp R \<longleftrightarrow> (\<forall>x y. R x y = (R x = R y))" -- {* John-Harrison-style characterization *}

lemma equivpI:
  "reflp R \<Longrightarrow> symp R \<Longrightarrow> transp R \<Longrightarrow> equivp R"
  by (auto elim: reflpE sympE transpE simp add: equivp_def)

lemma equivpE:
  assumes "equivp R"
  obtains "reflp R" and "symp R" and "transp R"
  using assms by (auto intro!: that reflpI sympI transpI simp add: equivp_def)

lemma equivp_implies_part_equivp:
  "equivp R \<Longrightarrow> part_equivp R"
  by (auto intro: part_equivpI elim: equivpE reflpE)

lemma equivp_equiv:
  "equiv UNIV A \<longleftrightarrow> equivp (\<lambda>x y. (x, y) \<in> A)"
  by (auto intro!: equivI equivpI [to_set] elim!: equivE equivpE [to_set])

lemma equivp_reflp_symp_transp:
  shows "equivp R \<longleftrightarrow> reflp R \<and> symp R \<and> transp R"
  by (auto intro: equivpI elim: equivpE)

lemma identity_equivp:
  "equivp (op =)"
  by (auto intro: equivpI reflpI sympI transpI)

lemma equivp_reflp:
  "equivp R \<Longrightarrow> R x x"
  by (erule equivpE, erule reflpE)

lemma equivp_symp:
  "equivp R \<Longrightarrow> R x y \<Longrightarrow> R y x"
  by (erule equivpE, erule sympE)

lemma equivp_transp:
  "equivp R \<Longrightarrow> R x y \<Longrightarrow> R y z \<Longrightarrow> R x z"
  by (erule equivpE, erule transpE)

hide_const (open) proj

end