1.1 --- a/NEWS Mon Apr 20 12:27:23 2009 +0200
1.2 +++ b/NEWS Mon Apr 20 16:28:13 2009 +0200
1.3 @@ -4,6 +4,25 @@
1.4 New in this Isabelle version
1.5 ----------------------------
1.6
1.7 +*** Pure ***
1.8 +
1.9 +* On instantiation of classes, remaining undefined class parameters are
1.10 +formally declared. INCOMPATIBILITY.
1.11 +
1.12 +
1.13 +*** HOL ***
1.14 +
1.15 +* Class semiring_div requires superclass no_zero_divisors and proof of div_mult_mult1;
1.16 +theorems div_mult_mult1, div_mult_mult2, div_mult_mult1_if, div_mult_mult1 and
1.17 +div_mult_mult2 have been generalized to class semiring_div, subsuming former
1.18 +theorems zdiv_zmult_zmult1, zdiv_zmult_zmult1_if, zdiv_zmult_zmult1 and zdiv_zmult_zmult2.
1.19 +div_mult_mult1 is now [simp] by default. INCOMPATIBILITY.
1.20 +
1.21 +* Power operations on relations and functions are now dedicated constants:
1.22 +
1.23 + relpow with infix syntax "^^"
1.24 + funpow with infix syntax "^o"
1.25 +
1.26
1.27
1.28 New in Isabelle2009 (April 2009)
2.1 --- a/doc-src/Codegen/Thy/Program.thy Mon Apr 20 12:27:23 2009 +0200
2.2 +++ b/doc-src/Codegen/Thy/Program.thy Mon Apr 20 16:28:13 2009 +0200
2.3 @@ -323,7 +323,7 @@
2.4 *}
2.5
2.6
2.7 -subsection {* Equality and wellsortedness *}
2.8 +subsection {* Equality *}
2.9
2.10 text {*
2.11 Surely you have already noticed how equality is treated
2.12 @@ -358,60 +358,7 @@
2.13 manually like any other type class.
2.14
2.15 Though this @{text eq} class is designed to get rarely in
2.16 - the way, a subtlety
2.17 - enters the stage when definitions of overloaded constants
2.18 - are dependent on operational equality. For example, let
2.19 - us define a lexicographic ordering on tuples
2.20 - (also see theory @{theory Product_ord}):
2.21 -*}
2.22 -
2.23 -instantiation %quote "*" :: (order, order) order
2.24 -begin
2.25 -
2.26 -definition %quote [code del]:
2.27 - "x \<le> y \<longleftrightarrow> fst x < fst y \<or> fst x = fst y \<and> snd x \<le> snd y"
2.28 -
2.29 -definition %quote [code del]:
2.30 - "x < y \<longleftrightarrow> fst x < fst y \<or> fst x = fst y \<and> snd x < snd y"
2.31 -
2.32 -instance %quote proof
2.33 -qed (auto simp: less_eq_prod_def less_prod_def intro: order_less_trans)
2.34 -
2.35 -end %quote
2.36 -
2.37 -lemma %quote order_prod [code]:
2.38 - "(x1 \<Colon> 'a\<Colon>order, y1 \<Colon> 'b\<Colon>order) < (x2, y2) \<longleftrightarrow>
2.39 - x1 < x2 \<or> x1 = x2 \<and> y1 < y2"
2.40 - "(x1 \<Colon> 'a\<Colon>order, y1 \<Colon> 'b\<Colon>order) \<le> (x2, y2) \<longleftrightarrow>
2.41 - x1 < x2 \<or> x1 = x2 \<and> y1 \<le> y2"
2.42 - by (simp_all add: less_prod_def less_eq_prod_def)
2.43 -
2.44 -text {*
2.45 - \noindent Then code generation will fail. Why? The definition
2.46 - of @{term "op \<le>"} depends on equality on both arguments,
2.47 - which are polymorphic and impose an additional @{class eq}
2.48 - class constraint, which the preprocessor does not propagate
2.49 - (for technical reasons).
2.50 -
2.51 - The solution is to add @{class eq} explicitly to the first sort arguments in the
2.52 - code theorems:
2.53 -*}
2.54 -
2.55 -lemma %quote order_prod_code [code]:
2.56 - "(x1 \<Colon> 'a\<Colon>{order, eq}, y1 \<Colon> 'b\<Colon>order) < (x2, y2) \<longleftrightarrow>
2.57 - x1 < x2 \<or> x1 = x2 \<and> y1 < y2"
2.58 - "(x1 \<Colon> 'a\<Colon>{order, eq}, y1 \<Colon> 'b\<Colon>order) \<le> (x2, y2) \<longleftrightarrow>
2.59 - x1 < x2 \<or> x1 = x2 \<and> y1 \<le> y2"
2.60 - by (simp_all add: less_prod_def less_eq_prod_def)
2.61 -
2.62 -text {*
2.63 - \noindent Then code generation succeeds:
2.64 -*}
2.65 -
2.66 -text %quote {*@{code_stmts "op \<le> \<Colon> _ \<times> _ \<Rightarrow> _ \<times> _ \<Rightarrow> bool" (SML)}*}
2.67 -
2.68 -text {*
2.69 - In some cases, the automatically derived code equations
2.70 + the way, in some cases the automatically derived code equations
2.71 for equality on a particular type may not be appropriate.
2.72 As example, watch the following datatype representing
2.73 monomorphic parametric types (where type constructors
3.1 --- a/doc-src/Codegen/Thy/document/Program.tex Mon Apr 20 12:27:23 2009 +0200
3.2 +++ b/doc-src/Codegen/Thy/document/Program.tex Mon Apr 20 16:28:13 2009 +0200
3.3 @@ -714,7 +714,7 @@
3.4 \end{isamarkuptext}%
3.5 \isamarkuptrue%
3.6 %
3.7 -\isamarkupsubsection{Equality and wellsortedness%
3.8 +\isamarkupsubsection{Equality%
3.9 }
3.10 \isamarkuptrue%
3.11 %
3.12 @@ -801,141 +801,7 @@
3.13 manually like any other type class.
3.14
3.15 Though this \isa{eq} class is designed to get rarely in
3.16 - the way, a subtlety
3.17 - enters the stage when definitions of overloaded constants
3.18 - are dependent on operational equality. For example, let
3.19 - us define a lexicographic ordering on tuples
3.20 - (also see theory \hyperlink{theory.Product-ord}{\mbox{\isa{Product{\isacharunderscore}ord}}}):%
3.21 -\end{isamarkuptext}%
3.22 -\isamarkuptrue%
3.23 -%
3.24 -\isadelimquote
3.25 -%
3.26 -\endisadelimquote
3.27 -%
3.28 -\isatagquote
3.29 -\isacommand{instantiation}\isamarkupfalse%
3.30 -\ {\isachardoublequoteopen}{\isacharasterisk}{\isachardoublequoteclose}\ {\isacharcolon}{\isacharcolon}\ {\isacharparenleft}order{\isacharcomma}\ order{\isacharparenright}\ order\isanewline
3.31 -\isakeyword{begin}\isanewline
3.32 -\isanewline
3.33 -\isacommand{definition}\isamarkupfalse%
3.34 -\ {\isacharbrackleft}code\ del{\isacharbrackright}{\isacharcolon}\isanewline
3.35 -\ \ {\isachardoublequoteopen}x\ {\isasymle}\ y\ {\isasymlongleftrightarrow}\ fst\ x\ {\isacharless}\ fst\ y\ {\isasymor}\ fst\ x\ {\isacharequal}\ fst\ y\ {\isasymand}\ snd\ x\ {\isasymle}\ snd\ y{\isachardoublequoteclose}\isanewline
3.36 -\isanewline
3.37 -\isacommand{definition}\isamarkupfalse%
3.38 -\ {\isacharbrackleft}code\ del{\isacharbrackright}{\isacharcolon}\isanewline
3.39 -\ \ {\isachardoublequoteopen}x\ {\isacharless}\ y\ {\isasymlongleftrightarrow}\ fst\ x\ {\isacharless}\ fst\ y\ {\isasymor}\ fst\ x\ {\isacharequal}\ fst\ y\ {\isasymand}\ snd\ x\ {\isacharless}\ snd\ y{\isachardoublequoteclose}\isanewline
3.40 -\isanewline
3.41 -\isacommand{instance}\isamarkupfalse%
3.42 -\ \isacommand{proof}\isamarkupfalse%
3.43 -\isanewline
3.44 -\isacommand{qed}\isamarkupfalse%
3.45 -\ {\isacharparenleft}auto\ simp{\isacharcolon}\ less{\isacharunderscore}eq{\isacharunderscore}prod{\isacharunderscore}def\ less{\isacharunderscore}prod{\isacharunderscore}def\ intro{\isacharcolon}\ order{\isacharunderscore}less{\isacharunderscore}trans{\isacharparenright}\isanewline
3.46 -\isanewline
3.47 -\isacommand{end}\isamarkupfalse%
3.48 -\isanewline
3.49 -\isanewline
3.50 -\isacommand{lemma}\isamarkupfalse%
3.51 -\ order{\isacharunderscore}prod\ {\isacharbrackleft}code{\isacharbrackright}{\isacharcolon}\isanewline
3.52 -\ \ {\isachardoublequoteopen}{\isacharparenleft}x{\isadigit{1}}\ {\isasymColon}\ {\isacharprime}a{\isasymColon}order{\isacharcomma}\ y{\isadigit{1}}\ {\isasymColon}\ {\isacharprime}b{\isasymColon}order{\isacharparenright}\ {\isacharless}\ {\isacharparenleft}x{\isadigit{2}}{\isacharcomma}\ y{\isadigit{2}}{\isacharparenright}\ {\isasymlongleftrightarrow}\isanewline
3.53 -\ \ \ \ \ x{\isadigit{1}}\ {\isacharless}\ x{\isadigit{2}}\ {\isasymor}\ x{\isadigit{1}}\ {\isacharequal}\ x{\isadigit{2}}\ {\isasymand}\ y{\isadigit{1}}\ {\isacharless}\ y{\isadigit{2}}{\isachardoublequoteclose}\isanewline
3.54 -\ \ {\isachardoublequoteopen}{\isacharparenleft}x{\isadigit{1}}\ {\isasymColon}\ {\isacharprime}a{\isasymColon}order{\isacharcomma}\ y{\isadigit{1}}\ {\isasymColon}\ {\isacharprime}b{\isasymColon}order{\isacharparenright}\ {\isasymle}\ {\isacharparenleft}x{\isadigit{2}}{\isacharcomma}\ y{\isadigit{2}}{\isacharparenright}\ {\isasymlongleftrightarrow}\isanewline
3.55 -\ \ \ \ \ x{\isadigit{1}}\ {\isacharless}\ x{\isadigit{2}}\ {\isasymor}\ x{\isadigit{1}}\ {\isacharequal}\ x{\isadigit{2}}\ {\isasymand}\ y{\isadigit{1}}\ {\isasymle}\ y{\isadigit{2}}{\isachardoublequoteclose}\isanewline
3.56 -\ \ \isacommand{by}\isamarkupfalse%
3.57 -\ {\isacharparenleft}simp{\isacharunderscore}all\ add{\isacharcolon}\ less{\isacharunderscore}prod{\isacharunderscore}def\ less{\isacharunderscore}eq{\isacharunderscore}prod{\isacharunderscore}def{\isacharparenright}%
3.58 -\endisatagquote
3.59 -{\isafoldquote}%
3.60 -%
3.61 -\isadelimquote
3.62 -%
3.63 -\endisadelimquote
3.64 -%
3.65 -\begin{isamarkuptext}%
3.66 -\noindent Then code generation will fail. Why? The definition
3.67 - of \isa{op\ {\isasymle}} depends on equality on both arguments,
3.68 - which are polymorphic and impose an additional \isa{eq}
3.69 - class constraint, which the preprocessor does not propagate
3.70 - (for technical reasons).
3.71 -
3.72 - The solution is to add \isa{eq} explicitly to the first sort arguments in the
3.73 - code theorems:%
3.74 -\end{isamarkuptext}%
3.75 -\isamarkuptrue%
3.76 -%
3.77 -\isadelimquote
3.78 -%
3.79 -\endisadelimquote
3.80 -%
3.81 -\isatagquote
3.82 -\isacommand{lemma}\isamarkupfalse%
3.83 -\ order{\isacharunderscore}prod{\isacharunderscore}code\ {\isacharbrackleft}code{\isacharbrackright}{\isacharcolon}\isanewline
3.84 -\ \ {\isachardoublequoteopen}{\isacharparenleft}x{\isadigit{1}}\ {\isasymColon}\ {\isacharprime}a{\isasymColon}{\isacharbraceleft}order{\isacharcomma}\ eq{\isacharbraceright}{\isacharcomma}\ y{\isadigit{1}}\ {\isasymColon}\ {\isacharprime}b{\isasymColon}order{\isacharparenright}\ {\isacharless}\ {\isacharparenleft}x{\isadigit{2}}{\isacharcomma}\ y{\isadigit{2}}{\isacharparenright}\ {\isasymlongleftrightarrow}\isanewline
3.85 -\ \ \ \ \ x{\isadigit{1}}\ {\isacharless}\ x{\isadigit{2}}\ {\isasymor}\ x{\isadigit{1}}\ {\isacharequal}\ x{\isadigit{2}}\ {\isasymand}\ y{\isadigit{1}}\ {\isacharless}\ y{\isadigit{2}}{\isachardoublequoteclose}\isanewline
3.86 -\ \ {\isachardoublequoteopen}{\isacharparenleft}x{\isadigit{1}}\ {\isasymColon}\ {\isacharprime}a{\isasymColon}{\isacharbraceleft}order{\isacharcomma}\ eq{\isacharbraceright}{\isacharcomma}\ y{\isadigit{1}}\ {\isasymColon}\ {\isacharprime}b{\isasymColon}order{\isacharparenright}\ {\isasymle}\ {\isacharparenleft}x{\isadigit{2}}{\isacharcomma}\ y{\isadigit{2}}{\isacharparenright}\ {\isasymlongleftrightarrow}\isanewline
3.87 -\ \ \ \ \ x{\isadigit{1}}\ {\isacharless}\ x{\isadigit{2}}\ {\isasymor}\ x{\isadigit{1}}\ {\isacharequal}\ x{\isadigit{2}}\ {\isasymand}\ y{\isadigit{1}}\ {\isasymle}\ y{\isadigit{2}}{\isachardoublequoteclose}\isanewline
3.88 -\ \ \isacommand{by}\isamarkupfalse%
3.89 -\ {\isacharparenleft}simp{\isacharunderscore}all\ add{\isacharcolon}\ less{\isacharunderscore}prod{\isacharunderscore}def\ less{\isacharunderscore}eq{\isacharunderscore}prod{\isacharunderscore}def{\isacharparenright}%
3.90 -\endisatagquote
3.91 -{\isafoldquote}%
3.92 -%
3.93 -\isadelimquote
3.94 -%
3.95 -\endisadelimquote
3.96 -%
3.97 -\begin{isamarkuptext}%
3.98 -\noindent Then code generation succeeds:%
3.99 -\end{isamarkuptext}%
3.100 -\isamarkuptrue%
3.101 -%
3.102 -\isadelimquote
3.103 -%
3.104 -\endisadelimquote
3.105 -%
3.106 -\isatagquote
3.107 -%
3.108 -\begin{isamarkuptext}%
3.109 -\isatypewriter%
3.110 -\noindent%
3.111 -\hspace*{0pt}structure Example = \\
3.112 -\hspace*{0pt}struct\\
3.113 -\hspace*{0pt}\\
3.114 -\hspace*{0pt}type 'a eq = {\char123}eq :~'a -> 'a -> bool{\char125};\\
3.115 -\hspace*{0pt}fun eq (A{\char95}:'a eq) = {\char35}eq A{\char95};\\
3.116 -\hspace*{0pt}\\
3.117 -\hspace*{0pt}type 'a ord = {\char123}less{\char95}eq :~'a -> 'a -> bool,~less :~'a -> 'a -> bool{\char125};\\
3.118 -\hspace*{0pt}fun less{\char95}eq (A{\char95}:'a ord) = {\char35}less{\char95}eq A{\char95};\\
3.119 -\hspace*{0pt}fun less (A{\char95}:'a ord) = {\char35}less A{\char95};\\
3.120 -\hspace*{0pt}\\
3.121 -\hspace*{0pt}fun eqop A{\char95}~a b = eq A{\char95}~a b;\\
3.122 -\hspace*{0pt}\\
3.123 -\hspace*{0pt}type 'a preorder = {\char123}Orderings{\char95}{\char95}ord{\char95}preorder :~'a ord{\char125};\\
3.124 -\hspace*{0pt}fun ord{\char95}preorder (A{\char95}:'a preorder) = {\char35}Orderings{\char95}{\char95}ord{\char95}preorder A{\char95};\\
3.125 -\hspace*{0pt}\\
3.126 -\hspace*{0pt}type 'a order = {\char123}Orderings{\char95}{\char95}preorder{\char95}order :~'a preorder{\char125};\\
3.127 -\hspace*{0pt}fun preorder{\char95}order (A{\char95}:'a order) = {\char35}Orderings{\char95}{\char95}preorder{\char95}order A{\char95};\\
3.128 -\hspace*{0pt}\\
3.129 -\hspace*{0pt}fun less{\char95}eqa (A1{\char95},~A2{\char95}) B{\char95}~(x1,~y1) (x2,~y2) =\\
3.130 -\hspace*{0pt} ~less ((ord{\char95}preorder o preorder{\char95}order) A2{\char95}) x1 x2 orelse\\
3.131 -\hspace*{0pt} ~~~eqop A1{\char95}~x1 x2 andalso\\
3.132 -\hspace*{0pt} ~~~~~less{\char95}eq ((ord{\char95}preorder o preorder{\char95}order) B{\char95}) y1 y2\\
3.133 -\hspace*{0pt} ~| less{\char95}eqa (A1{\char95},~A2{\char95}) B{\char95}~(x1,~y1) (x2,~y2) =\\
3.134 -\hspace*{0pt} ~~~less ((ord{\char95}preorder o preorder{\char95}order) A2{\char95}) x1 x2 orelse\\
3.135 -\hspace*{0pt} ~~~~~eqop A1{\char95}~x1 x2 andalso\\
3.136 -\hspace*{0pt} ~~~~~~~less{\char95}eq ((ord{\char95}preorder o preorder{\char95}order) B{\char95}) y1 y2;\\
3.137 -\hspace*{0pt}\\
3.138 -\hspace*{0pt}end;~(*struct Example*)%
3.139 -\end{isamarkuptext}%
3.140 -\isamarkuptrue%
3.141 -%
3.142 -\endisatagquote
3.143 -{\isafoldquote}%
3.144 -%
3.145 -\isadelimquote
3.146 -%
3.147 -\endisadelimquote
3.148 -%
3.149 -\begin{isamarkuptext}%
3.150 -In some cases, the automatically derived code equations
3.151 + the way, in some cases the automatically derived code equations
3.152 for equality on a particular type may not be appropriate.
3.153 As example, watch the following datatype representing
3.154 monomorphic parametric types (where type constructors
4.1 --- a/doc-src/TutorialI/tutorial.tex Mon Apr 20 12:27:23 2009 +0200
4.2 +++ b/doc-src/TutorialI/tutorial.tex Mon Apr 20 16:28:13 2009 +0200
4.3 @@ -39,10 +39,11 @@
4.4 %University of Cambridge\\
4.5 %Computer Laboratory
4.6 }
4.7 +\pagenumbering{roman}
4.8 \maketitle
4.9 +\newpage
4.10
4.11 -\pagenumbering{roman}
4.12 -\setcounter{page}{5}
4.13 +%\setcounter{page}{5}
4.14 %\vspace*{\fill}
4.15 %\begin{center}
4.16 %\LARGE In memoriam \\[1ex]
4.17 @@ -52,6 +53,7 @@
4.18 %\vspace*{\fill}
4.19 %\vspace*{\fill}
4.20 %\newpage
4.21 +
4.22 \include{preface}
4.23
4.24 \tableofcontents
5.1 --- a/src/HOL/Bali/Trans.thy Mon Apr 20 12:27:23 2009 +0200
5.2 +++ b/src/HOL/Bali/Trans.thy Mon Apr 20 16:28:13 2009 +0200
5.3 @@ -359,7 +359,7 @@
5.4
5.5 abbreviation
5.6 stepn:: "[prog, term \<times> state,nat,term \<times> state] \<Rightarrow> bool" ("_\<turnstile>_ \<mapsto>_ _"[61,82,82] 81)
5.7 - where "G\<turnstile>p \<mapsto>n p' \<equiv> (p,p') \<in> {(x, y). step G x y}^n"
5.8 + where "G\<turnstile>p \<mapsto>n p' \<equiv> (p,p') \<in> {(x, y). step G x y}^^n"
5.9
5.10 abbreviation
5.11 steptr:: "[prog,term \<times> state,term \<times> state] \<Rightarrow> bool" ("_\<turnstile>_ \<mapsto>* _"[61,82,82] 81)
5.12 @@ -370,25 +370,6 @@
5.13 Smallstep zu Bigstep, nur wenn nicht die Ausdrücke Callee, FinA ,\<dots>
5.14 *)
5.15
5.16 -lemma rtrancl_imp_rel_pow: "p \<in> R^* \<Longrightarrow> \<exists>n. p \<in> R^n"
5.17 -proof -
5.18 - assume "p \<in> R\<^sup>*"
5.19 - moreover obtain x y where p: "p = (x,y)" by (cases p)
5.20 - ultimately have "(x,y) \<in> R\<^sup>*" by hypsubst
5.21 - hence "\<exists>n. (x,y) \<in> R^n"
5.22 - proof induct
5.23 - fix a have "(a,a) \<in> R^0" by simp
5.24 - thus "\<exists>n. (a,a) \<in> R ^ n" ..
5.25 - next
5.26 - fix a b c assume "\<exists>n. (a,b) \<in> R ^ n"
5.27 - then obtain n where "(a,b) \<in> R^n" ..
5.28 - moreover assume "(b,c) \<in> R"
5.29 - ultimately have "(a,c) \<in> R^(Suc n)" by auto
5.30 - thus "\<exists>n. (a,c) \<in> R^n" ..
5.31 - qed
5.32 - with p show ?thesis by hypsubst
5.33 -qed
5.34 -
5.35 (*
5.36 lemma imp_eval_trans:
5.37 assumes eval: "G\<turnstile>s0 \<midarrow>t\<succ>\<rightarrow> (v,s1)"
6.1 --- a/src/HOL/Code_Eval.thy Mon Apr 20 12:27:23 2009 +0200
6.2 +++ b/src/HOL/Code_Eval.thy Mon Apr 20 16:28:13 2009 +0200
6.3 @@ -175,8 +175,7 @@
6.4 fun eval_term thy t =
6.5 t
6.6 |> Eval.mk_term_of (fastype_of t)
6.7 - |> (fn t => Code_ML.eval_term ("Eval.eval_ref", eval_ref) thy t [])
6.8 - |> Code.postprocess_term thy;
6.9 + |> (fn t => Code_ML.eval_term NONE ("Eval.eval_ref", eval_ref) thy t []);
6.10
6.11 end;
6.12 *}
7.1 --- a/src/HOL/Code_Setup.thy Mon Apr 20 12:27:23 2009 +0200
7.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
7.3 @@ -1,253 +0,0 @@
7.4 -(* Title: HOL/Code_Setup.thy
7.5 - ID: $Id$
7.6 - Author: Florian Haftmann
7.7 -*)
7.8 -
7.9 -header {* Setup of code generators and related tools *}
7.10 -
7.11 -theory Code_Setup
7.12 -imports HOL
7.13 -begin
7.14 -
7.15 -subsection {* Generic code generator foundation *}
7.16 -
7.17 -text {* Datatypes *}
7.18 -
7.19 -code_datatype True False
7.20 -
7.21 -code_datatype "TYPE('a\<Colon>{})"
7.22 -
7.23 -code_datatype Trueprop "prop"
7.24 -
7.25 -text {* Code equations *}
7.26 -
7.27 -lemma [code]:
7.28 - shows "(True \<Longrightarrow> PROP P) \<equiv> PROP P"
7.29 - and "(False \<Longrightarrow> Q) \<equiv> Trueprop True"
7.30 - and "(PROP P \<Longrightarrow> True) \<equiv> Trueprop True"
7.31 - and "(Q \<Longrightarrow> False) \<equiv> Trueprop (\<not> Q)" by (auto intro!: equal_intr_rule)
7.32 -
7.33 -lemma [code]:
7.34 - shows "False \<and> x \<longleftrightarrow> False"
7.35 - and "True \<and> x \<longleftrightarrow> x"
7.36 - and "x \<and> False \<longleftrightarrow> False"
7.37 - and "x \<and> True \<longleftrightarrow> x" by simp_all
7.38 -
7.39 -lemma [code]:
7.40 - shows "False \<or> x \<longleftrightarrow> x"
7.41 - and "True \<or> x \<longleftrightarrow> True"
7.42 - and "x \<or> False \<longleftrightarrow> x"
7.43 - and "x \<or> True \<longleftrightarrow> True" by simp_all
7.44 -
7.45 -lemma [code]:
7.46 - shows "\<not> True \<longleftrightarrow> False"
7.47 - and "\<not> False \<longleftrightarrow> True" by (rule HOL.simp_thms)+
7.48 -
7.49 -lemmas [code] = Let_def if_True if_False
7.50 -
7.51 -lemmas [code, code unfold, symmetric, code post] = imp_conv_disj
7.52 -
7.53 -text {* Equality *}
7.54 -
7.55 -context eq
7.56 -begin
7.57 -
7.58 -lemma equals_eq [code inline, code]: "op = \<equiv> eq"
7.59 - by (rule eq_reflection) (rule ext, rule ext, rule sym, rule eq_equals)
7.60 -
7.61 -declare eq [code unfold, code inline del]
7.62 -
7.63 -declare equals_eq [symmetric, code post]
7.64 -
7.65 -end
7.66 -
7.67 -declare simp_thms(6) [code nbe]
7.68 -
7.69 -hide (open) const eq
7.70 -hide const eq
7.71 -
7.72 -setup {*
7.73 - Code_Unit.add_const_alias @{thm equals_eq}
7.74 -*}
7.75 -
7.76 -text {* Cases *}
7.77 -
7.78 -lemma Let_case_cert:
7.79 - assumes "CASE \<equiv> (\<lambda>x. Let x f)"
7.80 - shows "CASE x \<equiv> f x"
7.81 - using assms by simp_all
7.82 -
7.83 -lemma If_case_cert:
7.84 - assumes "CASE \<equiv> (\<lambda>b. If b f g)"
7.85 - shows "(CASE True \<equiv> f) &&& (CASE False \<equiv> g)"
7.86 - using assms by simp_all
7.87 -
7.88 -setup {*
7.89 - Code.add_case @{thm Let_case_cert}
7.90 - #> Code.add_case @{thm If_case_cert}
7.91 - #> Code.add_undefined @{const_name undefined}
7.92 -*}
7.93 -
7.94 -code_abort undefined
7.95 -
7.96 -
7.97 -subsection {* Generic code generator preprocessor *}
7.98 -
7.99 -setup {*
7.100 - Code.map_pre (K HOL_basic_ss)
7.101 - #> Code.map_post (K HOL_basic_ss)
7.102 -*}
7.103 -
7.104 -
7.105 -subsection {* Generic code generator target languages *}
7.106 -
7.107 -text {* type bool *}
7.108 -
7.109 -code_type bool
7.110 - (SML "bool")
7.111 - (OCaml "bool")
7.112 - (Haskell "Bool")
7.113 -
7.114 -code_const True and False and Not and "op &" and "op |" and If
7.115 - (SML "true" and "false" and "not"
7.116 - and infixl 1 "andalso" and infixl 0 "orelse"
7.117 - and "!(if (_)/ then (_)/ else (_))")
7.118 - (OCaml "true" and "false" and "not"
7.119 - and infixl 4 "&&" and infixl 2 "||"
7.120 - and "!(if (_)/ then (_)/ else (_))")
7.121 - (Haskell "True" and "False" and "not"
7.122 - and infixl 3 "&&" and infixl 2 "||"
7.123 - and "!(if (_)/ then (_)/ else (_))")
7.124 -
7.125 -code_reserved SML
7.126 - bool true false not
7.127 -
7.128 -code_reserved OCaml
7.129 - bool not
7.130 -
7.131 -text {* using built-in Haskell equality *}
7.132 -
7.133 -code_class eq
7.134 - (Haskell "Eq")
7.135 -
7.136 -code_const "eq_class.eq"
7.137 - (Haskell infixl 4 "==")
7.138 -
7.139 -code_const "op ="
7.140 - (Haskell infixl 4 "==")
7.141 -
7.142 -text {* undefined *}
7.143 -
7.144 -code_const undefined
7.145 - (SML "!(raise/ Fail/ \"undefined\")")
7.146 - (OCaml "failwith/ \"undefined\"")
7.147 - (Haskell "error/ \"undefined\"")
7.148 -
7.149 -
7.150 -subsection {* SML code generator setup *}
7.151 -
7.152 -types_code
7.153 - "bool" ("bool")
7.154 -attach (term_of) {*
7.155 -fun term_of_bool b = if b then HOLogic.true_const else HOLogic.false_const;
7.156 -*}
7.157 -attach (test) {*
7.158 -fun gen_bool i =
7.159 - let val b = one_of [false, true]
7.160 - in (b, fn () => term_of_bool b) end;
7.161 -*}
7.162 - "prop" ("bool")
7.163 -attach (term_of) {*
7.164 -fun term_of_prop b =
7.165 - HOLogic.mk_Trueprop (if b then HOLogic.true_const else HOLogic.false_const);
7.166 -*}
7.167 -
7.168 -consts_code
7.169 - "Trueprop" ("(_)")
7.170 - "True" ("true")
7.171 - "False" ("false")
7.172 - "Not" ("Bool.not")
7.173 - "op |" ("(_ orelse/ _)")
7.174 - "op &" ("(_ andalso/ _)")
7.175 - "If" ("(if _/ then _/ else _)")
7.176 -
7.177 -setup {*
7.178 -let
7.179 -
7.180 -fun eq_codegen thy defs dep thyname b t gr =
7.181 - (case strip_comb t of
7.182 - (Const ("op =", Type (_, [Type ("fun", _), _])), _) => NONE
7.183 - | (Const ("op =", _), [t, u]) =>
7.184 - let
7.185 - val (pt, gr') = Codegen.invoke_codegen thy defs dep thyname false t gr;
7.186 - val (pu, gr'') = Codegen.invoke_codegen thy defs dep thyname false u gr';
7.187 - val (_, gr''') = Codegen.invoke_tycodegen thy defs dep thyname false HOLogic.boolT gr'';
7.188 - in
7.189 - SOME (Codegen.parens
7.190 - (Pretty.block [pt, Codegen.str " =", Pretty.brk 1, pu]), gr''')
7.191 - end
7.192 - | (t as Const ("op =", _), ts) => SOME (Codegen.invoke_codegen
7.193 - thy defs dep thyname b (Codegen.eta_expand t ts 2) gr)
7.194 - | _ => NONE);
7.195 -
7.196 -in
7.197 - Codegen.add_codegen "eq_codegen" eq_codegen
7.198 -end
7.199 -*}
7.200 -
7.201 -
7.202 -subsection {* Evaluation and normalization by evaluation *}
7.203 -
7.204 -setup {*
7.205 - Value.add_evaluator ("SML", Codegen.eval_term o ProofContext.theory_of)
7.206 -*}
7.207 -
7.208 -ML {*
7.209 -structure Eval_Method =
7.210 -struct
7.211 -
7.212 -val eval_ref : (unit -> bool) option ref = ref NONE;
7.213 -
7.214 -end;
7.215 -*}
7.216 -
7.217 -oracle eval_oracle = {* fn ct =>
7.218 - let
7.219 - val thy = Thm.theory_of_cterm ct;
7.220 - val t = Thm.term_of ct;
7.221 - val dummy = @{cprop True};
7.222 - in case try HOLogic.dest_Trueprop t
7.223 - of SOME t' => if Code_ML.eval_term
7.224 - ("Eval_Method.eval_ref", Eval_Method.eval_ref) thy t' []
7.225 - then Thm.capply (Thm.capply @{cterm "op \<equiv> \<Colon> prop \<Rightarrow> prop \<Rightarrow> prop"} ct) dummy
7.226 - else dummy
7.227 - | NONE => dummy
7.228 - end
7.229 -*}
7.230 -
7.231 -ML {*
7.232 -fun gen_eval_method conv ctxt = SIMPLE_METHOD'
7.233 - (CONVERSION (Conv.params_conv (~1) (K (Conv.concl_conv (~1) conv)) ctxt)
7.234 - THEN' rtac TrueI)
7.235 -*}
7.236 -
7.237 -method_setup eval = {* Scan.succeed (gen_eval_method eval_oracle) *}
7.238 - "solve goal by evaluation"
7.239 -
7.240 -method_setup evaluation = {* Scan.succeed (gen_eval_method Codegen.evaluation_conv) *}
7.241 - "solve goal by evaluation"
7.242 -
7.243 -method_setup normalization = {*
7.244 - Scan.succeed (K (SIMPLE_METHOD' (CONVERSION Nbe.norm_conv THEN' (fn k => TRY (rtac TrueI k)))))
7.245 -*} "solve goal by normalization"
7.246 -
7.247 -
7.248 -subsection {* Quickcheck *}
7.249 -
7.250 -setup {*
7.251 - Quickcheck.add_generator ("SML", Codegen.test_term)
7.252 -*}
7.253 -
7.254 -quickcheck_params [size = 5, iterations = 50]
7.255 -
7.256 -end
8.1 --- a/src/HOL/Decision_Procs/Approximation.thy Mon Apr 20 12:27:23 2009 +0200
8.2 +++ b/src/HOL/Decision_Procs/Approximation.thy Mon Apr 20 16:28:13 2009 +0200
8.3 @@ -23,8 +23,8 @@
8.4 qed
8.5
8.6 lemma horner_schema: fixes f :: "nat \<Rightarrow> nat" and G :: "nat \<Rightarrow> nat \<Rightarrow> nat" and F :: "nat \<Rightarrow> nat"
8.7 - assumes f_Suc: "\<And>n. f (Suc n) = G ((F^n) s) (f n)"
8.8 - shows "horner F G n ((F^j') s) (f j') x = (\<Sum> j = 0..< n. -1^j * (1 / real (f (j' + j))) * x^j)"
8.9 + assumes f_Suc: "\<And>n. f (Suc n) = G ((F o^ n) s) (f n)"
8.10 + shows "horner F G n ((F o^ j') s) (f j') x = (\<Sum> j = 0..< n. -1 ^ j * (1 / real (f (j' + j))) * x ^ j)"
8.11 proof (induct n arbitrary: i k j')
8.12 case (Suc n)
8.13
8.14 @@ -33,13 +33,13 @@
8.15 qed auto
8.16
8.17 lemma horner_bounds':
8.18 - assumes "0 \<le> Ifloat x" and f_Suc: "\<And>n. f (Suc n) = G ((F^n) s) (f n)"
8.19 + assumes "0 \<le> Ifloat x" and f_Suc: "\<And>n. f (Suc n) = G ((F o^ n) s) (f n)"
8.20 and lb_0: "\<And> i k x. lb 0 i k x = 0"
8.21 and lb_Suc: "\<And> n i k x. lb (Suc n) i k x = lapprox_rat prec 1 (int k) - x * (ub n (F i) (G i k) x)"
8.22 and ub_0: "\<And> i k x. ub 0 i k x = 0"
8.23 and ub_Suc: "\<And> n i k x. ub (Suc n) i k x = rapprox_rat prec 1 (int k) - x * (lb n (F i) (G i k) x)"
8.24 - shows "Ifloat (lb n ((F^j') s) (f j') x) \<le> horner F G n ((F^j') s) (f j') (Ifloat x) \<and>
8.25 - horner F G n ((F^j') s) (f j') (Ifloat x) \<le> Ifloat (ub n ((F^j') s) (f j') x)"
8.26 + shows "Ifloat (lb n ((F o^ j') s) (f j') x) \<le> horner F G n ((F o^ j') s) (f j') (Ifloat x) \<and>
8.27 + horner F G n ((F o^ j') s) (f j') (Ifloat x) \<le> Ifloat (ub n ((F o^ j') s) (f j') x)"
8.28 (is "?lb n j' \<le> ?horner n j' \<and> ?horner n j' \<le> ?ub n j'")
8.29 proof (induct n arbitrary: j')
8.30 case 0 thus ?case unfolding lb_0 ub_0 horner.simps by auto
8.31 @@ -49,15 +49,15 @@
8.32 proof (rule add_mono)
8.33 show "Ifloat (lapprox_rat prec 1 (int (f j'))) \<le> 1 / real (f j')" using lapprox_rat[of prec 1 "int (f j')"] by auto
8.34 from Suc[where j'="Suc j'", unfolded funpow.simps comp_def f_Suc, THEN conjunct2] `0 \<le> Ifloat x`
8.35 - show "- Ifloat (x * ub n (F ((F ^ j') s)) (G ((F ^ j') s) (f j')) x) \<le> - (Ifloat x * horner F G n (F ((F ^ j') s)) (G ((F ^ j') s) (f j')) (Ifloat x))"
8.36 + show "- Ifloat (x * ub n (F ((F o^ j') s)) (G ((F o^ j') s) (f j')) x) \<le> - (Ifloat x * horner F G n (F ((F o^ j') s)) (G ((F o^ j') s) (f j')) (Ifloat x))"
8.37 unfolding Ifloat_mult neg_le_iff_le by (rule mult_left_mono)
8.38 qed
8.39 moreover have "?horner (Suc n) j' \<le> ?ub (Suc n) j'" unfolding ub_Suc ub_Suc horner.simps Ifloat_sub diff_def
8.40 proof (rule add_mono)
8.41 show "1 / real (f j') \<le> Ifloat (rapprox_rat prec 1 (int (f j')))" using rapprox_rat[of 1 "int (f j')" prec] by auto
8.42 from Suc[where j'="Suc j'", unfolded funpow.simps comp_def f_Suc, THEN conjunct1] `0 \<le> Ifloat x`
8.43 - show "- (Ifloat x * horner F G n (F ((F ^ j') s)) (G ((F ^ j') s) (f j')) (Ifloat x)) \<le>
8.44 - - Ifloat (x * lb n (F ((F ^ j') s)) (G ((F ^ j') s) (f j')) x)"
8.45 + show "- (Ifloat x * horner F G n (F ((F o^ j') s)) (G ((F o^ j') s) (f j')) (Ifloat x)) \<le>
8.46 + - Ifloat (x * lb n (F ((F o^ j') s)) (G ((F o^ j') s) (f j')) x)"
8.47 unfolding Ifloat_mult neg_le_iff_le by (rule mult_left_mono)
8.48 qed
8.49 ultimately show ?case by blast
8.50 @@ -73,13 +73,13 @@
8.51 *}
8.52
8.53 lemma horner_bounds: fixes F :: "nat \<Rightarrow> nat" and G :: "nat \<Rightarrow> nat \<Rightarrow> nat"
8.54 - assumes "0 \<le> Ifloat x" and f_Suc: "\<And>n. f (Suc n) = G ((F^n) s) (f n)"
8.55 + assumes "0 \<le> Ifloat x" and f_Suc: "\<And>n. f (Suc n) = G ((F o^ n) s) (f n)"
8.56 and lb_0: "\<And> i k x. lb 0 i k x = 0"
8.57 and lb_Suc: "\<And> n i k x. lb (Suc n) i k x = lapprox_rat prec 1 (int k) - x * (ub n (F i) (G i k) x)"
8.58 and ub_0: "\<And> i k x. ub 0 i k x = 0"
8.59 and ub_Suc: "\<And> n i k x. ub (Suc n) i k x = rapprox_rat prec 1 (int k) - x * (lb n (F i) (G i k) x)"
8.60 - shows "Ifloat (lb n ((F^j') s) (f j') x) \<le> (\<Sum>j=0..<n. -1^j * (1 / real (f (j' + j))) * (Ifloat x)^j)" (is "?lb") and
8.61 - "(\<Sum>j=0..<n. -1^j * (1 / real (f (j' + j))) * (Ifloat x)^j) \<le> Ifloat (ub n ((F^j') s) (f j') x)" (is "?ub")
8.62 + shows "Ifloat (lb n ((F o^ j') s) (f j') x) \<le> (\<Sum>j=0..<n. -1 ^ j * (1 / real (f (j' + j))) * Ifloat x ^ j)" (is "?lb") and
8.63 + "(\<Sum>j=0..<n. -1 ^ j * (1 / real (f (j' + j))) * (Ifloat x ^ j)) \<le> Ifloat (ub n ((F o^ j') s) (f j') x)" (is "?ub")
8.64 proof -
8.65 have "?lb \<and> ?ub"
8.66 using horner_bounds'[where lb=lb, OF `0 \<le> Ifloat x` f_Suc lb_0 lb_Suc ub_0 ub_Suc]
8.67 @@ -88,13 +88,13 @@
8.68 qed
8.69
8.70 lemma horner_bounds_nonpos: fixes F :: "nat \<Rightarrow> nat" and G :: "nat \<Rightarrow> nat \<Rightarrow> nat"
8.71 - assumes "Ifloat x \<le> 0" and f_Suc: "\<And>n. f (Suc n) = G ((F^n) s) (f n)"
8.72 + assumes "Ifloat x \<le> 0" and f_Suc: "\<And>n. f (Suc n) = G ((F o^ n) s) (f n)"
8.73 and lb_0: "\<And> i k x. lb 0 i k x = 0"
8.74 and lb_Suc: "\<And> n i k x. lb (Suc n) i k x = lapprox_rat prec 1 (int k) + x * (ub n (F i) (G i k) x)"
8.75 and ub_0: "\<And> i k x. ub 0 i k x = 0"
8.76 and ub_Suc: "\<And> n i k x. ub (Suc n) i k x = rapprox_rat prec 1 (int k) + x * (lb n (F i) (G i k) x)"
8.77 - shows "Ifloat (lb n ((F^j') s) (f j') x) \<le> (\<Sum>j=0..<n. (1 / real (f (j' + j))) * (Ifloat x)^j)" (is "?lb") and
8.78 - "(\<Sum>j=0..<n. (1 / real (f (j' + j))) * (Ifloat x)^j) \<le> Ifloat (ub n ((F^j') s) (f j') x)" (is "?ub")
8.79 + shows "Ifloat (lb n ((F o^ j') s) (f j') x) \<le> (\<Sum>j=0..<n. (1 / real (f (j' + j))) * Ifloat x ^ j)" (is "?lb") and
8.80 + "(\<Sum>j=0..<n. (1 / real (f (j' + j))) * (Ifloat x ^ j)) \<le> Ifloat (ub n ((F o^ j') s) (f j') x)" (is "?ub")
8.81 proof -
8.82 { fix x y z :: float have "x - y * z = x + - y * z"
8.83 by (cases x, cases y, cases z, simp add: plus_float.simps minus_float.simps uminus_float.simps times_float.simps algebra_simps)
8.84 @@ -104,13 +104,13 @@
8.85
8.86 have move_minus: "Ifloat (-x) = -1 * Ifloat x" by auto
8.87
8.88 - have sum_eq: "(\<Sum>j=0..<n. (1 / real (f (j' + j))) * (Ifloat x)^j) =
8.89 + have sum_eq: "(\<Sum>j=0..<n. (1 / real (f (j' + j))) * Ifloat x ^ j) =
8.90 (\<Sum>j = 0..<n. -1 ^ j * (1 / real (f (j' + j))) * Ifloat (- x) ^ j)"
8.91 proof (rule setsum_cong, simp)
8.92 fix j assume "j \<in> {0 ..< n}"
8.93 show "1 / real (f (j' + j)) * Ifloat x ^ j = -1 ^ j * (1 / real (f (j' + j))) * Ifloat (- x) ^ j"
8.94 unfolding move_minus power_mult_distrib real_mult_assoc[symmetric]
8.95 - unfolding real_mult_commute unfolding real_mult_assoc[of "-1^j", symmetric] power_mult_distrib[symmetric]
8.96 + unfolding real_mult_commute unfolding real_mult_assoc[of "-1 ^ j", symmetric] power_mult_distrib[symmetric]
8.97 by auto
8.98 qed
8.99
8.100 @@ -160,21 +160,21 @@
8.101 else (0, (max (-l) u) ^ n))"
8.102
8.103 lemma float_power_bnds: assumes "(l1, u1) = float_power_bnds n l u" and "x \<in> {Ifloat l .. Ifloat u}"
8.104 - shows "x^n \<in> {Ifloat l1..Ifloat u1}"
8.105 + shows "x ^ n \<in> {Ifloat l1..Ifloat u1}"
8.106 proof (cases "even n")
8.107 case True
8.108 show ?thesis
8.109 proof (cases "0 < l")
8.110 case True hence "odd n \<or> 0 < l" and "0 \<le> Ifloat l" unfolding less_float_def by auto
8.111 have u1: "u1 = u ^ n" and l1: "l1 = l ^ n" using assms unfolding float_power_bnds_def if_P[OF `odd n \<or> 0 < l`] by auto
8.112 - have "Ifloat l^n \<le> x^n" and "x^n \<le> Ifloat u^n " using `0 \<le> Ifloat l` and assms unfolding atLeastAtMost_iff using power_mono[of "Ifloat l" x] power_mono[of x "Ifloat u"] by auto
8.113 + have "Ifloat l ^ n \<le> x ^ n" and "x ^ n \<le> Ifloat u ^ n " using `0 \<le> Ifloat l` and assms unfolding atLeastAtMost_iff using power_mono[of "Ifloat l" x] power_mono[of x "Ifloat u"] by auto
8.114 thus ?thesis using assms `0 < l` unfolding atLeastAtMost_iff l1 u1 float_power less_float_def by auto
8.115 next
8.116 case False hence P: "\<not> (odd n \<or> 0 < l)" using `even n` by auto
8.117 show ?thesis
8.118 proof (cases "u < 0")
8.119 case True hence "0 \<le> - Ifloat u" and "- Ifloat u \<le> - x" and "0 \<le> - x" and "-x \<le> - Ifloat l" using assms unfolding less_float_def by auto
8.120 - hence "Ifloat u^n \<le> x^n" and "x^n \<le> Ifloat l^n" using power_mono[of "-x" "-Ifloat l" n] power_mono[of "-Ifloat u" "-x" n]
8.121 + hence "Ifloat u ^ n \<le> x ^ n" and "x ^ n \<le> Ifloat l ^ n" using power_mono[of "-x" "-Ifloat l" n] power_mono[of "-Ifloat u" "-x" n]
8.122 unfolding power_minus_even[OF `even n`] by auto
8.123 moreover have u1: "u1 = l ^ n" and l1: "l1 = u ^ n" using assms unfolding float_power_bnds_def if_not_P[OF P] if_P[OF True] by auto
8.124 ultimately show ?thesis using float_power by auto
8.125 @@ -194,11 +194,11 @@
8.126 next
8.127 case False hence "odd n \<or> 0 < l" by auto
8.128 have u1: "u1 = u ^ n" and l1: "l1 = l ^ n" using assms unfolding float_power_bnds_def if_P[OF `odd n \<or> 0 < l`] by auto
8.129 - have "Ifloat l^n \<le> x^n" and "x^n \<le> Ifloat u^n " using assms unfolding atLeastAtMost_iff using power_mono_odd[OF False] by auto
8.130 + have "Ifloat l ^ n \<le> x ^ n" and "x ^ n \<le> Ifloat u ^ n " using assms unfolding atLeastAtMost_iff using power_mono_odd[OF False] by auto
8.131 thus ?thesis unfolding atLeastAtMost_iff l1 u1 float_power less_float_def by auto
8.132 qed
8.133
8.134 -lemma bnds_power: "\<forall> x l u. (l1, u1) = float_power_bnds n l u \<and> x \<in> {Ifloat l .. Ifloat u} \<longrightarrow> Ifloat l1 \<le> x^n \<and> x^n \<le> Ifloat u1"
8.135 +lemma bnds_power: "\<forall> x l u. (l1, u1) = float_power_bnds n l u \<and> x \<in> {Ifloat l .. Ifloat u} \<longrightarrow> Ifloat l1 \<le> x ^ n \<and> x ^ n \<le> Ifloat u1"
8.136 using float_power_bnds by auto
8.137
8.138 section "Square root"
8.139 @@ -794,8 +794,8 @@
8.140 let "?f n" = "fact (2 * n)"
8.141
8.142 { fix n
8.143 - have F: "\<And>m. ((\<lambda>i. i + 2) ^ n) m = m + 2 * n" by (induct n arbitrary: m, auto)
8.144 - have "?f (Suc n) = ?f n * ((\<lambda>i. i + 2) ^ n) 1 * (((\<lambda>i. i + 2) ^ n) 1 + 1)"
8.145 + have F: "\<And>m. ((\<lambda>i. i + 2) o^ n) m = m + 2 * n" by (induct n arbitrary: m, auto)
8.146 + have "?f (Suc n) = ?f n * ((\<lambda>i. i + 2) o^ n) 1 * (((\<lambda>i. i + 2) o^ n) 1 + 1)"
8.147 unfolding F by auto } note f_eq = this
8.148
8.149 from horner_bounds[where lb="lb_sin_cos_aux prec" and ub="ub_sin_cos_aux prec" and j'=0,
8.150 @@ -811,7 +811,7 @@
8.151 have "0 < x * x" using `0 < x` unfolding less_float_def Ifloat_mult Ifloat_0
8.152 using mult_pos_pos[where a="Ifloat x" and b="Ifloat x"] by auto
8.153
8.154 - { fix x n have "(\<Sum> i=0..<n. -1^i * (1/real (fact (2 * i))) * x^(2 * i))
8.155 + { fix x n have "(\<Sum> i=0..<n. -1^i * (1/real (fact (2 * i))) * x ^ (2 * i))
8.156 = (\<Sum> i = 0 ..< 2 * n. (if even(i) then (-1 ^ (i div 2))/(real (fact i)) else 0) * x ^ i)" (is "?sum = ?ifsum")
8.157 proof -
8.158 have "?sum = ?sum + (\<Sum> j = 0 ..< n. 0)" by auto
8.159 @@ -905,8 +905,8 @@
8.160 let "?f n" = "fact (2 * n + 1)"
8.161
8.162 { fix n
8.163 - have F: "\<And>m. ((\<lambda>i. i + 2) ^ n) m = m + 2 * n" by (induct n arbitrary: m, auto)
8.164 - have "?f (Suc n) = ?f n * ((\<lambda>i. i + 2) ^ n) 2 * (((\<lambda>i. i + 2) ^ n) 2 + 1)"
8.165 + have F: "\<And>m. ((\<lambda>i. i + 2) o^ n) m = m + 2 * n" by (induct n arbitrary: m, auto)
8.166 + have "?f (Suc n) = ?f n * ((\<lambda>i. i + 2) o^ n) 2 * (((\<lambda>i. i + 2) o^ n) 2 + 1)"
8.167 unfolding F by auto } note f_eq = this
8.168
8.169 from horner_bounds[where lb="lb_sin_cos_aux prec" and ub="ub_sin_cos_aux prec" and j'=0,
8.170 @@ -1382,8 +1382,8 @@
8.171 shows "exp (Ifloat x) \<in> { Ifloat (lb_exp_horner prec (get_even n) 1 1 x) .. Ifloat (ub_exp_horner prec (get_odd n) 1 1 x) }"
8.172 proof -
8.173 { fix n
8.174 - have F: "\<And> m. ((\<lambda>i. i + 1) ^ n) m = n + m" by (induct n, auto)
8.175 - have "fact (Suc n) = fact n * ((\<lambda>i. i + 1) ^ n) 1" unfolding F by auto } note f_eq = this
8.176 + have F: "\<And> m. ((\<lambda>i. i + 1) o^ n) m = n + m" by (induct n, auto)
8.177 + have "fact (Suc n) = fact n * ((\<lambda>i. i + 1) o^ n) 1" unfolding F by auto } note f_eq = this
8.178
8.179 note bounds = horner_bounds_nonpos[where f="fact" and lb="lb_exp_horner prec" and ub="ub_exp_horner prec" and j'=0 and s=1,
8.180 OF assms f_eq lb_exp_horner.simps ub_exp_horner.simps]
8.181 @@ -1631,10 +1631,10 @@
8.182
8.183 lemma ln_bounds:
8.184 assumes "0 \<le> x" and "x < 1"
8.185 - shows "(\<Sum>i=0..<2*n. -1^i * (1 / real (i + 1)) * x^(Suc i)) \<le> ln (x + 1)" (is "?lb")
8.186 - and "ln (x + 1) \<le> (\<Sum>i=0..<2*n + 1. -1^i * (1 / real (i + 1)) * x^(Suc i))" (is "?ub")
8.187 + shows "(\<Sum>i=0..<2*n. -1^i * (1 / real (i + 1)) * x ^ (Suc i)) \<le> ln (x + 1)" (is "?lb")
8.188 + and "ln (x + 1) \<le> (\<Sum>i=0..<2*n + 1. -1^i * (1 / real (i + 1)) * x ^ (Suc i))" (is "?ub")
8.189 proof -
8.190 - let "?a n" = "(1/real (n +1)) * x^(Suc n)"
8.191 + let "?a n" = "(1/real (n +1)) * x ^ (Suc n)"
8.192
8.193 have ln_eq: "(\<Sum> i. -1^i * ?a i) = ln (x + 1)"
8.194 using ln_series[of "x + 1"] `0 \<le> x` `x < 1` by auto
8.195 @@ -2479,7 +2479,7 @@
8.196 fun lift_var (Free (varname, _)) = (case AList.lookup (op =) bound_eqs varname of
8.197 SOME bound => bound
8.198 | NONE => raise TERM ("No bound equations found for " ^ varname, []))
8.199 - | lift_var t = raise TERM ("Can not convert expression " ^
8.200 + | lift_var t = raise TERM ("Can not convert expression " ^
8.201 (Syntax.string_of_term ctxt t), [t])
8.202
8.203 val _ $ vs = HOLogic.dest_Trueprop (Logic.strip_imp_concl goal')
9.1 --- a/src/HOL/Decision_Procs/cooper_tac.ML Mon Apr 20 12:27:23 2009 +0200
9.2 +++ b/src/HOL/Decision_Procs/cooper_tac.ML Mon Apr 20 16:28:13 2009 +0200
9.3 @@ -76,7 +76,7 @@
9.4 @{thm "div_by_1"}, @{thm "mod_by_1"}, @{thm "div_1"}, @{thm "mod_1"},
9.5 Suc_plus1]
9.6 addsimps @{thms add_ac}
9.7 - addsimprocs [cancel_div_mod_proc]
9.8 + addsimprocs [cancel_div_mod_nat_proc, cancel_div_mod_int_proc]
9.9 val simpset0 = HOL_basic_ss
9.10 addsimps [mod_div_equality', Suc_plus1]
9.11 addsimps comp_arith
10.1 --- a/src/HOL/Decision_Procs/mir_tac.ML Mon Apr 20 12:27:23 2009 +0200
10.2 +++ b/src/HOL/Decision_Procs/mir_tac.ML Mon Apr 20 16:28:13 2009 +0200
10.3 @@ -99,7 +99,7 @@
10.4 @{thm "div_by_1"}, @{thm "mod_by_1"}, @{thm "div_1"}, @{thm "mod_1"},
10.5 @{thm "Suc_plus1"}]
10.6 addsimps @{thms add_ac}
10.7 - addsimprocs [cancel_div_mod_proc]
10.8 + addsimprocs [cancel_div_mod_nat_proc, cancel_div_mod_int_proc]
10.9 val simpset0 = HOL_basic_ss
10.10 addsimps [mod_div_equality', Suc_plus1]
10.11 addsimps comp_ths
11.1 --- a/src/HOL/Divides.thy Mon Apr 20 12:27:23 2009 +0200
11.2 +++ b/src/HOL/Divides.thy Mon Apr 20 16:28:13 2009 +0200
11.3 @@ -1,5 +1,4 @@
11.4 (* Title: HOL/Divides.thy
11.5 - ID: $Id$
11.6 Author: Lawrence C Paulson, Cambridge University Computer Laboratory
11.7 Copyright 1999 University of Cambridge
11.8 *)
11.9 @@ -20,11 +19,12 @@
11.10
11.11 subsection {* Abstract division in commutative semirings. *}
11.12
11.13 -class semiring_div = comm_semiring_1_cancel + div +
11.14 +class semiring_div = comm_semiring_1_cancel + no_zero_divisors + div +
11.15 assumes mod_div_equality: "a div b * b + a mod b = a"
11.16 and div_by_0 [simp]: "a div 0 = 0"
11.17 and div_0 [simp]: "0 div a = 0"
11.18 and div_mult_self1 [simp]: "b \<noteq> 0 \<Longrightarrow> (a + c * b) div b = c + a div b"
11.19 + and div_mult_mult1 [simp]: "c \<noteq> 0 \<Longrightarrow> (c * a) div (c * b) = a div b"
11.20 begin
11.21
11.22 text {* @{const div} and @{const mod} *}
11.23 @@ -38,16 +38,16 @@
11.24 by (simp only: add_ac)
11.25
11.26 lemma div_mod_equality: "((a div b) * b + a mod b) + c = a + c"
11.27 -by (simp add: mod_div_equality)
11.28 + by (simp add: mod_div_equality)
11.29
11.30 lemma div_mod_equality2: "(b * (a div b) + a mod b) + c = a + c"
11.31 -by (simp add: mod_div_equality2)
11.32 + by (simp add: mod_div_equality2)
11.33
11.34 lemma mod_by_0 [simp]: "a mod 0 = a"
11.35 -using mod_div_equality [of a zero] by simp
11.36 + using mod_div_equality [of a zero] by simp
11.37
11.38 lemma mod_0 [simp]: "0 mod a = 0"
11.39 -using mod_div_equality [of zero a] div_0 by simp
11.40 + using mod_div_equality [of zero a] div_0 by simp
11.41
11.42 lemma div_mult_self2 [simp]:
11.43 assumes "b \<noteq> 0"
11.44 @@ -72,7 +72,7 @@
11.45 qed
11.46
11.47 lemma mod_mult_self2 [simp]: "(a + b * c) mod b = a mod b"
11.48 -by (simp add: mult_commute [of b])
11.49 + by (simp add: mult_commute [of b])
11.50
11.51 lemma div_mult_self1_is_id [simp]: "b \<noteq> 0 \<Longrightarrow> b * a div b = a"
11.52 using div_mult_self2 [of b 0 a] by simp
11.53 @@ -238,9 +238,9 @@
11.54 by (simp only: mod_add_eq [symmetric])
11.55 qed
11.56
11.57 -lemma div_add[simp]: "z dvd x \<Longrightarrow> z dvd y
11.58 +lemma div_add [simp]: "z dvd x \<Longrightarrow> z dvd y
11.59 \<Longrightarrow> (x + y) div z = x div z + y div z"
11.60 -by(cases "z=0", simp, unfold dvd_def, auto simp add: algebra_simps)
11.61 +by (cases "z = 0", simp, unfold dvd_def, auto simp add: algebra_simps)
11.62
11.63 text {* Multiplication respects modular equivalence. *}
11.64
11.65 @@ -297,21 +297,41 @@
11.66 finally show ?thesis .
11.67 qed
11.68
11.69 -end
11.70 -
11.71 -lemma div_mult_div_if_dvd: "(y::'a::{semiring_div,no_zero_divisors}) dvd x \<Longrightarrow>
11.72 - z dvd w \<Longrightarrow> (x div y) * (w div z) = (x * w) div (y * z)"
11.73 -unfolding dvd_def
11.74 - apply clarify
11.75 - apply (case_tac "y = 0")
11.76 - apply simp
11.77 - apply (case_tac "z = 0")
11.78 - apply simp
11.79 - apply (simp add: algebra_simps)
11.80 +lemma div_mult_div_if_dvd:
11.81 + "y dvd x \<Longrightarrow> z dvd w \<Longrightarrow> (x div y) * (w div z) = (x * w) div (y * z)"
11.82 + apply (cases "y = 0", simp)
11.83 + apply (cases "z = 0", simp)
11.84 + apply (auto elim!: dvdE simp add: algebra_simps)
11.85 apply (subst mult_assoc [symmetric])
11.86 apply (simp add: no_zero_divisors)
11.87 -done
11.88 + done
11.89
11.90 +lemma div_mult_mult2 [simp]:
11.91 + "c \<noteq> 0 \<Longrightarrow> (a * c) div (b * c) = a div b"
11.92 + by (drule div_mult_mult1) (simp add: mult_commute)
11.93 +
11.94 +lemma div_mult_mult1_if [simp]:
11.95 + "(c * a) div (c * b) = (if c = 0 then 0 else a div b)"
11.96 + by simp_all
11.97 +
11.98 +lemma mod_mult_mult1:
11.99 + "(c * a) mod (c * b) = c * (a mod b)"
11.100 +proof (cases "c = 0")
11.101 + case True then show ?thesis by simp
11.102 +next
11.103 + case False
11.104 + from mod_div_equality
11.105 + have "((c * a) div (c * b)) * (c * b) + (c * a) mod (c * b) = c * a" .
11.106 + with False have "c * ((a div b) * b + a mod b) + (c * a) mod (c * b)
11.107 + = c * a + c * (a mod b)" by (simp add: algebra_simps)
11.108 + with mod_div_equality show ?thesis by simp
11.109 +qed
11.110 +
11.111 +lemma mod_mult_mult2:
11.112 + "(a * c) mod (b * c) = (a mod b) * c"
11.113 + using mod_mult_mult1 [of c a b] by (simp add: mult_commute)
11.114 +
11.115 +end
11.116
11.117 lemma div_power: "(y::'a::{semiring_div,no_zero_divisors,recpower}) dvd x \<Longrightarrow>
11.118 (x div y)^n = x^n div y^n"
11.119 @@ -398,15 +418,17 @@
11.120 @{term "q\<Colon>nat"}(uotient) and @{term "r\<Colon>nat"}(emainder).
11.121 *}
11.122
11.123 -definition divmod_rel :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
11.124 - "divmod_rel m n q r \<longleftrightarrow> m = q * n + r \<and> (if n > 0 then 0 \<le> r \<and> r < n else q = 0)"
11.125 +definition divmod_rel :: "nat \<Rightarrow> nat \<Rightarrow> nat \<times> nat \<Rightarrow> bool" where
11.126 + "divmod_rel m n qr \<longleftrightarrow>
11.127 + m = fst qr * n + snd qr \<and>
11.128 + (if n = 0 then fst qr = 0 else if n > 0 then 0 \<le> snd qr \<and> snd qr < n else n < snd qr \<and> snd qr \<le> 0)"
11.129
11.130 text {* @{const divmod_rel} is total: *}
11.131
11.132 lemma divmod_rel_ex:
11.133 - obtains q r where "divmod_rel m n q r"
11.134 + obtains q r where "divmod_rel m n (q, r)"
11.135 proof (cases "n = 0")
11.136 - case True with that show thesis
11.137 + case True with that show thesis
11.138 by (auto simp add: divmod_rel_def)
11.139 next
11.140 case False
11.141 @@ -436,13 +458,14 @@
11.142
11.143 text {* @{const divmod_rel} is injective: *}
11.144
11.145 -lemma divmod_rel_unique_div:
11.146 - assumes "divmod_rel m n q r"
11.147 - and "divmod_rel m n q' r'"
11.148 - shows "q = q'"
11.149 +lemma divmod_rel_unique:
11.150 + assumes "divmod_rel m n qr"
11.151 + and "divmod_rel m n qr'"
11.152 + shows "qr = qr'"
11.153 proof (cases "n = 0")
11.154 case True with assms show ?thesis
11.155 - by (simp add: divmod_rel_def)
11.156 + by (cases qr, cases qr')
11.157 + (simp add: divmod_rel_def)
11.158 next
11.159 case False
11.160 have aux: "\<And>q r q' r'. q' * n + r' = q * n + r \<Longrightarrow> r < n \<Longrightarrow> q' \<le> (q\<Colon>nat)"
11.161 @@ -450,18 +473,11 @@
11.162 apply (subst less_iff_Suc_add)
11.163 apply (auto simp add: add_mult_distrib)
11.164 done
11.165 - from `n \<noteq> 0` assms show ?thesis
11.166 - by (auto simp add: divmod_rel_def
11.167 - intro: order_antisym dest: aux sym)
11.168 -qed
11.169 -
11.170 -lemma divmod_rel_unique_mod:
11.171 - assumes "divmod_rel m n q r"
11.172 - and "divmod_rel m n q' r'"
11.173 - shows "r = r'"
11.174 -proof -
11.175 - from assms have "q = q'" by (rule divmod_rel_unique_div)
11.176 - with assms show ?thesis by (simp add: divmod_rel_def)
11.177 + from `n \<noteq> 0` assms have "fst qr = fst qr'"
11.178 + by (auto simp add: divmod_rel_def intro: order_antisym dest: aux sym)
11.179 + moreover from this assms have "snd qr = snd qr'"
11.180 + by (simp add: divmod_rel_def)
11.181 + ultimately show ?thesis by (cases qr, cases qr') simp
11.182 qed
11.183
11.184 text {*
11.185 @@ -473,7 +489,21 @@
11.186 begin
11.187
11.188 definition divmod :: "nat \<Rightarrow> nat \<Rightarrow> nat \<times> nat" where
11.189 - [code del]: "divmod m n = (THE (q, r). divmod_rel m n q r)"
11.190 + [code del]: "divmod m n = (THE qr. divmod_rel m n qr)"
11.191 +
11.192 +lemma divmod_rel_divmod:
11.193 + "divmod_rel m n (divmod m n)"
11.194 +proof -
11.195 + from divmod_rel_ex
11.196 + obtain qr where rel: "divmod_rel m n qr" .
11.197 + then show ?thesis
11.198 + by (auto simp add: divmod_def intro: theI elim: divmod_rel_unique)
11.199 +qed
11.200 +
11.201 +lemma divmod_eq:
11.202 + assumes "divmod_rel m n qr"
11.203 + shows "divmod m n = qr"
11.204 + using assms by (auto intro: divmod_rel_unique divmod_rel_divmod)
11.205
11.206 definition div_nat where
11.207 "m div n = fst (divmod m n)"
11.208 @@ -485,30 +515,18 @@
11.209 "divmod m n = (m div n, m mod n)"
11.210 unfolding div_nat_def mod_nat_def by simp
11.211
11.212 -lemma divmod_eq:
11.213 - assumes "divmod_rel m n q r"
11.214 - shows "divmod m n = (q, r)"
11.215 - using assms by (auto simp add: divmod_def
11.216 - dest: divmod_rel_unique_div divmod_rel_unique_mod)
11.217 -
11.218 lemma div_eq:
11.219 - assumes "divmod_rel m n q r"
11.220 + assumes "divmod_rel m n (q, r)"
11.221 shows "m div n = q"
11.222 - using assms by (auto dest: divmod_eq simp add: div_nat_def)
11.223 + using assms by (auto dest: divmod_eq simp add: divmod_div_mod)
11.224
11.225 lemma mod_eq:
11.226 - assumes "divmod_rel m n q r"
11.227 + assumes "divmod_rel m n (q, r)"
11.228 shows "m mod n = r"
11.229 - using assms by (auto dest: divmod_eq simp add: mod_nat_def)
11.230 + using assms by (auto dest: divmod_eq simp add: divmod_div_mod)
11.231
11.232 -lemma divmod_rel: "divmod_rel m n (m div n) (m mod n)"
11.233 -proof -
11.234 - from divmod_rel_ex
11.235 - obtain q r where rel: "divmod_rel m n q r" .
11.236 - moreover with div_eq mod_eq have "m div n = q" and "m mod n = r"
11.237 - by simp_all
11.238 - ultimately show ?thesis by simp
11.239 -qed
11.240 +lemma divmod_rel: "divmod_rel m n (m div n, m mod n)"
11.241 + by (simp add: div_nat_def mod_nat_def divmod_rel_divmod)
11.242
11.243 lemma divmod_zero:
11.244 "divmod m 0 = (0, m)"
11.245 @@ -531,10 +549,10 @@
11.246 assumes "0 < n" and "n \<le> m"
11.247 shows "divmod m n = (Suc ((m - n) div n), (m - n) mod n)"
11.248 proof -
11.249 - from divmod_rel have divmod_m_n: "divmod_rel m n (m div n) (m mod n)" .
11.250 + from divmod_rel have divmod_m_n: "divmod_rel m n (m div n, m mod n)" .
11.251 with assms have m_div_n: "m div n \<ge> 1"
11.252 by (cases "m div n") (auto simp add: divmod_rel_def)
11.253 - from assms divmod_m_n have "divmod_rel (m - n) n (m div n - Suc 0) (m mod n)"
11.254 + from assms divmod_m_n have "divmod_rel (m - n) n (m div n - Suc 0, m mod n)"
11.255 by (cases "m div n") (auto simp add: divmod_rel_def)
11.256 with divmod_eq have "divmod (m - n) n = (m div n - Suc 0, m mod n)" by simp
11.257 moreover from divmod_div_mod have "divmod (m - n) n = ((m - n) div n, (m - n) mod n)" .
11.258 @@ -569,55 +587,74 @@
11.259 shows "m mod n = (m - n) mod n"
11.260 using assms divmod_step divmod_div_mod by (cases "n = 0") simp_all
11.261
11.262 -instance proof
11.263 - fix m n :: nat show "m div n * n + m mod n = m"
11.264 - using divmod_rel [of m n] by (simp add: divmod_rel_def)
11.265 -next
11.266 - fix n :: nat show "n div 0 = 0"
11.267 - using divmod_zero divmod_div_mod [of n 0] by simp
11.268 -next
11.269 - fix n :: nat show "0 div n = 0"
11.270 - using divmod_rel [of 0 n] by (cases n) (simp_all add: divmod_rel_def)
11.271 -next
11.272 - fix m n q :: nat assume "n \<noteq> 0" then show "(q + m * n) div n = m + q div n"
11.273 - by (induct m) (simp_all add: le_div_geq)
11.274 +instance proof -
11.275 + have [simp]: "\<And>n::nat. n div 0 = 0"
11.276 + by (simp add: div_nat_def divmod_zero)
11.277 + have [simp]: "\<And>n::nat. 0 div n = 0"
11.278 + proof -
11.279 + fix n :: nat
11.280 + show "0 div n = 0"
11.281 + by (cases "n = 0") simp_all
11.282 + qed
11.283 + show "OFCLASS(nat, semiring_div_class)" proof
11.284 + fix m n :: nat
11.285 + show "m div n * n + m mod n = m"
11.286 + using divmod_rel [of m n] by (simp add: divmod_rel_def)
11.287 + next
11.288 + fix m n q :: nat
11.289 + assume "n \<noteq> 0"
11.290 + then show "(q + m * n) div n = m + q div n"
11.291 + by (induct m) (simp_all add: le_div_geq)
11.292 + next
11.293 + fix m n q :: nat
11.294 + assume "m \<noteq> 0"
11.295 + then show "(m * n) div (m * q) = n div q"
11.296 + proof (cases "n \<noteq> 0 \<and> q \<noteq> 0")
11.297 + case False then show ?thesis by auto
11.298 + next
11.299 + case True with `m \<noteq> 0`
11.300 + have "m > 0" and "n > 0" and "q > 0" by auto
11.301 + then have "\<And>a b. divmod_rel n q (a, b) \<Longrightarrow> divmod_rel (m * n) (m * q) (a, m * b)"
11.302 + by (auto simp add: divmod_rel_def) (simp_all add: algebra_simps)
11.303 + moreover from divmod_rel have "divmod_rel n q (n div q, n mod q)" .
11.304 + ultimately have "divmod_rel (m * n) (m * q) (n div q, m * (n mod q))" .
11.305 + then show ?thesis by (simp add: div_eq)
11.306 + qed
11.307 + qed simp_all
11.308 qed
11.309
11.310 end
11.311
11.312 text {* Simproc for cancelling @{const div} and @{const mod} *}
11.313
11.314 -(*lemmas mod_div_equality_nat = semiring_div_class.times_div_mod_plus_zero_one.mod_div_equality [of "m\<Colon>nat" n, standard]
11.315 -lemmas mod_div_equality2_nat = mod_div_equality2 [of "n\<Colon>nat" m, standard*)
11.316 +ML {*
11.317 +local
11.318
11.319 -ML {*
11.320 -structure CancelDivModData =
11.321 -struct
11.322 +structure CancelDivMod = CancelDivModFun(struct
11.323
11.324 -val div_name = @{const_name div};
11.325 -val mod_name = @{const_name mod};
11.326 -val mk_binop = HOLogic.mk_binop;
11.327 -val mk_sum = Nat_Arith.mk_sum;
11.328 -val dest_sum = Nat_Arith.dest_sum;
11.329 + val div_name = @{const_name div};
11.330 + val mod_name = @{const_name mod};
11.331 + val mk_binop = HOLogic.mk_binop;
11.332 + val mk_sum = Nat_Arith.mk_sum;
11.333 + val dest_sum = Nat_Arith.dest_sum;
11.334
11.335 -(*logic*)
11.336 + val div_mod_eqs = map mk_meta_eq [@{thm div_mod_equality}, @{thm div_mod_equality2}];
11.337
11.338 -val div_mod_eqs = map mk_meta_eq [@{thm div_mod_equality}, @{thm div_mod_equality2}]
11.339 + val trans = trans;
11.340
11.341 -val trans = trans
11.342 + val prove_eq_sums = Arith_Data.prove_conv2 all_tac (Arith_Data.simp_all_tac
11.343 + (@{thm monoid_add_class.add_0_left} :: @{thm monoid_add_class.add_0_right} :: @{thms add_ac}))
11.344
11.345 -val prove_eq_sums =
11.346 - let val simps = @{thm add_0} :: @{thm add_0_right} :: @{thms add_ac}
11.347 - in Arith_Data.prove_conv2 all_tac (Arith_Data.simp_all_tac simps) end;
11.348 +end)
11.349
11.350 -end;
11.351 +in
11.352
11.353 -structure CancelDivMod = CancelDivModFun(CancelDivModData);
11.354 -
11.355 -val cancel_div_mod_proc = Simplifier.simproc (the_context ())
11.356 +val cancel_div_mod_nat_proc = Simplifier.simproc (the_context ())
11.357 "cancel_div_mod" ["(m::nat) + n"] (K CancelDivMod.proc);
11.358
11.359 -Addsimprocs[cancel_div_mod_proc];
11.360 +val _ = Addsimprocs [cancel_div_mod_nat_proc];
11.361 +
11.362 +end
11.363 *}
11.364
11.365 text {* code generator setup *}
11.366 @@ -658,7 +695,7 @@
11.367 fixes m n :: nat
11.368 assumes "n > 0"
11.369 shows "m mod n < (n::nat)"
11.370 - using assms divmod_rel unfolding divmod_rel_def by auto
11.371 + using assms divmod_rel [of m n] unfolding divmod_rel_def by auto
11.372
11.373 lemma mod_less_eq_dividend [simp]:
11.374 fixes m n :: nat
11.375 @@ -700,18 +737,19 @@
11.376 subsubsection {* Quotient and Remainder *}
11.377
11.378 lemma divmod_rel_mult1_eq:
11.379 - "[| divmod_rel b c q r; c > 0 |]
11.380 - ==> divmod_rel (a*b) c (a*q + a*r div c) (a*r mod c)"
11.381 + "divmod_rel b c (q, r) \<Longrightarrow> c > 0
11.382 + \<Longrightarrow> divmod_rel (a * b) c (a * q + a * r div c, a * r mod c)"
11.383 by (auto simp add: split_ifs divmod_rel_def algebra_simps)
11.384
11.385 -lemma div_mult1_eq: "(a*b) div c = a*(b div c) + a*(b mod c) div (c::nat)"
11.386 +lemma div_mult1_eq:
11.387 + "(a * b) div c = a * (b div c) + a * (b mod c) div (c::nat)"
11.388 apply (cases "c = 0", simp)
11.389 apply (blast intro: divmod_rel [THEN divmod_rel_mult1_eq, THEN div_eq])
11.390 done
11.391
11.392 lemma divmod_rel_add1_eq:
11.393 - "[| divmod_rel a c aq ar; divmod_rel b c bq br; c > 0 |]
11.394 - ==> divmod_rel (a + b) c (aq + bq + (ar+br) div c) ((ar + br) mod c)"
11.395 + "divmod_rel a c (aq, ar) \<Longrightarrow> divmod_rel b c (bq, br) \<Longrightarrow> c > 0
11.396 + \<Longrightarrow> divmod_rel (a + b) c (aq + bq + (ar + br) div c, (ar + br) mod c)"
11.397 by (auto simp add: split_ifs divmod_rel_def algebra_simps)
11.398
11.399 (*NOT suitable for rewriting: the RHS has an instance of the LHS*)
11.400 @@ -728,8 +766,9 @@
11.401 apply (simp add: add_mult_distrib2)
11.402 done
11.403
11.404 -lemma divmod_rel_mult2_eq: "[| divmod_rel a b q r; 0 < b; 0 < c |]
11.405 - ==> divmod_rel a (b*c) (q div c) (b*(q mod c) + r)"
11.406 +lemma divmod_rel_mult2_eq:
11.407 + "divmod_rel a b (q, r) \<Longrightarrow> 0 < b \<Longrightarrow> 0 < c
11.408 + \<Longrightarrow> divmod_rel a (b * c) (q div c, b *(q mod c) + r)"
11.409 by (auto simp add: mult_ac divmod_rel_def add_mult_distrib2 [symmetric] mod_lemma)
11.410
11.411 lemma div_mult2_eq: "a div (b*c) = (a div b) div (c::nat)"
11.412 @@ -745,23 +784,6 @@
11.413 done
11.414
11.415
11.416 -subsubsection{*Cancellation of Common Factors in Division*}
11.417 -
11.418 -lemma div_mult_mult_lemma:
11.419 - "[| (0::nat) < b; 0 < c |] ==> (c*a) div (c*b) = a div b"
11.420 -by (auto simp add: div_mult2_eq)
11.421 -
11.422 -lemma div_mult_mult1 [simp]: "(0::nat) < c ==> (c*a) div (c*b) = a div b"
11.423 - apply (cases "b = 0")
11.424 - apply (auto simp add: linorder_neq_iff [of b] div_mult_mult_lemma)
11.425 - done
11.426 -
11.427 -lemma div_mult_mult2 [simp]: "(0::nat) < c ==> (a*c) div (b*c) = a div b"
11.428 - apply (drule div_mult_mult1)
11.429 - apply (auto simp add: mult_commute)
11.430 - done
11.431 -
11.432 -
11.433 subsubsection{*Further Facts about Quotient and Remainder*}
11.434
11.435 lemma div_1 [simp]: "m div Suc 0 = m"
11.436 @@ -769,7 +791,7 @@
11.437
11.438
11.439 (* Monotonicity of div in first argument *)
11.440 -lemma div_le_mono [rule_format]:
11.441 +lemma div_le_mono [rule_format (no_asm)]:
11.442 "\<forall>m::nat. m \<le> n --> (m div k) \<le> (n div k)"
11.443 apply (case_tac "k=0", simp)
11.444 apply (induct "n" rule: nat_less_induct, clarify)
11.445 @@ -824,12 +846,6 @@
11.446 apply (simp_all)
11.447 done
11.448
11.449 -lemma nat_div_eq_0 [simp]: "(n::nat) > 0 ==> ((m div n) = 0) = (m < n)"
11.450 -by(auto, subst mod_div_equality [of m n, symmetric], auto)
11.451 -
11.452 -lemma nat_div_gt_0 [simp]: "(n::nat) > 0 ==> ((m div n) > 0) = (m >= n)"
11.453 -by (subst neq0_conv [symmetric], auto)
11.454 -
11.455 declare div_less_dividend [simp]
11.456
11.457 text{*A fact for the mutilated chess board*}
11.458 @@ -915,16 +931,10 @@
11.459 done
11.460
11.461 lemma dvd_imp_le: "[| k dvd n; 0 < n |] ==> k \<le> (n::nat)"
11.462 -by (auto elim!: dvdE) (auto simp add: gr0_conv_Suc)
11.463 -
11.464 -lemma nat_dvd_not_less: "(0::nat) < m \<Longrightarrow> m < n \<Longrightarrow> \<not> n dvd m"
11.465 -by (auto elim!: dvdE) (auto simp add: gr0_conv_Suc)
11.466 + by (auto elim!: dvdE) (auto simp add: gr0_conv_Suc)
11.467
11.468 lemma dvd_mult_div_cancel: "n dvd m ==> n * (m div n) = (m::nat)"
11.469 - apply (subgoal_tac "m mod n = 0")
11.470 - apply (simp add: mult_div_cancel)
11.471 - apply (simp only: dvd_eq_mod_eq_0)
11.472 - done
11.473 + by (simp add: dvd_eq_mod_eq_0 mult_div_cancel)
11.474
11.475 lemma nat_zero_less_power_iff [simp]: "(x^n > 0) = (x > (0::nat) | n=0)"
11.476 by (induct n) auto
11.477 @@ -1001,9 +1011,11 @@
11.478 from A B show ?lhs ..
11.479 next
11.480 assume P: ?lhs
11.481 - then have "divmod_rel m n q (m - n * q)"
11.482 + then have "divmod_rel m n (q, m - n * q)"
11.483 unfolding divmod_rel_def by (auto simp add: mult_ac)
11.484 - then show ?rhs using divmod_rel by (rule divmod_rel_unique_div)
11.485 + with divmod_rel_unique divmod_rel [of m n]
11.486 + have "(q, m - n * q) = (m div n, m mod n)" by auto
11.487 + then show ?rhs by simp
11.488 qed
11.489
11.490 theorem split_div':
11.491 @@ -1155,4 +1167,9 @@
11.492 with j show ?thesis by blast
11.493 qed
11.494
11.495 +lemma nat_dvd_not_less:
11.496 + fixes m n :: nat
11.497 + shows "0 < m \<Longrightarrow> m < n \<Longrightarrow> \<not> n dvd m"
11.498 +by (auto elim!: dvdE) (auto simp add: gr0_conv_Suc)
11.499 +
11.500 end
12.1 --- a/src/HOL/Groebner_Basis.thy Mon Apr 20 12:27:23 2009 +0200
12.2 +++ b/src/HOL/Groebner_Basis.thy Mon Apr 20 16:28:13 2009 +0200
12.3 @@ -5,7 +5,7 @@
12.4 header {* Semiring normalization and Groebner Bases *}
12.5
12.6 theory Groebner_Basis
12.7 -imports NatBin
12.8 +imports Nat_Numeral
12.9 uses
12.10 "Tools/Groebner_Basis/misc.ML"
12.11 "Tools/Groebner_Basis/normalizer_data.ML"
13.1 --- a/src/HOL/HOL.thy Mon Apr 20 12:27:23 2009 +0200
13.2 +++ b/src/HOL/HOL.thy Mon Apr 20 16:28:13 2009 +0200
13.3 @@ -5,7 +5,7 @@
13.4 header {* The basis of Higher-Order Logic *}
13.5
13.6 theory HOL
13.7 -imports Pure
13.8 +imports Pure "~~/src/Tools/Code_Generator"
13.9 uses
13.10 ("Tools/hologic.ML")
13.11 "~~/src/Tools/IsaPlanner/zipper.ML"
13.12 @@ -27,16 +27,6 @@
13.13 "~~/src/Tools/atomize_elim.ML"
13.14 "~~/src/Tools/induct.ML"
13.15 ("~~/src/Tools/induct_tacs.ML")
13.16 - "~~/src/Tools/value.ML"
13.17 - "~~/src/Tools/code/code_name.ML"
13.18 - "~~/src/Tools/code/code_funcgr.ML" (*formal dependency*)
13.19 - "~~/src/Tools/code/code_wellsorted.ML"
13.20 - "~~/src/Tools/code/code_thingol.ML"
13.21 - "~~/src/Tools/code/code_printer.ML"
13.22 - "~~/src/Tools/code/code_target.ML"
13.23 - "~~/src/Tools/code/code_ml.ML"
13.24 - "~~/src/Tools/code/code_haskell.ML"
13.25 - "~~/src/Tools/nbe.ML"
13.26 ("Tools/recfun_codegen.ML")
13.27 begin
13.28
13.29 @@ -1674,35 +1664,259 @@
13.30 *}
13.31
13.32
13.33 -subsection {* Code generator basics -- see further theory @{text "Code_Setup"} *}
13.34 +subsection {* Code generator setup *}
13.35
13.36 -text {* Equality *}
13.37 +subsubsection {* SML code generator setup *}
13.38 +
13.39 +use "Tools/recfun_codegen.ML"
13.40 +
13.41 +setup {*
13.42 + Codegen.setup
13.43 + #> RecfunCodegen.setup
13.44 +*}
13.45 +
13.46 +types_code
13.47 + "bool" ("bool")
13.48 +attach (term_of) {*
13.49 +fun term_of_bool b = if b then HOLogic.true_const else HOLogic.false_const;
13.50 +*}
13.51 +attach (test) {*
13.52 +fun gen_bool i =
13.53 + let val b = one_of [false, true]
13.54 + in (b, fn () => term_of_bool b) end;
13.55 +*}
13.56 + "prop" ("bool")
13.57 +attach (term_of) {*
13.58 +fun term_of_prop b =
13.59 + HOLogic.mk_Trueprop (if b then HOLogic.true_const else HOLogic.false_const);
13.60 +*}
13.61 +
13.62 +consts_code
13.63 + "Trueprop" ("(_)")
13.64 + "True" ("true")
13.65 + "False" ("false")
13.66 + "Not" ("Bool.not")
13.67 + "op |" ("(_ orelse/ _)")
13.68 + "op &" ("(_ andalso/ _)")
13.69 + "If" ("(if _/ then _/ else _)")
13.70 +
13.71 +setup {*
13.72 +let
13.73 +
13.74 +fun eq_codegen thy defs dep thyname b t gr =
13.75 + (case strip_comb t of
13.76 + (Const ("op =", Type (_, [Type ("fun", _), _])), _) => NONE
13.77 + | (Const ("op =", _), [t, u]) =>
13.78 + let
13.79 + val (pt, gr') = Codegen.invoke_codegen thy defs dep thyname false t gr;
13.80 + val (pu, gr'') = Codegen.invoke_codegen thy defs dep thyname false u gr';
13.81 + val (_, gr''') = Codegen.invoke_tycodegen thy defs dep thyname false HOLogic.boolT gr'';
13.82 + in
13.83 + SOME (Codegen.parens
13.84 + (Pretty.block [pt, Codegen.str " =", Pretty.brk 1, pu]), gr''')
13.85 + end
13.86 + | (t as Const ("op =", _), ts) => SOME (Codegen.invoke_codegen
13.87 + thy defs dep thyname b (Codegen.eta_expand t ts 2) gr)
13.88 + | _ => NONE);
13.89 +
13.90 +in
13.91 + Codegen.add_codegen "eq_codegen" eq_codegen
13.92 +end
13.93 +*}
13.94 +
13.95 +subsubsection {* Equality *}
13.96
13.97 class eq =
13.98 fixes eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
13.99 assumes eq_equals: "eq x y \<longleftrightarrow> x = y"
13.100 begin
13.101
13.102 -lemma eq: "eq = (op =)"
13.103 +lemma eq [code unfold, code inline del]: "eq = (op =)"
13.104 by (rule ext eq_equals)+
13.105
13.106 lemma eq_refl: "eq x x \<longleftrightarrow> True"
13.107 unfolding eq by rule+
13.108
13.109 +lemma equals_eq [code inline, code]: "(op =) \<equiv> eq"
13.110 + by (rule eq_reflection) (rule ext, rule ext, rule sym, rule eq_equals)
13.111 +
13.112 +declare equals_eq [symmetric, code post]
13.113 +
13.114 end
13.115
13.116 -text {* Module setup *}
13.117 +subsubsection {* Generic code generator foundation *}
13.118
13.119 -use "Tools/recfun_codegen.ML"
13.120 +text {* Datatypes *}
13.121 +
13.122 +code_datatype True False
13.123 +
13.124 +code_datatype "TYPE('a\<Colon>{})"
13.125 +
13.126 +code_datatype Trueprop "prop"
13.127 +
13.128 +text {* Code equations *}
13.129 +
13.130 +lemma [code]:
13.131 + shows "(True \<Longrightarrow> PROP P) \<equiv> PROP P"
13.132 + and "(False \<Longrightarrow> Q) \<equiv> Trueprop True"
13.133 + and "(PROP P \<Longrightarrow> True) \<equiv> Trueprop True"
13.134 + and "(Q \<Longrightarrow> False) \<equiv> Trueprop (\<not> Q)" by (auto intro!: equal_intr_rule)
13.135 +
13.136 +lemma [code]:
13.137 + shows "False \<and> x \<longleftrightarrow> False"
13.138 + and "True \<and> x \<longleftrightarrow> x"
13.139 + and "x \<and> False \<longleftrightarrow> False"
13.140 + and "x \<and> True \<longleftrightarrow> x" by simp_all
13.141 +
13.142 +lemma [code]:
13.143 + shows "False \<or> x \<longleftrightarrow> x"
13.144 + and "True \<or> x \<longleftrightarrow> True"
13.145 + and "x \<or> False \<longleftrightarrow> x"
13.146 + and "x \<or> True \<longleftrightarrow> True" by simp_all
13.147 +
13.148 +lemma [code]:
13.149 + shows "\<not> True \<longleftrightarrow> False"
13.150 + and "\<not> False \<longleftrightarrow> True" by (rule HOL.simp_thms)+
13.151 +
13.152 +lemmas [code] = Let_def if_True if_False
13.153 +
13.154 +lemmas [code, code unfold, symmetric, code post] = imp_conv_disj
13.155 +
13.156 +text {* Equality *}
13.157 +
13.158 +declare simp_thms(6) [code nbe]
13.159 +
13.160 +hide (open) const eq
13.161 +hide const eq
13.162
13.163 setup {*
13.164 - Code_ML.setup
13.165 - #> Code_Haskell.setup
13.166 - #> Nbe.setup
13.167 - #> Codegen.setup
13.168 - #> RecfunCodegen.setup
13.169 + Code_Unit.add_const_alias @{thm equals_eq}
13.170 *}
13.171
13.172 +text {* Cases *}
13.173 +
13.174 +lemma Let_case_cert:
13.175 + assumes "CASE \<equiv> (\<lambda>x. Let x f)"
13.176 + shows "CASE x \<equiv> f x"
13.177 + using assms by simp_all
13.178 +
13.179 +lemma If_case_cert:
13.180 + assumes "CASE \<equiv> (\<lambda>b. If b f g)"
13.181 + shows "(CASE True \<equiv> f) &&& (CASE False \<equiv> g)"
13.182 + using assms by simp_all
13.183 +
13.184 +setup {*
13.185 + Code.add_case @{thm Let_case_cert}
13.186 + #> Code.add_case @{thm If_case_cert}
13.187 + #> Code.add_undefined @{const_name undefined}
13.188 +*}
13.189 +
13.190 +code_abort undefined
13.191 +
13.192 +subsubsection {* Generic code generator preprocessor *}
13.193 +
13.194 +setup {*
13.195 + Code.map_pre (K HOL_basic_ss)
13.196 + #> Code.map_post (K HOL_basic_ss)
13.197 +*}
13.198 +
13.199 +subsubsection {* Generic code generator target languages *}
13.200 +
13.201 +text {* type bool *}
13.202 +
13.203 +code_type bool
13.204 + (SML "bool")
13.205 + (OCaml "bool")
13.206 + (Haskell "Bool")
13.207 +
13.208 +code_const True and False and Not and "op &" and "op |" and If
13.209 + (SML "true" and "false" and "not"
13.210 + and infixl 1 "andalso" and infixl 0 "orelse"
13.211 + and "!(if (_)/ then (_)/ else (_))")
13.212 + (OCaml "true" and "false" and "not"
13.213 + and infixl 4 "&&" and infixl 2 "||"
13.214 + and "!(if (_)/ then (_)/ else (_))")
13.215 + (Haskell "True" and "False" and "not"
13.216 + and infixl 3 "&&" and infixl 2 "||"
13.217 + and "!(if (_)/ then (_)/ else (_))")
13.218 +
13.219 +code_reserved SML
13.220 + bool true false not
13.221 +
13.222 +code_reserved OCaml
13.223 + bool not
13.224 +
13.225 +text {* using built-in Haskell equality *}
13.226 +
13.227 +code_class eq
13.228 + (Haskell "Eq")
13.229 +
13.230 +code_const "eq_class.eq"
13.231 + (Haskell infixl 4 "==")
13.232 +
13.233 +code_const "op ="
13.234 + (Haskell infixl 4 "==")
13.235 +
13.236 +text {* undefined *}
13.237 +
13.238 +code_const undefined
13.239 + (SML "!(raise/ Fail/ \"undefined\")")
13.240 + (OCaml "failwith/ \"undefined\"")
13.241 + (Haskell "error/ \"undefined\"")
13.242 +
13.243 +subsubsection {* Evaluation and normalization by evaluation *}
13.244 +
13.245 +setup {*
13.246 + Value.add_evaluator ("SML", Codegen.eval_term o ProofContext.theory_of)
13.247 +*}
13.248 +
13.249 +ML {*
13.250 +structure Eval_Method =
13.251 +struct
13.252 +
13.253 +val eval_ref : (unit -> bool) option ref = ref NONE;
13.254 +
13.255 +end;
13.256 +*}
13.257 +
13.258 +oracle eval_oracle = {* fn ct =>
13.259 + let
13.260 + val thy = Thm.theory_of_cterm ct;
13.261 + val t = Thm.term_of ct;
13.262 + val dummy = @{cprop True};
13.263 + in case try HOLogic.dest_Trueprop t
13.264 + of SOME t' => if Code_ML.eval NONE
13.265 + ("Eval_Method.eval_ref", Eval_Method.eval_ref) thy t' []
13.266 + then Thm.capply (Thm.capply @{cterm "op \<equiv> \<Colon> prop \<Rightarrow> prop \<Rightarrow> prop"} ct) dummy
13.267 + else dummy
13.268 + | NONE => dummy
13.269 + end
13.270 +*}
13.271 +
13.272 +ML {*
13.273 +fun gen_eval_method conv ctxt = SIMPLE_METHOD'
13.274 + (CONVERSION (Conv.params_conv (~1) (K (Conv.concl_conv (~1) conv)) ctxt)
13.275 + THEN' rtac TrueI)
13.276 +*}
13.277 +
13.278 +method_setup eval = {* Scan.succeed (gen_eval_method eval_oracle) *}
13.279 + "solve goal by evaluation"
13.280 +
13.281 +method_setup evaluation = {* Scan.succeed (gen_eval_method Codegen.evaluation_conv) *}
13.282 + "solve goal by evaluation"
13.283 +
13.284 +method_setup normalization = {*
13.285 + Scan.succeed (K (SIMPLE_METHOD' (CONVERSION Nbe.norm_conv THEN' (fn k => TRY (rtac TrueI k)))))
13.286 +*} "solve goal by normalization"
13.287 +
13.288 +subsubsection {* Quickcheck *}
13.289 +
13.290 +setup {*
13.291 + Quickcheck.add_generator ("SML", Codegen.test_term)
13.292 +*}
13.293 +
13.294 +quickcheck_params [size = 5, iterations = 50]
13.295 +
13.296
13.297 subsection {* Nitpick hooks *}
13.298
14.1 --- a/src/HOL/HoareParallel/OG_Tran.thy Mon Apr 20 12:27:23 2009 +0200
14.2 +++ b/src/HOL/HoareParallel/OG_Tran.thy Mon Apr 20 16:28:13 2009 +0200
14.3 @@ -74,7 +74,7 @@
14.4 abbreviation
14.5 ann_transition_n :: "('a ann_com_op \<times> 'a) \<Rightarrow> nat \<Rightarrow> ('a ann_com_op \<times> 'a)
14.6 \<Rightarrow> bool" ("_ -_\<rightarrow> _"[81,81] 100) where
14.7 - "con_0 -n\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> ann_transition^n"
14.8 + "con_0 -n\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> ann_transition ^^ n"
14.9
14.10 abbreviation
14.11 ann_transitions :: "('a ann_com_op \<times> 'a) \<Rightarrow> ('a ann_com_op \<times> 'a) \<Rightarrow> bool"
14.12 @@ -84,7 +84,7 @@
14.13 abbreviation
14.14 transition_n :: "('a com \<times> 'a) \<Rightarrow> nat \<Rightarrow> ('a com \<times> 'a) \<Rightarrow> bool"
14.15 ("_ -P_\<rightarrow> _"[81,81,81] 100) where
14.16 - "con_0 -Pn\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> transition^n"
14.17 + "con_0 -Pn\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> transition ^^ n"
14.18
14.19 subsection {* Definition of Semantics *}
14.20
15.1 --- a/src/HOL/IMP/Compiler0.thy Mon Apr 20 12:27:23 2009 +0200
15.2 +++ b/src/HOL/IMP/Compiler0.thy Mon Apr 20 16:28:13 2009 +0200
15.3 @@ -45,7 +45,7 @@
15.4 abbreviation
15.5 stepan :: "[instr list,state,nat,nat,state,nat] \<Rightarrow> bool"
15.6 ("_ \<turnstile>/ (3\<langle>_,_\<rangle>/ -(_)\<rightarrow> \<langle>_,_\<rangle>)" [50,0,0,0,0,0] 50) where
15.7 - "P \<turnstile> \<langle>s,m\<rangle> -(i)\<rightarrow> \<langle>t,n\<rangle> == ((s,m),t,n) : ((stepa1 P)^i)"
15.8 + "P \<turnstile> \<langle>s,m\<rangle> -(i)\<rightarrow> \<langle>t,n\<rangle> == ((s,m),t,n) : (stepa1 P ^^ i)"
15.9
15.10 subsection "The compiler"
15.11
16.1 --- a/src/HOL/IMP/Machines.thy Mon Apr 20 12:27:23 2009 +0200
16.2 +++ b/src/HOL/IMP/Machines.thy Mon Apr 20 16:28:13 2009 +0200
16.3 @@ -1,7 +1,6 @@
16.4 -
16.5 -(* $Id$ *)
16.6 -
16.7 -theory Machines imports Natural begin
16.8 +theory Machines
16.9 +imports Natural
16.10 +begin
16.11
16.12 lemma rtrancl_eq: "R^* = Id \<union> (R O R^*)"
16.13 by (fast intro: rtrancl_into_rtrancl elim: rtranclE)
16.14 @@ -11,20 +10,22 @@
16.15
16.16 lemmas converse_rel_powE = rel_pow_E2
16.17
16.18 -lemma R_O_Rn_commute: "R O R^n = R^n O R"
16.19 +lemma R_O_Rn_commute: "R O R ^^ n = R ^^ n O R"
16.20 by (induct n) (simp, simp add: O_assoc [symmetric])
16.21
16.22 lemma converse_in_rel_pow_eq:
16.23 - "((x,z) \<in> R^n) = (n=0 \<and> z=x \<or> (\<exists>m y. n = Suc m \<and> (x,y) \<in> R \<and> (y,z) \<in> R^m))"
16.24 + "((x,z) \<in> R ^^ n) = (n=0 \<and> z=x \<or> (\<exists>m y. n = Suc m \<and> (x,y) \<in> R \<and> (y,z) \<in> R ^^ m))"
16.25 apply(rule iffI)
16.26 apply(blast elim:converse_rel_powE)
16.27 apply (fastsimp simp add:gr0_conv_Suc R_O_Rn_commute)
16.28 done
16.29
16.30 -lemma rel_pow_plus: "R^(m+n) = R^n O R^m"
16.31 +lemma rel_pow_plus:
16.32 + "R ^^ (m+n) = R ^^ n O R ^^ m"
16.33 by (induct n) (simp, simp add: O_assoc)
16.34
16.35 -lemma rel_pow_plusI: "\<lbrakk> (x,y) \<in> R^m; (y,z) \<in> R^n \<rbrakk> \<Longrightarrow> (x,z) \<in> R^(m+n)"
16.36 +lemma rel_pow_plusI:
16.37 + "\<lbrakk> (x,y) \<in> R ^^ m; (y,z) \<in> R ^^ n \<rbrakk> \<Longrightarrow> (x,z) \<in> R ^^ (m+n)"
16.38 by (simp add: rel_pow_plus rel_compI)
16.39
16.40 subsection "Instructions"
16.41 @@ -57,7 +58,7 @@
16.42 abbreviation
16.43 exec0n :: "[instrs, nat,state, nat, nat,state] \<Rightarrow> bool"
16.44 ("(_/ \<turnstile> (1\<langle>_,/_\<rangle>)/ -_\<rightarrow> (1\<langle>_,/_\<rangle>))" [50,0,0,0,0] 50) where
16.45 - "p \<turnstile> \<langle>i,s\<rangle> -n\<rightarrow> \<langle>j,t\<rangle> == ((i,s),j,t) : (exec01 p)^n"
16.46 + "p \<turnstile> \<langle>i,s\<rangle> -n\<rightarrow> \<langle>j,t\<rangle> == ((i,s),j,t) : (exec01 p)^^n"
16.47
16.48 subsection "M0 with lists"
16.49
16.50 @@ -89,7 +90,7 @@
16.51 abbreviation
16.52 stepan :: "[instrs,instrs,state, nat, instrs,instrs,state] \<Rightarrow> bool"
16.53 ("((1\<langle>_,/_,/_\<rangle>)/ -_\<rightarrow> (1\<langle>_,/_,/_\<rangle>))" 50) where
16.54 - "\<langle>p,q,s\<rangle> -i\<rightarrow> \<langle>p',q',t\<rangle> == ((p,q,s),p',q',t) : (stepa1^i)"
16.55 + "\<langle>p,q,s\<rangle> -i\<rightarrow> \<langle>p',q',t\<rangle> == ((p,q,s),p',q',t) : (stepa1^^i)"
16.56
16.57 inductive_cases execE: "((i#is,p,s), (is',p',s')) : stepa1"
16.58
17.1 --- a/src/HOL/IMP/Transition.thy Mon Apr 20 12:27:23 2009 +0200
17.2 +++ b/src/HOL/IMP/Transition.thy Mon Apr 20 16:28:13 2009 +0200
17.3 @@ -1,5 +1,4 @@
17.4 (* Title: HOL/IMP/Transition.thy
17.5 - ID: $Id$
17.6 Author: Tobias Nipkow & Robert Sandner, TUM
17.7 Isar Version: Gerwin Klein, 2001
17.8 Copyright 1996 TUM
17.9 @@ -69,7 +68,7 @@
17.10 abbreviation
17.11 evalcn :: "[(com option\<times>state),nat,(com option\<times>state)] \<Rightarrow> bool"
17.12 ("_ -_\<rightarrow>\<^sub>1 _" [60,60,60] 60) where
17.13 - "cs -n\<rightarrow>\<^sub>1 cs' == (cs,cs') \<in> evalc1^n"
17.14 + "cs -n\<rightarrow>\<^sub>1 cs' == (cs,cs') \<in> evalc1^^n"
17.15
17.16 abbreviation
17.17 evalc' :: "[(com option\<times>state),(com option\<times>state)] \<Rightarrow> bool"
17.18 @@ -77,28 +76,9 @@
17.19 "cs \<longrightarrow>\<^sub>1\<^sup>* cs' == (cs,cs') \<in> evalc1^*"
17.20
17.21 (*<*)
17.22 -(* fixme: move to Relation_Power.thy *)
17.23 -lemma rel_pow_Suc_E2 [elim!]:
17.24 - "[| (x, z) \<in> R ^ Suc n; !!y. [| (x, y) \<in> R; (y, z) \<in> R ^ n |] ==> P |] ==> P"
17.25 - by (blast dest: rel_pow_Suc_D2)
17.26 +declare rel_pow_Suc_E2 [elim!]
17.27 +(*>*)
17.28
17.29 -lemma rtrancl_imp_rel_pow: "p \<in> R^* \<Longrightarrow> \<exists>n. p \<in> R^n"
17.30 -proof (induct p)
17.31 - fix x y
17.32 - assume "(x, y) \<in> R\<^sup>*"
17.33 - thus "\<exists>n. (x, y) \<in> R^n"
17.34 - proof induct
17.35 - fix a have "(a, a) \<in> R^0" by simp
17.36 - thus "\<exists>n. (a, a) \<in> R ^ n" ..
17.37 - next
17.38 - fix a b c assume "\<exists>n. (a, b) \<in> R ^ n"
17.39 - then obtain n where "(a, b) \<in> R^n" ..
17.40 - moreover assume "(b, c) \<in> R"
17.41 - ultimately have "(a, c) \<in> R^(Suc n)" by auto
17.42 - thus "\<exists>n. (a, c) \<in> R^n" ..
17.43 - qed
17.44 -qed
17.45 -(*>*)
17.46 text {*
17.47 As for the big step semantics you can read these rules in a
17.48 syntax directed way:
17.49 @@ -189,8 +169,8 @@
17.50 (*<*)
17.51 (* FIXME: relpow.simps don't work *)
17.52 lemmas [simp del] = relpow.simps
17.53 -lemma rel_pow_0 [simp]: "!!R::('a*'a) set. R^0 = Id" by (simp add: relpow.simps)
17.54 -lemma rel_pow_Suc_0 [simp]: "!!R::('a*'a) set. R^(Suc 0) = R" by (simp add: relpow.simps)
17.55 +lemma rel_pow_0 [simp]: "!!R::('a*'a) set. R ^^ 0 = Id" by (simp add: relpow.simps)
17.56 +lemma rel_pow_Suc_0 [simp]: "!!R::('a*'a) set. R ^^ Suc 0 = R" by (simp add: relpow.simps)
17.57
17.58 (*>*)
17.59 lemma evalc1_None_0 [simp]: "\<langle>s\<rangle> -n\<rightarrow>\<^sub>1 y = (n = 0 \<and> y = \<langle>s\<rangle>)"
18.1 --- a/src/HOL/Import/HOL/HOL4Base.thy Mon Apr 20 12:27:23 2009 +0200
18.2 +++ b/src/HOL/Import/HOL/HOL4Base.thy Mon Apr 20 16:28:13 2009 +0200
18.3 @@ -2794,8 +2794,8 @@
18.4 by (import numeral numeral_fact)
18.5
18.6 lemma numeral_funpow: "ALL n::nat.
18.7 - ((f::'a::type => 'a::type) ^ n) (x::'a::type) =
18.8 - (if n = 0 then x else (f ^ (n - 1)) (f x))"
18.9 + ((f::'a::type => 'a::type) o^ n) (x::'a::type) =
18.10 + (if n = 0 then x else (f o^ (n - 1)) (f x))"
18.11 by (import numeral numeral_funpow)
18.12
18.13 ;end_setup
19.1 --- a/src/HOL/Import/HOL/HOL4Word32.thy Mon Apr 20 12:27:23 2009 +0200
19.2 +++ b/src/HOL/Import/HOL/HOL4Word32.thy Mon Apr 20 16:28:13 2009 +0200
19.3 @@ -434,15 +434,15 @@
19.4 by (import word32 EQUIV_QT)
19.5
19.6 lemma FUNPOW_THM: "ALL (f::'a::type => 'a::type) (n::nat) x::'a::type.
19.7 - (f ^ n) (f x) = f ((f ^ n) x)"
19.8 + (f o^ n) (f x) = f ((f o^ n) x)"
19.9 by (import word32 FUNPOW_THM)
19.10
19.11 lemma FUNPOW_THM2: "ALL (f::'a::type => 'a::type) (n::nat) x::'a::type.
19.12 - (f ^ Suc n) x = f ((f ^ n) x)"
19.13 + (f o^ Suc n) x = f ((f o^ n) x)"
19.14 by (import word32 FUNPOW_THM2)
19.15
19.16 lemma FUNPOW_COMP: "ALL (f::'a::type => 'a::type) (m::nat) (n::nat) a::'a::type.
19.17 - (f ^ m) ((f ^ n) a) = (f ^ (m + n)) a"
19.18 + (f o^ m) ((f o^ n) a) = (f o^ (m + n)) a"
19.19 by (import word32 FUNPOW_COMP)
19.20
19.21 lemma INw_MODw: "ALL n::nat. INw (MODw n)"
19.22 @@ -1170,23 +1170,23 @@
19.23
19.24 constdefs
19.25 word_lsr :: "word32 => nat => word32"
19.26 - "word_lsr == %(a::word32) n::nat. (word_lsr1 ^ n) a"
19.27 + "word_lsr == %(a::word32) n::nat. (word_lsr1 o^ n) a"
19.28
19.29 -lemma word_lsr: "ALL (a::word32) n::nat. word_lsr a n = (word_lsr1 ^ n) a"
19.30 +lemma word_lsr: "ALL (a::word32) n::nat. word_lsr a n = (word_lsr1 o^ n) a"
19.31 by (import word32 word_lsr)
19.32
19.33 constdefs
19.34 word_asr :: "word32 => nat => word32"
19.35 - "word_asr == %(a::word32) n::nat. (word_asr1 ^ n) a"
19.36 + "word_asr == %(a::word32) n::nat. (word_asr1 o^ n) a"
19.37
19.38 -lemma word_asr: "ALL (a::word32) n::nat. word_asr a n = (word_asr1 ^ n) a"
19.39 +lemma word_asr: "ALL (a::word32) n::nat. word_asr a n = (word_asr1 o^ n) a"
19.40 by (import word32 word_asr)
19.41
19.42 constdefs
19.43 word_ror :: "word32 => nat => word32"
19.44 - "word_ror == %(a::word32) n::nat. (word_ror1 ^ n) a"
19.45 + "word_ror == %(a::word32) n::nat. (word_ror1 o^ n) a"
19.46
19.47 -lemma word_ror: "ALL (a::word32) n::nat. word_ror a n = (word_ror1 ^ n) a"
19.48 +lemma word_ror: "ALL (a::word32) n::nat. word_ror a n = (word_ror1 o^ n) a"
19.49 by (import word32 word_ror)
19.50
19.51 consts
19.52 @@ -1583,4 +1583,3 @@
19.53 ;end_setup
19.54
19.55 end
19.56 -
20.1 --- a/src/HOL/Import/HOL/arithmetic.imp Mon Apr 20 12:27:23 2009 +0200
20.2 +++ b/src/HOL/Import/HOL/arithmetic.imp Mon Apr 20 16:28:13 2009 +0200
20.3 @@ -43,7 +43,7 @@
20.4 "TWO" > "HOL4Base.arithmetic.TWO"
20.5 "TIMES2" > "NatSimprocs.nat_mult_2"
20.6 "SUC_SUB1" > "HOL4Base.arithmetic.SUC_SUB1"
20.7 - "SUC_ONE_ADD" > "NatBin.Suc_eq_add_numeral_1_left"
20.8 + "SUC_ONE_ADD" > "Nat_Numeral.Suc_eq_add_numeral_1_left"
20.9 "SUC_NOT" > "Nat.nat.simps_2"
20.10 "SUC_ELIM_THM" > "HOL4Base.arithmetic.SUC_ELIM_THM"
20.11 "SUC_ADD_SYM" > "HOL4Base.arithmetic.SUC_ADD_SYM"
20.12 @@ -233,7 +233,7 @@
20.13 "EVEN_AND_ODD" > "HOL4Base.arithmetic.EVEN_AND_ODD"
20.14 "EVEN_ADD" > "HOL4Base.arithmetic.EVEN_ADD"
20.15 "EVEN" > "HOL4Base.arithmetic.EVEN"
20.16 - "EQ_MULT_LCANCEL" > "NatBin.nat_mult_eq_cancel_disj"
20.17 + "EQ_MULT_LCANCEL" > "Nat_Numeral.nat_mult_eq_cancel_disj"
20.18 "EQ_MONO_ADD_EQ" > "Nat.nat_add_right_cancel"
20.19 "EQ_LESS_EQ" > "Orderings.order_eq_iff"
20.20 "EQ_ADD_RCANCEL" > "Nat.nat_add_right_cancel"
21.1 --- a/src/HOL/Import/HOL/real.imp Mon Apr 20 12:27:23 2009 +0200
21.2 +++ b/src/HOL/Import/HOL/real.imp Mon Apr 20 16:28:13 2009 +0200
21.3 @@ -99,7 +99,7 @@
21.4 "REAL_POW_INV" > "Power.power_inverse"
21.5 "REAL_POW_DIV" > "Power.power_divide"
21.6 "REAL_POW_ADD" > "Power.power_add"
21.7 - "REAL_POW2_ABS" > "NatBin.power2_abs"
21.8 + "REAL_POW2_ABS" > "Nat_Numeral.power2_abs"
21.9 "REAL_POS_NZ" > "HOL4Real.real.REAL_POS_NZ"
21.10 "REAL_POS" > "RealDef.real_of_nat_ge_zero"
21.11 "REAL_POASQ" > "HOL4Real.real.REAL_POASQ"
21.12 @@ -210,7 +210,7 @@
21.13 "REAL_LE_RDIV_EQ" > "Ring_and_Field.pos_le_divide_eq"
21.14 "REAL_LE_RDIV" > "Ring_and_Field.mult_imp_le_div_pos"
21.15 "REAL_LE_RADD" > "OrderedGroup.add_le_cancel_right"
21.16 - "REAL_LE_POW2" > "NatBin.zero_compare_simps_12"
21.17 + "REAL_LE_POW2" > "Nat_Numeral.zero_compare_simps_12"
21.18 "REAL_LE_NEGTOTAL" > "HOL4Real.real.REAL_LE_NEGTOTAL"
21.19 "REAL_LE_NEGR" > "OrderedGroup.le_minus_self_iff"
21.20 "REAL_LE_NEGL" > "OrderedGroup.minus_le_self_iff"
21.21 @@ -313,7 +313,7 @@
21.22 "POW_ONE" > "Power.power_one"
21.23 "POW_NZ" > "Power.field_power_not_zero"
21.24 "POW_MUL" > "Power.power_mult_distrib"
21.25 - "POW_MINUS1" > "NatBin.power_minus1_even"
21.26 + "POW_MINUS1" > "Nat_Numeral.power_minus1_even"
21.27 "POW_M1" > "HOL4Real.real.POW_M1"
21.28 "POW_LT" > "HOL4Real.real.POW_LT"
21.29 "POW_LE" > "Power.power_mono"
21.30 @@ -323,7 +323,7 @@
21.31 "POW_ABS" > "Power.power_abs"
21.32 "POW_2_LT" > "RealPow.two_realpow_gt"
21.33 "POW_2_LE1" > "RealPow.two_realpow_ge_one"
21.34 - "POW_2" > "NatBin.power2_eq_square"
21.35 + "POW_2" > "Nat_Numeral.power2_eq_square"
21.36 "POW_1" > "Power.power_one_right"
21.37 "POW_0" > "Power.power_0_Suc"
21.38 "ABS_ZERO" > "OrderedGroup.abs_eq_0"
21.39 @@ -335,7 +335,7 @@
21.40 "ABS_SIGN2" > "HOL4Real.real.ABS_SIGN2"
21.41 "ABS_SIGN" > "HOL4Real.real.ABS_SIGN"
21.42 "ABS_REFL" > "HOL4Real.real.ABS_REFL"
21.43 - "ABS_POW2" > "NatBin.abs_power2"
21.44 + "ABS_POW2" > "Nat_Numeral.abs_power2"
21.45 "ABS_POS" > "OrderedGroup.abs_ge_zero"
21.46 "ABS_NZ" > "OrderedGroup.zero_less_abs_iff"
21.47 "ABS_NEG" > "OrderedGroup.abs_minus_cancel"
22.1 --- a/src/HOL/Import/HOL4Compat.thy Mon Apr 20 12:27:23 2009 +0200
22.2 +++ b/src/HOL/Import/HOL4Compat.thy Mon Apr 20 16:28:13 2009 +0200
22.3 @@ -202,19 +202,13 @@
22.4
22.5 constdefs
22.6 FUNPOW :: "('a => 'a) => nat => 'a => 'a"
22.7 - "FUNPOW f n == f ^ n"
22.8 + "FUNPOW f n == f o^ n"
22.9
22.10 -lemma FUNPOW: "(ALL f x. (f ^ 0) x = x) &
22.11 - (ALL f n x. (f ^ Suc n) x = (f ^ n) (f x))"
22.12 -proof auto
22.13 - fix f n x
22.14 - have "ALL x. f ((f ^ n) x) = (f ^ n) (f x)"
22.15 - by (induct n,auto)
22.16 - thus "f ((f ^ n) x) = (f ^ n) (f x)"
22.17 - ..
22.18 -qed
22.19 +lemma FUNPOW: "(ALL f x. (f o^ 0) x = x) &
22.20 + (ALL f n x. (f o^ Suc n) x = (f o^ n) (f x))"
22.21 + by (simp add: funpow_swap1)
22.22
22.23 -lemma [hol4rew]: "FUNPOW f n = f ^ n"
22.24 +lemma [hol4rew]: "FUNPOW f n = f o^ n"
22.25 by (simp add: FUNPOW_def)
22.26
22.27 lemma ADD: "(!n. (0::nat) + n = n) & (!m n. Suc m + n = Suc (m + n))"
22.28 @@ -224,7 +218,7 @@
22.29 by simp
22.30
22.31 lemma SUB: "(!m. (0::nat) - m = 0) & (!m n. (Suc m) - n = (if m < n then 0 else Suc (m - n)))"
22.32 - by (simp, arith)
22.33 + by (simp) arith
22.34
22.35 lemma MAX_DEF: "max (m::nat) n = (if m < n then n else m)"
22.36 by (simp add: max_def)
23.1 --- a/src/HOL/Import/HOLLight/hollight.imp Mon Apr 20 12:27:23 2009 +0200
23.2 +++ b/src/HOL/Import/HOLLight/hollight.imp Mon Apr 20 16:28:13 2009 +0200
23.3 @@ -1515,7 +1515,7 @@
23.4 "EQ_REFL_T" > "HOL.simp_thms_6"
23.5 "EQ_REFL" > "Presburger.fm_modd_pinf"
23.6 "EQ_MULT_RCANCEL" > "Nat.mult_cancel2"
23.7 - "EQ_MULT_LCANCEL" > "NatBin.nat_mult_eq_cancel_disj"
23.8 + "EQ_MULT_LCANCEL" > "Nat_Numeral.nat_mult_eq_cancel_disj"
23.9 "EQ_IMP_LE" > "HOLLight.hollight.EQ_IMP_LE"
23.10 "EQ_EXT" > "HOL.meta_eq_to_obj_eq"
23.11 "EQ_CLAUSES" > "HOLLight.hollight.EQ_CLAUSES"
24.1 --- a/src/HOL/IntDiv.thy Mon Apr 20 12:27:23 2009 +0200
24.2 +++ b/src/HOL/IntDiv.thy Mon Apr 20 16:28:13 2009 +0200
24.3 @@ -249,33 +249,33 @@
24.4 text {* Tool setup *}
24.5
24.6 ML {*
24.7 -local
24.8 +local
24.9
24.10 -structure CancelDivMod = CancelDivModFun(
24.11 -struct
24.12 - val div_name = @{const_name Divides.div};
24.13 - val mod_name = @{const_name Divides.mod};
24.14 +structure CancelDivMod = CancelDivModFun(struct
24.15 +
24.16 + val div_name = @{const_name div};
24.17 + val mod_name = @{const_name mod};
24.18 val mk_binop = HOLogic.mk_binop;
24.19 val mk_sum = Int_Numeral_Simprocs.mk_sum HOLogic.intT;
24.20 val dest_sum = Int_Numeral_Simprocs.dest_sum;
24.21 - val div_mod_eqs =
24.22 - map mk_meta_eq [@{thm zdiv_zmod_equality},
24.23 - @{thm zdiv_zmod_equality2}];
24.24 +
24.25 + val div_mod_eqs = map mk_meta_eq [@{thm zdiv_zmod_equality}, @{thm zdiv_zmod_equality2}];
24.26 +
24.27 val trans = trans;
24.28 - val prove_eq_sums =
24.29 - let
24.30 - val simps = @{thm diff_int_def} :: Int_Numeral_Simprocs.add_0s @ @{thms zadd_ac}
24.31 - in Arith_Data.prove_conv2 all_tac (Arith_Data.simp_all_tac simps) end;
24.32 +
24.33 + val prove_eq_sums = Arith_Data.prove_conv2 all_tac (Arith_Data.simp_all_tac
24.34 + (@{thm diff_minus} :: @{thms add_0s} @ @{thms add_ac}))
24.35 +
24.36 end)
24.37
24.38 in
24.39
24.40 -val cancel_zdiv_zmod_proc = Simplifier.simproc (the_context ())
24.41 - "cancel_zdiv_zmod" ["(m::int) + n"] (K CancelDivMod.proc)
24.42 +val cancel_div_mod_int_proc = Simplifier.simproc (the_context ())
24.43 + "cancel_zdiv_zmod" ["(k::int) + l"] (K CancelDivMod.proc);
24.44
24.45 -end;
24.46 +val _ = Addsimprocs [cancel_div_mod_int_proc];
24.47
24.48 -Addsimprocs [cancel_zdiv_zmod_proc]
24.49 +end
24.50 *}
24.51
24.52 lemma pos_mod_conj : "(0::int) < b ==> 0 \<le> a mod b & a mod b < b"
24.53 @@ -711,6 +711,26 @@
24.54 show "(a + c * b) div b = c + a div b"
24.55 unfolding zdiv_zadd1_eq [of a "c * b"] using not0
24.56 by (simp add: zmod_zmult1_eq zmod_zdiv_trivial zdiv_zmult1_eq)
24.57 +next
24.58 + fix a b c :: int
24.59 + assume "a \<noteq> 0"
24.60 + then show "(a * b) div (a * c) = b div c"
24.61 + proof (cases "b \<noteq> 0 \<and> c \<noteq> 0")
24.62 + case False then show ?thesis by auto
24.63 + next
24.64 + case True then have "b \<noteq> 0" and "c \<noteq> 0" by auto
24.65 + with `a \<noteq> 0`
24.66 + have "\<And>q r. divmod_rel b c (q, r) \<Longrightarrow> divmod_rel (a * b) (a * c) (q, a * r)"
24.67 + apply (auto simp add: divmod_rel_def)
24.68 + apply (auto simp add: algebra_simps)
24.69 + apply (auto simp add: zero_less_mult_iff zero_le_mult_iff mult_le_0_iff)
24.70 + apply (simp_all add: mult_less_cancel_left_disj mult_commute [of _ a])
24.71 + done
24.72 + moreover with `c \<noteq> 0` divmod_rel_div_mod have "divmod_rel b c (b div c, b mod c)" by auto
24.73 + ultimately have "divmod_rel (a * b) (a * c) (b div c, a * (b mod c))" .
24.74 + moreover from `a \<noteq> 0` `c \<noteq> 0` have "a * c \<noteq> 0" by simp
24.75 + ultimately show ?thesis by (rule divmod_rel_div)
24.76 + qed
24.77 qed auto
24.78
24.79 lemma posDivAlg_div_mod:
24.80 @@ -808,52 +828,6 @@
24.81 done
24.82
24.83
24.84 -subsection{*Cancellation of Common Factors in div*}
24.85 -
24.86 -lemma zdiv_zmult_zmult1_aux1:
24.87 - "[| (0::int) < b; c \<noteq> 0 |] ==> (c*a) div (c*b) = a div b"
24.88 -by (subst zdiv_zmult2_eq, auto)
24.89 -
24.90 -lemma zdiv_zmult_zmult1_aux2:
24.91 - "[| b < (0::int); c \<noteq> 0 |] ==> (c*a) div (c*b) = a div b"
24.92 -apply (subgoal_tac " (c * (-a)) div (c * (-b)) = (-a) div (-b) ")
24.93 -apply (rule_tac [2] zdiv_zmult_zmult1_aux1, auto)
24.94 -done
24.95 -
24.96 -lemma zdiv_zmult_zmult1: "c \<noteq> (0::int) ==> (c*a) div (c*b) = a div b"
24.97 -apply (case_tac "b = 0", simp)
24.98 -apply (auto simp add: linorder_neq_iff zdiv_zmult_zmult1_aux1 zdiv_zmult_zmult1_aux2)
24.99 -done
24.100 -
24.101 -lemma zdiv_zmult_zmult1_if[simp]:
24.102 - "(k*m) div (k*n) = (if k = (0::int) then 0 else m div n)"
24.103 -by (simp add:zdiv_zmult_zmult1)
24.104 -
24.105 -
24.106 -subsection{*Distribution of Factors over mod*}
24.107 -
24.108 -lemma zmod_zmult_zmult1_aux1:
24.109 - "[| (0::int) < b; c \<noteq> 0 |] ==> (c*a) mod (c*b) = c * (a mod b)"
24.110 -by (subst zmod_zmult2_eq, auto)
24.111 -
24.112 -lemma zmod_zmult_zmult1_aux2:
24.113 - "[| b < (0::int); c \<noteq> 0 |] ==> (c*a) mod (c*b) = c * (a mod b)"
24.114 -apply (subgoal_tac " (c * (-a)) mod (c * (-b)) = c * ((-a) mod (-b))")
24.115 -apply (rule_tac [2] zmod_zmult_zmult1_aux1, auto)
24.116 -done
24.117 -
24.118 -lemma zmod_zmult_zmult1: "(c*a) mod (c*b) = (c::int) * (a mod b)"
24.119 -apply (case_tac "b = 0", simp)
24.120 -apply (case_tac "c = 0", simp)
24.121 -apply (auto simp add: linorder_neq_iff zmod_zmult_zmult1_aux1 zmod_zmult_zmult1_aux2)
24.122 -done
24.123 -
24.124 -lemma zmod_zmult_zmult2: "(a*c) mod (b*c) = (a mod b) * (c::int)"
24.125 -apply (cut_tac c = c in zmod_zmult_zmult1)
24.126 -apply (auto simp add: mult_commute)
24.127 -done
24.128 -
24.129 -
24.130 subsection {*Splitting Rules for div and mod*}
24.131
24.132 text{*The proofs of the two lemmas below are essentially identical*}
24.133 @@ -937,7 +911,7 @@
24.134 right_distrib)
24.135 thus ?thesis
24.136 by (subst zdiv_zadd1_eq,
24.137 - simp add: zdiv_zmult_zmult1 zmod_zmult_zmult1 one_less_a2
24.138 + simp add: mod_mult_mult1 one_less_a2
24.139 div_pos_pos_trivial)
24.140 qed
24.141
24.142 @@ -961,7 +935,7 @@
24.143 then number_of v div (number_of w)
24.144 else (number_of v + (1::int)) div (number_of w))"
24.145 apply (simp only: number_of_eq numeral_simps UNIV_I split: split_if)
24.146 -apply (simp add: zdiv_zmult_zmult1 pos_zdiv_mult_2 neg_zdiv_mult_2 add_ac)
24.147 +apply (simp add: pos_zdiv_mult_2 neg_zdiv_mult_2 add_ac)
24.148 done
24.149
24.150
24.151 @@ -977,7 +951,7 @@
24.152 apply (auto simp add: add_commute [of 1] mult_commute add1_zle_eq
24.153 pos_mod_bound)
24.154 apply (subst mod_add_eq)
24.155 -apply (simp add: zmod_zmult_zmult2 mod_pos_pos_trivial)
24.156 +apply (simp add: mod_mult_mult2 mod_pos_pos_trivial)
24.157 apply (rule mod_pos_pos_trivial)
24.158 apply (auto simp add: mod_pos_pos_trivial ring_distribs)
24.159 apply (subgoal_tac "0 \<le> b mod a", arith, simp)
24.160 @@ -998,7 +972,7 @@
24.161 "number_of (Int.Bit0 v) mod number_of (Int.Bit0 w) =
24.162 (2::int) * (number_of v mod number_of w)"
24.163 apply (simp only: number_of_eq numeral_simps)
24.164 -apply (simp add: zmod_zmult_zmult1 pos_zmod_mult_2
24.165 +apply (simp add: mod_mult_mult1 pos_zmod_mult_2
24.166 neg_zmod_mult_2 add_ac)
24.167 done
24.168
24.169 @@ -1008,7 +982,7 @@
24.170 then 2 * (number_of v mod number_of w) + 1
24.171 else 2 * ((number_of v + (1::int)) mod number_of w) - 1)"
24.172 apply (simp only: number_of_eq numeral_simps)
24.173 -apply (simp add: zmod_zmult_zmult1 pos_zmod_mult_2
24.174 +apply (simp add: mod_mult_mult1 pos_zmod_mult_2
24.175 neg_zmod_mult_2 add_ac)
24.176 done
24.177
24.178 @@ -1090,9 +1064,7 @@
24.179 done
24.180
24.181 lemma zdvd_zmod: "f dvd m ==> f dvd (n::int) ==> f dvd m mod n"
24.182 - apply (simp add: dvd_def)
24.183 - apply (auto simp add: zmod_zmult_zmult1)
24.184 - done
24.185 + by (auto elim!: dvdE simp add: mod_mult_mult1)
24.186
24.187 lemma zdvd_zmod_imp_zdvd: "k dvd m mod n ==> k dvd n ==> k dvd (m::int)"
24.188 apply (subgoal_tac "k dvd n * (m div n) + m mod n")
24.189 @@ -1247,9 +1219,9 @@
24.190 lemmas zmod_simps =
24.191 mod_add_left_eq [symmetric]
24.192 mod_add_right_eq [symmetric]
24.193 - IntDiv.zmod_zmult1_eq [symmetric]
24.194 - mod_mult_left_eq [symmetric]
24.195 - IntDiv.zpower_zmod
24.196 + zmod_zmult1_eq [symmetric]
24.197 + mod_mult_left_eq [symmetric]
24.198 + zpower_zmod
24.199 zminus_zmod zdiff_zmod_left zdiff_zmod_right
24.200
24.201 text {* Distributive laws for function @{text nat}. *}
25.1 --- a/src/HOL/IsaMakefile Mon Apr 20 12:27:23 2009 +0200
25.2 +++ b/src/HOL/IsaMakefile Mon Apr 20 16:28:13 2009 +0200
25.3 @@ -89,7 +89,6 @@
25.4 $(SRC)/Tools/IsaPlanner/rw_tools.ML \
25.5 $(SRC)/Tools/IsaPlanner/zipper.ML \
25.6 $(SRC)/Tools/atomize_elim.ML \
25.7 - $(SRC)/Tools/code/code_funcgr.ML \
25.8 $(SRC)/Tools/code/code_haskell.ML \
25.9 $(SRC)/Tools/code/code_ml.ML \
25.10 $(SRC)/Tools/code/code_name.ML \
25.11 @@ -106,7 +105,7 @@
25.12 $(SRC)/Tools/project_rule.ML \
25.13 $(SRC)/Tools/random_word.ML \
25.14 $(SRC)/Tools/value.ML \
25.15 - Code_Setup.thy \
25.16 + $(SRC)/Tools/Code_Generator.thy \
25.17 HOL.thy \
25.18 Tools/hologic.ML \
25.19 Tools/recfun_codegen.ML \
25.20 @@ -216,10 +215,9 @@
25.21 List.thy \
25.22 Main.thy \
25.23 Map.thy \
25.24 - NatBin.thy \
25.25 + Nat_Numeral.thy \
25.26 Presburger.thy \
25.27 Recdef.thy \
25.28 - Relation_Power.thy \
25.29 SetInterval.thy \
25.30 $(SRC)/Provers/Arith/assoc_fold.ML \
25.31 $(SRC)/Provers/Arith/cancel_numeral_factor.ML \
26.1 --- a/src/HOL/Library/Code_Index.thy Mon Apr 20 12:27:23 2009 +0200
26.2 +++ b/src/HOL/Library/Code_Index.thy Mon Apr 20 16:28:13 2009 +0200
26.3 @@ -144,7 +144,7 @@
26.4
26.5 subsection {* Basic arithmetic *}
26.6
26.7 -instantiation index :: "{minus, ordered_semidom, Divides.div, linorder}"
26.8 +instantiation index :: "{minus, ordered_semidom, semiring_div, linorder}"
26.9 begin
26.10
26.11 definition [simp, code del]:
26.12 @@ -172,7 +172,7 @@
26.13 "n < m \<longleftrightarrow> nat_of n < nat_of m"
26.14
26.15 instance proof
26.16 -qed (auto simp add: left_distrib)
26.17 +qed (auto simp add: index left_distrib div_mult_self1)
26.18
26.19 end
26.20
27.1 --- a/src/HOL/Library/Coinductive_List.thy Mon Apr 20 12:27:23 2009 +0200
27.2 +++ b/src/HOL/Library/Coinductive_List.thy Mon Apr 20 16:28:13 2009 +0200
27.3 @@ -786,7 +786,7 @@
27.4
27.5 lemma funpow_lmap:
27.6 fixes f :: "'a \<Rightarrow> 'a"
27.7 - shows "(lmap f ^ n) (LCons b l) = LCons ((f ^ n) b) ((lmap f ^ n) l)"
27.8 + shows "(lmap f o^ n) (LCons b l) = LCons ((f o^ n) b) ((lmap f o^ n) l)"
27.9 by (induct n) simp_all
27.10
27.11
27.12 @@ -796,35 +796,35 @@
27.13 proof
27.14 fix x
27.15 have "(h x, iterates f x) \<in>
27.16 - {((lmap f ^ n) (h u), (lmap f ^ n) (iterates f u)) | u n. True}"
27.17 + {((lmap f o^ n) (h u), (lmap f o^ n) (iterates f u)) | u n. True}"
27.18 proof -
27.19 - have "(h x, iterates f x) = ((lmap f ^ 0) (h x), (lmap f ^ 0) (iterates f x))"
27.20 + have "(h x, iterates f x) = ((lmap f o^ 0) (h x), (lmap f o^ 0) (iterates f x))"
27.21 by simp
27.22 then show ?thesis by blast
27.23 qed
27.24 then show "h x = iterates f x"
27.25 proof (coinduct rule: llist_equalityI)
27.26 case (Eqllist q)
27.27 - then obtain u n where "q = ((lmap f ^ n) (h u), (lmap f ^ n) (iterates f u))"
27.28 + then obtain u n where "q = ((lmap f o^ n) (h u), (lmap f o^ n) (iterates f u))"
27.29 (is "_ = (?q1, ?q2)")
27.30 by auto
27.31 - also have "?q1 = LCons ((f ^ n) u) ((lmap f ^ Suc n) (h u))"
27.32 + also have "?q1 = LCons ((f o^ n) u) ((lmap f o^ Suc n) (h u))"
27.33 proof -
27.34 - have "?q1 = (lmap f ^ n) (LCons u (lmap f (h u)))"
27.35 + have "?q1 = (lmap f o^ n) (LCons u (lmap f (h u)))"
27.36 by (subst h) rule
27.37 - also have "\<dots> = LCons ((f ^ n) u) ((lmap f ^ n) (lmap f (h u)))"
27.38 + also have "\<dots> = LCons ((f o^ n) u) ((lmap f o^ n) (lmap f (h u)))"
27.39 by (rule funpow_lmap)
27.40 - also have "(lmap f ^ n) (lmap f (h u)) = (lmap f ^ Suc n) (h u)"
27.41 + also have "(lmap f o^ n) (lmap f (h u)) = (lmap f o^ Suc n) (h u)"
27.42 by (simp add: funpow_swap1)
27.43 finally show ?thesis .
27.44 qed
27.45 - also have "?q2 = LCons ((f ^ n) u) ((lmap f ^ Suc n) (iterates f u))"
27.46 + also have "?q2 = LCons ((f o^ n) u) ((lmap f o^ Suc n) (iterates f u))"
27.47 proof -
27.48 - have "?q2 = (lmap f ^ n) (LCons u (iterates f (f u)))"
27.49 + have "?q2 = (lmap f o^ n) (LCons u (iterates f (f u)))"
27.50 by (subst iterates) rule
27.51 - also have "\<dots> = LCons ((f ^ n) u) ((lmap f ^ n) (iterates f (f u)))"
27.52 + also have "\<dots> = LCons ((f o^ n) u) ((lmap f o^ n) (iterates f (f u)))"
27.53 by (rule funpow_lmap)
27.54 - also have "(lmap f ^ n) (iterates f (f u)) = (lmap f ^ Suc n) (iterates f u)"
27.55 + also have "(lmap f o^ n) (iterates f (f u)) = (lmap f o^ Suc n) (iterates f u)"
27.56 by (simp add: lmap_iterates funpow_swap1)
27.57 finally show ?thesis .
27.58 qed
28.1 --- a/src/HOL/Library/Continuity.thy Mon Apr 20 12:27:23 2009 +0200
28.2 +++ b/src/HOL/Library/Continuity.thy Mon Apr 20 16:28:13 2009 +0200
28.3 @@ -5,7 +5,7 @@
28.4 header {* Continuity and iterations (of set transformers) *}
28.5
28.6 theory Continuity
28.7 -imports Relation_Power Main
28.8 +imports Transitive_Closure Main
28.9 begin
28.10
28.11 subsection {* Continuity for complete lattices *}
28.12 @@ -48,25 +48,25 @@
28.13 qed
28.14
28.15 lemma continuous_lfp:
28.16 - assumes "continuous F" shows "lfp F = (SUP i. (F^i) bot)"
28.17 + assumes "continuous F" shows "lfp F = (SUP i. (F o^ i) bot)"
28.18 proof -
28.19 note mono = continuous_mono[OF `continuous F`]
28.20 - { fix i have "(F^i) bot \<le> lfp F"
28.21 + { fix i have "(F o^ i) bot \<le> lfp F"
28.22 proof (induct i)
28.23 - show "(F^0) bot \<le> lfp F" by simp
28.24 + show "(F o^ 0) bot \<le> lfp F" by simp
28.25 next
28.26 case (Suc i)
28.27 - have "(F^(Suc i)) bot = F((F^i) bot)" by simp
28.28 + have "(F o^ Suc i) bot = F((F o^ i) bot)" by simp
28.29 also have "\<dots> \<le> F(lfp F)" by(rule monoD[OF mono Suc])
28.30 also have "\<dots> = lfp F" by(simp add:lfp_unfold[OF mono, symmetric])
28.31 finally show ?case .
28.32 qed }
28.33 - hence "(SUP i. (F^i) bot) \<le> lfp F" by (blast intro!:SUP_leI)
28.34 - moreover have "lfp F \<le> (SUP i. (F^i) bot)" (is "_ \<le> ?U")
28.35 + hence "(SUP i. (F o^ i) bot) \<le> lfp F" by (blast intro!:SUP_leI)
28.36 + moreover have "lfp F \<le> (SUP i. (F o^ i) bot)" (is "_ \<le> ?U")
28.37 proof (rule lfp_lowerbound)
28.38 - have "chain(%i. (F^i) bot)"
28.39 + have "chain(%i. (F o^ i) bot)"
28.40 proof -
28.41 - { fix i have "(F^i) bot \<le> (F^(Suc i)) bot"
28.42 + { fix i have "(F o^ i) bot \<le> (F o^ (Suc i)) bot"
28.43 proof (induct i)
28.44 case 0 show ?case by simp
28.45 next
28.46 @@ -74,7 +74,7 @@
28.47 qed }
28.48 thus ?thesis by(auto simp add:chain_def)
28.49 qed
28.50 - hence "F ?U = (SUP i. (F^(i+1)) bot)" using `continuous F` by (simp add:continuous_def)
28.51 + hence "F ?U = (SUP i. (F o^ (i+1)) bot)" using `continuous F` by (simp add:continuous_def)
28.52 also have "\<dots> \<le> ?U" by(fast intro:SUP_leI le_SUPI)
28.53 finally show "F ?U \<le> ?U" .
28.54 qed
28.55 @@ -193,7 +193,7 @@
28.56
28.57 definition
28.58 up_iterate :: "('a set => 'a set) => nat => 'a set" where
28.59 - "up_iterate f n = (f^n) {}"
28.60 + "up_iterate f n = (f o^ n) {}"
28.61
28.62 lemma up_iterate_0 [simp]: "up_iterate f 0 = {}"
28.63 by (simp add: up_iterate_def)
28.64 @@ -245,7 +245,7 @@
28.65
28.66 definition
28.67 down_iterate :: "('a set => 'a set) => nat => 'a set" where
28.68 - "down_iterate f n = (f^n) UNIV"
28.69 + "down_iterate f n = (f o^ n) UNIV"
28.70
28.71 lemma down_iterate_0 [simp]: "down_iterate f 0 = UNIV"
28.72 by (simp add: down_iterate_def)
29.1 --- a/src/HOL/Library/Eval_Witness.thy Mon Apr 20 12:27:23 2009 +0200
29.2 +++ b/src/HOL/Library/Eval_Witness.thy Mon Apr 20 16:28:13 2009 +0200
29.3 @@ -68,7 +68,7 @@
29.4 | dest_exs _ _ = sys_error "dest_exs";
29.5 val t = dest_exs (length ws) (HOLogic.dest_Trueprop goal);
29.6 in
29.7 - if Code_ML.eval_term ("Eval_Witness_Method.eval_ref", Eval_Witness_Method.eval_ref) thy t ws
29.8 + if Code_ML.eval NONE ("Eval_Witness_Method.eval_ref", Eval_Witness_Method.eval_ref) thy t ws
29.9 then Thm.cterm_of thy goal
29.10 else @{cprop True} (*dummy*)
29.11 end
30.1 --- a/src/HOL/Library/Formal_Power_Series.thy Mon Apr 20 12:27:23 2009 +0200
30.2 +++ b/src/HOL/Library/Formal_Power_Series.thy Mon Apr 20 16:28:13 2009 +0200
30.3 @@ -1022,13 +1022,15 @@
30.4 lemma XD_linear[simp]: "XD (fps_const c * a + fps_const d * b) = fps_const c * XD a + fps_const d * XD (b :: ('a::comm_ring_1) fps)"
30.5 by simp
30.6
30.7 -lemma XDN_linear: "(XD^n) (fps_const c * a + fps_const d * b) = fps_const c * (XD^n) a + fps_const d * (XD^n) (b :: ('a::comm_ring_1) fps)"
30.8 +lemma XDN_linear:
30.9 + "(XD o^ n) (fps_const c * a + fps_const d * b) = fps_const c * (XD o^ n) a + fps_const d * (XD o^ n) (b :: ('a::comm_ring_1) fps)"
30.10 by (induct n, simp_all)
30.11
30.12 lemma fps_mult_X_deriv_shift: "X* fps_deriv a = Abs_fps (\<lambda>n. of_nat n* a$n)" by (simp add: fps_eq_iff)
30.13
30.14 -lemma fps_mult_XD_shift: "(XD ^k) (a:: ('a::{comm_ring_1, recpower, ring_char_0}) fps) = Abs_fps (\<lambda>n. (of_nat n ^ k) * a$n)"
30.15 -by (induct k arbitrary: a) (simp_all add: power_Suc XD_def fps_eq_iff ring_simps del: One_nat_def)
30.16 +lemma fps_mult_XD_shift:
30.17 + "(XD o^ k) (a:: ('a::{comm_ring_1, recpower, ring_char_0}) fps) = Abs_fps (\<lambda>n. (of_nat n ^ k) * a$n)"
30.18 + by (induct k arbitrary: a) (simp_all add: power_Suc XD_def fps_eq_iff ring_simps del: One_nat_def)
30.19
30.20 subsubsection{* Rule 3 is trivial and is given by @{text fps_times_def}*}
30.21 subsubsection{* Rule 5 --- summation and "division" by (1 - X)*}
31.1 --- a/src/HOL/Library/Polynomial.thy Mon Apr 20 12:27:23 2009 +0200
31.2 +++ b/src/HOL/Library/Polynomial.thy Mon Apr 20 16:28:13 2009 +0200
31.3 @@ -987,6 +987,30 @@
31.4 by (simp add: pdivmod_rel_def left_distrib)
31.5 thus "(x + z * y) div y = z + x div y"
31.6 by (rule div_poly_eq)
31.7 +next
31.8 + fix x y z :: "'a poly"
31.9 + assume "x \<noteq> 0"
31.10 + show "(x * y) div (x * z) = y div z"
31.11 + proof (cases "y \<noteq> 0 \<and> z \<noteq> 0")
31.12 + have "\<And>x::'a poly. pdivmod_rel x 0 0 x"
31.13 + by (rule pdivmod_rel_by_0)
31.14 + then have [simp]: "\<And>x::'a poly. x div 0 = 0"
31.15 + by (rule div_poly_eq)
31.16 + have "\<And>x::'a poly. pdivmod_rel 0 x 0 0"
31.17 + by (rule pdivmod_rel_0)
31.18 + then have [simp]: "\<And>x::'a poly. 0 div x = 0"
31.19 + by (rule div_poly_eq)
31.20 + case False then show ?thesis by auto
31.21 + next
31.22 + case True then have "y \<noteq> 0" and "z \<noteq> 0" by auto
31.23 + with `x \<noteq> 0`
31.24 + have "\<And>q r. pdivmod_rel y z q r \<Longrightarrow> pdivmod_rel (x * y) (x * z) q (x * r)"
31.25 + by (auto simp add: pdivmod_rel_def algebra_simps)
31.26 + (rule classical, simp add: degree_mult_eq)
31.27 + moreover from pdivmod_rel have "pdivmod_rel y z (y div z) (y mod z)" .
31.28 + ultimately have "pdivmod_rel (x * y) (x * z) (y div z) (x * (y mod z))" .
31.29 + then show ?thesis by (simp add: div_poly_eq)
31.30 + qed
31.31 qed
31.32
31.33 end
32.1 --- a/src/HOL/Library/Quickcheck.thy Mon Apr 20 12:27:23 2009 +0200
32.2 +++ b/src/HOL/Library/Quickcheck.thy Mon Apr 20 16:28:13 2009 +0200
32.3 @@ -47,6 +47,8 @@
32.4
32.5 val eval_ref : (unit -> int -> int * int -> term list option * (int * int)) option ref = ref NONE;
32.6
32.7 +val target = "Quickcheck";
32.8 +
32.9 fun mk_generator_expr thy prop tys =
32.10 let
32.11 val bound_max = length tys - 1;
32.12 @@ -72,14 +74,74 @@
32.13 let
32.14 val tys = (map snd o fst o strip_abs) t;
32.15 val t' = mk_generator_expr thy t tys;
32.16 - val f = Code_ML.eval_term ("Quickcheck.eval_ref", eval_ref) thy t' [];
32.17 + val f = Code_ML.eval (SOME target) ("Quickcheck.eval_ref", eval_ref) thy t' [];
32.18 in f #> Random_Engine.run #> (Option.map o map) (Code.postprocess_term thy) end;
32.19
32.20 end
32.21 *}
32.22
32.23 setup {*
32.24 - Quickcheck.add_generator ("code", Quickcheck.compile_generator_expr o ProofContext.theory_of)
32.25 + Code_Target.extend_target (Quickcheck.target, (Code_ML.target_Eval, K I))
32.26 + #> Quickcheck.add_generator ("code", Quickcheck.compile_generator_expr o ProofContext.theory_of)
32.27 *}
32.28
32.29 +
32.30 +subsection {* Type @{typ "'a \<Rightarrow> 'b"} *}
32.31 +
32.32 +ML {*
32.33 +structure Random_Engine =
32.34 +struct
32.35 +
32.36 +open Random_Engine;
32.37 +
32.38 +fun random_fun (T1 : typ) (T2 : typ) (eq : 'a -> 'a -> bool) (term_of : 'a -> term)
32.39 + (random : Random_Engine.seed -> ('b * (unit -> term)) * Random_Engine.seed)
32.40 + (random_split : Random_Engine.seed -> Random_Engine.seed * Random_Engine.seed)
32.41 + (seed : Random_Engine.seed) =
32.42 + let
32.43 + val (seed', seed'') = random_split seed;
32.44 + val state = ref (seed', [], Const (@{const_name undefined}, T1 --> T2));
32.45 + val fun_upd = Const (@{const_name fun_upd},
32.46 + (T1 --> T2) --> T1 --> T2 --> T1 --> T2);
32.47 + fun random_fun' x =
32.48 + let
32.49 + val (seed, fun_map, f_t) = ! state;
32.50 + in case AList.lookup (uncurry eq) fun_map x
32.51 + of SOME y => y
32.52 + | NONE => let
32.53 + val t1 = term_of x;
32.54 + val ((y, t2), seed') = random seed;
32.55 + val fun_map' = (x, y) :: fun_map;
32.56 + val f_t' = fun_upd $ f_t $ t1 $ t2 ();
32.57 + val _ = state := (seed', fun_map', f_t');
32.58 + in y end
32.59 + end;
32.60 + fun term_fun' () = #3 (! state);
32.61 + in ((random_fun', term_fun'), seed'') end;
32.62 +
32.63 end
32.64 +*}
32.65 +
32.66 +axiomatization
32.67 + random_fun_aux :: "typerep \<Rightarrow> typerep \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> term)
32.68 + \<Rightarrow> (seed \<Rightarrow> ('b \<times> (unit \<Rightarrow> term)) \<times> seed) \<Rightarrow> (seed \<Rightarrow> seed \<times> seed)
32.69 + \<Rightarrow> seed \<Rightarrow> (('a \<Rightarrow> 'b) \<times> (unit \<Rightarrow> term)) \<times> seed"
32.70 +
32.71 +code_const random_fun_aux (Quickcheck "Random'_Engine.random'_fun")
32.72 + -- {* With enough criminal energy this can be abused to derive @{prop False};
32.73 + for this reason we use a distinguished target @{text Quickcheck}
32.74 + not spoiling the regular trusted code generation *}
32.75 +
32.76 +instantiation "fun" :: ("{eq, term_of}", "{type, random}") random
32.77 +begin
32.78 +
32.79 +definition random_fun :: "index \<Rightarrow> seed \<Rightarrow> (('a \<Rightarrow> 'b) \<times> (unit \<Rightarrow> term)) \<times> seed" where
32.80 + "random n = random_fun_aux TYPEREP('a) TYPEREP('b) (op =) Code_Eval.term_of (random n) split_seed"
32.81 +
32.82 +instance ..
32.83 +
32.84 +end
32.85 +
32.86 +code_reserved Quickcheck Random_Engine
32.87 +
32.88 +end
33.1 --- a/src/HOL/Library/Topology_Euclidean_Space.thy Mon Apr 20 12:27:23 2009 +0200
33.2 +++ b/src/HOL/Library/Topology_Euclidean_Space.thy Mon Apr 20 16:28:13 2009 +0200
33.3 @@ -5441,7 +5441,7 @@
33.4 have "1 - c > 0" using c by auto
33.5
33.6 from s(2) obtain z0 where "z0 \<in> s" by auto
33.7 - def z \<equiv> "\<lambda> n::nat. fun_pow n f z0"
33.8 + def z \<equiv> "\<lambda> n::nat. funpow n f z0"
33.9 { fix n::nat
33.10 have "z n \<in> s" unfolding z_def
33.11 proof(induct n) case 0 thus ?case using `z0 \<in>s` by auto
33.12 @@ -5580,7 +5580,7 @@
33.13 using dist[THEN bspec[where x=x], THEN bspec[where x=y]] by auto } note dist' = this
33.14 def y \<equiv> "g x"
33.15 have [simp]:"y\<in>s" unfolding y_def using gs[unfolded image_subset_iff] and `x\<in>s` by blast
33.16 - def f \<equiv> "\<lambda> n. fun_pow n g"
33.17 + def f \<equiv> "\<lambda> n. funpow n g"
33.18 have [simp]:"\<And>n z. g (f n z) = f (Suc n) z" unfolding f_def by auto
33.19 have [simp]:"\<And>z. f 0 z = z" unfolding f_def by auto
33.20 { fix n::nat and z assume "z\<in>s"
34.1 --- a/src/HOL/List.thy Mon Apr 20 12:27:23 2009 +0200
34.2 +++ b/src/HOL/List.thy Mon Apr 20 16:28:13 2009 +0200
34.3 @@ -5,7 +5,7 @@
34.4 header {* The datatype of finite lists *}
34.5
34.6 theory List
34.7 -imports Plain Relation_Power Presburger Recdef ATP_Linkup
34.8 +imports Plain Presburger Recdef ATP_Linkup
34.9 uses "Tools/string_syntax.ML"
34.10 begin
34.11
34.12 @@ -198,7 +198,7 @@
34.13
34.14 definition
34.15 rotate :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
34.16 - "rotate n = rotate1 ^ n"
34.17 + "rotate n = rotate1 o^ n"
34.18
34.19 definition
34.20 list_all2 :: "('a => 'b => bool) => 'a list => 'b list => bool" where
35.1 --- a/src/HOL/Map.thy Mon Apr 20 12:27:23 2009 +0200
35.2 +++ b/src/HOL/Map.thy Mon Apr 20 16:28:13 2009 +0200
35.3 @@ -11,7 +11,7 @@
35.4 imports List
35.5 begin
35.6
35.7 -types ('a,'b) "~=>" = "'a => 'b option" (infixr 0)
35.8 +types ('a,'b) "~=>" = "'a => 'b option" (infixr "~=>" 0)
35.9 translations (type) "a ~=> b " <= (type) "a => b option"
35.10
35.11 syntax (xsymbols)
36.1 --- a/src/HOL/Nat.thy Mon Apr 20 12:27:23 2009 +0200
36.2 +++ b/src/HOL/Nat.thy Mon Apr 20 16:28:13 2009 +0200
36.3 @@ -1164,6 +1164,37 @@
36.4 end
36.5
36.6
36.7 +subsection {* Natural operation of natural numbers on functions *}
36.8 +
36.9 +text {* @{text "f o^ n = f o ... o f"}, the n-fold composition of @{text f} *}
36.10 +
36.11 +primrec funpow :: "nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a" where
36.12 + "funpow 0 f = id"
36.13 + | "funpow (Suc n) f = f o funpow n f"
36.14 +
36.15 +abbreviation funpower :: "('a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "o^" 80) where
36.16 + "f o^ n \<equiv> funpow n f"
36.17 +
36.18 +notation (latex output)
36.19 + funpower ("(_\<^bsup>_\<^esup>)" [1000] 1000)
36.20 +
36.21 +notation (HTML output)
36.22 + funpower ("(_\<^bsup>_\<^esup>)" [1000] 1000)
36.23 +
36.24 +lemma funpow_add:
36.25 + "f o^ (m + n) = f o^ m \<circ> f o^ n"
36.26 + by (induct m) simp_all
36.27 +
36.28 +lemma funpow_swap1:
36.29 + "f ((f o^ n) x) = (f o^ n) (f x)"
36.30 +proof -
36.31 + have "f ((f o^ n) x) = (f o^ (n + 1)) x" by simp
36.32 + also have "\<dots> = (f o^ n o f o^ 1) x" by (simp only: funpow_add)
36.33 + also have "\<dots> = (f o^ n) (f x)" by simp
36.34 + finally show ?thesis .
36.35 +qed
36.36 +
36.37 +
36.38 subsection {* Embedding of the Naturals into any
36.39 @{text semiring_1}: @{term of_nat} *}
36.40
37.1 --- a/src/HOL/NatBin.thy Mon Apr 20 12:27:23 2009 +0200
37.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
37.3 @@ -1,975 +0,0 @@
37.4 -(* Title: HOL/NatBin.thy
37.5 - Author: Lawrence C Paulson, Cambridge University Computer Laboratory
37.6 - Copyright 1999 University of Cambridge
37.7 -*)
37.8 -
37.9 -header {* Binary arithmetic for the natural numbers *}
37.10 -
37.11 -theory NatBin
37.12 -imports IntDiv
37.13 -uses ("Tools/nat_simprocs.ML")
37.14 -begin
37.15 -
37.16 -text {*
37.17 - Arithmetic for naturals is reduced to that for the non-negative integers.
37.18 -*}
37.19 -
37.20 -instantiation nat :: number
37.21 -begin
37.22 -
37.23 -definition
37.24 - nat_number_of_def [code inline, code del]: "number_of v = nat (number_of v)"
37.25 -
37.26 -instance ..
37.27 -
37.28 -end
37.29 -
37.30 -lemma [code post]:
37.31 - "nat (number_of v) = number_of v"
37.32 - unfolding nat_number_of_def ..
37.33 -
37.34 -abbreviation (xsymbols)
37.35 - power2 :: "'a::power => 'a" ("(_\<twosuperior>)" [1000] 999) where
37.36 - "x\<twosuperior> == x^2"
37.37 -
37.38 -notation (latex output)
37.39 - power2 ("(_\<twosuperior>)" [1000] 999)
37.40 -
37.41 -notation (HTML output)
37.42 - power2 ("(_\<twosuperior>)" [1000] 999)
37.43 -
37.44 -
37.45 -subsection {* Predicate for negative binary numbers *}
37.46 -
37.47 -definition neg :: "int \<Rightarrow> bool" where
37.48 - "neg Z \<longleftrightarrow> Z < 0"
37.49 -
37.50 -lemma not_neg_int [simp]: "~ neg (of_nat n)"
37.51 -by (simp add: neg_def)
37.52 -
37.53 -lemma neg_zminus_int [simp]: "neg (- (of_nat (Suc n)))"
37.54 -by (simp add: neg_def neg_less_0_iff_less del: of_nat_Suc)
37.55 -
37.56 -lemmas neg_eq_less_0 = neg_def
37.57 -
37.58 -lemma not_neg_eq_ge_0: "(~neg x) = (0 \<le> x)"
37.59 -by (simp add: neg_def linorder_not_less)
37.60 -
37.61 -text{*To simplify inequalities when Numeral1 can get simplified to 1*}
37.62 -
37.63 -lemma not_neg_0: "~ neg 0"
37.64 -by (simp add: One_int_def neg_def)
37.65 -
37.66 -lemma not_neg_1: "~ neg 1"
37.67 -by (simp add: neg_def linorder_not_less zero_le_one)
37.68 -
37.69 -lemma neg_nat: "neg z ==> nat z = 0"
37.70 -by (simp add: neg_def order_less_imp_le)
37.71 -
37.72 -lemma not_neg_nat: "~ neg z ==> of_nat (nat z) = z"
37.73 -by (simp add: linorder_not_less neg_def)
37.74 -
37.75 -text {*
37.76 - If @{term Numeral0} is rewritten to 0 then this rule can't be applied:
37.77 - @{term Numeral0} IS @{term "number_of Pls"}
37.78 -*}
37.79 -
37.80 -lemma not_neg_number_of_Pls: "~ neg (number_of Int.Pls)"
37.81 - by (simp add: neg_def)
37.82 -
37.83 -lemma neg_number_of_Min: "neg (number_of Int.Min)"
37.84 - by (simp add: neg_def)
37.85 -
37.86 -lemma neg_number_of_Bit0:
37.87 - "neg (number_of (Int.Bit0 w)) = neg (number_of w)"
37.88 - by (simp add: neg_def)
37.89 -
37.90 -lemma neg_number_of_Bit1:
37.91 - "neg (number_of (Int.Bit1 w)) = neg (number_of w)"
37.92 - by (simp add: neg_def)
37.93 -
37.94 -lemmas neg_simps [simp] =
37.95 - not_neg_0 not_neg_1
37.96 - not_neg_number_of_Pls neg_number_of_Min
37.97 - neg_number_of_Bit0 neg_number_of_Bit1
37.98 -
37.99 -
37.100 -subsection{*Function @{term nat}: Coercion from Type @{typ int} to @{typ nat}*}
37.101 -
37.102 -declare nat_0 [simp] nat_1 [simp]
37.103 -
37.104 -lemma nat_number_of [simp]: "nat (number_of w) = number_of w"
37.105 -by (simp add: nat_number_of_def)
37.106 -
37.107 -lemma nat_numeral_0_eq_0 [simp]: "Numeral0 = (0::nat)"
37.108 -by (simp add: nat_number_of_def)
37.109 -
37.110 -lemma nat_numeral_1_eq_1 [simp]: "Numeral1 = (1::nat)"
37.111 -by (simp add: nat_1 nat_number_of_def)
37.112 -
37.113 -lemma numeral_1_eq_Suc_0: "Numeral1 = Suc 0"
37.114 -by (simp add: nat_numeral_1_eq_1)
37.115 -
37.116 -lemma numeral_2_eq_2: "2 = Suc (Suc 0)"
37.117 -apply (unfold nat_number_of_def)
37.118 -apply (rule nat_2)
37.119 -done
37.120 -
37.121 -
37.122 -subsection{*Function @{term int}: Coercion from Type @{typ nat} to @{typ int}*}
37.123 -
37.124 -lemma int_nat_number_of [simp]:
37.125 - "int (number_of v) =
37.126 - (if neg (number_of v :: int) then 0
37.127 - else (number_of v :: int))"
37.128 - unfolding nat_number_of_def number_of_is_id neg_def
37.129 - by simp
37.130 -
37.131 -
37.132 -subsubsection{*Successor *}
37.133 -
37.134 -lemma Suc_nat_eq_nat_zadd1: "(0::int) <= z ==> Suc (nat z) = nat (1 + z)"
37.135 -apply (rule sym)
37.136 -apply (simp add: nat_eq_iff int_Suc)
37.137 -done
37.138 -
37.139 -lemma Suc_nat_number_of_add:
37.140 - "Suc (number_of v + n) =
37.141 - (if neg (number_of v :: int) then 1+n else number_of (Int.succ v) + n)"
37.142 - unfolding nat_number_of_def number_of_is_id neg_def numeral_simps
37.143 - by (simp add: Suc_nat_eq_nat_zadd1 add_ac)
37.144 -
37.145 -lemma Suc_nat_number_of [simp]:
37.146 - "Suc (number_of v) =
37.147 - (if neg (number_of v :: int) then 1 else number_of (Int.succ v))"
37.148 -apply (cut_tac n = 0 in Suc_nat_number_of_add)
37.149 -apply (simp cong del: if_weak_cong)
37.150 -done
37.151 -
37.152 -
37.153 -subsubsection{*Addition *}
37.154 -
37.155 -lemma add_nat_number_of [simp]:
37.156 - "(number_of v :: nat) + number_of v' =
37.157 - (if v < Int.Pls then number_of v'
37.158 - else if v' < Int.Pls then number_of v
37.159 - else number_of (v + v'))"
37.160 - unfolding nat_number_of_def number_of_is_id numeral_simps
37.161 - by (simp add: nat_add_distrib)
37.162 -
37.163 -lemma nat_number_of_add_1 [simp]:
37.164 - "number_of v + (1::nat) =
37.165 - (if v < Int.Pls then 1 else number_of (Int.succ v))"
37.166 - unfolding nat_number_of_def number_of_is_id numeral_simps
37.167 - by (simp add: nat_add_distrib)
37.168 -
37.169 -lemma nat_1_add_number_of [simp]:
37.170 - "(1::nat) + number_of v =
37.171 - (if v < Int.Pls then 1 else number_of (Int.succ v))"
37.172 - unfolding nat_number_of_def number_of_is_id numeral_simps
37.173 - by (simp add: nat_add_distrib)
37.174 -
37.175 -lemma nat_1_add_1 [simp]: "1 + 1 = (2::nat)"
37.176 - by (rule int_int_eq [THEN iffD1]) simp
37.177 -
37.178 -
37.179 -subsubsection{*Subtraction *}
37.180 -
37.181 -lemma diff_nat_eq_if:
37.182 - "nat z - nat z' =
37.183 - (if neg z' then nat z
37.184 - else let d = z-z' in
37.185 - if neg d then 0 else nat d)"
37.186 -by (simp add: Let_def nat_diff_distrib [symmetric] neg_eq_less_0 not_neg_eq_ge_0)
37.187 -
37.188 -
37.189 -lemma diff_nat_number_of [simp]:
37.190 - "(number_of v :: nat) - number_of v' =
37.191 - (if v' < Int.Pls then number_of v
37.192 - else let d = number_of (v + uminus v') in
37.193 - if neg d then 0 else nat d)"
37.194 - unfolding nat_number_of_def number_of_is_id numeral_simps neg_def
37.195 - by auto
37.196 -
37.197 -lemma nat_number_of_diff_1 [simp]:
37.198 - "number_of v - (1::nat) =
37.199 - (if v \<le> Int.Pls then 0 else number_of (Int.pred v))"
37.200 - unfolding nat_number_of_def number_of_is_id numeral_simps
37.201 - by auto
37.202 -
37.203 -
37.204 -subsubsection{*Multiplication *}
37.205 -
37.206 -lemma mult_nat_number_of [simp]:
37.207 - "(number_of v :: nat) * number_of v' =
37.208 - (if v < Int.Pls then 0 else number_of (v * v'))"
37.209 - unfolding nat_number_of_def number_of_is_id numeral_simps
37.210 - by (simp add: nat_mult_distrib)
37.211 -
37.212 -
37.213 -subsubsection{*Quotient *}
37.214 -
37.215 -lemma div_nat_number_of [simp]:
37.216 - "(number_of v :: nat) div number_of v' =
37.217 - (if neg (number_of v :: int) then 0
37.218 - else nat (number_of v div number_of v'))"
37.219 - unfolding nat_number_of_def number_of_is_id neg_def
37.220 - by (simp add: nat_div_distrib)
37.221 -
37.222 -lemma one_div_nat_number_of [simp]:
37.223 - "Suc 0 div number_of v' = nat (1 div number_of v')"
37.224 -by (simp del: nat_numeral_1_eq_1 add: numeral_1_eq_Suc_0 [symmetric])
37.225 -
37.226 -
37.227 -subsubsection{*Remainder *}
37.228 -
37.229 -lemma mod_nat_number_of [simp]:
37.230 - "(number_of v :: nat) mod number_of v' =
37.231 - (if neg (number_of v :: int) then 0
37.232 - else if neg (number_of v' :: int) then number_of v
37.233 - else nat (number_of v mod number_of v'))"
37.234 - unfolding nat_number_of_def number_of_is_id neg_def
37.235 - by (simp add: nat_mod_distrib)
37.236 -
37.237 -lemma one_mod_nat_number_of [simp]:
37.238 - "Suc 0 mod number_of v' =
37.239 - (if neg (number_of v' :: int) then Suc 0
37.240 - else nat (1 mod number_of v'))"
37.241 -by (simp del: nat_numeral_1_eq_1 add: numeral_1_eq_Suc_0 [symmetric])
37.242 -
37.243 -
37.244 -subsubsection{* Divisibility *}
37.245 -
37.246 -lemmas dvd_eq_mod_eq_0_number_of =
37.247 - dvd_eq_mod_eq_0 [of "number_of x" "number_of y", standard]
37.248 -
37.249 -declare dvd_eq_mod_eq_0_number_of [simp]
37.250 -
37.251 -ML
37.252 -{*
37.253 -val nat_number_of_def = thm"nat_number_of_def";
37.254 -
37.255 -val nat_number_of = thm"nat_number_of";
37.256 -val nat_numeral_0_eq_0 = thm"nat_numeral_0_eq_0";
37.257 -val nat_numeral_1_eq_1 = thm"nat_numeral_1_eq_1";
37.258 -val numeral_1_eq_Suc_0 = thm"numeral_1_eq_Suc_0";
37.259 -val numeral_2_eq_2 = thm"numeral_2_eq_2";
37.260 -val nat_div_distrib = thm"nat_div_distrib";
37.261 -val nat_mod_distrib = thm"nat_mod_distrib";
37.262 -val int_nat_number_of = thm"int_nat_number_of";
37.263 -val Suc_nat_eq_nat_zadd1 = thm"Suc_nat_eq_nat_zadd1";
37.264 -val Suc_nat_number_of_add = thm"Suc_nat_number_of_add";
37.265 -val Suc_nat_number_of = thm"Suc_nat_number_of";
37.266 -val add_nat_number_of = thm"add_nat_number_of";
37.267 -val diff_nat_eq_if = thm"diff_nat_eq_if";
37.268 -val diff_nat_number_of = thm"diff_nat_number_of";
37.269 -val mult_nat_number_of = thm"mult_nat_number_of";
37.270 -val div_nat_number_of = thm"div_nat_number_of";
37.271 -val mod_nat_number_of = thm"mod_nat_number_of";
37.272 -*}
37.273 -
37.274 -
37.275 -subsection{*Comparisons*}
37.276 -
37.277 -subsubsection{*Equals (=) *}
37.278 -
37.279 -lemma eq_nat_nat_iff:
37.280 - "[| (0::int) <= z; 0 <= z' |] ==> (nat z = nat z') = (z=z')"
37.281 -by (auto elim!: nonneg_eq_int)
37.282 -
37.283 -lemma eq_nat_number_of [simp]:
37.284 - "((number_of v :: nat) = number_of v') =
37.285 - (if neg (number_of v :: int) then (number_of v' :: int) \<le> 0
37.286 - else if neg (number_of v' :: int) then (number_of v :: int) = 0
37.287 - else v = v')"
37.288 - unfolding nat_number_of_def number_of_is_id neg_def
37.289 - by auto
37.290 -
37.291 -
37.292 -subsubsection{*Less-than (<) *}
37.293 -
37.294 -lemma less_nat_number_of [simp]:
37.295 - "(number_of v :: nat) < number_of v' \<longleftrightarrow>
37.296 - (if v < v' then Int.Pls < v' else False)"
37.297 - unfolding nat_number_of_def number_of_is_id numeral_simps
37.298 - by auto
37.299 -
37.300 -
37.301 -subsubsection{*Less-than-or-equal *}
37.302 -
37.303 -lemma le_nat_number_of [simp]:
37.304 - "(number_of v :: nat) \<le> number_of v' \<longleftrightarrow>
37.305 - (if v \<le> v' then True else v \<le> Int.Pls)"
37.306 - unfolding nat_number_of_def number_of_is_id numeral_simps
37.307 - by auto
37.308 -
37.309 -(*Maps #n to n for n = 0, 1, 2*)
37.310 -lemmas numerals = nat_numeral_0_eq_0 nat_numeral_1_eq_1 numeral_2_eq_2
37.311 -
37.312 -
37.313 -subsection{*Powers with Numeric Exponents*}
37.314 -
37.315 -text{*We cannot refer to the number @{term 2} in @{text Ring_and_Field.thy}.
37.316 -We cannot prove general results about the numeral @{term "-1"}, so we have to
37.317 -use @{term "- 1"} instead.*}
37.318 -
37.319 -lemma power2_eq_square: "(a::'a::recpower)\<twosuperior> = a * a"
37.320 - by (simp add: numeral_2_eq_2 Power.power_Suc)
37.321 -
37.322 -lemma zero_power2 [simp]: "(0::'a::{semiring_1,recpower})\<twosuperior> = 0"
37.323 - by (simp add: power2_eq_square)
37.324 -
37.325 -lemma one_power2 [simp]: "(1::'a::{semiring_1,recpower})\<twosuperior> = 1"
37.326 - by (simp add: power2_eq_square)
37.327 -
37.328 -lemma power3_eq_cube: "(x::'a::recpower) ^ 3 = x * x * x"
37.329 - apply (subgoal_tac "3 = Suc (Suc (Suc 0))")
37.330 - apply (erule ssubst)
37.331 - apply (simp add: power_Suc mult_ac)
37.332 - apply (unfold nat_number_of_def)
37.333 - apply (subst nat_eq_iff)
37.334 - apply simp
37.335 -done
37.336 -
37.337 -text{*Squares of literal numerals will be evaluated.*}
37.338 -lemmas power2_eq_square_number_of =
37.339 - power2_eq_square [of "number_of w", standard]
37.340 -declare power2_eq_square_number_of [simp]
37.341 -
37.342 -
37.343 -lemma zero_le_power2[simp]: "0 \<le> (a\<twosuperior>::'a::{ordered_idom,recpower})"
37.344 - by (simp add: power2_eq_square)
37.345 -
37.346 -lemma zero_less_power2[simp]:
37.347 - "(0 < a\<twosuperior>) = (a \<noteq> (0::'a::{ordered_idom,recpower}))"
37.348 - by (force simp add: power2_eq_square zero_less_mult_iff linorder_neq_iff)
37.349 -
37.350 -lemma power2_less_0[simp]:
37.351 - fixes a :: "'a::{ordered_idom,recpower}"
37.352 - shows "~ (a\<twosuperior> < 0)"
37.353 -by (force simp add: power2_eq_square mult_less_0_iff)
37.354 -
37.355 -lemma zero_eq_power2[simp]:
37.356 - "(a\<twosuperior> = 0) = (a = (0::'a::{ordered_idom,recpower}))"
37.357 - by (force simp add: power2_eq_square mult_eq_0_iff)
37.358 -
37.359 -lemma abs_power2[simp]:
37.360 - "abs(a\<twosuperior>) = (a\<twosuperior>::'a::{ordered_idom,recpower})"
37.361 - by (simp add: power2_eq_square abs_mult abs_mult_self)
37.362 -
37.363 -lemma power2_abs[simp]:
37.364 - "(abs a)\<twosuperior> = (a\<twosuperior>::'a::{ordered_idom,recpower})"
37.365 - by (simp add: power2_eq_square abs_mult_self)
37.366 -
37.367 -lemma power2_minus[simp]:
37.368 - "(- a)\<twosuperior> = (a\<twosuperior>::'a::{comm_ring_1,recpower})"
37.369 - by (simp add: power2_eq_square)
37.370 -
37.371 -lemma power2_le_imp_le:
37.372 - fixes x y :: "'a::{ordered_semidom,recpower}"
37.373 - shows "\<lbrakk>x\<twosuperior> \<le> y\<twosuperior>; 0 \<le> y\<rbrakk> \<Longrightarrow> x \<le> y"
37.374 -unfolding numeral_2_eq_2 by (rule power_le_imp_le_base)
37.375 -
37.376 -lemma power2_less_imp_less:
37.377 - fixes x y :: "'a::{ordered_semidom,recpower}"
37.378 - shows "\<lbrakk>x\<twosuperior> < y\<twosuperior>; 0 \<le> y\<rbrakk> \<Longrightarrow> x < y"
37.379 -by (rule power_less_imp_less_base)
37.380 -
37.381 -lemma power2_eq_imp_eq:
37.382 - fixes x y :: "'a::{ordered_semidom,recpower}"
37.383 - shows "\<lbrakk>x\<twosuperior> = y\<twosuperior>; 0 \<le> x; 0 \<le> y\<rbrakk> \<Longrightarrow> x = y"
37.384 -unfolding numeral_2_eq_2 by (erule (2) power_eq_imp_eq_base, simp)
37.385 -
37.386 -lemma power_minus1_even[simp]: "(- 1) ^ (2*n) = (1::'a::{comm_ring_1,recpower})"
37.387 -proof (induct n)
37.388 - case 0 show ?case by simp
37.389 -next
37.390 - case (Suc n) then show ?case by (simp add: power_Suc power_add)
37.391 -qed
37.392 -
37.393 -lemma power_minus1_odd: "(- 1) ^ Suc(2*n) = -(1::'a::{comm_ring_1,recpower})"
37.394 - by (simp add: power_Suc)
37.395 -
37.396 -lemma power_even_eq: "(a::'a::recpower) ^ (2*n) = (a^n)^2"
37.397 -by (subst mult_commute) (simp add: power_mult)
37.398 -
37.399 -lemma power_odd_eq: "(a::int) ^ Suc(2*n) = a * (a^n)^2"
37.400 -by (simp add: power_even_eq)
37.401 -
37.402 -lemma power_minus_even [simp]:
37.403 - "(-a) ^ (2*n) = (a::'a::{comm_ring_1,recpower}) ^ (2*n)"
37.404 -by (simp add: power_minus1_even power_minus [of a])
37.405 -
37.406 -lemma zero_le_even_power'[simp]:
37.407 - "0 \<le> (a::'a::{ordered_idom,recpower}) ^ (2*n)"
37.408 -proof (induct "n")
37.409 - case 0
37.410 - show ?case by (simp add: zero_le_one)
37.411 -next
37.412 - case (Suc n)
37.413 - have "a ^ (2 * Suc n) = (a*a) * a ^ (2*n)"
37.414 - by (simp add: mult_ac power_add power2_eq_square)
37.415 - thus ?case
37.416 - by (simp add: prems zero_le_mult_iff)
37.417 -qed
37.418 -
37.419 -lemma odd_power_less_zero:
37.420 - "(a::'a::{ordered_idom,recpower}) < 0 ==> a ^ Suc(2*n) < 0"
37.421 -proof (induct "n")
37.422 - case 0
37.423 - then show ?case by simp
37.424 -next
37.425 - case (Suc n)
37.426 - have "a ^ Suc (2 * Suc n) = (a*a) * a ^ Suc(2*n)"
37.427 - by (simp add: mult_ac power_add power2_eq_square)
37.428 - thus ?case
37.429 - by (simp del: power_Suc add: prems mult_less_0_iff mult_neg_neg)
37.430 -qed
37.431 -
37.432 -lemma odd_0_le_power_imp_0_le:
37.433 - "0 \<le> a ^ Suc(2*n) ==> 0 \<le> (a::'a::{ordered_idom,recpower})"
37.434 -apply (insert odd_power_less_zero [of a n])
37.435 -apply (force simp add: linorder_not_less [symmetric])
37.436 -done
37.437 -
37.438 -text{*Simprules for comparisons where common factors can be cancelled.*}
37.439 -lemmas zero_compare_simps =
37.440 - add_strict_increasing add_strict_increasing2 add_increasing
37.441 - zero_le_mult_iff zero_le_divide_iff
37.442 - zero_less_mult_iff zero_less_divide_iff
37.443 - mult_le_0_iff divide_le_0_iff
37.444 - mult_less_0_iff divide_less_0_iff
37.445 - zero_le_power2 power2_less_0
37.446 -
37.447 -subsubsection{*Nat *}
37.448 -
37.449 -lemma Suc_pred': "0 < n ==> n = Suc(n - 1)"
37.450 -by (simp add: numerals)
37.451 -
37.452 -(*Expresses a natural number constant as the Suc of another one.
37.453 - NOT suitable for rewriting because n recurs in the condition.*)
37.454 -lemmas expand_Suc = Suc_pred' [of "number_of v", standard]
37.455 -
37.456 -subsubsection{*Arith *}
37.457 -
37.458 -lemma Suc_eq_add_numeral_1: "Suc n = n + 1"
37.459 -by (simp add: numerals)
37.460 -
37.461 -lemma Suc_eq_add_numeral_1_left: "Suc n = 1 + n"
37.462 -by (simp add: numerals)
37.463 -
37.464 -(* These two can be useful when m = number_of... *)
37.465 -
37.466 -lemma add_eq_if: "(m::nat) + n = (if m=0 then n else Suc ((m - 1) + n))"
37.467 - unfolding One_nat_def by (cases m) simp_all
37.468 -
37.469 -lemma mult_eq_if: "(m::nat) * n = (if m=0 then 0 else n + ((m - 1) * n))"
37.470 - unfolding One_nat_def by (cases m) simp_all
37.471 -
37.472 -lemma power_eq_if: "(p ^ m :: nat) = (if m=0 then 1 else p * (p ^ (m - 1)))"
37.473 - unfolding One_nat_def by (cases m) simp_all
37.474 -
37.475 -
37.476 -subsection{*Comparisons involving (0::nat) *}
37.477 -
37.478 -text{*Simplification already does @{term "n<0"}, @{term "n\<le>0"} and @{term "0\<le>n"}.*}
37.479 -
37.480 -lemma eq_number_of_0 [simp]:
37.481 - "number_of v = (0::nat) \<longleftrightarrow> v \<le> Int.Pls"
37.482 - unfolding nat_number_of_def number_of_is_id numeral_simps
37.483 - by auto
37.484 -
37.485 -lemma eq_0_number_of [simp]:
37.486 - "(0::nat) = number_of v \<longleftrightarrow> v \<le> Int.Pls"
37.487 -by (rule trans [OF eq_sym_conv eq_number_of_0])
37.488 -
37.489 -lemma less_0_number_of [simp]:
37.490 - "(0::nat) < number_of v \<longleftrightarrow> Int.Pls < v"
37.491 - unfolding nat_number_of_def number_of_is_id numeral_simps
37.492 - by simp
37.493 -
37.494 -lemma neg_imp_number_of_eq_0: "neg (number_of v :: int) ==> number_of v = (0::nat)"
37.495 -by (simp del: nat_numeral_0_eq_0 add: nat_numeral_0_eq_0 [symmetric])
37.496 -
37.497 -
37.498 -
37.499 -subsection{*Comparisons involving @{term Suc} *}
37.500 -
37.501 -lemma eq_number_of_Suc [simp]:
37.502 - "(number_of v = Suc n) =
37.503 - (let pv = number_of (Int.pred v) in
37.504 - if neg pv then False else nat pv = n)"
37.505 -apply (simp only: simp_thms Let_def neg_eq_less_0 linorder_not_less
37.506 - number_of_pred nat_number_of_def
37.507 - split add: split_if)
37.508 -apply (rule_tac x = "number_of v" in spec)
37.509 -apply (auto simp add: nat_eq_iff)
37.510 -done
37.511 -
37.512 -lemma Suc_eq_number_of [simp]:
37.513 - "(Suc n = number_of v) =
37.514 - (let pv = number_of (Int.pred v) in
37.515 - if neg pv then False else nat pv = n)"
37.516 -by (rule trans [OF eq_sym_conv eq_number_of_Suc])
37.517 -
37.518 -lemma less_number_of_Suc [simp]:
37.519 - "(number_of v < Suc n) =
37.520 - (let pv = number_of (Int.pred v) in
37.521 - if neg pv then True else nat pv < n)"
37.522 -apply (simp only: simp_thms Let_def neg_eq_less_0 linorder_not_less
37.523 - number_of_pred nat_number_of_def
37.524 - split add: split_if)
37.525 -apply (rule_tac x = "number_of v" in spec)
37.526 -apply (auto simp add: nat_less_iff)
37.527 -done
37.528 -
37.529 -lemma less_Suc_number_of [simp]:
37.530 - "(Suc n < number_of v) =
37.531 - (let pv = number_of (Int.pred v) in
37.532 - if neg pv then False else n < nat pv)"
37.533 -apply (simp only: simp_thms Let_def neg_eq_less_0 linorder_not_less
37.534 - number_of_pred nat_number_of_def
37.535 - split add: split_if)
37.536 -apply (rule_tac x = "number_of v" in spec)
37.537 -apply (auto simp add: zless_nat_eq_int_zless)
37.538 -done
37.539 -
37.540 -lemma le_number_of_Suc [simp]:
37.541 - "(number_of v <= Suc n) =
37.542 - (let pv = number_of (Int.pred v) in
37.543 - if neg pv then True else nat pv <= n)"
37.544 -by (simp add: Let_def less_Suc_number_of linorder_not_less [symmetric])
37.545 -
37.546 -lemma le_Suc_number_of [simp]:
37.547 - "(Suc n <= number_of v) =
37.548 - (let pv = number_of (Int.pred v) in
37.549 - if neg pv then False else n <= nat pv)"
37.550 -by (simp add: Let_def less_number_of_Suc linorder_not_less [symmetric])
37.551 -
37.552 -
37.553 -lemma eq_number_of_Pls_Min: "(Numeral0 ::int) ~= number_of Int.Min"
37.554 -by auto
37.555 -
37.556 -
37.557 -
37.558 -subsection{*Max and Min Combined with @{term Suc} *}
37.559 -
37.560 -lemma max_number_of_Suc [simp]:
37.561 - "max (Suc n) (number_of v) =
37.562 - (let pv = number_of (Int.pred v) in
37.563 - if neg pv then Suc n else Suc(max n (nat pv)))"
37.564 -apply (simp only: Let_def neg_eq_less_0 number_of_pred nat_number_of_def
37.565 - split add: split_if nat.split)
37.566 -apply (rule_tac x = "number_of v" in spec)
37.567 -apply auto
37.568 -done
37.569 -
37.570 -lemma max_Suc_number_of [simp]:
37.571 - "max (number_of v) (Suc n) =
37.572 - (let pv = number_of (Int.pred v) in
37.573 - if neg pv then Suc n else Suc(max (nat pv) n))"
37.574 -apply (simp only: Let_def neg_eq_less_0 number_of_pred nat_number_of_def
37.575 - split add: split_if nat.split)
37.576 -apply (rule_tac x = "number_of v" in spec)
37.577 -apply auto
37.578 -done
37.579 -
37.580 -lemma min_number_of_Suc [simp]:
37.581 - "min (Suc n) (number_of v) =
37.582 - (let pv = number_of (Int.pred v) in
37.583 - if neg pv then 0 else Suc(min n (nat pv)))"
37.584 -apply (simp only: Let_def neg_eq_less_0 number_of_pred nat_number_of_def
37.585 - split add: split_if nat.split)
37.586 -apply (rule_tac x = "number_of v" in spec)
37.587 -apply auto
37.588 -done
37.589 -
37.590 -lemma min_Suc_number_of [simp]:
37.591 - "min (number_of v) (Suc n) =
37.592 - (let pv = number_of (Int.pred v) in
37.593 - if neg pv then 0 else Suc(min (nat pv) n))"
37.594 -apply (simp only: Let_def neg_eq_less_0 number_of_pred nat_number_of_def
37.595 - split add: split_if nat.split)
37.596 -apply (rule_tac x = "number_of v" in spec)
37.597 -apply auto
37.598 -done
37.599 -
37.600 -subsection{*Literal arithmetic involving powers*}
37.601 -
37.602 -lemma nat_power_eq: "(0::int) <= z ==> nat (z^n) = nat z ^ n"
37.603 -apply (induct "n")
37.604 -apply (simp_all (no_asm_simp) add: nat_mult_distrib)
37.605 -done
37.606 -
37.607 -lemma power_nat_number_of:
37.608 - "(number_of v :: nat) ^ n =
37.609 - (if neg (number_of v :: int) then 0^n else nat ((number_of v :: int) ^ n))"
37.610 -by (simp only: simp_thms neg_nat not_neg_eq_ge_0 nat_number_of_def nat_power_eq
37.611 - split add: split_if cong: imp_cong)
37.612 -
37.613 -
37.614 -lemmas power_nat_number_of_number_of = power_nat_number_of [of _ "number_of w", standard]
37.615 -declare power_nat_number_of_number_of [simp]
37.616 -
37.617 -
37.618 -
37.619 -text{*For arbitrary rings*}
37.620 -
37.621 -lemma power_number_of_even:
37.622 - fixes z :: "'a::{number_ring,recpower}"
37.623 - shows "z ^ number_of (Int.Bit0 w) = (let w = z ^ (number_of w) in w * w)"
37.624 -unfolding Let_def nat_number_of_def number_of_Bit0
37.625 -apply (rule_tac x = "number_of w" in spec, clarify)
37.626 -apply (case_tac " (0::int) <= x")
37.627 -apply (auto simp add: nat_mult_distrib power_even_eq power2_eq_square)
37.628 -done
37.629 -
37.630 -lemma power_number_of_odd:
37.631 - fixes z :: "'a::{number_ring,recpower}"
37.632 - shows "z ^ number_of (Int.Bit1 w) = (if (0::int) <= number_of w
37.633 - then (let w = z ^ (number_of w) in z * w * w) else 1)"
37.634 -unfolding Let_def nat_number_of_def number_of_Bit1
37.635 -apply (rule_tac x = "number_of w" in spec, auto)
37.636 -apply (simp only: nat_add_distrib nat_mult_distrib)
37.637 -apply simp
37.638 -apply (auto simp add: nat_add_distrib nat_mult_distrib power_even_eq power2_eq_square neg_nat power_Suc)
37.639 -done
37.640 -
37.641 -lemmas zpower_number_of_even = power_number_of_even [where 'a=int]
37.642 -lemmas zpower_number_of_odd = power_number_of_odd [where 'a=int]
37.643 -
37.644 -lemmas power_number_of_even_number_of [simp] =
37.645 - power_number_of_even [of "number_of v", standard]
37.646 -
37.647 -lemmas power_number_of_odd_number_of [simp] =
37.648 - power_number_of_odd [of "number_of v", standard]
37.649 -
37.650 -
37.651 -
37.652 -ML
37.653 -{*
37.654 -val numeral_ss = @{simpset} addsimps @{thms numerals};
37.655 -
37.656 -val nat_bin_arith_setup =
37.657 - Lin_Arith.map_data
37.658 - (fn {add_mono_thms, mult_mono_thms, inj_thms, lessD, neqE, simpset} =>
37.659 - {add_mono_thms = add_mono_thms, mult_mono_thms = mult_mono_thms,
37.660 - inj_thms = inj_thms,
37.661 - lessD = lessD, neqE = neqE,
37.662 - simpset = simpset addsimps @{thms neg_simps} @
37.663 - [@{thm Suc_nat_number_of}, @{thm int_nat_number_of}]})
37.664 -*}
37.665 -
37.666 -declaration {* K nat_bin_arith_setup *}
37.667 -
37.668 -(* Enable arith to deal with div/mod k where k is a numeral: *)
37.669 -declare split_div[of _ _ "number_of k", standard, arith_split]
37.670 -declare split_mod[of _ _ "number_of k", standard, arith_split]
37.671 -
37.672 -lemma nat_number_of_Pls: "Numeral0 = (0::nat)"
37.673 - by (simp add: number_of_Pls nat_number_of_def)
37.674 -
37.675 -lemma nat_number_of_Min: "number_of Int.Min = (0::nat)"
37.676 - apply (simp only: number_of_Min nat_number_of_def nat_zminus_int)
37.677 - done
37.678 -
37.679 -lemma nat_number_of_Bit0:
37.680 - "number_of (Int.Bit0 w) = (let n::nat = number_of w in n + n)"
37.681 - unfolding nat_number_of_def number_of_is_id numeral_simps Let_def
37.682 - by auto
37.683 -
37.684 -lemma nat_number_of_Bit1:
37.685 - "number_of (Int.Bit1 w) =
37.686 - (if neg (number_of w :: int) then 0
37.687 - else let n = number_of w in Suc (n + n))"
37.688 - unfolding nat_number_of_def number_of_is_id numeral_simps neg_def Let_def
37.689 - by auto
37.690 -
37.691 -lemmas nat_number =
37.692 - nat_number_of_Pls nat_number_of_Min
37.693 - nat_number_of_Bit0 nat_number_of_Bit1
37.694 -
37.695 -lemma Let_Suc [simp]: "Let (Suc n) f == f (Suc n)"
37.696 - by (simp add: Let_def)
37.697 -
37.698 -lemma power_m1_even: "(-1) ^ (2*n) = (1::'a::{number_ring,recpower})"
37.699 -by (simp add: power_mult power_Suc);
37.700 -
37.701 -lemma power_m1_odd: "(-1) ^ Suc(2*n) = (-1::'a::{number_ring,recpower})"
37.702 -by (simp add: power_mult power_Suc);
37.703 -
37.704 -
37.705 -subsection{*Literal arithmetic and @{term of_nat}*}
37.706 -
37.707 -lemma of_nat_double:
37.708 - "0 \<le> x ==> of_nat (nat (2 * x)) = of_nat (nat x) + of_nat (nat x)"
37.709 -by (simp only: mult_2 nat_add_distrib of_nat_add)
37.710 -
37.711 -lemma nat_numeral_m1_eq_0: "-1 = (0::nat)"
37.712 -by (simp only: nat_number_of_def)
37.713 -
37.714 -lemma of_nat_number_of_lemma:
37.715 - "of_nat (number_of v :: nat) =
37.716 - (if 0 \<le> (number_of v :: int)
37.717 - then (number_of v :: 'a :: number_ring)
37.718 - else 0)"
37.719 -by (simp add: int_number_of_def nat_number_of_def number_of_eq of_nat_nat);
37.720 -
37.721 -lemma of_nat_number_of_eq [simp]:
37.722 - "of_nat (number_of v :: nat) =
37.723 - (if neg (number_of v :: int) then 0
37.724 - else (number_of v :: 'a :: number_ring))"
37.725 -by (simp only: of_nat_number_of_lemma neg_def, simp)
37.726 -
37.727 -
37.728 -subsection {*Lemmas for the Combination and Cancellation Simprocs*}
37.729 -
37.730 -lemma nat_number_of_add_left:
37.731 - "number_of v + (number_of v' + (k::nat)) =
37.732 - (if neg (number_of v :: int) then number_of v' + k
37.733 - else if neg (number_of v' :: int) then number_of v + k
37.734 - else number_of (v + v') + k)"
37.735 - unfolding nat_number_of_def number_of_is_id neg_def
37.736 - by auto
37.737 -
37.738 -lemma nat_number_of_mult_left:
37.739 - "number_of v * (number_of v' * (k::nat)) =
37.740 - (if v < Int.Pls then 0
37.741 - else number_of (v * v') * k)"
37.742 -by simp
37.743 -
37.744 -
37.745 -subsubsection{*For @{text combine_numerals}*}
37.746 -
37.747 -lemma left_add_mult_distrib: "i*u + (j*u + k) = (i+j)*u + (k::nat)"
37.748 -by (simp add: add_mult_distrib)
37.749 -
37.750 -
37.751 -subsubsection{*For @{text cancel_numerals}*}
37.752 -
37.753 -lemma nat_diff_add_eq1:
37.754 - "j <= (i::nat) ==> ((i*u + m) - (j*u + n)) = (((i-j)*u + m) - n)"
37.755 -by (simp split add: nat_diff_split add: add_mult_distrib)
37.756 -
37.757 -lemma nat_diff_add_eq2:
37.758 - "i <= (j::nat) ==> ((i*u + m) - (j*u + n)) = (m - ((j-i)*u + n))"
37.759 -by (simp split add: nat_diff_split add: add_mult_distrib)
37.760 -
37.761 -lemma nat_eq_add_iff1:
37.762 - "j <= (i::nat) ==> (i*u + m = j*u + n) = ((i-j)*u + m = n)"
37.763 -by (auto split add: nat_diff_split simp add: add_mult_distrib)
37.764 -
37.765 -lemma nat_eq_add_iff2:
37.766 - "i <= (j::nat) ==> (i*u + m = j*u + n) = (m = (j-i)*u + n)"
37.767 -by (auto split add: nat_diff_split simp add: add_mult_distrib)
37.768 -
37.769 -lemma nat_less_add_iff1:
37.770 - "j <= (i::nat) ==> (i*u + m < j*u + n) = ((i-j)*u + m < n)"
37.771 -by (auto split add: nat_diff_split simp add: add_mult_distrib)
37.772 -
37.773 -lemma nat_less_add_iff2:
37.774 - "i <= (j::nat) ==> (i*u + m < j*u + n) = (m < (j-i)*u + n)"
37.775 -by (auto split add: nat_diff_split simp add: add_mult_distrib)
37.776 -
37.777 -lemma nat_le_add_iff1:
37.778 - "j <= (i::nat) ==> (i*u + m <= j*u + n) = ((i-j)*u + m <= n)"
37.779 -by (auto split add: nat_diff_split simp add: add_mult_distrib)
37.780 -
37.781 -lemma nat_le_add_iff2:
37.782 - "i <= (j::nat) ==> (i*u + m <= j*u + n) = (m <= (j-i)*u + n)"
37.783 -by (auto split add: nat_diff_split simp add: add_mult_distrib)
37.784 -
37.785 -
37.786 -subsubsection{*For @{text cancel_numeral_factors} *}
37.787 -
37.788 -lemma nat_mult_le_cancel1: "(0::nat) < k ==> (k*m <= k*n) = (m<=n)"
37.789 -by auto
37.790 -
37.791 -lemma nat_mult_less_cancel1: "(0::nat) < k ==> (k*m < k*n) = (m<n)"
37.792 -by auto
37.793 -
37.794 -lemma nat_mult_eq_cancel1: "(0::nat) < k ==> (k*m = k*n) = (m=n)"
37.795 -by auto
37.796 -
37.797 -lemma nat_mult_div_cancel1: "(0::nat) < k ==> (k*m) div (k*n) = (m div n)"
37.798 -by auto
37.799 -
37.800 -lemma nat_mult_dvd_cancel_disj[simp]:
37.801 - "(k*m) dvd (k*n) = (k=0 | m dvd (n::nat))"
37.802 -by(auto simp: dvd_eq_mod_eq_0 mod_mult_distrib2[symmetric])
37.803 -
37.804 -lemma nat_mult_dvd_cancel1: "0 < k \<Longrightarrow> (k*m) dvd (k*n::nat) = (m dvd n)"
37.805 -by(auto)
37.806 -
37.807 -
37.808 -subsubsection{*For @{text cancel_factor} *}
37.809 -
37.810 -lemma nat_mult_le_cancel_disj: "(k*m <= k*n) = ((0::nat) < k --> m<=n)"
37.811 -by auto
37.812 -
37.813 -lemma nat_mult_less_cancel_disj: "(k*m < k*n) = ((0::nat) < k & m<n)"
37.814 -by auto
37.815 -
37.816 -lemma nat_mult_eq_cancel_disj: "(k*m = k*n) = (k = (0::nat) | m=n)"
37.817 -by auto
37.818 -
37.819 -lemma nat_mult_div_cancel_disj[simp]:
37.820 - "(k*m) div (k*n) = (if k = (0::nat) then 0 else m div n)"
37.821 -by (simp add: nat_mult_div_cancel1)
37.822 -
37.823 -
37.824 -subsection {* Simprocs for the Naturals *}
37.825 -
37.826 -use "Tools/nat_simprocs.ML"
37.827 -declaration {* K nat_simprocs_setup *}
37.828 -
37.829 -subsubsection{*For simplifying @{term "Suc m - K"} and @{term "K - Suc m"}*}
37.830 -
37.831 -text{*Where K above is a literal*}
37.832 -
37.833 -lemma Suc_diff_eq_diff_pred: "Numeral0 < n ==> Suc m - n = m - (n - Numeral1)"
37.834 -by (simp add: numeral_0_eq_0 numeral_1_eq_1 split add: nat_diff_split)
37.835 -
37.836 -text {*Now just instantiating @{text n} to @{text "number_of v"} does
37.837 - the right simplification, but with some redundant inequality
37.838 - tests.*}
37.839 -lemma neg_number_of_pred_iff_0:
37.840 - "neg (number_of (Int.pred v)::int) = (number_of v = (0::nat))"
37.841 -apply (subgoal_tac "neg (number_of (Int.pred v)) = (number_of v < Suc 0) ")
37.842 -apply (simp only: less_Suc_eq_le le_0_eq)
37.843 -apply (subst less_number_of_Suc, simp)
37.844 -done
37.845 -
37.846 -text{*No longer required as a simprule because of the @{text inverse_fold}
37.847 - simproc*}
37.848 -lemma Suc_diff_number_of:
37.849 - "Int.Pls < v ==>
37.850 - Suc m - (number_of v) = m - (number_of (Int.pred v))"
37.851 -apply (subst Suc_diff_eq_diff_pred)
37.852 -apply simp
37.853 -apply (simp del: nat_numeral_1_eq_1)
37.854 -apply (auto simp only: diff_nat_number_of less_0_number_of [symmetric]
37.855 - neg_number_of_pred_iff_0)
37.856 -done
37.857 -
37.858 -lemma diff_Suc_eq_diff_pred: "m - Suc n = (m - 1) - n"
37.859 -by (simp add: numerals split add: nat_diff_split)
37.860 -
37.861 -
37.862 -subsubsection{*For @{term nat_case} and @{term nat_rec}*}
37.863 -
37.864 -lemma nat_case_number_of [simp]:
37.865 - "nat_case a f (number_of v) =
37.866 - (let pv = number_of (Int.pred v) in
37.867 - if neg pv then a else f (nat pv))"
37.868 -by (simp split add: nat.split add: Let_def neg_number_of_pred_iff_0)
37.869 -
37.870 -lemma nat_case_add_eq_if [simp]:
37.871 - "nat_case a f ((number_of v) + n) =
37.872 - (let pv = number_of (Int.pred v) in
37.873 - if neg pv then nat_case a f n else f (nat pv + n))"
37.874 -apply (subst add_eq_if)
37.875 -apply (simp split add: nat.split
37.876 - del: nat_numeral_1_eq_1
37.877 - add: nat_numeral_1_eq_1 [symmetric]
37.878 - numeral_1_eq_Suc_0 [symmetric]
37.879 - neg_number_of_pred_iff_0)
37.880 -done
37.881 -
37.882 -lemma nat_rec_number_of [simp]:
37.883 - "nat_rec a f (number_of v) =
37.884 - (let pv = number_of (Int.pred v) in
37.885 - if neg pv then a else f (nat pv) (nat_rec a f (nat pv)))"
37.886 -apply (case_tac " (number_of v) ::nat")
37.887 -apply (simp_all (no_asm_simp) add: Let_def neg_number_of_pred_iff_0)
37.888 -apply (simp split add: split_if_asm)
37.889 -done
37.890 -
37.891 -lemma nat_rec_add_eq_if [simp]:
37.892 - "nat_rec a f (number_of v + n) =
37.893 - (let pv = number_of (Int.pred v) in
37.894 - if neg pv then nat_rec a f n
37.895 - else f (nat pv + n) (nat_rec a f (nat pv + n)))"
37.896 -apply (subst add_eq_if)
37.897 -apply (simp split add: nat.split
37.898 - del: nat_numeral_1_eq_1
37.899 - add: nat_numeral_1_eq_1 [symmetric]
37.900 - numeral_1_eq_Suc_0 [symmetric]
37.901 - neg_number_of_pred_iff_0)
37.902 -done
37.903 -
37.904 -
37.905 -subsubsection{*Various Other Lemmas*}
37.906 -
37.907 -text {*Evens and Odds, for Mutilated Chess Board*}
37.908 -
37.909 -text{*Lemmas for specialist use, NOT as default simprules*}
37.910 -lemma nat_mult_2: "2 * z = (z+z::nat)"
37.911 -proof -
37.912 - have "2*z = (1 + 1)*z" by simp
37.913 - also have "... = z+z" by (simp add: left_distrib)
37.914 - finally show ?thesis .
37.915 -qed
37.916 -
37.917 -lemma nat_mult_2_right: "z * 2 = (z+z::nat)"
37.918 -by (subst mult_commute, rule nat_mult_2)
37.919 -
37.920 -text{*Case analysis on @{term "n<2"}*}
37.921 -lemma less_2_cases: "(n::nat) < 2 ==> n = 0 | n = Suc 0"
37.922 -by arith
37.923 -
37.924 -lemma div2_Suc_Suc [simp]: "Suc(Suc m) div 2 = Suc (m div 2)"
37.925 -by arith
37.926 -
37.927 -lemma add_self_div_2 [simp]: "(m + m) div 2 = (m::nat)"
37.928 -by (simp add: nat_mult_2 [symmetric])
37.929 -
37.930 -lemma mod2_Suc_Suc [simp]: "Suc(Suc(m)) mod 2 = m mod 2"
37.931 -apply (subgoal_tac "m mod 2 < 2")
37.932 -apply (erule less_2_cases [THEN disjE])
37.933 -apply (simp_all (no_asm_simp) add: Let_def mod_Suc nat_1)
37.934 -done
37.935 -
37.936 -lemma mod2_gr_0 [simp]: "!!m::nat. (0 < m mod 2) = (m mod 2 = 1)"
37.937 -apply (subgoal_tac "m mod 2 < 2")
37.938 -apply (force simp del: mod_less_divisor, simp)
37.939 -done
37.940 -
37.941 -text{*Removal of Small Numerals: 0, 1 and (in additive positions) 2*}
37.942 -
37.943 -lemma add_2_eq_Suc [simp]: "2 + n = Suc (Suc n)"
37.944 -by simp
37.945 -
37.946 -lemma add_2_eq_Suc' [simp]: "n + 2 = Suc (Suc n)"
37.947 -by simp
37.948 -
37.949 -text{*Can be used to eliminate long strings of Sucs, but not by default*}
37.950 -lemma Suc3_eq_add_3: "Suc (Suc (Suc n)) = 3 + n"
37.951 -by simp
37.952 -
37.953 -
37.954 -text{*These lemmas collapse some needless occurrences of Suc:
37.955 - at least three Sucs, since two and fewer are rewritten back to Suc again!
37.956 - We already have some rules to simplify operands smaller than 3.*}
37.957 -
37.958 -lemma div_Suc_eq_div_add3 [simp]: "m div (Suc (Suc (Suc n))) = m div (3+n)"
37.959 -by (simp add: Suc3_eq_add_3)
37.960 -
37.961 -lemma mod_Suc_eq_mod_add3 [simp]: "m mod (Suc (Suc (Suc n))) = m mod (3+n)"
37.962 -by (simp add: Suc3_eq_add_3)
37.963 -
37.964 -lemma Suc_div_eq_add3_div: "(Suc (Suc (Suc m))) div n = (3+m) div n"
37.965 -by (simp add: Suc3_eq_add_3)
37.966 -
37.967 -lemma Suc_mod_eq_add3_mod: "(Suc (Suc (Suc m))) mod n = (3+m) mod n"
37.968 -by (simp add: Suc3_eq_add_3)
37.969 -
37.970 -lemmas Suc_div_eq_add3_div_number_of =
37.971 - Suc_div_eq_add3_div [of _ "number_of v", standard]
37.972 -declare Suc_div_eq_add3_div_number_of [simp]
37.973 -
37.974 -lemmas Suc_mod_eq_add3_mod_number_of =
37.975 - Suc_mod_eq_add3_mod [of _ "number_of v", standard]
37.976 -declare Suc_mod_eq_add3_mod_number_of [simp]
37.977 -
37.978 -end
38.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
38.2 +++ b/src/HOL/Nat_Numeral.thy Mon Apr 20 16:28:13 2009 +0200
38.3 @@ -0,0 +1,975 @@
38.4 +(* Title: HOL/Nat_Numeral.thy
38.5 + Author: Lawrence C Paulson, Cambridge University Computer Laboratory
38.6 + Copyright 1999 University of Cambridge
38.7 +*)
38.8 +
38.9 +header {* Binary numerals for the natural numbers *}
38.10 +
38.11 +theory Nat_Numeral
38.12 +imports IntDiv
38.13 +uses ("Tools/nat_simprocs.ML")
38.14 +begin
38.15 +
38.16 +text {*
38.17 + Arithmetic for naturals is reduced to that for the non-negative integers.
38.18 +*}
38.19 +
38.20 +instantiation nat :: number
38.21 +begin
38.22 +
38.23 +definition
38.24 + nat_number_of_def [code inline, code del]: "number_of v = nat (number_of v)"
38.25 +
38.26 +instance ..
38.27 +
38.28 +end
38.29 +
38.30 +lemma [code post]:
38.31 + "nat (number_of v) = number_of v"
38.32 + unfolding nat_number_of_def ..
38.33 +
38.34 +abbreviation (xsymbols)
38.35 + power2 :: "'a::power => 'a" ("(_\<twosuperior>)" [1000] 999) where
38.36 + "x\<twosuperior> == x^2"
38.37 +
38.38 +notation (latex output)
38.39 + power2 ("(_\<twosuperior>)" [1000] 999)
38.40 +
38.41 +notation (HTML output)
38.42 + power2 ("(_\<twosuperior>)" [1000] 999)
38.43 +
38.44 +
38.45 +subsection {* Predicate for negative binary numbers *}
38.46 +
38.47 +definition neg :: "int \<Rightarrow> bool" where
38.48 + "neg Z \<longleftrightarrow> Z < 0"
38.49 +
38.50 +lemma not_neg_int [simp]: "~ neg (of_nat n)"
38.51 +by (simp add: neg_def)
38.52 +
38.53 +lemma neg_zminus_int [simp]: "neg (- (of_nat (Suc n)))"
38.54 +by (simp add: neg_def neg_less_0_iff_less del: of_nat_Suc)
38.55 +
38.56 +lemmas neg_eq_less_0 = neg_def
38.57 +
38.58 +lemma not_neg_eq_ge_0: "(~neg x) = (0 \<le> x)"
38.59 +by (simp add: neg_def linorder_not_less)
38.60 +
38.61 +text{*To simplify inequalities when Numeral1 can get simplified to 1*}
38.62 +
38.63 +lemma not_neg_0: "~ neg 0"
38.64 +by (simp add: One_int_def neg_def)
38.65 +
38.66 +lemma not_neg_1: "~ neg 1"
38.67 +by (simp add: neg_def linorder_not_less zero_le_one)
38.68 +
38.69 +lemma neg_nat: "neg z ==> nat z = 0"
38.70 +by (simp add: neg_def order_less_imp_le)
38.71 +
38.72 +lemma not_neg_nat: "~ neg z ==> of_nat (nat z) = z"
38.73 +by (simp add: linorder_not_less neg_def)
38.74 +
38.75 +text {*
38.76 + If @{term Numeral0} is rewritten to 0 then this rule can't be applied:
38.77 + @{term Numeral0} IS @{term "number_of Pls"}
38.78 +*}
38.79 +
38.80 +lemma not_neg_number_of_Pls: "~ neg (number_of Int.Pls)"
38.81 + by (simp add: neg_def)
38.82 +
38.83 +lemma neg_number_of_Min: "neg (number_of Int.Min)"
38.84 + by (simp add: neg_def)
38.85 +
38.86 +lemma neg_number_of_Bit0:
38.87 + "neg (number_of (Int.Bit0 w)) = neg (number_of w)"
38.88 + by (simp add: neg_def)
38.89 +
38.90 +lemma neg_number_of_Bit1:
38.91 + "neg (number_of (Int.Bit1 w)) = neg (number_of w)"
38.92 + by (simp add: neg_def)
38.93 +
38.94 +lemmas neg_simps [simp] =
38.95 + not_neg_0 not_neg_1
38.96 + not_neg_number_of_Pls neg_number_of_Min
38.97 + neg_number_of_Bit0 neg_number_of_Bit1
38.98 +
38.99 +
38.100 +subsection{*Function @{term nat}: Coercion from Type @{typ int} to @{typ nat}*}
38.101 +
38.102 +declare nat_0 [simp] nat_1 [simp]
38.103 +
38.104 +lemma nat_number_of [simp]: "nat (number_of w) = number_of w"
38.105 +by (simp add: nat_number_of_def)
38.106 +
38.107 +lemma nat_numeral_0_eq_0 [simp]: "Numeral0 = (0::nat)"
38.108 +by (simp add: nat_number_of_def)
38.109 +
38.110 +lemma nat_numeral_1_eq_1 [simp]: "Numeral1 = (1::nat)"
38.111 +by (simp add: nat_1 nat_number_of_def)
38.112 +
38.113 +lemma numeral_1_eq_Suc_0: "Numeral1 = Suc 0"
38.114 +by (simp add: nat_numeral_1_eq_1)
38.115 +
38.116 +lemma numeral_2_eq_2: "2 = Suc (Suc 0)"
38.117 +apply (unfold nat_number_of_def)
38.118 +apply (rule nat_2)
38.119 +done
38.120 +
38.121 +
38.122 +subsection{*Function @{term int}: Coercion from Type @{typ nat} to @{typ int}*}
38.123 +
38.124 +lemma int_nat_number_of [simp]:
38.125 + "int (number_of v) =
38.126 + (if neg (number_of v :: int) then 0
38.127 + else (number_of v :: int))"
38.128 + unfolding nat_number_of_def number_of_is_id neg_def
38.129 + by simp
38.130 +
38.131 +
38.132 +subsubsection{*Successor *}
38.133 +
38.134 +lemma Suc_nat_eq_nat_zadd1: "(0::int) <= z ==> Suc (nat z) = nat (1 + z)"
38.135 +apply (rule sym)
38.136 +apply (simp add: nat_eq_iff int_Suc)
38.137 +done
38.138 +
38.139 +lemma Suc_nat_number_of_add:
38.140 + "Suc (number_of v + n) =
38.141 + (if neg (number_of v :: int) then 1+n else number_of (Int.succ v) + n)"
38.142 + unfolding nat_number_of_def number_of_is_id neg_def numeral_simps
38.143 + by (simp add: Suc_nat_eq_nat_zadd1 add_ac)
38.144 +
38.145 +lemma Suc_nat_number_of [simp]:
38.146 + "Suc (number_of v) =
38.147 + (if neg (number_of v :: int) then 1 else number_of (Int.succ v))"
38.148 +apply (cut_tac n = 0 in Suc_nat_number_of_add)
38.149 +apply (simp cong del: if_weak_cong)
38.150 +done
38.151 +
38.152 +
38.153 +subsubsection{*Addition *}
38.154 +
38.155 +lemma add_nat_number_of [simp]:
38.156 + "(number_of v :: nat) + number_of v' =
38.157 + (if v < Int.Pls then number_of v'
38.158 + else if v' < Int.Pls then number_of v
38.159 + else number_of (v + v'))"
38.160 + unfolding nat_number_of_def number_of_is_id numeral_simps
38.161 + by (simp add: nat_add_distrib)
38.162 +
38.163 +lemma nat_number_of_add_1 [simp]:
38.164 + "number_of v + (1::nat) =
38.165 + (if v < Int.Pls then 1 else number_of (Int.succ v))"
38.166 + unfolding nat_number_of_def number_of_is_id numeral_simps
38.167 + by (simp add: nat_add_distrib)
38.168 +
38.169 +lemma nat_1_add_number_of [simp]:
38.170 + "(1::nat) + number_of v =
38.171 + (if v < Int.Pls then 1 else number_of (Int.succ v))"
38.172 + unfolding nat_number_of_def number_of_is_id numeral_simps
38.173 + by (simp add: nat_add_distrib)
38.174 +
38.175 +lemma nat_1_add_1 [simp]: "1 + 1 = (2::nat)"
38.176 + by (rule int_int_eq [THEN iffD1]) simp
38.177 +
38.178 +
38.179 +subsubsection{*Subtraction *}
38.180 +
38.181 +lemma diff_nat_eq_if:
38.182 + "nat z - nat z' =
38.183 + (if neg z' then nat z
38.184 + else let d = z-z' in
38.185 + if neg d then 0 else nat d)"
38.186 +by (simp add: Let_def nat_diff_distrib [symmetric] neg_eq_less_0 not_neg_eq_ge_0)
38.187 +
38.188 +
38.189 +lemma diff_nat_number_of [simp]:
38.190 + "(number_of v :: nat) - number_of v' =
38.191 + (if v' < Int.Pls then number_of v
38.192 + else let d = number_of (v + uminus v') in
38.193 + if neg d then 0 else nat d)"
38.194 + unfolding nat_number_of_def number_of_is_id numeral_simps neg_def
38.195 + by auto
38.196 +
38.197 +lemma nat_number_of_diff_1 [simp]:
38.198 + "number_of v - (1::nat) =
38.199 + (if v \<le> Int.Pls then 0 else number_of (Int.pred v))"
38.200 + unfolding nat_number_of_def number_of_is_id numeral_simps
38.201 + by auto
38.202 +
38.203 +
38.204 +subsubsection{*Multiplication *}
38.205 +
38.206 +lemma mult_nat_number_of [simp]:
38.207 + "(number_of v :: nat) * number_of v' =
38.208 + (if v < Int.Pls then 0 else number_of (v * v'))"
38.209 + unfolding nat_number_of_def number_of_is_id numeral_simps
38.210 + by (simp add: nat_mult_distrib)
38.211 +
38.212 +
38.213 +subsubsection{*Quotient *}
38.214 +
38.215 +lemma div_nat_number_of [simp]:
38.216 + "(number_of v :: nat) div number_of v' =
38.217 + (if neg (number_of v :: int) then 0
38.218 + else nat (number_of v div number_of v'))"
38.219 + unfolding nat_number_of_def number_of_is_id neg_def
38.220 + by (simp add: nat_div_distrib)
38.221 +
38.222 +lemma one_div_nat_number_of [simp]:
38.223 + "Suc 0 div number_of v' = nat (1 div number_of v')"
38.224 +by (simp del: nat_numeral_1_eq_1 add: numeral_1_eq_Suc_0 [symmetric])
38.225 +
38.226 +
38.227 +subsubsection{*Remainder *}
38.228 +
38.229 +lemma mod_nat_number_of [simp]:
38.230 + "(number_of v :: nat) mod number_of v' =
38.231 + (if neg (number_of v :: int) then 0
38.232 + else if neg (number_of v' :: int) then number_of v
38.233 + else nat (number_of v mod number_of v'))"
38.234 + unfolding nat_number_of_def number_of_is_id neg_def
38.235 + by (simp add: nat_mod_distrib)
38.236 +
38.237 +lemma one_mod_nat_number_of [simp]:
38.238 + "Suc 0 mod number_of v' =
38.239 + (if neg (number_of v' :: int) then Suc 0
38.240 + else nat (1 mod number_of v'))"
38.241 +by (simp del: nat_numeral_1_eq_1 add: numeral_1_eq_Suc_0 [symmetric])
38.242 +
38.243 +
38.244 +subsubsection{* Divisibility *}
38.245 +
38.246 +lemmas dvd_eq_mod_eq_0_number_of =
38.247 + dvd_eq_mod_eq_0 [of "number_of x" "number_of y", standard]
38.248 +
38.249 +declare dvd_eq_mod_eq_0_number_of [simp]
38.250 +
38.251 +ML
38.252 +{*
38.253 +val nat_number_of_def = thm"nat_number_of_def";
38.254 +
38.255 +val nat_number_of = thm"nat_number_of";
38.256 +val nat_numeral_0_eq_0 = thm"nat_numeral_0_eq_0";
38.257 +val nat_numeral_1_eq_1 = thm"nat_numeral_1_eq_1";
38.258 +val numeral_1_eq_Suc_0 = thm"numeral_1_eq_Suc_0";
38.259 +val numeral_2_eq_2 = thm"numeral_2_eq_2";
38.260 +val nat_div_distrib = thm"nat_div_distrib";
38.261 +val nat_mod_distrib = thm"nat_mod_distrib";
38.262 +val int_nat_number_of = thm"int_nat_number_of";
38.263 +val Suc_nat_eq_nat_zadd1 = thm"Suc_nat_eq_nat_zadd1";
38.264 +val Suc_nat_number_of_add = thm"Suc_nat_number_of_add";
38.265 +val Suc_nat_number_of = thm"Suc_nat_number_of";
38.266 +val add_nat_number_of = thm"add_nat_number_of";
38.267 +val diff_nat_eq_if = thm"diff_nat_eq_if";
38.268 +val diff_nat_number_of = thm"diff_nat_number_of";
38.269 +val mult_nat_number_of = thm"mult_nat_number_of";
38.270 +val div_nat_number_of = thm"div_nat_number_of";
38.271 +val mod_nat_number_of = thm"mod_nat_number_of";
38.272 +*}
38.273 +
38.274 +
38.275 +subsection{*Comparisons*}
38.276 +
38.277 +subsubsection{*Equals (=) *}
38.278 +
38.279 +lemma eq_nat_nat_iff:
38.280 + "[| (0::int) <= z; 0 <= z' |] ==> (nat z = nat z') = (z=z')"
38.281 +by (auto elim!: nonneg_eq_int)
38.282 +
38.283 +lemma eq_nat_number_of [simp]:
38.284 + "((number_of v :: nat) = number_of v') =
38.285 + (if neg (number_of v :: int) then (number_of v' :: int) \<le> 0
38.286 + else if neg (number_of v' :: int) then (number_of v :: int) = 0
38.287 + else v = v')"
38.288 + unfolding nat_number_of_def number_of_is_id neg_def
38.289 + by auto
38.290 +
38.291 +
38.292 +subsubsection{*Less-than (<) *}
38.293 +
38.294 +lemma less_nat_number_of [simp]:
38.295 + "(number_of v :: nat) < number_of v' \<longleftrightarrow>
38.296 + (if v < v' then Int.Pls < v' else False)"
38.297 + unfolding nat_number_of_def number_of_is_id numeral_simps
38.298 + by auto
38.299 +
38.300 +
38.301 +subsubsection{*Less-than-or-equal *}
38.302 +
38.303 +lemma le_nat_number_of [simp]:
38.304 + "(number_of v :: nat) \<le> number_of v' \<longleftrightarrow>
38.305 + (if v \<le> v' then True else v \<le> Int.Pls)"
38.306 + unfolding nat_number_of_def number_of_is_id numeral_simps
38.307 + by auto
38.308 +
38.309 +(*Maps #n to n for n = 0, 1, 2*)
38.310 +lemmas numerals = nat_numeral_0_eq_0 nat_numeral_1_eq_1 numeral_2_eq_2
38.311 +
38.312 +
38.313 +subsection{*Powers with Numeric Exponents*}
38.314 +
38.315 +text{*We cannot refer to the number @{term 2} in @{text Ring_and_Field.thy}.
38.316 +We cannot prove general results about the numeral @{term "-1"}, so we have to
38.317 +use @{term "- 1"} instead.*}
38.318 +
38.319 +lemma power2_eq_square: "(a::'a::recpower)\<twosuperior> = a * a"
38.320 + by (simp add: numeral_2_eq_2 Power.power_Suc)
38.321 +
38.322 +lemma zero_power2 [simp]: "(0::'a::{semiring_1,recpower})\<twosuperior> = 0"
38.323 + by (simp add: power2_eq_square)
38.324 +
38.325 +lemma one_power2 [simp]: "(1::'a::{semiring_1,recpower})\<twosuperior> = 1"
38.326 + by (simp add: power2_eq_square)
38.327 +
38.328 +lemma power3_eq_cube: "(x::'a::recpower) ^ 3 = x * x * x"
38.329 + apply (subgoal_tac "3 = Suc (Suc (Suc 0))")
38.330 + apply (erule ssubst)
38.331 + apply (simp add: power_Suc mult_ac)
38.332 + apply (unfold nat_number_of_def)
38.333 + apply (subst nat_eq_iff)
38.334 + apply simp
38.335 +done
38.336 +
38.337 +text{*Squares of literal numerals will be evaluated.*}
38.338 +lemmas power2_eq_square_number_of =
38.339 + power2_eq_square [of "number_of w", standard]
38.340 +declare power2_eq_square_number_of [simp]
38.341 +
38.342 +
38.343 +lemma zero_le_power2[simp]: "0 \<le> (a\<twosuperior>::'a::{ordered_idom,recpower})"
38.344 + by (simp add: power2_eq_square)
38.345 +
38.346 +lemma zero_less_power2[simp]:
38.347 + "(0 < a\<twosuperior>) = (a \<noteq> (0::'a::{ordered_idom,recpower}))"
38.348 + by (force simp add: power2_eq_square zero_less_mult_iff linorder_neq_iff)
38.349 +
38.350 +lemma power2_less_0[simp]:
38.351 + fixes a :: "'a::{ordered_idom,recpower}"
38.352 + shows "~ (a\<twosuperior> < 0)"
38.353 +by (force simp add: power2_eq_square mult_less_0_iff)
38.354 +
38.355 +lemma zero_eq_power2[simp]:
38.356 + "(a\<twosuperior> = 0) = (a = (0::'a::{ordered_idom,recpower}))"
38.357 + by (force simp add: power2_eq_square mult_eq_0_iff)
38.358 +
38.359 +lemma abs_power2[simp]:
38.360 + "abs(a\<twosuperior>) = (a\<twosuperior>::'a::{ordered_idom,recpower})"
38.361 + by (simp add: power2_eq_square abs_mult abs_mult_self)
38.362 +
38.363 +lemma power2_abs[simp]:
38.364 + "(abs a)\<twosuperior> = (a\<twosuperior>::'a::{ordered_idom,recpower})"
38.365 + by (simp add: power2_eq_square abs_mult_self)
38.366 +
38.367 +lemma power2_minus[simp]:
38.368 + "(- a)\<twosuperior> = (a\<twosuperior>::'a::{comm_ring_1,recpower})"
38.369 + by (simp add: power2_eq_square)
38.370 +
38.371 +lemma power2_le_imp_le:
38.372 + fixes x y :: "'a::{ordered_semidom,recpower}"
38.373 + shows "\<lbrakk>x\<twosuperior> \<le> y\<twosuperior>; 0 \<le> y\<rbrakk> \<Longrightarrow> x \<le> y"
38.374 +unfolding numeral_2_eq_2 by (rule power_le_imp_le_base)
38.375 +
38.376 +lemma power2_less_imp_less:
38.377 + fixes x y :: "'a::{ordered_semidom,recpower}"
38.378 + shows "\<lbrakk>x\<twosuperior> < y\<twosuperior>; 0 \<le> y\<rbrakk> \<Longrightarrow> x < y"
38.379 +by (rule power_less_imp_less_base)
38.380 +
38.381 +lemma power2_eq_imp_eq:
38.382 + fixes x y :: "'a::{ordered_semidom,recpower}"
38.383 + shows "\<lbrakk>x\<twosuperior> = y\<twosuperior>; 0 \<le> x; 0 \<le> y\<rbrakk> \<Longrightarrow> x = y"
38.384 +unfolding numeral_2_eq_2 by (erule (2) power_eq_imp_eq_base, simp)
38.385 +
38.386 +lemma power_minus1_even[simp]: "(- 1) ^ (2*n) = (1::'a::{comm_ring_1,recpower})"
38.387 +proof (induct n)
38.388 + case 0 show ?case by simp
38.389 +next
38.390 + case (Suc n) then show ?case by (simp add: power_Suc power_add)
38.391 +qed
38.392 +
38.393 +lemma power_minus1_odd: "(- 1) ^ Suc(2*n) = -(1::'a::{comm_ring_1,recpower})"
38.394 + by (simp add: power_Suc)
38.395 +
38.396 +lemma power_even_eq: "(a::'a::recpower) ^ (2*n) = (a^n)^2"
38.397 +by (subst mult_commute) (simp add: power_mult)
38.398 +
38.399 +lemma power_odd_eq: "(a::int) ^ Suc(2*n) = a * (a^n)^2"
38.400 +by (simp add: power_even_eq)
38.401 +
38.402 +lemma power_minus_even [simp]:
38.403 + "(-a) ^ (2*n) = (a::'a::{comm_ring_1,recpower}) ^ (2*n)"
38.404 +by (simp add: power_minus1_even power_minus [of a])
38.405 +
38.406 +lemma zero_le_even_power'[simp]:
38.407 + "0 \<le> (a::'a::{ordered_idom,recpower}) ^ (2*n)"
38.408 +proof (induct "n")
38.409 + case 0
38.410 + show ?case by (simp add: zero_le_one)
38.411 +next
38.412 + case (Suc n)
38.413 + have "a ^ (2 * Suc n) = (a*a) * a ^ (2*n)"
38.414 + by (simp add: mult_ac power_add power2_eq_square)
38.415 + thus ?case
38.416 + by (simp add: prems zero_le_mult_iff)
38.417 +qed
38.418 +
38.419 +lemma odd_power_less_zero:
38.420 + "(a::'a::{ordered_idom,recpower}) < 0 ==> a ^ Suc(2*n) < 0"
38.421 +proof (induct "n")
38.422 + case 0
38.423 + then show ?case by simp
38.424 +next
38.425 + case (Suc n)
38.426 + have "a ^ Suc (2 * Suc n) = (a*a) * a ^ Suc(2*n)"
38.427 + by (simp add: mult_ac power_add power2_eq_square)
38.428 + thus ?case
38.429 + by (simp del: power_Suc add: prems mult_less_0_iff mult_neg_neg)
38.430 +qed
38.431 +
38.432 +lemma odd_0_le_power_imp_0_le:
38.433 + "0 \<le> a ^ Suc(2*n) ==> 0 \<le> (a::'a::{ordered_idom,recpower})"
38.434 +apply (insert odd_power_less_zero [of a n])
38.435 +apply (force simp add: linorder_not_less [symmetric])
38.436 +done
38.437 +
38.438 +text{*Simprules for comparisons where common factors can be cancelled.*}
38.439 +lemmas zero_compare_simps =
38.440 + add_strict_increasing add_strict_increasing2 add_increasing
38.441 + zero_le_mult_iff zero_le_divide_iff
38.442 + zero_less_mult_iff zero_less_divide_iff
38.443 + mult_le_0_iff divide_le_0_iff
38.444 + mult_less_0_iff divide_less_0_iff
38.445 + zero_le_power2 power2_less_0
38.446 +
38.447 +subsubsection{*Nat *}
38.448 +
38.449 +lemma Suc_pred': "0 < n ==> n = Suc(n - 1)"
38.450 +by (simp add: numerals)
38.451 +
38.452 +(*Expresses a natural number constant as the Suc of another one.
38.453 + NOT suitable for rewriting because n recurs in the condition.*)
38.454 +lemmas expand_Suc = Suc_pred' [of "number_of v", standard]
38.455 +
38.456 +subsubsection{*Arith *}
38.457 +
38.458 +lemma Suc_eq_add_numeral_1: "Suc n = n + 1"
38.459 +by (simp add: numerals)
38.460 +
38.461 +lemma Suc_eq_add_numeral_1_left: "Suc n = 1 + n"
38.462 +by (simp add: numerals)
38.463 +
38.464 +(* These two can be useful when m = number_of... *)
38.465 +
38.466 +lemma add_eq_if: "(m::nat) + n = (if m=0 then n else Suc ((m - 1) + n))"
38.467 + unfolding One_nat_def by (cases m) simp_all
38.468 +
38.469 +lemma mult_eq_if: "(m::nat) * n = (if m=0 then 0 else n + ((m - 1) * n))"
38.470 + unfolding One_nat_def by (cases m) simp_all
38.471 +
38.472 +lemma power_eq_if: "(p ^ m :: nat) = (if m=0 then 1 else p * (p ^ (m - 1)))"
38.473 + unfolding One_nat_def by (cases m) simp_all
38.474 +
38.475 +
38.476 +subsection{*Comparisons involving (0::nat) *}
38.477 +
38.478 +text{*Simplification already does @{term "n<0"}, @{term "n\<le>0"} and @{term "0\<le>n"}.*}
38.479 +
38.480 +lemma eq_number_of_0 [simp]:
38.481 + "number_of v = (0::nat) \<longleftrightarrow> v \<le> Int.Pls"
38.482 + unfolding nat_number_of_def number_of_is_id numeral_simps
38.483 + by auto
38.484 +
38.485 +lemma eq_0_number_of [simp]:
38.486 + "(0::nat) = number_of v \<longleftrightarrow> v \<le> Int.Pls"
38.487 +by (rule trans [OF eq_sym_conv eq_number_of_0])
38.488 +
38.489 +lemma less_0_number_of [simp]:
38.490 + "(0::nat) < number_of v \<longleftrightarrow> Int.Pls < v"
38.491 + unfolding nat_number_of_def number_of_is_id numeral_simps
38.492 + by simp
38.493 +
38.494 +lemma neg_imp_number_of_eq_0: "neg (number_of v :: int) ==> number_of v = (0::nat)"
38.495 +by (simp del: nat_numeral_0_eq_0 add: nat_numeral_0_eq_0 [symmetric])
38.496 +
38.497 +
38.498 +
38.499 +subsection{*Comparisons involving @{term Suc} *}
38.500 +
38.501 +lemma eq_number_of_Suc [simp]:
38.502 + "(number_of v = Suc n) =
38.503 + (let pv = number_of (Int.pred v) in
38.504 + if neg pv then False else nat pv = n)"
38.505 +apply (simp only: simp_thms Let_def neg_eq_less_0 linorder_not_less
38.506 + number_of_pred nat_number_of_def
38.507 + split add: split_if)
38.508 +apply (rule_tac x = "number_of v" in spec)
38.509 +apply (auto simp add: nat_eq_iff)
38.510 +done
38.511 +
38.512 +lemma Suc_eq_number_of [simp]:
38.513 + "(Suc n = number_of v) =
38.514 + (let pv = number_of (Int.pred v) in
38.515 + if neg pv then False else nat pv = n)"
38.516 +by (rule trans [OF eq_sym_conv eq_number_of_Suc])
38.517 +
38.518 +lemma less_number_of_Suc [simp]:
38.519 + "(number_of v < Suc n) =
38.520 + (let pv = number_of (Int.pred v) in
38.521 + if neg pv then True else nat pv < n)"
38.522 +apply (simp only: simp_thms Let_def neg_eq_less_0 linorder_not_less
38.523 + number_of_pred nat_number_of_def
38.524 + split add: split_if)
38.525 +apply (rule_tac x = "number_of v" in spec)
38.526 +apply (auto simp add: nat_less_iff)
38.527 +done
38.528 +
38.529 +lemma less_Suc_number_of [simp]:
38.530 + "(Suc n < number_of v) =
38.531 + (let pv = number_of (Int.pred v) in
38.532 + if neg pv then False else n < nat pv)"
38.533 +apply (simp only: simp_thms Let_def neg_eq_less_0 linorder_not_less
38.534 + number_of_pred nat_number_of_def
38.535 + split add: split_if)
38.536 +apply (rule_tac x = "number_of v" in spec)
38.537 +apply (auto simp add: zless_nat_eq_int_zless)
38.538 +done
38.539 +
38.540 +lemma le_number_of_Suc [simp]:
38.541 + "(number_of v <= Suc n) =
38.542 + (let pv = number_of (Int.pred v) in
38.543 + if neg pv then True else nat pv <= n)"
38.544 +by (simp add: Let_def less_Suc_number_of linorder_not_less [symmetric])
38.545 +
38.546 +lemma le_Suc_number_of [simp]:
38.547 + "(Suc n <= number_of v) =
38.548 + (let pv = number_of (Int.pred v) in
38.549 + if neg pv then False else n <= nat pv)"
38.550 +by (simp add: Let_def less_number_of_Suc linorder_not_less [symmetric])
38.551 +
38.552 +
38.553 +lemma eq_number_of_Pls_Min: "(Numeral0 ::int) ~= number_of Int.Min"
38.554 +by auto
38.555 +
38.556 +
38.557 +
38.558 +subsection{*Max and Min Combined with @{term Suc} *}
38.559 +
38.560 +lemma max_number_of_Suc [simp]:
38.561 + "max (Suc n) (number_of v) =
38.562 + (let pv = number_of (Int.pred v) in
38.563 + if neg pv then Suc n else Suc(max n (nat pv)))"
38.564 +apply (simp only: Let_def neg_eq_less_0 number_of_pred nat_number_of_def
38.565 + split add: split_if nat.split)
38.566 +apply (rule_tac x = "number_of v" in spec)
38.567 +apply auto
38.568 +done
38.569 +
38.570 +lemma max_Suc_number_of [simp]:
38.571 + "max (number_of v) (Suc n) =
38.572 + (let pv = number_of (Int.pred v) in
38.573 + if neg pv then Suc n else Suc(max (nat pv) n))"
38.574 +apply (simp only: Let_def neg_eq_less_0 number_of_pred nat_number_of_def
38.575 + split add: split_if nat.split)
38.576 +apply (rule_tac x = "number_of v" in spec)
38.577 +apply auto
38.578 +done
38.579 +
38.580 +lemma min_number_of_Suc [simp]:
38.581 + "min (Suc n) (number_of v) =
38.582 + (let pv = number_of (Int.pred v) in
38.583 + if neg pv then 0 else Suc(min n (nat pv)))"
38.584 +apply (simp only: Let_def neg_eq_less_0 number_of_pred nat_number_of_def
38.585 + split add: split_if nat.split)
38.586 +apply (rule_tac x = "number_of v" in spec)
38.587 +apply auto
38.588 +done
38.589 +
38.590 +lemma min_Suc_number_of [simp]:
38.591 + "min (number_of v) (Suc n) =
38.592 + (let pv = number_of (Int.pred v) in
38.593 + if neg pv then 0 else Suc(min (nat pv) n))"
38.594 +apply (simp only: Let_def neg_eq_less_0 number_of_pred nat_number_of_def
38.595 + split add: split_if nat.split)
38.596 +apply (rule_tac x = "number_of v" in spec)
38.597 +apply auto
38.598 +done
38.599 +
38.600 +subsection{*Literal arithmetic involving powers*}
38.601 +
38.602 +lemma nat_power_eq: "(0::int) <= z ==> nat (z^n) = nat z ^ n"
38.603 +apply (induct "n")
38.604 +apply (simp_all (no_asm_simp) add: nat_mult_distrib)
38.605 +done
38.606 +
38.607 +lemma power_nat_number_of:
38.608 + "(number_of v :: nat) ^ n =
38.609 + (if neg (number_of v :: int) then 0^n else nat ((number_of v :: int) ^ n))"
38.610 +by (simp only: simp_thms neg_nat not_neg_eq_ge_0 nat_number_of_def nat_power_eq
38.611 + split add: split_if cong: imp_cong)
38.612 +
38.613 +
38.614 +lemmas power_nat_number_of_number_of = power_nat_number_of [of _ "number_of w", standard]
38.615 +declare power_nat_number_of_number_of [simp]
38.616 +
38.617 +
38.618 +
38.619 +text{*For arbitrary rings*}
38.620 +
38.621 +lemma power_number_of_even:
38.622 + fixes z :: "'a::{number_ring,recpower}"
38.623 + shows "z ^ number_of (Int.Bit0 w) = (let w = z ^ (number_of w) in w * w)"
38.624 +unfolding Let_def nat_number_of_def number_of_Bit0
38.625 +apply (rule_tac x = "number_of w" in spec, clarify)
38.626 +apply (case_tac " (0::int) <= x")
38.627 +apply (auto simp add: nat_mult_distrib power_even_eq power2_eq_square)
38.628 +done
38.629 +
38.630 +lemma power_number_of_odd:
38.631 + fixes z :: "'a::{number_ring,recpower}"
38.632 + shows "z ^ number_of (Int.Bit1 w) = (if (0::int) <= number_of w
38.633 + then (let w = z ^ (number_of w) in z * w * w) else 1)"
38.634 +unfolding Let_def nat_number_of_def number_of_Bit1
38.635 +apply (rule_tac x = "number_of w" in spec, auto)
38.636 +apply (simp only: nat_add_distrib nat_mult_distrib)
38.637 +apply simp
38.638 +apply (auto simp add: nat_add_distrib nat_mult_distrib power_even_eq power2_eq_square neg_nat power_Suc)
38.639 +done
38.640 +
38.641 +lemmas zpower_number_of_even = power_number_of_even [where 'a=int]
38.642 +lemmas zpower_number_of_odd = power_number_of_odd [where 'a=int]
38.643 +
38.644 +lemmas power_number_of_even_number_of [simp] =
38.645 + power_number_of_even [of "number_of v", standard]
38.646 +
38.647 +lemmas power_number_of_odd_number_of [simp] =
38.648 + power_number_of_odd [of "number_of v", standard]
38.649 +
38.650 +
38.651 +
38.652 +ML
38.653 +{*
38.654 +val numeral_ss = @{simpset} addsimps @{thms numerals};
38.655 +
38.656 +val nat_bin_arith_setup =
38.657 + Lin_Arith.map_data
38.658 + (fn {add_mono_thms, mult_mono_thms, inj_thms, lessD, neqE, simpset} =>
38.659 + {add_mono_thms = add_mono_thms, mult_mono_thms = mult_mono_thms,
38.660 + inj_thms = inj_thms,
38.661 + lessD = lessD, neqE = neqE,
38.662 + simpset = simpset addsimps @{thms neg_simps} @
38.663 + [@{thm Suc_nat_number_of}, @{thm int_nat_number_of}]})
38.664 +*}
38.665 +
38.666 +declaration {* K nat_bin_arith_setup *}
38.667 +
38.668 +(* Enable arith to deal with div/mod k where k is a numeral: *)
38.669 +declare split_div[of _ _ "number_of k", standard, arith_split]
38.670 +declare split_mod[of _ _ "number_of k", standard, arith_split]
38.671 +
38.672 +lemma nat_number_of_Pls: "Numeral0 = (0::nat)"
38.673 + by (simp add: number_of_Pls nat_number_of_def)
38.674 +
38.675 +lemma nat_number_of_Min: "number_of Int.Min = (0::nat)"
38.676 + apply (simp only: number_of_Min nat_number_of_def nat_zminus_int)
38.677 + done
38.678 +
38.679 +lemma nat_number_of_Bit0:
38.680 + "number_of (Int.Bit0 w) = (let n::nat = number_of w in n + n)"
38.681 + unfolding nat_number_of_def number_of_is_id numeral_simps Let_def
38.682 + by auto
38.683 +
38.684 +lemma nat_number_of_Bit1:
38.685 + "number_of (Int.Bit1 w) =
38.686 + (if neg (number_of w :: int) then 0
38.687 + else let n = number_of w in Suc (n + n))"
38.688 + unfolding nat_number_of_def number_of_is_id numeral_simps neg_def Let_def
38.689 + by auto
38.690 +
38.691 +lemmas nat_number =
38.692 + nat_number_of_Pls nat_number_of_Min
38.693 + nat_number_of_Bit0 nat_number_of_Bit1
38.694 +
38.695 +lemma Let_Suc [simp]: "Let (Suc n) f == f (Suc n)"
38.696 + by (simp add: Let_def)
38.697 +
38.698 +lemma power_m1_even: "(-1) ^ (2*n) = (1::'a::{number_ring,recpower})"
38.699 +by (simp add: power_mult power_Suc);
38.700 +
38.701 +lemma power_m1_odd: "(-1) ^ Suc(2*n) = (-1::'a::{number_ring,recpower})"
38.702 +by (simp add: power_mult power_Suc);
38.703 +
38.704 +
38.705 +subsection{*Literal arithmetic and @{term of_nat}*}
38.706 +
38.707 +lemma of_nat_double:
38.708 + "0 \<le> x ==> of_nat (nat (2 * x)) = of_nat (nat x) + of_nat (nat x)"
38.709 +by (simp only: mult_2 nat_add_distrib of_nat_add)
38.710 +
38.711 +lemma nat_numeral_m1_eq_0: "-1 = (0::nat)"
38.712 +by (simp only: nat_number_of_def)
38.713 +
38.714 +lemma of_nat_number_of_lemma:
38.715 + "of_nat (number_of v :: nat) =
38.716 + (if 0 \<le> (number_of v :: int)
38.717 + then (number_of v :: 'a :: number_ring)
38.718 + else 0)"
38.719 +by (simp add: int_number_of_def nat_number_of_def number_of_eq of_nat_nat);
38.720 +
38.721 +lemma of_nat_number_of_eq [simp]:
38.722 + "of_nat (number_of v :: nat) =
38.723 + (if neg (number_of v :: int) then 0
38.724 + else (number_of v :: 'a :: number_ring))"
38.725 +by (simp only: of_nat_number_of_lemma neg_def, simp)
38.726 +
38.727 +
38.728 +subsection {*Lemmas for the Combination and Cancellation Simprocs*}
38.729 +
38.730 +lemma nat_number_of_add_left:
38.731 + "number_of v + (number_of v' + (k::nat)) =
38.732 + (if neg (number_of v :: int) then number_of v' + k
38.733 + else if neg (number_of v' :: int) then number_of v + k
38.734 + else number_of (v + v') + k)"
38.735 + unfolding nat_number_of_def number_of_is_id neg_def
38.736 + by auto
38.737 +
38.738 +lemma nat_number_of_mult_left:
38.739 + "number_of v * (number_of v' * (k::nat)) =
38.740 + (if v < Int.Pls then 0
38.741 + else number_of (v * v') * k)"
38.742 +by simp
38.743 +
38.744 +
38.745 +subsubsection{*For @{text combine_numerals}*}
38.746 +
38.747 +lemma left_add_mult_distrib: "i*u + (j*u + k) = (i+j)*u + (k::nat)"
38.748 +by (simp add: add_mult_distrib)
38.749 +
38.750 +
38.751 +subsubsection{*For @{text cancel_numerals}*}
38.752 +
38.753 +lemma nat_diff_add_eq1:
38.754 + "j <= (i::nat) ==> ((i*u + m) - (j*u + n)) = (((i-j)*u + m) - n)"
38.755 +by (simp split add: nat_diff_split add: add_mult_distrib)
38.756 +
38.757 +lemma nat_diff_add_eq2:
38.758 + "i <= (j::nat) ==> ((i*u + m) - (j*u + n)) = (m - ((j-i)*u + n))"
38.759 +by (simp split add: nat_diff_split add: add_mult_distrib)
38.760 +
38.761 +lemma nat_eq_add_iff1:
38.762 + "j <= (i::nat) ==> (i*u + m = j*u + n) = ((i-j)*u + m = n)"
38.763 +by (auto split add: nat_diff_split simp add: add_mult_distrib)
38.764 +
38.765 +lemma nat_eq_add_iff2:
38.766 + "i <= (j::nat) ==> (i*u + m = j*u + n) = (m = (j-i)*u + n)"
38.767 +by (auto split add: nat_diff_split simp add: add_mult_distrib)
38.768 +
38.769 +lemma nat_less_add_iff1:
38.770 + "j <= (i::nat) ==> (i*u + m < j*u + n) = ((i-j)*u + m < n)"
38.771 +by (auto split add: nat_diff_split simp add: add_mult_distrib)
38.772 +
38.773 +lemma nat_less_add_iff2:
38.774 + "i <= (j::nat) ==> (i*u + m < j*u + n) = (m < (j-i)*u + n)"
38.775 +by (auto split add: nat_diff_split simp add: add_mult_distrib)
38.776 +
38.777 +lemma nat_le_add_iff1:
38.778 + "j <= (i::nat) ==> (i*u + m <= j*u + n) = ((i-j)*u + m <= n)"
38.779 +by (auto split add: nat_diff_split simp add: add_mult_distrib)
38.780 +
38.781 +lemma nat_le_add_iff2:
38.782 + "i <= (j::nat) ==> (i*u + m <= j*u + n) = (m <= (j-i)*u + n)"
38.783 +by (auto split add: nat_diff_split simp add: add_mult_distrib)
38.784 +
38.785 +
38.786 +subsubsection{*For @{text cancel_numeral_factors} *}
38.787 +
38.788 +lemma nat_mult_le_cancel1: "(0::nat) < k ==> (k*m <= k*n) = (m<=n)"
38.789 +by auto
38.790 +
38.791 +lemma nat_mult_less_cancel1: "(0::nat) < k ==> (k*m < k*n) = (m<n)"
38.792 +by auto
38.793 +
38.794 +lemma nat_mult_eq_cancel1: "(0::nat) < k ==> (k*m = k*n) = (m=n)"
38.795 +by auto
38.796 +
38.797 +lemma nat_mult_div_cancel1: "(0::nat) < k ==> (k*m) div (k*n) = (m div n)"
38.798 +by auto
38.799 +
38.800 +lemma nat_mult_dvd_cancel_disj[simp]:
38.801 + "(k*m) dvd (k*n) = (k=0 | m dvd (n::nat))"
38.802 +by(auto simp: dvd_eq_mod_eq_0 mod_mult_distrib2[symmetric])
38.803 +
38.804 +lemma nat_mult_dvd_cancel1: "0 < k \<Longrightarrow> (k*m) dvd (k*n::nat) = (m dvd n)"
38.805 +by(auto)
38.806 +
38.807 +
38.808 +subsubsection{*For @{text cancel_factor} *}
38.809 +
38.810 +lemma nat_mult_le_cancel_disj: "(k*m <= k*n) = ((0::nat) < k --> m<=n)"
38.811 +by auto
38.812 +
38.813 +lemma nat_mult_less_cancel_disj: "(k*m < k*n) = ((0::nat) < k & m<n)"
38.814 +by auto
38.815 +
38.816 +lemma nat_mult_eq_cancel_disj: "(k*m = k*n) = (k = (0::nat) | m=n)"
38.817 +by auto
38.818 +
38.819 +lemma nat_mult_div_cancel_disj[simp]:
38.820 + "(k*m) div (k*n) = (if k = (0::nat) then 0 else m div n)"
38.821 +by (simp add: nat_mult_div_cancel1)
38.822 +
38.823 +
38.824 +subsection {* Simprocs for the Naturals *}
38.825 +
38.826 +use "Tools/nat_simprocs.ML"
38.827 +declaration {* K nat_simprocs_setup *}
38.828 +
38.829 +subsubsection{*For simplifying @{term "Suc m - K"} and @{term "K - Suc m"}*}
38.830 +
38.831 +text{*Where K above is a literal*}
38.832 +
38.833 +lemma Suc_diff_eq_diff_pred: "Numeral0 < n ==> Suc m - n = m - (n - Numeral1)"
38.834 +by (simp add: numeral_0_eq_0 numeral_1_eq_1 split add: nat_diff_split)
38.835 +
38.836 +text {*Now just instantiating @{text n} to @{text "number_of v"} does
38.837 + the right simplification, but with some redundant inequality
38.838 + tests.*}
38.839 +lemma neg_number_of_pred_iff_0:
38.840 + "neg (number_of (Int.pred v)::int) = (number_of v = (0::nat))"
38.841 +apply (subgoal_tac "neg (number_of (Int.pred v)) = (number_of v < Suc 0) ")
38.842 +apply (simp only: less_Suc_eq_le le_0_eq)
38.843 +apply (subst less_number_of_Suc, simp)
38.844 +done
38.845 +
38.846 +text{*No longer required as a simprule because of the @{text inverse_fold}
38.847 + simproc*}
38.848 +lemma Suc_diff_number_of:
38.849 + "Int.Pls < v ==>
38.850 + Suc m - (number_of v) = m - (number_of (Int.pred v))"
38.851 +apply (subst Suc_diff_eq_diff_pred)
38.852 +apply simp
38.853 +apply (simp del: nat_numeral_1_eq_1)
38.854 +apply (auto simp only: diff_nat_number_of less_0_number_of [symmetric]
38.855 + neg_number_of_pred_iff_0)
38.856 +done
38.857 +
38.858 +lemma diff_Suc_eq_diff_pred: "m - Suc n = (m - 1) - n"
38.859 +by (simp add: numerals split add: nat_diff_split)
38.860 +
38.861 +
38.862 +subsubsection{*For @{term nat_case} and @{term nat_rec}*}
38.863 +
38.864 +lemma nat_case_number_of [simp]:
38.865 + "nat_case a f (number_of v) =
38.866 + (let pv = number_of (Int.pred v) in
38.867 + if neg pv then a else f (nat pv))"
38.868 +by (simp split add: nat.split add: Let_def neg_number_of_pred_iff_0)
38.869 +
38.870 +lemma nat_case_add_eq_if [simp]:
38.871 + "nat_case a f ((number_of v) + n) =
38.872 + (let pv = number_of (Int.pred v) in
38.873 + if neg pv then nat_case a f n else f (nat pv + n))"
38.874 +apply (subst add_eq_if)
38.875 +apply (simp split add: nat.split
38.876 + del: nat_numeral_1_eq_1
38.877 + add: nat_numeral_1_eq_1 [symmetric]
38.878 + numeral_1_eq_Suc_0 [symmetric]
38.879 + neg_number_of_pred_iff_0)
38.880 +done
38.881 +
38.882 +lemma nat_rec_number_of [simp]:
38.883 + "nat_rec a f (number_of v) =
38.884 + (let pv = number_of (Int.pred v) in
38.885 + if neg pv then a else f (nat pv) (nat_rec a f (nat pv)))"
38.886 +apply (case_tac " (number_of v) ::nat")
38.887 +apply (simp_all (no_asm_simp) add: Let_def neg_number_of_pred_iff_0)
38.888 +apply (simp split add: split_if_asm)
38.889 +done
38.890 +
38.891 +lemma nat_rec_add_eq_if [simp]:
38.892 + "nat_rec a f (number_of v + n) =
38.893 + (let pv = number_of (Int.pred v) in
38.894 + if neg pv then nat_rec a f n
38.895 + else f (nat pv + n) (nat_rec a f (nat pv + n)))"
38.896 +apply (subst add_eq_if)
38.897 +apply (simp split add: nat.split
38.898 + del: nat_numeral_1_eq_1
38.899 + add: nat_numeral_1_eq_1 [symmetric]
38.900 + numeral_1_eq_Suc_0 [symmetric]
38.901 + neg_number_of_pred_iff_0)
38.902 +done
38.903 +
38.904 +
38.905 +subsubsection{*Various Other Lemmas*}
38.906 +
38.907 +text {*Evens and Odds, for Mutilated Chess Board*}
38.908 +
38.909 +text{*Lemmas for specialist use, NOT as default simprules*}
38.910 +lemma nat_mult_2: "2 * z = (z+z::nat)"
38.911 +proof -
38.912 + have "2*z = (1 + 1)*z" by simp
38.913 + also have "... = z+z" by (simp add: left_distrib)
38.914 + finally show ?thesis .
38.915 +qed
38.916 +
38.917 +lemma nat_mult_2_right: "z * 2 = (z+z::nat)"
38.918 +by (subst mult_commute, rule nat_mult_2)
38.919 +
38.920 +text{*Case analysis on @{term "n<2"}*}
38.921 +lemma less_2_cases: "(n::nat) < 2 ==> n = 0 | n = Suc 0"
38.922 +by arith
38.923 +
38.924 +lemma div2_Suc_Suc [simp]: "Suc(Suc m) div 2 = Suc (m div 2)"
38.925 +by arith
38.926 +
38.927 +lemma add_self_div_2 [simp]: "(m + m) div 2 = (m::nat)"
38.928 +by (simp add: nat_mult_2 [symmetric])
38.929 +
38.930 +lemma mod2_Suc_Suc [simp]: "Suc(Suc(m)) mod 2 = m mod 2"
38.931 +apply (subgoal_tac "m mod 2 < 2")
38.932 +apply (erule less_2_cases [THEN disjE])
38.933 +apply (simp_all (no_asm_simp) add: Let_def mod_Suc nat_1)
38.934 +done
38.935 +
38.936 +lemma mod2_gr_0 [simp]: "!!m::nat. (0 < m mod 2) = (m mod 2 = 1)"
38.937 +apply (subgoal_tac "m mod 2 < 2")
38.938 +apply (force simp del: mod_less_divisor, simp)
38.939 +done
38.940 +
38.941 +text{*Removal of Small Numerals: 0, 1 and (in additive positions) 2*}
38.942 +
38.943 +lemma add_2_eq_Suc [simp]: "2 + n = Suc (Suc n)"
38.944 +by simp
38.945 +
38.946 +lemma add_2_eq_Suc' [simp]: "n + 2 = Suc (Suc n)"
38.947 +by simp
38.948 +
38.949 +text{*Can be used to eliminate long strings of Sucs, but not by default*}
38.950 +lemma Suc3_eq_add_3: "Suc (Suc (Suc n)) = 3 + n"
38.951 +by simp
38.952 +
38.953 +
38.954 +text{*These lemmas collapse some needless occurrences of Suc:
38.955 + at least three Sucs, since two and fewer are rewritten back to Suc again!
38.956 + We already have some rules to simplify operands smaller than 3.*}
38.957 +
38.958 +lemma div_Suc_eq_div_add3 [simp]: "m div (Suc (Suc (Suc n))) = m div (3+n)"
38.959 +by (simp add: Suc3_eq_add_3)
38.960 +
38.961 +lemma mod_Suc_eq_mod_add3 [simp]: "m mod (Suc (Suc (Suc n))) = m mod (3+n)"
38.962 +by (simp add: Suc3_eq_add_3)
38.963 +
38.964 +lemma Suc_div_eq_add3_div: "(Suc (Suc (Suc m))) div n = (3+m) div n"
38.965 +by (simp add: Suc3_eq_add_3)
38.966 +
38.967 +lemma Suc_mod_eq_add3_mod: "(Suc (Suc (Suc m))) mod n = (3+m) mod n"
38.968 +by (simp add: Suc3_eq_add_3)
38.969 +
38.970 +lemmas Suc_div_eq_add3_div_number_of =
38.971 + Suc_div_eq_add3_div [of _ "number_of v", standard]
38.972 +declare Suc_div_eq_add3_div_number_of [simp]
38.973 +
38.974 +lemmas Suc_mod_eq_add3_mod_number_of =
38.975 + Suc_mod_eq_add3_mod [of _ "number_of v", standard]
38.976 +declare Suc_mod_eq_add3_mod_number_of [simp]
38.977 +
38.978 +end
39.1 --- a/src/HOL/Orderings.thy Mon Apr 20 12:27:23 2009 +0200
39.2 +++ b/src/HOL/Orderings.thy Mon Apr 20 16:28:13 2009 +0200
39.3 @@ -5,7 +5,7 @@
39.4 header {* Abstract orderings *}
39.5
39.6 theory Orderings
39.7 -imports Code_Setup
39.8 +imports HOL
39.9 uses "~~/src/Provers/order.ML"
39.10 begin
39.11
40.1 --- a/src/HOL/Predicate.thy Mon Apr 20 12:27:23 2009 +0200
40.2 +++ b/src/HOL/Predicate.thy Mon Apr 20 16:28:13 2009 +0200
40.3 @@ -622,6 +622,31 @@
40.4 "pred_rec f P = f (eval P)"
40.5 by (cases P) simp
40.6
40.7 +export_code Seq in Eval module_name Predicate
40.8 +
40.9 +ML {*
40.10 +signature PREDICATE =
40.11 +sig
40.12 + datatype 'a pred = Seq of (unit -> 'a seq)
40.13 + and 'a seq = Empty | Insert of 'a * 'a pred | Join of 'a pred * 'a seq
40.14 +end;
40.15 +
40.16 +structure Predicate : PREDICATE =
40.17 +struct
40.18 +
40.19 +open Predicate;
40.20 +
40.21 +end;
40.22 +*}
40.23 +
40.24 +code_reserved Eval Predicate
40.25 +
40.26 +code_type pred and seq
40.27 + (Eval "_/ Predicate.pred" and "_/ Predicate.seq")
40.28 +
40.29 +code_const Seq and Empty and Insert and Join
40.30 + (Eval "Predicate.Seq" and "Predicate.Empty" and "Predicate.Insert/ (_,/ _)" and "Predicate.Join/ (_,/ _)")
40.31 +
40.32 no_notation
40.33 inf (infixl "\<sqinter>" 70) and
40.34 sup (infixl "\<squnion>" 65) and
41.1 --- a/src/HOL/Product_Type.thy Mon Apr 20 12:27:23 2009 +0200
41.2 +++ b/src/HOL/Product_Type.thy Mon Apr 20 16:28:13 2009 +0200
41.3 @@ -84,6 +84,14 @@
41.4 lemma unit_abs_eta_conv [simp,noatp]: "(%u::unit. f ()) = f"
41.5 by (rule ext) simp
41.6
41.7 +instantiation unit :: default
41.8 +begin
41.9 +
41.10 +definition "default = ()"
41.11 +
41.12 +instance ..
41.13 +
41.14 +end
41.15
41.16 text {* code generator setup *}
41.17
42.1 --- a/src/HOL/Relation_Power.thy Mon Apr 20 12:27:23 2009 +0200
42.2 +++ b/src/HOL/Relation_Power.thy Mon Apr 20 16:28:13 2009 +0200
42.3 @@ -9,132 +9,124 @@
42.4 imports Power Transitive_Closure Plain
42.5 begin
42.6
42.7 -instance
42.8 - "fun" :: (type, type) power ..
42.9 - --{* only type @{typ "'a => 'a"} should be in class @{text power}!*}
42.10 +consts funpower :: "('a \<Rightarrow> 'b) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'b" (infixr "^^" 80)
42.11
42.12 overloading
42.13 - relpow \<equiv> "power \<Colon> ('a \<times> 'a) set \<Rightarrow> nat \<Rightarrow> ('a \<times> 'a) set" (unchecked)
42.14 + relpow \<equiv> "funpower \<Colon> ('a \<times> 'a) set \<Rightarrow> nat \<Rightarrow> ('a \<times> 'a) set"
42.15 begin
42.16
42.17 -text {* @{text "R ^ n = R O ... O R"}, the n-fold composition of @{text R} *}
42.18 +text {* @{text "R ^^ n = R O ... O R"}, the n-fold composition of @{text R} *}
42.19
42.20 primrec relpow where
42.21 - "(R \<Colon> ('a \<times> 'a) set) ^ 0 = Id"
42.22 - | "(R \<Colon> ('a \<times> 'a) set) ^ Suc n = R O (R ^ n)"
42.23 + "(R \<Colon> ('a \<times> 'a) set) ^^ 0 = Id"
42.24 + | "(R \<Colon> ('a \<times> 'a) set) ^^ Suc n = R O (R ^^ n)"
42.25
42.26 end
42.27
42.28 overloading
42.29 - funpow \<equiv> "power \<Colon> ('a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a" (unchecked)
42.30 + funpow \<equiv> "funpower \<Colon> ('a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a"
42.31 begin
42.32
42.33 -text {* @{text "f ^ n = f o ... o f"}, the n-fold composition of @{text f} *}
42.34 +text {* @{text "f ^^ n = f o ... o f"}, the n-fold composition of @{text f} *}
42.35
42.36 primrec funpow where
42.37 - "(f \<Colon> 'a \<Rightarrow> 'a) ^ 0 = id"
42.38 - | "(f \<Colon> 'a \<Rightarrow> 'a) ^ Suc n = f o (f ^ n)"
42.39 + "(f \<Colon> 'a \<Rightarrow> 'a) ^^ 0 = id"
42.40 + | "(f \<Colon> 'a \<Rightarrow> 'a) ^^ Suc n = f o (f ^^ n)"
42.41
42.42 end
42.43
42.44 -text{*WARNING: due to the limits of Isabelle's type classes, exponentiation on
42.45 -functions and relations has too general a domain, namely @{typ "('a * 'b)set"}
42.46 -and @{typ "'a => 'b"}. Explicit type constraints may therefore be necessary.
42.47 -For example, @{term "range(f^n) = A"} and @{term "Range(R^n) = B"} need
42.48 -constraints.*}
42.49 -
42.50 -text {*
42.51 - Circumvent this problem for code generation:
42.52 -*}
42.53 -
42.54 -primrec
42.55 - fun_pow :: "nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a"
42.56 -where
42.57 - "fun_pow 0 f = id"
42.58 +primrec fun_pow :: "nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a" where
42.59 + "fun_pow 0 f = id"
42.60 | "fun_pow (Suc n) f = f o fun_pow n f"
42.61
42.62 -lemma funpow_fun_pow [code unfold]: "f ^ n = fun_pow n f"
42.63 +lemma funpow_fun_pow [code unfold]:
42.64 + "f ^^ n = fun_pow n f"
42.65 unfolding funpow_def fun_pow_def ..
42.66
42.67 -lemma funpow_add: "f ^ (m+n) = f^m o f^n"
42.68 +lemma funpow_add:
42.69 + "f ^^ (m + n) = f ^^ m o f ^^ n"
42.70 by (induct m) simp_all
42.71
42.72 -lemma funpow_swap1: "f((f^n) x) = (f^n)(f x)"
42.73 +lemma funpow_swap1:
42.74 + "f ((f ^^ n) x) = (f ^^ n) (f x)"
42.75 proof -
42.76 - have "f((f^n) x) = (f^(n+1)) x" unfolding One_nat_def by simp
42.77 - also have "\<dots> = (f^n o f^1) x" by (simp only: funpow_add)
42.78 - also have "\<dots> = (f^n)(f x)" unfolding One_nat_def by simp
42.79 + have "f ((f ^^ n) x) = (f ^^ (n+1)) x" unfolding One_nat_def by simp
42.80 + also have "\<dots> = (f ^^ n o f ^^ 1) x" by (simp only: funpow_add)
42.81 + also have "\<dots> = (f ^^ n) (f x)" unfolding One_nat_def by simp
42.82 finally show ?thesis .
42.83 qed
42.84
42.85 lemma rel_pow_1 [simp]:
42.86 - fixes R :: "('a*'a)set"
42.87 - shows "R^1 = R"
42.88 - unfolding One_nat_def by simp
42.89 -
42.90 -lemma rel_pow_0_I: "(x,x) : R^0"
42.91 + fixes R :: "('a * 'a) set"
42.92 + shows "R ^^ 1 = R"
42.93 by simp
42.94
42.95 -lemma rel_pow_Suc_I: "[| (x,y) : R^n; (y,z):R |] ==> (x,z):R^(Suc n)"
42.96 +lemma rel_pow_0_I:
42.97 + "(x, x) \<in> R ^^ 0"
42.98 + by simp
42.99 +
42.100 +lemma rel_pow_Suc_I:
42.101 + "(x, y) \<in> R ^^ n \<Longrightarrow> (y, z) \<in> R \<Longrightarrow> (x, z) \<in> R ^^ Suc n"
42.102 by auto
42.103
42.104 lemma rel_pow_Suc_I2:
42.105 - "(x, y) : R \<Longrightarrow> (y, z) : R^n \<Longrightarrow> (x,z) : R^(Suc n)"
42.106 - apply (induct n arbitrary: z)
42.107 - apply simp
42.108 - apply fastsimp
42.109 - done
42.110 + "(x, y) \<in> R \<Longrightarrow> (y, z) \<in> R ^^ n \<Longrightarrow> (x, z) \<in> R ^^ Suc n"
42.111 + by (induct n arbitrary: z) (simp, fastsimp)
42.112
42.113 -lemma rel_pow_0_E: "[| (x,y) : R^0; x=y ==> P |] ==> P"
42.114 +lemma rel_pow_0_E:
42.115 + "(x, y) \<in> R ^^ 0 \<Longrightarrow> (x = y \<Longrightarrow> P) \<Longrightarrow> P"
42.116 by simp
42.117
42.118 lemma rel_pow_Suc_E:
42.119 - "[| (x,z) : R^(Suc n); !!y. [| (x,y) : R^n; (y,z) : R |] ==> P |] ==> P"
42.120 + "(x, z) \<in> R ^^ Suc n \<Longrightarrow> (\<And>y. (x, y) \<in> R ^^ n \<Longrightarrow> (y, z) \<in> R \<Longrightarrow> P) \<Longrightarrow> P"
42.121 by auto
42.122
42.123 lemma rel_pow_E:
42.124 - "[| (x,z) : R^n; [| n=0; x = z |] ==> P;
42.125 - !!y m. [| n = Suc m; (x,y) : R^m; (y,z) : R |] ==> P
42.126 - |] ==> P"
42.127 + "(x, z) \<in> R ^^ n \<Longrightarrow> (n = 0 \<Longrightarrow> x = z \<Longrightarrow> P)
42.128 + \<Longrightarrow> (\<And>y m. n = Suc m \<Longrightarrow> (x, y) \<in> R ^^ m \<Longrightarrow> (y, z) \<in> R \<Longrightarrow> P)
42.129 + \<Longrightarrow> P"
42.130 by (cases n) auto
42.131
42.132 lemma rel_pow_Suc_D2:
42.133 - "(x, z) : R^(Suc n) \<Longrightarrow> (\<exists>y. (x,y) : R & (y,z) : R^n)"
42.134 + "(x, z) \<in> R ^^ Suc n \<Longrightarrow> (\<exists>y. (x, y) \<in> R \<and> (y, z) \<in> R ^^ n)"
42.135 apply (induct n arbitrary: x z)
42.136 apply (blast intro: rel_pow_0_I elim: rel_pow_0_E rel_pow_Suc_E)
42.137 apply (blast intro: rel_pow_Suc_I elim: rel_pow_0_E rel_pow_Suc_E)
42.138 done
42.139
42.140 lemma rel_pow_Suc_D2':
42.141 - "\<forall>x y z. (x,y) : R^n & (y,z) : R --> (\<exists>w. (x,w) : R & (w,z) : R^n)"
42.142 + "\<forall>x y z. (x, y) \<in> R ^^ n \<and> (y, z) \<in> R \<longrightarrow> (\<exists>w. (x, w) \<in> R \<and> (w, z) \<in> R ^^ n)"
42.143 by (induct n) (simp_all, blast)
42.144
42.145 lemma rel_pow_E2:
42.146 - "[| (x,z) : R^n; [| n=0; x = z |] ==> P;
42.147 - !!y m. [| n = Suc m; (x,y) : R; (y,z) : R^m |] ==> P
42.148 - |] ==> P"
42.149 - apply (case_tac n, simp)
42.150 + "(x, z) \<in> R ^^ n \<Longrightarrow> (n = 0 \<Longrightarrow> x = z \<Longrightarrow> P)
42.151 + \<Longrightarrow> (\<And>y m. n = Suc m \<Longrightarrow> (x, y) \<in> R \<Longrightarrow> (y, z) \<in> R ^^ m \<Longrightarrow> P)
42.152 + \<Longrightarrow> P"
42.153 + apply (cases n, simp)
42.154 apply (cut_tac n=nat and R=R in rel_pow_Suc_D2', simp, blast)
42.155 done
42.156
42.157 -lemma rtrancl_imp_UN_rel_pow: "!!p. p:R^* ==> p : (UN n. R^n)"
42.158 - apply (simp only: split_tupled_all)
42.159 +lemma rtrancl_imp_UN_rel_pow:
42.160 + "p \<in> R^* \<Longrightarrow> p \<in> (\<Union>n. R ^^ n)"
42.161 + apply (cases p) apply (simp only:)
42.162 apply (erule rtrancl_induct)
42.163 apply (blast intro: rel_pow_0_I rel_pow_Suc_I)+
42.164 done
42.165
42.166 -lemma rel_pow_imp_rtrancl: "!!p. p:R^n ==> p:R^*"
42.167 - apply (simp only: split_tupled_all)
42.168 - apply (induct n)
42.169 +lemma rel_pow_imp_rtrancl:
42.170 + "p \<in> R ^^ n \<Longrightarrow> p \<in> R^*"
42.171 + apply (induct n arbitrary: p)
42.172 + apply (simp_all only: split_tupled_all)
42.173 apply (blast intro: rtrancl_refl elim: rel_pow_0_E)
42.174 apply (blast elim: rel_pow_Suc_E intro: rtrancl_into_rtrancl)
42.175 done
42.176
42.177 -lemma rtrancl_is_UN_rel_pow: "R^* = (UN n. R^n)"
42.178 +lemma rtrancl_is_UN_rel_pow:
42.179 + "R^* = (UN n. R ^^ n)"
42.180 by (blast intro: rtrancl_imp_UN_rel_pow rel_pow_imp_rtrancl)
42.181
42.182 lemma trancl_power:
42.183 - "x \<in> r^+ = (\<exists>n > 0. x \<in> r^n)"
42.184 + "x \<in> r^+ = (\<exists>n > 0. x \<in> r ^^ n)"
42.185 apply (cases x)
42.186 apply simp
42.187 apply (rule iffI)
42.188 @@ -151,30 +143,12 @@
42.189 done
42.190
42.191 lemma single_valued_rel_pow:
42.192 - "!!r::('a * 'a)set. single_valued r ==> single_valued (r^n)"
42.193 + fixes R :: "('a * 'a) set"
42.194 + shows "single_valued R \<Longrightarrow> single_valued (R ^^ n)"
42.195 + apply (induct n arbitrary: R)
42.196 + apply simp_all
42.197 apply (rule single_valuedI)
42.198 - apply (induct n)
42.199 - apply simp
42.200 apply (fast dest: single_valuedD elim: rel_pow_Suc_E)
42.201 done
42.202
42.203 -ML
42.204 -{*
42.205 -val funpow_add = thm "funpow_add";
42.206 -val rel_pow_1 = thm "rel_pow_1";
42.207 -val rel_pow_0_I = thm "rel_pow_0_I";
42.208 -val rel_pow_Suc_I = thm "rel_pow_Suc_I";
42.209 -val rel_pow_Suc_I2 = thm "rel_pow_Suc_I2";
42.210 -val rel_pow_0_E = thm "rel_pow_0_E";
42.211 -val rel_pow_Suc_E = thm "rel_pow_Suc_E";
42.212 -val rel_pow_E = thm "rel_pow_E";
42.213 -val rel_pow_Suc_D2 = thm "rel_pow_Suc_D2";
42.214 -val rel_pow_Suc_D2 = thm "rel_pow_Suc_D2";
42.215 -val rel_pow_E2 = thm "rel_pow_E2";
42.216 -val rtrancl_imp_UN_rel_pow = thm "rtrancl_imp_UN_rel_pow";
42.217 -val rel_pow_imp_rtrancl = thm "rel_pow_imp_rtrancl";
42.218 -val rtrancl_is_UN_rel_pow = thm "rtrancl_is_UN_rel_pow";
42.219 -val single_valued_rel_pow = thm "single_valued_rel_pow";
42.220 -*}
42.221 -
42.222 end
43.1 --- a/src/HOL/SizeChange/Interpretation.thy Mon Apr 20 12:27:23 2009 +0200
43.2 +++ b/src/HOL/SizeChange/Interpretation.thy Mon Apr 20 16:28:13 2009 +0200
43.3 @@ -35,7 +35,7 @@
43.4 and nia: "\<And>x. \<not>accp R x \<Longrightarrow> \<not>accp R (f x)"
43.5 by blast
43.6
43.7 - let ?s = "\<lambda>i. (f ^ i) x"
43.8 + let ?s = "\<lambda>i. (f o^ i) x"
43.9
43.10 {
43.11 fix i
44.1 --- a/src/HOL/Tools/Qelim/presburger.ML Mon Apr 20 12:27:23 2009 +0200
44.2 +++ b/src/HOL/Tools/Qelim/presburger.ML Mon Apr 20 16:28:13 2009 +0200
44.3 @@ -131,7 +131,7 @@
44.4 @{thm "div_0"}, @{thm "mod_0"}, @{thm "div_by_1"}, @{thm "mod_by_1"}, @{thm "div_1"},
44.5 @{thm "mod_1"}, @{thm "Suc_plus1"}]
44.6 @ @{thms add_ac}
44.7 - addsimprocs [cancel_div_mod_proc]
44.8 + addsimprocs [cancel_div_mod_nat_proc, cancel_div_mod_int_proc]
44.9 val splits_ss = comp_ss addsimps [@{thm "mod_div_equality'"}] addsplits
44.10 [@{thm "split_zdiv"}, @{thm "split_zmod"}, @{thm "split_div'"},
44.11 @{thm "split_min"}, @{thm "split_max"}, @{thm "abs_split"}]
45.1 --- a/src/HOL/Tools/int_factor_simprocs.ML Mon Apr 20 12:27:23 2009 +0200
45.2 +++ b/src/HOL/Tools/int_factor_simprocs.ML Mon Apr 20 16:28:13 2009 +0200
45.3 @@ -1,5 +1,4 @@
45.4 (* Title: HOL/int_factor_simprocs.ML
45.5 - ID: $Id$
45.6 Author: Lawrence C Paulson, Cambridge University Computer Laboratory
45.7 Copyright 2000 University of Cambridge
45.8
45.9 @@ -46,13 +45,13 @@
45.10 @{thm mult_zero_right}, @{thm mult_Bit1}, @{thm mult_1_right}];
45.11 end
45.12
45.13 -(*Version for integer division*)
45.14 -structure IntDivCancelNumeralFactor = CancelNumeralFactorFun
45.15 +(*Version for semiring_div*)
45.16 +structure DivCancelNumeralFactor = CancelNumeralFactorFun
45.17 (open CancelNumeralFactorCommon
45.18 val prove_conv = Arith_Data.prove_conv
45.19 val mk_bal = HOLogic.mk_binop @{const_name Divides.div}
45.20 - val dest_bal = HOLogic.dest_bin @{const_name Divides.div} HOLogic.intT
45.21 - val cancel = @{thm zdiv_zmult_zmult1} RS trans
45.22 + val dest_bal = HOLogic.dest_bin @{const_name Divides.div} Term.dummyT
45.23 + val cancel = @{thm div_mult_mult1} RS trans
45.24 val neg_exchanges = false
45.25 )
45.26
45.27 @@ -108,8 +107,9 @@
45.28 "(l::'a::{ordered_idom,number_ring}) <= m * n"],
45.29 K LeCancelNumeralFactor.proc),
45.30 ("int_div_cancel_numeral_factors",
45.31 - ["((l::int) * m) div n", "(l::int) div (m * n)"],
45.32 - K IntDivCancelNumeralFactor.proc),
45.33 + ["((l::'a::{semiring_div,number_ring}) * m) div n",
45.34 + "(l::'a::{semiring_div,number_ring}) div (m * n)"],
45.35 + K DivCancelNumeralFactor.proc),
45.36 ("divide_cancel_numeral_factor",
45.37 ["((l::'a::{division_by_zero,field,number_ring}) * m) / n",
45.38 "(l::'a::{division_by_zero,field,number_ring}) / (m * n)",
45.39 @@ -284,24 +284,25 @@
45.40 @{thm mult_less_cancel_left_pos} @{thm mult_less_cancel_left_neg}
45.41 );
45.42
45.43 -(*zdiv_zmult_zmult1_if is for integer division (div).*)
45.44 -structure IntDivCancelFactor = ExtractCommonTermFun
45.45 +(*for semirings with division*)
45.46 +structure DivCancelFactor = ExtractCommonTermFun
45.47 (open CancelFactorCommon
45.48 val prove_conv = Arith_Data.prove_conv
45.49 val mk_bal = HOLogic.mk_binop @{const_name Divides.div}
45.50 - val dest_bal = HOLogic.dest_bin @{const_name Divides.div} HOLogic.intT
45.51 - val simp_conv = K (K (SOME @{thm zdiv_zmult_zmult1_if}))
45.52 + val dest_bal = HOLogic.dest_bin @{const_name Divides.div} Term.dummyT
45.53 + val simp_conv = K (K (SOME @{thm div_mult_mult1_if}))
45.54 );
45.55
45.56 -structure IntModCancelFactor = ExtractCommonTermFun
45.57 +structure ModCancelFactor = ExtractCommonTermFun
45.58 (open CancelFactorCommon
45.59 val prove_conv = Arith_Data.prove_conv
45.60 val mk_bal = HOLogic.mk_binop @{const_name Divides.mod}
45.61 val dest_bal = HOLogic.dest_bin @{const_name Divides.mod} HOLogic.intT
45.62 - val simp_conv = K (K (SOME @{thm zmod_zmult_zmult1}))
45.63 + val simp_conv = K (K (SOME @{thm mod_mult_mult1}))
45.64 );
45.65
45.66 -structure IntDvdCancelFactor = ExtractCommonTermFun
45.67 +(*for idoms*)
45.68 +structure DvdCancelFactor = ExtractCommonTermFun
45.69 (open CancelFactorCommon
45.70 val prove_conv = Arith_Data.prove_conv
45.71 val mk_bal = HOLogic.mk_binrel @{const_name Ring_and_Field.dvd}
45.72 @@ -321,8 +322,8 @@
45.73 val cancel_factors =
45.74 map Arith_Data.prep_simproc
45.75 [("ring_eq_cancel_factor",
45.76 - ["(l::'a::{idom}) * m = n",
45.77 - "(l::'a::{idom}) = m * n"],
45.78 + ["(l::'a::idom) * m = n",
45.79 + "(l::'a::idom) = m * n"],
45.80 K EqCancelFactor.proc),
45.81 ("ordered_ring_le_cancel_factor",
45.82 ["(l::'a::ordered_ring) * m <= n",
45.83 @@ -333,14 +334,14 @@
45.84 "(l::'a::ordered_ring) < m * n"],
45.85 K LessCancelFactor.proc),
45.86 ("int_div_cancel_factor",
45.87 - ["((l::int) * m) div n", "(l::int) div (m * n)"],
45.88 - K IntDivCancelFactor.proc),
45.89 + ["((l::'a::semiring_div) * m) div n", "(l::'a::semiring_div) div (m * n)"],
45.90 + K DivCancelFactor.proc),
45.91 ("int_mod_cancel_factor",
45.92 - ["((l::int) * m) mod n", "(l::int) mod (m * n)"],
45.93 - K IntModCancelFactor.proc),
45.94 + ["((l::'a::semiring_div) * m) mod n", "(l::'a::semiring_div) mod (m * n)"],
45.95 + K ModCancelFactor.proc),
45.96 ("dvd_cancel_factor",
45.97 ["((l::'a::idom) * m) dvd n", "(l::'a::idom) dvd (m * n)"],
45.98 - K IntDvdCancelFactor.proc),
45.99 + K DvdCancelFactor.proc),
45.100 ("divide_cancel_factor",
45.101 ["((l::'a::{division_by_zero,field}) * m) / n",
45.102 "(l::'a::{division_by_zero,field}) / (m * n)"],
46.1 --- a/src/HOL/Transitive_Closure.thy Mon Apr 20 12:27:23 2009 +0200
46.2 +++ b/src/HOL/Transitive_Closure.thy Mon Apr 20 16:28:13 2009 +0200
46.3 @@ -630,6 +630,139 @@
46.4
46.5 declare trancl_into_rtrancl [elim]
46.6
46.7 +subsection {* The power operation on relations *}
46.8 +
46.9 +text {* @{text "R ^^ n = R O ... O R"}, the n-fold composition of @{text R} *}
46.10 +
46.11 +primrec relpow :: "('a \<times> 'a) set \<Rightarrow> nat \<Rightarrow> ('a \<times> 'a) set" (infixr "^^" 80) where
46.12 + "R ^^ 0 = Id"
46.13 + | "R ^^ Suc n = R O (R ^^ n)"
46.14 +
46.15 +notation (latex output)
46.16 + relpow ("(_\<^bsup>_\<^esup>)" [1000] 1000)
46.17 +
46.18 +notation (HTML output)
46.19 + relpow ("(_\<^bsup>_\<^esup>)" [1000] 1000)
46.20 +
46.21 +lemma rel_pow_1 [simp]:
46.22 + "R ^^ 1 = R"
46.23 + by simp
46.24 +
46.25 +lemma rel_pow_0_I:
46.26 + "(x, x) \<in> R ^^ 0"
46.27 + by simp
46.28 +
46.29 +lemma rel_pow_Suc_I:
46.30 + "(x, y) \<in> R ^^ n \<Longrightarrow> (y, z) \<in> R \<Longrightarrow> (x, z) \<in> R ^^ Suc n"
46.31 + by auto
46.32 +
46.33 +lemma rel_pow_Suc_I2:
46.34 + "(x, y) \<in> R \<Longrightarrow> (y, z) \<in> R ^^ n \<Longrightarrow> (x, z) \<in> R ^^ Suc n"
46.35 + by (induct n arbitrary: z) (simp, fastsimp)
46.36 +
46.37 +lemma rel_pow_0_E:
46.38 + "(x, y) \<in> R ^^ 0 \<Longrightarrow> (x = y \<Longrightarrow> P) \<Longrightarrow> P"
46.39 + by simp
46.40 +
46.41 +lemma rel_pow_Suc_E:
46.42 + "(x, z) \<in> R ^^ Suc n \<Longrightarrow> (\<And>y. (x, y) \<in> R ^^ n \<Longrightarrow> (y, z) \<in> R \<Longrightarrow> P) \<Longrightarrow> P"
46.43 + by auto
46.44 +
46.45 +lemma rel_pow_E:
46.46 + "(x, z) \<in> R ^^ n \<Longrightarrow> (n = 0 \<Longrightarrow> x = z \<Longrightarrow> P)
46.47 + \<Longrightarrow> (\<And>y m. n = Suc m \<Longrightarrow> (x, y) \<in> R ^^ m \<Longrightarrow> (y, z) \<in> R \<Longrightarrow> P)
46.48 + \<Longrightarrow> P"
46.49 + by (cases n) auto
46.50 +
46.51 +lemma rel_pow_Suc_D2:
46.52 + "(x, z) \<in> R ^^ Suc n \<Longrightarrow> (\<exists>y. (x, y) \<in> R \<and> (y, z) \<in> R ^^ n)"
46.53 + apply (induct n arbitrary: x z)
46.54 + apply (blast intro: rel_pow_0_I elim: rel_pow_0_E rel_pow_Suc_E)
46.55 + apply (blast intro: rel_pow_Suc_I elim: rel_pow_0_E rel_pow_Suc_E)
46.56 + done
46.57 +
46.58 +lemma rel_pow_Suc_E2:
46.59 + "(x, z) \<in> R ^^ Suc n \<Longrightarrow> (\<And>y. (x, y) \<in> R \<Longrightarrow> (y, z) \<in> R ^^ n \<Longrightarrow> P) \<Longrightarrow> P"
46.60 + by (blast dest: rel_pow_Suc_D2)
46.61 +
46.62 +lemma rel_pow_Suc_D2':
46.63 + "\<forall>x y z. (x, y) \<in> R ^^ n \<and> (y, z) \<in> R \<longrightarrow> (\<exists>w. (x, w) \<in> R \<and> (w, z) \<in> R ^^ n)"
46.64 + by (induct n) (simp_all, blast)
46.65 +
46.66 +lemma rel_pow_E2:
46.67 + "(x, z) \<in> R ^^ n \<Longrightarrow> (n = 0 \<Longrightarrow> x = z \<Longrightarrow> P)
46.68 + \<Longrightarrow> (\<And>y m. n = Suc m \<Longrightarrow> (x, y) \<in> R \<Longrightarrow> (y, z) \<in> R ^^ m \<Longrightarrow> P)
46.69 + \<Longrightarrow> P"
46.70 + apply (cases n, simp)
46.71 + apply (cut_tac n=nat and R=R in rel_pow_Suc_D2', simp, blast)
46.72 + done
46.73 +
46.74 +lemma rtrancl_imp_UN_rel_pow:
46.75 + assumes "p \<in> R^*"
46.76 + shows "p \<in> (\<Union>n. R ^^ n)"
46.77 +proof (cases p)
46.78 + case (Pair x y)
46.79 + with assms have "(x, y) \<in> R^*" by simp
46.80 + then have "(x, y) \<in> (\<Union>n. R ^^ n)" proof induct
46.81 + case base show ?case by (blast intro: rel_pow_0_I)
46.82 + next
46.83 + case step then show ?case by (blast intro: rel_pow_Suc_I)
46.84 + qed
46.85 + with Pair show ?thesis by simp
46.86 +qed
46.87 +
46.88 +lemma rel_pow_imp_rtrancl:
46.89 + assumes "p \<in> R ^^ n"
46.90 + shows "p \<in> R^*"
46.91 +proof (cases p)
46.92 + case (Pair x y)
46.93 + with assms have "(x, y) \<in> R ^^ n" by simp
46.94 + then have "(x, y) \<in> R^*" proof (induct n arbitrary: x y)
46.95 + case 0 then show ?case by simp
46.96 + next
46.97 + case Suc then show ?case
46.98 + by (blast elim: rel_pow_Suc_E intro: rtrancl_into_rtrancl)
46.99 + qed
46.100 + with Pair show ?thesis by simp
46.101 +qed
46.102 +
46.103 +lemma rtrancl_is_UN_rel_pow:
46.104 + "R^* = (\<Union>n. R ^^ n)"
46.105 + by (blast intro: rtrancl_imp_UN_rel_pow rel_pow_imp_rtrancl)
46.106 +
46.107 +lemma rtrancl_power:
46.108 + "p \<in> R^* \<longleftrightarrow> (\<exists>n. p \<in> R ^^ n)"
46.109 + by (simp add: rtrancl_is_UN_rel_pow)
46.110 +
46.111 +lemma trancl_power:
46.112 + "p \<in> R^+ \<longleftrightarrow> (\<exists>n > 0. p \<in> R ^^ n)"
46.113 + apply (cases p)
46.114 + apply simp
46.115 + apply (rule iffI)
46.116 + apply (drule tranclD2)
46.117 + apply (clarsimp simp: rtrancl_is_UN_rel_pow)
46.118 + apply (rule_tac x="Suc x" in exI)
46.119 + apply (clarsimp simp: rel_comp_def)
46.120 + apply fastsimp
46.121 + apply clarsimp
46.122 + apply (case_tac n, simp)
46.123 + apply clarsimp
46.124 + apply (drule rel_pow_imp_rtrancl)
46.125 + apply (drule rtrancl_into_trancl1) apply auto
46.126 + done
46.127 +
46.128 +lemma rtrancl_imp_rel_pow:
46.129 + "p \<in> R^* \<Longrightarrow> \<exists>n. p \<in> R ^^ n"
46.130 + by (auto dest: rtrancl_imp_UN_rel_pow)
46.131 +
46.132 +lemma single_valued_rel_pow:
46.133 + fixes R :: "('a * 'a) set"
46.134 + shows "single_valued R \<Longrightarrow> single_valued (R ^^ n)"
46.135 + apply (induct n arbitrary: R)
46.136 + apply simp_all
46.137 + apply (rule single_valuedI)
46.138 + apply (fast dest: single_valuedD elim: rel_pow_Suc_E)
46.139 + done
46.140
46.141 subsection {* Setup of transitivity reasoner *}
46.142
47.1 --- a/src/HOL/UNITY/Comp.thy Mon Apr 20 12:27:23 2009 +0200
47.2 +++ b/src/HOL/UNITY/Comp.thy Mon Apr 20 16:28:13 2009 +0200
47.3 @@ -15,14 +15,22 @@
47.4
47.5 header{*Composition: Basic Primitives*}
47.6
47.7 -theory Comp imports Union begin
47.8 +theory Comp
47.9 +imports Union
47.10 +begin
47.11
47.12 -instance program :: (type) ord ..
47.13 +instantiation program :: (type) ord
47.14 +begin
47.15
47.16 -defs
47.17 - component_def: "F \<le> H == \<exists>G. F\<squnion>G = H"
47.18 - strict_component_def: "(F < (H::'a program)) == (F \<le> H & F \<noteq> H)"
47.19 +definition
47.20 + component_def: "F \<le> H <-> (\<exists>G. F\<squnion>G = H)"
47.21
47.22 +definition
47.23 + strict_component_def: "F < (H::'a program) <-> (F \<le> H & F \<noteq> H)"
47.24 +
47.25 +instance ..
47.26 +
47.27 +end
47.28
47.29 constdefs
47.30 component_of :: "'a program =>'a program=> bool"
47.31 @@ -114,7 +122,7 @@
47.32 by (auto simp add: stable_def component_constrains)
47.33
47.34 (*Used in Guar.thy to show that programs are partially ordered*)
47.35 -lemmas program_less_le = strict_component_def [THEN meta_eq_to_obj_eq]
47.36 +lemmas program_less_le = strict_component_def
47.37
47.38
47.39 subsection{*The preserves property*}
47.40 @@ -229,8 +237,7 @@
47.41 apply (blast intro: Join_assoc [symmetric])
47.42 done
47.43
47.44 -lemmas strict_component_of_eq =
47.45 - strict_component_of_def [THEN meta_eq_to_obj_eq, standard]
47.46 +lemmas strict_component_of_eq = strict_component_of_def
47.47
47.48 (** localize **)
47.49 lemma localize_Init_eq [simp]: "Init (localize v F) = Init F"
48.1 --- a/src/HOL/UNITY/Transformers.thy Mon Apr 20 12:27:23 2009 +0200
48.2 +++ b/src/HOL/UNITY/Transformers.thy Mon Apr 20 16:28:13 2009 +0200
48.3 @@ -338,10 +338,10 @@
48.4
48.5 constdefs
48.6 wens_single_finite :: "[('a*'a) set, 'a set, nat] => 'a set"
48.7 - "wens_single_finite act B k == \<Union>i \<in> atMost k. ((wp act)^i) B"
48.8 + "wens_single_finite act B k == \<Union>i \<in> atMost k. (wp act o^ i) B"
48.9
48.10 wens_single :: "[('a*'a) set, 'a set] => 'a set"
48.11 - "wens_single act B == \<Union>i. ((wp act)^i) B"
48.12 + "wens_single act B == \<Union>i. (wp act o^ i) B"
48.13
48.14 lemma wens_single_Un_eq:
48.15 "single_valued act
49.1 --- a/src/HOL/Word/BinBoolList.thy Mon Apr 20 12:27:23 2009 +0200
49.2 +++ b/src/HOL/Word/BinBoolList.thy Mon Apr 20 16:28:13 2009 +0200
49.3 @@ -38,7 +38,7 @@
49.4 if y then rbl_add ws x else ws)"
49.5
49.6 lemma butlast_power:
49.7 - "(butlast ^ n) bl = take (length bl - n) bl"
49.8 + "(butlast o^ n) bl = take (length bl - n) bl"
49.9 by (induct n) (auto simp: butlast_take)
49.10
49.11 lemma bin_to_bl_aux_Pls_minus_simp [simp]:
49.12 @@ -370,14 +370,14 @@
49.13 done
49.14
49.15 lemma nth_rest_power_bin [rule_format] :
49.16 - "ALL n. bin_nth ((bin_rest ^ k) w) n = bin_nth w (n + k)"
49.17 + "ALL n. bin_nth ((bin_rest o^ k) w) n = bin_nth w (n + k)"
49.18 apply (induct k, clarsimp)
49.19 apply clarsimp
49.20 apply (simp only: bin_nth.Suc [symmetric] add_Suc)
49.21 done
49.22
49.23 lemma take_rest_power_bin:
49.24 - "m <= n ==> take m (bin_to_bl n w) = bin_to_bl m ((bin_rest ^ (n - m)) w)"
49.25 + "m <= n ==> take m (bin_to_bl n w) = bin_to_bl m ((bin_rest o^ (n - m)) w)"
49.26 apply (rule nth_equalityI)
49.27 apply simp
49.28 apply (clarsimp simp add: nth_bin_to_bl nth_rest_power_bin)
50.1 --- a/src/HOL/Word/BinGeneral.thy Mon Apr 20 12:27:23 2009 +0200
50.2 +++ b/src/HOL/Word/BinGeneral.thy Mon Apr 20 16:28:13 2009 +0200
50.3 @@ -439,7 +439,7 @@
50.4 apply clarsimp
50.5 apply (simp add: bin_last_mod bin_rest_div Bit_def
50.6 cong: number_of_False_cong)
50.7 - apply (clarsimp simp: zmod_zmult_zmult1 [symmetric]
50.8 + apply (clarsimp simp: mod_mult_mult1 [symmetric]
50.9 zmod_zdiv_equality [THEN diff_eq_eq [THEN iffD2 [THEN sym]]])
50.10 apply (rule trans [symmetric, OF _ emep1])
50.11 apply auto
50.12 @@ -822,8 +822,8 @@
50.13 by (induct n) auto
50.14
50.15 lemma bin_rest_power_trunc [rule_format] :
50.16 - "(bin_rest ^ k) (bintrunc n bin) =
50.17 - bintrunc (n - k) ((bin_rest ^ k) bin)"
50.18 + "(bin_rest o^ k) (bintrunc n bin) =
50.19 + bintrunc (n - k) ((bin_rest o^ k) bin)"
50.20 by (induct k) (auto simp: bin_rest_trunc)
50.21
50.22 lemma bin_rest_trunc_i:
50.23 @@ -857,7 +857,7 @@
50.24 by (rule ext) auto
50.25
50.26 lemma rco_lem:
50.27 - "f o g o f = g o f ==> f o (g o f) ^ n = g ^ n o f"
50.28 + "f o g o f = g o f ==> f o (g o f) o^ n = g o^ n o f"
50.29 apply (rule ext)
50.30 apply (induct_tac n)
50.31 apply (simp_all (no_asm))
50.32 @@ -867,7 +867,7 @@
50.33 apply simp
50.34 done
50.35
50.36 -lemma rco_alt: "(f o g) ^ n o f = f o (g o f) ^ n"
50.37 +lemma rco_alt: "(f o g) o^ n o f = f o (g o f) o^ n"
50.38 apply (rule ext)
50.39 apply (induct n)
50.40 apply (simp_all add: o_def)
50.41 @@ -891,8 +891,9 @@
50.42
50.43 subsection {* Miscellaneous lemmas *}
50.44
50.45 -lemmas funpow_minus_simp =
50.46 - trans [OF gen_minus [where f = "power f"] funpow_Suc, standard]
50.47 +lemma funpow_minus_simp:
50.48 + "0 < n \<Longrightarrow> f o^ n = f \<circ> f o^ (n - 1)"
50.49 + by (cases n) simp_all
50.50
50.51 lemmas funpow_pred_simp [simp] =
50.52 funpow_minus_simp [of "number_of bin", simplified nobm1, standard]
51.1 --- a/src/HOL/Word/BinOperations.thy Mon Apr 20 12:27:23 2009 +0200
51.2 +++ b/src/HOL/Word/BinOperations.thy Mon Apr 20 16:28:13 2009 +0200
51.3 @@ -641,7 +641,7 @@
51.4 apply (simp add: bin_rest_div zdiv_zmult2_eq)
51.5 apply (case_tac b rule: bin_exhaust)
51.6 apply simp
51.7 - apply (simp add: Bit_def zmod_zmult_zmult1 p1mod22k
51.8 + apply (simp add: Bit_def mod_mult_mult1 p1mod22k
51.9 split: bit.split
51.10 cong: number_of_False_cong)
51.11 done
52.1 --- a/src/HOL/Word/Num_Lemmas.thy Mon Apr 20 12:27:23 2009 +0200
52.2 +++ b/src/HOL/Word/Num_Lemmas.thy Mon Apr 20 16:28:13 2009 +0200
52.3 @@ -66,7 +66,7 @@
52.4 apply (safe dest!: even_equiv_def [THEN iffD1])
52.5 apply (subst pos_zmod_mult_2)
52.6 apply arith
52.7 - apply (simp add: zmod_zmult_zmult1)
52.8 + apply (simp add: mod_mult_mult1)
52.9 done
52.10
52.11 lemmas eme1p = emep1 [simplified add_commute]
53.1 --- a/src/HOL/Word/TdThs.thy Mon Apr 20 12:27:23 2009 +0200
53.2 +++ b/src/HOL/Word/TdThs.thy Mon Apr 20 16:28:13 2009 +0200
53.3 @@ -110,7 +110,7 @@
53.4 done
53.5
53.6 lemma fn_comm_power:
53.7 - "fa o tr = tr o fr ==> fa ^ n o tr = tr o fr ^ n"
53.8 + "fa o tr = tr o fr ==> fa o^ n o tr = tr o fr o^ n"
53.9 apply (rule ext)
53.10 apply (induct n)
53.11 apply (auto dest: fun_cong)
54.1 --- a/src/HOL/Word/WordDefinition.thy Mon Apr 20 12:27:23 2009 +0200
54.2 +++ b/src/HOL/Word/WordDefinition.thy Mon Apr 20 16:28:13 2009 +0200
54.3 @@ -207,10 +207,10 @@
54.4 "shiftr1 w = word_of_int (bin_rest (uint w))"
54.5
54.6 definition
54.7 - shiftl_def: "w << n = (shiftl1 ^ n) w"
54.8 + shiftl_def: "w << n = (shiftl1 o^ n) w"
54.9
54.10 definition
54.11 - shiftr_def: "w >> n = (shiftr1 ^ n) w"
54.12 + shiftr_def: "w >> n = (shiftr1 o^ n) w"
54.13
54.14 instance ..
54.15
54.16 @@ -245,7 +245,7 @@
54.17 "bshiftr1 b w == of_bl (b # butlast (to_bl w))"
54.18
54.19 sshiftr :: "'a :: len word => nat => 'a word" (infixl ">>>" 55)
54.20 - "w >>> n == (sshiftr1 ^ n) w"
54.21 + "w >>> n == (sshiftr1 o^ n) w"
54.22
54.23 mask :: "nat => 'a::len word"
54.24 "mask n == (1 << n) - 1"
54.25 @@ -268,7 +268,7 @@
54.26 case ys of [] => [] | x # xs => last ys # butlast ys"
54.27
54.28 rotater :: "nat => 'a list => 'a list"
54.29 - "rotater n == rotater1 ^ n"
54.30 + "rotater n == rotater1 o^ n"
54.31
54.32 word_rotr :: "nat => 'a :: len0 word => 'a :: len0 word"
54.33 "word_rotr n w == of_bl (rotater n (to_bl w))"
54.34 @@ -303,7 +303,7 @@
54.35 constdefs
54.36 -- "Largest representable machine integer."
54.37 max_word :: "'a::len word"
54.38 - "max_word \<equiv> word_of_int (2^len_of TYPE('a) - 1)"
54.39 + "max_word \<equiv> word_of_int (2 ^ len_of TYPE('a) - 1)"
54.40
54.41 consts
54.42 of_bool :: "bool \<Rightarrow> 'a::len word"
55.1 --- a/src/HOL/Word/WordShift.thy Mon Apr 20 12:27:23 2009 +0200
55.2 +++ b/src/HOL/Word/WordShift.thy Mon Apr 20 16:28:13 2009 +0200
55.3 @@ -361,14 +361,14 @@
55.4
55.5 lemma shiftr_no':
55.6 "w = number_of bin ==>
55.7 - (w::'a::len0 word) >> n = number_of ((bin_rest ^ n) (bintrunc (size w) bin))"
55.8 + (w::'a::len0 word) >> n = number_of ((bin_rest o^ n) (bintrunc (size w) bin))"
55.9 apply clarsimp
55.10 apply (rule word_eqI)
55.11 apply (auto simp: nth_shiftr nth_rest_power_bin nth_bintr word_size)
55.12 done
55.13
55.14 lemma sshiftr_no':
55.15 - "w = number_of bin ==> w >>> n = number_of ((bin_rest ^ n)
55.16 + "w = number_of bin ==> w >>> n = number_of ((bin_rest o^ n)
55.17 (sbintrunc (size w - 1) bin))"
55.18 apply clarsimp
55.19 apply (rule word_eqI)
56.1 --- a/src/HOL/base.ML Mon Apr 20 12:27:23 2009 +0200
56.2 +++ b/src/HOL/base.ML Mon Apr 20 16:28:13 2009 +0200
56.3 @@ -1,2 +1,2 @@
56.4 (*side-entry for HOL-Base*)
56.5 -use_thy "Code_Setup";
56.6 +use_thy "HOL";
57.1 --- a/src/HOL/ex/NormalForm.thy Mon Apr 20 12:27:23 2009 +0200
57.2 +++ b/src/HOL/ex/NormalForm.thy Mon Apr 20 16:28:13 2009 +0200
57.3 @@ -1,7 +1,6 @@
57.4 -(* Authors: Klaus Aehlig, Tobias Nipkow
57.5 -*)
57.6 +(* Authors: Klaus Aehlig, Tobias Nipkow *)
57.7
57.8 -header {* Test of normalization function *}
57.9 +header {* Testing implementation of normalization by evaluation *}
57.10
57.11 theory NormalForm
57.12 imports Main Rational
57.13 @@ -19,18 +18,13 @@
57.14
57.15 datatype n = Z | S n
57.16
57.17 -consts
57.18 - add :: "n \<Rightarrow> n \<Rightarrow> n"
57.19 - add2 :: "n \<Rightarrow> n \<Rightarrow> n"
57.20 - mul :: "n \<Rightarrow> n \<Rightarrow> n"
57.21 - mul2 :: "n \<Rightarrow> n \<Rightarrow> n"
57.22 - exp :: "n \<Rightarrow> n \<Rightarrow> n"
57.23 -primrec
57.24 - "add Z = id"
57.25 - "add (S m) = S o add m"
57.26 -primrec
57.27 - "add2 Z n = n"
57.28 - "add2 (S m) n = S(add2 m n)"
57.29 +primrec add :: "n \<Rightarrow> n \<Rightarrow> n" where
57.30 + "add Z = id"
57.31 + | "add (S m) = S o add m"
57.32 +
57.33 +primrec add2 :: "n \<Rightarrow> n \<Rightarrow> n" where
57.34 + "add2 Z n = n"
57.35 + | "add2 (S m) n = S(add2 m n)"
57.36
57.37 declare add2.simps [code]
57.38 lemma [code nbe]: "add2 (add2 n m) k = add2 n (add2 m k)"
57.39 @@ -44,15 +38,17 @@
57.40 lemma "add2 (add2 (S n) (S m)) (S k) = S(S(S(add2 n (add2 m k))))" by normalization
57.41 lemma "add2 (add2 (S n) (add2 (S m) Z)) (S k) = S(S(S(add2 n (add2 m k))))" by normalization
57.42
57.43 -primrec
57.44 - "mul Z = (%n. Z)"
57.45 - "mul (S m) = (%n. add (mul m n) n)"
57.46 -primrec
57.47 - "mul2 Z n = Z"
57.48 - "mul2 (S m) n = add2 n (mul2 m n)"
57.49 -primrec
57.50 - "exp m Z = S Z"
57.51 - "exp m (S n) = mul (exp m n) m"
57.52 +primrec mul :: "n \<Rightarrow> n \<Rightarrow> n" where
57.53 + "mul Z = (%n. Z)"
57.54 + | "mul (S m) = (%n. add (mul m n) n)"
57.55 +
57.56 +primrec mul2 :: "n \<Rightarrow> n \<Rightarrow> n" where
57.57 + "mul2 Z n = Z"
57.58 + | "mul2 (S m) n = add2 n (mul2 m n)"
57.59 +
57.60 +primrec exp :: "n \<Rightarrow> n \<Rightarrow> n" where
57.61 + "exp m Z = S Z"
57.62 + | "exp m (S n) = mul (exp m n) m"
57.63
57.64 lemma "mul2 (S(S(S(S(S Z))))) (S(S(S Z))) = S(S(S(S(S(S(S(S(S(S(S(S(S(S(S Z))))))))))))))" by normalization
57.65 lemma "mul (S(S(S(S(S Z))))) (S(S(S Z))) = S(S(S(S(S(S(S(S(S(S(S(S(S(S(S Z))))))))))))))" by normalization
58.1 --- a/src/HOL/ex/Predicate_Compile.thy Mon Apr 20 12:27:23 2009 +0200
58.2 +++ b/src/HOL/ex/Predicate_Compile.thy Mon Apr 20 16:28:13 2009 +0200
58.3 @@ -12,26 +12,21 @@
58.4 | "next yield (Predicate.Join P xq) = (case yield P
58.5 of None \<Rightarrow> next yield xq | Some (x, Q) \<Rightarrow> Some (x, Predicate.Seq (\<lambda>_. Predicate.Join Q xq)))"
58.6
58.7 -ML {*
58.8 -let
58.9 - fun yield (@{code Predicate.Seq} f) = @{code next} yield (f ())
58.10 -in
58.11 - yield @{code "\<bottom> :: 'a Predicate.pred"} (*replace bottom with sequence to evaluate*)
58.12 -end
58.13 -*}
58.14 -
58.15 fun anamorph :: "('b \<Rightarrow> ('a \<times> 'b) option) \<Rightarrow> index \<Rightarrow> 'b \<Rightarrow> 'a list \<times> 'b" where
58.16 "anamorph f k x = (if k = 0 then ([], x)
58.17 else case f x of None \<Rightarrow> ([], x) | Some (v, y) \<Rightarrow> let (vs, z) = anamorph f (k - 1) y in (v # vs, z))"
58.18
58.19 ML {*
58.20 -let
58.21 - fun yield (@{code Predicate.Seq} f) = @{code next} yield (f ())
58.22 - fun yieldn k = @{code anamorph} yield k
58.23 -in
58.24 - yieldn 0 (*replace with number of elements to retrieve*)
58.25 - @{code "\<bottom> :: 'a Predicate.pred"} (*replace bottom with sequence to evaluate*)
58.26 -end
58.27 +structure Predicate =
58.28 +struct
58.29 +
58.30 +open Predicate;
58.31 +
58.32 +fun yield (Predicate.Seq f) = @{code next} yield (f ());
58.33 +
58.34 +fun yieldn k = @{code anamorph} yield k;
58.35 +
58.36 +end;
58.37 *}
58.38
58.39 end
58.40 \ No newline at end of file
59.1 --- a/src/HOL/ex/Quickcheck_Generators.thy Mon Apr 20 12:27:23 2009 +0200
59.2 +++ b/src/HOL/ex/Quickcheck_Generators.thy Mon Apr 20 16:28:13 2009 +0200
59.3 @@ -6,62 +6,6 @@
59.4 imports Quickcheck State_Monad
59.5 begin
59.6
59.7 -subsection {* Type @{typ "'a \<Rightarrow> 'b"} *}
59.8 -
59.9 -ML {*
59.10 -structure Random_Engine =
59.11 -struct
59.12 -
59.13 -open Random_Engine;
59.14 -
59.15 -fun random_fun (T1 : typ) (T2 : typ) (eq : 'a -> 'a -> bool) (term_of : 'a -> term)
59.16 - (random : Random_Engine.seed -> ('b * (unit -> term)) * Random_Engine.seed)
59.17 - (random_split : Random_Engine.seed -> Random_Engine.seed * Random_Engine.seed)
59.18 - (seed : Random_Engine.seed) =
59.19 - let
59.20 - val (seed', seed'') = random_split seed;
59.21 - val state = ref (seed', [], Const (@{const_name undefined}, T1 --> T2));
59.22 - val fun_upd = Const (@{const_name fun_upd},
59.23 - (T1 --> T2) --> T1 --> T2 --> T1 --> T2);
59.24 - fun random_fun' x =
59.25 - let
59.26 - val (seed, fun_map, f_t) = ! state;
59.27 - in case AList.lookup (uncurry eq) fun_map x
59.28 - of SOME y => y
59.29 - | NONE => let
59.30 - val t1 = term_of x;
59.31 - val ((y, t2), seed') = random seed;
59.32 - val fun_map' = (x, y) :: fun_map;
59.33 - val f_t' = fun_upd $ f_t $ t1 $ t2 ();
59.34 - val _ = state := (seed', fun_map', f_t');
59.35 - in y end
59.36 - end;
59.37 - fun term_fun' () = #3 (! state);
59.38 - in ((random_fun', term_fun'), seed'') end;
59.39 -
59.40 -end
59.41 -*}
59.42 -
59.43 -axiomatization
59.44 - random_fun_aux :: "typerep \<Rightarrow> typerep \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> term)
59.45 - \<Rightarrow> (seed \<Rightarrow> ('b \<times> (unit \<Rightarrow> term)) \<times> seed) \<Rightarrow> (seed \<Rightarrow> seed \<times> seed)
59.46 - \<Rightarrow> seed \<Rightarrow> (('a \<Rightarrow> 'b) \<times> (unit \<Rightarrow> term)) \<times> seed"
59.47 -
59.48 -code_const random_fun_aux (SML "Random'_Engine.random'_fun")
59.49 -
59.50 -instantiation "fun" :: ("{eq, term_of}", "{type, random}") random
59.51 -begin
59.52 -
59.53 -definition random_fun :: "index \<Rightarrow> seed \<Rightarrow> (('a \<Rightarrow> 'b) \<times> (unit \<Rightarrow> term)) \<times> seed" where
59.54 - "random n = random_fun_aux TYPEREP('a) TYPEREP('b) (op =) Code_Eval.term_of (random n) split_seed"
59.55 -
59.56 -instance ..
59.57 -
59.58 -end
59.59 -
59.60 -code_reserved SML Random_Engine
59.61 -
59.62 -
59.63 subsection {* Datatypes *}
59.64
59.65 definition
60.1 --- a/src/Provers/Arith/cancel_div_mod.ML Mon Apr 20 12:27:23 2009 +0200
60.2 +++ b/src/Provers/Arith/cancel_div_mod.ML Mon Apr 20 16:28:13 2009 +0200
60.3 @@ -69,7 +69,7 @@
60.4
60.5 fun cancel ss t pq =
60.6 let val teqt' = Data.prove_eq_sums ss (t, rearrange t pq)
60.7 - in hd(Data.div_mod_eqs RL [teqt' RS transitive_thm]) end;
60.8 + in hd (Data.div_mod_eqs RL [teqt' RS transitive_thm]) end;
60.9
60.10 fun proc ss t =
60.11 let val (divs,mods) = coll_div_mod t ([],[])
61.1 --- a/src/Pure/Isar/code.ML Mon Apr 20 12:27:23 2009 +0200
61.2 +++ b/src/Pure/Isar/code.ML Mon Apr 20 16:28:13 2009 +0200
61.3 @@ -29,8 +29,6 @@
61.4 val add_undefined: string -> theory -> theory
61.5 val purge_data: theory -> theory
61.6
61.7 - val coregular_algebra: theory -> Sorts.algebra
61.8 - val operational_algebra: theory -> (sort -> sort) * Sorts.algebra
61.9 val these_eqns: theory -> string -> (thm * bool) list
61.10 val these_raw_eqns: theory -> string -> (thm * bool) list
61.11 val get_datatype: theory -> string -> ((string * sort) list * (string * typ list) list)
61.12 @@ -469,39 +467,6 @@
61.13 fun mk_default_eqn thy = Code_Unit.try_thm (check_linear o Code_Unit.mk_eqn thy);
61.14
61.15
61.16 -(** operational sort algebra and class discipline **)
61.17 -
61.18 -local
61.19 -
61.20 -fun arity_constraints thy algebra (class, tyco) =
61.21 - let
61.22 - val base_constraints = Sorts.mg_domain algebra tyco [class];
61.23 - val classparam_constraints = Sorts.complete_sort algebra [class]
61.24 - |> maps (map fst o these o try (#params o AxClass.get_info thy))
61.25 - |> map_filter (fn c => try (AxClass.param_of_inst thy) (c, tyco))
61.26 - |> maps (map fst o get_eqns thy)
61.27 - |> map (map (snd o dest_TVar) o Sign.const_typargs thy o Code_Unit.const_typ_eqn);
61.28 - val inter_sorts = map2 (curry (Sorts.inter_sort algebra));
61.29 - in fold inter_sorts classparam_constraints base_constraints end;
61.30 -
61.31 -fun retrieve_algebra thy operational =
61.32 - Sorts.subalgebra (Syntax.pp_global thy) operational
61.33 - (SOME o arity_constraints thy (Sign.classes_of thy))
61.34 - (Sign.classes_of thy);
61.35 -
61.36 -in
61.37 -
61.38 -fun coregular_algebra thy = retrieve_algebra thy (K true) |> snd;
61.39 -fun operational_algebra thy =
61.40 - let
61.41 - fun add_iff_operational class =
61.42 - can (AxClass.get_info thy) class ? cons class;
61.43 - val operational_classes = fold add_iff_operational (Sign.all_classes thy) []
61.44 - in retrieve_algebra thy (member (op =) operational_classes) end;
61.45 -
61.46 -end; (*local*)
61.47 -
61.48 -
61.49 (** interfaces and attributes **)
61.50
61.51 fun delete_force msg key xs =
62.1 --- a/src/Pure/axclass.ML Mon Apr 20 12:27:23 2009 +0200
62.2 +++ b/src/Pure/axclass.ML Mon Apr 20 16:28:13 2009 +0200
62.3 @@ -286,74 +286,6 @@
62.4 handle TYPE (msg, _, _) => error msg;
62.5
62.6
62.7 -(* primitive rules *)
62.8 -
62.9 -fun add_classrel th thy =
62.10 - let
62.11 - fun err () = raise THM ("add_classrel: malformed class relation", 0, [th]);
62.12 - val prop = Thm.plain_prop_of (Thm.transfer thy th);
62.13 - val rel = Logic.dest_classrel prop handle TERM _ => err ();
62.14 - val (c1, c2) = cert_classrel thy rel handle TYPE _ => err ();
62.15 - in
62.16 - thy
62.17 - |> Sign.primitive_classrel (c1, c2)
62.18 - |> put_classrel ((c1, c2), Thm.close_derivation (Drule.unconstrainTs th))
62.19 - |> perhaps complete_arities
62.20 - end;
62.21 -
62.22 -fun add_arity th thy =
62.23 - let
62.24 - fun err () = raise THM ("add_arity: malformed type arity", 0, [th]);
62.25 - val prop = Thm.plain_prop_of (Thm.transfer thy th);
62.26 - val (t, Ss, c) = Logic.dest_arity prop handle TERM _ => err ();
62.27 - val _ = map (Sign.certify_sort thy) Ss = Ss orelse err ();
62.28 - val _ = case filter_out (fn c => can (get_inst_param thy) (c, t)) (params_of thy c)
62.29 - of [] => ()
62.30 - | cs => Output.legacy_feature
62.31 - ("Missing specifications for overloaded parameters " ^ commas_quote cs)
62.32 - val th' = Drule.unconstrainTs th;
62.33 - in
62.34 - thy
62.35 - |> Sign.primitive_arity (t, Ss, [c])
62.36 - |> put_arity ((t, Ss, c), th')
62.37 - end;
62.38 -
62.39 -
62.40 -(* tactical proofs *)
62.41 -
62.42 -fun prove_classrel raw_rel tac thy =
62.43 - let
62.44 - val ctxt = ProofContext.init thy;
62.45 - val (c1, c2) = cert_classrel thy raw_rel;
62.46 - val th = Goal.prove ctxt [] [] (Logic.mk_classrel (c1, c2)) (K tac) handle ERROR msg =>
62.47 - cat_error msg ("The error(s) above occurred while trying to prove class relation " ^
62.48 - quote (Syntax.string_of_classrel ctxt [c1, c2]));
62.49 - in
62.50 - thy
62.51 - |> PureThy.add_thms [((Binding.name
62.52 - (prefix classrel_prefix (Logic.name_classrel (c1, c2))), th), [])]
62.53 - |-> (fn [th'] => add_classrel th')
62.54 - end;
62.55 -
62.56 -fun prove_arity raw_arity tac thy =
62.57 - let
62.58 - val ctxt = ProofContext.init thy;
62.59 - val arity = Sign.cert_arity thy raw_arity;
62.60 - val names = map (prefix arity_prefix) (Logic.name_arities arity);
62.61 - val props = Logic.mk_arities arity;
62.62 - val ths = Goal.prove_multi ctxt [] [] props
62.63 - (fn _ => Goal.precise_conjunction_tac (length props) 1 THEN tac) handle ERROR msg =>
62.64 - cat_error msg ("The error(s) above occurred while trying to prove type arity " ^
62.65 - quote (Syntax.string_of_arity ctxt arity));
62.66 - in
62.67 - thy
62.68 - |> PureThy.add_thms (map (rpair []) (map Binding.name names ~~ ths))
62.69 - |-> fold add_arity
62.70 - end;
62.71 -
62.72 -
62.73 -(* instance parameters and overloaded definitions *)
62.74 -
62.75 (* declaration and definition of instances of overloaded constants *)
62.76
62.77 fun declare_overloaded (c, T) thy =
62.78 @@ -398,6 +330,74 @@
62.79 end;
62.80
62.81
62.82 +(* primitive rules *)
62.83 +
62.84 +fun add_classrel th thy =
62.85 + let
62.86 + fun err () = raise THM ("add_classrel: malformed class relation", 0, [th]);
62.87 + val prop = Thm.plain_prop_of (Thm.transfer thy th);
62.88 + val rel = Logic.dest_classrel prop handle TERM _ => err ();
62.89 + val (c1, c2) = cert_classrel thy rel handle TYPE _ => err ();
62.90 + in
62.91 + thy
62.92 + |> Sign.primitive_classrel (c1, c2)
62.93 + |> put_classrel ((c1, c2), Thm.close_derivation (Drule.unconstrainTs th))
62.94 + |> perhaps complete_arities
62.95 + end;
62.96 +
62.97 +fun add_arity th thy =
62.98 + let
62.99 + fun err () = raise THM ("add_arity: malformed type arity", 0, [th]);
62.100 + val prop = Thm.plain_prop_of (Thm.transfer thy th);
62.101 + val (t, Ss, c) = Logic.dest_arity prop handle TERM _ => err ();
62.102 + val T = Type (t, map TFree (Name.names Name.context Name.aT Ss));
62.103 + val missing_params = Sign.complete_sort thy [c]
62.104 + |> maps (these o Option.map #params o try (get_info thy))
62.105 + |> filter_out (fn (const, _) => can (get_inst_param thy) (const, t))
62.106 + |> (map o apsnd o map_atyps) (K T);
62.107 + val _ = map (Sign.certify_sort thy) Ss = Ss orelse err ();
62.108 + val th' = Drule.unconstrainTs th;
62.109 + in
62.110 + thy
62.111 + |> fold (snd oo declare_overloaded) missing_params
62.112 + |> Sign.primitive_arity (t, Ss, [c])
62.113 + |> put_arity ((t, Ss, c), th')
62.114 + end;
62.115 +
62.116 +
62.117 +(* tactical proofs *)
62.118 +
62.119 +fun prove_classrel raw_rel tac thy =
62.120 + let
62.121 + val ctxt = ProofContext.init thy;
62.122 + val (c1, c2) = cert_classrel thy raw_rel;
62.123 + val th = Goal.prove ctxt [] [] (Logic.mk_classrel (c1, c2)) (K tac) handle ERROR msg =>
62.124 + cat_error msg ("The error(s) above occurred while trying to prove class relation " ^
62.125 + quote (Syntax.string_of_classrel ctxt [c1, c2]));
62.126 + in
62.127 + thy
62.128 + |> PureThy.add_thms [((Binding.name
62.129 + (prefix classrel_prefix (Logic.name_classrel (c1, c2))), th), [])]
62.130 + |-> (fn [th'] => add_classrel th')
62.131 + end;
62.132 +
62.133 +fun prove_arity raw_arity tac thy =
62.134 + let
62.135 + val ctxt = ProofContext.init thy;
62.136 + val arity = Sign.cert_arity thy raw_arity;
62.137 + val names = map (prefix arity_prefix) (Logic.name_arities arity);
62.138 + val props = Logic.mk_arities arity;
62.139 + val ths = Goal.prove_multi ctxt [] [] props
62.140 + (fn _ => Goal.precise_conjunction_tac (length props) 1 THEN tac) handle ERROR msg =>
62.141 + cat_error msg ("The error(s) above occurred while trying to prove type arity " ^
62.142 + quote (Syntax.string_of_arity ctxt arity));
62.143 + in
62.144 + thy
62.145 + |> PureThy.add_thms (map (rpair []) (map Binding.name names ~~ ths))
62.146 + |-> fold add_arity
62.147 + end;
62.148 +
62.149 +
62.150
62.151 (** class definitions **)
62.152
63.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
63.2 +++ b/src/Tools/Code_Generator.thy Mon Apr 20 16:28:13 2009 +0200
63.3 @@ -0,0 +1,27 @@
63.4 +(* Title: Tools/Code_Generator.thy
63.5 + Author: Florian Haftmann, TU Muenchen
63.6 +*)
63.7 +
63.8 +header {* Loading the code generator modules *}
63.9 +
63.10 +theory Code_Generator
63.11 +imports Pure
63.12 +uses
63.13 + "~~/src/Tools/value.ML"
63.14 + "~~/src/Tools/code/code_name.ML"
63.15 + "~~/src/Tools/code/code_wellsorted.ML"
63.16 + "~~/src/Tools/code/code_thingol.ML"
63.17 + "~~/src/Tools/code/code_printer.ML"
63.18 + "~~/src/Tools/code/code_target.ML"
63.19 + "~~/src/Tools/code/code_ml.ML"
63.20 + "~~/src/Tools/code/code_haskell.ML"
63.21 + "~~/src/Tools/nbe.ML"
63.22 +begin
63.23 +
63.24 +setup {*
63.25 + Code_ML.setup
63.26 + #> Code_Haskell.setup
63.27 + #> Nbe.setup
63.28 +*}
63.29 +
63.30 +end
63.31 \ No newline at end of file
64.1 --- a/src/Tools/code/code_funcgr.ML Mon Apr 20 12:27:23 2009 +0200
64.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
64.3 @@ -1,335 +0,0 @@
64.4 -(* Title: Tools/code/code_funcgr.ML
64.5 - Author: Florian Haftmann, TU Muenchen
64.6 -
64.7 -Retrieving, normalizing and structuring code equations in graph
64.8 -with explicit dependencies.
64.9 -
64.10 -Legacy. To be replaced by Tools/code/code_wellsorted.ML
64.11 -*)
64.12 -
64.13 -signature CODE_WELLSORTED =
64.14 -sig
64.15 - type T
64.16 - val eqns: T -> string -> (thm * bool) list
64.17 - val typ: T -> string -> (string * sort) list * typ
64.18 - val all: T -> string list
64.19 - val pretty: theory -> T -> Pretty.T
64.20 - val make: theory -> string list
64.21 - -> ((sort -> sort) * Sorts.algebra) * T
64.22 - val eval_conv: theory
64.23 - -> (term -> term * (((sort -> sort) * Sorts.algebra) -> T -> thm)) -> cterm -> thm
64.24 - val eval_term: theory
64.25 - -> (term -> term * (((sort -> sort) * Sorts.algebra) -> T -> 'a)) -> term -> 'a
64.26 - val timing: bool ref
64.27 -end
64.28 -
64.29 -structure Code_Wellsorted : CODE_WELLSORTED =
64.30 -struct
64.31 -
64.32 -(** the graph type **)
64.33 -
64.34 -type T = (((string * sort) list * typ) * (thm * bool) list) Graph.T;
64.35 -
64.36 -fun eqns funcgr =
64.37 - these o Option.map snd o try (Graph.get_node funcgr);
64.38 -
64.39 -fun typ funcgr =
64.40 - fst o Graph.get_node funcgr;
64.41 -
64.42 -fun all funcgr = Graph.keys funcgr;
64.43 -
64.44 -fun pretty thy funcgr =
64.45 - AList.make (snd o Graph.get_node funcgr) (Graph.keys funcgr)
64.46 - |> (map o apfst) (Code_Unit.string_of_const thy)
64.47 - |> sort (string_ord o pairself fst)
64.48 - |> map (fn (s, thms) =>
64.49 - (Pretty.block o Pretty.fbreaks) (
64.50 - Pretty.str s
64.51 - :: map (Display.pretty_thm o fst) thms
64.52 - ))
64.53 - |> Pretty.chunks;
64.54 -
64.55 -
64.56 -(** generic combinators **)
64.57 -
64.58 -fun fold_consts f thms =
64.59 - thms
64.60 - |> maps (op :: o swap o apfst (snd o strip_comb) o Logic.dest_equals o Thm.plain_prop_of)
64.61 - |> (fold o fold_aterms) (fn Const c => f c | _ => I);
64.62 -
64.63 -fun consts_of (const, []) = []
64.64 - | consts_of (const, thms as _ :: _) =
64.65 - let
64.66 - fun the_const (c, _) = if c = const then I else insert (op =) c
64.67 - in fold_consts the_const (map fst thms) [] end;
64.68 -
64.69 -fun insts_of thy algebra tys sorts =
64.70 - let
64.71 - fun class_relation (x, _) _ = x;
64.72 - fun type_constructor tyco xs class =
64.73 - (tyco, class) :: (maps o maps) fst xs;
64.74 - fun type_variable (TVar (_, sort)) = map (pair []) sort
64.75 - | type_variable (TFree (_, sort)) = map (pair []) sort;
64.76 - fun of_sort_deriv ty sort =
64.77 - Sorts.of_sort_derivation (Syntax.pp_global thy) algebra
64.78 - { class_relation = class_relation, type_constructor = type_constructor,
64.79 - type_variable = type_variable }
64.80 - (ty, sort) handle Sorts.CLASS_ERROR _ => [] (*permissive!*)
64.81 - in (flat o flat) (map2 of_sort_deriv tys sorts) end;
64.82 -
64.83 -fun meets_of thy algebra =
64.84 - let
64.85 - fun meet_of ty sort tab =
64.86 - Sorts.meet_sort algebra (ty, sort) tab
64.87 - handle Sorts.CLASS_ERROR _ => tab (*permissive!*);
64.88 - in fold2 meet_of end;
64.89 -
64.90 -
64.91 -(** graph algorithm **)
64.92 -
64.93 -val timing = ref false;
64.94 -
64.95 -local
64.96 -
64.97 -fun resort_thms thy algebra typ_of thms =
64.98 - let
64.99 - val cs = fold_consts (insert (op =)) thms [];
64.100 - fun meets (c, ty) = case typ_of c
64.101 - of SOME (vs, _) =>
64.102 - meets_of thy algebra (Sign.const_typargs thy (c, ty)) (map snd vs)
64.103 - | NONE => I;
64.104 - val tab = fold meets cs Vartab.empty;
64.105 - in map (Code_Unit.inst_thm thy tab) thms end;
64.106 -
64.107 -fun resort_eqnss thy algebra funcgr =
64.108 - let
64.109 - val typ_funcgr = try (fst o Graph.get_node funcgr);
64.110 - val resort_dep = (apsnd o burrow_fst) (resort_thms thy algebra typ_funcgr);
64.111 - fun resort_rec typ_of (c, []) = (true, (c, []))
64.112 - | resort_rec typ_of (c, thms as (thm, _) :: _) = if is_some (AxClass.inst_of_param thy c)
64.113 - then (true, (c, thms))
64.114 - else let
64.115 - val (_, (vs, ty)) = Code_Unit.head_eqn thy thm;
64.116 - val thms' as (thm', _) :: _ = burrow_fst (resort_thms thy algebra typ_of) thms
64.117 - val (_, (vs', ty')) = Code_Unit.head_eqn thy thm'; (*FIXME simplify check*)
64.118 - in (Sign.typ_equiv thy (ty, ty'), (c, thms')) end;
64.119 - fun resort_recs eqnss =
64.120 - let
64.121 - fun typ_of c = case these (AList.lookup (op =) eqnss c)
64.122 - of (thm, _) :: _ => (SOME o snd o Code_Unit.head_eqn thy) thm
64.123 - | [] => NONE;
64.124 - val (unchangeds, eqnss') = split_list (map (resort_rec typ_of) eqnss);
64.125 - val unchanged = fold (fn x => fn y => x andalso y) unchangeds true;
64.126 - in (unchanged, eqnss') end;
64.127 - fun resort_rec_until eqnss =
64.128 - let
64.129 - val (unchanged, eqnss') = resort_recs eqnss;
64.130 - in if unchanged then eqnss' else resort_rec_until eqnss' end;
64.131 - in map resort_dep #> resort_rec_until end;
64.132 -
64.133 -fun instances_of thy algebra insts =
64.134 - let
64.135 - val thy_classes = (#classes o Sorts.rep_algebra o Sign.classes_of) thy;
64.136 - fun all_classparams tyco class =
64.137 - these (try (#params o AxClass.get_info thy) class)
64.138 - |> map_filter (fn (c, _) => try (AxClass.param_of_inst thy) (c, tyco))
64.139 - in
64.140 - Symtab.empty
64.141 - |> fold (fn (tyco, class) =>
64.142 - Symtab.map_default (tyco, []) (insert (op =) class)) insts
64.143 - |> (fn tab => Symtab.fold (fn (tyco, classes) => append (maps (all_classparams tyco)
64.144 - (Graph.all_succs thy_classes classes))) tab [])
64.145 - end;
64.146 -
64.147 -fun instances_of_consts thy algebra funcgr consts =
64.148 - let
64.149 - fun inst (cexpr as (c, ty)) = insts_of thy algebra
64.150 - (Sign.const_typargs thy (c, ty)) ((map snd o fst) (typ funcgr c));
64.151 - in
64.152 - []
64.153 - |> fold (fold (insert (op =)) o inst) consts
64.154 - |> instances_of thy algebra
64.155 - end;
64.156 -
64.157 -fun ensure_const' thy algebra funcgr const auxgr =
64.158 - if can (Graph.get_node funcgr) const
64.159 - then (NONE, auxgr)
64.160 - else if can (Graph.get_node auxgr) const
64.161 - then (SOME const, auxgr)
64.162 - else if is_some (Code.get_datatype_of_constr thy const) then
64.163 - auxgr
64.164 - |> Graph.new_node (const, [])
64.165 - |> pair (SOME const)
64.166 - else let
64.167 - val thms = Code.these_eqns thy const
64.168 - |> burrow_fst (Code_Unit.norm_args thy)
64.169 - |> burrow_fst (Code_Unit.norm_varnames thy Code_Name.purify_tvar Code_Name.purify_var);
64.170 - val rhs = consts_of (const, thms);
64.171 - in
64.172 - auxgr
64.173 - |> Graph.new_node (const, thms)
64.174 - |> fold_map (ensure_const thy algebra funcgr) rhs
64.175 - |-> (fn rhs' => fold (fn SOME const' => Graph.add_edge (const, const')
64.176 - | NONE => I) rhs')
64.177 - |> pair (SOME const)
64.178 - end
64.179 -and ensure_const thy algebra funcgr const =
64.180 - let
64.181 - val timeap = if !timing
64.182 - then Output.timeap_msg ("time for " ^ Code_Unit.string_of_const thy const)
64.183 - else I;
64.184 - in timeap (ensure_const' thy algebra funcgr const) end;
64.185 -
64.186 -fun merge_eqnss thy algebra raw_eqnss funcgr =
64.187 - let
64.188 - val eqnss = raw_eqnss
64.189 - |> resort_eqnss thy algebra funcgr
64.190 - |> filter_out (can (Graph.get_node funcgr) o fst);
64.191 - fun typ_eqn c [] = Code.default_typscheme thy c
64.192 - | typ_eqn c (thms as (thm, _) :: _) = (snd o Code_Unit.head_eqn thy) thm;
64.193 - fun add_eqns (const, thms) =
64.194 - Graph.new_node (const, (typ_eqn const thms, thms));
64.195 - fun add_deps (eqns as (const, thms)) funcgr =
64.196 - let
64.197 - val deps = consts_of eqns;
64.198 - val insts = instances_of_consts thy algebra funcgr
64.199 - (fold_consts (insert (op =)) (map fst thms) []);
64.200 - in
64.201 - funcgr
64.202 - |> ensure_consts thy algebra insts
64.203 - |> fold (curry Graph.add_edge const) deps
64.204 - |> fold (curry Graph.add_edge const) insts
64.205 - end;
64.206 - in
64.207 - funcgr
64.208 - |> fold add_eqns eqnss
64.209 - |> fold add_deps eqnss
64.210 - end
64.211 -and ensure_consts thy algebra cs funcgr =
64.212 - let
64.213 - val auxgr = Graph.empty
64.214 - |> fold (snd oo ensure_const thy algebra funcgr) cs;
64.215 - in
64.216 - funcgr
64.217 - |> fold (merge_eqnss thy algebra)
64.218 - (map (AList.make (Graph.get_node auxgr))
64.219 - (rev (Graph.strong_conn auxgr)))
64.220 - end;
64.221 -
64.222 -in
64.223 -
64.224 -(** retrieval interfaces **)
64.225 -
64.226 -val ensure_consts = ensure_consts;
64.227 -
64.228 -fun proto_eval thy cterm_of evaluator_lift evaluator proto_ct funcgr =
64.229 - let
64.230 - val ct = cterm_of proto_ct;
64.231 - val _ = Sign.no_vars (Syntax.pp_global thy) (Thm.term_of ct);
64.232 - val _ = Term.fold_types (Type.no_tvars #> K I) (Thm.term_of ct) ();
64.233 - fun consts_of t =
64.234 - fold_aterms (fn Const c_ty => cons c_ty | _ => I) t [];
64.235 - val algebra = Code.coregular_algebra thy;
64.236 - val thm = Code.preprocess_conv thy ct;
64.237 - val ct' = Thm.rhs_of thm;
64.238 - val t' = Thm.term_of ct';
64.239 - val consts = map fst (consts_of t');
64.240 - val funcgr' = ensure_consts thy algebra consts funcgr;
64.241 - val (t'', evaluator_funcgr) = evaluator t';
64.242 - val consts' = consts_of t'';
64.243 - val dicts = instances_of_consts thy algebra funcgr' consts';
64.244 - val funcgr'' = ensure_consts thy algebra dicts funcgr';
64.245 - in (evaluator_lift (evaluator_funcgr (Code.operational_algebra thy)) thm funcgr'', funcgr'') end;
64.246 -
64.247 -fun proto_eval_conv thy =
64.248 - let
64.249 - fun evaluator_lift evaluator thm1 funcgr =
64.250 - let
64.251 - val thm2 = evaluator funcgr;
64.252 - val thm3 = Code.postprocess_conv thy (Thm.rhs_of thm2);
64.253 - in
64.254 - Thm.transitive thm1 (Thm.transitive thm2 thm3) handle THM _ =>
64.255 - error ("could not construct evaluation proof:\n"
64.256 - ^ (cat_lines o map Display.string_of_thm) [thm1, thm2, thm3])
64.257 - end;
64.258 - in proto_eval thy I evaluator_lift end;
64.259 -
64.260 -fun proto_eval_term thy =
64.261 - let
64.262 - fun evaluator_lift evaluator _ funcgr = evaluator funcgr;
64.263 - in proto_eval thy (Thm.cterm_of thy) evaluator_lift end;
64.264 -
64.265 -end; (*local*)
64.266 -
64.267 -structure Funcgr = CodeDataFun
64.268 -(
64.269 - type T = T;
64.270 - val empty = Graph.empty;
64.271 - fun purge _ cs funcgr =
64.272 - Graph.del_nodes ((Graph.all_preds funcgr
64.273 - o filter (can (Graph.get_node funcgr))) cs) funcgr;
64.274 -);
64.275 -
64.276 -fun make thy =
64.277 - pair (Code.operational_algebra thy)
64.278 - o Funcgr.change thy o ensure_consts thy (Code.coregular_algebra thy);
64.279 -
64.280 -fun eval_conv thy f =
64.281 - fst o Funcgr.change_yield thy o proto_eval_conv thy f;
64.282 -
64.283 -fun eval_term thy f =
64.284 - fst o Funcgr.change_yield thy o proto_eval_term thy f;
64.285 -
64.286 -
64.287 -(** diagnostic commands **)
64.288 -
64.289 -fun code_depgr thy consts =
64.290 - let
64.291 - val (_, gr) = make thy consts;
64.292 - val select = Graph.all_succs gr consts;
64.293 - in
64.294 - gr
64.295 - |> not (null consts) ? Graph.subgraph (member (op =) select)
64.296 - |> Graph.map_nodes ((apsnd o map o apfst) (AxClass.overload thy))
64.297 - end;
64.298 -
64.299 -fun code_thms thy = Pretty.writeln o pretty thy o code_depgr thy;
64.300 -
64.301 -fun code_deps thy consts =
64.302 - let
64.303 - val gr = code_depgr thy consts;
64.304 - fun mk_entry (const, (_, (_, parents))) =
64.305 - let
64.306 - val name = Code_Unit.string_of_const thy const;
64.307 - val nameparents = map (Code_Unit.string_of_const thy) parents;
64.308 - in { name = name, ID = name, dir = "", unfold = true,
64.309 - path = "", parents = nameparents }
64.310 - end;
64.311 - val prgr = Graph.fold ((fn x => fn xs => xs @ [x]) o mk_entry) gr [];
64.312 - in Present.display_graph prgr end;
64.313 -
64.314 -local
64.315 -
64.316 -structure P = OuterParse
64.317 -and K = OuterKeyword
64.318 -
64.319 -fun code_thms_cmd thy = code_thms thy o op @ o Code_Name.read_const_exprs thy;
64.320 -fun code_deps_cmd thy = code_deps thy o op @ o Code_Name.read_const_exprs thy;
64.321 -
64.322 -in
64.323 -
64.324 -val _ =
64.325 - OuterSyntax.improper_command "code_thms" "print system of code equations for code" OuterKeyword.diag
64.326 - (Scan.repeat P.term_group
64.327 - >> (fn cs => Toplevel.no_timing o Toplevel.unknown_theory
64.328 - o Toplevel.keep ((fn thy => code_thms_cmd thy cs) o Toplevel.theory_of)));
64.329 -
64.330 -val _ =
64.331 - OuterSyntax.improper_command "code_deps" "visualize dependencies of code equations for code" OuterKeyword.diag
64.332 - (Scan.repeat P.term_group
64.333 - >> (fn cs => Toplevel.no_timing o Toplevel.unknown_theory
64.334 - o Toplevel.keep ((fn thy => code_deps_cmd thy cs) o Toplevel.theory_of)));
64.335 -
64.336 -end;
64.337 -
64.338 -end; (*struct*)
65.1 --- a/src/Tools/code/code_ml.ML Mon Apr 20 12:27:23 2009 +0200
65.2 +++ b/src/Tools/code/code_ml.ML Mon Apr 20 16:28:13 2009 +0200
65.3 @@ -6,8 +6,11 @@
65.4
65.5 signature CODE_ML =
65.6 sig
65.7 - val eval_term: string * (unit -> 'a) option ref
65.8 + val eval_term: string option -> string * (unit -> term) option ref
65.9 + -> theory -> term -> string list -> term
65.10 + val eval: string option -> string * (unit -> 'a) option ref
65.11 -> theory -> term -> string list -> 'a
65.12 + val target_Eval: string
65.13 val setup: theory -> theory
65.14 end;
65.15
65.16 @@ -22,6 +25,7 @@
65.17
65.18 val target_SML = "SML";
65.19 val target_OCaml = "OCaml";
65.20 +val target_Eval = "Eval";
65.21
65.22 datatype ml_stmt =
65.23 MLExc of string * int
65.24 @@ -944,20 +948,20 @@
65.25
65.26 (** ML (system language) code for evaluation and instrumentalization **)
65.27
65.28 -fun ml_code_of thy = Code_Target.serialize_custom thy (target_SML,
65.29 +fun eval_code_of some_target thy = Code_Target.serialize_custom thy (the_default target_Eval some_target,
65.30 (fn _ => fn [] => serialize_ml target_SML (SOME (K ())) (K Pretty.chunks) pr_sml_stmt (SOME ""),
65.31 literals_sml));
65.32
65.33
65.34 (* evaluation *)
65.35
65.36 -fun eval eval'' term_of reff thy ct args =
65.37 +fun gen_eval eval some_target reff thy t args =
65.38 let
65.39 val ctxt = ProofContext.init thy;
65.40 - val _ = if null (Term.add_frees (term_of ct) []) then () else error ("Term "
65.41 - ^ quote (Syntax.string_of_term_global thy (term_of ct))
65.42 + val _ = if null (Term.add_frees t []) then () else error ("Term "
65.43 + ^ quote (Syntax.string_of_term_global thy t)
65.44 ^ " to be evaluated contains free variables");
65.45 - fun eval' naming program ((vs, ty), t) deps =
65.46 + fun evaluator naming program (((_, (_, ty)), _), t) deps =
65.47 let
65.48 val _ = if Code_Thingol.contains_dictvar t then
65.49 error "Term to be evaluated contains free dictionaries" else ();
65.50 @@ -966,13 +970,14 @@
65.51 |> Graph.new_node (value_name,
65.52 Code_Thingol.Fun (Term.dummy_patternN, (([], ty), [(([], t), (Drule.dummy_thm, true))])))
65.53 |> fold (curry Graph.add_edge value_name) deps;
65.54 - val (value_code, [SOME value_name']) = ml_code_of thy naming program' [value_name];
65.55 + val (value_code, [SOME value_name']) = eval_code_of some_target thy naming program' [value_name];
65.56 val sml_code = "let\n" ^ value_code ^ "\nin " ^ value_name'
65.57 ^ space_implode " " (map (enclose "(" ")") args) ^ " end";
65.58 in ML_Context.evaluate ctxt false reff sml_code end;
65.59 - in eval'' thy (rpair eval') ct end;
65.60 + in eval thy I evaluator t end;
65.61
65.62 -fun eval_term reff = eval Code_Thingol.eval_term I reff;
65.63 +fun eval_term thy = gen_eval Code_Thingol.eval_term thy;
65.64 +fun eval thy = gen_eval Code_Thingol.eval thy;
65.65
65.66
65.67 (* instrumentalization by antiquotation *)
65.68 @@ -990,7 +995,7 @@
65.69 fun delayed_code thy consts () =
65.70 let
65.71 val (consts', (naming, program)) = Code_Thingol.consts_program thy consts;
65.72 - val (ml_code, consts'') = ml_code_of thy naming program consts';
65.73 + val (ml_code, consts'') = eval_code_of NONE thy naming program consts';
65.74 val const_tab = map2 (fn const => fn NONE =>
65.75 error ("Constant " ^ (quote o Code_Unit.string_of_const thy) const
65.76 ^ "\nhas a user-defined serialization")
65.77 @@ -1048,6 +1053,7 @@
65.78 val setup =
65.79 Code_Target.add_target (target_SML, (isar_seri_sml, literals_sml))
65.80 #> Code_Target.add_target (target_OCaml, (isar_seri_ocaml, literals_ocaml))
65.81 + #> Code_Target.extend_target (target_Eval, (target_SML, K I))
65.82 #> Code_Target.add_syntax_tyco target_SML "fun" (SOME (2, fn pr_typ => fn fxy => fn [ty1, ty2] =>
65.83 brackify_infix (1, R) fxy [
65.84 pr_typ (INFX (1, X)) ty1,
66.1 --- a/src/Tools/code/code_thingol.ML Mon Apr 20 12:27:23 2009 +0200
66.2 +++ b/src/Tools/code/code_thingol.ML Mon Apr 20 16:28:13 2009 +0200
66.3 @@ -83,11 +83,14 @@
66.4
66.5 val consts_program: theory -> string list -> string list * (naming * program)
66.6 val cached_program: theory -> naming * program
66.7 - val eval_conv: theory
66.8 - -> (term -> term * (naming -> program -> typscheme * iterm -> string list -> thm))
66.9 + val eval_conv: theory -> (sort -> sort)
66.10 + -> (naming -> program -> (((string * sort) list * typscheme) * (string * itype) list) * iterm -> string list -> cterm -> thm)
66.11 -> cterm -> thm
66.12 - val eval_term: theory
66.13 - -> (term -> term * (naming -> program -> typscheme * iterm -> string list -> 'a))
66.14 + val eval_term: theory -> (sort -> sort)
66.15 + -> (naming -> program -> (((string * sort) list * typscheme) * (string * itype) list) * iterm -> string list -> term)
66.16 + -> term -> term
66.17 + val eval: theory -> (sort -> sort)
66.18 + -> (naming -> program -> (((string * sort) list * typscheme) * (string * itype) list) * iterm -> string list -> 'a)
66.19 -> term -> 'a
66.20 end;
66.21
66.22 @@ -459,7 +462,45 @@
66.23
66.24 (* translation *)
66.25
66.26 -fun ensure_class thy (algbr as (_, algebra)) funcgr class =
66.27 +fun ensure_tyco thy algbr funcgr tyco =
66.28 + let
66.29 + val stmt_datatype =
66.30 + let
66.31 + val (vs, cos) = Code.get_datatype thy tyco;
66.32 + in
66.33 + fold_map (translate_tyvar_sort thy algbr funcgr) vs
66.34 + ##>> fold_map (fn (c, tys) =>
66.35 + ensure_const thy algbr funcgr c
66.36 + ##>> fold_map (translate_typ thy algbr funcgr) tys) cos
66.37 + #>> (fn info => Datatype (tyco, info))
66.38 + end;
66.39 + in ensure_stmt lookup_tyco (declare_tyco thy) stmt_datatype tyco end
66.40 +and ensure_const thy algbr funcgr c =
66.41 + let
66.42 + fun stmt_datatypecons tyco =
66.43 + ensure_tyco thy algbr funcgr tyco
66.44 + #>> (fn tyco => Datatypecons (c, tyco));
66.45 + fun stmt_classparam class =
66.46 + ensure_class thy algbr funcgr class
66.47 + #>> (fn class => Classparam (c, class));
66.48 + fun stmt_fun ((vs, ty), raw_thms) =
66.49 + let
66.50 + val thms = if null (Term.add_tfreesT ty []) orelse (null o fst o strip_type) ty
66.51 + then raw_thms
66.52 + else (map o apfst) (Code_Unit.expand_eta thy 1) raw_thms;
66.53 + in
66.54 + fold_map (translate_tyvar_sort thy algbr funcgr) vs
66.55 + ##>> translate_typ thy algbr funcgr ty
66.56 + ##>> fold_map (translate_eq thy algbr funcgr) thms
66.57 + #>> (fn info => Fun (c, info))
66.58 + end;
66.59 + val stmt_const = case Code.get_datatype_of_constr thy c
66.60 + of SOME tyco => stmt_datatypecons tyco
66.61 + | NONE => (case AxClass.class_of_param thy c
66.62 + of SOME class => stmt_classparam class
66.63 + | NONE => stmt_fun (Code_Wellsorted.typ funcgr c, Code_Wellsorted.eqns funcgr c))
66.64 + in ensure_stmt lookup_const (declare_const thy) stmt_const c end
66.65 +and ensure_class thy (algbr as (_, algebra)) funcgr class =
66.66 let
66.67 val superclasses = (Sorts.minimize_sort algebra o Sorts.super_classes algebra) class;
66.68 val cs = #params (AxClass.get_info thy class);
66.69 @@ -477,65 +518,6 @@
66.70 ##>> ensure_class thy algbr funcgr superclass
66.71 #>> Classrel;
66.72 in ensure_stmt lookup_classrel (declare_classrel thy) stmt_classrel (subclass, superclass) end
66.73 -and ensure_tyco thy algbr funcgr tyco =
66.74 - let
66.75 - val stmt_datatype =
66.76 - let
66.77 - val (vs, cos) = Code.get_datatype thy tyco;
66.78 - in
66.79 - fold_map (translate_tyvar_sort thy algbr funcgr) vs
66.80 - ##>> fold_map (fn (c, tys) =>
66.81 - ensure_const thy algbr funcgr c
66.82 - ##>> fold_map (translate_typ thy algbr funcgr) tys) cos
66.83 - #>> (fn info => Datatype (tyco, info))
66.84 - end;
66.85 - in ensure_stmt lookup_tyco (declare_tyco thy) stmt_datatype tyco end
66.86 -and translate_tyvar_sort thy (algbr as (proj_sort, _)) funcgr (v, sort) =
66.87 - fold_map (ensure_class thy algbr funcgr) (proj_sort sort)
66.88 - #>> (fn sort => (unprefix "'" v, sort))
66.89 -and translate_typ thy algbr funcgr (TFree (v, _)) =
66.90 - pair (ITyVar (unprefix "'" v))
66.91 - | translate_typ thy algbr funcgr (Type (tyco, tys)) =
66.92 - ensure_tyco thy algbr funcgr tyco
66.93 - ##>> fold_map (translate_typ thy algbr funcgr) tys
66.94 - #>> (fn (tyco, tys) => tyco `%% tys)
66.95 -and translate_dicts thy (algbr as (proj_sort, algebra)) funcgr thm (ty, sort) =
66.96 - let
66.97 - val pp = Syntax.pp_global thy;
66.98 - datatype typarg =
66.99 - Global of (class * string) * typarg list list
66.100 - | Local of (class * class) list * (string * (int * sort));
66.101 - fun class_relation (Global ((_, tyco), yss), _) class =
66.102 - Global ((class, tyco), yss)
66.103 - | class_relation (Local (classrels, v), subclass) superclass =
66.104 - Local ((subclass, superclass) :: classrels, v);
66.105 - fun type_constructor tyco yss class =
66.106 - Global ((class, tyco), (map o map) fst yss);
66.107 - fun type_variable (TFree (v, sort)) =
66.108 - let
66.109 - val sort' = proj_sort sort;
66.110 - in map_index (fn (n, class) => (Local ([], (v, (n, sort'))), class)) sort' end;
66.111 - val typargs = Sorts.of_sort_derivation pp algebra
66.112 - {class_relation = class_relation, type_constructor = type_constructor,
66.113 - type_variable = type_variable} (ty, proj_sort sort)
66.114 - handle Sorts.CLASS_ERROR e => not_wellsorted thy thm ty sort e;
66.115 - fun mk_dict (Global (inst, yss)) =
66.116 - ensure_inst thy algbr funcgr inst
66.117 - ##>> (fold_map o fold_map) mk_dict yss
66.118 - #>> (fn (inst, dss) => DictConst (inst, dss))
66.119 - | mk_dict (Local (classrels, (v, (k, sort)))) =
66.120 - fold_map (ensure_classrel thy algbr funcgr) classrels
66.121 - #>> (fn classrels => DictVar (classrels, (unprefix "'" v, (k, length sort))))
66.122 - in fold_map mk_dict typargs end
66.123 -and translate_eq thy algbr funcgr (thm, linear) =
66.124 - let
66.125 - val (args, rhs) = (apfst (snd o strip_comb) o Logic.dest_equals
66.126 - o Logic.unvarify o prop_of) thm;
66.127 - in
66.128 - fold_map (translate_term thy algbr funcgr (SOME thm)) args
66.129 - ##>> translate_term thy algbr funcgr (SOME thm) rhs
66.130 - #>> rpair (thm, linear)
66.131 - end
66.132 and ensure_inst thy (algbr as (_, algebra)) funcgr (class, tyco) =
66.133 let
66.134 val superclasses = (Sorts.minimize_sort algebra o Sorts.super_classes algebra) class;
66.135 @@ -572,31 +554,12 @@
66.136 #>> (fn ((((class, tyco), arity), superarities), classparams) =>
66.137 Classinst ((class, (tyco, arity)), (superarities, classparams)));
66.138 in ensure_stmt lookup_instance (declare_instance thy) stmt_inst (class, tyco) end
66.139 -and ensure_const thy algbr funcgr c =
66.140 - let
66.141 - fun stmt_datatypecons tyco =
66.142 +and translate_typ thy algbr funcgr (TFree (v, _)) =
66.143 + pair (ITyVar (unprefix "'" v))
66.144 + | translate_typ thy algbr funcgr (Type (tyco, tys)) =
66.145 ensure_tyco thy algbr funcgr tyco
66.146 - #>> (fn tyco => Datatypecons (c, tyco));
66.147 - fun stmt_classparam class =
66.148 - ensure_class thy algbr funcgr class
66.149 - #>> (fn class => Classparam (c, class));
66.150 - fun stmt_fun ((vs, ty), raw_thms) =
66.151 - let
66.152 - val thms = if null (Term.add_tfreesT ty []) orelse (null o fst o strip_type) ty
66.153 - then raw_thms
66.154 - else (map o apfst) (Code_Unit.expand_eta thy 1) raw_thms;
66.155 - in
66.156 - fold_map (translate_tyvar_sort thy algbr funcgr) vs
66.157 - ##>> translate_typ thy algbr funcgr ty
66.158 - ##>> fold_map (translate_eq thy algbr funcgr) thms
66.159 - #>> (fn info => Fun (c, info))
66.160 - end;
66.161 - val stmt_const = case Code.get_datatype_of_constr thy c
66.162 - of SOME tyco => stmt_datatypecons tyco
66.163 - | NONE => (case AxClass.class_of_param thy c
66.164 - of SOME class => stmt_classparam class
66.165 - | NONE => stmt_fun (Code_Wellsorted.typ funcgr c, Code_Wellsorted.eqns funcgr c))
66.166 - in ensure_stmt lookup_const (declare_const thy) stmt_const c end
66.167 + ##>> fold_map (translate_typ thy algbr funcgr) tys
66.168 + #>> (fn (tyco, tys) => tyco `%% tys)
66.169 and translate_term thy algbr funcgr thm (Const (c, ty)) =
66.170 translate_app thy algbr funcgr thm ((c, ty), [])
66.171 | translate_term thy algbr funcgr thm (Free (v, _)) =
66.172 @@ -617,6 +580,15 @@
66.173 translate_term thy algbr funcgr thm t'
66.174 ##>> fold_map (translate_term thy algbr funcgr thm) ts
66.175 #>> (fn (t, ts) => t `$$ ts)
66.176 +and translate_eq thy algbr funcgr (thm, linear) =
66.177 + let
66.178 + val (args, rhs) = (apfst (snd o strip_comb) o Logic.dest_equals
66.179 + o Logic.unvarify o prop_of) thm;
66.180 + in
66.181 + fold_map (translate_term thy algbr funcgr (SOME thm)) args
66.182 + ##>> translate_term thy algbr funcgr (SOME thm) rhs
66.183 + #>> rpair (thm, linear)
66.184 + end
66.185 and translate_const thy algbr funcgr thm (c, ty) =
66.186 let
66.187 val tys = Sign.const_typargs thy (c, ty);
66.188 @@ -695,7 +667,38 @@
66.189 and translate_app thy algbr funcgr thm (c_ty_ts as ((c, _), _)) =
66.190 case Code.get_case_scheme thy c
66.191 of SOME case_scheme => translate_app_case thy algbr funcgr thm case_scheme c_ty_ts
66.192 - | NONE => translate_app_const thy algbr funcgr thm c_ty_ts;
66.193 + | NONE => translate_app_const thy algbr funcgr thm c_ty_ts
66.194 +and translate_tyvar_sort thy (algbr as (proj_sort, _)) funcgr (v, sort) =
66.195 + fold_map (ensure_class thy algbr funcgr) (proj_sort sort)
66.196 + #>> (fn sort => (unprefix "'" v, sort))
66.197 +and translate_dicts thy (algbr as (proj_sort, algebra)) funcgr thm (ty, sort) =
66.198 + let
66.199 + val pp = Syntax.pp_global thy;
66.200 + datatype typarg =
66.201 + Global of (class * string) * typarg list list
66.202 + | Local of (class * class) list * (string * (int * sort));
66.203 + fun class_relation (Global ((_, tyco), yss), _) class =
66.204 + Global ((class, tyco), yss)
66.205 + | class_relation (Local (classrels, v), subclass) superclass =
66.206 + Local ((subclass, superclass) :: classrels, v);
66.207 + fun type_constructor tyco yss class =
66.208 + Global ((class, tyco), (map o map) fst yss);
66.209 + fun type_variable (TFree (v, sort)) =
66.210 + let
66.211 + val sort' = proj_sort sort;
66.212 + in map_index (fn (n, class) => (Local ([], (v, (n, sort'))), class)) sort' end;
66.213 + val typargs = Sorts.of_sort_derivation pp algebra
66.214 + {class_relation = class_relation, type_constructor = type_constructor,
66.215 + type_variable = type_variable} (ty, proj_sort sort)
66.216 + handle Sorts.CLASS_ERROR e => not_wellsorted thy thm ty sort e;
66.217 + fun mk_dict (Global (inst, yss)) =
66.218 + ensure_inst thy algbr funcgr inst
66.219 + ##>> (fold_map o fold_map) mk_dict yss
66.220 + #>> (fn (inst, dss) => DictConst (inst, dss))
66.221 + | mk_dict (Local (classrels, (v, (k, sort)))) =
66.222 + fold_map (ensure_classrel thy algbr funcgr) classrels
66.223 + #>> (fn classrels => DictVar (classrels, (unprefix "'" v, (k, length sort))))
66.224 + in fold_map mk_dict typargs end;
66.225
66.226
66.227 (* store *)
66.228 @@ -733,14 +736,14 @@
66.229 fun generate_consts thy algebra funcgr =
66.230 fold_map (ensure_const thy algebra funcgr);
66.231 in
66.232 - invoke_generation thy (Code_Wellsorted.make thy cs) generate_consts cs
66.233 + invoke_generation thy (Code_Wellsorted.obtain thy cs []) generate_consts cs
66.234 |-> project_consts
66.235 end;
66.236
66.237
66.238 (* value evaluation *)
66.239
66.240 -fun ensure_value thy algbr funcgr t =
66.241 +fun ensure_value thy algbr funcgr (fs, t) =
66.242 let
66.243 val ty = fastype_of t;
66.244 val vs = fold_term_types (K (fold_atyps (insert (eq_fst op =)
66.245 @@ -751,33 +754,92 @@
66.246 ##>> translate_term thy algbr funcgr NONE t
66.247 #>> (fn ((vs, ty), t) => Fun
66.248 (Term.dummy_patternN, ((vs, ty), [(([], t), (Drule.dummy_thm, true))])));
66.249 - fun term_value (dep, (naming, program1)) =
66.250 + fun term_value fs (dep, (naming, program1)) =
66.251 let
66.252 - val Fun (_, ((vs, ty), [(([], t), _)])) =
66.253 + val Fun (_, (vs_ty, [(([], t), _)])) =
66.254 Graph.get_node program1 Term.dummy_patternN;
66.255 val deps = Graph.imm_succs program1 Term.dummy_patternN;
66.256 val program2 = Graph.del_nodes [Term.dummy_patternN] program1;
66.257 val deps_all = Graph.all_succs program2 deps;
66.258 val program3 = Graph.subgraph (member (op =) deps_all) program2;
66.259 - in (((naming, program3), (((vs, ty), t), deps)), (dep, (naming, program2))) end;
66.260 + in (((naming, program3), (((vs_ty, fs), t), deps)), (dep, (naming, program2))) end;
66.261 in
66.262 ensure_stmt ((K o K) NONE) pair stmt_value Term.dummy_patternN
66.263 #> snd
66.264 - #> term_value
66.265 + #> fold_map (fn (v, ty) => translate_typ thy algbr funcgr ty
66.266 + #-> (fn ty' => pair (v, ty'))) fs
66.267 + #-> (fn fs' => term_value fs')
66.268 end;
66.269
66.270 -fun eval thy evaluator t =
66.271 +fun base_evaluator thy evaluator algebra funcgr vs t =
66.272 let
66.273 - val (t', evaluator'') = evaluator t;
66.274 - fun evaluator' algebra funcgr =
66.275 - let
66.276 - val (((naming, program), (vs_ty_t, deps)), _) =
66.277 - invoke_generation thy (algebra, funcgr) ensure_value t';
66.278 - in evaluator'' naming program vs_ty_t deps end;
66.279 - in (t', evaluator') end
66.280 + val fs = Term.add_frees t [];
66.281 + val (((naming, program), ((((vs', ty'), fs'), t'), deps)), _) =
66.282 + invoke_generation thy (algebra, funcgr) ensure_value (fs, t);
66.283 + val vs'' = map (fn (v, _) => (v, (the o AList.lookup (op =) vs o prefix "'") v)) vs';
66.284 + in evaluator naming program (((vs'', (vs', ty')), fs'), t') deps end;
66.285
66.286 -fun eval_conv thy = Code_Wellsorted.eval_conv thy o eval thy;
66.287 -fun eval_term thy = Code_Wellsorted.eval_term thy o eval thy;
66.288 +fun eval_conv thy prep_sort = Code_Wellsorted.eval_conv thy prep_sort o base_evaluator thy;
66.289 +fun eval_term thy prep_sort = Code_Wellsorted.eval_term thy prep_sort o base_evaluator thy;
66.290 +fun eval thy prep_sort = Code_Wellsorted.eval thy prep_sort o base_evaluator thy;
66.291 +
66.292 +
66.293 +(** diagnostic commands **)
66.294 +
66.295 +fun code_depgr thy consts =
66.296 + let
66.297 + val (_, eqngr) = Code_Wellsorted.obtain thy consts [];
66.298 + val select = Graph.all_succs eqngr consts;
66.299 + in
66.300 + eqngr
66.301 + |> not (null consts) ? Graph.subgraph (member (op =) select)
66.302 + |> Graph.map_nodes ((apsnd o map o apfst) (AxClass.overload thy))
66.303 + end;
66.304 +
66.305 +fun code_thms thy = Pretty.writeln o Code_Wellsorted.pretty thy o code_depgr thy;
66.306 +
66.307 +fun code_deps thy consts =
66.308 + let
66.309 + val eqngr = code_depgr thy consts;
66.310 + val constss = Graph.strong_conn eqngr;
66.311 + val mapping = Symtab.empty |> fold (fn consts => fold (fn const =>
66.312 + Symtab.update (const, consts)) consts) constss;
66.313 + fun succs consts = consts
66.314 + |> maps (Graph.imm_succs eqngr)
66.315 + |> subtract (op =) consts
66.316 + |> map (the o Symtab.lookup mapping)
66.317 + |> distinct (op =);
66.318 + val conn = [] |> fold (fn consts => cons (consts, succs consts)) constss;
66.319 + fun namify consts = map (Code_Unit.string_of_const thy) consts
66.320 + |> commas;
66.321 + val prgr = map (fn (consts, constss) =>
66.322 + { name = namify consts, ID = namify consts, dir = "", unfold = true,
66.323 + path = "", parents = map namify constss }) conn;
66.324 + in Present.display_graph prgr end;
66.325 +
66.326 +local
66.327 +
66.328 +structure P = OuterParse
66.329 +and K = OuterKeyword
66.330 +
66.331 +fun code_thms_cmd thy = code_thms thy o op @ o Code_Name.read_const_exprs thy;
66.332 +fun code_deps_cmd thy = code_deps thy o op @ o Code_Name.read_const_exprs thy;
66.333 +
66.334 +in
66.335 +
66.336 +val _ =
66.337 + OuterSyntax.improper_command "code_thms" "print system of code equations for code" OuterKeyword.diag
66.338 + (Scan.repeat P.term_group
66.339 + >> (fn cs => Toplevel.no_timing o Toplevel.unknown_theory
66.340 + o Toplevel.keep ((fn thy => code_thms_cmd thy cs) o Toplevel.theory_of)));
66.341 +
66.342 +val _ =
66.343 + OuterSyntax.improper_command "code_deps" "visualize dependencies of code equations for code" OuterKeyword.diag
66.344 + (Scan.repeat P.term_group
66.345 + >> (fn cs => Toplevel.no_timing o Toplevel.unknown_theory
66.346 + o Toplevel.keep ((fn thy => code_deps_cmd thy cs) o Toplevel.theory_of)));
66.347 +
66.348 +end;
66.349
66.350 end; (*struct*)
66.351
67.1 --- a/src/Tools/code/code_wellsorted.ML Mon Apr 20 12:27:23 2009 +0200
67.2 +++ b/src/Tools/code/code_wellsorted.ML Mon Apr 20 16:28:13 2009 +0200
67.3 @@ -7,25 +7,28 @@
67.4
67.5 signature CODE_WELLSORTED =
67.6 sig
67.7 - type T
67.8 - val eqns: T -> string -> (thm * bool) list
67.9 - val typ: T -> string -> (string * sort) list * typ
67.10 - val all: T -> string list
67.11 - val pretty: theory -> T -> Pretty.T
67.12 - val make: theory -> string list
67.13 - -> ((sort -> sort) * Sorts.algebra) * T
67.14 - val eval_conv: theory
67.15 - -> (term -> term * (((sort -> sort) * Sorts.algebra) -> T -> thm)) -> cterm -> thm
67.16 - val eval_term: theory
67.17 - -> (term -> term * (((sort -> sort) * Sorts.algebra) -> T -> 'a)) -> term -> 'a
67.18 + type code_algebra
67.19 + type code_graph
67.20 + val eqns: code_graph -> string -> (thm * bool) list
67.21 + val typ: code_graph -> string -> (string * sort) list * typ
67.22 + val all: code_graph -> string list
67.23 + val pretty: theory -> code_graph -> Pretty.T
67.24 + val obtain: theory -> string list -> term list -> code_algebra * code_graph
67.25 + val eval_conv: theory -> (sort -> sort)
67.26 + -> (code_algebra -> code_graph -> (string * sort) list -> term -> cterm -> thm) -> cterm -> thm
67.27 + val eval_term: theory -> (sort -> sort)
67.28 + -> (code_algebra -> code_graph -> (string * sort) list -> term -> term) -> term -> term
67.29 + val eval: theory -> (sort -> sort)
67.30 + -> (code_algebra -> code_graph -> (string * sort) list -> term -> 'a) -> term -> 'a
67.31 end
67.32
67.33 structure Code_Wellsorted : CODE_WELLSORTED =
67.34 struct
67.35
67.36 -(** the equation graph type **)
67.37 +(** the algebra and code equation graph types **)
67.38
67.39 -type T = (((string * sort) list * typ) * (thm * bool) list) Graph.T;
67.40 +type code_algebra = (sort -> sort) * Sorts.algebra;
67.41 +type code_graph = (((string * sort) list * typ) * (thm * bool) list) Graph.T;
67.42
67.43 fun eqns eqngr = these o Option.map snd o try (Graph.get_node eqngr);
67.44 fun typ eqngr = fst o Graph.get_node eqngr;
67.45 @@ -47,8 +50,10 @@
67.46
67.47 (* auxiliary *)
67.48
67.49 +fun is_proper_class thy = can (AxClass.get_info thy);
67.50 +
67.51 fun complete_proper_sort thy =
67.52 - Sign.complete_sort thy #> filter (can (AxClass.get_info thy));
67.53 + Sign.complete_sort thy #> filter (is_proper_class thy);
67.54
67.55 fun inst_params thy tyco =
67.56 map (fn (c, _) => AxClass.param_of_inst thy (c, tyco))
67.57 @@ -232,8 +237,7 @@
67.58 ((class, tyco), map (fn k => (snd o Vargraph.get_node vardeps) (Inst (class, tyco), k))
67.59 (0 upto Sign.arity_number thy tyco - 1));
67.60
67.61 -fun add_eqs thy (proj_sort, algebra) vardeps
67.62 - (c, (proto_lhs, proto_eqns)) (rhss, eqngr) =
67.63 +fun add_eqs thy vardeps (c, (proto_lhs, proto_eqns)) (rhss, eqngr) =
67.64 if can (Graph.get_node eqngr) c then (rhss, eqngr)
67.65 else let
67.66 val lhs = map_index (fn (k, (v, _)) =>
67.67 @@ -246,72 +250,30 @@
67.68 val eqngr' = Graph.new_node (c, (tyscm, eqns)) eqngr;
67.69 in (map (pair c) rhss' @ rhss, eqngr') end;
67.70
67.71 -fun extend_arities_eqngr thy cs cs_rhss (arities, eqngr) =
67.72 +fun extend_arities_eqngr thy cs ts (arities, eqngr) =
67.73 let
67.74 - val cs_rhss' = (map o apsnd o map) (styp_of NONE) cs_rhss;
67.75 + val cs_rhss = (fold o fold_aterms) (fn Const (c_ty as (c, _)) =>
67.76 + insert (op =) (c, (map (styp_of NONE) o Sign.const_typargs thy) c_ty) | _ => I) ts [];
67.77 val (vardeps, (eqntab, insts)) = empty_vardeps_data
67.78 |> fold (assert_fun thy arities eqngr) cs
67.79 - |> fold (assert_rhs thy arities eqngr) cs_rhss';
67.80 + |> fold (assert_rhs thy arities eqngr) cs_rhss;
67.81 val arities' = fold (add_arity thy vardeps) insts arities;
67.82 val pp = Syntax.pp_global thy;
67.83 - val is_proper_class = can (AxClass.get_info thy);
67.84 - val (proj_sort, algebra) = Sorts.subalgebra pp is_proper_class
67.85 + val algebra = Sorts.subalgebra pp (is_proper_class thy)
67.86 (AList.lookup (op =) arities') (Sign.classes_of thy);
67.87 - val (rhss, eqngr') = Symtab.fold
67.88 - (add_eqs thy (proj_sort, algebra) vardeps) eqntab ([], eqngr);
67.89 - fun deps_of (c, rhs) = c ::
67.90 - maps (dicts_of thy (proj_sort, algebra))
67.91 - (rhs ~~ (map snd o fst o fst o Graph.get_node eqngr') c);
67.92 + val (rhss, eqngr') = Symtab.fold (add_eqs thy vardeps) eqntab ([], eqngr);
67.93 + fun deps_of (c, rhs) = c :: maps (dicts_of thy algebra)
67.94 + (rhs ~~ (map snd o fst o fst o Graph.get_node eqngr') c);
67.95 val eqngr'' = fold (fn (c, rhs) => fold
67.96 (curry Graph.add_edge c) (deps_of rhs)) rhss eqngr';
67.97 - in ((proj_sort, algebra), (arities', eqngr'')) end;
67.98 + in (algebra, (arities', eqngr'')) end;
67.99
67.100
67.101 -(** retrieval interfaces **)
67.102 -
67.103 -fun proto_eval thy cterm_of evaluator_lift evaluator proto_ct arities_eqngr =
67.104 - let
67.105 - val ct = cterm_of proto_ct;
67.106 - val _ = Sign.no_vars (Syntax.pp_global thy) (Thm.term_of ct);
67.107 - val _ = Term.fold_types (Type.no_tvars #> K I) (Thm.term_of ct) ();
67.108 - fun consts_of t =
67.109 - fold_aterms (fn Const c_ty => cons c_ty | _ => I) t [];
67.110 - val thm = Code.preprocess_conv thy ct;
67.111 - val ct' = Thm.rhs_of thm;
67.112 - val t' = Thm.term_of ct';
67.113 - val (t'', evaluator_eqngr) = evaluator t';
67.114 - val consts = map fst (consts_of t');
67.115 - val consts' = consts_of t'';
67.116 - val const_matches' = fold (fn (c, ty) =>
67.117 - insert (op =) (c, Sign.const_typargs thy (c, ty))) consts' [];
67.118 - val (algebra', arities_eqngr') =
67.119 - extend_arities_eqngr thy consts const_matches' arities_eqngr;
67.120 - in
67.121 - (evaluator_lift (evaluator_eqngr algebra') thm (snd arities_eqngr'),
67.122 - arities_eqngr')
67.123 - end;
67.124 -
67.125 -fun proto_eval_conv thy =
67.126 - let
67.127 - fun evaluator_lift evaluator thm1 eqngr =
67.128 - let
67.129 - val thm2 = evaluator eqngr;
67.130 - val thm3 = Code.postprocess_conv thy (Thm.rhs_of thm2);
67.131 - in
67.132 - Thm.transitive thm1 (Thm.transitive thm2 thm3) handle THM _ =>
67.133 - error ("could not construct evaluation proof:\n"
67.134 - ^ (cat_lines o map Display.string_of_thm) [thm1, thm2, thm3])
67.135 - end;
67.136 - in proto_eval thy I evaluator_lift end;
67.137 -
67.138 -fun proto_eval_term thy =
67.139 - let
67.140 - fun evaluator_lift evaluator _ eqngr = evaluator eqngr;
67.141 - in proto_eval thy (Thm.cterm_of thy) evaluator_lift end;
67.142 +(** store **)
67.143
67.144 structure Wellsorted = CodeDataFun
67.145 (
67.146 - type T = ((string * class) * sort list) list * T;
67.147 + type T = ((string * class) * sort list) list * code_graph;
67.148 val empty = ([], Graph.empty);
67.149 fun purge thy cs (arities, eqngr) =
67.150 let
67.151 @@ -327,71 +289,55 @@
67.152 in (arities', eqngr') end;
67.153 );
67.154
67.155 -fun make thy cs = apsnd snd
67.156 - (Wellsorted.change_yield thy (extend_arities_eqngr thy cs []));
67.157
67.158 -fun eval_conv thy f =
67.159 - fst o Wellsorted.change_yield thy o proto_eval_conv thy f;
67.160 +(** retrieval interfaces **)
67.161
67.162 -fun eval_term thy f =
67.163 - fst o Wellsorted.change_yield thy o proto_eval_term thy f;
67.164 +fun obtain thy cs ts = apsnd snd
67.165 + (Wellsorted.change_yield thy (extend_arities_eqngr thy cs ts));
67.166
67.167 +fun prepare_sorts prep_sort (Const (c, ty)) = Const (c, map_type_tfree
67.168 + (fn (v, sort) => TFree (v, prep_sort sort)) ty)
67.169 + | prepare_sorts prep_sort (t1 $ t2) =
67.170 + prepare_sorts prep_sort t1 $ prepare_sorts prep_sort t2
67.171 + | prepare_sorts prep_sort (Abs (v, ty, t)) =
67.172 + Abs (v, Type.strip_sorts ty, prepare_sorts prep_sort t)
67.173 + | prepare_sorts _ (Term.Free (v, ty)) = Term.Free (v, Type.strip_sorts ty)
67.174 + | prepare_sorts _ (t as Bound _) = t;
67.175
67.176 -(** diagnostic commands **)
67.177 +fun gen_eval thy cterm_of conclude_evaluation prep_sort evaluator proto_ct =
67.178 + let
67.179 + val ct = cterm_of proto_ct;
67.180 + val _ = (Term.map_types Type.no_tvars o Sign.no_vars (Syntax.pp_global thy))
67.181 + (Thm.term_of ct);
67.182 + val thm = Code.preprocess_conv thy ct;
67.183 + val ct' = Thm.rhs_of thm;
67.184 + val t' = Thm.term_of ct';
67.185 + val vs = Term.add_tfrees t' [];
67.186 + val consts = fold_aterms
67.187 + (fn Const (c, _) => insert (op =) c | _ => I) t' [];
67.188 + val t'' = prepare_sorts prep_sort t';
67.189 + val (algebra', eqngr') = obtain thy consts [t''];
67.190 + in conclude_evaluation (evaluator algebra' eqngr' vs t'' ct') thm end;
67.191
67.192 -fun code_depgr thy consts =
67.193 +fun simple_evaluator evaluator algebra eqngr vs t ct =
67.194 + evaluator algebra eqngr vs t;
67.195 +
67.196 +fun eval_conv thy =
67.197 let
67.198 - val (_, eqngr) = make thy consts;
67.199 - val select = Graph.all_succs eqngr consts;
67.200 - in
67.201 - eqngr
67.202 - |> not (null consts) ? Graph.subgraph (member (op =) select)
67.203 - |> Graph.map_nodes ((apsnd o map o apfst) (AxClass.overload thy))
67.204 - end;
67.205 + fun conclude_evaluation thm2 thm1 =
67.206 + let
67.207 + val thm3 = Code.postprocess_conv thy (Thm.rhs_of thm2);
67.208 + in
67.209 + Thm.transitive thm1 (Thm.transitive thm2 thm3) handle THM _ =>
67.210 + error ("could not construct evaluation proof:\n"
67.211 + ^ (cat_lines o map Display.string_of_thm) [thm1, thm2, thm3])
67.212 + end;
67.213 + in gen_eval thy I conclude_evaluation end;
67.214
67.215 -fun code_thms thy = Pretty.writeln o pretty thy o code_depgr thy;
67.216 +fun eval_term thy prep_sort evaluator = gen_eval thy (Thm.cterm_of thy)
67.217 + (fn t => K (Code.postprocess_term thy t)) prep_sort (simple_evaluator evaluator);
67.218
67.219 -fun code_deps thy consts =
67.220 - let
67.221 - val eqngr = code_depgr thy consts;
67.222 - val constss = Graph.strong_conn eqngr;
67.223 - val mapping = Symtab.empty |> fold (fn consts => fold (fn const =>
67.224 - Symtab.update (const, consts)) consts) constss;
67.225 - fun succs consts = consts
67.226 - |> maps (Graph.imm_succs eqngr)
67.227 - |> subtract (op =) consts
67.228 - |> map (the o Symtab.lookup mapping)
67.229 - |> distinct (op =);
67.230 - val conn = [] |> fold (fn consts => cons (consts, succs consts)) constss;
67.231 - fun namify consts = map (Code_Unit.string_of_const thy) consts
67.232 - |> commas;
67.233 - val prgr = map (fn (consts, constss) =>
67.234 - { name = namify consts, ID = namify consts, dir = "", unfold = true,
67.235 - path = "", parents = map namify constss }) conn;
67.236 - in Present.display_graph prgr end;
67.237 -
67.238 -local
67.239 -
67.240 -structure P = OuterParse
67.241 -and K = OuterKeyword
67.242 -
67.243 -fun code_thms_cmd thy = code_thms thy o op @ o Code_Name.read_const_exprs thy;
67.244 -fun code_deps_cmd thy = code_deps thy o op @ o Code_Name.read_const_exprs thy;
67.245 -
67.246 -in
67.247 -
67.248 -val _ =
67.249 - OuterSyntax.improper_command "code_thms" "print system of code equations for code" OuterKeyword.diag
67.250 - (Scan.repeat P.term_group
67.251 - >> (fn cs => Toplevel.no_timing o Toplevel.unknown_theory
67.252 - o Toplevel.keep ((fn thy => code_thms_cmd thy cs) o Toplevel.theory_of)));
67.253 -
67.254 -val _ =
67.255 - OuterSyntax.improper_command "code_deps" "visualize dependencies of code equations for code" OuterKeyword.diag
67.256 - (Scan.repeat P.term_group
67.257 - >> (fn cs => Toplevel.no_timing o Toplevel.unknown_theory
67.258 - o Toplevel.keep ((fn thy => code_deps_cmd thy cs) o Toplevel.theory_of)));
67.259 -
67.260 -end;
67.261 +fun eval thy prep_sort evaluator = gen_eval thy (Thm.cterm_of thy)
67.262 + (fn t => K t) prep_sort (simple_evaluator evaluator);
67.263
67.264 end; (*struct*)
68.1 --- a/src/Tools/nbe.ML Mon Apr 20 12:27:23 2009 +0200
68.2 +++ b/src/Tools/nbe.ML Mon Apr 20 16:28:13 2009 +0200
68.3 @@ -350,7 +350,7 @@
68.4
68.5 (* term evaluation *)
68.6
68.7 -fun eval_term ctxt gr deps ((vs, ty) : typscheme, t) =
68.8 +fun eval_term ctxt gr deps (vs : (string * sort) list, t) =
68.9 let
68.10 val frees = Code_Thingol.fold_unbound_varnames (insert (op =)) t []
68.11 val frees' = map (fn v => Free (v, [])) frees;
68.12 @@ -364,6 +364,15 @@
68.13
68.14 (* reification *)
68.15
68.16 +fun typ_of_itype program vs (ityco `%% itys) =
68.17 + let
68.18 + val Code_Thingol.Datatype (tyco, _) = Graph.get_node program ityco;
68.19 + in Type (tyco, map (typ_of_itype program vs) itys) end
68.20 + | typ_of_itype program vs (ITyVar v) =
68.21 + let
68.22 + val sort = (the o AList.lookup (op =) vs) v;
68.23 + in TFree ("'" ^ v, sort) end;
68.24 +
68.25 fun term_of_univ thy program idx_tab t =
68.26 let
68.27 fun take_until f [] = []
68.28 @@ -418,41 +427,40 @@
68.29
68.30 (* compilation, evaluation and reification *)
68.31
68.32 -fun compile_eval thy naming program vs_ty_t deps =
68.33 +fun compile_eval thy naming program vs_t deps =
68.34 let
68.35 val ctxt = ProofContext.init thy;
68.36 val (_, (gr, (_, idx_tab))) =
68.37 Nbe_Functions.change thy (ensure_stmts ctxt naming program o snd);
68.38 in
68.39 - vs_ty_t
68.40 + vs_t
68.41 |> eval_term ctxt gr deps
68.42 |> term_of_univ thy program idx_tab
68.43 end;
68.44
68.45 (* evaluation with type reconstruction *)
68.46
68.47 -fun eval thy t naming program vs_ty_t deps =
68.48 +fun norm thy naming program (((vs0, (vs, ty)), fs), t) deps =
68.49 let
68.50 fun subst_const f = map_aterms (fn t as Term.Const (c, ty) => Term.Const (f c, ty)
68.51 | t => t);
68.52 - val subst_triv_consts = subst_const (Code_Unit.resubst_alias thy);
68.53 - val ty = type_of t;
68.54 - val type_free = AList.lookup (op =)
68.55 - (map (fn (s, T) => (s, Term.Free (s, T))) (Term.add_frees t []));
68.56 - val type_frees = Term.map_aterms
68.57 - (fn (t as Term.Free (s, _)) => the_default t (type_free s) | t => t);
68.58 + val resubst_triv_consts = subst_const (Code_Unit.resubst_alias thy);
68.59 + val ty' = typ_of_itype program vs0 ty;
68.60 + val fs' = (map o apsnd) (typ_of_itype program vs0) fs;
68.61 + val type_frees = Term.map_aterms (fn (t as Term.Free (s, _)) =>
68.62 + Term.Free (s, (the o AList.lookup (op =) fs') s) | t => t);
68.63 fun type_infer t =
68.64 singleton (TypeInfer.infer_types (Syntax.pp_global thy) (Sign.tsig_of thy) I
68.65 (try (Type.strip_sorts o Sign.the_const_type thy)) (K NONE) Name.context 0)
68.66 - (TypeInfer.constrain ty t);
68.67 + (TypeInfer.constrain ty' t);
68.68 fun check_tvars t = if null (Term.add_tvars t []) then t else
68.69 error ("Illegal schematic type variables in normalized term: "
68.70 ^ setmp show_types true (Syntax.string_of_term_global thy) t);
68.71 val string_of_term = setmp show_types true (Syntax.string_of_term_global thy);
68.72 in
68.73 - compile_eval thy naming program vs_ty_t deps
68.74 + compile_eval thy naming program (vs, t) deps
68.75 |> tracing (fn t => "Normalized:\n" ^ string_of_term t)
68.76 - |> subst_triv_consts
68.77 + |> resubst_triv_consts
68.78 |> type_frees
68.79 |> tracing (fn t => "Vars typed:\n" ^ string_of_term t)
68.80 |> type_infer
68.81 @@ -463,32 +471,30 @@
68.82
68.83 (* evaluation oracle *)
68.84
68.85 -val (_, norm_oracle) = Context.>>> (Context.map_theory_result
68.86 - (Thm.add_oracle (Binding.name "norm", fn (thy, t, naming, program, vs_ty_t, deps) =>
68.87 - Thm.cterm_of thy (Logic.mk_equals (t, eval thy t naming program vs_ty_t deps)))));
68.88 +fun add_triv_classes thy = curry (Sorts.inter_sort (Sign.classes_of thy))
68.89 + (Code_Unit.triv_classes thy);
68.90
68.91 -fun add_triv_classes thy =
68.92 +fun mk_equals thy lhs raw_rhs =
68.93 let
68.94 - val inters = curry (Sorts.inter_sort (Sign.classes_of thy))
68.95 - (Code_Unit.triv_classes thy);
68.96 - fun map_sorts f = (map_types o map_atyps)
68.97 - (fn TVar (v, sort) => TVar (v, f sort)
68.98 - | TFree (v, sort) => TFree (v, f sort));
68.99 - in map_sorts inters end;
68.100 + val ty = Thm.typ_of (Thm.ctyp_of_term lhs);
68.101 + val eq = Thm.cterm_of thy (Term.Const ("==", ty --> ty --> propT));
68.102 + val rhs = Thm.cterm_of thy raw_rhs;
68.103 + in Thm.mk_binop eq lhs rhs end;
68.104 +
68.105 +val (_, raw_norm_oracle) = Context.>>> (Context.map_theory_result
68.106 + (Thm.add_oracle (Binding.name "norm", fn (thy, naming, program, vsp_ty_fs_t, deps, ct) =>
68.107 + mk_equals thy ct (norm thy naming program vsp_ty_fs_t deps))));
68.108 +
68.109 +fun norm_oracle thy naming program vsp_ty_fs_t deps ct =
68.110 + raw_norm_oracle (thy, naming, program, vsp_ty_fs_t, deps, ct);
68.111
68.112 fun norm_conv ct =
68.113 let
68.114 val thy = Thm.theory_of_cterm ct;
68.115 - fun evaluator' t naming program vs_ty_t deps =
68.116 - norm_oracle (thy, t, naming, program, vs_ty_t, deps);
68.117 - fun evaluator t = (add_triv_classes thy t, evaluator' t);
68.118 - in Code_Thingol.eval_conv thy evaluator ct end;
68.119 + in Code_Thingol.eval_conv thy (add_triv_classes thy) (norm_oracle thy) ct end;
68.120
68.121 -fun norm_term thy t =
68.122 - let
68.123 - fun evaluator' t naming program vs_ty_t deps = eval thy t naming program vs_ty_t deps;
68.124 - fun evaluator t = (add_triv_classes thy t, evaluator' t);
68.125 - in (Code.postprocess_term thy o Code_Thingol.eval_term thy evaluator) t end;
68.126 +fun norm_term thy = Code.postprocess_term thy
68.127 + o Code_Thingol.eval_term thy (add_triv_classes thy) (norm thy);
68.128
68.129 (* evaluation command *)
68.130