(*  Title:      ZF/ex/Primes.thy
    Author:     Christophe Tabacznyj and Lawrence C Paulson
    Copyright   1996  University of Cambridge
*)

section{*The Divides Relation and Euclid's algorithm for the GCD*}

theory Primes imports Main begin

definition
  divides :: "[i,i]=>o"              (infixl "dvd" 50)  where
    "m dvd n == m \<in> nat & n \<in> nat & (\<exists>k \<in> nat. n = m#*k)"

definition
  is_gcd  :: "[i,i,i]=>o"     --{*definition of great common divisor*}  where
    "is_gcd(p,m,n) == ((p dvd m) & (p dvd n))   &
                       (\<forall>d\<in>nat. (d dvd m) & (d dvd n) \<longrightarrow> d dvd p)"

definition
  gcd     :: "[i,i]=>i"       --{*Euclid's algorithm for the gcd*}  where
    "gcd(m,n) == transrec(natify(n),
                        %n f. \<lambda>m \<in> nat.
                                if n=0 then m else f`(m mod n)`n) ` natify(m)"

definition
  coprime :: "[i,i]=>o"       --{*the coprime relation*}  where
    "coprime(m,n) == gcd(m,n) = 1"

definition
  prime   :: i                --{*the set of prime numbers*}  where
   "prime == {p \<in> nat. 1<p & (\<forall>m \<in> nat. m dvd p \<longrightarrow> m=1 | m=p)}"

subsection{*The Divides Relation*}

lemma dvdD: "m dvd n ==> m \<in> nat & n \<in> nat & (\<exists>k \<in> nat. n = m#*k)"
by (unfold divides_def, assumption)

lemma dvdE:
     "[|m dvd n;  !!k. [|m \<in> nat; n \<in> nat; k \<in> nat; n = m#*k|] ==> P|] ==> P"
by (blast dest!: dvdD)

lemmas dvd_imp_nat1 = dvdD [THEN conjunct1]
lemmas dvd_imp_nat2 = dvdD [THEN conjunct2, THEN conjunct1]

lemma dvd_0_right [simp]: "m \<in> nat ==> m dvd 0"
apply (simp add: divides_def)
apply (fast intro: nat_0I mult_0_right [symmetric])
done

lemma dvd_0_left: "0 dvd m ==> m = 0"
by (simp add: divides_def)

lemma dvd_refl [simp]: "m \<in> nat ==> m dvd m"
apply (simp add: divides_def)
apply (fast intro: nat_1I mult_1_right [symmetric])
done

lemma dvd_trans: "[| m dvd n; n dvd p |] ==> m dvd p"
by (auto simp add: divides_def intro: mult_assoc mult_type)

lemma dvd_anti_sym: "[| m dvd n; n dvd m |] ==> m=n"
apply (simp add: divides_def)
apply (force dest: mult_eq_self_implies_10
             simp add: mult_assoc mult_eq_1_iff)
done

lemma dvd_mult_left: "[|(i#*j) dvd k; i \<in> nat|] ==> i dvd k"
by (auto simp add: divides_def mult_assoc)

lemma dvd_mult_right: "[|(i#*j) dvd k; j \<in> nat|] ==> j dvd k"
apply (simp add: divides_def, clarify)
apply (rule_tac x = "i#*ka" in bexI)
apply (simp add: mult_ac)
apply (rule mult_type)
done

subsection{*Euclid's Algorithm for the GCD*}

lemma gcd_0 [simp]: "gcd(m,0) = natify(m)"
apply (simp add: gcd_def)
apply (subst transrec, simp)
done

lemma gcd_natify1 [simp]: "gcd(natify(m),n) = gcd(m,n)"
by (simp add: gcd_def)

lemma gcd_natify2 [simp]: "gcd(m, natify(n)) = gcd(m,n)"
by (simp add: gcd_def)

lemma gcd_non_0_raw:
    "[| 0<n;  n \<in> nat |] ==> gcd(m,n) = gcd(n, m mod n)"
apply (simp add: gcd_def)
apply (rule_tac P = "%z. ?left (z) = ?right" in transrec [THEN ssubst])
apply (simp add: ltD [THEN mem_imp_not_eq, THEN not_sym]
                 mod_less_divisor [THEN ltD])
done

lemma gcd_non_0: "0 < natify(n) ==> gcd(m,n) = gcd(n, m mod n)"
apply (cut_tac m = m and n = "natify (n) " in gcd_non_0_raw)
apply auto
done

lemma gcd_1 [simp]: "gcd(m,1) = 1"
by (simp (no_asm_simp) add: gcd_non_0)

lemma dvd_add: "[| k dvd a; k dvd b |] ==> k dvd (a #+ b)"
apply (simp add: divides_def)
apply (fast intro: add_mult_distrib_left [symmetric] add_type)
done

lemma dvd_mult: "k dvd n ==> k dvd (m #* n)"
apply (simp add: divides_def)
apply (fast intro: mult_left_commute mult_type)
done

lemma dvd_mult2: "k dvd m ==> k dvd (m #* n)"
apply (subst mult_commute)
apply (blast intro: dvd_mult)
done

(* k dvd (m*k) *)
lemmas dvdI1 [simp] = dvd_refl [THEN dvd_mult]
lemmas dvdI2 [simp] = dvd_refl [THEN dvd_mult2]

lemma dvd_mod_imp_dvd_raw:
     "[| a \<in> nat; b \<in> nat; k dvd b; k dvd (a mod b) |] ==> k dvd a"
apply (case_tac "b=0")
 apply (simp add: DIVISION_BY_ZERO_MOD)
apply (blast intro: mod_div_equality [THEN subst]
             elim: dvdE
             intro!: dvd_add dvd_mult mult_type mod_type div_type)
done

lemma dvd_mod_imp_dvd: "[| k dvd (a mod b); k dvd b; a \<in> nat |] ==> k dvd a"
apply (cut_tac b = "natify (b)" in dvd_mod_imp_dvd_raw)
apply auto
apply (simp add: divides_def)
done

(*Imitating TFL*)
lemma gcd_induct_lemma [rule_format (no_asm)]: "[| n \<in> nat;
         \<forall>m \<in> nat. P(m,0);
         \<forall>m \<in> nat. \<forall>n \<in> nat. 0<n \<longrightarrow> P(n, m mod n) \<longrightarrow> P(m,n) |]
      ==> \<forall>m \<in> nat. P (m,n)"
apply (erule_tac i = n in complete_induct)
apply (case_tac "x=0")
apply (simp (no_asm_simp))
apply clarify
apply (drule_tac x1 = m and x = x in bspec [THEN bspec])
apply (simp_all add: Ord_0_lt_iff)
apply (blast intro: mod_less_divisor [THEN ltD])
done

lemma gcd_induct: "!!P. [| m \<in> nat; n \<in> nat;
         !!m. m \<in> nat ==> P(m,0);
         !!m n. [|m \<in> nat; n \<in> nat; 0<n; P(n, m mod n)|] ==> P(m,n) |]
      ==> P (m,n)"
by (blast intro: gcd_induct_lemma)

subsection{*Basic Properties of @{term gcd}*}

text{*type of gcd*}
lemma gcd_type [simp,TC]: "gcd(m, n) \<in> nat"
apply (subgoal_tac "gcd (natify (m), natify (n)) \<in> nat")
apply simp
apply (rule_tac m = "natify (m)" and n = "natify (n)" in gcd_induct)
apply auto
apply (simp add: gcd_non_0)
done

text{* Property 1: gcd(a,b) divides a and b *}

lemma gcd_dvd_both:
     "[| m \<in> nat; n \<in> nat |] ==> gcd (m, n) dvd m & gcd (m, n) dvd n"
apply (rule_tac m = m and n = n in gcd_induct)
apply (simp_all add: gcd_non_0)
apply (blast intro: dvd_mod_imp_dvd_raw nat_into_Ord [THEN Ord_0_lt])
done

lemma gcd_dvd1 [simp]: "m \<in> nat ==> gcd(m,n) dvd m"
apply (cut_tac m = "natify (m)" and n = "natify (n)" in gcd_dvd_both)
apply auto
done

lemma gcd_dvd2 [simp]: "n \<in> nat ==> gcd(m,n) dvd n"
apply (cut_tac m = "natify (m)" and n = "natify (n)" in gcd_dvd_both)
apply auto
done

text{* if f divides a and b then f divides gcd(a,b) *}

lemma dvd_mod: "[| f dvd a; f dvd b |] ==> f dvd (a mod b)"
apply (simp add: divides_def)
apply (case_tac "b=0")
 apply (simp add: DIVISION_BY_ZERO_MOD, auto)
apply (blast intro: mod_mult_distrib2 [symmetric])
done

text{* Property 2: for all a,b,f naturals,
               if f divides a and f divides b then f divides gcd(a,b)*}

lemma gcd_greatest_raw [rule_format]:
     "[| m \<in> nat; n \<in> nat; f \<in> nat |]
      ==> (f dvd m) \<longrightarrow> (f dvd n) \<longrightarrow> f dvd gcd(m,n)"
apply (rule_tac m = m and n = n in gcd_induct)
apply (simp_all add: gcd_non_0 dvd_mod)
done

lemma gcd_greatest: "[| f dvd m;  f dvd n;  f \<in> nat |] ==> f dvd gcd(m,n)"
apply (rule gcd_greatest_raw)
apply (auto simp add: divides_def)
done

lemma gcd_greatest_iff [simp]: "[| k \<in> nat; m \<in> nat; n \<in> nat |]
      ==> (k dvd gcd (m, n)) \<longleftrightarrow> (k dvd m & k dvd n)"
by (blast intro!: gcd_greatest gcd_dvd1 gcd_dvd2 intro: dvd_trans)

subsection{*The Greatest Common Divisor*}

text{*The GCD exists and function gcd computes it.*}

lemma is_gcd: "[| m \<in> nat; n \<in> nat |] ==> is_gcd(gcd(m,n), m, n)"
by (simp add: is_gcd_def)

text{*The GCD is unique*}

lemma is_gcd_unique: "[|is_gcd(m,a,b); is_gcd(n,a,b); m\<in>nat; n\<in>nat|] ==> m=n"
apply (simp add: is_gcd_def)
apply (blast intro: dvd_anti_sym)
done

lemma is_gcd_commute: "is_gcd(k,m,n) \<longleftrightarrow> is_gcd(k,n,m)"
by (simp add: is_gcd_def, blast)

lemma gcd_commute_raw: "[| m \<in> nat; n \<in> nat |] ==> gcd(m,n) = gcd(n,m)"
apply (rule is_gcd_unique)
apply (rule is_gcd)
apply (rule_tac [3] is_gcd_commute [THEN iffD1])
apply (rule_tac [3] is_gcd, auto)
done

lemma gcd_commute: "gcd(m,n) = gcd(n,m)"
apply (cut_tac m = "natify (m)" and n = "natify (n)" in gcd_commute_raw)
apply auto
done

lemma gcd_assoc_raw: "[| k \<in> nat; m \<in> nat; n \<in> nat |]
      ==> gcd (gcd (k, m), n) = gcd (k, gcd (m, n))"
apply (rule is_gcd_unique)
apply (rule is_gcd)
apply (simp_all add: is_gcd_def)
apply (blast intro: gcd_dvd1 gcd_dvd2 gcd_type intro: dvd_trans)
done

lemma gcd_assoc: "gcd (gcd (k, m), n) = gcd (k, gcd (m, n))"
apply (cut_tac k = "natify (k)" and m = "natify (m)" and n = "natify (n) "
       in gcd_assoc_raw)
apply auto
done

lemma gcd_0_left [simp]: "gcd (0, m) = natify(m)"
by (simp add: gcd_commute [of 0])

lemma gcd_1_left [simp]: "gcd (1, m) = 1"
by (simp add: gcd_commute [of 1])

subsection{*Addition laws*}

lemma gcd_add1 [simp]: "gcd (m #+ n, n) = gcd (m, n)"
apply (subgoal_tac "gcd (m #+ natify (n), natify (n)) = gcd (m, natify (n))")
apply simp
apply (case_tac "natify (n) = 0")
apply (auto simp add: Ord_0_lt_iff gcd_non_0)
done

lemma gcd_add2 [simp]: "gcd (m, m #+ n) = gcd (m, n)"
apply (rule gcd_commute [THEN trans])
apply (subst add_commute, simp)
apply (rule gcd_commute)
done

lemma gcd_add2' [simp]: "gcd (m, n #+ m) = gcd (m, n)"
by (subst add_commute, rule gcd_add2)

lemma gcd_add_mult_raw: "k \<in> nat ==> gcd (m, k #* m #+ n) = gcd (m, n)"
apply (erule nat_induct)
apply (auto simp add: gcd_add2 add_assoc)
done

lemma gcd_add_mult: "gcd (m, k #* m #+ n) = gcd (m, n)"
apply (cut_tac k = "natify (k)" in gcd_add_mult_raw)
apply auto
done

subsection{* Multiplication Laws*}

lemma gcd_mult_distrib2_raw:
     "[| k \<in> nat; m \<in> nat; n \<in> nat |]
      ==> k #* gcd (m, n) = gcd (k #* m, k #* n)"
apply (erule_tac m = m and n = n in gcd_induct, assumption)
apply simp
apply (case_tac "k = 0", simp)
apply (simp add: mod_geq gcd_non_0 mod_mult_distrib2 Ord_0_lt_iff)
done

lemma gcd_mult_distrib2: "k #* gcd (m, n) = gcd (k #* m, k #* n)"
apply (cut_tac k = "natify (k)" and m = "natify (m)" and n = "natify (n) "
       in gcd_mult_distrib2_raw)
apply auto
done

lemma gcd_mult [simp]: "gcd (k, k #* n) = natify(k)"
by (cut_tac k = k and m = 1 and n = n in gcd_mult_distrib2, auto)

lemma gcd_self [simp]: "gcd (k, k) = natify(k)"
by (cut_tac k = k and n = 1 in gcd_mult, auto)

lemma relprime_dvd_mult:
     "[| gcd (k,n) = 1;  k dvd (m #* n);  m \<in> nat |] ==> k dvd m"
apply (cut_tac k = m and m = k and n = n in gcd_mult_distrib2, auto)
apply (erule_tac b = m in ssubst)
apply (simp add: dvd_imp_nat1)
done

lemma relprime_dvd_mult_iff:
     "[| gcd (k,n) = 1;  m \<in> nat |] ==> k dvd (m #* n) \<longleftrightarrow> k dvd m"
by (blast intro: dvdI2 relprime_dvd_mult dvd_trans)

lemma prime_imp_relprime:
     "[| p \<in> prime;  ~ (p dvd n);  n \<in> nat |] ==> gcd (p, n) = 1"
apply (simp add: prime_def, clarify)
apply (drule_tac x = "gcd (p,n)" in bspec)
apply auto
apply (cut_tac m = p and n = n in gcd_dvd2, auto)
done

lemma prime_into_nat: "p \<in> prime ==> p \<in> nat"
by (simp add: prime_def)

lemma prime_nonzero: "p \<in> prime \<Longrightarrow> p\<noteq>0"
by (auto simp add: prime_def)

text{*This theorem leads immediately to a proof of the uniqueness of
  factorization.  If @{term p} divides a product of primes then it is
  one of those primes.*}

lemma prime_dvd_mult:
     "[|p dvd m #* n; p \<in> prime; m \<in> nat; n \<in> nat |] ==> p dvd m \<or> p dvd n"
by (blast intro: relprime_dvd_mult prime_imp_relprime prime_into_nat)

lemma gcd_mult_cancel_raw:
     "[|gcd (k,n) = 1; m \<in> nat; n \<in> nat|] ==> gcd (k #* m, n) = gcd (m, n)"
apply (rule dvd_anti_sym)
 apply (rule gcd_greatest)
  apply (rule relprime_dvd_mult [of _ k])
apply (simp add: gcd_assoc)
apply (simp add: gcd_commute)
apply (simp_all add: mult_commute)
apply (blast intro: dvdI1 gcd_dvd1 dvd_trans)
done

lemma gcd_mult_cancel: "gcd (k,n) = 1 ==> gcd (k #* m, n) = gcd (m, n)"
apply (cut_tac m = "natify (m)" and n = "natify (n)" in gcd_mult_cancel_raw)
apply auto
done

subsection{*The Square Root of a Prime is Irrational: Key Lemma*}

lemma prime_dvd_other_side:
     "\<lbrakk>n#*n = p#*(k#*k); p \<in> prime; n \<in> nat\<rbrakk> \<Longrightarrow> p dvd n"
apply (subgoal_tac "p dvd n#*n")
 apply (blast dest: prime_dvd_mult)
apply (rule_tac j = "k#*k" in dvd_mult_left)
 apply (auto simp add: prime_def)
done

lemma reduction:
     "\<lbrakk>k#*k = p#*(j#*j); p \<in> prime; 0 < k; j \<in> nat; k \<in> nat\<rbrakk>
      \<Longrightarrow> k < p#*j & 0 < j"
apply (rule ccontr)
apply (simp add: not_lt_iff_le prime_into_nat)
apply (erule disjE)
 apply (frule mult_le_mono, assumption+)
apply (simp add: mult_ac)
apply (auto dest!: natify_eqE
            simp add: not_lt_iff_le prime_into_nat mult_le_cancel_le1)
apply (simp add: prime_def)
apply (blast dest: lt_trans1)
done

lemma rearrange: "j #* (p#*j) = k#*k \<Longrightarrow> k#*k = p#*(j#*j)"
by (simp add: mult_ac)

lemma prime_not_square:
     "\<lbrakk>m \<in> nat; p \<in> prime\<rbrakk> \<Longrightarrow> \<forall>k \<in> nat. 0<k \<longrightarrow> m#*m \<noteq> p#*(k#*k)"
apply (erule complete_induct, clarify)
apply (frule prime_dvd_other_side, assumption)
apply assumption
apply (erule dvdE)
apply (simp add: mult_assoc mult_cancel1 prime_nonzero prime_into_nat)
apply (blast dest: rearrange reduction ltD)
done

end


theory Set_Mult
  imports "HOL-Algebra.Algebra"
begin

lemma (in group) set_mult_union:
  "A <#> (B \<union> C) = (A <#> B) \<union> (A <#> C)"
  unfolding set_mult_def by auto

lemma (in group) card_set_mult_single_el_eq:
  assumes "J \<subseteq> carrier G" "x \<in> carrier G"
  shows "card (l_coset G x J) = card J" unfolding l_coset_def
proof -
  have "card ((\<otimes>) x ` J) = card J" using inj_on_cmult[of x] card_image[of "(\<otimes>) x" J] assms inj_on_subset[of "(\<otimes>) x" "carrier G" J] by blast
  moreover have "(\<Union>y\<in>J. {x \<otimes> y}) = (\<otimes>) x ` J" using image_def[of "(\<otimes>) x" J] by blast
  ultimately show "card (\<Union>h\<in>J. {x \<otimes> h}) = card J" by presburger
