(*  Title:   Product_QuasiBorel.thy
    Author:  Michikazu Hirata, Tokyo Institute of Technology
*)

subsubsection \<open> Product Spaces\<close>
theory Product_QuasiBorel

imports "Binary_Product_QuasiBorel"

begin

definition prod_qbs_Mx :: "['a set, 'a \<Rightarrow> 'b quasi_borel] \<Rightarrow> (real \<Rightarrow> 'a \<Rightarrow> 'b) set" where
"prod_qbs_Mx I M \<equiv> { \<alpha> | \<alpha>. \<forall>i. (i \<in> I \<longrightarrow> (\<lambda>r. \<alpha> r i) \<in> qbs_Mx (M i)) \<and> (i \<notin> I \<longrightarrow> (\<lambda>r. \<alpha> r i) = (\<lambda>r. undefined))}"

lemma prod_qbs_MxI:
  assumes "\<And>i. i \<in> I \<Longrightarrow> (\<lambda>r. \<alpha> r i) \<in> qbs_Mx (M i)"
      and "\<And>i. i \<notin> I \<Longrightarrow> (\<lambda>r. \<alpha> r i) = (\<lambda>r. undefined)"
    shows "\<alpha> \<in> prod_qbs_Mx I M"
  using assms by(auto simp: prod_qbs_Mx_def)

lemma prod_qbs_MxE:
  assumes "\<alpha> \<in> prod_qbs_Mx I M"
  shows "\<And>i. i \<in> I \<Longrightarrow> (\<lambda>r. \<alpha> r i) \<in> qbs_Mx (M i)"
    and "\<And>i. i \<notin> I \<Longrightarrow> (\<lambda>r. \<alpha> r i) = (\<lambda>r. undefined)"
    and "\<And>i r. i \<notin> I \<Longrightarrow> \<alpha> r i = undefined"
  using assms by(auto simp: prod_qbs_Mx_def dest: fun_cong[where g="(\<lambda>r. undefined)"])

definition PiQ :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b quasi_borel) \<Rightarrow> ('a \<Rightarrow> 'b) quasi_borel" where
"PiQ I M \<equiv> Abs_quasi_borel (\<Pi>\<^sub>E i\<in>I. qbs_space (M i), prod_qbs_Mx I M)"

syntax
  "_PiQ" :: "pttrn \<Rightarrow> 'i set \<Rightarrow> 'a quasi_borel \<Rightarrow> ('i => 'a) quasi_borel"  ("(3\<Pi>\<^sub>Q _\<in>_./ _)"  10)
translations
  "\<Pi>\<^sub>Q x\<in>I. M" == "CONST PiQ I (\<lambda>x. M)"

lemma PiQ_f: "prod_qbs_Mx I M \<subseteq> UNIV \<rightarrow> (\<Pi>\<^sub>E i\<in>I. qbs_space (M i))"
  using prod_qbs_MxE by fastforce

lemma PiQ_closed1: "qbs_closed1 (prod_qbs_Mx I M)"
proof(rule qbs_closed1I)
  fix \<alpha> f
  assume h:"\<alpha> \<in> prod_qbs_Mx I M "
           "f \<in> real_borel \<rightarrow>\<^sub>M real_borel"
  show "\<alpha> \<circ> f \<in> prod_qbs_Mx I M"
  proof(rule prod_qbs_MxI)
    fix i
    assume "i \<in> I"
    from prod_qbs_MxE(1)[OF h(1) this]
    have "(\<lambda>r. \<alpha> r i) \<circ> f \<in> qbs_Mx (M i)"
      using h(2) by auto
    thus "(\<lambda>r. (\<alpha> \<circ> f) r i) \<in> qbs_Mx (M i)"
      by(simp add: comp_def)
  next
    fix i
    assume "i \<notin> I"
    from prod_qbs_MxE(3)[OF h(1) this]
    show "(\<lambda>r. (\<alpha> \<circ> f) r i) = (\<lambda>r. undefined)"
      by simp
  qed
qed

lemma PiQ_closed2: "qbs_closed2 (\<Pi>\<^sub>E i\<in>I. qbs_space (M i)) (prod_qbs_Mx I M)"
proof(rule qbs_closed2I)
  fix x
  assume h:"x \<in> (\<Pi>\<^sub>E i\<in>I. qbs_space (M i))"
  show "(\<lambda>r. x) \<in> prod_qbs_Mx I M"
  proof(rule prod_qbs_MxI)
    fix i
    assume hi:"i \<in> I"
    then have "x i \<in> qbs_space (M i)"
      using h by auto
    thus "(\<lambda>r. x i) \<in> qbs_Mx (M i)"
      by auto
  next
    show "\<And>i. i \<notin> I \<Longrightarrow> (\<lambda>r. x i) = (\<lambda>r. undefined)"
      using h by auto
  qed
qed

lemma PiQ_closed3: "qbs_closed3 (prod_qbs_Mx I M)"
proof(rule qbs_closed3I)
  fix P Fi
  assume h:"\<And>i::nat. P -` {i} \<in> sets real_borel"
           "\<And>i::nat. Fi i \<in> prod_qbs_Mx I M"
  show "(\<lambda>r. Fi (P r) r) \<in> prod_qbs_Mx I M"
  proof(rule prod_qbs_MxI)
    fix i
    assume hi:"i \<in> I"
    show "(\<lambda>r. Fi (P r) r i) \<in> qbs_Mx (M i)"
      using prod_qbs_MxE(1)[OF h(2) hi] qbs_closed3_dest[OF h(1),of "\<lambda>j r. Fi j r i"]
      by auto
  next
    show "\<And>i. i \<notin> I \<Longrightarrow>
         (\<lambda>r. Fi (P r) r i) = (\<lambda>r. undefined)"
      using prod_qbs_MxE[OF h(2)] by auto
  qed
qed

lemma PiQ_correct: "Rep_quasi_borel (PiQ I M) = (\<Pi>\<^sub>E i\<in>I. qbs_space (M i), prod_qbs_Mx I M)"
  by(auto intro!: Abs_quasi_borel_inverse PiQ_f is_quasi_borel_intro simp: PiQ_def PiQ_closed1 PiQ_closed2 PiQ_closed3)

lemma PiQ_space[simp]: "qbs_space (PiQ I M) = (\<Pi>\<^sub>E i\<in>I. qbs_space (M i))"
  by(simp add: qbs_space_def PiQ_correct)

lemma PiQ_Mx[simp]: "qbs_Mx (PiQ I M) = prod_qbs_Mx I M"
  by(simp add: qbs_Mx_def PiQ_correct)

lemma qbs_morphism_component_singleton:
  assumes "i \<in> I"
  shows "(\<lambda>x. x i) \<in> (\<Pi>\<^sub>Q i\<in>I. (M i)) \<rightarrow>\<^sub>Q M i"
  by(auto intro!: qbs_morphismI simp: prod_qbs_Mx_def comp_def assms)

lemma product_qbs_canonical1:
  assumes "\<And>i. i \<in> I \<Longrightarrow> f i \<in> Y \<rightarrow>\<^sub>Q X i"
      and "\<And>i. i \<notin> I \<Longrightarrow> f i = (\<lambda>y. undefined)"
    shows "(\<lambda>y i. f i y) \<in> Y \<rightarrow>\<^sub>Q (\<Pi>\<^sub>Q i\<in>I. X i)"
  using qbs_morphismE(3)[simplified comp_def,OF assms(1)] assms(2)
  by(auto intro!: qbs_morphismI prod_qbs_MxI)

lemma product_qbs_canonical2:
  assumes "\<And>i. i \<in> I \<Longrightarrow> f i \<in> Y \<rightarrow>\<^sub>Q X i"
          "\<And>i. i \<notin> I \<Longrightarrow> f i = (\<lambda>y. undefined)"
          "g \<in> Y \<rightarrow>\<^sub>Q (\<Pi>\<^sub>Q i\<in>I. X i)"
          "\<And>i. i \<in> I \<Longrightarrow> f i = (\<lambda>x. x i) \<circ> g"
      and "y \<in> qbs_space Y"
    shows "g y = (\<lambda>i. f i y)"
proof(rule ext)+
  fix i
  show "g y i = f i y"
  proof(cases "i \<in> I")
    case True
    then show ?thesis
      using assms(4)[of i] by simp
  next
    case False
    moreover have "(\<lambda>r. y) \<in> qbs_Mx Y"
      using assms(5) by simp
    ultimately show ?thesis
      using assms(2,3) qbs_morphismE(3)[OF assms(3) _]
      by(fastforce simp: prod_qbs_Mx_def)
  qed
qed

lemma merge_qbs_morphism:
 "merge I J \<in> (\<Pi>\<^sub>Q i\<in>I. (M i)) \<Otimes>\<^sub>Q (\<Pi>\<^sub>Q j\<in>J. (M j)) \<rightarrow>\<^sub>Q (\<Pi>\<^sub>Q i\<in>I\<union>J. (M i))"
