(*  Title:      ZF/ex/Group.thy *)

section {* Groups *}

theory Group imports Main begin

text{*Based on work by Clemens Ballarin, Florian Kammueller, L C Paulson and
Markus Wenzel.*}

subsection {* Monoids *}

(*First, we must simulate a record declaration:
record monoid =
  carrier :: i
  mult :: "[i,i] => i" (infixl "\<cdot>\<index>" 70)
  one :: i ("\<one>\<index>")
*)

definition
  carrier :: "i => i" where
  "carrier(M) == fst(M)"

definition
  mmult :: "[i, i, i] => i" (infixl "\<cdot>\<index>" 70) where
  "mmult(M,x,y) == fst(snd(M)) ` <x,y>"

definition
  one :: "i => i" ("\<one>\<index>") where
  "one(M) == fst(snd(snd(M)))"

definition
  update_carrier :: "[i,i] => i" where
  "update_carrier(M,A) == <A,snd(M)>"

definition
  m_inv :: "i => i => i" ("inv\<index> _" [81] 80) where
  "inv\<^bsub>G\<^esub> x == (THE y. y \<in> carrier(G) & y \<cdot>\<^bsub>G\<^esub> x = \<one>\<^bsub>G\<^esub> & x \<cdot>\<^bsub>G\<^esub> y = \<one>\<^bsub>G\<^esub>)"

locale monoid = fixes G (structure)
  assumes m_closed [intro, simp]:
         "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> x \<cdot> y \<in> carrier(G)"
      and m_assoc:
         "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G); z \<in> carrier(G)\<rbrakk>
          \<Longrightarrow> (x \<cdot> y) \<cdot> z = x \<cdot> (y \<cdot> z)"
      and one_closed [intro, simp]: "\<one> \<in> carrier(G)"
      and l_one [simp]: "x \<in> carrier(G) \<Longrightarrow> \<one> \<cdot> x = x"
      and r_one [simp]: "x \<in> carrier(G) \<Longrightarrow> x \<cdot> \<one> = x"

text{*Simulating the record*}
lemma carrier_eq [simp]: "carrier(<A,Z>) = A"
  by (simp add: carrier_def)

lemma mult_eq [simp]: "mmult(<A,M,Z>, x, y) = M ` <x,y>"
  by (simp add: mmult_def)

lemma one_eq [simp]: "one(<A,M,I,Z>) = I"
  by (simp add: one_def)

lemma update_carrier_eq [simp]: "update_carrier(<A,Z>,B) = <B,Z>"
  by (simp add: update_carrier_def)

lemma carrier_update_carrier [simp]: "carrier(update_carrier(M,B)) = B"
  by (simp add: update_carrier_def)

lemma mult_update_carrier [simp]: "mmult(update_carrier(M,B),x,y) = mmult(M,x,y)"
  by (simp add: update_carrier_def mmult_def)

lemma one_update_carrier [simp]: "one(update_carrier(M,B)) = one(M)"
  by (simp add: update_carrier_def one_def)

lemma (in monoid) inv_unique:
  assumes eq: "y \<cdot> x = \<one>"  "x \<cdot> y' = \<one>"
    and G: "x \<in> carrier(G)"  "y \<in> carrier(G)"  "y' \<in> carrier(G)"
  shows "y = y'"
proof -
  from G eq have "y = y \<cdot> (x \<cdot> y')" by simp
  also from G have "... = (y \<cdot> x) \<cdot> y'" by (simp add: m_assoc)
  also from G eq have "... = y'" by simp
  finally show ?thesis .
qed

text {*
  A group is a monoid all of whose elements are invertible.
*}

locale group = monoid +
  assumes inv_ex:
     "\<And>x. x \<in> carrier(G) \<Longrightarrow> \<exists>y \<in> carrier(G). y \<cdot> x = \<one> & x \<cdot> y = \<one>"

lemma (in group) is_group [simp]: "group(G)" by (rule group_axioms)

theorem groupI:
  fixes G (structure)
  assumes m_closed [simp]:
      "\<And>x y. \<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> x \<cdot> y \<in> carrier(G)"
    and one_closed [simp]: "\<one> \<in> carrier(G)"
    and m_assoc:
      "\<And>x y z. \<lbrakk>x \<in> carrier(G); y \<in> carrier(G); z \<in> carrier(G)\<rbrakk> \<Longrightarrow>
      (x \<cdot> y) \<cdot> z = x \<cdot> (y \<cdot> z)"
    and l_one [simp]: "\<And>x. x \<in> carrier(G) \<Longrightarrow> \<one> \<cdot> x = x"
    and l_inv_ex: "\<And>x. x \<in> carrier(G) \<Longrightarrow> \<exists>y \<in> carrier(G). y \<cdot> x = \<one>"
  shows "group(G)"
proof -
  have l_cancel [simp]:
    "\<And>x y z. \<lbrakk>x \<in> carrier(G); y \<in> carrier(G); z \<in> carrier(G)\<rbrakk> \<Longrightarrow>
    (x \<cdot> y = x \<cdot> z) \<longleftrightarrow> (y = z)"
  proof
    fix x y z
    assume G: "x \<in> carrier(G)"  "y \<in> carrier(G)"  "z \<in> carrier(G)"
    {
      assume eq: "x \<cdot> y = x \<cdot> z"
      with G l_inv_ex obtain x_inv where xG: "x_inv \<in> carrier(G)"
        and l_inv: "x_inv \<cdot> x = \<one>" by fast
      from G eq xG have "(x_inv \<cdot> x) \<cdot> y = (x_inv \<cdot> x) \<cdot> z"
        by (simp add: m_assoc)
      with G show "y = z" by (simp add: l_inv)
    next
      assume eq: "y = z"
      with G show "x \<cdot> y = x \<cdot> z" by simp
    }
  qed
  have r_one:
    "\<And>x. x \<in> carrier(G) \<Longrightarrow> x \<cdot> \<one> = x"
  proof -
    fix x
    assume x: "x \<in> carrier(G)"
    with l_inv_ex obtain x_inv where xG: "x_inv \<in> carrier(G)"
      and l_inv: "x_inv \<cdot> x = \<one>" by fast
    from x xG have "x_inv \<cdot> (x \<cdot> \<one>) = x_inv \<cdot> x"
      by (simp add: m_assoc [symmetric] l_inv)
    with x xG show "x \<cdot> \<one> = x" by simp
  qed
  have inv_ex:
    "!!x. x \<in> carrier(G) ==> \<exists>y \<in> carrier(G). y \<cdot> x = \<one> & x \<cdot> y = \<one>"
  proof -
    fix x
    assume x: "x \<in> carrier(G)"
    with l_inv_ex obtain y where y: "y \<in> carrier(G)"
      and l_inv: "y \<cdot> x = \<one>" by fast
    from x y have "y \<cdot> (x \<cdot> y) = y \<cdot> \<one>"
      by (simp add: m_assoc [symmetric] l_inv r_one)
    with x y have r_inv: "x \<cdot> y = \<one>"
      by simp
    from x y show "\<exists>y \<in> carrier(G). y \<cdot> x = \<one> & x \<cdot> y = \<one>"
      by (fast intro: l_inv r_inv)
  qed
  show ?thesis
    by (blast intro: group.intro monoid.intro group_axioms.intro
                     assms r_one inv_ex)
qed

lemma (in group) inv [simp]:
  "x \<in> carrier(G) \<Longrightarrow> inv x \<in> carrier(G) & inv x \<cdot> x = \<one> & x \<cdot> inv x = \<one>"
  apply (frule inv_ex)
  apply (unfold Bex_def m_inv_def)
  apply (erule exE)
  apply (rule theI)
  apply (rule ex1I, assumption)
   apply (blast intro: inv_unique)
  done

lemma (in group) inv_closed [intro!]:
  "x \<in> carrier(G) \<Longrightarrow> inv x \<in> carrier(G)"
  by simp

lemma (in group) l_inv:
  "x \<in> carrier(G) \<Longrightarrow> inv x \<cdot> x = \<one>"
  by simp

lemma (in group) r_inv:
  "x \<in> carrier(G) \<Longrightarrow> x \<cdot> inv x = \<one>"
  by simp

subsection {* Cancellation Laws and Basic Properties *}

lemma (in group) l_cancel [simp]:
  assumes "x \<in> carrier(G)" "y \<in> carrier(G)" "z \<in> carrier(G)"
  shows "(x \<cdot> y = x \<cdot> z) \<longleftrightarrow> (y = z)"
proof
  assume eq: "x \<cdot> y = x \<cdot> z"
  hence  "(inv x \<cdot> x) \<cdot> y = (inv x \<cdot> x) \<cdot> z"
    by (simp only: m_assoc inv_closed assms)
  thus "y = z" by (simp add: assms)
next
  assume eq: "y = z"
  then show "x \<cdot> y = x \<cdot> z" by simp
qed

lemma (in group) r_cancel [simp]:
  assumes "x \<in> carrier(G)" "y \<in> carrier(G)" "z \<in> carrier(G)"
  shows "(y \<cdot> x = z \<cdot> x) \<longleftrightarrow> (y = z)"
proof
  assume eq: "y \<cdot> x = z \<cdot> x"
  then have "y \<cdot> (x \<cdot> inv x) = z \<cdot> (x \<cdot> inv x)"
    by (simp only: m_assoc [symmetric] inv_closed assms)
  thus "y = z" by (simp add: assms)
next
  assume eq: "y = z"
  thus  "y \<cdot> x = z \<cdot> x" by simp
qed

lemma (in group) inv_comm:
  assumes "x \<cdot> y = \<one>"
      and G: "x \<in> carrier(G)"  "y \<in> carrier(G)"
  shows "y \<cdot> x = \<one>"
proof -
  from G have "x \<cdot> y \<cdot> x = x \<cdot> \<one>" by (auto simp add: assms)
  with G show ?thesis by (simp del: r_one add: m_assoc)
qed

lemma (in group) inv_equality:
     "\<lbrakk>y \<cdot> x = \<one>; x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> inv x = y"
apply (simp add: m_inv_def)
apply (rule the_equality)
 apply (simp add: inv_comm [of y x])
apply (rule r_cancel [THEN iffD1], auto)
done

lemma (in group) inv_one [simp]:
  "inv \<one> = \<one>"
  by (auto intro: inv_equality)

lemma (in group) inv_inv [simp]: "x \<in> carrier(G) \<Longrightarrow> inv (inv x) = x"
  by (auto intro: inv_equality)

text{*This proof is by cancellation*}
lemma (in group) inv_mult_group:
  "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> inv (x \<cdot> y) = inv y \<cdot> inv x"
proof -
  assume G: "x \<in> carrier(G)"  "y \<in> carrier(G)"
  then have "inv (x \<cdot> y) \<cdot> (x \<cdot> y) = (inv y \<cdot> inv x) \<cdot> (x \<cdot> y)"
    by (simp add: m_assoc l_inv) (simp add: m_assoc [symmetric] l_inv)
  with G show ?thesis by (simp_all del: inv add: inv_closed)
qed

subsection {* Substructures *}

locale subgroup = fixes H and G (structure)
  assumes subset: "H \<subseteq> carrier(G)"
    and m_closed [intro, simp]: "\<lbrakk>x \<in> H; y \<in> H\<rbrakk> \<Longrightarrow> x \<cdot> y \<in> H"
    and  one_closed [simp]: "\<one> \<in> H"
    and m_inv_closed [intro,simp]: "x \<in> H \<Longrightarrow> inv x \<in> H"

lemma (in subgroup) mem_carrier [simp]:
  "x \<in> H \<Longrightarrow> x \<in> carrier(G)"
  using subset by blast

lemma subgroup_imp_subset:
  "subgroup(H,G) \<Longrightarrow> H \<subseteq> carrier(G)"
  by (rule subgroup.subset)

lemma (in subgroup) group_axiomsI [intro]:
  assumes "group(G)"
  shows "group_axioms (update_carrier(G,H))"
proof -
  interpret group G by fact
  show ?thesis by (force intro: group_axioms.intro l_inv r_inv)
qed

lemma (in subgroup) is_group [intro]:
  assumes "group(G)"
  shows "group (update_carrier(G,H))"
proof -
  interpret group G by fact
  show ?thesis
  by (rule groupI) (auto intro: m_assoc l_inv mem_carrier)
qed

text {*
  Since @{term H} is nonempty, it contains some element @{term x}.  Since
  it is closed under inverse, it contains @{text "inv x"}.  Since
  it is closed under product, it contains @{text "x \<cdot> inv x = \<one>"}.
*}

text {*
  Since @{term H} is nonempty, it contains some element @{term x}.  Since
  it is closed under inverse, it contains @{text "inv x"}.  Since
  it is closed under product, it contains @{text "x \<cdot> inv x = \<one>"}.
*}

lemma (in group) one_in_subset:
  "\<lbrakk>H \<subseteq> carrier(G); H \<noteq> 0; \<forall>a \<in> H. inv a \<in> H; \<forall>a\<in>H. \<forall>b\<in>H. a \<cdot> b \<in> H\<rbrakk>
   \<Longrightarrow> \<one> \<in> H"
by (force simp add: l_inv)

text {* A characterization of subgroups: closed, non-empty subset. *}

declare monoid.one_closed [simp] group.inv_closed [simp]
  monoid.l_one [simp] monoid.r_one [simp] group.inv_inv [simp]

lemma subgroup_nonempty:
  "~ subgroup(0,G)"
  by (blast dest: subgroup.one_closed)

subsection {* Direct Products *}

definition
  DirProdGroup :: "[i,i] => i"  (infixr "\<Otimes>" 80) where
  "G \<Otimes> H == <carrier(G) \<times> carrier(H),
              (\<lambda><<g,h>, <g', h'>>
                   \<in> (carrier(G) \<times> carrier(H)) \<times> (carrier(G) \<times> carrier(H)).
                <g \<cdot>\<^bsub>G\<^esub> g', h \<cdot>\<^bsub>H\<^esub> h'>),
              <\<one>\<^bsub>G\<^esub>, \<one>\<^bsub>H\<^esub>>, 0>"

lemma DirProdGroup_group:
  assumes "group(G)" and "group(H)"
  shows "group (G \<Otimes> H)"
proof -
  interpret G: group G by fact
  interpret H: group H by fact
  show ?thesis by (force intro!: groupI G.m_assoc H.m_assoc G.l_inv H.l_inv
          simp add: DirProdGroup_def)
qed

lemma carrier_DirProdGroup [simp]:
     "carrier (G \<Otimes> H) = carrier(G) \<times> carrier(H)"
  by (simp add: DirProdGroup_def)

lemma one_DirProdGroup [simp]:
     "\<one>\<^bsub>G \<Otimes> H\<^esub> = <\<one>\<^bsub>G\<^esub>, \<one>\<^bsub>H\<^esub>>"
  by (simp add: DirProdGroup_def)

lemma mult_DirProdGroup [simp]:
     "[|g \<in> carrier(G); h \<in> carrier(H); g' \<in> carrier(G); h' \<in> carrier(H)|]
      ==> <g, h> \<cdot>\<^bsub>G \<Otimes> H\<^esub> <g', h'> = <g \<cdot>\<^bsub>G\<^esub> g', h \<cdot>\<^bsub>H\<^esub> h'>"
  by (simp add: DirProdGroup_def)

lemma inv_DirProdGroup [simp]:
  assumes "group(G)" and "group(H)"
  assumes g: "g \<in> carrier(G)"
      and h: "h \<in> carrier(H)"
  shows "inv \<^bsub>G \<Otimes> H\<^esub> <g, h> = <inv\<^bsub>G\<^esub> g, inv\<^bsub>H\<^esub> h>"
  apply (rule group.inv_equality [OF DirProdGroup_group])
  apply (simp_all add: assms group.l_inv)
  done

