section \<open>Auxiliary Lemma Library\<close>
theory IMP2_Aux_Lemmas
imports "HOL-Library.Multiset" "HOL-Library.Rewrite"
begin

text \<open>This library contains auxiliary lemmas, which are useful for proving
  various VCs.
\<close>

subsection \<open>Termination Proofs\<close>

\<comment> \<open>Useful lemma to show well-foundedness of some process approaching a finite upper bound\<close>
lemma wf_bounded_supset: "finite S \<Longrightarrow> wf {(Q',Q). Q'\<supset>Q \<and> Q'\<subseteq> S}"
proof -
  assume [simp]: "finite S"
  hence [simp]: "!!x. finite (S-x)" by auto
  have "{(Q',Q). Q\<subset>Q' \<and> Q'\<subseteq> S} \<subseteq> inv_image ({(s'::nat,s). s'<s}) (\<lambda>Q. card (S-Q))"
  proof (intro subsetI, case_tac x, simp)
    fix a b
    assume A: "b\<subset>a \<and> a\<subseteq>S"
    hence "S-a \<subset> S-b" by blast
    thus "card (S-a) < card (S-b)" by (auto simp add: psubset_card_mono)
  qed
  moreover have "wf ({(s'::nat,s). s'<s})" by (rule wf_less)
  ultimately show ?thesis by (blast intro: wf_subset)
qed

text \<open>Well-founded relation to approximate a finite set from below\<close>
definition "finite_psupset S \<equiv> { (Q',Q). Q\<subset>Q' \<and> Q' \<subseteq> S }"
lemma finite_psupset_wf[simp, intro]: "finite S \<Longrightarrow> wf (finite_psupset S)"
  unfolding finite_psupset_def by (blast intro: wf_bounded_supset)

subsection \<open>Conversion between \<open>nat\<close> and \<open>int\<close>\<close>

lemmas nat_distribs = nat_add_distrib nat_diff_distrib Suc_diff_le nat_mult_distrib nat_div_distrib

subsection \<open>Interval Sets\<close>

lemma intvs_singleton[simp]:
  "{i::int..<i + 1} = {i}"
  "{i-1..<i::int} = {i-1}"
  by auto

lemma intvs_incr_h:
  "l\<le>h \<Longrightarrow> {l::int..<h + 1} = insert h {l..<h}"
  by auto

lemma intvs_decr_h:
  "{l::int..<h - 1} = {l..<h} - {h-1}"
  by auto

lemma intvs_incr_l:
  "{l+1..<h::int} = {l..<h} - {l}"
  by auto

lemma intvs_decr_l:
  "l\<le>h \<Longrightarrow> {l-1..<h::int} = insert (l-1) {l..<h}"
  by auto

lemma intvs_lower_incr: "l<h \<Longrightarrow> {l::int..<h} = insert l ({l+1..<h})" by auto
lemma intvs_upper_decr: "l<h \<Longrightarrow> {l::int..<h} = insert (h-1) ({l..<h-1})" by auto

subsubsection \<open>Induction on Intervals\<close>

function intv_fwd_induct_scheme :: "int \<Rightarrow> int \<Rightarrow> unit" where
  "intv_fwd_induct_scheme l h = (if l<h then intv_fwd_induct_scheme (l+1) h else ())"
  by pat_completeness auto
termination apply (relation "measure (\<lambda>(l,h). nat (h-l))") by auto
lemmas intv_induct = intv_fwd_induct_scheme.induct[case_names incr]

function intv_bwd_induct_scheme :: "int \<Rightarrow> int \<Rightarrow> unit" where
  "intv_bwd_induct_scheme l h = (if l<h then intv_bwd_induct_scheme l (h-1) else ())"
  by pat_completeness auto
termination apply (relation "measure (\<lambda>(l,h). nat (h-l))") by auto
lemmas intv_bwd_induct = intv_bwd_induct_scheme.induct[case_names decr]

subsection \<open>Multiset Lemmas\<close>

lemma image_mset_eq_imp_set_eq:
  assumes "image_mset f s = image_mset g s"
  shows "f`(set_mset s) = g`set_mset s"
  using assms
  by (metis set_image_mset)

subsection \<open>Equal on Set\<close>
definition eq_on :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> bool" ("_ = _ on _" [50,50,50] 50)
  where "s=t on X \<longleftrightarrow> (\<forall>x\<in>X. s x = t x)"

lemma eq_on_subst_same:
  "x\<in>X \<Longrightarrow> s(x:=v) = t on X \<longleftrightarrow> t x = v \<and> s=t on (X-{x})"
  "x\<in>X \<Longrightarrow> s = t(x:=v) on X \<longleftrightarrow> s x = v \<and> s=t on (X-{x})"
  by (auto simp: eq_on_def)

lemma eq_on_subst_other[simp]:
  "x\<notin>X \<Longrightarrow> s(x:=v) = t on X \<longleftrightarrow> s=t on X"
  "x\<notin>X \<Longrightarrow> s = t(x:=v) on X \<longleftrightarrow> s=t on X"
  by (auto simp: eq_on_def)

lemma eq_on_refl[simp]: "s = s on X"
  by (auto simp: eq_on_def)

lemma eq_on_sym[sym]: "s=t on X \<Longrightarrow> t=s on X"
  by (auto simp: eq_on_def)

