(*
 * This is an autogenerated file. Do not edit.
 * The original is Laws.thy. It was converted using instantiate_laws.py.
 *)

section \<open>Generic laws about registers, instantiated quantumly\<close>

theory Laws_Quantum
  imports Axioms_Quantum
begin

text \<open>This notation is only used inside this file\<close>
notation cblinfun_compose (infixl "*\<^sub>u" 55)
notation tensor_op (infixr "\<otimes>\<^sub>u" 70)
notation register_pair ("'(_;_')")

subsection \<open>Elementary facts\<close>

declare complex_vector.linear_id[simp]
declare cblinfun_compose_id_left[simp]
declare cblinfun_compose_id_right[simp]
declare register_preregister[simp]
declare register_comp[simp]
declare register_of_id[simp]
declare register_tensor_left[simp]
declare register_tensor_right[simp]
declare preregister_mult_right[simp]
declare preregister_mult_left[simp]
declare register_id[simp]

subsection \<open>Preregisters\<close>

lemma preregister_tensor_left[simp]: \<open>clinear (\<lambda>b::'b::finite update. tensor_op a b)\<close>
  for a :: \<open>'a::finite update\<close>
proof -
  have \<open>clinear ((\<lambda>b1::('a\<times>'b) update. (a \<otimes>\<^sub>u id_cblinfun) *\<^sub>u b1) o (\<lambda>b. tensor_op id_cblinfun b))\<close>
    by (rule clinear_compose; simp)
  then show ?thesis
    by (simp add: o_def comp_tensor_op)
qed

lemma preregister_tensor_right[simp]: \<open>clinear (\<lambda>a::'a::finite update. tensor_op a b)\<close>
  for b :: \<open>'b::finite update\<close>
proof -
  have \<open>clinear ((\<lambda>a1::('a\<times>'b) update. (id_cblinfun \<otimes>\<^sub>u b) *\<^sub>u a1) o (\<lambda>a. tensor_op a id_cblinfun))\<close>
    by (rule clinear_compose, simp_all)
  then show ?thesis
    by (simp add: o_def comp_tensor_op)
qed

subsection \<open>Registers\<close>

lemma id_update_tensor_register[simp]:
  assumes \<open>register F\<close>
  shows \<open>register (\<lambda>a::'a::finite update. id_cblinfun \<otimes>\<^sub>u F a)\<close>
  using assms apply (rule register_comp[unfolded o_def])
  by simp

lemma register_tensor_id_update[simp]:
  assumes \<open>register F\<close>
  shows \<open>register (\<lambda>a::'a::finite update. F a \<otimes>\<^sub>u id_cblinfun)\<close>
  using assms apply (rule register_comp[unfolded o_def])
  by simp

subsection \<open>Tensor product of registers\<close>

definition register_tensor  (infixr "\<otimes>\<^sub>r" 70) where
  "register_tensor F G = register_pair (\<lambda>a. tensor_op (F a) id_cblinfun) (\<lambda>b. tensor_op id_cblinfun (G b))"

lemma register_tensor_is_register:
  fixes F :: "'a::finite update \<Rightarrow> 'b::finite update" and G :: "'c::finite update \<Rightarrow> 'd::finite update"
  shows "register F \<Longrightarrow> register G \<Longrightarrow> register (F \<otimes>\<^sub>r G)"
  unfolding register_tensor_def
  apply (rule register_pair_is_register)
  by (simp_all add: comp_tensor_op)

lemma register_tensor_apply[simp]:
  fixes F :: "'a::finite update \<Rightarrow> 'b::finite update" and G :: "'c::finite update \<Rightarrow> 'd::finite update"
  assumes \<open>register F\<close> and \<open>register G\<close>
  shows "(F \<otimes>\<^sub>r G) (a \<otimes>\<^sub>u b) = F a \<otimes>\<^sub>u G b"
  unfolding register_tensor_def
  apply (subst register_pair_apply)
  unfolding register_tensor_def
  by (simp_all add: assms comp_tensor_op)

definition "separating (_::'b::finite itself) A \<longleftrightarrow>
  (\<forall>F G :: 'a::finite update \<Rightarrow> 'b update. clinear F \<longrightarrow> clinear G \<longrightarrow> (\<forall>x\<in>A. F x = G x) \<longrightarrow> F = G)"

lemma separating_UNIV[simp]: \<open>separating TYPE(_) UNIV\<close>
  unfolding separating_def by auto

lemma separating_mono: \<open>A \<subseteq> B \<Longrightarrow> separating TYPE('a::finite) A \<Longrightarrow> separating TYPE('a) B\<close>
  unfolding separating_def by (meson in_mono)

lemma register_eqI: \<open>separating TYPE('b::finite) A \<Longrightarrow> clinear F \<Longrightarrow> clinear G \<Longrightarrow> (\<And>x. x\<in>A \<Longrightarrow> F x = G x) \<Longrightarrow> F = (G::_ \<Rightarrow> 'b update)\<close>
  unfolding separating_def by auto

lemma separating_tensor:
  fixes A :: \<open>'a::finite update set\<close> and B :: \<open>'b::finite update set\<close>
  assumes [simp]: \<open>separating TYPE('c::finite) A\<close>
  assumes [simp]: \<open>separating TYPE('c) B\<close>
  shows \<open>separating TYPE('c) {a \<otimes>\<^sub>u b | a b. a\<in>A \<and> b\<in>B}\<close>
proof (unfold separating_def, intro allI impI)
  fix F G :: \<open>('a\<times>'b) update \<Rightarrow> 'c update\<close>
  assume [simp]: \<open>clinear F\<close> \<open>clinear G\<close>
  have [simp]: \<open>clinear (\<lambda>x. F (a \<otimes>\<^sub>u x))\<close> for a
    using _ \<open>clinear F\<close> apply (rule clinear_compose[unfolded o_def])
    by simp
  have [simp]: \<open>clinear (\<lambda>x. G (a \<otimes>\<^sub>u x))\<close> for a
    using _ \<open>clinear G\<close> apply (rule clinear_compose[unfolded o_def])
    by simp
  have [simp]: \<open>clinear (\<lambda>x. F (x \<otimes>\<^sub>u b))\<close> for b
    using _ \<open>clinear F\<close> apply (rule clinear_compose[unfolded o_def])
    by simp
  have [simp]: \<open>clinear (\<lambda>x. G (x \<otimes>\<^sub>u b))\<close> for b
    using _ \<open>clinear G\<close> apply (rule clinear_compose[unfolded o_def])
    by simp

  assume \<open>\<forall>x\<in>{a \<otimes>\<^sub>u b |a b. a\<in>A \<and> b\<in>B}. F x = G x\<close>
  then have EQ: \<open>F (a \<otimes>\<^sub>u b) = G (a \<otimes>\<^sub>u b)\<close> if \<open>a \<in> A\<close> and \<open>b \<in> B\<close> for a b
    using that by auto
  then have \<open>F (a \<otimes>\<^sub>u b) = G (a \<otimes>\<^sub>u b)\<close> if \<open>a \<in> A\<close> for a b
    apply (rule register_eqI[where A=B, THEN fun_cong, where x=b, rotated -1])
    using that by auto
  then have \<open>F (a \<otimes>\<^sub>u b) = G (a \<otimes>\<^sub>u b)\<close> for a b
    apply (rule register_eqI[where A=A, THEN fun_cong, where x=a, rotated -1])
    by auto
  then show "F = G"
    apply (rule tensor_extensionality[rotated -1])
    by auto
qed

lemma register_tensor_distrib:
  assumes [simp]: \<open>register F\<close> \<open>register G\<close> \<open>register H\<close> \<open>register L\<close>
  shows \<open>(F \<otimes>\<^sub>r G) o (H \<otimes>\<^sub>r L) = (F o H) \<otimes>\<^sub>r (G o L)\<close>
  apply (rule tensor_extensionality)
  by (auto intro!: register_comp register_preregister register_tensor_is_register)

text \<open>The following is easier to apply using the @{method rule}-method than @{thm [source] separating_tensor}\<close>
lemma separating_tensor':
  fixes A :: \<open>'a::finite update set\<close> and B :: \<open>'b::finite update set\<close>
  assumes \<open>separating TYPE('c::finite) A\<close>
  assumes \<open>separating TYPE('c) B\<close>
  assumes \<open>C = {a \<otimes>\<^sub>u b | a b. a\<in>A \<and> b\<in>B}\<close>
  shows \<open>separating TYPE('c) C\<close>
  using assms
  by (simp add: separating_tensor)

lemma tensor_extensionality3:
  fixes F G :: \<open>('a::finite\<times>'b::finite\<times>'c::finite) update \<Rightarrow> 'd::finite update\<close>
  assumes [simp]: \<open>register F\<close> \<open>register G\<close>
  assumes "\<And>f g h. F (f \<otimes>\<^sub>u g \<otimes>\<^sub>u h) = G (f \<otimes>\<^sub>u g \<otimes>\<^sub>u h)"
  shows "F = G"
proof (rule register_eqI[where A=\<open>{a\<otimes>\<^sub>ub\<otimes>\<^sub>uc| a b c. True}\<close>])
  have \<open>separating TYPE('d) {b \<otimes>\<^sub>u c |b c. True}\<close>
    apply (rule separating_tensor'[where A=UNIV and B=UNIV])
    by auto
  then show \<open>separating TYPE('d) {a \<otimes>\<^sub>u b \<otimes>\<^sub>u c |a b c. True}\<close>
    apply (rule_tac separating_tensor'[where A=UNIV and B=\<open>{b\<otimes>\<^sub>uc| b c. True}\<close>])
    by auto
  show \<open>clinear F\<close> \<open>clinear G\<close> by auto
  show \<open>x \<in> {a \<otimes>\<^sub>u b \<otimes>\<^sub>u c |a b c. True} \<Longrightarrow> F x = G x\<close> for x
    using assms(3) by auto
qed

lemma tensor_extensionality3':
  fixes F G :: \<open>(('a::finite\<times>'b::finite)\<times>'c::finite) update \<Rightarrow> 'd::finite update\<close>
  assumes [simp]: \<open>register F\<close> \<open>register G\<close>
  assumes "\<And>f g h. F ((f \<otimes>\<^sub>u g) \<otimes>\<^sub>u h) = G ((f \<otimes>\<^sub>u g) \<otimes>\<^sub>u h)"
  shows "F = G"
proof (rule register_eqI[where A=\<open>{(a\<otimes>\<^sub>ub)\<otimes>\<^sub>uc| a b c. True}\<close>])
  have \<open>separating TYPE('d) {a \<otimes>\<^sub>u b | a b. True}\<close>
    apply (rule separating_tensor'[where A=UNIV and B=UNIV])
    by auto
  then show \<open>separating TYPE('d) {(a \<otimes>\<^sub>u b) \<otimes>\<^sub>u c |a b c. True}\<close>
    apply (rule_tac separating_tensor'[where B=UNIV and A=\<open>{a\<otimes>\<^sub>ub| a b. True}\<close>])
    by auto
  show \<open>clinear F\<close> \<open>clinear G\<close> by auto
  show \<open>x \<in> {(a \<otimes>\<^sub>u b) \<otimes>\<^sub>u c |a b c. True} \<Longrightarrow> F x = G x\<close> for x
    using assms(3) by auto
qed

lemma register_tensor_id[simp]: \<open>id \<otimes>\<^sub>r id = id\<close>
  apply (rule tensor_extensionality)
  by (auto simp add: register_tensor_is_register)

subsection \<open>Pairs and compatibility\<close>

definition compatible :: \<open>('a::finite update \<Rightarrow> 'c::finite update)
                       \<Rightarrow> ('b::finite update \<Rightarrow> 'c update) \<Rightarrow> bool\<close> where
  \<open>compatible F G \<longleftrightarrow> register F \<and> register G \<and> (\<forall>a b. F a *\<^sub>u G b = G b *\<^sub>u F a)\<close>

lemma compatibleI:
  assumes "register F" and "register G"
  assumes \<open>\<And>a b. (F a) *\<^sub>u (G b) = (G b) *\<^sub>u (F a)\<close>
  shows "compatible F G"
  using assms unfolding compatible_def by simp

lemma swap_registers:
  assumes "compatible R S"
  shows "R a *\<^sub>u S b = S b *\<^sub>u R a"
  using assms unfolding compatible_def by metis

lemma compatible_sym: "compatible x y \<Longrightarrow> compatible y x"
  by (simp add: compatible_def)

lemma pair_is_register[simp]:
  assumes "compatible F G"
  shows "register (F; G)"
  by (metis assms compatible_def register_pair_is_register)

lemma register_pair_apply:
  assumes \<open>compatible F G\<close>
  shows \<open>(F; G) (a \<otimes>\<^sub>u b) = (F a) *\<^sub>u (G b)\<close>
  apply (rule register_pair_apply)
  using assms unfolding compatible_def by metis+

lemma register_pair_apply':
  assumes \<open>compatible F G\<close>
  shows \<open>(F; G) (a \<otimes>\<^sub>u b) = (G b) *\<^sub>u (F a)\<close>
  apply (subst register_pair_apply)
  using assms by (auto simp: compatible_def intro: register_preregister)

lemma compatible_comp_left[simp]: "compatible F G \<Longrightarrow> register H \<Longrightarrow> compatible (F \<circ> H) G"
  by (simp add: compatible_def)

lemma compatible_comp_right[simp]: "compatible F G \<Longrightarrow> register H \<Longrightarrow> compatible F (G \<circ> H)"
  by (simp add: compatible_def)

lemma compatible_comp_inner[simp]:
  "compatible F G \<Longrightarrow> register H \<Longrightarrow> compatible (H \<circ> F) (H \<circ> G)"
  by (smt (verit, best) comp_apply compatible_def register_comp register_mult)

lemma compatible_register1: \<open>compatible F G \<Longrightarrow> register F\<close>
  by (simp add: compatible_def)
lemma compatible_register2: \<open>compatible F G \<Longrightarrow> register G\<close>
  by (simp add: compatible_def)

lemma pair_o_tensor:
  assumes "compatible A B" and [simp]: \<open>register C\<close> and [simp]: \<open>register D\<close>
  shows "(A; B) o (C \<otimes>\<^sub>r D) = (A o C; B o D)"
  apply (rule tensor_extensionality)
  using assms by (simp_all add: register_tensor_is_register register_pair_apply clinear_compose)

lemma compatible_tensor_id_update_left[simp]:
  fixes F :: "'a::finite update \<Rightarrow> 'c::finite update" and G :: "'b::finite update \<Rightarrow> 'c::finite update"
  assumes "compatible F G"
  shows "compatible (\<lambda>a. id_cblinfun \<otimes>\<^sub>u F a) (\<lambda>a. id_cblinfun \<otimes>\<^sub>u G a)"
  using assms apply (rule compatible_comp_inner[unfolded o_def])
  by simp

lemma compatible_tensor_id_update_right[simp]:
  fixes F :: "'a::finite update \<Rightarrow> 'c::finite update" and G :: "'b::finite update \<Rightarrow> 'c::finite update"
  assumes "compatible F G"
  shows "compatible (\<lambda>a. F a \<otimes>\<^sub>u id_cblinfun) (\<lambda>a. G a \<otimes>\<^sub>u id_cblinfun)"
  using assms apply (rule compatible_comp_inner[unfolded o_def])
  by simp

lemma compatible_tensor_id_update_rl[simp]:
  assumes "register F" and "register G"
  shows "compatible (\<lambda>a. F a \<otimes>\<^sub>u id_cblinfun) (\<lambda>a. id_cblinfun \<otimes>\<^sub>u G a)"
  apply (rule compatibleI)
  using assms by (auto simp: comp_tensor_op)

lemma compatible_tensor_id_update_lr[simp]:
  assumes "register F" and "register G"
  shows "compatible (\<lambda>a. id_cblinfun \<otimes>\<^sub>u F a) (\<lambda>a. G a \<otimes>\<^sub>u id_cblinfun)"
  apply (rule compatibleI)
  using assms by (auto simp: comp_tensor_op)

lemma register_comp_pair:
  assumes [simp]: \<open>register F\<close> and [simp]: \<open>compatible G H\<close>
  shows "(F o G; F o H) = F o (G; H)"
proof (rule tensor_extensionality)
  show \<open>clinear (F \<circ> G;F \<circ> H)\<close> and \<open>clinear (F \<circ> (G;H))\<close>
    by simp_all

  have [simp]: \<open>compatible (F o G) (F o H)\<close>
    apply (rule compatible_comp_inner, simp)
    by simp
  then have [simp]: \<open>register (F \<circ> G)\<close> \<open>register (F \<circ> H)\<close>
    unfolding compatible_def by auto
  from assms have [simp]: \<open>register G\<close> \<open>register H\<close>
    unfolding compatible_def by auto
  fix a b
  show \<open>(F \<circ> G;F \<circ> H) (a \<otimes>\<^sub>u b) = (F \<circ> (G;H)) (a \<otimes>\<^sub>u b)\<close>
    by (auto simp: register_pair_apply register_mult comp_tensor_op)
qed

lemma swap_registers_left:
  assumes "compatible R S"
  shows "R a *\<^sub>u S b *\<^sub>u c = S b *\<^sub>u R a *\<^sub>u c"
  using assms unfolding compatible_def by metis

lemma swap_registers_right:
  assumes "compatible R S"
  shows "c *\<^sub>u R a *\<^sub>u S b = c *\<^sub>u S b *\<^sub>u R a"
  by (metis assms cblinfun_compose_assoc compatible_def)

lemmas compatible_ac_rules = swap_registers cblinfun_compose_assoc[symmetric] swap_registers_right

subsection \<open>Fst and Snd\<close>

definition Fst where \<open>Fst a = a \<otimes>\<^sub>u id_cblinfun\<close>
definition Snd where \<open>Snd a = id_cblinfun \<otimes>\<^sub>u a\<close>

lemma register_Fst[simp]: \<open>register Fst\<close>
  unfolding Fst_def by (rule register_tensor_left)

lemma register_Snd[simp]: \<open>register Snd\<close>
  unfolding Snd_def by (rule register_tensor_right)

lemma compatible_Fst_Snd[simp]: \<open>compatible Fst Snd\<close>
  apply (rule compatibleI, simp, simp)
  by (simp add: Fst_def Snd_def comp_tensor_op)

lemmas compatible_Snd_Fst[simp] = compatible_Fst_Snd[THEN compatible_sym]

definition \<open>swap = (Snd; Fst)\<close>

lemma swap_apply[simp]: "swap (a \<otimes>\<^sub>u b) = (b \<otimes>\<^sub>u a)"
  unfolding swap_def
  by (simp add: Axioms_Quantum.register_pair_apply Fst_def Snd_def comp_tensor_op)

lemma swap_o_Fst: "swap o Fst = Snd"
  by (auto simp add: Fst_def Snd_def)
lemma swap_o_Snd: "swap o Snd = Fst"
  by (auto simp add: Fst_def Snd_def)

lemma register_swap[simp]: \<open>register swap\<close>
  by (simp add: swap_def)

lemma pair_Fst_Snd: \<open>(Fst; Snd) = id\<close>
  apply (rule tensor_extensionality)
  by (simp_all add: register_pair_apply Fst_def Snd_def comp_tensor_op)

lemma swap_o_swap[simp]: \<open>swap o swap = id\<close>
  by (metis swap_def compatible_Snd_Fst pair_Fst_Snd register_comp_pair register_swap swap_o_Fst swap_o_Snd)

lemma swap_swap[simp]: \<open>swap (swap x) = x\<close>
  by (simp add: pointfree_idE)

lemma inv_swap[simp]: \<open>inv swap = swap\<close>
  by (meson inv_unique_comp swap_o_swap)

lemma register_pair_Fst:
  assumes \<open>compatible F G\<close>
  shows \<open>(F;G) o Fst = F\<close>
  using assms by (auto intro!: ext simp: Fst_def register_pair_apply compatible_register2)

lemma register_pair_Snd:
  assumes \<open>compatible F G\<close>
  shows \<open>(F;G) o Snd = G\<close>
  using assms by (auto intro!: ext simp: Snd_def register_pair_apply compatible_register1)

lemma register_Fst_register_Snd[simp]:
  assumes \<open>register F\<close>
  shows \<open>(F o Fst; F o Snd) = F\<close>
  apply (rule tensor_extensionality)
  using assms by (auto simp: register_pair_apply Fst_def Snd_def register_mult comp_tensor_op)

lemma register_Snd_register_Fst[simp]:
  assumes \<open>register F\<close>
  shows \<open>(F o Snd; F o Fst) = F o swap\<close>
  apply (rule tensor_extensionality)
  using assms by (auto simp: register_pair_apply Fst_def Snd_def register_mult comp_tensor_op)

lemma compatible3[simp]:
  assumes [simp]: "compatible F G" and "compatible G H" and "compatible F H"
  shows "compatible (F; G) H"
proof (rule compatibleI)
  have [simp]: \<open>register F\<close> \<open>register G\<close> \<open>register H\<close>
    using assms compatible_def by auto
  then have [simp]: \<open>clinear F\<close> \<open>clinear G\<close> \<open>clinear H\<close>
    using register_preregister by blast+
  have [simp]: \<open>clinear (\<lambda>a. (F;G) a *\<^sub>u z)\<close> for z
    apply (rule clinear_compose[unfolded o_def, of \<open>(F;G)\<close>])
    by simp_all
  have [simp]: \<open>clinear (\<lambda>a. z *\<^sub>u (F;G) a)\<close> for z
    apply (rule clinear_compose[unfolded o_def, of \<open>(F;G)\<close>])
    by simp_all
  have "(F; G) (f \<otimes>\<^sub>u g) *\<^sub>u H h = H h *\<^sub>u (F; G) (f \<otimes>\<^sub>u g)" for f g h
  proof -
    have FH: "F f *\<^sub>u H h = H h *\<^sub>u F f"
      using assms compatible_def by metis
    have GH: "G g *\<^sub>u H h = H h *\<^sub>u G g"
      using assms compatible_def by metis
    have \<open>(F; G) (f \<otimes>\<^sub>u g) *\<^sub>u (H h) = F f *\<^sub>u G g *\<^sub>u H h\<close>
      using \<open>compatible F G\<close> by (subst register_pair_apply, auto)
    also have \<open>\<dots> = H h *\<^sub>u F f *\<^sub>u G g\<close>
      using FH GH by (metis cblinfun_compose_assoc)
    also have \<open>\<dots> = H h *\<^sub>u (F; G) (f \<otimes>\<^sub>u g)\<close>
      using \<open>compatible F G\<close> by (subst register_pair_apply, auto simp: cblinfun_compose_assoc)
    finally show ?thesis
      by -
  qed
  then show "(F; G) fg *\<^sub>u (H h) = (H h) *\<^sub>u (F; G) fg" for fg h
    apply (rule_tac tensor_extensionality[THEN fun_cong])
    by auto
  show "register H" and  "register (F; G)"
    by simp_all
qed

lemma compatible3'[simp]:
  assumes "compatible F G" and "compatible G H" and "compatible F H"
  shows "compatible F (G; H)"
  apply (rule compatible_sym)
  apply (rule compatible3)
  using assms by (auto simp: compatible_sym)

lemma pair_o_swap[simp]:
  assumes [simp]: "compatible A B"
  shows "(A; B) o swap = (B; A)"
proof (rule tensor_extensionality)
  have [simp]: "clinear A" "clinear B"
     apply (metis (no_types, opaque_lifting) assms compatible_register1 register_preregister)
    by (metis (full_types) assms compatible_register2 register_preregister)
  then show \<open>clinear ((A; B) \<circ> swap)\<close>
    by simp
  show \<open>clinear (B; A)\<close>
    by (metis (no_types, lifting) assms compatible_sym register_preregister pair_is_register)
  show \<open>((A; B) \<circ> swap) (a \<otimes>\<^sub>u b) = (B; A) (a \<otimes>\<^sub>u b)\<close> for a b
    (* Without the "only:", we would not need the "apply subst",
       but that proof fails when instantiated in Classical.thy *)
    apply (simp only: o_def swap_apply)
    apply (subst register_pair_apply, simp)
    apply (subst register_pair_apply, simp add: compatible_sym)
    by (metis (no_types, lifting) assms compatible_def)
qed

subsection \<open>Compatibility of register tensor products\<close>

lemma compatible_register_tensor:
  fixes F :: \<open>'a::finite update \<Rightarrow> 'e::finite update\<close> and G :: \<open>'b::finite update \<Rightarrow> 'f::finite update\<close>
    and F' :: \<open>'c::finite update \<Rightarrow> 'e update\<close> and G' :: \<open>'d::finite update \<Rightarrow> 'f update\<close>
  assumes [simp]: \<open>compatible F F'\<close>
  assumes [simp]: \<open>compatible G G'\<close>
  shows \<open>compatible (F \<otimes>\<^sub>r G) (F' \<otimes>\<^sub>r G')\<close>
proof -
  note [intro!] =
    clinear_compose[OF _ preregister_mult_right, unfolded o_def]
    clinear_compose[OF _ preregister_mult_left, unfolded o_def]
    clinear_compose
    register_tensor_is_register
  have [simp]: \<open>register F\<close> \<open>register G\<close> \<open>register F'\<close> \<open>register G'\<close>
    using assms compatible_def by blast+
  have [simp]: \<open>register (F \<otimes>\<^sub>r G)\<close> \<open>register (F' \<otimes>\<^sub>r G')\<close>
    by (auto simp add: register_tensor_def)
  have [simp]: \<open>register (F;F')\<close> \<open>register (G;G')\<close>
    by auto
  define reorder :: \<open>(('a\<times>'b) \<times> ('c\<times>'d)) update \<Rightarrow> (('a\<times>'c) \<times> ('b\<times>'d)) update\<close>
    where \<open>reorder = ((Fst o Fst; Snd o Fst); (Fst o Snd; Snd o Snd))\<close>
  have [simp]: \<open>clinear reorder\<close>
    by (auto simp: reorder_def)
  have [simp]: \<open>reorder ((a \<otimes>\<^sub>u b) \<otimes>\<^sub>u (c \<otimes>\<^sub>u d)) = ((a \<otimes>\<^sub>u c) \<otimes>\<^sub>u (b \<otimes>\<^sub>u d))\<close> for a b c d
    apply (simp add: reorder_def register_pair_apply)
    by (simp add: Fst_def Snd_def comp_tensor_op)
  define \<Phi> where \<open>\<Phi> c d = ((F;F') \<otimes>\<^sub>r (G;G')) o reorder o (\<lambda>\<sigma>. \<sigma> \<otimes>\<^sub>u (c \<otimes>\<^sub>u d))\<close> for c d
  have [simp]: \<open>clinear (\<Phi> c d)\<close> for c d
    unfolding \<Phi>_def
    by (auto intro: register_preregister)
  have \<open>\<Phi> c d (a \<otimes>\<^sub>u b) = (F \<otimes>\<^sub>r G) (a \<otimes>\<^sub>u b) *\<^sub>u (F' \<otimes>\<^sub>r G') (c \<otimes>\<^sub>u d)\<close> for a b c d
    unfolding \<Phi>_def by (auto simp: register_pair_apply comp_tensor_op)
  then have \<Phi>1: \<open>\<Phi> c d \<sigma> = (F \<otimes>\<^sub>r G) \<sigma> *\<^sub>u (F' \<otimes>\<^sub>r G') (c \<otimes>\<^sub>u d)\<close> for c d \<sigma>
    apply (rule_tac fun_cong[of _ _ \<sigma>])
    apply (rule tensor_extensionality)
    by auto
  have \<open>\<Phi> c d (a \<otimes>\<^sub>u b) = (F' \<otimes>\<^sub>r G') (c \<otimes>\<^sub>u d) *\<^sub>u (F \<otimes>\<^sub>r G) (a \<otimes>\<^sub>u b)\<close> for a b c d
    unfolding \<Phi>_def apply (auto simp: register_pair_apply)
    by (metis assms(1) assms(2) compatible_def comp_tensor_op)
  then have \<Phi>2: \<open>\<Phi> c d \<sigma> = (F' \<otimes>\<^sub>r G') (c \<otimes>\<^sub>u d) *\<^sub>u (F \<otimes>\<^sub>r G) \<sigma>\<close> for c d \<sigma>
    apply (rule_tac fun_cong[of _ _ \<sigma>])
    apply (rule tensor_extensionality)
    by auto
  from \<Phi>1 \<Phi>2 have \<open>(F \<otimes>\<^sub>r G) \<sigma> *\<^sub>u (F' \<otimes>\<^sub>r G') \<tau> = (F' \<otimes>\<^sub>r G') \<tau> *\<^sub>u (F \<otimes>\<^sub>r G) \<sigma>\<close> for \<tau> \<sigma>
    apply (rule_tac fun_cong[of _ _ \<tau>])
    apply (rule tensor_extensionality)
    by auto
  then show ?thesis
    apply (rule compatibleI[rotated -1])
    by auto
qed

subsection \<open>Associativity of the tensor product\<close>

definition assoc :: \<open>(('a::finite\<times>'b::finite)\<times>'c::finite) update \<Rightarrow> ('a\<times>('b\<times>'c)) update\<close> where
  \<open>assoc = ((Fst; Snd o Fst); Snd o Snd)\<close>

lemma assoc_is_hom[simp]: \<open>clinear assoc\<close>
  by (auto simp: assoc_def)

lemma assoc_apply[simp]: \<open>assoc ((a \<otimes>\<^sub>u b) \<otimes>\<^sub>u c) = (a \<otimes>\<^sub>u (b \<otimes>\<^sub>u c))\<close>
  by (auto simp: assoc_def register_pair_apply Fst_def Snd_def comp_tensor_op)

definition assoc' :: \<open>('a\<times>('b\<times>'c)) update \<Rightarrow> (('a::finite\<times>'b::finite)\<times>'c::finite) update\<close> where
  \<open>assoc' = (Fst o Fst; (Fst o Snd; Snd))\<close>

lemma assoc'_is_hom[simp]: \<open>clinear assoc'\<close>
  by (auto simp: assoc'_def)

lemma assoc'_apply[simp]: \<open>assoc' (a \<otimes>\<^sub>u (b \<otimes>\<^sub>u c)) =  ((a \<otimes>\<^sub>u b) \<otimes>\<^sub>u c)\<close>
  by (auto simp: assoc'_def register_pair_apply Fst_def Snd_def comp_tensor_op)

lemma register_assoc[simp]: \<open>register assoc\<close>
  unfolding assoc_def
  by force

lemma register_assoc'[simp]: \<open>register assoc'\<close>
  unfolding assoc'_def
  by force

lemma pair_o_assoc[simp]:
  assumes [simp]: \<open>compatible F G\<close> \<open>compatible G H\<close> \<open>compatible F H\<close>
  shows \<open>(F; (G; H)) \<circ> assoc = ((F; G); H)\<close>
proof (rule tensor_extensionality3')
  show \<open>register ((F; (G; H)) \<circ> assoc)\<close>
    by simp
  show \<open>register ((F; G); H)\<close>
    by simp
  show \<open>((F; (G; H)) \<circ> assoc) ((f \<otimes>\<^sub>u g) \<otimes>\<^sub>u h) = ((F; G); H) ((f \<otimes>\<^sub>u g) \<otimes>\<^sub>u h)\<close> for f g h
    by (simp add: register_pair_apply assoc_apply cblinfun_compose_assoc)
qed

lemma pair_o_assoc'[simp]:
  assumes [simp]: \<open>compatible F G\<close> \<open>compatible G H\<close> \<open>compatible F H\<close>
  shows \<open>((F; G); H) \<circ> assoc' = (F; (G; H))\<close>
proof (rule tensor_extensionality3)
  show \<open>register (((F; G); H) \<circ> assoc')\<close>
    by simp
  show \<open>register (F; (G; H))\<close>
    by simp
  show \<open>(((F; G); H) \<circ> assoc') (f \<otimes>\<^sub>u g \<otimes>\<^sub>u h) = (F; (G; H)) (f \<otimes>\<^sub>u g \<otimes>\<^sub>u h)\<close> for f g h
    by (simp add: register_pair_apply assoc'_apply cblinfun_compose_assoc)
qed

lemma assoc'_o_assoc[simp]: \<open>assoc' o assoc = id\<close>
  apply (rule tensor_extensionality3')
  by auto

lemma assoc'_assoc[simp]: \<open>assoc' (assoc x) = x\<close>
  by (simp add: pointfree_idE)

lemma assoc_o_assoc'[simp]: \<open>assoc o assoc' = id\<close>
  apply (rule tensor_extensionality3)
  by auto

lemma assoc_assoc'[simp]: \<open>assoc (assoc' x) = x\<close>
  by (simp add: pointfree_idE)

lemma inv_assoc[simp]: \<open>inv assoc = assoc'\<close>
  using assoc'_o_assoc assoc_o_assoc' inv_unique_comp by blast

lemma inv_assoc'[simp]: \<open>inv assoc' = assoc\<close>
  by (simp add: inv_equality)

lemma [simp]: \<open>bij assoc'\<close>
  using assoc'_o_assoc assoc_o_assoc' o_bij by blast

subsection \<open>Iso-registers\<close>

definition \<open>iso_register F \<longleftrightarrow> register F \<and> (\<exists>G. register G \<and> F o G = id \<and> G o F = id)\<close>
  for F :: \<open>_::finite update \<Rightarrow> _::finite update\<close>

lemma iso_registerI:
  assumes \<open>register F\<close> \<open>register G\<close> \<open>F o G = id\<close> \<open>G o F = id\<close>
  shows \<open>iso_register F\<close>
  using assms(1) assms(2) assms(3) assms(4) iso_register_def by blast

lemma iso_register_inv: \<open>iso_register F \<Longrightarrow> iso_register (inv F)\<close>
  by (metis inv_unique_comp iso_register_def)

lemma iso_register_inv_comp1: \<open>iso_register F \<Longrightarrow> inv F o F = id\<close>
  using inv_unique_comp iso_register_def by blast

lemma iso_register_inv_comp2: \<open>iso_register F \<Longrightarrow> F o inv F = id\<close>
  using inv_unique_comp iso_register_def by blast

lemma iso_register_id[simp]: \<open>iso_register id\<close>
  by (simp add: iso_register_def)

lemma iso_register_is_register: \<open>iso_register F \<Longrightarrow> register F\<close>
  using iso_register_def by blast

lemma iso_register_comp[simp]:
  assumes [simp]: \<open>iso_register F\<close> \<open>iso_register G\<close>
  shows \<open>iso_register (F o G)\<close>
proof -
  from assms obtain F' G' where [simp]: \<open>register F'\<close> \<open>register G'\<close> \<open>F o F' = id\<close> \<open>F' o F = id\<close>
    \<open>G o G' = id\<close> \<open>G' o G = id\<close>
    by (meson iso_register_def)
  show ?thesis
    apply (rule iso_registerI[where G=\<open>G' o F'\<close>])
       apply (auto simp: register_tensor_is_register iso_register_is_register register_tensor_distrib)
     apply (metis \<open>F \<circ> F' = id\<close> \<open>G \<circ> G' = id\<close> fcomp_assoc fcomp_comp id_fcomp)
    by (metis (no_types, lifting) \<open>F \<circ> F' = id\<close> \<open>F' \<circ> F = id\<close> \<open>G' \<circ> G = id\<close> fun.map_comp inj_iff inv_unique_comp o_inv_o_cancel)
qed

lemma iso_register_tensor_is_iso_register[simp]:
  assumes [simp]: \<open>iso_register F\<close> \<open>iso_register G\<close>
  shows \<open>iso_register (F \<otimes>\<^sub>r G)\<close>
proof -
  from assms obtain F' G' where [simp]: \<open>register F'\<close> \<open>register G'\<close> \<open>F o F' = id\<close> \<open>F' o F = id\<close>
    \<open>G o G' = id\<close> \<open>G' o G = id\<close>
    by (meson iso_register_def)
  show ?thesis
    apply (rule iso_registerI[where G=\<open>F' \<otimes>\<^sub>r G'\<close>])
    by (auto simp: register_tensor_is_register iso_register_is_register register_tensor_distrib)
qed

lemma iso_register_bij: \<open>iso_register F \<Longrightarrow> bij F\<close>
  using iso_register_def o_bij by auto

lemma inv_register_tensor[simp]:
  assumes [simp]: \<open>iso_register F\<close> \<open>iso_register G\<close>
  shows \<open>inv (F \<otimes>\<^sub>r G) = inv F \<otimes>\<^sub>r inv G\<close>
  apply (auto intro!: inj_imp_inv_eq bij_is_inj iso_register_bij
              simp: register_tensor_distrib[unfolded o_def, THEN fun_cong] iso_register_is_register
                    iso_register_inv bij_is_surj iso_register_bij surj_f_inv_f)
  by (metis eq_id_iff register_tensor_id)

lemma iso_register_swap[simp]: \<open>iso_register swap\<close>
  apply (rule iso_registerI[of _ swap])
  by auto

lemma iso_register_assoc[simp]: \<open>iso_register assoc\<close>
  apply (rule iso_registerI[of _ assoc'])
  by auto

lemma iso_register_assoc'[simp]: \<open>iso_register assoc'\<close>
  apply (rule iso_registerI[of _ assoc])
  by auto

definition \<open>equivalent_registers F G \<longleftrightarrow> (register F \<and> (\<exists>I. iso_register I \<and> F o I = G))\<close>
  for F G :: \<open>_::finite update \<Rightarrow> _::finite update\<close>

lemma iso_register_equivalent_id[simp]: \<open>equivalent_registers id F \<longleftrightarrow> iso_register F\<close>
  by (simp add: equivalent_registers_def)

lemma equivalent_registersI:
  assumes \<open>register F\<close>
  assumes \<open>iso_register I\<close>
  assumes \<open>F o I = G\<close>
  shows \<open>equivalent_registers F G\<close>
  using assms unfolding equivalent_registers_def by blast

lemma equivalent_registers_register_left: \<open>equivalent_registers F G \<Longrightarrow> register F\<close>
  using equivalent_registers_def by auto

lemma equivalent_registers_register_right: \<open>register G\<close> if \<open>equivalent_registers F G\<close>
  by (metis equivalent_registers_def iso_register_def register_comp that)

lemma equivalent_registers_sym:
  assumes \<open>equivalent_registers F G\<close>
  shows \<open>equivalent_registers G F\<close>
  by (smt (verit) assms comp_id equivalent_registers_def equivalent_registers_register_right fun.map_comp iso_register_def)

lemma equivalent_registers_trans[trans]:
  assumes \<open>equivalent_registers F G\<close> and \<open>equivalent_registers G H\<close>
  shows \<open>equivalent_registers F H\<close>
proof -
  from assms have [simp]: \<open>register F\<close> \<open>register G\<close>
    by (auto simp: equivalent_registers_def)
  from assms(1) obtain I where [simp]: \<open>iso_register I\<close> and \<open>F o I = G\<close>
    using equivalent_registers_def by blast
  from assms(2) obtain J where [simp]: \<open>iso_register J\<close> and \<open>G o J = H\<close>
    using equivalent_registers_def by blast
  have \<open>register F\<close>
    by (auto simp: equivalent_registers_def)
  moreover have \<open>iso_register (I o J)\<close>
    using \<open>iso_register I\<close> \<open>iso_register J\<close> iso_register_comp by blast
  moreover have \<open>F o (I o J) = H\<close>
    by (simp add: \<open>F \<circ> I = G\<close> \<open>G \<circ> J = H\<close> o_assoc)
  ultimately show ?thesis
    by (rule equivalent_registersI)
qed

lemma equivalent_registers_assoc[simp]:
  assumes [simp]: \<open>compatible F G\<close> \<open>compatible F H\<close> \<open>compatible G H\<close>
  shows \<open>equivalent_registers (F;(G;H)) ((F;G);H)\<close>
  apply (rule equivalent_registersI[where I=assoc])
  by auto

lemma equivalent_registers_pair_right:
  assumes [simp]: \<open>compatible F G\<close>
  assumes eq: \<open>equivalent_registers G H\<close>
  shows \<open>equivalent_registers (F;G) (F;H)\<close>
proof -
  from eq obtain I where [simp]: \<open>iso_register I\<close> and \<open>G o I = H\<close>
    by (metis equivalent_registers_def)
  then have *: \<open>(F;G) \<circ> (id \<otimes>\<^sub>r I) = (F;H)\<close>
    by (auto intro!: tensor_extensionality register_comp register_preregister register_tensor_is_register
        simp:  register_pair_apply iso_register_is_register)
  show ?thesis
    apply (rule equivalent_registersI[where I=\<open>id \<otimes>\<^sub>r I\<close>])
    using * by (auto intro!: iso_register_tensor_is_iso_register)
qed

lemma equivalent_registers_pair_left:
  assumes [simp]: \<open>compatible F G\<close>
  assumes eq: \<open>equivalent_registers F H\<close>
  shows \<open>equivalent_registers (F;G) (H;G)\<close>
proof -
  from eq obtain I where [simp]: \<open>iso_register I\<close> and \<open>F o I = H\<close>
    by (metis equivalent_registers_def)
  then have *: \<open>(F;G) \<circ> (I \<otimes>\<^sub>r id) = (H;G)\<close>
    by (auto intro!: tensor_extensionality register_comp register_preregister register_tensor_is_register
        simp:  register_pair_apply iso_register_is_register)
  show ?thesis
    apply (rule equivalent_registersI[where I=\<open>I \<otimes>\<^sub>r id\<close>])
    using * by (auto intro!: iso_register_tensor_is_iso_register)
qed

lemma equivalent_registers_comp:
  assumes \<open>register H\<close>
  assumes \<open>equivalent_registers F G\<close>
  shows \<open>equivalent_registers (H o F) (H o G)\<close>
  by (metis (no_types, lifting) assms(1) assms(2) comp_assoc equivalent_registers_def register_comp)

subsection \<open>Compatibility simplification\<close>

text \<open>The simproc \<open>compatibility_warn\<close> produces helpful warnings for subgoals of the form
   \<^term>\<open>compatible x y\<close> that are probably unsolvable due to missing declarations of
   variable compatibility facts. Same for subgoals of the form \<^term>\<open>register x\<close>.\<close>
simproc_setup "compatibility_warn" ("compatible x y" | "register x") = \<open>
let val thy_string = Markup.markup (Theory.get_markup \<^theory>) (Context.theory_name \<^theory>)
in
fn m => fn ctxt => fn ct => let
  val (x,y) = case Thm.term_of ct of
                 Const(\<^const_name>\<open>compatible\<close>,_ ) $ x $ y => (x, SOME y)
               | Const(\<^const_name>\<open>register\<close>,_ ) $ x => (x, NONE)
  val str : string lazy = Lazy.lazy (fn () => Syntax.string_of_term ctxt (Thm.term_of ct))
  fun w msg = warning (msg ^ "\n(Disable these warnings with: using [[simproc del: "^thy_string^".compatibility_warn]])")
  val _ = case (x,y) of
        (Free(n,T), SOME (Free(n',T'))) =>
            if String.isPrefix ":" n orelse String.isPrefix ":" n' then
                      w ("Simplification subgoal " ^ Lazy.force str ^ " contains a bound variable.\n" ^
                      "Try to add some assumptions that makes this goal solvable by the simplifier")
            else if n=n' then (if T=T' then ()
                          else w ("In simplification subgoal " ^ Lazy.force str ^
                               ", variables have same name and different types.\n" ^
                               "Probably something is wrong."))
                    else w ("Simplification subgoal " ^ Lazy.force str ^
                            " occurred but cannot be solved.\n" ^
                            "Please add assumption/fact  [simp]: \<open>" ^ Lazy.force str ^
                            "\<close>  somewhere.")
      | (Free(n,T), NONE) =>
            if String.isPrefix ":" n then
                      w ("Simplification subgoal '" ^ Lazy.force str ^ "' contains a bound variable.\n" ^
                      "Try to add some assumptions that makes this goal solvable by the simplifier")
            else w ("Simplification subgoal " ^ Lazy.force str ^ " occurred but cannot be solved.\n" ^
                    "Please add assumption/fact  [simp]: \<open>" ^ Lazy.force str ^ "\<close>  somewhere.")
      | _ => ()
  in NONE end
end\<close>

named_theorems register_attribute_rule_immediate
named_theorems register_attribute_rule

lemmas [register_attribute_rule] = conjunct1 conjunct2 iso_register_is_register iso_register_is_register[OF iso_register_inv]
lemmas [register_attribute_rule_immediate] = compatible_sym compatible_register1 compatible_register2
  asm_rl[of \<open>compatible _ _\<close>] asm_rl[of \<open>iso_register _\<close>] asm_rl[of \<open>register _\<close>] iso_register_inv

text \<open>The following declares an attribute \<open>[register]\<close>. When the attribute is applied to a fact
  of the form \<^term>\<open>register F\<close>, \<^term>\<open>iso_register F\<close>, \<^term>\<open>compatible F G\<close> or a conjunction of these,
  then those facts are added to the simplifier together with some derived theorems
  (e.g., \<^term>\<open>compatible F G\<close> also adds \<^term>\<open>register F\<close>).

  In theory \<open>Laws_Complement\<close>, support for \<^term>\<open>is_unit_register F\<close> and \<^term>\<open>complements F G\<close> is
  added to this attribute.\<close>

setup \<open>
let
fun add thm results =
  Net.insert_term (K true) (Thm.concl_of thm, thm) results
  handle Net.INSERT => results
fun try_rule f thm rule state = case SOME (rule OF [thm]) handle THM _ => NONE  of
  NONE => state | SOME th => f th state
fun collect (rules,rules_immediate) thm results =
  results |> fold (try_rule add thm) rules_immediate |> fold (try_rule (collect (rules,rules_immediate)) thm) rules
fun declare thm context = let
  val ctxt = Context.proof_of context
  val rules = Named_Theorems.get ctxt @{named_theorems register_attribute_rule}
  val rules_immediate = Named_Theorems.get ctxt @{named_theorems register_attribute_rule_immediate}
  val thms = collect (rules,rules_immediate) thm Net.empty |> Net.entries
  (* val _ = \<^print> thms *)
  in Simplifier.map_ss (fn ctxt => ctxt addsimps thms) context end
in
Attrib.setup \<^binding>\<open>register\<close>
 (Scan.succeed (Thm.declaration_attribute declare))
  "Add register-related rules to the simplifier"
end
\<close>

subsection \<open>Notation\<close>

no_notation cblinfun_compose (infixl "*\<^sub>u" 55)
no_notation tensor_op (infixr "\<otimes>\<^sub>u" 70)

bundle register_notation begin
notation register_tensor (infixr "\<otimes>\<^sub>r" 70)
notation register_pair ("'(_;_')")
end

bundle no_register_notation begin
no_notation register_tensor (infixr "\<otimes>\<^sub>r" 70)
no_notation register_pair ("'(_;_')")
end

end


theory Introduction
imports Setup
begin

section {* Introduction *}

text {*
  This tutorial introduces the code generator facilities of @{text
  "Isabelle/HOL"}.  It allows to turn (a certain class of) HOL
  specifications into corresponding executable code in the programming
  languages @{text SML} @{cite SML}, @{text OCaml} @{cite OCaml},
  @{text Haskell} @{cite "haskell-revised-report"} and @{text Scala}
  @{cite "scala-overview-tech-report"}.

  To profit from this tutorial, some familiarity and experience with
  @{theory HOL} @{cite "isa-tutorial"} and its basic theories is assumed.
*}

subsection {* Code generation principle: shallow embedding \label{sec:principle} *}

text {*
  The key concept for understanding Isabelle's code generation is
  \emph{shallow embedding}: logical entities like constants, types and
  classes are identified with corresponding entities in the target
  language.  In particular, the carrier of a generated program's
  semantics are \emph{equational theorems} from the logic.  If we view
  a generated program as an implementation of a higher-order rewrite
  system, then every rewrite step performed by the program can be
  simulated in the logic, which guarantees partial correctness
  @{cite "Haftmann-Nipkow:2010:code"}.
*}

subsection {* A quick start with the Isabelle/HOL toolbox \label{sec:queue_example} *}

text {*
  In a HOL theory, the @{command_def datatype} and @{command_def
  definition}/@{command_def primrec}/@{command_def fun} declarations
  form the core of a functional programming language.  By default
  equational theorems stemming from those are used for generated code,
  therefore \qt{naive} code generation can proceed without further
  ado.

  For example, here a simple \qt{implementation} of amortised queues:
*}

datatype %quote 'a queue = AQueue "'a list" "'a list"

definition %quote empty :: "'a queue" where
  "empty = AQueue [] []"

primrec %quote enqueue :: "'a \<Rightarrow> 'a queue \<Rightarrow> 'a queue" where
  "enqueue x (AQueue xs ys) = AQueue (x # xs) ys"

fun %quote dequeue :: "'a queue \<Rightarrow> 'a option \<times> 'a queue" where
    "dequeue (AQueue [] []) = (None, AQueue [] [])"
  | "dequeue (AQueue xs (y # ys)) = (Some y, AQueue xs ys)"
  | "dequeue (AQueue xs []) =
      (case rev xs of y # ys \<Rightarrow> (Some y, AQueue [] ys))" (*<*)

lemma %invisible dequeue_nonempty_Nil [simp]:
  "xs \<noteq> [] \<Longrightarrow> dequeue (AQueue xs []) = (case rev xs of y # ys \<Rightarrow> (Some y, AQueue [] ys))"
  by (cases xs) (simp_all split: list.splits) (*>*)

text {* \noindent Then we can generate code e.g.~for @{text SML} as follows: *}

export_code %quote empty dequeue enqueue in SML
  module_name Example file "examples/example.ML"

text {* \noindent resulting in the following code: *}

text %quotetypewriter {*
  @{code_stmts empty enqueue dequeue (SML)}
*}

text {*
  \noindent The @{command_def export_code} command takes a
  space-separated list of constants for which code shall be generated;
  anything else needed for those is added implicitly.  Then follows a
  target language identifier and a freely chosen module name.  A file
  name denotes the destination to store the generated code.  Note that
  the semantics of the destination depends on the target language: for
  @{text SML}, @{text OCaml} and @{text Scala} it denotes a \emph{file},
  for @{text Haskell} it denotes a \emph{directory} where a file named as the
  module name (with extension @{text ".hs"}) is written:
*}

export_code %quote empty dequeue enqueue in Haskell
  module_name Example file "examples/"

text {*
  \noindent This is the corresponding code:
*}

text %quotetypewriter {*
  @{code_stmts empty enqueue dequeue (Haskell)}
*}

text {*
  \noindent For more details about @{command export_code} see
  \secref{sec:further}.
*}

subsection {* Type classes *}

text {*
  Code can also be generated from type classes in a Haskell-like
  manner.  For illustration here an example from abstract algebra:
*}

class %quote semigroup =
  fixes mult :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<otimes>" 70)
  assumes assoc: "(x \<otimes> y) \<otimes> z = x \<otimes> (y \<otimes> z)"

class %quote monoid = semigroup +
  fixes neutral :: 'a ("\<one>")
  assumes neutl: "\<one> \<otimes> x = x"
    and neutr: "x \<otimes> \<one> = x"

instantiation %quote nat :: monoid
begin

primrec %quote mult_nat where
    "0 \<otimes> n = (0\<Colon>nat)"
  | "Suc m \<otimes> n = n + m \<otimes> n"

definition %quote neutral_nat where
  "\<one> = Suc 0"

lemma %quote add_mult_distrib:
  fixes n m q :: nat
  shows "(n + m) \<otimes> q = n \<otimes> q + m \<otimes> q"
  by (induct n) simp_all

instance %quote proof
  fix m n q :: nat
  show "m \<otimes> n \<otimes> q = m \<otimes> (n \<otimes> q)"
    by (induct m) (simp_all add: add_mult_distrib)
  show "\<one> \<otimes> n = n"
    by (simp add: neutral_nat_def)
  show "m \<otimes> \<one> = m"
    by (induct m) (simp_all add: neutral_nat_def)
qed

end %quote

text {*
  \noindent We define the natural operation of the natural numbers
  on monoids:
*}

primrec %quote (in monoid) pow :: "nat \<Rightarrow> 'a \<Rightarrow> 'a" where
    "pow 0 a = \<one>"
  | "pow (Suc n) a = a \<otimes> pow n a"

text {*
  \noindent This we use to define the discrete exponentiation
  function:
*}

definition %quote bexp :: "nat \<Rightarrow> nat" where
  "bexp n = pow n (Suc (Suc 0))"

text {*
  \noindent The corresponding code in Haskell uses that language's
  native classes:
*}

text %quotetypewriter {*
  @{code_stmts bexp (Haskell)}
*}

text {*
  \noindent This is a convenient place to show how explicit dictionary
  construction manifests in generated code -- the same example in
  @{text SML}:
*}

text %quotetypewriter {*
  @{code_stmts bexp (SML)}
*}

text {*
  \noindent Note the parameters with trailing underscore (@{verbatim
  "A_"}), which are the dictionary parameters.
*}

subsection {* How to continue from here *}

text {*
  What you have seen so far should be already enough in a lot of
  cases.  If you are content with this, you can quit reading here.

  Anyway, to understand situations where problems occur or to increase
  the scope of code generation beyond default, it is necessary to gain
  some understanding how the code generator actually works:

  \begin{itemize}

    \item The foundations of the code generator are described in
      \secref{sec:foundations}.

    \item In particular \secref{sec:utterly_wrong} gives hints how to
      debug situations where code generation does not succeed as
      expected.

    \item The scope and quality of generated code can be increased
      dramatically by applying refinement techniques, which are
      introduced in \secref{sec:refinement}.

    \item Inductive predicates can be turned executable using an
      extension of the code generator \secref{sec:inductive}.

    \item If you want to utilize code generation to obtain fast
      evaluators e.g.~for decision procedures, have a look at
      \secref{sec:evaluation}.

    \item You may want to skim over the more technical sections
      \secref{sec:adaptation} and \secref{sec:further}.

    \item The target language Scala @{cite "scala-overview-tech-report"}
      comes with some specialities discussed in \secref{sec:scala}.

    \item For exhaustive syntax diagrams etc. you should visit the
      Isabelle/Isar Reference Manual @{cite "isabelle-isar-ref"}.

  \end{itemize}

  \bigskip

  \begin{center}\fbox{\fbox{\begin{minipage}{8cm}

    \begin{center}\textit{Happy proving, happy hacking!}\end{center}

  \end{minipage}}}\end{center}
*}

end


(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection \<open>Record Based Version\<close>

text \<open>We provide an implementation for polynomials which may be parametrized
  by the ring- or field-operations. These don't have to be type-based!\<close>

subsubsection \<open>Definitions\<close>

theory Polynomial_Record_Based
imports
  Arithmetic_Record_Based
  Karatsuba_Multiplication
begin

context
  fixes ops :: "'i arith_ops_record" (structure)
begin
private abbreviation (input) zero where "zero \<equiv> arith_ops_record.zero ops"
private abbreviation (input) one where "one \<equiv> arith_ops_record.one ops"
private abbreviation (input) plus where "plus \<equiv> arith_ops_record.plus ops"
private abbreviation (input) times where "times \<equiv> arith_ops_record.times ops"
private abbreviation (input) minus where "minus \<equiv> arith_ops_record.minus ops"
private abbreviation (input) uminus where "uminus \<equiv> arith_ops_record.uminus ops"
private abbreviation (input) divide where "divide \<equiv> arith_ops_record.divide ops"
private abbreviation (input) inverse where "inverse \<equiv> arith_ops_record.inverse ops"
private abbreviation (input) modulo where "modulo \<equiv> arith_ops_record.modulo ops"
private abbreviation (input) normalize where "normalize \<equiv> arith_ops_record.normalize ops"
private abbreviation (input) unit_factor where "unit_factor \<equiv> arith_ops_record.unit_factor ops"
private abbreviation (input) DP where "DP \<equiv> arith_ops_record.DP ops"

definition is_poly :: "'i list \<Rightarrow> bool" where
  "is_poly xs \<longleftrightarrow> list_all DP xs \<and> no_trailing (HOL.eq zero) xs"

definition cCons_i :: "'i \<Rightarrow> 'i list \<Rightarrow> 'i list"
where
  "cCons_i x xs = (if xs = [] \<and> x = zero then [] else x # xs)"

fun plus_poly_i :: "'i list \<Rightarrow> 'i list \<Rightarrow> 'i list" where
  "plus_poly_i (x # xs) (y # ys) = cCons_i (plus x y) (plus_poly_i xs ys)"
| "plus_poly_i xs [] = xs"
| "plus_poly_i [] ys = ys"

definition uminus_poly_i :: "'i list \<Rightarrow> 'i list" where
  [code_unfold]: "uminus_poly_i = map uminus"

fun minus_poly_i :: "'i list \<Rightarrow> 'i list \<Rightarrow> 'i list" where
  "minus_poly_i (x # xs) (y # ys) = cCons_i (minus x y) (minus_poly_i xs ys)"
| "minus_poly_i xs [] = xs"
| "minus_poly_i [] ys = uminus_poly_i ys"

abbreviation (input) zero_poly_i :: "'i list" where
  "zero_poly_i \<equiv> []"

definition one_poly_i :: "'i list" where
  [code_unfold]: "one_poly_i = [one]"

definition smult_i :: "'i \<Rightarrow> 'i list \<Rightarrow> 'i list" where
  "smult_i a pp = (if a = zero then [] else strip_while ((=) zero) (map (times a) pp))"

definition sdiv_i :: "'i list \<Rightarrow> 'i \<Rightarrow> 'i list" where
  "sdiv_i pp a = (strip_while ((=) zero) (map (\<lambda> c. divide c a) pp))"

definition poly_of_list_i :: "'i list \<Rightarrow> 'i list" where
  "poly_of_list_i = strip_while ((=) zero)"

fun coeffs_minus_i :: "'i list \<Rightarrow> 'i list \<Rightarrow> 'i list" where
  "coeffs_minus_i (x # xs) (y # ys) = (minus x y # coeffs_minus_i xs ys)"
| "coeffs_minus_i xs [] = xs"
| "coeffs_minus_i [] ys = map uminus ys"

definition monom_mult_i :: "nat \<Rightarrow> 'i list \<Rightarrow> 'i list" where
  "monom_mult_i n xs = (if xs = [] then xs else replicate n zero @ xs)"

fun karatsuba_main_i :: "'i list \<Rightarrow> nat \<Rightarrow> 'i list \<Rightarrow> nat \<Rightarrow> 'i list" where
  "karatsuba_main_i f n g m = (if n \<le> karatsuba_lower_bound \<or> m \<le> karatsuba_lower_bound then
   let ff = poly_of_list_i f in foldr (\<lambda>a p. plus_poly_i (smult_i a ff) (cCons_i zero p)) g zero_poly_i
   else let n2 = n div 2 in
   if m > n2 then (case split_at n2 f of
   (f0,f1) \<Rightarrow> case split_at n2 g of
   (g0,g1) \<Rightarrow> let
      p1 = karatsuba_main_i f1 (n - n2) g1 (m - n2);
      p2 = karatsuba_main_i (coeffs_minus_i f1 f0) n2 (coeffs_minus_i g1 g0) n2;
      p3 = karatsuba_main_i f0 n2 g0 n2
      in plus_poly_i (monom_mult_i (n2 + n2) p1)
        (plus_poly_i (monom_mult_i n2 (plus_poly_i (minus_poly_i p1 p2) p3)) p3))
    else case split_at n2 f of
    (f0,f1) \<Rightarrow> let
       p1 = karatsuba_main_i f1 (n - n2) g m;
       p2 = karatsuba_main_i f0 n2 g m
     in plus_poly_i (monom_mult_i n2 p1) p2)"

definition times_poly_i :: "'i list \<Rightarrow> 'i list \<Rightarrow> 'i list" where
  "times_poly_i f g \<equiv> (let n = length f; m = length g
    in (if n \<le> karatsuba_lower_bound \<or> m \<le> karatsuba_lower_bound then if n \<le> m then
      foldr (\<lambda>a p. plus_poly_i (smult_i a g) (cCons_i zero p)) f zero_poly_i else
      foldr (\<lambda>a p. plus_poly_i (smult_i a f) (cCons_i zero p)) g zero_poly_i else
      if n \<le> m then karatsuba_main_i g m f n else karatsuba_main_i f n g m))"

definition coeff_i :: "'i list \<Rightarrow> nat \<Rightarrow> 'i" where
  "coeff_i = nth_default zero"

definition degree_i :: "'i list \<Rightarrow> nat" where
  "degree_i pp \<equiv> length pp - 1"

definition lead_coeff_i :: "'i list \<Rightarrow> 'i" where
  "lead_coeff_i pp = (case pp of [] \<Rightarrow> zero | _ \<Rightarrow> last pp)"

definition monic_i :: "'i list \<Rightarrow> bool" where
  "monic_i pp = (lead_coeff_i pp = one)"

fun minus_poly_rev_list_i :: "'i list \<Rightarrow> 'i list \<Rightarrow> 'i list" where
  "minus_poly_rev_list_i (x # xs) (y # ys) = (minus x y) # (minus_poly_rev_list_i xs ys)"
| "minus_poly_rev_list_i xs [] = xs"
| "minus_poly_rev_list_i [] (y # ys) = []"

fun divmod_poly_one_main_i :: "'i list \<Rightarrow> 'i list \<Rightarrow> 'i list
  \<Rightarrow> nat \<Rightarrow> 'i list \<times> 'i list" where
  "divmod_poly_one_main_i q r d (Suc n) = (let
     a = hd r;
     qqq = cCons_i a q;
     rr = tl (if a = zero then r else minus_poly_rev_list_i r (map (times a) d))
     in divmod_poly_one_main_i qqq rr d n)"
| "divmod_poly_one_main_i q r d 0 = (q,r)"

fun mod_poly_one_main_i :: "'i list \<Rightarrow> 'i list
  \<Rightarrow> nat \<Rightarrow> 'i list" where
  "mod_poly_one_main_i r d (Suc n) = (let
     a = hd r;
     rr = tl (if a = zero then r else minus_poly_rev_list_i r (map (times a) d))
     in mod_poly_one_main_i rr d n)"
| "mod_poly_one_main_i r d 0 = r"

definition pdivmod_monic_i :: "'i list \<Rightarrow> 'i list \<Rightarrow> 'i list \<times> 'i list" where
  "pdivmod_monic_i cf cg \<equiv> case
     divmod_poly_one_main_i [] (rev cf) (rev cg) (1 + length cf - length cg)
     of (q,r) \<Rightarrow> (poly_of_list_i q, poly_of_list_i (rev r))"

definition dupe_monic_i :: "'i list \<Rightarrow> 'i list \<Rightarrow> 'i list \<Rightarrow> 'i list \<Rightarrow> 'i list \<Rightarrow> 'i list \<times> 'i list" where
  "dupe_monic_i D H S T U = (case pdivmod_monic_i (times_poly_i T U) D of (Q,R) \<Rightarrow>
     (plus_poly_i (times_poly_i S U) (times_poly_i H Q), R))"

definition of_int_poly_i :: "int poly \<Rightarrow> 'i list" where
  "of_int_poly_i f = map (arith_ops_record.of_int ops) (coeffs f)"

definition to_int_poly_i :: "'i list \<Rightarrow> int poly" where
  "to_int_poly_i f = poly_of_list (map (arith_ops_record.to_int ops) f)"

definition dupe_monic_i_int :: "int poly \<Rightarrow> int poly \<Rightarrow> int poly \<Rightarrow> int poly \<Rightarrow> int poly \<Rightarrow> int poly \<times> int poly" where
  "dupe_monic_i_int D H S T = (let
      d = of_int_poly_i D;
      h = of_int_poly_i H;
      s = of_int_poly_i S;
      t = of_int_poly_i T
    in (\<lambda> U. case dupe_monic_i d h s t (of_int_poly_i U) of
       (D',H') \<Rightarrow> (to_int_poly_i D', to_int_poly_i H')))"

definition div_field_poly_i :: "'i list \<Rightarrow> 'i list \<Rightarrow> 'i list" where
  "div_field_poly_i cf cg = (
      if cg = [] then zero_poly_i
        else let ilc = inverse (last cg); ch = map (times ilc) cg;
                 q = fst (divmod_poly_one_main_i [] (rev cf) (rev ch) (1 + length cf - length cg))
             in poly_of_list_i ((map (times ilc) q)))"

definition mod_field_poly_i :: "'i list \<Rightarrow> 'i list \<Rightarrow> 'i list" where
  "mod_field_poly_i cf cg = (
      if cg = [] then cf
        else let ilc = inverse (last cg); ch = map (times ilc) cg;
                 r = mod_poly_one_main_i (rev cf) (rev ch) (1 + length cf - length cg)
             in poly_of_list_i (rev r))"

definition normalize_poly_i :: "'i list \<Rightarrow> 'i list" where
  "normalize_poly_i xs = smult_i (inverse (unit_factor (lead_coeff_i xs))) xs"

definition unit_factor_poly_i :: "'i list \<Rightarrow> 'i list" where
  "unit_factor_poly_i xs = cCons_i (unit_factor (lead_coeff_i xs)) []"

fun pderiv_main_i :: "'i \<Rightarrow> 'i list \<Rightarrow> 'i list" where
  "pderiv_main_i f (x # xs) = cCons_i (times f x) (pderiv_main_i (plus f one) xs)"
| "pderiv_main_i f [] = []"

definition pderiv_i :: "'i list \<Rightarrow> 'i list" where
  "pderiv_i xs = pderiv_main_i one (tl xs)"

definition dvd_poly_i :: "'i list \<Rightarrow> 'i list \<Rightarrow> bool" where
  "dvd_poly_i xs ys = (\<exists> zs. is_poly zs \<and> ys = times_poly_i xs zs)"

definition irreducible_i :: "'i list \<Rightarrow> bool" where
  "irreducible_i xs = (degree_i xs \<noteq> 0 \<and>
  (\<forall>q r. is_poly q \<longrightarrow> is_poly r \<longrightarrow> degree_i q < degree_i xs \<longrightarrow> degree_i r < degree_i xs
    \<longrightarrow> xs \<noteq> times_poly_i q r))"

definition poly_ops :: "'i list arith_ops_record" where
  "poly_ops \<equiv> Arith_Ops_Record
      zero_poly_i
      one_poly_i
      plus_poly_i
      times_poly_i
      minus_poly_i
      uminus_poly_i
      div_field_poly_i
      (\<lambda> _. []) \<comment> \<open>not defined\<close>
      mod_field_poly_i
      normalize_poly_i
      unit_factor_poly_i
      (\<lambda> i. if i = 0 then [] else [arith_ops_record.of_int ops i])
      (\<lambda> _. 0) \<comment> \<open>not defined\<close>
      is_poly"

definition gcd_poly_i :: "'i list \<Rightarrow> 'i list \<Rightarrow> 'i list" where
  "gcd_poly_i = arith_ops.gcd_eucl_i poly_ops"

definition euclid_ext_poly_i :: "'i list \<Rightarrow> 'i list \<Rightarrow> ('i list \<times> 'i list) \<times> 'i list" where
  "euclid_ext_poly_i = arith_ops.euclid_ext_i poly_ops"

definition separable_i :: "'i list \<Rightarrow> bool" where
  "separable_i xs \<equiv> gcd_poly_i xs (pderiv_i xs) = one_poly_i"

end

(* **************************************************************************** *)
subsubsection \<open>Properties\<close>

definition pdivmod_monic :: "'a::comm_ring_1 poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly \<times> 'a poly" where
  "pdivmod_monic f g \<equiv> let cg = coeffs g; cf = coeffs f;
     (q, r) = divmod_poly_one_main_list [] (rev cf) (rev cg) (1 + length cf - length cg)
         in (poly_of_list q, poly_of_list (rev r))"

lemma coeffs_smult': "coeffs (smult a p) = (if a = 0 then [] else strip_while ((=) 0) (map (Groups.times a) (coeffs p)))"
   by (simp add: coeffs_map_poly smult_conv_map_poly)

lemma coeffs_sdiv: "coeffs (sdiv_poly p a) = (strip_while ((=) 0) (map (\<lambda> x. x div a) (coeffs p)))"
  unfolding sdiv_poly_def by (rule coeffs_map_poly)

lifting_forget poly.lifting

context ring_ops
begin

definition poly_rel :: "'i list \<Rightarrow> 'a poly \<Rightarrow> bool" where
  "poly_rel x x' \<longleftrightarrow> list_all2 R x (coeffs x')"

lemma right_total_poly_rel[transfer_rule]:
  "right_total poly_rel"
  using list.right_total_rel[of R] right_total unfolding poly_rel_def right_total_def by auto

lemma poly_rel_inj: "poly_rel x y \<Longrightarrow> poly_rel x z \<Longrightarrow> y = z"
  using list.bi_unique_rel[OF bi_unique] unfolding poly_rel_def coeffs_eq_iff bi_unique_def by auto

lemma bi_unique_poly_rel[transfer_rule]: "bi_unique poly_rel"
  using list.bi_unique_rel[OF bi_unique] unfolding poly_rel_def bi_unique_def coeffs_eq_iff by auto

lemma Domainp_is_poly [transfer_domain_rule]:
  "Domainp poly_rel = is_poly ops"
unfolding poly_rel_def [abs_def] is_poly_def [abs_def]
proof (intro ext iffI, unfold Domainp_iff)
  note DPR = fun_cong [OF list.Domainp_rel [of R, unfolded DPR],
    unfolded Domainp_iff]
  let ?no_trailing = "no_trailing (HOL.eq zero)"
  fix xs
  have no_trailing: "no_trailing (HOL.eq 0) xs' \<longleftrightarrow> ?no_trailing xs"
    if "list_all2 R xs xs'" for xs'
  proof (cases xs rule: rev_cases)
    case Nil
    with that show ?thesis
      by simp
  next
    case (snoc ys y)
    with that have "xs' \<noteq> []"
      by auto
    then obtain ys' y' where "xs' = ys' @ [y']"
      by (cases xs' rule: rev_cases) simp_all
    with that snoc show ?thesis
      by simp (meson bi_unique bi_unique_def zero)
  qed
  let ?DPR = "arith_ops_record.DP ops"
  {
    assume "\<exists>x'. list_all2 R xs (coeffs x')"
    then obtain xs' where *: "list_all2 R xs (coeffs xs')" by auto
    with DPR [of xs] have "list_all ?DPR xs" by auto
    then show "list_all ?DPR xs \<and> ?no_trailing xs"
      using no_trailing [OF *] by simp
  }
  {
    assume "list_all ?DPR xs \<and> ?no_trailing xs"
    with DPR [of xs] obtain xs' where *: "list_all2 R xs xs'" and "?no_trailing xs"
      by auto
    from no_trailing [OF *] this(2) have "no_trailing (HOL.eq 0) xs'"
      by simp
    hence "coeffs (poly_of_list xs') = xs'" unfolding poly_of_list_impl by auto
    with * show "\<exists>x'. list_all2 R xs (coeffs x')" by metis
  }
qed

(* zero *)
lemma poly_rel_zero[transfer_rule]: "poly_rel zero_poly_i 0"
  unfolding poly_rel_def by auto

(* one *)
lemma poly_rel_one[transfer_rule]: "poly_rel (one_poly_i ops) 1"
  unfolding poly_rel_def one_poly_i_def by (simp add: one)

(* cCons *)
lemma poly_rel_cCons[transfer_rule]: "(R ===> list_all2 R ===> list_all2 R) (cCons_i ops) cCons"
  unfolding cCons_i_def[abs_def] cCons_def[abs_def]
  by transfer_prover

(* pCons *)
lemma poly_rel_pCons[transfer_rule]: "(R ===> poly_rel ===> poly_rel) (cCons_i ops) pCons"
  unfolding rel_fun_def poly_rel_def coeffs_pCons_eq_cCons cCons_def[symmetric]
  using poly_rel_cCons[unfolded rel_fun_def] by auto

(* equality *)
lemma poly_rel_eq[transfer_rule]: "(poly_rel ===> poly_rel ===> (=)) (=) (=)"
  unfolding poly_rel_def[abs_def] coeffs_eq_iff[abs_def] rel_fun_def
  by (metis bi_unique bi_uniqueDl bi_uniqueDr list.bi_unique_rel)

(* addition *)

(* unary minus *)
lemma poly_rel_uminus[transfer_rule]: "(poly_rel ===> poly_rel) (uminus_poly_i ops) Groups.uminus"
proof (intro rel_funI)
  fix x y
  assume "poly_rel x y"
  hence [transfer_rule]: "list_all2 R x (coeffs y)" unfolding poly_rel_def .
  show "poly_rel (uminus_poly_i ops x) (-y)"
    unfolding poly_rel_def coeffs_uminus uminus_poly_i_def by transfer_prover
qed

(* subtraction *)
lemma poly_rel_minus[transfer_rule]: "(poly_rel ===> poly_rel ===> poly_rel) (minus_poly_i ops) (-)"
proof (intro rel_funI)
  fix x1 y1 x2 y2
  assume "poly_rel x1 x2" and "poly_rel y1 y2"
  thus "poly_rel (minus_poly_i ops x1 y1) (x2 - y2)"
    unfolding diff_conv_add_uminus
    unfolding poly_rel_def coeffs_eq_iff coeffs_plus_eq_plus_coeffs coeffs_uminus
  proof (induct x1 y1 arbitrary: x2 y2 rule: minus_poly_i.induct)
    case (1 x1 xs1 y1 ys1 X2 Y2)
    from 1(2) obtain x2 xs2 where X2: "coeffs X2 = x2 # coeffs xs2"
      by (cases X2, auto simp: cCons_def split: if_splits)
    from 1(3) obtain y2 ys2 where Y2: "coeffs Y2 = y2 # coeffs ys2"
      by (cases Y2, auto simp: cCons_def split: if_splits)
    from 1(2) 1(3) have [transfer_rule]: "R x1 x2" "R y1 y2"
      and *: "list_all2 R xs1 (coeffs xs2)" "list_all2 R ys1 (coeffs ys2)" unfolding X2 Y2 by auto
    note [transfer_rule] = 1(1)[OF *]
    show ?case unfolding X2 Y2 by simp transfer_prover
  next
    case (2 xs1 xs2 ys2)
    thus ?case by (cases "coeffs xs2", auto)
  next
    case (3 xs2 y1 ys1 Y2)
    from 3(1) have id0: "coeffs ys1 = coeffs 0" by (cases ys1, auto)
    have id1: "minus_poly_i ops [] (xs2 # y1) = uminus_poly_i ops (xs2 # y1)" by simp
    from 3(2) have [transfer_rule]: "poly_rel (xs2 # y1) Y2" unfolding poly_rel_def by simp
    show ?case unfolding id0 id1 coeffs_uminus[symmetric] coeffs_plus_eq_plus_coeffs[symmetric]
      poly_rel_def[symmetric] by simp transfer_prover
  qed
qed

(* smult *)
lemma poly_rel_smult[transfer_rule]: "(R ===> poly_rel ===> poly_rel) (smult_i ops) smult"
  unfolding rel_fun_def poly_rel_def coeffs_smult' smult_i_def
proof (intro allI impI, goal_cases)
  case (1 x y xs ys)
  note [transfer_rule] = 1
  show ?case by transfer_prover
qed

(* coeffs *)
lemma poly_rel_coeffs[transfer_rule]: "(poly_rel ===> list_all2 R) (\<lambda> x. x) coeffs"
  unfolding rel_fun_def poly_rel_def by auto

(* poly_of_list *)
lemma poly_rel_poly_of_list[transfer_rule]: "(list_all2 R ===> poly_rel) (poly_of_list_i ops) poly_of_list"
  unfolding rel_fun_def poly_of_list_i_def poly_rel_def poly_of_list_impl
proof (intro allI impI, goal_cases)
  case (1 x y)
  note [transfer_rule] = this
  show ?case by transfer_prover
qed

lemma poly_rel_monom_mult[transfer_rule]:
  "((=) ===> poly_rel ===> poly_rel) (monom_mult_i ops) monom_mult"
  unfolding rel_fun_def monom_mult_i_def poly_rel_def monom_mult_code Let_def
proof (auto, goal_cases)
  case (1 x xs y)
  show ?case by (induct x, auto simp: 1(3) zero)
qed

declare karatsuba_main_i.simps[simp del]

lemma list_rel_coeffs_minus_i: assumes "list_all2 R x1 x2" "list_all2 R y1 y2"
  shows "list_all2 R (coeffs_minus_i ops x1 y1) (coeffs_minus x2 y2)"
proof -
  note simps = coeffs_minus_i.simps coeffs_minus.simps
  show ?thesis using assms
  proof (induct x1 y1 arbitrary: x2 y2 rule: coeffs_minus_i.induct)
    case (1 x xs y ys)
    from 1(2-) obtain Y Ys where y2: "y2 = Y # Ys" unfolding list_all2_conv_all_nth by (cases y2, auto)
    with 1(2-) have y: "R y Y" "list_all2 R ys Ys" by auto
    from 1(2-) obtain X Xs where x2: "x2 = X # Xs" unfolding list_all2_conv_all_nth by (cases x2, auto)
    with 1(2-) have x: "R x X" "list_all2 R xs Xs" by auto
    from 1(1)[OF x(2) y(2)] x(1) y(1)
    show ?case unfolding x2 y2 simps using minus[unfolded rel_fun_def] by auto
  next
    case (3 y ys)
    from 3 have x2: "x2 = []" by auto
    from 3 obtain Y Ys where y2: "y2 = Y # Ys" unfolding list_all2_conv_all_nth by (cases y2, auto)
    obtain y1 where y1: "y # ys = y1" by auto
    show ?case unfolding y2 simps x2 unfolding y2[symmetric] list_all2_map2 list_all2_map1
      using 3(2) unfolding y1 using uminus[unfolded rel_fun_def]
      unfolding list_all2_conv_all_nth by auto
  qed auto
qed

(* multiplication *)
lemma poly_rel_karatsuba_main: "list_all2 R x1 x2 \<Longrightarrow> list_all2 R y1 y2 \<Longrightarrow>
  poly_rel (karatsuba_main_i ops x1 n y1 m) (karatsuba_main x2 n y2 m)"
proof (induct n arbitrary: x1 y1 x2 y2 m rule: less_induct)
  case (less n f g F G m)
  note simp[simp] = karatsuba_main.simps[of F n G m] karatsuba_main_i.simps[of ops f n g m]
  note IH = less(1)
  note rel[transfer_rule] = less(2-3)
  show ?case (is "poly_rel ?lhs ?rhs")
  proof (cases "(n \<le> karatsuba_lower_bound \<or> m \<le> karatsuba_lower_bound) = False")
    case False
    from False
    have lhs: "?lhs = foldr (\<lambda>a p. plus_poly_i ops (smult_i ops a (poly_of_list_i ops f))
         (cCons_i ops zero p)) g []" by simp
    from False have rhs: "?rhs = foldr (\<lambda>a p. smult a (poly_of_list F) + pCons 0 p) G 0" by simp
    show ?thesis unfolding lhs rhs by transfer_prover
  next
    case True note * = this
    let ?n2 = "n div 2"
    have "?n2 < n" "n - ?n2 < n" using True unfolding karatsuba_lower_bound_def by auto
    note IH = IH[OF this(1)] IH[OF this(2)]
    obtain f1 f0 where f: "split_at ?n2 f = (f0,f1)" by force
    obtain g1 g0 where g: "split_at ?n2 g = (g0,g1)" by force
    obtain F1 F0 where F: "split_at ?n2 F = (F0,F1)" by force
    obtain G1 G0 where G: "split_at ?n2 G = (G0,G1)" by force
    from rel f F have relf[transfer_rule]: "list_all2 R f0 F0" "list_all2 R f1 F1"
      unfolding split_at_def by auto
    from rel g G have relg[transfer_rule]: "list_all2 R g0 G0" "list_all2 R g1 G1"
      unfolding split_at_def by auto
    show ?thesis
    proof (cases "?n2 < m")
      case True
      obtain p1 P1 where p1: "p1 = karatsuba_main_i ops f1 (n - n div 2) g1 (m - n div 2)"
          "P1 = karatsuba_main F1 (n - n div 2) G1 (m - n div 2)" by auto
      obtain p2 P2 where p2: "p2 = karatsuba_main_i ops (coeffs_minus_i ops f1 f0) (n div 2)
                          (coeffs_minus_i ops g1 g0) (n div 2)"
          "P2 = karatsuba_main (coeffs_minus F1 F0) (n div 2)
                          (coeffs_minus G1 G0) (n div 2)" by auto
      obtain p3 P3 where p3: "p3 = karatsuba_main_i ops f0 (n div 2) g0 (n div 2)"
          "P3 = karatsuba_main F0 (n div 2) G0 (n div 2)" by auto
      from * True have lhs: "?lhs = plus_poly_i ops (monom_mult_i ops (n div 2 + n div 2) p1)
                (plus_poly_i ops
                  (monom_mult_i ops (n div 2)
                    (plus_poly_i ops (minus_poly_i ops p1 p2) p3)) p3)"
        unfolding simp Let_def f g split p1 p2 p3 by auto
      have [transfer_rule]: "poly_rel p1 P1" using IH(2)[OF relf(2) relg(2)] unfolding p1 .
      have [transfer_rule]: "poly_rel p3 P3" using IH(1)[OF relf(1) relg(1)] unfolding p3 .
      have [transfer_rule]: "poly_rel p2 P2" unfolding p2
        by (rule IH(1)[OF list_rel_coeffs_minus_i list_rel_coeffs_minus_i], insert relf relg)
      from True * have rhs: "?rhs = monom_mult (n div 2 + n div 2) P1 +
               (monom_mult (n div 2) (P1 - P2 + P3) + P3)"
        unfolding simp Let_def F G split p1 p2 p3 by auto
      show ?thesis unfolding lhs rhs by transfer_prover
    next
      case False
      obtain p1 P1 where p1: "p1 = karatsuba_main_i ops f1 (n - n div 2) g m"
          "P1 = karatsuba_main F1 (n - n div 2) G m" by auto
      obtain p2 P2 where p2: "p2 = karatsuba_main_i ops f0 (n div 2) g m"
          "P2 = karatsuba_main F0 (n div 2) G m" by auto
      from * False have lhs: "?lhs = plus_poly_i ops (monom_mult_i ops (n div 2) p1) p2"
        unfolding simp Let_def f split p1 p2 by auto
      from * False have rhs: "?rhs = monom_mult (n div 2) P1 + P2"
        unfolding simp Let_def F split p1 p2 by auto
      have [transfer_rule]: "poly_rel p1 P1" using IH(2)[OF relf(2) rel(2)] unfolding p1 .
      have [transfer_rule]: "poly_rel p2 P2" using IH(1)[OF relf(1) rel(2)] unfolding p2 .
      show ?thesis unfolding lhs rhs by transfer_prover
    qed
  qed
qed

lemma poly_rel_times[transfer_rule]: "(poly_rel ===> poly_rel ===> poly_rel) (times_poly_i ops) ((*))"
proof (intro rel_funI)
  fix x1 y1 x2 y2
  assume x12[transfer_rule]: "poly_rel x1 x2" and y12 [transfer_rule]: "poly_rel y1 y2"
  hence X12[transfer_rule]: "list_all2 R x1 (coeffs x2)" and Y12[transfer_rule]: "list_all2 R y1 (coeffs y2)"
    unfolding poly_rel_def by auto
  hence len: "length (coeffs x2) = length x1" "length (coeffs y2) = length y1"
    unfolding list_all2_conv_all_nth by auto
  let ?cond1 = "length x1 \<le> karatsuba_lower_bound \<or> length y1 \<le> karatsuba_lower_bound"
  let ?cond2 = "length x1 \<le> length y1"
  note d = karatsuba_mult_poly[symmetric] karatsuba_mult_poly_def Let_def
      times_poly_i_def len if_True if_False
  consider (TT) "?cond1 = True" "?cond2 = True" | (TF) "?cond1 = True" "?cond2 = False"
      | (FT) "?cond1 = False" "?cond2 = True" | (FF) "?cond1 = False" "?cond2 = False" by auto
  thus "poly_rel (times_poly_i ops x1 y1) (x2 * y2)"
  proof (cases)
    case TT
    show ?thesis unfolding d TT
      unfolding poly_rel_def coeffs_eq_iff times_poly_def times_poly_i_def fold_coeffs_def
      by transfer_prover
  next
    case TF
    show ?thesis unfolding d TF
      unfolding poly_rel_def coeffs_eq_iff times_poly_def times_poly_i_def fold_coeffs_def
      by transfer_prover
  next
    case FT
    show ?thesis unfolding d FT
      by (rule poly_rel_karatsuba_main[OF Y12 X12])
  next
    case FF
    show ?thesis unfolding d FF
      by (rule poly_rel_karatsuba_main[OF X12 Y12])
  qed
qed

(* coeff *)
lemma poly_rel_coeff[transfer_rule]: "(poly_rel ===> (=) ===> R) (coeff_i ops) coeff"
  unfolding poly_rel_def rel_fun_def coeff_i_def nth_default_coeffs_eq[symmetric]
proof (intro allI impI, clarify)
  fix x y n
  assume [transfer_rule]: "list_all2 R x (coeffs y)"
  show "R (nth_default zero x n) (nth_default 0 (coeffs y) n)" by transfer_prover
qed

(* degree *)
lemma poly_rel_degree[transfer_rule]: "(poly_rel ===> (=)) degree_i degree"
  unfolding poly_rel_def rel_fun_def degree_i_def degree_eq_length_coeffs
  by (simp add: list_all2_lengthD)

(* lead_coeff *)
lemma lead_coeff_i_def': "lead_coeff_i ops x = (coeff_i ops) x (degree_i x)"
  unfolding lead_coeff_i_def degree_i_def coeff_i_def
proof (cases x, auto, goal_cases)
  case (1 a xs)
  hence id: "last xs = last (a # xs)" by auto
  show ?case unfolding id by (subst last_conv_nth_default, auto)
qed

lemma poly_rel_lead_coeff[transfer_rule]: "(poly_rel ===> R) (lead_coeff_i ops) lead_coeff"
  unfolding lead_coeff_i_def' [abs_def] by transfer_prover

(* minus_poly_rev_list *)
lemma poly_rel_minus_poly_rev_list[transfer_rule]:
  "(list_all2 R ===> list_all2 R ===> list_all2 R) (minus_poly_rev_list_i ops) minus_poly_rev_list"
proof (intro rel_funI, goal_cases)
  case (1 x1 x2 y1 y2)
  thus ?case
  proof (induct x1 y1 arbitrary: x2 y2 rule: minus_poly_rev_list_i.induct)
    case (1 x1 xs1 y1 ys1 X2 Y2)
    from 1(2) obtain x2 xs2 where X2: "X2 = x2 # xs2" by (cases X2, auto)
    from 1(3) obtain y2 ys2 where Y2: "Y2 = y2 # ys2" by (cases Y2, auto)
    from 1(2) 1(3) have [transfer_rule]: "R x1 x2" "R y1 y2"
      and *: "list_all2 R xs1 xs2" "list_all2 R ys1 ys2" unfolding X2 Y2 by auto
    note [transfer_rule] = 1(1)[OF *]
    show ?case unfolding X2 Y2 by (simp, intro conjI, transfer_prover+)
  next
    case (2 xs1 xs2 ys2)
    thus ?case by (cases xs2, auto)
  next
    case (3 xs2 y1 ys1 Y2)
    thus ?case by (cases Y2, auto)
  qed
qed

(* division *)
lemma divmod_poly_one_main_i: assumes len: "n \<le> length Y" and rel: "list_all2 R x X" "list_all2 R y Y"
    "list_all2 R z Z" and n: "n = N"
 shows "rel_prod (list_all2 R) (list_all2 R) (divmod_poly_one_main_i ops x y z n)
    (divmod_poly_one_main_list X Y Z N)"
   using len rel unfolding n
proof (induct N arbitrary: x X y Y z Z)
  case (Suc n x X y Y z Z)
  from Suc(2,4) have [transfer_rule]: "R (hd y) (hd Y)" by (cases y; cases Y, auto)
  note [transfer_rule] = Suc(3-5)
  have id: "?case = (rel_prod (list_all2 R) (list_all2 R)
     (divmod_poly_one_main_i ops (cCons_i ops (hd y) x)
       (tl (if hd y = zero then y else minus_poly_rev_list_i ops y (map (times (hd y)) z))) z n)
     (divmod_poly_one_main_list (cCons (hd Y) X)
       (tl (if hd Y = 0 then Y else minus_poly_rev_list Y (map ((*) (hd Y)) Z))) Z n))"
     by (simp add: Let_def)
  show ?case unfolding id
  proof (rule Suc(1), goal_cases)
    case 1
    show ?case using Suc(2) by simp
  qed (transfer_prover+)
qed simp

(* modulo *)
lemma mod_poly_one_main_i: assumes len: "n \<le> length X" and rel: "list_all2 R x X" "list_all2 R y Y"
    and n: "n = N"
 shows "list_all2 R (mod_poly_one_main_i ops x y n)
    (mod_poly_one_main_list X Y N)"
   using len rel unfolding n
proof (induct N arbitrary: x X y Y)
  case (Suc n y Y z Z)
  from Suc(2,3) have [transfer_rule]: "R (hd y) (hd Y)" by (cases y; cases Y, auto)
  note [transfer_rule] = Suc(3-4)
  have id: "?case = (list_all2 R
     (mod_poly_one_main_i ops
       (tl (if hd y = zero then y else minus_poly_rev_list_i ops y (map (times (hd y)) z))) z n)
     (mod_poly_one_main_list
       (tl (if hd Y = 0 then Y else minus_poly_rev_list Y (map ((*) (hd Y)) Z))) Z n))"
     by (simp add: Let_def)
  show ?case unfolding id
  proof (rule Suc(1), goal_cases)
    case 1
    show ?case using Suc(2) by simp
  qed (transfer_prover+)
qed simp

lemma poly_rel_dvd[transfer_rule]: "(poly_rel ===> poly_rel ===> (=)) (dvd_poly_i ops) (dvd)"
  unfolding dvd_poly_i_def[abs_def] dvd_def[abs_def]
  by (transfer_prover_start, transfer_step+, auto)

lemma poly_rel_monic[transfer_rule]: "(poly_rel ===> (=)) (monic_i ops) monic"
  unfolding monic_i_def lead_coeff_i_def' by transfer_prover

lemma poly_rel_pdivmod_monic: assumes mon: "monic Y"
  and x: "poly_rel x X" and y: "poly_rel y Y"
  shows "rel_prod poly_rel poly_rel (pdivmod_monic_i ops x y) (pdivmod_monic X Y)"
proof -
  note [transfer_rule] = x y
  note listall = this[unfolded poly_rel_def]
  note defs = pdivmod_monic_def pdivmod_monic_i_def Let_def
  from mon obtain k where len: "length (coeffs Y) = Suc k" unfolding poly_rel_def list_all2_iff
      by (cases "coeffs Y", auto)
  have [transfer_rule]:
    "rel_prod (list_all2 R) (list_all2 R)
       (divmod_poly_one_main_i ops [] (rev x) (rev y) (1 + length x - length y))
       (divmod_poly_one_main_list [] (rev (coeffs X)) (rev (coeffs Y)) (1 + length (coeffs X) - length (coeffs Y)))"
    by (rule divmod_poly_one_main_i, insert x y listall, auto, auto simp: poly_rel_def list_all2_iff len)
  show ?thesis unfolding defs by transfer_prover
qed

lemma ring_ops_poly: "ring_ops (poly_ops ops) poly_rel"
  by (unfold_locales, auto simp: poly_ops_def
  bi_unique_poly_rel
  right_total_poly_rel
  poly_rel_times
  poly_rel_zero
  poly_rel_one
  poly_rel_minus
  poly_rel_uminus
  poly_rel_plus
  poly_rel_eq
  Domainp_is_poly)
end

context idom_ops
begin

(* pderiv *)
lemma poly_rel_pderiv [transfer_rule]: "(poly_rel ===> poly_rel) (pderiv_i ops) pderiv"
proof (intro rel_funI, unfold poly_rel_def coeffs_pderiv_code pderiv_i_def pderiv_coeffs_def)
  fix xs xs'
  assume "list_all2 R xs (coeffs xs')"
  then obtain ys ys' y y' where id: "tl xs = ys" "tl (coeffs xs') = ys'" "one = y" "1 = y'" and
    R: "list_all2 R ys ys'" "R y y'"
    by (cases xs; cases "coeffs xs'"; auto simp: one)
  show "list_all2 R (pderiv_main_i ops one (tl xs))
            (pderiv_coeffs_code 1 (tl (coeffs xs')))"
    unfolding id using R
  proof (induct ys ys' arbitrary: y y' rule: list_all2_induct)
    case (Cons x xs x' xs' y y')
    note [transfer_rule] = Cons(1,2,4)
    have "R (plus y one) (y' + 1)"  by transfer_prover
    note [transfer_rule] = Cons(3)[OF this]
    show ?case by (simp, transfer_prover)
  qed simp
qed

lemma poly_rel_irreducible[transfer_rule]: "(poly_rel ===> (=)) (irreducible_i ops) irreducible\<^sub>d"
  unfolding irreducible_i_def[abs_def] irreducible\<^sub>d_def[abs_def]
  by (transfer_prover_start, transfer_step+, auto)

lemma idom_ops_poly: "idom_ops (poly_ops ops) poly_rel"
  using ring_ops_poly unfolding ring_ops_def idom_ops_def by auto
end

context idom_divide_ops
begin
(* sdiv *)
lemma poly_rel_sdiv[transfer_rule]: "(poly_rel ===> R ===> poly_rel) (sdiv_i ops) sdiv_poly"
  unfolding rel_fun_def poly_rel_def coeffs_sdiv sdiv_i_def
proof (intro allI impI, goal_cases)
  case (1 x y xs ys)
  note [transfer_rule] = 1
  show ?case by transfer_prover
qed
end

context field_ops
begin
(* division *)
lemma poly_rel_div[transfer_rule]: "(poly_rel ===> poly_rel ===> poly_rel)
  (div_field_poly_i ops) (div)"
proof (intro rel_funI, goal_cases)
  case (1 x X y Y)
  note [transfer_rule] = this
  note listall = this[unfolded poly_rel_def]
  note defs = div_field_poly_impl div_field_poly_impl_def div_field_poly_i_def Let_def
  show ?case
  proof (cases "y = []")
    case True
    with 1(2) have nil: "coeffs Y = []" unfolding poly_rel_def by auto
    show ?thesis unfolding defs True nil poly_rel_def by auto
  next
    case False
    from append_butlast_last_id[OF False] obtain ys yl where y: "y = ys @ [yl]" by metis
    from False listall have "coeffs Y \<noteq> []" by auto
    from append_butlast_last_id[OF this] obtain Ys Yl where Y: "coeffs Y = Ys @ [Yl]" by metis
    from listall have [transfer_rule]: "R yl Yl" by (simp add: y Y)
    have id: "last (coeffs Y) = Yl" "last (y) = yl"
      "\<And> t e. (if y = [] then t else e) = e"
      "\<And> t e. (if coeffs Y = [] then t else e) = e" unfolding y Y by auto
    have [transfer_rule]: "(rel_prod (list_all2 R) (list_all2 R))
      (divmod_poly_one_main_i ops [] (rev x) (rev (map (times (inverse yl)) y))
        (1 + length x - length y))
      (divmod_poly_one_main_list [] (rev (coeffs X))
                (rev (map ((*) (Fields.inverse Yl)) (coeffs Y)))
                (1 + length (coeffs X) - length (coeffs Y)))"
    proof (rule divmod_poly_one_main_i, goal_cases)
      case 5
      from listall show ?case by (simp add: list_all2_lengthD)
    next
      case 1
      from listall show ?case by (simp add: list_all2_lengthD Y)
    qed transfer_prover+
    show ?thesis unfolding defs id by transfer_prover
  qed
qed

(* modulo *)
lemma poly_rel_mod[transfer_rule]: "(poly_rel ===> poly_rel ===> poly_rel)
  (mod_field_poly_i ops) (mod)"
proof (intro rel_funI, goal_cases)
  case (1 x X y Y)
  note [transfer_rule] = this
  note listall = this[unfolded poly_rel_def]
  note defs = mod_poly_code mod_field_poly_i_def Let_def
  show ?case
  proof (cases "y = []")
    case True
    with 1(2) have nil: "coeffs Y = []" unfolding poly_rel_def by auto
    show ?thesis unfolding defs True nil poly_rel_def by (simp add: listall)
  next
    case False
    from append_butlast_last_id[OF False] obtain ys yl where y: "y = ys @ [yl]" by metis
    from False listall have "coeffs Y \<noteq> []" by auto
    from append_butlast_last_id[OF this] obtain Ys Yl where Y: "coeffs Y = Ys @ [Yl]" by metis
    from listall have [transfer_rule]: "R yl Yl" by (simp add: y Y)
    have id: "last (coeffs Y) = Yl" "last (y) = yl"
      "\<And> t e. (if y = [] then t else e) = e"
      "\<And> t e. (if coeffs Y = [] then t else e) = e" unfolding y Y by auto
    have [transfer_rule]: "list_all2 R
      (mod_poly_one_main_i ops (rev x) (rev (map (times (inverse yl)) y))
        (1 + length x - length y))
      (mod_poly_one_main_list (rev (coeffs X))
                (rev (map ((*) (Fields.inverse Yl)) (coeffs Y)))
                (1 + length (coeffs X) - length (coeffs Y)))"
    proof (rule mod_poly_one_main_i, goal_cases)
      case 4
      from listall show ?case by (simp add: list_all2_lengthD)
    next
      case 1
      from listall show ?case by (simp add: list_all2_lengthD Y)
    qed transfer_prover+
    show ?thesis unfolding defs id by transfer_prover
  qed
qed

(* normalize *)
lemma poly_rel_normalize [transfer_rule]: "(poly_rel ===> poly_rel)
  (normalize_poly_i ops) Rings.normalize"
  unfolding normalize_poly_old_def normalize_poly_i_def lead_coeff_i_def'
  by transfer_prover

(* unit_factor *)
lemma poly_rel_unit_factor [transfer_rule]: "(poly_rel ===> poly_rel)
  (unit_factor_poly_i ops) Rings.unit_factor"
  unfolding unit_factor_poly_def unit_factor_poly_i_def lead_coeff_i_def'
  unfolding monom_0 by transfer_prover

lemma idom_divide_ops_poly: "idom_divide_ops (poly_ops ops) poly_rel"
proof -
  interpret poly: idom_ops "poly_ops ops" poly_rel by (rule idom_ops_poly)
  show ?thesis
    by (unfold_locales, simp add: poly_rel_div poly_ops_def)
qed

lemma euclidean_ring_ops_poly: "euclidean_ring_ops (poly_ops ops) poly_rel"
proof -
  interpret poly: idom_ops "poly_ops ops" poly_rel by (rule idom_ops_poly)
  have id: "arith_ops_record.normalize (poly_ops ops) = normalize_poly_i ops"
    "arith_ops_record.unit_factor (poly_ops ops) = unit_factor_poly_i ops"
    unfolding poly_ops_def by simp_all
  show ?thesis
    by (unfold_locales, simp add: poly_rel_mod poly_ops_def, unfold id,
      simp add: poly_rel_normalize, insert poly_rel_div poly_rel_unit_factor,
      auto simp: poly_ops_def)
qed

(* gcd poly *)
lemma poly_rel_gcd [transfer_rule]: "(poly_rel ===> poly_rel ===> poly_rel) (gcd_poly_i ops) gcd"
proof -
  interpret poly: euclidean_ring_ops "poly_ops ops" poly_rel by (rule euclidean_ring_ops_poly)
  show ?thesis using poly.gcd_eucl_i unfolding gcd_poly_i_def gcd_eucl .
qed

(* euclid_ext poly *)
lemma poly_rel_euclid_ext [transfer_rule]: "(poly_rel ===> poly_rel ===>
  rel_prod (rel_prod poly_rel poly_rel) poly_rel) (euclid_ext_poly_i ops) euclid_ext"
proof -
  interpret poly: euclidean_ring_ops "poly_ops ops" poly_rel by (rule euclidean_ring_ops_poly)
  show ?thesis using poly.euclid_ext_i unfolding euclid_ext_poly_i_def .
qed

end

(* ********************************************************** *)

context ring_ops
begin
notepad (* checking transfer rules *)
begin
  fix xs x ys y
  assume [transfer_rule]: "poly_rel xs x" "poly_rel ys y"
  have "x * y = y * x" by simp
  from this[untransferred]
  have "times_poly_i ops xs ys = times_poly_i ops ys xs" .
end
end
end