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

section \<open>Groups\<close>

theory Group imports ZF begin

text\<open>Based on work by Clemens Ballarin, Florian Kammueller, L C Paulson and
Markus Wenzel.\<close>

subsection \<open>Monoids\<close>

(*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\<open>Simulating the record\<close>
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 \<open>
  A group is a monoid all of whose elements are invertible.
\<close>

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 \<open>Cancellation Laws and Basic Properties\<close>

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\<open>This proof is by cancellation\<close>
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 \<open>Substructures\<close>

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 \<open>
  Since @{term H} is nonempty, it contains some element @{term x}.  Since
  it is closed under inverse, it contains \<open>inv x\<close>.  Since
  it is closed under product, it contains \<open>x \<cdot> inv x = \<one>\<close>.
\<close>

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

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 \<open>A characterization of subgroups: closed, non-empty subset.\<close>

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 \<open>Direct Products\<close>

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 \<open>Isomorphisms\<close>

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 \<open>Isomorphisms\<close>

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\<open>Basis for homomorphism proofs: we assume two groups @{term G} and
  @{term H}, with a homomorphism @{term h} between them\<close>
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: H.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: H.inv)
qed

subsection \<open>Commutative Structures\<close>

text \<open>
  Naming convention: multiplicative structures that are commutative
  are called \emph{commutative}, additive structures are called
  \emph{Abelian}.
\<close>

subsection \<open>Definition\<close>

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 \<open>Bijections of a Set, Permutation Groups, Automorphism Groups\<close>

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 \<open>Bijections Form a Group\<close>

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\<open>Automorphisms Form a Group\<close>

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\<open>Cosets and Quotient Groups\<close>

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 + group +
  assumes coset_eq: "(\<forall>x \<in> carrier(G). H #> x = x <# H)"

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

subsection \<open>Basic Properties of Cosets\<close>

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"
  \<comment>\<open>Alternative proof is to put @{term "x=\<one>"} in \<open>repr_independence\<close>.\<close>
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\<open>Really needed?\<close>
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 \<open>Normal subgroups\<close>

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\<open>Alternative characterization of normal subgroups\<close>
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\<open>More Properties of Cosets\<close>

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 \<open>Set of inverses of an \<open>r_coset\<close>.\<close>

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 \<open>Theorems for \<open><#>\<close> with \<open>#>\<close> or \<open><#\<close>.\<close>

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"
  \<comment> \<open>generalizes \<open>subgroup_mult_id\<close>\<close>
  by (auto simp add: RCOSETS_def subset
        setmult_rcos_assoc subgroup_mult_id normal_axioms normal.axioms)

subsubsection\<open>Two distinct right cosets are disjoint\<close>

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\<open>Equivalence classes of \<open>rcong\<close> correspond to left cosets.
  Was there a mistake in the definitions? I'd have expected them to
  correspond to right cosets.\<close>
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 \<open>Order of a Group and Lagrange's Theorem\<close>

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\<open>More general than the HOL version, which also requires @{term G} to
      be finite.\<close>
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 \<open>Quotient Groups: Factorization of a Group\<close>

definition
  FactGroup :: "[i,i] => i" (infixl "Mod" 65) where
    \<comment>\<open>Actually defined for groups rather than monoids\<close>
  "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\<open>The coset map is a homomorphism from @{term G} to the quotient group
  @{term "G Mod H"}\<close>
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\<open>The First Isomorphism Theorem\<close>

text\<open>The quotient by the kernel of a homomorphism is isomorphic to the
  range of that homomorphism.\<close>

definition
  kernel :: "[i,i,i] => i" where
    \<comment>\<open>the kernel of a homomorphism\<close>
  "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\<open>The kernel of a homomorphism is a normal subgroup\<close>
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\<open>Lemma for the following injectivity result\<close>
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\<open>If the homomorphism @{term h} is onto @{term H}, then so is the
homomorphism from the quotient group\<close>
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"
        \<comment>\<open>The witness is @{term "kernel(G,H,h) #> g"}\<close>
    by (force simp add: FactGroup_def RCOSETS_def
           image_eq_UN [OF hom_is_fun] kernel_rcoset_subset)
qed

text\<open>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}.\<close>
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


header {* Deciding Equivalence of Extended Regular Expressions *}

theory Equivalence_Checking2
imports Regular_Exp2 "~~/src/HOL/Library/While_Combinator"
begin

subsection {* Term ordering *}

fun le_rexp :: "nat rexp \<Rightarrow> nat rexp \<Rightarrow> bool"
where
  "le_rexp Zero _ = True"
| "le_rexp _ Zero = False"
| "le_rexp One _ = True"
| "le_rexp _ One = False"
| "le_rexp (Atom a) (Atom b) = (a <= b)"
| "le_rexp (Atom _) _ = True"
| "le_rexp _ (Atom _) = False"
| "le_rexp (Star r) (Star s) = le_rexp r s"
| "le_rexp (Star _) _ = True"
| "le_rexp _ (Star _) = False"
| "le_rexp (Not r) (Not s) = le_rexp r s"
| "le_rexp (Not _) _ = True"
| "le_rexp _ (Not _) = False"
| "le_rexp (Plus r r') (Plus s s') =
    (if r = s then le_rexp r' s' else le_rexp r s)"
| "le_rexp (Plus _ _) _ = True"
| "le_rexp _ (Plus _ _) = False"
| "le_rexp (Times r r') (Times s s') =
    (if r = s then le_rexp r' s' else le_rexp r s)"
| "le_rexp (Times _ _) _ = True"
| "le_rexp _ (Times _ _) = False"
| "le_rexp (Inter r r') (Inter s s') =
    (if r = s then le_rexp r' s' else le_rexp r s)"

subsection {* Normalizing operations *}

text {* associativity, commutativity, idempotence, zero *}

fun nPlus :: "nat rexp \<Rightarrow> nat rexp \<Rightarrow> nat rexp"
where
  "nPlus Zero r = r"
| "nPlus r Zero = r"
| "nPlus (Plus r s) t = nPlus r (nPlus s t)"
| "nPlus r (Plus s t) =
     (if r = s then (Plus s t)
     else if le_rexp r s then Plus r (Plus s t)
     else Plus s (nPlus r t))"
| "nPlus r s =
     (if r = s then r
      else if le_rexp r s then Plus r s
      else Plus s r)"

lemma lang_nPlus[simp]: "lang S (nPlus r s) = lang S (Plus r s)"
by (induct r s rule: nPlus.induct) auto

text {* associativity, zero, one *}

fun nTimes :: "nat rexp \<Rightarrow> nat rexp \<Rightarrow> nat rexp"
where
  "nTimes Zero _ = Zero"
| "nTimes _ Zero = Zero"
| "nTimes One r = r"
| "nTimes r One = r"
| "nTimes (Times r s) t = Times r (nTimes s t)"
| "nTimes r s = Times r s"

lemma lang_nTimes[simp]: "lang S (nTimes r s) = lang S (Times r s)"
by (induct r s rule: nTimes.induct) (auto simp: conc_assoc)

text {* more optimisations: *}

fun nInter :: "nat rexp \<Rightarrow> nat rexp \<Rightarrow> nat rexp"
where
  "nInter Zero _ = Zero"
| "nInter _ Zero = Zero"
| "nInter r s = Inter r s"

lemma lang_nInter[simp]: "lang S (nInter r s) = lang S (Inter r s)"
by (induct r s rule: nInter.induct) (auto)

primrec norm :: "nat rexp \<Rightarrow> nat rexp"
where
  "norm Zero = Zero"
| "norm One = One"
| "norm (Atom a) = Atom a"
| "norm (Plus r s) = nPlus (norm r) (norm s)"
| "norm (Times r s) = nTimes (norm r) (norm s)"
| "norm (Star r) = Star (norm r)"
| "norm (Not r) = Not (norm r)"
| "norm (Inter r1 r2) = nInter (norm r1) (norm r2)"

lemma lang_norm[simp]: "lang S (norm r) = lang S r"
by (induct r) auto

subsection {* Derivative *}

primrec nderiv :: "nat \<Rightarrow> nat rexp \<Rightarrow> nat rexp"
where
  "nderiv _ Zero = Zero"
