(*  Title:      Group Actions
    Author:     Jakob von Raumer, Karlsruhe Institute of Technology
    Maintainer: Jakob von Raumer <jakob.raumer at student.kit.edu>
*)

theory GroupAction
imports
  "~~/src/HOL/Algebra/Bij"
  "~~/src/HOL/Algebra/Sylow"
begin

section {* Group Actions *}

text {* This is an implemention of group actions based on the group
implementation of HOL-Algebra. An action a group $G$ on a set $M$ is
represented by a group homomorphism between $G$ and the group of bijections
on $M$ *}

subsection {* Preliminaries and Definition*}

text {* First, we need two theorems about singletons and sets of singletons
which unfortunately are not included in the library. *}

theorem singleton_intersection:
  assumes A:"card A = 1"
  assumes B:"card B = 1"
  assumes noteq:"A \<noteq> B"
  shows "A \<inter> B = {}"
using assms by(auto simp:card_Suc_eq)

theorem card_singleton_set:
  assumes finA:"finite A"
  assumes cardOne:"\<forall>x \<in> A.(card x = 1)"
  shows "card (\<Union>A) = card A"
proof -
  from finA have "card (\<Union>A) = (\<Sum>x\<in>A. card x)"
  proof(rule card_Union_disjoint)
    from cardOne show "\<forall>A\<in>A. finite A" by (auto intro: card_ge_0_finite)
  next
    show "\<forall>x\<in>A. \<forall>y\<in>A. x \<noteq> y \<longrightarrow> x \<inter> y = {}"
    proof(clarify)
      fix x y
      assume x:"x \<in> A" and y:"y \<in> A" and "x \<noteq> y"
      with cardOne have "card x = 1" "card y = 1" by auto
      with `x \<noteq> y` show "x \<inter> y = {}" by (metis singleton_intersection)
    qed
  qed
  also from cardOne have "... = card A" by simp
  finally show ?thesis.
qed

text {* Intersecting Cosets are equal: *}

lemma (in subgroup) repr_independence2:
  assumes group:"group G"
  assumes U:"U \<in> rcosets\<^bsub>G\<^esub> H"
  assumes g:"g \<in> U"
  shows "U = H #> g"
proof -
  from U obtain h where h:"h \<in> carrier G" "U = H #> h" unfolding RCOSETS_def by auto
  with g have "g \<in> H #> h" by simp
  with group h show "U = H #> g" by (metis group.repr_independence is_subgroup)
qed

locale group_action = group +
  fixes \<phi> M
  assumes grouphom:"group_hom G (BijGroup M) \<phi>"

context group_action
begin

lemma is_group_action:"group_action G \<phi> M"..

text {* The action of @{term "\<one>\<^bsub>G\<^esub>"} has no effect: *}

lemma one_is_id:
  assumes "m \<in> M"
  shows "(\<phi> \<one>) m = m"
proof -
  from grouphom have "(\<phi> \<one>) m = \<one>\<^bsub>(BijGroup M)\<^esub> m" by (metis group_hom.hom_one)
  also have "... = (\<lambda>x\<in>M. x) m" unfolding BijGroup_def by (metis monoid.select_convs(2))
  also from assms have "... = m" by simp
  finally show ?thesis.
qed

lemma action_closed:
  assumes m:"m \<in> M"
  assumes g:"g \<in> carrier G"
  shows "\<phi> g m \<in> M"
using assms grouphom group_hom.hom_closed unfolding BijGroup_def Bij_def bij_betw_def by fastforce

lemma img_in_bij:
  assumes "g \<in> carrier G"
  shows "(\<phi> g) \<in> Bij M"
using assms grouphom unfolding BijGroup_def by (auto dest: group_hom.hom_closed)

text {* The action of @{term "inv g"} reverts the action of @{term g} *}

lemma group_inv_rel:
  assumes g:"g \<in> carrier G"
  assumes mn:"m \<in> M" "n \<in> M"
  assumes phi:"(\<phi> g) n = m"
  shows "(\<phi> (inv g)) m = n"
proof -
  from g have bij:"(\<phi> g) \<in> Bij M" unfolding BijGroup_def by (metis img_in_bij)
  with g grouphom have "\<phi> (inv g) = restrict (inv_into M (\<phi> g)) M" by(metis inv_BijGroup group_hom.hom_inv)
  hence "\<phi> (inv g) m = (restrict (inv_into M (\<phi> g)) M) m" by simp
  also from mn have "... = (inv_into M (\<phi> g)) m" by (metis restrict_def)
  also from g phi have "... = (inv_into M (\<phi> g)) ((\<phi> g) n)" by simp
  also from `\<phi> g \<in> Bij M` Bij_def have "bij_betw (\<phi> g) M M" by auto
  hence "inj_on (\<phi> g) M" by (metis bij_betw_imp_inj_on)
  with g mn have "(inv_into M (\<phi> g)) ((\<phi> g) n) = n" by (metis inv_into_f_f)
  finally show "\<phi> (inv g) m = n".
qed

lemma images_are_bij:
  assumes g:"g \<in> carrier G"
  shows "bij_betw (\<phi> g) M M"
proof -
  from g have bij:"(\<phi> g) \<in> Bij M" unfolding BijGroup_def by (metis img_in_bij)
  with Bij_def show "bij_betw (\<phi> g) M M" by auto
qed

lemma action_mult:
  assumes g:"g \<in> carrier G"
  assumes h:"h \<in> carrier G"
  assumes m:"m \<in> M"
  shows "(\<phi> g) ((\<phi> h) m) = (\<phi> (g \<otimes> h)) m"
proof -
  from g have \<phi>g:"(\<phi> g) \<in> Bij M" unfolding BijGroup_def by (rule img_in_bij)
  from h have \<phi>h:"(\<phi> h) \<in> Bij M" unfolding BijGroup_def by (rule img_in_bij)
  from h have "bij_betw (\<phi> h) M M" by (rule images_are_bij)
  hence "(\<phi> h) ` M = M" by (metis bij_betw_def)
  with m have hm:"(\<phi> h) m \<in> M" by (metis imageI)
  from grouphom g h have "(\<phi> (g \<otimes> h)) = ((\<phi> g) \<otimes>\<^bsub>(BijGroup M)\<^esub> (\<phi> h))" by (rule group_hom.hom_mult)
  hence "\<phi> (g \<otimes> h) m = ((\<phi> g) \<otimes>\<^bsub>(BijGroup M)\<^esub> (\<phi> h)) m" by simp
  also from \<phi>g \<phi>h have "... = (compose M (\<phi> g) (\<phi> h)) m" unfolding BijGroup_def by simp
  also from \<phi>g \<phi>h hm have "... = (\<phi> g) ((\<phi> h) m)" by (metis compose_eq m)
  finally show "(\<phi> g) ((\<phi> h) m) = (\<phi> (g \<otimes> h)) m"..
qed

subsection {* The orbit relation *}

text {* The following describes the relation containing the information
whether two elements of @{term M} lie in the same orbit of the action *}

definition same_orbit_rel
  where "same_orbit_rel = {p \<in> M \<times> M. \<exists>g \<in> carrier G. (\<phi> g) (snd p) = (fst p)}"

text {* Use the library about equivalence relations to define the set of
orbits and the map assigning to each element of @{term M} its orbit *}

definition orbits
 where "orbits = M // same_orbit_rel"

definition orbit :: "'c \<Rightarrow> 'c set"
  where "orbit m = same_orbit_rel `` {m}"

text {* Next, we define a more easy-to-use characterization of an orbit. *}

lemma orbit_char:
  assumes m:"m \<in> M"
  shows "orbit m = {n. \<exists>g. g \<in> carrier G \<and> (\<phi> g) m = n}"
using assms unfolding orbit_def Image_def same_orbit_rel_def
proof(auto)
  fix x g
  assume g:"g \<in> carrier G" and "\<phi> g x \<in> M" "x \<in> M"
  hence "\<phi> (inv g) (\<phi> g x) = x" by (metis group_inv_rel)
  moreover from g have "inv g \<in> carrier G" by (rule inv_closed)
  ultimately show "\<exists>h. h \<in> carrier G \<and> \<phi> h (\<phi> g x) = x" by auto
next
  fix g
  assume g:"g \<in> carrier G"
  with m show "\<phi> g m \<in> M" by (metis action_closed)
  with m g have "\<phi> (inv g) (\<phi> g m) = m" by (metis group_inv_rel)
  moreover from g have "inv g \<in> carrier G" by (rule inv_closed)
  ultimately show "\<exists>h\<in>carrier G. \<phi> h (\<phi> g m) = m" by auto
qed

text {* Now we show that the relation we've defined is, indeed, an
equivalence relation: *}

lemma same_orbit_is_equiv:
  shows "equiv M same_orbit_rel"
proof(rule equivI)
  show "refl_on M same_orbit_rel"
  proof(rule refl_onI)
    show "same_orbit_rel \<subseteq> M \<times> M" unfolding same_orbit_rel_def by auto
  next
    fix m
    assume "m \<in> M"
    hence "(\<phi> \<one>) m = m" by(rule one_is_id)
    with `m \<in> M` show  "(m, m) \<in> same_orbit_rel" unfolding same_orbit_rel_def by (auto simp:same_orbit_char)
  qed
next
  show "sym same_orbit_rel"
  proof(rule symI)
    fix m n
    assume mn:"(m, n) \<in> same_orbit_rel"
    then obtain g where g:"g \<in> carrier G" "\<phi> g n = m" unfolding same_orbit_rel_def by auto
    hence invg:"inv g \<in> carrier G" by (metis inv_closed)
    from mn have "(m, n) \<in> M \<times> M" unfolding same_orbit_rel_def by simp
    hence mn2:"m \<in> M" "n \<in> M" by auto
    from g mn2 have "\<phi> (inv g) m = n" by (metis group_inv_rel)
    with invg mn2 show "(n, m) \<in> same_orbit_rel" unfolding same_orbit_rel_def by auto
  qed
next
  show "trans same_orbit_rel"
  proof(rule transI)
    fix x y z
    assume xy:"(x, y) \<in> same_orbit_rel"
    then obtain g where g:"g \<in> carrier G" and grel:"(\<phi> g) y = x" unfolding same_orbit_rel_def by auto
    assume yz:"(y, z) \<in> same_orbit_rel"
    then obtain h where h:"h \<in> carrier G" and hrel:"(\<phi> h) z = y" unfolding same_orbit_rel_def by auto
    from g h have gh:"g \<otimes> h \<in> carrier G" by simp
    from xy yz have "x \<in> M" "z \<in> M" unfolding same_orbit_rel_def by auto
    with g h have "\<phi> (g \<otimes> h) z = (\<phi> g) ((\<phi> h) z)" by (metis action_mult)
    also from hrel grel have "... = x" by simp
    finally have "\<phi> (g \<otimes> h) z = x".
    with gh `x \<in> M` `z \<in> M` show "(x, z) \<in> same_orbit_rel" unfolding same_orbit_rel_def by auto
  qed
qed

subsection {* Stabilizer and fixed points *}

text {* The following definition models the stabilizer of a group action: *}

definition stabilizer :: "'c \<Rightarrow> _"
  where "stabilizer m = {g \<in> carrier G. (\<phi> g) m = m}"

text {*This shows that the stabilizer of @{term m} is a subgroup of @{term G}. *}

lemma stabilizer_is_subgroup:
  assumes m:"m \<in> M"
  shows "subgroup (stabilizer m) G"
proof(rule subgroupI)
  show "stabilizer m \<subseteq> carrier G" unfolding stabilizer_def by auto
next
  from m have "(\<phi> \<one>) m = m" by (rule one_is_id)
  hence "\<one> \<in> stabilizer m" unfolding stabilizer_def by simp
  thus "stabilizer m \<noteq> {}" by auto
next
  fix g
  assume g:"g \<in> stabilizer m"
  hence "g \<in> carrier G" "(\<phi> g) m = m" unfolding stabilizer_def by simp+
  with m have ginv:"(\<phi> (inv g)) m = m" by (metis group_inv_rel)
  from `g \<in> carrier G` have "inv g \<in> carrier G" by (metis inv_closed)
  with ginv show "(inv g) \<in>  stabilizer m" unfolding stabilizer_def by simp
next
  fix g h
  assume g:"g \<in> stabilizer m"
  hence g2:"g \<in> carrier G" unfolding stabilizer_def by simp
  assume h:"h \<in> stabilizer m"
  hence h2:"h \<in> carrier G" unfolding stabilizer_def by simp
  with g2 have gh:"g \<otimes> h \<in> carrier G" by (rule m_closed)
  from g2 h2 m have "\<phi> (g \<otimes> h) m = (\<phi> g) ((\<phi> h) m)" by (metis action_mult)
  also from g h have "... = m" unfolding stabilizer_def by simp
  finally have "\<phi> (g \<otimes> h) m = m".
  with gh show "g \<otimes> h \<in> stabilizer m" unfolding stabilizer_def by simp
qed

text {* Next, we define and characterize the fixed points of a group action. *}

definition fixed_points :: "'c set"
  where "fixed_points = {m \<in> M. carrier G \<subseteq> stabilizer m}"

lemma fixed_point_char:
  assumes "m \<in> M"
  shows "(m \<in> fixed_points) = (\<forall>g\<in>carrier G. \<phi> g m = m)"
using assms unfolding fixed_points_def stabilizer_def by force

lemma orbit_contains_rep:
  assumes m:"m \<in> M"
  shows "m \<in> orbit m"
unfolding orbit_def using assms by (metis equiv_class_self same_orbit_is_equiv)

lemma singleton_orbit_eq_fixed_point:
  assumes m:"m \<in> M"
  shows "(card (orbit m) = 1) = (m \<in> fixed_points)"
proof
  assume card:"card (orbit m) = 1"
  from m have "m \<in> orbit m" by (rule orbit_contains_rep)
  from m show "m \<in> fixed_points" unfolding fixed_points_def
  proof(auto)
    fix g
    assume gG:"g \<in> carrier G"
    with m have "\<phi> g m \<in> orbit m" by (auto dest:orbit_char)
    with `m \<in> orbit m` card have "\<phi> g m = m" by (auto simp add: card_Suc_eq)
    with gG show "g \<in> stabilizer m" unfolding stabilizer_def by simp
  qed
next
  assume "m \<in> fixed_points"
  hence fixed:"carrier G \<subseteq> stabilizer m" unfolding fixed_points_def by simp
  from m have "orbit m = {m}"
  proof(auto simp add: orbit_contains_rep)
    fix n
    assume "n \<in> orbit m"
    with m obtain g where g:"g \<in> carrier G" "\<phi> g m = n"  by (auto dest: orbit_char)
    moreover with fixed have "\<phi> g m = m" unfolding stabilizer_def by auto
    ultimately show "n = m" by simp
  qed
  thus "card (orbit m) = 1" by simp