lemma eq_on_trans'[trans]: "r=s on X \<Longrightarrow> s=t on X' \<Longrightarrow> r=t on (X\<inter>X')"
  by (auto simp: eq_on_def)

lemma eq_onD: "r = s on X \<Longrightarrow> x\<in>X \<Longrightarrow> r x = s x"
  by (auto simp: eq_on_def)

lemma eq_on_xfer_pointwise: "\<lbrakk>a=a' on r'; r\<subseteq>r'\<rbrakk> \<Longrightarrow> (\<forall>i\<in>r. P (a i)) \<longleftrightarrow> (\<forall>i\<in>r. P (a' i))"
  by (auto simp: eq_on_def subset_iff)

subsection \<open>Arrays\<close>

subsubsection \<open>Sortedness\<close>
text \<open>Sortedness as monotonicity property\<close>
definition ran_sorted :: "(int \<Rightarrow> int) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
  "ran_sorted a l h \<equiv> \<forall>i\<in>{l..<h}. \<forall>j\<in>{l..<h}. i\<le>j \<longrightarrow> a i \<le> a j"

text \<open>Alternative definition\<close>
lemma ran_sorted_alt: "ran_sorted a l h = ( \<forall>i j. l\<le>i \<and> i<j \<and> j<h \<longrightarrow> a i \<le> a j)"
  unfolding ran_sorted_def
  by auto (metis dual_order.order_iff_strict)

lemma ran_sorted_empty[simp]: "ran_sorted a l l"
  by (auto simp: ran_sorted_def)

lemma ran_sorted_singleton[simp]: "ran_sorted a l (l+1)"
  by (auto simp: ran_sorted_def)

lemma eq_on_xfer_ran_sorted: "\<lbrakk> a=a' on r'; {l..<h} \<subseteq> r' \<rbrakk> \<Longrightarrow> ran_sorted a l h \<longleftrightarrow> ran_sorted a' l h"
  unfolding ran_sorted_alt eq_on_def by (auto simp: subset_iff)

lemma combine_sorted_pivot:
  assumes "l\<le>i" "i<h"
  assumes "ran_sorted a l i"
  assumes "ran_sorted a (i+1) h"
  assumes "\<forall>k\<in>{l..<i}. a k < a i"
  assumes "\<forall>k\<in>{i+1..<h}. a k \<ge> a i"
  shows "ran_sorted a l h"
  using assms unfolding ran_sorted_def Ball_def
  by clarsimp smt

subsubsection \<open>Multiset of Ranges in Arrays\<close>
definition mset_ran :: "(int \<Rightarrow> 'a) \<Rightarrow> int set \<Rightarrow> 'a multiset"
  where "mset_ran a r \<equiv> image_mset a (mset_set r)"

lemma mset_ran_infinite[simp]: "infinite r \<Longrightarrow> mset_ran a r = {#}"
  by (auto simp: mset_ran_def)

lemma mset_ran_by_sum: "mset_ran a r = (\<Sum>i\<in>r. {#a i#})"
proof (cases "finite r")
  case True thus ?thesis
    apply (induction r)
     apply (auto simp: mset_ran_def)
    done
qed simp

lemma mset_ran_mem[simp, intro]: "finite r \<Longrightarrow> i\<in>r \<Longrightarrow> a i \<in># mset_ran a r"
  by (auto simp: mset_ran_def)

lemma mset_ran_empty[simp]:
  "mset_ran a {} = {#}"
  by (auto simp: mset_ran_def)

lemma mset_ran_empty_iff[simp]:
  "finite r \<Longrightarrow> mset_ran a r = {#} \<longleftrightarrow> r={}"
  by (auto simp: mset_ran_def mset_set_empty_iff)

lemma mset_ran_single[simp]: "mset_ran a {i} = {#a i#}"
  by (auto simp: mset_ran_def)

lemma mset_ran_eq_single_conv: "mset_ran a r = {#x#} \<longleftrightarrow> (\<exists>i. r={i} \<and> x= a i)"
  apply (cases "finite r")
   apply (auto simp: mset_ran_def)
  using finite_set_mset_mset_set msed_map_invR by force

lemma mset_ran_insert: "\<lbrakk>finite r; i\<notin>r\<rbrakk> \<Longrightarrow> mset_ran a (insert i r) = add_mset (a i) (mset_ran a r)"
  by (auto simp: mset_ran_def)

lemma mset_ran_subst_outside: "i\<notin>r \<Longrightarrow> mset_ran (a(i:=x)) r = mset_ran a r"
  unfolding mset_ran_def by (cases "finite r") (auto simp: image_mset_subst_outside)

lemma mset_ran_subst_inside: "finite r \<Longrightarrow> i\<in>r \<Longrightarrow> mset_ran (a(i:=x)) r = mset_ran a r + {#x#} - {#a i#}"
  unfolding mset_ran_def by (auto simp: image_mset_set_subst_inside)

lemma mset_ran_combine1: "\<lbrakk>finite r\<^sub>1; finite r\<^sub>2; r\<^sub>1\<inter>r\<^sub>2={}\<rbrakk> \<Longrightarrow> mset_ran a r\<^sub>1 + mset_ran a r\<^sub>2 = mset_ran a (r\<^sub>1\<union>r\<^sub>2)"
  by (auto simp: mset_ran_by_sum sum.union_disjoint[symmetric])

lemma mset_ran_combine2: "\<lbrakk>finite r; i\<notin>r\<rbrakk> \<Longrightarrow> add_mset (a i) (mset_ran a r) = mset_ran a (insert i r)"
  using mset_ran_combine1[of "{i}" r a]
  by auto

lemmas mset_ran_combine = mset_ran_combine1 mset_ran_combine2

lemma mset_ran_cong:
  "a = b on r \<Longrightarrow> mset_ran a r = mset_ran b r"
  apply (cases "finite r")
  by (auto simp: mset_ran_by_sum eq_on_def)

lemma mset_ran_shift:
  "inj_on f r \<Longrightarrow> mset_ran (a o f) r = mset_ran a (f`r)"
  apply (auto simp: mset_ran_def)
  by (metis image_mset_mset_set multiset.map_comp)

lemma mset_ran_combine_eqs:
  assumes "mset_ran a r\<^sub>1 = mset_ran b r\<^sub>1"
  assumes "mset_ran a r\<^sub>2 = mset_ran b r\<^sub>2"
  assumes "r\<^sub>1\<inter>r\<^sub>2 = {}"
  shows "mset_ran a (r\<^sub>1\<union>r\<^sub>2) = mset_ran b (r\<^sub>1\<union>r\<^sub>2)"
  apply (cases "finite r\<^sub>1"; cases "finite r\<^sub>2"; simp?)
  using assms(1,2)
  apply (simp add: mset_ran_combine1[OF _ _ assms(3), symmetric])
  done

lemma mset_ran_combine_eq_diff:
  assumes "mset_ran a (r-I) = mset_ran a' (r-I)"
  assumes "a=a' on I"
  shows "mset_ran a r = mset_ran a' r"
proof -
  have [simp]: "(r - I) \<inter> (r \<inter> I) = {}" by auto
  have [simp]: "r - I \<union> r \<inter> I = r" by auto

  from assms(2) have "mset_ran a (r \<inter> I) = mset_ran a' (r \<inter> I)"
    by (auto simp: mset_ran_by_sum eq_on_def)
  from mset_ran_combine_eqs[OF assms(1) this] show ?thesis by auto
qed

lemma mset_ran_eq_extend:
  assumes "mset_ran a r' = mset_ran a' r'"
  assumes "a = a' on r2"
  assumes "r-r' \<subseteq> r2"
  assumes "r'\<subseteq>r"
  shows "mset_ran a r = mset_ran a' r"
proof -
  have [simp]: "r' \<inter> (r - r') = {}" "r' \<union> r = r" using assms(4) by auto

  from assms(2,3) have "a=a' on r-r'" by (auto simp: eq_on_def)
  then have "mset_ran a (r-r') = mset_ran a' (r-r')"
    by (auto simp: mset_ran_by_sum eq_on_def)
  from mset_ran_combine_eqs[OF assms(1) this] show ?thesis by auto
qed

lemma mset_ran_xfer_pointwise:
  assumes "mset_ran a r = mset_ran a' r"
  assumes "finite r"
  shows "(\<forall>i\<in>r. P (a i)) \<longleftrightarrow> (\<forall>i\<in>r. P (a' i))"
  using assms unfolding mset_ran_def
  by (auto;force dest: image_mset_eq_imp_set_eq)

subsection \<open>Swap\<close>
definition "swap a i j \<equiv> a(i:=a j, j:=a i)"

lemma mset_ran_swap: "\<lbrakk> i\<in>r; j\<in>r \<rbrakk>
  \<Longrightarrow> mset_ran (swap a i j) r = mset_ran a r"
  by (cases "finite r") (auto simp: swap_def mset_ran_subst_inside)

subsection \<open>Range of an Array as List\<close>
function (sequential) lran :: "(int \<Rightarrow> 'a) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> 'a list" where
  "lran a l h = (if l<h then a l # lran a (l+1) h else [])"
  by pat_completeness auto
termination
  by (relation "measure (\<lambda>(_,l,h). nat (h-l))") auto

declare lran.simps[simp del]

text \<open>
  \<open>lran a l h\<close> is the list \<open>[a\<^sub>l,a\<^sub>l\<^sub>+\<^sub>1,...,a\<^sub>h\<^sub>-\<^sub>1]\<close>
\<close>

subsubsection \<open>Auxiliary Lemmas\<close>

lemma lran_empty[simp]:
  "lran a l l = []"
  "lran a l h = [] \<longleftrightarrow> h\<le>l"
  by (subst lran.simps; auto)+

lemma lran_bwd_simp: "lran a l h = (if l<h then lran a l (h-1)@[a (h-1)] else [])"
  apply (induction a l h rule: lran.induct)
  apply (rewrite in "\<hole> = _" lran.simps)
  apply (rewrite in "_ = \<hole>" lran.simps)
  by (auto simp: less_le)

lemma length_lran[simp]: "length (lran a l h) = nat (h-l)"
  apply (induction a l h rule: lran.induct)
  apply (subst lran.simps)
  apply (auto)
  done

lemma nth_lran[simp]: "int i < h-l \<Longrightarrow> lran a l h ! i = a (l + int i)"
  apply (induction a l h arbitrary: i rule: lran.induct)
  apply (subst lran.simps)
  apply (auto simp: nth_Cons nth_tl algebra_simps split: nat.splits)
  done

lemma lran_append1[simp]: "l\<le>h \<Longrightarrow> lran a l (h + 1) = lran a l h @ [a h]"
  by (rewrite in "\<hole> = _" lran_bwd_simp) auto

lemma lran_prepend1[simp]: "l\<le>h \<Longrightarrow> lran a (l-1) h = a(l-1) # lran a l h"
  by (rewrite in "\<hole> = _" lran.simps) auto

lemma lran_tail[simp]: "lran a (l+1) h = tl (lran a l h)"
  apply (rewrite in "_ = \<hole>" lran.simps)
  apply auto
  done

lemma lran_butlast[simp]: "lran a l (h-1) = butlast (lran a l h)"
  apply (rewrite in "_ = \<hole>" lran_bwd_simp)
  apply auto
  done

lemma hd_lran[simp]: "l<h \<Longrightarrow> hd (lran a l h) = a l"
  apply (subst lran.simps) by simp

lemma last_lran[simp]: "l<h \<Longrightarrow> last (lran a l h) = a (h-1)"
  apply (subst lran_bwd_simp) by simp

lemma lran_upd_outside[simp]:
  "i<l \<Longrightarrow> lran (a(i:=x)) l h = lran a l h"
  "h\<le>i \<Longrightarrow> lran (a(i:=x)) l h = lran a l h"
  subgoal
    apply (induction a l h rule: lran.induct)
    apply (rewrite in "\<hole> = _" lran.simps)
    apply (rewrite in "_ = \<hole>" lran.simps)
    by (auto)
  subgoal
    apply (induction a l h rule: lran.induct)
    apply (rewrite in "\<hole> = _" lran.simps)
    apply (rewrite in "_ = \<hole>" lran.simps)
    by (auto)
  done

lemma lran_upd_inside: "i\<in>{l..<h} \<Longrightarrow> lran (a(i:=x)) l h = (lran a l h)[nat (i-l) := x]"
  apply (rule nth_equalityI)
   apply (simp_all add: nth_list_update, linarith)
  done

lemma tl_upd_at0[simp]: "tl (xs[0:=x]) = tl xs" by (cases xs) auto

lemma lran_eq_iff: "lran a l h = lran a' l h \<longleftrightarrow> (\<forall>i. l\<le>i \<and> i<h \<longrightarrow> a i = a' i)"
  apply (induction a l h rule: lran.induct)
  apply (rewrite in "\<hole> = _" lran.simps)
  apply (rewrite in "_ = \<hole>" lran.simps)
  apply auto
  by (metis antisym_conv not_less zless_imp_add1_zle)

lemma set_lran: "set (lran a l h) = a`{l..<h}"
  apply (induction a l h rule: lran.induct)
  apply (rewrite in "\<hole> = _" lran.simps)
  apply auto
  by (metis atLeastLessThan_iff image_iff not_less not_less_iff_gr_or_eq zless_imp_add1_zle)

lemma mset_lran: "mset (lran a l h) = mset_ran a {l..<h}"
  apply (induction a l h rule: lran.induct)
  apply (rewrite in "\<hole> = _" lran.simps)
  by (auto simp: intvs_lower_incr mset_ran_insert)

end


section\<open>Theory of Quaternions\<close>
text\<open>This theory is inspired by the HOL Light development of quaternions, but follows its own route.
Quaternions are developed coinductively, as in the existing formalisation of the complex numbers.
Quaternions are quickly shown to belong to the type classes of real normed division algebras
and real inner product spaces. And therefore they inherit a great body of facts involving algebraic
laws, limits, continuity, etc., which must be proved explicitly in the HOL Light version.
The development concludes with the geometric interpretation of the product of imaginary quaternions.\<close>
theory "Quaternions"
  imports
    "HOL-Analysis.Multivariate_Analysis"
begin

subsection\<open>Basic definitions\<close>

text\<open>As with the complex numbers, coinduction is convenient\<close>

codatatype quat = Quat (Re: real) (Im1: real) (Im2: real) (Im3: real)

lemma quat_eqI [intro?]: "\<lbrakk>Re x = Re y; Im1 x = Im1 y; Im2 x = Im2 y; Im3 x = Im3 y\<rbrakk> \<Longrightarrow> x = y"
  by (rule quat.expand) simp

lemma quat_eq_iff: "x = y \<longleftrightarrow> Re x = Re y \<and> Im1 x = Im1 y \<and> Im2 x = Im2 y \<and> Im3 x = Im3 y"
  by (auto intro: quat.expand)

context
begin
no_notation Complex.imaginary_unit ("\<i>")

primcorec quat_ii :: quat  ("\<i>")
  where "Re \<i> = 0" | "Im1 \<i> = 1" | "Im2 \<i> = 0" | "Im3 \<i> = 0"

primcorec quat_jj :: quat  ("\<j>")
  where "Re \<j> = 0" | "Im1 \<j> = 0" | "Im2 \<j> = 1" | "Im3 \<j> = 0"

primcorec quat_kk :: quat  ("\<k>")
  where "Re \<k> = 0" | "Im1 \<k> = 0" | "Im2 \<k> = 0" | "Im3 \<k> = 1"

end

bundle quaternion_syntax begin
notation quat_ii ("\<i>")
no_notation Complex.imaginary_unit ("\<i>")
end

bundle no_quaternion_syntax begin
no_notation quat_ii ("\<i>")
notation Complex.imaginary_unit ("\<i>")
end

unbundle quaternion_syntax

subsection \<open>Addition and Subtraction: An Abelian Group\<close>

instantiation quat :: ab_group_add
begin

primcorec zero_quat
  where "Re 0 = 0" |"Im1 0 = 0" | "Im2 0 = 0" | "Im3 0 = 0"

primcorec plus_quat
  where
    "Re (x + y) = Re x + Re y"
  | "Im1 (x + y) = Im1 x + Im1 y"
  | "Im2 (x + y) = Im2 x + Im2 y"
  | "Im3 (x + y) = Im3 x + Im3 y"

primcorec uminus_quat
  where
    "Re (- x) = - Re x"
  | "Im1 (- x) = - Im1 x"
  | "Im2 (- x) = - Im2 x"
  | "Im3 (- x) = - Im3 x"

primcorec minus_quat
  where
    "Re (x - y) = Re x - Re y"
  | "Im1 (x - y) = Im1 x - Im1 y"
  | "Im2 (x - y) = Im2 x - Im2 y"
  | "Im3 (x - y) = Im3 x - Im3 y"

instance
  by standard (simp_all add: quat_eq_iff)

end

subsection \<open>A Vector Space\<close>

instantiation quat :: real_vector

begin

primcorec scaleR_quat
  where
    "Re (scaleR r x) = r * Re x"
  | "Im1 (scaleR r x) = r * Im1 x"
  | "Im2 (scaleR r x) = r * Im2 x"
  | "Im3 (scaleR r x) = r * Im3 x"

instance
  by standard (auto simp: quat_eq_iff distrib_left distrib_right  scaleR_add_right)

end

instantiation quat :: real_algebra_1

begin

primcorec one_quat
  where "Re 1 = 1" | "Im1 1 = 0" | "Im2 1 = 0" | "Im3 1 = 0"

primcorec times_quat
  where
    "Re (x * y) = Re x * Re y - Im1 x * Im1 y - Im2 x * Im2 y - Im3 x * Im3 y"
  | "Im1 (x * y) = Re x * Im1 y + Im1 x *  Re y + Im2 x * Im3 y - Im3 x * Im2 y"
  | "Im2 (x * y) = Re x * Im2 y - Im1 x * Im3 y + Im2 x *  Re y + Im3 x * Im1 y"
  | "Im3 (x * y) = Re x * Im3 y + Im1 x * Im2 y - Im2 x * Im1 y + Im3 x *  Re y"

instance
  by standard (auto simp: quat_eq_iff distrib_left distrib_right Rings.right_diff_distrib Rings.left_diff_distrib)

end

subsection \<open>Multiplication and Division: A Real Division Algebra\<close>

instantiation quat :: real_div_algebra
begin

primcorec inverse_quat
  where
    "Re (inverse x) = Re x / ((Re x)\<^sup>2 + (Im1 x)\<^sup>2 + (Im2 x)\<^sup>2 + (Im3 x)\<^sup>2)"
  | "Im1 (inverse x) = - (Im1 x) / ((Re x)\<^sup>2 + (Im1 x)\<^sup>2 + (Im2 x)\<^sup>2 + (Im3 x)\<^sup>2)"
  | "Im2 (inverse x) = - (Im2 x) / ((Re x)\<^sup>2 + (Im1 x)\<^sup>2 + (Im2 x)\<^sup>2 + (Im3 x)\<^sup>2)"
  | "Im3 (inverse x) = - (Im3 x) / ((Re x)\<^sup>2 + (Im1 x)\<^sup>2 + (Im2 x)\<^sup>2 + (Im3 x)\<^sup>2)"

definition "x div y = x * inverse y" for x y :: quat

instance
proof
  show "\<And>x::quat. x \<noteq> 0 \<Longrightarrow> inverse x * x = 1"
    by (auto simp: quat_eq_iff add_nonneg_eq_0_iff
        power2_eq_square add_divide_distrib [symmetric] diff_divide_distrib [symmetric])
  show "\<And>x::quat. x \<noteq> 0 \<Longrightarrow> x * inverse x = 1"
    by (auto simp: quat_eq_iff add_nonneg_eq_0_iff power2_eq_square add_divide_distrib [symmetric])
  show "\<And>x y::quat. x div y = x * inverse y"
    by (simp add: divide_quat_def)
  show "inverse 0 = (0::quat)"
    by (auto simp: quat_eq_iff)
qed

end

subsection \<open>Multiplication and Division: A Real Normed Division Algebra\<close>

fun quat_proj
  where
    "quat_proj x 0 = Re x"
  | "quat_proj x (Suc 0) = Im1 x"
  | "quat_proj x (Suc (Suc 0)) = Im2 x"
  | "quat_proj x (Suc (Suc (Suc 0))) = Im3 x"

lemma quat_proj_add:
  assumes "i \<le> 3"
  shows "quat_proj (x+y) i = quat_proj x i + quat_proj y i"
proof -
  consider "i = 0" | "i = 1" | "i = 2" | "i = 3"
    using assms by linarith
  then show ?thesis
    by cases (auto simp: numeral_2_eq_2 numeral_3_eq_3)
qed

instantiation quat :: real_normed_div_algebra
begin

definition "norm z = sqrt ((Re z)\<^sup>2 + (Im1 z)\<^sup>2 + (Im2 z)\<^sup>2 + (Im3 z)\<^sup>2)"

definition "sgn x = x /\<^sub>R norm x" for x :: quat

definition "dist x y = norm (x - y)" for x y :: quat

definition [code del]:
  "(uniformity :: (quat \<times> quat) filter) = (INF e\<in>{0 <..}. principal {(x, y). dist x y < e})"

definition [code del]:
  "open (U :: quat set) \<longleftrightarrow> (\<forall>x\<in>U. eventually (\<lambda>(x', y). x' = x \<longrightarrow> y \<in> U) uniformity)"

lemma norm_eq_L2: "norm z = L2_set (quat_proj z) {..3}"
  by (simp add: norm_quat_def L2_set_def numeral_3_eq_3)

instance
proof
  fix r :: real and x y :: quat and S :: "quat set"
  show "(norm x = 0) \<longleftrightarrow> (x = 0)"
    by (simp add: norm_quat_def quat_eq_iff add_nonneg_eq_0_iff)
  have eq: "L2_set (quat_proj (x + y)) {..3} = L2_set (\<lambda>i. quat_proj x i + quat_proj y i) {..3}"
    by (rule L2_set_cong) (auto simp: quat_proj_add)
  show "norm (x + y) \<le> norm x + norm y"
    by (simp add: norm_eq_L2 eq L2_set_triangle_ineq)
  show "norm (scaleR r x) = \<bar>r\<bar> * norm x"
    by (simp add: norm_quat_def quat_eq_iff power_mult_distrib distrib_left [symmetric] real_sqrt_mult)
  show "norm (x * y) = norm x * norm y"
    by (simp add: norm_quat_def quat_eq_iff real_sqrt_mult [symmetric]
        power2_eq_square algebra_simps)
qed (rule sgn_quat_def dist_quat_def open_quat_def uniformity_quat_def)+

end

instantiation quat :: real_inner
begin

definition inner_quat_def:
  "inner x y = Re x * Re y + Im1 x * Im1 y + Im2 x * Im2 y + Im3 x * Im3 y"

instance
proof
  fix x y z :: quat and r :: real
  show "inner x y = inner y x"
    unfolding inner_quat_def by (simp add: mult.commute)
  show "inner (x + y) z = inner x z + inner y z"
    unfolding inner_quat_def by (simp add: distrib_right)
  show "inner (scaleR r x) y = r * inner x y"
    unfolding inner_quat_def by (simp add: distrib_left)
  show "0 \<le> inner x x"
    unfolding inner_quat_def by simp
  show "inner x x = 0 \<longleftrightarrow> x = 0"
    unfolding inner_quat_def by (simp add: add_nonneg_eq_0_iff quat_eq_iff)
  show "norm x = sqrt (inner x x)"
    unfolding inner_quat_def norm_quat_def
    by (simp add: power2_eq_square)
qed

end

lemma quat_inner_1 [simp]: "inner 1 x = Re x"
  unfolding inner_quat_def by simp

lemma quat_inner_1_right [simp]: "inner x 1 = Re x"
  unfolding inner_quat_def by simp

lemma quat_inner_i_left [simp]: "inner \<i> x = Im1 x"
  unfolding inner_quat_def by simp

lemma quat_inner_i_right [simp]: "inner x \<i> = Im1 x"
  unfolding inner_quat_def by simp

lemma quat_inner_j_left [simp]: "inner \<j> x = Im2 x"
  unfolding inner_quat_def by simp

lemma quat_inner_j_right [simp]: "inner x \<j> = Im2 x"
  unfolding inner_quat_def by simp

lemma quat_inner_k_left [simp]: "inner \<k> x = Im3 x"
  unfolding inner_quat_def by simp

lemma quat_inner_k_right [simp]: "inner x \<k> = Im3 x"
  unfolding inner_quat_def by simp

abbreviation quat_of_real :: "real \<Rightarrow> quat"
  where "quat_of_real \<equiv> of_real"

lemma Re_quat_of_real [simp]: "Re(quat_of_real a) = a"
  by (simp add: of_real_def)

lemma Im1_quat_of_real [simp]: "Im1(quat_of_real a) = 0"
  by (simp add: of_real_def)

lemma Im2_quat_of_real [simp]: "Im2(quat_of_real a) = 0"
  by (simp add: of_real_def)

lemma Im3_quat_of_real [simp]: "Im3(quat_of_real a) = 0"
  by (simp add: of_real_def)

lemma quat_eq_0_iff: "q = 0 \<longleftrightarrow> (Re q)\<^sup>2 + (Im1 q)\<^sup>2 + (Im2 q)\<^sup>2 + (Im3 q)\<^sup>2 = 0"
proof
  assume "(quat.Re q)\<^sup>2 + (Im1 q)\<^sup>2 + (Im2 q)\<^sup>2 + (Im3 q)\<^sup>2 = 0"
  then have "\<forall>qa. qa - q = qa"
    by (simp add: add_nonneg_eq_0_iff minus_quat.ctr)
  then show "q = 0"
    by simp
qed auto

lemma quat_of_real_times_commute: "quat_of_real r * q = q * of_real r"
  by (simp add: of_real_def)

lemma quat_of_real_times_left_commute: "quat_of_real r * (p * q) = p * (of_real r * q)"
  by (simp add: of_real_def)

lemma quat_norm_units [simp]: "norm quat_ii = 1" "norm (\<j>::quat) = 1" "norm (\<k>::quat) = 1"
  by (auto simp: norm_quat_def)

lemma ii_nz [simp]: "quat_ii \<noteq> 0"
  using quat_ii.simps(2) by fastforce

lemma jj_nz [simp]: "\<j> \<noteq> 0"
  using quat_jj.sel(3) by fastforce

lemma kk_nz [simp]: "\<k> \<noteq> 0"
  using quat_kk.sel(4) by force

text\<open>An "expansion" theorem into the traditional notation\<close>

lemma quat_unfold:
   "q = of_real(Re q) + \<i> * of_real(Im1 q) + \<j> * of_real(Im2 q) + \<k> * of_real(Im3 q)"
  by (simp add: quat_eq_iff)

lemma quat_trad: "Quat x y z w = of_real x + \<i> * of_real y + \<j> * of_real z + \<k> * of_real w"
  by (simp add: quat_eq_iff)

lemma of_real_eq_Quat: "of_real a = Quat a 0 0 0"
  by (simp add: quat_trad)

lemma ii_squared [simp]: "quat_ii\<^sup>2 = -1"
  by (simp add: power2_eq_square quat.expand)

lemma jj_squared [simp]: "\<j>^2 = -1"
  by (simp add: power2_eq_square quat.expand)

lemma kk_squared [simp]: "\<k>^2 = -1"
  by (simp add: power2_eq_square quat.expand)

lemma inverse_ii [simp]: "inverse quat_ii = -quat_ii"
  by (simp add: power2_eq_square quat.expand)

lemma inverse_jj [simp]: "inverse \<j> = -\<j>"
  by (simp add: power2_eq_square quat.expand)

lemma inverse_kk [simp]: "inverse \<k> = -\<k>"
  by (simp add: power2_eq_square quat.expand)

lemma inverse_mult: "inverse (p * q) = inverse q * inverse p" for p::quat
  by (metis inverse_zero mult_not_zero nonzero_inverse_mult_distrib)

lemma quat_of_real_inverse_collapse [simp]:
  assumes "c \<noteq> 0"
  shows "quat_of_real c * quat_of_real (inverse c) = 1" "quat_of_real (inverse c) * quat_of_real c = 1"
  using assms by auto

subsection\<open>Conjugate of a quaternion\<close>

primcorec cnj :: "quat \<Rightarrow> quat"
  where
    "Re (cnj z) = Re z"
  | "Im1 (cnj z) = - Im1 z"
  | "Im2 (cnj z) = - Im2 z"
  | "Im3 (cnj z) = - Im3 z"

lemma cnj_cancel_iff [simp]: "cnj x = cnj y \<longleftrightarrow> x = y"
proof
  show "cnj x = cnj y \<Longrightarrow> x = y"
    by (simp add: quat_eq_iff)
qed auto

lemma cnj_of_real [simp]: "cnj(quat_of_real x) = quat_of_real x"
  by (simp add: quat_eqI)

lemma cnj_zero [simp]: "cnj 0 = 0"
  by (simp add: quat_eq_iff)

lemma cnj_zero_iff [iff]: "cnj z = 0 \<longleftrightarrow> z = 0"
  by (simp add: quat_eq_iff)

lemma cnj_one [simp]: "cnj 1 = 1"
  by (simp add: quat_eq_iff)

lemma cnj_one_iff [simp]: "cnj z = 1 \<longleftrightarrow> z = 1"
  by (simp add: quat_eq_iff)

lemma cnj_add [simp]: "cnj (x + y) = cnj x + cnj y"
  by (simp add: quat_eq_iff)

lemma cnj_sum [simp]: "cnj (sum f S) = (\<Sum>x\<in>S. cnj (f x))"
  by (induct S rule: infinite_finite_induct) auto

lemma cnj_diff [simp]: "cnj (x - y) = cnj x - cnj y"
  by (simp add: quat_eq_iff)

lemma cnj_minus [simp]: "cnj (- x) = - cnj x"
  by (simp add: quat_eq_iff)

lemma cnj_mult [simp]: "cnj (x * y) = cnj y * cnj x"
  by (simp add: quat_eq_iff)

lemma cnj_inverse [simp]: "cnj (inverse x) = inverse (cnj x)"
  by (simp add: quat_eq_iff)

lemma cnj_divide [simp]: "cnj (x / y) = inverse (cnj y) * cnj x"
  by (simp add: divide_quat_def)

lemma cnj_power [simp]: "cnj (x^n) = cnj x ^ n"
  by (induct n) (auto simp: power_commutes)

lemma cnj_of_nat [simp]: "cnj (of_nat n) = of_nat n"
  by (metis cnj_of_real of_real_of_nat_eq)

lemma cnj_of_int [simp]: "cnj (of_int z) = of_int z"
  by (metis cnj_of_real of_real_of_int_eq)

lemma cnj_neg_numeral [simp]: "cnj (- numeral w) = - numeral w"
  by simp

lemma cnj_scaleR [simp]: "cnj (scaleR r x) = scaleR r (cnj x)"
  by (simp add: quat_eq_iff)

lemma cnj_units [simp]: "cnj quat_ii = -\<i>" "cnj \<j> = -\<j>" "cnj \<k> = -\<k>"
  by (simp_all add: quat_eq_iff)

lemma cnj_eq_of_real: "cnj q = quat_of_real x \<longleftrightarrow> q = quat_of_real x"
proof
  show "cnj q = quat_of_real x \<Longrightarrow> q = quat_of_real x"
    by (metis cnj_of_real cnj_cnj)
qed auto

lemma quat_add_cnj: "q + cnj q = quat_of_real(2 * Re q)" "cnj q + q = quat_of_real(2 * Re q)"
  by simp_all (simp_all add: mult.commute mult_2 plus_quat.code)

lemma quat_divide_numeral:
  fixes x::quat shows "x / numeral w = x /\<^sub>R numeral w"
  unfolding divide_quat_def
  by (metis mult.right_neutral mult_scaleR_right of_real_def of_real_inverse of_real_numeral)

lemma Re_divide_numeral [simp]: "Re (x / numeral w) = Re x / numeral w"
  by (metis divide_inverse_commute quat_divide_numeral scaleR_quat.simps(1))

lemma Im1_divide_numeral [simp]: "Im1 (x / numeral w) = Im1 x / numeral w"
  unfolding quat_divide_numeral by simp

lemma Im3_divide_numeral [simp]: "Im3 (x / numeral w) = Im3 x / numeral w"
  unfolding quat_divide_numeral by simp

lemma of_real_quat_re_cnj: "quat_of_real(Re q) = inverse(quat_of_real 2) * (q + cnj q)"
  by (simp add: quat_eq_iff)

lemma quat_mult_cnj_commute: "cnj q * q = q * cnj q"
  by (simp add: quat_eq_iff)

lemma quat_norm_pow_2: "quat_of_real(norm q) ^ 2 = q * cnj q"
  by (simp add: quat_eq_iff norm_quat_def flip: of_real_power) (auto simp: power2_eq_square)

lemma quat_norm_pow_2_alt: "quat_of_real(norm q) ^ 2 = cnj q * q"
  by (simp add: quat_mult_cnj_commute quat_norm_pow_2)

lemma quat_inverse_cnj: "inverse q = inverse (quat_of_real((norm q)\<^sup>2)) * cnj q"
  by (simp add: quat_eq_iff norm_quat_def numeral_Bit0 flip: of_real_power)

lemma quat_inverse_eq_cnj: "norm q = 1 \<Longrightarrow> inverse q = cnj q"
  by (metis inverse_1 mult_cancel_left norm_eq_zero norm_one cnj_one quat_norm_pow_2 right_inverse)

subsection\<open>Linearity and continuity of the components\<close>

lemma bounded_linear_Re: "bounded_linear Re"
  and bounded_linear_Im1: "bounded_linear Im1"
  and bounded_linear_Im2: "bounded_linear Im2"
  and bounded_linear_Im3: "bounded_linear Im3"
  by (simp_all add: bounded_linear_intro [where K=1] norm_quat_def real_le_rsqrt add.assoc)

lemmas Cauchy_Re = bounded_linear.Cauchy [OF bounded_linear_Re]
lemmas Cauchy_Im1 = bounded_linear.Cauchy [OF bounded_linear_Im1]
lemmas Cauchy_Im2 = bounded_linear.Cauchy [OF bounded_linear_Im2]
lemmas Cauchy_Im3 = bounded_linear.Cauchy [OF bounded_linear_Im3]
lemmas tendsto_Re [tendsto_intros] = bounded_linear.tendsto [OF bounded_linear_Re]
lemmas tendsto_Im1 [tendsto_intros] = bounded_linear.tendsto [OF bounded_linear_Im1]
lemmas tendsto_Im2 [tendsto_intros] = bounded_linear.tendsto [OF bounded_linear_Im2]
lemmas tendsto_Im3 [tendsto_intros] = bounded_linear.tendsto [OF bounded_linear_Im3]
lemmas isCont_Re [simp] = bounded_linear.isCont [OF bounded_linear_Re]
lemmas isCont_Im1 [simp] = bounded_linear.isCont [OF bounded_linear_Im1]
lemmas isCont_Im2 [simp] = bounded_linear.isCont [OF bounded_linear_Im2]
lemmas isCont_Im3 [simp] = bounded_linear.isCont [OF bounded_linear_Im3]
lemmas continuous_Re [simp] = bounded_linear.continuous [OF bounded_linear_Re]
lemmas continuous_Im1 [simp] = bounded_linear.continuous [OF bounded_linear_Im1]
lemmas continuous_Im2 [simp] = bounded_linear.continuous [OF bounded_linear_Im2]
lemmas continuous_Im3 [simp] = bounded_linear.continuous [OF bounded_linear_Im3]
lemmas continuous_on_Re [continuous_intros] = bounded_linear.continuous_on[OF bounded_linear_Re]
lemmas continuous_on_Im1 [continuous_intros] = bounded_linear.continuous_on[OF bounded_linear_Im1]
lemmas continuous_on_Im2 [continuous_intros] = bounded_linear.continuous_on[OF bounded_linear_Im2]
lemmas continuous_on_Im3 [continuous_intros] = bounded_linear.continuous_on[OF bounded_linear_Im3]
lemmas has_derivative_Re [derivative_intros] = bounded_linear.has_derivative[OF bounded_linear_Re]
lemmas has_derivative_Im1 [derivative_intros] = bounded_linear.has_derivative[OF bounded_linear_Im1]
lemmas has_derivative_Im2 [derivative_intros] = bounded_linear.has_derivative[OF bounded_linear_Im2]
lemmas has_derivative_Im3 [derivative_intros] = bounded_linear.has_derivative[OF bounded_linear_Im3]
lemmas sums_Re = bounded_linear.sums [OF bounded_linear_Re]
lemmas sums_Im1 = bounded_linear.sums [OF bounded_linear_Im1]
lemmas sums_Im2 = bounded_linear.sums [OF bounded_linear_Im2]
lemmas sums_Im3 = bounded_linear.sums [OF bounded_linear_Im3]

subsection\<open>Quaternionic-specific theorems about sums\<close>

lemma Re_sum [simp]: "Re(sum f S) = sum (\<lambda>x.  Re(f x)) S" for f :: "'a \<Rightarrow> quat"
  by (induct S rule: infinite_finite_induct) auto

lemma Im1_sum [simp]: "Im1(sum f S) = sum (\<lambda>x. Im1(f x)) S"
  by (induct S rule: infinite_finite_induct) auto

lemma Im2_sum [simp]: "Im2(sum f S) = sum (\<lambda>x. Im2(f x)) S"
  by (induct S rule: infinite_finite_induct) auto

lemma Im3_sum [simp]: "Im3(sum f S) = sum (\<lambda>x. Im3(f x)) S"
  by (induct S rule: infinite_finite_induct) auto

lemma in_Reals_iff_Re: "q \<in> Reals \<longleftrightarrow> quat_of_real(Re q) = q"
  by (metis Re_quat_of_real Reals_cases Reals_of_real)

lemma in_Reals_iff_cnj: "q \<in> Reals \<longleftrightarrow> cnj q = q"
  by (simp add: in_Reals_iff_Re quat_eq_iff)

lemma real_norm: "q \<in> Reals \<Longrightarrow> norm q = abs(Re q)"
  by (metis in_Reals_iff_Re norm_of_real)

lemma norm_power2: "(norm q)\<^sup>2 = Re(cnj q * q)"
  by (metis Re_quat_of_real of_real_power quat_mult_cnj_commute quat_norm_pow_2)

lemma quat_norm_imaginary: "Re x = 0 \<Longrightarrow> x\<^sup>2 = - (quat_of_real (norm x))\<^sup>2"
  unfolding quat_norm_pow_2
  by (cases x) (auto simp: power2_eq_square cnj.ctr times_quat.ctr uminus_quat.ctr)

subsection\<open>Bound results for real and imaginary components of limits\<close>

lemma Re_tendsto_upperbound:
   "\<lbrakk>(f \<longlongrightarrow> l) net; \<forall>\<^sub>F x in net. quat.Re (f x) \<le> b; net \<noteq> bot\<rbrakk> \<Longrightarrow> Re l \<le> b"
  by (blast intro: tendsto_upperbound [OF tendsto_Re])

lemma Im1_tendsto_upperbound:
   "\<lbrakk>(f \<longlongrightarrow> l) net; \<forall>\<^sub>F x in net. Im1 (f x) \<le> b; net \<noteq> bot\<rbrakk> \<Longrightarrow> Im1 l \<le> b"
  by (blast intro: tendsto_upperbound [OF tendsto_Im1])

lemma Im2_tendsto_upperbound:
   "\<lbrakk>(f \<longlongrightarrow> l) net; \<forall>\<^sub>F x in net. Im2 (f x) \<le> b; net \<noteq> bot\<rbrakk> \<Longrightarrow> Im2 l \<le> b"
  by (blast intro: tendsto_upperbound [OF tendsto_Im2])

lemma Im1_tendsto_lowerbound:
   "\<lbrakk>(f \<longlongrightarrow> l) net; \<forall>\<^sub>F x in net. b \<le> Im1 (f x); net \<noteq> bot\<rbrakk> \<Longrightarrow> b \<le> Im1 l"
  by (blast intro: tendsto_lowerbound [OF tendsto_Im1])

lemma Im2_tendsto_lowerbound:
   "\<lbrakk>(f \<longlongrightarrow> l) net; \<forall>\<^sub>F x in net. b \<le> Im2 (f x); net \<noteq> bot\<rbrakk> \<Longrightarrow> b \<le> Im2 l"
  by (blast intro: tendsto_lowerbound [OF tendsto_Im2])

lemma Im3_tendsto_lowerbound:
   "\<lbrakk>(f \<longlongrightarrow> l) net; \<forall>\<^sub>F x in net. b \<le> Im3 (f x); net \<noteq> bot\<rbrakk> \<Longrightarrow> b \<le> Im3 l"
  by (blast intro: tendsto_lowerbound [OF tendsto_Im3])

lemma of_real_continuous_iff: "continuous net (\<lambda>x. quat_of_real(f x)) \<longleftrightarrow> continuous net f"
  by (simp add: continuous_def tendsto_iff)

lemma of_real_continuous_on_iff:
   "continuous_on S (\<lambda>x. quat_of_real(f x)) \<longleftrightarrow> continuous_on S f"
  using continuous_on_Re continuous_on_of_real by fastforce

subsection\<open>Quaternions for describing 3D isometries\<close>

subsubsection\<open>The \<open>HIm\<close> operator\<close>

definition HIm :: "quat \<Rightarrow> real^3" where
  "HIm q \<equiv> vector[Im1 q, Im2 q, Im3 q]"

lemma HIm_Quat: "HIm (Quat w x y z) = vector[x,y,z]"
  by (simp add: HIm_def)

lemma him_eq: "HIm p = HIm q \<longleftrightarrow> Im1 p = Im1 q \<and> Im2 p = Im2 q \<and> Im3 p = Im3 q"
  by (metis HIm_def vector_3)

lemma him_of_real [simp]: "HIm(of_real a) = 0"
  by (simp add: of_real_eq_Quat HIm_Quat vec_eq_iff vector_def)

lemma him_0 [simp]: "HIm 0 = 0"
  by (metis him_of_real of_real_0)

lemma him_1 [simp]: "HIm 1 = 0"
  by (metis him_of_real of_real_1)

lemma him_cnj: "HIm(cnj q) = - HIm q"
  by (simp add: HIm_def vec_eq_iff vector_def)

lemma him_mult_left [simp]: "HIm(of_real a * q) = a *\<^sub>R HIm q"
  by (simp add: HIm_def vec_eq_iff vector_def)

lemma him_mult_right [simp]: "HIm(q * of_real a) = a *\<^sub>R HIm q"
  by (simp add: HIm_def vec_eq_iff vector_def)

lemma him_add [simp]: "HIm(p + q) = HIm p + HIm q"
  by (simp add: HIm_def vec_eq_iff vector_def)

lemma him_minus [simp]: "HIm(-q) = - HIm q"
  by (simp add: HIm_def vec_eq_iff vector_def)

lemma him_diff [simp]: "HIm(p - q) = HIm p - HIm q"
  by (simp add: HIm_def vec_eq_iff vector_def)

lemma him_sum [simp]: "HIm (sum f S) = (\<Sum>x\<in>S. HIm (f x))"
  by (induct S rule: infinite_finite_induct) auto

lemma linear_him: "linear HIm"
  by (metis him_add him_mult_right linearI mult.right_neutral mult_scaleR_right of_real_def)

subsubsection\<open>The \<open>Hv\<close> operator\<close>

definition Hv :: "real^3 \<Rightarrow> quat" where
  "Hv v \<equiv> Quat 0 (v$1) (v$2) (v$3)"

lemma Re_Hv [simp]: "Re(Hv v) = 0"
  by (simp add: Hv_def)

lemma Im1_Hv [simp]: "Im1(Hv v) = v$1"
  by (simp add: Hv_def)

lemma Im2_Hv [simp]: "Im2(Hv v) = v$2"
  by (simp add: Hv_def)

lemma Im3_Hv [simp]: "Im3(Hv v) = v$3"
  by (simp add: Hv_def)

lemma hv_vec: "Hv(vec r) = Quat 0 r r r"
  by (simp add: Hv_def)

lemma hv_eq_zero [simp]: "Hv v = 0 \<longleftrightarrow> v = 0"
  by (simp add: quat_eq_iff vec_eq_iff) (metis exhaust_3)

lemma hv_zero [simp]: "Hv 0 = 0"
  by simp

lemma hv_vector [simp]: "Hv(vector[x,y,z]) = Quat 0 x y z"
  by (simp add: Hv_def)

lemma hv_basis: "Hv(axis 1 1) = \<i>" "Hv(axis 2 1) = \<j>" "Hv(axis 3 1) = \<k>"
  by (auto simp: Hv_def axis_def quat_ii.code quat_jj.code quat_kk.code)

lemma hv_add [simp]: "Hv(x + y) = Hv x + Hv y"
  by (simp add: Hv_def quat_eq_iff)

lemma hv_minus [simp]: "Hv(-x) = -Hv x"
  by (simp add: Hv_def quat_eq_iff)

lemma hv_diff [simp]: "Hv(x - y) = Hv x - Hv y"
  by (simp add: Hv_def quat_eq_iff)

lemma hv_cmult [simp]: "Hv(a *\<^sub>R x) = of_real a * Hv x"
  by (simp add: Hv_def quat_eq_iff)

lemma hv_sum [simp]: "Hv (sum f S) = (\<Sum>x\<in>S. Hv (f x))"
  by (induct S rule: infinite_finite_induct) auto

lemma hv_inj: "Hv x = Hv y \<longleftrightarrow> x = y"
  by (simp add: Hv_def quat_eq_iff vec_eq_iff) (metis (full_types) exhaust_3)

lemma linear_hv: "linear Hv"
  by unfold_locales (auto simp: of_real_def)

lemma him_hv [simp]: "HIm(Hv x) = x"
  using HIm_def hv_inj quat_eq_iff by fastforce

lemma cnj_hv [simp]: "cnj(Hv v) = -Hv v"
  using Hv_def cnj.code hv_minus by auto

lemma hv_him: "Hv(HIm q) = Quat 0 (Im1 q) (Im2 q) (Im3 q)"
  by (simp add: HIm_def)

lemma hv_him_eq: "Hv(HIm q) = q \<longleftrightarrow> Re q = 0"
  by (simp add: hv_him quat_eq_iff)

lemma dot_hv [simp]: "Hv u \<bullet> Hv v = u \<bullet> v"
  by (simp add: Hv_def inner_quat_def inner_vec_def sum_3)

lemma norm_hv [simp]: "norm (Hv v) = norm v"
  by (simp add: norm_eq)

subsection\<open>Geometric interpretation of the product of imaginary quaternions\<close>

context includes cross3_syntax
begin

lemma mult_hv_eq_cross_dot: "Hv x * Hv y = Hv(x \<times> y) - of_real (x \<bullet> y)"
  by (simp add: quat_eq_iff cross3_simps)

text\<open>Representing orthogonal transformations as conjugation or congruence with a quaternion\<close>

lemma orthogonal_transformation_quat_congruence:
  assumes "norm q = 1"
  shows "orthogonal_transformation (\<lambda>x. HIm(cnj q * Hv x * q))"
proof -
  have nq: "(quat.Re q)\<^sup>2 + (Im1 q)\<^sup>2 + (Im2 q)\<^sup>2 + (Im3 q)\<^sup>2 = 1"
    using assms norm_quat_def by auto
  have "Vector_Spaces.linear (*\<^sub>R) (*\<^sub>R) (\<lambda>x. HIm (cnj q * Hv x * q))"
  proof
    show "\<And>r b. HIm (cnj q * Hv (r *\<^sub>R b) * q) = r *\<^sub>R HIm (cnj q * Hv b * q)"
      by (metis him_mult_left hv_cmult mult_scaleR_left mult_scaleR_right scaleR_conv_of_real)
  qed (simp add: distrib_left distrib_right)
  moreover have "HIm (cnj q * Hv v * q) \<bullet> HIm (cnj q * Hv w * q) = ((quat.Re q)\<^sup>2 + (Im1 q)\<^sup>2 + (Im2 q)\<^sup>2 + (Im3 q)\<^sup>2)\<^sup>2 * (v \<bullet> w)" for v w
    by (simp add: HIm_def inner_vec_def sum_3 power2_eq_square algebra_simps) (*SLOW, like 15s*)
  ultimately show ?thesis
    by (simp add: orthogonal_transformation_def linear_def nq)
qed

lemma orthogonal_transformation_quat_conjugation:
  assumes "q \<noteq> 0"
  shows "orthogonal_transformation (\<lambda>x. HIm(inverse q * Hv x * q))"
proof -
  obtain c p where eq: "q = of_real c * p" and 1: "norm p = 1"
  proof
    show "q = quat_of_real (norm q) * (inverse (of_real (norm q)) * q)"
      by (metis assms mult.assoc mult.left_neutral norm_eq_zero of_real_eq_0_iff right_inverse)
    show "norm (inverse (quat_of_real (norm q)) * q) = 1"
      using assms by (simp add: norm_mult norm_inverse)
  qed
  have "c \<noteq> 0"
    using assms eq by auto
  then have "HIm (cnj p * Hv x * p) = HIm (inverse (quat_of_real c * p) * Hv x * (quat_of_real c * p))" for x
    apply (simp add: inverse_mult mult.assoc flip: quat_inverse_eq_cnj [OF 1] of_real_inverse)
    using quat_of_real_times_commute quat_of_real_times_left_commute quat_of_real_inverse_collapse
    by (simp add: of_real_def)
  then show ?thesis
    using orthogonal_transformation_quat_congruence [OF 1]
    by (simp add: eq)
qed

unbundle no_quaternion_syntax

end

end


theory Natural_Transformations
  imports Main Functors

begin

section \<open>Natural transformation\<close>

locale naturalTransformation =
A: category domain codomain composition nonex +
B: category domain' codomain' composition' nonex' +
F: functorCat domain codomain composition nonex domain' codomain' composition' nonex' F +
G: functorCat  domain codomain composition nonex domain' codomain' composition' nonex' G
for
  domain::"'a\<Rightarrow>'a" ("dom _") and
  codomain::"'a\<Rightarrow>'a" ("cod _") and
  composition::"'a\<Rightarrow>'a\<Rightarrow>'a" (infix "\<cdot>" 110) and
  nonex ::"'a" ("*") and
  domain'::"'b\<Rightarrow>'b" ("dom2 _") and
  codomain'::"'b\<Rightarrow>'b" ("cod2 _") and
  composition'::"'b\<Rightarrow>'b\<Rightarrow>'b" (infix "\<cdot>2" 110) and
  nonex' ::"'b" ("*2") and
  F :: "'a \<Rightarrow> 'b"  and
  G :: "'a \<Rightarrow> 'b"  +
fixes
  \<eta> :: "'a \<Rightarrow> 'b"
assumes
  ntExists: "(E x) \<longrightarrow> E(\<eta> x)" and
  nntExists: "\<not>(E x) \<longrightarrow> \<not>(E(\<eta> x))" and
  presDom: "(dom2 (\<eta> x)) \<cong> (dom2 (F x))" and
  presCod: "(cod2 (\<eta> x)) \<cong>  (cod2 (G x))" and
  naturality: "(E(z\<cdot>w)) \<longrightarrow> ((\<eta> z)\<cdot>2(F w)) \<simeq> ((G z)\<cdot>2(\<eta> w))"

begin

lemma True
   nitpick [satisfy, user_axioms, expect=genuine, card i=4-50] oops

lemma ActOnMorph:
  shows "\<eta> x \<cong> G (x)\<cdot>2(\<eta> (dom x))"
  by (metis A.S5 B.Ex_two_ob1 B.Ex_two_ob2 B.S5 F.pres1 G.nexists naturality nntExists presDom)

lemma preserves_comp:
  assumes "E(z\<cdot>w)"
  shows "(\<eta>(z\<cdot>w)) \<^bold>\<ge> ((G z)\<cdot>2(\<eta> w))"
  by (smt A.S2 A.S3 A.S4 A.S5 B.S2 B.S3 B.S4 B.S5 F.pres1 G.exists G.pres3 assms naturality)

lemma functor_equals_dom:
  assumes "functorCat domain codomain composition nonex domain' codomain' composition' nonex' \<eta>"
  shows "((F x) \<cong> (\<eta> x))"
  by (smt A.category_axioms B.category_axioms F.nexists assms category.S3 category.S6 functorCat.pres2 naturality nntExists ntExists preserves_comp)

lemma functor_equals_cod:
  assumes "functorCat domain codomain composition nonex domain' codomain' composition' nonex' \<eta>"
  shows "((G x) \<cong> (\<eta> x))"
  by (metis A.S5 B.S3 B.S5 F.pres1 G.nexists assms naturalTransformation.functor_equals_dom naturalTransformation_axioms nntExists ntExists preserves_comp)

lemma equalNT:
  assumes "naturalTransformation domain codomain composition nonex domain' codomain' composition' nonex' F G \<eta>" and
          "naturalTransformation domain codomain composition nonex domain' codomain' composition' nonex' F G \<tau>" and
          "\<^bold>\<forall>x. A.Id x \<longrightarrow> ((\<eta> x) \<^bold>= (\<tau> x))"
  shows "(\<eta> y) \<cong> (\<tau> y)"
  by (smt A.Id_def A.S3 A.S5 A.S6 B.S3 B.S5 F.pres1 assms(2) assms(3) naturalTransformation_axioms naturalTransformation_axioms_def naturalTransformation_def)

end

lemma functors_is_nat_transformation:
  assumes "functorCat domain codomain composition nonex domain' codomain' composition' nonex' F"
  shows "naturalTransformation domain codomain composition nonex domain' codomain' composition' nonex' F F F"
  using assms
  apply unfold_locales
  apply (meson category.S1 functorCat.axioms(1))
  apply (meson category.S2 functorCat.axioms(1))
  apply (meson category.S3 functorCat.axioms(1))
  apply (meson category.S4 functorCat.axioms(1))
  apply (meson category.S5 functorCat.axioms(1))
  apply (meson category.S6 functorCat.axioms(1))
  apply (meson category.S1 functorCat.axioms(1))
  apply (meson category.SN functorCat.axioms(1))
  apply (meson category.S1 functorCat.axioms(2))
  apply (meson category.S2 functorCat.axioms(2))
  apply (meson category.S3 functorCat.axioms(2))
  apply (meson category.S4 functorCat.axioms(2))
  apply (meson category.S5 functorCat.axioms(2))
  apply (meson category.S6 functorCat.axioms(2))
  apply (meson category.SN functorCat.axioms(2))
  apply (simp add: functorCat.exists)
  apply (simp add: functorCat.nexists)
  apply (meson functorCat.pres1)
  apply (meson functorCat.pres2)
  apply (meson functorCat.pres3)
  apply auto[1]
  apply auto[1]
  by (meson functorCat.Pres3Equiv)

sublocale functorCat \<subseteq> naturalTransformation domain codomain composition nonex domain' codomain' composition' nonex' F F F
  by (simp add: functorCat_axioms functors_is_nat_transformation)

section \<open>Natural transformation via identities\<close>

locale naturalTransformationViaIdentities =
A: category domain codomain composition nonex +
B: category domain' codomain' composition' nonex' +
F: functorCat domain codomain composition nonex domain' codomain' composition' nonex' F +
G: functorCat domain codomain composition nonex domain' codomain' composition' nonex' G
for
  domain::"'a\<Rightarrow>'a" ("dom _") and
  codomain::"'a\<Rightarrow>'a" ("cod _") and
  composition::"'a\<Rightarrow>'a\<Rightarrow>'a" (infix "\<cdot>" 110) and
  nonex ::"'a" ("*") and
  domain'::"'b\<Rightarrow>'b" ("dom2 _") and
  codomain'::"'b\<Rightarrow>'b" ("cod2 _") and
  composition'::"'b\<Rightarrow>'b\<Rightarrow>'b" (infix "\<cdot>2" 110) and
  nonex' ::"'b" ("*2") and
  F :: "'a \<Rightarrow> 'b"  and
  G :: "'a \<Rightarrow> 'b"  +
fixes
  \<eta> :: "'a \<Rightarrow> 'b"
assumes
  exists: "((dom a) \<simeq> a) \<longrightarrow> B.from_hom_set (\<eta> a) (F a) (G a)" and
  naturality: "(((G x)\<cdot>2(\<eta>(dom x))) \<cong> (\<eta>(cod x))\<cdot>2(F x))"
begin

definition map :: "'a \<Rightarrow> 'b"
  where "map x = (if (E x)
                 then (\<eta>(cod x))\<cdot>2(F x)
                 else *2)"

