| author | mengj | 
| Wed, 19 Oct 2005 10:25:46 +0200 | |
| changeset 17907 | c20e4bddcb11 | 
| parent 17589 | 58eeffd73be1 | 
| child 20799 | 46694b230cfb | 
| permissions | -rw-r--r-- | 
| 10213 | 1  | 
(* Title: HOL/Datatype_Universe.thy  | 
2  | 
ID: $Id$  | 
|
3  | 
Author: Lawrence C Paulson, Cambridge University Computer Laboratory  | 
|
4  | 
Copyright 1993 University of Cambridge  | 
|
5  | 
||
6  | 
Could <*> be generalized to a general summation (Sigma)?  | 
|
7  | 
*)  | 
|
8  | 
||
| 15388 | 9  | 
header{*Analogues of the Cartesian Product and Disjoint Sum for Datatypes*}
 | 
| 10213 | 10  | 
|
| 15388 | 11  | 
theory Datatype_Universe  | 
12  | 
imports NatArith Sum_Type  | 
|
13  | 
begin  | 
|
| 10213 | 14  | 
|
15  | 
||
16  | 
typedef (Node)  | 
|
| 11483 | 17  | 
  ('a,'b) node = "{p. EX f x k. p = (f::nat=>'b+nat, x::'a+nat) & f k = Inr 0}"
 | 
| 15388 | 18  | 
    --{*it is a subtype of @{text "(nat=>'b+nat) * ('a+nat)"}*}
 | 
19  | 
by auto  | 
|
| 10213 | 20  | 
|
| 15388 | 21  | 
text{*Datatypes will be represented by sets of type @{text node}*}
 | 
22  | 
||
23  | 
types 'a item        = "('a, unit) node set"
 | 
|
24  | 
      ('a, 'b) dtree = "('a, 'b) node set"
 | 
|
| 10213 | 25  | 
|
26  | 
consts  | 
|
27  | 
apfst :: "['a=>'c, 'a*'b] => 'c*'b"  | 
|
28  | 
  Push      :: "[('b + nat), nat => ('b + nat)] => (nat => ('b + nat))"
 | 
|
29  | 
||
30  | 
  Push_Node :: "[('b + nat), ('a, 'b) node] => ('a, 'b) node"
 | 
|
| 15388 | 31  | 
  ndepth    :: "('a, 'b) node => nat"
 | 
| 10213 | 32  | 
|
33  | 
  Atom      :: "('a + nat) => ('a, 'b) dtree"
 | 
|
| 15388 | 34  | 
  Leaf      :: "'a => ('a, 'b) dtree"
 | 
35  | 
  Numb      :: "nat => ('a, 'b) dtree"
 | 
|
36  | 
  Scons     :: "[('a, 'b) dtree, ('a, 'b) dtree] => ('a, 'b) dtree"
 | 
|
37  | 
  In0       :: "('a, 'b) dtree => ('a, 'b) dtree"
 | 
|
38  | 
  In1       :: "('a, 'b) dtree => ('a, 'b) dtree"
 | 
|
39  | 
  Lim       :: "('b => ('a, 'b) dtree) => ('a, 'b) dtree"
 | 
|
| 10213 | 40  | 
|
| 15388 | 41  | 
  ntrunc    :: "[nat, ('a, 'b) dtree] => ('a, 'b) dtree"
 | 
| 10213 | 42  | 
|
| 15388 | 43  | 
  uprod     :: "[('a, 'b) dtree set, ('a, 'b) dtree set]=> ('a, 'b) dtree set"
 | 
44  | 
  usum      :: "[('a, 'b) dtree set, ('a, 'b) dtree set]=> ('a, 'b) dtree set"
 | 
|
| 10213 | 45  | 
|
| 15388 | 46  | 
  Split     :: "[[('a, 'b) dtree, ('a, 'b) dtree]=>'c, ('a, 'b) dtree] => 'c"
 | 
47  | 
  Case      :: "[[('a, 'b) dtree]=>'c, [('a, 'b) dtree]=>'c, ('a, 'b) dtree] => 'c"
 | 
|
| 10213 | 48  | 
|
| 15388 | 49  | 
  dprod     :: "[(('a, 'b) dtree * ('a, 'b) dtree)set, (('a, 'b) dtree * ('a, 'b) dtree)set]
 | 
| 10213 | 50  | 
                => (('a, 'b) dtree * ('a, 'b) dtree)set"
 | 
| 15388 | 51  | 
  dsum      :: "[(('a, 'b) dtree * ('a, 'b) dtree)set, (('a, 'b) dtree * ('a, 'b) dtree)set]
 | 
| 10213 | 52  | 
                => (('a, 'b) dtree * ('a, 'b) dtree)set"
 | 
53  | 
||
54  | 
||
55  | 
defs  | 
|
56  | 
||
| 15388 | 57  | 
Push_Node_def: "Push_Node == (%n x. Abs_Node (apfst (Push n) (Rep_Node x)))"  | 
| 10213 | 58  | 
|
59  | 
(*crude "lists" of nats -- needed for the constructions*)  | 
|
| 15388 | 60  | 
apfst_def: "apfst == (%f (x,y). (f(x),y))"  | 
61  | 
Push_def: "Push == (%b h. nat_case b h)"  | 
|
| 10213 | 62  | 
|
63  | 
(** operations on S-expressions -- sets of nodes **)  | 
|
64  | 
||
65  | 
(*S-expression constructors*)  | 
|
| 15388 | 66  | 
  Atom_def:   "Atom == (%x. {Abs_Node((%k. Inr 0, x))})"
 | 