proof(rule qbs_morphismI)
  fix \<alpha>
  assume h:"\<alpha> \<in> qbs_Mx ((\<Pi>\<^sub>Q i\<in>I. (M i)) \<Otimes>\<^sub>Q (\<Pi>\<^sub>Q j\<in>J. (M j)))"
  show "merge I J \<circ> \<alpha> \<in> qbs_Mx (\<Pi>\<^sub>Q i\<in>I\<union>J. (M i))"
  proof(simp, rule prod_qbs_MxI)
    fix i
    assume "i \<in> I \<union> J"
    then consider "i \<in> I" | "i \<in> I \<and> i \<in> J" | "i \<notin> I \<and> i \<in> J"
      by auto
    then show "(\<lambda>r. (merge I J \<circ> \<alpha>) r i) \<in> qbs_Mx (M i)"
      apply cases
      using h
      by(auto simp: merge_def pair_qbs_Mx_def split_beta' dest: prod_qbs_MxE)
  next
    fix i
    assume "i \<notin> I \<union> J"
    then show "(\<lambda>r. (merge I J \<circ> \<alpha>) r i) = (\<lambda>r. undefined)"
      using h
      by(auto simp: merge_def pair_qbs_Mx_def split_beta' dest: prod_qbs_MxE )
  qed
qed

text \<open> The following lemma corresponds to \<^cite>\<open>"Heunen_2017"\<close> Proposition 19(1). \<close>
lemma r_preserves_product':
  "measure_to_qbs (\<Pi>\<^sub>M i\<in>I. M i) = (\<Pi>\<^sub>Q i\<in>I. measure_to_qbs (M i))"
proof(rule qbs_eqI)
  show "qbs_Mx (measure_to_qbs (Pi\<^sub>M I M)) = qbs_Mx (\<Pi>\<^sub>Q i\<in>I. measure_to_qbs (M i))"
  proof auto
    fix f
    assume h:"f \<in> real_borel \<rightarrow>\<^sub>M Pi\<^sub>M I M"
    show "f \<in> prod_qbs_Mx I (\<lambda>i. measure_to_qbs (M i))"
    proof(rule prod_qbs_MxI)
      fix i
      assume 1:"i \<in> I"
      show "(\<lambda>r. f r i) \<in> qbs_Mx (measure_to_qbs (M i))"
        using measurable_comp[OF h measurable_component_singleton[OF 1,of M]]
        by (simp add: comp_def)
    next
      fix i
      assume 1:"i \<notin> I"
      then show "(\<lambda>r. f r i) = (\<lambda>r. undefined)"
        using measurable_space[OF h] 1
        by(auto simp: space_PiM PiE_def extensional_def)
    qed
  next
    fix f
    assume h:"f \<in> prod_qbs_Mx I (\<lambda>i. measure_to_qbs (M i))"
    show "f \<in> real_borel \<rightarrow>\<^sub>M Pi\<^sub>M I M"
      apply(rule measurable_PiM_single')
      using prod_qbs_MxE(1)[OF h] apply auto[1]
      using PiQ_f[of I M] h by auto
  qed
qed

text \<open> $\prod_{i = 0,1} X_i \cong X_1 \times X_2$. \<close>
lemma product_binary_product:
 "\<exists>f g. f \<in> (\<Pi>\<^sub>Q i\<in>UNIV. if i then X else Y) \<rightarrow>\<^sub>Q X \<Otimes>\<^sub>Q Y \<and> g \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q (\<Pi>\<^sub>Q i\<in>UNIV. if i then X else Y) \<and>
        g \<circ> f = id \<and> f \<circ> g = id"
  by(auto intro!: exI[where x="\<lambda>f. (f True, f False)"] exI[where x="\<lambda>xy b. if b then fst xy else snd xy"] qbs_morphismI
            simp: prod_qbs_Mx_def pair_qbs_Mx_def comp_def all_bool_eq ext)

end


(*  Title:      HOL/HOLCF/Discrete.thy
    Author:     Tobias Nipkow
*)

section {* Discrete cpo types *}

theory Discrete
imports Cont
begin

datatype 'a discr = Discr "'a :: type"

subsection {* Discrete cpo class instance *}

instantiation discr :: (type) discrete_cpo
begin

definition
  "(op \<sqsubseteq> :: 'a discr \<Rightarrow> 'a discr \<Rightarrow> bool) = (op =)"

instance
by default (simp add: below_discr_def)

end

subsection {* \emph{undiscr} *}

definition
  undiscr :: "('a::type)discr => 'a" where
  "undiscr x = (case x of Discr y => y)"

lemma undiscr_Discr [simp]: "undiscr (Discr x) = x"
by (simp add: undiscr_def)

lemma Discr_undiscr [simp]: "Discr (undiscr y) = y"
by (induct y) simp

end


(*
Title: Strong-Security
Authors: Sylvia Grewe, Alexander Lux, Heiko Mantel, Jens Sauer
*)
theory Strongly_Secure_Skip_Assign
imports MWLf Parallel_Composition
begin

locale Strongly_Secure_Programs =
L? : MWLf_semantics "E" "BMap"
+ SS?: Strong_Security "MWLfSteps_det" "DA"
for E :: "('exp, 'id, 'val) Evalfunction"
and BMap :: "'val \<Rightarrow> bool"
and DA :: "('id, 'd::order) DomainAssignment"
begin

abbreviation USdBname ::"'d \<Rightarrow> ('exp, 'id) MWLfCom Bisimulation_type"
("\<approx>\<^bsub>_\<^esub>")
where "\<approx>\<^bsub>d\<^esub> \<equiv> USdB d"

abbreviation relatedbyUSdB :: "('exp,'id) MWLfCom list \<Rightarrow> 'd
  \<Rightarrow> ('exp,'id) MWLfCom list \<Rightarrow> bool" (infixr "\<approx>\<^bsub>_\<^esub>" 65)
where "V \<approx>\<^bsub>d\<^esub> V' \<equiv> (V,V') \<in> USdB d"

\<comment> \<open>define when two expressions are indistinguishable with respect to a domain d\<close>
definition d_indistinguishable :: "'d::order \<Rightarrow> 'exp \<Rightarrow> 'exp \<Rightarrow> bool"
where
"d_indistinguishable d e1 e2 \<equiv>
  \<forall>m m'. ((m =\<^bsub>d\<^esub> m') \<longrightarrow> ((E e1 m) = (E e2 m')))"

abbreviation d_indistinguishable' :: "'exp \<Rightarrow> 'd::order \<Rightarrow> 'exp \<Rightarrow> bool"
( "(_ \<equiv>\<^bsub>_\<^esub> _)" )
where
"e1 \<equiv>\<^bsub>d\<^esub> e2 \<equiv> d_indistinguishable d e1 e2"

\<comment> \<open>symmetry of d-indistinguishable\<close>
lemma d_indistinguishable_sym:
"e \<equiv>\<^bsub>d\<^esub> e' \<Longrightarrow> e' \<equiv>\<^bsub>d\<^esub> e"
by (simp add: d_indistinguishable_def d_equal_def, metis)

\<comment> \<open>transitivity of d-indistinguishable\<close>
lemma d_indistinguishable_trans:
"\<lbrakk> e \<equiv>\<^bsub>d\<^esub> e'; e' \<equiv>\<^bsub>d\<^esub> e'' \<rbrakk> \<Longrightarrow> e \<equiv>\<^bsub>d\<^esub> e''"
by (simp add: d_indistinguishable_def d_equal_def, metis)

theorem Strongly_Secure_Skip:
"[skip] \<approx>\<^bsub>d\<^esub> [skip]"
proof -
  define R0 where "R0 = {(V::('exp,'id) MWLfCom list,V'::('exp,'id) MWLfCom list).
    V = [skip] \<and> V' = [skip]}"

  have uptoR0: "d_Bisimulation_Up_To_USdB d R0"
    proof (simp add: d_Bisimulation_Up_To_USdB_def, auto)
      show "sym R0" by (simp add: R0_def sym_def)
    next
      fix V V'
      assume "(V,V') \<in> R0"
      thus "length V = length V'"
        by (simp add: R0_def)
    next
      fix V V' i m1 m1' W m2
      assume inR0: "(V,V') \<in> R0"
      assume irange: "i < length V"
      assume step: "\<langle>V!i,m1\<rangle> \<rightarrow> \<langle>W,m2\<rangle>"
      assume dequal: "m1 =\<^bsub>d\<^esub> m1'"

      from inR0 have Vassump:
        "V = [skip] \<and> V' = [skip]"
        by (simp add: R0_def)

      with step irange have step1:
        "W = [] \<and> m2 = m1"
        by (simp, metis MWLf_semantics.MWLfSteps_det_cases(1))

      from Vassump irange obtain m2' where step2:
        "\<langle>V'!i,m1'\<rangle> \<rightarrow> \<langle>[],m2'\<rangle> \<and> m2' = m1'"
         by (simp, metis MWLfSteps_det.skip)

      with step1 dequal trivialpair_in_USdB show "\<exists>W' m2'.
        \<langle>V'!i,m1'\<rangle> \<rightarrow> \<langle>W',m2'\<rangle> \<and>
        ((W,W') \<in> R0 \<or> W \<approx>\<^bsub>d\<^esub> W') \<and> m2 =\<^bsub>d\<^esub> m2'"
        by auto
   qed

   hence "R0 \<subseteq> \<approx>\<^bsub>d\<^esub>"
     by (rule Up_To_Technique)

   thus ?thesis
     by (simp add: R0_def)

qed

theorem Strongly_Secure_Assign:
  assumes d_indistinguishable_exp: "e \<equiv>\<^bsub>DA x\<^esub> e'"
  shows "[x := e] \<approx>\<^bsub>d\<^esub> [x := e']"
proof -
  define R0 where "R0 = {(V,V'). \<exists>x e e'. V = [x := e] \<and> V' = [x := e'] \<and>
    e \<equiv>\<^bsub>DA x\<^esub> e'}"

  from d_indistinguishable_exp have inR0: "([x:=e],[x:=e']) \<in> R0"
    by (simp add: R0_def)

  have "d_Bisimulation_Up_To_USdB d R0"
    proof (simp add: d_Bisimulation_Up_To_USdB_def, auto)
      from d_indistinguishable_sym show "sym R0"
        by (simp add: R0_def sym_def, fastforce)
    next
      fix V V'
      assume "(V,V') \<in> R0"
      thus "length V = length V'"
        by (simp add: R0_def, auto)
    next
      fix V V' i m1 m1' W m2
      assume inR0: "(V,V') \<in> R0"
      assume irange: "i < length V"
      assume step: "\<langle>V!i,m1\<rangle> \<rightarrow> \<langle>W,m2\<rangle>"
      assume dequal: "m1 =\<^bsub>d\<^esub> m1'"

      from inR0 obtain x e e' where Vassump:
        "V = [x := e] \<and> V' = [x := e'] \<and>
        e \<equiv>\<^bsub>DA x\<^esub> e'"
        by (simp add: R0_def, auto)

      with step irange obtain v where step1:
        "E e m1 = v \<and> W = [] \<and> m2 = m1(x := v)"
        by (auto, metis MWLf_semantics.MWLfSteps_det_cases(2))

      from Vassump irange obtain m2' v' where step2:
        "E e' m1' = v' \<and> \<langle>V'!i,m1'\<rangle> \<rightarrow> \<langle>[],m2'\<rangle> \<and> m2' = m1'(x := v')"
        by (auto, metis MWLfSteps_det.assign)

      with Vassump dequal step step1
      have dequalnext: "m1(x := v) =\<^bsub>d\<^esub> m1'(x := v')"
        by (simp add: d_equal_def d_indistinguishable_def, auto)

      with step1 step2 trivialpair_in_USdB show "\<exists>W' m2'.
        \<langle>V'!i,m1'\<rangle> \<rightarrow> \<langle>W',m2'\<rangle> \<and> ((W,W') \<in> R0 \<or> W \<approx>\<^bsub>d\<^esub> W')
        \<and> m2 =\<^bsub>d\<^esub> m2'"
        by auto
   qed

   hence "R0 \<subseteq> \<approx>\<^bsub>d\<^esub>"
     by (rule Up_To_Technique)

   with inR0 show ?thesis
     by auto

qed

end

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_weird_nat_mul2_assoc
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun add3acc :: "Nat => Nat => Nat => Nat" where
"add3acc (Z) (Z) z = z"
| "add3acc (Z) (S x3) z = add3acc Z x3 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

fun mul2 :: "Nat => Nat => Nat" where
"mul2 (Z) y = Z"
| "mul2 (S z) (Z) = Z"
| "mul2 (S z) (S x2) = plus (S Z) (add3acc z x2 (mul2 z x2))"

theorem property0 :
  "((mul2 x (mul2 y z)) = (mul2 (mul2 x y) z))"
  oops

end


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

section \<open>Infinite branching datatype definitions\<close>

theory Brouwer imports Main_ZFC begin

subsection \<open>The Brouwer ordinals\<close>

consts
  brouwer :: i

datatype \<subseteq> "Vfrom(0, csucc(nat))"
    "brouwer" = Zero | Suc ("b \<in> brouwer") | Lim ("h \<in> nat -> brouwer")
  monos Pi_mono
  type_intros inf_datatype_intros

lemma brouwer_unfold: "brouwer = {0} + brouwer + (nat -> brouwer)"
  by (fast intro!: brouwer.intros [unfolded brouwer.con_defs]
    elim: brouwer.cases [unfolded brouwer.con_defs])

lemma brouwer_induct2 [consumes 1, case_names Zero Suc Lim]:
  assumes b: "b \<in> brouwer"
    and cases:
      "P(Zero)"
      "!!b. [| b \<in> brouwer;  P(b) |] ==> P(Suc(b))"
      "!!h. [| h \<in> nat -> brouwer;  \<forall>i \<in> nat. P(h`i) |] ==> P(Lim(h))"
  shows "P(b)"
  \<comment> \<open>A nicer induction rule than the standard one.\<close>
  using b
  apply induct
    apply (rule cases(1))
   apply (erule (1) cases(2))
  apply (rule cases(3))
   apply (fast elim: fun_weaken_type)
  apply (fast dest: apply_type)
  done

subsection \<open>The Martin-Löf wellordering type\<close>

consts
  Well :: "[i, i => i] => i"

datatype \<subseteq> "Vfrom(A \<union> (\<Union>x \<in> A. B(x)), csucc(nat \<union> |\<Union>x \<in> A. B(x)|))"
    \<comment> \<open>The union with \<open>nat\<close> ensures that the cardinal is infinite.\<close>
  "Well(A, B)" = Sup ("a \<in> A", "f \<in> B(a) -> Well(A, B)")
  monos Pi_mono
  type_intros le_trans [OF UN_upper_cardinal le_nat_Un_cardinal] inf_datatype_intros

lemma Well_unfold: "Well(A, B) = (\<Sum>x \<in> A. B(x) -> Well(A, B))"
  by (fast intro!: Well.intros [unfolded Well.con_defs]
    elim: Well.cases [unfolded Well.con_defs])

lemma Well_induct2 [consumes 1, case_names step]:
  assumes w: "w \<in> Well(A, B)"
    and step: "!!a f. [| a \<in> A;  f \<in> B(a) -> Well(A,B);  \<forall>y \<in> B(a). P(f`y) |] ==> P(Sup(a,f))"
  shows "P(w)"
  \<comment> \<open>A nicer induction rule than the standard one.\<close>
  using w
  apply induct
  apply (assumption | rule step)+
   apply (fast elim: fun_weaken_type)
  apply (fast dest: apply_type)
  done

lemma Well_bool_unfold: "Well(bool, \<lambda>x. x) = 1 + (1 -> Well(bool, \<lambda>x. x))"
  \<comment> \<open>In fact it's isomorphic to \<open>nat\<close>, but we need a recursion operator\<close>
  \<comment> \<open>for \<open>Well\<close> to prove this.\<close>
  apply (rule Well_unfold [THEN trans])
  apply (simp add: Sigma_bool succ_def)
  done

end


(*
  Author: Jose Divasón
  Email:  jose.divason@unirioja.es
*)

section \<open>Smith normal form algorithm based on two steps in JNF\<close>

theory SNF_Algorithm_Two_Steps_JNF
  imports
  Diagonalize
  Diagonal_To_Smith_JNF
begin

subsection \<open>Moving the result from HOL Analysis to JNF\<close>
context diagonalize
begin

definition "Smith_normal_form_of_JNF A bezout = (
   let (P'',D,Q'') = diagonalize_JNF A bezout;
       (P',S,Q') = diagonal_to_Smith_PQ_JNF D bezout
   in (P'*P'',S,Q''*Q')
  )"

(*Soundness theorem in the JNF library*)

lemma Smith_normal_form_of_JNF_soundness:
  assumes b: "is_bezout_ext bezout" and A: "A \<in> carrier_mat m n"
  and n: "1 < n" and m: "1 < m" (*Same as previously, those assumptions arose from the requirements
of mod_type. They could be dropped proving them as particular cases*)
  and PSQ: "Smith_normal_form_of_JNF A bezout = (P,S,Q)"
shows "S = P*A*Q \<and> invertible_mat P \<and> invertible_mat Q \<and> Smith_normal_form_mat S
  \<and> P \<in> carrier_mat m m \<and> S \<in> carrier_mat m n \<and> Q\<in> carrier_mat n n"
proof -
  obtain P'' D Q'' where PDQ_diag: "(P'',D,Q'') = diagonalize_JNF A bezout"
    by (metis prod_cases3)
  have 1: "invertible_mat P'' \<and> invertible_mat Q'' \<and> isDiagonal_mat D \<and> D = P''*A*Q''
      \<and> P'' \<in> carrier_mat m m \<and> Q'' \<in> carrier_mat n n \<and> D \<in> carrier_mat m n"
    using soundness_diagonalize_JNF'[OF b A PDQ_diag[symmetric]] by auto
  obtain P' Q' where PSQ_D: "(P',S,Q') = diagonal_to_Smith_PQ_JNF D bezout"
    using PSQ PDQ_diag unfolding Smith_normal_form_of_JNF_def Let_def split_beta
    by (metis Pair_inject prod.collapse)
  have 2: "invertible_mat P' \<and> invertible_mat Q' \<and> Smith_normal_form_mat S \<and> S = P'*D*Q'
    \<and> P' \<in> carrier_mat m m \<and> Q' \<in> carrier_mat n n \<and> S \<in> carrier_mat m n"
    using diagonal_to_Smith_PQ_JNF[OF _ b _ PSQ_D n m] 1 n m by auto
  have P: "P = P'*P''"
    by (metis (no_types, lifting) PDQ_diag PSQ PSQ_D Smith_normal_form_of_JNF_def fst_conv prod.simps(2))
  have Q: "Q = Q''*Q'"
    by (metis (no_types, lifting) PDQ_diag PSQ PSQ_D Smith_normal_form_of_JNF_def snd_conv prod.simps(2))
  have "S = P'*(P''*A*Q'')*Q'" using 1 2 by auto
  also have "... = (P'*P'')*A*(Q''*Q')"
    by (smt "1" "2" A assoc_mult_mat carrier_matD carrier_mat_triv index_mult_mat)
  finally have "S = (P' * P'') * A * (Q'' * Q')" .
  moreover have "invertible_mat P" unfolding P by (rule invertible_mult_JNF, insert 1 2, auto)
  moreover have "invertible_mat Q" unfolding Q by (rule invertible_mult_JNF, insert 1 2, auto)
  ultimately show ?thesis using 1 2 P Q by auto
qed

end
end


(*  Title:      HOL/Proofs/ex/Hilbert_Classical.thy
    Author:     Stefan Berghofer and Markus Wenzel, TU Muenchen
*)

section {* Hilbert's choice and classical logic *}

theory Hilbert_Classical
imports Main
begin

text {*
  Derivation of the classical law of tertium-non-datur by means of
  Hilbert's choice operator (due to M. J. Beeson and J. Harrison).
*}

subsection {* Proof text *}

theorem tnd: "A \<or> \<not> A"
proof -
  let ?P = "\<lambda>X. X = False \<or> X = True \<and> A"
  let ?Q = "\<lambda>X. X = False \<and> A \<or> X = True"

  have a: "?P (Eps ?P)"
  proof (rule someI)
    have "False = False" ..
    thus "?P False" ..
  qed
  have b: "?Q (Eps ?Q)"
  proof (rule someI)
    have "True = True" ..
    thus "?Q True" ..
  qed

  from a show ?thesis
  proof
    assume "Eps ?P = True \<and> A"
    hence A ..
    thus ?thesis ..
  next
    assume P: "Eps ?P = False"
    from b show ?thesis
    proof
      assume "Eps ?Q = False \<and> A"
      hence A ..
      thus ?thesis ..
    next
      assume Q: "Eps ?Q = True"
      have neq: "?P \<noteq> ?Q"
      proof
        assume "?P = ?Q"
        hence "Eps ?P = Eps ?Q" by (rule arg_cong)
        also note P
        also note Q
        finally show False by (rule False_neq_True)
      qed
      have "\<not> A"
      proof
        assume a: A
        have "?P = ?Q"
        proof (rule ext)
          fix x show "?P x = ?Q x"
          proof
            assume "?P x"
            thus "?Q x"
            proof
              assume "x = False"
              from this and a have "x = False \<and> A" ..
              thus "?Q x" ..
            next
              assume "x = True \<and> A"
              hence "x = True" ..
              thus "?Q x" ..
            qed
          next
            assume "?Q x"
            thus "?P x"
            proof
              assume "x = False \<and> A"
              hence "x = False" ..
              thus "?P x" ..
            next
              assume "x = True"
              from this and a have "x = True \<and> A" ..
              thus "?P x" ..
            qed
          qed
        qed
        with neq show False by contradiction
      qed
      thus ?thesis ..
    qed
  qed
qed

subsection {* Proof term of text *}

prf tnd

subsection {* Proof script *}

theorem tnd': "A \<or> \<not> A"
  apply (subgoal_tac
    "(((SOME x. x = False \<or> x = True \<and> A) = False) \<or>
      ((SOME x. x = False \<or> x = True \<and> A) = True) \<and> A) \<and>
     (((SOME x. x = False \<and> A \<or> x = True) = False) \<and> A \<or>
      ((SOME x. x = False \<and> A \<or> x = True) = True))")
  prefer 2
  apply (rule conjI)
  apply (rule someI)
  apply (rule disjI1)
  apply (rule refl)
  apply (rule someI)
  apply (rule disjI2)
  apply (rule refl)
  apply (erule conjE)
  apply (erule disjE)
  apply (erule disjE)
  apply (erule conjE)
  apply (erule disjI1)
  prefer 2
  apply (erule conjE)
  apply (erule disjI1)
  apply (subgoal_tac
    "(\<lambda>x. (x = False) \<or> (x = True) \<and> A) \<noteq>
     (\<lambda>x. (x = False) \<and> A \<or> (x = True))")
  prefer 2
  apply (rule notI)
  apply (drule_tac f = "\<lambda>y. SOME x. y x" in arg_cong)
  apply (drule trans, assumption)
  apply (drule sym)
  apply (drule trans, assumption)
  apply (erule False_neq_True)
  apply (rule disjI2)
  apply (rule notI)
  apply (erule notE)
  apply (rule ext)
  apply (rule iffI)
  apply (erule disjE)
  apply (rule disjI1)
  apply (erule conjI)
  apply assumption
  apply (erule conjE)
  apply (erule disjI2)
  apply (erule disjE)
  apply (erule conjE)
  apply (erule disjI1)
  apply (rule disjI2)
  apply (erule conjI)
  apply assumption
  done

subsection {* Proof term of script *}

prf tnd'

end


subsection \<open>Ground constructions\<close>

theory Ground_Terms
  imports Basic_Utils
begin

subsubsection \<open>Ground terms\<close>

text \<open>This type serves two purposes. First of all, the encoding definitions and proofs are not
littered by cases for variables. Secondly, we can consider tree domains (usually sets of positions),
which become a special case of ground terms. This enables the construction of a term from a
tree domain and a function from positions to symbols.\<close>

datatype 'f gterm =
  GFun (groot_sym: 'f) (gargs: "'f gterm list")

lemma gterm_idx_induct[case_names GFun]:
  assumes "\<And> f ts. (\<And> i. i < length ts \<Longrightarrow> P (ts ! i)) \<Longrightarrow> P (GFun f ts)"
  shows "P t" using assms
  by (induct t) auto

fun term_of_gterm where
  "term_of_gterm (GFun f ts) = Fun f (map term_of_gterm ts)"

fun gterm_of_term where
  "gterm_of_term (Fun f ts) = GFun f (map gterm_of_term ts)"

fun groot where
  "groot (GFun f ts) = (f, length ts)"

lemma groot_sym_groot_conv:
  "groot_sym t = fst (groot t)"
  by (cases t) auto

lemma groot_sym_gterm_of_term:
  "ground t \<Longrightarrow> groot_sym (gterm_of_term t) = fst (the (root t))"
  by (cases t) auto

lemma length_args_length_gargs [simp]:
  "length (args (term_of_gterm t)) = length (gargs t)"
  by (cases t) auto

lemma ground_term_of_gterm [simp]:
  "ground (term_of_gterm s)"
  by (induct s) auto

lemma ground_term_of_gterm' [simp]:
  "term_of_gterm s = Fun f ss \<Longrightarrow> ground (Fun f ss)"
  by (induct s) auto

lemma term_of_gterm_inv [simp]:
  "gterm_of_term (term_of_gterm t) = t"
  by (induct t) (auto intro!: nth_equalityI)

lemma inj_term_of_gterm:
  "inj_on term_of_gterm X"
  by (metis inj_on_def term_of_gterm_inv)

lemma gterm_of_term_inv [simp]:
  "ground t \<Longrightarrow> term_of_gterm (gterm_of_term t) = t"
  by (induct t) (auto 0 0 intro!: nth_equalityI)

lemma ground_term_to_gtermD:
  "ground t \<Longrightarrow> \<exists>t'. t = term_of_gterm t'"
  by (metis gterm_of_term_inv)

lemma map_term_of_gterm [simp]:
  "map_term f g (term_of_gterm t) = term_of_gterm (map_gterm f t)"
  by (induct t) auto

lemma map_gterm_of_term [simp]:
  "ground t \<Longrightarrow> gterm_of_term (map_term f g t) = map_gterm f (gterm_of_term t)"
  by (induct t) auto

lemma gterm_set_gterm_funs_terms:
  "set_gterm t = funs_term (term_of_gterm t)"
  by (induct t) auto

lemma term_set_gterm_funs_terms:
  assumes "ground t"
  shows "set_gterm (gterm_of_term t) = funs_term t"
  using assms by (induct t) auto

lemma vars_term_of_gterm [simp]:
  "vars_term (term_of_gterm t) = {}"
  by (induct t) auto

lemma vars_term_of_gterm_subseteq [simp]:
  "vars_term (term_of_gterm t) \<subseteq> Q \<longleftrightarrow> True"
  by auto

context
  notes conj_cong [fundef_cong]
begin
fun gposs :: "'f gterm \<Rightarrow> pos set" where
  "gposs (GFun f ss) = {[]} \<union> {i # p | i p. i < length ss \<and> p \<in> gposs (ss ! i)}"
end

lemma gposs_Nil [simp]: "[] \<in> gposs s"
  by (cases s) auto

lemma gposs_map_gterm [simp]:
  "gposs (map_gterm f s) = gposs s"
  by (induct s) auto

lemma poss_gposs_conv:
  "poss (term_of_gterm t) = gposs t"
  by (induct t) auto

lemma poss_gposs_mem_conv:
  "p \<in> poss (term_of_gterm t) \<longleftrightarrow> p \<in> gposs t"
  using poss_gposs_conv by auto

lemma gposs_to_poss:
  "p \<in> gposs t \<Longrightarrow> p \<in> poss (term_of_gterm t)"
  by (simp add: poss_gposs_mem_conv)

fun gfun_at :: "'f gterm \<Rightarrow> pos \<Rightarrow> 'f option" where
  "gfun_at (GFun f ts) [] = Some f"
| "gfun_at (GFun f ts) (i # p) = (if i < length ts then gfun_at (ts ! i) p else None)"

abbreviation "exInl \<equiv> case_sum (\<lambda> x. x) (\<lambda> _.undefined)"

lemma gfun_at_gterm_of_term [simp]:
  "ground s \<Longrightarrow> map_option exInl (fun_at s p) = gfun_at (gterm_of_term s) p"
proof (induct p arbitrary: s)
  case Nil then show ?case
    by (cases s) auto
next
  case (Cons i p) then show ?case
    by (cases s) auto
qed

lemmas gfun_at_gterm_of_term' [simp] = gfun_at_gterm_of_term[OF ground_term_of_gterm, unfolded term_of_gterm_inv]

lemma gfun_at_None_ngposs_iff: "gfun_at s p = None \<longleftrightarrow> p \<notin> gposs s"
  by (induct rule: gfun_at.induct) auto

lemma gfun_at_map_gterm [simp]:
  "gfun_at (map_gterm f t) p = map_option f (gfun_at t p)"
  by (induct t arbitrary: p; case_tac p) (auto simp: comp_def)

lemma set_gterm_gposs_conv:
  "set_gterm t = {the (gfun_at t p) | p. p \<in> gposs t}"
proof (induct t)
  case (GFun f ts)
  note [simp] = gfun_at_gterm_of_term[OF ground_term_of_gterm, unfolded term_of_gterm_inv]
  have [simp]: "{the (map_option exInl (fun_at (Fun f (map term_of_gterm ts :: (_, unit) term list)) p)) |p.
    \<exists>i pa. p = i # pa \<and> i < length ts \<and> pa \<in> gposs (ts ! i)} =
    (\<Union>x\<in>{ts ! i |i. i < length ts}. {the (gfun_at x p) |p. p \<in> gposs x})" (* eww *)
    unfolding UNION_eq
  proof ((intro set_eqI iffI; elim CollectE exE bexE conjE), goal_cases lr rl)
    case (lr x p i pa) then show ?case
      by (intro CollectI[of _ x] bexI[of _ "ts ! i"] exI[of _ pa]) (auto intro!: arg_cong[where ?f = the])
  next
    case (rl x xa i p) then show ?case
      by (intro CollectI[of _ x] exI[of _ "i # p"]) auto
  qed
  have [simp]: "(\<Union>x\<in>{ts ! i |i. i < length ts}. {the (gfun_at x p) |p. p \<in> gposs x}) =
    {the (gfun_at (GFun f ts) p) |p. \<exists>i pa. p = i # pa \<and> i < length ts \<and> pa \<in> gposs (ts ! i)}"
    by auto (metis gfun_at.simps(2))+
  show ?case
    by (simp add: GFun(1) set_conv_nth conj_disj_distribL ex_disj_distrib Collect_disj_eq)
qed

text \<open>A @{type gterm} version of lemma @{verbatim eq_term_by_poss_fun_at}.\<close>

lemma fun_at_gfun_at_conv:
  "fun_at (term_of_gterm s) p = fun_at (term_of_gterm t) p \<longleftrightarrow> gfun_at s p = gfun_at t p"
proof (induct p arbitrary: s t)
  case Nil then show ?case
    by (cases s; cases t) auto
next
  case (Cons i p)
  obtain f h ss ts where [simp]: "s = GFun f ss" "t = GFun h ts" by (cases s; cases t) auto
  have [simp]: "None = fun_at (term_of_gterm (ts ! i)) p \<longleftrightarrow> p \<notin> gposs (ts ! i)"
    using fun_at_None_nposs_iff by (metis poss_gposs_mem_conv)
  have [simp]:"None = gfun_at (ts ! i) p \<longleftrightarrow> p \<notin> gposs (ts ! i)"
    using gfun_at_None_ngposs_iff by force
  show ?case using Cons[of "gargs s ! i" "gargs t ! i"]
    by (auto simp: poss_gposs_conv gfun_at_None_ngposs_iff fun_at_None_nposs_iff
       intro!: iffD2[OF gfun_at_None_ngposs_iff] iffD2[OF fun_at_None_nposs_iff])
qed

lemmas eq_gterm_by_gposs_gfun_at = arg_cong[where f = gterm_of_term,
  OF eq_term_by_poss_fun_at[of "term_of_gterm s :: (_, unit) term" "term_of_gterm t :: (_, unit) term" for s t],
  unfolded term_of_gterm_inv poss_gposs_conv fun_at_gfun_at_conv]

fun gsubt_at :: "'f gterm \<Rightarrow> pos \<Rightarrow> 'f gterm" where
  "gsubt_at s [] = s" |
  "gsubt_at (GFun f ss) (i # p) = gsubt_at (ss ! i) p"

lemma gsubt_at_to_subt_at:
  assumes "p \<in> gposs s"
  shows "gterm_of_term (term_of_gterm s |_ p) = gsubt_at s p"
  using assms by (induct arbitrary: p) (auto simp add: map_idI)

lemma term_of_gterm_gsubt:
  assumes "p \<in> gposs s"
  shows "(term_of_gterm s) |_ p = term_of_gterm (gsubt_at s p)"
  using assms by (induct arbitrary: p) auto

lemma gsubt_at_gposs [simp]:
  assumes "p \<in> gposs s"
  shows "gposs (gsubt_at s p) = {x | x. p @ x \<in> gposs s}"
  using assms by (induct s arbitrary: p) auto

lemma gfun_at_gsub_at [simp]:
  assumes "p \<in> gposs s" and "p @ q \<in> gposs s"
  shows "gfun_at (gsubt_at s p) q = gfun_at s (p @ q)"
  using assms by (induct s arbitrary: p q) auto

lemma gposs_gsubst_at_subst_at_eq [simp]:
  assumes "p \<in> gposs s"
  shows "gposs (gsubt_at s p) = poss (term_of_gterm s |_ p)" using assms
proof (induct s arbitrary: p)
  case (GFun f ts)
  show ?case using GFun(1)[OF nth_mem] GFun(2-)
    by (auto simp: poss_gposs_mem_conv) blast+
qed

lemma gpos_append_gposs:
  assumes "p \<in> gposs t" and "q \<in> gposs (gsubt_at t p)"
  shows "p @ q \<in> gposs t"
  using assms by auto

text \<open>Replace terms at position\<close>

fun replace_gterm_at ("_[_ \<leftarrow> _]\<^sub>G" [1000, 0, 0] 1000) where
  "replace_gterm_at s [] t = t"
| "replace_gterm_at (GFun f ts) (i # ps) t =
    (if i < length ts then GFun f (ts[i:=(replace_gterm_at (ts ! i) ps t)]) else GFun f ts)"

lemma replace_gterm_at_not_poss [simp]:
  "p \<notin> gposs s \<Longrightarrow> s[p \<leftarrow> t]\<^sub>G = s"
proof (induct s arbitrary: p)
  case (GFun f ts) show ?case using GFun(1)[OF nth_mem] GFun(2)
    by (cases p) (auto simp: min_def intro!: nth_equalityI)
qed

lemma parallel_replace_gterm_commute [ac_simps]:
  "p \<bottom> q \<Longrightarrow> s[p \<leftarrow> t]\<^sub>G[q \<leftarrow> u]\<^sub>G = s[q \<leftarrow> u]\<^sub>G[p \<leftarrow> t]\<^sub>G"
proof (induct s arbitrary: p q)
  case (GFun f ts)
  from GFun(2) have "p \<noteq> []" "q \<noteq> []" by auto
  then obtain i j ps qs where [simp]: "p = i # ps" "q = j # qs"
    by (cases p; cases q) auto
  have "i \<noteq> j \<Longrightarrow> (GFun f ts)[p \<leftarrow> t]\<^sub>G[q \<leftarrow> u]\<^sub>G = (GFun f ts)[q \<leftarrow> u]\<^sub>G[p \<leftarrow> t]\<^sub>G"
    by (auto simp: list_update_swap)
  then show ?case using GFun(1)[OF nth_mem, of j ps qs] GFun(2)
    by (cases "i = j") (auto simp: par_Cons_iff)
qed

lemma replace_gterm_at_above [simp]:
  "p \<le>\<^sub>p q \<Longrightarrow> s[q \<leftarrow> t]\<^sub>G[p \<leftarrow> u]\<^sub>G = s[p \<leftarrow> u]\<^sub>G"
proof (induct p arbitrary: s q)
  case (Cons i p)
  show ?case using Cons(1)[of "tl q" "gargs s ! i"] Cons(2)
    by (cases q; cases s) auto
qed auto

lemma replace_gterm_at_below [simp]:
  "p <\<^sub>p q \<Longrightarrow> s[p \<leftarrow> t]\<^sub>G[q \<leftarrow> u]\<^sub>G = s[p \<leftarrow> t[q -\<^sub>p p \<leftarrow> u]\<^sub>G]\<^sub>G"
proof (induct p arbitrary: s q)
  case (Cons i p)
  show ?case using Cons(1)[of "tl q" "gargs s ! i"] Cons(2)
    by (cases q; cases s) auto
qed auto

lemma groot_sym_replace_gterm [simp]:
  "p \<noteq> [] \<Longrightarrow> groot_sym s[p \<leftarrow> t]\<^sub>G = groot_sym s"
  by (cases s; cases p) auto

lemma replace_gterm_gsubt_at_id [simp]: "s[p \<leftarrow> gsubt_at s p]\<^sub>G = s"
proof (induct p arbitrary: s)
  case (Cons i p) then show ?case
    by (cases s) auto
qed auto

lemma replace_gterm_conv:
  "p \<in> gposs s \<Longrightarrow> (term_of_gterm s)[p \<leftarrow> (term_of_gterm t)] = term_of_gterm (s[p \<leftarrow> t]\<^sub>G)"
proof (induct p arbitrary: s)
  case (Cons i p) then show ?case
    by (cases s) (auto simp: nth_list_update intro: nth_equalityI)
qed auto

subsubsection \<open>Tree domains\<close>

type_synonym gdomain = "unit gterm"

abbreviation gdomain where
  "gdomain \<equiv> map_gterm (\<lambda>_. ())"

lemma gdomain_id:
  "gdomain t = t"
proof -
  have [simp]: "(\<lambda>_. ()) = id" by auto
  then show ?thesis by (simp add: gterm.map_id)
qed

lemma gdomain_gsubt [simp]:
  assumes "p \<in> gposs t"
  shows "gdomain (gsubt_at t p) = gsubt_at (gdomain t) p"
  using assms by (induct t arbitrary: p) auto

text \<open>Union of tree domains\<close>

fun gunion :: "gdomain \<Rightarrow> gdomain \<Rightarrow> gdomain" where
  "gunion (GFun f ss) (GFun g ts) = GFun () (map (\<lambda>i.
    if i < length ss then if i < length ts then gunion (ss ! i) (ts ! i)
    else ss ! i else ts ! i) [0..<max (length ss) (length ts)])"

lemma gposs_gunion [simp]:
  "gposs (gunion s t) = gposs s \<union> gposs t"
  by (induct s t rule: gunion.induct) (auto simp: less_max_iff_disj split: if_splits)

lemma gunion_unit [simp]:
  "gunion s (GFun () []) = s" "gunion (GFun () []) s = s"
  by (cases s, (auto intro!: nth_equalityI)[1])+

lemma gunion_gsubt_at_nt_poss1:
  assumes "p \<in> gposs s" and "p \<notin> gposs t"
  shows "gsubt_at (gunion s t) p = gsubt_at s p"
  using assms by (induct s arbitrary: p t) (case_tac p; case_tac t, auto)

lemma gunion_gsubt_at_nt_poss2:
  assumes "p \<in> gposs t" and "p \<notin> gposs s"
  shows "gsubt_at (gunion s t) p = gsubt_at t p"
  using assms by (induct t arbitrary: p s) (case_tac p; case_tac s, auto)

lemma gunion_gsubt_at_poss:
  assumes "p \<in> gposs s" and "p \<in> gposs t"
  shows "gunion (gsubt_at s p) (gsubt_at t p) = gsubt_at (gunion s t) p"
  using assms
proof (induct p arbitrary: s t)
  case (Cons a p)
  then show ?case by (cases s; cases t) auto
qed auto

lemma gfun_at_domain:
  shows "gfun_at t p = (if p \<in> gposs t then Some () else None)"
proof (induct t arbitrary: p)
  case (GFun f ts) then show ?case
    by (cases p) auto
qed

lemma gunion_assoc [ac_simps]:
  "gunion s (gunion t u) = gunion (gunion s t) u"
  by (intro eq_gterm_by_gposs_gfun_at) (auto simp: gfun_at_domain poss_gposs_mem_conv)

lemma gunion_commute [ac_simps]:
  "gunion s t = gunion t s"
  by (intro eq_gterm_by_gposs_gfun_at) (auto simp: gfun_at_domain poss_gposs_mem_conv)

lemma gunion_idemp [simp]:
  "gunion s s = s"
  by (intro eq_gterm_by_gposs_gfun_at) (auto simp: gfun_at_domain poss_gposs_mem_conv)

definition gunions :: "gdomain list \<Rightarrow> gdomain" where
  "gunions ts = foldr gunion ts (GFun () [])"

lemma gunions_append:
  "gunions (ss @ ts) = gunion (gunions ss) (gunions ts)"
  by (induct ss) (auto simp: gunions_def gunion_assoc)

lemma gposs_gunions [simp]:
  "gposs (gunions ts) = {[]} \<union> \<Union>{gposs t |t. t \<in> set ts}"
  by (induct ts) (auto simp: gunions_def)

text \<open>Given a tree domain and a function from positions to symbols, we can construct a term.\<close>
context
  notes conj_cong [fundef_cong]
begin
fun glabel :: "(pos \<Rightarrow> 'f) \<Rightarrow> gdomain \<Rightarrow> 'f gterm" where
  "glabel h (GFun f ts) = GFun (h []) (map (\<lambda>i. glabel (h \<circ> (#) i) (ts ! i)) [0..<length ts])"
end

lemma map_gterm_glabel:
  "map_gterm f (glabel h t) = glabel (f \<circ> h) t"
  by (induct t arbitrary: h) (auto simp: comp_def)

lemma gfun_at_glabel [simp]:
  "gfun_at (glabel f t) p = (if p \<in> gposs t then Some (f p) else None)"
  by (induct t arbitrary: f p, case_tac p) (auto simp: comp_def)

lemma gposs_glabel [simp]:
  "gposs (glabel f t) = gposs t"
  by (induct t arbitrary: f) auto

lemma glabel_map_gterm_conv:
  "glabel (f \<circ> gfun_at t) (gdomain t) = map_gterm (f \<circ> Some) t"
  by (induct t) (auto simp: comp_def intro!: nth_equalityI)

lemma gfun_at_nongposs [simp]:
  "p \<notin> gposs t \<Longrightarrow> gfun_at t p = None"
  using gfun_at_glabel[of "the \<circ> gfun_at t" "gdomain t" p, unfolded glabel_map_gterm_conv]
  by (simp add: comp_def option.map_ident)

lemma gfun_at_poss:
  "p \<in> gposs t \<Longrightarrow> \<exists>f. gfun_at t p = Some f"
  using gfun_at_glabel[of "the \<circ> gfun_at t" "gdomain t" p, unfolded glabel_map_gterm_conv]
  by (auto simp: comp_def)

lemma gfun_at_possE:
  assumes "p \<in> gposs t"
  obtains f where "gfun_at t p = Some f"
  using assms gfun_at_poss by blast

lemma gfun_at_poss_gpossD:
  "gfun_at t p = Some f \<Longrightarrow> p \<in> gposs t"
  by (metis gfun_at_nongposs option.distinct(1))

text \<open>function symbols of a ground term\<close>

primrec funas_gterm :: "'f gterm \<Rightarrow> ('f \<times> nat) set" where
  "funas_gterm (GFun f ts) = {(f, length ts)} \<union> \<Union>(set (map funas_gterm ts))"

lemma funas_gterm_gterm_of_term:
  "ground t \<Longrightarrow> funas_gterm (gterm_of_term t) = funas_term t"
  by (induct t) (auto simp: funas_gterm_def)

lemma funas_term_of_gterm_conv:
  "funas_term (term_of_gterm t) = funas_gterm t"
  by (induct t) (auto simp: funas_gterm_def)

lemma funas_gterm_map_gterm:
  assumes "funas_gterm t \<subseteq> \<F>"
  shows "funas_gterm (map_gterm f t) \<subseteq> (\<lambda> (h, n). (f h, n)) ` \<F>"
  using assms by (induct t) (auto simp: funas_gterm_def)

lemma gterm_of_term_inj:
  assumes "\<And> t. t \<in> S \<Longrightarrow> ground t"
  shows "inj_on gterm_of_term S"
  using assms gterm_of_term_inv by (fastforce simp: inj_on_def)

lemma funas_gterm_gsubt_at_subseteq:
  assumes "p \<in> gposs s"
  shows "funas_gterm (gsubt_at s p) \<subseteq> funas_gterm s" using assms
  apply (induct s arbitrary: p) apply auto
  using nth_mem by blast+

lemma finite_funas_gterm: "finite (funas_gterm t)"
  by (induct t) auto

text \<open>ground term set\<close>

abbreviation gterms where
  "gterms \<F> \<equiv> {s. funas_gterm s \<subseteq> \<F>}"

lemma gterms_mono:
  "\<G> \<subseteq> \<F> \<Longrightarrow> gterms \<G> \<subseteq> gterms \<F>"
  by auto

inductive_set \<T>\<^sub>G for \<F> where
  const [simp]: "(a, 0) \<in> \<F> \<Longrightarrow> GFun a [] \<in> \<T>\<^sub>G \<F>"
| ind [intro]: "(f, n) \<in> \<F> \<Longrightarrow> length ss = n \<Longrightarrow> (\<And> i. i < length ss \<Longrightarrow> ss ! i \<in> \<T>\<^sub>G \<F>) \<Longrightarrow> GFun f ss \<in> \<T>\<^sub>G \<F>"

lemma \<T>\<^sub>G_sound:
  "s \<in> \<T>\<^sub>G \<F> \<Longrightarrow> funas_gterm s \<subseteq> \<F>"
proof (induct)
  case (GFun f ts)
  show ?case using GFun(1)[OF nth_mem] GFun(2)
    by (fastforce simp: in_set_conv_nth elim!: \<T>\<^sub>G.cases intro: nth_mem)
qed

lemma \<T>\<^sub>G_complete:
  "funas_gterm s \<subseteq> \<F> \<Longrightarrow> s \<in> \<T>\<^sub>G \<F> "
  by (induct s) (auto simp: SUP_le_iff)

lemma \<T>\<^sub>G_funas_gterm_conv:
  "s \<in> \<T>\<^sub>G \<F> \<longleftrightarrow> funas_gterm s \<subseteq> \<F>"
  using \<T>\<^sub>G_sound \<T>\<^sub>G_complete by auto

lemma \<T>\<^sub>G_equivalent_def:
  "\<T>\<^sub>G \<F> = gterms \<F>"
  using \<T>\<^sub>G_funas_gterm_conv by auto

lemma \<T>\<^sub>G_intersection [simp]:
  "s \<in> \<T>\<^sub>G \<F> \<Longrightarrow> s \<in> \<T>\<^sub>G \<G> \<Longrightarrow> s \<in> \<T>\<^sub>G (\<F> \<inter> \<G>)"
  by (auto simp: \<T>\<^sub>G_funas_gterm_conv \<T>\<^sub>G_equivalent_def)

lemma \<T>\<^sub>G_mono:
  "\<G> \<subseteq> \<F> \<Longrightarrow> \<T>\<^sub>G \<G> \<subseteq> \<T>\<^sub>G \<F>"
  using gterms_mono by (simp add: \<T>\<^sub>G_equivalent_def)

lemma \<T>\<^sub>G_UNIV [simp]: "s \<in> \<T>\<^sub>G UNIV"
  by (induct) auto

definition funas_grel where
  "funas_grel \<R> = \<Union> ((\<lambda> (s, t). funas_gterm s \<union> funas_gterm t) ` \<R>)"

end


theory CoCallGraph
imports "../Launchbury/Vars" "../Launchbury/HOLCF-Join-Classes" "../Launchbury/HOLCF-Utils" "Set-Cpo"
begin

default_sort type

typedef CoCalls = "{G :: (var \<times> var) set.  sym G}"
  morphisms Rep_CoCall Abs_CoCall
  by (auto intro: exI[where x = "{}"] symI)

setup_lifting type_definition_CoCalls

instantiation CoCalls :: po
begin
lift_definition below_CoCalls :: "CoCalls \<Rightarrow> CoCalls \<Rightarrow> bool" is "op \<subseteq>".
instance
  apply standard
  apply ((transfer, auto)+)
  done
end

lift_definition coCallsLub :: "CoCalls set \<Rightarrow> CoCalls" is "\<lambda> S. \<Union> S"
  by (auto intro: symI elim: symE)

lemma coCallsLub_is_lub: "S <<| coCallsLub S"
proof (rule is_lubI)
  show "S <| coCallsLub S"
    by (rule is_ubI, transfer, auto)
next
  fix u
  assume "S <| u"
  hence "\<forall>x \<in> S. x \<sqsubseteq> u" by (auto dest: is_ubD)
  thus "coCallsLub S \<sqsubseteq> u" by transfer auto
qed

instance CoCalls :: cpo
proof
  fix S :: "nat \<Rightarrow> CoCalls"
  show "\<exists>x. range S <<| x" using coCallsLub_is_lub..
qed

lemma ccLubTransfer[transfer_rule]: "(rel_set pcr_CoCalls ===> pcr_CoCalls) Union lub"
proof-
  have "lub = coCallsLub"
    apply (rule)
    apply (rule lub_eqI)
    apply (rule coCallsLub_is_lub)
    done
  with coCallsLub.transfer
  show ?thesis by metis
qed

lift_definition is_cc_lub :: "CoCalls set \<Rightarrow> CoCalls \<Rightarrow> bool" is "(\<lambda> S x . x = Union S)".

lemma ccis_lubTransfer[transfer_rule]: "(rel_set pcr_CoCalls  ===> pcr_CoCalls ===> op =) (\<lambda> S x . x = Union S) op <<|"
proof-
  have "\<And> x xa . is_cc_lub x xa \<longleftrightarrow> xa = coCallsLub x" by transfer auto
  hence "is_cc_lub = op <<|"
  apply -
  apply (rule, rule)
  by (metis coCallsLub_is_lub is_lub_unique)
  thus ?thesis using is_cc_lub.transfer by simp
qed

lift_definition coCallsJoin :: "CoCalls \<Rightarrow> CoCalls  \<Rightarrow> CoCalls" is "op \<union>"
    by (rule sym_Un)

lemma ccJoinTransfer[transfer_rule]: "(pcr_CoCalls ===> pcr_CoCalls ===> pcr_CoCalls) op \<union> op \<squnion>"
proof-
  have "op \<squnion> = coCallsJoin"
    apply (rule)
    apply rule
    apply (rule lub_is_join)
    unfolding is_lub_def is_ub_def
    apply transfer
    apply auto
    done
  with coCallsJoin.transfer
  show ?thesis by metis
qed

lift_definition ccEmpty :: "CoCalls" is "{}" by (auto intro: symI)

lemma ccEmpty_below[simp]: "ccEmpty \<sqsubseteq> G"
  by transfer auto

instance CoCalls :: pcpo
proof
  have "\<forall>y . ccEmpty \<sqsubseteq> y" by transfer simp
  thus "\<exists>x. \<forall>y. (x::CoCalls) \<sqsubseteq> y"..
qed

lemma ccBotTransfer[transfer_rule]: "pcr_CoCalls {} \<bottom>"
proof-
  have "\<And>x. ccEmpty \<sqsubseteq> x" by transfer simp
  hence "ccEmpty = \<bottom>" by (rule bottomI)
  thus ?thesis using ccEmpty.transfer by simp
qed

lemma cc_lub_below_iff:
  fixes G :: CoCalls
  shows "lub X \<sqsubseteq> G \<longleftrightarrow> (\<forall> G'\<in>X. G' \<sqsubseteq> G)"
  by transfer auto

lift_definition ccField :: "CoCalls \<Rightarrow> var set" is Field.

lemma ccField_nil[simp]: "ccField \<bottom> = {}"
  by transfer auto

lift_definition
  inCC :: "var \<Rightarrow> var \<Rightarrow> CoCalls \<Rightarrow> bool" ("_--_\<in>_" [1000, 1000, 900] 900)
  is "\<lambda> x y s. (x,y) \<in> s".

abbreviation
  notInCC :: "var \<Rightarrow> var \<Rightarrow> CoCalls \<Rightarrow> bool" ("_--_\<notin>_" [1000, 1000, 900] 900)
  where "x--y\<notin>S \<equiv> \<not> x--y\<in>S"

lemma notInCC_bot[simp]: "x--y\<in>\<bottom> \<longleftrightarrow> False"
  by transfer auto

lemma below_CoCallsI:
   "(\<And> x y. x--y\<in>G \<Longrightarrow> x--y\<in>G') \<Longrightarrow> G \<sqsubseteq> G'"
  by transfer auto

lemma CoCalls_eqI:
   "(\<And> x y. x--y\<in>G \<longleftrightarrow> x--y\<in>G') \<Longrightarrow> G = G'"
  by transfer auto

lemma in_join[simp]:
  "x--y \<in> (G\<squnion>G') \<longleftrightarrow> x--y\<in>G \<or> x--y\<in>G'"
by transfer auto

lemma in_lub[simp]: "x--y\<in>(lub S) \<longleftrightarrow> (\<exists> G\<in>S. x--y\<in>G)"
  by transfer auto

lemma in_CoCallsLubI:
  "x--y\<in>G \<Longrightarrow> G \<in> S \<Longrightarrow> x--y\<in>lub S"
by transfer auto

lemma adm_not_in[simp]:
  assumes "cont t"
  shows "adm (\<lambda>a. x--y\<notin>t a)"
  by (rule admI) (auto simp add: cont2contlubE[OF assms])

lift_definition cc_delete :: "var \<Rightarrow> CoCalls \<Rightarrow> CoCalls"
  is "\<lambda> z. Set.filter (\<lambda> (x,y) . x \<noteq> z \<and> y \<noteq> z)"
  by (auto intro!: symI elim: symE)

lemma ccField_cc_delete: "ccField (cc_delete x S) \<subseteq> ccField S - {x}"
  by transfer (auto simp add: Field_def )

lift_definition ccProd :: "var set \<Rightarrow> var set \<Rightarrow> CoCalls" (infixr "G\<times>" 90)
  is "\<lambda> S1 S2. S1 \<times> S2 \<union> S2 \<times> S1"
  by (auto intro!: symI elim: symE)

lemma ccProd_empty[simp]: "{} G\<times> S = \<bottom>" by transfer auto

lemma ccProd_empty'[simp]: "S G\<times> {} = \<bottom>" by transfer auto

lemma ccProd_union2[simp]: "S G\<times> (S' \<union> S'') = S G\<times> S' \<squnion> S G\<times> S''"
  by transfer auto

lemma ccProd_Union2[simp]: "S G\<times> \<Union>S' = (\<Squnion> X\<in>S'. ccProd S X)"
  by transfer auto

lemma ccProd_Union2'[simp]: "S G\<times> (\<Union>X\<in>S'. f X) = (\<Squnion> X\<in>S'. ccProd S (f X))"
  by transfer auto

lemma in_ccProd[simp]: "x--y\<in>(S G\<times> S') = (x \<in> S \<and> y \<in> S' \<or> x \<in> S' \<and> y \<in> S)"
  by transfer auto

lemma ccProd_union1[simp]: "(S' \<union> S'') G\<times> S = S' G\<times> S \<squnion> S'' G\<times> S"
  by transfer auto

lemma ccProd_insert2: "S G\<times> insert x S' = S G\<times> {x} \<squnion> S G\<times> S'"
  by transfer auto

lemma ccProd_insert1: "insert x S' G\<times> S = {x} G\<times> S \<squnion> S' G\<times> S"
  by transfer auto

lemma ccProd_mono1: "S' \<subseteq> S'' \<Longrightarrow> S' G\<times> S \<sqsubseteq> S'' G\<times> S"
  by transfer auto

lemma ccProd_mono2: "S' \<subseteq> S'' \<Longrightarrow> S G\<times> S' \<sqsubseteq> S G\<times> S''"
  by transfer auto

lemma ccProd_mono: "S \<subseteq> S' \<Longrightarrow> T \<subseteq> T' \<Longrightarrow> S G\<times> T \<sqsubseteq> S' G\<times> T'"
  by transfer auto

lemma ccProd_comm: "S G\<times> S' = S' G\<times> S" by transfer auto

lemma ccProd_belowI:
   "(\<And> x y. x \<in> S \<Longrightarrow> y \<in> S' \<Longrightarrow> x--y\<in>G) \<Longrightarrow> S G\<times> S' \<sqsubseteq> G"
  by transfer (auto elim: symE)

lift_definition cc_restr :: "var set \<Rightarrow> CoCalls \<Rightarrow> CoCalls"
  is "\<lambda> S. Set.filter (\<lambda> (x,y) . x \<in> S \<and> y \<in> S)"
  by (auto intro!: symI elim: symE)

abbreviation cc_restr_sym (infixl "G|`"  110) where "G G|` S \<equiv> cc_restr S G"

lemma elem_cc_restr[simp]: "x--y\<in>(G G|` S) = (x--y\<in>G \<and> x \<in> S \<and> y \<in> S)"
  by transfer auto

lemma ccField_cc_restr: "ccField (G G|` S) \<subseteq> ccField G \<inter> S"
  by transfer (auto simp add: Field_def)

lemma cc_restr_empty: "ccField G \<subseteq> - S \<Longrightarrow> G G|` S = \<bottom>"
  apply transfer
  apply (auto simp add: Field_def)
  apply (drule DomainI)
  apply (drule (1) set_mp)
  apply simp
  done

lemma cc_restr_empty_set[simp]: "cc_restr {} G = \<bottom>"
  by transfer auto

lemma cc_restr_noop[simp]: "ccField G \<subseteq> S \<Longrightarrow> cc_restr S G = G"
  by transfer (force simp add: Field_def dest: DomainI RangeI elim: set_mp)

lemma cc_restr_bot[simp]: "cc_restr S \<bottom> = \<bottom>"
  by simp

lemma ccRestr_ccDelete[simp]: "cc_restr (-{x}) G = cc_delete x G"
  by transfer auto

lemma cc_restr_join[simp]:
  "cc_restr S (G \<squnion> G') = cc_restr S G \<squnion> cc_restr S G'"
by transfer auto

lemma cont_cc_restr: "cont (cc_restr S)"
  apply (rule contI)
  apply (thin_tac "chain _")
  apply transfer
  apply auto
  done

lemmas cont_compose[OF cont_cc_restr, cont2cont, simp]

lemma cc_restr_mono1:
  "S \<subseteq> S' \<Longrightarrow> cc_restr S G \<sqsubseteq> cc_restr S' G" by transfer auto

lemma cc_restr_mono2:
  "G \<sqsubseteq> G' \<Longrightarrow> cc_restr S G \<sqsubseteq> cc_restr S G'" by transfer auto

lemma cc_restr_below_arg:
  "cc_restr S G \<sqsubseteq> G" by transfer auto

lemma cc_restr_lub[simp]:
  "cc_restr S (lub X) = (\<Squnion> G\<in>X. cc_restr S G)" by transfer auto

lemma elem_to_ccField: "x--y\<in>G \<Longrightarrow> x \<in> ccField G \<and> y \<in> ccField G"
  by transfer (auto simp add: Field_def)

lemma ccField_to_elem: "x \<in> ccField G \<Longrightarrow> \<exists> y. x--y\<in>G"
  by transfer (auto simp add: Field_def dest: symD)

lemma cc_restr_intersect: "ccField G \<inter> ((S - S') \<union> (S' - S)) = {} \<Longrightarrow> cc_restr S G = cc_restr S' G"
  by (rule CoCalls_eqI) (auto dest: elem_to_ccField)

lemma cc_restr_cc_restr[simp]: "cc_restr S (cc_restr S' G) = cc_restr (S \<inter> S') G"
  by transfer auto

lemma cc_restr_twist: "cc_restr S (cc_restr S' G) = cc_restr S' (cc_restr S G) "
  by transfer auto

lemma cc_restr_cc_delete_twist: "cc_restr x (cc_delete S G) = cc_delete S (cc_restr x G)"
  by transfer auto

lemma cc_restr_ccProd[simp]:
  "cc_restr S (ccProd S\<^sub>1 S\<^sub>2) = ccProd (S\<^sub>1 \<inter> S) (S\<^sub>2 \<inter> S)"
  by transfer auto

lemma ccProd_below_cc_restr:
  "ccProd S S' \<sqsubseteq> cc_restr S'' G \<longleftrightarrow> ccProd S S' \<sqsubseteq> G \<and> (S = {} \<or> S' = {} \<or> S \<subseteq> S'' \<and> S' \<subseteq> S'')"
  by transfer auto

lemma cc_restr_ccSquare[simp]: "(S'²) G|` S = (S' \<inter> S)²"
  unfolding ccSquare_def by auto

lemma ccSquare_empty[simp]: "{}² = \<bottom>"
  unfolding ccSquare_def by simp

lift_definition ccNeighbors :: "var \<Rightarrow> CoCalls \<Rightarrow> var set"
  is "\<lambda> x G. {y .(y,x) \<in> G \<or> (x,y) \<in> G}".

lemma ccNeighbors_bot[simp]: "ccNeighbors x \<bottom> = {}" by transfer auto

lemma cont_ccProd1:
  "cont (\<lambda> S. ccProd S S')"
  apply (rule contI)
  apply (thin_tac "chain _")
  apply (subst lub_set)
  apply transfer
  apply auto
  done

lemma cont_ccProd2:
  "cont (\<lambda> S'. ccProd S S')"
  apply (rule contI)
  apply (thin_tac "chain _")
  apply (subst lub_set)
  apply transfer
  apply auto
  done

lemmas cont_compose2[OF cont_ccProd1 cont_ccProd2, simp, cont2cont]

lemma cont_ccNeighbors[THEN cont_compose, cont2cont, simp]:
  "cont (\<lambda>y. ccNeighbors x y)"
  apply (rule set_contI)
  apply (thin_tac "chain _")
  apply transfer
  apply auto
  done

lemma ccNeighbors_join[simp]: "ccNeighbors x (G \<squnion> G') = ccNeighbors x G \<union> ccNeighbors x G'"
  by transfer auto

lemma ccNeighbors_ccProd:
  "ccNeighbors x (ccProd S S') = (if x \<in> S then S' else {}) \<union> (if x \<in> S' then S else {})"
by transfer auto

lemma ccNeighbors_ccSquare:
  "ccNeighbors x (ccSquare S) = (if x \<in> S then S else {})"
  unfolding ccSquare_def by (auto simp add: ccNeighbors_ccProd)

lemma ccNeighbors_cc_restr[simp]:
  "ccNeighbors x (cc_restr S G) = (if x \<in> S then ccNeighbors x G \<inter> S else {})"
by transfer auto

lemma ccNeighbors_mono:
  "G \<sqsubseteq> G' \<Longrightarrow> ccNeighbors x G \<subseteq> ccNeighbors x G'"
  by transfer auto

lemma subset_ccNeighbors:
  "S \<subseteq> ccNeighbors x G \<longleftrightarrow> ccProd {x} S \<sqsubseteq> G"
  by transfer (auto simp add: sym_def)

lemma elem_ccNeighbors[simp]:
  "y \<in> ccNeighbors x G \<longleftrightarrow> (y--x\<in>G)"
  by transfer (auto simp add: sym_def)

lemma ccNeighbors_ccField:
  "ccNeighbors x G \<subseteq> ccField G" by transfer (auto simp add: Field_def)

lemma ccNeighbors_disjoint_empty[simp]:
  "ccNeighbors x G = {} \<longleftrightarrow> x \<notin> ccField G"
  by transfer (auto simp add: Field_def)

instance CoCalls :: Join_cpo
  by standard (metis coCallsLub_is_lub)

lemma ccNeighbors_lub[simp]: "ccNeighbors x (lub Gs) = lub (ccNeighbors x ` Gs)"
  by transfer (auto simp add: lub_set)

inductive list_pairs :: "'a list \<Rightarrow> ('a \<times> 'a) \<Rightarrow> bool"
  where "list_pairs xs p \<Longrightarrow> list_pairs (x#xs) p"
      | "y \<in> set xs \<Longrightarrow> list_pairs (x#xs) (x,y)"

lift_definition ccFromList :: "var list \<Rightarrow> CoCalls" is "\<lambda> xs. {(x,y). list_pairs xs (x,y) \<or> list_pairs xs (y,x)}"
  by (auto intro: symI)

lemma ccFromList_Nil[simp]: "ccFromList [] = \<bottom>"
  by transfer (auto elim: list_pairs.cases)

lemma ccFromList_Cons[simp]: "ccFromList (x#xs) = ccProd {x} (set xs) \<squnion> ccFromList xs"
  by transfer (auto elim: list_pairs.cases intro: list_pairs.intros)

lemma ccFromList_append[simp]: "ccFromList (xs@ys) = ccFromList xs \<squnion> ccFromList ys \<squnion> ccProd (set xs) (set ys)"
  by (induction xs) (auto simp add: ccProd_insert1[where S' = "set xs" for xs])

lemma ccFromList_filter[simp]:
  "ccFromList (filter P xs) = cc_restr {x. P x} (ccFromList xs)"
by (induction xs) (auto simp add: Collect_conj_eq)

lemma ccFromList_replicate[simp]: "ccFromList (replicate n x) = (if n \<le> 1 then \<bottom>  else ccProd {x} {x})"
  by (induction n) auto

definition ccLinear :: "var set \<Rightarrow> CoCalls \<Rightarrow> bool"
  where "ccLinear S G = (\<forall> x\<in>S. \<forall> y\<in>S. x--y\<notin>G)"

lemma ccLinear_bottom[simp]:
  "ccLinear S \<bottom>"
  unfolding ccLinear_def by simp

lemma ccLinear_empty[simp]:
  "ccLinear {} G"
  unfolding ccLinear_def by simp

lemma ccLinear_lub[simp]:
  "ccLinear S (lub X) = (\<forall> G\<in>X. ccLinear S G)"
 unfolding ccLinear_def by auto

(*
lemma ccLinear_ccNeighbors:
  "ccLinear S G \<Longrightarrow> ccNeighbors S G \<inter> S = {}"
 unfolding ccLinear_def by transfer auto
*)

lemma ccLinear_cc_restr[intro]:
  "ccLinear S G \<Longrightarrow> ccLinear S (cc_restr S' G)"
 unfolding ccLinear_def by transfer auto

(* TODO: Sort *)

lemma ccLinear_join[simp]:
  "ccLinear S (G \<squnion> G') \<longleftrightarrow> ccLinear S G \<and> ccLinear S G'"
  unfolding ccLinear_def
  by transfer auto

lemma ccLinear_ccProd[simp]:
  "ccLinear S (ccProd S\<^sub>1 S\<^sub>2) \<longleftrightarrow> S\<^sub>1 \<inter> S = {} \<or> S\<^sub>2 \<inter> S = {}"
  unfolding ccLinear_def
  by transfer auto

lemma ccLinear_mono1: "ccLinear S' G \<Longrightarrow> S \<subseteq> S' \<Longrightarrow> ccLinear S G"
  unfolding ccLinear_def
  by transfer auto

lemma ccLinear_mono2: "ccLinear S G' \<Longrightarrow> G \<sqsubseteq> G' \<Longrightarrow> ccLinear S G"
  unfolding ccLinear_def
  by transfer auto

lemma ccField_join[simp]:
  "ccField (G \<squnion> G') = ccField G \<union> ccField G'" by transfer auto

lemma ccField_lub[simp]:
  "ccField (lub S) = \<Union>(ccField ` S)" by transfer auto

lemma ccField_ccProd:
  "ccField (ccProd S S') = (if S = {} then {} else if S' = {} then {} else  S \<union> S')"
  by transfer (auto simp add: Field_def)

lemma ccField_ccProd_subset:
  "ccField (ccProd S S') \<subseteq>  S \<union> S'"
  by (simp add: ccField_ccProd)

lemma cont_ccField[THEN cont_compose, simp, cont2cont]:
  "cont ccField"
  by (rule set_contI) auto

end


(*  Title:      HOL/Algebra/Multiplicative_Group.thy
    Author:     Simon Wimmer
    Author:     Lars Noschinski
*)

theory Multiplicative_Group
imports
  Complex_Main
  Group
  Coset
  UnivPoly
  Generated_Groups
begin

section \<open>Simplification Rules for Polynomials\<close>
text_raw \<open>\label{sec:simp-rules}\<close>

lemma (in ring_hom_cring) hom_sub[simp]:
  assumes "x \<in> carrier R" "y \<in> carrier R"
  shows "h (x \<ominus> y) = h x \<ominus>\<^bsub>S\<^esub> h y"
  using assms by (simp add: R.minus_eq S.minus_eq)

context UP_ring begin

lemma deg_nzero_nzero:
  assumes deg_p_nzero: "deg R p \<noteq> 0"
  shows "p \<noteq> \<zero>\<^bsub>P\<^esub>"
  using deg_zero deg_p_nzero by auto

lemma deg_add_eq:
  assumes c: "p \<in> carrier P" "q \<in> carrier P"
  assumes "deg R q \<noteq> deg R p"
  shows "deg R (p \<oplus>\<^bsub>P\<^esub> q) = max (deg R p) (deg R q)"
proof -
  let ?m = "max (deg R p) (deg R q)"
  from assms have "coeff P p ?m = \<zero> \<longleftrightarrow> coeff P q ?m \<noteq> \<zero>"
    by (metis deg_belowI lcoeff_nonzero[OF deg_nzero_nzero] linear max.absorb_iff2 max.absorb1)
  then have "coeff P (p \<oplus>\<^bsub>P\<^esub> q) ?m \<noteq> \<zero>"
    using assms by auto
  then have "deg R (p \<oplus>\<^bsub>P\<^esub> q) \<ge> ?m"
    using assms by (blast intro: deg_belowI)
  with deg_add[OF c] show ?thesis by arith
qed

lemma deg_minus_eq:
  assumes "p \<in> carrier P" "q \<in> carrier P" "deg R q \<noteq> deg R p"
  shows "deg R (p \<ominus>\<^bsub>P\<^esub> q) = max (deg R p) (deg R q)"
  using assms by (simp add: deg_add_eq a_minus_def)

end

context UP_cring begin

lemma evalRR_add:
  assumes "p \<in> carrier P" "q \<in> carrier P"
  assumes x: "x \<in> carrier R"
  shows "eval R R id x (p \<oplus>\<^bsub>P\<^esub> q) = eval R R id x p \<oplus> eval R R id x q"
proof -
  interpret UP_pre_univ_prop R R id by unfold_locales simp
  interpret ring_hom_cring P R "eval R R id x" by unfold_locales (rule eval_ring_hom[OF x])
  show ?thesis using assms by simp
qed

lemma evalRR_sub:
  assumes "p \<in> carrier P" "q \<in> carrier P"
  assumes x: "x \<in> carrier R"
  shows "eval R R id x (p \<ominus>\<^bsub>P\<^esub> q) = eval R R id x p \<ominus> eval R R id x q"
proof -
  interpret UP_pre_univ_prop R R id by unfold_locales simp
  interpret ring_hom_cring P R "eval R R id x" by unfold_locales (rule eval_ring_hom[OF x])
  show ?thesis using assms by simp
qed

lemma evalRR_mult:
  assumes "p \<in> carrier P" "q \<in> carrier P"
  assumes x: "x \<in> carrier R"
  shows "eval R R id x (p \<otimes>\<^bsub>P\<^esub> q) = eval R R id x p \<otimes> eval R R id x q"
proof -
  interpret UP_pre_univ_prop R R id by unfold_locales simp
  interpret ring_hom_cring P R "eval R R id x" by unfold_locales (rule eval_ring_hom[OF x])
  show ?thesis using assms by simp
qed

lemma evalRR_monom:
  assumes a: "a \<in> carrier R" and x: "x \<in> carrier R"
  shows "eval R R id x (monom P a d) = a \<otimes> x [^] d"
proof -
  interpret UP_pre_univ_prop R R id by unfold_locales simp
  show ?thesis using assms by (simp add: eval_monom)
qed

lemma evalRR_one:
  assumes x: "x \<in> carrier R"
  shows "eval R R id x \<one>\<^bsub>P\<^esub> = \<one>"
proof -
  interpret UP_pre_univ_prop R R id by unfold_locales simp
  interpret ring_hom_cring P R "eval R R id x" by unfold_locales (rule eval_ring_hom[OF x])
  show ?thesis using assms by simp
qed

lemma carrier_evalRR:
  assumes x: "x \<in> carrier R" and "p \<in> carrier P"
  shows "eval R R id x p \<in> carrier R"
proof -
  interpret UP_pre_univ_prop R R id by unfold_locales simp
  interpret ring_hom_cring P R "eval R R id x" by unfold_locales (rule eval_ring_hom[OF x])
  show ?thesis using assms by simp
qed

lemmas evalRR_simps = evalRR_add evalRR_sub evalRR_mult evalRR_monom evalRR_one carrier_evalRR

end

section \<open>Properties of the Euler \<open>\<phi>\<close>-function\<close>
text_raw \<open>\label{sec:euler-phi}\<close>

text\<open>
  In this section we prove that for every positive natural number the equation
  $\sum_{d | n}^n \varphi(d) = n$ holds.
\<close>

lemma dvd_div_ge_1:
  fixes a b :: nat
  assumes "a \<ge> 1" "b dvd a"
  shows "a div b \<ge> 1"
proof -
  from \<open>b dvd a\<close> obtain c where "a = b * c" ..
  with \<open>a \<ge> 1\<close> show ?thesis by simp
qed

lemma dvd_nat_bounds:
 fixes n p :: nat
 assumes "p > 0" "n dvd p"
 shows "n > 0 \<and> n \<le> p"
 using assms by (simp add: dvd_pos_nat dvd_imp_le)

(* TODO FIXME: This is the "totient" function from HOL-Number_Theory, but since part of
   HOL-Number_Theory depends on HOL-Algebra.Multiplicative_Group, there would be a cyclic
   dependency. *)
definition phi' :: "nat => nat"
  where "phi' m = card {x. 1 \<le> x \<and> x \<le> m \<and> coprime x m}"

notation (latex output)
  phi' ("\<phi> _")

lemma phi'_nonzero:
  assumes "m > 0"
  shows "phi' m > 0"
proof -
  have "1 \<in> {x. 1 \<le> x \<and> x \<le> m \<and> coprime x m}" using assms by simp
  hence "card {x. 1 \<le> x \<and> x \<le> m \<and> coprime x m} > 0" by (auto simp: card_gt_0_iff)
  thus ?thesis unfolding phi'_def by simp
qed

lemma dvd_div_eq_1:
  fixes a b c :: nat
  assumes "c dvd a" "c dvd b" "a div c = b div c"
  shows "a = b" using assms dvd_mult_div_cancel[OF \<open>c dvd a\<close>] dvd_mult_div_cancel[OF \<open>c dvd b\<close>]
                by presburger

lemma dvd_div_eq_2:
  fixes a b c :: nat
  assumes "c>0" "a dvd c" "b dvd c" "c div a = c div b"
  shows "a = b"
  proof -
  have "a > 0" "a \<le> c" using dvd_nat_bounds[OF assms(1-2)] by auto
  have "a*(c div a) = c" using assms dvd_mult_div_cancel by fastforce
  also have "\<dots> = b*(c div a)" using assms dvd_mult_div_cancel by fastforce
  finally show "a = b" using \<open>c>0\<close> dvd_div_ge_1[OF _ \<open>a dvd c\<close>] by fastforce
qed

lemma div_mult_mono:
  fixes a b c :: nat
  assumes "a > 0" "a\<le>d"
  shows "a * b div d \<le> b"
proof -
  have "a*b div d \<le> b*a div a" using assms div_le_mono2 mult.commute[of a b] by presburger
  thus ?thesis using assms by force
qed

text\<open>
  We arrive at the main result of this section:
  For every positive natural number the equation $\sum_{d | n}^n \varphi(d) = n$ holds.

  The outline of the proof for this lemma is as follows:
  We count the $n$ fractions $1/n$, $\ldots$, $(n-1)/n$, $n/n$.
  We analyze the reduced form $a/d = m/n$ for any of those fractions.
  We want to know how many fractions $m/n$ have the reduced form denominator $d$.
  The condition $1 \leq m \leq n$ is equivalent to the condition $1 \leq a \leq d$.
  Therefore we want to know how many $a$ with $1 \leq a \leq d$ exist, s.t. \<^term>\<open>gcd a d = 1\<close>.
  This number is exactly \<^term>\<open>phi' d\<close>.

  Finally, by counting the fractions $m/n$ according to their reduced form denominator,
  we get: @{term [display] "(\<Sum>d | d dvd n . phi' d) = n"}.
  To formalize this proof in Isabelle, we analyze for an arbitrary divisor $d$ of $n$
  \begin{itemize}
    \item the set of reduced form numerators \<^term>\<open>{a. (1::nat) \<le> a \<and> a \<le> d \<and> coprime a d}\<close>
    \item the set of numerators $m$, for which $m/n$ has the reduced form denominator $d$,
      i.e. the set \<^term>\<open>{m \<in> {1::nat .. n}. n div gcd m n = d}\<close>
  \end{itemize}
  We show that \<^term>\<open>\<lambda>a. a*n div d\<close> with the inverse \<^term>\<open>\<lambda>a. a div gcd a n\<close> is
  a bijection between theses sets, thus yielding the equality
  @{term [display] "phi' d = card {m \<in> {1 .. n}. n div gcd m n = d}"}
  This gives us
  @{term [display] "(\<Sum>d | d dvd n . phi' d)
          = card (\<Union>d \<in> {d. d dvd n}. {m \<in> {1 .. n}. n div gcd m n = d})"}
  and by showing
  \<^term>\<open>(\<Union>d \<in> {d. d dvd n}. {m \<in> {1::nat .. n}. n div gcd m n = d}) \<supseteq> {1 .. n}\<close>
  (this is our counting argument) the thesis follows.
\<close>
lemma sum_phi'_factors:
 fixes n :: nat
 assumes "n > 0"
 shows "(\<Sum>d | d dvd n. phi' d) = n"
proof -
  { fix d assume "d dvd n" then obtain q where q: "n = d * q" ..
    have "card {a. 1 \<le> a \<and> a \<le> d \<and> coprime a d} = card {m \<in> {1 .. n}.  n div gcd m n = d}"
         (is "card ?RF = card ?F")
    proof (rule card_bij_eq)
      { fix a b assume "a * n div d = b * n div d"
        hence "a * (n div d) = b * (n div d)"
          using dvd_div_mult[OF \<open>d dvd n\<close>] by (fastforce simp add: mult.commute)
        hence "a = b" using dvd_div_ge_1[OF _ \<open>d dvd n\<close>] \<open>n>0\<close>
          by (simp add: mult.commute nat_mult_eq_cancel1)
      } thus "inj_on (\<lambda>a. a*n div d) ?RF" unfolding inj_on_def by blast
      { fix a assume a: "a\<in>?RF"
        hence "a * (n div d) \<ge> 1" using \<open>n>0\<close> dvd_div_ge_1[OF _ \<open>d dvd n\<close>] by simp
        hence ge_1: "a * n div d \<ge> 1" by (simp add: \<open>d dvd n\<close> div_mult_swap)
        have le_n: "a * n div d \<le> n" using div_mult_mono a by simp
        have "gcd (a * n div d) n = n div d * gcd a d"
          by (simp add: gcd_mult_distrib_nat q ac_simps)
        hence "n div gcd (a * n div d) n = d*n div (d*(n div d))" using a by simp
        hence "a * n div d \<in> ?F"
          using ge_1 le_n by (fastforce simp add: \<open>d dvd n\<close>)
      } thus "(\<lambda>a. a*n div d) ` ?RF \<subseteq> ?F" by blast
      { fix m l assume A: "m \<in> ?F" "l \<in> ?F" "m div gcd m n = l div gcd l n"
        hence "gcd m n = gcd l n" using dvd_div_eq_2[OF assms] by fastforce
        hence "m = l" using dvd_div_eq_1[of "gcd m n" m l] A(3) by fastforce
      } thus "inj_on (\<lambda>a. a div gcd a n) ?F" unfolding inj_on_def by blast
      { fix m assume "m \<in> ?F"
        hence "m div gcd m n \<in> ?RF" using dvd_div_ge_1
          by (fastforce simp add: div_le_mono div_gcd_coprime)
      } thus "(\<lambda>a. a div gcd a n) ` ?F \<subseteq> ?RF" by blast
    qed force+
  } hence phi'_eq: "\<And>d. d dvd n \<Longrightarrow> phi' d = card {m \<in> {1 .. n}. n div gcd m n = d}"
      unfolding phi'_def by presburger
  have fin: "finite {d. d dvd n}" using dvd_nat_bounds[OF \<open>n>0\<close>] by force
  have "(\<Sum>d | d dvd n. phi' d)
                 = card (\<Union>d \<in> {d. d dvd n}. {m \<in> {1 .. n}. n div gcd m n = d})"
    using card_UN_disjoint[OF fin, of "(\<lambda>d. {m \<in> {1 .. n}. n div gcd m n = d})"] phi'_eq
    by fastforce
  also have "(\<Union>d \<in> {d. d dvd n}. {m \<in> {1 .. n}. n div gcd m n = d}) = {1 .. n}" (is "?L = ?R")
  proof
    show "?L \<supseteq> ?R"
    proof
      fix m assume m: "m \<in> ?R"
      thus "m \<in> ?L" using dvd_triv_right[of "n div gcd m n" "gcd m n"]
        by simp
    qed
  qed fastforce
  finally show ?thesis by force
qed

section \<open>Order of an Element of a Group\<close>
text_raw \<open>\label{sec:order-elem}\<close>

context group begin

definition (in group) ord :: "'a \<Rightarrow> nat" where
  "ord x \<equiv> (@d. \<forall>n::nat. x [^] n = \<one> \<longleftrightarrow> d dvd n)"

lemma (in group) pow_eq_id:
  assumes "x \<in> carrier G"
  shows "x [^] n = \<one> \<longleftrightarrow> (ord x) dvd n"
proof (cases "\<forall>n::nat. pow G x n = one G \<longrightarrow> n = 0")
  case True
  show ?thesis
    unfolding ord_def
    by (rule someI2 [where a=0]) (auto simp: True)
next
  case False
  define N where "N \<equiv> LEAST n::nat. x [^] n = \<one> \<and> n > 0"
  have N: "x [^] N = \<one> \<and> N > 0"
    using False
    apply (simp add: N_def)
    by (metis (mono_tags, lifting) LeastI)
  have eq0: "n = 0" if "x [^] n = \<one>" "n < N" for n
    using N_def not_less_Least that by fastforce
  show ?thesis
    unfolding ord_def
  proof (rule someI2 [where a = N], rule allI)
    fix n :: "nat"
    show "(x [^] n = \<one>) \<longleftrightarrow> (N dvd n)"
    proof (cases "n = 0")
      case False
      show ?thesis
        unfolding dvd_def
      proof safe
        assume 1: "x [^] n = \<one>"
        have "x [^] n = x [^] (n mod N + N * (n div N))"
          by simp
        also have "\<dots> = x [^] (n mod N) \<otimes> x [^] (N * (n div N))"
          by (simp add: assms nat_pow_mult)
        also have "\<dots> = x [^] (n mod N)"
          by (metis N assms l_cancel_one nat_pow_closed nat_pow_one nat_pow_pow)
        finally have "x [^] (n mod N) = \<one>"
          by (simp add: "1")
        then have "n mod N = 0"
          using N eq0 mod_less_divisor by blast
        then show "\<exists>k. n = N * k"
          by blast
      next
        fix k :: "nat"
        assume "n = N * k"
        with N show "x [^] (N * k) = \<one>"
          by (metis assms nat_pow_one nat_pow_pow)
      qed
    qed simp
  qed blast
qed

lemma (in group) pow_ord_eq_1 [simp]:
   "x \<in> carrier G \<Longrightarrow> x [^] ord x = \<one>"
  by (simp add: pow_eq_id)

lemma (in group) int_pow_eq_id:
  assumes "x \<in> carrier G"
  shows "(pow G x i = one G \<longleftrightarrow> int (ord x) dvd i)"
proof (cases i rule: int_cases2)
  case (nonneg n)
  then show ?thesis
    by (simp add: int_pow_int pow_eq_id assms)
next
  case (nonpos n)
  then have "x [^] i = inv (x [^] n)"
    by (simp add: assms int_pow_int int_pow_neg)
  then show ?thesis
    by (simp add: assms pow_eq_id nonpos)
qed

lemma (in group) int_pow_eq:
   "x \<in> carrier G \<Longrightarrow> (x [^] m = x [^] n) \<longleftrightarrow> int (ord x) dvd (n - m)"
  apply (simp flip: int_pow_eq_id)
  by (metis int_pow_closed int_pow_diff inv_closed r_inv right_cancel)

lemma (in group) ord_eq_0:
   "x \<in> carrier G \<Longrightarrow> (ord x = 0 \<longleftrightarrow> (\<forall>n::nat. n \<noteq> 0 \<longrightarrow> x [^] n \<noteq> \<one>))"
  by (auto simp: pow_eq_id)

lemma (in group) ord_unique:
   "x \<in> carrier G \<Longrightarrow> ord x = d \<longleftrightarrow> (\<forall>n. pow G x n = one G \<longleftrightarrow> d dvd n)"
  by (meson dvd_antisym dvd_refl pow_eq_id)

lemma (in group) ord_eq_1:
   "x \<in> carrier G \<Longrightarrow> (ord x = 1 \<longleftrightarrow> x = \<one>)"
  by (metis pow_eq_id nat_dvd_1_iff_1 nat_pow_eone)

lemma (in group) ord_id [simp]:
   "ord (one G) = 1"
  using ord_eq_1 by blast

lemma (in group) ord_inv [simp]:
   "x \<in> carrier G
        \<Longrightarrow> ord (m_inv G x) = ord x"
  by (simp add: ord_unique pow_eq_id nat_pow_inv)

lemma (in group) ord_pow:
  assumes "x \<in> carrier G" "k dvd ord x" "k \<noteq> 0"
  shows "ord (pow G x k) = ord x div k"
proof -
  have "(x [^] k) [^] (ord x div k) = \<one>"
    using assms by (simp add: nat_pow_pow)
  moreover have "ord x dvd k * ord (x [^] k)"
    by (metis assms(1) pow_ord_eq_1 pow_eq_id nat_pow_closed nat_pow_pow)
  ultimately show ?thesis
    by (metis assms div_dvd_div dvd_antisym dvd_triv_left pow_eq_id nat_pow_closed nonzero_mult_div_cancel_left)
qed

lemma (in group) ord_mul_divides:
  assumes eq: "x \<otimes> y = y \<otimes> x" and xy: "x \<in> carrier G" "y \<in> carrier G"
  shows "ord (x \<otimes> y) dvd (ord x * ord y)"
apply (simp add: xy flip: pow_eq_id eq)
  by (metis dvd_triv_left dvd_triv_right eq pow_eq_id one_closed pow_mult_distrib r_one xy)

lemma (in comm_group) abelian_ord_mul_divides:
   "\<lbrakk>x \<in> carrier G; y \<in> carrier G\<rbrakk>
        \<Longrightarrow> ord (x \<otimes> y) dvd (ord x * ord y)"
  by (simp add: ord_mul_divides m_comm)

lemma ord_inj:
  assumes a: "a \<in> carrier G"
  shows "inj_on (\<lambda> x . a [^] x) {0 .. ord a - 1}"
proof -
  let ?M = "Max (ord ` carrier G)"
  have "finite {d \<in> {..?M}. a [^] d = \<one>}" by auto

  have *: False if A: "x < y" "x \<in> {0 .. ord a - 1}" "y \<in> {0 .. ord a - 1}"
        "a [^] x = a [^] y" for x y
  proof -
    have "y - x < ord a" using that by auto
    moreover have "a [^] (y-x) = \<one>" using a A by (simp add: pow_eq_div2)
    ultimately have "min (y - x) (ord a) = ord a"
      using A(1) a pow_eq_id by auto
    with \<open>y - x < ord a\<close> show False by linarith
  qed
  show ?thesis
    unfolding inj_on_def by (metis nat_neq_iff *)
qed

lemma ord_inj':
  assumes a: "a \<in> carrier G"
  shows "inj_on (\<lambda> x . a [^] x) {1 .. ord a}"
proof (rule inj_onI, rule ccontr)
  fix x y :: nat
  assume A: "x \<in> {1 .. ord a}" "y \<in> {1 .. ord a}" "a [^] x = a [^] y" "x\<noteq>y"
  { assume "x < ord a" "y < ord a"
    hence False using ord_inj[OF assms] A unfolding inj_on_def by fastforce
  }
  moreover
  { assume "x = ord a" "y < ord a"
    hence "a [^] y = a [^] (0::nat)" using pow_ord_eq_1 A by (simp add: a)
    hence "y=0" using ord_inj[OF assms] \<open>y < ord a\<close> unfolding inj_on_def by force
    hence False using A by fastforce
  }
  moreover
  { assume "y = ord a" "x < ord a"
    hence "a [^] x = a [^] (0::nat)" using pow_ord_eq_1 A by (simp add: a)
    hence "x=0" using ord_inj[OF assms] \<open>x < ord a\<close> unfolding inj_on_def by force
    hence False using A by fastforce
  }
  ultimately show False using A  by force
qed

lemma (in group) ord_ge_1:
  assumes finite: "finite (carrier G)" and a: "a \<in> carrier G"
  shows "ord a \<ge> 1"
proof -
  have "((\<lambda>n::nat. a [^] n) ` {0<..}) \<subseteq> carrier G"
    using a by blast
  then have "finite ((\<lambda>n::nat. a [^] n) ` {0<..})"
    using finite_subset finite by auto
  then have "\<not> inj_on (\<lambda>n::nat. a [^] n) {0<..}"
    using finite_imageD infinite_Ioi by blast
  then obtain i j::nat where "i \<noteq> j" "a [^] i = a [^] j"
    by (auto simp: inj_on_def)
  then have "\<exists>n::nat. n>0 \<and> a [^] n = \<one>"
    by (metis a diffs0_imp_equal pow_eq_div2 neq0_conv)
  then have "ord a \<noteq> 0"
    by (simp add: ord_eq_0 [OF a])
  then show ?thesis
    by simp
qed

lemma ord_elems:
  assumes "finite (carrier G)" "a \<in> carrier G"
  shows "{a[^]x | x. x \<in> (UNIV :: nat set)} = {a[^]x | x. x \<in> {0 .. ord a - 1}}" (is "?L = ?R")
proof
  show "?R \<subseteq> ?L" by blast
  { fix y assume "y \<in> ?L"
    then obtain x::nat where x: "y = a[^]x" by auto
    define r q where "r = x mod ord a" and "q = x div ord a"
    then have "x = q * ord a + r"
      by (simp add: div_mult_mod_eq)
    hence "y = (a[^]ord a)[^]q \<otimes> a[^]r"
      using x assms by (metis mult.commute nat_pow_mult nat_pow_pow)
    hence "y = a[^]r" using assms by (simp add: pow_ord_eq_1)
    have "r < ord a" using ord_ge_1[OF assms] by (simp add: r_def)
    hence "r \<in> {0 .. ord a - 1}" by (force simp: r_def)
    hence "y \<in> {a[^]x | x. x \<in> {0 .. ord a - 1}}" using \<open>y=a[^]r\<close> by blast
  }
  thus "?L \<subseteq> ?R" by auto
qed

lemma generate_pow_on_finite_carrier: \<^marker>\<open>contributor \<open>Paulo Emílio de Vilhena\<close>\<close>
  assumes "finite (carrier G)" and a: "a \<in> carrier G"
  shows "generate G { a } = { a [^] k | k. k \<in> (UNIV :: nat set) }"
proof
  show "{ a [^] k | k. k \<in> (UNIV :: nat set) } \<subseteq> generate G { a }"
  proof
    fix b assume "b \<in> { a [^] k | k. k \<in> (UNIV :: nat set) }"
    then obtain k :: nat where "b = a [^] k" by blast
    hence "b = a [^] (int k)"
      by (simp add: int_pow_int)
    thus "b \<in> generate G { a }"
      unfolding generate_pow[OF a] by blast
  qed
next
  show "generate G { a } \<subseteq> { a [^] k | k. k \<in> (UNIV :: nat set) }"
  proof
    fix b assume "b \<in> generate G { a }"
    then obtain k :: int where k: "b = a [^] k"
      unfolding generate_pow[OF a] by blast
    show "b \<in> { a [^] k | k. k \<in> (UNIV :: nat set) }"
    proof (cases "k < 0")
      assume "\<not> k < 0"
      hence "b = a [^] (nat k)"
        by (simp add: k)
      thus ?thesis by blast
    next
      assume "k < 0"
      hence b: "b = inv (a [^] (nat (- k)))"
        using k a by (auto simp: int_pow_neg)
      obtain m where m: "ord a * m \<ge> nat (- k)"
        by (metis assms mult.left_neutral mult_le_mono1 ord_ge_1)
      hence "a [^] (ord a * m) = \<one>"
        by (metis a nat_pow_one nat_pow_pow pow_ord_eq_1)
      then obtain k' :: nat where "(a [^] (nat (- k))) \<otimes> (a [^] k') = \<one>"
        using m a nat_le_iff_add nat_pow_mult by auto
      hence "b = a [^] k'"
        using b a by (metis inv_unique' nat_pow_closed nat_pow_comm)
      thus "b \<in> { a [^] k | k. k \<in> (UNIV :: nat set) }" by blast
    qed
  qed
qed

lemma generate_pow_card: \<^marker>\<open>contributor \<open>Paulo Emílio de Vilhena\<close>\<close>
  assumes "finite (carrier G)" and a: "a \<in> carrier G"
  shows "ord a = card (generate G { a })"
proof -
  have "generate G { a } = (([^]) a) ` {0..ord a - 1}"
    using generate_pow_on_finite_carrier[OF assms] unfolding ord_elems[OF assms] by auto
  thus ?thesis
    using ord_inj[OF a] ord_ge_1[OF assms] by (simp add: card_image)
qed

lemma ord_dvd_group_order:
  assumes "a \<in> carrier G"
  shows "(ord a) dvd (order G)"
proof (cases "finite (carrier G)")
  case True
  then show ?thesis
    using lagrange[OF generate_is_subgroup[of "{a}"]] assms
    unfolding generate_pow_card[OF True assms]
    by (metis dvd_triv_right empty_subsetI insert_subset)
next
  case False
  then show ?thesis
    using order_gt_0_iff_finite by auto
qed

lemma (in group) pow_order_eq_1:
  assumes "a \<in> carrier G" shows "a [^] order G = \<one>"
  using assms by (metis nat_pow_pow ord_dvd_group_order pow_ord_eq_1 dvdE nat_pow_one)

lemma dvd_gcd:
  fixes a b :: nat
  obtains q where "a * (b div gcd a b) = b*q"
proof
  have "a * (b div gcd a b) = (a div gcd a b) * b" by (simp add:  div_mult_swap dvd_div_mult)
  also have "\<dots> = b * (a div gcd a b)" by simp
  finally show "a * (b div gcd a b) = b * (a div gcd a b) " .
qed

lemma (in group) ord_le_group_order:
  assumes finite: "finite (carrier G)" and a: "a \<in> carrier G"
  shows "ord a \<le> order G"
  by (simp add: a dvd_imp_le local.finite ord_dvd_group_order order_gt_0_iff_finite)

lemma (in group) ord_pow_gen:
  assumes "x \<in> carrier G"
  shows "ord (pow G x k) = (if k = 0 then 1 else ord x div gcd (ord x) k)"
proof -
  have "ord (x [^] k) = ord x div gcd (ord x) k"
    if "0 < k"
  proof -
    have "(d dvd k * n) = (d div gcd (d) k dvd n)" for d n
      using that by (simp add: div_dvd_iff_mult gcd_mult_distrib_nat mult.commute)
    then show ?thesis
      using that by (auto simp add: assms ord_unique nat_pow_pow pow_eq_id)
  qed
  then show ?thesis by auto
qed

lemma (in group)
  assumes finite': "finite (carrier G)" "a \<in> carrier G"
  shows pow_ord_eq_ord_iff: "group.ord G (a [^] k) = ord a \<longleftrightarrow> coprime k (ord a)" (is "?L \<longleftrightarrow> ?R")
    using assms ord_ge_1 [OF assms]
    by (auto simp: div_eq_dividend_iff ord_pow_gen coprime_iff_gcd_eq_1 gcd.commute split: if_split_asm)

lemma element_generates_subgroup:
  assumes finite[simp]: "finite (carrier G)"
  assumes a[simp]: "a \<in> carrier G"
  shows "subgroup {a [^] i | i. i \<in> {0 .. ord a - 1}} G"
  using generate_is_subgroup[of "{ a }"] assms(2)
        generate_pow_on_finite_carrier[OF assms]
  unfolding ord_elems[OF assms] by auto

end

section \<open>Number of Roots of a Polynomial\<close>
text_raw \<open>\label{sec:number-roots}\<close>

definition mult_of :: "('a, 'b) ring_scheme \<Rightarrow> 'a monoid" where
  "mult_of R \<equiv> \<lparr> carrier = carrier R - {\<zero>\<^bsub>R\<^esub>}, mult = mult R, one = \<one>\<^bsub>R\<^esub>\<rparr>"

lemma carrier_mult_of [simp]: "carrier (mult_of R) = carrier R - {\<zero>\<^bsub>R\<^esub>}"
  by (simp add: mult_of_def)

lemma mult_mult_of [simp]: "mult (mult_of R) = mult R"
 by (simp add: mult_of_def)

lemma nat_pow_mult_of: "([^]\<^bsub>mult_of R\<^esub>) = (([^]\<^bsub>R\<^esub>) :: _ \<Rightarrow> nat \<Rightarrow> _)"
  by (simp add: mult_of_def fun_eq_iff nat_pow_def)

lemma one_mult_of [simp]: "\<one>\<^bsub>mult_of R\<^esub> = \<one>\<^bsub>R\<^esub>"
  by (simp add: mult_of_def)

lemmas mult_of_simps = carrier_mult_of mult_mult_of nat_pow_mult_of one_mult_of

context field
begin

lemma mult_of_is_Units: "mult_of R = units_of R"
  unfolding mult_of_def units_of_def using field_Units by auto

lemma m_inv_mult_of:
"\<And>x. x \<in> carrier (mult_of R) \<Longrightarrow> m_inv (mult_of R) x = m_inv R x"
  using mult_of_is_Units units_of_inv unfolding units_of_def
  by simp

lemma (in field) field_mult_group: "group (mult_of R)"
  proof (rule groupI)
  show "\<exists>y\<in>carrier (mult_of R). y \<otimes>\<^bsub>mult_of R\<^esub> x = \<one>\<^bsub>mult_of R\<^esub>"
    if "x \<in> carrier (mult_of R)" for x
    using group.l_inv_ex mult_of_is_Units that units_group by fastforce
qed (auto simp: m_assoc dest: integral)

lemma finite_mult_of: "finite (carrier R) \<Longrightarrow> finite (carrier (mult_of R))"
  by simp

lemma order_mult_of: "finite (carrier R) \<Longrightarrow> order (mult_of R) = order R - 1"
  unfolding order_def carrier_mult_of by (simp add: card.remove)

end

lemma (in monoid) Units_pow_closed :
  fixes d :: nat
  assumes "x \<in> Units G"
  shows "x [^] d \<in> Units G"
    by (metis assms group.is_monoid monoid.nat_pow_closed units_group units_of_carrier units_of_pow)

lemma (in ring) r_right_minus_eq[simp]:
  assumes "a \<in> carrier R" "b \<in> carrier R"
  shows "a \<ominus> b = \<zero> \<longleftrightarrow> a = b"
  using assms by (metis a_minus_def add.inv_closed minus_equality r_neg)

context UP_cring begin

lemma is_UP_cring: "UP_cring R" by (unfold_locales)
lemma is_UP_ring:
  shows "UP_ring R" by (unfold_locales)

end

context UP_domain begin

lemma roots_bound:
  assumes f [simp]: "f \<in> carrier P"
  assumes f_not_zero: "f \<noteq> \<zero>\<^bsub>P\<^esub>"
  assumes finite: "finite (carrier R)"
  shows "finite {a \<in> carrier R . eval R R id a f = \<zero>} \<and>
         card {a \<in> carrier R . eval R R id a f = \<zero>} \<le> deg R f" using f f_not_zero
proof (induction "deg R f" arbitrary: f)
  case 0
  have "\<And>x. eval R R id x f \<noteq> \<zero>"
  proof -
    fix x
    have "(\<Oplus>i\<in>{..deg R f}. id (coeff P f i) \<otimes> x [^] i) \<noteq> \<zero>"
      using 0 lcoeff_nonzero_nonzero[where p = f] by simp
    thus "eval R R id x f \<noteq> \<zero>" using 0 unfolding eval_def P_def by simp
  qed
  then have *: "{a \<in> carrier R. eval R R (\<lambda>a. a) a f = \<zero>} = {}"
    by (auto simp: id_def)
  show ?case by (simp add: *)
next
  case (Suc x)
  show ?case
  proof (cases "\<exists> a \<in> carrier R . eval R R id a f = \<zero>")
    case True
    then obtain a where a_carrier[simp]: "a \<in> carrier R" and a_root: "eval R R id a f = \<zero>" by blast
    have R_not_triv: "carrier R \<noteq> {\<zero>}"
      by (metis R.one_zeroI R.zero_not_one)
    obtain q  where q: "(q \<in> carrier P)" and
      f: "f = (monom P \<one>\<^bsub>R\<^esub> 1 \<ominus>\<^bsub> P\<^esub> monom P a 0) \<otimes>\<^bsub>P\<^esub> q \<oplus>\<^bsub>P\<^esub> monom P (eval R R id a f) 0"
     using remainder_theorem[OF Suc.prems(1) a_carrier R_not_triv] by auto
    hence lin_fac: "f = (monom P \<one>\<^bsub>R\<^esub> 1 \<ominus>\<^bsub> P\<^esub> monom P a 0) \<otimes>\<^bsub>P\<^esub> q" using q by (simp add: a_root)
    have deg: "deg R (monom P \<one>\<^bsub>R\<^esub> 1 \<ominus>\<^bsub> P\<^esub> monom P a 0) = 1"
      using a_carrier by (simp add: deg_minus_eq)
    hence mon_not_zero: "(monom P \<one>\<^bsub>R\<^esub> 1 \<ominus>\<^bsub> P\<^esub> monom P a 0) \<noteq> \<zero>\<^bsub>P\<^esub>"
      by (fastforce simp del: r_right_minus_eq)
    have q_not_zero: "q \<noteq> \<zero>\<^bsub>P\<^esub>" using Suc by (auto simp add : lin_fac)
    hence "deg R q = x" using Suc deg deg_mult[OF mon_not_zero q_not_zero _ q]
      by (simp add : lin_fac)
    hence q_IH: "finite {a \<in> carrier R . eval R R id a q = \<zero>}
                \<and> card {a \<in> carrier R . eval R R id a q = \<zero>} \<le> x" using Suc q q_not_zero by blast
    have subs: "{a \<in> carrier R . eval R R id a f = \<zero>}
                \<subseteq> {a \<in> carrier R . eval R R id a q = \<zero>} \<union> {a}" (is "?L \<subseteq> ?R \<union> {a}")
      using a_carrier \<open>q \<in> _\<close>
      by (auto simp: evalRR_simps lin_fac R.integral_iff)
    have "{a \<in> carrier R . eval R R id a f = \<zero>} \<subseteq> insert a {a \<in> carrier R . eval R R id a q = \<zero>}"
     using subs by auto
    hence "card {a \<in> carrier R . eval R R id a f = \<zero>} \<le>
           card (insert a {a \<in> carrier R . eval R R id a q = \<zero>})" using q_IH by (blast intro: card_mono)
    also have "\<dots> \<le> deg R f" using q_IH \<open>Suc x = _\<close>
      by (simp add: card_insert_if)
    finally show ?thesis using q_IH \<open>Suc x = _\<close> using finite by force
  next
    case False
    hence "card {a \<in> carrier R. eval R R id a f = \<zero>} = 0" using finite by auto
    also have "\<dots> \<le>  deg R f" by simp
    finally show ?thesis using finite by auto
  qed
qed

end

lemma (in domain) num_roots_le_deg :
  fixes p d :: nat
  assumes finite: "finite (carrier R)"
  assumes d_neq_zero: "d \<noteq> 0"
  shows "card {x \<in> carrier R. x [^] d = \<one>} \<le> d"
proof -
  let ?f = "monom (UP R) \<one>\<^bsub>R\<^esub> d \<ominus>\<^bsub> (UP R)\<^esub> monom (UP R) \<one>\<^bsub>R\<^esub> 0"
  have one_in_carrier: "\<one> \<in> carrier R" by simp
  interpret R: UP_domain R "UP R" by (unfold_locales)
  have "deg R ?f = d"
    using d_neq_zero by (simp add: R.deg_minus_eq)
  hence f_not_zero: "?f \<noteq> \<zero>\<^bsub>UP R\<^esub>" using  d_neq_zero by (auto simp add : R.deg_nzero_nzero)
  have roots_bound: "finite {a \<in> carrier R . eval R R id a ?f = \<zero>} \<and>
                    card {a \<in> carrier R . eval R R id a ?f = \<zero>} \<le> deg R ?f"
                    using finite by (intro R.roots_bound[OF _ f_not_zero]) simp
  have subs: "{x \<in> carrier R. x [^] d = \<one>} \<subseteq> {a \<in> carrier R . eval R R id a ?f = \<zero>}"
    by (auto simp: R.evalRR_simps)
  then have "card {x \<in> carrier R. x [^] d = \<one>} \<le>
        card {a \<in> carrier R. eval R R id a ?f = \<zero>}" using finite by (simp add : card_mono)
  thus ?thesis using \<open>deg R ?f = d\<close> roots_bound by linarith
qed

section \<open>The Multiplicative Group of a Field\<close>
text_raw \<open>\label{sec:mult-group}\<close>

text \<open>
  In this section we show that the multiplicative group of a finite field
  is generated by a single element, i.e. it is cyclic. The proof is inspired
  by the first proof given in the survey~@{cite "conrad-cyclicity"}.
\<close>

context field begin

lemma num_elems_of_ord_eq_phi':
  assumes finite: "finite (carrier R)" and dvd: "d dvd order (mult_of R)"
      and exists: "\<exists>a\<in>carrier (mult_of R). group.ord (mult_of R) a = d"
  shows "card {a \<in> carrier (mult_of R). group.ord (mult_of R) a = d} = phi' d"
proof -
  note mult_of_simps[simp]
  have finite': "finite (carrier (mult_of R))" using finite by (rule finite_mult_of)

  interpret G:group "mult_of R" rewrites "([^]\<^bsub>mult_of R\<^esub>) = (([^]) :: _ \<Rightarrow> nat \<Rightarrow> _)" and "\<one>\<^bsub>mult_of R\<^esub> = \<one>"
    by (rule field_mult_group) simp_all

  from exists
  obtain a where a: "a \<in> carrier (mult_of R)" and ord_a: "group.ord (mult_of R) a = d"
    by (auto simp add: card_gt_0_iff)

  have set_eq1: "{a[^]n| n. n \<in> {1 .. d}} = {x \<in> carrier (mult_of R). x [^] d = \<one>}"
  proof (rule card_seteq)
    show "finite {x \<in> carrier (mult_of R). x [^] d = \<one>}" using finite by auto

    show "{a[^]n| n. n \<in> {1 ..d}} \<subseteq> {x \<in> carrier (mult_of R). x[^]d = \<one>}"
    proof
      fix x assume "x \<in> {a[^]n | n. n \<in> {1 .. d}}"
      then obtain n where n: "x = a[^]n \<and> n \<in> {1 .. d}" by auto
      have "x[^]d =(a[^]d)[^]n" using n a ord_a by (simp add:nat_pow_pow mult.commute)
      hence "x[^]d = \<one>" using ord_a G.pow_ord_eq_1[OF a] by fastforce
      thus "x \<in> {x \<in> carrier (mult_of R). x[^]d = \<one>}" using G.nat_pow_closed[OF a] n by blast
    qed

    show "card {x \<in> carrier (mult_of R). x [^] d = \<one>} \<le> card {a[^]n | n. n \<in> {1 .. d}}"
    proof -
      have *: "{a[^]n | n. n \<in> {1 .. d }} = ((\<lambda> n. a[^]n) ` {1 .. d})" by auto
      have "0 < order (mult_of R)" unfolding order_mult_of[OF finite]
        using card_mono[OF finite, of "{\<zero>, \<one>}"] by (simp add: order_def)
      have "card {x \<in> carrier (mult_of R). x [^] d = \<one>} \<le> card {x \<in> carrier R. x [^] d = \<one>}"
        using finite by (auto intro: card_mono)
      also have "\<dots> \<le> d" using \<open>0 < order (mult_of R)\<close> num_roots_le_deg[OF finite, of d]
        by (simp add : dvd_pos_nat[OF _ \<open>d dvd order (mult_of R)\<close>])
      finally show ?thesis using G.ord_inj'[OF a] ord_a * by (simp add: card_image)
    qed
  qed

  have set_eq2: "{x \<in> carrier (mult_of R) . group.ord (mult_of R) x = d}
                = (\<lambda> n . a[^]n) ` {n \<in> {1 .. d}. group.ord (mult_of R) (a[^]n) = d}" (is "?L = ?R")
  proof
    { fix x assume x: "x \<in> (carrier (mult_of R)) \<and> group.ord (mult_of R) x = d"
      hence "x \<in> {x \<in> carrier (mult_of R). x [^] d = \<one>}"
        by (simp add: G.pow_ord_eq_1[of x, symmetric])
      then obtain n where n: "x = a[^]n \<and> n \<in> {1 .. d}" using set_eq1 by blast
      hence "x \<in> ?R" using x by fast
    } thus "?L \<subseteq> ?R" by blast
    show "?R \<subseteq> ?L" using a by (auto simp add: carrier_mult_of[symmetric] simp del: carrier_mult_of)
  qed
  have "inj_on (\<lambda> n . a[^]n) {n \<in> {1 .. d}. group.ord (mult_of R) (a[^]n) = d}"
    using G.ord_inj'[OF a, unfolded ord_a] unfolding inj_on_def by fast
  hence "card ((\<lambda>n. a[^]n) ` {n \<in> {1 .. d}. group.ord (mult_of R) (a[^]n) = d})
         = card {k \<in> {1 .. d}. group.ord (mult_of R) (a[^]k) = d}"
         using card_image by blast
  thus ?thesis using set_eq2 G.pow_ord_eq_ord_iff[OF finite' \<open>a \<in> _\<close>, unfolded ord_a]
    by (simp add: phi'_def)
qed

end

theorem (in field) finite_field_mult_group_has_gen :
  assumes finite: "finite (carrier R)"
  shows "\<exists> a \<in> carrier (mult_of R) . carrier (mult_of R) = {a[^]i | i::nat . i \<in> UNIV}"
proof -
  note mult_of_simps[simp]
  have finite': "finite (carrier (mult_of R))" using finite by (rule finite_mult_of)

  interpret G: group "mult_of R" rewrites
      "([^]\<^bsub>mult_of R\<^esub>) = (([^]) :: _ \<Rightarrow> nat \<Rightarrow> _)" and "\<one>\<^bsub>mult_of R\<^esub> = \<one>"
    by (rule field_mult_group) (simp_all add: fun_eq_iff nat_pow_def)

  let ?N = "\<lambda> x . card {a \<in> carrier (mult_of R). group.ord (mult_of R) a  = x}"
  have "0 < order R - 1" unfolding order_def using card_mono[OF finite, of "{\<zero>, \<one>}"] by simp
  then have *: "0 < order (mult_of R)" using assms by (simp add: order_mult_of)
  have fin: "finite {d. d dvd order (mult_of R) }" using dvd_nat_bounds[OF *] by force

  have "(\<Sum>d | d dvd order (mult_of R). ?N d)
      = card (UN d:{d . d dvd order (mult_of R) }. {a \<in> carrier (mult_of R). group.ord (mult_of R) a  = d})"
      (is "_ = card ?U")
    using fin finite by (subst card_UN_disjoint) auto
  also have "?U = carrier (mult_of R)"
  proof
    { fix x assume x: "x \<in> carrier (mult_of R)"
      hence x': "x\<in>carrier (mult_of R)" by simp
      then have "group.ord (mult_of R) x dvd order (mult_of R)"
        using G.ord_dvd_group_order by blast
      hence "x \<in> ?U" using dvd_nat_bounds[of "order (mult_of R)" "group.ord (mult_of R) x"] x by blast
    } thus "carrier (mult_of R) \<subseteq> ?U" by blast
  qed auto
  also have "card ... = order (mult_of R)"
    using order_mult_of finite' by (simp add: order_def)
  finally have sum_Ns_eq: "(\<Sum>d | d dvd order (mult_of R). ?N d) = order (mult_of R)" .

  { fix d assume d: "d dvd order (mult_of R)"
    have "card {a \<in> carrier (mult_of R). group.ord (mult_of R) a = d} \<le> phi' d"
    proof cases
      assume "card {a \<in> carrier (mult_of R). group.ord (mult_of R) a = d} = 0" thus ?thesis by presburger
      next
      assume "card {a \<in> carrier (mult_of R). group.ord (mult_of R) a = d} \<noteq> 0"
      hence "\<exists>a \<in> carrier (mult_of R). group.ord (mult_of R) a = d" by (auto simp: card_eq_0_iff)
      thus ?thesis using num_elems_of_ord_eq_phi'[OF finite d] by auto
    qed
  }
  hence all_le: "\<And>i. i \<in> {d. d dvd order (mult_of R) }
        \<Longrightarrow> (\<lambda>i. card {a \<in> carrier (mult_of R). group.ord (mult_of R) a = i}) i \<le> (\<lambda>i. phi' i) i" by fast
  hence le: "(\<Sum>i | i dvd order (mult_of R). ?N i)
            \<le> (\<Sum>i | i dvd order (mult_of R). phi' i)"
            using sum_mono[of "{d .  d dvd order (mult_of R)}"
                  "\<lambda>i. card {a \<in> carrier (mult_of R). group.ord (mult_of R) a = i}"] by presburger
  have "order (mult_of R) = (\<Sum>d | d dvd order (mult_of R). phi' d)" using *
    by (simp add: sum_phi'_factors)
  hence eq: "(\<Sum>i | i dvd order (mult_of R). ?N i)
          = (\<Sum>i | i dvd order (mult_of R). phi' i)" using le sum_Ns_eq by presburger
  have "\<And>i. i \<in> {d. d dvd order (mult_of R) } \<Longrightarrow> ?N i = (\<lambda>i. phi' i) i"
  proof (rule ccontr)
    fix i
    assume i1: "i \<in> {d. d dvd order (mult_of R)}" and "?N i \<noteq> phi' i"
    hence "?N i = 0"
      using num_elems_of_ord_eq_phi'[OF finite, of i] by (auto simp: card_eq_0_iff)
    moreover  have "0 < i" using * i1 by (simp add: dvd_nat_bounds[of "order (mult_of R)" i])
    ultimately have "?N i < phi' i" using phi'_nonzero by presburger
    hence "(\<Sum>i | i dvd order (mult_of R). ?N i)
         < (\<Sum>i | i dvd order (mult_of R). phi' i)"
      using sum_strict_mono_ex1[OF fin, of "?N" "\<lambda> i . phi' i"]
            i1 all_le by auto
    thus False using eq by force
  qed
  hence "?N (order (mult_of R)) > 0" using * by (simp add: phi'_nonzero)
  then obtain a where a: "a \<in> carrier (mult_of R)" and a_ord: "group.ord (mult_of R) a = order (mult_of R)"
    by (auto simp add: card_gt_0_iff)
  hence set_eq: "{a[^]i | i::nat. i \<in> UNIV} = (\<lambda>x. a[^]x) ` {0 .. group.ord (mult_of R) a - 1}"
    using G.ord_elems[OF finite'] by auto
  have card_eq: "card ((\<lambda>x. a[^]x) ` {0 .. group.ord (mult_of R) a - 1}) = card {0 .. group.ord (mult_of R) a - 1}"
    by (intro card_image G.ord_inj finite' a)
  hence "card ((\<lambda> x . a[^]x) ` {0 .. group.ord (mult_of R) a - 1}) = card {0 ..order (mult_of R) - 1}"
    using assms by (simp add: card_eq a_ord)
  hence card_R_minus_1: "card {a[^]i | i::nat. i \<in> UNIV} =  order (mult_of R)"
    using * by (subst set_eq) auto
  have **: "{a[^]i | i::nat. i \<in> UNIV} \<subseteq> carrier (mult_of R)"
    using G.nat_pow_closed[OF a] by auto
  with _ have "carrier (mult_of R) = {a[^]i|i::nat. i \<in> UNIV}"
    by (rule card_seteq[symmetric]) (simp_all add: card_R_minus_1 finite order_def del: UNIV_I)
  thus ?thesis using a by blast
qed

end


theory prop_55
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun minus :: "Nat => Nat => Nat" where
  "minus (Z) y = Z"
  | "minus (S z) (Z) = S z"
  | "minus (S z) (S x2) = minus z x2"
  fun len :: "'a list => Nat" where
  "len (Nil2) = Z"
  | "len (Cons2 y xs) = S (len xs)"
  fun drop :: "Nat => 'a list => 'a list" where
  "drop (Z) y = y"
  | "drop (S z) (Nil2) = Nil2"
  | "drop (S z) (Cons2 x2 x3) = drop z x3"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  (*hipster minus len drop append *)
  theorem x0 :
    "(drop n (append xs ys)) =
       (append (drop n xs) (drop (minus n (len xs)) ys))"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


theory RollingRule imports HOLCF
begin

(* http://afp.sourceforge.net/browser_info/current/AFP/WorkerWrapper/FixedPointTheorems.html *)
lemma rolling_rule_ltr: "fix\<cdot>(g oo f) \<sqsubseteq> g\<cdot>(fix\<cdot>(f oo g))"
proof -
  have "g\<cdot>(fix\<cdot>(f oo g)) \<sqsubseteq> g\<cdot>(fix\<cdot>(f oo g))"
    by (rule below_refl) -- {* reflexivity *}
  hence "g\<cdot>((f oo g)\<cdot>(fix\<cdot>(f oo g))) \<sqsubseteq> g\<cdot>(fix\<cdot>(f oo g))"
    using fix_eq[where F="f oo g"] by simp -- {* computation *}
  hence "(g oo f)\<cdot>(g\<cdot>(fix\<cdot>(f oo g))) \<sqsubseteq> g\<cdot>(fix\<cdot>(f oo g))"
    by simp -- {* re-associate @{term "op oo"} *}
  thus "fix\<cdot>(g oo f) \<sqsubseteq> g\<cdot>(fix\<cdot>(f oo g))"
    using fix_least_below by blast -- {* induction *}
qed

lemma rolling_rule_rtl: "g\<cdot>(fix\<cdot>(f oo g)) \<sqsubseteq> fix\<cdot>(g oo f)"
proof -
  have "fix\<cdot>(f oo g) \<sqsubseteq> f\<cdot>(fix\<cdot>(g oo f))" by (rule rolling_rule_ltr)
  hence "g\<cdot>(fix\<cdot>(f oo g)) \<sqsubseteq> g\<cdot>(f\<cdot>(fix\<cdot>(g oo f)))"
    by (rule monofun_cfun_arg) -- {* g is monotonic *}
  thus "g\<cdot>(fix\<cdot>(f oo g)) \<sqsubseteq> fix\<cdot>(g oo f)"
    using fix_eq[where F="g oo f"] by simp -- {* computation *}
qed

lemma rolling_rule: "fix\<cdot>(g oo f) = g\<cdot>(fix\<cdot>(f oo g))"
  by (rule below_antisym[OF rolling_rule_ltr rolling_rule_rtl])

lemma rolling_rule2:
  assumes "cont F" and "cont G"
  shows "fix\<cdot>(\<Lambda> x. G (F x)) = G (fix\<cdot>(\<Lambda> x. F (G x)))"
  using cont_compose[OF assms(1), cont2cont] cont_compose[OF assms(2), cont2cont]
  using rolling_rule[where g = "\<Lambda> x. G x" and f = "\<Lambda> x. F x"]
  by (auto simp add: oo_def)

end