lemma map_ide[simp]:
  assumes "(dom a) \<simeq> a"
  shows "map a \<simeq> \<eta> a"
  by (smt A.cod_dom B.category_axioms assms category.S5 category.from_hom_set_def category.morph_hom exists local.map_def)

lemma components_transformation_4:
  shows "(cod2 (map x)) \<cong>  (cod2 (G x))"
  by (smt A.dom_cod B.S2 B.S3 B.S6 B.SN B.cod_of_comp B.from_hom_set_def F.pres2 G.nntExists G.ntExists G.pres2 exists local.map_def)

lemma components_transformation_5:
  shows "(E(z\<cdot>w)) \<longrightarrow> ((map z)\<cdot>2(F w)) \<simeq> ((G z)\<cdot>2(map w))"
  by (smt A.Ex_two_ob1 A.Ex_two_ob2 A.S3 B.ExDomCod(1) B.S2 B.S3 B.S4 G.ntExists G.pres1 G.pres2 components_transformation_4 local.map_def naturality)

lemma components_transformation_3:
  shows "(dom2 (map x)) \<cong> (dom2 (F x))"
  by (smt A.double_dom B.ExDomCod(2) B.SN B.category_axioms B.dom_of_comp B.from_hom_set_def F.nntExists F.pres1 G.pres1 category.S3 exists local.map_def naturality)

