author | paulson |
Wed, 09 Oct 1996 13:32:33 +0200 | |
changeset 2073 | fb0655539d05 |
parent 2033 | 639de962ded4 |
child 2275 | dbce3dce821a |
permissions | -rw-r--r-- |
1461 | 1 |
(* Title: HOLCF/tr1.ML |
243
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
2 |
ID: $Id$ |
1461 | 3 |
Author: Franz Regensburger |
243
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
4 |
Copyright 1993 Technische Universitaet Muenchen |
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
5 |
|
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
6 |
Lemmas for tr1.thy |
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
7 |
*) |
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
8 |
|
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
9 |
open Tr1; |
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
10 |
|
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
11 |
(* -------------------------------------------------------------------------- *) |
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
12 |
(* distinctness for type tr *) |
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
13 |
(* -------------------------------------------------------------------------- *) |
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
14 |
|
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
15 |
val dist_less_tr = [ |
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
16 |
prove_goalw Tr1.thy [TT_def] "~TT << UU" |
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
17 |
(fn prems => |
1461 | 18 |
[ |
19 |
(rtac classical3 1), |
|
20 |
(rtac defined_sinl 1), |
|
21 |
(rtac not_less2not_eq 1), |
|
22 |
(resolve_tac dist_less_one 1), |
|
23 |
(rtac (rep_tr_iso RS subst) 1), |
|
24 |
(rtac (rep_tr_iso RS subst) 1), |
|
25 |
(rtac cfun_arg_cong 1), |
|
2033 | 26 |
(stac ((abs_tr_iso RS allI) RS ((rep_tr_iso RS allI) RS iso_strict ) RS conjunct2) 1), |
1461 | 27 |
(etac (eq_UU_iff RS ssubst) 1) |
28 |
]), |
|
243
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
29 |
prove_goalw Tr1.thy [FF_def] "~FF << UU" |
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
30 |
(fn prems => |
1461 | 31 |
[ |
32 |
(rtac classical3 1), |
|
33 |
(rtac defined_sinr 1), |
|
34 |
(rtac not_less2not_eq 1), |
|
35 |
(resolve_tac dist_less_one 1), |
|
36 |
(rtac (rep_tr_iso RS subst) 1), |
|
37 |
(rtac (rep_tr_iso RS subst) 1), |
|
38 |
(rtac cfun_arg_cong 1), |
|
2033 | 39 |
(stac ((abs_tr_iso RS allI) RS ((rep_tr_iso RS allI) RS iso_strict ) RS conjunct2) 1), |
1461 | 40 |
(etac (eq_UU_iff RS ssubst) 1) |
41 |
]), |
|
243
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
42 |
prove_goalw Tr1.thy [FF_def,TT_def] "~TT << FF" |
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
43 |
(fn prems => |
1461 | 44 |
[ |
45 |
(rtac classical3 1), |
|
46 |
(rtac (less_ssum4c RS iffD1) 2), |
|
47 |
(rtac not_less2not_eq 1), |
|
48 |
(resolve_tac dist_less_one 1), |
|
49 |
(rtac (rep_tr_iso RS subst) 1), |
|
50 |
(rtac (rep_tr_iso RS subst) 1), |
|
51 |
(etac monofun_cfun_arg 1) |
|
52 |
]), |
|
243
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
53 |
prove_goalw Tr1.thy [FF_def,TT_def] "~FF << TT" |
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
54 |
(fn prems => |
1461 | 55 |
[ |
56 |
(rtac classical3 1), |
|
57 |
(rtac (less_ssum4d RS iffD1) 2), |
|
58 |
(rtac not_less2not_eq 1), |
|
59 |
(resolve_tac dist_less_one 1), |
|
60 |
(rtac (rep_tr_iso RS subst) 1), |
|
61 |
(rtac (rep_tr_iso RS subst) 1), |
|
62 |
(etac monofun_cfun_arg 1) |
|
63 |
]) |
|
243
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
64 |
]; |
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
65 |
|
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
66 |
fun prover s = prove_goal Tr1.thy s |
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
67 |
(fn prems => |
1461 | 68 |
[ |
69 |
(rtac not_less2not_eq 1), |
|
70 |
(resolve_tac dist_less_tr 1) |
|
71 |
]); |
|
243
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
72 |
|
1168
74be52691d62
The curried version of HOLCF is now just called HOLCF. The old
regensbu
parents:
892
diff
changeset
|
73 |
val dist_eq_tr = map prover ["TT~=UU","FF~=UU","TT~=FF"]; |
243
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
74 |
val dist_eq_tr = dist_eq_tr @ (map (fn thm => (thm RS not_sym)) dist_eq_tr); |
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
75 |
|
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
76 |
(* ------------------------------------------------------------------------ *) |
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
77 |
(* Exhaustion and elimination for type tr *) |
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
78 |
(* ------------------------------------------------------------------------ *) |
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
79 |
|
892 | 80 |
qed_goalw "Exh_tr" Tr1.thy [FF_def,TT_def] "t=UU | t = TT | t = FF" |
243
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
81 |
(fn prems => |
1461 | 82 |
[ |
83 |
(res_inst_tac [("p","rep_tr`t")] ssumE 1), |
|
84 |
(rtac disjI1 1), |
|
85 |
(rtac ((abs_tr_iso RS allI) RS ((rep_tr_iso RS allI) RS iso_strict ) |
|
86 |
RS conjunct2 RS subst) 1), |
|
87 |
(rtac (abs_tr_iso RS subst) 1), |
|
88 |
(etac cfun_arg_cong 1), |
|
89 |
(rtac disjI2 1), |
|
90 |
(rtac disjI1 1), |
|
91 |
(rtac (abs_tr_iso RS subst) 1), |
|
92 |
(rtac cfun_arg_cong 1), |
|
93 |
(etac trans 1), |
|
94 |
(rtac cfun_arg_cong 1), |
|
95 |
(rtac (Exh_one RS disjE) 1), |
|
96 |
(contr_tac 1), |
|
97 |
(atac 1), |
|
98 |
(rtac disjI2 1), |
|
99 |
(rtac disjI2 1), |
|
100 |
(rtac (abs_tr_iso RS subst) 1), |
|
101 |
(rtac cfun_arg_cong 1), |
|
102 |
(etac trans 1), |
|
103 |
(rtac cfun_arg_cong 1), |
|
104 |
(rtac (Exh_one RS disjE) 1), |
|
105 |
(contr_tac 1), |
|
106 |
(atac 1) |
|
107 |
]); |
|
243
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
108 |
|
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
109 |
|
892 | 110 |
qed_goal "trE" Tr1.thy |
1461 | 111 |
"[| p=UU ==> Q; p = TT ==>Q; p = FF ==>Q|] ==>Q" |
243
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
112 |
(fn prems => |
1461 | 113 |
[ |
114 |
(rtac (Exh_tr RS disjE) 1), |
|
115 |
(eresolve_tac prems 1), |
|
116 |
(etac disjE 1), |
|
117 |
(eresolve_tac prems 1), |
|
118 |
(eresolve_tac prems 1) |
|
119 |
]); |
|
243
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
120 |
|
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
121 |
|
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
122 |
(* ------------------------------------------------------------------------ *) |
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
123 |
(* type tr is flat *) |
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
124 |
(* ------------------------------------------------------------------------ *) |
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
125 |
|
1410
324aa8134639
changed predicate flat to is_flat in theory Fix.thy
regensbu
parents:
1267
diff
changeset
|
126 |
qed_goalw "flat_tr" Tr1.thy [is_flat_def] "is_flat(TT)" |
430 | 127 |
(fn prems => |
1461 | 128 |
[ |
129 |
(rtac allI 1), |
|
130 |
(rtac allI 1), |
|
131 |
(res_inst_tac [("p","x")] trE 1), |
|
132 |
(Asm_simp_tac 1), |
|
133 |
(res_inst_tac [("p","y")] trE 1), |
|
134 |
(asm_simp_tac (!simpset addsimps dist_less_tr) 1), |
|
135 |
(asm_simp_tac (!simpset addsimps dist_less_tr) 1), |
|
136 |
(asm_simp_tac (!simpset addsimps dist_less_tr) 1), |
|
137 |
(res_inst_tac [("p","y")] trE 1), |
|
138 |
(asm_simp_tac (!simpset addsimps dist_less_tr) 1), |
|
139 |
(asm_simp_tac (!simpset addsimps dist_less_tr) 1), |
|
140 |
(asm_simp_tac (!simpset addsimps dist_less_tr) 1) |
|
141 |
]); |
|
243
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
142 |
|
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
143 |
|
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
144 |
(* ------------------------------------------------------------------------ *) |
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
145 |
(* properties of tr_when *) |
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
146 |
(* ------------------------------------------------------------------------ *) |
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
147 |
|
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
148 |
fun prover s = prove_goalw Tr1.thy [tr_when_def,TT_def,FF_def] s |
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
149 |
(fn prems => |
1461 | 150 |
[ |
151 |
(Simp_tac 1), |
|
152 |
(simp_tac (!simpset addsimps [(rep_tr_iso ), |
|
153 |
(abs_tr_iso RS allI) RS ((rep_tr_iso RS allI) |
|
154 |
RS iso_strict) RS conjunct1]@dist_eq_one)1) |
|
155 |
]); |
|
243
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
156 |
|
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
157 |
val tr_when = map prover [ |
1461 | 158 |
"tr_when`x`y`UU = UU", |
159 |
"tr_when`x`y`TT = x", |
|
160 |
"tr_when`x`y`FF = y" |
|
161 |
]; |
|
243
c22b85994e17
Franz Regensburger's Higher-Order Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset
|
162 |