67  | 
Scons_def: "Scons M N == (Push_Node (Inr 1) ` M) Un (Push_Node (Inr (Suc 1)) ` N)"  | 
|
| 10213 | 68  | 
|
69  | 
(*Leaf nodes, with arbitrary or nat labels*)  | 
|
| 15388 | 70  | 
Leaf_def: "Leaf == Atom o Inl"  | 
71  | 
Numb_def: "Numb == Atom o Inr"  | 
|
| 10213 | 72  | 
|
73  | 
(*Injections of the "disjoint sum"*)  | 
|
| 15388 | 74  | 
In0_def: "In0(M) == Scons (Numb 0) M"  | 
75  | 
In1_def: "In1(M) == Scons (Numb 1) M"  | 
|
| 10213 | 76  | 
|
77  | 
(*Function spaces*)  | 
|
| 15388 | 78  | 
  Lim_def: "Lim f == Union {z. ? x. z = Push_Node (Inl x) ` (f x)}"
 | 
| 10213 | 79  | 
|
80  | 
(*the set of nodes with depth less than k*)  | 
|
| 15388 | 81  | 
ndepth_def: "ndepth(n) == (%(f,x). LEAST k. f k = Inr 0) (Rep_Node n)"  | 
82  | 
  ntrunc_def: "ntrunc k N == {n. n:N & ndepth(n)<k}"
 | 
|
| 10213 | 83  | 
|
84  | 
(*products and sums for the "universe"*)  | 
|
| 15388 | 85  | 
  uprod_def:  "uprod A B == UN x:A. UN y:B. { Scons x y }"
 | 
86  | 
usum_def: "usum A B == In0`A Un In1`B"  | 
|
| 10213 | 87  | 
|
88  | 
(*the corresponding eliminators*)  | 
|
| 15388 | 89  | 
Split_def: "Split c M == THE u. EX x y. M = Scons x y & u = c x y"  | 
| 10213 | 90  | 
|
| 15388 | 91  | 
Case_def: "Case c d M == THE u. (EX x . M = In0(x) & u = c(x))  | 
| 
11451
 
8abfb4f7bd02
partial restructuring to reduce dependence on Axiom of Choice
 
paulson 
parents: 
10832 
diff
changeset
 | 
92  | 
| (EX y . M = In1(y) & u = d(y))"  | 
| 10213 | 93  | 
|
94  | 
||
95  | 
(** equality for the "universe" **)  | 
|
96  | 
||
| 15388 | 97  | 
  dprod_def:  "dprod r s == UN (x,x'):r. UN (y,y'):s. {(Scons x y, Scons x' y')}"
 | 
| 10213 | 98  | 
|
| 15388 | 99  | 
  dsum_def:   "dsum r s == (UN (x,x'):r. {(In0(x),In0(x'))}) Un
 | 
| 10213 | 100  | 
                          (UN (y,y'):s. {(In1(y),In1(y'))})"
 | 
101  | 
||
| 15388 | 102  | 
|
103  | 
||
104  | 
(** apfst -- can be used in similar type definitions **)  | 
|
105  | 
||
106  | 
lemma apfst_conv [simp]: "apfst f (a,b) = (f(a),b)"  | 
|
107  | 
by (simp add: apfst_def)  | 
|
108  | 
||
109  | 
||
110  | 
lemma apfst_convE:  | 
|
111  | 
"[| q = apfst f p; !!x y. [| p = (x,y); q = (f(x),y) |] ==> R  | 
|
112  | 
|] ==> R"  | 
|
113  | 
by (force simp add: apfst_def)  | 
|
114  | 
||
115  | 
(** Push -- an injection, analogous to Cons on lists **)  | 
|
116  | 
||
117  | 
lemma Push_inject1: "Push i f = Push j g ==> i=j"  | 
|
118  | 
apply (simp add: Push_def expand_fun_eq)  | 
|
119  | 
apply (drule_tac x=0 in spec, simp)  | 
|
120  | 
done  | 
|
121  | 
||
122  | 
lemma Push_inject2: "Push i f = Push j g ==> f=g"  | 
|
123  | 
apply (auto simp add: Push_def expand_fun_eq)  | 
|
124  | 
apply (drule_tac x="Suc x" in spec, simp)  | 
|
125  | 
done  | 
|
126  | 
||
127  | 
lemma Push_inject:  | 
|
128  | 
"[| Push i f =Push j g; [| i=j; f=g |] ==> P |] ==> P"  | 
|
129  | 
by (blast dest: Push_inject1 Push_inject2)  | 
|
130  | 
||
131  | 
lemma Push_neq_K0: "Push (Inr (Suc k)) f = (%z. Inr 0) ==> P"  | 
|
132  | 
by (auto simp add: Push_def expand_fun_eq split: nat.split_asm)  | 
|
133  | 
||
| 15413 | 134  | 
lemmas Abs_Node_inj = Abs_Node_inject [THEN [2] rev_iffD1, standard]  | 
| 15388 | 135  | 
|
136  | 
||
137  | 
(*** Introduction rules for Node ***)  | 
|
138  | 
||
139  | 
lemma Node_K0_I: "(%k. Inr 0, a) : Node"  | 
|
140  | 
by (simp add: Node_def)  | 
|
141  | 
||
| 15413 | 142  | 
lemma Node_Push_I: "p: Node ==> apfst (Push i) p : Node"  | 
| 15388 | 143  | 
apply (simp add: Node_def Push_def)  | 
144  | 
apply (fast intro!: apfst_conv nat_case_Suc [THEN trans])  | 
|
145  | 
done  | 
|
146  | 
||
147  | 
||
| 17472 | 148  | 
subsection{*Freeness: Distinctness of Constructors*}
 | 
