--- a/NEWS Thu Feb 26 11:18:40 2009 +0000
+++ b/NEWS Thu Feb 26 11:21:29 2009 +0000
@@ -367,6 +367,50 @@
mult_div ~> div_mult_self2_is_id
mult_mod ~> mod_mult_self2_is_0
+* HOL/IntDiv: removed most (all?) lemmas that are instances of class-based
+generalizations (from Divides and Ring_and_Field).
+INCOMPATIBILITY. Rename old lemmas as follows:
+
+dvd_diff -> nat_dvd_diff
+dvd_zminus_iff -> dvd_minus_iff
+nat_mod_add_left_eq -> mod_add_left_eq
+nat_mod_add_right_eq -> mod_add_right_eq
+nat_mod_div_trivial -> mod_div_trivial
+nat_mod_mod_trivial -> mod_mod_trivial
+zdiv_zadd_self1 -> div_add_self1
+zdiv_zadd_self2 -> div_add_self2
+zdiv_zmult_self2 -> div_mult_self1_is_id
+zdvd_triv_left -> dvd_triv_left
+zdvd_triv_right -> dvd_triv_right
+zdvd_zmult_cancel_disj -> dvd_mult_cancel_left
+zmod_eq0_zdvd_iff -> dvd_eq_mod_eq_0[symmetric]
+zmod_zadd_left_eq -> mod_add_left_eq
+zmod_zadd_right_eq -> mod_add_right_eq
+zmod_zadd_self1 -> mod_add_self1
+zmod_zadd_self2 -> mod_add_self2
+zmod_zdiff1_eq -> mod_diff_eq
+zmod_zdvd_zmod -> mod_mod_cancel
+zmod_zmod_cancel -> mod_mod_cancel
+zmod_zmult_self1 -> mod_mult_self2_is_0
+zmod_zmult_self2 -> mod_mult_self1_is_0
+zmod_1 -> mod_by_1
+zdiv_1 -> div_by_1
+zdvd_abs1 -> abs_dvd_iff
+zdvd_abs2 -> dvd_abs_iff
+zdvd_refl -> dvd_refl
+zdvd_trans -> dvd_trans
+zdvd_zadd -> dvd_add
+zdvd_zdiff -> dvd_diff
+zdvd_zminus_iff -> dvd_minus_iff
+zdvd_zminus2_iff -> minus_dvd_iff
+zdvd_zmultD -> dvd_mult_right
+zdvd_zmultD2 -> dvd_mult_left
+zdvd_zmult_mono -> mult_dvd_mono
+zdvd_0_right -> dvd_0_right
+zdvd_0_left -> dvd_0_left_iff
+zdvd_1_left -> one_dvd
+zminus_dvd_iff -> minus_dvd_iff
+
* HOL/Library/GCD: Curried operations gcd, lcm (for nat) and zgcd,
zlcm (for int); carried together from various gcd/lcm developements in
the HOL Distribution. zgcd and zlcm replace former igcd and ilcm;
--- a/src/HOL/Algebra/Exponent.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Algebra/Exponent.thy Thu Feb 26 11:21:29 2009 +0000
@@ -210,12 +210,12 @@
lemma p_fac_forw: "[| (m::nat) > 0; k>0; k < p^a; (p^r) dvd (p^a)* m - k |]
==> (p^r) dvd (p^a) - k"
-apply (frule_tac k1 = k and i = p in p_fac_forw_lemma [THEN le_imp_power_dvd], auto)
+apply (frule p_fac_forw_lemma [THEN le_imp_power_dvd, of _ k p], auto)
apply (subgoal_tac "p^r dvd p^a*m")
prefer 2 apply (blast intro: dvd_mult2)
apply (drule dvd_diffD1)
apply assumption
- prefer 2 apply (blast intro: dvd_diff)
+ prefer 2 apply (blast intro: nat_dvd_diff)
apply (drule gr0_implies_Suc, auto)
done
@@ -226,12 +226,12 @@
lemma p_fac_backw: "[| m>0; k>0; (p::nat)\<noteq>0; k < p^a; (p^r) dvd p^a - k |]
==> (p^r) dvd (p^a)*m - k"
-apply (frule_tac k1 = k and i = p in r_le_a_forw [THEN le_imp_power_dvd], auto)
+apply (frule_tac k1 = k and p1 = p in r_le_a_forw [THEN le_imp_power_dvd], auto)
apply (subgoal_tac "p^r dvd p^a*m")
prefer 2 apply (blast intro: dvd_mult2)
apply (drule dvd_diffD1)
apply assumption
- prefer 2 apply (blast intro: dvd_diff)
+ prefer 2 apply (blast intro: nat_dvd_diff)
apply (drule less_imp_Suc_add, auto)
done
--- a/src/HOL/Algebra/IntRing.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Algebra/IntRing.thy Thu Feb 26 11:21:29 2009 +0000
@@ -407,7 +407,7 @@
hence "b mod m = (x * m + a) mod m" by simp
also
- have "\<dots> = ((x * m) mod m) + (a mod m)" by (simp add: zmod_zadd1_eq)
+ have "\<dots> = ((x * m) mod m) + (a mod m)" by (simp add: mod_add_eq)
also
have "\<dots> = a mod m" by simp
finally
--- a/src/HOL/Algebra/poly/UnivPoly2.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Algebra/poly/UnivPoly2.thy Thu Feb 26 11:21:29 2009 +0000
@@ -1,6 +1,5 @@
(*
Title: Univariate Polynomials
- Id: $Id$
Author: Clemens Ballarin, started 9 December 1996
Copyright: Clemens Ballarin
*)
@@ -388,7 +387,7 @@
proof (cases k)
case 0 then show ?thesis by simp ring
next
- case Suc then show ?thesis by (simp add: algebra_simps) ring
+ case Suc then show ?thesis by simp (ring, simp)
qed
then show "coeff (monom a 0 * p) k = coeff (a *s p) k" by ring
qed
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Archimedean_Field.thy Thu Feb 26 11:21:29 2009 +0000
@@ -0,0 +1,400 @@
+(* Title: Archimedean_Field.thy
+ Author: Brian Huffman
+*)
+
+header {* Archimedean Fields, Floor and Ceiling Functions *}
+
+theory Archimedean_Field
+imports Main
+begin
+
+subsection {* Class of Archimedean fields *}
+
+text {* Archimedean fields have no infinite elements. *}
+
+class archimedean_field = ordered_field + number_ring +
+ assumes ex_le_of_int: "\<exists>z. x \<le> of_int z"
+
+lemma ex_less_of_int:
+ fixes x :: "'a::archimedean_field" shows "\<exists>z. x < of_int z"
+proof -
+ from ex_le_of_int obtain z where "x \<le> of_int z" ..
+ then have "x < of_int (z + 1)" by simp
+ then show ?thesis ..
+qed
+
+lemma ex_of_int_less:
+ fixes x :: "'a::archimedean_field" shows "\<exists>z. of_int z < x"
+proof -
+ from ex_less_of_int obtain z where "- x < of_int z" ..
+ then have "of_int (- z) < x" by simp
+ then show ?thesis ..
+qed
+
+lemma ex_less_of_nat:
+ fixes x :: "'a::archimedean_field" shows "\<exists>n. x < of_nat n"
+proof -
+ obtain z where "x < of_int z" using ex_less_of_int ..
+ also have "\<dots> \<le> of_int (int (nat z))" by simp
+ also have "\<dots> = of_nat (nat z)" by (simp only: of_int_of_nat_eq)
+ finally show ?thesis ..
+qed
+
+lemma ex_le_of_nat:
+ fixes x :: "'a::archimedean_field" shows "\<exists>n. x \<le> of_nat n"
+proof -
+ obtain n where "x < of_nat n" using ex_less_of_nat ..
+ then have "x \<le> of_nat n" by simp
+ then show ?thesis ..
+qed
+
+text {* Archimedean fields have no infinitesimal elements. *}
+
+lemma ex_inverse_of_nat_Suc_less:
+ fixes x :: "'a::archimedean_field"
+ assumes "0 < x" shows "\<exists>n. inverse (of_nat (Suc n)) < x"
+proof -
+ from `0 < x` have "0 < inverse x"
+ by (rule positive_imp_inverse_positive)
+ obtain n where "inverse x < of_nat n"
+ using ex_less_of_nat ..
+ then obtain m where "inverse x < of_nat (Suc m)"
+ using `0 < inverse x` by (cases n) (simp_all del: of_nat_Suc)
+ then have "inverse (of_nat (Suc m)) < inverse (inverse x)"
+ using `0 < inverse x` by (rule less_imp_inverse_less)
+ then have "inverse (of_nat (Suc m)) < x"
+ using `0 < x` by (simp add: nonzero_inverse_inverse_eq)
+ then show ?thesis ..
+qed
+
+lemma ex_inverse_of_nat_less:
+ fixes x :: "'a::archimedean_field"
+ assumes "0 < x" shows "\<exists>n>0. inverse (of_nat n) < x"
+ using ex_inverse_of_nat_Suc_less [OF `0 < x`] by auto
+
+lemma ex_less_of_nat_mult:
+ fixes x :: "'a::archimedean_field"
+ assumes "0 < x" shows "\<exists>n. y < of_nat n * x"
+proof -
+ obtain n where "y / x < of_nat n" using ex_less_of_nat ..
+ with `0 < x` have "y < of_nat n * x" by (simp add: pos_divide_less_eq)
+ then show ?thesis ..
+qed
+
+
+subsection {* Existence and uniqueness of floor function *}
+
+lemma exists_least_lemma:
+ assumes "\<not> P 0" and "\<exists>n. P n"
+ shows "\<exists>n. \<not> P n \<and> P (Suc n)"
+proof -
+ from `\<exists>n. P n` have "P (Least P)" by (rule LeastI_ex)
+ with `\<not> P 0` obtain n where "Least P = Suc n"
+ by (cases "Least P") auto
+ then have "n < Least P" by simp
+ then have "\<not> P n" by (rule not_less_Least)
+ then have "\<not> P n \<and> P (Suc n)"
+ using `P (Least P)` `Least P = Suc n` by simp
+ then show ?thesis ..
+qed
+
+lemma floor_exists:
+ fixes x :: "'a::archimedean_field"
+ shows "\<exists>z. of_int z \<le> x \<and> x < of_int (z + 1)"
+proof (cases)
+ assume "0 \<le> x"
+ then have "\<not> x < of_nat 0" by simp
+ then have "\<exists>n. \<not> x < of_nat n \<and> x < of_nat (Suc n)"
+ using ex_less_of_nat by (rule exists_least_lemma)
+ then obtain n where "\<not> x < of_nat n \<and> x < of_nat (Suc n)" ..
+ then have "of_int (int n) \<le> x \<and> x < of_int (int n + 1)" by simp
+ then show ?thesis ..
+next
+ assume "\<not> 0 \<le> x"
+ then have "\<not> - x \<le> of_nat 0" by simp
+ then have "\<exists>n. \<not> - x \<le> of_nat n \<and> - x \<le> of_nat (Suc n)"
+ using ex_le_of_nat by (rule exists_least_lemma)
+ then obtain n where "\<not> - x \<le> of_nat n \<and> - x \<le> of_nat (Suc n)" ..
+ then have "of_int (- int n - 1) \<le> x \<and> x < of_int (- int n - 1 + 1)" by simp
+ then show ?thesis ..
+qed
+
+lemma floor_exists1:
+ fixes x :: "'a::archimedean_field"
+ shows "\<exists>!z. of_int z \<le> x \<and> x < of_int (z + 1)"
+proof (rule ex_ex1I)
+ show "\<exists>z. of_int z \<le> x \<and> x < of_int (z + 1)"
+ by (rule floor_exists)
+next
+ fix y z assume
+ "of_int y \<le> x \<and> x < of_int (y + 1)"
+ "of_int z \<le> x \<and> x < of_int (z + 1)"
+ then have
+ "of_int y \<le> x" "x < of_int (y + 1)"
+ "of_int z \<le> x" "x < of_int (z + 1)"
+ by simp_all
+ from le_less_trans [OF `of_int y \<le> x` `x < of_int (z + 1)`]
+ le_less_trans [OF `of_int z \<le> x` `x < of_int (y + 1)`]
+ show "y = z" by (simp del: of_int_add)
+qed
+
+
+subsection {* Floor function *}
+
+definition
+ floor :: "'a::archimedean_field \<Rightarrow> int" where
+ [code del]: "floor x = (THE z. of_int z \<le> x \<and> x < of_int (z + 1))"
+
+notation (xsymbols)
+ floor ("\<lfloor>_\<rfloor>")
+
+notation (HTML output)
+ floor ("\<lfloor>_\<rfloor>")
+
+lemma floor_correct: "of_int (floor x) \<le> x \<and> x < of_int (floor x + 1)"
+ unfolding floor_def using floor_exists1 by (rule theI')
+
+lemma floor_unique: "\<lbrakk>of_int z \<le> x; x < of_int z + 1\<rbrakk> \<Longrightarrow> floor x = z"
+ using floor_correct [of x] floor_exists1 [of x] by auto
+
+lemma of_int_floor_le: "of_int (floor x) \<le> x"
+ using floor_correct ..
+
+lemma le_floor_iff: "z \<le> floor x \<longleftrightarrow> of_int z \<le> x"
+proof
+ assume "z \<le> floor x"
+ then have "(of_int z :: 'a) \<le> of_int (floor x)" by simp
+ also have "of_int (floor x) \<le> x" by (rule of_int_floor_le)
+ finally show "of_int z \<le> x" .
+next
+ assume "of_int z \<le> x"
+ also have "x < of_int (floor x + 1)" using floor_correct ..
+ finally show "z \<le> floor x" by (simp del: of_int_add)
+qed
+
+lemma floor_less_iff: "floor x < z \<longleftrightarrow> x < of_int z"
+ by (simp add: not_le [symmetric] le_floor_iff)
+
+lemma less_floor_iff: "z < floor x \<longleftrightarrow> of_int z + 1 \<le> x"
+ using le_floor_iff [of "z + 1" x] by auto
+
+lemma floor_le_iff: "floor x \<le> z \<longleftrightarrow> x < of_int z + 1"
+ by (simp add: not_less [symmetric] less_floor_iff)
+
+lemma floor_mono: assumes "x \<le> y" shows "floor x \<le> floor y"
+proof -
+ have "of_int (floor x) \<le> x" by (rule of_int_floor_le)
+ also note `x \<le> y`
+ finally show ?thesis by (simp add: le_floor_iff)
+qed
+
+lemma floor_less_cancel: "floor x < floor y \<Longrightarrow> x < y"
+ by (auto simp add: not_le [symmetric] floor_mono)
+
+lemma floor_of_int [simp]: "floor (of_int z) = z"
+ by (rule floor_unique) simp_all
+
+lemma floor_of_nat [simp]: "floor (of_nat n) = int n"
+ using floor_of_int [of "of_nat n"] by simp
+
+text {* Floor with numerals *}
+
+lemma floor_zero [simp]: "floor 0 = 0"
+ using floor_of_int [of 0] by simp
+
+lemma floor_one [simp]: "floor 1 = 1"
+ using floor_of_int [of 1] by simp
+
+lemma floor_number_of [simp]: "floor (number_of v) = number_of v"
+ using floor_of_int [of "number_of v"] by simp
+
+lemma zero_le_floor [simp]: "0 \<le> floor x \<longleftrightarrow> 0 \<le> x"
+ by (simp add: le_floor_iff)
+
+lemma one_le_floor [simp]: "1 \<le> floor x \<longleftrightarrow> 1 \<le> x"
+ by (simp add: le_floor_iff)
+
+lemma number_of_le_floor [simp]: "number_of v \<le> floor x \<longleftrightarrow> number_of v \<le> x"
+ by (simp add: le_floor_iff)
+
+lemma zero_less_floor [simp]: "0 < floor x \<longleftrightarrow> 1 \<le> x"
+ by (simp add: less_floor_iff)
+
+lemma one_less_floor [simp]: "1 < floor x \<longleftrightarrow> 2 \<le> x"
+ by (simp add: less_floor_iff)
+
+lemma number_of_less_floor [simp]:
+ "number_of v < floor x \<longleftrightarrow> number_of v + 1 \<le> x"
+ by (simp add: less_floor_iff)
+
+lemma floor_le_zero [simp]: "floor x \<le> 0 \<longleftrightarrow> x < 1"
+ by (simp add: floor_le_iff)
+
+lemma floor_le_one [simp]: "floor x \<le> 1 \<longleftrightarrow> x < 2"
+ by (simp add: floor_le_iff)
+
+lemma floor_le_number_of [simp]:
+ "floor x \<le> number_of v \<longleftrightarrow> x < number_of v + 1"
+ by (simp add: floor_le_iff)
+
+lemma floor_less_zero [simp]: "floor x < 0 \<longleftrightarrow> x < 0"
+ by (simp add: floor_less_iff)
+
+lemma floor_less_one [simp]: "floor x < 1 \<longleftrightarrow> x < 1"
+ by (simp add: floor_less_iff)
+
+lemma floor_less_number_of [simp]:
+ "floor x < number_of v \<longleftrightarrow> x < number_of v"
+ by (simp add: floor_less_iff)
+
+text {* Addition and subtraction of integers *}
+
+lemma floor_add_of_int [simp]: "floor (x + of_int z) = floor x + z"
+ using floor_correct [of x] by (simp add: floor_unique)
+
+lemma floor_add_number_of [simp]:
+ "floor (x + number_of v) = floor x + number_of v"
+ using floor_add_of_int [of x "number_of v"] by simp
+
+lemma floor_add_one [simp]: "floor (x + 1) = floor x + 1"
+ using floor_add_of_int [of x 1] by simp
+
+lemma floor_diff_of_int [simp]: "floor (x - of_int z) = floor x - z"
+ using floor_add_of_int [of x "- z"] by (simp add: algebra_simps)
+
+lemma floor_diff_number_of [simp]:
+ "floor (x - number_of v) = floor x - number_of v"
+ using floor_diff_of_int [of x "number_of v"] by simp
+
+lemma floor_diff_one [simp]: "floor (x - 1) = floor x - 1"
+ using floor_diff_of_int [of x 1] by simp
+
+
+subsection {* Ceiling function *}
+
+definition
+ ceiling :: "'a::archimedean_field \<Rightarrow> int" where
+ [code del]: "ceiling x = - floor (- x)"
+
+notation (xsymbols)
+ ceiling ("\<lceil>_\<rceil>")
+
+notation (HTML output)
+ ceiling ("\<lceil>_\<rceil>")
+
+lemma ceiling_correct: "of_int (ceiling x) - 1 < x \<and> x \<le> of_int (ceiling x)"
+ unfolding ceiling_def using floor_correct [of "- x"] by simp
+
+lemma ceiling_unique: "\<lbrakk>of_int z - 1 < x; x \<le> of_int z\<rbrakk> \<Longrightarrow> ceiling x = z"
+ unfolding ceiling_def using floor_unique [of "- z" "- x"] by simp
+
+lemma le_of_int_ceiling: "x \<le> of_int (ceiling x)"
+ using ceiling_correct ..
+
+lemma ceiling_le_iff: "ceiling x \<le> z \<longleftrightarrow> x \<le> of_int z"
+ unfolding ceiling_def using le_floor_iff [of "- z" "- x"] by auto
+
+lemma less_ceiling_iff: "z < ceiling x \<longleftrightarrow> of_int z < x"
+ by (simp add: not_le [symmetric] ceiling_le_iff)
+
+lemma ceiling_less_iff: "ceiling x < z \<longleftrightarrow> x \<le> of_int z - 1"
+ using ceiling_le_iff [of x "z - 1"] by simp
+
+lemma le_ceiling_iff: "z \<le> ceiling x \<longleftrightarrow> of_int z - 1 < x"
+ by (simp add: not_less [symmetric] ceiling_less_iff)
+
+lemma ceiling_mono: "x \<ge> y \<Longrightarrow> ceiling x \<ge> ceiling y"
+ unfolding ceiling_def by (simp add: floor_mono)
+
+lemma ceiling_less_cancel: "ceiling x < ceiling y \<Longrightarrow> x < y"
+ by (auto simp add: not_le [symmetric] ceiling_mono)
+
+lemma ceiling_of_int [simp]: "ceiling (of_int z) = z"
+ by (rule ceiling_unique) simp_all
+
+lemma ceiling_of_nat [simp]: "ceiling (of_nat n) = int n"
+ using ceiling_of_int [of "of_nat n"] by simp
+
+text {* Ceiling with numerals *}
+
+lemma ceiling_zero [simp]: "ceiling 0 = 0"
+ using ceiling_of_int [of 0] by simp
+
+lemma ceiling_one [simp]: "ceiling 1 = 1"
+ using ceiling_of_int [of 1] by simp
+
+lemma ceiling_number_of [simp]: "ceiling (number_of v) = number_of v"
+ using ceiling_of_int [of "number_of v"] by simp
+
+lemma ceiling_le_zero [simp]: "ceiling x \<le> 0 \<longleftrightarrow> x \<le> 0"
+ by (simp add: ceiling_le_iff)
+
+lemma ceiling_le_one [simp]: "ceiling x \<le> 1 \<longleftrightarrow> x \<le> 1"
+ by (simp add: ceiling_le_iff)
+
+lemma ceiling_le_number_of [simp]:
+ "ceiling x \<le> number_of v \<longleftrightarrow> x \<le> number_of v"
+ by (simp add: ceiling_le_iff)
+
+lemma ceiling_less_zero [simp]: "ceiling x < 0 \<longleftrightarrow> x \<le> -1"
+ by (simp add: ceiling_less_iff)
+
+lemma ceiling_less_one [simp]: "ceiling x < 1 \<longleftrightarrow> x \<le> 0"
+ by (simp add: ceiling_less_iff)
+
+lemma ceiling_less_number_of [simp]:
+ "ceiling x < number_of v \<longleftrightarrow> x \<le> number_of v - 1"
+ by (simp add: ceiling_less_iff)
+
+lemma zero_le_ceiling [simp]: "0 \<le> ceiling x \<longleftrightarrow> -1 < x"
+ by (simp add: le_ceiling_iff)
+
+lemma one_le_ceiling [simp]: "1 \<le> ceiling x \<longleftrightarrow> 0 < x"
+ by (simp add: le_ceiling_iff)
+
+lemma number_of_le_ceiling [simp]:
+ "number_of v \<le> ceiling x\<longleftrightarrow> number_of v - 1 < x"
+ by (simp add: le_ceiling_iff)
+
+lemma zero_less_ceiling [simp]: "0 < ceiling x \<longleftrightarrow> 0 < x"
+ by (simp add: less_ceiling_iff)
+
+lemma one_less_ceiling [simp]: "1 < ceiling x \<longleftrightarrow> 1 < x"
+ by (simp add: less_ceiling_iff)
+
+lemma number_of_less_ceiling [simp]:
+ "number_of v < ceiling x \<longleftrightarrow> number_of v < x"
+ by (simp add: less_ceiling_iff)
+
+text {* Addition and subtraction of integers *}
+
+lemma ceiling_add_of_int [simp]: "ceiling (x + of_int z) = ceiling x + z"
+ using ceiling_correct [of x] by (simp add: ceiling_unique)
+
+lemma ceiling_add_number_of [simp]:
+ "ceiling (x + number_of v) = ceiling x + number_of v"
+ using ceiling_add_of_int [of x "number_of v"] by simp
+
+lemma ceiling_add_one [simp]: "ceiling (x + 1) = ceiling x + 1"
+ using ceiling_add_of_int [of x 1] by simp
+
+lemma ceiling_diff_of_int [simp]: "ceiling (x - of_int z) = ceiling x - z"
+ using ceiling_add_of_int [of x "- z"] by (simp add: algebra_simps)
+
+lemma ceiling_diff_number_of [simp]:
+ "ceiling (x - number_of v) = ceiling x - number_of v"
+ using ceiling_diff_of_int [of x "number_of v"] by simp
+
+lemma ceiling_diff_one [simp]: "ceiling (x - 1) = ceiling x - 1"
+ using ceiling_diff_of_int [of x 1] by simp
+
+
+subsection {* Negation *}
+
+lemma floor_minus [simp]: "floor (- x) = - ceiling x"
+ unfolding ceiling_def by simp
+
+lemma ceiling_minus [simp]: "ceiling (- x) = - floor x"
+ unfolding ceiling_def by simp
+
+end
--- a/src/HOL/Arith_Tools.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Arith_Tools.thy Thu Feb 26 11:21:29 2009 +0000
@@ -68,8 +68,9 @@
apply (subst add_eq_if)
apply (simp split add: nat.split
del: nat_numeral_1_eq_1
- add: numeral_1_eq_Suc_0 [symmetric] Let_def
- neg_imp_number_of_eq_0 neg_number_of_pred_iff_0)
+ add: nat_numeral_1_eq_1 [symmetric]
+ numeral_1_eq_Suc_0 [symmetric]
+ neg_number_of_pred_iff_0)
done
lemma nat_rec_number_of [simp]:
@@ -89,7 +90,8 @@
apply (subst add_eq_if)
apply (simp split add: nat.split
del: nat_numeral_1_eq_1
- add: numeral_1_eq_Suc_0 [symmetric] Let_def neg_imp_number_of_eq_0
+ add: nat_numeral_1_eq_1 [symmetric]
+ numeral_1_eq_Suc_0 [symmetric]
neg_number_of_pred_iff_0)
done
--- a/src/HOL/Complex_Main.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Complex_Main.thy Thu Feb 26 11:21:29 2009 +0000
@@ -9,7 +9,6 @@
Ln
Taylor
Integration
- FrechetDeriv
begin
end
--- a/src/HOL/Decision_Procs/Cooper.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Decision_Procs/Cooper.thy Thu Feb 26 11:21:29 2009 +0000
@@ -620,7 +620,7 @@
{assume "i=0" hence ?case using "12.hyps" by (simp add: dvd_def Let_def)}
moreover
{assume i1: "abs i = 1"
- from zdvd_1_left[where m = "Inum bs a"] uminus_dvd_conv[where d="1" and t="Inum bs a"]
+ from one_dvd[of "Inum bs a"] uminus_dvd_conv[where d="1" and t="Inum bs a"]
have ?case using i1 apply (cases "i=0", simp_all add: Let_def)
by (cases "i > 0", simp_all)}
moreover
@@ -640,7 +640,7 @@
{assume "i=0" hence ?case using "13.hyps" by (simp add: dvd_def Let_def)}
moreover
{assume i1: "abs i = 1"
- from zdvd_1_left[where m = "Inum bs a"] uminus_dvd_conv[where d="1" and t="Inum bs a"]
+ from one_dvd[of "Inum bs a"] uminus_dvd_conv[where d="1" and t="Inum bs a"]
have ?case using i1 apply (cases "i=0", simp_all add: Let_def)
apply (cases "i > 0", simp_all) done}
moreover
@@ -990,7 +990,7 @@
have "j=0 \<or> (j\<noteq>0 \<and> ?c = 0) \<or> (j\<noteq>0 \<and> ?c >0) \<or> (j\<noteq> 0 \<and> ?c<0)" by arith
moreover
{assume "j=0" hence z: "zlfm (Dvd j a) = (zlfm (Eq a))" by (simp add: Let_def)
- hence ?case using prems by (simp del: zlfm.simps add: zdvd_0_left)}
+ hence ?case using prems by (simp del: zlfm.simps)}
moreover
{assume "?c=0" and "j\<noteq>0" hence ?case
using zsplit0_I[OF spl, where x="i" and bs="bs"]
@@ -1005,7 +1005,7 @@
moreover
{assume cn: "?c < 0" and jnz: "j\<noteq>0" hence l: "?L (?l (Dvd j a))"
by (simp add: nb Let_def split_def)
- hence ?case using Ia cn jnz zdvd_zminus_iff[where m="abs j" and n="?c*i + ?N ?r" ]
+ hence ?case using Ia cn jnz dvd_minus_iff[of "abs j" "?c*i + ?N ?r" ]
by (simp add: Let_def split_def) }
ultimately show ?case by blast
next
@@ -1019,7 +1019,7 @@
have "j=0 \<or> (j\<noteq>0 \<and> ?c = 0) \<or> (j\<noteq>0 \<and> ?c >0) \<or> (j\<noteq> 0 \<and> ?c<0)" by arith
moreover
{assume "j=0" hence z: "zlfm (NDvd j a) = (zlfm (NEq a))" by (simp add: Let_def)
- hence ?case using prems by (simp del: zlfm.simps add: zdvd_0_left)}
+ hence ?case using prems by (simp del: zlfm.simps)}
moreover
{assume "?c=0" and "j\<noteq>0" hence ?case
using zsplit0_I[OF spl, where x="i" and bs="bs"]
@@ -1034,7 +1034,7 @@
moreover
{assume cn: "?c < 0" and jnz: "j\<noteq>0" hence l: "?L (?l (Dvd j a))"
by (simp add: nb Let_def split_def)
- hence ?case using Ia cn jnz zdvd_zminus_iff[where m="abs j" and n="?c*i + ?N ?r" ]
+ hence ?case using Ia cn jnz dvd_minus_iff[of "abs j" "?c*i + ?N ?r"]
by (simp add: Let_def split_def)}
ultimately show ?case by blast
qed auto
@@ -1092,10 +1092,10 @@
using lin ad d
proof(induct p rule: iszlfm.induct)
case (9 i c e) thus ?case using d
- by (simp add: zdvd_trans[where m="i" and n="d" and k="d'"])
+ by (simp add: dvd_trans[of "i" "d" "d'"])
next
case (10 i c e) thus ?case using d
- by (simp add: zdvd_trans[where m="i" and n="d" and k="d'"])
+ by (simp add: dvd_trans[of "i" "d" "d'"])
qed simp_all
lemma \<delta> : assumes lin:"iszlfm p"
@@ -1354,7 +1354,7 @@
case (9 j c e) hence nb: "numbound0 e" by simp
have "Ifm bbs (x#bs) (mirror (Dvd j (CN 0 c e))) = (j dvd c*x - Inum (x#bs) e)" (is "_ = (j dvd c*x - ?e)") by simp
also have "\<dots> = (j dvd (- (c*x - ?e)))"
- by (simp only: zdvd_zminus_iff)
+ by (simp only: dvd_minus_iff)
also have "\<dots> = (j dvd (c* (- x)) + ?e)"
apply (simp only: minus_mult_right[symmetric] minus_mult_left[symmetric] diff_def zadd_ac zminus_zadd_distrib)
by (simp add: algebra_simps)
@@ -1366,7 +1366,7 @@
case (10 j c e) hence nb: "numbound0 e" by simp
have "Ifm bbs (x#bs) (mirror (Dvd j (CN 0 c e))) = (j dvd c*x - Inum (x#bs) e)" (is "_ = (j dvd c*x - ?e)") by simp
also have "\<dots> = (j dvd (- (c*x - ?e)))"
- by (simp only: zdvd_zminus_iff)
+ by (simp only: dvd_minus_iff)
also have "\<dots> = (j dvd (c* (- x)) + ?e)"
apply (simp only: minus_mult_right[symmetric] minus_mult_left[symmetric] diff_def zadd_ac zminus_zadd_distrib)
by (simp add: algebra_simps)
@@ -1392,7 +1392,7 @@
and dr: "d\<beta> p l"
and d: "l dvd l'"
shows "d\<beta> p l'"
-using dr linp zdvd_trans[where n="l" and k="l'", simplified d]
+using dr linp dvd_trans[of _ "l" "l'", simplified d]
by (induct p rule: iszlfm.induct) simp_all
lemma \<alpha>_l: assumes lp: "iszlfm p"
@@ -1431,7 +1431,7 @@
by (simp add: zdiv_mono1[OF clel cp])
then have ldcp:"0 < l div c"
by (simp add: zdiv_self[OF cnz])
- have "c * (l div c) = c* (l div c) + l mod c" using d' zdvd_iff_zmod_eq_0[where m="c" and n="l"] by simp
+ have "c * (l div c) = c* (l div c) + l mod c" using d' dvd_eq_mod_eq_0[of "c" "l"] by simp
hence cl:"c * (l div c) =l" using zmod_zdiv_equality[where a="l" and b="c", symmetric]
by simp
hence "(l*x + (l div c) * Inum (x # bs) e < 0) =
@@ -1449,7 +1449,7 @@
by (simp add: zdiv_mono1[OF clel cp])
then have ldcp:"0 < l div c"
by (simp add: zdiv_self[OF cnz])
- have "c * (l div c) = c* (l div c) + l mod c" using d' zdvd_iff_zmod_eq_0[where m="c" and n="l"] by simp
+ have "c * (l div c) = c* (l div c) + l mod c" using d' dvd_eq_mod_eq_0[of "c" "l"] by simp
hence cl:"c * (l div c) =l" using zmod_zdiv_equality[where a="l" and b="c", symmetric]
by simp
hence "(l*x + (l div c) * Inum (x# bs) e \<le> 0) =
@@ -1467,7 +1467,7 @@
by (simp add: zdiv_mono1[OF clel cp])
then have ldcp:"0 < l div c"
by (simp add: zdiv_self[OF cnz])
- have "c * (l div c) = c* (l div c) + l mod c" using d' zdvd_iff_zmod_eq_0[where m="c" and n="l"] by simp
+ have "c * (l div c) = c* (l div c) + l mod c" using d' dvd_eq_mod_eq_0[of "c" "l"] by simp
hence cl:"c * (l div c) =l" using zmod_zdiv_equality[where a="l" and b="c", symmetric]
by simp
hence "(l*x + (l div c)* Inum (x # bs) e > 0) =
@@ -1485,7 +1485,7 @@
by (simp add: zdiv_mono1[OF clel cp])
then have ldcp:"0 < l div c"
by (simp add: zdiv_self[OF cnz])
- have "c * (l div c) = c* (l div c) + l mod c" using d' zdvd_iff_zmod_eq_0[where m="c" and n="l"] by simp
+ have "c * (l div c) = c* (l div c) + l mod c" using d' dvd_eq_mod_eq_0[of "c" "l"] by simp
hence cl:"c * (l div c) =l" using zmod_zdiv_equality[where a="l" and b="c", symmetric]
by simp
hence "(l*x + (l div c)* Inum (x # bs) e \<ge> 0) =
@@ -1505,7 +1505,7 @@
by (simp add: zdiv_mono1[OF clel cp])
then have ldcp:"0 < l div c"
by (simp add: zdiv_self[OF cnz])
- have "c * (l div c) = c* (l div c) + l mod c" using d' zdvd_iff_zmod_eq_0[where m="c" and n="l"] by simp
+ have "c * (l div c) = c* (l div c) + l mod c" using d' dvd_eq_mod_eq_0[of "c" "l"] by simp
hence cl:"c * (l div c) =l" using zmod_zdiv_equality[where a="l" and b="c", symmetric]
by simp
hence "(l * x + (l div c) * Inum (x # bs) e = 0) =
@@ -1523,7 +1523,7 @@
by (simp add: zdiv_mono1[OF clel cp])
then have ldcp:"0 < l div c"
by (simp add: zdiv_self[OF cnz])
- have "c * (l div c) = c* (l div c) + l mod c" using d' zdvd_iff_zmod_eq_0[where m="c" and n="l"] by simp
+ have "c * (l div c) = c* (l div c) + l mod c" using d' dvd_eq_mod_eq_0[of "c" "l"] by simp
hence cl:"c * (l div c) =l" using zmod_zdiv_equality[where a="l" and b="c", symmetric]
by simp
hence "(l * x + (l div c) * Inum (x # bs) e \<noteq> 0) =
@@ -1541,7 +1541,7 @@
by (simp add: zdiv_mono1[OF clel cp])
then have ldcp:"0 < l div c"
by (simp add: zdiv_self[OF cnz])
- have "c * (l div c) = c* (l div c) + l mod c" using d' zdvd_iff_zmod_eq_0[where m="c" and n="l"] by simp
+ have "c * (l div c) = c* (l div c) + l mod c" using d' dvd_eq_mod_eq_0[of "c" "l"] by simp
hence cl:"c * (l div c) =l" using zmod_zdiv_equality[where a="l" and b="c", symmetric]
by simp
hence "(\<exists> (k::int). l * x + (l div c) * Inum (x # bs) e = ((l div c) * j) * k) = (\<exists> (k::int). (c * (l div c)) * x + (l div c) * Inum (x # bs) e = ((l div c) * j) * k)" by simp
@@ -1558,7 +1558,7 @@
by (simp add: zdiv_mono1[OF clel cp])
then have ldcp:"0 < l div c"
by (simp add: zdiv_self[OF cnz])
- have "c * (l div c) = c* (l div c) + l mod c" using d' zdvd_iff_zmod_eq_0[where m="c" and n="l"] by simp
+ have "c * (l div c) = c* (l div c) + l mod c" using d' dvd_eq_mod_eq_0[of "c" "l"] by simp
hence cl:"c * (l div c) =l" using zmod_zdiv_equality[where a="l" and b="c", symmetric]
by simp
hence "(\<exists> (k::int). l * x + (l div c) * Inum (x # bs) e = ((l div c) * j) * k) = (\<exists> (k::int). (c * (l div c)) * x + (l div c) * Inum (x # bs) e = ((l div c) * j) * k)" by simp
--- a/src/HOL/Decision_Procs/Ferrack.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Decision_Procs/Ferrack.thy Thu Feb 26 11:21:29 2009 +0000
@@ -501,9 +501,9 @@
assumes gdg: "g dvd g'" and dgt':"dvdnumcoeff t g'"
shows "dvdnumcoeff t g"
using dgt' gdg
- by (induct t rule: dvdnumcoeff.induct, simp_all add: gdg zdvd_trans[OF gdg])
+ by (induct t rule: dvdnumcoeff.induct, simp_all add: gdg dvd_trans[OF gdg])
-declare zdvd_trans [trans add]
+declare dvd_trans [trans add]
lemma natabs0: "(nat (abs x) = 0) = (x = 0)"
by arith
--- a/src/HOL/Decision_Procs/MIR.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Decision_Procs/MIR.thy Thu Feb 26 11:21:29 2009 +0000
@@ -83,7 +83,7 @@
have "real (floor x) \<le> x" by simp
hence "real (floor x) < real (n + 1) " using ub by arith
hence "floor x < n+1" by simp
- moreover from lb have "n \<le> floor x" using floor_mono2[where x="real n" and y="x"]
+ moreover from lb have "n \<le> floor x" using floor_mono[where x="real n" and y="x"]
by simp ultimately show "floor x = n" by simp
qed
@@ -132,13 +132,13 @@
assume d: "real d rdvd t"
from d int_rdvd_real have d2: "d dvd (floor t)" and ti: "real (floor t) = t" by auto
- from iffD2[OF zdvd_abs1] d2 have "(abs d) dvd (floor t)" by blast
+ from iffD2[OF abs_dvd_iff] d2 have "(abs d) dvd (floor t)" by blast
with ti int_rdvd_real[symmetric] have "real (abs d) rdvd t" by blast
thus "abs (real d) rdvd t" by simp
next
assume "abs (real d) rdvd t" hence "real (abs d) rdvd t" by simp
with int_rdvd_real[where i="abs d" and x="t"] have d2: "abs d dvd floor t" and ti: "real (floor t) =t" by auto
- from iffD1[OF zdvd_abs1] d2 have "d dvd floor t" by blast
+ from iffD1[OF abs_dvd_iff] d2 have "d dvd floor t" by blast
with ti int_rdvd_real[symmetric] show "real d rdvd t" by blast
qed
@@ -675,9 +675,9 @@
assumes gdg: "g dvd g'" and dgt':"dvdnumcoeff t g'"
shows "dvdnumcoeff t g"
using dgt' gdg
- by (induct t rule: dvdnumcoeff.induct, simp_all add: gdg zdvd_trans[OF gdg])
-
-declare zdvd_trans [trans add]
+ by (induct t rule: dvdnumcoeff.induct, simp_all add: gdg dvd_trans[OF gdg])
+
+declare dvd_trans [trans add]
lemma natabs0: "(nat (abs x) = 0) = (x = 0)"
by arith
@@ -1775,11 +1775,11 @@
"(real (a::int) \<le> b) = (a \<le> floor b \<or> (a = floor b \<and> real (floor b) < b))"
proof( auto)
assume alb: "real a \<le> b" and agb: "\<not> a \<le> floor b"
- from alb have "floor (real a) \<le> floor b " by (simp only: floor_mono2)
+ from alb have "floor (real a) \<le> floor b " by (simp only: floor_mono)
hence "a \<le> floor b" by simp with agb show "False" by simp
next
assume alb: "a \<le> floor b"
- hence "real a \<le> real (floor b)" by (simp only: floor_mono2)
+ hence "real a \<le> real (floor b)" by (simp only: floor_mono)
also have "\<dots>\<le> b" by simp finally show "real a \<le> b" .
qed
@@ -2114,10 +2114,10 @@
using lin ad d
proof(induct p rule: iszlfm.induct)
case (9 i c e) thus ?case using d
- by (simp add: zdvd_trans[where m="i" and n="d" and k="d'"])
+ by (simp add: dvd_trans[of "i" "d" "d'"])
next
case (10 i c e) thus ?case using d
- by (simp add: zdvd_trans[where m="i" and n="d" and k="d'"])
+ by (simp add: dvd_trans[of "i" "d" "d'"])
qed simp_all
lemma \<delta> : assumes lin:"iszlfm p bs"
@@ -2496,7 +2496,7 @@
and dr: "d\<beta> p l"
and d: "l dvd l'"
shows "d\<beta> p l'"
-using dr linp zdvd_trans[where n="l" and k="l'", simplified d]
+using dr linp dvd_trans[of _ "l" "l'", simplified d]
by (induct p rule: iszlfm.induct) simp_all
lemma \<alpha>_l: assumes lp: "iszlfm p (a#bs)"
@@ -2535,7 +2535,7 @@
by (simp add: zdiv_mono1[OF clel cp])
then have ldcp:"0 < l div c"
by (simp add: zdiv_self[OF cnz])
- have "c * (l div c) = c* (l div c) + l mod c" using d' zdvd_iff_zmod_eq_0[where m="c" and n="l"] by simp
+ have "c * (l div c) = c* (l div c) + l mod c" using d' dvd_eq_mod_eq_0[of "c" "l"] by simp
hence cl:"c * (l div c) =l" using zmod_zdiv_equality[where a="l" and b="c", symmetric]
by simp
hence "(real l * real x + real (l div c) * Inum (real x # bs) e < (0\<Colon>real)) =
@@ -2553,7 +2553,7 @@
by (simp add: zdiv_mono1[OF clel cp])
then have ldcp:"0 < l div c"
by (simp add: zdiv_self[OF cnz])
- have "c * (l div c) = c* (l div c) + l mod c" using d' zdvd_iff_zmod_eq_0[where m="c" and n="l"] by simp
+ have "c * (l div c) = c* (l div c) + l mod c" using d' dvd_eq_mod_eq_0[of "c" "l"] by simp
hence cl:"c * (l div c) =l" using zmod_zdiv_equality[where a="l" and b="c", symmetric]
by simp
hence "(real l * real x + real (l div c) * Inum (real x # bs) e \<le> (0\<Colon>real)) =
@@ -2571,7 +2571,7 @@
by (simp add: zdiv_mono1[OF clel cp])
then have ldcp:"0 < l div c"
by (simp add: zdiv_self[OF cnz])
- have "c * (l div c) = c* (l div c) + l mod c" using d' zdvd_iff_zmod_eq_0[where m="c" and n="l"] by simp
+ have "c * (l div c) = c* (l div c) + l mod c" using d' dvd_eq_mod_eq_0[of "c" "l"] by simp
hence cl:"c * (l div c) =l" using zmod_zdiv_equality[where a="l" and b="c", symmetric]
by simp
hence "(real l * real x + real (l div c) * Inum (real x # bs) e > (0\<Colon>real)) =
@@ -2589,7 +2589,7 @@
by (simp add: zdiv_mono1[OF clel cp])
then have ldcp:"0 < l div c"
by (simp add: zdiv_self[OF cnz])
- have "c * (l div c) = c* (l div c) + l mod c" using d' zdvd_iff_zmod_eq_0[where m="c" and n="l"] by simp
+ have "c * (l div c) = c* (l div c) + l mod c" using d' dvd_eq_mod_eq_0[of "c" "l"] by simp
hence cl:"c * (l div c) =l" using zmod_zdiv_equality[where a="l" and b="c", symmetric]
by simp
hence "(real l * real x + real (l div c) * Inum (real x # bs) e \<ge> (0\<Colon>real)) =
@@ -2607,7 +2607,7 @@
by (simp add: zdiv_mono1[OF clel cp])
then have ldcp:"0 < l div c"
by (simp add: zdiv_self[OF cnz])
- have "c * (l div c) = c* (l div c) + l mod c" using d' zdvd_iff_zmod_eq_0[where m="c" and n="l"] by simp
+ have "c * (l div c) = c* (l div c) + l mod c" using d' dvd_eq_mod_eq_0[of "c" "l"] by simp
hence cl:"c * (l div c) =l" using zmod_zdiv_equality[where a="l" and b="c", symmetric]
by simp
hence "(real l * real x + real (l div c) * Inum (real x # bs) e = (0\<Colon>real)) =
@@ -2625,7 +2625,7 @@
by (simp add: zdiv_mono1[OF clel cp])
then have ldcp:"0 < l div c"
by (simp add: zdiv_self[OF cnz])
- have "c * (l div c) = c* (l div c) + l mod c" using d' zdvd_iff_zmod_eq_0[where m="c" and n="l"] by simp
+ have "c * (l div c) = c* (l div c) + l mod c" using d' dvd_eq_mod_eq_0[of "c" "l"] by simp
hence cl:"c * (l div c) =l" using zmod_zdiv_equality[where a="l" and b="c", symmetric]
by simp
hence "(real l * real x + real (l div c) * Inum (real x # bs) e \<noteq> (0\<Colon>real)) =
@@ -2643,7 +2643,7 @@
by (simp add: zdiv_mono1[OF clel cp])
then have ldcp:"0 < l div c"
by (simp add: zdiv_self[OF cnz])
- have "c * (l div c) = c* (l div c) + l mod c" using d' zdvd_iff_zmod_eq_0[where m="c" and n="l"] by simp
+ have "c * (l div c) = c* (l div c) + l mod c" using d' dvd_eq_mod_eq_0[of "c" "l"] by simp
hence cl:"c * (l div c) =l" using zmod_zdiv_equality[where a="l" and b="c", symmetric]
by simp
hence "(\<exists> (k::int). real l * real x + real (l div c) * Inum (real x # bs) e = (real (l div c) * real j) * real k) = (\<exists> (k::int). real (c * (l div c)) * real x + real (l div c) * Inum (real x # bs) e = (real (l div c) * real j) * real k)" by simp
@@ -2660,7 +2660,7 @@
by (simp add: zdiv_mono1[OF clel cp])
then have ldcp:"0 < l div c"
by (simp add: zdiv_self[OF cnz])
- have "c * (l div c) = c* (l div c) + l mod c" using d' zdvd_iff_zmod_eq_0[where m="c" and n="l"] by simp
+ have "c * (l div c) = c* (l div c) + l mod c" using d' dvd_eq_mod_eq_0[of "c" "l"] by simp
hence cl:"c * (l div c) =l" using zmod_zdiv_equality[where a="l" and b="c", symmetric]
by simp
hence "(\<exists> (k::int). real l * real x + real (l div c) * Inum (real x # bs) e = (real (l div c) * real j) * real k) = (\<exists> (k::int). real (c * (l div c)) * real x + real (l div c) * Inum (real x # bs) e = (real (l div c) * real j) * real k)" by simp
@@ -3697,7 +3697,7 @@
assumes xb: "real m \<le> x \<and> x < real ((n::int) + 1)"
shows "\<exists> j\<in> {m.. n}. real j \<le> x \<and> x < real (j+1)" (is "\<exists> j\<in> ?N. ?P j")
by (rule bexI[where P="?P" and x="floor x" and A="?N"])
-(auto simp add: floor_less_eq[where x="x" and a="n+1", simplified] xb[simplified] floor_mono2[where x="real m" and y="x", OF conjunct1[OF xb], simplified floor_real_of_int[where n="m"]])
+(auto simp add: floor_less_eq[where x="x" and a="n+1", simplified] xb[simplified] floor_mono[where x="real m" and y="x", OF conjunct1[OF xb], simplified floor_real_of_int[where n="m"]])
lemma rsplit0_complete:
assumes xp:"0 \<le> x" and x1:"x < 1"
--- a/src/HOL/Decision_Procs/cooper_tac.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Decision_Procs/cooper_tac.ML Thu Feb 26 11:21:29 2009 +0000
@@ -28,11 +28,9 @@
val imp_le_cong = @{thm imp_le_cong};
val conj_le_cong = @{thm conj_le_cong};
val nat_mod_add_eq = @{thm mod_add1_eq} RS sym;
-val nat_mod_add_left_eq = @{thm mod_add_left_eq} RS sym;
-val nat_mod_add_right_eq = @{thm mod_add_right_eq} RS sym;
-val int_mod_add_eq = @{thm zmod_zadd1_eq} RS sym;
-val int_mod_add_left_eq = @{thm zmod_zadd_left_eq} RS sym;
-val int_mod_add_right_eq = @{thm zmod_zadd_right_eq} RS sym;
+val mod_add_left_eq = @{thm mod_add_left_eq} RS sym;
+val mod_add_right_eq = @{thm mod_add_right_eq} RS sym;
+val int_mod_add_eq = @{thm mod_add_eq} RS sym;
val nat_div_add_eq = @{thm div_add1_eq} RS sym;
val int_div_add_eq = @{thm zdiv_zadd1_eq} RS sym;
@@ -70,14 +68,13 @@
val (t,np,nh) = prepare_for_linz q g
(* Some simpsets for dealing with mod div abs and nat*)
val mod_div_simpset = HOL_basic_ss
- addsimps [refl,nat_mod_add_eq, nat_mod_add_left_eq,
- nat_mod_add_right_eq, int_mod_add_eq,
- int_mod_add_right_eq, int_mod_add_left_eq,
+ addsimps [refl,nat_mod_add_eq, mod_add_left_eq,
+ mod_add_right_eq, int_mod_add_eq,
nat_div_add_eq, int_div_add_eq,
@{thm mod_self}, @{thm "zmod_self"},
@{thm mod_by_0}, @{thm div_by_0},
@{thm "zdiv_zero"}, @{thm "zmod_zero"}, @{thm "div_0"}, @{thm "mod_0"},
- @{thm "zdiv_1"}, @{thm "zmod_1"}, @{thm "div_1"}, @{thm "mod_1"},
+ @{thm "div_by_1"}, @{thm "mod_by_1"}, @{thm "div_1"}, @{thm "mod_1"},
Suc_plus1]
addsimps @{thms add_ac}
addsimprocs [cancel_div_mod_proc]
--- a/src/HOL/Decision_Procs/ferrack_tac.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Decision_Procs/ferrack_tac.ML Thu Feb 26 11:21:29 2009 +0000
@@ -32,11 +32,9 @@
val imp_le_cong = @{thm imp_le_cong};
val conj_le_cong = @{thm conj_le_cong};
val nat_mod_add_eq = @{thm mod_add1_eq} RS sym;
-val nat_mod_add_left_eq = @{thm mod_add_left_eq} RS sym;
-val nat_mod_add_right_eq = @{thm mod_add_right_eq} RS sym;
-val int_mod_add_eq = @{thm zmod_zadd1_eq} RS sym;
-val int_mod_add_left_eq = @{thm zmod_zadd_left_eq} RS sym;
-val int_mod_add_right_eq = @{thm zmod_zadd_right_eq} RS sym;
+val mod_add_left_eq = @{thm mod_add_left_eq} RS sym;
+val mod_add_right_eq = @{thm mod_add_right_eq} RS sym;
+val int_mod_add_eq = @{thm mod_add_eq} RS sym;
val nat_div_add_eq = @{thm div_add1_eq} RS sym;
val int_div_add_eq = @{thm zdiv_zadd1_eq} RS sym;
val ZDIVISION_BY_ZERO_MOD = @{thm DIVISION_BY_ZERO} RS conjunct2;
--- a/src/HOL/Decision_Procs/mir_tac.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Decision_Procs/mir_tac.ML Thu Feb 26 11:21:29 2009 +0000
@@ -47,11 +47,9 @@
val imp_le_cong = @{thm "imp_le_cong"};
val conj_le_cong = @{thm "conj_le_cong"};
val nat_mod_add_eq = @{thm "mod_add1_eq"} RS sym;
-val nat_mod_add_left_eq = @{thm "mod_add_left_eq"} RS sym;
-val nat_mod_add_right_eq = @{thm "mod_add_right_eq"} RS sym;
-val int_mod_add_eq = @{thm "zmod_zadd1_eq"} RS sym;
-val int_mod_add_left_eq = @{thm "zmod_zadd_left_eq"} RS sym;
-val int_mod_add_right_eq = @{thm "zmod_zadd_right_eq"} RS sym;
+val mod_add_left_eq = @{thm "mod_add_left_eq"} RS sym;
+val mod_add_right_eq = @{thm "mod_add_right_eq"} RS sym;
+val int_mod_add_eq = @{thm "mod_add_eq"} RS sym;
val nat_div_add_eq = @{thm "div_add1_eq"} RS sym;
val int_div_add_eq = @{thm "zdiv_zadd1_eq"} RS sym;
val ZDIVISION_BY_ZERO_MOD = @{thm "DIVISION_BY_ZERO"} RS conjunct2;
@@ -99,7 +97,7 @@
addsimps [refl,nat_mod_add_eq,
@{thm "mod_self"}, @{thm "zmod_self"},
@{thm "zdiv_zero"},@{thm "zmod_zero"},@{thm "div_0"}, @{thm "mod_0"},
- @{thm "zdiv_1"}, @{thm "zmod_1"}, @{thm "div_1"}, @{thm "mod_1"},
+ @{thm "div_by_1"}, @{thm "mod_by_1"}, @{thm "div_1"}, @{thm "mod_1"},
@{thm "Suc_plus1"}]
addsimps @{thms add_ac}
addsimprocs [cancel_div_mod_proc]
--- a/src/HOL/Deriv.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Deriv.thy Thu Feb 26 11:21:29 2009 +0000
@@ -9,7 +9,7 @@
header{* Differentiation *}
theory Deriv
-imports Lim Polynomial
+imports Lim
begin
text{*Standard Definitions*}
@@ -217,9 +217,7 @@
by (cases "n", simp, simp add: DERIV_power_Suc f)
-(* ------------------------------------------------------------------------ *)
-(* Caratheodory formulation of derivative at a point: standard proof *)
-(* ------------------------------------------------------------------------ *)
+text {* Caratheodory formulation of derivative at a point *}
lemma CARAT_DERIV:
"(DERIV f x :> l) =
@@ -307,6 +305,9 @@
==> DERIV (%y. f(y) / (g y)) x :> (d*g(x) - (e*f(x))) / (g(x) ^ Suc (Suc 0))"
by (drule (2) DERIV_divide) (simp add: mult_commute power_Suc)
+lemma lemma_DERIV_subst: "[| DERIV f x :> D; D = E |] ==> DERIV f x :> E"
+by auto
+
subsection {* Differentiability predicate *}
@@ -655,6 +656,9 @@
apply (blast intro: IVT2)
done
+
+subsection {* Boundedness of continuous functions *}
+
text{*By bisection, function continuous on closed interval is bounded above*}
lemma isCont_bounded:
@@ -773,6 +777,8 @@
done
+subsection {* Local extrema *}
+
text{*If @{term "0 < f'(x)"} then @{term x} is Locally Strictly Increasing At The Right*}
lemma DERIV_left_inc:
@@ -877,6 +883,9 @@
shows "[| DERIV f x :> l; 0 < d; \<forall>y. \<bar>x-y\<bar> < d --> f(x) = f(y) |] ==> l = 0"
by (auto dest!: DERIV_local_max)
+
+subsection {* Rolle's Theorem *}
+
text{*Lemma about introducing open ball in open interval*}
lemma lemma_interval_lt:
"[| a < x; x < b |]
@@ -1163,6 +1172,8 @@
qed
+subsection {* Continuous injective functions *}
+
text{*Dull lemma: an continuous injection on an interval must have a
strict maximum at an end point, not in the middle.*}
@@ -1356,6 +1367,9 @@
using neq by (rule LIM_inverse)
qed
+
+subsection {* Generalized Mean Value Theorem *}
+
theorem GMVT:
fixes a b :: real
assumes alb: "a < b"
@@ -1442,245 +1456,6 @@
with g'cdef f'cdef cint show ?thesis by auto
qed
-lemma lemma_DERIV_subst: "[| DERIV f x :> D; D = E |] ==> DERIV f x :> E"
-by auto
-
-
-subsection {* Derivatives of univariate polynomials *}
-
-definition
- pderiv :: "'a::real_normed_field poly \<Rightarrow> 'a poly" where
- "pderiv = poly_rec 0 (\<lambda>a p p'. p + pCons 0 p')"
-
-lemma pderiv_0 [simp]: "pderiv 0 = 0"
- unfolding pderiv_def by (simp add: poly_rec_0)
-
-lemma pderiv_pCons: "pderiv (pCons a p) = p + pCons 0 (pderiv p)"
- unfolding pderiv_def by (simp add: poly_rec_pCons)
-
-lemma coeff_pderiv: "coeff (pderiv p) n = of_nat (Suc n) * coeff p (Suc n)"
- apply (induct p arbitrary: n, simp)
- apply (simp add: pderiv_pCons coeff_pCons algebra_simps split: nat.split)
- done
-
-lemma pderiv_eq_0_iff: "pderiv p = 0 \<longleftrightarrow> degree p = 0"
- apply (rule iffI)
- apply (cases p, simp)
- apply (simp add: expand_poly_eq coeff_pderiv del: of_nat_Suc)
- apply (simp add: expand_poly_eq coeff_pderiv coeff_eq_0)
- done
-
-lemma degree_pderiv: "degree (pderiv p) = degree p - 1"
- apply (rule order_antisym [OF degree_le])
- apply (simp add: coeff_pderiv coeff_eq_0)
- apply (cases "degree p", simp)
- apply (rule le_degree)
- apply (simp add: coeff_pderiv del: of_nat_Suc)
- apply (rule subst, assumption)
- apply (rule leading_coeff_neq_0, clarsimp)
- done
-
-lemma pderiv_singleton [simp]: "pderiv [:a:] = 0"
-by (simp add: pderiv_pCons)
-
-lemma pderiv_add: "pderiv (p + q) = pderiv p + pderiv q"
-by (rule poly_ext, simp add: coeff_pderiv algebra_simps)
-
-lemma pderiv_minus: "pderiv (- p) = - pderiv p"
-by (rule poly_ext, simp add: coeff_pderiv)
-
-lemma pderiv_diff: "pderiv (p - q) = pderiv p - pderiv q"
-by (rule poly_ext, simp add: coeff_pderiv algebra_simps)
-
-lemma pderiv_smult: "pderiv (smult a p) = smult a (pderiv p)"
-by (rule poly_ext, simp add: coeff_pderiv algebra_simps)
-
-lemma pderiv_mult: "pderiv (p * q) = p * pderiv q + q * pderiv p"
-apply (induct p)
-apply simp
-apply (simp add: pderiv_add pderiv_smult pderiv_pCons algebra_simps)
-done
-
-lemma pderiv_power_Suc:
- "pderiv (p ^ Suc n) = smult (of_nat (Suc n)) (p ^ n) * pderiv p"
-apply (induct n)
-apply simp
-apply (subst power_Suc)
-apply (subst pderiv_mult)
-apply (erule ssubst)
-apply (simp add: smult_add_left algebra_simps)
-done
-
-lemma DERIV_cmult2: "DERIV f x :> D ==> DERIV (%x. (f x) * c :: real) x :> D * c"
-by (simp add: DERIV_cmult mult_commute [of _ c])
-
-lemma DERIV_pow2: "DERIV (%x. x ^ Suc n) x :> real (Suc n) * (x ^ n)"
-by (rule lemma_DERIV_subst, rule DERIV_pow, simp)
-declare DERIV_pow2 [simp] DERIV_pow [simp]
-
-lemma DERIV_add_const: "DERIV f x :> D ==> DERIV (%x. a + f x :: 'a::real_normed_field) x :> D"
-by (rule lemma_DERIV_subst, rule DERIV_add, auto)
-
-lemma poly_DERIV[simp]: "DERIV (%x. poly p x) x :> poly (pderiv p) x"
-apply (induct p)
-apply simp
-apply (simp add: pderiv_pCons)
-apply (rule lemma_DERIV_subst)
-apply (rule DERIV_add DERIV_mult DERIV_const DERIV_ident | assumption)+
-apply simp
-done
-
-text{* Consequences of the derivative theorem above*}
-
-lemma poly_differentiable[simp]: "(%x. poly p x) differentiable (x::real)"
-apply (simp add: differentiable_def)
-apply (blast intro: poly_DERIV)
-done
-
-lemma poly_isCont[simp]: "isCont (%x. poly p x) (x::real)"
-by (rule poly_DERIV [THEN DERIV_isCont])
-
-lemma poly_IVT_pos: "[| a < b; poly p (a::real) < 0; 0 < poly p b |]
- ==> \<exists>x. a < x & x < b & (poly p x = 0)"
-apply (cut_tac f = "%x. poly p x" and a = a and b = b and y = 0 in IVT_objl)
-apply (auto simp add: order_le_less)
-done
-
-lemma poly_IVT_neg: "[| (a::real) < b; 0 < poly p a; poly p b < 0 |]
- ==> \<exists>x. a < x & x < b & (poly p x = 0)"
-by (insert poly_IVT_pos [where p = "- p" ]) simp
-
-lemma poly_MVT: "(a::real) < b ==>
- \<exists>x. a < x & x < b & (poly p b - poly p a = (b - a) * poly (pderiv p) x)"
-apply (drule_tac f = "poly p" in MVT, auto)
-apply (rule_tac x = z in exI)
-apply (auto simp add: real_mult_left_cancel poly_DERIV [THEN DERIV_unique])
-done
-
-text{*Lemmas for Derivatives*}
-
-(* FIXME
-lemma lemma_order_pderiv [rule_format]:
- "\<forall>p q a. 0 < n &
- poly (pderiv p) \<noteq> poly [] &
- poly p = poly ([- a, 1] %^ n *** q) & ~ [- a, 1] divides q
- --> n = Suc (order a (pderiv p))"
-apply (induct "n", safe)
-apply (rule order_unique_lemma, rule conjI, assumption)
-apply (subgoal_tac "\<forall>r. r divides (pderiv p) = r divides (pderiv ([-a, 1] %^ Suc n *** q))")
-apply (drule_tac [2] poly_pderiv_welldef)
- prefer 2 apply (simp add: divides_def del: pmult_Cons pexp_Suc)
-apply (simp del: pmult_Cons pexp_Suc)
-apply (rule conjI)
-apply (simp add: divides_def fun_eq del: pmult_Cons pexp_Suc)
-apply (rule_tac x = "[-a, 1] *** (pderiv q) +++ real (Suc n) %* q" in exI)
-apply (simp add: poly_pderiv_mult poly_pderiv_exp_prime poly_add poly_mult poly_cmult right_distrib mult_ac del: pmult_Cons pexp_Suc)
-apply (simp add: poly_mult right_distrib left_distrib mult_ac del: pmult_Cons)
-apply (erule_tac V = "\<forall>r. r divides pderiv p = r divides pderiv ([- a, 1] %^ Suc n *** q)" in thin_rl)
-apply (unfold divides_def)
-apply (simp (no_asm) add: poly_pderiv_mult poly_pderiv_exp_prime fun_eq poly_add poly_mult del: pmult_Cons pexp_Suc)
-apply (rule contrapos_np, assumption)
-apply (rotate_tac 3, erule contrapos_np)
-apply (simp del: pmult_Cons pexp_Suc, safe)
-apply (rule_tac x = "inverse (real (Suc n)) %* (qa +++ -- (pderiv q))" in exI)
-apply (subgoal_tac "poly ([-a, 1] %^ n *** q) = poly ([-a, 1] %^ n *** ([-a, 1] *** (inverse (real (Suc n)) %* (qa +++ -- (pderiv q))))) ")
-apply (drule poly_mult_left_cancel [THEN iffD1], simp)
-apply (simp add: fun_eq poly_mult poly_add poly_cmult poly_minus del: pmult_Cons mult_cancel_left, safe)
-apply (rule_tac c1 = "real (Suc n)" in real_mult_left_cancel [THEN iffD1])
-apply (simp (no_asm))
-apply (subgoal_tac "real (Suc n) * (poly ([- a, 1] %^ n) xa * poly q xa) =
- (poly qa xa + - poly (pderiv q) xa) *
- (poly ([- a, 1] %^ n) xa *
- ((- a + xa) * (inverse (real (Suc n)) * real (Suc n))))")
-apply (simp only: mult_ac)
-apply (rotate_tac 2)
-apply (drule_tac x = xa in spec)
-apply (simp add: left_distrib mult_ac del: pmult_Cons)
-done
-
-lemma order_pderiv: "[| poly (pderiv p) \<noteq> poly []; order a p \<noteq> 0 |]
- ==> (order a p = Suc (order a (pderiv p)))"
-apply (case_tac "poly p = poly []")
-apply (auto dest: pderiv_zero)
-apply (drule_tac a = a and p = p in order_decomp)
-using neq0_conv
-apply (blast intro: lemma_order_pderiv)
-done
-
-text{*Now justify the standard squarefree decomposition, i.e. f / gcd(f,f'). *}
-
-lemma poly_squarefree_decomp_order: "[| poly (pderiv p) \<noteq> poly [];
- poly p = poly (q *** d);
- poly (pderiv p) = poly (e *** d);
- poly d = poly (r *** p +++ s *** pderiv p)
- |] ==> order a q = (if order a p = 0 then 0 else 1)"
-apply (subgoal_tac "order a p = order a q + order a d")
-apply (rule_tac [2] s = "order a (q *** d)" in trans)
-prefer 2 apply (blast intro: order_poly)
-apply (rule_tac [2] order_mult)
- prefer 2 apply force
-apply (case_tac "order a p = 0", simp)
-apply (subgoal_tac "order a (pderiv p) = order a e + order a d")
-apply (rule_tac [2] s = "order a (e *** d)" in trans)
-prefer 2 apply (blast intro: order_poly)
-apply (rule_tac [2] order_mult)
- prefer 2 apply force
-apply (case_tac "poly p = poly []")
-apply (drule_tac p = p in pderiv_zero, simp)
-apply (drule order_pderiv, assumption)
-apply (subgoal_tac "order a (pderiv p) \<le> order a d")
-apply (subgoal_tac [2] " ([-a, 1] %^ (order a (pderiv p))) divides d")
- prefer 2 apply (simp add: poly_entire order_divides)
-apply (subgoal_tac [2] " ([-a, 1] %^ (order a (pderiv p))) divides p & ([-a, 1] %^ (order a (pderiv p))) divides (pderiv p) ")
- prefer 3 apply (simp add: order_divides)
- prefer 2 apply (simp add: divides_def del: pexp_Suc pmult_Cons, safe)
-apply (rule_tac x = "r *** qa +++ s *** qaa" in exI)
-apply (simp add: fun_eq poly_add poly_mult left_distrib right_distrib mult_ac del: pexp_Suc pmult_Cons, auto)
-done
-
-
-lemma poly_squarefree_decomp_order2: "[| poly (pderiv p) \<noteq> poly [];
- poly p = poly (q *** d);
- poly (pderiv p) = poly (e *** d);
- poly d = poly (r *** p +++ s *** pderiv p)
- |] ==> \<forall>a. order a q = (if order a p = 0 then 0 else 1)"
-apply (blast intro: poly_squarefree_decomp_order)
-done
-
-lemma order_pderiv2: "[| poly (pderiv p) \<noteq> poly []; order a p \<noteq> 0 |]
- ==> (order a (pderiv p) = n) = (order a p = Suc n)"
-apply (auto dest: order_pderiv)
-done
-
-lemma rsquarefree_roots:
- "rsquarefree p = (\<forall>a. ~(poly p a = 0 & poly (pderiv p) a = 0))"
-apply (simp add: rsquarefree_def)
-apply (case_tac "poly p = poly []", simp, simp)
-apply (case_tac "poly (pderiv p) = poly []")
-apply simp
-apply (drule pderiv_iszero, clarify)
-apply (subgoal_tac "\<forall>a. order a p = order a [h]")
-apply (simp add: fun_eq)
-apply (rule allI)
-apply (cut_tac p = "[h]" and a = a in order_root)
-apply (simp add: fun_eq)
-apply (blast intro: order_poly)
-apply (auto simp add: order_root order_pderiv2)
-apply (erule_tac x="a" in allE, simp)
-done
-
-lemma poly_squarefree_decomp: "[| poly (pderiv p) \<noteq> poly [];
- poly p = poly (q *** d);
- poly (pderiv p) = poly (e *** d);
- poly d = poly (r *** p +++ s *** pderiv p)
- |] ==> rsquarefree q & (\<forall>a. (poly q a = 0) = (poly p a = 0))"
-apply (frule poly_squarefree_decomp_order2, assumption+)
-apply (case_tac "poly p = poly []")
-apply (blast dest: pderiv_zero)
-apply (simp (no_asm) add: rsquarefree_def order_root del: pmult_Cons)
-apply (simp add: poly_entire del: pmult_Cons)
-done
-*)
subsection {* Theorems about Limits *}
--- a/src/HOL/Divides.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Divides.thy Thu Feb 26 11:21:29 2009 +0000
@@ -173,11 +173,17 @@
qed
lemma dvd_imp_mod_0: "a dvd b \<Longrightarrow> b mod a = 0"
-by (unfold dvd_def, auto)
+by (rule dvd_eq_mod_eq_0[THEN iffD1])
lemma dvd_div_mult_self: "a dvd b \<Longrightarrow> (b div a) * a = b"
by (subst (2) mod_div_equality [of b a, symmetric]) (simp add:dvd_imp_mod_0)
+lemma dvd_div_mult: "a dvd b \<Longrightarrow> (b div a) * c = b * c div a"
+apply (cases "a = 0")
+ apply simp
+apply (auto simp: dvd_def mult_assoc)
+done
+
lemma div_dvd_div[simp]:
"a dvd b \<Longrightarrow> a dvd c \<Longrightarrow> (b div a dvd c div a) = (b dvd c)"
apply (cases "a = 0")
@@ -188,6 +194,12 @@
apply(fastsimp simp add: mult_assoc)
done
+lemma dvd_mod_imp_dvd: "[| k dvd m mod n; k dvd n |] ==> k dvd m"
+ apply (subgoal_tac "k dvd (m div n) *n + m mod n")
+ apply (simp add: mod_div_equality)
+ apply (simp only: dvd_add dvd_mult)
+ done
+
text {* Addition respects modular equivalence. *}
lemma mod_add_left_eq: "(a + b) mod c = (a mod c + b) mod c"
@@ -478,9 +490,9 @@
from divmod_rel have divmod_m_n: "divmod_rel m n (m div n) (m mod n)" .
with assms have m_div_n: "m div n \<ge> 1"
by (cases "m div n") (auto simp add: divmod_rel_def)
- from assms divmod_m_n have "divmod_rel (m - n) n (m div n - 1) (m mod n)"
+ from assms divmod_m_n have "divmod_rel (m - n) n (m div n - Suc 0) (m mod n)"
by (cases "m div n") (auto simp add: divmod_rel_def)
- with divmod_eq have "divmod (m - n) n = (m div n - 1, m mod n)" by simp
+ with divmod_eq have "divmod (m - n) n = (m div n - Suc 0, m mod n)" by simp
moreover from divmod_div_mod have "divmod (m - n) n = ((m - n) div n, (m - n) mod n)" .
ultimately have "m div n = Suc ((m - n) div n)"
and "m mod n = (m - n) mod n" using m_div_n by simp_all
@@ -795,12 +807,6 @@
apply (auto simp add: Suc_diff_le le_mod_geq)
done
-lemma nat_mod_div_trivial: "m mod n div n = (0 :: nat)"
-by simp
-
-lemma nat_mod_mod_trivial: "m mod n mod n = (m mod n :: nat)"
-by simp
-
subsubsection {* The Divides Relation *}
@@ -810,6 +816,9 @@
lemma dvd_1_iff_1 [simp]: "(m dvd Suc 0) = (m = Suc 0)"
by (simp add: dvd_def)
+lemma nat_dvd_1_iff_1 [simp]: "m dvd (1::nat) \<longleftrightarrow> m = 1"
+by (simp add: dvd_def)
+
lemma dvd_anti_sym: "[| m dvd n; n dvd m |] ==> m = (n::nat)"
unfolding dvd_def
by (force dest: mult_eq_self_implies_10 simp add: mult_assoc mult_eq_1_iff)
@@ -819,9 +828,9 @@
interpretation dvd!: order "op dvd" "\<lambda>n m \<Colon> nat. n dvd m \<and> \<not> m dvd n"
proof qed (auto intro: dvd_refl dvd_trans dvd_anti_sym)
-lemma dvd_diff: "[| k dvd m; k dvd n |] ==> k dvd (m-n :: nat)"
- unfolding dvd_def
- by (blast intro: diff_mult_distrib2 [symmetric])
+lemma nat_dvd_diff[simp]: "[| k dvd m; k dvd n |] ==> k dvd (m-n :: nat)"
+unfolding dvd_def
+by (blast intro: diff_mult_distrib2 [symmetric])
lemma dvd_diffD: "[| k dvd m-n; k dvd n; n\<le>m |] ==> k dvd (m::nat)"
apply (erule linorder_not_less [THEN iffD2, THEN add_diff_inverse, THEN subst])
@@ -829,7 +838,7 @@
done
lemma dvd_diffD1: "[| k dvd m-n; k dvd m; n\<le>m |] ==> k dvd (n::nat)"
-by (drule_tac m = m in dvd_diff, auto)
+by (drule_tac m = m in nat_dvd_diff, auto)
lemma dvd_reduce: "(k dvd n + k) = (k dvd (n::nat))"
apply (rule iffI)
@@ -838,7 +847,7 @@
apply (subgoal_tac "n = (n+k) -k")
prefer 2 apply simp
apply (erule ssubst)
- apply (erule dvd_diff)
+ apply (erule nat_dvd_diff)
apply (rule dvd_refl)
done
@@ -848,12 +857,6 @@
apply (blast intro: mod_mult_distrib2 [symmetric])
done
-lemma dvd_mod_imp_dvd: "[| (k::nat) dvd m mod n; k dvd n |] ==> k dvd m"
- apply (subgoal_tac "k dvd (m div n) *n + m mod n")
- apply (simp add: mod_div_equality)
- apply (simp only: dvd_add dvd_mult)
- done
-
lemma dvd_mod_iff: "k dvd n ==> ((k::nat) dvd m mod n) = (k dvd m)"
by (blast intro: dvd_mod_imp_dvd dvd_mod)
@@ -889,21 +892,9 @@
apply (simp only: dvd_eq_mod_eq_0)
done
-lemma le_imp_power_dvd: "!!i::nat. m \<le> n ==> i^m dvd i^n"
- apply (unfold dvd_def)
- apply (erule linorder_not_less [THEN iffD2, THEN add_diff_inverse, THEN subst])
- apply (simp add: power_add)
- done
-
lemma nat_zero_less_power_iff [simp]: "(x^n > 0) = (x > (0::nat) | n=0)"
by (induct n) auto
-lemma power_le_dvd [rule_format]: "k^j dvd n --> i\<le>j --> k^i dvd (n::nat)"
- apply (induct j)
- apply (simp_all add: le_Suc_eq)
- apply (blast dest!: dvd_mult_right)
- done
-
lemma power_dvd_imp_le: "[|i^m dvd i^n; (1::nat) < i|] ==> m \<le> n"
apply (rule power_le_imp_le_exp, assumption)
apply (erule dvd_imp_le, simp)
--- a/src/HOL/Extraction/Euclid.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Extraction/Euclid.thy Thu Feb 26 11:21:29 2009 +0000
@@ -189,7 +189,7 @@
assume pn: "p \<le> n"
from `prime p` have "0 < p" by (rule prime_g_zero)
then have "p dvd n!" using pn by (rule dvd_factorial)
- with dvd have "p dvd ?k - n!" by (rule dvd_diff)
+ with dvd have "p dvd ?k - n!" by (rule nat_dvd_diff)
then have "p dvd 1" by simp
with prime show False using prime_nd_one by auto
qed
--- a/src/HOL/Fact.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Fact.thy Thu Feb 26 11:21:29 2009 +0000
@@ -7,7 +7,7 @@
header{*Factorial Function*}
theory Fact
-imports Nat
+imports Main
begin
consts fact :: "nat => nat"
@@ -58,7 +58,7 @@
"n < Suc m ==> fact (Suc m - n) = (Suc m - n) * fact (m - n)"
apply (induct n arbitrary: m)
apply auto
-apply (drule_tac x = "m - 1" in meta_spec, auto)
+apply (drule_tac x = "m - Suc 0" in meta_spec, auto)
done
lemma fact_num0: "fact 0 = 1"
--- a/src/HOL/Finite_Set.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Finite_Set.thy Thu Feb 26 11:21:29 2009 +0000
@@ -489,7 +489,7 @@
subsection {* A fold functional for finite sets *}
text {* The intended behaviour is
-@{text "fold f z {x1, ..., xn} = f x1 (\<dots> (f xn z)\<dots>)"}
+@{text "fold f z {x\<^isub>1, ..., x\<^isub>n} = f x\<^isub>1 (\<dots> (f x\<^isub>n z)\<dots>)"}
if @{text f} is ``left-commutative'':
*}
@@ -2486,16 +2486,16 @@
begin
definition
- Inf_fin :: "'a set \<Rightarrow> 'a" ("\<Sqinter>fin_" [900] 900)
+ Inf_fin :: "'a set \<Rightarrow> 'a" ("\<Sqinter>\<^bsub>fin\<^esub>_" [900] 900)
where
"Inf_fin = fold1 inf"
definition
- Sup_fin :: "'a set \<Rightarrow> 'a" ("\<Squnion>fin_" [900] 900)
+ Sup_fin :: "'a set \<Rightarrow> 'a" ("\<Squnion>\<^bsub>fin\<^esub>_" [900] 900)
where
"Sup_fin = fold1 sup"
-lemma Inf_le_Sup [simp]: "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> \<Sqinter>finA \<le> \<Squnion>finA"
+lemma Inf_le_Sup [simp]: "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> \<Sqinter>\<^bsub>fin\<^esub>A \<le> \<Squnion>\<^bsub>fin\<^esub>A"
apply(unfold Sup_fin_def Inf_fin_def)
apply(subgoal_tac "EX a. a:A")
prefer 2 apply blast
@@ -2506,13 +2506,13 @@
done
lemma sup_Inf_absorb [simp]:
- "finite A \<Longrightarrow> a \<in> A \<Longrightarrow> sup a (\<Sqinter>finA) = a"
+ "finite A \<Longrightarrow> a \<in> A \<Longrightarrow> sup a (\<Sqinter>\<^bsub>fin\<^esub>A) = a"
apply(subst sup_commute)
apply(simp add: Inf_fin_def sup_absorb2 fold1_belowI)
done
lemma inf_Sup_absorb [simp]:
- "finite A \<Longrightarrow> a \<in> A \<Longrightarrow> inf a (\<Squnion>finA) = a"
+ "finite A \<Longrightarrow> a \<in> A \<Longrightarrow> inf a (\<Squnion>\<^bsub>fin\<^esub>A) = a"
by (simp add: Sup_fin_def inf_absorb1
lower_semilattice.fold1_belowI [OF dual_lattice])
@@ -2524,7 +2524,7 @@
lemma sup_Inf1_distrib:
assumes "finite A"
and "A \<noteq> {}"
- shows "sup x (\<Sqinter>finA) = \<Sqinter>fin{sup x a|a. a \<in> A}"
+ shows "sup x (\<Sqinter>\<^bsub>fin\<^esub>A) = \<Sqinter>\<^bsub>fin\<^esub>{sup x a|a. a \<in> A}"
proof -
interpret ab_semigroup_idem_mult inf
by (rule ab_semigroup_idem_mult_inf)
@@ -2536,7 +2536,7 @@
lemma sup_Inf2_distrib:
assumes A: "finite A" "A \<noteq> {}" and B: "finite B" "B \<noteq> {}"
- shows "sup (\<Sqinter>finA) (\<Sqinter>finB) = \<Sqinter>fin{sup a b|a b. a \<in> A \<and> b \<in> B}"
+ shows "sup (\<Sqinter>\<^bsub>fin\<^esub>A) (\<Sqinter>\<^bsub>fin\<^esub>B) = \<Sqinter>\<^bsub>fin\<^esub>{sup a b|a b. a \<in> A \<and> b \<in> B}"
using A proof (induct rule: finite_ne_induct)
case singleton thus ?case
by (simp add: sup_Inf1_distrib [OF B] fold1_singleton_def [OF Inf_fin_def])
@@ -2553,13 +2553,13 @@
thus ?thesis by(simp add: insert(1) B(1))
qed
have ne: "{sup a b |a b. a \<in> A \<and> b \<in> B} \<noteq> {}" using insert B by blast
- have "sup (\<Sqinter>fin(insert x A)) (\<Sqinter>finB) = sup (inf x (\<Sqinter>finA)) (\<Sqinter>finB)"
+ have "sup (\<Sqinter>\<^bsub>fin\<^esub>(insert x A)) (\<Sqinter>\<^bsub>fin\<^esub>B) = sup (inf x (\<Sqinter>\<^bsub>fin\<^esub>A)) (\<Sqinter>\<^bsub>fin\<^esub>B)"
using insert by (simp add: fold1_insert_idem_def [OF Inf_fin_def])
- also have "\<dots> = inf (sup x (\<Sqinter>finB)) (sup (\<Sqinter>finA) (\<Sqinter>finB))" by(rule sup_inf_distrib2)
- also have "\<dots> = inf (\<Sqinter>fin{sup x b|b. b \<in> B}) (\<Sqinter>fin{sup a b|a b. a \<in> A \<and> b \<in> B})"
+ also have "\<dots> = inf (sup x (\<Sqinter>\<^bsub>fin\<^esub>B)) (sup (\<Sqinter>\<^bsub>fin\<^esub>A) (\<Sqinter>\<^bsub>fin\<^esub>B))" by(rule sup_inf_distrib2)
+ also have "\<dots> = inf (\<Sqinter>\<^bsub>fin\<^esub>{sup x b|b. b \<in> B}) (\<Sqinter>\<^bsub>fin\<^esub>{sup a b|a b. a \<in> A \<and> b \<in> B})"
using insert by(simp add:sup_Inf1_distrib[OF B])
- also have "\<dots> = \<Sqinter>fin({sup x b |b. b \<in> B} \<union> {sup a b |a b. a \<in> A \<and> b \<in> B})"
- (is "_ = \<Sqinter>fin?M")
+ also have "\<dots> = \<Sqinter>\<^bsub>fin\<^esub>({sup x b |b. b \<in> B} \<union> {sup a b |a b. a \<in> A \<and> b \<in> B})"
+ (is "_ = \<Sqinter>\<^bsub>fin\<^esub>?M")
using B insert
by (simp add: Inf_fin_def fold1_Un2 [OF finB _ finAB ne])
also have "?M = {sup a b |a b. a \<in> insert x A \<and> b \<in> B}"
@@ -2569,7 +2569,7 @@
lemma inf_Sup1_distrib:
assumes "finite A" and "A \<noteq> {}"
- shows "inf x (\<Squnion>finA) = \<Squnion>fin{inf x a|a. a \<in> A}"
+ shows "inf x (\<Squnion>\<^bsub>fin\<^esub>A) = \<Squnion>\<^bsub>fin\<^esub>{inf x a|a. a \<in> A}"
proof -
interpret ab_semigroup_idem_mult sup
by (rule ab_semigroup_idem_mult_sup)
@@ -2580,7 +2580,7 @@
lemma inf_Sup2_distrib:
assumes A: "finite A" "A \<noteq> {}" and B: "finite B" "B \<noteq> {}"
- shows "inf (\<Squnion>finA) (\<Squnion>finB) = \<Squnion>fin{inf a b|a b. a \<in> A \<and> b \<in> B}"
+ shows "inf (\<Squnion>\<^bsub>fin\<^esub>A) (\<Squnion>\<^bsub>fin\<^esub>B) = \<Squnion>\<^bsub>fin\<^esub>{inf a b|a b. a \<in> A \<and> b \<in> B}"
using A proof (induct rule: finite_ne_induct)
case singleton thus ?case
by(simp add: inf_Sup1_distrib [OF B] fold1_singleton_def [OF Sup_fin_def])
@@ -2597,13 +2597,13 @@
have ne: "{inf a b |a b. a \<in> A \<and> b \<in> B} \<noteq> {}" using insert B by blast
interpret ab_semigroup_idem_mult sup
by (rule ab_semigroup_idem_mult_sup)
- have "inf (\<Squnion>fin(insert x A)) (\<Squnion>finB) = inf (sup x (\<Squnion>finA)) (\<Squnion>finB)"
+ have "inf (\<Squnion>\<^bsub>fin\<^esub>(insert x A)) (\<Squnion>\<^bsub>fin\<^esub>B) = inf (sup x (\<Squnion>\<^bsub>fin\<^esub>A)) (\<Squnion>\<^bsub>fin\<^esub>B)"
using insert by (simp add: fold1_insert_idem_def [OF Sup_fin_def])
- also have "\<dots> = sup (inf x (\<Squnion>finB)) (inf (\<Squnion>finA) (\<Squnion>finB))" by(rule inf_sup_distrib2)
- also have "\<dots> = sup (\<Squnion>fin{inf x b|b. b \<in> B}) (\<Squnion>fin{inf a b|a b. a \<in> A \<and> b \<in> B})"
+ also have "\<dots> = sup (inf x (\<Squnion>\<^bsub>fin\<^esub>B)) (inf (\<Squnion>\<^bsub>fin\<^esub>A) (\<Squnion>\<^bsub>fin\<^esub>B))" by(rule inf_sup_distrib2)
+ also have "\<dots> = sup (\<Squnion>\<^bsub>fin\<^esub>{inf x b|b. b \<in> B}) (\<Squnion>\<^bsub>fin\<^esub>{inf a b|a b. a \<in> A \<and> b \<in> B})"
using insert by(simp add:inf_Sup1_distrib[OF B])
- also have "\<dots> = \<Squnion>fin({inf x b |b. b \<in> B} \<union> {inf a b |a b. a \<in> A \<and> b \<in> B})"
- (is "_ = \<Squnion>fin?M")
+ also have "\<dots> = \<Squnion>\<^bsub>fin\<^esub>({inf x b |b. b \<in> B} \<union> {inf a b |a b. a \<in> A \<and> b \<in> B})"
+ (is "_ = \<Squnion>\<^bsub>fin\<^esub>?M")
using B insert
by (simp add: Sup_fin_def fold1_Un2 [OF finB _ finAB ne])
also have "?M = {inf a b |a b. a \<in> insert x A \<and> b \<in> B}"
@@ -2622,7 +2622,7 @@
lemma Inf_fin_Inf:
assumes "finite A" and "A \<noteq> {}"
- shows "\<Sqinter>finA = Inf A"
+ shows "\<Sqinter>\<^bsub>fin\<^esub>A = Inf A"
proof -
interpret ab_semigroup_idem_mult inf
by (rule ab_semigroup_idem_mult_inf)
@@ -2633,7 +2633,7 @@
lemma Sup_fin_Sup:
assumes "finite A" and "A \<noteq> {}"
- shows "\<Squnion>finA = Sup A"
+ shows "\<Squnion>\<^bsub>fin\<^esub>A = Sup A"
proof -
interpret ab_semigroup_idem_mult sup
by (rule ab_semigroup_idem_mult_sup)
--- a/src/HOL/FrechetDeriv.thy Thu Feb 26 11:18:40 2009 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,503 +0,0 @@
-(* Title : FrechetDeriv.thy
- ID : $Id$
- Author : Brian Huffman
-*)
-
-header {* Frechet Derivative *}
-
-theory FrechetDeriv
-imports Lim
-begin
-
-definition
- fderiv ::
- "['a::real_normed_vector \<Rightarrow> 'b::real_normed_vector, 'a, 'a \<Rightarrow> 'b] \<Rightarrow> bool"
- -- {* Frechet derivative: D is derivative of function f at x *}
- ("(FDERIV (_)/ (_)/ :> (_))" [1000, 1000, 60] 60) where
- "FDERIV f x :> D = (bounded_linear D \<and>
- (\<lambda>h. norm (f (x + h) - f x - D h) / norm h) -- 0 --> 0)"
-
-lemma FDERIV_I:
- "\<lbrakk>bounded_linear D; (\<lambda>h. norm (f (x + h) - f x - D h) / norm h) -- 0 --> 0\<rbrakk>
- \<Longrightarrow> FDERIV f x :> D"
-by (simp add: fderiv_def)
-
-lemma FDERIV_D:
- "FDERIV f x :> D \<Longrightarrow> (\<lambda>h. norm (f (x + h) - f x - D h) / norm h) -- 0 --> 0"
-by (simp add: fderiv_def)
-
-lemma FDERIV_bounded_linear: "FDERIV f x :> D \<Longrightarrow> bounded_linear D"
-by (simp add: fderiv_def)
-
-lemma bounded_linear_zero:
- "bounded_linear (\<lambda>x::'a::real_normed_vector. 0::'b::real_normed_vector)"
-proof
- show "(0::'b) = 0 + 0" by simp
- fix r show "(0::'b) = scaleR r 0" by simp
- have "\<forall>x::'a. norm (0::'b) \<le> norm x * 0" by simp
- thus "\<exists>K. \<forall>x::'a. norm (0::'b) \<le> norm x * K" ..
-qed
-
-lemma FDERIV_const: "FDERIV (\<lambda>x. k) x :> (\<lambda>h. 0)"
-by (simp add: fderiv_def bounded_linear_zero)
-
-lemma bounded_linear_ident:
- "bounded_linear (\<lambda>x::'a::real_normed_vector. x)"
-proof
- fix x y :: 'a show "x + y = x + y" by simp
- fix r and x :: 'a show "scaleR r x = scaleR r x" by simp
- have "\<forall>x::'a. norm x \<le> norm x * 1" by simp
- thus "\<exists>K. \<forall>x::'a. norm x \<le> norm x * K" ..
-qed
-
-lemma FDERIV_ident: "FDERIV (\<lambda>x. x) x :> (\<lambda>h. h)"
-by (simp add: fderiv_def bounded_linear_ident)
-
-subsection {* Addition *}
-
-lemma add_diff_add:
- fixes a b c d :: "'a::ab_group_add"
- shows "(a + c) - (b + d) = (a - b) + (c - d)"
-by simp
-
-lemma bounded_linear_add:
- assumes "bounded_linear f"
- assumes "bounded_linear g"
- shows "bounded_linear (\<lambda>x. f x + g x)"
-proof -
- interpret f: bounded_linear f by fact
- interpret g: bounded_linear g by fact
- show ?thesis apply (unfold_locales)
- apply (simp only: f.add g.add add_ac)
- apply (simp only: f.scaleR g.scaleR scaleR_right_distrib)
- apply (rule f.pos_bounded [THEN exE], rename_tac Kf)
- apply (rule g.pos_bounded [THEN exE], rename_tac Kg)
- apply (rule_tac x="Kf + Kg" in exI, safe)
- apply (subst right_distrib)
- apply (rule order_trans [OF norm_triangle_ineq])
- apply (rule add_mono, erule spec, erule spec)
- done
-qed
-
-lemma norm_ratio_ineq:
- fixes x y :: "'a::real_normed_vector"
- fixes h :: "'b::real_normed_vector"
- shows "norm (x + y) / norm h \<le> norm x / norm h + norm y / norm h"
-apply (rule ord_le_eq_trans)
-apply (rule divide_right_mono)
-apply (rule norm_triangle_ineq)
-apply (rule norm_ge_zero)
-apply (rule add_divide_distrib)
-done
-
-lemma FDERIV_add:
- assumes f: "FDERIV f x :> F"
- assumes g: "FDERIV g x :> G"
- shows "FDERIV (\<lambda>x. f x + g x) x :> (\<lambda>h. F h + G h)"
-proof (rule FDERIV_I)
- show "bounded_linear (\<lambda>h. F h + G h)"
- apply (rule bounded_linear_add)
- apply (rule FDERIV_bounded_linear [OF f])
- apply (rule FDERIV_bounded_linear [OF g])
- done
-next
- have f': "(\<lambda>h. norm (f (x + h) - f x - F h) / norm h) -- 0 --> 0"
- using f by (rule FDERIV_D)
- have g': "(\<lambda>h. norm (g (x + h) - g x - G h) / norm h) -- 0 --> 0"
- using g by (rule FDERIV_D)
- from f' g'
- have "(\<lambda>h. norm (f (x + h) - f x - F h) / norm h
- + norm (g (x + h) - g x - G h) / norm h) -- 0 --> 0"
- by (rule LIM_add_zero)
- thus "(\<lambda>h. norm (f (x + h) + g (x + h) - (f x + g x) - (F h + G h))
- / norm h) -- 0 --> 0"
- apply (rule real_LIM_sandwich_zero)
- apply (simp add: divide_nonneg_pos)
- apply (simp only: add_diff_add)
- apply (rule norm_ratio_ineq)
- done
-qed
-
-subsection {* Subtraction *}
-
-lemma bounded_linear_minus:
- assumes "bounded_linear f"
- shows "bounded_linear (\<lambda>x. - f x)"
-proof -
- interpret f: bounded_linear f by fact
- show ?thesis apply (unfold_locales)
- apply (simp add: f.add)
- apply (simp add: f.scaleR)
- apply (simp add: f.bounded)
- done
-qed
-
-lemma FDERIV_minus:
- "FDERIV f x :> F \<Longrightarrow> FDERIV (\<lambda>x. - f x) x :> (\<lambda>h. - F h)"
-apply (rule FDERIV_I)
-apply (rule bounded_linear_minus)
-apply (erule FDERIV_bounded_linear)
-apply (simp only: fderiv_def minus_diff_minus norm_minus_cancel)
-done
-
-lemma FDERIV_diff:
- "\<lbrakk>FDERIV f x :> F; FDERIV g x :> G\<rbrakk>
- \<Longrightarrow> FDERIV (\<lambda>x. f x - g x) x :> (\<lambda>h. F h - G h)"
-by (simp only: diff_minus FDERIV_add FDERIV_minus)
-
-subsection {* Continuity *}
-
-lemma FDERIV_isCont:
- assumes f: "FDERIV f x :> F"
- shows "isCont f x"
-proof -
- from f interpret F: bounded_linear "F" by (rule FDERIV_bounded_linear)
- have "(\<lambda>h. norm (f (x + h) - f x - F h) / norm h) -- 0 --> 0"
- by (rule FDERIV_D [OF f])
- hence "(\<lambda>h. norm (f (x + h) - f x - F h) / norm h * norm h) -- 0 --> 0"
- by (intro LIM_mult_zero LIM_norm_zero LIM_ident)
- hence "(\<lambda>h. norm (f (x + h) - f x - F h)) -- 0 --> 0"
- by (simp cong: LIM_cong)
- hence "(\<lambda>h. f (x + h) - f x - F h) -- 0 --> 0"
- by (rule LIM_norm_zero_cancel)
- hence "(\<lambda>h. f (x + h) - f x - F h + F h) -- 0 --> 0"
- by (intro LIM_add_zero F.LIM_zero LIM_ident)
- hence "(\<lambda>h. f (x + h) - f x) -- 0 --> 0"
- by simp
- thus "isCont f x"
- unfolding isCont_iff by (rule LIM_zero_cancel)
-qed
-
-subsection {* Composition *}
-
-lemma real_divide_cancel_lemma:
- fixes a b c :: real
- shows "(b = 0 \<Longrightarrow> a = 0) \<Longrightarrow> (a / b) * (b / c) = a / c"
-by simp
-
-lemma bounded_linear_compose:
- assumes "bounded_linear f"
- assumes "bounded_linear g"
- shows "bounded_linear (\<lambda>x. f (g x))"
-proof -
- interpret f: bounded_linear f by fact
- interpret g: bounded_linear g by fact
- show ?thesis proof (unfold_locales)
- fix x y show "f (g (x + y)) = f (g x) + f (g y)"
- by (simp only: f.add g.add)
- next
- fix r x show "f (g (scaleR r x)) = scaleR r (f (g x))"
- by (simp only: f.scaleR g.scaleR)
- next
- from f.pos_bounded
- obtain Kf where f: "\<And>x. norm (f x) \<le> norm x * Kf" and Kf: "0 < Kf" by fast
- from g.pos_bounded
- obtain Kg where g: "\<And>x. norm (g x) \<le> norm x * Kg" by fast
- show "\<exists>K. \<forall>x. norm (f (g x)) \<le> norm x * K"
- proof (intro exI allI)
- fix x
- have "norm (f (g x)) \<le> norm (g x) * Kf"
- using f .
- also have "\<dots> \<le> (norm x * Kg) * Kf"
- using g Kf [THEN order_less_imp_le] by (rule mult_right_mono)
- also have "(norm x * Kg) * Kf = norm x * (Kg * Kf)"
- by (rule mult_assoc)
- finally show "norm (f (g x)) \<le> norm x * (Kg * Kf)" .
- qed
- qed
-qed
-
-lemma FDERIV_compose:
- fixes f :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
- fixes g :: "'b::real_normed_vector \<Rightarrow> 'c::real_normed_vector"
- assumes f: "FDERIV f x :> F"
- assumes g: "FDERIV g (f x) :> G"
- shows "FDERIV (\<lambda>x. g (f x)) x :> (\<lambda>h. G (F h))"
-proof (rule FDERIV_I)
- from FDERIV_bounded_linear [OF g] FDERIV_bounded_linear [OF f]
- show "bounded_linear (\<lambda>h. G (F h))"
- by (rule bounded_linear_compose)
-next
- let ?Rf = "\<lambda>h. f (x + h) - f x - F h"
- let ?Rg = "\<lambda>k. g (f x + k) - g (f x) - G k"
- let ?k = "\<lambda>h. f (x + h) - f x"
- let ?Nf = "\<lambda>h. norm (?Rf h) / norm h"
- let ?Ng = "\<lambda>h. norm (?Rg (?k h)) / norm (?k h)"
- from f interpret F!: bounded_linear "F" by (rule FDERIV_bounded_linear)
- from g interpret G!: bounded_linear "G" by (rule FDERIV_bounded_linear)
- from F.bounded obtain kF where kF: "\<And>x. norm (F x) \<le> norm x * kF" by fast
- from G.bounded obtain kG where kG: "\<And>x. norm (G x) \<le> norm x * kG" by fast
-
- let ?fun2 = "\<lambda>h. ?Nf h * kG + ?Ng h * (?Nf h + kF)"
-
- show "(\<lambda>h. norm (g (f (x + h)) - g (f x) - G (F h)) / norm h) -- 0 --> 0"
- proof (rule real_LIM_sandwich_zero)
- have Nf: "?Nf -- 0 --> 0"
- using FDERIV_D [OF f] .
-
- have Ng1: "isCont (\<lambda>k. norm (?Rg k) / norm k) 0"
- by (simp add: isCont_def FDERIV_D [OF g])
- have Ng2: "?k -- 0 --> 0"
- apply (rule LIM_zero)
- apply (fold isCont_iff)
- apply (rule FDERIV_isCont [OF f])
- done
- have Ng: "?Ng -- 0 --> 0"
- using isCont_LIM_compose [OF Ng1 Ng2] by simp
-
- have "(\<lambda>h. ?Nf h * kG + ?Ng h * (?Nf h + kF))
- -- 0 --> 0 * kG + 0 * (0 + kF)"
- by (intro LIM_add LIM_mult LIM_const Nf Ng)
- thus "(\<lambda>h. ?Nf h * kG + ?Ng h * (?Nf h + kF)) -- 0 --> 0"
- by simp
- next
- fix h::'a assume h: "h \<noteq> 0"
- thus "0 \<le> norm (g (f (x + h)) - g (f x) - G (F h)) / norm h"
- by (simp add: divide_nonneg_pos)
- next
- fix h::'a assume h: "h \<noteq> 0"
- have "g (f (x + h)) - g (f x) - G (F h) = G (?Rf h) + ?Rg (?k h)"
- by (simp add: G.diff)
- hence "norm (g (f (x + h)) - g (f x) - G (F h)) / norm h
- = norm (G (?Rf h) + ?Rg (?k h)) / norm h"
- by (rule arg_cong)
- also have "\<dots> \<le> norm (G (?Rf h)) / norm h + norm (?Rg (?k h)) / norm h"
- by (rule norm_ratio_ineq)
- also have "\<dots> \<le> ?Nf h * kG + ?Ng h * (?Nf h + kF)"
- proof (rule add_mono)
- show "norm (G (?Rf h)) / norm h \<le> ?Nf h * kG"
- apply (rule ord_le_eq_trans)
- apply (rule divide_right_mono [OF kG norm_ge_zero])
- apply simp
- done
- next
- have "norm (?Rg (?k h)) / norm h = ?Ng h * (norm (?k h) / norm h)"
- apply (rule real_divide_cancel_lemma [symmetric])
- apply (simp add: G.zero)
- done
- also have "\<dots> \<le> ?Ng h * (?Nf h + kF)"
- proof (rule mult_left_mono)
- have "norm (?k h) / norm h = norm (?Rf h + F h) / norm h"
- by simp
- also have "\<dots> \<le> ?Nf h + norm (F h) / norm h"
- by (rule norm_ratio_ineq)
- also have "\<dots> \<le> ?Nf h + kF"
- apply (rule add_left_mono)
- apply (subst pos_divide_le_eq, simp add: h)
- apply (subst mult_commute)
- apply (rule kF)
- done
- finally show "norm (?k h) / norm h \<le> ?Nf h + kF" .
- next
- show "0 \<le> ?Ng h"
- apply (case_tac "f (x + h) - f x = 0", simp)
- apply (rule divide_nonneg_pos [OF norm_ge_zero])
- apply simp
- done
- qed
- finally show "norm (?Rg (?k h)) / norm h \<le> ?Ng h * (?Nf h + kF)" .
- qed
- finally show "norm (g (f (x + h)) - g (f x) - G (F h)) / norm h
- \<le> ?Nf h * kG + ?Ng h * (?Nf h + kF)" .
- qed
-qed
-
-subsection {* Product Rule *}
-
-lemma (in bounded_bilinear) FDERIV_lemma:
- "a' ** b' - a ** b - (a ** B + A ** b)
- = a ** (b' - b - B) + (a' - a - A) ** b' + A ** (b' - b)"
-by (simp add: diff_left diff_right)
-
-lemma (in bounded_bilinear) FDERIV:
- fixes x :: "'d::real_normed_vector"
- assumes f: "FDERIV f x :> F"
- assumes g: "FDERIV g x :> G"
- shows "FDERIV (\<lambda>x. f x ** g x) x :> (\<lambda>h. f x ** G h + F h ** g x)"
-proof (rule FDERIV_I)
- show "bounded_linear (\<lambda>h. f x ** G h + F h ** g x)"
- apply (rule bounded_linear_add)
- apply (rule bounded_linear_compose [OF bounded_linear_right])
- apply (rule FDERIV_bounded_linear [OF g])
- apply (rule bounded_linear_compose [OF bounded_linear_left])
- apply (rule FDERIV_bounded_linear [OF f])
- done
-next
- from bounded_linear.bounded [OF FDERIV_bounded_linear [OF f]]
- obtain KF where norm_F: "\<And>x. norm (F x) \<le> norm x * KF" by fast
-
- from pos_bounded obtain K where K: "0 < K" and norm_prod:
- "\<And>a b. norm (a ** b) \<le> norm a * norm b * K" by fast
-
- let ?Rf = "\<lambda>h. f (x + h) - f x - F h"
- let ?Rg = "\<lambda>h. g (x + h) - g x - G h"
-
- let ?fun1 = "\<lambda>h.
- norm (f x ** ?Rg h + ?Rf h ** g (x + h) + F h ** (g (x + h) - g x)) /
- norm h"
-
- let ?fun2 = "\<lambda>h.
- norm (f x) * (norm (?Rg h) / norm h) * K +
- norm (?Rf h) / norm h * norm (g (x + h)) * K +
- KF * norm (g (x + h) - g x) * K"
-
- have "?fun1 -- 0 --> 0"
- proof (rule real_LIM_sandwich_zero)
- from f g isCont_iff [THEN iffD1, OF FDERIV_isCont [OF g]]
- have "?fun2 -- 0 -->
- norm (f x) * 0 * K + 0 * norm (g x) * K + KF * norm (0::'b) * K"
- by (intro LIM_add LIM_mult LIM_const LIM_norm LIM_zero FDERIV_D)
- thus "?fun2 -- 0 --> 0"
- by simp
- next
- fix h::'d assume "h \<noteq> 0"
- thus "0 \<le> ?fun1 h"
- by (simp add: divide_nonneg_pos)
- next
- fix h::'d assume "h \<noteq> 0"
- have "?fun1 h \<le> (norm (f x) * norm (?Rg h) * K +
- norm (?Rf h) * norm (g (x + h)) * K +
- norm h * KF * norm (g (x + h) - g x) * K) / norm h"
- by (intro
- divide_right_mono mult_mono'
- order_trans [OF norm_triangle_ineq add_mono]
- order_trans [OF norm_prod mult_right_mono]
- mult_nonneg_nonneg order_refl norm_ge_zero norm_F
- K [THEN order_less_imp_le]
- )
- also have "\<dots> = ?fun2 h"
- by (simp add: add_divide_distrib)
- finally show "?fun1 h \<le> ?fun2 h" .
- qed
- thus "(\<lambda>h.
- norm (f (x + h) ** g (x + h) - f x ** g x - (f x ** G h + F h ** g x))
- / norm h) -- 0 --> 0"
- by (simp only: FDERIV_lemma)
-qed
-
-lemmas FDERIV_mult = mult.FDERIV
-
-lemmas FDERIV_scaleR = scaleR.FDERIV
-
-
-subsection {* Powers *}
-
-lemma FDERIV_power_Suc:
- fixes x :: "'a::{real_normed_algebra,recpower,comm_ring_1}"
- shows "FDERIV (\<lambda>x. x ^ Suc n) x :> (\<lambda>h. (1 + of_nat n) * x ^ n * h)"
- apply (induct n)
- apply (simp add: power_Suc FDERIV_ident)
- apply (drule FDERIV_mult [OF FDERIV_ident])
- apply (simp only: of_nat_Suc left_distrib mult_1_left)
- apply (simp only: power_Suc right_distrib add_ac mult_ac)
-done
-
-lemma FDERIV_power:
- fixes x :: "'a::{real_normed_algebra,recpower,comm_ring_1}"
- shows "FDERIV (\<lambda>x. x ^ n) x :> (\<lambda>h. of_nat n * x ^ (n - 1) * h)"
- apply (cases n)
- apply (simp add: FDERIV_const)
- apply (simp add: FDERIV_power_Suc)
- done
-
-
-subsection {* Inverse *}
-
-lemma inverse_diff_inverse:
- "\<lbrakk>(a::'a::division_ring) \<noteq> 0; b \<noteq> 0\<rbrakk>
- \<Longrightarrow> inverse a - inverse b = - (inverse a * (a - b) * inverse b)"
-by (simp add: right_diff_distrib left_diff_distrib mult_assoc)
-
-lemmas bounded_linear_mult_const =
- mult.bounded_linear_left [THEN bounded_linear_compose]
-
-lemmas bounded_linear_const_mult =
- mult.bounded_linear_right [THEN bounded_linear_compose]
-
-lemma FDERIV_inverse:
- fixes x :: "'a::real_normed_div_algebra"
- assumes x: "x \<noteq> 0"
- shows "FDERIV inverse x :> (\<lambda>h. - (inverse x * h * inverse x))"
- (is "FDERIV ?inv _ :> _")
-proof (rule FDERIV_I)
- show "bounded_linear (\<lambda>h. - (?inv x * h * ?inv x))"
- apply (rule bounded_linear_minus)
- apply (rule bounded_linear_mult_const)
- apply (rule bounded_linear_const_mult)
- apply (rule bounded_linear_ident)
- done
-next
- show "(\<lambda>h. norm (?inv (x + h) - ?inv x - - (?inv x * h * ?inv x)) / norm h)
- -- 0 --> 0"
- proof (rule LIM_equal2)
- show "0 < norm x" using x by simp
- next
- fix h::'a
- assume 1: "h \<noteq> 0"
- assume "norm (h - 0) < norm x"
- hence "h \<noteq> -x" by clarsimp
- hence 2: "x + h \<noteq> 0"
- apply (rule contrapos_nn)
- apply (rule sym)
- apply (erule equals_zero_I)
- done
- show "norm (?inv (x + h) - ?inv x - - (?inv x * h * ?inv x)) / norm h
- = norm ((?inv (x + h) - ?inv x) * h * ?inv x) / norm h"
- apply (subst inverse_diff_inverse [OF 2 x])
- apply (subst minus_diff_minus)
- apply (subst norm_minus_cancel)
- apply (simp add: left_diff_distrib)
- done
- next
- show "(\<lambda>h. norm ((?inv (x + h) - ?inv x) * h * ?inv x) / norm h)
- -- 0 --> 0"
- proof (rule real_LIM_sandwich_zero)
- show "(\<lambda>h. norm (?inv (x + h) - ?inv x) * norm (?inv x))
- -- 0 --> 0"
- apply (rule LIM_mult_left_zero)
- apply (rule LIM_norm_zero)
- apply (rule LIM_zero)
- apply (rule LIM_offset_zero)
- apply (rule LIM_inverse)
- apply (rule LIM_ident)
- apply (rule x)
- done
- next
- fix h::'a assume h: "h \<noteq> 0"
- show "0 \<le> norm ((?inv (x + h) - ?inv x) * h * ?inv x) / norm h"
- apply (rule divide_nonneg_pos)
- apply (rule norm_ge_zero)
- apply (simp add: h)
- done
- next
- fix h::'a assume h: "h \<noteq> 0"
- have "norm ((?inv (x + h) - ?inv x) * h * ?inv x) / norm h
- \<le> norm (?inv (x + h) - ?inv x) * norm h * norm (?inv x) / norm h"
- apply (rule divide_right_mono [OF _ norm_ge_zero])
- apply (rule order_trans [OF norm_mult_ineq])
- apply (rule mult_right_mono [OF _ norm_ge_zero])
- apply (rule norm_mult_ineq)
- done
- also have "\<dots> = norm (?inv (x + h) - ?inv x) * norm (?inv x)"
- by simp
- finally show "norm ((?inv (x + h) - ?inv x) * h * ?inv x) / norm h
- \<le> norm (?inv (x + h) - ?inv x) * norm (?inv x)" .
- qed
- qed
-qed
-
-subsection {* Alternate definition *}
-
-lemma field_fderiv_def:
- fixes x :: "'a::real_normed_field" shows
- "FDERIV f x :> (\<lambda>h. h * D) = (\<lambda>h. (f (x + h) - f x) / h) -- 0 --> D"
- apply (unfold fderiv_def)
- apply (simp add: mult.bounded_linear_left)
- apply (simp cong: LIM_cong add: nonzero_norm_divide [symmetric])
- apply (subst diff_divide_distrib)
- apply (subst times_divide_eq_left [symmetric])
- apply (simp cong: LIM_cong)
- apply (simp add: LIM_norm_zero_iff LIM_zero_iff)
-done
-
-end
--- a/src/HOL/GCD.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/GCD.thy Thu Feb 26 11:21:29 2009 +0000
@@ -60,9 +60,12 @@
lemma gcd_non_0: "n > 0 \<Longrightarrow> gcd m n = gcd n (m mod n)"
by simp
-lemma gcd_1 [simp, algebra]: "gcd m (Suc 0) = 1"
+lemma gcd_1 [simp, algebra]: "gcd m (Suc 0) = Suc 0"
by simp
+lemma nat_gcd_1_right [simp, algebra]: "gcd m 1 = 1"
+ unfolding One_nat_def by (rule gcd_1)
+
declare gcd.simps [simp del]
text {*
@@ -116,9 +119,12 @@
apply (blast intro: dvd_trans)
done
-lemma gcd_1_left [simp, algebra]: "gcd (Suc 0) m = 1"
+lemma gcd_1_left [simp, algebra]: "gcd (Suc 0) m = Suc 0"
by (simp add: gcd_commute)
+lemma nat_gcd_1_left [simp, algebra]: "gcd 1 m = 1"
+ unfolding One_nat_def by (rule gcd_1_left)
+
text {*
\medskip Multiplication laws
*}
@@ -156,7 +162,6 @@
apply (simp add: gcd_assoc)
apply (simp add: gcd_commute)
apply (simp_all add: mult_commute)
- apply (blast intro: dvd_mult)
done
@@ -404,7 +409,7 @@
{fix x y assume H: "a * x - b * y = d \<or> b * x - a * y = d"
have dv: "?g dvd a*x" "?g dvd b * y" "?g dvd b*x" "?g dvd a * y"
using dvd_mult2[OF gcd_dvd1[of a b]] dvd_mult2[OF gcd_dvd2[of a b]] by simp_all
- from dvd_diff[OF dv(1,2)] dvd_diff[OF dv(3,4)] H
+ from nat_dvd_diff[OF dv(1,2)] nat_dvd_diff[OF dv(3,4)] H
have ?rhs by auto}
ultimately show ?thesis by blast
qed
@@ -597,8 +602,8 @@
from h' have "int (nat \<bar>k\<bar>) = int (nat \<bar>i\<bar> * h')" by simp
then have "\<bar>k\<bar> = \<bar>i\<bar> * int h'" by (simp add: int_mult)
then show ?thesis
- apply (subst zdvd_abs1 [symmetric])
- apply (subst zdvd_abs2 [symmetric])
+ apply (subst abs_dvd_iff [symmetric])
+ apply (subst dvd_abs_iff [symmetric])
apply (unfold dvd_def)
apply (rule_tac x = "int h'" in exI, simp)
done
@@ -614,11 +619,11 @@
let ?m' = "nat \<bar>m\<bar>"
let ?n' = "nat \<bar>n\<bar>"
from `k dvd m` and `k dvd n` have dvd': "?k' dvd ?m'" "?k' dvd ?n'"
- unfolding zdvd_int by (simp_all only: int_nat_abs zdvd_abs1 zdvd_abs2)
+ unfolding zdvd_int by (simp_all only: int_nat_abs abs_dvd_iff dvd_abs_iff)
from gcd_greatest [OF dvd'] have "int (nat \<bar>k\<bar>) dvd zgcd m n"
unfolding zgcd_def by (simp only: zdvd_int)
then have "\<bar>k\<bar> dvd zgcd m n" by (simp only: int_nat_abs)
- then show "k dvd zgcd m n" by (simp add: zdvd_abs1)
+ then show "k dvd zgcd m n" by simp
qed
lemma div_zgcd_relprime:
@@ -721,7 +726,7 @@
assumes "k dvd i" shows "k dvd (zlcm i j)"
proof -
have "nat(abs k) dvd nat(abs i)" using `k dvd i`
- by(simp add:int_dvd_iff[symmetric] dvd_int_iff[symmetric] zdvd_abs1)
+ by(simp add:int_dvd_iff[symmetric] dvd_int_iff[symmetric])
thus ?thesis by(simp add:zlcm_def dvd_int_iff)(blast intro: dvd_trans)
qed
@@ -729,7 +734,7 @@
assumes "k dvd j" shows "k dvd (zlcm i j)"
proof -
have "nat(abs k) dvd nat(abs j)" using `k dvd j`
- by(simp add:int_dvd_iff[symmetric] dvd_int_iff[symmetric] zdvd_abs1)
+ by(simp add:int_dvd_iff[symmetric] dvd_int_iff[symmetric])
thus ?thesis by(simp add:zlcm_def dvd_int_iff)(blast intro: dvd_trans)
qed
--- a/src/HOL/Groebner_Basis.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Groebner_Basis.thy Thu Feb 26 11:21:29 2009 +0000
@@ -147,7 +147,7 @@
next show "pwr (mul x y) q = mul (pwr x q) (pwr y q)" by (rule pwr_mul)
next show "pwr (pwr x p) q = pwr x (p * q)" by (rule pwr_pwr)
next show "pwr x 0 = r1" using pwr_0 .
-next show "pwr x 1 = x" by (simp add: nat_number pwr_Suc pwr_0 mul_1 mul_c)
+next show "pwr x 1 = x" unfolding One_nat_def by (simp add: nat_number pwr_Suc pwr_0 mul_1 mul_c)
next show "mul x (add y z) = add (mul x y) (mul x z)" using mul_d by simp
next show "pwr x (Suc q) = mul x (pwr x q)" using pwr_Suc by simp
next show "pwr x (2 * n) = mul (pwr x n) (pwr x n)" by (simp add: nat_number mul_pwr)
@@ -436,8 +436,8 @@
*} "solve polynomial equations over (semi)rings and ideal membership problems using Groebner bases"
declare dvd_def[algebra]
declare dvd_eq_mod_eq_0[symmetric, algebra]
-declare nat_mod_div_trivial[algebra]
-declare nat_mod_mod_trivial[algebra]
+declare mod_div_trivial[algebra]
+declare mod_mod_trivial[algebra]
declare conjunct1[OF DIVISION_BY_ZERO, algebra]
declare conjunct2[OF DIVISION_BY_ZERO, algebra]
declare zmod_zdiv_equality[symmetric,algebra]
@@ -448,16 +448,16 @@
declare zmod_zminus2[algebra]
declare zdiv_zero[algebra]
declare zmod_zero[algebra]
-declare zmod_1[algebra]
-declare zdiv_1[algebra]
+declare mod_by_1[algebra]
+declare div_by_1[algebra]
declare zmod_minus1_right[algebra]
declare zdiv_minus1_right[algebra]
declare mod_div_trivial[algebra]
declare mod_mod_trivial[algebra]
-declare zmod_zmult_self1[algebra]
-declare zmod_zmult_self2[algebra]
+declare mod_mult_self2_is_0[algebra]
+declare mod_mult_self1_is_0[algebra]
declare zmod_eq_0_iff[algebra]
-declare zdvd_0_left[algebra]
+declare dvd_0_left_iff[algebra]
declare zdvd1_eq[algebra]
declare zmod_eq_dvd_iff[algebra]
declare nat_mod_eq_iff[algebra]
--- a/src/HOL/HOL.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/HOL.thy Thu Feb 26 11:21:29 2009 +0000
@@ -28,7 +28,8 @@
("~~/src/Tools/induct_tacs.ML")
"~~/src/Tools/value.ML"
"~~/src/Tools/code/code_name.ML"
- "~~/src/Tools/code/code_funcgr.ML"
+ "~~/src/Tools/code/code_wellsorted.ML" (* formal dependency *)
+ (*"~~/src/Tools/code/code_funcgr.ML"*)
"~~/src/Tools/code/code_thingol.ML"
"~~/src/Tools/code/code_printer.ML"
"~~/src/Tools/code/code_target.ML"
@@ -290,7 +291,7 @@
typed_print_translation {*
let
fun tr' c = (c, fn show_sorts => fn T => fn ts =>
- if T = dummyT orelse not (! show_types) andalso can Term.dest_Type T then raise Match
+ if (not o null) ts orelse T = dummyT orelse not (! show_types) andalso can Term.dest_Type T then raise Match
else Syntax.const Syntax.constrainC $ Syntax.const c $ Syntax.term_of_typ show_sorts T);
in map tr' [@{const_syntax HOL.one}, @{const_syntax HOL.zero}] end;
*} -- {* show types that are presumably too general *}
--- a/src/HOL/Hoare/Arith2.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Hoare/Arith2.thy Thu Feb 26 11:21:29 2009 +0000
@@ -42,12 +42,12 @@
lemma cd_diff_l: "n<=m ==> cd x m n = cd x (m-n) n"
apply (unfold cd_def)
- apply (blast intro: dvd_diff dest: dvd_diffD)
+ apply (fastsimp dest: dvd_diffD)
done
lemma cd_diff_r: "m<=n ==> cd x m n = cd x m (n-m)"
apply (unfold cd_def)
- apply (blast intro: dvd_diff dest: dvd_diffD)
+ apply (fastsimp dest: dvd_diffD)
done
--- a/src/HOL/Induct/Common_Patterns.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Induct/Common_Patterns.thy Thu Feb 26 11:21:29 2009 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/Induct/Common_Patterns.thy
- ID: $Id$
Author: Makarius
*)
--- a/src/HOL/Int.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Int.thy Thu Feb 26 11:21:29 2009 +0000
@@ -832,8 +832,8 @@
le_imp_0_less [THEN order_less_imp_le])
next
case (neg n)
- thus ?thesis by (simp del: of_nat_Suc of_nat_add
- add: algebra_simps of_nat_1 [symmetric] of_nat_add [symmetric])
+ thus ?thesis by (simp del: of_nat_Suc of_nat_add of_nat_1
+ add: algebra_simps of_nat_1 [where 'a=int, symmetric] of_nat_add [symmetric])
qed
lemma bin_less_0_simps:
@@ -1165,8 +1165,8 @@
le_imp_0_less [THEN order_less_imp_le])
next
case (neg n)
- thus ?thesis by (simp del: of_nat_Suc of_nat_add
- add: algebra_simps of_nat_1 [symmetric] of_nat_add [symmetric])
+ thus ?thesis by (simp del: of_nat_Suc of_nat_add of_nat_1
+ add: algebra_simps of_nat_1 [where 'a=int, symmetric] of_nat_add [symmetric])
qed
text {* Less-Than or Equals *}
@@ -1547,7 +1547,7 @@
"abs(-1 ^ n) = (1::'a::{ordered_idom,number_ring,recpower})"
by (simp add: power_abs)
-lemma of_int_number_of_eq:
+lemma of_int_number_of_eq [simp]:
"of_int (number_of v) = (number_of v :: 'a :: number_ring)"
by (simp add: number_of_eq)
@@ -1627,7 +1627,7 @@
context ring_1
begin
-lemma of_int_of_nat:
+lemma of_int_of_nat [nitpick_const_simp]:
"of_int k = (if k < 0 then - of_nat (nat (- k)) else of_nat (nat k))"
proof (cases "k < 0")
case True then have "0 \<le> - k" by simp
@@ -1785,11 +1785,12 @@
lemma int_val_lemma:
"(\<forall>i<n::nat. abs(f(i+1) - f i) \<le> 1) -->
f 0 \<le> k --> k \<le> f n --> (\<exists>i \<le> n. f i = (k::int))"
+unfolding One_nat_def
apply (induct n, simp)
apply (intro strip)
apply (erule impE, simp)
apply (erule_tac x = n in allE, simp)
-apply (case_tac "k = f (n+1) ")
+apply (case_tac "k = f (Suc n)")
apply force
apply (erule impE)
apply (simp add: abs_if split add: split_if_asm)
@@ -1803,6 +1804,7 @@
f m \<le> k; k \<le> f n |] ==> ? i. m \<le> i & i \<le> n & f i = (k::int)"
apply (cut_tac n = "n-m" and f = "%i. f (i+m) " and k = k
in int_val_lemma)
+unfolding One_nat_def
apply simp
apply (erule exE)
apply (rule_tac x = "i+m" in exI, arith)
--- a/src/HOL/IntDiv.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/IntDiv.thy Thu Feb 26 11:21:29 2009 +0000
@@ -377,6 +377,11 @@
apply (blast intro: divmod_rel_div_mod [THEN zminus1_lemma, THEN divmod_rel_mod])
done
+lemma zmod_zminus1_not_zero:
+ fixes k l :: int
+ shows "- k mod l \<noteq> 0 \<Longrightarrow> k mod l \<noteq> 0"
+ unfolding zmod_zminus1_eq_if by auto
+
lemma zdiv_zminus2: "a div (-b) = (-a::int) div b"
by (cut_tac a = "-a" in zdiv_zminus_zminus, auto)
@@ -393,6 +398,11 @@
"a mod (-b::int) = (if a mod b = 0 then 0 else (a mod b) - b)"
by (simp add: zmod_zminus1_eq_if zmod_zminus2)
+lemma zmod_zminus2_not_zero:
+ fixes k l :: int
+ shows "k mod - l \<noteq> 0 \<Longrightarrow> k mod l \<noteq> 0"
+ unfolding zmod_zminus2_eq_if by auto
+
subsection{*Division of a Number by Itself*}
@@ -441,9 +451,6 @@
lemma zmod_zero [simp]: "(0::int) mod b = 0"
by (simp add: mod_def divmod_def)
-lemma zdiv_minus1: "(0::int) < b ==> -1 div b = -1"
-by (simp add: div_def divmod_def)
-
lemma zmod_minus1: "(0::int) < b ==> -1 mod b = b - 1"
by (simp add: mod_def divmod_def)
@@ -540,34 +547,6 @@
simproc_setup binary_int_mod ("number_of m mod number_of n :: int") =
{* K (divmod_proc (@{thm divmod_rel_mod_eq})) *}
-(* The following 8 lemmas are made unnecessary by the above simprocs: *)
-
-lemmas div_pos_pos_number_of =
- div_pos_pos [of "number_of v" "number_of w", standard]
-
-lemmas div_neg_pos_number_of =
- div_neg_pos [of "number_of v" "number_of w", standard]
-
-lemmas div_pos_neg_number_of =
- div_pos_neg [of "number_of v" "number_of w", standard]
-
-lemmas div_neg_neg_number_of =
- div_neg_neg [of "number_of v" "number_of w", standard]
-
-
-lemmas mod_pos_pos_number_of =
- mod_pos_pos [of "number_of v" "number_of w", standard]
-
-lemmas mod_neg_pos_number_of =
- mod_neg_pos [of "number_of v" "number_of w", standard]
-
-lemmas mod_pos_neg_number_of =
- mod_pos_neg [of "number_of v" "number_of w", standard]
-
-lemmas mod_neg_neg_number_of =
- mod_neg_neg [of "number_of v" "number_of w", standard]
-
-
lemmas posDivAlg_eqn_number_of [simp] =
posDivAlg_eqn [of "number_of v" "number_of w", standard]
@@ -577,15 +556,6 @@
text{*Special-case simplification *}
-lemma zmod_1 [simp]: "a mod (1::int) = 0"
-apply (cut_tac a = a and b = 1 in pos_mod_sign)
-apply (cut_tac [2] a = a and b = 1 in pos_mod_bound)
-apply (auto simp del:pos_mod_bound pos_mod_sign)
-done
-
-lemma zdiv_1 [simp]: "a div (1::int) = a"
-by (cut_tac a = a and b = 1 in zmod_zdiv_equality, auto)
-
lemma zmod_minus1_right [simp]: "a mod (-1::int) = 0"
apply (cut_tac a = a and b = "-1" in neg_mod_sign)
apply (cut_tac [2] a = a and b = "-1" in neg_mod_bound)
@@ -719,18 +689,6 @@
apply (blast intro: divmod_rel_div_mod [THEN zmult1_lemma, THEN divmod_rel_mod])
done
-lemma zmod_zmult1_eq': "(a*b) mod (c::int) = ((a mod c) * b) mod c"
-apply (rule trans)
-apply (rule_tac s = "b*a mod c" in trans)
-apply (rule_tac [2] zmod_zmult1_eq)
-apply (simp_all add: mult_commute)
-done
-
-lemma zmod_zmult_distrib: "(a*b) mod (c::int) = ((a mod c) * (b mod c)) mod c"
-apply (rule zmod_zmult1_eq' [THEN trans])
-apply (rule zmod_zmult1_eq)
-done
-
lemma zdiv_zmult_self1 [simp]: "b \<noteq> (0::int) ==> (a*b) div b = a"
by (simp add: zdiv_zmult1_eq)
@@ -739,11 +697,6 @@
apply (auto simp add: linorder_neq_iff div_pos_pos_trivial div_neg_neg_trivial)
done
-lemma zmod_zmod_trivial: "(a mod b) mod b = a mod (b::int)"
-apply (case_tac "b = 0", simp)
-apply (force simp add: linorder_neq_iff mod_pos_pos_trivial mod_neg_neg_trivial)
-done
-
text{*proving (a+b) div c = a div c + b div c + ((a mod c + b mod c) div c) *}
lemma zadd1_lemma:
@@ -758,11 +711,6 @@
apply (blast intro: zadd1_lemma [OF divmod_rel_div_mod divmod_rel_div_mod] divmod_rel_div)
done
-lemma zmod_zadd1_eq: "(a+b) mod (c::int) = (a mod c + b mod c) mod c"
-apply (case_tac "c = 0", simp)
-apply (blast intro: zadd1_lemma [OF divmod_rel_div_mod divmod_rel_div_mod] divmod_rel_mod)
-done
-
instance int :: ring_div
proof
fix a b c :: int
@@ -799,41 +747,12 @@
show ?thesis by simp
qed
-lemma zdiv_zadd_self1: "a \<noteq> (0::int) ==> (a+b) div a = b div a + 1"
-by (rule div_add_self1) (* already declared [simp] *)
-
-lemma zdiv_zadd_self2: "a \<noteq> (0::int) ==> (b+a) div a = b div a + 1"
-by (rule div_add_self2) (* already declared [simp] *)
-
-lemma zdiv_zmult_self2: "b \<noteq> (0::int) ==> (b*a) div b = a"
-by (rule div_mult_self1_is_id) (* already declared [simp] *)
-
-lemma zmod_zmult_self1: "(a*b) mod b = (0::int)"
-by (rule mod_mult_self2_is_0) (* already declared [simp] *)
-
-lemma zmod_zmult_self2: "(b*a) mod b = (0::int)"
-by (rule mod_mult_self1_is_0) (* already declared [simp] *)
-
lemma zmod_eq_0_iff: "(m mod d = 0) = (EX q::int. m = d*q)"
by (simp add: dvd_eq_mod_eq_0 [symmetric] dvd_def)
(* REVISIT: should this be generalized to all semiring_div types? *)
lemmas zmod_eq_0D [dest!] = zmod_eq_0_iff [THEN iffD1]
-lemma zmod_zadd_left_eq: "(a+b) mod (c::int) = ((a mod c) + b) mod c"
-by (rule mod_add_left_eq)
-
-lemma zmod_zadd_right_eq: "(a+b) mod (c::int) = (a + (b mod c)) mod c"
-by (rule mod_add_right_eq)
-
-lemma zmod_zadd_self1: "(a+b) mod a = b mod (a::int)"
-by (rule mod_add_self1) (* already declared [simp] *)
-
-lemma zmod_zadd_self2: "(b+a) mod a = b mod (a::int)"
-by (rule mod_add_self2) (* already declared [simp] *)
-
-lemma zmod_zdiff1_eq: "(a - b) mod c = (a mod c - b mod c) mod (c::int)"
-by (rule mod_diff_eq)
subsection{*Proving @{term "a div (b*c) = (a div b) div c"} *}
@@ -917,13 +836,6 @@
"(k*m) div (k*n) = (if k = (0::int) then 0 else m div n)"
by (simp add:zdiv_zmult_zmult1)
-(*
-lemma zdiv_zmult_zmult2: "c \<noteq> (0::int) ==> (a*c) div (b*c) = a div b"
-apply (drule zdiv_zmult_zmult1)
-apply (auto simp add: mult_commute)
-done
-*)
-
subsection{*Distribution of Factors over mod*}
@@ -948,9 +860,6 @@
apply (auto simp add: mult_commute)
done
-lemma zmod_zmod_cancel: "n dvd m \<Longrightarrow> (k::int) mod m mod n = k mod n"
-by (rule mod_mod_cancel)
-
subsection {*Splitting Rules for div and mod*}
@@ -961,7 +870,7 @@
P(n div k :: int)(n mod k) = (\<forall>i j. 0\<le>j & j<k & n = k*i + j --> P i j)"
apply (rule iffI, clarify)
apply (erule_tac P="P ?x ?y" in rev_mp)
- apply (subst zmod_zadd1_eq)
+ apply (subst mod_add_eq)
apply (subst zdiv_zadd1_eq)
apply (simp add: div_pos_pos_trivial mod_pos_pos_trivial)
txt{*converse direction*}
@@ -974,7 +883,7 @@
P(n div k :: int)(n mod k) = (\<forall>i j. k<j & j\<le>0 & n = k*i + j --> P i j)"
apply (rule iffI, clarify)
apply (erule_tac P="P ?x ?y" in rev_mp)
- apply (subst zmod_zadd1_eq)
+ apply (subst mod_add_eq)
apply (subst zdiv_zadd1_eq)
apply (simp add: div_neg_neg_trivial mod_neg_neg_trivial)
txt{*converse direction*}
@@ -1047,11 +956,6 @@
simp)
done
-(*Not clear why this must be proved separately; probably number_of causes
- simplification problems*)
-lemma not_0_le_lemma: "~ 0 \<le> x ==> x \<le> (0::int)"
-by auto
-
lemma zdiv_number_of_Bit0 [simp]:
"number_of (Int.Bit0 v) div number_of (Int.Bit0 w) =
number_of v div (number_of w :: int)"
@@ -1078,7 +982,7 @@
apply (rule_tac [2] mult_left_mono)
apply (auto simp add: add_commute [of 1] mult_commute add1_zle_eq
pos_mod_bound)
-apply (subst zmod_zadd1_eq)
+apply (subst mod_add_eq)
apply (simp add: zmod_zmult_zmult2 mod_pos_pos_trivial)
apply (rule mod_pos_pos_trivial)
apply (auto simp add: mod_pos_pos_trivial ring_distribs)
@@ -1090,7 +994,7 @@
apply (subgoal_tac "(1 + 2* (-b - 1)) mod (2* (-a)) =
1 + 2* ((-b - 1) mod (-a))")
apply (rule_tac [2] pos_zmod_mult_2)
-apply (auto simp add: minus_mult_right [symmetric] right_diff_distrib)
+apply (auto simp add: right_diff_distrib)
apply (subgoal_tac " (-1 - (2 * b)) = - (1 + (2 * b))")
prefer 2 apply simp
apply (simp only: zmod_zminus_zminus diff_minus minus_add_distrib [symmetric])
@@ -1101,7 +1005,7 @@
(2::int) * (number_of v mod number_of w)"
apply (simp only: number_of_eq numeral_simps)
apply (simp add: zmod_zmult_zmult1 pos_zmod_mult_2
- not_0_le_lemma neg_zmod_mult_2 add_ac)
+ neg_zmod_mult_2 add_ac)
done
lemma zmod_number_of_Bit1 [simp]:
@@ -1111,7 +1015,7 @@
else 2 * ((number_of v + (1::int)) mod number_of w) - 1)"
apply (simp only: number_of_eq numeral_simps)
apply (simp add: zmod_zmult_zmult1 pos_zmod_mult_2
- not_0_le_lemma neg_zmod_mult_2 add_ac)
+ neg_zmod_mult_2 add_ac)
done
@@ -1121,7 +1025,7 @@
apply (subgoal_tac "a div b \<le> -1", force)
apply (rule order_trans)
apply (rule_tac a' = "-1" in zdiv_mono1)
-apply (auto simp add: zdiv_minus1)
+apply (auto simp add: div_eq_minus1)
done
lemma div_nonneg_neg_le0: "[| (0::int) \<le> a; b < 0 |] ==> a div b \<le> 0"
@@ -1152,38 +1056,8 @@
subsection {* The Divides Relation *}
-lemma zdvd_iff_zmod_eq_0: "(m dvd n) = (n mod m = (0::int))"
- by (rule dvd_eq_mod_eq_0)
-
lemmas zdvd_iff_zmod_eq_0_number_of [simp] =
- zdvd_iff_zmod_eq_0 [of "number_of x" "number_of y", standard]
-
-lemma zdvd_0_right: "(m::int) dvd 0"
- by (rule dvd_0_right) (* already declared [iff] *)
-
-lemma zdvd_0_left: "(0 dvd (m::int)) = (m = 0)"
- by (rule dvd_0_left_iff) (* already declared [noatp,simp] *)
-
-lemma zdvd_1_left: "1 dvd (m::int)"
- by (rule one_dvd) (* already declared [simp] *)
-
-lemma zdvd_refl [simp]: "m dvd (m::int)"
- by (rule dvd_refl) (* TODO: declare generic dvd_refl [simp] *)
-
-lemma zdvd_trans: "m dvd n ==> n dvd k ==> m dvd (k::int)"
- by (rule dvd_trans)
-
-lemma zdvd_zminus_iff[simp]: "m dvd -n \<longleftrightarrow> m dvd (n::int)"
- by (rule dvd_minus_iff)
-
-lemma zdvd_zminus2_iff[simp]: "-m dvd n \<longleftrightarrow> m dvd (n::int)"
- by (rule minus_dvd_iff)
-
-lemma zdvd_abs1[simp]: "( \<bar>i::int\<bar> dvd j) = (i dvd j)"
- by (cases "i > 0") (simp_all add: zdvd_zminus2_iff)
-
-lemma zdvd_abs2[simp]: "( (i::int) dvd \<bar>j\<bar>) = (i dvd j)"
- by (cases "j > 0") (simp_all add: zdvd_zminus_iff)
+ dvd_eq_mod_eq_0 [of "number_of x::int" "number_of y::int", standard]
lemma zdvd_anti_sym:
"0 < m ==> 0 < n ==> m dvd n ==> n dvd m ==> m = (n::int)"
@@ -1191,58 +1065,32 @@
apply (simp add: mult_assoc zero_less_mult_iff zmult_eq_1_iff)
done
-lemma zdvd_zadd: "k dvd m ==> k dvd n ==> k dvd (m + n :: int)"
- by (rule dvd_add)
-
-lemma zdvd_dvd_eq: assumes anz:"a \<noteq> 0" and ab: "(a::int) dvd b" and ba:"b dvd a"
+lemma zdvd_dvd_eq: assumes "a \<noteq> 0" and "(a::int) dvd b" and "b dvd a"
shows "\<bar>a\<bar> = \<bar>b\<bar>"
proof-
- from ab obtain k where k:"b = a*k" unfolding dvd_def by blast
- from ba obtain k' where k':"a = b*k'" unfolding dvd_def by blast
+ from `a dvd b` obtain k where k:"b = a*k" unfolding dvd_def by blast
+ from `b dvd a` obtain k' where k':"a = b*k'" unfolding dvd_def by blast
from k k' have "a = a*k*k'" by simp
with mult_cancel_left1[where c="a" and b="k*k'"]
- have kk':"k*k' = 1" using anz by (simp add: mult_assoc)
+ have kk':"k*k' = 1" using `a\<noteq>0` by (simp add: mult_assoc)
hence "k = 1 \<and> k' = 1 \<or> k = -1 \<and> k' = -1" by (simp add: zmult_eq_1_iff)
thus ?thesis using k k' by auto
qed
-lemma zdvd_zdiff: "k dvd m ==> k dvd n ==> k dvd (m - n :: int)"
- by (rule Ring_and_Field.dvd_diff)
-
lemma zdvd_zdiffD: "k dvd m - n ==> k dvd n ==> k dvd (m::int)"
apply (subgoal_tac "m = n + (m - n)")
apply (erule ssubst)
- apply (blast intro: zdvd_zadd, simp)
+ apply (blast intro: dvd_add, simp)
done
-lemma zdvd_zmult: "k dvd (n::int) ==> k dvd m * n"
- by (rule dvd_mult)
-
-lemma zdvd_zmult2: "k dvd (m::int) ==> k dvd m * n"
- by (rule dvd_mult2)
-
-lemma zdvd_triv_right: "(k::int) dvd m * k"
- by (rule dvd_triv_right) (* already declared [simp] *)
-
-lemma zdvd_triv_left: "(k::int) dvd k * m"
- by (rule dvd_triv_left) (* already declared [simp] *)
-
-lemma zdvd_zmultD2: "j * k dvd n ==> j dvd (n::int)"
- by (rule dvd_mult_left)
-
-lemma zdvd_zmultD: "j * k dvd n ==> k dvd (n::int)"
- by (rule dvd_mult_right)
-
-lemma zdvd_zmult_mono: "i dvd m ==> j dvd (n::int) ==> i * j dvd m * n"
- by (rule mult_dvd_mono)
-
lemma zdvd_reduce: "(k dvd n + k * m) = (k dvd (n::int))"
- apply (rule iffI)
- apply (erule_tac [2] zdvd_zadd)
- apply (subgoal_tac "n = (n + k * m) - k * m")
- apply (erule ssubst)
- apply (erule zdvd_zdiff, simp_all)
- done
+apply (rule iffI)
+ apply (erule_tac [2] dvd_add)
+ apply (subgoal_tac "n = (n + k * m) - k * m")
+ apply (erule ssubst)
+ apply (erule dvd_diff)
+ apply(simp_all)
+done
lemma zdvd_zmod: "f dvd m ==> f dvd (n::int) ==> f dvd m mod n"
apply (simp add: dvd_def)
@@ -1252,7 +1100,7 @@
lemma zdvd_zmod_imp_zdvd: "k dvd m mod n ==> k dvd n ==> k dvd (m::int)"
apply (subgoal_tac "k dvd n * (m div n) + m mod n")
apply (simp add: zmod_zdiv_equality [symmetric])
- apply (simp only: zdvd_zadd zdvd_zmult2)
+ apply (simp only: dvd_add dvd_mult2)
done
lemma zdvd_not_zless: "0 < m ==> m < n ==> \<not> n dvd (m::int)"
@@ -1272,7 +1120,7 @@
lemma zdvd_mult_div_cancel:"(n::int) dvd m \<Longrightarrow> n * (m div n) = m"
apply (subgoal_tac "m mod n = 0")
apply (simp add: zmult_div_cancel)
-apply (simp only: zdvd_iff_zmod_eq_0)
+apply (simp only: dvd_eq_mod_eq_0)
done
lemma zdvd_mult_cancel: assumes d:"k * m dvd k * n" and kz:"k \<noteq> (0::int)"
@@ -1285,10 +1133,6 @@
thus ?thesis by simp
qed
-lemma zdvd_zmult_cancel_disj[simp]:
- "(k*m) dvd (k*n) = (k=0 | m dvd (n::int))"
-by (auto simp: zdvd_zmult_mono dest: zdvd_mult_cancel)
-
theorem ex_nat: "(\<exists>x::nat. P x) = (\<exists>x::int. 0 <= x \<and> P (nat x))"
apply (simp split add: split_nat)
@@ -1320,44 +1164,38 @@
then show ?thesis by (simp only: negative_eq_positive) auto
qed
qed
- then show ?thesis by (auto elim!: dvdE simp only: zdvd_triv_left int_mult)
+ then show ?thesis by (auto elim!: dvdE simp only: dvd_triv_left int_mult)
qed
lemma zdvd1_eq[simp]: "(x::int) dvd 1 = ( \<bar>x\<bar> = 1)"
proof
- assume d: "x dvd 1" hence "int (nat \<bar>x\<bar>) dvd int (nat 1)" by (simp add: zdvd_abs1)
+ assume d: "x dvd 1" hence "int (nat \<bar>x\<bar>) dvd int (nat 1)" by simp
hence "nat \<bar>x\<bar> dvd 1" by (simp add: zdvd_int)
hence "nat \<bar>x\<bar> = 1" by simp
thus "\<bar>x\<bar> = 1" by (cases "x < 0", auto)
next
assume "\<bar>x\<bar>=1" thus "x dvd 1"
- by(cases "x < 0",simp_all add: minus_equation_iff zdvd_iff_zmod_eq_0)
+ by(cases "x < 0",simp_all add: minus_equation_iff dvd_eq_mod_eq_0)
qed
lemma zdvd_mult_cancel1:
assumes mp:"m \<noteq>(0::int)" shows "(m * n dvd m) = (\<bar>n\<bar> = 1)"
proof
assume n1: "\<bar>n\<bar> = 1" thus "m * n dvd m"
- by (cases "n >0", auto simp add: zdvd_zminus2_iff minus_equation_iff)
+ by (cases "n >0", auto simp add: minus_dvd_iff minus_equation_iff)
next
assume H: "m * n dvd m" hence H2: "m * n dvd m * 1" by simp
from zdvd_mult_cancel[OF H2 mp] show "\<bar>n\<bar> = 1" by (simp only: zdvd1_eq)
qed
lemma int_dvd_iff: "(int m dvd z) = (m dvd nat (abs z))"
- unfolding zdvd_int by (cases "z \<ge> 0") (simp_all add: zdvd_zminus_iff)
+ unfolding zdvd_int by (cases "z \<ge> 0") simp_all
lemma dvd_int_iff: "(z dvd int m) = (nat (abs z) dvd m)"
- unfolding zdvd_int by (cases "z \<ge> 0") (simp_all add: zdvd_zminus2_iff)
+ unfolding zdvd_int by (cases "z \<ge> 0") simp_all
lemma nat_dvd_iff: "(nat z dvd m) = (if 0 \<le> z then (z dvd int m) else m = 0)"
by (auto simp add: dvd_int_iff)
-lemma zminus_dvd_iff [iff]: "(-z dvd w) = (z dvd (w::int))"
- by (rule minus_dvd_iff)
-
-lemma dvd_zminus_iff [iff]: "(z dvd -w) = (z dvd (w::int))"
- by (rule dvd_minus_iff)
-
lemma zdvd_imp_le: "[| z dvd n; 0 < n |] ==> z \<le> (n::int)"
apply (rule_tac z=n in int_cases)
apply (auto simp add: dvd_int_iff)
@@ -1369,7 +1207,7 @@
apply (induct "y", auto)
apply (rule zmod_zmult1_eq [THEN trans])
apply (simp (no_asm_simp))
-apply (rule zmod_zmult_distrib [symmetric])
+apply (rule mod_mult_eq [symmetric])
done
lemma zdiv_int: "int (a div b) = (int a) div (int b)"
@@ -1390,7 +1228,7 @@
text{*Suggested by Matthias Daum*}
lemma int_power_div_base:
"\<lbrakk>0 < m; 0 < k\<rbrakk> \<Longrightarrow> k ^ m div k = (k::int) ^ (m - Suc 0)"
-apply (subgoal_tac "k ^ m = k ^ ((m - 1) + 1)")
+apply (subgoal_tac "k ^ m = k ^ ((m - Suc 0) + Suc 0)")
apply (erule ssubst)
apply (simp only: power_add)
apply simp_all
@@ -1407,10 +1245,10 @@
by (rule mod_diff_right_eq [symmetric])
lemmas zmod_simps =
- IntDiv.zmod_zadd_left_eq [symmetric]
- IntDiv.zmod_zadd_right_eq [symmetric]
+ mod_add_left_eq [symmetric]
+ mod_add_right_eq [symmetric]
IntDiv.zmod_zmult1_eq [symmetric]
- IntDiv.zmod_zmult1_eq' [symmetric]
+ mod_mult_left_eq [symmetric]
IntDiv.zpower_zmod
zminus_zmod zdiff_zmod_left zdiff_zmod_right
@@ -1483,14 +1321,14 @@
assume H: "x mod n = y mod n"
hence "x mod n - y mod n = 0" by simp
hence "(x mod n - y mod n) mod n = 0" by simp
- hence "(x - y) mod n = 0" by (simp add: zmod_zdiff1_eq[symmetric])
- thus "n dvd x - y" by (simp add: zdvd_iff_zmod_eq_0)
+ hence "(x - y) mod n = 0" by (simp add: mod_diff_eq[symmetric])
+ thus "n dvd x - y" by (simp add: dvd_eq_mod_eq_0)
next
assume H: "n dvd x - y"
then obtain k where k: "x-y = n*k" unfolding dvd_def by blast
hence "x = n*k + y" by simp
hence "x mod n = (n*k + y) mod n" by simp
- thus "x mod n = y mod n" by (simp add: zmod_zadd_left_eq)
+ thus "x mod n = y mod n" by (simp add: mod_add_left_eq)
qed
lemma nat_mod_eq_lemma: assumes xyn: "(x::nat) mod n = y mod n" and xy:"y \<le> x"
@@ -1523,6 +1361,40 @@
thus ?lhs by simp
qed
+
+subsection {* Code generation *}
+
+definition pdivmod :: "int \<Rightarrow> int \<Rightarrow> int \<times> int" where
+ "pdivmod k l = (\<bar>k\<bar> div \<bar>l\<bar>, \<bar>k\<bar> mod \<bar>l\<bar>)"
+
+lemma pdivmod_posDivAlg [code]:
+ "pdivmod k l = (if l = 0 then (0, \<bar>k\<bar>) else posDivAlg \<bar>k\<bar> \<bar>l\<bar>)"
+by (subst posDivAlg_div_mod) (simp_all add: pdivmod_def)
+
+lemma divmod_pdivmod: "divmod k l = (if k = 0 then (0, 0) else if l = 0 then (0, k) else
+ apsnd ((op *) (sgn l)) (if 0 < l \<and> 0 \<le> k \<or> l < 0 \<and> k < 0
+ then pdivmod k l
+ else (let (r, s) = pdivmod k l in
+ if s = 0 then (- r, 0) else (- r - 1, \<bar>l\<bar> - s))))"
+proof -
+ have aux: "\<And>q::int. - k = l * q \<longleftrightarrow> k = l * - q" by auto
+ show ?thesis
+ by (simp add: divmod_mod_div pdivmod_def)
+ (auto simp add: aux not_less not_le zdiv_zminus1_eq_if
+ zmod_zminus1_eq_if zdiv_zminus2_eq_if zmod_zminus2_eq_if)
+qed
+
+lemma divmod_code [code]: "divmod k l = (if k = 0 then (0, 0) else if l = 0 then (0, k) else
+ apsnd ((op *) (sgn l)) (if sgn k = sgn l
+ then pdivmod k l
+ else (let (r, s) = pdivmod k l in
+ if s = 0 then (- r, 0) else (- r - 1, \<bar>l\<bar> - s))))"
+proof -
+ have "k \<noteq> 0 \<Longrightarrow> l \<noteq> 0 \<Longrightarrow> 0 < l \<and> 0 \<le> k \<or> l < 0 \<and> k < 0 \<longleftrightarrow> sgn k = sgn l"
+ by (auto simp add: not_less sgn_if)
+ then show ?thesis by (simp add: divmod_pdivmod)
+qed
+
code_modulename SML
IntDiv Integer
--- a/src/HOL/Integration.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Integration.thy Thu Feb 26 11:21:29 2009 +0000
@@ -134,7 +134,7 @@
apply (frule partition [THEN iffD1], safe)
apply (drule_tac x = "psize D" and P="%n. psize D \<le> n --> ?P n" in spec, safe)
apply (case_tac "psize D = 0")
-apply (drule_tac [2] n = "psize D - 1" in partition_lt, auto)
+apply (drule_tac [2] n = "psize D - Suc 0" in partition_lt, auto)
done
lemma partition_gt: "[|partition(a,b) D; n < (psize D)|] ==> D(n) < D(psize D)"
@@ -145,7 +145,7 @@
apply (rotate_tac 2)
apply (drule_tac x = "psize D" in spec)
apply (rule ccontr)
-apply (drule_tac n = "psize D - 1" in partition_lt)
+apply (drule_tac n = "psize D - Suc 0" in partition_lt)
apply auto
done
--- a/src/HOL/IsaMakefile Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/IsaMakefile Thu Feb 26 11:21:29 2009 +0000
@@ -86,7 +86,7 @@
Tools/simpdata.ML \
$(SRC)/Tools/atomize_elim.ML \
$(SRC)/Tools/code/code_funcgr.ML \
- $(SRC)/Tools/code/code_funcgr.ML \
+ $(SRC)/Tools/code/code_wellsorted.ML \
$(SRC)/Tools/code/code_name.ML \
$(SRC)/Tools/code/code_printer.ML \
$(SRC)/Tools/code/code_target.ML \
@@ -267,11 +267,11 @@
@$(ISABELLE_TOOL) usedir -b -f main.ML -g true $(OUT)/Pure HOL-Main
$(OUT)/HOL: ROOT.ML $(MAIN_DEPENDENCIES) \
+ Archimedean_Field.thy \
Complex_Main.thy \
Complex.thy \
Deriv.thy \
Fact.thy \
- FrechetDeriv.thy \
Integration.thy \
Lim.thy \
Ln.thy \
@@ -285,7 +285,6 @@
GCD.thy \
Parity.thy \
Lubs.thy \
- Polynomial.thy \
PReal.thy \
Rational.thy \
RComplete.thy \
@@ -314,8 +313,11 @@
Library/Euclidean_Space.thy Library/Glbs.thy Library/normarith.ML \
Library/Executable_Set.thy Library/Infinite_Set.thy \
Library/FuncSet.thy Library/Permutations.thy Library/Determinants.thy\
+ Library/Bit.thy \
Library/Finite_Cartesian_Product.thy \
+ Library/FrechetDeriv.thy \
Library/Fundamental_Theorem_Algebra.thy \
+ Library/Inner_Product.thy \
Library/Library.thy Library/List_Prefix.thy Library/State_Monad.thy \
Library/Nat_Int_Bij.thy Library/Multiset.thy Library/Permutation.thy \
Library/Primes.thy Library/Pocklington.thy Library/Quotient.thy \
@@ -336,6 +338,10 @@
Library/Boolean_Algebra.thy Library/Countable.thy \
Library/RBT.thy Library/Univ_Poly.thy \
Library/Random.thy Library/Quickcheck.thy \
+ Library/Poly_Deriv.thy \
+ Library/Polynomial.thy \
+ Library/Product_plus.thy \
+ Library/Product_Vector.thy \
Library/Enum.thy Library/Float.thy $(SRC)/Tools/float.ML $(SRC)/HOL/Tools/float_arith.ML \
Library/reify_data.ML Library/reflection.ML
@cd Library; $(ISABELLE_TOOL) usedir $(OUT)/HOL Library
--- a/src/HOL/Library/Abstract_Rat.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Library/Abstract_Rat.thy Thu Feb 26 11:21:29 2009 +0000
@@ -247,7 +247,7 @@
(of_int(n div d)::'a::{field, ring_char_0}) = of_int n / of_int d"
apply (frule of_int_div_aux [of d n, where ?'a = 'a])
apply simp
- apply (simp add: zdvd_iff_zmod_eq_0)
+ apply (simp add: dvd_eq_mod_eq_0)
done
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Library/Bit.thy Thu Feb 26 11:21:29 2009 +0000
@@ -0,0 +1,128 @@
+(* Title: Bit.thy
+ Author: Brian Huffman
+*)
+
+header {* The Field of Integers mod 2 *}
+
+theory Bit
+imports Main
+begin
+
+subsection {* Bits as a datatype *}
+
+typedef (open) bit = "UNIV :: bool set" ..
+
+instantiation bit :: "{zero, one}"
+begin
+
+definition zero_bit_def:
+ "0 = Abs_bit False"
+
+definition one_bit_def:
+ "1 = Abs_bit True"
+
+instance ..
+
+end
+
+rep_datatype (bit) "0::bit" "1::bit"
+proof -
+ fix P and x :: bit
+ assume "P (0::bit)" and "P (1::bit)"
+ then have "\<forall>b. P (Abs_bit b)"
+ unfolding zero_bit_def one_bit_def
+ by (simp add: all_bool_eq)
+ then show "P x"
+ by (induct x) simp
+next
+ show "(0::bit) \<noteq> (1::bit)"
+ unfolding zero_bit_def one_bit_def
+ by (simp add: Abs_bit_inject)
+qed
+
+lemma bit_not_0_iff [iff]: "(x::bit) \<noteq> 0 \<longleftrightarrow> x = 1"
+ by (induct x) simp_all
+
+lemma bit_not_1_iff [iff]: "(x::bit) \<noteq> 1 \<longleftrightarrow> x = 0"
+ by (induct x) simp_all
+
+
+subsection {* Type @{typ bit} forms a field *}
+
+instantiation bit :: "{field, division_by_zero}"
+begin
+
+definition plus_bit_def:
+ "x + y = (case x of 0 \<Rightarrow> y | 1 \<Rightarrow> (case y of 0 \<Rightarrow> 1 | 1 \<Rightarrow> 0))"
+
+definition times_bit_def:
+ "x * y = (case x of 0 \<Rightarrow> 0 | 1 \<Rightarrow> y)"
+
+definition uminus_bit_def [simp]:
+ "- x = (x :: bit)"
+
+definition minus_bit_def [simp]:
+ "x - y = (x + y :: bit)"
+
+definition inverse_bit_def [simp]:
+ "inverse x = (x :: bit)"
+
+definition divide_bit_def [simp]:
+ "x / y = (x * y :: bit)"
+
+lemmas field_bit_defs =
+ plus_bit_def times_bit_def minus_bit_def uminus_bit_def
+ divide_bit_def inverse_bit_def
+
+instance proof
+qed (unfold field_bit_defs, auto split: bit.split)
+
+end
+
+lemma bit_1_plus_1 [simp]: "1 + 1 = (0 :: bit)"
+ unfolding plus_bit_def by simp
+
+lemma bit_add_self [simp]: "x + x = (0 :: bit)"
+ by (cases x) simp_all
+
+lemma bit_add_self_left [simp]: "x + (x + y) = (y :: bit)"
+ by simp
+
+lemma bit_mult_eq_1_iff [simp]: "x * y = (1 :: bit) \<longleftrightarrow> x = 1 \<and> y = 1"
+ unfolding times_bit_def by (simp split: bit.split)
+
+text {* Not sure whether the next two should be simp rules. *}
+
+lemma bit_add_eq_0_iff: "x + y = (0 :: bit) \<longleftrightarrow> x = y"
+ unfolding plus_bit_def by (simp split: bit.split)
+
+lemma bit_add_eq_1_iff: "x + y = (1 :: bit) \<longleftrightarrow> x \<noteq> y"
+ unfolding plus_bit_def by (simp split: bit.split)
+
+
+subsection {* Numerals at type @{typ bit} *}
+
+instantiation bit :: number_ring
+begin
+
+definition number_of_bit_def:
+ "(number_of w :: bit) = of_int w"
+
+instance proof
+qed (rule number_of_bit_def)
+
+end
+
+text {* All numerals reduce to either 0 or 1. *}
+
+lemma bit_minus1 [simp]: "-1 = (1 :: bit)"
+ by (simp only: number_of_Min uminus_bit_def)
+
+lemma bit_number_of_even [simp]: "number_of (Int.Bit0 w) = (0 :: bit)"
+ by (simp only: number_of_Bit0 add_0_left bit_add_self)
+
+lemma bit_number_of_odd [simp]: "number_of (Int.Bit1 w) = (1 :: bit)"
+ by (simp only: number_of_Bit1 add_assoc bit_add_self
+ monoid_add_class.add_0_right)
+
+end
--- a/src/HOL/Library/Boolean_Algebra.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Library/Boolean_Algebra.thy Thu Feb 26 11:21:29 2009 +0000
@@ -223,7 +223,7 @@
lemma xor_left_self [simp]: "x \<oplus> (x \<oplus> y) = y"
by (simp only: xor_assoc [symmetric] xor_self xor_zero_left)
-lemma xor_compl_left: "\<sim> x \<oplus> y = \<sim> (x \<oplus> y)"
+lemma xor_compl_left [simp]: "\<sim> x \<oplus> y = \<sim> (x \<oplus> y)"
apply (simp only: xor_def de_Morgan_disj de_Morgan_conj double_compl)
apply (simp only: conj_disj_distribs)
apply (simp only: conj_cancel_right conj_cancel_left)
@@ -231,7 +231,7 @@
apply (simp only: disj_ac conj_ac)
done
-lemma xor_compl_right: "x \<oplus> \<sim> y = \<sim> (x \<oplus> y)"
+lemma xor_compl_right [simp]: "x \<oplus> \<sim> y = \<sim> (x \<oplus> y)"
apply (simp only: xor_def de_Morgan_disj de_Morgan_conj double_compl)
apply (simp only: conj_disj_distribs)
apply (simp only: conj_cancel_right conj_cancel_left)
@@ -239,11 +239,11 @@
apply (simp only: disj_ac conj_ac)
done
-lemma xor_cancel_right [simp]: "x \<oplus> \<sim> x = \<one>"
+lemma xor_cancel_right: "x \<oplus> \<sim> x = \<one>"
by (simp only: xor_compl_right xor_self compl_zero)
-lemma xor_cancel_left [simp]: "\<sim> x \<oplus> x = \<one>"
-by (subst xor_commute) (rule xor_cancel_right)
+lemma xor_cancel_left: "\<sim> x \<oplus> x = \<one>"
+by (simp only: xor_compl_left xor_self compl_zero)
lemma conj_xor_distrib: "x \<sqinter> (y \<oplus> z) = (x \<sqinter> y) \<oplus> (x \<sqinter> z)"
proof -
--- a/src/HOL/Library/Code_Char.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Library/Code_Char.thy Thu Feb 26 11:21:29 2009 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/Library/Code_Char.thy
- ID: $Id$
Author: Florian Haftmann
*)
--- a/src/HOL/Library/Code_Integer.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Library/Code_Integer.thy Thu Feb 26 11:21:29 2009 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/Library/Code_Integer.thy
- ID: $Id$
Author: Florian Haftmann, TU Muenchen
*)
@@ -72,6 +71,11 @@
(OCaml "Big'_int.mult'_big'_int")
(Haskell infixl 7 "*")
+code_const pdivmod
+ (SML "(fn k => fn l =>/ IntInf.divMod/ (IntInf.abs k,/ IntInf.abs l))")
+ (OCaml "(fun k -> fun l ->/ Big'_int.quomod'_big'_int/ (Big'_int.abs'_big'_int k)/ (Big'_int.abs'_big'_int l))")
+ (Haskell "(\\k l ->/ divMod/ (abs k)/ (abs l))")
+
code_const "eq_class.eq \<Colon> int \<Rightarrow> int \<Rightarrow> bool"
(SML "!((_ : IntInf.int) = _)")
(OCaml "Big'_int.eq'_big'_int")
--- a/src/HOL/Library/Determinants.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Library/Determinants.thy Thu Feb 26 11:21:29 2009 +0000
@@ -1048,7 +1048,7 @@
note th0 = this
let ?g = "\<lambda>x. if x = 0 then 0 else norm x *s f (inverse (norm x) *s x)"
{fix x:: "real ^'n" assume nx: "norm x = 1"
- have "?g x = f x" using nx by (simp add: norm_eq_0[symmetric])}
+ have "?g x = f x" using nx by auto}
hence thfg: "\<forall>x. norm x = 1 \<longrightarrow> ?g x = f x" by blast
have g0: "?g 0 = 0" by simp
{fix x y :: "real ^'n"
@@ -1057,15 +1057,15 @@
moreover
{assume "x = 0" "y \<noteq> 0"
then have "dist (?g x) (?g y) = dist x y"
- apply (simp add: dist_def norm_neg norm_mul norm_eq_0)
+ apply (simp add: dist_def norm_mul)
apply (rule f1[rule_format])
- by(simp add: norm_mul norm_eq_0 field_simps)}
+ by(simp add: norm_mul field_simps)}
moreover
{assume "x \<noteq> 0" "y = 0"
then have "dist (?g x) (?g y) = dist x y"
- apply (simp add: dist_def norm_neg norm_mul norm_eq_0)
+ apply (simp add: dist_def norm_mul)
apply (rule f1[rule_format])
- by(simp add: norm_mul norm_eq_0 field_simps)}
+ by(simp add: norm_mul field_simps)}
moreover
{assume z: "x \<noteq> 0" "y \<noteq> 0"
have th00: "x = norm x *s inverse (norm x) *s x" "y = norm y *s inverse (norm y) *s y" "norm x *s f (inverse (norm x) *s x) = norm x *s f (inverse (norm x) *s x)"
@@ -1077,7 +1077,7 @@
"norm (f (inverse (norm x) *s x) - f (inverse (norm y) *s y)) =
norm (inverse (norm x) *s x - inverse (norm y) *s y)"
using z
- by (auto simp add: norm_eq_0 vector_smult_assoc field_simps norm_mul intro: f1[rule_format] fd1[rule_format, unfolded dist_def])
+ by (auto simp add: vector_smult_assoc field_simps norm_mul intro: f1[rule_format] fd1[rule_format, unfolded dist_def])
from z th0[OF th00] have "dist (?g x) (?g y) = dist x y"
by (simp add: dist_def)}
ultimately have "dist (?g x) (?g y) = dist x y" by blast}
@@ -1148,4 +1148,4 @@
by (simp add: ring_simps)
qed
-end
\ No newline at end of file
+end
--- a/src/HOL/Library/Efficient_Nat.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Library/Efficient_Nat.thy Thu Feb 26 11:21:29 2009 +0000
@@ -105,10 +105,16 @@
This can be accomplished by applying the following transformation rules:
*}
-lemma Suc_if_eq: "(\<And>n. f (Suc n) = h n) \<Longrightarrow> f 0 = g \<Longrightarrow>
+lemma Suc_if_eq': "(\<And>n. f (Suc n) = h n) \<Longrightarrow> f 0 = g \<Longrightarrow>
f n = (if n = 0 then g else h (n - 1))"
by (cases n) simp_all
+lemma Suc_if_eq: "(\<And>n. f (Suc n) \<equiv> h n) \<Longrightarrow> f 0 \<equiv> g \<Longrightarrow>
+ f n \<equiv> if n = 0 then g else h (n - 1)"
+ by (rule eq_reflection, rule Suc_if_eq')
+ (rule meta_eq_to_obj_eq, assumption,
+ rule meta_eq_to_obj_eq, assumption)
+
lemma Suc_clause: "(\<And>n. P n (Suc n)) \<Longrightarrow> n \<noteq> 0 \<Longrightarrow> P (n - 1) n"
by (cases n) simp_all
@@ -123,14 +129,14 @@
setup {*
let
-fun remove_suc thy thms =
+fun gen_remove_suc Suc_if_eq dest_judgement thy thms =
let
val vname = Name.variant (map fst
- (fold (Term.add_var_names o Thm.full_prop_of) thms [])) "x";
+ (fold (Term.add_var_names o Thm.full_prop_of) thms [])) "n";
val cv = cterm_of thy (Var ((vname, 0), HOLogic.natT));
fun lhs_of th = snd (Thm.dest_comb
- (fst (Thm.dest_comb (snd (Thm.dest_comb (cprop_of th))))));
- fun rhs_of th = snd (Thm.dest_comb (snd (Thm.dest_comb (cprop_of th))));
+ (fst (Thm.dest_comb (dest_judgement (cprop_of th)))));
+ fun rhs_of th = snd (Thm.dest_comb (dest_judgement (cprop_of th)));
fun find_vars ct = (case term_of ct of
(Const (@{const_name Suc}, _) $ Var _) => [(cv, snd (Thm.dest_comb ct))]
| _ $ _ =>
@@ -150,7 +156,7 @@
(Drule.instantiate'
[SOME (ctyp_of_term ct)] [SOME (Thm.cabs cv ct),
SOME (Thm.cabs cv' (rhs_of th)), NONE, SOME cv']
- @{thm Suc_if_eq})) (Thm.forall_intr cv' th)
+ Suc_if_eq)) (Thm.forall_intr cv' th)
in
case map_filter (fn th'' =>
SOME (th'', singleton
@@ -161,20 +167,26 @@
let val (ths1, ths2) = split_list thps
in SOME (subtract Thm.eq_thm (th :: ths1) thms @ ths2) end
end
- in case get_first mk_thms eqs of
- NONE => thms
- | SOME x => remove_suc thy x
+ in get_first mk_thms eqs end;
+
+fun gen_eqn_suc_preproc Suc_if_eq dest_judgement dest_lhs thy thms =
+ let
+ val dest = dest_lhs o prop_of;
+ val contains_suc = exists_Const (fn (c, _) => c = @{const_name Suc});
+ in
+ if forall (can dest) thms andalso exists (contains_suc o dest) thms
+ then perhaps_loop (gen_remove_suc Suc_if_eq dest_judgement thy) thms
+ else NONE
end;
-fun eqn_suc_preproc thy ths =
- let
- val dest = fst o HOLogic.dest_eq o HOLogic.dest_Trueprop o prop_of;
- val contains_suc = exists_Const (fn (c, _) => c = @{const_name Suc});
- in
- if forall (can dest) ths andalso
- exists (contains_suc o dest) ths
- then remove_suc thy ths else ths
- end;
+fun eqn_suc_preproc thy = map fst
+ #> gen_eqn_suc_preproc
+ @{thm Suc_if_eq} I (fst o Logic.dest_equals) thy
+ #> (Option.map o map) (Code_Unit.mk_eqn thy);
+
+fun eqn_suc_preproc' thy thms = gen_eqn_suc_preproc
+ @{thm Suc_if_eq'} (snd o Thm.dest_comb) (fst o HOLogic.dest_eq o HOLogic.dest_Trueprop) thy thms
+ |> the_default thms;
fun remove_suc_clause thy thms =
let
@@ -215,27 +227,11 @@
(map_filter (try dest) (concl_of th :: prems_of th))) ths
then remove_suc_clause thy ths else ths
end;
-
-fun lift f thy eqns1 =
- let
- val eqns2 = burrow_fst Drule.zero_var_indexes_list eqns1;
- val thms3 = try (map fst
- #> map (fn thm => thm RS @{thm meta_eq_to_obj_eq})
- #> f thy
- #> map (fn thm => thm RS @{thm eq_reflection})
- #> map (Conv.fconv_rule Drule.beta_eta_conversion)) eqns2;
- val thms4 = Option.map Drule.zero_var_indexes_list thms3;
- in case thms4
- of NONE => NONE
- | SOME thms4 => if Thm.eq_thms (map fst eqns2, thms4)
- then NONE else SOME (map (apfst (AxClass.overload thy) o Code_Unit.mk_eqn thy) thms4)
- end
-
in
- Codegen.add_preprocessor eqn_suc_preproc
+ Codegen.add_preprocessor eqn_suc_preproc'
#> Codegen.add_preprocessor clause_suc_preproc
- #> Code.add_functrans ("eqn_Suc", lift eqn_suc_preproc)
+ #> Code.add_functrans ("eqn_Suc", eqn_suc_preproc)
end;
*}
--- a/src/HOL/Library/Enum.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Library/Enum.thy Thu Feb 26 11:21:29 2009 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/Library/Enum.thy
- ID: $Id$
Author: Florian Haftmann, TU Muenchen
*)
--- a/src/HOL/Library/Euclidean_Space.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Library/Euclidean_Space.thy Thu Feb 26 11:21:29 2009 +0000
@@ -8,6 +8,7 @@
theory Euclidean_Space
imports "~~/src/HOL/Decision_Procs/Dense_Linear_Order" Complex_Main
Finite_Cartesian_Product Glbs Infinite_Set Numeral_Type
+ Inner_Product
uses ("normarith.ML")
begin
@@ -84,7 +85,13 @@
instance by (intro_classes)
end
-text{* Also the scalar-vector multiplication. FIXME: We should unify this with the scalar multiplication in @{text real_vector} *}
+instantiation "^" :: (scaleR, type) scaleR
+begin
+definition vector_scaleR_def: "scaleR = (\<lambda> r x. (\<chi> i. scaleR r (x$i)))"
+instance ..
+end
+
+text{* Also the scalar-vector multiplication. *}
definition vector_scalar_mult:: "'a::times \<Rightarrow> 'a ^'n \<Rightarrow> 'a ^ 'n" (infixr "*s" 75)
where "c *s x = (\<chi> i. c * (x$i))"
@@ -118,6 +125,7 @@
[@{thm vector_add_def}, @{thm vector_mult_def},
@{thm vector_minus_def}, @{thm vector_uminus_def},
@{thm vector_one_def}, @{thm vector_zero_def}, @{thm vec_def},
+ @{thm vector_scaleR_def},
@{thm Cart_lambda_beta'}, @{thm vector_scalar_mult_def}]
fun vector_arith_tac ths =
simp_tac ss1
@@ -166,9 +174,18 @@
shows "(- x)$i = - (x$i)"
using i by vector
+lemma vector_scaleR_component:
+ fixes x :: "'a::scaleR ^ 'n"
+ assumes i: "i \<in> {1 .. dimindex(UNIV :: 'n set)}"
+ shows "(scaleR r x)$i = scaleR r (x$i)"
+ using i by vector
+
lemma cond_component: "(if b then x else y)$i = (if b then x$i else y$i)" by vector
-lemmas vector_component = vec_component vector_add_component vector_mult_component vector_smult_component vector_minus_component vector_uminus_component cond_component
+lemmas vector_component =
+ vec_component vector_add_component vector_mult_component
+ vector_smult_component vector_minus_component vector_uminus_component
+ vector_scaleR_component cond_component
subsection {* Some frequently useful arithmetic lemmas over vectors. *}
@@ -199,6 +216,9 @@
apply (intro_classes)
by (vector Cart_eq)
+instance "^" :: (real_vector, type) real_vector
+ by default (vector scaleR_left_distrib scaleR_right_distrib)+
+
instance "^" :: (semigroup_mult,type) semigroup_mult
apply (intro_classes) by (vector mult_assoc)
@@ -242,6 +262,18 @@
instance "^" :: (ring,type) ring by (intro_classes)
instance "^" :: (semiring_1_cancel,type) semiring_1_cancel by (intro_classes)
instance "^" :: (comm_semiring_1,type) comm_semiring_1 by (intro_classes)
+
+instance "^" :: (ring_1,type) ring_1 ..
+
+instance "^" :: (real_algebra,type) real_algebra
+ apply intro_classes
+ apply (simp_all add: vector_scaleR_def ring_simps)
+ apply vector
+ apply vector
+ done
+
+instance "^" :: (real_algebra_1,type) real_algebra_1 ..
+
lemma of_nat_index:
"i\<in>{1 .. dimindex (UNIV :: 'n set)} \<Longrightarrow> (of_nat n :: 'a::semiring_1 ^'n)$i = of_nat n"
apply (induct n)
@@ -290,8 +322,7 @@
qed
instance "^" :: (comm_ring_1,type) comm_ring_1 by intro_classes
- (* FIXME!!! Why does the axclass package complain here !!*)
-(* instance "^" :: (ring_char_0,type) ring_char_0 by intro_classes *)
+instance "^" :: (ring_char_0,type) ring_char_0 by intro_classes
lemma vector_smult_assoc: "a *s (b *s x) = ((a::'a::semigroup_mult) * b) *s x"
by (vector mult_assoc)
@@ -314,6 +345,241 @@
apply (auto simp add: vec_def Cart_eq vec_component Cart_lambda_beta )
using dimindex_ge_1 apply auto done
+subsection {* Square root of sum of squares *}
+
+definition
+ "setL2 f A = sqrt (\<Sum>i\<in>A. (f i)\<twosuperior>)"
+
+lemma setL2_cong:
+ "\<lbrakk>A = B; \<And>x. x \<in> B \<Longrightarrow> f x = g x\<rbrakk> \<Longrightarrow> setL2 f A = setL2 g B"
+ unfolding setL2_def by simp
+
+lemma strong_setL2_cong:
+ "\<lbrakk>A = B; \<And>x. x \<in> B =simp=> f x = g x\<rbrakk> \<Longrightarrow> setL2 f A = setL2 g B"
+ unfolding setL2_def simp_implies_def by simp
+
+lemma setL2_infinite [simp]: "\<not> finite A \<Longrightarrow> setL2 f A = 0"
+ unfolding setL2_def by simp
+
+lemma setL2_empty [simp]: "setL2 f {} = 0"
+ unfolding setL2_def by simp
+
+lemma setL2_insert [simp]:
+ "\<lbrakk>finite F; a \<notin> F\<rbrakk> \<Longrightarrow>
+ setL2 f (insert a F) = sqrt ((f a)\<twosuperior> + (setL2 f F)\<twosuperior>)"
+ unfolding setL2_def by (simp add: setsum_nonneg)
+
+lemma setL2_nonneg [simp]: "0 \<le> setL2 f A"
+ unfolding setL2_def by (simp add: setsum_nonneg)
+
+lemma setL2_0': "\<forall>a\<in>A. f a = 0 \<Longrightarrow> setL2 f A = 0"
+ unfolding setL2_def by simp
+
+lemma setL2_mono:
+ assumes "\<And>i. i \<in> K \<Longrightarrow> f i \<le> g i"
+ assumes "\<And>i. i \<in> K \<Longrightarrow> 0 \<le> f i"
+ shows "setL2 f K \<le> setL2 g K"
+ unfolding setL2_def
+ by (simp add: setsum_nonneg setsum_mono power_mono prems)
+
+lemma setL2_right_distrib:
+ "0 \<le> r \<Longrightarrow> r * setL2 f A = setL2 (\<lambda>x. r * f x) A"
+ unfolding setL2_def
+ apply (simp add: power_mult_distrib)
+ apply (simp add: setsum_right_distrib [symmetric])
+ apply (simp add: real_sqrt_mult setsum_nonneg)
+ done
+
+lemma setL2_left_distrib:
+ "0 \<le> r \<Longrightarrow> setL2 f A * r = setL2 (\<lambda>x. f x * r) A"
+ unfolding setL2_def
+ apply (simp add: power_mult_distrib)
+ apply (simp add: setsum_left_distrib [symmetric])
+ apply (simp add: real_sqrt_mult setsum_nonneg)
+ done
+
+lemma setsum_nonneg_eq_0_iff:
+ fixes f :: "'a \<Rightarrow> 'b::pordered_ab_group_add"
+ shows "\<lbrakk>finite A; \<forall>x\<in>A. 0 \<le> f x\<rbrakk> \<Longrightarrow> setsum f A = 0 \<longleftrightarrow> (\<forall>x\<in>A. f x = 0)"
+ apply (induct set: finite, simp)
+ apply (simp add: add_nonneg_eq_0_iff setsum_nonneg)
+ done
+
+lemma setL2_eq_0_iff: "finite A \<Longrightarrow> setL2 f A = 0 \<longleftrightarrow> (\<forall>x\<in>A. f x = 0)"
+ unfolding setL2_def
+ by (simp add: setsum_nonneg setsum_nonneg_eq_0_iff)
+
+lemma setL2_triangle_ineq:
+ shows "setL2 (\<lambda>i. f i + g i) A \<le> setL2 f A + setL2 g A"
+proof (cases "finite A")
+ case False
+ thus ?thesis by simp
+next
+ case True
+ thus ?thesis
+ proof (induct set: finite)
+ case empty
+ show ?case by simp
+ next
+ case (insert x F)
+ hence "sqrt ((f x + g x)\<twosuperior> + (setL2 (\<lambda>i. f i + g i) F)\<twosuperior>) \<le>
+ sqrt ((f x + g x)\<twosuperior> + (setL2 f F + setL2 g F)\<twosuperior>)"
+ by (intro real_sqrt_le_mono add_left_mono power_mono insert
+ setL2_nonneg add_increasing zero_le_power2)
+ also have
+ "\<dots> \<le> sqrt ((f x)\<twosuperior> + (setL2 f F)\<twosuperior>) + sqrt ((g x)\<twosuperior> + (setL2 g F)\<twosuperior>)"
+ by (rule real_sqrt_sum_squares_triangle_ineq)
+ finally show ?case
+ using insert by simp
+ qed
+qed
+
+lemma sqrt_sum_squares_le_sum:
+ "\<lbrakk>0 \<le> x; 0 \<le> y\<rbrakk> \<Longrightarrow> sqrt (x\<twosuperior> + y\<twosuperior>) \<le> x + y"
+ apply (rule power2_le_imp_le)
+ apply (simp add: power2_sum)
+ apply (simp add: mult_nonneg_nonneg)
+ apply (simp add: add_nonneg_nonneg)
+ done
+
+lemma setL2_le_setsum [rule_format]:
+ "(\<forall>i\<in>A. 0 \<le> f i) \<longrightarrow> setL2 f A \<le> setsum f A"
+ apply (cases "finite A")
+ apply (induct set: finite)
+ apply simp
+ apply clarsimp
+ apply (erule order_trans [OF sqrt_sum_squares_le_sum])
+ apply simp
+ apply simp
+ apply simp
+ done
+
+lemma sqrt_sum_squares_le_sum_abs: "sqrt (x\<twosuperior> + y\<twosuperior>) \<le> \<bar>x\<bar> + \<bar>y\<bar>"
+ apply (rule power2_le_imp_le)
+ apply (simp add: power2_sum)
+ apply (simp add: mult_nonneg_nonneg)
+ apply (simp add: add_nonneg_nonneg)
+ done
+
+lemma setL2_le_setsum_abs: "setL2 f A \<le> (\<Sum>i\<in>A. \<bar>f i\<bar>)"
+ apply (cases "finite A")
+ apply (induct set: finite)
+ apply simp
+ apply simp
+ apply (rule order_trans [OF sqrt_sum_squares_le_sum_abs])
+ apply simp
+ apply simp
+ done
+
+lemma setL2_mult_ineq_lemma:
+ fixes a b c d :: real
+ shows "2 * (a * c) * (b * d) \<le> a\<twosuperior> * d\<twosuperior> + b\<twosuperior> * c\<twosuperior>"
+proof -
+ have "0 \<le> (a * d - b * c)\<twosuperior>" by simp
+ also have "\<dots> = a\<twosuperior> * d\<twosuperior> + b\<twosuperior> * c\<twosuperior> - 2 * (a * d) * (b * c)"
+ by (simp only: power2_diff power_mult_distrib)
+ also have "\<dots> = a\<twosuperior> * d\<twosuperior> + b\<twosuperior> * c\<twosuperior> - 2 * (a * c) * (b * d)"
+ by simp
+ finally show "2 * (a * c) * (b * d) \<le> a\<twosuperior> * d\<twosuperior> + b\<twosuperior> * c\<twosuperior>"
+ by simp
+qed
+
+lemma setL2_mult_ineq: "(\<Sum>i\<in>A. \<bar>f i\<bar> * \<bar>g i\<bar>) \<le> setL2 f A * setL2 g A"
+ apply (cases "finite A")
+ apply (induct set: finite)
+ apply simp
+ apply (rule power2_le_imp_le, simp)
+ apply (rule order_trans)
+ apply (rule power_mono)
+ apply (erule add_left_mono)
+ apply (simp add: add_nonneg_nonneg mult_nonneg_nonneg setsum_nonneg)
+ apply (simp add: power2_sum)
+ apply (simp add: power_mult_distrib)
+ apply (simp add: right_distrib left_distrib)
+ apply (rule ord_le_eq_trans)
+ apply (rule setL2_mult_ineq_lemma)
+ apply simp
+ apply (intro mult_nonneg_nonneg setL2_nonneg)
+ apply simp
+ done
+
+lemma member_le_setL2: "\<lbrakk>finite A; i \<in> A\<rbrakk> \<Longrightarrow> f i \<le> setL2 f A"
+ apply (rule_tac s="insert i (A - {i})" and t="A" in subst)
+ apply fast
+ apply (subst setL2_insert)
+ apply simp
+ apply simp
+ apply simp
+ done
+
+subsection {* Norms *}
+
+instantiation "^" :: (real_normed_vector, type) real_normed_vector
+begin
+
+definition vector_norm_def:
+ "norm (x::'a^'b) = setL2 (\<lambda>i. norm (x$i)) {1 .. dimindex (UNIV:: 'b set)}"
+
+definition vector_sgn_def:
+ "sgn (x::'a^'b) = scaleR (inverse (norm x)) x"
+
+instance proof
+ fix a :: real and x y :: "'a ^ 'b"
+ show "0 \<le> norm x"
+ unfolding vector_norm_def
+ by (rule setL2_nonneg)
+ show "norm x = 0 \<longleftrightarrow> x = 0"
+ unfolding vector_norm_def
+ by (simp add: setL2_eq_0_iff Cart_eq)
+ show "norm (x + y) \<le> norm x + norm y"
+ unfolding vector_norm_def
+ apply (rule order_trans [OF _ setL2_triangle_ineq])
+ apply (rule setL2_mono)
+ apply (simp add: vector_component norm_triangle_ineq)
+ apply simp
+ done
+ show "norm (scaleR a x) = \<bar>a\<bar> * norm x"
+ unfolding vector_norm_def
+ by (simp add: vector_component norm_scaleR setL2_right_distrib
+ cong: strong_setL2_cong)
+ show "sgn x = scaleR (inverse (norm x)) x"
+ by (rule vector_sgn_def)
+qed
+
+end
+
+subsection {* Inner products *}
+
+instantiation "^" :: (real_inner, type) real_inner
+begin
+
+definition vector_inner_def:
+ "inner x y = setsum (\<lambda>i. inner (x$i) (y$i)) {1 .. dimindex(UNIV::'b set)}"
+
+instance proof
+ fix r :: real and x y z :: "'a ^ 'b"
+ show "inner x y = inner y x"
+ unfolding vector_inner_def
+ by (simp add: inner_commute)
+ show "inner (x + y) z = inner x z + inner y z"
+ unfolding vector_inner_def
+ by (vector inner_left_distrib)
+ show "inner (scaleR r x) y = r * inner x y"
+ unfolding vector_inner_def
+ by (vector inner_scaleR_left)
+ show "0 \<le> inner x x"
+ unfolding vector_inner_def
+ by (simp add: setsum_nonneg)
+ show "inner x x = 0 \<longleftrightarrow> x = 0"
+ unfolding vector_inner_def
+ by (simp add: Cart_eq setsum_nonneg_eq_0_iff)
+ show "norm x = sqrt (inner x x)"
+ unfolding vector_inner_def vector_norm_def setL2_def
+ by (simp add: power2_norm_eq_inner)
+qed
+
+end
+
subsection{* Properties of the dot product. *}
lemma dot_sym: "(x::'a:: {comm_monoid_add, ab_semigroup_mult} ^ 'n) \<bullet> y = y \<bullet> x"
@@ -363,18 +629,7 @@
lemma dot_pos_lt: "(0 < x \<bullet> x) \<longleftrightarrow> (x::'a::{ordered_ring_strict,ring_no_zero_divisors} ^ 'n) \<noteq> 0" using dot_eq_0[of x] dot_pos_le[of x]
by (auto simp add: le_less)
-subsection {* Introduce norms, but defer many properties till we get square roots. *}
-text{* FIXME : This is ugly *}
-defs (overloaded)
- real_of_real_def [code inline, simp]: "real == id"
-
-instantiation "^" :: ("{times, comm_monoid_add}", type) norm begin
-definition real_vector_norm_def: "norm \<equiv> (\<lambda>x. sqrt (real (x \<bullet> x)))"
-instance ..
-end
-
-
-subsection{* The collapse of the general concepts to dimention one. *}
+subsection{* The collapse of the general concepts to dimension one. *}
lemma vector_one: "(x::'a ^1) = (\<chi> i. (x$1))"
by (vector dimindex_def)
@@ -385,11 +640,15 @@
apply (simp only: vector_one[symmetric])
done
+lemma norm_vector_1: "norm (x :: _^1) = norm (x$1)"
+ by (simp add: vector_norm_def dimindex_def)
+
lemma norm_real: "norm(x::real ^ 1) = abs(x$1)"
- by (simp add: real_vector_norm_def)
+ by (simp add: norm_vector_1)
text{* Metric *}
+text {* FIXME: generalize to arbitrary @{text real_normed_vector} types *}
definition dist:: "real ^ 'n \<Rightarrow> real ^ 'n \<Rightarrow> real" where
"dist x y = norm (x - y)"
@@ -501,27 +760,18 @@
text{* Hence derive more interesting properties of the norm. *}
lemma norm_0: "norm (0::real ^ 'n) = 0"
- by (simp add: real_vector_norm_def dot_eq_0)
-
-lemma norm_pos_le: "0 <= norm (x::real^'n)"
- by (simp add: real_vector_norm_def dot_pos_le)
-lemma norm_neg: " norm(-x) = norm (x:: real ^ 'n)"
- by (simp add: real_vector_norm_def dot_lneg dot_rneg)
-lemma norm_sub: "norm(x - y) = norm(y - (x::real ^ 'n))"
- by (metis norm_neg minus_diff_eq)
+ by (rule norm_zero)
+
lemma norm_mul: "norm(a *s x) = abs(a) * norm x"
- by (simp add: real_vector_norm_def dot_lmult dot_rmult mult_assoc[symmetric] real_sqrt_mult)
+ by (simp add: vector_norm_def vector_component setL2_right_distrib
+ abs_mult cong: strong_setL2_cong)
lemma norm_eq_0_dot: "(norm x = 0) \<longleftrightarrow> (x \<bullet> x = (0::real))"
+ by (simp add: vector_norm_def dot_def setL2_def power2_eq_square)
+lemma real_vector_norm_def: "norm x = sqrt (x \<bullet> x)"
+ by (simp add: vector_norm_def setL2_def dot_def power2_eq_square)
+lemma norm_pow_2: "norm x ^ 2 = x \<bullet> x"
by (simp add: real_vector_norm_def)
-lemma norm_eq_0: "norm x = 0 \<longleftrightarrow> x = (0::real ^ 'n)"
- by (simp add: real_vector_norm_def dot_eq_0)
-lemma norm_pos_lt: "0 < norm x \<longleftrightarrow> x \<noteq> (0::real ^ 'n)"
- by (metis less_le real_vector_norm_def norm_pos_le norm_eq_0)
-lemma norm_pow_2: "norm x ^ 2 = x \<bullet> x"
- by (simp add: real_vector_norm_def dot_pos_le)
-lemma norm_eq_0_imp: "norm x = 0 ==> x = (0::real ^'n)" by (metis norm_eq_0)
-lemma norm_le_0: "norm x <= 0 \<longleftrightarrow> x = (0::real ^'n)"
- by (metis norm_eq_0 norm_pos_le order_antisym)
+lemma norm_eq_0_imp: "norm x = 0 ==> x = (0::real ^'n)" by (metis norm_eq_zero)
lemma vector_mul_eq_0: "(a *s x = 0) \<longleftrightarrow> a = (0::'a::idom) \<or> x = 0"
by vector
lemma vector_mul_lcancel: "a *s x = a *s y \<longleftrightarrow> a = (0::real) \<or> x = y"
@@ -535,14 +785,14 @@
lemma norm_cauchy_schwarz: "x \<bullet> y <= norm x * norm y"
proof-
{assume "norm x = 0"
- hence ?thesis by (simp add: norm_eq_0 dot_lzero dot_rzero norm_0)}
+ hence ?thesis by (simp add: dot_lzero dot_rzero)}
moreover
{assume "norm y = 0"
- hence ?thesis by (simp add: norm_eq_0 dot_lzero dot_rzero norm_0)}
+ hence ?thesis by (simp add: dot_lzero dot_rzero)}
moreover
{assume h: "norm x \<noteq> 0" "norm y \<noteq> 0"
let ?z = "norm y *s x - norm x *s y"
- from h have p: "norm x * norm y > 0" by (metis norm_pos_le le_less zero_compare_simps)
+ from h have p: "norm x * norm y > 0" by (metis norm_ge_zero le_less zero_compare_simps)
from dot_pos_le[of ?z]
have "(norm x * norm y) * (x \<bullet> y) \<le> norm x ^2 * norm y ^2"
apply (simp add: dot_rsub dot_lsub dot_lmult dot_rmult ring_simps)
@@ -553,26 +803,16 @@
ultimately show ?thesis by metis
qed
-lemma norm_abs[simp]: "abs (norm x) = norm (x::real ^'n)"
- using norm_pos_le[of x] by (simp add: real_abs_def linorder_linear)
-
lemma norm_cauchy_schwarz_abs: "\<bar>x \<bullet> y\<bar> \<le> norm x * norm y"
using norm_cauchy_schwarz[of x y] norm_cauchy_schwarz[of x "-y"]
- by (simp add: real_abs_def dot_rneg norm_neg)
-lemma norm_triangle: "norm(x + y) <= norm x + norm (y::real ^'n)"
- unfolding real_vector_norm_def
- apply (rule real_le_lsqrt)
- apply (auto simp add: dot_pos_le real_vector_norm_def[symmetric] norm_pos_le norm_pow_2[symmetric] intro: add_nonneg_nonneg)[1]
- apply (auto simp add: dot_pos_le real_vector_norm_def[symmetric] norm_pos_le norm_pow_2[symmetric] intro: add_nonneg_nonneg)[1]
- apply (simp add: dot_ladd dot_radd dot_sym )
- by (simp add: norm_pow_2[symmetric] power2_eq_square ring_simps norm_cauchy_schwarz)
+ by (simp add: real_abs_def dot_rneg)
lemma norm_triangle_sub: "norm (x::real ^'n) <= norm(y) + norm(x - y)"
- using norm_triangle[of "y" "x - y"] by (simp add: ring_simps)
+ using norm_triangle_ineq[of "y" "x - y"] by (simp add: ring_simps)
lemma norm_triangle_le: "norm(x::real ^'n) + norm y <= e ==> norm(x + y) <= e"
- by (metis order_trans norm_triangle)
+ by (metis order_trans norm_triangle_ineq)
lemma norm_triangle_lt: "norm(x::real ^'n) + norm(y) < e ==> norm(x + y) < e"
- by (metis basic_trans_rules(21) norm_triangle)
+ by (metis basic_trans_rules(21) norm_triangle_ineq)
lemma setsum_delta:
assumes fS: "finite S"
@@ -597,19 +837,10 @@
qed
lemma component_le_norm: "i \<in> {1 .. dimindex(UNIV :: 'n set)} ==> \<bar>x$i\<bar> <= norm (x::real ^ 'n)"
-proof(simp add: real_vector_norm_def, rule real_le_rsqrt, clarsimp)
- assume i: "Suc 0 \<le> i" "i \<le> dimindex (UNIV :: 'n set)"
- let ?S = "{1 .. dimindex(UNIV :: 'n set)}"
- let ?f = "(\<lambda>k. if k = i then x$i ^2 else 0)"
- have fS: "finite ?S" by simp
- from i setsum_delta[OF fS, of i "\<lambda>k. x$i ^ 2"]
- have th: "x$i^2 = setsum ?f ?S" by simp
- let ?g = "\<lambda>k. x$k * x$k"
- {fix x assume x: "x \<in> ?S" have "?f x \<le> ?g x" by (simp add: power2_eq_square)}
- with setsum_mono[of ?S ?f ?g]
- have "setsum ?f ?S \<le> setsum ?g ?S" by blast
- then show "x$i ^2 \<le> x \<bullet> (x:: real ^ 'n)" unfolding dot_def th[symmetric] .
-qed
+ apply (simp add: vector_norm_def)
+ apply (rule member_le_setL2, simp_all)
+ done
+
lemma norm_bound_component_le: "norm(x::real ^ 'n) <= e
==> \<forall>i \<in> {1 .. dimindex(UNIV:: 'n set)}. \<bar>x$i\<bar> <= e"
by (metis component_le_norm order_trans)
@@ -619,24 +850,12 @@
by (metis component_le_norm basic_trans_rules(21))
lemma norm_le_l1: "norm (x:: real ^'n) <= setsum(\<lambda>i. \<bar>x$i\<bar>) {1..dimindex(UNIV::'n set)}"
-proof (simp add: real_vector_norm_def, rule real_le_lsqrt,simp add: dot_pos_le, simp add: setsum_mono, simp add: dot_def, induct "dimindex(UNIV::'n set)")
- case 0 thus ?case by simp
-next
- case (Suc n)
- have th: "2 * (\<bar>x$(Suc n)\<bar> * (\<Sum>i = Suc 0..n. \<bar>x$i\<bar>)) \<ge> 0"
- apply simp
- apply (rule mult_nonneg_nonneg)
- by (simp_all add: setsum_abs_ge_zero)
-
- from Suc
- show ?case using th by (simp add: power2_eq_square ring_simps)
-qed
+ by (simp add: vector_norm_def setL2_le_setsum)
lemma real_abs_norm: "\<bar> norm x\<bar> = norm (x :: real ^'n)"
- by (simp add: norm_pos_le)
+ by (rule abs_norm_cancel)
lemma real_abs_sub_norm: "\<bar>norm(x::real ^'n) - norm y\<bar> <= norm(x - y)"
- apply (simp add: abs_le_iff ring_simps)
- by (metis norm_triangle_sub norm_sub)
+ by (rule norm_triangle_ineq3)
lemma norm_le: "norm(x::real ^ 'n) <= norm(y) \<longleftrightarrow> x \<bullet> x <= y \<bullet> y"
by (simp add: real_vector_norm_def)
lemma norm_lt: "norm(x::real ^'n) < norm(y) \<longleftrightarrow> x \<bullet> x < y \<bullet> y"
@@ -652,13 +871,7 @@
by (simp add: real_vector_norm_def dot_pos_le )
lemma norm_eq_square: "norm(x) = a \<longleftrightarrow> 0 <= a \<and> x \<bullet> x = a^2"
-proof-
- have th: "\<And>x y::real. x^2 = y^2 \<longleftrightarrow> x = y \<or> x = -y" by algebra
- show ?thesis using norm_pos_le[of x]
- apply (simp add: dot_square_norm th)
- apply arith
- done
-qed
+ by (auto simp add: real_vector_norm_def)
lemma real_abs_le_square_iff: "\<bar>x\<bar> \<le> \<bar>y\<bar> \<longleftrightarrow> (x::real)^2 \<le> y^2"
proof-
@@ -668,14 +881,14 @@
qed
lemma norm_le_square: "norm(x) <= a \<longleftrightarrow> 0 <= a \<and> x \<bullet> x <= a^2"
- using norm_pos_le[of x]
apply (simp add: dot_square_norm real_abs_le_square_iff[symmetric])
+ using norm_ge_zero[of x]
apply arith
done
lemma norm_ge_square: "norm(x) >= a \<longleftrightarrow> a <= 0 \<or> x \<bullet> x >= a ^ 2"
- using norm_pos_le[of x]
apply (simp add: dot_square_norm real_abs_le_square_iff[symmetric])
+ using norm_ge_zero[of x]
apply arith
done
@@ -746,14 +959,14 @@
lemma pth_d: "x + (0::real ^'n) == x" by (atomize (full)) vector
lemma norm_imp_pos_and_ge: "norm (x::real ^ 'n) == n \<Longrightarrow> norm x \<ge> 0 \<and> n \<ge> norm x"
- by (atomize) (auto simp add: norm_pos_le)
+ by (atomize) (auto simp add: norm_ge_zero)
lemma real_eq_0_iff_le_ge_0: "(x::real) = 0 == x \<ge> 0 \<and> -x \<ge> 0" by arith
lemma norm_pths:
"(x::real ^'n) = y \<longleftrightarrow> norm (x - y) \<le> 0"
"x \<noteq> y \<longleftrightarrow> \<not> (norm (x - y) \<le> 0)"
- using norm_pos_le[of "x - y"] by (auto simp add: norm_0 norm_eq_0)
+ using norm_ge_zero[of "x - y"] by auto
use "normarith.ML"
@@ -797,11 +1010,6 @@
lemma dist_le_0: "dist x y <= 0 \<longleftrightarrow> x = y" by norm
-instantiation "^" :: (monoid_add,type) monoid_add
-begin
- instance by (intro_classes)
-end
-
lemma setsum_eq: "setsum f S = (\<chi> i. setsum (\<lambda>x. (f x)$i ) S)"
apply vector
apply auto
@@ -873,7 +1081,7 @@
assumes fS: "finite S"
shows "norm (setsum f S) <= setsum (\<lambda>x. norm(f x)) S"
proof(induct rule: finite_induct[OF fS])
- case 1 thus ?case by (simp add: norm_zero)
+ case 1 thus ?case by simp
next
case (2 x S)
from "2.hyps" have "norm (setsum f (insert x S)) \<le> norm (f x) + norm (setsum f S)" by (simp add: norm_triangle_ineq)
@@ -887,10 +1095,10 @@
assumes fS: "finite S"
shows "norm (setsum f S) <= setsum (\<lambda>x. norm(f x)) S"
proof(induct rule: finite_induct[OF fS])
- case 1 thus ?case by simp norm
+ case 1 thus ?case by simp
next
case (2 x S)
- from "2.hyps" have "norm (setsum f (insert x S)) \<le> norm (f x) + norm (setsum f S)" apply (simp add: norm_triangle_ineq) by norm
+ from "2.hyps" have "norm (setsum f (insert x S)) \<le> norm (f x) + norm (setsum f S)" by (simp add: norm_triangle_ineq)
also have "\<dots> \<le> norm (f x) + setsum (\<lambda>x. norm(f x)) S"
using "2.hyps" by simp
finally show ?case using "2.hyps" by simp
@@ -936,45 +1144,6 @@
using real_setsum_norm_le[OF fS K] setsum_constant[symmetric]
by simp
-instantiation "^" :: ("{scaleR, one, times}",type) scaleR
-begin
-
-definition vector_scaleR_def: "(scaleR :: real \<Rightarrow> 'a ^'b \<Rightarrow> 'a ^'b) \<equiv> (\<lambda> c x . (scaleR c 1) *s x)"
-instance ..
-end
-
-instantiation "^" :: ("ring_1",type) ring_1
-begin
-instance by intro_classes
-end
-
-instantiation "^" :: (real_algebra_1,type) real_vector
-begin
-
-instance
- apply intro_classes
- apply (simp_all add: vector_scaleR_def)
- apply (simp_all add: vector_sadd_rdistrib vector_add_ldistrib vector_smult_lid vector_smult_assoc scaleR_left_distrib mult_commute)
- done
-end
-
-instantiation "^" :: (real_algebra_1,type) real_algebra
-begin
-
-instance
- apply intro_classes
- apply (simp_all add: vector_scaleR_def ring_simps)
- apply vector
- apply vector
- done
-end
-
-instantiation "^" :: (real_algebra_1,type) real_algebra_1
-begin
-
-instance ..
-end
-
lemma setsum_vmul:
fixes f :: "'a \<Rightarrow> 'b::{real_normed_vector,semiring, mult_zero}"
assumes fS: "finite S"
@@ -1211,7 +1380,7 @@
by (auto simp add: setsum_component intro: abs_le_D1)
have Pne: "setsum (\<lambda>x. \<bar>f x $ i\<bar>) ?Pn \<le> e"
using i component_le_norm[OF i, of "setsum (\<lambda>x. - f x) ?Pn"] fPs[OF PnP]
- by (auto simp add: setsum_negf norm_neg setsum_component vector_component intro: abs_le_D1)
+ by (auto simp add: setsum_negf setsum_component vector_component intro: abs_le_D1)
have "setsum (\<lambda>x. \<bar>f x $ i\<bar>) P = setsum (\<lambda>x. \<bar>f x $ i\<bar>) ?Pp + setsum (\<lambda>x. \<bar>f x $ i\<bar>) ?Pn"
apply (subst thp)
apply (rule setsum_Un_nonzero)
@@ -1535,7 +1704,7 @@
unfolding norm_mul
apply (simp only: mult_commute)
apply (rule mult_mono)
- by (auto simp add: ring_simps norm_pos_le) }
+ by (auto simp add: ring_simps norm_ge_zero) }
then have th: "\<forall>i\<in> ?S. norm ((x$i) *s f (basis i :: real ^'m)) \<le> norm (f (basis i)) * norm x" by metis
from real_setsum_norm_le[OF fS, of "\<lambda>i. (x$i) *s (f (basis i))", OF th]
have "norm (f x) \<le> ?B * norm x" unfolding th0 setsum_left_distrib by metis}
@@ -1552,16 +1721,18 @@
let ?K = "\<bar>B\<bar> + 1"
have Kp: "?K > 0" by arith
{assume C: "B < 0"
- have "norm (1::real ^ 'n) > 0" by (simp add: norm_pos_lt)
+ have "norm (1::real ^ 'n) > 0" by (simp add: zero_less_norm_iff)
with C have "B * norm (1:: real ^ 'n) < 0"
by (simp add: zero_compare_simps)
- with B[rule_format, of 1] norm_pos_le[of "f 1"] have False by simp
+ with B[rule_format, of 1] norm_ge_zero[of "f 1"] have False by simp
}
then have Bp: "B \<ge> 0" by ferrack
{fix x::"real ^ 'n"
have "norm (f x) \<le> ?K * norm x"
- using B[rule_format, of x] norm_pos_le[of x] norm_pos_le[of "f x"] Bp
- by (auto simp add: ring_simps split add: abs_split)
+ using B[rule_format, of x] norm_ge_zero[of x] norm_ge_zero[of "f x"] Bp
+ apply (auto simp add: ring_simps split add: abs_split)
+ apply (erule order_trans, simp)
+ done
}
then show ?thesis using Kp by blast
qed
@@ -1641,9 +1812,9 @@
apply simp
apply (auto simp add: bilinear_rmul[OF bh] bilinear_lmul[OF bh] norm_mul ring_simps)
apply (rule mult_mono)
- apply (auto simp add: norm_pos_le zero_le_mult_iff component_le_norm)
+ apply (auto simp add: norm_ge_zero zero_le_mult_iff component_le_norm)
apply (rule mult_mono)
- apply (auto simp add: norm_pos_le zero_le_mult_iff component_le_norm)
+ apply (auto simp add: norm_ge_zero zero_le_mult_iff component_le_norm)
done}
then show ?thesis by metis
qed
@@ -1663,7 +1834,7 @@
have "B * norm x * norm y \<le> ?K * norm x * norm y"
apply -
apply (rule mult_right_mono, rule mult_right_mono)
- by (auto simp add: norm_pos_le)
+ by (auto simp add: norm_ge_zero)
then have "norm (h x y) \<le> ?K * norm x * norm y"
using B[rule_format, of x y] by simp}
with Kp show ?thesis by blast
@@ -2276,21 +2447,21 @@
moreover
{assume H: ?lhs
from H[rule_format, of "basis 1"]
- have bp: "b \<ge> 0" using norm_pos_le[of "f (basis 1)"] dimindex_ge_1[of "UNIV:: 'n set"]
- by (auto simp add: norm_basis)
+ have bp: "b \<ge> 0" using norm_ge_zero[of "f (basis 1)"] dimindex_ge_1[of "UNIV:: 'n set"]
+ by (auto simp add: norm_basis elim: order_trans [OF norm_ge_zero])
{fix x :: "real ^'n"
{assume "x = 0"
- then have "norm (f x) \<le> b * norm x" by (simp add: linear_0[OF lf] norm_0 bp)}
+ then have "norm (f x) \<le> b * norm x" by (simp add: linear_0[OF lf] bp)}
moreover
{assume x0: "x \<noteq> 0"
- hence n0: "norm x \<noteq> 0" by (metis norm_eq_0)
+ hence n0: "norm x \<noteq> 0" by (metis norm_eq_zero)
let ?c = "1/ norm x"
- have "norm (?c*s x) = 1" by (simp add: n0 norm_mul)
+ have "norm (?c*s x) = 1" using x0 by (simp add: n0 norm_mul)
with H have "norm (f(?c*s x)) \<le> b" by blast
hence "?c * norm (f x) \<le> b"
by (simp add: linear_cmul[OF lf] norm_mul)
hence "norm (f x) \<le> b * norm x"
- using n0 norm_pos_le[of x] by (auto simp add: field_simps)}
+ using n0 norm_ge_zero[of x] by (auto simp add: field_simps)}
ultimately have "norm (f x) \<le> b * norm x" by blast}
then have ?rhs by blast}
ultimately show ?thesis by blast
@@ -2322,12 +2493,12 @@
qed
lemma onorm_pos_le: assumes lf: "linear (f::real ^'n \<Rightarrow> real ^'m)" shows "0 <= onorm f"
- using order_trans[OF norm_pos_le onorm(1)[OF lf, of "basis 1"], unfolded norm_basis_1] by simp
+ using order_trans[OF norm_ge_zero onorm(1)[OF lf, of "basis 1"], unfolded norm_basis_1] by simp
lemma onorm_eq_0: assumes lf: "linear (f::real ^'n \<Rightarrow> real ^'m)"
shows "onorm f = 0 \<longleftrightarrow> (\<forall>x. f x = 0)"
using onorm[OF lf]
- apply (auto simp add: norm_0 onorm_pos_le norm_le_0)
+ apply (auto simp add: onorm_pos_le)
apply atomize
apply (erule allE[where x="0::real"])
using onorm_pos_le[OF lf]
@@ -2365,7 +2536,7 @@
lemma onorm_neg_lemma: assumes lf: "linear (f::real ^'n \<Rightarrow> real^'m)"
shows "onorm (\<lambda>x. - f x) \<le> onorm f"
using onorm[OF linear_compose_neg[OF lf]] onorm[OF lf]
- unfolding norm_neg by metis
+ unfolding norm_minus_cancel by metis
lemma onorm_neg: assumes lf: "linear (f::real ^'n \<Rightarrow> real^'m)"
shows "onorm (\<lambda>x. - f x) = onorm f"
@@ -2377,7 +2548,7 @@
shows "onorm (\<lambda>x. f x + g x) <= onorm f + onorm g"
apply(rule onorm(2)[OF linear_compose_add[OF lf lg], rule_format])
apply (rule order_trans)
- apply (rule norm_triangle)
+ apply (rule norm_triangle_ineq)
apply (simp add: distrib)
apply (rule add_mono)
apply (rule onorm(1)[OF lf])
@@ -2594,7 +2765,7 @@
by (simp add: dot_def setsum_add_split[OF th_0, of _ ?m] pastecart_def dimindex_finite_sum Cart_lambda_beta setsum_nonneg zero_le_square del: One_nat_def)
then show ?thesis
unfolding th0
- unfolding real_vector_norm_def real_sqrt_le_iff real_of_real_def id_def
+ unfolding real_vector_norm_def real_sqrt_le_iff id_def
by (simp add: dot_def dimindex_finite_sum Cart_lambda_beta)
qed
@@ -2626,7 +2797,7 @@
by (simp add: dot_def setsum_add_split[OF th_0, of _ ?m] pastecart_def dimindex_finite_sum Cart_lambda_beta setsum_nonneg zero_le_square setsum_reindex[OF finj, unfolded fS] del: One_nat_def)
then show ?thesis
unfolding th0
- unfolding real_vector_norm_def real_sqrt_le_iff real_of_real_def id_def
+ unfolding real_vector_norm_def real_sqrt_le_iff id_def
by (simp add: dot_def dimindex_finite_sum Cart_lambda_beta)
qed
@@ -2683,7 +2854,7 @@
qed
lemma norm_pastecart: "norm(pastecart x y) <= norm(x :: real ^ _) + norm(y)"
- unfolding real_vector_norm_def dot_pastecart real_sqrt_le_iff real_of_real_def id_def
+ unfolding real_vector_norm_def dot_pastecart real_sqrt_le_iff id_def
apply (rule power2_le_imp_le)
apply (simp add: real_sqrt_pow2[OF add_nonneg_nonneg[OF dot_pos_le[of x] dot_pos_le[of y]]])
apply (auto simp add: power2_eq_square ring_simps)
@@ -5007,7 +5178,7 @@
apply blast
by (rule abs_ge_zero)
from real_le_lsqrt[OF dot_pos_le th th1]
- show ?thesis unfolding real_vector_norm_def real_of_real_def id_def .
+ show ?thesis unfolding real_vector_norm_def id_def .
qed
(* Equality in Cauchy-Schwarz and triangle inequalities. *)
@@ -5015,10 +5186,10 @@
lemma norm_cauchy_schwarz_eq: "(x::real ^'n) \<bullet> y = norm x * norm y \<longleftrightarrow> norm x *s y = norm y *s x" (is "?lhs \<longleftrightarrow> ?rhs")
proof-
{assume h: "x = 0"
- hence ?thesis by (simp add: norm_0)}
+ hence ?thesis by simp}
moreover
{assume h: "y = 0"
- hence ?thesis by (simp add: norm_0)}
+ hence ?thesis by simp}
moreover
{assume x: "x \<noteq> 0" and y: "y \<noteq> 0"
from dot_eq_0[of "norm y *s x - norm x *s y"]
@@ -5032,7 +5203,7 @@
also have "\<dots> \<longleftrightarrow> (2 * norm x * norm y * (norm x * norm y - x \<bullet> y) = 0)" using x y
by (simp add: ring_simps dot_sym)
also have "\<dots> \<longleftrightarrow> ?lhs" using x y
- apply (simp add: norm_eq_0)
+ apply simp
by metis
finally have ?thesis by blast}
ultimately show ?thesis by blast
@@ -5043,14 +5214,14 @@
proof-
have th: "\<And>(x::real) a. a \<ge> 0 \<Longrightarrow> abs x = a \<longleftrightarrow> x = a \<or> x = - a" by arith
have "?rhs \<longleftrightarrow> norm x *s y = norm y *s x \<or> norm (- x) *s y = norm y *s (- x)"
- apply (simp add: norm_neg) by vector
+ apply simp by vector
also have "\<dots> \<longleftrightarrow>(x \<bullet> y = norm x * norm y \<or>
(-x) \<bullet> y = norm x * norm y)"
unfolding norm_cauchy_schwarz_eq[symmetric]
- unfolding norm_neg
+ unfolding norm_minus_cancel
norm_mul by blast
also have "\<dots> \<longleftrightarrow> ?lhs"
- unfolding th[OF mult_nonneg_nonneg, OF norm_pos_le[of x] norm_pos_le[of y]] dot_lneg
+ unfolding th[OF mult_nonneg_nonneg, OF norm_ge_zero[of x] norm_ge_zero[of y]] dot_lneg
by arith
finally show ?thesis ..
qed
@@ -5058,17 +5229,17 @@
lemma norm_triangle_eq: "norm(x + y) = norm x + norm y \<longleftrightarrow> norm x *s y = norm y *s x"
proof-
{assume x: "x =0 \<or> y =0"
- hence ?thesis by (cases "x=0", simp_all add: norm_0)}
+ hence ?thesis by (cases "x=0", simp_all)}
moreover
{assume x: "x \<noteq> 0" and y: "y \<noteq> 0"
hence "norm x \<noteq> 0" "norm y \<noteq> 0"
- by (simp_all add: norm_eq_0)
+ by simp_all
hence n: "norm x > 0" "norm y > 0"
- using norm_pos_le[of x] norm_pos_le[of y]
+ using norm_ge_zero[of x] norm_ge_zero[of y]
by arith+
have th: "\<And>(a::real) b c. a + b + c \<noteq> 0 ==> (a = b + c \<longleftrightarrow> a^2 = (b + c)^2)" by algebra
have "norm(x + y) = norm x + norm y \<longleftrightarrow> norm(x + y)^ 2 = (norm x + norm y) ^2"
- apply (rule th) using n norm_pos_le[of "x + y"]
+ apply (rule th) using n norm_ge_zero[of "x + y"]
by arith
also have "\<dots> \<longleftrightarrow> norm x *s y = norm y *s x"
unfolding norm_cauchy_schwarz_eq[symmetric]
@@ -5138,8 +5309,8 @@
lemma norm_cauchy_schwarz_equal: "abs(x \<bullet> y) = norm x * norm y \<longleftrightarrow> collinear {(0::real^'n),x,y}"
unfolding norm_cauchy_schwarz_abs_eq
-apply (cases "x=0", simp_all add: collinear_2 norm_0)
-apply (cases "y=0", simp_all add: collinear_2 norm_0 insert_commute)
+apply (cases "x=0", simp_all add: collinear_2)
+apply (cases "y=0", simp_all add: collinear_2 insert_commute)
unfolding collinear_lemma
apply simp
apply (subgoal_tac "norm x \<noteq> 0")
@@ -5164,8 +5335,8 @@
apply (simp add: ring_simps)
apply (case_tac "c <= 0", simp add: ring_simps)
apply (simp add: ring_simps)
-apply (simp add: norm_eq_0)
-apply (simp add: norm_eq_0)
+apply simp
+apply simp
done
-end
\ No newline at end of file
+end
--- a/src/HOL/Library/Float.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Library/Float.thy Thu Feb 26 11:21:29 2009 +0000
@@ -1,7 +1,10 @@
(* Title: HOL/Library/Float.thy
* Author: Steven Obua 2008
- * Johannes Hölzl, TU Muenchen <hoelzl@in.tum.de> 2008 / 2009
+ * Johannes HÃ\<paragraph>lzl, TU Muenchen <hoelzl@in.tum.de> 2008 / 2009
*)
+
+header {* Floating-Point Numbers *}
+
theory Float
imports Complex_Main
begin
@@ -792,7 +795,7 @@
have "x \<noteq> y"
proof (rule ccontr)
assume "\<not> x \<noteq> y" hence "x = y" by auto
- have "?X mod y = 0" unfolding `x = y` using zmod_zmult_self2 by auto
+ have "?X mod y = 0" unfolding `x = y` using mod_mult_self1_is_0 by auto
thus False using False by auto
qed
hence "x < y" using `x \<le> y` by auto
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Library/FrechetDeriv.thy Thu Feb 26 11:21:29 2009 +0000
@@ -0,0 +1,503 @@
+(* Title : FrechetDeriv.thy
+ ID : $Id$
+ Author : Brian Huffman
+*)
+
+header {* Frechet Derivative *}
+
+theory FrechetDeriv
+imports Lim
+begin
+
+definition
+ fderiv ::
+ "['a::real_normed_vector \<Rightarrow> 'b::real_normed_vector, 'a, 'a \<Rightarrow> 'b] \<Rightarrow> bool"
+ -- {* Frechet derivative: D is derivative of function f at x *}
+ ("(FDERIV (_)/ (_)/ :> (_))" [1000, 1000, 60] 60) where
+ "FDERIV f x :> D = (bounded_linear D \<and>
+ (\<lambda>h. norm (f (x + h) - f x - D h) / norm h) -- 0 --> 0)"
+
+lemma FDERIV_I:
+ "\<lbrakk>bounded_linear D; (\<lambda>h. norm (f (x + h) - f x - D h) / norm h) -- 0 --> 0\<rbrakk>
+ \<Longrightarrow> FDERIV f x :> D"
+by (simp add: fderiv_def)
+
+lemma FDERIV_D:
+ "FDERIV f x :> D \<Longrightarrow> (\<lambda>h. norm (f (x + h) - f x - D h) / norm h) -- 0 --> 0"
+by (simp add: fderiv_def)
+
+lemma FDERIV_bounded_linear: "FDERIV f x :> D \<Longrightarrow> bounded_linear D"
+by (simp add: fderiv_def)
+
+lemma bounded_linear_zero:
+ "bounded_linear (\<lambda>x::'a::real_normed_vector. 0::'b::real_normed_vector)"
+proof
+ show "(0::'b) = 0 + 0" by simp
+ fix r show "(0::'b) = scaleR r 0" by simp
+ have "\<forall>x::'a. norm (0::'b) \<le> norm x * 0" by simp
+ thus "\<exists>K. \<forall>x::'a. norm (0::'b) \<le> norm x * K" ..
+qed
+
+lemma FDERIV_const: "FDERIV (\<lambda>x. k) x :> (\<lambda>h. 0)"
+by (simp add: fderiv_def bounded_linear_zero)
+
+lemma bounded_linear_ident:
+ "bounded_linear (\<lambda>x::'a::real_normed_vector. x)"
+proof
+ fix x y :: 'a show "x + y = x + y" by simp
+ fix r and x :: 'a show "scaleR r x = scaleR r x" by simp
+ have "\<forall>x::'a. norm x \<le> norm x * 1" by simp
+ thus "\<exists>K. \<forall>x::'a. norm x \<le> norm x * K" ..
+qed
+
+lemma FDERIV_ident: "FDERIV (\<lambda>x. x) x :> (\<lambda>h. h)"
+by (simp add: fderiv_def bounded_linear_ident)
+
+subsection {* Addition *}
+
+lemma add_diff_add:
+ fixes a b c d :: "'a::ab_group_add"
+ shows "(a + c) - (b + d) = (a - b) + (c - d)"
+by simp
+
+lemma bounded_linear_add:
+ assumes "bounded_linear f"
+ assumes "bounded_linear g"
+ shows "bounded_linear (\<lambda>x. f x + g x)"
+proof -
+ interpret f: bounded_linear f by fact
+ interpret g: bounded_linear g by fact
+ show ?thesis apply (unfold_locales)
+ apply (simp only: f.add g.add add_ac)
+ apply (simp only: f.scaleR g.scaleR scaleR_right_distrib)
+ apply (rule f.pos_bounded [THEN exE], rename_tac Kf)
+ apply (rule g.pos_bounded [THEN exE], rename_tac Kg)
+ apply (rule_tac x="Kf + Kg" in exI, safe)
+ apply (subst right_distrib)
+ apply (rule order_trans [OF norm_triangle_ineq])
+ apply (rule add_mono, erule spec, erule spec)
+ done
+qed
+
+lemma norm_ratio_ineq:
+ fixes x y :: "'a::real_normed_vector"
+ fixes h :: "'b::real_normed_vector"
+ shows "norm (x + y) / norm h \<le> norm x / norm h + norm y / norm h"
+apply (rule ord_le_eq_trans)
+apply (rule divide_right_mono)
+apply (rule norm_triangle_ineq)
+apply (rule norm_ge_zero)
+apply (rule add_divide_distrib)
+done
+
+lemma FDERIV_add:
+ assumes f: "FDERIV f x :> F"
+ assumes g: "FDERIV g x :> G"
+ shows "FDERIV (\<lambda>x. f x + g x) x :> (\<lambda>h. F h + G h)"
+proof (rule FDERIV_I)
+ show "bounded_linear (\<lambda>h. F h + G h)"
+ apply (rule bounded_linear_add)
+ apply (rule FDERIV_bounded_linear [OF f])
+ apply (rule FDERIV_bounded_linear [OF g])
+ done
+next
+ have f': "(\<lambda>h. norm (f (x + h) - f x - F h) / norm h) -- 0 --> 0"
+ using f by (rule FDERIV_D)
+ have g': "(\<lambda>h. norm (g (x + h) - g x - G h) / norm h) -- 0 --> 0"
+ using g by (rule FDERIV_D)
+ from f' g'
+ have "(\<lambda>h. norm (f (x + h) - f x - F h) / norm h
+ + norm (g (x + h) - g x - G h) / norm h) -- 0 --> 0"
+ by (rule LIM_add_zero)
+ thus "(\<lambda>h. norm (f (x + h) + g (x + h) - (f x + g x) - (F h + G h))
+ / norm h) -- 0 --> 0"
+ apply (rule real_LIM_sandwich_zero)
+ apply (simp add: divide_nonneg_pos)
+ apply (simp only: add_diff_add)
+ apply (rule norm_ratio_ineq)
+ done
+qed
+
+subsection {* Subtraction *}
+
+lemma bounded_linear_minus:
+ assumes "bounded_linear f"
+ shows "bounded_linear (\<lambda>x. - f x)"
+proof -
+ interpret f: bounded_linear f by fact
+ show ?thesis apply (unfold_locales)
+ apply (simp add: f.add)
+ apply (simp add: f.scaleR)
+ apply (simp add: f.bounded)
+ done
+qed
+
+lemma FDERIV_minus:
+ "FDERIV f x :> F \<Longrightarrow> FDERIV (\<lambda>x. - f x) x :> (\<lambda>h. - F h)"
+apply (rule FDERIV_I)
+apply (rule bounded_linear_minus)
+apply (erule FDERIV_bounded_linear)
+apply (simp only: fderiv_def minus_diff_minus norm_minus_cancel)
+done
+
+lemma FDERIV_diff:
+ "\<lbrakk>FDERIV f x :> F; FDERIV g x :> G\<rbrakk>
+ \<Longrightarrow> FDERIV (\<lambda>x. f x - g x) x :> (\<lambda>h. F h - G h)"
+by (simp only: diff_minus FDERIV_add FDERIV_minus)
+
+subsection {* Continuity *}
+
+lemma FDERIV_isCont:
+ assumes f: "FDERIV f x :> F"
+ shows "isCont f x"
+proof -
+ from f interpret F: bounded_linear "F" by (rule FDERIV_bounded_linear)
+ have "(\<lambda>h. norm (f (x + h) - f x - F h) / norm h) -- 0 --> 0"
+ by (rule FDERIV_D [OF f])
+ hence "(\<lambda>h. norm (f (x + h) - f x - F h) / norm h * norm h) -- 0 --> 0"
+ by (intro LIM_mult_zero LIM_norm_zero LIM_ident)
+ hence "(\<lambda>h. norm (f (x + h) - f x - F h)) -- 0 --> 0"
+ by (simp cong: LIM_cong)
+ hence "(\<lambda>h. f (x + h) - f x - F h) -- 0 --> 0"
+ by (rule LIM_norm_zero_cancel)
+ hence "(\<lambda>h. f (x + h) - f x - F h + F h) -- 0 --> 0"
+ by (intro LIM_add_zero F.LIM_zero LIM_ident)
+ hence "(\<lambda>h. f (x + h) - f x) -- 0 --> 0"
+ by simp
+ thus "isCont f x"
+ unfolding isCont_iff by (rule LIM_zero_cancel)
+qed
+
+subsection {* Composition *}
+
+lemma real_divide_cancel_lemma:
+ fixes a b c :: real
+ shows "(b = 0 \<Longrightarrow> a = 0) \<Longrightarrow> (a / b) * (b / c) = a / c"
+by simp
+
+lemma bounded_linear_compose:
+ assumes "bounded_linear f"
+ assumes "bounded_linear g"
+ shows "bounded_linear (\<lambda>x. f (g x))"
+proof -
+ interpret f: bounded_linear f by fact
+ interpret g: bounded_linear g by fact
+ show ?thesis proof (unfold_locales)
+ fix x y show "f (g (x + y)) = f (g x) + f (g y)"
+ by (simp only: f.add g.add)
+ next
+ fix r x show "f (g (scaleR r x)) = scaleR r (f (g x))"
+ by (simp only: f.scaleR g.scaleR)
+ next
+ from f.pos_bounded
+ obtain Kf where f: "\<And>x. norm (f x) \<le> norm x * Kf" and Kf: "0 < Kf" by fast
+ from g.pos_bounded
+ obtain Kg where g: "\<And>x. norm (g x) \<le> norm x * Kg" by fast
+ show "\<exists>K. \<forall>x. norm (f (g x)) \<le> norm x * K"
+ proof (intro exI allI)
+ fix x
+ have "norm (f (g x)) \<le> norm (g x) * Kf"
+ using f .
+ also have "\<dots> \<le> (norm x * Kg) * Kf"
+ using g Kf [THEN order_less_imp_le] by (rule mult_right_mono)
+ also have "(norm x * Kg) * Kf = norm x * (Kg * Kf)"
+ by (rule mult_assoc)
+ finally show "norm (f (g x)) \<le> norm x * (Kg * Kf)" .
+ qed
+ qed
+qed
+
+lemma FDERIV_compose:
+ fixes f :: "'a::real_normed_vector \<Rightarrow> 'b::real_normed_vector"
+ fixes g :: "'b::real_normed_vector \<Rightarrow> 'c::real_normed_vector"
+ assumes f: "FDERIV f x :> F"
+ assumes g: "FDERIV g (f x) :> G"
+ shows "FDERIV (\<lambda>x. g (f x)) x :> (\<lambda>h. G (F h))"
+proof (rule FDERIV_I)
+ from FDERIV_bounded_linear [OF g] FDERIV_bounded_linear [OF f]
+ show "bounded_linear (\<lambda>h. G (F h))"
+ by (rule bounded_linear_compose)
+next
+ let ?Rf = "\<lambda>h. f (x + h) - f x - F h"
+ let ?Rg = "\<lambda>k. g (f x + k) - g (f x) - G k"
+ let ?k = "\<lambda>h. f (x + h) - f x"
+ let ?Nf = "\<lambda>h. norm (?Rf h) / norm h"
+ let ?Ng = "\<lambda>h. norm (?Rg (?k h)) / norm (?k h)"
+ from f interpret F!: bounded_linear "F" by (rule FDERIV_bounded_linear)
+ from g interpret G!: bounded_linear "G" by (rule FDERIV_bounded_linear)
+ from F.bounded obtain kF where kF: "\<And>x. norm (F x) \<le> norm x * kF" by fast
+ from G.bounded obtain kG where kG: "\<And>x. norm (G x) \<le> norm x * kG" by fast
+
+ let ?fun2 = "\<lambda>h. ?Nf h * kG + ?Ng h * (?Nf h + kF)"
+
+ show "(\<lambda>h. norm (g (f (x + h)) - g (f x) - G (F h)) / norm h) -- 0 --> 0"
+ proof (rule real_LIM_sandwich_zero)
+ have Nf: "?Nf -- 0 --> 0"
+ using FDERIV_D [OF f] .
+
+ have Ng1: "isCont (\<lambda>k. norm (?Rg k) / norm k) 0"
+ by (simp add: isCont_def FDERIV_D [OF g])
+ have Ng2: "?k -- 0 --> 0"
+ apply (rule LIM_zero)
+ apply (fold isCont_iff)
+ apply (rule FDERIV_isCont [OF f])
+ done
+ have Ng: "?Ng -- 0 --> 0"
+ using isCont_LIM_compose [OF Ng1 Ng2] by simp
+
+ have "(\<lambda>h. ?Nf h * kG + ?Ng h * (?Nf h + kF))
+ -- 0 --> 0 * kG + 0 * (0 + kF)"
+ by (intro LIM_add LIM_mult LIM_const Nf Ng)
+ thus "(\<lambda>h. ?Nf h * kG + ?Ng h * (?Nf h + kF)) -- 0 --> 0"
+ by simp
+ next
+ fix h::'a assume h: "h \<noteq> 0"
+ thus "0 \<le> norm (g (f (x + h)) - g (f x) - G (F h)) / norm h"
+ by (simp add: divide_nonneg_pos)
+ next
+ fix h::'a assume h: "h \<noteq> 0"
+ have "g (f (x + h)) - g (f x) - G (F h) = G (?Rf h) + ?Rg (?k h)"
+ by (simp add: G.diff)
+ hence "norm (g (f (x + h)) - g (f x) - G (F h)) / norm h
+ = norm (G (?Rf h) + ?Rg (?k h)) / norm h"
+ by (rule arg_cong)
+ also have "\<dots> \<le> norm (G (?Rf h)) / norm h + norm (?Rg (?k h)) / norm h"
+ by (rule norm_ratio_ineq)
+ also have "\<dots> \<le> ?Nf h * kG + ?Ng h * (?Nf h + kF)"
+ proof (rule add_mono)
+ show "norm (G (?Rf h)) / norm h \<le> ?Nf h * kG"
+ apply (rule ord_le_eq_trans)
+ apply (rule divide_right_mono [OF kG norm_ge_zero])
+ apply simp
+ done
+ next
+ have "norm (?Rg (?k h)) / norm h = ?Ng h * (norm (?k h) / norm h)"
+ apply (rule real_divide_cancel_lemma [symmetric])
+ apply (simp add: G.zero)
+ done
+ also have "\<dots> \<le> ?Ng h * (?Nf h + kF)"
+ proof (rule mult_left_mono)
+ have "norm (?k h) / norm h = norm (?Rf h + F h) / norm h"
+ by simp
+ also have "\<dots> \<le> ?Nf h + norm (F h) / norm h"
+ by (rule norm_ratio_ineq)
+ also have "\<dots> \<le> ?Nf h + kF"
+ apply (rule add_left_mono)
+ apply (subst pos_divide_le_eq, simp add: h)
+ apply (subst mult_commute)
+ apply (rule kF)
+ done
+ finally show "norm (?k h) / norm h \<le> ?Nf h + kF" .
+ next
+ show "0 \<le> ?Ng h"
+ apply (case_tac "f (x + h) - f x = 0", simp)
+ apply (rule divide_nonneg_pos [OF norm_ge_zero])
+ apply simp
+ done
+ qed
+ finally show "norm (?Rg (?k h)) / norm h \<le> ?Ng h * (?Nf h + kF)" .
+ qed
+ finally show "norm (g (f (x + h)) - g (f x) - G (F h)) / norm h
+ \<le> ?Nf h * kG + ?Ng h * (?Nf h + kF)" .
+ qed
+qed
+
+subsection {* Product Rule *}
+
+lemma (in bounded_bilinear) FDERIV_lemma:
+ "a' ** b' - a ** b - (a ** B + A ** b)
+ = a ** (b' - b - B) + (a' - a - A) ** b' + A ** (b' - b)"
+by (simp add: diff_left diff_right)
+
+lemma (in bounded_bilinear) FDERIV:
+ fixes x :: "'d::real_normed_vector"
+ assumes f: "FDERIV f x :> F"
+ assumes g: "FDERIV g x :> G"
+ shows "FDERIV (\<lambda>x. f x ** g x) x :> (\<lambda>h. f x ** G h + F h ** g x)"
+proof (rule FDERIV_I)
+ show "bounded_linear (\<lambda>h. f x ** G h + F h ** g x)"
+ apply (rule bounded_linear_add)
+ apply (rule bounded_linear_compose [OF bounded_linear_right])
+ apply (rule FDERIV_bounded_linear [OF g])
+ apply (rule bounded_linear_compose [OF bounded_linear_left])
+ apply (rule FDERIV_bounded_linear [OF f])
+ done
+next
+ from bounded_linear.bounded [OF FDERIV_bounded_linear [OF f]]
+ obtain KF where norm_F: "\<And>x. norm (F x) \<le> norm x * KF" by fast
+
+ from pos_bounded obtain K where K: "0 < K" and norm_prod:
+ "\<And>a b. norm (a ** b) \<le> norm a * norm b * K" by fast
+
+ let ?Rf = "\<lambda>h. f (x + h) - f x - F h"
+ let ?Rg = "\<lambda>h. g (x + h) - g x - G h"
+
+ let ?fun1 = "\<lambda>h.
+ norm (f x ** ?Rg h + ?Rf h ** g (x + h) + F h ** (g (x + h) - g x)) /
+ norm h"
+
+ let ?fun2 = "\<lambda>h.
+ norm (f x) * (norm (?Rg h) / norm h) * K +
+ norm (?Rf h) / norm h * norm (g (x + h)) * K +
+ KF * norm (g (x + h) - g x) * K"
+
+ have "?fun1 -- 0 --> 0"
+ proof (rule real_LIM_sandwich_zero)
+ from f g isCont_iff [THEN iffD1, OF FDERIV_isCont [OF g]]
+ have "?fun2 -- 0 -->
+ norm (f x) * 0 * K + 0 * norm (g x) * K + KF * norm (0::'b) * K"
+ by (intro LIM_add LIM_mult LIM_const LIM_norm LIM_zero FDERIV_D)
+ thus "?fun2 -- 0 --> 0"
+ by simp
+ next
+ fix h::'d assume "h \<noteq> 0"
+ thus "0 \<le> ?fun1 h"
+ by (simp add: divide_nonneg_pos)
+ next
+ fix h::'d assume "h \<noteq> 0"
+ have "?fun1 h \<le> (norm (f x) * norm (?Rg h) * K +
+ norm (?Rf h) * norm (g (x + h)) * K +
+ norm h * KF * norm (g (x + h) - g x) * K) / norm h"
+ by (intro
+ divide_right_mono mult_mono'
+ order_trans [OF norm_triangle_ineq add_mono]
+ order_trans [OF norm_prod mult_right_mono]
+ mult_nonneg_nonneg order_refl norm_ge_zero norm_F
+ K [THEN order_less_imp_le]
+ )
+ also have "\<dots> = ?fun2 h"
+ by (simp add: add_divide_distrib)
+ finally show "?fun1 h \<le> ?fun2 h" .
+ qed
+ thus "(\<lambda>h.
+ norm (f (x + h) ** g (x + h) - f x ** g x - (f x ** G h + F h ** g x))
+ / norm h) -- 0 --> 0"
+ by (simp only: FDERIV_lemma)
+qed
+
+lemmas FDERIV_mult = mult.FDERIV
+
+lemmas FDERIV_scaleR = scaleR.FDERIV
+
+
+subsection {* Powers *}
+
+lemma FDERIV_power_Suc:
+ fixes x :: "'a::{real_normed_algebra,recpower,comm_ring_1}"
+ shows "FDERIV (\<lambda>x. x ^ Suc n) x :> (\<lambda>h. (1 + of_nat n) * x ^ n * h)"
+ apply (induct n)
+ apply (simp add: power_Suc FDERIV_ident)
+ apply (drule FDERIV_mult [OF FDERIV_ident])
+ apply (simp only: of_nat_Suc left_distrib mult_1_left)
+ apply (simp only: power_Suc right_distrib add_ac mult_ac)
+done
+
+lemma FDERIV_power:
+ fixes x :: "'a::{real_normed_algebra,recpower,comm_ring_1}"
+ shows "FDERIV (\<lambda>x. x ^ n) x :> (\<lambda>h. of_nat n * x ^ (n - 1) * h)"
+ apply (cases n)
+ apply (simp add: FDERIV_const)
+ apply (simp add: FDERIV_power_Suc)
+ done
+
+
+subsection {* Inverse *}
+
+lemma inverse_diff_inverse:
+ "\<lbrakk>(a::'a::division_ring) \<noteq> 0; b \<noteq> 0\<rbrakk>
+ \<Longrightarrow> inverse a - inverse b = - (inverse a * (a - b) * inverse b)"
+by (simp add: right_diff_distrib left_diff_distrib mult_assoc)
+
+lemmas bounded_linear_mult_const =
+ mult.bounded_linear_left [THEN bounded_linear_compose]
+
+lemmas bounded_linear_const_mult =
+ mult.bounded_linear_right [THEN bounded_linear_compose]
+
+lemma FDERIV_inverse:
+ fixes x :: "'a::real_normed_div_algebra"
+ assumes x: "x \<noteq> 0"
+ shows "FDERIV inverse x :> (\<lambda>h. - (inverse x * h * inverse x))"
+ (is "FDERIV ?inv _ :> _")
+proof (rule FDERIV_I)
+ show "bounded_linear (\<lambda>h. - (?inv x * h * ?inv x))"
+ apply (rule bounded_linear_minus)
+ apply (rule bounded_linear_mult_const)
+ apply (rule bounded_linear_const_mult)
+ apply (rule bounded_linear_ident)
+ done
+next
+ show "(\<lambda>h. norm (?inv (x + h) - ?inv x - - (?inv x * h * ?inv x)) / norm h)
+ -- 0 --> 0"
+ proof (rule LIM_equal2)
+ show "0 < norm x" using x by simp
+ next
+ fix h::'a
+ assume 1: "h \<noteq> 0"
+ assume "norm (h - 0) < norm x"
+ hence "h \<noteq> -x" by clarsimp
+ hence 2: "x + h \<noteq> 0"
+ apply (rule contrapos_nn)
+ apply (rule sym)
+ apply (erule equals_zero_I)
+ done
+ show "norm (?inv (x + h) - ?inv x - - (?inv x * h * ?inv x)) / norm h
+ = norm ((?inv (x + h) - ?inv x) * h * ?inv x) / norm h"
+ apply (subst inverse_diff_inverse [OF 2 x])
+ apply (subst minus_diff_minus)
+ apply (subst norm_minus_cancel)
+ apply (simp add: left_diff_distrib)
+ done
+ next
+ show "(\<lambda>h. norm ((?inv (x + h) - ?inv x) * h * ?inv x) / norm h)
+ -- 0 --> 0"
+ proof (rule real_LIM_sandwich_zero)
+ show "(\<lambda>h. norm (?inv (x + h) - ?inv x) * norm (?inv x))
+ -- 0 --> 0"
+ apply (rule LIM_mult_left_zero)
+ apply (rule LIM_norm_zero)
+ apply (rule LIM_zero)
+ apply (rule LIM_offset_zero)
+ apply (rule LIM_inverse)
+ apply (rule LIM_ident)
+ apply (rule x)
+ done
+ next
+ fix h::'a assume h: "h \<noteq> 0"
+ show "0 \<le> norm ((?inv (x + h) - ?inv x) * h * ?inv x) / norm h"
+ apply (rule divide_nonneg_pos)
+ apply (rule norm_ge_zero)
+ apply (simp add: h)
+ done
+ next
+ fix h::'a assume h: "h \<noteq> 0"
+ have "norm ((?inv (x + h) - ?inv x) * h * ?inv x) / norm h
+ \<le> norm (?inv (x + h) - ?inv x) * norm h * norm (?inv x) / norm h"
+ apply (rule divide_right_mono [OF _ norm_ge_zero])
+ apply (rule order_trans [OF norm_mult_ineq])
+ apply (rule mult_right_mono [OF _ norm_ge_zero])
+ apply (rule norm_mult_ineq)
+ done
+ also have "\<dots> = norm (?inv (x + h) - ?inv x) * norm (?inv x)"
+ by simp
+ finally show "norm ((?inv (x + h) - ?inv x) * h * ?inv x) / norm h
+ \<le> norm (?inv (x + h) - ?inv x) * norm (?inv x)" .
+ qed
+ qed
+qed
+
+subsection {* Alternate definition *}
+
+lemma field_fderiv_def:
+ fixes x :: "'a::real_normed_field" shows
+ "FDERIV f x :> (\<lambda>h. h * D) = (\<lambda>h. (f (x + h) - f x) / h) -- 0 --> D"
+ apply (unfold fderiv_def)
+ apply (simp add: mult.bounded_linear_left)
+ apply (simp cong: LIM_cong add: nonzero_norm_divide [symmetric])
+ apply (subst diff_divide_distrib)
+ apply (subst times_divide_eq_left [symmetric])
+ apply (simp cong: LIM_cong)
+ apply (simp add: LIM_norm_zero_iff LIM_zero_iff)
+done
+
+end
--- a/src/HOL/Library/Fundamental_Theorem_Algebra.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Library/Fundamental_Theorem_Algebra.thy Thu Feb 26 11:21:29 2009 +0000
@@ -946,90 +946,6 @@
ultimately show ?case by blast
qed simp
-subsection {* Order of polynomial roots *}
-
-definition
- order :: "'a::{idom,recpower} \<Rightarrow> 'a poly \<Rightarrow> nat"
-where
- [code del]:
- "order a p = (LEAST n. \<not> [:-a, 1:] ^ Suc n dvd p)"
-
-lemma degree_power_le: "degree (p ^ n) \<le> degree p * n"
-by (induct n, simp, auto intro: order_trans degree_mult_le)
-
-lemma coeff_linear_power:
- fixes a :: "'a::{comm_semiring_1,recpower}"
- shows "coeff ([:a, 1:] ^ n) n = 1"
-apply (induct n, simp_all)
-apply (subst coeff_eq_0)
-apply (auto intro: le_less_trans degree_power_le)
-done
-
-lemma degree_linear_power:
- fixes a :: "'a::{comm_semiring_1,recpower}"
- shows "degree ([:a, 1:] ^ n) = n"
-apply (rule order_antisym)
-apply (rule ord_le_eq_trans [OF degree_power_le], simp)
-apply (rule le_degree, simp add: coeff_linear_power)
-done
-
-lemma order_1: "[:-a, 1:] ^ order a p dvd p"
-apply (cases "p = 0", simp)
-apply (cases "order a p", simp)
-apply (subgoal_tac "nat < (LEAST n. \<not> [:-a, 1:] ^ Suc n dvd p)")
-apply (drule not_less_Least, simp)
-apply (fold order_def, simp)
-done
-
-lemma order_2: "p \<noteq> 0 \<Longrightarrow> \<not> [:-a, 1:] ^ Suc (order a p) dvd p"
-unfolding order_def
-apply (rule LeastI_ex)
-apply (rule_tac x="degree p" in exI)
-apply (rule notI)
-apply (drule (1) dvd_imp_degree_le)
-apply (simp only: degree_linear_power)
-done
-
-lemma order:
- "p \<noteq> 0 \<Longrightarrow> [:-a, 1:] ^ order a p dvd p \<and> \<not> [:-a, 1:] ^ Suc (order a p) dvd p"
-by (rule conjI [OF order_1 order_2])
-
-lemma order_degree:
- assumes p: "p \<noteq> 0"
- shows "order a p \<le> degree p"
-proof -
- have "order a p = degree ([:-a, 1:] ^ order a p)"
- by (simp only: degree_linear_power)
- also have "\<dots> \<le> degree p"
- using order_1 p by (rule dvd_imp_degree_le)
- finally show ?thesis .
-qed
-
-lemma order_root: "poly p a = 0 \<longleftrightarrow> p = 0 \<or> order a p \<noteq> 0"
-apply (cases "p = 0", simp_all)
-apply (rule iffI)
-apply (rule ccontr, simp)
-apply (frule order_2 [where a=a], simp)
-apply (simp add: poly_eq_0_iff_dvd)
-apply (simp add: poly_eq_0_iff_dvd)
-apply (simp only: order_def)
-apply (drule not_less_Least, simp)
-done
-
-lemma poly_zero:
- fixes p :: "'a::{idom,ring_char_0} poly"
- shows "poly p = poly 0 \<longleftrightarrow> p = 0"
-apply (cases "p = 0", simp_all)
-apply (drule poly_roots_finite)
-apply (auto simp add: infinite_UNIV_char_0)
-done
-
-lemma poly_eq_iff:
- fixes p q :: "'a::{idom,ring_char_0} poly"
- shows "poly p = poly q \<longleftrightarrow> p = q"
- using poly_zero [of "p - q"]
- by (simp add: expand_fun_eq)
-
subsection{* Nullstellenstatz, degrees and divisibility of polynomials *}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Library/Inner_Product.thy Thu Feb 26 11:21:29 2009 +0000
@@ -0,0 +1,296 @@
+(* Title: Inner_Product.thy
+ Author: Brian Huffman
+*)
+
+header {* Inner Product Spaces and the Gradient Derivative *}
+
+theory Inner_Product
+imports Complex FrechetDeriv
+begin
+
+subsection {* Real inner product spaces *}
+
+class real_inner = real_vector + sgn_div_norm +
+ fixes inner :: "'a \<Rightarrow> 'a \<Rightarrow> real"
+ assumes inner_commute: "inner x y = inner y x"
+ and inner_left_distrib: "inner (x + y) z = inner x z + inner y z"
+ and inner_scaleR_left: "inner (scaleR r x) y = r * (inner x y)"
+ and inner_ge_zero [simp]: "0 \<le> inner x x"
+ and inner_eq_zero_iff [simp]: "inner x x = 0 \<longleftrightarrow> x = 0"
+ and norm_eq_sqrt_inner: "norm x = sqrt (inner x x)"
+begin
+
+lemma inner_zero_left [simp]: "inner 0 x = 0"
+ using inner_left_distrib [of 0 0 x] by simp
+
+lemma inner_minus_left [simp]: "inner (- x) y = - inner x y"
+ using inner_left_distrib [of x "- x" y] by simp
+
+lemma inner_diff_left: "inner (x - y) z = inner x z - inner y z"
+ by (simp add: diff_minus inner_left_distrib)
+
+text {* Transfer distributivity rules to right argument. *}
+
+lemma inner_right_distrib: "inner x (y + z) = inner x y + inner x z"
+ using inner_left_distrib [of y z x] by (simp only: inner_commute)
+
+lemma inner_scaleR_right: "inner x (scaleR r y) = r * (inner x y)"
+ using inner_scaleR_left [of r y x] by (simp only: inner_commute)
+
+lemma inner_zero_right [simp]: "inner x 0 = 0"
+ using inner_zero_left [of x] by (simp only: inner_commute)
+
+lemma inner_minus_right [simp]: "inner x (- y) = - inner x y"
+ using inner_minus_left [of y x] by (simp only: inner_commute)
+
+lemma inner_diff_right: "inner x (y - z) = inner x y - inner x z"
+ using inner_diff_left [of y z x] by (simp only: inner_commute)
+
+lemmas inner_distrib = inner_left_distrib inner_right_distrib
+lemmas inner_diff = inner_diff_left inner_diff_right
+lemmas inner_scaleR = inner_scaleR_left inner_scaleR_right
+
+lemma inner_gt_zero_iff [simp]: "0 < inner x x \<longleftrightarrow> x \<noteq> 0"
+ by (simp add: order_less_le)
+
+lemma power2_norm_eq_inner: "(norm x)\<twosuperior> = inner x x"
+ by (simp add: norm_eq_sqrt_inner)
+
+lemma Cauchy_Schwarz_ineq:
+ "(inner x y)\<twosuperior> \<le> inner x x * inner y y"
+proof (cases)
+ assume "y = 0"
+ thus ?thesis by simp
+next
+ assume y: "y \<noteq> 0"
+ let ?r = "inner x y / inner y y"
+ have "0 \<le> inner (x - scaleR ?r y) (x - scaleR ?r y)"
+ by (rule inner_ge_zero)
+ also have "\<dots> = inner x x - inner y x * ?r"
+ by (simp add: inner_diff inner_scaleR)
+ also have "\<dots> = inner x x - (inner x y)\<twosuperior> / inner y y"
+ by (simp add: power2_eq_square inner_commute)
+ finally have "0 \<le> inner x x - (inner x y)\<twosuperior> / inner y y" .
+ hence "(inner x y)\<twosuperior> / inner y y \<le> inner x x"
+ by (simp add: le_diff_eq)
+ thus "(inner x y)\<twosuperior> \<le> inner x x * inner y y"
+ by (simp add: pos_divide_le_eq y)
+qed
+
+lemma Cauchy_Schwarz_ineq2:
+ "\<bar>inner x y\<bar> \<le> norm x * norm y"
+proof (rule power2_le_imp_le)
+ have "(inner x y)\<twosuperior> \<le> inner x x * inner y y"
+ using Cauchy_Schwarz_ineq .
+ thus "\<bar>inner x y\<bar>\<twosuperior> \<le> (norm x * norm y)\<twosuperior>"
+ by (simp add: power_mult_distrib power2_norm_eq_inner)
+ show "0 \<le> norm x * norm y"
+ unfolding norm_eq_sqrt_inner
+ by (intro mult_nonneg_nonneg real_sqrt_ge_zero inner_ge_zero)
+qed
+
+subclass real_normed_vector
+proof
+ fix a :: real and x y :: 'a
+ show "0 \<le> norm x"
+ unfolding norm_eq_sqrt_inner by simp
+ show "norm x = 0 \<longleftrightarrow> x = 0"
+ unfolding norm_eq_sqrt_inner by simp
+ show "norm (x + y) \<le> norm x + norm y"
+ proof (rule power2_le_imp_le)
+ have "inner x y \<le> norm x * norm y"
+ by (rule order_trans [OF abs_ge_self Cauchy_Schwarz_ineq2])
+ thus "(norm (x + y))\<twosuperior> \<le> (norm x + norm y)\<twosuperior>"
+ unfolding power2_sum power2_norm_eq_inner
+ by (simp add: inner_distrib inner_commute)
+ show "0 \<le> norm x + norm y"
+ unfolding norm_eq_sqrt_inner
+ by (simp add: add_nonneg_nonneg)
+ qed
+ have "sqrt (a\<twosuperior> * inner x x) = \<bar>a\<bar> * sqrt (inner x x)"
+ by (simp add: real_sqrt_mult_distrib)
+ then show "norm (a *\<^sub>R x) = \<bar>a\<bar> * norm x"
+ unfolding norm_eq_sqrt_inner
+ by (simp add: inner_scaleR power2_eq_square mult_assoc)
+qed
+
+end
+
+interpretation inner!:
+ bounded_bilinear "inner::'a::real_inner \<Rightarrow> 'a \<Rightarrow> real"
+proof
+ fix x y z :: 'a and r :: real
+ show "inner (x + y) z = inner x z + inner y z"
+ by (rule inner_left_distrib)
+ show "inner x (y + z) = inner x y + inner x z"
+ by (rule inner_right_distrib)
+ show "inner (scaleR r x) y = scaleR r (inner x y)"
+ unfolding real_scaleR_def by (rule inner_scaleR_left)
+ show "inner x (scaleR r y) = scaleR r (inner x y)"
+ unfolding real_scaleR_def by (rule inner_scaleR_right)
+ show "\<exists>K. \<forall>x y::'a. norm (inner x y) \<le> norm x * norm y * K"
+ proof
+ show "\<forall>x y::'a. norm (inner x y) \<le> norm x * norm y * 1"
+ by (simp add: Cauchy_Schwarz_ineq2)
+ qed
+qed
+
+interpretation inner_left!:
+ bounded_linear "\<lambda>x::'a::real_inner. inner x y"
+ by (rule inner.bounded_linear_left)
+
+interpretation inner_right!:
+ bounded_linear "\<lambda>y::'a::real_inner. inner x y"
+ by (rule inner.bounded_linear_right)
+
+
+subsection {* Class instances *}
+
+instantiation real :: real_inner
+begin
+
+definition inner_real_def [simp]: "inner = op *"
+
+instance proof
+ fix x y z r :: real
+ show "inner x y = inner y x"
+ unfolding inner_real_def by (rule mult_commute)
+ show "inner (x + y) z = inner x z + inner y z"
+ unfolding inner_real_def by (rule left_distrib)
+ show "inner (scaleR r x) y = r * inner x y"
+ unfolding inner_real_def real_scaleR_def by (rule mult_assoc)
+ show "0 \<le> inner x x"
+ unfolding inner_real_def by simp
+ show "inner x x = 0 \<longleftrightarrow> x = 0"
+ unfolding inner_real_def by simp
+ show "norm x = sqrt (inner x x)"
+ unfolding inner_real_def by simp
+qed
+
+end
+
+instantiation complex :: real_inner
+begin
+
+definition inner_complex_def:
+ "inner x y = Re x * Re y + Im x * Im y"
+
+instance proof
+ fix x y z :: complex and r :: real
+ show "inner x y = inner y x"
+ unfolding inner_complex_def by (simp add: mult_commute)
+ show "inner (x + y) z = inner x z + inner y z"
+ unfolding inner_complex_def by (simp add: left_distrib)
+ show "inner (scaleR r x) y = r * inner x y"
+ unfolding inner_complex_def by (simp add: right_distrib)
+ show "0 \<le> inner x x"
+ unfolding inner_complex_def by (simp add: add_nonneg_nonneg)
+ show "inner x x = 0 \<longleftrightarrow> x = 0"
+ unfolding inner_complex_def
+ by (simp add: add_nonneg_eq_0_iff complex_Re_Im_cancel_iff)
+ show "norm x = sqrt (inner x x)"
+ unfolding inner_complex_def complex_norm_def
+ by (simp add: power2_eq_square)
+qed
+
+end
+
+
+subsection {* Gradient derivative *}
+
+definition
+ gderiv ::
+ "['a::real_inner \<Rightarrow> real, 'a, 'a] \<Rightarrow> bool"
+ ("(GDERIV (_)/ (_)/ :> (_))" [1000, 1000, 60] 60)
+where
+ "GDERIV f x :> D \<longleftrightarrow> FDERIV f x :> (\<lambda>h. inner h D)"
+
+lemma deriv_fderiv: "DERIV f x :> D \<longleftrightarrow> FDERIV f x :> (\<lambda>h. h * D)"
+ by (simp only: deriv_def field_fderiv_def)
+
+lemma gderiv_deriv [simp]: "GDERIV f x :> D \<longleftrightarrow> DERIV f x :> D"
+ by (simp only: gderiv_def deriv_fderiv inner_real_def)
+
+lemma GDERIV_DERIV_compose:
+ "\<lbrakk>GDERIV f x :> df; DERIV g (f x) :> dg\<rbrakk>
+ \<Longrightarrow> GDERIV (\<lambda>x. g (f x)) x :> scaleR dg df"
+ unfolding gderiv_def deriv_fderiv
+ apply (drule (1) FDERIV_compose)
+ apply (simp add: inner_scaleR_right mult_ac)
+ done
+
+lemma FDERIV_subst: "\<lbrakk>FDERIV f x :> df; df = d\<rbrakk> \<Longrightarrow> FDERIV f x :> d"
+ by simp
+
+lemma GDERIV_subst: "\<lbrakk>GDERIV f x :> df; df = d\<rbrakk> \<Longrightarrow> GDERIV f x :> d"
+ by simp
+
+lemma GDERIV_const: "GDERIV (\<lambda>x. k) x :> 0"
+ unfolding gderiv_def inner_right.zero by (rule FDERIV_const)
+
+lemma GDERIV_add:
+ "\<lbrakk>GDERIV f x :> df; GDERIV g x :> dg\<rbrakk>
+ \<Longrightarrow> GDERIV (\<lambda>x. f x + g x) x :> df + dg"
+ unfolding gderiv_def inner_right.add by (rule FDERIV_add)
+
+lemma GDERIV_minus:
+ "GDERIV f x :> df \<Longrightarrow> GDERIV (\<lambda>x. - f x) x :> - df"
+ unfolding gderiv_def inner_right.minus by (rule FDERIV_minus)
+
+lemma GDERIV_diff:
+ "\<lbrakk>GDERIV f x :> df; GDERIV g x :> dg\<rbrakk>
+ \<Longrightarrow> GDERIV (\<lambda>x. f x - g x) x :> df - dg"
+ unfolding gderiv_def inner_right.diff by (rule FDERIV_diff)
+
+lemma GDERIV_scaleR:
+ "\<lbrakk>DERIV f x :> df; GDERIV g x :> dg\<rbrakk>
+ \<Longrightarrow> GDERIV (\<lambda>x. scaleR (f x) (g x)) x
+ :> (scaleR (f x) dg + scaleR df (g x))"
+ unfolding gderiv_def deriv_fderiv inner_right.add inner_right.scaleR
+ apply (rule FDERIV_subst)
+ apply (erule (1) scaleR.FDERIV)
+ apply (simp add: mult_ac)
+ done
+
+lemma GDERIV_mult:
+ "\<lbrakk>GDERIV f x :> df; GDERIV g x :> dg\<rbrakk>
+ \<Longrightarrow> GDERIV (\<lambda>x. f x * g x) x :> scaleR (f x) dg + scaleR (g x) df"
+ unfolding gderiv_def
+ apply (rule FDERIV_subst)
+ apply (erule (1) FDERIV_mult)
+ apply (simp add: inner_distrib inner_scaleR mult_ac)
+ done
+
+lemma GDERIV_inverse:
+ "\<lbrakk>GDERIV f x :> df; f x \<noteq> 0\<rbrakk>
+ \<Longrightarrow> GDERIV (\<lambda>x. inverse (f x)) x :> - (inverse (f x))\<twosuperior> *\<^sub>R df"
+ apply (erule GDERIV_DERIV_compose)
+ apply (erule DERIV_inverse [folded numeral_2_eq_2])
+ done
+
+lemma GDERIV_norm:
+ assumes "x \<noteq> 0" shows "GDERIV (\<lambda>x. norm x) x :> sgn x"
+proof -
+ have 1: "FDERIV (\<lambda>x. inner x x) x :> (\<lambda>h. inner x h + inner h x)"
+ by (intro inner.FDERIV FDERIV_ident)
+ have 2: "(\<lambda>h. inner x h + inner h x) = (\<lambda>h. inner h (scaleR 2 x))"
+ by (simp add: expand_fun_eq inner_scaleR inner_commute)
+ have "0 < inner x x" using `x \<noteq> 0` by simp
+ then have 3: "DERIV sqrt (inner x x) :> (inverse (sqrt (inner x x)) / 2)"
+ by (rule DERIV_real_sqrt)
+ have 4: "(inverse (sqrt (inner x x)) / 2) *\<^sub>R 2 *\<^sub>R x = sgn x"
+ by (simp add: sgn_div_norm norm_eq_sqrt_inner)
+ show ?thesis
+ unfolding norm_eq_sqrt_inner
+ apply (rule GDERIV_subst [OF _ 4])
+ apply (rule GDERIV_DERIV_compose [where g=sqrt and df="scaleR 2 x"])
+ apply (subst gderiv_def)
+ apply (rule FDERIV_subst [OF _ 2])
+ apply (rule 1)
+ apply (rule 3)
+ done
+qed
+
+lemmas FDERIV_norm = GDERIV_norm [unfolded gderiv_def]
+
+end
--- a/src/HOL/Library/Library.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Library/Library.thy Thu Feb 26 11:21:29 2009 +0000
@@ -5,6 +5,7 @@
AssocList
BigO
Binomial
+ Bit
Boolean_Algebra
Char_ord
Code_Char_chr
@@ -22,9 +23,11 @@
Executable_Set
Float
Formal_Power_Series
+ FrechetDeriv
FuncSet
Fundamental_Theorem_Algebra
Infinite_Set
+ Inner_Product
ListVector
Mapping
Multiset
@@ -35,7 +38,10 @@
Option_ord
Permutation
Pocklington
+ Poly_Deriv
+ Polynomial
Primes
+ Product_Vector
Quickcheck
Quicksort
Quotient
--- a/src/HOL/Library/Numeral_Type.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Library/Numeral_Type.thy Thu Feb 26 11:21:29 2009 +0000
@@ -42,36 +42,87 @@
end
*}
-lemma card_unit: "CARD(unit) = 1"
+lemma card_unit [simp]: "CARD(unit) = 1"
unfolding UNIV_unit by simp
-lemma card_bool: "CARD(bool) = 2"
+lemma card_bool [simp]: "CARD(bool) = 2"
unfolding UNIV_bool by simp
-lemma card_prod: "CARD('a::finite \<times> 'b::finite) = CARD('a) * CARD('b)"
+lemma card_prod [simp]: "CARD('a \<times> 'b) = CARD('a::finite) * CARD('b::finite)"
unfolding UNIV_Times_UNIV [symmetric] by (simp only: card_cartesian_product)
-lemma card_sum: "CARD('a::finite + 'b::finite) = CARD('a) + CARD('b)"
+lemma card_sum [simp]: "CARD('a + 'b) = CARD('a::finite) + CARD('b::finite)"
unfolding UNIV_Plus_UNIV [symmetric] by (simp only: finite card_Plus)
-lemma card_option: "CARD('a::finite option) = Suc CARD('a)"
+lemma card_option [simp]: "CARD('a option) = Suc CARD('a::finite)"
unfolding insert_None_conv_UNIV [symmetric]
apply (subgoal_tac "(None::'a option) \<notin> range Some")
- apply (simp add: finite card_image)
+ apply (simp add: card_image)
apply fast
done
-lemma card_set: "CARD('a::finite set) = 2 ^ CARD('a)"
+lemma card_set [simp]: "CARD('a set) = 2 ^ CARD('a::finite)"
unfolding Pow_UNIV [symmetric]
by (simp only: card_Pow finite numeral_2_eq_2)
+lemma card_nat [simp]: "CARD(nat) = 0"
+ by (simp add: infinite_UNIV_nat card_eq_0_iff)
+
+
+subsection {* Classes with at least 1 and 2 *}
+
+text {* Class finite already captures "at least 1" *}
+
+lemma zero_less_card_finite [simp]: "0 < CARD('a::finite)"
+ unfolding neq0_conv [symmetric] by simp
+
+lemma one_le_card_finite [simp]: "Suc 0 \<le> CARD('a::finite)"
+ by (simp add: less_Suc_eq_le [symmetric])
+
+text {* Class for cardinality "at least 2" *}
+
+class card2 = finite +
+ assumes two_le_card: "2 \<le> CARD('a)"
+
+lemma one_less_card: "Suc 0 < CARD('a::card2)"
+ using two_le_card [where 'a='a] by simp
+
+lemma one_less_int_card: "1 < int CARD('a::card2)"
+ using one_less_card [where 'a='a] by simp
+
subsection {* Numeral Types *}
typedef (open) num0 = "UNIV :: nat set" ..
typedef (open) num1 = "UNIV :: unit set" ..
-typedef (open) 'a bit0 = "UNIV :: (bool * 'a) set" ..
-typedef (open) 'a bit1 = "UNIV :: (bool * 'a) option set" ..
+
+typedef (open) 'a bit0 = "{0 ..< 2 * int CARD('a::finite)}"
+proof
+ show "0 \<in> {0 ..< 2 * int CARD('a)}"
+ by simp
+qed
+
+typedef (open) 'a bit1 = "{0 ..< 1 + 2 * int CARD('a::finite)}"
+proof
+ show "0 \<in> {0 ..< 1 + 2 * int CARD('a)}"
+ by simp
+qed
+
+lemma card_num0 [simp]: "CARD (num0) = 0"
+ unfolding type_definition.card [OF type_definition_num0]
+ by simp
+
+lemma card_num1 [simp]: "CARD(num1) = 1"
+ unfolding type_definition.card [OF type_definition_num1]
+ by (simp only: card_unit)
+
+lemma card_bit0 [simp]: "CARD('a bit0) = 2 * CARD('a::finite)"
+ unfolding type_definition.card [OF type_definition_bit0]
+ by simp
+
+lemma card_bit1 [simp]: "CARD('a bit1) = Suc (2 * CARD('a::finite))"
+ unfolding type_definition.card [OF type_definition_bit1]
+ by simp
instance num1 :: finite
proof
@@ -80,46 +131,263 @@
using finite by (rule finite_imageI)
qed
-instance bit0 :: (finite) finite
+instance bit0 :: (finite) card2
proof
show "finite (UNIV::'a bit0 set)"
unfolding type_definition.univ [OF type_definition_bit0]
- using finite by (rule finite_imageI)
+ by simp
+ show "2 \<le> CARD('a bit0)"
+ by simp
qed
-instance bit1 :: (finite) finite
+instance bit1 :: (finite) card2
proof
show "finite (UNIV::'a bit1 set)"
unfolding type_definition.univ [OF type_definition_bit1]
- using finite by (rule finite_imageI)
+ by simp
+ show "2 \<le> CARD('a bit1)"
+ by simp
qed
-lemma card_num1: "CARD(num1) = 1"
- unfolding type_definition.card [OF type_definition_num1]
- by (simp only: card_unit)
+
+subsection {* Locale for modular arithmetic subtypes *}
+
+locale mod_type =
+ fixes n :: int
+ and Rep :: "'a::{zero,one,plus,times,uminus,minus,power} \<Rightarrow> int"
+ and Abs :: "int \<Rightarrow> 'a::{zero,one,plus,times,uminus,minus,power}"
+ assumes type: "type_definition Rep Abs {0..<n}"
+ and size1: "1 < n"
+ and zero_def: "0 = Abs 0"
+ and one_def: "1 = Abs 1"
+ and add_def: "x + y = Abs ((Rep x + Rep y) mod n)"
+ and mult_def: "x * y = Abs ((Rep x * Rep y) mod n)"
+ and diff_def: "x - y = Abs ((Rep x - Rep y) mod n)"
+ and minus_def: "- x = Abs ((- Rep x) mod n)"
+ and power_def: "x ^ k = Abs (Rep x ^ k mod n)"
+begin
+
+lemma size0: "0 < n"
+by (cut_tac size1, simp)
+
+lemmas definitions =
+ zero_def one_def add_def mult_def minus_def diff_def power_def
+
+lemma Rep_less_n: "Rep x < n"
+by (rule type_definition.Rep [OF type, simplified, THEN conjunct2])
+
+lemma Rep_le_n: "Rep x \<le> n"
+by (rule Rep_less_n [THEN order_less_imp_le])
+
+lemma Rep_inject_sym: "x = y \<longleftrightarrow> Rep x = Rep y"
+by (rule type_definition.Rep_inject [OF type, symmetric])
+
+lemma Rep_inverse: "Abs (Rep x) = x"
+by (rule type_definition.Rep_inverse [OF type])
+
+lemma Abs_inverse: "m \<in> {0..<n} \<Longrightarrow> Rep (Abs m) = m"
+by (rule type_definition.Abs_inverse [OF type])
+
+lemma Rep_Abs_mod: "Rep (Abs (m mod n)) = m mod n"
+by (simp add: Abs_inverse IntDiv.pos_mod_conj [OF size0])
+
+lemma Rep_Abs_0: "Rep (Abs 0) = 0"
+by (simp add: Abs_inverse size0)
+
+lemma Rep_0: "Rep 0 = 0"
+by (simp add: zero_def Rep_Abs_0)
+
+lemma Rep_Abs_1: "Rep (Abs 1) = 1"
+by (simp add: Abs_inverse size1)
+
+lemma Rep_1: "Rep 1 = 1"
+by (simp add: one_def Rep_Abs_1)
-lemma card_bit0: "CARD('a::finite bit0) = 2 * CARD('a)"
- unfolding type_definition.card [OF type_definition_bit0]
- by (simp only: card_prod card_bool)
+lemma Rep_mod: "Rep x mod n = Rep x"
+apply (rule_tac x=x in type_definition.Abs_cases [OF type])
+apply (simp add: type_definition.Abs_inverse [OF type])
+apply (simp add: mod_pos_pos_trivial)
+done
+
+lemmas Rep_simps =
+ Rep_inject_sym Rep_inverse Rep_Abs_mod Rep_mod Rep_Abs_0 Rep_Abs_1
+
+lemma comm_ring_1: "OFCLASS('a, comm_ring_1_class)"
+apply (intro_classes, unfold definitions)
+apply (simp_all add: Rep_simps zmod_simps ring_simps)
+done
+
+lemma recpower: "OFCLASS('a, recpower_class)"
+apply (intro_classes, unfold definitions)
+apply (simp_all add: Rep_simps zmod_simps add_ac mult_assoc
+ mod_pos_pos_trivial size1)
+done
+
+end
+
+locale mod_ring = mod_type +
+ constrains n :: int
+ and Rep :: "'a::{number_ring,power} \<Rightarrow> int"
+ and Abs :: "int \<Rightarrow> 'a::{number_ring,power}"
+begin
-lemma card_bit1: "CARD('a::finite bit1) = Suc (2 * CARD('a))"
- unfolding type_definition.card [OF type_definition_bit1]
- by (simp only: card_prod card_option card_bool)
+lemma of_nat_eq: "of_nat k = Abs (int k mod n)"
+apply (induct k)
+apply (simp add: zero_def)
+apply (simp add: Rep_simps add_def one_def zmod_simps add_ac)
+done
+
+lemma of_int_eq: "of_int z = Abs (z mod n)"
+apply (cases z rule: int_diff_cases)
+apply (simp add: Rep_simps of_nat_eq diff_def zmod_simps)
+done
+
+lemma Rep_number_of:
+ "Rep (number_of w) = number_of w mod n"
+by (simp add: number_of_eq of_int_eq Rep_Abs_mod)
+
+lemma iszero_number_of:
+ "iszero (number_of w::'a) \<longleftrightarrow> number_of w mod n = 0"
+by (simp add: Rep_simps number_of_eq of_int_eq iszero_def zero_def)
+
+lemma cases:
+ assumes 1: "\<And>z. \<lbrakk>(x::'a) = of_int z; 0 \<le> z; z < n\<rbrakk> \<Longrightarrow> P"
+ shows "P"
+apply (cases x rule: type_definition.Abs_cases [OF type])
+apply (rule_tac z="y" in 1)
+apply (simp_all add: of_int_eq mod_pos_pos_trivial)
+done
+
+lemma induct:
+ "(\<And>z. \<lbrakk>0 \<le> z; z < n\<rbrakk> \<Longrightarrow> P (of_int z)) \<Longrightarrow> P (x::'a)"
+by (cases x rule: cases) simp
+
+end
+
+
+subsection {* Number ring instances *}
-lemma card_num0: "CARD (num0) = 0"
- by (simp add: infinite_UNIV_nat card_eq_0_iff type_definition.card [OF type_definition_num0])
+text {*
+ Unfortunately a number ring instance is not possible for
+ @{typ num1}, since 0 and 1 are not distinct.
+*}
+
+instantiation num1 :: "{comm_ring,comm_monoid_mult,number,recpower}"
+begin
+
+lemma num1_eq_iff: "(x::num1) = (y::num1) \<longleftrightarrow> True"
+ by (induct x, induct y) simp
+
+instance proof
+qed (simp_all add: num1_eq_iff)
+
+end
+
+instantiation
+ bit0 and bit1 :: (finite) "{zero,one,plus,times,uminus,minus,power}"
+begin
+
+definition Abs_bit0' :: "int \<Rightarrow> 'a bit0" where
+ "Abs_bit0' x = Abs_bit0 (x mod int CARD('a bit0))"
+
+definition Abs_bit1' :: "int \<Rightarrow> 'a bit1" where
+ "Abs_bit1' x = Abs_bit1 (x mod int CARD('a bit1))"
+
+definition "0 = Abs_bit0 0"
+definition "1 = Abs_bit0 1"
+definition "x + y = Abs_bit0' (Rep_bit0 x + Rep_bit0 y)"
+definition "x * y = Abs_bit0' (Rep_bit0 x * Rep_bit0 y)"
+definition "x - y = Abs_bit0' (Rep_bit0 x - Rep_bit0 y)"
+definition "- x = Abs_bit0' (- Rep_bit0 x)"
+definition "x ^ k = Abs_bit0' (Rep_bit0 x ^ k)"
+
+definition "0 = Abs_bit1 0"
+definition "1 = Abs_bit1 1"
+definition "x + y = Abs_bit1' (Rep_bit1 x + Rep_bit1 y)"
+definition "x * y = Abs_bit1' (Rep_bit1 x * Rep_bit1 y)"
+definition "x - y = Abs_bit1' (Rep_bit1 x - Rep_bit1 y)"
+definition "- x = Abs_bit1' (- Rep_bit1 x)"
+definition "x ^ k = Abs_bit1' (Rep_bit1 x ^ k)"
+
+instance ..
+
+end
-lemmas card_univ_simps [simp] =
- card_unit
- card_bool
- card_prod
- card_sum
- card_option
- card_set
- card_num1
- card_bit0
- card_bit1
- card_num0
+interpretation bit0!:
+ mod_type "int CARD('a::finite bit0)"
+ "Rep_bit0 :: 'a::finite bit0 \<Rightarrow> int"
+ "Abs_bit0 :: int \<Rightarrow> 'a::finite bit0"
+apply (rule mod_type.intro)
+apply (simp add: int_mult type_definition_bit0)
+apply (rule one_less_int_card)
+apply (rule zero_bit0_def)
+apply (rule one_bit0_def)
+apply (rule plus_bit0_def [unfolded Abs_bit0'_def])
+apply (rule times_bit0_def [unfolded Abs_bit0'_def])
+apply (rule minus_bit0_def [unfolded Abs_bit0'_def])
+apply (rule uminus_bit0_def [unfolded Abs_bit0'_def])
+apply (rule power_bit0_def [unfolded Abs_bit0'_def])
+done
+
+interpretation bit1!:
+ mod_type "int CARD('a::finite bit1)"
+ "Rep_bit1 :: 'a::finite bit1 \<Rightarrow> int"
+ "Abs_bit1 :: int \<Rightarrow> 'a::finite bit1"
+apply (rule mod_type.intro)
+apply (simp add: int_mult type_definition_bit1)
+apply (rule one_less_int_card)
+apply (rule zero_bit1_def)
+apply (rule one_bit1_def)
+apply (rule plus_bit1_def [unfolded Abs_bit1'_def])
+apply (rule times_bit1_def [unfolded Abs_bit1'_def])
+apply (rule minus_bit1_def [unfolded Abs_bit1'_def])
+apply (rule uminus_bit1_def [unfolded Abs_bit1'_def])
+apply (rule power_bit1_def [unfolded Abs_bit1'_def])
+done
+
+instance bit0 :: (finite) "{comm_ring_1,recpower}"
+ by (rule bit0.comm_ring_1 bit0.recpower)+
+
+instance bit1 :: (finite) "{comm_ring_1,recpower}"
+ by (rule bit1.comm_ring_1 bit1.recpower)+
+
+instantiation bit0 and bit1 :: (finite) number_ring
+begin
+
+definition "(number_of w :: _ bit0) = of_int w"
+
+definition "(number_of w :: _ bit1) = of_int w"
+
+instance proof
+qed (rule number_of_bit0_def number_of_bit1_def)+
+
+end
+
+interpretation bit0!:
+ mod_ring "int CARD('a::finite bit0)"
+ "Rep_bit0 :: 'a::finite bit0 \<Rightarrow> int"
+ "Abs_bit0 :: int \<Rightarrow> 'a::finite bit0"
+ ..
+
+interpretation bit1!:
+ mod_ring "int CARD('a::finite bit1)"
+ "Rep_bit1 :: 'a::finite bit1 \<Rightarrow> int"
+ "Abs_bit1 :: int \<Rightarrow> 'a::finite bit1"
+ ..
+
+text {* Set up cases, induction, and arithmetic *}
+
+lemmas bit0_cases [case_names of_int, cases type: bit0] = bit0.cases
+lemmas bit1_cases [case_names of_int, cases type: bit1] = bit1.cases
+
+lemmas bit0_induct [case_names of_int, induct type: bit0] = bit0.induct
+lemmas bit1_induct [case_names of_int, induct type: bit1] = bit1.induct
+
+lemmas bit0_iszero_number_of [simp] = bit0.iszero_number_of
+lemmas bit1_iszero_number_of [simp] = bit1.iszero_number_of
+
+declare power_Suc [where ?'a="'a::finite bit0", standard, simp]
+declare power_Suc [where ?'a="'a::finite bit1", standard, simp]
subsection {* Syntax *}
@@ -184,42 +452,10 @@
in [("bit0", bit_tr' 0), ("bit1", bit_tr' 1)] end;
*}
-
-subsection {* Classes with at least 1 and 2 *}
-
-text {* Class finite already captures "at least 1" *}
-
-lemma zero_less_card_finite [simp]:
- "0 < CARD('a::finite)"
-proof (cases "CARD('a::finite) = 0")
- case False thus ?thesis by (simp del: card_0_eq)
-next
- case True
- thus ?thesis by (simp add: finite)
-qed
-
-lemma one_le_card_finite [simp]:
- "Suc 0 <= CARD('a::finite)"
- by (simp add: less_Suc_eq_le [symmetric] zero_less_card_finite)
-
-
-text {* Class for cardinality "at least 2" *}
-
-class card2 = finite +
- assumes two_le_card: "2 <= CARD('a)"
-
-lemma one_less_card: "Suc 0 < CARD('a::card2)"
- using two_le_card [where 'a='a] by simp
-
-instance bit0 :: (finite) card2
- by intro_classes (simp add: one_le_card_finite)
-
-instance bit1 :: (finite) card2
- by intro_classes (simp add: one_le_card_finite)
-
subsection {* Examples *}
lemma "CARD(0) = 0" by simp
lemma "CARD(17) = 17" by simp
+lemma "8 * 11 ^ 3 - 6 = (2::5)" by simp
end
--- a/src/HOL/Library/Permutations.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Library/Permutations.thy Thu Feb 26 11:21:29 2009 +0000
@@ -6,7 +6,7 @@
header {* Permutations, both general and specifically on finite sets.*}
theory Permutations
-imports Main Finite_Cartesian_Product Parity
+imports Main Finite_Cartesian_Product Parity Fact
begin
(* Why should I import Main just to solve the Typerep problem! *)
@@ -683,13 +683,13 @@
(* ------------------------------------------------------------------------- *)
lemma permutes_natset_le:
- assumes p: "p permutes (S:: nat set)" and le: "\<forall>i \<in> S. p i <= i" shows "p = id"
+ assumes p: "p permutes (S::'a::wellorder set)" and le: "\<forall>i \<in> S. p i <= i" shows "p = id"
proof-
{fix n
have "p n = n"
using p le
- proof(induct n arbitrary: S rule: nat_less_induct)
- fix n S assume H: "\<forall> m< n. \<forall>S. p permutes S \<longrightarrow> (\<forall>i\<in>S. p i \<le> i) \<longrightarrow> p m = m"
+ proof(induct n arbitrary: S rule: less_induct)
+ fix n S assume H: "\<And>m S. \<lbrakk>m < n; p permutes S; \<forall>i\<in>S. p i \<le> i\<rbrakk> \<Longrightarrow> p m = m"
"p permutes S" "\<forall>i \<in>S. p i \<le> i"
{assume "n \<notin> S"
with H(2) have "p n = n" unfolding permutes_def by metis}
@@ -699,7 +699,7 @@
moreover{assume h: "p n < n"
from H h have "p (p n) = p n" by metis
with permutes_inj[OF H(2)] have "p n = n" unfolding inj_on_def by blast
- with h have False by arith}
+ with h have False by simp}
ultimately have "p n = n" by blast }
ultimately show "p n = n" by blast
qed}
@@ -707,7 +707,7 @@
qed
lemma permutes_natset_ge:
- assumes p: "p permutes (S:: nat set)" and le: "\<forall>i \<in> S. p i \<ge> i" shows "p = id"
+ assumes p: "p permutes (S::'a::wellorder set)" and le: "\<forall>i \<in> S. p i \<ge> i" shows "p = id"
proof-
{fix i assume i: "i \<in> S"
from i permutes_in_image[OF permutes_inv[OF p]] have "inv p i \<in> S" by simp
@@ -757,13 +757,13 @@
done
term setsum
-lemma setsum_permutations_inverse: "setsum f {p. p permutes {m..n}} = setsum (\<lambda>p. f(inv p)) {p. p permutes {m..n}}" (is "?lhs = ?rhs")
+lemma setsum_permutations_inverse: "setsum f {p. p permutes S} = setsum (\<lambda>p. f(inv p)) {p. p permutes S}" (is "?lhs = ?rhs")
proof-
- let ?S = "{p . p permutes {m .. n}}"
+ let ?S = "{p . p permutes S}"
have th0: "inj_on inv ?S"
proof(auto simp add: inj_on_def)
fix q r
- assume q: "q permutes {m .. n}" and r: "r permutes {m .. n}" and qr: "inv q = inv r"
+ assume q: "q permutes S" and r: "r permutes S" and qr: "inv q = inv r"
hence "inv (inv q) = inv (inv r)" by simp
with permutes_inv_inv[OF q] permutes_inv_inv[OF r]
show "q = r" by metis
@@ -774,17 +774,17 @@
qed
lemma setum_permutations_compose_left:
- assumes q: "q permutes {m..n}"
- shows "setsum f {p. p permutes {m..n}} =
- setsum (\<lambda>p. f(q o p)) {p. p permutes {m..n}}" (is "?lhs = ?rhs")
+ assumes q: "q permutes S"
+ shows "setsum f {p. p permutes S} =
+ setsum (\<lambda>p. f(q o p)) {p. p permutes S}" (is "?lhs = ?rhs")
proof-
- let ?S = "{p. p permutes {m..n}}"
+ let ?S = "{p. p permutes S}"
have th0: "?rhs = setsum (f o (op o q)) ?S" by (simp add: o_def)
have th1: "inj_on (op o q) ?S"
apply (auto simp add: inj_on_def)
proof-
fix p r
- assume "p permutes {m..n}" and r:"r permutes {m..n}" and rp: "q \<circ> p = q \<circ> r"
+ assume "p permutes S" and r:"r permutes S" and rp: "q \<circ> p = q \<circ> r"
hence "inv q o q o p = inv q o q o r" by (simp add: o_assoc[symmetric])
with permutes_inj[OF q, unfolded inj_iff]
@@ -796,17 +796,17 @@
qed
lemma sum_permutations_compose_right:
- assumes q: "q permutes {m..n}"
- shows "setsum f {p. p permutes {m..n}} =
- setsum (\<lambda>p. f(p o q)) {p. p permutes {m..n}}" (is "?lhs = ?rhs")
+ assumes q: "q permutes S"
+ shows "setsum f {p. p permutes S} =
+ setsum (\<lambda>p. f(p o q)) {p. p permutes S}" (is "?lhs = ?rhs")
proof-
- let ?S = "{p. p permutes {m..n}}"
+ let ?S = "{p. p permutes S}"
have th0: "?rhs = setsum (f o (\<lambda>p. p o q)) ?S" by (simp add: o_def)
have th1: "inj_on (\<lambda>p. p o q) ?S"
apply (auto simp add: inj_on_def)
proof-
fix p r
- assume "p permutes {m..n}" and r:"r permutes {m..n}" and rp: "p o q = r o q"
+ assume "p permutes S" and r:"r permutes S" and rp: "p o q = r o q"
hence "p o (q o inv q) = r o (q o inv q)" by (simp add: o_assoc)
with permutes_surj[OF q, unfolded surj_iff]
--- a/src/HOL/Library/Pocklington.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Library/Pocklington.thy Thu Feb 26 11:21:29 2009 +0000
@@ -873,7 +873,7 @@
from lh[unfolded nat_mod]
obtain q1 q2 where q12:"a ^ d + n * q1 = 1 + n * q2" by blast
hence "a ^ d + n * q1 - n * q2 = 1" by simp
- with dvd_diff [OF dvd_add [OF divides_rexp[OF p(2), of d'] dvd_mult2[OF p(1), of q1]] dvd_mult2[OF p(1), of q2]] d' have "p dvd 1" by simp
+ with nat_dvd_diff [OF dvd_add [OF divides_rexp[OF p(2), of d'] dvd_mult2[OF p(1), of q1]] dvd_mult2[OF p(1), of q2]] d' have "p dvd 1" by simp
with p(3) have False by simp
hence ?rhs ..}
ultimately have ?rhs by blast}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Library/Poly_Deriv.thy Thu Feb 26 11:21:29 2009 +0000
@@ -0,0 +1,316 @@
+(* Title: Poly_Deriv.thy
+ Author: Amine Chaieb
+ Ported to new Polynomial library by Brian Huffman
+*)
+
+header{* Polynomials and Differentiation *}
+
+theory Poly_Deriv
+imports Deriv Polynomial
+begin
+
+subsection {* Derivatives of univariate polynomials *}
+
+definition
+ pderiv :: "'a::real_normed_field poly \<Rightarrow> 'a poly" where
+ "pderiv = poly_rec 0 (\<lambda>a p p'. p + pCons 0 p')"
+
+lemma pderiv_0 [simp]: "pderiv 0 = 0"
+ unfolding pderiv_def by (simp add: poly_rec_0)
+
+lemma pderiv_pCons: "pderiv (pCons a p) = p + pCons 0 (pderiv p)"
+ unfolding pderiv_def by (simp add: poly_rec_pCons)
+
+lemma coeff_pderiv: "coeff (pderiv p) n = of_nat (Suc n) * coeff p (Suc n)"
+ apply (induct p arbitrary: n, simp)
+ apply (simp add: pderiv_pCons coeff_pCons algebra_simps split: nat.split)
+ done
+
+lemma pderiv_eq_0_iff: "pderiv p = 0 \<longleftrightarrow> degree p = 0"
+ apply (rule iffI)
+ apply (cases p, simp)
+ apply (simp add: expand_poly_eq coeff_pderiv del: of_nat_Suc)
+ apply (simp add: expand_poly_eq coeff_pderiv coeff_eq_0)
+ done
+
+lemma degree_pderiv: "degree (pderiv p) = degree p - 1"
+ apply (rule order_antisym [OF degree_le])
+ apply (simp add: coeff_pderiv coeff_eq_0)
+ apply (cases "degree p", simp)
+ apply (rule le_degree)
+ apply (simp add: coeff_pderiv del: of_nat_Suc)
+ apply (rule subst, assumption)
+ apply (rule leading_coeff_neq_0, clarsimp)
+ done
+
+lemma pderiv_singleton [simp]: "pderiv [:a:] = 0"
+by (simp add: pderiv_pCons)
+
+lemma pderiv_add: "pderiv (p + q) = pderiv p + pderiv q"
+by (rule poly_ext, simp add: coeff_pderiv algebra_simps)
+
+lemma pderiv_minus: "pderiv (- p) = - pderiv p"
+by (rule poly_ext, simp add: coeff_pderiv)
+
+lemma pderiv_diff: "pderiv (p - q) = pderiv p - pderiv q"
+by (rule poly_ext, simp add: coeff_pderiv algebra_simps)
+
+lemma pderiv_smult: "pderiv (smult a p) = smult a (pderiv p)"
+by (rule poly_ext, simp add: coeff_pderiv algebra_simps)
+
+lemma pderiv_mult: "pderiv (p * q) = p * pderiv q + q * pderiv p"
+apply (induct p)
+apply simp
+apply (simp add: pderiv_add pderiv_smult pderiv_pCons algebra_simps)
+done
+
+lemma pderiv_power_Suc:
+ "pderiv (p ^ Suc n) = smult (of_nat (Suc n)) (p ^ n) * pderiv p"
+apply (induct n)
+apply simp
+apply (subst power_Suc)
+apply (subst pderiv_mult)
+apply (erule ssubst)
+apply (simp add: smult_add_left algebra_simps)
+done
+
+lemma DERIV_cmult2: "DERIV f x :> D ==> DERIV (%x. (f x) * c :: real) x :> D * c"
+by (simp add: DERIV_cmult mult_commute [of _ c])
+
+lemma DERIV_pow2: "DERIV (%x. x ^ Suc n) x :> real (Suc n) * (x ^ n)"
+by (rule lemma_DERIV_subst, rule DERIV_pow, simp)
+declare DERIV_pow2 [simp] DERIV_pow [simp]
+
+lemma DERIV_add_const: "DERIV f x :> D ==> DERIV (%x. a + f x :: 'a::real_normed_field) x :> D"
+by (rule lemma_DERIV_subst, rule DERIV_add, auto)
+
+lemma poly_DERIV[simp]: "DERIV (%x. poly p x) x :> poly (pderiv p) x"
+apply (induct p)
+apply simp
+apply (simp add: pderiv_pCons)
+apply (rule lemma_DERIV_subst)
+apply (rule DERIV_add DERIV_mult DERIV_const DERIV_ident | assumption)+
+apply simp
+done
+
+text{* Consequences of the derivative theorem above*}
+
+lemma poly_differentiable[simp]: "(%x. poly p x) differentiable (x::real)"
+apply (simp add: differentiable_def)
+apply (blast intro: poly_DERIV)
+done
+
+lemma poly_isCont[simp]: "isCont (%x. poly p x) (x::real)"
+by (rule poly_DERIV [THEN DERIV_isCont])
+
+lemma poly_IVT_pos: "[| a < b; poly p (a::real) < 0; 0 < poly p b |]
+ ==> \<exists>x. a < x & x < b & (poly p x = 0)"
+apply (cut_tac f = "%x. poly p x" and a = a and b = b and y = 0 in IVT_objl)
+apply (auto simp add: order_le_less)
+done
+
+lemma poly_IVT_neg: "[| (a::real) < b; 0 < poly p a; poly p b < 0 |]
+ ==> \<exists>x. a < x & x < b & (poly p x = 0)"
+by (insert poly_IVT_pos [where p = "- p" ]) simp
+
+lemma poly_MVT: "(a::real) < b ==>
+ \<exists>x. a < x & x < b & (poly p b - poly p a = (b - a) * poly (pderiv p) x)"
+apply (drule_tac f = "poly p" in MVT, auto)
+apply (rule_tac x = z in exI)
+apply (auto simp add: real_mult_left_cancel poly_DERIV [THEN DERIV_unique])
+done
+
+text{*Lemmas for Derivatives*}
+
+lemma order_unique_lemma:
+ fixes p :: "'a::idom poly"
+ assumes "[:-a, 1:] ^ n dvd p \<and> \<not> [:-a, 1:] ^ Suc n dvd p"
+ shows "n = order a p"
+unfolding Polynomial.order_def
+apply (rule Least_equality [symmetric])
+apply (rule assms [THEN conjunct2])
+apply (erule contrapos_np)
+apply (rule power_le_dvd)
+apply (rule assms [THEN conjunct1])
+apply simp
+done
+
+lemma lemma_order_pderiv1:
+ "pderiv ([:- a, 1:] ^ Suc n * q) = [:- a, 1:] ^ Suc n * pderiv q +
+ smult (of_nat (Suc n)) (q * [:- a, 1:] ^ n)"
+apply (simp only: pderiv_mult pderiv_power_Suc)
+apply (simp del: power_poly_Suc of_nat_Suc add: pderiv_pCons)
+done
+
+lemma dvd_add_cancel1:
+ fixes a b c :: "'a::comm_ring_1"
+ shows "a dvd b + c \<Longrightarrow> a dvd b \<Longrightarrow> a dvd c"
+ by (drule (1) Ring_and_Field.dvd_diff, simp)
+
+lemma lemma_order_pderiv [rule_format]:
+ "\<forall>p q a. 0 < n &
+ pderiv p \<noteq> 0 &
+ p = [:- a, 1:] ^ n * q & ~ [:- a, 1:] dvd q
+ --> n = Suc (order a (pderiv p))"
+ apply (cases "n", safe, rename_tac n p q a)
+ apply (rule order_unique_lemma)
+ apply (rule conjI)
+ apply (subst lemma_order_pderiv1)
+ apply (rule dvd_add)
+ apply (rule dvd_mult2)
+ apply (rule le_imp_power_dvd, simp)
+ apply (rule dvd_smult)
+ apply (rule dvd_mult)
+ apply (rule dvd_refl)
+ apply (subst lemma_order_pderiv1)
+ apply (erule contrapos_nn) back
+ apply (subgoal_tac "[:- a, 1:] ^ Suc n dvd q * [:- a, 1:] ^ n")
+ apply (simp del: mult_pCons_left)
+ apply (drule dvd_add_cancel1)
+ apply (simp del: mult_pCons_left)
+ apply (drule dvd_smult_cancel, simp del: of_nat_Suc)
+ apply assumption
+done
+
+lemma order_decomp:
+ "p \<noteq> 0
+ ==> \<exists>q. p = [:-a, 1:] ^ (order a p) * q &
+ ~([:-a, 1:] dvd q)"
+apply (drule order [where a=a])
+apply (erule conjE)
+apply (erule dvdE)
+apply (rule exI)
+apply (rule conjI, assumption)
+apply (erule contrapos_nn)
+apply (erule ssubst) back
+apply (subst power_Suc2)
+apply (erule mult_dvd_mono [OF dvd_refl])
+done
+
+lemma order_pderiv: "[| pderiv p \<noteq> 0; order a p \<noteq> 0 |]
+ ==> (order a p = Suc (order a (pderiv p)))"
+apply (case_tac "p = 0", simp)
+apply (drule_tac a = a and p = p in order_decomp)
+using neq0_conv
+apply (blast intro: lemma_order_pderiv)
+done
+
+lemma order_mult: "p * q \<noteq> 0 \<Longrightarrow> order a (p * q) = order a p + order a q"
+proof -
+ def i \<equiv> "order a p"
+ def j \<equiv> "order a q"
+ def t \<equiv> "[:-a, 1:]"
+ have t_dvd_iff: "\<And>u. t dvd u \<longleftrightarrow> poly u a = 0"
+ unfolding t_def by (simp add: dvd_iff_poly_eq_0)
+ assume "p * q \<noteq> 0"
+ then show "order a (p * q) = i + j"
+ apply clarsimp
+ apply (drule order [where a=a and p=p, folded i_def t_def])
+ apply (drule order [where a=a and p=q, folded j_def t_def])
+ apply clarify
+ apply (rule order_unique_lemma [symmetric], fold t_def)
+ apply (erule dvdE)+
+ apply (simp add: power_add t_dvd_iff)
+ done
+qed
+
+text{*Now justify the standard squarefree decomposition, i.e. f / gcd(f,f'). *}
+
+lemma order_divides: "[:-a, 1:] ^ n dvd p \<longleftrightarrow> p = 0 \<or> n \<le> order a p"
+apply (cases "p = 0", auto)
+apply (drule order_2 [where a=a and p=p])
+apply (erule contrapos_np)
+apply (erule power_le_dvd)
+apply simp
+apply (erule power_le_dvd [OF order_1])
+done
+
+lemma poly_squarefree_decomp_order:
+ assumes "pderiv p \<noteq> 0"
+ and p: "p = q * d"
+ and p': "pderiv p = e * d"
+ and d: "d = r * p + s * pderiv p"
+ shows "order a q = (if order a p = 0 then 0 else 1)"
+proof (rule classical)
+ assume 1: "order a q \<noteq> (if order a p = 0 then 0 else 1)"
+ from `pderiv p \<noteq> 0` have "p \<noteq> 0" by auto
+ with p have "order a p = order a q + order a d"
+ by (simp add: order_mult)
+ with 1 have "order a p \<noteq> 0" by (auto split: if_splits)
+ have "order a (pderiv p) = order a e + order a d"
+ using `pderiv p \<noteq> 0` `pderiv p = e * d` by (simp add: order_mult)
+ have "order a p = Suc (order a (pderiv p))"
+ using `pderiv p \<noteq> 0` `order a p \<noteq> 0` by (rule order_pderiv)
+ have "d \<noteq> 0" using `p \<noteq> 0` `p = q * d` by simp
+ have "([:-a, 1:] ^ (order a (pderiv p))) dvd d"
+ apply (simp add: d)
+ apply (rule dvd_add)
+ apply (rule dvd_mult)
+ apply (simp add: order_divides `p \<noteq> 0`
+ `order a p = Suc (order a (pderiv p))`)
+ apply (rule dvd_mult)
+ apply (simp add: order_divides)
+ done
+ then have "order a (pderiv p) \<le> order a d"
+ using `d \<noteq> 0` by (simp add: order_divides)
+ show ?thesis
+ using `order a p = order a q + order a d`
+ using `order a (pderiv p) = order a e + order a d`
+ using `order a p = Suc (order a (pderiv p))`
+ using `order a (pderiv p) \<le> order a d`
+ by auto
+qed
+
+lemma poly_squarefree_decomp_order2: "[| pderiv p \<noteq> 0;
+ p = q * d;
+ pderiv p = e * d;
+ d = r * p + s * pderiv p
+ |] ==> \<forall>a. order a q = (if order a p = 0 then 0 else 1)"
+apply (blast intro: poly_squarefree_decomp_order)
+done
+
+lemma order_pderiv2: "[| pderiv p \<noteq> 0; order a p \<noteq> 0 |]
+ ==> (order a (pderiv p) = n) = (order a p = Suc n)"
+apply (auto dest: order_pderiv)
+done
+
+definition
+ rsquarefree :: "'a::idom poly => bool" where
+ "rsquarefree p = (p \<noteq> 0 & (\<forall>a. (order a p = 0) | (order a p = 1)))"
+
+lemma pderiv_iszero: "pderiv p = 0 \<Longrightarrow> \<exists>h. p = [:h:]"
+apply (simp add: pderiv_eq_0_iff)
+apply (case_tac p, auto split: if_splits)
+done
+
+lemma rsquarefree_roots:
+ "rsquarefree p = (\<forall>a. ~(poly p a = 0 & poly (pderiv p) a = 0))"
+apply (simp add: rsquarefree_def)
+apply (case_tac "p = 0", simp, simp)
+apply (case_tac "pderiv p = 0")
+apply simp
+apply (drule pderiv_iszero, clarify)
+apply simp
+apply (rule allI)
+apply (cut_tac p = "[:h:]" and a = a in order_root)
+apply simp
+apply (auto simp add: order_root order_pderiv2)
+apply (erule_tac x="a" in allE, simp)
+done
+
+lemma poly_squarefree_decomp:
+ assumes "pderiv p \<noteq> 0"
+ and "p = q * d"
+ and "pderiv p = e * d"
+ and "d = r * p + s * pderiv p"
+ shows "rsquarefree q & (\<forall>a. (poly q a = 0) = (poly p a = 0))"
+proof -
+ from `pderiv p \<noteq> 0` have "p \<noteq> 0" by auto
+ with `p = q * d` have "q \<noteq> 0" by simp
+ have "\<forall>a. order a q = (if order a p = 0 then 0 else 1)"
+ using assms by (rule poly_squarefree_decomp_order2)
+ with `p \<noteq> 0` `q \<noteq> 0` show ?thesis
+ by (simp add: rsquarefree_def order_root)
+qed
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Library/Polynomial.thy Thu Feb 26 11:21:29 2009 +0000
@@ -0,0 +1,1462 @@
+(* Title: HOL/Polynomial.thy
+ Author: Brian Huffman
+ Based on an earlier development by Clemens Ballarin
+*)
+
+header {* Univariate Polynomials *}
+
+theory Polynomial
+imports Plain SetInterval Main
+begin
+
+subsection {* Definition of type @{text poly} *}
+
+typedef (Poly) 'a poly = "{f::nat \<Rightarrow> 'a::zero. \<exists>n. \<forall>i>n. f i = 0}"
+ morphisms coeff Abs_poly
+ by auto
+
+lemma expand_poly_eq: "p = q \<longleftrightarrow> (\<forall>n. coeff p n = coeff q n)"
+by (simp add: coeff_inject [symmetric] expand_fun_eq)
+
+lemma poly_ext: "(\<And>n. coeff p n = coeff q n) \<Longrightarrow> p = q"
+by (simp add: expand_poly_eq)
+
+
+subsection {* Degree of a polynomial *}
+
+definition
+ degree :: "'a::zero poly \<Rightarrow> nat" where
+ "degree p = (LEAST n. \<forall>i>n. coeff p i = 0)"
+
+lemma coeff_eq_0: "degree p < n \<Longrightarrow> coeff p n = 0"
+proof -
+ have "coeff p \<in> Poly"
+ by (rule coeff)
+ hence "\<exists>n. \<forall>i>n. coeff p i = 0"
+ unfolding Poly_def by simp
+ hence "\<forall>i>degree p. coeff p i = 0"
+ unfolding degree_def by (rule LeastI_ex)
+ moreover assume "degree p < n"
+ ultimately show ?thesis by simp
+qed
+
+lemma le_degree: "coeff p n \<noteq> 0 \<Longrightarrow> n \<le> degree p"
+ by (erule contrapos_np, rule coeff_eq_0, simp)
+
+lemma degree_le: "\<forall>i>n. coeff p i = 0 \<Longrightarrow> degree p \<le> n"
+ unfolding degree_def by (erule Least_le)
+
+lemma less_degree_imp: "n < degree p \<Longrightarrow> \<exists>i>n. coeff p i \<noteq> 0"
+ unfolding degree_def by (drule not_less_Least, simp)
+
+
+subsection {* The zero polynomial *}
+
+instantiation poly :: (zero) zero
+begin
+
+definition
+ zero_poly_def: "0 = Abs_poly (\<lambda>n. 0)"
+
+instance ..
+end
+
+lemma coeff_0 [simp]: "coeff 0 n = 0"
+ unfolding zero_poly_def
+ by (simp add: Abs_poly_inverse Poly_def)
+
+lemma degree_0 [simp]: "degree 0 = 0"
+ by (rule order_antisym [OF degree_le le0]) simp
+
+lemma leading_coeff_neq_0:
+ assumes "p \<noteq> 0" shows "coeff p (degree p) \<noteq> 0"
+proof (cases "degree p")
+ case 0
+ from `p \<noteq> 0` have "\<exists>n. coeff p n \<noteq> 0"
+ by (simp add: expand_poly_eq)
+ then obtain n where "coeff p n \<noteq> 0" ..
+ hence "n \<le> degree p" by (rule le_degree)
+ with `coeff p n \<noteq> 0` and `degree p = 0`
+ show "coeff p (degree p) \<noteq> 0" by simp
+next
+ case (Suc n)
+ from `degree p = Suc n` have "n < degree p" by simp
+ hence "\<exists>i>n. coeff p i \<noteq> 0" by (rule less_degree_imp)
+ then obtain i where "n < i" and "coeff p i \<noteq> 0" by fast
+ from `degree p = Suc n` and `n < i` have "degree p \<le> i" by simp
+ also from `coeff p i \<noteq> 0` have "i \<le> degree p" by (rule le_degree)
+ finally have "degree p = i" .
+ with `coeff p i \<noteq> 0` show "coeff p (degree p) \<noteq> 0" by simp
+qed
+
+lemma leading_coeff_0_iff [simp]: "coeff p (degree p) = 0 \<longleftrightarrow> p = 0"
+ by (cases "p = 0", simp, simp add: leading_coeff_neq_0)
+
+
+subsection {* List-style constructor for polynomials *}
+
+definition
+ pCons :: "'a::zero \<Rightarrow> 'a poly \<Rightarrow> 'a poly"
+where
+ [code del]: "pCons a p = Abs_poly (nat_case a (coeff p))"
+
+syntax
+ "_poly" :: "args \<Rightarrow> 'a poly" ("[:(_):]")
+
+translations
+ "[:x, xs:]" == "CONST pCons x [:xs:]"
+ "[:x:]" == "CONST pCons x 0"
+
+lemma Poly_nat_case: "f \<in> Poly \<Longrightarrow> nat_case a f \<in> Poly"
+ unfolding Poly_def by (auto split: nat.split)
+
+lemma coeff_pCons:
+ "coeff (pCons a p) = nat_case a (coeff p)"
+ unfolding pCons_def
+ by (simp add: Abs_poly_inverse Poly_nat_case coeff)
+
+lemma coeff_pCons_0 [simp]: "coeff (pCons a p) 0 = a"
+ by (simp add: coeff_pCons)
+
+lemma coeff_pCons_Suc [simp]: "coeff (pCons a p) (Suc n) = coeff p n"
+ by (simp add: coeff_pCons)
+
+lemma degree_pCons_le: "degree (pCons a p) \<le> Suc (degree p)"
+by (rule degree_le, simp add: coeff_eq_0 coeff_pCons split: nat.split)
+
+lemma degree_pCons_eq:
+ "p \<noteq> 0 \<Longrightarrow> degree (pCons a p) = Suc (degree p)"
+apply (rule order_antisym [OF degree_pCons_le])
+apply (rule le_degree, simp)
+done
+
+lemma degree_pCons_0: "degree (pCons a 0) = 0"
+apply (rule order_antisym [OF _ le0])
+apply (rule degree_le, simp add: coeff_pCons split: nat.split)
+done
+
+lemma degree_pCons_eq_if [simp]:
+ "degree (pCons a p) = (if p = 0 then 0 else Suc (degree p))"
+apply (cases "p = 0", simp_all)
+apply (rule order_antisym [OF _ le0])
+apply (rule degree_le, simp add: coeff_pCons split: nat.split)
+apply (rule order_antisym [OF degree_pCons_le])
+apply (rule le_degree, simp)
+done
+
+lemma pCons_0_0 [simp]: "pCons 0 0 = 0"
+by (rule poly_ext, simp add: coeff_pCons split: nat.split)
+
+lemma pCons_eq_iff [simp]:
+ "pCons a p = pCons b q \<longleftrightarrow> a = b \<and> p = q"
+proof (safe)
+ assume "pCons a p = pCons b q"
+ then have "coeff (pCons a p) 0 = coeff (pCons b q) 0" by simp
+ then show "a = b" by simp
+next
+ assume "pCons a p = pCons b q"
+ then have "\<forall>n. coeff (pCons a p) (Suc n) =
+ coeff (pCons b q) (Suc n)" by simp
+ then show "p = q" by (simp add: expand_poly_eq)
+qed
+
+lemma pCons_eq_0_iff [simp]: "pCons a p = 0 \<longleftrightarrow> a = 0 \<and> p = 0"
+ using pCons_eq_iff [of a p 0 0] by simp
+
+lemma Poly_Suc: "f \<in> Poly \<Longrightarrow> (\<lambda>n. f (Suc n)) \<in> Poly"
+ unfolding Poly_def
+ by (clarify, rule_tac x=n in exI, simp)
+
+lemma pCons_cases [cases type: poly]:
+ obtains (pCons) a q where "p = pCons a q"
+proof
+ show "p = pCons (coeff p 0) (Abs_poly (\<lambda>n. coeff p (Suc n)))"
+ by (rule poly_ext)
+ (simp add: Abs_poly_inverse Poly_Suc coeff coeff_pCons
+ split: nat.split)
+qed
+
+lemma pCons_induct [case_names 0 pCons, induct type: poly]:
+ assumes zero: "P 0"
+ assumes pCons: "\<And>a p. P p \<Longrightarrow> P (pCons a p)"
+ shows "P p"
+proof (induct p rule: measure_induct_rule [where f=degree])
+ case (less p)
+ obtain a q where "p = pCons a q" by (rule pCons_cases)
+ have "P q"
+ proof (cases "q = 0")
+ case True
+ then show "P q" by (simp add: zero)
+ next
+ case False
+ then have "degree (pCons a q) = Suc (degree q)"
+ by (rule degree_pCons_eq)
+ then have "degree q < degree p"
+ using `p = pCons a q` by simp
+ then show "P q"
+ by (rule less.hyps)
+ qed
+ then have "P (pCons a q)"
+ by (rule pCons)
+ then show ?case
+ using `p = pCons a q` by simp
+qed
+
+
+subsection {* Recursion combinator for polynomials *}
+
+function
+ poly_rec :: "'b \<Rightarrow> ('a::zero \<Rightarrow> 'a poly \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a poly \<Rightarrow> 'b"
+where
+ poly_rec_pCons_eq_if [simp del, code del]:
+ "poly_rec z f (pCons a p) = f a p (if p = 0 then z else poly_rec z f p)"
+by (case_tac x, rename_tac q, case_tac q, auto)
+
+termination poly_rec
+by (relation "measure (degree \<circ> snd \<circ> snd)", simp)
+ (simp add: degree_pCons_eq)
+
+lemma poly_rec_0:
+ "f 0 0 z = z \<Longrightarrow> poly_rec z f 0 = z"
+ using poly_rec_pCons_eq_if [of z f 0 0] by simp
+
+lemma poly_rec_pCons:
+ "f 0 0 z = z \<Longrightarrow> poly_rec z f (pCons a p) = f a p (poly_rec z f p)"
+ by (simp add: poly_rec_pCons_eq_if poly_rec_0)
+
+
+subsection {* Monomials *}
+
+definition
+ monom :: "'a \<Rightarrow> nat \<Rightarrow> 'a::zero poly" where
+ "monom a m = Abs_poly (\<lambda>n. if m = n then a else 0)"
+
+lemma coeff_monom [simp]: "coeff (monom a m) n = (if m=n then a else 0)"
+ unfolding monom_def
+ by (subst Abs_poly_inverse, auto simp add: Poly_def)
+
+lemma monom_0: "monom a 0 = pCons a 0"
+ by (rule poly_ext, simp add: coeff_pCons split: nat.split)
+
+lemma monom_Suc: "monom a (Suc n) = pCons 0 (monom a n)"
+ by (rule poly_ext, simp add: coeff_pCons split: nat.split)
+
+lemma monom_eq_0 [simp]: "monom 0 n = 0"
+ by (rule poly_ext) simp
+
+lemma monom_eq_0_iff [simp]: "monom a n = 0 \<longleftrightarrow> a = 0"
+ by (simp add: expand_poly_eq)
+
+lemma monom_eq_iff [simp]: "monom a n = monom b n \<longleftrightarrow> a = b"
+ by (simp add: expand_poly_eq)
+
+lemma degree_monom_le: "degree (monom a n) \<le> n"
+ by (rule degree_le, simp)
+
+lemma degree_monom_eq: "a \<noteq> 0 \<Longrightarrow> degree (monom a n) = n"
+ apply (rule order_antisym [OF degree_monom_le])
+ apply (rule le_degree, simp)
+ done
+
+
+subsection {* Addition and subtraction *}
+
+instantiation poly :: (comm_monoid_add) comm_monoid_add
+begin
+
+definition
+ plus_poly_def [code del]:
+ "p + q = Abs_poly (\<lambda>n. coeff p n + coeff q n)"
+
+lemma Poly_add:
+ fixes f g :: "nat \<Rightarrow> 'a"
+ shows "\<lbrakk>f \<in> Poly; g \<in> Poly\<rbrakk> \<Longrightarrow> (\<lambda>n. f n + g n) \<in> Poly"
+ unfolding Poly_def
+ apply (clarify, rename_tac m n)
+ apply (rule_tac x="max m n" in exI, simp)
+ done
+
+lemma coeff_add [simp]:
+ "coeff (p + q) n = coeff p n + coeff q n"
+ unfolding plus_poly_def
+ by (simp add: Abs_poly_inverse coeff Poly_add)
+
+instance proof
+ fix p q r :: "'a poly"
+ show "(p + q) + r = p + (q + r)"
+ by (simp add: expand_poly_eq add_assoc)
+ show "p + q = q + p"
+ by (simp add: expand_poly_eq add_commute)
+ show "0 + p = p"
+ by (simp add: expand_poly_eq)
+qed
+
+end
+
+instance poly :: (cancel_comm_monoid_add) cancel_comm_monoid_add
+proof
+ fix p q r :: "'a poly"
+ assume "p + q = p + r" thus "q = r"
+ by (simp add: expand_poly_eq)
+qed
+
+instantiation poly :: (ab_group_add) ab_group_add
+begin
+
+definition
+ uminus_poly_def [code del]:
+ "- p = Abs_poly (\<lambda>n. - coeff p n)"
+
+definition
+ minus_poly_def [code del]:
+ "p - q = Abs_poly (\<lambda>n. coeff p n - coeff q n)"
+
+lemma Poly_minus:
+ fixes f :: "nat \<Rightarrow> 'a"
+ shows "f \<in> Poly \<Longrightarrow> (\<lambda>n. - f n) \<in> Poly"
+ unfolding Poly_def by simp
+
+lemma Poly_diff:
+ fixes f g :: "nat \<Rightarrow> 'a"
+ shows "\<lbrakk>f \<in> Poly; g \<in> Poly\<rbrakk> \<Longrightarrow> (\<lambda>n. f n - g n) \<in> Poly"
+ unfolding diff_minus by (simp add: Poly_add Poly_minus)
+
+lemma coeff_minus [simp]: "coeff (- p) n = - coeff p n"
+ unfolding uminus_poly_def
+ by (simp add: Abs_poly_inverse coeff Poly_minus)
+
+lemma coeff_diff [simp]:
+ "coeff (p - q) n = coeff p n - coeff q n"
+ unfolding minus_poly_def
+ by (simp add: Abs_poly_inverse coeff Poly_diff)
+
+instance proof
+ fix p q :: "'a poly"
+ show "- p + p = 0"
+ by (simp add: expand_poly_eq)
+ show "p - q = p + - q"
+ by (simp add: expand_poly_eq diff_minus)
+qed
+
+end
+
+lemma add_pCons [simp]:
+ "pCons a p + pCons b q = pCons (a + b) (p + q)"
+ by (rule poly_ext, simp add: coeff_pCons split: nat.split)
+
+lemma minus_pCons [simp]:
+ "- pCons a p = pCons (- a) (- p)"
+ by (rule poly_ext, simp add: coeff_pCons split: nat.split)
+
+lemma diff_pCons [simp]:
+ "pCons a p - pCons b q = pCons (a - b) (p - q)"
+ by (rule poly_ext, simp add: coeff_pCons split: nat.split)
+
+lemma degree_add_le_max: "degree (p + q) \<le> max (degree p) (degree q)"
+ by (rule degree_le, auto simp add: coeff_eq_0)
+
+lemma degree_add_le:
+ "\<lbrakk>degree p \<le> n; degree q \<le> n\<rbrakk> \<Longrightarrow> degree (p + q) \<le> n"
+ by (auto intro: order_trans degree_add_le_max)
+
+lemma degree_add_less:
+ "\<lbrakk>degree p < n; degree q < n\<rbrakk> \<Longrightarrow> degree (p + q) < n"
+ by (auto intro: le_less_trans degree_add_le_max)
+
+lemma degree_add_eq_right:
+ "degree p < degree q \<Longrightarrow> degree (p + q) = degree q"
+ apply (cases "q = 0", simp)
+ apply (rule order_antisym)
+ apply (simp add: degree_add_le)
+ apply (rule le_degree)
+ apply (simp add: coeff_eq_0)
+ done
+
+lemma degree_add_eq_left:
+ "degree q < degree p \<Longrightarrow> degree (p + q) = degree p"
+ using degree_add_eq_right [of q p]
+ by (simp add: add_commute)
+
+lemma degree_minus [simp]: "degree (- p) = degree p"
+ unfolding degree_def by simp
+
+lemma degree_diff_le_max: "degree (p - q) \<le> max (degree p) (degree q)"
+ using degree_add_le [where p=p and q="-q"]
+ by (simp add: diff_minus)
+
+lemma degree_diff_le:
+ "\<lbrakk>degree p \<le> n; degree q \<le> n\<rbrakk> \<Longrightarrow> degree (p - q) \<le> n"
+ by (simp add: diff_minus degree_add_le)
+
+lemma degree_diff_less:
+ "\<lbrakk>degree p < n; degree q < n\<rbrakk> \<Longrightarrow> degree (p - q) < n"
+ by (simp add: diff_minus degree_add_less)
+
+lemma add_monom: "monom a n + monom b n = monom (a + b) n"
+ by (rule poly_ext) simp
+
+lemma diff_monom: "monom a n - monom b n = monom (a - b) n"
+ by (rule poly_ext) simp
+
+lemma minus_monom: "- monom a n = monom (-a) n"
+ by (rule poly_ext) simp
+
+lemma coeff_setsum: "coeff (\<Sum>x\<in>A. p x) i = (\<Sum>x\<in>A. coeff (p x) i)"
+ by (cases "finite A", induct set: finite, simp_all)
+
+lemma monom_setsum: "monom (\<Sum>x\<in>A. a x) n = (\<Sum>x\<in>A. monom (a x) n)"
+ by (rule poly_ext) (simp add: coeff_setsum)
+
+
+subsection {* Multiplication by a constant *}
+
+definition
+ smult :: "'a::comm_semiring_0 \<Rightarrow> 'a poly \<Rightarrow> 'a poly" where
+ "smult a p = Abs_poly (\<lambda>n. a * coeff p n)"
+
+lemma Poly_smult:
+ fixes f :: "nat \<Rightarrow> 'a::comm_semiring_0"
+ shows "f \<in> Poly \<Longrightarrow> (\<lambda>n. a * f n) \<in> Poly"
+ unfolding Poly_def
+ by (clarify, rule_tac x=n in exI, simp)
+
+lemma coeff_smult [simp]: "coeff (smult a p) n = a * coeff p n"
+ unfolding smult_def
+ by (simp add: Abs_poly_inverse Poly_smult coeff)
+
+lemma degree_smult_le: "degree (smult a p) \<le> degree p"
+ by (rule degree_le, simp add: coeff_eq_0)
+
+lemma smult_smult [simp]: "smult a (smult b p) = smult (a * b) p"
+ by (rule poly_ext, simp add: mult_assoc)
+
+lemma smult_0_right [simp]: "smult a 0 = 0"
+ by (rule poly_ext, simp)
+
+lemma smult_0_left [simp]: "smult 0 p = 0"
+ by (rule poly_ext, simp)
+
+lemma smult_1_left [simp]: "smult (1::'a::comm_semiring_1) p = p"
+ by (rule poly_ext, simp)
+
+lemma smult_add_right:
+ "smult a (p + q) = smult a p + smult a q"
+ by (rule poly_ext, simp add: algebra_simps)
+
+lemma smult_add_left:
+ "smult (a + b) p = smult a p + smult b p"
+ by (rule poly_ext, simp add: algebra_simps)
+
+lemma smult_minus_right [simp]:
+ "smult (a::'a::comm_ring) (- p) = - smult a p"
+ by (rule poly_ext, simp)
+
+lemma smult_minus_left [simp]:
+ "smult (- a::'a::comm_ring) p = - smult a p"
+ by (rule poly_ext, simp)
+
+lemma smult_diff_right:
+ "smult (a::'a::comm_ring) (p - q) = smult a p - smult a q"
+ by (rule poly_ext, simp add: algebra_simps)
+
+lemma smult_diff_left:
+ "smult (a - b::'a::comm_ring) p = smult a p - smult b p"
+ by (rule poly_ext, simp add: algebra_simps)
+
+lemmas smult_distribs =
+ smult_add_left smult_add_right
+ smult_diff_left smult_diff_right
+
+lemma smult_pCons [simp]:
+ "smult a (pCons b p) = pCons (a * b) (smult a p)"
+ by (rule poly_ext, simp add: coeff_pCons split: nat.split)
+
+lemma smult_monom: "smult a (monom b n) = monom (a * b) n"
+ by (induct n, simp add: monom_0, simp add: monom_Suc)
+
+lemma degree_smult_eq [simp]:
+ fixes a :: "'a::idom"
+ shows "degree (smult a p) = (if a = 0 then 0 else degree p)"
+ by (cases "a = 0", simp, simp add: degree_def)
+
+lemma smult_eq_0_iff [simp]:
+ fixes a :: "'a::idom"
+ shows "smult a p = 0 \<longleftrightarrow> a = 0 \<or> p = 0"
+ by (simp add: expand_poly_eq)
+
+
+subsection {* Multiplication of polynomials *}
+
+text {* TODO: move to SetInterval.thy *}
+lemma setsum_atMost_Suc_shift:
+ fixes f :: "nat \<Rightarrow> 'a::comm_monoid_add"
+ shows "(\<Sum>i\<le>Suc n. f i) = f 0 + (\<Sum>i\<le>n. f (Suc i))"
+proof (induct n)
+ case 0 show ?case by simp
+next
+ case (Suc n) note IH = this
+ have "(\<Sum>i\<le>Suc (Suc n). f i) = (\<Sum>i\<le>Suc n. f i) + f (Suc (Suc n))"
+ by (rule setsum_atMost_Suc)
+ also have "(\<Sum>i\<le>Suc n. f i) = f 0 + (\<Sum>i\<le>n. f (Suc i))"
+ by (rule IH)
+ also have "f 0 + (\<Sum>i\<le>n. f (Suc i)) + f (Suc (Suc n)) =
+ f 0 + ((\<Sum>i\<le>n. f (Suc i)) + f (Suc (Suc n)))"
+ by (rule add_assoc)
+ also have "(\<Sum>i\<le>n. f (Suc i)) + f (Suc (Suc n)) = (\<Sum>i\<le>Suc n. f (Suc i))"
+ by (rule setsum_atMost_Suc [symmetric])
+ finally show ?case .
+qed
+
+instantiation poly :: (comm_semiring_0) comm_semiring_0
+begin
+
+definition
+ times_poly_def [code del]:
+ "p * q = poly_rec 0 (\<lambda>a p pq. smult a q + pCons 0 pq) p"
+
+lemma mult_poly_0_left: "(0::'a poly) * q = 0"
+ unfolding times_poly_def by (simp add: poly_rec_0)
+
+lemma mult_pCons_left [simp]:
+ "pCons a p * q = smult a q + pCons 0 (p * q)"
+ unfolding times_poly_def by (simp add: poly_rec_pCons)
+
+lemma mult_poly_0_right: "p * (0::'a poly) = 0"
+ by (induct p, simp add: mult_poly_0_left, simp)
+
+lemma mult_pCons_right [simp]:
+ "p * pCons a q = smult a p + pCons 0 (p * q)"
+ by (induct p, simp add: mult_poly_0_left, simp add: algebra_simps)
+
+lemmas mult_poly_0 = mult_poly_0_left mult_poly_0_right
+
+lemma mult_smult_left [simp]: "smult a p * q = smult a (p * q)"
+ by (induct p, simp add: mult_poly_0, simp add: smult_add_right)
+
+lemma mult_smult_right [simp]: "p * smult a q = smult a (p * q)"
+ by (induct q, simp add: mult_poly_0, simp add: smult_add_right)
+
+lemma mult_poly_add_left:
+ fixes p q r :: "'a poly"
+ shows "(p + q) * r = p * r + q * r"
+ by (induct r, simp add: mult_poly_0,
+ simp add: smult_distribs algebra_simps)
+
+instance proof
+ fix p q r :: "'a poly"
+ show 0: "0 * p = 0"
+ by (rule mult_poly_0_left)
+ show "p * 0 = 0"
+ by (rule mult_poly_0_right)
+ show "(p + q) * r = p * r + q * r"
+ by (rule mult_poly_add_left)
+ show "(p * q) * r = p * (q * r)"
+ by (induct p, simp add: mult_poly_0, simp add: mult_poly_add_left)
+ show "p * q = q * p"
+ by (induct p, simp add: mult_poly_0, simp)
+qed
+
+end
+
+instance poly :: (comm_semiring_0_cancel) comm_semiring_0_cancel ..
+
+lemma coeff_mult:
+ "coeff (p * q) n = (\<Sum>i\<le>n. coeff p i * coeff q (n-i))"
+proof (induct p arbitrary: n)
+ case 0 show ?case by simp
+next
+ case (pCons a p n) thus ?case
+ by (cases n, simp, simp add: setsum_atMost_Suc_shift
+ del: setsum_atMost_Suc)
+qed
+
+lemma degree_mult_le: "degree (p * q) \<le> degree p + degree q"
+apply (rule degree_le)
+apply (induct p)
+apply simp
+apply (simp add: coeff_eq_0 coeff_pCons split: nat.split)
+done
+
+lemma mult_monom: "monom a m * monom b n = monom (a * b) (m + n)"
+ by (induct m, simp add: monom_0 smult_monom, simp add: monom_Suc)
+
+
+subsection {* The unit polynomial and exponentiation *}
+
+instantiation poly :: (comm_semiring_1) comm_semiring_1
+begin
+
+definition
+ one_poly_def:
+ "1 = pCons 1 0"
+
+instance proof
+ fix p :: "'a poly" show "1 * p = p"
+ unfolding one_poly_def
+ by simp
+next
+ show "0 \<noteq> (1::'a poly)"
+ unfolding one_poly_def by simp
+qed
+
+end
+
+instance poly :: (comm_semiring_1_cancel) comm_semiring_1_cancel ..
+
+lemma coeff_1 [simp]: "coeff 1 n = (if n = 0 then 1 else 0)"
+ unfolding one_poly_def
+ by (simp add: coeff_pCons split: nat.split)
+
+lemma degree_1 [simp]: "degree 1 = 0"
+ unfolding one_poly_def
+ by (rule degree_pCons_0)
+
+text {* Lemmas about divisibility *}
+
+lemma dvd_smult: "p dvd q \<Longrightarrow> p dvd smult a q"
+proof -
+ assume "p dvd q"
+ then obtain k where "q = p * k" ..
+ then have "smult a q = p * smult a k" by simp
+ then show "p dvd smult a q" ..
+qed
+
+lemma dvd_smult_cancel:
+ fixes a :: "'a::field"
+ shows "p dvd smult a q \<Longrightarrow> a \<noteq> 0 \<Longrightarrow> p dvd q"
+ by (drule dvd_smult [where a="inverse a"]) simp
+
+lemma dvd_smult_iff:
+ fixes a :: "'a::field"
+ shows "a \<noteq> 0 \<Longrightarrow> p dvd smult a q \<longleftrightarrow> p dvd q"
+ by (safe elim!: dvd_smult dvd_smult_cancel)
+
+instantiation poly :: (comm_semiring_1) recpower
+begin
+
+primrec power_poly where
+ power_poly_0: "(p::'a poly) ^ 0 = 1"
+| power_poly_Suc: "(p::'a poly) ^ (Suc n) = p * p ^ n"
+
+instance
+ by default simp_all
+
+end
+
+lemma degree_power_le: "degree (p ^ n) \<le> degree p * n"
+by (induct n, simp, auto intro: order_trans degree_mult_le)
+
+instance poly :: (comm_ring) comm_ring ..
+
+instance poly :: (comm_ring_1) comm_ring_1 ..
+
+instantiation poly :: (comm_ring_1) number_ring
+begin
+
+definition
+ "number_of k = (of_int k :: 'a poly)"
+
+instance
+ by default (rule number_of_poly_def)
+
+end
+
+
+subsection {* Polynomials form an integral domain *}
+
+lemma coeff_mult_degree_sum:
+ "coeff (p * q) (degree p + degree q) =
+ coeff p (degree p) * coeff q (degree q)"
+ by (induct p, simp, simp add: coeff_eq_0)
+
+instance poly :: (idom) idom
+proof
+ fix p q :: "'a poly"
+ assume "p \<noteq> 0" and "q \<noteq> 0"
+ have "coeff (p * q) (degree p + degree q) =
+ coeff p (degree p) * coeff q (degree q)"
+ by (rule coeff_mult_degree_sum)
+ also have "coeff p (degree p) * coeff q (degree q) \<noteq> 0"
+ using `p \<noteq> 0` and `q \<noteq> 0` by simp
+ finally have "\<exists>n. coeff (p * q) n \<noteq> 0" ..
+ thus "p * q \<noteq> 0" by (simp add: expand_poly_eq)
+qed
+
+lemma degree_mult_eq:
+ fixes p q :: "'a::idom poly"
+ shows "\<lbrakk>p \<noteq> 0; q \<noteq> 0\<rbrakk> \<Longrightarrow> degree (p * q) = degree p + degree q"
+apply (rule order_antisym [OF degree_mult_le le_degree])
+apply (simp add: coeff_mult_degree_sum)
+done
+
+lemma dvd_imp_degree_le:
+ fixes p q :: "'a::idom poly"
+ shows "\<lbrakk>p dvd q; q \<noteq> 0\<rbrakk> \<Longrightarrow> degree p \<le> degree q"
+ by (erule dvdE, simp add: degree_mult_eq)
+
+
+subsection {* Polynomials form an ordered integral domain *}
+
+definition
+ pos_poly :: "'a::ordered_idom poly \<Rightarrow> bool"
+where
+ "pos_poly p \<longleftrightarrow> 0 < coeff p (degree p)"
+
+lemma pos_poly_pCons:
+ "pos_poly (pCons a p) \<longleftrightarrow> pos_poly p \<or> (p = 0 \<and> 0 < a)"
+ unfolding pos_poly_def by simp
+
+lemma not_pos_poly_0 [simp]: "\<not> pos_poly 0"
+ unfolding pos_poly_def by simp
+
+lemma pos_poly_add: "\<lbrakk>pos_poly p; pos_poly q\<rbrakk> \<Longrightarrow> pos_poly (p + q)"
+ apply (induct p arbitrary: q, simp)
+ apply (case_tac q, force simp add: pos_poly_pCons add_pos_pos)
+ done
+
+lemma pos_poly_mult: "\<lbrakk>pos_poly p; pos_poly q\<rbrakk> \<Longrightarrow> pos_poly (p * q)"
+ unfolding pos_poly_def
+ apply (subgoal_tac "p \<noteq> 0 \<and> q \<noteq> 0")
+ apply (simp add: degree_mult_eq coeff_mult_degree_sum mult_pos_pos)
+ apply auto
+ done
+
+lemma pos_poly_total: "p = 0 \<or> pos_poly p \<or> pos_poly (- p)"
+by (induct p) (auto simp add: pos_poly_pCons)
+
+instantiation poly :: (ordered_idom) ordered_idom
+begin
+
+definition
+ [code del]:
+ "x < y \<longleftrightarrow> pos_poly (y - x)"
+
+definition
+ [code del]:
+ "x \<le> y \<longleftrightarrow> x = y \<or> pos_poly (y - x)"
+
+definition
+ [code del]:
+ "abs (x::'a poly) = (if x < 0 then - x else x)"
+
+definition
+ [code del]:
+ "sgn (x::'a poly) = (if x = 0 then 0 else if 0 < x then 1 else - 1)"
+
+instance proof
+ fix x y :: "'a poly"
+ show "x < y \<longleftrightarrow> x \<le> y \<and> \<not> y \<le> x"
+ unfolding less_eq_poly_def less_poly_def
+ apply safe
+ apply simp
+ apply (drule (1) pos_poly_add)
+ apply simp
+ done
+next
+ fix x :: "'a poly" show "x \<le> x"
+ unfolding less_eq_poly_def by simp
+next
+ fix x y z :: "'a poly"
+ assume "x \<le> y" and "y \<le> z" thus "x \<le> z"
+ unfolding less_eq_poly_def
+ apply safe
+ apply (drule (1) pos_poly_add)
+ apply (simp add: algebra_simps)
+ done
+next
+ fix x y :: "'a poly"
+ assume "x \<le> y" and "y \<le> x" thus "x = y"
+ unfolding less_eq_poly_def
+ apply safe
+ apply (drule (1) pos_poly_add)
+ apply simp
+ done
+next
+ fix x y z :: "'a poly"
+ assume "x \<le> y" thus "z + x \<le> z + y"
+ unfolding less_eq_poly_def
+ apply safe
+ apply (simp add: algebra_simps)
+ done
+next
+ fix x y :: "'a poly"
+ show "x \<le> y \<or> y \<le> x"
+ unfolding less_eq_poly_def
+ using pos_poly_total [of "x - y"]
+ by auto
+next
+ fix x y z :: "'a poly"
+ assume "x < y" and "0 < z"
+ thus "z * x < z * y"
+ unfolding less_poly_def
+ by (simp add: right_diff_distrib [symmetric] pos_poly_mult)
+next
+ fix x :: "'a poly"
+ show "\<bar>x\<bar> = (if x < 0 then - x else x)"
+ by (rule abs_poly_def)
+next
+ fix x :: "'a poly"
+ show "sgn x = (if x = 0 then 0 else if 0 < x then 1 else - 1)"
+ by (rule sgn_poly_def)
+qed
+
+end
+
+text {* TODO: Simplification rules for comparisons *}
+
+
+subsection {* Long division of polynomials *}
+
+definition
+ pdivmod_rel :: "'a::field poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly \<Rightarrow> bool"
+where
+ [code del]:
+ "pdivmod_rel x y q r \<longleftrightarrow>
+ x = q * y + r \<and> (if y = 0 then q = 0 else r = 0 \<or> degree r < degree y)"
+
+lemma pdivmod_rel_0:
+ "pdivmod_rel 0 y 0 0"
+ unfolding pdivmod_rel_def by simp
+
+lemma pdivmod_rel_by_0:
+ "pdivmod_rel x 0 0 x"
+ unfolding pdivmod_rel_def by simp
+
+lemma eq_zero_or_degree_less:
+ assumes "degree p \<le> n" and "coeff p n = 0"
+ shows "p = 0 \<or> degree p < n"
+proof (cases n)
+ case 0
+ with `degree p \<le> n` and `coeff p n = 0`
+ have "coeff p (degree p) = 0" by simp
+ then have "p = 0" by simp
+ then show ?thesis ..
+next
+ case (Suc m)
+ have "\<forall>i>n. coeff p i = 0"
+ using `degree p \<le> n` by (simp add: coeff_eq_0)
+ then have "\<forall>i\<ge>n. coeff p i = 0"
+ using `coeff p n = 0` by (simp add: le_less)
+ then have "\<forall>i>m. coeff p i = 0"
+ using `n = Suc m` by (simp add: less_eq_Suc_le)
+ then have "degree p \<le> m"
+ by (rule degree_le)
+ then have "degree p < n"
+ using `n = Suc m` by (simp add: less_Suc_eq_le)
+ then show ?thesis ..
+qed
+
+lemma pdivmod_rel_pCons:
+ assumes rel: "pdivmod_rel x y q r"
+ assumes y: "y \<noteq> 0"
+ assumes b: "b = coeff (pCons a r) (degree y) / coeff y (degree y)"
+ shows "pdivmod_rel (pCons a x) y (pCons b q) (pCons a r - smult b y)"
+ (is "pdivmod_rel ?x y ?q ?r")
+proof -
+ have x: "x = q * y + r" and r: "r = 0 \<or> degree r < degree y"
+ using assms unfolding pdivmod_rel_def by simp_all
+
+ have 1: "?x = ?q * y + ?r"
+ using b x by simp
+
+ have 2: "?r = 0 \<or> degree ?r < degree y"
+ proof (rule eq_zero_or_degree_less)
+ show "degree ?r \<le> degree y"
+ proof (rule degree_diff_le)
+ show "degree (pCons a r) \<le> degree y"
+ using r by auto
+ show "degree (smult b y) \<le> degree y"
+ by (rule degree_smult_le)
+ qed
+ next
+ show "coeff ?r (degree y) = 0"
+ using `y \<noteq> 0` unfolding b by simp
+ qed
+
+ from 1 2 show ?thesis
+ unfolding pdivmod_rel_def
+ using `y \<noteq> 0` by simp
+qed
+
+lemma pdivmod_rel_exists: "\<exists>q r. pdivmod_rel x y q r"
+apply (cases "y = 0")
+apply (fast intro!: pdivmod_rel_by_0)
+apply (induct x)
+apply (fast intro!: pdivmod_rel_0)
+apply (fast intro!: pdivmod_rel_pCons)
+done
+
+lemma pdivmod_rel_unique:
+ assumes 1: "pdivmod_rel x y q1 r1"
+ assumes 2: "pdivmod_rel x y q2 r2"
+ shows "q1 = q2 \<and> r1 = r2"
+proof (cases "y = 0")
+ assume "y = 0" with assms show ?thesis
+ by (simp add: pdivmod_rel_def)
+next
+ assume [simp]: "y \<noteq> 0"
+ from 1 have q1: "x = q1 * y + r1" and r1: "r1 = 0 \<or> degree r1 < degree y"
+ unfolding pdivmod_rel_def by simp_all
+ from 2 have q2: "x = q2 * y + r2" and r2: "r2 = 0 \<or> degree r2 < degree y"
+ unfolding pdivmod_rel_def by simp_all
+ from q1 q2 have q3: "(q1 - q2) * y = r2 - r1"
+ by (simp add: algebra_simps)
+ from r1 r2 have r3: "(r2 - r1) = 0 \<or> degree (r2 - r1) < degree y"
+ by (auto intro: degree_diff_less)
+
+ show "q1 = q2 \<and> r1 = r2"
+ proof (rule ccontr)
+ assume "\<not> (q1 = q2 \<and> r1 = r2)"
+ with q3 have "q1 \<noteq> q2" and "r1 \<noteq> r2" by auto
+ with r3 have "degree (r2 - r1) < degree y" by simp
+ also have "degree y \<le> degree (q1 - q2) + degree y" by simp
+ also have "\<dots> = degree ((q1 - q2) * y)"
+ using `q1 \<noteq> q2` by (simp add: degree_mult_eq)
+ also have "\<dots> = degree (r2 - r1)"
+ using q3 by simp
+ finally have "degree (r2 - r1) < degree (r2 - r1)" .
+ then show "False" by simp
+ qed
+qed
+
+lemma pdivmod_rel_0_iff: "pdivmod_rel 0 y q r \<longleftrightarrow> q = 0 \<and> r = 0"
+by (auto dest: pdivmod_rel_unique intro: pdivmod_rel_0)
+
+lemma pdivmod_rel_by_0_iff: "pdivmod_rel x 0 q r \<longleftrightarrow> q = 0 \<and> r = x"
+by (auto dest: pdivmod_rel_unique intro: pdivmod_rel_by_0)
+
+lemmas pdivmod_rel_unique_div =
+ pdivmod_rel_unique [THEN conjunct1, standard]
+
+lemmas pdivmod_rel_unique_mod =
+ pdivmod_rel_unique [THEN conjunct2, standard]
+
+instantiation poly :: (field) ring_div
+begin
+
+definition div_poly where
+ [code del]: "x div y = (THE q. \<exists>r. pdivmod_rel x y q r)"
+
+definition mod_poly where
+ [code del]: "x mod y = (THE r. \<exists>q. pdivmod_rel x y q r)"
+
+lemma div_poly_eq:
+ "pdivmod_rel x y q r \<Longrightarrow> x div y = q"
+unfolding div_poly_def
+by (fast elim: pdivmod_rel_unique_div)
+
+lemma mod_poly_eq:
+ "pdivmod_rel x y q r \<Longrightarrow> x mod y = r"
+unfolding mod_poly_def
+by (fast elim: pdivmod_rel_unique_mod)
+
+lemma pdivmod_rel:
+ "pdivmod_rel x y (x div y) (x mod y)"
+proof -
+ from pdivmod_rel_exists
+ obtain q r where "pdivmod_rel x y q r" by fast
+ thus ?thesis
+ by (simp add: div_poly_eq mod_poly_eq)
+qed
+
+instance proof
+ fix x y :: "'a poly"
+ show "x div y * y + x mod y = x"
+ using pdivmod_rel [of x y]
+ by (simp add: pdivmod_rel_def)
+next
+ fix x :: "'a poly"
+ have "pdivmod_rel x 0 0 x"
+ by (rule pdivmod_rel_by_0)
+ thus "x div 0 = 0"
+ by (rule div_poly_eq)
+next
+ fix y :: "'a poly"
+ have "pdivmod_rel 0 y 0 0"
+ by (rule pdivmod_rel_0)
+ thus "0 div y = 0"
+ by (rule div_poly_eq)
+next
+ fix x y z :: "'a poly"
+ assume "y \<noteq> 0"
+ hence "pdivmod_rel (x + z * y) y (z + x div y) (x mod y)"
+ using pdivmod_rel [of x y]
+ by (simp add: pdivmod_rel_def left_distrib)
+ thus "(x + z * y) div y = z + x div y"
+ by (rule div_poly_eq)
+qed
+
+end
+
+lemma degree_mod_less:
+ "y \<noteq> 0 \<Longrightarrow> x mod y = 0 \<or> degree (x mod y) < degree y"
+ using pdivmod_rel [of x y]
+ unfolding pdivmod_rel_def by simp
+
+lemma div_poly_less: "degree x < degree y \<Longrightarrow> x div y = 0"
+proof -
+ assume "degree x < degree y"
+ hence "pdivmod_rel x y 0 x"
+ by (simp add: pdivmod_rel_def)
+ thus "x div y = 0" by (rule div_poly_eq)
+qed
+
+lemma mod_poly_less: "degree x < degree y \<Longrightarrow> x mod y = x"
+proof -
+ assume "degree x < degree y"
+ hence "pdivmod_rel x y 0 x"
+ by (simp add: pdivmod_rel_def)
+ thus "x mod y = x" by (rule mod_poly_eq)
+qed
+
+lemma pdivmod_rel_smult_left:
+ "pdivmod_rel x y q r
+ \<Longrightarrow> pdivmod_rel (smult a x) y (smult a q) (smult a r)"
+ unfolding pdivmod_rel_def by (simp add: smult_add_right)
+
+lemma div_smult_left: "(smult a x) div y = smult a (x div y)"
+ by (rule div_poly_eq, rule pdivmod_rel_smult_left, rule pdivmod_rel)
+
+lemma mod_smult_left: "(smult a x) mod y = smult a (x mod y)"
+ by (rule mod_poly_eq, rule pdivmod_rel_smult_left, rule pdivmod_rel)
+
+lemma poly_div_minus_left [simp]:
+ fixes x y :: "'a::field poly"
+ shows "(- x) div y = - (x div y)"
+ using div_smult_left [of "- 1::'a"] by simp
+
+lemma poly_mod_minus_left [simp]:
+ fixes x y :: "'a::field poly"
+ shows "(- x) mod y = - (x mod y)"
+ using mod_smult_left [of "- 1::'a"] by simp
+
+lemma pdivmod_rel_smult_right:
+ "\<lbrakk>a \<noteq> 0; pdivmod_rel x y q r\<rbrakk>
+ \<Longrightarrow> pdivmod_rel x (smult a y) (smult (inverse a) q) r"
+ unfolding pdivmod_rel_def by simp
+
+lemma div_smult_right:
+ "a \<noteq> 0 \<Longrightarrow> x div (smult a y) = smult (inverse a) (x div y)"
+ by (rule div_poly_eq, erule pdivmod_rel_smult_right, rule pdivmod_rel)
+
+lemma mod_smult_right: "a \<noteq> 0 \<Longrightarrow> x mod (smult a y) = x mod y"
+ by (rule mod_poly_eq, erule pdivmod_rel_smult_right, rule pdivmod_rel)
+
+lemma poly_div_minus_right [simp]:
+ fixes x y :: "'a::field poly"
+ shows "x div (- y) = - (x div y)"
+ using div_smult_right [of "- 1::'a"]
+ by (simp add: nonzero_inverse_minus_eq)
+
+lemma poly_mod_minus_right [simp]:
+ fixes x y :: "'a::field poly"
+ shows "x mod (- y) = x mod y"
+ using mod_smult_right [of "- 1::'a"] by simp
+
+lemma pdivmod_rel_mult:
+ "\<lbrakk>pdivmod_rel x y q r; pdivmod_rel q z q' r'\<rbrakk>
+ \<Longrightarrow> pdivmod_rel x (y * z) q' (y * r' + r)"
+apply (cases "z = 0", simp add: pdivmod_rel_def)
+apply (cases "y = 0", simp add: pdivmod_rel_by_0_iff pdivmod_rel_0_iff)
+apply (cases "r = 0")
+apply (cases "r' = 0")
+apply (simp add: pdivmod_rel_def)
+apply (simp add: pdivmod_rel_def ring_simps degree_mult_eq)
+apply (cases "r' = 0")
+apply (simp add: pdivmod_rel_def degree_mult_eq)
+apply (simp add: pdivmod_rel_def ring_simps)
+apply (simp add: degree_mult_eq degree_add_less)
+done
+
+lemma poly_div_mult_right:
+ fixes x y z :: "'a::field poly"
+ shows "x div (y * z) = (x div y) div z"
+ by (rule div_poly_eq, rule pdivmod_rel_mult, (rule pdivmod_rel)+)
+
+lemma poly_mod_mult_right:
+ fixes x y z :: "'a::field poly"
+ shows "x mod (y * z) = y * (x div y mod z) + x mod y"
+ by (rule mod_poly_eq, rule pdivmod_rel_mult, (rule pdivmod_rel)+)
+
+lemma mod_pCons:
+ fixes a and x
+ assumes y: "y \<noteq> 0"
+ defines b: "b \<equiv> coeff (pCons a (x mod y)) (degree y) / coeff y (degree y)"
+ shows "(pCons a x) mod y = (pCons a (x mod y) - smult b y)"
+unfolding b
+apply (rule mod_poly_eq)
+apply (rule pdivmod_rel_pCons [OF pdivmod_rel y refl])
+done
+
+
+subsection {* Evaluation of polynomials *}
+
+definition
+ poly :: "'a::comm_semiring_0 poly \<Rightarrow> 'a \<Rightarrow> 'a" where
+ "poly = poly_rec (\<lambda>x. 0) (\<lambda>a p f x. a + x * f x)"
+
+lemma poly_0 [simp]: "poly 0 x = 0"
+ unfolding poly_def by (simp add: poly_rec_0)
+
+lemma poly_pCons [simp]: "poly (pCons a p) x = a + x * poly p x"
+ unfolding poly_def by (simp add: poly_rec_pCons)
+
+lemma poly_1 [simp]: "poly 1 x = 1"
+ unfolding one_poly_def by simp
+
+lemma poly_monom:
+ fixes a x :: "'a::{comm_semiring_1,recpower}"
+ shows "poly (monom a n) x = a * x ^ n"
+ by (induct n, simp add: monom_0, simp add: monom_Suc power_Suc mult_ac)
+
+lemma poly_add [simp]: "poly (p + q) x = poly p x + poly q x"
+ apply (induct p arbitrary: q, simp)
+ apply (case_tac q, simp, simp add: algebra_simps)
+ done
+
+lemma poly_minus [simp]:
+ fixes x :: "'a::comm_ring"
+ shows "poly (- p) x = - poly p x"
+ by (induct p, simp_all)
+
+lemma poly_diff [simp]:
+ fixes x :: "'a::comm_ring"
+ shows "poly (p - q) x = poly p x - poly q x"
+ by (simp add: diff_minus)
+
+lemma poly_setsum: "poly (\<Sum>k\<in>A. p k) x = (\<Sum>k\<in>A. poly (p k) x)"
+ by (cases "finite A", induct set: finite, simp_all)
+
+lemma poly_smult [simp]: "poly (smult a p) x = a * poly p x"
+ by (induct p, simp, simp add: algebra_simps)
+
+lemma poly_mult [simp]: "poly (p * q) x = poly p x * poly q x"
+ by (induct p, simp_all, simp add: algebra_simps)
+
+lemma poly_power [simp]:
+ fixes p :: "'a::{comm_semiring_1,recpower} poly"
+ shows "poly (p ^ n) x = poly p x ^ n"
+ by (induct n, simp, simp add: power_Suc)
+
+
+subsection {* Synthetic division *}
+
+text {*
+ Synthetic division is simply division by the
+ linear polynomial @{term "x - c"}.
+*}
+
+definition
+ synthetic_divmod :: "'a::comm_semiring_0 poly \<Rightarrow> 'a \<Rightarrow> 'a poly \<times> 'a"
+where [code del]:
+ "synthetic_divmod p c =
+ poly_rec (0, 0) (\<lambda>a p (q, r). (pCons r q, a + c * r)) p"
+
+definition
+ synthetic_div :: "'a::comm_semiring_0 poly \<Rightarrow> 'a \<Rightarrow> 'a poly"
+where
+ "synthetic_div p c = fst (synthetic_divmod p c)"
+
+lemma synthetic_divmod_0 [simp]:
+ "synthetic_divmod 0 c = (0, 0)"
+ unfolding synthetic_divmod_def
+ by (simp add: poly_rec_0)
+
+lemma synthetic_divmod_pCons [simp]:
+ "synthetic_divmod (pCons a p) c =
+ (\<lambda>(q, r). (pCons r q, a + c * r)) (synthetic_divmod p c)"
+ unfolding synthetic_divmod_def
+ by (simp add: poly_rec_pCons)
+
+lemma snd_synthetic_divmod: "snd (synthetic_divmod p c) = poly p c"
+ by (induct p, simp, simp add: split_def)
+
+lemma synthetic_div_0 [simp]: "synthetic_div 0 c = 0"
+ unfolding synthetic_div_def by simp
+
+lemma synthetic_div_pCons [simp]:
+ "synthetic_div (pCons a p) c = pCons (poly p c) (synthetic_div p c)"
+ unfolding synthetic_div_def
+ by (simp add: split_def snd_synthetic_divmod)
+
+lemma synthetic_div_eq_0_iff:
+ "synthetic_div p c = 0 \<longleftrightarrow> degree p = 0"
+ by (induct p, simp, case_tac p, simp)
+
+lemma degree_synthetic_div:
+ "degree (synthetic_div p c) = degree p - 1"
+ by (induct p, simp, simp add: synthetic_div_eq_0_iff)
+
+lemma synthetic_div_correct:
+ "p + smult c (synthetic_div p c) = pCons (poly p c) (synthetic_div p c)"
+ by (induct p) simp_all
+
+lemma synthetic_div_unique_lemma: "smult c p = pCons a p \<Longrightarrow> p = 0"
+by (induct p arbitrary: a) simp_all
+
+lemma synthetic_div_unique:
+ "p + smult c q = pCons r q \<Longrightarrow> r = poly p c \<and> q = synthetic_div p c"
+apply (induct p arbitrary: q r)
+apply (simp, frule synthetic_div_unique_lemma, simp)
+apply (case_tac q, force)
+done
+
+lemma synthetic_div_correct':
+ fixes c :: "'a::comm_ring_1"
+ shows "[:-c, 1:] * synthetic_div p c + [:poly p c:] = p"
+ using synthetic_div_correct [of p c]
+ by (simp add: algebra_simps)
+
+lemma poly_eq_0_iff_dvd:
+ fixes c :: "'a::idom"
+ shows "poly p c = 0 \<longleftrightarrow> [:-c, 1:] dvd p"
+proof
+ assume "poly p c = 0"
+ with synthetic_div_correct' [of c p]
+ have "p = [:-c, 1:] * synthetic_div p c" by simp
+ then show "[:-c, 1:] dvd p" ..
+next
+ assume "[:-c, 1:] dvd p"
+ then obtain k where "p = [:-c, 1:] * k" by (rule dvdE)
+ then show "poly p c = 0" by simp
+qed
+
+lemma dvd_iff_poly_eq_0:
+ fixes c :: "'a::idom"
+ shows "[:c, 1:] dvd p \<longleftrightarrow> poly p (-c) = 0"
+ by (simp add: poly_eq_0_iff_dvd)
+
+lemma poly_roots_finite:
+ fixes p :: "'a::idom poly"
+ shows "p \<noteq> 0 \<Longrightarrow> finite {x. poly p x = 0}"
+proof (induct n \<equiv> "degree p" arbitrary: p)
+ case (0 p)
+ then obtain a where "a \<noteq> 0" and "p = [:a:]"
+ by (cases p, simp split: if_splits)
+ then show "finite {x. poly p x = 0}" by simp
+next
+ case (Suc n p)
+ show "finite {x. poly p x = 0}"
+ proof (cases "\<exists>x. poly p x = 0")
+ case False
+ then show "finite {x. poly p x = 0}" by simp
+ next
+ case True
+ then obtain a where "poly p a = 0" ..
+ then have "[:-a, 1:] dvd p" by (simp only: poly_eq_0_iff_dvd)
+ then obtain k where k: "p = [:-a, 1:] * k" ..
+ with `p \<noteq> 0` have "k \<noteq> 0" by auto
+ with k have "degree p = Suc (degree k)"
+ by (simp add: degree_mult_eq del: mult_pCons_left)
+ with `Suc n = degree p` have "n = degree k" by simp
+ with `k \<noteq> 0` have "finite {x. poly k x = 0}" by (rule Suc.hyps)
+ then have "finite (insert a {x. poly k x = 0})" by simp
+ then show "finite {x. poly p x = 0}"
+ by (simp add: k uminus_add_conv_diff Collect_disj_eq
+ del: mult_pCons_left)
+ qed
+qed
+
+lemma poly_zero:
+ fixes p :: "'a::{idom,ring_char_0} poly"
+ shows "poly p = poly 0 \<longleftrightarrow> p = 0"
+apply (cases "p = 0", simp_all)
+apply (drule poly_roots_finite)
+apply (auto simp add: infinite_UNIV_char_0)
+done
+
+lemma poly_eq_iff:
+ fixes p q :: "'a::{idom,ring_char_0} poly"
+ shows "poly p = poly q \<longleftrightarrow> p = q"
+ using poly_zero [of "p - q"]
+ by (simp add: expand_fun_eq)
+
+
+subsection {* Composition of polynomials *}
+
+definition
+ pcompose :: "'a::comm_semiring_0 poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly"
+where
+ "pcompose p q = poly_rec 0 (\<lambda>a _ c. [:a:] + q * c) p"
+
+lemma pcompose_0 [simp]: "pcompose 0 q = 0"
+ unfolding pcompose_def by (simp add: poly_rec_0)
+
+lemma pcompose_pCons:
+ "pcompose (pCons a p) q = [:a:] + q * pcompose p q"
+ unfolding pcompose_def by (simp add: poly_rec_pCons)
+
+lemma poly_pcompose: "poly (pcompose p q) x = poly p (poly q x)"
+ by (induct p) (simp_all add: pcompose_pCons)
+
+lemma degree_pcompose_le:
+ "degree (pcompose p q) \<le> degree p * degree q"
+apply (induct p, simp)
+apply (simp add: pcompose_pCons, clarify)
+apply (rule degree_add_le, simp)
+apply (rule order_trans [OF degree_mult_le], simp)
+done
+
+
+subsection {* Order of polynomial roots *}
+
+definition
+ order :: "'a::idom \<Rightarrow> 'a poly \<Rightarrow> nat"
+where
+ [code del]:
+ "order a p = (LEAST n. \<not> [:-a, 1:] ^ Suc n dvd p)"
+
+lemma coeff_linear_power:
+ fixes a :: "'a::comm_semiring_1"
+ shows "coeff ([:a, 1:] ^ n) n = 1"
+apply (induct n, simp_all)
+apply (subst coeff_eq_0)
+apply (auto intro: le_less_trans degree_power_le)
+done
+
+lemma degree_linear_power:
+ fixes a :: "'a::comm_semiring_1"
+ shows "degree ([:a, 1:] ^ n) = n"
+apply (rule order_antisym)
+apply (rule ord_le_eq_trans [OF degree_power_le], simp)
+apply (rule le_degree, simp add: coeff_linear_power)
+done
+
+lemma order_1: "[:-a, 1:] ^ order a p dvd p"
+apply (cases "p = 0", simp)
+apply (cases "order a p", simp)
+apply (subgoal_tac "nat < (LEAST n. \<not> [:-a, 1:] ^ Suc n dvd p)")
+apply (drule not_less_Least, simp)
+apply (fold order_def, simp)
+done
+
+lemma order_2: "p \<noteq> 0 \<Longrightarrow> \<not> [:-a, 1:] ^ Suc (order a p) dvd p"
+unfolding order_def
+apply (rule LeastI_ex)
+apply (rule_tac x="degree p" in exI)
+apply (rule notI)
+apply (drule (1) dvd_imp_degree_le)
+apply (simp only: degree_linear_power)
+done
+
+lemma order:
+ "p \<noteq> 0 \<Longrightarrow> [:-a, 1:] ^ order a p dvd p \<and> \<not> [:-a, 1:] ^ Suc (order a p) dvd p"
+by (rule conjI [OF order_1 order_2])
+
+lemma order_degree:
+ assumes p: "p \<noteq> 0"
+ shows "order a p \<le> degree p"
+proof -
+ have "order a p = degree ([:-a, 1:] ^ order a p)"
+ by (simp only: degree_linear_power)
+ also have "\<dots> \<le> degree p"
+ using order_1 p by (rule dvd_imp_degree_le)
+ finally show ?thesis .
+qed
+
+lemma order_root: "poly p a = 0 \<longleftrightarrow> p = 0 \<or> order a p \<noteq> 0"
+apply (cases "p = 0", simp_all)
+apply (rule iffI)
+apply (rule ccontr, simp)
+apply (frule order_2 [where a=a], simp)
+apply (simp add: poly_eq_0_iff_dvd)
+apply (simp add: poly_eq_0_iff_dvd)
+apply (simp only: order_def)
+apply (drule not_less_Least, simp)
+done
+
+
+subsection {* Configuration of the code generator *}
+
+code_datatype "0::'a::zero poly" pCons
+
+declare pCons_0_0 [code post]
+
+instantiation poly :: ("{zero,eq}") eq
+begin
+
+definition [code del]:
+ "eq_class.eq (p::'a poly) q \<longleftrightarrow> p = q"
+
+instance
+ by default (rule eq_poly_def)
+
+end
+
+lemma eq_poly_code [code]:
+ "eq_class.eq (0::_ poly) (0::_ poly) \<longleftrightarrow> True"
+ "eq_class.eq (0::_ poly) (pCons b q) \<longleftrightarrow> eq_class.eq 0 b \<and> eq_class.eq 0 q"
+ "eq_class.eq (pCons a p) (0::_ poly) \<longleftrightarrow> eq_class.eq a 0 \<and> eq_class.eq p 0"
+ "eq_class.eq (pCons a p) (pCons b q) \<longleftrightarrow> eq_class.eq a b \<and> eq_class.eq p q"
+unfolding eq by simp_all
+
+lemmas coeff_code [code] =
+ coeff_0 coeff_pCons_0 coeff_pCons_Suc
+
+lemmas degree_code [code] =
+ degree_0 degree_pCons_eq_if
+
+lemmas monom_poly_code [code] =
+ monom_0 monom_Suc
+
+lemma add_poly_code [code]:
+ "0 + q = (q :: _ poly)"
+ "p + 0 = (p :: _ poly)"
+ "pCons a p + pCons b q = pCons (a + b) (p + q)"
+by simp_all
+
+lemma minus_poly_code [code]:
+ "- 0 = (0 :: _ poly)"
+ "- pCons a p = pCons (- a) (- p)"
+by simp_all
+
+lemma diff_poly_code [code]:
+ "0 - q = (- q :: _ poly)"
+ "p - 0 = (p :: _ poly)"
+ "pCons a p - pCons b q = pCons (a - b) (p - q)"
+by simp_all
+
+lemmas smult_poly_code [code] =
+ smult_0_right smult_pCons
+
+lemma mult_poly_code [code]:
+ "0 * q = (0 :: _ poly)"
+ "pCons a p * q = smult a q + pCons 0 (p * q)"
+by simp_all
+
+lemmas poly_code [code] =
+ poly_0 poly_pCons
+
+lemmas synthetic_divmod_code [code] =
+ synthetic_divmod_0 synthetic_divmod_pCons
+
+text {* code generator setup for div and mod *}
+
+definition
+ pdivmod :: "'a::field poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly \<times> 'a poly"
+where
+ [code del]: "pdivmod x y = (x div y, x mod y)"
+
+lemma div_poly_code [code]: "x div y = fst (pdivmod x y)"
+ unfolding pdivmod_def by simp
+
+lemma mod_poly_code [code]: "x mod y = snd (pdivmod x y)"
+ unfolding pdivmod_def by simp
+
+lemma pdivmod_0 [code]: "pdivmod 0 y = (0, 0)"
+ unfolding pdivmod_def by simp
+
+lemma pdivmod_pCons [code]:
+ "pdivmod (pCons a x) y =
+ (if y = 0 then (0, pCons a x) else
+ (let (q, r) = pdivmod x y;
+ b = coeff (pCons a r) (degree y) / coeff y (degree y)
+ in (pCons b q, pCons a r - smult b y)))"
+apply (simp add: pdivmod_def Let_def, safe)
+apply (rule div_poly_eq)
+apply (erule pdivmod_rel_pCons [OF pdivmod_rel _ refl])
+apply (rule mod_poly_eq)
+apply (erule pdivmod_rel_pCons [OF pdivmod_rel _ refl])
+done
+
+end
--- a/src/HOL/Library/Primes.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Library/Primes.thy Thu Feb 26 11:21:29 2009 +0000
@@ -45,12 +45,14 @@
by (rule prime_dvd_square) (simp_all add: power2_eq_square)
-lemma exp_eq_1:"(x::nat)^n = 1 \<longleftrightarrow> x = 1 \<or> n = 0" by (induct n, auto)
+lemma exp_eq_1:"(x::nat)^n = 1 \<longleftrightarrow> x = 1 \<or> n = 0"
+by (induct n, auto)
+
lemma exp_mono_lt: "(x::nat) ^ (Suc n) < y ^ (Suc n) \<longleftrightarrow> x < y"
- using power_less_imp_less_base[of x "Suc n" y] power_strict_mono[of x y "Suc n"]
- by auto
+by(metis linorder_not_less not_less0 power_le_imp_le_base power_less_imp_less_base)
+
lemma exp_mono_le: "(x::nat) ^ (Suc n) \<le> y ^ (Suc n) \<longleftrightarrow> x \<le> y"
- by (simp only: linorder_not_less[symmetric] exp_mono_lt)
+by (simp only: linorder_not_less[symmetric] exp_mono_lt)
lemma exp_mono_eq: "(x::nat) ^ Suc n = y ^ Suc n \<longleftrightarrow> x = y"
using power_inject_base[of x n y] by auto
@@ -307,8 +309,8 @@
{fix e assume H: "e dvd a^n" "e dvd b^n"
from bezout_gcd_pow[of a n b] obtain x y
where xy: "a ^ n * x - b ^ n * y = ?gn \<or> b ^ n * x - a ^ n * y = ?gn" by blast
- from dvd_diff [OF dvd_mult2[OF H(1), of x] dvd_mult2[OF H(2), of y]]
- dvd_diff [OF dvd_mult2[OF H(2), of x] dvd_mult2[OF H(1), of y]] xy
+ from nat_dvd_diff [OF dvd_mult2[OF H(1), of x] dvd_mult2[OF H(2), of y]]
+ nat_dvd_diff [OF dvd_mult2[OF H(2), of x] dvd_mult2[OF H(1), of y]] xy
have "e dvd ?gn" by (cases "a ^ n * x - b ^ n * y = gcd a b ^ n", simp_all)}
hence th: "\<forall>e. e dvd a^n \<and> e dvd b^n \<longrightarrow> e dvd ?gn" by blast
from divides_exp[OF gcd_dvd1[of a b], of n] divides_exp[OF gcd_dvd2[of a b], of n] th
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Library/Product_Vector.thy Thu Feb 26 11:21:29 2009 +0000
@@ -0,0 +1,273 @@
+(* Title: HOL/Library/Product_Vector.thy
+ Author: Brian Huffman
+*)
+
+header {* Cartesian Products as Vector Spaces *}
+
+theory Product_Vector
+imports Inner_Product Product_plus
+begin
+
+subsection {* Product is a real vector space *}
+
+instantiation "*" :: (real_vector, real_vector) real_vector
+begin
+
+definition scaleR_prod_def:
+ "scaleR r A = (scaleR r (fst A), scaleR r (snd A))"
+
+lemma fst_scaleR [simp]: "fst (scaleR r A) = scaleR r (fst A)"
+ unfolding scaleR_prod_def by simp
+
+lemma snd_scaleR [simp]: "snd (scaleR r A) = scaleR r (snd A)"
+ unfolding scaleR_prod_def by simp
+
+lemma scaleR_Pair [simp]: "scaleR r (a, b) = (scaleR r a, scaleR r b)"
+ unfolding scaleR_prod_def by simp
+
+instance proof
+ fix a b :: real and x y :: "'a \<times> 'b"
+ show "scaleR a (x + y) = scaleR a x + scaleR a y"
+ by (simp add: expand_prod_eq scaleR_right_distrib)
+ show "scaleR (a + b) x = scaleR a x + scaleR b x"
+ by (simp add: expand_prod_eq scaleR_left_distrib)
+ show "scaleR a (scaleR b x) = scaleR (a * b) x"
+ by (simp add: expand_prod_eq)
+ show "scaleR 1 x = x"
+ by (simp add: expand_prod_eq)
+qed
+
+end
+
+subsection {* Product is a normed vector space *}
+
+instantiation
+ "*" :: (real_normed_vector, real_normed_vector) real_normed_vector
+begin
+
+definition norm_prod_def:
+ "norm x = sqrt ((norm (fst x))\<twosuperior> + (norm (snd x))\<twosuperior>)"
+
+definition sgn_prod_def:
+ "sgn (x::'a \<times> 'b) = scaleR (inverse (norm x)) x"
+
+lemma norm_Pair: "norm (a, b) = sqrt ((norm a)\<twosuperior> + (norm b)\<twosuperior>)"
+ unfolding norm_prod_def by simp
+
+instance proof
+ fix r :: real and x y :: "'a \<times> 'b"
+ show "0 \<le> norm x"
+ unfolding norm_prod_def by simp
+ show "norm x = 0 \<longleftrightarrow> x = 0"
+ unfolding norm_prod_def
+ by (simp add: expand_prod_eq)
+ show "norm (x + y) \<le> norm x + norm y"
+ unfolding norm_prod_def
+ apply (rule order_trans [OF _ real_sqrt_sum_squares_triangle_ineq])
+ apply (simp add: add_mono power_mono norm_triangle_ineq)
+ done
+ show "norm (scaleR r x) = \<bar>r\<bar> * norm x"
+ unfolding norm_prod_def
+ apply (simp add: norm_scaleR power_mult_distrib)
+ apply (simp add: right_distrib [symmetric])
+ apply (simp add: real_sqrt_mult_distrib)
+ done
+ show "sgn x = scaleR (inverse (norm x)) x"
+ by (rule sgn_prod_def)
+qed
+
+end
+
+subsection {* Product is an inner product space *}
+
+instantiation "*" :: (real_inner, real_inner) real_inner
+begin
+
+definition inner_prod_def:
+ "inner x y = inner (fst x) (fst y) + inner (snd x) (snd y)"
+
+lemma inner_Pair [simp]: "inner (a, b) (c, d) = inner a c + inner b d"
+ unfolding inner_prod_def by simp
+
+instance proof
+ fix r :: real
+ fix x y z :: "'a::real_inner * 'b::real_inner"
+ show "inner x y = inner y x"
+ unfolding inner_prod_def
+ by (simp add: inner_commute)
+ show "inner (x + y) z = inner x z + inner y z"
+ unfolding inner_prod_def
+ by (simp add: inner_left_distrib)
+ show "inner (scaleR r x) y = r * inner x y"
+ unfolding inner_prod_def
+ by (simp add: inner_scaleR_left right_distrib)
+ show "0 \<le> inner x x"
+ unfolding inner_prod_def
+ by (intro add_nonneg_nonneg inner_ge_zero)
+ show "inner x x = 0 \<longleftrightarrow> x = 0"
+ unfolding inner_prod_def expand_prod_eq
+ by (simp add: add_nonneg_eq_0_iff)
+ show "norm x = sqrt (inner x x)"
+ unfolding norm_prod_def inner_prod_def
+ by (simp add: power2_norm_eq_inner)
+qed
+
+end
+
+subsection {* Pair operations are linear and continuous *}
+
+interpretation fst!: bounded_linear fst
+ apply (unfold_locales)
+ apply (rule fst_add)
+ apply (rule fst_scaleR)
+ apply (rule_tac x="1" in exI, simp add: norm_Pair)
+ done
+
+interpretation snd!: bounded_linear snd
+ apply (unfold_locales)
+ apply (rule snd_add)
+ apply (rule snd_scaleR)
+ apply (rule_tac x="1" in exI, simp add: norm_Pair)
+ done
+
+text {* TODO: move to NthRoot *}
+lemma sqrt_add_le_add_sqrt:
+ assumes x: "0 \<le> x" and y: "0 \<le> y"
+ shows "sqrt (x + y) \<le> sqrt x + sqrt y"
+apply (rule power2_le_imp_le)
+apply (simp add: real_sum_squared_expand add_nonneg_nonneg x y)
+apply (simp add: mult_nonneg_nonneg x y)
+apply (simp add: add_nonneg_nonneg x y)
+done
+
+lemma bounded_linear_Pair:
+ assumes f: "bounded_linear f"
+ assumes g: "bounded_linear g"
+ shows "bounded_linear (\<lambda>x. (f x, g x))"
+proof
+ interpret f: bounded_linear f by fact
+ interpret g: bounded_linear g by fact
+ fix x y and r :: real
+ show "(f (x + y), g (x + y)) = (f x, g x) + (f y, g y)"
+ by (simp add: f.add g.add)
+ show "(f (r *\<^sub>R x), g (r *\<^sub>R x)) = r *\<^sub>R (f x, g x)"
+ by (simp add: f.scaleR g.scaleR)
+ obtain Kf where "0 < Kf" and norm_f: "\<And>x. norm (f x) \<le> norm x * Kf"
+ using f.pos_bounded by fast
+ obtain Kg where "0 < Kg" and norm_g: "\<And>x. norm (g x) \<le> norm x * Kg"
+ using g.pos_bounded by fast
+ have "\<forall>x. norm (f x, g x) \<le> norm x * (Kf + Kg)"
+ apply (rule allI)
+ apply (simp add: norm_Pair)
+ apply (rule order_trans [OF sqrt_add_le_add_sqrt], simp, simp)
+ apply (simp add: right_distrib)
+ apply (rule add_mono [OF norm_f norm_g])
+ done
+ then show "\<exists>K. \<forall>x. norm (f x, g x) \<le> norm x * K" ..
+qed
+
+text {*
+ TODO: The next three proofs are nearly identical to each other.
+ Is there a good way to factor out the common parts?
+*}
+
+lemma LIMSEQ_Pair:
+ assumes "X ----> a" and "Y ----> b"
+ shows "(\<lambda>n. (X n, Y n)) ----> (a, b)"
+proof (rule LIMSEQ_I)
+ fix r :: real assume "0 < r"
+ then have "0 < r / sqrt 2" (is "0 < ?s")
+ by (simp add: divide_pos_pos)
+ obtain M where M: "\<forall>n\<ge>M. norm (X n - a) < ?s"
+ using LIMSEQ_D [OF `X ----> a` `0 < ?s`] ..
+ obtain N where N: "\<forall>n\<ge>N. norm (Y n - b) < ?s"
+ using LIMSEQ_D [OF `Y ----> b` `0 < ?s`] ..
+ have "\<forall>n\<ge>max M N. norm ((X n, Y n) - (a, b)) < r"
+ using M N by (simp add: real_sqrt_sum_squares_less norm_Pair)
+ then show "\<exists>n0. \<forall>n\<ge>n0. norm ((X n, Y n) - (a, b)) < r" ..
+qed
+
+lemma Cauchy_Pair:
+ assumes "Cauchy X" and "Cauchy Y"
+ shows "Cauchy (\<lambda>n. (X n, Y n))"
+proof (rule CauchyI)
+ fix r :: real assume "0 < r"
+ then have "0 < r / sqrt 2" (is "0 < ?s")
+ by (simp add: divide_pos_pos)
+ obtain M where M: "\<forall>m\<ge>M. \<forall>n\<ge>M. norm (X m - X n) < ?s"
+ using CauchyD [OF `Cauchy X` `0 < ?s`] ..
+ obtain N where N: "\<forall>m\<ge>N. \<forall>n\<ge>N. norm (Y m - Y n) < ?s"
+ using CauchyD [OF `Cauchy Y` `0 < ?s`] ..
+ have "\<forall>m\<ge>max M N. \<forall>n\<ge>max M N. norm ((X m, Y m) - (X n, Y n)) < r"
+ using M N by (simp add: real_sqrt_sum_squares_less norm_Pair)
+ then show "\<exists>n0. \<forall>m\<ge>n0. \<forall>n\<ge>n0. norm ((X m, Y m) - (X n, Y n)) < r" ..
+qed
+
+lemma LIM_Pair:
+ assumes "f -- x --> a" and "g -- x --> b"
+ shows "(\<lambda>x. (f x, g x)) -- x --> (a, b)"
+proof (rule LIM_I)
+ fix r :: real assume "0 < r"
+ then have "0 < r / sqrt 2" (is "0 < ?e")
+ by (simp add: divide_pos_pos)
+ obtain s where s: "0 < s"
+ "\<forall>z. z \<noteq> x \<and> norm (z - x) < s \<longrightarrow> norm (f z - a) < ?e"
+ using LIM_D [OF `f -- x --> a` `0 < ?e`] by fast
+ obtain t where t: "0 < t"
+ "\<forall>z. z \<noteq> x \<and> norm (z - x) < t \<longrightarrow> norm (g z - b) < ?e"
+ using LIM_D [OF `g -- x --> b` `0 < ?e`] by fast
+ have "0 < min s t \<and>
+ (\<forall>z. z \<noteq> x \<and> norm (z - x) < min s t \<longrightarrow> norm ((f z, g z) - (a, b)) < r)"
+ using s t by (simp add: real_sqrt_sum_squares_less norm_Pair)
+ then show
+ "\<exists>s>0. \<forall>z. z \<noteq> x \<and> norm (z - x) < s \<longrightarrow> norm ((f z, g z) - (a, b)) < r" ..
+qed
+
+lemma isCont_Pair [simp]:
+ "\<lbrakk>isCont f x; isCont g x\<rbrakk> \<Longrightarrow> isCont (\<lambda>x. (f x, g x)) x"
+ unfolding isCont_def by (rule LIM_Pair)
+
+
+subsection {* Product is a complete vector space *}
+
+instance "*" :: (banach, banach) banach
+proof
+ fix X :: "nat \<Rightarrow> 'a \<times> 'b" assume "Cauchy X"
+ have 1: "(\<lambda>n. fst (X n)) ----> lim (\<lambda>n. fst (X n))"
+ using fst.Cauchy [OF `Cauchy X`]
+ by (simp add: Cauchy_convergent_iff convergent_LIMSEQ_iff)
+ have 2: "(\<lambda>n. snd (X n)) ----> lim (\<lambda>n. snd (X n))"
+ using snd.Cauchy [OF `Cauchy X`]
+ by (simp add: Cauchy_convergent_iff convergent_LIMSEQ_iff)
+ have "X ----> (lim (\<lambda>n. fst (X n)), lim (\<lambda>n. snd (X n)))"
+ using LIMSEQ_Pair [OF 1 2] by simp
+ then show "convergent X"
+ by (rule convergentI)
+qed
+
+subsection {* Frechet derivatives involving pairs *}
+
+lemma FDERIV_Pair:
+ assumes f: "FDERIV f x :> f'" and g: "FDERIV g x :> g'"
+ shows "FDERIV (\<lambda>x. (f x, g x)) x :> (\<lambda>h. (f' h, g' h))"
+apply (rule FDERIV_I)
+apply (rule bounded_linear_Pair)
+apply (rule FDERIV_bounded_linear [OF f])
+apply (rule FDERIV_bounded_linear [OF g])
+apply (simp add: norm_Pair)
+apply (rule real_LIM_sandwich_zero)
+apply (rule LIM_add_zero)
+apply (rule FDERIV_D [OF f])
+apply (rule FDERIV_D [OF g])
+apply (rename_tac h)
+apply (simp add: divide_nonneg_pos)
+apply (rename_tac h)
+apply (subst add_divide_distrib [symmetric])
+apply (rule divide_right_mono [OF _ norm_ge_zero])
+apply (rule order_trans [OF sqrt_add_le_add_sqrt])
+apply simp
+apply simp
+apply simp
+done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Library/Product_plus.thy Thu Feb 26 11:21:29 2009 +0000
@@ -0,0 +1,115 @@
+(* Title: HOL/Library/Product_plus.thy
+ Author: Brian Huffman
+*)
+
+header {* Additive group operations on product types *}
+
+theory Product_plus
+imports Main
+begin
+
+subsection {* Operations *}
+
+instantiation "*" :: (zero, zero) zero
+begin
+
+definition zero_prod_def: "0 = (0, 0)"
+
+instance ..
+end
+
+instantiation "*" :: (plus, plus) plus
+begin
+
+definition plus_prod_def:
+ "x + y = (fst x + fst y, snd x + snd y)"
+
+instance ..
+end
+
+instantiation "*" :: (minus, minus) minus
+begin
+
+definition minus_prod_def:
+ "x - y = (fst x - fst y, snd x - snd y)"
+
+instance ..
+end
+
+instantiation "*" :: (uminus, uminus) uminus
+begin
+
+definition uminus_prod_def:
+ "- x = (- fst x, - snd x)"
+
+instance ..
+end
+
+lemma fst_zero [simp]: "fst 0 = 0"
+ unfolding zero_prod_def by simp
+
+lemma snd_zero [simp]: "snd 0 = 0"
+ unfolding zero_prod_def by simp
+
+lemma fst_add [simp]: "fst (x + y) = fst x + fst y"
+ unfolding plus_prod_def by simp
+
+lemma snd_add [simp]: "snd (x + y) = snd x + snd y"
+ unfolding plus_prod_def by simp
+
+lemma fst_diff [simp]: "fst (x - y) = fst x - fst y"
+ unfolding minus_prod_def by simp
+
+lemma snd_diff [simp]: "snd (x - y) = snd x - snd y"
+ unfolding minus_prod_def by simp
+
+lemma fst_uminus [simp]: "fst (- x) = - fst x"
+ unfolding uminus_prod_def by simp
+
+lemma snd_uminus [simp]: "snd (- x) = - snd x"
+ unfolding uminus_prod_def by simp
+
+lemma add_Pair [simp]: "(a, b) + (c, d) = (a + c, b + d)"
+ unfolding plus_prod_def by simp
+
+lemma diff_Pair [simp]: "(a, b) - (c, d) = (a - c, b - d)"
+ unfolding minus_prod_def by simp
+
+lemma uminus_Pair [simp, code]: "- (a, b) = (- a, - b)"
+ unfolding uminus_prod_def by simp
+
+lemmas expand_prod_eq = Pair_fst_snd_eq
+
+
+subsection {* Class instances *}
+
+instance "*" :: (semigroup_add, semigroup_add) semigroup_add
+ by default (simp add: expand_prod_eq add_assoc)
+
+instance "*" :: (ab_semigroup_add, ab_semigroup_add) ab_semigroup_add
+ by default (simp add: expand_prod_eq add_commute)
+
+instance "*" :: (monoid_add, monoid_add) monoid_add
+ by default (simp_all add: expand_prod_eq)
+
+instance "*" :: (comm_monoid_add, comm_monoid_add) comm_monoid_add
+ by default (simp add: expand_prod_eq)
+
+instance "*" ::
+ (cancel_semigroup_add, cancel_semigroup_add) cancel_semigroup_add
+ by default (simp_all add: expand_prod_eq)
+
+instance "*" ::
+ (cancel_ab_semigroup_add, cancel_ab_semigroup_add) cancel_ab_semigroup_add
+ by default (simp add: expand_prod_eq)
+
+instance "*" ::
+ (cancel_comm_monoid_add, cancel_comm_monoid_add) cancel_comm_monoid_add ..
+
+instance "*" :: (group_add, group_add) group_add
+ by default (simp_all add: expand_prod_eq diff_minus)
+
+instance "*" :: (ab_group_add, ab_group_add) ab_group_add
+ by default (simp_all add: expand_prod_eq)
+
+end
--- a/src/HOL/List.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/List.thy Thu Feb 26 11:21:29 2009 +0000
@@ -1438,10 +1438,10 @@
apply (auto split:nat.split)
done
-lemma last_conv_nth: "xs\<noteq>[] \<Longrightarrow> last xs = xs!(length xs - 1)"
+lemma last_conv_nth: "xs\<noteq>[] \<Longrightarrow> last xs = xs!(length xs - Suc 0)"
by(induct xs)(auto simp:neq_Nil_conv)
-lemma butlast_conv_take: "butlast xs = take (length xs - 1) xs"
+lemma butlast_conv_take: "butlast xs = take (length xs - Suc 0) xs"
by (induct xs, simp, case_tac xs, simp_all)
@@ -1588,7 +1588,7 @@
done
lemma butlast_take:
- "n <= length xs ==> butlast (take n xs) = take (n - 1) xs"
+ "n <= length xs ==> butlast (take n xs) = take (n - Suc 0) xs"
by (simp add: butlast_conv_take min_max.inf_absorb1 min_max.inf_absorb2)
lemma butlast_drop: "butlast (drop n xs) = drop n (butlast xs)"
@@ -1639,7 +1639,7 @@
done
lemma take_hd_drop:
- "n < length xs \<Longrightarrow> take n xs @ [hd (drop n xs)] = take (n+1) xs"
+ "n < length xs \<Longrightarrow> take n xs @ [hd (drop n xs)] = take (Suc n) xs"
apply(induct xs arbitrary: n)
apply simp
apply(simp add:drop_Cons split:nat.split)
@@ -2458,7 +2458,7 @@
done
lemma length_remove1:
- "length(remove1 x xs) = (if x : set xs then length xs - 1 else length xs)"
+ "length(remove1 x xs) = (if x : set xs then length xs - Suc 0 else length xs)"
apply (induct xs)
apply (auto dest!:length_pos_if_in_set)
done
@@ -3564,52 +3564,51 @@
open Basic_Code_Thingol;
-fun implode_list (nil', cons') t =
- let
- fun dest_cons (IConst (c, _) `$ t1 `$ t2) =
- if c = cons'
- then SOME (t1, t2)
- else NONE
- | dest_cons _ = NONE;
- val (ts, t') = Code_Thingol.unfoldr dest_cons t;
- in case t'
- of IConst (c, _) => if c = nil' then SOME ts else NONE
+fun implode_list naming t = case pairself
+ (Code_Thingol.lookup_const naming) (@{const_name Nil}, @{const_name Cons})
+ of (SOME nil', SOME cons') => let
+ fun dest_cons (IConst (c, _) `$ t1 `$ t2) =
+ if c = cons'
+ then SOME (t1, t2)
+ else NONE
+ | dest_cons _ = NONE;
+ val (ts, t') = Code_Thingol.unfoldr dest_cons t;
+ in case t'
+ of IConst (c, _) => if c = nil' then SOME ts else NONE
+ | _ => NONE
+ end
| _ => NONE
- end;
-
-fun decode_char nibbles' (IConst (c1, _), IConst (c2, _)) =
- let
- fun idx c = find_index (curry (op =) c) nibbles';
- fun decode ~1 _ = NONE
- | decode _ ~1 = NONE
- | decode n m = SOME (chr (n * 16 + m));
- in decode (idx c1) (idx c2) end
- | decode_char _ _ = NONE;
-
-fun implode_string (char', nibbles') mk_char mk_string ts =
- let
- fun implode_char (IConst (c, _) `$ t1 `$ t2) =
- if c = char' then decode_char nibbles' (t1, t2) else NONE
- | implode_char _ = NONE;
- val ts' = map implode_char ts;
- in if forall is_some ts'
- then (SOME o Code_Printer.str o mk_string o implode o map_filter I) ts'
- else NONE
- end;
-
-fun list_names naming = pairself (the o Code_Thingol.lookup_const naming)
- (@{const_name Nil}, @{const_name Cons});
-fun char_name naming = (the o Code_Thingol.lookup_const naming)
- @{const_name Char}
-fun nibble_names naming = map (the o Code_Thingol.lookup_const naming)
- [@{const_name Nibble0}, @{const_name Nibble1},
+
+fun decode_char naming (IConst (c1, _), IConst (c2, _)) = (case map_filter
+ (Code_Thingol.lookup_const naming)[@{const_name Nibble0}, @{const_name Nibble1},
@{const_name Nibble2}, @{const_name Nibble3},
@{const_name Nibble4}, @{const_name Nibble5},
@{const_name Nibble6}, @{const_name Nibble7},
@{const_name Nibble8}, @{const_name Nibble9},
@{const_name NibbleA}, @{const_name NibbleB},
@{const_name NibbleC}, @{const_name NibbleD},
- @{const_name NibbleE}, @{const_name NibbleF}];
+ @{const_name NibbleE}, @{const_name NibbleF}]
+ of nibbles' as [_, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _] => let
+ fun idx c = find_index (curry (op =) c) nibbles';
+ fun decode ~1 _ = NONE
+ | decode _ ~1 = NONE
+ | decode n m = SOME (chr (n * 16 + m));
+ in decode (idx c1) (idx c2) end
+ | _ => NONE)
+ | decode_char _ _ = NONE
+
+fun implode_string naming mk_char mk_string ts = case
+ Code_Thingol.lookup_const naming @{const_name Char}
+ of SOME char' => let
+ fun implode_char (IConst (c, _) `$ t1 `$ t2) =
+ if c = char' then decode_char naming (t1, t2) else NONE
+ | implode_char _ = NONE;
+ val ts' = map implode_char ts;
+ in if forall is_some ts'
+ then (SOME o Code_Printer.str o mk_string o implode o map_filter I) ts'
+ else NONE
+ end
+ | _ => NONE;
fun default_list (target_fxy, target_cons) pr fxy t1 t2 =
Code_Printer.brackify_infix (target_fxy, Code_Printer.R) fxy [
@@ -3622,7 +3621,7 @@
let
val mk_list = Code_Printer.literal_list literals;
fun pretty pr naming thm vars fxy [(t1, _), (t2, _)] =
- case Option.map (cons t1) (implode_list (list_names naming) t2)
+ case Option.map (cons t1) (implode_list naming t2)
of SOME ts => mk_list (map (pr vars Code_Printer.NOBR) ts)
| NONE => default_list (Code_Printer.infix_cons literals) (pr vars) fxy t1 t2;
in (2, pretty) end;
@@ -3633,8 +3632,8 @@
val mk_char = Code_Printer.literal_char literals;
val mk_string = Code_Printer.literal_string literals;
fun pretty pr naming thm vars fxy [(t1, _), (t2, _)] =
- case Option.map (cons t1) (implode_list (list_names naming) t2)
- of SOME ts => (case implode_string (char_name naming, nibble_names naming) mk_char mk_string ts
+ case Option.map (cons t1) (implode_list naming t2)
+ of SOME ts => (case implode_string naming mk_char mk_string ts
of SOME p => p
| NONE => mk_list (map (pr vars Code_Printer.NOBR) ts))
| NONE => default_list (Code_Printer.infix_cons literals) (pr vars) fxy t1 t2;
@@ -3644,7 +3643,7 @@
let
val mk_char = Code_Printer.literal_char literals;
fun pretty _ naming thm _ _ [(t1, _), (t2, _)] =
- case decode_char (nibble_names naming) (t1, t2)
+ case decode_char naming (t1, t2)
of SOME c => (Code_Printer.str o mk_char) c
| NONE => Code_Printer.nerror thm "Illegal character expression";
in (2, pretty) end;
@@ -3654,8 +3653,8 @@
val mk_char = Code_Printer.literal_char literals;
val mk_string = Code_Printer.literal_string literals;
fun pretty _ naming thm _ _ [(t, _)] =
- case implode_list (list_names naming) t
- of SOME ts => (case implode_string (char_name naming, nibble_names naming) mk_char mk_string ts
+ case implode_list naming t
+ of SOME ts => (case implode_string naming mk_char mk_string ts
of SOME p => p
| NONE => Code_Printer.nerror thm "Illegal message expression")
| NONE => Code_Printer.nerror thm "Illegal message expression";
--- a/src/HOL/MacLaurin.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/MacLaurin.thy Thu Feb 26 11:21:29 2009 +0000
@@ -81,7 +81,7 @@
prefer 2 apply simp
apply (frule less_iff_Suc_add [THEN iffD1], clarify)
apply (simp del: setsum_op_ivl_Suc)
- apply (insert sumr_offset4 [of 1])
+ apply (insert sumr_offset4 [of "Suc 0"])
apply (simp del: setsum_op_ivl_Suc fact_Suc realpow_Suc)
apply (rule lemma_DERIV_subst)
apply (rule DERIV_add)
@@ -124,7 +124,7 @@
have g2: "g 0 = 0 & g h = 0"
apply (simp add: m f_h g_def del: setsum_op_ivl_Suc)
- apply (cut_tac n = m and k = 1 in sumr_offset2)
+ apply (cut_tac n = m and k = "Suc 0" in sumr_offset2)
apply (simp add: eq_diff_eq' diff_0 del: setsum_op_ivl_Suc)
done
@@ -144,7 +144,7 @@
apply (simp add: m difg_def)
apply (frule less_iff_Suc_add [THEN iffD1], clarify)
apply (simp del: setsum_op_ivl_Suc)
- apply (insert sumr_offset4 [of 1])
+ apply (insert sumr_offset4 [of "Suc 0"])
apply (simp del: setsum_op_ivl_Suc fact_Suc realpow_Suc)
done
@@ -552,6 +552,10 @@
"[|x = y; abs u \<le> (v::real) |] ==> \<bar>(x + u) - y\<bar> \<le> v"
by auto
+text {* TODO: move to Parity.thy *}
+lemma nat_odd_1 [simp]: "odd (1::nat)"
+ unfolding even_nat_def by simp
+
lemma Maclaurin_sin_bound:
"abs(sin x - (\<Sum>m=0..<n. (if even m then 0 else (-1 ^ ((m - Suc 0) div 2)) / real (fact m)) *
x ^ m)) \<le> inverse(real (fact n)) * \<bar>x\<bar> ^ n"
--- a/src/HOL/NSA/NSA.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/NSA/NSA.thy Thu Feb 26 11:21:29 2009 +0000
@@ -157,7 +157,7 @@
by transfer (rule norm_divide)
lemma hypreal_hnorm_def [simp]:
- "\<And>r::hypreal. hnorm r \<equiv> \<bar>r\<bar>"
+ "\<And>r::hypreal. hnorm r = \<bar>r\<bar>"
by transfer (rule real_norm_def)
lemma hnorm_add_less:
--- a/src/HOL/Nat.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Nat.thy Thu Feb 26 11:21:29 2009 +0000
@@ -196,8 +196,8 @@
instance proof
fix n m q :: nat
- show "0 \<noteq> (1::nat)" by simp
- show "1 * n = n" by simp
+ show "0 \<noteq> (1::nat)" unfolding One_nat_def by simp
+ show "1 * n = n" unfolding One_nat_def by simp
show "n * m = m * n" by (induct n) simp_all
show "(n * m) * q = n * (m * q)" by (induct n) (simp_all add: add_mult_distrib)
show "(n + m) * q = n * q + m * q" by (rule add_mult_distrib)
@@ -280,6 +280,9 @@
lemma diff_add_0: "n - (n + m) = (0::nat)"
by (induct n) simp_all
+lemma diff_Suc_1 [simp]: "Suc n - 1 = n"
+ unfolding One_nat_def by simp
+
text {* Difference distributes over multiplication *}
lemma diff_mult_distrib: "((m::nat) - n) * k = (m * k) - (n * k)"
@@ -307,18 +310,24 @@
lemmas nat_distrib =
add_mult_distrib add_mult_distrib2 diff_mult_distrib diff_mult_distrib2
-lemma mult_eq_1_iff [simp]: "(m * n = Suc 0) = (m = 1 & n = 1)"
+lemma mult_eq_1_iff [simp]: "(m * n = Suc 0) = (m = Suc 0 & n = Suc 0)"
apply (induct m)
apply simp
apply (induct n)
apply auto
done
-lemma one_eq_mult_iff [simp,noatp]: "(Suc 0 = m * n) = (m = 1 & n = 1)"
+lemma one_eq_mult_iff [simp,noatp]: "(Suc 0 = m * n) = (m = Suc 0 & n = Suc 0)"
apply (rule trans)
apply (rule_tac [2] mult_eq_1_iff, fastsimp)
done
+lemma nat_mult_eq_1_iff [simp]: "m * n = (1::nat) \<longleftrightarrow> m = 1 \<and> n = 1"
+ unfolding One_nat_def by (rule mult_eq_1_iff)
+
+lemma nat_1_eq_mult_iff [simp]: "(1::nat) = m * n \<longleftrightarrow> m = 1 \<and> n = 1"
+ unfolding One_nat_def by (rule one_eq_mult_iff)
+
lemma mult_cancel1 [simp]: "(k * m = k * n) = (m = n | (k = (0::nat)))"
proof -
have "k \<noteq> 0 \<Longrightarrow> k * m = k * n \<Longrightarrow> m = n"
@@ -465,11 +474,11 @@
lemma less_Suc_eq: "(m < Suc n) = (m < n | m = n)"
unfolding less_Suc_eq_le le_less ..
-lemma less_one [iff, noatp]: "(n < (1::nat)) = (n = 0)"
+lemma less_Suc0 [iff]: "(n < Suc 0) = (n = 0)"
by (simp add: less_Suc_eq)
-lemma less_Suc0 [iff]: "(n < Suc 0) = (n = 0)"
- by (simp add: less_Suc_eq)
+lemma less_one [iff, noatp]: "(n < (1::nat)) = (n = 0)"
+ unfolding One_nat_def by (rule less_Suc0)
lemma Suc_mono: "m < n ==> Suc m < Suc n"
by simp
@@ -735,6 +744,11 @@
show "i < j ==> 0 < k ==> k * i < k * j" by (simp add: mult_less_mono2)
qed
+instance nat :: no_zero_divisors
+proof
+ fix a::nat and b::nat show "a ~= 0 \<Longrightarrow> b ~= 0 \<Longrightarrow> a * b ~= 0" by auto
+qed
+
lemma nat_mult_1: "(1::nat) * n = n"
by simp
@@ -795,6 +809,7 @@
done
lemma ex_least_nat_less: "\<not>P(0) \<Longrightarrow> P(n::nat) \<Longrightarrow> \<exists>k<n. (\<forall>i\<le>k. \<not>P i) & P(k+1)"
+ unfolding One_nat_def
apply (cases n)
apply blast
apply (frule (1) ex_least_nat_le)
@@ -1084,7 +1099,7 @@
apply simp_all
done
-lemma one_le_mult_iff [simp]: "(Suc 0 \<le> m * n) = (1 \<le> m & 1 \<le> n)"
+lemma one_le_mult_iff [simp]: "(Suc 0 \<le> m * n) = (Suc 0 \<le> m & Suc 0 \<le> n)"
apply (induct m)
apply simp
apply (case_tac n)
@@ -1120,7 +1135,7 @@
by (cases m) (auto intro: le_add1)
text {* Lemma for @{text gcd} *}
-lemma mult_eq_self_implies_10: "(m::nat) = m * n ==> n = 1 | m = 0"
+lemma mult_eq_self_implies_10: "(m::nat) = m * n ==> n = Suc 0 | m = 0"
apply (drule sym)
apply (rule disjCI)
apply (rule nat_less_cases, erule_tac [2] _)
@@ -1159,7 +1174,7 @@
| of_nat_Suc: "of_nat (Suc m) = 1 + of_nat m"
lemma of_nat_1 [simp]: "of_nat 1 = 1"
- by simp
+ unfolding One_nat_def by simp
lemma of_nat_add [simp]: "of_nat (m + n) = of_nat m + of_nat n"
by (induct m) (simp_all add: add_ac)
@@ -1271,7 +1286,7 @@
end
lemma of_nat_id [simp]: "of_nat n = n"
- by (induct n) auto
+ by (induct n) (auto simp add: One_nat_def)
lemma of_nat_eq_id [simp]: "of_nat = id"
by (auto simp add: expand_fun_eq)
@@ -1376,7 +1391,7 @@
apply(induct_tac k)
apply simp
apply(erule_tac x="m+n" in meta_allE)
-apply(erule_tac x="m+n+1" in meta_allE)
+apply(erule_tac x="Suc(m+n)" in meta_allE)
apply simp
done
--- a/src/HOL/NatBin.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/NatBin.thy Thu Feb 26 11:21:29 2009 +0000
@@ -159,6 +159,21 @@
unfolding nat_number_of_def number_of_is_id numeral_simps
by (simp add: nat_add_distrib)
+lemma nat_number_of_add_1 [simp]:
+ "number_of v + (1::nat) =
+ (if v < Int.Pls then 1 else number_of (Int.succ v))"
+ unfolding nat_number_of_def number_of_is_id numeral_simps
+ by (simp add: nat_add_distrib)
+
+lemma nat_1_add_number_of [simp]:
+ "(1::nat) + number_of v =
+ (if v < Int.Pls then 1 else number_of (Int.succ v))"
+ unfolding nat_number_of_def number_of_is_id numeral_simps
+ by (simp add: nat_add_distrib)
+
+lemma nat_1_add_1 [simp]: "1 + 1 = (2::nat)"
+ by (rule int_int_eq [THEN iffD1]) simp
+
subsubsection{*Subtraction *}
@@ -178,6 +193,12 @@
unfolding nat_number_of_def number_of_is_id numeral_simps neg_def
by auto
+lemma nat_number_of_diff_1 [simp]:
+ "number_of v - (1::nat) =
+ (if v \<le> Int.Pls then 0 else number_of (Int.pred v))"
+ unfolding nat_number_of_def number_of_is_id numeral_simps
+ by auto
+
subsubsection{*Multiplication *}
@@ -442,19 +463,13 @@
(* These two can be useful when m = number_of... *)
lemma add_eq_if: "(m::nat) + n = (if m=0 then n else Suc ((m - 1) + n))"
-apply (case_tac "m")
-apply (simp_all add: numerals)
-done
+ unfolding One_nat_def by (cases m) simp_all
lemma mult_eq_if: "(m::nat) * n = (if m=0 then 0 else n + ((m - 1) * n))"
-apply (case_tac "m")
-apply (simp_all add: numerals)
-done
+ unfolding One_nat_def by (cases m) simp_all
lemma power_eq_if: "(p ^ m :: nat) = (if m=0 then 1 else p * (p ^ (m - 1)))"
-apply (case_tac "m")
-apply (simp_all add: numerals)
-done
+ unfolding One_nat_def by (cases m) simp_all
subsection{*Comparisons involving (0::nat) *}
--- a/src/HOL/Nominal/Examples/Fsub.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Nominal/Examples/Fsub.thy Thu Feb 26 11:21:29 2009 +0000
@@ -7,13 +7,18 @@
text{* Authors: Christian Urban,
Benjamin Pierce,
Dimitrios Vytiniotis
- Stephanie Weirich and
+ Stephanie Weirich
Steve Zdancewic
+ Julien Narboux
+ Stefan Berghofer
- with great help from Stefan Berghofer and Markus Wenzel. *}
+ with great help from Markus Wenzel. *}
section {* Types for Names, Nominal Datatype Declaration for Types and Terms *}
+no_syntax
+ "_Map" :: "maplets => 'a ~=> 'b" ("(1[_])")
+
text {* The main point of this solution is to use names everywhere (be they bound,
binding or free). In System \FSUB{} there are two kinds of names corresponding to
type-variables and to term-variables. These two kinds of names are represented in
@@ -31,30 +36,35 @@
nominal_datatype ty =
Tvar "tyvrs"
| Top
- | Arrow "ty" "ty" ("_ \<rightarrow> _" [100,100] 100)
+ | Arrow "ty" "ty" (infixr "\<rightarrow>" 200)
| Forall "\<guillemotleft>tyvrs\<guillemotright>ty" "ty"
nominal_datatype trm =
Var "vrs"
- | Lam "\<guillemotleft>vrs\<guillemotright>trm" "ty"
- | Tabs "\<guillemotleft>tyvrs\<guillemotright>trm" "ty"
- | App "trm" "trm"
- | Tapp "trm" "ty"
+ | Abs "\<guillemotleft>vrs\<guillemotright>trm" "ty"
+ | TAbs "\<guillemotleft>tyvrs\<guillemotright>trm" "ty"
+ | App "trm" "trm" (infixl "\<cdot>" 200)
+ | TApp "trm" "ty" (infixl "\<cdot>\<^sub>\<tau>" 200)
text {* To be polite to the eye, some more familiar notation is introduced.
Because of the change in the order of arguments, one needs to use
translation rules, instead of syntax annotations at the term-constructors
as given above for @{term "Arrow"}. *}
-syntax
- Forall_syn :: "tyvrs \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> ty" ("\<forall>[_<:_]._" [100,100,100] 100)
- Lam_syn :: "vrs \<Rightarrow> ty \<Rightarrow> trm \<Rightarrow> trm" ("Lam [_:_]._" [100,100,100] 100)
- Tabs_syn :: "tyvrs \<Rightarrow> ty \<Rightarrow> trm \<Rightarrow> trm" ("Tabs [_<:_]._" [100,100,100] 100)
+abbreviation
+ Forall_syn :: "tyvrs \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> ty" ("(3\<forall>_<:_./ _)" [0, 0, 10] 10)
+where
+ "\<forall>X<:T\<^isub>1. T\<^isub>2 \<equiv> ty.Forall X T\<^isub>2 T\<^isub>1"
-translations
- "\<forall>[X<:T\<^isub>1].T\<^isub>2" \<rightleftharpoons> "ty.Forall X T\<^isub>2 T\<^isub>1"
- "Lam [x:T].t" \<rightleftharpoons> "trm.Lam x t T"
- "Tabs [X<:T].t" \<rightleftharpoons> "trm.Tabs X t T"
+abbreviation
+ Abs_syn :: "vrs \<Rightarrow> ty \<Rightarrow> trm \<Rightarrow> trm" ("(3\<lambda>_:_./ _)" [0, 0, 10] 10)
+where
+ "\<lambda>x:T. t \<equiv> trm.Abs x t T"
+
+abbreviation
+ TAbs_syn :: "tyvrs \<Rightarrow> ty \<Rightarrow> trm \<Rightarrow> trm" ("(3\<lambda>_<:_./ _)" [0, 0, 10] 10)
+where
+ "\<lambda>X<:T. t \<equiv> trm.TAbs X t T"
text {* Again there are numerous facts that are proved automatically for @{typ "ty"}
and @{typ "trm"}: for example that the set of free variables, i.e.~the @{text "support"},
@@ -64,13 +74,17 @@
and @{typ "trm"}s are equal: *}
lemma alpha_illustration:
- shows "\<forall>[X<:T].(Tvar X) = \<forall>[Y<:T].(Tvar Y)"
- and "Lam [x:T].(Var x) = Lam [y:T].(Var y)"
+ shows "(\<forall>X<:T. Tvar X) = (\<forall>Y<:T. Tvar Y)"
+ and "(\<lambda>x:T. Var x) = (\<lambda>y:T. Var y)"
by (simp_all add: ty.inject trm.inject alpha calc_atm fresh_atm)
section {* SubTyping Contexts *}
-types ty_context = "(tyvrs\<times>ty) list"
+nominal_datatype binding =
+ VarB vrs ty
+ | TVarB tyvrs ty
+
+types env = "binding list"
text {* Typing contexts are represented as lists that ``grow" on the left; we
thereby deviating from the convention in the POPLmark-paper. The lists contain
@@ -79,66 +93,139 @@
text {* In order to state validity-conditions for typing-contexts, the notion of
a @{text "domain"} of a typing-context is handy. *}
+nominal_primrec
+ "tyvrs_of" :: "binding \<Rightarrow> tyvrs set"
+where
+ "tyvrs_of (VarB x y) = {}"
+| "tyvrs_of (TVarB x y) = {x}"
+by auto
+
+nominal_primrec
+ "vrs_of" :: "binding \<Rightarrow> vrs set"
+where
+ "vrs_of (VarB x y) = {x}"
+| "vrs_of (TVarB x y) = {}"
+by auto
+
consts
- "domain" :: "ty_context \<Rightarrow> tyvrs set"
+ "ty_domain" :: "env \<Rightarrow> tyvrs set"
primrec
- "domain [] = {}"
- "domain (X#\<Gamma>) = {fst X}\<union>(domain \<Gamma>)"
+ "ty_domain [] = {}"
+ "ty_domain (X#\<Gamma>) = (tyvrs_of X)\<union>(ty_domain \<Gamma>)"
+
+consts
+ "trm_domain" :: "env \<Rightarrow> vrs set"
+primrec
+ "trm_domain [] = {}"
+ "trm_domain (X#\<Gamma>) = (vrs_of X)\<union>(trm_domain \<Gamma>)"
-lemma domain_eqvt[eqvt]:
+lemma vrs_of_eqvt[eqvt]:
+ fixes pi ::"tyvrs prm"
+ and pi'::"vrs prm"
+ shows "pi \<bullet>(tyvrs_of x) = tyvrs_of (pi\<bullet>x)"
+ and "pi'\<bullet>(tyvrs_of x) = tyvrs_of (pi'\<bullet>x)"
+ and "pi \<bullet>(vrs_of x) = vrs_of (pi\<bullet>x)"
+ and "pi'\<bullet>(vrs_of x) = vrs_of (pi'\<bullet>x)"
+by (nominal_induct x rule: binding.strong_induct) (simp_all add: tyvrs_of.simps eqvts)
+
+lemma domains_eqvt[eqvt]:
fixes pi::"tyvrs prm"
and pi'::"vrs prm"
- shows "pi\<bullet>(domain \<Gamma>) = domain (pi\<bullet>\<Gamma>)"
- and "pi'\<bullet>(domain \<Gamma>) = domain (pi'\<bullet>\<Gamma>)"
- by (induct \<Gamma>) (simp_all add: eqvts)
+ shows "pi \<bullet>(ty_domain \<Gamma>) = ty_domain (pi\<bullet>\<Gamma>)"
+ and "pi'\<bullet>(ty_domain \<Gamma>) = ty_domain (pi'\<bullet>\<Gamma>)"
+ and "pi \<bullet>(trm_domain \<Gamma>) = trm_domain (pi\<bullet>\<Gamma>)"
+ and "pi'\<bullet>(trm_domain \<Gamma>) = trm_domain (pi'\<bullet>\<Gamma>)"
+by (induct \<Gamma>) (simp_all add: eqvts)
+
+lemma finite_vrs:
+ shows "finite (tyvrs_of x)"
+ and "finite (vrs_of x)"
+by (nominal_induct rule:binding.strong_induct, auto)
+
+lemma finite_domains:
+ shows "finite (ty_domain \<Gamma>)"
+ and "finite (trm_domain \<Gamma>)"
+by (induct \<Gamma>, auto simp add: finite_vrs)
+
+lemma ty_domain_supp:
+ shows "(supp (ty_domain \<Gamma>)) = (ty_domain \<Gamma>)"
+ and "(supp (trm_domain \<Gamma>)) = (trm_domain \<Gamma>)"
+by (simp only: at_fin_set_supp at_tyvrs_inst at_vrs_inst finite_domains)+
-lemma finite_domain:
- shows "finite (domain \<Gamma>)"
+lemma ty_domain_inclusion:
+ assumes a: "(TVarB X T)\<in>set \<Gamma>"
+ shows "X\<in>(ty_domain \<Gamma>)"
+using a by (induct \<Gamma>, auto)
+
+lemma ty_binding_existence:
+ assumes "X \<in> (tyvrs_of a)"
+ shows "\<exists>T.(TVarB X T=a)"
+ using assms
+by (nominal_induct a rule: binding.strong_induct, auto)
+
+lemma ty_domain_existence:
+ assumes a: "X\<in>(ty_domain \<Gamma>)"
+ shows "\<exists>T.(TVarB X T)\<in>set \<Gamma>"
+ using a
+ apply (induct \<Gamma>, auto)
+ apply (subgoal_tac "\<exists>T.(TVarB X T=a)")
+ apply (auto)
+ apply (auto simp add: ty_binding_existence)
+done
+
+lemma domains_append:
+ shows "ty_domain (\<Gamma>@\<Delta>) = ((ty_domain \<Gamma>) \<union> (ty_domain \<Delta>))"
+ and "trm_domain (\<Gamma>@\<Delta>) = ((trm_domain \<Gamma>) \<union> (trm_domain \<Delta>))"
by (induct \<Gamma>, auto)
-lemma domain_supp:
- shows "(supp (domain \<Gamma>)) = (domain \<Gamma>)"
- by (simp only: at_fin_set_supp at_tyvrs_inst finite_domain)
-
-lemma domain_inclusion:
- assumes a: "(X,T)\<in>set \<Gamma>"
- shows "X\<in>(domain \<Gamma>)"
- using a by (induct \<Gamma>, auto)
+lemma ty_vrs_prm_simp:
+ fixes pi::"vrs prm"
+ and S::"ty"
+ shows "pi\<bullet>S = S"
+by (induct S rule: ty.induct) (auto simp add: calc_atm)
-lemma domain_existence:
- assumes a: "X\<in>(domain \<Gamma>)"
- shows "\<exists>T.(X,T)\<in>set \<Gamma>"
- using a by (induct \<Gamma>, auto)
+lemma fresh_ty_domain_cons:
+ fixes X::"tyvrs"
+ shows "X\<sharp>(ty_domain (Y#\<Gamma>)) = (X\<sharp>(tyvrs_of Y) \<and> X\<sharp>(ty_domain \<Gamma>))"
+ apply (nominal_induct rule:binding.strong_induct)
+ apply (auto)
+ apply (simp add: fresh_def supp_def eqvts)
+ apply (simp add: fresh_fin_insert [OF pt_tyvrs_inst at_tyvrs_inst fs_tyvrs_inst] finite_domains)
+ apply (simp add: fresh_def supp_def eqvts)
+ apply (simp add: fresh_fin_insert [OF pt_tyvrs_inst at_tyvrs_inst fs_tyvrs_inst] finite_domains)+
+ done
-lemma domain_append:
- shows "domain (\<Gamma>@\<Delta>) = ((domain \<Gamma>) \<union> (domain \<Delta>))"
- by (induct \<Gamma>, auto)
-
-lemma fresh_domain_cons:
- fixes X::"tyvrs"
- shows "X\<sharp>(domain (Y#\<Gamma>)) = (X\<sharp>(fst Y) \<and> X\<sharp>(domain \<Gamma>))"
- by (simp add: fresh_fin_insert pt_tyvrs_inst at_tyvrs_inst fs_tyvrs_inst finite_domain)
+lemma tyvrs_fresh:
+ fixes X::"tyvrs"
+ assumes "X \<sharp> a"
+ shows "X \<sharp> tyvrs_of a"
+ and "X \<sharp> vrs_of a"
+ using assms
+ apply (nominal_induct a rule:binding.strong_induct)
+ apply (auto)
+ apply (fresh_guess)+
+done
lemma fresh_domain:
fixes X::"tyvrs"
assumes a: "X\<sharp>\<Gamma>"
- shows "X\<sharp>(domain \<Gamma>)"
+ shows "X\<sharp>(ty_domain \<Gamma>)"
using a
apply(induct \<Gamma>)
apply(simp add: fresh_set_empty)
-apply(simp only: fresh_domain_cons)
-apply(auto simp add: fresh_prod fresh_list_cons)
+apply(simp only: fresh_ty_domain_cons)
+apply(auto simp add: fresh_prod fresh_list_cons tyvrs_fresh)
done
-text {* Not all lists of type @{typ "ty_context"} are well-formed. One condition
- requires that in @{term "(X,S)#\<Gamma>"} all free variables of @{term "S"} must be
- in the @{term "domain"} of @{term "\<Gamma>"}, that is @{term "S"} must be @{text "closed"}
+text {* Not all lists of type @{typ "env"} are well-formed. One condition
+ requires that in @{term "TVarB X S#\<Gamma>"} all free variables of @{term "S"} must be
+ in the @{term "ty_domain"} of @{term "\<Gamma>"}, that is @{term "S"} must be @{text "closed"}
in @{term "\<Gamma>"}. The set of free variables of @{term "S"} is the
@{text "support"} of @{term "S"}. *}
constdefs
- "closed_in" :: "ty \<Rightarrow> ty_context \<Rightarrow> bool" ("_ closed'_in _" [100,100] 100)
- "S closed_in \<Gamma> \<equiv> (supp S)\<subseteq>(domain \<Gamma>)"
+ "closed_in" :: "ty \<Rightarrow> env \<Rightarrow> bool" ("_ closed'_in _" [100,100] 100)
+ "S closed_in \<Gamma> \<equiv> (supp S)\<subseteq>(ty_domain \<Gamma>)"
lemma closed_in_eqvt[eqvt]:
fixes pi::"tyvrs prm"
@@ -150,80 +237,148 @@
then show "(pi\<bullet>S) closed_in (pi\<bullet>\<Gamma>)" by (simp add: closed_in_def eqvts)
qed
-lemma ty_vrs_prm_simp:
+lemma tyvrs_vrs_prm_simp:
fixes pi::"vrs prm"
- and S::"ty"
- shows "pi\<bullet>S = S"
-by (induct S rule: ty.induct) (auto simp add: calc_atm)
+ shows "tyvrs_of (pi\<bullet>a) = tyvrs_of a"
+ apply (nominal_induct rule:binding.strong_induct)
+ apply (simp_all add: eqvts)
+ apply (simp add: dj_perm_forget[OF dj_tyvrs_vrs])
+ done
-lemma ty_context_vrs_prm_simp:
+lemma ty_vrs_fresh[fresh]:
+ fixes x::"vrs"
+ and T::"ty"
+ shows "x \<sharp> T"
+by (simp add: fresh_def supp_def ty_vrs_prm_simp)
+
+lemma ty_domain_vrs_prm_simp:
fixes pi::"vrs prm"
- and \<Gamma>::"ty_context"
- shows "pi\<bullet>\<Gamma> = \<Gamma>"
-by (induct \<Gamma>)
- (auto simp add: calc_atm ty_vrs_prm_simp)
+ and \<Gamma>::"env"
+ shows "(ty_domain (pi\<bullet>\<Gamma>)) = (ty_domain \<Gamma>)"
+ apply(induct \<Gamma>)
+ apply (simp add: eqvts)
+ apply(simp add: tyvrs_vrs_prm_simp)
+done
lemma closed_in_eqvt'[eqvt]:
fixes pi::"vrs prm"
assumes a: "S closed_in \<Gamma>"
shows "(pi\<bullet>S) closed_in (pi\<bullet>\<Gamma>)"
using a
-by (simp add: ty_vrs_prm_simp ty_context_vrs_prm_simp)
+by (simp add: closed_in_def ty_domain_vrs_prm_simp ty_vrs_prm_simp)
+
+lemma fresh_vrs_of:
+ fixes x::"vrs"
+ shows "x\<sharp>vrs_of b = x\<sharp>b"
+ by (nominal_induct b rule: binding.strong_induct)
+ (simp_all add: fresh_singleton [OF pt_vrs_inst at_vrs_inst] fresh_set_empty ty_vrs_fresh fresh_atm)
+
+lemma fresh_trm_domain:
+ fixes x::"vrs"
+ shows "x\<sharp> trm_domain \<Gamma> = x\<sharp>\<Gamma>"
+ by (induct \<Gamma>)
+ (simp_all add: fresh_set_empty fresh_list_cons
+ fresh_fin_union [OF pt_vrs_inst at_vrs_inst fs_vrs_inst]
+ finite_domains finite_vrs fresh_vrs_of fresh_list_nil)
+
+lemma closed_in_fresh: "(X::tyvrs) \<sharp> ty_domain \<Gamma> \<Longrightarrow> T closed_in \<Gamma> \<Longrightarrow> X \<sharp> T"
+ by (auto simp add: closed_in_def fresh_def ty_domain_supp)
text {* Now validity of a context is a straightforward inductive definition. *}
-inductive
- valid_rel :: "ty_context \<Rightarrow> bool" ("\<turnstile> _ ok" [100] 100)
+inductive
+ valid_rel :: "env \<Rightarrow> bool" ("\<turnstile> _ ok" [100] 100)
where
- valid_nil[simp]: "\<turnstile> [] ok"
-| valid_cons[simp]: "\<lbrakk>\<turnstile> \<Gamma> ok; X\<sharp>(domain \<Gamma>); T closed_in \<Gamma>\<rbrakk> \<Longrightarrow> \<turnstile> ((X,T)#\<Gamma>) ok"
+ valid_nil[simp]: "\<turnstile> [] ok"
+| valid_consT[simp]: "\<lbrakk>\<turnstile> \<Gamma> ok; X\<sharp>(ty_domain \<Gamma>); T closed_in \<Gamma>\<rbrakk> \<Longrightarrow> \<turnstile> (TVarB X T#\<Gamma>) ok"
+| valid_cons [simp]: "\<lbrakk>\<turnstile> \<Gamma> ok; x\<sharp>(trm_domain \<Gamma>); T closed_in \<Gamma>\<rbrakk> \<Longrightarrow> \<turnstile> (VarB x T#\<Gamma>) ok"
equivariance valid_rel
-lemma validE:
- assumes a: "\<turnstile> ((X,T)#\<Gamma>) ok"
- shows "\<turnstile> \<Gamma> ok \<and> X\<sharp>(domain \<Gamma>) \<and> T closed_in \<Gamma>"
-using a by (cases, auto)
+declare binding.inject [simp add]
+declare trm.inject [simp add]
+
+inductive_cases validE[elim]: "\<turnstile> (TVarB X T#\<Gamma>) ok" "\<turnstile> (VarB x T#\<Gamma>) ok" "\<turnstile> (b#\<Gamma>) ok"
+
+declare binding.inject [simp del]
+declare trm.inject [simp del]
lemma validE_append:
assumes a: "\<turnstile> (\<Delta>@\<Gamma>) ok"
shows "\<turnstile> \<Gamma> ok"
- using a by (induct \<Delta>, auto dest: validE)
+ using a
+proof (induct \<Delta>)
+ case (Cons a \<Gamma>')
+ then show ?case
+ by (nominal_induct a rule:binding.strong_induct)
+ (auto elim: validE)
+qed (auto)
lemma replace_type:
- assumes a: "\<turnstile> (\<Delta>@(X,T)#\<Gamma>) ok"
+ assumes a: "\<turnstile> (\<Delta>@(TVarB X T)#\<Gamma>) ok"
and b: "S closed_in \<Gamma>"
- shows "\<turnstile> (\<Delta>@(X,S)#\<Gamma>) ok"
+ shows "\<turnstile> (\<Delta>@(TVarB X S)#\<Gamma>) ok"
using a b
-apply(induct \<Delta>)
-apply(auto dest!: validE intro!: valid_cons simp add: domain_append closed_in_def)
-done
+proof(induct \<Delta>)
+ case Nil
+ then show ?case by (auto elim: validE intro: valid_cons simp add: domains_append closed_in_def)
+next
+ case (Cons a \<Gamma>')
+ then show ?case
+ by (nominal_induct a rule:binding.strong_induct)
+ (auto elim: validE intro!: valid_cons simp add: domains_append closed_in_def)
+qed
text {* Well-formed contexts have a unique type-binding for a type-variable. *}
lemma uniqueness_of_ctxt:
- fixes \<Gamma>::"ty_context"
+ fixes \<Gamma>::"env"
assumes a: "\<turnstile> \<Gamma> ok"
- and b: "(X,T)\<in>set \<Gamma>"
- and c: "(X,S)\<in>set \<Gamma>"
+ and b: "(TVarB X T)\<in>set \<Gamma>"
+ and c: "(TVarB X S)\<in>set \<Gamma>"
shows "T=S"
using a b c
proof (induct)
- case valid_nil thus "T=S" by simp
-next
- case valid_cons
+ case (valid_consT \<Gamma> X' T')
moreover
- { fix \<Gamma>::"ty_context"
- assume a: "X\<sharp>(domain \<Gamma>)"
- have "\<not>(\<exists>T.(X,T)\<in>(set \<Gamma>))" using a
- proof (induct \<Gamma>)
- case (Cons Y \<Gamma>)
- thus "\<not> (\<exists>T.(X,T)\<in>set(Y#\<Gamma>))"
- by (simp only: fresh_domain_cons, auto simp add: fresh_atm)
+ { fix \<Gamma>'::"env"
+ assume a: "X'\<sharp>(ty_domain \<Gamma>')"
+ have "\<not>(\<exists>T.(TVarB X' T)\<in>(set \<Gamma>'))" using a
+ proof (induct \<Gamma>')
+ case (Cons Y \<Gamma>')
+ thus "\<not> (\<exists>T.(TVarB X' T)\<in>set(Y#\<Gamma>'))"
+ by (simp add: fresh_ty_domain_cons
+ fresh_fin_union[OF pt_tyvrs_inst at_tyvrs_inst fs_tyvrs_inst]
+ finite_vrs finite_domains,
+ auto simp add: fresh_atm fresh_singleton [OF pt_tyvrs_inst at_tyvrs_inst])
qed (simp)
}
- ultimately show "T=S" by auto
-qed
+ ultimately show "T=S" by (auto simp add: binding.inject)
+qed (auto)
+
+lemma uniqueness_of_ctxt':
+ fixes \<Gamma>::"env"
+ assumes a: "\<turnstile> \<Gamma> ok"
+ and b: "(VarB x T)\<in>set \<Gamma>"
+ and c: "(VarB x S)\<in>set \<Gamma>"
+ shows "T=S"
+using a b c
+proof (induct)
+ case (valid_cons \<Gamma> x' T')
+ moreover
+ { fix \<Gamma>'::"env"
+ assume a: "x'\<sharp>(trm_domain \<Gamma>')"
+ have "\<not>(\<exists>T.(VarB x' T)\<in>(set \<Gamma>'))" using a
+ proof (induct \<Gamma>')
+ case (Cons y \<Gamma>')
+ thus "\<not> (\<exists>T.(VarB x' T)\<in>set(y#\<Gamma>'))"
+ by (simp add: fresh_fin_union[OF pt_vrs_inst at_vrs_inst fs_vrs_inst]
+ finite_vrs finite_domains,
+ auto simp add: fresh_atm fresh_singleton [OF pt_vrs_inst at_vrs_inst])
+ qed (simp)
+ }
+ ultimately show "T=S" by (auto simp add: binding.inject)
+qed (auto)
section {* Size and Capture-Avoiding Substitution for Types *}
@@ -233,7 +388,7 @@
"size_ty (Tvar X) = 1"
| "size_ty (Top) = 1"
| "size_ty (T1 \<rightarrow> T2) = (size_ty T1) + (size_ty T2) + 1"
-| "X\<sharp>T1 \<Longrightarrow> size_ty (\<forall>[X<:T1].T2) = (size_ty T1) + (size_ty T2) + 1"
+| "X \<sharp> T1 \<Longrightarrow> size_ty (\<forall>X<:T1. T2) = (size_ty T1) + (size_ty T2) + 1"
apply (finite_guess)+
apply (rule TrueI)+
apply (simp add: fresh_nat)
@@ -241,24 +396,195 @@
done
nominal_primrec
- subst_ty :: "ty \<Rightarrow> tyvrs \<Rightarrow> ty \<Rightarrow> ty" ("_[_:=_]\<^isub>t\<^isub>y" [100,100,100] 100)
+ subst_ty :: "ty \<Rightarrow> tyvrs \<Rightarrow> ty \<Rightarrow> ty" ("_[_ \<mapsto> _]\<^sub>\<tau>" [300, 0, 0] 300)
where
- "(Tvar X)[Y:=T]\<^isub>t\<^isub>y= (if X=Y then T else (Tvar X))"
-| "(Top)[Y:=T]\<^isub>t\<^isub>y = Top"
-| "(T\<^isub>1 \<rightarrow> T\<^isub>2)[Y:=T]\<^isub>t\<^isub>y = (T\<^isub>1[Y:=T]\<^isub>t\<^isub>y) \<rightarrow> (T\<^isub>2[Y:=T]\<^isub>t\<^isub>y)"
-| "\<lbrakk>X\<sharp>(Y,T); X\<sharp>T\<^isub>1\<rbrakk> \<Longrightarrow> (\<forall>[X<:T\<^isub>1].T\<^isub>2)[Y:=T]\<^isub>t\<^isub>y = (\<forall>[X<:(T\<^isub>1[Y:=T]\<^isub>t\<^isub>y)].(T\<^isub>2[Y:=T]\<^isub>t\<^isub>y))"
+ "(Tvar X)[Y \<mapsto> T]\<^sub>\<tau> = (if X=Y then T else Tvar X)"
+| "(Top)[Y \<mapsto> T]\<^sub>\<tau> = Top"
+| "(T\<^isub>1 \<rightarrow> T\<^isub>2)[Y \<mapsto> T]\<^sub>\<tau> = T\<^isub>1[Y \<mapsto> T]\<^sub>\<tau> \<rightarrow> T\<^isub>2[Y \<mapsto> T]\<^sub>\<tau>"
+| "\<lbrakk>X\<sharp>(Y,T); X\<sharp>T\<^isub>1\<rbrakk> \<Longrightarrow> (\<forall>X<:T\<^isub>1. T\<^isub>2)[Y \<mapsto> T]\<^sub>\<tau> = (\<forall>X<:T\<^isub>1[Y \<mapsto> T]\<^sub>\<tau>. T\<^isub>2[Y \<mapsto> T]\<^sub>\<tau>)"
apply (finite_guess)+
apply (rule TrueI)+
apply (simp add: abs_fresh)
apply (fresh_guess)+
done
+lemma subst_eqvt[eqvt]:
+ fixes pi::"tyvrs prm"
+ and T::"ty"
+ shows "pi\<bullet>(T[X \<mapsto> T']\<^sub>\<tau>) = (pi\<bullet>T)[(pi\<bullet>X) \<mapsto> (pi\<bullet>T')]\<^sub>\<tau>"
+ by (nominal_induct T avoiding: X T' rule: ty.strong_induct)
+ (perm_simp add: fresh_bij)+
+
+lemma subst_eqvt'[eqvt]:
+ fixes pi::"vrs prm"
+ and T::"ty"
+ shows "pi\<bullet>(T[X \<mapsto> T']\<^sub>\<tau>) = (pi\<bullet>T)[(pi\<bullet>X) \<mapsto> (pi\<bullet>T')]\<^sub>\<tau>"
+ by (nominal_induct T avoiding: X T' rule: ty.strong_induct)
+ (perm_simp add: fresh_left)+
+
+lemma type_subst_fresh[fresh]:
+ fixes X::"tyvrs"
+ assumes "X \<sharp> T" and "X \<sharp> P"
+ shows "X \<sharp> T[Y \<mapsto> P]\<^sub>\<tau>"
+using assms
+by (nominal_induct T avoiding: X Y P rule:ty.strong_induct)
+ (auto simp add: abs_fresh)
+
+lemma fresh_type_subst_fresh[fresh]:
+ assumes "X\<sharp>T'"
+ shows "X\<sharp>T[X \<mapsto> T']\<^sub>\<tau>"
+using assms
+by (nominal_induct T avoiding: X T' rule: ty.strong_induct)
+ (auto simp add: fresh_atm abs_fresh fresh_nat)
+
+lemma type_subst_identity: "X \<sharp> T \<Longrightarrow> T[X \<mapsto> U]\<^sub>\<tau> = T"
+ by (nominal_induct T avoiding: X U rule: ty.strong_induct)
+ (simp_all add: fresh_atm abs_fresh)
+
+lemma type_substitution_lemma:
+ "X \<noteq> Y \<Longrightarrow> X \<sharp> L \<Longrightarrow> M[X \<mapsto> N]\<^sub>\<tau>[Y \<mapsto> L]\<^sub>\<tau> = M[Y \<mapsto> L]\<^sub>\<tau>[X \<mapsto> N[Y \<mapsto> L]\<^sub>\<tau>]\<^sub>\<tau>"
+ by (nominal_induct M avoiding: X Y N L rule: ty.strong_induct)
+ (auto simp add: type_subst_fresh type_subst_identity)
+
+lemma type_subst_rename:
+ "Y \<sharp> T \<Longrightarrow> ([(Y, X)] \<bullet> T)[Y \<mapsto> U]\<^sub>\<tau> = T[X \<mapsto> U]\<^sub>\<tau>"
+ by (nominal_induct T avoiding: X Y U rule: ty.strong_induct)
+ (simp_all add: fresh_atm calc_atm abs_fresh fresh_aux)
+
+nominal_primrec
+ subst_tyb :: "binding \<Rightarrow> tyvrs \<Rightarrow> ty \<Rightarrow> binding" ("_[_ \<mapsto> _]\<^sub>b" [100,100,100] 100)
+where
+ "(TVarB X U)[Y \<mapsto> T]\<^sub>b = TVarB X (U[Y \<mapsto> T]\<^sub>\<tau>)"
+| "(VarB X U)[Y \<mapsto> T]\<^sub>b = VarB X (U[Y \<mapsto> T]\<^sub>\<tau>)"
+by auto
+
+lemma binding_subst_fresh[fresh]:
+ fixes X::"tyvrs"
+ assumes "X \<sharp> a"
+ and "X \<sharp> P"
+ shows "X \<sharp> a[Y \<mapsto> P]\<^sub>b"
+using assms
+by (nominal_induct a rule:binding.strong_induct)
+ (auto simp add: freshs)
+
+lemma binding_subst_identity: "X \<sharp> B \<Longrightarrow> B[X \<mapsto> U]\<^sub>b = B"
+ by (induct B rule: binding.induct)
+ (simp_all add: fresh_atm type_subst_identity)
+
consts
- subst_tyc :: "ty_context \<Rightarrow> tyvrs \<Rightarrow> ty \<Rightarrow> ty_context" ("_[_:=_]\<^isub>t\<^isub>y\<^isub>c" [100,100,100] 100)
+ subst_tyc :: "env \<Rightarrow> tyvrs \<Rightarrow> ty \<Rightarrow> env" ("_[_ \<mapsto> _]\<^sub>e" [100,100,100] 100)
+
primrec
-"([])[Y:=T]\<^isub>t\<^isub>y\<^isub>c= []"
-"(XT#\<Gamma>)[Y:=T]\<^isub>t\<^isub>y\<^isub>c = (fst XT,(snd XT)[Y:=T]\<^isub>t\<^isub>y)#(\<Gamma>[Y:=T]\<^isub>t\<^isub>y\<^isub>c)"
-
+"([])[Y \<mapsto> T]\<^sub>e= []"
+"(B#\<Gamma>)[Y \<mapsto> T]\<^sub>e = (B[Y \<mapsto> T]\<^sub>b)#(\<Gamma>[Y \<mapsto> T]\<^sub>e)"
+
+lemma ctxt_subst_fresh'[fresh]:
+ fixes X::"tyvrs"
+ assumes "X \<sharp> \<Gamma>"
+ and "X \<sharp> P"
+ shows "X \<sharp> \<Gamma>[Y \<mapsto> P]\<^sub>e"
+using assms
+by (induct \<Gamma>)
+ (auto simp add: fresh_list_cons freshs)
+
+lemma ctxt_subst_mem_TVarB: "TVarB X T \<in> set \<Gamma> \<Longrightarrow> TVarB X (T[Y \<mapsto> U]\<^sub>\<tau>) \<in> set (\<Gamma>[Y \<mapsto> U]\<^sub>e)"
+ by (induct \<Gamma>) auto
+
+lemma ctxt_subst_mem_VarB: "VarB x T \<in> set \<Gamma> \<Longrightarrow> VarB x (T[Y \<mapsto> U]\<^sub>\<tau>) \<in> set (\<Gamma>[Y \<mapsto> U]\<^sub>e)"
+ by (induct \<Gamma>) auto
+
+lemma ctxt_subst_identity: "X \<sharp> \<Gamma> \<Longrightarrow> \<Gamma>[X \<mapsto> U]\<^sub>e = \<Gamma>"
+ by (induct \<Gamma>) (simp_all add: fresh_list_cons binding_subst_identity)
+
+lemma ctxt_subst_append: "(\<Delta> @ \<Gamma>)[X \<mapsto> T]\<^sub>e = \<Delta>[X \<mapsto> T]\<^sub>e @ \<Gamma>[X \<mapsto> T]\<^sub>e"
+ by (induct \<Delta>) simp_all
+
+nominal_primrec
+ subst_trm :: "trm \<Rightarrow> vrs \<Rightarrow> trm \<Rightarrow> trm" ("_[_ \<mapsto> _]" [300, 0, 0] 300)
+where
+ "(Var x)[y \<mapsto> t'] = (if x=y then t' else (Var x))"
+| "(t1 \<cdot> t2)[y \<mapsto> t'] = t1[y \<mapsto> t'] \<cdot> t2[y \<mapsto> t']"
+| "(t \<cdot>\<^sub>\<tau> T)[y \<mapsto> t'] = t[y \<mapsto> t'] \<cdot>\<^sub>\<tau> T"
+| "X\<sharp>(T,t') \<Longrightarrow> (\<lambda>X<:T. t)[y \<mapsto> t'] = (\<lambda>X<:T. t[y \<mapsto> t'])"
+| "x\<sharp>(y,t') \<Longrightarrow> (\<lambda>x:T. t)[y \<mapsto> t'] = (\<lambda>x:T. t[y \<mapsto> t'])"
+apply(finite_guess)+
+apply(rule TrueI)+
+apply(simp add: abs_fresh)+
+apply(fresh_guess add: ty_vrs_fresh abs_fresh)+
+done
+
+lemma subst_trm_fresh_tyvar:
+ "(X::tyvrs) \<sharp> t \<Longrightarrow> X \<sharp> u \<Longrightarrow> X \<sharp> t[x \<mapsto> u]"
+ by (nominal_induct t avoiding: x u rule: trm.strong_induct)
+ (auto simp add: trm.fresh abs_fresh)
+
+lemma subst_trm_fresh_var: "x \<sharp> u \<Longrightarrow> x \<sharp> t[x \<mapsto> u]"
+ by (nominal_induct t avoiding: x u rule: trm.strong_induct)
+ (simp_all add: abs_fresh fresh_atm ty_vrs_fresh)
+
+lemma subst_trm_eqvt[eqvt]:
+ fixes pi::"tyvrs prm"
+ and t::"trm"
+ shows "pi\<bullet>(t[x \<mapsto> u]) = (pi\<bullet>t)[(pi\<bullet>x) \<mapsto> (pi\<bullet>u)]"
+ by (nominal_induct t avoiding: x u rule: trm.strong_induct)
+ (perm_simp add: fresh_left)+
+
+lemma subst_trm_eqvt'[eqvt]:
+ fixes pi::"vrs prm"
+ and t::"trm"
+ shows "pi\<bullet>(t[x \<mapsto> u]) = (pi\<bullet>t)[(pi\<bullet>x) \<mapsto> (pi\<bullet>u)]"
+ by (nominal_induct t avoiding: x u rule: trm.strong_induct)
+ (perm_simp add: fresh_left)+
+
+lemma subst_trm_rename:
+ "y \<sharp> t \<Longrightarrow> ([(y, x)] \<bullet> t)[y \<mapsto> u] = t[x \<mapsto> u]"
+ by (nominal_induct t avoiding: x y u rule: trm.strong_induct)
+ (simp_all add: fresh_atm calc_atm abs_fresh fresh_aux ty_vrs_fresh perm_fresh_fresh)
+
+nominal_primrec (freshness_context: "T2::ty")
+ subst_trm_ty :: "trm \<Rightarrow> tyvrs \<Rightarrow> ty \<Rightarrow> trm" ("_[_ \<mapsto>\<^sub>\<tau> _]" [300, 0, 0] 300)
+where
+ "(Var x)[Y \<mapsto>\<^sub>\<tau> T2] = Var x"
+| "(t1 \<cdot> t2)[Y \<mapsto>\<^sub>\<tau> T2] = t1[Y \<mapsto>\<^sub>\<tau> T2] \<cdot> t2[Y \<mapsto>\<^sub>\<tau> T2]"
+| "(t1 \<cdot>\<^sub>\<tau> T)[Y \<mapsto>\<^sub>\<tau> T2] = t1[Y \<mapsto>\<^sub>\<tau> T2] \<cdot>\<^sub>\<tau> T[Y \<mapsto> T2]\<^sub>\<tau>"
+| "X\<sharp>(Y,T,T2) \<Longrightarrow> (\<lambda>X<:T. t)[Y \<mapsto>\<^sub>\<tau> T2] = (\<lambda>X<:T[Y \<mapsto> T2]\<^sub>\<tau>. t[Y \<mapsto>\<^sub>\<tau> T2])"
+| "(\<lambda>x:T. t)[Y \<mapsto>\<^sub>\<tau> T2] = (\<lambda>x:T[Y \<mapsto> T2]\<^sub>\<tau>. t[Y \<mapsto>\<^sub>\<tau> T2])"
+apply(finite_guess)+
+apply(rule TrueI)+
+apply(simp add: abs_fresh ty_vrs_fresh)+
+apply(simp add: type_subst_fresh)
+apply(fresh_guess add: ty_vrs_fresh abs_fresh)+
+done
+
+lemma subst_trm_ty_fresh:
+ "(X::tyvrs) \<sharp> t \<Longrightarrow> X \<sharp> T \<Longrightarrow> X \<sharp> t[Y \<mapsto>\<^sub>\<tau> T]"
+ by (nominal_induct t avoiding: Y T rule: trm.strong_induct)
+ (auto simp add: abs_fresh type_subst_fresh)
+
+lemma subst_trm_ty_fresh':
+ "X \<sharp> T \<Longrightarrow> X \<sharp> t[X \<mapsto>\<^sub>\<tau> T]"
+ by (nominal_induct t avoiding: X T rule: trm.strong_induct)
+ (simp_all add: abs_fresh fresh_type_subst_fresh fresh_atm)
+
+lemma subst_trm_ty_eqvt[eqvt]:
+ fixes pi::"tyvrs prm"
+ and t::"trm"
+ shows "pi\<bullet>(t[X \<mapsto>\<^sub>\<tau> T]) = (pi\<bullet>t)[(pi\<bullet>X) \<mapsto>\<^sub>\<tau> (pi\<bullet>T)]"
+ by (nominal_induct t avoiding: X T rule: trm.strong_induct)
+ (perm_simp add: fresh_bij subst_eqvt)+
+
+lemma subst_trm_ty_eqvt'[eqvt]:
+ fixes pi::"vrs prm"
+ and t::"trm"
+ shows "pi\<bullet>(t[X \<mapsto>\<^sub>\<tau> T]) = (pi\<bullet>t)[(pi\<bullet>X) \<mapsto>\<^sub>\<tau> (pi\<bullet>T)]"
+ by (nominal_induct t avoiding: X T rule: trm.strong_induct)
+ (perm_simp add: fresh_left subst_eqvt')+
+
+lemma subst_trm_ty_rename:
+ "Y \<sharp> t \<Longrightarrow> ([(Y, X)] \<bullet> t)[Y \<mapsto>\<^sub>\<tau> U] = t[X \<mapsto>\<^sub>\<tau> U]"
+ by (nominal_induct t avoiding: X Y U rule: trm.strong_induct)
+ (simp_all add: fresh_atm calc_atm abs_fresh fresh_aux type_subst_rename)
+
section {* Subtyping-Relation *}
text {* The definition for the subtyping-relation follows quite closely what is written
@@ -269,13 +595,13 @@
$\alpha$-equivalence classes.) *}
inductive
- subtype_of :: "ty_context \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("_\<turnstile>_<:_" [100,100,100] 100)
+ subtype_of :: "env \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("_\<turnstile>_<:_" [100,100,100] 100)
where
- S_Top[intro]: "\<lbrakk>\<turnstile> \<Gamma> ok; S closed_in \<Gamma>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> S <: Top"
-| S_Var[intro]: "\<lbrakk>(X,S) \<in> set \<Gamma>; \<Gamma> \<turnstile> S <: T\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> (Tvar X) <: T"
-| S_Refl[intro]: "\<lbrakk>\<turnstile> \<Gamma> ok; X \<in> domain \<Gamma>\<rbrakk>\<Longrightarrow> \<Gamma> \<turnstile> Tvar X <: Tvar X"
-| S_Arrow[intro]: "\<lbrakk>\<Gamma> \<turnstile> T\<^isub>1 <: S\<^isub>1; \<Gamma> \<turnstile> S\<^isub>2 <: T\<^isub>2\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> (S\<^isub>1 \<rightarrow> S\<^isub>2) <: (T\<^isub>1 \<rightarrow> T\<^isub>2)"
-| S_Forall[intro]: "\<lbrakk>\<Gamma> \<turnstile> T\<^isub>1 <: S\<^isub>1; X\<sharp>\<Gamma>; ((X,T\<^isub>1)#\<Gamma>) \<turnstile> S\<^isub>2 <: T\<^isub>2\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> \<forall>[X<:S\<^isub>1].S\<^isub>2 <: \<forall>[X<:T\<^isub>1].T\<^isub>2"
+ SA_Top[intro]: "\<lbrakk>\<turnstile> \<Gamma> ok; S closed_in \<Gamma>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> S <: Top"
+| SA_refl_TVar[intro]: "\<lbrakk>\<turnstile> \<Gamma> ok; X \<in> ty_domain \<Gamma>\<rbrakk>\<Longrightarrow> \<Gamma> \<turnstile> Tvar X <: Tvar X"
+| SA_trans_TVar[intro]: "\<lbrakk>(TVarB X S) \<in> set \<Gamma>; \<Gamma> \<turnstile> S <: T\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> (Tvar X) <: T"
+| SA_arrow[intro]: "\<lbrakk>\<Gamma> \<turnstile> T\<^isub>1 <: S\<^isub>1; \<Gamma> \<turnstile> S\<^isub>2 <: T\<^isub>2\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> (S\<^isub>1 \<rightarrow> S\<^isub>2) <: (T\<^isub>1 \<rightarrow> T\<^isub>2)"
+| SA_all[intro]: "\<lbrakk>\<Gamma> \<turnstile> T\<^isub>1 <: S\<^isub>1; ((TVarB X T\<^isub>1)#\<Gamma>) \<turnstile> S\<^isub>2 <: T\<^isub>2\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> (\<forall>X<:S\<^isub>1. S\<^isub>2) <: (\<forall>X<:T\<^isub>1. T\<^isub>2)"
lemma subtype_implies_ok:
fixes X::"tyvrs"
@@ -288,15 +614,15 @@
shows "S closed_in \<Gamma> \<and> T closed_in \<Gamma>"
using a
proof (induct)
- case (S_Top \<Gamma> S)
+ case (SA_Top \<Gamma> S)
have "Top closed_in \<Gamma>" by (simp add: closed_in_def ty.supp)
moreover
have "S closed_in \<Gamma>" by fact
ultimately show "S closed_in \<Gamma> \<and> Top closed_in \<Gamma>" by simp
next
- case (S_Var X S \<Gamma> T)
- have "(X,S)\<in>set \<Gamma>" by fact
- hence "X \<in> domain \<Gamma>" by (rule domain_inclusion)
+ case (SA_trans_TVar X S \<Gamma> T)
+ have "(TVarB X S)\<in>set \<Gamma>" by fact
+ hence "X \<in> ty_domain \<Gamma>" by (rule ty_domain_inclusion)
hence "(Tvar X) closed_in \<Gamma>" by (simp add: closed_in_def ty.supp supp_atm)
moreover
have "S closed_in \<Gamma> \<and> T closed_in \<Gamma>" by fact
@@ -311,20 +637,33 @@
shows "X\<sharp>S \<and> X\<sharp>T"
proof -
from a1 have "\<turnstile> \<Gamma> ok" by (rule subtype_implies_ok)
- with a2 have "X\<sharp>domain(\<Gamma>)" by (simp add: fresh_domain)
+ with a2 have "X\<sharp>ty_domain(\<Gamma>)" by (simp add: fresh_domain)
moreover
from a1 have "S closed_in \<Gamma> \<and> T closed_in \<Gamma>" by (rule subtype_implies_closed)
- hence "supp S \<subseteq> ((supp (domain \<Gamma>))::tyvrs set)"
- and "supp T \<subseteq> ((supp (domain \<Gamma>))::tyvrs set)" by (simp_all add: domain_supp closed_in_def)
+ hence "supp S \<subseteq> ((supp (ty_domain \<Gamma>))::tyvrs set)"
+ and "supp T \<subseteq> ((supp (ty_domain \<Gamma>))::tyvrs set)" by (simp_all add: ty_domain_supp closed_in_def)
ultimately show "X\<sharp>S \<and> X\<sharp>T" by (force simp add: supp_prod fresh_def)
qed
+lemma valid_ty_domain_fresh:
+ fixes X::"tyvrs"
+ assumes valid: "\<turnstile> \<Gamma> ok"
+ shows "X\<sharp>(ty_domain \<Gamma>) = X\<sharp>\<Gamma>"
+ using valid
+ apply induct
+ apply (simp add: fresh_list_nil fresh_set_empty)
+ apply (simp_all add: binding.fresh fresh_list_cons
+ fresh_fin_insert [OF pt_tyvrs_inst at_tyvrs_inst fs_tyvrs_inst] finite_domains fresh_atm)
+ apply (auto simp add: closed_in_fresh)
+ done
+
equivariance subtype_of
-nominal_inductive subtype_of
- by (simp_all add: abs_fresh subtype_implies_fresh)
-
-thm subtype_of.strong_induct
+nominal_inductive subtype_of
+ apply (simp_all add: abs_fresh)
+ apply (fastsimp simp add: valid_ty_domain_fresh dest: subtype_implies_ok)
+ apply (force simp add: closed_in_fresh dest: subtype_implies_closed subtype_implies_ok)+
+ done
section {* Reflexivity of Subtyping *}
@@ -338,17 +677,17 @@
have ih_T\<^isub>1: "\<And>\<Gamma>. \<lbrakk>\<turnstile> \<Gamma> ok; T\<^isub>1 closed_in \<Gamma>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> T\<^isub>1 <: T\<^isub>1" by fact
have ih_T\<^isub>2: "\<And>\<Gamma>. \<lbrakk>\<turnstile> \<Gamma> ok; T\<^isub>2 closed_in \<Gamma>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> T\<^isub>2 <: T\<^isub>2" by fact
have fresh_cond: "X\<sharp>\<Gamma>" by fact
- hence fresh_domain: "X\<sharp>(domain \<Gamma>)" by (simp add: fresh_domain)
- have "(\<forall>[X<:T\<^isub>2].T\<^isub>1) closed_in \<Gamma>" by fact
- hence closed\<^isub>T\<^isub>2: "T\<^isub>2 closed_in \<Gamma>" and closed\<^isub>T\<^isub>1: "T\<^isub>1 closed_in ((X,T\<^isub>2)#\<Gamma>)"
+ hence fresh_ty_domain: "X\<sharp>(ty_domain \<Gamma>)" by (simp add: fresh_domain)
+ have "(\<forall>X<:T\<^isub>2. T\<^isub>1) closed_in \<Gamma>" by fact
+ hence closed\<^isub>T\<^isub>2: "T\<^isub>2 closed_in \<Gamma>" and closed\<^isub>T\<^isub>1: "T\<^isub>1 closed_in ((TVarB X T\<^isub>2)#\<Gamma>)"
by (auto simp add: closed_in_def ty.supp abs_supp)
have ok: "\<turnstile> \<Gamma> ok" by fact
- hence ok': "\<turnstile> ((X,T\<^isub>2)#\<Gamma>) ok" using closed\<^isub>T\<^isub>2 fresh_domain by simp
+ hence ok': "\<turnstile> ((TVarB X T\<^isub>2)#\<Gamma>) ok" using closed\<^isub>T\<^isub>2 fresh_ty_domain by simp
have "\<Gamma> \<turnstile> T\<^isub>2 <: T\<^isub>2" using ih_T\<^isub>2 closed\<^isub>T\<^isub>2 ok by simp
moreover
- have "((X,T\<^isub>2)#\<Gamma>) \<turnstile> T\<^isub>1 <: T\<^isub>1" using ih_T\<^isub>1 closed\<^isub>T\<^isub>1 ok' by simp
- ultimately show "\<Gamma> \<turnstile> \<forall>[X<:T\<^isub>2].T\<^isub>1 <: \<forall>[X<:T\<^isub>2].T\<^isub>1" using fresh_cond
- by (simp add: subtype_of.S_Forall)
+ have "((TVarB X T\<^isub>2)#\<Gamma>) \<turnstile> T\<^isub>1 <: T\<^isub>1" using ih_T\<^isub>1 closed\<^isub>T\<^isub>1 ok' by simp
+ ultimately show "\<Gamma> \<turnstile> (\<forall>X<:T\<^isub>2. T\<^isub>1) <: (\<forall>X<:T\<^isub>2. T\<^isub>1)" using fresh_cond
+ by (simp add: subtype_of.SA_all)
qed (auto simp add: closed_in_def ty.supp supp_atm)
lemma subtype_reflexivity_semiautomated:
@@ -361,11 +700,10 @@
--{* Too bad that this instantiation cannot be found automatically by
\isakeyword{auto}; \isakeyword{blast} would find it if we had not used
an explicit definition for @{text "closed_in_def"}. *}
-apply(drule_tac x="(tyvrs, ty2)#\<Gamma>" in meta_spec)
+apply(drule_tac x="(TVarB tyvrs ty2)#\<Gamma>" in meta_spec)
apply(force dest: fresh_domain simp add: closed_in_def)
done
-
section {* Weakening *}
text {* In order to prove weakening we introduce the notion of a type-context extending
@@ -373,16 +711,16 @@
smoother than if we had strictly adhered to the version in the POPLmark-paper. *}
constdefs
- extends :: "ty_context \<Rightarrow> ty_context \<Rightarrow> bool" ("_ extends _" [100,100] 100)
- "\<Delta> extends \<Gamma> \<equiv> \<forall>X Q. (X,Q)\<in>set \<Gamma> \<longrightarrow> (X,Q)\<in>set \<Delta>"
+ extends :: "env \<Rightarrow> env \<Rightarrow> bool" ("_ extends _" [100,100] 100)
+ "\<Delta> extends \<Gamma> \<equiv> \<forall>X Q. (TVarB X Q)\<in>set \<Gamma> \<longrightarrow> (TVarB X Q)\<in>set \<Delta>"
-lemma extends_domain:
+lemma extends_ty_domain:
assumes a: "\<Delta> extends \<Gamma>"
- shows "domain \<Gamma> \<subseteq> domain \<Delta>"
+ shows "ty_domain \<Gamma> \<subseteq> ty_domain \<Delta>"
using a
apply (auto simp add: extends_def)
- apply (drule domain_existence)
- apply (force simp add: domain_inclusion)
+ apply (drule ty_domain_existence)
+ apply (force simp add: ty_domain_inclusion)
done
lemma extends_closed:
@@ -390,12 +728,12 @@
and a2: "\<Delta> extends \<Gamma>"
shows "T closed_in \<Delta>"
using a1 a2
- by (auto dest: extends_domain simp add: closed_in_def)
+ by (auto dest: extends_ty_domain simp add: closed_in_def)
lemma extends_memb:
assumes a: "\<Delta> extends \<Gamma>"
- and b: "(X,T) \<in> set \<Gamma>"
- shows "(X,T) \<in> set \<Delta>"
+ and b: "(TVarB X T) \<in> set \<Gamma>"
+ shows "(TVarB X T) \<in> set \<Delta>"
using a b by (simp add: extends_def)
lemma weakening:
@@ -405,7 +743,7 @@
shows "\<Delta> \<turnstile> S <: T"
using a b c
proof (nominal_induct \<Gamma> S T avoiding: \<Delta> rule: subtype_of.strong_induct)
- case (S_Top \<Gamma> S)
+ case (SA_Top \<Gamma> S)
have lh_drv_prem: "S closed_in \<Gamma>" by fact
have "\<turnstile> \<Delta> ok" by fact
moreover
@@ -413,43 +751,43 @@
hence "S closed_in \<Delta>" using lh_drv_prem by (simp only: extends_closed)
ultimately show "\<Delta> \<turnstile> S <: Top" by force
next
- case (S_Var X S \<Gamma> T)
- have lh_drv_prem: "(X,S) \<in> set \<Gamma>" by fact
+ case (SA_trans_TVar X S \<Gamma> T)
+ have lh_drv_prem: "(TVarB X S) \<in> set \<Gamma>" by fact
have ih: "\<And>\<Delta>. \<turnstile> \<Delta> ok \<Longrightarrow> \<Delta> extends \<Gamma> \<Longrightarrow> \<Delta> \<turnstile> S <: T" by fact
have ok: "\<turnstile> \<Delta> ok" by fact
have extends: "\<Delta> extends \<Gamma>" by fact
- have "(X,S) \<in> set \<Delta>" using lh_drv_prem extends by (simp only: extends_memb)
+ have "(TVarB X S) \<in> set \<Delta>" using lh_drv_prem extends by (simp only: extends_memb)
moreover
have "\<Delta> \<turnstile> S <: T" using ok extends ih by simp
ultimately show "\<Delta> \<turnstile> Tvar X <: T" using ok by force
next
- case (S_Refl \<Gamma> X)
- have lh_drv_prem: "X \<in> domain \<Gamma>" by fact
+ case (SA_refl_TVar \<Gamma> X)
+ have lh_drv_prem: "X \<in> ty_domain \<Gamma>" by fact
have "\<turnstile> \<Delta> ok" by fact
moreover
have "\<Delta> extends \<Gamma>" by fact
- hence "X \<in> domain \<Delta>" using lh_drv_prem by (force dest: extends_domain)
+ hence "X \<in> ty_domain \<Delta>" using lh_drv_prem by (force dest: extends_ty_domain)
ultimately show "\<Delta> \<turnstile> Tvar X <: Tvar X" by force
next
- case (S_Arrow \<Gamma> T\<^isub>1 S\<^isub>1 S\<^isub>2 T\<^isub>2) thus "\<Delta> \<turnstile> S\<^isub>1 \<rightarrow> S\<^isub>2 <: T\<^isub>1 \<rightarrow> T\<^isub>2" by blast
+ case (SA_arrow \<Gamma> T\<^isub>1 S\<^isub>1 S\<^isub>2 T\<^isub>2) thus "\<Delta> \<turnstile> S\<^isub>1 \<rightarrow> S\<^isub>2 <: T\<^isub>1 \<rightarrow> T\<^isub>2" by blast
next
- case (S_Forall \<Gamma> T\<^isub>1 S\<^isub>1 X S\<^isub>2 T\<^isub>2)
+ case (SA_all \<Gamma> T\<^isub>1 S\<^isub>1 X S\<^isub>2 T\<^isub>2)
have fresh_cond: "X\<sharp>\<Delta>" by fact
- hence fresh_domain: "X\<sharp>(domain \<Delta>)" by (simp add: fresh_domain)
+ hence fresh_domain: "X\<sharp>(ty_domain \<Delta>)" by (simp add: fresh_domain)
have ih\<^isub>1: "\<And>\<Delta>. \<turnstile> \<Delta> ok \<Longrightarrow> \<Delta> extends \<Gamma> \<Longrightarrow> \<Delta> \<turnstile> T\<^isub>1 <: S\<^isub>1" by fact
- have ih\<^isub>2: "\<And>\<Delta>. \<turnstile> \<Delta> ok \<Longrightarrow> \<Delta> extends ((X,T\<^isub>1)#\<Gamma>) \<Longrightarrow> \<Delta> \<turnstile> S\<^isub>2 <: T\<^isub>2" by fact
+ have ih\<^isub>2: "\<And>\<Delta>. \<turnstile> \<Delta> ok \<Longrightarrow> \<Delta> extends ((TVarB X T\<^isub>1)#\<Gamma>) \<Longrightarrow> \<Delta> \<turnstile> S\<^isub>2 <: T\<^isub>2" by fact
have lh_drv_prem: "\<Gamma> \<turnstile> T\<^isub>1 <: S\<^isub>1" by fact
hence closed\<^isub>T\<^isub>1: "T\<^isub>1 closed_in \<Gamma>" by (simp add: subtype_implies_closed)
have ok: "\<turnstile> \<Delta> ok" by fact
have ext: "\<Delta> extends \<Gamma>" by fact
have "T\<^isub>1 closed_in \<Delta>" using ext closed\<^isub>T\<^isub>1 by (simp only: extends_closed)
- hence "\<turnstile> ((X,T\<^isub>1)#\<Delta>) ok" using fresh_domain ok by force
+ hence "\<turnstile> ((TVarB X T\<^isub>1)#\<Delta>) ok" using fresh_domain ok by force
moreover
- have "((X,T\<^isub>1)#\<Delta>) extends ((X,T\<^isub>1)#\<Gamma>)" using ext by (force simp add: extends_def)
- ultimately have "((X,T\<^isub>1)#\<Delta>) \<turnstile> S\<^isub>2 <: T\<^isub>2" using ih\<^isub>2 by simp
+ have "((TVarB X T\<^isub>1)#\<Delta>) extends ((TVarB X T\<^isub>1)#\<Gamma>)" using ext by (force simp add: extends_def)
+ ultimately have "((TVarB X T\<^isub>1)#\<Delta>) \<turnstile> S\<^isub>2 <: T\<^isub>2" using ih\<^isub>2 by simp
moreover
have "\<Delta> \<turnstile> T\<^isub>1 <: S\<^isub>1" using ok ext ih\<^isub>1 by simp
- ultimately show "\<Delta> \<turnstile> \<forall>[X<:S\<^isub>1].S\<^isub>2 <: \<forall>[X<:T\<^isub>1].T\<^isub>2" using ok by (force intro: S_Forall)
+ ultimately show "\<Delta> \<turnstile> (\<forall>X<:S\<^isub>1. S\<^isub>2) <: (\<forall>X<:T\<^isub>1. T\<^isub>2)" using ok by (force intro: SA_all)
qed
text {* In fact all ``non-binding" cases can be solved automatically: *}
@@ -461,44 +799,41 @@
shows "\<Delta> \<turnstile> S <: T"
using a b c
proof (nominal_induct \<Gamma> S T avoiding: \<Delta> rule: subtype_of.strong_induct)
- case (S_Forall \<Gamma> T\<^isub>1 S\<^isub>1 X S\<^isub>2 T\<^isub>2)
+ case (SA_all \<Gamma> T\<^isub>1 S\<^isub>1 X S\<^isub>2 T\<^isub>2)
have fresh_cond: "X\<sharp>\<Delta>" by fact
- hence fresh_domain: "X\<sharp>(domain \<Delta>)" by (simp add: fresh_domain)
+ hence fresh_domain: "X\<sharp>(ty_domain \<Delta>)" by (simp add: fresh_domain)
have ih\<^isub>1: "\<And>\<Delta>. \<turnstile> \<Delta> ok \<Longrightarrow> \<Delta> extends \<Gamma> \<Longrightarrow> \<Delta> \<turnstile> T\<^isub>1 <: S\<^isub>1" by fact
- have ih\<^isub>2: "\<And>\<Delta>. \<turnstile> \<Delta> ok \<Longrightarrow> \<Delta> extends ((X,T\<^isub>1)#\<Gamma>) \<Longrightarrow> \<Delta> \<turnstile> S\<^isub>2 <: T\<^isub>2" by fact
+ have ih\<^isub>2: "\<And>\<Delta>. \<turnstile> \<Delta> ok \<Longrightarrow> \<Delta> extends ((TVarB X T\<^isub>1)#\<Gamma>) \<Longrightarrow> \<Delta> \<turnstile> S\<^isub>2 <: T\<^isub>2" by fact
have lh_drv_prem: "\<Gamma> \<turnstile> T\<^isub>1 <: S\<^isub>1" by fact
hence closed\<^isub>T\<^isub>1: "T\<^isub>1 closed_in \<Gamma>" by (simp add: subtype_implies_closed)
have ok: "\<turnstile> \<Delta> ok" by fact
have ext: "\<Delta> extends \<Gamma>" by fact
have "T\<^isub>1 closed_in \<Delta>" using ext closed\<^isub>T\<^isub>1 by (simp only: extends_closed)
- hence "\<turnstile> ((X,T\<^isub>1)#\<Delta>) ok" using fresh_domain ok by force
+ hence "\<turnstile> ((TVarB X T\<^isub>1)#\<Delta>) ok" using fresh_domain ok by force
moreover
- have "((X,T\<^isub>1)#\<Delta>) extends ((X,T\<^isub>1)#\<Gamma>)" using ext by (force simp add: extends_def)
- ultimately have "((X,T\<^isub>1)#\<Delta>) \<turnstile> S\<^isub>2 <: T\<^isub>2" using ih\<^isub>2 by simp
+ have "((TVarB X T\<^isub>1)#\<Delta>) extends ((TVarB X T\<^isub>1)#\<Gamma>)" using ext by (force simp add: extends_def)
+ ultimately have "((TVarB X T\<^isub>1)#\<Delta>) \<turnstile> S\<^isub>2 <: T\<^isub>2" using ih\<^isub>2 by simp
moreover
have "\<Delta> \<turnstile> T\<^isub>1 <: S\<^isub>1" using ok ext ih\<^isub>1 by simp
- ultimately show "\<Delta> \<turnstile> \<forall>[X<:S\<^isub>1].S\<^isub>2 <: \<forall>[X<:T\<^isub>1].T\<^isub>2" using ok by (force intro: S_Forall)
-qed (blast intro: extends_closed extends_memb dest: extends_domain)+
+ ultimately show "\<Delta> \<turnstile> (\<forall>X<:S\<^isub>1. S\<^isub>2) <: (\<forall>X<:T\<^isub>1. T\<^isub>2)" using ok by (force intro: SA_all)
+qed (blast intro: extends_closed extends_memb dest: extends_ty_domain)+
section {* Transitivity and Narrowing *}
text {* Some inversion lemmas that are needed in the transitivity and narrowing proof.*}
-lemma S_TopE:
- assumes a: "\<Gamma> \<turnstile> Top <: T"
- shows "T = Top"
-using a by (cases, auto)
+declare ty.inject [simp add]
-lemma S_ArrowE_left:
- assumes a: "\<Gamma> \<turnstile> S\<^isub>1 \<rightarrow> S\<^isub>2 <: T"
- shows "T = Top \<or> (\<exists>T\<^isub>1 T\<^isub>2. T = T\<^isub>1 \<rightarrow> T\<^isub>2 \<and> \<Gamma> \<turnstile> T\<^isub>1 <: S\<^isub>1 \<and> \<Gamma> \<turnstile> S\<^isub>2 <: T\<^isub>2)"
-using a by (cases, auto simp add: ty.inject)
+inductive_cases S_TopE: "\<Gamma> \<turnstile> Top <: T"
+inductive_cases S_ArrowE_left: "\<Gamma> \<turnstile> S\<^isub>1 \<rightarrow> S\<^isub>2 <: T"
+
+declare ty.inject [simp del]
lemma S_ForallE_left:
- shows "\<lbrakk>\<Gamma> \<turnstile> \<forall>[X<:S\<^isub>1].S\<^isub>2 <: T; X\<sharp>\<Gamma>; X\<sharp>S\<^isub>1\<rbrakk>
- \<Longrightarrow> T = Top \<or> (\<exists>T\<^isub>1 T\<^isub>2. T = \<forall>[X<:T\<^isub>1].T\<^isub>2 \<and> \<Gamma> \<turnstile> T\<^isub>1 <: S\<^isub>1 \<and> ((X,T\<^isub>1)#\<Gamma>) \<turnstile> S\<^isub>2 <: T\<^isub>2)"
+ shows "\<lbrakk>\<Gamma> \<turnstile> (\<forall>X<:S\<^isub>1. S\<^isub>2) <: T; X\<sharp>\<Gamma>; X\<sharp>S\<^isub>1\<rbrakk>
+ \<Longrightarrow> T = Top \<or> (\<exists>T\<^isub>1 T\<^isub>2. T = (\<forall>X<:T\<^isub>1. T\<^isub>2) \<and> \<Gamma> \<turnstile> T\<^isub>1 <: S\<^isub>1 \<and> ((TVarB X T\<^isub>1)#\<Gamma>) \<turnstile> S\<^isub>2 <: T\<^isub>2)"
apply(frule subtype_implies_ok)
- apply(ind_cases "\<Gamma> \<turnstile> \<forall>[X<:S\<^isub>1].S\<^isub>2 <: T")
+ apply(ind_cases "\<Gamma> \<turnstile> (\<forall>X<:S\<^isub>1. S\<^isub>2) <: T")
apply(auto simp add: ty.inject alpha)
apply(rule_tac x="[(X,Xa)]\<bullet>T\<^isub>2" in exI)
apply(rule conjI)
@@ -509,18 +844,20 @@
apply(rule at_ds5[OF at_tyvrs_inst])
apply(rule conjI)
apply(simp add: pt_fresh_left[OF pt_tyvrs_inst, OF at_tyvrs_inst] calc_atm)
- apply(drule_tac \<Gamma>="((Xa,T\<^isub>1)#\<Gamma>)" in subtype_implies_closed)+
+ apply(drule_tac \<Gamma>="((TVarB Xa T\<^isub>1)#\<Gamma>)" in subtype_implies_closed)+
apply(simp add: closed_in_def)
apply(drule fresh_domain)+
apply(simp add: fresh_def)
- apply(subgoal_tac "X \<notin> (insert Xa (domain \<Gamma>))")(*A*)
+ apply(subgoal_tac "X \<notin> (insert Xa (ty_domain \<Gamma>))")(*A*)
apply(force)
- (*A*)apply(simp add: at_fin_set_supp[OF at_tyvrs_inst, OF finite_domain])
+ (*A*)apply(simp add: at_fin_set_supp[OF at_tyvrs_inst, OF finite_domains(1)])
(* 2nd conjunct *)apply(frule_tac X="X" in subtype_implies_fresh)
apply(assumption)
+ apply (frule_tac \<Gamma>="TVarB Xa T\<^isub>1 # \<Gamma>" in subtype_implies_ok)
+ apply (erule validE)
+ apply (simp add: valid_ty_domain_fresh)
apply(drule_tac X="Xa" in subtype_implies_fresh)
apply(assumption)
- apply(simp add: fresh_prod)
apply(drule_tac pi="[(X,Xa)]" in subtype_of.eqvt(2))
apply(simp add: calc_atm)
apply(simp add: pt_fresh_fresh[OF pt_tyvrs_inst, OF at_tyvrs_inst])
@@ -556,8 +893,8 @@
that of @{term x} the property @{term "P y"} holds. *}
lemma
- shows trans: "\<Gamma>\<turnstile>S<:Q \<Longrightarrow> \<Gamma>\<turnstile>Q<:T \<Longrightarrow> \<Gamma>\<turnstile>S<:T"
- and narrow: "(\<Delta>@[(X,Q)]@\<Gamma>)\<turnstile>M<:N \<Longrightarrow> \<Gamma>\<turnstile>P<:Q \<Longrightarrow> (\<Delta>@[(X,P)]@\<Gamma>)\<turnstile>M<:N"
+ shows subtype_transitivity: "\<Gamma>\<turnstile>S<:Q \<Longrightarrow> \<Gamma>\<turnstile>Q<:T \<Longrightarrow> \<Gamma>\<turnstile>S<:T"
+ and subtype_narrow: "(\<Delta>@[(TVarB X Q)]@\<Gamma>)\<turnstile>M<:N \<Longrightarrow> \<Gamma>\<turnstile>P<:Q \<Longrightarrow> (\<Delta>@[(TVarB X P)]@\<Gamma>)\<turnstile>M<:N"
proof (induct Q arbitrary: \<Gamma> S T \<Delta> X P M N taking: "size_ty" rule: measure_induct_rule)
case (less Q)
--{* \begin{minipage}[t]{0.9\textwidth}
@@ -566,8 +903,8 @@
have IH_trans:
"\<And>Q' \<Gamma> S T. \<lbrakk>size_ty Q' < size_ty Q; \<Gamma>\<turnstile>S<:Q'; \<Gamma>\<turnstile>Q'<:T\<rbrakk> \<Longrightarrow> \<Gamma>\<turnstile>S<:T" by fact
have IH_narrow:
- "\<And>Q' \<Delta> \<Gamma> X M N P. \<lbrakk>size_ty Q' < size_ty Q; (\<Delta>@[(X,Q')]@\<Gamma>)\<turnstile>M<:N; \<Gamma>\<turnstile>P<:Q'\<rbrakk>
- \<Longrightarrow> (\<Delta>@[(X,P)]@\<Gamma>)\<turnstile>M<:N" by fact
+ "\<And>Q' \<Delta> \<Gamma> X M N P. \<lbrakk>size_ty Q' < size_ty Q; (\<Delta>@[(TVarB X Q')]@\<Gamma>)\<turnstile>M<:N; \<Gamma>\<turnstile>P<:Q'\<rbrakk>
+ \<Longrightarrow> (\<Delta>@[(TVarB X P)]@\<Gamma>)\<turnstile>M<:N" by fact
--{* \begin{minipage}[t]{0.9\textwidth}
We proceed with the transitivity proof as an auxiliary lemma, because it needs
to be referenced in the narrowing proof.\end{minipage}*}
@@ -579,37 +916,36 @@
and "\<Gamma>' \<turnstile> Q <: T" --{* right-hand derivation *}
thus "\<Gamma>' \<turnstile> S' <: T"
proof (nominal_induct \<Gamma>' S' Q\<equiv>Q rule: subtype_of.strong_induct)
- case (S_Top \<Gamma> S)
+ case (SA_Top \<Gamma> S)
--{* \begin{minipage}[t]{0.9\textwidth}
In this case the left-hand derivation is @{term "\<Gamma> \<turnstile> S <: Top"}, giving
us @{term "\<turnstile> \<Gamma> ok"} and @{term "S closed_in \<Gamma>"}. This case is straightforward,
because the right-hand derivation must be of the form @{term "\<Gamma> \<turnstile> Top <: Top"}
giving us the equation @{term "T = Top"}.\end{minipage}*}
hence rh_drv: "\<Gamma> \<turnstile> Top <: T" by simp
- hence T_inst: "T = Top" by (simp add: S_TopE)
- have "\<turnstile> \<Gamma> ok"
- and "S closed_in \<Gamma>" by fact+
- hence "\<Gamma> \<turnstile> S <: Top" by (simp add: subtype_of.S_Top)
+ hence T_inst: "T = Top" by (auto elim: S_TopE)
+ from `\<turnstile> \<Gamma> ok` and `S closed_in \<Gamma>`
+ have "\<Gamma> \<turnstile> S <: Top" by (simp add: subtype_of.SA_Top)
thus "\<Gamma> \<turnstile> S <: T" using T_inst by simp
next
- case (S_Var Y U \<Gamma>)
+ case (SA_trans_TVar Y U \<Gamma>)
-- {* \begin{minipage}[t]{0.9\textwidth}
In this case the left-hand derivation is @{term "\<Gamma> \<turnstile> Tvar Y <: Q"}
with @{term "S = Tvar Y"}. We have therefore @{term "(Y,U)"}
is in @{term "\<Gamma>"} and by inner induction hypothesis that @{term "\<Gamma> \<turnstile> U <: T"}.
By @{text "S_Var"} follows @{term "\<Gamma> \<turnstile> Tvar Y <: T"}.\end{minipage}*}
hence IH_inner: "\<Gamma> \<turnstile> U <: T" by simp
- have "(Y,U) \<in> set \<Gamma>" by fact
- with IH_inner show "\<Gamma> \<turnstile> Tvar Y <: T" by (simp add: subtype_of.S_Var)
+ have "(TVarB Y U) \<in> set \<Gamma>" by fact
+ with IH_inner show "\<Gamma> \<turnstile> Tvar Y <: T" by (simp add: subtype_of.SA_trans_TVar)
next
- case (S_Refl \<Gamma> X)
+ case (SA_refl_TVar \<Gamma> X)
--{* \begin{minipage}[t]{0.9\textwidth}
In this case the left-hand derivation is @{term "\<Gamma>\<turnstile>(Tvar X) <: (Tvar X)"} with
@{term "Q=Tvar X"}. The goal then follows immediately from the right-hand
derivation.\end{minipage}*}
thus "\<Gamma> \<turnstile> Tvar X <: T" by simp
next
- case (S_Arrow \<Gamma> Q\<^isub>1 S\<^isub>1 S\<^isub>2 Q\<^isub>2)
+ case (SA_arrow \<Gamma> Q\<^isub>1 S\<^isub>1 S\<^isub>2 Q\<^isub>2)
--{* \begin{minipage}[t]{0.9\textwidth}
In this case the left-hand derivation is @{term "\<Gamma> \<turnstile> S\<^isub>1 \<rightarrow> S\<^isub>2 <: Q\<^isub>1 \<rightarrow> Q\<^isub>2"} with
@{term "S\<^isub>1\<rightarrow>S\<^isub>2=S"} and @{term "Q\<^isub>1\<rightarrow>Q\<^isub>2=Q"}. We know that the @{text "size_ty"} of
@@ -629,7 +965,7 @@
have lh_drv_prm\<^isub>1: "\<Gamma> \<turnstile> Q\<^isub>1 <: S\<^isub>1" by fact
have lh_drv_prm\<^isub>2: "\<Gamma> \<turnstile> S\<^isub>2 <: Q\<^isub>2" by fact
from rh_drv have "T=Top \<or> (\<exists>T\<^isub>1 T\<^isub>2. T=T\<^isub>1\<rightarrow>T\<^isub>2 \<and> \<Gamma>\<turnstile>T\<^isub>1<:Q\<^isub>1 \<and> \<Gamma>\<turnstile>Q\<^isub>2<:T\<^isub>2)"
- by (simp add: S_ArrowE_left)
+ by (auto elim: S_ArrowE_left)
moreover
have "S\<^isub>1 closed_in \<Gamma>" and "S\<^isub>2 closed_in \<Gamma>"
using lh_drv_prm\<^isub>1 lh_drv_prm\<^isub>2 by (simp_all add: subtype_implies_closed)
@@ -647,176 +983,1020 @@
moreover
from IH_trans[of "Q\<^isub>2"]
have "\<Gamma> \<turnstile> S\<^isub>2 <: T\<^isub>2" using Q\<^isub>1\<^isub>2_less rh_drv_prm\<^isub>2 lh_drv_prm\<^isub>2 by simp
- ultimately have "\<Gamma> \<turnstile> S\<^isub>1 \<rightarrow> S\<^isub>2 <: T\<^isub>1 \<rightarrow> T\<^isub>2" by (simp add: subtype_of.S_Arrow)
+ ultimately have "\<Gamma> \<turnstile> S\<^isub>1 \<rightarrow> S\<^isub>2 <: T\<^isub>1 \<rightarrow> T\<^isub>2" by (simp add: subtype_of.SA_arrow)
hence "\<Gamma> \<turnstile> S\<^isub>1 \<rightarrow> S\<^isub>2 <: T" using T_inst by simp
}
ultimately show "\<Gamma> \<turnstile> S\<^isub>1 \<rightarrow> S\<^isub>2 <: T" by blast
next
- case (S_Forall \<Gamma> Q\<^isub>1 S\<^isub>1 X S\<^isub>2 Q\<^isub>2)
+ case (SA_all \<Gamma> Q\<^isub>1 S\<^isub>1 X S\<^isub>2 Q\<^isub>2)
--{* \begin{minipage}[t]{0.9\textwidth}
- In this case the left-hand derivation is @{text "\<Gamma>\<turnstile>\<forall>[X<:S\<^isub>1].S\<^isub>2 <: \<forall>[X<:Q\<^isub>1].Q\<^isub>2"} with
- @{text "\<forall>[X<:S\<^isub>1].S\<^isub>2=S"} and @{text "\<forall>[X<:Q\<^isub>1].Q\<^isub>2=Q"}. We therefore have the sub-derivations
- @{term "\<Gamma>\<turnstile>Q\<^isub>1<:S\<^isub>1"} and @{term "((X,Q\<^isub>1)#\<Gamma>)\<turnstile>S\<^isub>2<:Q\<^isub>2"}. Since @{term "X"} is a binder, we
+ In this case the left-hand derivation is @{term "\<Gamma>\<turnstile>(\<forall>X<:S\<^isub>1. S\<^isub>2) <: (\<forall>X<:Q\<^isub>1. Q\<^isub>2)"} with
+ @{term "(\<forall>X<:S\<^isub>1. S\<^isub>2)=S"} and @{term "(\<forall>X<:Q\<^isub>1. Q\<^isub>2)=Q"}. We therefore have the sub-derivations
+ @{term "\<Gamma>\<turnstile>Q\<^isub>1<:S\<^isub>1"} and @{term "((TVarB X Q\<^isub>1)#\<Gamma>)\<turnstile>S\<^isub>2<:Q\<^isub>2"}. Since @{term "X"} is a binder, we
assume that it is sufficiently fresh; in particular we have the freshness conditions
@{term "X\<sharp>\<Gamma>"} and @{term "X\<sharp>Q\<^isub>1"} (these assumptions are provided by the strong
induction-rule @{text "subtype_of_induct"}). We know that the @{text "size_ty"} of
@{term Q\<^isub>1} and @{term Q\<^isub>2} is smaller than that of @{term Q};
so we can apply the outer induction hypotheses for @{term Q\<^isub>1} and @{term Q\<^isub>2}.
- The right-hand derivation is @{text "\<Gamma> \<turnstile> \<forall>[X<:Q\<^isub>1].Q\<^isub>2 <: T"}. Since @{term "X\<sharp>\<Gamma>"}
+ The right-hand derivation is @{term "\<Gamma> \<turnstile> (\<forall>X<:Q\<^isub>1. Q\<^isub>2) <: T"}. Since @{term "X\<sharp>\<Gamma>"}
and @{term "X\<sharp>Q\<^isub>1"} there exists types @{text "T\<^isub>1,T\<^isub>2"} such that
- @{text "T=Top \<or> T=\<forall>[X<:T\<^isub>1].T\<^isub>2"}. The @{term "Top"}-case is straightforward once we know
- @{text "(\<forall>[X<:S\<^isub>1].S\<^isub>2) closed_in \<Gamma>"} and @{term "\<turnstile> \<Gamma> ok"}. In the other case we have
- the sub-derivations @{term "\<Gamma>\<turnstile>T\<^isub>1<:Q\<^isub>1"} and @{term "((X,T\<^isub>1)#\<Gamma>)\<turnstile>Q\<^isub>2<:T\<^isub>2"}. Using the outer
+ @{term "T=Top \<or> T=(\<forall>X<:T\<^isub>1. T\<^isub>2)"}. The @{term "Top"}-case is straightforward once we know
+ @{term "(\<forall>X<:S\<^isub>1. S\<^isub>2) closed_in \<Gamma>"} and @{term "\<turnstile> \<Gamma> ok"}. In the other case we have
+ the sub-derivations @{term "\<Gamma>\<turnstile>T\<^isub>1<:Q\<^isub>1"} and @{term "((TVarB X T\<^isub>1)#\<Gamma>)\<turnstile>Q\<^isub>2<:T\<^isub>2"}. Using the outer
induction hypothesis for transitivity we can derive @{term "\<Gamma>\<turnstile>T\<^isub>1<:S\<^isub>1"}. From the outer
- induction for narrowing we get @{term "((X,T\<^isub>1)#\<Gamma>) \<turnstile> S\<^isub>2 <: Q\<^isub>2"} and then using again
- induction for transitivity we obtain @{term "((X,T\<^isub>1)#\<Gamma>) \<turnstile> S\<^isub>2 <: T\<^isub>2"}. By rule
+ induction for narrowing we get @{term "((TVarB X T\<^isub>1)#\<Gamma>) \<turnstile> S\<^isub>2 <: Q\<^isub>2"} and then using again
+ induction for transitivity we obtain @{term "((TVarB X T\<^isub>1)#\<Gamma>) \<turnstile> S\<^isub>2 <: T\<^isub>2"}. By rule
@{text "S_Forall"} and the freshness condition @{term "X\<sharp>\<Gamma>"} follows
- @{text "\<Gamma> \<turnstile> \<forall>[X<:S\<^isub>1].S\<^isub>2 <: \<forall>[X<:T\<^isub>1].T\<^isub>2"}, which is @{text "\<Gamma> \<turnstile> \<forall>[X<:S\<^isub>1].S\<^isub>2 <: T\<^isub>"}.
+ @{term "\<Gamma> \<turnstile> (\<forall>X<:S\<^isub>1. S\<^isub>2) <: (\<forall>X<:T\<^isub>1. T\<^isub>2)"}, which is @{term "\<Gamma> \<turnstile> (\<forall>X<:S\<^isub>1. S\<^isub>2) <: T\<^isub>"}.
\end{minipage}*}
- hence rh_drv: "\<Gamma> \<turnstile> \<forall>[X<:Q\<^isub>1].Q\<^isub>2 <: T" by simp
+ hence rh_drv: "\<Gamma> \<turnstile> (\<forall>X<:Q\<^isub>1. Q\<^isub>2) <: T" by simp
have lh_drv_prm\<^isub>1: "\<Gamma> \<turnstile> Q\<^isub>1 <: S\<^isub>1" by fact
- have lh_drv_prm\<^isub>2: "((X,Q\<^isub>1)#\<Gamma>) \<turnstile> S\<^isub>2 <: Q\<^isub>2" by fact
- have "X\<sharp>\<Gamma>" by fact
+ have lh_drv_prm\<^isub>2: "((TVarB X Q\<^isub>1)#\<Gamma>) \<turnstile> S\<^isub>2 <: Q\<^isub>2" by fact
+ then have "X\<sharp>\<Gamma>" by (force dest: subtype_implies_ok simp add: valid_ty_domain_fresh)
then have fresh_cond: "X\<sharp>\<Gamma>" "X\<sharp>Q\<^isub>1" using lh_drv_prm\<^isub>1 by (simp_all add: subtype_implies_fresh)
- from `\<forall>[X<:Q\<^isub>1].Q\<^isub>2 = Q`
+ from `(\<forall>X<:Q\<^isub>1. Q\<^isub>2) = Q`
have Q\<^isub>1\<^isub>2_less: "size_ty Q\<^isub>1 < size_ty Q" "size_ty Q\<^isub>2 < size_ty Q " using fresh_cond by auto
from rh_drv
- have "T=Top \<or> (\<exists>T\<^isub>1 T\<^isub>2. T=\<forall>[X<:T\<^isub>1].T\<^isub>2 \<and> \<Gamma>\<turnstile>T\<^isub>1<:Q\<^isub>1 \<and> ((X,T\<^isub>1)#\<Gamma>)\<turnstile>Q\<^isub>2<:T\<^isub>2)"
+ have "T=Top \<or> (\<exists>T\<^isub>1 T\<^isub>2. T=(\<forall>X<:T\<^isub>1. T\<^isub>2) \<and> \<Gamma>\<turnstile>T\<^isub>1<:Q\<^isub>1 \<and> ((TVarB X T\<^isub>1)#\<Gamma>)\<turnstile>Q\<^isub>2<:T\<^isub>2)"
using fresh_cond by (simp add: S_ForallE_left)
moreover
- have "S\<^isub>1 closed_in \<Gamma>" and "S\<^isub>2 closed_in ((X,Q\<^isub>1)#\<Gamma>)"
+ have "S\<^isub>1 closed_in \<Gamma>" and "S\<^isub>2 closed_in ((TVarB X Q\<^isub>1)#\<Gamma>)"
using lh_drv_prm\<^isub>1 lh_drv_prm\<^isub>2 by (simp_all add: subtype_implies_closed)
- hence "(\<forall>[X<:S\<^isub>1].S\<^isub>2) closed_in \<Gamma>" by (force simp add: closed_in_def ty.supp abs_supp)
+ hence "(\<forall>X<:S\<^isub>1. S\<^isub>2) closed_in \<Gamma>" by (force simp add: closed_in_def ty.supp abs_supp)
moreover
have "\<turnstile> \<Gamma> ok" using rh_drv by (rule subtype_implies_ok)
moreover
- { assume "\<exists>T\<^isub>1 T\<^isub>2. T=\<forall>[X<:T\<^isub>1].T\<^isub>2 \<and> \<Gamma>\<turnstile>T\<^isub>1<:Q\<^isub>1 \<and> ((X,T\<^isub>1)#\<Gamma>)\<turnstile>Q\<^isub>2<:T\<^isub>2"
+ { assume "\<exists>T\<^isub>1 T\<^isub>2. T=(\<forall>X<:T\<^isub>1. T\<^isub>2) \<and> \<Gamma>\<turnstile>T\<^isub>1<:Q\<^isub>1 \<and> ((TVarB X T\<^isub>1)#\<Gamma>)\<turnstile>Q\<^isub>2<:T\<^isub>2"
then obtain T\<^isub>1 T\<^isub>2
- where T_inst: "T = \<forall>[X<:T\<^isub>1].T\<^isub>2"
+ where T_inst: "T = (\<forall>X<:T\<^isub>1. T\<^isub>2)"
and rh_drv_prm\<^isub>1: "\<Gamma> \<turnstile> T\<^isub>1 <: Q\<^isub>1"
- and rh_drv_prm\<^isub>2:"((X,T\<^isub>1)#\<Gamma>) \<turnstile> Q\<^isub>2 <: T\<^isub>2" by force
+ and rh_drv_prm\<^isub>2:"((TVarB X T\<^isub>1)#\<Gamma>) \<turnstile> Q\<^isub>2 <: T\<^isub>2" by force
from IH_trans[of "Q\<^isub>1"]
have "\<Gamma> \<turnstile> T\<^isub>1 <: S\<^isub>1" using lh_drv_prm\<^isub>1 rh_drv_prm\<^isub>1 Q\<^isub>1\<^isub>2_less by blast
moreover
from IH_narrow[of "Q\<^isub>1" "[]"]
- have "((X,T\<^isub>1)#\<Gamma>) \<turnstile> S\<^isub>2 <: Q\<^isub>2" using Q\<^isub>1\<^isub>2_less lh_drv_prm\<^isub>2 rh_drv_prm\<^isub>1 by simp
+ have "((TVarB X T\<^isub>1)#\<Gamma>) \<turnstile> S\<^isub>2 <: Q\<^isub>2" using Q\<^isub>1\<^isub>2_less lh_drv_prm\<^isub>2 rh_drv_prm\<^isub>1 by simp
with IH_trans[of "Q\<^isub>2"]
- have "((X,T\<^isub>1)#\<Gamma>) \<turnstile> S\<^isub>2 <: T\<^isub>2" using Q\<^isub>1\<^isub>2_less rh_drv_prm\<^isub>2 by simp
- ultimately have "\<Gamma> \<turnstile> \<forall>[X<:S\<^isub>1].S\<^isub>2 <: \<forall>[X<:T\<^isub>1].T\<^isub>2"
- using fresh_cond by (simp add: subtype_of.S_Forall)
- hence "\<Gamma> \<turnstile> \<forall>[X<:S\<^isub>1].S\<^isub>2 <: T" using T_inst by simp
+ have "((TVarB X T\<^isub>1)#\<Gamma>) \<turnstile> S\<^isub>2 <: T\<^isub>2" using Q\<^isub>1\<^isub>2_less rh_drv_prm\<^isub>2 by simp
+ ultimately have "\<Gamma> \<turnstile> (\<forall>X<:S\<^isub>1. S\<^isub>2) <: (\<forall>X<:T\<^isub>1. T\<^isub>2)"
+ using fresh_cond by (simp add: subtype_of.SA_all)
+ hence "\<Gamma> \<turnstile> (\<forall>X<:S\<^isub>1. S\<^isub>2) <: T" using T_inst by simp
}
- ultimately show "\<Gamma> \<turnstile> \<forall>[X<:S\<^isub>1].S\<^isub>2 <: T" by blast
+ ultimately show "\<Gamma> \<turnstile> (\<forall>X<:S\<^isub>1. S\<^isub>2) <: T" by blast
qed
qed
{ --{* The transitivity proof is now by the auxiliary lemma. *}
case 1
- have "\<Gamma> \<turnstile> S <: Q"
- and "\<Gamma> \<turnstile> Q <: T" by fact+
- thus "\<Gamma> \<turnstile> S <: T" by (rule transitivity_aux)
+ from `\<Gamma> \<turnstile> S <: Q` and `\<Gamma> \<turnstile> Q <: T`
+ show "\<Gamma> \<turnstile> S <: T" by (rule transitivity_aux)
next
- --{* The narrowing proof proceeds by an induction over @{term "(\<Delta>@[(X,Q)]@\<Gamma>) \<turnstile> M <: N"}. *}
+ --{* The narrowing proof proceeds by an induction over @{term "(\<Delta>@[(TVarB X Q)]@\<Gamma>) \<turnstile> M <: N"}. *}
case 2
- have "(\<Delta>@[(X,Q)]@\<Gamma>) \<turnstile> M <: N" --{* left-hand derivation *}
- and "\<Gamma> \<turnstile> P<:Q" by fact+ --{* right-hand derivation *}
- thus "(\<Delta>@[(X,P)]@\<Gamma>) \<turnstile> M <: N"
- proof (nominal_induct \<Gamma>\<equiv>"\<Delta>@[(X,Q)]@\<Gamma>" M N avoiding: \<Delta> \<Gamma> X rule: subtype_of.strong_induct)
- case (S_Top _ S \<Delta> \<Gamma> X)
+ from `(\<Delta>@[(TVarB X Q)]@\<Gamma>) \<turnstile> M <: N` --{* left-hand derivation *}
+ and `\<Gamma> \<turnstile> P<:Q` --{* right-hand derivation *}
+ show "(\<Delta>@[(TVarB X P)]@\<Gamma>) \<turnstile> M <: N"
+ proof (nominal_induct \<Gamma>\<equiv>"\<Delta>@[(TVarB X Q)]@\<Gamma>" M N avoiding: \<Delta> \<Gamma> X rule: subtype_of.strong_induct)
+ case (SA_Top _ S \<Delta> \<Gamma> X)
--{* \begin{minipage}[t]{0.9\textwidth}
- In this case the left-hand derivation is @{term "(\<Delta>@[(X,Q)]@\<Gamma>) \<turnstile> S <: Top"}. We show
- that the context @{term "\<Delta>@[(X,P)]@\<Gamma>"} is ok and that @{term S} is closed in
- @{term "\<Delta>@[(X,P)]@\<Gamma>"}. Then we can apply the @{text "S_Top"}-rule.\end{minipage}*}
- hence lh_drv_prm\<^isub>1: "\<turnstile> (\<Delta>@[(X,Q)]@\<Gamma>) ok"
- and lh_drv_prm\<^isub>2: "S closed_in (\<Delta>@[(X,Q)]@\<Gamma>)" by simp_all
+ In this case the left-hand derivation is @{term "(\<Delta>@[(TVarB X Q)]@\<Gamma>) \<turnstile> S <: Top"}. We show
+ that the context @{term "\<Delta>@[(TVarB X P)]@\<Gamma>"} is ok and that @{term S} is closed in
+ @{term "\<Delta>@[(TVarB X P)]@\<Gamma>"}. Then we can apply the @{text "S_Top"}-rule.\end{minipage}*}
+ hence lh_drv_prm\<^isub>1: "\<turnstile> (\<Delta>@[(TVarB X Q)]@\<Gamma>) ok"
+ and lh_drv_prm\<^isub>2: "S closed_in (\<Delta>@[(TVarB X Q)]@\<Gamma>)" by simp_all
have rh_drv: "\<Gamma> \<turnstile> P <: Q" by fact
hence "P closed_in \<Gamma>" by (simp add: subtype_implies_closed)
- with lh_drv_prm\<^isub>1 have "\<turnstile> (\<Delta>@[(X,P)]@\<Gamma>) ok" by (simp add: replace_type)
+ with lh_drv_prm\<^isub>1 have "\<turnstile> (\<Delta>@[(TVarB X P)]@\<Gamma>) ok" by (simp add: replace_type)
moreover
- from lh_drv_prm\<^isub>2 have "S closed_in (\<Delta>@[(X,P)]@\<Gamma>)"
- by (simp add: closed_in_def domain_append)
- ultimately show "(\<Delta>@[(X,P)]@\<Gamma>) \<turnstile> S <: Top" by (simp add: subtype_of.S_Top)
+ from lh_drv_prm\<^isub>2 have "S closed_in (\<Delta>@[(TVarB X P)]@\<Gamma>)"
+ by (simp add: closed_in_def domains_append)
+ ultimately show "(\<Delta>@[(TVarB X P)]@\<Gamma>) \<turnstile> S <: Top" by (simp add: subtype_of.SA_Top)
next
- case (S_Var Y S _ N \<Delta> \<Gamma> X)
+ case (SA_trans_TVar Y S _ N \<Delta> \<Gamma> X)
--{* \begin{minipage}[t]{0.9\textwidth}
- In this case the left-hand derivation is @{term "(\<Delta>@[(X,Q)]@\<Gamma>) \<turnstile> Tvar Y <: N"} and
- by inner induction hypothesis we have @{term "(\<Delta>@[(X,P)]@\<Gamma>) \<turnstile> S <: N"}. We therefore
- know that the contexts @{term "\<Delta>@[(X,Q)]@\<Gamma>"} and @{term "\<Delta>@[(X,P)]@\<Gamma>"} are ok, and that
- @{term "(Y,S)"} is in @{term "\<Delta>@[(X,Q)]@\<Gamma>"}. We need to show that
- @{term "(\<Delta>@[(X,P)]@\<Gamma>) \<turnstile> Tvar Y <: N"} holds. In case @{term "X\<noteq>Y"} we know that
- @{term "(Y,S)"} is in @{term "\<Delta>@[(X,P)]@\<Gamma>"} and can use the inner induction hypothesis
+ In this case the left-hand derivation is @{term "(\<Delta>@[(TVarB X Q)]@\<Gamma>) \<turnstile> Tvar Y <: N"} and
+ by inner induction hypothesis we have @{term "(\<Delta>@[(TVarB X P)]@\<Gamma>) \<turnstile> S <: N"}. We therefore
+ know that the contexts @{term "\<Delta>@[(TVarB X Q)]@\<Gamma>"} and @{term "\<Delta>@[(TVarB X P)]@\<Gamma>"} are ok, and that
+ @{term "(Y,S)"} is in @{term "\<Delta>@[(TVarB X Q)]@\<Gamma>"}. We need to show that
+ @{term "(\<Delta>@[(TVarB X P)]@\<Gamma>) \<turnstile> Tvar Y <: N"} holds. In case @{term "X\<noteq>Y"} we know that
+ @{term "(Y,S)"} is in @{term "\<Delta>@[(TVarB X P)]@\<Gamma>"} and can use the inner induction hypothesis
and rule @{text "S_Var"} to conclude. In case @{term "X=Y"} we can infer that
- @{term "S=Q"}; moreover we have that @{term "(\<Delta>@[(X,P)]@\<Gamma>) extends \<Gamma>"} and therefore
- by @{text "weakening"} that @{term "(\<Delta>@[(X,P)]@\<Gamma>) \<turnstile> P <: Q"} holds. By transitivity we
- obtain then @{term "(\<Delta>@[(X,P)]@\<Gamma>) \<turnstile> P <: N"} and can conclude by applying rule
+ @{term "S=Q"}; moreover we have that @{term "(\<Delta>@[(TVarB X P)]@\<Gamma>) extends \<Gamma>"} and therefore
+ by @{text "weakening"} that @{term "(\<Delta>@[(TVarB X P)]@\<Gamma>) \<turnstile> P <: Q"} holds. By transitivity we
+ obtain then @{term "(\<Delta>@[(TVarB X P)]@\<Gamma>) \<turnstile> P <: N"} and can conclude by applying rule
@{text "S_Var"}.\end{minipage}*}
- hence IH_inner: "(\<Delta>@[(X,P)]@\<Gamma>) \<turnstile> S <: N"
- and lh_drv_prm: "(Y,S) \<in> set (\<Delta>@[(X,Q)]@\<Gamma>)"
+ hence IH_inner: "(\<Delta>@[(TVarB X P)]@\<Gamma>) \<turnstile> S <: N"
+ and lh_drv_prm: "(TVarB Y S) \<in> set (\<Delta>@[(TVarB X Q)]@\<Gamma>)"
and rh_drv: "\<Gamma> \<turnstile> P<:Q"
- and ok\<^isub>Q: "\<turnstile> (\<Delta>@[(X,Q)]@\<Gamma>) ok" by (simp_all add: subtype_implies_ok)
- hence ok\<^isub>P: "\<turnstile> (\<Delta>@[(X,P)]@\<Gamma>) ok" by (simp add: subtype_implies_ok)
- show "(\<Delta>@[(X,P)]@\<Gamma>) \<turnstile> Tvar Y <: N"
+ and ok\<^isub>Q: "\<turnstile> (\<Delta>@[(TVarB X Q)]@\<Gamma>) ok" by (simp_all add: subtype_implies_ok)
+ hence ok\<^isub>P: "\<turnstile> (\<Delta>@[(TVarB X P)]@\<Gamma>) ok" by (simp add: subtype_implies_ok)
+ show "(\<Delta>@[(TVarB X P)]@\<Gamma>) \<turnstile> Tvar Y <: N"
proof (cases "X=Y")
case False
have "X\<noteq>Y" by fact
- hence "(Y,S)\<in>set (\<Delta>@[(X,P)]@\<Gamma>)" using lh_drv_prm by simp
- with IH_inner show "(\<Delta>@[(X,P)]@\<Gamma>) \<turnstile> Tvar Y <: N" by (simp add: subtype_of.S_Var)
+ hence "(TVarB Y S)\<in>set (\<Delta>@[(TVarB X P)]@\<Gamma>)" using lh_drv_prm by (simp add:binding.inject)
+ with IH_inner show "(\<Delta>@[(TVarB X P)]@\<Gamma>) \<turnstile> Tvar Y <: N" by (simp add: subtype_of.SA_trans_TVar)
next
case True
- have memb\<^isub>X\<^isub>Q: "(X,Q)\<in>set (\<Delta>@[(X,Q)]@\<Gamma>)" by simp
- have memb\<^isub>X\<^isub>P: "(X,P)\<in>set (\<Delta>@[(X,P)]@\<Gamma>)" by simp
+ have memb\<^isub>X\<^isub>Q: "(TVarB X Q)\<in>set (\<Delta>@[(TVarB X Q)]@\<Gamma>)" by simp
+ have memb\<^isub>X\<^isub>P: "(TVarB X P)\<in>set (\<Delta>@[(TVarB X P)]@\<Gamma>)" by simp
have eq: "X=Y" by fact
hence "S=Q" using ok\<^isub>Q lh_drv_prm memb\<^isub>X\<^isub>Q by (simp only: uniqueness_of_ctxt)
- hence "(\<Delta>@[(X,P)]@\<Gamma>) \<turnstile> Q <: N" using IH_inner by simp
+ hence "(\<Delta>@[(TVarB X P)]@\<Gamma>) \<turnstile> Q <: N" using IH_inner by simp
moreover
- have "(\<Delta>@[(X,P)]@\<Gamma>) extends \<Gamma>" by (simp add: extends_def)
- hence "(\<Delta>@[(X,P)]@\<Gamma>) \<turnstile> P <: Q" using rh_drv ok\<^isub>P by (simp only: weakening)
- ultimately have "(\<Delta>@[(X,P)]@\<Gamma>) \<turnstile> P <: N" by (simp add: transitivity_aux)
- thus "(\<Delta>@[(X,P)]@\<Gamma>) \<turnstile> Tvar Y <: N" using memb\<^isub>X\<^isub>P eq by (simp only: subtype_of.S_Var)
+ have "(\<Delta>@[(TVarB X P)]@\<Gamma>) extends \<Gamma>" by (simp add: extends_def)
+ hence "(\<Delta>@[(TVarB X P)]@\<Gamma>) \<turnstile> P <: Q" using rh_drv ok\<^isub>P by (simp only: weakening)
+ ultimately have "(\<Delta>@[(TVarB X P)]@\<Gamma>) \<turnstile> P <: N" by (simp add: transitivity_aux)
+ thus "(\<Delta>@[(TVarB X P)]@\<Gamma>) \<turnstile> Tvar Y <: N" using memb\<^isub>X\<^isub>P eq by (simp only: subtype_of.SA_trans_TVar)
qed
next
- case (S_Refl _ Y \<Delta> \<Gamma> X)
+ case (SA_refl_TVar _ Y \<Delta> \<Gamma> X)
--{* \begin{minipage}[t]{0.9\textwidth}
- In this case the left-hand derivation is @{term "(\<Delta>@[(X,Q)]@\<Gamma>) \<turnstile> Tvar Y <: Tvar Y"} and we
- therefore know that @{term "\<Delta>@[(X,Q)]@\<Gamma>"} is ok and that @{term "Y"} is in
- the domain of @{term "\<Delta>@[(X,Q)]@\<Gamma>"}. We therefore know that @{term "\<Delta>@[(X,P)]@\<Gamma>"} is ok
- and that @{term Y} is in the domain of @{term "\<Delta>@[(X,P)]@\<Gamma>"}. We can conclude by applying
+ In this case the left-hand derivation is @{term "(\<Delta>@[(TVarB X Q)]@\<Gamma>) \<turnstile> Tvar Y <: Tvar Y"} and we
+ therefore know that @{term "\<Delta>@[(TVarB X Q)]@\<Gamma>"} is ok and that @{term "Y"} is in
+ the domain of @{term "\<Delta>@[(TVarB X Q)]@\<Gamma>"}. We therefore know that @{term "\<Delta>@[(TVarB X P)]@\<Gamma>"} is ok
+ and that @{term Y} is in the domain of @{term "\<Delta>@[(TVarB X P)]@\<Gamma>"}. We can conclude by applying
rule @{text "S_Refl"}.\end{minipage}*}
- hence lh_drv_prm\<^isub>1: "\<turnstile> (\<Delta>@[(X,Q)]@\<Gamma>) ok"
- and lh_drv_prm\<^isub>2: "Y \<in> domain (\<Delta>@[(X,Q)]@\<Gamma>)" by simp_all
+ hence lh_drv_prm\<^isub>1: "\<turnstile> (\<Delta>@[(TVarB X Q)]@\<Gamma>) ok"
+ and lh_drv_prm\<^isub>2: "Y \<in> ty_domain (\<Delta>@[(TVarB X Q)]@\<Gamma>)" by simp_all
have "\<Gamma> \<turnstile> P <: Q" by fact
hence "P closed_in \<Gamma>" by (simp add: subtype_implies_closed)
- with lh_drv_prm\<^isub>1 have "\<turnstile> (\<Delta>@[(X,P)]@\<Gamma>) ok" by (simp add: replace_type)
+ with lh_drv_prm\<^isub>1 have "\<turnstile> (\<Delta>@[(TVarB X P)]@\<Gamma>) ok" by (simp add: replace_type)
moreover
- from lh_drv_prm\<^isub>2 have "Y \<in> domain (\<Delta>@[(X,P)]@\<Gamma>)" by (simp add: domain_append)
- ultimately show "(\<Delta>@[(X,P)]@\<Gamma>) \<turnstile> Tvar Y <: Tvar Y" by (simp add: subtype_of.S_Refl)
+ from lh_drv_prm\<^isub>2 have "Y \<in> ty_domain (\<Delta>@[(TVarB X P)]@\<Gamma>)" by (simp add: domains_append)
+ ultimately show "(\<Delta>@[(TVarB X P)]@\<Gamma>) \<turnstile> Tvar Y <: Tvar Y" by (simp add: subtype_of.SA_refl_TVar)
next
- case (S_Arrow _ S\<^isub>1 Q\<^isub>1 Q\<^isub>2 S\<^isub>2 \<Delta> \<Gamma> X)
+ case (SA_arrow _ S\<^isub>1 Q\<^isub>1 Q\<^isub>2 S\<^isub>2 \<Delta> \<Gamma> X)
--{* \begin{minipage}[t]{0.9\textwidth}
- In this case the left-hand derivation is @{term "(\<Delta>@[(X,Q)]@\<Gamma>) \<turnstile> Q\<^isub>1 \<rightarrow> Q\<^isub>2 <: S\<^isub>1 \<rightarrow> S\<^isub>2"}
+ In this case the left-hand derivation is @{term "(\<Delta>@[(TVarB X Q)]@\<Gamma>) \<turnstile> Q\<^isub>1 \<rightarrow> Q\<^isub>2 <: S\<^isub>1 \<rightarrow> S\<^isub>2"}
and the proof is trivial.\end{minipage}*}
- thus "(\<Delta>@[(X,P)]@\<Gamma>) \<turnstile> Q\<^isub>1 \<rightarrow> Q\<^isub>2 <: S\<^isub>1 \<rightarrow> S\<^isub>2" by blast
+ thus "(\<Delta>@[(TVarB X P)]@\<Gamma>) \<turnstile> Q\<^isub>1 \<rightarrow> Q\<^isub>2 <: S\<^isub>1 \<rightarrow> S\<^isub>2" by blast
next
- case (S_Forall _ T\<^isub>1 S\<^isub>1 Y S\<^isub>2 T\<^isub>2 \<Delta> \<Gamma> X)
+ case (SA_all \<Gamma>' T\<^isub>1 S\<^isub>1 Y S\<^isub>2 T\<^isub>2 \<Delta> \<Gamma> X)
--{* \begin{minipage}[t]{0.9\textwidth}
- In this case the left-hand derivation is @{text "(\<Delta>@[(X,Q)]@\<Gamma>) \<turnstile> \<forall>[Y<:S\<^isub>1].S\<^isub>2 <: \<forall>[Y<:T\<^isub>1].T\<^isub>2"}
- and therfore we know that the binder @{term Y} is fresh for @{term "\<Delta>@[(X,Q)]@\<Gamma>"}. By
- the inner induction hypothesis we have that @{term "(\<Delta>@[(X,P)]@\<Gamma>) \<turnstile> T\<^isub>1 <: S\<^isub>1"} and
- @{term "((Y,T\<^isub>1)#\<Delta>@[(X,P)]@\<Gamma>) \<turnstile> S\<^isub>2 <: T\<^isub>2"}. Since @{term P} is a subtype of @{term Q}
+ In this case the left-hand derivation is @{term "(\<Delta>@[(TVarB X Q)]@\<Gamma>) \<turnstile> (\<forall>Y<:S\<^isub>1. S\<^isub>2) <: (\<forall>Y<:T\<^isub>1. T\<^isub>2)"}
+ and therfore we know that the binder @{term Y} is fresh for @{term "\<Delta>@[(TVarB X Q)]@\<Gamma>"}. By
+ the inner induction hypothesis we have that @{term "(\<Delta>@[(TVarB X P)]@\<Gamma>) \<turnstile> T\<^isub>1 <: S\<^isub>1"} and
+ @{term "((TVarB Y T\<^isub>1)#\<Delta>@[(TVarB X P)]@\<Gamma>) \<turnstile> S\<^isub>2 <: T\<^isub>2"}. Since @{term P} is a subtype of @{term Q}
we can infer that @{term Y} is fresh for @{term P} and thus also fresh for
- @{term "\<Delta>@[(X,P)]@\<Gamma>"}. We can then conclude by applying rule @{text "S_Forall"}.
+ @{term "\<Delta>@[(TVarB X P)]@\<Gamma>"}. We can then conclude by applying rule @{text "S_Forall"}.
\end{minipage}*}
- hence IH_inner\<^isub>1: "(\<Delta>@[(X,P)]@\<Gamma>) \<turnstile> T\<^isub>1 <: S\<^isub>1"
- and IH_inner\<^isub>2: "((Y,T\<^isub>1)#\<Delta>@[(X,P)]@\<Gamma>) \<turnstile> S\<^isub>2 <: T\<^isub>2"
- and lh_drv_prm: "Y\<sharp>(\<Delta>@[(X,Q)]@\<Gamma>)" by force+
- have rh_drv: "\<Gamma> \<turnstile> P <: Q" by fact
- hence "Y\<sharp>P" using lh_drv_prm by (simp only: fresh_list_append subtype_implies_fresh)
- hence "Y\<sharp>(\<Delta>@[(X,P)]@\<Gamma>)" using lh_drv_prm
- by (simp add: fresh_list_append fresh_list_cons fresh_prod)
+ hence rh_drv: "\<Gamma> \<turnstile> P <: Q"
+ and IH_inner\<^isub>1: "(\<Delta>@[(TVarB X P)]@\<Gamma>) \<turnstile> T\<^isub>1 <: S\<^isub>1"
+ and "TVarB Y T\<^isub>1 # \<Gamma>' = ((TVarB Y T\<^isub>1)#\<Delta>) @ [TVarB X Q] @ \<Gamma>" by auto
+ moreover have " \<lbrakk>\<Gamma>\<turnstile>P<:Q; TVarB Y T\<^isub>1 # \<Gamma>' = ((TVarB Y T\<^isub>1)#\<Delta>) @ [TVarB X Q] @ \<Gamma>\<rbrakk> \<Longrightarrow> (((TVarB Y T\<^isub>1)#\<Delta>) @ [TVarB X P] @ \<Gamma>)\<turnstile>S\<^isub>2<:T\<^isub>2" by fact
+ ultimately have IH_inner\<^isub>2: "(((TVarB Y T\<^isub>1)#\<Delta>) @ [TVarB X P] @ \<Gamma>)\<turnstile>S\<^isub>2<:T\<^isub>2" by auto
with IH_inner\<^isub>1 IH_inner\<^isub>2
- show "(\<Delta>@[(X,P)]@\<Gamma>) \<turnstile> \<forall>[Y<:S\<^isub>1].S\<^isub>2 <: \<forall>[Y<:T\<^isub>1].T\<^isub>2" by (simp add: subtype_of.S_Forall)
+ show "(\<Delta>@[(TVarB X P)]@\<Gamma>) \<turnstile> (\<forall>Y<:S\<^isub>1. S\<^isub>2) <: (\<forall>Y<:T\<^isub>1. T\<^isub>2)" by (simp add: subtype_of.SA_all)
qed
}
qed
-end
\ No newline at end of file
+section {* Typing *}
+
+inductive
+ typing :: "env \<Rightarrow> trm \<Rightarrow> ty \<Rightarrow> bool" ("_ \<turnstile> _ : _" [60,60,60] 60)
+where
+ T_Var[intro]: "\<lbrakk> VarB x T \<in> set \<Gamma>; \<turnstile> \<Gamma> ok \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Var x : T"
+| T_App[intro]: "\<lbrakk> \<Gamma> \<turnstile> t\<^isub>1 : T\<^isub>1 \<rightarrow> T\<^isub>2; \<Gamma> \<turnstile> t\<^isub>2 : T\<^isub>1 \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> t\<^isub>1 \<cdot> t\<^isub>2 : T\<^isub>2"
+| T_Abs[intro]: "\<lbrakk> VarB x T\<^isub>1 # \<Gamma> \<turnstile> t\<^isub>2 : T\<^isub>2 \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> (\<lambda>x:T\<^isub>1. t\<^isub>2) : T\<^isub>1 \<rightarrow> T\<^isub>2"
+| T_Sub[intro]: "\<lbrakk> \<Gamma> \<turnstile> t : S; \<Gamma> \<turnstile> S <: T \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> t : T"
+| T_TAbs[intro]:"\<lbrakk> TVarB X T\<^isub>1 # \<Gamma> \<turnstile> t\<^isub>2 : T\<^isub>2 \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> (\<lambda>X<:T\<^isub>1. t\<^isub>2) : (\<forall>X<:T\<^isub>1. T\<^isub>2)"
+| T_TApp[intro]:"\<lbrakk> X \<sharp> (\<Gamma>, t\<^isub>1, T\<^isub>2); \<Gamma> \<turnstile> t\<^isub>1 : (\<forall>X<:T\<^isub>1\<^isub>1. T\<^isub>1\<^isub>2); \<Gamma> \<turnstile> T\<^isub>2 <: T\<^isub>1\<^isub>1 \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> t\<^isub>1 \<cdot>\<^sub>\<tau> T\<^isub>2 : (T\<^isub>1\<^isub>2[X \<mapsto> T\<^isub>2]\<^sub>\<tau>)"
+
+equivariance typing
+
+lemma better_T_TApp:
+ assumes H1: "\<Gamma> \<turnstile> t\<^isub>1 : (\<forall>X<:T11. T12)"
+ and H2: "\<Gamma> \<turnstile> T2 <: T11"
+ shows "\<Gamma> \<turnstile> t\<^isub>1 \<cdot>\<^sub>\<tau> T2 : (T12[X \<mapsto> T2]\<^sub>\<tau>)"
+proof -
+ obtain Y::tyvrs where Y: "Y \<sharp> (X, T12, \<Gamma>, t\<^isub>1, T2)"
+ by (rule exists_fresh) (rule fin_supp)
+ then have "Y \<sharp> (\<Gamma>, t\<^isub>1, T2)" by simp
+ moreover from Y have "(\<forall>X<:T11. T12) = (\<forall>Y<:T11. [(Y, X)] \<bullet> T12)"
+ by (auto simp add: ty.inject alpha' fresh_prod fresh_atm)
+ with H1 have "\<Gamma> \<turnstile> t\<^isub>1 : (\<forall>Y<:T11. [(Y, X)] \<bullet> T12)" by simp
+ ultimately have "\<Gamma> \<turnstile> t\<^isub>1 \<cdot>\<^sub>\<tau> T2 : (([(Y, X)] \<bullet> T12)[Y \<mapsto> T2]\<^sub>\<tau>)" using H2
+ by (rule T_TApp)
+ with Y show ?thesis by (simp add: type_subst_rename)
+qed
+
+lemma typing_ok:
+ assumes "\<Gamma> \<turnstile> t : T"
+ shows "\<turnstile> \<Gamma> ok"
+using assms by (induct, auto)
+
+nominal_inductive typing
+ by (auto dest!: typing_ok intro: closed_in_fresh fresh_domain
+ simp: abs_fresh fresh_prod fresh_atm freshs valid_ty_domain_fresh fresh_trm_domain)
+
+lemma ok_imp_VarB_closed_in:
+ assumes ok: "\<turnstile> \<Gamma> ok"
+ shows "VarB x T \<in> set \<Gamma> \<Longrightarrow> T closed_in \<Gamma>" using ok
+ by induct (auto simp add: binding.inject closed_in_def)
+
+lemma tyvrs_of_subst: "tyvrs_of (B[X \<mapsto> T]\<^sub>b) = tyvrs_of B"
+ by (nominal_induct B rule: binding.strong_induct) simp_all
+
+lemma ty_domain_subst: "ty_domain (\<Gamma>[X \<mapsto> T]\<^sub>e) = ty_domain \<Gamma>"
+ by (induct \<Gamma>) (simp_all add: tyvrs_of_subst)
+
+lemma vrs_of_subst: "vrs_of (B[X \<mapsto> T]\<^sub>b) = vrs_of B"
+ by (nominal_induct B rule: binding.strong_induct) simp_all
+
+lemma trm_domain_subst: "trm_domain (\<Gamma>[X \<mapsto> T]\<^sub>e) = trm_domain \<Gamma>"
+ by (induct \<Gamma>) (simp_all add: vrs_of_subst)
+
+lemma subst_closed_in:
+ "T closed_in (\<Delta> @ TVarB X S # \<Gamma>) \<Longrightarrow> U closed_in \<Gamma> \<Longrightarrow> T[X \<mapsto> U]\<^sub>\<tau> closed_in (\<Delta>[X \<mapsto> U]\<^sub>e @ \<Gamma>)"
+ apply (nominal_induct T avoiding: X U \<Gamma> rule: ty.strong_induct)
+ apply (simp add: closed_in_def ty.supp supp_atm domains_append ty_domain_subst)
+ apply blast
+ apply (simp add: closed_in_def ty.supp)
+ apply (simp add: closed_in_def ty.supp)
+ apply (simp add: closed_in_def ty.supp abs_supp)
+ apply (drule_tac x = X in meta_spec)
+ apply (drule_tac x = U in meta_spec)
+ apply (drule_tac x = "(TVarB tyvrs ty2) # \<Gamma>" in meta_spec)
+ apply (simp add: domains_append ty_domain_subst)
+ apply blast
+ done
+
+lemmas subst_closed_in' = subst_closed_in [where \<Delta>="[]", simplified]
+
+lemma typing_closed_in:
+ assumes "\<Gamma> \<turnstile> t : T"
+ shows "T closed_in \<Gamma>"
+using assms
+proof induct
+ case (T_Var x T \<Gamma>)
+ from `\<turnstile> \<Gamma> ok` and `VarB x T \<in> set \<Gamma>`
+ show ?case by (rule ok_imp_VarB_closed_in)
+next
+ case (T_App \<Gamma> t\<^isub>1 T\<^isub>1 T\<^isub>2 t\<^isub>2)
+ then show ?case by (auto simp add: ty.supp closed_in_def)
+next
+ case (T_Abs x T\<^isub>1 \<Gamma> t\<^isub>2 T\<^isub>2)
+ from `VarB x T\<^isub>1 # \<Gamma> \<turnstile> t\<^isub>2 : T\<^isub>2`
+ have "T\<^isub>1 closed_in \<Gamma>" by (auto dest: typing_ok)
+ with T_Abs show ?case by (auto simp add: ty.supp closed_in_def)
+next
+ case (T_Sub \<Gamma> t S T)
+ from `\<Gamma> \<turnstile> S <: T` show ?case by (simp add: subtype_implies_closed)
+next
+ case (T_TAbs X T\<^isub>1 \<Gamma> t\<^isub>2 T\<^isub>2)
+ from `TVarB X T\<^isub>1 # \<Gamma> \<turnstile> t\<^isub>2 : T\<^isub>2`
+ have "T\<^isub>1 closed_in \<Gamma>" by (auto dest: typing_ok)
+ with T_TAbs show ?case by (auto simp add: ty.supp closed_in_def abs_supp)
+next
+ case (T_TApp X \<Gamma> t\<^isub>1 T2 T11 T12)
+ then have "T12 closed_in (TVarB X T11 # \<Gamma>)"
+ by (auto simp add: closed_in_def ty.supp abs_supp)
+ moreover from T_TApp have "T2 closed_in \<Gamma>"
+ by (simp add: subtype_implies_closed)
+ ultimately show ?case by (rule subst_closed_in')
+qed
+
+
+subsection {* Evaluation *}
+
+inductive
+ val :: "trm \<Rightarrow> bool"
+where
+ Abs[intro]: "val (\<lambda>x:T. t)"
+| TAbs[intro]: "val (\<lambda>X<:T. t)"
+
+equivariance val
+
+inductive_cases val_inv_auto[elim]:
+ "val (Var x)"
+ "val (t1 \<cdot> t2)"
+ "val (t1 \<cdot>\<^sub>\<tau> t2)"
+
+inductive
+ eval :: "trm \<Rightarrow> trm \<Rightarrow> bool" ("_ \<longmapsto> _" [60,60] 60)
+where
+ E_Abs : "\<lbrakk> x \<sharp> v\<^isub>2; val v\<^isub>2 \<rbrakk> \<Longrightarrow> (\<lambda>x:T\<^isub>1\<^isub>1. t\<^isub>1\<^isub>2) \<cdot> v\<^isub>2 \<longmapsto> t\<^isub>1\<^isub>2[x \<mapsto> v\<^isub>2]"
+| E_App1 [intro]: "t \<longmapsto> t' \<Longrightarrow> t \<cdot> u \<longmapsto> t' \<cdot> u"
+| E_App2 [intro]: "\<lbrakk> val v; t \<longmapsto> t' \<rbrakk> \<Longrightarrow> v \<cdot> t \<longmapsto> v \<cdot> t'"
+| E_TAbs : "X \<sharp> (T\<^isub>1\<^isub>1, T\<^isub>2) \<Longrightarrow> (\<lambda>X<:T\<^isub>1\<^isub>1. t\<^isub>1\<^isub>2) \<cdot>\<^sub>\<tau> T\<^isub>2 \<longmapsto> t\<^isub>1\<^isub>2[X \<mapsto>\<^sub>\<tau> T\<^isub>2]"
+| E_TApp [intro]: "t \<longmapsto> t' \<Longrightarrow> t \<cdot>\<^sub>\<tau> T \<longmapsto> t' \<cdot>\<^sub>\<tau> T"
+
+lemma better_E_Abs[intro]:
+ assumes H: "val v2"
+ shows "(\<lambda>x:T11. t12) \<cdot> v2 \<longmapsto> t12[x \<mapsto> v2]"
+proof -
+ obtain y::vrs where y: "y \<sharp> (x, t12, v2)" by (rule exists_fresh) (rule fin_supp)
+ then have "y \<sharp> v2" by simp
+ then have "(\<lambda>y:T11. [(y, x)] \<bullet> t12) \<cdot> v2 \<longmapsto> ([(y, x)] \<bullet> t12)[y \<mapsto> v2]" using H
+ by (rule E_Abs)
+ moreover from y have "(\<lambda>x:T11. t12) \<cdot> v2 = (\<lambda>y:T11. [(y, x)] \<bullet> t12) \<cdot> v2"
+ by (auto simp add: trm.inject alpha' fresh_prod fresh_atm)
+ ultimately have "(\<lambda>x:T11. t12) \<cdot> v2 \<longmapsto> ([(y, x)] \<bullet> t12)[y \<mapsto> v2]"
+ by simp
+ with y show ?thesis by (simp add: subst_trm_rename)
+qed
+
+lemma better_E_TAbs[intro]: "(\<lambda>X<:T11. t12) \<cdot>\<^sub>\<tau> T2 \<longmapsto> t12[X \<mapsto>\<^sub>\<tau> T2]"
+proof -
+ obtain Y::tyvrs where Y: "Y \<sharp> (X, t12, T11, T2)" by (rule exists_fresh) (rule fin_supp)
+ then have "Y \<sharp> (T11, T2)" by simp
+ then have "(\<lambda>Y<:T11. [(Y, X)] \<bullet> t12) \<cdot>\<^sub>\<tau> T2 \<longmapsto> ([(Y, X)] \<bullet> t12)[Y \<mapsto>\<^sub>\<tau> T2]"
+ by (rule E_TAbs)
+ moreover from Y have "(\<lambda>X<:T11. t12) \<cdot>\<^sub>\<tau> T2 = (\<lambda>Y<:T11. [(Y, X)] \<bullet> t12) \<cdot>\<^sub>\<tau> T2"
+ by (auto simp add: trm.inject alpha' fresh_prod fresh_atm)
+ ultimately have "(\<lambda>X<:T11. t12) \<cdot>\<^sub>\<tau> T2 \<longmapsto> ([(Y, X)] \<bullet> t12)[Y \<mapsto>\<^sub>\<tau> T2]"
+ by simp
+ with Y show ?thesis by (simp add: subst_trm_ty_rename)
+qed
+
+equivariance eval
+
+nominal_inductive eval
+ by (simp_all add: abs_fresh ty_vrs_fresh subst_trm_fresh_tyvar
+ subst_trm_fresh_var subst_trm_ty_fresh')
+
+inductive_cases eval_inv_auto[elim]:
+ "Var x \<longmapsto> t'"
+ "(\<lambda>x:T. t) \<longmapsto> t'"
+ "(\<lambda>X<:T. t) \<longmapsto> t'"
+
+lemma ty_domain_cons:
+ shows "ty_domain (\<Gamma>@[VarB X Q]@\<Delta>) = ty_domain (\<Gamma>@\<Delta>)"
+by (induct \<Gamma>, auto)
+
+lemma closed_in_cons:
+ assumes "S closed_in (\<Gamma> @ VarB X Q # \<Delta>)"
+ shows "S closed_in (\<Gamma>@\<Delta>)"
+using assms ty_domain_cons closed_in_def by auto
+
+lemma closed_in_weaken: "T closed_in (\<Delta> @ \<Gamma>) \<Longrightarrow> T closed_in (\<Delta> @ B # \<Gamma>)"
+ by (auto simp add: closed_in_def domains_append)
+
+lemma closed_in_weaken': "T closed_in \<Gamma> \<Longrightarrow> T closed_in (\<Delta> @ \<Gamma>)"
+ by (auto simp add: closed_in_def domains_append)
+
+lemma valid_subst:
+ assumes ok: "\<turnstile> (\<Delta> @ TVarB X Q # \<Gamma>) ok"
+ and closed: "P closed_in \<Gamma>"
+ shows "\<turnstile> (\<Delta>[X \<mapsto> P]\<^sub>e @ \<Gamma>) ok" using ok closed
+ apply (induct \<Delta>)
+ apply simp_all
+ apply (erule validE)
+ apply assumption
+ apply (erule validE)
+ apply simp
+ apply (rule valid_consT)
+ apply assumption
+ apply (simp add: domains_append ty_domain_subst)
+ apply (simp add: fresh_fin_insert [OF pt_tyvrs_inst at_tyvrs_inst fs_tyvrs_inst] finite_domains)
+ apply (rule_tac S=Q in subst_closed_in')
+ apply (simp add: closed_in_def domains_append ty_domain_subst)
+ apply (simp add: closed_in_def domains_append)
+ apply blast
+ apply simp
+ apply (rule valid_cons)
+ apply assumption
+ apply (simp add: domains_append trm_domain_subst)
+ apply (rule_tac S=Q in subst_closed_in')
+ apply (simp add: closed_in_def domains_append ty_domain_subst)
+ apply (simp add: closed_in_def domains_append)
+ apply blast
+ done
+
+lemma ty_domain_vrs:
+ shows "ty_domain (G @ [VarB x Q] @ D) = ty_domain (G @ D)"
+by (induct G, auto)
+
+lemma valid_cons':
+ assumes "\<turnstile> (\<Gamma> @ VarB x Q # \<Delta>) ok"
+ shows "\<turnstile> (\<Gamma> @ \<Delta>) ok"
+ using assms
+proof (induct \<Gamma>' \<equiv> "\<Gamma> @ VarB x Q # \<Delta>" arbitrary: \<Gamma> \<Delta>)
+ case valid_nil
+ have "[] = \<Gamma> @ VarB x Q # \<Delta>" by fact
+ then have "False" by auto
+ then show ?case by auto
+next
+ case (valid_consT G X T)
+ then show ?case
+ proof (cases \<Gamma>)
+ case Nil
+ with valid_consT show ?thesis by simp
+ next
+ case (Cons b bs)
+ with valid_consT
+ have "\<turnstile> (bs @ \<Delta>) ok" by simp
+ moreover from Cons and valid_consT have "X \<sharp> ty_domain (bs @ \<Delta>)"
+ by (simp add: domains_append)
+ moreover from Cons and valid_consT have "T closed_in (bs @ \<Delta>)"
+ by (simp add: closed_in_def domains_append)
+ ultimately have "\<turnstile> (TVarB X T # bs @ \<Delta>) ok"
+ by (rule valid_rel.valid_consT)
+ with Cons and valid_consT show ?thesis by simp
+ qed
+next
+ case (valid_cons G x T)
+ then show ?case
+ proof (cases \<Gamma>)
+ case Nil
+ with valid_cons show ?thesis by simp
+ next
+ case (Cons b bs)
+ with valid_cons
+ have "\<turnstile> (bs @ \<Delta>) ok" by simp
+ moreover from Cons and valid_cons have "x \<sharp> trm_domain (bs @ \<Delta>)"
+ by (simp add: domains_append finite_domains
+ fresh_fin_insert [OF pt_vrs_inst at_vrs_inst fs_vrs_inst])
+ moreover from Cons and valid_cons have "T closed_in (bs @ \<Delta>)"
+ by (simp add: closed_in_def domains_append)
+ ultimately have "\<turnstile> (VarB x T # bs @ \<Delta>) ok"
+ by (rule valid_rel.valid_cons)
+ with Cons and valid_cons show ?thesis by simp
+ qed
+qed
+
+text {* A.5(6) *}
+
+lemma type_weaken:
+ assumes "(\<Delta>@\<Gamma>) \<turnstile> t : T"
+ and "\<turnstile> (\<Delta> @ B # \<Gamma>) ok"
+ shows "(\<Delta> @ B # \<Gamma>) \<turnstile> t : T"
+using assms
+proof(nominal_induct \<Gamma>'\<equiv> "\<Delta> @ \<Gamma>" t T avoiding: \<Delta> \<Gamma> B rule: typing.strong_induct)
+ case (T_Var x' T \<Gamma>' \<Gamma>'' \<Delta>')
+ then show ?case by auto
+next
+ case (T_App \<Gamma> t\<^isub>1 T\<^isub>1 T\<^isub>2 t\<^isub>2 \<Gamma> \<Delta>)
+ then show ?case by force
+next
+ case (T_Abs y T\<^isub>1 \<Gamma>' t\<^isub>2 T\<^isub>2 \<Delta> \<Gamma>)
+ then have "VarB y T\<^isub>1 # \<Delta> @ \<Gamma> \<turnstile> t\<^isub>2 : T\<^isub>2" by simp
+ then have closed: "T\<^isub>1 closed_in (\<Delta> @ \<Gamma>)"
+ by (auto dest: typing_ok)
+ have "\<turnstile> (VarB y T\<^isub>1 # \<Delta> @ B # \<Gamma>) ok"
+ apply (rule valid_cons)
+ apply (rule T_Abs)
+ apply (simp add: domains_append
+ fresh_fin_insert [OF pt_vrs_inst at_vrs_inst fs_vrs_inst]
+ fresh_fin_union [OF pt_vrs_inst at_vrs_inst fs_vrs_inst]
+ finite_domains finite_vrs fresh_vrs_of T_Abs fresh_trm_domain)
+ apply (rule closed_in_weaken)
+ apply (rule closed)
+ done
+ then have "\<turnstile> ((VarB y T\<^isub>1 # \<Delta>) @ B # \<Gamma>) ok" by simp
+ then have "(VarB y T\<^isub>1 # \<Delta>) @ B # \<Gamma> \<turnstile> t\<^isub>2 : T\<^isub>2"
+ by (rule T_Abs) (simp add: T_Abs)
+ then have "VarB y T\<^isub>1 # \<Delta> @ B # \<Gamma> \<turnstile> t\<^isub>2 : T\<^isub>2" by simp
+ then show ?case by (rule typing.T_Abs)
+next
+ case (T_Sub \<Gamma>' t S T \<Delta> \<Gamma>)
+ from `\<turnstile> (\<Delta> @ B # \<Gamma>) ok` and `\<Gamma>' = \<Delta> @ \<Gamma>`
+ have "\<Delta> @ B # \<Gamma> \<turnstile> t : S" by (rule T_Sub)
+ moreover from `\<Gamma>'\<turnstile>S<:T` and `\<turnstile> (\<Delta> @ B # \<Gamma>) ok`
+ have "(\<Delta> @ B # \<Gamma>)\<turnstile>S<:T"
+ by (rule weakening) (simp add: extends_def T_Sub)
+ ultimately show ?case by (rule typing.T_Sub)
+next
+ case (T_TAbs X T\<^isub>1 \<Gamma>' t\<^isub>2 T\<^isub>2 \<Delta> \<Gamma>)
+ then have "TVarB X T\<^isub>1 # \<Delta> @ \<Gamma> \<turnstile> t\<^isub>2 : T\<^isub>2" by simp
+ then have closed: "T\<^isub>1 closed_in (\<Delta> @ \<Gamma>)"
+ by (auto dest: typing_ok)
+ have "\<turnstile> (TVarB X T\<^isub>1 # \<Delta> @ B # \<Gamma>) ok"
+ apply (rule valid_consT)
+ apply (rule T_TAbs)
+ apply (simp add: domains_append
+ fresh_fin_insert [OF pt_tyvrs_inst at_tyvrs_inst fs_tyvrs_inst]
+ fresh_fin_union [OF pt_tyvrs_inst at_tyvrs_inst fs_tyvrs_inst]
+ finite_domains finite_vrs tyvrs_fresh T_TAbs fresh_domain)
+ apply (rule closed_in_weaken)
+ apply (rule closed)
+ done
+ then have "\<turnstile> ((TVarB X T\<^isub>1 # \<Delta>) @ B # \<Gamma>) ok" by simp
+ then have "(TVarB X T\<^isub>1 # \<Delta>) @ B # \<Gamma> \<turnstile> t\<^isub>2 : T\<^isub>2"
+ by (rule T_TAbs) (simp add: T_TAbs)
+ then have "TVarB X T\<^isub>1 # \<Delta> @ B # \<Gamma> \<turnstile> t\<^isub>2 : T\<^isub>2" by simp
+ then show ?case by (rule typing.T_TAbs)
+next
+ case (T_TApp X \<Gamma>' t\<^isub>1 T2 T11 T12 \<Delta> \<Gamma>)
+ have "\<Delta> @ B # \<Gamma> \<turnstile> t\<^isub>1 : (\<forall>X<:T11. T12)"
+ by (rule T_TApp)+
+ moreover from `\<Gamma>'\<turnstile>T2<:T11` and `\<turnstile> (\<Delta> @ B # \<Gamma>) ok`
+ have "(\<Delta> @ B # \<Gamma>)\<turnstile>T2<:T11"
+ by (rule weakening) (simp add: extends_def T_TApp)
+ ultimately show ?case by (rule better_T_TApp)
+qed
+
+lemma type_weaken':
+ "\<Gamma> \<turnstile> t : T \<Longrightarrow> \<turnstile> (\<Delta>@\<Gamma>) ok \<Longrightarrow> (\<Delta>@\<Gamma>) \<turnstile> t : T"
+ apply (induct \<Delta>)
+ apply simp_all
+ apply (erule validE)
+ apply (insert type_weaken [of "[]", simplified])
+ apply simp_all
+ done
+
+text {* A.6 *}
+
+lemma strengthening:
+ assumes "(\<Gamma> @ VarB x Q # \<Delta>) \<turnstile> S <: T"
+ shows "(\<Gamma>@\<Delta>) \<turnstile> S <: T"
+ using assms
+proof (induct \<Gamma>' \<equiv> "\<Gamma> @ VarB x Q # \<Delta>" S T arbitrary: \<Gamma>)
+ case (SA_Top G' S G)
+ then have "\<turnstile> (G @ \<Delta>) ok" by (auto dest: valid_cons')
+ moreover have "S closed_in (G @ \<Delta>)" using SA_Top by (auto dest: closed_in_cons)
+ ultimately show ?case using subtype_of.SA_Top by auto
+next
+ case (SA_refl_TVar G X' G')
+ then have "\<turnstile> (G' @ VarB x Q # \<Delta>) ok" by simp
+ then have h1:"\<turnstile> (G' @ \<Delta>) ok" by (auto dest: valid_cons')
+ have "X' \<in> ty_domain (G' @ VarB x Q # \<Delta>)" using SA_refl_TVar by auto
+ then have h2:"X' \<in> ty_domain (G' @ \<Delta>)" using ty_domain_vrs by auto
+ show ?case using h1 h2 by auto
+next
+ case (SA_all G T1 S1 X S2 T2 G')
+ have ih1:"TVarB X T1 # G = (TVarB X T1 # G') @ VarB x Q # \<Delta> \<Longrightarrow> ((TVarB X T1 # G') @ \<Delta>)\<turnstile>S2<:T2" by fact
+ then have h1:"(TVarB X T1 # (G' @ \<Delta>))\<turnstile>S2<:T2" using SA_all by auto
+ have ih2:"G = G' @ VarB x Q # \<Delta> \<Longrightarrow> (G' @ \<Delta>)\<turnstile>T1<:S1" by fact
+ then have h2:"(G' @ \<Delta>)\<turnstile>T1<:S1" using SA_all by auto
+ then show ?case using h1 h2 by auto
+qed (auto)
+
+lemma narrow_type: -- {* A.7 *}
+ assumes H: "\<Delta> @ (TVarB X Q) # \<Gamma> \<turnstile> t : T"
+ shows "\<Gamma> \<turnstile> P <: Q \<Longrightarrow> \<Delta> @ (TVarB X P) # \<Gamma> \<turnstile> t : T"
+ using H
+ proof (nominal_induct \<Gamma>' \<equiv> "\<Delta> @ (TVarB X Q) # \<Gamma>" t T avoiding: P arbitrary: \<Delta> rule: typing.strong_induct)
+ case (T_Var x T G P D)
+ then have "VarB x T \<in> set (D @ TVarB X P # \<Gamma>)"
+ and "\<turnstile> (D @ TVarB X P # \<Gamma>) ok"
+ by (auto intro: replace_type dest!: subtype_implies_closed)
+ then show ?case by auto
+ next
+ case (T_App G t1 T1 T2 t2 P D)
+ then show ?case by force
+ next
+ case (T_Abs x T1 G t2 T2 P D)
+ then show ?case by (fastsimp dest: typing_ok)
+ next
+ case (T_Sub G t S T D)
+ then show ?case using subtype_narrow by fastsimp
+ next
+ case (T_TAbs X' T1 G t2 T2 P D)
+ then show ?case by (fastsimp dest: typing_ok)
+ next
+ case (T_TApp X' G t1 T2 T11 T12 P D)
+ then have "D @ TVarB X P # \<Gamma> \<turnstile> t1 : Forall X' T12 T11" by fastsimp
+ moreover have "(D @ [TVarB X Q] @ \<Gamma>) \<turnstile> T2<:T11" using T_TApp by auto
+ then have "(D @ [TVarB X P] @ \<Gamma>) \<turnstile> T2<:T11" using `\<Gamma>\<turnstile>P<:Q`
+ by (rule subtype_narrow)
+ moreover from T_TApp have "X' \<sharp> (D @ TVarB X P # \<Gamma>, t1, T2)"
+ by (simp add: fresh_list_append fresh_list_cons fresh_prod)
+ ultimately show ?case by auto
+qed
+
+subsection {* Substitution lemmas *}
+
+subsubsection {* Substition Preserves Typing *}
+
+theorem subst_type: -- {* A.8 *}
+ assumes H: "(\<Delta> @ (VarB x U) # \<Gamma>) \<turnstile> t : T"
+ shows "\<Gamma> \<turnstile> u : U \<Longrightarrow> \<Delta> @ \<Gamma> \<turnstile> t[x \<mapsto> u] : T" using H
+ proof (nominal_induct \<Gamma>' \<equiv> "\<Delta> @ (VarB x U) # \<Gamma>" t T avoiding: x u arbitrary: \<Delta> rule: typing.strong_induct)
+ case (T_Var y T G x u D)
+ show ?case
+ proof (cases "x = y")
+ assume eq:"x=y"
+ then have "T=U" using T_Var uniqueness_of_ctxt' by auto
+ then show ?case using eq T_Var
+ by (auto intro: type_weaken' dest: valid_cons')
+ next
+ assume "x\<noteq>y"
+ then show ?case using T_Var
+ by (auto simp add:binding.inject dest: valid_cons')
+ qed
+ next
+ case (T_App G t1 T1 T2 t2 x u D)
+ then show ?case by force
+ next
+ case (T_Abs y T1 G t2 T2 x u D)
+ then show ?case by force
+ next
+ case (T_Sub G t S T x u D)
+ then have "D @ \<Gamma> \<turnstile> t[x \<mapsto> u] : S" by auto
+ moreover have "(D @ \<Gamma>) \<turnstile> S<:T" using T_Sub by (auto dest: strengthening)
+ ultimately show ?case by auto
+ next
+ case (T_TAbs X T1 G t2 T2 x u D)
+ from `TVarB X T1 # G \<turnstile> t2 : T2` have "X \<sharp> T1"
+ by (auto simp add: valid_ty_domain_fresh dest: typing_ok intro!: closed_in_fresh)
+ with `X \<sharp> u` and T_TAbs show ?case by fastsimp
+ next
+ case (T_TApp X G t1 T2 T11 T12 x u D)
+ then have "(D@\<Gamma>) \<turnstile>T2<:T11" using T_TApp by (auto dest: strengthening)
+ then show "((D @ \<Gamma>) \<turnstile> ((t1 \<cdot>\<^sub>\<tau> T2)[x \<mapsto> u]) : (T12[X \<mapsto> T2]\<^sub>\<tau>))" using T_TApp
+ by (force simp add: fresh_prod fresh_list_append fresh_list_cons subst_trm_fresh_tyvar)
+qed
+
+subsubsection {* Type Substitution Preserves Subtyping *}
+
+lemma substT_subtype: -- {* A.10 *}
+ assumes H: "(\<Delta> @ ((TVarB X Q) # \<Gamma>)) \<turnstile> S <: T"
+ shows "\<Gamma> \<turnstile> P <: Q \<Longrightarrow> (\<Delta>[X \<mapsto> P]\<^sub>e @ \<Gamma>) \<turnstile> S[X \<mapsto> P]\<^sub>\<tau> <: T[X \<mapsto> P]\<^sub>\<tau>"
+ using H
+proof (nominal_induct \<Gamma>' \<equiv> "\<Delta> @ TVarB X Q # \<Gamma>" S T avoiding: X P arbitrary: \<Delta> rule: subtype_of.strong_induct)
+ case (SA_Top G S X P D)
+ then have "\<turnstile> (D @ TVarB X Q # \<Gamma>) ok" by simp
+ moreover have closed: "P closed_in \<Gamma>" using SA_Top subtype_implies_closed by auto
+ ultimately have "\<turnstile> (D[X \<mapsto> P]\<^sub>e @ \<Gamma>) ok" by (rule valid_subst)
+ moreover from SA_Top have "S closed_in (D @ TVarB X Q # \<Gamma>)" by simp
+ then have "S[X \<mapsto> P]\<^sub>\<tau> closed_in (D[X \<mapsto> P]\<^sub>e @ \<Gamma>)" using closed by (rule subst_closed_in)
+ ultimately show ?case by auto
+next
+ case (SA_trans_TVar Y S G T X P D)
+ have h:"G\<turnstile>S<:T" by fact
+ then have ST: "(D[X \<mapsto> P]\<^sub>e @ \<Gamma>) \<turnstile> S[X \<mapsto> P]\<^sub>\<tau> <: T[X \<mapsto> P]\<^sub>\<tau>" using SA_trans_TVar by auto
+ from `G\<turnstile>S<:T` have G_ok: "\<turnstile> G ok" by (rule subtype_implies_ok)
+ from G_ok and SA_trans_TVar have X\<Gamma>_ok: "\<turnstile> (TVarB X Q # \<Gamma>) ok"
+ by (auto intro: validE_append)
+ show "(D[X \<mapsto> P]\<^sub>e @ \<Gamma>) \<turnstile> Tvar Y[X \<mapsto> P]\<^sub>\<tau><:T[X \<mapsto> P]\<^sub>\<tau>"
+ proof (cases "X = Y")
+ assume eq: "X = Y"
+ from eq and SA_trans_TVar have "TVarB Y Q \<in> set G" by simp
+ with G_ok have QS: "Q = S" using `TVarB Y S \<in> set G` by (rule uniqueness_of_ctxt)
+ from X\<Gamma>_ok have "X \<sharp> ty_domain \<Gamma>" and "Q closed_in \<Gamma>" by auto
+ then have XQ: "X \<sharp> Q" by (rule closed_in_fresh)
+ note `\<Gamma>\<turnstile>P<:Q`
+ moreover from ST have "\<turnstile> (D[X \<mapsto> P]\<^sub>e @ \<Gamma>) ok" by (rule subtype_implies_ok)
+ moreover have "(D[X \<mapsto> P]\<^sub>e @ \<Gamma>) extends \<Gamma>" by (simp add: extends_def)
+ ultimately have "(D[X \<mapsto> P]\<^sub>e @ \<Gamma>) \<turnstile> P<:Q" by (rule weakening)
+ with QS have "(D[X \<mapsto> P]\<^sub>e @ \<Gamma>) \<turnstile> P<:S" by simp
+ moreover from XQ and ST and QS have "(D[X \<mapsto> P]\<^sub>e @ \<Gamma>) \<turnstile> S<:T[X \<mapsto> P]\<^sub>\<tau>"
+ by (simp add: type_subst_identity)
+ ultimately have "(D[X \<mapsto> P]\<^sub>e @ \<Gamma>) \<turnstile> P<:T[X \<mapsto> P]\<^sub>\<tau>"
+ by (rule subtype_transitivity)
+ with eq show ?case by simp
+ next
+ assume neq: "X \<noteq> Y"
+ with SA_trans_TVar have "TVarB Y S \<in> set D \<or> TVarB Y S \<in> set \<Gamma>"
+ by (simp add: binding.inject)
+ then show ?case
+ proof
+ assume "TVarB Y S \<in> set D"
+ then have "TVarB Y (S[X \<mapsto> P]\<^sub>\<tau>) \<in> set (D[X \<mapsto> P]\<^sub>e)"
+ by (rule ctxt_subst_mem_TVarB)
+ then have "TVarB Y (S[X \<mapsto> P]\<^sub>\<tau>) \<in> set (D[X \<mapsto> P]\<^sub>e @ \<Gamma>)" by simp
+ with neq and ST show ?thesis by auto
+ next
+ assume Y: "TVarB Y S \<in> set \<Gamma>"
+ from X\<Gamma>_ok have "X \<sharp> ty_domain \<Gamma>" and "\<turnstile> \<Gamma> ok" by auto
+ then have "X \<sharp> \<Gamma>" by (simp add: valid_ty_domain_fresh)
+ with Y have "X \<sharp> S"
+ by (induct \<Gamma>) (auto simp add: fresh_list_nil fresh_list_cons)
+ with ST have "(D[X \<mapsto> P]\<^sub>e @ \<Gamma>)\<turnstile>S<:T[X \<mapsto> P]\<^sub>\<tau>"
+ by (simp add: type_subst_identity)
+ moreover from Y have "TVarB Y S \<in> set (D[X \<mapsto> P]\<^sub>e @ \<Gamma>)" by simp
+ ultimately show ?thesis using neq by auto
+ qed
+ qed
+next
+ case (SA_refl_TVar G Y X P D)
+ then have "\<turnstile> (D @ TVarB X Q # \<Gamma>) ok" by simp
+ moreover from SA_refl_TVar have closed: "P closed_in \<Gamma>"
+ by (auto dest: subtype_implies_closed)
+ ultimately have ok: "\<turnstile> (D[X \<mapsto> P]\<^sub>e @ \<Gamma>) ok" using valid_subst by auto
+ from closed have closed': "P closed_in (D[X \<mapsto> P]\<^sub>e @ \<Gamma>)"
+ by (simp add: closed_in_weaken')
+ show ?case
+ proof (cases "X = Y")
+ assume "X = Y"
+ with closed' and ok show ?thesis
+ by (auto intro: subtype_reflexivity)
+ next
+ assume neq: "X \<noteq> Y"
+ with SA_refl_TVar have "Y \<in> ty_domain (D[X \<mapsto> P]\<^sub>e @ \<Gamma>)"
+ by (simp add: ty_domain_subst domains_append)
+ with neq and ok show ?thesis by auto
+ qed
+next
+ case (SA_arrow G T1 S1 S2 T2 X P D)
+ then have h1:"(D[X \<mapsto> P]\<^sub>e @ \<Gamma>)\<turnstile>T1[X \<mapsto> P]\<^sub>\<tau><:S1[X \<mapsto> P]\<^sub>\<tau>" using SA_arrow by auto
+ from SA_arrow have h2:"(D[X \<mapsto> P]\<^sub>e @ \<Gamma>)\<turnstile>S2[X \<mapsto> P]\<^sub>\<tau><:T2[X \<mapsto> P]\<^sub>\<tau>" using SA_arrow by auto
+ show ?case using subtype_of.SA_arrow h1 h2 by auto
+next
+ case (SA_all G T1 S1 Y S2 T2 X P D)
+ then have Y: "Y \<sharp> ty_domain (D @ TVarB X Q # \<Gamma>)"
+ by (auto dest: subtype_implies_ok intro: fresh_domain)
+ moreover from SA_all have "S1 closed_in (D @ TVarB X Q # \<Gamma>)"
+ by (auto dest: subtype_implies_closed)
+ ultimately have S1: "Y \<sharp> S1" by (rule closed_in_fresh)
+ from SA_all have "T1 closed_in (D @ TVarB X Q # \<Gamma>)"
+ by (auto dest: subtype_implies_closed)
+ with Y have T1: "Y \<sharp> T1" by (rule closed_in_fresh)
+ with SA_all and S1 show ?case by force
+qed
+
+subsubsection {* Type Substitution Preserves Typing *}
+
+theorem substT_type: -- {* A.11 *}
+ assumes H: "(D @ TVarB X Q # G) \<turnstile> t : T"
+ shows "G \<turnstile> P <: Q \<Longrightarrow>
+ (D[X \<mapsto> P]\<^sub>e @ G) \<turnstile> t[X \<mapsto>\<^sub>\<tau> P] : T[X \<mapsto> P]\<^sub>\<tau>" using H
+proof (nominal_induct \<Gamma>'\<equiv>"(D @ TVarB X Q # G)" t T avoiding: X P arbitrary: D rule: typing.strong_induct)
+ case (T_Var x T G' X P D')
+ have "G\<turnstile>P<:Q" by fact
+ then have "P closed_in G" using subtype_implies_closed by auto
+ moreover have "\<turnstile> (D' @ TVarB X Q # G) ok" using T_Var by auto
+ ultimately have "\<turnstile> (D'[X \<mapsto> P]\<^sub>e @ G) ok" using valid_subst by auto
+ moreover have "VarB x T \<in> set (D' @ TVarB X Q # G)" using T_Var by auto
+ then have "VarB x T \<in> set D' \<or> VarB x T \<in> set G" by simp
+ then have "(VarB x (T[X \<mapsto> P]\<^sub>\<tau>)) \<in> set (D'[X \<mapsto> P]\<^sub>e @ G)"
+ proof
+ assume "VarB x T \<in> set D'"
+ then have "VarB x (T[X \<mapsto> P]\<^sub>\<tau>) \<in> set (D'[X \<mapsto> P]\<^sub>e)"
+ by (rule ctxt_subst_mem_VarB)
+ then show ?thesis by simp
+ next
+ assume x: "VarB x T \<in> set G"
+ from T_Var have ok: "\<turnstile> G ok" by (auto dest: subtype_implies_ok)
+ then have "X \<sharp> ty_domain G" using T_Var by (auto dest: validE_append)
+ with ok have "X \<sharp> G" by (simp add: valid_ty_domain_fresh)
+ moreover from x have "VarB x T \<in> set (D' @ G)" by simp
+ then have "VarB x (T[X \<mapsto> P]\<^sub>\<tau>) \<in> set ((D' @ G)[X \<mapsto> P]\<^sub>e)"
+ by (rule ctxt_subst_mem_VarB)
+ ultimately show ?thesis
+ by (simp add: ctxt_subst_append ctxt_subst_identity)
+ qed
+ ultimately show ?case by auto
+next
+ case (T_App G' t1 T1 T2 t2 X P D')
+ then have "D'[X \<mapsto> P]\<^sub>e @ G \<turnstile> t1[X \<mapsto>\<^sub>\<tau> P] : (T1 \<rightarrow> T2)[X \<mapsto> P]\<^sub>\<tau>" by auto
+ moreover from T_App have "D'[X \<mapsto> P]\<^sub>e @ G \<turnstile> t2[X \<mapsto>\<^sub>\<tau> P] : T1[X \<mapsto> P]\<^sub>\<tau>" by auto
+ ultimately show ?case by auto
+next
+ case (T_Abs x T1 G' t2 T2 X P D')
+ then show ?case by force
+next
+ case (T_Sub G' t S T X P D')
+ then show ?case using substT_subtype by force
+next
+ case (T_TAbs X' G' T1 t2 T2 X P D')
+ then have "X' \<sharp> ty_domain (D' @ TVarB X Q # G)"
+ and "G' closed_in (D' @ TVarB X Q # G)"
+ by (auto dest: typing_ok)
+ then have "X' \<sharp> G'" by (rule closed_in_fresh)
+ with T_TAbs show ?case by force
+next
+ case (T_TApp X' G' t1 T2 T11 T12 X P D')
+ then have "X' \<sharp> ty_domain (D' @ TVarB X Q # G)"
+ by (simp add: fresh_domain)
+ moreover from T_TApp have "T11 closed_in (D' @ TVarB X Q # G)"
+ by (auto dest: subtype_implies_closed)
+ ultimately have X': "X' \<sharp> T11" by (rule closed_in_fresh)
+ from T_TApp have "D'[X \<mapsto> P]\<^sub>e @ G \<turnstile> t1[X \<mapsto>\<^sub>\<tau> P] : (\<forall>X'<:T11. T12)[X \<mapsto> P]\<^sub>\<tau>"
+ by simp
+ with X' and T_TApp show ?case
+ by (auto simp add: fresh_atm type_substitution_lemma
+ fresh_list_append fresh_list_cons
+ ctxt_subst_fresh' type_subst_fresh subst_trm_ty_fresh
+ intro: substT_subtype)
+qed
+
+lemma Abs_type: -- {* A.13(1) *}
+ assumes H: "\<Gamma> \<turnstile> (\<lambda>x:S. s) : T"
+ and H': "\<Gamma> \<turnstile> T <: U \<rightarrow> U'"
+ and H'': "x \<sharp> \<Gamma>"
+ obtains S' where "\<Gamma> \<turnstile> U <: S"
+ and "(VarB x S) # \<Gamma> \<turnstile> s : S'"
+ and "\<Gamma> \<turnstile> S' <: U'"
+ using H H' H''
+proof (nominal_induct \<Gamma> t \<equiv> "\<lambda>x:S. s" T avoiding: x arbitrary: U U' S s rule: typing.strong_induct)
+ case (T_Abs y T\<^isub>1 \<Gamma> t\<^isub>2 T\<^isub>2)
+ from `\<Gamma> \<turnstile> T\<^isub>1 \<rightarrow> T\<^isub>2 <: U \<rightarrow> U'`
+ obtain ty1: "\<Gamma> \<turnstile> U <: S" and ty2: "\<Gamma> \<turnstile> T\<^isub>2 <: U'" using T_Abs
+ by cases (simp_all add: ty.inject trm.inject alpha fresh_atm)
+ from T_Abs have "VarB y S # \<Gamma> \<turnstile> [(y, x)] \<bullet> s : T\<^isub>2"
+ by (simp add: trm.inject alpha fresh_atm)
+ then have "[(y, x)] \<bullet> (VarB y S # \<Gamma>) \<turnstile> [(y, x)] \<bullet> [(y, x)] \<bullet> s : [(y, x)] \<bullet> T\<^isub>2"
+ by (rule typing.eqvt)
+ moreover from T_Abs have "y \<sharp> \<Gamma>"
+ by (auto dest!: typing_ok simp add: fresh_trm_domain)
+ ultimately have "VarB x S # \<Gamma> \<turnstile> s : T\<^isub>2" using T_Abs
+ by (perm_simp add: ty_vrs_prm_simp)
+ with ty1 show ?case using ty2 by (rule T_Abs)
+next
+ case (T_Sub \<Gamma> t S T)
+ then show ?case using subtype_transitivity by blast
+qed simp_all
+
+lemma subtype_reflexivity_from_typing:
+ assumes "\<Gamma> \<turnstile> t : T"
+ shows "\<Gamma> \<turnstile> T <: T"
+using assms subtype_reflexivity typing_ok typing_closed_in by simp
+
+lemma Abs_type':
+ assumes H: "\<Gamma> \<turnstile> (\<lambda>x:S. s) : U \<rightarrow> U'"
+ and H': "x \<sharp> \<Gamma>"
+ obtains S'
+ where "\<Gamma> \<turnstile> U <: S"
+ and "(VarB x S) # \<Gamma> \<turnstile> s : S'"
+ and "\<Gamma> \<turnstile> S' <: U'"
+ using H subtype_reflexivity_from_typing [OF H] H'
+ by (rule Abs_type)
+
+lemma TAbs_type: -- {* A.13(2) *}
+ assumes H: "\<Gamma> \<turnstile> (\<lambda>X<:S. s) : T"
+ and H': "\<Gamma> \<turnstile> T <: (\<forall>X<:U. U')"
+ and fresh: "X \<sharp> \<Gamma>" "X \<sharp> S" "X \<sharp> U"
+ obtains S'
+ where "\<Gamma> \<turnstile> U <: S"
+ and "(TVarB X U # \<Gamma>) \<turnstile> s : S'"
+ and "(TVarB X U # \<Gamma>) \<turnstile> S' <: U'"
+ using H H' fresh
+proof (nominal_induct \<Gamma> t \<equiv> "\<lambda>X<:S. s" T avoiding: X U U' S arbitrary: s rule: typing.strong_induct)
+ case (T_TAbs Y T\<^isub>1 \<Gamma> t\<^isub>2 T\<^isub>2)
+ from `TVarB Y T\<^isub>1 # \<Gamma> \<turnstile> t\<^isub>2 : T\<^isub>2` have Y: "Y \<sharp> \<Gamma>"
+ by (auto dest!: typing_ok simp add: valid_ty_domain_fresh)
+ from `Y \<sharp> U'` and `Y \<sharp> X`
+ have "(\<forall>X<:U. U') = (\<forall>Y<:U. [(Y, X)] \<bullet> U')"
+ by (simp add: ty.inject alpha' fresh_atm)
+ with T_TAbs have "\<Gamma> \<turnstile> (\<forall>Y<:S. T\<^isub>2) <: (\<forall>Y<:U. [(Y, X)] \<bullet> U')" by (simp add: trm.inject)
+ then obtain ty1: "\<Gamma> \<turnstile> U <: S" and ty2: "(TVarB Y U # \<Gamma>) \<turnstile> T\<^isub>2 <: ([(Y, X)] \<bullet> U')" using T_TAbs Y
+ by (cases rule: subtype_of.strong_cases [where X=Y]) (simp_all add: ty.inject alpha abs_fresh)
+ note ty1
+ moreover from T_TAbs have "TVarB Y S # \<Gamma> \<turnstile> ([(Y, X)] \<bullet> s) : T\<^isub>2"
+ by (simp add: trm.inject alpha fresh_atm)
+ then have "[(Y, X)] \<bullet> (TVarB Y S # \<Gamma>) \<turnstile> [(Y, X)] \<bullet> [(Y, X)] \<bullet> s : [(Y, X)] \<bullet> T\<^isub>2"
+ by (rule typing.eqvt)
+ with `X \<sharp> \<Gamma>` `X \<sharp> S` Y `Y \<sharp> S` have "TVarB X S # \<Gamma> \<turnstile> s : [(Y, X)] \<bullet> T\<^isub>2"
+ by perm_simp
+ then have "TVarB X U # \<Gamma> \<turnstile> s : [(Y, X)] \<bullet> T\<^isub>2" using ty1
+ by (rule narrow_type [of "[]", simplified])
+ moreover from ty2 have "([(Y, X)] \<bullet> (TVarB Y U # \<Gamma>)) \<turnstile> ([(Y, X)] \<bullet> T\<^isub>2) <: ([(Y, X)] \<bullet> [(Y, X)] \<bullet> U')"
+ by (rule subtype_of.eqvt)
+ with `X \<sharp> \<Gamma>` `X \<sharp> U` Y `Y \<sharp> U` have "(TVarB X U # \<Gamma>) \<turnstile> ([(Y, X)] \<bullet> T\<^isub>2) <: U'"
+ by perm_simp
+ ultimately show ?case by (rule T_TAbs)
+next
+ case (T_Sub \<Gamma> t S T)
+ then show ?case using subtype_transitivity by blast
+qed simp_all
+
+lemma TAbs_type':
+ assumes H: "\<Gamma> \<turnstile> (\<lambda>X<:S. s) : (\<forall>X<:U. U')"
+ and fresh: "X \<sharp> \<Gamma>" "X \<sharp> S" "X \<sharp> U"
+ obtains S'
+ where "\<Gamma> \<turnstile> U <: S"
+ and "(TVarB X U # \<Gamma>) \<turnstile> s : S'"
+ and "(TVarB X U # \<Gamma>) \<turnstile> S' <: U'"
+ using H subtype_reflexivity_from_typing [OF H] fresh
+ by (rule TAbs_type)
+
+theorem preservation: -- {* A.20 *}
+ assumes H: "\<Gamma> \<turnstile> t : T"
+ shows "t \<longmapsto> t' \<Longrightarrow> \<Gamma> \<turnstile> t' : T" using H
+proof (nominal_induct avoiding: t' rule: typing.strong_induct)
+ case (T_App \<Gamma> t\<^isub>1 T\<^isub>1\<^isub>1 T\<^isub>1\<^isub>2 t\<^isub>2 t')
+ obtain x::vrs where x_fresh: "x \<sharp> (\<Gamma>, t\<^isub>1 \<cdot> t\<^isub>2, t')"
+ by (rule exists_fresh) (rule fin_supp)
+ obtain X::tyvrs where "X \<sharp> (t\<^isub>1 \<cdot> t\<^isub>2, t')"
+ by (rule exists_fresh) (rule fin_supp)
+ with `t\<^isub>1 \<cdot> t\<^isub>2 \<longmapsto> t'` show ?case
+ proof (cases rule: eval.strong_cases [where x=x and X=X])
+ case (E_Abs v\<^isub>2 T\<^isub>1\<^isub>1' t\<^isub>1\<^isub>2)
+ with T_App and x_fresh have h: "\<Gamma> \<turnstile> (\<lambda>x:T\<^isub>1\<^isub>1'. t\<^isub>1\<^isub>2) : T\<^isub>1\<^isub>1 \<rightarrow> T\<^isub>1\<^isub>2"
+ by (simp add: trm.inject fresh_prod)
+ moreover from x_fresh have "x \<sharp> \<Gamma>" by simp
+ ultimately obtain S'
+ where T\<^isub>1\<^isub>1: "\<Gamma> \<turnstile> T\<^isub>1\<^isub>1 <: T\<^isub>1\<^isub>1'"
+ and t\<^isub>1\<^isub>2: "(VarB x T\<^isub>1\<^isub>1') # \<Gamma> \<turnstile> t\<^isub>1\<^isub>2 : S'"
+ and S': "\<Gamma> \<turnstile> S' <: T\<^isub>1\<^isub>2"
+ by (rule Abs_type') blast
+ from `\<Gamma> \<turnstile> t\<^isub>2 : T\<^isub>1\<^isub>1`
+ have "\<Gamma> \<turnstile> t\<^isub>2 : T\<^isub>1\<^isub>1'" using T\<^isub>1\<^isub>1 by (rule T_Sub)
+ with t\<^isub>1\<^isub>2 have "\<Gamma> \<turnstile> t\<^isub>1\<^isub>2[x \<mapsto> t\<^isub>2] : S'"
+ by (rule subst_type [where \<Delta>="[]", simplified])
+ hence "\<Gamma> \<turnstile> t\<^isub>1\<^isub>2[x \<mapsto> t\<^isub>2] : T\<^isub>1\<^isub>2" using S' by (rule T_Sub)
+ with E_Abs and x_fresh show ?thesis by (simp add: trm.inject fresh_prod)
+ next
+ case (E_App1 t''' t'' u)
+ hence "t\<^isub>1 \<longmapsto> t''" by (simp add:trm.inject)
+ hence "\<Gamma> \<turnstile> t'' : T\<^isub>1\<^isub>1 \<rightarrow> T\<^isub>1\<^isub>2" by (rule T_App)
+ hence "\<Gamma> \<turnstile> t'' \<cdot> t\<^isub>2 : T\<^isub>1\<^isub>2" using `\<Gamma> \<turnstile> t\<^isub>2 : T\<^isub>1\<^isub>1`
+ by (rule typing.T_App)
+ with E_App1 show ?thesis by (simp add:trm.inject)
+ next
+ case (E_App2 v t''' t'')
+ hence "t\<^isub>2 \<longmapsto> t''" by (simp add:trm.inject)
+ hence "\<Gamma> \<turnstile> t'' : T\<^isub>1\<^isub>1" by (rule T_App)
+ with T_App(1) have "\<Gamma> \<turnstile> t\<^isub>1 \<cdot> t'' : T\<^isub>1\<^isub>2"
+ by (rule typing.T_App)
+ with E_App2 show ?thesis by (simp add:trm.inject)
+ qed (simp_all add: fresh_prod)
+next
+ case (T_TApp X \<Gamma> t\<^isub>1 T\<^isub>2 T\<^isub>1\<^isub>1 T\<^isub>1\<^isub>2 t')
+ obtain x::vrs where "x \<sharp> (t\<^isub>1 \<cdot>\<^sub>\<tau> T\<^isub>2, t')"
+ by (rule exists_fresh) (rule fin_supp)
+ with `t\<^isub>1 \<cdot>\<^sub>\<tau> T\<^isub>2 \<longmapsto> t'`
+ show ?case
+ proof (cases rule: eval.strong_cases [where X=X and x=x])
+ case (E_TAbs T\<^isub>1\<^isub>1' T\<^isub>2' t\<^isub>1\<^isub>2)
+ with T_TApp have "\<Gamma> \<turnstile> (\<lambda>X<:T\<^isub>1\<^isub>1'. t\<^isub>1\<^isub>2) : (\<forall>X<:T\<^isub>1\<^isub>1. T\<^isub>1\<^isub>2)" and "X \<sharp> \<Gamma>" and "X \<sharp> T\<^isub>1\<^isub>1'"
+ by (simp_all add: trm.inject)
+ moreover from `\<Gamma>\<turnstile>T\<^isub>2<:T\<^isub>1\<^isub>1` and `X \<sharp> \<Gamma>` have "X \<sharp> T\<^isub>1\<^isub>1"
+ by (blast intro: closed_in_fresh fresh_domain dest: subtype_implies_closed)
+ ultimately obtain S'
+ where "TVarB X T\<^isub>1\<^isub>1 # \<Gamma> \<turnstile> t\<^isub>1\<^isub>2 : S'"
+ and "(TVarB X T\<^isub>1\<^isub>1 # \<Gamma>) \<turnstile> S' <: T\<^isub>1\<^isub>2"
+ by (rule TAbs_type') blast
+ hence "TVarB X T\<^isub>1\<^isub>1 # \<Gamma> \<turnstile> t\<^isub>1\<^isub>2 : T\<^isub>1\<^isub>2" by (rule T_Sub)
+ hence "\<Gamma> \<turnstile> t\<^isub>1\<^isub>2[X \<mapsto>\<^sub>\<tau> T\<^isub>2] : T\<^isub>1\<^isub>2[X \<mapsto> T\<^isub>2]\<^sub>\<tau>" using `\<Gamma> \<turnstile> T\<^isub>2 <: T\<^isub>1\<^isub>1`
+ by (rule substT_type [where D="[]", simplified])
+ with T_TApp and E_TAbs show ?thesis by (simp add: trm.inject)
+ next
+ case (E_TApp t''' t'' T)
+ from E_TApp have "t\<^isub>1 \<longmapsto> t''" by (simp add: trm.inject)
+ then have "\<Gamma> \<turnstile> t'' : (\<forall>X<:T\<^isub>1\<^isub>1. T\<^isub>1\<^isub>2)" by (rule T_TApp)
+ then have "\<Gamma> \<turnstile> t'' \<cdot>\<^sub>\<tau> T\<^isub>2 : T\<^isub>1\<^isub>2[X \<mapsto> T\<^isub>2]\<^sub>\<tau>" using `\<Gamma> \<turnstile> T\<^isub>2 <: T\<^isub>1\<^isub>1`
+ by (rule better_T_TApp)
+ with E_TApp show ?thesis by (simp add: trm.inject)
+ qed (simp_all add: fresh_prod)
+next
+ case (T_Sub \<Gamma> t S T t')
+ have "t \<longmapsto> t'" by fact
+ hence "\<Gamma> \<turnstile> t' : S" by (rule T_Sub)
+ moreover have "\<Gamma> \<turnstile> S <: T" by fact
+ ultimately show ?case by (rule typing.T_Sub)
+qed (auto)
+
+lemma Fun_canonical: -- {* A.14(1) *}
+ assumes ty: "[] \<turnstile> v : T\<^isub>1 \<rightarrow> T\<^isub>2"
+ shows "val v \<Longrightarrow> \<exists>x t S. v = (\<lambda>x:S. t)" using ty
+proof (induct \<Gamma>\<equiv>"[]::env" v T\<equiv>"T\<^isub>1 \<rightarrow> T\<^isub>2" arbitrary: T\<^isub>1 T\<^isub>2)
+ case (T_Sub \<Gamma> t S T)
+ hence "\<Gamma> \<turnstile> S <: T\<^isub>1 \<rightarrow> T\<^isub>2" by simp
+ then obtain S\<^isub>1 S\<^isub>2 where S: "S = S\<^isub>1 \<rightarrow> S\<^isub>2"
+ by cases (auto simp add: T_Sub)
+ with `val t` and `\<Gamma> = []` show ?case by (rule T_Sub)
+qed (auto)
+
+lemma TyAll_canonical: -- {* A.14(3) *}
+ fixes X::tyvrs
+ assumes ty: "[] \<turnstile> v : (\<forall>X<:T\<^isub>1. T\<^isub>2)"
+ shows "val v \<Longrightarrow> \<exists>X t S. v = (\<lambda>X<:S. t)" using ty
+proof (induct \<Gamma>\<equiv>"[]::env" v T\<equiv>"\<forall>X<:T\<^isub>1. T\<^isub>2" arbitrary: X T\<^isub>1 T\<^isub>2)
+ case (T_Sub \<Gamma> t S T)
+ hence "\<Gamma> \<turnstile> S <: (\<forall>X<:T\<^isub>1. T\<^isub>2)" by simp
+ then obtain X S\<^isub>1 S\<^isub>2 where S: "S = (\<forall>X<:S\<^isub>1. S\<^isub>2)"
+ by cases (auto simp add: T_Sub)
+ then show ?case using T_Sub by auto
+qed (auto)
+
+theorem progress:
+ assumes "[] \<turnstile> t : T"
+ shows "val t \<or> (\<exists>t'. t \<longmapsto> t')"
+using assms
+proof (induct \<Gamma> \<equiv> "[]::env" t T)
+ case (T_App \<Gamma> t\<^isub>1 T\<^isub>1\<^isub>1 T\<^isub>1\<^isub>2 t\<^isub>2)
+ hence "val t\<^isub>1 \<or> (\<exists>t'. t\<^isub>1 \<longmapsto> t')" by simp
+ thus ?case
+ proof
+ assume t\<^isub>1_val: "val t\<^isub>1"
+ with T_App obtain x t3 S where t\<^isub>1: "t\<^isub>1 = (\<lambda>x:S. t3)"
+ by (auto dest!: Fun_canonical)
+ from T_App have "val t\<^isub>2 \<or> (\<exists>t'. t\<^isub>2 \<longmapsto> t')" by simp
+ thus ?case
+ proof
+ assume "val t\<^isub>2"
+ with t\<^isub>1 have "t\<^isub>1 \<cdot> t\<^isub>2 \<longmapsto> t3[x \<mapsto> t\<^isub>2]" by auto
+ thus ?case by auto
+ next
+ assume "\<exists>t'. t\<^isub>2 \<longmapsto> t'"
+ then obtain t' where "t\<^isub>2 \<longmapsto> t'" by auto
+ with t\<^isub>1_val have "t\<^isub>1 \<cdot> t\<^isub>2 \<longmapsto> t\<^isub>1 \<cdot> t'" by auto
+ thus ?case by auto
+ qed
+ next
+ assume "\<exists>t'. t\<^isub>1 \<longmapsto> t'"
+ then obtain t' where "t\<^isub>1 \<longmapsto> t'" by auto
+ hence "t\<^isub>1 \<cdot> t\<^isub>2 \<longmapsto> t' \<cdot> t\<^isub>2" by auto
+ thus ?case by auto
+ qed
+next
+ case (T_TApp X \<Gamma> t\<^isub>1 T\<^isub>2 T\<^isub>1\<^isub>1 T\<^isub>1\<^isub>2)
+ hence "val t\<^isub>1 \<or> (\<exists>t'. t\<^isub>1 \<longmapsto> t')" by simp
+ thus ?case
+ proof
+ assume "val t\<^isub>1"
+ with T_TApp obtain x t S where "t\<^isub>1 = (\<lambda>x<:S. t)"
+ by (auto dest!: TyAll_canonical)
+ hence "t\<^isub>1 \<cdot>\<^sub>\<tau> T\<^isub>2 \<longmapsto> t[x \<mapsto>\<^sub>\<tau> T\<^isub>2]" by auto
+ thus ?case by auto
+ next
+ assume "\<exists>t'. t\<^isub>1 \<longmapsto> t'" thus ?case by auto
+ qed
+qed (auto)
+
+end
--- a/src/HOL/Nominal/Nominal.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Nominal/Nominal.thy Thu Feb 26 11:21:29 2009 +0000
@@ -397,6 +397,18 @@
lemmas fresh_star_prod = fresh_star_prod_list fresh_star_prod_set
+text {* Normalization of freshness results; cf.\ @{text nominal_induct} *}
+
+lemma fresh_star_unit_elim:
+ shows "((a::'a set)\<sharp>*() \<Longrightarrow> PROP C) \<equiv> PROP C"
+ and "((b::'a list)\<sharp>*() \<Longrightarrow> PROP C) \<equiv> PROP C"
+ by (simp_all add: fresh_star_def fresh_def supp_unit)
+
+lemma fresh_star_prod_elim:
+ shows "((a::'a set)\<sharp>*(x,y) \<Longrightarrow> PROP C) \<equiv> (a\<sharp>*x \<Longrightarrow> a\<sharp>*y \<Longrightarrow> PROP C)"
+ and "((b::'a list)\<sharp>*(x,y) \<Longrightarrow> PROP C) \<equiv> (b\<sharp>*x \<Longrightarrow> b\<sharp>*y \<Longrightarrow> PROP C)"
+ by (rule, simp_all add: fresh_star_prod)+
+
section {* Abstract Properties for Permutations and Atoms *}
(*=========================================================*)
@@ -1645,6 +1657,31 @@
apply(rule at)
done
+lemma pt_fresh_star_eqvt:
+ fixes pi :: "'x prm"
+ and x :: "'a"
+ and a :: "'x set"
+ and b :: "'x list"
+ assumes pt: "pt TYPE('a) TYPE('x)"
+ and at: "at TYPE('x)"
+ shows "pi\<bullet>(a\<sharp>*x) = (pi\<bullet>a)\<sharp>*(pi\<bullet>x)"
+ and "pi\<bullet>(b\<sharp>*x) = (pi\<bullet>b)\<sharp>*(pi\<bullet>x)"
+ by (simp_all add: perm_bool pt_fresh_star_bij[OF pt, OF at])
+
+lemma pt_fresh_star_eqvt_ineq:
+ fixes pi::"'x prm"
+ and a::"'y set"
+ and b::"'y list"
+ and x::"'a"
+ assumes pta: "pt TYPE('a) TYPE('x)"
+ and ptb: "pt TYPE('y) TYPE('x)"
+ and at: "at TYPE('x)"
+ and cp: "cp TYPE('a) TYPE('x) TYPE('y)"
+ and dj: "disjoint TYPE('y) TYPE('x)"
+ shows "pi\<bullet>(a\<sharp>*x) = (pi\<bullet>a)\<sharp>*(pi\<bullet>x)"
+ and "pi\<bullet>(b\<sharp>*x) = (pi\<bullet>b)\<sharp>*(pi\<bullet>x)"
+ by (simp_all add: pt_fresh_star_bij_ineq[OF pta, OF ptb, OF at, OF cp] dj_perm_forget[OF dj] perm_bool)
+
lemma pt_fresh_bij1:
fixes pi :: "'x prm"
and x :: "'a"
--- a/src/HOL/Nominal/nominal_atoms.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Nominal/nominal_atoms.ML Thu Feb 26 11:21:29 2009 +0000
@@ -1,5 +1,4 @@
(* title: HOL/Nominal/nominal_atoms.ML
- ID: $Id$
Author: Christian Urban and Stefan Berghofer, TU Muenchen
Declaration of atom types to be used in nominal datatypes.
@@ -784,6 +783,8 @@
val fresh_star_bij = @{thms "Nominal.pt_fresh_star_bij"};
val fresh_eqvt = @{thm "Nominal.pt_fresh_eqvt"};
val fresh_eqvt_ineq = @{thm "Nominal.pt_fresh_eqvt_ineq"};
+ val fresh_star_eqvt = @{thms "Nominal.pt_fresh_star_eqvt"};
+ val fresh_star_eqvt_ineq= @{thms "Nominal.pt_fresh_star_eqvt_ineq"};
val set_diff_eqvt = @{thm "Nominal.pt_set_diff_eqvt"};
val in_eqvt = @{thm "Nominal.pt_in_eqvt"};
val eq_eqvt = @{thm "Nominal.pt_eq_eqvt"};
@@ -947,13 +948,17 @@
in [(("fresh_bij", thms1 @ thms2),[])] end
||>> add_thmss_string
let val thms1 = inst_pt_at fresh_star_bij
- and thms2 = flat (map (fn ti => inst_pt_pt_at_cp [ti]) fresh_star_bij_ineq);
+ and thms2 = maps (fn ti => inst_pt_pt_at_cp [ti]) fresh_star_bij_ineq
in [(("fresh_star_bij", thms1 @ thms2),[])] end
||>> add_thmss_string
let val thms1 = inst_pt_at [fresh_eqvt]
and thms2 = inst_pt_pt_at_cp_dj [fresh_eqvt_ineq]
in [(("fresh_eqvt", thms1 @ thms2),[NominalThmDecls.eqvt_add])] end
||>> add_thmss_string
+ let val thms1 = inst_pt_at fresh_star_eqvt
+ and thms2 = maps (fn ti => inst_pt_pt_at_cp_dj [ti]) fresh_star_eqvt_ineq
+ in [(("fresh_star_eqvt", thms1 @ thms2),[NominalThmDecls.eqvt_add])] end
+ ||>> add_thmss_string
let val thms1 = inst_pt_at [in_eqvt]
in [(("in_eqvt", thms1),[NominalThmDecls.eqvt_add])] end
||>> add_thmss_string
--- a/src/HOL/Nominal/nominal_induct.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Nominal/nominal_induct.ML Thu Feb 26 11:21:29 2009 +0000
@@ -1,5 +1,4 @@
-(* ID: $Id$
- Author: Christian Urban and Makarius
+(* Author: Christian Urban and Makarius
The nominal induct proof method.
*)
@@ -24,7 +23,8 @@
val split_all_tuples =
Simplifier.full_simplify (HOL_basic_ss addsimps
- [split_conv, split_paired_all, unit_all_eq1, thm "fresh_unit_elim", thm "fresh_prod_elim"]);
+ [split_conv, split_paired_all, unit_all_eq1, @{thm fresh_unit_elim}, @{thm fresh_prod_elim}] @
+ @{thms fresh_star_unit_elim} @ @{thms fresh_star_prod_elim});
(* prepare rule *)
--- a/src/HOL/Nominal/nominal_inductive.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Nominal/nominal_inductive.ML Thu Feb 26 11:21:29 2009 +0000
@@ -7,8 +7,8 @@
signature NOMINAL_INDUCTIVE =
sig
- val prove_strong_ind: string -> (string * string list) list -> theory -> Proof.state
- val prove_eqvt: string -> string list -> theory -> theory
+ val prove_strong_ind: string -> (string * string list) list -> local_theory -> Proof.state
+ val prove_eqvt: string -> string list -> local_theory -> local_theory
end
structure NominalInductive : NOMINAL_INDUCTIVE =
@@ -28,6 +28,8 @@
fun atomize_induct ctxt = Conv.fconv_rule (Conv.prems_conv ~1
(Conv.params_conv ~1 (K (Conv.prems_conv ~1 atomize_conv)) ctxt));
+fun preds_of ps t = gen_inter (op = o apfst dest_Free) (ps, Term.add_frees t []);
+
val fresh_prod = thm "fresh_prod";
val perm_bool = mk_meta_eq (thm "perm_bool");
@@ -142,9 +144,9 @@
fun first_order_mrs ths th = ths MRS
Thm.instantiate (first_order_matchs (cprems_of th) (map cprop_of ths)) th;
-fun prove_strong_ind s avoids thy =
+fun prove_strong_ind s avoids ctxt =
let
- val ctxt = ProofContext.init thy;
+ val thy = ProofContext.theory_of ctxt;
val ({names, ...}, {raw_induct, intrs, elims, ...}) =
InductivePackage.the_inductive ctxt (Sign.intern_const thy s);
val ind_params = InductivePackage.params_of raw_induct;
@@ -158,8 +160,7 @@
commas_quote xs));
val induct_cases = map fst (fst (RuleCases.get (the
(Induct.lookup_inductP ctxt (hd names)))));
- val raw_induct' = Logic.unvarify (prop_of raw_induct);
- val elims' = map (Logic.unvarify o prop_of) elims;
+ val ([raw_induct'], ctxt') = Variable.import_terms false [prop_of raw_induct] ctxt;
val concls = raw_induct' |> Logic.strip_imp_concl |> HOLogic.dest_Trueprop |>
HOLogic.dest_conj |> map (HOLogic.dest_imp ##> strip_comb);
val ps = map (fst o snd) concls;
@@ -199,8 +200,8 @@
val ind_sort = if null atomTs then HOLogic.typeS
else Sign.certify_sort thy (map (fn T => Sign.intern_class thy
("fs_" ^ Sign.base_name (fst (dest_Type T)))) atomTs);
- val fs_ctxt_tyname = Name.variant (map fst (OldTerm.term_tfrees raw_induct')) "'n";
- val fs_ctxt_name = Name.variant (OldTerm.add_term_names (raw_induct', [])) "z";
+ val ([fs_ctxt_tyname], _) = Name.variants ["'n"] (Variable.names_of ctxt');
+ val ([fs_ctxt_name], ctxt'') = Variable.variant_fixes ["z"] ctxt';
val fsT = TFree (fs_ctxt_tyname, ind_sort);
val inductive_forall_def' = Drule.instantiate'
@@ -237,7 +238,7 @@
val prem = Logic.list_implies
(map mk_fresh bvars @ mk_distinct bvars @
map (fn prem =>
- if null (OldTerm.term_frees prem inter ps) then prem
+ if null (preds_of ps prem) then prem
else lift_prem prem) prems,
HOLogic.mk_Trueprop (lift_pred p ts));
val vs = map (Var o apfst (rpair 0)) (Term.rename_wrt_term prem params')
@@ -263,7 +264,7 @@
val vc_compat = map (fn (params, bvars, prems, (p, ts)) =>
map (fn q => list_all (params, incr_boundvars ~1 (Logic.list_implies
(List.mapPartial (fn prem =>
- if null (ps inter OldTerm.term_frees prem) then SOME prem
+ if null (preds_of ps prem) then SOME prem
else map_term (split_conj (K o I) names) prem prem) prems, q))))
(mk_distinct bvars @
maps (fn (t, T) => map (fn (u, U) => HOLogic.mk_Trueprop
@@ -309,8 +310,8 @@
[ex] ctxt
in (freshs1 @ [term_of cx], freshs2 @ ths, ctxt') end;
- fun mk_ind_proof thy thss =
- Goal.prove_global thy [] prems' concl' (fn {prems = ihyps, context = ctxt} =>
+ fun mk_ind_proof ctxt' thss =
+ Goal.prove ctxt' [] prems' concl' (fn {prems = ihyps, context = ctxt} =>
let val th = Goal.prove ctxt [] [] concl (fn {context, ...} =>
rtac raw_induct 1 THEN
EVERY (maps (fn ((((_, bvars, oprems, _), vc_compat_ths), ihyp), (vs, ihypt)) =>
@@ -352,7 +353,7 @@
(rev pis' @ pis) th));
val (gprems1, gprems2) = split_list
(map (fn (th, t) =>
- if null (OldTerm.term_frees t inter ps) then (SOME th, mk_pi th)
+ if null (preds_of ps t) then (SOME th, mk_pi th)
else
(map_thm ctxt (split_conj (K o I) names)
(etac conjunct1 1) monos NONE th,
@@ -403,42 +404,42 @@
REPEAT (REPEAT (resolve_tac [conjI, impI] 1) THEN
etac impE 1 THEN atac 1 THEN REPEAT (etac @{thm allE_Nil} 1) THEN
asm_full_simp_tac (simpset_of thy) 1)
- end);
+ end) |> singleton (ProofContext.export ctxt' ctxt);
(** strong case analysis rule **)
val cases_prems = map (fn ((name, avoids), rule) =>
let
- val prem :: prems = Logic.strip_imp_prems rule;
- val concl = Logic.strip_imp_concl rule;
- val used = Term.add_free_names rule [];
+ val ([rule'], ctxt') = Variable.import_terms false [prop_of rule] ctxt;
+ val prem :: prems = Logic.strip_imp_prems rule';
+ val concl = Logic.strip_imp_concl rule'
in
(prem,
List.drop (snd (strip_comb (HOLogic.dest_Trueprop prem)), length ind_params),
concl,
- fst (fold_map (fn (prem, (_, avoid)) => fn used =>
+ fold_map (fn (prem, (_, avoid)) => fn ctxt =>
let
val prems = Logic.strip_assums_hyp prem;
val params = Logic.strip_params prem;
val bnds = fold (add_binders thy 0) prems [] @ mk_avoids params avoid;
- fun mk_subst (p as (s, T)) (i, j, used, ps, qs, is, ts) =
+ fun mk_subst (p as (s, T)) (i, j, ctxt, ps, qs, is, ts) =
if member (op = o apsnd fst) bnds (Bound i) then
let
- val s' = Name.variant used s;
+ val ([s'], ctxt') = Variable.variant_fixes [s] ctxt;
val t = Free (s', T)
- in (i + 1, j, s' :: used, ps, (t, T) :: qs, i :: is, t :: ts) end
- else (i + 1, j + 1, used, p :: ps, qs, is, Bound j :: ts);
- val (_, _, used', ps, qs, is, ts) = fold_rev mk_subst params
- (0, 0, used, [], [], [], [])
+ in (i + 1, j, ctxt', ps, (t, T) :: qs, i :: is, t :: ts) end
+ else (i + 1, j + 1, ctxt, p :: ps, qs, is, Bound j :: ts);
+ val (_, _, ctxt', ps, qs, is, ts) = fold_rev mk_subst params
+ (0, 0, ctxt, [], [], [], [])
in
- ((ps, qs, is, map (curry subst_bounds (rev ts)) prems), used')
- end) (prems ~~ avoids) used))
+ ((ps, qs, is, map (curry subst_bounds (rev ts)) prems), ctxt')
+ end) (prems ~~ avoids) ctxt')
end)
(InductivePackage.partition_rules' raw_induct (intrs ~~ avoids') ~~
- elims');
+ elims);
val cases_prems' =
- map (fn (prem, args, concl, prems) =>
+ map (fn (prem, args, concl, (prems, _)) =>
let
fun mk_prem (ps, [], _, prems) =
list_all (ps, Logic.list_implies (prems, concl))
@@ -462,9 +463,9 @@
val simp_fresh_atm = map
(Simplifier.simplify (HOL_basic_ss addsimps fresh_atm));
- fun mk_cases_proof thy ((((name, thss), elim), (prem, args, concl, prems)),
+ fun mk_cases_proof ((((name, thss), elim), (prem, args, concl, (prems, ctxt'))),
prems') =
- (name, Goal.prove_global thy [] (prem :: prems') concl
+ (name, Goal.prove ctxt' [] (prem :: prems') concl
(fn {prems = hyp :: hyps, context = ctxt1} =>
EVERY (rtac (hyp RS elim) 1 ::
map (fn (((_, vc_compat_ths), case_hyp), (_, qs, is, _)) =>
@@ -537,52 +538,54 @@
end) ctxt4 1)
val final = ProofContext.export ctxt3 ctxt2 [th]
in resolve_tac final 1 end) ctxt1 1)
- (thss ~~ hyps ~~ prems))))
+ (thss ~~ hyps ~~ prems))) |>
+ singleton (ProofContext.export ctxt' ctxt))
in
- thy |>
- ProofContext.init |>
- Proof.theorem_i NONE (fn thss => ProofContext.theory (fn thy =>
+ ctxt'' |>
+ Proof.theorem_i NONE (fn thss => fn ctxt =>
let
- val ctxt = ProofContext.init thy;
val rec_name = space_implode "_" (map Sign.base_name names);
+ val rec_qualified = Binding.qualify rec_name;
val ind_case_names = RuleCases.case_names induct_cases;
val induct_cases' = InductivePackage.partition_rules' raw_induct
(intrs ~~ induct_cases);
val thss' = map (map atomize_intr) thss;
val thsss = InductivePackage.partition_rules' raw_induct (intrs ~~ thss');
val strong_raw_induct =
- mk_ind_proof thy thss' |> InductivePackage.rulify;
- val strong_cases = map (mk_cases_proof thy ##> InductivePackage.rulify)
+ mk_ind_proof ctxt thss' |> InductivePackage.rulify;
+ val strong_cases = map (mk_cases_proof ##> InductivePackage.rulify)
(thsss ~~ elims ~~ cases_prems ~~ cases_prems');
val strong_induct =
if length names > 1 then
(strong_raw_induct, [ind_case_names, RuleCases.consumes 0])
else (strong_raw_induct RSN (2, rev_mp),
[ind_case_names, RuleCases.consumes 1]);
- val ([strong_induct'], thy') = thy |>
- Sign.add_path rec_name |>
- PureThy.add_thms [((Binding.name "strong_induct", #1 strong_induct), #2 strong_induct)];
+ val ((_, [strong_induct']), ctxt') = LocalTheory.note Thm.theoremK
+ ((rec_qualified (Binding.name "strong_induct"),
+ map (Attrib.internal o K) (#2 strong_induct)), [#1 strong_induct])
+ ctxt;
val strong_inducts =
ProjectRule.projects ctxt (1 upto length names) strong_induct'
in
- thy' |>
- PureThy.add_thmss [((Binding.name "strong_inducts", strong_inducts),
- [ind_case_names, RuleCases.consumes 1])] |> snd |>
- Sign.parent_path |>
- fold (fn ((name, elim), (_, cases)) =>
- Sign.add_path (Sign.base_name name) #>
- PureThy.add_thms [((Binding.name "strong_cases", elim),
- [RuleCases.case_names (map snd cases),
- RuleCases.consumes 1])] #> snd #>
- Sign.parent_path) (strong_cases ~~ induct_cases')
- end))
+ ctxt' |>
+ LocalTheory.note Thm.theoremK
+ ((rec_qualified (Binding.name "strong_inducts"),
+ [Attrib.internal (K ind_case_names),
+ Attrib.internal (K (RuleCases.consumes 1))]),
+ strong_inducts) |> snd |>
+ LocalTheory.notes Thm.theoremK (map (fn ((name, elim), (_, cases)) =>
+ ((Binding.name (NameSpace.qualified (Sign.base_name name) "strong_cases"),
+ [Attrib.internal (K (RuleCases.case_names (map snd cases))),
+ Attrib.internal (K (RuleCases.consumes 1))]), [([elim], [])]))
+ (strong_cases ~~ induct_cases')) |> snd
+ end)
(map (map (rulify_term thy #> rpair [])) vc_compat)
end;
-fun prove_eqvt s xatoms thy =
+fun prove_eqvt s xatoms ctxt =
let
- val ctxt = ProofContext.init thy;
+ val thy = ProofContext.theory_of ctxt;
val ({names, ...}, {raw_induct, intrs, elims, ...}) =
InductivePackage.the_inductive ctxt (Sign.intern_const thy s);
val raw_induct = atomize_induct ctxt raw_induct;
@@ -594,6 +597,7 @@
(s, ths ~~ InductivePackage.infer_intro_vars th k ths))
(InductivePackage.partition_rules raw_induct intrs ~~
InductivePackage.arities_of raw_induct ~~ elims));
+ val k = length (InductivePackage.params_of raw_induct);
val atoms' = NominalAtoms.atoms_of thy;
val atoms =
if null xatoms then atoms' else
@@ -612,19 +616,21 @@
(NominalThmDecls.get_eqvt_thms ctxt @ perm_pi_simp) addsimprocs
[mk_perm_bool_simproc names,
NominalPermeq.perm_simproc_app, NominalPermeq.perm_simproc_fun];
- val t = Logic.unvarify (concl_of raw_induct);
- val pi = Name.variant (OldTerm.add_term_names (t, [])) "pi";
+ val (([t], [pi]), ctxt') = ctxt |>
+ Variable.import_terms false [concl_of raw_induct] ||>>
+ Variable.variant_fixes ["pi"];
val ps = map (fst o HOLogic.dest_imp)
(HOLogic.dest_conj (HOLogic.dest_Trueprop t));
- fun eqvt_tac pi (intr, vs) st =
+ fun eqvt_tac ctxt'' pi (intr, vs) st =
let
- fun eqvt_err s = error
- ("Could not prove equivariance for introduction rule\n" ^
- Syntax.string_of_term_global (theory_of_thm intr)
- (Logic.unvarify (prop_of intr)) ^ "\n" ^ s);
+ fun eqvt_err s =
+ let val ([t], ctxt''') = Variable.import_terms true [prop_of intr] ctxt
+ in error ("Could not prove equivariance for introduction rule\n" ^
+ Syntax.string_of_term ctxt''' t ^ "\n" ^ s)
+ end;
val res = SUBPROOF (fn {prems, params, ...} =>
let
- val prems' = map (fn th => the_default th (map_thm ctxt
+ val prems' = map (fn th => the_default th (map_thm ctxt'
(split_conj (K I) names) (etac conjunct2 1) monos NONE th)) prems;
val prems'' = map (fn th => Simplifier.simplify eqvt_ss
(mk_perm_bool (cterm_of thy pi) th)) prems';
@@ -632,29 +638,36 @@
map (cterm_of thy o NominalPackage.mk_perm [] pi o term_of) params)
intr
in (rtac intr' THEN_ALL_NEW (TRY o resolve_tac prems'')) 1
- end) ctxt 1 st
+ end) ctxt' 1 st
in
case (Seq.pull res handle THM (s, _, _) => eqvt_err s) of
NONE => eqvt_err ("Rule does not match goal\n" ^
- Syntax.string_of_term_global (theory_of_thm st) (hd (prems_of st)))
+ Syntax.string_of_term ctxt'' (hd (prems_of st)))
| SOME (th, _) => Seq.single th
end;
val thss = map (fn atom =>
let val pi' = Free (pi, NominalAtoms.mk_permT (Type (atom, [])))
in map (fn th => zero_var_indexes (th RS mp))
- (DatatypeAux.split_conj_thm (Goal.prove_global thy [] []
+ (DatatypeAux.split_conj_thm (Goal.prove ctxt' [] []
(HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj (map (fn p =>
- HOLogic.mk_imp (p, list_comb
- (apsnd (map (NominalPackage.mk_perm [] pi')) (strip_comb p)))) ps)))
- (fn _ => EVERY (rtac raw_induct 1 :: map (fn intr_vs =>
+ let
+ val (h, ts) = strip_comb p;
+ val (ts1, ts2) = chop k ts
+ in
+ HOLogic.mk_imp (p, list_comb (h, ts1 @
+ map (NominalPackage.mk_perm [] pi') ts2))
+ end) ps)))
+ (fn {context, ...} => EVERY (rtac raw_induct 1 :: map (fn intr_vs =>
full_simp_tac eqvt_ss 1 THEN
- eqvt_tac pi' intr_vs) intrs'))))
+ eqvt_tac context pi' intr_vs) intrs')) |>
+ singleton (ProofContext.export ctxt' ctxt)))
end) atoms
in
- fold (fn (name, ths) =>
- Sign.add_path (Sign.base_name name) #>
- PureThy.add_thmss [((Binding.name "eqvt", ths), [NominalThmDecls.eqvt_add])] #> snd #>
- Sign.parent_path) (names ~~ transp thss) thy
+ ctxt |>
+ LocalTheory.notes Thm.theoremK (map (fn (name, ths) =>
+ ((Binding.name (NameSpace.qualified (Sign.base_name name) "eqvt"),
+ [Attrib.internal (K NominalThmDecls.eqvt_add)]), [(ths, [])]))
+ (names ~~ transp thss)) |> snd
end;
@@ -665,17 +678,17 @@
val _ = OuterKeyword.keyword "avoids";
val _ =
- OuterSyntax.command "nominal_inductive"
+ OuterSyntax.local_theory_to_proof "nominal_inductive"
"prove equivariance and strong induction theorem for inductive predicate involving nominal datatypes" K.thy_goal
- (P.name -- Scan.optional (P.$$$ "avoids" |-- P.and_list1 (P.name --
+ (P.xname -- Scan.optional (P.$$$ "avoids" |-- P.and_list1 (P.name --
(P.$$$ ":" |-- Scan.repeat1 P.name))) [] >> (fn (name, avoids) =>
- Toplevel.print o Toplevel.theory_to_proof (prove_strong_ind name avoids)));
+ prove_strong_ind name avoids));
val _ =
- OuterSyntax.command "equivariance"
+ OuterSyntax.local_theory "equivariance"
"prove equivariance for inductive predicate involving nominal datatypes" K.thy_decl
- (P.name -- Scan.optional (P.$$$ "[" |-- P.list1 P.name --| P.$$$ "]") [] >>
- (fn (name, atoms) => Toplevel.theory (prove_eqvt name atoms)));
+ (P.xname -- Scan.optional (P.$$$ "[" |-- P.list1 P.name --| P.$$$ "]") [] >>
+ (fn (name, atoms) => prove_eqvt name atoms));
end;
--- a/src/HOL/Nominal/nominal_inductive2.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Nominal/nominal_inductive2.ML Thu Feb 26 11:21:29 2009 +0000
@@ -8,7 +8,7 @@
signature NOMINAL_INDUCTIVE2 =
sig
- val prove_strong_ind: string -> (string * string list) list -> theory -> Proof.state
+ val prove_strong_ind: string -> (string * string list) list -> local_theory -> Proof.state
end
structure NominalInductive2 : NOMINAL_INDUCTIVE2 =
@@ -28,6 +28,8 @@
fun atomize_induct ctxt = Conv.fconv_rule (Conv.prems_conv ~1
(Conv.params_conv ~1 (K (Conv.prems_conv ~1 atomize_conv)) ctxt));
+fun preds_of ps t = gen_inter (op = o apfst dest_Free) (ps, Term.add_frees t []);
+
val perm_bool = mk_meta_eq (thm "perm_bool");
val perm_boolI = thm "perm_boolI";
val (_, [perm_boolI_pi, _]) = Drule.strip_comb (snd (Thm.dest_comb
@@ -148,9 +150,9 @@
map (Envir.subst_vars env #> cterm_of thy) vs ~~ cts) th
end;
-fun prove_strong_ind s avoids thy =
+fun prove_strong_ind s avoids ctxt =
let
- val ctxt = ProofContext.init thy;
+ val thy = ProofContext.theory_of ctxt;
val ({names, ...}, {raw_induct, intrs, elims, ...}) =
InductivePackage.the_inductive ctxt (Sign.intern_const thy s);
val ind_params = InductivePackage.params_of raw_induct;
@@ -166,8 +168,7 @@
(Induct.lookup_inductP ctxt (hd names)))));
val induct_cases' = if null induct_cases then replicate (length intrs) ""
else induct_cases;
- val raw_induct' = Logic.unvarify (prop_of raw_induct);
- val elims' = map (Logic.unvarify o prop_of) elims;
+ val ([raw_induct'], ctxt') = Variable.import_terms false [prop_of raw_induct] ctxt;
val concls = raw_induct' |> Logic.strip_imp_concl |> HOLogic.dest_Trueprop |>
HOLogic.dest_conj |> map (HOLogic.dest_imp ##> strip_comb);
val ps = map (fst o snd) concls;
@@ -221,8 +222,8 @@
val ind_sort = if null atomTs then HOLogic.typeS
else Sign.certify_sort thy (map (fn a => Sign.intern_class thy
("fs_" ^ Sign.base_name a)) atoms);
- val fs_ctxt_tyname = Name.variant (map fst (OldTerm.term_tfrees raw_induct')) "'n";
- val fs_ctxt_name = Name.variant (OldTerm.add_term_names (raw_induct', [])) "z";
+ val ([fs_ctxt_tyname], _) = Name.variants ["'n"] (Variable.names_of ctxt');
+ val ([fs_ctxt_name], ctxt'') = Variable.variant_fixes ["z"] ctxt';
val fsT = TFree (fs_ctxt_tyname, ind_sort);
val inductive_forall_def' = Drule.instantiate'
@@ -253,7 +254,7 @@
val prem = Logic.list_implies
(map mk_fresh sets @
map (fn prem =>
- if null (OldTerm.term_frees prem inter ps) then prem
+ if null (preds_of ps prem) then prem
else lift_prem prem) prems,
HOLogic.mk_Trueprop (lift_pred p ts));
in abs_params params' prem end) prems);
@@ -276,7 +277,7 @@
val (vc_compat, vc_compat') = map (fn (params, sets, prems, (p, ts)) =>
map (fn q => abs_params params (incr_boundvars ~1 (Logic.list_implies
(List.mapPartial (fn prem =>
- if null (ps inter OldTerm.term_frees prem) then SOME prem
+ if null (preds_of ps prem) then SOME prem
else map_term (split_conj (K o I) names) prem prem) prems, q))))
(maps (fn (t, T) => map (fn (u, U) => HOLogic.mk_Trueprop
(NominalPackage.fresh_star_const U T $ u $ t)) sets)
@@ -345,8 +346,8 @@
ths1 @ ths, ths2 @ [th1], ths3 @ [th2'], ctxt')
end;
- fun mk_ind_proof thy thss =
- Goal.prove_global thy [] prems' concl' (fn {prems = ihyps, context = ctxt} =>
+ fun mk_ind_proof ctxt' thss =
+ Goal.prove ctxt' [] prems' concl' (fn {prems = ihyps, context = ctxt} =>
let val th = Goal.prove ctxt [] [] concl (fn {context, ...} =>
rtac raw_induct 1 THEN
EVERY (maps (fn (((((_, sets, oprems, _),
@@ -363,7 +364,7 @@
fold_rev (NominalPackage.mk_perm []) pis t) sets';
val (P, ts) = strip_comb (HOLogic.dest_Trueprop (term_of concl));
val gprems1 = List.mapPartial (fn (th, t) =>
- if null (OldTerm.term_frees t inter ps) then SOME th
+ if null (preds_of ps t) then SOME th
else
map_thm ctxt' (split_conj (K o I) names)
(etac conjunct1 1) monos NONE th)
@@ -405,7 +406,7 @@
(fold_rev (mk_perm_bool o cterm_of thy)
(pis' @ pis) th));
val gprems2 = map (fn (th, t) =>
- if null (OldTerm.term_frees t inter ps) then mk_pi th
+ if null (preds_of ps t) then mk_pi th
else
mk_pi (the (map_thm ctxt (inst_conj_all names ps (rev pis''))
(inst_conj_all_tac (length pis'')) monos (SOME t) th)))
@@ -435,38 +436,40 @@
REPEAT (REPEAT (resolve_tac [conjI, impI] 1) THEN
etac impE 1 THEN atac 1 THEN REPEAT (etac @{thm allE_Nil} 1) THEN
asm_full_simp_tac (simpset_of thy) 1)
- end);
+ end) |> singleton (ProofContext.export ctxt' ctxt);
in
- thy |>
- ProofContext.init |>
- Proof.theorem_i NONE (fn thss => ProofContext.theory (fn thy =>
+ ctxt'' |>
+ Proof.theorem_i NONE (fn thss => fn ctxt =>
let
- val ctxt = ProofContext.init thy;
val rec_name = space_implode "_" (map Sign.base_name names);
+ val rec_qualified = Binding.qualify rec_name;
val ind_case_names = RuleCases.case_names induct_cases;
val induct_cases' = InductivePackage.partition_rules' raw_induct
(intrs ~~ induct_cases);
val thss' = map (map atomize_intr) thss;
val thsss = InductivePackage.partition_rules' raw_induct (intrs ~~ thss');
val strong_raw_induct =
- mk_ind_proof thy thss' |> InductivePackage.rulify;
+ mk_ind_proof ctxt thss' |> InductivePackage.rulify;
val strong_induct =
if length names > 1 then
(strong_raw_induct, [ind_case_names, RuleCases.consumes 0])
else (strong_raw_induct RSN (2, rev_mp),
[ind_case_names, RuleCases.consumes 1]);
- val ([strong_induct'], thy') = thy |>
- Sign.add_path rec_name |>
- PureThy.add_thms [((Binding.name "strong_induct", #1 strong_induct), #2 strong_induct)];
+ val ((_, [strong_induct']), ctxt') = LocalTheory.note Thm.theoremK
+ ((rec_qualified (Binding.name "strong_induct"),
+ map (Attrib.internal o K) (#2 strong_induct)), [#1 strong_induct])
+ ctxt;
val strong_inducts =
- ProjectRule.projects ctxt (1 upto length names) strong_induct'
+ ProjectRule.projects ctxt' (1 upto length names) strong_induct'
in
- thy' |>
- PureThy.add_thmss [((Binding.name "strong_inducts", strong_inducts),
- [ind_case_names, RuleCases.consumes 1])] |> snd |>
- Sign.parent_path
- end))
+ ctxt' |>
+ LocalTheory.note Thm.theoremK
+ ((rec_qualified (Binding.name "strong_inducts"),
+ [Attrib.internal (K ind_case_names),
+ Attrib.internal (K (RuleCases.consumes 1))]),
+ strong_inducts) |> snd
+ end)
(map (map (rulify_term thy #> rpair [])) vc_compat)
end;
@@ -476,11 +479,11 @@
local structure P = OuterParse and K = OuterKeyword in
val _ =
- OuterSyntax.command "nominal_inductive2"
+ OuterSyntax.local_theory_to_proof "nominal_inductive2"
"prove strong induction theorem for inductive predicate involving nominal datatypes" K.thy_goal
- (P.name -- Scan.optional (P.$$$ "avoids" |-- P.enum1 "|" (P.name --
+ (P.xname -- Scan.optional (P.$$$ "avoids" |-- P.enum1 "|" (P.name --
(P.$$$ ":" |-- P.and_list1 P.term))) [] >> (fn (name, avoids) =>
- Toplevel.print o Toplevel.theory_to_proof (prove_strong_ind name avoids)));
+ prove_strong_ind name avoids));
end;
--- a/src/HOL/Nominal/nominal_thmdecls.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Nominal/nominal_thmdecls.ML Thu Feb 26 11:21:29 2009 +0000
@@ -1,5 +1,4 @@
-(* ID: "$Id$"
- Authors: Julien Narboux and Christian Urban
+(* Authors: Julien Narboux and Christian Urban
This file introduces the infrastructure for the lemma
declaration "eqvts" "bijs" and "freshs".
@@ -63,10 +62,11 @@
then tac THEN print_tac ("after "^msg)
else tac
-fun tactic_eqvt ctx orig_thm pi typi =
+fun tactic_eqvt ctx orig_thm pi pi' =
let
- val mypi = Thm.cterm_of ctx (Var (pi,typi))
- val mypifree = Thm.cterm_of ctx (Const ("List.rev",typi --> typi) $ Free (fst pi,typi))
+ val mypi = Thm.cterm_of ctx pi
+ val T = fastype_of pi'
+ val mypifree = Thm.cterm_of ctx (Const ("List.rev", T --> T) $ pi')
val perm_pi_simp = PureThy.get_thms ctx "perm_pi_simp"
in
EVERY [tactic ("iffI applied",rtac iffI 1),
@@ -80,14 +80,19 @@
full_simp_tac (HOL_basic_ss addsimps perm_pi_simp) 1)]
end;
-fun get_derived_thm thy hyp concl orig_thm pi typi =
- let
- val lhs = (Const("Nominal.perm", typi --> HOLogic.boolT --> HOLogic.boolT) $ Var(pi,typi) $ hyp)
- val goal_term = Logic.unvarify (HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs,concl)))
- val _ = Display.print_cterm (cterm_of thy goal_term)
- in
- Goal.prove_global thy [] [] goal_term (fn _ => (tactic_eqvt thy orig_thm pi typi))
- end
+fun get_derived_thm ctxt hyp concl orig_thm pi typi =
+ let
+ val thy = ProofContext.theory_of ctxt;
+ val pi' = Var (pi, typi);
+ val lhs = Const ("Nominal.perm", typi --> HOLogic.boolT --> HOLogic.boolT) $ pi' $ hyp;
+ val ([goal_term, pi''], ctxt') = Variable.import_terms false
+ [HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, concl)), pi'] ctxt
+ val _ = Display.print_cterm (cterm_of thy goal_term)
+ in
+ Goal.prove ctxt' [] [] goal_term
+ (fn _ => tactic_eqvt thy orig_thm pi' pi'') |>
+ singleton (ProofContext.export ctxt' ctxt)
+ end
(* replaces every variable x in t with pi o x *)
fun apply_pi trm (pi,typi) =
@@ -145,7 +150,8 @@
if (apply_pi hyp (pi,typi) = concl)
then
(warning ("equivariance lemma of the relational form");
- [orig_thm, get_derived_thm thy hyp concl orig_thm pi typi])
+ [orig_thm,
+ get_derived_thm (Context.proof_of context) hyp concl orig_thm pi typi])
else raise EQVT_FORM "Type Implication"
end
(* case: eqvt-lemma is of the equational form *)
--- a/src/HOL/NumberTheory/Chinese.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/NumberTheory/Chinese.thy Thu Feb 26 11:21:29 2009 +0000
@@ -90,10 +90,8 @@
"k \<le> i --> i \<le> k + l --> mf i dvd funprod mf k l"
apply (induct l)
apply auto
- apply (rule_tac [1] zdvd_zmult2)
- apply (rule_tac [2] zdvd_zmult)
- apply (subgoal_tac "i = Suc (k + l)")
- apply (simp_all (no_asm_simp))
+ apply (subgoal_tac "i = Suc (k + l)")
+ apply (simp_all (no_asm_simp))
done
lemma funsum_mod:
@@ -101,9 +99,9 @@
apply (induct l)
apply auto
apply (rule trans)
- apply (rule zmod_zadd1_eq)
+ apply (rule mod_add_eq)
apply simp
- apply (rule zmod_zadd_right_eq [symmetric])
+ apply (rule mod_add_right_eq [symmetric])
done
lemma funsum_zero [rule_format (no_asm)]:
@@ -196,8 +194,8 @@
apply (case_tac [2] "i = n")
apply (simp_all (no_asm_simp))
apply (case_tac [3] "j < i")
- apply (rule_tac [3] zdvd_zmult2)
- apply (rule_tac [4] zdvd_zmult)
+ apply (rule_tac [3] dvd_mult2)
+ apply (rule_tac [4] dvd_mult)
apply (rule_tac [!] funprod_zdvd)
apply arith
apply arith
@@ -217,8 +215,8 @@
apply (subst funsum_mod)
apply (subst funsum_oneelem)
apply auto
- apply (subst zdvd_iff_zmod_eq_0 [symmetric])
- apply (rule zdvd_zmult)
+ apply (subst dvd_eq_mod_eq_0 [symmetric])
+ apply (rule dvd_mult)
apply (rule x_sol_lin_aux)
apply auto
done
@@ -237,21 +235,21 @@
apply (unfold lincong_sol_def)
apply safe
apply (tactic {* stac (thm "zcong_zmod") 3 *})
- apply (tactic {* stac (thm "zmod_zmult_distrib") 3 *})
- apply (tactic {* stac (thm "zmod_zdvd_zmod") 3 *})
- apply (tactic {* stac (thm "x_sol_lin") 5 *})
- apply (tactic {* stac (thm "zmod_zmult_distrib" RS sym) 7 *})
- apply (tactic {* stac (thm "zcong_zmod" RS sym) 7 *})
- apply (subgoal_tac [7]
+ apply (tactic {* stac (thm "mod_mult_eq") 3 *})
+ apply (tactic {* stac (thm "mod_mod_cancel") 3 *})
+ apply (tactic {* stac (thm "x_sol_lin") 4 *})
+ apply (tactic {* stac (thm "mod_mult_eq" RS sym) 6 *})
+ apply (tactic {* stac (thm "zcong_zmod" RS sym) 6 *})
+ apply (subgoal_tac [6]
"0 \<le> xilin_sol i n kf bf mf \<and> xilin_sol i n kf bf mf < mf i
\<and> [kf i * mhf mf n i * xilin_sol i n kf bf mf = bf i] (mod mf i)")
- prefer 7
+ prefer 6
apply (simp add: zmult_ac)
apply (unfold xilin_sol_def)
- apply (tactic {* asm_simp_tac @{simpset} 7 *})
- apply (rule_tac [7] ex1_implies_ex [THEN someI_ex])
- apply (rule_tac [7] unique_xi_sol)
- apply (rule_tac [4] funprod_zdvd)
+ apply (tactic {* asm_simp_tac @{simpset} 6 *})
+ apply (rule_tac [6] ex1_implies_ex [THEN someI_ex])
+ apply (rule_tac [6] unique_xi_sol)
+ apply (rule_tac [3] funprod_zdvd)
apply (unfold m_cond_def)
apply (rule funprod_pos [THEN pos_mod_sign])
apply (rule_tac [2] funprod_pos [THEN pos_mod_bound])
--- a/src/HOL/NumberTheory/Euler.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/NumberTheory/Euler.thy Thu Feb 26 11:21:29 2009 +0000
@@ -272,7 +272,7 @@
text {* \medskip Prove the final part of Euler's Criterion: *}
lemma aux__1: "[| ~([x = 0] (mod p)); [y ^ 2 = x] (mod p)|] ==> ~(p dvd y)"
- by (metis dvdI power2_eq_square zcong_sym zcong_trans zcong_zero_equiv_div zdvd_trans)
+ by (metis dvdI power2_eq_square zcong_sym zcong_trans zcong_zero_equiv_div dvd_trans)
lemma aux__2: "2 * nat((p - 1) div 2) = nat (2 * ((p - 1) div 2))"
by (auto simp add: nat_mult_distrib)
--- a/src/HOL/NumberTheory/EulerFermat.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/NumberTheory/EulerFermat.thy Thu Feb 26 11:21:29 2009 +0000
@@ -155,7 +155,7 @@
prefer 2
apply (subst zdvd_iff_zgcd [symmetric])
apply (rule_tac [4] zgcd_zcong_zgcd)
- apply (simp_all add: zdvd_zminus_iff zcong_sym)
+ apply (simp_all add: zcong_sym)
done
--- a/src/HOL/NumberTheory/Gauss.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/NumberTheory/Gauss.thy Thu Feb 26 11:21:29 2009 +0000
@@ -64,14 +64,14 @@
qed
lemma p_eq: "p = (2 * (p - 1) div 2) + 1"
- using zdiv_zmult_self2 [of 2 "p - 1"] by auto
+ using div_mult_self1_is_id [of 2 "p - 1"] by auto
lemma (in -) zodd_imp_zdiv_eq: "x \<in> zOdd ==> 2 * (x - 1) div 2 = 2 * ((x - 1) div 2)"
apply (frule odd_minus_one_even)
apply (simp add: zEven_def)
apply (subgoal_tac "2 \<noteq> 0")
- apply (frule_tac b = "2 :: int" and a = "x - 1" in zdiv_zmult_self2)
+ apply (frule_tac b = "2 :: int" and a = "x - 1" in div_mult_self1_is_id)
apply (auto simp add: even_div_2_prop2)
done
--- a/src/HOL/NumberTheory/Int2.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/NumberTheory/Int2.thy Thu Feb 26 11:21:29 2009 +0000
@@ -18,7 +18,7 @@
lemma zpower_zdvd_prop1:
"0 < n \<Longrightarrow> p dvd y \<Longrightarrow> p dvd ((y::int) ^ n)"
- by (induct n) (auto simp add: zdvd_zmult zdvd_zmult2 [of p y])
+ by (induct n) (auto simp add: dvd_mult2 [of p y])
lemma zdvd_bounds: "n dvd m ==> m \<le> (0::int) | n \<le> m"
proof -
@@ -42,7 +42,7 @@
apply simp
apply (frule zprime_zdvd_zmult_better)
apply simp
- apply force
+ apply (force simp del:dvd_mult)
done
lemma div_prop1: "[| 0 < z; (x::int) < y * z |] ==> x div z < y"
@@ -86,7 +86,7 @@
by (auto simp add: zcong_def)
lemma zcong_id: "[m = 0] (mod m)"
- by (auto simp add: zcong_def zdvd_0_right)
+ by (auto simp add: zcong_def)
lemma zcong_shift: "[a = b] (mod m) ==> [a + c = b + c] (mod m)"
by (auto simp add: zcong_refl zcong_zadd)
--- a/src/HOL/NumberTheory/IntPrimes.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/NumberTheory/IntPrimes.thy Thu Feb 26 11:21:29 2009 +0000
@@ -50,7 +50,7 @@
lemma zrelprime_zdvd_zmult_aux:
"zgcd n k = 1 ==> k dvd m * n ==> 0 \<le> m ==> k dvd m"
- by (metis abs_of_nonneg zdvd_triv_right zgcd_greatest_iff zgcd_zmult_distrib2_abs zmult_1_right)
+ by (metis abs_of_nonneg dvd_triv_right zgcd_greatest_iff zgcd_zmult_distrib2_abs zmult_1_right)
lemma zrelprime_zdvd_zmult: "zgcd n k = 1 ==> k dvd m * n ==> k dvd m"
apply (case_tac "0 \<le> m")
@@ -73,7 +73,7 @@
lemma zprime_imp_zrelprime:
"zprime p ==> \<not> p dvd n ==> zgcd n p = 1"
apply (auto simp add: zprime_def)
- apply (metis zgcd_commute zgcd_geq_zero zgcd_zdvd1 zgcd_zdvd2)
+ apply (metis zgcd_geq_zero zgcd_zdvd1 zgcd_zdvd2)
done
lemma zless_zprime_imp_zrelprime:
@@ -88,14 +88,12 @@
lemma zgcd_zadd_zmult [simp]: "zgcd (m + n * k) n = zgcd m n"
apply (rule zgcd_eq [THEN trans])
- apply (simp add: zmod_zadd1_eq)
+ apply (simp add: mod_add_eq)
apply (rule zgcd_eq [symmetric])
done
lemma zgcd_zdvd_zgcd_zmult: "zgcd m n dvd zgcd (k * m) n"
- apply (simp add: zgcd_greatest_iff)
- apply (blast intro: zdvd_trans dvd_triv_right)
- done
+by (simp add: zgcd_greatest_iff)
lemma zgcd_zmult_zdvd_zgcd:
"zgcd k n = 1 ==> zgcd (k * m) n dvd zgcd m n"
@@ -127,20 +125,20 @@
by (unfold zcong_def, auto)
lemma zcong_sym: "[a = b] (mod m) = [b = a] (mod m)"
- unfolding zcong_def minus_diff_eq [of a, symmetric] zdvd_zminus_iff ..
+ unfolding zcong_def minus_diff_eq [of a, symmetric] dvd_minus_iff ..
lemma zcong_zadd:
"[a = b] (mod m) ==> [c = d] (mod m) ==> [a + c = b + d] (mod m)"
apply (unfold zcong_def)
apply (rule_tac s = "(a - b) + (c - d)" in subst)
- apply (rule_tac [2] zdvd_zadd, auto)
+ apply (rule_tac [2] dvd_add, auto)
done
lemma zcong_zdiff:
"[a = b] (mod m) ==> [c = d] (mod m) ==> [a - c = b - d] (mod m)"
apply (unfold zcong_def)
apply (rule_tac s = "(a - b) - (c - d)" in subst)
- apply (rule_tac [2] zdvd_zdiff, auto)
+ apply (rule_tac [2] dvd_diff, auto)
done
lemma zcong_trans:
@@ -151,8 +149,8 @@
"[a = b] (mod m) ==> [c = d] (mod m) ==> [a * c = b * d] (mod m)"
apply (rule_tac b = "b * c" in zcong_trans)
apply (unfold zcong_def)
- apply (metis zdiff_zmult_distrib2 zdvd_zmult zmult_commute)
- apply (metis zdiff_zmult_distrib2 zdvd_zmult)
+ apply (metis zdiff_zmult_distrib2 dvd_mult zmult_commute)
+ apply (metis zdiff_zmult_distrib2 dvd_mult)
done
lemma zcong_scalar: "[a = b] (mod m) ==> [a * k = b * k] (mod m)"
@@ -163,7 +161,7 @@
lemma zcong_zmult_self: "[a * m = b * m] (mod m)"
apply (unfold zcong_def)
- apply (rule zdvd_zdiff, simp_all)
+ apply (rule dvd_diff, simp_all)
done
lemma zcong_square:
@@ -191,7 +189,7 @@
apply (simp_all add: zdiff_zmult_distrib)
apply (subgoal_tac "m dvd (-(a * k - b * k))")
apply simp
- apply (subst zdvd_zminus_iff, assumption)
+ apply (subst dvd_minus_iff, assumption)
done
lemma zcong_cancel2:
@@ -206,10 +204,10 @@
apply (subgoal_tac "m dvd n * ka")
apply (subgoal_tac "m dvd ka")
apply (case_tac [2] "0 \<le> ka")
- apply (metis zdvd_mult_div_cancel zdvd_refl zdvd_zminus2_iff zdvd_zmultD2 zgcd_zminus zmult_commute zmult_zminus zrelprime_zdvd_zmult)
- apply (metis IntDiv.zdvd_abs1 abs_of_nonneg zadd_0 zgcd_0_left zgcd_commute zgcd_zadd_zmult zgcd_zdvd_zgcd_zmult zgcd_zmult_distrib2_abs zmult_1_right zmult_commute)
- apply (metis abs_eq_0 int_0_neq_1 mult_le_0_iff zdvd_mono zdvd_mult_cancel zdvd_mult_cancel1 zdvd_refl zdvd_triv_left zdvd_zmult2 zero_le_mult_iff zgcd_greatest_iff zle_anti_sym zle_linear zle_refl zmult_commute zrelprime_zdvd_zmult)
- apply (metis zdvd_triv_left)
+ apply (metis zdvd_mult_div_cancel dvd_refl dvd_mult_left zmult_commute zrelprime_zdvd_zmult)
+ apply (metis abs_dvd_iff abs_of_nonneg zadd_0 zgcd_0_left zgcd_commute zgcd_zadd_zmult zgcd_zdvd_zgcd_zmult zgcd_zmult_distrib2_abs zmult_1_right zmult_commute)
+ apply (metis mult_le_0_iff zdvd_mono zdvd_mult_cancel dvd_triv_left zero_le_mult_iff zle_anti_sym zle_linear zle_refl zmult_commute zrelprime_zdvd_zmult)
+ apply (metis dvd_triv_left)
done
lemma zcong_zless_imp_eq:
@@ -217,7 +215,7 @@
a < m ==> 0 \<le> b ==> b < m ==> [a = b] (mod m) ==> a = b"
apply (unfold zcong_def dvd_def, auto)
apply (drule_tac f = "\<lambda>z. z mod m" in arg_cong)
- apply (metis diff_add_cancel mod_pos_pos_trivial zadd_0 zadd_commute zmod_eq_0_iff zmod_zadd_right_eq)
+ apply (metis diff_add_cancel mod_pos_pos_trivial zadd_0 zadd_commute zmod_eq_0_iff mod_add_right_eq)
done
lemma zcong_square_zless:
@@ -237,7 +235,7 @@
lemma zcong_zless_0:
"0 \<le> a ==> a < m ==> [a = 0] (mod m) ==> a = 0"
apply (unfold zcong_def dvd_def, auto)
- apply (metis div_pos_pos_trivial linorder_not_less zdiv_zmult_self2 zle_refl zle_trans)
+ apply (metis div_pos_pos_trivial linorder_not_less div_mult_self1_is_id)
done
lemma zcong_zless_unique:
@@ -302,7 +300,7 @@
lemma zmod_zdvd_zmod:
"0 < (m::int) ==> m dvd b ==> (a mod b mod m) = (a mod m)"
- by (rule zmod_zmod_cancel)
+ by (rule mod_mod_cancel)
subsection {* Extended GCD *}
@@ -403,7 +401,7 @@
prefer 2
apply simp
apply (unfold zcong_def)
- apply (simp (no_asm) add: zmult_commute zdvd_zminus_iff)
+ apply (simp (no_asm) add: zmult_commute)
done
lemma zcong_lineq_unique:
--- a/src/HOL/NumberTheory/Quadratic_Reciprocity.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/NumberTheory/Quadratic_Reciprocity.thy Thu Feb 26 11:21:29 2009 +0000
@@ -322,7 +322,7 @@
by (rule zdiv_mono1) (insert p_g_2, auto)
then show "b \<le> (q * a) div p"
apply (subgoal_tac "p \<noteq> 0")
- apply (frule zdiv_zmult_self2, force)
+ apply (frule div_mult_self1_is_id, force)
apply (insert p_g_2, auto)
done
qed
@@ -356,7 +356,7 @@
by (rule zdiv_mono1) (insert q_g_2, auto)
then show "a \<le> (p * b) div q"
apply (subgoal_tac "q \<noteq> 0")
- apply (frule zdiv_zmult_self2, force)
+ apply (frule div_mult_self1_is_id, force)
apply (insert q_g_2, auto)
done
qed
--- a/src/HOL/NumberTheory/Residues.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/NumberTheory/Residues.thy Thu Feb 26 11:21:29 2009 +0000
@@ -48,12 +48,12 @@
by (auto simp add: StandardRes_def zcong_zmod_eq)
lemma StandardRes_prop3: "(~[x = 0] (mod p)) = (~(StandardRes p x = 0))"
- by (auto simp add: StandardRes_def zcong_def zdvd_iff_zmod_eq_0)
+ by (auto simp add: StandardRes_def zcong_def dvd_eq_mod_eq_0)
lemma StandardRes_prop4: "2 < m
==> [StandardRes m x * StandardRes m y = (x * y)] (mod m)"
by (auto simp add: StandardRes_def zcong_zmod_eq
- zmod_zmult_distrib [of x y m])
+ mod_mult_eq [of x y m])
lemma StandardRes_lbound: "0 < p ==> 0 \<le> StandardRes p x"
by (auto simp add: StandardRes_def pos_mod_sign)
--- a/src/HOL/NumberTheory/WilsonBij.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/NumberTheory/WilsonBij.thy Thu Feb 26 11:21:29 2009 +0000
@@ -57,7 +57,7 @@
apply (rule_tac [2] zdvd_not_zless)
apply (subgoal_tac "p dvd 1")
prefer 2
- apply (subst zdvd_zminus_iff [symmetric])
+ apply (subst dvd_minus_iff [symmetric])
apply auto
done
@@ -79,7 +79,7 @@
apply (simp add: OrderedGroup.diff_diff_eq diff_diff_eq2 zdiff_zmult_distrib2)
apply (rule_tac s = "p dvd -((a + 1) + (p * -a))" in trans)
apply (simp add: mult_commute)
- apply (subst zdvd_zminus_iff)
+ apply (subst dvd_minus_iff)
apply (subst zdvd_reduce)
apply (rule_tac s = "p dvd (a + 1) + (p * -1)" in trans)
apply (subst zdvd_reduce)
--- a/src/HOL/NumberTheory/WilsonRuss.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/NumberTheory/WilsonRuss.thy Thu Feb 26 11:21:29 2009 +0000
@@ -68,7 +68,7 @@
apply (rule_tac [2] zdvd_not_zless)
apply (subgoal_tac "p dvd 1")
prefer 2
- apply (subst zdvd_zminus_iff [symmetric], auto)
+ apply (subst dvd_minus_iff [symmetric], auto)
done
lemma inv_not_1:
@@ -87,7 +87,7 @@
apply (simp add: OrderedGroup.diff_diff_eq diff_diff_eq2 zdiff_zmult_distrib2)
apply (rule_tac s = "p dvd -((a + 1) + (p * -a))" in trans)
apply (simp add: mult_commute)
- apply (subst zdvd_zminus_iff)
+ apply (subst dvd_minus_iff)
apply (subst zdvd_reduce)
apply (rule_tac s = "p dvd (a + 1) + (p * -1)" in trans)
apply (subst zdvd_reduce, auto)
--- a/src/HOL/Parity.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Parity.thy Thu Feb 26 11:21:29 2009 +0000
@@ -228,20 +228,9 @@
lemma zero_le_odd_power: "odd n ==>
(0 <= (x::'a::{recpower,ordered_idom}) ^ n) = (0 <= x)"
- apply (simp add: odd_nat_equiv_def2)
- apply (erule exE)
- apply (erule ssubst)
- apply (subst power_Suc)
- apply (subst power_add)
- apply (subst zero_le_mult_iff)
- apply auto
- apply (subgoal_tac "x = 0 & y > 0")
- apply (erule conjE, assumption)
- apply (subst power_eq_0_iff [symmetric])
- apply (subgoal_tac "0 <= x^y * x^y")
- apply simp
- apply (rule zero_le_square)+
- done
+apply (auto simp: odd_nat_equiv_def2 power_Suc power_add zero_le_mult_iff)
+apply (metis field_power_not_zero no_zero_divirors_neq0 order_antisym_conv zero_le_square)
+done
lemma zero_le_power_eq[presburger]: "(0 <= (x::'a::{recpower,ordered_idom}) ^ n) =
(even n | (odd n & 0 <= x))"
--- a/src/HOL/Plain.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Plain.thy Thu Feb 26 11:21:29 2009 +0000
@@ -1,7 +1,7 @@
header {* Plain HOL *}
theory Plain
-imports Datatype FunDef Record Extraction Divides Fact
+imports Datatype FunDef Record Extraction Divides
begin
text {*
--- a/src/HOL/Polynomial.thy Thu Feb 26 11:18:40 2009 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,1305 +0,0 @@
-(* Title: HOL/Polynomial.thy
- Author: Brian Huffman
- Based on an earlier development by Clemens Ballarin
-*)
-
-header {* Univariate Polynomials *}
-
-theory Polynomial
-imports Plain SetInterval Main
-begin
-
-subsection {* Definition of type @{text poly} *}
-
-typedef (Poly) 'a poly = "{f::nat \<Rightarrow> 'a::zero. \<exists>n. \<forall>i>n. f i = 0}"
- morphisms coeff Abs_poly
- by auto
-
-lemma expand_poly_eq: "p = q \<longleftrightarrow> (\<forall>n. coeff p n = coeff q n)"
-by (simp add: coeff_inject [symmetric] expand_fun_eq)
-
-lemma poly_ext: "(\<And>n. coeff p n = coeff q n) \<Longrightarrow> p = q"
-by (simp add: expand_poly_eq)
-
-
-subsection {* Degree of a polynomial *}
-
-definition
- degree :: "'a::zero poly \<Rightarrow> nat" where
- "degree p = (LEAST n. \<forall>i>n. coeff p i = 0)"
-
-lemma coeff_eq_0: "degree p < n \<Longrightarrow> coeff p n = 0"
-proof -
- have "coeff p \<in> Poly"
- by (rule coeff)
- hence "\<exists>n. \<forall>i>n. coeff p i = 0"
- unfolding Poly_def by simp
- hence "\<forall>i>degree p. coeff p i = 0"
- unfolding degree_def by (rule LeastI_ex)
- moreover assume "degree p < n"
- ultimately show ?thesis by simp
-qed
-
-lemma le_degree: "coeff p n \<noteq> 0 \<Longrightarrow> n \<le> degree p"
- by (erule contrapos_np, rule coeff_eq_0, simp)
-
-lemma degree_le: "\<forall>i>n. coeff p i = 0 \<Longrightarrow> degree p \<le> n"
- unfolding degree_def by (erule Least_le)
-
-lemma less_degree_imp: "n < degree p \<Longrightarrow> \<exists>i>n. coeff p i \<noteq> 0"
- unfolding degree_def by (drule not_less_Least, simp)
-
-
-subsection {* The zero polynomial *}
-
-instantiation poly :: (zero) zero
-begin
-
-definition
- zero_poly_def: "0 = Abs_poly (\<lambda>n. 0)"
-
-instance ..
-end
-
-lemma coeff_0 [simp]: "coeff 0 n = 0"
- unfolding zero_poly_def
- by (simp add: Abs_poly_inverse Poly_def)
-
-lemma degree_0 [simp]: "degree 0 = 0"
- by (rule order_antisym [OF degree_le le0]) simp
-
-lemma leading_coeff_neq_0:
- assumes "p \<noteq> 0" shows "coeff p (degree p) \<noteq> 0"
-proof (cases "degree p")
- case 0
- from `p \<noteq> 0` have "\<exists>n. coeff p n \<noteq> 0"
- by (simp add: expand_poly_eq)
- then obtain n where "coeff p n \<noteq> 0" ..
- hence "n \<le> degree p" by (rule le_degree)
- with `coeff p n \<noteq> 0` and `degree p = 0`
- show "coeff p (degree p) \<noteq> 0" by simp
-next
- case (Suc n)
- from `degree p = Suc n` have "n < degree p" by simp
- hence "\<exists>i>n. coeff p i \<noteq> 0" by (rule less_degree_imp)
- then obtain i where "n < i" and "coeff p i \<noteq> 0" by fast
- from `degree p = Suc n` and `n < i` have "degree p \<le> i" by simp
- also from `coeff p i \<noteq> 0` have "i \<le> degree p" by (rule le_degree)
- finally have "degree p = i" .
- with `coeff p i \<noteq> 0` show "coeff p (degree p) \<noteq> 0" by simp
-qed
-
-lemma leading_coeff_0_iff [simp]: "coeff p (degree p) = 0 \<longleftrightarrow> p = 0"
- by (cases "p = 0", simp, simp add: leading_coeff_neq_0)
-
-
-subsection {* List-style constructor for polynomials *}
-
-definition
- pCons :: "'a::zero \<Rightarrow> 'a poly \<Rightarrow> 'a poly"
-where
- [code del]: "pCons a p = Abs_poly (nat_case a (coeff p))"
-
-syntax
- "_poly" :: "args \<Rightarrow> 'a poly" ("[:(_):]")
-
-translations
- "[:x, xs:]" == "CONST pCons x [:xs:]"
- "[:x:]" == "CONST pCons x 0"
-
-lemma Poly_nat_case: "f \<in> Poly \<Longrightarrow> nat_case a f \<in> Poly"
- unfolding Poly_def by (auto split: nat.split)
-
-lemma coeff_pCons:
- "coeff (pCons a p) = nat_case a (coeff p)"
- unfolding pCons_def
- by (simp add: Abs_poly_inverse Poly_nat_case coeff)
-
-lemma coeff_pCons_0 [simp]: "coeff (pCons a p) 0 = a"
- by (simp add: coeff_pCons)
-
-lemma coeff_pCons_Suc [simp]: "coeff (pCons a p) (Suc n) = coeff p n"
- by (simp add: coeff_pCons)
-
-lemma degree_pCons_le: "degree (pCons a p) \<le> Suc (degree p)"
-by (rule degree_le, simp add: coeff_eq_0 coeff_pCons split: nat.split)
-
-lemma degree_pCons_eq:
- "p \<noteq> 0 \<Longrightarrow> degree (pCons a p) = Suc (degree p)"
-apply (rule order_antisym [OF degree_pCons_le])
-apply (rule le_degree, simp)
-done
-
-lemma degree_pCons_0: "degree (pCons a 0) = 0"
-apply (rule order_antisym [OF _ le0])
-apply (rule degree_le, simp add: coeff_pCons split: nat.split)
-done
-
-lemma degree_pCons_eq_if [simp]:
- "degree (pCons a p) = (if p = 0 then 0 else Suc (degree p))"
-apply (cases "p = 0", simp_all)
-apply (rule order_antisym [OF _ le0])
-apply (rule degree_le, simp add: coeff_pCons split: nat.split)
-apply (rule order_antisym [OF degree_pCons_le])
-apply (rule le_degree, simp)
-done
-
-lemma pCons_0_0 [simp]: "pCons 0 0 = 0"
-by (rule poly_ext, simp add: coeff_pCons split: nat.split)
-
-lemma pCons_eq_iff [simp]:
- "pCons a p = pCons b q \<longleftrightarrow> a = b \<and> p = q"
-proof (safe)
- assume "pCons a p = pCons b q"
- then have "coeff (pCons a p) 0 = coeff (pCons b q) 0" by simp
- then show "a = b" by simp
-next
- assume "pCons a p = pCons b q"
- then have "\<forall>n. coeff (pCons a p) (Suc n) =
- coeff (pCons b q) (Suc n)" by simp
- then show "p = q" by (simp add: expand_poly_eq)
-qed
-
-lemma pCons_eq_0_iff [simp]: "pCons a p = 0 \<longleftrightarrow> a = 0 \<and> p = 0"
- using pCons_eq_iff [of a p 0 0] by simp
-
-lemma Poly_Suc: "f \<in> Poly \<Longrightarrow> (\<lambda>n. f (Suc n)) \<in> Poly"
- unfolding Poly_def
- by (clarify, rule_tac x=n in exI, simp)
-
-lemma pCons_cases [cases type: poly]:
- obtains (pCons) a q where "p = pCons a q"
-proof
- show "p = pCons (coeff p 0) (Abs_poly (\<lambda>n. coeff p (Suc n)))"
- by (rule poly_ext)
- (simp add: Abs_poly_inverse Poly_Suc coeff coeff_pCons
- split: nat.split)
-qed
-
-lemma pCons_induct [case_names 0 pCons, induct type: poly]:
- assumes zero: "P 0"
- assumes pCons: "\<And>a p. P p \<Longrightarrow> P (pCons a p)"
- shows "P p"
-proof (induct p rule: measure_induct_rule [where f=degree])
- case (less p)
- obtain a q where "p = pCons a q" by (rule pCons_cases)
- have "P q"
- proof (cases "q = 0")
- case True
- then show "P q" by (simp add: zero)
- next
- case False
- then have "degree (pCons a q) = Suc (degree q)"
- by (rule degree_pCons_eq)
- then have "degree q < degree p"
- using `p = pCons a q` by simp
- then show "P q"
- by (rule less.hyps)
- qed
- then have "P (pCons a q)"
- by (rule pCons)
- then show ?case
- using `p = pCons a q` by simp
-qed
-
-
-subsection {* Recursion combinator for polynomials *}
-
-function
- poly_rec :: "'b \<Rightarrow> ('a::zero \<Rightarrow> 'a poly \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a poly \<Rightarrow> 'b"
-where
- poly_rec_pCons_eq_if [simp del, code del]:
- "poly_rec z f (pCons a p) = f a p (if p = 0 then z else poly_rec z f p)"
-by (case_tac x, rename_tac q, case_tac q, auto)
-
-termination poly_rec
-by (relation "measure (degree \<circ> snd \<circ> snd)", simp)
- (simp add: degree_pCons_eq)
-
-lemma poly_rec_0:
- "f 0 0 z = z \<Longrightarrow> poly_rec z f 0 = z"
- using poly_rec_pCons_eq_if [of z f 0 0] by simp
-
-lemma poly_rec_pCons:
- "f 0 0 z = z \<Longrightarrow> poly_rec z f (pCons a p) = f a p (poly_rec z f p)"
- by (simp add: poly_rec_pCons_eq_if poly_rec_0)
-
-
-subsection {* Monomials *}
-
-definition
- monom :: "'a \<Rightarrow> nat \<Rightarrow> 'a::zero poly" where
- "monom a m = Abs_poly (\<lambda>n. if m = n then a else 0)"
-
-lemma coeff_monom [simp]: "coeff (monom a m) n = (if m=n then a else 0)"
- unfolding monom_def
- by (subst Abs_poly_inverse, auto simp add: Poly_def)
-
-lemma monom_0: "monom a 0 = pCons a 0"
- by (rule poly_ext, simp add: coeff_pCons split: nat.split)
-
-lemma monom_Suc: "monom a (Suc n) = pCons 0 (monom a n)"
- by (rule poly_ext, simp add: coeff_pCons split: nat.split)
-
-lemma monom_eq_0 [simp]: "monom 0 n = 0"
- by (rule poly_ext) simp
-
-lemma monom_eq_0_iff [simp]: "monom a n = 0 \<longleftrightarrow> a = 0"
- by (simp add: expand_poly_eq)
-
-lemma monom_eq_iff [simp]: "monom a n = monom b n \<longleftrightarrow> a = b"
- by (simp add: expand_poly_eq)
-
-lemma degree_monom_le: "degree (monom a n) \<le> n"
- by (rule degree_le, simp)
-
-lemma degree_monom_eq: "a \<noteq> 0 \<Longrightarrow> degree (monom a n) = n"
- apply (rule order_antisym [OF degree_monom_le])
- apply (rule le_degree, simp)
- done
-
-
-subsection {* Addition and subtraction *}
-
-instantiation poly :: (comm_monoid_add) comm_monoid_add
-begin
-
-definition
- plus_poly_def [code del]:
- "p + q = Abs_poly (\<lambda>n. coeff p n + coeff q n)"
-
-lemma Poly_add:
- fixes f g :: "nat \<Rightarrow> 'a"
- shows "\<lbrakk>f \<in> Poly; g \<in> Poly\<rbrakk> \<Longrightarrow> (\<lambda>n. f n + g n) \<in> Poly"
- unfolding Poly_def
- apply (clarify, rename_tac m n)
- apply (rule_tac x="max m n" in exI, simp)
- done
-
-lemma coeff_add [simp]:
- "coeff (p + q) n = coeff p n + coeff q n"
- unfolding plus_poly_def
- by (simp add: Abs_poly_inverse coeff Poly_add)
-
-instance proof
- fix p q r :: "'a poly"
- show "(p + q) + r = p + (q + r)"
- by (simp add: expand_poly_eq add_assoc)
- show "p + q = q + p"
- by (simp add: expand_poly_eq add_commute)
- show "0 + p = p"
- by (simp add: expand_poly_eq)
-qed
-
-end
-
-instance poly :: (cancel_comm_monoid_add) cancel_comm_monoid_add
-proof
- fix p q r :: "'a poly"
- assume "p + q = p + r" thus "q = r"
- by (simp add: expand_poly_eq)
-qed
-
-instantiation poly :: (ab_group_add) ab_group_add
-begin
-
-definition
- uminus_poly_def [code del]:
- "- p = Abs_poly (\<lambda>n. - coeff p n)"
-
-definition
- minus_poly_def [code del]:
- "p - q = Abs_poly (\<lambda>n. coeff p n - coeff q n)"
-
-lemma Poly_minus:
- fixes f :: "nat \<Rightarrow> 'a"
- shows "f \<in> Poly \<Longrightarrow> (\<lambda>n. - f n) \<in> Poly"
- unfolding Poly_def by simp
-
-lemma Poly_diff:
- fixes f g :: "nat \<Rightarrow> 'a"
- shows "\<lbrakk>f \<in> Poly; g \<in> Poly\<rbrakk> \<Longrightarrow> (\<lambda>n. f n - g n) \<in> Poly"
- unfolding diff_minus by (simp add: Poly_add Poly_minus)
-
-lemma coeff_minus [simp]: "coeff (- p) n = - coeff p n"
- unfolding uminus_poly_def
- by (simp add: Abs_poly_inverse coeff Poly_minus)
-
-lemma coeff_diff [simp]:
- "coeff (p - q) n = coeff p n - coeff q n"
- unfolding minus_poly_def
- by (simp add: Abs_poly_inverse coeff Poly_diff)
-
-instance proof
- fix p q :: "'a poly"
- show "- p + p = 0"
- by (simp add: expand_poly_eq)
- show "p - q = p + - q"
- by (simp add: expand_poly_eq diff_minus)
-qed
-
-end
-
-lemma add_pCons [simp]:
- "pCons a p + pCons b q = pCons (a + b) (p + q)"
- by (rule poly_ext, simp add: coeff_pCons split: nat.split)
-
-lemma minus_pCons [simp]:
- "- pCons a p = pCons (- a) (- p)"
- by (rule poly_ext, simp add: coeff_pCons split: nat.split)
-
-lemma diff_pCons [simp]:
- "pCons a p - pCons b q = pCons (a - b) (p - q)"
- by (rule poly_ext, simp add: coeff_pCons split: nat.split)
-
-lemma degree_add_le_max: "degree (p + q) \<le> max (degree p) (degree q)"
- by (rule degree_le, auto simp add: coeff_eq_0)
-
-lemma degree_add_le:
- "\<lbrakk>degree p \<le> n; degree q \<le> n\<rbrakk> \<Longrightarrow> degree (p + q) \<le> n"
- by (auto intro: order_trans degree_add_le_max)
-
-lemma degree_add_less:
- "\<lbrakk>degree p < n; degree q < n\<rbrakk> \<Longrightarrow> degree (p + q) < n"
- by (auto intro: le_less_trans degree_add_le_max)
-
-lemma degree_add_eq_right:
- "degree p < degree q \<Longrightarrow> degree (p + q) = degree q"
- apply (cases "q = 0", simp)
- apply (rule order_antisym)
- apply (simp add: degree_add_le)
- apply (rule le_degree)
- apply (simp add: coeff_eq_0)
- done
-
-lemma degree_add_eq_left:
- "degree q < degree p \<Longrightarrow> degree (p + q) = degree p"
- using degree_add_eq_right [of q p]
- by (simp add: add_commute)
-
-lemma degree_minus [simp]: "degree (- p) = degree p"
- unfolding degree_def by simp
-
-lemma degree_diff_le_max: "degree (p - q) \<le> max (degree p) (degree q)"
- using degree_add_le [where p=p and q="-q"]
- by (simp add: diff_minus)
-
-lemma degree_diff_le:
- "\<lbrakk>degree p \<le> n; degree q \<le> n\<rbrakk> \<Longrightarrow> degree (p - q) \<le> n"
- by (simp add: diff_minus degree_add_le)
-
-lemma degree_diff_less:
- "\<lbrakk>degree p < n; degree q < n\<rbrakk> \<Longrightarrow> degree (p - q) < n"
- by (simp add: diff_minus degree_add_less)
-
-lemma add_monom: "monom a n + monom b n = monom (a + b) n"
- by (rule poly_ext) simp
-
-lemma diff_monom: "monom a n - monom b n = monom (a - b) n"
- by (rule poly_ext) simp
-
-lemma minus_monom: "- monom a n = monom (-a) n"
- by (rule poly_ext) simp
-
-lemma coeff_setsum: "coeff (\<Sum>x\<in>A. p x) i = (\<Sum>x\<in>A. coeff (p x) i)"
- by (cases "finite A", induct set: finite, simp_all)
-
-lemma monom_setsum: "monom (\<Sum>x\<in>A. a x) n = (\<Sum>x\<in>A. monom (a x) n)"
- by (rule poly_ext) (simp add: coeff_setsum)
-
-
-subsection {* Multiplication by a constant *}
-
-definition
- smult :: "'a::comm_semiring_0 \<Rightarrow> 'a poly \<Rightarrow> 'a poly" where
- "smult a p = Abs_poly (\<lambda>n. a * coeff p n)"
-
-lemma Poly_smult:
- fixes f :: "nat \<Rightarrow> 'a::comm_semiring_0"
- shows "f \<in> Poly \<Longrightarrow> (\<lambda>n. a * f n) \<in> Poly"
- unfolding Poly_def
- by (clarify, rule_tac x=n in exI, simp)
-
-lemma coeff_smult [simp]: "coeff (smult a p) n = a * coeff p n"
- unfolding smult_def
- by (simp add: Abs_poly_inverse Poly_smult coeff)
-
-lemma degree_smult_le: "degree (smult a p) \<le> degree p"
- by (rule degree_le, simp add: coeff_eq_0)
-
-lemma smult_smult [simp]: "smult a (smult b p) = smult (a * b) p"
- by (rule poly_ext, simp add: mult_assoc)
-
-lemma smult_0_right [simp]: "smult a 0 = 0"
- by (rule poly_ext, simp)
-
-lemma smult_0_left [simp]: "smult 0 p = 0"
- by (rule poly_ext, simp)
-
-lemma smult_1_left [simp]: "smult (1::'a::comm_semiring_1) p = p"
- by (rule poly_ext, simp)
-
-lemma smult_add_right:
- "smult a (p + q) = smult a p + smult a q"
- by (rule poly_ext, simp add: algebra_simps)
-
-lemma smult_add_left:
- "smult (a + b) p = smult a p + smult b p"
- by (rule poly_ext, simp add: algebra_simps)
-
-lemma smult_minus_right [simp]:
- "smult (a::'a::comm_ring) (- p) = - smult a p"
- by (rule poly_ext, simp)
-
-lemma smult_minus_left [simp]:
- "smult (- a::'a::comm_ring) p = - smult a p"
- by (rule poly_ext, simp)
-
-lemma smult_diff_right:
- "smult (a::'a::comm_ring) (p - q) = smult a p - smult a q"
- by (rule poly_ext, simp add: algebra_simps)
-
-lemma smult_diff_left:
- "smult (a - b::'a::comm_ring) p = smult a p - smult b p"
- by (rule poly_ext, simp add: algebra_simps)
-
-lemmas smult_distribs =
- smult_add_left smult_add_right
- smult_diff_left smult_diff_right
-
-lemma smult_pCons [simp]:
- "smult a (pCons b p) = pCons (a * b) (smult a p)"
- by (rule poly_ext, simp add: coeff_pCons split: nat.split)
-
-lemma smult_monom: "smult a (monom b n) = monom (a * b) n"
- by (induct n, simp add: monom_0, simp add: monom_Suc)
-
-lemma degree_smult_eq [simp]:
- fixes a :: "'a::idom"
- shows "degree (smult a p) = (if a = 0 then 0 else degree p)"
- by (cases "a = 0", simp, simp add: degree_def)
-
-lemma smult_eq_0_iff [simp]:
- fixes a :: "'a::idom"
- shows "smult a p = 0 \<longleftrightarrow> a = 0 \<or> p = 0"
- by (simp add: expand_poly_eq)
-
-
-subsection {* Multiplication of polynomials *}
-
-text {* TODO: move to SetInterval.thy *}
-lemma setsum_atMost_Suc_shift:
- fixes f :: "nat \<Rightarrow> 'a::comm_monoid_add"
- shows "(\<Sum>i\<le>Suc n. f i) = f 0 + (\<Sum>i\<le>n. f (Suc i))"
-proof (induct n)
- case 0 show ?case by simp
-next
- case (Suc n) note IH = this
- have "(\<Sum>i\<le>Suc (Suc n). f i) = (\<Sum>i\<le>Suc n. f i) + f (Suc (Suc n))"
- by (rule setsum_atMost_Suc)
- also have "(\<Sum>i\<le>Suc n. f i) = f 0 + (\<Sum>i\<le>n. f (Suc i))"
- by (rule IH)
- also have "f 0 + (\<Sum>i\<le>n. f (Suc i)) + f (Suc (Suc n)) =
- f 0 + ((\<Sum>i\<le>n. f (Suc i)) + f (Suc (Suc n)))"
- by (rule add_assoc)
- also have "(\<Sum>i\<le>n. f (Suc i)) + f (Suc (Suc n)) = (\<Sum>i\<le>Suc n. f (Suc i))"
- by (rule setsum_atMost_Suc [symmetric])
- finally show ?case .
-qed
-
-instantiation poly :: (comm_semiring_0) comm_semiring_0
-begin
-
-definition
- times_poly_def [code del]:
- "p * q = poly_rec 0 (\<lambda>a p pq. smult a q + pCons 0 pq) p"
-
-lemma mult_poly_0_left: "(0::'a poly) * q = 0"
- unfolding times_poly_def by (simp add: poly_rec_0)
-
-lemma mult_pCons_left [simp]:
- "pCons a p * q = smult a q + pCons 0 (p * q)"
- unfolding times_poly_def by (simp add: poly_rec_pCons)
-
-lemma mult_poly_0_right: "p * (0::'a poly) = 0"
- by (induct p, simp add: mult_poly_0_left, simp)
-
-lemma mult_pCons_right [simp]:
- "p * pCons a q = smult a p + pCons 0 (p * q)"
- by (induct p, simp add: mult_poly_0_left, simp add: algebra_simps)
-
-lemmas mult_poly_0 = mult_poly_0_left mult_poly_0_right
-
-lemma mult_smult_left [simp]: "smult a p * q = smult a (p * q)"
- by (induct p, simp add: mult_poly_0, simp add: smult_add_right)
-
-lemma mult_smult_right [simp]: "p * smult a q = smult a (p * q)"
- by (induct q, simp add: mult_poly_0, simp add: smult_add_right)
-
-lemma mult_poly_add_left:
- fixes p q r :: "'a poly"
- shows "(p + q) * r = p * r + q * r"
- by (induct r, simp add: mult_poly_0,
- simp add: smult_distribs algebra_simps)
-
-instance proof
- fix p q r :: "'a poly"
- show 0: "0 * p = 0"
- by (rule mult_poly_0_left)
- show "p * 0 = 0"
- by (rule mult_poly_0_right)
- show "(p + q) * r = p * r + q * r"
- by (rule mult_poly_add_left)
- show "(p * q) * r = p * (q * r)"
- by (induct p, simp add: mult_poly_0, simp add: mult_poly_add_left)
- show "p * q = q * p"
- by (induct p, simp add: mult_poly_0, simp)
-qed
-
-end
-
-instance poly :: (comm_semiring_0_cancel) comm_semiring_0_cancel ..
-
-lemma coeff_mult:
- "coeff (p * q) n = (\<Sum>i\<le>n. coeff p i * coeff q (n-i))"
-proof (induct p arbitrary: n)
- case 0 show ?case by simp
-next
- case (pCons a p n) thus ?case
- by (cases n, simp, simp add: setsum_atMost_Suc_shift
- del: setsum_atMost_Suc)
-qed
-
-lemma degree_mult_le: "degree (p * q) \<le> degree p + degree q"
-apply (rule degree_le)
-apply (induct p)
-apply simp
-apply (simp add: coeff_eq_0 coeff_pCons split: nat.split)
-done
-
-lemma mult_monom: "monom a m * monom b n = monom (a * b) (m + n)"
- by (induct m, simp add: monom_0 smult_monom, simp add: monom_Suc)
-
-
-subsection {* The unit polynomial and exponentiation *}
-
-instantiation poly :: (comm_semiring_1) comm_semiring_1
-begin
-
-definition
- one_poly_def:
- "1 = pCons 1 0"
-
-instance proof
- fix p :: "'a poly" show "1 * p = p"
- unfolding one_poly_def
- by simp
-next
- show "0 \<noteq> (1::'a poly)"
- unfolding one_poly_def by simp
-qed
-
-end
-
-instance poly :: (comm_semiring_1_cancel) comm_semiring_1_cancel ..
-
-lemma coeff_1 [simp]: "coeff 1 n = (if n = 0 then 1 else 0)"
- unfolding one_poly_def
- by (simp add: coeff_pCons split: nat.split)
-
-lemma degree_1 [simp]: "degree 1 = 0"
- unfolding one_poly_def
- by (rule degree_pCons_0)
-
-instantiation poly :: (comm_semiring_1) recpower
-begin
-
-primrec power_poly where
- power_poly_0: "(p::'a poly) ^ 0 = 1"
-| power_poly_Suc: "(p::'a poly) ^ (Suc n) = p * p ^ n"
-
-instance
- by default simp_all
-
-end
-
-instance poly :: (comm_ring) comm_ring ..
-
-instance poly :: (comm_ring_1) comm_ring_1 ..
-
-instantiation poly :: (comm_ring_1) number_ring
-begin
-
-definition
- "number_of k = (of_int k :: 'a poly)"
-
-instance
- by default (rule number_of_poly_def)
-
-end
-
-
-subsection {* Polynomials form an integral domain *}
-
-lemma coeff_mult_degree_sum:
- "coeff (p * q) (degree p + degree q) =
- coeff p (degree p) * coeff q (degree q)"
- by (induct p, simp, simp add: coeff_eq_0)
-
-instance poly :: (idom) idom
-proof
- fix p q :: "'a poly"
- assume "p \<noteq> 0" and "q \<noteq> 0"
- have "coeff (p * q) (degree p + degree q) =
- coeff p (degree p) * coeff q (degree q)"
- by (rule coeff_mult_degree_sum)
- also have "coeff p (degree p) * coeff q (degree q) \<noteq> 0"
- using `p \<noteq> 0` and `q \<noteq> 0` by simp
- finally have "\<exists>n. coeff (p * q) n \<noteq> 0" ..
- thus "p * q \<noteq> 0" by (simp add: expand_poly_eq)
-qed
-
-lemma degree_mult_eq:
- fixes p q :: "'a::idom poly"
- shows "\<lbrakk>p \<noteq> 0; q \<noteq> 0\<rbrakk> \<Longrightarrow> degree (p * q) = degree p + degree q"
-apply (rule order_antisym [OF degree_mult_le le_degree])
-apply (simp add: coeff_mult_degree_sum)
-done
-
-lemma dvd_imp_degree_le:
- fixes p q :: "'a::idom poly"
- shows "\<lbrakk>p dvd q; q \<noteq> 0\<rbrakk> \<Longrightarrow> degree p \<le> degree q"
- by (erule dvdE, simp add: degree_mult_eq)
-
-
-subsection {* Polynomials form an ordered integral domain *}
-
-definition
- pos_poly :: "'a::ordered_idom poly \<Rightarrow> bool"
-where
- "pos_poly p \<longleftrightarrow> 0 < coeff p (degree p)"
-
-lemma pos_poly_pCons:
- "pos_poly (pCons a p) \<longleftrightarrow> pos_poly p \<or> (p = 0 \<and> 0 < a)"
- unfolding pos_poly_def by simp
-
-lemma not_pos_poly_0 [simp]: "\<not> pos_poly 0"
- unfolding pos_poly_def by simp
-
-lemma pos_poly_add: "\<lbrakk>pos_poly p; pos_poly q\<rbrakk> \<Longrightarrow> pos_poly (p + q)"
- apply (induct p arbitrary: q, simp)
- apply (case_tac q, force simp add: pos_poly_pCons add_pos_pos)
- done
-
-lemma pos_poly_mult: "\<lbrakk>pos_poly p; pos_poly q\<rbrakk> \<Longrightarrow> pos_poly (p * q)"
- unfolding pos_poly_def
- apply (subgoal_tac "p \<noteq> 0 \<and> q \<noteq> 0")
- apply (simp add: degree_mult_eq coeff_mult_degree_sum mult_pos_pos)
- apply auto
- done
-
-lemma pos_poly_total: "p = 0 \<or> pos_poly p \<or> pos_poly (- p)"
-by (induct p) (auto simp add: pos_poly_pCons)
-
-instantiation poly :: (ordered_idom) ordered_idom
-begin
-
-definition
- [code del]:
- "x < y \<longleftrightarrow> pos_poly (y - x)"
-
-definition
- [code del]:
- "x \<le> y \<longleftrightarrow> x = y \<or> pos_poly (y - x)"
-
-definition
- [code del]:
- "abs (x::'a poly) = (if x < 0 then - x else x)"
-
-definition
- [code del]:
- "sgn (x::'a poly) = (if x = 0 then 0 else if 0 < x then 1 else - 1)"
-
-instance proof
- fix x y :: "'a poly"
- show "x < y \<longleftrightarrow> x \<le> y \<and> \<not> y \<le> x"
- unfolding less_eq_poly_def less_poly_def
- apply safe
- apply simp
- apply (drule (1) pos_poly_add)
- apply simp
- done
-next
- fix x :: "'a poly" show "x \<le> x"
- unfolding less_eq_poly_def by simp
-next
- fix x y z :: "'a poly"
- assume "x \<le> y" and "y \<le> z" thus "x \<le> z"
- unfolding less_eq_poly_def
- apply safe
- apply (drule (1) pos_poly_add)
- apply (simp add: algebra_simps)
- done
-next
- fix x y :: "'a poly"
- assume "x \<le> y" and "y \<le> x" thus "x = y"
- unfolding less_eq_poly_def
- apply safe
- apply (drule (1) pos_poly_add)
- apply simp
- done
-next
- fix x y z :: "'a poly"
- assume "x \<le> y" thus "z + x \<le> z + y"
- unfolding less_eq_poly_def
- apply safe
- apply (simp add: algebra_simps)
- done
-next
- fix x y :: "'a poly"
- show "x \<le> y \<or> y \<le> x"
- unfolding less_eq_poly_def
- using pos_poly_total [of "x - y"]
- by auto
-next
- fix x y z :: "'a poly"
- assume "x < y" and "0 < z"
- thus "z * x < z * y"
- unfolding less_poly_def
- by (simp add: right_diff_distrib [symmetric] pos_poly_mult)
-next
- fix x :: "'a poly"
- show "\<bar>x\<bar> = (if x < 0 then - x else x)"
- by (rule abs_poly_def)
-next
- fix x :: "'a poly"
- show "sgn x = (if x = 0 then 0 else if 0 < x then 1 else - 1)"
- by (rule sgn_poly_def)
-qed
-
-end
-
-text {* TODO: Simplification rules for comparisons *}
-
-
-subsection {* Long division of polynomials *}
-
-definition
- pdivmod_rel :: "'a::field poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly \<Rightarrow> bool"
-where
- [code del]:
- "pdivmod_rel x y q r \<longleftrightarrow>
- x = q * y + r \<and> (if y = 0 then q = 0 else r = 0 \<or> degree r < degree y)"
-
-lemma pdivmod_rel_0:
- "pdivmod_rel 0 y 0 0"
- unfolding pdivmod_rel_def by simp
-
-lemma pdivmod_rel_by_0:
- "pdivmod_rel x 0 0 x"
- unfolding pdivmod_rel_def by simp
-
-lemma eq_zero_or_degree_less:
- assumes "degree p \<le> n" and "coeff p n = 0"
- shows "p = 0 \<or> degree p < n"
-proof (cases n)
- case 0
- with `degree p \<le> n` and `coeff p n = 0`
- have "coeff p (degree p) = 0" by simp
- then have "p = 0" by simp
- then show ?thesis ..
-next
- case (Suc m)
- have "\<forall>i>n. coeff p i = 0"
- using `degree p \<le> n` by (simp add: coeff_eq_0)
- then have "\<forall>i\<ge>n. coeff p i = 0"
- using `coeff p n = 0` by (simp add: le_less)
- then have "\<forall>i>m. coeff p i = 0"
- using `n = Suc m` by (simp add: less_eq_Suc_le)
- then have "degree p \<le> m"
- by (rule degree_le)
- then have "degree p < n"
- using `n = Suc m` by (simp add: less_Suc_eq_le)
- then show ?thesis ..
-qed
-
-lemma pdivmod_rel_pCons:
- assumes rel: "pdivmod_rel x y q r"
- assumes y: "y \<noteq> 0"
- assumes b: "b = coeff (pCons a r) (degree y) / coeff y (degree y)"
- shows "pdivmod_rel (pCons a x) y (pCons b q) (pCons a r - smult b y)"
- (is "pdivmod_rel ?x y ?q ?r")
-proof -
- have x: "x = q * y + r" and r: "r = 0 \<or> degree r < degree y"
- using assms unfolding pdivmod_rel_def by simp_all
-
- have 1: "?x = ?q * y + ?r"
- using b x by simp
-
- have 2: "?r = 0 \<or> degree ?r < degree y"
- proof (rule eq_zero_or_degree_less)
- show "degree ?r \<le> degree y"
- proof (rule degree_diff_le)
- show "degree (pCons a r) \<le> degree y"
- using r by auto
- show "degree (smult b y) \<le> degree y"
- by (rule degree_smult_le)
- qed
- next
- show "coeff ?r (degree y) = 0"
- using `y \<noteq> 0` unfolding b by simp
- qed
-
- from 1 2 show ?thesis
- unfolding pdivmod_rel_def
- using `y \<noteq> 0` by simp
-qed
-
-lemma pdivmod_rel_exists: "\<exists>q r. pdivmod_rel x y q r"
-apply (cases "y = 0")
-apply (fast intro!: pdivmod_rel_by_0)
-apply (induct x)
-apply (fast intro!: pdivmod_rel_0)
-apply (fast intro!: pdivmod_rel_pCons)
-done
-
-lemma pdivmod_rel_unique:
- assumes 1: "pdivmod_rel x y q1 r1"
- assumes 2: "pdivmod_rel x y q2 r2"
- shows "q1 = q2 \<and> r1 = r2"
-proof (cases "y = 0")
- assume "y = 0" with assms show ?thesis
- by (simp add: pdivmod_rel_def)
-next
- assume [simp]: "y \<noteq> 0"
- from 1 have q1: "x = q1 * y + r1" and r1: "r1 = 0 \<or> degree r1 < degree y"
- unfolding pdivmod_rel_def by simp_all
- from 2 have q2: "x = q2 * y + r2" and r2: "r2 = 0 \<or> degree r2 < degree y"
- unfolding pdivmod_rel_def by simp_all
- from q1 q2 have q3: "(q1 - q2) * y = r2 - r1"
- by (simp add: algebra_simps)
- from r1 r2 have r3: "(r2 - r1) = 0 \<or> degree (r2 - r1) < degree y"
- by (auto intro: degree_diff_less)
-
- show "q1 = q2 \<and> r1 = r2"
- proof (rule ccontr)
- assume "\<not> (q1 = q2 \<and> r1 = r2)"
- with q3 have "q1 \<noteq> q2" and "r1 \<noteq> r2" by auto
- with r3 have "degree (r2 - r1) < degree y" by simp
- also have "degree y \<le> degree (q1 - q2) + degree y" by simp
- also have "\<dots> = degree ((q1 - q2) * y)"
- using `q1 \<noteq> q2` by (simp add: degree_mult_eq)
- also have "\<dots> = degree (r2 - r1)"
- using q3 by simp
- finally have "degree (r2 - r1) < degree (r2 - r1)" .
- then show "False" by simp
- qed
-qed
-
-lemma pdivmod_rel_0_iff: "pdivmod_rel 0 y q r \<longleftrightarrow> q = 0 \<and> r = 0"
-by (auto dest: pdivmod_rel_unique intro: pdivmod_rel_0)
-
-lemma pdivmod_rel_by_0_iff: "pdivmod_rel x 0 q r \<longleftrightarrow> q = 0 \<and> r = x"
-by (auto dest: pdivmod_rel_unique intro: pdivmod_rel_by_0)
-
-lemmas pdivmod_rel_unique_div =
- pdivmod_rel_unique [THEN conjunct1, standard]
-
-lemmas pdivmod_rel_unique_mod =
- pdivmod_rel_unique [THEN conjunct2, standard]
-
-instantiation poly :: (field) ring_div
-begin
-
-definition div_poly where
- [code del]: "x div y = (THE q. \<exists>r. pdivmod_rel x y q r)"
-
-definition mod_poly where
- [code del]: "x mod y = (THE r. \<exists>q. pdivmod_rel x y q r)"
-
-lemma div_poly_eq:
- "pdivmod_rel x y q r \<Longrightarrow> x div y = q"
-unfolding div_poly_def
-by (fast elim: pdivmod_rel_unique_div)
-
-lemma mod_poly_eq:
- "pdivmod_rel x y q r \<Longrightarrow> x mod y = r"
-unfolding mod_poly_def
-by (fast elim: pdivmod_rel_unique_mod)
-
-lemma pdivmod_rel:
- "pdivmod_rel x y (x div y) (x mod y)"
-proof -
- from pdivmod_rel_exists
- obtain q r where "pdivmod_rel x y q r" by fast
- thus ?thesis
- by (simp add: div_poly_eq mod_poly_eq)
-qed
-
-instance proof
- fix x y :: "'a poly"
- show "x div y * y + x mod y = x"
- using pdivmod_rel [of x y]
- by (simp add: pdivmod_rel_def)
-next
- fix x :: "'a poly"
- have "pdivmod_rel x 0 0 x"
- by (rule pdivmod_rel_by_0)
- thus "x div 0 = 0"
- by (rule div_poly_eq)
-next
- fix y :: "'a poly"
- have "pdivmod_rel 0 y 0 0"
- by (rule pdivmod_rel_0)
- thus "0 div y = 0"
- by (rule div_poly_eq)
-next
- fix x y z :: "'a poly"
- assume "y \<noteq> 0"
- hence "pdivmod_rel (x + z * y) y (z + x div y) (x mod y)"
- using pdivmod_rel [of x y]
- by (simp add: pdivmod_rel_def left_distrib)
- thus "(x + z * y) div y = z + x div y"
- by (rule div_poly_eq)
-qed
-
-end
-
-lemma degree_mod_less:
- "y \<noteq> 0 \<Longrightarrow> x mod y = 0 \<or> degree (x mod y) < degree y"
- using pdivmod_rel [of x y]
- unfolding pdivmod_rel_def by simp
-
-lemma div_poly_less: "degree x < degree y \<Longrightarrow> x div y = 0"
-proof -
- assume "degree x < degree y"
- hence "pdivmod_rel x y 0 x"
- by (simp add: pdivmod_rel_def)
- thus "x div y = 0" by (rule div_poly_eq)
-qed
-
-lemma mod_poly_less: "degree x < degree y \<Longrightarrow> x mod y = x"
-proof -
- assume "degree x < degree y"
- hence "pdivmod_rel x y 0 x"
- by (simp add: pdivmod_rel_def)
- thus "x mod y = x" by (rule mod_poly_eq)
-qed
-
-lemma pdivmod_rel_smult_left:
- "pdivmod_rel x y q r
- \<Longrightarrow> pdivmod_rel (smult a x) y (smult a q) (smult a r)"
- unfolding pdivmod_rel_def by (simp add: smult_add_right)
-
-lemma div_smult_left: "(smult a x) div y = smult a (x div y)"
- by (rule div_poly_eq, rule pdivmod_rel_smult_left, rule pdivmod_rel)
-
-lemma mod_smult_left: "(smult a x) mod y = smult a (x mod y)"
- by (rule mod_poly_eq, rule pdivmod_rel_smult_left, rule pdivmod_rel)
-
-lemma pdivmod_rel_smult_right:
- "\<lbrakk>a \<noteq> 0; pdivmod_rel x y q r\<rbrakk>
- \<Longrightarrow> pdivmod_rel x (smult a y) (smult (inverse a) q) r"
- unfolding pdivmod_rel_def by simp
-
-lemma div_smult_right:
- "a \<noteq> 0 \<Longrightarrow> x div (smult a y) = smult (inverse a) (x div y)"
- by (rule div_poly_eq, erule pdivmod_rel_smult_right, rule pdivmod_rel)
-
-lemma mod_smult_right: "a \<noteq> 0 \<Longrightarrow> x mod (smult a y) = x mod y"
- by (rule mod_poly_eq, erule pdivmod_rel_smult_right, rule pdivmod_rel)
-
-lemma pdivmod_rel_mult:
- "\<lbrakk>pdivmod_rel x y q r; pdivmod_rel q z q' r'\<rbrakk>
- \<Longrightarrow> pdivmod_rel x (y * z) q' (y * r' + r)"
-apply (cases "z = 0", simp add: pdivmod_rel_def)
-apply (cases "y = 0", simp add: pdivmod_rel_by_0_iff pdivmod_rel_0_iff)
-apply (cases "r = 0")
-apply (cases "r' = 0")
-apply (simp add: pdivmod_rel_def)
-apply (simp add: pdivmod_rel_def ring_simps degree_mult_eq)
-apply (cases "r' = 0")
-apply (simp add: pdivmod_rel_def degree_mult_eq)
-apply (simp add: pdivmod_rel_def ring_simps)
-apply (simp add: degree_mult_eq degree_add_less)
-done
-
-lemma poly_div_mult_right:
- fixes x y z :: "'a::field poly"
- shows "x div (y * z) = (x div y) div z"
- by (rule div_poly_eq, rule pdivmod_rel_mult, (rule pdivmod_rel)+)
-
-lemma poly_mod_mult_right:
- fixes x y z :: "'a::field poly"
- shows "x mod (y * z) = y * (x div y mod z) + x mod y"
- by (rule mod_poly_eq, rule pdivmod_rel_mult, (rule pdivmod_rel)+)
-
-lemma mod_pCons:
- fixes a and x
- assumes y: "y \<noteq> 0"
- defines b: "b \<equiv> coeff (pCons a (x mod y)) (degree y) / coeff y (degree y)"
- shows "(pCons a x) mod y = (pCons a (x mod y) - smult b y)"
-unfolding b
-apply (rule mod_poly_eq)
-apply (rule pdivmod_rel_pCons [OF pdivmod_rel y refl])
-done
-
-
-subsection {* Evaluation of polynomials *}
-
-definition
- poly :: "'a::comm_semiring_0 poly \<Rightarrow> 'a \<Rightarrow> 'a" where
- "poly = poly_rec (\<lambda>x. 0) (\<lambda>a p f x. a + x * f x)"
-
-lemma poly_0 [simp]: "poly 0 x = 0"
- unfolding poly_def by (simp add: poly_rec_0)
-
-lemma poly_pCons [simp]: "poly (pCons a p) x = a + x * poly p x"
- unfolding poly_def by (simp add: poly_rec_pCons)
-
-lemma poly_1 [simp]: "poly 1 x = 1"
- unfolding one_poly_def by simp
-
-lemma poly_monom:
- fixes a x :: "'a::{comm_semiring_1,recpower}"
- shows "poly (monom a n) x = a * x ^ n"
- by (induct n, simp add: monom_0, simp add: monom_Suc power_Suc mult_ac)
-
-lemma poly_add [simp]: "poly (p + q) x = poly p x + poly q x"
- apply (induct p arbitrary: q, simp)
- apply (case_tac q, simp, simp add: algebra_simps)
- done
-
-lemma poly_minus [simp]:
- fixes x :: "'a::comm_ring"
- shows "poly (- p) x = - poly p x"
- by (induct p, simp_all)
-
-lemma poly_diff [simp]:
- fixes x :: "'a::comm_ring"
- shows "poly (p - q) x = poly p x - poly q x"
- by (simp add: diff_minus)
-
-lemma poly_setsum: "poly (\<Sum>k\<in>A. p k) x = (\<Sum>k\<in>A. poly (p k) x)"
- by (cases "finite A", induct set: finite, simp_all)
-
-lemma poly_smult [simp]: "poly (smult a p) x = a * poly p x"
- by (induct p, simp, simp add: algebra_simps)
-
-lemma poly_mult [simp]: "poly (p * q) x = poly p x * poly q x"
- by (induct p, simp_all, simp add: algebra_simps)
-
-lemma poly_power [simp]:
- fixes p :: "'a::{comm_semiring_1,recpower} poly"
- shows "poly (p ^ n) x = poly p x ^ n"
- by (induct n, simp, simp add: power_Suc)
-
-
-subsection {* Synthetic division *}
-
-definition
- synthetic_divmod :: "'a::comm_semiring_0 poly \<Rightarrow> 'a \<Rightarrow> 'a poly \<times> 'a"
-where [code del]:
- "synthetic_divmod p c =
- poly_rec (0, 0) (\<lambda>a p (q, r). (pCons r q, a + c * r)) p"
-
-definition
- synthetic_div :: "'a::comm_semiring_0 poly \<Rightarrow> 'a \<Rightarrow> 'a poly"
-where
- "synthetic_div p c = fst (synthetic_divmod p c)"
-
-lemma synthetic_divmod_0 [simp]:
- "synthetic_divmod 0 c = (0, 0)"
- unfolding synthetic_divmod_def
- by (simp add: poly_rec_0)
-
-lemma synthetic_divmod_pCons [simp]:
- "synthetic_divmod (pCons a p) c =
- (\<lambda>(q, r). (pCons r q, a + c * r)) (synthetic_divmod p c)"
- unfolding synthetic_divmod_def
- by (simp add: poly_rec_pCons)
-
-lemma snd_synthetic_divmod: "snd (synthetic_divmod p c) = poly p c"
- by (induct p, simp, simp add: split_def)
-
-lemma synthetic_div_0 [simp]: "synthetic_div 0 c = 0"
- unfolding synthetic_div_def by simp
-
-lemma synthetic_div_pCons [simp]:
- "synthetic_div (pCons a p) c = pCons (poly p c) (synthetic_div p c)"
- unfolding synthetic_div_def
- by (simp add: split_def snd_synthetic_divmod)
-
-lemma synthetic_div_eq_0_iff:
- "synthetic_div p c = 0 \<longleftrightarrow> degree p = 0"
- by (induct p, simp, case_tac p, simp)
-
-lemma degree_synthetic_div:
- "degree (synthetic_div p c) = degree p - 1"
- by (induct p, simp, simp add: synthetic_div_eq_0_iff)
-
-lemma synthetic_div_correct:
- "p + smult c (synthetic_div p c) = pCons (poly p c) (synthetic_div p c)"
- by (induct p) simp_all
-
-lemma synthetic_div_unique_lemma: "smult c p = pCons a p \<Longrightarrow> p = 0"
-by (induct p arbitrary: a) simp_all
-
-lemma synthetic_div_unique:
- "p + smult c q = pCons r q \<Longrightarrow> r = poly p c \<and> q = synthetic_div p c"
-apply (induct p arbitrary: q r)
-apply (simp, frule synthetic_div_unique_lemma, simp)
-apply (case_tac q, force)
-done
-
-lemma synthetic_div_correct':
- fixes c :: "'a::comm_ring_1"
- shows "[:-c, 1:] * synthetic_div p c + [:poly p c:] = p"
- using synthetic_div_correct [of p c]
- by (simp add: algebra_simps)
-
-lemma poly_eq_0_iff_dvd:
- fixes c :: "'a::idom"
- shows "poly p c = 0 \<longleftrightarrow> [:-c, 1:] dvd p"
-proof
- assume "poly p c = 0"
- with synthetic_div_correct' [of c p]
- have "p = [:-c, 1:] * synthetic_div p c" by simp
- then show "[:-c, 1:] dvd p" ..
-next
- assume "[:-c, 1:] dvd p"
- then obtain k where "p = [:-c, 1:] * k" by (rule dvdE)
- then show "poly p c = 0" by simp
-qed
-
-lemma dvd_iff_poly_eq_0:
- fixes c :: "'a::idom"
- shows "[:c, 1:] dvd p \<longleftrightarrow> poly p (-c) = 0"
- by (simp add: poly_eq_0_iff_dvd)
-
-lemma poly_roots_finite:
- fixes p :: "'a::idom poly"
- shows "p \<noteq> 0 \<Longrightarrow> finite {x. poly p x = 0}"
-proof (induct n \<equiv> "degree p" arbitrary: p)
- case (0 p)
- then obtain a where "a \<noteq> 0" and "p = [:a:]"
- by (cases p, simp split: if_splits)
- then show "finite {x. poly p x = 0}" by simp
-next
- case (Suc n p)
- show "finite {x. poly p x = 0}"
- proof (cases "\<exists>x. poly p x = 0")
- case False
- then show "finite {x. poly p x = 0}" by simp
- next
- case True
- then obtain a where "poly p a = 0" ..
- then have "[:-a, 1:] dvd p" by (simp only: poly_eq_0_iff_dvd)
- then obtain k where k: "p = [:-a, 1:] * k" ..
- with `p \<noteq> 0` have "k \<noteq> 0" by auto
- with k have "degree p = Suc (degree k)"
- by (simp add: degree_mult_eq del: mult_pCons_left)
- with `Suc n = degree p` have "n = degree k" by simp
- with `k \<noteq> 0` have "finite {x. poly k x = 0}" by (rule Suc.hyps)
- then have "finite (insert a {x. poly k x = 0})" by simp
- then show "finite {x. poly p x = 0}"
- by (simp add: k uminus_add_conv_diff Collect_disj_eq
- del: mult_pCons_left)
- qed
-qed
-
-
-subsection {* Configuration of the code generator *}
-
-code_datatype "0::'a::zero poly" pCons
-
-declare pCons_0_0 [code post]
-
-instantiation poly :: ("{zero,eq}") eq
-begin
-
-definition [code del]:
- "eq_class.eq (p::'a poly) q \<longleftrightarrow> p = q"
-
-instance
- by default (rule eq_poly_def)
-
-end
-
-lemma eq_poly_code [code]:
- "eq_class.eq (0::_ poly) (0::_ poly) \<longleftrightarrow> True"
- "eq_class.eq (0::_ poly) (pCons b q) \<longleftrightarrow> eq_class.eq 0 b \<and> eq_class.eq 0 q"
- "eq_class.eq (pCons a p) (0::_ poly) \<longleftrightarrow> eq_class.eq a 0 \<and> eq_class.eq p 0"
- "eq_class.eq (pCons a p) (pCons b q) \<longleftrightarrow> eq_class.eq a b \<and> eq_class.eq p q"
-unfolding eq by simp_all
-
-lemmas coeff_code [code] =
- coeff_0 coeff_pCons_0 coeff_pCons_Suc
-
-lemmas degree_code [code] =
- degree_0 degree_pCons_eq_if
-
-lemmas monom_poly_code [code] =
- monom_0 monom_Suc
-
-lemma add_poly_code [code]:
- "0 + q = (q :: _ poly)"
- "p + 0 = (p :: _ poly)"
- "pCons a p + pCons b q = pCons (a + b) (p + q)"
-by simp_all
-
-lemma minus_poly_code [code]:
- "- 0 = (0 :: _ poly)"
- "- pCons a p = pCons (- a) (- p)"
-by simp_all
-
-lemma diff_poly_code [code]:
- "0 - q = (- q :: _ poly)"
- "p - 0 = (p :: _ poly)"
- "pCons a p - pCons b q = pCons (a - b) (p - q)"
-by simp_all
-
-lemmas smult_poly_code [code] =
- smult_0_right smult_pCons
-
-lemma mult_poly_code [code]:
- "0 * q = (0 :: _ poly)"
- "pCons a p * q = smult a q + pCons 0 (p * q)"
-by simp_all
-
-lemmas poly_code [code] =
- poly_0 poly_pCons
-
-lemmas synthetic_divmod_code [code] =
- synthetic_divmod_0 synthetic_divmod_pCons
-
-text {* code generator setup for div and mod *}
-
-definition
- pdivmod :: "'a::field poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly \<times> 'a poly"
-where
- [code del]: "pdivmod x y = (x div y, x mod y)"
-
-lemma div_poly_code [code]: "x div y = fst (pdivmod x y)"
- unfolding pdivmod_def by simp
-
-lemma mod_poly_code [code]: "x mod y = snd (pdivmod x y)"
- unfolding pdivmod_def by simp
-
-lemma pdivmod_0 [code]: "pdivmod 0 y = (0, 0)"
- unfolding pdivmod_def by simp
-
-lemma pdivmod_pCons [code]:
- "pdivmod (pCons a x) y =
- (if y = 0 then (0, pCons a x) else
- (let (q, r) = pdivmod x y;
- b = coeff (pCons a r) (degree y) / coeff y (degree y)
- in (pCons b q, pCons a r - smult b y)))"
-apply (simp add: pdivmod_def Let_def, safe)
-apply (rule div_poly_eq)
-apply (erule pdivmod_rel_pCons [OF pdivmod_rel _ refl])
-apply (rule mod_poly_eq)
-apply (erule pdivmod_rel_pCons [OF pdivmod_rel _ refl])
-done
-
-end
--- a/src/HOL/Power.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Power.thy Thu Feb 26 11:21:29 2009 +0000
@@ -31,7 +31,7 @@
by (induct n) (simp_all add: power_Suc)
lemma power_one_right [simp]: "(a::'a::recpower) ^ 1 = a"
- by (simp add: power_Suc)
+ unfolding One_nat_def by (simp add: power_Suc)
lemma power_commutes: "(a::'a::recpower) ^ n * a = a * a ^ n"
by (induct n) (simp_all add: power_Suc mult_assoc)
@@ -143,11 +143,13 @@
done
lemma power_eq_0_iff [simp]:
- "(a^n = 0) = (a = (0::'a::{ring_1_no_zero_divisors,recpower}) & n>0)"
+ "(a^n = 0) \<longleftrightarrow>
+ (a = (0::'a::{mult_zero,zero_neq_one,no_zero_divisors,recpower}) & n\<noteq>0)"
apply (induct "n")
-apply (auto simp add: power_Suc zero_neq_one [THEN not_sym])
+apply (auto simp add: power_Suc zero_neq_one [THEN not_sym] no_zero_divisors)
done
+
lemma field_power_not_zero:
"a \<noteq> (0::'a::{ring_1_no_zero_divisors,recpower}) ==> a^n \<noteq> 0"
by force
@@ -324,6 +326,24 @@
shows "\<lbrakk>a ^ n = b ^ n; 0 \<le> a; 0 \<le> b; 0 < n\<rbrakk> \<Longrightarrow> a = b"
by (cases n, simp_all, rule power_inject_base)
+text {* The divides relation *}
+
+lemma le_imp_power_dvd:
+ fixes a :: "'a::{comm_semiring_1,recpower}"
+ assumes "m \<le> n" shows "a^m dvd a^n"
+proof
+ have "a^n = a^(m + (n - m))"
+ using `m \<le> n` by simp
+ also have "\<dots> = a^m * a^(n - m)"
+ by (rule power_add)
+ finally show "a^n = a^m * a^(n - m)" .
+qed
+
+lemma power_le_dvd:
+ fixes a b :: "'a::{comm_semiring_1,recpower}"
+ shows "a^n dvd b \<Longrightarrow> m \<le> n \<Longrightarrow> a^m dvd b"
+ by (rule dvd_trans [OF le_imp_power_dvd])
+
subsection{*Exponentiation for the Natural Numbers*}
@@ -346,12 +366,19 @@
"of_nat (m ^ n) = (of_nat m::'a::{semiring_1,recpower}) ^ n"
by (induct n, simp_all add: power_Suc of_nat_mult)
-lemma nat_one_le_power [simp]: "1 \<le> i ==> Suc 0 \<le> i^n"
-by (insert one_le_power [of i n], simp)
+lemma nat_one_le_power [simp]: "Suc 0 \<le> i ==> Suc 0 \<le> i^n"
+by (rule one_le_power [of i n, unfolded One_nat_def])
lemma nat_zero_less_power_iff [simp]: "(x^n > 0) = (x > (0::nat) | n=0)"
by (induct "n", auto)
+lemma nat_power_eq_Suc_0_iff [simp]:
+ "((x::nat)^m = Suc 0) = (m = 0 | x = Suc 0)"
+by (induct_tac m, auto)
+
+lemma power_Suc_0[simp]: "(Suc 0)^n = Suc 0"
+by simp
+
text{*Valid for the naturals, but what if @{text"0<i<1"}?
Premises cannot be weakened: consider the case where @{term "i=0"},
@{term "m=1"} and @{term "n=0"}.*}
@@ -425,4 +452,3 @@
*}
end
-
--- a/src/HOL/Presburger.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Presburger.thy Thu Feb 26 11:21:29 2009 +0000
@@ -412,19 +412,15 @@
"(((number_of v)::int) = (number_of w)) = iszero ((number_of (v + (uminus w)))::int)"
by (rule eq_number_of_eq)
-lemma mod_eq0_dvd_iff[presburger]: "(m::nat) mod n = 0 \<longleftrightarrow> n dvd m"
-unfolding dvd_eq_mod_eq_0[symmetric] ..
-
-lemma zmod_eq0_zdvd_iff[presburger]: "(m::int) mod n = 0 \<longleftrightarrow> n dvd m"
-unfolding zdvd_iff_zmod_eq_0[symmetric] ..
+declare dvd_eq_mod_eq_0[symmetric, presburger]
declare mod_1[presburger]
declare mod_0[presburger]
-declare zmod_1[presburger]
+declare mod_by_1[presburger]
declare zmod_zero[presburger]
declare zmod_self[presburger]
declare mod_self[presburger]
declare mod_by_0[presburger]
-declare nat_mod_div_trivial[presburger]
+declare mod_div_trivial[presburger]
declare div_mod_equality2[presburger]
declare div_mod_equality[presburger]
declare mod_div_equality2[presburger]
--- a/src/HOL/RComplete.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/RComplete.thy Thu Feb 26 11:21:29 2009 +0000
@@ -380,33 +380,28 @@
thus "\<exists>(n::nat). x < real n" ..
qed
+instance real :: archimedean_field
+proof
+ fix r :: real
+ obtain n :: nat where "r < real n"
+ using reals_Archimedean2 ..
+ then have "r \<le> of_int (int n)"
+ unfolding real_eq_of_nat by simp
+ then show "\<exists>z. r \<le> of_int z" ..
+qed
+
lemma reals_Archimedean3:
assumes x_greater_zero: "0 < x"
shows "\<forall>(y::real). \<exists>(n::nat). y < real n * x"
-proof
- fix y
- have x_not_zero: "x \<noteq> 0" using x_greater_zero by simp
- obtain n where "y * inverse x < real (n::nat)"
- using reals_Archimedean2 ..
- hence "y * inverse x * x < real n * x"
- using x_greater_zero by (simp add: mult_strict_right_mono)
- hence "x * inverse x * y < x * real n"
- by (simp add: algebra_simps)
- hence "y < real (n::nat) * x"
- using x_not_zero by (simp add: algebra_simps)
- thus "\<exists>(n::nat). y < real n * x" ..
-qed
+ unfolding real_of_nat_def using `0 < x`
+ by (auto intro: ex_less_of_nat_mult)
lemma reals_Archimedean6:
"0 \<le> r ==> \<exists>(n::nat). real (n - 1) \<le> r & r < real (n)"
-apply (insert reals_Archimedean2 [of r], safe)
-apply (subgoal_tac "\<exists>x::nat. r < real x \<and> (\<forall>y. r < real y \<longrightarrow> x \<le> y)", auto)
-apply (rule_tac x = x in exI)
-apply (case_tac x, simp)
-apply (rename_tac x')
-apply (drule_tac x = x' in spec, simp)
-apply (rule_tac x="LEAST n. r < real n" in exI, safe)
-apply (erule LeastI, erule Least_le)
+unfolding real_of_nat_def
+apply (rule exI [where x="nat (floor r + 1)"])
+apply (insert floor_correct [of r])
+apply (simp add: nat_add_distrib of_nat_nat)
done
lemma reals_Archimedean6a: "0 \<le> r ==> \<exists>n. real (n) \<le> r & r < real (Suc n)"
@@ -414,19 +409,11 @@
lemma reals_Archimedean_6b_int:
"0 \<le> r ==> \<exists>n::int. real n \<le> r & r < real (n+1)"
-apply (drule reals_Archimedean6a, auto)
-apply (rule_tac x = "int n" in exI)
-apply (simp add: real_of_int_real_of_nat real_of_nat_Suc)
-done
+ unfolding real_of_int_def by (rule floor_exists)
lemma reals_Archimedean_6c_int:
"r < 0 ==> \<exists>n::int. real n \<le> r & r < real (n+1)"
-apply (rule reals_Archimedean_6b_int [of "-r", THEN exE], simp, auto)
-apply (rename_tac n)
-apply (drule order_le_imp_less_or_eq, auto)
-apply (rule_tac x = "- n - 1" in exI)
-apply (rule_tac [2] x = "- n" in exI, auto)
-done
+ unfolding real_of_int_def by (rule floor_exists)
subsection{*Density of the Rational Reals in the Reals*}
@@ -485,23 +472,6 @@
subsection{*Floor and Ceiling Functions from the Reals to the Integers*}
-definition
- floor :: "real => int" where
- [code del]: "floor r = (LEAST n::int. r < real (n+1))"
-
-definition
- ceiling :: "real => int" where
- "ceiling r = - floor (- r)"
-
-notation (xsymbols)
- floor ("\<lfloor>_\<rfloor>") and
- ceiling ("\<lceil>_\<rceil>")
-
-notation (HTML output)
- floor ("\<lfloor>_\<rfloor>") and
- ceiling ("\<lceil>_\<rceil>")
-
-
lemma number_of_less_real_of_int_iff [simp]:
"((number_of n) < real (m::int)) = (number_of n < m)"
apply auto
@@ -524,51 +494,23 @@
"(real (m::int) \<le> (number_of n)) = (m \<le> number_of n)"
by (simp add: linorder_not_less [symmetric])
-lemma floor_zero [simp]: "floor 0 = 0"
-apply (simp add: floor_def del: real_of_int_add)
-apply (rule Least_equality)
-apply simp_all
-done
-
-lemma floor_real_of_nat_zero [simp]: "floor (real (0::nat)) = 0"
-by auto
+lemma floor_real_of_nat_zero: "floor (real (0::nat)) = 0"
+by auto (* delete? *)
lemma floor_real_of_nat [simp]: "floor (real (n::nat)) = int n"
-apply (simp only: floor_def)
-apply (rule Least_equality)
-apply (drule_tac [2] real_of_int_of_nat_eq [THEN ssubst])
-apply (drule_tac [2] real_of_int_less_iff [THEN iffD1])
-apply simp_all
-done
+unfolding real_of_nat_def by simp
lemma floor_minus_real_of_nat [simp]: "floor (- real (n::nat)) = - int n"
-apply (simp only: floor_def)
-apply (rule Least_equality)
-apply (drule_tac [2] real_of_int_of_nat_eq [THEN ssubst])
-apply (drule_tac [2] real_of_int_minus [THEN sym, THEN subst])
-apply (drule_tac [2] real_of_int_less_iff [THEN iffD1])
-apply simp_all
-done
+unfolding real_of_nat_def by simp
lemma floor_real_of_int [simp]: "floor (real (n::int)) = n"
-apply (simp only: floor_def)
-apply (rule Least_equality)
-apply auto
-done
+unfolding real_of_int_def by simp
lemma floor_minus_real_of_int [simp]: "floor (- real (n::int)) = - n"
-apply (simp only: floor_def)
-apply (rule Least_equality)
-apply (drule_tac [2] real_of_int_minus [THEN sym, THEN subst])
-apply auto
-done
+unfolding real_of_int_def by simp
lemma real_lb_ub_int: " \<exists>n::int. real n \<le> r & r < real (n+1)"
-apply (case_tac "r < 0")
-apply (blast intro: reals_Archimedean_6c_int)
-apply (simp only: linorder_not_less)
-apply (blast intro: reals_Archimedean_6b_int reals_Archimedean_6c_int)
-done
+unfolding real_of_int_def by (rule floor_exists)
lemma lemma_floor:
assumes a1: "real m \<le> r" and a2: "r < real n + 1"
@@ -581,48 +523,20 @@
qed
lemma real_of_int_floor_le [simp]: "real (floor r) \<le> r"
-apply (simp add: floor_def Least_def)
-apply (insert real_lb_ub_int [of r], safe)
-apply (rule theI2)
-apply auto
-done
-
-lemma floor_mono: "x < y ==> floor x \<le> floor y"
-apply (simp add: floor_def Least_def)
-apply (insert real_lb_ub_int [of x])
-apply (insert real_lb_ub_int [of y], safe)
-apply (rule theI2)
-apply (rule_tac [3] theI2)
-apply simp
-apply (erule conjI)
-apply (auto simp add: order_eq_iff int_le_real_less)
-done
-
-lemma floor_mono2: "x \<le> y ==> floor x \<le> floor y"
-by (auto dest: order_le_imp_less_or_eq simp add: floor_mono)
+unfolding real_of_int_def by (rule of_int_floor_le)
lemma lemma_floor2: "real n < real (x::int) + 1 ==> n \<le> x"
by (auto intro: lemma_floor)
lemma real_of_int_floor_cancel [simp]:
"(real (floor x) = x) = (\<exists>n::int. x = real n)"
-apply (simp add: floor_def Least_def)
-apply (insert real_lb_ub_int [of x], erule exE)
-apply (rule theI2)
-apply (auto intro: lemma_floor)
-done
+ using floor_real_of_int by metis
lemma floor_eq: "[| real n < x; x < real n + 1 |] ==> floor x = n"
-apply (simp add: floor_def)
-apply (rule Least_equality)
-apply (auto intro: lemma_floor)
-done
+ unfolding real_of_int_def using floor_unique [of n x] by simp
lemma floor_eq2: "[| real n \<le> x; x < real n + 1 |] ==> floor x = n"
-apply (simp add: floor_def)
-apply (rule Least_equality)
-apply (auto intro: lemma_floor)
-done
+ unfolding real_of_int_def by (rule floor_unique)
lemma floor_eq3: "[| real n < x; x < real (Suc n) |] ==> nat(floor x) = n"
apply (rule inj_int [THEN injD])
@@ -635,353 +549,205 @@
apply (auto intro: floor_eq3)
done
-lemma floor_number_of_eq [simp]:
+lemma floor_number_of_eq:
"floor(number_of n :: real) = (number_of n :: int)"
-apply (subst real_number_of [symmetric])
-apply (rule floor_real_of_int)
-done
-
-lemma floor_one [simp]: "floor 1 = 1"
- apply (rule trans)
- prefer 2
- apply (rule floor_real_of_int)
- apply simp
-done
+ by (rule floor_number_of) (* already declared [simp] *)
lemma real_of_int_floor_ge_diff_one [simp]: "r - 1 \<le> real(floor r)"
-apply (simp add: floor_def Least_def)
-apply (insert real_lb_ub_int [of r], safe)
-apply (rule theI2)
-apply (auto intro: lemma_floor)
-done
+ unfolding real_of_int_def using floor_correct [of r] by simp
lemma real_of_int_floor_gt_diff_one [simp]: "r - 1 < real(floor r)"
-apply (simp add: floor_def Least_def)
-apply (insert real_lb_ub_int [of r], safe)
-apply (rule theI2)
-apply (auto intro: lemma_floor)
-done
+ unfolding real_of_int_def using floor_correct [of r] by simp
lemma real_of_int_floor_add_one_ge [simp]: "r \<le> real(floor r) + 1"
-apply (insert real_of_int_floor_ge_diff_one [of r])
-apply (auto simp del: real_of_int_floor_ge_diff_one)
-done
+ unfolding real_of_int_def using floor_correct [of r] by simp
lemma real_of_int_floor_add_one_gt [simp]: "r < real(floor r) + 1"
-apply (insert real_of_int_floor_gt_diff_one [of r])
-apply (auto simp del: real_of_int_floor_gt_diff_one)
-done
+ unfolding real_of_int_def using floor_correct [of r] by simp
lemma le_floor: "real a <= x ==> a <= floor x"
- apply (subgoal_tac "a < floor x + 1")
- apply arith
- apply (subst real_of_int_less_iff [THEN sym])
- apply simp
- apply (insert real_of_int_floor_add_one_gt [of x])
- apply arith
-done
+ unfolding real_of_int_def by (simp add: le_floor_iff)
lemma real_le_floor: "a <= floor x ==> real a <= x"
- apply (rule order_trans)
- prefer 2
- apply (rule real_of_int_floor_le)
- apply (subst real_of_int_le_iff)
- apply assumption
-done
+ unfolding real_of_int_def by (simp add: le_floor_iff)
lemma le_floor_eq: "(a <= floor x) = (real a <= x)"
- apply (rule iffI)
- apply (erule real_le_floor)
- apply (erule le_floor)
-done
+ unfolding real_of_int_def by (rule le_floor_iff)
-lemma le_floor_eq_number_of [simp]:
+lemma le_floor_eq_number_of:
"(number_of n <= floor x) = (number_of n <= x)"
-by (simp add: le_floor_eq)
+ by (rule number_of_le_floor) (* already declared [simp] *)
-lemma le_floor_eq_zero [simp]: "(0 <= floor x) = (0 <= x)"
-by (simp add: le_floor_eq)
+lemma le_floor_eq_zero: "(0 <= floor x) = (0 <= x)"
+ by (rule zero_le_floor) (* already declared [simp] *)
-lemma le_floor_eq_one [simp]: "(1 <= floor x) = (1 <= x)"
-by (simp add: le_floor_eq)
+lemma le_floor_eq_one: "(1 <= floor x) = (1 <= x)"
+ by (rule one_le_floor) (* already declared [simp] *)
lemma floor_less_eq: "(floor x < a) = (x < real a)"
- apply (subst linorder_not_le [THEN sym])+
- apply simp
- apply (rule le_floor_eq)
-done
+ unfolding real_of_int_def by (rule floor_less_iff)
-lemma floor_less_eq_number_of [simp]:
+lemma floor_less_eq_number_of:
"(floor x < number_of n) = (x < number_of n)"
-by (simp add: floor_less_eq)
+ by (rule floor_less_number_of) (* already declared [simp] *)
-lemma floor_less_eq_zero [simp]: "(floor x < 0) = (x < 0)"
-by (simp add: floor_less_eq)
+lemma floor_less_eq_zero: "(floor x < 0) = (x < 0)"
+ by (rule floor_less_zero) (* already declared [simp] *)
-lemma floor_less_eq_one [simp]: "(floor x < 1) = (x < 1)"
-by (simp add: floor_less_eq)
+lemma floor_less_eq_one: "(floor x < 1) = (x < 1)"
+ by (rule floor_less_one) (* already declared [simp] *)
lemma less_floor_eq: "(a < floor x) = (real a + 1 <= x)"
- apply (insert le_floor_eq [of "a + 1" x])
- apply auto
-done
+ unfolding real_of_int_def by (rule less_floor_iff)
-lemma less_floor_eq_number_of [simp]:
+lemma less_floor_eq_number_of:
"(number_of n < floor x) = (number_of n + 1 <= x)"
-by (simp add: less_floor_eq)
+ by (rule number_of_less_floor) (* already declared [simp] *)
-lemma less_floor_eq_zero [simp]: "(0 < floor x) = (1 <= x)"
-by (simp add: less_floor_eq)
+lemma less_floor_eq_zero: "(0 < floor x) = (1 <= x)"
+ by (rule zero_less_floor) (* already declared [simp] *)
-lemma less_floor_eq_one [simp]: "(1 < floor x) = (2 <= x)"
-by (simp add: less_floor_eq)
+lemma less_floor_eq_one: "(1 < floor x) = (2 <= x)"
+ by (rule one_less_floor) (* already declared [simp] *)
lemma floor_le_eq: "(floor x <= a) = (x < real a + 1)"
- apply (insert floor_less_eq [of x "a + 1"])
- apply auto
-done
+ unfolding real_of_int_def by (rule floor_le_iff)
-lemma floor_le_eq_number_of [simp]:
+lemma floor_le_eq_number_of:
"(floor x <= number_of n) = (x < number_of n + 1)"
-by (simp add: floor_le_eq)
+ by (rule floor_le_number_of) (* already declared [simp] *)
-lemma floor_le_eq_zero [simp]: "(floor x <= 0) = (x < 1)"
-by (simp add: floor_le_eq)
+lemma floor_le_eq_zero: "(floor x <= 0) = (x < 1)"
+ by (rule floor_le_zero) (* already declared [simp] *)
-lemma floor_le_eq_one [simp]: "(floor x <= 1) = (x < 2)"
-by (simp add: floor_le_eq)
+lemma floor_le_eq_one: "(floor x <= 1) = (x < 2)"
+ by (rule floor_le_one) (* already declared [simp] *)
lemma floor_add [simp]: "floor (x + real a) = floor x + a"
- apply (subst order_eq_iff)
- apply (rule conjI)
- prefer 2
- apply (subgoal_tac "floor x + a < floor (x + real a) + 1")
- apply arith
- apply (subst real_of_int_less_iff [THEN sym])
- apply simp
- apply (subgoal_tac "x + real a < real(floor(x + real a)) + 1")
- apply (subgoal_tac "real (floor x) <= x")
- apply arith
- apply (rule real_of_int_floor_le)
- apply (rule real_of_int_floor_add_one_gt)
- apply (subgoal_tac "floor (x + real a) < floor x + a + 1")
- apply arith
- apply (subst real_of_int_less_iff [THEN sym])
- apply simp
- apply (subgoal_tac "real(floor(x + real a)) <= x + real a")
- apply (subgoal_tac "x < real(floor x) + 1")
- apply arith
- apply (rule real_of_int_floor_add_one_gt)
- apply (rule real_of_int_floor_le)
-done
-
-lemma floor_add_number_of [simp]:
- "floor (x + number_of n) = floor x + number_of n"
- apply (subst floor_add [THEN sym])
- apply simp
-done
-
-lemma floor_add_one [simp]: "floor (x + 1) = floor x + 1"
- apply (subst floor_add [THEN sym])
- apply simp
-done
+ unfolding real_of_int_def by (rule floor_add_of_int)
lemma floor_subtract [simp]: "floor (x - real a) = floor x - a"
- apply (subst diff_minus)+
- apply (subst real_of_int_minus [THEN sym])
- apply (rule floor_add)
-done
+ unfolding real_of_int_def by (rule floor_diff_of_int)
-lemma floor_subtract_number_of [simp]: "floor (x - number_of n) =
+lemma floor_subtract_number_of: "floor (x - number_of n) =
floor x - number_of n"
- apply (subst floor_subtract [THEN sym])
- apply simp
-done
+ by (rule floor_diff_number_of) (* already declared [simp] *)
-lemma floor_subtract_one [simp]: "floor (x - 1) = floor x - 1"
- apply (subst floor_subtract [THEN sym])
- apply simp
-done
-
-lemma ceiling_zero [simp]: "ceiling 0 = 0"
-by (simp add: ceiling_def)
+lemma floor_subtract_one: "floor (x - 1) = floor x - 1"
+ by (rule floor_diff_one) (* already declared [simp] *)
lemma ceiling_real_of_nat [simp]: "ceiling (real (n::nat)) = int n"
-by (simp add: ceiling_def)
+ unfolding real_of_nat_def by simp
-lemma ceiling_real_of_nat_zero [simp]: "ceiling (real (0::nat)) = 0"
-by auto
+lemma ceiling_real_of_nat_zero: "ceiling (real (0::nat)) = 0"
+by auto (* delete? *)
lemma ceiling_floor [simp]: "ceiling (real (floor r)) = floor r"
-by (simp add: ceiling_def)
+ unfolding real_of_int_def by simp
lemma floor_ceiling [simp]: "floor (real (ceiling r)) = ceiling r"
-by (simp add: ceiling_def)
+ unfolding real_of_int_def by simp
lemma real_of_int_ceiling_ge [simp]: "r \<le> real (ceiling r)"
-apply (simp add: ceiling_def)
-apply (subst le_minus_iff, simp)
-done
+ unfolding real_of_int_def by (rule le_of_int_ceiling)
-lemma ceiling_mono: "x < y ==> ceiling x \<le> ceiling y"
-by (simp add: floor_mono ceiling_def)
-
-lemma ceiling_mono2: "x \<le> y ==> ceiling x \<le> ceiling y"
-by (simp add: floor_mono2 ceiling_def)
+lemma ceiling_real_of_int [simp]: "ceiling (real (n::int)) = n"
+ unfolding real_of_int_def by simp
lemma real_of_int_ceiling_cancel [simp]:
"(real (ceiling x) = x) = (\<exists>n::int. x = real n)"
-apply (auto simp add: ceiling_def)
-apply (drule arg_cong [where f = uminus], auto)
-apply (rule_tac x = "-n" in exI, auto)
-done
+ using ceiling_real_of_int by metis
lemma ceiling_eq: "[| real n < x; x < real n + 1 |] ==> ceiling x = n + 1"
-apply (simp add: ceiling_def)
-apply (rule minus_equation_iff [THEN iffD1])
-apply (simp add: floor_eq [where n = "-(n+1)"])
-done
+ unfolding real_of_int_def using ceiling_unique [of "n + 1" x] by simp
lemma ceiling_eq2: "[| real n < x; x \<le> real n + 1 |] ==> ceiling x = n + 1"
-by (simp add: ceiling_def floor_eq2 [where n = "-(n+1)"])
+ unfolding real_of_int_def using ceiling_unique [of "n + 1" x] by simp
lemma ceiling_eq3: "[| real n - 1 < x; x \<le> real n |] ==> ceiling x = n"
-by (simp add: ceiling_def floor_eq2 [where n = "-n"])
+ unfolding real_of_int_def using ceiling_unique [of n x] by simp
-lemma ceiling_real_of_int [simp]: "ceiling (real (n::int)) = n"
-by (simp add: ceiling_def)
-
-lemma ceiling_number_of_eq [simp]:
+lemma ceiling_number_of_eq:
"ceiling (number_of n :: real) = (number_of n)"
-apply (subst real_number_of [symmetric])
-apply (rule ceiling_real_of_int)
-done
-
-lemma ceiling_one [simp]: "ceiling 1 = 1"
- by (unfold ceiling_def, simp)
+ by (rule ceiling_number_of) (* already declared [simp] *)
lemma real_of_int_ceiling_diff_one_le [simp]: "real (ceiling r) - 1 \<le> r"
-apply (rule neg_le_iff_le [THEN iffD1])
-apply (simp add: ceiling_def diff_minus)
-done
+ unfolding real_of_int_def using ceiling_correct [of r] by simp
lemma real_of_int_ceiling_le_add_one [simp]: "real (ceiling r) \<le> r + 1"
-apply (insert real_of_int_ceiling_diff_one_le [of r])
-apply (simp del: real_of_int_ceiling_diff_one_le)
-done
+ unfolding real_of_int_def using ceiling_correct [of r] by simp
lemma ceiling_le: "x <= real a ==> ceiling x <= a"
- apply (unfold ceiling_def)
- apply (subgoal_tac "-a <= floor(- x)")
- apply simp
- apply (rule le_floor)
- apply simp
-done
+ unfolding real_of_int_def by (simp add: ceiling_le_iff)
lemma ceiling_le_real: "ceiling x <= a ==> x <= real a"
- apply (unfold ceiling_def)
- apply (subgoal_tac "real(- a) <= - x")
- apply simp
- apply (rule real_le_floor)
- apply simp
-done
+ unfolding real_of_int_def by (simp add: ceiling_le_iff)
lemma ceiling_le_eq: "(ceiling x <= a) = (x <= real a)"
- apply (rule iffI)
- apply (erule ceiling_le_real)
- apply (erule ceiling_le)
-done
+ unfolding real_of_int_def by (rule ceiling_le_iff)
-lemma ceiling_le_eq_number_of [simp]:
+lemma ceiling_le_eq_number_of:
"(ceiling x <= number_of n) = (x <= number_of n)"
-by (simp add: ceiling_le_eq)
+ by (rule ceiling_le_number_of) (* already declared [simp] *)
-lemma ceiling_le_zero_eq [simp]: "(ceiling x <= 0) = (x <= 0)"
-by (simp add: ceiling_le_eq)
+lemma ceiling_le_zero_eq: "(ceiling x <= 0) = (x <= 0)"
+ by (rule ceiling_le_zero) (* already declared [simp] *)
-lemma ceiling_le_eq_one [simp]: "(ceiling x <= 1) = (x <= 1)"
-by (simp add: ceiling_le_eq)
+lemma ceiling_le_eq_one: "(ceiling x <= 1) = (x <= 1)"
+ by (rule ceiling_le_one) (* already declared [simp] *)
lemma less_ceiling_eq: "(a < ceiling x) = (real a < x)"
- apply (subst linorder_not_le [THEN sym])+
- apply simp
- apply (rule ceiling_le_eq)
-done
+ unfolding real_of_int_def by (rule less_ceiling_iff)
-lemma less_ceiling_eq_number_of [simp]:
+lemma less_ceiling_eq_number_of:
"(number_of n < ceiling x) = (number_of n < x)"
-by (simp add: less_ceiling_eq)
+ by (rule number_of_less_ceiling) (* already declared [simp] *)
-lemma less_ceiling_eq_zero [simp]: "(0 < ceiling x) = (0 < x)"
-by (simp add: less_ceiling_eq)
+lemma less_ceiling_eq_zero: "(0 < ceiling x) = (0 < x)"
+ by (rule zero_less_ceiling) (* already declared [simp] *)
-lemma less_ceiling_eq_one [simp]: "(1 < ceiling x) = (1 < x)"
-by (simp add: less_ceiling_eq)
+lemma less_ceiling_eq_one: "(1 < ceiling x) = (1 < x)"
+ by (rule one_less_ceiling) (* already declared [simp] *)
lemma ceiling_less_eq: "(ceiling x < a) = (x <= real a - 1)"
- apply (insert ceiling_le_eq [of x "a - 1"])
- apply auto
-done
+ unfolding real_of_int_def by (rule ceiling_less_iff)
-lemma ceiling_less_eq_number_of [simp]:
+lemma ceiling_less_eq_number_of:
"(ceiling x < number_of n) = (x <= number_of n - 1)"
-by (simp add: ceiling_less_eq)
+ by (rule ceiling_less_number_of) (* already declared [simp] *)
-lemma ceiling_less_eq_zero [simp]: "(ceiling x < 0) = (x <= -1)"
-by (simp add: ceiling_less_eq)
+lemma ceiling_less_eq_zero: "(ceiling x < 0) = (x <= -1)"
+ by (rule ceiling_less_zero) (* already declared [simp] *)
-lemma ceiling_less_eq_one [simp]: "(ceiling x < 1) = (x <= 0)"
-by (simp add: ceiling_less_eq)
+lemma ceiling_less_eq_one: "(ceiling x < 1) = (x <= 0)"
+ by (rule ceiling_less_one) (* already declared [simp] *)
lemma le_ceiling_eq: "(a <= ceiling x) = (real a - 1 < x)"
- apply (insert less_ceiling_eq [of "a - 1" x])
- apply auto
-done
+ unfolding real_of_int_def by (rule le_ceiling_iff)
-lemma le_ceiling_eq_number_of [simp]:
+lemma le_ceiling_eq_number_of:
"(number_of n <= ceiling x) = (number_of n - 1 < x)"
-by (simp add: le_ceiling_eq)
+ by (rule number_of_le_ceiling) (* already declared [simp] *)
-lemma le_ceiling_eq_zero [simp]: "(0 <= ceiling x) = (-1 < x)"
-by (simp add: le_ceiling_eq)
+lemma le_ceiling_eq_zero: "(0 <= ceiling x) = (-1 < x)"
+ by (rule zero_le_ceiling) (* already declared [simp] *)
-lemma le_ceiling_eq_one [simp]: "(1 <= ceiling x) = (0 < x)"
-by (simp add: le_ceiling_eq)
+lemma le_ceiling_eq_one: "(1 <= ceiling x) = (0 < x)"
+ by (rule one_le_ceiling) (* already declared [simp] *)
lemma ceiling_add [simp]: "ceiling (x + real a) = ceiling x + a"
- apply (unfold ceiling_def, simp)
- apply (subst real_of_int_minus [THEN sym])
- apply (subst floor_add)
- apply simp
-done
-
-lemma ceiling_add_number_of [simp]: "ceiling (x + number_of n) =
- ceiling x + number_of n"
- apply (subst ceiling_add [THEN sym])
- apply simp
-done
-
-lemma ceiling_add_one [simp]: "ceiling (x + 1) = ceiling x + 1"
- apply (subst ceiling_add [THEN sym])
- apply simp
-done
+ unfolding real_of_int_def by (rule ceiling_add_of_int)
lemma ceiling_subtract [simp]: "ceiling (x - real a) = ceiling x - a"
- apply (subst diff_minus)+
- apply (subst real_of_int_minus [THEN sym])
- apply (rule ceiling_add)
-done
+ unfolding real_of_int_def by (rule ceiling_diff_of_int)
-lemma ceiling_subtract_number_of [simp]: "ceiling (x - number_of n) =
+lemma ceiling_subtract_number_of: "ceiling (x - number_of n) =
ceiling x - number_of n"
- apply (subst ceiling_subtract [THEN sym])
- apply simp
-done
+ by (rule ceiling_diff_number_of) (* already declared [simp] *)
-lemma ceiling_subtract_one [simp]: "ceiling (x - 1) = ceiling x - 1"
- apply (subst ceiling_subtract [THEN sym])
- apply simp
-done
+lemma ceiling_subtract_one: "ceiling (x - 1) = ceiling x - 1"
+ by (rule ceiling_diff_one) (* already declared [simp] *)
+
subsection {* Versions for the natural numbers *}
@@ -1015,7 +781,7 @@
apply (unfold natfloor_def)
apply (subgoal_tac "floor x <= floor 0")
apply simp
- apply (erule floor_mono2)
+ apply (erule floor_mono)
done
lemma natfloor_mono: "x <= y ==> natfloor x <= natfloor y"
@@ -1023,7 +789,7 @@
apply (subst natfloor_def)+
apply (subst nat_le_eq_zle)
apply force
- apply (erule floor_mono2)
+ apply (erule floor_mono)
apply (subst natfloor_neg)
apply simp
apply simp
@@ -1144,7 +910,7 @@
apply (subst real_nat_eq_real)
apply (subgoal_tac "ceiling 0 <= ceiling x")
apply simp
- apply (rule ceiling_mono2)
+ apply (rule ceiling_mono)
apply simp
apply simp
done
@@ -1165,7 +931,7 @@
apply simp
apply (erule order_trans)
apply simp
- apply (erule ceiling_mono2)
+ apply (erule ceiling_mono)
apply (subst natceiling_neg)
apply simp_all
done
@@ -1215,7 +981,7 @@
apply (subst eq_nat_nat_iff)
apply (subgoal_tac "ceiling 0 <= ceiling x")
apply simp
- apply (rule ceiling_mono2)
+ apply (rule ceiling_mono)
apply force
apply force
apply (rule ceiling_eq2)
@@ -1233,7 +999,7 @@
apply (subst nat_add_distrib)
apply (subgoal_tac "0 = ceiling 0")
apply (erule ssubst)
- apply (erule ceiling_mono2)
+ apply (erule ceiling_mono)
apply simp_all
done
--- a/src/HOL/Rational.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Rational.thy Thu Feb 26 11:21:29 2009 +0000
@@ -5,7 +5,7 @@
header {* Rational numbers *}
theory Rational
-imports GCD
+imports GCD Archimedean_Field
uses ("Tools/rat_arith.ML")
begin
@@ -255,7 +255,6 @@
with `b \<noteq> 0` have "a \<noteq> 0" by (simp add: Zero_rat_def eq_rat)
with Fract `q = Fract a b` `b \<noteq> 0` show C by auto
qed
-
subsubsection {* The field of rational numbers *}
@@ -532,8 +531,67 @@
qed
lemma zero_less_Fract_iff:
- "0 < b ==> (0 < Fract a b) = (0 < a)"
-by (simp add: Zero_rat_def order_less_imp_not_eq2 zero_less_mult_iff)
+ "0 < b \<Longrightarrow> 0 < Fract a b \<longleftrightarrow> 0 < a"
+ by (simp add: Zero_rat_def zero_less_mult_iff)
+
+lemma Fract_less_zero_iff:
+ "0 < b \<Longrightarrow> Fract a b < 0 \<longleftrightarrow> a < 0"
+ by (simp add: Zero_rat_def mult_less_0_iff)
+
+lemma zero_le_Fract_iff:
+ "0 < b \<Longrightarrow> 0 \<le> Fract a b \<longleftrightarrow> 0 \<le> a"
+ by (simp add: Zero_rat_def zero_le_mult_iff)
+
+lemma Fract_le_zero_iff:
+ "0 < b \<Longrightarrow> Fract a b \<le> 0 \<longleftrightarrow> a \<le> 0"
+ by (simp add: Zero_rat_def mult_le_0_iff)
+
+lemma one_less_Fract_iff:
+ "0 < b \<Longrightarrow> 1 < Fract a b \<longleftrightarrow> b < a"
+ by (simp add: One_rat_def mult_less_cancel_right_disj)
+
+lemma Fract_less_one_iff:
+ "0 < b \<Longrightarrow> Fract a b < 1 \<longleftrightarrow> a < b"
+ by (simp add: One_rat_def mult_less_cancel_right_disj)
+
+lemma one_le_Fract_iff:
+ "0 < b \<Longrightarrow> 1 \<le> Fract a b \<longleftrightarrow> b \<le> a"
+ by (simp add: One_rat_def mult_le_cancel_right)
+
+lemma Fract_le_one_iff:
+ "0 < b \<Longrightarrow> Fract a b \<le> 1 \<longleftrightarrow> a \<le> b"
+ by (simp add: One_rat_def mult_le_cancel_right)
+
+
+subsubsection {* Rationals are an Archimedean field *}
+
+lemma rat_floor_lemma:
+ assumes "0 < b"
+ shows "of_int (a div b) \<le> Fract a b \<and> Fract a b < of_int (a div b + 1)"
+proof -
+ have "Fract a b = of_int (a div b) + Fract (a mod b) b"
+ using `0 < b` by (simp add: of_int_rat)
+ moreover have "0 \<le> Fract (a mod b) b \<and> Fract (a mod b) b < 1"
+ using `0 < b` by (simp add: zero_le_Fract_iff Fract_less_one_iff)
+ ultimately show ?thesis by simp
+qed
+
+instance rat :: archimedean_field
+proof
+ fix r :: rat
+ show "\<exists>z. r \<le> of_int z"
+ proof (induct r)
+ case (Fract a b)
+ then have "Fract a b \<le> of_int (a div b + 1)"
+ using rat_floor_lemma [of b a] by simp
+ then show "\<exists>z. Fract a b \<le> of_int z" ..
+ qed
+qed
+
+lemma floor_Fract:
+ assumes "0 < b" shows "floor (Fract a b) = a div b"
+ using rat_floor_lemma [OF `0 < b`, of a]
+ by (simp add: floor_unique)
subsection {* Arithmetic setup *}
@@ -886,14 +944,13 @@
finally show ?thesis using assms by simp
qed
-lemma rat_less_eq_code [code]:
- "Fract a b \<le> Fract c d \<longleftrightarrow> (if b = 0
- then sgn c * sgn d \<ge> 0
- else if d = 0
- then sgn a * sgn b \<le> 0
- else a * \<bar>d\<bar> * sgn b \<le> c * \<bar>b\<bar> * sgn d)"
-by (auto simp add: sgn_times mult_le_0_iff zero_le_mult_iff le_rat' eq_rat simp del: le_rat)
- (auto simp add: sgn_times sgn_0_0 le_less sgn_1_pos [symmetric] sgn_1_neg [symmetric])
+lemma (in ordered_idom) sgn_greater [simp]:
+ "0 < sgn a \<longleftrightarrow> 0 < a"
+ unfolding sgn_if by auto
+
+lemma (in ordered_idom) sgn_less [simp]:
+ "sgn a < 0 \<longleftrightarrow> a < 0"
+ unfolding sgn_if by auto
lemma rat_le_eq_code [code]:
"Fract a b < Fract c d \<longleftrightarrow> (if b = 0
@@ -901,9 +958,17 @@
else if d = 0
then sgn a * sgn b < 0
else a * \<bar>d\<bar> * sgn b < c * \<bar>b\<bar> * sgn d)"
-by (auto simp add: sgn_times mult_less_0_iff zero_less_mult_iff less_rat' eq_rat simp del: less_rat)
- (auto simp add: sgn_times sgn_0_0 sgn_1_pos [symmetric] sgn_1_neg [symmetric],
- auto simp add: sgn_1_pos)
+ by (auto simp add: sgn_times mult_less_0_iff zero_less_mult_iff less_rat' eq_rat simp del: less_rat)
+
+lemma rat_less_eq_code [code]:
+ "Fract a b \<le> Fract c d \<longleftrightarrow> (if b = 0
+ then sgn c * sgn d \<ge> 0
+ else if d = 0
+ then sgn a * sgn b \<le> 0
+ else a * \<bar>d\<bar> * sgn b \<le> c * \<bar>b\<bar> * sgn d)"
+ by (auto simp add: sgn_times mult_le_0_iff zero_le_mult_iff le_rat' eq_rat simp del: le_rat)
+ (auto simp add: le_less not_less sgn_0_0)
+
lemma rat_plus_code [code]:
"Fract a b + Fract c d = (if b = 0
--- a/src/HOL/RealDef.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/RealDef.thy Thu Feb 26 11:21:29 2009 +0000
@@ -655,7 +655,7 @@
real(n div d) = real n / real d"
apply (frule real_of_int_div_aux [of d n])
apply simp
- apply (simp add: zdvd_iff_zmod_eq_0)
+ apply (simp add: dvd_eq_mod_eq_0)
done
lemma real_of_int_div2:
@@ -705,6 +705,9 @@
lemma real_of_nat_zero [simp]: "real (0::nat) = 0"
by (simp add: real_of_nat_def)
+lemma real_of_nat_1 [simp]: "real (1::nat) = 1"
+by (simp add: real_of_nat_def)
+
lemma real_of_nat_one [simp]: "real (Suc 0) = (1::real)"
by (simp add: real_of_nat_def)
--- a/src/HOL/RealPow.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/RealPow.thy Thu Feb 26 11:21:29 2009 +0000
@@ -44,7 +44,8 @@
by (insert power_decreasing [of 1 "Suc n" r], simp)
lemma realpow_minus_mult [rule_format]:
- "0 < n --> (x::real) ^ (n - 1) * x = x ^ n"
+ "0 < n --> (x::real) ^ (n - 1) * x = x ^ n"
+unfolding One_nat_def
apply (simp split add: nat_diff_split)
done
--- a/src/HOL/RealVector.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/RealVector.thy Thu Feb 26 11:21:29 2009 +0000
@@ -46,8 +46,10 @@
locale vector_space =
fixes scale :: "'a::field \<Rightarrow> 'b::ab_group_add \<Rightarrow> 'b"
- assumes scale_right_distrib: "scale a (x + y) = scale a x + scale a y"
- and scale_left_distrib: "scale (a + b) x = scale a x + scale b x"
+ assumes scale_right_distrib [algebra_simps]:
+ "scale a (x + y) = scale a x + scale a y"
+ and scale_left_distrib [algebra_simps]:
+ "scale (a + b) x = scale a x + scale b x"
and scale_scale [simp]: "scale a (scale b x) = scale (a * b) x"
and scale_one [simp]: "scale 1 x = x"
begin
@@ -58,7 +60,8 @@
lemma scale_zero_left [simp]: "scale 0 x = 0"
and scale_minus_left [simp]: "scale (- a) x = - (scale a x)"
- and scale_left_diff_distrib: "scale (a - b) x = scale a x - scale b x"
+ and scale_left_diff_distrib [algebra_simps]:
+ "scale (a - b) x = scale a x - scale b x"
proof -
interpret s: additive "\<lambda>a. scale a x"
proof qed (rule scale_left_distrib)
@@ -69,7 +72,8 @@
lemma scale_zero_right [simp]: "scale a 0 = 0"
and scale_minus_right [simp]: "scale a (- x) = - (scale a x)"
- and scale_right_diff_distrib: "scale a (x - y) = scale a x - scale a y"
+ and scale_right_diff_distrib [algebra_simps]:
+ "scale a (x - y) = scale a x - scale a y"
proof -
interpret s: additive "\<lambda>x. scale a x"
proof qed (rule scale_right_distrib)
@@ -135,21 +139,11 @@
end
-instantiation real :: scaleR
-begin
-
-definition
- real_scaleR_def [simp]: "scaleR a x = a * x"
-
-instance ..
-
-end
-
class real_vector = scaleR + ab_group_add +
assumes scaleR_right_distrib: "scaleR a (x + y) = scaleR a x + scaleR a y"
and scaleR_left_distrib: "scaleR (a + b) x = scaleR a x + scaleR b x"
- and scaleR_scaleR [simp]: "scaleR a (scaleR b x) = scaleR (a * b) x"
- and scaleR_one [simp]: "scaleR 1 x = x"
+ and scaleR_scaleR: "scaleR a (scaleR b x) = scaleR (a * b) x"
+ and scaleR_one: "scaleR 1 x = x"
interpretation real_vector!:
vector_space "scaleR :: real \<Rightarrow> 'a \<Rightarrow> 'a::real_vector"
@@ -185,15 +179,16 @@
class real_field = real_div_algebra + field
-instance real :: real_field
-apply (intro_classes, unfold real_scaleR_def)
-apply (rule right_distrib)
-apply (rule left_distrib)
-apply (rule mult_assoc [symmetric])
-apply (rule mult_1_left)
-apply (rule mult_assoc)
-apply (rule mult_left_commute)
-done
+instantiation real :: real_field
+begin
+
+definition
+ real_scaleR_def [simp]: "scaleR a x = a * x"
+
+instance proof
+qed (simp_all add: algebra_simps)
+
+end
interpretation scaleR_left!: additive "(\<lambda>a. scaleR a x::'a::real_vector)"
proof qed (rule scaleR_left_distrib)
@@ -307,7 +302,7 @@
definition
Reals :: "'a::real_algebra_1 set" where
- [code del]: "Reals \<equiv> range of_real"
+ [code del]: "Reals = range of_real"
notation (xsymbols)
Reals ("\<real>")
@@ -421,16 +416,6 @@
class norm =
fixes norm :: "'a \<Rightarrow> real"
-instantiation real :: norm
-begin
-
-definition
- real_norm_def [simp]: "norm r \<equiv> \<bar>r\<bar>"
-
-instance ..
-
-end
-
class sgn_div_norm = scaleR + norm + sgn +
assumes sgn_div_norm: "sgn x = x /\<^sub>R norm x"
@@ -462,7 +447,13 @@
thus "norm (1::'a) = 1" by simp
qed
-instance real :: real_normed_field
+instantiation real :: real_normed_field
+begin
+
+definition
+ real_norm_def [simp]: "norm r = \<bar>r\<bar>"
+
+instance
apply (intro_classes, unfold real_norm_def real_scaleR_def)
apply (simp add: real_sgn_def)
apply (rule abs_ge_zero)
@@ -472,6 +463,8 @@
apply (rule abs_mult)
done
+end
+
lemma norm_zero [simp]: "norm (0::'a::real_normed_vector) = 0"
by simp
--- a/src/HOL/Relation_Power.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Relation_Power.thy Thu Feb 26 11:21:29 2009 +0000
@@ -61,16 +61,16 @@
lemma funpow_swap1: "f((f^n) x) = (f^n)(f x)"
proof -
- have "f((f^n) x) = (f^(n+1)) x" by simp
+ have "f((f^n) x) = (f^(n+1)) x" unfolding One_nat_def by simp
also have "\<dots> = (f^n o f^1) x" by (simp only: funpow_add)
- also have "\<dots> = (f^n)(f x)" by simp
+ also have "\<dots> = (f^n)(f x)" unfolding One_nat_def by simp
finally show ?thesis .
qed
lemma rel_pow_1 [simp]:
fixes R :: "('a*'a)set"
shows "R^1 = R"
- by simp
+ unfolding One_nat_def by simp
lemma rel_pow_0_I: "(x,x) : R^0"
by simp
--- a/src/HOL/Ring_and_Field.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Ring_and_Field.thy Thu Feb 26 11:21:29 2009 +0000
@@ -1,5 +1,4 @@
(* Title: HOL/Ring_and_Field.thy
- ID: $Id$
Author: Gertrud Bauer, Steven Obua, Tobias Nipkow, Lawrence C Paulson, and Markus Wenzel,
with contributions by Jeremy Avigad
*)
@@ -148,10 +147,10 @@
lemma one_dvd [simp]: "1 dvd a"
by (auto intro!: dvdI)
-lemma dvd_mult: "a dvd c \<Longrightarrow> a dvd (b * c)"
+lemma dvd_mult[simp]: "a dvd c \<Longrightarrow> a dvd (b * c)"
by (auto intro!: mult_left_commute dvdI elim!: dvdE)
-lemma dvd_mult2: "a dvd b \<Longrightarrow> a dvd (b * c)"
+lemma dvd_mult2[simp]: "a dvd b \<Longrightarrow> a dvd (b * c)"
apply (subst mult_commute)
apply (erule dvd_mult)
done
@@ -163,12 +162,12 @@
by (rule dvd_mult2) (rule dvd_refl)
lemma mult_dvd_mono:
- assumes ab: "a dvd b"
- and "cd": "c dvd d"
+ assumes "a dvd b"
+ and "c dvd d"
shows "a * c dvd b * d"
proof -
- from ab obtain b' where "b = a * b'" ..
- moreover from "cd" obtain d' where "d = c * d'" ..
+ from `a dvd b` obtain b' where "b = a * b'" ..
+ moreover from `c dvd d` obtain d' where "d = c * d'" ..
ultimately have "b * d = (a * c) * (b' * d')" by (simp add: mult_ac)
then show ?thesis ..
qed
@@ -311,8 +310,8 @@
then show "- x dvd y" ..
qed
-lemma dvd_diff: "x dvd y \<Longrightarrow> x dvd z \<Longrightarrow> x dvd (y - z)"
-by (simp add: diff_minus dvd_add dvd_minus_iff)
+lemma dvd_diff[simp]: "x dvd y \<Longrightarrow> x dvd z \<Longrightarrow> x dvd (y - z)"
+by (simp add: diff_minus dvd_minus_iff)
end
@@ -385,6 +384,26 @@
then show "a * a = b * b" by auto
qed
+lemma dvd_mult_cancel_right [simp]:
+ "a * c dvd b * c \<longleftrightarrow> c = 0 \<or> a dvd b"
+proof -
+ have "a * c dvd b * c \<longleftrightarrow> (\<exists>k. b * c = (a * k) * c)"
+ unfolding dvd_def by (simp add: mult_ac)
+ also have "(\<exists>k. b * c = (a * k) * c) \<longleftrightarrow> c = 0 \<or> a dvd b"
+ unfolding dvd_def by simp
+ finally show ?thesis .
+qed
+
+lemma dvd_mult_cancel_left [simp]:
+ "c * a dvd c * b \<longleftrightarrow> c = 0 \<or> a dvd b"
+proof -
+ have "c * a dvd c * b \<longleftrightarrow> (\<exists>k. b * c = (a * k) * c)"
+ unfolding dvd_def by (simp add: mult_ac)
+ also have "(\<exists>k. b * c = (a * k) * c) \<longleftrightarrow> c = 0 \<or> a dvd b"
+ unfolding dvd_def by simp
+ finally show ?thesis .
+qed
+
end
class division_ring = ring_1 + inverse +
@@ -1078,6 +1097,14 @@
"sgn a = - 1 \<longleftrightarrow> a < 0"
unfolding sgn_if by (auto simp add: equal_neg_zero)
+lemma sgn_pos [simp]:
+ "0 < a \<Longrightarrow> sgn a = 1"
+unfolding sgn_1_pos .
+
+lemma sgn_neg [simp]:
+ "a < 0 \<Longrightarrow> sgn a = - 1"
+unfolding sgn_1_neg .
+
lemma sgn_times:
"sgn (a * b) = sgn a * sgn b"
by (auto simp add: sgn_if zero_less_mult_iff)
@@ -1085,32 +1112,19 @@
lemma abs_sgn: "abs k = k * sgn k"
unfolding sgn_if abs_if by auto
-(* The int instances are proved, these generic ones are tedious to prove here.
-And not very useful, as int seems to be the only instance.
-If needed, they should be proved later, when metis is available.
-lemma dvd_abs[simp]: "(abs m) dvd k \<longleftrightarrow> m dvd k"
-proof-
- have "\<forall>k.\<exists>ka. - (m * k) = m * ka"
- by(simp add: mult_minus_right[symmetric] del: mult_minus_right)
- moreover
- have "\<forall>k.\<exists>ka. m * k = - (m * ka)"
- by(auto intro!: minus_minus[symmetric]
- simp add: mult_minus_right[symmetric] simp del: mult_minus_right)
- ultimately show ?thesis by (auto simp: abs_if dvd_def)
-qed
-
-lemma dvd_abs2[simp]: "m dvd (abs k) \<longleftrightarrow> m dvd k"
-proof-
- have "\<forall>k.\<exists>ka. - (m * k) = m * ka"
- by(simp add: mult_minus_right[symmetric] del: mult_minus_right)
- moreover
- have "\<forall>k.\<exists>ka. - (m * ka) = m * k"
- by(auto intro!: minus_minus
- simp add: mult_minus_right[symmetric] simp del: mult_minus_right)
- ultimately show ?thesis
- by (auto simp add:abs_if dvd_def minus_equation_iff[of k])
-qed
-*)
+lemma sgn_greater [simp]:
+ "0 < sgn a \<longleftrightarrow> 0 < a"
+ unfolding sgn_if by auto
+
+lemma sgn_less [simp]:
+ "sgn a < 0 \<longleftrightarrow> a < 0"
+ unfolding sgn_if by auto
+
+lemma abs_dvd_iff [simp]: "(abs m) dvd k \<longleftrightarrow> m dvd k"
+ by (simp add: abs_if)
+
+lemma dvd_abs_iff [simp]: "m dvd (abs k) \<longleftrightarrow> m dvd k"
+ by (simp add: abs_if)
end
--- a/src/HOL/SEQ.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/SEQ.thy Thu Feb 26 11:21:29 2009 +0000
@@ -338,10 +338,10 @@
done
lemma LIMSEQ_Suc: "f ----> l \<Longrightarrow> (\<lambda>n. f (Suc n)) ----> l"
-by (drule_tac k="1" in LIMSEQ_ignore_initial_segment, simp)
+by (drule_tac k="Suc 0" in LIMSEQ_ignore_initial_segment, simp)
lemma LIMSEQ_imp_Suc: "(\<lambda>n. f (Suc n)) ----> l \<Longrightarrow> f ----> l"
-by (rule_tac k="1" in LIMSEQ_offset, simp)
+by (rule_tac k="Suc 0" in LIMSEQ_offset, simp)
lemma LIMSEQ_Suc_iff: "(\<lambda>n. f (Suc n)) ----> l = f ----> l"
by (blast intro: LIMSEQ_imp_Suc LIMSEQ_Suc)
--- a/src/HOL/Series.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Series.thy Thu Feb 26 11:21:29 2009 +0000
@@ -312,6 +312,7 @@
shows "\<lbrakk>summable f;
\<forall>d. 0 < f (k + (Suc(Suc 0) * d)) + f (k + ((Suc(Suc 0) * d) + 1))\<rbrakk>
\<Longrightarrow> setsum f {0..<k} < suminf f"
+unfolding One_nat_def
apply (subst suminf_split_initial_segment [where k="k"])
apply assumption
apply simp
@@ -537,7 +538,7 @@
apply (safe, subgoal_tac "\<forall>n. N < n --> f (n) = 0")
prefer 2
apply clarify
- apply(erule_tac x = "n - 1" in allE)
+ apply(erule_tac x = "n - Suc 0" in allE)
apply (simp add:diff_Suc split:nat.splits)
apply (blast intro: norm_ratiotest_lemma)
apply (rule_tac x = "Suc N" in exI, clarify)
--- a/src/HOL/SetInterval.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/SetInterval.thy Thu Feb 26 11:21:29 2009 +0000
@@ -352,11 +352,11 @@
corollary image_Suc_atLeastAtMost[simp]:
"Suc ` {i..j} = {Suc i..Suc j}"
-using image_add_atLeastAtMost[where k=1] by simp
+using image_add_atLeastAtMost[where k="Suc 0"] by simp
corollary image_Suc_atLeastLessThan[simp]:
"Suc ` {i..<j} = {Suc i..<Suc j}"
-using image_add_atLeastLessThan[where k=1] by simp
+using image_add_atLeastLessThan[where k="Suc 0"] by simp
lemma image_add_int_atLeastLessThan:
"(%x. x + (l::int)) ` {0..<u-l} = {l..<u}"
@@ -556,7 +556,7 @@
qed
lemma card_less_Suc2: "0 \<notin> M \<Longrightarrow> card {k. Suc k \<in> M \<and> k < i} = card {k \<in> M. k < Suc i}"
-apply (rule card_bij_eq [of "Suc" _ _ "\<lambda>x. x - 1"])
+apply (rule card_bij_eq [of "Suc" _ _ "\<lambda>x. x - Suc 0"])
apply simp
apply fastsimp
apply auto
@@ -803,7 +803,7 @@
lemma setsum_head_upt_Suc:
"m < n \<Longrightarrow> setsum f {m..<n} = f m + setsum f {Suc m..<n}"
-apply(insert setsum_head_Suc[of m "n - 1" f])
+apply(insert setsum_head_Suc[of m "n - Suc 0" f])
apply (simp add: atLeastLessThanSuc_atLeastAtMost[symmetric] algebra_simps)
done
@@ -835,11 +835,11 @@
corollary setsum_shift_bounds_cl_Suc_ivl:
"setsum f {Suc m..Suc n} = setsum (%i. f(Suc i)){m..n}"
-by (simp add:setsum_shift_bounds_cl_nat_ivl[where k=1,simplified])
+by (simp add:setsum_shift_bounds_cl_nat_ivl[where k="Suc 0", simplified])
corollary setsum_shift_bounds_Suc_ivl:
"setsum f {Suc m..<Suc n} = setsum (%i. f(Suc i)){m..<n}"
-by (simp add:setsum_shift_bounds_nat_ivl[where k=1,simplified])
+by (simp add:setsum_shift_bounds_nat_ivl[where k="Suc 0", simplified])
lemma setsum_shift_lb_Suc0_0:
"f(0::nat) = (0::nat) \<Longrightarrow> setsum f {Suc 0..k} = setsum f {0..k}"
@@ -883,6 +883,7 @@
by (rule setsum_addf)
also from ngt1 have "\<dots> = ?n*a + (\<Sum>i\<in>{..<n}. ?I i*d)" by simp
also from ngt1 have "\<dots> = (?n*a + d*(\<Sum>i\<in>{1..<n}. ?I i))"
+ unfolding One_nat_def
by (simp add: setsum_right_distrib atLeast0LessThan[symmetric] setsum_shift_lb_Suc0_0_upt mult_ac)
also have "(1+1)*\<dots> = (1+1)*?n*a + d*(1+1)*(\<Sum>i\<in>{1..<n}. ?I i)"
by (simp add: left_distrib right_distrib)
@@ -890,7 +891,7 @@
by (cases n) (auto simp: atLeastLessThanSuc_atLeastAtMost)
also from ngt1
have "(1+1)*?n*a + d*(1+1)*(\<Sum>i\<in>{1..n - 1}. ?I i) = ((1+1)*?n*a + d*?I (n - 1)*?I n)"
- by (simp only: mult_ac gauss_sum [of "n - 1"])
+ by (simp only: mult_ac gauss_sum [of "n - 1"], unfold One_nat_def)
(simp add: mult_ac trans [OF add_commute of_nat_Suc [symmetric]])
finally show ?thesis by (simp add: algebra_simps)
next
@@ -906,7 +907,8 @@
"((1::nat) + 1) * (\<Sum>i\<in>{..<n::nat}. a + of_nat(i)*d) =
of_nat(n) * (a + (a + of_nat(n - 1)*d))"
by (rule arith_series_general)
- thus ?thesis by (auto simp add: of_nat_id)
+ thus ?thesis
+ unfolding One_nat_def by (auto simp add: of_nat_id)
qed
lemma arith_series_int:
--- a/src/HOL/Tools/Qelim/generated_cooper.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Tools/Qelim/generated_cooper.ML Thu Feb 26 11:21:29 2009 +0000
@@ -15,13 +15,13 @@
fun divmod n m = (if eqop eq_nat m 0 then (0, n) else IntInf.divMod (n, m));
-fun snd (a, y) = y;
+fun snd (a, b) = b;
fun mod_nat m n = snd (divmod m n);
fun gcd m n = (if eqop eq_nat n 0 then m else gcd n (mod_nat m n));
-fun fst (y, b) = y;
+fun fst (a, b) = a;
fun div_nat m n = fst (divmod m n);
@@ -48,7 +48,7 @@
fun map f [] = []
| map f (x :: xs) = f x :: map f xs;
-fun append [] y = y
+fun append [] ys = ys
| append (x :: xs) ys = x :: append xs ys;
fun disjuncts (Or (p, q)) = append (disjuncts p) (disjuncts q)
@@ -105,53 +105,53 @@
(Le num) = f4 num
| fm_case f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19
(Lt num) = f3 num
- | fm_case f1 y f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 F
- = y
- | fm_case y f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 T
- = y;
+ | fm_case f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 F
+ = f2
+ | fm_case f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18 f19 T
+ = f1;
-fun eq_num (Mul (cb, dc)) (Sub (ae, be)) = false
- | eq_num (Mul (cb, dc)) (Add (ae, be)) = false
- | eq_num (Sub (cc, dc)) (Add (ae, be)) = false
- | eq_num (Mul (bd, cc)) (Neg ae) = false
- | eq_num (Sub (be, cc)) (Neg ae) = false
- | eq_num (Add (be, cc)) (Neg ae) = false
- | eq_num (Mul (db, ea)) (Cn (ac, bd, cc)) = false
- | eq_num (Sub (dc, ea)) (Cn (ac, bd, cc)) = false
- | eq_num (Add (dc, ea)) (Cn (ac, bd, cc)) = false
- | eq_num (Neg dc) (Cn (ac, bd, cc)) = false
- | eq_num (Mul (bd, cc)) (Bound ac) = false
- | eq_num (Sub (be, cc)) (Bound ac) = false
- | eq_num (Add (be, cc)) (Bound ac) = false
- | eq_num (Neg be) (Bound ac) = false
- | eq_num (Cn (bc, cb, dc)) (Bound ac) = false
- | eq_num (Mul (bd, cc)) (C ad) = false
- | eq_num (Sub (be, cc)) (C ad) = false
- | eq_num (Add (be, cc)) (C ad) = false
- | eq_num (Neg be) (C ad) = false
- | eq_num (Cn (bc, cb, dc)) (C ad) = false
- | eq_num (Bound bc) (C ad) = false
- | eq_num (Sub (ab, bb)) (Mul (c, da)) = false
- | eq_num (Add (ab, bb)) (Mul (c, da)) = false
- | eq_num (Add (ab, bb)) (Sub (ca, da)) = false
- | eq_num (Neg ab) (Mul (ba, ca)) = false
- | eq_num (Neg ab) (Sub (bb, ca)) = false
- | eq_num (Neg ab) (Add (bb, ca)) = false
- | eq_num (Cn (a, ba, ca)) (Mul (d, e)) = false
- | eq_num (Cn (a, ba, ca)) (Sub (da, e)) = false
- | eq_num (Cn (a, ba, ca)) (Add (da, e)) = false
- | eq_num (Cn (a, ba, ca)) (Neg da) = false
- | eq_num (Bound a) (Mul (ba, ca)) = false
- | eq_num (Bound a) (Sub (bb, ca)) = false
- | eq_num (Bound a) (Add (bb, ca)) = false
- | eq_num (Bound a) (Neg bb) = false
- | eq_num (Bound a) (Cn (b, c, da)) = false
- | eq_num (C aa) (Mul (ba, ca)) = false
- | eq_num (C aa) (Sub (bb, ca)) = false
- | eq_num (C aa) (Add (bb, ca)) = false
- | eq_num (C aa) (Neg bb) = false
- | eq_num (C aa) (Cn (b, c, da)) = false
- | eq_num (C aa) (Bound b) = false
+fun eq_num (Mul (c, d)) (Sub (a, b)) = false
+ | eq_num (Mul (c, d)) (Add (a, b)) = false
+ | eq_num (Sub (c, d)) (Add (a, b)) = false
+ | eq_num (Mul (b, c)) (Neg a) = false
+ | eq_num (Sub (b, c)) (Neg a) = false
+ | eq_num (Add (b, c)) (Neg a) = false
+ | eq_num (Mul (d, e)) (Cn (a, b, c)) = false
+ | eq_num (Sub (d, e)) (Cn (a, b, c)) = false
+ | eq_num (Add (d, e)) (Cn (a, b, c)) = false
+ | eq_num (Neg d) (Cn (a, b, c)) = false
+ | eq_num (Mul (b, c)) (Bound a) = false
+ | eq_num (Sub (b, c)) (Bound a) = false
+ | eq_num (Add (b, c)) (Bound a) = false
+ | eq_num (Neg b) (Bound a) = false
+ | eq_num (Cn (b, c, d)) (Bound a) = false
+ | eq_num (Mul (b, c)) (C a) = false
+ | eq_num (Sub (b, c)) (C a) = false
+ | eq_num (Add (b, c)) (C a) = false
+ | eq_num (Neg b) (C a) = false
+ | eq_num (Cn (b, c, d)) (C a) = false
+ | eq_num (Bound b) (C a) = false
+ | eq_num (Sub (a, b)) (Mul (c, d)) = false
+ | eq_num (Add (a, b)) (Mul (c, d)) = false
+ | eq_num (Add (a, b)) (Sub (c, d)) = false
+ | eq_num (Neg a) (Mul (b, c)) = false
+ | eq_num (Neg a) (Sub (b, c)) = false
+ | eq_num (Neg a) (Add (b, c)) = false
+ | eq_num (Cn (a, b, c)) (Mul (d, e)) = false
+ | eq_num (Cn (a, b, c)) (Sub (d, e)) = false
+ | eq_num (Cn (a, b, c)) (Add (d, e)) = false
+ | eq_num (Cn (a, b, c)) (Neg d) = false
+ | eq_num (Bound a) (Mul (b, c)) = false
+ | eq_num (Bound a) (Sub (b, c)) = false
+ | eq_num (Bound a) (Add (b, c)) = false
+ | eq_num (Bound a) (Neg b) = false
+ | eq_num (Bound a) (Cn (b, c, d)) = false
+ | eq_num (C a) (Mul (b, c)) = false
+ | eq_num (C a) (Sub (b, c)) = false
+ | eq_num (C a) (Add (b, c)) = false
+ | eq_num (C a) (Neg b) = false
+ | eq_num (C a) (Cn (b, c, d)) = false
+ | eq_num (C a) (Bound b) = false
| eq_num (Mul (inta, num)) (Mul (int', num')) =
((inta : IntInf.int) = int') andalso eq_num num num'
| eq_num (Sub (num1, num2)) (Sub (num1', num2')) =
@@ -165,347 +165,347 @@
| eq_num (Bound nat) (Bound nat') = ((nat : IntInf.int) = nat')
| eq_num (C inta) (C int') = ((inta : IntInf.int) = int');
-fun eq_fm (NClosed bd) (Closed ad) = false
- | eq_fm (NClosed bd) (A af) = false
- | eq_fm (Closed bd) (A af) = false
- | eq_fm (NClosed bd) (E af) = false
- | eq_fm (Closed bd) (E af) = false
- | eq_fm (A bf) (E af) = false
- | eq_fm (NClosed cd) (Iff (af, bf)) = false
- | eq_fm (Closed cd) (Iff (af, bf)) = false
- | eq_fm (A cf) (Iff (af, bf)) = false
- | eq_fm (E cf) (Iff (af, bf)) = false
- | eq_fm (NClosed cd) (Imp (af, bf)) = false
- | eq_fm (Closed cd) (Imp (af, bf)) = false
- | eq_fm (A cf) (Imp (af, bf)) = false
- | eq_fm (E cf) (Imp (af, bf)) = false
- | eq_fm (Iff (cf, db)) (Imp (af, bf)) = false
- | eq_fm (NClosed cd) (Or (af, bf)) = false
- | eq_fm (Closed cd) (Or (af, bf)) = false
- | eq_fm (A cf) (Or (af, bf)) = false
- | eq_fm (E cf) (Or (af, bf)) = false
- | eq_fm (Iff (cf, db)) (Or (af, bf)) = false
- | eq_fm (Imp (cf, db)) (Or (af, bf)) = false
- | eq_fm (NClosed cd) (And (af, bf)) = false
- | eq_fm (Closed cd) (And (af, bf)) = false
- | eq_fm (A cf) (And (af, bf)) = false
- | eq_fm (E cf) (And (af, bf)) = false
- | eq_fm (Iff (cf, db)) (And (af, bf)) = false
- | eq_fm (Imp (cf, db)) (And (af, bf)) = false
- | eq_fm (Or (cf, db)) (And (af, bf)) = false
- | eq_fm (NClosed bd) (Not af) = false
- | eq_fm (Closed bd) (Not af) = false
- | eq_fm (A bf) (Not af) = false
- | eq_fm (E bf) (Not af) = false
- | eq_fm (Iff (bf, cf)) (Not af) = false
- | eq_fm (Imp (bf, cf)) (Not af) = false
- | eq_fm (Or (bf, cf)) (Not af) = false
- | eq_fm (And (bf, cf)) (Not af) = false
- | eq_fm (NClosed cd) (NDvd (ae, bg)) = false
- | eq_fm (Closed cd) (NDvd (ae, bg)) = false
- | eq_fm (A cf) (NDvd (ae, bg)) = false
- | eq_fm (E cf) (NDvd (ae, bg)) = false
- | eq_fm (Iff (cf, db)) (NDvd (ae, bg)) = false
- | eq_fm (Imp (cf, db)) (NDvd (ae, bg)) = false
- | eq_fm (Or (cf, db)) (NDvd (ae, bg)) = false
- | eq_fm (And (cf, db)) (NDvd (ae, bg)) = false
- | eq_fm (Not cf) (NDvd (ae, bg)) = false
- | eq_fm (NClosed cd) (Dvd (ae, bg)) = false
- | eq_fm (Closed cd) (Dvd (ae, bg)) = false
- | eq_fm (A cf) (Dvd (ae, bg)) = false
- | eq_fm (E cf) (Dvd (ae, bg)) = false
- | eq_fm (Iff (cf, db)) (Dvd (ae, bg)) = false
- | eq_fm (Imp (cf, db)) (Dvd (ae, bg)) = false
- | eq_fm (Or (cf, db)) (Dvd (ae, bg)) = false
- | eq_fm (And (cf, db)) (Dvd (ae, bg)) = false
- | eq_fm (Not cf) (Dvd (ae, bg)) = false
- | eq_fm (NDvd (ce, dc)) (Dvd (ae, bg)) = false
- | eq_fm (NClosed bd) (NEq ag) = false
- | eq_fm (Closed bd) (NEq ag) = false
- | eq_fm (A bf) (NEq ag) = false
- | eq_fm (E bf) (NEq ag) = false
- | eq_fm (Iff (bf, cf)) (NEq ag) = false
- | eq_fm (Imp (bf, cf)) (NEq ag) = false
- | eq_fm (Or (bf, cf)) (NEq ag) = false
- | eq_fm (And (bf, cf)) (NEq ag) = false
- | eq_fm (Not bf) (NEq ag) = false
- | eq_fm (NDvd (be, cg)) (NEq ag) = false
- | eq_fm (Dvd (be, cg)) (NEq ag) = false
- | eq_fm (NClosed bd) (Eq ag) = false
- | eq_fm (Closed bd) (Eq ag) = false
- | eq_fm (A bf) (Eq ag) = false
- | eq_fm (E bf) (Eq ag) = false
- | eq_fm (Iff (bf, cf)) (Eq ag) = false
- | eq_fm (Imp (bf, cf)) (Eq ag) = false
- | eq_fm (Or (bf, cf)) (Eq ag) = false
- | eq_fm (And (bf, cf)) (Eq ag) = false
- | eq_fm (Not bf) (Eq ag) = false
- | eq_fm (NDvd (be, cg)) (Eq ag) = false
- | eq_fm (Dvd (be, cg)) (Eq ag) = false
- | eq_fm (NEq bg) (Eq ag) = false
- | eq_fm (NClosed bd) (Ge ag) = false
- | eq_fm (Closed bd) (Ge ag) = false
- | eq_fm (A bf) (Ge ag) = false
- | eq_fm (E bf) (Ge ag) = false
- | eq_fm (Iff (bf, cf)) (Ge ag) = false
- | eq_fm (Imp (bf, cf)) (Ge ag) = false
- | eq_fm (Or (bf, cf)) (Ge ag) = false
- | eq_fm (And (bf, cf)) (Ge ag) = false
- | eq_fm (Not bf) (Ge ag) = false
- | eq_fm (NDvd (be, cg)) (Ge ag) = false
- | eq_fm (Dvd (be, cg)) (Ge ag) = false
- | eq_fm (NEq bg) (Ge ag) = false
- | eq_fm (Eq bg) (Ge ag) = false
- | eq_fm (NClosed bd) (Gt ag) = false
- | eq_fm (Closed bd) (Gt ag) = false
- | eq_fm (A bf) (Gt ag) = false
- | eq_fm (E bf) (Gt ag) = false
- | eq_fm (Iff (bf, cf)) (Gt ag) = false
- | eq_fm (Imp (bf, cf)) (Gt ag) = false
- | eq_fm (Or (bf, cf)) (Gt ag) = false
- | eq_fm (And (bf, cf)) (Gt ag) = false
- | eq_fm (Not bf) (Gt ag) = false
- | eq_fm (NDvd (be, cg)) (Gt ag) = false
- | eq_fm (Dvd (be, cg)) (Gt ag) = false
- | eq_fm (NEq bg) (Gt ag) = false
- | eq_fm (Eq bg) (Gt ag) = false
- | eq_fm (Ge bg) (Gt ag) = false
- | eq_fm (NClosed bd) (Le ag) = false
- | eq_fm (Closed bd) (Le ag) = false
- | eq_fm (A bf) (Le ag) = false
- | eq_fm (E bf) (Le ag) = false
- | eq_fm (Iff (bf, cf)) (Le ag) = false
- | eq_fm (Imp (bf, cf)) (Le ag) = false
- | eq_fm (Or (bf, cf)) (Le ag) = false
- | eq_fm (And (bf, cf)) (Le ag) = false
- | eq_fm (Not bf) (Le ag) = false
- | eq_fm (NDvd (be, cg)) (Le ag) = false
- | eq_fm (Dvd (be, cg)) (Le ag) = false
- | eq_fm (NEq bg) (Le ag) = false
- | eq_fm (Eq bg) (Le ag) = false
- | eq_fm (Ge bg) (Le ag) = false
- | eq_fm (Gt bg) (Le ag) = false
- | eq_fm (NClosed bd) (Lt ag) = false
- | eq_fm (Closed bd) (Lt ag) = false
- | eq_fm (A bf) (Lt ag) = false
- | eq_fm (E bf) (Lt ag) = false
- | eq_fm (Iff (bf, cf)) (Lt ag) = false
- | eq_fm (Imp (bf, cf)) (Lt ag) = false
- | eq_fm (Or (bf, cf)) (Lt ag) = false
- | eq_fm (And (bf, cf)) (Lt ag) = false
- | eq_fm (Not bf) (Lt ag) = false
- | eq_fm (NDvd (be, cg)) (Lt ag) = false
- | eq_fm (Dvd (be, cg)) (Lt ag) = false
- | eq_fm (NEq bg) (Lt ag) = false
- | eq_fm (Eq bg) (Lt ag) = false
- | eq_fm (Ge bg) (Lt ag) = false
- | eq_fm (Gt bg) (Lt ag) = false
- | eq_fm (Le bg) (Lt ag) = false
- | eq_fm (NClosed ad) F = false
- | eq_fm (Closed ad) F = false
- | eq_fm (A af) F = false
- | eq_fm (E af) F = false
- | eq_fm (Iff (af, bf)) F = false
- | eq_fm (Imp (af, bf)) F = false
- | eq_fm (Or (af, bf)) F = false
- | eq_fm (And (af, bf)) F = false
- | eq_fm (Not af) F = false
- | eq_fm (NDvd (ae, bg)) F = false
- | eq_fm (Dvd (ae, bg)) F = false
- | eq_fm (NEq ag) F = false
- | eq_fm (Eq ag) F = false
- | eq_fm (Ge ag) F = false
- | eq_fm (Gt ag) F = false
- | eq_fm (Le ag) F = false
- | eq_fm (Lt ag) F = false
- | eq_fm (NClosed ad) T = false
- | eq_fm (Closed ad) T = false
- | eq_fm (A af) T = false
- | eq_fm (E af) T = false
- | eq_fm (Iff (af, bf)) T = false
- | eq_fm (Imp (af, bf)) T = false
- | eq_fm (Or (af, bf)) T = false
- | eq_fm (And (af, bf)) T = false
- | eq_fm (Not af) T = false
- | eq_fm (NDvd (ae, bg)) T = false
- | eq_fm (Dvd (ae, bg)) T = false
- | eq_fm (NEq ag) T = false
- | eq_fm (Eq ag) T = false
- | eq_fm (Ge ag) T = false
- | eq_fm (Gt ag) T = false
- | eq_fm (Le ag) T = false
- | eq_fm (Lt ag) T = false
+fun eq_fm (NClosed b) (Closed a) = false
+ | eq_fm (NClosed b) (A a) = false
+ | eq_fm (Closed b) (A a) = false
+ | eq_fm (NClosed b) (E a) = false
+ | eq_fm (Closed b) (E a) = false
+ | eq_fm (A b) (E a) = false
+ | eq_fm (NClosed c) (Iff (a, b)) = false
+ | eq_fm (Closed c) (Iff (a, b)) = false
+ | eq_fm (A c) (Iff (a, b)) = false
+ | eq_fm (E c) (Iff (a, b)) = false
+ | eq_fm (NClosed c) (Imp (a, b)) = false
+ | eq_fm (Closed c) (Imp (a, b)) = false
+ | eq_fm (A c) (Imp (a, b)) = false
+ | eq_fm (E c) (Imp (a, b)) = false
+ | eq_fm (Iff (c, d)) (Imp (a, b)) = false
+ | eq_fm (NClosed c) (Or (a, b)) = false
+ | eq_fm (Closed c) (Or (a, b)) = false
+ | eq_fm (A c) (Or (a, b)) = false
+ | eq_fm (E c) (Or (a, b)) = false
+ | eq_fm (Iff (c, d)) (Or (a, b)) = false
+ | eq_fm (Imp (c, d)) (Or (a, b)) = false
+ | eq_fm (NClosed c) (And (a, b)) = false
+ | eq_fm (Closed c) (And (a, b)) = false
+ | eq_fm (A c) (And (a, b)) = false
+ | eq_fm (E c) (And (a, b)) = false
+ | eq_fm (Iff (c, d)) (And (a, b)) = false
+ | eq_fm (Imp (c, d)) (And (a, b)) = false
+ | eq_fm (Or (c, d)) (And (a, b)) = false
+ | eq_fm (NClosed b) (Not a) = false
+ | eq_fm (Closed b) (Not a) = false
+ | eq_fm (A b) (Not a) = false
+ | eq_fm (E b) (Not a) = false
+ | eq_fm (Iff (b, c)) (Not a) = false
+ | eq_fm (Imp (b, c)) (Not a) = false
+ | eq_fm (Or (b, c)) (Not a) = false
+ | eq_fm (And (b, c)) (Not a) = false
+ | eq_fm (NClosed c) (NDvd (a, b)) = false
+ | eq_fm (Closed c) (NDvd (a, b)) = false
+ | eq_fm (A c) (NDvd (a, b)) = false
+ | eq_fm (E c) (NDvd (a, b)) = false
+ | eq_fm (Iff (c, d)) (NDvd (a, b)) = false
+ | eq_fm (Imp (c, d)) (NDvd (a, b)) = false
+ | eq_fm (Or (c, d)) (NDvd (a, b)) = false
+ | eq_fm (And (c, d)) (NDvd (a, b)) = false
+ | eq_fm (Not c) (NDvd (a, b)) = false
+ | eq_fm (NClosed c) (Dvd (a, b)) = false
+ | eq_fm (Closed c) (Dvd (a, b)) = false
+ | eq_fm (A c) (Dvd (a, b)) = false
+ | eq_fm (E c) (Dvd (a, b)) = false
+ | eq_fm (Iff (c, d)) (Dvd (a, b)) = false
+ | eq_fm (Imp (c, d)) (Dvd (a, b)) = false
+ | eq_fm (Or (c, d)) (Dvd (a, b)) = false
+ | eq_fm (And (c, d)) (Dvd (a, b)) = false
+ | eq_fm (Not c) (Dvd (a, b)) = false
+ | eq_fm (NDvd (c, d)) (Dvd (a, b)) = false
+ | eq_fm (NClosed b) (NEq a) = false
+ | eq_fm (Closed b) (NEq a) = false
+ | eq_fm (A b) (NEq a) = false
+ | eq_fm (E b) (NEq a) = false
+ | eq_fm (Iff (b, c)) (NEq a) = false
+ | eq_fm (Imp (b, c)) (NEq a) = false
+ | eq_fm (Or (b, c)) (NEq a) = false
+ | eq_fm (And (b, c)) (NEq a) = false
+ | eq_fm (Not b) (NEq a) = false
+ | eq_fm (NDvd (b, c)) (NEq a) = false
+ | eq_fm (Dvd (b, c)) (NEq a) = false
+ | eq_fm (NClosed b) (Eq a) = false
+ | eq_fm (Closed b) (Eq a) = false
+ | eq_fm (A b) (Eq a) = false
+ | eq_fm (E b) (Eq a) = false
+ | eq_fm (Iff (b, c)) (Eq a) = false
+ | eq_fm (Imp (b, c)) (Eq a) = false
+ | eq_fm (Or (b, c)) (Eq a) = false
+ | eq_fm (And (b, c)) (Eq a) = false
+ | eq_fm (Not b) (Eq a) = false
+ | eq_fm (NDvd (b, c)) (Eq a) = false
+ | eq_fm (Dvd (b, c)) (Eq a) = false
+ | eq_fm (NEq b) (Eq a) = false
+ | eq_fm (NClosed b) (Ge a) = false
+ | eq_fm (Closed b) (Ge a) = false
+ | eq_fm (A b) (Ge a) = false
+ | eq_fm (E b) (Ge a) = false
+ | eq_fm (Iff (b, c)) (Ge a) = false
+ | eq_fm (Imp (b, c)) (Ge a) = false
+ | eq_fm (Or (b, c)) (Ge a) = false
+ | eq_fm (And (b, c)) (Ge a) = false
+ | eq_fm (Not b) (Ge a) = false
+ | eq_fm (NDvd (b, c)) (Ge a) = false
+ | eq_fm (Dvd (b, c)) (Ge a) = false
+ | eq_fm (NEq b) (Ge a) = false
+ | eq_fm (Eq b) (Ge a) = false
+ | eq_fm (NClosed b) (Gt a) = false
+ | eq_fm (Closed b) (Gt a) = false
+ | eq_fm (A b) (Gt a) = false
+ | eq_fm (E b) (Gt a) = false
+ | eq_fm (Iff (b, c)) (Gt a) = false
+ | eq_fm (Imp (b, c)) (Gt a) = false
+ | eq_fm (Or (b, c)) (Gt a) = false
+ | eq_fm (And (b, c)) (Gt a) = false
+ | eq_fm (Not b) (Gt a) = false
+ | eq_fm (NDvd (b, c)) (Gt a) = false
+ | eq_fm (Dvd (b, c)) (Gt a) = false
+ | eq_fm (NEq b) (Gt a) = false
+ | eq_fm (Eq b) (Gt a) = false
+ | eq_fm (Ge b) (Gt a) = false
+ | eq_fm (NClosed b) (Le a) = false
+ | eq_fm (Closed b) (Le a) = false
+ | eq_fm (A b) (Le a) = false
+ | eq_fm (E b) (Le a) = false
+ | eq_fm (Iff (b, c)) (Le a) = false
+ | eq_fm (Imp (b, c)) (Le a) = false
+ | eq_fm (Or (b, c)) (Le a) = false
+ | eq_fm (And (b, c)) (Le a) = false
+ | eq_fm (Not b) (Le a) = false
+ | eq_fm (NDvd (b, c)) (Le a) = false
+ | eq_fm (Dvd (b, c)) (Le a) = false
+ | eq_fm (NEq b) (Le a) = false
+ | eq_fm (Eq b) (Le a) = false
+ | eq_fm (Ge b) (Le a) = false
+ | eq_fm (Gt b) (Le a) = false
+ | eq_fm (NClosed b) (Lt a) = false
+ | eq_fm (Closed b) (Lt a) = false
+ | eq_fm (A b) (Lt a) = false
+ | eq_fm (E b) (Lt a) = false
+ | eq_fm (Iff (b, c)) (Lt a) = false
+ | eq_fm (Imp (b, c)) (Lt a) = false
+ | eq_fm (Or (b, c)) (Lt a) = false
+ | eq_fm (And (b, c)) (Lt a) = false
+ | eq_fm (Not b) (Lt a) = false
+ | eq_fm (NDvd (b, c)) (Lt a) = false
+ | eq_fm (Dvd (b, c)) (Lt a) = false
+ | eq_fm (NEq b) (Lt a) = false
+ | eq_fm (Eq b) (Lt a) = false
+ | eq_fm (Ge b) (Lt a) = false
+ | eq_fm (Gt b) (Lt a) = false
+ | eq_fm (Le b) (Lt a) = false
+ | eq_fm (NClosed a) F = false
+ | eq_fm (Closed a) F = false
+ | eq_fm (A a) F = false
+ | eq_fm (E a) F = false
+ | eq_fm (Iff (a, b)) F = false
+ | eq_fm (Imp (a, b)) F = false
+ | eq_fm (Or (a, b)) F = false
+ | eq_fm (And (a, b)) F = false
+ | eq_fm (Not a) F = false
+ | eq_fm (NDvd (a, b)) F = false
+ | eq_fm (Dvd (a, b)) F = false
+ | eq_fm (NEq a) F = false
+ | eq_fm (Eq a) F = false
+ | eq_fm (Ge a) F = false
+ | eq_fm (Gt a) F = false
+ | eq_fm (Le a) F = false
+ | eq_fm (Lt a) F = false
+ | eq_fm (NClosed a) T = false
+ | eq_fm (Closed a) T = false
+ | eq_fm (A a) T = false
+ | eq_fm (E a) T = false
+ | eq_fm (Iff (a, b)) T = false
+ | eq_fm (Imp (a, b)) T = false
+ | eq_fm (Or (a, b)) T = false
+ | eq_fm (And (a, b)) T = false
+ | eq_fm (Not a) T = false
+ | eq_fm (NDvd (a, b)) T = false
+ | eq_fm (Dvd (a, b)) T = false
+ | eq_fm (NEq a) T = false
+ | eq_fm (Eq a) T = false
+ | eq_fm (Ge a) T = false
+ | eq_fm (Gt a) T = false
+ | eq_fm (Le a) T = false
+ | eq_fm (Lt a) T = false
| eq_fm F T = false
| eq_fm (Closed a) (NClosed b) = false
- | eq_fm (A ab) (NClosed b) = false
- | eq_fm (A ab) (Closed b) = false
- | eq_fm (E ab) (NClosed b) = false
- | eq_fm (E ab) (Closed b) = false
- | eq_fm (E ab) (A bb) = false
- | eq_fm (Iff (ab, bb)) (NClosed c) = false
- | eq_fm (Iff (ab, bb)) (Closed c) = false
- | eq_fm (Iff (ab, bb)) (A cb) = false
- | eq_fm (Iff (ab, bb)) (E cb) = false
- | eq_fm (Imp (ab, bb)) (NClosed c) = false
- | eq_fm (Imp (ab, bb)) (Closed c) = false
- | eq_fm (Imp (ab, bb)) (A cb) = false
- | eq_fm (Imp (ab, bb)) (E cb) = false
- | eq_fm (Imp (ab, bb)) (Iff (cb, d)) = false
- | eq_fm (Or (ab, bb)) (NClosed c) = false
- | eq_fm (Or (ab, bb)) (Closed c) = false
- | eq_fm (Or (ab, bb)) (A cb) = false
- | eq_fm (Or (ab, bb)) (E cb) = false
- | eq_fm (Or (ab, bb)) (Iff (cb, d)) = false
- | eq_fm (Or (ab, bb)) (Imp (cb, d)) = false
- | eq_fm (And (ab, bb)) (NClosed c) = false
- | eq_fm (And (ab, bb)) (Closed c) = false
- | eq_fm (And (ab, bb)) (A cb) = false
- | eq_fm (And (ab, bb)) (E cb) = false
- | eq_fm (And (ab, bb)) (Iff (cb, d)) = false
- | eq_fm (And (ab, bb)) (Imp (cb, d)) = false
- | eq_fm (And (ab, bb)) (Or (cb, d)) = false
- | eq_fm (Not ab) (NClosed b) = false
- | eq_fm (Not ab) (Closed b) = false
- | eq_fm (Not ab) (A bb) = false
- | eq_fm (Not ab) (E bb) = false
- | eq_fm (Not ab) (Iff (bb, cb)) = false
- | eq_fm (Not ab) (Imp (bb, cb)) = false
- | eq_fm (Not ab) (Or (bb, cb)) = false
- | eq_fm (Not ab) (And (bb, cb)) = false
- | eq_fm (NDvd (aa, bc)) (NClosed c) = false
- | eq_fm (NDvd (aa, bc)) (Closed c) = false
- | eq_fm (NDvd (aa, bc)) (A cb) = false
- | eq_fm (NDvd (aa, bc)) (E cb) = false
- | eq_fm (NDvd (aa, bc)) (Iff (cb, d)) = false
- | eq_fm (NDvd (aa, bc)) (Imp (cb, d)) = false
- | eq_fm (NDvd (aa, bc)) (Or (cb, d)) = false
- | eq_fm (NDvd (aa, bc)) (And (cb, d)) = false
- | eq_fm (NDvd (aa, bc)) (Not cb) = false
- | eq_fm (Dvd (aa, bc)) (NClosed c) = false
- | eq_fm (Dvd (aa, bc)) (Closed c) = false
- | eq_fm (Dvd (aa, bc)) (A cb) = false
- | eq_fm (Dvd (aa, bc)) (E cb) = false
- | eq_fm (Dvd (aa, bc)) (Iff (cb, d)) = false
- | eq_fm (Dvd (aa, bc)) (Imp (cb, d)) = false
- | eq_fm (Dvd (aa, bc)) (Or (cb, d)) = false
- | eq_fm (Dvd (aa, bc)) (And (cb, d)) = false
- | eq_fm (Dvd (aa, bc)) (Not cb) = false
- | eq_fm (Dvd (aa, bc)) (NDvd (ca, da)) = false
- | eq_fm (NEq ac) (NClosed b) = false
- | eq_fm (NEq ac) (Closed b) = false
- | eq_fm (NEq ac) (A bb) = false
- | eq_fm (NEq ac) (E bb) = false
- | eq_fm (NEq ac) (Iff (bb, cb)) = false
- | eq_fm (NEq ac) (Imp (bb, cb)) = false
- | eq_fm (NEq ac) (Or (bb, cb)) = false
- | eq_fm (NEq ac) (And (bb, cb)) = false
- | eq_fm (NEq ac) (Not bb) = false
- | eq_fm (NEq ac) (NDvd (ba, cc)) = false
- | eq_fm (NEq ac) (Dvd (ba, cc)) = false
- | eq_fm (Eq ac) (NClosed b) = false
- | eq_fm (Eq ac) (Closed b) = false
- | eq_fm (Eq ac) (A bb) = false
- | eq_fm (Eq ac) (E bb) = false
- | eq_fm (Eq ac) (Iff (bb, cb)) = false
- | eq_fm (Eq ac) (Imp (bb, cb)) = false
- | eq_fm (Eq ac) (Or (bb, cb)) = false
- | eq_fm (Eq ac) (And (bb, cb)) = false
- | eq_fm (Eq ac) (Not bb) = false
- | eq_fm (Eq ac) (NDvd (ba, cc)) = false
- | eq_fm (Eq ac) (Dvd (ba, cc)) = false
- | eq_fm (Eq ac) (NEq bc) = false
- | eq_fm (Ge ac) (NClosed b) = false
- | eq_fm (Ge ac) (Closed b) = false
- | eq_fm (Ge ac) (A bb) = false
- | eq_fm (Ge ac) (E bb) = false
- | eq_fm (Ge ac) (Iff (bb, cb)) = false
- | eq_fm (Ge ac) (Imp (bb, cb)) = false
- | eq_fm (Ge ac) (Or (bb, cb)) = false
- | eq_fm (Ge ac) (And (bb, cb)) = false
- | eq_fm (Ge ac) (Not bb) = false
- | eq_fm (Ge ac) (NDvd (ba, cc)) = false
- | eq_fm (Ge ac) (Dvd (ba, cc)) = false
- | eq_fm (Ge ac) (NEq bc) = false
- | eq_fm (Ge ac) (Eq bc) = false
- | eq_fm (Gt ac) (NClosed b) = false
- | eq_fm (Gt ac) (Closed b) = false
- | eq_fm (Gt ac) (A bb) = false
- | eq_fm (Gt ac) (E bb) = false
- | eq_fm (Gt ac) (Iff (bb, cb)) = false
- | eq_fm (Gt ac) (Imp (bb, cb)) = false
- | eq_fm (Gt ac) (Or (bb, cb)) = false
- | eq_fm (Gt ac) (And (bb, cb)) = false
- | eq_fm (Gt ac) (Not bb) = false
- | eq_fm (Gt ac) (NDvd (ba, cc)) = false
- | eq_fm (Gt ac) (Dvd (ba, cc)) = false
- | eq_fm (Gt ac) (NEq bc) = false
- | eq_fm (Gt ac) (Eq bc) = false
- | eq_fm (Gt ac) (Ge bc) = false
- | eq_fm (Le ac) (NClosed b) = false
- | eq_fm (Le ac) (Closed b) = false
- | eq_fm (Le ac) (A bb) = false
- | eq_fm (Le ac) (E bb) = false
- | eq_fm (Le ac) (Iff (bb, cb)) = false
- | eq_fm (Le ac) (Imp (bb, cb)) = false
- | eq_fm (Le ac) (Or (bb, cb)) = false
- | eq_fm (Le ac) (And (bb, cb)) = false
- | eq_fm (Le ac) (Not bb) = false
- | eq_fm (Le ac) (NDvd (ba, cc)) = false
- | eq_fm (Le ac) (Dvd (ba, cc)) = false
- | eq_fm (Le ac) (NEq bc) = false
- | eq_fm (Le ac) (Eq bc) = false
- | eq_fm (Le ac) (Ge bc) = false
- | eq_fm (Le ac) (Gt bc) = false
- | eq_fm (Lt ac) (NClosed b) = false
- | eq_fm (Lt ac) (Closed b) = false
- | eq_fm (Lt ac) (A bb) = false
- | eq_fm (Lt ac) (E bb) = false
- | eq_fm (Lt ac) (Iff (bb, cb)) = false
- | eq_fm (Lt ac) (Imp (bb, cb)) = false
- | eq_fm (Lt ac) (Or (bb, cb)) = false
- | eq_fm (Lt ac) (And (bb, cb)) = false
- | eq_fm (Lt ac) (Not bb) = false
- | eq_fm (Lt ac) (NDvd (ba, cc)) = false
- | eq_fm (Lt ac) (Dvd (ba, cc)) = false
- | eq_fm (Lt ac) (NEq bc) = false
- | eq_fm (Lt ac) (Eq bc) = false
- | eq_fm (Lt ac) (Ge bc) = false
- | eq_fm (Lt ac) (Gt bc) = false
- | eq_fm (Lt ac) (Le bc) = false
+ | eq_fm (A a) (NClosed b) = false
+ | eq_fm (A a) (Closed b) = false
+ | eq_fm (E a) (NClosed b) = false
+ | eq_fm (E a) (Closed b) = false
+ | eq_fm (E a) (A b) = false
+ | eq_fm (Iff (a, b)) (NClosed c) = false
+ | eq_fm (Iff (a, b)) (Closed c) = false
+ | eq_fm (Iff (a, b)) (A c) = false
+ | eq_fm (Iff (a, b)) (E c) = false
+ | eq_fm (Imp (a, b)) (NClosed c) = false
+ | eq_fm (Imp (a, b)) (Closed c) = false
+ | eq_fm (Imp (a, b)) (A c) = false
+ | eq_fm (Imp (a, b)) (E c) = false
+ | eq_fm (Imp (a, b)) (Iff (c, d)) = false
+ | eq_fm (Or (a, b)) (NClosed c) = false
+ | eq_fm (Or (a, b)) (Closed c) = false
+ | eq_fm (Or (a, b)) (A c) = false
+ | eq_fm (Or (a, b)) (E c) = false
+ | eq_fm (Or (a, b)) (Iff (c, d)) = false
+ | eq_fm (Or (a, b)) (Imp (c, d)) = false
+ | eq_fm (And (a, b)) (NClosed c) = false
+ | eq_fm (And (a, b)) (Closed c) = false
+ | eq_fm (And (a, b)) (A c) = false
+ | eq_fm (And (a, b)) (E c) = false
+ | eq_fm (And (a, b)) (Iff (c, d)) = false
+ | eq_fm (And (a, b)) (Imp (c, d)) = false
+ | eq_fm (And (a, b)) (Or (c, d)) = false
+ | eq_fm (Not a) (NClosed b) = false
+ | eq_fm (Not a) (Closed b) = false
+ | eq_fm (Not a) (A b) = false
+ | eq_fm (Not a) (E b) = false
+ | eq_fm (Not a) (Iff (b, c)) = false
+ | eq_fm (Not a) (Imp (b, c)) = false
+ | eq_fm (Not a) (Or (b, c)) = false
+ | eq_fm (Not a) (And (b, c)) = false
+ | eq_fm (NDvd (a, b)) (NClosed c) = false
+ | eq_fm (NDvd (a, b)) (Closed c) = false
+ | eq_fm (NDvd (a, b)) (A c) = false
+ | eq_fm (NDvd (a, b)) (E c) = false
+ | eq_fm (NDvd (a, b)) (Iff (c, d)) = false
+ | eq_fm (NDvd (a, b)) (Imp (c, d)) = false
+ | eq_fm (NDvd (a, b)) (Or (c, d)) = false
+ | eq_fm (NDvd (a, b)) (And (c, d)) = false
+ | eq_fm (NDvd (a, b)) (Not c) = false
+ | eq_fm (Dvd (a, b)) (NClosed c) = false
+ | eq_fm (Dvd (a, b)) (Closed c) = false
+ | eq_fm (Dvd (a, b)) (A c) = false
+ | eq_fm (Dvd (a, b)) (E c) = false
+ | eq_fm (Dvd (a, b)) (Iff (c, d)) = false
+ | eq_fm (Dvd (a, b)) (Imp (c, d)) = false
+ | eq_fm (Dvd (a, b)) (Or (c, d)) = false
+ | eq_fm (Dvd (a, b)) (And (c, d)) = false
+ | eq_fm (Dvd (a, b)) (Not c) = false
+ | eq_fm (Dvd (a, b)) (NDvd (c, d)) = false
+ | eq_fm (NEq a) (NClosed b) = false
+ | eq_fm (NEq a) (Closed b) = false
+ | eq_fm (NEq a) (A b) = false
+ | eq_fm (NEq a) (E b) = false
+ | eq_fm (NEq a) (Iff (b, c)) = false
+ | eq_fm (NEq a) (Imp (b, c)) = false
+ | eq_fm (NEq a) (Or (b, c)) = false
+ | eq_fm (NEq a) (And (b, c)) = false
+ | eq_fm (NEq a) (Not b) = false
+ | eq_fm (NEq a) (NDvd (b, c)) = false
+ | eq_fm (NEq a) (Dvd (b, c)) = false
+ | eq_fm (Eq a) (NClosed b) = false
+ | eq_fm (Eq a) (Closed b) = false
+ | eq_fm (Eq a) (A b) = false
+ | eq_fm (Eq a) (E b) = false
+ | eq_fm (Eq a) (Iff (b, c)) = false
+ | eq_fm (Eq a) (Imp (b, c)) = false
+ | eq_fm (Eq a) (Or (b, c)) = false
+ | eq_fm (Eq a) (And (b, c)) = false
+ | eq_fm (Eq a) (Not b) = false
+ | eq_fm (Eq a) (NDvd (b, c)) = false
+ | eq_fm (Eq a) (Dvd (b, c)) = false
+ | eq_fm (Eq a) (NEq b) = false
+ | eq_fm (Ge a) (NClosed b) = false
+ | eq_fm (Ge a) (Closed b) = false
+ | eq_fm (Ge a) (A b) = false
+ | eq_fm (Ge a) (E b) = false
+ | eq_fm (Ge a) (Iff (b, c)) = false
+ | eq_fm (Ge a) (Imp (b, c)) = false
+ | eq_fm (Ge a) (Or (b, c)) = false
+ | eq_fm (Ge a) (And (b, c)) = false
+ | eq_fm (Ge a) (Not b) = false
+ | eq_fm (Ge a) (NDvd (b, c)) = false
+ | eq_fm (Ge a) (Dvd (b, c)) = false
+ | eq_fm (Ge a) (NEq b) = false
+ | eq_fm (Ge a) (Eq b) = false
+ | eq_fm (Gt a) (NClosed b) = false
+ | eq_fm (Gt a) (Closed b) = false
+ | eq_fm (Gt a) (A b) = false
+ | eq_fm (Gt a) (E b) = false
+ | eq_fm (Gt a) (Iff (b, c)) = false
+ | eq_fm (Gt a) (Imp (b, c)) = false
+ | eq_fm (Gt a) (Or (b, c)) = false
+ | eq_fm (Gt a) (And (b, c)) = false
+ | eq_fm (Gt a) (Not b) = false
+ | eq_fm (Gt a) (NDvd (b, c)) = false
+ | eq_fm (Gt a) (Dvd (b, c)) = false
+ | eq_fm (Gt a) (NEq b) = false
+ | eq_fm (Gt a) (Eq b) = false
+ | eq_fm (Gt a) (Ge b) = false
+ | eq_fm (Le a) (NClosed b) = false
+ | eq_fm (Le a) (Closed b) = false
+ | eq_fm (Le a) (A b) = false
+ | eq_fm (Le a) (E b) = false
+ | eq_fm (Le a) (Iff (b, c)) = false
+ | eq_fm (Le a) (Imp (b, c)) = false
+ | eq_fm (Le a) (Or (b, c)) = false
+ | eq_fm (Le a) (And (b, c)) = false
+ | eq_fm (Le a) (Not b) = false
+ | eq_fm (Le a) (NDvd (b, c)) = false
+ | eq_fm (Le a) (Dvd (b, c)) = false
+ | eq_fm (Le a) (NEq b) = false
+ | eq_fm (Le a) (Eq b) = false
+ | eq_fm (Le a) (Ge b) = false
+ | eq_fm (Le a) (Gt b) = false
+ | eq_fm (Lt a) (NClosed b) = false
+ | eq_fm (Lt a) (Closed b) = false
+ | eq_fm (Lt a) (A b) = false
+ | eq_fm (Lt a) (E b) = false
+ | eq_fm (Lt a) (Iff (b, c)) = false
+ | eq_fm (Lt a) (Imp (b, c)) = false
+ | eq_fm (Lt a) (Or (b, c)) = false
+ | eq_fm (Lt a) (And (b, c)) = false
+ | eq_fm (Lt a) (Not b) = false
+ | eq_fm (Lt a) (NDvd (b, c)) = false
+ | eq_fm (Lt a) (Dvd (b, c)) = false
+ | eq_fm (Lt a) (NEq b) = false
+ | eq_fm (Lt a) (Eq b) = false
+ | eq_fm (Lt a) (Ge b) = false
+ | eq_fm (Lt a) (Gt b) = false
+ | eq_fm (Lt a) (Le b) = false
| eq_fm F (NClosed a) = false
| eq_fm F (Closed a) = false
- | eq_fm F (A ab) = false
- | eq_fm F (E ab) = false
- | eq_fm F (Iff (ab, bb)) = false
- | eq_fm F (Imp (ab, bb)) = false
- | eq_fm F (Or (ab, bb)) = false
- | eq_fm F (And (ab, bb)) = false
- | eq_fm F (Not ab) = false
- | eq_fm F (NDvd (aa, bc)) = false
- | eq_fm F (Dvd (aa, bc)) = false
- | eq_fm F (NEq ac) = false
- | eq_fm F (Eq ac) = false
- | eq_fm F (Ge ac) = false
- | eq_fm F (Gt ac) = false
- | eq_fm F (Le ac) = false
- | eq_fm F (Lt ac) = false
+ | eq_fm F (A a) = false
+ | eq_fm F (E a) = false
+ | eq_fm F (Iff (a, b)) = false
+ | eq_fm F (Imp (a, b)) = false
+ | eq_fm F (Or (a, b)) = false
+ | eq_fm F (And (a, b)) = false
+ | eq_fm F (Not a) = false
+ | eq_fm F (NDvd (a, b)) = false
+ | eq_fm F (Dvd (a, b)) = false
+ | eq_fm F (NEq a) = false
+ | eq_fm F (Eq a) = false
+ | eq_fm F (Ge a) = false
+ | eq_fm F (Gt a) = false
+ | eq_fm F (Le a) = false
+ | eq_fm F (Lt a) = false
| eq_fm T (NClosed a) = false
| eq_fm T (Closed a) = false
- | eq_fm T (A ab) = false
- | eq_fm T (E ab) = false
- | eq_fm T (Iff (ab, bb)) = false
- | eq_fm T (Imp (ab, bb)) = false
- | eq_fm T (Or (ab, bb)) = false
- | eq_fm T (And (ab, bb)) = false
- | eq_fm T (Not ab) = false
- | eq_fm T (NDvd (aa, bc)) = false
- | eq_fm T (Dvd (aa, bc)) = false
- | eq_fm T (NEq ac) = false
- | eq_fm T (Eq ac) = false
- | eq_fm T (Ge ac) = false
- | eq_fm T (Gt ac) = false
- | eq_fm T (Le ac) = false
- | eq_fm T (Lt ac) = false
+ | eq_fm T (A a) = false
+ | eq_fm T (E a) = false
+ | eq_fm T (Iff (a, b)) = false
+ | eq_fm T (Imp (a, b)) = false
+ | eq_fm T (Or (a, b)) = false
+ | eq_fm T (And (a, b)) = false
+ | eq_fm T (Not a) = false
+ | eq_fm T (NDvd (a, b)) = false
+ | eq_fm T (Dvd (a, b)) = false
+ | eq_fm T (NEq a) = false
+ | eq_fm T (Eq a) = false
+ | eq_fm T (Ge a) = false
+ | eq_fm T (Gt a) = false
+ | eq_fm T (Le a) = false
+ | eq_fm T (Lt a) = false
| eq_fm T F = false
| eq_fm (NClosed nat) (NClosed nat') = ((nat : IntInf.int) = nat')
| eq_fm (Closed nat) (Closed nat') = ((nat : IntInf.int) = nat')
@@ -554,7 +554,7 @@
| NClosed nat => Or (f p, q))
end));
-fun foldr f [] y = y
+fun foldr f [] a = a
| foldr f (x :: xs) a = f x (foldr f xs a);
fun evaldjf f ps = foldr (djf f) ps F;
@@ -607,9 +607,9 @@
| numsubst0 t (Add (a, b)) = Add (numsubst0 t a, numsubst0 t b)
| numsubst0 t (Sub (a, b)) = Sub (numsubst0 t a, numsubst0 t b)
| numsubst0 t (Mul (i, a)) = Mul (i, numsubst0 t a)
- | numsubst0 ta (Cn (v, ia, aa)) =
- (if eqop eq_nat v 0 then Add (Mul (ia, ta), numsubst0 ta aa)
- else Cn (suc (minus_nat v 1), ia, numsubst0 ta aa));
+ | numsubst0 t (Cn (v, i, a)) =
+ (if eqop eq_nat v 0 then Add (Mul (i, t), numsubst0 t a)
+ else Cn (suc (minus_nat v 1), i, numsubst0 t a));
fun subst0 t T = T
| subst0 t F = F
@@ -691,36 +691,35 @@
| minusinf (NEq (Cn (hm, c, e))) =
(if eqop eq_nat hm 0 then T else NEq (Cn (suc (minus_nat hm 1), c, e)));
-fun adjust b =
- (fn a as (q, r) =>
- (if IntInf.<= ((0 : IntInf.int), IntInf.- (r, b))
- then (IntInf.+ (IntInf.* ((2 : IntInf.int), q), (1 : IntInf.int)),
- IntInf.- (r, b))
- else (IntInf.* ((2 : IntInf.int), q), r)));
+val eq_int = {eq = (fn a => fn b => ((a : IntInf.int) = b))} : IntInf.int eq;
-fun negDivAlg a b =
- (if IntInf.<= ((0 : IntInf.int), IntInf.+ (a, b)) orelse
- IntInf.<= (b, (0 : IntInf.int))
- then ((~1 : IntInf.int), IntInf.+ (a, b))
- else adjust b (negDivAlg a (IntInf.* ((2 : IntInf.int), b))));
+fun sgn_int i =
+ (if eqop eq_int i (0 : IntInf.int) then (0 : IntInf.int)
+ else (if IntInf.< ((0 : IntInf.int), i) then (1 : IntInf.int)
+ else IntInf.~ (1 : IntInf.int)));
fun apsnd f (x, y) = (x, f y);
-val eq_int = {eq = (fn a => fn b => ((a : IntInf.int) = b))} : IntInf.int eq;
-
-fun posDivAlg a b =
- (if IntInf.< (a, b) orelse IntInf.<= (b, (0 : IntInf.int))
- then ((0 : IntInf.int), a)
- else adjust b (posDivAlg a (IntInf.* ((2 : IntInf.int), b))));
-
-fun divmoda a b =
- (if IntInf.<= ((0 : IntInf.int), a)
- then (if IntInf.<= ((0 : IntInf.int), b) then posDivAlg a b
- else (if eqop eq_int a (0 : IntInf.int)
- then ((0 : IntInf.int), (0 : IntInf.int))
- else apsnd IntInf.~ (negDivAlg (IntInf.~ a) (IntInf.~ b))))
- else (if IntInf.< ((0 : IntInf.int), b) then negDivAlg a b
- else apsnd IntInf.~ (posDivAlg (IntInf.~ a) (IntInf.~ b))));
+fun divmoda k l =
+ (if eqop eq_int k (0 : IntInf.int) then ((0 : IntInf.int), (0 : IntInf.int))
+ else (if eqop eq_int l (0 : IntInf.int) then ((0 : IntInf.int), k)
+ else apsnd (fn a => IntInf.* (sgn_int l, a))
+ (if eqop eq_int (sgn_int k) (sgn_int l)
+ then (fn k => fn l => IntInf.divMod (IntInf.abs k,
+ IntInf.abs l))
+ k l
+ else let
+ val a =
+ (fn k => fn l => IntInf.divMod (IntInf.abs k,
+ IntInf.abs l))
+ k l;
+ val (r, s) = a;
+ in
+ (if eqop eq_int s (0 : IntInf.int)
+ then (IntInf.~ r, (0 : IntInf.int))
+ else (IntInf.- (IntInf.~ r, (1 : IntInf.int)),
+ IntInf.- (abs_int l, s)))
+ end)));
fun mod_int a b = snd (divmoda a b);
@@ -823,23 +822,23 @@
else nummul i (simpnum t))
| simpnum (Cn (v, va, vb)) = Cn (v, va, vb);
-fun nota (Not y) = y
+fun nota (Not p) = p
| nota T = F
| nota F = T
- | nota (Lt vc) = Not (Lt vc)
- | nota (Le vc) = Not (Le vc)
- | nota (Gt vc) = Not (Gt vc)
- | nota (Ge vc) = Not (Ge vc)
- | nota (Eq vc) = Not (Eq vc)
- | nota (NEq vc) = Not (NEq vc)
- | nota (Dvd (va, vab)) = Not (Dvd (va, vab))
- | nota (NDvd (va, vab)) = Not (NDvd (va, vab))
- | nota (And (vb, vaa)) = Not (And (vb, vaa))
- | nota (Or (vb, vaa)) = Not (Or (vb, vaa))
- | nota (Imp (vb, vaa)) = Not (Imp (vb, vaa))
- | nota (Iff (vb, vaa)) = Not (Iff (vb, vaa))
- | nota (E vb) = Not (E vb)
- | nota (A vb) = Not (A vb)
+ | nota (Lt v) = Not (Lt v)
+ | nota (Le v) = Not (Le v)
+ | nota (Gt v) = Not (Gt v)
+ | nota (Ge v) = Not (Ge v)
+ | nota (Eq v) = Not (Eq v)
+ | nota (NEq v) = Not (NEq v)
+ | nota (Dvd (v, va)) = Not (Dvd (v, va))
+ | nota (NDvd (v, va)) = Not (NDvd (v, va))
+ | nota (And (v, va)) = Not (And (v, va))
+ | nota (Or (v, va)) = Not (Or (v, va))
+ | nota (Imp (v, va)) = Not (Imp (v, va))
+ | nota (Iff (v, va)) = Not (Iff (v, va))
+ | nota (E v) = Not (E v)
+ | nota (A v) = Not (A v)
| nota (Closed v) = Not (Closed v)
| nota (NClosed v) = Not (NClosed v);
@@ -1184,7 +1183,7 @@
| delta (Le v) = (1 : IntInf.int)
| delta (Gt w) = (1 : IntInf.int)
| delta (Ge x) = (1 : IntInf.int)
- | delta (Eq ya) = (1 : IntInf.int)
+ | delta (Eq y) = (1 : IntInf.int)
| delta (NEq z) = (1 : IntInf.int)
| delta (Dvd (aa, C bo)) = (1 : IntInf.int)
| delta (Dvd (aa, Bound bp)) = (1 : IntInf.int)
@@ -1205,10 +1204,10 @@
| delta (A ao) = (1 : IntInf.int)
| delta (Closed ap) = (1 : IntInf.int)
| delta (NClosed aq) = (1 : IntInf.int)
- | delta (Dvd (b, Cn (cm, c, e))) =
- (if eqop eq_nat cm 0 then b else (1 : IntInf.int))
- | delta (NDvd (b, Cn (dm, c, e))) =
- (if eqop eq_nat dm 0 then b else (1 : IntInf.int));
+ | delta (Dvd (i, Cn (cm, c, e))) =
+ (if eqop eq_nat cm 0 then i else (1 : IntInf.int))
+ | delta (NDvd (i, Cn (dm, c, e))) =
+ (if eqop eq_nat dm 0 then i else (1 : IntInf.int));
fun div_int a b = fst (divmoda a b);
@@ -1367,22 +1366,22 @@
| zeta (A ao) = (1 : IntInf.int)
| zeta (Closed ap) = (1 : IntInf.int)
| zeta (NClosed aq) = (1 : IntInf.int)
- | zeta (Lt (Cn (cm, b, e))) =
- (if eqop eq_nat cm 0 then b else (1 : IntInf.int))
- | zeta (Le (Cn (dm, b, e))) =
- (if eqop eq_nat dm 0 then b else (1 : IntInf.int))
- | zeta (Gt (Cn (em, b, e))) =
- (if eqop eq_nat em 0 then b else (1 : IntInf.int))
- | zeta (Ge (Cn (fm, b, e))) =
- (if eqop eq_nat fm 0 then b else (1 : IntInf.int))
- | zeta (Eq (Cn (gm, b, e))) =
- (if eqop eq_nat gm 0 then b else (1 : IntInf.int))
- | zeta (NEq (Cn (hm, b, e))) =
- (if eqop eq_nat hm 0 then b else (1 : IntInf.int))
- | zeta (Dvd (i, Cn (im, b, e))) =
- (if eqop eq_nat im 0 then b else (1 : IntInf.int))
- | zeta (NDvd (i, Cn (jm, b, e))) =
- (if eqop eq_nat jm 0 then b else (1 : IntInf.int));
+ | zeta (Lt (Cn (cm, c, e))) =
+ (if eqop eq_nat cm 0 then c else (1 : IntInf.int))
+ | zeta (Le (Cn (dm, c, e))) =
+ (if eqop eq_nat dm 0 then c else (1 : IntInf.int))
+ | zeta (Gt (Cn (em, c, e))) =
+ (if eqop eq_nat em 0 then c else (1 : IntInf.int))
+ | zeta (Ge (Cn (fm, c, e))) =
+ (if eqop eq_nat fm 0 then c else (1 : IntInf.int))
+ | zeta (Eq (Cn (gm, c, e))) =
+ (if eqop eq_nat gm 0 then c else (1 : IntInf.int))
+ | zeta (NEq (Cn (hm, c, e))) =
+ (if eqop eq_nat hm 0 then c else (1 : IntInf.int))
+ | zeta (Dvd (i, Cn (im, c, e))) =
+ (if eqop eq_nat im 0 then c else (1 : IntInf.int))
+ | zeta (NDvd (i, Cn (jm, c, e))) =
+ (if eqop eq_nat jm 0 then c else (1 : IntInf.int));
fun zsplit0 (C c) = ((0 : IntInf.int), C c)
| zsplit0 (Bound n) =
@@ -1691,4 +1690,16 @@
(if IntInf.<= (i, (0 : IntInf.int)) then n
else nat_aux (IntInf.- (i, (1 : IntInf.int))) (suc n));
+fun adjust b =
+ (fn a as (q, r) =>
+ (if IntInf.<= ((0 : IntInf.int), IntInf.- (r, b))
+ then (IntInf.+ (IntInf.* ((2 : IntInf.int), q), (1 : IntInf.int)),
+ IntInf.- (r, b))
+ else (IntInf.* ((2 : IntInf.int), q), r)));
+
+fun posDivAlg a b =
+ (if IntInf.< (a, b) orelse IntInf.<= (b, (0 : IntInf.int))
+ then ((0 : IntInf.int), a)
+ else adjust b (posDivAlg a (IntInf.* ((2 : IntInf.int), b))));
+
end; (*struct GeneratedCooper*)
--- a/src/HOL/Tools/Qelim/presburger.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Tools/Qelim/presburger.ML Thu Feb 26 11:21:29 2009 +0000
@@ -122,14 +122,13 @@
addcongs [@{thm "conj_le_cong"}, @{thm "imp_le_cong"}]
val div_mod_ss = HOL_basic_ss addsimps simp_thms
@ map (symmetric o mk_meta_eq)
- [@{thm "dvd_eq_mod_eq_0"}, @{thm "zdvd_iff_zmod_eq_0"}, @{thm "mod_add1_eq"},
+ [@{thm "dvd_eq_mod_eq_0"}, @{thm "mod_add1_eq"},
@{thm "mod_add_left_eq"}, @{thm "mod_add_right_eq"},
- @{thm "zmod_zadd1_eq"}, @{thm "zmod_zadd_left_eq"},
- @{thm "zmod_zadd_right_eq"}, @{thm "div_add1_eq"}, @{thm "zdiv_zadd1_eq"}]
+ @{thm "mod_add_eq"}, @{thm "div_add1_eq"}, @{thm "zdiv_zadd1_eq"}]
@ [@{thm "mod_self"}, @{thm "zmod_self"}, @{thm "mod_by_0"},
@{thm "div_by_0"}, @{thm "DIVISION_BY_ZERO"} RS conjunct1,
@{thm "DIVISION_BY_ZERO"} RS conjunct2, @{thm "zdiv_zero"}, @{thm "zmod_zero"},
- @{thm "div_0"}, @{thm "mod_0"}, @{thm "zdiv_1"}, @{thm "zmod_1"}, @{thm "div_1"},
+ @{thm "div_0"}, @{thm "mod_0"}, @{thm "div_by_1"}, @{thm "mod_by_1"}, @{thm "div_1"},
@{thm "mod_1"}, @{thm "Suc_plus1"}]
@ @{thms add_ac}
addsimprocs [cancel_div_mod_proc]
@@ -170,14 +169,14 @@
THEN_ALL_NEW simp_tac ss
THEN_ALL_NEW (TRY o generalize_tac (int_nat_terms ctxt))
THEN_ALL_NEW ObjectLogic.full_atomize_tac
- THEN_ALL_NEW (TRY o thin_prems_tac (is_relevant ctxt))
+ THEN_ALL_NEW (thin_prems_tac (is_relevant ctxt))
THEN_ALL_NEW ObjectLogic.full_atomize_tac
THEN_ALL_NEW div_mod_tac ctxt
THEN_ALL_NEW splits_tac ctxt
THEN_ALL_NEW simp_tac ss
THEN_ALL_NEW CONVERSION Thm.eta_long_conversion
THEN_ALL_NEW nat_to_int_tac ctxt
- THEN_ALL_NEW core_cooper_tac ctxt
+ THEN_ALL_NEW (core_cooper_tac ctxt)
THEN_ALL_NEW finish_tac elim
end;
--- a/src/HOL/Tools/atp_wrapper.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Tools/atp_wrapper.ML Thu Feb 26 11:21:29 2009 +0000
@@ -78,10 +78,14 @@
val failure = find_failure proof
val success = rc = 0 andalso is_none failure
val message =
- if isSome failure then "Could not prove: " ^ the failure
- else if rc <> 0
- then "Exited with return code " ^ string_of_int rc ^ ": " ^ proof
- else "Try this command: " ^ produce_answer (proof, thm_names, ctxt, goal, subgoalno)
+ if success then "Try this command: " ^ produce_answer (proof, thm_names, ctxt, goal, subgoalno)
+ else "Could not prove goal."
+ val _ = if isSome failure
+ then Output.debug (fn () => "Sledgehammer failure: " ^ the failure ^ "\nOutput: " ^ proof)
+ else ()
+ val _ = if rc <> 0
+ then Output.debug (fn () => "Sledgehammer exited with return code " ^ string_of_int rc ^ ":\n" ^ proof)
+ else ()
in (success, message) end;
--- a/src/HOL/Tools/datatype_codegen.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Tools/datatype_codegen.ML Thu Feb 26 11:21:29 2009 +0000
@@ -6,8 +6,8 @@
signature DATATYPE_CODEGEN =
sig
- val get_eq: theory -> string -> thm list
- val get_case_cert: theory -> string -> thm
+ val mk_eq: theory -> string -> thm list
+ val mk_case_cert: theory -> string -> thm
val setup: theory -> theory
end;
@@ -323,7 +323,7 @@
(* case certificates *)
-fun get_case_cert thy tyco =
+fun mk_case_cert thy tyco =
let
val raw_thms =
(#case_rewrites o DatatypePackage.the_datatype thy) tyco;
@@ -357,10 +357,13 @@
fun add_datatype_cases dtco thy =
let
val {case_rewrites, ...} = DatatypePackage.the_datatype thy dtco;
- val certs = get_case_cert thy dtco;
+ val cert = mk_case_cert thy dtco;
+ fun add_case_liberal thy = thy
+ |> try (Code.add_case cert)
+ |> the_default thy;
in
thy
- |> Code.add_case certs
+ |> add_case_liberal
|> fold_rev Code.add_default_eqn case_rewrites
end;
@@ -369,10 +372,10 @@
local
-val not_sym = thm "HOL.not_sym";
-val not_false_true = iffD2 OF [nth (thms "HOL.simp_thms") 7, TrueI];
-val refl = thm "refl";
-val eqTrueI = thm "eqTrueI";
+val not_sym = @{thm HOL.not_sym};
+val not_false_true = iffD2 OF [nth @{thms HOL.simp_thms} 7, TrueI];
+val refl = @{thm refl};
+val eqTrueI = @{thm eqTrueI};
fun mk_distinct cos =
let
@@ -397,7 +400,7 @@
in
-fun get_eq thy dtco =
+fun mk_eq thy dtco =
let
val (vs, cs) = DatatypePackage.the_datatype_spec thy dtco;
fun mk_triv_inject co =
@@ -445,7 +448,7 @@
in (thm', lthy') end;
fun tac thms = Class.intro_classes_tac []
THEN ALLGOALS (ProofContext.fact_tac thms);
- fun get_eq' thy dtco = get_eq thy dtco
+ fun mk_eq' thy dtco = mk_eq thy dtco
|> map (Code_Unit.constrain_thm thy [HOLogic.class_eq])
|> map Simpdata.mk_eq
|> map (MetaSimplifier.rewrite_rule [Thm.transfer thy @{thm equals_eq}])
@@ -460,10 +463,10 @@
([pairself (Thm.ctyp_of thy) (TVar (("'a", 0), @{sort eq}), Logic.varifyT ty)], [])
|> Simpdata.mk_eq
|> AxClass.unoverload thy;
- fun get_thms () = (eq_refl, false)
- :: rev (map (rpair true) (get_eq' (Theory.deref thy_ref) dtco));
+ fun mk_thms () = (eq_refl, false)
+ :: rev (map (rpair true) (mk_eq' (Theory.deref thy_ref) dtco));
in
- Code.add_eqnl (const, Lazy.lazy get_thms) thy
+ Code.add_eqnl (const, Lazy.lazy mk_thms) thy
end;
in
thy
--- a/src/HOL/Tools/datatype_package.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Tools/datatype_package.ML Thu Feb 26 11:21:29 2009 +0000
@@ -659,7 +659,7 @@
| pretty_constr (co, [ty']) =
(Pretty.block o Pretty.breaks)
[Syntax.pretty_term ctxt (Const (co, ty' --> ty)),
- Syntax.pretty_typ ctxt ty']
+ pretty_typ_br ty']
| pretty_constr (co, tys) =
(Pretty.block o Pretty.breaks)
(Syntax.pretty_term ctxt (Const (co, tys ---> ty)) ::
--- a/src/HOL/Tools/inductive_package.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Tools/inductive_package.ML Thu Feb 26 11:21:29 2009 +0000
@@ -738,7 +738,7 @@
val _ = message (quiet_mode andalso not verbose)
("Proofs for " ^ coind_prefix coind ^ "inductive predicate(s) " ^ commas_quote names);
- val cnames = map (Sign.full_name (ProofContext.theory_of ctxt) o #1) cnames_syn; (* FIXME *)
+ val cnames = map (LocalTheory.full_name ctxt o #1) cnames_syn; (* FIXME *)
val ((intr_names, intr_atts), intr_ts) =
apfst split_list (split_list (map (check_rule ctxt cs params) intros));
--- a/src/HOL/Tools/inductive_set_package.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Tools/inductive_set_package.ML Thu Feb 26 11:21:29 2009 +0000
@@ -503,7 +503,7 @@
if Binding.is_empty alt_name then
Binding.name (space_implode "_" (map (Binding.base_name o fst) cnames_syn))
else alt_name;
- val cnames = map (Sign.full_name (ProofContext.theory_of ctxt3) o #1) cnames_syn; (* FIXME *)
+ val cnames = map (LocalTheory.full_name ctxt3 o #1) cnames_syn; (* FIXME *)
val (intr_names, intr_atts) = split_list (map fst intros);
val raw_induct' = to_set [] (Context.Proof ctxt3) raw_induct;
val (intrs', elims', induct, ctxt4) =
--- a/src/HOL/Tools/int_factor_simprocs.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Tools/int_factor_simprocs.ML Thu Feb 26 11:21:29 2009 +0000
@@ -216,7 +216,7 @@
(** Final simplification for the CancelFactor simprocs **)
val simplify_one = Int_Numeral_Simprocs.simplify_meta_eq
- [@{thm mult_1_left}, @{thm mult_1_right}, @{thm zdiv_1}, @{thm numeral_1_eq_1}];
+ [@{thm mult_1_left}, @{thm mult_1_right}, @{thm div_by_1}, @{thm numeral_1_eq_1}];
fun cancel_simplify_meta_eq cancel_th ss th =
simplify_one ss (([th, cancel_th]) MRS trans);
@@ -263,8 +263,8 @@
(open CancelFactorCommon
val prove_conv = Int_Numeral_Base_Simprocs.prove_conv
val mk_bal = HOLogic.mk_binrel @{const_name Ring_and_Field.dvd}
- val dest_bal = HOLogic.dest_bin @{const_name Ring_and_Field.dvd} HOLogic.intT
- val simplify_meta_eq = cancel_simplify_meta_eq @{thm zdvd_zmult_cancel_disj}
+ val dest_bal = HOLogic.dest_bin @{const_name Ring_and_Field.dvd} Term.dummyT
+ val simplify_meta_eq = cancel_simplify_meta_eq @{thm dvd_mult_cancel_left}
);
(*Version for all fields, including unordered ones (type complex).*)
@@ -288,8 +288,8 @@
("int_mod_cancel_factor",
["((l::int) * m) mod n", "(l::int) mod (m * n)"],
K IntModCancelFactor.proc),
- ("int_dvd_cancel_factor",
- ["((l::int) * m) dvd n", "(l::int) dvd (m * n)"],
+ ("dvd_cancel_factor",
+ ["((l::'a::idom) * m) dvd n", "(l::'a::idom) dvd (m * n)"],
K IntDvdCancelFactor.proc),
("divide_cancel_factor",
["((l::'a::{division_by_zero,field}) * m) / n",
--- a/src/HOL/Tools/refute.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Tools/refute.ML Thu Feb 26 11:21:29 2009 +0000
@@ -2662,6 +2662,34 @@
(* theory -> model -> arguments -> Term.term ->
(interpretation * model * arguments) option *)
+ fun set_interpreter thy model args t =
+ let
+ val (typs, terms) = model
+ in
+ case AList.lookup (op =) terms t of
+ SOME intr =>
+ (* return an existing interpretation *)
+ SOME (intr, model, args)
+ | NONE =>
+ (case t of
+ (* 'Collect' == identity *)
+ Const (@{const_name Collect}, _) $ t1 =>
+ SOME (interpret thy model args t1)
+ | Const (@{const_name Collect}, _) =>
+ SOME (interpret thy model args (eta_expand t 1))
+ (* 'op :' == application *)
+ | Const (@{const_name "op :"}, _) $ t1 $ t2 =>
+ SOME (interpret thy model args (t2 $ t1))
+ | Const (@{const_name "op :"}, _) $ t1 =>
+ SOME (interpret thy model args (eta_expand t 1))
+ | Const (@{const_name "op :"}, _) =>
+ SOME (interpret thy model args (eta_expand t 2))
+ | _ => NONE)
+ end;
+
+ (* theory -> model -> arguments -> Term.term ->
+ (interpretation * model * arguments) option *)
+
(* only an optimization: 'card' could in principle be interpreted with *)
(* interpreters available already (using its definition), but the code *)
(* below is more efficient *)
@@ -3271,6 +3299,7 @@
add_interpreter "stlc" stlc_interpreter #>
add_interpreter "Pure" Pure_interpreter #>
add_interpreter "HOLogic" HOLogic_interpreter #>
+ add_interpreter "set" set_interpreter #>
add_interpreter "IDT" IDT_interpreter #>
add_interpreter "IDT_constructor" IDT_constructor_interpreter #>
add_interpreter "IDT_recursion" IDT_recursion_interpreter #>
--- a/src/HOL/Transcendental.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Transcendental.thy Thu Feb 26 11:21:29 2009 +0000
@@ -120,7 +120,7 @@
case (Suc n)
have "(\<Sum> i = 0 ..< 2 * Suc n. if even i then f i else g i) =
(\<Sum> i = 0 ..< n. f (2 * i)) + (\<Sum> i = 0 ..< n. g (2 * i + 1)) + (f (2 * n) + g (2 * n + 1))"
- using Suc.hyps by auto
+ using Suc.hyps unfolding One_nat_def by auto
also have "\<dots> = (\<Sum> i = 0 ..< Suc n. f (2 * i)) + (\<Sum> i = 0 ..< Suc n. g (2 * i + 1))" by auto
finally show ?case .
qed auto
@@ -187,16 +187,18 @@
((\<forall>n. l \<le> (\<Sum>i=0..<2*n + 1. -1^i*a i)) \<and> (\<lambda> n. \<Sum>i=0..<2*n + 1. -1^i*a i) ----> l)"
(is "\<exists>l. ((\<forall>n. ?f n \<le> l) \<and> _) \<and> ((\<forall>n. l \<le> ?g n) \<and> _)")
proof -
- have fg_diff: "\<And>n. ?f n - ?g n = - a (2 * n)" by auto
+ have fg_diff: "\<And>n. ?f n - ?g n = - a (2 * n)" unfolding One_nat_def by auto
have "\<forall> n. ?f n \<le> ?f (Suc n)"
proof fix n show "?f n \<le> ?f (Suc n)" using mono[of "2*n"] by auto qed
moreover
have "\<forall> n. ?g (Suc n) \<le> ?g n"
- proof fix n show "?g (Suc n) \<le> ?g n" using mono[of "Suc (2*n)"] by auto qed
+ proof fix n show "?g (Suc n) \<le> ?g n" using mono[of "Suc (2*n)"]
+ unfolding One_nat_def by auto qed
moreover
have "\<forall> n. ?f n \<le> ?g n"
- proof fix n show "?f n \<le> ?g n" using fg_diff a_pos by auto qed
+ proof fix n show "?f n \<le> ?g n" using fg_diff a_pos
+ unfolding One_nat_def by auto qed
moreover
have "(\<lambda> n. ?f n - ?g n) ----> 0" unfolding fg_diff
proof (rule LIMSEQ_I)
@@ -904,7 +906,7 @@
proof -
have "(\<Sum>n = 0..<1. f n * 0 ^ n) = (\<Sum>n. f n * 0 ^ n)"
by (rule sums_unique [OF series_zero], simp add: power_0_left)
- thus ?thesis by simp
+ thus ?thesis unfolding One_nat_def by simp
qed
lemma exp_zero [simp]: "exp 0 = 1"
@@ -1234,10 +1236,11 @@
show "x - 1 \<in> {- 1<..<1}" and "(0 :: real) < 1" using `0 < x` `x < 2` by auto
{ fix x :: real assume "x \<in> {- 1<..<1}" hence "norm (-x) < 1" by auto
show "summable (\<lambda>n. -1 ^ n * (1 / real (n + 1)) * real (Suc n) * x ^ n)"
+ unfolding One_nat_def
by (auto simp del: power_mult_distrib simp add: power_mult_distrib[symmetric] summable_geometric[OF `norm (-x) < 1`])
}
qed
- hence "DERIV (\<lambda>x. suminf (?f x)) (x - 1) :> suminf (?f' x)" by auto
+ hence "DERIV (\<lambda>x. suminf (?f x)) (x - 1) :> suminf (?f' x)" unfolding One_nat_def by auto
hence "DERIV (\<lambda>x. suminf (?f (x - 1))) x :> suminf (?f' x)" unfolding DERIV_iff repos .
ultimately have "DERIV (\<lambda>x. ln x - suminf (?f (x - 1))) x :> (suminf (?f' x) - suminf (?f' x))"
by (rule DERIV_diff)
@@ -1514,6 +1517,7 @@
lemma DERIV_fun_pow: "DERIV g x :> m ==>
DERIV (%x. (g x) ^ n) x :> real n * (g x) ^ (n - 1) * m"
+unfolding One_nat_def
apply (rule lemma_DERIV_subst)
apply (rule_tac f = "(%x. x ^ n)" in DERIV_chain2)
apply (rule DERIV_pow, auto)
@@ -1635,7 +1639,7 @@
sums sin x"
unfolding sin_def
by (rule sin_converges [THEN sums_summable, THEN sums_group], simp)
- thus ?thesis by (simp add: mult_ac)
+ thus ?thesis unfolding One_nat_def by (simp add: mult_ac)
qed
lemma sin_gt_zero: "[|0 < x; x < 2 |] ==> 0 < sin x"
@@ -1647,6 +1651,7 @@
apply (rule sin_paired [THEN sums_summable, THEN sums_group], simp)
apply (rotate_tac 2)
apply (drule sin_paired [THEN sums_unique, THEN ssubst])
+unfolding One_nat_def
apply (auto simp del: fact_Suc realpow_Suc)
apply (frule sums_unique)
apply (auto simp del: fact_Suc realpow_Suc)
@@ -1720,6 +1725,7 @@
apply (simp (no_asm) add: mult_assoc del: setsum_op_ivl_Suc)
apply (rule sumr_pos_lt_pair)
apply (erule sums_summable, safe)
+unfolding One_nat_def
apply (simp (no_asm) add: divide_inverse real_0_less_add_iff mult_assoc [symmetric]
del: fact_Suc)
apply (rule real_mult_inverse_cancel2)
@@ -2792,7 +2798,7 @@
lemma monoseq_arctan_series: fixes x :: real
assumes "\<bar>x\<bar> \<le> 1" shows "monoseq (\<lambda> n. 1 / real (n*2+1) * x^(n*2+1))" (is "monoseq ?a")
-proof (cases "x = 0") case True thus ?thesis unfolding monoseq_def by auto
+proof (cases "x = 0") case True thus ?thesis unfolding monoseq_def One_nat_def by auto
next
case False
have "norm x \<le> 1" and "x \<le> 1" and "-1 \<le> x" using assms by auto
@@ -2823,7 +2829,7 @@
lemma zeroseq_arctan_series: fixes x :: real
assumes "\<bar>x\<bar> \<le> 1" shows "(\<lambda> n. 1 / real (n*2+1) * x^(n*2+1)) ----> 0" (is "?a ----> 0")
-proof (cases "x = 0") case True thus ?thesis by (auto simp add: LIMSEQ_const)
+proof (cases "x = 0") case True thus ?thesis unfolding One_nat_def by (auto simp add: LIMSEQ_const)
next
case False
have "norm x \<le> 1" and "x \<le> 1" and "-1 \<le> x" using assms by auto
@@ -2831,12 +2837,14 @@
proof (cases "\<bar>x\<bar> < 1")
case True hence "norm x < 1" by auto
from LIMSEQ_mult[OF LIMSEQ_inverse_real_of_nat LIMSEQ_power_zero[OF `norm x < 1`, THEN LIMSEQ_Suc]]
- show ?thesis unfolding inverse_eq_divide Suc_plus1 using LIMSEQ_linear[OF _ pos2] by auto
+ have "(\<lambda>n. 1 / real (n + 1) * x ^ (n + 1)) ----> 0"
+ unfolding inverse_eq_divide Suc_plus1 by simp
+ then show ?thesis using pos2 by (rule LIMSEQ_linear)
next
case False hence "x = -1 \<or> x = 1" using `\<bar>x\<bar> \<le> 1` by auto
- hence n_eq: "\<And> n. x ^ (n * 2 + 1) = x" by auto
+ hence n_eq: "\<And> n. x ^ (n * 2 + 1) = x" unfolding One_nat_def by auto
from LIMSEQ_mult[OF LIMSEQ_inverse_real_of_nat[THEN LIMSEQ_linear, OF pos2, unfolded inverse_eq_divide] LIMSEQ_const[of x]]
- show ?thesis unfolding n_eq by auto
+ show ?thesis unfolding n_eq Suc_plus1 by auto
qed
qed
@@ -2989,7 +2997,7 @@
from `even n` obtain m where "2 * m = n" unfolding even_mult_two_ex by auto
from bounds[of m, unfolded this atLeastAtMost_iff]
have "\<bar>arctan x - (\<Sum>i = 0..<n. (?c x i))\<bar> \<le> (\<Sum>i = 0..<n + 1. (?c x i)) - (\<Sum>i = 0..<n. (?c x i))" by auto
- also have "\<dots> = ?c x n" by auto
+ also have "\<dots> = ?c x n" unfolding One_nat_def by auto
also have "\<dots> = ?a x n" unfolding sgn_pos a_pos by auto
finally show ?thesis .
next
@@ -2998,7 +3006,7 @@
hence m_plus: "2 * (m + 1) = n + 1" by auto
from bounds[of "m + 1", unfolded this atLeastAtMost_iff, THEN conjunct1] bounds[of m, unfolded m_def atLeastAtMost_iff, THEN conjunct2]
have "\<bar>arctan x - (\<Sum>i = 0..<n. (?c x i))\<bar> \<le> (\<Sum>i = 0..<n. (?c x i)) - (\<Sum>i = 0..<n+1. (?c x i))" by auto
- also have "\<dots> = - ?c x n" by auto
+ also have "\<dots> = - ?c x n" unfolding One_nat_def by auto
also have "\<dots> = ?a x n" unfolding sgn_neg a_pos by auto
finally show ?thesis .
qed
@@ -3011,7 +3019,9 @@
ultimately have "0 \<le> ?a 1 n - ?diff 1 n" by (rule LIM_less_bound)
hence "?diff 1 n \<le> ?a 1 n" by auto
}
- have "?a 1 ----> 0" unfolding LIMSEQ_rabs_zero power_one divide_inverse by (auto intro!: LIMSEQ_mult LIMSEQ_linear LIMSEQ_inverse_real_of_nat)
+ have "?a 1 ----> 0"
+ unfolding LIMSEQ_rabs_zero power_one divide_inverse One_nat_def
+ by (auto intro!: LIMSEQ_mult LIMSEQ_linear LIMSEQ_inverse_real_of_nat)
have "?diff 1 ----> 0"
proof (rule LIMSEQ_I)
fix r :: real assume "0 < r"
@@ -3031,7 +3041,7 @@
have "- (pi / 2) < 0" using pi_gt_zero by auto
have "- (2 * pi) < 0" using pi_gt_zero by auto
- have c_minus_minus: "\<And> i. ?c (- 1) i = - ?c 1 i" by auto
+ have c_minus_minus: "\<And> i. ?c (- 1) i = - ?c 1 i" unfolding One_nat_def by auto
have "arctan (- 1) = arctan (tan (-(pi / 4)))" unfolding tan_45 tan_minus ..
also have "\<dots> = - (pi / 4)" by (rule arctan_tan, auto simp add: order_less_trans[OF `- (pi / 2) < 0` pi_gt_zero])
@@ -3179,4 +3189,4 @@
apply (erule polar_ex2)
done
-end
+end
--- a/src/HOL/Word/BinGeneral.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Word/BinGeneral.thy Thu Feb 26 11:21:29 2009 +0000
@@ -433,7 +433,7 @@
"!!w. sbintrunc n w = ((w + 2 ^ n) mod 2 ^ (Suc n) - 2 ^ n :: int)"
apply (induct n)
apply clarsimp
- apply (subst zmod_zadd_left_eq)
+ apply (subst mod_add_left_eq)
apply (simp add: bin_last_mod)
apply (simp add: number_of_eq)
apply clarsimp
@@ -767,23 +767,23 @@
lemmas zpower_zmod' = zpower_zmod [where m="c" and y="k", standard]
lemmas brdmod1s' [symmetric] =
- zmod_zadd_left_eq zmod_zadd_right_eq
+ mod_add_left_eq mod_add_right_eq
zmod_zsub_left_eq zmod_zsub_right_eq
zmod_zmult1_eq zmod_zmult1_eq_rev
lemmas brdmods' [symmetric] =
zpower_zmod' [symmetric]
- trans [OF zmod_zadd_left_eq zmod_zadd_right_eq]
+ trans [OF mod_add_left_eq mod_add_right_eq]
trans [OF zmod_zsub_left_eq zmod_zsub_right_eq]
trans [OF zmod_zmult1_eq zmod_zmult1_eq_rev]
zmod_uminus' [symmetric]
- zmod_zadd_left_eq [where b = "1"]
+ mod_add_left_eq [where b = "1::int"]
zmod_zsub_left_eq [where b = "1"]
lemmas bintr_arith1s =
- brdmod1s' [where c="2^n", folded pred_def succ_def bintrunc_mod2p, standard]
+ brdmod1s' [where c="2^n::int", folded pred_def succ_def bintrunc_mod2p, standard]
lemmas bintr_ariths =
- brdmods' [where c="2^n", folded pred_def succ_def bintrunc_mod2p, standard]
+ brdmods' [where c="2^n::int", folded pred_def succ_def bintrunc_mod2p, standard]
lemmas m2pths = pos_mod_sign pos_mod_bound [OF zless2p, standard]
--- a/src/HOL/Word/Num_Lemmas.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Word/Num_Lemmas.thy Thu Feb 26 11:21:29 2009 +0000
@@ -95,7 +95,7 @@
lemma z1pdiv2:
"(2 * b + 1) div 2 = (b::int)" by arith
-lemmas zdiv_le_dividend = xtr3 [OF zdiv_1 [symmetric] zdiv_mono2,
+lemmas zdiv_le_dividend = xtr3 [OF div_by_1 [symmetric] zdiv_mono2,
simplified int_one_le_iff_zero_less, simplified, standard]
lemma axxbyy:
@@ -121,18 +121,18 @@
lemma zmod_zsub_distrib: "((a::int) - b) mod c = (a mod c - b mod c) mod c"
apply (unfold diff_int_def)
- apply (rule trans [OF _ zmod_zadd1_eq [symmetric]])
- apply (simp add: zmod_uminus zmod_zadd1_eq [symmetric])
+ apply (rule trans [OF _ mod_add_eq [symmetric]])
+ apply (simp add: zmod_uminus mod_add_eq [symmetric])
done
lemma zmod_zsub_right_eq: "((a::int) - b) mod c = (a - b mod c) mod c"
apply (unfold diff_int_def)
- apply (rule trans [OF _ zmod_zadd_right_eq [symmetric]])
- apply (simp add : zmod_uminus zmod_zadd_right_eq [symmetric])
+ apply (rule trans [OF _ mod_add_right_eq [symmetric]])
+ apply (simp add : zmod_uminus mod_add_right_eq [symmetric])
done
lemma zmod_zsub_left_eq: "((a::int) - b) mod c = (a mod c - b) mod c"
- by (rule zmod_zadd_left_eq [where b = "- b", simplified diff_int_def [symmetric]])
+ by (rule mod_add_left_eq [where b = "- b", simplified diff_int_def [symmetric]])
lemma zmod_zsub_self [simp]:
"((b :: int) - a) mod a = b mod a"
@@ -146,8 +146,8 @@
done
lemmas rdmods [symmetric] = zmod_uminus [symmetric]
- zmod_zsub_left_eq zmod_zsub_right_eq zmod_zadd_left_eq
- zmod_zadd_right_eq zmod_zmult1_eq zmod_zmult1_eq_rev
+ zmod_zsub_left_eq zmod_zsub_right_eq mod_add_left_eq
+ mod_add_right_eq zmod_zmult1_eq zmod_zmult1_eq_rev
lemma mod_plus_right:
"((a + x) mod m = (b + x) mod m) = (a mod m = b mod (m :: nat))"
@@ -162,14 +162,15 @@
lemmas nat_minus_mod_plus_right = trans [OF nat_minus_mod mod_0 [symmetric],
THEN mod_plus_right [THEN iffD2], standard, simplified]
-lemmas push_mods' = zmod_zadd1_eq [standard]
- zmod_zmult_distrib [standard] zmod_zsub_distrib [standard]
+lemmas push_mods' = mod_add_eq [standard]
+ mod_mult_eq [standard] zmod_zsub_distrib [standard]
zmod_uminus [symmetric, standard]
lemmas push_mods = push_mods' [THEN eq_reflection, standard]
lemmas pull_mods = push_mods [symmetric] rdmods [THEN eq_reflection, standard]
lemmas mod_simps =
- zmod_zmult_self1 [THEN eq_reflection] zmod_zmult_self2 [THEN eq_reflection]
+ mod_mult_self2_is_0 [THEN eq_reflection]
+ mod_mult_self1_is_0 [THEN eq_reflection]
mod_mod_trivial [THEN eq_reflection]
lemma nat_mod_eq:
@@ -313,7 +314,7 @@
"a > 1 ==> a ^ n mod a ^ m = (if m <= n then 0 else (a :: int) ^ n)"
apply clarsimp
apply safe
- apply (simp add: zdvd_iff_zmod_eq_0 [symmetric])
+ apply (simp add: dvd_eq_mod_eq_0 [symmetric])
apply (drule le_iff_add [THEN iffD1])
apply (force simp: zpower_zadd_distrib)
apply (rule mod_pos_pos_trivial)
--- a/src/HOL/Word/WordGenLib.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Word/WordGenLib.thy Thu Feb 26 11:21:29 2009 +0000
@@ -273,7 +273,7 @@
have x: "2^len_of TYPE('a) - i = -i + 2^len_of TYPE('a)" by simp
show ?thesis
apply (subst x)
- apply (subst word_uint.Abs_norm [symmetric], subst zmod_zadd_self2)
+ apply (subst word_uint.Abs_norm [symmetric], subst mod_add_self2)
apply simp
done
qed
@@ -293,9 +293,9 @@
shows "(x + y) mod b = z' mod b'"
proof -
from 1 2[symmetric] 3[symmetric] have "(x + y) mod b = (x' mod b' + y' mod b') mod b'"
- by (simp add: zmod_zadd1_eq[symmetric])
+ by (simp add: mod_add_eq[symmetric])
also have "\<dots> = (x' + y') mod b'"
- by (simp add: zmod_zadd1_eq[symmetric])
+ by (simp add: mod_add_eq[symmetric])
finally show ?thesis by (simp add: 4)
qed
--- a/src/HOL/Word/WordShift.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/Word/WordShift.thy Thu Feb 26 11:21:29 2009 +0000
@@ -530,7 +530,7 @@
done
lemma and_mask_dvd: "2 ^ n dvd uint w = (w AND mask n = 0)"
- apply (simp add: zdvd_iff_zmod_eq_0 and_mask_mod_2p)
+ apply (simp add: dvd_eq_mod_eq_0 and_mask_mod_2p)
apply (simp add: word_uint.norm_eq_iff [symmetric] word_of_int_homs)
apply (subst word_uint.norm_Rep [symmetric])
apply (simp only: bintrunc_bintrunc_min bintrunc_mod2p [symmetric] min_def)
--- a/src/HOL/ex/Efficient_Nat_examples.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/ex/Efficient_Nat_examples.thy Thu Feb 26 11:21:29 2009 +0000
@@ -1,12 +1,11 @@
(* Title: HOL/ex/Efficient_Nat_examples.thy
- ID: $Id$
Author: Florian Haftmann, TU Muenchen
*)
header {* Simple examples for Efficient\_Nat theory. *}
theory Efficient_Nat_examples
-imports Main "~~/src/HOL/Real/RealDef" Efficient_Nat
+imports Complex_Main Efficient_Nat
begin
fun to_n :: "nat \<Rightarrow> nat list" where
--- a/src/HOL/ex/Eval_Examples.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/ex/Eval_Examples.thy Thu Feb 26 11:21:29 2009 +0000
@@ -1,6 +1,4 @@
-(* ID: $Id$
- Author: Florian Haftmann, TU Muenchen
-*)
+(* Author: Florian Haftmann, TU Muenchen *)
header {* Small examples for evaluation mechanisms *}
--- a/src/HOL/ex/Numeral.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/ex/Numeral.thy Thu Feb 26 11:21:29 2009 +0000
@@ -1,8 +1,8 @@
(* Title: HOL/ex/Numeral.thy
Author: Florian Haftmann
+*)
-An experimental alternative numeral representation.
-*)
+header {* An experimental alternative numeral representation. *}
theory Numeral
imports Int Inductive
@@ -10,70 +10,103 @@
subsection {* The @{text num} type *}
+datatype num = One | Dig0 num | Dig1 num
+
+text {* Increment function for type @{typ num} *}
+
+primrec
+ inc :: "num \<Rightarrow> num"
+where
+ "inc One = Dig0 One"
+| "inc (Dig0 x) = Dig1 x"
+| "inc (Dig1 x) = Dig0 (inc x)"
+
+text {* Converting between type @{typ num} and type @{typ nat} *}
+
+primrec
+ nat_of_num :: "num \<Rightarrow> nat"
+where
+ "nat_of_num One = Suc 0"
+| "nat_of_num (Dig0 x) = nat_of_num x + nat_of_num x"
+| "nat_of_num (Dig1 x) = Suc (nat_of_num x + nat_of_num x)"
+
+primrec
+ num_of_nat :: "nat \<Rightarrow> num"
+where
+ "num_of_nat 0 = One"
+| "num_of_nat (Suc n) = (if 0 < n then inc (num_of_nat n) else One)"
+
+lemma nat_of_num_pos: "0 < nat_of_num x"
+ by (induct x) simp_all
+
+lemma nat_of_num_neq_0: " nat_of_num x \<noteq> 0"
+ by (induct x) simp_all
+
+lemma nat_of_num_inc: "nat_of_num (inc x) = Suc (nat_of_num x)"
+ by (induct x) simp_all
+
+lemma num_of_nat_double:
+ "0 < n \<Longrightarrow> num_of_nat (n + n) = Dig0 (num_of_nat n)"
+ by (induct n) simp_all
+
text {*
- We construct @{text num} as a copy of strictly positive
+ Type @{typ num} is isomorphic to the strictly positive
natural numbers.
*}
-typedef (open) num = "\<lambda>n\<Colon>nat. n > 0"
- morphisms nat_of_num num_of_nat_abs
- by (auto simp add: mem_def)
-
-text {*
- A totalized abstraction function. It is not entirely clear
- whether this is really useful.
-*}
-
-definition num_of_nat :: "nat \<Rightarrow> num" where
- "num_of_nat n = (if n = 0 then num_of_nat_abs 1 else num_of_nat_abs n)"
+lemma nat_of_num_inverse: "num_of_nat (nat_of_num x) = x"
+ by (induct x) (simp_all add: num_of_nat_double nat_of_num_pos)
-lemma num_cases [case_names nat, cases type: num]:
- assumes "(\<And>n\<Colon>nat. m = num_of_nat n \<Longrightarrow> 0 < n \<Longrightarrow> P)"
- shows P
-apply (rule num_of_nat_abs_cases)
-apply (unfold mem_def)
-using assms unfolding num_of_nat_def
-apply auto
-done
+lemma num_of_nat_inverse: "0 < n \<Longrightarrow> nat_of_num (num_of_nat n) = n"
+ by (induct n) (simp_all add: nat_of_num_inc)
-lemma num_of_nat_zero: "num_of_nat 0 = num_of_nat 1"
- by (simp add: num_of_nat_def)
-
-lemma num_of_nat_inverse: "nat_of_num (num_of_nat n) = (if n = 0 then 1 else n)"
- apply (simp add: num_of_nat_def)
- apply (subst num_of_nat_abs_inverse)
- apply (auto simp add: mem_def num_of_nat_abs_inverse)
+lemma num_eq_iff: "x = y \<longleftrightarrow> nat_of_num x = nat_of_num y"
+ apply safe
+ apply (drule arg_cong [where f=num_of_nat])
+ apply (simp add: nat_of_num_inverse)
done
-lemma num_of_nat_inject:
- "num_of_nat m = num_of_nat n \<longleftrightarrow> m = n \<or> (m = 0 \<or> m = 1) \<and> (n = 0 \<or> n = 1)"
-by (auto simp add: num_of_nat_def num_of_nat_abs_inject [unfolded mem_def])
-
-lemma split_num_all:
- "(\<And>m. PROP P m) \<equiv> (\<And>n. PROP P (num_of_nat n))"
-proof
- fix n
- assume "\<And>m\<Colon>num. PROP P m"
- then show "PROP P (num_of_nat n)" .
-next
- fix m
- have nat_of_num: "\<And>m. nat_of_num m \<noteq> 0"
- using nat_of_num by (auto simp add: mem_def)
- have nat_of_num_inverse: "\<And>m. num_of_nat (nat_of_num m) = m"
- by (auto simp add: num_of_nat_def nat_of_num_inverse nat_of_num)
- assume "\<And>n. PROP P (num_of_nat n)"
- then have "PROP P (num_of_nat (nat_of_num m))" .
- then show "PROP P m" unfolding nat_of_num_inverse .
+lemma num_induct [case_names One inc]:
+ fixes P :: "num \<Rightarrow> bool"
+ assumes One: "P One"
+ and inc: "\<And>x. P x \<Longrightarrow> P (inc x)"
+ shows "P x"
+proof -
+ obtain n where n: "Suc n = nat_of_num x"
+ by (cases "nat_of_num x", simp_all add: nat_of_num_neq_0)
+ have "P (num_of_nat (Suc n))"
+ proof (induct n)
+ case 0 show ?case using One by simp
+ next
+ case (Suc n)
+ then have "P (inc (num_of_nat (Suc n)))" by (rule inc)
+ then show "P (num_of_nat (Suc (Suc n)))" by simp
+ qed
+ with n show "P x"
+ by (simp add: nat_of_num_inverse)
qed
+text {*
+ From now on, there are two possible models for @{typ num}:
+ as positive naturals (rule @{text "num_induct"})
+ and as digit representation (rules @{text "num.induct"}, @{text "num.cases"}).
-subsection {* Digit representation for @{typ num} *}
+ It is not entirely clear in which context it is better to use
+ the one or the other, or whether the construction should be reversed.
+*}
+
-instantiation num :: "{semiring, monoid_mult}"
-begin
+subsection {* Numeral operations *}
-definition one_num :: num where
- [code del]: "1 = num_of_nat 1"
+ML {*
+structure DigSimps =
+ NamedThmsFun(val name = "numeral"; val description = "Simplification rules for numerals")
+*}
+
+setup DigSimps.setup
+
+instantiation num :: "{plus,times,ord}"
+begin
definition plus_num :: "num \<Rightarrow> num \<Rightarrow> num" where
[code del]: "m + n = num_of_nat (nat_of_num m + nat_of_num n)"
@@ -81,167 +114,126 @@
definition times_num :: "num \<Rightarrow> num \<Rightarrow> num" where
[code del]: "m * n = num_of_nat (nat_of_num m * nat_of_num n)"
-definition Dig0 :: "num \<Rightarrow> num" where
- [code del]: "Dig0 n = n + n"
+definition less_eq_num :: "num \<Rightarrow> num \<Rightarrow> bool" where
+ [code del]: "m \<le> n \<longleftrightarrow> nat_of_num m \<le> nat_of_num n"
-definition Dig1 :: "num \<Rightarrow> num" where
- [code del]: "Dig1 n = n + n + 1"
+definition less_num :: "num \<Rightarrow> num \<Rightarrow> bool" where
+ [code del]: "m < n \<longleftrightarrow> nat_of_num m < nat_of_num n"
-instance proof
-qed (simp_all add: one_num_def plus_num_def times_num_def
- split_num_all num_of_nat_inverse num_of_nat_zero add_ac mult_ac nat_distrib)
+instance ..
end
-text {*
- The following proofs seem horribly complicated.
- Any room for simplification!?
-*}
+lemma nat_of_num_add: "nat_of_num (x + y) = nat_of_num x + nat_of_num y"
+ unfolding plus_num_def
+ by (intro num_of_nat_inverse add_pos_pos nat_of_num_pos)
+
+lemma nat_of_num_mult: "nat_of_num (x * y) = nat_of_num x * nat_of_num y"
+ unfolding times_num_def
+ by (intro num_of_nat_inverse mult_pos_pos nat_of_num_pos)
+
+lemma Dig_plus [numeral, simp, code]:
+ "One + One = Dig0 One"
+ "One + Dig0 m = Dig1 m"
+ "One + Dig1 m = Dig0 (m + One)"
+ "Dig0 n + One = Dig1 n"
+ "Dig0 n + Dig0 m = Dig0 (n + m)"
+ "Dig0 n + Dig1 m = Dig1 (n + m)"
+ "Dig1 n + One = Dig0 (n + One)"
+ "Dig1 n + Dig0 m = Dig1 (n + m)"
+ "Dig1 n + Dig1 m = Dig0 (n + m + One)"
+ by (simp_all add: num_eq_iff nat_of_num_add)
-lemma nat_dig_cases [case_names 0 1 dig0 dig1]:
- fixes n :: nat
- assumes "n = 0 \<Longrightarrow> P"
- and "n = 1 \<Longrightarrow> P"
- and "\<And>m. m > 0 \<Longrightarrow> n = m + m \<Longrightarrow> P"
- and "\<And>m. m > 0 \<Longrightarrow> n = Suc (m + m) \<Longrightarrow> P"
- shows P
-using assms proof (induct n)
- case 0 then show ?case by simp
-next
- case (Suc n)
- show P proof (rule Suc.hyps)
- assume "n = 0"
- then have "Suc n = 1" by simp
- then show P by (rule Suc.prems(2))
- next
- assume "n = 1"
- have "1 > (0\<Colon>nat)" by simp
- moreover from `n = 1` have "Suc n = 1 + 1" by simp
- ultimately show P by (rule Suc.prems(3))
- next
- fix m
- assume "0 < m" and "n = m + m"
- note `0 < m`
- moreover from `n = m + m` have "Suc n = Suc (m + m)" by simp
- ultimately show P by (rule Suc.prems(4))
- next
- fix m
- assume "0 < m" and "n = Suc (m + m)"
- have "0 < Suc m" by simp
- moreover from `n = Suc (m + m)` have "Suc n = Suc m + Suc m" by simp
- ultimately show P by (rule Suc.prems(3))
- qed
-qed
+lemma Dig_times [numeral, simp, code]:
+ "One * One = One"
+ "One * Dig0 n = Dig0 n"
+ "One * Dig1 n = Dig1 n"
+ "Dig0 n * One = Dig0 n"
+ "Dig0 n * Dig0 m = Dig0 (n * Dig0 m)"
+ "Dig0 n * Dig1 m = Dig0 (n * Dig1 m)"
+ "Dig1 n * One = Dig1 n"
+ "Dig1 n * Dig0 m = Dig0 (n * Dig0 m + m)"
+ "Dig1 n * Dig1 m = Dig1 (n * Dig1 m + m)"
+ by (simp_all add: num_eq_iff nat_of_num_add nat_of_num_mult
+ left_distrib right_distrib)
-lemma num_induct_raw:
- fixes n :: nat
- assumes not0: "n > 0"
- assumes "P 1"
- and "\<And>n. n > 0 \<Longrightarrow> P n \<Longrightarrow> P (n + n)"
- and "\<And>n. n > 0 \<Longrightarrow> P n \<Longrightarrow> P (Suc (n + n))"
- shows "P n"
-using not0 proof (induct n rule: less_induct)
- case (less n)
- show "P n" proof (cases n rule: nat_dig_cases)
- case 0 then show ?thesis using less by simp
- next
- case 1 then show ?thesis using assms by simp
- next
- case (dig0 m)
- then show ?thesis apply simp
- apply (rule assms(3)) apply assumption
- apply (rule less)
- apply simp_all
- done
- next
- case (dig1 m)
- then show ?thesis apply simp
- apply (rule assms(4)) apply assumption
- apply (rule less)
- apply simp_all
- done
- qed
-qed
-
-lemma num_of_nat_Suc: "num_of_nat (Suc n) = (if n = 0 then 1 else num_of_nat n + 1)"
- by (cases n) (auto simp add: one_num_def plus_num_def num_of_nat_inverse)
+lemma Dig_eq:
+ "One = One \<longleftrightarrow> True"
+ "One = Dig0 n \<longleftrightarrow> False"
+ "One = Dig1 n \<longleftrightarrow> False"
+ "Dig0 m = One \<longleftrightarrow> False"
+ "Dig1 m = One \<longleftrightarrow> False"
+ "Dig0 m = Dig0 n \<longleftrightarrow> m = n"
+ "Dig0 m = Dig1 n \<longleftrightarrow> False"
+ "Dig1 m = Dig0 n \<longleftrightarrow> False"
+ "Dig1 m = Dig1 n \<longleftrightarrow> m = n"
+ by simp_all
-lemma num_induct [case_names 1 Suc, induct type: num]:
- fixes P :: "num \<Rightarrow> bool"
- assumes 1: "P 1"
- and Suc: "\<And>n. P n \<Longrightarrow> P (n + 1)"
- shows "P n"
-proof (cases n)
- case (nat m) then show ?thesis by (induct m arbitrary: n)
- (auto simp: num_of_nat_Suc intro: 1 Suc split: split_if_asm)
-qed
+lemma less_eq_num_code [numeral, simp, code]:
+ "One \<le> n \<longleftrightarrow> True"
+ "Dig0 m \<le> One \<longleftrightarrow> False"
+ "Dig1 m \<le> One \<longleftrightarrow> False"
+ "Dig0 m \<le> Dig0 n \<longleftrightarrow> m \<le> n"
+ "Dig0 m \<le> Dig1 n \<longleftrightarrow> m \<le> n"
+ "Dig1 m \<le> Dig1 n \<longleftrightarrow> m \<le> n"
+ "Dig1 m \<le> Dig0 n \<longleftrightarrow> m < n"
+ using nat_of_num_pos [of n] nat_of_num_pos [of m]
+ by (auto simp add: less_eq_num_def less_num_def)
+
+lemma less_num_code [numeral, simp, code]:
+ "m < One \<longleftrightarrow> False"
+ "One < One \<longleftrightarrow> False"
+ "One < Dig0 n \<longleftrightarrow> True"
+ "One < Dig1 n \<longleftrightarrow> True"
+ "Dig0 m < Dig0 n \<longleftrightarrow> m < n"
+ "Dig0 m < Dig1 n \<longleftrightarrow> m \<le> n"
+ "Dig1 m < Dig1 n \<longleftrightarrow> m < n"
+ "Dig1 m < Dig0 n \<longleftrightarrow> m < n"
+ using nat_of_num_pos [of n] nat_of_num_pos [of m]
+ by (auto simp add: less_eq_num_def less_num_def)
+
+text {* Rules using @{text One} and @{text inc} as constructors *}
+
+lemma add_One: "x + One = inc x"
+ by (simp add: num_eq_iff nat_of_num_add nat_of_num_inc)
+
+lemma add_inc: "x + inc y = inc (x + y)"
+ by (simp add: num_eq_iff nat_of_num_add nat_of_num_inc)
-rep_datatype "1::num" Dig0 Dig1 proof -
- fix P m
- assume 1: "P 1"
- and Dig0: "\<And>m. P m \<Longrightarrow> P (Dig0 m)"
- and Dig1: "\<And>m. P m \<Longrightarrow> P (Dig1 m)"
- obtain n where "0 < n" and m: "m = num_of_nat n"
- by (cases m) auto
- from `0 < n` have "P (num_of_nat n)" proof (induct n rule: num_induct_raw)
- case 1 from `0 < n` show ?case .
- next
- case 2 with 1 show ?case by (simp add: one_num_def)
- next
- case (3 n) then have "P (num_of_nat n)" by auto
- then have "P (Dig0 (num_of_nat n))" by (rule Dig0)
- with 3 show ?case by (simp add: Dig0_def plus_num_def num_of_nat_inverse)
- next
- case (4 n) then have "P (num_of_nat n)" by auto
- then have "P (Dig1 (num_of_nat n))" by (rule Dig1)
- with 4 show ?case by (simp add: Dig1_def one_num_def plus_num_def num_of_nat_inverse)
- qed
- with m show "P m" by simp
-next
- fix m n
- show "Dig0 m = Dig0 n \<longleftrightarrow> m = n"
- apply (cases m) apply (cases n)
- by (auto simp add: Dig0_def plus_num_def num_of_nat_inverse num_of_nat_inject)
-next
- fix m n
- show "Dig1 m = Dig1 n \<longleftrightarrow> m = n"
- apply (cases m) apply (cases n)
- by (auto simp add: Dig1_def plus_num_def num_of_nat_inverse num_of_nat_inject)
-next
- fix n
- show "1 \<noteq> Dig0 n"
- apply (cases n)
- by (auto simp add: Dig0_def one_num_def plus_num_def num_of_nat_inverse num_of_nat_inject)
-next
- fix n
- show "1 \<noteq> Dig1 n"
- apply (cases n)
- by (auto simp add: Dig1_def one_num_def plus_num_def num_of_nat_inverse num_of_nat_inject)
-next
- fix m n
- have "\<And>n m. n + n \<noteq> Suc (m + m)"
- proof -
- fix n m
- show "n + n \<noteq> Suc (m + m)"
- proof (induct m arbitrary: n)
- case 0 then show ?case by (cases n) simp_all
- next
- case (Suc m) then show ?case by (cases n) simp_all
- qed
- qed
- then show "Dig0 n \<noteq> Dig1 m"
- apply (cases n) apply (cases m)
- by (auto simp add: Dig0_def Dig1_def one_num_def plus_num_def num_of_nat_inverse num_of_nat_inject)
-qed
+lemma mult_One: "x * One = x"
+ by (simp add: num_eq_iff nat_of_num_mult)
+
+lemma mult_inc: "x * inc y = x * y + x"
+ by (simp add: num_eq_iff nat_of_num_mult nat_of_num_add nat_of_num_inc)
+
+text {* A double-and-decrement function *}
+
+primrec DigM :: "num \<Rightarrow> num" where
+ "DigM One = One"
+ | "DigM (Dig0 n) = Dig1 (DigM n)"
+ | "DigM (Dig1 n) = Dig1 (Dig0 n)"
+
+lemma DigM_plus_one: "DigM n + One = Dig0 n"
+ by (induct n) simp_all
-text {*
- From now on, there are two possible models for @{typ num}:
- as positive naturals (rules @{text "num_induct"}, @{text "num_cases"})
- and as digit representation (rules @{text "num.induct"}, @{text "num.cases"}).
+lemma add_One_commute: "One + n = n + One"
+ by (induct n) simp_all
+
+lemma one_plus_DigM: "One + DigM n = Dig0 n"
+ unfolding add_One_commute DigM_plus_one ..
+
+text {* Squaring and exponentiation *}
- It is not entirely clear in which context it is better to use
- the one or the other, or whether the construction should be reversed.
-*}
+primrec square :: "num \<Rightarrow> num" where
+ "square One = One"
+| "square (Dig0 n) = Dig0 (Dig0 (square n))"
+| "square (Dig1 n) = Dig1 (Dig0 (square n + n))"
+
+primrec pow :: "num \<Rightarrow> num \<Rightarrow> num"
+where
+ "pow x One = x"
+| "pow x (Dig0 y) = square (pow x y)"
+| "pow x (Dig1 y) = x * square (pow x y)"
subsection {* Binary numerals *}
@@ -251,21 +243,17 @@
structure using @{text of_num}.
*}
-ML {*
-structure DigSimps =
- NamedThmsFun(val name = "numeral"; val description = "Simplification rules for numerals")
-*}
-
-setup DigSimps.setup
-
class semiring_numeral = semiring + monoid_mult
begin
primrec of_num :: "num \<Rightarrow> 'a" where
- of_num_one [numeral]: "of_num 1 = 1"
+ of_num_one [numeral]: "of_num One = 1"
| "of_num (Dig0 n) = of_num n + of_num n"
| "of_num (Dig1 n) = of_num n + of_num n + 1"
+lemma of_num_inc: "of_num (inc x) = of_num x + 1"
+ by (induct x) (simp_all add: add_ac)
+
declare of_num.simps [simp del]
end
@@ -275,14 +263,14 @@
*}
ML {*
-fun mk_num 1 = @{term "1::num"}
+fun mk_num 1 = @{term One}
| mk_num k =
let
val (l, b) = Integer.div_mod k 2;
val bit = (if b = 0 then @{term Dig0} else @{term Dig1});
in bit $ (mk_num l) end;
-fun dest_num @{term "1::num"} = 1
+fun dest_num @{term One} = 1
| dest_num (@{term Dig0} $ n) = 2 * dest_num n
| dest_num (@{term Dig1} $ n) = 2 * dest_num n + 1;
@@ -301,7 +289,7 @@
parse_translation {*
let
fun num_of_int n = if n > 0 then case IntInf.quotRem (n, 2)
- of (0, 1) => Const (@{const_name HOL.one}, dummyT)
+ of (0, 1) => Const (@{const_name One}, dummyT)
| (n, 0) => Const (@{const_name Dig0}, dummyT) $ num_of_int n
| (n, 1) => Const (@{const_name Dig1}, dummyT) $ num_of_int n
else raise Match;
@@ -322,7 +310,7 @@
dig 0 (int_of_num' n)
| int_of_num' (Const (@{const_syntax Dig1}, _) $ n) =
dig 1 (int_of_num' n)
- | int_of_num' (Const (@{const_syntax HOL.one}, _)) = 1;
+ | int_of_num' (Const (@{const_syntax One}, _)) = 1;
fun num_tr' show_sorts T [n] =
let
val k = int_of_num' n;
@@ -336,45 +324,18 @@
in [(@{const_syntax of_num}, num_tr')] end
*}
-
-subsection {* Numeral operations *}
-
-text {*
- First, addition and multiplication on digits.
-*}
-
-lemma Dig_plus [numeral, simp, code]:
- "1 + 1 = Dig0 1"
- "1 + Dig0 m = Dig1 m"
- "1 + Dig1 m = Dig0 (m + 1)"
- "Dig0 n + 1 = Dig1 n"
- "Dig0 n + Dig0 m = Dig0 (n + m)"
- "Dig0 n + Dig1 m = Dig1 (n + m)"
- "Dig1 n + 1 = Dig0 (n + 1)"
- "Dig1 n + Dig0 m = Dig1 (n + m)"
- "Dig1 n + Dig1 m = Dig0 (n + m + 1)"
- by (simp_all add: add_ac Dig0_def Dig1_def)
-
-lemma Dig_times [numeral, simp, code]:
- "1 * 1 = (1::num)"
- "1 * Dig0 n = Dig0 n"
- "1 * Dig1 n = Dig1 n"
- "Dig0 n * 1 = Dig0 n"
- "Dig0 n * Dig0 m = Dig0 (n * Dig0 m)"
- "Dig0 n * Dig1 m = Dig0 (n * Dig1 m)"
- "Dig1 n * 1 = Dig1 n"
- "Dig1 n * Dig0 m = Dig0 (n * Dig0 m + m)"
- "Dig1 n * Dig1 m = Dig1 (n * Dig1 m + m)"
- by (simp_all add: left_distrib right_distrib add_ac Dig0_def Dig1_def)
+subsection {* Class-specific numeral rules *}
text {*
@{const of_num} is a morphism.
*}
+subsubsection {* Class @{text semiring_numeral} *}
+
context semiring_numeral
begin
-abbreviation "Num1 \<equiv> of_num 1"
+abbreviation "Num1 \<equiv> of_num One"
text {*
Alas, there is still the duplication of @{term 1},
@@ -386,18 +347,17 @@
*}
lemma of_num_plus_one [numeral]:
- "of_num n + 1 = of_num (n + 1)"
- by (rule sym, induct n) (simp_all add: Dig_plus of_num.simps add_ac)
+ "of_num n + 1 = of_num (n + One)"
+ by (rule sym, induct n) (simp_all add: of_num.simps add_ac)
lemma of_num_one_plus [numeral]:
- "1 + of_num n = of_num (n + 1)"
+ "1 + of_num n = of_num (n + One)"
unfolding of_num_plus_one [symmetric] add_commute ..
lemma of_num_plus [numeral]:
"of_num m + of_num n = of_num (m + n)"
by (induct n rule: num_induct)
- (simp_all add: Dig_plus of_num_one semigroup_add_class.add_assoc [symmetric, of m]
- add_ac of_num_plus_one [symmetric])
+ (simp_all add: add_One add_inc of_num_one of_num_inc add_ac)
lemma of_num_times_one [numeral]:
"of_num n * 1 = of_num n"
@@ -410,13 +370,13 @@
lemma of_num_times [numeral]:
"of_num m * of_num n = of_num (m * n)"
by (induct n rule: num_induct)
- (simp_all add: of_num_plus [symmetric]
- semiring_class.right_distrib right_distrib of_num_one)
+ (simp_all add: of_num_plus [symmetric] mult_One mult_inc
+ semiring_class.right_distrib right_distrib of_num_one of_num_inc)
end
-text {*
- Structures with a @{term 0}.
+subsubsection {*
+ Structures with a zero: class @{text semiring_1}
*}
context semiring_1
@@ -449,16 +409,13 @@
lemma nat_of_num_of_num: "nat_of_num = of_num"
proof
fix n
- have "of_num n = nat_of_num n" apply (induct n)
- apply (simp_all add: of_num.simps)
- using nat_of_num
- apply (simp_all add: one_num_def plus_num_def Dig0_def Dig1_def num_of_nat_inverse mem_def)
- done
+ have "of_num n = nat_of_num n"
+ by (induct n) (simp_all add: of_num.simps)
then show "nat_of_num n = of_num n" by simp
qed
-text {*
- Equality.
+subsubsection {*
+ Equality: class @{text semiring_char_0}
*}
context semiring_char_0
@@ -467,77 +424,32 @@
lemma of_num_eq_iff [numeral]:
"of_num m = of_num n \<longleftrightarrow> m = n"
unfolding of_nat_of_num [symmetric] nat_of_num_of_num [symmetric]
- of_nat_eq_iff nat_of_num_inject ..
+ of_nat_eq_iff num_eq_iff ..
lemma of_num_eq_one_iff [numeral]:
- "of_num n = 1 \<longleftrightarrow> n = 1"
+ "of_num n = 1 \<longleftrightarrow> n = One"
proof -
- have "of_num n = of_num 1 \<longleftrightarrow> n = 1" unfolding of_num_eq_iff ..
+ have "of_num n = of_num One \<longleftrightarrow> n = One" unfolding of_num_eq_iff ..
then show ?thesis by (simp add: of_num_one)
qed
lemma one_eq_of_num_iff [numeral]:
- "1 = of_num n \<longleftrightarrow> n = 1"
+ "1 = of_num n \<longleftrightarrow> n = One"
unfolding of_num_eq_one_iff [symmetric] by auto
end
-text {*
- Comparisons. Could be perhaps more general than here.
+subsubsection {*
+ Comparisons: class @{text ordered_semidom}
*}
-lemma (in ordered_semidom) of_num_pos: "0 < of_num n"
-proof -
- have "(0::nat) < of_num n"
- by (induct n) (simp_all add: semiring_numeral_class.of_num.simps)
- then have "of_nat 0 \<noteq> of_nat (of_num n)"
- by (cases n) (simp_all only: semiring_numeral_class.of_num.simps of_nat_eq_iff)
- then have "0 \<noteq> of_num n"
- by (simp add: of_nat_of_num)
- moreover have "0 \<le> of_nat (of_num n)" by simp
- ultimately show ?thesis by (simp add: of_nat_of_num)
-qed
+text {* Could be perhaps more general than here. *}
-instantiation num :: linorder
+context ordered_semidom
begin
-definition less_eq_num :: "num \<Rightarrow> num \<Rightarrow> bool" where
- [code del]: "m \<le> n \<longleftrightarrow> nat_of_num m \<le> nat_of_num n"
-
-definition less_num :: "num \<Rightarrow> num \<Rightarrow> bool" where
- [code del]: "m < n \<longleftrightarrow> nat_of_num m < nat_of_num n"
-
-instance proof
-qed (auto simp add: less_eq_num_def less_num_def
- split_num_all num_of_nat_inverse num_of_nat_inject split: split_if_asm)
-
-end
-
-lemma less_eq_num_code [numeral, simp, code]:
- "(1::num) \<le> n \<longleftrightarrow> True"
- "Dig0 m \<le> 1 \<longleftrightarrow> False"
- "Dig1 m \<le> 1 \<longleftrightarrow> False"
- "Dig0 m \<le> Dig0 n \<longleftrightarrow> m \<le> n"
- "Dig0 m \<le> Dig1 n \<longleftrightarrow> m \<le> n"
- "Dig1 m \<le> Dig1 n \<longleftrightarrow> m \<le> n"
- "Dig1 m \<le> Dig0 n \<longleftrightarrow> m < n"
- using of_num_pos [of n, where ?'a = nat] of_num_pos [of m, where ?'a = nat]
- by (auto simp add: less_eq_num_def less_num_def nat_of_num_of_num of_num.simps)
-
-lemma less_num_code [numeral, simp, code]:
- "m < (1::num) \<longleftrightarrow> False"
- "(1::num) < 1 \<longleftrightarrow> False"
- "1 < Dig0 n \<longleftrightarrow> True"
- "1 < Dig1 n \<longleftrightarrow> True"
- "Dig0 m < Dig0 n \<longleftrightarrow> m < n"
- "Dig0 m < Dig1 n \<longleftrightarrow> m \<le> n"
- "Dig1 m < Dig1 n \<longleftrightarrow> m < n"
- "Dig1 m < Dig0 n \<longleftrightarrow> m < n"
- using of_num_pos [of n, where ?'a = nat] of_num_pos [of m, where ?'a = nat]
- by (auto simp add: less_eq_num_def less_num_def nat_of_num_of_num of_num.simps)
-
-context ordered_semidom
-begin
+lemma of_num_pos [numeral]: "0 < of_num n"
+ by (induct n) (simp_all add: of_num.simps add_pos_pos)
lemma of_num_less_eq_iff [numeral]: "of_num m \<le> of_num n \<longleftrightarrow> m \<le> n"
proof -
@@ -546,16 +458,16 @@
then show ?thesis by (simp add: of_nat_of_num)
qed
-lemma of_num_less_eq_one_iff [numeral]: "of_num n \<le> 1 \<longleftrightarrow> n = 1"
+lemma of_num_less_eq_one_iff [numeral]: "of_num n \<le> 1 \<longleftrightarrow> n = One"
proof -
- have "of_num n \<le> of_num 1 \<longleftrightarrow> n = 1"
+ have "of_num n \<le> of_num One \<longleftrightarrow> n = One"
by (cases n) (simp_all add: of_num_less_eq_iff)
then show ?thesis by (simp add: of_num_one)
qed
lemma one_less_eq_of_num_iff [numeral]: "1 \<le> of_num n"
proof -
- have "of_num 1 \<le> of_num n"
+ have "of_num One \<le> of_num n"
by (cases n) (simp_all add: of_num_less_eq_iff)
then show ?thesis by (simp add: of_num_one)
qed
@@ -569,50 +481,85 @@
lemma of_num_less_one_iff [numeral]: "\<not> of_num n < 1"
proof -
- have "\<not> of_num n < of_num 1"
+ have "\<not> of_num n < of_num One"
by (cases n) (simp_all add: of_num_less_iff)
then show ?thesis by (simp add: of_num_one)
qed
-lemma one_less_of_num_iff [numeral]: "1 < of_num n \<longleftrightarrow> n \<noteq> 1"
+lemma one_less_of_num_iff [numeral]: "1 < of_num n \<longleftrightarrow> n \<noteq> One"
proof -
- have "of_num 1 < of_num n \<longleftrightarrow> n \<noteq> 1"
+ have "of_num One < of_num n \<longleftrightarrow> n \<noteq> One"
by (cases n) (simp_all add: of_num_less_iff)
then show ?thesis by (simp add: of_num_one)
qed
+lemma of_num_nonneg [numeral]: "0 \<le> of_num n"
+ by (induct n) (simp_all add: of_num.simps add_nonneg_nonneg)
+
+lemma of_num_less_zero_iff [numeral]: "\<not> of_num n < 0"
+ by (simp add: not_less of_num_nonneg)
+
+lemma of_num_le_zero_iff [numeral]: "\<not> of_num n \<le> 0"
+ by (simp add: not_le of_num_pos)
+
end
-text {*
- Structures with subtraction @{term "op -"}.
-*}
+context ordered_idom
+begin
-text {* A decrement function *}
+lemma minus_of_num_less_of_num_iff [numeral]: "- of_num m < of_num n"
+proof -
+ have "- of_num m < 0" by (simp add: of_num_pos)
+ also have "0 < of_num n" by (simp add: of_num_pos)
+ finally show ?thesis .
+qed
-primrec dec :: "num \<Rightarrow> num" where
- "dec 1 = 1"
- | "dec (Dig0 n) = (case n of 1 \<Rightarrow> 1 | _ \<Rightarrow> Dig1 (dec n))"
- | "dec (Dig1 n) = Dig0 n"
+lemma minus_of_num_less_one_iff [numeral]: "- of_num n < 1"
+proof -
+ have "- of_num n < 0" by (simp add: of_num_pos)
+ also have "0 < 1" by simp
+ finally show ?thesis .
+qed
-declare dec.simps [simp del, code del]
+lemma minus_one_less_of_num_iff [numeral]: "- 1 < of_num n"
+proof -
+ have "- 1 < 0" by simp
+ also have "0 < of_num n" by (simp add: of_num_pos)
+ finally show ?thesis .
+qed
+
+lemma minus_of_num_le_of_num_iff [numeral]: "- of_num m \<le> of_num n"
+ by (simp add: less_imp_le minus_of_num_less_of_num_iff)
-lemma Dig_dec [numeral, simp, code]:
- "dec 1 = 1"
- "dec (Dig0 1) = 1"
- "dec (Dig0 (Dig0 n)) = Dig1 (dec (Dig0 n))"
- "dec (Dig0 (Dig1 n)) = Dig1 (Dig0 n)"
- "dec (Dig1 n) = Dig0 n"
- by (simp_all add: dec.simps)
+lemma minus_of_num_le_one_iff [numeral]: "- of_num n \<le> 1"
+ by (simp add: less_imp_le minus_of_num_less_one_iff)
+
+lemma minus_one_le_of_num_iff [numeral]: "- 1 \<le> of_num n"
+ by (simp add: less_imp_le minus_one_less_of_num_iff)
+
+lemma of_num_le_minus_of_num_iff [numeral]: "\<not> of_num m \<le> - of_num n"
+ by (simp add: not_le minus_of_num_less_of_num_iff)
+
+lemma one_le_minus_of_num_iff [numeral]: "\<not> 1 \<le> - of_num n"
+ by (simp add: not_le minus_of_num_less_one_iff)
+
+lemma of_num_le_minus_one_iff [numeral]: "\<not> of_num n \<le> - 1"
+ by (simp add: not_le minus_one_less_of_num_iff)
-lemma Dig_dec_plus_one:
- "dec n + 1 = (if n = 1 then Dig0 1 else n)"
- by (induct n)
- (auto simp add: Dig_plus dec.simps,
- auto simp add: Dig_plus split: num.splits)
+lemma of_num_less_minus_of_num_iff [numeral]: "\<not> of_num m < - of_num n"
+ by (simp add: not_less minus_of_num_le_of_num_iff)
+
+lemma one_less_minus_of_num_iff [numeral]: "\<not> 1 < - of_num n"
+ by (simp add: not_less minus_of_num_le_one_iff)
-lemma Dig_one_plus_dec:
- "1 + dec n = (if n = 1 then Dig0 1 else n)"
- unfolding add_commute [of 1] Dig_dec_plus_one ..
+lemma of_num_less_minus_one_iff [numeral]: "\<not> of_num n < - 1"
+ by (simp add: not_less minus_one_le_of_num_iff)
+
+end
+
+subsubsection {*
+ Structures with subtraction: class @{text semiring_1_minus}
+*}
class semiring_minus = semiring + minus + zero +
assumes minus_inverts_plus1: "a + b = c \<Longrightarrow> c - b = a"
@@ -645,7 +592,7 @@
by (rule minus_minus_zero_inverts_plus1) (simp add: of_num_plus assms)
lemmas Dig_plus_eval =
- of_num_plus of_num_eq_iff Dig_plus refl [of "1::num", THEN eqTrueI] num.inject
+ of_num_plus of_num_eq_iff Dig_plus refl [of One, THEN eqTrueI] num.inject
simproc_setup numeral_minus ("of_num m - of_num n") = {*
let
@@ -683,17 +630,21 @@
by (simp add: minus_inverts_plus1)
lemma Dig_of_num_minus_one [numeral]:
- "of_num (Dig0 n) - 1 = of_num (dec (Dig0 n))"
+ "of_num (Dig0 n) - 1 = of_num (DigM n)"
"of_num (Dig1 n) - 1 = of_num (Dig0 n)"
- by (auto intro: minus_inverts_plus1 simp add: Dig_dec_plus_one of_num.simps of_num_plus_one)
+ by (auto intro: minus_inverts_plus1 simp add: DigM_plus_one of_num.simps of_num_plus_one)
lemma Dig_one_minus_of_num [numeral]:
- "1 - of_num (Dig0 n) = 0 - of_num (dec (Dig0 n))"
+ "1 - of_num (Dig0 n) = 0 - of_num (DigM n)"
"1 - of_num (Dig1 n) = 0 - of_num (Dig0 n)"
- by (auto intro: minus_minus_zero_inverts_plus1 simp add: Dig_dec_plus_one of_num.simps of_num_plus_one)
+ by (auto intro: minus_minus_zero_inverts_plus1 simp add: DigM_plus_one of_num.simps of_num_plus_one)
end
+subsubsection {*
+ Structures with negation: class @{text ring_1}
+*}
+
context ring_1
begin
@@ -735,21 +686,63 @@
end
-text {*
+subsubsection {*
+ Structures with exponentiation
+*}
+
+lemma of_num_square: "of_num (square x) = of_num x * of_num x"
+by (induct x)
+ (simp_all add: of_num.simps of_num_plus [symmetric] algebra_simps)
+
+lemma of_num_pow:
+ "(of_num (pow x y)::'a::{semiring_numeral,recpower}) = of_num x ^ of_num y"
+by (induct y)
+ (simp_all add: of_num.simps of_num_square of_num_times [symmetric]
+ power_Suc power_add)
+
+lemma power_of_num [numeral]:
+ "of_num x ^ of_num y = (of_num (pow x y)::'a::{semiring_numeral,recpower})"
+ by (rule of_num_pow [symmetric])
+
+lemma power_zero_of_num [numeral]:
+ "0 ^ of_num n = (0::'a::{semiring_0,recpower})"
+ using of_num_pos [where n=n and ?'a=nat]
+ by (simp add: power_0_left)
+
+lemma power_minus_one_double:
+ "(- 1) ^ (n + n) = (1::'a::{ring_1,recpower})"
+ by (induct n) (simp_all add: power_Suc)
+
+lemma power_minus_Dig0 [numeral]:
+ fixes x :: "'a::{ring_1,recpower}"
+ shows "(- x) ^ of_num (Dig0 n) = x ^ of_num (Dig0 n)"
+ by (subst power_minus)
+ (simp add: of_num.simps power_minus_one_double)
+
+lemma power_minus_Dig1 [numeral]:
+ fixes x :: "'a::{ring_1,recpower}"
+ shows "(- x) ^ of_num (Dig1 n) = - (x ^ of_num (Dig1 n))"
+ by (subst power_minus)
+ (simp add: of_num.simps power_Suc power_minus_one_double)
+
+declare power_one [numeral]
+
+
+subsubsection {*
Greetings to @{typ nat}.
*}
instance nat :: semiring_1_minus proof qed simp_all
-lemma Suc_of_num [numeral]: "Suc (of_num n) = of_num (n + 1)"
+lemma Suc_of_num [numeral]: "Suc (of_num n) = of_num (n + One)"
unfolding of_num_plus_one [symmetric] by simp
lemma nat_number:
"1 = Suc 0"
- "of_num 1 = Suc 0"
- "of_num (Dig0 n) = Suc (of_num (dec (Dig0 n)))"
+ "of_num One = Suc 0"
+ "of_num (Dig0 n) = Suc (of_num (DigM n))"
"of_num (Dig1 n) = Suc (of_num (Dig0 n))"
- by (simp_all add: of_num.simps Dig_dec_plus_one Suc_of_num)
+ by (simp_all add: of_num.simps DigM_plus_one Suc_of_num)
declare diff_0_eq_0 [numeral]
@@ -773,17 +766,17 @@
[code del]: "dup k = 2 * k"
lemma Dig_sub [code]:
- "sub 1 1 = 0"
- "sub (Dig0 m) 1 = of_num (dec (Dig0 m))"
- "sub (Dig1 m) 1 = of_num (Dig0 m)"
- "sub 1 (Dig0 n) = - of_num (dec (Dig0 n))"
- "sub 1 (Dig1 n) = - of_num (Dig0 n)"
+ "sub One One = 0"
+ "sub (Dig0 m) One = of_num (DigM m)"
+ "sub (Dig1 m) One = of_num (Dig0 m)"
+ "sub One (Dig0 n) = - of_num (DigM n)"
+ "sub One (Dig1 n) = - of_num (Dig0 n)"
"sub (Dig0 m) (Dig0 n) = dup (sub m n)"
"sub (Dig1 m) (Dig1 n) = dup (sub m n)"
"sub (Dig1 m) (Dig0 n) = dup (sub m n) + 1"
"sub (Dig0 m) (Dig1 n) = dup (sub m n) - 1"
apply (simp_all add: dup_def algebra_simps)
- apply (simp_all add: of_num_plus Dig_one_plus_dec)[4]
+ apply (simp_all add: of_num_plus one_plus_DigM)[4]
apply (simp_all add: of_num.simps)
done
@@ -805,7 +798,7 @@
by rule+
lemma one_int_code [code]:
- "1 = Pls 1"
+ "1 = Pls One"
by (simp add: of_num_one)
lemma plus_int_code [code]:
--- a/src/HOL/ex/ThreeDivides.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOL/ex/ThreeDivides.thy Thu Feb 26 11:21:29 2009 +0000
@@ -187,9 +187,8 @@
"nd = nlen (m div 10) \<Longrightarrow>
m div 10 = (\<Sum>x<nd. m div 10 div 10^x mod 10 * 10^x)"
by blast
- have "\<exists>c. m = 10*(m div 10) + c \<and> c < 10" by presburger
- then obtain c where mexp: "m = 10*(m div 10) + c \<and> c < 10" ..
- then have cdef: "c = m mod 10" by arith
+ obtain c where mexp: "m = 10*(m div 10) + c \<and> c < 10"
+ and cdef: "c = m mod 10" by simp
show "m = (\<Sum>x<nlen m. m div 10^x mod 10 * 10^x)"
proof -
from `Suc nd = nlen m`
--- a/src/HOLCF/ConvexPD.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOLCF/ConvexPD.thy Thu Feb 26 11:21:29 2009 +0000
@@ -291,22 +291,26 @@
apply (simp add: PDPlus_commute)
done
-lemma convex_plus_absorb: "xs +\<natural> xs = xs"
+lemma convex_plus_absorb [simp]: "xs +\<natural> xs = xs"
apply (induct xs rule: convex_pd.principal_induct, simp)
apply (simp add: PDPlus_absorb)
done
-interpretation aci_convex_plus!: ab_semigroup_idem_mult "op +\<natural>"
- proof qed (rule convex_plus_assoc convex_plus_commute convex_plus_absorb)+
+lemma convex_plus_left_commute: "xs +\<natural> (ys +\<natural> zs) = ys +\<natural> (xs +\<natural> zs)"
+by (rule mk_left_commute
+ [of "op +\<natural>", OF convex_plus_assoc convex_plus_commute])
-lemma convex_plus_left_commute: "xs +\<natural> (ys +\<natural> zs) = ys +\<natural> (xs +\<natural> zs)"
-by (rule aci_convex_plus.mult_left_commute)
+lemma convex_plus_left_absorb [simp]: "xs +\<natural> (xs +\<natural> ys) = xs +\<natural> ys"
+by (simp only: convex_plus_assoc [symmetric] convex_plus_absorb)
-lemma convex_plus_left_absorb: "xs +\<natural> (xs +\<natural> ys) = xs +\<natural> ys"
-by (rule aci_convex_plus.mult_left_idem)
-(*
-lemmas convex_plus_aci = aci_convex_plus.mult_ac_idem
-*)
+text {* Useful for @{text "simp add: convex_plus_ac"} *}
+lemmas convex_plus_ac =
+ convex_plus_assoc convex_plus_commute convex_plus_left_commute
+
+text {* Useful for @{text "simp only: convex_plus_aci"} *}
+lemmas convex_plus_aci =
+ convex_plus_ac convex_plus_absorb convex_plus_left_absorb
+
lemma convex_unit_less_plus_iff [simp]:
"{x}\<natural> \<sqsubseteq> ys +\<natural> zs \<longleftrightarrow> {x}\<natural> \<sqsubseteq> ys \<and> {x}\<natural> \<sqsubseteq> zs"
apply (rule iffI)
@@ -413,7 +417,7 @@
apply unfold_locales
apply (simp add: convex_plus_assoc)
apply (simp add: convex_plus_commute)
-apply (simp add: convex_plus_absorb eta_cfun)
+apply (simp add: eta_cfun)
done
lemma convex_bind_basis_simps [simp]:
--- a/src/HOLCF/IsaMakefile Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOLCF/IsaMakefile Thu Feb 26 11:21:29 2009 +0000
@@ -89,6 +89,7 @@
$(LOG)/HOLCF-ex.gz: $(OUT)/HOLCF ex/Stream.thy ex/Dagstuhl.thy \
ex/Dnat.thy ex/Fix2.thy ex/Focus_ex.thy ex/Hoare.thy ex/Loop.thy \
+ ex/Powerdomain_ex.thy \
ex/ROOT.ML ex/Fixrec_ex.thy ../HOL/Library/Nat_Infinity.thy
@$(ISABELLE_TOOL) usedir $(OUT)/HOLCF ex
--- a/src/HOLCF/LowerPD.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOLCF/LowerPD.thy Thu Feb 26 11:21:29 2009 +0000
@@ -245,22 +245,25 @@
apply (simp add: PDPlus_commute)
done
-lemma lower_plus_absorb: "xs +\<flat> xs = xs"
+lemma lower_plus_absorb [simp]: "xs +\<flat> xs = xs"
apply (induct xs rule: lower_pd.principal_induct, simp)
apply (simp add: PDPlus_absorb)
done
-interpretation aci_lower_plus!: ab_semigroup_idem_mult "op +\<flat>"
- proof qed (rule lower_plus_assoc lower_plus_commute lower_plus_absorb)+
+lemma lower_plus_left_commute: "xs +\<flat> (ys +\<flat> zs) = ys +\<flat> (xs +\<flat> zs)"
+by (rule mk_left_commute [of "op +\<flat>", OF lower_plus_assoc lower_plus_commute])
-lemma lower_plus_left_commute: "xs +\<flat> (ys +\<flat> zs) = ys +\<flat> (xs +\<flat> zs)"
-by (rule aci_lower_plus.mult_left_commute)
+lemma lower_plus_left_absorb [simp]: "xs +\<flat> (xs +\<flat> ys) = xs +\<flat> ys"
+by (simp only: lower_plus_assoc [symmetric] lower_plus_absorb)
-lemma lower_plus_left_absorb: "xs +\<flat> (xs +\<flat> ys) = xs +\<flat> ys"
-by (rule aci_lower_plus.mult_left_idem)
-(*
-lemmas lower_plus_aci = aci_lower_plus.mult_ac_idem
-*)
+text {* Useful for @{text "simp add: lower_plus_ac"} *}
+lemmas lower_plus_ac =
+ lower_plus_assoc lower_plus_commute lower_plus_left_commute
+
+text {* Useful for @{text "simp only: lower_plus_aci"} *}
+lemmas lower_plus_aci =
+ lower_plus_ac lower_plus_absorb lower_plus_left_absorb
+
lemma lower_plus_less1: "xs \<sqsubseteq> xs +\<flat> ys"
apply (induct xs ys rule: lower_pd.principal_induct2, simp, simp)
apply (simp add: PDPlus_lower_less)
@@ -315,14 +318,8 @@
lower_plus_less_iff
lower_unit_less_plus_iff
-lemma fooble:
- fixes f :: "'a::po \<Rightarrow> 'b::po"
- assumes f: "\<And>x y. f x \<sqsubseteq> f y \<longleftrightarrow> x \<sqsubseteq> y"
- shows "f x = f y \<longleftrightarrow> x = y"
-unfolding po_eq_conv by (simp add: f)
-
lemma lower_unit_eq_iff [simp]: "{x}\<flat> = {y}\<flat> \<longleftrightarrow> x = y"
-by (rule lower_unit_less_iff [THEN fooble])
+by (simp add: po_eq_conv)
lemma lower_unit_strict [simp]: "{\<bottom>}\<flat> = \<bottom>"
unfolding inst_lower_pd_pcpo Rep_compact_bot [symmetric] by simp
@@ -399,7 +396,7 @@
apply unfold_locales
apply (simp add: lower_plus_assoc)
apply (simp add: lower_plus_commute)
-apply (simp add: lower_plus_absorb eta_cfun)
+apply (simp add: eta_cfun)
done
lemma lower_bind_basis_simps [simp]:
--- a/src/HOLCF/UpperPD.thy Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOLCF/UpperPD.thy Thu Feb 26 11:21:29 2009 +0000
@@ -243,22 +243,25 @@
apply (simp add: PDPlus_commute)
done
-lemma upper_plus_absorb: "xs +\<sharp> xs = xs"
+lemma upper_plus_absorb [simp]: "xs +\<sharp> xs = xs"
apply (induct xs rule: upper_pd.principal_induct, simp)
apply (simp add: PDPlus_absorb)
done
-interpretation aci_upper_plus!: ab_semigroup_idem_mult "op +\<sharp>"
- proof qed (rule upper_plus_assoc upper_plus_commute upper_plus_absorb)+
+lemma upper_plus_left_commute: "xs +\<sharp> (ys +\<sharp> zs) = ys +\<sharp> (xs +\<sharp> zs)"
+by (rule mk_left_commute [of "op +\<sharp>", OF upper_plus_assoc upper_plus_commute])
-lemma upper_plus_left_commute: "xs +\<sharp> (ys +\<sharp> zs) = ys +\<sharp> (xs +\<sharp> zs)"
-by (rule aci_upper_plus.mult_left_commute)
+lemma upper_plus_left_absorb [simp]: "xs +\<sharp> (xs +\<sharp> ys) = xs +\<sharp> ys"
+by (simp only: upper_plus_assoc [symmetric] upper_plus_absorb)
-lemma upper_plus_left_absorb: "xs +\<sharp> (xs +\<sharp> ys) = xs +\<sharp> ys"
-by (rule aci_upper_plus.mult_left_idem)
-(*
-lemmas upper_plus_aci = aci_upper_plus.mult_ac_idem
-*)
+text {* Useful for @{text "simp add: upper_plus_ac"} *}
+lemmas upper_plus_ac =
+ upper_plus_assoc upper_plus_commute upper_plus_left_commute
+
+text {* Useful for @{text "simp only: upper_plus_aci"} *}
+lemmas upper_plus_aci =
+ upper_plus_ac upper_plus_absorb upper_plus_left_absorb
+
lemma upper_plus_less1: "xs +\<sharp> ys \<sqsubseteq> xs"
apply (induct xs ys rule: upper_pd.principal_induct2, simp, simp)
apply (simp add: PDPlus_upper_less)
@@ -388,7 +391,7 @@
apply unfold_locales
apply (simp add: upper_plus_assoc)
apply (simp add: upper_plus_commute)
-apply (simp add: upper_plus_absorb eta_cfun)
+apply (simp add: eta_cfun)
done
lemma upper_bind_basis_simps [simp]:
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOLCF/ex/Powerdomain_ex.thy Thu Feb 26 11:21:29 2009 +0000
@@ -0,0 +1,123 @@
+(* Title: HOLCF/ex/Powerdomain_ex.thy
+ Author: Brian Huffman
+*)
+
+header {* Powerdomain examples *}
+
+theory Powerdomain_ex
+imports HOLCF
+begin
+
+defaultsort bifinite
+
+subsection {* Monadic sorting example *}
+
+domain ordering = LT | EQ | GT
+
+declare ordering.rews [simp]
+
+definition
+ compare :: "int lift \<rightarrow> int lift \<rightarrow> ordering" where
+ "compare = (FLIFT x y. if x < y then LT else if x = y then EQ else GT)"
+
+definition
+ is_le :: "int lift \<rightarrow> int lift \<rightarrow> tr" where
+ "is_le = (\<Lambda> x y. case compare\<cdot>x\<cdot>y of LT \<Rightarrow> TT | EQ \<Rightarrow> TT | GT \<Rightarrow> FF)"
+
+definition
+ is_less :: "int lift \<rightarrow> int lift \<rightarrow> tr" where
+ "is_less = (\<Lambda> x y. case compare\<cdot>x\<cdot>y of LT \<Rightarrow> TT | EQ \<Rightarrow> FF | GT \<Rightarrow> FF)"
+
+definition
+ r1 :: "(int lift \<times> 'a) \<rightarrow> (int lift \<times> 'a) \<rightarrow> tr convex_pd" where
+ "r1 = (\<Lambda> \<langle>x,_\<rangle> \<langle>y,_\<rangle>. case compare\<cdot>x\<cdot>y of
+ LT \<Rightarrow> {TT}\<natural> |
+ EQ \<Rightarrow> {TT, FF}\<natural> |
+ GT \<Rightarrow> {FF}\<natural>)"
+
+definition
+ r2 :: "(int lift \<times> 'a) \<rightarrow> (int lift \<times> 'a) \<rightarrow> tr convex_pd" where
+ "r2 = (\<Lambda> \<langle>x,_\<rangle> \<langle>y,_\<rangle>. {is_le\<cdot>x\<cdot>y, is_less\<cdot>x\<cdot>y}\<natural>)"
+
+lemma r1_r2: "r1\<cdot>\<langle>x,a\<rangle>\<cdot>\<langle>y,b\<rangle> = (r2\<cdot>\<langle>x,a\<rangle>\<cdot>\<langle>y,b\<rangle> :: tr convex_pd)"
+apply (simp add: r1_def r2_def)
+apply (simp add: is_le_def is_less_def)
+apply (cases "compare\<cdot>x\<cdot>y" rule: ordering.casedist)
+apply simp_all
+done
+
+
+subsection {* Picking a leaf from a tree *}
+
+domain 'a tree =
+ Node (lazy "'a tree") (lazy "'a tree") |
+ Leaf (lazy "'a")
+
+consts
+ mirror :: "'a tree \<rightarrow> 'a tree"
+ pick :: "'a tree \<rightarrow> 'a convex_pd"
+
+fixrec
+ mirror_Leaf: "mirror\<cdot>(Leaf\<cdot>a) = Leaf\<cdot>a"
+ mirror_Node: "mirror\<cdot>(Node\<cdot>l\<cdot>r) = Node\<cdot>(mirror\<cdot>r)\<cdot>(mirror\<cdot>l)"
+
+fixpat
+ mirror_strict [simp]: "mirror\<cdot>\<bottom>"
+
+fixrec
+ pick_Leaf: "pick\<cdot>(Leaf\<cdot>a) = {a}\<natural>"
+ pick_Node: "pick\<cdot>(Node\<cdot>l\<cdot>r) = pick\<cdot>l +\<natural> pick\<cdot>r"
+
+fixpat
+ pick_strict [simp]: "pick\<cdot>\<bottom>"
+
+lemma pick_mirror: "pick\<cdot>(mirror\<cdot>t) = pick\<cdot>t"
+by (induct t rule: tree.ind)
+ (simp_all add: convex_plus_ac)
+
+consts
+ tree1 :: "int lift tree"
+ tree2 :: "int lift tree"
+ tree3 :: "int lift tree"
+
+fixrec
+ "tree1 = Node\<cdot>(Node\<cdot>(Leaf\<cdot>(Def 1))\<cdot>(Leaf\<cdot>(Def 2)))
+ \<cdot>(Node\<cdot>(Leaf\<cdot>(Def 3))\<cdot>(Leaf\<cdot>(Def 4)))"
+
+fixrec
+ "tree2 = Node\<cdot>(Node\<cdot>(Leaf\<cdot>(Def 1))\<cdot>(Leaf\<cdot>(Def 2)))
+ \<cdot>(Node\<cdot>\<bottom>\<cdot>(Leaf\<cdot>(Def 4)))"
+
+fixrec
+ "tree3 = Node\<cdot>(Node\<cdot>(Leaf\<cdot>(Def 1))\<cdot>tree3)
+ \<cdot>(Node\<cdot>(Leaf\<cdot>(Def 3))\<cdot>(Leaf\<cdot>(Def 4)))"
+
+declare tree1_simps tree2_simps tree3_simps [simp del]
+
+lemma pick_tree1:
+ "pick\<cdot>tree1 = {Def 1, Def 2, Def 3, Def 4}\<natural>"
+apply (subst tree1_simps)
+apply simp
+apply (simp add: convex_plus_ac)
+done
+
+lemma pick_tree2:
+ "pick\<cdot>tree2 = {Def 1, Def 2, \<bottom>, Def 4}\<natural>"
+apply (subst tree2_simps)
+apply simp
+apply (simp add: convex_plus_ac)
+done
+
+lemma pick_tree3:
+ "pick\<cdot>tree3 = {Def 1, \<bottom>, Def 3, Def 4}\<natural>"
+apply (subst tree3_simps)
+apply simp
+apply (induct rule: tree3_induct)
+apply simp
+apply simp
+apply (simp add: convex_plus_ac)
+apply simp
+apply (simp add: convex_plus_ac)
+done
+
+end
--- a/src/HOLCF/ex/ROOT.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/HOLCF/ex/ROOT.ML Thu Feb 26 11:21:29 2009 +0000
@@ -1,8 +1,7 @@
(* Title: HOLCF/ex/ROOT.ML
- ID: $Id$
Misc HOLCF examples.
*)
use_thys ["Dnat", "Stream", "Dagstuhl", "Focus_ex", "Fix2", "Hoare",
- "Loop", "Fixrec_ex"];
+ "Loop", "Fixrec_ex", "Powerdomain_ex"];
--- a/src/Pure/Isar/class_target.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/Pure/Isar/class_target.ML Thu Feb 26 11:21:29 2009 +0000
@@ -493,7 +493,7 @@
fun init_instantiation (tycos, vs, sort) thy =
let
val _ = if null tycos then error "At least one arity must be given" else ();
- val params = these_params thy sort;
+ val params = these_params thy (filter (can (AxClass.get_info thy)) sort);
fun get_param tyco (param, (_, (c, ty))) =
if can (AxClass.param_of_inst thy) (c, tyco)
then NONE else SOME ((c, tyco),
@@ -513,7 +513,8 @@
| SOME ts' => SOME (ts', ctxt);
fun improve (c, ty) = case AxClass.inst_tyco_of thy (c, ty)
of SOME tyco => (case AList.lookup (op =) inst_params (c, tyco)
- of SOME (_, ty') => if Type.raw_instance (ty', ty) then SOME (ty, ty') else NONE
+ of SOME (_, ty') => if Type.typ_instance (Sign.tsig_of thy) (ty', ty)
+ then SOME (ty, ty') else NONE
| NONE => NONE)
| NONE => NONE;
in
@@ -523,8 +524,7 @@
|> fold (Variable.declare_typ o TFree) vs
|> fold (Variable.declare_names o Free o snd) inst_params
|> (Overloading.map_improvable_syntax o apfst)
- (fn ((_, _), ((_, subst), unchecks)) =>
- ((primary_constraints, []), (((improve, K NONE), false), [])))
+ (K ((primary_constraints, []), (((improve, K NONE), false), [])))
|> Overloading.add_improvable_syntax
|> Context.proof_map (Syntax.add_term_check 0 "resorting" resort_check)
|> synchronize_inst_syntax
--- a/src/Pure/Isar/code.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/Pure/Isar/code.ML Thu Feb 26 11:21:29 2009 +0000
@@ -35,7 +35,7 @@
val these_raw_eqns: theory -> string -> (thm * bool) list
val get_datatype: theory -> string -> ((string * sort) list * (string * typ list) list)
val get_datatype_of_constr: theory -> string -> string option
- val get_case_data: theory -> string -> (int * string list) option
+ val get_case_scheme: theory -> string -> (int * (int * string list)) option
val is_undefined: theory -> string -> bool
val default_typscheme: theory -> string -> (string * sort) list * typ
@@ -111,7 +111,7 @@
(** logical and syntactical specification of executable code **)
-(* defining equations *)
+(* code equations *)
type eqns = bool * (thm * bool) list lazy;
(*default flag, theorems with linear flag (perhaps lazy)*)
@@ -136,7 +136,7 @@
Pattern.matchess thy (args, (map incr_idx o curry Library.take (length args)) args');
fun drop (thm', linear') = if (linear orelse not linear')
andalso matches_args (args_of thm') then
- (warning ("Code generator: dropping redundant defining equation\n" ^ Display.string_of_thm thm'); true)
+ (warning ("Code generator: dropping redundant code equation\n" ^ Display.string_of_thm thm'); true)
else false;
in (thm, linear) :: filter_out drop thms end;
@@ -157,7 +157,7 @@
(*with explicit history*),
dtyps: ((serial * ((string * sort) list * (string * typ list) list)) list) Symtab.table
(*with explicit history*),
- cases: (int * string list) Symtab.table * unit Symtab.table
+ cases: (int * (int * string list)) Symtab.table * unit Symtab.table
};
fun mk_spec ((concluded_history, eqns), (dtyps, cases)) =
@@ -409,7 +409,7 @@
in
(Pretty.writeln o Pretty.chunks) [
Pretty.block (
- Pretty.str "defining equations:"
+ Pretty.str "code equations:"
:: Pretty.fbrk
:: (Pretty.fbreaks o map pretty_eqn) eqns
),
@@ -452,7 +452,7 @@
val ty1 :: tys = map (snd o Code_Unit.const_typ_eqn) thms';
fun unify ty env = Sign.typ_unify thy (ty1, ty) env
handle Type.TUNIFY =>
- error ("Type unificaton failed, while unifying defining equations\n"
+ error ("Type unificaton failed, while unifying code equations\n"
^ (cat_lines o map Display.string_of_thm) thms
^ "\nwith types\n"
^ (cat_lines o map (Code_Unit.string_of_typ thy)) (ty1 :: tys));
@@ -463,7 +463,7 @@
fun check_linear (eqn as (thm, linear)) =
if linear then eqn else Code_Unit.bad_thm
- ("Duplicate variables on left hand side of defining equation:\n"
+ ("Duplicate variables on left hand side of code equation:\n"
^ Display.string_of_thm thm);
fun mk_eqn thy linear =
@@ -489,7 +489,7 @@
fun retrieve_algebra thy operational =
Sorts.subalgebra (Syntax.pp_global thy) operational
- (arity_constraints thy (Sign.classes_of thy))
+ (SOME o arity_constraints thy (Sign.classes_of thy))
(Sign.classes_of thy);
in
@@ -525,22 +525,13 @@
then SOME tyco else NONE
| _ => NONE;
-fun get_constr_typ thy c =
- case get_datatype_of_constr thy c
- of SOME tyco => let
- val (vs, cos) = get_datatype thy tyco;
- val SOME tys = AList.lookup (op =) cos c;
- val ty = tys ---> Type (tyco, map TFree vs);
- in SOME (Logic.varifyT ty) end
- | NONE => NONE;
-
fun recheck_eqn thy = Code_Unit.error_thm
(Code_Unit.assert_linear (is_some o get_datatype_of_constr thy) o apfst (Code_Unit.assert_eqn thy));
fun recheck_eqns_const thy c eqns =
let
fun cert (eqn as (thm, _)) = if c = Code_Unit.const_eqn thm
- then eqn else error ("Wrong head of defining equation,\nexpected constant "
+ then eqn else error ("Wrong head of code equation,\nexpected constant "
^ Code_Unit.string_of_const thy c ^ "\n" ^ Display.string_of_thm thm)
in map (cert o recheck_eqn thy) eqns end;
@@ -554,11 +545,11 @@
let
val c = Code_Unit.const_eqn thm;
val _ = if not default andalso (is_some o AxClass.class_of_param thy) c
- then error ("Rejected polymorphic equation for overloaded constant:\n"
+ then error ("Rejected polymorphic code equation for overloaded constant:\n"
^ Display.string_of_thm thm)
else ();
val _ = if not default andalso (is_some o get_datatype_of_constr thy) c
- then error ("Rejected equation for datatype constructor:\n"
+ then error ("Rejected code equation for datatype constructor:\n"
^ Display.string_of_thm thm)
else ();
in change_eqns false c (add_thm thy default (thm, linear)) thy end
@@ -583,7 +574,7 @@
fun del_eqns c = change_eqns true c (K (false, Lazy.value []));
-val get_case_data = Symtab.lookup o fst o the_cases o the_exec;
+fun get_case_scheme thy = Symtab.lookup ((fst o the_cases o the_exec) thy);
val is_undefined = Symtab.defined o snd o the_cases o the_exec;
@@ -593,11 +584,17 @@
let
val cs = map (fn c_ty as (_, ty) => (AxClass.unoverload_const thy c_ty, ty)) raw_cs;
val (tyco, vs_cos) = Code_Unit.constrset_of_consts thy cs;
+ val old_cs = (map fst o snd o get_datatype thy) tyco;
+ fun drop_outdated_cases cases = fold Symtab.delete_safe
+ (Symtab.fold (fn (c, (_, (_, cos))) =>
+ if exists (member (op =) old_cs) cos
+ then insert (op =) c else I) cases []) cases;
in
thy
|> map_exec_purge NONE
((map_dtyps o Symtab.map_default (tyco, [])) (cons (serial (), vs_cos))
- #> map_eqns (fold (Symtab.delete_safe o fst) cs))
+ #> map_eqns (fold (Symtab.delete_safe o fst) cs)
+ #> (map_cases o apfst) drop_outdated_cases)
|> TypeInterpretation.data (tyco, serial ())
end;
@@ -611,10 +608,12 @@
fun add_case thm thy =
let
- val entry as (c, _) = Code_Unit.case_cert thm;
- in
- (map_exec_purge (SOME [c]) o map_cases o apfst) (Symtab.update entry) thy
- end;
+ val (c, (k, case_pats)) = Code_Unit.case_cert thm;
+ val _ = case filter (is_none o get_datatype_of_constr thy) case_pats
+ of [] => ()
+ | cs => error ("Non-constructor(s) in case certificate: " ^ commas (map quote cs));
+ val entry = (1 + Int.max (1, length case_pats), (k, case_pats))
+ in (map_exec_purge (SOME [c]) o map_cases o apfst) (Symtab.update (c, entry)) thy end;
fun add_undefined c thy =
(map_exec_purge (SOME [c]) o map_cases o apsnd) (Symtab.update (c, ())) thy;
@@ -727,18 +726,16 @@
fun default_typscheme thy c =
let
- val typscheme = curry (Code_Unit.typscheme thy) c
- val the_const_type = snd o dest_Const o TermSubst.zero_var_indexes
- o curry Const "" o Sign.the_const_type thy;
+ fun the_const_typscheme c = (curry (Code_Unit.typscheme thy) c o snd o dest_Const
+ o TermSubst.zero_var_indexes o curry Const "" o Sign.the_const_type thy) c;
+ fun strip_sorts (vs, ty) = (map (fn (v, _) => (v, [])) vs, ty);
in case AxClass.class_of_param thy c
- of SOME class => the_const_type c
- |> Term.map_type_tvar (K (TVar ((Name.aT, 0), [class])))
- |> typscheme
- | NONE => (case get_constr_typ thy c
- of SOME ty => typscheme ty
- | NONE => (case get_eqns thy c
- of (thm, _) :: _ => snd (Code_Unit.head_eqn thy (Drule.zero_var_indexes thm))
- | [] => typscheme (the_const_type c))) end;
+ of SOME class => ([(Name.aT, [class])], snd (the_const_typscheme c))
+ | NONE => if is_some (get_datatype_of_constr thy c)
+ then strip_sorts (the_const_typscheme c)
+ else case get_eqns thy c
+ of (thm, _) :: _ => snd (Code_Unit.head_eqn thy (Drule.zero_var_indexes thm))
+ | [] => strip_sorts (the_const_typscheme c) end;
end; (*local*)
--- a/src/Pure/Isar/code_unit.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/Pure/Isar/code_unit.ML Thu Feb 26 11:21:29 2009 +0000
@@ -34,7 +34,7 @@
val constrset_of_consts: theory -> (string * typ) list
-> string * ((string * sort) list * (string * typ list) list)
- (*defining equations*)
+ (*code equations*)
val assert_eqn: theory -> thm -> thm
val mk_eqn: theory -> thm -> thm * bool
val assert_linear: (string -> bool) -> thm * bool -> thm * bool
@@ -76,10 +76,11 @@
fun typscheme thy (c, ty) =
let
- fun dest (TVar ((v, 0), sort)) = (v, sort)
+ val ty' = Logic.unvarifyT ty;
+ fun dest (TFree (v, sort)) = (v, sort)
| dest ty = error ("Illegal type parameter in type scheme: " ^ Syntax.string_of_typ_global thy ty);
- val vs = map dest (Sign.const_typargs thy (c, ty));
- in (vs, ty) end;
+ val vs = map dest (Sign.const_typargs thy (c, ty'));
+ in (vs, Type.strip_sorts ty') end;
fun inst_thm thy tvars' thm =
let
@@ -313,10 +314,10 @@
val ((tyco, sorts), cs'') = fold add cs' (apsnd single c');
val vs = Name.names Name.context Name.aT sorts;
val cs''' = map (inst vs) cs'';
- in (tyco, (vs, cs''')) end;
+ in (tyco, (vs, rev cs''')) end;
-(* defining equations *)
+(* code equations *)
fun assert_eqn thy thm =
let
@@ -351,7 +352,7 @@
^ Display.string_of_thm thm)
| check 0 (Var _) = ()
| check _ (Var _) = bad_thm
- ("Variable with application on left hand side of defining equation\n"
+ ("Variable with application on left hand side of code equation\n"
^ Display.string_of_thm thm)
| check n (t1 $ t2) = (check (n+1) t1; check 0 t2)
| check n (Const (_, ty)) = if n <> (length o fst o strip_type) ty
@@ -363,7 +364,7 @@
val ty_decl = Sign.the_const_type thy c;
val _ = if Sign.typ_equiv thy (Type.strip_sorts ty_decl, Type.strip_sorts ty)
then () else bad_thm ("Type\n" ^ string_of_typ thy ty
- ^ "\nof defining equation\n"
+ ^ "\nof code equation\n"
^ Display.string_of_thm thm
^ "\nis incompatible with declared function type\n"
^ string_of_typ thy ty_decl)
@@ -388,7 +389,7 @@
fun assert_linear is_cons (thm, false) = (thm, false)
| assert_linear is_cons (thm, true) = if snd (add_linear (assert_pat is_cons thm)) then (thm, true)
else bad_thm
- ("Duplicate variables on left hand side of defining equation:\n"
+ ("Duplicate variables on left hand side of code equation:\n"
^ Display.string_of_thm thm);
--- a/src/Pure/Isar/theory_target.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/Pure/Isar/theory_target.ML Thu Feb 26 11:21:29 2009 +0000
@@ -13,7 +13,7 @@
val begin: string -> Proof.context -> local_theory
val context: xstring -> theory -> local_theory
val instantiation: string list * (string * sort) list * sort -> theory -> local_theory
- val instantiation_cmd: xstring list * sort * xstring -> theory -> local_theory
+ val instantiation_cmd: xstring list * xstring list * xstring -> theory -> local_theory
val overloading: (string * (string * typ) * bool) list -> theory -> local_theory
val overloading_cmd: (string * string * bool) list -> theory -> local_theory
end;
--- a/src/Pure/sorts.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/Pure/sorts.ML Thu Feb 26 11:21:29 2009 +0000
@@ -46,9 +46,7 @@
val add_arities: Pretty.pp -> string * (class * sort list) list -> algebra -> algebra
val empty_algebra: algebra
val merge_algebra: Pretty.pp -> algebra * algebra -> algebra
- val classrels_of: algebra -> (class * class list) list
- val instances_of: algebra -> (string * class) list
- val subalgebra: Pretty.pp -> (class -> bool) -> (class * string -> sort list)
+ val subalgebra: Pretty.pp -> (class -> bool) -> (class * string -> sort list option)
-> algebra -> (sort -> sort) * algebra
type class_error
val class_error: Pretty.pp -> class_error -> string
@@ -302,19 +300,14 @@
(* algebra projections *)
-fun classrels_of (Algebra {classes, ...}) =
- map (fn [c] => (c, Graph.imm_succs classes c)) (rev (Graph.strong_conn classes));
-
-fun instances_of (Algebra {arities, ...}) =
- Symtab.fold (fn (a, cs) => append (map (pair a o fst) cs)) arities [];
-
fun subalgebra pp P sargs (algebra as Algebra {classes, arities}) =
let
val restrict_sort = minimize_sort algebra o filter P o Graph.all_succs classes;
fun restrict_arity tyco (c, (_, Ss)) =
- if P c then
- SOME (c, (c, Ss |> map2 (curry (inter_sort algebra)) (sargs (c, tyco))
+ if P c then case sargs (c, tyco)
+ of SOME sorts => SOME (c, (c, Ss |> map2 (curry (inter_sort algebra)) sorts
|> map restrict_sort))
+ | NONE => NONE
else NONE;
val classes' = classes |> Graph.subgraph P;
val arities' = arities |> Symtab.map' (map_filter o restrict_arity);
--- a/src/Tools/auto_solve.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/Tools/auto_solve.ML Thu Feb 26 11:21:29 2009 +0000
@@ -23,7 +23,7 @@
structure FT = FindTheorems;
val auto = ref false;
- val auto_time_limit = ref 5000;
+ val auto_time_limit = ref 2500;
fun seek_solution int state = let
val ctxt = Proof.context_of state;
--- a/src/Tools/code/code_funcgr.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/Tools/code/code_funcgr.ML Thu Feb 26 11:21:29 2009 +0000
@@ -1,8 +1,7 @@
(* Title: Tools/code/code_funcgr.ML
- ID: $Id$
Author: Florian Haftmann, TU Muenchen
-Retrieving, normalizing and structuring defining equations in graph
+Retrieving, normalizing and structuring code equations in graph
with explicit dependencies.
*)
@@ -318,13 +317,13 @@
in
val _ =
- OuterSyntax.improper_command "code_thms" "print system of defining equations for code" OuterKeyword.diag
+ OuterSyntax.improper_command "code_thms" "print system of code equations for code" OuterKeyword.diag
(Scan.repeat P.term_group
>> (fn cs => Toplevel.no_timing o Toplevel.unknown_theory
o Toplevel.keep ((fn thy => code_thms_cmd thy cs) o Toplevel.theory_of)));
val _ =
- OuterSyntax.improper_command "code_deps" "visualize dependencies of defining equations for code" OuterKeyword.diag
+ OuterSyntax.improper_command "code_deps" "visualize dependencies of code equations for code" OuterKeyword.diag
(Scan.repeat P.term_group
>> (fn cs => Toplevel.no_timing o Toplevel.unknown_theory
o Toplevel.keep ((fn thy => code_deps_cmd thy cs) o Toplevel.theory_of)));
--- a/src/Tools/code/code_funcgr_new.ML Thu Feb 26 11:18:40 2009 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,414 +0,0 @@
-(* Title: Tools/code/code_funcgr.ML
- ID: $Id$
- Author: Florian Haftmann, TU Muenchen
-
-Retrieving, well-sorting and structuring defining equations in graph
-with explicit dependencies.
-*)
-
-signature CODE_FUNCGR =
-sig
- type T
- val eqns: T -> string -> (thm * bool) list
- val typ: T -> string -> (string * sort) list * typ
- val all: T -> string list
- val pretty: theory -> T -> Pretty.T
- val make: theory -> string list
- -> ((sort -> sort) * Sorts.algebra) * T
- val eval_conv: theory
- -> (term -> term * (((sort -> sort) * Sorts.algebra) -> T -> thm)) -> cterm -> thm
- val eval_term: theory
- -> (term -> term * (((sort -> sort) * Sorts.algebra) -> T -> 'a)) -> term -> 'a
-end
-
-structure Code_Funcgr : CODE_FUNCGR =
-struct
-
-(** the graph type **)
-
-type T = (((string * sort) list * typ) * (thm * bool) list) Graph.T;
-
-fun eqns funcgr =
- these o Option.map snd o try (Graph.get_node funcgr);
-
-fun typ funcgr =
- fst o Graph.get_node funcgr;
-
-fun all funcgr = Graph.keys funcgr;
-
-fun pretty thy funcgr =
- AList.make (snd o Graph.get_node funcgr) (Graph.keys funcgr)
- |> (map o apfst) (Code_Unit.string_of_const thy)
- |> sort (string_ord o pairself fst)
- |> map (fn (s, thms) =>
- (Pretty.block o Pretty.fbreaks) (
- Pretty.str s
- :: map (Display.pretty_thm o fst) thms
- ))
- |> Pretty.chunks;
-
-
-(** generic combinators **)
-
-fun fold_consts f thms =
- thms
- |> maps (op :: o swap o apfst (snd o strip_comb) o Logic.dest_equals o Thm.plain_prop_of)
- |> (fold o fold_aterms) (fn Const c => f c | _ => I);
-
-fun consts_of (const, []) = []
- | consts_of (const, thms as _ :: _) =
- let
- fun the_const (c, _) = if c = const then I else insert (op =) c
- in fold_consts the_const (map fst thms) [] end;
-
-
-(** graph algorithm **)
-
-(* some nonsense -- FIXME *)
-
-fun lhs_rhss_of thy c =
- let
- val eqns = Code.these_eqns thy c
- |> burrow_fst (Code_Unit.norm_args thy)
- |> burrow_fst (Code_Unit.norm_varnames thy Code_Name.purify_tvar Code_Name.purify_var);
- val (lhs, _) = case eqns of [] => Code.default_typscheme thy c
- | ((thm, _) :: _) => (snd o Code_Unit.head_eqn thy) thm;
- val rhss = fold_consts (fn (c, ty) =>
- insert (op =) (c, Sign.const_typargs thy (c, Logic.unvarifyT ty))) (map fst eqns) [];
- in (lhs, rhss) end;
-
-fun inst_params thy tyco class =
- map (fn (c, _) => AxClass.param_of_inst thy (c, tyco))
- ((#params o AxClass.get_info thy) class);
-
-fun complete_proper_sort thy sort =
- Sign.complete_sort thy sort |> filter (can (AxClass.get_info thy));
-
-fun minimal_proper_sort thy sort =
- complete_proper_sort thy sort |> Sign.minimize_sort thy;
-
-fun dicts_of thy algebra (T, sort) =
- let
- fun class_relation (x, _) _ = x;
- fun type_constructor tyco xs class =
- inst_params thy tyco class @ (maps o maps) fst xs;
- fun type_variable (TFree (_, sort)) = map (pair []) sort;
- in
- flat (Sorts.of_sort_derivation (Syntax.pp_global thy) algebra
- { class_relation = class_relation, type_constructor = type_constructor,
- type_variable = type_variable } (T, minimal_proper_sort thy sort)
- handle Sorts.CLASS_ERROR _ => [] (*permissive!*))
- end;
-
-
-(* data structures *)
-
-datatype const = Fun of string | Inst of class * string;
-
-fun const_ord (Fun c1, Fun c2) = fast_string_ord (c1, c2)
- | const_ord (Inst class_tyco1, Inst class_tyco2) =
- prod_ord fast_string_ord fast_string_ord (class_tyco1, class_tyco2)
- | const_ord (Fun _, Inst _) = LESS
- | const_ord (Inst _, Fun _) = GREATER;
-
-type var = const * int;
-
-structure Vargraph =
- GraphFun(type key = var val ord = prod_ord const_ord int_ord);
-
-datatype styp = Tyco of string * styp list | Var of var;
-
-type vardeps = const list * ((string * styp list) list * class list) Vargraph.T;
-
-
-(* computing instantiations -- FIXME does not consider existing things *)
-
-fun add_classes thy c_k new_classes vardeps =
- let
- val _ = tracing "add_classes";
- val (styps, old_classes) = Vargraph.get_node (snd vardeps) c_k;
- val diff_classes = new_classes |> subtract (op =) old_classes;
- in if null diff_classes then vardeps
- else let
- val c_ks = Vargraph.imm_succs (snd vardeps) c_k |> insert (op =) c_k;
- in
- vardeps
- |> (apsnd o Vargraph.map_node c_k o apsnd) (append diff_classes)
- |> fold (fn styp => fold (add_typmatch_inst thy styp) new_classes) styps
- |> fold (fn c_k => add_classes thy c_k diff_classes) c_ks
- end end
-and add_styp thy c_k tyco_styps vardeps =
- let
- val _ = tracing "add_styp";
- val (old_styps, classes) = Vargraph.get_node (snd vardeps) c_k;
- in if member (op =) old_styps tyco_styps then vardeps
- else
- vardeps
- |> (apsnd o Vargraph.map_node c_k o apfst) (cons tyco_styps)
- |> fold (add_typmatch_inst thy tyco_styps) classes
- end
-and add_dep thy c_k c_k' vardeps =
- let
- val _ = tracing ("add_dep " ^ makestring c_k ^ " -> " ^ makestring c_k');
- val (_, classes) = Vargraph.get_node (snd vardeps) c_k;
- in
- vardeps
- |> add_classes thy c_k' classes
- |> apsnd (Vargraph.add_edge (c_k, c_k'))
- end
-and add_typmatch_inst thy (tyco, styps) class vardeps = if can (Sign.arity_sorts thy tyco) [class]
- then vardeps
- |> tap (fn _ => tracing "add_typmatch_inst")
- |> assert thy (Inst (class, tyco))
- |> fold_index (fn (k, styp) =>
- add_typmatch thy styp (Inst (class, tyco), k)) styps
- else vardeps (*permissive!*)
-and add_typmatch thy (Var c_k') c_k vardeps =
- vardeps
- |> tap (fn _ => tracing "add_typmatch (Inst)")
- |> add_dep thy c_k c_k'
- | add_typmatch thy (Tyco tyco_styps) c_k vardeps =
- vardeps
- |> tap (fn _ => tracing "add_typmatch (Tyco)")
- |> add_styp thy c_k tyco_styps
-and add_inst thy (class, tyco) vardeps =
- let
- val _ = tracing ("add_inst " ^ tyco ^ "::" ^ class);
- val superclasses = complete_proper_sort thy
- (Sign.super_classes thy class);
- val classess = map (complete_proper_sort thy)
- (Sign.arity_sorts thy tyco [class]);
- val inst_params = inst_params thy tyco class;
- in
- vardeps
- |> fold (fn superclass => assert thy (Inst (superclass, tyco))) superclasses
- |> fold (assert thy o Fun) inst_params
- |> fold_index (fn (k, classes) =>
- apsnd (Vargraph.default_node ((Inst (class, tyco), k), ([] ,[])))
- #> add_classes thy (Inst (class, tyco), k) classes
- #> fold (fn superclass =>
- add_dep thy (Inst (superclass, tyco), k)
- (Inst (class, tyco), k)) superclasses
- #> fold (fn inst_param =>
- add_dep thy (Fun inst_param, k)
- (Inst (class, tyco), k)
- ) inst_params
- ) classess
- end
-and add_const thy c vardeps =
- let
- val _ = tracing "add_const";
- val (lhs, rhss) = lhs_rhss_of thy c;
- fun styp_of (Type (tyco, tys)) = Tyco (tyco, map styp_of tys)
- | styp_of (TFree (v, _)) = Var (Fun c, find_index (fn (v', _) => v = v') lhs);
- val rhss' = (map o apsnd o map) styp_of rhss;
- in
- vardeps
- |> fold_index (fn (k, (_, sort)) =>
- apsnd (Vargraph.default_node ((Fun c, k), ([] ,[])))
- #> add_classes thy (Fun c, k) (complete_proper_sort thy sort)) lhs
- |> fold (assert thy o Fun o fst) rhss'
- |> fold (fn (c', styps) => fold_index (fn (k', styp) =>
- add_typmatch thy styp (Fun c', k')) styps) rhss'
- end
-and assert thy c (vardeps as (asserted, _)) =
- if member (op =) asserted c then vardeps
- else case c
- of Fun const => vardeps |> apfst (cons c) |> add_const thy const
- | Inst inst => vardeps |> apfst (cons c) |> add_inst thy inst;
-
-
-(* applying instantiations *)
-
-fun algebra_of thy vardeps =
- let
- val pp = Syntax.pp_global thy;
- val thy_algebra = Sign.classes_of thy;
- val is_proper = can (AxClass.get_info thy);
- val arities = Vargraph.fold (fn ((Fun _, _), _) => I
- | ((Inst (class, tyco), k), ((_, classes), _)) =>
- AList.map_default (op =)
- ((tyco, class), replicate (Sign.arity_number thy tyco) [])
- (nth_map k (K classes))) vardeps [];
- val classrels = Sorts.classrels_of thy_algebra
- |> filter (is_proper o fst)
- |> (map o apsnd) (filter is_proper);
- fun add_arity (tyco, class) = case AList.lookup (op =) arities (tyco, class)
- of SOME sorts => Sorts.add_arities pp (tyco, [(class, sorts)])
- | NONE => if Sign.arity_number thy tyco = 0
- then (tracing (tyco ^ "::" ^ class); Sorts.add_arities pp (tyco, [(class, [])]))
- else I;
- val instances = Sorts.instances_of thy_algebra
- |> filter (is_proper o snd)
- in
- Sorts.empty_algebra
- |> fold (Sorts.add_class pp) classrels
- |> fold add_arity instances
- end;
-
-fun add_eqs thy algebra vardeps c gr =
- let
- val eqns = Code.these_eqns thy c
- |> burrow_fst (Code_Unit.norm_args thy)
- |> burrow_fst (Code_Unit.norm_varnames thy Code_Name.purify_tvar Code_Name.purify_var);
- val (vs, _) = case eqns of [] => Code.default_typscheme thy c
- | ((thm, _) :: _) => (snd o Code_Unit.head_eqn thy) thm;
- val inst = Vartab.empty |> fold_index (fn (k, (v, _)) =>
- Vartab.update ((v, 0), snd (Vargraph.get_node vardeps (Fun c, k)))) vs;
- val eqns' = eqns
- |> (map o apfst) (Code_Unit.inst_thm thy inst);
- val tyscm = case eqns' of [] => Code.default_typscheme thy c
- | ((thm, _) :: _) => (snd o Code_Unit.head_eqn thy) thm;
- val _ = tracing ("tyscm " ^ makestring (map snd (fst tyscm)));
- val rhss = fold_consts (fn (c, ty) =>
- insert (op =) (c, Sign.const_typargs thy (c, Logic.unvarifyT ty))) (map fst eqns') [];
- in
- gr
- |> Graph.new_node (c, (tyscm, eqns'))
- |> fold (fn (c', Ts) => ensure_eqs_dep thy algebra vardeps c c'
- #-> (fn (vs, _) =>
- fold2 (ensure_match thy algebra vardeps c) Ts (map snd vs))) rhss
- |> pair tyscm
- end
-and ensure_match thy algebra vardeps c T sort gr =
- gr
- |> fold (fn c' => ensure_eqs_dep thy algebra vardeps c c' #> snd)
- (dicts_of thy algebra (T, sort))
-and ensure_eqs_dep thy algebra vardeps c c' gr =
- gr
- |> ensure_eqs thy algebra vardeps c'
- ||> Graph.add_edge (c, c')
-and ensure_eqs thy algebra vardeps c gr =
- case try (Graph.get_node gr) c
- of SOME (tyscm, _) => (tyscm, gr)
- | NONE => add_eqs thy algebra vardeps c gr;
-
-fun extend_graph thy cs gr =
- let
- val _ = tracing ("extending with " ^ commas cs);
- val _ = tracing "obtaining instantiations";
- val (_, vardeps) = fold (assert thy o Fun) cs ([], Vargraph.empty)
- val _ = tracing "obtaining algebra";
- val algebra = algebra_of thy vardeps;
- val _ = tracing "obtaining equations";
- val (_, gr) = fold_map (ensure_eqs thy algebra vardeps) cs gr;
- val _ = tracing "sort projection";
- val minimal_proper_sort = fn sort => sort
- |> Sorts.complete_sort (Sign.classes_of thy)
- |> filter (can (AxClass.get_info thy))
- |> Sorts.minimize_sort algebra;
- in ((minimal_proper_sort, algebra), gr) end;
-
-
-(** retrieval interfaces **)
-
-fun proto_eval thy cterm_of evaluator_lift evaluator proto_ct funcgr =
- let
- val ct = cterm_of proto_ct;
- val _ = Sign.no_vars (Syntax.pp_global thy) (Thm.term_of ct);
- val _ = Term.fold_types (Type.no_tvars #> K I) (Thm.term_of ct) ();
- fun consts_of t =
- fold_aterms (fn Const c_ty => cons c_ty | _ => I) t [];
- val thm = Code.preprocess_conv thy ct;
- val ct' = Thm.rhs_of thm;
- val t' = Thm.term_of ct';
- val consts = map fst (consts_of t');
- val (algebra', funcgr') = extend_graph thy consts funcgr;
- val (t'', evaluator_funcgr) = evaluator t';
- val consts' = consts_of t'';
- val const_matches = fold (fn (c, ty) =>
- insert (op =) (Sign.const_typargs thy (c, Logic.unvarifyT ty), c)) consts' [];
- val typ_matches = maps (fn (tys, c) => tys ~~ map snd (fst (fst (Graph.get_node funcgr' c))))
- const_matches;
- val dicts = maps (dicts_of thy (snd algebra')) typ_matches;
- val (algebra'', funcgr'') = extend_graph thy dicts funcgr';
- in (evaluator_lift (evaluator_funcgr algebra'') thm funcgr'', funcgr'') end;
-
-fun proto_eval_conv thy =
- let
- fun evaluator_lift evaluator thm1 funcgr =
- let
- val thm2 = evaluator funcgr;
- val thm3 = Code.postprocess_conv thy (Thm.rhs_of thm2);
- in
- Thm.transitive thm1 (Thm.transitive thm2 thm3) handle THM _ =>
- error ("could not construct evaluation proof:\n"
- ^ (cat_lines o map Display.string_of_thm) [thm1, thm2, thm3])
- end;
- in proto_eval thy I evaluator_lift end;
-
-fun proto_eval_term thy =
- let
- fun evaluator_lift evaluator _ funcgr = evaluator funcgr;
- in proto_eval thy (Thm.cterm_of thy) evaluator_lift end;
-
-structure Funcgr = CodeDataFun
-(
- type T = T;
- val empty = Graph.empty;
- fun purge _ cs funcgr =
- Graph.del_nodes ((Graph.all_preds funcgr
- o filter (can (Graph.get_node funcgr))) cs) funcgr;
-);
-
-fun make thy = Funcgr.change_yield thy o extend_graph thy;
-
-fun eval_conv thy f =
- fst o Funcgr.change_yield thy o proto_eval_conv thy f;
-
-fun eval_term thy f =
- fst o Funcgr.change_yield thy o proto_eval_term thy f;
-
-
-(** diagnostic commands **)
-
-fun code_depgr thy consts =
- let
- val (_, gr) = make thy consts;
- val select = Graph.all_succs gr consts;
- in
- gr
- |> not (null consts) ? Graph.subgraph (member (op =) select)
- |> Graph.map_nodes ((apsnd o map o apfst) (AxClass.overload thy))
- end;
-
-fun code_thms thy = Pretty.writeln o pretty thy o code_depgr thy;
-
-fun code_deps thy consts =
- let
- val gr = code_depgr thy consts;
- fun mk_entry (const, (_, (_, parents))) =
- let
- val name = Code_Unit.string_of_const thy const;
- val nameparents = map (Code_Unit.string_of_const thy) parents;
- in { name = name, ID = name, dir = "", unfold = true,
- path = "", parents = nameparents }
- end;
- val prgr = Graph.fold ((fn x => fn xs => xs @ [x]) o mk_entry) gr [];
- in Present.display_graph prgr end;
-
-local
-
-structure P = OuterParse
-and K = OuterKeyword
-
-fun code_thms_cmd thy = code_thms thy o op @ o Code_Name.read_const_exprs thy;
-fun code_deps_cmd thy = code_deps thy o op @ o Code_Name.read_const_exprs thy;
-
-in
-
-val _ =
- OuterSyntax.improper_command "code_thms" "print system of defining equations for code" OuterKeyword.diag
- (Scan.repeat P.term_group
- >> (fn cs => Toplevel.no_timing o Toplevel.unknown_theory
- o Toplevel.keep ((fn thy => code_thms_cmd thy cs) o Toplevel.theory_of)));
-
-val _ =
- OuterSyntax.improper_command "code_deps" "visualize dependencies of defining equations for code" OuterKeyword.diag
- (Scan.repeat P.term_group
- >> (fn cs => Toplevel.no_timing o Toplevel.unknown_theory
- o Toplevel.keep ((fn thy => code_deps_cmd thy cs) o Toplevel.theory_of)));
-
-end;
-
-end; (*struct*)
--- a/src/Tools/code/code_haskell.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/Tools/code/code_haskell.ML Thu Feb 26 11:21:29 2009 +0000
@@ -101,7 +101,7 @@
and pr_bind tyvars = pr_haskell_bind (pr_term tyvars)
and pr_case tyvars thm vars fxy (cases as ((_, [_]), _)) =
let
- val (binds, t) = Code_Thingol.unfold_let (ICase cases);
+ val (binds, body) = Code_Thingol.unfold_let (ICase cases);
fun pr ((pat, ty), t) vars =
vars
|> pr_bind tyvars thm BR ((NONE, SOME pat), ty)
@@ -110,20 +110,20 @@
in
Pretty.block_enclose (
str "let {",
- concat [str "}", str "in", pr_term tyvars thm vars' NOBR t]
+ concat [str "}", str "in", pr_term tyvars thm vars' NOBR body]
) ps
end
- | pr_case tyvars thm vars fxy (((td, ty), bs as _ :: _), _) =
+ | pr_case tyvars thm vars fxy (((t, ty), clauses as _ :: _), _) =
let
- fun pr (pat, t) =
+ fun pr (pat, body) =
let
val (p, vars') = pr_bind tyvars thm NOBR ((NONE, SOME pat), ty) vars;
- in semicolon [p, str "->", pr_term tyvars thm vars' NOBR t] end;
+ in semicolon [p, str "->", pr_term tyvars thm vars' NOBR body] end;
in
Pretty.block_enclose (
- concat [str "(case", pr_term tyvars thm vars NOBR td, str "of", str "{"],
+ concat [str "(case", pr_term tyvars thm vars NOBR t, str "of", str "{"],
str "})"
- ) (map pr bs)
+ ) (map pr clauses)
end
| pr_case tyvars thm vars fxy ((_, []), _) = str "error \"empty case\"";
fun pr_stmt (name, Code_Thingol.Fun (_, ((vs, ty), []))) =
--- a/src/Tools/code/code_ml.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/Tools/code/code_ml.ML Thu Feb 26 11:21:29 2009 +0000
@@ -130,7 +130,7 @@
and pr_bind is_closure = gen_pr_bind pr_bind' (pr_term is_closure)
and pr_case is_closure thm vars fxy (cases as ((_, [_]), _)) =
let
- val (binds, t') = Code_Thingol.unfold_let (ICase cases);
+ val (binds, body) = Code_Thingol.unfold_let (ICase cases);
fun pr ((pat, ty), t) vars =
vars
|> pr_bind is_closure thm NOBR ((NONE, SOME pat), ty)
@@ -139,24 +139,24 @@
in
Pretty.chunks [
[str ("let"), Pretty.fbrk, Pretty.chunks ps] |> Pretty.block,
- [str ("in"), Pretty.fbrk, pr_term is_closure thm vars' NOBR t'] |> Pretty.block,
+ [str ("in"), Pretty.fbrk, pr_term is_closure thm vars' NOBR body] |> Pretty.block,
str ("end")
]
end
- | pr_case is_closure thm vars fxy (((td, ty), b::bs), _) =
+ | pr_case is_closure thm vars fxy (((t, ty), clause :: clauses), _) =
let
- fun pr delim (pat, t) =
+ fun pr delim (pat, body) =
let
val (p, vars') = pr_bind is_closure thm NOBR ((NONE, SOME pat), ty) vars;
in
- concat [str delim, p, str "=>", pr_term is_closure thm vars' NOBR t]
+ concat [str delim, p, str "=>", pr_term is_closure thm vars' NOBR body]
end;
in
(Pretty.enclose "(" ")" o single o brackify fxy) (
str "case"
- :: pr_term is_closure thm vars NOBR td
- :: pr "of" b
- :: map (pr "|") bs
+ :: pr_term is_closure thm vars NOBR t
+ :: pr "of" clause
+ :: map (pr "|") clauses
)
end
| pr_case is_closure thm vars fxy ((_, []), _) = str "raise Fail \"empty case\"";
@@ -434,26 +434,26 @@
and pr_bind is_closure = gen_pr_bind pr_bind' (pr_term is_closure)
and pr_case is_closure thm vars fxy (cases as ((_, [_]), _)) =
let
- val (binds, t') = Code_Thingol.unfold_let (ICase cases);
+ val (binds, body) = Code_Thingol.unfold_let (ICase cases);
fun pr ((pat, ty), t) vars =
vars
|> pr_bind is_closure thm NOBR ((NONE, SOME pat), ty)
|>> (fn p => concat
[str "let", p, str "=", pr_term is_closure thm vars NOBR t, str "in"])
val (ps, vars') = fold_map pr binds vars;
- in Pretty.chunks (ps @| pr_term is_closure thm vars' NOBR t') end
- | pr_case is_closure thm vars fxy (((td, ty), b::bs), _) =
+ in Pretty.chunks (ps @| pr_term is_closure thm vars' NOBR body) end
+ | pr_case is_closure thm vars fxy (((t, ty), clause :: clauses), _) =
let
- fun pr delim (pat, t) =
+ fun pr delim (pat, body) =
let
val (p, vars') = pr_bind is_closure thm NOBR ((NONE, SOME pat), ty) vars;
- in concat [str delim, p, str "->", pr_term is_closure thm vars' NOBR t] end;
+ in concat [str delim, p, str "->", pr_term is_closure thm vars' NOBR body] end;
in
(Pretty.enclose "(" ")" o single o brackify fxy) (
str "match"
- :: pr_term is_closure thm vars NOBR td
- :: pr "with" b
- :: map (pr "|") bs
+ :: pr_term is_closure thm vars NOBR t
+ :: pr "with" clause
+ :: map (pr "|") clauses
)
end
| pr_case is_closure thm vars fxy ((_, []), _) = str "failwith \"empty case\"";
--- a/src/Tools/code/code_target.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/Tools/code/code_target.ML Thu Feb 26 11:21:29 2009 +0000
@@ -418,7 +418,7 @@
val program4 = Graph.subgraph (member (op =) names_all) program3;
val empty_funs = filter_out (member (op =) abortable)
(Code_Thingol.empty_funs program3);
- val _ = if null empty_funs then () else error ("No defining equations for "
+ val _ = if null empty_funs then () else error ("No code equations for "
^ commas (map (Sign.extern_const thy) empty_funs));
in
serializer module args (labelled_name thy program2) reserved includes
--- a/src/Tools/code/code_thingol.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/Tools/code/code_thingol.ML Thu Feb 26 11:21:29 2009 +0000
@@ -109,7 +109,7 @@
let val (xs', x') = unfoldr dest x2 in (x1::xs', x') end;
-(** language core - types, patterns, expressions **)
+(** language core - types, terms **)
type vname = string;
@@ -131,31 +131,6 @@
| ICase of ((iterm * itype) * (iterm * iterm) list) * iterm;
(*see also signature*)
-(*
- variable naming conventions
-
- bare names:
- variable names v
- class names class
- type constructor names tyco
- datatype names dtco
- const names (general) c (const)
- constructor names co
- class parameter names classparam
- arbitrary name s
-
- v, c, co, classparam also annotated with types etc.
-
- constructs:
- sort sort
- type parameters vs
- type ty
- type schemes tysm
- term t
- (term as pattern) p
- instance (class, tyco) inst
- *)
-
val op `$$ = Library.foldl (op `$);
val op `|--> = Library.foldr (op `|->);
@@ -478,7 +453,7 @@
let
val err_class = Sorts.class_error (Syntax.pp_global thy) e;
val err_thm = case thm
- of SOME thm => "\n(in defining equation " ^ Display.string_of_thm thm ^ ")" | NONE => "";
+ of SOME thm => "\n(in code equation " ^ Display.string_of_thm thm ^ ")" | NONE => "";
val err_typ = "Type " ^ Syntax.string_of_typ_global thy ty ^ " not of sort "
^ Syntax.string_of_sort_global thy sort;
in error ("Wellsortedness error" ^ err_thm ^ ":\n" ^ err_typ ^ "\n" ^ err_class) end;
@@ -520,9 +495,8 @@
and translate_tyvar_sort thy (algbr as (proj_sort, _)) funcgr (v, sort) =
fold_map (ensure_class thy algbr funcgr) (proj_sort sort)
#>> (fn sort => (unprefix "'" v, sort))
-and translate_typ thy algbr funcgr (TFree v_sort) =
- translate_tyvar_sort thy algbr funcgr v_sort
- #>> (fn (v, sort) => ITyVar v)
+and translate_typ thy algbr funcgr (TFree (v, _)) =
+ pair (ITyVar (unprefix "'" v))
| translate_typ thy algbr funcgr (Type (tyco, tys)) =
ensure_tyco thy algbr funcgr tyco
##>> fold_map (translate_typ thy algbr funcgr) tys
@@ -537,16 +511,8 @@
Global ((class, tyco), yss)
| class_relation (Local (classrels, v), subclass) superclass =
Local ((subclass, superclass) :: classrels, v);
- fun norm_typargs ys =
- let
- val raw_sort = map snd ys;
- val sort = Sorts.minimize_sort algebra raw_sort;
- in
- map_filter (fn (y, class) =>
- if member (op =) sort class then SOME y else NONE) ys
- end;
fun type_constructor tyco yss class =
- Global ((class, tyco), map norm_typargs yss);
+ Global ((class, tyco), (map o map) fst yss);
fun type_variable (TFree (v, sort)) =
let
val sort' = proj_sort sort;
@@ -616,9 +582,8 @@
fun stmt_classparam class =
ensure_class thy algbr funcgr class
#>> (fn class => Classparam (c, class));
- fun stmt_fun ((vs, raw_ty), raw_thms) =
+ fun stmt_fun ((vs, ty), raw_thms) =
let
- val ty = Logic.unvarifyT raw_ty;
val thms = if null (Term.add_tfreesT ty []) orelse (null o fst o strip_type) ty
then raw_thms
else (map o apfst) (Code_Unit.expand_eta thy 1) raw_thms;
@@ -665,63 +630,74 @@
##>> fold_map (translate_typ thy algbr funcgr) tys_args
#>> (fn ((c, iss), tys) => IConst (c, (iss, tys)))
end
-and translate_app_default thy algbr funcgr thm (c_ty, ts) =
+and translate_app_const thy algbr funcgr thm (c_ty, ts) =
translate_const thy algbr funcgr thm c_ty
##>> fold_map (translate_term thy algbr funcgr thm) ts
#>> (fn (t, ts) => t `$$ ts)
-and translate_case thy algbr funcgr thm n cases (app as ((c, ty), ts)) =
+and translate_case thy algbr funcgr thm (num_args, (t_pos, case_pats)) (c_ty, ts) =
let
- val (tys, _) =
- (chop (1 + (if null cases then 1 else length cases)) o fst o strip_type) ty;
- val dt = nth ts n;
- val dty = nth tys n;
- fun is_undefined (Const (c, _)) = Code.is_undefined thy c
- | is_undefined _ = false;
- fun mk_case (co, n) t =
+ val (tys, _) = (chop num_args o fst o strip_type o snd) c_ty;
+ val t = nth ts t_pos;
+ val ty = nth tys t_pos;
+ val ts_clause = nth_drop t_pos ts;
+ fun mk_clause (co, num_co_args) t =
let
- val _ = if (is_some o Code.get_datatype_of_constr thy) co then ()
- else error ("Non-constructor " ^ quote co
- ^ " encountered in case pattern"
- ^ (case thm of NONE => ""
- | SOME thm => ", in equation\n" ^ Display.string_of_thm thm))
- val (vs, body) = Term.strip_abs_eta n t;
- val selector = list_comb (Const (co, map snd vs ---> dty), map Free vs);
- in if is_undefined body then NONE else SOME (selector, body) end;
- fun mk_ds [] =
+ val (vs, body) = Term.strip_abs_eta num_co_args t;
+ val not_undefined = case body
+ of (Const (c, _)) => not (Code.is_undefined thy c)
+ | _ => true;
+ val pat = list_comb (Const (co, map snd vs ---> ty), map Free vs);
+ in (not_undefined, (pat, body)) end;
+ val clauses = if null case_pats then let val ([v_ty], body) =
+ Term.strip_abs_eta 1 (the_single ts_clause)
+ in [(true, (Free v_ty, body))] end
+ else map (uncurry mk_clause)
+ (AList.make (Code_Unit.no_args thy) case_pats ~~ ts_clause);
+ fun retermify ty (_, (IVar x, body)) =
+ (x, ty) `|-> body
+ | retermify _ (_, (pat, body)) =
let
- val ([v_ty], body) = Term.strip_abs_eta 1 (the_single (nth_drop n ts))
- in [(Free v_ty, body)] end
- | mk_ds cases = map_filter (uncurry mk_case)
- (AList.make (Code_Unit.no_args thy) cases ~~ nth_drop n ts);
+ val (IConst (_, (_, tys)), ts) = unfold_app pat;
+ val vs = map2 (fn IVar x => fn ty => (x, ty)) ts tys;
+ in vs `|--> body end;
+ fun mk_icase const t ty clauses =
+ let
+ val (ts1, ts2) = chop t_pos (map (retermify ty) clauses);
+ in
+ ICase (((t, ty), map_filter (fn (b, d) => if b then SOME d else NONE) clauses),
+ const `$$ (ts1 @ t :: ts2))
+ end;
in
- translate_term thy algbr funcgr thm dt
- ##>> translate_typ thy algbr funcgr dty
- ##>> fold_map (fn (pat, body) => translate_term thy algbr funcgr thm pat
- ##>> translate_term thy algbr funcgr thm body) (mk_ds cases)
- ##>> translate_app_default thy algbr funcgr thm app
- #>> (fn (((dt, dty), ds), t0) => ICase (((dt, dty), ds), t0))
+ translate_const thy algbr funcgr thm c_ty
+ ##>> translate_term thy algbr funcgr thm t
+ ##>> translate_typ thy algbr funcgr ty
+ ##>> fold_map (fn (b, (pat, body)) => translate_term thy algbr funcgr thm pat
+ ##>> translate_term thy algbr funcgr thm body
+ #>> pair b) clauses
+ #>> (fn (((const, t), ty), ds) => mk_icase const t ty ds)
end
-and translate_app thy algbr funcgr thm ((c, ty), ts) = case Code.get_case_data thy c
- of SOME (n, cases) => let val i = 1 + (if null cases then 1 else length cases) in
- if length ts < i then
- let
- val k = length ts;
- val tys = (curry Library.take (i - k) o curry Library.drop k o fst o strip_type) ty;
- val ctxt = (fold o fold_aterms) Term.declare_term_frees ts Name.context;
- val vs = Name.names ctxt "a" tys;
- in
- fold_map (translate_typ thy algbr funcgr) tys
- ##>> translate_case thy algbr funcgr thm n cases ((c, ty), ts @ map Free vs)
- #>> (fn (tys, t) => map2 (fn (v, _) => pair v) vs tys `|--> t)
- end
- else if length ts > i then
- translate_case thy algbr funcgr thm n cases ((c, ty), Library.take (i, ts))
- ##>> fold_map (translate_term thy algbr funcgr thm) (Library.drop (i, ts))
- #>> (fn (t, ts) => t `$$ ts)
- else
- translate_case thy algbr funcgr thm n cases ((c, ty), ts)
- end
- | NONE => translate_app_default thy algbr funcgr thm ((c, ty), ts);
+and translate_app_case thy algbr funcgr thm (case_scheme as (num_args, _)) ((c, ty), ts) =
+ if length ts < num_args then
+ let
+ val k = length ts;
+ val tys = (curry Library.take (num_args - k) o curry Library.drop k o fst o strip_type) ty;
+ val ctxt = (fold o fold_aterms) Term.declare_term_frees ts Name.context;
+ val vs = Name.names ctxt "a" tys;
+ in
+ fold_map (translate_typ thy algbr funcgr) tys
+ ##>> translate_case thy algbr funcgr thm case_scheme ((c, ty), ts @ map Free vs)
+ #>> (fn (tys, t) => map2 (fn (v, _) => pair v) vs tys `|--> t)
+ end
+ else if length ts > num_args then
+ translate_case thy algbr funcgr thm case_scheme ((c, ty), Library.take (num_args, ts))
+ ##>> fold_map (translate_term thy algbr funcgr thm) (Library.drop (num_args, ts))
+ #>> (fn (t, ts) => t `$$ ts)
+ else
+ translate_case thy algbr funcgr thm case_scheme ((c, ty), ts)
+and translate_app thy algbr funcgr thm (c_ty_ts as ((c, _), _)) =
+ case Code.get_case_scheme thy c
+ of SOME case_scheme => translate_app_case thy algbr funcgr thm case_scheme c_ty_ts
+ | NONE => translate_app_const thy algbr funcgr thm c_ty_ts;
(* store *)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/Tools/code/code_wellsorted.ML Thu Feb 26 11:21:29 2009 +0000
@@ -0,0 +1,390 @@
+(* Title: Tools/code/code_wellsorted.ML
+ Author: Florian Haftmann, TU Muenchen
+
+Producing well-sorted systems of code equations in a graph
+with explicit dependencies -- the Waisenhaus algorithm.
+*)
+
+signature CODE_FUNCGR =
+sig
+ type T
+ val eqns: T -> string -> (thm * bool) list
+ val typ: T -> string -> (string * sort) list * typ
+ val all: T -> string list
+ val pretty: theory -> T -> Pretty.T
+ val make: theory -> string list
+ -> ((sort -> sort) * Sorts.algebra) * T
+ val eval_conv: theory
+ -> (term -> term * (((sort -> sort) * Sorts.algebra) -> T -> thm)) -> cterm -> thm
+ val eval_term: theory
+ -> (term -> term * (((sort -> sort) * Sorts.algebra) -> T -> 'a)) -> term -> 'a
+end
+
+structure Code_Funcgr : CODE_FUNCGR =
+struct
+
+(** the equation graph type **)
+
+type T = (((string * sort) list * typ) * (thm * bool) list) Graph.T;
+
+fun eqns eqngr = these o Option.map snd o try (Graph.get_node eqngr);
+fun typ eqngr = fst o Graph.get_node eqngr;
+fun all eqngr = Graph.keys eqngr;
+
+fun pretty thy eqngr =
+ AList.make (snd o Graph.get_node eqngr) (Graph.keys eqngr)
+ |> (map o apfst) (Code_Unit.string_of_const thy)
+ |> sort (string_ord o pairself fst)
+ |> map (fn (s, thms) =>
+ (Pretty.block o Pretty.fbreaks) (
+ Pretty.str s
+ :: map (Display.pretty_thm o fst) thms
+ ))
+ |> Pretty.chunks;
+
+
+(** the Waisenhaus algorithm **)
+
+(* auxiliary *)
+
+fun complete_proper_sort thy =
+ Sign.complete_sort thy #> filter (can (AxClass.get_info thy));
+
+fun inst_params thy tyco =
+ map (fn (c, _) => AxClass.param_of_inst thy (c, tyco))
+ o maps (#params o AxClass.get_info thy);
+
+fun consts_of thy eqns = [] |> (fold o fold o fold_aterms)
+ (fn Const (c, ty) => insert (op =) (c, Sign.const_typargs thy (c, Logic.unvarifyT ty)) | _ => I)
+ (map (op :: o swap o apfst (snd o strip_comb) o Logic.dest_equals o Thm.plain_prop_of o fst) eqns);
+
+fun tyscm_rhss_of thy c eqns =
+ let
+ val tyscm = case eqns of [] => Code.default_typscheme thy c
+ | ((thm, _) :: _) => (snd o Code_Unit.head_eqn thy) thm;
+ val rhss = consts_of thy eqns;
+ in (tyscm, rhss) end;
+
+
+(* data structures *)
+
+datatype const = Fun of string | Inst of class * string;
+
+fun const_ord (Fun c1, Fun c2) = fast_string_ord (c1, c2)
+ | const_ord (Inst class_tyco1, Inst class_tyco2) =
+ prod_ord fast_string_ord fast_string_ord (class_tyco1, class_tyco2)
+ | const_ord (Fun _, Inst _) = LESS
+ | const_ord (Inst _, Fun _) = GREATER;
+
+type var = const * int;
+
+structure Vargraph =
+ GraphFun(type key = var val ord = prod_ord const_ord int_ord);
+
+datatype styp = Tyco of string * styp list | Var of var | Free;
+
+fun styp_of c_lhs (Type (tyco, tys)) = Tyco (tyco, map (styp_of c_lhs) tys)
+ | styp_of c_lhs (TFree (v, _)) = case c_lhs
+ of SOME (c, lhs) => Var (Fun c, find_index (fn (v', _) => v = v') lhs)
+ | NONE => Free;
+
+type vardeps_data = ((string * styp list) list * class list) Vargraph.T
+ * (((string * sort) list * (thm * bool) list) Symtab.table
+ * (class * string) list);
+
+val empty_vardeps_data : vardeps_data =
+ (Vargraph.empty, (Symtab.empty, []));
+
+(* retrieving equations and instances from the background context *)
+
+fun obtain_eqns thy eqngr c =
+ case try (Graph.get_node eqngr) c
+ of SOME ((lhs, _), eqns) => ((lhs, []), [])
+ | NONE => let
+ val eqns = Code.these_eqns thy c
+ |> burrow_fst (Code_Unit.norm_args thy)
+ |> burrow_fst (Code_Unit.norm_varnames thy Code_Name.purify_tvar Code_Name.purify_var);
+ val ((lhs, _), rhss) = tyscm_rhss_of thy c eqns;
+ in ((lhs, rhss), eqns) end;
+
+fun obtain_instance thy arities (inst as (class, tyco)) =
+ case AList.lookup (op =) arities inst
+ of SOME classess => (classess, ([], []))
+ | NONE => let
+ val all_classes = complete_proper_sort thy [class];
+ val superclasses = remove (op =) class all_classes
+ val classess = map (complete_proper_sort thy)
+ (Sign.arity_sorts thy tyco [class]);
+ val inst_params = inst_params thy tyco all_classes;
+ in (classess, (superclasses, inst_params)) end;
+
+
+(* computing instantiations *)
+
+fun add_classes thy arities eqngr c_k new_classes vardeps_data =
+ let
+ val (styps, old_classes) = Vargraph.get_node (fst vardeps_data) c_k;
+ val diff_classes = new_classes |> subtract (op =) old_classes;
+ in if null diff_classes then vardeps_data
+ else let
+ val c_ks = Vargraph.imm_succs (fst vardeps_data) c_k |> insert (op =) c_k;
+ in
+ vardeps_data
+ |> (apfst o Vargraph.map_node c_k o apsnd) (append diff_classes)
+ |> fold (fn styp => fold (assert_typmatch_inst thy arities eqngr styp) new_classes) styps
+ |> fold (fn c_k => add_classes thy arities eqngr c_k diff_classes) c_ks
+ end end
+and add_styp thy arities eqngr c_k tyco_styps vardeps_data =
+ let
+ val (old_styps, classes) = Vargraph.get_node (fst vardeps_data) c_k;
+ in if member (op =) old_styps tyco_styps then vardeps_data
+ else
+ vardeps_data
+ |> (apfst o Vargraph.map_node c_k o apfst) (cons tyco_styps)
+ |> fold (assert_typmatch_inst thy arities eqngr tyco_styps) classes
+ end
+and add_dep thy arities eqngr c_k c_k' vardeps_data =
+ let
+ val (_, classes) = Vargraph.get_node (fst vardeps_data) c_k;
+ in
+ vardeps_data
+ |> add_classes thy arities eqngr c_k' classes
+ |> apfst (Vargraph.add_edge (c_k, c_k'))
+ end
+and assert_typmatch_inst thy arities eqngr (tyco, styps) class vardeps_data =
+ if can (Sign.arity_sorts thy tyco) [class]
+ then vardeps_data
+ |> assert_inst thy arities eqngr (class, tyco)
+ |> fold_index (fn (k, styp) =>
+ assert_typmatch thy arities eqngr styp (Inst (class, tyco), k)) styps
+ else vardeps_data (*permissive!*)
+and assert_inst thy arities eqngr (inst as (class, tyco)) (vardeps_data as (_, (_, insts))) =
+ if member (op =) insts inst then vardeps_data
+ else let
+ val (classess, (superclasses, inst_params)) =
+ obtain_instance thy arities inst;
+ in
+ vardeps_data
+ |> (apsnd o apsnd) (insert (op =) inst)
+ |> fold_index (fn (k, _) =>
+ apfst (Vargraph.new_node ((Inst (class, tyco), k), ([] ,[])))) classess
+ |> fold (fn superclass => assert_inst thy arities eqngr (superclass, tyco)) superclasses
+ |> fold (assert_fun thy arities eqngr) inst_params
+ |> fold_index (fn (k, classes) =>
+ add_classes thy arities eqngr (Inst (class, tyco), k) classes
+ #> fold (fn superclass =>
+ add_dep thy arities eqngr (Inst (superclass, tyco), k)
+ (Inst (class, tyco), k)) superclasses
+ #> fold (fn inst_param =>
+ add_dep thy arities eqngr (Fun inst_param, k)
+ (Inst (class, tyco), k)
+ ) inst_params
+ ) classess
+ end
+and assert_typmatch thy arities eqngr (Tyco tyco_styps) c_k vardeps_data =
+ vardeps_data
+ |> add_styp thy arities eqngr c_k tyco_styps
+ | assert_typmatch thy arities eqngr (Var c_k') c_k vardeps_data =
+ vardeps_data
+ |> add_dep thy arities eqngr c_k c_k'
+ | assert_typmatch thy arities eqngr Free c_k vardeps_data =
+ vardeps_data
+and assert_rhs thy arities eqngr (c', styps) vardeps_data =
+ vardeps_data
+ |> assert_fun thy arities eqngr c'
+ |> fold_index (fn (k, styp) =>
+ assert_typmatch thy arities eqngr styp (Fun c', k)) styps
+and assert_fun thy arities eqngr c (vardeps_data as (_, (eqntab, _))) =
+ if Symtab.defined eqntab c then vardeps_data
+ else let
+ val ((lhs, rhss), eqns) = obtain_eqns thy eqngr c;
+ val rhss' = (map o apsnd o map) (styp_of (SOME (c, lhs))) rhss;
+ in
+ vardeps_data
+ |> (apsnd o apfst) (Symtab.update_new (c, (lhs, eqns)))
+ |> fold_index (fn (k, _) =>
+ apfst (Vargraph.new_node ((Fun c, k), ([] ,[])))) lhs
+ |> fold_index (fn (k, (_, sort)) =>
+ add_classes thy arities eqngr (Fun c, k) (complete_proper_sort thy sort)) lhs
+ |> fold (assert_rhs thy arities eqngr) rhss'
+ end;
+
+
+(* applying instantiations *)
+
+fun dicts_of thy (proj_sort, algebra) (T, sort) =
+ let
+ fun class_relation (x, _) _ = x;
+ fun type_constructor tyco xs class =
+ inst_params thy tyco (Sorts.complete_sort algebra [class])
+ @ (maps o maps) fst xs;
+ fun type_variable (TFree (_, sort)) = map (pair []) (proj_sort sort);
+ in
+ flat (Sorts.of_sort_derivation (Syntax.pp_global thy) algebra
+ { class_relation = class_relation, type_constructor = type_constructor,
+ type_variable = type_variable } (T, proj_sort sort)
+ handle Sorts.CLASS_ERROR _ => [] (*permissive!*))
+ end;
+
+fun add_arity thy vardeps (class, tyco) =
+ AList.default (op =)
+ ((class, tyco), map (fn k => (snd o Vargraph.get_node vardeps) (Inst (class, tyco), k))
+ (0 upto Sign.arity_number thy tyco - 1));
+
+fun add_eqs thy (proj_sort, algebra) vardeps
+ (c, (proto_lhs, proto_eqns)) (rhss, eqngr) =
+ if can (Graph.get_node eqngr) c then (rhss, eqngr)
+ else let
+ val lhs = map_index (fn (k, (v, _)) =>
+ (v, snd (Vargraph.get_node vardeps (Fun c, k)))) proto_lhs;
+ val inst_tab = Vartab.empty |> fold (fn (v, sort) =>
+ Vartab.update ((v, 0), sort)) lhs;
+ val eqns = proto_eqns
+ |> (map o apfst) (Code_Unit.inst_thm thy inst_tab);
+ val (tyscm, rhss') = tyscm_rhss_of thy c eqns;
+ val eqngr' = Graph.new_node (c, (tyscm, eqns)) eqngr;
+ in (map (pair c) rhss' @ rhss, eqngr') end;
+
+fun extend_arities_eqngr thy cs cs_rhss (arities, eqngr) =
+ let
+ val cs_rhss' = (map o apsnd o map) (styp_of NONE) cs_rhss;
+ val (vardeps, (eqntab, insts)) = empty_vardeps_data
+ |> fold (assert_fun thy arities eqngr) cs
+ |> fold (assert_rhs thy arities eqngr) cs_rhss';
+ val arities' = fold (add_arity thy vardeps) insts arities;
+ val pp = Syntax.pp_global thy;
+ val is_proper_class = can (AxClass.get_info thy);
+ val (proj_sort, algebra) = Sorts.subalgebra pp is_proper_class
+ (AList.lookup (op =) arities') (Sign.classes_of thy);
+ val (rhss, eqngr') = Symtab.fold
+ (add_eqs thy (proj_sort, algebra) vardeps) eqntab ([], eqngr);
+ fun deps_of (c, rhs) = c ::
+ maps (dicts_of thy (proj_sort, algebra))
+ (rhs ~~ (map snd o fst o fst o Graph.get_node eqngr') c);
+ val eqngr'' = fold (fn (c, rhs) => fold
+ (curry Graph.add_edge c) (deps_of rhs)) rhss eqngr';
+ in ((proj_sort, algebra), (arities', eqngr'')) end;
+
+
+(** retrieval interfaces **)
+
+fun proto_eval thy cterm_of evaluator_lift evaluator proto_ct arities_eqngr =
+ let
+ val ct = cterm_of proto_ct;
+ val _ = Sign.no_vars (Syntax.pp_global thy) (Thm.term_of ct);
+ val _ = Term.fold_types (Type.no_tvars #> K I) (Thm.term_of ct) ();
+ fun consts_of t =
+ fold_aterms (fn Const c_ty => cons c_ty | _ => I) t [];
+ val thm = Code.preprocess_conv thy ct;
+ val ct' = Thm.rhs_of thm;
+ val t' = Thm.term_of ct';
+ val (t'', evaluator_eqngr) = evaluator t';
+ val consts = map fst (consts_of t');
+ val consts' = consts_of t'';
+ val const_matches' = fold (fn (c, ty) =>
+ insert (op =) (c, Sign.const_typargs thy (c, ty))) consts' [];
+ val (algebra', arities_eqngr') =
+ extend_arities_eqngr thy consts const_matches' arities_eqngr;
+ in
+ (evaluator_lift (evaluator_eqngr algebra') thm (snd arities_eqngr'),
+ arities_eqngr')
+ end;
+
+fun proto_eval_conv thy =
+ let
+ fun evaluator_lift evaluator thm1 eqngr =
+ let
+ val thm2 = evaluator eqngr;
+ val thm3 = Code.postprocess_conv thy (Thm.rhs_of thm2);
+ in
+ Thm.transitive thm1 (Thm.transitive thm2 thm3) handle THM _ =>
+ error ("could not construct evaluation proof:\n"
+ ^ (cat_lines o map Display.string_of_thm) [thm1, thm2, thm3])
+ end;
+ in proto_eval thy I evaluator_lift end;
+
+fun proto_eval_term thy =
+ let
+ fun evaluator_lift evaluator _ eqngr = evaluator eqngr;
+ in proto_eval thy (Thm.cterm_of thy) evaluator_lift end;
+
+structure Wellsorted = CodeDataFun
+(
+ type T = ((string * class) * sort list) list * T;
+ val empty = ([], Graph.empty);
+ fun purge thy cs (arities, eqngr) =
+ let
+ val del_cs = ((Graph.all_preds eqngr
+ o filter (can (Graph.get_node eqngr))) cs);
+ val del_arities = del_cs
+ |> map_filter (AxClass.inst_of_param thy)
+ |> maps (fn (c, tyco) =>
+ (map (rpair tyco) o Sign.complete_sort thy o the_list
+ o AxClass.class_of_param thy) c);
+ val arities' = fold (AList.delete (op =)) del_arities arities;
+ val eqngr' = Graph.del_nodes del_cs eqngr;
+ in (arities', eqngr') end;
+);
+
+fun make thy cs = apsnd snd
+ (Wellsorted.change_yield thy (extend_arities_eqngr thy cs []));
+
+fun eval_conv thy f =
+ fst o Wellsorted.change_yield thy o proto_eval_conv thy f;
+
+fun eval_term thy f =
+ fst o Wellsorted.change_yield thy o proto_eval_term thy f;
+
+
+(** diagnostic commands **)
+
+fun code_depgr thy consts =
+ let
+ val (_, eqngr) = make thy consts;
+ val select = Graph.all_succs eqngr consts;
+ in
+ eqngr
+ |> not (null consts) ? Graph.subgraph (member (op =) select)
+ |> Graph.map_nodes ((apsnd o map o apfst) (AxClass.overload thy))
+ end;
+
+fun code_thms thy = Pretty.writeln o pretty thy o code_depgr thy;
+
+fun code_deps thy consts =
+ let
+ val eqngr = code_depgr thy consts;
+ fun mk_entry (const, (_, (_, parents))) =
+ let
+ val name = Code_Unit.string_of_const thy const;
+ val nameparents = map (Code_Unit.string_of_const thy) parents;
+ in { name = name, ID = name, dir = "", unfold = true,
+ path = "", parents = nameparents }
+ end;
+ val prgr = Graph.fold ((fn x => fn xs => xs @ [x]) o mk_entry) eqngr [];
+ in Present.display_graph prgr end;
+
+local
+
+structure P = OuterParse
+and K = OuterKeyword
+
+fun code_thms_cmd thy = code_thms thy o op @ o Code_Name.read_const_exprs thy;
+fun code_deps_cmd thy = code_deps thy o op @ o Code_Name.read_const_exprs thy;
+
+in
+
+val _ =
+ OuterSyntax.improper_command "code_thms" "print system of code equations for code" OuterKeyword.diag
+ (Scan.repeat P.term_group
+ >> (fn cs => Toplevel.no_timing o Toplevel.unknown_theory
+ o Toplevel.keep ((fn thy => code_thms_cmd thy cs) o Toplevel.theory_of)));
+
+val _ =
+ OuterSyntax.improper_command "code_deps" "visualize dependencies of code equations for code" OuterKeyword.diag
+ (Scan.repeat P.term_group
+ >> (fn cs => Toplevel.no_timing o Toplevel.unknown_theory
+ o Toplevel.keep ((fn thy => code_deps_cmd thy cs) o Toplevel.theory_of)));
+
+end;
+
+end; (*struct*)
--- a/src/Tools/nbe.ML Thu Feb 26 11:18:40 2009 +0000
+++ b/src/Tools/nbe.ML Thu Feb 26 11:21:29 2009 +0000
@@ -389,8 +389,8 @@
val ts' = take_until is_dict ts;
val c = const_of_idx idx;
val (_, T) = Code.default_typscheme thy c;
- val T' = map_type_tvar (fn ((v, i), S) => TypeInfer.param (typidx + i) (v, [])) T;
- val typidx' = typidx + maxidx_of_typ T' + 1;
+ val T' = map_type_tfree (fn (v, _) => TypeInfer.param typidx (v, [])) T;
+ val typidx' = typidx + 1;
in of_apps bounds (Term.Const (c, T'), ts') typidx' end
| of_univ bounds (Free (name, ts)) typidx =
of_apps bounds (Term.Free (name, dummyT), ts) typidx