merged
authorhaftmann
Tue Apr 21 15:48:02 2009 +0200 (2009-04-21)
changeset 30958d8a30cdae862
parent 30909 bd4f255837e5
parent 30957 20d01210b9b1
child 30959 458e55fd0a33
merged
src/HOL/Code_Setup.thy
src/HOL/NatBin.thy
src/Tools/code/code_funcgr.ML
     1.1 --- a/NEWS	Tue Apr 21 09:53:31 2009 +0200
     1.2 +++ b/NEWS	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
     2.2 +++ b/doc-src/Codegen/Thy/Program.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
     3.2 +++ b/doc-src/Codegen/Thy/document/Program.tex	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
     4.2 +++ b/doc-src/TutorialI/tutorial.tex	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
     5.2 +++ b/src/HOL/Bali/Trans.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
     6.2 +++ b/src/HOL/Code_Eval.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 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	Tue Apr 21 09:53:31 2009 +0200
     8.2 +++ b/src/HOL/Decision_Procs/Approximation.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
     9.2 +++ b/src/HOL/Decision_Procs/cooper_tac.ML	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    10.2 +++ b/src/HOL/Decision_Procs/mir_tac.ML	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    11.2 +++ b/src/HOL/Divides.thy	Tue Apr 21 15:48:02 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 +structure CancelDivMod = CancelDivModFun(struct
  11.320  
  11.321 -ML {*
  11.322 -structure CancelDivModData =
  11.323 -struct
  11.324 -
  11.325 -val div_name = @{const_name div};
  11.326 -val mod_name = @{const_name mod};
  11.327 -val mk_binop = HOLogic.mk_binop;
  11.328 -val mk_sum = Nat_Arith.mk_sum;
  11.329 -val dest_sum = Nat_Arith.dest_sum;
  11.330 +  val div_name = @{const_name div};
  11.331 +  val mod_name = @{const_name mod};
  11.332 +  val mk_binop = HOLogic.mk_binop;
  11.333 +  val mk_sum = Nat_Arith.mk_sum;
  11.334 +  val dest_sum = Nat_Arith.dest_sum;
  11.335  
  11.336 -(*logic*)
  11.337 +  val div_mod_eqs = map mk_meta_eq [@{thm div_mod_equality}, @{thm div_mod_equality2}];
  11.338  
  11.339 -val div_mod_eqs = map mk_meta_eq [@{thm div_mod_equality}, @{thm div_mod_equality2}]
  11.340 -
  11.341 -val trans = trans
  11.342 +  val trans = trans;
  11.343  
  11.344 -val prove_eq_sums =
  11.345 -  let val simps = @{thm add_0} :: @{thm add_0_right} :: @{thms add_ac}
  11.346 -  in Arith_Data.prove_conv2 all_tac (Arith_Data.simp_all_tac simps) end;
  11.347 +  val prove_eq_sums = Arith_Data.prove_conv2 all_tac (Arith_Data.simp_all_tac
  11.348 +    (@{thm monoid_add_class.add_0_left} :: @{thm monoid_add_class.add_0_right} :: @{thms add_ac}))
  11.349  
  11.350 -end;
  11.351 +end)
  11.352  
  11.353 -structure CancelDivMod = CancelDivModFun(CancelDivModData);
  11.354 +in
  11.355  
  11.356 -val cancel_div_mod_proc = Simplifier.simproc (the_context ())
  11.357 +val cancel_div_mod_nat_proc = Simplifier.simproc (the_context ())
  11.358    "cancel_div_mod" ["(m::nat) + n"] (K CancelDivMod.proc);
  11.359  
  11.360 -Addsimprocs[cancel_div_mod_proc];
  11.361 +val _ = Addsimprocs [cancel_div_mod_nat_proc];
  11.362 +
  11.363 +end
  11.364  *}
  11.365  
  11.366  text {* code generator setup *}
  11.367 @@ -658,7 +695,7 @@
  11.368    fixes m n :: nat
  11.369    assumes "n > 0"
  11.370    shows "m mod n < (n::nat)"
  11.371 -  using assms divmod_rel unfolding divmod_rel_def by auto
  11.372 +  using assms divmod_rel [of m n] unfolding divmod_rel_def by auto
  11.373  
  11.374  lemma mod_less_eq_dividend [simp]:
  11.375    fixes m n :: nat
  11.376 @@ -700,18 +737,19 @@
  11.377  subsubsection {* Quotient and Remainder *}
  11.378  
  11.379  lemma divmod_rel_mult1_eq:
  11.380 -  "[| divmod_rel b c q r; c > 0 |]
  11.381 -   ==> divmod_rel (a*b) c (a*q + a*r div c) (a*r mod c)"
  11.382 +  "divmod_rel b c (q, r) \<Longrightarrow> c > 0
  11.383 +   \<Longrightarrow> divmod_rel (a * b) c (a * q + a * r div c, a * r mod c)"
  11.384  by (auto simp add: split_ifs divmod_rel_def algebra_simps)
  11.385  
  11.386 -lemma div_mult1_eq: "(a*b) div c = a*(b div c) + a*(b mod c) div (c::nat)"
  11.387 +lemma div_mult1_eq:
  11.388 +  "(a * b) div c = a * (b div c) + a * (b mod c) div (c::nat)"
  11.389  apply (cases "c = 0", simp)
  11.390  apply (blast intro: divmod_rel [THEN divmod_rel_mult1_eq, THEN div_eq])
  11.391  done
  11.392  
  11.393  lemma divmod_rel_add1_eq:
  11.394 -  "[| divmod_rel a c aq ar; divmod_rel b c bq br;  c > 0 |]
  11.395 -   ==> divmod_rel (a + b) c (aq + bq + (ar+br) div c) ((ar + br) mod c)"
  11.396 +  "divmod_rel a c (aq, ar) \<Longrightarrow> divmod_rel b c (bq, br) \<Longrightarrow>  c > 0
  11.397 +   \<Longrightarrow> divmod_rel (a + b) c (aq + bq + (ar + br) div c, (ar + br) mod c)"
  11.398  by (auto simp add: split_ifs divmod_rel_def algebra_simps)
  11.399  
  11.400  (*NOT suitable for rewriting: the RHS has an instance of the LHS*)
  11.401 @@ -728,8 +766,9 @@
  11.402    apply (simp add: add_mult_distrib2)
  11.403    done
  11.404  
  11.405 -lemma divmod_rel_mult2_eq: "[| divmod_rel a b q r;  0 < b;  0 < c |]
  11.406 -      ==> divmod_rel a (b*c) (q div c) (b*(q mod c) + r)"
  11.407 +lemma divmod_rel_mult2_eq:
  11.408 +  "divmod_rel a b (q, r) \<Longrightarrow> 0 < b \<Longrightarrow> 0 < c
  11.409 +   \<Longrightarrow> divmod_rel a (b * c) (q div c, b *(q mod c) + r)"
  11.410  by (auto simp add: mult_ac divmod_rel_def add_mult_distrib2 [symmetric] mod_lemma)
  11.411  
  11.412  lemma div_mult2_eq: "a div (b*c) = (a div b) div (c::nat)"
  11.413 @@ -745,23 +784,6 @@
  11.414    done
  11.415  
  11.416  
  11.417 -subsubsection{*Cancellation of Common Factors in Division*}
  11.418 -
  11.419 -lemma div_mult_mult_lemma:
  11.420 -    "[| (0::nat) < b;  0 < c |] ==> (c*a) div (c*b) = a div b"
  11.421 -by (auto simp add: div_mult2_eq)
  11.422 -
  11.423 -lemma div_mult_mult1 [simp]: "(0::nat) < c ==> (c*a) div (c*b) = a div b"
  11.424 -  apply (cases "b = 0")
  11.425 -  apply (auto simp add: linorder_neq_iff [of b] div_mult_mult_lemma)
  11.426 -  done
  11.427 -
  11.428 -lemma div_mult_mult2 [simp]: "(0::nat) < c ==> (a*c) div (b*c) = a div b"
  11.429 -  apply (drule div_mult_mult1)
  11.430 -  apply (auto simp add: mult_commute)
  11.431 -  done
  11.432 -
  11.433 -
  11.434  subsubsection{*Further Facts about Quotient and Remainder*}
  11.435  
  11.436  lemma div_1 [simp]: "m div Suc 0 = m"
  11.437 @@ -769,7 +791,7 @@
  11.438  
  11.439  
  11.440  (* Monotonicity of div in first argument *)
  11.441 -lemma div_le_mono [rule_format]:
  11.442 +lemma div_le_mono [rule_format (no_asm)]:
  11.443      "\<forall>m::nat. m \<le> n --> (m div k) \<le> (n div k)"
  11.444  apply (case_tac "k=0", simp)
  11.445  apply (induct "n" rule: nat_less_induct, clarify)
  11.446 @@ -824,12 +846,6 @@
  11.447    apply (simp_all)
  11.448  done
  11.449  
  11.450 -lemma nat_div_eq_0 [simp]: "(n::nat) > 0 ==> ((m div n) = 0) = (m < n)"
  11.451 -by(auto, subst mod_div_equality [of m n, symmetric], auto)
  11.452 -
  11.453 -lemma nat_div_gt_0 [simp]: "(n::nat) > 0 ==> ((m div n) > 0) = (m >= n)"
  11.454 -by (subst neq0_conv [symmetric], auto)
  11.455 -
  11.456  declare div_less_dividend [simp]
  11.457  
  11.458  text{*A fact for the mutilated chess board*}
  11.459 @@ -915,16 +931,10 @@
  11.460    done
  11.461  
  11.462  lemma dvd_imp_le: "[| k dvd n; 0 < n |] ==> k \<le> (n::nat)"
  11.463 -by (auto elim!: dvdE) (auto simp add: gr0_conv_Suc)
  11.464 -
  11.465 -lemma nat_dvd_not_less: "(0::nat) < m \<Longrightarrow> m < n \<Longrightarrow> \<not> n dvd m"
  11.466 -by (auto elim!: dvdE) (auto simp add: gr0_conv_Suc)
  11.467 +  by (auto elim!: dvdE) (auto simp add: gr0_conv_Suc)
  11.468  
  11.469  lemma dvd_mult_div_cancel: "n dvd m ==> n * (m div n) = (m::nat)"
  11.470 -  apply (subgoal_tac "m mod n = 0")
  11.471 -   apply (simp add: mult_div_cancel)
  11.472 -  apply (simp only: dvd_eq_mod_eq_0)
  11.473 -  done
  11.474 +  by (simp add: dvd_eq_mod_eq_0 mult_div_cancel)
  11.475  
  11.476  lemma nat_zero_less_power_iff [simp]: "(x^n > 0) = (x > (0::nat) | n=0)"
  11.477    by (induct n) auto
  11.478 @@ -1001,9 +1011,11 @@
  11.479    from A B show ?lhs ..
  11.480  next
  11.481    assume P: ?lhs
  11.482 -  then have "divmod_rel m n q (m - n * q)"
  11.483 +  then have "divmod_rel m n (q, m - n * q)"
  11.484      unfolding divmod_rel_def by (auto simp add: mult_ac)
  11.485 -  then show ?rhs using divmod_rel by (rule divmod_rel_unique_div)
  11.486 +  with divmod_rel_unique divmod_rel [of m n]
  11.487 +  have "(q, m - n * q) = (m div n, m mod n)" by auto
  11.488 +  then show ?rhs by simp
  11.489  qed
  11.490  
  11.491  theorem split_div':
  11.492 @@ -1155,4 +1167,9 @@
  11.493    with j show ?thesis by blast
  11.494  qed
  11.495  
  11.496 +lemma nat_dvd_not_less:
  11.497 +  fixes m n :: nat
  11.498 +  shows "0 < m \<Longrightarrow> m < n \<Longrightarrow> \<not> n dvd m"
  11.499 +by (auto elim!: dvdE) (auto simp add: gr0_conv_Suc)
  11.500 +
  11.501  end
    12.1 --- a/src/HOL/Groebner_Basis.thy	Tue Apr 21 09:53:31 2009 +0200
    12.2 +++ b/src/HOL/Groebner_Basis.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    13.2 +++ b/src/HOL/HOL.thy	Tue Apr 21 15:48:02 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 +subsubsection {* SML code generator setup *}
   13.37 +
   13.38 +use "Tools/recfun_codegen.ML"
   13.39 +
   13.40 +setup {*
   13.41 +  Codegen.setup
   13.42 +  #> RecfunCodegen.setup
   13.43 +*}
   13.44 +
   13.45 +types_code
   13.46 +  "bool"  ("bool")
   13.47 +attach (term_of) {*
   13.48 +fun term_of_bool b = if b then HOLogic.true_const else HOLogic.false_const;
   13.49 +*}
   13.50 +attach (test) {*
   13.51 +fun gen_bool i =
   13.52 +  let val b = one_of [false, true]
   13.53 +  in (b, fn () => term_of_bool b) end;
   13.54 +*}
   13.55 +  "prop"  ("bool")
   13.56 +attach (term_of) {*
   13.57 +fun term_of_prop b =
   13.58 +  HOLogic.mk_Trueprop (if b then HOLogic.true_const else HOLogic.false_const);
   13.59 +*}
   13.60  
   13.61 -text {* Equality *}
   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 +text {* Datatypes *}
  13.120 +
  13.121 +code_datatype True False
  13.122 +
  13.123 +code_datatype "TYPE('a\<Colon>{})"
  13.124 +
  13.125 +code_datatype Trueprop "prop"
  13.126 +
  13.127 +text {* Code equations *}
  13.128 +
  13.129 +lemma [code]:
  13.130 +  shows "(True \<Longrightarrow> PROP P) \<equiv> PROP P" 
  13.131 +    and "(False \<Longrightarrow> Q) \<equiv> Trueprop True" 
  13.132 +    and "(PROP P \<Longrightarrow> True) \<equiv> Trueprop True" 
  13.133 +    and "(Q \<Longrightarrow> False) \<equiv> Trueprop (\<not> Q)" by (auto intro!: equal_intr_rule)
  13.134 +
  13.135 +lemma [code]:
  13.136 +  shows "False \<and> x \<longleftrightarrow> False"
  13.137 +    and "True \<and> x \<longleftrightarrow> x"
  13.138 +    and "x \<and> False \<longleftrightarrow> False"
  13.139 +    and "x \<and> True \<longleftrightarrow> x" by simp_all
  13.140 +
  13.141 +lemma [code]:
  13.142 +  shows "False \<or> x \<longleftrightarrow> x"
  13.143 +    and "True \<or> x \<longleftrightarrow> True"
  13.144 +    and "x \<or> False \<longleftrightarrow> x"
  13.145 +    and "x \<or> True \<longleftrightarrow> True" by simp_all
  13.146 +
  13.147 +lemma [code]:
  13.148 +  shows "\<not> True \<longleftrightarrow> False"
  13.149 +    and "\<not> False \<longleftrightarrow> True" by (rule HOL.simp_thms)+
  13.150  
  13.151 -use "Tools/recfun_codegen.ML"
  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_Unit.add_const_alias @{thm equals_eq}
  13.165 +*}
  13.166 +
  13.167 +text {* Cases *}
  13.168 +
  13.169 +lemma Let_case_cert:
  13.170 +  assumes "CASE \<equiv> (\<lambda>x. Let x f)"
  13.171 +  shows "CASE x \<equiv> f x"
  13.172 +  using assms by simp_all
  13.173 +
  13.174 +lemma If_case_cert:
  13.175 +  assumes "CASE \<equiv> (\<lambda>b. If b f g)"
  13.176 +  shows "(CASE True \<equiv> f) &&& (CASE False \<equiv> g)"
  13.177 +  using assms by simp_all
  13.178 +
  13.179 +setup {*
  13.180 +  Code.add_case @{thm Let_case_cert}
  13.181 +  #> Code.add_case @{thm If_case_cert}
  13.182 +  #> Code.add_undefined @{const_name undefined}
  13.183 +*}
  13.184 +
  13.185 +code_abort undefined
  13.186 +
  13.187 +subsubsection {* Generic code generator preprocessor *}
  13.188  
  13.189  setup {*
  13.190 -  Code_ML.setup
  13.191 -  #> Code_Haskell.setup
  13.192 -  #> Nbe.setup
  13.193 -  #> Codegen.setup
  13.194 -  #> RecfunCodegen.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	Tue Apr 21 09:53:31 2009 +0200
    14.2 +++ b/src/HOL/HoareParallel/OG_Tran.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    15.2 +++ b/src/HOL/IMP/Compiler0.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    16.2 +++ b/src/HOL/IMP/Machines.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    17.2 +++ b/src/HOL/IMP/Transition.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    18.2 +++ b/src/HOL/Import/HOL/HOL4Base.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    19.2 +++ b/src/HOL/Import/HOL/HOL4Word32.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    20.2 +++ b/src/HOL/Import/HOL/arithmetic.imp	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    21.2 +++ b/src/HOL/Import/HOL/real.imp	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    22.2 +++ b/src/HOL/Import/HOL4Compat.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    23.2 +++ b/src/HOL/Import/HOLLight/hollight.imp	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    24.2 +++ b/src/HOL/IntDiv.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    25.2 +++ b/src/HOL/IsaMakefile	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    26.2 +++ b/src/HOL/Library/Code_Index.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    27.2 +++ b/src/HOL/Library/Coinductive_List.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    28.2 +++ b/src/HOL/Library/Continuity.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    29.2 +++ b/src/HOL/Library/Eval_Witness.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    30.2 +++ b/src/HOL/Library/Formal_Power_Series.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    31.2 +++ b/src/HOL/Library/Polynomial.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    32.2 +++ b/src/HOL/Library/Quickcheck.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    33.2 +++ b/src/HOL/Library/Topology_Euclidean_Space.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    34.2 +++ b/src/HOL/List.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    35.2 +++ b/src/HOL/Map.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    36.2 +++ b/src/HOL/Nat.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 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	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    39.2 +++ b/src/HOL/Orderings.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    40.2 +++ b/src/HOL/Predicate.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    41.2 +++ b/src/HOL/Product_Type.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    42.2 +++ b/src/HOL/Relation_Power.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    43.2 +++ b/src/HOL/SizeChange/Interpretation.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    44.2 +++ b/src/HOL/Tools/Qelim/presburger.ML	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    45.2 +++ b/src/HOL/Tools/int_factor_simprocs.ML	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    46.2 +++ b/src/HOL/Transitive_Closure.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    47.2 +++ b/src/HOL/UNITY/Comp.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    48.2 +++ b/src/HOL/UNITY/Transformers.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    49.2 +++ b/src/HOL/Word/BinBoolList.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    50.2 +++ b/src/HOL/Word/BinGeneral.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    51.2 +++ b/src/HOL/Word/BinOperations.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    52.2 +++ b/src/HOL/Word/Num_Lemmas.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    53.2 +++ b/src/HOL/Word/TdThs.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    54.2 +++ b/src/HOL/Word/WordDefinition.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    55.2 +++ b/src/HOL/Word/WordShift.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    56.2 +++ b/src/HOL/base.ML	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    57.2 +++ b/src/HOL/ex/NormalForm.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    58.2 +++ b/src/HOL/ex/Predicate_Compile.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    59.2 +++ b/src/HOL/ex/Quickcheck_Generators.thy	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    60.2 +++ b/src/Provers/Arith/cancel_div_mod.ML	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    61.2 +++ b/src/Pure/Isar/code.ML	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    62.2 +++ b/src/Pure/axclass.ML	Tue Apr 21 15:48:02 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	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 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	Tue Apr 21 09:53:31 2009 +0200
    65.2 +++ b/src/Tools/code/code_ml.ML	Tue Apr 21 15:48:02 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	Tue Apr 21 09:53:31 2009 +0200
    66.2 +++ b/src/Tools/code/code_thingol.ML	Tue Apr 21 15:48:02 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 base_evaluator thy evaluator algebra funcgr vs t =
  66.271 +  let
  66.272 +    val fs = Term.add_frees t [];
  66.273 +    val (((naming, program), ((((vs', ty'), fs'), t'), deps)), _) =
  66.274 +      invoke_generation thy (algebra, funcgr) ensure_value (fs, t);
  66.275 +    val vs'' = map (fn (v, _) => (v, (the o AList.lookup (op =) vs o prefix "'") v)) vs';
  66.276 +  in evaluator naming program (((vs'', (vs', ty')), fs'), t') deps end;
  66.277 +
  66.278 +fun eval_conv thy prep_sort = Code_Wellsorted.eval_conv thy prep_sort o base_evaluator thy;
  66.279 +fun eval_term thy prep_sort = Code_Wellsorted.eval_term thy prep_sort o base_evaluator thy;
  66.280 +fun eval thy prep_sort = Code_Wellsorted.eval thy prep_sort o base_evaluator thy;
  66.281 +
  66.282 +
  66.283 +(** diagnostic commands **)
  66.284 +
  66.285 +fun code_depgr thy consts =
  66.286 +  let
  66.287 +    val (_, eqngr) = Code_Wellsorted.obtain thy consts [];
  66.288 +    val select = Graph.all_succs eqngr consts;
  66.289 +  in
  66.290 +    eqngr
  66.291 +    |> not (null consts) ? Graph.subgraph (member (op =) select) 
  66.292 +    |> Graph.map_nodes ((apsnd o map o apfst) (AxClass.overload thy))
  66.293    end;
  66.294  
  66.295 -fun eval thy evaluator t =
  66.296 +fun code_thms thy = Pretty.writeln o Code_Wellsorted.pretty thy o code_depgr thy;
  66.297 +
  66.298 +fun code_deps thy consts =
  66.299    let
  66.300 -    val (t', evaluator'') = evaluator t;
  66.301 -    fun evaluator' algebra funcgr =
  66.302 -      let
  66.303 -        val (((naming, program), (vs_ty_t, deps)), _) =
  66.304 -          invoke_generation thy (algebra, funcgr) ensure_value t';
  66.305 -      in evaluator'' naming program vs_ty_t deps end;
  66.306 -  in (t', evaluator') end
  66.307 +    val eqngr = code_depgr thy consts;
  66.308 +    val constss = Graph.strong_conn eqngr;
  66.309 +    val mapping = Symtab.empty |> fold (fn consts => fold (fn const =>
  66.310 +      Symtab.update (const, consts)) consts) constss;
  66.311 +    fun succs consts = consts
  66.312 +      |> maps (Graph.imm_succs eqngr)
  66.313 +      |> subtract (op =) consts
  66.314 +      |> map (the o Symtab.lookup mapping)
  66.315 +      |> distinct (op =);
  66.316 +    val conn = [] |> fold (fn consts => cons (consts, succs consts)) constss;
  66.317 +    fun namify consts = map (Code_Unit.string_of_const thy) consts
  66.318 +      |> commas;
  66.319 +    val prgr = map (fn (consts, constss) =>
  66.320 +      { name = namify consts, ID = namify consts, dir = "", unfold = true,
  66.321 +        path = "", parents = map namify constss }) conn;
  66.322 +  in Present.display_graph prgr end;
  66.323 +
  66.324 +local
  66.325  
  66.326 -fun eval_conv thy = Code_Wellsorted.eval_conv thy o eval thy;
  66.327 -fun eval_term thy = Code_Wellsorted.eval_term thy o eval thy;
  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	Tue Apr 21 09:53:31 2009 +0200
    67.2 +++ b/src/Tools/code/code_wellsorted.ML	Tue Apr 21 15:48:02 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 -
  67.165 -
  67.166 -(** diagnostic commands **)
  67.167 +fun obtain thy cs ts = apsnd snd
  67.168 +  (Wellsorted.change_yield thy (extend_arities_eqngr thy cs ts));
  67.169  
  67.170 -fun code_depgr thy consts =
  67.171 -  let
  67.172 -    val (_, eqngr) = make thy consts;
  67.173 -    val select = Graph.all_succs eqngr consts;
  67.174 -  in
  67.175 -    eqngr
  67.176 -    |> not (null consts) ? Graph.subgraph (member (op =) select) 
  67.177 -    |> Graph.map_nodes ((apsnd o map o apfst) (AxClass.overload thy))
  67.178 -  end;
  67.179 +fun prepare_sorts prep_sort (Const (c, ty)) = Const (c, map_type_tfree
  67.180 +      (fn (v, sort) => TFree (v, prep_sort sort)) ty)
  67.181 +  | prepare_sorts prep_sort (t1 $ t2) =
  67.182 +      prepare_sorts prep_sort t1 $ prepare_sorts prep_sort t2
  67.183 +  | prepare_sorts prep_sort (Abs (v, ty, t)) =
  67.184 +      Abs (v, Type.strip_sorts ty, prepare_sorts prep_sort t)
  67.185 +  | prepare_sorts _ (Term.Free (v, ty)) = Term.Free (v, Type.strip_sorts ty)
  67.186 +  | prepare_sorts _ (t as Bound _) = t;
  67.187  
  67.188 -fun code_thms thy = Pretty.writeln o pretty thy o code_depgr thy;
  67.189 -
  67.190 -fun code_deps thy consts =
  67.191 +fun gen_eval thy cterm_of conclude_evaluation prep_sort evaluator proto_ct =
  67.192    let
  67.193 -    val eqngr = code_depgr thy consts;
  67.194 -    val constss = Graph.strong_conn eqngr;
  67.195 -    val mapping = Symtab.empty |> fold (fn consts => fold (fn const =>
  67.196 -      Symtab.update (const, consts)) consts) constss;
  67.197 -    fun succs consts = consts
  67.198 -      |> maps (Graph.imm_succs eqngr)
  67.199 -      |> subtract (op =) consts
  67.200 -      |> map (the o Symtab.lookup mapping)
  67.201 -      |> distinct (op =);
  67.202 -    val conn = [] |> fold (fn consts => cons (consts, succs consts)) constss;
  67.203 -    fun namify consts = map (Code_Unit.string_of_const thy) consts
  67.204 -      |> commas;
  67.205 -    val prgr = map (fn (consts, constss) =>
  67.206 -      { name = namify consts, ID = namify consts, dir = "", unfold = true,
  67.207 -        path = "", parents = map namify constss }) conn;
  67.208 -  in Present.display_graph prgr end;
  67.209 +    val ct = cterm_of proto_ct;
  67.210 +    val _ = (Term.map_types Type.no_tvars o Sign.no_vars (Syntax.pp_global thy))
  67.211 +      (Thm.term_of ct);
  67.212 +    val thm = Code.preprocess_conv thy ct;
  67.213 +    val ct' = Thm.rhs_of thm;
  67.214 +    val t' = Thm.term_of ct';
  67.215 +    val vs = Term.add_tfrees t' [];
  67.216 +    val consts = fold_aterms
  67.217 +      (fn Const (c, _) => insert (op =) c | _ => I) t' [];
  67.218 +    val t'' = prepare_sorts prep_sort t';
  67.219 +    val (algebra', eqngr') = obtain thy consts [t''];
  67.220 +  in conclude_evaluation (evaluator algebra' eqngr' vs t'' ct') thm end;
  67.221  
  67.222 -local
  67.223 +fun simple_evaluator evaluator algebra eqngr vs t ct =
  67.224 +  evaluator algebra eqngr vs t;
  67.225  
  67.226 -structure P = OuterParse
  67.227 -and K = OuterKeyword
  67.228 -
  67.229 -fun code_thms_cmd thy = code_thms thy o op @ o Code_Name.read_const_exprs thy;
  67.230 -fun code_deps_cmd thy = code_deps thy o op @ o Code_Name.read_const_exprs thy;
  67.231 -
  67.232 -in
  67.233 +fun eval_conv thy =
  67.234 +  let
  67.235 +    fun conclude_evaluation thm2 thm1 =
  67.236 +      let
  67.237 +        val thm3 = Code.postprocess_conv thy (Thm.rhs_of thm2);
  67.238 +      in
  67.239 +        Thm.transitive thm1 (Thm.transitive thm2 thm3) handle THM _ =>
  67.240 +          error ("could not construct evaluation proof:\n"
  67.241 +          ^ (cat_lines o map Display.string_of_thm) [thm1, thm2, thm3])
  67.242 +      end;
  67.243 +  in gen_eval thy I conclude_evaluation end;
  67.244  
  67.245 -val _ =
  67.246 -  OuterSyntax.improper_command "code_thms" "print system of code equations for code" OuterKeyword.diag
  67.247 -    (Scan.repeat P.term_group
  67.248 -      >> (fn cs => Toplevel.no_timing o Toplevel.unknown_theory
  67.249 -        o Toplevel.keep ((fn thy => code_thms_cmd thy cs) o Toplevel.theory_of)));
  67.250 +fun eval_term thy prep_sort evaluator = gen_eval thy (Thm.cterm_of thy)
  67.251 +  (fn t => K (Code.postprocess_term thy t)) prep_sort (simple_evaluator evaluator);
  67.252  
  67.253 -val _ =
  67.254 -  OuterSyntax.improper_command "code_deps" "visualize dependencies of code equations for code" OuterKeyword.diag
  67.255 -    (Scan.repeat P.term_group
  67.256 -      >> (fn cs => Toplevel.no_timing o Toplevel.unknown_theory
  67.257 -        o Toplevel.keep ((fn thy => code_deps_cmd thy cs) o Toplevel.theory_of)));
  67.258 -
  67.259 -end;
  67.260 +fun eval thy prep_sort evaluator = gen_eval thy (Thm.cterm_of thy)
  67.261 +  (fn t => K t) prep_sort (simple_evaluator evaluator);
  67.262  
  67.263  end; (*struct*)
    68.1 --- a/src/Tools/nbe.ML	Tue Apr 21 09:53:31 2009 +0200
    68.2 +++ b/src/Tools/nbe.ML	Tue Apr 21 15:48:02 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