section "Derivatives of regular expressions"

(* Author: Christian Urban *)

theory Derivatives
imports Regular_Exp
begin

text\<open>This theory is based on work by Brozowski \cite{Brzozowski64} and Antimirov \cite{Antimirov95}.\<close>

subsection \<open>Brzozowski's derivatives of regular expressions\<close>

primrec
  deriv :: "'a \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp"
where
  "deriv c (Zero) = Zero"
| "deriv c (One) = Zero"
| "deriv c (Atom c') = (if c = c' then One else Zero)"
| "deriv c (Plus r1 r2) = Plus (deriv c r1) (deriv c r2)"
| "deriv c (Times r1 r2) =
    (if nullable r1 then Plus (Times (deriv c r1) r2) (deriv c r2) else Times (deriv c r1) r2)"
| "deriv c (Star r) = Times (deriv c r) (Star r)"

primrec
  derivs :: "'a list \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp"
where
  "derivs [] r = r"
| "derivs (c # s) r = derivs s (deriv c r)"

lemma atoms_deriv_subset: "atoms (deriv x r) \<subseteq> atoms r"
by (induction r) (auto)

lemma atoms_derivs_subset: "atoms (derivs w r) \<subseteq> atoms r"
by (induction w arbitrary: r) (auto dest: atoms_deriv_subset[THEN subsetD])

lemma lang_deriv: "lang (deriv c r) = Deriv c (lang r)"
by (induct r) (simp_all add: nullable_iff)

lemma lang_derivs: "lang (derivs s r) = Derivs s (lang r)"
by (induct s arbitrary: r) (simp_all add: lang_deriv)

text \<open>A regular expression matcher:\<close>

definition matcher :: "'a rexp \<Rightarrow> 'a list \<Rightarrow> bool" where
"matcher r s = nullable (derivs s r)"

lemma matcher_correctness: "matcher r s \<longleftrightarrow> s \<in> lang r"
by (induct s arbitrary: r)
   (simp_all add: nullable_iff lang_deriv matcher_def Deriv_def)

subsection \<open>Antimirov's partial derivatives\<close>

abbreviation
  "Timess rs r \<equiv> (\<Union>r' \<in> rs. {Times r' r})"

lemma Timess_eq_image:
  "Timess rs r = (\<lambda>r'. Times r' r) ` rs"
  by auto

primrec
  pderiv :: "'a \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp set"
where
  "pderiv c Zero = {}"
| "pderiv c One = {}"
| "pderiv c (Atom c') = (if c = c' then {One} else {})"
| "pderiv c (Plus r1 r2) = (pderiv c r1) \<union> (pderiv c r2)"
| "pderiv c (Times r1 r2) =
    (if nullable r1 then Timess (pderiv c r1) r2 \<union> pderiv c r2 else Timess (pderiv c r1) r2)"
| "pderiv c (Star r) = Timess (pderiv c r) (Star r)"

primrec
  pderivs :: "'a list \<Rightarrow> 'a rexp \<Rightarrow> ('a rexp) set"
where
  "pderivs [] r = {r}"
| "pderivs (c # s) r = \<Union> (pderivs s ` pderiv c r)"

abbreviation
 pderiv_set :: "'a \<Rightarrow> 'a rexp set \<Rightarrow> 'a rexp set"
where
  "pderiv_set c rs \<equiv> \<Union> (pderiv c ` rs)"

abbreviation
  pderivs_set :: "'a list \<Rightarrow> 'a rexp set \<Rightarrow> 'a rexp set"
where
  "pderivs_set s rs \<equiv> \<Union> (pderivs s ` rs)"

lemma pderivs_append:
  "pderivs (s1 @ s2) r = \<Union> (pderivs s2 ` pderivs s1 r)"
by (induct s1 arbitrary: r) (simp_all)

lemma pderivs_snoc:
  shows "pderivs (s @ [c]) r = pderiv_set c (pderivs s r)"
by (simp add: pderivs_append)

lemma pderivs_simps [simp]:
  shows "pderivs s Zero = (if s = [] then {Zero} else {})"
  and   "pderivs s One = (if s = [] then {One} else {})"
  and   "pderivs s (Plus r1 r2) = (if s = [] then {Plus r1 r2} else (pderivs s r1) \<union> (pderivs s r2))"
by (induct s) (simp_all)

lemma pderivs_Atom:
  shows "pderivs s (Atom c) \<subseteq> {Atom c, One}"
by (induct s) (simp_all)

subsection \<open>Relating left-quotients and partial derivatives\<close>

lemma Deriv_pderiv:
  shows "Deriv c (lang r) = \<Union> (lang ` pderiv c r)"
by (induct r) (auto simp add: nullable_iff conc_UNION_distrib)