qed

lemma (in group) set_mult_card_le:
  assumes "finite H" "H \<subseteq> carrier G" "J \<subseteq> carrier G"
  shows "card (H <#> J) \<le> card H * card J"
  using assms
proof (induction "card H" arbitrary: H)
  case 0
  then have "H = {}" by force
  then show ?case using set_mult_def[of G H J] by simp
next
  case (Suc n)
  then obtain a where a_def: "a \<in> H" by fastforce
  then have c_n:"card (H - {a}) = n" using Suc.hyps(2) Suc.prems(1) by force
  then have "card ((H - {a}) <#> J) \<le> card (H - {a}) * card J" using Suc by blast
  moreover have "card ({a} <#> J) = card J"
    using Suc(4, 5) a_def card_set_mult_single_el_eq[of J a] l_coset_eq_set_mult[of G a J] by auto
  moreover have "H <#> J = (H - {a} <#> J) \<union> ({a} <#> J)" using set_mult_def[of G _ J] a_def by auto
  moreover have "card (H - {a}) * card J + card J = Suc n * card J" using c_n mult_Suc by presburger
  ultimately show ?case using card_Un_le[of "H - {a} <#> J" "{a} <#> J"] c_n \<open>Suc n = card H\<close> by auto
qed

lemma (in group) set_mult_finite:
  assumes "finite H" "finite J" "H \<subseteq> carrier G" "J \<subseteq> carrier G"
  shows "finite (H <#> J)"
  using assms set_mult_def[of G H J] by auto