qed

subsection {* The Orbit-Stabilizer Theorem *}

text {* This section contains some theorems about orbits and their quotient
groups. The first one is the well-known orbit-stabilizer theorem which
establishes a bijection between the the quotient group of the an element's
stabilizer and its orbit. *}

theorem orbit_thm:
  assumes m:"m \<in> M"
  assumes rep:"\<And>U. U \<in> (carrier (G Mod (stabilizer m))) \<Longrightarrow> rep U \<in> U"
  shows "bij_betw (\<lambda>H. (\<phi> (inv (rep H)) m)) (carrier (G Mod (stabilizer m))) (orbit m)"
apply(simp add:bij_betw_def)
proof(auto)
  show "inj_on (\<lambda>H. \<phi> (inv (rep H)) m) (carrier (G Mod stabilizer m))"
  proof(rule inj_onI)
    fix U V
    assume U:"U \<in> carrier (G Mod (stabilizer m))"
    assume V:"V \<in> carrier (G Mod (stabilizer m))"
    def h \<equiv> "rep V"
    def g \<equiv> "rep U"
    have stabSubset:"(stabilizer m) \<subseteq> carrier G" unfolding stabilizer_def by auto
    from m have stabSubgroup: "subgroup (stabilizer m) G" by (metis stabilizer_is_subgroup)
    from V rep have hV:"h \<in> V" unfolding h_def by simp
    from V stabSubset have "V \<subseteq> carrier G" unfolding FactGroup_def RCOSETS_def r_coset_def by auto
    with hV have hG:"h \<in> carrier G" by auto
    hence hinvG:"inv h \<in> carrier G" by (metis inv_closed)
    from U rep have gU:"g \<in> U" unfolding g_def by simp
    from U stabSubset have "U \<subseteq> carrier G" unfolding FactGroup_def RCOSETS_def r_coset_def by auto
    with gU have gG:"g \<in> carrier G" by auto
    hence ginvG:"inv g \<in> carrier G" by (metis inv_closed)
    from gG hinvG have ginvhG: "g \<otimes> inv h \<in> carrier G" by (metis m_closed)
    assume reps:"\<phi> (inv rep U) m = \<phi> (inv rep V) m"
    hence gh:"\<phi> (inv g) m = \<phi> (inv h) m" unfolding g_def h_def.
    from gG hinvG m have "\<phi> (g \<otimes> (inv h)) m = \<phi> g (\<phi> (inv h) m)" by (metis action_mult)
    also with gh ginvG gG m have "... = \<phi> (g \<otimes> inv g) m" by (metis action_mult)
    also with m gG have "... = m" by (auto simp: one_is_id)
    finally have "\<phi> (g \<otimes> inv h) m = m".
    with ginvhG have "(g \<otimes> inv h) \<in> stabilizer m" unfolding stabilizer_def by simp
    hence "(stabilizer m) #> (g \<otimes> inv h) = (stabilizer m) #> \<one>" by (metis coset_join2 coset_mult_one m stabSubset stabilizer_is_subgroup subgroup.mem_carrier)
    with hinvG hG gG stabSubset have  stabgstabh:"(stabilizer m) #> g = (stabilizer m) #> h" by (metis coset_mult_inv1 group.coset_mult_one is_group)
    from stabSubgroup is_group U gU have "U = (stabilizer m) #> g" unfolding FactGroup_def by (simp add:subgroup.repr_independence2)
    also with stabgstabh is_group stabSubgroup V hV subgroup.repr_independence2 have "... = V" unfolding FactGroup_def by force
    finally show "U = V".
  qed
next
  have stabSubset:"stabilizer m \<subseteq> carrier G" unfolding stabilizer_def by auto
  fix H
  assume H:"H \<in> carrier (G Mod stabilizer m)"
  with rep have "rep H \<in> H" by simp
  moreover with H stabSubset have "H \<subseteq> carrier G" unfolding FactGroup_def RCOSETS_def r_coset_def by auto
  ultimately have "rep H \<in> carrier G"..
  hence "inv rep H \<in> carrier G" by (rule inv_closed)
  with m show "\<phi> (inv rep H) m \<in> orbit m" by (auto dest:orbit_char)
next
  fix n
  assume "n \<in> orbit m"
  with m obtain g where g:"g \<in> carrier G" "\<phi> g m = n" by (auto dest:orbit_char)
  hence invg:"inv g \<in> carrier G" by simp
  hence stabinvg:"((stabilizer m) #> (inv g)) \<in> carrier (G Mod stabilizer m)" unfolding FactGroup_def RCOSETS_def by auto
  hence "rep ((stabilizer m) #> (inv g)) \<in> (stabilizer m) #> (inv g)" by (metis rep)
  then obtain h where h:"h \<in> stabilizer m" "rep ((stabilizer m) #> (inv g)) = h \<otimes> (inv g)" unfolding r_coset_def by auto
  with g have "\<phi> (inv rep ((stabilizer m) #> (inv g))) m =  \<phi> (inv (h \<otimes> (inv g))) m" by simp
  also from h have hG:"h \<in> carrier G" unfolding stabilizer_def by simp
  with g have "\<phi> (inv (h \<otimes> (inv g))) m = \<phi> (g \<otimes> (inv h)) m" by (metis inv_closed inv_inv inv_mult_group)
  also from g hG m have "... = \<phi> g (\<phi> (inv h) m)" by (metis action_mult inv_closed)
  also from h m have "inv h \<in> stabilizer m" by (metis stabilizer_is_subgroup subgroup.m_inv_closed)
  hence "\<phi> g (\<phi> (inv h) m) = \<phi> g m" unfolding stabilizer_def by simp
  also from g have "... = n" by simp
  finally have "n = \<phi> (inv rep ((stabilizer m) #> (inv g))) m"..
  with stabinvg show "n \<in> (\<lambda>H. \<phi> (inv rep H) m) ` carrier (G Mod stabilizer m)" by simp
qed

text {* In the case of @{term G} being finite, the last theorem can be reduced
to a statement about the cardinality of orbit and stabilizer: *}

corollary orbit_size:
  assumes fin:"finite (carrier G)"
  assumes m:"m \<in> M"
  shows "order G = card (orbit m) * card (stabilizer m)"
proof -
  def rep \<equiv> "\<lambda>U \<in> (carrier (G Mod (stabilizer m))). (SOME x. x \<in> U)"
  have "\<And>U. U \<in> (carrier (G Mod (stabilizer m))) \<Longrightarrow> rep U \<in> U"
  proof -
    fix U
    assume U:"U \<in> carrier (G Mod stabilizer m)"
    then obtain g where "g \<in> carrier G" " U = (stabilizer m) #> g" unfolding FactGroup_def RCOSETS_def by auto
    with m have "(SOME x. x \<in> U) \<in> U" by (metis rcos_self stabilizer_is_subgroup someI_ex)
    with U show "rep U \<in> U" unfolding rep_def by simp
  qed
  with m have  bij:"card (carrier (G Mod (stabilizer m))) = card (orbit m)" by (metis bij_betw_same_card orbit_thm)
  from fin m have "card (carrier (G Mod (stabilizer m))) * card (stabilizer m)  = order G" unfolding FactGroup_def by (simp add: stabilizer_is_subgroup lagrange)
  with bij show ?thesis by simp
qed

lemma orbit_not_empty:
  assumes fin:"finite M"
  assumes A:"A \<in> orbits"
  shows "card A > 0"
proof -
  from A obtain m where "m \<in> M" "A = orbit m" unfolding orbits_def quotient_def orbit_def by auto
  hence "m \<in> A" by (metis orbit_contains_rep)
  hence "A \<noteq> {}" unfolding orbits_def by auto
  moreover from fin A have "finite A" unfolding orbits_def quotient_def Image_def same_orbit_rel_def by auto
  ultimately show ?thesis by auto
qed

lemma fin_set_imp_fin_orbits:
  assumes finM:"finite M"
  shows "finite orbits"
using assms unfolding orbits_def quotient_def by simp

(*One-Element-Orbits are Fixed Points*)
lemma singleton_orbits:
  shows "\<Union>{N\<in>orbits. card N = 1} = fixed_points"
proof
  show "\<Union>{N \<in> orbits. card N = 1} \<subseteq> fixed_points"
  proof
    fix x
    assume a:"x \<in> \<Union>{N \<in> orbits. card N = 1}"
    hence "x \<in> M" unfolding orbits_def quotient_def Image_def same_orbit_rel_def by auto
    from a obtain N where N:"N \<in> orbits" "card N = 1" "x \<in> N" by auto
    then obtain y where Norbit:"N = orbit y" "y \<in> M" unfolding orbits_def quotient_def orbit_def by auto
    hence "y \<in> N" by (metis orbit_contains_rep)
    with N have Nsing:"N = {x}" "N = {y}" by (auto simp: card_Suc_eq)
    hence "x = y" by simp
    with Norbit have Norbit2:"N = orbit x" by simp
    have "{g \<in> carrier G. \<phi> g x = x} = carrier G"
    proof(auto)
      fix g
      assume "g \<in> carrier G"
      with `x \<in> M` have "\<phi> g x \<in> orbit x" by (auto dest:orbit_char)
      with Nsing show "\<phi> g x = x" by (metis Norbit2 singleton_iff)
    qed
    with `x \<in> M` show "x \<in> fixed_points" unfolding fixed_points_def stabilizer_def by simp
  qed
next
  show "fixed_points \<subseteq> \<Union>{N \<in> orbits. card N = 1}"
  proof
    fix m
    assume m:"m \<in> fixed_points"
    hence mM:"m \<in> M" unfolding fixed_points_def by simp
    hence orbit:"orbit m \<in> orbits" unfolding orbits_def quotient_def orbit_def by auto
    from mM m have "card (orbit m) = 1" by (metis singleton_orbit_eq_fixed_point)
    with orbit have "orbit m \<in> {N \<in> orbits. card N = 1}" by simp
    with mM show "m \<in> \<Union>{N \<in> orbits. card N = 1}" by (auto dest: orbit_contains_rep)
  qed
qed

text {* If @{term G} is a @{term p}-group acting on a finite set, a given orbit is
either a singleton or @{term p} divides its cardinality. *}

lemma p_dvd_orbit_size:
  assumes orderG:"order G = p ^ a"
  assumes prime:"prime p"
  assumes finM:"finite M"
  assumes Norbit:"N \<in> orbits"
  assumes "card N > 1"
  shows "p dvd card N"
proof -
  from Norbit obtain m where m:"m \<in> M" "N = orbit m"  unfolding orbits_def quotient_def orbit_def by auto
  from prime have "0 < p ^ a" by (metis zero_less_prime_power)
  with orderG have "finite (carrier G)" unfolding order_def by (metis card_infinite less_nat_zero_code)
  with m have "order G = card (orbit m) * card (stabilizer m)" by (metis orbit_size)
  with orderG m have "p ^ a = card N * card (stabilizer m)" by simp
  with `card N > 1` show ?thesis
    by (metis dvd_mult2 dvd_mult_cancel1 nat_dvd_not_less nat_mult_1 prime prime_dvd_power_nat prime_factor_nat prime_nat_def zero_less_one)
qed

text {* As a result of the last lemma the only orbits that count modulo
@{term p} are the fixed points *}

lemma fixed_point_congruence:
  assumes "order G = p ^ a"
  assumes "prime p"
  assumes finM:"finite M"
  shows "card M mod p = card fixed_points mod p"
proof -
  def big_orbits \<equiv> "{N\<in>orbits. card N > 1}"
  from finM have orbit_part:"orbits = big_orbits \<union> {N\<in>orbits. card N = 1}" unfolding big_orbits_def by (auto dest:orbit_not_empty)
  have orbit_disj:"big_orbits \<inter> {N\<in>orbits. card N = 1} = {}" unfolding big_orbits_def by auto
  from finM have orbits_fin:"finite orbits" by (rule fin_set_imp_fin_orbits)
  hence fin_parts:"finite big_orbits" "finite {N\<in>orbits. card N = 1}" unfolding big_orbits_def by simp+
  from assms have "\<And>N. N \<in> big_orbits \<Longrightarrow> p dvd card N" unfolding big_orbits_def by (auto simp: p_dvd_orbit_size)
  hence orbit_div:"\<And>N. N \<in> big_orbits \<Longrightarrow> card N = (card N div p) * p" by (metis dvd_mult_div_cancel mult.commute)
  have "card M = card (\<Union> orbits)" unfolding orbits_def by (metis Union_quotient same_orbit_is_equiv)
  also from orbits_fin have "card (\<Union> orbits) = (\<Sum>N\<in>orbits. card N)" unfolding orbits_def
  apply(rule card_Union_disjoint)
    defer 1
    apply(metis same_orbit_is_equiv quotient_disj)
    using finM same_orbit_rel_def apply(auto dest:finite_equiv_class)
  done
  also from orbit_part orbit_disj fin_parts have "... = (\<Sum>N\<in>big_orbits. card N) + (\<Sum>N\<in>{N'\<in>orbits. card N' = 1}. card N)" by (metis (lifting) setsum.union_disjoint)
  also from assms orbit_div fin_parts have "... = (\<Sum>N\<in>big_orbits. (card N div p) * p) + card (\<Union>{N'\<in>orbits. card N' = 1})" by (auto simp: card_singleton_set)
  also have "... = (\<Sum>N\<in>big_orbits. card N div p) * p + card fixed_points" using singleton_orbits by (auto simp:setsum_left_distrib)
  finally have "card M = (\<Sum>N\<in>big_orbits. card N div p) * p + card fixed_points".
  hence "card M mod p = ((\<Sum>N\<in>big_orbits. card N div p) * p + card fixed_points) mod p" by simp
  also have "... = (card fixed_points) mod p" by (metis mod_mult_self3)
  finally show ?thesis.
qed

text {* We can restrict any group action to the action of a subgroup: *}

lemma subgroup_action:
  assumes H:"subgroup H G"
  shows "group_action (G\<lparr>carrier := H\<rparr>) \<phi> M"
unfolding group_action_def group_action_axioms_def group_hom_def group_hom_axioms_def hom_def
using assms
proof (auto simp add: is_group subgroup.subgroup_is_group group_BijGroup)
  fix x
  assume "x \<in> H"
  with H have "x \<in> carrier G" by (metis subgroup.mem_carrier)
  with grouphom show "\<phi> x \<in> carrier (BijGroup M)" by (metis group_hom.hom_closed)
next
  fix x y
  assume x:"x \<in> H" and y:"y \<in> H"
  with H have "x \<in> carrier G" "y \<in> carrier G" by (metis subgroup.mem_carrier)+
  with grouphom show "\<phi> (x \<otimes> y) = \<phi> x \<otimes>\<^bsub>BijGroup M\<^esub> \<phi> y" by (simp add: group_hom.hom_mult)