subsection {* Isomorphisms *}

definition
  hom :: "[i,i] => i" where
  "hom(G,H) ==
    {h \<in> carrier(G) -> carrier(H).
      (\<forall>x \<in> carrier(G). \<forall>y \<in> carrier(G). h ` (x \<cdot>\<^bsub>G\<^esub> y) = (h ` x) \<cdot>\<^bsub>H\<^esub> (h ` y))}"

lemma hom_mult:
  "\<lbrakk>h \<in> hom(G,H); x \<in> carrier(G); y \<in> carrier(G)\<rbrakk>
   \<Longrightarrow> h ` (x \<cdot>\<^bsub>G\<^esub> y) = h ` x \<cdot>\<^bsub>H\<^esub> h ` y"
  by (simp add: hom_def)

lemma hom_closed:
  "\<lbrakk>h \<in> hom(G,H); x \<in> carrier(G)\<rbrakk> \<Longrightarrow> h ` x \<in> carrier(H)"
  by (auto simp add: hom_def)

lemma (in group) hom_compose:
     "\<lbrakk>h \<in> hom(G,H); i \<in> hom(H,I)\<rbrakk> \<Longrightarrow> i O h \<in> hom(G,I)"
by (force simp add: hom_def comp_fun)

lemma hom_is_fun:
  "h \<in> hom(G,H) \<Longrightarrow> h \<in> carrier(G) -> carrier(H)"
  by (simp add: hom_def)

subsection {* Isomorphisms *}

definition
  iso :: "[i,i] => i"  (infixr "\<cong>" 60) where
  "G \<cong> H == hom(G,H) \<inter> bij(carrier(G), carrier(H))"

lemma (in group) iso_refl: "id(carrier(G)) \<in> G \<cong> G"
  by (simp add: iso_def hom_def id_type id_bij)

lemma (in group) iso_sym:
     "h \<in> G \<cong> H \<Longrightarrow> converse(h) \<in> H \<cong> G"
apply (simp add: iso_def bij_converse_bij, clarify)
apply (subgoal_tac "converse(h) \<in> carrier(H) \<rightarrow> carrier(G)")
 prefer 2 apply (simp add: bij_converse_bij bij_is_fun)
apply (auto intro: left_inverse_eq [of _ "carrier(G)" "carrier(H)"]
            simp add: hom_def bij_is_inj right_inverse_bij)
done

lemma (in group) iso_trans:
     "\<lbrakk>h \<in> G \<cong> H; i \<in> H \<cong> I\<rbrakk> \<Longrightarrow> i O h \<in> G \<cong> I"
  by (auto simp add: iso_def hom_compose comp_bij)

lemma DirProdGroup_commute_iso:
  assumes "group(G)" and "group(H)"
  shows "(\<lambda><x,y> \<in> carrier(G \<Otimes> H). <y,x>) \<in> (G \<Otimes> H) \<cong> (H \<Otimes> G)"
proof -
  interpret group G by fact
  interpret group H by fact
  show ?thesis by (auto simp add: iso_def hom_def inj_def surj_def bij_def)
qed

lemma DirProdGroup_assoc_iso:
  assumes "group(G)" and "group(H)" and "group(I)"
  shows "(\<lambda><<x,y>,z> \<in> carrier((G \<Otimes> H) \<Otimes> I). <x,<y,z>>)
          \<in> ((G \<Otimes> H) \<Otimes> I) \<cong> (G \<Otimes> (H \<Otimes> I))"
proof -
  interpret group G by fact
  interpret group H by fact
  interpret group I by fact
  show ?thesis
    by (auto intro: lam_type simp add: iso_def hom_def inj_def surj_def bij_def)
qed

text{*Basis for homomorphism proofs: we assume two groups @{term G} and
  @{term H}, with a homomorphism @{term h} between them*}
locale group_hom = G: group G + H: group H
  for G (structure) and H (structure) and h +
  assumes homh: "h \<in> hom(G,H)"
  notes hom_mult [simp] = hom_mult [OF homh]
    and hom_closed [simp] = hom_closed [OF homh]
    and hom_is_fun [simp] = hom_is_fun [OF homh]

lemma (in group_hom) one_closed [simp]:
  "h ` \<one> \<in> carrier(H)"
  by simp

lemma (in group_hom) hom_one [simp]:
  "h ` \<one> = \<one>\<^bsub>H\<^esub>"
proof -
  have "h ` \<one> \<cdot>\<^bsub>H\<^esub> \<one>\<^bsub>H\<^esub> = (h ` \<one>) \<cdot>\<^bsub>H\<^esub> (h ` \<one>)"
    by (simp add: hom_mult [symmetric] del: hom_mult)
  then show ?thesis by (simp del: r_one)
qed

lemma (in group_hom) inv_closed [simp]:
  "x \<in> carrier(G) \<Longrightarrow> h ` (inv x) \<in> carrier(H)"
  by simp

lemma (in group_hom) hom_inv [simp]:
  "x \<in> carrier(G) \<Longrightarrow> h ` (inv x) = inv\<^bsub>H\<^esub> (h ` x)"
proof -
  assume x: "x \<in> carrier(G)"
  then have "h ` x \<cdot>\<^bsub>H\<^esub> h ` (inv x) = \<one>\<^bsub>H\<^esub>"
    by (simp add: hom_mult [symmetric] G.r_inv del: hom_mult)
  also from x have "... = h ` x \<cdot>\<^bsub>H\<^esub> inv\<^bsub>H\<^esub> (h ` x)"
    by (simp add: hom_mult [symmetric] H.r_inv del: hom_mult)
  finally have "h ` x \<cdot>\<^bsub>H\<^esub> h ` (inv x) = h ` x \<cdot>\<^bsub>H\<^esub> inv\<^bsub>H\<^esub> (h ` x)" .
  with x show ?thesis by (simp del: inv)
qed

subsection {* Commutative Structures *}

text {*
  Naming convention: multiplicative structures that are commutative
  are called \emph{commutative}, additive structures are called
  \emph{Abelian}.
*}

subsection {* Definition *}

locale comm_monoid = monoid +
  assumes m_comm: "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> x \<cdot> y = y \<cdot> x"

lemma (in comm_monoid) m_lcomm:
  "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G); z \<in> carrier(G)\<rbrakk> \<Longrightarrow>
   x \<cdot> (y \<cdot> z) = y \<cdot> (x \<cdot> z)"
proof -
  assume xyz: "x \<in> carrier(G)"  "y \<in> carrier(G)"  "z \<in> carrier(G)"
  from xyz have "x \<cdot> (y \<cdot> z) = (x \<cdot> y) \<cdot> z" by (simp add: m_assoc)
  also from xyz have "... = (y \<cdot> x) \<cdot> z" by (simp add: m_comm)
  also from xyz have "... = y \<cdot> (x \<cdot> z)" by (simp add: m_assoc)
  finally show ?thesis .
qed

lemmas (in comm_monoid) m_ac = m_assoc m_comm m_lcomm

locale comm_group = comm_monoid + group

lemma (in comm_group) inv_mult:
  "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> inv (x \<cdot> y) = inv x \<cdot> inv y"
  by (simp add: m_ac inv_mult_group)

lemma (in group) subgroup_self: "subgroup (carrier(G),G)"
by (simp add: subgroup_def)

lemma (in group) subgroup_imp_group:
  "subgroup(H,G) \<Longrightarrow> group (update_carrier(G,H))"
by (simp add: subgroup.is_group)

lemma (in group) subgroupI:
  assumes subset: "H \<subseteq> carrier(G)" and non_empty: "H \<noteq> 0"
    and "!!a. a \<in> H ==> inv a \<in> H"
    and "!!a b. [|a \<in> H; b \<in> H|] ==> a \<cdot> b \<in> H"
  shows "subgroup(H,G)"
proof (simp add: subgroup_def assms)
  show "\<one> \<in> H"
    by (rule one_in_subset) (auto simp only: assms)
qed

subsection {* Bijections of a Set, Permutation Groups, Automorphism Groups *}

definition
  BijGroup :: "i=>i" where
  "BijGroup(S) ==
    <bij(S,S),
     \<lambda><g,f> \<in> bij(S,S) \<times> bij(S,S). g O f,
     id(S), 0>"

subsection {*Bijections Form a Group *}

theorem group_BijGroup: "group(BijGroup(S))"
apply (simp add: BijGroup_def)
apply (rule groupI)
    apply (simp_all add: id_bij comp_bij comp_assoc)
 apply (simp add: id_bij bij_is_fun left_comp_id [of _ S S] fun_is_rel)
apply (blast intro: left_comp_inverse bij_is_inj bij_converse_bij)
done

subsection{*Automorphisms Form a Group*}

lemma Bij_Inv_mem: "\<lbrakk>f \<in> bij(S,S);  x \<in> S\<rbrakk> \<Longrightarrow> converse(f) ` x \<in> S"
by (blast intro: apply_funtype bij_is_fun bij_converse_bij)

lemma inv_BijGroup: "f \<in> bij(S,S) \<Longrightarrow> m_inv (BijGroup(S), f) = converse(f)"
apply (rule group.inv_equality)
apply (rule group_BijGroup)
apply (simp_all add: BijGroup_def bij_converse_bij
          left_comp_inverse [OF bij_is_inj])
done

lemma iso_is_bij: "h \<in> G \<cong> H ==> h \<in> bij(carrier(G), carrier(H))"
by (simp add: iso_def)

definition
  auto :: "i=>i" where
  "auto(G) == iso(G,G)"

definition
  AutoGroup :: "i=>i" where
  "AutoGroup(G) == update_carrier(BijGroup(carrier(G)), auto(G))"

lemma (in group) id_in_auto: "id(carrier(G)) \<in> auto(G)"
  by (simp add: iso_refl auto_def)

lemma (in group) subgroup_auto:
      "subgroup (auto(G)) (BijGroup (carrier(G)))"
proof (rule subgroup.intro)
  show "auto(G) \<subseteq> carrier (BijGroup (carrier(G)))"
    by (auto simp add: auto_def BijGroup_def iso_def)
next
  fix x y
  assume "x \<in> auto(G)" "y \<in> auto(G)"
  thus "x \<cdot>\<^bsub>BijGroup (carrier(G))\<^esub> y \<in> auto(G)"
    by (auto simp add: BijGroup_def auto_def iso_def bij_is_fun
                       group.hom_compose comp_bij)
next
  show "\<one>\<^bsub>BijGroup (carrier(G))\<^esub> \<in> auto(G)" by (simp add:  BijGroup_def id_in_auto)
next
  fix x
  assume "x \<in> auto(G)"
  thus "inv\<^bsub>BijGroup (carrier(G))\<^esub> x \<in> auto(G)"
    by (simp add: auto_def inv_BijGroup iso_is_bij iso_sym)
qed

theorem (in group) AutoGroup: "group (AutoGroup(G))"
by (simp add: AutoGroup_def subgroup.is_group subgroup_auto group_BijGroup)

subsection{*Cosets and Quotient Groups*}

definition
  r_coset  :: "[i,i,i] => i"  (infixl "#>\<index>" 60) where
  "H #>\<^bsub>G\<^esub> a == \<Union>h\<in>H. {h \<cdot>\<^bsub>G\<^esub> a}"

definition
  l_coset  :: "[i,i,i] => i"  (infixl "<#\<index>" 60) where
  "a <#\<^bsub>G\<^esub> H == \<Union>h\<in>H. {a \<cdot>\<^bsub>G\<^esub> h}"

definition
  RCOSETS  :: "[i,i] => i"  ("rcosets\<index> _" [81] 80) where
  "rcosets\<^bsub>G\<^esub> H == \<Union>a\<in>carrier(G). {H #>\<^bsub>G\<^esub> a}"

definition
  set_mult :: "[i,i,i] => i"  (infixl "<#>\<index>" 60) where
  "H <#>\<^bsub>G\<^esub> K == \<Union>h\<in>H. \<Union>k\<in>K. {h \<cdot>\<^bsub>G\<^esub> k}"

definition
  SET_INV  :: "[i,i] => i"  ("set'_inv\<index> _" [81] 80) where
  "set_inv\<^bsub>G\<^esub> H == \<Union>h\<in>H. {inv\<^bsub>G\<^esub> h}"

locale normal = subgroup: subgroup + group +
  assumes coset_eq: "(\<forall>x \<in> carrier(G). H #> x = x <# H)"

notation
  normal  (infixl "\<lhd>" 60)

subsection {*Basic Properties of Cosets*}

lemma (in group) coset_mult_assoc:
     "\<lbrakk>M \<subseteq> carrier(G); g \<in> carrier(G); h \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> (M #> g) #> h = M #> (g \<cdot> h)"
by (force simp add: r_coset_def m_assoc)

lemma (in group) coset_mult_one [simp]: "M \<subseteq> carrier(G) \<Longrightarrow> M #> \<one> = M"
by (force simp add: r_coset_def)

lemma (in group) solve_equation:
    "\<lbrakk>subgroup(H,G); x \<in> H; y \<in> H\<rbrakk> \<Longrightarrow> \<exists>h\<in>H. y = h \<cdot> x"
apply (rule bexI [of _ "y \<cdot> (inv x)"])
apply (auto simp add: subgroup.m_closed subgroup.m_inv_closed m_assoc
                      subgroup.subset [THEN subsetD])
done

lemma (in group) repr_independence:
     "\<lbrakk>y \<in> H #> x;  x \<in> carrier(G); subgroup(H,G)\<rbrakk> \<Longrightarrow> H #> x = H #> y"
by (auto simp add: r_coset_def m_assoc [symmetric]
                   subgroup.subset [THEN subsetD]
                   subgroup.m_closed solve_equation)

lemma (in group) coset_join2:
     "\<lbrakk>x \<in> carrier(G);  subgroup(H,G);  x\<in>H\<rbrakk> \<Longrightarrow> H #> x = H"
  --{*Alternative proof is to put @{term "x=\<one>"} in @{text repr_independence}.*}
by (force simp add: subgroup.m_closed r_coset_def solve_equation)

lemma (in group) r_coset_subset_G:
     "\<lbrakk>H \<subseteq> carrier(G); x \<in> carrier(G)\<rbrakk> \<Longrightarrow> H #> x \<subseteq> carrier(G)"
by (auto simp add: r_coset_def)

lemma (in group) rcosI:
     "\<lbrakk>h \<in> H; H \<subseteq> carrier(G); x \<in> carrier(G)\<rbrakk> \<Longrightarrow> h \<cdot> x \<in> H #> x"
by (auto simp add: r_coset_def)

lemma (in group) rcosetsI:
     "\<lbrakk>H \<subseteq> carrier(G); x \<in> carrier(G)\<rbrakk> \<Longrightarrow> H #> x \<in> rcosets H"
by (auto simp add: RCOSETS_def)

text{*Really needed?*}
lemma (in group) transpose_inv:
     "\<lbrakk>x \<cdot> y = z;  x \<in> carrier(G);  y \<in> carrier(G);  z \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> (inv x) \<cdot> z = y"
by (force simp add: m_assoc [symmetric])

subsection {* Normal subgroups *}

lemma normal_imp_subgroup: "H \<lhd> G ==> subgroup(H,G)"
  by (simp add: normal_def subgroup_def)

lemma (in group) normalI:
  "subgroup(H,G) \<Longrightarrow> (\<forall>x \<in> carrier(G). H #> x = x <# H) \<Longrightarrow> H \<lhd> G"
  by (simp add: normal_def normal_axioms_def)

lemma (in normal) inv_op_closed1:
     "\<lbrakk>x \<in> carrier(G); h \<in> H\<rbrakk> \<Longrightarrow> (inv x) \<cdot> h \<cdot> x \<in> H"
apply (insert coset_eq)
apply (auto simp add: l_coset_def r_coset_def)
apply (drule bspec, assumption)
apply (drule equalityD1 [THEN subsetD], blast, clarify)
apply (simp add: m_assoc)
apply (simp add: m_assoc [symmetric])
done

lemma (in normal) inv_op_closed2:
     "\<lbrakk>x \<in> carrier(G); h \<in> H\<rbrakk> \<Longrightarrow> x \<cdot> h \<cdot> (inv x) \<in> H"
apply (subgoal_tac "inv (inv x) \<cdot> h \<cdot> (inv x) \<in> H")
apply simp
apply (blast intro: inv_op_closed1)
done

text{*Alternative characterization of normal subgroups*}
lemma (in group) normal_inv_iff:
     "(N \<lhd> G) \<longleftrightarrow>
      (subgroup(N,G) & (\<forall>x \<in> carrier(G). \<forall>h \<in> N. x \<cdot> h \<cdot> (inv x) \<in> N))"
      (is "_ \<longleftrightarrow> ?rhs")
proof
  assume N: "N \<lhd> G"
  show ?rhs
    by (blast intro: N normal.inv_op_closed2 normal_imp_subgroup)
next
  assume ?rhs
  hence sg: "subgroup(N,G)"
    and closed: "\<And>x. x\<in>carrier(G) \<Longrightarrow> \<forall>h\<in>N. x \<cdot> h \<cdot> inv x \<in> N" by auto
  hence sb: "N \<subseteq> carrier(G)" by (simp add: subgroup.subset)
  show "N \<lhd> G"
  proof (intro normalI [OF sg], simp add: l_coset_def r_coset_def, clarify)
    fix x
    assume x: "x \<in> carrier(G)"
    show "(\<Union>h\<in>N. {h \<cdot> x}) = (\<Union>h\<in>N. {x \<cdot> h})"
    proof
      show "(\<Union>h\<in>N. {h \<cdot> x}) \<subseteq> (\<Union>h\<in>N. {x \<cdot> h})"
      proof clarify
        fix n
        assume n: "n \<in> N"
        show "n \<cdot> x \<in> (\<Union>h\<in>N. {x \<cdot> h})"
        proof (rule UN_I)
          from closed [of "inv x"]
          show "inv x \<cdot> n \<cdot> x \<in> N" by (simp add: x n)
          show "n \<cdot> x \<in> {x \<cdot> (inv x \<cdot> n \<cdot> x)}"
            by (simp add: x n m_assoc [symmetric] sb [THEN subsetD])
        qed
      qed
    next
      show "(\<Union>h\<in>N. {x \<cdot> h}) \<subseteq> (\<Union>h\<in>N. {h \<cdot> x})"
      proof clarify
        fix n
        assume n: "n \<in> N"
        show "x \<cdot> n \<in> (\<Union>h\<in>N. {h \<cdot> x})"
        proof (rule UN_I)
          show "x \<cdot> n \<cdot> inv x \<in> N" by (simp add: x n closed)
          show "x \<cdot> n \<in> {x \<cdot> n \<cdot> inv x \<cdot> x}"
            by (simp add: x n m_assoc sb [THEN subsetD])
        qed
      qed
    qed
  qed
qed

subsection{*More Properties of Cosets*}

lemma (in group) l_coset_subset_G:
     "\<lbrakk>H \<subseteq> carrier(G); x \<in> carrier(G)\<rbrakk> \<Longrightarrow> x <# H \<subseteq> carrier(G)"
by (auto simp add: l_coset_def subsetD)

lemma (in group) l_coset_swap:
     "\<lbrakk>y \<in> x <# H;  x \<in> carrier(G);  subgroup(H,G)\<rbrakk> \<Longrightarrow> x \<in> y <# H"
proof (simp add: l_coset_def)
  assume "\<exists>h\<in>H. y = x \<cdot> h"
    and x: "x \<in> carrier(G)"
    and sb: "subgroup(H,G)"
  then obtain h' where h': "h' \<in> H & x \<cdot> h' = y" by blast
  show "\<exists>h\<in>H. x = y \<cdot> h"
  proof
    show "x = y \<cdot> inv h'" using h' x sb
      by (auto simp add: m_assoc subgroup.subset [THEN subsetD])
    show "inv h' \<in> H" using h' sb
      by (auto simp add: subgroup.subset [THEN subsetD] subgroup.m_inv_closed)
  qed
qed

lemma (in group) l_coset_carrier:
     "\<lbrakk>y \<in> x <# H;  x \<in> carrier(G);  subgroup(H,G)\<rbrakk> \<Longrightarrow> y \<in> carrier(G)"
by (auto simp add: l_coset_def m_assoc
                   subgroup.subset [THEN subsetD] subgroup.m_closed)

lemma (in group) l_repr_imp_subset:
  assumes y: "y \<in> x <# H" and x: "x \<in> carrier(G)" and sb: "subgroup(H,G)"
  shows "y <# H \<subseteq> x <# H"
proof -
  from y
  obtain h' where "h' \<in> H" "x \<cdot> h' = y" by (auto simp add: l_coset_def)
  thus ?thesis using x sb
    by (auto simp add: l_coset_def m_assoc
                       subgroup.subset [THEN subsetD] subgroup.m_closed)
qed

lemma (in group) l_repr_independence:
  assumes y: "y \<in> x <# H" and x: "x \<in> carrier(G)" and sb: "subgroup(H,G)"
  shows "x <# H = y <# H"
proof
  show "x <# H \<subseteq> y <# H"
    by (rule l_repr_imp_subset,
        (blast intro: l_coset_swap l_coset_carrier y x sb)+)
  show "y <# H \<subseteq> x <# H" by (rule l_repr_imp_subset [OF y x sb])
qed

lemma (in group) setmult_subset_G:
     "\<lbrakk>H \<subseteq> carrier(G); K \<subseteq> carrier(G)\<rbrakk> \<Longrightarrow> H <#> K \<subseteq> carrier(G)"
by (auto simp add: set_mult_def subsetD)

lemma (in group) subgroup_mult_id: "subgroup(H,G) \<Longrightarrow> H <#> H = H"
apply (rule equalityI)
apply (auto simp add: subgroup.m_closed set_mult_def Sigma_def image_def)
apply (rule_tac x = x in bexI)
apply (rule bexI [of _ "\<one>"])
apply (auto simp add: subgroup.one_closed subgroup.subset [THEN subsetD])
done

subsubsection {* Set of inverses of an @{text r_coset}. *}

lemma (in normal) rcos_inv:
  assumes x:     "x \<in> carrier(G)"
  shows "set_inv (H #> x) = H #> (inv x)"
proof (simp add: r_coset_def SET_INV_def x inv_mult_group, safe intro!: equalityI)
  fix h
  assume h: "h \<in> H"
  {
    show "inv x \<cdot> inv h \<in> (\<Union>j\<in>H. {j \<cdot> inv x})"
    proof (rule UN_I)
      show "inv x \<cdot> inv h \<cdot> x \<in> H"
        by (simp add: inv_op_closed1 h x)
      show "inv x \<cdot> inv h \<in> {inv x \<cdot> inv h \<cdot> x \<cdot> inv x}"
        by (simp add: h x m_assoc)
    qed
  next
    show "h \<cdot> inv x \<in> (\<Union>j\<in>H. {inv x \<cdot> inv j})"
    proof (rule UN_I)
      show "x \<cdot> inv h \<cdot> inv x \<in> H"
        by (simp add: inv_op_closed2 h x)
      show "h \<cdot> inv x \<in> {inv x \<cdot> inv (x \<cdot> inv h \<cdot> inv x)}"
        by (simp add: h x m_assoc [symmetric] inv_mult_group)
    qed
  }
qed

subsubsection {*Theorems for @{text "<#>"} with @{text "#>"} or @{text "<#"}.*}

lemma (in group) setmult_rcos_assoc:
     "\<lbrakk>H \<subseteq> carrier(G); K \<subseteq> carrier(G); x \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> H <#> (K #> x) = (H <#> K) #> x"
by (force simp add: r_coset_def set_mult_def m_assoc)

lemma (in group) rcos_assoc_lcos:
     "\<lbrakk>H \<subseteq> carrier(G); K \<subseteq> carrier(G); x \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> (H #> x) <#> K = H <#> (x <# K)"
by (force simp add: r_coset_def l_coset_def set_mult_def m_assoc)

lemma (in normal) rcos_mult_step1:
     "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> (H #> x) <#> (H #> y) = (H <#> (x <# H)) #> y"
by (simp add: setmult_rcos_assoc subset
              r_coset_subset_G l_coset_subset_G rcos_assoc_lcos)

lemma (in normal) rcos_mult_step2:
     "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> (H <#> (x <# H)) #> y = (H <#> (H #> x)) #> y"
by (insert coset_eq, simp add: normal_def)

lemma (in normal) rcos_mult_step3:
     "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> (H <#> (H #> x)) #> y = H #> (x \<cdot> y)"
  by (simp add: setmult_rcos_assoc coset_mult_assoc
              subgroup_mult_id subset normal_axioms normal.axioms)

lemma (in normal) rcos_sum:
     "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> (H #> x) <#> (H #> y) = H #> (x \<cdot> y)"
by (simp add: rcos_mult_step1 rcos_mult_step2 rcos_mult_step3)

lemma (in normal) rcosets_mult_eq: "M \<in> rcosets H \<Longrightarrow> H <#> M = M"
  -- {* generalizes @{text subgroup_mult_id} *}
  by (auto simp add: RCOSETS_def subset
        setmult_rcos_assoc subgroup_mult_id normal_axioms normal.axioms)

subsubsection{*Two distinct right cosets are disjoint*}

definition
  r_congruent :: "[i,i] => i" ("rcong\<index> _" [60] 60) where
  "rcong\<^bsub>G\<^esub> H == {<x,y> \<in> carrier(G) * carrier(G). inv\<^bsub>G\<^esub> x \<cdot>\<^bsub>G\<^esub> y \<in> H}"

lemma (in subgroup) equiv_rcong:
   assumes "group(G)"
   shows "equiv (carrier(G), rcong H)"
proof -
  interpret group G by fact
  show ?thesis proof (simp add: equiv_def, intro conjI)
    show "rcong H \<subseteq> carrier(G) \<times> carrier(G)"
      by (auto simp add: r_congruent_def)
  next
    show "refl (carrier(G), rcong H)"
      by (auto simp add: r_congruent_def refl_def)
  next
    show "sym (rcong H)"
    proof (simp add: r_congruent_def sym_def, clarify)
      fix x y
      assume [simp]: "x \<in> carrier(G)" "y \<in> carrier(G)"
        and "inv x \<cdot> y \<in> H"
      hence "inv (inv x \<cdot> y) \<in> H" by simp
      thus "inv y \<cdot> x \<in> H" by (simp add: inv_mult_group)
    qed
  next
    show "trans (rcong H)"
    proof (simp add: r_congruent_def trans_def, clarify)
      fix x y z
      assume [simp]: "x \<in> carrier(G)" "y \<in> carrier(G)" "z \<in> carrier(G)"
        and "inv x \<cdot> y \<in> H" and "inv y \<cdot> z \<in> H"
      hence "(inv x \<cdot> y) \<cdot> (inv y \<cdot> z) \<in> H" by simp
      hence "inv x \<cdot> (y \<cdot> inv y) \<cdot> z \<in> H" by (simp add: m_assoc del: inv)
      thus "inv x \<cdot> z \<in> H" by simp
    qed
  qed
qed

text{*Equivalence classes of @{text rcong} correspond to left cosets.
  Was there a mistake in the definitions? I'd have expected them to
  correspond to right cosets.*}
lemma (in subgroup) l_coset_eq_rcong:
  assumes "group(G)"
  assumes a: "a \<in> carrier(G)"
  shows "a <# H = (rcong H) `` {a}"
proof -
  interpret group G by fact
  show ?thesis
    by (force simp add: r_congruent_def l_coset_def m_assoc [symmetric] a
      Collect_image_eq)
qed

lemma (in group) rcos_equation:
  assumes "subgroup(H, G)"
  shows
     "\<lbrakk>ha \<cdot> a = h \<cdot> b; a \<in> carrier(G);  b \<in> carrier(G);
        h \<in> H;  ha \<in> H;  hb \<in> H\<rbrakk>
      \<Longrightarrow> hb \<cdot> a \<in> (\<Union>h\<in>H. {h \<cdot> b})" (is "PROP ?P")
proof -
  interpret subgroup H G by fact
  show "PROP ?P"
    apply (rule UN_I [of "hb \<cdot> ((inv ha) \<cdot> h)"], simp)
    apply (simp add: m_assoc transpose_inv)
    done
qed

lemma (in group) rcos_disjoint:
  assumes "subgroup(H, G)"
  shows "\<lbrakk>a \<in> rcosets H; b \<in> rcosets H; a\<noteq>b\<rbrakk> \<Longrightarrow> a \<inter> b = 0" (is "PROP ?P")
proof -
  interpret subgroup H G by fact
  show "PROP ?P"
    apply (simp add: RCOSETS_def r_coset_def)
    apply (blast intro: rcos_equation assms sym)
    done
qed

subsection {*Order of a Group and Lagrange's Theorem*}

definition
  order :: "i => i" where
  "order(S) == |carrier(S)|"

lemma (in group) rcos_self:
  assumes "subgroup(H, G)"
  shows "x \<in> carrier(G) \<Longrightarrow> x \<in> H #> x" (is "PROP ?P")
proof -
  interpret subgroup H G by fact
  show "PROP ?P"
    apply (simp add: r_coset_def)
    apply (rule_tac x="\<one>" in bexI) apply (auto)
    done
qed

lemma (in group) rcosets_part_G:
  assumes "subgroup(H, G)"
  shows "\<Union>(rcosets H) = carrier(G)"
proof -
  interpret subgroup H G by fact
  show ?thesis
    apply (rule equalityI)
    apply (force simp add: RCOSETS_def r_coset_def)
    apply (auto simp add: RCOSETS_def intro: rcos_self assms)
    done
qed

lemma (in group) cosets_finite:
     "\<lbrakk>c \<in> rcosets H;  H \<subseteq> carrier(G);  Finite (carrier(G))\<rbrakk> \<Longrightarrow> Finite(c)"
apply (auto simp add: RCOSETS_def)
apply (simp add: r_coset_subset_G [THEN subset_Finite])
done

text{*More general than the HOL version, which also requires @{term G} to
      be finite.*}
lemma (in group) card_cosets_equal:
  assumes H:   "H \<subseteq> carrier(G)"
  shows "c \<in> rcosets H \<Longrightarrow> |c| = |H|"
proof (simp add: RCOSETS_def, clarify)
  fix a
  assume a: "a \<in> carrier(G)"
  show "|H #> a| = |H|"
  proof (rule eqpollI [THEN cardinal_cong])
    show "H #> a \<lesssim> H"
    proof (simp add: lepoll_def, intro exI)
      show "(\<lambda>y \<in> H#>a. y \<cdot> inv a) \<in> inj(H #> a, H)"
        by (auto intro: lam_type
                 simp add: inj_def r_coset_def m_assoc subsetD [OF H] a)
    qed
    show "H \<lesssim> H #> a"
    proof (simp add: lepoll_def, intro exI)
      show "(\<lambda>y\<in> H. y \<cdot> a) \<in> inj(H, H #> a)"
        by (auto intro: lam_type
                 simp add: inj_def r_coset_def  subsetD [OF H] a)
    qed
  qed
qed

lemma (in group) rcosets_subset_PowG:
     "subgroup(H,G) \<Longrightarrow> rcosets H \<subseteq> Pow(carrier(G))"
apply (simp add: RCOSETS_def)
apply (blast dest: r_coset_subset_G subgroup.subset)
done

theorem (in group) lagrange:
     "\<lbrakk>Finite(carrier(G)); subgroup(H,G)\<rbrakk>
      \<Longrightarrow> |rcosets H| #* |H| = order(G)"
apply (simp (no_asm_simp) add: order_def rcosets_part_G [symmetric])
apply (subst mult_commute)
apply (rule card_partition)
   apply (simp add: rcosets_subset_PowG [THEN subset_Finite])
  apply (simp add: rcosets_part_G)
 apply (simp add: card_cosets_equal [OF subgroup.subset])
apply (simp add: rcos_disjoint)
done

subsection {*Quotient Groups: Factorization of a Group*}

definition
  FactGroup :: "[i,i] => i" (infixl "Mod" 65) where
    --{*Actually defined for groups rather than monoids*}
  "G Mod H ==
     <rcosets\<^bsub>G\<^esub> H, \<lambda><K1,K2> \<in> (rcosets\<^bsub>G\<^esub> H) \<times> (rcosets\<^bsub>G\<^esub> H). K1 <#>\<^bsub>G\<^esub> K2, H, 0>"

lemma (in normal) setmult_closed:
     "\<lbrakk>K1 \<in> rcosets H; K2 \<in> rcosets H\<rbrakk> \<Longrightarrow> K1 <#> K2 \<in> rcosets H"
by (auto simp add: rcos_sum RCOSETS_def)

lemma (in normal) setinv_closed:
     "K \<in> rcosets H \<Longrightarrow> set_inv K \<in> rcosets H"
by (auto simp add: rcos_inv RCOSETS_def)

lemma (in normal) rcosets_assoc:
     "\<lbrakk>M1 \<in> rcosets H; M2 \<in> rcosets H; M3 \<in> rcosets H\<rbrakk>
      \<Longrightarrow> M1 <#> M2 <#> M3 = M1 <#> (M2 <#> M3)"
by (auto simp add: RCOSETS_def rcos_sum m_assoc)

lemma (in subgroup) subgroup_in_rcosets:
  assumes "group(G)"
  shows "H \<in> rcosets H"
proof -
  interpret group G by fact
  have "H #> \<one> = H"
    using _ subgroup_axioms by (rule coset_join2) simp_all
  then show ?thesis
    by (auto simp add: RCOSETS_def intro: sym)
qed

lemma (in normal) rcosets_inv_mult_group_eq:
     "M \<in> rcosets H \<Longrightarrow> set_inv M <#> M = H"
by (auto simp add: RCOSETS_def rcos_inv rcos_sum subgroup.subset normal_axioms normal.axioms)

theorem (in normal) factorgroup_is_group:
  "group (G Mod H)"
apply (simp add: FactGroup_def)
apply (rule groupI)
    apply (simp add: setmult_closed)
   apply (simp add: normal_imp_subgroup subgroup_in_rcosets)
  apply (simp add: setmult_closed rcosets_assoc)
 apply (simp add: normal_imp_subgroup
                  subgroup_in_rcosets rcosets_mult_eq)
apply (auto dest: rcosets_inv_mult_group_eq simp add: setinv_closed)
done

lemma (in normal) inv_FactGroup:
     "X \<in> carrier (G Mod H) \<Longrightarrow> inv\<^bsub>G Mod H\<^esub> X = set_inv X"
apply (rule group.inv_equality [OF factorgroup_is_group])
apply (simp_all add: FactGroup_def setinv_closed rcosets_inv_mult_group_eq)
done

text{*The coset map is a homomorphism from @{term G} to the quotient group
  @{term "G Mod H"}*}
lemma (in normal) r_coset_hom_Mod:
  "(\<lambda>a \<in> carrier(G). H #> a) \<in> hom(G, G Mod H)"
by (auto simp add: FactGroup_def RCOSETS_def hom_def rcos_sum intro: lam_type)

subsection{*The First Isomorphism Theorem*}

text{*The quotient by the kernel of a homomorphism is isomorphic to the
  range of that homomorphism.*}

definition
  kernel :: "[i,i,i] => i" where
    --{*the kernel of a homomorphism*}
  "kernel(G,H,h) == {x \<in> carrier(G). h ` x = \<one>\<^bsub>H\<^esub>}"

lemma (in group_hom) subgroup_kernel: "subgroup (kernel(G,H,h), G)"
apply (rule subgroup.intro)
apply (auto simp add: kernel_def group.intro)
done

text{*The kernel of a homomorphism is a normal subgroup*}
lemma (in group_hom) normal_kernel: "(kernel(G,H,h)) \<lhd> G"
apply (simp add: group.normal_inv_iff subgroup_kernel group.intro)
apply (simp add: kernel_def)
done

lemma (in group_hom) FactGroup_nonempty:
  assumes X: "X \<in> carrier (G Mod kernel(G,H,h))"
  shows "X \<noteq> 0"
proof -
  from X
  obtain g where "g \<in> carrier(G)"
             and "X = kernel(G,H,h) #> g"
    by (auto simp add: FactGroup_def RCOSETS_def)
  thus ?thesis
   by (auto simp add: kernel_def r_coset_def image_def intro: hom_one)
qed

lemma (in group_hom) FactGroup_contents_mem:
  assumes X: "X \<in> carrier (G Mod (kernel(G,H,h)))"
  shows "contents (h``X) \<in> carrier(H)"
proof -
  from X
  obtain g where g: "g \<in> carrier(G)"
             and "X = kernel(G,H,h) #> g"
    by (auto simp add: FactGroup_def RCOSETS_def)
  hence "h `` X = {h ` g}"
    by (auto simp add: kernel_def r_coset_def image_UN
                       image_eq_UN [OF hom_is_fun] g)
  thus ?thesis by (auto simp add: g)
qed

lemma mult_FactGroup:
     "[|X \<in> carrier(G Mod H); X' \<in> carrier(G Mod H)|]
      ==> X \<cdot>\<^bsub>(G Mod H)\<^esub> X' = X <#>\<^bsub>G\<^esub> X'"
by (simp add: FactGroup_def)

lemma (in normal) FactGroup_m_closed:
     "[|X \<in> carrier(G Mod H); X' \<in> carrier(G Mod H)|]
      ==> X <#>\<^bsub>G\<^esub> X' \<in> carrier(G Mod H)"
by (simp add: FactGroup_def setmult_closed)

lemma (in group_hom) FactGroup_hom:
     "(\<lambda>X \<in> carrier(G Mod (kernel(G,H,h))). contents (h``X))
      \<in> hom (G Mod (kernel(G,H,h)), H)"
proof (simp add: hom_def FactGroup_contents_mem lam_type mult_FactGroup normal.FactGroup_m_closed [OF normal_kernel], intro ballI)
  fix X and X'
  assume X:  "X  \<in> carrier (G Mod kernel(G,H,h))"
     and X': "X' \<in> carrier (G Mod kernel(G,H,h))"
  then
  obtain g and g'
           where "g \<in> carrier(G)" and "g' \<in> carrier(G)"
             and "X = kernel(G,H,h) #> g" and "X' = kernel(G,H,h) #> g'"
    by (auto simp add: FactGroup_def RCOSETS_def)
  hence all: "\<forall>x\<in>X. h ` x = h ` g" "\<forall>x\<in>X'. h ` x = h ` g'"
    and Xsub: "X \<subseteq> carrier(G)" and X'sub: "X' \<subseteq> carrier(G)"
    by (force simp add: kernel_def r_coset_def image_def)+
  hence "h `` (X <#> X') = {h ` g \<cdot>\<^bsub>H\<^esub> h ` g'}" using X X'
    by (auto dest!: FactGroup_nonempty
             simp add: set_mult_def image_eq_UN [OF hom_is_fun] image_UN
                       subsetD [OF Xsub] subsetD [OF X'sub])
  thus "contents (h `` (X <#> X')) = contents (h `` X) \<cdot>\<^bsub>H\<^esub> contents (h `` X')"
    by (simp add: all image_eq_UN [OF hom_is_fun] FactGroup_nonempty
                  X X' Xsub X'sub)
qed

text{*Lemma for the following injectivity result*}
lemma (in group_hom) FactGroup_subset:
     "\<lbrakk>g \<in> carrier(G); g' \<in> carrier(G); h ` g = h ` g'\<rbrakk>
      \<Longrightarrow>  kernel(G,H,h) #> g \<subseteq> kernel(G,H,h) #> g'"
apply (clarsimp simp add: kernel_def r_coset_def image_def)
apply (rename_tac y)
apply (rule_tac x="y \<cdot> g \<cdot> inv g'" in bexI)
apply (simp_all add: G.m_assoc)
done

lemma (in group_hom) FactGroup_inj:
     "(\<lambda>X\<in>carrier (G Mod kernel(G,H,h)). contents (h `` X))
      \<in> inj(carrier (G Mod kernel(G,H,h)), carrier(H))"
proof (simp add: inj_def FactGroup_contents_mem lam_type, clarify)
  fix X and X'
  assume X:  "X  \<in> carrier (G Mod kernel(G,H,h))"
     and X': "X' \<in> carrier (G Mod kernel(G,H,h))"
  then
  obtain g and g'
           where gX: "g \<in> carrier(G)"  "g' \<in> carrier(G)"
              "X = kernel(G,H,h) #> g" "X' = kernel(G,H,h) #> g'"
    by (auto simp add: FactGroup_def RCOSETS_def)
  hence all: "\<forall>x\<in>X. h ` x = h ` g" "\<forall>x\<in>X'. h ` x = h ` g'"
    and Xsub: "X \<subseteq> carrier(G)" and X'sub: "X' \<subseteq> carrier(G)"
    by (force simp add: kernel_def r_coset_def image_def)+
  assume "contents (h `` X) = contents (h `` X')"
  hence h: "h ` g = h ` g'"
    by (simp add: all image_eq_UN [OF hom_is_fun] FactGroup_nonempty
                  X X' Xsub X'sub)
  show "X=X'" by (rule equalityI) (simp_all add: FactGroup_subset h gX)
qed

lemma (in group_hom) kernel_rcoset_subset:
  assumes g: "g \<in> carrier(G)"
  shows "kernel(G,H,h) #> g \<subseteq> carrier (G)"
    by (auto simp add: g kernel_def r_coset_def)

text{*If the homomorphism @{term h} is onto @{term H}, then so is the
homomorphism from the quotient group*}
lemma (in group_hom) FactGroup_surj:
  assumes h: "h \<in> surj(carrier(G), carrier(H))"
  shows "(\<lambda>X\<in>carrier (G Mod kernel(G,H,h)). contents (h `` X))
         \<in> surj(carrier (G Mod kernel(G,H,h)), carrier(H))"
proof (simp add: surj_def FactGroup_contents_mem lam_type, clarify)
  fix y
  assume y: "y \<in> carrier(H)"
  with h obtain g where g: "g \<in> carrier(G)" "h ` g = y"
    by (auto simp add: surj_def)
  hence "(\<Union>x\<in>kernel(G,H,h) #> g. {h ` x}) = {y}"
    by (auto simp add: y kernel_def r_coset_def)
  with g show "\<exists>x\<in>carrier(G Mod kernel(G, H, h)). contents(h `` x) = y"
        --{*The witness is @{term "kernel(G,H,h) #> g"}*}
    by (force simp add: FactGroup_def RCOSETS_def
           image_eq_UN [OF hom_is_fun] kernel_rcoset_subset)
qed

text{*If @{term h} is a homomorphism from @{term G} onto @{term H}, then the
 quotient group @{term "G Mod (kernel(G,H,h))"} is isomorphic to @{term H}.*}
theorem (in group_hom) FactGroup_iso:
  "h \<in> surj(carrier(G), carrier(H))
   \<Longrightarrow> (\<lambda>X\<in>carrier (G Mod kernel(G,H,h)). contents (h``X)) \<in> (G Mod (kernel(G,H,h))) \<cong> H"
by (simp add: iso_def FactGroup_hom FactGroup_inj bij_def FactGroup_surj)

end


(*  Title:      CoW_Graph_Lemma.Graph_Lemma
    Author:     Štěpán Holub, Charles University
    Author:     Štěpán Starosta, CTU in Prague
*)

theory Graph_Lemma
  imports Combinatorics_Words.Submonoids

begin

chapter \<open>Graph Lemma\<close>

text\<open>The Graph Lemma is an important tool for gaining information about systems of word equations.
It yields an upper bound on the rank of the solution, that is, on the number of factors into all images of unknowns can be factorized.
The most straightforward application is showing that a system of equations admits periodic solutions only, which
in particular holds for any nontrivial equation over two words.

The name refers to a graph whose vertices are the unknowns of the system, and edges connect front letters of the left- and right-
hand sides of equations. The bound mentioned above is then the number of connected components of the graph.

We formalize the algebraic proof from @{cite Berstel1979} \<close>

text\<open>Let @{term C} be a set of generators, and $b$ its distinguished element. We define the set of all
 products that do not start with $b$.\<close>

inductive_set no_head :: "'a list set \<Rightarrow> 'a list \<Rightarrow> 'a list set"
  for C b where
  emp_in_no_head[simp]:  "\<epsilon> \<in> no_head C b"
  | "u \<in> C \<Longrightarrow> u \<noteq> b \<Longrightarrow> u \<in> no_head C b"
  | "u \<noteq> \<epsilon> \<Longrightarrow> u \<in> no_head C b \<Longrightarrow> v \<in> \<langle>C\<rangle> \<Longrightarrow>  u \<cdot> v \<in> no_head C b"

text\<open>The set is a submonoid of @{term "\<langle>C\<rangle>"}\<close>

lemma no_head_sub: "no_head C b \<subseteq> \<langle>C\<rangle>"
proof
  fix u assume "u \<in> no_head C b"
  show "u \<in> \<langle>C\<rangle>"
  proof (induction rule: no_head.induct[OF \<open>u \<in> no_head C b\<close>], auto)
    case (3 u v)
    then show "u \<cdot> v \<in> \<langle>C\<rangle>"
      using hull_closed by blast
  qed
qed

lemma no_head_closed:  "\<langle>no_head C b\<rangle> = no_head C b"
proof(intro equalityI)
  show "no_head C b \<subseteq> \<langle>no_head C b\<rangle>" by (simp add: genset_sub)
next
  show "\<langle>no_head C b\<rangle> \<subseteq> no_head C b"
  proof
    fix x assume "x \<in> \<langle>no_head C b\<rangle>"
    thus "x \<in> no_head C b"
    proof (induction rule: hull.induct, simp)
      case (prod_cl w1 w2)
      then show "w1 \<cdot> w2 \<in> no_head C b"
        using no_head.intros(3)[OF _ \<open>w1 \<in> no_head C b\<close>]
          in_mono[OF no_head_sub, of w2] by fastforce
    qed
  qed
qed

text\<open>We are interested mainly in the situation when @{term C} is a code.\<close>

context code
begin

text\<open>We characterize the set @{term no_head} in terms of the decomposition of its (nonempty) elements: the first factor is not b\<close>

lemma no_head_hd: assumes "u \<in> no_head \<C> b" and "u \<noteq> \<epsilon>" shows "hd (Dec \<C> u) \<noteq> b"
  using \<open>u \<noteq> \<epsilon>\<close>
proof(induct rule: no_head.induct[OF \<open>u \<in> no_head \<C> b\<close>], simp)
  case (2 u)
  then show ?case
    using code_el_dec by auto
next
  case (3 u v)
  have "Dec \<C> u \<noteq> \<epsilon>" and "u \<in> \<langle>\<C>\<rangle>" and "v \<in> \<langle>\<C>\<rangle>"
    using dec_nemp no_head_sub "3.hyps" by blast+
  show "hd (Dec \<C> u \<cdot> v) \<noteq> b"
    using "3.hyps"(3)[OF \<open>u \<noteq> \<epsilon>\<close>] hd_append2[OF \<open>Dec \<C> u \<noteq> \<epsilon>\<close>, of "Dec \<C> v"]
    unfolding code_dec_morph[OF \<open> u \<in> \<langle>\<C>\<rangle>\<close> \<open>v \<in> \<langle>\<C>\<rangle>\<close>] by simp
qed

lemma b_not_in_no_head: assumes "b \<in> \<C>" shows "b \<notin> no_head \<C> b"
  using \<open>b \<in> \<C>\<close> code_el_dec emp_not_in_code no_head_hd by fastforce

lemma hd_no_head: assumes "u \<in> \<langle>\<C>\<rangle>" and "hd (Dec \<C> u) \<noteq> b" shows "u \<in> no_head \<C> b"
proof(cases "u \<noteq> \<epsilon>")
  assume "u \<noteq> \<epsilon>"
  have "Dec \<C> u \<noteq> \<epsilon>"
    using dec_nemp'[OF \<open>u \<noteq> \<epsilon>\<close> \<open>u \<in> \<langle>\<C>\<rangle>\<close>].
  have "u = hd (Dec \<C> u) \<cdot> concat (tl (Dec \<C> u))"
    using concat.simps(2)[of "hd (Dec \<C> u)" "tl(Dec \<C> u)"]
    unfolding hd_Cons_tl[OF \<open>Dec \<C> u \<noteq> \<epsilon>\<close>] decI[OF \<open>u \<in> \<langle>\<C>\<rangle>\<close>].
  have "hd (Dec \<C> u) # tl (Dec \<C> u) \<in> lists \<C>" and "hd (Dec \<C> u) \<in> \<C>"
    using \<open>Dec \<C> u \<noteq> \<epsilon>\<close> \<open>u \<in> \<langle>\<C>\<rangle>\<close> dec_dom' lists_hd by auto blast
  have "concat (tl (decompose \<C> u)) \<in> \<langle>\<C>\<rangle>"
    using concat_tl[of "hd (Dec \<C> u)" "tl(Dec \<C> u)" \<C>, OF \<open>hd (Dec \<C> u) # tl (Dec \<C> u) \<in> lists \<C>\<close>].
  have "hd (Dec \<C> u) \<noteq> \<epsilon>" and "hd (Dec \<C> u) \<in> no_head \<C> b"
    using no_head.intros(2)[OF \<open>hd (Dec \<C> u) \<in> \<C>\<close> \<open>hd (Dec \<C> u) \<noteq> b\<close>] \<open>hd (Dec \<C> u) \<in> \<C>\<close> emp_not_in_code by auto
  from no_head.intros(3)[OF this \<open>concat (tl (decompose \<C> u)) \<in> \<langle>\<C>\<rangle>\<close> ]
  show "u \<in> no_head \<C> b"
    unfolding sym[OF \<open>u = hd (Dec \<C> u) \<cdot> concat (tl (Dec \<C> u))\<close>].
qed simp

corollary "no_head \<C> b = {u \<in> \<langle>\<C>\<rangle>. u = \<epsilon> \<or> hd (Dec \<C> u) \<noteq> b}"
proof(intro equalityI subsetI, standard)
  fix x assume  "x \<in> no_head \<C> b"
  thus "x \<in> \<langle>\<C>\<rangle> \<and> (x = \<epsilon> \<or> hd (Dec \<C> x) \<noteq> b)"
    using no_head_hd no_head_sub by blast
next
  fix x assume "x \<in> {u \<in> \<langle>\<C>\<rangle>. u = \<epsilon> \<or> hd (Dec \<C> u) \<noteq> b}"
  thus "x \<in> no_head \<C> b"
    using hd_no_head no_head.simps by blast
qed

end

text\<open>The set @{term no_head} is generated by the following set.\<close>

inductive_set no_head_gen :: "'a list set \<Rightarrow> 'a list \<Rightarrow> 'a list set"
  for C b where
    "u \<in> C \<Longrightarrow> u \<noteq> b \<Longrightarrow> u \<in> no_head_gen C b"
  | "u \<in> no_head_gen C b \<Longrightarrow>  u \<cdot> b \<in> no_head_gen C b"

lemma no_head_gen_set: "no_head_gen C b = {z \<cdot> b\<^sup>@k |z k. z \<in> C \<and> z \<noteq> b}"
proof(intro equalityI subsetI)
  fix x assume "x \<in> no_head_gen C b"
  hence "\<exists> z k. z \<in> C \<and> z \<noteq> b \<and> x = z \<cdot> b\<^sup>@k"
  proof (rule no_head_gen.induct)
    fix u assume "u \<in> C" and "u \<noteq> b"
    show "\<exists>z k. z \<in> C \<and> z \<noteq> b \<and> u = z \<cdot> b\<^sup>@k"
      using \<open>u \<in> C\<close> \<open>u \<noteq> b\<close> pow_zero by blast
  next
    fix u assume "u \<in> no_head_gen C b" and "\<exists>z k. z \<in> C \<and> z \<noteq> b \<and> u = z \<cdot> b\<^sup>@k"
    thus "\<exists>z k. z \<in> C \<and> z \<noteq> b \<and> u \<cdot> b = z \<cdot> b\<^sup>@k"
      using pow_Suc2_list append.assoc by metis
  qed
  thus "x \<in> {z \<cdot> b\<^sup>@k |z k. z \<in> C \<and> z \<noteq> b}"
    by auto
next
  fix x assume "x \<in> {z \<cdot> b \<^sup>@ k |z k. z \<in> C \<and> z \<noteq> b}"
  then obtain z k where "z \<in> C" and "z \<noteq> b" and "x = z\<cdot>b\<^sup>@k" by blast
  then show "x \<in> no_head_gen C b"
  proof(induct k arbitrary: x)
    case 0
    then show ?case
      by (simp add: \<open>z \<in> C\<close> \<open>z \<noteq> b\<close> no_head_gen.intros(1))
  next
    case (Suc k)
    from this(1)[OF this(2) this(3), of "z \<cdot> b \<^sup>@ k",
        THEN no_head_gen.intros(2), unfolded rassoc,
        folded pow_Suc2_list[of b k] \<open>x = z\<cdot>b\<^sup>@Suc k\<close>]
    show ?case
      by blast
  qed
qed

lemma no_head_genE: assumes "u \<in> no_head_gen C b"
  obtains z k where "z \<in> C" and  "z \<noteq> b" and "u = z \<cdot> b\<^sup>@k"
proof(induct rule: no_head_gen.induct[OF assms])
  case (1 u)
  show ?case
    using "1.prems"[OF "1.hyps", of 0] by simp
next
  case (2 u)
  have "(z \<cdot> b\<^sup>@k) \<cdot> b = z \<cdot> b\<^sup>@(Suc k)" for z k
    by (simp add: power_commutes)
  then show ?case
    using "2.prems" "2.hyps"(2) by blast
qed

context code
begin

text\<open>We show that this indeed is a set of generators\<close>

lemma emp_not_in_Cb: "\<epsilon> \<notin> no_head_gen \<C> b"
  by (simp add: emp_not_in_code no_head_gen_set)

lemma no_head_sub': "b \<in> \<C> \<Longrightarrow> no_head_gen \<C> b \<subseteq> no_head \<C> b"
proof
  fix u assume "b \<in> \<C>" "u \<in> no_head_gen \<C> b"
  show "u \<in> no_head \<C> b"
  proof (induction rule: no_head_gen.induct[OF \<open>u \<in> no_head_gen \<C> b\<close>], simp add: no_head.intros(2))
    case (2 u)
    show "u \<cdot> b \<in> no_head \<C> b"
      using no_head.intros(3)[OF _ \<open>u \<in> no_head \<C> b\<close> gen_in[OF \<open>b \<in> \<C>\<close>]]
       "2.hyps" emp_not_in_Cb by blast
  qed
qed

lemma no_head_generates0: assumes "v \<in> \<langle>\<C>\<rangle>" shows
  "u \<noteq> \<epsilon> \<longrightarrow> u \<in> \<langle>no_head_gen \<C> b\<rangle> \<longrightarrow> u \<cdot> v \<in>  \<langle>no_head_gen \<C> b\<rangle>"
proof (induct arbitrary: u rule: hull.induct[OF \<open>v \<in> \<langle>\<C>\<rangle>\<close>], simp)
  case (2 w1 w2)
  then show ?case
  proof(cases "w1 = b")
    assume "w1 \<noteq> b"
    show ?thesis
      using "2.hyps"(1) emp_not_in_code  no_head_gen.intros(1)[OF \<open>w1 \<in> \<C>\<close> \<open>w1 \<noteq> b\<close>,THEN gen_in]
            "2.hyps"(3)[of w1] hull_closed[of u "no_head_gen \<C> b" "w1\<cdot> w2"] by blast
  next
    assume "w1 = b"
    show ?thesis
    proof (standard, standard)
      assume "u \<noteq> \<epsilon>" and "u \<in> \<langle>no_head_gen \<C> b\<rangle>"
      hence dec_nemp: "Dec (no_head_gen \<C> b) u \<noteq> \<epsilon>"
        using dec_nemp' by blast
      from concat_butlast_last[OF this]
      have u_w1: "u \<cdot> w1 = concat (butlast (Dec (no_head_gen \<C> b) u)) \<cdot> (last (Dec (no_head_gen \<C> b) u) \<cdot> w1)"
        unfolding decI[OF \<open>u \<in> \<langle>no_head_gen \<C> b\<rangle>\<close>] by simp
      from dec_dom'[OF \<open>u \<in> \<langle>no_head_gen \<C> b\<rangle>\<close>] append_butlast_last_id[OF dec_nemp]
      have con_but: "concat (butlast (Dec (no_head_gen \<C> b) u)) \<in> \<langle>no_head_gen \<C> b\<rangle>" and last_in: "last (Dec (no_head_gen \<C> b) u) \<in> no_head_gen \<C> b"
        using append_in_lists_conv[of "butlast (Dec (no_head_gen \<C> b) u)" "[last (Dec (no_head_gen \<C> b) u)]" "no_head_gen \<C> b"]
          concat_in_hull'[of "butlast (Dec (no_head_gen \<C> b) u)" "no_head_gen \<C> b"] by auto
      hence "last (Dec (no_head_gen \<C> b) u) \<cdot> w1 \<in> no_head_gen \<C> b"
        unfolding \<open>w1 = b\<close> using  no_head_gen.intros(2)[of "last (Dec (no_head_gen \<C> b) u)" \<C> b] by blast
      from this[THEN  gen_in,THEN[2] hull_closed, OF con_but]
      have "u \<cdot> w1 \<in> \<langle>no_head_gen \<C> b\<rangle>"
        unfolding u_w1.
      from "2.hyps"(3)[rule_format, OF _ this, unfolded rassoc]
      show "u \<cdot> w1 \<cdot> w2 \<in> \<langle>no_head_gen \<C> b\<rangle>"
        using  pref_nemp[OF \<open>u\<noteq>\<epsilon>\<close>] by blast
    qed
  qed
qed

theorem no_head_generates: assumes "b \<in> \<C>" shows "\<langle>no_head_gen \<C> b\<rangle> =  no_head \<C> b"
proof (intro equalityI)
  show "\<langle>no_head_gen \<C> b\<rangle> \<subseteq> no_head \<C> b"
    using hull_mon[OF no_head_sub'[OF \<open>b \<in> \<C>\<close>]] unfolding no_head_closed.
  show "no_head \<C> b \<subseteq> \<langle>no_head_gen \<C> b\<rangle>"
  proof (intro subsetI)
    fix x assume "x \<in> no_head \<C> b"
    show "x \<in> \<langle>no_head_gen \<C> b\<rangle>"
      by (induct rule: no_head.induct[OF \<open>x \<in> no_head \<C> b\<close>],auto, simp add: gen_in no_head_gen.intros(1),simp add: no_head_generates0)
  qed
qed

text\<open>Moreover, the generating set @{term no_head_gen} is a code\<close>

lemma lists_no_head_sub: "b \<in> \<C> \<Longrightarrow> us \<in> lists (no_head_gen \<C> b) \<Longrightarrow> us \<in> lists \<langle>\<C>\<rangle>"
  using no_head_sub' no_head_sub by blast

lemma ref_hd: assumes "z \<in> \<C>" and  "b \<in> \<C>" and "z \<noteq> b" and "vs \<in> lists (no_head_gen \<C> b)"
  shows "refine \<C> ((z\<cdot>b\<^sup>@k) # vs) = [z]\<cdot>[b]\<^sup>@k \<cdot> refine \<C> vs"
proof-
  have "refine \<C> ((z\<cdot>b\<^sup>@k) # vs) = (Dec \<C> (z\<cdot>b\<^sup>@k)) \<cdot> refine \<C> vs"
    using ref_pop_hd lists_no_head_sub[OF \<open>b \<in> \<C>\<close>]  by simp
  have "[z]\<cdot>[b]\<^sup>@k \<in> lists \<C>"
    by (induct k, simp add: \<open>z \<in> \<C>\<close>, simp add: \<open>b \<in> \<C>\<close>)
  have "concat ([z]\<cdot>[b]\<^sup>@k) = z \<cdot> b\<^sup>@k"
    using concat_sing_pow by auto
  hence "Dec \<C> (z\<cdot>b\<^sup>@k) = [z]\<cdot>[b]\<^sup>@k"
    using  code.code_unique_dec[OF code_axioms \<open>[z]\<cdot>[b]\<^sup>@k \<in> lists \<C>\<close>] by auto
  thus ?thesis
    by simp
qed

lemma no_head_gen_code_ind_step:
  assumes "vs \<in> lists (no_head_gen \<C> b)" "us \<in> lists (no_head_gen \<C> b)" "b \<in> \<C>"
    and eq: "[b]\<^sup>@ku \<cdot> (refine \<C> us) = [b]\<^sup>@kv \<cdot> (refine \<C> vs)"
  shows  "ku = kv"
proof-
  {fix ku :: nat and kv and us and vs and b
    assume "kv \<le> ku" "[b]\<^sup>@ku \<cdot> (refine \<C> us) = [b]\<^sup>@kv \<cdot> (refine \<C> vs)"
      "vs \<in> lists (no_head_gen \<C> b)" "us \<in> lists (no_head_gen \<C> b)" "b \<in> \<C>"
    have  "concat vs \<in> no_head \<C> b"
      using  \<open>vs \<in> lists (no_head_gen \<C> b)\<close> no_head_generates[OF \<open>b \<in> \<C>\<close>] by fastforce
    have  "Ref \<C> vs = Dec \<C> (concat vs)"
      using \<open>vs \<in> lists (no_head_gen \<C> b)\<close> \<open>b \<in> \<C>\<close> code_unique_ref lists_no_head_sub by auto
    have "vs \<noteq> \<epsilon> \<Longrightarrow> concat vs \<noteq> \<epsilon>"
      using  emp_not_in_Cb[of b] concat.simps(2) \<open>vs \<in> lists (no_head_gen \<C> b)\<close>[unfolded lists.simps[of vs]]
        pref_nemp by auto
    have "[b]\<^sup>@(ku - kv) \<cdot> (refine \<C> us) = refine \<C> vs"
      using \<open>kv \<le> ku\<close> eq pop_pow_cancel \<open>[b]\<^sup>@ku \<cdot> (refine \<C> us) = [b]\<^sup>@kv \<cdot> (refine \<C> vs) \<close>by blast
    hence "ku - kv \<noteq> 0 \<Longrightarrow> hd (refine \<C> vs) = b \<and> vs \<noteq> \<epsilon>"
      using hd_append2[of "[b]\<^sup>@(ku - kv)" "refine \<C> us"]  \<open>[b]\<^sup>@(ku - kv) \<cdot> (refine \<C> us) = refine \<C> vs\<close>
        hd_sing_power[of "ku - kv" b]
        append_is_Nil_conv[of "[b]\<^sup>@(ku - kv)" "refine \<C> us"]  sing_pow_empty[of b "ku - kv"]
        dec_emp[of \<C>] by auto
    hence "ku = kv"
      using \<open>kv \<le> ku\<close> no_head_hd[OF \<open>concat vs \<in> no_head \<C> b\<close>] \<open>vs \<noteq> \<epsilon> \<Longrightarrow> concat vs \<noteq> \<epsilon>\<close>
      unfolding \<open>Ref \<C> vs = Dec \<C> (concat vs)\<close> by auto}
  thus ?thesis  using assms nat_le_linear[of ku kv] by metis
qed

lemma no_head_gen_code':
  "b \<in> \<C> \<Longrightarrow> xs \<in> lists (no_head_gen \<C> b)
   \<Longrightarrow> ys \<in>  lists (no_head_gen \<C> b) \<Longrightarrow> concat xs = concat ys \<Longrightarrow> xs = ys"
proof (induct xs ys rule: list_induct2', simp, simp add: emp_not_in_Cb, simp add: emp_not_in_Cb)
  case (4 hx xs hy ys)
  then show ?case
  proof-
    have "hx # xs \<in> lists \<langle>\<C>\<rangle>" and "hy # ys \<in> lists \<langle>\<C>\<rangle>"
      using \<open>b \<in> \<C>\<close>  \<open>hx # xs \<in> lists (no_head_gen \<C> b)\<close> \<open>hy # ys \<in> lists (no_head_gen \<C> b)\<close> lists_no_head_sub by blast+
    have eq: "refine \<C> (hx#xs) = refine \<C>  (hy#ys)"
      using \<open>concat (hx # xs) = concat (hy # ys)\<close> \<open>hx # xs \<in> lists \<langle>\<C>\<rangle>\<close> \<open>hy # ys \<in> lists \<langle>\<C>\<rangle>\<close>
      using code_unique_ref by presburger
    have "hx \<in> (no_head_gen \<C> b)" and "hy \<in> (no_head_gen \<C> b)"
      using \<open>hx # xs \<in> lists (no_head_gen \<C> b)\<close> \<open>hy # ys \<in> lists (no_head_gen \<C> b)\<close> by auto+
    then obtain zx zy kx ky where "hx = zx \<cdot> b\<^sup>@kx" and "hy = zy \<cdot> b\<^sup>@ky" "zx \<noteq> b" "zy \<noteq> b" "zx \<in> \<C>" "zy \<in> \<C>"
      using no_head_genE by metis
    have r1: "refine \<C> (hx#xs) = [zx] \<cdot> [b]\<^sup>@kx \<cdot> refine \<C> xs"
      using \<open>hx = zx \<cdot> b\<^sup>@kx\<close> \<open>zx \<in> \<C>\<close> \<open>zx \<noteq> b\<close> ref_hd \<open>b \<in> \<C>\<close> by auto
    have r2: "refine \<C> (hy#ys) = [zy] \<cdot> [b]\<^sup>@ky \<cdot> refine \<C> ys"
      using \<open>hy = zy \<cdot> b\<^sup>@ky\<close> \<open>zy \<in> \<C>\<close> \<open>zy \<noteq> b\<close> ref_hd \<open>b \<in> \<C>\<close> by auto
    hence "zx = zy"
      using r1 r2 eq by auto
    hence "[b]\<^sup>@kx \<cdot> refine \<C> xs = [b]\<^sup>@ky \<cdot> refine \<C> ys"
      using eq r1 r2 by auto
    hence "kx = ky"
      using no_head_gen_code_ind_step \<open>b \<in> \<C>\<close> \<open>hx # xs \<in> lists (no_head_gen \<C> b)\<close> \<open>hy # ys \<in> lists (no_head_gen \<C> b)\<close>
        listsE  by metis
    hence "hx = hy"
      by (simp add: \<open>hx = zx \<cdot> b\<^sup>@kx\<close> \<open>hy = zy \<cdot> b\<^sup>@ky\<close> \<open>zx = zy\<close>)
    hence "xs = ys" using "4.hyps"
      using \<open>hx # xs \<in> lists (no_head_gen \<C> b)\<close> \<open>hy # ys \<in> lists (no_head_gen \<C> b)\<close>
        \<open>concat (hx # xs) = concat (hy # ys)\<close> \<open>b \<in> \<C>\<close> by auto
    thus ?thesis
      by (simp add: \<open>hx = hy\<close>)
  qed
qed

end

theorem no_head_gen_code:
  assumes "code C" and "b \<in> C"
  shows "code {z \<cdot> b\<^sup>@k | z k. z \<in> C \<and> z \<noteq> b}"
  using code.no_head_gen_code'[OF \<open>code C\<close> \<open>b \<in> C\<close>] code.intro
  unfolding no_head_gen_set  by blast

text\<open>We are now ready to prove the Graph Lemma \<close>

theorem graph_lemma: "\<BB>\<^sub>F X = {hd (Dec (\<BB>\<^sub>F X) x) | x. x \<in> X \<and> x \<noteq> \<epsilon>}"
proof
  \<comment> \<open>the core is to show that each element of the free basis must be a head\<close>
  show "\<BB>\<^sub>F X \<subseteq> {hd (Dec (\<BB>\<^sub>F X) x) | x. x \<in> X \<and> x \<noteq> \<epsilon>}"
  proof (rule ccontr)
    \<comment> \<open>Assume the contrary.\<close>
     assume "\<not> \<BB>\<^sub>F X \<subseteq> {hd (Dec \<BB>\<^sub>F X x) |x. x \<in> X \<and> x \<noteq> \<epsilon>}"
    \<comment> \<open>And let b be the not-head\<close>
    then obtain b where "b \<in> \<BB>\<^sub>F X" and nohd: "\<And> x.   x \<in> X \<and> x \<noteq> \<epsilon> \<Longrightarrow> hd (Dec (\<BB>\<^sub>F X) x) \<noteq> b"
      by blast
    interpret code "\<BB>\<^sub>F X"
        using free_basis_code by auto
          \<comment> \<open>For contradiction: We have a free hull which does not contain b but contains X.\<close>
      let ?Cb = "no_head_gen (\<BB>\<^sub>F X) b"
      have "code ?Cb"
        using \<open>b \<in> \<BB>\<^sub>F X\<close> code_def no_head_gen_code' by blast
      have "b \<notin> \<langle>?Cb\<rangle>"
        using \<open>b \<in> \<BB>\<^sub>F X\<close> b_not_in_no_head no_head_generates by blast
      have "X \<subseteq> \<langle>?Cb\<rangle>"
      proof
        fix x assume "x \<in> X"
        hence "x \<in> \<langle>\<BB>\<^sub>F X\<rangle>"
          using basis_gen_hull free_hull.free_gen_in
          unfolding free_basis_def by blast
        have " x \<in> X \<and> x \<noteq> \<epsilon> \<Longrightarrow> x \<in> \<langle>?Cb\<rangle>"
          using hd_no_head[OF \<open>x \<in> \<langle>\<BB>\<^sub>F X\<rangle>\<close> nohd]
            \<open>b \<in> \<BB>\<^sub>F X\<close> no_head_generates by blast
        thus "x \<in> \<langle>?Cb\<rangle>"
          using \<open>x \<in> X\<close> by blast
      qed
      have "\<langle>X\<rangle>\<^sub>F \<subseteq> \<langle>?Cb\<rangle>"
        using free_hull_min[OF \<open>code ?Cb\<close> \<open>X \<subseteq> \<langle>?Cb\<rangle>\<close>].
      from this[unfolded subset_eq, rule_format, of b]
      show False
        using \<open>b \<in> \<BB>\<^sub>F X\<close> \<open>b \<notin> \<langle>?Cb\<rangle>\<close> basisD simp_el_el unfolding free_basis_def by blast
  qed
next
  \<comment> \<open>The opposite inclusion is easy\<close>
  show "{hd (Dec (\<BB>\<^sub>F X) x) | x.  x \<in> X \<and> x \<noteq> \<epsilon>} \<subseteq> \<BB>\<^sub>F X"
    using basis_gen_hull_free dec_hd genset_sub_free by blast
qed

section \<open>Binary code\<close>

text\<open>We illustrate the use of the Graph Lemma in an alternative proof of the fact that two non-commuting words form a code.
See also @{thm no_comm_bin_code [no_vars]} in @{theory Combinatorics_Words.CoWBasic}.

First, we prove a lemma which is the core of the alternative proof.
\<close>

lemma non_comm_hds_neq: assumes "u \<cdot> v \<noteq> v \<cdot> u" shows "hd (Dec \<BB>\<^sub>F {u,v} u) \<noteq> hd (Dec \<BB>\<^sub>F {u,v} v)"
proof
  have "u \<noteq> \<epsilon>" and "v \<noteq> \<epsilon>" using assms by auto
  hence basis: "\<BB>\<^sub>F {u,v} = {hd (Dec \<BB>\<^sub>F {u,v} u),hd (Dec \<BB>\<^sub>F {u,v} v)}"
    using graph_lemma[of "{u,v}"] by blast
  assume eq: "hd (Dec \<BB>\<^sub>F {u,v} u) = hd (Dec \<BB>\<^sub>F {u,v} v)"
  hence "u \<in> (hd (Dec \<BB>\<^sub>F {u,v} u))*"
    using basis unfolding free_basis_def
    by (metis basis_gen_hull free_hull.simps free_hull_hull insertI1 insert_absorb2 sing_gen)
  moreover have  "v \<in> (hd (Dec \<BB>\<^sub>F {u,v} u))*"
    using basis eq unfolding free_basis_def
    by (metis basis_gen_hull free_hull_hull genset_sub_free insert_absorb2 insert_subset sing_gen)
  ultimately show False
    using comm_root assms by blast
qed

theorem assumes "u \<cdot> v \<noteq> v \<cdot> u"
  shows "xs \<in> lists {u, v} \<Longrightarrow> ys \<in> lists {u, v} \<Longrightarrow> concat xs = concat ys \<Longrightarrow> xs = ys"
proof (induct xs ys rule: list_induct2', simp)
  case (2 x xs)
  then show ?case
    using Nil_is_append_conv append_Nil assms by auto
next
  case (3 y ys)
  then show ?case
    using Nil_is_append_conv append_Nil assms by auto
next
  case (4 x xs y ys)
  then show ?case
  proof-
    have "u \<noteq> \<epsilon>" and "v \<noteq> \<epsilon>" using assms by force+
    hence "x \<noteq> \<epsilon>" and "y \<noteq> \<epsilon>" using \<open>x # xs \<in> lists {u, v}\<close> \<open>y # ys \<in> lists {u, v}\<close> by auto
    have or_x: "x = u \<or> x = v" and or_y: "y = u \<or> y = v" using \<open>x # xs \<in> lists {u, v}\<close> \<open>y # ys \<in> lists {u, v}\<close> by auto

    have hd_z: "z \<noteq> \<epsilon> \<Longrightarrow> z # zs \<in> lists {u, v} \<Longrightarrow> hd (Dec \<BB>\<^sub>F {u,v} (concat (z#zs))) = hd (Dec \<BB>\<^sub>F {u,v} z)" for z zs
    proof-
      assume "z \<noteq> \<epsilon>" "z # zs \<in> lists {u, v}"
      have "z \<in> \<langle>{u,v}\<rangle>\<^sub>F"
        using \<open>z # zs \<in> lists {u, v}\<close> by auto
      moreover have "concat zs \<in> \<langle>{u,v}\<rangle>\<^sub>F"
        using concat_tl[OF \<open>z # zs \<in> lists {u, v}\<close>] hull_in_free_hull[of "{u,v}"] by blast
      ultimately have "Dec \<BB>\<^sub>F {u,v} (concat (z#zs)) = (Dec \<BB>\<^sub>F {u,v} z) \<cdot> (Dec \<BB>\<^sub>F {u,v} (concat zs))"
        using free_basis_dec_morph[of z "{u,v}" "concat zs"] by fastforce
      moreover have "Dec \<BB>\<^sub>F {u,v} z \<noteq> \<epsilon>"
        using \<open>z \<in> \<langle>{u, v}\<rangle>\<^sub>F\<close> basis_gen_hull_free dec_nemp'[OF  \<open>z \<noteq> \<epsilon>\<close>] by blast
      ultimately show "hd (Dec \<BB>\<^sub>F {u,v} (concat (z#zs))) = hd (Dec \<BB>\<^sub>F {u,v} z)"
        using hd_append  by simp
    qed

    have "hd (Dec \<BB>\<^sub>F {u,v} u) \<noteq> hd (Dec \<BB>\<^sub>F {u,v} v)"
      using non_comm_hds_neq[OF assms].
    hence "x  = y"
      using hd_z[OF \<open>x \<noteq> \<epsilon>\<close> \<open>x # xs \<in> lists {u, v}\<close> , unfolded \<open>concat (x # xs) = concat (y # ys)\<close> hd_z[OF \<open>y \<noteq> \<epsilon>\<close> \<open>y # ys \<in> lists {u, v}\<close>]] or_x or_y
      by fastforce
    thus ?thesis
      using "4.hyps" "4.prems" by auto
  qed
qed

end


(*  Author:  Florian Haftmann, TUM
*)

section \<open>Proof of concept for algebraically founded bit word types\<close>

theory Word
  imports
    Main
    "HOL-Library.Type_Length"
    "HOL-ex.Bit_Operations"
begin

subsection \<open>Preliminaries\<close>

definition signed_take_bit :: "nat \<Rightarrow> int \<Rightarrow> int"
  where signed_take_bit_eq_take_bit:
    "signed_take_bit n k = take_bit (Suc n) (k + 2 ^ n) - 2 ^ n"

lemma signed_take_bit_eq_take_bit':
  "signed_take_bit (n - Suc 0) k = take_bit n (k + 2 ^ (n - 1)) - 2 ^ (n - 1)" if "n > 0"
  using that by (simp add: signed_take_bit_eq_take_bit)

lemma signed_take_bit_0 [simp]:
  "signed_take_bit 0 k = - (k mod 2)"
proof (cases "even k")
  case True
  then have "odd (k + 1)"
    by simp
  then have "(k + 1) mod 2 = 1"
    by (simp add: even_iff_mod_2_eq_zero)
  with True show ?thesis
    by (simp add: signed_take_bit_eq_take_bit take_bit_Suc)
next
  case False
  then show ?thesis
    by (simp add: signed_take_bit_eq_take_bit odd_iff_mod_2_eq_one take_bit_Suc)
qed

lemma signed_take_bit_Suc:
  "signed_take_bit (Suc n) k = signed_take_bit n (k div 2) * 2 + k mod 2"
  by (simp add: odd_iff_mod_2_eq_one signed_take_bit_eq_take_bit algebra_simps take_bit_Suc)

lemma signed_take_bit_of_0 [simp]:
  "signed_take_bit n 0 = 0"
  by (simp add: signed_take_bit_eq_take_bit take_bit_eq_mod)

lemma signed_take_bit_of_minus_1 [simp]:
  "signed_take_bit n (- 1) = - 1"
  by (induct n) (simp_all add: signed_take_bit_Suc)

lemma signed_take_bit_eq_iff_take_bit_eq:
  "signed_take_bit (n - Suc 0) k = signed_take_bit (n - Suc 0) l \<longleftrightarrow> take_bit n k = take_bit n l" (is "?P \<longleftrightarrow> ?Q")
  if "n > 0"
proof -
  from that obtain m where m: "n = Suc m"
    by (cases n) auto
  show ?thesis
  proof
    assume ?Q
    have "take_bit (Suc m) (k + 2 ^ m) =
      take_bit (Suc m) (take_bit (Suc m) k + take_bit (Suc m) (2 ^ m))"
      by (simp only: take_bit_add)
    also have "\<dots> =
      take_bit (Suc m) (take_bit (Suc m) l + take_bit (Suc m) (2 ^ m))"
      by (simp only: \<open>?Q\<close> m [symmetric])
    also have "\<dots> = take_bit (Suc m) (l + 2 ^ m)"
      by (simp only: take_bit_add)
    finally show ?P
      by (simp only: signed_take_bit_eq_take_bit m) simp
  next
    assume ?P
    with that have "(k + 2 ^ (n - Suc 0)) mod 2 ^ n = (l + 2 ^ (n - Suc 0)) mod 2 ^ n"
      by (simp add: signed_take_bit_eq_take_bit' take_bit_eq_mod)
    then have "(i + (k + 2 ^ (n - Suc 0))) mod 2 ^ n = (i + (l + 2 ^ (n - Suc 0))) mod 2 ^ n" for i
      by (metis mod_add_eq)
    then have "k mod 2 ^ n = l mod 2 ^ n"
      by (metis add_diff_cancel_right' uminus_add_conv_diff)
    then show ?Q
      by (simp add: take_bit_eq_mod)
  qed
qed

subsection \<open>Bit strings as quotient type\<close>

subsubsection \<open>Basic properties\<close>

quotient_type (overloaded) 'a word = int / "\<lambda>k l. take_bit LENGTH('a) k = take_bit LENGTH('a::len0) l"
  by (auto intro!: equivpI reflpI sympI transpI)

instantiation word :: (len0) "{semiring_numeral, comm_semiring_0, comm_ring}"
begin

lift_definition zero_word :: "'a word"
  is 0
  .

lift_definition one_word :: "'a word"
  is 1
  .

lift_definition plus_word :: "'a word \<Rightarrow> 'a word \<Rightarrow> 'a word"
  is plus
  by (subst take_bit_add [symmetric]) (simp add: take_bit_add)

lift_definition uminus_word :: "'a word \<Rightarrow> 'a word"
  is uminus
  by (subst take_bit_minus [symmetric]) (simp add: take_bit_minus)

lift_definition minus_word :: "'a word \<Rightarrow> 'a word \<Rightarrow> 'a word"
  is minus
  by (subst take_bit_diff [symmetric]) (simp add: take_bit_diff)

lift_definition times_word :: "'a word \<Rightarrow> 'a word \<Rightarrow> 'a word"
  is times
  by (auto simp add: take_bit_eq_mod intro: mod_mult_cong)

instance
  by standard (transfer; simp add: algebra_simps)+

end

instance word :: (len) comm_ring_1
  by standard (transfer; simp)+

quickcheck_generator word
  constructors:
    "zero_class.zero :: ('a::len0) word",
    "numeral :: num \<Rightarrow> ('a::len0) word",
    "uminus :: ('a::len0) word \<Rightarrow> ('a::len0) word"

context
  includes lifting_syntax
  notes power_transfer [transfer_rule]
begin

lemma power_transfer_word [transfer_rule]:
  \<open>(pcr_word ===> (=) ===> pcr_word) (^) (^)\<close>
  by transfer_prover

end

subsubsection \<open>Conversions\<close>

context
  includes lifting_syntax
  notes
    transfer_rule_of_bool [transfer_rule]
    transfer_rule_numeral [transfer_rule]
    transfer_rule_of_nat [transfer_rule]
    transfer_rule_of_int [transfer_rule]
begin

lemma [transfer_rule]:
  "((=) ===> (pcr_word :: int \<Rightarrow> 'a::len0 word \<Rightarrow> bool)) numeral numeral"
  by transfer_prover

lemma [transfer_rule]:
  "((=) ===> pcr_word) int of_nat"
  by transfer_prover

lemma [transfer_rule]:
  "((=) ===> pcr_word) (\<lambda>k. k) of_int"
proof -
  have "((=) ===> pcr_word) of_int of_int"
    by transfer_prover
  then show ?thesis by (simp add: id_def)
qed

end

lemma abs_word_eq:
  "abs_word = of_int"
  by (rule ext) (transfer, rule)

context semiring_1
begin

lift_definition unsigned :: "'b::len0 word \<Rightarrow> 'a"
  is "of_nat \<circ> nat \<circ> take_bit LENGTH('b)"
  by simp

lemma unsigned_0 [simp]:
  "unsigned 0 = 0"
  by transfer simp

end

context semiring_char_0
begin

lemma word_eq_iff_unsigned:
  "a = b \<longleftrightarrow> unsigned a = unsigned b"
  by safe (transfer; simp add: eq_nat_nat_iff)

end

instantiation word :: (len0) equal
begin

definition equal_word :: "'a word \<Rightarrow> 'a word \<Rightarrow> bool"
  where "equal_word a b \<longleftrightarrow> (unsigned a :: int) = unsigned b"

instance proof
  fix a b :: "'a word"
  show "HOL.equal a b \<longleftrightarrow> a = b"
    using word_eq_iff_unsigned [of a b] by (auto simp add: equal_word_def)
qed

end

context ring_1
begin

lift_definition signed :: "'b::len word \<Rightarrow> 'a"
  is "of_int \<circ> signed_take_bit (LENGTH('b) - 1)"
  by (simp add: signed_take_bit_eq_iff_take_bit_eq [symmetric])

lemma signed_0 [simp]:
  "signed 0 = 0"
  by transfer simp

end

lemma unsigned_of_nat [simp]:
  "unsigned (of_nat n :: 'a word) = take_bit LENGTH('a::len) n"
  by transfer (simp add: nat_eq_iff take_bit_eq_mod zmod_int)

lemma of_nat_unsigned [simp]:
  "of_nat (unsigned a) = a"
  by transfer simp

lemma of_int_unsigned [simp]:
  "of_int (unsigned a) = a"
  by transfer simp

lemma unsigned_nat_less:
  \<open>unsigned a < (2 ^ LENGTH('a) :: nat)\<close> for a :: \<open>'a::len0 word\<close>
  by transfer (simp add: take_bit_eq_mod)

lemma unsigned_int_less:
  \<open>unsigned a < (2 ^ LENGTH('a) :: int)\<close> for a :: \<open>'a::len0 word\<close>
  by transfer (simp add: take_bit_eq_mod)

context ring_char_0
begin

lemma word_eq_iff_signed:
  "a = b \<longleftrightarrow> signed a = signed b"
  by safe (transfer; auto simp add: signed_take_bit_eq_iff_take_bit_eq)

end

lemma signed_of_int [simp]:
  "signed (of_int k :: 'a word) = signed_take_bit (LENGTH('a::len) - 1) k"
  by transfer simp

lemma of_int_signed [simp]:
  "of_int (signed a) = a"
  by transfer (simp add: signed_take_bit_eq_take_bit take_bit_eq_mod mod_simps)

subsubsection \<open>Properties\<close>

lemma exp_eq_zero_iff:
  \<open>(2 :: 'a::len word) ^ n = 0 \<longleftrightarrow> LENGTH('a) \<le> n\<close>
  by transfer simp

subsubsection \<open>Division\<close>

instantiation word :: (len0) modulo
begin

lift_definition divide_word :: "'a word \<Rightarrow> 'a word \<Rightarrow> 'a word"
  is "\<lambda>a b. take_bit LENGTH('a) a div take_bit LENGTH('a) b"
  by simp

lift_definition modulo_word :: "'a word \<Rightarrow> 'a word \<Rightarrow> 'a word"
  is "\<lambda>a b. take_bit LENGTH('a) a mod take_bit LENGTH('a) b"
  by simp

instance ..

end

lemma zero_word_div_eq [simp]:
  \<open>0 div a = 0\<close> for a :: \<open>'a::len0 word\<close>
  by transfer simp

lemma div_zero_word_eq [simp]:
  \<open>a div 0 = 0\<close> for a :: \<open>'a::len0 word\<close>
  by transfer simp

context
  includes lifting_syntax
begin

lemma [transfer_rule]:
  "(pcr_word ===> (\<longleftrightarrow>)) even ((dvd) 2 :: 'a::len word \<Rightarrow> bool)"
proof -
  have even_word_unfold: "even k \<longleftrightarrow> (\<exists>l. take_bit LENGTH('a) k = take_bit LENGTH('a) (2 * l))" (is "?P \<longleftrightarrow> ?Q")
    for k :: int
  proof
    assume ?P
    then show ?Q
      by auto
  next
    assume ?Q
    then obtain l where "take_bit LENGTH('a) k = take_bit LENGTH('a) (2 * l)" ..
    then have "even (take_bit LENGTH('a) k)"
      by simp
    then show ?P
      by simp
  qed
  show ?thesis by (simp only: even_word_unfold [abs_def] dvd_def [where ?'a = "'a word", abs_def])
    transfer_prover
qed

end

instance word :: (len) semiring_modulo
proof
  show "a div b * b + a mod b = a" for a b :: "'a word"
  proof transfer
    fix k l :: int
    define r :: int where "r = 2 ^ LENGTH('a)"
    then have r: "take_bit LENGTH('a) k = k mod r" for k
      by (simp add: take_bit_eq_mod)
    have "k mod r = ((k mod r) div (l mod r) * (l mod r)
      + (k mod r) mod (l mod r)) mod r"
      by (simp add: div_mult_mod_eq)
    also have "... = (((k mod r) div (l mod r) * (l mod r)) mod r
      + (k mod r) mod (l mod r)) mod r"
      by (simp add: mod_add_left_eq)
    also have "... = (((k mod r) div (l mod r) * l) mod r
      + (k mod r) mod (l mod r)) mod r"
      by (simp add: mod_mult_right_eq)
    finally have "k mod r = ((k mod r) div (l mod r) * l
      + (k mod r) mod (l mod r)) mod r"
      by (simp add: mod_simps)
    with r show "take_bit LENGTH('a) (take_bit LENGTH('a) k div take_bit LENGTH('a) l * l
      + take_bit LENGTH('a) k mod take_bit LENGTH('a) l) = take_bit LENGTH('a) k"
      by simp
  qed
qed

instance word :: (len) semiring_parity
proof
  show "\<not> 2 dvd (1::'a word)"
    by transfer simp
  show even_iff_mod_2_eq_0: "2 dvd a \<longleftrightarrow> a mod 2 = 0"
    for a :: "'a word"
    by transfer (simp_all add: mod_2_eq_odd take_bit_Suc)
  show "\<not> 2 dvd a \<longleftrightarrow> a mod 2 = 1"
    for a :: "'a word"
    by transfer (simp_all add: mod_2_eq_odd take_bit_Suc)
qed

subsubsection \<open>Orderings\<close>

instantiation word :: (len0) linorder
begin

lift_definition less_eq_word :: "'a word \<Rightarrow> 'a word \<Rightarrow> bool"
  is "\<lambda>a b. take_bit LENGTH('a) a \<le> take_bit LENGTH('a) b"
  by simp

lift_definition less_word :: "'a word \<Rightarrow> 'a word \<Rightarrow> bool"
  is "\<lambda>a b. take_bit LENGTH('a) a < take_bit LENGTH('a) b"
  by simp

instance
  by standard (transfer; auto)+

end

context linordered_semidom
begin

lemma word_less_eq_iff_unsigned:
  "a \<le> b \<longleftrightarrow> unsigned a \<le> unsigned b"
  by (transfer fixing: less_eq) (simp add: nat_le_eq_zle)

lemma word_less_iff_unsigned:
  "a < b \<longleftrightarrow> unsigned a < unsigned b"
  by (transfer fixing: less) (auto dest: preorder_class.le_less_trans [OF take_bit_nonnegative])

end

lemma word_greater_zero_iff:
  \<open>a > 0 \<longleftrightarrow> a \<noteq> 0\<close> for a :: \<open>'a::len0 word\<close>
  by transfer (simp add: less_le)

lemma of_nat_word_eq_iff:
  \<open>of_nat m = (of_nat n :: 'a::len word) \<longleftrightarrow> take_bit LENGTH('a) m = take_bit LENGTH('a) n\<close>
  by transfer (simp add: take_bit_of_nat)

lemma of_nat_word_less_eq_iff:
  \<open>of_nat m \<le> (of_nat n :: 'a::len word) \<longleftrightarrow> take_bit LENGTH('a) m \<le> take_bit LENGTH('a) n\<close>
  by transfer (simp add: take_bit_of_nat)

lemma of_nat_word_less_iff:
  \<open>of_nat m < (of_nat n :: 'a::len word) \<longleftrightarrow> take_bit LENGTH('a) m < take_bit LENGTH('a) n\<close>
  by transfer (simp add: take_bit_of_nat)

lemma of_nat_word_eq_0_iff:
  \<open>of_nat n = (0 :: 'a::len word) \<longleftrightarrow> 2 ^ LENGTH('a) dvd n\<close>
  using of_nat_word_eq_iff [where ?'a = 'a, of n 0] by (simp add: take_bit_eq_0_iff)

lemma of_int_word_eq_iff:
  \<open>of_int k = (of_int l :: 'a::len word) \<longleftrightarrow> take_bit LENGTH('a) k = take_bit LENGTH('a) l\<close>
  by transfer rule

lemma of_int_word_less_eq_iff:
  \<open>of_int k \<le> (of_int l :: 'a::len word) \<longleftrightarrow> take_bit LENGTH('a) k \<le> take_bit LENGTH('a) l\<close>
  by transfer rule

lemma of_int_word_less_iff:
  \<open>of_int k < (of_int l :: 'a::len word) \<longleftrightarrow> take_bit LENGTH('a) k < take_bit LENGTH('a) l\<close>
  by transfer rule

lemma of_int_word_eq_0_iff:
  \<open>of_int k = (0 :: 'a::len word) \<longleftrightarrow> 2 ^ LENGTH('a) dvd k\<close>
  using of_int_word_eq_iff [where ?'a = 'a, of k 0] by (simp add: take_bit_eq_0_iff)

subsection \<open>Bit structure on \<^typ>\<open>'a word\<close>\<close>

lemma word_bit_induct [case_names zero even odd]:
  \<open>P a\<close> if word_zero: \<open>P 0\<close>
    and word_even: \<open>\<And>a. P a \<Longrightarrow> 0 < a \<Longrightarrow> a < 2 ^ (LENGTH('a) - 1) \<Longrightarrow> P (2 * a)\<close>
    and word_odd: \<open>\<And>a. P a \<Longrightarrow> a < 2 ^ (LENGTH('a) - 1) \<Longrightarrow> P (1 + 2 * a)\<close>
  for P and a :: \<open>'a::len word\<close>
proof -
  define m :: nat where \<open>m = LENGTH('a) - 1\<close>
  then have l: \<open>LENGTH('a) = Suc m\<close>
    by simp
  define n :: nat where \<open>n = unsigned a\<close>
  then have \<open>n < 2 ^ LENGTH('a)\<close>
    by (simp add: unsigned_nat_less)
  then have \<open>n < 2 * 2 ^ m\<close>
    by (simp add: l)
  then have \<open>P (of_nat n)\<close>
  proof (induction n rule: nat_bit_induct)
    case zero
    show ?case
      by simp (rule word_zero)
  next
    case (even n)
    then have \<open>n < 2 ^ m\<close>
      by simp
    with even.IH have \<open>P (of_nat n)\<close>
      by simp
    moreover from \<open>n < 2 ^ m\<close> even.hyps have \<open>0 < (of_nat n :: 'a word)\<close>
      by (auto simp add: word_greater_zero_iff of_nat_word_eq_0_iff l)
    moreover from \<open>n < 2 ^ m\<close> have \<open>(of_nat n :: 'a word) < 2 ^ (LENGTH('a) - 1)\<close>
      using of_nat_word_less_iff [where ?'a = 'a, of n \<open>2 ^ m\<close>]
      by (cases \<open>m = 0\<close>) (simp_all add: not_less take_bit_eq_self ac_simps l)
    ultimately have \<open>P (2 * of_nat n)\<close>
      by (rule word_even)
    then show ?case
      by simp
  next
    case (odd n)
    then have \<open>Suc n \<le> 2 ^ m\<close>
      by simp
    with odd.IH have \<open>P (of_nat n)\<close>
      by simp
    moreover from \<open>Suc n \<le> 2 ^ m\<close> have \<open>(of_nat n :: 'a word) < 2 ^ (LENGTH('a) - 1)\<close>
      using of_nat_word_less_iff [where ?'a = 'a, of n \<open>2 ^ m\<close>]
      by (cases \<open>m = 0\<close>) (simp_all add: not_less take_bit_eq_self ac_simps l)
    ultimately have \<open>P (1 + 2 * of_nat n)\<close>
      by (rule word_odd)
    then show ?case
      by simp
  qed
  then show ?thesis
    by (simp add: n_def)
qed

lemma bit_word_half_eq:
  \<open>(of_bool b + a * 2) div 2 = a\<close>
    if \<open>a < 2 ^ (LENGTH('a) - Suc 0)\<close>
    for a :: \<open>'a::len word\<close>
proof (cases \<open>2 \<le> LENGTH('a::len)\<close>)
  case False
  have \<open>of_bool (odd k) < (1 :: int) \<longleftrightarrow> even k\<close> for k :: int
    by auto
  with False that show ?thesis
    by transfer (simp add: eq_iff)
next
  case True
  obtain n where length: \<open>LENGTH('a) = Suc n\<close>
    by (cases \<open>LENGTH('a)\<close>) simp_all
  show ?thesis proof (cases b)
    case False
    moreover have \<open>a * 2 div 2 = a\<close>
    using that proof transfer
      fix k :: int
      from length have \<open>k * 2 mod 2 ^ LENGTH('a) = (k mod 2 ^ n) * 2\<close>
        by simp
      moreover assume \<open>take_bit LENGTH('a) k < take_bit LENGTH('a) (2 ^ (LENGTH('a) - Suc 0))\<close>
      with \<open>LENGTH('a) = Suc n\<close>
      have \<open>k mod 2 ^ LENGTH('a) = k mod 2 ^ n\<close>
        by (simp add: take_bit_eq_mod divmod_digit_0)
      ultimately have \<open>take_bit LENGTH('a) (k * 2) = take_bit LENGTH('a) k * 2\<close>
        by (simp add: take_bit_eq_mod)
      with True show \<open>take_bit LENGTH('a) (take_bit LENGTH('a) (k * 2) div take_bit LENGTH('a) 2)
        = take_bit LENGTH('a) k\<close>
        by simp
    qed
    ultimately show ?thesis
      by simp
  next
    case True
    moreover have \<open>(1 + a * 2) div 2 = a\<close>
    using that proof transfer
      fix k :: int
      from length have \<open>(1 + k * 2) mod 2 ^ LENGTH('a) = 1 + (k mod 2 ^ n) * 2\<close>
        using pos_zmod_mult_2 [of \<open>2 ^ n\<close> k] by (simp add: ac_simps)
      moreover assume \<open>take_bit LENGTH('a) k < take_bit LENGTH('a) (2 ^ (LENGTH('a) - Suc 0))\<close>
      with \<open>LENGTH('a) = Suc n\<close>
      have \<open>k mod 2 ^ LENGTH('a) = k mod 2 ^ n\<close>
        by (simp add: take_bit_eq_mod divmod_digit_0)
      ultimately have \<open>take_bit LENGTH('a) (1 + k * 2) = 1 + take_bit LENGTH('a) k * 2\<close>
        by (simp add: take_bit_eq_mod)
      with True show \<open>take_bit LENGTH('a) (take_bit LENGTH('a) (1 + k * 2) div take_bit LENGTH('a) 2)
        = take_bit LENGTH('a) k\<close>
        by (auto simp add: take_bit_Suc)
    qed
    ultimately show ?thesis
      by simp
  qed
qed

lemma even_mult_exp_div_word_iff:
  \<open>even (a * 2 ^ m div 2 ^ n) \<longleftrightarrow> \<not> (
    m \<le> n \<and>
    n < LENGTH('a) \<and> odd (a div 2 ^ (n - m)))\<close> for a :: \<open>'a::len word\<close>
  by transfer
    (auto simp flip: drop_bit_eq_div simp add: even_drop_bit_iff_not_bit bit_take_bit_iff,
      simp_all flip: push_bit_eq_mult add: bit_push_bit_iff_int)

instance word :: (len) semiring_bits
proof
  show \<open>P a\<close> if stable: \<open>\<And>a. a div 2 = a \<Longrightarrow> P a\<close>
    and rec: \<open>\<And>a b. P a \<Longrightarrow> (of_bool b + 2 * a) div 2 = a \<Longrightarrow> P (of_bool b + 2 * a)\<close>
  for P and a :: \<open>'a word\<close>
  proof (induction a rule: word_bit_induct)
    case zero
    from stable [of 0] show ?case
      by simp
  next
    case (even a)
    with rec [of a False] show ?case
      using bit_word_half_eq [of a False] by (simp add: ac_simps)
  next
    case (odd a)
    with rec [of a True] show ?case
      using bit_word_half_eq [of a True] by (simp add: ac_simps)
  qed
  show \<open>0 div a = 0\<close>
    for a :: \<open>'a word\<close>
    by transfer simp
  show \<open>a div 1 = a\<close>
    for a :: \<open>'a word\<close>
    by transfer simp
  show \<open>a mod b div b = 0\<close>
    for a b :: \<open>'a word\<close>
    apply transfer
    apply (simp add: take_bit_eq_mod)
    apply (subst (3) mod_pos_pos_trivial [of _ \<open>2 ^ LENGTH('a)\<close>])
      apply simp_all
     apply (metis le_less mod_by_0 pos_mod_conj zero_less_numeral zero_less_power)
    using pos_mod_bound [of \<open>2 ^ LENGTH('a)\<close>] apply simp
  proof -
    fix aa :: int and ba :: int
    have f1: "\<And>i n. (i::int) mod 2 ^ n = 0 \<or> 0 < i mod 2 ^ n"
      by (metis le_less take_bit_eq_mod take_bit_nonnegative)
    have "(0::int) < 2 ^ len_of (TYPE('a)::'a itself) \<and> ba mod 2 ^ len_of (TYPE('a)::'a itself) \<noteq> 0 \<or> aa mod 2 ^ len_of (TYPE('a)::'a itself) mod (ba mod 2 ^ len_of (TYPE('a)::'a itself)) < 2 ^ len_of (TYPE('a)::'a itself)"
      by (metis (no_types) mod_by_0 unique_euclidean_semiring_numeral_class.pos_mod_bound zero_less_numeral zero_less_power)
    then show "aa mod 2 ^ len_of (TYPE('a)::'a itself) mod (ba mod 2 ^ len_of (TYPE('a)::'a itself)) < 2 ^ len_of (TYPE('a)::'a itself)"
      using f1 by (meson le_less less_le_trans unique_euclidean_semiring_numeral_class.pos_mod_bound)
  qed
  show \<open>(1 + a) div 2 = a div 2\<close>
    if \<open>even a\<close>
    for a :: \<open>'a word\<close>
    using that by transfer
      (auto dest: le_Suc_ex simp add: mod_2_eq_odd take_bit_Suc elim!: evenE)
  show \<open>(2 :: 'a word) ^ m div 2 ^ n = of_bool ((2 :: 'a word) ^ m \<noteq> 0 \<and> n \<le> m) * 2 ^ (m - n)\<close>
    for m n :: nat
    by transfer (simp, simp add: exp_div_exp_eq)
  show "a div 2 ^ m div 2 ^ n = a div 2 ^ (m + n)"
    for a :: "'a word" and m n :: nat
    apply transfer
    apply (auto simp add: not_less take_bit_drop_bit ac_simps simp flip: drop_bit_eq_div)
    apply (simp add: drop_bit_take_bit)
    done
  show "a mod 2 ^ m mod 2 ^ n = a mod 2 ^ min m n"
    for a :: "'a word" and m n :: nat
    by transfer (auto simp flip: take_bit_eq_mod simp add: ac_simps)
  show \<open>a * 2 ^ m mod 2 ^ n = a mod 2 ^ (n - m) * 2 ^ m\<close>
    if \<open>m \<le> n\<close> for a :: "'a word" and m n :: nat
    using that apply transfer
    apply (auto simp flip: take_bit_eq_mod)
           apply (auto simp flip: push_bit_eq_mult simp add: push_bit_take_bit split: split_min_lin)
    done
  show \<open>a div 2 ^ n mod 2 ^ m = a mod (2 ^ (n + m)) div 2 ^ n\<close>
    for a :: "'a word" and m n :: nat
    by transfer (auto simp add: not_less take_bit_drop_bit ac_simps simp flip: take_bit_eq_mod drop_bit_eq_div split: split_min_lin)
  show \<open>even ((2 ^ m - 1) div (2::'a word) ^ n) \<longleftrightarrow> 2 ^ n = (0::'a word) \<or> m \<le> n\<close>
    for m n :: nat
    by transfer (auto simp add: take_bit_of_mask even_mask_div_iff)
  show \<open>even (a * 2 ^ m div 2 ^ n) \<longleftrightarrow> n < m \<or> (2::'a word) ^ n = 0 \<or> m \<le> n \<and> even (a div 2 ^ (n - m))\<close>
    for a :: \<open>'a word\<close> and m n :: nat
  proof transfer
    show \<open>even (take_bit LENGTH('a) (k * 2 ^ m) div take_bit LENGTH('a) (2 ^ n)) \<longleftrightarrow>
      n < m
      \<or> take_bit LENGTH('a) ((2::int) ^ n) = take_bit LENGTH('a) 0
      \<or> (m \<le> n \<and> even (take_bit LENGTH('a) k div take_bit LENGTH('a) (2 ^ (n - m))))\<close>
    for m n :: nat and k l :: int
      by (auto simp flip: take_bit_eq_mod drop_bit_eq_div push_bit_eq_mult
        simp add: div_push_bit_of_1_eq_drop_bit drop_bit_take_bit drop_bit_push_bit_int [of n m])
  qed
qed

context
  includes lifting_syntax
begin

lemma transfer_rule_bit_word [transfer_rule]:
  \<open>((pcr_word :: int \<Rightarrow> 'a::len word \<Rightarrow> bool) ===> (=)) (\<lambda>k n. n < LENGTH('a) \<and> bit k n) bit\<close>
proof -
  let ?t = \<open>\<lambda>a n. odd (take_bit LENGTH('a) a div take_bit LENGTH('a) ((2::int) ^ n))\<close>
  have \<open>((pcr_word :: int \<Rightarrow> 'a word \<Rightarrow> bool) ===> (=)) ?t bit\<close>
    by (unfold bit_def) transfer_prover
  also have \<open>?t = (\<lambda>k n. n < LENGTH('a) \<and> bit k n)\<close>
    by (simp add: fun_eq_iff bit_take_bit_iff flip: bit_def)
  finally show ?thesis .
qed

end

instantiation word :: (len) semiring_bit_shifts
begin

lift_definition push_bit_word :: \<open>nat \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>
  is push_bit
proof -
  show \<open>take_bit LENGTH('a) (push_bit n k) = take_bit LENGTH('a) (push_bit n l)\<close>
    if \<open>take_bit LENGTH('a) k = take_bit LENGTH('a) l\<close> for k l :: int and n :: nat
  proof -
    from that
    have \<open>take_bit (LENGTH('a) - n) (take_bit LENGTH('a) k)
      = take_bit (LENGTH('a) - n) (take_bit LENGTH('a) l)\<close>
      by simp
    moreover have \<open>min (LENGTH('a) - n) LENGTH('a) = LENGTH('a) - n\<close>
      by simp
    ultimately show ?thesis
      by (simp add: take_bit_push_bit)
  qed
qed

lift_definition drop_bit_word :: \<open>nat \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>
  is \<open>\<lambda>n. drop_bit n \<circ> take_bit LENGTH('a)\<close>
  by (simp add: take_bit_eq_mod)

instance proof
  show \<open>push_bit n a = a * 2 ^ n\<close> for n :: nat and a :: "'a word"
    by transfer (simp add: push_bit_eq_mult)
  show \<open>drop_bit n a = a div 2 ^ n\<close> for n :: nat and a :: "'a word"
    by transfer (simp flip: drop_bit_eq_div add: drop_bit_take_bit)
qed

end

instantiation word :: (len) ring_bit_operations
begin

lift_definition not_word :: "'a word \<Rightarrow> 'a word"
  is not
  by (simp add: take_bit_not_iff)

lift_definition and_word :: "'a word \<Rightarrow> 'a word \<Rightarrow> 'a word"
  is \<open>and\<close>
  by simp

lift_definition or_word :: "'a word \<Rightarrow> 'a word \<Rightarrow> 'a word"
  is or
  by simp

lift_definition xor_word ::  "'a word \<Rightarrow> 'a word \<Rightarrow> 'a word"
  is xor
  by simp

instance proof
  fix a b :: \<open>'a word\<close> and n :: nat
  show \<open>- a = NOT (a - 1)\<close>
    by transfer (simp add: minus_eq_not_minus_1)
  show \<open>bit (NOT a) n \<longleftrightarrow> (2 :: 'a word) ^ n \<noteq> 0 \<and> \<not> bit a n\<close>
    by transfer (simp add: bit_not_iff)
  show \<open>bit (a AND b) n \<longleftrightarrow> bit a n \<and> bit b n\<close>
    by transfer (auto simp add: bit_and_iff)
  show \<open>bit (a OR b) n \<longleftrightarrow> bit a n \<or> bit b n\<close>
    by transfer (auto simp add: bit_or_iff)
  show \<open>bit (a XOR b) n \<longleftrightarrow> bit a n \<noteq> bit b n\<close>
    by transfer (auto simp add: bit_xor_iff)
qed

end

definition even_word :: \<open>'a::len word \<Rightarrow> bool\<close>
  where [code_abbrev]: \<open>even_word = even\<close>

lemma even_word_iff [code]:
  \<open>even_word a \<longleftrightarrow> a AND 1 = 0\<close>
  by (simp add: even_word_def even_iff_mod_2_eq_zero)

definition bit_word :: \<open>'a::len word \<Rightarrow> nat \<Rightarrow> bool\<close>
  where [code_abbrev]: \<open>bit_word = bit\<close>

lemma bit_word_iff [code]:
  \<open>bit_word a n \<longleftrightarrow> drop_bit n a AND 1 = 1\<close>
  by (simp add: bit_word_def bit_iff_odd_drop_bit odd_iff_mod_2_eq_one)

lifting_update word.lifting
lifting_forget word.lifting

end