lemma Derivs_pderivs:
  shows "Derivs s (lang r) = \<Union> (lang ` pderivs s r)"
proof (induct s arbitrary: r)
  case (Cons c s)
  have ih: "\<And>r. Derivs s (lang r) = \<Union> (lang ` pderivs s r)" by fact
  have "Derivs (c # s) (lang r) = Derivs s (Deriv c (lang r))" by simp
  also have "\<dots> = Derivs s (\<Union> (lang ` pderiv c r))" by (simp add: Deriv_pderiv)
  also have "\<dots> = Derivss s (lang ` (pderiv c r))"
    by (auto simp add:  Derivs_def)
  also have "\<dots> = \<Union> (lang ` (pderivs_set s (pderiv c r)))"
    using ih by auto
  also have "\<dots> = \<Union> (lang ` (pderivs (c # s) r))" by simp
  finally show "Derivs (c # s) (lang r) = \<Union> (lang ` pderivs (c # s) r)" .
qed (simp add: Derivs_def)

subsection \<open>Relating derivatives and partial derivatives\<close>

lemma deriv_pderiv:
  shows "\<Union> (lang ` (pderiv c r)) = lang (deriv c r)"
unfolding lang_deriv Deriv_pderiv by simp

lemma derivs_pderivs:
  shows "\<Union> (lang ` (pderivs s r)) = lang (derivs s r)"
unfolding lang_derivs Derivs_pderivs by simp

subsection \<open>Finiteness property of partial derivatives\<close>

definition
  pderivs_lang :: "'a lang \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp set"
where
  "pderivs_lang A r \<equiv> \<Union>x \<in> A. pderivs x r"

lemma pderivs_lang_subsetI:
  assumes "\<And>s. s \<in> A \<Longrightarrow> pderivs s r \<subseteq> C"
  shows "pderivs_lang A r \<subseteq> C"
using assms unfolding pderivs_lang_def by (rule UN_least)

lemma pderivs_lang_union:
  shows "pderivs_lang (A \<union> B) r = (pderivs_lang A r \<union> pderivs_lang B r)"
by (simp add: pderivs_lang_def)

lemma pderivs_lang_subset:
  shows "A \<subseteq> B \<Longrightarrow> pderivs_lang A r \<subseteq> pderivs_lang B r"
by (auto simp add: pderivs_lang_def)

definition
  "UNIV1 \<equiv> UNIV - {[]}"

lemma pderivs_lang_Zero [simp]:
  shows "pderivs_lang UNIV1 Zero = {}"
unfolding UNIV1_def pderivs_lang_def by auto

lemma pderivs_lang_One [simp]:
  shows "pderivs_lang UNIV1 One = {}"
unfolding UNIV1_def pderivs_lang_def by (auto split: if_splits)

lemma pderivs_lang_Atom [simp]:
  shows "pderivs_lang UNIV1 (Atom c) = {One}"
unfolding UNIV1_def pderivs_lang_def
apply(auto)
apply(frule rev_subsetD)
apply(rule pderivs_Atom)
apply(simp)
apply(case_tac xa)
apply(auto split: if_splits)
done

lemma pderivs_lang_Plus [simp]:
  shows "pderivs_lang UNIV1 (Plus r1 r2) = pderivs_lang UNIV1 r1 \<union> pderivs_lang UNIV1 r2"
unfolding UNIV1_def pderivs_lang_def by auto

text \<open>Non-empty suffixes of a string (needed for the cases of @{const Times} and @{const Star} below)\<close>

definition
  "PSuf s \<equiv> {v. v \<noteq> [] \<and> (\<exists>u. u @ v = s)}"

lemma PSuf_snoc:
  shows "PSuf (s @ [c]) = (PSuf s) @@ {[c]} \<union> {[c]}"
unfolding PSuf_def conc_def
by (auto simp add: append_eq_append_conv2 append_eq_Cons_conv)

lemma PSuf_Union:
  shows "(\<Union>v \<in> PSuf s @@ {[c]}. f v) = (\<Union>v \<in> PSuf s. f (v @ [c]))"
by (auto simp add: conc_def)

lemma pderivs_lang_snoc:
  shows "pderivs_lang (PSuf s @@ {[c]}) r = (pderiv_set c (pderivs_lang (PSuf s) r))"
unfolding pderivs_lang_def
by (simp add: PSuf_Union pderivs_snoc)

lemma pderivs_Times:
  shows "pderivs s (Times r1 r2) \<subseteq> Timess (pderivs s r1) r2 \<union> (pderivs_lang (PSuf s) r2)"