| 15388 | 149  | 
|
150  | 
(** Scons vs Atom **)  | 
|
151  | 
||
152  | 
lemma Scons_not_Atom [iff]: "Scons M N \<noteq> Atom(a)"  | 
|
153  | 
apply (simp add: Atom_def Scons_def Push_Node_def One_nat_def)  | 
|
154  | 
apply (blast intro: Node_K0_I Rep_Node [THEN Node_Push_I]  | 
|
155  | 
dest!: Abs_Node_inj  | 
|
156  | 
elim!: apfst_convE sym [THEN Push_neq_K0])  | 
|
157  | 
done  | 
|
158  | 
||
| 
17084
 
fb0a80aef0be
classical rules must have names for ATP integration
 
paulson 
parents: 
15413 
diff
changeset
 | 
159  | 
lemmas Atom_not_Scons = Scons_not_Atom [THEN not_sym, standard]  | 
| 
 
fb0a80aef0be
classical rules must have names for ATP integration
 
paulson 
parents: 
15413 
diff
changeset
 | 
160  | 
declare Atom_not_Scons [iff]  | 
| 15388 | 161  | 
|
162  | 
(*** Injectiveness ***)  | 
|
163  | 
||
164  | 
(** Atomic nodes **)  | 
|
165  | 
||
166  | 
lemma inj_Atom: "inj(Atom)"  | 
|
167  | 
apply (simp add: Atom_def)  | 
|
168  | 
apply (blast intro!: inj_onI Node_K0_I dest!: Abs_Node_inj)  | 
|
169  | 
done  | 
|
170  | 
lemmas Atom_inject = inj_Atom [THEN injD, standard]  | 
|
171  | 
||
172  | 
lemma Atom_Atom_eq [iff]: "(Atom(a)=Atom(b)) = (a=b)"  | 
|
173  | 
by (blast dest!: Atom_inject)  | 
|
174  | 
||
175  | 
lemma inj_Leaf: "inj(Leaf)"  | 
|
176  | 
apply (simp add: Leaf_def o_def)  | 
|
177  | 
apply (rule inj_onI)  | 
|
178  | 
apply (erule Atom_inject [THEN Inl_inject])  | 
|
179  | 
done  | 
|
180  | 
||
| 
17084
 
fb0a80aef0be
classical rules must have names for ATP integration
 
paulson 
parents: 
15413 
diff
changeset
 | 
181  | 
lemmas Leaf_inject = inj_Leaf [THEN injD, standard]  | 
| 
 
fb0a80aef0be
classical rules must have names for ATP integration
 
paulson 
parents: 
15413 
diff
changeset
 | 
182  | 
declare Leaf_inject [dest!]  | 
| 15388 | 183  | 
|
184  | 
lemma inj_Numb: "inj(Numb)"  | 
|
185  | 
apply (simp add: Numb_def o_def)  | 
|
186  | 
apply (rule inj_onI)  | 
|
187  | 
apply (erule Atom_inject [THEN Inr_inject])  | 
|
188  | 
done  | 
|
189  | 
||
| 
17084
 
fb0a80aef0be
classical rules must have names for ATP integration
 
paulson 
parents: 
15413 
diff
changeset
 | 
190  | 
lemmas Numb_inject = inj_Numb [THEN injD, standard]  | 
| 
 
fb0a80aef0be
classical rules must have names for ATP integration
 
paulson 
parents: 
15413 
diff
changeset
 | 
191  | 
declare Numb_inject [dest!]  | 
| 15388 | 192  | 
|
193  | 
||
194  | 
(** Injectiveness of Push_Node **)  | 
|
195  | 
||
196  | 
lemma Push_Node_inject:  | 
|
197  | 
"[| Push_Node i m =Push_Node j n; [| i=j; m=n |] ==> P  | 
|
198  | 
|] ==> P"  | 
|
199  | 
apply (simp add: Push_Node_def)  | 
|
200  | 
apply (erule Abs_Node_inj [THEN apfst_convE])  | 
|
201  | 
apply (rule Rep_Node [THEN Node_Push_I])+  | 
|
202  | 
apply (erule sym [THEN apfst_convE])  | 
|
| 15413 | 203  | 
apply (blast intro: Rep_Node_inject [THEN iffD1] trans sym elim!: Push_inject)  | 
| 15388 | 204  | 
done  | 
205  | 
||
206  | 
||
207  | 
(** Injectiveness of Scons **)  | 
|
208  | 
||
209  | 
lemma Scons_inject_lemma1: "Scons M N <= Scons M' N' ==> M<=M'"  | 
|
210  | 
apply (simp add: Scons_def One_nat_def)  | 
|
211  | 
apply (blast dest!: Push_Node_inject)  | 
|
212  | 
done  | 
|
213  | 
||
214  | 
lemma Scons_inject_lemma2: "Scons M N <= Scons M' N' ==> N<=N'"  | 
|
215  | 
apply (simp add: Scons_def One_nat_def)  | 
|
216  | 
apply (blast dest!: Push_Node_inject)  | 
|
217  | 
done  | 
|
218  | 
||
219  | 
lemma Scons_inject1: "Scons M N = Scons M' N' ==> M=M'"  | 
|
220  | 
apply (erule equalityE)  | 
|
| 17589 | 221  | 
apply (iprover intro: equalityI Scons_inject_lemma1)  | 
| 15388 | 222  | 
done  | 
223  | 
||
224  | 
lemma Scons_inject2: "Scons M N = Scons M' N' ==> N=N'"  | 
|
225  | 
apply (erule equalityE)  | 
|
| 17589 | 226  | 
apply (iprover intro: equalityI Scons_inject_lemma2)  | 
| 15388 | 227  | 
done  | 
228  | 
||
229  | 
lemma Scons_inject:  | 
|
230  | 
"[| Scons M N = Scons M' N'; [| M=M'; N=N' |] ==> P |] ==> P"  | 
|
| 17589 | 231  | 
by (iprover dest: Scons_inject1 Scons_inject2)  | 
| 15388 | 232  | 
|
233  | 
lemma Scons_Scons_eq [iff]: "(Scons M N = Scons M' N') = (M=M' & N=N')"  | 
|
234  | 
by (blast elim!: Scons_inject)  | 
|
235  | 
||
236  | 
(*** Distinctness involving Leaf and Numb ***)  | 
|
237  | 
||
238  | 
(** Scons vs Leaf **)  | 
|
239  | 
||
240  | 
lemma Scons_not_Leaf [iff]: "Scons M N \<noteq> Leaf(a)"  | 
|
241  | 
by (simp add: Leaf_def o_def Scons_not_Atom)  | 
|
242  | 
||
| 
17084
 