qed

end

subsection {* Some Examples for Group Actions *}

lemma (in group) right_mult_is_bij:
  assumes h:"h \<in> carrier G"
  shows "(\<lambda>g \<in> carrier G. h \<otimes> g) \<in> Bij (carrier G)"
proof(auto simp add:Bij_def bij_betw_def inj_on_def)
  fix x y
  assume x:"x \<in> carrier G" and y:"y \<in> carrier G" and "h \<otimes> x = h \<otimes> y"
  with h show "x = y" by (metis l_cancel)
next
  fix x
  assume x:"x \<in> carrier G"
  with h show "h \<otimes> x \<in> carrier G" by (metis m_closed)
  from x h have "inv h \<otimes> x \<in> carrier G" by (metis m_closed inv_closed)
  moreover from x h have "h \<otimes> (inv h \<otimes> x)  = x" by (metis inv_closed r_inv m_assoc l_one)
  ultimately show "x \<in> op \<otimes> h ` carrier G" by force
qed

lemma (in group) right_mult_group_action:
  shows "group_action G (\<lambda>h. \<lambda>g \<in> carrier G. h \<otimes> g) (carrier G)"
unfolding group_action_def group_action_axioms_def group_hom_def group_hom_axioms_def hom_def
proof(auto simp add:is_group group_BijGroup)
  fix h
  assume "h \<in> carrier G"
  thus "(\<lambda>g \<in> carrier G. h \<otimes> g) \<in> carrier (BijGroup (carrier G))" unfolding BijGroup_def by (auto simp:right_mult_is_bij)
next
  fix x y
  assume x:"x \<in> carrier G" and y:"y \<in> carrier G"
  def multx \<equiv> "(\<lambda>g\<in>carrier G. x \<otimes> g)" and  multy \<equiv> "(\<lambda>g\<in>carrier G. y \<otimes> g)"
  with x y have "multx \<in> (Bij (carrier G))" "multy \<in> (Bij (carrier G))" by (metis right_mult_is_bij)+
  hence "multx \<otimes>\<^bsub>BijGroup (carrier G)\<^esub> multy = (\<lambda>g\<in>carrier G. multx (multy g))" unfolding BijGroup_def by (auto simp: compose_def)
  also have "... = (\<lambda>g\<in>carrier G. (x \<otimes> y) \<otimes> g)" unfolding multx_def multy_def
  proof(rule restrict_ext)
    fix g
    assume g:"g \<in> carrier G"
    with x y have "x \<otimes> y \<in> carrier G" "y \<otimes> g \<in> carrier G" by simp+
    with x y g show "(\<lambda>g\<in>carrier G. x \<otimes> g) ((\<lambda>g\<in>carrier G. y \<otimes> g) g) = x \<otimes> y \<otimes> g" by (auto simp:m_assoc)
  qed
  finally show "(\<lambda>g\<in>carrier G. (x \<otimes> y) \<otimes> g) = (\<lambda>g\<in>carrier G. x \<otimes> g) \<otimes>\<^bsub>BijGroup (carrier G)\<^esub> (\<lambda>g\<in>carrier G. y \<otimes> g)" unfolding multx_def multy_def by simp
qed

lemma (in group) rcosets_closed:
  assumes HG:"subgroup H G"
  assumes g:"g \<in> carrier G"
  assumes M:"M \<in> rcosets H"
  shows "M #> g \<in> rcosets H"
proof -
  from M obtain h where h:"h \<in> carrier G" "M = H #> h" unfolding RCOSETS_def by auto
  with g HG have "M #> g = H #> (h \<otimes> g)" by (metis coset_mult_assoc subgroup_imp_subset)
  with HG g h show "M #> g \<in> rcosets H" by (metis rcosetsI subgroup.m_closed subgroup_imp_subset subgroup_self)
qed

lemma (in group) inv_mult_on_rcosets_is_bij:
  assumes HG:"subgroup H G"
  assumes g:"g \<in> carrier G"
  shows "(\<lambda>U \<in> rcosets H. U #> inv g) \<in> Bij (rcosets H)"
proof(auto simp add:Bij_def bij_betw_def inj_on_def)
  fix M
  assume "M \<in> rcosets H"
  with HG g show "M #> inv g \<in> rcosets H" by (metis inv_closed rcosets_closed)
next
  fix M
  assume M:"M \<in> rcosets H"
  with HG g have "M #> g \<in> rcosets H" by (rule rcosets_closed)
  moreover from M HG g have "M #> g #> inv g = M" by (metis coset_mult_assoc coset_mult_inv2 inv_closed is_group subgroup.rcosets_carrier)
  ultimately show " M \<in> (\<lambda>U. U #> inv g) ` (rcosets H)" by auto
next
  fix M N x
  assume M:"M \<in> rcosets H" and N:"N \<in> rcosets H" and "M #> inv g = N #> inv g"
  hence "(M #> inv g) #> g = (N #> inv g) #> g" by simp
  with HG M N g have "M #> (inv g \<otimes> g) = N #> (inv g \<otimes> g)" by (metis coset_mult_assoc is_group subgroup.m_inv_closed subgroup.rcosets_carrier subgroup_self)
  with HG M N g have a1:"M = N" by (metis l_inv coset_mult_one is_group subgroup.rcosets_carrier)
  {
    assume "x \<in> M"
    with a1 show "x \<in> N" by simp
  }
  {
    assume "x \<in> N"
    with a1 show "x \<in> M" by simp
  }
qed

lemma (in group) inv_mult_on_rcosets_action:
  assumes HG:"subgroup H G"
  shows "group_action G (\<lambda>g. \<lambda>U \<in> rcosets H. U #> inv g) (rcosets H)"
unfolding group_action_def group_action_axioms_def group_hom_def group_hom_axioms_def hom_def
proof(auto simp add:is_group group_BijGroup)
  fix h
  assume "h \<in> carrier G"
  with HG show "(\<lambda>U \<in> rcosets H. U #> inv h) \<in> carrier (BijGroup (rcosets H))" unfolding BijGroup_def by (auto simp:inv_mult_on_rcosets_is_bij)
next
  fix x y
  assume x:"x \<in> carrier G" and y:"y \<in> carrier G"
  def cosx \<equiv> "(\<lambda>U\<in>rcosets H. U #> inv x)" and  cosy \<equiv> "(\<lambda>U\<in>rcosets H. U #> inv y)"
  with x y HG have "cosx \<in> (Bij (rcosets H))" "cosy \<in> (Bij (rcosets H))" by (metis inv_mult_on_rcosets_is_bij)+
  hence "cosx \<otimes>\<^bsub>BijGroup (rcosets H)\<^esub> cosy = (\<lambda>U\<in>rcosets H. cosx (cosy U))" unfolding BijGroup_def by (auto simp: compose_def)
  also have "... = (\<lambda>U\<in>rcosets H. U #> inv (x \<otimes> y))" unfolding cosx_def cosy_def
  proof(rule restrict_ext)
    fix U
    assume U:"U \<in> rcosets H"
    with HG y have "U #> inv y \<in> rcosets H" by (metis inv_closed rcosets_closed)
    with x y HG U have "(\<lambda>U\<in>rcosets H. U #> inv x) ((\<lambda>U\<in>rcosets H. U #> inv y) U) = U #> inv y #> inv x" by auto
    also from x y U HG have "... = U #> inv (x \<otimes> y)" by (metis inv_mult_group coset_mult_assoc inv_closed is_group subgroup.rcosets_carrier)
    finally show "(\<lambda>U\<in>rcosets H. U #> inv x) ((\<lambda>U\<in>rcosets H. U #> inv y) U) = U #> inv (x \<otimes> y)".
  qed
  finally show "(\<lambda>U\<in>rcosets H. U #> inv (x \<otimes> y)) = (\<lambda>U\<in>rcosets H. U #> inv x) \<otimes>\<^bsub>BijGroup (rcosets H)\<^esub> (\<lambda>U\<in>rcosets H. U #> inv y)" unfolding cosx_def cosy_def by simp
qed

end


header{* Designs *}

theory Designs
imports Relations
begin

text {* In UTP, in order to explicitly record the termination of a program,
a subset of alphabetized relations is introduced. These relations are called
designs and their alphabet should contain the special boolean observational variable ok.
It is used to record the start and termination of a program. *}

subsection{* Definitions *}

text {* In the following, the definitions of designs alphabets, designs and
healthiness (well-formedness) conditions are given. The healthiness conditions of
designs are defined by $H1$, $H2$, $H3$ and $H4$.*}

record alpha_d = ok::bool

type_synonym '\<alpha> alphabet_d  = "'\<alpha> alpha_d_scheme alphabet"
type_synonym '\<alpha> relation_d = "'\<alpha> alphabet_d relation"

definition design::"'\<alpha> relation_d \<Rightarrow> '\<alpha> relation_d \<Rightarrow> '\<alpha> relation_d" ("'(_ \<turnstile> _')")
where " (P \<turnstile> Q) \<equiv> \<lambda> (A, A') .  (ok A \<and> P (A,A')) \<longrightarrow> (ok A' \<and> Q (A,A'))"

definition skip_d :: "'\<alpha> relation_d" ("\<Pi>d")
where "\<Pi>d \<equiv> (true \<turnstile> \<Pi>r)"

definition J
where "J  \<equiv>  \<lambda> (A, A') . (ok A  \<longrightarrow>  ok A') \<and> more A = more A'"

type_synonym '\<alpha> Healthiness_condition = "'\<alpha> relation \<Rightarrow> '\<alpha> relation"

definition
Healthy::"'\<alpha> relation \<Rightarrow> '\<alpha> Healthiness_condition \<Rightarrow> bool" ("_ is _ healthy")
where "P is H healthy \<equiv> (P = H P)"

lemma Healthy_def': "P is H healthy = (H P = P)"
  unfolding Healthy_def by auto

definition H1::"('\<alpha> alphabet_d) Healthiness_condition"
where "H1 (P)  \<equiv>  (ok o fst  \<longrightarrow> P)"

definition H2::"('\<alpha> alphabet_d) Healthiness_condition"
where "H2 (P)  \<equiv>  P ;; J"

definition H3::"('\<alpha> alphabet_d) Healthiness_condition"
where "H3 (P)  \<equiv>  P ;; \<Pi>d"

definition H4::"('\<alpha> alphabet_d) Healthiness_condition"
where "H4 (P)  \<equiv>  ((P;;true) \<longleftrightarrow> true)"

definition \<sigma>f::"'\<alpha> relation_d \<Rightarrow> '\<alpha> relation_d"
where "\<sigma>f D \<equiv> \<lambda> (A, A') . D (A, A'\<lparr>ok:=False\<rparr>)"

definition \<sigma>t::"'\<alpha> relation_d \<Rightarrow> '\<alpha> relation_d"
where "\<sigma>t D \<equiv> \<lambda> (A, A') . D (A, A'\<lparr>ok:=True\<rparr>)"

definition OKAY::"'\<alpha> relation_d"
where "OKAY \<equiv> \<lambda> (A, A') . ok A"

definition OKAY'::"'\<alpha> relation_d"
where "OKAY' \<equiv> \<lambda> (A, A') . ok A'"

lemmas design_defs = design_def skip_d_def J_def Healthy_def H1_def H2_def H3_def
                     H4_def \<sigma>f_def \<sigma>t_def OKAY_def OKAY'_def

subsection{* Proofs *}

text {* Proof of theorems and properties of designs and their healthiness conditions
are given in the following.*}

lemma t_comp_lz_d: "(true;;(P \<turnstile> Q)) = true"
  apply (auto simp: fun_eq_iff design_defs)
  apply (rule_tac b="b\<lparr>ok:=False\<rparr>" in comp_intro, auto)
done

lemma pi_comp_left_unit: "(\<Pi>d;;(P \<turnstile> Q)) = (P \<turnstile> Q)"
by (auto simp: fun_eq_iff design_defs)

theorem t3_1_4_2:
"((P1 \<turnstile> Q1) \<triangleleft> b \<triangleright> (P2 \<turnstile> Q2)) = ((P1 \<triangleleft> b \<triangleright> P2) \<turnstile> (Q1 \<triangleleft> b \<triangleright> Q2))"
by (auto simp: fun_eq_iff design_defs split: cond_splits)

lemma conv_conj_distr: "\<sigma>t (P \<and> Q) = (\<sigma>t P \<and> \<sigma>t Q)"
by (auto simp: design_defs fun_eq_iff)

lemma conv_disj_distr: "\<sigma>t (P \<or> Q) = (\<sigma>t P \<or> \<sigma>t Q)"
by (auto simp: design_defs fun_eq_iff)

lemma conv_imp_distr: "\<sigma>t (P \<longrightarrow> Q) = ((\<sigma>t P) \<longrightarrow> \<sigma>t Q)"
by (auto simp: design_defs fun_eq_iff)

lemma conv_not_distr: "\<sigma>t (\<not> P) = (\<not>(\<sigma>t P))"
by (auto simp: design_defs fun_eq_iff)

lemma div_conj_distr: "\<sigma>f (P \<and> Q) = (\<sigma>f P \<and> \<sigma>f Q)"
by (auto simp: design_defs fun_eq_iff)

lemma div_disj_distr: "\<sigma>f (P \<or> Q) = (\<sigma>f P \<or> \<sigma>f Q)"
by (auto simp: design_defs fun_eq_iff)

lemma div_imp_distr: "\<sigma>f (P \<longrightarrow> Q) = ((\<sigma>f P) \<longrightarrow> \<sigma>f Q)"
by (auto simp: design_defs fun_eq_iff)

lemma div_not_distr: "\<sigma>f (\<not> P) = (\<not>(\<sigma>f P))"
by (auto simp: design_defs fun_eq_iff)

lemma ok_conv: "\<sigma>t OKAY = OKAY"
by (auto simp: design_defs fun_eq_iff)

lemma ok_div: "\<sigma>f OKAY = OKAY"
by (auto simp: design_defs fun_eq_iff)

lemma ok'_conv: "\<sigma>t OKAY' = true"
by (auto simp: design_defs fun_eq_iff)

lemma ok'_div: "\<sigma>f OKAY' = false"
by (auto simp: design_defs fun_eq_iff)

lemma H2_J_1:
 assumes A: "P is H2 healthy"
 shows "[(\<lambda> (A, A'). (P(A, A'\<lparr>ok := False\<rparr>) \<longrightarrow> P(A, A'\<lparr>ok := True\<rparr>)))]"
using A by (auto simp: design_defs fun_eq_iff)

lemma H2_J_2_a : "P (a,b) \<longrightarrow> (P ;; J) (a,b)"
  unfolding J_def by auto