proof (induct s rule: rev_induct)
  case (snoc c s)
  have ih: "pderivs s (Times r1 r2) \<subseteq> Timess (pderivs s r1) r2 \<union> (pderivs_lang (PSuf s) r2)"
    by fact
  have "pderivs (s @ [c]) (Times r1 r2) = pderiv_set c (pderivs s (Times r1 r2))"
    by (simp add: pderivs_snoc)
  also have "\<dots> \<subseteq> pderiv_set c (Timess (pderivs s r1) r2 \<union> (pderivs_lang (PSuf s) r2))"
    using ih by fastforce
  also have "\<dots> = pderiv_set c (Timess (pderivs s r1) r2) \<union> pderiv_set c (pderivs_lang (PSuf s) r2)"
    by (simp)
  also have "\<dots> = pderiv_set c (Timess (pderivs s r1) r2) \<union> pderivs_lang (PSuf s @@ {[c]}) r2"
    by (simp add: pderivs_lang_snoc)
  also
  have "\<dots> \<subseteq> pderiv_set c (Timess (pderivs s r1) r2) \<union> pderiv c r2 \<union> pderivs_lang (PSuf s @@ {[c]}) r2"
    by auto
  also
  have "\<dots> \<subseteq> Timess (pderiv_set c (pderivs s r1)) r2 \<union> pderiv c r2 \<union> pderivs_lang (PSuf s @@ {[c]}) r2"
    by (auto simp add: if_splits)
  also have "\<dots> = Timess (pderivs (s @ [c]) r1) r2 \<union> pderiv c r2 \<union> pderivs_lang (PSuf s @@ {[c]}) r2"
    by (simp add: pderivs_snoc)
  also have "\<dots> \<subseteq> Timess (pderivs (s @ [c]) r1) r2 \<union> pderivs_lang (PSuf (s @ [c])) r2"
    unfolding pderivs_lang_def by (auto simp add: PSuf_snoc)
  finally show ?case .
qed (simp)

lemma pderivs_lang_Times_aux1:
  assumes a: "s \<in> UNIV1"
  shows "pderivs_lang (PSuf s) r \<subseteq> pderivs_lang UNIV1 r"
using a unfolding UNIV1_def PSuf_def pderivs_lang_def by auto

lemma pderivs_lang_Times:
  shows "pderivs_lang UNIV1 (Times r1 r2) \<subseteq> Timess (pderivs_lang UNIV1 r1) r2 \<union> pderivs_lang UNIV1 r2"
apply(rule pderivs_lang_subsetI)
apply(rule subset_trans)
apply(rule pderivs_Times)
using pderivs_lang_Times_aux1 pderivs_lang_Times_aux2
apply auto
apply blast
done

lemma pderivs_Star:
  assumes a: "s \<noteq> []"
  shows "pderivs s (Star r) \<subseteq> Timess (pderivs_lang (PSuf s) r) (Star r)"
using a
proof (induct s rule: rev_induct)
  case (snoc c s)
  have ih: "s \<noteq> [] \<Longrightarrow> pderivs s (Star r) \<subseteq> Timess (pderivs_lang (PSuf s) r) (Star r)" by fact
  { assume asm: "s \<noteq> []"
    have "pderivs (s @ [c]) (Star r) = pderiv_set c (pderivs s (Star r))" by (simp add: pderivs_snoc)
    also have "\<dots> \<subseteq> pderiv_set c (Timess (pderivs_lang (PSuf s) r) (Star r))"
      using ih[OF asm] by fast
    also have "\<dots> \<subseteq> Timess (pderiv_set c (pderivs_lang (PSuf s) r)) (Star r) \<union> pderiv c (Star r)"
      by (auto split: if_splits)
    also have "\<dots> \<subseteq> Timess (pderivs_lang (PSuf (s @ [c])) r) (Star r) \<union> (Timess (pderiv c r) (Star r))"
      by (simp only: PSuf_snoc pderivs_lang_snoc pderivs_lang_union)
         (auto simp add: pderivs_lang_def)
    also have "\<dots> = Timess (pderivs_lang (PSuf (s @ [c])) r) (Star r)"
      by (auto simp add: PSuf_snoc PSuf_Union pderivs_snoc pderivs_lang_def)
    finally have ?case .
  }
  moreover
  { assume asm: "s = []"
    then have ?case by (auto simp add: pderivs_lang_def pderivs_snoc PSuf_def)
  }
  ultimately show ?case by blast
qed (simp)

lemma pderivs_lang_Star:
  shows "pderivs_lang UNIV1 (Star r) \<subseteq> Timess (pderivs_lang UNIV1 r) (Star r)"
apply(rule pderivs_lang_subsetI)
apply(rule subset_trans)
apply(rule pderivs_Star)
apply(simp add: UNIV1_def)
apply(simp add: UNIV1_def PSuf_def)
apply(auto simp add: pderivs_lang_def)
done