fb0a80aef0be
classical rules must have names for ATP integration
 
paulson 
parents: 
15413 
diff
changeset
 | 
243  | 
lemmas Leaf_not_Scons = Scons_not_Leaf [THEN not_sym, standard]  | 
| 
 
fb0a80aef0be
classical rules must have names for ATP integration
 
paulson 
parents: 
15413 
diff
changeset
 | 
244  | 
declare Leaf_not_Scons [iff]  | 
| 15388 | 245  | 
|
246  | 
(** Scons vs Numb **)  | 
|
247  | 
||
248  | 
lemma Scons_not_Numb [iff]: "Scons M N \<noteq> Numb(k)"  | 
|
249  | 
by (simp add: Numb_def o_def Scons_not_Atom)  | 
|
250  | 
||
| 
17084
 
fb0a80aef0be
classical rules must have names for ATP integration
 
paulson 
parents: 
15413 
diff
changeset
 | 
251  | 
lemmas Numb_not_Scons = Scons_not_Numb [THEN not_sym, standard]  | 
| 
 
fb0a80aef0be
classical rules must have names for ATP integration
 
paulson 
parents: 
15413 
diff
changeset
 | 
252  | 
declare Numb_not_Scons [iff]  | 
| 15388 | 253  | 
|
254  | 
||
255  | 
(** Leaf vs Numb **)  | 
|
256  | 
||
257  | 
lemma Leaf_not_Numb [iff]: "Leaf(a) \<noteq> Numb(k)"  | 
|
258  | 
by (simp add: Leaf_def Numb_def)  | 
|
259  | 
||
| 
17084
 
fb0a80aef0be
classical rules must have names for ATP integration
 
paulson 
parents: 
15413 
diff
changeset
 | 
260  | 
lemmas Numb_not_Leaf = Leaf_not_Numb [THEN not_sym, standard]  | 
| 
 
fb0a80aef0be
classical rules must have names for ATP integration
 
paulson 
parents: 
15413 
diff
changeset
 | 
261  | 
declare Numb_not_Leaf [iff]  | 
| 15388 | 262  | 
|
263  | 
||
264  | 
(*** ndepth -- the depth of a node ***)  | 
|
265  | 
||
266  | 
lemma ndepth_K0: "ndepth (Abs_Node(%k. Inr 0, x)) = 0"  | 
|
267  | 
by (simp add: ndepth_def Node_K0_I [THEN Abs_Node_inverse] Least_equality)  | 
|
268  | 
||
269  | 
lemma ndepth_Push_Node_aux:  | 
|
270  | 
"nat_case (Inr (Suc i)) f k = Inr 0 --> Suc(LEAST x. f x = Inr 0) <= k"  | 
|
271  | 
apply (induct_tac "k", auto)  | 
|
272  | 
apply (erule Least_le)  | 
|
273  | 
done  | 
|
274  | 
||
275  | 
lemma ndepth_Push_Node:  | 
|
276  | 
"ndepth (Push_Node (Inr (Suc i)) n) = Suc(ndepth(n))"  | 
|
277  | 
apply (insert Rep_Node [of n, unfolded Node_def])  | 
|
278  | 
apply (auto simp add: ndepth_def Push_Node_def  | 
|
279  | 
Rep_Node [THEN Node_Push_I, THEN Abs_Node_inverse])  | 
|
280  | 
apply (rule Least_equality)  | 
|
281  | 
apply (auto simp add: Push_def ndepth_Push_Node_aux)  | 
|
282  | 
apply (erule LeastI)  | 
|
283  | 
done  | 
|
284  | 
||
285  | 
||
286  | 
(*** ntrunc applied to the various node sets ***)  | 
|
287  | 
||
288  | 
lemma ntrunc_0 [simp]: "ntrunc 0 M = {}"
 | 
