--- a/Admin/Mercurial/isabelle-style.diff Wed Mar 03 15:40:39 2010 +0100
+++ b/Admin/Mercurial/isabelle-style.diff Wed Mar 03 16:43:55 2010 +0100
@@ -1,34 +1,38 @@
-diff -r gitweb/changelogentry.tmpl isabelle/changelogentry.tmpl
-2,8c2
-< <a class="title" href="{url}rev/#node|short#{sessionvars%urlparameter}"><span class="age">#date|age# ago</span>#desc|strip|firstline|escape#<span class="logtags"> {inbranch%inbranchtag}{branches%branchtag}{tags%tagtag}</span></a>
-< </div>
-< <div class="title_text">
-< <div class="log_link">
-< <a href="{url}rev/#node|short#{sessionvars%urlparameter}">changeset</a><br/>
-< </div>
-< <i>#author|obfuscate# [#date|rfc822date#] rev #rev#</i><br/>
----
-> <a class="title" href="{url}rev/#node|short#{sessionvars%urlparameter}"><span class="age">#date|age# ago</span>#author|obfuscate# [#date|rfc822date#] rev #rev#<span class="logtags"> {inbranch%inbranchtag}{branches%branchtag}{tags%tagtag}</span></a>
-12a7,9
-> <div class="files">
-> #files#
-> </div>
-diff -r gitweb/changeset.tmpl isabelle/changeset.tmpl
-19c19
-< <a class="title" href="{url}raw-rev/#node|short#">#desc|strip|escape|firstline# <span class="logtags">{inbranch%inbranchtag}{branches%branchtag}{tags%tagtag}</span></a>
----
-> <a class="title" href="{url}raw-rev/#node|short#">#desc|strip|escape# <span class="logtags">{inbranch%inbranchtag}{branches%branchtag}{tags%tagtag}</span></a>
-diff -r gitweb/map isabelle/map
-29c29
-< annotateline = '<tr style="font-family:monospace" class="parity#parity#"><td class="linenr" style="text-align: right;"><a href="#url#annotate/#node|short#/#file|urlescape#{sessionvars%urlparameter}#l{targetline}" title="{node|short}: {desc|escape|firstline}">#author|user#@#rev#</a></td><td><pre><a class="linenr" href="##lineid#" id="#lineid#">#linenumber#</a></pre></td><td><pre>#line|escape#</pre></td></tr>'
----
-> annotateline = '<tr style="font-family:monospace" class="parity#parity#"><td class="linenr" style="text-align: right;"><a href="#url#annotate/#node|short#/#file|urlescape#{sessionvars%urlparameter}#l{targetline}" title="{node|short}: {desc|escape}">#author|user#@#rev#</a></td><td><pre><a class="linenr" href="##lineid#" id="#lineid#">#linenumber#</a></pre></td><td><pre>#line|escape#</pre></td></tr>'
-59,60c59,60
-< shortlogentry = '<tr class="parity#parity#"><td class="age"><i>#date|age# ago</i></td><td><i>#author|person#</i></td><td><a class="list" href="{url}rev/#node|short#{sessionvars%urlparameter}"><b>#desc|strip|firstline|escape#</b> <span class="logtags">{inbranch%inbranchtag}{branches%branchtag}{tags%tagtag}</span></a></td><td class="link" nowrap><a href="{url}rev/#node|short#{sessionvars%urlparameter}">changeset</a> | <a href="{url}file/#node|short#{sessionvars%urlparameter}">files</a></td></tr>'
-< filelogentry = '<tr class="parity#parity#"><td class="age"><i>#date|age# ago</i></td><td><a class="list" href="{url}rev/#node|short#{sessionvars%urlparameter}"><b>#desc|strip|firstline|escape#</b></a></td><td class="link"><a href="{url}file/#node|short#/#file|urlescape#{sessionvars%urlparameter}">file</a> | <a href="{url}diff/#node|short#/#file|urlescape#{sessionvars%urlparameter}">diff</a> | <a href="{url}annotate/#node|short#/#file|urlescape#{sessionvars%urlparameter}">annotate</a> #rename%filelogrename#</td></tr>'
----
-> shortlogentry = '<tr class="parity#parity#"><td class="age"><i>#date|age# ago</i></td><td><i>#date|shortdate#</i></td><td><i>#author|person#</i></td><td><a class="list" href="{url}rev/#node|short#{sessionvars%urlparameter}"><b>#desc|strip|escape#</b> <span class="logtags">{inbranch%inbranchtag}{branches%branchtag}{tags%tagtag}</span></a></td><td class="link" nowrap><a href="{url}rev/#node|short#{sessionvars%urlparameter}">changeset</a> | <a href="{url}file/#node|short#{sessionvars%urlparameter}">files</a></td></tr>'
-> filelogentry = '<tr class="parity#parity#"><td class="age"><i>#date|age# ago</i></td><td><i>#date|shortdate#</i></td><td><i>#author|person#</i></td><td><a class="list" href="{url}rev/#node|short#{sessionvars%urlparameter}"><b>#desc|strip|escape#</b></a></td><td class="link"><a href="{url}file/#node|short#/#file|urlescape#{sessionvars%urlparameter}">file</a> | <a href="{url}diff/#node|short#/#file|urlescape#{sessionvars%urlparameter}">diff</a> | <a href="{url}annotate/#node|short#/#file|urlescape#{sessionvars%urlparameter}">annotate</a> #rename%filelogrename#</td></tr>'
-diff -r gitweb/summary.tmpl isabelle/summary.tmpl
-34d33
-< <tr><td>owner</td><td>#owner|obfuscate#</td></tr>
+diff -u gitweb/changelogentry.tmpl isabelle/changelogentry.tmpl
+--- gitweb/changelogentry.tmpl 2010-02-01 16:34:34.000000000 +0100
++++ isabelle/changelogentry.tmpl 2010-03-03 15:12:12.000000000 +0100
+@@ -1,14 +1,12 @@
+ <div>
+-<a class="title" href="{url}rev/{node|short}{sessionvars%urlparameter}"><span class="age">{date|age}</span>{desc|strip|firstline|escape|nonempty}<span class="logtags"> {inbranch%inbranchtag}{branches%branchtag}{tags%tagtag}</span></a>
+-</div>
+-<div class="title_text">
+-<div class="log_link">
+-<a href="{url}rev/{node|short}{sessionvars%urlparameter}">changeset</a><br/>
+-</div>
+-<i>{author|obfuscate} [{date|rfc822date}] rev {rev}</i><br/>
++<a class="title" href="{url}rev/{node|short}{sessionvars%urlparameter}"><span class="age">{date|age}</span>
++{author|obfuscate} [{date|rfc822date}] rev {rev}<span class="logtags"> {inbranch%inbranchtag}{branches%branchtag}{tags%tagtag}</span></a>
+ </div>
+ <div class="log_body">
+ {desc|strip|escape|addbreaks|nonempty}
+ <br/>
++<div class="files">
++{files}
++</div>
+ <br/>
+ </div>
+diff -u gitweb/map isabelle/map
+--- gitweb/map 2010-02-01 16:34:34.000000000 +0100
++++ isabelle/map 2010-03-03 15:13:25.000000000 +0100
+@@ -206,9 +206,10 @@
+ <tr class="parity{parity}">
+ <td class="age"><i>{date|age}</i></td>
+ <td><i>{author|person}</i></td>
++ <td><i>{date|shortdate}</i></td>
+ <td>
+ <a class="list" href="{url}rev/{node|short}{sessionvars%urlparameter}">
+- <b>{desc|strip|firstline|escape|nonempty}</b>
++ <b>{desc|strip|escape|nonempty}</b>
+ <span class="logtags">{inbranch%inbranchtag}{branches%branchtag}{tags%tagtag}</span>
+ </a>
+ </td>
--- a/doc-src/TutorialI/Overview/LNCS/Ordinal.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/doc-src/TutorialI/Overview/LNCS/Ordinal.thy Wed Mar 03 16:43:55 2010 +0100
@@ -11,7 +11,8 @@
definition OpLim :: "(nat \<Rightarrow> (ordinal \<Rightarrow> ordinal)) \<Rightarrow> (ordinal \<Rightarrow> ordinal)" where
"OpLim F a \<equiv> Limit (\<lambda>n. F n a)"
- OpItw :: "(ordinal \<Rightarrow> ordinal) \<Rightarrow> (ordinal \<Rightarrow> ordinal)" ("\<Squnion>")
+
+definition OpItw :: "(ordinal \<Rightarrow> ordinal) \<Rightarrow> (ordinal \<Rightarrow> ordinal)" ("\<Squnion>") where
"\<Squnion>f \<equiv> OpLim (power f)"
consts
@@ -40,9 +41,11 @@
definition veb :: "ordinal \<Rightarrow> ordinal" where
"veb a \<equiv> veblen a Zero"
- epsilon0 :: ordinal ("\<epsilon>\<^sub>0")
+
+definition epsilon0 :: ordinal ("\<epsilon>\<^sub>0") where
"\<epsilon>\<^sub>0 \<equiv> veb Zero"
- Gamma0 :: ordinal ("\<Gamma>\<^sub>0")
+
+definition Gamma0 :: ordinal ("\<Gamma>\<^sub>0") where
"\<Gamma>\<^sub>0 \<equiv> Limit (\<lambda>n. (veb^n) Zero)"
thm Gamma0_def
--- a/doc-src/TutorialI/Protocol/NS_Public.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/doc-src/TutorialI/Protocol/NS_Public.thy Wed Mar 03 16:43:55 2010 +0100
@@ -76,7 +76,7 @@
@{term [display,indent=5] "Says A' B (Crypt (pubK B) \<lbrace>Nonce NA, Agent A\<rbrace>)"}
may be extended by an event of the form
@{term [display,indent=5] "Says B A (Crypt (pubK A) \<lbrace>Nonce NA, Nonce NB, Agent B\<rbrace>)"}
-where @{text NB} is a fresh nonce: @{term "Nonce NB \<in> used evs2"}.
+where @{text NB} is a fresh nonce: @{term "Nonce NB \<notin> used evs2"}.
Writing the sender as @{text A'} indicates that @{text B} does not
know who sent the message. Calling the trace variable @{text evs2} rather
than simply @{text evs} helps us know where we are in a proof after many
--- a/doc-src/TutorialI/Protocol/document/NS_Public.tex Wed Mar 03 15:40:39 2010 +0100
+++ b/doc-src/TutorialI/Protocol/document/NS_Public.tex Wed Mar 03 16:43:55 2010 +0100
@@ -84,7 +84,7 @@
\begin{isabelle}%
\ \ \ \ \ Says\ B\ A\ {\isacharparenleft}Crypt\ {\isacharparenleft}pubK\ A{\isacharparenright}\ {\isasymlbrace}Nonce\ NA{\isacharcomma}\ Nonce\ NB{\isacharcomma}\ Agent\ B{\isasymrbrace}{\isacharparenright}%
\end{isabelle}
-where \isa{NB} is a fresh nonce: \isa{Nonce\ NB\ {\isasymin}\ used\ evs{\isadigit{2}}}.
+where \isa{NB} is a fresh nonce: \isa{Nonce\ NB\ {\isasymnotin}\ used\ evs{\isadigit{2}}}.
Writing the sender as \isa{A{\isacharprime}} indicates that \isa{B} does not
know who sent the message. Calling the trace variable \isa{evs{\isadigit{2}}} rather
than simply \isa{evs} helps us know where we are in a proof after many
--- a/src/HOL/Bali/Decl.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/Bali/Decl.thy Wed Mar 03 16:43:55 2010 +0100
@@ -763,51 +763,57 @@
section "general recursion operators for the interface and class hiearchies"
-consts
- iface_rec :: "prog \<times> qtname \<Rightarrow> \<spacespace> (qtname \<Rightarrow> iface \<Rightarrow> 'a set \<Rightarrow> 'a) \<Rightarrow> 'a"
- class_rec :: "prog \<times> qtname \<Rightarrow> 'a \<Rightarrow> (qtname \<Rightarrow> class \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a"
-
-recdef iface_rec "same_fst ws_prog (\<lambda>G. (subint1 G)^-1)"
-"iface_rec (G,I) =
- (\<lambda>f. case iface G I of
+function
+ iface_rec :: "prog \<Rightarrow> qtname \<Rightarrow> \<spacespace>(qtname \<Rightarrow> iface \<Rightarrow> 'a set \<Rightarrow> 'a) \<Rightarrow> 'a"
+where
+[simp del]: "iface_rec G I f =
+ (case iface G I of
None \<Rightarrow> undefined
| Some i \<Rightarrow> if ws_prog G
then f I i
- ((\<lambda>J. iface_rec (G,J) f)`set (isuperIfs i))
+ ((\<lambda>J. iface_rec G J f)`set (isuperIfs i))
else undefined)"
-(hints recdef_wf: wf_subint1 intro: subint1I)
-declare iface_rec.simps [simp del]
+by auto
+termination
+by (relation "inv_image (same_fst ws_prog (\<lambda>G. (subint1 G)^-1)) (%(x,y,z). (x,y))")
+ (auto simp: wf_subint1 subint1I wf_same_fst)
lemma iface_rec:
"\<lbrakk>iface G I = Some i; ws_prog G\<rbrakk> \<Longrightarrow>
- iface_rec (G,I) f = f I i ((\<lambda>J. iface_rec (G,J) f)`set (isuperIfs i))"
+ iface_rec G I f = f I i ((\<lambda>J. iface_rec G J f)`set (isuperIfs i))"
apply (subst iface_rec.simps)
apply simp
done
-recdef class_rec "same_fst ws_prog (\<lambda>G. (subcls1 G)^-1)"
-"class_rec(G,C) =
- (\<lambda>t f. case class G C of
+
+function
+ class_rec :: "prog \<Rightarrow> qtname \<Rightarrow> 'a \<Rightarrow> (qtname \<Rightarrow> class \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a"
+where
+[simp del]: "class_rec G C t f =
+ (case class G C of
None \<Rightarrow> undefined
| Some c \<Rightarrow> if ws_prog G
then f C c
(if C = Object then t
- else class_rec (G,super c) t f)
+ else class_rec G (super c) t f)
else undefined)"
-(hints recdef_wf: wf_subcls1 intro: subcls1I)
-declare class_rec.simps [simp del]
+
+by auto
+termination
+by (relation "inv_image (same_fst ws_prog (\<lambda>G. (subcls1 G)^-1)) (%(x,y,z,w). (x,y))")
+ (auto simp: wf_subcls1 subcls1I wf_same_fst)
lemma class_rec: "\<lbrakk>class G C = Some c; ws_prog G\<rbrakk> \<Longrightarrow>
- class_rec (G,C) t f =
- f C c (if C = Object then t else class_rec (G,super c) t f)"
-apply (rule class_rec.simps [THEN trans [THEN fun_cong [THEN fun_cong]]])
+ class_rec G C t f =
+ f C c (if C = Object then t else class_rec G (super c) t f)"
+apply (subst class_rec.simps)
apply simp
done
definition imethds :: "prog \<Rightarrow> qtname \<Rightarrow> (sig,qtname \<times> mhead) tables" where
--{* methods of an interface, with overriding and inheritance, cf. 9.2 *}
"imethds G I
- \<equiv> iface_rec (G,I)
+ \<equiv> iface_rec G I
(\<lambda>I i ts. (Un_tables ts) \<oplus>\<oplus>
(Option.set \<circ> table_of (map (\<lambda>(s,m). (s,I,m)) (imethods i))))"
--- a/src/HOL/Bali/DeclConcepts.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/Bali/DeclConcepts.thy Wed Mar 03 16:43:55 2010 +0100
@@ -1381,7 +1381,7 @@
definition imethds :: "prog \<Rightarrow> qtname \<Rightarrow> (sig,qtname \<times> mhead) tables" where
"imethds G I
- \<equiv> iface_rec (G,I)
+ \<equiv> iface_rec G I
(\<lambda>I i ts. (Un_tables ts) \<oplus>\<oplus>
(Option.set \<circ> table_of (map (\<lambda>(s,m). (s,I,m)) (imethods i))))"
text {* methods of an interface, with overriding and inheritance, cf. 9.2 *}
@@ -1396,7 +1396,7 @@
definition methd :: "prog \<Rightarrow> qtname \<Rightarrow> (sig,qtname \<times> methd) table" where
"methd G C
- \<equiv> class_rec (G,C) empty
+ \<equiv> class_rec G C empty
(\<lambda>C c subcls_mthds.
filter_tab (\<lambda>sig m. G\<turnstile>C inherits method sig m)
subcls_mthds
@@ -1429,7 +1429,7 @@
then (case methd G statC sig of
None \<Rightarrow> None
| Some statM
- \<Rightarrow> (class_rec (G,dynC) empty
+ \<Rightarrow> (class_rec G dynC empty
(\<lambda>C c subcls_mthds.
subcls_mthds
++
@@ -1481,7 +1481,7 @@
definition fields :: "prog \<Rightarrow> qtname \<Rightarrow> ((vname \<times> qtname) \<times> field) list" where
"fields G C
- \<equiv> class_rec (G,C) [] (\<lambda>C c ts. map (\<lambda>(n,t). ((n,C),t)) (cfields c) @ ts)"
+ \<equiv> class_rec G C [] (\<lambda>C c ts. map (\<lambda>(n,t). ((n,C),t)) (cfields c) @ ts)"
text {* @{term "fields G C"}
list of fields of a class, including all the fields of the superclasses
(private, inherited and hidden ones) not only the accessible ones
@@ -1805,7 +1805,7 @@
(\<lambda>_ dynM. G,sig \<turnstile> dynM overrides statM \<or> dynM = statM)
(methd G C)"
let "?class_rec C" =
- "(class_rec (G, C) empty
+ "(class_rec G C empty
(\<lambda>C c subcls_mthds. subcls_mthds ++ (?filter C)))"
from statM Subcls ws subclseq_dynC_statC
have dynmethd_dynC_def:
@@ -2270,7 +2270,7 @@
section "calculation of the superclasses of a class"
definition superclasses :: "prog \<Rightarrow> qtname \<Rightarrow> qtname set" where
- "superclasses G C \<equiv> class_rec (G,C) {}
+ "superclasses G C \<equiv> class_rec G C {}
(\<lambda> C c superclss. (if C=Object
then {}
else insert (super c) superclss))"
--- a/src/HOL/Bali/WellForm.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/Bali/WellForm.thy Wed Mar 03 16:43:55 2010 +0100
@@ -730,13 +730,15 @@
\<Longrightarrow> \<not>is_static im \<and> accmodi im = Public"
proof -
assume asm: "wf_prog G" "is_iface G I" "im \<in> imethds G I sig"
+
+ note iface_rec_induct' = iface_rec.induct[of "(%x y z. P x y)", standard]
have "wf_prog G \<longrightarrow>
(\<forall> i im. iface G I = Some i \<longrightarrow> im \<in> imethds G I sig
\<longrightarrow> \<not>is_static im \<and> accmodi im = Public)" (is "?P G I")
- proof (rule iface_rec.induct,intro allI impI)
+ proof (induct G I rule: iface_rec_induct', intro allI impI)
fix G I i im
- assume hyp: "\<forall> J i. J \<in> set (isuperIfs i) \<and> ws_prog G \<and> iface G I = Some i
- \<longrightarrow> ?P G J"
+ assume hyp: "\<And> i J. iface G I = Some i \<Longrightarrow> ws_prog G \<Longrightarrow> J \<in> set (isuperIfs i)
+ \<Longrightarrow> ?P G J"
assume wf: "wf_prog G" and if_I: "iface G I = Some i" and
im: "im \<in> imethds G I sig"
show "\<not>is_static im \<and> accmodi im = Public"
@@ -1345,14 +1347,16 @@
qed
qed
+lemmas class_rec_induct' = class_rec.induct[of "%x y z w. P x y", standard]
+
lemma declclass_widen[rule_format]:
"wf_prog G
\<longrightarrow> (\<forall>c m. class G C = Some c \<longrightarrow> methd G C sig = Some m
\<longrightarrow> G\<turnstile>C \<preceq>\<^sub>C declclass m)" (is "?P G C")
-proof (rule class_rec.induct,intro allI impI)
+proof (induct G C rule: class_rec_induct', intro allI impI)
fix G C c m
- assume Hyp: "\<forall>c. C \<noteq> Object \<and> ws_prog G \<and> class G C = Some c
- \<longrightarrow> ?P G (super c)"
+ assume Hyp: "\<And>c. class G C = Some c \<Longrightarrow> ws_prog G \<Longrightarrow> C \<noteq> Object
+ \<Longrightarrow> ?P G (super c)"
assume wf: "wf_prog G" and cls_C: "class G C = Some c" and
m: "methd G C sig = Some m"
show "G\<turnstile>C\<preceq>\<^sub>C declclass m"
@@ -1976,27 +1980,6 @@
qed
qed
-(* Tactical version *)
-(*
-lemma declclassD[rule_format]:
- "wf_prog G \<longrightarrow>
- (\<forall> c d m. class G C = Some c \<longrightarrow> methd G C sig = Some m \<longrightarrow>
- class G (declclass m) = Some d
- \<longrightarrow> table_of (methods d) sig = Some (mthd m))"
-apply (rule class_rec.induct)
-apply (rule impI)
-apply (rule allI)+
-apply (rule impI)
-apply (case_tac "C=Object")
-apply (force simp add: methd_rec)
-
-apply (subst methd_rec)
-apply (blast dest: wf_ws_prog)+
-apply (case_tac "table_of (map (\<lambda>(s, m). (s, C, m)) (methods c)) sig")
-apply (auto dest: wf_prog_cdecl wf_cdecl_supD is_acc_class_is_class)
-done
-*)
-
lemma dynmethd_Object:
assumes statM: "methd G Object sig = Some statM" and
private: "accmodi statM = Private" and
@@ -2355,9 +2338,9 @@
have "wf_prog G \<longrightarrow>
(\<forall> c m. class G C = Some c \<longrightarrow> methd G C sig = Some m
\<longrightarrow> methd G (declclass m) sig = Some m)" (is "?P G C")
- proof (rule class_rec.induct,intro allI impI)
+ proof (induct G C rule: class_rec_induct', intro allI impI)
fix G C c m
- assume hyp: "\<forall>c. C \<noteq> Object \<and> ws_prog G \<and> class G C = Some c \<longrightarrow>
+ assume hyp: "\<And>c. class G C = Some c \<Longrightarrow> ws_prog G \<Longrightarrow> C \<noteq> Object \<Longrightarrow>
?P G (super c)"
assume wf: "wf_prog G" and cls_C: "class G C = Some c" and
m: "methd G C sig = Some m"
--- a/src/HOL/Induct/Tree.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/Induct/Tree.thy Wed Mar 03 16:43:55 2010 +0100
@@ -68,7 +68,7 @@
subsection{*A WF Ordering for The Brouwer ordinals (Michael Compton)*}
-text{*To define recdef style functions we need an ordering on the Brouwer
+text{*To use the function package we need an ordering on the Brouwer
ordinals. Start with a predecessor relation and form its transitive
closure. *}
--- a/src/HOL/IsaMakefile Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/IsaMakefile Wed Mar 03 16:43:55 2010 +0100
@@ -47,6 +47,7 @@
HOL-MicroJava \
HOL-Mirabelle \
HOL-Modelcheck \
+ HOL-Mutabelle \
HOL-NanoJava \
HOL-Nitpick_Examples \
HOL-Nominal-Examples \
@@ -756,7 +757,7 @@
HOL-ZF: HOL $(LOG)/HOL-ZF.gz
-$(LOG)/HOL-ZF.gz: $(OUT)/HOL ZF/ROOT.ML ZF/Helper.thy ZF/LProd.thy \
+$(LOG)/HOL-ZF.gz: $(OUT)/HOL ZF/ROOT.ML ZF/LProd.thy \
ZF/HOLZF.thy ZF/MainZF.thy ZF/Games.thy ZF/document/root.tex
@$(ISABELLE_TOOL) usedir $(OUT)/HOL ZF
--- a/src/HOL/Lambda/ParRed.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/Lambda/ParRed.thy Wed Mar 03 16:43:55 2010 +0100
@@ -85,14 +85,14 @@
subsection {* Complete developments *}
-consts
+fun
"cd" :: "dB => dB"
-recdef "cd" "measure size"
+where
"cd (Var n) = Var n"
- "cd (Var n \<degree> t) = Var n \<degree> cd t"
- "cd ((s1 \<degree> s2) \<degree> t) = cd (s1 \<degree> s2) \<degree> cd t"
- "cd (Abs u \<degree> t) = (cd u)[cd t/0]"
- "cd (Abs s) = Abs (cd s)"
+| "cd (Var n \<degree> t) = Var n \<degree> cd t"
+| "cd ((s1 \<degree> s2) \<degree> t) = cd (s1 \<degree> s2) \<degree> cd t"
+| "cd (Abs u \<degree> t) = (cd u)[cd t/0]"
+| "cd (Abs s) = Abs (cd s)"
lemma par_beta_cd: "s => t \<Longrightarrow> t => cd s"
apply (induct s arbitrary: t rule: cd.induct)
--- a/src/HOL/Library/RBT.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/Library/RBT.thy Wed Mar 03 16:43:55 2010 +0100
@@ -11,135 +11,151 @@
begin
datatype color = R | B
-datatype ('a,'b)"rbt" = Empty | Tr color "('a,'b)rbt" 'a 'b "('a,'b)rbt"
+datatype ('a, 'b) rbt = Empty | Branch color "('a, 'b) rbt" 'a 'b "('a, 'b) rbt"
+
+lemma rbt_cases:
+ obtains (Empty) "t = Empty"
+ | (Red) l k v r where "t = Branch R l k v r"
+ | (Black) l k v r where "t = Branch B l k v r"
+proof (cases t)
+ case Empty with that show thesis by blast
+next
+ case (Branch c) with that show thesis by (cases c) blast+
+qed
+
+text {* Content of a tree *}
+
+primrec entries
+where
+ "entries Empty = []"
+| "entries (Branch _ l k v r) = entries l @ (k,v) # entries r"
text {* Search tree properties *}
-primrec
- pin_tree :: "'a \<Rightarrow> 'b \<Rightarrow> ('a,'b) rbt \<Rightarrow> bool"
+primrec entry_in_tree :: "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) rbt \<Rightarrow> bool"
where
- "pin_tree k v Empty = False"
-| "pin_tree k v (Tr c l x y r) = (k = x \<and> v = y \<or> pin_tree k v l \<or> pin_tree k v r)"
+ "entry_in_tree k v Empty = False"
+| "entry_in_tree k v (Branch c l x y r) \<longleftrightarrow> k = x \<and> v = y \<or> entry_in_tree k v l \<or> entry_in_tree k v r"
-primrec
- keys :: "('k,'v) rbt \<Rightarrow> 'k set"
+primrec keys :: "('k, 'v) rbt \<Rightarrow> 'k set"
where
"keys Empty = {}"
-| "keys (Tr _ l k _ r) = { k } \<union> keys l \<union> keys r"
+| "keys (Branch _ l k _ r) = { k } \<union> keys l \<union> keys r"
-lemma pint_keys: "pin_tree k v t \<Longrightarrow> k \<in> keys t" by (induct t) auto
+lemma entry_in_tree_keys:
+ "entry_in_tree k v t \<Longrightarrow> k \<in> keys t"
+ by (induct t) auto
-primrec tlt :: "'a\<Colon>order \<Rightarrow> ('a,'b) rbt \<Rightarrow> bool"
+definition tree_less :: "'a\<Colon>order \<Rightarrow> ('a, 'b) rbt \<Rightarrow> bool"
where
- "tlt k Empty = True"
-| "tlt k (Tr c lt kt v rt) = (kt < k \<and> tlt k lt \<and> tlt k rt)"
+ tree_less_prop: "tree_less k t \<longleftrightarrow> (\<forall>x\<in>keys t. x < k)"
+
+abbreviation tree_less_symbol (infix "|\<guillemotleft>" 50)
+where "t |\<guillemotleft> x \<equiv> tree_less x t"
-abbreviation tllt (infix "|\<guillemotleft>" 50)
-where "t |\<guillemotleft> x == tlt x t"
+definition tree_greater :: "'a\<Colon>order \<Rightarrow> ('a, 'b) rbt \<Rightarrow> bool" (infix "\<guillemotleft>|" 50)
+where
+ tree_greater_prop: "tree_greater k t = (\<forall>x\<in>keys t. k < x)"
-primrec tgt :: "'a\<Colon>order \<Rightarrow> ('a,'b) rbt \<Rightarrow> bool" (infix "\<guillemotleft>|" 50)
-where
- "tgt k Empty = True"
-| "tgt k (Tr c lt kt v rt) = (k < kt \<and> tgt k lt \<and> tgt k rt)"
+lemma tree_less_simps [simp]:
+ "tree_less k Empty = True"
+ "tree_less k (Branch c lt kt v rt) \<longleftrightarrow> kt < k \<and> tree_less k lt \<and> tree_less k rt"
+ by (auto simp add: tree_less_prop)
-lemma tlt_prop: "(t |\<guillemotleft> k) = (\<forall>x\<in>keys t. x < k)" by (induct t) auto
-lemma tgt_prop: "(k \<guillemotleft>| t) = (\<forall>x\<in>keys t. k < x)" by (induct t) auto
-lemmas tlgt_props = tlt_prop tgt_prop
+lemma tree_greater_simps [simp]:
+ "tree_greater k Empty = True"
+ "tree_greater k (Branch c lt kt v rt) \<longleftrightarrow> k < kt \<and> tree_greater k lt \<and> tree_greater k rt"
+ by (auto simp add: tree_greater_prop)
-lemmas tgt_nit = tgt_prop pint_keys
-lemmas tlt_nit = tlt_prop pint_keys
+lemmas tree_ord_props = tree_less_prop tree_greater_prop
-lemma tlt_trans: "\<lbrakk> t |\<guillemotleft> x; x < y \<rbrakk> \<Longrightarrow> t |\<guillemotleft> y"
- and tgt_trans: "\<lbrakk> x < y; y \<guillemotleft>| t\<rbrakk> \<Longrightarrow> x \<guillemotleft>| t"
-by (auto simp: tlgt_props)
-
+lemmas tree_greater_nit = tree_greater_prop entry_in_tree_keys
+lemmas tree_less_nit = tree_less_prop entry_in_tree_keys
-primrec st :: "('a::linorder, 'b) rbt \<Rightarrow> bool"
-where
- "st Empty = True"
-| "st (Tr c l k v r) = (l |\<guillemotleft> k \<and> k \<guillemotleft>| r \<and> st l \<and> st r)"
+lemma tree_less_trans: "t |\<guillemotleft> x \<Longrightarrow> x < y \<Longrightarrow> t |\<guillemotleft> y"
+ and tree_greater_trans: "x < y \<Longrightarrow> y \<guillemotleft>| t \<Longrightarrow> x \<guillemotleft>| t"
+by (auto simp: tree_ord_props)
-primrec map_of :: "('a\<Colon>linorder, 'b) rbt \<Rightarrow> 'a \<rightharpoonup> 'b"
+primrec sorted :: "('a::linorder, 'b) rbt \<Rightarrow> bool"
where
- "map_of Empty k = None"
-| "map_of (Tr _ l x y r) k = (if k < x then map_of l k else if x < k then map_of r k else Some y)"
+ "sorted Empty = True"
+| "sorted (Branch c l k v r) = (l |\<guillemotleft> k \<and> k \<guillemotleft>| r \<and> sorted l \<and> sorted r)"
-lemma map_of_tlt[simp]: "t |\<guillemotleft> k \<Longrightarrow> map_of t k = None"
+primrec lookup :: "('a\<Colon>linorder, 'b) rbt \<Rightarrow> 'a \<rightharpoonup> 'b"
+where
+ "lookup Empty k = None"
+| "lookup (Branch _ l x y r) k = (if k < x then lookup l k else if x < k then lookup r k else Some y)"
+
+lemma lookup_tree_less[simp]: "t |\<guillemotleft> k \<Longrightarrow> lookup t k = None"
by (induct t) auto
-lemma map_of_tgt[simp]: "k \<guillemotleft>| t \<Longrightarrow> map_of t k = None"
+lemma lookup_tree_greater[simp]: "k \<guillemotleft>| t \<Longrightarrow> lookup t k = None"
by (induct t) auto
-lemma mapof_keys: "st t \<Longrightarrow> dom (map_of t) = keys t"
-by (induct t) (auto simp: dom_def tgt_prop tlt_prop)
+lemma lookup_keys: "sorted t \<Longrightarrow> dom (lookup t) = keys t"
+by (induct t) (auto simp: dom_def tree_greater_prop tree_less_prop)
-lemma mapof_pit: "st t \<Longrightarrow> (map_of t k = Some v) = pin_tree k v t"
-by (induct t) (auto simp: tlt_prop tgt_prop pint_keys)
+lemma lookup_pit: "sorted t \<Longrightarrow> (lookup t k = Some v) = entry_in_tree k v t"
+by (induct t) (auto simp: tree_less_prop tree_greater_prop entry_in_tree_keys)
-lemma map_of_Empty: "map_of Empty = empty"
+lemma lookup_Empty: "lookup Empty = empty"
by (rule ext) simp
(* a kind of extensionality *)
-lemma mapof_from_pit:
- assumes st: "st t1" "st t2"
- and eq: "\<And>v. pin_tree (k\<Colon>'a\<Colon>linorder) v t1 = pin_tree k v t2"
- shows "map_of t1 k = map_of t2 k"
-proof (cases "map_of t1 k")
+lemma lookup_from_pit:
+ assumes sorted: "sorted t1" "sorted t2"
+ and eq: "\<And>v. entry_in_tree (k\<Colon>'a\<Colon>linorder) v t1 = entry_in_tree k v t2"
+ shows "lookup t1 k = lookup t2 k"
+proof (cases "lookup t1 k")
case None
- then have "\<And>v. \<not> pin_tree k v t1"
- by (simp add: mapof_pit[symmetric] st)
+ then have "\<And>v. \<not> entry_in_tree k v t1"
+ by (simp add: lookup_pit[symmetric] sorted)
with None show ?thesis
- by (cases "map_of t2 k") (auto simp: mapof_pit st eq)
+ by (cases "lookup t2 k") (auto simp: lookup_pit sorted eq)
next
case (Some a)
then show ?thesis
- apply (cases "map_of t2 k")
- apply (auto simp: mapof_pit st eq)
- by (auto simp add: mapof_pit[symmetric] st Some)
+ apply (cases "lookup t2 k")
+ apply (auto simp: lookup_pit sorted eq)
+ by (auto simp add: lookup_pit[symmetric] sorted Some)
qed
subsection {* Red-black properties *}
-primrec treec :: "('a,'b) rbt \<Rightarrow> color"
+primrec color_of :: "('a, 'b) rbt \<Rightarrow> color"
where
- "treec Empty = B"
-| "treec (Tr c _ _ _ _) = c"
+ "color_of Empty = B"
+| "color_of (Branch c _ _ _ _) = c"
-primrec inv1 :: "('a,'b) rbt \<Rightarrow> bool"
+primrec bheight :: "('a,'b) rbt \<Rightarrow> nat"
+where
+ "bheight Empty = 0"
+| "bheight (Branch c lt k v rt) = (if c = B then Suc (bheight lt) else bheight lt)"
+
+primrec inv1 :: "('a, 'b) rbt \<Rightarrow> bool"
where
"inv1 Empty = True"
-| "inv1 (Tr c lt k v rt) = (inv1 lt \<and> inv1 rt \<and> (c = B \<or> treec lt = B \<and> treec rt = B))"
+| "inv1 (Branch c lt k v rt) \<longleftrightarrow> inv1 lt \<and> inv1 rt \<and> (c = B \<or> color_of lt = B \<and> color_of rt = B)"
-(* Weaker version *)
-primrec inv1l :: "('a,'b) rbt \<Rightarrow> bool"
+primrec inv1l :: "('a, 'b) rbt \<Rightarrow> bool" -- {* Weaker version *}
where
"inv1l Empty = True"
-| "inv1l (Tr c l k v r) = (inv1 l \<and> inv1 r)"
+| "inv1l (Branch c l k v r) = (inv1 l \<and> inv1 r)"
lemma [simp]: "inv1 t \<Longrightarrow> inv1l t" by (cases t) simp+
-primrec bh :: "('a,'b) rbt \<Rightarrow> nat"
-where
- "bh Empty = 0"
-| "bh (Tr c lt k v rt) = (if c = B then Suc (bh lt) else bh lt)"
-
-primrec inv2 :: "('a,'b) rbt \<Rightarrow> bool"
+primrec inv2 :: "('a, 'b) rbt \<Rightarrow> bool"
where
"inv2 Empty = True"
-| "inv2 (Tr c lt k v rt) = (inv2 lt \<and> inv2 rt \<and> bh lt = bh rt)"
+| "inv2 (Branch c lt k v rt) = (inv2 lt \<and> inv2 rt \<and> bheight lt = bheight rt)"
-definition
- "isrbt t = (inv1 t \<and> inv2 t \<and> treec t = B \<and> st t)"
-
-lemma isrbt_st[simp]: "isrbt t \<Longrightarrow> st t" by (simp add: isrbt_def)
+definition is_rbt :: "('a\<Colon>linorder, 'b) rbt \<Rightarrow> bool" where
+ "is_rbt t \<longleftrightarrow> inv1 t \<and> inv2 t \<and> color_of t = B \<and> sorted t"
-lemma rbt_cases:
- obtains (Empty) "t = Empty"
- | (Red) l k v r where "t = Tr R l k v r"
- | (Black) l k v r where "t = Tr B l k v r"
-by (cases t, simp) (case_tac "color", auto)
+lemma is_rbt_sorted [simp]:
+ "is_rbt t \<Longrightarrow> sorted t" by (simp add: is_rbt_def)
-theorem Empty_isrbt[simp]: "isrbt Empty"
-unfolding isrbt_def by simp
+theorem Empty_is_rbt [simp]:
+ "is_rbt Empty" by (simp add: is_rbt_def)
subsection {* Insertion *}
@@ -147,80 +163,80 @@
fun (* slow, due to massive case splitting *)
balance :: "('a,'b) rbt \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a,'b) rbt \<Rightarrow> ('a,'b) rbt"
where
- "balance (Tr R a w x b) s t (Tr R c y z d) = Tr R (Tr B a w x b) s t (Tr B c y z d)" |
- "balance (Tr R (Tr R a w x b) s t c) y z d = Tr R (Tr B a w x b) s t (Tr B c y z d)" |
- "balance (Tr R a w x (Tr R b s t c)) y z d = Tr R (Tr B a w x b) s t (Tr B c y z d)" |
- "balance a w x (Tr R b s t (Tr R c y z d)) = Tr R (Tr B a w x b) s t (Tr B c y z d)" |
- "balance a w x (Tr R (Tr R b s t c) y z d) = Tr R (Tr B a w x b) s t (Tr B c y z d)" |
- "balance a s t b = Tr B a s t b"
+ "balance (Branch R a w x b) s t (Branch R c y z d) = Branch R (Branch B a w x b) s t (Branch B c y z d)" |
+ "balance (Branch R (Branch R a w x b) s t c) y z d = Branch R (Branch B a w x b) s t (Branch B c y z d)" |
+ "balance (Branch R a w x (Branch R b s t c)) y z d = Branch R (Branch B a w x b) s t (Branch B c y z d)" |
+ "balance a w x (Branch R b s t (Branch R c y z d)) = Branch R (Branch B a w x b) s t (Branch B c y z d)" |
+ "balance a w x (Branch R (Branch R b s t c) y z d) = Branch R (Branch B a w x b) s t (Branch B c y z d)" |
+ "balance a s t b = Branch B a s t b"
lemma balance_inv1: "\<lbrakk>inv1l l; inv1l r\<rbrakk> \<Longrightarrow> inv1 (balance l k v r)"
by (induct l k v r rule: balance.induct) auto
-lemma balance_bh: "bh l = bh r \<Longrightarrow> bh (balance l k v r) = Suc (bh l)"
+lemma balance_bheight: "bheight l = bheight r \<Longrightarrow> bheight (balance l k v r) = Suc (bheight l)"
by (induct l k v r rule: balance.induct) auto
lemma balance_inv2:
- assumes "inv2 l" "inv2 r" "bh l = bh r"
+ assumes "inv2 l" "inv2 r" "bheight l = bheight r"
shows "inv2 (balance l k v r)"
using assms
by (induct l k v r rule: balance.induct) auto
-lemma balance_tgt[simp]: "(v \<guillemotleft>| balance a k x b) = (v \<guillemotleft>| a \<and> v \<guillemotleft>| b \<and> v < k)"
+lemma balance_tree_greater[simp]: "(v \<guillemotleft>| balance a k x b) = (v \<guillemotleft>| a \<and> v \<guillemotleft>| b \<and> v < k)"
by (induct a k x b rule: balance.induct) auto
-lemma balance_tlt[simp]: "(balance a k x b |\<guillemotleft> v) = (a |\<guillemotleft> v \<and> b |\<guillemotleft> v \<and> k < v)"
+lemma balance_tree_less[simp]: "(balance a k x b |\<guillemotleft> v) = (a |\<guillemotleft> v \<and> b |\<guillemotleft> v \<and> k < v)"
by (induct a k x b rule: balance.induct) auto
-lemma balance_st:
+lemma balance_sorted:
fixes k :: "'a::linorder"
- assumes "st l" "st r" "l |\<guillemotleft> k" "k \<guillemotleft>| r"
- shows "st (balance l k v r)"
+ assumes "sorted l" "sorted r" "l |\<guillemotleft> k" "k \<guillemotleft>| r"
+ shows "sorted (balance l k v r)"
using assms proof (induct l k v r rule: balance.induct)
case ("2_2" a x w b y t c z s va vb vd vc)
- hence "y < z \<and> z \<guillemotleft>| Tr B va vb vd vc"
- by (auto simp add: tlgt_props)
- hence "tgt y (Tr B va vb vd vc)" by (blast dest: tgt_trans)
+ hence "y < z \<and> z \<guillemotleft>| Branch B va vb vd vc"
+ by (auto simp add: tree_ord_props)
+ hence "tree_greater y (Branch B va vb vd vc)" by (blast dest: tree_greater_trans)
with "2_2" show ?case by simp
next
case ("3_2" va vb vd vc x w b y s c z)
- from "3_2" have "x < y \<and> tlt x (Tr B va vb vd vc)"
- by (simp add: tlt.simps tgt.simps)
- hence "tlt y (Tr B va vb vd vc)" by (blast dest: tlt_trans)
+ from "3_2" have "x < y \<and> tree_less x (Branch B va vb vd vc)"
+ by simp
+ hence "tree_less y (Branch B va vb vd vc)" by (blast dest: tree_less_trans)
with "3_2" show ?case by simp
next
case ("3_3" x w b y s c z t va vb vd vc)
- from "3_3" have "y < z \<and> tgt z (Tr B va vb vd vc)" by simp
- hence "tgt y (Tr B va vb vd vc)" by (blast dest: tgt_trans)
+ from "3_3" have "y < z \<and> tree_greater z (Branch B va vb vd vc)" by simp
+ hence "tree_greater y (Branch B va vb vd vc)" by (blast dest: tree_greater_trans)
with "3_3" show ?case by simp
next
case ("3_4" vd ve vg vf x w b y s c z t va vb vii vc)
- hence "x < y \<and> tlt x (Tr B vd ve vg vf)" by simp
- hence 1: "tlt y (Tr B vd ve vg vf)" by (blast dest: tlt_trans)
- from "3_4" have "y < z \<and> tgt z (Tr B va vb vii vc)" by simp
- hence "tgt y (Tr B va vb vii vc)" by (blast dest: tgt_trans)
+ hence "x < y \<and> tree_less x (Branch B vd ve vg vf)" by simp
+ hence 1: "tree_less y (Branch B vd ve vg vf)" by (blast dest: tree_less_trans)
+ from "3_4" have "y < z \<and> tree_greater z (Branch B va vb vii vc)" by simp
+ hence "tree_greater y (Branch B va vb vii vc)" by (blast dest: tree_greater_trans)
with 1 "3_4" show ?case by simp
next
case ("4_2" va vb vd vc x w b y s c z t dd)
- hence "x < y \<and> tlt x (Tr B va vb vd vc)" by simp
- hence "tlt y (Tr B va vb vd vc)" by (blast dest: tlt_trans)
+ hence "x < y \<and> tree_less x (Branch B va vb vd vc)" by simp
+ hence "tree_less y (Branch B va vb vd vc)" by (blast dest: tree_less_trans)
with "4_2" show ?case by simp
next
case ("5_2" x w b y s c z t va vb vd vc)
- hence "y < z \<and> tgt z (Tr B va vb vd vc)" by simp
- hence "tgt y (Tr B va vb vd vc)" by (blast dest: tgt_trans)
+ hence "y < z \<and> tree_greater z (Branch B va vb vd vc)" by simp
+ hence "tree_greater y (Branch B va vb vd vc)" by (blast dest: tree_greater_trans)
with "5_2" show ?case by simp
next
case ("5_3" va vb vd vc x w b y s c z t)
- hence "x < y \<and> tlt x (Tr B va vb vd vc)" by simp
- hence "tlt y (Tr B va vb vd vc)" by (blast dest: tlt_trans)
+ hence "x < y \<and> tree_less x (Branch B va vb vd vc)" by simp
+ hence "tree_less y (Branch B va vb vd vc)" by (blast dest: tree_less_trans)
with "5_3" show ?case by simp
next
case ("5_4" va vb vg vc x w b y s c z t vd ve vii vf)
- hence "x < y \<and> tlt x (Tr B va vb vg vc)" by simp
- hence 1: "tlt y (Tr B va vb vg vc)" by (blast dest: tlt_trans)
- from "5_4" have "y < z \<and> tgt z (Tr B vd ve vii vf)" by simp
- hence "tgt y (Tr B vd ve vii vf)" by (blast dest: tgt_trans)
+ hence "x < y \<and> tree_less x (Branch B va vb vg vc)" by simp
+ hence 1: "tree_less y (Branch B va vb vg vc)" by (blast dest: tree_less_trans)
+ from "5_4" have "y < z \<and> tree_greater z (Branch B vd ve vii vf)" by simp
+ hence "tree_greater y (Branch B vd ve vii vf)" by (blast dest: tree_greater_trans)
with 1 "5_4" show ?case by simp
qed simp+
@@ -229,62 +245,62 @@
by (induct l k v r rule: balance.induct) auto
lemma balance_pit:
- "pin_tree k x (balance l v y r) = (pin_tree k x l \<or> k = v \<and> x = y \<or> pin_tree k x r)"
+ "entry_in_tree k x (balance l v y r) = (entry_in_tree k x l \<or> k = v \<and> x = y \<or> entry_in_tree k x r)"
by (induct l v y r rule: balance.induct) auto
-lemma map_of_balance[simp]:
+lemma lookup_balance[simp]:
fixes k :: "'a::linorder"
-assumes "st l" "st r" "l |\<guillemotleft> k" "k \<guillemotleft>| r"
-shows "map_of (balance l k v r) x = map_of (Tr B l k v r) x"
-by (rule mapof_from_pit) (auto simp:assms balance_pit balance_st)
+assumes "sorted l" "sorted r" "l |\<guillemotleft> k" "k \<guillemotleft>| r"
+shows "lookup (balance l k v r) x = lookup (Branch B l k v r) x"
+by (rule lookup_from_pit) (auto simp:assms balance_pit balance_sorted)
primrec paint :: "color \<Rightarrow> ('a,'b) rbt \<Rightarrow> ('a,'b) rbt"
where
"paint c Empty = Empty"
-| "paint c (Tr _ l k v r) = Tr c l k v r"
+| "paint c (Branch _ l k v r) = Branch c l k v r"
lemma paint_inv1l[simp]: "inv1l t \<Longrightarrow> inv1l (paint c t)" by (cases t) auto
lemma paint_inv1[simp]: "inv1l t \<Longrightarrow> inv1 (paint B t)" by (cases t) auto
lemma paint_inv2[simp]: "inv2 t \<Longrightarrow> inv2 (paint c t)" by (cases t) auto
-lemma paint_treec[simp]: "treec (paint B t) = B" by (cases t) auto
-lemma paint_st[simp]: "st t \<Longrightarrow> st (paint c t)" by (cases t) auto
-lemma paint_pit[simp]: "pin_tree k x (paint c t) = pin_tree k x t" by (cases t) auto
-lemma paint_mapof[simp]: "map_of (paint c t) = map_of t" by (rule ext) (cases t, auto)
-lemma paint_tgt[simp]: "(v \<guillemotleft>| paint c t) = (v \<guillemotleft>| t)" by (cases t) auto
-lemma paint_tlt[simp]: "(paint c t |\<guillemotleft> v) = (t |\<guillemotleft> v)" by (cases t) auto
+lemma paint_color_of[simp]: "color_of (paint B t) = B" by (cases t) auto
+lemma paint_sorted[simp]: "sorted t \<Longrightarrow> sorted (paint c t)" by (cases t) auto
+lemma paint_pit[simp]: "entry_in_tree k x (paint c t) = entry_in_tree k x t" by (cases t) auto
+lemma paint_lookup[simp]: "lookup (paint c t) = lookup t" by (rule ext) (cases t, auto)
+lemma paint_tree_greater[simp]: "(v \<guillemotleft>| paint c t) = (v \<guillemotleft>| t)" by (cases t) auto
+lemma paint_tree_less[simp]: "(paint c t |\<guillemotleft> v) = (t |\<guillemotleft> v)" by (cases t) auto
fun
ins :: "('a\<Colon>linorder \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a,'b) rbt \<Rightarrow> ('a,'b) rbt"
where
- "ins f k v Empty = Tr R Empty k v Empty" |
- "ins f k v (Tr B l x y r) = (if k < x then balance (ins f k v l) x y r
+ "ins f k v Empty = Branch R Empty k v Empty" |
+ "ins f k v (Branch B l x y r) = (if k < x then balance (ins f k v l) x y r
else if k > x then balance l x y (ins f k v r)
- else Tr B l x (f k y v) r)" |
- "ins f k v (Tr R l x y r) = (if k < x then Tr R (ins f k v l) x y r
- else if k > x then Tr R l x y (ins f k v r)
- else Tr R l x (f k y v) r)"
+ else Branch B l x (f k y v) r)" |
+ "ins f k v (Branch R l x y r) = (if k < x then Branch R (ins f k v l) x y r
+ else if k > x then Branch R l x y (ins f k v r)
+ else Branch R l x (f k y v) r)"
lemma ins_inv1_inv2:
assumes "inv1 t" "inv2 t"
- shows "inv2 (ins f k x t)" "bh (ins f k x t) = bh t"
- "treec t = B \<Longrightarrow> inv1 (ins f k x t)" "inv1l (ins f k x t)"
+ shows "inv2 (ins f k x t)" "bheight (ins f k x t) = bheight t"
+ "color_of t = B \<Longrightarrow> inv1 (ins f k x t)" "inv1l (ins f k x t)"
using assms
- by (induct f k x t rule: ins.induct) (auto simp: balance_inv1 balance_inv2 balance_bh)
+ by (induct f k x t rule: ins.induct) (auto simp: balance_inv1 balance_inv2 balance_bheight)
-lemma ins_tgt[simp]: "(v \<guillemotleft>| ins f k x t) = (v \<guillemotleft>| t \<and> k > v)"
+lemma ins_tree_greater[simp]: "(v \<guillemotleft>| ins f k x t) = (v \<guillemotleft>| t \<and> k > v)"
by (induct f k x t rule: ins.induct) auto
-lemma ins_tlt[simp]: "(ins f k x t |\<guillemotleft> v) = (t |\<guillemotleft> v \<and> k < v)"
+lemma ins_tree_less[simp]: "(ins f k x t |\<guillemotleft> v) = (t |\<guillemotleft> v \<and> k < v)"
by (induct f k x t rule: ins.induct) auto
-lemma ins_st[simp]: "st t \<Longrightarrow> st (ins f k x t)"
- by (induct f k x t rule: ins.induct) (auto simp: balance_st)
+lemma ins_sorted[simp]: "sorted t \<Longrightarrow> sorted (ins f k x t)"
+ by (induct f k x t rule: ins.induct) (auto simp: balance_sorted)
lemma keys_ins: "keys (ins f k v t) = { k } \<union> keys t"
by (induct f k v t rule: ins.induct) auto
-lemma map_of_ins:
+lemma lookup_ins:
fixes k :: "'a::linorder"
- assumes "st t"
- shows "map_of (ins f k v t) x = ((map_of t)(k |-> case map_of t k of None \<Rightarrow> v
+ assumes "sorted t"
+ shows "lookup (ins f k v t) x = ((lookup t)(k |-> case lookup t k of None \<Rightarrow> v
| Some w \<Rightarrow> f k w v)) x"
using assms by (induct f k v t rule: ins.induct) auto
@@ -293,98 +309,97 @@
where
"insertwithkey f k v t = paint B (ins f k v t)"
-lemma insertwk_st: "st t \<Longrightarrow> st (insertwithkey f k x t)"
+lemma insertwk_sorted: "sorted t \<Longrightarrow> sorted (insertwithkey f k x t)"
by (auto simp: insertwithkey_def)
-theorem insertwk_isrbt:
- assumes inv: "isrbt t"
- shows "isrbt (insertwithkey f k x t)"
+theorem insertwk_is_rbt:
+ assumes inv: "is_rbt t"
+ shows "is_rbt (insertwithkey f k x t)"
using assms
-unfolding insertwithkey_def isrbt_def
+unfolding insertwithkey_def is_rbt_def
by (auto simp: ins_inv1_inv2)
-lemma map_of_insertwk:
- assumes "st t"
- shows "map_of (insertwithkey f k v t) x = ((map_of t)(k |-> case map_of t k of None \<Rightarrow> v
+lemma lookup_insertwk:
+ assumes "sorted t"
+ shows "lookup (insertwithkey f k v t) x = ((lookup t)(k |-> case lookup t k of None \<Rightarrow> v
| Some w \<Rightarrow> f k w v)) x"
unfolding insertwithkey_def using assms
-by (simp add:map_of_ins)
+by (simp add:lookup_ins)
definition
insertw_def: "insertwith f = insertwithkey (\<lambda>_. f)"
-lemma insertw_st: "st t \<Longrightarrow> st (insertwith f k v t)" by (simp add: insertwk_st insertw_def)
-theorem insertw_isrbt: "isrbt t \<Longrightarrow> isrbt (insertwith f k v t)" by (simp add: insertwk_isrbt insertw_def)
+lemma insertw_sorted: "sorted t \<Longrightarrow> sorted (insertwith f k v t)" by (simp add: insertwk_sorted insertw_def)
+theorem insertw_is_rbt: "is_rbt t \<Longrightarrow> is_rbt (insertwith f k v t)" by (simp add: insertwk_is_rbt insertw_def)
-lemma map_of_insertw:
- assumes "isrbt t"
- shows "map_of (insertwith f k v t) = (map_of t)(k \<mapsto> (if k:dom (map_of t) then f (the (map_of t k)) v else v))"
+lemma lookup_insertw:
+ assumes "is_rbt t"
+ shows "lookup (insertwith f k v t) = (lookup t)(k \<mapsto> (if k:dom (lookup t) then f (the (lookup t k)) v else v))"
using assms
unfolding insertw_def
-by (rule_tac ext) (cases "map_of t k", auto simp:map_of_insertwk dom_def)
-
+by (rule_tac ext) (cases "lookup t k", auto simp:lookup_insertwk dom_def)
-definition
- "insrt k v t = insertwithkey (\<lambda>_ _ nv. nv) k v t"
+definition insert :: "'a\<Colon>linorder \<Rightarrow> 'b \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt" where
+ "insert k v t = insertwithkey (\<lambda>_ _ nv. nv) k v t"
-lemma insrt_st: "st t \<Longrightarrow> st (insrt k v t)" by (simp add: insertwk_st insrt_def)
-theorem insrt_isrbt: "isrbt t \<Longrightarrow> isrbt (insrt k v t)" by (simp add: insertwk_isrbt insrt_def)
+lemma insert_sorted: "sorted t \<Longrightarrow> sorted (insert k v t)" by (simp add: insertwk_sorted insert_def)
+theorem insert_is_rbt: "is_rbt t \<Longrightarrow> is_rbt (insert k v t)" by (simp add: insertwk_is_rbt insert_def)
-lemma map_of_insert:
- assumes "isrbt t"
- shows "map_of (insrt k v t) = (map_of t)(k\<mapsto>v)"
-unfolding insrt_def
+lemma lookup_insert:
+ assumes "is_rbt t"
+ shows "lookup (insert k v t) = (lookup t)(k\<mapsto>v)"
+unfolding insert_def
using assms
-by (rule_tac ext) (simp add: map_of_insertwk split:option.split)
+by (rule_tac ext) (simp add: lookup_insertwk split:option.split)
subsection {* Deletion *}
-lemma bh_paintR'[simp]: "treec t = B \<Longrightarrow> bh (paint R t) = bh t - 1"
+lemma bheight_paintR'[simp]: "color_of t = B \<Longrightarrow> bheight (paint R t) = bheight t - 1"
by (cases t rule: rbt_cases) auto
fun
balleft :: "('a,'b) rbt \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a,'b) rbt \<Rightarrow> ('a,'b) rbt"
where
- "balleft (Tr R a k x b) s y c = Tr R (Tr B a k x b) s y c" |
- "balleft bl k x (Tr B a s y b) = balance bl k x (Tr R a s y b)" |
- "balleft bl k x (Tr R (Tr B a s y b) t z c) = Tr R (Tr B bl k x a) s y (balance b t z (paint R c))" |
+ "balleft (Branch R a k x b) s y c = Branch R (Branch B a k x b) s y c" |
+ "balleft bl k x (Branch B a s y b) = balance bl k x (Branch R a s y b)" |
+ "balleft bl k x (Branch R (Branch B a s y b) t z c) = Branch R (Branch B bl k x a) s y (balance b t z (paint R c))" |
"balleft t k x s = Empty"
lemma balleft_inv2_with_inv1:
- assumes "inv2 lt" "inv2 rt" "bh lt + 1 = bh rt" "inv1 rt"
- shows "bh (balleft lt k v rt) = bh lt + 1"
+ assumes "inv2 lt" "inv2 rt" "bheight lt + 1 = bheight rt" "inv1 rt"
+ shows "bheight (balleft lt k v rt) = bheight lt + 1"
and "inv2 (balleft lt k v rt)"
using assms
-by (induct lt k v rt rule: balleft.induct) (auto simp: balance_inv2 balance_bh)
+by (induct lt k v rt rule: balleft.induct) (auto simp: balance_inv2 balance_bheight)
lemma balleft_inv2_app:
- assumes "inv2 lt" "inv2 rt" "bh lt + 1 = bh rt" "treec rt = B"
+ assumes "inv2 lt" "inv2 rt" "bheight lt + 1 = bheight rt" "color_of rt = B"
shows "inv2 (balleft lt k v rt)"
- "bh (balleft lt k v rt) = bh rt"
+ "bheight (balleft lt k v rt) = bheight rt"
using assms
-by (induct lt k v rt rule: balleft.induct) (auto simp add: balance_inv2 balance_bh)+
+by (induct lt k v rt rule: balleft.induct) (auto simp add: balance_inv2 balance_bheight)+
-lemma balleft_inv1: "\<lbrakk>inv1l a; inv1 b; treec b = B\<rbrakk> \<Longrightarrow> inv1 (balleft a k x b)"
+lemma balleft_inv1: "\<lbrakk>inv1l a; inv1 b; color_of b = B\<rbrakk> \<Longrightarrow> inv1 (balleft a k x b)"
by (induct a k x b rule: balleft.induct) (simp add: balance_inv1)+
lemma balleft_inv1l: "\<lbrakk> inv1l lt; inv1 rt \<rbrakk> \<Longrightarrow> inv1l (balleft lt k x rt)"
by (induct lt k x rt rule: balleft.induct) (auto simp: balance_inv1)
-lemma balleft_st: "\<lbrakk> st l; st r; tlt k l; tgt k r \<rbrakk> \<Longrightarrow> st (balleft l k v r)"
+lemma balleft_sorted: "\<lbrakk> sorted l; sorted r; tree_less k l; tree_greater k r \<rbrakk> \<Longrightarrow> sorted (balleft l k v r)"
apply (induct l k v r rule: balleft.induct)
-apply (auto simp: balance_st)
-apply (unfold tgt_prop tlt_prop)
+apply (auto simp: balance_sorted)
+apply (unfold tree_greater_prop tree_less_prop)
by force+
-lemma balleft_tgt:
+lemma balleft_tree_greater:
fixes k :: "'a::order"
assumes "k \<guillemotleft>| a" "k \<guillemotleft>| b" "k < x"
shows "k \<guillemotleft>| balleft a x t b"
using assms
by (induct a x t b rule: balleft.induct) auto
-lemma balleft_tlt:
+lemma balleft_tree_less:
fixes k :: "'a::order"
assumes "a |\<guillemotleft> k" "b |\<guillemotleft> k" "x < k"
shows "balleft a x t b |\<guillemotleft> k"
@@ -392,52 +407,52 @@
by (induct a x t b rule: balleft.induct) auto
lemma balleft_pit:
- assumes "inv1l l" "inv1 r" "bh l + 1 = bh r"
- shows "pin_tree k v (balleft l a b r) = (pin_tree k v l \<or> k = a \<and> v = b \<or> pin_tree k v r)"
+ assumes "inv1l l" "inv1 r" "bheight l + 1 = bheight r"
+ shows "entry_in_tree k v (balleft l a b r) = (entry_in_tree k v l \<or> k = a \<and> v = b \<or> entry_in_tree k v r)"
using assms
by (induct l k v r rule: balleft.induct) (auto simp: balance_pit)
fun
balright :: "('a,'b) rbt \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a,'b) rbt \<Rightarrow> ('a,'b) rbt"
where
- "balright a k x (Tr R b s y c) = Tr R a k x (Tr B b s y c)" |
- "balright (Tr B a k x b) s y bl = balance (Tr R a k x b) s y bl" |
- "balright (Tr R a k x (Tr B b s y c)) t z bl = Tr R (balance (paint R a) k x b) s y (Tr B c t z bl)" |
+ "balright a k x (Branch R b s y c) = Branch R a k x (Branch B b s y c)" |
+ "balright (Branch B a k x b) s y bl = balance (Branch R a k x b) s y bl" |
+ "balright (Branch R a k x (Branch B b s y c)) t z bl = Branch R (balance (paint R a) k x b) s y (Branch B c t z bl)" |
"balright t k x s = Empty"
lemma balright_inv2_with_inv1:
- assumes "inv2 lt" "inv2 rt" "bh lt = bh rt + 1" "inv1 lt"
- shows "inv2 (balright lt k v rt) \<and> bh (balright lt k v rt) = bh lt"
+ assumes "inv2 lt" "inv2 rt" "bheight lt = bheight rt + 1" "inv1 lt"
+ shows "inv2 (balright lt k v rt) \<and> bheight (balright lt k v rt) = bheight lt"
using assms
-by (induct lt k v rt rule: balright.induct) (auto simp: balance_inv2 balance_bh)
+by (induct lt k v rt rule: balright.induct) (auto simp: balance_inv2 balance_bheight)
-lemma balright_inv1: "\<lbrakk>inv1 a; inv1l b; treec a = B\<rbrakk> \<Longrightarrow> inv1 (balright a k x b)"
+lemma balright_inv1: "\<lbrakk>inv1 a; inv1l b; color_of a = B\<rbrakk> \<Longrightarrow> inv1 (balright a k x b)"
by (induct a k x b rule: balright.induct) (simp add: balance_inv1)+
lemma balright_inv1l: "\<lbrakk> inv1 lt; inv1l rt \<rbrakk> \<Longrightarrow>inv1l (balright lt k x rt)"
by (induct lt k x rt rule: balright.induct) (auto simp: balance_inv1)
-lemma balright_st: "\<lbrakk> st l; st r; tlt k l; tgt k r \<rbrakk> \<Longrightarrow> st (balright l k v r)"
+lemma balright_sorted: "\<lbrakk> sorted l; sorted r; tree_less k l; tree_greater k r \<rbrakk> \<Longrightarrow> sorted (balright l k v r)"
apply (induct l k v r rule: balright.induct)
-apply (auto simp:balance_st)
-apply (unfold tlt_prop tgt_prop)
+apply (auto simp:balance_sorted)
+apply (unfold tree_less_prop tree_greater_prop)
by force+
-lemma balright_tgt:
+lemma balright_tree_greater:
fixes k :: "'a::order"
assumes "k \<guillemotleft>| a" "k \<guillemotleft>| b" "k < x"
shows "k \<guillemotleft>| balright a x t b"
using assms by (induct a x t b rule: balright.induct) auto
-lemma balright_tlt:
+lemma balright_tree_less:
fixes k :: "'a::order"
assumes "a |\<guillemotleft> k" "b |\<guillemotleft> k" "x < k"
shows "balright a x t b |\<guillemotleft> k"
using assms by (induct a x t b rule: balright.induct) auto
lemma balright_pit:
- assumes "inv1 l" "inv1l r" "bh l = bh r + 1" "inv2 l" "inv2 r"
- shows "pin_tree x y (balright l k v r) = (pin_tree x y l \<or> x = k \<and> y = v \<or> pin_tree x y r)"
+ assumes "inv1 l" "inv1l r" "bheight l = bheight r + 1" "inv2 l" "inv2 r"
+ shows "entry_in_tree x y (balright l k v r) = (entry_in_tree x y l \<or> x = k \<and> y = v \<or> entry_in_tree x y r)"
using assms by (induct l k v r rule: balright.induct) (auto simp: balance_pit)
@@ -448,50 +463,50 @@
where
"app Empty x = x"
| "app x Empty = x"
-| "app (Tr R a k x b) (Tr R c s y d) = (case (app b c) of
- Tr R b2 t z c2 \<Rightarrow> (Tr R (Tr R a k x b2) t z (Tr R c2 s y d)) |
- bc \<Rightarrow> Tr R a k x (Tr R bc s y d))"
-| "app (Tr B a k x b) (Tr B c s y d) = (case (app b c) of
- Tr R b2 t z c2 \<Rightarrow> Tr R (Tr B a k x b2) t z (Tr B c2 s y d) |
- bc \<Rightarrow> balleft a k x (Tr B bc s y d))"
-| "app a (Tr R b k x c) = Tr R (app a b) k x c"
-| "app (Tr R a k x b) c = Tr R a k x (app b c)"
+| "app (Branch R a k x b) (Branch R c s y d) = (case (app b c) of
+ Branch R b2 t z c2 \<Rightarrow> (Branch R (Branch R a k x b2) t z (Branch R c2 s y d)) |
+ bc \<Rightarrow> Branch R a k x (Branch R bc s y d))"
+| "app (Branch B a k x b) (Branch B c s y d) = (case (app b c) of
+ Branch R b2 t z c2 \<Rightarrow> Branch R (Branch B a k x b2) t z (Branch B c2 s y d) |
+ bc \<Rightarrow> balleft a k x (Branch B bc s y d))"
+| "app a (Branch R b k x c) = Branch R (app a b) k x c"
+| "app (Branch R a k x b) c = Branch R a k x (app b c)"
lemma app_inv2:
- assumes "inv2 lt" "inv2 rt" "bh lt = bh rt"
- shows "bh (app lt rt) = bh lt" "inv2 (app lt rt)"
+ assumes "inv2 lt" "inv2 rt" "bheight lt = bheight rt"
+ shows "bheight (app lt rt) = bheight lt" "inv2 (app lt rt)"
using assms
by (induct lt rt rule: app.induct)
(auto simp: balleft_inv2_app split: rbt.splits color.splits)
lemma app_inv1:
assumes "inv1 lt" "inv1 rt"
- shows "treec lt = B \<Longrightarrow> treec rt = B \<Longrightarrow> inv1 (app lt rt)"
+ shows "color_of lt = B \<Longrightarrow> color_of rt = B \<Longrightarrow> inv1 (app lt rt)"
"inv1l (app lt rt)"
using assms
by (induct lt rt rule: app.induct)
(auto simp: balleft_inv1 split: rbt.splits color.splits)
-lemma app_tgt[simp]:
+lemma app_tree_greater[simp]:
fixes k :: "'a::linorder"
assumes "k \<guillemotleft>| l" "k \<guillemotleft>| r"
shows "k \<guillemotleft>| app l r"
using assms
by (induct l r rule: app.induct)
- (auto simp: balleft_tgt split:rbt.splits color.splits)
+ (auto simp: balleft_tree_greater split:rbt.splits color.splits)
-lemma app_tlt[simp]:
+lemma app_tree_less[simp]:
fixes k :: "'a::linorder"
assumes "l |\<guillemotleft> k" "r |\<guillemotleft> k"
shows "app l r |\<guillemotleft> k"
using assms
by (induct l r rule: app.induct)
- (auto simp: balleft_tlt split:rbt.splits color.splits)
+ (auto simp: balleft_tree_less split:rbt.splits color.splits)
-lemma app_st:
+lemma app_sorted:
fixes k :: "'a::linorder"
- assumes "st l" "st r" "l |\<guillemotleft> k" "k \<guillemotleft>| r"
- shows "st (app l r)"
+ assumes "sorted l" "sorted r" "l |\<guillemotleft> k" "k \<guillemotleft>| r"
+ shows "sorted (app l r)"
using assms proof (induct l r rule: app.induct)
case (3 a x v b c y w d)
hence ineqs: "a |\<guillemotleft> x" "x \<guillemotleft>| b" "b |\<guillemotleft> k" "k \<guillemotleft>| c" "c |\<guillemotleft> y" "y \<guillemotleft>| d"
@@ -500,55 +515,55 @@
show ?case
apply (cases "app b c" rule: rbt_cases)
apply auto
- by (metis app_tgt app_tlt ineqs ineqs tlt.simps(2) tgt.simps(2) tgt_trans tlt_trans)+
+ by (metis app_tree_greater app_tree_less ineqs ineqs tree_less_simps(2) tree_greater_simps(2) tree_greater_trans tree_less_trans)+
next
case (4 a x v b c y w d)
- hence "x < k \<and> tgt k c" by simp
- hence "tgt x c" by (blast dest: tgt_trans)
- with 4 have 2: "tgt x (app b c)" by (simp add: app_tgt)
- from 4 have "k < y \<and> tlt k b" by simp
- hence "tlt y b" by (blast dest: tlt_trans)
- with 4 have 3: "tlt y (app b c)" by (simp add: app_tlt)
+ hence "x < k \<and> tree_greater k c" by simp
+ hence "tree_greater x c" by (blast dest: tree_greater_trans)
+ with 4 have 2: "tree_greater x (app b c)" by (simp add: app_tree_greater)
+ from 4 have "k < y \<and> tree_less k b" by simp
+ hence "tree_less y b" by (blast dest: tree_less_trans)
+ with 4 have 3: "tree_less y (app b c)" by (simp add: app_tree_less)
show ?case
proof (cases "app b c" rule: rbt_cases)
case Empty
- from 4 have "x < y \<and> tgt y d" by auto
- hence "tgt x d" by (blast dest: tgt_trans)
- with 4 Empty have "st a" and "st (Tr B Empty y w d)" and "tlt x a" and "tgt x (Tr B Empty y w d)" by auto
- with Empty show ?thesis by (simp add: balleft_st)
+ from 4 have "x < y \<and> tree_greater y d" by auto
+ hence "tree_greater x d" by (blast dest: tree_greater_trans)
+ with 4 Empty have "sorted a" and "sorted (Branch B Empty y w d)" and "tree_less x a" and "tree_greater x (Branch B Empty y w d)" by auto
+ with Empty show ?thesis by (simp add: balleft_sorted)
next
case (Red lta va ka rta)
- with 2 4 have "x < va \<and> tlt x a" by simp
- hence 5: "tlt va a" by (blast dest: tlt_trans)
- from Red 3 4 have "va < y \<and> tgt y d" by simp
- hence "tgt va d" by (blast dest: tgt_trans)
+ with 2 4 have "x < va \<and> tree_less x a" by simp
+ hence 5: "tree_less va a" by (blast dest: tree_less_trans)
+ from Red 3 4 have "va < y \<and> tree_greater y d" by simp
+ hence "tree_greater va d" by (blast dest: tree_greater_trans)
with Red 2 3 4 5 show ?thesis by simp
next
case (Black lta va ka rta)
- from 4 have "x < y \<and> tgt y d" by auto
- hence "tgt x d" by (blast dest: tgt_trans)
- with Black 2 3 4 have "st a" and "st (Tr B (app b c) y w d)" and "tlt x a" and "tgt x (Tr B (app b c) y w d)" by auto
- with Black show ?thesis by (simp add: balleft_st)
+ from 4 have "x < y \<and> tree_greater y d" by auto
+ hence "tree_greater x d" by (blast dest: tree_greater_trans)
+ with Black 2 3 4 have "sorted a" and "sorted (Branch B (app b c) y w d)" and "tree_less x a" and "tree_greater x (Branch B (app b c) y w d)" by auto
+ with Black show ?thesis by (simp add: balleft_sorted)
qed
next
case (5 va vb vd vc b x w c)
- hence "k < x \<and> tlt k (Tr B va vb vd vc)" by simp
- hence "tlt x (Tr B va vb vd vc)" by (blast dest: tlt_trans)
- with 5 show ?case by (simp add: app_tlt)
+ hence "k < x \<and> tree_less k (Branch B va vb vd vc)" by simp
+ hence "tree_less x (Branch B va vb vd vc)" by (blast dest: tree_less_trans)
+ with 5 show ?case by (simp add: app_tree_less)
next
case (6 a x v b va vb vd vc)
- hence "x < k \<and> tgt k (Tr B va vb vd vc)" by simp
- hence "tgt x (Tr B va vb vd vc)" by (blast dest: tgt_trans)
- with 6 show ?case by (simp add: app_tgt)
+ hence "x < k \<and> tree_greater k (Branch B va vb vd vc)" by simp
+ hence "tree_greater x (Branch B va vb vd vc)" by (blast dest: tree_greater_trans)
+ with 6 show ?case by (simp add: app_tree_greater)
qed simp+
lemma app_pit:
- assumes "inv2 l" "inv2 r" "bh l = bh r" "inv1 l" "inv1 r"
- shows "pin_tree k v (app l r) = (pin_tree k v l \<or> pin_tree k v r)"
+ assumes "inv2 l" "inv2 r" "bheight l = bheight r" "inv1 l" "inv1 r"
+ shows "entry_in_tree k v (app l r) = (entry_in_tree k v l \<or> entry_in_tree k v r)"
using assms
proof (induct l r rule: app.induct)
case (4 _ _ _ b c)
- hence a: "bh (app b c) = bh b" by (simp add: app_inv2)
+ hence a: "bheight (app b c) = bheight b" by (simp add: app_inv2)
from 4 have b: "inv1l (app b c)" by (simp add: app_inv1)
show ?case
@@ -570,21 +585,21 @@
del :: "('a\<Colon>linorder) \<Rightarrow> ('a,'b) rbt \<Rightarrow> ('a,'b) rbt"
where
"del x Empty = Empty" |
- "del x (Tr c a y s b) = (if x < y then delformLeft x a y s b else (if x > y then delformRight x a y s b else app a b))" |
- "delformLeft x (Tr B lt z v rt) y s b = balleft (del x (Tr B lt z v rt)) y s b" |
- "delformLeft x a y s b = Tr R (del x a) y s b" |
- "delformRight x a y s (Tr B lt z v rt) = balright a y s (del x (Tr B lt z v rt))" |
- "delformRight x a y s b = Tr R a y s (del x b)"
+ "del x (Branch c a y s b) = (if x < y then delformLeft x a y s b else (if x > y then delformRight x a y s b else app a b))" |
+ "delformLeft x (Branch B lt z v rt) y s b = balleft (del x (Branch B lt z v rt)) y s b" |
+ "delformLeft x a y s b = Branch R (del x a) y s b" |
+ "delformRight x a y s (Branch B lt z v rt) = balright a y s (del x (Branch B lt z v rt))" |
+ "delformRight x a y s b = Branch R a y s (del x b)"
lemma
assumes "inv2 lt" "inv1 lt"
shows
- "\<lbrakk>inv2 rt; bh lt = bh rt; inv1 rt\<rbrakk> \<Longrightarrow>
- inv2 (delformLeft x lt k v rt) \<and> bh (delformLeft x lt k v rt) = bh lt \<and> (treec lt = B \<and> treec rt = B \<and> inv1 (delformLeft x lt k v rt) \<or> (treec lt \<noteq> B \<or> treec rt \<noteq> B) \<and> inv1l (delformLeft x lt k v rt))"
- and "\<lbrakk>inv2 rt; bh lt = bh rt; inv1 rt\<rbrakk> \<Longrightarrow>
- inv2 (delformRight x lt k v rt) \<and> bh (delformRight x lt k v rt) = bh lt \<and> (treec lt = B \<and> treec rt = B \<and> inv1 (delformRight x lt k v rt) \<or> (treec lt \<noteq> B \<or> treec rt \<noteq> B) \<and> inv1l (delformRight x lt k v rt))"
- and del_inv1_inv2: "inv2 (del x lt) \<and> (treec lt = R \<and> bh (del x lt) = bh lt \<and> inv1 (del x lt)
- \<or> treec lt = B \<and> bh (del x lt) = bh lt - 1 \<and> inv1l (del x lt))"
+ "\<lbrakk>inv2 rt; bheight lt = bheight rt; inv1 rt\<rbrakk> \<Longrightarrow>
+ inv2 (delformLeft x lt k v rt) \<and> bheight (delformLeft x lt k v rt) = bheight lt \<and> (color_of lt = B \<and> color_of rt = B \<and> inv1 (delformLeft x lt k v rt) \<or> (color_of lt \<noteq> B \<or> color_of rt \<noteq> B) \<and> inv1l (delformLeft x lt k v rt))"
+ and "\<lbrakk>inv2 rt; bheight lt = bheight rt; inv1 rt\<rbrakk> \<Longrightarrow>
+ inv2 (delformRight x lt k v rt) \<and> bheight (delformRight x lt k v rt) = bheight lt \<and> (color_of lt = B \<and> color_of rt = B \<and> inv1 (delformRight x lt k v rt) \<or> (color_of lt \<noteq> B \<or> color_of rt \<noteq> B) \<and> inv1l (delformRight x lt k v rt))"
+ and del_inv1_inv2: "inv2 (del x lt) \<and> (color_of lt = R \<and> bheight (del x lt) = bheight lt \<and> inv1 (del x lt)
+ \<or> color_of lt = B \<and> bheight (del x lt) = bheight lt - 1 \<and> inv1l (del x lt))"
using assms
proof (induct x lt k v rt and x lt k v rt and x lt rule: delformLeft_delformRight_del.induct)
case (2 y c _ y')
@@ -601,55 +616,55 @@
qed
next
case (3 y lt z v rta y' ss bb)
- thus ?case by (cases "treec (Tr B lt z v rta) = B \<and> treec bb = B") (simp add: balleft_inv2_with_inv1 balleft_inv1 balleft_inv1l)+
+ thus ?case by (cases "color_of (Branch B lt z v rta) = B \<and> color_of bb = B") (simp add: balleft_inv2_with_inv1 balleft_inv1 balleft_inv1l)+
next
case (5 y a y' ss lt z v rta)
- thus ?case by (cases "treec a = B \<and> treec (Tr B lt z v rta) = B") (simp add: balright_inv2_with_inv1 balright_inv1 balright_inv1l)+
+ thus ?case by (cases "color_of a = B \<and> color_of (Branch B lt z v rta) = B") (simp add: balright_inv2_with_inv1 balright_inv1 balright_inv1l)+
next
- case ("6_1" y a y' ss) thus ?case by (cases "treec a = B \<and> treec Empty = B") simp+
+ case ("6_1" y a y' ss) thus ?case by (cases "color_of a = B \<and> color_of Empty = B") simp+
qed auto
lemma
- delformLeft_tlt: "\<lbrakk>tlt v lt; tlt v rt; k < v\<rbrakk> \<Longrightarrow> tlt v (delformLeft x lt k y rt)"
- and delformRight_tlt: "\<lbrakk>tlt v lt; tlt v rt; k < v\<rbrakk> \<Longrightarrow> tlt v (delformRight x lt k y rt)"
- and del_tlt: "tlt v lt \<Longrightarrow> tlt v (del x lt)"
+ delformLeft_tree_less: "\<lbrakk>tree_less v lt; tree_less v rt; k < v\<rbrakk> \<Longrightarrow> tree_less v (delformLeft x lt k y rt)"
+ and delformRight_tree_less: "\<lbrakk>tree_less v lt; tree_less v rt; k < v\<rbrakk> \<Longrightarrow> tree_less v (delformRight x lt k y rt)"
+ and del_tree_less: "tree_less v lt \<Longrightarrow> tree_less v (del x lt)"
by (induct x lt k y rt and x lt k y rt and x lt rule: delformLeft_delformRight_del.induct)
- (auto simp: balleft_tlt balright_tlt)
+ (auto simp: balleft_tree_less balright_tree_less)
-lemma delformLeft_tgt: "\<lbrakk>tgt v lt; tgt v rt; k > v\<rbrakk> \<Longrightarrow> tgt v (delformLeft x lt k y rt)"
- and delformRight_tgt: "\<lbrakk>tgt v lt; tgt v rt; k > v\<rbrakk> \<Longrightarrow> tgt v (delformRight x lt k y rt)"
- and del_tgt: "tgt v lt \<Longrightarrow> tgt v (del x lt)"
+lemma delformLeft_tree_greater: "\<lbrakk>tree_greater v lt; tree_greater v rt; k > v\<rbrakk> \<Longrightarrow> tree_greater v (delformLeft x lt k y rt)"
+ and delformRight_tree_greater: "\<lbrakk>tree_greater v lt; tree_greater v rt; k > v\<rbrakk> \<Longrightarrow> tree_greater v (delformRight x lt k y rt)"
+ and del_tree_greater: "tree_greater v lt \<Longrightarrow> tree_greater v (del x lt)"
by (induct x lt k y rt and x lt k y rt and x lt rule: delformLeft_delformRight_del.induct)
- (auto simp: balleft_tgt balright_tgt)
+ (auto simp: balleft_tree_greater balright_tree_greater)
-lemma "\<lbrakk>st lt; st rt; tlt k lt; tgt k rt\<rbrakk> \<Longrightarrow> st (delformLeft x lt k y rt)"
- and "\<lbrakk>st lt; st rt; tlt k lt; tgt k rt\<rbrakk> \<Longrightarrow> st (delformRight x lt k y rt)"
- and del_st: "st lt \<Longrightarrow> st (del x lt)"
+lemma "\<lbrakk>sorted lt; sorted rt; tree_less k lt; tree_greater k rt\<rbrakk> \<Longrightarrow> sorted (delformLeft x lt k y rt)"
+ and "\<lbrakk>sorted lt; sorted rt; tree_less k lt; tree_greater k rt\<rbrakk> \<Longrightarrow> sorted (delformRight x lt k y rt)"
+ and del_sorted: "sorted lt \<Longrightarrow> sorted (del x lt)"
proof (induct x lt k y rt and x lt k y rt and x lt rule: delformLeft_delformRight_del.induct)
case (3 x lta zz v rta yy ss bb)
- from 3 have "tlt yy (Tr B lta zz v rta)" by simp
- hence "tlt yy (del x (Tr B lta zz v rta))" by (rule del_tlt)
- with 3 show ?case by (simp add: balleft_st)
+ from 3 have "tree_less yy (Branch B lta zz v rta)" by simp
+ hence "tree_less yy (del x (Branch B lta zz v rta))" by (rule del_tree_less)
+ with 3 show ?case by (simp add: balleft_sorted)
next
case ("4_2" x vaa vbb vdd vc yy ss bb)
- hence "tlt yy (Tr R vaa vbb vdd vc)" by simp
- hence "tlt yy (del x (Tr R vaa vbb vdd vc))" by (rule del_tlt)
+ hence "tree_less yy (Branch R vaa vbb vdd vc)" by simp
+ hence "tree_less yy (del x (Branch R vaa vbb vdd vc))" by (rule del_tree_less)
with "4_2" show ?case by simp
next
case (5 x aa yy ss lta zz v rta)
- hence "tgt yy (Tr B lta zz v rta)" by simp
- hence "tgt yy (del x (Tr B lta zz v rta))" by (rule del_tgt)
- with 5 show ?case by (simp add: balright_st)
+ hence "tree_greater yy (Branch B lta zz v rta)" by simp
+ hence "tree_greater yy (del x (Branch B lta zz v rta))" by (rule del_tree_greater)
+ with 5 show ?case by (simp add: balright_sorted)
next
case ("6_2" x aa yy ss vaa vbb vdd vc)
- hence "tgt yy (Tr R vaa vbb vdd vc)" by simp
- hence "tgt yy (del x (Tr R vaa vbb vdd vc))" by (rule del_tgt)
+ hence "tree_greater yy (Branch R vaa vbb vdd vc)" by simp
+ hence "tree_greater yy (del x (Branch R vaa vbb vdd vc))" by (rule del_tree_greater)
with "6_2" show ?case by simp
-qed (auto simp: app_st)
+qed (auto simp: app_sorted)
-lemma "\<lbrakk>st lt; st rt; tlt kt lt; tgt kt rt; inv1 lt; inv1 rt; inv2 lt; inv2 rt; bh lt = bh rt; x < kt\<rbrakk> \<Longrightarrow> pin_tree k v (delformLeft x lt kt y rt) = (False \<or> (x \<noteq> k \<and> pin_tree k v (Tr c lt kt y rt)))"
- and "\<lbrakk>st lt; st rt; tlt kt lt; tgt kt rt; inv1 lt; inv1 rt; inv2 lt; inv2 rt; bh lt = bh rt; x > kt\<rbrakk> \<Longrightarrow> pin_tree k v (delformRight x lt kt y rt) = (False \<or> (x \<noteq> k \<and> pin_tree k v (Tr c lt kt y rt)))"
- and del_pit: "\<lbrakk>st t; inv1 t; inv2 t\<rbrakk> \<Longrightarrow> pin_tree k v (del x t) = (False \<or> (x \<noteq> k \<and> pin_tree k v t))"
+lemma "\<lbrakk>sorted lt; sorted rt; tree_less kt lt; tree_greater kt rt; inv1 lt; inv1 rt; inv2 lt; inv2 rt; bheight lt = bheight rt; x < kt\<rbrakk> \<Longrightarrow> entry_in_tree k v (delformLeft x lt kt y rt) = (False \<or> (x \<noteq> k \<and> entry_in_tree k v (Branch c lt kt y rt)))"
+ and "\<lbrakk>sorted lt; sorted rt; tree_less kt lt; tree_greater kt rt; inv1 lt; inv1 rt; inv2 lt; inv2 rt; bheight lt = bheight rt; x > kt\<rbrakk> \<Longrightarrow> entry_in_tree k v (delformRight x lt kt y rt) = (False \<or> (x \<noteq> k \<and> entry_in_tree k v (Branch c lt kt y rt)))"
+ and del_pit: "\<lbrakk>sorted t; inv1 t; inv2 t\<rbrakk> \<Longrightarrow> entry_in_tree k v (del x t) = (False \<or> (x \<noteq> k \<and> entry_in_tree k v t))"
proof (induct x lt kt y rt and x lt kt y rt and x t rule: delformLeft_delformRight_del.induct)
case (2 xx c aa yy ss bb)
have "xx = yy \<or> xx < yy \<or> xx > yy" by auto
@@ -657,68 +672,68 @@
assume "xx = yy"
with 2 show ?thesis proof (cases "xx = k")
case True
- from 2 `xx = yy` `xx = k` have "st (Tr c aa yy ss bb) \<and> k = yy" by simp
- hence "\<not> pin_tree k v aa" "\<not> pin_tree k v bb" by (auto simp: tlt_nit tgt_prop)
+ from 2 `xx = yy` `xx = k` have "sorted (Branch c aa yy ss bb) \<and> k = yy" by simp
+ hence "\<not> entry_in_tree k v aa" "\<not> entry_in_tree k v bb" by (auto simp: tree_less_nit tree_greater_prop)
with `xx = yy` 2 `xx = k` show ?thesis by (simp add: app_pit)
qed (simp add: app_pit)
qed simp+
next
case (3 xx lta zz vv rta yy ss bb)
- def mt[simp]: mt == "Tr B lta zz vv rta"
+ def mt[simp]: mt == "Branch B lta zz vv rta"
from 3 have "inv2 mt \<and> inv1 mt" by simp
- hence "inv2 (del xx mt) \<and> (treec mt = R \<and> bh (del xx mt) = bh mt \<and> inv1 (del xx mt) \<or> treec mt = B \<and> bh (del xx mt) = bh mt - 1 \<and> inv1l (del xx mt))" by (blast dest: del_inv1_inv2)
- with 3 have 4: "pin_tree k v (delformLeft xx mt yy ss bb) = (False \<or> xx \<noteq> k \<and> pin_tree k v mt \<or> (k = yy \<and> v = ss) \<or> pin_tree k v bb)" by (simp add: balleft_pit)
+ hence "inv2 (del xx mt) \<and> (color_of mt = R \<and> bheight (del xx mt) = bheight mt \<and> inv1 (del xx mt) \<or> color_of mt = B \<and> bheight (del xx mt) = bheight mt - 1 \<and> inv1l (del xx mt))" by (blast dest: del_inv1_inv2)
+ with 3 have 4: "entry_in_tree k v (delformLeft xx mt yy ss bb) = (False \<or> xx \<noteq> k \<and> entry_in_tree k v mt \<or> (k = yy \<and> v = ss) \<or> entry_in_tree k v bb)" by (simp add: balleft_pit)
thus ?case proof (cases "xx = k")
case True
- from 3 True have "tgt yy bb \<and> yy > k" by simp
- hence "tgt k bb" by (blast dest: tgt_trans)
- with 3 4 True show ?thesis by (auto simp: tgt_nit)
+ from 3 True have "tree_greater yy bb \<and> yy > k" by simp
+ hence "tree_greater k bb" by (blast dest: tree_greater_trans)
+ with 3 4 True show ?thesis by (auto simp: tree_greater_nit)
qed auto
next
case ("4_1" xx yy ss bb)
show ?case proof (cases "xx = k")
case True
- with "4_1" have "tgt yy bb \<and> k < yy" by simp
- hence "tgt k bb" by (blast dest: tgt_trans)
+ with "4_1" have "tree_greater yy bb \<and> k < yy" by simp
+ hence "tree_greater k bb" by (blast dest: tree_greater_trans)
with "4_1" `xx = k`
- have "pin_tree k v (Tr R Empty yy ss bb) = pin_tree k v Empty" by (auto simp: tgt_nit)
+ have "entry_in_tree k v (Branch R Empty yy ss bb) = entry_in_tree k v Empty" by (auto simp: tree_greater_nit)
thus ?thesis by auto
qed simp+
next
case ("4_2" xx vaa vbb vdd vc yy ss bb)
thus ?case proof (cases "xx = k")
case True
- with "4_2" have "k < yy \<and> tgt yy bb" by simp
- hence "tgt k bb" by (blast dest: tgt_trans)
- with True "4_2" show ?thesis by (auto simp: tgt_nit)
+ with "4_2" have "k < yy \<and> tree_greater yy bb" by simp
+ hence "tree_greater k bb" by (blast dest: tree_greater_trans)
+ with True "4_2" show ?thesis by (auto simp: tree_greater_nit)
qed simp
next
case (5 xx aa yy ss lta zz vv rta)
- def mt[simp]: mt == "Tr B lta zz vv rta"
+ def mt[simp]: mt == "Branch B lta zz vv rta"
from 5 have "inv2 mt \<and> inv1 mt" by simp
- hence "inv2 (del xx mt) \<and> (treec mt = R \<and> bh (del xx mt) = bh mt \<and> inv1 (del xx mt) \<or> treec mt = B \<and> bh (del xx mt) = bh mt - 1 \<and> inv1l (del xx mt))" by (blast dest: del_inv1_inv2)
- with 5 have 3: "pin_tree k v (delformRight xx aa yy ss mt) = (pin_tree k v aa \<or> (k = yy \<and> v = ss) \<or> False \<or> xx \<noteq> k \<and> pin_tree k v mt)" by (simp add: balright_pit)
+ hence "inv2 (del xx mt) \<and> (color_of mt = R \<and> bheight (del xx mt) = bheight mt \<and> inv1 (del xx mt) \<or> color_of mt = B \<and> bheight (del xx mt) = bheight mt - 1 \<and> inv1l (del xx mt))" by (blast dest: del_inv1_inv2)
+ with 5 have 3: "entry_in_tree k v (delformRight xx aa yy ss mt) = (entry_in_tree k v aa \<or> (k = yy \<and> v = ss) \<or> False \<or> xx \<noteq> k \<and> entry_in_tree k v mt)" by (simp add: balright_pit)
thus ?case proof (cases "xx = k")
case True
- from 5 True have "tlt yy aa \<and> yy < k" by simp
- hence "tlt k aa" by (blast dest: tlt_trans)
- with 3 5 True show ?thesis by (auto simp: tlt_nit)
+ from 5 True have "tree_less yy aa \<and> yy < k" by simp
+ hence "tree_less k aa" by (blast dest: tree_less_trans)
+ with 3 5 True show ?thesis by (auto simp: tree_less_nit)
qed auto
next
case ("6_1" xx aa yy ss)
show ?case proof (cases "xx = k")
case True
- with "6_1" have "tlt yy aa \<and> k > yy" by simp
- hence "tlt k aa" by (blast dest: tlt_trans)
- with "6_1" `xx = k` show ?thesis by (auto simp: tlt_nit)
+ with "6_1" have "tree_less yy aa \<and> k > yy" by simp
+ hence "tree_less k aa" by (blast dest: tree_less_trans)
+ with "6_1" `xx = k` show ?thesis by (auto simp: tree_less_nit)
qed simp
next
case ("6_2" xx aa yy ss vaa vbb vdd vc)
thus ?case proof (cases "xx = k")
case True
- with "6_2" have "k > yy \<and> tlt yy aa" by simp
- hence "tlt k aa" by (blast dest: tlt_trans)
- with True "6_2" show ?thesis by (auto simp: tlt_nit)
+ with "6_2" have "k > yy \<and> tree_less yy aa" by simp
+ hence "tree_less k aa" by (blast dest: tree_less_trans)
+ with True "6_2" show ?thesis by (auto simp: tree_less_nit)
qed simp
qed simp
@@ -726,36 +741,36 @@
definition delete where
delete_def: "delete k t = paint B (del k t)"
-theorem delete_isrbt[simp]: assumes "isrbt t" shows "isrbt (delete k t)"
+theorem delete_is_rbt[simp]: assumes "is_rbt t" shows "is_rbt (delete k t)"
proof -
- from assms have "inv2 t" and "inv1 t" unfolding isrbt_def by auto
- hence "inv2 (del k t) \<and> (treec t = R \<and> bh (del k t) = bh t \<and> inv1 (del k t) \<or> treec t = B \<and> bh (del k t) = bh t - 1 \<and> inv1l (del k t))" by (rule del_inv1_inv2)
- hence "inv2 (del k t) \<and> inv1l (del k t)" by (cases "treec t") auto
+ from assms have "inv2 t" and "inv1 t" unfolding is_rbt_def by auto
+ hence "inv2 (del k t) \<and> (color_of t = R \<and> bheight (del k t) = bheight t \<and> inv1 (del k t) \<or> color_of t = B \<and> bheight (del k t) = bheight t - 1 \<and> inv1l (del k t))" by (rule del_inv1_inv2)
+ hence "inv2 (del k t) \<and> inv1l (del k t)" by (cases "color_of t") auto
with assms show ?thesis
- unfolding isrbt_def delete_def
- by (auto intro: paint_st del_st)
+ unfolding is_rbt_def delete_def
+ by (auto intro: paint_sorted del_sorted)
qed
lemma delete_pit:
- assumes "isrbt t"
- shows "pin_tree k v (delete x t) = (x \<noteq> k \<and> pin_tree k v t)"
- using assms unfolding isrbt_def delete_def
+ assumes "is_rbt t"
+ shows "entry_in_tree k v (delete x t) = (x \<noteq> k \<and> entry_in_tree k v t)"
+ using assms unfolding is_rbt_def delete_def
by (auto simp: del_pit)
-lemma map_of_delete:
- assumes isrbt: "isrbt t"
- shows "map_of (delete k t) = (map_of t)|`(-{k})"
+lemma lookup_delete:
+ assumes is_rbt: "is_rbt t"
+ shows "lookup (delete k t) = (lookup t)|`(-{k})"
proof
fix x
- show "map_of (delete k t) x = (map_of t |` (-{k})) x"
+ show "lookup (delete k t) x = (lookup t |` (-{k})) x"
proof (cases "x = k")
assume "x = k"
- with isrbt show ?thesis
- by (cases "map_of (delete k t) k") (auto simp: mapof_pit delete_pit)
+ with is_rbt show ?thesis
+ by (cases "lookup (delete k t) k") (auto simp: lookup_pit delete_pit)
next
assume "x \<noteq> k"
thus ?thesis
- by auto (metis isrbt delete_isrbt delete_pit isrbt_st mapof_from_pit)
+ by auto (metis is_rbt delete_is_rbt delete_pit is_rbt_sorted lookup_from_pit)
qed
qed
@@ -765,43 +780,43 @@
unionwithkey :: "('a\<Colon>linorder \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a,'b) rbt \<Rightarrow> ('a,'b) rbt \<Rightarrow> ('a,'b) rbt"
where
"unionwithkey f t Empty = t"
-| "unionwithkey f t (Tr c lt k v rt) = unionwithkey f (unionwithkey f (insertwithkey f k v t) lt) rt"
+| "unionwithkey f t (Branch c lt k v rt) = unionwithkey f (unionwithkey f (insertwithkey f k v t) lt) rt"
-lemma unionwk_st: "st lt \<Longrightarrow> st (unionwithkey f lt rt)"
- by (induct rt arbitrary: lt) (auto simp: insertwk_st)
-theorem unionwk_isrbt[simp]: "isrbt lt \<Longrightarrow> isrbt (unionwithkey f lt rt)"
- by (induct rt arbitrary: lt) (simp add: insertwk_isrbt)+
+lemma unionwk_sorted: "sorted lt \<Longrightarrow> sorted (unionwithkey f lt rt)"
+ by (induct rt arbitrary: lt) (auto simp: insertwk_sorted)
+theorem unionwk_is_rbt[simp]: "is_rbt lt \<Longrightarrow> is_rbt (unionwithkey f lt rt)"
+ by (induct rt arbitrary: lt) (simp add: insertwk_is_rbt)+
definition
unionwith where
"unionwith f = unionwithkey (\<lambda>_. f)"
-theorem unionw_isrbt: "isrbt lt \<Longrightarrow> isrbt (unionwith f lt rt)" unfolding unionwith_def by simp
+theorem unionw_is_rbt: "is_rbt lt \<Longrightarrow> is_rbt (unionwith f lt rt)" unfolding unionwith_def by simp
definition union where
"union = unionwithkey (%_ _ rv. rv)"
-theorem union_isrbt: "isrbt lt \<Longrightarrow> isrbt (union lt rt)" unfolding union_def by simp
+theorem union_is_rbt: "is_rbt lt \<Longrightarrow> is_rbt (union lt rt)" unfolding union_def by simp
-lemma union_Tr[simp]:
- "union t (Tr c lt k v rt) = union (union (insrt k v t) lt) rt"
- unfolding union_def insrt_def
+lemma union_Branch[simp]:
+ "union t (Branch c lt k v rt) = union (union (insert k v t) lt) rt"
+ unfolding union_def insert_def
by simp
-lemma map_of_union:
- assumes "isrbt s" "st t"
- shows "map_of (union s t) = map_of s ++ map_of t"
+lemma lookup_union:
+ assumes "is_rbt s" "sorted t"
+ shows "lookup (union s t) = lookup s ++ lookup t"
using assms
proof (induct t arbitrary: s)
case Empty thus ?case by (auto simp: union_def)
next
- case (Tr c l k v r s)
- hence strl: "st r" "st l" "l |\<guillemotleft> k" "k \<guillemotleft>| r" by auto
+ case (Branch c l k v r s)
+ hence sortedrl: "sorted r" "sorted l" "l |\<guillemotleft> k" "k \<guillemotleft>| r" by auto
- have meq: "map_of s(k \<mapsto> v) ++ map_of l ++ map_of r =
- map_of s ++
- (\<lambda>a. if a < k then map_of l a
- else if k < a then map_of r a else Some v)" (is "?m1 = ?m2")
+ have meq: "lookup s(k \<mapsto> v) ++ lookup l ++ lookup r =
+ lookup s ++
+ (\<lambda>a. if a < k then lookup l a
+ else if k < a then lookup r a else Some v)" (is "?m1 = ?m2")
proof (rule ext)
fix a
@@ -809,7 +824,7 @@
thus "?m1 a = ?m2 a"
proof (elim disjE)
assume "k < a"
- with `l |\<guillemotleft> k` have "l |\<guillemotleft> a" by (rule tlt_trans)
+ with `l |\<guillemotleft> k` have "l |\<guillemotleft> a" by (rule tree_less_trans)
with `k < a` show ?thesis
by (auto simp: map_add_def split: option.splits)
next
@@ -818,20 +833,20 @@
show ?thesis by (auto simp: map_add_def)
next
assume "a < k"
- from this `k \<guillemotleft>| r` have "a \<guillemotleft>| r" by (rule tgt_trans)
+ from this `k \<guillemotleft>| r` have "a \<guillemotleft>| r" by (rule tree_greater_trans)
with `a < k` show ?thesis
by (auto simp: map_add_def split: option.splits)
qed
qed
- from Tr
+ from Branch
have IHs:
- "map_of (union (union (insrt k v s) l) r) = map_of (union (insrt k v s) l) ++ map_of r"
- "map_of (union (insrt k v s) l) = map_of (insrt k v s) ++ map_of l"
- by (auto intro: union_isrbt insrt_isrbt)
+ "lookup (union (union (insert k v s) l) r) = lookup (union (insert k v s) l) ++ lookup r"
+ "lookup (union (insert k v s) l) = lookup (insert k v s) ++ lookup l"
+ by (auto intro: union_is_rbt insert_is_rbt)
with meq show ?case
- by (auto simp: map_of_insert[OF Tr(3)])
+ by (auto simp: lookup_insert[OF Branch(3)])
qed
subsection {* Adjust *}
@@ -840,33 +855,33 @@
adjustwithkey :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a\<Colon>linorder) \<Rightarrow> ('a,'b) rbt \<Rightarrow> ('a,'b) rbt"
where
"adjustwithkey f k Empty = Empty"
-| "adjustwithkey f k (Tr c lt x v rt) = (if k < x then (Tr c (adjustwithkey f k lt) x v rt) else if k > x then (Tr c lt x v (adjustwithkey f k rt)) else (Tr c lt x (f x v) rt))"
+| "adjustwithkey f k (Branch c lt x v rt) = (if k < x then (Branch c (adjustwithkey f k lt) x v rt) else if k > x then (Branch c lt x v (adjustwithkey f k rt)) else (Branch c lt x (f x v) rt))"
-lemma adjustwk_treec: "treec (adjustwithkey f k t) = treec t" by (induct t) simp+
-lemma adjustwk_inv1: "inv1 (adjustwithkey f k t) = inv1 t" by (induct t) (simp add: adjustwk_treec)+
-lemma adjustwk_inv2: "inv2 (adjustwithkey f k t) = inv2 t" "bh (adjustwithkey f k t) = bh t" by (induct t) simp+
-lemma adjustwk_tgt: "tgt k (adjustwithkey f kk t) = tgt k t" by (induct t) simp+
-lemma adjustwk_tlt: "tlt k (adjustwithkey f kk t) = tlt k t" by (induct t) simp+
-lemma adjustwk_st: "st (adjustwithkey f k t) = st t" by (induct t) (simp add: adjustwk_tlt adjustwk_tgt)+
+lemma adjustwk_color_of: "color_of (adjustwithkey f k t) = color_of t" by (induct t) simp+
+lemma adjustwk_inv1: "inv1 (adjustwithkey f k t) = inv1 t" by (induct t) (simp add: adjustwk_color_of)+
+lemma adjustwk_inv2: "inv2 (adjustwithkey f k t) = inv2 t" "bheight (adjustwithkey f k t) = bheight t" by (induct t) simp+
+lemma adjustwk_tree_greater: "tree_greater k (adjustwithkey f kk t) = tree_greater k t" by (induct t) simp+
+lemma adjustwk_tree_less: "tree_less k (adjustwithkey f kk t) = tree_less k t" by (induct t) simp+
+lemma adjustwk_sorted: "sorted (adjustwithkey f k t) = sorted t" by (induct t) (simp add: adjustwk_tree_less adjustwk_tree_greater)+
-theorem adjustwk_isrbt[simp]: "isrbt (adjustwithkey f k t) = isrbt t"
-unfolding isrbt_def by (simp add: adjustwk_inv2 adjustwk_treec adjustwk_st adjustwk_inv1 )
+theorem adjustwk_is_rbt[simp]: "is_rbt (adjustwithkey f k t) = is_rbt t"
+unfolding is_rbt_def by (simp add: adjustwk_inv2 adjustwk_color_of adjustwk_sorted adjustwk_inv1 )
theorem adjustwithkey_map[simp]:
- "map_of (adjustwithkey f k t) x =
- (if x = k then case map_of t x of None \<Rightarrow> None | Some y \<Rightarrow> Some (f k y)
- else map_of t x)"
+ "lookup (adjustwithkey f k t) x =
+ (if x = k then case lookup t x of None \<Rightarrow> None | Some y \<Rightarrow> Some (f k y)
+ else lookup t x)"
by (induct t arbitrary: x) (auto split:option.splits)
definition adjust where
"adjust f = adjustwithkey (\<lambda>_. f)"
-theorem adjust_isrbt[simp]: "isrbt (adjust f k t) = isrbt t" unfolding adjust_def by simp
+theorem adjust_is_rbt[simp]: "is_rbt (adjust f k t) = is_rbt t" unfolding adjust_def by simp
theorem adjust_map[simp]:
- "map_of (adjust f k t) x =
- (if x = k then case map_of t x of None \<Rightarrow> None | Some y \<Rightarrow> Some (f y)
- else map_of t x)"
+ "lookup (adjust f k t) x =
+ (if x = k then case lookup t x of None \<Rightarrow> None | Some y \<Rightarrow> Some (f y)
+ else lookup t x)"
unfolding adjust_def by simp
subsection {* Map *}
@@ -875,27 +890,27 @@
mapwithkey :: "('a::linorder \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a,'b) rbt \<Rightarrow> ('a,'c) rbt"
where
"mapwithkey f Empty = Empty"
-| "mapwithkey f (Tr c lt k v rt) = Tr c (mapwithkey f lt) k (f k v) (mapwithkey f rt)"
+| "mapwithkey f (Branch c lt k v rt) = Branch c (mapwithkey f lt) k (f k v) (mapwithkey f rt)"
theorem mapwk_keys[simp]: "keys (mapwithkey f t) = keys t" by (induct t) auto
-lemma mapwk_tgt: "tgt k (mapwithkey f t) = tgt k t" by (induct t) simp+
-lemma mapwk_tlt: "tlt k (mapwithkey f t) = tlt k t" by (induct t) simp+
-lemma mapwk_st: "st (mapwithkey f t) = st t" by (induct t) (simp add: mapwk_tlt mapwk_tgt)+
-lemma mapwk_treec: "treec (mapwithkey f t) = treec t" by (induct t) simp+
-lemma mapwk_inv1: "inv1 (mapwithkey f t) = inv1 t" by (induct t) (simp add: mapwk_treec)+
-lemma mapwk_inv2: "inv2 (mapwithkey f t) = inv2 t" "bh (mapwithkey f t) = bh t" by (induct t) simp+
-theorem mapwk_isrbt[simp]: "isrbt (mapwithkey f t) = isrbt t"
-unfolding isrbt_def by (simp add: mapwk_inv1 mapwk_inv2 mapwk_st mapwk_treec)
+lemma mapwk_tree_greater: "tree_greater k (mapwithkey f t) = tree_greater k t" by (induct t) simp+
+lemma mapwk_tree_less: "tree_less k (mapwithkey f t) = tree_less k t" by (induct t) simp+
+lemma mapwk_sorted: "sorted (mapwithkey f t) = sorted t" by (induct t) (simp add: mapwk_tree_less mapwk_tree_greater)+
+lemma mapwk_color_of: "color_of (mapwithkey f t) = color_of t" by (induct t) simp+
+lemma mapwk_inv1: "inv1 (mapwithkey f t) = inv1 t" by (induct t) (simp add: mapwk_color_of)+
+lemma mapwk_inv2: "inv2 (mapwithkey f t) = inv2 t" "bheight (mapwithkey f t) = bheight t" by (induct t) simp+
+theorem mapwk_is_rbt[simp]: "is_rbt (mapwithkey f t) = is_rbt t"
+unfolding is_rbt_def by (simp add: mapwk_inv1 mapwk_inv2 mapwk_sorted mapwk_color_of)
-theorem map_of_mapwk[simp]: "map_of (mapwithkey f t) x = Option.map (f x) (map_of t x)"
+theorem lookup_mapwk[simp]: "lookup (mapwithkey f t) x = Option.map (f x) (lookup t x)"
by (induct t) auto
definition map
where map_def: "map f == mapwithkey (\<lambda>_. f)"
theorem map_keys[simp]: "keys (map f t) = keys t" unfolding map_def by simp
-theorem map_isrbt[simp]: "isrbt (map f t) = isrbt t" unfolding map_def by simp
-theorem map_of_map[simp]: "map_of (map f t) = Option.map f o map_of t"
+theorem map_is_rbt[simp]: "is_rbt (map f t) = is_rbt t" unfolding map_def by simp
+theorem lookup_map[simp]: "lookup (map f t) = Option.map f o lookup t"
by (rule ext) (simp add:map_def)
subsection {* Fold *}
@@ -906,62 +921,57 @@
foldwithkey :: "('a::linorder \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'c) \<Rightarrow> ('a,'b) rbt \<Rightarrow> 'c \<Rightarrow> 'c"
where
"foldwithkey f Empty v = v"
-| "foldwithkey f (Tr c lt k x rt) v = foldwithkey f rt (f k x (foldwithkey f lt v))"
+| "foldwithkey f (Branch c lt k x rt) v = foldwithkey f rt (f k x (foldwithkey f lt v))"
-primrec alist_of
-where
- "alist_of Empty = []"
-| "alist_of (Tr _ l k v r) = alist_of l @ (k,v) # alist_of r"
-
-lemma map_of_alist_of_aux: "st (Tr c t1 k v t2) \<Longrightarrow> RBT.map_of (Tr c t1 k v t2) = RBT.map_of t2 ++ [k\<mapsto>v] ++ RBT.map_of t1"
+lemma lookup_entries_aux: "sorted (Branch c t1 k v t2) \<Longrightarrow> RBT.lookup (Branch c t1 k v t2) = RBT.lookup t2 ++ [k\<mapsto>v] ++ RBT.lookup t1"
proof (rule ext)
fix x
- assume ST: "st (Tr c t1 k v t2)"
- let ?thesis = "RBT.map_of (Tr c t1 k v t2) x = (RBT.map_of t2 ++ [k \<mapsto> v] ++ RBT.map_of t1) x"
+ assume SORTED: "sorted (Branch c t1 k v t2)"
+ let ?thesis = "RBT.lookup (Branch c t1 k v t2) x = (RBT.lookup t2 ++ [k \<mapsto> v] ++ RBT.lookup t1) x"
- have DOM_T1: "!!k'. k'\<in>dom (RBT.map_of t1) \<Longrightarrow> k>k'"
+ have DOM_T1: "!!k'. k'\<in>dom (RBT.lookup t1) \<Longrightarrow> k>k'"
proof -
fix k'
- from ST have "t1 |\<guillemotleft> k" by simp
- with tlt_prop have "\<forall>k'\<in>keys t1. k>k'" by auto
- moreover assume "k'\<in>dom (RBT.map_of t1)"
- ultimately show "k>k'" using RBT.mapof_keys ST by auto
+ from SORTED have "t1 |\<guillemotleft> k" by simp
+ with tree_less_prop have "\<forall>k'\<in>keys t1. k>k'" by auto
+ moreover assume "k'\<in>dom (RBT.lookup t1)"
+ ultimately show "k>k'" using RBT.lookup_keys SORTED by auto
qed
- have DOM_T2: "!!k'. k'\<in>dom (RBT.map_of t2) \<Longrightarrow> k<k'"
+ have DOM_T2: "!!k'. k'\<in>dom (RBT.lookup t2) \<Longrightarrow> k<k'"
proof -
fix k'
- from ST have "k \<guillemotleft>| t2" by simp
- with tgt_prop have "\<forall>k'\<in>keys t2. k<k'" by auto
- moreover assume "k'\<in>dom (RBT.map_of t2)"
- ultimately show "k<k'" using RBT.mapof_keys ST by auto
+ from SORTED have "k \<guillemotleft>| t2" by simp
+ with tree_greater_prop have "\<forall>k'\<in>keys t2. k<k'" by auto
+ moreover assume "k'\<in>dom (RBT.lookup t2)"
+ ultimately show "k<k'" using RBT.lookup_keys SORTED by auto
qed
{
assume C: "x<k"
- hence "RBT.map_of (Tr c t1 k v t2) x = RBT.map_of t1 x" by simp
+ hence "RBT.lookup (Branch c t1 k v t2) x = RBT.lookup t1 x" by simp
moreover from C have "x\<notin>dom [k\<mapsto>v]" by simp
- moreover have "x\<notin>dom (RBT.map_of t2)" proof
- assume "x\<in>dom (RBT.map_of t2)"
+ moreover have "x\<notin>dom (RBT.lookup t2)" proof
+ assume "x\<in>dom (RBT.lookup t2)"
with DOM_T2 have "k<x" by blast
with C show False by simp
qed
ultimately have ?thesis by (simp add: map_add_upd_left map_add_dom_app_simps)
} moreover {
assume [simp]: "x=k"
- hence "RBT.map_of (Tr c t1 k v t2) x = [k \<mapsto> v] x" by simp
- moreover have "x\<notin>dom (RBT.map_of t1)" proof
- assume "x\<in>dom (RBT.map_of t1)"
+ hence "RBT.lookup (Branch c t1 k v t2) x = [k \<mapsto> v] x" by simp
+ moreover have "x\<notin>dom (RBT.lookup t1)" proof
+ assume "x\<in>dom (RBT.lookup t1)"
with DOM_T1 have "k>x" by blast
thus False by simp
qed
ultimately have ?thesis by (simp add: map_add_upd_left map_add_dom_app_simps)
} moreover {
assume C: "x>k"
- hence "RBT.map_of (Tr c t1 k v t2) x = RBT.map_of t2 x" by (simp add: less_not_sym[of k x])
+ hence "RBT.lookup (Branch c t1 k v t2) x = RBT.lookup t2 x" by (simp add: less_not_sym[of k x])
moreover from C have "x\<notin>dom [k\<mapsto>v]" by simp
- moreover have "x\<notin>dom (RBT.map_of t1)" proof
- assume "x\<in>dom (RBT.map_of t1)"
+ moreover have "x\<notin>dom (RBT.lookup t1)" proof
+ assume "x\<in>dom (RBT.lookup t1)"
with DOM_T1 have "k>x" by simp
with C show False by simp
qed
@@ -969,35 +979,38 @@
} ultimately show ?thesis using less_linear by blast
qed
-lemma map_of_alist_of:
- shows "st t \<Longrightarrow> Map.map_of (alist_of t) = map_of t"
+lemma map_of_entries:
+ shows "sorted t \<Longrightarrow> map_of (entries t) = lookup t"
proof (induct t)
- case Empty thus ?case by (simp add: RBT.map_of_Empty)
+ case Empty thus ?case by (simp add: RBT.lookup_Empty)
next
- case (Tr c t1 k v t2)
- hence "Map.map_of (alist_of (Tr c t1 k v t2)) = RBT.map_of t2 ++ [k \<mapsto> v] ++ RBT.map_of t1" by simp
- also note map_of_alist_of_aux[OF Tr.prems,symmetric]
+ case (Branch c t1 k v t2)
+ hence "map_of (entries (Branch c t1 k v t2)) = RBT.lookup t2 ++ [k \<mapsto> v] ++ RBT.lookup t1" by simp
+ also note lookup_entries_aux [OF Branch.prems,symmetric]
finally show ?case .
qed
-lemma fold_alist_fold:
- "foldwithkey f t x = foldl (\<lambda>x (k,v). f k v x) x (alist_of t)"
+lemma fold_entries_fold:
+ "foldwithkey f t x = foldl (\<lambda>x (k,v). f k v x) x (entries t)"
by (induct t arbitrary: x) auto
-lemma alist_pit[simp]: "(k, v) \<in> set (alist_of t) = pin_tree k v t"
+lemma entries_pit[simp]: "(k, v) \<in> set (entries t) = entry_in_tree k v t"
by (induct t) auto
-lemma sorted_alist:
- "st t \<Longrightarrow> sorted (List.map fst (alist_of t))"
+lemma sorted_entries:
+ "sorted t \<Longrightarrow> List.sorted (List.map fst (entries t))"
by (induct t)
- (force simp: sorted_append sorted_Cons tlgt_props
- dest!:pint_keys)+
+ (force simp: sorted_append sorted_Cons tree_ord_props
+ dest!: entry_in_tree_keys)+
-lemma distinct_alist:
- "st t \<Longrightarrow> distinct (List.map fst (alist_of t))"
+lemma distinct_entries:
+ "sorted t \<Longrightarrow> distinct (List.map fst (entries t))"
by (induct t)
- (force simp: sorted_append sorted_Cons tlgt_props
- dest!:pint_keys)+
+ (force simp: sorted_append sorted_Cons tree_ord_props
+ dest!: entry_in_tree_keys)+
+
+hide (open) const Empty insert delete entries lookup map fold union adjust sorted
+
(*>*)
text {*
@@ -1010,20 +1023,20 @@
text {*
The type @{typ "('k, 'v) rbt"} denotes red-black trees with keys of
type @{typ "'k"} and values of type @{typ "'v"}. To function
- properly, the key type must belong to the @{text "linorder"} class.
+ properly, the key type musorted belong to the @{text "linorder"} class.
A value @{term t} of this type is a valid red-black tree if it
- satisfies the invariant @{text "isrbt t"}.
+ satisfies the invariant @{text "is_rbt t"}.
This theory provides lemmas to prove that the invariant is
satisfied throughout the computation.
- The interpretation function @{const "map_of"} returns the partial
+ The interpretation function @{const "RBT.lookup"} returns the partial
map represented by a red-black tree:
- @{term_type[display] "map_of"}
+ @{term_type[display] "RBT.lookup"}
This function should be used for reasoning about the semantics of the RBT
operations. Furthermore, it implements the lookup functionality for
- the data structure: It is executable and the lookup is performed in
+ the data sortedructure: It is executable and the lookup is performed in
$O(\log n)$.
*}
@@ -1032,19 +1045,19 @@
text {*
Currently, the following operations are supported:
- @{term_type[display] "Empty"}
+ @{term_type[display] "RBT.Empty"}
Returns the empty tree. $O(1)$
- @{term_type[display] "insrt"}
+ @{term_type[display] "RBT.insert"}
Updates the map at a given position. $O(\log n)$
- @{term_type[display] "delete"}
+ @{term_type[display] "RBT.delete"}
Deletes a map entry at a given position. $O(\log n)$
- @{term_type[display] "union"}
+ @{term_type[display] "RBT.union"}
Forms the union of two trees, preferring entries from the first one.
- @{term_type[display] "map"}
+ @{term_type[display] "RBT.map"}
Maps a function over the values of a map. $O(n)$
*}
@@ -1053,47 +1066,47 @@
text {*
\noindent
- @{thm Empty_isrbt}\hfill(@{text "Empty_isrbt"})
+ @{thm Empty_is_rbt}\hfill(@{text "Empty_is_rbt"})
\noindent
- @{thm insrt_isrbt}\hfill(@{text "insrt_isrbt"})
+ @{thm insert_is_rbt}\hfill(@{text "insert_is_rbt"})
\noindent
- @{thm delete_isrbt}\hfill(@{text "delete_isrbt"})
+ @{thm delete_is_rbt}\hfill(@{text "delete_is_rbt"})
\noindent
- @{thm union_isrbt}\hfill(@{text "union_isrbt"})
+ @{thm union_is_rbt}\hfill(@{text "union_is_rbt"})
\noindent
- @{thm map_isrbt}\hfill(@{text "map_isrbt"})
+ @{thm map_is_rbt}\hfill(@{text "map_is_rbt"})
*}
subsection {* Map Semantics *}
text {*
\noindent
- \underline{@{text "map_of_Empty"}}
- @{thm[display] map_of_Empty}
+ \underline{@{text "lookup_Empty"}}
+ @{thm[display] lookup_Empty}
\vspace{1ex}
\noindent
- \underline{@{text "map_of_insert"}}
- @{thm[display] map_of_insert}
+ \underline{@{text "lookup_insert"}}
+ @{thm[display] lookup_insert}
\vspace{1ex}
\noindent
- \underline{@{text "map_of_delete"}}
- @{thm[display] map_of_delete}
+ \underline{@{text "lookup_delete"}}
+ @{thm[display] lookup_delete}
\vspace{1ex}
\noindent
- \underline{@{text "map_of_union"}}
- @{thm[display] map_of_union}
+ \underline{@{text "lookup_union"}}
+ @{thm[display] lookup_union}
\vspace{1ex}
\noindent
- \underline{@{text "map_of_map"}}
- @{thm[display] map_of_map}
+ \underline{@{text "lookup_map"}}
+ @{thm[display] lookup_map}
\vspace{1ex}
*}
--- a/src/HOL/Library/Word.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/Library/Word.thy Wed Mar 03 16:43:55 2010 +0100
@@ -311,11 +311,11 @@
lemma norm_unsigned_idem [simp]: "norm_unsigned (norm_unsigned w) = norm_unsigned w"
by (rule bit_list_induct [of _ w],simp_all)
-consts
+fun
nat_to_bv_helper :: "nat => bit list => bit list"
-recdef nat_to_bv_helper "measure (\<lambda>n. n)"
- "nat_to_bv_helper n = (%bs. (if n = 0 then bs
- else nat_to_bv_helper (n div 2) ((if n mod 2 = 0 then \<zero> else \<one>)#bs)))"
+where
+ "nat_to_bv_helper n bs = (if n = 0 then bs
+ else nat_to_bv_helper (n div 2) ((if n mod 2 = 0 then \<zero> else \<one>)#bs))"
definition
nat_to_bv :: "nat => bit list" where
--- a/src/HOL/List.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/List.thy Wed Mar 03 16:43:55 2010 +0100
@@ -761,13 +761,13 @@
by(induct ys, auto simp add: Cons_eq_map_conv)
lemma map_eq_imp_length_eq:
- assumes "map f xs = map f ys"
+ assumes "map f xs = map g ys"
shows "length xs = length ys"
using assms proof (induct ys arbitrary: xs)
case Nil then show ?case by simp
next
case (Cons y ys) then obtain z zs where xs: "xs = z # zs" by auto
- from Cons xs have "map f zs = map f ys" by simp
+ from Cons xs have "map f zs = map g ys" by simp
moreover with Cons have "length zs = length ys" by blast
with xs show ?case by simp
qed
--- a/src/HOL/MicroJava/BV/Effect.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/MicroJava/BV/Effect.thy Wed Mar 03 16:43:55 2010 +0100
@@ -34,33 +34,34 @@
| "succs Throw pc = [pc]"
text "Effect of instruction on the state type:"
-consts
-eff' :: "instr \<times> jvm_prog \<times> state_type \<Rightarrow> state_type"
-recdef eff' "{}"
-"eff' (Load idx, G, (ST, LT)) = (ok_val (LT ! idx) # ST, LT)"
-"eff' (Store idx, G, (ts#ST, LT)) = (ST, LT[idx:= OK ts])"
-"eff' (LitPush v, G, (ST, LT)) = (the (typeof (\<lambda>v. None) v) # ST, LT)"
-"eff' (Getfield F C, G, (oT#ST, LT)) = (snd (the (field (G,C) F)) # ST, LT)"
-"eff' (Putfield F C, G, (vT#oT#ST, LT)) = (ST,LT)"
-"eff' (New C, G, (ST,LT)) = (Class C # ST, LT)"
-"eff' (Checkcast C, G, (RefT rt#ST,LT)) = (Class C # ST,LT)"
-"eff' (Pop, G, (ts#ST,LT)) = (ST,LT)"
-"eff' (Dup, G, (ts#ST,LT)) = (ts#ts#ST,LT)"
-"eff' (Dup_x1, G, (ts1#ts2#ST,LT)) = (ts1#ts2#ts1#ST,LT)"
-"eff' (Dup_x2, G, (ts1#ts2#ts3#ST,LT)) = (ts1#ts2#ts3#ts1#ST,LT)"
-"eff' (Swap, G, (ts1#ts2#ST,LT)) = (ts2#ts1#ST,LT)"
+fun eff' :: "instr \<times> jvm_prog \<times> state_type \<Rightarrow> state_type"
+where
+"eff' (Load idx, G, (ST, LT)) = (ok_val (LT ! idx) # ST, LT)" |
+"eff' (Store idx, G, (ts#ST, LT)) = (ST, LT[idx:= OK ts])" |
+"eff' (LitPush v, G, (ST, LT)) = (the (typeof (\<lambda>v. None) v) # ST, LT)" |
+"eff' (Getfield F C, G, (oT#ST, LT)) = (snd (the (field (G,C) F)) # ST, LT)" |
+"eff' (Putfield F C, G, (vT#oT#ST, LT)) = (ST,LT)" |
+"eff' (New C, G, (ST,LT)) = (Class C # ST, LT)" |
+"eff' (Checkcast C, G, (RefT rt#ST,LT)) = (Class C # ST,LT)" |
+"eff' (Pop, G, (ts#ST,LT)) = (ST,LT)" |
+"eff' (Dup, G, (ts#ST,LT)) = (ts#ts#ST,LT)" |
+"eff' (Dup_x1, G, (ts1#ts2#ST,LT)) = (ts1#ts2#ts1#ST,LT)" |
+"eff' (Dup_x2, G, (ts1#ts2#ts3#ST,LT)) = (ts1#ts2#ts3#ts1#ST,LT)" |
+"eff' (Swap, G, (ts1#ts2#ST,LT)) = (ts2#ts1#ST,LT)" |
"eff' (IAdd, G, (PrimT Integer#PrimT Integer#ST,LT))
- = (PrimT Integer#ST,LT)"
-"eff' (Ifcmpeq b, G, (ts1#ts2#ST,LT)) = (ST,LT)"
-"eff' (Goto b, G, s) = s"
+ = (PrimT Integer#ST,LT)" |
+"eff' (Ifcmpeq b, G, (ts1#ts2#ST,LT)) = (ST,LT)" |
+"eff' (Goto b, G, s) = s" |
-- "Return has no successor instruction in the same method"
-"eff' (Return, G, s) = s"
+"eff' (Return, G, s) = s" |
-- "Throw always terminates abruptly"
-"eff' (Throw, G, s) = s"
+"eff' (Throw, G, s) = s" |
"eff' (Invoke C mn fpTs, G, (ST,LT)) = (let ST' = drop (length fpTs) ST
in (fst (snd (the (method (G,C) (mn,fpTs))))#(tl ST'),LT))"
+
+
primrec match_any :: "jvm_prog \<Rightarrow> p_count \<Rightarrow> exception_table \<Rightarrow> cname list" where
"match_any G pc [] = []"
| "match_any G pc (e#es) = (let (start_pc, end_pc, handler_pc, catch_type) = e;
@@ -77,16 +78,16 @@
"match G X pc et = (if \<exists>e \<in> set et. match_exception_entry G (Xcpt X) pc e then [Xcpt X] else [])"
by (induct et) auto
-consts
+fun
xcpt_names :: "instr \<times> jvm_prog \<times> p_count \<times> exception_table \<Rightarrow> cname list"
-recdef xcpt_names "{}"
+where
"xcpt_names (Getfield F C, G, pc, et) = match G NullPointer pc et"
- "xcpt_names (Putfield F C, G, pc, et) = match G NullPointer pc et"
- "xcpt_names (New C, G, pc, et) = match G OutOfMemory pc et"
- "xcpt_names (Checkcast C, G, pc, et) = match G ClassCast pc et"
- "xcpt_names (Throw, G, pc, et) = match_any G pc et"
- "xcpt_names (Invoke C m p, G, pc, et) = match_any G pc et"
- "xcpt_names (i, G, pc, et) = []"
+| "xcpt_names (Putfield F C, G, pc, et) = match G NullPointer pc et"
+| "xcpt_names (New C, G, pc, et) = match G OutOfMemory pc et"
+| "xcpt_names (Checkcast C, G, pc, et) = match G ClassCast pc et"
+| "xcpt_names (Throw, G, pc, et) = match_any G pc et"
+| "xcpt_names (Invoke C m p, G, pc, et) = match_any G pc et"
+| "xcpt_names (i, G, pc, et) = []"
definition xcpt_eff :: "instr \<Rightarrow> jvm_prog \<Rightarrow> p_count \<Rightarrow> state_type option \<Rightarrow> exception_table \<Rightarrow> succ_type" where
@@ -118,53 +119,53 @@
text "Conditions under which eff is applicable:"
-consts
+
+fun
app' :: "instr \<times> jvm_prog \<times> p_count \<times> nat \<times> ty \<times> state_type \<Rightarrow> bool"
-
-recdef app' "{}"
+where
"app' (Load idx, G, pc, maxs, rT, s) =
- (idx < length (snd s) \<and> (snd s) ! idx \<noteq> Err \<and> length (fst s) < maxs)"
+ (idx < length (snd s) \<and> (snd s) ! idx \<noteq> Err \<and> length (fst s) < maxs)" |
"app' (Store idx, G, pc, maxs, rT, (ts#ST, LT)) =
- (idx < length LT)"
+ (idx < length LT)" |
"app' (LitPush v, G, pc, maxs, rT, s) =
- (length (fst s) < maxs \<and> typeof (\<lambda>t. None) v \<noteq> None)"
+ (length (fst s) < maxs \<and> typeof (\<lambda>t. None) v \<noteq> None)" |
"app' (Getfield F C, G, pc, maxs, rT, (oT#ST, LT)) =
(is_class G C \<and> field (G,C) F \<noteq> None \<and> fst (the (field (G,C) F)) = C \<and>
- G \<turnstile> oT \<preceq> (Class C))"
+ G \<turnstile> oT \<preceq> (Class C))" |
"app' (Putfield F C, G, pc, maxs, rT, (vT#oT#ST, LT)) =
(is_class G C \<and> field (G,C) F \<noteq> None \<and> fst (the (field (G,C) F)) = C \<and>
- G \<turnstile> oT \<preceq> (Class C) \<and> G \<turnstile> vT \<preceq> (snd (the (field (G,C) F))))"
+ G \<turnstile> oT \<preceq> (Class C) \<and> G \<turnstile> vT \<preceq> (snd (the (field (G,C) F))))" |
"app' (New C, G, pc, maxs, rT, s) =
- (is_class G C \<and> length (fst s) < maxs)"
+ (is_class G C \<and> length (fst s) < maxs)" |
"app' (Checkcast C, G, pc, maxs, rT, (RefT rt#ST,LT)) =
- (is_class G C)"
+ (is_class G C)" |
"app' (Pop, G, pc, maxs, rT, (ts#ST,LT)) =
- True"
+ True" |
"app' (Dup, G, pc, maxs, rT, (ts#ST,LT)) =
- (1+length ST < maxs)"
+ (1+length ST < maxs)" |
"app' (Dup_x1, G, pc, maxs, rT, (ts1#ts2#ST,LT)) =
- (2+length ST < maxs)"
+ (2+length ST < maxs)" |
"app' (Dup_x2, G, pc, maxs, rT, (ts1#ts2#ts3#ST,LT)) =
- (3+length ST < maxs)"
+ (3+length ST < maxs)" |
"app' (Swap, G, pc, maxs, rT, (ts1#ts2#ST,LT)) =
- True"
+ True" |
"app' (IAdd, G, pc, maxs, rT, (PrimT Integer#PrimT Integer#ST,LT)) =
- True"
+ True" |
"app' (Ifcmpeq b, G, pc, maxs, rT, (ts#ts'#ST,LT)) =
- (0 \<le> int pc + b \<and> (isPrimT ts \<and> ts' = ts \<or> isRefT ts \<and> isRefT ts'))"
+ (0 \<le> int pc + b \<and> (isPrimT ts \<and> ts' = ts \<or> isRefT ts \<and> isRefT ts'))" |
"app' (Goto b, G, pc, maxs, rT, s) =
- (0 \<le> int pc + b)"
+ (0 \<le> int pc + b)" |
"app' (Return, G, pc, maxs, rT, (T#ST,LT)) =
- (G \<turnstile> T \<preceq> rT)"
+ (G \<turnstile> T \<preceq> rT)" |
"app' (Throw, G, pc, maxs, rT, (T#ST,LT)) =
- isRefT T"
+ isRefT T" |
"app' (Invoke C mn fpTs, G, pc, maxs, rT, s) =
(length fpTs < length (fst s) \<and>
(let apTs = rev (take (length fpTs) (fst s));
X = hd (drop (length fpTs) (fst s))
in
G \<turnstile> X \<preceq> Class C \<and> is_class G C \<and> method (G,C) (mn,fpTs) \<noteq> None \<and>
- list_all2 (\<lambda>x y. G \<turnstile> x \<preceq> y) apTs fpTs))"
+ list_all2 (\<lambda>x y. G \<turnstile> x \<preceq> y) apTs fpTs))" |
"app' (i,G, pc,maxs,rT,s) = False"
@@ -208,7 +209,7 @@
qed auto
lemma 2: "\<not>(2 < length a) \<Longrightarrow> a = [] \<or> (\<exists> l. a = [l]) \<or> (\<exists> l l'. a = [l,l'])"
-proof -;
+proof -
assume "\<not>(2 < length a)"
hence "length a < (Suc (Suc (Suc 0)))" by simp
hence * : "length a = 0 \<or> length a = Suc 0 \<or> length a = Suc (Suc 0)"
@@ -268,7 +269,7 @@
"(app (Checkcast C) G maxs rT pc et (Some s)) =
(\<exists>rT ST LT. s = (RefT rT#ST,LT) \<and> is_class G C \<and>
(\<forall>x \<in> set (match G ClassCast pc et). is_class G x))"
- by (cases s, cases "fst s", simp add: app_def) (cases "hd (fst s)", auto)
+ by (cases s, cases "fst s", simp) (cases "hd (fst s)", auto)
lemma appPop[simp]:
"(app Pop G maxs rT pc et (Some s)) = (\<exists>ts ST LT. s = (ts#ST,LT))"
@@ -359,7 +360,7 @@
assume app: "?app (a,b)"
hence "a = (rev (rev (take (length fpTs) a))) @ (drop (length fpTs) a) \<and>
length fpTs < length a" (is "?a \<and> ?l")
- by (auto simp add: app_def)
+ by auto
hence "?a \<and> 0 < length (drop (length fpTs) a)" (is "?a \<and> ?l")
by auto
hence "?a \<and> ?l \<and> length (rev (take (length fpTs) a)) = length fpTs"
@@ -374,7 +375,7 @@
hence "\<exists>apTs X ST. a = rev apTs @ X # ST \<and> length apTs = length fpTs"
by blast
with app
- show ?thesis by (unfold app_def, clarsimp) blast
+ show ?thesis by clarsimp blast
qed
with Pair
have "?app s \<Longrightarrow> ?P s" by (simp only:)
--- a/src/HOL/MicroJava/JVM/JVMExec.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/MicroJava/JVM/JVMExec.thy Wed Mar 03 16:43:55 2010 +0100
@@ -8,21 +8,19 @@
theory JVMExec imports JVMExecInstr JVMExceptions begin
-consts
+fun
exec :: "jvm_prog \<times> jvm_state => jvm_state option"
-
-
--- "exec is not recursive. recdef is just used for pattern matching"
-recdef exec "{}"
+-- "exec is not recursive. fun is just used for pattern matching"
+where
"exec (G, xp, hp, []) = None"
- "exec (G, None, hp, (stk,loc,C,sig,pc)#frs) =
+| "exec (G, None, hp, (stk,loc,C,sig,pc)#frs) =
(let
i = fst(snd(snd(snd(snd(the(method (G,C) sig)))))) ! pc;
(xcpt', hp', frs') = exec_instr i G hp stk loc C sig pc frs
in Some (find_handler G xcpt' hp' frs'))"
- "exec (G, Some xp, hp, frs) = None"
+| "exec (G, Some xp, hp, frs) = None"
definition exec_all :: "[jvm_prog,jvm_state,jvm_state] => bool"
--- a/src/HOL/Multivariate_Analysis/Convex_Euclidean_Space.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/Multivariate_Analysis/Convex_Euclidean_Space.thy Wed Mar 03 16:43:55 2010 +0100
@@ -15,8 +15,6 @@
declare vector_add_ldistrib[simp] vector_ssub_ldistrib[simp] vector_smult_assoc[simp] vector_smult_rneg[simp]
declare vector_sadd_rdistrib[simp] vector_sub_rdistrib[simp]
-declare dot_ladd[simp] dot_radd[simp] dot_lsub[simp] dot_rsub[simp]
-declare dot_lmult[simp] dot_rmult[simp] dot_lneg[simp] dot_rneg[simp]
declare UNIV_1[simp]
(*lemma dim1in[intro]:"Suc 0 \<in> {1::nat .. CARD(1)}" by auto*)
@@ -1717,7 +1715,7 @@
using norm_basis and dimindex_ge_1 by auto
thus ?thesis apply(rule_tac x="basis a" in exI, rule_tac x=1 in exI) using True by auto
next case False thus ?thesis using False using separating_hyperplane_closed_point[OF assms]
- apply - apply(erule exE)+ unfolding dot_rzero apply(rule_tac x=a in exI, rule_tac x=b in exI) by auto qed
+ apply - apply(erule exE)+ unfolding inner.zero_right apply(rule_tac x=a in exI, rule_tac x=b in exI) by auto qed
subsection {* Now set-to-set for closed/compact sets. *}
--- a/src/HOL/Multivariate_Analysis/Derivative.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/Multivariate_Analysis/Derivative.thy Wed Mar 03 16:43:55 2010 +0100
@@ -12,6 +12,9 @@
(* Because I do not want to type this all the time *)
lemmas linear_linear = linear_conv_bounded_linear[THEN sym]
+(** move this **)
+declare norm_vec1[simp]
+
subsection {* Derivatives *}
text {* The definition is slightly tricky since we make it work over
@@ -612,7 +615,7 @@
finally have "\<bar>(f (x + c *\<^sub>R basis j) - f x - D *v (c *\<^sub>R basis j)) $ k\<bar> \<le> \<bar>D $ k $ j\<bar> / 2 * \<bar>c\<bar>" by simp
hence "\<bar>f (x + c *\<^sub>R basis j) $ k - f x $ k - c * D $ k $ j\<bar> \<le> \<bar>D $ k $ j\<bar> / 2 * \<bar>c\<bar>"
unfolding vector_component_simps matrix_vector_mul_component unfolding smult_conv_scaleR[symmetric]
- unfolding dot_rmult dot_basis unfolding smult_conv_scaleR by simp } note * = this
+ unfolding inner_simps dot_basis smult_conv_scaleR by simp } note * = this
have "x + d *\<^sub>R basis j \<in> ball x e" "x - d *\<^sub>R basis j \<in> ball x e"
unfolding mem_ball vector_dist_norm using norm_basis[of j] d by auto
hence **:"((f (x - d *\<^sub>R basis j))$k \<le> (f x)$k \<and> (f (x + d *\<^sub>R basis j))$k \<le> (f x)$k) \<or>
@@ -702,20 +705,17 @@
subsection {* A nice generalization (see Havin's proof of 5.19 from Rudin's book). *}
-lemma inner_eq_dot: fixes a::"real^'n"
- shows "a \<bullet> b = inner a b" unfolding inner_vector_def dot_def by auto
-
lemma mvt_general: fixes f::"real\<Rightarrow>real^'n"
assumes "a<b" "continuous_on {a..b} f" "\<forall>x\<in>{a<..<b}. (f has_derivative f'(x)) (at x)"
shows "\<exists>x\<in>{a<..<b}. norm(f b - f a) \<le> norm(f'(x) (b - a))" proof-
have "\<exists>x\<in>{a<..<b}. (op \<bullet> (f b - f a) \<circ> f) b - (op \<bullet> (f b - f a) \<circ> f) a = (f b - f a) \<bullet> f' x (b - a)"
- apply(rule mvt) apply(rule assms(1))unfolding inner_eq_dot apply(rule continuous_on_inner continuous_on_intros assms(2))+
+ apply(rule mvt) apply(rule assms(1)) apply(rule continuous_on_inner continuous_on_intros assms(2))+
unfolding o_def apply(rule,rule has_derivative_lift_dot) using assms(3) by auto
then guess x .. note x=this
show ?thesis proof(cases "f a = f b")
case False have "norm (f b - f a) * norm (f b - f a) = norm (f b - f a)^2" by(simp add:class_semiring.semiring_rules)
- also have "\<dots> = (f b - f a) \<bullet> (f b - f a)" unfolding norm_pow_2 ..
- also have "\<dots> = (f b - f a) \<bullet> f' x (b - a)" using x by auto
+ also have "\<dots> = (f b - f a) \<bullet> (f b - f a)" unfolding power2_norm_eq_inner ..
+ also have "\<dots> = (f b - f a) \<bullet> f' x (b - a)" using x unfolding inner_simps by auto
also have "\<dots> \<le> norm (f b - f a) * norm (f' x (b - a))" by(rule norm_cauchy_schwarz)
finally show ?thesis using False x(1) by(auto simp add: real_mult_left_cancel) next
case True thus ?thesis using assms(1) apply(rule_tac x="(a + b) /2" in bexI) by auto qed qed
@@ -751,9 +751,6 @@
also have "\<dots> \<le> B * norm(y - x)" apply(rule **) using * and u by auto
finally show ?thesis by(auto simp add:norm_minus_commute) qed
-(** move this **)
-declare norm_vec1[simp]
-
lemma onorm_vec1: fixes f::"real \<Rightarrow> real"
shows "onorm (\<lambda>x. vec1 (f (dest_vec1 x))) = onorm f" proof-
have "\<forall>x::real^1. norm x = 1 \<longleftrightarrow> x\<in>{vec1 -1, vec1 (1::real)}" unfolding forall_vec1 by(auto simp add:Cart_eq)
--- a/src/HOL/Multivariate_Analysis/Determinants.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/Multivariate_Analysis/Determinants.thy Wed Mar 03 16:43:55 2010 +0100
@@ -837,7 +837,7 @@
unfolding orthogonal_transformation_def
apply auto
apply (erule_tac x=v in allE)+
- apply (simp add: real_vector_norm_def)
+ apply (simp add: norm_eq_sqrt_inner)
by (simp add: dot_norm linear_add[symmetric])
definition "orthogonal_matrix (Q::'a::semiring_1^'n^'n) \<longleftrightarrow> transpose Q ** Q = mat 1 \<and> Q ** transpose Q = mat 1"
@@ -879,7 +879,7 @@
by simp_all
from fd[rule_format, of "basis i" "basis j", unfolded matrix_works[OF lf, symmetric] dot_matrix_vector_mul]
have "?A$i$j = ?m1 $ i $ j"
- by (simp add: dot_def matrix_matrix_mult_def columnvector_def rowvector_def basis_def th0 setsum_delta[OF fU] mat_def)}
+ by (simp add: inner_vector_def matrix_matrix_mult_def columnvector_def rowvector_def basis_def th0 setsum_delta[OF fU] mat_def)}
hence "orthogonal_matrix ?mf" unfolding orthogonal_matrix by vector
with lf have ?rhs by blast}
moreover
@@ -929,8 +929,7 @@
unfolding dot_norm_neg dist_norm[symmetric]
unfolding th0 fd[rule_format] by (simp add: power2_eq_square field_simps)}
note fc = this
- show ?thesis unfolding linear_def vector_eq
- by (simp add: dot_lmult dot_ladd dot_rmult dot_radd fc ring_simps)
+ show ?thesis unfolding linear_def vector_eq smult_conv_scaleR by (simp add: inner_simps fc ring_simps)
qed
lemma isometry_linear:
@@ -972,7 +971,7 @@
"x' = norm x *s x0'" "y' = norm y *s y0'"
"norm x0 = 1" "norm x0' = 1" "norm y0 = 1" "norm y0' = 1"
"norm(x0' - y0') = norm(x0 - y0)"
-
+ hence *:"x0 \<bullet> y0 = x0' \<bullet> y0' + y0' \<bullet> x0' - y0 \<bullet> x0 " by(simp add: norm_eq norm_eq_1 inner_simps)
have "norm(x' - y') = norm(x - y)"
apply (subst H(1))
apply (subst H(2))
@@ -980,9 +979,8 @@
apply (subst H(4))
using H(5-9)
apply (simp add: norm_eq norm_eq_1)
- apply (simp add: dot_lsub dot_rsub dot_lmult dot_rmult)
- apply (simp add: ring_simps)
- by (simp only: right_distrib[symmetric])}
+ apply (simp add: inner_simps smult_conv_scaleR) unfolding *
+ by (simp add: ring_simps) }
note th0 = this
let ?g = "\<lambda>x. if x = 0 then 0 else norm x *s f (inverse (norm x) *s x)"
{fix x:: "real ^'n" assume nx: "norm x = 1"
--- a/src/HOL/Multivariate_Analysis/Euclidean_Space.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/Multivariate_Analysis/Euclidean_Space.thy Wed Mar 03 16:43:55 2010 +0100
@@ -100,6 +100,12 @@
instance ..
end
+instantiation cart :: (scaleR, finite) scaleR
+begin
+ definition vector_scaleR_def: "scaleR = (\<lambda> r x. (\<chi> i. scaleR r (x$i)))"
+ instance ..
+end
+
instantiation cart :: (ord,finite) ord
begin
definition vector_le_def:
@@ -108,12 +114,31 @@
instance by (intro_classes)
end
-instantiation cart :: (scaleR, finite) scaleR
+text{* The ordering on real^1 is linear. *}
+
+class cart_one = assumes UNIV_one: "card (UNIV \<Colon> 'a set) = Suc 0"
begin
- definition vector_scaleR_def: "scaleR = (\<lambda> r x. (\<chi> i. scaleR r (x$i)))"
- instance ..
+ subclass finite
+ proof from UNIV_one show "finite (UNIV :: 'a set)"
+ by (auto intro!: card_ge_0_finite) qed
end
+instantiation num1 :: cart_one begin
+instance proof
+ show "CARD(1) = Suc 0" by auto
+qed end
+
+instantiation cart :: (linorder,cart_one) linorder begin
+instance proof
+ guess a B using UNIV_one[where 'a='b] unfolding card_Suc_eq apply- by(erule exE)+
+ hence *:"UNIV = {a}" by auto
+ have "\<And>P. (\<forall>i\<in>UNIV. P i) \<longleftrightarrow> P a" unfolding * by auto hence all:"\<And>P. (\<forall>i. P i) \<longleftrightarrow> P a" by auto
+ fix x y z::"'a^'b::cart_one" note * = vector_le_def vector_less_def all Cart_eq
+ show "x\<le>x" "(x < y) = (x \<le> y \<and> \<not> y \<le> x)" "x\<le>y \<or> y\<le>x" unfolding * by(auto simp only:field_simps)
+ { assume "x\<le>y" "y\<le>z" thus "x\<le>z" unfolding * by(auto simp only:field_simps) }
+ { assume "x\<le>y" "y\<le>x" thus "x=y" unfolding * by(auto simp only:field_simps) }
+qed end
+
text{* Also the scalar-vector multiplication. *}
definition vector_scalar_mult:: "'a::times \<Rightarrow> 'a ^ 'n \<Rightarrow> 'a ^ 'n" (infixl "*s" 70)
@@ -123,25 +148,11 @@
definition "vec x = (\<chi> i. x)"
-text{* Dot products. *}
-
-definition dot :: "'a::{comm_monoid_add, times} ^ 'n \<Rightarrow> 'a ^ 'n \<Rightarrow> 'a" (infix "\<bullet>" 70) where
- "x \<bullet> y = setsum (\<lambda>i. x$i * y$i) UNIV"
-
-lemma dot_1[simp]: "(x::'a::{comm_monoid_add, times}^1) \<bullet> y = (x$1) * (y$1)"
- by (simp add: dot_def setsum_1)
-
-lemma dot_2[simp]: "(x::'a::{comm_monoid_add, times}^2) \<bullet> y = (x$1) * (y$1) + (x$2) * (y$2)"
- by (simp add: dot_def setsum_2)
-
-lemma dot_3[simp]: "(x::'a::{comm_monoid_add, times}^3) \<bullet> y = (x$1) * (y$1) + (x$2) * (y$2) + (x$3) * (y$3)"
- by (simp add: dot_def setsum_3)
-
subsection {* A naive proof procedure to lift really trivial arithmetic stuff from the basis of the vector space. *}
method_setup vector = {*
let
- val ss1 = HOL_basic_ss addsimps [@{thm dot_def}, @{thm setsum_addf} RS sym,
+ val ss1 = HOL_basic_ss addsimps [@{thm setsum_addf} RS sym,
@{thm setsum_subtractf} RS sym, @{thm setsum_right_distrib},
@{thm setsum_left_distrib}, @{thm setsum_negf} RS sym]
val ss2 = @{simpset} addsimps
@@ -165,8 +176,6 @@
lemma vec_0[simp]: "vec 0 = 0" by (vector vector_zero_def)
lemma vec_1[simp]: "vec 1 = 1" by (vector vector_one_def)
-
-
text{* Obvious "component-pushing". *}
lemma vec_component [simp]: "vec x $ i = x"
@@ -791,6 +800,8 @@
subsection {* Inner products *}
+abbreviation inner_bullet (infix "\<bullet>" 70) where "x \<bullet> y \<equiv> inner x y"
+
instantiation cart :: (real_inner, finite) real_inner
begin
@@ -821,27 +832,6 @@
end
-subsection{* Properties of the dot product. *}
-
-lemma dot_sym: "(x::'a:: {comm_monoid_add, ab_semigroup_mult} ^ 'n) \<bullet> y = y \<bullet> x"
- by (vector mult_commute)
-lemma dot_ladd: "((x::'a::ring ^ 'n) + y) \<bullet> z = (x \<bullet> z) + (y \<bullet> z)"
- by (vector ring_simps)
-lemma dot_radd: "x \<bullet> (y + (z::'a::ring ^ 'n)) = (x \<bullet> y) + (x \<bullet> z)"
- by (vector ring_simps)
-lemma dot_lsub: "((x::'a::ring ^ 'n) - y) \<bullet> z = (x \<bullet> z) - (y \<bullet> z)"
- by (vector ring_simps)
-lemma dot_rsub: "(x::'a::ring ^ 'n) \<bullet> (y - z) = (x \<bullet> y) - (x \<bullet> z)"
- by (vector ring_simps)
-lemma dot_lmult: "(c *s x) \<bullet> y = (c::'a::ring) * (x \<bullet> y)" by (vector ring_simps)
-lemma dot_rmult: "x \<bullet> (c *s y) = (c::'a::comm_ring) * (x \<bullet> y)" by (vector ring_simps)
-lemma dot_lneg: "(-x) \<bullet> (y::'a::ring ^ 'n) = -(x \<bullet> y)" by vector
-lemma dot_rneg: "(x::'a::ring ^ 'n) \<bullet> (-y) = -(x \<bullet> y)" by vector
-lemma dot_lzero[simp]: "0 \<bullet> x = (0::'a::{comm_monoid_add, mult_zero})" by vector
-lemma dot_rzero[simp]: "x \<bullet> 0 = (0::'a::{comm_monoid_add, mult_zero})" by vector
-lemma dot_pos_le[simp]: "(0::'a\<Colon>linordered_ring_strict) <= x \<bullet> x"
- by (simp add: dot_def setsum_nonneg)
-
lemma setsum_squares_eq_0_iff: assumes fS: "finite F" and fp: "\<forall>x \<in> F. f x \<ge> (0 ::'a::ordered_ab_group_add)" shows "setsum f F = 0 \<longleftrightarrow> (ALL x:F. f x = 0)"
using fS fp setsum_nonneg[OF fp]
proof (induct set: finite)
@@ -855,12 +845,6 @@
show ?case by (simp add: h)
qed
-lemma dot_eq_0: "x \<bullet> x = 0 \<longleftrightarrow> (x::'a::{linordered_ring_strict,ring_no_zero_divisors} ^ 'n) = 0"
- by (simp add: dot_def setsum_squares_eq_0_iff Cart_eq)
-
-lemma dot_pos_lt[simp]: "(0 < x \<bullet> x) \<longleftrightarrow> (x::'a::{linordered_ring_strict,ring_no_zero_divisors} ^ 'n) \<noteq> 0" using dot_eq_0[of x] dot_pos_le[of x]
- by (auto simp add: le_less)
-
subsection{* The collapse of the general concepts to dimension one. *}
lemma vector_one: "(x::'a ^1) = (\<chi> i. (x$1))"
@@ -994,12 +978,8 @@
lemma norm_mul[simp]: "norm(a *s x) = abs(a) * norm x"
by (simp add: norm_vector_def vector_component setL2_right_distrib
abs_mult cong: strong_setL2_cong)
-lemma norm_eq_0_dot: "(norm x = 0) \<longleftrightarrow> (x \<bullet> x = (0::real))"
- by (simp add: norm_vector_def dot_def setL2_def power2_eq_square)
-lemma real_vector_norm_def: "norm x = sqrt (x \<bullet> x)"
- by (simp add: norm_vector_def setL2_def dot_def power2_eq_square)
-lemma norm_pow_2: "norm x ^ 2 = x \<bullet> x"
- by (simp add: real_vector_norm_def)
+lemma norm_eq_0_dot: "(norm x = 0) \<longleftrightarrow> (inner x x = (0::real))"
+ by (simp add: norm_vector_def setL2_def power2_eq_square)
lemma norm_eq_0_imp: "norm x = 0 ==> x = (0::real ^'n)" by (metis norm_eq_zero)
lemma vector_mul_eq_0[simp]: "(a *s x = 0) \<longleftrightarrow> a = (0::'a::idom) \<or> x = 0"
by vector
@@ -1011,34 +991,17 @@
by (metis vector_mul_lcancel)
lemma vector_mul_rcancel_imp: "x \<noteq> 0 \<Longrightarrow> (a::real) *s x = b *s x ==> a = b"
by (metis vector_mul_rcancel)
+
lemma norm_cauchy_schwarz:
fixes x y :: "real ^ 'n"
- shows "x \<bullet> y <= norm x * norm y"
-proof-
- {assume "norm x = 0"
- hence ?thesis by (simp add: dot_lzero dot_rzero)}
- moreover
- {assume "norm y = 0"
- hence ?thesis by (simp add: dot_lzero dot_rzero)}
- moreover
- {assume h: "norm x \<noteq> 0" "norm y \<noteq> 0"
- let ?z = "norm y *s x - norm x *s y"
- from h have p: "norm x * norm y > 0" by (metis norm_ge_zero le_less zero_compare_simps)
- from dot_pos_le[of ?z]
- have "(norm x * norm y) * (x \<bullet> y) \<le> norm x ^2 * norm y ^2"
- apply (simp add: dot_rsub dot_lsub dot_lmult dot_rmult ring_simps)
- by (simp add: norm_pow_2[symmetric] power2_eq_square dot_sym)
- hence "x\<bullet>y \<le> (norm x ^2 * norm y ^2) / (norm x * norm y)" using p
- by (simp add: field_simps)
- hence ?thesis using h by (simp add: power2_eq_square)}
- ultimately show ?thesis by metis
-qed
+ shows "inner x y <= norm x * norm y"
+ using Cauchy_Schwarz_ineq2[of x y] by auto
lemma norm_cauchy_schwarz_abs:
fixes x y :: "real ^ 'n"
- shows "\<bar>x \<bullet> y\<bar> \<le> norm x * norm y"
+ shows "\<bar>inner x y\<bar> \<le> norm x * norm y"
using norm_cauchy_schwarz[of x y] norm_cauchy_schwarz[of x "-y"]
- by (simp add: real_abs_def dot_rneg)
+ by (simp add: real_abs_def)
lemma norm_triangle_sub:
fixes x y :: "'a::real_normed_vector"
@@ -1064,21 +1027,21 @@
lemma real_abs_sub_norm: "\<bar>norm (x::real ^ 'n) - norm y\<bar> <= norm(x - y)"
by (rule norm_triangle_ineq3)
lemma norm_le: "norm(x::real ^ 'n) <= norm(y) \<longleftrightarrow> x \<bullet> x <= y \<bullet> y"
- by (simp add: real_vector_norm_def)
+ by (simp add: norm_eq_sqrt_inner)
lemma norm_lt: "norm(x::real ^ 'n) < norm(y) \<longleftrightarrow> x \<bullet> x < y \<bullet> y"
- by (simp add: real_vector_norm_def)
-lemma norm_eq: "norm(x::real ^ 'n) = norm y \<longleftrightarrow> x \<bullet> x = y \<bullet> y"
- by (simp add: order_eq_iff norm_le)
+ by (simp add: norm_eq_sqrt_inner)
+lemma norm_eq: "norm(x::real ^ 'n) = norm (y::real ^ 'n) \<longleftrightarrow> x \<bullet> x = y \<bullet> y"
+ apply(subst order_eq_iff) unfolding norm_le by auto
lemma norm_eq_1: "norm(x::real ^ 'n) = 1 \<longleftrightarrow> x \<bullet> x = 1"
- by (simp add: real_vector_norm_def)
+ unfolding norm_eq_sqrt_inner by auto
text{* Squaring equations and inequalities involving norms. *}
lemma dot_square_norm: "x \<bullet> x = norm(x)^2"
- by (simp add: real_vector_norm_def)
+ by (simp add: norm_eq_sqrt_inner)
lemma norm_eq_square: "norm(x) = a \<longleftrightarrow> 0 <= a \<and> x \<bullet> x = a^2"
- by (auto simp add: real_vector_norm_def)
+ by (auto simp add: norm_eq_sqrt_inner)
lemma real_abs_le_square_iff: "\<bar>x\<bar> \<le> \<bar>y\<bar> \<longleftrightarrow> (x::real)^2 \<le> y^2"
proof-
@@ -1106,12 +1069,14 @@
text{* Dot product in terms of the norm rather than conversely. *}
+lemmas inner_simps = inner.add_left inner.add_right inner.diff_right inner.diff_left
+inner.scaleR_left inner.scaleR_right
+
lemma dot_norm: "x \<bullet> y = (norm(x + y) ^2 - norm x ^ 2 - norm y ^ 2) / 2"
- by (simp add: norm_pow_2 dot_ladd dot_radd dot_sym)
+ unfolding power2_norm_eq_inner inner_simps inner_commute by auto
lemma dot_norm_neg: "x \<bullet> y = ((norm x ^ 2 + norm y ^ 2) - norm(x - y) ^ 2) / 2"
- by (simp add: norm_pow_2 dot_ladd dot_radd dot_lsub dot_rsub dot_sym)
-
+ unfolding power2_norm_eq_inner inner_simps inner_commute by(auto simp add:group_simps)
text{* Equality of vectors in terms of @{term "op \<bullet>"} products. *}
@@ -1120,14 +1085,12 @@
assume "?lhs" then show ?rhs by simp
next
assume ?rhs
- then have "x \<bullet> x - x \<bullet> y = 0 \<and> x \<bullet> y - y\<bullet> y = 0" by simp
- hence "x \<bullet> (x - y) = 0 \<and> y \<bullet> (x - y) = 0"
- by (simp add: dot_rsub dot_lsub dot_sym)
- then have "(x - y) \<bullet> (x - y) = 0" by (simp add: ring_simps dot_lsub dot_rsub)
- then show "x = y" by (simp add: dot_eq_0)
+ then have "x \<bullet> x - x \<bullet> y = 0 \<and> x \<bullet> y - y \<bullet> y = 0" by simp
+ hence "x \<bullet> (x - y) = 0 \<and> y \<bullet> (x - y) = 0" by (simp add: inner_simps inner_commute)
+ then have "(x - y) \<bullet> (x - y) = 0" by (simp add: ring_simps inner_simps inner_commute)
+ then show "x = y" by (simp)
qed
-
subsection{* General linear decision procedure for normed spaces. *}
lemma norm_cmul_rule_thm:
@@ -1456,15 +1419,14 @@
finally show ?thesis .
qed
-lemma dot_lsum: "finite S \<Longrightarrow> setsum f S \<bullet> (y::'a::{comm_ring}^'n) = setsum (\<lambda>x. f x \<bullet> y) S "
- by (induct rule: finite_induct, auto simp add: dot_lzero dot_ladd dot_radd)
-
-lemma dot_rsum: "finite S \<Longrightarrow> (y::'a::{comm_ring}^'n) \<bullet> setsum f S = setsum (\<lambda>x. y \<bullet> f x) S "
- by (induct rule: finite_induct, auto simp add: dot_rzero dot_radd)
+lemma dot_lsum: "finite S \<Longrightarrow> setsum f S \<bullet> (y::'a::{real_inner}^'n) = setsum (\<lambda>x. f x \<bullet> y) S "
+ apply(induct rule: finite_induct) by(auto simp add: inner_simps)
+
+lemma dot_rsum: "finite S \<Longrightarrow> (y::'a::{real_inner}^'n) \<bullet> setsum f S = setsum (\<lambda>x. y \<bullet> f x) S "
+ apply(induct rule: finite_induct) by(auto simp add: inner_simps)
subsection{* Basis vectors in coordinate directions. *}
-
definition "basis k = (\<chi> i. if i = k then 1 else 0)"
lemma basis_component [simp]: "basis k $ i = (if k=i then 1 else 0)"
@@ -1475,11 +1437,9 @@
lemma norm_basis:
shows "norm (basis k :: real ^'n) = 1"
- apply (simp add: basis_def real_vector_norm_def dot_def)
+ apply (simp add: basis_def norm_eq_sqrt_inner) unfolding inner_vector_def
apply (vector delta_mult_idempotent)
- using setsum_delta[of "UNIV :: 'n set" "k" "\<lambda>k. 1::real"]
- apply auto
- done
+ using setsum_delta[of "UNIV :: 'n set" "k" "\<lambda>k. 1::real"] by auto
lemma norm_basis_1: "norm(basis 1 :: real ^'n::{finite,one}) = 1"
by (rule norm_basis)
@@ -1515,8 +1475,8 @@
by auto
lemma dot_basis:
- shows "basis i \<bullet> x = x$i" "x \<bullet> (basis i :: 'a^'n) = (x$i :: 'a::semiring_1)"
- by (auto simp add: dot_def basis_def cond_application_beta cond_value_iff setsum_delta cong del: if_weak_cong)
+ shows "basis i \<bullet> x = x$i" "x \<bullet> (basis i) = (x$i)"
+ unfolding inner_vector_def by (auto simp add: basis_def cond_application_beta cond_value_iff setsum_delta cong del: if_weak_cong)
lemma inner_basis:
fixes x :: "'a::{real_inner, real_algebra_1} ^ 'n"
@@ -1532,7 +1492,7 @@
shows "basis k \<noteq> (0:: 'a::semiring_1 ^'n)"
by (simp add: basis_eq_0)
-lemma vector_eq_ldot: "(\<forall>x. x \<bullet> y = x \<bullet> z) \<longleftrightarrow> y = (z::'a::semiring_1^'n)"
+lemma vector_eq_ldot: "(\<forall>x. x \<bullet> y = x \<bullet> z) \<longleftrightarrow> y = (z::real^'n)"
apply (auto simp add: Cart_eq dot_basis)
apply (erule_tac x="basis i" in allE)
apply (simp add: dot_basis)
@@ -1541,7 +1501,7 @@
apply (simp add: Cart_eq)
done
-lemma vector_eq_rdot: "(\<forall>z. x \<bullet> z = y \<bullet> z) \<longleftrightarrow> x = (y::'a::semiring_1^'n)"
+lemma vector_eq_rdot: "(\<forall>z. x \<bullet> z = y \<bullet> z) \<longleftrightarrow> x = (y::real^'n)"
apply (auto simp add: Cart_eq dot_basis)
apply (erule_tac x="basis i" in allE)
apply (simp add: dot_basis)
@@ -1555,31 +1515,29 @@
definition "orthogonal x y \<longleftrightarrow> (x \<bullet> y = 0)"
lemma orthogonal_basis:
- shows "orthogonal (basis i :: 'a^'n) x \<longleftrightarrow> x$i = (0::'a::ring_1)"
- by (auto simp add: orthogonal_def dot_def basis_def cond_value_iff cond_application_beta setsum_delta cong del: if_weak_cong)
+ shows "orthogonal (basis i) x \<longleftrightarrow> x$i = (0::real)"
+ by (auto simp add: orthogonal_def inner_vector_def basis_def cond_value_iff cond_application_beta setsum_delta cong del: if_weak_cong)
lemma orthogonal_basis_basis:
- shows "orthogonal (basis i :: 'a::ring_1^'n) (basis j) \<longleftrightarrow> i \<noteq> j"
+ shows "orthogonal (basis i :: real^'n) (basis j) \<longleftrightarrow> i \<noteq> j"
unfolding orthogonal_basis[of i] basis_component[of j] by simp
(* FIXME : Maybe some of these require less than comm_ring, but not all*)
lemma orthogonal_clauses:
- "orthogonal a (0::'a::comm_ring ^'n)"
- "orthogonal a x ==> orthogonal a (c *s x)"
+ "orthogonal a (0::real ^'n)"
+ "orthogonal a x ==> orthogonal a (c *\<^sub>R x)"
"orthogonal a x ==> orthogonal a (-x)"
"orthogonal a x \<Longrightarrow> orthogonal a y ==> orthogonal a (x + y)"
"orthogonal a x \<Longrightarrow> orthogonal a y ==> orthogonal a (x - y)"
"orthogonal 0 a"
- "orthogonal x a ==> orthogonal (c *s x) a"
+ "orthogonal x a ==> orthogonal (c *\<^sub>R x) a"
"orthogonal x a ==> orthogonal (-x) a"
"orthogonal x a \<Longrightarrow> orthogonal y a ==> orthogonal (x + y) a"
"orthogonal x a \<Longrightarrow> orthogonal y a ==> orthogonal (x - y) a"
- unfolding orthogonal_def dot_rneg dot_rmult dot_radd dot_rsub
- dot_lzero dot_rzero dot_lneg dot_lmult dot_ladd dot_lsub
- by simp_all
-
-lemma orthogonal_commute: "orthogonal (x::'a::{ab_semigroup_mult,comm_monoid_add} ^'n)y \<longleftrightarrow> orthogonal y x"
- by (simp add: orthogonal_def dot_sym)
+ unfolding orthogonal_def inner_simps by auto
+
+lemma orthogonal_commute: "orthogonal (x::real ^'n)y \<longleftrightarrow> orthogonal y x"
+ by (simp add: orthogonal_def inner_commute)
subsection{* Explicit vector construction from lists. *}
@@ -1969,7 +1927,7 @@
lemma choice_iff: "(\<forall>x. \<exists>y. P x y) \<longleftrightarrow> (\<exists>f. \<forall>x. P x (f x))" by metis
lemma adjoint_works_lemma:
- fixes f:: "'a::ring_1 ^'n \<Rightarrow> 'a ^'m"
+ fixes f:: "real ^'n \<Rightarrow> real ^'m"
assumes lf: "linear f"
shows "\<forall>x y. f x \<bullet> y = x \<bullet> adjoint f y"
proof-
@@ -1977,8 +1935,8 @@
let ?M = "UNIV :: 'm set"
have fN: "finite ?N" by simp
have fM: "finite ?M" by simp
- {fix y:: "'a ^ 'm"
- let ?w = "(\<chi> i. (f (basis i) \<bullet> y)) :: 'a ^ 'n"
+ {fix y:: "real ^ 'm"
+ let ?w = "(\<chi> i. (f (basis i) \<bullet> y)) :: real ^ 'n"
{fix x
have "f x \<bullet> y = f (setsum (\<lambda>i. (x$i) *s basis i) ?N) \<bullet> y"
by (simp only: basis_expansion)
@@ -1987,7 +1945,7 @@
by (simp add: linear_cmul[OF lf])
finally have "f x \<bullet> y = x \<bullet> ?w"
apply (simp only: )
- apply (simp add: dot_def setsum_left_distrib setsum_right_distrib setsum_commute[of _ ?M ?N] ring_simps)
+ apply (simp add: inner_vector_def setsum_left_distrib setsum_right_distrib setsum_commute[of _ ?M ?N] ring_simps)
done}
}
then show ?thesis unfolding adjoint_def
@@ -1997,34 +1955,34 @@
qed
lemma adjoint_works:
- fixes f:: "'a::ring_1 ^'n \<Rightarrow> 'a ^'m"
+ fixes f:: "real ^'n \<Rightarrow> real ^'m"
assumes lf: "linear f"
shows "x \<bullet> adjoint f y = f x \<bullet> y"
using adjoint_works_lemma[OF lf] by metis
-
lemma adjoint_linear:
- fixes f :: "'a::comm_ring_1 ^'n \<Rightarrow> 'a ^'m"
+ fixes f:: "real ^'n \<Rightarrow> real ^'m"
assumes lf: "linear f"
shows "linear (adjoint f)"
- by (simp add: linear_def vector_eq_ldot[symmetric] dot_radd dot_rmult adjoint_works[OF lf])
+ unfolding linear_def vector_eq_ldot[symmetric] apply safe
+ unfolding inner_simps smult_conv_scaleR adjoint_works[OF lf] by auto
lemma adjoint_clauses:
- fixes f:: "'a::comm_ring_1 ^'n \<Rightarrow> 'a ^'m"
+ fixes f:: "real ^'n \<Rightarrow> real ^'m"
assumes lf: "linear f"
shows "x \<bullet> adjoint f y = f x \<bullet> y"
and "adjoint f y \<bullet> x = y \<bullet> f x"
- by (simp_all add: adjoint_works[OF lf] dot_sym )
+ by (simp_all add: adjoint_works[OF lf] inner_commute)
lemma adjoint_adjoint:
- fixes f:: "'a::comm_ring_1 ^ 'n \<Rightarrow> 'a ^'m"
+ fixes f:: "real ^'n \<Rightarrow> real ^'m"
assumes lf: "linear f"
shows "adjoint (adjoint f) = f"
apply (rule ext)
by (simp add: vector_eq_ldot[symmetric] adjoint_clauses[OF adjoint_linear[OF lf]] adjoint_clauses[OF lf])
lemma adjoint_unique:
- fixes f:: "'a::comm_ring_1 ^ 'n \<Rightarrow> 'a ^'m"
+ fixes f:: "real ^'n \<Rightarrow> real ^'m"
assumes lf: "linear f" and u: "\<forall>x y. f' x \<bullet> y = x \<bullet> f y"
shows "f' = adjoint f"
apply (rule ext)
@@ -2101,11 +2059,11 @@
by (auto simp add: basis_def cond_value_iff cond_application_beta setsum_delta[OF finite] cong del: if_weak_cong)
lemma matrix_vector_mul_component:
- shows "((A::'a::semiring_1^_^_) *v x)$k = (A$k) \<bullet> x"
- by (simp add: matrix_vector_mult_def dot_def)
-
-lemma dot_lmul_matrix: "((x::'a::comm_semiring_1 ^_) v* A) \<bullet> y = x \<bullet> (A *v y)"
- apply (simp add: dot_def matrix_vector_mult_def vector_matrix_mult_def setsum_left_distrib setsum_right_distrib mult_ac)
+ shows "((A::real^_^_) *v x)$k = (A$k) \<bullet> x"
+ by (simp add: matrix_vector_mult_def inner_vector_def)
+
+lemma dot_lmul_matrix: "((x::real ^_) v* A) \<bullet> y = x \<bullet> (A *v y)"
+ apply (simp add: inner_vector_def matrix_vector_mult_def vector_matrix_mult_def setsum_left_distrib setsum_right_distrib mult_ac)
apply (subst setsum_commute)
by simp
@@ -2133,7 +2091,7 @@
text{* Two sometimes fruitful ways of looking at matrix-vector multiplication. *}
lemma matrix_mult_dot: "A *v x = (\<chi> i. A$i \<bullet> x)"
- by (simp add: matrix_vector_mult_def dot_def)
+ by (simp add: matrix_vector_mult_def inner_vector_def)
lemma matrix_mult_vsum: "(A::'a::comm_semiring_1^'n^'m) *v x = setsum (\<lambda>i. (x$i) *s column i A) (UNIV:: 'n set)"
by (simp add: matrix_vector_mult_def Cart_eq column_def mult_commute)
@@ -2194,15 +2152,15 @@
lemma matrix_vector_column:"(A::'a::comm_semiring_1^'n^_) *v x = setsum (\<lambda>i. (x$i) *s ((transpose A)$i)) (UNIV:: 'n set)"
by (simp add: matrix_vector_mult_def transpose_def Cart_eq mult_commute)
-lemma adjoint_matrix: "adjoint(\<lambda>x. (A::'a::comm_ring_1^'n^'m) *v x) = (\<lambda>x. transpose A *v x)"
+lemma adjoint_matrix: "adjoint(\<lambda>x. (A::real^'n^'m) *v x) = (\<lambda>x. transpose A *v x)"
apply (rule adjoint_unique[symmetric])
apply (rule matrix_vector_mul_linear)
- apply (simp add: transpose_def dot_def matrix_vector_mult_def setsum_left_distrib setsum_right_distrib)
+ apply (simp add: transpose_def inner_vector_def matrix_vector_mult_def setsum_left_distrib setsum_right_distrib)
apply (subst setsum_commute)
apply (auto simp add: mult_ac)
done
-lemma matrix_adjoint: assumes lf: "linear (f :: 'a::comm_ring_1^'n \<Rightarrow> 'a ^'m)"
+lemma matrix_adjoint: assumes lf: "linear (f :: real^'n \<Rightarrow> real ^'m)"
shows "matrix(adjoint f) = transpose(matrix f)"
apply (subst matrix_vector_mul[OF lf])
unfolding adjoint_matrix matrix_of_matrix_vector_mul ..
@@ -2514,11 +2472,11 @@
apply (auto simp add: Cart_eq matrix_vector_mult_def column_def mult_commute UNIV_1)
done
-lemma linear_to_scalars: assumes lf: "linear (f::'a::comm_ring_1 ^'n \<Rightarrow> 'a^1)"
+lemma linear_to_scalars: assumes lf: "linear (f::real ^'n \<Rightarrow> real^1)"
shows "f = (\<lambda>x. vec1(row 1 (matrix f) \<bullet> x))"
apply (rule ext)
apply (subst matrix_works[OF lf, symmetric])
- apply (simp add: Cart_eq matrix_vector_mult_def row_def dot_def mult_commute forall_1)
+ apply (simp add: Cart_eq matrix_vector_mult_def row_def inner_vector_def mult_commute forall_1)
done
lemma dest_vec1_eq_0: "dest_vec1 x = 0 \<longleftrightarrow> x = 0"
@@ -2624,11 +2582,11 @@
have th0: "norm x = norm (pastecart (fstcart x) (sndcart x))"
by (simp add: pastecart_fst_snd)
have th1: "fstcart x \<bullet> fstcart x \<le> pastecart (fstcart x) (sndcart x) \<bullet> pastecart (fstcart x) (sndcart x)"
- by (simp add: dot_def setsum_UNIV_sum pastecart_def setsum_nonneg)
+ by (simp add: inner_vector_def setsum_UNIV_sum pastecart_def setsum_nonneg)
then show ?thesis
unfolding th0
- unfolding real_vector_norm_def real_sqrt_le_iff id_def
- by (simp add: dot_def)
+ unfolding norm_eq_sqrt_inner real_sqrt_le_iff id_def
+ by (simp add: inner_vector_def)
qed
lemma dist_fstcart: "dist(fstcart (x::real^_)) (fstcart y) <= dist x y"
@@ -2639,18 +2597,18 @@
have th0: "norm x = norm (pastecart (fstcart x) (sndcart x))"
by (simp add: pastecart_fst_snd)
have th1: "sndcart x \<bullet> sndcart x \<le> pastecart (fstcart x) (sndcart x) \<bullet> pastecart (fstcart x) (sndcart x)"
- by (simp add: dot_def setsum_UNIV_sum pastecart_def setsum_nonneg)
+ by (simp add: inner_vector_def setsum_UNIV_sum pastecart_def setsum_nonneg)
then show ?thesis
unfolding th0
- unfolding real_vector_norm_def real_sqrt_le_iff id_def
- by (simp add: dot_def)
+ unfolding norm_eq_sqrt_inner real_sqrt_le_iff id_def
+ by (simp add: inner_vector_def)
qed
lemma dist_sndcart: "dist(sndcart (x::real^_)) (sndcart y) <= dist x y"
unfolding dist_norm by (metis sndcart_sub[symmetric] norm_sndcart)
-lemma dot_pastecart: "(pastecart (x1::'a::{times,comm_monoid_add}^'n) (x2::'a::{times,comm_monoid_add}^'m)) \<bullet> (pastecart y1 y2) = x1 \<bullet> y1 + x2 \<bullet> y2"
- by (simp add: dot_def setsum_UNIV_sum pastecart_def)
+lemma dot_pastecart: "(pastecart (x1::real^'n) (x2::real^'m)) \<bullet> (pastecart y1 y2) = x1 \<bullet> y1 + x2 \<bullet> y2"
+ by (simp add: inner_vector_def setsum_UNIV_sum pastecart_def)
text {* TODO: move to NthRoot *}
lemma sqrt_add_le_add_sqrt:
@@ -3586,8 +3544,8 @@
{fix x assume xs: "x \<in> s"
have t: "t \<subseteq> (insert b (insert a (t -{b})))" using b by auto
from b(1) have "b \<in> span t" by (simp add: span_superset)
- have bs: "b \<in> span (insert a (t - {b}))"
- by (metis in_span_delete a sp mem_def subset_eq)
+ have bs: "b \<in> span (insert a (t - {b}))" apply(rule in_span_delete)
+ using a sp unfolding subset_eq by auto
from xs sp have "x \<in> span t" by blast
with span_mono[OF t]
have x: "x \<in> span (insert b (insert a (t - {b})))" ..
@@ -3842,11 +3800,8 @@
(* FIXME : Move to some general theory ?*)
definition "pairwise R S \<longleftrightarrow> (\<forall>x \<in> S. \<forall>y\<in> S. x\<noteq>y \<longrightarrow> R x y)"
-lemma vector_sub_project_orthogonal: "(b::'a::linordered_field^'n) \<bullet> (x - ((b \<bullet> x) / (b\<bullet>b)) *s b) = 0"
- apply (cases "b = 0", simp)
- apply (simp add: dot_rsub dot_rmult)
- unfolding times_divide_eq_right[symmetric]
- by (simp add: field_simps dot_eq_0)
+lemma vector_sub_project_orthogonal: "(b::real^'n) \<bullet> (x - ((b \<bullet> x) / (b \<bullet> b)) *s b) = 0"
+ unfolding inner_simps smult_conv_scaleR by auto
lemma basis_orthogonal:
fixes B :: "(real ^'n) set"
@@ -3861,7 +3816,7 @@
from `\<exists>C. finite C \<and> card C \<le> card B \<and> span C = span B \<and> pairwise orthogonal C`
obtain C where C: "finite C" "card C \<le> card B"
"span C = span B" "pairwise orthogonal C" by blast
- let ?a = "a - setsum (\<lambda>x. (x\<bullet>a / (x\<bullet>x)) *s x) C"
+ let ?a = "a - setsum (\<lambda>x. (x \<bullet> a / (x \<bullet> x)) *s x) C"
let ?C = "insert ?a C"
from C(1) have fC: "finite ?C" by simp
from fB aB C(1,2) have cC: "card ?C \<le> card (insert a B)" by (simp add: card_insert_if)
@@ -3887,13 +3842,12 @@
have fth: "finite (C - {y})" using C by simp
have "orthogonal x y"
using xa ya
- unfolding orthogonal_def xa dot_lsub dot_rsub diff_eq_0_iff_eq
+ unfolding orthogonal_def xa inner_simps diff_eq_0_iff_eq
apply simp
apply (subst Cy)
using C(1) fth
- apply (simp only: setsum_clauses)
- thm dot_ladd
- apply (auto simp add: dot_ladd dot_radd dot_lmult dot_rmult dot_eq_0 dot_sym[of y a] dot_lsum[OF fth])
+ apply (simp only: setsum_clauses) unfolding smult_conv_scaleR
+ apply (auto simp add: inner_simps inner_eq_zero_iff inner_commute[of y a] dot_lsum[OF fth])
apply (rule setsum_0')
apply clarsimp
apply (rule C(4)[unfolded pairwise_def orthogonal_def, rule_format])
@@ -3904,13 +3858,13 @@
have fth: "finite (C - {x})" using C by simp
have "orthogonal x y"
using xa ya
- unfolding orthogonal_def ya dot_rsub dot_lsub diff_eq_0_iff_eq
+ unfolding orthogonal_def ya inner_simps diff_eq_0_iff_eq
apply simp
apply (subst Cx)
using C(1) fth
- apply (simp only: setsum_clauses)
- apply (subst dot_sym[of x])
- apply (auto simp add: dot_radd dot_rmult dot_eq_0 dot_sym[of x a] dot_rsum[OF fth])
+ apply (simp only: setsum_clauses) unfolding smult_conv_scaleR
+ apply (subst inner_commute[of x])
+ apply (auto simp add: inner_simps inner_eq_zero_iff inner_commute[of x a] dot_rsum[OF fth])
apply (rule setsum_0')
apply clarsimp
apply (rule C(4)[unfolded pairwise_def orthogonal_def, rule_format])
@@ -3945,7 +3899,8 @@
qed
lemma span_eq: "span S = span T \<longleftrightarrow> S \<subseteq> span T \<and> T \<subseteq> span S"
- by (metis set_eq_subset span_mono span_span span_inc) (* FIXME: slow *)
+ using span_inc[unfolded subset_eq] using span_mono[of T "span S"] span_mono[of S "span T"]
+ by(auto simp add: span_span)
(* ------------------------------------------------------------------------- *)
(* Low-dimensional subset is in a hyperplane (weak orthogonal complement). *)
@@ -3962,8 +3917,8 @@
from B have fB: "finite B" "card B = dim S" using independent_bound by auto
from span_mono[OF B(2)] span_mono[OF B(3)]
have sSB: "span S = span B" by (simp add: span_span)
- let ?a = "a - setsum (\<lambda>b. (a\<bullet>b / (b\<bullet>b)) *s b) B"
- have "setsum (\<lambda>b. (a\<bullet>b / (b\<bullet>b)) *s b) B \<in> span S"
+ let ?a = "a - setsum (\<lambda>b. (a \<bullet> b / (b \<bullet> b)) *s b) B"
+ have "setsum (\<lambda>b. (a \<bullet> b / (b \<bullet> b)) *s b) B \<in> span S"
unfolding sSB
apply (rule span_setsum[OF fB(1)])
apply clarsimp
@@ -3972,20 +3927,20 @@
with a have a0:"?a \<noteq> 0" by auto
have "\<forall>x\<in>span B. ?a \<bullet> x = 0"
proof(rule span_induct')
- show "subspace (\<lambda>x. ?a \<bullet> x = 0)"
- by (auto simp add: subspace_def mem_def dot_radd dot_rmult)
- next
+ show "subspace (\<lambda>x. ?a \<bullet> x = 0)" by (auto simp add: subspace_def mem_def inner_simps smult_conv_scaleR)
+
+next
{fix x assume x: "x \<in> B"
from x have B': "B = insert x (B - {x})" by blast
have fth: "finite (B - {x})" using fB by simp
have "?a \<bullet> x = 0"
apply (subst B') using fB fth
unfolding setsum_clauses(2)[OF fth]
- apply simp
- apply (clarsimp simp add: dot_lsub dot_ladd dot_lmult dot_lsum dot_eq_0)
+ apply simp unfolding inner_simps smult_conv_scaleR
+ apply (clarsimp simp add: inner_simps inner_eq_zero_iff smult_conv_scaleR dot_lsum)
apply (rule setsum_0', rule ballI)
- unfolding dot_sym
- by (auto simp add: x field_simps dot_eq_0 intro: B(5)[unfolded pairwise_def orthogonal_def, rule_format])}
+ unfolding inner_commute
+ by (auto simp add: x field_simps inner_eq_zero_iff intro: B(5)[unfolded pairwise_def orthogonal_def, rule_format])}
then show "\<forall>x \<in> B. ?a \<bullet> x = 0" by blast
qed
with a0 show ?thesis unfolding sSB by (auto intro: exI[where x="?a"])
@@ -4754,8 +4709,8 @@
"columnvector (A *v v) = A ** columnvector v"
by (vector columnvector_def matrix_matrix_mult_def matrix_vector_mult_def)
-lemma dot_matrix_product: "(x::'a::semiring_1^'n) \<bullet> y = (((rowvector x ::'a^'n^1) ** (columnvector y :: 'a^1^'n))$1)$1"
- by (vector matrix_matrix_mult_def rowvector_def columnvector_def dot_def)
+lemma dot_matrix_product: "(x::real^'n) \<bullet> y = (((rowvector x ::real^'n^1) ** (columnvector y :: real^1^'n))$1)$1"
+ by (vector matrix_matrix_mult_def rowvector_def columnvector_def inner_vector_def)
lemma dot_matrix_vector_mul:
fixes A B :: "real ^'n ^'n" and x y :: "real ^'n"
@@ -4911,20 +4866,18 @@
by (auto intro: real_sqrt_pow2)
have th: "sqrt (real ?d) * infnorm x \<ge> 0"
by (simp add: zero_le_mult_iff real_sqrt_ge_0_iff infnorm_pos_le)
- have th1: "x\<bullet>x \<le> (sqrt (real ?d) * infnorm x)^2"
+ have th1: "x \<bullet> x \<le> (sqrt (real ?d) * infnorm x)^2"
unfolding power_mult_distrib d2
+ unfolding real_of_nat_def inner_vector_def
+ apply (subst power2_abs[symmetric])
+ apply (rule setsum_bounded)
+ apply(auto simp add: power2_eq_square[symmetric])
apply (subst power2_abs[symmetric])
- unfolding real_of_nat_def dot_def power2_eq_square[symmetric]
- apply (subst power2_abs[symmetric])
- apply (rule setsum_bounded)
apply (rule power_mono)
- unfolding abs_of_nonneg[OF infnorm_pos_le]
unfolding infnorm_def Sup_finite_ge_iff[OF infnorm_set_lemma]
- unfolding infnorm_set_image bex_simps
- apply blast
- by (rule abs_ge_zero)
- from real_le_lsqrt[OF dot_pos_le th th1]
- show ?thesis unfolding real_vector_norm_def id_def .
+ unfolding infnorm_set_image bex_simps apply(rule_tac x=i in exI) by auto
+ from real_le_lsqrt[OF inner_ge_zero th th1]
+ show ?thesis unfolding norm_eq_sqrt_inner id_def .
qed
(* Equality in Cauchy-Schwarz and triangle inequalities. *)
@@ -4938,16 +4891,14 @@
hence ?thesis by simp}
moreover
{assume x: "x \<noteq> 0" and y: "y \<noteq> 0"
- from dot_eq_0[of "norm y *s x - norm x *s y"]
+ from inner_eq_zero_iff[of "norm y *s x - norm x *s y"]
have "?rhs \<longleftrightarrow> (norm y * (norm y * norm x * norm x - norm x * (x \<bullet> y)) - norm x * (norm y * (y \<bullet> x) - norm x * norm y * norm y) = 0)"
using x y
- unfolding dot_rsub dot_lsub dot_lmult dot_rmult
- unfolding norm_pow_2[symmetric] power2_eq_square diff_eq_0_iff_eq apply (simp add: dot_sym)
- apply (simp add: ring_simps)
- apply metis
- done
+ unfolding inner_simps smult_conv_scaleR
+ unfolding power2_norm_eq_inner[symmetric] power2_eq_square diff_eq_0_iff_eq apply (simp add: inner_commute)
+ apply (simp add: ring_simps) by metis
also have "\<dots> \<longleftrightarrow> (2 * norm x * norm y * (norm x * norm y - x \<bullet> y) = 0)" using x y
- by (simp add: ring_simps dot_sym)
+ by (simp add: ring_simps inner_commute)
also have "\<dots> \<longleftrightarrow> ?lhs" using x y
apply simp
by metis
@@ -4969,8 +4920,7 @@
unfolding norm_minus_cancel
norm_mul by blast
also have "\<dots> \<longleftrightarrow> ?lhs"
- unfolding th[OF mult_nonneg_nonneg, OF norm_ge_zero[of x] norm_ge_zero[of y]] dot_lneg
- by arith
+ unfolding th[OF mult_nonneg_nonneg, OF norm_ge_zero[of x] norm_ge_zero[of y]] inner_simps by auto
finally show ?thesis ..
qed
@@ -4993,8 +4943,8 @@
by arith
also have "\<dots> \<longleftrightarrow> norm x *s y = norm y *s x"
unfolding norm_cauchy_schwarz_eq[symmetric]
- unfolding norm_pow_2 dot_ladd dot_radd
- by (simp add: norm_pow_2[symmetric] power2_eq_square dot_sym ring_simps)
+ unfolding power2_norm_eq_inner inner_simps
+ by (simp add: power2_norm_eq_inner[symmetric] power2_eq_square inner_commute ring_simps)
finally have ?thesis .}
ultimately show ?thesis by blast
qed
@@ -5089,3 +5039,4 @@
done
end
+
\ No newline at end of file
--- a/src/HOL/Multivariate_Analysis/Integration.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/Multivariate_Analysis/Integration.thy Wed Mar 03 16:43:55 2010 +0100
@@ -1310,9 +1310,12 @@
lemma integral_empty[simp]: shows "integral {} f = 0"
apply(rule integral_unique) using has_integral_empty .
-lemma has_integral_refl[intro]: shows "(f has_integral 0) {a..a}"
- apply(rule has_integral_null) unfolding content_eq_0_interior
- unfolding interior_closed_interval using interval_sing by auto
+lemma has_integral_refl[intro]: shows "(f has_integral 0) {a..a}" "(f has_integral 0) {a}"
+proof- have *:"{a} = {a..a}" apply(rule set_ext) unfolding mem_interval singleton_iff Cart_eq
+ apply safe prefer 3 apply(erule_tac x=i in allE) by(auto simp add: field_simps)
+ show "(f has_integral 0) {a..a}" "(f has_integral 0) {a}" unfolding *
+ apply(rule_tac[!] has_integral_null) unfolding content_eq_0_interior
+ unfolding interior_closed_interval using interval_sing by auto qed
lemma integrable_on_refl[intro]: shows "f integrable_on {a..a}" unfolding integrable_on_def by auto
@@ -2811,6 +2814,9 @@
subsection {* Special case of additivity we need for the FCT. *}
+lemma interval_bound_sing[simp]: "interval_upperbound {a} = a" "interval_lowerbound {a} = a"
+ unfolding interval_upperbound_def interval_lowerbound_def unfolding Cart_eq by auto
+
lemma additive_tagged_division_1: fixes f::"real^1 \<Rightarrow> 'a::real_normed_vector"
assumes "dest_vec1 a \<le> dest_vec1 b" "p tagged_division_of {a..b}"
shows "setsum (\<lambda>(x,k). f(interval_upperbound k) - f(interval_lowerbound k)) p = f b - f a"
--- a/src/HOL/Mutabelle/mutabelle_extra.ML Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/Mutabelle/mutabelle_extra.ML Wed Mar 03 16:43:55 2010 +0100
@@ -54,7 +54,7 @@
(* quickcheck options *)
(*val quickcheck_generator = "SML"*)
-val iterations = 100
+val iterations = 10
val size = 5
exception RANDOM;
--- a/src/HOL/Nominal/Examples/Fsub.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/Nominal/Examples/Fsub.thy Wed Mar 03 16:43:55 2010 +0100
@@ -686,13 +686,13 @@
have fresh_cond: "X\<sharp>\<Gamma>" by fact
hence fresh_ty_dom: "X\<sharp>(ty_dom \<Gamma>)" by (simp add: fresh_dom)
have "(\<forall>X<:T\<^isub>2. T\<^isub>1) closed_in \<Gamma>" by fact
- hence closed\<^isub>T2: "T\<^isub>2 closed_in \<Gamma>" and closed\<^isub>T1: "T\<^isub>1 closed_in ((TVarB X T\<^isub>2)#\<Gamma>)"
+ hence closed\<^isub>T\<^isub>2: "T\<^isub>2 closed_in \<Gamma>" and closed\<^isub>T\<^isub>1: "T\<^isub>1 closed_in ((TVarB X T\<^isub>2)#\<Gamma>)"
by (auto simp add: closed_in_def ty.supp abs_supp)
have ok: "\<turnstile> \<Gamma> ok" by fact
- hence ok': "\<turnstile> ((TVarB X T\<^isub>2)#\<Gamma>) ok" using closed\<^isub>T2 fresh_ty_dom by simp
- have "\<Gamma> \<turnstile> T\<^isub>2 <: T\<^isub>2" using ih_T\<^isub>2 closed\<^isub>T2 ok by simp
+ hence ok': "\<turnstile> ((TVarB X T\<^isub>2)#\<Gamma>) ok" using closed\<^isub>T\<^isub>2 fresh_ty_dom by simp
+ have "\<Gamma> \<turnstile> T\<^isub>2 <: T\<^isub>2" using ih_T\<^isub>2 closed\<^isub>T\<^isub>2 ok by simp
moreover
- have "((TVarB X T\<^isub>2)#\<Gamma>) \<turnstile> T\<^isub>1 <: T\<^isub>1" using ih_T\<^isub>1 closed\<^isub>T1 ok' by simp
+ have "((TVarB X T\<^isub>2)#\<Gamma>) \<turnstile> T\<^isub>1 <: T\<^isub>1" using ih_T\<^isub>1 closed\<^isub>T\<^isub>1 ok' by simp
ultimately show "\<Gamma> \<turnstile> (\<forall>X<:T\<^isub>2. T\<^isub>1) <: (\<forall>X<:T\<^isub>2. T\<^isub>1)" using fresh_cond
by (simp add: subtype_of.SA_all)
qed (auto simp add: closed_in_def ty.supp supp_atm)
@@ -783,10 +783,10 @@
have ih\<^isub>1: "\<And>\<Delta>. \<turnstile> \<Delta> ok \<Longrightarrow> \<Delta> extends \<Gamma> \<Longrightarrow> \<Delta> \<turnstile> T\<^isub>1 <: S\<^isub>1" by fact
have ih\<^isub>2: "\<And>\<Delta>. \<turnstile> \<Delta> ok \<Longrightarrow> \<Delta> extends ((TVarB X T\<^isub>1)#\<Gamma>) \<Longrightarrow> \<Delta> \<turnstile> S\<^isub>2 <: T\<^isub>2" by fact
have lh_drv_prem: "\<Gamma> \<turnstile> T\<^isub>1 <: S\<^isub>1" by fact
- hence closed\<^isub>T1: "T\<^isub>1 closed_in \<Gamma>" by (simp add: subtype_implies_closed)
+ hence closed\<^isub>T\<^isub>1: "T\<^isub>1 closed_in \<Gamma>" by (simp add: subtype_implies_closed)
have ok: "\<turnstile> \<Delta> ok" by fact
have ext: "\<Delta> extends \<Gamma>" by fact
- have "T\<^isub>1 closed_in \<Delta>" using ext closed\<^isub>T1 by (simp only: extends_closed)
+ have "T\<^isub>1 closed_in \<Delta>" using ext closed\<^isub>T\<^isub>1 by (simp only: extends_closed)
hence "\<turnstile> ((TVarB X T\<^isub>1)#\<Delta>) ok" using fresh_dom ok by force
moreover
have "((TVarB X T\<^isub>1)#\<Delta>) extends ((TVarB X T\<^isub>1)#\<Gamma>)" using ext by (force simp add: extends_def)
@@ -811,10 +811,10 @@
have ih\<^isub>1: "\<And>\<Delta>. \<turnstile> \<Delta> ok \<Longrightarrow> \<Delta> extends \<Gamma> \<Longrightarrow> \<Delta> \<turnstile> T\<^isub>1 <: S\<^isub>1" by fact
have ih\<^isub>2: "\<And>\<Delta>. \<turnstile> \<Delta> ok \<Longrightarrow> \<Delta> extends ((TVarB X T\<^isub>1)#\<Gamma>) \<Longrightarrow> \<Delta> \<turnstile> S\<^isub>2 <: T\<^isub>2" by fact
have lh_drv_prem: "\<Gamma> \<turnstile> T\<^isub>1 <: S\<^isub>1" by fact
- hence closed\<^isub>T1: "T\<^isub>1 closed_in \<Gamma>" by (simp add: subtype_implies_closed)
+ hence closed\<^isub>T\<^isub>1: "T\<^isub>1 closed_in \<Gamma>" by (simp add: subtype_implies_closed)
have ok: "\<turnstile> \<Delta> ok" by fact
have ext: "\<Delta> extends \<Gamma>" by fact
- have "T\<^isub>1 closed_in \<Delta>" using ext closed\<^isub>T1 by (simp only: extends_closed)
+ have "T\<^isub>1 closed_in \<Delta>" using ext closed\<^isub>T\<^isub>1 by (simp only: extends_closed)
hence "\<turnstile> ((TVarB X T\<^isub>1)#\<Delta>) ok" using fresh_dom ok by force
moreover
have "((TVarB X T\<^isub>1)#\<Delta>) extends ((TVarB X T\<^isub>1)#\<Gamma>)" using ext by (force simp add: extends_def)
@@ -903,7 +903,7 @@
case (SA_arrow \<Gamma> Q\<^isub>1 S\<^isub>1 S\<^isub>2 Q\<^isub>2)
then have rh_drv: "\<Gamma> \<turnstile> Q\<^isub>1 \<rightarrow> Q\<^isub>2 <: T" by simp
from `Q\<^isub>1 \<rightarrow> Q\<^isub>2 = Q`
- have Q\<^isub>12_less: "size_ty Q\<^isub>1 < size_ty Q" "size_ty Q\<^isub>2 < size_ty Q" by auto
+ have Q\<^isub>1\<^isub>2_less: "size_ty Q\<^isub>1 < size_ty Q" "size_ty Q\<^isub>2 < size_ty Q" by auto
have lh_drv_prm\<^isub>1: "\<Gamma> \<turnstile> Q\<^isub>1 <: S\<^isub>1" by fact
have lh_drv_prm\<^isub>2: "\<Gamma> \<turnstile> S\<^isub>2 <: Q\<^isub>2" by fact
from rh_drv have "T=Top \<or> (\<exists>T\<^isub>1 T\<^isub>2. T=T\<^isub>1\<rightarrow>T\<^isub>2 \<and> \<Gamma>\<turnstile>T\<^isub>1<:Q\<^isub>1 \<and> \<Gamma>\<turnstile>Q\<^isub>2<:T\<^isub>2)"
@@ -921,10 +921,10 @@
and rh_drv_prm\<^isub>1: "\<Gamma> \<turnstile> T\<^isub>1 <: Q\<^isub>1"
and rh_drv_prm\<^isub>2: "\<Gamma> \<turnstile> Q\<^isub>2 <: T\<^isub>2" by force
from IH_trans[of "Q\<^isub>1"]
- have "\<Gamma> \<turnstile> T\<^isub>1 <: S\<^isub>1" using Q\<^isub>12_less rh_drv_prm\<^isub>1 lh_drv_prm\<^isub>1 by simp
+ have "\<Gamma> \<turnstile> T\<^isub>1 <: S\<^isub>1" using Q\<^isub>1\<^isub>2_less rh_drv_prm\<^isub>1 lh_drv_prm\<^isub>1 by simp
moreover
from IH_trans[of "Q\<^isub>2"]
- have "\<Gamma> \<turnstile> S\<^isub>2 <: T\<^isub>2" using Q\<^isub>12_less rh_drv_prm\<^isub>2 lh_drv_prm\<^isub>2 by simp
+ have "\<Gamma> \<turnstile> S\<^isub>2 <: T\<^isub>2" using Q\<^isub>1\<^isub>2_less rh_drv_prm\<^isub>2 lh_drv_prm\<^isub>2 by simp
ultimately have "\<Gamma> \<turnstile> S\<^isub>1 \<rightarrow> S\<^isub>2 <: T\<^isub>1 \<rightarrow> T\<^isub>2" by auto
then have "\<Gamma> \<turnstile> S\<^isub>1 \<rightarrow> S\<^isub>2 <: T" using T_inst by simp
}
@@ -954,15 +954,15 @@
and rh_drv_prm\<^isub>1: "\<Gamma> \<turnstile> T\<^isub>1 <: Q\<^isub>1"
and rh_drv_prm\<^isub>2:"((TVarB X T\<^isub>1)#\<Gamma>) \<turnstile> Q\<^isub>2 <: T\<^isub>2" by force
have "(\<forall>X<:Q\<^isub>1. Q\<^isub>2) = Q" by fact
- then have Q\<^isub>12_less: "size_ty Q\<^isub>1 < size_ty Q" "size_ty Q\<^isub>2 < size_ty Q"
+ then have Q\<^isub>1\<^isub>2_less: "size_ty Q\<^isub>1 < size_ty Q" "size_ty Q\<^isub>2 < size_ty Q"
using fresh_cond by auto
from IH_trans[of "Q\<^isub>1"]
- have "\<Gamma> \<turnstile> T\<^isub>1 <: S\<^isub>1" using lh_drv_prm\<^isub>1 rh_drv_prm\<^isub>1 Q\<^isub>12_less by blast
+ have "\<Gamma> \<turnstile> T\<^isub>1 <: S\<^isub>1" using lh_drv_prm\<^isub>1 rh_drv_prm\<^isub>1 Q\<^isub>1\<^isub>2_less by blast
moreover
from IH_narrow[of "Q\<^isub>1" "[]"]
- have "((TVarB X T\<^isub>1)#\<Gamma>) \<turnstile> S\<^isub>2 <: Q\<^isub>2" using Q\<^isub>12_less lh_drv_prm\<^isub>2 rh_drv_prm\<^isub>1 by simp
+ have "((TVarB X T\<^isub>1)#\<Gamma>) \<turnstile> S\<^isub>2 <: Q\<^isub>2" using Q\<^isub>1\<^isub>2_less lh_drv_prm\<^isub>2 rh_drv_prm\<^isub>1 by simp
with IH_trans[of "Q\<^isub>2"]
- have "((TVarB X T\<^isub>1)#\<Gamma>) \<turnstile> S\<^isub>2 <: T\<^isub>2" using Q\<^isub>12_less rh_drv_prm\<^isub>2 by simp
+ have "((TVarB X T\<^isub>1)#\<Gamma>) \<turnstile> S\<^isub>2 <: T\<^isub>2" using Q\<^isub>1\<^isub>2_less rh_drv_prm\<^isub>2 by simp
ultimately have "\<Gamma> \<turnstile> (\<forall>X<:S\<^isub>1. S\<^isub>2) <: (\<forall>X<:T\<^isub>1. T\<^isub>2)"
using fresh_cond by (simp add: subtype_of.SA_all)
hence "\<Gamma> \<turnstile> (\<forall>X<:S\<^isub>1. S\<^isub>2) <: T" using T_inst by simp
@@ -1005,16 +1005,16 @@
with IH_inner show "(\<Delta>@[(TVarB X P)]@\<Gamma>) \<turnstile> Tvar Y <: N" by (simp add: subtype_of.SA_trans_TVar)
next
case True
- have memb\<^isub>XQ: "(TVarB X Q)\<in>set (\<Delta>@[(TVarB X Q)]@\<Gamma>)" by simp
- have memb\<^isub>XP: "(TVarB X P)\<in>set (\<Delta>@[(TVarB X P)]@\<Gamma>)" by simp
+ have memb\<^isub>X\<^isub>Q: "(TVarB X Q)\<in>set (\<Delta>@[(TVarB X Q)]@\<Gamma>)" by simp
+ have memb\<^isub>X\<^isub>P: "(TVarB X P)\<in>set (\<Delta>@[(TVarB X P)]@\<Gamma>)" by simp
have eq: "X=Y" by fact
- hence "S=Q" using ok\<^isub>Q lh_drv_prm memb\<^isub>XQ by (simp only: uniqueness_of_ctxt)
+ hence "S=Q" using ok\<^isub>Q lh_drv_prm memb\<^isub>X\<^isub>Q by (simp only: uniqueness_of_ctxt)
hence "(\<Delta>@[(TVarB X P)]@\<Gamma>) \<turnstile> Q <: N" using IH_inner by simp
moreover
have "(\<Delta>@[(TVarB X P)]@\<Gamma>) extends \<Gamma>" by (simp add: extends_def)
hence "(\<Delta>@[(TVarB X P)]@\<Gamma>) \<turnstile> P <: Q" using rh_drv ok\<^isub>P by (simp only: weakening)
ultimately have "(\<Delta>@[(TVarB X P)]@\<Gamma>) \<turnstile> P <: N" by (simp add: transitivity_lemma)
- then show "(\<Delta>@[(TVarB X P)]@\<Gamma>) \<turnstile> Tvar Y <: N" using memb\<^isub>XP eq by auto
+ then show "(\<Delta>@[(TVarB X P)]@\<Gamma>) \<turnstile> Tvar Y <: N" using memb\<^isub>X\<^isub>P eq by auto
qed
next
case (SA_refl_TVar Y \<Gamma> X \<Delta>)
@@ -1049,7 +1049,7 @@
| T_Abs[intro]: "\<lbrakk> VarB x T\<^isub>1 # \<Gamma> \<turnstile> t\<^isub>2 : T\<^isub>2 \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> (\<lambda>x:T\<^isub>1. t\<^isub>2) : T\<^isub>1 \<rightarrow> T\<^isub>2"
| T_Sub[intro]: "\<lbrakk> \<Gamma> \<turnstile> t : S; \<Gamma> \<turnstile> S <: T \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> t : T"
| T_TAbs[intro]:"\<lbrakk> TVarB X T\<^isub>1 # \<Gamma> \<turnstile> t\<^isub>2 : T\<^isub>2 \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> (\<lambda>X<:T\<^isub>1. t\<^isub>2) : (\<forall>X<:T\<^isub>1. T\<^isub>2)"
-| T_TApp[intro]:"\<lbrakk>X\<sharp>(\<Gamma>,t\<^isub>1,T\<^isub>2); \<Gamma> \<turnstile> t\<^isub>1 : (\<forall>X<:T\<^isub>11. T\<^isub>12); \<Gamma> \<turnstile> T\<^isub>2 <: T\<^isub>11\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> t\<^isub>1 \<cdot>\<^sub>\<tau> T\<^isub>2 : (T\<^isub>12[X \<mapsto> T\<^isub>2]\<^sub>\<tau>)"
+| T_TApp[intro]:"\<lbrakk>X\<sharp>(\<Gamma>,t\<^isub>1,T\<^isub>2); \<Gamma> \<turnstile> t\<^isub>1 : (\<forall>X<:T\<^isub>1\<^isub>1. T\<^isub>1\<^isub>2); \<Gamma> \<turnstile> T\<^isub>2 <: T\<^isub>1\<^isub>1\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> t\<^isub>1 \<cdot>\<^sub>\<tau> T\<^isub>2 : (T\<^isub>1\<^isub>2[X \<mapsto> T\<^isub>2]\<^sub>\<tau>)"
equivariance typing
@@ -1164,10 +1164,10 @@
inductive
eval :: "trm \<Rightarrow> trm \<Rightarrow> bool" ("_ \<longmapsto> _" [60,60] 60)
where
- E_Abs : "\<lbrakk> x \<sharp> v\<^isub>2; val v\<^isub>2 \<rbrakk> \<Longrightarrow> (\<lambda>x:T\<^isub>11. t\<^isub>12) \<cdot> v\<^isub>2 \<longmapsto> t\<^isub>12[x \<mapsto> v\<^isub>2]"
+ E_Abs : "\<lbrakk> x \<sharp> v\<^isub>2; val v\<^isub>2 \<rbrakk> \<Longrightarrow> (\<lambda>x:T\<^isub>1\<^isub>1. t\<^isub>1\<^isub>2) \<cdot> v\<^isub>2 \<longmapsto> t\<^isub>1\<^isub>2[x \<mapsto> v\<^isub>2]"
| E_App1 [intro]: "t \<longmapsto> t' \<Longrightarrow> t \<cdot> u \<longmapsto> t' \<cdot> u"
| E_App2 [intro]: "\<lbrakk> val v; t \<longmapsto> t' \<rbrakk> \<Longrightarrow> v \<cdot> t \<longmapsto> v \<cdot> t'"
-| E_TAbs : "X \<sharp> (T\<^isub>11, T\<^isub>2) \<Longrightarrow> (\<lambda>X<:T\<^isub>11. t\<^isub>12) \<cdot>\<^sub>\<tau> T\<^isub>2 \<longmapsto> t\<^isub>12[X \<mapsto>\<^sub>\<tau> T\<^isub>2]"
+| E_TAbs : "X \<sharp> (T\<^isub>1\<^isub>1, T\<^isub>2) \<Longrightarrow> (\<lambda>X<:T\<^isub>1\<^isub>1. t\<^isub>1\<^isub>2) \<cdot>\<^sub>\<tau> T\<^isub>2 \<longmapsto> t\<^isub>1\<^isub>2[X \<mapsto>\<^sub>\<tau> T\<^isub>2]"
| E_TApp [intro]: "t \<longmapsto> t' \<Longrightarrow> t \<cdot>\<^sub>\<tau> T \<longmapsto> t' \<cdot>\<^sub>\<tau> T"
lemma better_E_Abs[intro]:
@@ -1315,7 +1315,7 @@
case (T_Var x T)
then show ?case by auto
next
- case (T_App X t\<^isub>1 T\<^isub>2 T\<^isub>11 T\<^isub>12)
+ case (T_App X t\<^isub>1 T\<^isub>2 T\<^isub>1\<^isub>1 T\<^isub>1\<^isub>2)
then show ?case by force
next
case (T_Abs y T\<^isub>1 t\<^isub>2 T\<^isub>2 \<Delta> \<Gamma>)
@@ -1744,68 +1744,68 @@
assumes H: "\<Gamma> \<turnstile> t : T"
shows "t \<longmapsto> t' \<Longrightarrow> \<Gamma> \<turnstile> t' : T" using H
proof (nominal_induct avoiding: t' rule: typing.strong_induct)
- case (T_App \<Gamma> t\<^isub>1 T\<^isub>11 T\<^isub>12 t\<^isub>2 t')
+ case (T_App \<Gamma> t\<^isub>1 T\<^isub>1\<^isub>1 T\<^isub>1\<^isub>2 t\<^isub>2 t')
obtain x::vrs where x_fresh: "x \<sharp> (\<Gamma>, t\<^isub>1 \<cdot> t\<^isub>2, t')"
by (rule exists_fresh) (rule fin_supp)
obtain X::tyvrs where "X \<sharp> (t\<^isub>1 \<cdot> t\<^isub>2, t')"
by (rule exists_fresh) (rule fin_supp)
with `t\<^isub>1 \<cdot> t\<^isub>2 \<longmapsto> t'` show ?case
proof (cases rule: eval.strong_cases [where x=x and X=X])
- case (E_Abs v\<^isub>2 T\<^isub>11' t\<^isub>12)
- with T_App and x_fresh have h: "\<Gamma> \<turnstile> (\<lambda>x:T\<^isub>11'. t\<^isub>12) : T\<^isub>11 \<rightarrow> T\<^isub>12"
+ case (E_Abs v\<^isub>2 T\<^isub>1\<^isub>1' t\<^isub>1\<^isub>2)
+ with T_App and x_fresh have h: "\<Gamma> \<turnstile> (\<lambda>x:T\<^isub>1\<^isub>1'. t\<^isub>1\<^isub>2) : T\<^isub>1\<^isub>1 \<rightarrow> T\<^isub>1\<^isub>2"
by (simp add: trm.inject fresh_prod)
moreover from x_fresh have "x \<sharp> \<Gamma>" by simp
ultimately obtain S'
- where T\<^isub>11: "\<Gamma> \<turnstile> T\<^isub>11 <: T\<^isub>11'"
- and t\<^isub>12: "(VarB x T\<^isub>11') # \<Gamma> \<turnstile> t\<^isub>12 : S'"
- and S': "\<Gamma> \<turnstile> S' <: T\<^isub>12"
+ where T\<^isub>1\<^isub>1: "\<Gamma> \<turnstile> T\<^isub>1\<^isub>1 <: T\<^isub>1\<^isub>1'"
+ and t\<^isub>1\<^isub>2: "(VarB x T\<^isub>1\<^isub>1') # \<Gamma> \<turnstile> t\<^isub>1\<^isub>2 : S'"
+ and S': "\<Gamma> \<turnstile> S' <: T\<^isub>1\<^isub>2"
by (rule Abs_type') blast
- from `\<Gamma> \<turnstile> t\<^isub>2 : T\<^isub>11`
- have "\<Gamma> \<turnstile> t\<^isub>2 : T\<^isub>11'" using T\<^isub>11 by (rule T_Sub)
- with t\<^isub>12 have "\<Gamma> \<turnstile> t\<^isub>12[x \<mapsto> t\<^isub>2] : S'"
+ from `\<Gamma> \<turnstile> t\<^isub>2 : T\<^isub>1\<^isub>1`
+ have "\<Gamma> \<turnstile> t\<^isub>2 : T\<^isub>1\<^isub>1'" using T\<^isub>1\<^isub>1 by (rule T_Sub)
+ with t\<^isub>1\<^isub>2 have "\<Gamma> \<turnstile> t\<^isub>1\<^isub>2[x \<mapsto> t\<^isub>2] : S'"
by (rule subst_type [where \<Delta>="[]", simplified])
- hence "\<Gamma> \<turnstile> t\<^isub>12[x \<mapsto> t\<^isub>2] : T\<^isub>12" using S' by (rule T_Sub)
+ hence "\<Gamma> \<turnstile> t\<^isub>1\<^isub>2[x \<mapsto> t\<^isub>2] : T\<^isub>1\<^isub>2" using S' by (rule T_Sub)
with E_Abs and x_fresh show ?thesis by (simp add: trm.inject fresh_prod)
next
case (E_App1 t''' t'' u)
hence "t\<^isub>1 \<longmapsto> t''" by (simp add:trm.inject)
- hence "\<Gamma> \<turnstile> t'' : T\<^isub>11 \<rightarrow> T\<^isub>12" by (rule T_App)
- hence "\<Gamma> \<turnstile> t'' \<cdot> t\<^isub>2 : T\<^isub>12" using `\<Gamma> \<turnstile> t\<^isub>2 : T\<^isub>11`
+ hence "\<Gamma> \<turnstile> t'' : T\<^isub>1\<^isub>1 \<rightarrow> T\<^isub>1\<^isub>2" by (rule T_App)
+ hence "\<Gamma> \<turnstile> t'' \<cdot> t\<^isub>2 : T\<^isub>1\<^isub>2" using `\<Gamma> \<turnstile> t\<^isub>2 : T\<^isub>1\<^isub>1`
by (rule typing.T_App)
with E_App1 show ?thesis by (simp add:trm.inject)
next
case (E_App2 v t''' t'')
hence "t\<^isub>2 \<longmapsto> t''" by (simp add:trm.inject)
- hence "\<Gamma> \<turnstile> t'' : T\<^isub>11" by (rule T_App)
- with T_App(1) have "\<Gamma> \<turnstile> t\<^isub>1 \<cdot> t'' : T\<^isub>12"
+ hence "\<Gamma> \<turnstile> t'' : T\<^isub>1\<^isub>1" by (rule T_App)
+ with T_App(1) have "\<Gamma> \<turnstile> t\<^isub>1 \<cdot> t'' : T\<^isub>1\<^isub>2"
by (rule typing.T_App)
with E_App2 show ?thesis by (simp add:trm.inject)
qed (simp_all add: fresh_prod)
next
- case (T_TApp X \<Gamma> t\<^isub>1 T\<^isub>2 T\<^isub>11 T\<^isub>12 t')
+ case (T_TApp X \<Gamma> t\<^isub>1 T\<^isub>2 T\<^isub>1\<^isub>1 T\<^isub>1\<^isub>2 t')
obtain x::vrs where "x \<sharp> (t\<^isub>1 \<cdot>\<^sub>\<tau> T\<^isub>2, t')"
by (rule exists_fresh) (rule fin_supp)
with `t\<^isub>1 \<cdot>\<^sub>\<tau> T\<^isub>2 \<longmapsto> t'`
show ?case
proof (cases rule: eval.strong_cases [where X=X and x=x])
- case (E_TAbs T\<^isub>11' T\<^isub>2' t\<^isub>12)
- with T_TApp have "\<Gamma> \<turnstile> (\<lambda>X<:T\<^isub>11'. t\<^isub>12) : (\<forall>X<:T\<^isub>11. T\<^isub>12)" and "X \<sharp> \<Gamma>" and "X \<sharp> T\<^isub>11'"
+ case (E_TAbs T\<^isub>1\<^isub>1' T\<^isub>2' t\<^isub>1\<^isub>2)
+ with T_TApp have "\<Gamma> \<turnstile> (\<lambda>X<:T\<^isub>1\<^isub>1'. t\<^isub>1\<^isub>2) : (\<forall>X<:T\<^isub>1\<^isub>1. T\<^isub>1\<^isub>2)" and "X \<sharp> \<Gamma>" and "X \<sharp> T\<^isub>1\<^isub>1'"
by (simp_all add: trm.inject)
- moreover from `\<Gamma>\<turnstile>T\<^isub>2<:T\<^isub>11` and `X \<sharp> \<Gamma>` have "X \<sharp> T\<^isub>11"
+ moreover from `\<Gamma>\<turnstile>T\<^isub>2<:T\<^isub>1\<^isub>1` and `X \<sharp> \<Gamma>` have "X \<sharp> T\<^isub>1\<^isub>1"
by (blast intro: closed_in_fresh fresh_dom dest: subtype_implies_closed)
ultimately obtain S'
- where "TVarB X T\<^isub>11 # \<Gamma> \<turnstile> t\<^isub>12 : S'"
- and "(TVarB X T\<^isub>11 # \<Gamma>) \<turnstile> S' <: T\<^isub>12"
+ where "TVarB X T\<^isub>1\<^isub>1 # \<Gamma> \<turnstile> t\<^isub>1\<^isub>2 : S'"
+ and "(TVarB X T\<^isub>1\<^isub>1 # \<Gamma>) \<turnstile> S' <: T\<^isub>1\<^isub>2"
by (rule TAbs_type') blast
- hence "TVarB X T\<^isub>11 # \<Gamma> \<turnstile> t\<^isub>12 : T\<^isub>12" by (rule T_Sub)
- hence "\<Gamma> \<turnstile> t\<^isub>12[X \<mapsto>\<^sub>\<tau> T\<^isub>2] : T\<^isub>12[X \<mapsto> T\<^isub>2]\<^sub>\<tau>" using `\<Gamma> \<turnstile> T\<^isub>2 <: T\<^isub>11`
+ hence "TVarB X T\<^isub>1\<^isub>1 # \<Gamma> \<turnstile> t\<^isub>1\<^isub>2 : T\<^isub>1\<^isub>2" by (rule T_Sub)
+ hence "\<Gamma> \<turnstile> t\<^isub>1\<^isub>2[X \<mapsto>\<^sub>\<tau> T\<^isub>2] : T\<^isub>1\<^isub>2[X \<mapsto> T\<^isub>2]\<^sub>\<tau>" using `\<Gamma> \<turnstile> T\<^isub>2 <: T\<^isub>1\<^isub>1`
by (rule substT_type [where D="[]", simplified])
with T_TApp and E_TAbs show ?thesis by (simp add: trm.inject)
next
case (E_TApp t''' t'' T)
from E_TApp have "t\<^isub>1 \<longmapsto> t''" by (simp add: trm.inject)
- then have "\<Gamma> \<turnstile> t'' : (\<forall>X<:T\<^isub>11. T\<^isub>12)" by (rule T_TApp)
- then have "\<Gamma> \<turnstile> t'' \<cdot>\<^sub>\<tau> T\<^isub>2 : T\<^isub>12[X \<mapsto> T\<^isub>2]\<^sub>\<tau>" using `\<Gamma> \<turnstile> T\<^isub>2 <: T\<^isub>11`
+ then have "\<Gamma> \<turnstile> t'' : (\<forall>X<:T\<^isub>1\<^isub>1. T\<^isub>1\<^isub>2)" by (rule T_TApp)
+ then have "\<Gamma> \<turnstile> t'' \<cdot>\<^sub>\<tau> T\<^isub>2 : T\<^isub>1\<^isub>2[X \<mapsto> T\<^isub>2]\<^sub>\<tau>" using `\<Gamma> \<turnstile> T\<^isub>2 <: T\<^isub>1\<^isub>1`
by (rule better_T_TApp)
with E_TApp show ?thesis by (simp add: trm.inject)
qed (simp_all add: fresh_prod)
@@ -1845,7 +1845,7 @@
shows "val t \<or> (\<exists>t'. t \<longmapsto> t')"
using assms
proof (induct "[]::env" t T)
- case (T_App t\<^isub>1 T\<^isub>11 T\<^isub>12 t\<^isub>2)
+ case (T_App t\<^isub>1 T\<^isub>1\<^isub>1 T\<^isub>1\<^isub>2 t\<^isub>2)
hence "val t\<^isub>1 \<or> (\<exists>t'. t\<^isub>1 \<longmapsto> t')" by simp
thus ?case
proof
@@ -1871,7 +1871,7 @@
thus ?case by auto
qed
next
- case (T_TApp X t\<^isub>1 T\<^isub>2 T\<^isub>11 T\<^isub>12)
+ case (T_TApp X t\<^isub>1 T\<^isub>2 T\<^isub>1\<^isub>1 T\<^isub>1\<^isub>2)
hence "val t\<^isub>1 \<or> (\<exists>t'. t\<^isub>1 \<longmapsto> t')" by simp
thus ?case
proof
--- a/src/HOL/Old_Number_Theory/Euler.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/Old_Number_Theory/Euler.thy Wed Mar 03 16:43:55 2010 +0100
@@ -162,8 +162,11 @@
lemma aux2: "[| (a::int) < c; b < c |] ==> (a \<le> b | b \<le> a)"
by auto
+lemma d22set_induct_old: "(\<And>a::int. 1 < a \<longrightarrow> P (a - 1) \<Longrightarrow> P a) \<Longrightarrow> P x"
+using d22set.induct by blast
+
lemma SRStar_d22set_prop: "2 < p \<Longrightarrow> (SRStar p) = {1} \<union> (d22set (p - 1))"
- apply (induct p rule: d22set.induct)
+ apply (induct p rule: d22set_induct_old)
apply auto
apply (simp add: SRStar_def d22set.simps)
apply (simp add: SRStar_def d22set.simps, clarify)
--- a/src/HOL/Old_Number_Theory/EulerFermat.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/Old_Number_Theory/EulerFermat.thy Wed Mar 03 16:43:55 2010 +0100
@@ -25,20 +25,18 @@
| insert: "A \<in> RsetR m ==> zgcd a m = 1 ==>
\<forall>a'. a' \<in> A --> \<not> zcong a a' m ==> insert a A \<in> RsetR m"
-consts
- BnorRset :: "int * int => int set"
-
-recdef BnorRset
- "measure ((\<lambda>(a, m). nat a) :: int * int => nat)"
- "BnorRset (a, m) =
+fun
+ BnorRset :: "int \<Rightarrow> int => int set"
+where
+ "BnorRset a m =
(if 0 < a then
- let na = BnorRset (a - 1, m)
+ let na = BnorRset (a - 1) m
in (if zgcd a m = 1 then insert a na else na)
else {})"
definition
norRRset :: "int => int set" where
- "norRRset m = BnorRset (m - 1, m)"
+ "norRRset m = BnorRset (m - 1) m"
definition
noXRRset :: "int => int => int set" where
@@ -74,28 +72,27 @@
lemma BnorRset_induct:
assumes "!!a m. P {} a m"
- and "!!a m. 0 < (a::int) ==> P (BnorRset (a - 1, m::int)) (a - 1) m
- ==> P (BnorRset(a,m)) a m"
- shows "P (BnorRset(u,v)) u v"
+ and "!!a m :: int. 0 < a ==> P (BnorRset (a - 1) m) (a - 1) m
+ ==> P (BnorRset a m) a m"
+ shows "P (BnorRset u v) u v"
apply (rule BnorRset.induct)
- apply safe
- apply (case_tac [2] "0 < a")
- apply (rule_tac [2] prems)
+ apply (case_tac "0 < a")
+ apply (rule_tac assms)
apply simp_all
- apply (simp_all add: BnorRset.simps prems)
+ apply (simp_all add: BnorRset.simps assms)
done
-lemma Bnor_mem_zle [rule_format]: "b \<in> BnorRset (a, m) \<longrightarrow> b \<le> a"
+lemma Bnor_mem_zle [rule_format]: "b \<in> BnorRset a m \<longrightarrow> b \<le> a"
apply (induct a m rule: BnorRset_induct)
apply simp
apply (subst BnorRset.simps)
apply (unfold Let_def, auto)
done
-lemma Bnor_mem_zle_swap: "a < b ==> b \<notin> BnorRset (a, m)"
+lemma Bnor_mem_zle_swap: "a < b ==> b \<notin> BnorRset a m"
by (auto dest: Bnor_mem_zle)
-lemma Bnor_mem_zg [rule_format]: "b \<in> BnorRset (a, m) --> 0 < b"
+lemma Bnor_mem_zg [rule_format]: "b \<in> BnorRset a m --> 0 < b"
apply (induct a m rule: BnorRset_induct)
prefer 2
apply (subst BnorRset.simps)
@@ -103,7 +100,7 @@
done
lemma Bnor_mem_if [rule_format]:
- "zgcd b m = 1 --> 0 < b --> b \<le> a --> b \<in> BnorRset (a, m)"
+ "zgcd b m = 1 --> 0 < b --> b \<le> a --> b \<in> BnorRset a m"
apply (induct a m rule: BnorRset.induct, auto)
apply (subst BnorRset.simps)
defer
@@ -111,7 +108,7 @@
apply (unfold Let_def, auto)
done
-lemma Bnor_in_RsetR [rule_format]: "a < m --> BnorRset (a, m) \<in> RsetR m"
+lemma Bnor_in_RsetR [rule_format]: "a < m --> BnorRset a m \<in> RsetR m"
apply (induct a m rule: BnorRset_induct, simp)
apply (subst BnorRset.simps)
apply (unfold Let_def, auto)
@@ -124,7 +121,7 @@
apply (rule_tac [5] Bnor_mem_zg, auto)
done
-lemma Bnor_fin: "finite (BnorRset (a, m))"
+lemma Bnor_fin: "finite (BnorRset a m)"
apply (induct a m rule: BnorRset_induct)
prefer 2
apply (subst BnorRset.simps)
@@ -258,8 +255,8 @@
by (unfold inj_on_def, auto)
lemma Bnor_prod_power [rule_format]:
- "x \<noteq> 0 ==> a < m --> \<Prod>((\<lambda>a. a * x) ` BnorRset (a, m)) =
- \<Prod>(BnorRset(a, m)) * x^card (BnorRset (a, m))"
+ "x \<noteq> 0 ==> a < m --> \<Prod>((\<lambda>a. a * x) ` BnorRset a m) =
+ \<Prod>(BnorRset a m) * x^card (BnorRset a m)"
apply (induct a m rule: BnorRset_induct)
prefer 2
apply (simplesubst BnorRset.simps) --{*multiple redexes*}
@@ -284,7 +281,7 @@
done
lemma Bnor_prod_zgcd [rule_format]:
- "a < m --> zgcd (\<Prod>(BnorRset(a, m))) m = 1"
+ "a < m --> zgcd (\<Prod>(BnorRset a m)) m = 1"
apply (induct a m rule: BnorRset_induct)
prefer 2
apply (subst BnorRset.simps)
@@ -299,13 +296,13 @@
apply (case_tac "x = 0")
apply (case_tac [2] "m = 1")
apply (rule_tac [3] iffD1)
- apply (rule_tac [3] k = "\<Prod>(BnorRset(m - 1, m))"
+ apply (rule_tac [3] k = "\<Prod>(BnorRset (m - 1) m)"
in zcong_cancel2)
prefer 5
apply (subst Bnor_prod_power [symmetric])
apply (rule_tac [7] Bnor_prod_zgcd, simp_all)
apply (rule bijzcong_zcong_prod)
- apply (fold norRRset_def noXRRset_def)
+ apply (fold norRRset_def, fold noXRRset_def)
apply (subst RRset2norRR_eq_norR [symmetric])
apply (rule_tac [3] inj_func_bijR, auto)
apply (unfold zcongm_def)
@@ -319,12 +316,12 @@
done
lemma Bnor_prime:
- "\<lbrakk> zprime p; a < p \<rbrakk> \<Longrightarrow> card (BnorRset (a, p)) = nat a"
+ "\<lbrakk> zprime p; a < p \<rbrakk> \<Longrightarrow> card (BnorRset a p) = nat a"
apply (induct a p rule: BnorRset.induct)
apply (subst BnorRset.simps)
apply (unfold Let_def, auto simp add:zless_zprime_imp_zrelprime)
- apply (subgoal_tac "finite (BnorRset (a - 1,m))")
- apply (subgoal_tac "a ~: BnorRset (a - 1,m)")
+ apply (subgoal_tac "finite (BnorRset (a - 1) m)")
+ apply (subgoal_tac "a ~: BnorRset (a - 1) m")
apply (auto simp add: card_insert_disjoint Suc_nat_eq_nat_zadd1)
apply (frule Bnor_mem_zle, arith)
apply (frule Bnor_fin)
--- a/src/HOL/Old_Number_Theory/IntFact.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/Old_Number_Theory/IntFact.thy Wed Mar 03 16:43:55 2010 +0100
@@ -14,14 +14,14 @@
\bigskip
*}
-consts
+fun
zfact :: "int => int"
- d22set :: "int => int set"
-
-recdef zfact "measure ((\<lambda>n. nat n) :: int => nat)"
+where
"zfact n = (if n \<le> 0 then 1 else n * zfact (n - 1))"
-recdef d22set "measure ((\<lambda>a. nat a) :: int => nat)"
+fun
+ d22set :: "int => int set"
+where
"d22set a = (if 1 < a then insert a (d22set (a - 1)) else {})"
@@ -38,12 +38,10 @@
and "!!a. 1 < (a::int) ==> P (d22set (a - 1)) (a - 1) ==> P (d22set a) a"
shows "P (d22set u) u"
apply (rule d22set.induct)
- apply safe
- prefer 2
- apply (case_tac "1 < a")
- apply (rule_tac prems)
- apply (simp_all (no_asm_simp))
- apply (simp_all (no_asm_simp) add: d22set.simps prems)
+ apply (case_tac "1 < a")
+ apply (rule_tac assms)
+ apply (simp_all (no_asm_simp))
+ apply (simp_all (no_asm_simp) add: d22set.simps assms)
done
lemma d22set_g_1 [rule_format]: "b \<in> d22set a --> 1 < b"
@@ -66,7 +64,8 @@
lemma d22set_mem: "1 < b \<Longrightarrow> b \<le> a \<Longrightarrow> b \<in> d22set a"
apply (induct a rule: d22set.induct)
apply auto
- apply (simp_all add: d22set.simps)
+ apply (subst d22set.simps)
+ apply (case_tac "b < a", auto)
done
lemma d22set_fin: "finite (d22set a)"
@@ -81,8 +80,6 @@
lemma d22set_prod_zfact: "\<Prod>(d22set a) = zfact a"
apply (induct a rule: d22set.induct)
- apply safe
- apply (simp add: d22set.simps zfact.simps)
apply (subst d22set.simps)
apply (subst zfact.simps)
apply (case_tac "1 < a")
--- a/src/HOL/Old_Number_Theory/IntPrimes.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/Old_Number_Theory/IntPrimes.thy Wed Mar 03 16:43:55 2010 +0100
@@ -19,17 +19,14 @@
subsection {* Definitions *}
-consts
- xzgcda :: "int * int * int * int * int * int * int * int => int * int * int"
-
-recdef xzgcda
- "measure ((\<lambda>(m, n, r', r, s', s, t', t). nat r)
- :: int * int * int * int *int * int * int * int => nat)"
- "xzgcda (m, n, r', r, s', s, t', t) =
+fun
+ xzgcda :: "int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int => (int * int * int)"
+where
+ "xzgcda m n r' r s' s t' t =
(if r \<le> 0 then (r', s', t')
- else xzgcda (m, n, r, r' mod r,
- s, s' - (r' div r) * s,
- t, t' - (r' div r) * t))"
+ else xzgcda m n r (r' mod r)
+ s (s' - (r' div r) * s)
+ t (t' - (r' div r) * t))"
definition
zprime :: "int \<Rightarrow> bool" where
@@ -37,7 +34,7 @@
definition
xzgcd :: "int => int => int * int * int" where
- "xzgcd m n = xzgcda (m, n, m, n, 1, 0, 0, 1)"
+ "xzgcd m n = xzgcda m n m n 1 0 0 1"
definition
zcong :: "int => int => int => bool" ("(1[_ = _] '(mod _'))") where
@@ -307,9 +304,8 @@
lemma xzgcd_correct_aux1:
"zgcd r' r = k --> 0 < r -->
- (\<exists>sn tn. xzgcda (m, n, r', r, s', s, t', t) = (k, sn, tn))"
- apply (rule_tac u = m and v = n and w = r' and x = r and y = s' and
- z = s and aa = t' and ab = t in xzgcda.induct)
+ (\<exists>sn tn. xzgcda m n r' r s' s t' t = (k, sn, tn))"
+ apply (induct m n r' r s' s t' t rule: xzgcda.induct)
apply (subst zgcd_eq)
apply (subst xzgcda.simps, auto)
apply (case_tac "r' mod r = 0")
@@ -321,17 +317,16 @@
done
lemma xzgcd_correct_aux2:
- "(\<exists>sn tn. xzgcda (m, n, r', r, s', s, t', t) = (k, sn, tn)) --> 0 < r -->
+ "(\<exists>sn tn. xzgcda m n r' r s' s t' t = (k, sn, tn)) --> 0 < r -->
zgcd r' r = k"
- apply (rule_tac u = m and v = n and w = r' and x = r and y = s' and
- z = s and aa = t' and ab = t in xzgcda.induct)
+ apply (induct m n r' r s' s t' t rule: xzgcda.induct)
apply (subst zgcd_eq)
apply (subst xzgcda.simps)
apply (auto simp add: linorder_not_le)
apply (case_tac "r' mod r = 0")
prefer 2
apply (frule_tac a = "r'" in pos_mod_sign, auto)
- apply (metis Pair_eq simps zle_refl)
+ apply (metis Pair_eq xzgcda.simps zle_refl)
done
lemma xzgcd_correct:
@@ -362,10 +357,9 @@
by (rule iffD2 [OF order_less_le conjI])
lemma xzgcda_linear [rule_format]:
- "0 < r --> xzgcda (m, n, r', r, s', s, t', t) = (rn, sn, tn) -->
+ "0 < r --> xzgcda m n r' r s' s t' t = (rn, sn, tn) -->
r' = s' * m + t' * n --> r = s * m + t * n --> rn = sn * m + tn * n"
- apply (rule_tac u = m and v = n and w = r' and x = r and y = s' and
- z = s and aa = t' and ab = t in xzgcda.induct)
+ apply (induct m n r' r s' s t' t rule: xzgcda.induct)
apply (subst xzgcda.simps)
apply (simp (no_asm))
apply (rule impI)+
--- a/src/HOL/Old_Number_Theory/WilsonRuss.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/Old_Number_Theory/WilsonRuss.thy Wed Mar 03 16:43:55 2010 +0100
@@ -17,14 +17,12 @@
inv :: "int => int => int" where
"inv p a = (a^(nat (p - 2))) mod p"
-consts
- wset :: "int * int => int set"
-
-recdef wset
- "measure ((\<lambda>(a, p). nat a) :: int * int => nat)"
- "wset (a, p) =
+fun
+ wset :: "int \<Rightarrow> int => int set"
+where
+ "wset a p =
(if 1 < a then
- let ws = wset (a - 1, p)
+ let ws = wset (a - 1) p
in (if a \<in> ws then ws else insert a (insert (inv p a) ws)) else {})"
@@ -163,35 +161,33 @@
lemma wset_induct:
assumes "!!a p. P {} a p"
and "!!a p. 1 < (a::int) \<Longrightarrow>
- P (wset (a - 1, p)) (a - 1) p ==> P (wset (a, p)) a p"
- shows "P (wset (u, v)) u v"
- apply (rule wset.induct, safe)
- prefer 2
- apply (case_tac "1 < a")
- apply (rule prems)
- apply simp_all
- apply (simp_all add: wset.simps prems)
+ P (wset (a - 1) p) (a - 1) p ==> P (wset a p) a p"
+ shows "P (wset u v) u v"
+ apply (rule wset.induct)
+ apply (case_tac "1 < a")
+ apply (rule assms)
+ apply (simp_all add: wset.simps assms)
done
lemma wset_mem_imp_or [rule_format]:
- "1 < a \<Longrightarrow> b \<notin> wset (a - 1, p)
- ==> b \<in> wset (a, p) --> b = a \<or> b = inv p a"
+ "1 < a \<Longrightarrow> b \<notin> wset (a - 1) p
+ ==> b \<in> wset a p --> b = a \<or> b = inv p a"
apply (subst wset.simps)
apply (unfold Let_def, simp)
done
-lemma wset_mem_mem [simp]: "1 < a ==> a \<in> wset (a, p)"
+lemma wset_mem_mem [simp]: "1 < a ==> a \<in> wset a p"
apply (subst wset.simps)
apply (unfold Let_def, simp)
done
-lemma wset_subset: "1 < a \<Longrightarrow> b \<in> wset (a - 1, p) ==> b \<in> wset (a, p)"
+lemma wset_subset: "1 < a \<Longrightarrow> b \<in> wset (a - 1) p ==> b \<in> wset a p"
apply (subst wset.simps)
apply (unfold Let_def, auto)
done
lemma wset_g_1 [rule_format]:
- "zprime p --> a < p - 1 --> b \<in> wset (a, p) --> 1 < b"
+ "zprime p --> a < p - 1 --> b \<in> wset a p --> 1 < b"
apply (induct a p rule: wset_induct, auto)
apply (case_tac "b = a")
apply (case_tac [2] "b = inv p a")
@@ -203,7 +199,7 @@
done
lemma wset_less [rule_format]:
- "zprime p --> a < p - 1 --> b \<in> wset (a, p) --> b < p - 1"
+ "zprime p --> a < p - 1 --> b \<in> wset a p --> b < p - 1"
apply (induct a p rule: wset_induct, auto)
apply (case_tac "b = a")
apply (case_tac [2] "b = inv p a")
@@ -216,7 +212,7 @@
lemma wset_mem [rule_format]:
"zprime p -->
- a < p - 1 --> 1 < b --> b \<le> a --> b \<in> wset (a, p)"
+ a < p - 1 --> 1 < b --> b \<le> a --> b \<in> wset a p"
apply (induct a p rule: wset.induct, auto)
apply (rule_tac wset_subset)
apply (simp (no_asm_simp))
@@ -224,8 +220,8 @@
done
lemma wset_mem_inv_mem [rule_format]:
- "zprime p --> 5 \<le> p --> a < p - 1 --> b \<in> wset (a, p)
- --> inv p b \<in> wset (a, p)"
+ "zprime p --> 5 \<le> p --> a < p - 1 --> b \<in> wset a p
+ --> inv p b \<in> wset a p"
apply (induct a p rule: wset_induct, auto)
apply (case_tac "b = a")
apply (subst wset.simps)
@@ -240,13 +236,13 @@
lemma wset_inv_mem_mem:
"zprime p \<Longrightarrow> 5 \<le> p \<Longrightarrow> a < p - 1 \<Longrightarrow> 1 < b \<Longrightarrow> b < p - 1
- \<Longrightarrow> inv p b \<in> wset (a, p) \<Longrightarrow> b \<in> wset (a, p)"
+ \<Longrightarrow> inv p b \<in> wset a p \<Longrightarrow> b \<in> wset a p"
apply (rule_tac s = "inv p (inv p b)" and t = b in subst)
apply (rule_tac [2] wset_mem_inv_mem)
apply (rule inv_inv, simp_all)
done
-lemma wset_fin: "finite (wset (a, p))"
+lemma wset_fin: "finite (wset a p)"
apply (induct a p rule: wset_induct)
prefer 2
apply (subst wset.simps)
@@ -255,27 +251,27 @@
lemma wset_zcong_prod_1 [rule_format]:
"zprime p -->
- 5 \<le> p --> a < p - 1 --> [(\<Prod>x\<in>wset(a, p). x) = 1] (mod p)"
+ 5 \<le> p --> a < p - 1 --> [(\<Prod>x\<in>wset a p. x) = 1] (mod p)"
apply (induct a p rule: wset_induct)
prefer 2
apply (subst wset.simps)
- apply (unfold Let_def, auto)
+ apply (auto, unfold Let_def, auto)
apply (subst setprod_insert)
apply (tactic {* stac (thm "setprod_insert") 3 *})
apply (subgoal_tac [5]
- "zcong (a * inv p a * (\<Prod>x\<in> wset(a - 1, p). x)) (1 * 1) p")
+ "zcong (a * inv p a * (\<Prod>x\<in>wset (a - 1) p. x)) (1 * 1) p")
prefer 5
apply (simp add: zmult_assoc)
apply (rule_tac [5] zcong_zmult)
apply (rule_tac [5] inv_is_inv)
apply (tactic "clarify_tac @{claset} 4")
- apply (subgoal_tac [4] "a \<in> wset (a - 1, p)")
+ apply (subgoal_tac [4] "a \<in> wset (a - 1) p")
apply (rule_tac [5] wset_inv_mem_mem)
apply (simp_all add: wset_fin)
apply (rule inv_distinct, auto)
done
-lemma d22set_eq_wset: "zprime p ==> d22set (p - 2) = wset (p - 2, p)"
+lemma d22set_eq_wset: "zprime p ==> d22set (p - 2) = wset (p - 2) p"
apply safe
apply (erule wset_mem)
apply (rule_tac [2] d22set_g_1)
--- a/src/HOL/RealPow.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/RealPow.thy Wed Mar 03 16:43:55 2010 +0100
@@ -113,9 +113,6 @@
lemma real_le_add_half_cancel: "(x + y/2 \<le> (y::real)) = (x \<le> y /2)"
by auto
-lemma real_minus_half_eq [simp]: "(x::real) - x/2 = x/2"
-by auto
-
lemma real_mult_inverse_cancel:
"[|(0::real) < x; 0 < x1; x1 * y < x * u |]
==> inverse x * y < inverse x1 * u"
--- a/src/HOL/Tools/Predicate_Compile/predicate_compile_quickcheck.ML Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/Tools/Predicate_Compile/predicate_compile_quickcheck.ML Wed Mar 03 16:43:55 2010 +0100
@@ -10,12 +10,10 @@
val test_ref :
((unit -> int -> int -> int * int -> term list DSequence.dseq * (int * int)) option) Unsynchronized.ref
val tracing : bool Unsynchronized.ref;
- val quickcheck_compile_term : bool -> bool ->
+ val quickcheck_compile_term : bool -> bool -> int ->
Proof.context -> bool -> term -> int -> term list option * (bool list * bool);
(* val test_term : Proof.context -> bool -> int -> int -> int -> int -> term -> *)
- val quiet : bool Unsynchronized.ref;
val nrandom : int Unsynchronized.ref;
- val depth : int Unsynchronized.ref;
val debug : bool Unsynchronized.ref;
val function_flattening : bool Unsynchronized.ref;
val no_higher_order_predicate : string list Unsynchronized.ref;
@@ -31,19 +29,17 @@
val tracing = Unsynchronized.ref false;
-val target = "Quickcheck"
+val quiet = Unsynchronized.ref true;
-val quiet = Unsynchronized.ref false;
+val target = "Quickcheck"
val nrandom = Unsynchronized.ref 2;
-val depth = Unsynchronized.ref 8;
+val debug = Unsynchronized.ref false;
-val debug = Unsynchronized.ref false;
val function_flattening = Unsynchronized.ref true;
-
-val no_higher_order_predicate = Unsynchronized.ref [];
+val no_higher_order_predicate = Unsynchronized.ref ([] : string list);
val options = Options {
expected_modes = NONE,
@@ -231,21 +227,21 @@
(* quickcheck interface functions *)
-fun compile_term' options ctxt report t =
+fun compile_term' options depth ctxt report t =
let
val c = compile_term options ctxt t
val dummy_report = ([], false)
in
- fn size => (try_upto (!quiet) (c size (!nrandom)) (!depth), dummy_report)
+ fn size => (try_upto (!quiet) (c size (!nrandom)) depth, dummy_report)
end
-fun quickcheck_compile_term function_flattening fail_safe_function_flattening ctxt t =
+fun quickcheck_compile_term function_flattening fail_safe_function_flattening depth =
let
val options =
set_fail_safe_function_flattening fail_safe_function_flattening
(set_function_flattening function_flattening (get_options ()))
in
- compile_term' options ctxt t
+ compile_term' options depth
end
end;
--- a/src/HOL/ZF/Games.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/ZF/Games.thy Wed Mar 03 16:43:55 2010 +0100
@@ -1,4 +1,4 @@
-(* Title: HOL/ZF/Games.thy
+(* Title: HOL/ZF/MainZF.thy/Games.thy
Author: Steven Obua
An application of HOLZF: Partizan Games. See "Partizan Games in
@@ -347,13 +347,12 @@
right_option_def[symmetric] left_option_def[symmetric])
done
-consts
+function
neg_game :: "game \<Rightarrow> game"
-
-recdef neg_game "option_of"
- "neg_game g = Game (zimage neg_game (right_options g)) (zimage neg_game (left_options g))"
-
-declare neg_game.simps[simp del]
+where
+ [simp del]: "neg_game g = Game (zimage neg_game (right_options g)) (zimage neg_game (left_options g))"
+by auto
+termination by (relation "option_of") auto
lemma "neg_game (neg_game g) = g"
apply (induct g rule: neg_game.induct)
@@ -365,17 +364,16 @@
apply (auto simp add: zet_ext_eq zimage_iff)
done
-consts
+function
ge_game :: "(game * game) \<Rightarrow> bool"
-
-recdef ge_game "(gprod_2_1 option_of)"
- "ge_game (G, H) = (\<forall> x. if zin x (right_options G) then (
+where
+ [simp del]: "ge_game (G, H) = (\<forall> x. if zin x (right_options G) then (
if zin x (left_options H) then \<not> (ge_game (H, x) \<or> (ge_game (x, G)))
else \<not> (ge_game (H, x)))
else (if zin x (left_options H) then \<not> (ge_game (x, G)) else True))"
-(hints simp: gprod_2_1_def)
-
-declare ge_game.simps [simp del]
+by auto
+termination by (relation "(gprod_2_1 option_of)")
+ (simp, auto simp: gprod_2_1_def)
lemma ge_game_eq: "ge_game (G, H) = (\<forall> x. (zin x (right_options G) \<longrightarrow> \<not> ge_game (H, x)) \<and> (zin x (left_options H) \<longrightarrow> \<not> ge_game (x, G)))"
apply (subst ge_game.simps[where G=G and H=H])
@@ -506,19 +504,18 @@
definition zero_game :: game
where "zero_game \<equiv> Game zempty zempty"
-consts
- plus_game :: "game * game \<Rightarrow> game"
+function
+ plus_game :: "game \<Rightarrow> game \<Rightarrow> game"
+where
+ [simp del]: "plus_game G H = Game (zunion (zimage (\<lambda> g. plus_game g H) (left_options G))
+ (zimage (\<lambda> h. plus_game G h) (left_options H)))
+ (zunion (zimage (\<lambda> g. plus_game g H) (right_options G))
+ (zimage (\<lambda> h. plus_game G h) (right_options H)))"
+by auto
+termination by (relation "gprod_2_2 option_of")
+ (simp, auto simp: gprod_2_2_def)
-recdef plus_game "gprod_2_2 option_of"
- "plus_game (G, H) = Game (zunion (zimage (\<lambda> g. plus_game (g, H)) (left_options G))
- (zimage (\<lambda> h. plus_game (G, h)) (left_options H)))
- (zunion (zimage (\<lambda> g. plus_game (g, H)) (right_options G))
- (zimage (\<lambda> h. plus_game (G, h)) (right_options H)))"
-(hints simp add: gprod_2_2_def)
-
-declare plus_game.simps[simp del]
-
-lemma plus_game_comm: "plus_game (G, H) = plus_game (H, G)"
+lemma plus_game_comm: "plus_game G H = plus_game H G"
proof (induct G H rule: plus_game.induct)
case (1 G H)
show ?case
@@ -541,11 +538,11 @@
lemma right_zero_game[simp]: "right_options (zero_game) = zempty"
by (simp add: zero_game_def)
-lemma plus_game_zero_right[simp]: "plus_game (G, zero_game) = G"
+lemma plus_game_zero_right[simp]: "plus_game G zero_game = G"
proof -
{
fix G H
- have "H = zero_game \<longrightarrow> plus_game (G, H) = G "
+ have "H = zero_game \<longrightarrow> plus_game G H = G "
proof (induct G H rule: plus_game.induct, rule impI)
case (goal1 G H)
note induct_hyp = prems[simplified goal1, simplified] and prems
@@ -553,7 +550,7 @@
apply (simp only: plus_game.simps[where G=G and H=H])
apply (simp add: game_ext_eq prems)
apply (auto simp add:
- zimage_cong[where f = "\<lambda> g. plus_game (g, zero_game)" and g = "id"]
+ zimage_cong[where f = "\<lambda> g. plus_game g zero_game" and g = "id"]
induct_hyp)
done
qed
@@ -561,7 +558,7 @@
then show ?thesis by auto
qed
-lemma plus_game_zero_left: "plus_game (zero_game, G) = G"
+lemma plus_game_zero_left: "plus_game zero_game G = G"
by (simp add: plus_game_comm)
lemma left_imp_options[simp]: "zin opt (left_options g) \<Longrightarrow> zin opt (options g)"
@@ -571,11 +568,11 @@
by (simp add: options_def zunion)
lemma left_options_plus:
- "left_options (plus_game (u, v)) = zunion (zimage (\<lambda>g. plus_game (g, v)) (left_options u)) (zimage (\<lambda>h. plus_game (u, h)) (left_options v))"
+ "left_options (plus_game u v) = zunion (zimage (\<lambda>g. plus_game g v) (left_options u)) (zimage (\<lambda>h. plus_game u h) (left_options v))"
by (subst plus_game.simps, simp)
lemma right_options_plus:
- "right_options (plus_game (u, v)) = zunion (zimage (\<lambda>g. plus_game (g, v)) (right_options u)) (zimage (\<lambda>h. plus_game (u, h)) (right_options v))"
+ "right_options (plus_game u v) = zunion (zimage (\<lambda>g. plus_game g v) (right_options u)) (zimage (\<lambda>h. plus_game u h) (right_options v))"
by (subst plus_game.simps, simp)
lemma left_options_neg: "left_options (neg_game u) = zimage neg_game (right_options u)"
@@ -584,32 +581,32 @@
lemma right_options_neg: "right_options (neg_game u) = zimage neg_game (left_options u)"
by (subst neg_game.simps, simp)
-lemma plus_game_assoc: "plus_game (plus_game (F, G), H) = plus_game (F, plus_game (G, H))"
+lemma plus_game_assoc: "plus_game (plus_game F G) H = plus_game F (plus_game G H)"
proof -
{
fix a
- have "\<forall> F G H. a = [F, G, H] \<longrightarrow> plus_game (plus_game (F, G), H) = plus_game (F, plus_game (G, H))"
+ have "\<forall> F G H. a = [F, G, H] \<longrightarrow> plus_game (plus_game F G) H = plus_game F (plus_game G H)"
proof (induct a rule: induct_game, (rule impI | rule allI)+)
case (goal1 x F G H)
- let ?L = "plus_game (plus_game (F, G), H)"
- let ?R = "plus_game (F, plus_game (G, H))"
+ let ?L = "plus_game (plus_game F G) H"
+ let ?R = "plus_game F (plus_game G H)"
note options_plus = left_options_plus right_options_plus
{
fix opt
note hyp = goal1(1)[simplified goal1(2), rule_format]
- have F: "zin opt (options F) \<Longrightarrow> plus_game (plus_game (opt, G), H) = plus_game (opt, plus_game (G, H))"
+ have F: "zin opt (options F) \<Longrightarrow> plus_game (plus_game opt G) H = plus_game opt (plus_game G H)"
by (blast intro: hyp lprod_3_3)
- have G: "zin opt (options G) \<Longrightarrow> plus_game (plus_game (F, opt), H) = plus_game (F, plus_game (opt, H))"
+ have G: "zin opt (options G) \<Longrightarrow> plus_game (plus_game F opt) H = plus_game F (plus_game opt H)"
by (blast intro: hyp lprod_3_4)
- have H: "zin opt (options H) \<Longrightarrow> plus_game (plus_game (F, G), opt) = plus_game (F, plus_game (G, opt))"
+ have H: "zin opt (options H) \<Longrightarrow> plus_game (plus_game F G) opt = plus_game F (plus_game G opt)"
by (blast intro: hyp lprod_3_5)
note F and G and H
}
note induct_hyp = this
have "left_options ?L = left_options ?R \<and> right_options ?L = right_options ?R"
by (auto simp add:
- plus_game.simps[where G="plus_game (F,G)" and H=H]
- plus_game.simps[where G="F" and H="plus_game (G,H)"]
+ plus_game.simps[where G="plus_game F G" and H=H]
+ plus_game.simps[where G="F" and H="plus_game G H"]
zet_ext_eq zunion zimage_iff options_plus
induct_hyp left_imp_options right_imp_options)
then show ?case
@@ -619,7 +616,7 @@
then show ?thesis by auto
qed
-lemma neg_plus_game: "neg_game (plus_game (G, H)) = plus_game(neg_game G, neg_game H)"
+lemma neg_plus_game: "neg_game (plus_game G H) = plus_game (neg_game G) (neg_game H)"
proof (induct G H rule: plus_game.induct)
case (1 G H)
note opt_ops =
@@ -627,26 +624,26 @@
left_options_neg right_options_neg
show ?case
by (auto simp add: opt_ops
- neg_game.simps[of "plus_game (G,H)"]
+ neg_game.simps[of "plus_game G H"]
plus_game.simps[of "neg_game G" "neg_game H"]
Game_ext zet_ext_eq zunion zimage_iff prems)
qed
-lemma eq_game_plus_inverse: "eq_game (plus_game (x, neg_game x)) zero_game"
+lemma eq_game_plus_inverse: "eq_game (plus_game x (neg_game x)) zero_game"
proof (induct x rule: wf_induct[OF wf_option_of])
case (goal1 x)
{ fix y
assume "zin y (options x)"
- then have "eq_game (plus_game (y, neg_game y)) zero_game"
+ then have "eq_game (plus_game y (neg_game y)) zero_game"
by (auto simp add: prems)
}
note ihyp = this
{
fix y
assume y: "zin y (right_options x)"
- have "\<not> (ge_game (zero_game, plus_game (y, neg_game x)))"
+ have "\<not> (ge_game (zero_game, plus_game y (neg_game x)))"
apply (subst ge_game.simps, simp)
- apply (rule exI[where x="plus_game (y, neg_game y)"])
+ apply (rule exI[where x="plus_game y (neg_game y)"])
apply (auto simp add: ihyp[of y, simplified y right_imp_options eq_game_def])
apply (auto simp add: left_options_plus left_options_neg zunion zimage_iff intro: prems)
done
@@ -655,9 +652,9 @@
{
fix y
assume y: "zin y (left_options x)"
- have "\<not> (ge_game (zero_game, plus_game (x, neg_game y)))"
+ have "\<not> (ge_game (zero_game, plus_game x (neg_game y)))"
apply (subst ge_game.simps, simp)
- apply (rule exI[where x="plus_game (y, neg_game y)"])
+ apply (rule exI[where x="plus_game y (neg_game y)"])
apply (auto simp add: ihyp[of y, simplified y left_imp_options eq_game_def])
apply (auto simp add: left_options_plus zunion zimage_iff intro: prems)
done
@@ -666,9 +663,9 @@
{
fix y
assume y: "zin y (left_options x)"
- have "\<not> (ge_game (plus_game (y, neg_game x), zero_game))"
+ have "\<not> (ge_game (plus_game y (neg_game x), zero_game))"
apply (subst ge_game.simps, simp)
- apply (rule exI[where x="plus_game (y, neg_game y)"])
+ apply (rule exI[where x="plus_game y (neg_game y)"])
apply (auto simp add: ihyp[of y, simplified y left_imp_options eq_game_def])
apply (auto simp add: right_options_plus right_options_neg zunion zimage_iff intro: prems)
done
@@ -677,9 +674,9 @@
{
fix y
assume y: "zin y (right_options x)"
- have "\<not> (ge_game (plus_game (x, neg_game y), zero_game))"
+ have "\<not> (ge_game (plus_game x (neg_game y), zero_game))"
apply (subst ge_game.simps, simp)
- apply (rule exI[where x="plus_game (y, neg_game y)"])
+ apply (rule exI[where x="plus_game y (neg_game y)"])
apply (auto simp add: ihyp[of y, simplified y right_imp_options eq_game_def])
apply (auto simp add: right_options_plus zunion zimage_iff intro: prems)
done
@@ -687,28 +684,28 @@
note case4 = this
show ?case
apply (simp add: eq_game_def)
- apply (simp add: ge_game.simps[of "plus_game (x, neg_game x)" "zero_game"])
- apply (simp add: ge_game.simps[of "zero_game" "plus_game (x, neg_game x)"])
+ apply (simp add: ge_game.simps[of "plus_game x (neg_game x)" "zero_game"])
+ apply (simp add: ge_game.simps[of "zero_game" "plus_game x (neg_game x)"])
apply (simp add: right_options_plus left_options_plus right_options_neg left_options_neg zunion zimage_iff)
apply (auto simp add: case1 case2 case3 case4)
done
qed
-lemma ge_plus_game_left: "ge_game (y,z) = ge_game(plus_game (x, y), plus_game (x, z))"
+lemma ge_plus_game_left: "ge_game (y,z) = ge_game (plus_game x y, plus_game x z)"
proof -
{ fix a
- have "\<forall> x y z. a = [x,y,z] \<longrightarrow> ge_game (y,z) = ge_game(plus_game (x, y), plus_game (x, z))"
+ have "\<forall> x y z. a = [x,y,z] \<longrightarrow> ge_game (y,z) = ge_game (plus_game x y, plus_game x z)"
proof (induct a rule: induct_game, (rule impI | rule allI)+)
case (goal1 a x y z)
note induct_hyp = goal1(1)[rule_format, simplified goal1(2)]
{
- assume hyp: "ge_game(plus_game (x, y), plus_game (x, z))"
+ assume hyp: "ge_game(plus_game x y, plus_game x z)"
have "ge_game (y, z)"
proof -
{ fix yr
assume yr: "zin yr (right_options y)"
- from hyp have "\<not> (ge_game (plus_game (x, z), plus_game (x, yr)))"
- by (auto simp add: ge_game_eq[of "plus_game (x,y)" "plus_game(x,z)"]
+ from hyp have "\<not> (ge_game (plus_game x z, plus_game x yr))"
+ by (auto simp add: ge_game_eq[of "plus_game x y" "plus_game x z"]
right_options_plus zunion zimage_iff intro: yr)
then have "\<not> (ge_game (z, yr))"
apply (subst induct_hyp[where y="[x, z, yr]", of "x" "z" "yr"])
@@ -718,8 +715,8 @@
note yr = this
{ fix zl
assume zl: "zin zl (left_options z)"
- from hyp have "\<not> (ge_game (plus_game (x, zl), plus_game (x, y)))"
- by (auto simp add: ge_game_eq[of "plus_game (x,y)" "plus_game(x,z)"]
+ from hyp have "\<not> (ge_game (plus_game x zl, plus_game x y))"
+ by (auto simp add: ge_game_eq[of "plus_game x y" "plus_game x z"]
left_options_plus zunion zimage_iff intro: zl)
then have "\<not> (ge_game (zl, y))"
apply (subst goal1(1)[rule_format, where y="[x, zl, y]", of "x" "zl" "y"])
@@ -739,11 +736,11 @@
{
fix x'
assume x': "zin x' (right_options x)"
- assume hyp: "ge_game (plus_game (x, z), plus_game (x', y))"
- then have n: "\<not> (ge_game (plus_game (x', y), plus_game (x', z)))"
- by (auto simp add: ge_game_eq[of "plus_game (x,z)" "plus_game (x', y)"]
+ assume hyp: "ge_game (plus_game x z, plus_game x' y)"
+ then have n: "\<not> (ge_game (plus_game x' y, plus_game x' z))"
+ by (auto simp add: ge_game_eq[of "plus_game x z" "plus_game x' y"]
right_options_plus zunion zimage_iff intro: x')
- have t: "ge_game (plus_game (x', y), plus_game (x', z))"
+ have t: "ge_game (plus_game x' y, plus_game x' z)"
apply (subst induct_hyp[symmetric])
apply (auto intro: lprod_3_3 x' yz)
done
@@ -753,11 +750,11 @@
{
fix x'
assume x': "zin x' (left_options x)"
- assume hyp: "ge_game (plus_game (x', z), plus_game (x, y))"
- then have n: "\<not> (ge_game (plus_game (x', y), plus_game (x', z)))"
- by (auto simp add: ge_game_eq[of "plus_game (x',z)" "plus_game (x, y)"]
+ assume hyp: "ge_game (plus_game x' z, plus_game x y)"
+ then have n: "\<not> (ge_game (plus_game x' y, plus_game x' z))"
+ by (auto simp add: ge_game_eq[of "plus_game x' z" "plus_game x y"]
left_options_plus zunion zimage_iff intro: x')
- have t: "ge_game (plus_game (x', y), plus_game (x', z))"
+ have t: "ge_game (plus_game x' y, plus_game x' z)"
apply (subst induct_hyp[symmetric])
apply (auto intro: lprod_3_3 x' yz)
done
@@ -767,7 +764,7 @@
{
fix y'
assume y': "zin y' (right_options y)"
- assume hyp: "ge_game (plus_game(x, z), plus_game (x, y'))"
+ assume hyp: "ge_game (plus_game x z, plus_game x y')"
then have "ge_game(z, y')"
apply (subst induct_hyp[of "[x, z, y']" "x" "z" "y'"])
apply (auto simp add: hyp lprod_3_6 y')
@@ -780,7 +777,7 @@
{
fix z'
assume z': "zin z' (left_options z)"
- assume hyp: "ge_game (plus_game(x, z'), plus_game (x, y))"
+ assume hyp: "ge_game (plus_game x z', plus_game x y)"
then have "ge_game(z', y)"
apply (subst induct_hyp[of "[x, z', y]" "x" "z'" "y"])
apply (auto simp add: hyp lprod_3_7 z')
@@ -790,7 +787,7 @@
with z' have "False" by (auto simp add: ge_game_leftright_refl)
}
note case4 = this
- have "ge_game(plus_game (x, y), plus_game (x, z))"
+ have "ge_game(plus_game x y, plus_game x z)"
apply (subst ge_game_eq)
apply (auto simp add: right_options_plus left_options_plus zunion zimage_iff)
apply (auto intro: case1 case2 case3 case4)
@@ -804,7 +801,7 @@
then show ?thesis by blast
qed
-lemma ge_plus_game_right: "ge_game (y,z) = ge_game(plus_game (y, x), plus_game (z, x))"
+lemma ge_plus_game_right: "ge_game (y,z) = ge_game(plus_game y x, plus_game z x)"
by (simp add: ge_plus_game_left plus_game_comm)
lemma ge_neg_game: "ge_game (neg_game x, neg_game y) = ge_game (y, x)"
@@ -865,7 +862,7 @@
Pg_minus_def: "- G = contents (\<Union> g \<in> Rep_Pg G. {Abs_Pg (eq_game_rel `` {neg_game g})})"
definition
- Pg_plus_def: "G + H = contents (\<Union> g \<in> Rep_Pg G. \<Union> h \<in> Rep_Pg H. {Abs_Pg (eq_game_rel `` {plus_game (g,h)})})"
+ Pg_plus_def: "G + H = contents (\<Union> g \<in> Rep_Pg G. \<Union> h \<in> Rep_Pg H. {Abs_Pg (eq_game_rel `` {plus_game g h})})"
definition
Pg_diff_def: "G - H = G + (- (H::Pg))"
@@ -891,14 +888,14 @@
apply (simp add: eq_game_rel_def)
done
-lemma char_Pg_plus[simp]: "Abs_Pg (eq_game_rel `` {g}) + Abs_Pg (eq_game_rel `` {h}) = Abs_Pg (eq_game_rel `` {plus_game (g, h)})"
+lemma char_Pg_plus[simp]: "Abs_Pg (eq_game_rel `` {g}) + Abs_Pg (eq_game_rel `` {h}) = Abs_Pg (eq_game_rel `` {plus_game g h})"
proof -
- have "(\<lambda> g h. {Abs_Pg (eq_game_rel `` {plus_game (g, h)})}) respects2 eq_game_rel"
+ have "(\<lambda> g h. {Abs_Pg (eq_game_rel `` {plus_game g h})}) respects2 eq_game_rel"
apply (simp add: congruent2_def)
apply (auto simp add: eq_game_rel_def eq_game_def)
- apply (rule_tac y="plus_game (y1, z2)" in ge_game_trans)
+ apply (rule_tac y="plus_game y1 z2" in ge_game_trans)
apply (simp add: ge_plus_game_left[symmetric] ge_plus_game_right[symmetric])+
- apply (rule_tac y="plus_game (z1, y2)" in ge_game_trans)
+ apply (rule_tac y="plus_game z1 y2" in ge_game_trans)
apply (simp add: ge_plus_game_left[symmetric] ge_plus_game_right[symmetric])+
done
then show ?thesis
--- a/src/HOL/ZF/HOLZF.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/ZF/HOLZF.thy Wed Mar 03 16:43:55 2010 +0100
@@ -6,7 +6,7 @@
*)
theory HOLZF
-imports Helper
+imports Main
begin
typedecl ZF
@@ -298,7 +298,7 @@
apply (rule_tac x="Fst z" in exI)
apply (simp add: isOpair_def)
apply (auto simp add: Fst Snd Opair)
- apply (rule theI2')
+ apply (rule the1I2)
apply auto
apply (drule Fun_implies_PFun)
apply (drule_tac x="Opair x ya" and y="Opair x yb" in PFun_inj)
@@ -306,7 +306,7 @@
apply (drule Fun_implies_PFun)
apply (drule_tac x="Opair x y" and y="Opair x ya" in PFun_inj)
apply (auto simp add: Fst Snd)
- apply (rule theI2')
+ apply (rule the1I2)
apply (auto simp add: Fun_total)
apply (drule Fun_implies_PFun)
apply (drule_tac x="Opair a x" and y="Opair a y" in PFun_inj)
--- a/src/HOL/ZF/Helper.thy Wed Mar 03 15:40:39 2010 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,32 +0,0 @@
-(* Title: HOL/ZF/Helper.thy
- ID: $Id$
- Author: Steven Obua
-
- Some helpful lemmas that probably will end up elsewhere.
-*)
-
-theory Helper
-imports Main
-begin
-
-lemma theI2' : "?! x. P x \<Longrightarrow> (!! x. P x \<Longrightarrow> Q x) \<Longrightarrow> Q (THE x. P x)"
- apply auto
- apply (subgoal_tac "P (THE x. P x)")
- apply blast
- apply (rule theI)
- apply auto
- done
-
-lemma in_range_superfluous: "(z \<in> range f & z \<in> (f ` x)) = (z \<in> f ` x)"
- by auto
-
-lemma f_x_in_range_f: "f x \<in> range f"
- by (blast intro: image_eqI)
-
-lemma comp_inj: "inj f \<Longrightarrow> inj g \<Longrightarrow> inj (g o f)"
- by (blast intro: comp_inj_on subset_inj_on)
-
-lemma comp_image_eq: "(g o f) ` x = g ` f ` x"
- by auto
-
-end
\ No newline at end of file
--- a/src/HOL/ZF/Zet.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/ZF/Zet.thy Wed Mar 03 16:43:55 2010 +0100
@@ -35,7 +35,7 @@
apply (rule_tac x="Repl z (g o (inv_into A f))" in exI)
apply (simp add: explode_Repl_eq)
apply (subgoal_tac "explode z = f ` A")
- apply (simp_all add: comp_image_eq)
+ apply (simp_all add: image_compose)
done
lemma zet_image_mem:
@@ -56,7 +56,7 @@
apply (auto simp add: subset injf)
done
show ?thesis
- apply (simp add: zet_def' comp_image_eq[symmetric])
+ apply (simp add: zet_def' image_compose[symmetric])
apply (rule exI[where x="?w"])
apply (simp add: injw image_zet_rep Azet)
done
@@ -108,7 +108,7 @@
lemma comp_zimage_eq: "zimage g (zimage f A) = zimage (g o f) A"
apply (simp add: zimage_def)
apply (subst Abs_zet_inverse)
- apply (simp_all add: comp_image_eq zet_image_mem Rep_zet)
+ apply (simp_all add: image_compose zet_image_mem Rep_zet)
done
definition zunion :: "'a zet \<Rightarrow> 'a zet \<Rightarrow> 'a zet" where
@@ -196,7 +196,7 @@
lemma zimage_id[simp]: "zimage id A = A"
by (simp add: zet_ext_eq zimage_iff)
-lemma zimage_cong[recdef_cong]: "\<lbrakk> M = N; !! x. zin x N \<Longrightarrow> f x = g x \<rbrakk> \<Longrightarrow> zimage f M = zimage g N"
+lemma zimage_cong[recdef_cong, fundef_cong]: "\<lbrakk> M = N; !! x. zin x N \<Longrightarrow> f x = g x \<rbrakk> \<Longrightarrow> zimage f M = zimage g N"
by (auto simp add: zet_ext_eq zimage_iff)
end
--- a/src/HOL/ex/Gauge_Integration.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/ex/Gauge_Integration.thy Wed Mar 03 16:43:55 2010 +0100
@@ -28,7 +28,7 @@
definition
gauge :: "[real set, real => real] => bool" where
- [code del]:"gauge E g = (\<forall>x\<in>E. 0 < g(x))"
+ [code del]: "gauge E g = (\<forall>x\<in>E. 0 < g(x))"
subsection {* Gauge-fine divisions *}
@@ -63,14 +63,20 @@
apply (drule fine_imp_le, simp)
done
-lemma empty_fine_imp_eq: "\<lbrakk>fine \<delta> (a, b) D; D = []\<rbrakk> \<Longrightarrow> a = b"
-by (induct set: fine, simp_all)
+lemma fine_Nil_iff: "fine \<delta> (a, b) [] \<longleftrightarrow> a = b"
+by (auto elim: fine.cases intro: fine.intros)
-lemma fine_eq: "fine \<delta> (a, b) D \<Longrightarrow> a = b \<longleftrightarrow> D = []"
-apply (cases "D = []")
-apply (drule (1) empty_fine_imp_eq, simp)
-apply (drule (1) nonempty_fine_imp_less, simp)
-done
+lemma fine_same_iff: "fine \<delta> (a, a) D \<longleftrightarrow> D = []"
+proof
+ assume "fine \<delta> (a, a) D" thus "D = []"
+ by (metis nonempty_fine_imp_less less_irrefl)
+next
+ assume "D = []" thus "fine \<delta> (a, a) D"
+ by (simp add: fine_Nil)
+qed
+
+lemma empty_fine_imp_eq: "\<lbrakk>fine \<delta> (a, b) D; D = []\<rbrakk> \<Longrightarrow> a = b"
+by (simp add: fine_Nil_iff)
lemma mem_fine:
"\<lbrakk>fine \<delta> (a, b) D; (u, x, v) \<in> set D\<rbrakk> \<Longrightarrow> u < v \<and> u \<le> x \<and> x \<le> v"
@@ -174,7 +180,7 @@
lemma fine_\<delta>_expand:
assumes "fine \<delta> (a,b) D"
- and "\<And> x. \<lbrakk> a \<le> x ; x \<le> b \<rbrakk> \<Longrightarrow> \<delta> x \<le> \<delta>' x"
+ and "\<And>x. a \<le> x \<Longrightarrow> x \<le> b \<Longrightarrow> \<delta> x \<le> \<delta>' x"
shows "fine \<delta>' (a,b) D"
using assms proof induct
case 1 show ?case by (rule fine_Nil)
@@ -258,6 +264,22 @@
(\<forall>D. fine \<delta> (a,b) D -->
\<bar>rsum D f - k\<bar> < e)))"
+lemma Integral_eq:
+ "Integral (a, b) f k \<longleftrightarrow>
+ (\<forall>e>0. \<exists>\<delta>. gauge {a..b} \<delta> \<and> (\<forall>D. fine \<delta> (a,b) D \<longrightarrow> \<bar>rsum D f - k\<bar> < e))"
+unfolding Integral_def by simp
+
+lemma IntegralI:
+ assumes "\<And>e. 0 < e \<Longrightarrow>
+ \<exists>\<delta>. gauge {a..b} \<delta> \<and> (\<forall>D. fine \<delta> (a, b) D \<longrightarrow> \<bar>rsum D f - k\<bar> < e)"
+ shows "Integral (a, b) f k"
+using assms unfolding Integral_def by auto
+
+lemma IntegralE:
+ assumes "Integral (a, b) f k" and "0 < e"
+ obtains \<delta> where "gauge {a..b} \<delta>" and "\<forall>D. fine \<delta> (a, b) D \<longrightarrow> \<bar>rsum D f - k\<bar> < e"
+using assms unfolding Integral_def by auto
+
lemma Integral_def2:
"Integral = (%(a,b) f k. \<forall>e>0. (\<exists>\<delta>. gauge {a..b} \<delta> &
(\<forall>D. fine \<delta> (a,b) D -->
@@ -272,60 +294,69 @@
text{*The integral is unique if it exists*}
lemma Integral_unique:
- "[| a \<le> b; Integral(a,b) f k1; Integral(a,b) f k2 |] ==> k1 = k2"
-apply (simp add: Integral_def)
-apply (drule_tac x = "\<bar>k1 - k2\<bar> /2" in spec)+
-apply auto
-apply (drule gauge_min, assumption)
-apply (drule_tac \<delta> = "%x. min (\<delta> x) (\<delta>' x)"
- in fine_exists, assumption, auto)
-apply (drule fine_min)
-apply (drule spec)+
-apply auto
-apply (subgoal_tac "\<bar>(rsum D f - k2) - (rsum D f - k1)\<bar> < \<bar>k1 - k2\<bar>")
-apply arith
-apply (drule add_strict_mono, assumption)
-apply (auto simp only: left_distrib [symmetric] mult_2_right [symmetric]
- mult_less_cancel_right)
+ assumes le: "a \<le> b"
+ assumes 1: "Integral (a, b) f k1"
+ assumes 2: "Integral (a, b) f k2"
+ shows "k1 = k2"
+proof (rule ccontr)
+ assume "k1 \<noteq> k2"
+ hence e: "0 < \<bar>k1 - k2\<bar> / 2" by simp
+ obtain d1 where "gauge {a..b} d1" and
+ d1: "\<forall>D. fine d1 (a, b) D \<longrightarrow> \<bar>rsum D f - k1\<bar> < \<bar>k1 - k2\<bar> / 2"
+ using 1 e by (rule IntegralE)
+ obtain d2 where "gauge {a..b} d2" and
+ d2: "\<forall>D. fine d2 (a, b) D \<longrightarrow> \<bar>rsum D f - k2\<bar> < \<bar>k1 - k2\<bar> / 2"
+ using 2 e by (rule IntegralE)
+ have "gauge {a..b} (\<lambda>x. min (d1 x) (d2 x))"
+ using `gauge {a..b} d1` and `gauge {a..b} d2`
+ by (rule gauge_min)
+ then obtain D where "fine (\<lambda>x. min (d1 x) (d2 x)) (a, b) D"
+ using fine_exists [OF le] by fast
+ hence "fine d1 (a, b) D" and "fine d2 (a, b) D"
+ by (auto dest: fine_min)
+ hence "\<bar>rsum D f - k1\<bar> < \<bar>k1 - k2\<bar> / 2" and "\<bar>rsum D f - k2\<bar> < \<bar>k1 - k2\<bar> / 2"
+ using d1 d2 by simp_all
+ hence "\<bar>rsum D f - k1\<bar> + \<bar>rsum D f - k2\<bar> < \<bar>k1 - k2\<bar> / 2 + \<bar>k1 - k2\<bar> / 2"
+ by (rule add_strict_mono)
+ thus False by auto
+qed
+
+lemma Integral_zero: "Integral(a,a) f 0"
+apply (rule IntegralI)
+apply (rule_tac x = "\<lambda>x. 1" in exI)
+apply (simp add: fine_same_iff gauge_def)
done
-lemma Integral_zero [simp]: "Integral(a,a) f 0"
-apply (auto simp add: Integral_def)
-apply (rule_tac x = "%x. 1" in exI)
-apply (auto dest: fine_eq simp add: gauge_def rsum_def)
+lemma Integral_same_iff [simp]: "Integral (a, a) f k \<longleftrightarrow> k = 0"
+ by (auto intro: Integral_zero Integral_unique)
+
+lemma Integral_zero_fun: "Integral (a,b) (\<lambda>x. 0) 0"
+apply (rule IntegralI)
+apply (rule_tac x="\<lambda>x. 1" in exI, simp add: gauge_def)
done
lemma fine_rsum_const: "fine \<delta> (a,b) D \<Longrightarrow> rsum D (\<lambda>x. c) = (c * (b - a))"
unfolding rsum_def
by (induct set: fine, auto simp add: algebra_simps)
-lemma Integral_eq_diff_bounds: "a \<le> b ==> Integral(a,b) (%x. 1) (b - a)"
+lemma Integral_mult_const: "a \<le> b \<Longrightarrow> Integral(a,b) (\<lambda>x. c) (c * (b - a))"
apply (cases "a = b", simp)
-apply (simp add: Integral_def, clarify)
-apply (rule_tac x = "%x. b - a" in exI)
+apply (rule IntegralI)
+apply (rule_tac x = "\<lambda>x. b - a" in exI)
apply (rule conjI, simp add: gauge_def)
apply (clarify)
apply (subst fine_rsum_const, assumption, simp)
done
-lemma Integral_mult_const: "a \<le> b ==> Integral(a,b) (%x. c) (c*(b - a))"
-apply (cases "a = b", simp)
-apply (simp add: Integral_def, clarify)
-apply (rule_tac x = "%x. b - a" in exI)
-apply (rule conjI, simp add: gauge_def)
-apply (clarify)
-apply (subst fine_rsum_const, assumption, simp)
-done
+lemma Integral_eq_diff_bounds: "a \<le> b \<Longrightarrow> Integral(a,b) (\<lambda>x. 1) (b - a)"
+ using Integral_mult_const [of a b 1] by simp
lemma Integral_mult:
"[| a \<le> b; Integral(a,b) f k |] ==> Integral(a,b) (%x. c * f x) (c * k)"
-apply (auto simp add: order_le_less
- dest: Integral_unique [OF order_refl Integral_zero])
-apply (auto simp add: Integral_def setsum_right_distrib[symmetric] mult_assoc)
-apply (case_tac "c = 0", force)
-apply (drule_tac x = "e/abs c" in spec)
-apply (simp add: divide_pos_pos)
-apply clarify
+apply (auto simp add: order_le_less)
+apply (cases "c = 0", simp add: Integral_zero_fun)
+apply (rule IntegralI)
+apply (erule_tac e="e / \<bar>c\<bar>" in IntegralE, simp add: divide_pos_pos)
apply (rule_tac x="\<delta>" in exI, clarify)
apply (drule_tac x="D" in spec, clarify)
apply (simp add: pos_less_divide_eq abs_mult [symmetric]
@@ -337,22 +368,20 @@
assumes "Integral (b, c) f x2"
assumes "a \<le> b" and "b \<le> c"
shows "Integral (a, c) f (x1 + x2)"
-proof (cases "a < b \<and> b < c", simp only: Integral_def split_conv, rule allI, rule impI)
+proof (cases "a < b \<and> b < c", rule IntegralI)
fix \<epsilon> :: real assume "0 < \<epsilon>"
hence "0 < \<epsilon> / 2" by auto
assume "a < b \<and> b < c"
hence "a < b" and "b < c" by auto
- from `Integral (a, b) f x1`[simplified Integral_def split_conv,
- rule_format, OF `0 < \<epsilon>/2`]
obtain \<delta>1 where \<delta>1_gauge: "gauge {a..b} \<delta>1"
- and I1: "\<And> D. fine \<delta>1 (a,b) D \<Longrightarrow> \<bar> rsum D f - x1 \<bar> < (\<epsilon> / 2)" by auto
+ and I1: "\<And> D. fine \<delta>1 (a,b) D \<Longrightarrow> \<bar> rsum D f - x1 \<bar> < (\<epsilon> / 2)"
+ using IntegralE [OF `Integral (a, b) f x1` `0 < \<epsilon>/2`] by auto
- from `Integral (b, c) f x2`[simplified Integral_def split_conv,
- rule_format, OF `0 < \<epsilon>/2`]
obtain \<delta>2 where \<delta>2_gauge: "gauge {b..c} \<delta>2"
- and I2: "\<And> D. fine \<delta>2 (b,c) D \<Longrightarrow> \<bar> rsum D f - x2 \<bar> < (\<epsilon> / 2)" by auto
+ and I2: "\<And> D. fine \<delta>2 (b,c) D \<Longrightarrow> \<bar> rsum D f - x2 \<bar> < (\<epsilon> / 2)"
+ using IntegralE [OF `Integral (b, c) f x2` `0 < \<epsilon>/2`] by auto
def \<delta> \<equiv> "\<lambda> x. if x < b then min (\<delta>1 x) (b - x)
else if x = b then min (\<delta>1 b) (\<delta>2 b)
@@ -360,6 +389,7 @@
have "gauge {a..c} \<delta>"
using \<delta>1_gauge \<delta>2_gauge unfolding \<delta>_def gauge_def by auto
+
moreover {
fix D :: "(real \<times> real \<times> real) list"
assume fine: "fine \<delta> (a,c) D"
@@ -462,12 +492,12 @@
thus ?thesis
proof (rule disjE)
assume "a = b" hence "x1 = 0"
- using `Integral (a, b) f x1` Integral_zero Integral_unique[of a b] by auto
- thus ?thesis using `a = b` `Integral (b, c) f x2` by auto
+ using `Integral (a, b) f x1` by simp
+ thus ?thesis using `a = b` `Integral (b, c) f x2` by simp
next
assume "b = c" hence "x2 = 0"
- using `Integral (b, c) f x2` Integral_zero Integral_unique[of b c] by auto
- thus ?thesis using `b = c` `Integral (a, b) f x1` by auto
+ using `Integral (b, c) f x2` by simp
+ thus ?thesis using `b = c` `Integral (a, b) f x1` by simp
qed
qed
@@ -486,7 +516,7 @@
apply (rule_tac z1 = "\<bar>inverse (z - x)\<bar>"
in real_mult_le_cancel_iff2 [THEN iffD1])
apply simp
-apply (simp del: abs_inverse abs_mult add: abs_mult [symmetric]
+apply (simp del: abs_inverse add: abs_mult [symmetric]
mult_assoc [symmetric])
apply (subgoal_tac "inverse (z - x) * (f z - f x - f' x * (z - x))
= (f z - f x) / (z - x) - f' x")
@@ -543,31 +573,51 @@
qed
lemma fundamental_theorem_of_calculus:
- "\<lbrakk> a \<le> b; \<forall>x. a \<le> x & x \<le> b --> DERIV f x :> f'(x) \<rbrakk>
- \<Longrightarrow> Integral(a,b) f' (f(b) - f(a))"
- apply (drule order_le_imp_less_or_eq, auto)
- apply (auto simp add: Integral_def2)
- apply (drule_tac e = "e / (b - a)" in lemma_straddle)
- apply (simp add: divide_pos_pos)
- apply clarify
- apply (rule_tac x="g" in exI, clarify)
- apply (clarsimp simp add: rsum_def)
- apply (frule fine_listsum_eq_diff [where f=f])
- apply (erule subst)
- apply (subst listsum_subtractf [symmetric])
- apply (rule listsum_abs [THEN order_trans])
- apply (subst map_map [unfolded o_def])
- apply (subgoal_tac "e = (\<Sum>(u, x, v)\<leftarrow>D. (e / (b - a)) * (v - u))")
- apply (erule ssubst)
- apply (simp add: abs_minus_commute)
- apply (rule listsum_mono)
- apply (clarify, rename_tac u x v)
- apply ((drule spec)+, erule mp)
- apply (simp add: mem_fine mem_fine2 mem_fine3)
- apply (frule fine_listsum_eq_diff [where f="\<lambda>x. x"])
- apply (simp only: split_def)
- apply (subst listsum_const_mult)
- apply simp
-done
+ assumes "a \<le> b"
+ assumes f': "\<forall>x. a \<le> x \<and> x \<le> b \<longrightarrow> DERIV f x :> f'(x)"
+ shows "Integral (a, b) f' (f(b) - f(a))"
+proof (cases "a = b")
+ assume "a = b" thus ?thesis by simp
+next
+ assume "a \<noteq> b" with `a \<le> b` have "a < b" by simp
+ show ?thesis
+ proof (simp add: Integral_def2, clarify)
+ fix e :: real assume "0 < e"
+ with `a < b` have "0 < e / (b - a)" by (simp add: divide_pos_pos)
+
+ from lemma_straddle [OF f' this]
+ obtain \<delta> where "gauge {a..b} \<delta>"
+ and \<delta>: "\<And>x u v. \<lbrakk>a \<le> u; u \<le> x; x \<le> v; v \<le> b; v - u < \<delta> x\<rbrakk> \<Longrightarrow>
+ \<bar>f v - f u - f' x * (v - u)\<bar> \<le> e * (v - u) / (b - a)" by auto
+
+ have "\<forall>D. fine \<delta> (a, b) D \<longrightarrow> \<bar>rsum D f' - (f b - f a)\<bar> \<le> e"
+ proof (clarify)
+ fix D assume D: "fine \<delta> (a, b) D"
+ hence "(\<Sum>(u, x, v)\<leftarrow>D. f v - f u) = f b - f a"
+ by (rule fine_listsum_eq_diff)
+ hence "\<bar>rsum D f' - (f b - f a)\<bar> = \<bar>rsum D f' - (\<Sum>(u, x, v)\<leftarrow>D. f v - f u)\<bar>"
+ by simp
+ also have "\<dots> = \<bar>(\<Sum>(u, x, v)\<leftarrow>D. f v - f u) - rsum D f'\<bar>"
+ by (rule abs_minus_commute)
+ also have "\<dots> = \<bar>\<Sum>(u, x, v)\<leftarrow>D. (f v - f u) - f' x * (v - u)\<bar>"
+ by (simp only: rsum_def listsum_subtractf split_def)
+ also have "\<dots> \<le> (\<Sum>(u, x, v)\<leftarrow>D. \<bar>(f v - f u) - f' x * (v - u)\<bar>)"
+ by (rule ord_le_eq_trans [OF listsum_abs], simp add: o_def split_def)
+ also have "\<dots> \<le> (\<Sum>(u, x, v)\<leftarrow>D. (e / (b - a)) * (v - u))"
+ apply (rule listsum_mono, clarify, rename_tac u x v)
+ using D apply (simp add: \<delta> mem_fine mem_fine2 mem_fine3)
+ done
+ also have "\<dots> = e"
+ using fine_listsum_eq_diff [OF D, where f="\<lambda>x. x"]
+ unfolding split_def listsum_const_mult
+ using `a < b` by simp
+ finally show "\<bar>rsum D f' - (f b - f a)\<bar> \<le> e" .
+ qed
+
+ with `gauge {a..b} \<delta>`
+ show "\<exists>\<delta>. gauge {a..b} \<delta> \<and> (\<forall>D. fine \<delta> (a, b) D \<longrightarrow> \<bar>rsum D f' - (f b - f a)\<bar> \<le> e)"
+ by auto
+ qed
+qed
end
--- a/src/HOL/ex/Predicate_Compile_Quickcheck.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOL/ex/Predicate_Compile_Quickcheck.thy Wed Mar 03 16:43:55 2010 +0100
@@ -7,9 +7,9 @@
uses "../Tools/Predicate_Compile/predicate_compile_quickcheck.ML"
begin
-setup {* Quickcheck.add_generator ("predicate_compile_wo_ff", Predicate_Compile_Quickcheck.quickcheck_compile_term false true) *}
-setup {* Quickcheck.add_generator ("predicate_compile_ff_fs", Predicate_Compile_Quickcheck.quickcheck_compile_term true true) *}
-setup {* Quickcheck.add_generator ("predicate_compile_ff_nofs", Predicate_Compile_Quickcheck.quickcheck_compile_term true false) *}
+setup {* Quickcheck.add_generator ("predicate_compile_wo_ff", Predicate_Compile_Quickcheck.quickcheck_compile_term false true 8) *}
+setup {* Quickcheck.add_generator ("predicate_compile_ff_fs", Predicate_Compile_Quickcheck.quickcheck_compile_term true true 8) *}
+setup {* Quickcheck.add_generator ("predicate_compile_ff_nofs", Predicate_Compile_Quickcheck.quickcheck_compile_term true false 8) *}
(*
datatype alphabet = a | b
--- a/src/HOLCF/Bifinite.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOLCF/Bifinite.thy Wed Mar 03 16:43:55 2010 +0100
@@ -295,7 +295,7 @@
by (rule finite_range_imp_finite_fixes)
qed
-instantiation "->" :: (profinite, profinite) profinite
+instantiation cfun :: (profinite, profinite) profinite
begin
definition
@@ -325,7 +325,7 @@
end
-instance "->" :: (profinite, bifinite) bifinite ..
+instance cfun :: (profinite, bifinite) bifinite ..
lemma approx_cfun: "approx n\<cdot>f\<cdot>x = approx n\<cdot>(f\<cdot>(approx n\<cdot>x))"
by (simp add: approx_cfun_def)
--- a/src/HOLCF/Cfun.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOLCF/Cfun.thy Wed Mar 03 16:43:55 2010 +0100
@@ -20,11 +20,11 @@
lemma adm_cont: "adm cont"
by (rule admI, rule cont_lub_fun)
-cpodef (CFun) ('a, 'b) "->" (infixr "->" 0) = "{f::'a => 'b. cont f}"
+cpodef (CFun) ('a, 'b) cfun (infixr "->" 0) = "{f::'a => 'b. cont f}"
by (simp_all add: Ex_cont adm_cont)
type_notation (xsymbols)
- "->" ("(_ \<rightarrow>/ _)" [1, 0] 0)
+ cfun ("(_ \<rightarrow>/ _)" [1, 0] 0)
notation
Rep_CFun ("(_$/_)" [999,1000] 999)
@@ -103,16 +103,16 @@
lemma UU_CFun: "\<bottom> \<in> CFun"
by (simp add: CFun_def inst_fun_pcpo cont_const)
-instance "->" :: (finite_po, finite_po) finite_po
+instance cfun :: (finite_po, finite_po) finite_po
by (rule typedef_finite_po [OF type_definition_CFun])
-instance "->" :: (finite_po, chfin) chfin
+instance cfun :: (finite_po, chfin) chfin
by (rule typedef_chfin [OF type_definition_CFun below_CFun_def])
-instance "->" :: (cpo, discrete_cpo) discrete_cpo
+instance cfun :: (cpo, discrete_cpo) discrete_cpo
by intro_classes (simp add: below_CFun_def Rep_CFun_inject)
-instance "->" :: (cpo, pcpo) pcpo
+instance cfun :: (cpo, pcpo) pcpo
by (rule typedef_pcpo [OF type_definition_CFun below_CFun_def UU_CFun])
lemmas Rep_CFun_strict =
--- a/src/HOLCF/Domain.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOLCF/Domain.thy Wed Mar 03 16:43:55 2010 +0100
@@ -9,8 +9,8 @@
uses
("Tools/cont_consts.ML")
("Tools/cont_proc.ML")
+ ("Tools/Domain/domain_constructors.ML")
("Tools/Domain/domain_library.ML")
- ("Tools/Domain/domain_syntax.ML")
("Tools/Domain/domain_axioms.ML")
("Tools/Domain/domain_theorems.ML")
("Tools/Domain/domain_extender.ML")
@@ -86,7 +86,10 @@
lemma rep_defined_iff: "(rep\<cdot>x = \<bottom>) = (x = \<bottom>)"
by (rule iso.abs_defined_iff [OF iso.swap]) (rule iso_axioms)
-lemma (in iso) compact_abs_rev: "compact (abs\<cdot>x) \<Longrightarrow> compact x"
+lemma casedist_rule: "rep\<cdot>x = \<bottom> \<or> P \<Longrightarrow> x = \<bottom> \<or> P"
+ by (simp add: rep_defined_iff)
+
+lemma compact_abs_rev: "compact (abs\<cdot>x) \<Longrightarrow> compact x"
proof (unfold compact_def)
assume "adm (\<lambda>y. \<not> abs\<cdot>x \<sqsubseteq> y)"
with cont_Rep_CFun2
@@ -228,11 +231,50 @@
lemmas con_eq_iff_rules =
sinl_eq sinr_eq sinl_eq_sinr sinr_eq_sinl con_defined_iff_rules
+lemmas sel_strict_rules =
+ cfcomp2 sscase1 sfst_strict ssnd_strict fup1
+
+lemma sel_app_extra_rules:
+ "sscase\<cdot>ID\<cdot>\<bottom>\<cdot>(sinr\<cdot>x) = \<bottom>"
+ "sscase\<cdot>ID\<cdot>\<bottom>\<cdot>(sinl\<cdot>x) = x"
+ "sscase\<cdot>\<bottom>\<cdot>ID\<cdot>(sinl\<cdot>x) = \<bottom>"
+ "sscase\<cdot>\<bottom>\<cdot>ID\<cdot>(sinr\<cdot>x) = x"
+ "fup\<cdot>ID\<cdot>(up\<cdot>x) = x"
+by (cases "x = \<bottom>", simp, simp)+
+
+lemmas sel_app_rules =
+ sel_strict_rules sel_app_extra_rules
+ ssnd_spair sfst_spair up_defined spair_defined
+
+lemmas sel_defined_iff_rules =
+ cfcomp2 sfst_defined_iff ssnd_defined_iff
+
+lemmas take_con_rules =
+ ID1 ssum_map_sinl' ssum_map_sinr' ssum_map_strict
+ sprod_map_spair' sprod_map_strict u_map_up u_map_strict
+
+lemma lub_ID_take_lemma:
+ assumes "chain t" and "(\<Squnion>n. t n) = ID"
+ assumes "\<And>n. t n\<cdot>x = t n\<cdot>y" shows "x = y"
+proof -
+ have "(\<Squnion>n. t n\<cdot>x) = (\<Squnion>n. t n\<cdot>y)"
+ using assms(3) by simp
+ then have "(\<Squnion>n. t n)\<cdot>x = (\<Squnion>n. t n)\<cdot>y"
+ using assms(1) by (simp add: lub_distribs)
+ then show "x = y"
+ using assms(2) by simp
+qed
+
+lemma lub_ID_reach:
+ assumes "chain t" and "(\<Squnion>n. t n) = ID"
+ shows "(\<Squnion>n. t n\<cdot>x) = x"
+using assms by (simp add: lub_distribs)
+
use "Tools/cont_consts.ML"
use "Tools/cont_proc.ML"
use "Tools/Domain/domain_library.ML"
-use "Tools/Domain/domain_syntax.ML"
use "Tools/Domain/domain_axioms.ML"
+use "Tools/Domain/domain_constructors.ML"
use "Tools/Domain/domain_theorems.ML"
use "Tools/Domain/domain_extender.ML"
--- a/src/HOLCF/FOCUS/Fstream.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOLCF/FOCUS/Fstream.thy Wed Mar 03 16:43:55 2010 +0100
@@ -83,7 +83,7 @@
by (simp add: fscons_def2)
lemma fstream_prefix: "a~> s << t ==> ? tt. t = a~> tt & s << tt"
-apply (rule_tac x="t" in stream.casedist)
+apply (cases t)
apply (cut_tac fscons_not_empty)
apply (fast dest: eq_UU_iff [THEN iffD2])
apply (simp add: fscons_def2)
--- a/src/HOLCF/Fixrec.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOLCF/Fixrec.thy Wed Mar 03 16:43:55 2010 +0100
@@ -6,7 +6,9 @@
theory Fixrec
imports Sprod Ssum Up One Tr Fix
-uses ("Tools/fixrec.ML")
+uses
+ ("Tools/holcf_library.ML")
+ ("Tools/fixrec.ML")
begin
subsection {* Maybe monad type *}
@@ -265,7 +267,7 @@
*}
translations
- "x" <= "_match Fixrec.return (_variable x)"
+ "x" <= "_match (CONST Fixrec.return) (_variable x)"
subsection {* Pattern combinators for data constructors *}
@@ -603,6 +605,7 @@
subsection {* Initializing the fixrec package *}
+use "Tools/holcf_library.ML"
use "Tools/fixrec.ML"
setup {* Fixrec.setup *}
--- a/src/HOLCF/HOLCF.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOLCF/HOLCF.thy Wed Mar 03 16:43:55 2010 +0100
@@ -6,8 +6,10 @@
theory HOLCF
imports
- Domain ConvexPD Algebraic Universal Sum_Cpo Main
- Representable
+ Main
+ Domain
+ Powerdomains
+ Sum_Cpo
uses
"holcf_logic.ML"
"Tools/adm_tac.ML"
--- a/src/HOLCF/IOA/meta_theory/Seq.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOLCF/IOA/meta_theory/Seq.thy Wed Mar 03 16:43:55 2010 +0100
@@ -191,7 +191,7 @@
by simp
lemma nil_less_is_nil: "nil<<x ==> nil=x"
-apply (rule_tac x="x" in seq.casedist)
+apply (cases x)
apply simp
apply simp
apply simp
@@ -286,8 +286,8 @@
lemma Finite_upward: "\<lbrakk>Finite x; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> Finite y"
apply (induct arbitrary: y set: Finite)
-apply (rule_tac x=y in seq.casedist, simp, simp, simp)
-apply (rule_tac x=y in seq.casedist, simp, simp)
+apply (case_tac y, simp, simp, simp)
+apply (case_tac y, simp, simp)
apply simp
done
--- a/src/HOLCF/IOA/meta_theory/Sequence.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOLCF/IOA/meta_theory/Sequence.thy Wed Mar 03 16:43:55 2010 +0100
@@ -163,8 +163,7 @@
lemma Last_cons: "Last$(x>>xs)= (if xs=nil then Def x else Last$xs)"
apply (simp add: Last_def Consq_def)
-apply (rule_tac x="xs" in seq.casedist)
-apply simp
+apply (cases xs)
apply simp_all
done
@@ -208,7 +207,7 @@
lemma Zip_UU2: "x~=nil ==> Zip$x$UU =UU"
apply (subst Zip_unfold)
apply simp
-apply (rule_tac x="x" in seq.casedist)
+apply (cases x)
apply simp_all
done
@@ -902,15 +901,10 @@
shows "s1<<s2"
apply (rule_tac t="s1" in seq.reach [THEN subst])
apply (rule_tac t="s2" in seq.reach [THEN subst])
-apply (rule fix_def2 [THEN ssubst])
-apply (subst contlub_cfun_fun)
-apply (rule chain_iterate)
-apply (subst contlub_cfun_fun)
-apply (rule chain_iterate)
apply (rule lub_mono)
-apply (rule chain_iterate [THEN ch2ch_Rep_CFunL])
-apply (rule chain_iterate [THEN ch2ch_Rep_CFunL])
-apply (rule prems [unfolded seq.take_def])
+apply (rule seq.chain_take [THEN ch2ch_Rep_CFunL])
+apply (rule seq.chain_take [THEN ch2ch_Rep_CFunL])
+apply (rule assms)
done
--- a/src/HOLCF/IsaMakefile Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOLCF/IsaMakefile Wed Mar 03 16:43:55 2010 +0100
@@ -51,6 +51,7 @@
Pcpodef.thy \
Pcpo.thy \
Porder.thy \
+ Powerdomains.thy \
Product_Cpo.thy \
Representable.thy \
Sprod.thy \
@@ -63,11 +64,13 @@
Tools/adm_tac.ML \
Tools/cont_consts.ML \
Tools/cont_proc.ML \
+ Tools/holcf_library.ML \
Tools/Domain/domain_extender.ML \
Tools/Domain/domain_axioms.ML \
+ Tools/Domain/domain_constructors.ML \
Tools/Domain/domain_isomorphism.ML \
Tools/Domain/domain_library.ML \
- Tools/Domain/domain_syntax.ML \
+ Tools/Domain/domain_take_proofs.ML \
Tools/Domain/domain_theorems.ML \
Tools/fixrec.ML \
Tools/pcpodef.ML \
--- a/src/HOLCF/Pcpo.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOLCF/Pcpo.thy Wed Mar 03 16:43:55 2010 +0100
@@ -91,6 +91,10 @@
\<Longrightarrow> (\<Squnion>i. X i) = (\<Squnion>i. Y i)"
by (simp only: expand_fun_eq [symmetric])
+lemma lub_eq:
+ "(\<And>i. X i = Y i) \<Longrightarrow> (\<Squnion>i. X i) = (\<Squnion>i. Y i)"
+ by simp
+
text {* more results about mono and = of lubs of chains *}
lemma lub_mono2:
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOLCF/Powerdomains.thy Wed Mar 03 16:43:55 2010 +0100
@@ -0,0 +1,313 @@
+(* Title: HOLCF/Powerdomains.thy
+ Author: Brian Huffman
+*)
+
+header {* Powerdomains *}
+
+theory Powerdomains
+imports Representable ConvexPD
+begin
+
+subsection {* Powerdomains are representable *}
+
+text "Upper powerdomain of a representable type is representable."
+
+instantiation upper_pd :: (rep) rep
+begin
+
+definition emb_upper_pd_def: "emb = udom_emb oo upper_map\<cdot>emb"
+definition prj_upper_pd_def: "prj = upper_map\<cdot>prj oo udom_prj"
+
+instance
+ apply (intro_classes, unfold emb_upper_pd_def prj_upper_pd_def)
+ apply (intro ep_pair_comp ep_pair_upper_map ep_pair_emb_prj ep_pair_udom)
+done
+
+end
+
+text "Lower powerdomain of a representable type is representable."
+
+instantiation lower_pd :: (rep) rep
+begin
+
+definition emb_lower_pd_def: "emb = udom_emb oo lower_map\<cdot>emb"
+definition prj_lower_pd_def: "prj = lower_map\<cdot>prj oo udom_prj"
+
+instance
+ apply (intro_classes, unfold emb_lower_pd_def prj_lower_pd_def)
+ apply (intro ep_pair_comp ep_pair_lower_map ep_pair_emb_prj ep_pair_udom)
+done
+
+end
+
+text "Convex powerdomain of a representable type is representable."
+
+instantiation convex_pd :: (rep) rep
+begin
+
+definition emb_convex_pd_def: "emb = udom_emb oo convex_map\<cdot>emb"
+definition prj_convex_pd_def: "prj = convex_map\<cdot>prj oo udom_prj"
+
+instance
+ apply (intro_classes, unfold emb_convex_pd_def prj_convex_pd_def)
+ apply (intro ep_pair_comp ep_pair_convex_map ep_pair_emb_prj ep_pair_udom)
+done
+
+end
+
+subsection {* Finite deflation lemmas *}
+
+text "TODO: move these lemmas somewhere else"
+
+lemma finite_compact_range_imp_finite_range:
+ fixes d :: "'a::profinite \<rightarrow> 'b::cpo"
+ assumes "finite ((\<lambda>x. d\<cdot>x) ` {x. compact x})"
+ shows "finite (range (\<lambda>x. d\<cdot>x))"
+proof (rule finite_subset [OF _ prems])
+ {
+ fix x :: 'a
+ have "range (\<lambda>i. d\<cdot>(approx i\<cdot>x)) \<subseteq> (\<lambda>x. d\<cdot>x) ` {x. compact x}"
+ by auto
+ hence "finite (range (\<lambda>i. d\<cdot>(approx i\<cdot>x)))"
+ using prems by (rule finite_subset)
+ hence "finite_chain (\<lambda>i. d\<cdot>(approx i\<cdot>x))"
+ by (simp add: finite_range_imp_finch)
+ hence "\<exists>i. (\<Squnion>i. d\<cdot>(approx i\<cdot>x)) = d\<cdot>(approx i\<cdot>x)"
+ by (simp add: finite_chain_def maxinch_is_thelub)
+ hence "\<exists>i. d\<cdot>x = d\<cdot>(approx i\<cdot>x)"
+ by (simp add: lub_distribs)
+ hence "d\<cdot>x \<in> (\<lambda>x. d\<cdot>x) ` {x. compact x}"
+ by auto
+ }
+ thus "range (\<lambda>x. d\<cdot>x) \<subseteq> (\<lambda>x. d\<cdot>x) ` {x. compact x}"
+ by clarsimp
+qed
+
+lemma finite_deflation_upper_map:
+ assumes "finite_deflation d" shows "finite_deflation (upper_map\<cdot>d)"
+proof (intro finite_deflation.intro finite_deflation_axioms.intro)
+ interpret d: finite_deflation d by fact
+ have "deflation d" by fact
+ thus "deflation (upper_map\<cdot>d)" by (rule deflation_upper_map)
+ have "finite (range (\<lambda>x. d\<cdot>x))" by (rule d.finite_range)
+ hence "finite (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))"
+ by (rule finite_vimageI, simp add: inj_on_def Rep_compact_basis_inject)
+ hence "finite (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x)))" by simp
+ hence "finite (Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))"
+ by (rule finite_vimageI, simp add: inj_on_def Rep_pd_basis_inject)
+ hence "finite (upper_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp
+ hence "finite ((\<lambda>xs. upper_map\<cdot>d\<cdot>xs) ` range upper_principal)"
+ apply (rule finite_subset [COMP swap_prems_rl])
+ apply (clarsimp, rename_tac t)
+ apply (induct_tac t rule: pd_basis_induct)
+ apply (simp only: upper_unit_Rep_compact_basis [symmetric] upper_map_unit)
+ apply (subgoal_tac "\<exists>b. d\<cdot>(Rep_compact_basis a) = Rep_compact_basis b")
+ apply clarsimp
+ apply (rule imageI)
+ apply (rule vimageI2)
+ apply (simp add: Rep_PDUnit)
+ apply (rule image_eqI)
+ apply (erule sym)
+ apply simp
+ apply (rule exI)
+ apply (rule Abs_compact_basis_inverse [symmetric])
+ apply (simp add: d.compact)
+ apply (simp only: upper_plus_principal [symmetric] upper_map_plus)
+ apply clarsimp
+ apply (rule imageI)
+ apply (rule vimageI2)
+ apply (simp add: Rep_PDPlus)
+ done
+ moreover have "{xs::'a upper_pd. compact xs} = range upper_principal"
+ by (auto dest: upper_pd.compact_imp_principal)
+ ultimately have "finite ((\<lambda>xs. upper_map\<cdot>d\<cdot>xs) ` {xs::'a upper_pd. compact xs})"
+ by simp
+ hence "finite (range (\<lambda>xs. upper_map\<cdot>d\<cdot>xs))"
+ by (rule finite_compact_range_imp_finite_range)
+ thus "finite {xs. upper_map\<cdot>d\<cdot>xs = xs}"
+ by (rule finite_range_imp_finite_fixes)
+qed
+
+lemma finite_deflation_lower_map:
+ assumes "finite_deflation d" shows "finite_deflation (lower_map\<cdot>d)"
+proof (intro finite_deflation.intro finite_deflation_axioms.intro)
+ interpret d: finite_deflation d by fact
+ have "deflation d" by fact
+ thus "deflation (lower_map\<cdot>d)" by (rule deflation_lower_map)
+ have "finite (range (\<lambda>x. d\<cdot>x))" by (rule d.finite_range)
+ hence "finite (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))"
+ by (rule finite_vimageI, simp add: inj_on_def Rep_compact_basis_inject)
+ hence "finite (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x)))" by simp
+ hence "finite (Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))"
+ by (rule finite_vimageI, simp add: inj_on_def Rep_pd_basis_inject)
+ hence "finite (lower_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp
+ hence "finite ((\<lambda>xs. lower_map\<cdot>d\<cdot>xs) ` range lower_principal)"
+ apply (rule finite_subset [COMP swap_prems_rl])
+ apply (clarsimp, rename_tac t)
+ apply (induct_tac t rule: pd_basis_induct)
+ apply (simp only: lower_unit_Rep_compact_basis [symmetric] lower_map_unit)
+ apply (subgoal_tac "\<exists>b. d\<cdot>(Rep_compact_basis a) = Rep_compact_basis b")
+ apply clarsimp
+ apply (rule imageI)
+ apply (rule vimageI2)
+ apply (simp add: Rep_PDUnit)
+ apply (rule image_eqI)
+ apply (erule sym)
+ apply simp
+ apply (rule exI)
+ apply (rule Abs_compact_basis_inverse [symmetric])
+ apply (simp add: d.compact)
+ apply (simp only: lower_plus_principal [symmetric] lower_map_plus)
+ apply clarsimp
+ apply (rule imageI)
+ apply (rule vimageI2)
+ apply (simp add: Rep_PDPlus)
+ done
+ moreover have "{xs::'a lower_pd. compact xs} = range lower_principal"
+ by (auto dest: lower_pd.compact_imp_principal)
+ ultimately have "finite ((\<lambda>xs. lower_map\<cdot>d\<cdot>xs) ` {xs::'a lower_pd. compact xs})"
+ by simp
+ hence "finite (range (\<lambda>xs. lower_map\<cdot>d\<cdot>xs))"
+ by (rule finite_compact_range_imp_finite_range)
+ thus "finite {xs. lower_map\<cdot>d\<cdot>xs = xs}"
+ by (rule finite_range_imp_finite_fixes)
+qed
+
+lemma finite_deflation_convex_map:
+ assumes "finite_deflation d" shows "finite_deflation (convex_map\<cdot>d)"
+proof (intro finite_deflation.intro finite_deflation_axioms.intro)
+ interpret d: finite_deflation d by fact
+ have "deflation d" by fact
+ thus "deflation (convex_map\<cdot>d)" by (rule deflation_convex_map)
+ have "finite (range (\<lambda>x. d\<cdot>x))" by (rule d.finite_range)
+ hence "finite (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))"
+ by (rule finite_vimageI, simp add: inj_on_def Rep_compact_basis_inject)
+ hence "finite (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x)))" by simp
+ hence "finite (Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))"
+ by (rule finite_vimageI, simp add: inj_on_def Rep_pd_basis_inject)
+ hence "finite (convex_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp
+ hence "finite ((\<lambda>xs. convex_map\<cdot>d\<cdot>xs) ` range convex_principal)"
+ apply (rule finite_subset [COMP swap_prems_rl])
+ apply (clarsimp, rename_tac t)
+ apply (induct_tac t rule: pd_basis_induct)
+ apply (simp only: convex_unit_Rep_compact_basis [symmetric] convex_map_unit)
+ apply (subgoal_tac "\<exists>b. d\<cdot>(Rep_compact_basis a) = Rep_compact_basis b")
+ apply clarsimp
+ apply (rule imageI)
+ apply (rule vimageI2)
+ apply (simp add: Rep_PDUnit)
+ apply (rule image_eqI)
+ apply (erule sym)
+ apply simp
+ apply (rule exI)
+ apply (rule Abs_compact_basis_inverse [symmetric])
+ apply (simp add: d.compact)
+ apply (simp only: convex_plus_principal [symmetric] convex_map_plus)
+ apply clarsimp
+ apply (rule imageI)
+ apply (rule vimageI2)
+ apply (simp add: Rep_PDPlus)
+ done
+ moreover have "{xs::'a convex_pd. compact xs} = range convex_principal"
+ by (auto dest: convex_pd.compact_imp_principal)
+ ultimately have "finite ((\<lambda>xs. convex_map\<cdot>d\<cdot>xs) ` {xs::'a convex_pd. compact xs})"
+ by simp
+ hence "finite (range (\<lambda>xs. convex_map\<cdot>d\<cdot>xs))"
+ by (rule finite_compact_range_imp_finite_range)
+ thus "finite {xs. convex_map\<cdot>d\<cdot>xs = xs}"
+ by (rule finite_range_imp_finite_fixes)
+qed
+
+subsection {* Deflation combinators *}
+
+definition "upper_defl = TypeRep_fun1 upper_map"
+definition "lower_defl = TypeRep_fun1 lower_map"
+definition "convex_defl = TypeRep_fun1 convex_map"
+
+lemma cast_upper_defl:
+ "cast\<cdot>(upper_defl\<cdot>A) = udom_emb oo upper_map\<cdot>(cast\<cdot>A) oo udom_prj"
+unfolding upper_defl_def
+apply (rule cast_TypeRep_fun1)
+apply (erule finite_deflation_upper_map)
+done
+
+lemma cast_lower_defl:
+ "cast\<cdot>(lower_defl\<cdot>A) = udom_emb oo lower_map\<cdot>(cast\<cdot>A) oo udom_prj"
+unfolding lower_defl_def
+apply (rule cast_TypeRep_fun1)
+apply (erule finite_deflation_lower_map)
+done
+
+lemma cast_convex_defl:
+ "cast\<cdot>(convex_defl\<cdot>A) = udom_emb oo convex_map\<cdot>(cast\<cdot>A) oo udom_prj"
+unfolding convex_defl_def
+apply (rule cast_TypeRep_fun1)
+apply (erule finite_deflation_convex_map)
+done
+
+lemma REP_upper: "REP('a upper_pd) = upper_defl\<cdot>REP('a)"
+apply (rule cast_eq_imp_eq, rule ext_cfun)
+apply (simp add: cast_REP cast_upper_defl)
+apply (simp add: prj_upper_pd_def)
+apply (simp add: emb_upper_pd_def)
+apply (simp add: upper_map_map cfcomp1)
+done
+
+lemma REP_lower: "REP('a lower_pd) = lower_defl\<cdot>REP('a)"
+apply (rule cast_eq_imp_eq, rule ext_cfun)
+apply (simp add: cast_REP cast_lower_defl)
+apply (simp add: prj_lower_pd_def)
+apply (simp add: emb_lower_pd_def)
+apply (simp add: lower_map_map cfcomp1)
+done
+
+lemma REP_convex: "REP('a convex_pd) = convex_defl\<cdot>REP('a)"
+apply (rule cast_eq_imp_eq, rule ext_cfun)
+apply (simp add: cast_REP cast_convex_defl)
+apply (simp add: prj_convex_pd_def)
+apply (simp add: emb_convex_pd_def)
+apply (simp add: convex_map_map cfcomp1)
+done
+
+lemma isodefl_upper:
+ "isodefl d t \<Longrightarrow> isodefl (upper_map\<cdot>d) (upper_defl\<cdot>t)"
+apply (rule isodeflI)
+apply (simp add: cast_upper_defl cast_isodefl)
+apply (simp add: emb_upper_pd_def prj_upper_pd_def)
+apply (simp add: upper_map_map)
+done
+
+lemma isodefl_lower:
+ "isodefl d t \<Longrightarrow> isodefl (lower_map\<cdot>d) (lower_defl\<cdot>t)"
+apply (rule isodeflI)
+apply (simp add: cast_lower_defl cast_isodefl)
+apply (simp add: emb_lower_pd_def prj_lower_pd_def)
+apply (simp add: lower_map_map)
+done
+
+lemma isodefl_convex:
+ "isodefl d t \<Longrightarrow> isodefl (convex_map\<cdot>d) (convex_defl\<cdot>t)"
+apply (rule isodeflI)
+apply (simp add: cast_convex_defl cast_isodefl)
+apply (simp add: emb_convex_pd_def prj_convex_pd_def)
+apply (simp add: convex_map_map)
+done
+
+subsection {* Domain package setup for powerdomains *}
+
+setup {*
+ fold Domain_Isomorphism.add_type_constructor
+ [(@{type_name "upper_pd"}, @{term upper_defl}, @{const_name upper_map},
+ @{thm REP_upper}, @{thm isodefl_upper}, @{thm upper_map_ID},
+ @{thm deflation_upper_map}),
+
+ (@{type_name "lower_pd"}, @{term lower_defl}, @{const_name lower_map},
+ @{thm REP_lower}, @{thm isodefl_lower}, @{thm lower_map_ID},
+ @{thm deflation_lower_map}),
+
+ (@{type_name "convex_pd"}, @{term convex_defl}, @{const_name convex_map},
+ @{thm REP_convex}, @{thm isodefl_convex}, @{thm convex_map_ID},
+ @{thm deflation_convex_map})]
+*}
+
+end
--- a/src/HOLCF/Representable.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOLCF/Representable.thy Wed Mar 03 16:43:55 2010 +0100
@@ -5,9 +5,10 @@
header {* Representable Types *}
theory Representable
-imports Algebraic Universal Ssum Sprod One ConvexPD Fixrec
+imports Algebraic Universal Ssum Sprod One Fixrec
uses
("Tools/repdef.ML")
+ ("Tools/Domain/domain_take_proofs.ML")
("Tools/Domain/domain_isomorphism.ML")
begin
@@ -179,6 +180,33 @@
shows "abs\<cdot>(rep\<cdot>x) = x"
unfolding abs_def rep_def by (simp add: REP [symmetric])
+lemma deflation_abs_rep:
+ fixes abs and rep and d
+ assumes abs_iso: "\<And>x. rep\<cdot>(abs\<cdot>x) = x"
+ assumes rep_iso: "\<And>y. abs\<cdot>(rep\<cdot>y) = y"
+ shows "deflation d \<Longrightarrow> deflation (abs oo d oo rep)"
+by (rule ep_pair.deflation_e_d_p) (simp add: ep_pair.intro assms)
+
+lemma deflation_chain_min:
+ assumes chain: "chain d"
+ assumes defl: "\<And>i. deflation (d i)"
+ shows "d i\<cdot>(d j\<cdot>x) = d (min i j)\<cdot>x"
+proof (rule linorder_le_cases)
+ assume "i \<le> j"
+ with chain have "d i \<sqsubseteq> d j" by (rule chain_mono)
+ then have "d i\<cdot>(d j\<cdot>x) = d i\<cdot>x"
+ by (rule deflation_below_comp1 [OF defl defl])
+ moreover from `i \<le> j` have "min i j = i" by simp
+ ultimately show ?thesis by simp
+next
+ assume "j \<le> i"
+ with chain have "d j \<sqsubseteq> d i" by (rule chain_mono)
+ then have "d i\<cdot>(d j\<cdot>x) = d j\<cdot>x"
+ by (rule deflation_below_comp2 [OF defl defl])
+ moreover from `j \<le> i` have "min i j = j" by simp
+ ultimately show ?thesis by simp
+qed
+
subsection {* Proving a subtype is representable *}
@@ -387,7 +415,7 @@
text "Functions between representable types are representable."
-instantiation "->" :: (rep, rep) rep
+instantiation cfun :: (rep, rep) rep
begin
definition emb_cfun_def: "emb = udom_emb oo cfun_map\<cdot>prj\<cdot>emb"
@@ -402,7 +430,7 @@
text "Strict products of representable types are representable."
-instantiation "**" :: (rep, rep) rep
+instantiation sprod :: (rep, rep) rep
begin
definition emb_sprod_def: "emb = udom_emb oo sprod_map\<cdot>emb\<cdot>emb"
@@ -417,7 +445,7 @@
text "Strict sums of representable types are representable."
-instantiation "++" :: (rep, rep) rep
+instantiation ssum :: (rep, rep) rep
begin
definition emb_ssum_def: "emb = udom_emb oo ssum_map\<cdot>emb\<cdot>emb"
@@ -460,214 +488,6 @@
end
-text "Upper powerdomain of a representable type is representable."
-
-instantiation upper_pd :: (rep) rep
-begin
-
-definition emb_upper_pd_def: "emb = udom_emb oo upper_map\<cdot>emb"
-definition prj_upper_pd_def: "prj = upper_map\<cdot>prj oo udom_prj"
-
-instance
- apply (intro_classes, unfold emb_upper_pd_def prj_upper_pd_def)
- apply (intro ep_pair_comp ep_pair_upper_map ep_pair_emb_prj ep_pair_udom)
-done
-
-end
-
-text "Lower powerdomain of a representable type is representable."
-
-instantiation lower_pd :: (rep) rep
-begin
-
-definition emb_lower_pd_def: "emb = udom_emb oo lower_map\<cdot>emb"
-definition prj_lower_pd_def: "prj = lower_map\<cdot>prj oo udom_prj"
-
-instance
- apply (intro_classes, unfold emb_lower_pd_def prj_lower_pd_def)
- apply (intro ep_pair_comp ep_pair_lower_map ep_pair_emb_prj ep_pair_udom)
-done
-
-end
-
-text "Convex powerdomain of a representable type is representable."
-
-instantiation convex_pd :: (rep) rep
-begin
-
-definition emb_convex_pd_def: "emb = udom_emb oo convex_map\<cdot>emb"
-definition prj_convex_pd_def: "prj = convex_map\<cdot>prj oo udom_prj"
-
-instance
- apply (intro_classes, unfold emb_convex_pd_def prj_convex_pd_def)
- apply (intro ep_pair_comp ep_pair_convex_map ep_pair_emb_prj ep_pair_udom)
-done
-
-end
-
-subsection {* Finite deflation lemmas *}
-
-text "TODO: move these lemmas somewhere else"
-
-lemma finite_compact_range_imp_finite_range:
- fixes d :: "'a::profinite \<rightarrow> 'b::cpo"
- assumes "finite ((\<lambda>x. d\<cdot>x) ` {x. compact x})"
- shows "finite (range (\<lambda>x. d\<cdot>x))"
-proof (rule finite_subset [OF _ prems])
- {
- fix x :: 'a
- have "range (\<lambda>i. d\<cdot>(approx i\<cdot>x)) \<subseteq> (\<lambda>x. d\<cdot>x) ` {x. compact x}"
- by auto
- hence "finite (range (\<lambda>i. d\<cdot>(approx i\<cdot>x)))"
- using prems by (rule finite_subset)
- hence "finite_chain (\<lambda>i. d\<cdot>(approx i\<cdot>x))"
- by (simp add: finite_range_imp_finch)
- hence "\<exists>i. (\<Squnion>i. d\<cdot>(approx i\<cdot>x)) = d\<cdot>(approx i\<cdot>x)"
- by (simp add: finite_chain_def maxinch_is_thelub)
- hence "\<exists>i. d\<cdot>x = d\<cdot>(approx i\<cdot>x)"
- by (simp add: lub_distribs)
- hence "d\<cdot>x \<in> (\<lambda>x. d\<cdot>x) ` {x. compact x}"
- by auto
- }
- thus "range (\<lambda>x. d\<cdot>x) \<subseteq> (\<lambda>x. d\<cdot>x) ` {x. compact x}"
- by clarsimp
-qed
-
-lemma finite_deflation_upper_map:
- assumes "finite_deflation d" shows "finite_deflation (upper_map\<cdot>d)"
-proof (intro finite_deflation.intro finite_deflation_axioms.intro)
- interpret d: finite_deflation d by fact
- have "deflation d" by fact
- thus "deflation (upper_map\<cdot>d)" by (rule deflation_upper_map)
- have "finite (range (\<lambda>x. d\<cdot>x))" by (rule d.finite_range)
- hence "finite (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))"
- by (rule finite_vimageI, simp add: inj_on_def Rep_compact_basis_inject)
- hence "finite (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x)))" by simp
- hence "finite (Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))"
- by (rule finite_vimageI, simp add: inj_on_def Rep_pd_basis_inject)
- hence "finite (upper_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp
- hence "finite ((\<lambda>xs. upper_map\<cdot>d\<cdot>xs) ` range upper_principal)"
- apply (rule finite_subset [COMP swap_prems_rl])
- apply (clarsimp, rename_tac t)
- apply (induct_tac t rule: pd_basis_induct)
- apply (simp only: upper_unit_Rep_compact_basis [symmetric] upper_map_unit)
- apply (subgoal_tac "\<exists>b. d\<cdot>(Rep_compact_basis a) = Rep_compact_basis b")
- apply clarsimp
- apply (rule imageI)
- apply (rule vimageI2)
- apply (simp add: Rep_PDUnit)
- apply (rule image_eqI)
- apply (erule sym)
- apply simp
- apply (rule exI)
- apply (rule Abs_compact_basis_inverse [symmetric])
- apply (simp add: d.compact)
- apply (simp only: upper_plus_principal [symmetric] upper_map_plus)
- apply clarsimp
- apply (rule imageI)
- apply (rule vimageI2)
- apply (simp add: Rep_PDPlus)
- done
- moreover have "{xs::'a upper_pd. compact xs} = range upper_principal"
- by (auto dest: upper_pd.compact_imp_principal)
- ultimately have "finite ((\<lambda>xs. upper_map\<cdot>d\<cdot>xs) ` {xs::'a upper_pd. compact xs})"
- by simp
- hence "finite (range (\<lambda>xs. upper_map\<cdot>d\<cdot>xs))"
- by (rule finite_compact_range_imp_finite_range)
- thus "finite {xs. upper_map\<cdot>d\<cdot>xs = xs}"
- by (rule finite_range_imp_finite_fixes)
-qed
-
-lemma finite_deflation_lower_map:
- assumes "finite_deflation d" shows "finite_deflation (lower_map\<cdot>d)"
-proof (intro finite_deflation.intro finite_deflation_axioms.intro)
- interpret d: finite_deflation d by fact
- have "deflation d" by fact
- thus "deflation (lower_map\<cdot>d)" by (rule deflation_lower_map)
- have "finite (range (\<lambda>x. d\<cdot>x))" by (rule d.finite_range)
- hence "finite (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))"
- by (rule finite_vimageI, simp add: inj_on_def Rep_compact_basis_inject)
- hence "finite (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x)))" by simp
- hence "finite (Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))"
- by (rule finite_vimageI, simp add: inj_on_def Rep_pd_basis_inject)
- hence "finite (lower_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp
- hence "finite ((\<lambda>xs. lower_map\<cdot>d\<cdot>xs) ` range lower_principal)"
- apply (rule finite_subset [COMP swap_prems_rl])
- apply (clarsimp, rename_tac t)
- apply (induct_tac t rule: pd_basis_induct)
- apply (simp only: lower_unit_Rep_compact_basis [symmetric] lower_map_unit)
- apply (subgoal_tac "\<exists>b. d\<cdot>(Rep_compact_basis a) = Rep_compact_basis b")
- apply clarsimp
- apply (rule imageI)
- apply (rule vimageI2)
- apply (simp add: Rep_PDUnit)
- apply (rule image_eqI)
- apply (erule sym)
- apply simp
- apply (rule exI)
- apply (rule Abs_compact_basis_inverse [symmetric])
- apply (simp add: d.compact)
- apply (simp only: lower_plus_principal [symmetric] lower_map_plus)
- apply clarsimp
- apply (rule imageI)
- apply (rule vimageI2)
- apply (simp add: Rep_PDPlus)
- done
- moreover have "{xs::'a lower_pd. compact xs} = range lower_principal"
- by (auto dest: lower_pd.compact_imp_principal)
- ultimately have "finite ((\<lambda>xs. lower_map\<cdot>d\<cdot>xs) ` {xs::'a lower_pd. compact xs})"
- by simp
- hence "finite (range (\<lambda>xs. lower_map\<cdot>d\<cdot>xs))"
- by (rule finite_compact_range_imp_finite_range)
- thus "finite {xs. lower_map\<cdot>d\<cdot>xs = xs}"
- by (rule finite_range_imp_finite_fixes)
-qed
-
-lemma finite_deflation_convex_map:
- assumes "finite_deflation d" shows "finite_deflation (convex_map\<cdot>d)"
-proof (intro finite_deflation.intro finite_deflation_axioms.intro)
- interpret d: finite_deflation d by fact
- have "deflation d" by fact
- thus "deflation (convex_map\<cdot>d)" by (rule deflation_convex_map)
- have "finite (range (\<lambda>x. d\<cdot>x))" by (rule d.finite_range)
- hence "finite (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))"
- by (rule finite_vimageI, simp add: inj_on_def Rep_compact_basis_inject)
- hence "finite (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x)))" by simp
- hence "finite (Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))"
- by (rule finite_vimageI, simp add: inj_on_def Rep_pd_basis_inject)
- hence "finite (convex_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp
- hence "finite ((\<lambda>xs. convex_map\<cdot>d\<cdot>xs) ` range convex_principal)"
- apply (rule finite_subset [COMP swap_prems_rl])
- apply (clarsimp, rename_tac t)
- apply (induct_tac t rule: pd_basis_induct)
- apply (simp only: convex_unit_Rep_compact_basis [symmetric] convex_map_unit)
- apply (subgoal_tac "\<exists>b. d\<cdot>(Rep_compact_basis a) = Rep_compact_basis b")
- apply clarsimp
- apply (rule imageI)
- apply (rule vimageI2)
- apply (simp add: Rep_PDUnit)
- apply (rule image_eqI)
- apply (erule sym)
- apply simp
- apply (rule exI)
- apply (rule Abs_compact_basis_inverse [symmetric])
- apply (simp add: d.compact)
- apply (simp only: convex_plus_principal [symmetric] convex_map_plus)
- apply clarsimp
- apply (rule imageI)
- apply (rule vimageI2)
- apply (simp add: Rep_PDPlus)
- done
- moreover have "{xs::'a convex_pd. compact xs} = range convex_principal"
- by (auto dest: convex_pd.compact_imp_principal)
- ultimately have "finite ((\<lambda>xs. convex_map\<cdot>d\<cdot>xs) ` {xs::'a convex_pd. compact xs})"
- by simp
- hence "finite (range (\<lambda>xs. convex_map\<cdot>d\<cdot>xs))"
- by (rule finite_compact_range_imp_finite_range)
- thus "finite {xs. convex_map\<cdot>d\<cdot>xs = xs}"
- by (rule finite_range_imp_finite_fixes)
-qed
-
subsection {* Type combinators *}
definition
@@ -697,9 +517,6 @@
definition "sprod_defl = TypeRep_fun2 sprod_map"
definition "cprod_defl = TypeRep_fun2 cprod_map"
definition "u_defl = TypeRep_fun1 u_map"
-definition "upper_defl = TypeRep_fun1 upper_map"
-definition "lower_defl = TypeRep_fun1 lower_map"
-definition "convex_defl = TypeRep_fun1 convex_map"
lemma Rep_fin_defl_mono: "a \<sqsubseteq> b \<Longrightarrow> Rep_fin_defl a \<sqsubseteq> Rep_fin_defl b"
unfolding below_fin_defl_def .
@@ -783,27 +600,6 @@
apply (erule finite_deflation_u_map)
done
-lemma cast_upper_defl:
- "cast\<cdot>(upper_defl\<cdot>A) = udom_emb oo upper_map\<cdot>(cast\<cdot>A) oo udom_prj"
-unfolding upper_defl_def
-apply (rule cast_TypeRep_fun1)
-apply (erule finite_deflation_upper_map)
-done
-
-lemma cast_lower_defl:
- "cast\<cdot>(lower_defl\<cdot>A) = udom_emb oo lower_map\<cdot>(cast\<cdot>A) oo udom_prj"
-unfolding lower_defl_def
-apply (rule cast_TypeRep_fun1)
-apply (erule finite_deflation_lower_map)
-done
-
-lemma cast_convex_defl:
- "cast\<cdot>(convex_defl\<cdot>A) = udom_emb oo convex_map\<cdot>(cast\<cdot>A) oo udom_prj"
-unfolding convex_defl_def
-apply (rule cast_TypeRep_fun1)
-apply (erule finite_deflation_convex_map)
-done
-
text {* REP of type constructor = type combinator *}
lemma REP_cfun: "REP('a \<rightarrow> 'b) = cfun_defl\<cdot>REP('a)\<cdot>REP('b)"
@@ -814,7 +610,6 @@
apply (simp add: expand_cfun_eq ep_pair.e_eq_iff [OF ep_pair_udom])
done
-
lemma REP_ssum: "REP('a \<oplus> 'b) = ssum_defl\<cdot>REP('a)\<cdot>REP('b)"
apply (rule cast_eq_imp_eq, rule ext_cfun)
apply (simp add: cast_REP cast_ssum_defl)
@@ -847,39 +642,12 @@
apply (simp add: u_map_map cfcomp1)
done
-lemma REP_upper: "REP('a upper_pd) = upper_defl\<cdot>REP('a)"
-apply (rule cast_eq_imp_eq, rule ext_cfun)
-apply (simp add: cast_REP cast_upper_defl)
-apply (simp add: prj_upper_pd_def)
-apply (simp add: emb_upper_pd_def)
-apply (simp add: upper_map_map cfcomp1)
-done
-
-lemma REP_lower: "REP('a lower_pd) = lower_defl\<cdot>REP('a)"
-apply (rule cast_eq_imp_eq, rule ext_cfun)
-apply (simp add: cast_REP cast_lower_defl)
-apply (simp add: prj_lower_pd_def)
-apply (simp add: emb_lower_pd_def)
-apply (simp add: lower_map_map cfcomp1)
-done
-
-lemma REP_convex: "REP('a convex_pd) = convex_defl\<cdot>REP('a)"
-apply (rule cast_eq_imp_eq, rule ext_cfun)
-apply (simp add: cast_REP cast_convex_defl)
-apply (simp add: prj_convex_pd_def)
-apply (simp add: emb_convex_pd_def)
-apply (simp add: convex_map_map cfcomp1)
-done
-
lemmas REP_simps =
REP_cfun
REP_ssum
REP_sprod
REP_cprod
REP_up
- REP_upper
- REP_lower
- REP_convex
subsection {* Isomorphic deflations *}
@@ -1007,59 +775,27 @@
apply (simp add: u_map_map)
done
-lemma isodefl_upper:
- "isodefl d t \<Longrightarrow> isodefl (upper_map\<cdot>d) (upper_defl\<cdot>t)"
-apply (rule isodeflI)
-apply (simp add: cast_upper_defl cast_isodefl)
-apply (simp add: emb_upper_pd_def prj_upper_pd_def)
-apply (simp add: upper_map_map)
-done
-
-lemma isodefl_lower:
- "isodefl d t \<Longrightarrow> isodefl (lower_map\<cdot>d) (lower_defl\<cdot>t)"
-apply (rule isodeflI)
-apply (simp add: cast_lower_defl cast_isodefl)
-apply (simp add: emb_lower_pd_def prj_lower_pd_def)
-apply (simp add: lower_map_map)
-done
-
-lemma isodefl_convex:
- "isodefl d t \<Longrightarrow> isodefl (convex_map\<cdot>d) (convex_defl\<cdot>t)"
-apply (rule isodeflI)
-apply (simp add: cast_convex_defl cast_isodefl)
-apply (simp add: emb_convex_pd_def prj_convex_pd_def)
-apply (simp add: convex_map_map)
-done
-
subsection {* Constructing Domain Isomorphisms *}
+use "Tools/Domain/domain_take_proofs.ML"
use "Tools/Domain/domain_isomorphism.ML"
setup {*
fold Domain_Isomorphism.add_type_constructor
- [(@{type_name "->"}, @{term cfun_defl}, @{const_name cfun_map},
- @{thm REP_cfun}, @{thm isodefl_cfun}, @{thm cfun_map_ID}),
-
- (@{type_name "++"}, @{term ssum_defl}, @{const_name ssum_map},
- @{thm REP_ssum}, @{thm isodefl_ssum}, @{thm ssum_map_ID}),
+ [(@{type_name cfun}, @{term cfun_defl}, @{const_name cfun_map}, @{thm REP_cfun},
+ @{thm isodefl_cfun}, @{thm cfun_map_ID}, @{thm deflation_cfun_map}),
- (@{type_name "**"}, @{term sprod_defl}, @{const_name sprod_map},
- @{thm REP_sprod}, @{thm isodefl_sprod}, @{thm sprod_map_ID}),
-
- (@{type_name "*"}, @{term cprod_defl}, @{const_name cprod_map},
- @{thm REP_cprod}, @{thm isodefl_cprod}, @{thm cprod_map_ID}),
+ (@{type_name ssum}, @{term ssum_defl}, @{const_name ssum_map}, @{thm REP_ssum},
+ @{thm isodefl_ssum}, @{thm ssum_map_ID}, @{thm deflation_ssum_map}),
- (@{type_name "u"}, @{term u_defl}, @{const_name u_map},
- @{thm REP_up}, @{thm isodefl_u}, @{thm u_map_ID}),
-
- (@{type_name "upper_pd"}, @{term upper_defl}, @{const_name upper_map},
- @{thm REP_upper}, @{thm isodefl_upper}, @{thm upper_map_ID}),
+ (@{type_name sprod}, @{term sprod_defl}, @{const_name sprod_map}, @{thm REP_sprod},
+ @{thm isodefl_sprod}, @{thm sprod_map_ID}, @{thm deflation_sprod_map}),
- (@{type_name "lower_pd"}, @{term lower_defl}, @{const_name lower_map},
- @{thm REP_lower}, @{thm isodefl_lower}, @{thm lower_map_ID}),
+ (@{type_name "*"}, @{term cprod_defl}, @{const_name cprod_map}, @{thm REP_cprod},
+ @{thm isodefl_cprod}, @{thm cprod_map_ID}, @{thm deflation_cprod_map}),
- (@{type_name "convex_pd"}, @{term convex_defl}, @{const_name convex_map},
- @{thm REP_convex}, @{thm isodefl_convex}, @{thm convex_map_ID})]
+ (@{type_name "u"}, @{term u_defl}, @{const_name u_map}, @{thm REP_up},
+ @{thm isodefl_u}, @{thm u_map_ID}, @{thm deflation_u_map})]
*}
end
--- a/src/HOLCF/Sprod.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOLCF/Sprod.thy Wed Mar 03 16:43:55 2010 +0100
@@ -12,20 +12,20 @@
subsection {* Definition of strict product type *}
-pcpodef (Sprod) ('a, 'b) "**" (infixr "**" 20) =
+pcpodef (Sprod) ('a, 'b) sprod (infixr "**" 20) =
"{p::'a \<times> 'b. p = \<bottom> \<or> (fst p \<noteq> \<bottom> \<and> snd p \<noteq> \<bottom>)}"
by simp_all
-instance "**" :: ("{finite_po,pcpo}", "{finite_po,pcpo}") finite_po
+instance sprod :: ("{finite_po,pcpo}", "{finite_po,pcpo}") finite_po
by (rule typedef_finite_po [OF type_definition_Sprod])
-instance "**" :: ("{chfin,pcpo}", "{chfin,pcpo}") chfin
+instance sprod :: ("{chfin,pcpo}", "{chfin,pcpo}") chfin
by (rule typedef_chfin [OF type_definition_Sprod below_Sprod_def])
type_notation (xsymbols)
- "**" ("(_ \<otimes>/ _)" [21,20] 20)
+ sprod ("(_ \<otimes>/ _)" [21,20] 20)
type_notation (HTML output)
- "**" ("(_ \<otimes>/ _)" [21,20] 20)
+ sprod ("(_ \<otimes>/ _)" [21,20] 20)
lemma spair_lemma:
"(strictify\<cdot>(\<Lambda> b. a)\<cdot>b, strictify\<cdot>(\<Lambda> a. b)\<cdot>a) \<in> Sprod"
@@ -80,11 +80,11 @@
apply fast
done
-lemma sprodE [cases type: **]:
+lemma sprodE [cases type: sprod]:
"\<lbrakk>p = \<bottom> \<Longrightarrow> Q; \<And>x y. \<lbrakk>p = (:x, y:); x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
by (cut_tac z=p in Exh_Sprod, auto)
-lemma sprod_induct [induct type: **]:
+lemma sprod_induct [induct type: sprod]:
"\<lbrakk>P \<bottom>; \<And>x y. \<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> P (:x, y:)\<rbrakk> \<Longrightarrow> P x"
by (cases x, simp_all)
@@ -221,7 +221,7 @@
subsection {* Strict product preserves flatness *}
-instance "**" :: (flat, flat) flat
+instance sprod :: (flat, flat) flat
proof
fix x y :: "'a \<otimes> 'b"
assume "x \<sqsubseteq> y" thus "x = \<bottom> \<or> x = y"
@@ -245,6 +245,10 @@
"x \<noteq> \<bottom> \<Longrightarrow> y \<noteq> \<bottom> \<Longrightarrow> sprod_map\<cdot>f\<cdot>g\<cdot>(:x, y:) = (:f\<cdot>x, g\<cdot>y:)"
by (simp add: sprod_map_def)
+lemma sprod_map_spair':
+ "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> g\<cdot>\<bottom> = \<bottom> \<Longrightarrow> sprod_map\<cdot>f\<cdot>g\<cdot>(:x, y:) = (:f\<cdot>x, g\<cdot>y:)"
+by (cases "x = \<bottom> \<or> y = \<bottom>") auto
+
lemma sprod_map_ID: "sprod_map\<cdot>ID\<cdot>ID = ID"
unfolding sprod_map_def by (simp add: expand_cfun_eq eta_cfun)
@@ -308,7 +312,7 @@
subsection {* Strict product is a bifinite domain *}
-instantiation "**" :: (bifinite, bifinite) bifinite
+instantiation sprod :: (bifinite, bifinite) bifinite
begin
definition
--- a/src/HOLCF/Ssum.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOLCF/Ssum.thy Wed Mar 03 16:43:55 2010 +0100
@@ -12,22 +12,23 @@
subsection {* Definition of strict sum type *}
-pcpodef (Ssum) ('a, 'b) "++" (infixr "++" 10) =
+pcpodef (Ssum) ('a, 'b) ssum (infixr "++" 10) =
"{p :: tr \<times> ('a \<times> 'b).
(fst p \<sqsubseteq> TT \<longleftrightarrow> snd (snd p) = \<bottom>) \<and>
(fst p \<sqsubseteq> FF \<longleftrightarrow> fst (snd p) = \<bottom>)}"
by simp_all
-instance "++" :: ("{finite_po,pcpo}", "{finite_po,pcpo}") finite_po
+instance ssum :: ("{finite_po,pcpo}", "{finite_po,pcpo}") finite_po
by (rule typedef_finite_po [OF type_definition_Ssum])
-instance "++" :: ("{chfin,pcpo}", "{chfin,pcpo}") chfin
+instance ssum :: ("{chfin,pcpo}", "{chfin,pcpo}") chfin
by (rule typedef_chfin [OF type_definition_Ssum below_Ssum_def])
type_notation (xsymbols)
- "++" ("(_ \<oplus>/ _)" [21, 20] 20)
+ ssum ("(_ \<oplus>/ _)" [21, 20] 20)
type_notation (HTML output)
- "++" ("(_ \<oplus>/ _)" [21, 20] 20)
+ ssum ("(_ \<oplus>/ _)" [21, 20] 20)
+
subsection {* Definitions of constructors *}
@@ -150,13 +151,13 @@
apply (simp add: sinr_Abs_Ssum Ssum_def)
done
-lemma ssumE [cases type: ++]:
+lemma ssumE [cases type: ssum]:
"\<lbrakk>p = \<bottom> \<Longrightarrow> Q;
\<And>x. \<lbrakk>p = sinl\<cdot>x; x \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> Q;
\<And>y. \<lbrakk>p = sinr\<cdot>y; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
by (cut_tac z=p in Exh_Ssum, auto)
-lemma ssum_induct [induct type: ++]:
+lemma ssum_induct [induct type: ssum]:
"\<lbrakk>P \<bottom>;
\<And>x. x \<noteq> \<bottom> \<Longrightarrow> P (sinl\<cdot>x);
\<And>y. y \<noteq> \<bottom> \<Longrightarrow> P (sinr\<cdot>y)\<rbrakk> \<Longrightarrow> P x"
@@ -203,7 +204,7 @@
subsection {* Strict sum preserves flatness *}
-instance "++" :: (flat, flat) flat
+instance ssum :: (flat, flat) flat
apply (intro_classes, clarify)
apply (case_tac x, simp)
apply (case_tac y, simp_all add: flat_below_iff)
@@ -226,6 +227,12 @@
lemma ssum_map_sinr [simp]: "x \<noteq> \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinr\<cdot>x) = sinr\<cdot>(g\<cdot>x)"
unfolding ssum_map_def by simp
+lemma ssum_map_sinl': "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinl\<cdot>x) = sinl\<cdot>(f\<cdot>x)"
+by (cases "x = \<bottom>") simp_all
+
+lemma ssum_map_sinr': "g\<cdot>\<bottom> = \<bottom> \<Longrightarrow> ssum_map\<cdot>f\<cdot>g\<cdot>(sinr\<cdot>x) = sinr\<cdot>(g\<cdot>x)"
+by (cases "x = \<bottom>") simp_all
+
lemma ssum_map_ID: "ssum_map\<cdot>ID\<cdot>ID = ID"
unfolding ssum_map_def by (simp add: expand_cfun_eq eta_cfun)
@@ -290,7 +297,7 @@
subsection {* Strict sum is a bifinite domain *}
-instantiation "++" :: (bifinite, bifinite) bifinite
+instantiation ssum :: (bifinite, bifinite) bifinite
begin
definition
--- a/src/HOLCF/Tools/Domain/domain_axioms.ML Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOLCF/Tools/Domain/domain_axioms.ML Wed Mar 03 16:43:55 2010 +0100
@@ -1,22 +1,22 @@
(* Title: HOLCF/Tools/Domain/domain_axioms.ML
Author: David von Oheimb
+ Author: Brian Huffman
Syntax generator for domain command.
*)
signature DOMAIN_AXIOMS =
sig
+ val axiomatize_isomorphism :
+ binding * (typ * typ) ->
+ theory -> Domain_Take_Proofs.iso_info * theory
+
val copy_of_dtyp :
string Symtab.table -> (int -> term) -> Datatype.dtyp -> term
- val calc_axioms :
- bool -> string Symtab.table ->
- string -> Domain_Library.eq list -> int -> Domain_Library.eq ->
- string * (string * term) list * (string * term) list
-
val add_axioms :
- bool ->
- bstring -> Domain_Library.eq list -> theory -> theory
+ (binding * (typ * typ)) list ->
+ theory -> theory
end;
@@ -31,9 +31,9 @@
(* FIXME: use theory data for this *)
val copy_tab : string Symtab.table =
- Symtab.make [(@{type_name "->"}, @{const_name "cfun_map"}),
- (@{type_name "++"}, @{const_name "ssum_map"}),
- (@{type_name "**"}, @{const_name "sprod_map"}),
+ Symtab.make [(@{type_name cfun}, @{const_name "cfun_map"}),
+ (@{type_name ssum}, @{const_name "ssum_map"}),
+ (@{type_name sprod}, @{const_name "sprod_map"}),
(@{type_name "*"}, @{const_name "cprod_map"}),
(@{type_name "u"}, @{const_name "u_map"})];
@@ -46,116 +46,57 @@
SOME f => list_ccomb (%%:f, map (copy_of_dtyp tab r) ds)
| NONE => (warning ("copy_of_dtyp: unknown type constructor " ^ c); ID);
-fun calc_axioms
- (definitional : bool)
- (map_tab : string Symtab.table)
- (comp_dname : string)
- (eqs : eq list)
- (n : int)
- (eqn as ((dname,_),cons) : eq)
- : string * (string * term) list * (string * term) list =
- let
-
-(* ----- axioms and definitions concerning the isomorphism ------------------ *)
+local open HOLCF_Library in
- val dc_abs = %%:(dname^"_abs");
- val dc_rep = %%:(dname^"_rep");
- val x_name'= "x";
- val x_name = idx_name eqs x_name' (n+1);
- val dnam = Long_Name.base_name dname;
+fun axiomatize_isomorphism
+ (dbind : binding, (lhsT, rhsT))
+ (thy : theory)
+ : Domain_Take_Proofs.iso_info * theory =
+ let
+ val dname = Long_Name.base_name (Binding.name_of dbind);
- val abs_iso_ax = ("abs_iso", mk_trp(dc_rep`(dc_abs`%x_name') === %:x_name'));
- val rep_iso_ax = ("rep_iso", mk_trp(dc_abs`(dc_rep`%x_name') === %:x_name'));
-
- val when_def = ("when_def",%%:(dname^"_when") ==
- List.foldr (uncurry /\ ) (/\x_name'((when_body cons (fn (x,y) =>
- Bound(1+length cons+x-y)))`(dc_rep`Bound 0))) (when_funs cons));
+ val abs_bind = Binding.suffix_name "_abs" dbind;
+ val rep_bind = Binding.suffix_name "_rep" dbind;
- val copy_def =
- let fun r i = proj (Bound 0) eqs i;
- in
- ("copy_def", %%:(dname^"_copy") == /\ "f"
- (dc_abs oo (copy_of_dtyp map_tab r (dtyp_of_eq eqn)) oo dc_rep))
- end;
-
-(* -- definitions concerning the constructors, discriminators and selectors - *)
+ val (abs_const, thy) =
+ Sign.declare_const ((abs_bind, rhsT ->> lhsT), NoSyn) thy;
+ val (rep_const, thy) =
+ Sign.declare_const ((rep_bind, lhsT ->> rhsT), NoSyn) thy;
- fun con_def m n (_,args) = let
- fun idxs z x arg = (if is_lazy arg then mk_up else I) (Bound(z-x));
- fun parms vs = mk_stuple (mapn (idxs(length vs)) 1 vs);
- fun inj y 1 _ = y
- | inj y _ 0 = mk_sinl y
- | inj y i j = mk_sinr (inj y (i-1) (j-1));
- in List.foldr /\# (dc_abs`(inj (parms args) m n)) args end;
-
- val con_defs = mapn (fn n => fn (con, _, args) =>
- (extern_name con ^"_def", %%:con == con_def (length cons) n (con,args))) 0 cons;
-
- val dis_defs = let
- fun ddef (con,_,_) = (dis_name con ^"_def",%%:(dis_name con) ==
- list_ccomb(%%:(dname^"_when"),map
- (fn (con',_,args) => (List.foldr /\#
- (if con'=con then TT else FF) args)) cons))
- in map ddef cons end;
+ val x = Free ("x", lhsT);
+ val y = Free ("y", rhsT);
+
+ val abs_iso_eqn =
+ Logic.all y (mk_trp (mk_eq (rep_const ` (abs_const ` y), y)));
+ val rep_iso_eqn =
+ Logic.all x (mk_trp (mk_eq (abs_const ` (rep_const ` x), x)));
- val mat_defs =
- let
- fun mdef (con, _, _) =
- let
- val k = Bound 0
- val x = Bound 1
- fun one_con (con', _, args') =
- if con'=con then k else List.foldr /\# mk_fail args'
- val w = list_ccomb(%%:(dname^"_when"), map one_con cons)
- val rhs = /\ "x" (/\ "k" (w ` x))
- in (mat_name con ^"_def", %%:(mat_name con) == rhs) end
- in map mdef cons end;
+ val thy = Sign.add_path dname thy;
+
+ val (abs_iso_thm, thy) =
+ yield_singleton PureThy.add_axioms
+ ((Binding.name "abs_iso", abs_iso_eqn), []) thy;
- val pat_defs =
- let
- fun pdef (con, _, args) =
- let
- val ps = mapn (fn n => fn _ => %:("pat" ^ string_of_int n)) 1 args;
- val xs = map (bound_arg args) args;
- val r = Bound (length args);
- val rhs = case args of [] => mk_return HOLogic.unit
- | _ => mk_ctuple_pat ps ` mk_ctuple xs;
- fun one_con (con', _, args') = List.foldr /\# (if con'=con then rhs else mk_fail) args';
- in (pat_name con ^"_def", list_comb (%%:(pat_name con), ps) ==
- list_ccomb(%%:(dname^"_when"), map one_con cons))
- end
- in map pdef cons end;
+ val (rep_iso_thm, thy) =
+ yield_singleton PureThy.add_axioms
+ ((Binding.name "rep_iso", rep_iso_eqn), []) thy;
+
+ val thy = Sign.parent_path thy;
- val sel_defs = let
- fun sdef con n arg = Option.map (fn sel => (sel^"_def",%%:sel ==
- list_ccomb(%%:(dname^"_when"),map
- (fn (con', _, args) => if con'<>con then UU else
- List.foldr /\# (Bound (length args - n)) args) cons))) (sel_of arg);
- in map_filter I (maps (fn (con, _, args) => mapn (sdef con) 1 args) cons) end;
-
-
-(* ----- axiom and definitions concerning induction ------------------------- *)
+ val result =
+ {
+ absT = lhsT,
+ repT = rhsT,
+ abs_const = abs_const,
+ rep_const = rep_const,
+ abs_inverse = abs_iso_thm,
+ rep_inverse = rep_iso_thm
+ };
+ in
+ (result, thy)
+ end;
- val reach_ax = ("reach", mk_trp(proj (mk_fix (%%:(comp_dname^"_copy"))) eqs n
- `%x_name === %:x_name));
- val take_def =
- ("take_def",
- %%:(dname^"_take") ==
- mk_lam("n",proj
- (mk_iterate (Bound 0, %%:(comp_dname^"_copy"), UU)) eqs n));
- val finite_def =
- ("finite_def",
- %%:(dname^"_finite") ==
- mk_lam(x_name,
- mk_ex("n",(%%:(dname^"_take") $ Bound 0)`Bound 1 === Bound 1)));
-
- in (dnam,
- (if definitional then [] else [abs_iso_ax, rep_iso_ax, reach_ax]),
- (if definitional then [when_def] else [when_def, copy_def]) @
- con_defs @ dis_defs @ mat_defs @ pat_defs @ sel_defs @
- [take_def, finite_def])
- end; (* let (calc_axioms) *)
-
+end;
(* legacy type inference *)
@@ -170,84 +111,46 @@
fun add_axioms_i x = snd o PureThy.add_axioms (map (Thm.no_attributes o apfst Binding.name) x);
fun add_axioms_infer axms thy = add_axioms_i (infer_props thy axms) thy;
-fun add_defs_i x = snd o (PureThy.add_defs false) (map (Thm.no_attributes o apfst Binding.name) x);
-fun add_defs_infer defs thy = add_defs_i (infer_props thy defs) thy;
-
-fun add_matchers (((dname,_),cons) : eq) thy =
- let
- val con_names = map first cons;
- val mat_names = map mat_name con_names;
- fun qualify n = Sign.full_name thy (Binding.name n);
- val ms = map qualify con_names ~~ map qualify mat_names;
- in Fixrec.add_matchers ms thy end;
-
-fun add_axioms definitional comp_dnam (eqs : eq list) thy' =
+fun add_axioms
+ (dom_eqns : (binding * (typ * typ)) list)
+ (thy : theory) =
let
- val comp_dname = Sign.full_bname thy' comp_dnam;
- val dnames = map (fst o fst) eqs;
- val x_name = idx_name dnames "x";
- fun copy_app dname = %%:(dname^"_copy")`Bound 0;
- val copy_def = ("copy_def" , %%:(comp_dname^"_copy") ==
- /\ "f"(mk_ctuple (map copy_app dnames)));
- fun one_con (con, _, args) =
- let
- val nonrec_args = filter_out is_rec args;
- val rec_args = filter is_rec args;
- val recs_cnt = length rec_args;
- val allargs = nonrec_args @ rec_args
- @ map (upd_vname (fn s=> s^"'")) rec_args;
- val allvns = map vname allargs;
- fun vname_arg s arg = if is_rec arg then vname arg^s else vname arg;
- val vns1 = map (vname_arg "" ) args;
- val vns2 = map (vname_arg "'") args;
- val allargs_cnt = length nonrec_args + 2*recs_cnt;
- val rec_idxs = (recs_cnt-1) downto 0;
- val nonlazy_idxs = map snd (filter_out (fn (arg,_) => is_lazy arg)
- (allargs~~((allargs_cnt-1) downto 0)));
- fun rel_app i ra = proj (Bound(allargs_cnt+2)) eqs (rec_of ra) $
- Bound (2*recs_cnt-i) $ Bound (recs_cnt-i);
- val capps =
- List.foldr
- mk_conj
- (mk_conj(
- Bound(allargs_cnt+1)===list_ccomb(%%:con,map (bound_arg allvns) vns1),
- Bound(allargs_cnt+0)===list_ccomb(%%:con,map (bound_arg allvns) vns2)))
- (mapn rel_app 1 rec_args);
- in
- List.foldr
- mk_ex
- (Library.foldr mk_conj
- (map (defined o Bound) nonlazy_idxs,capps)) allvns
- end;
- fun one_comp n (_,cons) =
- mk_all (x_name(n+1),
- mk_all (x_name(n+1)^"'",
- mk_imp (proj (Bound 2) eqs n $ Bound 1 $ Bound 0,
- foldr1 mk_disj (mk_conj(Bound 1 === UU,Bound 0 === UU)
- ::map one_con cons))));
- val bisim_def =
- ("bisim_def", %%:(comp_dname^"_bisim") ==
- mk_lam("R", foldr1 mk_conj (mapn one_comp 0 eqs)));
+ (* declare and axiomatize abs/rep *)
+ val (iso_infos, thy) =
+ fold_map axiomatize_isomorphism dom_eqns thy;
- fun add_one (dnam, axs, dfs) =
+ fun add_one (dnam, axs) =
Sign.add_path dnam
- #> add_defs_infer dfs
#> add_axioms_infer axs
#> Sign.parent_path;
- val map_tab = Domain_Isomorphism.get_map_tab thy';
+ (* define take function *)
+ val (take_info, thy) =
+ Domain_Take_Proofs.define_take_functions
+ (map fst dom_eqns ~~ iso_infos) thy;
- val thy = thy'
- |> fold add_one (mapn (calc_axioms definitional map_tab comp_dname eqs) 0 eqs);
+ (* declare lub_take axioms *)
+ local
+ fun ax_lub_take (dbind, take_const) =
+ let
+ val dnam = Long_Name.base_name (Binding.name_of dbind);
+ val lub = %%: @{const_name lub};
+ val image = %%: @{const_name image};
+ val UNIV = @{term "UNIV :: nat set"};
+ val lhs = lub $ (image $ take_const $ UNIV);
+ val ax = mk_trp (lhs === ID);
+ in
+ add_one (dnam, [("lub_take", ax)])
+ end
+ val dbinds = map fst dom_eqns;
+ val take_consts = #take_consts take_info;
+ in
+ val thy = fold ax_lub_take (dbinds ~~ take_consts) thy
+ end;
- val use_copy_def = length eqs>1 andalso not definitional;
in
- thy
- |> Sign.add_path comp_dnam
- |> add_defs_infer (bisim_def::(if use_copy_def then [copy_def] else []))
- |> Sign.parent_path
- |> fold add_matchers eqs
- end; (* let (add_axioms) *)
+ thy (* TODO: also return iso_infos, take_info, lub_take_thms *)
+ end;
end; (* struct *)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOLCF/Tools/Domain/domain_constructors.ML Wed Mar 03 16:43:55 2010 +0100
@@ -0,0 +1,1123 @@
+(* Title: HOLCF/Tools/domain/domain_constructors.ML
+ Author: Brian Huffman
+
+Defines constructor functions for a given domain isomorphism
+and proves related theorems.
+*)
+
+signature DOMAIN_CONSTRUCTORS =
+sig
+ val add_domain_constructors :
+ string
+ -> (binding * (bool * binding option * typ) list * mixfix) list
+ -> Domain_Take_Proofs.iso_info
+ -> theory
+ -> { con_consts : term list,
+ con_betas : thm list,
+ exhaust : thm,
+ casedist : thm,
+ con_compacts : thm list,
+ con_rews : thm list,
+ inverts : thm list,
+ injects : thm list,
+ dist_les : thm list,
+ dist_eqs : thm list,
+ cases : thm list,
+ sel_rews : thm list,
+ dis_rews : thm list,
+ match_rews : thm list,
+ pat_rews : thm list
+ } * theory;
+end;
+
+
+structure Domain_Constructors :> DOMAIN_CONSTRUCTORS =
+struct
+
+open HOLCF_Library;
+infixr 6 ->>;
+infix -->>;
+
+(************************** miscellaneous functions ***************************)
+
+val simple_ss =
+ HOL_basic_ss addsimps simp_thms;
+
+val beta_ss =
+ HOL_basic_ss
+ addsimps simp_thms
+ addsimps [@{thm beta_cfun}]
+ addsimprocs [@{simproc cont_proc}];
+
+fun define_consts
+ (specs : (binding * term * mixfix) list)
+ (thy : theory)
+ : (term list * thm list) * theory =
+ let
+ fun mk_decl (b, t, mx) = (b, fastype_of t, mx);
+ val decls = map mk_decl specs;
+ val thy = Cont_Consts.add_consts decls thy;
+ fun mk_const (b, T, mx) = Const (Sign.full_name thy b, T);
+ val consts = map mk_const decls;
+ fun mk_def c (b, t, mx) =
+ (Binding.suffix_name "_def" b, Logic.mk_equals (c, t));
+ val defs = map2 mk_def consts specs;
+ val (def_thms, thy) =
+ PureThy.add_defs false (map Thm.no_attributes defs) thy;
+ in
+ ((consts, def_thms), thy)
+ end;
+
+fun prove
+ (thy : theory)
+ (defs : thm list)
+ (goal : term)
+ (tacs : {prems: thm list, context: Proof.context} -> tactic list)
+ : thm =
+ let
+ fun tac {prems, context} =
+ rewrite_goals_tac defs THEN
+ EVERY (tacs {prems = map (rewrite_rule defs) prems, context = context})
+ in
+ Goal.prove_global thy [] [] goal tac
+ end;
+
+fun get_vars_avoiding
+ (taken : string list)
+ (args : (bool * typ) list)
+ : (term list * term list) =
+ let
+ val Ts = map snd args;
+ val ns = Name.variant_list taken (Datatype_Prop.make_tnames Ts);
+ val vs = map Free (ns ~~ Ts);
+ val nonlazy = map snd (filter_out (fst o fst) (args ~~ vs));
+ in
+ (vs, nonlazy)
+ end;
+
+fun get_vars args = get_vars_avoiding [] args;
+
+(************** generating beta reduction rules from definitions **************)
+
+local
+ fun arglist (Const _ $ Abs (s, T, t)) =
+ let
+ val arg = Free (s, T);
+ val (args, body) = arglist (subst_bound (arg, t));
+ in (arg :: args, body) end
+ | arglist t = ([], t);
+in
+ fun beta_of_def thy def_thm =
+ let
+ val (con, lam) = Logic.dest_equals (concl_of def_thm);
+ val (args, rhs) = arglist lam;
+ val lhs = list_ccomb (con, args);
+ val goal = mk_equals (lhs, rhs);
+ val cs = ContProc.cont_thms lam;
+ val betas = map (fn c => mk_meta_eq (c RS @{thm beta_cfun})) cs;
+ in
+ prove thy (def_thm::betas) goal (K [rtac reflexive_thm 1])
+ end;
+end;
+
+(******************************************************************************)
+(************* definitions and theorems for constructor functions *************)
+(******************************************************************************)
+
+fun add_constructors
+ (spec : (binding * (bool * typ) list * mixfix) list)
+ (abs_const : term)
+ (iso_locale : thm)
+ (thy : theory)
+ =
+ let
+
+ (* get theorems about rep and abs *)
+ val abs_strict = iso_locale RS @{thm iso.abs_strict};
+
+ (* get types of type isomorphism *)
+ val (rhsT, lhsT) = dest_cfunT (fastype_of abs_const);
+
+ fun vars_of args =
+ let
+ val Ts = map snd args;
+ val ns = Datatype_Prop.make_tnames Ts;
+ in
+ map Free (ns ~~ Ts)
+ end;
+
+ (* define constructor functions *)
+ val ((con_consts, con_defs), thy) =
+ let
+ fun one_arg (lazy, T) var = if lazy then mk_up var else var;
+ fun one_con (_,args,_) = mk_stuple (map2 one_arg args (vars_of args));
+ fun mk_abs t = abs_const ` t;
+ val rhss = map mk_abs (mk_sinjects (map one_con spec));
+ fun mk_def (bind, args, mx) rhs =
+ (bind, big_lambdas (vars_of args) rhs, mx);
+ in
+ define_consts (map2 mk_def spec rhss) thy
+ end;
+
+ (* prove beta reduction rules for constructors *)
+ val con_betas = map (beta_of_def thy) con_defs;
+
+ (* replace bindings with terms in constructor spec *)
+ val spec' : (term * (bool * typ) list) list =
+ let fun one_con con (b, args, mx) = (con, args);
+ in map2 one_con con_consts spec end;
+
+ (* prove exhaustiveness of constructors *)
+ local
+ fun arg2typ n (true, T) = (n+1, mk_upT (TVar (("'a", n), @{sort cpo})))
+ | arg2typ n (false, T) = (n+1, TVar (("'a", n), @{sort pcpo}));
+ fun args2typ n [] = (n, oneT)
+ | args2typ n [arg] = arg2typ n arg
+ | args2typ n (arg::args) =
+ let
+ val (n1, t1) = arg2typ n arg;
+ val (n2, t2) = args2typ n1 args
+ in (n2, mk_sprodT (t1, t2)) end;
+ fun cons2typ n [] = (n, oneT)
+ | cons2typ n [con] = args2typ n (snd con)
+ | cons2typ n (con::cons) =
+ let
+ val (n1, t1) = args2typ n (snd con);
+ val (n2, t2) = cons2typ n1 cons
+ in (n2, mk_ssumT (t1, t2)) end;
+ val ct = ctyp_of thy (snd (cons2typ 1 spec'));
+ val thm1 = instantiate' [SOME ct] [] @{thm exh_start};
+ val thm2 = rewrite_rule (map mk_meta_eq @{thms ex_defined_iffs}) thm1;
+ val thm3 = rewrite_rule [mk_meta_eq @{thm conj_assoc}] thm2;
+
+ val y = Free ("y", lhsT);
+ fun one_con (con, args) =
+ let
+ val (vs, nonlazy) = get_vars_avoiding ["y"] args;
+ val eqn = mk_eq (y, list_ccomb (con, vs));
+ val conj = foldr1 mk_conj (eqn :: map mk_defined nonlazy);
+ in Library.foldr mk_ex (vs, conj) end;
+ val goal = mk_trp (foldr1 mk_disj (mk_undef y :: map one_con spec'));
+ (* first 3 rules replace "y = UU \/ P" with "rep$y = UU \/ P" *)
+ val tacs = [
+ rtac (iso_locale RS @{thm iso.casedist_rule}) 1,
+ rewrite_goals_tac [mk_meta_eq (iso_locale RS @{thm iso.iso_swap})],
+ rtac thm3 1];
+ in
+ val exhaust = prove thy con_betas goal (K tacs);
+ val casedist =
+ (exhaust RS @{thm exh_casedist0})
+ |> rewrite_rule @{thms exh_casedists}
+ |> Drule.export_without_context;
+ end;
+
+ (* prove compactness rules for constructors *)
+ val con_compacts =
+ let
+ val rules = @{thms compact_sinl compact_sinr compact_spair
+ compact_up compact_ONE};
+ val tacs =
+ [rtac (iso_locale RS @{thm iso.compact_abs}) 1,
+ REPEAT (resolve_tac rules 1 ORELSE atac 1)];
+ fun con_compact (con, args) =
+ let
+ val vs = vars_of args;
+ val con_app = list_ccomb (con, vs);
+ val concl = mk_trp (mk_compact con_app);
+ val assms = map (mk_trp o mk_compact) vs;
+ val goal = Logic.list_implies (assms, concl);
+ in
+ prove thy con_betas goal (K tacs)
+ end;
+ in
+ map con_compact spec'
+ end;
+
+ (* prove strictness rules for constructors *)
+ local
+ fun con_strict (con, args) =
+ let
+ val rules = abs_strict :: @{thms con_strict_rules};
+ val (vs, nonlazy) = get_vars args;
+ fun one_strict v' =
+ let
+ val UU = mk_bottom (fastype_of v');
+ val vs' = map (fn v => if v = v' then UU else v) vs;
+ val goal = mk_trp (mk_undef (list_ccomb (con, vs')));
+ val tacs = [simp_tac (HOL_basic_ss addsimps rules) 1];
+ in prove thy con_betas goal (K tacs) end;
+ in map one_strict nonlazy end;
+
+ fun con_defin (con, args) =
+ let
+ fun iff_disj (t, []) = HOLogic.mk_not t
+ | iff_disj (t, ts) = mk_eq (t, foldr1 HOLogic.mk_disj ts);
+ val (vs, nonlazy) = get_vars args;
+ val lhs = mk_undef (list_ccomb (con, vs));
+ val rhss = map mk_undef nonlazy;
+ val goal = mk_trp (iff_disj (lhs, rhss));
+ val rule1 = iso_locale RS @{thm iso.abs_defined_iff};
+ val rules = rule1 :: @{thms con_defined_iff_rules};
+ val tacs = [simp_tac (HOL_ss addsimps rules) 1];
+ in prove thy con_betas goal (K tacs) end;
+ in
+ val con_stricts = maps con_strict spec';
+ val con_defins = map con_defin spec';
+ val con_rews = con_stricts @ con_defins;
+ end;
+
+ (* prove injectiveness of constructors *)
+ local
+ fun pgterm rel (con, args) =
+ let
+ fun prime (Free (n, T)) = Free (n^"'", T)
+ | prime t = t;
+ val (xs, nonlazy) = get_vars args;
+ val ys = map prime xs;
+ val lhs = rel (list_ccomb (con, xs), list_ccomb (con, ys));
+ val rhs = foldr1 mk_conj (ListPair.map rel (xs, ys));
+ val concl = mk_trp (mk_eq (lhs, rhs));
+ val zs = case args of [_] => [] | _ => nonlazy;
+ val assms = map (mk_trp o mk_defined) zs;
+ val goal = Logic.list_implies (assms, concl);
+ in prove thy con_betas goal end;
+ val cons' = filter (fn (_, args) => not (null args)) spec';
+ in
+ val inverts =
+ let
+ val abs_below = iso_locale RS @{thm iso.abs_below};
+ val rules1 = abs_below :: @{thms sinl_below sinr_below spair_below up_below};
+ val rules2 = @{thms up_defined spair_defined ONE_defined}
+ val rules = rules1 @ rules2;
+ val tacs = [asm_simp_tac (simple_ss addsimps rules) 1];
+ in map (fn c => pgterm mk_below c (K tacs)) cons' end;
+ val injects =
+ let
+ val abs_eq = iso_locale RS @{thm iso.abs_eq};
+ val rules1 = abs_eq :: @{thms sinl_eq sinr_eq spair_eq up_eq};
+ val rules2 = @{thms up_defined spair_defined ONE_defined}
+ val rules = rules1 @ rules2;
+ val tacs = [asm_simp_tac (simple_ss addsimps rules) 1];
+ in map (fn c => pgterm mk_eq c (K tacs)) cons' end;
+ end;
+
+ (* prove distinctness of constructors *)
+ local
+ fun map_dist (f : 'a -> 'a -> 'b) (xs : 'a list) : 'b list =
+ flat (map_index (fn (i, x) => map (f x) (nth_drop i xs)) xs);
+ fun prime (Free (n, T)) = Free (n^"'", T)
+ | prime t = t;
+ fun iff_disj (t, []) = mk_not t
+ | iff_disj (t, ts) = mk_eq (t, foldr1 mk_disj ts);
+ fun iff_disj2 (t, [], us) = mk_not t
+ | iff_disj2 (t, ts, []) = mk_not t
+ | iff_disj2 (t, ts, us) =
+ mk_eq (t, mk_conj (foldr1 mk_disj ts, foldr1 mk_disj us));
+ fun dist_le (con1, args1) (con2, args2) =
+ let
+ val (vs1, zs1) = get_vars args1;
+ val (vs2, zs2) = get_vars args2 |> pairself (map prime);
+ val lhs = mk_below (list_ccomb (con1, vs1), list_ccomb (con2, vs2));
+ val rhss = map mk_undef zs1;
+ val goal = mk_trp (iff_disj (lhs, rhss));
+ val rule1 = iso_locale RS @{thm iso.abs_below};
+ val rules = rule1 :: @{thms con_below_iff_rules};
+ val tacs = [simp_tac (HOL_ss addsimps rules) 1];
+ in prove thy con_betas goal (K tacs) end;
+ fun dist_eq (con1, args1) (con2, args2) =
+ let
+ val (vs1, zs1) = get_vars args1;
+ val (vs2, zs2) = get_vars args2 |> pairself (map prime);
+ val lhs = mk_eq (list_ccomb (con1, vs1), list_ccomb (con2, vs2));
+ val rhss1 = map mk_undef zs1;
+ val rhss2 = map mk_undef zs2;
+ val goal = mk_trp (iff_disj2 (lhs, rhss1, rhss2));
+ val rule1 = iso_locale RS @{thm iso.abs_eq};
+ val rules = rule1 :: @{thms con_eq_iff_rules};
+ val tacs = [simp_tac (HOL_ss addsimps rules) 1];
+ in prove thy con_betas goal (K tacs) end;
+ in
+ val dist_les = map_dist dist_le spec';
+ val dist_eqs = map_dist dist_eq spec';
+ end;
+
+ val result =
+ {
+ con_consts = con_consts,
+ con_betas = con_betas,
+ exhaust = exhaust,
+ casedist = casedist,
+ con_compacts = con_compacts,
+ con_rews = con_rews,
+ inverts = inverts,
+ injects = injects,
+ dist_les = dist_les,
+ dist_eqs = dist_eqs
+ };
+ in
+ (result, thy)
+ end;
+
+(******************************************************************************)
+(**************** definition and theorems for case combinator *****************)
+(******************************************************************************)
+
+fun add_case_combinator
+ (spec : (term * (bool * typ) list) list)
+ (lhsT : typ)
+ (dname : string)
+ (con_betas : thm list)
+ (casedist : thm)
+ (iso_locale : thm)
+ (rep_const : term)
+ (thy : theory)
+ : ((typ -> term) * thm list) * theory =
+ let
+
+ (* TODO: move these to holcf_library.ML *)
+ fun one_when_const T = Const (@{const_name one_when}, T ->> oneT ->> T);
+ fun mk_one_when t = one_when_const (fastype_of t) ` t;
+ fun mk_sscase (t, u) =
+ let
+ val (T, V) = dest_cfunT (fastype_of t);
+ val (U, V) = dest_cfunT (fastype_of u);
+ in sscase_const (T, U, V) ` t ` u end;
+ fun strictify_const T = Const (@{const_name strictify}, T ->> T);
+ fun mk_strictify t = strictify_const (fastype_of t) ` t;
+ fun ssplit_const (T, U, V) =
+ Const (@{const_name ssplit}, (T ->> U ->> V) ->> mk_sprodT (T, U) ->> V);
+ fun mk_ssplit t =
+ let val (T, (U, V)) = apsnd dest_cfunT (dest_cfunT (fastype_of t));
+ in ssplit_const (T, U, V) ` t end;
+ fun lambda_stuple [] t = mk_one_when t
+ | lambda_stuple [x] t = mk_strictify (big_lambda x t)
+ | lambda_stuple [x,y] t = mk_ssplit (big_lambdas [x, y] t)
+ | lambda_stuple (x::xs) t = mk_ssplit (big_lambda x (lambda_stuple xs t));
+
+ (* eta contraction for simplifying definitions *)
+ fun cont_eta_contract (Const(@{const_name Abs_CFun},TT) $ Abs(a,T,body)) =
+ (case cont_eta_contract body of
+ body' as (Const(@{const_name Abs_CFun},Ta) $ f $ Bound 0) =>
+ if not (0 mem loose_bnos f) then incr_boundvars ~1 f
+ else Const(@{const_name Abs_CFun},TT) $ Abs(a,T,body')
+ | body' => Const(@{const_name Abs_CFun},TT) $ Abs(a,T,body'))
+ | cont_eta_contract(f$t) = cont_eta_contract f $ cont_eta_contract t
+ | cont_eta_contract t = t;
+
+ (* prove rep/abs rules *)
+ val rep_strict = iso_locale RS @{thm iso.rep_strict};
+ val abs_inverse = iso_locale RS @{thm iso.abs_iso};
+
+ (* calculate function arguments of case combinator *)
+ val tns = map (fst o dest_TFree) (snd (dest_Type lhsT));
+ val resultT = TFree (Name.variant tns "'t", @{sort pcpo});
+ fun fTs T = map (fn (_, args) => map snd args -->> T) spec;
+ val fns = Datatype_Prop.indexify_names (map (K "f") spec);
+ val fs = map Free (fns ~~ fTs resultT);
+ fun caseT T = fTs T -->> (lhsT ->> T);
+
+ (* definition of case combinator *)
+ local
+ val case_bind = Binding.name (dname ^ "_when");
+ fun one_con f (_, args) =
+ let
+ fun argT (lazy, T) = if lazy then mk_upT T else T;
+ fun down (lazy, T) v = if lazy then from_up T ` v else v;
+ val Ts = map argT args;
+ val ns = Name.variant_list fns (Datatype_Prop.make_tnames Ts);
+ val vs = map Free (ns ~~ Ts);
+ val xs = map2 down args vs;
+ in
+ cont_eta_contract (lambda_stuple vs (list_ccomb (f, xs)))
+ end;
+ val body = foldr1 mk_sscase (map2 one_con fs spec);
+ val rhs = big_lambdas fs (mk_cfcomp (body, rep_const));
+ val ((case_consts, case_defs), thy) =
+ define_consts [(case_bind, rhs, NoSyn)] thy;
+ val case_name = Sign.full_name thy case_bind;
+ in
+ val case_def = hd case_defs;
+ fun case_const T = Const (case_name, caseT T);
+ val case_app = list_ccomb (case_const resultT, fs);
+ val thy = thy;
+ end;
+
+ (* define syntax for case combinator *)
+ (* TODO: re-implement case syntax using a parse translation *)
+ local
+ open Syntax
+ fun syntax c = Syntax.mark_const (fst (dest_Const c));
+ fun xconst c = Long_Name.base_name (fst (dest_Const c));
+ fun c_ast authentic con =
+ Constant (if authentic then syntax con else xconst con);
+ fun showint n = string_of_int (n+1);
+ fun expvar n = Variable ("e" ^ showint n);
+ fun argvar n (m, _) = Variable ("a" ^ showint n ^ "_" ^ showint m);
+ fun argvars n args = map_index (argvar n) args;
+ fun app s (l, r) = mk_appl (Constant s) [l, r];
+ val cabs = app "_cabs";
+ val capp = app @{const_syntax Rep_CFun};
+ val capps = Library.foldl capp
+ fun con1 authentic n (con,args) =
+ Library.foldl capp (c_ast authentic con, argvars n args);
+ fun case1 authentic (n, c) =
+ app "_case1" (con1 authentic n c, expvar n);
+ fun arg1 (n, (con,args)) = List.foldr cabs (expvar n) (argvars n args);
+ fun when1 n (m, c) =
+ if n = m then arg1 (n, c) else (Constant @{const_syntax UU});
+ val case_constant = Constant (syntax (case_const dummyT));
+ fun case_trans authentic =
+ ParsePrintRule
+ (app "_case_syntax"
+ (Variable "x",
+ foldr1 (app "_case2") (map_index (case1 authentic) spec)),
+ capp (capps (case_constant, map_index arg1 spec), Variable "x"));
+ fun one_abscon_trans authentic (n, c) =
+ ParsePrintRule
+ (cabs (con1 authentic n c, expvar n),
+ capps (case_constant, map_index (when1 n) spec));
+ fun abscon_trans authentic =
+ map_index (one_abscon_trans authentic) spec;
+ val trans_rules : ast Syntax.trrule list =
+ case_trans false :: case_trans true ::
+ abscon_trans false @ abscon_trans true;
+ in
+ val thy = Sign.add_trrules_i trans_rules thy;
+ end;
+
+ (* prove beta reduction rule for case combinator *)
+ val case_beta = beta_of_def thy case_def;
+
+ (* prove strictness of case combinator *)
+ val case_strict =
+ let
+ val defs = case_beta :: map mk_meta_eq [rep_strict, @{thm cfcomp2}];
+ val goal = mk_trp (mk_strict case_app);
+ val rules = @{thms sscase1 ssplit1 strictify1 one_when1};
+ val tacs = [resolve_tac rules 1];
+ in prove thy defs goal (K tacs) end;
+
+ (* prove rewrites for case combinator *)
+ local
+ fun one_case (con, args) f =
+ let
+ val (vs, nonlazy) = get_vars args;
+ val assms = map (mk_trp o mk_defined) nonlazy;
+ val lhs = case_app ` list_ccomb (con, vs);
+ val rhs = list_ccomb (f, vs);
+ val concl = mk_trp (mk_eq (lhs, rhs));
+ val goal = Logic.list_implies (assms, concl);
+ val defs = case_beta :: con_betas;
+ val rules1 = @{thms strictify2 sscase2 sscase3 ssplit2 fup2 ID1};
+ val rules2 = @{thms con_defined_iff_rules};
+ val rules3 = @{thms cfcomp2 one_when2};
+ val rules = abs_inverse :: rules1 @ rules2 @ rules3;
+ val tacs = [asm_simp_tac (beta_ss addsimps rules) 1];
+ in prove thy defs goal (K tacs) end;
+ in
+ val case_apps = map2 one_case spec fs;
+ end
+
+ in
+ ((case_const, case_strict :: case_apps), thy)
+ end
+
+(******************************************************************************)
+(************** definitions and theorems for selector functions ***************)
+(******************************************************************************)
+
+fun add_selectors
+ (spec : (term * (bool * binding option * typ) list) list)
+ (rep_const : term)
+ (abs_inv : thm)
+ (rep_strict : thm)
+ (rep_strict_iff : thm)
+ (con_betas : thm list)
+ (thy : theory)
+ : thm list * theory =
+ let
+
+ (* define selector functions *)
+ val ((sel_consts, sel_defs), thy) =
+ let
+ fun rangeT s = snd (dest_cfunT (fastype_of s));
+ fun mk_outl s = mk_cfcomp (from_sinl (dest_ssumT (rangeT s)), s);
+ fun mk_outr s = mk_cfcomp (from_sinr (dest_ssumT (rangeT s)), s);
+ fun mk_sfst s = mk_cfcomp (sfst_const (dest_sprodT (rangeT s)), s);
+ fun mk_ssnd s = mk_cfcomp (ssnd_const (dest_sprodT (rangeT s)), s);
+ fun mk_down s = mk_cfcomp (from_up (dest_upT (rangeT s)), s);
+
+ fun sels_of_arg s (lazy, NONE, T) = []
+ | sels_of_arg s (lazy, SOME b, T) =
+ [(b, if lazy then mk_down s else s, NoSyn)];
+ fun sels_of_args s [] = []
+ | sels_of_args s (v :: []) = sels_of_arg s v
+ | sels_of_args s (v :: vs) =
+ sels_of_arg (mk_sfst s) v @ sels_of_args (mk_ssnd s) vs;
+ fun sels_of_cons s [] = []
+ | sels_of_cons s ((con, args) :: []) = sels_of_args s args
+ | sels_of_cons s ((con, args) :: cs) =
+ sels_of_args (mk_outl s) args @ sels_of_cons (mk_outr s) cs;
+ val sel_eqns : (binding * term * mixfix) list =
+ sels_of_cons rep_const spec;
+ in
+ define_consts sel_eqns thy
+ end
+
+ (* replace bindings with terms in constructor spec *)
+ val spec2 : (term * (bool * term option * typ) list) list =
+ let
+ fun prep_arg (lazy, NONE, T) sels = ((lazy, NONE, T), sels)
+ | prep_arg (lazy, SOME _, T) sels =
+ ((lazy, SOME (hd sels), T), tl sels);
+ fun prep_con (con, args) sels =
+ apfst (pair con) (fold_map prep_arg args sels);
+ in
+ fst (fold_map prep_con spec sel_consts)
+ end;
+
+ (* prove selector strictness rules *)
+ val sel_stricts : thm list =
+ let
+ val rules = rep_strict :: @{thms sel_strict_rules};
+ val tacs = [simp_tac (HOL_basic_ss addsimps rules) 1];
+ fun sel_strict sel =
+ let
+ val goal = mk_trp (mk_strict sel);
+ in
+ prove thy sel_defs goal (K tacs)
+ end
+ in
+ map sel_strict sel_consts
+ end
+
+ (* prove selector application rules *)
+ val sel_apps : thm list =
+ let
+ val defs = con_betas @ sel_defs;
+ val rules = abs_inv :: @{thms sel_app_rules};
+ val tacs = [asm_simp_tac (simple_ss addsimps rules) 1];
+ fun sel_apps_of (i, (con, args)) =
+ let
+ val Ts : typ list = map #3 args;
+ val ns : string list = Datatype_Prop.make_tnames Ts;
+ val vs : term list = map Free (ns ~~ Ts);
+ val con_app : term = list_ccomb (con, vs);
+ val vs' : (bool * term) list = map #1 args ~~ vs;
+ fun one_same (n, sel, T) =
+ let
+ val xs = map snd (filter_out fst (nth_drop n vs'));
+ val assms = map (mk_trp o mk_defined) xs;
+ val concl = mk_trp (mk_eq (sel ` con_app, nth vs n));
+ val goal = Logic.list_implies (assms, concl);
+ in
+ prove thy defs goal (K tacs)
+ end;
+ fun one_diff (n, sel, T) =
+ let
+ val goal = mk_trp (mk_eq (sel ` con_app, mk_bottom T));
+ in
+ prove thy defs goal (K tacs)
+ end;
+ fun one_con (j, (_, args')) : thm list =
+ let
+ fun prep (i, (lazy, NONE, T)) = NONE
+ | prep (i, (lazy, SOME sel, T)) = SOME (i, sel, T);
+ val sels : (int * term * typ) list =
+ map_filter prep (map_index I args');
+ in
+ if i = j
+ then map one_same sels
+ else map one_diff sels
+ end
+ in
+ flat (map_index one_con spec2)
+ end
+ in
+ flat (map_index sel_apps_of spec2)
+ end
+
+ (* prove selector definedness rules *)
+ val sel_defins : thm list =
+ let
+ val rules = rep_strict_iff :: @{thms sel_defined_iff_rules};
+ val tacs = [simp_tac (HOL_basic_ss addsimps rules) 1];
+ fun sel_defin sel =
+ let
+ val (T, U) = dest_cfunT (fastype_of sel);
+ val x = Free ("x", T);
+ val lhs = mk_eq (sel ` x, mk_bottom U);
+ val rhs = mk_eq (x, mk_bottom T);
+ val goal = mk_trp (mk_eq (lhs, rhs));
+ in
+ prove thy sel_defs goal (K tacs)
+ end
+ fun one_arg (false, SOME sel, T) = SOME (sel_defin sel)
+ | one_arg _ = NONE;
+ in
+ case spec2 of
+ [(con, args)] => map_filter one_arg args
+ | _ => []
+ end;
+
+ in
+ (sel_stricts @ sel_defins @ sel_apps, thy)
+ end
+
+(******************************************************************************)
+(************ definitions and theorems for discriminator functions ************)
+(******************************************************************************)
+
+fun add_discriminators
+ (bindings : binding list)
+ (spec : (term * (bool * typ) list) list)
+ (lhsT : typ)
+ (casedist : thm)
+ (case_const : typ -> term)
+ (case_rews : thm list)
+ (thy : theory) =
+ let
+
+ fun vars_of args =
+ let
+ val Ts = map snd args;
+ val ns = Datatype_Prop.make_tnames Ts;
+ in
+ map Free (ns ~~ Ts)
+ end;
+
+ (* define discriminator functions *)
+ local
+ fun dis_fun i (j, (con, args)) =
+ let
+ val (vs, nonlazy) = get_vars args;
+ val tr = if i = j then @{term TT} else @{term FF};
+ in
+ big_lambdas vs tr
+ end;
+ fun dis_eqn (i, bind) : binding * term * mixfix =
+ let
+ val dis_bind = Binding.prefix_name "is_" bind;
+ val rhs = list_ccomb (case_const trT, map_index (dis_fun i) spec);
+ in
+ (dis_bind, rhs, NoSyn)
+ end;
+ in
+ val ((dis_consts, dis_defs), thy) =
+ define_consts (map_index dis_eqn bindings) thy
+ end;
+
+ (* prove discriminator strictness rules *)
+ local
+ fun dis_strict dis =
+ let val goal = mk_trp (mk_strict dis);
+ in prove thy dis_defs goal (K [rtac (hd case_rews) 1]) end;
+ in
+ val dis_stricts = map dis_strict dis_consts;
+ end;
+
+ (* prove discriminator/constructor rules *)
+ local
+ fun dis_app (i, dis) (j, (con, args)) =
+ let
+ val (vs, nonlazy) = get_vars args;
+ val lhs = dis ` list_ccomb (con, vs);
+ val rhs = if i = j then @{term TT} else @{term FF};
+ val assms = map (mk_trp o mk_defined) nonlazy;
+ val concl = mk_trp (mk_eq (lhs, rhs));
+ val goal = Logic.list_implies (assms, concl);
+ val tacs = [asm_simp_tac (beta_ss addsimps case_rews) 1];
+ in prove thy dis_defs goal (K tacs) end;
+ fun one_dis (i, dis) =
+ map_index (dis_app (i, dis)) spec;
+ in
+ val dis_apps = flat (map_index one_dis dis_consts);
+ end;
+
+ (* prove discriminator definedness rules *)
+ local
+ fun dis_defin dis =
+ let
+ val x = Free ("x", lhsT);
+ val simps = dis_apps @ @{thms dist_eq_tr};
+ val tacs =
+ [rtac @{thm iffI} 1,
+ asm_simp_tac (HOL_basic_ss addsimps dis_stricts) 2,
+ rtac casedist 1, atac 1,
+ DETERM_UNTIL_SOLVED (CHANGED
+ (asm_full_simp_tac (simple_ss addsimps simps) 1))];
+ val goal = mk_trp (mk_eq (mk_undef (dis ` x), mk_undef x));
+ in prove thy [] goal (K tacs) end;
+ in
+ val dis_defins = map dis_defin dis_consts;
+ end;
+
+ in
+ (dis_stricts @ dis_defins @ dis_apps, thy)
+ end;
+
+(******************************************************************************)
+(*************** definitions and theorems for match combinators ***************)
+(******************************************************************************)
+
+fun add_match_combinators
+ (bindings : binding list)
+ (spec : (term * (bool * typ) list) list)
+ (lhsT : typ)
+ (casedist : thm)
+ (case_const : typ -> term)
+ (case_rews : thm list)
+ (thy : theory) =
+ let
+
+ (* get a fresh type variable for the result type *)
+ val resultT : typ =
+ let
+ val ts : string list = map (fst o dest_TFree) (snd (dest_Type lhsT));
+ val t : string = Name.variant ts "'t";
+ in TFree (t, @{sort pcpo}) end;
+
+ (* define match combinators *)
+ local
+ val x = Free ("x", lhsT);
+ fun k args = Free ("k", map snd args -->> mk_matchT resultT);
+ val fail = mk_fail resultT;
+ fun mat_fun i (j, (con, args)) =
+ let
+ val (vs, nonlazy) = get_vars_avoiding ["x","k"] args;
+ in
+ if i = j then k args else big_lambdas vs fail
+ end;
+ fun mat_eqn (i, (bind, (con, args))) : binding * term * mixfix =
+ let
+ val mat_bind = Binding.prefix_name "match_" bind;
+ val funs = map_index (mat_fun i) spec
+ val body = list_ccomb (case_const (mk_matchT resultT), funs);
+ val rhs = big_lambda x (big_lambda (k args) (body ` x));
+ in
+ (mat_bind, rhs, NoSyn)
+ end;
+ in
+ val ((match_consts, match_defs), thy) =
+ define_consts (map_index mat_eqn (bindings ~~ spec)) thy
+ end;
+
+ (* register match combinators with fixrec package *)
+ local
+ val con_names = map (fst o dest_Const o fst) spec;
+ val mat_names = map (fst o dest_Const) match_consts;
+ in
+ val thy = Fixrec.add_matchers (con_names ~~ mat_names) thy;
+ end;
+
+ (* prove strictness of match combinators *)
+ local
+ fun match_strict mat =
+ let
+ val (T, (U, V)) = apsnd dest_cfunT (dest_cfunT (fastype_of mat));
+ val k = Free ("k", U);
+ val goal = mk_trp (mk_eq (mat ` mk_bottom T ` k, mk_bottom V));
+ val tacs = [asm_simp_tac (beta_ss addsimps case_rews) 1];
+ in prove thy match_defs goal (K tacs) end;
+ in
+ val match_stricts = map match_strict match_consts;
+ end;
+
+ (* prove match/constructor rules *)
+ local
+ val fail = mk_fail resultT;
+ fun match_app (i, mat) (j, (con, args)) =
+ let
+ val (vs, nonlazy) = get_vars_avoiding ["k"] args;
+ val (_, (kT, _)) = apsnd dest_cfunT (dest_cfunT (fastype_of mat));
+ val k = Free ("k", kT);
+ val lhs = mat ` list_ccomb (con, vs) ` k;
+ val rhs = if i = j then list_ccomb (k, vs) else fail;
+ val assms = map (mk_trp o mk_defined) nonlazy;
+ val concl = mk_trp (mk_eq (lhs, rhs));
+ val goal = Logic.list_implies (assms, concl);
+ val tacs = [asm_simp_tac (beta_ss addsimps case_rews) 1];
+ in prove thy match_defs goal (K tacs) end;
+ fun one_match (i, mat) =
+ map_index (match_app (i, mat)) spec;
+ in
+ val match_apps = flat (map_index one_match match_consts);
+ end;
+
+ in
+ (match_stricts @ match_apps, thy)
+ end;
+
+(******************************************************************************)
+(************** definitions and theorems for pattern combinators **************)
+(******************************************************************************)
+
+fun add_pattern_combinators
+ (bindings : binding list)
+ (spec : (term * (bool * typ) list) list)
+ (lhsT : typ)
+ (casedist : thm)
+ (case_const : typ -> term)
+ (case_rews : thm list)
+ (thy : theory) =
+ let
+
+ (* utility functions *)
+ fun mk_pair_pat (p1, p2) =
+ let
+ val T1 = fastype_of p1;
+ val T2 = fastype_of p2;
+ val (U1, V1) = apsnd dest_matchT (dest_cfunT T1);
+ val (U2, V2) = apsnd dest_matchT (dest_cfunT T2);
+ val pat_typ = [T1, T2] --->
+ (mk_prodT (U1, U2) ->> mk_matchT (mk_prodT (V1, V2)));
+ val pat_const = Const (@{const_name cpair_pat}, pat_typ);
+ in
+ pat_const $ p1 $ p2
+ end;
+ fun mk_tuple_pat [] = return_const HOLogic.unitT
+ | mk_tuple_pat ps = foldr1 mk_pair_pat ps;
+ fun branch_const (T,U,V) =
+ Const (@{const_name branch},
+ (T ->> mk_matchT U) --> (U ->> V) ->> T ->> mk_matchT V);
+
+ (* define pattern combinators *)
+ local
+ val tns = map (fst o dest_TFree) (snd (dest_Type lhsT));
+
+ fun pat_eqn (i, (bind, (con, args))) : binding * term * mixfix =
+ let
+ val pat_bind = Binding.suffix_name "_pat" bind;
+ val Ts = map snd args;
+ val Vs =
+ (map (K "'t") args)
+ |> Datatype_Prop.indexify_names
+ |> Name.variant_list tns
+ |> map (fn t => TFree (t, @{sort pcpo}));
+ val patNs = Datatype_Prop.indexify_names (map (K "pat") args);
+ val patTs = map2 (fn T => fn V => T ->> mk_matchT V) Ts Vs;
+ val pats = map Free (patNs ~~ patTs);
+ val fail = mk_fail (mk_tupleT Vs);
+ val (vs, nonlazy) = get_vars_avoiding patNs args;
+ val rhs = big_lambdas vs (mk_tuple_pat pats ` mk_tuple vs);
+ fun one_fun (j, (_, args')) =
+ let
+ val (vs', nonlazy) = get_vars_avoiding patNs args';
+ in if i = j then rhs else big_lambdas vs' fail end;
+ val funs = map_index one_fun spec;
+ val body = list_ccomb (case_const (mk_matchT (mk_tupleT Vs)), funs);
+ in
+ (pat_bind, lambdas pats body, NoSyn)
+ end;
+ in
+ val ((pat_consts, pat_defs), thy) =
+ define_consts (map_index pat_eqn (bindings ~~ spec)) thy
+ end;
+
+ (* syntax translations for pattern combinators *)
+ local
+ open Syntax
+ fun syntax c = Syntax.mark_const (fst (dest_Const c));
+ fun app s (l, r) = Syntax.mk_appl (Constant s) [l, r];
+ val capp = app @{const_syntax Rep_CFun};
+ val capps = Library.foldl capp
+
+ fun app_var x = Syntax.mk_appl (Constant "_variable") [x, Variable "rhs"];
+ fun app_pat x = Syntax.mk_appl (Constant "_pat") [x];
+ fun args_list [] = Constant "_noargs"
+ | args_list xs = foldr1 (app "_args") xs;
+ fun one_case_trans (pat, (con, args)) =
+ let
+ val cname = Constant (syntax con);
+ val pname = Constant (syntax pat);
+ val ns = 1 upto length args;
+ val xs = map (fn n => Variable ("x"^(string_of_int n))) ns;
+ val ps = map (fn n => Variable ("p"^(string_of_int n))) ns;
+ val vs = map (fn n => Variable ("v"^(string_of_int n))) ns;
+ in
+ [ParseRule (app_pat (capps (cname, xs)),
+ mk_appl pname (map app_pat xs)),
+ ParseRule (app_var (capps (cname, xs)),
+ app_var (args_list xs)),
+ PrintRule (capps (cname, ListPair.map (app "_match") (ps,vs)),
+ app "_match" (mk_appl pname ps, args_list vs))]
+ end;
+ val trans_rules : Syntax.ast Syntax.trrule list =
+ maps one_case_trans (pat_consts ~~ spec);
+ in
+ val thy = Sign.add_trrules_i trans_rules thy;
+ end;
+
+ (* prove strictness and reduction rules of pattern combinators *)
+ local
+ val tns = map (fst o dest_TFree) (snd (dest_Type lhsT));
+ val rn = Name.variant tns "'r";
+ val R = TFree (rn, @{sort pcpo});
+ fun pat_lhs (pat, args) =
+ let
+ val Ts = map snd args;
+ val Vs =
+ (map (K "'t") args)
+ |> Datatype_Prop.indexify_names
+ |> Name.variant_list (rn::tns)
+ |> map (fn t => TFree (t, @{sort pcpo}));
+ val patNs = Datatype_Prop.indexify_names (map (K "pat") args);
+ val patTs = map2 (fn T => fn V => T ->> mk_matchT V) Ts Vs;
+ val pats = map Free (patNs ~~ patTs);
+ val k = Free ("rhs", mk_tupleT Vs ->> R);
+ val branch1 = branch_const (lhsT, mk_tupleT Vs, R);
+ val fun1 = (branch1 $ list_comb (pat, pats)) ` k;
+ val branch2 = branch_const (mk_tupleT Ts, mk_tupleT Vs, R);
+ val fun2 = (branch2 $ mk_tuple_pat pats) ` k;
+ val taken = "rhs" :: patNs;
+ in (fun1, fun2, taken) end;
+ fun pat_strict (pat, (con, args)) =
+ let
+ val (fun1, fun2, taken) = pat_lhs (pat, args);
+ val defs = @{thm branch_def} :: pat_defs;
+ val goal = mk_trp (mk_strict fun1);
+ val rules = @{thm Fixrec.bind_strict} :: case_rews;
+ val tacs = [simp_tac (beta_ss addsimps rules) 1];
+ in prove thy defs goal (K tacs) end;
+ fun pat_apps (i, (pat, (con, args))) =
+ let
+ val (fun1, fun2, taken) = pat_lhs (pat, args);
+ fun pat_app (j, (con', args')) =
+ let
+ val (vs, nonlazy) = get_vars_avoiding taken args';
+ val con_app = list_ccomb (con', vs);
+ val assms = map (mk_trp o mk_defined) nonlazy;
+ val rhs = if i = j then fun2 ` mk_tuple vs else mk_fail R;
+ val concl = mk_trp (mk_eq (fun1 ` con_app, rhs));
+ val goal = Logic.list_implies (assms, concl);
+ val defs = @{thm branch_def} :: pat_defs;
+ val rules = @{thms bind_fail left_unit} @ case_rews;
+ val tacs = [asm_simp_tac (beta_ss addsimps rules) 1];
+ in prove thy defs goal (K tacs) end;
+ in map_index pat_app spec end;
+ in
+ val pat_stricts = map pat_strict (pat_consts ~~ spec);
+ val pat_apps = flat (map_index pat_apps (pat_consts ~~ spec));
+ end;
+
+ in
+ (pat_stricts @ pat_apps, thy)
+ end
+
+(******************************************************************************)
+(******************************* main function ********************************)
+(******************************************************************************)
+
+fun add_domain_constructors
+ (dname : string)
+ (spec : (binding * (bool * binding option * typ) list * mixfix) list)
+ (iso_info : Domain_Take_Proofs.iso_info)
+ (thy : theory) =
+ let
+
+ (* retrieve facts about rep/abs *)
+ val lhsT = #absT iso_info;
+ val {rep_const, abs_const, ...} = iso_info;
+ val abs_iso_thm = #abs_inverse iso_info;
+ val rep_iso_thm = #rep_inverse iso_info;
+ val iso_locale = @{thm iso.intro} OF [abs_iso_thm, rep_iso_thm];
+ val rep_strict = iso_locale RS @{thm iso.rep_strict};
+ val abs_strict = iso_locale RS @{thm iso.abs_strict};
+ val rep_defined_iff = iso_locale RS @{thm iso.rep_defined_iff};
+ val abs_defined_iff = iso_locale RS @{thm iso.abs_defined_iff};
+
+ (* qualify constants and theorems with domain name *)
+ val thy = Sign.add_path dname thy;
+
+ (* define constructor functions *)
+ val (con_result, thy) =
+ let
+ fun prep_arg (lazy, sel, T) = (lazy, T);
+ fun prep_con (b, args, mx) = (b, map prep_arg args, mx);
+ val con_spec = map prep_con spec;
+ in
+ add_constructors con_spec abs_const iso_locale thy
+ end;
+ val {con_consts, con_betas, casedist, ...} = con_result;
+
+ (* define case combinator *)
+ val ((case_const : typ -> term, cases : thm list), thy) =
+ let
+ fun prep_arg (lazy, sel, T) = (lazy, T);
+ fun prep_con c (b, args, mx) = (c, map prep_arg args);
+ val case_spec = map2 prep_con con_consts spec;
+ in
+ add_case_combinator case_spec lhsT dname
+ con_betas casedist iso_locale rep_const thy
+ end;
+
+ (* define and prove theorems for selector functions *)
+ val (sel_thms : thm list, thy : theory) =
+ let
+ val sel_spec : (term * (bool * binding option * typ) list) list =
+ map2 (fn con => fn (b, args, mx) => (con, args)) con_consts spec;
+ in
+ add_selectors sel_spec rep_const
+ abs_iso_thm rep_strict rep_defined_iff con_betas thy
+ end;
+
+ (* define and prove theorems for discriminator functions *)
+ val (dis_thms : thm list, thy : theory) =
+ let
+ val bindings = map #1 spec;
+ fun prep_arg (lazy, sel, T) = (lazy, T);
+ fun prep_con c (b, args, mx) = (c, map prep_arg args);
+ val dis_spec = map2 prep_con con_consts spec;
+ in
+ add_discriminators bindings dis_spec lhsT
+ casedist case_const cases thy
+ end
+
+ (* define and prove theorems for match combinators *)
+ val (match_thms : thm list, thy : theory) =
+ let
+ val bindings = map #1 spec;
+ fun prep_arg (lazy, sel, T) = (lazy, T);
+ fun prep_con c (b, args, mx) = (c, map prep_arg args);
+ val mat_spec = map2 prep_con con_consts spec;
+ in
+ add_match_combinators bindings mat_spec lhsT
+ casedist case_const cases thy
+ end
+
+ (* define and prove theorems for pattern combinators *)
+ val (pat_thms : thm list, thy : theory) =
+ let
+ val bindings = map #1 spec;
+ fun prep_arg (lazy, sel, T) = (lazy, T);
+ fun prep_con c (b, args, mx) = (c, map prep_arg args);
+ val pat_spec = map2 prep_con con_consts spec;
+ in
+ add_pattern_combinators bindings pat_spec lhsT
+ casedist case_const cases thy
+ end
+
+ (* restore original signature path *)
+ val thy = Sign.parent_path thy;
+
+ val result =
+ { con_consts = con_consts,
+ con_betas = con_betas,
+ exhaust = #exhaust con_result,
+ casedist = casedist,
+ con_compacts = #con_compacts con_result,
+ con_rews = #con_rews con_result,
+ inverts = #inverts con_result,
+ injects = #injects con_result,
+ dist_les = #dist_les con_result,
+ dist_eqs = #dist_eqs con_result,
+ cases = cases,
+ sel_rews = sel_thms,
+ dis_rews = dis_thms,
+ match_rews = match_thms,
+ pat_rews = pat_thms };
+ in
+ (result, thy)
+ end;
+
+end;
--- a/src/HOLCF/Tools/Domain/domain_extender.ML Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOLCF/Tools/Domain/domain_extender.ML Wed Mar 03 16:43:55 2010 +0100
@@ -79,7 +79,9 @@
| rm_sorts (Type(s,ts)) = Type(s,remove_sorts ts)
| rm_sorts (TVar(s,_)) = TVar(s,[])
and remove_sorts l = map rm_sorts l;
- val indirect_ok = ["*","Cfun.->","Ssum.++","Sprod.**","Up.u"]
+ val indirect_ok =
+ [@{type_name "*"}, @{type_name cfun}, @{type_name ssum},
+ @{type_name sprod}, @{type_name u}];
fun analyse indirect (TFree(v,s)) =
(case AList.lookup (op =) tvars v of
NONE => error ("Free type variable " ^ quote v ^ " on rhs.")
@@ -127,52 +129,68 @@
(comp_dnam : string)
(eqs''' : ((string * string option) list * binding * mixfix *
(binding * (bool * binding option * 'a) list * mixfix) list) list)
- (thy''' : theory) =
+ (thy : theory) =
let
- fun readS (SOME s) = Syntax.read_sort_global thy''' s
- | readS NONE = Sign.defaultS thy''';
- fun readTFree (a, s) = TFree (a, readS s);
+ val dtnvs : (binding * typ list * mixfix) list =
+ let
+ fun readS (SOME s) = Syntax.read_sort_global thy s
+ | readS NONE = Sign.defaultS thy;
+ fun readTFree (a, s) = TFree (a, readS s);
+ in
+ map (fn (vs,dname:binding,mx,_) =>
+ (dname, map readTFree vs, mx)) eqs'''
+ end;
- val dtnvs = map (fn (vs,dname:binding,mx,_) =>
- (dname, map readTFree vs, mx)) eqs''';
- val cons''' = map (fn (_,_,_,cons) => cons) eqs''';
- fun thy_type (dname,tvars,mx) = (dname, length tvars, mx);
- fun thy_arity (dname,tvars,mx) =
- (Sign.full_name thy''' dname, map (snd o dest_TFree) tvars, pcpoS);
- val thy'' =
- thy'''
- |> Sign.add_types (map thy_type dtnvs)
- |> fold (AxClass.axiomatize_arity o thy_arity) dtnvs;
- val cons'' =
- map (map (upd_second (map (upd_third (prep_typ thy''))))) cons''';
- val dtnvs' =
- map (fn (dname,vs,mx) => (Sign.full_name thy''' dname,vs)) dtnvs;
+ (* declare new types *)
+ val thy =
+ let
+ fun thy_type (dname,tvars,mx) = (dname, length tvars, mx);
+ fun thy_arity (dname,tvars,mx) =
+ (Sign.full_name thy dname, map (snd o dest_TFree) tvars, pcpoS);
+ in
+ thy
+ |> Sign.add_types (map thy_type dtnvs)
+ |> fold (AxClass.axiomatize_arity o thy_arity) dtnvs
+ end;
+
+ val dbinds : binding list =
+ map (fn (_,dbind,_,_) => dbind) eqs''';
+ val cons''' :
+ (binding * (bool * binding option * 'a) list * mixfix) list list =
+ map (fn (_,_,_,cons) => cons) eqs''';
+ val cons'' :
+ (binding * (bool * binding option * typ) list * mixfix) list list =
+ map (map (upd_second (map (upd_third (prep_typ thy))))) cons''';
+ val dtnvs' : (string * typ list) list =
+ map (fn (dname,vs,mx) => (Sign.full_name thy dname,vs)) dtnvs;
val eqs' : ((string * typ list) *
(binding * (bool * binding option * typ) list * mixfix) list) list =
- check_and_sort_domain false dtnvs' cons'' thy'';
- val thy' = thy'' |> Domain_Syntax.add_syntax false comp_dnam eqs';
- val dts = map (Type o fst) eqs';
- val new_dts = map (fn ((s,Ts),_) => (s, map (fst o dest_TFree) Ts)) eqs';
- fun strip ss = drop (find_index (fn s => s = "'") ss + 1) ss;
- fun typid (Type (id,_)) =
- let val c = hd (Symbol.explode (Long_Name.base_name id))
- in if Symbol.is_letter c then c else "t" end
- | typid (TFree (id,_) ) = hd (strip (tl (Symbol.explode id)))
- | typid (TVar ((id,_),_)) = hd (tl (Symbol.explode id));
- fun one_con (con,args,mx) =
+ check_and_sort_domain false dtnvs' cons'' thy;
+(* val thy = Domain_Syntax.add_syntax eqs' thy; *)
+ val dts : typ list = map (Type o fst) eqs';
+ val new_dts : (string * string list) list =
+ map (fn ((s,Ts),_) => (s, map (fst o dest_TFree) Ts)) eqs';
+ fun one_con (con,args,mx) : cons =
(Binding.name_of con, (* FIXME preverse binding (!?) *)
- mx,
ListPair.map (fn ((lazy,sel,tp),vn) =>
- mk_arg ((lazy, Datatype_Aux.dtyp_of_typ new_dts tp),
- Option.map Binding.name_of sel,vn))
- (args,(mk_var_names(map (typid o third) args)))
- ) : cons;
+ mk_arg ((lazy, Datatype_Aux.dtyp_of_typ new_dts tp), vn))
+ (args, Datatype_Prop.make_tnames (map third args)));
val eqs : eq list =
map (fn (dtnvs,cons') => (dtnvs, map one_con cons')) eqs';
- val thy = thy' |> Domain_Axioms.add_axioms false comp_dnam eqs;
+
+ fun mk_arg_typ (lazy, dest_opt, T) = if lazy then mk_uT T else T;
+ fun mk_con_typ (bind, args, mx) =
+ if null args then oneT else foldr1 mk_sprodT (map mk_arg_typ args);
+ fun mk_eq_typ (_, cons) = foldr1 mk_ssumT (map mk_con_typ cons);
+ val repTs : typ list = map mk_eq_typ eqs';
+ val dom_eqns : (binding * (typ * typ)) list = dbinds ~~ (dts ~~ repTs);
+ val thy = Domain_Axioms.add_axioms dom_eqns thy;
+
val ((rewss, take_rews), theorems_thy) =
thy
- |> fold_map (fn eq => Domain_Theorems.theorems (eq, eqs)) eqs
+ |> fold_map (fn (eq, (x,cs)) =>
+ Domain_Theorems.theorems (eq, eqs) (Type x, cs))
+ (eqs ~~ eqs')
||>> Domain_Theorems.comp_theorems (comp_dnam, eqs);
in
theorems_thy
@@ -188,67 +206,67 @@
(comp_dnam : string)
(eqs''' : ((string * string option) list * binding * mixfix *
(binding * (bool * binding option * 'a) list * mixfix) list) list)
- (thy''' : theory) =
+ (thy : theory) =
let
- fun readS (SOME s) = Syntax.read_sort_global thy''' s
- | readS NONE = Sign.defaultS thy''';
- fun readTFree (a, s) = TFree (a, readS s);
+ val dtnvs : (binding * typ list * mixfix) list =
+ let
+ fun readS (SOME s) = Syntax.read_sort_global thy s
+ | readS NONE = Sign.defaultS thy;
+ fun readTFree (a, s) = TFree (a, readS s);
+ in
+ map (fn (vs,dname:binding,mx,_) =>
+ (dname, map readTFree vs, mx)) eqs'''
+ end;
- val dtnvs = map (fn (vs,dname:binding,mx,_) =>
- (dname, map readTFree vs, mx)) eqs''';
- val cons''' = map (fn (_,_,_,cons) => cons) eqs''';
fun thy_type (dname,tvars,mx) = (dname, length tvars, mx);
fun thy_arity (dname,tvars,mx) =
- (Sign.full_name thy''' dname, map (snd o dest_TFree) tvars, @{sort rep});
+ (Sign.full_name thy dname, map (snd o dest_TFree) tvars, @{sort rep});
(* this theory is used just for parsing and error checking *)
- val tmp_thy = thy'''
+ val tmp_thy = thy
|> Theory.copy
|> Sign.add_types (map thy_type dtnvs)
|> fold (AxClass.axiomatize_arity o thy_arity) dtnvs;
- val cons'' : (binding * (bool * binding option * typ) list * mixfix) list list =
- map (map (upd_second (map (upd_third (prep_typ tmp_thy))))) cons''';
+ val cons''' :
+ (binding * (bool * binding option * 'a) list * mixfix) list list =
+ map (fn (_,_,_,cons) => cons) eqs''';
+ val cons'' :
+ (binding * (bool * binding option * typ) list * mixfix) list list =
+ map (map (upd_second (map (upd_third (prep_typ tmp_thy))))) cons''';
val dtnvs' : (string * typ list) list =
- map (fn (dname,vs,mx) => (Sign.full_name thy''' dname,vs)) dtnvs;
+ map (fn (dname,vs,mx) => (Sign.full_name thy dname,vs)) dtnvs;
val eqs' : ((string * typ list) *
(binding * (bool * binding option * typ) list * mixfix) list) list =
- check_and_sort_domain true dtnvs' cons'' tmp_thy;
+ check_and_sort_domain true dtnvs' cons'' tmp_thy;
fun mk_arg_typ (lazy, dest_opt, T) = if lazy then mk_uT T else T;
fun mk_con_typ (bind, args, mx) =
if null args then oneT else foldr1 mk_sprodT (map mk_arg_typ args);
fun mk_eq_typ (_, cons) = foldr1 mk_ssumT (map mk_con_typ cons);
- val thy'' = thy''' |>
+ val (iso_infos, thy) = thy |>
Domain_Isomorphism.domain_isomorphism
(map (fn ((vs, dname, mx, _), eq) =>
(map fst vs, dname, mx, mk_eq_typ eq, NONE))
(eqs''' ~~ eqs'))
- val thy' = thy'' |> Domain_Syntax.add_syntax true comp_dnam eqs';
- val dts = map (Type o fst) eqs';
- val new_dts = map (fn ((s,Ts),_) => (s, map (fst o dest_TFree) Ts)) eqs';
- fun strip ss = drop (find_index (fn s => s = "'") ss + 1) ss;
- fun typid (Type (id,_)) =
- let val c = hd (Symbol.explode (Long_Name.base_name id))
- in if Symbol.is_letter c then c else "t" end
- | typid (TFree (id,_) ) = hd (strip (tl (Symbol.explode id)))
- | typid (TVar ((id,_),_)) = hd (tl (Symbol.explode id));
- fun one_con (con,args,mx) =
+ val dts : typ list = map (Type o fst) eqs';
+ val new_dts : (string * string list) list =
+ map (fn ((s,Ts),_) => (s, map (fst o dest_TFree) Ts)) eqs';
+ fun one_con (con,args,mx) : cons =
(Binding.name_of con, (* FIXME preverse binding (!?) *)
- mx,
ListPair.map (fn ((lazy,sel,tp),vn) =>
- mk_arg ((lazy, Datatype_Aux.dtyp_of_typ new_dts tp),
- Option.map Binding.name_of sel,vn))
- (args,(mk_var_names(map (typid o third) args)))
- ) : cons;
+ mk_arg ((lazy, Datatype_Aux.dtyp_of_typ new_dts tp), vn))
+ (args, Datatype_Prop.make_tnames (map third args))
+ );
val eqs : eq list =
map (fn (dtnvs,cons') => (dtnvs, map one_con cons')) eqs';
- val thy = thy' |> Domain_Axioms.add_axioms true comp_dnam eqs;
val ((rewss, take_rews), theorems_thy) =
thy
- |> fold_map (fn eq => Domain_Theorems.theorems (eq, eqs)) eqs
+ |> fold_map (fn (eq, (x,cs)) =>
+ Domain_Theorems.theorems (eq, eqs) (Type x, cs))
+ (eqs ~~ eqs')
||>> Domain_Theorems.comp_theorems (comp_dnam, eqs);
in
theorems_thy
--- a/src/HOLCF/Tools/Domain/domain_isomorphism.ML Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOLCF/Tools/Domain/domain_isomorphism.ML Wed Mar 03 16:43:55 2010 +0100
@@ -6,19 +6,17 @@
signature DOMAIN_ISOMORPHISM =
sig
- val domain_isomorphism:
+ val domain_isomorphism :
(string list * binding * mixfix * typ * (binding * binding) option) list
- -> theory -> theory
- val domain_isomorphism_cmd:
+ -> theory -> Domain_Take_Proofs.iso_info list * theory
+ val domain_isomorphism_cmd :
(string list * binding * mixfix * string * (binding * binding) option) list
-> theory -> theory
- val add_type_constructor:
- (string * term * string * thm * thm * thm) -> theory -> theory
- val get_map_tab:
- theory -> string Symtab.table
+ val add_type_constructor :
+ (string * term * string * thm * thm * thm * thm) -> theory -> theory
end;
-structure Domain_Isomorphism :> DOMAIN_ISOMORPHISM =
+structure Domain_Isomorphism : DOMAIN_ISOMORPHISM =
struct
val beta_ss =
@@ -35,30 +33,16 @@
structure DeflData = Theory_Data
(
+ (* terms like "foo_defl" *)
type T = term Symtab.table;
val empty = Symtab.empty;
val extend = I;
fun merge data = Symtab.merge (K true) data;
);
-structure MapData = Theory_Data
-(
- type T = string Symtab.table;
- val empty = Symtab.empty;
- val extend = I;
- fun merge data = Symtab.merge (K true) data;
-);
-
structure RepData = Theory_Data
(
- type T = thm list;
- val empty = [];
- val extend = I;
- val merge = Thm.merge_thms;
-);
-
-structure IsodeflData = Theory_Data
-(
+ (* theorems like "REP('a foo) = foo_defl$REP('a)" *)
type T = thm list;
val empty = [];
val extend = I;
@@ -67,6 +51,16 @@
structure MapIdData = Theory_Data
(
+ (* theorems like "foo_map$ID = ID" *)
+ type T = thm list;
+ val empty = [];
+ val extend = I;
+ val merge = Thm.merge_thms;
+);
+
+structure IsodeflData = Theory_Data
+(
+ (* theorems like "isodefl d t ==> isodefl (foo_map$d) (foo_defl$t)" *)
type T = thm list;
val empty = [];
val extend = I;
@@ -74,108 +68,32 @@
);
fun add_type_constructor
- (tname, defl_const, map_name, REP_thm, isodefl_thm, map_ID_thm) =
+ (tname, defl_const, map_name, REP_thm,
+ isodefl_thm, map_ID_thm, defl_map_thm) =
DeflData.map (Symtab.insert (K true) (tname, defl_const))
- #> MapData.map (Symtab.insert (K true) (tname, map_name))
+ #> Domain_Take_Proofs.add_map_function (tname, map_name, defl_map_thm)
#> RepData.map (Thm.add_thm REP_thm)
#> IsodeflData.map (Thm.add_thm isodefl_thm)
#> MapIdData.map (Thm.add_thm map_ID_thm);
-val get_map_tab = MapData.get;
+
+(* val get_map_tab = MapData.get; *)
(******************************************************************************)
-(******************************* building types *******************************)
+(************************** building types and terms **************************)
(******************************************************************************)
-(* ->> is taken from holcf_logic.ML *)
-fun cfunT (T, U) = Type(@{type_name "->"}, [T, U]);
-
-infixr 6 ->>; val (op ->>) = cfunT;
+open HOLCF_Library;
-fun dest_cfunT (Type(@{type_name "->"}, [T, U])) = (T, U)
- | dest_cfunT T = raise TYPE ("dest_cfunT", [T], []);
-
-fun tupleT [] = HOLogic.unitT
- | tupleT [T] = T
- | tupleT (T :: Ts) = HOLogic.mk_prodT (T, tupleT Ts);
+infixr 6 ->>;
+infix -->>;
val deflT = @{typ "udom alg_defl"};
fun mapT (T as Type (_, Ts)) =
- Library.foldr cfunT (map (fn T => T ->> T) Ts, T ->> T);
-
-(******************************************************************************)
-(******************************* building terms *******************************)
-(******************************************************************************)
-
-(* builds the expression (v1,v2,..,vn) *)
-fun mk_tuple [] = HOLogic.unit
-| mk_tuple (t::[]) = t
-| mk_tuple (t::ts) = HOLogic.mk_prod (t, mk_tuple ts);
-
-(* builds the expression (%(v1,v2,..,vn). rhs) *)
-fun lambda_tuple [] rhs = Term.lambda (Free("unit", HOLogic.unitT)) rhs
- | lambda_tuple (v::[]) rhs = Term.lambda v rhs
- | lambda_tuple (v::vs) rhs =
- HOLogic.mk_split (Term.lambda v (lambda_tuple vs rhs));
-
-(* continuous application and abstraction *)
-
-fun capply_const (S, T) =
- Const(@{const_name Rep_CFun}, (S ->> T) --> (S --> T));
-
-fun cabs_const (S, T) =
- Const(@{const_name Abs_CFun}, (S --> T) --> (S ->> T));
-
-fun mk_cabs t =
- let val T = Term.fastype_of t
- in cabs_const (Term.domain_type T, Term.range_type T) $ t end
-
-(* builds the expression (LAM v. rhs) *)
-fun big_lambda v rhs =
- cabs_const (Term.fastype_of v, Term.fastype_of rhs) $ Term.lambda v rhs;
-
-(* builds the expression (LAM v1 v2 .. vn. rhs) *)
-fun big_lambdas [] rhs = rhs
- | big_lambdas (v::vs) rhs = big_lambda v (big_lambdas vs rhs);
-
-fun mk_capply (t, u) =
- let val (S, T) =
- case Term.fastype_of t of
- Type(@{type_name "->"}, [S, T]) => (S, T)
- | _ => raise TERM ("mk_capply " ^ ML_Syntax.print_list ML_Syntax.print_term [t, u], [t, u]);
- in capply_const (S, T) $ t $ u end;
-
-(* miscellaneous term constructions *)
-
-val mk_trp = HOLogic.mk_Trueprop;
-
-val mk_fst = HOLogic.mk_fst;
-val mk_snd = HOLogic.mk_snd;
-
-fun mk_cont t =
- let val T = Term.fastype_of t
- in Const(@{const_name cont}, T --> HOLogic.boolT) $ t end;
-
-fun mk_fix t =
- let val (T, _) = dest_cfunT (Term.fastype_of t)
- in mk_capply (Const(@{const_name fix}, (T ->> T) ->> T), t) end;
-
-fun ID_const T = Const (@{const_name ID}, cfunT (T, T));
-
-fun cfcomp_const (T, U, V) =
- Const (@{const_name cfcomp}, (U ->> V) ->> (T ->> U) ->> (T ->> V));
-
-fun mk_cfcomp (f, g) =
- let
- val (U, V) = dest_cfunT (Term.fastype_of f);
- val (T, U') = dest_cfunT (Term.fastype_of g);
- in
- if U = U'
- then mk_capply (mk_capply (cfcomp_const (T, U, V), f), g)
- else raise TYPE ("mk_cfcomp", [U, U'], [f, g])
- end;
+ (map (fn T => T ->> T) Ts) -->> (T ->> T)
+ | mapT T = T ->> T;
fun mk_Rep_of T =
Const (@{const_name Rep_of}, Term.itselfT T --> deflT) $ Logic.mk_type T;
@@ -185,12 +103,39 @@
fun isodefl_const T =
Const (@{const_name isodefl}, (T ->> T) --> deflT --> HOLogic.boolT);
+fun mk_deflation t =
+ Const (@{const_name deflation}, Term.fastype_of t --> boolT) $ t;
+
+fun mk_lub t =
+ let
+ val T = Term.range_type (Term.fastype_of t);
+ val lub_const = Const (@{const_name lub}, (T --> boolT) --> T);
+ val UNIV_const = @{term "UNIV :: nat set"};
+ val image_type = (natT --> T) --> (natT --> boolT) --> T --> boolT;
+ val image_const = Const (@{const_name image}, image_type);
+ in
+ lub_const $ (image_const $ t $ UNIV_const)
+ end;
+
(* splits a cterm into the right and lefthand sides of equality *)
fun dest_eqs t = HOLogic.dest_eq (HOLogic.dest_Trueprop t);
fun mk_eqs (t, u) = HOLogic.mk_Trueprop (HOLogic.mk_eq (t, u));
(******************************************************************************)
+(****************************** isomorphism info ******************************)
+(******************************************************************************)
+
+fun deflation_abs_rep (info : Domain_Take_Proofs.iso_info) : thm =
+ let
+ val abs_iso = #abs_inverse info;
+ val rep_iso = #rep_inverse info;
+ val thm = @{thm deflation_abs_rep} OF [abs_iso, rep_iso];
+ in
+ Drule.export_without_context thm
+ end
+
+(******************************************************************************)
(*************** fixed-point definitions and unfolding theorems ***************)
(******************************************************************************)
@@ -204,7 +149,8 @@
val fixpoint = mk_fix (mk_cabs functional);
(* project components of fixpoint *)
- fun mk_projs (x::[]) t = [(x, t)]
+ fun mk_projs [] t = []
+ | mk_projs (x::[]) t = [(x, t)]
| mk_projs (x::xs) t = (x, mk_fst t) :: mk_projs xs (mk_snd t);
val projs = mk_projs lhss fixpoint;
@@ -272,31 +218,41 @@
| defl_of (TVar _) = error ("defl_of_typ: TVar")
| defl_of (T as Type (c, Ts)) =
case Symtab.lookup tab c of
- SOME t => Library.foldl mk_capply (t, map defl_of Ts)
+ SOME t => list_ccomb (t, map defl_of Ts)
| NONE => if is_closed_typ T
then mk_Rep_of T
else error ("defl_of_typ: type variable under unsupported type constructor " ^ c);
in defl_of T end;
-fun map_of_typ
- (tab : string Symtab.table)
- (T : typ) : term =
- let
- fun is_closed_typ (Type (_, Ts)) = forall is_closed_typ Ts
- | is_closed_typ _ = false;
- fun map_of (T as TFree (a, _)) = Free (Library.unprefix "'" a, T ->> T)
- | map_of (T as TVar _) = error ("map_of_typ: TVar")
- | map_of (T as Type (c, Ts)) =
- case Symtab.lookup tab c of
- SOME t => Library.foldl mk_capply (Const (t, mapT T), map map_of Ts)
- | NONE => if is_closed_typ T
- then ID_const T
- else error ("map_of_typ: type variable under unsupported type constructor " ^ c);
- in map_of T end;
-
(******************************************************************************)
-(* prepare datatype specifications *)
+(********************* declaring definitions and theorems *********************)
+(******************************************************************************)
+
+fun define_const
+ (bind : binding, rhs : term)
+ (thy : theory)
+ : (term * thm) * theory =
+ let
+ val typ = Term.fastype_of rhs;
+ val (const, thy) = Sign.declare_const ((bind, typ), NoSyn) thy;
+ val eqn = Logic.mk_equals (const, rhs);
+ val def = Thm.no_attributes (Binding.suffix_name "_def" bind, eqn);
+ val (def_thm, thy) = yield_singleton (PureThy.add_defs false) def thy;
+ in
+ ((const, def_thm), thy)
+ end;
+
+fun add_qualified_thm name (path, thm) thy =
+ thy
+ |> Sign.add_path path
+ |> yield_singleton PureThy.add_thms
+ (Thm.no_attributes (Binding.name name, thm))
+ ||> Sign.parent_path;
+
+(******************************************************************************)
+(******************************* main function ********************************)
+(******************************************************************************)
fun read_typ thy str sorts =
let
@@ -320,7 +276,7 @@
(prep_typ: theory -> 'a -> (string * sort) list -> typ * (string * sort) list)
(doms_raw: (string list * binding * mixfix * 'a * (binding * binding) option) list)
(thy: theory)
- : theory =
+ : Domain_Take_Proofs.iso_info list * theory =
let
val _ = Theory.requires thy "Representable" "domain isomorphisms";
@@ -345,7 +301,7 @@
val dom_eqns = map mk_dom_eqn doms;
(* check for valid type parameters *)
- val (tyvars, _, _, _, _)::_ = doms;
+ val (tyvars, _, _, _, _) = hd doms;
val new_doms = map (fn (tvs, tname, mx, _, _) =>
let val full_tname = Sign.full_name tmp_thy tname
in
@@ -362,7 +318,7 @@
(* declare deflation combinator constants *)
fun declare_defl_const (vs, tbind, mx, rhs, morphs) thy =
let
- val defl_type = Library.foldr cfunT (map (K deflT) vs, deflT);
+ val defl_type = map (K deflT) vs -->> deflT;
val defl_bind = Binding.suffix_name "_defl" tbind;
in
Sign.declare_const ((defl_bind, defl_type), NoSyn) thy
@@ -390,7 +346,7 @@
let
fun tfree a = TFree (a, the (AList.lookup (op =) sorts a))
val reps = map (mk_Rep_of o tfree) vs;
- val defl = Library.foldl mk_capply (defl_const, reps);
+ val defl = list_ccomb (defl_const, reps);
val ((_, _, _, {REP, ...}), thy) =
Repdef.add_repdef false NONE (tbind, vs, mx) defl NONE thy;
in
@@ -421,21 +377,12 @@
(* define rep/abs functions *)
fun mk_rep_abs ((tbind, morphs), (lhsT, rhsT)) thy =
let
- val rep_type = cfunT (lhsT, rhsT);
- val abs_type = cfunT (rhsT, lhsT);
val rep_bind = Binding.suffix_name "_rep" tbind;
val abs_bind = Binding.suffix_name "_abs" tbind;
- val (rep_bind, abs_bind) = the_default (rep_bind, abs_bind) morphs;
- val (rep_const, thy) = thy |>
- Sign.declare_const ((rep_bind, rep_type), NoSyn);
- val (abs_const, thy) = thy |>
- Sign.declare_const ((abs_bind, abs_type), NoSyn);
- val rep_eqn = Logic.mk_equals (rep_const, coerce_const rep_type);
- val abs_eqn = Logic.mk_equals (abs_const, coerce_const abs_type);
- val ([rep_def, abs_def], thy) = thy |>
- (PureThy.add_defs false o map Thm.no_attributes)
- [(Binding.suffix_name "_rep_def" tbind, rep_eqn),
- (Binding.suffix_name "_abs_def" tbind, abs_eqn)];
+ val ((rep_const, rep_def), thy) =
+ define_const (rep_bind, coerce_const (lhsT ->> rhsT)) thy;
+ val ((abs_const, abs_def), thy) =
+ define_const (abs_bind, coerce_const (rhsT ->> lhsT)) thy;
in
(((rep_const, abs_const), (rep_def, abs_def)), thy)
end;
@@ -463,10 +410,27 @@
in
(((rep_iso_thm, abs_iso_thm), isodefl_thm), thy)
end;
- val ((iso_thms, isodefl_abs_rep_thms), thy) = thy
+ val ((iso_thms, isodefl_abs_rep_thms), thy) =
+ thy
|> fold_map mk_iso_thms (dom_binds ~~ REP_eq_thms ~~ rep_abs_defs)
|>> ListPair.unzip;
+ (* collect info about rep/abs *)
+ val iso_infos : Domain_Take_Proofs.iso_info list =
+ let
+ fun mk_info (((lhsT, rhsT), (repC, absC)), (rep_iso, abs_iso)) =
+ {
+ repT = rhsT,
+ absT = lhsT,
+ rep_const = repC,
+ abs_const = absC,
+ rep_inverse = rep_iso,
+ abs_inverse = abs_iso
+ };
+ in
+ map mk_info (dom_eqns ~~ rep_abs_consts ~~ iso_thms)
+ end
+
(* declare map functions *)
fun declare_map_const (tbind, (lhsT, rhsT)) thy =
let
@@ -479,19 +443,24 @@
fold_map declare_map_const (dom_binds ~~ dom_eqns);
(* defining equations for map functions *)
- val map_tab1 = MapData.get thy;
- val map_tab2 =
- Symtab.make (map (fst o dest_Type o fst) dom_eqns
- ~~ map (fst o dest_Const) map_consts);
- val map_tab' = Symtab.merge (K true) (map_tab1, map_tab2);
- val thy = MapData.put map_tab' thy;
- fun mk_map_spec ((rep_const, abs_const), (lhsT, rhsT)) =
- let
- val lhs = map_of_typ map_tab' lhsT;
- val body = map_of_typ map_tab' rhsT;
- val rhs = mk_cfcomp (abs_const, mk_cfcomp (body, rep_const));
- in mk_eqs (lhs, rhs) end;
- val map_specs = map mk_map_spec (rep_abs_consts ~~ dom_eqns);
+ local
+ fun unprime a = Library.unprefix "'" a;
+ fun mapvar T = Free (unprime (fst (dest_TFree T)), T ->> T);
+ fun map_lhs (map_const, lhsT) =
+ (lhsT, list_ccomb (map_const, map mapvar (snd (dest_Type lhsT))));
+ val tab1 = map map_lhs (map_consts ~~ map fst dom_eqns);
+ val Ts = (snd o dest_Type o fst o hd) dom_eqns;
+ val tab = (Ts ~~ map mapvar Ts) @ tab1;
+ fun mk_map_spec (((rep_const, abs_const), map_const), (lhsT, rhsT)) =
+ let
+ val lhs = Domain_Take_Proofs.map_of_typ thy tab lhsT;
+ val body = Domain_Take_Proofs.map_of_typ thy tab rhsT;
+ val rhs = mk_cfcomp (abs_const, mk_cfcomp (body, rep_const));
+ in mk_eqs (lhs, rhs) end;
+ in
+ val map_specs =
+ map mk_map_spec (rep_abs_consts ~~ map_consts ~~ dom_eqns);
+ end;
(* register recursive definition of map functions *)
val map_binds = map (Binding.suffix_name "_map") dom_binds;
@@ -502,13 +471,14 @@
val isodefl_thm =
let
fun unprime a = Library.unprefix "'" a;
- fun mk_d (TFree (a, _)) = Free ("d" ^ unprime a, deflT);
- fun mk_f (T as TFree (a, _)) = Free ("f" ^ unprime a, T ->> T);
+ fun mk_d T = Free ("d" ^ unprime (fst (dest_TFree T)), deflT);
+ fun mk_f T = Free ("f" ^ unprime (fst (dest_TFree T)), T ->> T);
fun mk_assm T = mk_trp (isodefl_const T $ mk_f T $ mk_d T);
- fun mk_goal ((map_const, defl_const), (T as Type (c, Ts), rhsT)) =
+ fun mk_goal ((map_const, defl_const), (T, rhsT)) =
let
- val map_term = Library.foldl mk_capply (map_const, map mk_f Ts);
- val defl_term = Library.foldl mk_capply (defl_const, map mk_d Ts);
+ val (_, Ts) = dest_Type T;
+ val map_term = list_ccomb (map_const, map mk_f Ts);
+ val defl_term = list_ccomb (defl_const, map mk_d Ts);
in isodefl_const T $ map_term $ defl_term end;
val assms = (map mk_assm o snd o dest_Type o fst o hd) dom_eqns;
val goals = map mk_goal (map_consts ~~ defl_consts ~~ dom_eqns);
@@ -554,8 +524,8 @@
(((map_const, (lhsT, _)), REP_thm), isodefl_thm) =
let
val Ts = snd (dest_Type lhsT);
- val lhs = Library.foldl mk_capply (map_const, map ID_const Ts);
- val goal = mk_eqs (lhs, ID_const lhsT);
+ val lhs = list_ccomb (map_const, map mk_ID Ts);
+ val goal = mk_eqs (lhs, mk_ID lhsT);
val tac = EVERY
[rtac @{thm isodefl_REP_imp_ID} 1,
stac REP_thm 1,
@@ -573,121 +543,122 @@
(map_ID_binds ~~ map_ID_thms);
val thy = MapIdData.map (fold Thm.add_thm map_ID_thms) thy;
- (* define copy combinators *)
- val new_dts =
- map (apsnd (map (fst o dest_TFree)) o dest_Type o fst) dom_eqns;
- val copy_arg_type = tupleT (map (fn (T, _) => T ->> T) dom_eqns);
- val copy_arg = Free ("f", copy_arg_type);
- val copy_args =
- let fun mk_copy_args [] t = []
- | mk_copy_args (_::[]) t = [t]
- | mk_copy_args (_::xs) t =
- mk_fst t :: mk_copy_args xs (mk_snd t);
- in mk_copy_args doms copy_arg end;
- fun copy_of_dtyp (T, dt) =
- if Datatype_Aux.is_rec_type dt
- then copy_of_dtyp' (T, dt)
- else ID_const T
- and copy_of_dtyp' (T, Datatype_Aux.DtRec i) = nth copy_args i
- | copy_of_dtyp' (T, Datatype_Aux.DtTFree a) = ID_const T
- | copy_of_dtyp' (T as Type (_, Ts), Datatype_Aux.DtType (c, ds)) =
- case Symtab.lookup map_tab' c of
- SOME f =>
- Library.foldl mk_capply
- (Const (f, mapT T), map copy_of_dtyp (Ts ~~ ds))
- | NONE =>
- (warning ("copy_of_dtyp: unknown type constructor " ^ c); ID_const T);
- fun define_copy ((tbind, (rep_const, abs_const)), (lhsT, rhsT)) thy =
+ (* prove deflation theorems for map functions *)
+ val deflation_abs_rep_thms = map deflation_abs_rep iso_infos;
+ val deflation_map_thm =
let
- val copy_type = copy_arg_type ->> (lhsT ->> lhsT);
- val copy_bind = Binding.suffix_name "_copy" tbind;
- val (copy_const, thy) = thy |>
- Sign.declare_const ((copy_bind, copy_type), NoSyn);
- val dtyp = Datatype_Aux.dtyp_of_typ new_dts rhsT;
- val body = copy_of_dtyp (rhsT, dtyp);
- val comp = mk_cfcomp (abs_const, mk_cfcomp (body, rep_const));
- val rhs = big_lambda copy_arg comp;
- val eqn = Logic.mk_equals (copy_const, rhs);
- val ([copy_def], thy) =
- thy
- |> Sign.add_path (Binding.name_of tbind)
- |> (PureThy.add_defs false o map Thm.no_attributes)
- [(Binding.name "copy_def", eqn)]
- ||> Sign.parent_path;
- in ((copy_const, copy_def), thy) end;
- val ((copy_consts, copy_defs), thy) = thy
- |> fold_map define_copy (dom_binds ~~ rep_abs_consts ~~ dom_eqns)
- |>> ListPair.unzip;
+ fun unprime a = Library.unprefix "'" a;
+ fun mk_f T = Free (unprime (fst (dest_TFree T)), T ->> T);
+ fun mk_assm T = mk_trp (mk_deflation (mk_f T));
+ fun mk_goal (map_const, (lhsT, rhsT)) =
+ let
+ val (_, Ts) = dest_Type lhsT;
+ val map_term = list_ccomb (map_const, map mk_f Ts);
+ in mk_deflation map_term end;
+ val assms = (map mk_assm o snd o dest_Type o fst o hd) dom_eqns;
+ val goals = map mk_goal (map_consts ~~ dom_eqns);
+ val goal = mk_trp (foldr1 HOLogic.mk_conj goals);
+ val start_thms =
+ @{thm split_def} :: map_apply_thms;
+ val adm_rules =
+ @{thms adm_conj adm_subst [OF _ adm_deflation]
+ cont2cont_fst cont2cont_snd cont_id};
+ val bottom_rules =
+ @{thms fst_strict snd_strict deflation_UU simp_thms};
+ val deflation_rules =
+ @{thms conjI deflation_ID}
+ @ deflation_abs_rep_thms
+ @ Domain_Take_Proofs.get_deflation_thms thy;
+ in
+ Goal.prove_global thy [] assms goal (fn {prems, ...} =>
+ EVERY
+ [simp_tac (HOL_basic_ss addsimps start_thms) 1,
+ rtac @{thm fix_ind} 1,
+ REPEAT (resolve_tac adm_rules 1),
+ simp_tac (HOL_basic_ss addsimps bottom_rules) 1,
+ simp_tac beta_ss 1,
+ simp_tac (HOL_basic_ss addsimps @{thms fst_conv snd_conv}) 1,
+ REPEAT (etac @{thm conjE} 1),
+ REPEAT (resolve_tac (deflation_rules @ prems) 1 ORELSE atac 1)])
+ end;
+ val deflation_map_binds = dom_binds |>
+ map (Binding.prefix_name "deflation_" o Binding.suffix_name "_map");
+ val (deflation_map_thms, thy) = thy |>
+ (PureThy.add_thms o map (Thm.no_attributes o apsnd Drule.export_without_context))
+ (conjuncts deflation_map_binds deflation_map_thm);
- (* define combined copy combinator *)
- val ((c_const, c_def_thms), thy) =
- if length doms = 1
- then ((hd copy_consts, []), thy)
- else
- let
- val c_type = copy_arg_type ->> copy_arg_type;
- val c_name = space_implode "_" (map Binding.name_of dom_binds);
- val c_bind = Binding.name (c_name ^ "_copy");
- val c_body =
- mk_tuple (map (mk_capply o rpair copy_arg) copy_consts);
- val c_rhs = big_lambda copy_arg c_body;
- val (c_const, thy) =
- Sign.declare_const ((c_bind, c_type), NoSyn) thy;
- val c_eqn = Logic.mk_equals (c_const, c_rhs);
- val (c_def_thms, thy) =
- thy
- |> Sign.add_path c_name
- |> (PureThy.add_defs false o map Thm.no_attributes)
- [(Binding.name "copy_def", c_eqn)]
- ||> Sign.parent_path;
- in ((c_const, c_def_thms), thy) end;
+ (* register map functions in theory data *)
+ local
+ fun register_map ((dname, map_name), defl_thm) =
+ Domain_Take_Proofs.add_map_function (dname, map_name, defl_thm);
+ val dnames = map (fst o dest_Type o fst) dom_eqns;
+ val map_names = map (fst o dest_Const) map_consts;
+ in
+ val thy =
+ fold register_map (dnames ~~ map_names ~~ deflation_map_thms) thy;
+ end;
+
+ (* definitions and proofs related to take functions *)
+ val (take_info, thy) =
+ Domain_Take_Proofs.define_take_functions
+ (dom_binds ~~ iso_infos) thy;
+ val { take_consts, take_defs, chain_take_thms, take_0_thms,
+ take_Suc_thms, deflation_take_thms,
+ finite_consts, finite_defs } = take_info;
- (* fixed-point lemma for combined copy combinator *)
- val fix_copy_lemma =
+ (* least-upper-bound lemma for take functions *)
+ val lub_take_lemma =
let
- fun mk_map_ID (map_const, (Type (c, Ts), rhsT)) =
- Library.foldl mk_capply (map_const, map ID_const Ts);
+ val lhs = mk_tuple (map mk_lub take_consts);
+ fun mk_map_ID (map_const, (lhsT, rhsT)) =
+ list_ccomb (map_const, map mk_ID (snd (dest_Type lhsT)));
val rhs = mk_tuple (map mk_map_ID (map_consts ~~ dom_eqns));
- val goal = mk_eqs (mk_fix c_const, rhs);
- val rules =
- [@{thm pair_collapse}, @{thm split_def}]
- @ map_apply_thms
- @ c_def_thms @ copy_defs
- @ MapIdData.get thy;
- val tac = simp_tac (beta_ss addsimps rules) 1;
+ val goal = mk_trp (mk_eq (lhs, rhs));
+ val start_rules =
+ @{thms thelub_Pair [symmetric] ch2ch_Pair} @ chain_take_thms
+ @ @{thms pair_collapse split_def}
+ @ map_apply_thms @ MapIdData.get thy;
+ val rules0 =
+ @{thms iterate_0 Pair_strict} @ take_0_thms;
+ val rules1 =
+ @{thms iterate_Suc Pair_fst_snd_eq fst_conv snd_conv}
+ @ take_Suc_thms;
+ val tac =
+ EVERY
+ [simp_tac (HOL_basic_ss addsimps start_rules) 1,
+ simp_tac (HOL_basic_ss addsimps @{thms fix_def2}) 1,
+ rtac @{thm lub_eq} 1,
+ rtac @{thm nat.induct} 1,
+ simp_tac (HOL_basic_ss addsimps rules0) 1,
+ asm_full_simp_tac (beta_ss addsimps rules1) 1];
in
Goal.prove_global thy [] [] goal (K tac)
end;
- (* prove reach lemmas *)
- val reach_thm_projs =
- let fun mk_projs (x::[]) t = [(x, t)]
- | mk_projs (x::xs) t = (x, mk_fst t) :: mk_projs xs (mk_snd t);
- in mk_projs dom_binds (mk_fix c_const) end;
- fun prove_reach_thm (((bind, t), map_ID_thm), (lhsT, rhsT)) thy =
+ (* prove lub of take equals ID *)
+ fun prove_lub_take (((bind, take_const), map_ID_thm), (lhsT, rhsT)) thy =
let
- val x = Free ("x", lhsT);
- val goal = mk_eqs (mk_capply (t, x), x);
- val rules =
- fix_copy_lemma :: map_ID_thm :: @{thms fst_conv snd_conv ID1};
- val tac = simp_tac (HOL_basic_ss addsimps rules) 1;
- val reach_thm = Goal.prove_global thy [] [] goal (K tac);
+ val i = Free ("i", natT);
+ val goal = mk_eqs (mk_lub (lambda i (take_const $ i)), mk_ID lhsT);
+ val tac =
+ EVERY
+ [rtac @{thm trans} 1, rtac map_ID_thm 2,
+ cut_facts_tac [lub_take_lemma] 1,
+ REPEAT (etac @{thm Pair_inject} 1), atac 1];
+ val lub_take_thm = Goal.prove_global thy [] [] goal (K tac);
in
- thy
- |> Sign.add_path (Binding.name_of bind)
- |> yield_singleton (PureThy.add_thms o map Thm.no_attributes)
- (Binding.name "reach", reach_thm)
- ||> Sign.parent_path
+ add_qualified_thm "lub_take" (Binding.name_of bind, lub_take_thm) thy
end;
- val (reach_thms, thy) = thy |>
- fold_map prove_reach_thm (reach_thm_projs ~~ map_ID_thms ~~ dom_eqns);
+ val (lub_take_thms, thy) =
+ fold_map prove_lub_take
+ (dom_binds ~~ take_consts ~~ map_ID_thms ~~ dom_eqns) thy;
in
- thy
+ (iso_infos, thy)
end;
val domain_isomorphism = gen_domain_isomorphism cert_typ;
-val domain_isomorphism_cmd = gen_domain_isomorphism read_typ;
+val domain_isomorphism_cmd = snd oo gen_domain_isomorphism read_typ;
(******************************************************************************)
(******************************** outer syntax ********************************)
--- a/src/HOLCF/Tools/Domain/domain_library.ML Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOLCF/Tools/Domain/domain_library.ML Wed Mar 03 16:43:55 2010 +0100
@@ -5,36 +5,6 @@
*)
-(* ----- general support ---------------------------------------------------- *)
-
-fun mapn f n [] = []
- | mapn f n (x::xs) = (f n x) :: mapn f (n+1) xs;
-
-fun foldr'' f (l,f2) =
- let fun itr [] = raise Fail "foldr''"
- | itr [a] = f2 a
- | itr (a::l) = f(a, itr l)
- in itr l end;
-
-fun map_cumulr f start xs =
- List.foldr (fn (x,(ys,res))=>case f(x,res) of (y,res2) =>
- (y::ys,res2)) ([],start) xs;
-
-fun first (x,_,_) = x; fun second (_,x,_) = x; fun third (_,_,x) = x;
-fun upd_first f (x,y,z) = (f x, y, z);
-fun upd_second f (x,y,z) = ( x, f y, z);
-fun upd_third f (x,y,z) = ( x, y, f z);
-
-fun atomize ctxt thm =
- let
- val r_inst = read_instantiate ctxt;
- fun at thm =
- case concl_of thm of
- _$(Const("op &",_)$_$_) => at(thm RS conjunct1)@at(thm RS conjunct2)
- | _$(Const("All" ,_)$Abs(s,_,_))=> at(thm RS (r_inst [(("x", 0), "?" ^ s)] spec))
- | _ => [thm];
- in map zero_var_indexes (at thm) end;
-
(* infix syntax *)
infixr 5 -->;
@@ -44,8 +14,6 @@
infix 0 ==;
infix 1 ===;
infix 1 ~=;
-infix 1 <<;
-infix 1 ~<<;
infix 9 ` ;
infix 9 `% ;
@@ -56,19 +24,25 @@
signature DOMAIN_LIBRARY =
sig
+ val first : 'a * 'b * 'c -> 'a
+ val second : 'a * 'b * 'c -> 'b
+ val third : 'a * 'b * 'c -> 'c
+ val upd_second : ('b -> 'd) -> 'a * 'b * 'c -> 'a * 'd * 'c
+ val upd_third : ('c -> 'd) -> 'a * 'b * 'c -> 'a * 'b * 'd
+ val mapn : (int -> 'a -> 'b) -> int -> 'a list -> 'b list
+ val atomize : Proof.context -> thm -> thm list
+
val Imposs : string -> 'a;
val cpo_type : theory -> typ -> bool;
val pcpo_type : theory -> typ -> bool;
val string_of_typ : theory -> typ -> string;
(* Creating HOLCF types *)
- val mk_cfunT : typ * typ -> typ;
val ->> : typ * typ -> typ;
val mk_ssumT : typ * typ -> typ;
val mk_sprodT : typ * typ -> typ;
val mk_uT : typ -> typ;
val oneT : typ;
- val trT : typ;
val mk_maybeT : typ -> typ;
val mk_ctupleT : typ list -> typ;
val mk_TFree : string -> typ;
@@ -81,26 +55,17 @@
val `% : term * string -> term;
val /\ : string -> term -> term;
val UU : term;
- val TT : term;
- val FF : term;
val ID : term;
val oo : term * term -> term;
- val mk_up : term -> term;
- val mk_sinl : term -> term;
- val mk_sinr : term -> term;
- val mk_stuple : term list -> term;
val mk_ctuple : term list -> term;
val mk_fix : term -> term;
val mk_iterate : term * term * term -> term;
val mk_fail : term;
val mk_return : term -> term;
val list_ccomb : term * term list -> term;
- (*
- val con_app : string -> ('a * 'b * string) list -> term;
- *)
val con_app2 : string -> ('a -> term) -> 'a list -> term;
+ val prj : ('a -> 'b -> 'a) -> ('a -> 'b -> 'a) -> 'a -> 'b list -> int -> 'a
val proj : term -> 'a list -> int -> term;
- val prj : ('a -> 'b -> 'a) -> ('a -> 'b -> 'a) -> 'a -> 'b list -> int -> 'a;
val mk_ctuple_pat : term list -> term;
val mk_branch : term -> term;
@@ -111,15 +76,11 @@
val mk_lam : string * term -> term;
val mk_all : string * term -> term;
val mk_ex : string * term -> term;
- val mk_constrain : typ * term -> term;
val mk_constrainall : string * typ * term -> term;
val === : term * term -> term;
- val << : term * term -> term;
- val ~<< : term * term -> term;
val strict : term -> term;
val defined : term -> term;
val mk_adm : term -> term;
- val mk_compact : term -> term;
val lift : ('a -> term) -> 'a list * term -> term;
val lift_defined : ('a -> term) -> 'a list * term -> term;
@@ -132,13 +93,12 @@
(* Domain specifications *)
eqtype arg;
- type cons = string * mixfix * arg list;
+ type cons = string * arg list;
type eq = (string * typ list) * cons list;
- val mk_arg : (bool * Datatype.dtyp) * string option * string -> arg;
+ val mk_arg : (bool * Datatype.dtyp) * string -> arg;
val is_lazy : arg -> bool;
val rec_of : arg -> int;
val dtyp_of : arg -> Datatype.dtyp;
- val sel_of : arg -> string option;
val vname : arg -> string;
val upd_vname : (string -> string) -> arg -> arg;
val is_rec : arg -> bool;
@@ -147,8 +107,6 @@
val nonlazy_rec : arg list -> string list;
val %# : arg -> term;
val /\# : arg * term -> term;
- val when_body : cons list -> (int * int -> term) -> term;
- val when_funs : 'a list -> string list;
val bound_arg : ''a list -> ''a -> term; (* ''a = arg or string *)
val idx_name : 'a list -> string -> int -> string;
val app_rec_arg : (int -> term) -> arg -> term;
@@ -162,12 +120,38 @@
val dis_name : string -> string;
val mat_name : string -> string;
val pat_name : string -> string;
- val mk_var_names : string list -> string list;
end;
structure Domain_Library :> DOMAIN_LIBRARY =
struct
+fun first (x,_,_) = x;
+fun second (_,x,_) = x;
+fun third (_,_,x) = x;
+
+fun upd_first f (x,y,z) = (f x, y, z);
+fun upd_second f (x,y,z) = ( x, f y, z);
+fun upd_third f (x,y,z) = ( x, y, f z);
+
+fun mapn f n [] = []
+ | mapn f n (x::xs) = (f n x) :: mapn f (n+1) xs;
+
+fun foldr'' f (l,f2) =
+ let fun itr [] = raise Fail "foldr''"
+ | itr [a] = f2 a
+ | itr (a::l) = f(a, itr l)
+ in itr l end;
+
+fun atomize ctxt thm =
+ let
+ val r_inst = read_instantiate ctxt;
+ fun at thm =
+ case concl_of thm of
+ _$(Const("op &",_)$_$_) => at(thm RS conjunct1)@at(thm RS conjunct2)
+ | _$(Const("All" ,_)$Abs(s,_,_))=> at(thm RS (r_inst [(("x", 0), "?" ^ s)] spec))
+ | _ => [thm];
+ in map zero_var_indexes (at thm) end;
+
exception Impossible of string;
fun Imposs msg = raise Impossible ("Domain:"^msg);
@@ -191,22 +175,6 @@
fun pat_name con = (extern_name con) ^ "_pat";
fun pat_name_ con = (strip_esc con) ^ "_pat";
-(* make distinct names out of the type list,
- forbidding "o","n..","x..","f..","P.." as names *)
-(* a number string is added if necessary *)
-fun mk_var_names ids : string list =
- let
- fun nonreserved s = if s mem ["n","x","f","P"] then s^"'" else s;
- fun index_vnames(vn::vns,occupied) =
- (case AList.lookup (op =) occupied vn of
- NONE => if vn mem vns
- then (vn^"1") :: index_vnames(vns,(vn,1) ::occupied)
- else vn :: index_vnames(vns, occupied)
- | SOME(i) => (vn^(string_of_int (i+1)))
- :: index_vnames(vns,(vn,i+1)::occupied))
- | index_vnames([],occupied) = [];
- in index_vnames(map nonreserved ids, [("O",0),("o",0)]) end;
-
fun cpo_type sg t = Sign.of_sort sg (Sign.certify_typ sg t, @{sort cpo});
fun pcpo_type sg t = Sign.of_sort sg (Sign.certify_typ sg t, @{sort pcpo});
fun string_of_typ sg = Syntax.string_of_typ_global sg o Sign.certify_typ sg;
@@ -215,12 +183,10 @@
type arg =
(bool * Datatype.dtyp) * (* (lazy, recursive element) *)
- string option * (* selector name *)
string; (* argument name *)
type cons =
string * (* operator name of constr *)
- mixfix * (* mixfix syntax of constructor *)
arg list; (* argument list *)
type eq =
@@ -230,15 +196,14 @@
val mk_arg = I;
-fun rec_of ((_,dtyp),_,_) =
+fun rec_of ((_,dtyp),_) =
case dtyp of Datatype_Aux.DtRec i => i | _ => ~1;
(* FIXME: what about indirect recursion? *)
-fun is_lazy arg = fst (first arg);
-fun dtyp_of arg = snd (first arg);
-val sel_of = second;
-val vname = third;
-val upd_vname = upd_third;
+fun is_lazy arg = fst (fst arg);
+fun dtyp_of arg = snd (fst arg);
+val vname = snd;
+val upd_vname = apsnd;
fun is_rec arg = rec_of arg >=0;
fun is_nonlazy_rec arg = is_rec arg andalso not (is_lazy arg);
fun nonlazy args = map vname (filter_out is_lazy args);
@@ -248,8 +213,8 @@
(* ----- combinators for making dtyps ----- *)
fun mk_uD T = Datatype_Aux.DtType(@{type_name "u"}, [T]);
-fun mk_sprodD (T, U) = Datatype_Aux.DtType(@{type_name "**"}, [T, U]);
-fun mk_ssumD (T, U) = Datatype_Aux.DtType(@{type_name "++"}, [T, U]);
+fun mk_sprodD (T, U) = Datatype_Aux.DtType(@{type_name sprod}, [T, U]);
+fun mk_ssumD (T, U) = Datatype_Aux.DtType(@{type_name ssum}, [T, U]);
fun mk_liftD T = Datatype_Aux.DtType(@{type_name "lift"}, [T]);
val unitD = Datatype_Aux.DtType(@{type_name "unit"}, []);
val boolD = Datatype_Aux.DtType(@{type_name "bool"}, []);
@@ -258,19 +223,18 @@
fun big_sprodD ds = case ds of [] => oneD | _ => foldr1 mk_sprodD ds;
fun big_ssumD ds = case ds of [] => unitD | _ => foldr1 mk_ssumD ds;
-fun dtyp_of_arg ((lazy, D), _, _) = if lazy then mk_uD D else D;
-fun dtyp_of_cons (_, _, args) = big_sprodD (map dtyp_of_arg args);
+fun dtyp_of_arg ((lazy, D), _) = if lazy then mk_uD D else D;
+fun dtyp_of_cons (_, args) = big_sprodD (map dtyp_of_arg args);
fun dtyp_of_eq (_, cons) = big_ssumD (map dtyp_of_cons cons);
(* ----- support for type and mixfix expressions ----- *)
fun mk_uT T = Type(@{type_name "u"}, [T]);
-fun mk_cfunT (T, U) = Type(@{type_name "->"}, [T, U]);
-fun mk_sprodT (T, U) = Type(@{type_name "**"}, [T, U]);
-fun mk_ssumT (T, U) = Type(@{type_name "++"}, [T, U]);
+fun mk_cfunT (T, U) = Type(@{type_name cfun}, [T, U]);
+fun mk_sprodT (T, U) = Type(@{type_name sprod}, [T, U]);
+fun mk_ssumT (T, U) = Type(@{type_name ssum}, [T, U]);
val oneT = @{typ one};
-val trT = @{typ tr};
val op ->> = mk_cfunT;
@@ -290,7 +254,6 @@
fun mk_lam (x,T) = Abs(x,dummyT,T);
fun mk_all (x,P) = HOLogic.mk_all (x,dummyT,P);
fun mk_ex (x,P) = mk_exists (x,dummyT,P);
-val mk_constrain = uncurry TypeInfer.constrain;
fun mk_constrainall (x,typ,P) = %%:"All" $ (TypeInfer.constrain (typ --> boolT) (mk_lam(x,P)));
end
@@ -301,29 +264,18 @@
infix 0 ==; fun S == T = %%:"==" $ S $ T;
infix 1 ===; fun S === T = %%:"op =" $ S $ T;
infix 1 ~=; fun S ~= T = HOLogic.mk_not (S === T);
-infix 1 <<; fun S << T = %%: @{const_name Porder.below} $ S $ T;
-infix 1 ~<<; fun S ~<< T = HOLogic.mk_not (S << T);
infix 9 ` ; fun f ` x = %%: @{const_name Rep_CFun} $ f $ x;
infix 9 `% ; fun f`% s = f` %: s;
infix 9 `%%; fun f`%%s = f` %%:s;
fun mk_adm t = %%: @{const_name adm} $ t;
-fun mk_compact t = %%: @{const_name compact} $ t;
val ID = %%: @{const_name ID};
fun mk_strictify t = %%: @{const_name strictify}`t;
-(*val csplitN = "Cprod.csplit";*)
-(*val sfstN = "Sprod.sfst";*)
-(*val ssndN = "Sprod.ssnd";*)
fun mk_ssplit t = %%: @{const_name ssplit}`t;
-fun mk_sinl t = %%: @{const_name sinl}`t;
-fun mk_sinr t = %%: @{const_name sinr}`t;
fun mk_sscase (x, y) = %%: @{const_name sscase}`x`y;
-fun mk_up t = %%: @{const_name up}`t;
fun mk_fup (t,u) = %%: @{const_name fup} ` t ` u;
val ONE = @{term ONE};
-val TT = @{term TT};
-val FF = @{term FF};
fun mk_iterate (n,f,z) = %%: @{const_name iterate} $ n ` f ` z;
fun mk_fix t = %%: @{const_name fix}`t;
fun mk_return t = %%: @{const_name Fixrec.return}`t;
@@ -354,8 +306,6 @@
fun spair (t,u) = %%: @{const_name spair}`t`u;
fun mk_ctuple [] = HOLogic.unit (* used in match_defs *)
| mk_ctuple ts = foldr1 cpair ts;
-fun mk_stuple [] = ONE
- | mk_stuple ts = foldr1 spair ts;
fun mk_ctupleT [] = HOLogic.unitT (* used in match_defs *)
| mk_ctupleT Ts = foldr1 HOLogic.mk_prodT Ts;
fun mk_maybeT T = Type ("Fixrec.maybe",[T]);
@@ -374,23 +324,5 @@
| cont_eta_contract t = t;
fun idx_name dnames s n = s^(if length dnames = 1 then "" else string_of_int n);
-fun when_funs cons = if length cons = 1 then ["f"]
- else mapn (fn n => K("f"^(string_of_int n))) 1 cons;
-fun when_body cons funarg =
- let
- fun one_fun n (_,_,[] ) = /\ "dummy" (funarg(1,n))
- | one_fun n (_,_,args) = let
- val l2 = length args;
- fun idxs m arg = (if is_lazy arg then (fn t => mk_fup (ID, t))
- else I) (Bound(l2-m));
- in cont_eta_contract
- (foldr''
- (fn (a,t) => mk_ssplit (/\# (a,t)))
- (args,
- fn a=> /\#(a,(list_ccomb(funarg(l2,n),mapn idxs 1 args))))
- ) end;
- in (if length cons = 1 andalso length(third(hd cons)) <= 1
- then mk_strictify else I)
- (foldr1 mk_sscase (mapn one_fun 1 cons)) end;
end; (* struct *)
--- a/src/HOLCF/Tools/Domain/domain_syntax.ML Wed Mar 03 15:40:39 2010 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,210 +0,0 @@
-(* Title: HOLCF/Tools/Domain/domain_syntax.ML
- Author: David von Oheimb
-
-Syntax generator for domain command.
-*)
-
-signature DOMAIN_SYNTAX =
-sig
- val calc_syntax:
- theory ->
- bool ->
- typ ->
- (string * typ list) *
- (binding * (bool * binding option * typ) list * mixfix) list ->
- (binding * typ * mixfix) list * ast Syntax.trrule list
-
- val add_syntax:
- bool ->
- string ->
- ((string * typ list) *
- (binding * (bool * binding option * typ) list * mixfix) list) list ->
- theory -> theory
-end;
-
-
-structure Domain_Syntax :> DOMAIN_SYNTAX =
-struct
-
-open Domain_Library;
-infixr 5 -->; infixr 6 ->>;
-
-fun calc_syntax thy
- (definitional : bool)
- (dtypeprod : typ)
- ((dname : string, typevars : typ list),
- (cons': (binding * (bool * binding option * typ) list * mixfix) list))
- : (binding * typ * mixfix) list * ast Syntax.trrule list =
- let
-(* ----- constants concerning the isomorphism ------------------------------- *)
- local
- fun opt_lazy (lazy,_,t) = if lazy then mk_uT t else t
- fun prod (_,args,_) = case args of [] => oneT
- | _ => foldr1 mk_sprodT (map opt_lazy args);
- fun freetvar s = let val tvar = mk_TFree s in
- if tvar mem typevars then freetvar ("t"^s) else tvar end;
- fun when_type (_,args,_) = List.foldr (op ->>) (freetvar "t") (map third args);
- in
- val dtype = Type(dname,typevars);
- val dtype2 = foldr1 mk_ssumT (map prod cons');
- val dnam = Long_Name.base_name dname;
- fun dbind s = Binding.name (dnam ^ s);
- val const_rep = (dbind "_rep" , dtype ->> dtype2, NoSyn);
- val const_abs = (dbind "_abs" , dtype2 ->> dtype , NoSyn);
- val const_when = (dbind "_when", List.foldr (op ->>) (dtype ->> freetvar "t") (map when_type cons'), NoSyn);
- val const_copy = (dbind "_copy", dtypeprod ->> dtype ->> dtype , NoSyn);
- end;
-
-(* ----- constants concerning constructors, discriminators, and selectors --- *)
-
- local
- val escape = let
- fun esc (c::cs) = if c mem ["'","_","(",")","/"] then "'"::c::esc cs
- else c::esc cs
- | esc [] = []
- in implode o esc o Symbol.explode end;
-
- fun dis_name_ con =
- Binding.name ("is_" ^ strip_esc (Binding.name_of con));
- fun mat_name_ con =
- Binding.name ("match_" ^ strip_esc (Binding.name_of con));
- fun pat_name_ con =
- Binding.name (strip_esc (Binding.name_of con) ^ "_pat");
- fun con (name,args,mx) =
- (name, List.foldr (op ->>) dtype (map third args), mx);
- fun dis (con,args,mx) =
- (dis_name_ con, dtype->>trT,
- Mixfix(escape ("is_" ^ Binding.name_of con), [], Syntax.max_pri));
- (* strictly speaking, these constants have one argument,
- but the mixfix (without arguments) is introduced only
- to generate parse rules for non-alphanumeric names*)
- fun freetvar s n =
- let val tvar = mk_TFree (s ^ string_of_int n)
- in if tvar mem typevars then freetvar ("t"^s) n else tvar end;
-
- fun mk_matT (a,bs,c) =
- a ->> List.foldr (op ->>) (mk_maybeT c) bs ->> mk_maybeT c;
- fun mat (con,args,mx) =
- (mat_name_ con,
- mk_matT(dtype, map third args, freetvar "t" 1),
- Mixfix(escape ("match_" ^ Binding.name_of con), [], Syntax.max_pri));
- fun sel1 (_,sel,typ) =
- Option.map (fn s => (s,dtype ->> typ,NoSyn)) sel;
- fun sel (con,args,mx) = map_filter sel1 args;
- fun mk_patT (a,b) = a ->> mk_maybeT b;
- fun pat_arg_typ n arg = mk_patT (third arg, freetvar "t" n);
- fun pat (con,args,mx) =
- (pat_name_ con,
- (mapn pat_arg_typ 1 args)
- --->
- mk_patT (dtype, mk_ctupleT (map (freetvar "t") (1 upto length args))),
- Mixfix(escape (Binding.name_of con ^ "_pat"), [], Syntax.max_pri));
- in
- val consts_con = map con cons';
- val consts_dis = map dis cons';
- val consts_mat = map mat cons';
- val consts_pat = map pat cons';
- val consts_sel = maps sel cons';
- end;
-
-(* ----- constants concerning induction ------------------------------------- *)
-
- val const_take = (dbind "_take" , HOLogic.natT-->dtype->>dtype, NoSyn);
- val const_finite = (dbind "_finite", dtype-->HOLogic.boolT , NoSyn);
-
-(* ----- case translation --------------------------------------------------- *)
-
- fun syntax b = Syntax.mark_const (Sign.full_bname thy b);
-
- local open Syntax in
- local
- fun c_ast authentic con = Constant ((authentic ? syntax) (Binding.name_of con));
- fun expvar n = Variable ("e" ^ string_of_int n);
- fun argvar n m _ = Variable ("a" ^ string_of_int n ^ "_" ^ string_of_int m);
- fun argvars n args = mapn (argvar n) 1 args;
- fun app s (l, r) = mk_appl (Constant s) [l, r];
- val cabs = app "_cabs";
- val capp = app @{const_syntax Rep_CFun};
- fun con1 authentic n (con,args,mx) =
- Library.foldl capp (c_ast authentic con, argvars n args);
- fun case1 authentic n (con,args,mx) =
- app "_case1" (con1 authentic n (con,args,mx), expvar n);
- fun arg1 n (con,args,_) = List.foldr cabs (expvar n) (argvars n args);
- fun when1 n m = if n = m then arg1 n else K (Constant @{const_syntax UU});
-
- fun app_var x = mk_appl (Constant "_variable") [x, Variable "rhs"];
- fun app_pat x = mk_appl (Constant "_pat") [x];
- fun args_list [] = Constant "_noargs"
- | args_list xs = foldr1 (app "_args") xs;
- in
- fun case_trans authentic =
- ParsePrintRule
- (app "_case_syntax" (Variable "x", foldr1 (app "_case2") (mapn (case1 authentic) 1 cons')),
- capp (Library.foldl capp
- (Constant (syntax (dnam ^ "_when")), mapn arg1 1 cons'), Variable "x"));
-
- fun one_abscon_trans authentic n (con,mx,args) =
- ParsePrintRule
- (cabs (con1 authentic n (con,mx,args), expvar n),
- Library.foldl capp (Constant (syntax (dnam ^ "_when")), mapn (when1 n) 1 cons'));
- fun abscon_trans authentic = mapn (one_abscon_trans authentic) 1 cons';
-
- fun one_case_trans authentic (con,args,mx) =
- let
- val cname = c_ast authentic con;
- val pname = Constant (syntax (strip_esc (Binding.name_of con) ^ "_pat"));
- val ns = 1 upto length args;
- val xs = map (fn n => Variable ("x"^(string_of_int n))) ns;
- val ps = map (fn n => Variable ("p"^(string_of_int n))) ns;
- val vs = map (fn n => Variable ("v"^(string_of_int n))) ns;
- in
- [ParseRule (app_pat (Library.foldl capp (cname, xs)),
- mk_appl pname (map app_pat xs)),
- ParseRule (app_var (Library.foldl capp (cname, xs)),
- app_var (args_list xs)),
- PrintRule (Library.foldl capp (cname, ListPair.map (app "_match") (ps,vs)),
- app "_match" (mk_appl pname ps, args_list vs))]
- end;
- val Case_trans = maps (one_case_trans false) cons' @ maps (one_case_trans true) cons';
- end;
- end;
- val optional_consts =
- if definitional then [] else [const_rep, const_abs, const_copy];
-
- in (optional_consts @ [const_when] @
- consts_con @ consts_dis @ consts_mat @ consts_pat @ consts_sel @
- [const_take, const_finite],
- (case_trans false :: case_trans true :: (abscon_trans false @ abscon_trans true @ Case_trans)))
- end; (* let *)
-
-(* ----- putting all the syntax stuff together ------------------------------ *)
-
-fun add_syntax
- (definitional : bool)
- (comp_dnam : string)
- (eqs' : ((string * typ list) *
- (binding * (bool * binding option * typ) list * mixfix) list) list)
- (thy'' : theory) =
- let
- val dtypes = map (Type o fst) eqs';
- val boolT = HOLogic.boolT;
- val funprod =
- foldr1 HOLogic.mk_prodT (map (fn tp => tp ->> tp ) dtypes);
- val relprod =
- foldr1 HOLogic.mk_prodT (map (fn tp => tp --> tp --> boolT) dtypes);
- val const_copy =
- (Binding.name (comp_dnam^"_copy"), funprod ->> funprod, NoSyn);
- val const_bisim =
- (Binding.name (comp_dnam^"_bisim"), relprod --> boolT, NoSyn);
- val ctt : ((binding * typ * mixfix) list * ast Syntax.trrule list) list =
- map (calc_syntax thy'' definitional funprod) eqs';
- in thy''
- |> Cont_Consts.add_consts
- (maps fst ctt @
- (if length eqs'>1 andalso not definitional
- then [const_copy] else []) @
- [const_bisim])
- |> Sign.add_trrules_i (maps snd ctt)
- end; (* let *)
-
-end; (* struct *)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOLCF/Tools/Domain/domain_take_proofs.ML Wed Mar 03 16:43:55 2010 +0100
@@ -0,0 +1,421 @@
+(* Title: HOLCF/Tools/domain/domain_take_proofs.ML
+ Author: Brian Huffman
+
+Defines take functions for the given domain equation
+and proves related theorems.
+*)
+
+signature DOMAIN_TAKE_PROOFS =
+sig
+ type iso_info =
+ {
+ absT : typ,
+ repT : typ,
+ abs_const : term,
+ rep_const : term,
+ abs_inverse : thm,
+ rep_inverse : thm
+ }
+
+ val define_take_functions :
+ (binding * iso_info) list -> theory ->
+ { take_consts : term list,
+ take_defs : thm list,
+ chain_take_thms : thm list,
+ take_0_thms : thm list,
+ take_Suc_thms : thm list,
+ deflation_take_thms : thm list,
+ finite_consts : term list,
+ finite_defs : thm list
+ } * theory
+
+ val map_of_typ :
+ theory -> (typ * term) list -> typ -> term
+
+ val add_map_function :
+ (string * string * thm) -> theory -> theory
+
+ val get_map_tab : theory -> string Symtab.table
+ val get_deflation_thms : theory -> thm list
+end;
+
+structure Domain_Take_Proofs : DOMAIN_TAKE_PROOFS =
+struct
+
+type iso_info =
+ {
+ absT : typ,
+ repT : typ,
+ abs_const : term,
+ rep_const : term,
+ abs_inverse : thm,
+ rep_inverse : thm
+ };
+
+val beta_ss =
+ HOL_basic_ss
+ addsimps simp_thms
+ addsimps [@{thm beta_cfun}]
+ addsimprocs [@{simproc cont_proc}];
+
+val beta_tac = simp_tac beta_ss;
+
+(******************************************************************************)
+(******************************** theory data *********************************)
+(******************************************************************************)
+
+structure MapData = Theory_Data
+(
+ (* constant names like "foo_map" *)
+ type T = string Symtab.table;
+ val empty = Symtab.empty;
+ val extend = I;
+ fun merge data = Symtab.merge (K true) data;
+);
+
+structure DeflMapData = Theory_Data
+(
+ (* theorems like "deflation a ==> deflation (foo_map$a)" *)
+ type T = thm list;
+ val empty = [];
+ val extend = I;
+ val merge = Thm.merge_thms;
+);
+
+fun add_map_function (tname, map_name, deflation_map_thm) =
+ MapData.map (Symtab.insert (K true) (tname, map_name))
+ #> DeflMapData.map (Thm.add_thm deflation_map_thm);
+
+val get_map_tab = MapData.get;
+val get_deflation_thms = DeflMapData.get;
+
+(******************************************************************************)
+(************************** building types and terms **************************)
+(******************************************************************************)
+
+open HOLCF_Library;
+
+infixr 6 ->>;
+infix -->>;
+infix 9 `;
+
+val deflT = @{typ "udom alg_defl"};
+
+fun mapT (T as Type (_, Ts)) =
+ (map (fn T => T ->> T) Ts) -->> (T ->> T)
+ | mapT T = T ->> T;
+
+fun mk_Rep_of T =
+ Const (@{const_name Rep_of}, Term.itselfT T --> deflT) $ Logic.mk_type T;
+
+fun coerce_const T = Const (@{const_name coerce}, T);
+
+fun isodefl_const T =
+ Const (@{const_name isodefl}, (T ->> T) --> deflT --> HOLogic.boolT);
+
+fun mk_deflation t =
+ Const (@{const_name deflation}, Term.fastype_of t --> boolT) $ t;
+
+fun mk_lub t =
+ let
+ val T = Term.range_type (Term.fastype_of t);
+ val lub_const = Const (@{const_name lub}, (T --> boolT) --> T);
+ val UNIV_const = @{term "UNIV :: nat set"};
+ val image_type = (natT --> T) --> (natT --> boolT) --> T --> boolT;
+ val image_const = Const (@{const_name image}, image_type);
+ in
+ lub_const $ (image_const $ t $ UNIV_const)
+ end;
+
+(* splits a cterm into the right and lefthand sides of equality *)
+fun dest_eqs t = HOLogic.dest_eq (HOLogic.dest_Trueprop t);
+
+fun mk_eqs (t, u) = HOLogic.mk_Trueprop (HOLogic.mk_eq (t, u));
+
+(******************************************************************************)
+(****************************** isomorphism info ******************************)
+(******************************************************************************)
+
+fun deflation_abs_rep (info : iso_info) : thm =
+ let
+ val abs_iso = #abs_inverse info;
+ val rep_iso = #rep_inverse info;
+ val thm = @{thm deflation_abs_rep} OF [abs_iso, rep_iso];
+ in
+ Drule.export_without_context thm
+ end
+
+(******************************************************************************)
+(********************* building map functions over types **********************)
+(******************************************************************************)
+
+fun map_of_typ (thy : theory) (sub : (typ * term) list) (T : typ) : term =
+ let
+ val map_tab = get_map_tab thy;
+ fun auto T = T ->> T;
+ fun map_of T =
+ case AList.lookup (op =) sub T of
+ SOME m => (m, true) | NONE => map_of' T
+ and map_of' (T as (Type (c, Ts))) =
+ (case Symtab.lookup map_tab c of
+ SOME map_name =>
+ let
+ val map_type = map auto Ts -->> auto T;
+ val (ms, bs) = map_split map_of Ts;
+ in
+ if exists I bs
+ then (list_ccomb (Const (map_name, map_type), ms), true)
+ else (mk_ID T, false)
+ end
+ | NONE => (mk_ID T, false))
+ | map_of' T = (mk_ID T, false);
+ in
+ fst (map_of T)
+ end;
+
+
+(******************************************************************************)
+(********************* declaring definitions and theorems *********************)
+(******************************************************************************)
+
+fun define_const
+ (bind : binding, rhs : term)
+ (thy : theory)
+ : (term * thm) * theory =
+ let
+ val typ = Term.fastype_of rhs;
+ val (const, thy) = Sign.declare_const ((bind, typ), NoSyn) thy;
+ val eqn = Logic.mk_equals (const, rhs);
+ val def = Thm.no_attributes (Binding.suffix_name "_def" bind, eqn);
+ val (def_thm, thy) = yield_singleton (PureThy.add_defs false) def thy;
+ in
+ ((const, def_thm), thy)
+ end;
+
+fun add_qualified_thm name (path, thm) thy =
+ thy
+ |> Sign.add_path path
+ |> yield_singleton PureThy.add_thms
+ (Thm.no_attributes (Binding.name name, thm))
+ ||> Sign.parent_path;
+
+(******************************************************************************)
+(************************** defining take functions ***************************)
+(******************************************************************************)
+
+fun define_take_functions
+ (spec : (binding * iso_info) list)
+ (thy : theory) =
+ let
+
+ (* retrieve components of spec *)
+ val dom_binds = map fst spec;
+ val iso_infos = map snd spec;
+ val dom_eqns = map (fn x => (#absT x, #repT x)) iso_infos;
+ val rep_abs_consts = map (fn x => (#rep_const x, #abs_const x)) iso_infos;
+ val dnames = map Binding.name_of dom_binds;
+
+ (* get table of map functions *)
+ val map_tab = MapData.get thy;
+
+ fun mk_projs [] t = []
+ | mk_projs (x::[]) t = [(x, t)]
+ | mk_projs (x::xs) t = (x, mk_fst t) :: mk_projs xs (mk_snd t);
+
+ fun mk_cfcomp2 ((rep_const, abs_const), f) =
+ mk_cfcomp (abs_const, mk_cfcomp (f, rep_const));
+
+ (* define take functional *)
+ val newTs : typ list = map fst dom_eqns;
+ val copy_arg_type = mk_tupleT (map (fn T => T ->> T) newTs);
+ val copy_arg = Free ("f", copy_arg_type);
+ val copy_args = map snd (mk_projs dom_binds copy_arg);
+ fun one_copy_rhs (rep_abs, (lhsT, rhsT)) =
+ let
+ val body = map_of_typ thy (newTs ~~ copy_args) rhsT;
+ in
+ mk_cfcomp2 (rep_abs, body)
+ end;
+ val take_functional =
+ big_lambda copy_arg
+ (mk_tuple (map one_copy_rhs (rep_abs_consts ~~ dom_eqns)));
+ val take_rhss =
+ let
+ val i = Free ("i", HOLogic.natT);
+ val rhs = mk_iterate (i, take_functional)
+ in
+ map (Term.lambda i o snd) (mk_projs dom_binds rhs)
+ end;
+
+ (* define take constants *)
+ fun define_take_const ((tbind, take_rhs), (lhsT, rhsT)) thy =
+ let
+ val take_type = HOLogic.natT --> lhsT ->> lhsT;
+ val take_bind = Binding.suffix_name "_take" tbind;
+ val (take_const, thy) =
+ Sign.declare_const ((take_bind, take_type), NoSyn) thy;
+ val take_eqn = Logic.mk_equals (take_const, take_rhs);
+ val (take_def_thm, thy) =
+ thy
+ |> Sign.add_path (Binding.name_of tbind)
+ |> yield_singleton
+ (PureThy.add_defs false o map Thm.no_attributes)
+ (Binding.name "take_def", take_eqn)
+ ||> Sign.parent_path;
+ in ((take_const, take_def_thm), thy) end;
+ val ((take_consts, take_defs), thy) = thy
+ |> fold_map define_take_const (dom_binds ~~ take_rhss ~~ dom_eqns)
+ |>> ListPair.unzip;
+
+ (* prove chain_take lemmas *)
+ fun prove_chain_take (take_const, dname) thy =
+ let
+ val goal = mk_trp (mk_chain take_const);
+ val rules = take_defs @ @{thms chain_iterate ch2ch_fst ch2ch_snd};
+ val tac = simp_tac (HOL_basic_ss addsimps rules) 1;
+ val chain_take_thm = Goal.prove_global thy [] [] goal (K tac);
+ in
+ add_qualified_thm "chain_take" (dname, chain_take_thm) thy
+ end;
+ val (chain_take_thms, thy) =
+ fold_map prove_chain_take (take_consts ~~ dnames) thy;
+
+ (* prove take_0 lemmas *)
+ fun prove_take_0 ((take_const, dname), (lhsT, rhsT)) thy =
+ let
+ val lhs = take_const $ @{term "0::nat"};
+ val goal = mk_eqs (lhs, mk_bottom (lhsT ->> lhsT));
+ val rules = take_defs @ @{thms iterate_0 fst_strict snd_strict};
+ val tac = simp_tac (HOL_basic_ss addsimps rules) 1;
+ val take_0_thm = Goal.prove_global thy [] [] goal (K tac);
+ in
+ add_qualified_thm "take_0" (dname, take_0_thm) thy
+ end;
+ val (take_0_thms, thy) =
+ fold_map prove_take_0 (take_consts ~~ dnames ~~ dom_eqns) thy;
+
+ (* prove take_Suc lemmas *)
+ val i = Free ("i", natT);
+ val take_is = map (fn t => t $ i) take_consts;
+ fun prove_take_Suc
+ (((take_const, rep_abs), dname), (lhsT, rhsT)) thy =
+ let
+ val lhs = take_const $ (@{term Suc} $ i);
+ val body = map_of_typ thy (newTs ~~ take_is) rhsT;
+ val rhs = mk_cfcomp2 (rep_abs, body);
+ val goal = mk_eqs (lhs, rhs);
+ val simps = @{thms iterate_Suc fst_conv snd_conv}
+ val rules = take_defs @ simps;
+ val tac = simp_tac (beta_ss addsimps rules) 1;
+ val take_Suc_thm = Goal.prove_global thy [] [] goal (K tac);
+ in
+ add_qualified_thm "take_Suc" (dname, take_Suc_thm) thy
+ end;
+ val (take_Suc_thms, thy) =
+ fold_map prove_take_Suc
+ (take_consts ~~ rep_abs_consts ~~ dnames ~~ dom_eqns) thy;
+
+ (* prove deflation theorems for take functions *)
+ val deflation_abs_rep_thms = map deflation_abs_rep iso_infos;
+ val deflation_take_thm =
+ let
+ val i = Free ("i", natT);
+ fun mk_goal take_const = mk_deflation (take_const $ i);
+ val goal = mk_trp (foldr1 mk_conj (map mk_goal take_consts));
+ val adm_rules =
+ @{thms adm_conj adm_subst [OF _ adm_deflation]
+ cont2cont_fst cont2cont_snd cont_id};
+ val bottom_rules =
+ take_0_thms @ @{thms deflation_UU simp_thms};
+ val deflation_rules =
+ @{thms conjI deflation_ID}
+ @ deflation_abs_rep_thms
+ @ DeflMapData.get thy;
+ in
+ Goal.prove_global thy [] [] goal (fn _ =>
+ EVERY
+ [rtac @{thm nat.induct} 1,
+ simp_tac (HOL_basic_ss addsimps bottom_rules) 1,
+ asm_simp_tac (HOL_basic_ss addsimps take_Suc_thms) 1,
+ REPEAT (etac @{thm conjE} 1
+ ORELSE resolve_tac deflation_rules 1
+ ORELSE atac 1)])
+ end;
+ fun conjuncts [] thm = []
+ | conjuncts (n::[]) thm = [(n, thm)]
+ | conjuncts (n::ns) thm = let
+ val thmL = thm RS @{thm conjunct1};
+ val thmR = thm RS @{thm conjunct2};
+ in (n, thmL):: conjuncts ns thmR end;
+ val (deflation_take_thms, thy) =
+ fold_map (add_qualified_thm "deflation_take")
+ (map (apsnd Drule.export_without_context)
+ (conjuncts dnames deflation_take_thm)) thy;
+
+ (* prove strictness of take functions *)
+ fun prove_take_strict (take_const, dname) thy =
+ let
+ val goal = mk_trp (mk_strict (take_const $ Free ("i", natT)));
+ val tac = rtac @{thm deflation_strict} 1
+ THEN resolve_tac deflation_take_thms 1;
+ val take_strict_thm = Goal.prove_global thy [] [] goal (K tac);
+ in
+ add_qualified_thm "take_strict" (dname, take_strict_thm) thy
+ end;
+ val (take_strict_thms, thy) =
+ fold_map prove_take_strict (take_consts ~~ dnames) thy;
+
+ (* prove take/take rules *)
+ fun prove_take_take ((chain_take, deflation_take), dname) thy =
+ let
+ val take_take_thm =
+ @{thm deflation_chain_min} OF [chain_take, deflation_take];
+ in
+ add_qualified_thm "take_take" (dname, take_take_thm) thy
+ end;
+ val (take_take_thms, thy) =
+ fold_map prove_take_take
+ (chain_take_thms ~~ deflation_take_thms ~~ dnames) thy;
+
+ (* define finiteness predicates *)
+ fun define_finite_const ((tbind, take_const), (lhsT, rhsT)) thy =
+ let
+ val finite_type = lhsT --> boolT;
+ val finite_bind = Binding.suffix_name "_finite" tbind;
+ val (finite_const, thy) =
+ Sign.declare_const ((finite_bind, finite_type), NoSyn) thy;
+ val x = Free ("x", lhsT);
+ val i = Free ("i", natT);
+ val finite_rhs =
+ lambda x (HOLogic.exists_const natT $
+ (lambda i (mk_eq (mk_capply (take_const $ i, x), x))));
+ val finite_eqn = Logic.mk_equals (finite_const, finite_rhs);
+ val (finite_def_thm, thy) =
+ thy
+ |> Sign.add_path (Binding.name_of tbind)
+ |> yield_singleton
+ (PureThy.add_defs false o map Thm.no_attributes)
+ (Binding.name "finite_def", finite_eqn)
+ ||> Sign.parent_path;
+ in ((finite_const, finite_def_thm), thy) end;
+ val ((finite_consts, finite_defs), thy) = thy
+ |> fold_map define_finite_const (dom_binds ~~ take_consts ~~ dom_eqns)
+ |>> ListPair.unzip;
+
+ val result =
+ {
+ take_consts = take_consts,
+ take_defs = take_defs,
+ chain_take_thms = chain_take_thms,
+ take_0_thms = take_0_thms,
+ take_Suc_thms = take_Suc_thms,
+ deflation_take_thms = deflation_take_thms,
+ finite_consts = finite_consts,
+ finite_defs = finite_defs
+ };
+
+ in
+ (result, thy)
+ end;
+
+end;
--- a/src/HOLCF/Tools/Domain/domain_theorems.ML Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOLCF/Tools/Domain/domain_theorems.ML Wed Mar 03 16:43:55 2010 +0100
@@ -9,7 +9,11 @@
signature DOMAIN_THEOREMS =
sig
- val theorems: Domain_Library.eq * Domain_Library.eq list -> theory -> thm list * theory;
+ val theorems:
+ Domain_Library.eq * Domain_Library.eq list
+ -> typ * (binding * (bool * binding option * typ) list * mixfix) list
+ -> theory -> thm list * theory;
+
val comp_theorems: bstring * Domain_Library.eq list -> theory -> thm list * theory;
val quiet_mode: bool Unsynchronized.ref;
val trace_domain: bool Unsynchronized.ref;
@@ -28,20 +32,11 @@
val adm_all = @{thm adm_all};
val adm_conj = @{thm adm_conj};
val adm_subst = @{thm adm_subst};
-val antisym_less_inverse = @{thm below_antisym_inverse};
-val beta_cfun = @{thm beta_cfun};
-val cfun_arg_cong = @{thm cfun_arg_cong};
val ch2ch_fst = @{thm ch2ch_fst};
val ch2ch_snd = @{thm ch2ch_snd};
val ch2ch_Rep_CFunL = @{thm ch2ch_Rep_CFunL};
val ch2ch_Rep_CFunR = @{thm ch2ch_Rep_CFunR};
val chain_iterate = @{thm chain_iterate};
-val compact_ONE = @{thm compact_ONE};
-val compact_sinl = @{thm compact_sinl};
-val compact_sinr = @{thm compact_sinr};
-val compact_spair = @{thm compact_spair};
-val compact_up = @{thm compact_up};
-val contlub_cfun_arg = @{thm contlub_cfun_arg};
val contlub_cfun_fun = @{thm contlub_cfun_fun};
val contlub_fst = @{thm contlub_fst};
val contlub_snd = @{thm contlub_snd};
@@ -52,35 +47,10 @@
val cont2cont_snd = @{thm cont2cont_snd};
val cont2cont_Rep_CFun = @{thm cont2cont_Rep_CFun};
val fix_def2 = @{thm fix_def2};
-val injection_eq = @{thm injection_eq};
-val injection_less = @{thm injection_below};
val lub_equal = @{thm lub_equal};
-val monofun_cfun_arg = @{thm monofun_cfun_arg};
val retraction_strict = @{thm retraction_strict};
-val spair_eq = @{thm spair_eq};
-val spair_less = @{thm spair_below};
-val sscase1 = @{thm sscase1};
-val ssplit1 = @{thm ssplit1};
-val strictify1 = @{thm strictify1};
val wfix_ind = @{thm wfix_ind};
-
-val iso_intro = @{thm iso.intro};
-val iso_abs_iso = @{thm iso.abs_iso};
-val iso_rep_iso = @{thm iso.rep_iso};
-val iso_abs_strict = @{thm iso.abs_strict};
-val iso_rep_strict = @{thm iso.rep_strict};
-val iso_abs_defin' = @{thm iso.abs_defin'};
-val iso_rep_defin' = @{thm iso.rep_defin'};
-val iso_abs_defined = @{thm iso.abs_defined};
-val iso_rep_defined = @{thm iso.rep_defined};
-val iso_compact_abs = @{thm iso.compact_abs};
-val iso_compact_rep = @{thm iso.compact_rep};
-val iso_iso_swap = @{thm iso.iso_swap};
-
-val exh_start = @{thm exh_start};
-val ex_defined_iffs = @{thms ex_defined_iffs};
-val exh_casedist0 = @{thm exh_casedist0};
-val exh_casedists = @{thms exh_casedists};
+val iso_intro = @{thm iso.intro};
open Domain_Library;
infixr 0 ===>;
@@ -118,26 +88,25 @@
else cut_facts_tac prems 1 :: tacsf context;
in pg'' thy defs t tacs end;
+(* FIXME!!!!!!!!! *)
+(* We should NEVER re-parse variable names as strings! *)
+(* The names can conflict with existing constants or other syntax! *)
fun case_UU_tac ctxt rews i v =
InductTacs.case_tac ctxt (v^"=UU") i THEN
asm_simp_tac (HOLCF_ss addsimps rews) i;
-val chain_tac =
- REPEAT_DETERM o resolve_tac
- [chain_iterate, ch2ch_Rep_CFunR, ch2ch_Rep_CFunL, ch2ch_fst, ch2ch_snd];
-
(* ----- general proofs ----------------------------------------------------- *)
val all2E = @{lemma "!x y . P x y ==> (P x y ==> R) ==> R" by simp}
-val dist_eqI = @{lemma "!!x::'a::po. ~ x << y ==> x ~= y" by (blast dest!: below_antisym_inverse)}
-
-fun theorems (((dname, _), cons) : eq, eqs : eq list) thy =
+fun theorems
+ (((dname, _), cons) : eq, eqs : eq list)
+ (dom_eqn : typ * (binding * (bool * binding option * typ) list * mixfix) list)
+ (thy : theory) =
let
val _ = message ("Proving isomorphism properties of domain "^dname^" ...");
-val pg = pg' thy;
-val map_tab = Domain_Isomorphism.get_map_tab thy;
+val map_tab = Domain_Take_Proofs.get_map_tab thy;
(* ----- getting the axioms and definitions --------------------------------- *)
@@ -147,515 +116,94 @@
in
val ax_abs_iso = ga "abs_iso" dname;
val ax_rep_iso = ga "rep_iso" dname;
- val ax_when_def = ga "when_def" dname;
- fun get_def mk_name (con, _, _) = ga (mk_name con^"_def") dname;
- val axs_con_def = map (get_def extern_name) cons;
- val axs_dis_def = map (get_def dis_name) cons;
- val axs_mat_def = map (get_def mat_name) cons;
- val axs_pat_def = map (get_def pat_name) cons;
- val axs_sel_def =
- let
- fun def_of_sel sel = ga (sel^"_def") dname;
- fun def_of_arg arg = Option.map def_of_sel (sel_of arg);
- fun defs_of_con (_, _, args) = map_filter def_of_arg args;
- in
- maps defs_of_con cons
- end;
- val ax_copy_def = ga "copy_def" dname;
+ val ax_take_0 = ga "take_0" dname;
+ val ax_take_Suc = ga "take_Suc" dname;
+ val ax_take_strict = ga "take_strict" dname;
end; (* local *)
+(* ----- define constructors ------------------------------------------------ *)
+
+val lhsT = fst dom_eqn;
+
+val rhsT =
+ let
+ fun mk_arg_typ (lazy, sel, T) = if lazy then mk_uT T else T;
+ fun mk_con_typ (bind, args, mx) =
+ if null args then oneT else foldr1 mk_sprodT (map mk_arg_typ args);
+ fun mk_eq_typ (_, cons) = foldr1 mk_ssumT (map mk_con_typ cons);
+ in
+ mk_eq_typ dom_eqn
+ end;
+
+val rep_const = Const(dname^"_rep", lhsT ->> rhsT);
+
+val abs_const = Const(dname^"_abs", rhsT ->> lhsT);
+
+val iso_info : Domain_Take_Proofs.iso_info =
+ {
+ absT = lhsT,
+ repT = rhsT,
+ abs_const = abs_const,
+ rep_const = rep_const,
+ abs_inverse = ax_abs_iso,
+ rep_inverse = ax_rep_iso
+ };
+
+val (result, thy) =
+ Domain_Constructors.add_domain_constructors
+ (Long_Name.base_name dname) (snd dom_eqn) iso_info thy;
+
+val con_appls = #con_betas result;
+val {exhaust, casedist, ...} = result;
+val {con_compacts, con_rews, inverts, injects, dist_les, dist_eqs, ...} = result;
+val {sel_rews, ...} = result;
+val when_rews = #cases result;
+val when_strict = hd when_rews;
+val dis_rews = #dis_rews result;
+val mat_rews = #match_rews result;
+val pat_rews = #pat_rews result;
+
(* ----- theorems concerning the isomorphism -------------------------------- *)
-val dc_abs = %%:(dname^"_abs");
-val dc_rep = %%:(dname^"_rep");
-val dc_copy = %%:(dname^"_copy");
-val x_name = "x";
+val pg = pg' thy;
-val iso_locale = iso_intro OF [ax_abs_iso, ax_rep_iso];
val abs_strict = ax_rep_iso RS (allI RS retraction_strict);
val rep_strict = ax_abs_iso RS (allI RS retraction_strict);
-val abs_defin' = iso_locale RS iso_abs_defin';
-val rep_defin' = iso_locale RS iso_rep_defin';
val iso_rews = map Drule.export_without_context [ax_abs_iso, ax_rep_iso, abs_strict, rep_strict];
-(* ----- generating beta reduction rules from definitions-------------------- *)
-
-val _ = trace " Proving beta reduction rules...";
-
-local
- fun arglist (Const _ $ Abs (s, _, t)) =
- let
- val (vars,body) = arglist t;
- in (s :: vars, body) end
- | arglist t = ([], t);
- fun bind_fun vars t = Library.foldr mk_All (vars, t);
- fun bound_vars 0 = []
- | bound_vars i = Bound (i-1) :: bound_vars (i - 1);
-in
- fun appl_of_def def =
- let
- val (_ $ con $ lam) = concl_of def;
- val (vars, rhs) = arglist lam;
- val lhs = list_ccomb (con, bound_vars (length vars));
- val appl = bind_fun vars (lhs == rhs);
- val cs = ContProc.cont_thms lam;
- val betas = map (fn c => mk_meta_eq (c RS beta_cfun)) cs;
- in pg (def::betas) appl (K [rtac reflexive_thm 1]) end;
-end;
-
-val _ = trace "Proving when_appl...";
-val when_appl = appl_of_def ax_when_def;
-val _ = trace "Proving con_appls...";
-val con_appls = map appl_of_def axs_con_def;
-
-local
- fun arg2typ n arg =
- let val t = TVar (("'a", n), pcpoS)
- in (n + 1, if is_lazy arg then mk_uT t else t) end;
-
- fun args2typ n [] = (n, oneT)
- | args2typ n [arg] = arg2typ n arg
- | args2typ n (arg::args) =
- let
- val (n1, t1) = arg2typ n arg;
- val (n2, t2) = args2typ n1 args
- in (n2, mk_sprodT (t1, t2)) end;
-
- fun cons2typ n [] = (n,oneT)
- | cons2typ n [con] = args2typ n (third con)
- | cons2typ n (con::cons) =
- let
- val (n1, t1) = args2typ n (third con);
- val (n2, t2) = cons2typ n1 cons
- in (n2, mk_ssumT (t1, t2)) end;
-in
- fun cons2ctyp cons = ctyp_of thy (snd (cons2typ 1 cons));
-end;
-
-local
- val iso_swap = iso_locale RS iso_iso_swap;
- fun one_con (con, _, args) =
- let
- val vns = map vname args;
- val eqn = %:x_name === con_app2 con %: vns;
- val conj = foldr1 mk_conj (eqn :: map (defined o %:) (nonlazy args));
- in Library.foldr mk_ex (vns, conj) end;
-
- val conj_assoc = @{thm conj_assoc};
- val exh = foldr1 mk_disj ((%:x_name === UU) :: map one_con cons);
- val thm1 = instantiate' [SOME (cons2ctyp cons)] [] exh_start;
- val thm2 = rewrite_rule (map mk_meta_eq ex_defined_iffs) thm1;
- val thm3 = rewrite_rule [mk_meta_eq @{thm conj_assoc}] thm2;
-
- (* first 3 rules replace "x = UU \/ P" with "rep$x = UU \/ P" *)
- val tacs = [
- rtac disjE 1,
- etac (rep_defin' RS disjI1) 2,
- etac disjI2 2,
- rewrite_goals_tac [mk_meta_eq iso_swap],
- rtac thm3 1];
-in
- val _ = trace " Proving exhaust...";
- val exhaust = pg con_appls (mk_trp exh) (K tacs);
- val _ = trace " Proving casedist...";
- val casedist =
- Drule.export_without_context (rewrite_rule exh_casedists (exhaust RS exh_casedist0));
-end;
-
-local
- fun bind_fun t = Library.foldr mk_All (when_funs cons, t);
- fun bound_fun i _ = Bound (length cons - i);
- val when_app = list_ccomb (%%:(dname^"_when"), mapn bound_fun 1 cons);
-in
- val _ = trace " Proving when_strict...";
- val when_strict =
- let
- val axs = [when_appl, mk_meta_eq rep_strict];
- val goal = bind_fun (mk_trp (strict when_app));
- val tacs = [resolve_tac [sscase1, ssplit1, strictify1] 1];
- in pg axs goal (K tacs) end;
-
- val _ = trace " Proving when_apps...";
- val when_apps =
- let
- fun one_when n (con, _, args) =
- let
- val axs = when_appl :: con_appls;
- val goal = bind_fun (lift_defined %: (nonlazy args,
- mk_trp (when_app`(con_app con args) ===
- list_ccomb (bound_fun n 0, map %# args))));
- val tacs = [asm_simp_tac (HOLCF_ss addsimps [ax_abs_iso]) 1];
- in pg axs goal (K tacs) end;
- in mapn one_when 1 cons end;
-end;
-val when_rews = when_strict :: when_apps;
-
-(* ----- theorems concerning the constructors, discriminators and selectors - *)
-
-local
- fun dis_strict (con, _, _) =
- let
- val goal = mk_trp (strict (%%:(dis_name con)));
- in pg axs_dis_def goal (K [rtac when_strict 1]) end;
-
- fun dis_app c (con, _, args) =
- let
- val lhs = %%:(dis_name c) ` con_app con args;
- val rhs = if con = c then TT else FF;
- val goal = lift_defined %: (nonlazy args, mk_trp (lhs === rhs));
- val tacs = [asm_simp_tac (HOLCF_ss addsimps when_rews) 1];
- in pg axs_dis_def goal (K tacs) end;
-
- val _ = trace " Proving dis_apps...";
- val dis_apps = maps (fn (c,_,_) => map (dis_app c) cons) cons;
-
- fun dis_defin (con, _, args) =
- let
- val goal = defined (%:x_name) ==> defined (%%:(dis_name con) `% x_name);
- val tacs =
- [rtac casedist 1,
- contr_tac 1,
- DETERM_UNTIL_SOLVED (CHANGED
- (asm_simp_tac (HOLCF_ss addsimps dis_apps) 1))];
- in pg [] goal (K tacs) end;
-
- val _ = trace " Proving dis_stricts...";
- val dis_stricts = map dis_strict cons;
- val _ = trace " Proving dis_defins...";
- val dis_defins = map dis_defin cons;
-in
- val dis_rews = dis_stricts @ dis_defins @ dis_apps;
-end;
-
-local
- fun mat_strict (con, _, _) =
- let
- val goal = mk_trp (%%:(mat_name con) ` UU ` %:"rhs" === UU);
- val tacs = [asm_simp_tac (HOLCF_ss addsimps [when_strict]) 1];
- in pg axs_mat_def goal (K tacs) end;
-
- val _ = trace " Proving mat_stricts...";
- val mat_stricts = map mat_strict cons;
-
- fun one_mat c (con, _, args) =
- let
- val lhs = %%:(mat_name c) ` con_app con args ` %:"rhs";
- val rhs =
- if con = c
- then list_ccomb (%:"rhs", map %# args)
- else mk_fail;
- val goal = lift_defined %: (nonlazy args, mk_trp (lhs === rhs));
- val tacs = [asm_simp_tac (HOLCF_ss addsimps when_rews) 1];
- in pg axs_mat_def goal (K tacs) end;
-
- val _ = trace " Proving mat_apps...";
- val mat_apps =
- maps (fn (c,_,_) => map (one_mat c) cons) cons;
-in
- val mat_rews = mat_stricts @ mat_apps;
-end;
-
-local
- fun ps args = mapn (fn n => fn _ => %:("pat" ^ string_of_int n)) 1 args;
-
- fun pat_lhs (con,_,args) = mk_branch (list_comb (%%:(pat_name con), ps args));
-
- fun pat_rhs (con,_,[]) = mk_return ((%:"rhs") ` HOLogic.unit)
- | pat_rhs (con,_,args) =
- (mk_branch (mk_ctuple_pat (ps args)))
- `(%:"rhs")`(mk_ctuple (map %# args));
-
- fun pat_strict c =
- let
- val axs = @{thm branch_def} :: axs_pat_def;
- val goal = mk_trp (strict (pat_lhs c ` (%:"rhs")));
- val tacs = [simp_tac (HOLCF_ss addsimps [when_strict]) 1];
- in pg axs goal (K tacs) end;
-
- fun pat_app c (con, _, args) =
- let
- val axs = @{thm branch_def} :: axs_pat_def;
- val lhs = (pat_lhs c)`(%:"rhs")`(con_app con args);
- val rhs = if con = first c then pat_rhs c else mk_fail;
- val goal = lift_defined %: (nonlazy args, mk_trp (lhs === rhs));
- val tacs = [asm_simp_tac (HOLCF_ss addsimps when_rews) 1];
- in pg axs goal (K tacs) end;
-
- val _ = trace " Proving pat_stricts...";
- val pat_stricts = map pat_strict cons;
- val _ = trace " Proving pat_apps...";
- val pat_apps = maps (fn c => map (pat_app c) cons) cons;
-in
- val pat_rews = pat_stricts @ pat_apps;
-end;
-
-local
- fun con_strict (con, _, args) =
- let
- val rules = abs_strict :: @{thms con_strict_rules};
- fun one_strict vn =
- let
- fun f arg = if vname arg = vn then UU else %# arg;
- val goal = mk_trp (con_app2 con f args === UU);
- val tacs = [simp_tac (HOL_basic_ss addsimps rules) 1];
- in pg con_appls goal (K tacs) end;
- in map one_strict (nonlazy args) end;
-
- fun con_defin (con, _, args) =
- let
- fun iff_disj (t, []) = HOLogic.mk_not t
- | iff_disj (t, ts) = t === foldr1 HOLogic.mk_disj ts;
- val lhs = con_app con args === UU;
- val rhss = map (fn x => %:x === UU) (nonlazy args);
- val goal = mk_trp (iff_disj (lhs, rhss));
- val rule1 = iso_locale RS @{thm iso.abs_defined_iff};
- val rules = rule1 :: @{thms con_defined_iff_rules};
- val tacs = [simp_tac (HOL_ss addsimps rules) 1];
- in pg con_appls goal (K tacs) end;
-in
- val _ = trace " Proving con_stricts...";
- val con_stricts = maps con_strict cons;
- val _ = trace " Proving con_defins...";
- val con_defins = map con_defin cons;
- val con_rews = con_stricts @ con_defins;
-end;
-
-local
- val rules =
- [compact_sinl, compact_sinr, compact_spair, compact_up, compact_ONE];
- fun con_compact (con, _, args) =
- let
- val concl = mk_trp (mk_compact (con_app con args));
- val goal = lift (fn x => mk_compact (%#x)) (args, concl);
- val tacs = [
- rtac (iso_locale RS iso_compact_abs) 1,
- REPEAT (resolve_tac rules 1 ORELSE atac 1)];
- in pg con_appls goal (K tacs) end;
-in
- val _ = trace " Proving con_compacts...";
- val con_compacts = map con_compact cons;
-end;
-
-local
- fun one_sel sel =
- pg axs_sel_def (mk_trp (strict (%%:sel)))
- (K [simp_tac (HOLCF_ss addsimps when_rews) 1]);
-
- fun sel_strict (_, _, args) =
- map_filter (Option.map one_sel o sel_of) args;
-in
- val _ = trace " Proving sel_stricts...";
- val sel_stricts = maps sel_strict cons;
-end;
-
-local
- fun sel_app_same c n sel (con, args) =
- let
- val nlas = nonlazy args;
- val vns = map vname args;
- val vnn = List.nth (vns, n);
- val nlas' = filter (fn v => v <> vnn) nlas;
- val lhs = (%%:sel)`(con_app con args);
- val goal = lift_defined %: (nlas', mk_trp (lhs === %:vnn));
- fun tacs1 ctxt =
- if vnn mem nlas
- then [case_UU_tac ctxt (when_rews @ con_stricts) 1 vnn]
- else [];
- val tacs2 = [asm_simp_tac (HOLCF_ss addsimps when_rews) 1];
- in pg axs_sel_def goal (fn ctxt => (tacs1 ctxt @ tacs2)) end;
-
- fun sel_app_diff c n sel (con, args) =
- let
- val nlas = nonlazy args;
- val goal = mk_trp (%%:sel ` con_app con args === UU);
- fun tacs1 ctxt = map (case_UU_tac ctxt (when_rews @ con_stricts) 1) nlas;
- val tacs2 = [asm_simp_tac (HOLCF_ss addsimps when_rews) 1];
- in pg axs_sel_def goal (fn ctxt => (tacs1 ctxt @ tacs2)) end;
-
- fun sel_app c n sel (con, _, args) =
- if con = c
- then sel_app_same c n sel (con, args)
- else sel_app_diff c n sel (con, args);
-
- fun one_sel c n sel = map (sel_app c n sel) cons;
- fun one_sel' c n arg = Option.map (one_sel c n) (sel_of arg);
- fun one_con (c, _, args) =
- flat (map_filter I (mapn (one_sel' c) 0 args));
-in
- val _ = trace " Proving sel_apps...";
- val sel_apps = maps one_con cons;
-end;
-
-local
- fun sel_defin sel =
- let
- val goal = defined (%:x_name) ==> defined (%%:sel`%x_name);
- val tacs = [
- rtac casedist 1,
- contr_tac 1,
- DETERM_UNTIL_SOLVED (CHANGED
- (asm_simp_tac (HOLCF_ss addsimps sel_apps) 1))];
- in pg [] goal (K tacs) end;
-in
- val _ = trace " Proving sel_defins...";
- val sel_defins =
- if length cons = 1
- then map_filter (fn arg => Option.map sel_defin (sel_of arg))
- (filter_out is_lazy (third (hd cons)))
- else [];
-end;
-
-val sel_rews = sel_stricts @ sel_defins @ sel_apps;
-
-val _ = trace " Proving dist_les...";
-val dist_les =
- let
- fun dist (con1, args1) (con2, args2) =
- let
- fun iff_disj (t, []) = HOLogic.mk_not t
- | iff_disj (t, ts) = t === foldr1 HOLogic.mk_disj ts;
- val lhs = con_app con1 args1 << con_app con2 args2;
- val rhss = map (fn x => %:x === UU) (nonlazy args1);
- val goal = mk_trp (iff_disj (lhs, rhss));
- val rule1 = iso_locale RS @{thm iso.abs_below};
- val rules = rule1 :: @{thms con_below_iff_rules};
- val tacs = [simp_tac (HOL_ss addsimps rules) 1];
- in pg con_appls goal (K tacs) end;
-
- fun distinct (con1, _, args1) (con2, _, args2) =
- let
- val arg1 = (con1, args1);
- val arg2 =
- (con2, ListPair.map (fn (arg,vn) => upd_vname (K vn) arg)
- (args2, Name.variant_list (map vname args1) (map vname args2)));
- in [dist arg1 arg2, dist arg2 arg1] end;
- fun distincts [] = []
- | distincts (c::cs) = maps (distinct c) cs @ distincts cs;
- in distincts cons end;
-
-val _ = trace " Proving dist_eqs...";
-val dist_eqs =
- let
- fun dist (con1, args1) (con2, args2) =
- let
- fun iff_disj (t, [], us) = HOLogic.mk_not t
- | iff_disj (t, ts, []) = HOLogic.mk_not t
- | iff_disj (t, ts, us) =
- let
- val disj1 = foldr1 HOLogic.mk_disj ts;
- val disj2 = foldr1 HOLogic.mk_disj us;
- in t === HOLogic.mk_conj (disj1, disj2) end;
- val lhs = con_app con1 args1 === con_app con2 args2;
- val rhss1 = map (fn x => %:x === UU) (nonlazy args1);
- val rhss2 = map (fn x => %:x === UU) (nonlazy args2);
- val goal = mk_trp (iff_disj (lhs, rhss1, rhss2));
- val rule1 = iso_locale RS @{thm iso.abs_eq};
- val rules = rule1 :: @{thms con_eq_iff_rules};
- val tacs = [simp_tac (HOL_ss addsimps rules) 1];
- in pg con_appls goal (K tacs) end;
-
- fun distinct (con1, _, args1) (con2, _, args2) =
- let
- val arg1 = (con1, args1);
- val arg2 =
- (con2, ListPair.map (fn (arg,vn) => upd_vname (K vn) arg)
- (args2, Name.variant_list (map vname args1) (map vname args2)));
- in [dist arg1 arg2, dist arg2 arg1] end;
- fun distincts [] = []
- | distincts (c::cs) = maps (distinct c) cs @ distincts cs;
- in distincts cons end;
-
-local
- fun pgterm rel con args =
- let
- fun append s = upd_vname (fn v => v^s);
- val (largs, rargs) = (args, map (append "'") args);
- val concl =
- foldr1 mk_conj (ListPair.map rel (map %# largs, map %# rargs));
- val prem = rel (con_app con largs, con_app con rargs);
- val sargs = case largs of [_] => [] | _ => nonlazy args;
- val prop = lift_defined %: (sargs, mk_trp (prem === concl));
- in pg con_appls prop end;
- val cons' = filter (fn (_, _, args) => args<>[]) cons;
-in
- val _ = trace " Proving inverts...";
- val inverts =
- let
- val abs_less = ax_abs_iso RS (allI RS injection_less);
- val tacs =
- [asm_full_simp_tac (HOLCF_ss addsimps [abs_less, spair_less]) 1];
- in map (fn (con, _, args) => pgterm (op <<) con args (K tacs)) cons' end;
-
- val _ = trace " Proving injects...";
- val injects =
- let
- val abs_eq = ax_abs_iso RS (allI RS injection_eq);
- val tacs = [asm_full_simp_tac (HOLCF_ss addsimps [abs_eq, spair_eq]) 1];
- in map (fn (con, _, args) => pgterm (op ===) con args (K tacs)) cons' end;
-end;
-
(* ----- theorems concerning one induction step ----------------------------- *)
-val copy_strict =
- let
- val _ = trace " Proving copy_strict...";
- val goal = mk_trp (strict (dc_copy `% "f"));
- val rules = [abs_strict, rep_strict] @ @{thms domain_map_stricts};
- val tacs = [asm_simp_tac (HOLCF_ss addsimps rules) 1];
- in
- SOME (pg [ax_copy_def] goal (K tacs))
- handle
- THM (s, _, _) => (trace s; NONE)
- | ERROR s => (trace s; NONE)
- end;
+local
+ fun dc_take dn = %%:(dn^"_take");
+ val dnames = map (fst o fst) eqs;
+ val deflation_thms = Domain_Take_Proofs.get_deflation_thms thy;
+ fun get_deflation_take dn = PureThy.get_thm thy (dn ^ ".deflation_take");
+ val axs_deflation_take = map get_deflation_take dnames;
-local
- fun copy_app (con, _, args) =
+ fun one_take_app (con, args) =
let
- val lhs = dc_copy`%"f"`(con_app con args);
+ fun mk_take n = dc_take (List.nth (dnames, n)) $ %:"n";
fun one_rhs arg =
if Datatype_Aux.is_rec_type (dtyp_of arg)
then Domain_Axioms.copy_of_dtyp map_tab
- (proj (%:"f") eqs) (dtyp_of arg) ` (%# arg)
+ mk_take (dtyp_of arg) ` (%# arg)
else (%# arg);
+ val lhs = (dc_take dname $ (%%:"Suc" $ %:"n"))`(con_app con args);
val rhs = con_app2 con one_rhs args;
- fun is_rec arg = Datatype_Aux.is_rec_type (dtyp_of arg);
- fun is_nonlazy_rec arg = is_rec arg andalso not (is_lazy arg);
- fun nonlazy_rec args = map vname (filter is_nonlazy_rec args);
- val goal = lift_defined %: (nonlazy_rec args, mk_trp (lhs === rhs));
- val args' = filter_out (fn a => is_rec a orelse is_lazy a) args;
- val stricts = abs_strict :: rep_strict :: @{thms domain_map_stricts};
- fun tacs1 ctxt = map (case_UU_tac ctxt stricts 1 o vname) args';
- val rules = [ax_abs_iso] @ @{thms domain_map_simps};
- val tacs2 = [asm_simp_tac (HOLCF_ss addsimps rules) 1];
- in pg (ax_copy_def::con_appls) goal (fn ctxt => (tacs1 ctxt @ tacs2)) end;
+ val goal = mk_trp (lhs === rhs);
+ val rules = [ax_take_Suc, ax_abs_iso, @{thm cfcomp2}];
+ val rules2 =
+ @{thms take_con_rules ID1 deflation_strict}
+ @ deflation_thms @ axs_deflation_take;
+ val tacs =
+ [simp_tac (HOL_basic_ss addsimps rules) 1,
+ asm_simp_tac (HOL_basic_ss addsimps rules2) 1];
+ in pg con_appls goal (K tacs) end;
+ val take_apps = map (Drule.export_without_context o one_take_app) cons;
in
- val _ = trace " Proving copy_apps...";
- val copy_apps = map copy_app cons;
+ val take_rews = ax_take_0 :: ax_take_strict :: take_apps;
end;
-local
- fun one_strict (con, _, args) =
- let
- val goal = mk_trp (dc_copy`UU`(con_app con args) === UU);
- val rews = the_list copy_strict @ copy_apps @ con_rews;
- fun tacs ctxt = map (case_UU_tac ctxt rews 1) (nonlazy args) @
- [asm_simp_tac (HOLCF_ss addsimps rews) 1];
- in
- SOME (pg [] goal tacs)
- handle
- THM (s, _, _) => (trace s; NONE)
- | ERROR s => (trace s; NONE)
- end;
-
- fun has_nonlazy_rec (_, _, args) = exists is_nonlazy_rec args;
-in
- val _ = trace " Proving copy_stricts...";
- val copy_stricts = map_filter one_strict (filter has_nonlazy_rec cons);
-end;
-
-val copy_rews = the_list copy_strict @ copy_apps @ copy_stricts;
-
in
thy
|> Sign.add_path (Long_Name.base_name dname)
@@ -674,24 +222,98 @@
((Binding.name "dist_eqs" , dist_eqs ), [Simplifier.simp_add]),
((Binding.name "inverts" , inverts ), [Simplifier.simp_add]),
((Binding.name "injects" , injects ), [Simplifier.simp_add]),
- ((Binding.name "copy_rews" , copy_rews ), [Simplifier.simp_add]),
+ ((Binding.name "take_rews" , take_rews ), [Simplifier.simp_add]),
((Binding.name "match_rews", mat_rews ),
[Simplifier.simp_add, Fixrec.fixrec_simp_add])]
|> Sign.parent_path
|> pair (iso_rews @ when_rews @ con_rews @ sel_rews @ dis_rews @
- pat_rews @ dist_les @ dist_eqs @ copy_rews)
+ pat_rews @ dist_les @ dist_eqs)
end; (* let *)
fun comp_theorems (comp_dnam, eqs: eq list) thy =
let
-val global_ctxt = ProofContext.init thy;
-val map_tab = Domain_Isomorphism.get_map_tab thy;
+val map_tab = Domain_Take_Proofs.get_map_tab thy;
val dnames = map (fst o fst) eqs;
val conss = map snd eqs;
val comp_dname = Sign.full_bname thy comp_dnam;
val _ = message ("Proving induction properties of domain "^comp_dname^" ...");
+
+(* ----- define bisimulation predicate -------------------------------------- *)
+
+local
+ open HOLCF_Library
+ val dtypes = map (Type o fst) eqs;
+ val relprod = mk_tupleT (map (fn tp => tp --> tp --> boolT) dtypes);
+ val bisim_bind = Binding.name (comp_dnam ^ "_bisim");
+ val bisim_type = relprod --> boolT;
+in
+ val (bisim_const, thy) =
+ Sign.declare_const ((bisim_bind, bisim_type), NoSyn) thy;
+end;
+
+local
+
+ fun legacy_infer_term thy t =
+ singleton (Syntax.check_terms (ProofContext.init thy)) (Sign.intern_term thy t);
+ fun legacy_infer_prop thy t = legacy_infer_term thy (TypeInfer.constrain propT t);
+ fun infer_props thy = map (apsnd (legacy_infer_prop thy));
+ fun add_defs_i x = PureThy.add_defs false (map Thm.no_attributes x);
+ fun add_defs_infer defs thy = add_defs_i (infer_props thy defs) thy;
+
+ val comp_dname = Sign.full_bname thy comp_dnam;
+ val dnames = map (fst o fst) eqs;
+ val x_name = idx_name dnames "x";
+
+ fun one_con (con, args) =
+ let
+ val nonrec_args = filter_out is_rec args;
+ val rec_args = filter is_rec args;
+ val recs_cnt = length rec_args;
+ val allargs = nonrec_args @ rec_args
+ @ map (upd_vname (fn s=> s^"'")) rec_args;
+ val allvns = map vname allargs;
+ fun vname_arg s arg = if is_rec arg then vname arg^s else vname arg;
+ val vns1 = map (vname_arg "" ) args;
+ val vns2 = map (vname_arg "'") args;
+ val allargs_cnt = length nonrec_args + 2*recs_cnt;
+ val rec_idxs = (recs_cnt-1) downto 0;
+ val nonlazy_idxs = map snd (filter_out (fn (arg,_) => is_lazy arg)
+ (allargs~~((allargs_cnt-1) downto 0)));
+ fun rel_app i ra = proj (Bound(allargs_cnt+2)) eqs (rec_of ra) $
+ Bound (2*recs_cnt-i) $ Bound (recs_cnt-i);
+ val capps =
+ List.foldr
+ mk_conj
+ (mk_conj(
+ Bound(allargs_cnt+1)===list_ccomb(%%:con,map (bound_arg allvns) vns1),
+ Bound(allargs_cnt+0)===list_ccomb(%%:con,map (bound_arg allvns) vns2)))
+ (mapn rel_app 1 rec_args);
+ in
+ List.foldr
+ mk_ex
+ (Library.foldr mk_conj
+ (map (defined o Bound) nonlazy_idxs,capps)) allvns
+ end;
+ fun one_comp n (_,cons) =
+ mk_all (x_name(n+1),
+ mk_all (x_name(n+1)^"'",
+ mk_imp (proj (Bound 2) eqs n $ Bound 1 $ Bound 0,
+ foldr1 mk_disj (mk_conj(Bound 1 === UU,Bound 0 === UU)
+ ::map one_con cons))));
+ val bisim_eqn =
+ %%:(comp_dname^"_bisim") ==
+ mk_lam("R", foldr1 mk_conj (mapn one_comp 0 eqs));
+
+in
+ val ([ax_bisim_def], thy) =
+ thy
+ |> Sign.add_path comp_dnam
+ |> add_defs_infer [(Binding.name "bisim_def", bisim_eqn)]
+ ||> Sign.parent_path;
+end; (* local *)
+
val pg = pg' thy;
(* ----- getting the composite axiom and definitions ------------------------ *)
@@ -699,11 +321,10 @@
local
fun ga s dn = PureThy.get_thm thy (dn ^ "." ^ s);
in
- val axs_reach = map (ga "reach" ) dnames;
val axs_take_def = map (ga "take_def" ) dnames;
+ val axs_chain_take = map (ga "chain_take") dnames;
+ val axs_lub_take = map (ga "lub_take" ) dnames;
val axs_finite_def = map (ga "finite_def") dnames;
- val ax_copy2_def = ga "copy_def" comp_dnam;
- val ax_bisim_def = ga "bisim_def" comp_dnam;
end;
local
@@ -712,7 +333,6 @@
in
val cases = map (gt "casedist" ) dnames;
val con_rews = maps (gts "con_rews" ) dnames;
- val copy_rews = maps (gts "copy_rews") dnames;
end;
fun dc_take dn = %%:(dn^"_take");
@@ -722,64 +342,20 @@
(* ----- theorems concerning finite approximation and finite induction ------ *)
-local
- val iterate_Cprod_ss = global_simpset_of @{theory Fix};
- val copy_con_rews = copy_rews @ con_rews;
- val copy_take_defs =
- (if n_eqs = 1 then [] else [ax_copy2_def]) @ axs_take_def;
- val _ = trace " Proving take_stricts...";
- fun one_take_strict ((dn, args), _) =
- let
- val goal = mk_trp (strict (dc_take dn $ %:"n"));
- val rules = [
- @{thm monofun_fst [THEN monofunE]},
- @{thm monofun_snd [THEN monofunE]}];
- val tacs = [
- rtac @{thm UU_I} 1,
- rtac @{thm below_eq_trans} 1,
- resolve_tac axs_reach 2,
- rtac @{thm monofun_cfun_fun} 1,
- REPEAT (resolve_tac rules 1),
- rtac @{thm iterate_below_fix} 1];
- in pg axs_take_def goal (K tacs) end;
- val take_stricts = map one_take_strict eqs;
- fun take_0 n dn =
- let
- val goal = mk_trp ((dc_take dn $ @{term "0::nat"}) `% x_name n === UU);
- in pg axs_take_def goal (K [simp_tac iterate_Cprod_ss 1]) end;
- val take_0s = mapn take_0 1 dnames;
- val _ = trace " Proving take_apps...";
- fun one_take_app dn (con, _, args) =
- let
- fun mk_take n = dc_take (List.nth (dnames, n)) $ %:"n";
- fun one_rhs arg =
- if Datatype_Aux.is_rec_type (dtyp_of arg)
- then Domain_Axioms.copy_of_dtyp map_tab
- mk_take (dtyp_of arg) ` (%# arg)
- else (%# arg);
- val lhs = (dc_take dn $ (%%:"Suc" $ %:"n"))`(con_app con args);
- val rhs = con_app2 con one_rhs args;
- fun is_rec arg = Datatype_Aux.is_rec_type (dtyp_of arg);
- fun is_nonlazy_rec arg = is_rec arg andalso not (is_lazy arg);
- fun nonlazy_rec args = map vname (filter is_nonlazy_rec args);
- val goal = lift_defined %: (nonlazy_rec args, mk_trp (lhs === rhs));
- val tacs = [asm_simp_tac (HOLCF_ss addsimps copy_con_rews) 1];
- in pg copy_take_defs goal (K tacs) end;
- fun one_take_apps ((dn, _), cons) = map (one_take_app dn) cons;
- val take_apps = maps one_take_apps eqs;
-in
- val take_rews = map Drule.export_without_context
- (take_stricts @ take_0s @ take_apps);
-end; (* local *)
+val take_rews =
+ maps (fn dn => PureThy.get_thms thy (dn ^ ".take_rews")) dnames;
local
- fun one_con p (con, _, args) =
+ fun one_con p (con, args) =
let
+ val P_names = map P_name (1 upto (length dnames));
+ val vns = Name.variant_list P_names (map vname args);
+ val nonlazy_vns = map snd (filter_out (is_lazy o fst) (args ~~ vns));
fun ind_hyp arg = %:(P_name (1 + rec_of arg)) $ bound_arg args arg;
val t1 = mk_trp (%:p $ con_app2 con (bound_arg args) args);
val t2 = lift ind_hyp (filter is_rec args, t1);
- val t3 = lift_defined (bound_arg (map vname args)) (nonlazy args, t2);
- in Library.foldr mk_All (map vname args, t3) end;
+ val t3 = lift_defined (bound_arg vns) (nonlazy_vns, t2);
+ in Library.foldr mk_All (vns, t3) end;
fun one_eq ((p, cons), concl) =
mk_trp (%:p $ UU) ===> Logic.list_implies (map (one_con p) cons, concl);
@@ -787,14 +363,14 @@
fun ind_term concf = Library.foldr one_eq
(mapn (fn n => fn x => (P_name n, x)) 1 conss,
mk_trp (foldr1 mk_conj (mapn concf 1 dnames)));
- val take_ss = HOL_ss addsimps take_rews;
+ val take_ss = HOL_ss addsimps (@{thm Rep_CFun_strict1} :: take_rews);
fun quant_tac ctxt i = EVERY
(mapn (fn n => fn _ => res_inst_tac ctxt [(("x", 0), x_name n)] spec i) 1 dnames);
fun ind_prems_tac prems = EVERY
(maps (fn cons =>
(resolve_tac prems 1 ::
- maps (fn (_,_,args) =>
+ maps (fn (_,args) =>
resolve_tac prems 1 ::
map (K(atac 1)) (nonlazy args) @
map (K(atac 1)) (filter is_rec args))
@@ -809,7 +385,7 @@
((rec_of arg = n andalso nfn(lazy_rec orelse is_lazy arg)) orelse
rec_of arg <> n andalso rec_to quant nfn rfn (rec_of arg::ns)
(lazy_rec orelse is_lazy arg) (n, (List.nth(conss,rec_of arg))))
- ) o third) cons;
+ ) o snd) cons;
fun all_rec_to ns = rec_to forall not all_rec_to ns;
fun warn (n,cons) =
if all_rec_to [] false (n,cons)
@@ -838,16 +414,17 @@
simp_tac (take_ss addsimps prems) 1,
TRY (safe_tac HOL_cs)];
fun arg_tac arg =
+ (* FIXME! case_UU_tac *)
case_UU_tac context (prems @ con_rews) 1
(List.nth (dnames, rec_of arg) ^ "_take n$" ^ vname arg);
- fun con_tacs (con, _, args) =
+ fun con_tacs (con, args) =
asm_simp_tac take_ss 1 ::
map arg_tac (filter is_nonlazy_rec args) @
[resolve_tac prems 1] @
map (K (atac 1)) (nonlazy args) @
map (K (etac spec 1)) (filter is_rec args);
fun cases_tacs (cons, cases) =
- res_inst_tac context [(("x", 0), "x")] cases 1 ::
+ res_inst_tac context [(("y", 0), "x")] cases 1 ::
asm_simp_tac (take_ss addsimps prems) 1 ::
maps con_tacs cons;
in
@@ -860,31 +437,20 @@
val _ = trace " Proving take_lemmas...";
val take_lemmas =
let
- fun take_lemma n (dn, ax_reach) =
- let
- val lhs = dc_take dn $ Bound 0 `%(x_name n);
- val rhs = dc_take dn $ Bound 0 `%(x_name n^"'");
- val concl = mk_trp (%:(x_name n) === %:(x_name n^"'"));
- val goal = mk_All ("n", mk_trp (lhs === rhs)) ===> concl;
- val rules = [contlub_fst RS contlubE RS ssubst,
- contlub_snd RS contlubE RS ssubst];
- fun tacf {prems, context} = [
- res_inst_tac context [(("t", 0), x_name n )] (ax_reach RS subst) 1,
- res_inst_tac context [(("t", 0), x_name n^"'")] (ax_reach RS subst) 1,
- stac fix_def2 1,
- REPEAT (CHANGED
- (resolve_tac rules 1 THEN chain_tac 1)),
- stac contlub_cfun_fun 1,
- stac contlub_cfun_fun 2,
- rtac lub_equal 3,
- chain_tac 1,
- rtac allI 1,
- resolve_tac prems 1];
- in pg'' thy axs_take_def goal tacf end;
- in mapn take_lemma 1 (dnames ~~ axs_reach) end;
+ fun take_lemma (ax_chain_take, ax_lub_take) =
+ @{thm lub_ID_take_lemma} OF [ax_chain_take, ax_lub_take];
+ in map take_lemma (axs_chain_take ~~ axs_lub_take) end;
+
+ val axs_reach =
+ let
+ fun reach (ax_chain_take, ax_lub_take) =
+ @{thm lub_ID_reach} OF [ax_chain_take, ax_lub_take];
+ in map reach (axs_chain_take ~~ axs_lub_take) end;
(* ----- theorems concerning finiteness and induction ----------------------- *)
+ val global_ctxt = ProofContext.init thy;
+
val _ = trace " Proving finites, ind...";
val (finites, ind) =
(
@@ -927,13 +493,13 @@
etac disjE 1,
asm_simp_tac (HOL_ss addsimps con_rews) 1,
asm_simp_tac take_ss 1];
- fun con_tacs ctxt (con, _, args) =
+ fun con_tacs ctxt (con, args) =
asm_simp_tac take_ss 1 ::
maps (arg_tacs ctxt) (nonlazy_rec args);
fun foo_tacs ctxt n (cons, cases) =
simp_tac take_ss 1 ::
rtac allI 1 ::
- res_inst_tac ctxt [(("x", 0), x_name n)] cases 1 ::
+ res_inst_tac ctxt [(("y", 0), x_name n)] cases 1 ::
asm_simp_tac take_ss 1 ::
maps (con_tacs ctxt) cons;
fun tacs ctxt =
@@ -948,6 +514,7 @@
let
val goal = mk_trp (%%:(dn^"_finite") $ %:"x");
fun tacs ctxt = [
+ (* FIXME! case_UU_tac *)
case_UU_tac ctxt take_rews 1 "x",
eresolve_tac finite_lemmas1a 1,
step_tac HOL_cs 1,
@@ -990,22 +557,28 @@
val cont_rules =
[cont_id, cont_const, cont2cont_Rep_CFun,
cont2cont_fst, cont2cont_snd];
+ val subgoal =
+ let fun p n dn = %:(P_name n) $ (dc_take dn $ Bound 0 `%(x_name n));
+ in mk_trp (mk_all ("n", foldr1 mk_conj (mapn p 1 dnames))) end;
+ val subgoal' = legacy_infer_term thy subgoal;
fun tacf {prems, context} =
- map (fn ax_reach => rtac (ax_reach RS subst) 1) axs_reach @ [
- quant_tac context 1,
- rtac (adm_impl_admw RS wfix_ind) 1,
- REPEAT_DETERM (rtac adm_all 1),
- REPEAT_DETERM (
- TRY (rtac adm_conj 1) THEN
- rtac adm_subst 1 THEN
- REPEAT (resolve_tac cont_rules 1) THEN
- resolve_tac prems 1),
- strip_tac 1,
- rtac (rewrite_rule axs_take_def finite_ind) 1,
- ind_prems_tac prems];
+ let
+ val subtac =
+ EVERY [rtac allI 1, rtac finite_ind 1, ind_prems_tac prems];
+ val subthm = Goal.prove context [] [] subgoal' (K subtac);
+ in
+ map (fn ax_reach => rtac (ax_reach RS subst) 1) axs_reach @ [
+ cut_facts_tac (subthm :: take (length dnames) prems) 1,
+ REPEAT (rtac @{thm conjI} 1 ORELSE
+ EVERY [etac @{thm admD [OF _ ch2ch_Rep_CFunL]} 1,
+ resolve_tac axs_chain_take 1,
+ asm_simp_tac HOL_basic_ss 1])
+ ]
+ end;
val ind = (pg'' thy [] goal tacf
handle ERROR _ =>
- (warning "Cannot prove infinite induction rule"; TrueI));
+ (warning "Cannot prove infinite induction rule"; TrueI)
+ );
in (finites, ind) end
)
handle THM _ =>
@@ -1013,7 +586,6 @@
| ERROR _ =>
(warning "Cannot prove induction rule"; ([], TrueI));
-
end; (* local *)
(* ----- theorem concerning coinduction ------------------------------------- *)
@@ -1021,7 +593,7 @@
local
val xs = mapn (fn n => K (x_name n)) 1 dnames;
fun bnd_arg n i = Bound(2*(n_eqs - n)-i-1);
- val take_ss = HOL_ss addsimps take_rews;
+ val take_ss = HOL_ss addsimps (@{thm Rep_CFun_strict1} :: take_rews);
val sproj = prj (fn s => K("fst("^s^")")) (fn s => K("snd("^s^")"));
val _ = trace " Proving coind_lemma...";
val coind_lemma =
@@ -1075,8 +647,8 @@
in thy |> Sign.add_path comp_dnam
|> snd o PureThy.add_thmss [
- ((Binding.name "take_rews" , take_rews ), [Simplifier.simp_add]),
((Binding.name "take_lemmas", take_lemmas ), []),
+ ((Binding.name "reach" , axs_reach ), []),
((Binding.name "finites" , finites ), []),
((Binding.name "finite_ind" , [finite_ind]), []),
((Binding.name "ind" , [ind] ), []),
--- a/src/HOLCF/Tools/cont_consts.ML Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOLCF/Tools/cont_consts.ML Wed Mar 03 16:43:55 2010 +0100
@@ -56,7 +56,7 @@
trans_rules (syntax c2) (syntax c1) n mx)
end;
-fun cfun_arity (Type (n, [_, T])) = if n = @{type_name "->"} then 1 + cfun_arity T else 0
+fun cfun_arity (Type (n, [_, T])) = if n = @{type_name cfun} then 1 + cfun_arity T else 0
| cfun_arity _ = 0;
fun is_contconst (_, _, NoSyn) = false
--- a/src/HOLCF/Tools/fixrec.ML Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOLCF/Tools/fixrec.ML Wed Mar 03 16:43:55 2010 +0100
@@ -22,10 +22,15 @@
structure Fixrec :> FIXREC =
struct
+open HOLCF_Library;
+
+infixr 6 ->>;
+infix -->>;
+infix 9 `;
+
val def_cont_fix_eq = @{thm def_cont_fix_eq};
val def_cont_fix_ind = @{thm def_cont_fix_ind};
-
fun fixrec_err s = error ("fixrec definition error:\n" ^ s);
fun fixrec_eq_err thy s eq =
fixrec_err (s ^ "\nin\n" ^ quote (Syntax.string_of_term_global thy eq));
@@ -34,42 +39,23 @@
(***************************** building types ****************************)
(*************************************************************************)
-(* ->> is taken from holcf_logic.ML *)
-fun cfunT (T, U) = Type(@{type_name "->"}, [T, U]);
-
-infixr 6 ->>; val (op ->>) = cfunT;
-
-fun dest_cfunT (Type(@{type_name "->"}, [T, U])) = (T, U)
- | dest_cfunT T = raise TYPE ("dest_cfunT", [T], []);
-
-fun maybeT T = Type(@{type_name "maybe"}, [T]);
-
-fun dest_maybeT (Type(@{type_name "maybe"}, [T])) = T
- | dest_maybeT T = raise TYPE ("dest_maybeT", [T], []);
-
-fun tupleT [] = HOLogic.unitT
- | tupleT [T] = T
- | tupleT (T :: Ts) = HOLogic.mk_prodT (T, tupleT Ts);
-
local
-fun binder_cfun (Type(@{type_name "->"},[T, U])) = T :: binder_cfun U
+fun binder_cfun (Type(@{type_name cfun},[T, U])) = T :: binder_cfun U
| binder_cfun (Type(@{type_name "fun"},[T, U])) = T :: binder_cfun U
| binder_cfun _ = [];
-fun body_cfun (Type(@{type_name "->"},[T, U])) = body_cfun U
+fun body_cfun (Type(@{type_name cfun},[T, U])) = body_cfun U
| body_cfun (Type(@{type_name "fun"},[T, U])) = body_cfun U
| body_cfun T = T;
fun strip_cfun T : typ list * typ =
(binder_cfun T, body_cfun T);
-fun cfunsT (Ts, U) = List.foldr cfunT U Ts;
-
in
-fun matchT (T, U) =
- body_cfun T ->> cfunsT (binder_cfun T, U) ->> U;
+fun matcherT (T, U) =
+ body_cfun T ->> (binder_cfun T -->> U) ->> U;
end
@@ -86,43 +72,8 @@
fun chead_of (Const(@{const_name Rep_CFun},_)$f$t) = chead_of f
| chead_of u = u;
-fun capply_const (S, T) =
- Const(@{const_name Rep_CFun}, (S ->> T) --> (S --> T));
-
-fun cabs_const (S, T) =
- Const(@{const_name Abs_CFun}, (S --> T) --> (S ->> T));
-
-fun mk_cabs t =
- let val T = Term.fastype_of t
- in cabs_const (Term.domain_type T, Term.range_type T) $ t end
-
-fun mk_capply (t, u) =
- let val (S, T) =
- case Term.fastype_of t of
- Type(@{type_name "->"}, [S, T]) => (S, T)
- | _ => raise TERM ("mk_capply " ^ ML_Syntax.print_list ML_Syntax.print_term [t, u], [t, u]);
- in capply_const (S, T) $ t $ u end;
-
infix 0 ==; val (op ==) = Logic.mk_equals;
infix 1 ===; val (op ===) = HOLogic.mk_eq;
-infix 9 ` ; val (op `) = mk_capply;
-
-(* builds the expression (LAM v. rhs) *)
-fun big_lambda v rhs =
- cabs_const (Term.fastype_of v, Term.fastype_of rhs) $ Term.lambda v rhs;
-
-(* builds the expression (LAM v1 v2 .. vn. rhs) *)
-fun big_lambdas [] rhs = rhs
- | big_lambdas (v::vs) rhs = big_lambda v (big_lambdas vs rhs);
-
-fun mk_return t =
- let val T = Term.fastype_of t
- in Const(@{const_name Fixrec.return}, T ->> maybeT T) ` t end;
-
-fun mk_bind (t, u) =
- let val (T, mU) = dest_cfunT (Term.fastype_of u);
- val bindT = maybeT T ->> (T ->> mU) ->> mU;
- in Const(@{const_name Fixrec.bind}, bindT) ` t ` u end;
fun mk_mplus (t, u) =
let val mT = Term.fastype_of t
@@ -130,31 +81,9 @@
fun mk_run t =
let val mT = Term.fastype_of t
- val T = dest_maybeT mT
+ val T = dest_matchT mT
in Const(@{const_name Fixrec.run}, mT ->> T) ` t end;
-fun mk_fix t =
- let val (T, _) = dest_cfunT (Term.fastype_of t)
- in Const(@{const_name fix}, (T ->> T) ->> T) ` t end;
-
-fun mk_cont t =
- let val T = Term.fastype_of t
- in Const(@{const_name cont}, T --> HOLogic.boolT) $ t end;
-
-val mk_fst = HOLogic.mk_fst
-val mk_snd = HOLogic.mk_snd
-
-(* builds the expression (v1,v2,..,vn) *)
-fun mk_tuple [] = HOLogic.unit
-| mk_tuple (t::[]) = t
-| mk_tuple (t::ts) = HOLogic.mk_prod (t, mk_tuple ts);
-
-(* builds the expression (%(v1,v2,..,vn). rhs) *)
-fun lambda_tuple [] rhs = Term.lambda (Free("unit", HOLogic.unitT)) rhs
- | lambda_tuple (v::[]) rhs = Term.lambda v rhs
- | lambda_tuple (v::vs) rhs =
- HOLogic.mk_split (Term.lambda v (lambda_tuple vs rhs));
-
(*************************************************************************)
(************* fixed-point definitions and unfolding theorems ************)
@@ -288,11 +217,11 @@
| Const(c,T) =>
let
val n = Name.variant taken "v";
- fun result_type (Type(@{type_name "->"},[_,T])) (x::xs) = result_type T xs
+ fun result_type (Type(@{type_name cfun},[_,T])) (x::xs) = result_type T xs
| result_type (Type (@{type_name "fun"},[_,T])) (x::xs) = result_type T xs
| result_type T _ = T;
val v = Free(n, result_type T vs);
- val m = Const(match_name c, matchT (T, fastype_of rhs));
+ val m = Const(match_name c, matcherT (T, fastype_of rhs));
val k = big_lambdas vs rhs;
in
(m`v`k, v, n::taken)
@@ -340,7 +269,7 @@
val msum = foldr1 mk_mplus (map (unLAM arity) ms);
val (Ts, U) = LAM_Ts arity (hd ms)
in
- reLAM (rev Ts, dest_maybeT U) (mk_run msum)
+ reLAM (rev Ts, dest_matchT U) (mk_run msum)
end;
(* this is the pattern-matching compiler function *)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOLCF/Tools/holcf_library.ML Wed Mar 03 16:43:55 2010 +0100
@@ -0,0 +1,250 @@
+(* Title: HOLCF/Tools/holcf_library.ML
+ Author: Brian Huffman
+
+Functions for constructing HOLCF types and terms.
+*)
+
+structure HOLCF_Library =
+struct
+
+infixr 6 ->>;
+infix -->>;
+
+(*** Operations from Isabelle/HOL ***)
+
+val boolT = HOLogic.boolT;
+val natT = HOLogic.natT;
+
+val mk_equals = Logic.mk_equals;
+val mk_eq = HOLogic.mk_eq;
+val mk_trp = HOLogic.mk_Trueprop;
+val mk_fst = HOLogic.mk_fst;
+val mk_snd = HOLogic.mk_snd;
+val mk_not = HOLogic.mk_not;
+val mk_conj = HOLogic.mk_conj;
+val mk_disj = HOLogic.mk_disj;
+
+fun mk_ex (x, t) = HOLogic.exists_const (fastype_of x) $ Term.lambda x t;
+
+
+(*** Basic HOLCF concepts ***)
+
+fun mk_bottom T = Const (@{const_name UU}, T);
+
+fun below_const T = Const (@{const_name below}, [T, T] ---> boolT);
+fun mk_below (t, u) = below_const (fastype_of t) $ t $ u;
+
+fun mk_undef t = mk_eq (t, mk_bottom (fastype_of t));
+
+fun mk_defined t = mk_not (mk_undef t);
+
+fun mk_compact t =
+ Const (@{const_name compact}, fastype_of t --> boolT) $ t;
+
+fun mk_cont t =
+ Const (@{const_name cont}, fastype_of t --> boolT) $ t;
+
+fun mk_chain t =
+ Const (@{const_name chain}, Term.fastype_of t --> boolT) $ t;
+
+
+(*** Continuous function space ***)
+
+(* ->> is taken from holcf_logic.ML *)
+fun mk_cfunT (T, U) = Type(@{type_name cfun}, [T, U]);
+
+val (op ->>) = mk_cfunT;
+val (op -->>) = Library.foldr mk_cfunT;
+
+fun dest_cfunT (Type(@{type_name cfun}, [T, U])) = (T, U)
+ | dest_cfunT T = raise TYPE ("dest_cfunT", [T], []);
+
+fun capply_const (S, T) =
+ Const(@{const_name Rep_CFun}, (S ->> T) --> (S --> T));
+
+fun cabs_const (S, T) =
+ Const(@{const_name Abs_CFun}, (S --> T) --> (S ->> T));
+
+fun mk_cabs t =
+ let val T = fastype_of t
+ in cabs_const (Term.domain_type T, Term.range_type T) $ t end
+
+(* builds the expression (% v1 v2 .. vn. rhs) *)
+fun lambdas [] rhs = rhs
+ | lambdas (v::vs) rhs = Term.lambda v (lambdas vs rhs);
+
+(* builds the expression (LAM v. rhs) *)
+fun big_lambda v rhs =
+ cabs_const (fastype_of v, fastype_of rhs) $ Term.lambda v rhs;
+
+(* builds the expression (LAM v1 v2 .. vn. rhs) *)
+fun big_lambdas [] rhs = rhs
+ | big_lambdas (v::vs) rhs = big_lambda v (big_lambdas vs rhs);
+
+fun mk_capply (t, u) =
+ let val (S, T) =
+ case fastype_of t of
+ Type(@{type_name cfun}, [S, T]) => (S, T)
+ | _ => raise TERM ("mk_capply " ^ ML_Syntax.print_list ML_Syntax.print_term [t, u], [t, u]);
+ in capply_const (S, T) $ t $ u end;
+
+infix 9 ` ; val (op `) = mk_capply;
+
+val list_ccomb : term * term list -> term = Library.foldl mk_capply;
+
+fun mk_ID T = Const (@{const_name ID}, T ->> T);
+
+fun cfcomp_const (T, U, V) =
+ Const (@{const_name cfcomp}, (U ->> V) ->> (T ->> U) ->> (T ->> V));
+
+fun mk_cfcomp (f, g) =
+ let
+ val (U, V) = dest_cfunT (fastype_of f);
+ val (T, U') = dest_cfunT (fastype_of g);
+ in
+ if U = U'
+ then mk_capply (mk_capply (cfcomp_const (T, U, V), f), g)
+ else raise TYPE ("mk_cfcomp", [U, U'], [f, g])
+ end;
+
+fun mk_strict t =
+ let val (T, U) = dest_cfunT (fastype_of t);
+ in mk_eq (t ` mk_bottom T, mk_bottom U) end;
+
+
+(*** Product type ***)
+
+val mk_prodT = HOLogic.mk_prodT
+
+fun mk_tupleT [] = HOLogic.unitT
+ | mk_tupleT [T] = T
+ | mk_tupleT (T :: Ts) = mk_prodT (T, mk_tupleT Ts);
+
+(* builds the expression (v1,v2,..,vn) *)
+fun mk_tuple [] = HOLogic.unit
+ | mk_tuple (t::[]) = t
+ | mk_tuple (t::ts) = HOLogic.mk_prod (t, mk_tuple ts);
+
+(* builds the expression (%(v1,v2,..,vn). rhs) *)
+fun lambda_tuple [] rhs = Term.lambda (Free("unit", HOLogic.unitT)) rhs
+ | lambda_tuple (v::[]) rhs = Term.lambda v rhs
+ | lambda_tuple (v::vs) rhs =
+ HOLogic.mk_split (Term.lambda v (lambda_tuple vs rhs));
+
+
+(*** Lifted cpo type ***)
+
+fun mk_upT T = Type(@{type_name "u"}, [T]);
+
+fun dest_upT (Type(@{type_name "u"}, [T])) = T
+ | dest_upT T = raise TYPE ("dest_upT", [T], []);
+
+fun up_const T = Const(@{const_name up}, T ->> mk_upT T);
+
+fun mk_up t = up_const (fastype_of t) ` t;
+
+fun fup_const (T, U) =
+ Const(@{const_name fup}, (T ->> U) ->> mk_upT T ->> U);
+
+fun from_up T = fup_const (T, T) ` mk_ID T;
+
+
+(*** Strict product type ***)
+
+val oneT = @{typ "one"};
+
+fun mk_sprodT (T, U) = Type(@{type_name sprod}, [T, U]);
+
+fun dest_sprodT (Type(@{type_name sprod}, [T, U])) = (T, U)
+ | dest_sprodT T = raise TYPE ("dest_sprodT", [T], []);
+
+fun spair_const (T, U) =
+ Const(@{const_name spair}, T ->> U ->> mk_sprodT (T, U));
+
+(* builds the expression (:t, u:) *)
+fun mk_spair (t, u) =
+ spair_const (fastype_of t, fastype_of u) ` t ` u;
+
+(* builds the expression (:t1,t2,..,tn:) *)
+fun mk_stuple [] = @{term "ONE"}
+ | mk_stuple (t::[]) = t
+ | mk_stuple (t::ts) = mk_spair (t, mk_stuple ts);
+
+fun sfst_const (T, U) =
+ Const(@{const_name sfst}, mk_sprodT (T, U) ->> T);
+
+fun ssnd_const (T, U) =
+ Const(@{const_name ssnd}, mk_sprodT (T, U) ->> U);
+
+
+(*** Strict sum type ***)
+
+fun mk_ssumT (T, U) = Type(@{type_name ssum}, [T, U]);
+
+fun dest_ssumT (Type(@{type_name ssum}, [T, U])) = (T, U)
+ | dest_ssumT T = raise TYPE ("dest_ssumT", [T], []);
+
+fun sinl_const (T, U) = Const(@{const_name sinl}, T ->> mk_ssumT (T, U));
+fun sinr_const (T, U) = Const(@{const_name sinr}, U ->> mk_ssumT (T, U));
+
+(* builds the list [sinl(t1), sinl(sinr(t2)), ... sinr(...sinr(tn))] *)
+fun mk_sinjects ts =
+ let
+ val Ts = map fastype_of ts;
+ fun combine (t, T) (us, U) =
+ let
+ val v = sinl_const (T, U) ` t;
+ val vs = map (fn u => sinr_const (T, U) ` u) us;
+ in
+ (v::vs, mk_ssumT (T, U))
+ end
+ fun inj [] = error "mk_sinjects: empty list"
+ | inj ((t, T)::[]) = ([t], T)
+ | inj ((t, T)::ts) = combine (t, T) (inj ts);
+ in
+ fst (inj (ts ~~ Ts))
+ end;
+
+fun sscase_const (T, U, V) =
+ Const(@{const_name sscase},
+ (T ->> V) ->> (U ->> V) ->> mk_ssumT (T, U) ->> V);
+
+fun from_sinl (T, U) =
+ sscase_const (T, U, T) ` mk_ID T ` mk_bottom (U ->> T);
+
+fun from_sinr (T, U) =
+ sscase_const (T, U, U) ` mk_bottom (T ->> U) ` mk_ID U;
+
+
+(*** pattern match monad type ***)
+
+fun mk_matchT T = Type (@{type_name "maybe"}, [T]);
+
+fun dest_matchT (Type(@{type_name "maybe"}, [T])) = T
+ | dest_matchT T = raise TYPE ("dest_matchT", [T], []);
+
+fun mk_fail T = Const (@{const_name "Fixrec.fail"}, mk_matchT T);
+
+fun return_const T = Const (@{const_name "Fixrec.return"}, T ->> mk_matchT T);
+fun mk_return t = return_const (fastype_of t) ` t;
+
+
+(*** lifted boolean type ***)
+
+val trT = @{typ "tr"};
+
+
+(*** theory of fixed points ***)
+
+fun mk_fix t =
+ let val (T, _) = dest_cfunT (fastype_of t)
+ in mk_capply (Const(@{const_name fix}, (T ->> T) ->> T), t) end;
+
+fun iterate_const T =
+ Const (@{const_name iterate}, natT --> (T ->> T) ->> (T ->> T));
+
+fun mk_iterate (n, f) =
+ let val (T, _) = dest_cfunT (Term.fastype_of f);
+ in (iterate_const T $ n) ` f ` mk_bottom T end;
+
+end;
--- a/src/HOLCF/Tools/repdef.ML Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOLCF/Tools/repdef.ML Wed Mar 03 16:43:55 2010 +0100
@@ -20,32 +20,28 @@
structure Repdef :> REPDEF =
struct
+open HOLCF_Library;
+
+infixr 6 ->>;
+infix -->>;
+
(** type definitions **)
type rep_info =
{ emb_def: thm, prj_def: thm, approx_def: thm, REP: thm };
-(* building terms *)
+(* building types and terms *)
-fun adm_const T = Const (@{const_name adm}, (T --> HOLogic.boolT) --> HOLogic.boolT);
-fun mk_adm (x, T, P) = adm_const T $ absfree (x, T, P);
-
-fun below_const T = Const (@{const_name below}, T --> T --> HOLogic.boolT);
-
-val natT = @{typ nat};
val udomT = @{typ udom};
fun alg_deflT T = Type (@{type_name alg_defl}, [T]);
-fun cfunT (T, U) = Type (@{type_name "->"}, [T, U]);
-fun emb_const T = Const (@{const_name emb}, cfunT (T, udomT));
-fun prj_const T = Const (@{const_name prj}, cfunT (udomT, T));
-fun approx_const T = Const (@{const_name approx}, natT --> cfunT (T, T));
+fun emb_const T = Const (@{const_name emb}, T ->> udomT);
+fun prj_const T = Const (@{const_name prj}, udomT ->> T);
+fun approx_const T = Const (@{const_name approx}, natT --> (T ->> T));
-fun LAM_const (T, U) = Const (@{const_name Abs_CFun}, (T --> U) --> cfunT (T, U));
-fun APP_const (T, U) = Const (@{const_name Rep_CFun}, cfunT (T, U) --> (T --> U));
-fun cast_const T = Const (@{const_name cast}, cfunT (alg_deflT T, cfunT (T, T)));
+fun cast_const T = Const (@{const_name cast}, alg_deflT T ->> T ->> T);
fun mk_cast (t, x) =
- APP_const (udomT, udomT)
- $ (APP_const (alg_deflT udomT, cfunT (udomT, udomT)) $ cast_const udomT $ t)
+ capply_const (udomT, udomT)
+ $ (capply_const (alg_deflT udomT, udomT ->> udomT) $ cast_const udomT $ t)
$ x;
(* manipulating theorems *)
@@ -99,12 +95,12 @@
(*definitions*)
val Rep_const = Const (#Rep_name info, newT --> udomT);
val Abs_const = Const (#Abs_name info, udomT --> newT);
- val emb_eqn = Logic.mk_equals (emb_const newT, LAM_const (newT, udomT) $ Rep_const);
- val prj_eqn = Logic.mk_equals (prj_const newT, LAM_const (udomT, newT) $
+ val emb_eqn = Logic.mk_equals (emb_const newT, cabs_const (newT, udomT) $ Rep_const);
+ val prj_eqn = Logic.mk_equals (prj_const newT, cabs_const (udomT, newT) $
Abs ("x", udomT, Abs_const $ mk_cast (defl, Bound 0)));
val repdef_approx_const =
Const (@{const_name repdef_approx}, (newT --> udomT) --> (udomT --> newT)
- --> alg_deflT udomT --> natT --> cfunT (newT, newT));
+ --> alg_deflT udomT --> natT --> (newT ->> newT));
val approx_eqn = Logic.mk_equals (approx_const newT,
repdef_approx_const $ Rep_const $ Abs_const $ defl);
--- a/src/HOLCF/ex/Dnat.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOLCF/ex/Dnat.thy Wed Mar 03 16:43:55 2010 +0100
@@ -55,17 +55,17 @@
apply (induct_tac x rule: dnat.ind)
apply fast
apply (rule allI)
- apply (rule_tac x = y in dnat.casedist)
+ apply (case_tac y)
apply simp
apply simp
apply simp
apply (rule allI)
- apply (rule_tac x = y in dnat.casedist)
+ apply (case_tac y)
apply (fast intro!: UU_I)
- apply (thin_tac "ALL y. d << y --> d = UU | d = y")
+ apply (thin_tac "ALL y. dnat << y --> dnat = UU | dnat = y")
apply simp
apply (simp (no_asm_simp))
- apply (drule_tac x="da" in spec)
+ apply (drule_tac x="dnata" in spec)
apply simp
done
--- a/src/HOLCF/ex/Domain_Proofs.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOLCF/ex/Domain_Proofs.thy Wed Mar 03 16:43:55 2010 +0100
@@ -196,7 +196,7 @@
by (rule bar_defl_unfold)
lemma REP_baz': "REP('a baz) = REP(('a foo convex_pd \<rightarrow> tr)\<^sub>\<bottom>)"
-unfolding REP_foo REP_bar REP_baz REP_simps
+unfolding REP_foo REP_bar REP_baz REP_simps REP_convex
by (rule baz_defl_unfold)
(********************************************************************)
--- a/src/HOLCF/ex/Domain_ex.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOLCF/ex/Domain_ex.thy Wed Mar 03 16:43:55 2010 +0100
@@ -99,7 +99,7 @@
text {* Trivial datatypes will produce a warning message. *}
-domain triv = triv1 triv triv
+domain triv = Triv triv triv
-- "domain Domain_ex.triv is empty!"
lemma "(x::triv) = \<bottom>" by (induct x, simp_all)
@@ -122,7 +122,7 @@
text {* Rules about constructors *}
term Leaf
term Node
-thm tree.Leaf_def tree.Node_def
+thm Leaf_def Node_def
thm tree.exhaust
thm tree.casedist
thm tree.compacts
@@ -134,7 +134,7 @@
text {* Rules about case combinator *}
term tree_when
-thm tree.when_def
+thm tree.tree_when_def
thm tree.when_rews
text {* Rules about selectors *}
@@ -157,16 +157,17 @@
term match_Node
thm tree.match_rews
-text {* Rules about copy function *}
-term tree_copy
-thm tree.copy_def
-thm tree.copy_rews
-
text {* Rules about take function *}
term tree_take
thm tree.take_def
+thm tree.take_0
+thm tree.take_Suc
thm tree.take_rews
+thm tree.chain_take
+thm tree.take_take
+thm tree.deflation_take
thm tree.take_lemmas
+thm tree.reach
thm tree.finite_ind
text {* Rules about finiteness predicate *}
--- a/src/HOLCF/ex/New_Domain.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOLCF/ex/New_Domain.thy Wed Mar 03 16:43:55 2010 +0100
@@ -51,12 +51,12 @@
thm ltree.reach
text {*
- The definition of the copy function uses map functions associated with
+ The definition of the take function uses map functions associated with
each type constructor involved in the definition. A map function
for the lazy list type has been generated by the new domain package.
*}
-thm ltree.copy_def
+thm ltree.take_rews
thm llist_map_def
lemma ltree_induct:
@@ -67,24 +67,24 @@
assumes Branch: "\<And>f l. \<forall>x. P (f\<cdot>x) \<Longrightarrow> P (Branch\<cdot>(llist_map\<cdot>f\<cdot>l))"
shows "P x"
proof -
- have "\<forall>x. P (fix\<cdot>ltree_copy\<cdot>x)"
- proof (rule fix_ind)
- show "adm (\<lambda>a. \<forall>x. P (a\<cdot>x))"
- by (simp add: adm_subst [OF _ adm])
- next
- show "\<forall>x. P (\<bottom>\<cdot>x)"
- by (simp add: bot)
- next
- fix f :: "'a ltree \<rightarrow> 'a ltree"
- assume f: "\<forall>x. P (f\<cdot>x)"
- show "\<forall>x. P (ltree_copy\<cdot>f\<cdot>x)"
- apply (rule allI)
- apply (case_tac x)
- apply (simp add: bot)
- apply (simp add: Leaf)
- apply (simp add: Branch [OF f])
- done
- qed
+ have "P (\<Squnion>i. ltree_take i\<cdot>x)"
+ using adm
+ proof (rule admD)
+ fix i
+ show "P (ltree_take i\<cdot>x)"
+ proof (induct i arbitrary: x)
+ case (0 x)
+ show "P (ltree_take 0\<cdot>x)" by (simp add: bot)
+ next
+ case (Suc n x)
+ show "P (ltree_take (Suc n)\<cdot>x)"
+ apply (cases x)
+ apply (simp add: bot)
+ apply (simp add: Leaf)
+ apply (simp add: Branch Suc)
+ done
+ qed
+ qed (simp add: ltree.chain_take)
thus ?thesis
by (simp add: ltree.reach)
qed
--- a/src/HOLCF/ex/Stream.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOLCF/ex/Stream.thy Wed Mar 03 16:43:55 2010 +0100
@@ -143,16 +143,10 @@
lemma stream_reach2: "(LUB i. stream_take i$s) = s"
-apply (insert stream.reach [of s], erule subst) back
-apply (simp add: fix_def2 stream.take_def)
-apply (insert contlub_cfun_fun [of "%i. iterate i$stream_copy$UU" s,THEN sym])
-by simp
+by (rule stream.reach)
lemma chain_stream_take: "chain (%i. stream_take i$s)"
-apply (rule chainI)
-apply (rule monofun_cfun_fun)
-apply (simp add: stream.take_def del: iterate_Suc)
-by (rule chainE, simp)
+by (simp add: stream.chain_take)
lemma stream_take_prefix [simp]: "stream_take n$s << s"
apply (insert stream_reach2 [of s])
@@ -259,10 +253,9 @@
lemma stream_ind2:
"[| adm P; P UU; !!a. a ~= UU ==> P (a && UU); !!a b s. [| a ~= UU; b ~= UU; P s |] ==> P (a && b && s) |] ==> P x"
apply (insert stream.reach [of x],erule subst)
-apply (frule adm_impl_admw, rule wfix_ind, auto)
-apply (rule adm_subst [THEN adm_impl_admw],auto)
+apply (erule admD, rule chain_stream_take)
apply (insert stream_finite_ind2 [of P])
-by (simp add: stream.take_def)
+by simp
@@ -275,16 +268,9 @@
lemma stream_coind_lemma2: "!s1 s2. R s1 s2 --> ft$s1 = ft$s2 & R (rt$s1) (rt$s2) ==> stream_bisim R"
apply (simp add: stream.bisim_def,clarsimp)
- apply (case_tac "x=UU",clarsimp)
- apply (erule_tac x="UU" in allE,simp)
- apply (case_tac "x'=UU",simp)
- apply (drule stream_exhaust_eq [THEN iffD1],auto)+
- apply (case_tac "x'=UU",auto)
- apply (erule_tac x="a && y" in allE)
- apply (erule_tac x="UU" in allE)+
- apply (auto,drule stream_exhaust_eq [THEN iffD1],clarsimp)
- apply (erule_tac x="a && y" in allE)
- apply (erule_tac x="aa && ya" in allE) back
+ apply (drule spec, drule spec, drule (1) mp)
+ apply (case_tac "x", simp)
+ apply (case_tac "x'", simp)
by auto
@@ -304,12 +290,12 @@
lemma stream_finite_lemma1: "stream_finite xs ==> stream_finite (x && xs)"
apply (simp add: stream.finite_def,auto)
-apply (rule_tac x="Suc n" in exI)
+apply (rule_tac x="Suc i" in exI)
by (simp add: stream_take_lemma4)
lemma stream_finite_lemma2: "[| x ~= UU; stream_finite (x && xs) |] ==> stream_finite xs"
apply (simp add: stream.finite_def, auto)
-apply (rule_tac x="n" in exI)
+apply (rule_tac x="i" in exI)
by (erule stream_take_lemma3,simp)
lemma stream_finite_rt_eq: "stream_finite (rt$s) = stream_finite s"
@@ -379,8 +365,8 @@
lemma slen_scons_eq_rev: "(#x < Fin (Suc (Suc n))) = (!a y. x ~= a && y | a = \<bottom> | #y < Fin (Suc n))"
apply (rule stream.casedist [of x], auto)
apply (simp add: zero_inat_def)
- apply (case_tac "#s") apply (simp_all add: iSuc_Fin)
- apply (case_tac "#s") apply (simp_all add: iSuc_Fin)
+ apply (case_tac "#stream") apply (simp_all add: iSuc_Fin)
+ apply (case_tac "#stream") apply (simp_all add: iSuc_Fin)
done
lemma slen_take_lemma4 [rule_format]:
--- a/src/HOLCF/ex/Strict_Fun.thy Wed Mar 03 15:40:39 2010 +0100
+++ b/src/HOLCF/ex/Strict_Fun.thy Wed Mar 03 16:43:55 2010 +0100
@@ -232,8 +232,8 @@
setup {*
Domain_Isomorphism.add_type_constructor
- (@{type_name "sfun"}, @{term sfun_defl}, @{const_name sfun_map},
- @{thm REP_sfun}, @{thm isodefl_sfun}, @{thm sfun_map_ID})
+ (@{type_name "sfun"}, @{term sfun_defl}, @{const_name sfun_map}, @{thm REP_sfun},
+ @{thm isodefl_sfun}, @{thm sfun_map_ID}, @{thm deflation_sfun_map})
*}
end
--- a/src/Tools/nbe.ML Wed Mar 03 15:40:39 2010 +0100
+++ b/src/Tools/nbe.ML Wed Mar 03 16:43:55 2010 +0100
@@ -235,7 +235,7 @@
fun nbe_dict v n = "d_" ^ v ^ "_" ^ string_of_int n;
fun nbe_bound v = "v_" ^ v;
fun nbe_bound_optional NONE = "_"
- | nbe_bound_optional (SOME v) = nbe_bound v;
+ | nbe_bound_optional (SOME v) = nbe_bound v;
fun nbe_default v = "w_" ^ v;
(*note: these three are the "turning spots" where proper argument order is established!*)
@@ -434,7 +434,7 @@
#-> fold (fn (name, univ) => (Graph.map_node name o apfst) (K (SOME univ))))
end;
-fun ensure_stmts ctxt naming program =
+fun ensure_stmts ctxt program =
let
fun add_stmts names (gr, (maxidx, idx_tab)) = if exists ((can o Graph.get_node) gr) names
then (gr, (maxidx, idx_tab))
@@ -443,7 +443,6 @@
Graph.imm_succs program name)) names);
in
fold_rev add_stmts (Graph.strong_conn program)
- #> pair naming
end;
@@ -513,18 +512,18 @@
structure Nbe_Functions = Code_Data
(
- type T = Code_Thingol.naming * ((Univ option * int) Graph.T * (int * string Inttab.table));
- val empty = (Code_Thingol.empty_naming, (Graph.empty, (0, Inttab.empty)));
+ type T = (Univ option * int) Graph.T * (int * string Inttab.table);
+ val empty = (Graph.empty, (0, Inttab.empty));
);
(* compilation, evaluation and reification *)
-fun compile_eval thy naming program vs_t deps =
+fun compile_eval thy program vs_t deps =
let
val ctxt = ProofContext.init thy;
- val (_, (gr, (_, idx_tab))) =
- Nbe_Functions.change thy (ensure_stmts ctxt naming program o snd);
+ val (gr, (_, idx_tab)) =
+ Nbe_Functions.change thy (ensure_stmts ctxt program);
in
vs_t
|> eval_term ctxt gr deps
@@ -534,7 +533,7 @@
(* evaluation with type reconstruction *)
-fun normalize thy naming program ((vs0, (vs, ty)), t) deps =
+fun normalize thy program ((vs0, (vs, ty)), t) deps =
let
val ty' = typ_of_itype program vs0 ty;
fun type_infer t =
@@ -546,7 +545,7 @@
^ setmp_CRITICAL show_types true (Syntax.string_of_term_global thy) t);
val string_of_term = setmp_CRITICAL show_types true (Syntax.string_of_term_global thy);
in
- compile_eval thy naming program (vs, t) deps
+ compile_eval thy program (vs, t) deps
|> traced (fn t => "Normalized:\n" ^ string_of_term t)
|> type_infer
|> traced (fn t => "Types inferred:\n" ^ string_of_term t)
@@ -565,11 +564,11 @@
in Thm.mk_binop eq lhs rhs end;
val (_, raw_norm_oracle) = Context.>>> (Context.map_theory_result
- (Thm.add_oracle (Binding.name "norm", fn (thy, naming, program, vsp_ty_t, deps, ct) =>
- mk_equals thy ct (normalize thy naming program vsp_ty_t deps))));
+ (Thm.add_oracle (Binding.name "norm", fn (thy, program, vsp_ty_t, deps, ct) =>
+ mk_equals thy ct (normalize thy program vsp_ty_t deps))));
-fun norm_oracle thy naming program vsp_ty_t deps ct =
- raw_norm_oracle (thy, naming, program, vsp_ty_t, deps, ct);
+fun norm_oracle thy program vsp_ty_t deps ct =
+ raw_norm_oracle (thy, program, vsp_ty_t, deps, ct);
fun no_frees_conv conv ct =
let
@@ -597,9 +596,9 @@
val norm_conv = no_frees_conv (fn ct =>
let
val thy = Thm.theory_of_cterm ct;
- in lift_triv_classes_conv thy (Code_Thingol.eval_conv thy (norm_oracle thy)) ct end);
+ in lift_triv_classes_conv thy (Code_Thingol.eval_conv thy (K (norm_oracle thy))) ct end);
-fun norm thy = lift_triv_classes_rew thy (no_frees_rew (Code_Thingol.eval thy I (normalize thy)));
+fun norm thy = lift_triv_classes_rew thy (no_frees_rew (Code_Thingol.eval thy I (K (normalize thy))));
(* evaluation command *)