lemma (in group) set_mult_card_eq_impl_empty_inter:
  "\<lbrakk>finite H; finite J; H \<subseteq> carrier G; J \<subseteq> carrier G; card (H <#> J) = card H * card J\<rbrakk> \<Longrightarrow> (\<And>a b.\<lbrakk>a \<in> H; b \<in> H; a \<noteq> b\<rbrakk> \<Longrightarrow> ((\<otimes>) a ` J) \<inter> ((\<otimes>) b ` J) = {}) "
proof (induction H rule: finite_induct)
  case empty
  then show ?case by fast
next
  case step: (insert x H)

  from step.prems(2) have x_c: "x \<in> carrier G" by simp
  from step.prems(2) have H_c: "H \<subseteq> carrier G" by simp
  from card_set_mult_single_el_eq[of J x] have card_x: "card ({x} <#> J) = card J" using \<open>J \<subseteq> carrier G\<close> x_c l_coset_eq_set_mult by metis
  moreover have ins: "(insert x H) <#> J = (H <#> J) \<union> ({x} <#> J)" using set_mult_def[of G _ J] by auto
  ultimately have "card (H <#> J) \<ge> card H * card J" using card_Un_le[of "H <#> J" "{x} <#> J"] \<open>card (insert x H <#> J) = card (insert x H) * card J\<close>
    by (simp add: step.hyps(1) step.hyps(2))
  then have card_eq:"card (H <#> J) = card H * card J" using set_mult_card_le[of H J] step.hyps(1) step.prems(1, 3) H_c by linarith
  then have ih:"(\<And>a b.\<lbrakk>a \<in> H; b \<in> H; a \<noteq> b\<rbrakk> \<Longrightarrow> ((\<otimes>) a ` J) \<inter> ((\<otimes>) b ` J) = {})" using step.IH step.hyps(1) step.prems(1, 3) H_c by presburger

  have "card (insert x H) * card J = card H * card J + card J" using \<open>x \<notin> H\<close> using step.hyps(1) by simp
  then have "({x} <#> J) \<inter> (H <#> J) = {}" using card_eq card_x ins card_Un_Int[of "H <#> J" "{x} <#> J"] step.prems(3, 4) \<open>finite H\<close> \<open>finite J\<close> set_mult_finite H_c x_c by auto
  then have "\<And>a. a \<in> H \<Longrightarrow> (\<Union>y\<in>J. {a \<otimes> y}) \<inter> (\<Union>y\<in>J. {x \<otimes> y}) = {}" using set_mult_def[of G _ J] by blast
  then have "\<And>a b.\<lbrakk>a \<in> (insert x H); b \<in> (insert x H); a \<noteq> b\<rbrakk> \<Longrightarrow> ((\<otimes>) a ` J) \<inter> ((\<otimes>) b ` J) = {}" using \<open>x \<notin> H\<close> ih by blast (* slow *)
  then show ?case using step by algebra
qed

lemma (in group) set_mult_card_eq_impl_empty_inter':
  "\<lbrakk>finite H; finite J; H \<subseteq> carrier G; J \<subseteq> carrier G; card (H <#> J) = card H * card J\<rbrakk> \<Longrightarrow> (\<And>a b.\<lbrakk>a \<in> H; b \<in> H; a \<noteq> b\<rbrakk> \<Longrightarrow> (l_coset G a J) \<inter> (l_coset G b J) = {})"
  unfolding l_coset_def
  using set_mult_card_eq_impl_empty_inter image_def[of "(\<otimes>) _" J] by blast

lemma (in comm_group) set_mult_comm:
  assumes "H \<subseteq> carrier G" "J \<subseteq> carrier G"
  shows "(H <#> J) = (J <#> H)"
  unfolding set_mult_def
proof -
  have 1:"\<And>a b. \<lbrakk>a \<in> carrier G; b \<in> carrier G\<rbrakk> \<Longrightarrow> {a \<otimes> b} = {b \<otimes> a}" using m_comm by simp
  then have "\<And>a b.\<lbrakk>a \<in> H; b \<in> J\<rbrakk> \<Longrightarrow> {a \<otimes> b} = {b \<otimes> a}" using assms by auto
  moreover have "\<And>a b.\<lbrakk>b \<in> H; a \<in> J\<rbrakk> \<Longrightarrow> {a \<otimes> b} = {b \<otimes> a}" using assms 1 by auto
  ultimately show "(\<Union>h\<in>H. \<Union>k\<in>J. {h \<otimes> k}) = (\<Union>k\<in>J. \<Union>h\<in>H. {k \<otimes> h})"  by fast
qed

lemma (in group) one_imp_set_mult_inc:
  assumes "\<one> \<in> A" "A \<subseteq> carrier G" "B \<subseteq> carrier G"
  shows "B \<subseteq> (B <#> A)"
proof
  fix x
  assume "x \<in> B"
  thus "x \<in> (B <#> A)" using assms unfolding set_mult_def by force
qed

lemma (in group) set_mult_subset_generate:
  assumes "A \<subseteq> carrier G" "B \<subseteq> carrier G"
  shows "A <#> B \<subseteq> generate G (A \<union> B)"
proof
  fix x
  assume "x \<in> A <#> B"
  then obtain a b where ab: "a \<in> A" "b \<in> B" "x = a \<otimes> b" unfolding set_mult_def by blast
  then have "a \<in> generate G (A \<union> B)" "b \<in> generate G (A \<union> B)" using generate.incl[of _ "A \<union> B" G] by simp+
  thus "x \<in> generate G (A \<union> B)" using ab generate.eng by metis
qed

lemma (in comm_group) generate_subgroup_eq_set_mult:
  assumes "subgroup H G" "subgroup J G"
  shows "generate G (H \<union> J) = H <#> J" (is "?L = ?R")
proof
  show "?L \<subseteq> ?R"
  proof
    fix x
    assume "x \<in> ?L"
    then show "x \<in> ?R"
    proof(induction rule: generate.induct)
      case one
      moreover have "\<one> \<in> H" using assms subgroup.one_closed by auto
      moreover have "\<one> \<in> J" using assms subgroup.one_closed by auto
      moreover have "\<one> \<otimes> \<one> = \<one>" using nat_pow_one[of 2] by simp
      ultimately show ?case using assms set_mult_def[of G H J] by fastforce
    next
      case (incl x)
      have H1:"\<one> \<in> H" using assms subgroup.one_closed by auto
      have J1:"\<one> \<in> J" using assms subgroup.one_closed by auto
      have lx:"x \<otimes> \<one> = x" using r_one[of x] incl subgroup.subset[of J G] subgroup.subset[of H G] assms by blast
      have rx:"\<one> \<otimes> x = x" using l_one[of x] incl subgroup.subset[of J G] subgroup.subset[of H G] assms by blast
      show ?case
      proof (cases "x \<in> H")
        case True
        then show ?thesis using set_mult_def[of G H J] J1 lx by fastforce
      next
        case False
        then show ?thesis using set_mult_def[of G H J] H1 rx incl by fastforce
      qed
    next
      case (inv h)
      then have inv_in:"(inv h) \<in> H \<union> J" (is "?iv \<in> H \<union> J") using assms subgroup.m_inv_closed[of _ G h] by (cases "h \<in> H"; blast)
      have H1:"\<one> \<in> H" using assms subgroup.one_closed by auto
      have J1:"\<one> \<in> J" using assms subgroup.one_closed by auto
      have lx:"?iv \<otimes> \<one> = ?iv" using r_one[of "?iv"] subgroup.subset[of J G] subgroup.subset[of H G] inv_in assms by blast
      have rx:"\<one> \<otimes> ?iv = ?iv" using l_one[of "?iv"] incl subgroup.subset[of J G] subgroup.subset[of H G] inv_in assms by blast
      show ?case
      proof (cases "?iv \<in> H")
        case True
        then show ?thesis using set_mult_def[of G H J] J1 lx by fastforce
      next
        case False
        then show ?thesis using set_mult_def[of G H J] H1 rx inv_in by fastforce
      qed
    next
      case (eng h g)
      from eng(3) have "\<exists>a \<in> H. \<exists>b \<in> J. h = a \<otimes> b" using set_mult_def[of G H J] by blast
      then obtain a b where aH: "a \<in> H" and bJ: "b \<in> J" and h_def: "h = a \<otimes> b" by blast
      have a_carr: "a \<in> carrier G" by (metis subgroup.mem_carrier assms(1) aH)
      have b_carr: "b \<in> carrier G" by (metis subgroup.mem_carrier assms(2) bJ)
      from eng(4) have "\<exists>c \<in> H. \<exists>d \<in> J. g = c \<otimes> d" using set_mult_def[of G H J] by blast
      then obtain c d where cH: "c \<in> H" and dJ: "d \<in> J" and g_def: "g = c \<otimes> d" by blast
      have c_carr: "c \<in> carrier G" by (metis subgroup.mem_carrier assms(1) cH)
      have d_carr: "d \<in> carrier G" by (metis subgroup.mem_carrier assms(2) dJ)
      then have "h \<otimes> g = (a \<otimes> c) \<otimes> (b \<otimes> d)" using a_carr b_carr c_carr d_carr g_def h_def m_assoc m_comm by force
      moreover have "a \<otimes> c \<in> H" using assms(1) aH cH subgroup.m_closed[of H G a c] by blast
      moreover have "b \<otimes> d \<in> J" using assms(2) bJ dJ subgroup.m_closed[of J G b d] by blast
      ultimately show ?case using set_mult_def by fast
    qed
  qed
next
  show "?R \<subseteq> ?L" using set_mult_subset_generate[of H J] subgroup.subset assms by blast
qed

end


(*  Title:      HOL/ex/Primrec.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1997  University of Cambridge
*)

section \<open>Ackermann's Function and the Primitive Recursive Functions\<close>

theory Primrec imports Main begin

text \<open>
  Proof adopted from

  Nora Szasz, A Machine Checked Proof that Ackermann's Function is not
  Primitive Recursive, In: Huet \& Plotkin, eds., Logical Environments
  (CUP, 1993), 317-338.

  See also E. Mendelson, Introduction to Mathematical Logic.  (Van
  Nostrand, 1964), page 250, exercise 11.
  \medskip
\<close>

subsection\<open>Ackermann's Function\<close>

fun ack :: "[nat,nat] \<Rightarrow> nat" where
  "ack 0 n =  Suc n"
| "ack (Suc m) 0 = ack m 1"
| "ack (Suc m) (Suc n) = ack m (ack (Suc m) n)"

text \<open>PROPERTY A 4\<close>

lemma less_ack2 [iff]: "j < ack i j"
  by (induct i j rule: ack.induct) simp_all

text \<open>PROPERTY A 5-, the single-step lemma\<close>

lemma ack_less_ack_Suc2 [iff]: "ack i j < ack i (Suc j)"
  by (induct i j rule: ack.induct) simp_all

text \<open>PROPERTY A 5, monotonicity for \<open><\<close>\<close>

lemma ack_less_mono2: "j < k \<Longrightarrow> ack i j < ack i k"
  by (simp add: lift_Suc_mono_less)

text \<open>PROPERTY A 5', monotonicity for \<open>\<le>\<close>\<close>

lemma ack_le_mono2: "j \<le> k \<Longrightarrow> ack i j \<le> ack i k"
  by (simp add: ack_less_mono2 less_mono_imp_le_mono)

text \<open>PROPERTY A 6\<close>

lemma ack2_le_ack1 [iff]: "ack i (Suc j) \<le> ack (Suc i) j"
proof (induct j)
  case 0 show ?case by simp
next
  case (Suc j) show ?case
    by (metis Suc ack.simps(3) ack_le_mono2 le_trans less_ack2 less_eq_Suc_le)
qed

text \<open>PROPERTY A 7-, the single-step lemma\<close>

lemma ack_less_ack_Suc1 [iff]: "ack i j < ack (Suc i) j"
  by (blast intro: ack_less_mono2 less_le_trans)

text \<open>PROPERTY A 4'? Extra lemma needed for \<^term>\<open>CONSTANT\<close> case, constant functions\<close>

lemma less_ack1 [iff]: "i < ack i j"
proof (induct i)
  case 0
  then show ?case
    by simp
next
  case (Suc i)
  then show ?case
    using less_trans_Suc by blast
qed

text \<open>PROPERTY A 8\<close>

lemma ack_1 [simp]: "ack (Suc 0) j = j + 2"
  by (induct j) simp_all

text \<open>PROPERTY A 9.  The unary \<open>1\<close> and \<open>2\<close> in \<^term>\<open>ack\<close> is essential for the rewriting.\<close>

lemma ack_2 [simp]: "ack (Suc (Suc 0)) j = 2 * j + 3"
  by (induct j) simp_all

text \<open>PROPERTY A 7, monotonicity for \<open><\<close> [not clear why
  @{thm [source] ack_1} is now needed first!]\<close>

lemma ack_less_mono1_aux: "ack i k < ack (Suc (i +i')) k"
proof (induct i k rule: ack.induct)
  case (1 n) show ?case
    using less_le_trans by auto
next
  case (2 m) thus ?case by simp
next
  case (3 m n) thus ?case
    using ack_less_mono2 less_trans by fastforce
qed

lemma ack_less_mono1: "i < j \<Longrightarrow> ack i k < ack j k"
  using ack_less_mono1_aux less_iff_Suc_add by auto

text \<open>PROPERTY A 7', monotonicity for \<open>\<le>\<close>\<close>

lemma ack_le_mono1: "i \<le> j \<Longrightarrow> ack i k \<le> ack j k"
  using ack_less_mono1 le_eq_less_or_eq by auto

text \<open>PROPERTY A 10\<close>

lemma ack_nest_bound: "ack i1 (ack i2 j) < ack (2 + (i1 + i2)) j"
proof -
  have "ack i1 (ack i2 j) < ack (i1 + i2) (ack (Suc (i1 + i2)) j)"
    by (meson ack_le_mono1 ack_less_mono1 ack_less_mono2 le_add1 le_trans less_add_Suc2 not_less)
  also have "... = ack (Suc (i1 + i2)) (Suc j)"
    by simp
  also have "... \<le> ack (2 + (i1 + i2)) j"
    using ack2_le_ack1 add_2_eq_Suc by presburger
  finally show ?thesis .
qed

text \<open>PROPERTY A 11\<close>

lemma ack_add_bound: "ack i1 j + ack i2 j < ack (4 + (i1 + i2)) j"
proof -
  have "ack i1 j \<le> ack (i1 + i2) j" "ack i2 j \<le> ack (i1 + i2) j"
    by (simp_all add: ack_le_mono1)
  then have "ack i1 j + ack i2 j < ack (Suc (Suc 0)) (ack (i1 + i2) j)"
    by simp
  also have "... < ack (4 + (i1 + i2)) j"
    by (metis ack_nest_bound add.assoc numeral_2_eq_2 numeral_Bit0)
  finally show ?thesis .
qed

text \<open>PROPERTY A 12.  Article uses existential quantifier but the ALF proof
  used \<open>k + 4\<close>.  Quantified version must be nested \<open>\<exists>k'. \<forall>i j. ...\<close>\<close>

lemma ack_add_bound2:
  assumes "i < ack k j" shows "i + j < ack (4 + k) j"
proof -
  have "i + j < ack k j + ack 0 j"
    using assms by auto
  also have "... < ack (4 + k) j"
    by (metis ack_add_bound add.right_neutral)
  finally show ?thesis .
qed

subsection\<open>Primitive Recursive Functions\<close>

primrec hd0 :: "nat list \<Rightarrow> nat" where
  "hd0 [] = 0"
| "hd0 (m # ms) = m"

text \<open>Inductive definition of the set of primitive recursive functions of type \<^typ>\<open>nat list \<Rightarrow> nat\<close>.\<close>

definition SC :: "nat list \<Rightarrow> nat"
  where "SC l = Suc (hd0 l)"

definition CONSTANT :: "nat \<Rightarrow> nat list \<Rightarrow> nat"
  where "CONSTANT k l = k"

definition PROJ :: "nat \<Rightarrow> nat list \<Rightarrow> nat"
  where "PROJ i l = hd0 (drop i l)"

definition COMP :: "[nat list \<Rightarrow> nat, (nat list \<Rightarrow> nat) list, nat list] \<Rightarrow> nat"
  where "COMP g fs l = g (map (\<lambda>f. f l) fs)"

fun PREC :: "[nat list \<Rightarrow> nat, nat list \<Rightarrow> nat, nat list] \<Rightarrow> nat"
  where
    "PREC f g [] = 0"
  | "PREC f g (x # l) = rec_nat (f l) (\<lambda>y r. g (r # y # l)) x"
    \<comment> \<open>Note that \<^term>\<open>g\<close> is applied first to \<^term>\<open>PREC f g y\<close> and then to \<^term>\<open>y\<close>!\<close>

inductive PRIMREC :: "(nat list \<Rightarrow> nat) \<Rightarrow> bool" where
  SC: "PRIMREC SC"
| CONSTANT: "PRIMREC (CONSTANT k)"
| PROJ: "PRIMREC (PROJ i)"
| COMP: "PRIMREC g \<Longrightarrow> \<forall>f \<in> set fs. PRIMREC f \<Longrightarrow> PRIMREC (COMP g fs)"
| PREC: "PRIMREC f \<Longrightarrow> PRIMREC g \<Longrightarrow> PRIMREC (PREC f g)"

text \<open>Useful special cases of evaluation\<close>

lemma SC [simp]: "SC (x # l) = Suc x"
  by (simp add: SC_def)

lemma PROJ_0 [simp]: "PROJ 0 (x # l) = x"
  by (simp add: PROJ_def)

lemma COMP_1 [simp]: "COMP g [f] l = g [f l]"
  by (simp add: COMP_def)

lemma PREC_0: "PREC f g (0 # l) = f l"
  by simp

lemma PREC_Suc [simp]: "PREC f g (Suc x # l) = g (PREC f g (x # l) # x # l)"
  by auto

subsection \<open>MAIN RESULT\<close>

lemma SC_case: "SC l < ack 1 (sum_list l)"
  unfolding SC_def
  by (induct l) (simp_all add: le_add1 le_imp_less_Suc)

lemma CONSTANT_case: "CONSTANT k l < ack k (sum_list l)"
  by (simp add: CONSTANT_def)

lemma PROJ_case: "PROJ i l < ack 0 (sum_list l)"
  unfolding PROJ_def
proof (induct l arbitrary: i)
  case Nil
  then show ?case
    by simp
next
  case (Cons a l)
  then show ?case
    by (metis ack.simps(1) add.commute drop_Cons' hd0.simps(2) leD leI lessI not_less_eq sum_list.Cons trans_le_add2)
qed

text \<open>\<^term>\<open>COMP\<close> case\<close>

lemma COMP_map_aux: "\<forall>f \<in> set fs. PRIMREC f \<and> (\<exists>kf. \<forall>l. f l < ack kf (sum_list l))
  \<Longrightarrow> \<exists>k. \<forall>l. sum_list (map (\<lambda>f. f l) fs) < ack k (sum_list l)"
proof (induct fs)
  case Nil
  then show ?case
    by auto
next
  case (Cons a fs)
  then show ?case
    by simp (blast intro: add_less_mono ack_add_bound less_trans)
qed

lemma COMP_case:
  assumes 1: "\<forall>l. g l < ack kg (sum_list l)"
      and 2: "\<forall>f \<in> set fs. PRIMREC f \<and> (\<exists>kf. \<forall>l. f l < ack kf (sum_list l))"
  shows "\<exists>k. \<forall>l. COMP g fs  l < ack k (sum_list l)"
  unfolding COMP_def
  using 1 COMP_map_aux [OF 2] by (meson ack_less_mono2 ack_nest_bound less_trans)

text \<open>\<^term>\<open>PREC\<close> case\<close>

lemma PREC_case_aux:
  assumes f: "\<And>l. f l + sum_list l < ack kf (sum_list l)"
      and g: "\<And>l. g l + sum_list l < ack kg (sum_list l)"
  shows "PREC f g l + sum_list l < ack (Suc (kf + kg)) (sum_list l)"
proof (cases l)
  case Nil
  then show ?thesis
    by (simp add: Suc_lessD)
next
  case (Cons m l)
  have "rec_nat (f l) (\<lambda>y r. g (r # y # l)) m + (m + sum_list l) < ack (Suc (kf + kg)) (m + sum_list l)"
  proof (induct m)
    case 0
    then show ?case
      using ack_less_mono1_aux f less_trans by fastforce
  next
    case (Suc m)
    let ?r = "rec_nat (f l) (\<lambda>y r. g (r # y # l)) m"
    have "\<not> g (?r # m # l) + sum_list (?r # m # l) < g (?r # m # l) + (m + sum_list l)"
      by force
    then have "g (?r # m # l) + (m + sum_list l) < ack kg (sum_list (?r # m # l))"
      by (meson assms(2) leI less_le_trans)
    moreover
    have "... < ack (kf + kg) (ack (Suc (kf + kg)) (m + sum_list l))"
      using Suc.hyps by simp (meson ack_le_mono1 ack_less_mono2 le_add2 le_less_trans)
    ultimately show ?case
      by auto
  qed
  then show ?thesis
    by (simp add: local.Cons)
qed

proposition PREC_case:
  "\<lbrakk>\<And>l. f l < ack kf (sum_list l); \<And>l. g l < ack kg (sum_list l)\<rbrakk>
  \<Longrightarrow> \<exists>k. \<forall>l. PREC f g l < ack k (sum_list l)"
  by (metis le_less_trans [OF le_add1 PREC_case_aux] ack_add_bound2)

lemma ack_bounds_PRIMREC: "PRIMREC f \<Longrightarrow> \<exists>k. \<forall>l. f l < ack k (sum_list l)"
  by (erule PRIMREC.induct) (blast intro: SC_case CONSTANT_case PROJ_case COMP_case PREC_case)+

theorem ack_not_PRIMREC:
  "\<not> PRIMREC (\<lambda>l. case l of [] \<Rightarrow> 0 | x # l' \<Rightarrow> ack x x)"
proof
  assume *: "PRIMREC (\<lambda>l. case l of [] \<Rightarrow> 0 | x # l' \<Rightarrow> ack x x)"
  then obtain m where m: "\<And>l. (case l of [] \<Rightarrow> 0 | x # l' \<Rightarrow> ack x x) < ack m (sum_list l)"
    using ack_bounds_PRIMREC by metis
  show False
    using m [of "[m]"] by simp
qed

end


(*<*)theory PDL imports Base begin(*>*)

subsection{*Propositional Dynamic Logic --- PDL*}

text{*\index{PDL|(}
The formulae of PDL are built up from atomic propositions via
negation and conjunction and the two temporal
connectives @{text AX} and @{text EF}\@. Since formulae are essentially
syntax trees, they are naturally modelled as a datatype:%
\footnote{The customary definition of PDL
@{cite "HarelKT-DL"} looks quite different from ours, but the two are easily
shown to be equivalent.}
*}

datatype formula = Atom "atom"
                  | Neg formula
                  | And formula formula
                  | AX formula
                  | EF formula

text{*\noindent
This resembles the boolean expression case study in
\S\ref{sec:boolex}.
A validity relation between states and formulae specifies the semantics.
The syntax annotation allows us to write @{text"s \<Turnstile> f"} instead of
\hbox{@{text"valid s f"}}. The definition is by recursion over the syntax:
*}

primrec valid :: "state \<Rightarrow> formula \<Rightarrow> bool"   ("(_ \<Turnstile> _)" [80,80] 80)
where
"s \<Turnstile> Atom a  = (a \<in> L s)" |
"s \<Turnstile> Neg f   = (\<not>(s \<Turnstile> f))" |
"s \<Turnstile> And f g = (s \<Turnstile> f \<and> s \<Turnstile> g)" |
"s \<Turnstile> AX f    = (\<forall>t. (s,t) \<in> M \<longrightarrow> t \<Turnstile> f)" |
"s \<Turnstile> EF f    = (\<exists>t. (s,t) \<in> M\<^sup>* \<and> t \<Turnstile> f)"

text{*\noindent
The first three equations should be self-explanatory. The temporal formula
@{term"AX f"} means that @{term f} is true in \emph{A}ll ne\emph{X}t states whereas
@{term"EF f"} means that there \emph{E}xists some \emph{F}uture state in which @{term f} is
true. The future is expressed via @{text"\<^sup>*"}, the reflexive transitive
closure. Because of reflexivity, the future includes the present.

Now we come to the model checker itself. It maps a formula into the
set of states where the formula is true.  It too is defined by
recursion over the syntax: *}

primrec mc :: "formula \<Rightarrow> state set" where
"mc(Atom a)  = {s. a \<in> L s}" |
"mc(Neg f)   = -mc f" |
"mc(And f g) = mc f \<inter> mc g" |
"mc(AX f)    = {s. \<forall>t. (s,t) \<in> M  \<longrightarrow> t \<in> mc f}" |
"mc(EF f)    = lfp(\<lambda>T. mc f \<union> (M\<inverse> `` T))"

text{*\noindent
Only the equation for @{term EF} deserves some comments. Remember that the
postfix @{text"\<inverse>"} and the infix @{text"``"} are predefined and denote the
converse of a relation and the image of a set under a relation.  Thus
@{term "M\<inverse> `` T"} is the set of all predecessors of @{term T} and the least
fixed point (@{term lfp}) of @{term"\<lambda>T. mc f \<union> M\<inverse> `` T"} is the least set
@{term T} containing @{term"mc f"} and all predecessors of @{term T}. If you
find it hard to see that @{term"mc(EF f)"} contains exactly those states from
which there is a path to a state where @{term f} is true, do not worry --- this
will be proved in a moment.

First we prove monotonicity of the function inside @{term lfp}
in order to make sure it really has a least fixed point.
*}

lemma mono_ef: "mono(\<lambda>T. A \<union> (M\<inverse> `` T))"
apply(rule monoI)
apply blast
done

text{*\noindent
Now we can relate model checking and semantics. For the @{text EF} case we need
a separate lemma:
*}

lemma EF_lemma:
  "lfp(\<lambda>T. A \<union> (M\<inverse> `` T)) = {s. \<exists>t. (s,t) \<in> M\<^sup>* \<and> t \<in> A}"

txt{*\noindent
The equality is proved in the canonical fashion by proving that each set
includes the other; the inclusion is shown pointwise:
*}

apply(rule equalityI)
 apply(rule subsetI)
 apply(simp)(*<*)apply(rename_tac s)(*>*)

txt{*\noindent
Simplification leaves us with the following first subgoal
@{subgoals[display,indent=0,goals_limit=1]}
which is proved by @{term lfp}-induction:
*}

 apply(erule lfp_induct_set)
  apply(rule mono_ef)
 apply(simp)
txt{*\noindent
Having disposed of the monotonicity subgoal,
simplification leaves us with the following goal:
\begin{isabelle}
\ {\isadigit{1}}{\isachardot}\ {\isasymAnd}x{\isachardot}\ x\ {\isasymin}\ A\ {\isasymor}\isanewline
\ \ \ \ \ \ \ \ \ x\ {\isasymin}\ M{\isasyminverse}\ {\isacharbackquote}{\isacharbackquote}\ {\isacharparenleft}lfp\ {\isacharparenleft}\dots{\isacharparenright}\ {\isasyminter}\ {\isacharbraceleft}x{\isachardot}\ {\isasymexists}t{\isachardot}\ {\isacharparenleft}x{\isacharcomma}\ t{\isacharparenright}\ {\isasymin}\ M\isactrlsup {\isacharasterisk}\ {\isasymand}\ t\ {\isasymin}\ A{\isacharbraceright}{\isacharparenright}\isanewline
\ \ \ \ \ \ \ \ {\isasymLongrightarrow}\ {\isasymexists}t{\isachardot}\ {\isacharparenleft}x{\isacharcomma}\ t{\isacharparenright}\ {\isasymin}\ M\isactrlsup {\isacharasterisk}\ {\isasymand}\ t\ {\isasymin}\ A
\end{isabelle}
It is proved by @{text blast}, using the transitivity of
\isa{M\isactrlsup {\isacharasterisk}}.
*}

 apply(blast intro: rtrancl_trans)

txt{*
We now return to the second set inclusion subgoal, which is again proved
pointwise:
*}

apply(rule subsetI)
apply(simp, clarify)

txt{*\noindent
After simplification and clarification we are left with
@{subgoals[display,indent=0,goals_limit=1]}
This goal is proved by induction on @{term"(s,t)\<in>M\<^sup>*"}. But since the model
checker works backwards (from @{term t} to @{term s}), we cannot use the
induction theorem @{thm[source]rtrancl_induct}: it works in the
forward direction. Fortunately the converse induction theorem
@{thm[source]converse_rtrancl_induct} already exists:
@{thm[display,margin=60]converse_rtrancl_induct[no_vars]}
It says that if @{prop"(a,b):r\<^sup>*"} and we know @{prop"P b"} then we can infer
@{prop"P a"} provided each step backwards from a predecessor @{term z} of
@{term b} preserves @{term P}.
*}

apply(erule converse_rtrancl_induct)

txt{*\noindent
The base case
@{subgoals[display,indent=0,goals_limit=1]}
is solved by unrolling @{term lfp} once
*}

 apply(subst lfp_unfold[OF mono_ef])

txt{*
@{subgoals[display,indent=0,goals_limit=1]}
and disposing of the resulting trivial subgoal automatically:
*}

 apply(blast)

txt{*\noindent
The proof of the induction step is identical to the one for the base case:
*}

apply(subst lfp_unfold[OF mono_ef])
apply(blast)
done

text{*
The main theorem is proved in the familiar manner: induction followed by
@{text auto} augmented with the lemma as a simplification rule.
*}

theorem "mc f = {s. s \<Turnstile> f}"
apply(induct_tac f)
apply(auto simp add: EF_lemma)
done

text{*
\begin{exercise}
@{term AX} has a dual operator @{term EN}
(``there exists a next state such that'')%
\footnote{We cannot use the customary @{text EX}: it is reserved
as the \textsc{ascii}-equivalent of @{text"\<exists>"}.}
with the intended semantics
@{prop[display]"(s \<Turnstile> EN f) = (EX t. (s,t) : M & t \<Turnstile> f)"}
Fortunately, @{term"EN f"} can already be expressed as a PDL formula. How?

Show that the semantics for @{term EF} satisfies the following recursion equation:
@{prop[display]"(s \<Turnstile> EF f) = (s \<Turnstile> f | s \<Turnstile> EN(EF f))"}
\end{exercise}
\index{PDL|)}
*}
(*<*)
theorem main: "mc f = {s. s \<Turnstile> f}"
apply(induct_tac f)
apply(auto simp add: EF_lemma)
done

lemma aux: "s \<Turnstile> f = (s : mc f)"
apply(simp add: main)
done

lemma "(s \<Turnstile> EF f) = (s \<Turnstile> f | s \<Turnstile> Neg(AX(Neg(EF f))))"
apply(simp only: aux)
apply(simp)
apply(subst lfp_unfold[OF mono_ef], fast)
done

end
(*>*)


section \<open>Dimension of Spans\<close>

text \<open>We define the notion of dimension of a span of vectors and prove some natural results about them.
  The definition is made as a function, so that no interpretation of locales like subspace is required.\<close>
theory Dim_Span
  imports Missing_VS_Connect
begin

context vec_space
begin
definition "dim_span W = Max (card ` {V. V \<subseteq> carrier_vec n \<and> V \<subseteq> span W \<and> lin_indpt V})"

lemma fixes V W :: "'a vec set"
  shows
    card_le_dim_span:
    "V \<subseteq> carrier_vec n \<Longrightarrow> V \<subseteq> span W \<Longrightarrow> lin_indpt V \<Longrightarrow> card V \<le> dim_span W" and
    card_eq_dim_span_imp_same_span:
    "W \<subseteq> carrier_vec n \<Longrightarrow> V \<subseteq> span W \<Longrightarrow> lin_indpt V \<Longrightarrow> card V = dim_span W \<Longrightarrow> span V = span W" and
    same_span_imp_card_eq_dim_span:
    "V \<subseteq> carrier_vec n \<Longrightarrow> W \<subseteq> carrier_vec n \<Longrightarrow> span V = span W \<Longrightarrow> lin_indpt V \<Longrightarrow> card V = dim_span W" and
    dim_span_cong:
    "span V = span W \<Longrightarrow> dim_span V = dim_span W" and
    ex_basis_span:
    "V \<subseteq> carrier_vec n \<Longrightarrow> \<exists> W. W \<subseteq> carrier_vec n \<and> lin_indpt W \<and> span V = span W \<and> dim_span V = card W"
proof -
  show cong: "\<And> V W. span V = span W \<Longrightarrow> dim_span V = dim_span W" unfolding dim_span_def by auto
  {
    fix W :: "'a vec set"
    let ?M = "{V. V \<subseteq> carrier_vec n \<and> V \<subseteq> span W \<and> lin_indpt V}"
    have "card ` ?M \<subseteq> {0 .. n}"
    proof
      fix k
      assume "k \<in> card ` ?M"
      then obtain V where V: "V \<subseteq> carrier_vec n \<and> V \<subseteq> span W \<and> lin_indpt V"
        and k: "k = card V"
        by auto
      from V have "card V \<le> n" using dim_is_n li_le_dim by auto
      with k show "k \<in> {0 .. n}" by auto
    qed
    from finite_subset[OF this]
    have fin: "finite (card ` ?M)" by auto
    have "{} \<in> ?M" by (auto simp: span_empty span_zero)
    from imageI[OF this, of card]
    have "0 \<in> card ` ?M" by auto
    hence Mempty: "card ` ?M \<noteq> {}" by auto
    from Max_ge[OF fin, folded dim_span_def]
    show "\<And> V :: 'a vec set. V \<subseteq> carrier_vec n \<Longrightarrow> V \<subseteq> span W \<Longrightarrow> lin_indpt V \<Longrightarrow> card V \<le> dim_span W"
      by auto
    note this fin Mempty
  } note part1 = this
  {
    fix V W :: "'a vec set"
    assume  W: "W \<subseteq> carrier_vec n"
      and VsW: "V \<subseteq> span W" and linV: "lin_indpt V" and card: "card V = dim_span W"
    from W VsW have V: "V \<subseteq> carrier_vec n" using span_mem[OF W] by auto
    from Max_in[OF part1(2,3), folded dim_span_def, of W]
    obtain WW where WW: "WW \<subseteq> carrier_vec n" "WW \<subseteq> span W" "lin_indpt WW"
      and id: "dim_span W = card WW" by auto
    show "span V = span W"
    proof (rule ccontr)
      from VsW V W have sub: "span V \<subseteq> span W" using span_subsetI by metis
      assume "span V \<noteq> span W"
      with sub obtain w where wW: "w \<in> span W" and wsV: "w \<notin> span V" by auto
      from wW W have w: "w \<in> carrier_vec n" by auto
      from linV V have finV: "finite V" using fin_dim fin_dim_li_fin by blast
      from wsV span_mem[OF V, of w] have wV: "w \<notin> V" by auto
      let ?X = "insert w V"
      have "card ?X = Suc (card V)" using wV finV by simp
      hence gt: "card ?X > dim_span W" unfolding card by simp
      have linX: "lin_indpt ?X" using lin_dep_iff_in_span[OF V linV w wV] wsV by auto
      have XW: "?X \<subseteq> span W" using wW VsW by auto
      from part1(1)[OF _ XW linX] w V have "card ?X \<le> dim_span W" by auto
      with gt show False by auto
    qed
  } note card_dim_span = this
  {
    fix V :: "'a vec set"
    assume V: "V \<subseteq> carrier_vec n"
    from Max_in[OF part1(2,3), folded dim_span_def, of V]
    obtain W where W: "W \<subseteq> carrier_vec n" "W \<subseteq> span V" "lin_indpt W"
      and idW: "card W = dim_span V" by auto
    show "\<exists> W. W \<subseteq> carrier_vec n \<and> lin_indpt W \<and> span V = span W \<and> dim_span V = card W"
    proof (intro exI[of _ W] conjI W idW[symmetric])
      from card_dim_span[OF V(1) W(2-3) idW] show "span V = span W"  by auto
    qed
  }
  {
    fix V W
    assume V: "V \<subseteq> carrier_vec n"
      and W: "W \<subseteq> carrier_vec n"
      and span: "span V = span W"
      and lin: "lin_indpt V"
    from Max_in[OF part1(2,3), folded dim_span_def, of W]
    obtain WW where WW: "WW \<subseteq> carrier_vec n" "WW \<subseteq> span W" "lin_indpt WW"
      and idWW: "card WW = dim_span W" by auto
    from card_dim_span[OF W WW(2-3) idWW] span
    have spanWW: "span WW = span V" by auto
    from span have "V \<subseteq> span W" using span_mem[OF V] by auto
    from part1(1)[OF V this lin] have VW: "card V \<le> dim_span W" .
    have finWW: "finite WW" using WW by (simp add: fin_dim_li_fin)
    have finV: "finite V" using lin V by (simp add: fin_dim_li_fin)
    from replacement[OF finWW finV V WW(3) WW(2)[folded span], unfolded idWW]
    obtain C :: "'a vec set"
      where le: "int (card C) \<le> int (card V) - int (dim_span W)" by auto
    from le have "int (dim_span W) + int (card C) \<le> int (card V)" by linarith
    hence "dim_span W + card C \<le> card V" by linarith
    with VW show "card V = dim_span W" by auto
  }
qed

lemma dim_span_le_n: assumes W: "W \<subseteq> carrier_vec n" shows "dim_span W \<le> n"
proof -
  from ex_basis_span[OF W] obtain V where
    V: "V \<subseteq> carrier_vec n"
    and lin: "lin_indpt V"
    and dim: "dim_span W = card V"
    by auto
  show ?thesis unfolding dim using lin V
    using dim_is_n li_le_dim by auto
qed

lemma dim_span_insert: assumes W: "W \<subseteq> carrier_vec n"
  and v: "v \<in> carrier_vec n" and vs: "v \<notin> span W"
shows "dim_span (insert v W) = Suc (dim_span W)"
proof -
  from ex_basis_span[OF W] obtain V where
    V: "V \<subseteq> carrier_vec n"
    and lin: "lin_indpt V"
    and span: "span W = span V"
    and dim: "dim_span W = card V"
    by auto
  from V vs[unfolded span] have vV: "v \<notin> V" using span_mem[OF V] by blast
  from lin_dep_iff_in_span[OF V lin v vV] vs span
  have lin': "lin_indpt (insert v V)" by auto
  have finV: "finite V" using lin V using fin_dim fin_dim_li_fin by blast
  have "card (insert v V) = Suc (card V)" using finV vV by auto
  hence cvV: "card (insert v V) = Suc (dim_span W)" using dim by auto
  have "span (insert v V) = span (insert v W)"
    using span V W v by (metis bot_least insert_subset insert_union span_union_is_sum)
  from same_span_imp_card_eq_dim_span[OF _ _ this lin'] cvV v V W
  show ?thesis by auto
qed
end
end


theory SumTail
  imports Main
begin

text \<open>
\begin{description}
\item[\bf (a)] Define a primitive recursive function @{term ListSum} that
computes the sum of all elements of a list of natural numbers.

Prove the following equations.  Note that @{term  "[0..n]"} und @{term
"replicate n a"} are already defined in a theory {\tt List.thy}.
\end{description}
\<close>

primrec ListSum :: "nat list \<Rightarrow> nat"
  where
"ListSum [] = 0" |
"ListSum (x#xs) = x + ListSum xs"

lemma ListSum_append[simp]:"ListSum (xs @ ys) = ListSum xs + ListSum ys"
  apply (induction xs) by auto

theorem "2 * ListSum [0..<n+1] = n * (n + 1)"
  apply (induction n) by auto

theorem "ListSum (replicate n a) = n * a"
  apply (induction n) by auto

text \<open>
\begin{description}
\item[\bf (b)] Define an equivalent function @{term ListSumT} using a
tail-recursive function @{term ListSumTAux}.  Prove that @{term ListSum}
and @{term ListSumT} are in fact equivalent.
\end{description}
\<close>

primrec ListSumTAux :: "nat list \<Rightarrow> nat \<Rightarrow> nat"
  where
"ListSumTAux [] n = n" |
"ListSumTAux (x#xs) n = ListSumTAux xs (x + n)"

lemma ListSumTAux_sum_accum[simp]:"\<forall> a b. ListSumTAux xs (a + b) = a + ListSumTAux xs b"
  apply (induction xs) by auto

lemma ListSumTAux_append[simp]:"ListSumTAux (xs @ ys) 0 = ListSumTAux xs 0 + ListSumTAux ys 0"
  apply (induction xs)
   apply auto
  by (metis ListSumTAux_sum_accum Nat.add_0_right)

definition ListSumT :: "nat list \<Rightarrow> nat"
  where
"ListSumT xs = ListSumTAux xs 0"

lemma ListSumT_append[simp]:"ListSumT (xs @ ys) = ListSumT xs + ListSumT ys"
  apply (induction xs)
   apply (auto simp add: ListSumT_def)
  by (metis ListSumTAux_append ListSumTAux_sum_accum add.commute add.left_neutral)

theorem "ListSum xs = ListSumT xs"
  apply (induction xs)
   apply (auto simp add: ListSumT_def)
  by (metis ListSumTAux_sum_accum Nat.add_0_right)

end


theory "Mono-Nat-Fun"
imports "Library/Infinite_Set"
begin

text {*
The following lemma proves that a monotonous function from and the natural numbers is either eventually
constant or unbounded.
*}

lemma nat_mono_characterization:
  fixes f :: "nat \<Rightarrow> nat"
  assumes "mono f"
  obtains n where "\<And>m . n \<le> m \<Longrightarrow> f n = f m" | "\<And> m . \<exists> n . m \<le> f n"
proof (cases "finite (range f)")
  case True
  from Max_in[OF True]
  obtain n where Max: "f n = Max (range f)" by auto
  show thesis
  proof(rule that(1))
    fix m
    assume "n \<le> m"
    hence "f n \<le> f m" using `mono f` by (metis monoD)
    also
    have "f m \<le> f n" unfolding Max by (rule Max_ge[OF True rangeI])
    finally
    show "f n = f m".
  qed
next
  case False
  thus thesis by (fastforce intro: that(2) simp add: infinite_nat_iff_unbounded_le)
qed

end


theory P23 imports Main begin

datatype form = T | Var nat | And form form | Xor form form

definition
xor :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
"xor x y \<equiv> (\<not> (x=y))"

primrec evalf :: "(nat \<Rightarrow> bool) \<Rightarrow> form \<Rightarrow> bool" where
"evalf p T = True" |
"evalf p (Var n) = p n" |
"evalf p (And f1 f2) = ((evalf p f1) \<and> (evalf p f2))" |
"evalf p (Xor f1 f2) = (xor (evalf p f1) (evalf p f2))"

primrec evalm :: "(nat \<Rightarrow> bool) \<Rightarrow> nat list \<Rightarrow> bool" where
"evalm p Nil = True" |
"evalm p (x # xs) = ((p x) \<and> (evalm p xs))"

primrec evalp :: "(nat \<Rightarrow> bool) \<Rightarrow> nat list list \<Rightarrow> bool" where
"evalp p Nil = False" |
"evalp p (xs # xss) = (\<not>((evalm p xs) = (evalp p xss)))"

lemma "evalm (\<lambda>x. False) Nil = True"
  apply simp
  done

lemma "evalm (\<lambda>x. False) [1] = False"
  apply simp
  done

lemma "evalp (\<lambda>x. False) [] = False"
  apply simp
  done

lemma "evalp (\<lambda>x. False) [[1], [2]] = False"
  apply simp
  done

lemma "evalp (\<lambda>x. True) [[1], [2], [3]] = True"
  apply simp
  done

primrec mulpp :: "nat list list \<Rightarrow> nat list list \<Rightarrow> nat list list" where
"mulpp Nil qs = Nil" |
"mulpp (p # ps) qs = (map (\<lambda>x. x @ p) qs @ (mulpp ps qs))"

primrec poly :: "form \<Rightarrow> nat list list" where
"poly T = [[]]" |
"poly (Var n) = [[n]]" |
"poly (And f1 f2) = mulpp (poly f1) (poly f2)" |
"poly (Xor f1 f2) = (poly f1 @ poly f2)"

lemma evalm_app: "evalm e (xs @ ys) = (evalm e xs \<and> evalm e ys)"
  apply (induct xs)
   apply auto
  done

lemma evalp_app: "evalp e (xs @ ys) = (xor (evalp e xs) (evalp e ys))"
  apply (induct xs)
   apply (auto simp add: xor_def)
done

theorem mulmp_correct: "evalp e (map (\<lambda>x. x @ m) p) = (evalm e m \<and> evalp e p)"
  apply (induct p)
  apply (auto simp add: xor_def evalm_app)
  done

theorem mulpp_correct: "evalp e (mulpp p q) = (evalp e p \<and> evalp e q)"
  apply (induct p)
   apply (auto simp add: xor_def mulmp_correct evalp_app)
done

theorem poly_correct: "evalf e f = evalp e (poly f)"
  apply (induct f)
  apply simp
  apply simp
  apply (simp add: mulpp_correct)
  apply (simp add: evalp_app)
  done

end