|
289  | 
by (simp add: ntrunc_def)  | 
|
290  | 
||
291  | 
lemma ntrunc_Atom [simp]: "ntrunc (Suc k) (Atom a) = Atom(a)"  | 
|
292  | 
by (auto simp add: Atom_def ntrunc_def ndepth_K0)  | 
|
293  | 
||
294  | 
lemma ntrunc_Leaf [simp]: "ntrunc (Suc k) (Leaf a) = Leaf(a)"  | 
|
295  | 
by (simp add: Leaf_def o_def ntrunc_Atom)  | 
|
296  | 
||
297  | 
lemma ntrunc_Numb [simp]: "ntrunc (Suc k) (Numb i) = Numb(i)"  | 
|
298  | 
by (simp add: Numb_def o_def ntrunc_Atom)  | 
|
299  | 
||
300  | 
lemma ntrunc_Scons [simp]:  | 
|
301  | 
"ntrunc (Suc k) (Scons M N) = Scons (ntrunc k M) (ntrunc k N)"  | 
|
302  | 
by (auto simp add: Scons_def ntrunc_def One_nat_def ndepth_Push_Node)  | 
|
303  | 
||
304  | 
||
305  | 
||
306  | 
(** Injection nodes **)  | 
|
307  | 
||
308  | 
lemma ntrunc_one_In0 [simp]: "ntrunc (Suc 0) (In0 M) = {}"
 | 
|
309  | 
apply (simp add: In0_def)  | 
|
310  | 
apply (simp add: Scons_def)  | 
|
311  | 
done  | 
|
312  | 
||
313  | 
lemma ntrunc_In0 [simp]: "ntrunc (Suc(Suc k)) (In0 M) = In0 (ntrunc (Suc k) M)"  | 
|
314  | 
by (simp add: In0_def)  | 
|
315  | 
||
316  | 
lemma ntrunc_one_In1 [simp]: "ntrunc (Suc 0) (In1 M) = {}"
 | 
|
317  | 
apply (simp add: In1_def)  | 
|
318  | 
apply (simp add: Scons_def)  | 
|
319  | 
done  | 
|
320  | 
||
321  | 
lemma ntrunc_In1 [simp]: "ntrunc (Suc(Suc k)) (In1 M) = In1 (ntrunc (Suc k) M)"  | 
|
322  | 
by (simp add: In1_def)  | 
|
323  | 
||
324  | 
||
325  | 
subsection{*Set Constructions*}
 | 
|
326  | 
||
327  | 
||
328  | 
(*** Cartesian Product ***)  | 
|
329  | 
||
330  | 
lemma uprodI [intro!]: "[| M:A; N:B |] ==> Scons M N : uprod A B"  | 
|
331  | 
by (simp add: uprod_def)  | 
|
332  | 
||
333  | 
(*The general elimination rule*)  | 
|
334  | 
lemma uprodE [elim!]:  | 
|
335  | 
"[| c : uprod A B;  | 
|
336  | 
!!x y. [| x:A; y:B; c = Scons x y |] ==> P  | 
|
337  | 
|] ==> P"  | 
|
338  | 
by (auto simp add: uprod_def)  | 
|
339  | 
||
340  | 
||
341  | 
(*Elimination of a pair -- introduces no eigenvariables*)  | 
|
342  | 
lemma uprodE2: "[| Scons M N : uprod A B; [| M:A; N:B |] ==> P |] ==> P"  | 
|
343  | 
by (auto simp add: uprod_def)  | 
|
344  | 
||
345  | 
||
346  | 
(*** Disjoint Sum ***)  | 
|
347  | 
||
348  | 
lemma usum_In0I [intro]: "M:A ==> In0(M) : usum A B"  | 
|
349  | 
by (simp add: usum_def)  | 
|
350  | 
||
351  | 
lemma usum_In1I [intro]: "N:B ==> In1(N) : usum A B"  | 
|
352  | 
by (simp add: usum_def)  | 
|
353  | 
||
354  | 
lemma usumE [elim!]:  | 
|
355  | 
"[| u : usum A B;  | 
|
356  | 
!!x. [| x:A; u=In0(x) |] ==> P;  | 
|
357  | 
!!y. [| y:B; u=In1(y) |] ==> P  | 
|
358  | 
|] ==> P"  | 
|
359  | 
by (auto simp add: usum_def)  | 
|
360  | 
||
361  | 
||
362  | 
(** Injection **)  | 
|
363  | 
||
364  | 
lemma In0_not_In1 [iff]: "In0(M) \<noteq> In1(N)"  | 
|
365  | 
by (auto simp add: In0_def In1_def One_nat_def)  | 
|
366  | 
||
| 
17084
 
fb0a80aef0be
classical rules must have names for ATP integration
 
paulson 
parents: 
15413 
diff
changeset
 | 
367  | 
lemmas In1_not_In0 = In0_not_In1 [THEN not_sym, standard]  | 
| 
 
fb0a80aef0be
classical rules must have names for ATP integration
 
paulson 
parents: 
15413 
diff
changeset
 | 
