author  wenzelm 
Sun, 11 Jan 2009 21:49:59 +0100  
changeset 29450  ac7f67be7f1f 
parent 27239  f2f42f9fa09d 
child 35128  c1ad622e90e4 
permissions  rwrr 
19757  1 
(* Title: LCF/LCF.thy 
0  2 
ID: $Id$ 
1474  3 
Author: Tobias Nipkow 
0  4 
Copyright 1992 University of Cambridge 
5 
*) 

6 

17248  7 
header {* LCF on top of FirstOrder Logic *} 
0  8 

17248  9 
theory LCF 
10 
imports FOL 

11 
begin 

0  12 

17248  13 
text {* This theory is based on Lawrence Paulson's book Logic and Computation. *} 
0  14 

17248  15 
subsection {* Natural Deduction Rules for LCF *} 
16 

17 
classes cpo < "term" 

18 
defaultsort cpo 

19 

20 
typedecl tr 

21 
typedecl void 

22 
typedecl ('a,'b) "*" (infixl 6) 

23 
typedecl ('a,'b) "+" (infixl 5) 

0  24 

283  25 
arities 
27208
5fe899199f85
proper context for tactics derived from res_inst_tac;
wenzelm
parents:
22810
diff
changeset

26 
"fun" :: (cpo, cpo) cpo 
17248  27 
"*" :: (cpo, cpo) cpo 
28 
"+" :: (cpo, cpo) cpo 

29 
tr :: cpo 

30 
void :: cpo 

0  31 

32 
consts 

1474  33 
UU :: "'a" 
17248  34 
TT :: "tr" 
35 
FF :: "tr" 

1474  36 
FIX :: "('a => 'a) => 'a" 
37 
FST :: "'a*'b => 'a" 

38 
SND :: "'a*'b => 'b" 

0  39 
INL :: "'a => 'a+'b" 
40 
INR :: "'b => 'a+'b" 

41 
WHEN :: "['a=>'c, 'b=>'c, 'a+'b] => 'c" 

1474  42 
adm :: "('a => o) => o" 
43 
VOID :: "void" ("'(')") 

44 
PAIR :: "['a,'b] => 'a*'b" ("(1<_,/_>)" [0,0] 100) 

45 
COND :: "[tr,'a,'a] => 'a" ("(_ =>/ (_ / _))" [60,60,60] 60) 

22810  46 
less :: "['a,'a] => o" (infixl "<<" 50) 
17248  47 

48 
axioms 

0  49 
(** DOMAIN THEORY **) 
50 

17248  51 
eq_def: "x=y == x << y & y << x" 
0  52 

17248  53 
less_trans: "[ x << y; y << z ] ==> x << z" 
0  54 

17248  55 
less_ext: "(ALL x. f(x) << g(x)) ==> f << g" 
0  56 

17248  57 
mono: "[ f << g; x << y ] ==> f(x) << g(y)" 
0  58 

17248  59 
minimal: "UU << x" 
0  60 

17248  61 
FIX_eq: "f(FIX(f)) = FIX(f)" 
0  62 

63 
(** TR **) 

64 

17248  65 
tr_cases: "p=UU  p=TT  p=FF" 
0  66 

17248  67 
not_TT_less_FF: "~ TT << FF" 
68 
not_FF_less_TT: "~ FF << TT" 

69 
not_TT_less_UU: "~ TT << UU" 

70 
not_FF_less_UU: "~ FF << UU" 

0  71 

17248  72 
COND_UU: "UU => x  y = UU" 
73 
COND_TT: "TT => x  y = x" 

74 
COND_FF: "FF => x  y = y" 

0  75 

76 
(** PAIRS **) 

77 

17248  78 
surj_pairing: "<FST(z),SND(z)> = z" 
0  79 

17248  80 
FST: "FST(<x,y>) = x" 
81 
SND: "SND(<x,y>) = y" 

0  82 

83 
(*** STRICT SUM ***) 

84 

17248  85 
INL_DEF: "~x=UU ==> ~INL(x)=UU" 
86 
INR_DEF: "~x=UU ==> ~INR(x)=UU" 

0  87 

17248  88 
INL_STRICT: "INL(UU) = UU" 
89 
INR_STRICT: "INR(UU) = UU" 

0  90 

17248  91 
WHEN_UU: "WHEN(f,g,UU) = UU" 
92 
WHEN_INL: "~x=UU ==> WHEN(f,g,INL(x)) = f(x)" 

93 
WHEN_INR: "~x=UU ==> WHEN(f,g,INR(x)) = g(x)" 

0  94 

17248  95 
SUM_EXHAUSTION: 
0  96 
"z = UU  (EX x. ~x=UU & z = INL(x))  (EX y. ~y=UU & z = INR(y))" 
97 

98 
(** VOID **) 

99 

17248  100 
void_cases: "(x::void) = UU" 
0  101 

102 
(** INDUCTION **) 

103 

17248  104 
induct: "[ adm(P); P(UU); ALL x. P(x) > P(f(x)) ] ==> P(FIX(f))" 
0  105 

106 
(** Admissibility / Chain Completeness **) 

107 
(* All rules can be found on pages 199200 of Larry's LCF book. 

108 
Note that "easiness" of types is not taken into account 

109 
because it cannot be expressed schematically; flatness could be. *) 

110 

17248  111 
adm_less: "adm(%x. t(x) << u(x))" 
112 
adm_not_less: "adm(%x.~ t(x) << u)" 

113 
adm_not_free: "adm(%x. A)" 

114 
adm_subst: "adm(P) ==> adm(%x. P(t(x)))" 

115 
adm_conj: "[ adm(P); adm(Q) ] ==> adm(%x. P(x)&Q(x))" 

116 
adm_disj: "[ adm(P); adm(Q) ] ==> adm(%x. P(x)Q(x))" 

117 
adm_imp: "[ adm(%x.~P(x)); adm(Q) ] ==> adm(%x. P(x)>Q(x))" 

118 
adm_all: "(!!y. adm(P(y))) ==> adm(%x. ALL y. P(y,x))" 

119 

19757  120 

121 
lemma eq_imp_less1: "x = y ==> x << y" 

122 
by (simp add: eq_def) 

123 

124 
lemma eq_imp_less2: "x = y ==> y << x" 

125 
by (simp add: eq_def) 

126 

127 
lemma less_refl [simp]: "x << x" 

128 
apply (rule eq_imp_less1) 

129 
apply (rule refl) 

130 
done 

131 

132 
lemma less_anti_sym: "[ x << y; y << x ] ==> x=y" 

133 
by (simp add: eq_def) 

134 

135 
lemma ext: "(!!x::'a::cpo. f(x)=(g(x)::'b::cpo)) ==> (%x. f(x))=(%x. g(x))" 

136 
apply (rule less_anti_sym) 

137 
apply (rule less_ext) 

138 
apply simp 

139 
apply simp 

140 
done 

141 

142 
lemma cong: "[ f=g; x=y ] ==> f(x)=g(y)" 

143 
by simp 

144 

145 
lemma less_ap_term: "x << y ==> f(x) << f(y)" 

146 
by (rule less_refl [THEN mono]) 

147 

148 
lemma less_ap_thm: "f << g ==> f(x) << g(x)" 

149 
by (rule less_refl [THEN [2] mono]) 

150 

151 
lemma ap_term: "(x::'a::cpo) = y ==> (f(x)::'b::cpo) = f(y)" 

152 
apply (rule cong [OF refl]) 

153 
apply simp 

154 
done 

155 

156 
lemma ap_thm: "f = g ==> f(x) = g(x)" 

157 
apply (erule cong) 

158 
apply (rule refl) 

159 
done 

160 

161 

162 
lemma UU_abs: "(%x::'a::cpo. UU) = UU" 

163 
apply (rule less_anti_sym) 

164 
prefer 2 

165 
apply (rule minimal) 

166 
apply (rule less_ext) 

167 
apply (rule allI) 

168 
apply (rule minimal) 

169 
done 

170 

171 
lemma UU_app: "UU(x) = UU" 

172 
by (rule UU_abs [symmetric, THEN ap_thm]) 

173 

174 
lemma less_UU: "x << UU ==> x=UU" 

175 
apply (rule less_anti_sym) 

176 
apply assumption 

177 
apply (rule minimal) 

178 
done 

17248  179 

19757  180 
lemma tr_induct: "[ P(UU); P(TT); P(FF) ] ==> ALL b. P(b)" 
181 
apply (rule allI) 

182 
apply (rule mp) 

183 
apply (rule_tac [2] p = b in tr_cases) 

184 
apply blast 

185 
done 

186 

187 
lemma Contrapos: "~ B ==> (A ==> B) ==> ~A" 

188 
by blast 

189 

190 
lemma not_less_imp_not_eq1: "~ x << y \<Longrightarrow> x \<noteq> y" 

191 
apply (erule Contrapos) 

192 
apply simp 

193 
done 

194 

195 
lemma not_less_imp_not_eq2: "~ y << x \<Longrightarrow> x \<noteq> y" 

196 
apply (erule Contrapos) 

197 
apply simp 

198 
done 

199 

200 
lemma not_UU_eq_TT: "UU \<noteq> TT" 

201 
by (rule not_less_imp_not_eq2) (rule not_TT_less_UU) 

202 
lemma not_UU_eq_FF: "UU \<noteq> FF" 

203 
by (rule not_less_imp_not_eq2) (rule not_FF_less_UU) 

204 
lemma not_TT_eq_UU: "TT \<noteq> UU" 

205 
by (rule not_less_imp_not_eq1) (rule not_TT_less_UU) 

206 
lemma not_TT_eq_FF: "TT \<noteq> FF" 

207 
by (rule not_less_imp_not_eq1) (rule not_TT_less_FF) 

208 
lemma not_FF_eq_UU: "FF \<noteq> UU" 

209 
by (rule not_less_imp_not_eq1) (rule not_FF_less_UU) 

210 
lemma not_FF_eq_TT: "FF \<noteq> TT" 

211 
by (rule not_less_imp_not_eq1) (rule not_FF_less_TT) 

212 

213 

214 
lemma COND_cases_iff [rule_format]: 

215 
"ALL b. P(b=>xy) <> (b=UU>P(UU)) & (b=TT>P(x)) & (b=FF>P(y))" 

216 
apply (insert not_UU_eq_TT not_UU_eq_FF not_TT_eq_UU 

217 
not_TT_eq_FF not_FF_eq_UU not_FF_eq_TT) 

218 
apply (rule tr_induct) 

219 
apply (simplesubst COND_UU) 

220 
apply blast 

221 
apply (simplesubst COND_TT) 

222 
apply blast 

223 
apply (simplesubst COND_FF) 

224 
apply blast 

225 
done 

226 

227 
lemma COND_cases: 

228 
"[ x = UU > P(UU); x = TT > P(xa); x = FF > P(y) ] ==> P(x => xa  y)" 

229 
apply (rule COND_cases_iff [THEN iffD2]) 

230 
apply blast 

231 
done 

232 

233 
lemmas [simp] = 

234 
minimal 

235 
UU_app 

236 
UU_app [THEN ap_thm] 

237 
UU_app [THEN ap_thm, THEN ap_thm] 

238 
not_TT_less_FF not_FF_less_TT not_TT_less_UU not_FF_less_UU not_UU_eq_TT 

239 
not_UU_eq_FF not_TT_eq_UU not_TT_eq_FF not_FF_eq_UU not_FF_eq_TT 

240 
COND_UU COND_TT COND_FF 

241 
surj_pairing FST SND 

17248  242 

243 

244 
subsection {* Ordered pairs and products *} 

245 

19757  246 
lemma expand_all_PROD: "(ALL p. P(p)) <> (ALL x y. P(<x,y>))" 
247 
apply (rule iffI) 

248 
apply blast 

249 
apply (rule allI) 

250 
apply (rule surj_pairing [THEN subst]) 

251 
apply blast 

252 
done 

253 

254 
lemma PROD_less: "(p::'a*'b) << q <> FST(p) << FST(q) & SND(p) << SND(q)" 

255 
apply (rule iffI) 

256 
apply (rule conjI) 

257 
apply (erule less_ap_term) 

258 
apply (erule less_ap_term) 

259 
apply (erule conjE) 

260 
apply (rule surj_pairing [of p, THEN subst]) 

261 
apply (rule surj_pairing [of q, THEN subst]) 

262 
apply (rule mono, erule less_ap_term, assumption) 

263 
done 

264 

265 
lemma PROD_eq: "p=q <> FST(p)=FST(q) & SND(p)=SND(q)" 

266 
apply (rule iffI) 

267 
apply simp 

268 
apply (unfold eq_def) 

269 
apply (simp add: PROD_less) 

270 
done 

271 

272 
lemma PAIR_less [simp]: "<a,b> << <c,d> <> a<<c & b<<d" 

273 
by (simp add: PROD_less) 

274 

275 
lemma PAIR_eq [simp]: "<a,b> = <c,d> <> a=c & b=d" 

276 
by (simp add: PROD_eq) 

277 

278 
lemma UU_is_UU_UU [simp]: "<UU,UU> = UU" 

279 
by (rule less_UU) (simp add: PROD_less) 

280 

281 
lemma FST_STRICT [simp]: "FST(UU) = UU" 

282 
apply (rule subst [OF UU_is_UU_UU]) 

283 
apply (simp del: UU_is_UU_UU) 

284 
done 

285 

286 
lemma SND_STRICT [simp]: "SND(UU) = UU" 

287 
apply (rule subst [OF UU_is_UU_UU]) 

288 
apply (simp del: UU_is_UU_UU) 

289 
done 

17248  290 

291 

292 
subsection {* Fixedpoint theory *} 

293 

19757  294 
lemma adm_eq: "adm(%x. t(x)=(u(x)::'a::cpo))" 
295 
apply (unfold eq_def) 

296 
apply (rule adm_conj adm_less)+ 

297 
done 

298 

299 
lemma adm_not_not: "adm(P) ==> adm(%x.~~P(x))" 

300 
by simp 

301 

302 
lemma not_eq_TT: "ALL p. ~p=TT <> (p=FF  p=UU)" 

303 
and not_eq_FF: "ALL p. ~p=FF <> (p=TT  p=UU)" 

304 
and not_eq_UU: "ALL p. ~p=UU <> (p=TT  p=FF)" 

305 
by (rule tr_induct, simp_all)+ 

306 

307 
lemma adm_not_eq_tr: "ALL p::tr. adm(%x. ~t(x)=p)" 

308 
apply (rule tr_induct) 

309 
apply (simp_all add: not_eq_TT not_eq_FF not_eq_UU) 

310 
apply (rule adm_disj adm_eq)+ 

311 
done 

312 

313 
lemmas adm_lemmas = 

314 
adm_not_free adm_eq adm_less adm_not_less 

315 
adm_not_eq_tr adm_conj adm_disj adm_imp adm_all 

316 

317 

318 
ML {* 

27208
5fe899199f85
proper context for tactics derived from res_inst_tac;
wenzelm
parents:
22810
diff
changeset

319 
fun induct_tac ctxt v i = 
27239  320 
res_inst_tac ctxt [(("f", 0), v)] @{thm induct} i THEN 
22810  321 
REPEAT (resolve_tac @{thms adm_lemmas} i) 
19757  322 
*} 
323 

324 
lemma least_FIX: "f(p) = p ==> FIX(f) << p" 

27208
5fe899199f85
proper context for tactics derived from res_inst_tac;
wenzelm
parents:
22810
diff
changeset

325 
apply (tactic {* induct_tac @{context} "f" 1 *}) 
19757  326 
apply (rule minimal) 
327 
apply (intro strip) 

328 
apply (erule subst) 

329 
apply (erule less_ap_term) 

330 
done 

331 

332 
lemma lfp_is_FIX: 

333 
assumes 1: "f(p) = p" 

334 
and 2: "ALL q. f(q)=q > p << q" 

335 
shows "p = FIX(f)" 

336 
apply (rule less_anti_sym) 

337 
apply (rule 2 [THEN spec, THEN mp]) 

338 
apply (rule FIX_eq) 

339 
apply (rule least_FIX) 

340 
apply (rule 1) 

341 
done 

342 

343 

344 
lemma FIX_pair: "<FIX(f),FIX(g)> = FIX(%p.<f(FST(p)),g(SND(p))>)" 

345 
apply (rule lfp_is_FIX) 

346 
apply (simp add: FIX_eq [of f] FIX_eq [of g]) 

347 
apply (intro strip) 

348 
apply (simp add: PROD_less) 

349 
apply (rule conjI) 

350 
apply (rule least_FIX) 

351 
apply (erule subst, rule FST [symmetric]) 

352 
apply (rule least_FIX) 

353 
apply (erule subst, rule SND [symmetric]) 

354 
done 

355 

356 
lemma FIX1: "FIX(f) = FST(FIX(%p. <f(FST(p)),g(SND(p))>))" 

357 
by (rule FIX_pair [unfolded PROD_eq FST SND, THEN conjunct1]) 

358 

359 
lemma FIX2: "FIX(g) = SND(FIX(%p. <f(FST(p)),g(SND(p))>))" 

360 
by (rule FIX_pair [unfolded PROD_eq FST SND, THEN conjunct2]) 

361 

362 
lemma induct2: 

363 
assumes 1: "adm(%p. P(FST(p),SND(p)))" 

364 
and 2: "P(UU::'a,UU::'b)" 

365 
and 3: "ALL x y. P(x,y) > P(f(x),g(y))" 

366 
shows "P(FIX(f),FIX(g))" 

367 
apply (rule FIX1 [THEN ssubst, of _ f g]) 

368 
apply (rule FIX2 [THEN ssubst, of _ f g]) 

19758  369 
apply (rule induct [where ?f = "%x. <f(FST(x)),g(SND(x))>"]) 
370 
apply (rule 1) 

19757  371 
apply simp 
372 
apply (rule 2) 

373 
apply (simp add: expand_all_PROD) 

374 
apply (rule 3) 

375 
done 

376 

377 
ML {* 

27208
5fe899199f85
proper context for tactics derived from res_inst_tac;
wenzelm
parents:
22810
diff
changeset

378 
fun induct2_tac ctxt (f, g) i = 
27239  379 
res_inst_tac ctxt [(("f", 0), f), (("g", 0), g)] @{thm induct2} i THEN 
22810  380 
REPEAT(resolve_tac @{thms adm_lemmas} i) 
19757  381 
*} 
382 

383 
end 