lemma def_nat_transformation:
  shows "naturalTransformation domain codomain composition nonex domain' codomain' composition' nonex' F G map"
  using map_def naturality
  apply (unfold_locales)
  apply (smt A.Ex_from_hom_set A.double_dom A.from_hom_set_def B.S3 B.category_axioms G.functorCat_axioms category.from_hom_set_def exists functorCat.pres1)
  apply (simp add: B.SN)
  using components_transformation_3 apply blast
  using components_transformation_4 apply blast
  using components_transformation_5 by blast
end

sublocale naturalTransformationViaIdentities \<subseteq> naturalTransformation domain codomain composition nonex domain' codomain' composition' nonex' F G map
  by (simp add: def_nat_transformation)

section \<open>Natural isomorphism\<close>

locale naturalIsomorphism =
A: category domain codomain composition nonex +
B: category domain' codomain' composition' nonex' +
F: functorCat domain codomain composition nonex domain' codomain' composition' nonex' F +
G: functorCat  domain codomain composition nonex domain' codomain' composition' nonex' G +
\<eta>: naturalTransformation domain codomain composition nonex domain' codomain' composition' nonex' F G \<eta>
for
  domain :: "'a \<Rightarrow> 'a" ("dom _" [108] 109) and
  codomain :: "'a\<Rightarrow>'a" ("cod _" [110] 111) and
  composition :: "'a\<Rightarrow>'a\<Rightarrow>'a" (infix "\<cdot>" 110) and
  nonex :: "'a" ("*") and
  domain' :: "'b \<Rightarrow> 'b" ("dom2 _" [108] 109) and
  codomain' :: "'b\<Rightarrow>'b" ("cod2 _" [110] 111) and
  composition' :: "'b\<Rightarrow>'b\<Rightarrow>'b" (infix "\<cdot>2" 110) and
  nonex' :: "'b" ("*2") and
  F :: "'a \<Rightarrow> 'b" and
  G :: "'a \<Rightarrow> 'b" and
  \<eta> :: "'a \<Rightarrow> 'b" +