368  | 
declare In1_not_In0 [iff]  | 
| 15388 | 369  | 
|
370  | 
lemma In0_inject: "In0(M) = In0(N) ==> M=N"  | 
|
371  | 
by (simp add: In0_def)  | 
|
372  | 
||
373  | 
lemma In1_inject: "In1(M) = In1(N) ==> M=N"  | 
|
374  | 
by (simp add: In1_def)  | 
|
375  | 
||
376  | 
lemma In0_eq [iff]: "(In0 M = In0 N) = (M=N)"  | 
|
377  | 
by (blast dest!: In0_inject)  | 
|
378  | 
||
379  | 
lemma In1_eq [iff]: "(In1 M = In1 N) = (M=N)"  | 
|
380  | 
by (blast dest!: In1_inject)  | 
|
381  | 
||
382  | 
lemma inj_In0: "inj In0"  | 
|
383  | 
by (blast intro!: inj_onI)  | 
|
384  | 
||
385  | 
lemma inj_In1: "inj In1"  | 
|
386  | 
by (blast intro!: inj_onI)  | 
|
387  | 
||
388  | 
||
389  | 
(*** Function spaces ***)  | 
|
390  | 
||
391  | 
lemma Lim_inject: "Lim f = Lim g ==> f = g"  | 
|
392  | 
apply (simp add: Lim_def)  | 
|
393  | 
apply (rule ext)  | 
|
394  | 
apply (blast elim!: Push_Node_inject)  | 
|
395  | 
done  | 
|
396  | 
||
397  | 
||
398  | 
(*** proving equality of sets and functions using ntrunc ***)  | 
|
399  | 
||
400  | 
lemma ntrunc_subsetI: "ntrunc k M <= M"  | 
|
401  | 
by (auto simp add: ntrunc_def)  | 
|
402  | 
||
403  | 
lemma ntrunc_subsetD: "(!!k. ntrunc k M <= N) ==> M<=N"  | 
|
404  | 
by (auto simp add: ntrunc_def)  | 
|
405  | 
||
406  | 
(*A generalized form of the take-lemma*)  | 
|
407  | 
lemma ntrunc_equality: "(!!k. ntrunc k M = ntrunc k N) ==> M=N"  | 
|
408  | 
apply (rule equalityI)  | 
|
409  | 
apply (rule_tac [!] ntrunc_subsetD)  | 
|
410  | 
apply (rule_tac [!] ntrunc_subsetI [THEN [2] subset_trans], auto)  | 
|
411  | 
done  | 
|
412  | 
||
413  | 
lemma ntrunc_o_equality:  | 
|
414  | 
"[| !!k. (ntrunc(k) o h1) = (ntrunc(k) o h2) |] ==> h1=h2"  | 
|
415  | 
apply (rule ntrunc_equality [THEN ext])  | 
|
416  | 
apply (simp add: expand_fun_eq)  | 
|
417  | 
done  | 
|
418  | 
||
419  | 
||
420  | 
(*** Monotonicity ***)  | 
|
421  | 
||
422  | 
lemma uprod_mono: "[| A<=A'; B<=B' |] ==> uprod A B <= uprod A' B'"  | 
|
423  | 
by (simp add: uprod_def, blast)  | 
|
424  | 
||
425  | 
lemma usum_mono: "[| A<=A'; B<=B' |] ==> usum A B <= usum A' B'"  | 
|
426  | 
by (simp add: usum_def, blast)  | 
|
427  | 
||
428  | 
lemma Scons_mono: "[| M<=M'; N<=N' |] ==> Scons M N <= Scons M' N'"  | 
|
429  | 
by (simp add: Scons_def, blast)  | 
|
430  | 
||
431  | 
lemma In0_mono: "M<=N ==> In0(M) <= In0(N)"  | 
|
432  | 
by (simp add: In0_def subset_refl Scons_mono)  | 
|
433  | 
||
434  | 
lemma In1_mono: "M<=N ==> In1(M) <= In1(N)"  | 
|
435  | 
by (simp add: In1_def subset_refl Scons_mono)  | 
|
436  | 
||
437  | 
||
438  | 
(*** Split and Case ***)  | 
|
439  | 
||
440  | 
lemma Split [simp]: "Split c (Scons M N) = c M N"  | 
|
441  | 
by (simp add: Split_def)  | 
|
442  | 
||
443  | 
lemma Case_In0 [simp]: "Case c d (In0 M) = c(M)"  | 
|
444  | 
by (simp add: Case_def)  | 
|
445  | 
||
446  | 
lemma Case_In1 [simp]: "Case c d (In1 N) = d(N)"  | 
|
447  | 
by (simp add: Case_def)  | 
|
448  | 
||
449  | 
||
450  | 
||
451  | 
(**** UN x. B(x) rules ****)  | 
|
452  | 
||
453  | 
lemma ntrunc_UN1: "ntrunc k (UN x. f(x)) = (UN x. ntrunc k (f x))"  | 
|
454  | 
by (simp add: ntrunc_def, blast)  | 
|
455  | 
||
456  | 
lemma Scons_UN1_x: "Scons (UN x. f x) M = (UN x. Scons (f x) M)"  | 
|
457  | 
by (simp add: Scons_def, blast)  | 
|
458  | 
||
459  | 
lemma Scons_UN1_y: "Scons M (UN x. f x) = (UN x. Scons M (f x))"  | 
|
460  | 
by (simp add: Scons_def, blast)  | 
|
461  | 
||
462  | 
lemma In0_UN1: "In0(UN x. f(x)) = (UN x. In0(f(x)))"  | 
|
463  | 
by (simp add: In0_def Scons_UN1_y)  | 
|
464  | 
||
465  | 
lemma In1_UN1: "In1(UN x. f(x)) = (UN x. In1(f(x)))"  | 
|
466  | 
by (simp add: In1_def Scons_UN1_y)  | 
|
467  | 
||
468  | 
||
469  | 
(*** Equality for Cartesian Product ***)  | 
|
470  | 
||
471  | 
lemma dprodI [intro!]:  | 
|
472  | 
"[| (M,M'):r; (N,N'):s |] ==> (Scons M N, Scons M' N') : dprod r s"  | 
|
473  | 
by (auto simp add: dprod_def)  | 
|
474  | 
||
475  | 
(*The general elimination rule*)  | 
|
476  | 
lemma dprodE [elim!]:  | 
|
477  | 
"[| c : dprod r s;  | 
|
478  | 
!!x y x' y'. [| (x,x') : r; (y,y') : s;  | 
|
479  | 
c = (Scons x y, Scons x' y') |] ==> P  | 
|
480  | 
|] ==> P"  | 
|
481  | 
by (auto simp add: dprod_def)  | 
|
482  | 
||
483  | 
||
484  | 
(*** Equality for Disjoint Sum ***)  | 
|
485  | 
||
486  | 
lemma dsum_In0I [intro]: "(M,M'):r ==> (In0(M), In0(M')) : dsum r s"  | 
|
487  | 
by (auto simp add: dsum_def)  | 
|
488  | 
||
489  | 
lemma dsum_In1I [intro]: "(N,N'):s ==> (In1(N), In1(N')) : dsum r s"  | 
|
490  | 
by (auto simp add: dsum_def)  | 
|
491  | 
||
492  | 
lemma dsumE [elim!]:  | 
|
493  | 
"[| w : dsum r s;  | 
|
494  | 
!!x x'. [| (x,x') : r; w = (In0(x), In0(x')) |] ==> P;  | 
|
495  | 
!!y y'. [| (y,y') : s; w = (In1(y), In1(y')) |] ==> P  | 
|
496  | 
|] ==> P"  | 
|
497  | 
by (auto simp add: dsum_def)  | 
|
498  | 
||
499  | 
||
500  | 
(*** Monotonicity ***)  | 
|
501  | 
||
502  | 
lemma dprod_mono: "[| r<=r'; s<=s' |] ==> dprod r s <= dprod r' s'"  | 
|
503  | 
by blast  | 
|
504  | 
||
505  | 
lemma dsum_mono: "[| r<=r'; s<=s' |] ==> dsum r s <= dsum r' s'"  | 
|
506  | 
by blast  | 
|
507  | 
||
508  | 
||
509  | 
(*** Bounding theorems ***)  | 
|
510  | 
||
511  | 
lemma dprod_Sigma: "(dprod (A <*> B) (C <*> D)) <= (uprod A C) <*> (uprod B D)"  | 
|
512  | 
by blast  | 
|
513  | 
||
514  | 
lemmas dprod_subset_Sigma = subset_trans [OF dprod_mono dprod_Sigma, standard]  | 
|
515  | 
||
516  | 
(*Dependent version*)  | 
|
517  | 
lemma dprod_subset_Sigma2:  | 
|
518  | 
"(dprod (Sigma A B) (Sigma C D)) <=  | 
|
519  | 
Sigma (uprod A C) (Split (%x y. uprod (B x) (D y)))"  | 
|
520  | 
by auto  | 
|
521  | 
||
522  | 
lemma dsum_Sigma: "(dsum (A <*> B) (C <*> D)) <= (usum A C) <*> (usum B D)"  | 
|
523  | 
by blast  | 
|
524  | 
||
525  | 
lemmas dsum_subset_Sigma = subset_trans [OF dsum_mono dsum_Sigma, standard]  | 
|
526  | 
||
527  | 
||
528  | 
(*** Domain ***)  | 
|
529  | 
||
530  | 
lemma Domain_dprod [simp]: "Domain (dprod r s) = uprod (Domain r) (Domain s)"  | 
|
531  | 
by auto  | 
|
532  | 
||
533  | 
lemma Domain_dsum [simp]: "Domain (dsum r s) = usum (Domain r) (Domain s)"  | 
|
534  | 
by auto  | 
|
535  | 
||
536  | 
ML  | 
|
537  | 
{*
 | 
|
538  | 
val apfst_conv = thm "apfst_conv";  | 
|
539  | 
val apfst_convE = thm "apfst_convE";  | 
|
540  | 
val Push_inject1 = thm "Push_inject1";  | 
|
541  | 
val Push_inject2 = thm "Push_inject2";  | 
|
542  | 
val Push_inject = thm "Push_inject";  | 
|
543  | 
val Push_neq_K0 = thm "Push_neq_K0";  | 
|
544  | 
val Abs_Node_inj = thm "Abs_Node_inj";  | 
|
545  | 
val Node_K0_I = thm "Node_K0_I";  | 
|
546  | 
val Node_Push_I = thm "Node_Push_I";  | 
|
547  | 
val Scons_not_Atom = thm "Scons_not_Atom";  | 
|
548  | 
val Atom_not_Scons = thm "Atom_not_Scons";  | 
|
549  | 
val inj_Atom = thm "inj_Atom";  | 
|
550  | 
val Atom_inject = thm "Atom_inject";  | 
|
551  | 
val Atom_Atom_eq = thm "Atom_Atom_eq";  | 
|
552  | 
val inj_Leaf = thm "inj_Leaf";  | 
|
553  | 
val Leaf_inject = thm "Leaf_inject";  | 
|
554  | 
val inj_Numb = thm "inj_Numb";  | 
|
555  | 
val Numb_inject = thm "Numb_inject";  | 
|
556  | 
val Push_Node_inject = thm "Push_Node_inject";  | 
|
557  | 
val Scons_inject1 = thm "Scons_inject1";  | 
|
558  | 
val Scons_inject2 = thm "Scons_inject2";  | 
|
559  | 
val Scons_inject = thm "Scons_inject";  | 
|
560  | 
val Scons_Scons_eq = thm "Scons_Scons_eq";  | 
|
561  | 
val Scons_not_Leaf = thm "Scons_not_Leaf";  | 
|
562  | 
val Leaf_not_Scons = thm "Leaf_not_Scons";  | 
|
563  | 
val Scons_not_Numb = thm "Scons_not_Numb";  | 
|
564  | 
val Numb_not_Scons = thm "Numb_not_Scons";  | 
|
565  | 
val Leaf_not_Numb = thm "Leaf_not_Numb";  | 
|
566  | 
val Numb_not_Leaf = thm "Numb_not_Leaf";  | 
|
567  | 
val ndepth_K0 = thm "ndepth_K0";  | 
|
568  | 
val ndepth_Push_Node_aux = thm "ndepth_Push_Node_aux";  | 
|
569  | 
val ndepth_Push_Node = thm "ndepth_Push_Node";  | 
|
570  | 
val ntrunc_0 = thm "ntrunc_0";  | 
|
571  | 
val ntrunc_Atom = thm "ntrunc_Atom";  | 
|
572  | 
val ntrunc_Leaf = thm "ntrunc_Leaf";  | 
|
573  | 
val ntrunc_Numb = thm "ntrunc_Numb";  | 
|
574  | 
val ntrunc_Scons = thm "ntrunc_Scons";  | 
|
575  | 
val ntrunc_one_In0 = thm "ntrunc_one_In0";  | 
|
576  | 
val ntrunc_In0 = thm "ntrunc_In0";  | 
|
577  | 
val ntrunc_one_In1 = thm "ntrunc_one_In1";  | 
|
578  | 
val ntrunc_In1 = thm "ntrunc_In1";  | 
|
579  | 
val uprodI = thm "uprodI";  | 
|
580  | 
val uprodE = thm "uprodE";  | 
|
581  | 
val uprodE2 = thm "uprodE2";  | 
|
582  | 
val usum_In0I = thm "usum_In0I";  | 
|
583  | 
val usum_In1I = thm "usum_In1I";  | 
|
584  | 
val usumE = thm "usumE";  | 
|
585  | 
val In0_not_In1 = thm "In0_not_In1";  | 
|
586  | 
val In1_not_In0 = thm "In1_not_In0";  | 
|
587  | 
val In0_inject = thm "In0_inject";  | 
|
588  | 
val In1_inject = thm "In1_inject";  | 
|
589  | 
val In0_eq = thm "In0_eq";  | 
|
590  | 
val In1_eq = thm "In1_eq";  | 
|
591  | 
val inj_In0 = thm "inj_In0";  | 
|
592  | 
val inj_In1 = thm "inj_In1";  | 
|
593  | 
val Lim_inject = thm "Lim_inject";  | 
|
594  | 
val ntrunc_subsetI = thm "ntrunc_subsetI";  | 
|
595  | 
val ntrunc_subsetD = thm "ntrunc_subsetD";  | 
|
596  | 
val ntrunc_equality = thm "ntrunc_equality";  | 
|
597  | 
val ntrunc_o_equality = thm "ntrunc_o_equality";  | 
|
598  | 
val uprod_mono = thm "uprod_mono";  | 
|
599  | 
val usum_mono = thm "usum_mono";  | 
|
600  | 
val Scons_mono = thm "Scons_mono";  | 
|
601  | 
val In0_mono = thm "In0_mono";  | 
|
602  | 
val In1_mono = thm "In1_mono";  | 
|
603  | 
val Split = thm "Split";  | 
|
604  | 
val Case_In0 = thm "Case_In0";  | 
|
605  | 
val Case_In1 = thm "Case_In1";  | 
|
606  | 
val ntrunc_UN1 = thm "ntrunc_UN1";  | 
|
607  | 
val Scons_UN1_x = thm "Scons_UN1_x";  | 
|
608  | 
val Scons_UN1_y = thm "Scons_UN1_y";  | 
|
609  | 
val In0_UN1 = thm "In0_UN1";  | 
|
610  | 
val In1_UN1 = thm "In1_UN1";  | 
|
611  | 
val dprodI = thm "dprodI";  | 
|
612  | 
val dprodE = thm "dprodE";  | 
|
613  | 
val dsum_In0I = thm "dsum_In0I";  | 
|
614  | 
val dsum_In1I = thm "dsum_In1I";  | 
|
615  | 
val dsumE = thm "dsumE";  | 
|
616  | 
val dprod_mono = thm "dprod_mono";  | 
|
617  | 
val dsum_mono = thm "dsum_mono";  | 
|
618  | 
val dprod_Sigma = thm "dprod_Sigma";  | 
|
619  | 
val dprod_subset_Sigma = thm "dprod_subset_Sigma";  | 
|
620  | 
val dprod_subset_Sigma2 = thm "dprod_subset_Sigma2";  | 
|
621  | 
val dsum_Sigma = thm "dsum_Sigma";  | 
|
622  | 
val dsum_subset_Sigma = thm "dsum_subset_Sigma";  | 
|
623  | 
val Domain_dprod = thm "Domain_dprod";  | 
|
624  | 
val Domain_dsum = thm "Domain_dsum";  | 
|
625  | 
*}  | 
|
626  | 
||
| 10213 | 627  | 
end  |