| "nderiv _ One = Zero"
| "nderiv a (Atom b) = (if a = b then One else Zero)"
| "nderiv a (Plus r s) = nPlus (nderiv a r) (nderiv a s)"
| "nderiv a (Times r s) =
    (let r's = nTimes (nderiv a r) s
     in if nullable r then nPlus r's (nderiv a s) else r's)"
| "nderiv a (Star r) = nTimes (nderiv a r) (Star r)"
| "nderiv a (Not r) = Not (nderiv a r)"
| "nderiv a (Inter r1 r2) = nInter (nderiv a r1) (nderiv a r2)"

lemma lang_nderiv: "a:S \<Longrightarrow> lang S (nderiv a r) = Deriv a (lang S r)"
by (induct r) (auto simp: Let_def nullable_iff[where S=S])

lemma atoms_nPlus[simp]: "atoms (nPlus r s) = atoms r \<union> atoms s"
by (induct r s rule: nPlus.induct) auto

lemma atoms_nTimes: "atoms (nTimes r s) \<subseteq> atoms r \<union> atoms s"
by (induct r s rule: nTimes.induct) auto

lemma atoms_nInter: "atoms (nInter r s) \<subseteq> atoms r \<union> atoms s"
by (induct r s rule: nInter.induct) auto

lemma atoms_norm: "atoms (norm r) \<subseteq> atoms r"
by (induct r) (auto dest!:subsetD[OF atoms_nTimes]subsetD[OF atoms_nInter])

lemma atoms_nderiv: "atoms (nderiv a r) \<subseteq> atoms r"
by (induct r) (auto simp: Let_def dest!:subsetD[OF atoms_nTimes]subsetD[OF atoms_nInter])

subsection {* Bisimulation between languages and regular expressions *}

context
fixes S :: "'a set"
begin

coinductive bisimilar :: "'a lang \<Rightarrow> 'a lang \<Rightarrow> bool" where
"K \<subseteq> lists S \<Longrightarrow> L \<subseteq> lists S
 \<Longrightarrow> ([] \<in> K \<longleftrightarrow> [] \<in> L)
 \<Longrightarrow> (\<And>x. x:S \<Longrightarrow> bisimilar (Deriv x K) (Deriv x L))
 \<Longrightarrow> bisimilar K L"

lemma equal_if_bisimilar:
assumes "K \<subseteq> lists S" "L \<subseteq> lists S" "bisimilar K L" shows "K = L"
proof (rule set_eqI)
  fix w
  from assms show "w \<in> K \<longleftrightarrow> w \<in> L"
  proof (induction w arbitrary: K L)
    case Nil thus ?case by (auto elim: bisimilar.cases)
  next
    case (Cons a w K L)
    show ?case
    proof cases
      assume "a : S"
      with `bisimilar K L` have "bisimilar (Deriv a K) (Deriv a L)"
        by (auto elim: bisimilar.cases)
      then have "w \<in> Deriv a K \<longleftrightarrow> w \<in> Deriv a L"
        by (metis Cons.IH bisimilar.cases)
      thus ?case by (auto simp: Deriv_def)
    next
      assume "a \<notin> S"
      thus ?case using Cons.prems by auto
    qed
  qed
qed

lemma language_coinduct:
fixes R (infixl "\<sim>" 50)
assumes "\<And>K L. K \<sim> L \<Longrightarrow> K \<subseteq> lists S \<and> L \<subseteq> lists S"
assumes "K \<sim> L"
assumes "\<And>K L. K \<sim> L \<Longrightarrow> ([] \<in> K \<longleftrightarrow> [] \<in> L)"
assumes "\<And>K L x. K \<sim> L \<Longrightarrow> x : S \<Longrightarrow> Deriv x K \<sim> Deriv x L"
shows "K = L"
apply (rule equal_if_bisimilar)
apply (metis assms(1) assms(2))
apply (metis assms(1) assms(2))
apply (rule bisimilar.coinduct[of R, OF `K \<sim> L`])
apply (auto simp: assms)
done

end

type_synonym rexp_pair = "nat rexp * nat rexp"
type_synonym rexp_pairs = "rexp_pair list"

definition is_bisimulation :: "nat list \<Rightarrow> rexp_pairs \<Rightarrow> bool"
where
"is_bisimulation as ps =
  (\<forall>(r,s)\<in> set ps. (atoms r \<union> atoms s \<subseteq> set as) \<and> (nullable r \<longleftrightarrow> nullable s) \<and>
    (\<forall>a\<in>set as. (nderiv a r, nderiv a s) \<in> set ps))"

lemma bisim_lang_eq:
assumes bisim: "is_bisimulation as ps"
assumes "(r, s) \<in> set ps"
shows "lang (set as) r = lang (set as) s"
proof -
  let ?R = "\<lambda>K L. (\<exists>(r,s)\<in>set ps. K = lang (set as) r \<and> L = lang (set as) s)"
  show ?thesis
  proof (rule language_coinduct[where R="?R" and S = "set as"])
    from `(r, s) \<in> set ps` show "?R (lang (set as) r) (lang (set as) s)"
      by auto
  next
    fix K L assume "?R K L"
    then obtain r s where rs: "(r, s) \<in> set ps"
      and KL: "K = lang (set as) r" "L = lang (set as) s" by auto
    with bisim have "nullable r \<longleftrightarrow> nullable s"
      by (auto simp: is_bisimulation_def)
    thus "[] \<in> K \<longleftrightarrow> [] \<in> L" by (auto simp: nullable_iff[where S="set as"] KL)
  txt{* next case, but shared context *}
    from bisim rs KL lang_subset_lists[of _ "set as"]
    show "K \<subseteq> lists (set as) \<and> L \<subseteq> lists (set as)"
      unfolding is_bisimulation_def by blast
  txt{* next case, but shared context *}
    fix a assume "a \<in> set as"
    with rs bisim
    have "(nderiv a r, nderiv a s) \<in> set ps"
      by (auto simp: is_bisimulation_def)
    thus "?R (Deriv a K) (Deriv a L)" using `a \<in> set as`
      by (force simp: KL lang_nderiv)
  qed
qed

subsection {* Closure computation *}

fun test :: "rexp_pairs * rexp_pairs \<Rightarrow> bool"
where "test (ws, ps) = (case ws of [] \<Rightarrow>  False | (p,q)#_ \<Rightarrow> nullable p = nullable q)"