lemma finite_Timess [simp]:
  assumes a: "finite A"
  shows "finite (Timess A r)"
using a by auto

lemma finite_pderivs_lang_UNIV1:
  shows "finite (pderivs_lang UNIV1 r)"
apply(induct r)
apply(simp_all add:
  finite_subset[OF pderivs_lang_Times]
  finite_subset[OF pderivs_lang_Star])
done

lemma pderivs_lang_UNIV:
  shows "pderivs_lang UNIV r = pderivs [] r \<union> pderivs_lang UNIV1 r"
unfolding UNIV1_def pderivs_lang_def
by blast

lemma finite_pderivs_lang_UNIV:
  shows "finite (pderivs_lang UNIV r)"
unfolding pderivs_lang_UNIV
by (simp add: finite_pderivs_lang_UNIV1)

lemma finite_pderivs_lang:
  shows "finite (pderivs_lang A r)"
by (metis finite_pderivs_lang_UNIV pderivs_lang_subset rev_finite_subset subset_UNIV)

text\<open>The following relationship between the alphabetic width of regular expressions
(called \<open>awidth\<close> below) and the number of partial derivatives was proved
by Antimirov~\cite{Antimirov95} and formalized by Max Haslbeck.\<close>

fun awidth :: "'a rexp \<Rightarrow> nat" where
"awidth Zero = 0" |
"awidth One = 0" |
"awidth (Atom a) = 1" |
"awidth (Plus r1 r2) = awidth r1 + awidth r2" |
"awidth (Times r1 r2) = awidth r1 + awidth r2" |
"awidth (Star r1) = awidth r1"

lemma card_Timess_pderivs_lang_le:
  "card (Timess (pderivs_lang A r) s) \<le> card (pderivs_lang A r)"
  using finite_pderivs_lang unfolding Timess_eq_image by (rule card_image_le)

lemma card_pderivs_lang_UNIV1_le_awidth: "card (pderivs_lang UNIV1 r) \<le> awidth r"
proof (induction r)
  case (Plus r1 r2)
  have "card (pderivs_lang UNIV1 (Plus r1 r2)) = card (pderivs_lang UNIV1 r1 \<union> pderivs_lang UNIV1 r2)" by simp
  also have "\<dots> \<le> card (pderivs_lang UNIV1 r1) + card (pderivs_lang UNIV1 r2)"
    by(simp add: card_Un_le)
  also have "\<dots> \<le> awidth (Plus r1 r2)" using Plus.IH by simp
  finally show ?case .
next
  case (Times r1 r2)
  have "card (pderivs_lang UNIV1 (Times r1 r2)) \<le> card (Timess (pderivs_lang UNIV1 r1) r2 \<union> pderivs_lang UNIV1 r2)"
    by (simp add: card_mono finite_pderivs_lang pderivs_lang_Times)
  also have "\<dots> \<le> card (Timess (pderivs_lang UNIV1 r1) r2) + card (pderivs_lang UNIV1 r2)"
    by (simp add: card_Un_le)
  also have "\<dots> \<le> card (pderivs_lang UNIV1 r1) + card (pderivs_lang UNIV1 r2)"
    by (simp add: card_Timess_pderivs_lang_le)
  also have "\<dots> \<le> awidth (Times r1 r2)" using Times.IH by simp
  finally show ?case .
next
  case (Star r)
  have "card (pderivs_lang UNIV1 (Star r)) \<le> card (Timess (pderivs_lang UNIV1 r) (Star r))"
    by (simp add: card_mono finite_pderivs_lang pderivs_lang_Star)
  also have "\<dots> \<le> card (pderivs_lang UNIV1 r)" by (rule card_Timess_pderivs_lang_le)
  also have "\<dots> \<le> awidth (Star r)" by (simp add: Star.IH)
  finally show ?case .
qed (auto)

text\<open>Antimirov's Theorem 3.4:\<close>
theorem card_pderivs_lang_UNIV_le_awidth: "card (pderivs_lang UNIV r) \<le> awidth r + 1"
proof -
  have "card (insert r (pderivs_lang UNIV1 r)) \<le> Suc (card (pderivs_lang UNIV1 r))"
    by(auto simp: card_insert_if[OF finite_pderivs_lang_UNIV1])
  also have "\<dots> \<le> Suc (awidth r)" by(simp add: card_pderivs_lang_UNIV1_le_awidth)
  finally show ?thesis by(simp add: pderivs_lang_UNIV)
qed