assumes
  comp_iso: "A.IdEx x \<longrightarrow> (B.Iso (\<eta> x))"

begin

lemma True
  nitpick [satisfy, user_axioms, expect=genuine] oops

lemma pres_iso:
  assumes "A.Iso x"
  shows "B.Iso (\<eta> x)"
  by (smt A.IsoE A.double_dom A.inv_ex2 B.IsoComp F.functorCat_axioms G.iso_pres \<eta>.ActOnMorph \<eta>.ntExists assms category.S3 functorCat.axioms(1) local.comp_iso)

end

section \<open>Inverse natural transformation\<close>

locale inverse_natural_tr =
A: category domain codomain composition nonex +
B: category domain' codomain' composition' nonex' +
F: functorCat domain codomain composition nonex domain' codomain' composition' nonex' F +
G: functorCat  domain codomain composition nonex domain' codomain' composition' nonex' G +
\<eta>: naturalIsomorphism domain codomain composition nonex domain' codomain' composition' nonex' F G \<eta>
for
  domain :: "'a \<Rightarrow> 'a" ("dom _" [108] 109) and
  codomain :: "'a\<Rightarrow>'a" ("cod _" [110] 111) and
  composition :: "'a\<Rightarrow>'a\<Rightarrow>'a" (infix "\<cdot>" 110) and
  nonex :: "'a" ("*") and
  domain' :: "'b \<Rightarrow> 'b" ("dom2 _" [108] 109) and
  codomain' :: "'b\<Rightarrow>'b" ("cod2 _" [110] 111) and
  composition' :: "'b\<Rightarrow>'b\<Rightarrow>'b" (infix "\<cdot>2" 110) and
  nonex' :: "'b" ("*2") and
  F :: "'a \<Rightarrow> 'b" and
  G :: "'a \<Rightarrow> 'b" and
  \<eta> :: "'a \<Rightarrow> 'b"

begin

lemma True
  nitpick [satisfy, user_axioms, expect=genuine] oops

lemma int1:
  shows "((dom a) \<simeq> a) \<Longrightarrow> B.from_hom_set (B.inv (\<eta> a)) (G a) (F a)"
proof -
  assume a1: "((dom a) \<simeq> a)"
  have a2: "(B.Iso (\<eta> a))"
    using \<eta>.comp_iso a1 by blast
  have a3: "E(B.inv (\<eta> a))"
    using B.Ex_two_ob1 B.inv_ex a2 by blast
  have a4: "B.from_hom_set (\<eta> a) (F a) (G a)"
    by (metis A.cod_dom B.from_hom_set_def F.ntExists F.pres1 G.ntExists G.pres2 \<eta>.\<eta>.presCod \<eta>.\<eta>.presDom a1)
  have a5: "E (F a)"
    using F.ntExists a1 by blast
  have a6: "E (G a)"
    using G.ntExists a1 by blast
  have a7: "(dom2 (B.inv (\<eta> a))) = (G a)"
    by (metis B.S3 B.from_hom_set_def B.inv_ex a2 a4)
  have a8: "cod a \<simeq> a"
    using A.cod_dom a1 by fastforce
  have a9: "E(cod a) \<and> E a \<and> (cod a \<^bold>= a)"
    using a8 by blast
  have a10: "(cod2 (B.inv (\<eta> a))) = (F a)"
    using B.Iso_inv_cod a2 a4 by blast
  have a11: "B.from_hom_set (B.inv (\<eta> a)) (G a) (F a)"
    by (simp add: B.Iso_inv_hom a2 a4)
  show ?thesis
    using a11 by blast
qed

lemma int2:
  shows "((dom a) \<simeq> a) \<^bold>\<rightarrow> B.from_hom_set (B.inv (\<eta> a)) (G a) (F a)"
  using int1 by blast

lemma int3:
  assumes "(((G x)\<cdot>2(\<eta>(dom x))) \<cong> (\<eta>(cod x))\<cdot>2(F x))"
  shows "(E x) \<longrightarrow> (((G x)\<cdot>2(\<eta>(dom x))) \<cong> (\<eta>(cod x))\<cdot>2(F x))"
  using assms by auto

lemma int4:
  assumes "(E x) \<longrightarrow> (((G x)\<cdot>2(\<eta>(dom x))) \<cong> (\<eta>(cod x))\<cdot>2(F x))"
  shows "(((G x)\<cdot>2(\<eta>(dom x))) \<cong> (\<eta>(cod x))\<cdot>2(F x))"
  using B.Ex_two_ob1 B.Ex_two_ob2 F.reflects_morp G.reflects_morp assms by blast

interpretation \<eta>': naturalTransformationViaIdentities domain codomain composition nonex domain' codomain' composition' nonex' G F "\<lambda>a. B.inv (\<eta> a)"
  apply (unfold_locales, simp_all)
  apply (simp add: int2)
  using int4 int3
  by (smt A.category_axioms A.dom_cod B.Ex_from_hom_set B.Id_cod B.Id_def B.Iso_def B.S5 B.S6 B.category_axioms B.cod_of_comp B.commSquare1 B.dom_of_comp B.from_hom_set_def F.functorCat_axioms F.reflects_morp G.pres2 \<eta>.\<eta>.naturality \<eta>.\<eta>.ntExists \<eta>.\<eta>.presCod \<eta>.\<eta>.presDom \<eta>.comp_iso category.S3 category.arrow_and_inv1 category.cod_dom functorCat.pres1 functorCat.pres2 int1)

definition map
  where "map = \<eta>'.map"

lemma identity_under_map[simp]:
  assumes "dom a \<simeq> a"
  shows "map a = B.inv (\<eta> a)"
  using \<eta>'.map_ide assms local.map_def by auto