fun step :: "nat list \<Rightarrow> rexp_pairs * rexp_pairs \<Rightarrow> rexp_pairs * rexp_pairs"
where "step as (ws,ps) =
    (let
      (r, s) = hd ws;
      ps' = (r, s) # ps;
      succs = map (\<lambda>a. (nderiv a r, nderiv a s)) as;
      new = filter (\<lambda>p. p \<notin> set ps' \<union> set ws) succs
    in (new @ tl ws, ps'))"

definition closure ::
  "nat list \<Rightarrow> rexp_pairs * rexp_pairs
   \<Rightarrow> (rexp_pairs * rexp_pairs) option" where
"closure as = while_option test (step as)"

definition pre_bisim :: "nat list \<Rightarrow> nat rexp \<Rightarrow> nat rexp \<Rightarrow>
 rexp_pairs * rexp_pairs \<Rightarrow> bool"
where
"pre_bisim as r s = (\<lambda>(ws,ps).
 ((r, s) \<in> set ws \<union> set ps) \<and>
 (\<forall>(r,s)\<in> set ws \<union> set ps. atoms r \<union> atoms s \<subseteq> set as) \<and>
 (\<forall>(r,s)\<in> set ps. (nullable r \<longleftrightarrow> nullable s) \<and>
   (\<forall>a\<in>set as. (nderiv a r, nderiv a s) \<in> set ps \<union> set ws)))"

subsection {* The overall procedure *}

primrec add_atoms :: "nat rexp \<Rightarrow> nat list \<Rightarrow> nat list"
where
  "add_atoms Zero = id"
| "add_atoms One = id"
| "add_atoms (Atom a) = List.insert a"
| "add_atoms (Plus r s) = add_atoms s o add_atoms r"
| "add_atoms (Times r s) = add_atoms s o add_atoms r"
| "add_atoms (Not r) = add_atoms r"
| "add_atoms (Inter r s) = add_atoms s o add_atoms r"
| "add_atoms (Star r) = add_atoms r"

lemma set_add_atoms: "set (add_atoms r as) = atoms r \<union> set as"
by (induct r arbitrary: as) auto

definition check_eqv :: "nat list \<Rightarrow> nat rexp \<Rightarrow> nat rexp \<Rightarrow> bool"
where
"check_eqv as r s \<longleftrightarrow> set(add_atoms r (add_atoms s [])) \<subseteq> set as \<and>
  (case closure as ([(norm r, norm s)], []) of
     Some([],_) \<Rightarrow> True | _ \<Rightarrow> False)"

lemma "check_eqv [0] (Plus One (Times (Atom 0) (Star(Atom 0)))) (Star(Atom 0))"
by eval

lemma "check_eqv [0,1] (Not(Atom 0))
  (Plus One (Times (Plus (Atom 1) (Times (Atom 0) (Plus (Atom 0) (Atom 1))))
                   (Star(Plus (Atom 0) (Atom 1)))))"
by eval

lemma "check_eqv [0] (Atom 0) (Inter (Star (Atom 0)) (Atom 0))"
by eval

end


(*  Title:       Operations on Iterators over Finite Sets
    Author:      Thomas Tuerk <tuerk@in.tum.de>
    Maintainer:  Thomas Tuerk <tuerk@in.tum.de>
*)
header {* Operations on Set Iterators *}
theory SetIteratorOperations
imports Main SetIterator
begin

text{* Many operations on sets can be lifted to iterators over sets. This theory tries to introduce
the most useful such operations. *}

subsection {* Empty set *}

text {* Iterators over empty sets and singleton sets are very easy to define. *}
definition set_iterator_emp :: "('a,'\<sigma>) set_iterator" where
  "set_iterator_emp c f \<sigma>0 = \<sigma>0"

lemma set_iterator_emp_foldli_conv :
  "set_iterator_emp = foldli []"
by (simp add: fun_eq_iff set_iterator_emp_def)

lemma set_iterator_genord_emp_correct :
  "set_iterator_genord set_iterator_emp {} R"
apply (rule set_iterator_genord.intro)
apply (rule exI[where x="[]"])
apply (simp add: set_iterator_emp_foldli_conv)
done

lemma set_iterator_emp_correct :
  "set_iterator set_iterator_emp {}"
using set_iterator_intro [OF set_iterator_genord_emp_correct] .

lemma (in linorder) set_iterator_linord_emp_correct :
  "set_iterator_linord set_iterator_emp {}"
unfolding set_iterator_linord_def
by (fact set_iterator_genord_emp_correct)

lemma (in linorder) set_iterator_rev_linord_emp_correct :
  "set_iterator_rev_linord set_iterator_emp {}"
unfolding set_iterator_rev_linord_def
by (fact set_iterator_genord_emp_correct)

lemma (in linorder) map_iterator_linord_emp_correct :
  "map_iterator_linord set_iterator_emp empty"
  "set_iterator_map_linord set_iterator_emp {}"
unfolding set_iterator_map_linord_def
by (simp_all add: set_iterator_genord_emp_correct map_to_set_def)

lemma (in linorder) map_iterator_rev_linord_emp_correct :
  "map_iterator_rev_linord set_iterator_emp empty"
  "set_iterator_map_rev_linord set_iterator_emp {}"
unfolding set_iterator_map_rev_linord_def
by (simp_all add: set_iterator_genord_emp_correct map_to_set_def)

subsection{*Singleton Sets*}

definition set_iterator_sng :: "'a \<Rightarrow> ('a,'\<sigma>) set_iterator" where
  "set_iterator_sng x c f \<sigma>0 = (if c \<sigma>0 then f x \<sigma>0 else \<sigma>0)"

lemma set_iterator_sng_foldli_conv :
  "set_iterator_sng x = foldli [x]"
by (simp add: fun_eq_iff set_iterator_sng_def)

lemma set_iterator_genord_sng_correct :
  "set_iterator_genord (set_iterator_sng (x::'a)) {x} R"
apply (rule set_iterator_genord.intro)
apply (rule exI[where x="[x]"])
apply (simp add: set_iterator_sng_foldli_conv)
done

lemma set_iterator_sng_correct :
  "set_iterator (set_iterator_sng x) {x}"
unfolding set_iterator_def
by (rule set_iterator_genord_sng_correct)

lemma (in linorder) set_iterator_linord_sng_correct :
  "set_iterator_linord (set_iterator_sng x) {x}"
unfolding set_iterator_linord_def
by (simp add: set_iterator_genord_sng_correct)

lemma (in linorder) set_iterator_rev_linord_sng_correct :
  "set_iterator_rev_linord (set_iterator_sng x) {x}"
unfolding set_iterator_rev_linord_def
by (simp add: set_iterator_genord_sng_correct)

lemma (in linorder) map_iterator_linord_sng_correct :
  "map_iterator_linord (set_iterator_sng (k,v)) (empty (k \<mapsto> v))"
unfolding set_iterator_map_linord_def
by (simp add: set_iterator_genord_sng_correct)

lemma (in linorder) map_iterator_rev_linord_sng_correct :
  "map_iterator_rev_linord (set_iterator_sng (k,v)) (empty (k \<mapsto> v))"
unfolding set_iterator_map_rev_linord_def
by (simp add: set_iterator_genord_sng_correct)

subsection {* Union *}

text {* Iterators over disjoint sets can be combined by first iterating over one and then the
other set. The result is an iterator over the union of the original sets.*}

definition set_iterator_union ::
    "('a,'\<sigma>) set_iterator \<Rightarrow> ('a, '\<sigma>) set_iterator \<Rightarrow> ('a,'\<sigma>) set_iterator" where
  "set_iterator_union it_a it_b \<equiv> \<lambda>c f \<sigma>0. (it_b c f (it_a c f \<sigma>0))"

lemma set_iterator_union_foldli_conv :
  "set_iterator_union (foldli as) (foldli bs) = foldli (as @ bs)"
by (simp add: fun_eq_iff set_iterator_union_def foldli_append)

lemma set_iterator_genord_union_correct :
  fixes it_a :: "('a,'\<sigma>) set_iterator"
  fixes it_b :: "('a,'\<sigma>) set_iterator"
  fixes R S_a S_b
  assumes it_a: "set_iterator_genord it_a S_a R"
  assumes it_b: "set_iterator_genord it_b S_b R"
  assumes dist_Sab: "S_a \<inter> S_b = {}"
  assumes R_OK: "\<And>a b. \<lbrakk>a \<in> S_a; b \<in> S_b\<rbrakk> \<Longrightarrow> R a b"
  shows "set_iterator_genord (set_iterator_union it_a it_b) (S_a \<union> S_b) R"
proof -
  from it_a obtain as where
    dist_as: "distinct as" and S_a_eq: "S_a = set as" and
    sorted_as: "sorted_by_rel R as" and it_a_eq: "it_a = foldli as"
  unfolding set_iterator_genord_foldli_conv by blast

  from it_b obtain bs where
    dist_bs: "distinct bs" and S_b_eq: "S_b = set bs" and
    sorted_bs: "sorted_by_rel R bs" and it_b_eq: "it_b = foldli bs"
  unfolding set_iterator_genord_foldli_conv by blast

  show ?thesis
  proof (rule set_iterator_genord_I [of "as @ bs"])
    from dist_Sab S_a_eq S_b_eq dist_as dist_bs
    show "distinct (as @ bs)" by simp
  next
    from S_a_eq S_b_eq
    show "S_a \<union> S_b = set (as @ bs)" by simp
  next
    from sorted_as sorted_bs R_OK S_a_eq S_b_eq
    show "sorted_by_rel R (as @ bs)"
      by (simp add: sorted_by_rel_append Ball_def)
  next
    show "set_iterator_union it_a it_b = (foldli (as @ bs))"
      unfolding it_a_eq it_b_eq set_iterator_union_foldli_conv by simp
  qed
qed

lemma set_iterator_union_emp [simp] :
  "set_iterator_union (set_iterator_emp) it = it"
  "set_iterator_union it (set_iterator_emp) = it"
unfolding set_iterator_emp_def set_iterator_union_def
by simp_all

lemma set_iterator_union_correct :
  assumes it_a: "set_iterator it_a S_a"
  assumes it_b: "set_iterator it_b S_b"
  assumes dist_Sab: "S_a \<inter> S_b = {}"
  shows "set_iterator (set_iterator_union it_a it_b) (S_a \<union> S_b)"
proof -
  note res' = set_iterator_genord_union_correct [OF it_a[unfolded set_iterator_def]
                                                    it_b[unfolded set_iterator_def] dist_Sab]
  from set_iterator_intro [OF res']
  show ?thesis by simp
qed

lemma (in linorder) set_iterator_linord_union_correct :
  assumes it_a: "set_iterator_linord it_a S_a"
  assumes it_b: "set_iterator_linord it_b S_b"
  assumes ord_Sab: "\<And>a b. \<lbrakk>a \<in> S_a; b \<in> S_b\<rbrakk> \<Longrightarrow> a < b"
  shows "set_iterator_linord (set_iterator_union it_a it_b) (S_a \<union> S_b)"
unfolding set_iterator_linord_def
apply (rule_tac set_iterator_genord_union_correct[
   OF it_a[unfolded set_iterator_linord_def] it_b[unfolded set_iterator_linord_def]])
apply (insert ord_Sab)
apply auto
apply (metis less_le_not_le ord_Sab)
done

lemma (in linorder) set_iterator_rev_linord_union_correct :
  assumes it_a: "set_iterator_rev_linord it_a S_a"
  assumes it_b: "set_iterator_rev_linord it_b S_b"
  assumes ord_Sab: "\<And>a b. \<lbrakk>a \<in> S_a; b \<in> S_b\<rbrakk> \<Longrightarrow> a > b"
  shows "set_iterator_rev_linord (set_iterator_union it_a it_b) (S_a \<union> S_b)"
unfolding set_iterator_rev_linord_def
apply (rule_tac set_iterator_genord_union_correct[
   OF it_a[unfolded set_iterator_rev_linord_def] it_b[unfolded set_iterator_rev_linord_def]])
apply (insert ord_Sab)
apply auto
apply (metis less_le_not_le ord_Sab)
done

lemma (in linorder) map_iterator_linord_union_correct :
  assumes it_a: "set_iterator_map_linord it_a S_a"
  assumes it_b: "set_iterator_map_linord it_b S_b"
  assumes ord_Sab: "\<And>kv kv'. \<lbrakk>kv \<in> S_a; kv' \<in> S_b\<rbrakk> \<Longrightarrow> fst kv < fst kv'"
  shows "set_iterator_map_linord (set_iterator_union it_a it_b) (S_a \<union> S_b)"
  unfolding set_iterator_map_linord_def
  apply (rule set_iterator_genord_union_correct [OF
    it_a[unfolded set_iterator_map_linord_def]
    it_b[unfolded set_iterator_map_linord_def]])
  apply (insert ord_Sab)
  apply auto
  apply (metis less_le_not_le)
done

lemma (in linorder) map_iterator_rev_linord_union_correct :
  assumes it_a: "set_iterator_map_rev_linord it_a S_a"
  assumes it_b: "set_iterator_map_rev_linord it_b S_b"
  assumes ord_Sab: "\<And>kv kv'. \<lbrakk>kv \<in> S_a; kv' \<in> S_b\<rbrakk> \<Longrightarrow> fst kv > fst kv'"
  shows "set_iterator_map_rev_linord (set_iterator_union it_a it_b) (S_a \<union> S_b)"
  unfolding set_iterator_map_rev_linord_def
  apply (rule set_iterator_genord_union_correct [OF
    it_a[unfolded set_iterator_map_rev_linord_def]
    it_b[unfolded set_iterator_map_rev_linord_def]])
  apply (insert ord_Sab)
  apply auto
  apply (metis less_le_not_le)
done

subsection {* Product *}

definition set_iterator_product ::
    "('a,'\<sigma>) set_iterator \<Rightarrow> ('a \<Rightarrow> ('b,'\<sigma>) set_iterator) \<Rightarrow> ('a \<times> 'b ,'\<sigma>) set_iterator" where
  "set_iterator_product it_a it_b \<equiv> \<lambda>c f \<sigma>0.
    it_a c (
      \<lambda>a \<sigma>. it_b a c (\<lambda>b \<sigma>. f (a,b) \<sigma>) \<sigma>
    ) \<sigma>0"

lemma set_iterator_product_foldli_conv:
  "set_iterator_product (foldli as) (\<lambda>a. foldli (bs a)) =
   foldli (concat (map (\<lambda>a. map (\<lambda>b. (a, b)) (bs a)) as))"
apply (induct as)
  apply (simp add: set_iterator_product_def)
apply (simp add: set_iterator_product_def foldli_append foldli_map o_def fun_eq_iff)
done

lemma set_iterator_product_it_b_cong:
assumes it_a_OK: "set_iterator it_a S_a"
    and it_b_b': "\<And>a. a \<in> S_a \<Longrightarrow> it_b a = it_b' a"
shows "set_iterator_product it_a it_b =
       set_iterator_product it_a it_b'"
proof -
  from it_a_OK obtain as where
    dist_as: "distinct as" and S_a_eq: "S_a = set as" and
    it_a_eq: "it_a = foldli as"
  unfolding set_iterator_foldli_conv by blast

  from it_b_b'[unfolded S_a_eq]
  show ?thesis unfolding it_a_eq
    by (induct as)
       (simp_all add: set_iterator_product_def it_b_b' fun_eq_iff)
qed

definition set_iterator_product_order ::
  "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow>
   ('a \<times> 'b) \<Rightarrow> ('a \<times> 'b) \<Rightarrow> bool" where
  "set_iterator_product_order R_a R_b ab ab' \<longleftrightarrow>
   (if (fst ab = fst ab') then R_b (fst ab) (snd ab) (snd ab') else
                               R_a (fst ab) (fst ab'))"

lemma set_iterator_genord_product_correct :
  fixes it_a :: "('a,'\<sigma>) set_iterator"
  fixes it_b :: "'a \<Rightarrow> ('b,'\<sigma>) set_iterator"
  assumes it_a: "set_iterator_genord it_a S_a R_a"
  assumes it_b: "\<And>a. a \<in> S_a \<Longrightarrow> set_iterator_genord (it_b a) (S_b a) (R_b a)"
  shows "set_iterator_genord (set_iterator_product it_a it_b) (Sigma S_a S_b)
             (set_iterator_product_order R_a R_b)"
proof -
  from it_a obtain as where
    dist_as: "distinct as" and S_a_eq: "S_a = set as" and
    sorted_as: "sorted_by_rel R_a as" and it_a_eq: "it_a = foldli as"
  unfolding set_iterator_genord_foldli_conv by blast

  from it_b obtain bs where
    dist_bs: "\<And>a. a \<in> set as \<Longrightarrow> distinct (bs a)" and S_b_eq: "\<And>a. a \<in> set as \<Longrightarrow>  S_b a = set (bs a)" and
    sorted_bs: "\<And>a. a \<in> set as \<Longrightarrow> sorted_by_rel (R_b a) (bs a)" and
    it_b_eq: "\<And>a. a \<in> set as \<Longrightarrow> it_b a = foldli (bs a)"
  unfolding set_iterator_genord_foldli_conv by (metis S_a_eq)

  let ?abs = "concat (map (\<lambda>a. map (\<lambda>b. (a, b)) (bs a)) as)"

  show ?thesis
  proof (rule set_iterator_genord_I[of ?abs])
    from set_iterator_product_it_b_cong[of it_a S_a it_b,
       OF set_iterator_intro[OF it_a] it_b_eq] it_a_eq S_a_eq
    have "set_iterator_product it_a it_b =
          set_iterator_product (foldli as) (\<lambda>a. foldli (bs a))" by simp
    thus "set_iterator_product it_a it_b = foldli ?abs"
      by (simp add: set_iterator_product_foldli_conv)
  next
    show "distinct ?abs"
    using dist_as dist_bs[unfolded S_a_eq]
    by (induct as)
       (simp_all add: distinct_map inj_on_def dist_bs set_eq_iff image_iff)
  next
    show "Sigma S_a S_b = set ?abs"
      unfolding S_a_eq using S_b_eq
      by (induct as) auto
  next
    from sorted_as sorted_bs dist_as
    show "sorted_by_rel
           (set_iterator_product_order R_a R_b)
           (concat (map (\<lambda>a. map (Pair a) (bs a)) as))"
    proof (induct as rule: list.induct)
      case Nil thus ?case by simp
    next
      case (Cons a as)
      from Cons(2) have R_a_as: "\<And>a'. a' \<in> set as \<Longrightarrow> R_a a a'" and
                        sorted_as: "sorted_by_rel R_a as" by simp_all
      from Cons(3) have sorted_bs_a: "sorted_by_rel (R_b a) (bs a)"
                    and sorted_bs_as: "\<And>a. a \<in> set as \<Longrightarrow> sorted_by_rel (R_b a) (bs a)" by simp_all
      from Cons(4) have dist_as: "distinct as" and a_nin_as: "a \<notin> set as" by simp_all
      note ind_hyp = Cons(1)[OF sorted_as sorted_bs_as dist_as]

      def bs_a \<equiv> "bs a"
      from sorted_bs_a
      have sorted_prod_a : "sorted_by_rel (set_iterator_product_order R_a R_b) (map (Pair a) (bs a))"
        unfolding bs_a_def[symmetric]
        apply (induct bs_a rule: list.induct)
        apply (simp_all add: set_iterator_product_order_def Ball_def image_iff)
      done

      show ?case
        apply (simp add: sorted_by_rel_append ind_hyp sorted_prod_a)
        apply (simp add: set_iterator_product_order_def R_a_as a_nin_as)
      done
    qed
  qed
qed

lemma set_iterator_product_correct :
  assumes it_a: "set_iterator it_a S_a"
  assumes it_b: "\<And>a. a \<in> S_a \<Longrightarrow> set_iterator (it_b a) (S_b a)"
  shows "set_iterator (set_iterator_product it_a it_b) (Sigma S_a S_b)"
proof -
  note res' = set_iterator_genord_product_correct [OF it_a[unfolded set_iterator_def],
     of it_b S_b "\<lambda>_ _ _. True", OF it_b[unfolded set_iterator_def]]
  note res = set_iterator_intro [OF res']
  thus ?thesis by simp
qed

subsection {* Filter and Image *}

text {* Filtering and applying an injective function on iterators is easily defineable as well.
  In contrast to sets the function really has to be injective, because an iterator guarentees to
  visit each element only once. *}

definition set_iterator_image_filter ::
    "('a \<Rightarrow> 'b option) \<Rightarrow> ('a,'\<sigma>) set_iterator \<Rightarrow> ('b,'\<sigma>) set_iterator" where
  "set_iterator_image_filter g it \<equiv> \<lambda>c f \<sigma>0. (it c
     (\<lambda>x \<sigma>. (case (g x) of Some x' \<Rightarrow> f x' \<sigma> | None \<Rightarrow> \<sigma>)) \<sigma>0)"

lemma set_iterator_image_filter_foldli_conv :
  "set_iterator_image_filter g (foldli xs) =
   foldli (List.map_filter g xs)"
by (induct xs) (auto simp add: List.map_filter_def set_iterator_image_filter_def fun_eq_iff)

lemma set_iterator_genord_image_filter_correct :
  fixes it :: "('a,'\<sigma>) set_iterator"
  fixes g :: "'a \<Rightarrow> 'b option"
  assumes it_OK: "set_iterator_genord it S R"
  assumes g_inj_on: "inj_on g (S \<inter> dom g)"
  assumes R'_prop: "\<And>x y x' y'. \<lbrakk>x \<in> S; g x = Some x'; y \<in> S; g y = Some y'; R x y\<rbrakk> \<Longrightarrow> R' x' y'"
  shows "set_iterator_genord (set_iterator_image_filter g it) {y. \<exists>x. x \<in> S \<and> g x = Some y} R'"
proof -
  from it_OK obtain xs where
    dist_xs: "distinct xs" and S_eq: "S = set xs" and
    sorted_xs: "sorted_by_rel R xs" and it_eq: "it = foldli xs"
  unfolding set_iterator_genord_foldli_conv by blast

  show ?thesis
  proof (rule set_iterator_genord_I [of "List.map_filter g xs"])
    show "set_iterator_image_filter g it =
          foldli (List.map_filter g xs)"
      unfolding it_eq  set_iterator_image_filter_foldli_conv by simp
  next
    from dist_xs g_inj_on[unfolded S_eq]
    show "distinct (List.map_filter g xs)"
      apply (induct xs)
      apply (simp add: List.map_filter_simps)
      apply (simp add: List.map_filter_def image_iff inj_on_def Ball_def dom_def)
      apply (metis not_Some_eq option.sel)
    done
  next
    show "{y. \<exists>x. x \<in> S \<and> g x = Some y} =
          set (List.map_filter g xs)"
      unfolding S_eq set_map_filter by simp
  next
    from sorted_xs R'_prop[unfolded S_eq]
    show "sorted_by_rel R' (List.map_filter g xs)"
    proof (induct xs rule: list.induct)
      case Nil thus ?case by (simp add: List.map_filter_simps)
    next
      case (Cons x xs)
      note sort_x_xs = Cons(2)
      note R'_x_xs = Cons(3)

      from Cons have ind_hyp: "sorted_by_rel R' (List.map_filter g xs)" by auto

      show ?case
        apply (cases "g x")
        apply (simp add: List.map_filter_simps ind_hyp)
        apply (simp add: List.map_filter_simps set_map_filter Ball_def ind_hyp)
        apply (insert R'_x_xs[of x] sort_x_xs)
        apply (simp add: Ball_def)
        apply metis
      done
    qed
  qed
qed

lemma set_iterator_image_filter_correct :
  fixes it :: "('a,'\<sigma>) set_iterator"
  fixes g :: "'a \<Rightarrow> 'b option"
  assumes it_OK: "set_iterator it S"
  assumes g_inj_on: "inj_on g (S \<inter> dom g)"
  shows "set_iterator (set_iterator_image_filter g it) {y. \<exists>x. x \<in> S \<and> g x = Some y}"
proof -
  note res' = set_iterator_genord_image_filter_correct [OF it_OK[unfolded set_iterator_def],
     of g "\<lambda>_ _. True"]
  note res = set_iterator_intro [OF res']
  with g_inj_on show ?thesis by simp
qed

text {* Special definitions for only filtering or only appling a function are handy. *}
definition set_iterator_filter ::
    "('a \<Rightarrow> bool) \<Rightarrow> ('a,'\<sigma>) set_iterator \<Rightarrow> ('a,'\<sigma>) set_iterator" where
  "set_iterator_filter P \<equiv> set_iterator_image_filter (\<lambda>x. if P x then Some x else None)"

lemma set_iterator_filter_foldli_conv :
  "set_iterator_filter P (foldli xs) = foldli (filter P xs)"
  apply (simp add: set_iterator_filter_def set_iterator_image_filter_foldli_conv)
  apply (rule cong) apply simp
  apply (induct xs)
  apply (simp_all add: List.map_filter_def)
done

lemma set_iterator_filter_alt_def [code] :
  "set_iterator_filter P it = (\<lambda>c f. it c (\<lambda>(x::'a) (\<sigma>::'b). if P x then f x \<sigma> else \<sigma>))"
proof -
  have "\<And>f. (\<lambda>(x::'a) (\<sigma>::'b).
             case if P x then Some x else None of None \<Rightarrow> \<sigma>
             | Some x' \<Rightarrow> f x' \<sigma>) =
            (\<lambda>x \<sigma>. if P x then f x \<sigma> else \<sigma>)"
     by auto
  thus ?thesis
    unfolding set_iterator_filter_def
              set_iterator_image_filter_def[abs_def]
    by simp
qed

lemma set_iterator_genord_filter_correct :
  fixes it :: "('a,'\<sigma>) set_iterator"
  assumes it_OK: "set_iterator_genord it S R"
  shows "set_iterator_genord (set_iterator_filter P it) {x. x \<in> S \<and> P x} R"
proof -
  let ?g = "\<lambda>x. if P x then Some x else None"
  have set_eq: "\<And>S. {y |x y. x \<in> S \<and> ?g x = Some y} = {x. x \<in> S \<and> P x}"  by auto
  have in_dom_g: "\<And>x. x \<in> dom ?g \<longleftrightarrow> P x" unfolding dom_def by auto

  from set_iterator_genord_image_filter_correct [OF it_OK, of ?g R, folded set_iterator_filter_def]
  show ?thesis
    by (simp add: split_if_eq1 set_eq[symmetric] inj_on_def Ball_def in_dom_g)
qed

lemma set_iterator_filter_correct :
  assumes it_OK: "set_iterator it S"
  shows "set_iterator (set_iterator_filter P it) {x. x \<in> S \<and> P x}"
proof -
  note res' = set_iterator_genord_filter_correct [OF it_OK[unfolded set_iterator_def],
    of P]
  note res = set_iterator_intro [OF res']
  thus ?thesis by simp
qed

lemma (in linorder) set_iterator_linord_filter_correct :
  assumes it_OK: "set_iterator_linord it S"
  shows "set_iterator_linord (set_iterator_filter P it) {x. x \<in> S \<and> P x}"
using assms
unfolding set_iterator_linord_def
by (rule set_iterator_genord_filter_correct)

lemma (in linorder) set_iterator_rev_linord_filter_correct :
  assumes it_OK: "set_iterator_rev_linord it S"
  shows "set_iterator_rev_linord (set_iterator_filter P it) {x. x \<in> S \<and> P x}"
using assms
unfolding set_iterator_rev_linord_def
by (rule set_iterator_genord_filter_correct)

definition set_iterator_image ::
    "('a \<Rightarrow> 'b) \<Rightarrow> ('a,'\<sigma>) set_iterator \<Rightarrow> ('b,'\<sigma>) set_iterator" where
  "set_iterator_image g \<equiv> set_iterator_image_filter (\<lambda>x. Some (g x))"

lemma set_iterator_image_foldli_conv :
  "set_iterator_image g (foldli xs) = foldli (map g xs)"
  apply (simp add: set_iterator_image_def set_iterator_image_filter_foldli_conv)
  apply (rule cong) apply simp
  apply (induct xs)
  apply (simp_all add: List.map_filter_def)
done

lemma set_iterator_image_alt_def [code] :
  "set_iterator_image g it = (\<lambda>c f. it c (\<lambda>x. f (g x)))"
unfolding set_iterator_image_def
          set_iterator_image_filter_def[abs_def]
by simp

lemma set_iterator_genord_image_correct :
  fixes it :: "('a,'\<sigma>) set_iterator"
  assumes it_OK: "set_iterator_genord it S R"
  assumes g_inj: "inj_on g S"
  assumes R'_prop: "\<And>x y. \<lbrakk>x \<in> S; y \<in> S; R x y\<rbrakk> \<Longrightarrow> R' (g x) (g y)"
  shows "set_iterator_genord (set_iterator_image g it) (g ` S) R'"
proof -
  let ?g = "\<lambda>x. Some (g x)"
  have set_eq: "\<And>S. {y . \<exists>x. x \<in> S \<and> ?g x = Some y} = g ` S" by auto

  show ?thesis
    apply (rule set_iterator_genord_image_filter_correct [OF it_OK, of ?g R',
     folded set_iterator_image_def set_eq[symmetric]])
    apply (insert g_inj, simp add: inj_on_def) []
    apply (insert R'_prop, auto)
  done
qed

lemma set_iterator_image_correct :
  assumes it_OK: "set_iterator it S"
  assumes g_inj: "inj_on g S"
  assumes S'_OK: "S' = g ` S"
  shows "set_iterator (set_iterator_image g it) S'"
proof -
  note res' = set_iterator_genord_image_correct [OF it_OK[unfolded set_iterator_def] g_inj,
    of "\<lambda>_ _. True"]
  note res = set_iterator_intro [OF res', folded S'_OK]
  thus ?thesis by simp
qed

subsection {*Construction from list (foldli)*}

text {* Iterators correspond by definition to iteration over distinct lists. They fix an order
 in which the elements are visited. Therefore, it is trivial to construct an iterator from a
 distinct list. *}

lemma set_iterator_genord_foldli_correct :
"distinct xs \<Longrightarrow> sorted_by_rel R xs \<Longrightarrow> set_iterator_genord (foldli xs) (set xs) R"
by (rule set_iterator_genord_I[of xs]) (simp_all)

lemma set_iterator_foldli_correct :
"distinct xs \<Longrightarrow> set_iterator (foldli xs) (set xs)"
by (rule set_iterator_I[of xs]) (simp_all)

lemma (in linorder) set_iterator_linord_foldli_correct :
assumes dist_xs: "distinct xs"
assumes sorted_xs: "sorted xs"
shows "set_iterator_linord (foldli xs) (set xs)"
using assms
by (rule_tac set_iterator_linord_I[of xs]) (simp_all)

lemma (in linorder) set_iterator_rev_linord_foldli_correct :
assumes dist_xs: "distinct xs"
assumes sorted_xs: "sorted (rev xs)"
shows "set_iterator_rev_linord (foldli xs) (set xs)"
using assms
by (rule_tac set_iterator_rev_linord_I[of xs]) (simp_all)

lemma map_iterator_genord_foldli_correct :
"distinct (map fst xs) \<Longrightarrow> sorted_by_rel R xs \<Longrightarrow> map_iterator_genord (foldli xs) (map_of xs) R"
by (rule map_iterator_genord_I[of xs]) simp_all

lemma map_iterator_foldli_correct :
"distinct (map fst xs) \<Longrightarrow> map_iterator (foldli xs) (map_of xs)"
by (rule map_iterator_I[of xs]) (simp_all)

lemma (in linorder) map_iterator_linord_foldli_correct :
assumes dist_xs: "distinct (map fst xs)"
assumes sorted_xs: "sorted (map fst xs)"
shows "map_iterator_linord (foldli xs) (map_of xs)"
using assms
by (rule_tac map_iterator_linord_I[of xs]) (simp_all)

lemma (in linorder) map_iterator_rev_linord_foldli_correct :
assumes dist_xs: "distinct (map fst xs)"
assumes sorted_xs: "sorted (rev (map fst xs))"
shows "map_iterator_rev_linord (foldli xs) (map_of xs)"
using assms
by (rule_tac map_iterator_rev_linord_I[of xs]) (simp_all)

subsection {*Construction from list (foldri)*}

lemma set_iterator_genord_foldri_correct :
"distinct xs \<Longrightarrow> sorted_by_rel R (rev xs) \<Longrightarrow> set_iterator_genord (foldri xs) (set xs) R"
by (rule set_iterator_genord_I[of "rev xs"]) (simp_all add: foldri_def)

lemma set_iterator_foldri_correct :
"distinct xs \<Longrightarrow> set_iterator (foldri xs) (set xs)"
by (rule set_iterator_I[of "rev xs"]) (simp_all add: foldri_def)

lemma (in linorder) set_iterator_linord_foldri_correct :
assumes dist_xs: "distinct xs"
assumes sorted_xs: "sorted (rev xs)"
shows "set_iterator_linord (foldri xs) (set xs)"
using assms
by (rule_tac set_iterator_linord_I[of "rev xs"]) (simp_all add: foldri_def)

lemma (in linorder) set_iterator_rev_linord_foldri_correct :
assumes dist_xs: "distinct xs"
assumes sorted_xs: "sorted xs"
shows "set_iterator_rev_linord (foldri xs) (set xs)"
using assms
by (rule_tac set_iterator_rev_linord_I[of "rev xs"]) (simp_all add: foldri_def)

lemma map_iterator_genord_foldri_correct :
"distinct (map fst xs) \<Longrightarrow> sorted_by_rel R (rev xs) \<Longrightarrow> map_iterator_genord (foldri xs) (map_of xs) R"
by (rule map_iterator_genord_I[of "rev xs"])
   (simp_all add: rev_map[symmetric] foldri_def)

lemma map_iterator_foldri_correct :
"distinct (map fst xs) \<Longrightarrow> map_iterator (foldri xs) (map_of xs)"
by (rule map_iterator_I[of "rev xs"])
   (simp_all add: rev_map[symmetric] foldri_def)

lemma (in linorder) map_iterator_linord_foldri_correct :
assumes dist_xs: "distinct (map fst xs)"
assumes sorted_xs: "sorted (rev (map fst xs))"
shows "map_iterator_linord (foldri xs) (map_of xs)"
using assms
by (rule_tac map_iterator_linord_I[of "rev xs"])
   (simp_all add: rev_map[symmetric] foldri_def)

lemma (in linorder) map_iterator_rev_linord_foldri_correct :
assumes dist_xs: "distinct (map fst xs)"
assumes sorted_xs: "sorted (map fst xs)"
shows "map_iterator_rev_linord (foldri xs) (map_of xs)"
using assms
by (rule_tac map_iterator_rev_linord_I[of "rev xs"])
   (simp_all add: rev_map[symmetric] foldri_def)

subsection {* Iterators over Maps *}

text {* In the following iterator over the key-value pairs of a finite map are called
 iterators over maps. Operations for such iterators are presented.*}

subsubsection{* Domain Iterator *}

text {* One very simple such operation is iterating over only the keys of the map. *}

definition map_iterator_dom where
  "map_iterator_dom it = set_iterator_image fst it"

lemma map_iterator_dom_foldli_conv :
  "map_iterator_dom (foldli kvs) = foldli (map fst kvs)"
unfolding map_iterator_dom_def set_iterator_image_foldli_conv by simp

lemma map_iterator_genord_dom_correct :
  assumes it_OK: "map_iterator_genord it m R"
  assumes R'_prop: "\<And>k v k' v'. \<lbrakk>m k = Some v; m k' = Some v'; R (k, v) (k', v')\<rbrakk> \<Longrightarrow> R' k k'"
  shows "set_iterator_genord (map_iterator_dom it) (dom m) R'"
proof -
  have pre1: "inj_on fst (map_to_set m)"
     unfolding inj_on_def map_to_set_def by simp

  from set_iterator_genord_image_correct[OF it_OK pre1, of R'] R'_prop
  show ?thesis
    unfolding map_iterator_dom_def map_to_set_dom[symmetric]
    by (auto simp add: map_to_set_def)
qed

lemma map_iterator_dom_correct :
  assumes it_OK: "map_iterator it m"
  shows "set_iterator (map_iterator_dom it) (dom m)"
using assms
unfolding set_iterator_def
apply (rule_tac map_iterator_genord_dom_correct)
apply simp_all
done

lemma (in linorder) map_iterator_linord_dom_correct :
  assumes it_OK: "map_iterator_linord it m"
  shows "set_iterator_linord (map_iterator_dom it) (dom m)"
using assms
unfolding set_iterator_linord_def set_iterator_map_linord_def
apply (rule_tac map_iterator_genord_dom_correct)
apply assumption
apply auto
done

lemma (in linorder) map_iterator_rev_linord_dom_correct :
  assumes it_OK: "map_iterator_rev_linord it m"
  shows "set_iterator_rev_linord (map_iterator_dom it) (dom m)"
using assms
unfolding set_iterator_rev_linord_def set_iterator_map_rev_linord_def
apply (rule_tac map_iterator_genord_dom_correct)
apply assumption
apply auto
done

subsubsection{* Domain Iterator with Filter *}

text {* More complex is iterating over only the keys such that the key-value pairs satisfy some
        property.*}

definition map_iterator_dom_filter ::
    "('a \<times> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<times> 'b,'\<sigma>) set_iterator \<Rightarrow> ('a,'\<sigma>) set_iterator" where
  "map_iterator_dom_filter P it \<equiv> set_iterator_image_filter
     (\<lambda>xy. if P xy then Some (fst xy) else None) it"

lemma map_iterator_dom_filter_alt_def [code] :
  "map_iterator_dom_filter P it =
   (\<lambda>c f. it c (\<lambda>kv \<sigma>. if P kv then f (fst kv) \<sigma> else \<sigma>))"
unfolding map_iterator_dom_filter_def set_iterator_image_filter_def
apply (rule ext)
apply (rule ext)
apply (rule arg_cong2[where f="it"])
apply (simp)
apply (simp add: fun_eq_iff split: option.splits)
done

lemma map_iterator_genord_dom_filter_correct :
  fixes it :: "('a \<times> 'b, '\<sigma>) set_iterator"
  assumes it_OK: "set_iterator_genord it (map_to_set m) R"
  assumes R'_prop: "\<And>k1 v1 k2 v2.
      \<lbrakk>m k1 = Some v1; P (k1, v1);
       m k2 = Some v2; P (k2, v2); R (k1, v1) (k2, v2)\<rbrakk> \<Longrightarrow> R' k1 k2"
  shows "set_iterator_genord (map_iterator_dom_filter P it) {k . \<exists>v. m k = Some v \<and> P (k, v)} R'"
proof -
  def g \<equiv> "\<lambda>xy::('a \<times> 'b). if P xy then Some (fst xy) else None"

  note set_iterator_genord_image_filter_correct [OF it_OK, of g R']

  have g_eq_Some: "\<And>kv k. g kv = Some k \<longleftrightarrow> ((k = fst kv) \<and> P kv)"
    unfolding g_def by (auto split: prod.splits option.splits)

  have "\<And>x1 x2 y. x1 \<in> map_to_set m \<Longrightarrow> x2 \<in> map_to_set m \<Longrightarrow>
                  g x1 = Some y \<Longrightarrow> g x2 = Some y \<Longrightarrow> x1 = x2"
  proof -
    fix x1 x2 y
    assume x1_in: "x1 \<in> map_to_set m"
       and x2_in: "x2 \<in> map_to_set m"
       and g1_eq: "g x1 = Some y"
       and g2_eq: "g x2 = Some y"

    obtain k1 v1 where x1_eq[simp] : "x1 = (k1, v1)" by (rule PairE)
    obtain k2 v2 where x2_eq[simp] : "x2 = (k2, v2)" by (rule PairE)

    from g1_eq g2_eq g_eq_Some have k1_eq: "k1 = k2" by simp
    with x1_in x2_in have v1_eq: "v1 = v2"
      unfolding map_to_set_def by simp
    from k1_eq v1_eq show "x1 = x2" by simp
  qed
  hence g_inj_on: "inj_on g (map_to_set m \<inter> dom g)"
    unfolding inj_on_def dom_def by auto

  have g_eq_Some: "\<And>x y. (g x = Some y) \<longleftrightarrow> (P x \<and> y = (fst x))"
    unfolding g_def by auto

  have "set_iterator_genord (set_iterator_image_filter g it)
            {y. \<exists>x. x \<in> map_to_set m \<and> g x = Some y} R'"
    apply (rule set_iterator_genord_image_filter_correct [OF it_OK, of g R', OF g_inj_on])
    apply (insert R'_prop)
    apply (auto simp add: g_eq_Some map_to_set_def)
  done
  thus ?thesis
    unfolding map_iterator_dom_filter_def g_def[symmetric]
    by (simp add: g_eq_Some map_to_set_def)
qed

lemma map_iterator_dom_filter_correct :
  assumes it_OK: "map_iterator it m"
  shows "set_iterator (map_iterator_dom_filter P it) {k. \<exists>v. m k = Some v \<and> P (k, v)}"
using assms
unfolding set_iterator_def
apply (rule_tac map_iterator_genord_dom_filter_correct)
apply simp_all
done

lemma (in linorder) map_iterator_linord_dom_filter_correct :
  assumes it_OK: "map_iterator_linord it m"
  shows "set_iterator_linord (map_iterator_dom_filter P it) {k. \<exists>v. m k = Some v \<and> P (k, v)}"
using assms
unfolding set_iterator_map_linord_def set_iterator_linord_def
apply (rule_tac map_iterator_genord_dom_filter_correct
  [where R = "\<lambda>(k,_) (k',_). k\<le>k'"])
apply (simp_all add: set_iterator_def)
done

lemma (in linorder) set_iterator_rev_linord_map_filter_correct :
  assumes it_OK: "map_iterator_rev_linord it m"
  shows "set_iterator_rev_linord (map_iterator_dom_filter P it)
  {k. \<exists>v. m k = Some v \<and> P (k, v)}"
using assms
unfolding set_iterator_map_rev_linord_def set_iterator_rev_linord_def
apply (rule_tac map_iterator_genord_dom_filter_correct
  [where R = "\<lambda>(k,_) (k',_). k\<ge>k'"])
apply (simp_all add: set_iterator_def)
done

subsubsection{* Product for Maps *}

definition map_iterator_product where
  "map_iterator_product it_a it_b =
   set_iterator_image (\<lambda>kvv'. (fst (fst kvv'), snd kvv'))
    (set_iterator_product it_a (\<lambda>kv. it_b (snd kv)))"

lemma map_iterator_product_foldli_conv :
"map_iterator_product (foldli as) (\<lambda>a. foldli (bs a)) =
 foldli (concat (map (\<lambda>(k, v). map (Pair k) (bs v)) as))"
unfolding map_iterator_product_def set_iterator_product_foldli_conv set_iterator_image_foldli_conv
by (simp add: map_concat o_def split_def)

lemma map_iterator_product_alt_def [code] :
  "map_iterator_product it_a it_b =
   (\<lambda>c f. it_a c (\<lambda>a. it_b (snd a) c (\<lambda>b. f (fst a, b))))"
unfolding map_iterator_product_def set_iterator_product_def set_iterator_image_alt_def
by simp

lemma map_iterator_genord_product_correct :
  fixes it_a :: "(('k \<times> 'v),'\<sigma>) set_iterator"
  fixes it_b :: "'v \<Rightarrow> ('e,'\<sigma>) set_iterator"
  fixes S_a S_b R_a R_b m
  assumes it_a: "map_iterator_genord it_a m R_a"
  assumes it_b: "\<And>k v. m k = Some v \<Longrightarrow> set_iterator_genord (it_b v) (S_b v) (R_b v)"
  assumes R'_prop: "\<And>k v u k' v' u'.
       m k = Some v \<Longrightarrow>
       u \<in> S_b v \<Longrightarrow>
       m k' = Some v' \<Longrightarrow>
       u' \<in> S_b v' \<Longrightarrow>
       if k = k' then R_b v u u'
       else R_a (k, v) (k', v') \<Longrightarrow>
       R_ab (k, u) (k', u')"
  shows "set_iterator_genord (map_iterator_product it_a it_b)
     {(k, e) . (\<exists>v. m k = Some v \<and> e \<in> S_b v)} R_ab"
proof -
  from it_b have it_b': "\<And>kv. kv \<in> map_to_set m \<Longrightarrow>
       set_iterator_genord (it_b (snd kv)) (S_b (snd kv)) (R_b (snd kv))"
    unfolding map_to_set_def by (case_tac kv, simp)

  have "(\<Union>x\<in>{(k, v). m k = Some v}. \<Union>y\<in>S_b (snd x). {(x, y)}) = {((k,v), e) .
          (m k = Some v) \<and> e \<in> S_b v}" by (auto)
  with set_iterator_genord_product_correct [OF it_a, of "\<lambda>kv. it_b (snd kv)"
    "\<lambda>kv. S_b (snd kv)" "\<lambda>kv. R_b (snd kv)", OF it_b']
  have it_ab': "set_iterator_genord (set_iterator_product it_a (\<lambda>kv. it_b (snd kv)))
      {((k,v), e) . (m k = Some v) \<and> e \<in> S_b v}
      (set_iterator_product_order R_a
        (\<lambda>kv. R_b (snd kv)))"
     (is "set_iterator_genord ?it_ab' ?S_ab' ?R_ab'")
    unfolding map_to_set_def
    by (simp add: Sigma_def)

  let ?g = "\<lambda>kvv'. (fst (fst kvv'), snd kvv')"
  have inj_g: "inj_on ?g ?S_ab'"
    unfolding inj_on_def by simp

  have R_ab_OK: "\<And>x y.
      x \<in> {((k, v), e). m k = Some v \<and> e \<in> S_b v} \<Longrightarrow>
      y \<in> {((k, v), e). m k = Some v \<and> e \<in> S_b v} \<Longrightarrow>
      set_iterator_product_order R_a (\<lambda>kv. R_b (snd kv)) x y \<Longrightarrow>
      R_ab (fst (fst x), snd x) (fst (fst y), snd y)"
    apply (simp add: set_iterator_product_order_def)
    apply clarify
    apply (simp)
    apply (unfold fst_conv snd_conv)
    apply (metis R'_prop option.inject)
  done

  have "(?g ` {((k, v), e). m k = Some v \<and> e \<in> S_b v}) = {(k, e). \<exists>v. m k = Some v \<and> e \<in> S_b v}"
    by (simp add: image_iff set_eq_iff)
  with set_iterator_genord_image_correct [OF it_ab' inj_g, of R_ab, OF R_ab_OK]
  show ?thesis
    by (simp add: map_iterator_product_def)
qed

lemma map_iterator_product_correct :
  assumes it_a: "map_iterator it_a m"
  assumes it_b: "\<And>k v. m k = Some v \<Longrightarrow> set_iterator (it_b v) (S_b v)"
  shows "set_iterator (map_iterator_product it_a it_b)
         {(k, e) . (\<exists>v. m k = Some v \<and> e \<in> S_b v)}"
proof -
  note res' = map_iterator_genord_product_correct [OF it_a[unfolded set_iterator_def],
     of it_b S_b "\<lambda>_ _ _. True"]
  note res = set_iterator_intro [OF res']
  with it_b show ?thesis unfolding set_iterator_def by simp
qed

subsubsection{* Key Filter *}

definition map_iterator_key_filter ::
    "('a \<Rightarrow> bool) \<Rightarrow> ('a \<times> 'b,'\<sigma>) set_iterator \<Rightarrow> ('a \<times> 'b,'\<sigma>) set_iterator" where
  "map_iterator_key_filter P \<equiv> set_iterator_filter (P \<circ> fst)"

lemma map_iterator_key_filter_foldli_conv :
  "map_iterator_key_filter P (foldli kvs) =  foldli (filter (\<lambda>(k, v). P k) kvs)"
unfolding map_iterator_key_filter_def set_iterator_filter_foldli_conv o_def split_def
by simp

lemma map_iterator_key_filter_alt_def [code] :
  "map_iterator_key_filter P it = (\<lambda>c f. it c (\<lambda>x \<sigma>. if P (fst x) then f x \<sigma> else \<sigma>))"
unfolding map_iterator_key_filter_def set_iterator_filter_alt_def
  set_iterator_image_filter_def by simp

lemma map_iterator_genord_key_filter_correct :
  fixes it :: "('a \<times> 'b, '\<sigma>) set_iterator"
  assumes it_OK: "map_iterator_genord it m R"
  shows "map_iterator_genord (map_iterator_key_filter P it) (m |` {k . P k}) R"
proof -
  from set_iterator_genord_filter_correct [OF it_OK, of "P \<circ> fst",
    folded map_iterator_key_filter_def]
  have step1: "set_iterator_genord (map_iterator_key_filter P it)
                  {x \<in> map_to_set m. (P \<circ> fst) x} R"
    by simp

  have "{x \<in> map_to_set m. (P \<circ> fst) x} = map_to_set (m |` {k . P k})"
    unfolding map_to_set_def restrict_map_def
    by (auto split: if_splits)
  with step1 show ?thesis by simp
qed

lemma map_iterator_key_filter_correct :
  assumes it_OK: "map_iterator it m"
  shows "set_iterator (map_iterator_key_filter P it) (map_to_set (m |` {k . P k}))"
using assms
unfolding set_iterator_def
apply (rule_tac map_iterator_genord_key_filter_correct)
apply simp_all
done

end