lemma ok_or_not_ok : "\<lbrakk>P(a, b\<lparr>ok := True\<rparr>); P(a, b\<lparr>ok := False\<rparr>)\<rbrakk> \<Longrightarrow> P(a, b)"
  apply (case_tac "ok b")
  apply (subgoal_tac "b\<lparr>ok:=True\<rparr> = b")
  apply (simp_all)
  apply (subgoal_tac "b\<lparr>ok:=False\<rparr> = b")
  apply (simp_all)
done

lemma H2_J_2_b :
  assumes A: "[(\<lambda> (A, A'). (P(A, A'\<lparr>ok := False\<rparr>) \<longrightarrow> P(A, A'\<lparr>ok := True\<rparr>)))]"
  and B : "(P ;; J) (a,b)"
  shows "P (a,b)"
  using B
  apply (auto simp: design_defs fun_eq_iff)
  apply (case_tac "ok b")
  apply (subgoal_tac "b = ba\<lparr>ok:=True\<rparr>", auto intro!: A[simplified, rule_format])
  apply (rule_tac s=ba and t="ba\<lparr>ok:=False\<rparr>" in subst, simp_all)
  apply (subgoal_tac "b = ba", simp_all)
  apply (case_tac "ok ba")
  apply (subgoal_tac "b = ba", simp_all)
  apply (subgoal_tac "b = ba\<lparr>ok:=True\<rparr>", auto intro!: A[simplified, rule_format])
  apply (rule_tac s=ba and t="ba\<lparr>ok:=False\<rparr>" in subst, simp_all)
done

lemma H2_J_2 :
  assumes A: "[(\<lambda> (A, A'). (P(A, A'\<lparr>ok := False\<rparr>) \<longrightarrow> P(A, A'\<lparr>ok := True\<rparr>)))]"
  shows "P is H2 healthy "
  apply (auto simp add: H2_def Healthy_def fun_eq_iff)
  apply (simp add: H2_J_2_a)
  apply (rule H2_J_2_b [OF A])
  apply auto
  done

lemma H2_J:
"[\<lambda> (A, A'). P(A, A'\<lparr>ok := False\<rparr>) \<longrightarrow> P(A, A'\<lparr>ok := True\<rparr>)] = P is H2 healthy"
using H2_J_1 H2_J_2 by blast

lemma design_eq1: "(P \<turnstile> Q) = (P \<turnstile> P \<and> Q)"
by (rule ext) (auto simp: design_defs)

lemma H1_idem: "H1 o H1 = H1"
by (auto simp: design_defs fun_eq_iff)

lemma H1_idem2: "(H1 (H1 P)) = (H1 P)"
by (simp add: H1_idem[simplified fun_eq_iff Fun.comp_def, rule_format] fun_eq_iff)

lemma H2_idem: "H2 o H2 = H2"
by (auto simp: design_defs fun_eq_iff)

lemma H2_idem2: "(H2 (H2 P)) = (H2 P)"
by (simp add: H2_idem[simplified fun_eq_iff Fun.comp_def, rule_format] fun_eq_iff)

lemma H1_H2_commute: "H1 o H2 = H2 o H1"
by (auto simp: design_defs fun_eq_iff split: cond_splits)

lemma H1_H2_commute2: "H1 (H2 P) = H2 (H1 P)"
by (simp add: H1_H2_commute[simplified fun_eq_iff Fun.comp_def, rule_format] fun_eq_iff)

lemma alpha_d_eqD: "r = r' \<Longrightarrow> ok r = ok r' \<and> alpha_d.more r = alpha_d.more r'"
by (auto simp: alpha_d.equality)

lemma design_H1: "(P \<turnstile> Q) is H1 healthy"
by (auto simp: design_defs fun_eq_iff)

lemma design_H2:
"(\<forall> a b. P (a, b\<lparr>ok := True\<rparr>) \<longrightarrow> P (a, b\<lparr>ok := False\<rparr>)) \<Longrightarrow> (P \<turnstile> Q) is H2 healthy"
by (rule H2_J_2) (auto simp: design_defs fun_eq_iff)

end


(*  Author:     Tobias Nipkow, 2007  *)

section\<open>Logic\<close>

theory Logic
imports Main "HOL-Library.FuncSet"
begin

text\<open>\noindent
We start with a generic formalization of quantified logical formulae
using de Bruijn notation. The syntax is parametric in the type of atoms.\<close>

declare Let_def[simp]

