theory PALandWiseMenPuzzle2021 imports Main    (* Sebastian Reiche and Christoph Benzmüller, 2021 *)

begin
 (* Parameter settings for Nitpick *) nitpick_params[user_axioms=true, format=4, show_all]

 typedecl i (* Type of possible worlds *)
 type_synonym \<sigma> = "i\<Rightarrow>bool" (* \<D> *)
 type_synonym \<tau> = "\<sigma>\<Rightarrow>i\<Rightarrow>bool" (* Type of world depended formulas (truth sets) *)
 type_synonym \<alpha> = "i\<Rightarrow>i\<Rightarrow>bool" (* Type of accessibility relations between world *)

 (* Some useful relations (for constraining accessibility relations) *)
 definition reflexive::"\<alpha>\<Rightarrow>bool" where "reflexive R \<equiv> \<forall>x. R x x"
 definition symmetric::"\<alpha>\<Rightarrow>bool" where "symmetric R \<equiv> \<forall>x y. R x y \<longrightarrow> R y x"
 definition transitive::"\<alpha>\<Rightarrow>bool" where "transitive R \<equiv> \<forall>x y z. R x y \<and> R y z \<longrightarrow> R x z"
 definition euclidean::"\<alpha>\<Rightarrow>bool" where "euclidean R \<equiv> \<forall>x y z. R x y \<and> R x z \<longrightarrow> R y z"
 definition intersection_rel::"\<alpha>\<Rightarrow>\<alpha>\<Rightarrow>\<alpha>" where "intersection_rel R Q \<equiv> \<lambda>u v. R u v \<and> Q u v"
 definition union_rel::"\<alpha>\<Rightarrow>\<alpha>\<Rightarrow>\<alpha>" where "union_rel R Q \<equiv> \<lambda>u v. R u v \<or> Q u v"
 definition sub_rel::"\<alpha>\<Rightarrow>\<alpha>\<Rightarrow>bool" where "sub_rel R Q \<equiv> \<forall>u v. R u v \<longrightarrow> Q u v"
 definition inverse_rel::"\<alpha>\<Rightarrow>\<alpha>" where "inverse_rel R \<equiv> \<lambda>u v. R v u"
 definition bigunion_rel::"(\<alpha>\<Rightarrow>bool)\<Rightarrow>\<alpha>" ("\<^bold>\<Union>_") where "\<^bold>\<Union> X \<equiv> \<lambda>u v. \<exists>R. (X R) \<and> (R u v)"
 definition bigintersection_rel::"(\<alpha>\<Rightarrow>bool)\<Rightarrow>\<alpha>" ("\<^bold>\<Inter>_") where "\<^bold>\<Inter> X \<equiv> \<lambda>u v. \<forall>R. (X R) \<longrightarrow> (R u v)"

 (*In HOL the transitive closure of a relation can be defined in a single line.*)
 definition tc::"\<alpha>\<Rightarrow>\<alpha>" where "tc R \<equiv> \<lambda>x y.\<forall>Q. transitive Q \<longrightarrow> (sub_rel R Q \<longrightarrow> Q x y)"

 (* Lifted HOMML connectives for PAL *)
 abbreviation patom::"\<sigma>\<Rightarrow>\<tau>" ("\<^sup>A_"[79]80) where "\<^sup>Ap \<equiv> \<lambda>W w. W w \<and> p w"
 abbreviation ptop::"\<tau>" ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>W w. True"
 abbreviation pneg::"\<tau>\<Rightarrow>\<tau>" ("\<^bold>\<not>_"[52]53) where "\<^bold>\<not>\<phi> \<equiv> \<lambda>W w. \<not>(\<phi> W w)"
 abbreviation pand::"\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" (infixr"\<^bold>\<and>"51) where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>W w. (\<phi> W w) \<and> (\<psi> W w)"
 abbreviation por::"\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" (infixr"\<^bold>\<or>"50) where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>W w. (\<phi> W w) \<or> (\<psi> W w)"
 abbreviation pimp::"\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" (infixr"\<^bold>\<rightarrow>"49) where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>W w. (\<phi> W w) \<longrightarrow> (\<psi> W w)"
 abbreviation pequ::"\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" (infixr"\<^bold>\<leftrightarrow>"48) where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>W w. (\<phi> W w) \<longleftrightarrow> (\<psi> W w)"
 abbreviation pknow::"\<alpha>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("\<^bold>K_ _") where "\<^bold>K r \<phi> \<equiv> \<lambda>W w.\<forall>v. (W v \<and> r w v) \<longrightarrow> (\<phi> W v)"
 abbreviation ppal::"\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("\<^bold>[\<^bold>!_\<^bold>]_") where "\<^bold>[\<^bold>!\<phi>\<^bold>]\<psi> \<equiv> \<lambda>W w. (\<phi> W w) \<longrightarrow> (\<psi> (\<lambda>z. W z \<and> \<phi> W z) w)"

 (* Agents *)
 consts a::"\<alpha>" b::"\<alpha>" c::"\<alpha>" (* Agents modeled as accessibility relations *)

 abbreviation  Agent::"\<alpha>\<Rightarrow>bool" ("\<A>") where "\<A> x \<equiv> x = a \<or> x = b \<or> x = c"
 (* alternatively, use set notation
 abbreviation  Agent::"\<alpha>\<Rightarrow>bool" ("\<A>") where "\<A> x \<equiv> x \<in> {a, b, c}" *)

 abbreviation EVR::"\<alpha>" ("EVR") where "EVR \<equiv> \<^bold>\<Union> \<A>"
 abbreviation DIS :: "\<alpha>" ("DIS") where "DIS \<equiv> \<^bold>\<Inter> \<A>"

 abbreviation prck::"\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("\<^bold>C\<^bold>\<lparr>_\<^bold>|_\<^bold>\<rparr>")
   where "\<^bold>C\<^bold>\<lparr>\<phi>\<^bold>|\<psi>\<^bold>\<rparr> \<equiv> \<lambda>W w. \<forall>v. \<not>(tc (intersection_rel EVR (\<lambda>u v. W v \<and> \<phi> W v)) w v) \<or> (\<psi> W v)"

 axiomatization where  group_S5: "\<forall>i. \<A> i \<longrightarrow> (reflexive i \<and> transitive i \<and> euclidean i)"
 (* alldifferent doesn't seem to be neccessary
   and  alldifferent:  "\<not>(a = b) \<and> \<not>(a = c) \<and> \<not>(b = c)" *)

 (* Validity of \<tau>-type lifted PAL formulas *)
 abbreviation pvalid::"\<tau> \<Rightarrow> bool" ("\<^bold>\<lfloor>_\<^bold>\<rfloor>"[7]8) where "\<^bold>\<lfloor>\<phi>\<^bold>\<rfloor> \<equiv> \<forall>W.\<forall>w. W w \<longrightarrow> \<phi> W w"

 (* Agent Knowledge, Mutual Knowledge, Common Knowledge *)
 abbreviation agttknows::"\<alpha>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("\<^bold>K\<^sub>_ _") where "\<^bold>K\<^sub>r \<phi> \<equiv>  \<^bold>K r \<phi>"
 abbreviation evrknows::"\<tau>\<Rightarrow>\<tau>" ("\<^bold>E\<^sub>\<A> _") where "\<^bold>E\<^sub>\<A> \<phi> \<equiv>  \<^bold>K EVR \<phi>"
 abbreviation pcmn::"\<tau>\<Rightarrow>\<tau>" ("\<^bold>C\<^sub>\<A> _") where "\<^bold>C\<^sub>\<A> \<phi> \<equiv>  \<^bold>C\<^bold>\<lparr>\<^bold>\<top>\<^bold>|\<phi>\<^bold>\<rparr>"
 abbreviation disknows :: "\<tau>\<Rightarrow>\<tau>" ("\<^bold>D\<^sub>\<A> _") where "\<^bold>D\<^sub>\<A> \<phi> \<equiv> \<^bold>K DIS \<phi>"

 (* Introducing "Defs" as the set of the above definitions; useful for convenient unfolding *)
 named_theorems Defs
 declare reflexive_def[Defs] symmetric_def[Defs] transitive_def[Defs] euclidean_def[Defs]
   intersection_rel_def[Defs] union_rel_def[Defs] sub_rel_def[Defs] inverse_rel_def[Defs]
   bigunion_rel_def[Defs] tc_def[Defs]

 (***********************************************************************************************)
 (*****                         Experiments and Wise Men Puzzle                             *****)
 (***********************************************************************************************)
 (* correctness of big union / intersection operator
 abbreviation EVR_old::"\<alpha>" ("EVR_old") where "EVR_old \<equiv> union_rel (union_rel a b) c"
 abbreviation DIS_old::"\<alpha>" ("DIS_old") where "DIS_old \<equiv> intersection_rel (intersection_rel a b) c"
 lemma same_relation_evr: "EVR \<equiv> EVR_old" unfolding Defs sledgehammer nitpick oops
 -- "vampire": One-line proof reconstruction failed: by metis )
 lemma same_relation_dis: "DIS \<equiv> DIS_old" unfolding Defs sledgehammer nitpick oops
 -- "vampire": One-line proof reconstruction failed: by (metis bigintersection_rel_def) *)

 (*Some useful lemmata *)
 lemma trans_tc: "transitive (tc R)" unfolding Defs tc_def by metis
 lemma trans_inv_tc: "transitive (inverse_rel (tc R))" unfolding Defs tc_def by metis
 lemma sub_rel_tc: "symmetric R \<longrightarrow> (sub_rel R (inverse_rel (tc R)))" unfolding Defs tc_def by smt
 lemma sub_rel_tc_tc: "symmetric R \<longrightarrow> (sub_rel (tc R) (inverse_rel (tc R)))"
   using sub_rel_def sub_rel_tc tc_def trans_inv_tc by fastforce
 lemma symm_tc: "symmetric R \<longrightarrow> symmetric (tc R)"
   using inverse_rel_def sub_rel_def sub_rel_tc_tc symmetric_def by auto

 (* System K: is implied by the semantical embedding *)
 lemma tautologies: "\<^bold>\<lfloor>\<^bold>\<top>\<^bold>\<rfloor>" by auto
 lemma axiom_K: "\<A> i \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>K\<^sub>i (\<phi> \<^bold>\<rightarrow> \<psi>)) \<^bold>\<rightarrow> ((\<^bold>K\<^sub>i \<phi>) \<^bold>\<rightarrow> (\<^bold>K\<^sub>i \<psi>))\<^bold>\<rfloor>" by auto
 lemma modusponens: assumes 1: "\<^bold>\<lfloor>\<phi> \<^bold>\<rightarrow> \<psi>\<^bold>\<rfloor>" and 2: "\<^bold>\<lfloor>\<phi>\<^bold>\<rfloor>" shows "\<^bold>\<lfloor>\<psi>\<^bold>\<rfloor>" using 1 2 by auto
 lemma necessitation: assumes 1: "\<^bold>\<lfloor>\<phi>\<^bold>\<rfloor>" shows "\<A> i \<Longrightarrow> \<^bold>\<lfloor>\<^bold>K\<^sub>i \<phi>\<^bold>\<rfloor>" using 1 by auto
 (* More axioms: implied by the semantical embedding  *)
 lemma axiom_T: "\<A> i \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>K\<^sub>i \<phi>) \<^bold>\<rightarrow> \<phi>\<^bold>\<rfloor>" using group_S5 reflexive_def by blast
 lemma axiom_4: "\<A> i \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>K\<^sub>i \<phi>) \<^bold>\<rightarrow> (\<^bold>K\<^sub>i (\<^bold>K\<^sub>i \<phi>))\<^bold>\<rfloor>" by (meson group_S5 transitive_def)
 lemma axiom_5: "\<A> i \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>\<not>\<^bold>K\<^sub>i \<phi>) \<^bold>\<rightarrow> (\<^bold>K\<^sub>i (\<^bold>\<not>\<^bold>K\<^sub>i \<phi>))\<^bold>\<rfloor>" by (metis euclidean_def group_S5)
 (*Reduction axioms: implied by the semantical embedding *)
 lemma atomic_permanence: "\<^bold>\<lfloor>(\<^bold>[\<^bold>!\<phi>\<^bold>]\<^sup>Ap) \<^bold>\<leftrightarrow> (\<phi> \<^bold>\<rightarrow> \<^sup>Ap)\<^bold>\<rfloor>" by auto
 lemma conjunction: "\<^bold>\<lfloor>(\<^bold>[\<^bold>!\<phi>\<^bold>](\<psi> \<^bold>\<and> \<chi>)) \<^bold>\<rightarrow> ((\<^bold>[\<^bold>!\<phi>\<^bold>]\<psi>) \<^bold>\<and> (\<^bold>[\<^bold>!\<phi>\<^bold>]\<chi>))\<^bold>\<rfloor>" by auto
 lemma part_func: "\<^bold>\<lfloor>(\<^bold>[\<^bold>!\<phi>\<^bold>]\<^bold>\<not>\<psi>) \<^bold>\<leftrightarrow> (\<phi> \<^bold>\<rightarrow> (\<^bold>\<not>\<^bold>[\<^bold>!\<phi>\<^bold>]\<psi>))\<^bold>\<rfloor>" by auto
 lemma action_knowledge: "\<A> i \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>[\<^bold>!\<phi>\<^bold>](\<^bold>K\<^sub>i \<psi>)) \<^bold>\<leftrightarrow> (\<phi> \<^bold>\<rightarrow> (\<^bold>K\<^sub>i (\<phi> \<^bold>\<rightarrow> (\<^bold>[\<^bold>!\<phi>\<^bold>]\<psi>))))\<^bold>\<rfloor>" by auto
 lemma "\<^bold>\<lfloor>(\<^bold>[\<^bold>!\<phi>\<^bold>](\<^bold>C\<^bold>\<lparr>\<chi>\<^bold>|\<psi>\<^bold>\<rparr>)) \<^bold>\<leftrightarrow> (\<phi> \<^bold>\<rightarrow> (\<^bold>C\<^bold>\<lparr>\<phi>\<^bold>\<and>(\<^bold>[\<^bold>!\<phi>\<^bold>]\<chi>)\<^bold>|\<^bold>[\<^bold>!\<phi>\<^bold>]\<psi>\<^bold>\<rparr>))\<^bold>\<rfloor>"
   by (smt intersection_rel_def sub_rel_def tc_def transitive_def)

 declare [[smt_solver=cvc4,smt_oracle]]

 (* Axiom schemes for RCK: implied by the semantical embedding *)
 lemma \<C>_normality: "\<^bold>\<lfloor>\<^bold>C\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rightarrow>\<psi>\<^bold>\<rparr> \<^bold>\<rightarrow>(\<^bold>C\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr> \<^bold>\<rightarrow> \<^bold>C\<^bold>\<lparr>\<chi>\<^bold>|\<psi>\<^bold>\<rparr>)\<^bold>\<rfloor>" unfolding Defs by blast
 lemma mix_axiom1: "\<^bold>\<lfloor>\<^bold>C\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr> \<^bold>\<rightarrow> (\<^bold>E\<^sub>\<A> (\<chi> \<^bold>\<rightarrow> (\<phi> \<^bold>\<and> \<^bold>C\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>)))\<^bold>\<rfloor>" unfolding Defs by smt
 lemma mix_axiom2: "\<^bold>\<lfloor>(\<^bold>E\<^sub>\<A> (\<chi> \<^bold>\<rightarrow> (\<phi> \<^bold>\<and> \<^bold>C\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>))) \<^bold>\<rightarrow> \<^bold>C\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>\<^bold>\<rfloor>" unfolding Defs (* timeout *) sorry
 lemma induction_axiom: "\<^bold>\<lfloor>((\<^bold>E\<^sub>\<A> (\<chi> \<^bold>\<rightarrow> \<phi>)) \<^bold>\<and> \<^bold>C\<^bold>\<lparr>\<chi>\<^bold>|\<phi> \<^bold>\<rightarrow> (\<^bold>E\<^sub>\<A> (\<chi> \<^bold>\<rightarrow> \<phi>))\<^bold>\<rparr>) \<^bold>\<rightarrow> \<^bold>C\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>\<^bold>\<rfloor>"
   unfolding Defs (* timeout *) sorry

 (* Necessitation rules: implied by the semantical embedding *)
 lemma announcement_nec: assumes "\<^bold>\<lfloor>\<phi>\<^bold>\<rfloor>" shows "\<^bold>\<lfloor>\<^bold>[\<^bold>!\<psi>\<^bold>]\<phi>\<^bold>\<rfloor>" by (simp add: assms)
 lemma rkc_necessitation: assumes "\<^bold>\<lfloor>\<phi>\<^bold>\<rfloor>" shows "\<^bold>\<lfloor>\<^bold>C\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>\<^bold>\<rfloor>"
   by (smt assms intersection_rel_def sub_rel_def tc_def transitive_def)

 (* Axiom schemes for Distributed Knowledge: implied by the semantical embedding *)
 lemma System_W: "\<A> i \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>K\<^sub>i \<phi>) \<^bold>\<rightarrow> (\<^bold>D\<^sub>\<A> \<phi>)\<^bold>\<rfloor>" using bigintersection_rel_def by auto
 lemma System_K\<^sub>D: "\<^bold>\<lfloor>(\<^bold>D\<^sub>\<A> (\<phi> \<^bold>\<rightarrow> \<psi>)) \<^bold>\<rightarrow> ((\<^bold>D\<^sub>\<A> \<phi>) \<^bold>\<rightarrow> (\<^bold>D\<^sub>\<A> \<psi>))\<^bold>\<rfloor>" by blast
 lemma System_T\<^sub>D: "\<^bold>\<lfloor>(\<^bold>D\<^sub>\<A> \<phi>) \<^bold>\<rightarrow> \<phi>\<^bold>\<rfloor>" using bigintersection_rel_def group_S5 reflexive_def by auto
 lemma System_4\<^sub>D: "\<^bold>\<lfloor>(\<^bold>D\<^sub>\<A> \<phi>) \<^bold>\<rightarrow> (\<^bold>D\<^sub>\<A> (\<^bold>D\<^sub>\<A> \<phi>))\<^bold>\<rfloor>" by (smt bigintersection_rel_def group_S5 transitive_def)
 lemma System_5\<^sub>D: "\<^bold>\<lfloor>(\<^bold>\<not>\<^bold>D\<^sub>\<A> \<phi>) \<^bold>\<rightarrow> (\<^bold>D\<^sub>\<A> (\<^bold>\<not>\<^bold>D\<^sub>\<A> \<phi>))\<^bold>\<rfloor>"
   by (smt bigintersection_rel_def euclidean_def group_S5)

 (* Further axioms: implied for atomic formulas, but not implied in general *)
 lemma "\<^bold>\<lfloor>\<^sup>Ap \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<^sup>Ap\<^bold>](\<^bold>\<not>\<^sup>Ap)\<^bold>\<rfloor>" by simp
 lemma "\<^bold>\<lfloor>\<phi> \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<phi>\<^bold>](\<^bold>\<not>\<phi>)\<^bold>\<rfloor>" nitpick oops (* countermodel found *)
 lemma "\<^bold>\<lfloor>\<^sup>Ap \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<^sup>Ap\<^bold>](\<^bold>\<not>\<^bold>K\<^sub>a \<^sup>Ap)\<^bold>\<rfloor>" by simp
 lemma "\<^bold>\<lfloor>\<phi> \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<phi>\<^bold>](\<^bold>\<not>\<^bold>K\<^sub>a \<phi>)\<^bold>\<rfloor>" nitpick oops (* countermodel found *)
 lemma "\<^bold>\<lfloor>\<^sup>Ap \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<^sup>Ap\<^bold>](\<^sup>Ap \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>a \<^sup>Ap)\<^bold>\<rfloor>" by simp
 lemma "\<^bold>\<lfloor>\<phi> \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<phi>\<^bold>](\<phi> \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>a \<phi>)\<^bold>\<rfloor>" nitpick oops (* countermodel found *)
 lemma "\<^bold>\<lfloor>(\<^sup>Ap \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>a \<^sup>Ap) \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<^sup>Ap \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>a \<^sup>Ap\<^bold>](\<^sup>Ap \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>a \<^sup>Ap)\<^bold>\<rfloor>" by blast
 lemma "\<^bold>\<lfloor>(\<phi> \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>a \<phi>) \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<phi> \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>a \<phi>\<^bold>](\<phi> \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>a \<phi>)\<^bold>\<rfloor>" nitpick oops (* countermodel found *)
 lemma "\<^bold>\<lfloor>(\<^bold>K\<^sub>a \<^sup>Ap) \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<^sup>Ap\<^bold>](\<^bold>\<not>\<^bold>K\<^sub>a \<^sup>Ap)\<^bold>\<rfloor>" using group_S5 reflexive_def by auto
 lemma "\<^bold>\<lfloor>(\<^bold>K\<^sub>a \<phi>) \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<phi>\<^bold>](\<^bold>\<not>\<^bold>K\<^sub>a \<phi>)\<^bold>\<rfloor>" nitpick oops (* countermodel found *)
 lemma "\<^bold>\<lfloor>(\<^bold>K\<^sub>a \<^sup>Ap) \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<^sup>Ap\<^bold>](\<^sup>Ap \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>a \<^sup>Ap)\<^bold>\<rfloor>" using group_S5 reflexive_def by auto
 lemma "\<^bold>\<lfloor>(\<^bold>K\<^sub>a \<phi>) \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<phi>\<^bold>](\<phi> \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>a \<phi>)\<^bold>\<rfloor>" nitpick oops (* countermodel found *)

 (*** Encoding of the wise men puzzle in PAL ***)
 (* Choose CVC4 as smt solver *)  declare [[smt_solver=cvc4,smt_oracle,smt_timeout=1200]]
 (* Common knowledge: At least one of a, b and c has a white spot *)
 consts ws::"\<alpha>\<Rightarrow>\<sigma>"
 axiomatization where WM1: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^sup>Aws a \<^bold>\<or> \<^sup>Aws b \<^bold>\<or> \<^sup>Aws c)\<^bold>\<rfloor>"

 axiomatization where
   (* Common knowledge: If x does not have a white spot then y know this *)
   WM2ab: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws a) \<^bold>\<rightarrow> (\<^bold>K\<^sub>b (\<^bold>\<not>(\<^sup>Aws a))))\<^bold>\<rfloor>" and
   WM2ac: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws a) \<^bold>\<rightarrow> (\<^bold>K\<^sub>c (\<^bold>\<not>(\<^sup>Aws a))))\<^bold>\<rfloor>" and
   WM2ba: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws b) \<^bold>\<rightarrow> (\<^bold>K\<^sub>a (\<^bold>\<not>(\<^sup>Aws b))))\<^bold>\<rfloor>" and
   WM2bc: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws b) \<^bold>\<rightarrow> (\<^bold>K\<^sub>c (\<^bold>\<not>(\<^sup>Aws b))))\<^bold>\<rfloor>" and
   WM2ca: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws c) \<^bold>\<rightarrow> (\<^bold>K\<^sub>a (\<^bold>\<not>(\<^sup>Aws c))))\<^bold>\<rfloor>" and
   WM2cb: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws c) \<^bold>\<rightarrow> (\<^bold>K\<^sub>b (\<^bold>\<not>(\<^sup>Aws c))))\<^bold>\<rfloor>"

 (* Positive introspection principles are implied *)
 lemma WM2ab': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws a) \<^bold>\<rightarrow> (\<^bold>K\<^sub>b (\<^sup>Aws a)))\<^bold>\<rfloor>" using WM2ab group_S5 unfolding Defs by metis
 lemma WM2ac': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws a) \<^bold>\<rightarrow> (\<^bold>K\<^sub>c (\<^sup>Aws a)))\<^bold>\<rfloor>" using WM2ac group_S5 unfolding Defs by metis
 lemma WM2ba': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws b) \<^bold>\<rightarrow> (\<^bold>K\<^sub>a (\<^sup>Aws b)))\<^bold>\<rfloor>" using WM2ba group_S5 unfolding Defs by metis
 lemma WM2bc': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws b) \<^bold>\<rightarrow> (\<^bold>K\<^sub>c (\<^sup>Aws b)))\<^bold>\<rfloor>" using WM2bc group_S5 unfolding Defs by metis
 lemma WM2ca': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws c) \<^bold>\<rightarrow> (\<^bold>K\<^sub>a (\<^sup>Aws c)))\<^bold>\<rfloor>" using WM2ca group_S5 unfolding Defs by metis
 lemma WM2cb': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws c) \<^bold>\<rightarrow> (\<^bold>K\<^sub>b (\<^sup>Aws c)))\<^bold>\<rfloor>" using WM2cb group_S5 unfolding Defs by metis

 (* Automated solutions of the Wise Men Puzzle *)
 theorem whitespot_c:
     "\<^bold>\<lfloor>\<^bold>[\<^bold>!\<^bold>\<not>((\<^bold>K\<^sub>a (\<^sup>Aws a)) \<^bold>\<or> (\<^bold>K\<^sub>a (\<^bold>\<not>\<^sup>Aws a)))\<^bold>](\<^bold>[\<^bold>!\<^bold>\<not>((\<^bold>K\<^sub>b (\<^sup>Aws b)) \<^bold>\<or> (\<^bold>K\<^sub>b (\<^bold>\<not>\<^sup>Aws b)))\<^bold>](\<^bold>K\<^sub>c (\<^sup>Aws c)))\<^bold>\<rfloor>"
   using WM1 WM2ba WM2ca WM2cb unfolding Defs by (smt (verit))

 theorem "\<^bold>\<lfloor>\<^bold>[\<^bold>!\<^bold>\<not>\<^bold>K\<^sub>a(\<^sup>Aws a)\<^bold>](\<^bold>[\<^bold>!\<^bold>\<not>\<^bold>K\<^sub>b(\<^sup>Aws b)\<^bold>](\<^bold>K\<^sub>c (\<^sup>Aws c)))\<^bold>\<rfloor>"
   using WM1 WM2ba WM2ca WM2cb unfolding Defs by (smt (verit))

 (* Consistency confirmed by nitpick *)
 lemma True nitpick [satisfy] oops  (* model found *)