lemma arrows_under_map[simp]:
  assumes "E (x::'a)"
  shows "map x = (B.inv (\<eta> (cod x)))\<cdot>2(G x)"
  by (simp add: \<eta>'.map_def assms local.map_def)

lemma inverse_components:
  assumes "dom a \<simeq> a"
  shows "B.inv_arrows (\<eta> a) (map a)"
  by (smt A.cod_dom B.Id_def B.Iso_hom_set B.Iso_inv_cod B.S3 B.S4 B.S5 B.category_axioms \<eta>'.naturality \<eta>.\<eta>.naturalTransformation_axioms \<eta>.\<eta>.ntExists \<eta>.naturalIsomorphism_axioms assms category.Iso_def category.arrow_and_inv1 category.inv_arrows_def identity_under_map naturalIsomorphism.comp_iso naturalTransformation.presCod)

lemma inverse_is_nat_transformation:
  shows "naturalIsomorphism domain codomain composition nonex domain' codomain' composition' nonex' G F map"
   by (smt A.S5 A.category_axioms B.Id3 B.Id_ex B.Iso_hom_set B.Iso_inv_cod B.S4 B.arrow_and_inv1 B.category_axioms B.cod_of_comp F.functorCat_axioms G.functorCat_axioms \<eta>'.map_def \<eta>'.naturalTransformation_axioms \<eta>.\<eta>.naturalTransformation_axioms \<eta>.\<eta>.naturality \<eta>.naturalIsomorphism_axioms category.Iso_def category.S3 functorCat.pres1 local.map_def naturalIsomorphism.comp_iso naturalIsomorphism.intro naturalIsomorphism_axioms.intro naturalTransformation.ntExists naturalTransformation.preserves_comp)

end

sublocale inverse_natural_tr \<subseteq> naturalTransformation domain codomain composition nonex domain' codomain' composition' nonex' G F map
  using inverse_is_nat_transformation naturalIsomorphism_def
  by (simp add: naturalIsomorphism_def)

sublocale inverse_natural_tr \<subseteq> naturalIsomorphism domain codomain composition nonex domain' codomain' composition' nonex' G F map
  by (simp add: inverse_is_nat_transformation)

sublocale functorCat \<subseteq> naturalIsomorphism domain codomain composition nonex domain' codomain' composition' nonex' F F F
  apply unfold_locales
  using pres_identity B.ide_is_iso
  by (simp add: A.Id_def ntExists)

lemma nat_transform_impl_inverse:
  assumes "naturalIsomorphism domain codomain composition nonex domain' codomain' composition' nonex' F G \<eta>"
  shows "inverse_natural_tr domain codomain composition nonex domain' codomain' composition' nonex' F G \<eta>"
  using assms inverse_natural_tr_def naturalIsomorphism_def
  by (simp add: inverse_natural_tr_def naturalIsomorphism_def)

section \<open>Binary functor defines natural transformations\<close>

context biFunctor

begin

lemma fix_arr1n:
  assumes "E x1"
  shows "naturalTransformation domain' codomain' composition' nonex' domain'' codomain'' composition'' nonex'' (\<lambda>x2. BF (domain x1, x2)) (\<lambda>x2. BF (codomain x1, x2)) (\<lambda>x2. BF (x1,x2))"
  using assms
  apply unfold_locales
  using A.from_hom_set_def AxB.Ex ntExists
  using A.Ex_from_hom_set apply blast
  using AxB.Ex nntExists apply blast
  apply (metis A.double_dom AxB.Ex fst_conv nntExists pres1 snd_conv)
  apply (metis A.S3 A.S5 fst_conv pres2 snd_conv)
  using A.S5 A.double_dom A.from_hom_set_def fst_conv pres3 snd_conv
  apply (metis AxB.Ex nntExists)
  using A.from_hom_set_def AxB.Ex ntExists
  apply (meson A.Ex_from_hom_set)
  using AxB.Ex nntExists apply blast
  apply (metis A.S3 A.S6 fst_conv pres1 snd_conv)
  apply (metis A.double_cod AxB.Ex fst_conv nntExists pres2 snd_conv)
  apply (metis A.S6 A.double_cod AxB.Ex fst_conv nntExists pres3 snd_conv)
  using A.morph_hom AxB.Ex ntExists apply blast
  using AxB.Ex nntExists apply blast
  apply (metis (no_types, lifting) A.Ex_from_hom_set A.double_dom A.from_hom_set_def fst_conv pres1 snd_conv)
  apply (smt A.Ex_from_hom_set A.double_cod A.from_hom_set_def fst_conv pres2 snd_conv)
  by (metis A.S5 A.S6 AxB.Ex fst_conv ntExists pres3 snd_conv)

lemma fix_arr2:
  assumes "E x2"
  shows "naturalTransformation domain codomain composition nonex domain'' codomain'' composition'' nonex'' (\<lambda>x1. BF (x1, dom2 x2)) (\<lambda>x1. BF (x1, cod2 x2)) (\<lambda>x1. BF (x1,x2))"
  using assms
  apply unfold_locales
  using A.from_hom_set_def AxB.Ex ntExists
  using B.Ex_from_hom_set
  apply (meson B.from_hom_set_def)
  using AxB.Ex nntExists apply blast
  apply (metis AxB.Ex B.double_dom fst_conv nntExists pres1 snd_conv)
  apply (metis B.S3 B.S5 fst_conv pres2 snd_conv)
  using A.S5 A.double_dom A.from_hom_set_def fst_conv pres3 snd_conv
  using A.from_hom_set_def AxB.Ex ntExists
  using AxB.Ex nntExists
  apply (metis B.S6 B.cod_dom)
  using AxB.Ex B.Ex_from_hom_set B.from_hom_set_def ntExists apply blast
  apply (metis AxB.Ex nntExists)
  apply (metis AxB.Ex B.dom_cod fst_conv nntExists pres1 snd_conv)
  using A.morph_hom AxB.Ex ntExists
  apply (metis B.double_cod fst_conv nntExists pres2 snd_conv)
  apply (metis AxB.Ex B.S5 B.dom_cod fst_conv pres3 reflects_morp snd_conv)
  using AxB.Ex ntExists apply blast
  using AxB.Ex reflects_morp apply blast
  apply (metis AxB.Ex B.double_dom fst_conv nntExists pres1 snd_conv)
  apply (metis B.S3 B.S6 B.double_cod fst_conv pres2 snd_conv)
  by (smt AxB.Ex B.S5 B.category_axioms category.S6 fst_conv ntExists pres3 snd_conv)

lemma fix_arr1:
  assumes "E x1"
  shows "naturalTransformationViaIdentities domain' codomain' composition' nonex' domain'' codomain'' composition'' nonex'' (\<lambda>x2. BF (domain x1, x2)) (\<lambda>x2. BF (codomain x1, x2)) (\<lambda>x2. BF (x1,x2))"
  using assms
  apply unfold_locales
  apply (metis A.S3 A.S5 AxB.Ex ntExists)
  using AxB.Ex reflects_morp apply blast
  apply (metis A.double_dom AxB.Ex fst_conv nntExists pres1 snd_conv)
  apply (metis A.S3 A.S5 fst_conv pres2 snd_conv)
  apply (metis A.S5 A.double_dom AxB.Ex fst_conv preserves_comp reflects_morp snd_conv)
  apply (metis A.Ex_two_ob1 A.S6 AxB.Ex ntExists)
  using AxB.Ex reflects_morp apply blast
  apply (metis A.S3 A.S6 fst_conv pres1 snd_conv)
  apply (metis A.Ex_two_ob1 A.S6 A.double_cod fst_conv pres2 snd_conv)
  apply (metis A.S6 A.double_cod AxB.Ex Pres3Equiv fst_conv nntExists snd_conv)
  apply (smt A.S5 ActOnMorph AxB.Ex C.ExDomCod(1) C.from_hom_set_def biFunctor_axioms biFunctor_def category.S3 category.cod_dom fst_conv ntExists pres2 snd_conv)
  by (smt A.S5 AxB.Ex AxB.prod_S6 B.cod_dom C.Ex_two_ob2 C.S5 Pres3Equiv biFunctor_axioms biFunctor_def category.S3 fst_conv nntExists pres1 snd_conv)

lemma fix_arr2n:
  assumes "E x2"
  shows "naturalTransformationViaIdentities domain codomain composition nonex domain'' codomain'' composition'' nonex'' (\<lambda>x1. BF (x1, dom2 x2)) (\<lambda>x1. BF (x1, cod2 x2)) (\<lambda>x1. BF (x1,x2))"
  using assms
  apply unfold_locales
  apply (metis AxB.Ex B.S3 B.S5 ntExists)
  using AxB.Ex reflects_morp apply blast
  apply (metis B.double_dom AxB.Ex fst_conv nntExists pres1 snd_conv)
  apply (metis B.S3 B.S5 fst_conv pres2 snd_conv)
  apply (metis B.S5 B.double_dom AxB.Ex fst_conv preserves_comp reflects_morp snd_conv)
  apply (metis B.Ex_two_ob1 B.S6 AxB.Ex ntExists)
  using AxB.Ex reflects_morp apply blast
  apply (metis B.S3 B.S6 fst_conv pres1 snd_conv)
  apply (metis B.Ex_two_ob1 B.S6 B.double_cod fst_conv pres2 snd_conv)
  apply (metis B.S6 B.double_cod AxB.Ex Pres3Equiv fst_conv nntExists snd_conv)
  apply (smt B.S5 ActOnMorph AxB.Ex C.ExDomCod(1) C.from_hom_set_def biFunctor_axioms biFunctor_def category.S3 category.cod_dom fst_conv ntExists pres2 snd_conv)
  by (smt B.S5 AxB.Ex AxB.prod_S6 A.cod_dom C.Ex_two_ob2 C.S5 Pres3Equiv biFunctor_axioms biFunctor_def category.S3 fst_conv nntExists pres1 snd_conv)

end

end


theory T181
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z)))
"
nitpick[card nat=7,timeout=86400]
oops
end


theory T91
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory equational_clausal_logic