datatype (atoms: 'a) fm =
  TrueF | FalseF | Atom 'a | And "'a fm" "'a fm" | Or "'a fm" "'a fm" |
  Neg "'a fm" | ExQ "'a fm"

notation map_fm ("map\<^sub>f\<^sub>m")

abbreviation Imp where "Imp \<phi>\<^sub>1 \<phi>\<^sub>2 \<equiv> Or (Neg \<phi>\<^sub>1) \<phi>\<^sub>2"
abbreviation AllQ where "AllQ \<phi> \<equiv> Neg(ExQ(Neg \<phi>))"

definition neg where
"neg \<phi> = (if \<phi>=TrueF then FalseF else if \<phi>=FalseF then TrueF else Neg \<phi>)"

definition "and" :: "'a fm \<Rightarrow> 'a fm \<Rightarrow> 'a fm" where
"and \<phi>\<^sub>1 \<phi>\<^sub>2 =
 (if \<phi>\<^sub>1=TrueF then \<phi>\<^sub>2 else if \<phi>\<^sub>2=TrueF then \<phi>\<^sub>1 else
  if \<phi>\<^sub>1=FalseF \<or> \<phi>\<^sub>2=FalseF then FalseF else And \<phi>\<^sub>1 \<phi>\<^sub>2)"

definition or :: "'a fm \<Rightarrow> 'a fm \<Rightarrow> 'a fm" where
"or \<phi>\<^sub>1 \<phi>\<^sub>2 =
 (if \<phi>\<^sub>1=FalseF then \<phi>\<^sub>2 else if \<phi>\<^sub>2=FalseF then \<phi>\<^sub>1 else
  if \<phi>\<^sub>1=TrueF \<or> \<phi>\<^sub>2=TrueF then TrueF else Or \<phi>\<^sub>1 \<phi>\<^sub>2)"

definition list_conj :: "'a fm list \<Rightarrow> 'a fm" where
"list_conj fs = foldr and fs TrueF"

definition list_disj :: "'a fm list \<Rightarrow> 'a fm" where
"list_disj fs = foldr or fs FalseF"

abbreviation "Disj is f \<equiv> list_disj (map f is)"

lemmas atoms_map_fm[simp] = fm.set_map

fun amap_fm :: "('a \<Rightarrow> 'b fm) \<Rightarrow> 'a fm \<Rightarrow> 'b fm" ("amap\<^sub>f\<^sub>m") where
"amap\<^sub>f\<^sub>m h TrueF = TrueF" |
"amap\<^sub>f\<^sub>m h FalseF = FalseF" |
"amap\<^sub>f\<^sub>m h (Atom a) = h a" |
"amap\<^sub>f\<^sub>m h (And \<phi>\<^sub>1 \<phi>\<^sub>2) = and (amap\<^sub>f\<^sub>m h \<phi>\<^sub>1) (amap\<^sub>f\<^sub>m h \<phi>\<^sub>2)" |
"amap\<^sub>f\<^sub>m h (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = or (amap\<^sub>f\<^sub>m h \<phi>\<^sub>1) (amap\<^sub>f\<^sub>m h \<phi>\<^sub>2)" |
"amap\<^sub>f\<^sub>m h (Neg \<phi>) = neg (amap\<^sub>f\<^sub>m h \<phi>)"

lemma amap_fm_list_disj:
  "amap\<^sub>f\<^sub>m h (list_disj fs) = list_disj (map (amap\<^sub>f\<^sub>m h) fs)"
by(induct fs) (auto simp:list_disj_def or_def)

fun qfree :: "'a fm \<Rightarrow> bool" where
"qfree(ExQ f) = False" |
"qfree(And \<phi>\<^sub>1 \<phi>\<^sub>2) = (qfree \<phi>\<^sub>1 \<and> qfree \<phi>\<^sub>2)" |
"qfree(Or \<phi>\<^sub>1 \<phi>\<^sub>2) = (qfree \<phi>\<^sub>1 \<and> qfree \<phi>\<^sub>2)" |
"qfree(Neg \<phi>) = (qfree \<phi>)" |
"qfree \<phi> = True"

lemma qfree_and[simp]: "\<lbrakk> qfree \<phi>\<^sub>1; qfree \<phi>\<^sub>2 \<rbrakk> \<Longrightarrow> qfree(and \<phi>\<^sub>1 \<phi>\<^sub>2)"
by(simp add:and_def)

lemma qfree_or[simp]: "\<lbrakk> qfree \<phi>\<^sub>1; qfree \<phi>\<^sub>2 \<rbrakk> \<Longrightarrow> qfree(or \<phi>\<^sub>1 \<phi>\<^sub>2)"
by(simp add:or_def)

lemma qfree_neg[simp]: "qfree(neg \<phi>) = qfree \<phi>"
by(simp add:neg_def)

lemma qfree_foldr_Or[simp]:
 "qfree(foldr Or fs \<phi>) = (qfree \<phi> \<and> (\<forall>\<phi> \<in> set fs. qfree \<phi>))"
by (induct fs) auto

lemma qfree_list_conj[simp]:
assumes "\<forall>\<phi> \<in> set fs. qfree \<phi>" shows "qfree(list_conj fs)"
proof -
  { fix fs \<phi>
    have "\<lbrakk> \<forall>\<phi> \<in> set fs. qfree \<phi>; qfree \<phi> \<rbrakk> \<Longrightarrow> qfree(foldr and fs \<phi>)"
      by (induct fs) auto
  } thus ?thesis using assms by (fastforce simp add:list_conj_def)
qed

lemma qfree_list_disj[simp]:
assumes "\<forall>\<phi> \<in> set fs. qfree \<phi>" shows "qfree(list_disj fs)"
proof -
  { fix fs \<phi>
    have "\<lbrakk> \<forall>\<phi> \<in> set fs. qfree \<phi>; qfree \<phi> \<rbrakk> \<Longrightarrow> qfree(foldr or fs \<phi>)"
      by (induct fs) auto
  } thus ?thesis using assms by (fastforce simp add:list_disj_def)
qed

lemma qfree_map_fm: "qfree (map\<^sub>f\<^sub>m f \<phi>) = qfree \<phi>"
by (induct \<phi>) simp_all

lemma atoms_list_disjE:
  "a \<in> atoms(list_disj fs) \<Longrightarrow> a \<in> (\<Union>\<phi> \<in> set fs. atoms \<phi>)"
apply(induct fs)
 apply (simp add:list_disj_def)
apply (auto simp add:list_disj_def Logic.or_def split:if_split_asm)
done

lemma atoms_list_conjE:
  "a \<in> atoms(list_conj fs) \<Longrightarrow> a \<in> (\<Union>\<phi> \<in> set fs. atoms \<phi>)"
apply(induct fs)
 apply (simp add:list_conj_def)
apply (auto simp add:list_conj_def Logic.and_def split:if_split_asm)
done

fun dnf :: "'a fm \<Rightarrow> 'a list list" where
"dnf TrueF = [[]]" |
"dnf FalseF = []" |
"dnf (Atom \<phi>) = [[\<phi>]]" |
"dnf (And \<phi>\<^sub>1 \<phi>\<^sub>2) = [d1 @ d2. d1 \<leftarrow> dnf \<phi>\<^sub>1, d2 \<leftarrow> dnf \<phi>\<^sub>2]" |
"dnf (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = dnf \<phi>\<^sub>1 @ dnf \<phi>\<^sub>2"

fun nqfree :: "'a fm \<Rightarrow> bool" where
"nqfree(Atom a) = True" |
"nqfree TrueF = True" |
"nqfree FalseF = True" |
"nqfree (And \<phi>\<^sub>1 \<phi>\<^sub>2) = (nqfree \<phi>\<^sub>1 \<and> nqfree \<phi>\<^sub>2)" |
"nqfree (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = (nqfree \<phi>\<^sub>1 \<and> nqfree \<phi>\<^sub>2)" |
"nqfree \<phi> = False"

lemma nqfree_qfree[simp]: "nqfree \<phi> \<Longrightarrow> qfree \<phi>"
by (induct \<phi>) simp_all

lemma nqfree_map_fm: "nqfree (map\<^sub>f\<^sub>m f \<phi>) = nqfree \<phi>"
by (induct \<phi>) simp_all

fun "interpret" :: "('a \<Rightarrow> 'b list \<Rightarrow> bool) \<Rightarrow> 'a fm \<Rightarrow> 'b list \<Rightarrow> bool" where
"interpret h TrueF xs = True" |
"interpret h FalseF xs = False" |
"interpret h (Atom a) xs = h a xs" |
"interpret h (And \<phi>\<^sub>1 \<phi>\<^sub>2) xs = (interpret h \<phi>\<^sub>1 xs \<and> interpret h \<phi>\<^sub>2 xs)" |
"interpret h (Or \<phi>\<^sub>1 \<phi>\<^sub>2) xs = (interpret h \<phi>\<^sub>1 xs \<or> interpret h \<phi>\<^sub>2 xs)" |
"interpret h (Neg \<phi>) xs = (\<not> interpret h \<phi> xs)" |
"interpret h (ExQ \<phi>) xs = (\<exists>x. interpret h \<phi> (x#xs))"

subsection\<open>Atoms\<close>

text\<open>The locale ATOM of atoms provides a minimal framework for the
generic formulation of theory-independent algorithms, in particular
quantifier elimination.\<close>

locale ATOM =
fixes aneg :: "'a \<Rightarrow> 'a fm"
fixes anormal :: "'a \<Rightarrow> bool"
assumes nqfree_aneg: "nqfree(aneg a)"
assumes anormal_aneg: "anormal a \<Longrightarrow> \<forall>b\<in>atoms(aneg a). anormal b"

fixes I\<^sub>a :: "'a \<Rightarrow> 'b list \<Rightarrow> bool"
assumes I\<^sub>a_aneg: "interpret I\<^sub>a (aneg a) xs = (\<not> I\<^sub>a a xs)"

fixes depends\<^sub>0 :: "'a \<Rightarrow> bool"
and decr :: "'a \<Rightarrow> 'a"
assumes not_dep_decr: "\<not>depends\<^sub>0 a \<Longrightarrow> I\<^sub>a a (x#xs) = I\<^sub>a (decr a) xs"
assumes anormal_decr: "\<not> depends\<^sub>0 a \<Longrightarrow> anormal a \<Longrightarrow> anormal(decr a)"

begin

fun atoms\<^sub>0 :: "'a fm \<Rightarrow> 'a list" where
"atoms\<^sub>0 TrueF = []" |
"atoms\<^sub>0 FalseF = []" |
"atoms\<^sub>0 (Atom a) = (if depends\<^sub>0 a then [a] else [])" |
"atoms\<^sub>0 (And \<phi>\<^sub>1 \<phi>\<^sub>2) = atoms\<^sub>0 \<phi>\<^sub>1 @ atoms\<^sub>0 \<phi>\<^sub>2" |
"atoms\<^sub>0 (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = atoms\<^sub>0 \<phi>\<^sub>1 @ atoms\<^sub>0 \<phi>\<^sub>2" |
"atoms\<^sub>0 (Neg \<phi>) = atoms\<^sub>0 \<phi>"

abbreviation I where "I \<equiv> interpret I\<^sub>a"

fun nnf :: "'a fm \<Rightarrow> 'a fm" where
"nnf (And \<phi>\<^sub>1 \<phi>\<^sub>2) = And (nnf \<phi>\<^sub>1) (nnf \<phi>\<^sub>2)" |
"nnf (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = Or (nnf \<phi>\<^sub>1) (nnf \<phi>\<^sub>2)" |
"nnf (Neg TrueF) = FalseF" |
"nnf (Neg FalseF) = TrueF" |
"nnf (Neg (Neg \<phi>)) = (nnf \<phi>)" |
"nnf (Neg (And \<phi>\<^sub>1 \<phi>\<^sub>2)) = (Or (nnf (Neg \<phi>\<^sub>1)) (nnf (Neg \<phi>\<^sub>2)))" |
"nnf (Neg (Or \<phi>\<^sub>1 \<phi>\<^sub>2)) = (And (nnf (Neg \<phi>\<^sub>1)) (nnf (Neg \<phi>\<^sub>2)))" |
"nnf (Neg (Atom a)) = aneg a" |
"nnf \<phi> = \<phi>"

lemma nqfree_nnf: "qfree \<phi> \<Longrightarrow> nqfree(nnf \<phi>)"
by(induct \<phi> rule:nnf.induct)
  (simp_all add: nqfree_aneg and_def or_def)

lemma qfree_nnf[simp]: "qfree(nnf \<phi>) = qfree \<phi>"
by (induct \<phi> rule:nnf.induct)(simp_all add: nqfree_aneg)

lemma I_neg[simp]: "I (neg \<phi>) xs = I (Neg \<phi>) xs"
by(simp add:neg_def)

lemma I_and[simp]: "I (and \<phi>\<^sub>1 \<phi>\<^sub>2) xs = I (And \<phi>\<^sub>1 \<phi>\<^sub>2) xs"
by(simp add:and_def)

lemma I_list_conj[simp]:
 "I (list_conj fs) xs = (\<forall>\<phi> \<in> set fs. I \<phi> xs)"
proof -
  { fix fs \<phi>
    have "I (foldr and fs \<phi>) xs = (I \<phi> xs \<and> (\<forall>\<phi> \<in> set fs. I \<phi> xs))"
      by (induct fs) auto
  } thus ?thesis by(simp add:list_conj_def)
qed

lemma I_or[simp]: "I (or \<phi>\<^sub>1 \<phi>\<^sub>2) xs = I (Or \<phi>\<^sub>1 \<phi>\<^sub>2) xs"
by(simp add:or_def)

lemma I_list_disj[simp]:
 "I (list_disj fs) xs = (\<exists>\<phi> \<in> set fs. I \<phi> xs)"
proof -
  { fix fs \<phi>
    have "I (foldr or fs \<phi>) xs = (I \<phi> xs \<or> (\<exists>\<phi> \<in> set fs. I \<phi> xs))"
      by (induct fs) auto
  } thus ?thesis by(simp add:list_disj_def)
qed

lemma I_nnf: "I (nnf \<phi>) xs = I \<phi> xs"
by(induct rule:nnf.induct)(simp_all add: I\<^sub>a_aneg)

lemma I_dnf:
"nqfree \<phi> \<Longrightarrow> (\<exists>as\<in>set (dnf \<phi>). \<forall>a\<in>set as. I\<^sub>a a xs) = I \<phi> xs"
by (induct \<phi>) (fastforce)+

definition "normal \<phi> = (\<forall>a \<in> atoms \<phi>. anormal a)"

lemma normal_simps[simp]:
"normal TrueF"
"normal FalseF"
"normal (Atom a) \<longleftrightarrow> anormal a"
"normal (And \<phi>\<^sub>1 \<phi>\<^sub>2) \<longleftrightarrow> normal \<phi>\<^sub>1 \<and> normal \<phi>\<^sub>2"
"normal (Or \<phi>\<^sub>1 \<phi>\<^sub>2) \<longleftrightarrow> normal \<phi>\<^sub>1 \<and> normal \<phi>\<^sub>2"
"normal (Neg \<phi>) \<longleftrightarrow> normal \<phi>"
"normal (ExQ \<phi>) \<longleftrightarrow> normal \<phi>"
by(auto simp:normal_def)

lemma normal_aneg[simp]: "anormal a \<Longrightarrow> normal (aneg a)"
by (simp add:anormal_aneg normal_def)

lemma normal_and[simp]:
  "normal \<phi>\<^sub>1 \<Longrightarrow> normal \<phi>\<^sub>2 \<Longrightarrow> normal (and \<phi>\<^sub>1 \<phi>\<^sub>2)"
by (simp add:Logic.and_def)

lemma normal_or[simp]:
  "normal \<phi>\<^sub>1 \<Longrightarrow> normal \<phi>\<^sub>2 \<Longrightarrow> normal (or \<phi>\<^sub>1 \<phi>\<^sub>2)"
by (simp add:Logic.or_def)

lemma normal_list_disj[simp]:
  "\<forall>\<phi>\<in>set fs. normal \<phi> \<Longrightarrow> normal (list_disj fs)"
apply(induct fs)
 apply (simp add:list_disj_def)
apply (simp add:list_disj_def)
done

lemma normal_nnf: "normal \<phi> \<Longrightarrow> normal(nnf \<phi>)"
by(induct \<phi> rule:nnf.induct) simp_all

lemma normal_map_fm:
  "\<forall>a. anormal(f a) = anormal(a) \<Longrightarrow> normal (map\<^sub>f\<^sub>m f \<phi>) = normal \<phi>"
by(induct \<phi>) auto

lemma anormal_nnf:
  "qfree \<phi> \<Longrightarrow> normal \<phi> \<Longrightarrow> \<forall>a\<in>atoms(nnf \<phi>). anormal a"
apply(induct \<phi> rule:nnf.induct)
apply(unfold normal_def)
apply(simp_all)
apply (blast dest:anormal_aneg)+
done

lemma atoms_dnf: "nqfree \<phi> \<Longrightarrow> as \<in> set(dnf \<phi>) \<Longrightarrow> a \<in> set as \<Longrightarrow> a \<in> atoms \<phi>"
by(induct \<phi> arbitrary: as a rule:nqfree.induct)(auto)

lemma anormal_dnf_nnf:
  "as \<in> set(dnf(nnf \<phi>)) \<Longrightarrow> qfree \<phi> \<Longrightarrow> normal \<phi> \<Longrightarrow> a \<in> set as \<Longrightarrow> anormal a"
apply(induct \<phi> arbitrary: a as rule:nnf.induct)
            apply(simp_all add: normal_def)
    apply clarify
    apply (metis UnE set_append)
   apply metis
  apply metis
 apply fastforce
apply (metis anormal_aneg atoms_dnf nqfree_aneg)
done

end

end


(*  Title:      ZF/Sum.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge
*)

section\<open>Disjoint Sums\<close>

theory Sum imports Bool equalities begin

text\<open>And the "Part" primitive for simultaneous recursive type definitions\<close>

definition sum :: "[i,i]\<Rightarrow>i" (infixr \<open>+\<close> 65) where
     "A+B \<equiv> {0}*A \<union> {1}*B"

definition Inl :: "i\<Rightarrow>i" where
     "Inl(a) \<equiv> \<langle>0,a\<rangle>"

definition Inr :: "i\<Rightarrow>i" where
     "Inr(b) \<equiv> \<langle>1,b\<rangle>"

definition "case" :: "[i\<Rightarrow>i, i\<Rightarrow>i, i]\<Rightarrow>i" where
     "case(c,d) \<equiv> (\<lambda>\<langle>y,z\<rangle>. cond(y, d(z), c(z)))"

  (*operator for selecting out the various summands*)
definition Part :: "[i,i\<Rightarrow>i] \<Rightarrow> i" where
     "Part(A,h) \<equiv> {x \<in> A. \<exists>z. x = h(z)}"

subsection\<open>Rules for the \<^term>\<open>Part\<close> Primitive\<close>

lemma Part_iff:
    "a \<in> Part(A,h) \<longleftrightarrow> a \<in> A \<and> (\<exists>y. a=h(y))"
  unfolding Part_def
apply (rule separation)
done

lemma Part_eqI [intro]:
    "\<lbrakk>a \<in> A;  a=h(b)\<rbrakk> \<Longrightarrow> a \<in> Part(A,h)"
by (unfold Part_def, blast)

lemmas PartI = refl [THEN [2] Part_eqI]

lemma PartE [elim!]:
    "\<lbrakk>a \<in> Part(A,h);  \<And>z. \<lbrakk>a \<in> A;  a=h(z)\<rbrakk> \<Longrightarrow> P
\<rbrakk> \<Longrightarrow> P"
apply (unfold Part_def, blast)
done

lemma Part_subset: "Part(A,h) \<subseteq> A"
  unfolding Part_def
apply (rule Collect_subset)
done

subsection\<open>Rules for Disjoint Sums\<close>

lemmas sum_defs = sum_def Inl_def Inr_def case_def

lemma Sigma_bool: "Sigma(bool,C) = C(0) + C(1)"
by (unfold bool_def sum_def, blast)

(** Introduction rules for the injections **)

lemma InlI [intro!,simp,TC]: "a \<in> A \<Longrightarrow> Inl(a) \<in> A+B"
by (unfold sum_defs, blast)

lemma InrI [intro!,simp,TC]: "b \<in> B \<Longrightarrow> Inr(b) \<in> A+B"
by (unfold sum_defs, blast)

(** Elimination rules **)

lemma sumE [elim!]:
    "\<lbrakk>u \<in> A+B;
        \<And>x. \<lbrakk>x \<in> A;  u=Inl(x)\<rbrakk> \<Longrightarrow> P;
        \<And>y. \<lbrakk>y \<in> B;  u=Inr(y)\<rbrakk> \<Longrightarrow> P
\<rbrakk> \<Longrightarrow> P"
by (unfold sum_defs, blast)

(** Injection and freeness equivalences, for rewriting **)

lemma Inl_iff [iff]: "Inl(a)=Inl(b) \<longleftrightarrow> a=b"
by (simp add: sum_defs)

lemma Inr_iff [iff]: "Inr(a)=Inr(b) \<longleftrightarrow> a=b"
by (simp add: sum_defs)

lemma Inl_Inr_iff [simp]: "Inl(a)=Inr(b) \<longleftrightarrow> False"
by (simp add: sum_defs)

lemma Inr_Inl_iff [simp]: "Inr(b)=Inl(a) \<longleftrightarrow> False"
by (simp add: sum_defs)

lemma sum_empty [simp]: "0+0 = 0"
by (simp add: sum_defs)

(*Injection and freeness rules*)

lemmas Inl_inject = Inl_iff [THEN iffD1]
lemmas Inr_inject = Inr_iff [THEN iffD1]
lemmas Inl_neq_Inr = Inl_Inr_iff [THEN iffD1, THEN FalseE, elim!]
lemmas Inr_neq_Inl = Inr_Inl_iff [THEN iffD1, THEN FalseE, elim!]

lemma InlD: "Inl(a): A+B \<Longrightarrow> a \<in> A"
by blast

lemma InrD: "Inr(b): A+B \<Longrightarrow> b \<in> B"
by blast

lemma sum_iff: "u \<in> A+B \<longleftrightarrow> (\<exists>x. x \<in> A \<and> u=Inl(x)) | (\<exists>y. y \<in> B \<and> u=Inr(y))"
by blast

lemma Inl_in_sum_iff [simp]: "(Inl(x) \<in> A+B) \<longleftrightarrow> (x \<in> A)"
by auto

lemma Inr_in_sum_iff [simp]: "(Inr(y) \<in> A+B) \<longleftrightarrow> (y \<in> B)"
by auto

lemma sum_subset_iff: "A+B \<subseteq> C+D \<longleftrightarrow> A<=C \<and> B<=D"
by blast

lemma sum_equal_iff: "A+B = C+D \<longleftrightarrow> A=C \<and> B=D"
by (simp add: extension sum_subset_iff, blast)

lemma sum_eq_2_times: "A+A = 2*A"
by (simp add: sum_def, blast)

subsection\<open>The Eliminator: \<^term>\<open>case\<close>\<close>

lemma case_Inl [simp]: "case(c, d, Inl(a)) = c(a)"
by (simp add: sum_defs)

lemma case_Inr [simp]: "case(c, d, Inr(b)) = d(b)"
by (simp add: sum_defs)

lemma case_type [TC]:
    "\<lbrakk>u \<in> A+B;
        \<And>x. x \<in> A \<Longrightarrow> c(x): C(Inl(x));
        \<And>y. y \<in> B \<Longrightarrow> d(y): C(Inr(y))
\<rbrakk> \<Longrightarrow> case(c,d,u) \<in> C(u)"
by auto

lemma expand_case: "u \<in> A+B \<Longrightarrow>
        R(case(c,d,u)) \<longleftrightarrow>
        ((\<forall>x\<in>A. u = Inl(x) \<longrightarrow> R(c(x))) \<and>
        (\<forall>y\<in>B. u = Inr(y) \<longrightarrow> R(d(y))))"
by auto

lemma case_cong:
  "\<lbrakk>z \<in> A+B;
      \<And>x. x \<in> A \<Longrightarrow> c(x)=c'(x);
      \<And>y. y \<in> B \<Longrightarrow> d(y)=d'(y)
\<rbrakk> \<Longrightarrow> case(c,d,z) = case(c',d',z)"
by auto

lemma case_case: "z \<in> A+B \<Longrightarrow>
        case(c, d, case(\<lambda>x. Inl(c'(x)), \<lambda>y. Inr(d'(y)), z)) =
        case(\<lambda>x. c(c'(x)), \<lambda>y. d(d'(y)), z)"
by auto

subsection\<open>More Rules for \<^term>\<open>Part(A,h)\<close>\<close>

lemma Part_mono: "A<=B \<Longrightarrow> Part(A,h)<=Part(B,h)"
by blast

lemma Part_Collect: "Part(Collect(A,P), h) = Collect(Part(A,h), P)"
by blast

lemmas Part_CollectE =
     Part_Collect [THEN equalityD1, THEN subsetD, THEN CollectE]

lemma Part_Inl: "Part(A+B,Inl) = {Inl(x). x \<in> A}"
by blast

lemma Part_Inr: "Part(A+B,Inr) = {Inr(y). y \<in> B}"
by blast

lemma PartD1: "a \<in> Part(A,h) \<Longrightarrow> a \<in> A"
by (simp add: Part_def)

lemma Part_id: "Part(A,\<lambda>x. x) = A"
by blast

lemma Part_Inr2: "Part(A+B, \<lambda>x. Inr(h(x))) = {Inr(y). y \<in> Part(B,h)}"
by blast

lemma Part_sum_equality: "C \<subseteq> A+B \<Longrightarrow> Part(C,Inl) \<union> Part(C,Inr) = C"
by blast

end


section \<open>Auxiliary material\<close>
theory Lucas_Lehmer_Auxiliary
imports
  "HOL-Algebra.Ring"
  "Probabilistic_Prime_Tests.Jacobi_Symbol"
begin

(* TODO: Much of this belongs in the library *)

subsection \<open>Auxiliary  number-theoretic material\<close>

lemma congD: "[a = b] (mod n) \<Longrightarrow> a mod n = b mod n"
  by (auto simp: cong_def)

lemma eval_coprime:
  "(b :: 'a :: euclidean_semiring_gcd) \<noteq> 0 \<Longrightarrow> coprime a b \<longleftrightarrow> coprime b (a mod b)"
  by (simp add: coprime_commute)

lemma two_power_odd_mod_12:
  assumes "odd n" "n > 1"
  shows   "[2 ^ n = 8] (mod (12 :: nat))"
  using assms
proof (induction n rule: less_induct)
  case (less n)
  show ?case
  proof (cases "n = 3")
    case False
    with less.prems have "n > 3" by (auto elim!: oddE)
    hence "[2 ^ (n - 2 + 2) = (8 * 4 :: nat)] (mod 12)"
      unfolding power_add using less.prems by (intro cong_mult less) auto
    also have "n - 2 + 2 = n"
      using \<open>n > 3\<close> by simp
    finally show ?thesis by (simp add: cong_def)
  qed auto
qed

lemma Legendre_3_right:
  fixes p :: nat
  assumes p: "prime p" "p > 3"
  shows   "p mod 12 \<in> {1, 5, 7, 11}" and "Legendre p 3 = (if p mod 12 \<in> {1, 7} then 1 else -1)"
proof -
  have "coprime p 2" using p prime_nat_not_dvd[of p 2]
    by (intro prime_imp_coprime) (auto dest: dvd_imp_le)
  moreover have "coprime p 3" using p
    by (intro prime_imp_coprime) auto
  ultimately have "coprime p (2 * 2 * 3)"
    unfolding coprime_mult_right_iff by auto
  hence "coprime 12 p"
    by (simp add: coprime_commute)

  hence "p mod 12 \<in> {p\<in>{..11}. coprime 12 p}" by auto
  also have "{p\<in>{..11}. coprime 12 p} = {1::nat, 5, 7, 11}"
    unfolding atMost_nat_numeral pred_numeral_simps arith_simps
    by (auto simp del: coprime_imp_gcd_eq_1 simp: eval_coprime)
  finally show "p mod 12 \<in> {1, 5, 7, 11}" by auto
  hence "p mod 12 = 1 \<or> p mod 12 = 5 \<or> p mod 12 = 7 \<or> p mod 12 = 11"
    by auto
  thus "Legendre p 3 = (if p mod 12 \<in> {1, 7} then 1 else -1)"
  proof safe
    assume "p mod 12 = 1"
    have "Legendre (int p) 3 = Legendre (int p mod 3) 3"
      by (intro Legendre_mod [symmetric]) auto
    also from \<open>p mod 12 = 1\<close> have "p mod 12 mod 3 = 1" by simp
    hence "p mod 3 = 1" by (simp add: mod_mod_cancel)
    hence "int p mod 3 = 1" by presburger
    finally have "Legendre p 3 = 1" by simp
    thus ?thesis using \<open>p mod 12 = 1\<close> by simp
  next
    assume "p mod 12 = 5"
    have "Legendre (int p) 3 = Legendre (int p mod 3) 3"
      by (intro Legendre_mod [symmetric]) auto
    also from \<open>p mod 12 = 5\<close> have "p mod 12 mod 3 = 2" by simp
    hence "p mod 3 = 2" by (simp add: mod_mod_cancel)
    hence "int p mod 3 = 2" by presburger
    finally have "Legendre p 3 = -1" by (simp add: supplement2_Legendre)
    thus ?thesis using \<open>p mod 12 = 5\<close> by simp
  next
    assume "p mod 12 = 7"
    have "Legendre (int p) 3 = Legendre (int p mod 3) 3"
      by (intro Legendre_mod [symmetric]) auto
    also from \<open>p mod 12 = 7\<close> have "p mod 12 mod 3 = 1" by simp
    hence "p mod 3 = 1" by (simp add: mod_mod_cancel)
    hence "int p mod 3 = 1" by presburger
    finally have "Legendre p 3 = 1" by simp
    thus ?thesis using \<open>p mod 12 = 7\<close> by simp
  next
    assume "p mod 12 = 11"
    have "Legendre (int p) 3 = Legendre (int p mod 3) 3"
      by (intro Legendre_mod [symmetric]) auto
    also from \<open>p mod 12 = 11\<close> have "p mod 12 mod 3 = 2" by simp
    hence "p mod 3 = 2" by (simp add: mod_mod_cancel)
    hence "int p mod 3 = 2" by presburger
    finally have "Legendre p 3 = -1" by (simp add: supplement2_Legendre)
    thus ?thesis using \<open>p mod 12 = 11\<close> by simp
  qed
qed

lemma Legendre_3_left:
  fixes p :: nat
  assumes p: "prime p" "p > 3"
  shows   "Legendre 3 p = (if p mod 12 \<in> {1, 11} then 1 else -1)"
proof (cases "p mod 12 = 1 \<or> p mod 12 = 5")
  case True
  hence "p mod 12 mod 4 = 1" by auto
  hence "even ((p - Suc 0) div 2)"
    by (intro even_mod_4_div_2) (auto simp: mod_mod_cancel)
  with Quadratic_Reciprocity[of p 3] Legendre_3_right(2)[of p] assms True show ?thesis
    by auto
next
  case False
  with Legendre_3_right(1)[OF assms] have *: "p mod 12 = 7 \<or> p mod 12 = 11" by auto
  hence "p mod 12 mod 4 = 3" by auto
  hence "odd ((p - Suc 0) div 2)"
    by (intro odd_mod_4_div_2) (auto simp: mod_mod_cancel)
  with Quadratic_Reciprocity[of p 3] Legendre_3_right(2)[of p] assms * show ?thesis
    by fastforce
qed

lemma supplement2_Legendre':
  assumes "prime p" "p \<noteq> 2"
  shows "Legendre 2 p = (if p mod 8 = 1 \<or> p mod 8 = 7 then 1 else -1)"
proof -
  from assms have "p > 2"
    using prime_gt_1_int[of p] by auto
  moreover from this and assms have "odd p"
    by (auto simp: prime_odd_int)
  ultimately show ?thesis
    using supplement2_Jacobi'[of p] assms prime_odd_int[of p]
    by (simp add: prime_p_Jacobi_eq_Legendre)
qed

lemma little_Fermat_nat:
  fixes a :: nat
  assumes "prime p" "\<not>p dvd a"
  shows   "[a ^ p = a] (mod p)"
proof -
  have "p = Suc (p - 1)"
    using prime_gt_0_nat[OF assms(1)] by simp
  also have "p - 1 = totient p"
    using assms by (simp add: totient_prime)
  also have "a ^ (Suc \<dots>) = a * a ^ totient p"
    by simp
  also have "[\<dots> = a * 1] (mod p)"
    using prime_imp_coprime[of p a] assms
    by (intro cong_mult cong_refl euler_theorem) (auto simp: coprime_commute)
  finally show ?thesis by simp
qed

lemma little_Fermat_int:
  fixes a :: int and p :: nat
  assumes "prime p" "\<not>p dvd a"
  shows   "[a ^ p = a] (mod p)"
proof -
  have "p > 1" using prime_gt_1_nat assms by simp
  have "\<not>int p dvd a mod int p"
    using assms by (simp add: dvd_mod_iff)
  also from \<open>p > 1\<close> have "a mod int p = int (nat (a mod int p))"
    by simp
  finally have not_dvd: "\<not>p dvd nat (a mod int p)"
    by (subst (asm) int_dvd_int_iff)

  have "[a ^ p = (a mod p) ^ p] (mod p)"
    by (intro cong_pow) (auto simp: cong_def)
  also have "(a mod p) ^ p = (int (nat (a mod p))) ^ p"
    using \<open>p > 1\<close> by (subst of_nat_nat) auto
  also have "\<dots> = int (nat (a mod p) ^ p)"
    by simp
  also have "[\<dots> = int (nat (a mod p))] (mod p)"
    by (subst cong_int_iff, rule little_Fermat_nat) (use assms not_dvd in auto)
  also have "int (nat (a mod p)) = a mod p"
    using \<open>p > 1\<close> by simp
  also have "[a mod p = a] (mod p)"
    by (auto simp: cong_def)
  finally show ?thesis .
qed

lemma prime_dvd_choose:
  assumes "0 < k" "k < p" "prime p"
  shows "p dvd (p choose k)"
proof -
  have "k \<le> p" using \<open>k < p\<close> by auto

  have "p dvd fact p" using assms by (simp add: prime_dvd_fact_iff)

  moreover have "\<not> p dvd fact k * fact (p - k)"
    unfolding prime_dvd_mult_iff[OF assms(3)] prime_dvd_fact_iff[OF assms(3)]
    using assms by simp

  ultimately show ?thesis
    unfolding binomial_fact_lemma[OF \<open>k \<le> p\<close>, symmetric]
    using assms prime_dvd_multD by blast
qed

lemma prime_natD:
  assumes "prime (p :: nat)" "a dvd p"
  shows   "a = 1 \<or> a = p"
  using assms by (auto simp: prime_nat_iff)

  lemma not_prime_imp_ex_prod_nat:
  assumes "m > 1" "\<not> prime (m::nat)"
  shows   "\<exists>n k. m = n * k \<and> 1 < n \<and> n < m \<and> 1 < k \<and> k < m"
proof -
  from assms have "\<not>Factorial_Ring.irreducible m"
    by (simp flip: prime_elem_iff_irreducible)
  with assms obtain n k where nk: "m = n * k" "n \<noteq> 1" "k \<noteq> 1"
    by (auto simp: Factorial_Ring.irreducible_def)
  moreover from this assms have "n > 0" "k > 0"
    by auto
  with nk have "n > 1" "k > 1" by auto
  moreover {
    from assms nk have "n dvd m" "k dvd m" by auto
    with assms have "n \<le> m" "k \<le> m"
      by (auto intro!: dvd_imp_le)
    moreover from nk \<open>n > 1\<close> \<open>k > 1\<close> have "n \<noteq> m" "k \<noteq> m"
      by auto
    ultimately have "n < m" "k < m" by auto
  }
  ultimately show ?thesis by blast
qed

subsection \<open>Auxiliary algebraic material\<close>

lemma (in group) ord_eqI_prime_factors:
  assumes "\<And>p. p \<in> prime_factors n \<Longrightarrow> x [^] (n div p) \<noteq> \<one>" and "x [^] n = \<one>"
  assumes "x \<in> carrier G" "n > 0"
  shows   "group.ord G x = n"
proof -
  have "group.ord G x dvd n"
    using assms by (subst pow_eq_id [symmetric]) auto
  then obtain k where k: "n = group.ord G x * k"
    by auto
  have "k = 1"
  proof (rule ccontr)
    assume "k \<noteq> 1"
    then obtain p where p: "prime p" "p dvd k"
      using prime_factor_nat by blast
    have "x [^] (group.ord G x * (k div p)) = \<one>"
      by (subst pow_eq_id) (use assms in auto)
    also have "group.ord G x * (k div p) = n div p"
      using p by (auto simp: k)
    finally have "x [^] (n div p) = \<one>" .
    moreover have "x [^] (n div p) \<noteq> \<one>"
      using p k assms by (intro assms) (auto simp: in_prime_factors_iff)
    ultimately show False by contradiction
  qed
  with k show ?thesis by simp
qed

lemma (in monoid) pow_nat_eq_1_imp_unit:
  fixes n :: nat
  assumes "x [^] n = \<one>" and "n > 0" and [simp]: "x \<in> carrier G"
  shows   "x \<in> Units G"
proof -
  from \<open>n > 0\<close> have "x [^] (1 :: nat) \<otimes> x [^] (n - 1) = x [^] n"
    by (subst nat_pow_mult) auto
  with assms have "x \<otimes> x [^] (n - 1) = \<one>"
    by simp
  moreover from \<open>n > 0\<close> have "x [^] (n - 1) \<otimes> x [^] (1 :: nat) = x [^] n"
    by (subst nat_pow_mult) auto
  with assms have "x [^] (n - 1) \<otimes> x = \<one>"
    by simp
  ultimately show ?thesis by (auto simp: Units_def)
qed

lemma (in cring) finsum_reindex_bij_betw:
  assumes "bij_betw h S T" "g \<in> T \<rightarrow> carrier R"
  shows   "finsum R (\<lambda>x. g (h x)) S = finsum R g T"
  using assms by (auto simp: bij_betw_def finsum_reindex)

lemma (in cring) finsum_reindex_bij_witness:
  assumes witness:
    "\<And>a. a \<in> S \<Longrightarrow> i (j a) = a"
    "\<And>a. a \<in> S \<Longrightarrow> j a \<in> T"
    "\<And>b. b \<in> T \<Longrightarrow> j (i b) = b"
    "\<And>b. b \<in> T \<Longrightarrow> i b \<in> S"
    "\<And>b. b \<in> S \<Longrightarrow> g b \<in> carrier R"
  assumes eq:
    "\<And>a. a \<in> S \<Longrightarrow> h (j a) = g a"
  shows "finsum R g S = finsum R h T"
proof -
  have bij: "bij_betw j S T"
    using bij_betw_byWitness[where A=S and f=j and f'=i and A'=T] witness by auto
  hence T_eq: "T = j ` S" by (auto simp: bij_betw_def)
  from assms have "h \<in> T \<rightarrow> carrier R"
    by (subst T_eq) auto
  moreover have "finsum R g S = finsum R (\<lambda>x. h (j x)) S"
    using assms by (intro finsum_cong) (auto simp: eq)
  ultimately show ?thesis using assms(5)
    using finsum_reindex_bij_betw[OF bij, of h] by simp
qed

lemma (in cring) binomial:
  fixes n :: nat
  assumes [simp]: "x \<in> carrier R" "y \<in> carrier R"
  shows   "(x \<oplus> y) [^] n = (\<Oplus>i\<in>{..n}. add_pow R (n choose i) (x [^] i \<otimes> y [^] (n - i)))"
proof (induction n)
  case (Suc n)
  have binomial_Suc: "Suc n choose i = (n choose (i - 1)) + (n choose i)" if "i \<in> {1..n}" for i
    using that by (cases i) auto
  have Suc_diff: "Suc n - i = Suc (n - i)" if "i \<le> n" for i
    using that by linarith
  have "(x \<oplus> y) [^] Suc n =
          (\<Oplus>i\<in>{..n}. add_pow R (n choose i) (x [^] i \<otimes> y [^] (n - i))) \<otimes> x \<oplus>
          (\<Oplus>i\<in>{..n}. add_pow R (n choose i) (x [^] i \<otimes> y [^] (n - i))) \<otimes> y"
    by (simp add: semiring_simprules Suc)
  also have "(\<Oplus>i\<in>{..n}. add_pow R (n choose i) (x [^] i \<otimes> y [^] (n - i))) \<otimes> x =
             (\<Oplus>i\<in>{..n}. add_pow R (n choose i) (x [^] Suc i \<otimes> y [^] (n - i)))"
    by (subst finsum_ldistr)
       (auto simp: cring_simprules Suc add_pow_rdistr intro!: finsum_cong)
  also have "\<dots> = (\<Oplus>i\<in>{1..Suc n}. add_pow R (n choose (i - 1)) (x [^] i \<otimes> y [^] (Suc n - i)))"
    by (intro finsum_reindex_bij_witness[of _ "\<lambda>i. i - 1" Suc]) auto
  also have "{1..Suc n} = insert (Suc n) {1..n}" by auto
  also have "(\<Oplus>i\<in>\<dots>. add_pow R (n choose (i - 1)) (x [^] i \<otimes> y [^] (Suc n - i))) =
             x [^] Suc n \<oplus> (\<Oplus>i\<in>{1..n}. add_pow R (n choose (i - 1)) (x [^] i \<otimes> y [^] (Suc n - i)))"
    (is "_ = _ \<oplus> ?S1") by (subst finsum_insert) auto
  also have "(\<Oplus>i\<in>{..n}. add_pow R (n choose i) (x [^] i \<otimes> y [^] (n - i))) \<otimes> y =
             (\<Oplus>i\<in>{..n}. add_pow R (n choose i) (x [^] i \<otimes> y [^] (Suc n - i)))"
    by (subst finsum_ldistr)
       (auto simp: cring_simprules Suc add_pow_rdistr Suc_diff intro!: finsum_cong)
  also have "{..n} = insert 0 {1..n}" by auto
  also have "(\<Oplus>i\<in>\<dots>. add_pow R (n choose i) (x [^] i \<otimes> y [^] (Suc n - i))) =
             y [^] Suc n \<oplus> (\<Oplus>i\<in>{1..n}. add_pow R (n choose i) (x [^] i \<otimes> y [^] (Suc n - i)))"
    (is "_ = _ \<oplus> ?S2") by (subst finsum_insert) auto
  also have "(x [^] Suc n \<oplus> ?S1) \<oplus> (y [^] Suc n \<oplus> ?S2) =
               x [^] Suc n \<oplus> y [^] Suc n \<oplus> (?S1 \<oplus> ?S2)"
    by (simp add: cring_simprules)
  also have "?S1 \<oplus> ?S2 = (\<Oplus>i\<in>{1..n}. add_pow R (Suc n choose i) (x [^] i \<otimes> y [^] (Suc n - i)))"
    by (subst finsum_addf [symmetric], simp, simp, rule finsum_cong')
       (auto intro!: finsum_cong simp: binomial_Suc add.nat_pow_mult)
  also have "x [^] Suc n \<oplus> y [^] Suc n \<oplus> \<dots> =
               (\<Oplus>i\<in>{0, Suc n} \<union> {1..n}. add_pow R (Suc n choose i) (x [^] i \<otimes> y [^] (Suc n - i)))"
    by (subst finsum_Un_disjoint) (auto simp: cring_simprules)
  also have "{0, Suc n} \<union> {1..n} = {..Suc n}" by auto
  finally show ?case .
qed auto

lemma (in cring) binomial_finite_char:
  fixes p :: nat
  assumes [simp]: "x \<in> carrier R" "y \<in> carrier R" and "add_pow R p \<one> = \<zero>" "prime p"
  shows   "(x \<oplus> y) [^] p = x [^] p \<oplus> y [^] p"
proof -
  have *: "add_pow R (p choose i) (x [^] i \<otimes> y [^] (p - i)) = \<zero>" if "i \<in> {1..<p}" for i
  proof -
    have "p dvd (p choose i)"
      by (rule prime_dvd_choose) (use that assms in auto)
    then obtain k where [simp]: "(p choose i) = p * k"
      by auto
    have "add_pow R (p choose i) (x [^] i \<otimes> y [^] (p - i)) =
            add_pow R (p choose i) \<one> \<otimes> (x [^] i \<otimes> y [^] (p - i))"
      by (simp add: add_pow_ldistr)
    also have "add_pow R (p choose i) \<one> = \<zero>"
      using assms by (simp flip: add.nat_pow_pow)
    finally show ?thesis by simp
  qed

  have "(x \<oplus> y) [^] p = (\<Oplus>i\<in>{..p}. add_pow R (p choose i) (x [^] i \<otimes> y [^] (p - i)))"
    by (rule binomial) auto
  also have "\<dots> = (\<Oplus>i\<in>{0, p}. add_pow R (p choose i) (x [^] i \<otimes> y [^] (p - i)))"
    using * by (intro add.finprod_mono_neutral_cong_right) auto
  also have "\<dots> = x [^] p \<oplus> y [^] p"
    using assms prime_gt_0_nat[of p] by (simp add: cring_simprules)
  finally show ?thesis .
qed

lemma (in ring_hom_cring) hom_add_pow_nat:
  "x \<in> carrier R \<Longrightarrow> h (add_pow R (n::nat) x) = add_pow S n (h x)"
  by (induction n) auto

end


theory intersect
imports Main
        "../data/Natu"
        "../data/list"
        "../funcs/elem"
        "$HIPSTER_HOME/IsaHipster"

begin

fun intersect :: "Nat list => Nat list => Nat list" where
  "intersect (Nil2) y = Nil2"
| "intersect (Cons2 z xs) y =
     (if elem z y then Cons2 z (intersect xs y) else intersect xs y)"

hipster elem intersect equal2
lemma lemma_ad [thy_expl]: "intersect (intersect x5 y5) y5 = intersect x5 y5"
by (hipster_induct_schemes elem.simps intersect.simps equal2.simps)

lemma unknown [thy_expl]: "intersect x x = x"
oops

lemma unknown [thy_expl]: "elem x (intersect y z) = elem x (intersect z y)"
oops

lemma unknown [thy_expl]: "intersect x (intersect y z) = intersect x (intersect z y)"
oops

lemma unknown [thy_expl]: "intersect (intersect x y) z = intersect x (intersect y z)"
oops

lemma unknown [thy_expl]: "intersect (intersect x y) z = intersect x (intersect z y)"
oops

lemma unknown [thy_expl]: "intersect x (intersect x y) = intersect x y"
oops

lemma unknown [thy_expl]: "intersect x (intersect y x) = intersect x y"
oops

lemma unknown [thy_expl]: "intersect (intersect x y) x = intersect x y"
oops

lemma unknown [thy_expl]: "intersect (intersect x y) (intersect x z) = intersect x (intersect y z)"
oops

lemma unknown [thy_expl]: "intersect (intersect x y) (intersect y z) = intersect x (intersect y z)"
oops

lemma unknown [thy_expl]: "intersect (intersect x y) (intersect z x) = intersect x (intersect y z)"
oops

lemma unknown [thy_expl]: "intersect (intersect x y) (intersect z y) = intersect x (intersect y z)"
oops

lemma unknown [thy_expl]: "intersect (intersect x y) (intersect x z) = intersect x (intersect z y)"
oops

lemma unknown [thy_expl]: "intersect (intersect x y) (intersect z x) = intersect x (intersect z y)"
oops

lemma unknown [thy_expl]: "intersect (intersect x y) (intersect z y) = intersect x (intersect z y)"
oops

lemma unknown [thy_expl]: "intersect (intersect x y) (intersect y z) = intersect x (intersect z y)"
oops

lemma unknown [thy_expl]: "elem (S x) (intersect y z) = elem (S x) (intersect z y)"
oops

lemma unknown [thy_expl]: "elem Z (intersect x y) = elem Z (intersect y x)"
oops

lemma unknown [thy_expl]: "intersect (intersect x y) (intersect x y) = intersect x y"
oops

lemma unknown [thy_expl]: "intersect (intersect x y) (intersect y x) = intersect x y"
oops

lemma unknown [thy_expl]: "elem (S Z) (intersect x y) = elem (S Z) (intersect y x)"
oops

hipster_cond elem intersect equal2
lemma lemma_ae [thy_expl]: "elem x1 z1 \<Longrightarrow> elem x1 (intersect y1 z1) = elem x1 y1"
by (hipster_induct_schemes elem.simps intersect.simps equal2.simps)

lemma unknown [thy_expl]: "intersect x x = x"
oops

lemma unknown [thy_expl]: "elem x (intersect y z) = elem x (intersect z y)"
oops

lemma unknown [thy_expl]: "intersect x (intersect y z) = intersect x (intersect z y)"
oops

lemma unknown [thy_expl]: "intersect (intersect x y) z = intersect x (intersect y z)"
oops

lemma unknown [thy_expl]: "intersect (intersect x y) z = intersect x (intersect z y)"
oops

lemma unknown [thy_expl]: "intersect x (intersect x y) = intersect x y"
oops

lemma unknown [thy_expl]: "intersect x (intersect y x) = intersect x y"
oops

lemma unknown [thy_expl]: "intersect (intersect x y) x = intersect x y"
oops

lemma unknown [thy_expl]: "intersect (intersect x y) (intersect x z) = intersect x (intersect y z)"
oops

lemma unknown [thy_expl]: "intersect (intersect x y) (intersect y z) = intersect x (intersect y z)"
oops

lemma unknown [thy_expl]: "intersect (intersect x y) (intersect z x) = intersect x (intersect y z)"
oops

lemma unknown [thy_expl]: "intersect (intersect x y) (intersect z y) = intersect x (intersect y z)"
oops

lemma unknown [thy_expl]: "intersect (intersect x y) (intersect x z) = intersect x (intersect z y)"
oops

lemma unknown [thy_expl]: "intersect (intersect x y) (intersect z x) = intersect x (intersect z y)"
oops

lemma unknown [thy_expl]: "intersect (intersect x y) (intersect z y) = intersect x (intersect z y)"
oops

lemma unknown [thy_expl]: "intersect (intersect x y) (intersect y z) = intersect x (intersect z y)"
oops

lemma unknown [thy_expl]: "elem (S x) (intersect y z) = elem (S x) (intersect z y)"
oops

lemma unknown [thy_expl]: "elem Z (intersect x y) = elem Z (intersect y x)"
oops

lemma unknown [thy_expl]: "intersect (intersect x y) (intersect x y) = intersect x y"
oops

lemma unknown [thy_expl]: "intersect (intersect x y) (intersect y x) = intersect x y"
oops

lemma unknown [thy_expl]: "elem (S Z) (intersect x y) = elem (S Z) (intersect y x)"
oops

lemma unknown [thy_expl]: "elem x y \<Longrightarrow> elem x (intersect y z) = elem x z"
oops

end


theory rotate_self
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = S "Nat" | Z

datatype 'a List2 = Cons2 "'a" "'a List2" | Nil2

fun append :: "'a List2 => 'a List2 => 'a List2" where
"append (Cons2 z xs) y = Cons2 z (append xs y)"
| "append (Nil2) y = y"

fun rotate :: "Nat => 'a List2 => 'a List2" where
"rotate (S z) (Cons2 x2 x3) =
   rotate z (append x3 (Cons2 x2 (Nil2)))"
| "rotate (S z) (Nil2) = Nil2"
| "rotate (Z) y = y"

(*hipster append rotate *)

theorem x0 :
  "!! (n :: Nat) (xs :: 'a List2) .
     (rotate n (append xs xs)) = (append (rotate n xs) (rotate n xs))"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory Type_infer imports Main begin

\<comment> \<open> type inference for TLA set theory \<close>

\<comment> \<open> variables \<close>
datatype 'ty var = Var int 'ty
datatype row = Row \<comment> \<open> the annotation for row variables \<close>
datatype constructor = Cstor string

datatype ty =
  Ty_var "unit var"
| Ty_top  \<comment> \<open> the universal type \<close>
| Ty_app string "ty list"
| Ty_cases "constructor list" "row var option" \<comment> \<open> A | B | C | \<rho> \<close>

value "Ty_app ''list'' [Ty_cases [Cstor ''A'', Cstor ''B''] None]"

\<comment> \<open> does a variable occur in a type? \<close>
fun var_occurs_in_ty :: "_ var \<Rightarrow> ty \<Rightarrow> bool" where
  "var_occurs_in_ty v (Ty_var v') = (v=v')"
| "var_occurs_in_ty _ Ty_top = False"
| "var_occurs_in_ty v (Ty_app _ l) = List.list_ex (var_occurs_in_ty v) l"
| "var_occurs_in_ty _ (Ty_cases _ _) = False"

\<comment> \<open> free variables of a type \<close>
fun free_vars_ty :: "ty \<Rightarrow> unit var set" where
  "free_vars_ty (Ty_var v) = {v}"
| "free_vars_ty Ty_top = {}"
| "free_vars_ty (Ty_app _ l) =  List.foldl (\<lambda> s t. s \<union> free_vars_ty t) {} l"
| "free_vars_ty (Ty_cases _ _) = {}"

definition tyvar1 :: "unit var" where "tyvar1 = Var 1 ()"
definition tyvar2 :: "unit var" where "tyvar2 = Var 2 ()"
definition tyvar3 :: "unit var" where "tyvar3 = Var 3 ()"
definition tynat :: ty where "tynat = Ty_app ''nat'' []"
definition tylist :: ty where "tylist = Ty_app ''list'' [Ty_var tyvar1]"
definition abc :: ty where "abc = Ty_cases [Cstor ''A'', Cstor ''B'', Cstor ''C''] None"

\<comment> \<open> terms (with typed variables) \<close>

datatype "term" =
  T_var "ty var"
| T_app string "term list"

value "[1,2,3] :: int list"
value "''f'' :: string"
value "T_app ''f'' [T_var (Var 1 tynat), T_app ''a'' []]"

\<comment> \<open> substitution for types: one function for regular variables, one for row variables \<close>
record subst =
  subst_tvar :: "ty var \<Rightarrow> term option"
  subst_tyvar :: "unit var \<Rightarrow> ty option"
  subst_tyrowvars :: "row var \<Rightarrow> (constructor list * row var option) option"

definition const_none :: "'a \<Rightarrow> 'b option" where "const_none _ = None"
definition subst_empty :: subst where "subst_empty = subst.make const_none const_none const_none"

fun eval_ty :: "subst \<Rightarrow> ty \<Rightarrow> ty" where
  "eval_ty _ Ty_top = Ty_top"
| "eval_ty \<sigma> (Ty_app f l) =
    ( let l' = map (eval_ty \<sigma>) l in
      if List.member l' Ty_top
      then Ty_top (* absorbing *)
      else Ty_app f l' )"
| "eval_ty \<sigma> (Ty_var v) =
    (case (subst_tyvar \<sigma>) v of
          None \<Rightarrow> Ty_var v
        | Some t \<Rightarrow> t)"
| "eval_ty \<sigma> (Ty_cases l None) = Ty_cases l None"
| "eval_ty \<sigma> (Ty_cases l (Some \<rho>)) =
    (case (subst_tyrowvars \<sigma>) \<rho> of
      None \<Rightarrow> Ty_cases l (Some \<rho>)
    | Some (l', \<rho>') \<Rightarrow> Ty_cases (l @ l') \<rho>')"

fun eval_term :: "subst \<Rightarrow> term \<Rightarrow> term" where
  "eval_term \<sigma> (T_var v) = (case subst_tvar \<sigma> v of None \<Rightarrow> (T_var v) | Some t \<Rightarrow> t)"
| "eval_term \<sigma> (T_app f l) = T_app f (List.map (eval_term \<sigma>) l)"

\<comment> \<open> generator of fresh (free) variables \<close>

record varset =
  tyvars :: "unit var set"
  tvars :: "ty var set"
  rowvars :: "row var set"

type_synonym ('s,'a) state = "'s \<Rightarrow> ('a * 's)"

fun return :: "'a \<Rightarrow> ('s, 'a) state" where
  "return x = (\<lambda> s. (x,s))"

fun bind :: "('st,'a) state \<Rightarrow> ('a \<Rightarrow> ('st,'b) state) \<Rightarrow> ('st,'b) state" (infixr "\<bind>" 80) where
  "bind f_a f = (\<lambda> s. let (x,s') = f_a s in f x s')"

\<comment> \<open> abstract generator for fresh variables \<close>
locale var_gen =
  fixes new_tyvar :: "(varset, unit var) state"
  fixes new_tvar :: "(varset, ty var) state"
  fixes new_rowvar :: "(varset, row var) state"
  assumes is_fresh_tyvar[intro,simp]: "\<forall> s. (let (x,_) = new_tyvar s in x \<notin> tyvars s)"
  assumes is_fresh_tvar[intro,simp]: "\<forall> s. (let (x,_) = new_tvar s in x \<notin> tvars s)"
  assumes is_fresh_rowvar[intro,simp]: "\<forall> s. (let (x,_) = new_rowvar s in x \<notin> rowvars s)"

\<comment> \<open> type unification.
     It lives in the monad because it might need to allocate new row variables \<close>

fun is_bound :: "unit var \<Rightarrow> subst \<Rightarrow> bool" (infix "\<in>?" 90) where
  "is_bound v \<sigma> = (case subst_tyvar \<sigma> v of Some _ \<Rightarrow> True | None \<Rightarrow> False)"

fun occur_check_ty :: "subst \<Rightarrow> unit var \<Rightarrow> ty \<Rightarrow> bool" where
  "occur_check_ty \<sigma> v ty = (v \<in> free_vars_ty (eval_ty \<sigma> ty))"

value "\<not> tyvar1 \<in>? x"

fun bind_tyvar :: "unit var \<Rightarrow> ty \<Rightarrow> subst \<Rightarrow> subst" where
  "bind_tyvar v ty \<sigma> = (\<sigma>\<lparr> subst_tyvar := (subst_tyvar \<sigma>)(v := Some ty) \<rparr>)"

fun get_tyvar :: "subst \<Rightarrow> unit var \<Rightarrow> ty" where
  "get_tyvar \<sigma> v = the (subst_tyvar \<sigma> v)"

\<comment> \<open> handle set of cases \<close>
record split_cases_rec =
  common :: "constructor set"
  left_only :: "constructor set"
  right_only :: "constructor set"

\<comment> \<open> split two cases lists l1, l2 into a common part, a left-only part, a right only part \<close>
fun split_cases :: "constructor list \<Rightarrow> constructor list \<Rightarrow> split_cases_rec" where
  "split_cases [] [] = split_cases_rec.make {} {} {}"
| "split_cases [] (c#l) = (
    let r = split_cases [] l in
    if c \<in> left_only r
      then r\<lparr> left_only := Set.remove c (left_only r),
              common := Set.insert c (common r) \<rparr>
      else r\<lparr> right_only := Set.insert c (right_only r) \<rparr> )"
| "split_cases (c#l) l2 =  (
    let r = split_cases l l2 in
    if c \<in> right_only r
      then r\<lparr> right_only := Set.remove c (right_only r),
              common := Set.insert c (common r) \<rparr>
      else r\<lparr> left_only := Set.insert c (left_only r) \<rparr> )"

\<comment> \<open> Type unification, defined inductively.
    TODO: represent, in the type, that the result can become Top?
      Or really implement this as a function (subst => ty => ty => (subst | top))
    \<close>
inductive
    unif_ty :: "subst \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> subst \<Rightarrow> bool"
and unif_ty_list :: "subst \<Rightarrow> ty list \<Rightarrow> ty list \<Rightarrow> subst \<Rightarrow> bool"
and unif_ty_row :: "subst \<Rightarrow> row var option \<Rightarrow> constructor set \<Rightarrow> subst \<Rightarrow> bool"
where
  left_var: "
    \<not> v1 \<in>? \<sigma> \<Longrightarrow>
    \<not> occur_check_ty \<sigma> v1 ty2 \<Longrightarrow>
    unif_ty \<sigma> (Ty_var v1) ty2 (bind_tyvar v1 ty2 \<sigma>)"
| right_var: "
    \<not> v2 \<in>? \<sigma> \<Longrightarrow>
    \<not> occur_check_ty \<sigma> v2 ty1 \<Longrightarrow>
    unif_ty \<sigma> ty1 (Ty_var v2) (bind_tyvar v2 ty1 \<sigma>)"
| deref_left: "
    v1 \<in>? \<sigma> \<Longrightarrow>
    unif_ty \<sigma> (get_tyvar \<sigma> v1) ty2 \<sigma>' \<Longrightarrow>
    unif_ty \<sigma> (Ty_var v1) ty2 \<sigma>'"
| deref_right: "
    v2 \<in>? \<sigma> \<Longrightarrow>
    unif_ty \<sigma> ty1 (get_tyvar \<sigma> v2) \<sigma>' \<Longrightarrow>
    unif_ty \<sigma> ty1 (Ty_var v2) \<sigma>'"
| same_fun: "
    f = f \<Longrightarrow>
    List.length l1 = List.length l2 \<Longrightarrow>
    unif_ty_list \<sigma> l1 l2 \<sigma>' \<Longrightarrow>
    unif_ty \<sigma> (Ty_app f l1) (Ty_app f l2) \<sigma>' "
| trivial_top: "unif_ty \<sigma> Ty_top Ty_top \<sigma>"
| cases: "
    unify_ty_row \<sigma> \<rho>1 ronly \<sigma>' \<Longrightarrow>
    unify_ty_row \<sigma>' \<rho>2 lonly \<sigma>'' \<Longrightarrow>
    split_cases l1 l2 = split_cases_rec\<lparr> left_only := lonly, right_only := ronly \<rparr> \<Longrightarrow>
    unify_ty \<sigma> (Ty_cases l1 \<rho>1) (Ty_cases l2 \<rho>2) \<sigma>'' "
| row_empty: "unify_ty_row \<sigma> None {} \<sigma>"
\<comment> \<open> TODO: introduce new row var? \<close>
| nil: "unif_ty_list \<sigma> [] [] \<sigma>"
| cons: "
    unif_ty \<sigma> x1 x2 \<sigma>' \<Longrightarrow>
    unif_ty_list \<sigma>' l1 l2 \<sigma>'' \<Longrightarrow>
    unif_ty_list \<sigma> (x1#l1) (x2#l2) \<sigma>''"

lemma test_unif1: "\<forall> ty. \<exists>\<sigma>. unif_ty subst_empty ty ty \<sigma>"
  nitpick

end


(*  Title:       Executable Transitive Closures of Finite Relations
    Author:      Christian Sternagel <c.sternagel@gmail.com>
                 René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and René Thiemann
    License:     LGPL
*)

section {* Closure Computation using Lists *}

theory Transitive_Closure_List_Impl
imports Transitive_Closure_Impl
begin

text \<open>
  We provide two algorithms for the computation of the reflexive transitive closure which internally
  work on lists. The first one (@{term rtrancl_list_impl}) computes the closure on demand for a
  given set of initial states. The second one (@{term memo_list_rtrancl}) precomputes the closure
  for each individual state, stores the result, and then only does a look-up.

  For the transitive closure there are the corresponding algorithms @{term trancl_list_impl} and
  @{term memo_list_trancl}.
\<close>

subsection \<open>Computing Closures from Sets On-The-Fly\<close>

text \<open>
  The algorithms are based on the generic algorithms @{const rtrancl_impl} and @{const trancl_impl}
  instantiated by list operations. Here, after computing the successors in a straightforward way,
  we use @{const remdups} to not have duplicates in the results. Moreover, also in the union
  operation we filter to those elements that have not yet been seen. The use of @{const filter} in
  the union operation is preferred over @{const remdups} since by construction the latter set will
  not contain duplicates.
\<close>

definition rtrancl_list_impl :: "('a \<times> 'a) list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "rtrancl_list_impl = rtrancl_impl
    (\<lambda> r as. remdups (map snd (filter (\<lambda> (a, b). a \<in> set as) r)))
    (\<lambda> xs ys. (filter (\<lambda> x. x \<notin> set ys) xs) @ ys)
    (\<lambda> x xs. x \<in> set xs)
    []"

definition trancl_list_impl :: "('a \<times> 'a) list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "trancl_list_impl = trancl_impl
    (\<lambda> r as. remdups (map snd (filter (\<lambda> (a, b). a \<in> set as) r)))
    (\<lambda> xs ys. (filter (\<lambda> x. x \<notin> set ys) xs) @ ys)
    (\<lambda> x xs. x \<in> set xs)
    []"

lemma rtrancl_list_impl:
  "set (rtrancl_list_impl r as) = {b. \<exists> a \<in> set as. (a, b) \<in> (set r)\<^sup>*}"
  unfolding rtrancl_list_impl_def
  by (rule set_access_gen.rtrancl_impl, unfold_locales, force+)

lemma trancl_list_impl:
  "set (trancl_list_impl r as) = {b. \<exists> a \<in> set as. (a, b) \<in> (set r)\<^sup>+}"
  unfolding trancl_list_impl_def
  by (rule set_access_gen.trancl_impl, unfold_locales, force+)

subsection \<open>Precomputing Closures for Single States\<close>

text \<open>
  Storing all relevant entries is done by mapping all left-hand sides of the relation to their
  closure. To avoid redundant entries, @{const remdups} is used.
\<close>

definition memo_list_rtrancl :: "('a \<times> 'a) list \<Rightarrow> ('a \<Rightarrow> 'a list)"
where
  "memo_list_rtrancl r =
    (let
      tr = rtrancl_list_impl r;
      rm = map (\<lambda>a. (a, tr [a])) ((remdups \<circ> map fst) r)
    in
      (\<lambda>a. case map_of rm a of
        None \<Rightarrow> [a]
      | Some as \<Rightarrow> as))"

lemma memo_list_rtrancl:
  "set (memo_list_rtrancl r a) = {b. (a, b) \<in> (set r)\<^sup>*}" (is "?l = ?r")
proof -
  let ?rm = "map (\<lambda> a. (a, rtrancl_list_impl r [a])) ((remdups \<circ> map fst) r)"
  show ?thesis
  proof (cases "map_of ?rm a")
    case None
    have one: "?l = {a}"
      unfolding memo_list_rtrancl_def Let_def None
      by auto
    from None [unfolded map_of_eq_None_iff]
    have a: "a \<notin> fst ` set r" by force
    {
      fix b
      assume "b \<in> ?r"
      from this [unfolded rtrancl_power relpow_fun_conv] obtain n f where
        ab: "f 0 = a \<and> f n = b" and steps: "\<And> i. i < n \<Longrightarrow> (f i, f (Suc i)) \<in> set r" by auto
      from ab steps [of 0] a have "a = b"
        by (cases n, force+)
    }
    then have "?r = {a}" by auto
    then show ?thesis unfolding one by simp
  next
    case (Some as)
    have as: "set as = {b. (a, b) \<in> (set r)^*}"
      using map_of_SomeD [OF Some]
        rtrancl_list_impl [of r "[a]"] by force
    then show ?thesis unfolding memo_list_rtrancl_def Let_def Some by simp
  qed
qed

definition memo_list_trancl :: "('a \<times> 'a) list \<Rightarrow> ('a \<Rightarrow> 'a list)"
where
  "memo_list_trancl r =
    (let
      tr = trancl_list_impl r;
      rm = map (\<lambda>a. (a, tr [a])) ((remdups \<circ> map fst) r)
    in
      (\<lambda>a. case map_of rm a of
        None \<Rightarrow> []
      | Some as \<Rightarrow> as))"

lemma memo_list_trancl:
  "set (memo_list_trancl r a) = {b. (a, b) \<in> (set r)\<^sup>+}" (is "?l = ?r")
proof -
  let ?rm = "map (\<lambda> a. (a, trancl_list_impl r [a])) ((remdups \<circ> map fst) r)"
  show ?thesis
  proof (cases "map_of ?rm a")
    case None
    have one: "?l = {}"
      unfolding memo_list_trancl_def Let_def None
      by auto
    from None [unfolded map_of_eq_None_iff]
      have a: "a \<notin> fst ` set r" by force
    {
      fix b
      assume "b \<in> ?r"
      from this [unfolded trancl_unfold_left] a have False by force
    }
    then have "?r = {}" by auto
    then show ?thesis unfolding one by simp
  next
    case (Some as)
    have as: "set as = {b. (a, b) \<in> (set r)\<^sup>+}"
      using map_of_SomeD [OF Some]
        trancl_list_impl[of r "[a]"] by force
    then show ?thesis unfolding memo_list_trancl_def Let_def Some by simp
  qed
qed

end