end


section \<open>Counting Irreducible Polynomials \label{sec:card_irred}\<close>

subsection \<open>The polynomial $X^n - X$\<close>

theory Card_Irreducible_Polynomials_Aux
imports
  "HOL-Algebra.Multiplicative_Group"
  Formal_Polynomial_Derivatives
  Monic_Polynomial_Factorization
begin

lemma (in domain)
  assumes "subfield K R"
  assumes "f \<in> carrier (K[X])" "degree f > 0"
  shows embed_inj: "inj_on (rupture_surj K f \<circ> poly_of_const) K"
    and rupture_order: "order (Rupt K f) = card K^degree f"
    and rupture_char: "char (Rupt K f) = char R"
proof -
  interpret p: principal_domain "K[X]"
    using univ_poly_is_principal[OF assms(1)] by simp

  interpret I: ideal "PIdl\<^bsub>K[X]\<^esub> f" "K[X]"
    using p.cgenideal_ideal[OF assms(2)] by simp

  interpret d: ring "Rupt K f"
    unfolding rupture_def using I.quotient_is_ring by simp

  have e: "subring K R"
    using assms(1) subfieldE(1) by auto

  interpret h:
    ring_hom_ring "R \<lparr> carrier := K \<rparr>"
      "Rupt K f" "rupture_surj K f \<circ> poly_of_const"
    using rupture_surj_norm_is_hom[OF e assms(2)]
    using ring_hom_ringI2 subring_is_ring d.ring_axioms e
    by blast

  have "field (R \<lparr>carrier := K\<rparr>)"
    using assms(1) subfield_iff(2) by simp
  hence "subfield K (R\<lparr>carrier := K\<rparr>)"
    using ring.subfield_iff[OF subring_is_ring[OF e]] by simp
  hence b: "subfield (rupture_surj K f ` poly_of_const ` K) (Rupt K f)"
    unfolding image_image comp_def[symmetric]
    by (intro h.img_is_subfield rupture_one_not_zero assms, simp)

  have "inj_on poly_of_const K"
    using poly_of_const_inj inj_on_subset by auto
  moreover have
    "poly_of_const ` K \<subseteq> ((\<lambda>q. q pmod f) ` carrier (K [X]))"
  proof (rule image_subsetI)
    fix x assume "x \<in> K"
    hence f:
      "poly_of_const x \<in> carrier (K[X])"
      "degree (poly_of_const x) = 0"
      using poly_of_const_over_subfield[OF assms(1)] by auto
    moreover
    have "degree (poly_of_const x) < degree f"
      using f(2) assms by simp
    hence "poly_of_const x pmod f = poly_of_const x"
      by (intro pmod_const(2)[OF assms(1)] f assms(2), simp)
    ultimately show
      "poly_of_const x \<in> ((\<lambda>q. q pmod f) ` carrier (K [X]))"
      by force
  qed
  hence "inj_on (rupture_surj K f) (poly_of_const ` K)"
    using rupture_surj_inj_on[OF assms(1,2)] inj_on_subset by blast
  ultimately show d: "inj_on (rupture_surj K f \<circ> poly_of_const) K"
    using comp_inj_on by auto

  have a: "d.dimension (degree f) (rupture_surj K f ` poly_of_const ` K)
    (carrier (Rupt K f))"
    using rupture_dimension[OF assms(1-3)] by auto
  then obtain base where base_def:
    "set base \<subseteq> carrier (Rupt K f)"
    "d.independent (rupture_surj K f ` poly_of_const ` K) base"
    "length base = degree f"
    "d.Span (rupture_surj K f ` poly_of_const ` K) base =
      carrier (Rupt K f)"
    using d.exists_base[OF b a] by auto
  have "order (Rupt K f) =
    card (d.Span (rupture_surj K f ` poly_of_const ` K) base)"
    unfolding order_def base_def(4) by simp
  also have "... =
    card (rupture_surj K f ` poly_of_const ` K) ^ length base"
    using d.card_span[OF b base_def(2,1)] by simp
  also have "...
    = card ((rupture_surj K f \<circ> poly_of_const) ` K) ^ degree f"
    using base_def(3) image_image unfolding comp_def by metis
  also have "... = card K^degree f"
    by (subst card_image[OF d], simp)
  finally show "order (Rupt K f) = card K^degree f" by simp

  have "char (Rupt K f) = char (R \<lparr> carrier := K \<rparr>)"
    using h.char_consistent d by simp
  also have "... = char R"
    using char_consistent[OF subfieldE(1)[OF assms(1)]] by simp
  finally show "char (Rupt K f) = char R" by simp
qed

definition gauss_poly where
  "gauss_poly K n = X\<^bsub>K\<^esub> [^]\<^bsub>poly_ring K\<^esub> (n::nat) \<ominus>\<^bsub>poly_ring K\<^esub> X\<^bsub>K\<^esub>"

context field
begin

interpretation polynomial_ring "R" "carrier R"
  unfolding polynomial_ring_def polynomial_ring_axioms_def
  using field_axioms carrier_is_subfield by simp

text \<open>The following lemma can be found in Ireland and Rosen~\<^cite>\<open>\<open>\textsection 7.1, Lemma 2\<close> in "ireland1982"\<close>.\<close>

lemma gauss_poly_div_gauss_poly_iff_1:
  fixes l m :: nat
  assumes "l > 0"
  shows "(X [^]\<^bsub>P\<^esub> l \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) pdivides (X [^]\<^bsub>P\<^esub> m \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) \<longleftrightarrow> l dvd m"
    (is "?lhs \<longleftrightarrow> ?rhs")
proof -
  define q where "q = m div l"
  define r where "r = m mod l"
  have m_def: "m = q * l + r" and r_range: "r < l"
    using assms by (auto simp add:q_def r_def)

  have pow_sum_carr:"(\<Oplus>\<^bsub>P\<^esub>i\<in>{..<q}. (X [^]\<^bsub>P\<^esub> l)[^]\<^bsub>P\<^esub> i) \<in> carrier P"
    using var_pow_closed
    by (intro p.finsum_closed, simp)

  have "(X [^]\<^bsub>P\<^esub> (q*l) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) = ((X [^]\<^bsub>P\<^esub> l)[^]\<^bsub>P\<^esub> q) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>"
    using var_closed
    by (subst p.nat_pow_pow, simp_all add:algebra_simps)
  also have "... =
    (X [^]\<^bsub>P\<^esub> l \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) \<otimes>\<^bsub>P\<^esub> (\<Oplus>\<^bsub>P\<^esub>i\<in>{..<q}. (X [^]\<^bsub>P\<^esub> l) [^]\<^bsub>P\<^esub> i)"
    using var_pow_closed
    by (subst p.geom[symmetric], simp_all)
  finally have pow_sum_fact: "(X [^]\<^bsub>P\<^esub> (q*l) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) =
    (X [^]\<^bsub>P\<^esub> l \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) \<otimes>\<^bsub>P\<^esub> (\<Oplus>\<^bsub>P\<^esub>i\<in>{..<q}. (X\<^bsub>R\<^esub> [^]\<^bsub>P\<^esub> l) [^]\<^bsub>P\<^esub> i)"
    by simp

  have "(X [^]\<^bsub>P\<^esub> l \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) divides\<^bsub>P\<^esub> (X [^]\<^bsub>P\<^esub> (q*l) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>)"
    by (rule dividesI[OF pow_sum_carr pow_sum_fact])

  hence c:"(X [^]\<^bsub>P\<^esub> l \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) divides\<^bsub>P\<^esub> X [^]\<^bsub>P\<^esub> r \<otimes>\<^bsub>P\<^esub> (X [^]\<^bsub>P\<^esub> (q * l) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>)"
    using var_pow_closed
    by (intro p.divides_prod_l, auto)

  have "(X [^]\<^bsub>P\<^esub> m \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) = X [^]\<^bsub>P\<^esub> (r + q * l) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>"
    unfolding m_def using add.commute by metis
  also have "... = (X [^]\<^bsub>P\<^esub> r) \<otimes>\<^bsub>P\<^esub> (X [^]\<^bsub>P\<^esub> (q*l)) \<oplus>\<^bsub>P\<^esub> (\<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>)"
    using var_closed
    by (subst p.nat_pow_mult, auto simp add:a_minus_def)
  also have "... = ((X [^]\<^bsub>P\<^esub> r) \<otimes>\<^bsub>P\<^esub> (X [^]\<^bsub>P\<^esub> (q*l) \<oplus>\<^bsub>P\<^esub> (\<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>))
    \<oplus>\<^bsub>P\<^esub> (X [^]\<^bsub>P\<^esub> r)) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>"
    using var_pow_closed
    by algebra
  also have "... = (X [^]\<^bsub>P\<^esub> r) \<otimes>\<^bsub>P\<^esub> (X [^]\<^bsub>P\<^esub> (q*l) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>)
    \<oplus>\<^bsub>P\<^esub> (X [^]\<^bsub>P\<^esub> r) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>"
    by algebra
  also have "... = (X [^]\<^bsub>P\<^esub> r) \<otimes>\<^bsub>P\<^esub> (X [^]\<^bsub>P\<^esub> (q*l) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>)
    \<oplus>\<^bsub>P\<^esub> ((X [^]\<^bsub>P\<^esub> r) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>)"
    unfolding a_minus_def using var_pow_closed
    by (subst p.a_assoc, auto)
  finally have a:"(X [^]\<^bsub>P\<^esub> m \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) =
    (X [^]\<^bsub>P\<^esub> r) \<otimes>\<^bsub>P\<^esub> (X [^]\<^bsub>P\<^esub> (q*l) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) \<oplus>\<^bsub>P\<^esub> (X [^]\<^bsub>P\<^esub> r \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>)"
    (is "_ = ?x")
    by simp

  have xn_m_1_deg': "degree (X [^]\<^bsub>P\<^esub> n \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) = n"
    if "n > 0" for n :: nat
  proof -
    have "degree (X [^]\<^bsub>P\<^esub> n \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) = degree (X [^]\<^bsub>P\<^esub> n \<oplus>\<^bsub>P\<^esub> \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>)"
      by (simp add:a_minus_def)
    also have "... = max (degree (X [^]\<^bsub>P\<^esub> n)) (degree (\<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>))"
      using var_pow_closed var_pow_carr var_pow_degree
      using univ_poly_a_inv_degree degree_one that
      by (subst degree_add_distinct, auto)
    also have "... = n"
      using var_pow_degree degree_one univ_poly_a_inv_degree
      by simp
    finally show ?thesis by simp
  qed

  have xn_m_1_deg: "degree (X [^]\<^bsub>P\<^esub> n \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) = n" for n :: nat
  proof (cases "n > 0")
    case True
    then show ?thesis using xn_m_1_deg' by auto
  next
    case False
    hence "n = 0" by simp
    hence "degree (X [^]\<^bsub>P\<^esub> n \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) = degree (\<zero>\<^bsub>P\<^esub>)"
      by (intro arg_cong[where f="degree"], simp)
    then show ?thesis using False by (simp add:univ_poly_zero)
  qed

  have b: "degree (X [^]\<^bsub>P\<^esub> l \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) > degree (X\<^bsub>R\<^esub> [^]\<^bsub>P\<^esub> r \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>)"
    using r_range unfolding xn_m_1_deg by simp

  have xn_m_1_carr: "X [^]\<^bsub>P\<^esub> n \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub> \<in> carrier P" for n :: nat
    unfolding a_minus_def
    by (intro p.a_closed var_pow_closed, simp)

  have "?lhs \<longleftrightarrow> (X [^]\<^bsub>P\<^esub> l \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) pdivides ?x"
    by (subst a, simp)
  also have "... \<longleftrightarrow> (X [^]\<^bsub>P\<^esub> l \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) pdivides (X [^]\<^bsub>P\<^esub> r \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>)"
    unfolding pdivides_def
    by (intro p.div_sum_iff c var_pow_closed
        xn_m_1_carr p.a_closed p.m_closed)
  also have "... \<longleftrightarrow> r = 0"
  proof (cases "r = 0")
    case True
    have "(X [^]\<^bsub>P\<^esub> l \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) pdivides \<zero>\<^bsub>P\<^esub>"
      unfolding univ_poly_zero
      by (intro pdivides_zero xn_m_1_carr)
    also have "... = (X [^]\<^bsub>P\<^esub> r \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>)"
      by (simp add:a_minus_def True) algebra
    finally show ?thesis using True by simp
  next
    case False
    hence "degree (X [^]\<^bsub>P\<^esub> r \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) > 0" using xn_m_1_deg by simp
    hence "X [^]\<^bsub>P\<^esub> r \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub> \<noteq> []" by auto
    hence "\<not>(X [^]\<^bsub>P\<^esub> l \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) pdivides (X [^]\<^bsub>P\<^esub> r \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>)"
      using pdivides_imp_degree_le b xn_m_1_carr
      by (metis le_antisym less_or_eq_imp_le nat_neq_iff)
    thus ?thesis using False by simp
  qed
  also have "... \<longleftrightarrow> l dvd m"
    unfolding m_def using r_range assms by auto
  finally show ?thesis
    by simp
qed

lemma gauss_poly_factor:
  assumes "n > 0"
  shows "gauss_poly R n = (X [^]\<^bsub>P\<^esub> (n-1) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) \<otimes>\<^bsub>P\<^esub> X" (is "_ = ?rhs")
proof -
  have a:"1 + (n - 1) = n"
    using assms by simp
  have "gauss_poly R n = X [^]\<^bsub>P\<^esub> (1+(n-1)) \<ominus>\<^bsub>P\<^esub> X"
    unfolding gauss_poly_def by (subst a, simp)
  also have "... = (X [^]\<^bsub>P\<^esub> (n-1)) \<otimes>\<^bsub>P\<^esub> X \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub> \<otimes>\<^bsub>P\<^esub> X"
    using var_closed by simp
  also have "... = ?rhs"
    unfolding a_minus_def using var_closed l_one
    by (subst p.l_distr, auto, algebra)
  finally show ?thesis by simp
qed

lemma var_neq_zero: "X \<noteq> \<zero>\<^bsub>P\<^esub>"
  by (simp add:var_def univ_poly_zero)

lemma var_pow_eq_one_iff: "X [^]\<^bsub>P\<^esub> k = \<one>\<^bsub>P\<^esub> \<longleftrightarrow> k = (0::nat)"
proof (cases "k=0")
  case True
  then show ?thesis using var_closed(1) by simp
next
  case False
  have "degree (X\<^bsub>R\<^esub> [^]\<^bsub>P\<^esub> k) = k "
    using var_pow_degree by simp
  also have "... \<noteq> degree (\<one>\<^bsub>P\<^esub>)" using False degree_one by simp
  finally have "degree (X\<^bsub>R\<^esub> [^]\<^bsub>P\<^esub> k) \<noteq> degree \<one>\<^bsub>P\<^esub>" by simp
  then show ?thesis by auto
qed

lemma gauss_poly_carr: "gauss_poly R n \<in> carrier P"
  using var_closed(1)
  unfolding gauss_poly_def by simp

lemma gauss_poly_degree:
  assumes "n > 1"
  shows "degree (gauss_poly R n) = n"
proof -
  have "degree (gauss_poly R n) = max n 1"
    unfolding gauss_poly_def a_minus_def
    using var_pow_carr var_carr degree_var
    using var_pow_degree univ_poly_a_inv_degree
    using assms by (subst degree_add_distinct, auto)
  also have "... = n" using assms by simp
  finally show ?thesis by simp
qed

lemma gauss_poly_not_zero:
  assumes "n > 1"
  shows "gauss_poly R n \<noteq> \<zero>\<^bsub>P\<^esub>"
proof -
  have "degree (gauss_poly R n) \<noteq> degree ( \<zero>\<^bsub>P\<^esub>)"
    using assms by (subst gauss_poly_degree, simp_all add:univ_poly_zero)
  thus ?thesis by auto
qed

lemma gauss_poly_monic:
  assumes "n > 1"
  shows "monic_poly R (gauss_poly R n)"
proof -
  have "monic_poly R (X [^]\<^bsub>P\<^esub> n)"
    by (intro monic_poly_pow monic_poly_var)
  moreover have "\<ominus>\<^bsub>P\<^esub> X \<in> carrier P"
    using var_closed by simp
  moreover have "degree (\<ominus>\<^bsub>P\<^esub> X) < degree (X [^]\<^bsub>P\<^esub> n)"
    using assms univ_poly_a_inv_degree var_closed
    using degree_var
    unfolding var_pow_degree by (simp)
  ultimately show ?thesis
    unfolding gauss_poly_def a_minus_def
    by (intro monic_poly_add_distinct, auto)
qed

lemma geom_nat:
  fixes q :: nat
  fixes x :: "_ :: {comm_ring,monoid_mult}"
  shows "(x-1) * (\<Sum>i \<in> {..<q}. x^i) = x^q-1"
  by (induction q, auto simp:algebra_simps)

text \<open>The following lemma can be found in Ireland and Rosen~\<^cite>\<open>\<open>\textsection 7.1, Lemma 3\<close> in "ireland1982"\<close>.\<close>

lemma gauss_poly_div_gauss_poly_iff_2:
  fixes a :: int
  fixes l m :: nat
  assumes "l > 0" "a > 1"
  shows "(a ^ l - 1) dvd (a ^ m - 1) \<longleftrightarrow> l dvd m"
    (is "?lhs \<longleftrightarrow> ?rhs")
proof -
  define q where "q = m div l"
  define r where "r = m mod l"
  have m_def: "m = q * l + r" and r_range: "r < l" "r \<ge> 0"
    using assms by (auto simp add:q_def r_def)

  have "a ^ (l * q) - 1 = (a ^ l) ^ q - 1"
    by (simp add: power_mult)
  also have "... = (a^l - 1) * (\<Sum>i \<in> {..<q}. (a^l)^i)"
    by (subst geom_nat[symmetric], simp)
  finally have "a ^ (l * q) - 1 = (a^l - 1) * (\<Sum>i \<in> {..<q}. (a^l)^i)"
    by simp
  hence c:"a ^ l - 1 dvd a^ r * (a ^ (q * l) - 1)" by (simp add:mult.commute)

  have "a ^ m - 1 = a ^ (r + q * l) - 1"
    unfolding m_def using add.commute by metis
  also have "... = (a ^ r) * (a ^ (q*l)) -1"
    by (simp add: power_add)
  also have "... = ((a ^ r) * (a ^ (q*l) -1)) + (a ^ r) - 1"
    by (simp add: right_diff_distrib)
  also have "... = (a ^ r) * (a ^ (q*l) - 1) + ((a ^ r) - 1)"
    by simp
  finally have a:
    "a ^ m - 1 = (a ^ r) * (a ^ (q*l) - 1) + ((a ^ r) - 1)"
    (is "_ = ?x")
    by simp

  have "?lhs \<longleftrightarrow> (a^l -1) dvd ?x"
    by (subst a, simp)
  also have "... \<longleftrightarrow> (a^l -1) dvd (a^r -1)"
    using c dvd_add_right_iff by auto
  also have "... \<longleftrightarrow> r = 0"
  proof
    assume "a ^ l - 1 dvd a ^ r - 1"
    hence "a ^ l - 1  \<le> a ^ r -1 \<or> r = 0 "
      using assms r_range zdvd_not_zless by force
    moreover have "a ^ r < a^l" using assms r_range by simp
    ultimately show "r= 0"by simp
  next
    assume "r = 0"
    thus "a ^ l - 1 dvd a ^ r - 1" by simp
  qed
  also have "... \<longleftrightarrow> l dvd m"
    using r_def by auto
  finally show ?thesis by simp
qed

lemma gauss_poly_div_gauss_poly_iff:
  assumes "m > 0" "n > 0" "a > 1"
  shows "gauss_poly R (a^n) pdivides\<^bsub>R\<^esub> gauss_poly R (a^m)
    \<longleftrightarrow> n dvd m" (is "?lhs=?rhs")
proof -
  have a:"a^m > 1" using assms one_less_power by blast
  hence a1: "a^m > 0" by linarith
  have b:"a^n > 1" using assms one_less_power by blast
  hence b1:"a^n > 0" by linarith

  have "?lhs \<longleftrightarrow>
    (X [^]\<^bsub>P\<^esub> (a^n-1) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) \<otimes>\<^bsub>P\<^esub> X pdivides
    (X [^]\<^bsub>P\<^esub> (a^m-1) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) \<otimes>\<^bsub>P\<^esub> X"
    using  gauss_poly_factor a1 b1 by simp
  also have "... \<longleftrightarrow>
    (X [^]\<^bsub>P\<^esub> (a^n-1) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>) pdivides
    (X [^]\<^bsub>P\<^esub> (a^m-1) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>)"
    using var_closed a b var_neq_zero
    by (subst pdivides_mult_r, simp_all add:var_pow_eq_one_iff)
  also have "... \<longleftrightarrow> a^n-1 dvd a^m-1"
    using b
    by (subst gauss_poly_div_gauss_poly_iff_1) simp_all
  also have "... \<longleftrightarrow> int (a^n-1) dvd int (a^m-1)"
    by (subst of_nat_dvd_iff, simp)
  also have "... \<longleftrightarrow> int a^n-1 dvd int a^m-1"
    using a b by (simp add:of_nat_diff)
  also have "... \<longleftrightarrow> n dvd m"
    using assms
    by (subst gauss_poly_div_gauss_poly_iff_2) simp_all
  finally show ?thesis by simp
qed

end

context finite_field
begin

interpretation polynomial_ring "R" "carrier R"
  unfolding polynomial_ring_def polynomial_ring_axioms_def
  using field_axioms carrier_is_subfield by simp

lemma div_gauss_poly_iff:
  assumes "n > 0"
  assumes "monic_irreducible_poly R f"
  shows "f pdivides\<^bsub>R\<^esub> gauss_poly R (order R^n) \<longleftrightarrow> degree f dvd n"
proof -
  have f_carr: "f \<in> carrier P"
    using assms(2) unfolding monic_irreducible_poly_def
    unfolding monic_poly_def by simp
  have f_deg: "degree f > 0"
    using assms(2) monic_poly_min_degree by fastforce

  define K where "K = Rupt\<^bsub>R\<^esub> (carrier R) f"
  have field_K: "field K"
    using assms(2) unfolding K_def monic_irreducible_poly_def
    unfolding monic_poly_def
    by (subst rupture_is_field_iff_pirreducible)  auto
  have a: "order K = order R^degree f"
    using rupture_order[OF carrier_is_subfield] f_carr f_deg
    unfolding K_def order_def by simp
  have char_K: "char K = char R"
    using rupture_char[OF carrier_is_subfield] f_carr f_deg
    unfolding K_def by simp

  have "card (carrier K) > 0"
    using a f_deg finite_field_min_order unfolding order_def by simp
  hence d: "finite (carrier K)" using card_ge_0_finite by auto
  interpret f: finite_field "K"
    using field_K d by (intro finite_fieldI, simp_all)
  interpret fp: polynomial_ring "K" "(carrier K)"
    unfolding polynomial_ring_def polynomial_ring_axioms_def
    using f.field_axioms f.carrier_is_subfield by simp

  define \<phi> where "\<phi> = rupture_surj (carrier R) f"
  interpret h:ring_hom_ring "P" "K" "\<phi>"
    unfolding K_def \<phi>_def using f_carr rupture_surj_hom by simp

  have embed_inj: "inj_on (\<phi> \<circ> poly_of_const) (carrier R)"
    unfolding \<phi>_def
    using embed_inj[OF carrier_is_subfield f_carr f_deg] by simp

  interpret r:ring_hom_ring "R" "P" "poly_of_const"
    using canonical_embedding_ring_hom by simp

  obtain rn where "order R = char K^rn" "rn > 0"
    unfolding char_K using finite_field_order by auto
  hence ord_rn: "order R ^n = char K^(rn * n)" using assms(1)
    by (simp add: power_mult)

  interpret q:ring_hom_cring "K" "K" "\<lambda>x. x [^]\<^bsub>K\<^esub> order R^n"
    using ord_rn
    by (intro f.frobenius_hom f.finite_carr_imp_char_ge_0 d, simp)

  have o1: "order R^degree f > 1"
    using f_deg finite_field_min_order one_less_power
    by blast
  hence o11: "order R^degree f > 0" by linarith
  have o2: "order R^n > 1"
    using assms(1) finite_field_min_order one_less_power
    by blast
  hence o21: "order R^n > 0" by linarith
  let ?g1 = "gauss_poly K (order R^degree f)"
  let ?g2 = "gauss_poly K (order R^n)"

  have g1_monic: "monic_poly K ?g1"
    using f.gauss_poly_monic[OF o1] by simp

  have c:"x [^]\<^bsub>K\<^esub> (order R^degree f) = x" if b:"x \<in> carrier K" for x
    using b d order_pow_eq_self
    unfolding a[symmetric]
    by (intro f.order_pow_eq_self, auto)

  have k_cycle:
    "\<phi> (poly_of_const x) [^]\<^bsub>K\<^esub> (order R^n) = \<phi>(poly_of_const x)"
    if k_cycle_1: "x \<in> carrier R" for x
  proof -
    have "\<phi> (poly_of_const x) [^]\<^bsub>K\<^esub> (order R^n) =
      \<phi> (poly_of_const (x [^]\<^bsub>R\<^esub> (order R^n)))"
      using k_cycle_1 by (simp add: h.hom_nat_pow r.hom_nat_pow)
    also have "... = \<phi> (poly_of_const x)"
      using order_pow_eq_self' k_cycle_1 by simp
    finally show ?thesis by simp
  qed

  have roots_g1: "pmult\<^bsub>K\<^esub> d ?g1 \<ge> 1"
    if roots_g1_assms: "degree d = 1" "monic_irreducible_poly K d" for d
  proof -
    obtain x where x_def: "x \<in> carrier K" "d = [\<one>\<^bsub>K\<^esub>, \<ominus>\<^bsub>K\<^esub> x]"
      using f.degree_one_monic_poly roots_g1_assms by auto
    interpret x:ring_hom_cring "poly_ring K" "K" "(\<lambda>p. f.eval p x)"
      by (intro fp.eval_cring_hom x_def)
    have "ring.eval K ?g1 x = \<zero>\<^bsub>K\<^esub>"
      unfolding gauss_poly_def a_minus_def
      using fp.var_closed f.eval_var x_def c
      by (simp, algebra)
    hence "f.is_root ?g1 x"
      using x_def f.gauss_poly_not_zero[OF o1]
      unfolding f.is_root_def univ_poly_zero by simp
    hence "[\<one>\<^bsub>K\<^esub>, \<ominus>\<^bsub>K\<^esub> x] pdivides\<^bsub>K\<^esub> ?g1"
      using f.is_root_imp_pdivides f.gauss_poly_carr by simp
    hence "d pdivides\<^bsub>K\<^esub> ?g1" by (simp add:x_def)
    thus "pmult\<^bsub>K\<^esub> d ?g1 \<ge> 1"
      using that f.gauss_poly_not_zero f.gauss_poly_carr o1
      by (subst f.multiplicity_ge_1_iff_pdivides, simp_all)
  qed

  show ?thesis
  proof
    assume f:"f pdivides\<^bsub>R\<^esub> gauss_poly R (order R^n)"
    have "(\<phi> X) [^]\<^bsub>K\<^esub> (order R^n) \<ominus>\<^bsub>K\<^esub> (\<phi> X\<^bsub>R\<^esub>) =
      \<phi> (gauss_poly R (order R^n))"
      unfolding gauss_poly_def a_minus_def using var_closed
      by (simp add: h.hom_nat_pow)
    also have "... = \<zero>\<^bsub>K\<^esub>"
      unfolding K_def \<phi>_def using f_carr gauss_poly_carr f
      by (subst rupture_eq_0_iff, simp_all)
    finally have "(\<phi> X\<^bsub>R\<^esub>) [^]\<^bsub>K\<^esub> (order R^n) \<ominus>\<^bsub>K\<^esub> (\<phi> X\<^bsub>R\<^esub>) = \<zero>\<^bsub>K\<^esub>"
      by simp
    hence g:"(\<phi> X) [^]\<^bsub>K\<^esub> (order R^n) = (\<phi> X)"
      using var_closed by simp

    have roots_g2: "pmult\<^bsub>K\<^esub> d ?g2 \<ge> 1"
      if roots_g2_assms: "degree d = 1" "monic_irreducible_poly K d" for d
    proof -
      obtain y where y_def: "y \<in> carrier K" "d = [\<one>\<^bsub>K\<^esub>, \<ominus>\<^bsub>K\<^esub> y]"
        using f.degree_one_monic_poly roots_g2_assms by auto

      interpret x:ring_hom_cring "poly_ring K" "K" "(\<lambda>p. f.eval p y)"
        by (intro fp.eval_cring_hom y_def)
      obtain x where x_def: "x \<in> carrier P" "y = \<phi> x"
        using y_def unfolding \<phi>_def K_def rupture_def
        unfolding FactRing_def A_RCOSETS_def'
        by auto
      let ?\<tau>  = "\<lambda>i. poly_of_const (coeff x i)"
      have test: "?\<tau> i \<in> carrier P" for i
        by (intro r.hom_closed coeff_range x_def)
      have test_2: "coeff x i \<in> carrier R" for i
        by (intro coeff_range x_def)

      have x_coeff_carr: "i \<in> set x \<Longrightarrow> i \<in> carrier R"  for i
        using x_def(1)
        by (auto simp add:univ_poly_carrier[symmetric] polynomial_def)

      have a:"map (\<phi> \<circ> poly_of_const) x \<in> carrier (poly_ring K)"
        using rupture_surj_norm_is_hom[OF f_carr]
        using domain_axioms f.domain_axioms embed_inj
        by (intro carrier_hom'[OF  x_def(1)])
         (simp_all add:\<phi>_def K_def)

      have "(\<phi> x) [^]\<^bsub>K\<^esub> (order R^n) =
        f.eval (map (\<phi> \<circ> poly_of_const) x) (\<phi> X) [^]\<^bsub>K\<^esub> (order R^n)"
        unfolding \<phi>_def K_def
        by (subst rupture_surj_as_eval[OF f_carr x_def(1)], simp)
      also have "... =
        f.eval (map (\<lambda>x. \<phi> (poly_of_const x) [^]\<^bsub>K\<^esub> order R ^ n) x) (\<phi> X)"
        using a h.hom_closed var_closed(1)
        by (subst q.ring.eval_hom[OF f.carrier_is_subring])
          (simp_all add:comp_def g)
      also have "... = f.eval (map (\<lambda>x. \<phi> (poly_of_const x)) x) (\<phi> X)"
        using k_cycle x_coeff_carr
        by (intro arg_cong2[where f="f.eval"] map_cong, simp_all)
      also have "... = (\<phi> x)"
        unfolding \<phi>_def K_def
        by (subst rupture_surj_as_eval[OF f_carr x_def(1)], simp add:comp_def)
      finally have "\<phi> x [^]\<^bsub>K\<^esub> order R ^ n = \<phi> x" by simp

      hence "y [^]\<^bsub>K\<^esub> (order R^n) = y" using x_def by simp
      hence "ring.eval K ?g2 y = \<zero>\<^bsub>K\<^esub>"
        unfolding gauss_poly_def a_minus_def
        using fp.var_closed f.eval_var y_def
        by (simp, algebra)
      hence "f.is_root ?g2 y"
        using y_def f.gauss_poly_not_zero[OF o2]
        unfolding f.is_root_def univ_poly_zero by simp
      hence "d pdivides\<^bsub>K\<^esub> ?g2"
        unfolding y_def
        by (intro f.is_root_imp_pdivides f.gauss_poly_carr, simp)
      thus "pmult\<^bsub>K\<^esub> d ?g2 \<ge> 1"
        using that f.gauss_poly_carr f.gauss_poly_not_zero o2
        by (subst f.multiplicity_ge_1_iff_pdivides, auto)
    qed

    have inv_k_inj: "inj_on (\<lambda>x. \<ominus>\<^bsub>K\<^esub> x) (carrier K)"
      by (intro inj_onI, metis f.minus_minus)
    let ?mip = "monic_irreducible_poly K"

    have "sum' (\<lambda>d. pmult\<^bsub>K\<^esub> d ?g1 * degree d) {d. ?mip d} = degree ?g1"
      using f.gauss_poly_monic o1
      by (subst f.degree_monic_poly', simp_all)
    also have "... = order K"
      using f.gauss_poly_degree o1 a by simp
    also have "... = card ((\<lambda>k. [\<one>\<^bsub>K\<^esub>, \<ominus>\<^bsub>K\<^esub> k]) ` carrier K)"
      unfolding order_def using inj_onD[OF inv_k_inj]
      by (intro card_image[symmetric] inj_onI) (simp_all)
    also have "... = card {d. ?mip d \<and> degree d = 1}"
      using f.degree_one_monic_poly
      by (intro arg_cong[where f="card"], simp add:set_eq_iff image_iff)
    also have "... = sum (\<lambda>d. 1) {d. ?mip d \<and> degree d = 1}"
      by simp
    also have "... = sum' (\<lambda>d. 1) {d. ?mip d \<and> degree d = 1}"
      by (intro sum.eq_sum[symmetric]
          finite_subset[OF _ fp.finite_poly(1)[OF d]])
       (auto simp:monic_irreducible_poly_def monic_poly_def)
    also have "... = sum' (\<lambda>d. of_bool (degree d = 1)) {d. ?mip d}"
      by (intro sum.mono_neutral_cong_left' subsetI, simp_all)
    also have "... \<le> sum' (\<lambda>d. of_bool (degree d = 1)) {d. ?mip d}"
      by simp
    finally have "sum' (\<lambda>d. pmult\<^bsub>K\<^esub> d ?g1 * degree d) {d. ?mip d}
      \<le> sum' (\<lambda>d. of_bool (degree d = 1)) {d. ?mip d}"
      by simp
    moreover have
      "pmult\<^bsub>K\<^esub> d ?g1 * degree d \<ge> of_bool (degree d = 1)"
      if v:"monic_irreducible_poly K d" for d
    proof (cases "degree d = 1")
      case True
      then obtain x where "x \<in> carrier K" "d = [\<one>\<^bsub>K\<^esub>, \<ominus>\<^bsub>K\<^esub> x]"
        using f.degree_one_monic_poly v by auto
      hence "pmult\<^bsub>K\<^esub> d ?g1 \<ge> 1"
        using roots_g1 v by simp
      then show ?thesis using True by simp
    next
      case False
      then show ?thesis by simp
    qed
    moreover have
      "finite {d. ?mip d \<and> pmult\<^bsub>K\<^esub> d ?g1 * degree d > 0}"
      by (intro finite_subset[OF _ f.factor_monic_poly_fin[OF g1_monic]]
          subsetI) simp
    ultimately have v2:
      "\<forall>d \<in> {d. ?mip d}. pmult\<^bsub>K\<^esub> d ?g1 * degree d =
      of_bool (degree d = 1)"
      by (intro sum'_eq_iff, simp_all add:not_le)
    have "pmult\<^bsub>K\<^esub> d ?g1 \<le> pmult\<^bsub>K\<^esub> d ?g2" if "?mip d" for d
    proof (cases "degree d = 1")
      case True
      hence "pmult\<^bsub>K\<^esub> d ?g1 = 1" using v2 that by auto
      also have "... \<le> pmult\<^bsub>K\<^esub> d ?g2"
        by (intro roots_g2 True that)
      finally show ?thesis by simp
    next
      case False
      hence "degree d > 1"
        using f.monic_poly_min_degree[OF that] by simp
      hence "pmult\<^bsub>K\<^esub> d ?g1 = 0" using v2 that by force
      then show ?thesis by simp
    qed
    hence "?g1 pdivides\<^bsub>K\<^esub> ?g2"
      using o1 o2 f.divides_monic_poly f.gauss_poly_monic by simp
    thus "degree f dvd n"
      by (subst (asm) f.gauss_poly_div_gauss_poly_iff
          [OF assms(1) f_deg finite_field_min_order], simp)
  next
    have d:"\<phi> X\<^bsub>R\<^esub> \<in> carrier K"
      by (intro h.hom_closed var_closed)

    have "\<phi> (gauss_poly R (order R^degree f)) =
      (\<phi> X\<^bsub>R\<^esub>) [^]\<^bsub>K\<^esub> (order R^degree f) \<ominus>\<^bsub>K\<^esub> (\<phi> X\<^bsub>R\<^esub>)"
      unfolding gauss_poly_def a_minus_def using var_closed
      by (simp add: h.hom_nat_pow)
    also have "... = \<zero>\<^bsub>K\<^esub>"
      using c d by simp
    finally have "\<phi> (gauss_poly R (order R^degree f)) = \<zero>\<^bsub>K\<^esub>" by simp
    hence "f pdivides\<^bsub>R\<^esub> gauss_poly R (order R^degree f)"
      unfolding K_def \<phi>_def using f_carr gauss_poly_carr
      by (subst (asm) rupture_eq_0_iff, simp_all)
    moreover assume "degree f dvd n"

    hence "gauss_poly R (order R^degree f) pdivides
      (gauss_poly R (order R^n))"
      using gauss_poly_div_gauss_poly_iff
        [OF assms(1) f_deg finite_field_min_order]
      by simp
    ultimately show "f pdivides\<^bsub>R\<^esub> gauss_poly R (order R^n)"
      using f_carr a p.divides_trans unfolding pdivides_def by blast
  qed
qed

lemma gauss_poly_splitted:
  "splitted (gauss_poly R (order R))"
proof -
  have "degree q \<le> 1" if
    "q \<in> carrier P"
    "pirreducible (carrier R) q"
    "q pdivides gauss_poly R (order R)" for q
  proof -
    have q_carr: "q \<in> carrier (mult_of P)"
      using that unfolding ring_irreducible_def by simp
    moreover have "irreducible (mult_of P) q"
      using that unfolding ring_irreducible_def
      by (intro p.irreducible_imp_irreducible_mult that, simp_all)
    ultimately obtain p where p_def:
      "monic_irreducible_poly R p" "q \<sim>\<^bsub>mult_of P\<^esub> p"
      using monic_poly_span by auto
    have p_carr: "p \<in> carrier P" "p \<noteq> []"
      using p_def(1)
      unfolding monic_irreducible_poly_def monic_poly_def
      by auto
    moreover have "p divides\<^bsub>mult_of P\<^esub> q"
      using associatedE[OF p_def(2)] by auto
    hence "p pdivides q"
      unfolding pdivides_def using divides_mult_imp_divides by simp
    moreover have "q pdivides gauss_poly R (order R^1)"
      using that by simp
    ultimately have "p pdivides gauss_poly R (order R^1)"
      unfolding pdivides_def using p.divides_trans by blast
    hence "degree p dvd 1"
      using  div_gauss_poly_iff[where n="1"] p_def(1) by simp
    hence "degree p = 1" by simp
    moreover have "q divides\<^bsub>mult_of P\<^esub> p"
      using associatedE[OF p_def(2)] by auto
    hence "q pdivides p"
      unfolding pdivides_def using divides_mult_imp_divides by simp
    hence "degree q \<le> degree p"
      using that p_carr
      by (intro pdivides_imp_degree_le) auto
    ultimately show ?thesis by simp
  qed

  thus ?thesis
    using gauss_poly_carr
    by (intro trivial_factors_imp_splitted, auto)
qed

text \<open>The following lemma, for the case when @{term "R"} is a simple prime field, can be found in
Ireland and Rosen~\<^cite>\<open>\<open>\textsection 7.1, Theorem 2\<close> in "ireland1982"\<close>. Here the result is verified even
for arbitrary finite fields.\<close>

lemma multiplicity_of_factor_of_gauss_poly:
  assumes "n > 0"
  assumes "monic_irreducible_poly R f"
  shows
    "pmult\<^bsub>R\<^esub> f (gauss_poly R (order R^n)) = of_bool (degree f dvd n)"
proof (cases "degree f dvd n")
  case True
  let ?g = "gauss_poly R (order R^n)"
  have f_carr: "f \<in> carrier P" "f \<noteq> []"
    using assms(2)
    unfolding monic_irreducible_poly_def monic_poly_def
    by auto

  have o2: "order R^n > 1"
    using finite_field_min_order assms(1) one_less_power by blast
  hence o21: "order R^n > 0" by linarith

  obtain d :: nat where order_dim: "order R = char R ^ d" "d > 0"
    using finite_field_order by blast
  have "d * n > 0" using order_dim assms by simp
  hence char_dvd_order: "int (char R) dvd int (order R ^ n)"
    unfolding order_dim
    using finite_carr_imp_char_ge_0[OF finite_carrier]
    by (simp add:power_mult[symmetric])

  interpret h: ring_hom_ring  "R" "P" "poly_of_const"
    using canonical_embedding_ring_hom by simp

  have "f pdivides\<^bsub>R\<^esub> ?g"
    using True div_gauss_poly_iff[OF assms] by simp
  hence "pmult\<^bsub>R\<^esub> f ?g \<ge> 1"
    using multiplicity_ge_1_iff_pdivides[OF assms(2)]
    using gauss_poly_carr gauss_poly_not_zero[OF o2]
    by auto
  moreover have "pmult\<^bsub>R\<^esub> f ?g < 2"
  proof (rule ccontr)
    assume "\<not> pmult\<^bsub>R\<^esub> f ?g < 2"
    hence "pmult\<^bsub>R\<^esub> f ?g \<ge> 2" by simp
    hence "(f [^]\<^bsub>P\<^esub> (2::nat)) pdivides\<^bsub>R\<^esub> ?g"
      using gauss_poly_carr gauss_poly_not_zero[OF o2]
      by (subst (asm) multiplicity_ge_iff[OF assms(2)]) simp_all
    hence "(f [^]\<^bsub>P\<^esub> (2::nat)) divides\<^bsub>mult_of P\<^esub> ?g"
      unfolding pdivides_def
      using f_carr gauss_poly_not_zero o2 gauss_poly_carr
      by (intro p.divides_imp_divides_mult) simp_all
    then obtain h where h_def:
      "h \<in> carrier (mult_of P)"
      "?g = f [^]\<^bsub>P\<^esub> (2::nat) \<otimes>\<^bsub>P\<^esub> h"
      using dividesD by auto
    have "\<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub> = int_embed P (order R ^ n)
      \<otimes>\<^bsub>P\<^esub> (X\<^bsub>R\<^esub> [^]\<^bsub>P\<^esub> (order R ^ n-1)) \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>"
      using var_closed
      apply (subst int_embed_consistent_with_poly_of_const)
      apply (subst iffD2[OF embed_char_eq_0_iff char_dvd_order])
      by (simp add:a_minus_def)
    also have "... = pderiv\<^bsub>R\<^esub> (X\<^bsub>R\<^esub> [^]\<^bsub>P\<^esub> order R ^ n) \<ominus>\<^bsub>P\<^esub> pderiv\<^bsub>R\<^esub> X\<^bsub>R\<^esub>"
      using pderiv_var
      by (subst pderiv_var_pow[OF o21], simp)
    also have "... = pderiv\<^bsub>R\<^esub> ?g"
      unfolding gauss_poly_def a_minus_def using var_closed
      by (subst pderiv_add, simp_all add:pderiv_inv)
    also have "... = pderiv\<^bsub>R\<^esub> (f [^]\<^bsub>P\<^esub> (2::nat) \<otimes>\<^bsub>P\<^esub> h)"
      using h_def(2) by simp
    also have "... = pderiv\<^bsub>R\<^esub> (f [^]\<^bsub>P\<^esub> (2::nat)) \<otimes>\<^bsub>P\<^esub> h
      \<oplus>\<^bsub>P\<^esub> (f [^]\<^bsub>P\<^esub> (2::nat)) \<otimes>\<^bsub>P\<^esub> pderiv\<^bsub>R\<^esub> h"
      using f_carr h_def
      by (intro pderiv_mult, simp_all)
    also have "... = int_embed P 2 \<otimes>\<^bsub>P\<^esub> f  \<otimes>\<^bsub>P\<^esub> pderiv\<^bsub>R\<^esub> f \<otimes>\<^bsub>P\<^esub> h
      \<oplus>\<^bsub>P\<^esub> f \<otimes>\<^bsub>P\<^esub> f \<otimes>\<^bsub>P\<^esub> pderiv\<^bsub>R\<^esub> h"
      using f_carr
      by (subst pderiv_pow, simp_all add:numeral_eq_Suc)
    also have "... = f \<otimes>\<^bsub>P\<^esub> (int_embed P 2 \<otimes>\<^bsub>P\<^esub> pderiv\<^bsub>R\<^esub> f \<otimes>\<^bsub>P\<^esub> h)
      \<oplus>\<^bsub>P\<^esub> f \<otimes>\<^bsub>P\<^esub> (f \<otimes>\<^bsub>P\<^esub> pderiv\<^bsub>R\<^esub> h)"
      using f_carr pderiv_carr h_def p.int_embed_closed
      apply (intro arg_cong2[where f="(\<oplus>\<^bsub>P\<^esub>)"])
      by (subst p.m_comm, simp_all add:p.m_assoc)
    also have "... = f \<otimes>\<^bsub>P\<^esub>
      (int_embed P 2 \<otimes>\<^bsub>P\<^esub> pderiv\<^bsub>R\<^esub> f \<otimes>\<^bsub>P\<^esub> h \<oplus>\<^bsub>P\<^esub> f \<otimes>\<^bsub>P\<^esub> pderiv\<^bsub>R\<^esub> h)"
      using f_carr pderiv_carr h_def p.int_embed_closed
      by (subst p.r_distr, simp_all)
    finally have "\<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub> = f \<otimes>\<^bsub>P\<^esub>
      (int_embed P 2 \<otimes>\<^bsub>P\<^esub> pderiv\<^bsub>R\<^esub> f \<otimes>\<^bsub>P\<^esub> h \<oplus>\<^bsub>P\<^esub> f \<otimes>\<^bsub>P\<^esub> pderiv\<^bsub>R\<^esub> h)"
      (is "_ = f \<otimes>\<^bsub>P\<^esub> ?q")
      by simp

    hence "f pdivides\<^bsub>R\<^esub> \<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>"
      unfolding factor_def pdivides_def
      using f_carr pderiv_carr h_def p.int_embed_closed
      by auto
    moreover have "\<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub> \<noteq> \<zero>\<^bsub>P\<^esub>" by simp
    ultimately have  "degree f \<le> degree (\<ominus>\<^bsub>P\<^esub> \<one>\<^bsub>P\<^esub>)"
      using f_carr
      by (intro pdivides_imp_degree_le, simp_all add:univ_poly_zero)
    also have "... = 0"
      by (subst univ_poly_a_inv_degree, simp)
       (simp add:univ_poly_one)
    finally have "degree f = 0" by simp

    then show "False"
      using pirreducible_degree assms(2)
      unfolding monic_irreducible_poly_def monic_poly_def
      by fastforce
  qed
  ultimately have "pmult\<^bsub>R\<^esub> f ?g = 1" by simp
  then show ?thesis using True by simp
next
  case False
  have o2: "order R^n > 1"
    using finite_field_min_order assms(1) one_less_power by blast

  have "\<not>(f pdivides\<^bsub>R\<^esub> gauss_poly R (order R^n))"
    using div_gauss_poly_iff[OF assms] False by simp
  hence "pmult\<^bsub>R\<^esub> f (gauss_poly R (order R^n)) = 0"
    using multiplicity_ge_1_iff_pdivides[OF assms(2)]
    using gauss_poly_carr gauss_poly_not_zero[OF o2] leI less_one
    by blast
  then show ?thesis using False by simp
qed

text \<open>The following lemma, for the case when @{term "R"} is a simple prime field, can be found in Ireland
and Rosen~\<^cite>\<open>\<open>\textsection 7.1, Corollary 1\<close> in "ireland1982"\<close>. Here the result is verified even for
arbitrary finite fields.\<close>

lemma card_irred_aux:
  assumes "n > 0"
  shows "order R^n = (\<Sum>d | d dvd n. d *
    card {f. monic_irreducible_poly R f \<and> degree f = d})"
  (is "?lhs = ?rhs")
proof -
  let ?G = "{f. monic_irreducible_poly R f \<and> degree f dvd n}"

  let ?D = "{f. monic_irreducible_poly R f}"
  have a: "finite {d. d dvd n}" using finite_divisors_nat assms by simp
  have b: "finite {f. monic_irreducible_poly R f \<and> degree f = k}" for k
  proof -
    have "{f. monic_irreducible_poly R f \<and> degree f = k} \<subseteq>
      {f. f \<in> carrier P \<and> degree f \<le> k}"
      unfolding monic_irreducible_poly_def monic_poly_def by auto
    moreover have "finite {f. f \<in> carrier P \<and> degree f \<le> k}"
      using finite_poly[OF finite_carrier] by simp
    ultimately show ?thesis using finite_subset by simp
  qed

  have G_split: "?G =
    \<Union> {{f.  monic_irreducible_poly R f \<and> degree f = d} | d. d dvd n}"
    by auto
  have c: "finite ?G"
    using a b by (subst G_split, auto)
  have d: "order R^n > 1"
    using assms finite_field_min_order one_less_power by blast

  have "?lhs = degree (gauss_poly R (order R^n))"
    using d
    by (subst gauss_poly_degree, simp_all)
  also have "... =
    sum' (\<lambda>d. pmult\<^bsub>R\<^esub> d (gauss_poly R (order R^n)) * degree d) ?D"
    using d
    by (intro degree_monic_poly'[symmetric] gauss_poly_monic)
  also have "... = sum' (\<lambda>d. of_bool (degree d dvd n) * degree d) ?D"
    using multiplicity_of_factor_of_gauss_poly[OF assms]
    by (intro sum.cong', auto)
  also have "... = sum' (\<lambda>d. degree d) ?G"
    by (intro sum.mono_neutral_cong_right' subsetI, auto)
  also have "... = (\<Sum> d \<in> ?G. degree d)"
    using c by (intro sum.eq_sum, simp)
  also have "... =
    (\<Sum> f \<in> (\<Union> d \<in> {d. d dvd n}.
    {f. monic_irreducible_poly R f \<and> degree f = d}). degree f)"
    by (intro sum.cong, auto simp add:set_eq_iff)
  also have "... = (\<Sum>d | d dvd n. sum degree
    {f. monic_irreducible_poly R f \<and> degree f = d})"
    using a b by (subst sum.UNION_disjoint, auto simp add:set_eq_iff)
  also have "... = (\<Sum>d | d dvd n. sum (\<lambda>_. d)
    {f. monic_irreducible_poly R f \<and> degree f = d})"
    by (intro sum.cong, simp_all)
  also have "... = ?rhs"
    by (simp add:mult.commute)
  finally show ?thesis
    by simp
qed

end

end


(*  Title:      HOL/UNITY/Comp/Priority.thy
    Author:     Sidi O Ehmety, Cambridge University Computer Laboratory
    Copyright   2001  University of Cambridge
*)

section\<open>The priority system\<close>

theory Priority imports PriorityAux begin

text\<open>From Charpentier and Chandy,
Examples of Program Composition Illustrating the Use of Universal Properties
   In J. Rolim (editor), Parallel and Distributed Processing,
   Spriner LNCS 1586 (1999), pages 1215-1227.\<close>

type_synonym state = "(vertex*vertex)set"
type_synonym command = "vertex=>(state*state)set"

consts
  init :: "(vertex*vertex)set"
  \<comment> \<open>the initial state\<close>

text\<open>Following the definitions given in section 4.4\<close>

definition highest :: "[vertex, (vertex*vertex)set]=>bool"
  where "highest i r \<longleftrightarrow> A i r = {}"
    \<comment> \<open>i has highest priority in r\<close>

definition lowest :: "[vertex, (vertex*vertex)set]=>bool"
  where "lowest i r \<longleftrightarrow> R i r = {}"
    \<comment> \<open>i has lowest priority in r\<close>

definition act :: command
  where "act i = {(s, s'). s'=reverse i s & highest i s}"

definition Component :: "vertex=>state program"
  where "Component i = mk_total_program({init}, {act i}, UNIV)"
    \<comment> \<open>All components start with the same initial state\<close>

text\<open>Some Abbreviations\<close>
definition Highest :: "vertex=>state set"
  where "Highest i = {s. highest i s}"

definition Lowest :: "vertex=>state set"
  where "Lowest i = {s. lowest i s}"

definition Acyclic :: "state set"
  where "Acyclic = {s. acyclic s}"

definition Maximal :: "state set"
    \<comment> \<open>Every ``above'' set has a maximal vertex\<close>
  where "Maximal = (\<Inter>i. {s. ~highest i s-->(\<exists>j \<in> above i  s. highest j s)})"

definition Maximal' :: "state set"
    \<comment> \<open>Maximal vertex: equivalent definition\<close>
  where "Maximal' = (\<Inter>i. Highest i Un (\<Union>j. {s. j \<in> above i s} Int Highest j))"

definition Safety :: "state set"
  where "Safety = (\<Inter>i. {s. highest i s --> (\<forall>j \<in> neighbors i s. ~highest j s)})"

  (* Composition of a finite set of component;
     the vertex 'UNIV' is finite by assumption *)

definition system :: "state program"
  where "system = (\<Squnion>i. Component i)"

declare highest_def [simp] lowest_def [simp]
declare Highest_def [THEN def_set_simp, simp]
    and Lowest_def  [THEN def_set_simp, simp]

declare Component_def [THEN def_prg_Init, simp]
declare act_def [THEN def_act_simp, simp]

subsection\<open>Component correctness proofs\<close>

text\<open>neighbors is stable\<close>
lemma Component_neighbors_stable: "Component i \<in> stable {s. neighbors k s = n}"
by (simp add: Component_def, safety, auto)

text\<open>property 4\<close>
lemma Component_waits_priority: "Component i \<in> {s. ((i,j) \<in> s) = b} \<inter> (- Highest i) co {s. ((i,j) \<in> s)=b}"
by (simp add: Component_def, safety)

text\<open>property 5: charpentier and Chandy mistakenly express it as
 'transient Highest i'. Consider the case where i has neighbors\<close>
lemma Component_yields_priority:
 "Component i \<in> {s. neighbors i s \<noteq> {}} Int Highest i
               ensures - Highest i"
apply (simp add: Component_def)
apply (ensures_tac "act i", blast+)
done

text\<open>or better\<close>
lemma Component_yields_priority': "Component i \<in> Highest i ensures Lowest i"
apply (simp add: Component_def)
apply (ensures_tac "act i", blast+)
done

text\<open>property 6: Component doesn't introduce cycle\<close>
lemma Component_well_behaves: "Component i \<in> Highest i co Highest i Un Lowest i"
by (simp add: Component_def, safety, fast)

text\<open>property 7: local axiom\<close>
lemma locality: "Component i \<in> stable {s. \<forall>j k. j\<noteq>i & k\<noteq>i--> ((j,k) \<in> s) = b j k}"
by (simp add: Component_def, safety)

subsection\<open>System  properties\<close>
text\<open>property 8: strictly universal\<close>

lemma Safety: "system \<in> stable Safety"
apply (unfold Safety_def)
apply (rule stable_INT)
apply (simp add: system_def, safety, fast)
done

text\<open>property 13: universal\<close>
lemma p13: "system \<in> {s. s = q} co {s. s=q} Un {s. \<exists>i. derive i q s}"
by (simp add: system_def Component_def mk_total_program_def totalize_JN, safety, blast)

text\<open>property 14: the 'above set' of a Component that hasn't got
      priority doesn't increase\<close>
lemma above_not_increase:
     "system \<in> -Highest i Int {s. j\<notin>above i s} co {s. j\<notin>above i s}"
apply (insert reach_lemma [of concl: j])
apply (simp add: system_def Component_def mk_total_program_def totalize_JN,
       safety)
apply (simp add: trancl_converse, blast)
done

lemma above_not_increase':
     "system \<in> -Highest i Int {s. above i s = x} co {s. above i s <= x}"
apply (insert above_not_increase [of i])
apply (simp add: trancl_converse constrains_def, blast)
done

text\<open>p15: universal property: all Components well behave\<close>
lemma system_well_behaves: "system \<in> Highest i co Highest i Un Lowest i"
  by (simp add: system_def Component_def mk_total_program_def totalize_JN, safety, auto)

lemma Acyclic_eq: "Acyclic = (\<Inter>i. {s. i\<notin>above i s})"
  by (auto simp add: Acyclic_def acyclic_def trancl_converse)

lemmas system_co =
      constrains_Un [OF above_not_increase [rule_format] system_well_behaves]

lemma Acyclic_stable: "system \<in> stable Acyclic"
apply (simp add: stable_def Acyclic_eq)
apply (auto intro!: constrains_INT system_co [THEN constrains_weaken]
            simp add: image0_r_iff_image0_trancl trancl_converse)
done

lemma Acyclic_subset_Maximal: "Acyclic <= Maximal"
apply (unfold Acyclic_def Maximal_def, clarify)
apply (drule above_lemma_b, auto)
done

text\<open>property 17: original one is an invariant\<close>
lemma Acyclic_Maximal_stable: "system \<in> stable (Acyclic Int Maximal)"
by (simp add: Acyclic_subset_Maximal [THEN Int_absorb2] Acyclic_stable)

text\<open>property 5: existential property\<close>

lemma Highest_leadsTo_Lowest: "system \<in> Highest i leadsTo Lowest i"
apply (simp add: system_def Component_def mk_total_program_def totalize_JN)
apply (ensures_tac "act i", auto)
done

text\<open>a lowest i can never be in any abover set\<close>
lemma Lowest_above_subset: "Lowest i <= (\<Inter>k. {s. i\<notin>above k s})"
by (auto simp add: image0_r_iff_image0_trancl trancl_converse)

text\<open>property 18: a simpler proof than the original, one which uses psp\<close>
lemma Highest_escapes_above: "system \<in> Highest i leadsTo (\<Inter>k. {s. i\<notin>above k s})"
apply (rule leadsTo_weaken_R)
apply (rule_tac [2] Lowest_above_subset)
apply (rule Highest_leadsTo_Lowest)
done

lemma Highest_escapes_above':
     "system \<in> Highest j Int {s. j \<in> above i s} leadsTo {s. j\<notin>above i s}"
by (blast intro: leadsTo_weaken [OF Highest_escapes_above Int_lower1 INT_lower])

subsection\<open>The main result: above set decreases\<close>

text\<open>The original proof of the following formula was wrong\<close>

lemma Highest_iff_above0: "Highest i = {s. above i s ={}}"
by (auto simp add: image0_trancl_iff_image0_r)

lemmas above_decreases_lemma =
     psp [THEN leadsTo_weaken, OF Highest_escapes_above' above_not_increase']

lemma above_decreases:
     "system \<in> (\<Union>j. {s. above i s = x} Int {s. j \<in> above i s} Int Highest j)
               leadsTo {s. above i s < x}"
apply (rule leadsTo_UN)
apply (rule single_leadsTo_I, clarify)
apply (rule_tac x = "above i xa" in above_decreases_lemma)
apply (simp_all (no_asm_use) add: Highest_iff_above0)
apply blast+
done

(** Just a massage of conditions to have the desired form ***)
lemma Maximal_eq_Maximal': "Maximal = Maximal'"
by (unfold Maximal_def Maximal'_def Highest_def, blast)

lemma Acyclic_subset:
   "x\<noteq>{} ==>
    Acyclic Int {s. above i s = x} <=
    (\<Union>j. {s. above i s = x} Int {s. j \<in> above i s} Int Highest j)"
apply (rule_tac B = "Maximal' Int {s. above i s = x}" in subset_trans)
apply (simp (no_asm) add: Maximal_eq_Maximal' [symmetric])
apply (blast intro: Acyclic_subset_Maximal [THEN subsetD])
apply (simp (no_asm) del: above_def add: Maximal'_def Highest_iff_above0)
apply blast
done

lemmas above_decreases' = leadsTo_weaken_L [OF above_decreases Acyclic_subset]
lemmas above_decreases_psp = psp_stable [OF above_decreases' Acyclic_stable]

lemma above_decreases_psp':
"x\<noteq>{}==> system \<in> Acyclic Int {s. above i s = x} leadsTo
                   Acyclic Int {s. above i s < x}"
by (erule above_decreases_psp [THEN leadsTo_weaken], blast, auto)

lemmas finite_psubset_induct = wf_finite_psubset [THEN leadsTo_wf_induct]

lemma Progress: "system \<in> Acyclic leadsTo Highest i"
apply (rule_tac f = "%s. above i s" in finite_psubset_induct)
apply (simp del: above_def
            add: Highest_iff_above0 vimage_def finite_psubset_def, clarify)
apply (case_tac "m={}")
apply (rule Int_lower2 [THEN [2] leadsTo_weaken_L])
apply (force simp add: leadsTo_refl)
apply (rule_tac A' = "Acyclic Int {x. above i x < m}" in leadsTo_weaken_R)
apply (blast intro: above_decreases_psp')+
done

text\<open>We have proved all (relevant) theorems given in the paper.  We didn't
assume any thing about the relation \<^term>\<open>r\<close>.  It is not necessary that
\<^term>\<open>r\<close> be a priority relation as assumed in the original proof.  It
suffices that we start from a state which is finite and acyclic.\<close>

end


theory Practical
imports Main
begin

(***************************First-order logic*************************************)

(*1 mark*)
lemma "A\<or>A \<longrightarrow> A"
  oops

(*1 mark*)
lemma "(P\<longrightarrow>R)\<longrightarrow>(\<not>P\<or>R)"
  oops

(*1 mark*)
lemma "(P\<and>Q\<longrightarrow>R)\<longrightarrow>P\<longrightarrow>Q\<longrightarrow>R"
  oops

(*3 marks*)
lemma "\<not>\<not>P \<or> \<not>P"
  oops

(*4 marks*)
lemma "(P\<or>R)\<longleftrightarrow>(\<not>(\<not>P\<and> \<not>R))"
  oops

(*1 mark*)
lemma "(\<forall> x . F x) \<and> (\<forall> x . G x ) \<longrightarrow> (\<forall> x . F x \<and> G x )"
  oops

(*1 mark*)
lemma "(\<forall> x y. R x y) \<longrightarrow> (\<forall> x . R x x )"
  oops

(*3 marks*)
lemma "(\<forall>x. P x)\<or>(\<exists>x.\<not>P x)"
  oops

(*3 marks*)
lemma "(\<forall>x. \<not> (P x \<longrightarrow> Q x)) \<longrightarrow> \<not>(\<exists>x. \<not>P x \<and> Q x)"
  oops

(*3 marks*)
lemma "\<exists>Bob. (drunk Bob \<longrightarrow> (\<forall>y. drunk y))"
  oops

(*4 marks*)
lemma "\<not> (\<exists> barber . man barber \<and> (\<forall> x . man x \<and> \<not>shaves x x \<longleftrightarrow> shaves barber x ))"
  oops

locale incidence =
  fixes incidence_points_on_sections :: "'point \<Rightarrow> 'section \<Rightarrow> bool" (infix " \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t " 80)
  fixes region_to_section :: "'region \<Rightarrow> 'section"
  assumes section_nonempty: (*Write here your axiom stating that every section has
                                            a point incident to it*) (*2 marks*)
  and section_uniqueness: (*Write here your axiom stating that two sections are the same
                                      if the same points are incident to each*) (*2 marks*)
begin

definition isPartOf ::"'section \<Rightarrow> 'section \<Rightarrow> bool" (infix "isPartOf" 80) where
(*write your formalisation of definition D1 here*) (*1 mark*)

definition inclusion ::"'region \<Rightarrow> 'section \<Rightarrow> bool"(infix "isIncludedIn" 80) where
(*write your formalisation of definition D2 here*) (*1 mark*)

definition overlaps ::"'region \<Rightarrow> 'section \<Rightarrow> bool"(infix "overlaps" 80) where
(*write your formalisation of definition D3 here*) (*1 mark*)

lemma region_overlaps_itself: "R overlaps (region_to_section R)"
(*Write your structured proof here*) (*2 marks*)
  oops

(*Formalise and prove that isPartOf is reflexive, transitive and antisymmetric*) (*3 marks*)
lemma isPartOf_reflexive:
(*Formalise and prove that isPartOf is reflexive here*)
  oops

lemma isPartOf_transitive:
(*Formalise and prove that isPartOf is transitive here*)
  oops

lemma isPartOf_antisymmetric:
(*Formalise and prove that isPartOf is antisymmetric here*)
  oops

end

locale section_bundles =  incidence incidence_points_on_sections region_to_section
  for  incidence_points_on_sections :: "'point \<Rightarrow> 'section \<Rightarrow> bool"
  and region_to_section :: "'region \<Rightarrow> 'section" +
  fixes crossing :: "'region \<Rightarrow> 'section \<Rightarrow> bool" (infix "crosses" 80)
  and incidence_sections_on_bundles :: "'section \<Rightarrow> 'bundle \<Rightarrow> bool" (infix "\<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n" 80)
 assumes SC1: (*Write your formalisation of Axiom SC1 here*) (*1 mark*)
 and SI1: (*Write your formalisation of Axiom SI1 here*)     (*1 mark*)
begin

definition atLeastAsRestrictiveAs :: "'section \<Rightarrow> 'bundle \<Rightarrow> 'section \<Rightarrow> bool" where
(*Write your formalisation of atLeastAsRestrictiveAs here*) (*1 mark*)

notation
  atLeastAsRestrictiveAs ("_ \<le>\<^sub>_ _" [80, 80, 80] 80)

(*Formalise and prove that atLeastAsRestrictiveAs is reflexive, transitive and antisymmetric*) (*2 marks*)

(*Kulik and Eschenbach say 'The relation \<ge> is reflexive, transitive and antisymmetric for a given
sector bundle.' So, do they mean, given that the sections under consideration are in the bundle?
This is what we assume for reflexivity.*)
lemma atLeastAsRestrictiveAs_reflexive:
  assumes "s \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b"  shows "s \<le>\<^sub>b s"
(*Add your proof here*)
  oops

lemma atLeastAsRestrictiveAs_transitive:
(*Formalise and prove that atLeastAsRestrictiveAs is transitive*)
  oops

lemma atLeastAsRestrictiveAs_antisymmetric:
(*Formalise and prove that atLeastAsRestrictiveAs is antisymmetric*))
  oops

end

locale comparison = section_bundles incidence_points_on_sections region_to_section
 crossing incidence_sections_on_bundles
  for  incidence_points_on_sections :: "'point \<Rightarrow> 'section \<Rightarrow> bool" (infix "\<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t" 80)
  and region_to_section :: "'region \<Rightarrow> 'section"
  and crossing :: "'region \<Rightarrow> 'section \<Rightarrow> bool" (infix "crosses" 80)
  and incidence_sections_on_bundles :: "'section \<Rightarrow> 'bundle \<Rightarrow> bool" (infix "\<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n" 80)+
assumes SB2:(*Write your formalisation of Axiom SB2 here*) (*1 mark*)
begin

lemma T1:(*Write your formalisation and proof of Theorem T1 here*) (*1 mark*)

lemma T2:(*Write your formalisation and proof of Theorem T2 here*) (*1 mark*)

definition isCore (infix "isCoreOf" 80) where
"s isCoreOf b = (s \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<and> (\<forall>s'. s' \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<longrightarrow> s \<le>\<^sub>b s'))"

definition (*Write your definition of hull here*) (*1 mark*)

end

locale crossing_sector = comparison incidence_points_on_sections
          region_to_section crossing incidence_sections_on_bundles
          for incidence_points_on_sections :: "'point \<Rightarrow> 'section \<Rightarrow> bool" (infix "\<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t" 80)
and region_to_section :: "'region \<Rightarrow> 'section"
and crossing :: "'region \<Rightarrow> 'section \<Rightarrow> bool" (infix "crosses" 80)
and incidence_sections_on_bundles :: "'section \<Rightarrow> 'bundle \<Rightarrow> bool" (infix "\<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n" 80) +
assumes SC2: (*Write your formalisation of Axiom SC2 here*) (*1 mark*)
begin

lemma overlaps_core: (*Write your formalisation and structured proof of the remark `If a region
overlaps the core of a section bundle then it overlaps every section of the section bundle'*)
(*4 marks*)

lemma crosses_hull: (*Write your formalisation and structured proof of the remark `If a region
crosses the hull of a section bundle then it crosses every sector of the section bundle'*)
(*4 marks*)

lemma not_overlap_hull:  (*Write your formalisation and structured proof of the remark `If a region
does not overlap the hull of a section bundle, it does not overlap any of its sections'*)
(*4 marks*)

definition overlapsAsMuchAs :: "'region \<Rightarrow> 'bundle \<Rightarrow> 'region \<Rightarrow> bool"  where
"overlapsAsMuchAs R b R' == (\<forall>s. s \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<longrightarrow> R' overlaps s \<longrightarrow> R overlaps s)"

notation
  overlapsAsMuchAs ("_ \<ge>\<^sub>o\<^sub>v\<^sub>e\<^sub>r\<^sub>l\<^sub>a\<^sub>p\<^sub>s \<^sub>_ _" [80, 80, 80] 80)

definition eq_overlapsAsMuchAs :: "'region \<Rightarrow> 'bundle \<Rightarrow> 'region \<Rightarrow> bool"  where
"eq_overlapsAsMuchAs R b R' == R \<ge>\<^sub>o\<^sub>v\<^sub>e\<^sub>r\<^sub>l\<^sub>a\<^sub>p\<^sub>s \<^sub>b R' \<and> R' \<ge>\<^sub>o\<^sub>v\<^sub>e\<^sub>r\<^sub>l\<^sub>a\<^sub>p\<^sub>s \<^sub>b R"

notation
  eq_overlapsAsMuchAs ("_ \<cong>\<^sub>o\<^sub>v\<^sub>e\<^sub>r\<^sub>l\<^sub>a\<^sub>p\<^sub>s \<^sub>_ _" [80, 80, 80] 80)

abbreviation
rev_overlapsAsMuchAs :: "'region \<Rightarrow> 'bundle \<Rightarrow> 'region \<Rightarrow> bool"  ("_ \<le>\<^sub>o\<^sub>v\<^sub>e\<^sub>r\<^sub>l\<^sub>a\<^sub>p\<^sub>s \<^sub>_ _" [80, 80, 80] 80)
where"rev_overlapsAsMuchAs R b R' == overlapsAsMuchAs R' b R"

definition more_overlapsAsMuchAs :: "'region \<Rightarrow> 'bundle \<Rightarrow> 'region \<Rightarrow> bool"  where
"more_overlapsAsMuchAs R b R' == R \<ge>\<^sub>o\<^sub>v\<^sub>e\<^sub>r\<^sub>l\<^sub>a\<^sub>p\<^sub>s \<^sub>b R' \<and> \<not>(R' \<ge>\<^sub>o\<^sub>v\<^sub>e\<^sub>r\<^sub>l\<^sub>a\<^sub>p\<^sub>s \<^sub>b R)"

notation
  more_overlapsAsMuchAs ("_ >\<^sub>o\<^sub>v\<^sub>e\<^sub>r\<^sub>l\<^sub>a\<^sub>p\<^sub>s \<^sub>_ _" [80, 80, 80] 80)

abbreviation
less_overlapsAsMuchAs :: "'region \<Rightarrow> 'bundle \<Rightarrow> 'region \<Rightarrow> bool"  ("_ <\<^sub>o\<^sub>v\<^sub>e\<^sub>r\<^sub>l\<^sub>a\<^sub>p\<^sub>s \<^sub>_ _" [80, 80, 80] 80)
where"less_overlapsAsMuchAs R b R' == more_overlapsAsMuchAs R' b R"

(*Formalise and prove that overlapsAsMuchAs is reflexive and transitive*) (*2 marks*)

lemma overlapsAsMuchAs_reflexive:
(*Write your formalisation and proof that overlapsAsMuchAs is reflexive here*)

lemma overlapsAsMuchAs_transitive:
(*Write your formalisation and proof that overlapsAsMuchAs is transitive here*)

lemma T3: (*Write your formalisation and structured proof of Theorem T3 here. You must attempt to
formalise Kulik et al.'s reasoning*) (*11 marks*)

(*In under 200 words, compare and contrast the mechanical proof that you produced with the
pen-and-paper proof by Kulik et al.\. In particular, indicate any reasoning, proof parts, and/or
useful lemmas that you had to make explicit during the mechanisation but may have been glossed over
 or assumed by the pen-and-paper proof. Also highlight any inaccuracies in their language or
notation. Note any parts where you had to diverge from their reasoning, and why.
Write your answer in a comment here.*) (*4 marks*)

lemma T4: (*Write your formalisation and proof of Theorem T4 here*) (*1 mark*)

lemma T5: (*Write your formalisation and structured proof of Theorem T5 here.
You must show it follows from T4*) (*3 marks*)

(********************Challenge problem****************************************)

definition crosses_isIncludedIn (*Write your definition of the relation ci here.
Kulik et al. say `If a region crosses or is included in a section we write ci'.*) (*2 marks*)

definition crosses_isIncludedInAsMuchAs (*Write your definition of `crosses or is included in as much
as' here*) (*2 marks*)

definition belongsAsMuchAs (*Write your definition of `belongs as much as here: definition D8 in
the paper.*) (*2 marks*)

(*Formalise and write structured proofs of Theorems T6-T8 for both crossesIncludedInAsMuchAs and
belongsAsMuchAs*) (*14 marks*)

lemma T6_crosses_isIncludedInAsMuchAs:

lemma T6_belongsAsMuchAs:

lemma T7_crosses_isIncludedInAsMuchAs:

lemma T7_belongsAsMuchAs:

lemma T8_crosses_isIncludedInAsMuchAs:

lemma T8_belongsAsMuchAs:

end

end


(*  Title:      ListPre.thy
    Author:     Ludovic Henrio and Florian Kammuller, 2006

List lemmata and other general stuff as preparation for ASP.
*)

section \<open>List features\<close>

theory ListPre
imports Main
begin

lemma drop_lem[rule_format]:
  fixes n :: nat and l :: "'a list" and g :: "'a list"
  assumes "drop n l = drop n g" and "length l = length g" and "n < length g"
  shows "l!n = g!n"
proof -
  from assms(2-3) have "n < length l" by simp
  from Cons_nth_drop_Suc[OF this] Cons_nth_drop_Suc[OF assms(3)] assms(1)
  have "l!n # drop (Suc n) l = g!n # drop (Suc n) g" by simp
  thus ?thesis by simp
qed

lemma mem_append_lem': "x \<in> set (l @ [y]) \<Longrightarrow> x \<in> set l \<or> x = y"
  by auto

lemma nth_last: "length l = n \<Longrightarrow> (l @ [x])!n = x"
  by auto

lemma take_n:
  fixes n :: nat and l :: "'a list" and g :: "'a list"
  assumes "take n l = take n g" and "Suc n \<le> length g" and "length l = length g"
  shows "take (Suc n) (l[n := g!n]) = take (Suc n) g"
proof -
  from assms(2) have ng: "n < length g" by simp
  with assms(3) have nlupd: "n < length (l[n := g!n])" by simp
  hence nl: "n < length l" by simp
  from
    sym[OF assms(1)] id_take_nth_drop[OF ng] take_Suc_conv_app_nth[OF nlupd]
    nth_list_update_eq[OF nl] take_Suc_conv_app_nth[OF ng]
    upd_conv_take_nth_drop[OF nl] assms(2-3)
  show ?thesis by simp
qed

lemma drop_n_lem:
  fixes n :: nat and l :: "'a list"
  assumes "Suc n \<le> length l"
  shows "drop (Suc n) (l[n := x]) = drop (Suc n) l"
proof -
  from assms have "n < length l" by simp
  from
    upd_conv_take_nth_drop[OF this] drop_Suc[of n "l[n := x]"]
    drop_Suc[of n l] assms
  show ?thesis by (simp,(subst drop_tl)+, simp)
qed

lemma drop_n:
  fixes n :: nat and l :: "'a list" and g :: "'a list"
  assumes "drop n l = drop n g" and "Suc n \<le> length g" and "length l = length g"
  shows "drop (Suc n) (l[n := g!n]) = drop (Suc n) g"
proof -
  from assms(2-3) have "Suc n \<le> length l" by simp
  from drop_n_lem[OF this] assms(1) show ?thesis
    by (simp, (subst drop_Suc)+, (subst drop_tl)+, simp)
qed

lemma nth_fst[rule_format]: "length l = n + 1 \<longrightarrow> (l @ [x])!0 = l!0"
  by (induct l, simp_all)

lemma nth_zero_app:
  fixes l :: "'a list" and x :: 'a and y :: 'a
  assumes "l \<noteq> []" and "l!0 = x"
  shows"(l @ [y])!0 = x"
proof -
  have "l \<noteq> [] \<and> l!0 = x \<longrightarrow> (l @ [y])!0 = x"
    by (induct l, simp_all)
  with assms show ?thesis by simp
qed

lemma rev_induct2[consumes 1]:
  fixes xs :: "'a list" and ys :: "'a list" and P :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  assumes
  "length xs = length ys" and "P [] []" and
  "\<And>x xs y ys. \<lbrakk> length xs = length ys; P xs ys \<rbrakk> \<Longrightarrow> P (xs @ [x]) (ys @ [y])"
  shows "P xs ys"
proof (simplesubst rev_rev_ident[symmetric])
  from assms(1) have lrev: "length (rev xs) = length (rev ys)" by simp
  from assms have "P (rev (rev xs))(rev (rev ys))"
    by (induct rule: list_induct2[OF lrev], simp_all)
  thus "P xs (rev (rev ys))" by simp
qed

lemma list_induct3: (* Similar to induction for 2: see ML "thm \"list_induct2\""; *)
  "\<And>ys zs. \<lbrakk> length xs = length ys; length zs = length xs; P [] [] [];
              \<And>x xs y ys z zs. \<lbrakk> length xs = length ys;
                                    length zs = length xs; P xs ys zs \<rbrakk>
                                 \<Longrightarrow> P (x # xs)(y # ys)(z # zs)
  \<rbrakk> \<Longrightarrow> P xs ys zs"
proof (induct xs, simp)
  case (Cons a xs ys zs)
  from \<open>length (a#xs) = length ys\<close> \<open>length zs = length (a#xs)\<close>
  have "ys \<noteq> [] \<and> zs \<noteq> []" by auto
  then obtain b ly c lz where "ys = b#ly" and "zs = c#lz"
    by (auto simp: neq_Nil_conv)
  with \<open>length (a#xs) = length ys\<close> \<open>length zs = length (a#xs)\<close>
  obtain "length xs = length ly" and "length lz = length xs"
    by auto
  from
    Cons(5)[OF this Cons(1)[OF this \<open>P [] [] []\<close>]]
    Cons(5) \<open>ys = b#ly\<close> \<open>zs = c#lz\<close>
  show ?case by simp
qed

primrec list_insert :: "'a list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "list_insert (ah#as) i a =
  (case i of
        0      \<Rightarrow> a#ah#as
       |Suc j  \<Rightarrow> ah#(list_insert as j a))" |

  "list_insert [] i a = [a]"

lemma insert_eq[simp]: "\<forall>i\<le>length l. (list_insert l i a)!i = a"
  by (induct l, simp, intro strip, simp split: nat.split)

lemma insert_gt[simp]: "\<forall>i\<le>length l. \<forall>j<i. (list_insert  l i a)!j = l!j"
proof (induct l, simp)
  case (Cons x l) thus ?case
  proof (auto split: nat.split)
    fix n j assume "n \<le> length l" and "j < Suc n"
    with Cons(1) show "(x#(list_insert l n a))!j = (x#l)!j"
      by (cases j) simp_all
  qed
qed

lemma insert_lt[simp]: "\<forall>j\<le>length l. \<forall>i\<le>j. (list_insert l i a)!Suc j = l!j"
proof (induct l, simp)
  case (Cons x l) thus ?case
  proof (auto split: nat.split)
    fix n j assume "j \<le> Suc (length l)" and "Suc n \<le> j"
    with Cons(1) show "(list_insert l n a)!j = l!(j - Suc 0)"
      by (cases j) simp_all
  qed
qed

lemma insert_first[simp]: "list_insert l 0 b = b#l"
  by (induct l, simp_all)

lemma insert_prepend[simp]:
  "i = Suc j \<Longrightarrow> list_insert (a#l) i b = a # list_insert l j b"
  by auto

lemma insert_lt2[simp]: "\<forall>j. \<forall>i\<le>j. (list_insert  l i a)!Suc j = l!j"
proof (induct l, simp)
  case (Cons x l) thus ?case
  proof (auto split: nat.split)
    fix n j assume "Suc n \<le> j"
    with Cons(1) show "(list_insert l n a)!j = l!(j - Suc 0)"
      by (cases j) simp_all
  qed
qed

lemma insert_commute[simp]:
  "\<forall>i\<le>length l. (list_insert (list_insert l i b) 0 a) =
                 (list_insert (list_insert l 0 a ) (Suc i) b)"
  by (induct l, auto split: nat.split)

lemma insert_length': "\<And>i x. length (list_insert l i x) = length (x#l)"
  by (induct l, auto split: nat.split)

lemma insert_length[simp]: "length (list_insert l i b) = length (list_insert l j c)"
  by (simp add: insert_length')

lemma insert_select[simp]: "the ((f(l \<mapsto> t)) l) = t"
  by auto

lemma dom_insert[simp]: "l \<in> dom f \<Longrightarrow> dom (f(l \<mapsto> t)) = dom f"
  by auto

lemma insert_select2[simp]: "l1 \<noteq> l2 \<Longrightarrow> ((f(l1 \<mapsto> t)) l2) = (f l2)"
  by auto

lemma the_insert_select[simp]:
  "\<lbrakk> l2 \<in> dom f; l1 \<noteq> l2 \<rbrakk> \<Longrightarrow>  the ((f(l1 \<mapsto> t)) l2) =  the (f l2)"
  by auto

lemma insert_dom_eq: "dom f = dom f' \<Longrightarrow> dom (f(l \<mapsto> x)) = dom (f'(l \<mapsto> x'))"
  by auto

lemma insert_dom_less_eq:
  "\<lbrakk> x \<notin> dom f; x \<notin> dom f'; dom (f(x \<mapsto> y)) = dom (f'(x \<mapsto> y')) \<rbrakk>
  \<Longrightarrow> dom f = dom f'"
  by auto

lemma one_more_dom[rule_format]:
  "\<forall>l\<in>dom f . \<exists>f'. f = f'(l \<mapsto> the(f l)) \<and> l \<notin> dom f'"
proof
  fix l assume "l \<in> dom f"
  hence "\<And>la. f la = ((\<lambda>la. if la = l then None else f la)(l \<mapsto> the (f l))) la"
    by auto
  hence "f = (\<lambda>la. if la = l then None else f la)(l \<mapsto> the (f l))"
    by (rule ext)
  thus "\<exists>f'. f = f'(l \<mapsto> the(f l) ) \<and> l \<notin> dom f'" by auto
qed

end