(* N. Peltier - http://membres-lig.imag.fr/peltier/ *)

imports Main terms "HOL-Library.Multiset"

begin

section \<open>Equational Clausal Logic\<close>

text \<open>The syntax and semantics of clausal equational logic are defined as usual.
Interpretations are congruences on binary trees.\<close>

subsection \<open>Syntax\<close>

text \<open>We first define the syntax of equational clauses.\<close>

datatype 'a equation = Eq "'a trm" "'a trm"

fun lhs
  where "lhs (Comb t1 t2) = t1" |
     "lhs (Var x) = (Var x)" |
     "lhs (Const x) = (Const x)"

fun rhs
  where "rhs (Comb t1 t2) = t2" |
     "rhs (Var x) = (Var x)" |
     "rhs (Const x) = (Const x)"

datatype 'a literal = Pos "'a equation" | Neg "'a equation"

fun atom :: "'a literal \<Rightarrow> 'a equation"
  where
    "(atom (Pos x)) = x" |
    "(atom (Neg x)) = x"

datatype sign = pos | neg

fun get_sign :: "'a literal \<Rightarrow> sign"
  where
    "(get_sign (Pos x)) = pos" |
    "(get_sign (Neg x)) = neg"

fun positive_literal :: "'a literal \<Rightarrow> bool"
  where
    "(positive_literal (Pos x)) = True" |
    "(positive_literal (Neg x)) = False"

fun negative_literal :: "'a literal \<Rightarrow> bool"
  where
    "(negative_literal (Pos x)) = False" |
    "(negative_literal (Neg x)) = True"

fun mk_lit :: "sign \<Rightarrow> 'a equation \<Rightarrow> 'a literal"
  where
    "(mk_lit pos x) = (Pos x)" |
    "(mk_lit neg x) = (Neg x)"

definition decompose_equation
  where "decompose_equation e t s = (e = (Eq t s) \<or> (e = (Eq s t)))"

definition decompose_literal
  where "decompose_literal L t s p =
            (\<exists>e. ((p = pos \<and> (L = (Pos e)) \<and> decompose_equation e t s)
            \<or> (p = neg \<and> (L = (Neg e)) \<and> decompose_equation e t s)))"

fun subterms_of_eq
  where "subterms_of_eq (Eq t s) = (subterms_of t \<union> subterms_of s)"

fun vars_of_eq
  where "vars_of_eq (Eq t s) = (vars_of t \<union> vars_of s)"

lemma decompose_equation_vars:
  assumes "decompose_equation e t s"
  shows "vars_of t \<subseteq> vars_of_eq e"
by (metis assms decompose_equation_def sup.cobounded1 sup_commute vars_of_eq.simps)

fun subterms_of_lit
  where
    "subterms_of_lit (Pos e) = (subterms_of_eq e)" |
    "subterms_of_lit (Neg e) = (subterms_of_eq e)"

fun vars_of_lit
  where
    "vars_of_lit (Pos e) = (vars_of_eq e)" |
    "vars_of_lit (Neg e) = (vars_of_eq e)"

fun vars_of_cl
  where "vars_of_cl C = { x. \<exists>L. x \<in> (vars_of_lit L) \<and> L \<in> C }"

fun subterms_of_cl
  where "subterms_of_cl C = { x. \<exists>L. x \<in> (subterms_of_lit L) \<and> L \<in> C }"

text \<open>Note that clauses are defined as sets and not as multisets
(identical literals are always merged).\<close>

type_synonym 'a clause = "'a literal set"

fun ground_clause :: "'a clause \<Rightarrow> bool"
where
  "(ground_clause C) = ((vars_of_cl C) = {})"

fun subst_equation :: "'a equation \<Rightarrow> 'a subst \<Rightarrow> 'a equation"
where
  "(subst_equation (Eq u v) s)
    = (Eq (subst u s) (subst v s))"

fun subst_lit :: "'a literal \<Rightarrow> 'a subst \<Rightarrow> 'a literal"
where
  "(subst_lit (Pos e) s)
    = (Pos (subst_equation e s))" |
  "(subst_lit (Neg e) s)
    = (Neg (subst_equation e s))"

fun subst_cl :: "'a clause \<Rightarrow> 'a subst \<Rightarrow> 'a clause"
where
  "(subst_cl C s) = { L. (\<exists>L'. (L' \<in> C) \<and> (L = (subst_lit L' s))) }"

text \<open>We establish some properties of the functions returning the set of variables occurring in
an object.\<close>

lemma decompose_literal_vars:
  assumes "decompose_literal L t s p"
  shows "vars_of t \<subseteq> vars_of_lit L"
by (metis assms decompose_equation_vars decompose_literal_def vars_of_lit.simps(1) vars_of_lit.simps(2))

lemma vars_of_cl_lem:
  assumes "L \<in> C"
  shows "vars_of_lit L \<subseteq> vars_of_cl C"
using assms by auto

lemma set_of_variables_is_finite_eq:
  shows "finite (vars_of_eq e)"
proof -
  obtain t and s where "e = Eq t s" using equation.exhaust by auto
  then have "vars_of_eq e = (vars_of t) \<union> (vars_of s)" by auto
  from this show ?thesis by auto
qed

lemma set_of_variables_is_finite_lit:
  shows "finite (vars_of_lit l)"
proof -
  obtain e where "l = Pos e \<or> l = Neg e" using literal.exhaust by auto
  then have "vars_of_lit l = (vars_of_eq e)" by auto
  from this show ?thesis using set_of_variables_is_finite_eq by auto
qed

lemma set_of_variables_is_finite_cl:
  assumes "finite C"
  shows "finite (vars_of_cl C)"
proof -
  let ?S = "{ x. \<exists>l. x = vars_of_lit l \<and> l \<in> C }"
  have "vars_of_cl C = \<Union> ?S" by auto
  from assms have "finite ?S" by auto
  { fix x have "x \<in> ?S \<Longrightarrow> finite x" using set_of_variables_is_finite_lit by auto }
  from this and \<open>finite ?S\<close> have "finite (\<Union> ?S)" using finite_Union by auto
  from this and \<open>vars_of_cl C = \<Union> ?S\<close> show ?thesis by auto
qed

lemma subterm_lit_vars :
  assumes "u \<in> subterms_of_lit L"
  shows "vars_of u \<subseteq> vars_of_lit L"
proof -
  obtain e where def_e: "L = (Pos e) \<or> L = (Neg e)" and "vars_of_lit L = vars_of_eq e"
    by (metis negative_literal.elims(2) negative_literal.elims(3)
      vars_of_lit.simps(1) vars_of_lit.simps(2))
  obtain t and s where def_ts: "e = (Eq t s) \<or> e = (Eq s t)" and "vars_of_eq e = vars_of t \<union> vars_of s"
    by (metis equation.exhaust vars_of_eq.simps)
  from this and \<open>vars_of_lit L = vars_of_eq e\<close> have "vars_of_lit L = vars_of t \<union> vars_of s" by auto
  from assms(1) and def_e def_ts have "u \<in> subterms_of t \<union> subterms_of s" by auto
  from this have "vars_of u \<subseteq> vars_of t \<union> vars_of s"
    by (meson UnE sup.coboundedI1 sup.coboundedI2 vars_subterms_of)
  from this and \<open>vars_of_lit L = vars_of t \<union> vars_of s\<close> show ?thesis by auto
qed

lemma subterm_vars :
  assumes "u \<in> subterms_of_cl C"
  shows "vars_of u \<subseteq> vars_of_cl C"
proof -
  from assms(1) obtain L where "u \<in> subterms_of_lit L" and "L \<in> C" by auto
  from \<open>u \<in> subterms_of_lit L\<close> have "vars_of u \<subseteq> vars_of_lit L" using subterm_lit_vars by auto
  from  \<open>L \<in> C\<close> have "vars_of_lit L \<subseteq> vars_of_cl C" using vars_of_cl.simps by auto
  from this and \<open>vars_of u \<subseteq> vars_of_lit L\<close> show ?thesis by auto
qed

text \<open>We establish some basic properties of substitutions.\<close>

lemma subterm_cl_subst:
  assumes "x \<in> (subterms_of_cl C)"
  shows "(subst x \<sigma>) \<in>  (subterms_of_cl (subst_cl C \<sigma>))"
proof -
  from assms(1) obtain L where "L \<in> C" and "x \<in> subterms_of_lit L" by auto
  from \<open>L \<in> C\<close> have "(subst_lit L \<sigma>) \<in> (subst_cl C \<sigma>)" by auto
  obtain e where "L = (Pos e) \<or> L = (Neg e)" using literal.exhaust by auto
  then show ?thesis
  proof
    assume "L = (Pos e)"
    from this and \<open>x \<in> subterms_of_lit L\<close> have "x \<in> subterms_of_eq e" by auto
    from \<open>L = (Pos e)\<close> have "(subst_lit L \<sigma>) = (Pos (subst_equation e \<sigma>))"
      by auto
    obtain t s where "e = (Eq t s)" using equation.exhaust by auto
    from this have "(subst_equation e \<sigma>) = (Eq (subst t \<sigma>)  (subst s \<sigma>))"
      by auto
    from \<open>x \<in> subterms_of_eq e\<close> and \<open>e = (Eq t s)\<close> have "x \<in> subterms_of t \<or> x \<in> subterms_of s" by auto
    then show ?thesis
    proof
      assume "x \<in> subterms_of t"
      then have "occurs_in x t" by auto
      then obtain p where "subterm t p x" unfolding occurs_in_def by blast
      from this have "subterm (subst t \<sigma>) p (subst x \<sigma>)"
        using substs_preserve_subterms by auto
      from this have "occurs_in (subst x \<sigma>) (subst t \<sigma>)" unfolding occurs_in_def by auto
      then have "(subst x \<sigma>) \<in> subterms_of (subst t \<sigma>)" by auto
      then have "(subst x \<sigma>) \<in> subterms_of_eq (Eq (subst t \<sigma>) (subst s \<sigma>))" by auto
      from this and \<open>L = (Pos e)\<close> and \<open>e = Eq t s\<close>
        have "(subst x \<sigma>) \<in> (subterms_of_lit (subst_lit L \<sigma>))" by auto
      from this and \<open>(subst_lit L \<sigma>) \<in> (subst_cl C \<sigma>)\<close>
        show "(subst x \<sigma>) \<in> subterms_of_cl (subst_cl C \<sigma>)" by auto
    next
      assume "x \<in> subterms_of s"
      then have "occurs_in x s" by auto
      then obtain p where "subterm s p x" unfolding occurs_in_def by blast
      from this have "subterm (subst s \<sigma>) p (subst x \<sigma>)"
        using substs_preserve_subterms by auto
      from this have "occurs_in (subst x \<sigma>) (subst s \<sigma>)" unfolding occurs_in_def by auto
      then have "(subst x \<sigma>) \<in> subterms_of (subst s \<sigma>)" by auto
      then have "(subst x \<sigma>) \<in> subterms_of_eq (Eq (subst t \<sigma>) (subst s \<sigma>))" by auto
      from this and \<open>L = (Pos e)\<close> and \<open>e = Eq t s\<close>
        have "(subst x \<sigma>) \<in> (subterms_of_lit (subst_lit L \<sigma>))" by auto
      from this and \<open>(subst_lit L \<sigma>) \<in> (subst_cl C \<sigma>)\<close>
        show "(subst x \<sigma>) \<in> subterms_of_cl (subst_cl C \<sigma>)" by auto
    qed
    next
    assume "L = (Neg e)"
    from this and \<open>x \<in> subterms_of_lit L\<close> have "x \<in> subterms_of_eq e" by auto
    from \<open>L = (Neg e)\<close> have "(subst_lit L \<sigma>) = (Neg (subst_equation e \<sigma>))"
      by auto
    obtain t s where "e = (Eq t s)" using equation.exhaust by auto
    from this have "(subst_equation e \<sigma>) = (Eq (subst t \<sigma>)  (subst s \<sigma>))"
      by auto
    from \<open>x \<in> subterms_of_eq e\<close> and \<open>e = (Eq t s)\<close> have "x \<in> subterms_of t \<or> x \<in> subterms_of s" by auto
    then show ?thesis
    proof
      assume "x \<in> subterms_of t"
      then have "occurs_in x t" by auto
      then obtain p where "subterm t p x" unfolding occurs_in_def by blast
      from this have "subterm (subst t \<sigma>) p (subst x \<sigma>)"
        using substs_preserve_subterms by auto
      from this have "occurs_in (subst x \<sigma>) (subst t \<sigma>)" unfolding occurs_in_def by auto
      then have "(subst x \<sigma>) \<in> subterms_of (subst t \<sigma>)" by auto
      then have "(subst x \<sigma>) \<in> subterms_of_eq (Eq (subst t \<sigma>) (subst s \<sigma>))" by auto
      from this and \<open>L = (Neg e)\<close> and \<open>e = Eq t s\<close>
        have "(subst x \<sigma>) \<in> (subterms_of_lit (subst_lit L \<sigma>))" by auto
      from this and \<open>(subst_lit L \<sigma>) \<in> (subst_cl C \<sigma>)\<close>
        show "(subst x \<sigma>) \<in> subterms_of_cl (subst_cl C \<sigma>)" by auto
    next
      assume "x \<in> subterms_of s"
      then have "occurs_in x s" by auto
      then obtain p where "subterm s p x" unfolding occurs_in_def by blast
      from this have "subterm (subst s \<sigma>) p (subst x \<sigma>)"
        using substs_preserve_subterms by auto
      from this have "occurs_in (subst x \<sigma>) (subst s \<sigma>)" unfolding occurs_in_def by auto
      then have "(subst x \<sigma>) \<in> subterms_of (subst s \<sigma>)" by auto
      then have "(subst x \<sigma>) \<in> subterms_of_eq (Eq (subst t \<sigma>) (subst s \<sigma>))" by auto
      from this and \<open>L = (Neg e)\<close> and \<open>e = Eq t s\<close>
        have "(subst x \<sigma>) \<in> (subterms_of_lit (subst_lit L \<sigma>))" by auto
      from this and \<open>(subst_lit L \<sigma>) \<in> (subst_cl C \<sigma>)\<close>
        show "(subst x \<sigma>) \<in> subterms_of_cl (subst_cl C \<sigma>)" by auto
    qed
  qed
qed

lemma ground_substs_yield_ground_clause:
  assumes "ground_on (vars_of_cl C) \<sigma>"
  shows "ground_clause (subst_cl C \<sigma>)"
proof (rule ccontr)
    let ?D = "(subst_cl C \<sigma>)"
    let ?V = "(vars_of_cl C)"
    assume "\<not>(ground_clause ?D)"
    then obtain x where "x \<in> (vars_of_cl ?D)" by auto
    then obtain l where "l \<in> C" and "x \<in> (vars_of_lit (subst_lit l  \<sigma>))" by auto
    from \<open>l \<in> C\<close> have "vars_of_lit l \<subseteq> vars_of_cl C" by auto
    obtain e  where "l = Pos e \<or> l = Neg e" using literal.exhaust by auto
    then have "vars_of_lit l = vars_of_eq e" by auto
    let ?l' = "(subst_lit l \<sigma>)"
    let ?e' = "(subst_equation e \<sigma>)"
    obtain t and s where "e = Eq t s" using equation.exhaust by auto
    then have "vars_of_eq e = vars_of t \<union> vars_of s" by auto
    let ?t' = "(subst t \<sigma>)"
    let ?s' = "(subst s \<sigma>)"
    from \<open>e = Eq t s\<close> have "?e' = (Eq ?t' ?s')" by auto
    from \<open>l = Pos e \<or> l = Neg e\<close> have "?l' = Pos ?e' \<or> ?l' = Neg ?e'" by auto
    from \<open>l \<in> C\<close> have "?l' \<in> ?D" by auto
    from \<open>?l' = Pos ?e' \<or> ?l' = Neg ?e'\<close> and \<open>x \<in> (vars_of_lit ?l')\<close>
      have "x \<in> (vars_of_eq ?e')" by auto
    from this and \<open>?e' = (Eq ?t' ?s')\<close> have "x \<in> (vars_of ?t' \<union> vars_of ?s')" by auto
    then have i:"\<not>(ground_term ?t') \<or> \<not>(ground_term ?s')" unfolding ground_term_def by auto
    from \<open>vars_of_eq e = vars_of t \<union> vars_of s\<close> and \<open>vars_of_lit l = vars_of_eq e\<close> and
      \<open>vars_of_lit l \<subseteq> ?V\<close> have "vars_of t \<subseteq> ?V" and "vars_of s \<subseteq> ?V" by auto
    from \<open>vars_of t  \<subseteq> ?V\<close> and \<open>ground_on ?V \<sigma>\<close> have  "ground_on (vars_of t) \<sigma>"
      unfolding ground_on_def by auto
    then have ii:"ground_term ?t'" using ground_instance by auto
    from \<open>vars_of s  \<subseteq> ?V\<close> and \<open>ground_on ?V \<sigma>\<close> have  "ground_on (vars_of s) \<sigma>"
      unfolding ground_on_def by auto
    then have iii:"ground_term ?s'" using ground_instance by auto
    from i and ii and iii show False by auto
qed

lemma ground_clauses_and_ground_substs:
  assumes "ground_clause (subst_cl C \<sigma>)"
  shows "ground_on (vars_of_cl C) \<sigma>"
proof (rule ccontr)
  assume "\<not>ground_on (vars_of_cl C) \<sigma>"
  from this obtain x where "x \<in> vars_of_cl C" and "\<not> ground_term (subst (Var x) \<sigma>)"
    unfolding ground_on_def by auto
  from \<open>\<not> ground_term (subst (Var x) \<sigma>)\<close> obtain y where
    "y \<in> vars_of (subst (Var x) \<sigma>)" unfolding ground_term_def by auto
  from \<open>x \<in> vars_of_cl C\<close> obtain L where "L \<in> C" and "x \<in> vars_of_lit L" by auto
  from \<open>x \<in> vars_of_lit L\<close> obtain e where "L = Pos e \<or> L = Neg e" and "x \<in> vars_of_eq e"
    by (metis vars_of_lit.elims)
  from \<open>x \<in> vars_of_eq e\<close> obtain t s where "e = (Eq t s)" and "x \<in> vars_of t \<union> vars_of s"
    by (metis vars_of_eq.elims)
  from this have "x \<in> vars_of t \<or> x \<in> vars_of s" by auto
  then have "y \<in> vars_of_eq (subst_equation e \<sigma>)"
  proof
    assume "x \<in> vars_of t"
    have i: "vars_of (subst t \<sigma>) = \<Union>{V. \<exists>x. x \<in> vars_of t \<and> V = vars_of (subst (Var x) \<sigma>) }"
      using vars_of_instances [of t \<sigma>] by meson
    from \<open>x \<in> vars_of t\<close>  i
      have "vars_of (subst (Var x) \<sigma>) \<subseteq> vars_of (subst t \<sigma>)"
      by auto
    from this and \<open>y \<in> vars_of (subst (Var x) \<sigma>)\<close> \<open>e = (Eq t s)\<close> show ?thesis by auto
  next
    assume "x \<in> vars_of s"
    have i: "vars_of (subst s \<sigma>) = \<Union>{V. \<exists>x. x \<in> vars_of s \<and> V = vars_of (subst (Var x) \<sigma>) }"
      using vars_of_instances [of s \<sigma>] by meson
    from \<open>x \<in> vars_of s\<close> i
      have "vars_of (subst (Var x) \<sigma>) \<subseteq> vars_of (subst s \<sigma>)"
      by auto
    from this and \<open>y \<in> vars_of (subst (Var x) \<sigma>)\<close> \<open>e = (Eq t s)\<close> show ?thesis by auto
  qed
  from this and \<open>L = Pos e \<or> L = Neg e\<close> have "y \<in> vars_of_lit (subst_lit L \<sigma>)"
    by auto
  from this and \<open>L \<in> C\<close> have "y \<in> vars_of_cl (subst_cl C \<sigma>)" by auto
  from this and assms(1) show False by auto
qed

lemma ground_instance_exists:
  assumes "finite C"
  shows "\<exists>\<sigma>. (ground_clause (subst_cl C \<sigma>))"
proof -
  let ?V = "(vars_of_cl C)"
  from assms have "finite ?V" using set_of_variables_is_finite_cl by auto
  from this obtain \<sigma> where "ground_on ?V \<sigma>"
    using ground_subst_exists by blast
  let ?D = "(subst_cl C \<sigma>)"
  from \<open>ground_on ?V \<sigma>\<close> have "(ground_clause ?D)" using ground_substs_yield_ground_clause [of C \<sigma>] by auto
  then show ?thesis by auto
qed

lemma composition_of_substs :
  shows "(subst (subst t  \<sigma>) \<eta>)
    = (subst t (comp \<sigma> \<eta>))"
by simp

lemma composition_of_substs_eq :
  shows "(subst_equation (subst_equation e \<sigma>) \<eta>)
    = (subst_equation e (comp \<sigma> \<eta>))"
by (metis subst_equation.simps composition_of_substs vars_of_eq.elims)

lemma composition_of_substs_lit :
  shows "(subst_lit (subst_lit l \<sigma>) \<eta>)
    = (subst_lit l (comp \<sigma> \<eta>))"
by (metis subst_lit.simps(1) subst_lit.simps(2)
    composition_of_substs_eq positive_literal.cases)

lemma composition_of_substs_cl :
  shows "(subst_cl (subst_cl C \<sigma>) \<eta>)
    = (subst_cl C (comp \<sigma> \<eta>))"
proof -
  let ?f = "(\<lambda>x. (subst_lit (subst_lit x  \<sigma>) \<eta>))"
  let ?f' = "(\<lambda>x. (subst_lit x (comp \<sigma> \<eta>)))"
  have "\<forall>l. (?f l) = (?f' l)" using composition_of_substs_lit by auto
  then show ?thesis by auto
qed

lemma substs_preserve_ground_lit :
  assumes "ground_clause C"
  assumes "y \<in> C"
  shows "subst_lit y \<sigma> = y"
proof -
    obtain t and s where "y = Pos (Eq t s) \<or> y = Neg (Eq t s)"
      by (metis subst_equation.elims get_sign.elims)
    from this have "vars_of t \<subseteq> vars_of_lit y" by auto
    from this and \<open>y \<in> C\<close> have "vars_of t \<subseteq> vars_of_cl C" by auto
    from this and assms(1) have "ground_term t" unfolding ground_term_def by auto
    then have "subst t \<sigma> = t" using substs_preserve_ground_terms by auto
    from \<open>y = Pos (Eq t s) \<or> y = Neg (Eq t s)\<close> have "vars_of s \<subseteq> vars_of_lit y" by auto
    from this and \<open>y \<in> C\<close> have "vars_of s \<subseteq> vars_of_cl C" by auto
    from this and assms(1) have "ground_term s" unfolding ground_term_def by auto
    then have "subst s \<sigma> = s" using substs_preserve_ground_terms by auto
    from \<open>subst s \<sigma> = s\<close> and \<open>subst t \<sigma> = t\<close> and \<open>y = Pos (Eq t s) \<or> y = Neg (Eq t s)\<close>
    show "subst_lit y \<sigma> = y" by auto
qed

lemma substs_preserve_ground_clause :
  assumes "ground_clause C"
  shows "subst_cl C \<sigma> = C"
proof
  show "subst_cl C \<sigma> \<subseteq> C"
  proof
    fix x assume "x \<in> subst_cl C \<sigma>"
    then obtain y where "y \<in> C" and "x = subst_lit y \<sigma>" by auto
    from assms(1) and \<open>y \<in> C\<close> and \<open>x = subst_lit y \<sigma>\<close>
      have "x = y" using substs_preserve_ground_lit by auto
    from this and \<open>y \<in> C\<close> show "x \<in> C" by auto
  qed
next
  show "C \<subseteq> subst_cl C \<sigma>"
  proof
    fix x assume "x \<in> C"
    then have "subst_lit x \<sigma> \<in> subst_cl C \<sigma>" by auto
    from assms(1) and \<open>x \<in> C\<close> have "x = subst_lit x \<sigma>"
      using substs_preserve_ground_lit [of C x] by auto
    from this and \<open>x \<in> C\<close> show "x \<in> subst_cl C \<sigma>" by auto
  qed
qed

lemma substs_preserve_finiteness :
  assumes "finite C"
  shows "finite (subst_cl C \<sigma>)"
proof -
  from assms(1) show ?thesis using Finite_Set.finite_imageI by auto
qed

text \<open>We prove that two equal substitutions yield the same objects.\<close>

lemma subst_eq_eq :
  assumes "subst_eq \<sigma> \<eta>"
  shows "subst_equation e \<sigma> = subst_equation e \<eta>"
proof -
  obtain t and s where "e = Eq t s" using equation.exhaust by auto
  from assms(1) have "subst s \<sigma> = subst s \<eta>" by auto
  from assms(1) have "subst t \<sigma> = subst t \<eta>" by auto
  from \<open>subst s \<sigma> = subst s \<eta>\<close> \<open>subst t \<sigma> = subst t \<eta>\<close>
    and \<open>e = Eq t s\<close> show ?thesis by auto
qed

lemma subst_eq_cl:
  assumes "subst_eq \<sigma> \<eta>"
  shows "subst_cl C \<sigma> = subst_cl C \<eta>"
proof (rule ccontr)
  assume "subst_cl C \<sigma> \<noteq> subst_cl C \<eta>"
  then obtain L where "L \<in> C" and "subst_lit L \<sigma> \<noteq> subst_lit L \<eta>"
    by force
  from assms(1) and \<open>subst_lit L \<sigma> \<noteq> subst_lit L \<eta>\<close>
    show False using subst_eq_lit by auto
qed

lemma coincide_on_eq :
  assumes "coincide_on \<sigma> \<eta> (vars_of_eq e)"
  shows "subst_equation e \<sigma> = subst_equation e \<eta>"
proof -
  obtain t and s where "e = Eq t s" using equation.exhaust by auto
  then have "vars_of t \<subseteq> vars_of_eq e" by simp
  from this and \<open>coincide_on \<sigma> \<eta> (vars_of_eq e)\<close> have "coincide_on \<sigma> \<eta> (vars_of t)"
    unfolding coincide_on_def by auto
  from this have "subst t \<sigma> = subst t \<eta>" using coincide_on_term by auto
  from \<open>e = Eq t s\<close>  have "vars_of s \<subseteq> vars_of_eq e" by simp
  from this and \<open>coincide_on \<sigma> \<eta> (vars_of_eq e)\<close> have "coincide_on \<sigma> \<eta> (vars_of s)"
    unfolding coincide_on_def by auto
  from this have "subst s \<sigma> = subst s \<eta>" using coincide_on_term by auto
  from \<open>subst t \<sigma> = subst t \<eta>\<close>
    and \<open>subst s \<sigma> = subst s \<eta>\<close>
    and \<open>e = Eq t s\<close> show ?thesis by auto
qed

lemma coincide_on_lit :
  assumes "coincide_on \<sigma> \<eta> (vars_of_lit l)"
  shows "subst_lit l \<sigma> = subst_lit l \<eta>"
proof -
  obtain e where "l = Pos e \<or> l = Neg e" using literal.exhaust by auto
  then have "vars_of_eq e \<subseteq> vars_of_lit l" by auto
  from this and \<open>coincide_on \<sigma> \<eta> (vars_of_lit l)\<close> have "coincide_on \<sigma> \<eta> (vars_of_eq e)"
    unfolding coincide_on_def by auto
  from this have "subst_equation e \<sigma> = subst_equation e \<eta>"
    using coincide_on_eq by auto
  from this and \<open>l = Pos e \<or> l = Neg e\<close> show ?thesis by auto
qed

lemma coincide_on_cl :
  assumes "coincide_on \<sigma> \<eta> (vars_of_cl C)"
  shows "subst_cl C \<sigma> = subst_cl C \<eta>"
proof (rule ccontr)
  assume "subst_cl C \<sigma> \<noteq> subst_cl C \<eta>"
  then obtain L where "L \<in> C" and "subst_lit L \<sigma> \<noteq> subst_lit L \<eta>"
    by force
  from \<open>L \<in> C\<close> have "vars_of_lit L \<subseteq> vars_of_cl C" by auto
  from this and assms have "coincide_on \<sigma> \<eta> (vars_of_lit L)" unfolding coincide_on_def by auto
  from this and \<open>subst_lit L \<sigma> \<noteq> subst_lit L \<eta>\<close>
    show False using coincide_on_lit by auto
qed

subsection \<open>Semantics\<close>

text \<open>Interpretations are congruences on the set of terms.\<close>

definition fo_interpretation :: "'a binary_relation_on_trms \<Rightarrow> bool"
where
  "(fo_interpretation x) = (congruence x)"

fun validate_ground_eq :: "'a binary_relation_on_trms \<Rightarrow> 'a equation  \<Rightarrow> bool"
where
"(validate_ground_eq I (Eq t s) = (I t s))"

fun validate_ground_lit :: "'a binary_relation_on_trms \<Rightarrow> 'a literal  \<Rightarrow> bool"
where
"validate_ground_lit I (Pos E) = (validate_ground_eq I E)" |
"validate_ground_lit I (Neg E) = (\<not>(validate_ground_eq I E))"

fun validate_ground_clause :: "'a binary_relation_on_trms \<Rightarrow> 'a clause \<Rightarrow> bool"
where
"validate_ground_clause I C = (\<exists>L.(L \<in> C) \<and> (validate_ground_lit I L))"

fun validate_clause :: "'a binary_relation_on_trms \<Rightarrow> 'a clause \<Rightarrow> bool"
where
"validate_clause I C = (\<forall>s. (ground_clause (subst_cl C s))
  \<longrightarrow> (validate_ground_clause I (subst_cl C s)))"

fun validate_clause_set :: "'a binary_relation_on_trms \<Rightarrow> 'a clause set \<Rightarrow> bool"
where
"validate_clause_set I S = (\<forall>C. (C \<in> S  \<longrightarrow> (validate_clause I C)))"

definition clause_entails_clause :: "'a clause \<Rightarrow> 'a clause \<Rightarrow> bool"
where
  "clause_entails_clause C D = (\<forall>I. (fo_interpretation I \<longrightarrow> validate_clause I C \<longrightarrow> validate_clause I D))"

definition set_entails_clause :: "'a clause set \<Rightarrow> 'a clause \<Rightarrow> bool"
where
  "set_entails_clause S C = (\<forall>I. (fo_interpretation I \<longrightarrow> validate_clause_set I S \<longrightarrow> validate_clause I C))"

definition satisfiable_clause_set :: "'a clause set \<Rightarrow> bool"
 where
 "(satisfiable_clause_set S) = (\<exists>I. (fo_interpretation I) \<and> (validate_clause_set I S))"

text \<open>We state basic properties of the entailment relation.\<close>

lemma set_entails_clause_member:
  assumes "C \<in> S"
  shows "set_entails_clause S C"
proof (rule ccontr)
  assume "\<not> ?thesis"
  from this obtain I where "fo_interpretation I" "validate_clause_set I S" "\<not> validate_clause I C"
    unfolding set_entails_clause_def by auto
  from \<open>validate_clause_set I S\<close> and assms(1) \<open>\<not> validate_clause I C\<close> show False  by auto
qed

lemma instances_are_entailed :
  assumes "validate_clause I C"
  shows "validate_clause I (subst_cl C \<sigma>)"
proof (rule ccontr)
  assume "\<not>validate_clause I (subst_cl C \<sigma>)"
  then obtain \<eta>
    where "\<not>validate_ground_clause I (subst_cl (subst_cl C \<sigma>) \<eta>)"
      and "ground_clause (subst_cl (subst_cl C \<sigma>) \<eta>)"
    by auto
  then have i: "\<not>validate_ground_clause I (subst_cl C (comp \<sigma> \<eta>))"
   using composition_of_substs_cl by metis
  from \<open>ground_clause (subst_cl (subst_cl C \<sigma>) \<eta>)\<close>
    have ii: "ground_clause (subst_cl C (comp \<sigma> \<eta>))"
    using composition_of_substs_cl by metis
  from i and ii have "\<not>validate_clause I C" by auto
  from \<open>\<not>validate_clause I C\<close> and \<open>validate_clause I C\<close> show False by blast
qed

text \<open>We prove that two equivalent substitutions yield equivalent objects.\<close>

lemma equivalent_on_eq :
  assumes "equivalent_on \<sigma> \<eta> (vars_of_eq e) I"
  assumes "fo_interpretation I"
  shows "(validate_ground_eq I (subst_equation e \<sigma>)) = (validate_ground_eq I (subst_equation e \<eta>))"
proof -
  obtain t and s where "e = Eq t s" using equation.exhaust by auto
  then have "vars_of t \<subseteq> vars_of_eq e" by simp
  from this and assms(1) have "equivalent_on \<sigma> \<eta> (vars_of t) I"
    unfolding equivalent_on_def by auto
  from this assms(2)
    have "I (subst t \<sigma>) (subst t \<eta>)" using equivalent_on_term
    unfolding fo_interpretation_def by auto
  from \<open>e = Eq t s\<close>  have "vars_of s \<subseteq> vars_of_eq e" by simp
  from this and \<open>equivalent_on \<sigma> \<eta> (vars_of_eq e) I\<close> have "equivalent_on \<sigma> \<eta> (vars_of s) I"
    unfolding equivalent_on_def by auto
  from this assms(2) have "I (subst s \<sigma>) (subst s \<eta>)"
    using equivalent_on_term unfolding fo_interpretation_def by auto
  from assms(2) \<open>I (subst t \<sigma>) (subst t \<eta>)\<close>
    and \<open>I (subst s \<sigma>) (subst s \<eta>)\<close>
    and \<open>e = Eq t s\<close> show ?thesis unfolding fo_interpretation_def congruence_def equivalence_relation_def
    transitive_def symmetric_def reflexive_def
    by (metis (full_types) subst_equation.simps validate_ground_eq.simps)
qed

lemma equivalent_on_lit :
  assumes "equivalent_on \<sigma> \<eta> (vars_of_lit l) I"
  assumes "fo_interpretation I"
  shows "(validate_ground_lit I (subst_lit l \<sigma>))
    = (validate_ground_lit I (subst_lit l \<eta>))"
proof -
  obtain e where "l = Pos e \<or> l = Neg e" using literal.exhaust by auto
  then have "vars_of_eq e \<subseteq> vars_of_lit l" by auto
  from this and \<open>equivalent_on \<sigma> \<eta> (vars_of_lit l) I\<close> have "equivalent_on \<sigma> \<eta> (vars_of_eq e) I"
    unfolding equivalent_on_def by auto
  from this assms(2) have "(validate_ground_eq I (subst_equation e \<sigma>)) = (validate_ground_eq I (subst_equation e \<eta>))"
    using equivalent_on_eq by auto
  from this and \<open>l = Pos e \<or> l = Neg e\<close> show ?thesis by auto
qed

lemma equivalent_on_cl :
  assumes "equivalent_on \<sigma> \<eta> (vars_of_cl C) I"
  assumes "fo_interpretation I"
  shows "(validate_ground_clause I (subst_cl C \<sigma>))
    = (validate_ground_clause I (subst_cl C \<eta>))"
proof (rule ccontr)
  assume "(validate_ground_clause I (subst_cl C \<sigma>))
    \<noteq> (validate_ground_clause I (subst_cl C \<eta>))"
  then obtain L where "L \<in> C" and "(validate_ground_lit I (subst_lit L \<sigma>))
    \<noteq> (validate_ground_lit I (subst_lit L \<eta>))"
    by force
  from \<open>L \<in> C\<close> have "vars_of_lit L \<subseteq> vars_of_cl C" by auto
  from this and assms have "equivalent_on \<sigma> \<eta> (vars_of_lit L) I" unfolding equivalent_on_def by auto
  from this assms(2) and \<open>(validate_ground_lit I (subst_lit L \<sigma>))
    \<noteq> (validate_ground_lit I (subst_lit L \<eta>))\<close>
    show False using equivalent_on_lit by metis
qed

end