text\<open>Antimirov's Corollary 3.5:\<close>
corollary card_pderivs_lang_le_awidth: "card (pderivs_lang A r) \<le> awidth r + 1"
by(rule order_trans[OF
  card_mono[OF finite_pderivs_lang_UNIV pderivs_lang_subset[OF subset_UNIV]]
  card_pderivs_lang_UNIV_le_awidth])

end


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

section\<open>The Divides Relation and Euclid's algorithm for the GCD\<close>

theory Primes imports ZF begin

definition
  divides :: "[i,i]=>o"              (infixl \<open>dvd\<close> 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"     \<comment> \<open>definition of great common divisor\<close>  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"       \<comment> \<open>Euclid's algorithm for the gcd\<close>  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"       \<comment> \<open>the coprime relation\<close>  where
    "coprime(m,n) == gcd(m,n) = 1"

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

subsection\<open>The Divides Relation\<close>

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\<open>Euclid's Algorithm for the GCD\<close>

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" for left 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\<open>Basic Properties of \<^term>\<open>gcd\<close>\<close>

text\<open>type of gcd\<close>
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\<open>Property 1: gcd(a,b) divides a and b\<close>

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\<open>if f divides a and b then f divides gcd(a,b)\<close>

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\<open>Property 2: for all a,b,f naturals,
               if f divides a and f divides b then f divides gcd(a,b)\<close>

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\<open>The Greatest Common Divisor\<close>

text\<open>The GCD exists and function gcd computes it.\<close>

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

text\<open>The GCD is unique\<close>

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\<open>Addition laws\<close>

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\<open>Multiplication Laws\<close>

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\<open>This theorem leads immediately to a proof of the uniqueness of
  factorization.  If \<^term>\<open>p\<close> divides a product of primes then it is
  one of those primes.\<close>

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\<open>The Square Root of a Prime is Irrational: Key Lemma\<close>

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 Advanced imports Even begin
ML_file \<open>../../antiquote_setup.ML\<close>
(*>*)

text \<open>
The premises of introduction rules may contain universal quantifiers and
monotone functions.  A universal quantifier lets the rule
refer to any number of instances of
the inductively defined set.  A monotone function lets the rule refer
to existing constructions (such as ``list of'') over the inductively defined
set.  The examples below show how to use the additional expressiveness
and how to reason from the resulting definitions.
\<close>

subsection\<open>Universal Quantifiers in Introduction Rules \label{sec:gterm-datatype}\<close>

text \<open>
\index{ground terms example|(}%
\index{quantifiers!and inductive definitions|(}%
As a running example, this section develops the theory of \textbf{ground
terms}: terms constructed from constant and function
symbols but not variables. To simplify matters further, we regard a
constant as a function applied to the null argument  list.  Let us declare a
datatype \<open>gterm\<close> for the type of ground  terms. It is a type constructor
whose argument is a type of  function symbols.
\<close>

datatype 'f gterm = Apply 'f "'f gterm list"

text \<open>
To try it out, we declare a datatype of some integer operations:
integer constants, the unary minus operator and the addition
operator.
\<close>

datatype integer_op = Number int | UnaryMinus | Plus

text \<open>
Now the type \<^typ>\<open>integer_op gterm\<close> denotes the ground
terms built over those symbols.

The type constructor \<open>gterm\<close> can be generalized to a function
over sets.  It returns
the set of ground terms that can be formed over a set \<open>F\<close> of function symbols. For
example,  we could consider the set of ground terms formed from the finite
set \<open>{Number 2, UnaryMinus, Plus}\<close>.

This concept is inductive. If we have a list \<open>args\<close> of ground terms
over~\<open>F\<close> and a function symbol \<open>f\<close> in \<open>F\<close>, then we
can apply \<open>f\<close> to \<open>args\<close> to obtain another ground term.
The only difficulty is that the argument list may be of any length. Hitherto,
each rule in an inductive definition referred to the inductively
defined set a fixed number of times, typically once or twice.
A universal quantifier in the premise of the introduction rule
expresses that every element of \<open>args\<close> belongs
to our inductively defined set: is a ground term
over~\<open>F\<close>.  The function \<^term>\<open>set\<close> denotes the set of elements in a given
list.
\<close>

inductive_set
  gterms :: "'f set \<Rightarrow> 'f gterm set"
  for F :: "'f set"
where
step[intro!]: "\<lbrakk>\<forall>t \<in> set args. t \<in> gterms F;  f \<in> F\<rbrakk>
               \<Longrightarrow> (Apply f args) \<in> gterms F"

text \<open>
To demonstrate a proof from this definition, let us
show that the function \<^term>\<open>gterms\<close>
is \textbf{monotone}.  We shall need this concept shortly.
\<close>

lemma gterms_mono: "F\<subseteq>G \<Longrightarrow> gterms F \<subseteq> gterms G"
apply clarify
apply (erule gterms.induct)
apply blast
done
(*<*)
lemma gterms_mono: "F\<subseteq>G \<Longrightarrow> gterms F \<subseteq> gterms G"
apply clarify
apply (erule gterms.induct)
(*>*)
txt\<open>
Intuitively, this theorem says that
enlarging the set of function symbols enlarges the set of ground
terms. The proof is a trivial rule induction.
First we use the \<open>clarify\<close> method to assume the existence of an element of
\<^term>\<open>gterms F\<close>.  (We could have used \<open>intro subsetI\<close>.)  We then
apply rule induction. Here is the resulting subgoal:
@{subgoals[display,indent=0]}
The assumptions state that \<open>f\<close> belongs
to~\<open>F\<close>, which is included in~\<open>G\<close>, and that every element of the list \<open>args\<close> is
a ground term over~\<open>G\<close>.  The \<open>blast\<close> method finds this chain of reasoning easily.
\<close>
(*<*)oops(*>*)
text \<open>
\begin{warn}
Why do we call this function \<open>gterms\<close> instead
of \<open>gterm\<close>?  A constant may have the same name as a type.  However,
name  clashes could arise in the theorems that Isabelle generates.
Our choice of names keeps \<open>gterms.induct\<close> separate from
\<open>gterm.induct\<close>.
\end{warn}

Call a term \textbf{well-formed} if each symbol occurring in it is applied
to the correct number of arguments.  (This number is called the symbol's
\textbf{arity}.)  We can express well-formedness by
generalizing the inductive definition of
\isa{gterms}.
Suppose we are given a function called \<open>arity\<close>, specifying the arities
of all symbols.  In the inductive step, we have a list \<open>args\<close> of such
terms and a function  symbol~\<open>f\<close>. If the length of the list matches the
function's arity  then applying \<open>f\<close> to \<open>args\<close> yields a well-formed
term.
\<close>

inductive_set
  well_formed_gterm :: "('f \<Rightarrow> nat) \<Rightarrow> 'f gterm set"
  for arity :: "'f \<Rightarrow> nat"
where
step[intro!]: "\<lbrakk>\<forall>t \<in> set args. t \<in> well_formed_gterm arity;
                length args = arity f\<rbrakk>
               \<Longrightarrow> (Apply f args) \<in> well_formed_gterm arity"

text \<open>
The inductive definition neatly captures the reasoning above.
The universal quantification over the
\<open>set\<close> of arguments expresses that all of them are well-formed.%
\index{quantifiers!and inductive definitions|)}
\<close>

subsection\<open>Alternative Definition Using a Monotone Function\<close>

text \<open>
\index{monotone functions!and inductive definitions|(}%
An inductive definition may refer to the
inductively defined  set through an arbitrary monotone function.  To
demonstrate this powerful feature, let us
change the  inductive definition above, replacing the
quantifier by a use of the function \<^term>\<open>lists\<close>. This
function, from the Isabelle theory of lists, is analogous to the
function \<^term>\<open>gterms\<close> declared above: if \<open>A\<close> is a set then
\<^term>\<open>lists A\<close> is the set of lists whose elements belong to
\<^term>\<open>A\<close>.

In the inductive definition of well-formed terms, examine the one
introduction rule.  The first premise states that \<open>args\<close> belongs to
the \<open>lists\<close> of well-formed terms.  This formulation is more
direct, if more obscure, than using a universal quantifier.
\<close>

inductive_set
  well_formed_gterm' :: "('f \<Rightarrow> nat) \<Rightarrow> 'f gterm set"
  for arity :: "'f \<Rightarrow> nat"
where
step[intro!]: "\<lbrakk>args \<in> lists (well_formed_gterm' arity);
                length args = arity f\<rbrakk>
               \<Longrightarrow> (Apply f args) \<in> well_formed_gterm' arity"
monos lists_mono

text \<open>
We cite the theorem \<open>lists_mono\<close> to justify
using the function \<^term>\<open>lists\<close>.%
\footnote{This particular theorem is installed by default already, but we
include the \isakeyword{monos} declaration in order to illustrate its syntax.}
@{named_thms [display,indent=0] lists_mono [no_vars] (lists_mono)}
Why must the function be monotone?  An inductive definition describes
an iterative construction: each element of the set is constructed by a
finite number of introduction rule applications.  For example, the
elements of \isa{even} are constructed by finitely many applications of
the rules
@{thm [display,indent=0] even.intros [no_vars]}
All references to a set in its
inductive definition must be positive.  Applications of an
introduction rule cannot invalidate previous applications, allowing the
construction process to converge.
The following pair of rules do not constitute an inductive definition:
\begin{trivlist}
\item \<^term>\<open>0 \<in> even\<close>
\item \<^term>\<open>n \<notin> even \<Longrightarrow> (Suc n) \<in> even\<close>
\end{trivlist}
Showing that 4 is even using these rules requires showing that 3 is not
even.  It is far from trivial to show that this set of rules
characterizes the even numbers.

Even with its use of the function \isa{lists}, the premise of our
introduction rule is positive:
@{thm [display,indent=0] (prem 1) step [no_vars]}
To apply the rule we construct a list \<^term>\<open>args\<close> of previously
constructed well-formed terms.  We obtain a
new term, \<^term>\<open>Apply f args\<close>.  Because \<^term>\<open>lists\<close> is monotone,
applications of the rule remain valid as new terms are constructed.
Further lists of well-formed
terms become available and none are taken away.%
\index{monotone functions!and inductive definitions|)}
\<close>

subsection\<open>A Proof of Equivalence\<close>

text \<open>
We naturally hope that these two inductive definitions of ``well-formed''
coincide.  The equality can be proved by separate inclusions in
each direction.  Each is a trivial rule induction.
\<close>

lemma "well_formed_gterm arity \<subseteq> well_formed_gterm' arity"
apply clarify
apply (erule well_formed_gterm.induct)
apply auto
done
(*<*)
lemma "well_formed_gterm arity \<subseteq> well_formed_gterm' arity"
apply clarify
apply (erule well_formed_gterm.induct)
(*>*)
txt \<open>
The \<open>clarify\<close> method gives
us an element of \<^term>\<open>well_formed_gterm arity\<close> on which to perform
induction.  The resulting subgoal can be proved automatically:
@{subgoals[display,indent=0]}
This proof resembles the one given in
{\S}\ref{sec:gterm-datatype} above, especially in the form of the
induction hypothesis.  Next, we consider the opposite inclusion:
\<close>
(*<*)oops(*>*)
lemma "well_formed_gterm' arity \<subseteq> well_formed_gterm arity"
apply clarify
apply (erule well_formed_gterm'.induct)
apply auto
done
(*<*)
lemma "well_formed_gterm' arity \<subseteq> well_formed_gterm arity"
apply clarify
apply (erule well_formed_gterm'.induct)
(*>*)
txt \<open>
The proof script is virtually identical,
but the subgoal after applying induction may be surprising:
@{subgoals[display,indent=0,margin=65]}
The induction hypothesis contains an application of \<^term>\<open>lists\<close>.  Using a
monotone function in the inductive definition always has this effect.  The
subgoal may look uninviting, but fortunately
\<^term>\<open>lists\<close> distributes over intersection:
@{named_thms [display,indent=0] lists_Int_eq [no_vars] (lists_Int_eq)}
Thanks to this default simplification rule, the induction hypothesis
is quickly replaced by its two parts:
\begin{trivlist}
\item \<^term>\<open>args \<in> lists (well_formed_gterm' arity)\<close>
\item \<^term>\<open>args \<in> lists (well_formed_gterm arity)\<close>
\end{trivlist}
Invoking the rule \<open>well_formed_gterm.step\<close> completes the proof.  The
call to \<open>auto\<close> does all this work.

This example is typical of how monotone functions
\index{monotone functions} can be used.  In particular, many of them
distribute over intersection.  Monotonicity implies one direction of
this set equality; we have this theorem:
@{named_thms [display,indent=0] mono_Int [no_vars] (mono_Int)}
\<close>
(*<*)oops(*>*)

subsection\<open>Another Example of Rule Inversion\<close>

text \<open>
\index{rule inversion|(}%
Does \<^term>\<open>gterms\<close> distribute over intersection?  We have proved that this
function is monotone, so \<open>mono_Int\<close> gives one of the inclusions.  The
opposite inclusion asserts that if \<^term>\<open>t\<close> is a ground term over both of the
sets
\<^term>\<open>F\<close> and~\<^term>\<open>G\<close> then it is also a ground term over their intersection,
\<^term>\<open>F \<inter> G\<close>.
\<close>

lemma gterms_IntI:
     "t \<in> gterms F \<Longrightarrow> t \<in> gterms G \<longrightarrow> t \<in> gterms (F\<inter>G)"
(*<*)oops(*>*)
text \<open>
Attempting this proof, we get the assumption
\<^term>\<open>Apply f args \<in> gterms G\<close>, which cannot be broken down.
It looks like a job for rule inversion:\cmmdx{inductive\protect\_cases}
\<close>

inductive_cases gterm_Apply_elim [elim!]: "Apply f args \<in> gterms F"

text \<open>
Here is the result.
@{named_thms [display,indent=0,margin=50] gterm_Apply_elim [no_vars] (gterm_Apply_elim)}
This rule replaces an assumption about \<^term>\<open>Apply f args\<close> by
assumptions about \<^term>\<open>f\<close> and~\<^term>\<open>args\<close>.
No cases are discarded (there was only one to begin
with) but the rule applies specifically to the pattern \<^term>\<open>Apply f args\<close>.
It can be applied repeatedly as an elimination rule without looping, so we
have given the \<open>elim!\<close> attribute.

Now we can prove the other half of that distributive law.
\<close>

lemma gterms_IntI [rule_format, intro!]:
     "t \<in> gterms F \<Longrightarrow> t \<in> gterms G \<longrightarrow> t \<in> gterms (F\<inter>G)"
apply (erule gterms.induct)
apply blast
done
(*<*)
lemma "t \<in> gterms F \<Longrightarrow> t \<in> gterms G \<longrightarrow> t \<in> gterms (F\<inter>G)"
apply (erule gterms.induct)
(*>*)
txt \<open>
The proof begins with rule induction over the definition of
\<^term>\<open>gterms\<close>, which leaves a single subgoal:
@{subgoals[display,indent=0,margin=65]}
To prove this, we assume \<^term>\<open>Apply f args \<in> gterms G\<close>.  Rule inversion,
in the form of \<open>gterm_Apply_elim\<close>, infers
that every element of \<^term>\<open>args\<close> belongs to
\<^term>\<open>gterms G\<close>; hence (by the induction hypothesis) it belongs
to \<^term>\<open>gterms (F \<inter> G)\<close>.  Rule inversion also yields
\<^term>\<open>f \<in> G\<close> and hence \<^term>\<open>f \<in> F \<inter> G\<close>.
All of this reasoning is done by \<open>blast\<close>.

\smallskip
Our distributive law is a trivial consequence of previously-proved results:
\<close>
(*<*)oops(*>*)
lemma gterms_Int_eq [simp]:
     "gterms (F \<inter> G) = gterms F \<inter> gterms G"
by (blast intro!: mono_Int monoI gterms_mono)

text_raw \<open>
\index{rule inversion|)}%
\index{ground terms example|)}

\begin{isamarkuptext}
\begin{exercise}
A function mapping function symbols to their
types is called a \textbf{signature}.  Given a type
ranging over type symbols, we can represent a function's type by a
list of argument types paired with the result type.
Complete this inductive definition:
\begin{isabelle}
\<close>

inductive_set
  well_typed_gterm :: "('f \<Rightarrow> 't list * 't) \<Rightarrow> ('f gterm * 't)set"
  for sig :: "'f \<Rightarrow> 't list * 't"
(*<*)
where
step[intro!]:
    "\<lbrakk>\<forall>pair \<in> set args. pair \<in> well_typed_gterm sig;
      sig f = (map snd args, rtype)\<rbrakk>
     \<Longrightarrow> (Apply f (map fst args), rtype)
         \<in> well_typed_gterm sig"
(*>*)
text_raw \<open>
\end{isabelle}
\end{exercise}
\end{isamarkuptext}
\<close>

(*<*)

text\<open>the following declaration isn't actually used\<close>
primrec
  integer_arity :: "integer_op \<Rightarrow> nat"
where
  "integer_arity (Number n)        = 0"
| "integer_arity UnaryMinus        = 1"
| "integer_arity Plus              = 2"

text\<open>the rest isn't used: too complicated.  OK for an exercise though.\<close>

inductive_set
  integer_signature :: "(integer_op * (unit list * unit)) set"
where
  Number:     "(Number n,   ([], ())) \<in> integer_signature"
| UnaryMinus: "(UnaryMinus, ([()], ())) \<in> integer_signature"
| Plus:       "(Plus,       ([(),()], ())) \<in> integer_signature"

inductive_set
  well_typed_gterm' :: "('f \<Rightarrow> 't list * 't) \<Rightarrow> ('f gterm * 't)set"
  for sig :: "'f \<Rightarrow> 't list * 't"
where
step[intro!]:
    "\<lbrakk>args \<in> lists(well_typed_gterm' sig);
      sig f = (map snd args, rtype)\<rbrakk>
     \<Longrightarrow> (Apply f (map fst args), rtype)
         \<in> well_typed_gterm' sig"
monos lists_mono

lemma "well_typed_gterm sig \<subseteq> well_typed_gterm' sig"
apply clarify
apply (erule well_typed_gterm.induct)
apply auto
done

lemma "well_typed_gterm' sig \<subseteq> well_typed_gterm sig"
apply clarify
apply (erule well_typed_gterm'.induct)
apply auto
done

end
(*>*)