author  huffman 
Tue, 08 Mar 2005 00:00:49 +0100  
changeset 15588  14e3228f18cc 
parent 15577  e16da3068ad6 
child 15640  2d1d6ea579a1 
permissions  rwrr 
2640  1 
(* Title: HOLCF/Pcpo.thy 
2 
ID: $Id$ 

3 
Author: Franz Regensburger 

15563  4 
License: GPL (GNU GENERAL PUBLIC LICENSE) 
2640  5 

6 
introduction of the classes cpo and pcpo 

7 
*) 

15576
efb95d0d01f7
converted to newstyle theories, and combined numbered files
huffman
parents:
15563
diff
changeset

8 

efb95d0d01f7
converted to newstyle theories, and combined numbered files
huffman
parents:
15563
diff
changeset

9 
header {* Classes cpo and pcpo *} 
efb95d0d01f7
converted to newstyle theories, and combined numbered files
huffman
parents:
15563
diff
changeset

10 

15577  11 
theory Pcpo 
12 
imports Porder 

13 
begin 

243
c22b85994e17
Franz Regensburger's HigherOrder Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset

14 

15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

15 
subsection {* Complete partial orders *} 
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

16 

14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

17 
text {* The class cpo of chain complete partial orders *} 
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

18 

2640  19 
axclass cpo < po 
15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

20 
 {* class axiom: *} 
15563  21 
cpo: "chain S ==> ? x. range S << x" 
2394  22 

15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

23 
text {* in cpo's everthing equal to THE lub has lub properties for every chain *} 
15563  24 

15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

25 
lemma thelubE: "[ chain(S); lub(range(S)) = (l::'a::cpo) ] ==> range(S) << l" 
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

26 
by (blast dest: cpo intro: lubI) 
15563  27 

15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

28 
text {* Properties of the lub *} 
15563  29 

30 
lemma is_ub_thelub: "chain (S::nat => 'a::cpo) ==> S(x) << lub(range(S))" 

15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

31 
by (blast dest: cpo intro: lubI [THEN is_ub_lub]) 
15563  32 

33 
lemma is_lub_thelub: "[ chain (S::nat => 'a::cpo); range(S) < x ] ==> lub(range S) << x" 

15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

34 
by (blast dest: cpo intro: lubI [THEN is_lub_lub]) 
15563  35 

36 
lemma lub_range_mono: "[ range X <= range Y; chain Y; chain (X::nat=>'a::cpo) ] ==> lub(range X) << lub(range Y)" 

37 
apply (erule is_lub_thelub) 

38 
apply (rule ub_rangeI) 

39 
apply (subgoal_tac "? j. X i = Y j") 

40 
apply clarsimp 

41 
apply (erule is_ub_thelub) 

42 
apply auto 

43 
done 

44 

45 
lemma lub_range_shift: "chain (Y::nat=>'a::cpo) ==> lub(range (%i. Y(i + j))) = lub(range Y)" 

46 
apply (rule antisym_less) 

47 
apply (rule lub_range_mono) 

48 
apply fast 

49 
apply assumption 

50 
apply (erule chain_shift) 

51 
apply (rule is_lub_thelub) 

52 
apply assumption 

53 
apply (rule ub_rangeI) 

54 
apply (rule trans_less) 

55 
apply (rule_tac [2] is_ub_thelub) 

56 
apply (erule_tac [2] chain_shift) 

57 
apply (erule chain_mono3) 

58 
apply (rule le_add1) 

59 
done 

60 

61 
lemma maxinch_is_thelub: "chain Y ==> max_in_chain i Y = (lub(range(Y)) = ((Y i)::'a::cpo))" 

62 
apply (rule iffI) 

63 
apply (fast intro!: thelubI lub_finch1) 

64 
apply (unfold max_in_chain_def) 

65 
apply (safe intro!: antisym_less) 

66 
apply (fast elim!: chain_mono3) 

67 
apply (drule sym) 

68 
apply (force elim!: is_ub_thelub) 

69 
done 

70 

15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

71 
text {* the @{text "<<"} relation between two chains is preserved by their lubs *} 
15563  72 

73 
lemma lub_mono: "[chain(C1::(nat=>'a::cpo));chain(C2); ALL k. C1(k) << C2(k)] 

74 
==> lub(range(C1)) << lub(range(C2))" 

75 
apply (erule is_lub_thelub) 

76 
apply (rule ub_rangeI) 

77 
apply (rule trans_less) 

78 
apply (erule spec) 

79 
apply (erule is_ub_thelub) 

80 
done 

81 

15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

82 
text {* the = relation between two chains is preserved by their lubs *} 
15563  83 

84 
lemma lub_equal: "[ chain(C1::(nat=>'a::cpo));chain(C2);ALL k. C1(k)=C2(k)] 

85 
==> lub(range(C1))=lub(range(C2))" 

15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

86 
by (simp only: expand_fun_eq [symmetric]) 
15563  87 

15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

88 
text {* more results about mono and = of lubs of chains *} 
3326  89 

15563  90 
lemma lub_mono2: "[EX j. ALL i. j<i > X(i::nat)=Y(i);chain(X::nat=>'a::cpo);chain(Y)] 
15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

91 
==> lub(range(X))<<lub(range(Y))" 
15563  92 
apply (erule exE) 
93 
apply (rule is_lub_thelub) 

94 
apply assumption 

95 
apply (rule ub_rangeI) 

96 
apply (case_tac "j<i") 

97 
apply (rule_tac s = "Y (i) " and t = "X (i) " in subst) 

98 
apply (rule sym) 

99 
apply fast 

100 
apply (rule is_ub_thelub) 

101 
apply assumption 

102 
apply (rule_tac y = "X (Suc (j))" in trans_less) 

103 
apply (rule chain_mono) 

104 
apply assumption 

105 
apply (rule not_less_eq [THEN subst]) 

106 
apply assumption 

107 
apply (rule_tac s = "Y (Suc (j))" and t = "X (Suc (j))" in subst) 

15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

108 
apply (simp) 
15563  109 
apply (erule is_ub_thelub) 
110 
done 

111 

112 
lemma lub_equal2: "[EX j. ALL i. j<i > X(i)=Y(i); chain(X::nat=>'a::cpo); chain(Y)] 

113 
==> lub(range(X))=lub(range(Y))" 

15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

114 
by (blast intro: antisym_less lub_mono2 sym) 
15563  115 

116 
lemma lub_mono3: "[chain(Y::nat=>'a::cpo);chain(X); 

117 
ALL i. EX j. Y(i)<< X(j)]==> lub(range(Y))<<lub(range(X))" 

118 
apply (rule is_lub_thelub) 

119 
apply assumption 

120 
apply (rule ub_rangeI) 

121 
apply (erule allE) 

122 
apply (erule exE) 

123 
apply (rule trans_less) 

124 
apply (rule_tac [2] is_ub_thelub) 

125 
prefer 2 apply (assumption) 

126 
apply assumption 

127 
done 

128 

15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

129 
subsection {* Pointed cpos *} 
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

130 

14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

131 
text {* The class pcpo of pointed cpos *} 
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

132 

14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

133 
axclass pcpo < cpo 
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

134 
least: "? x.!y. x<<y" 
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

135 

14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

136 
consts 
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

137 
UU :: "'a::pcpo" 
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

138 

14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

139 
syntax (xsymbols) 
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

140 
UU :: "'a::pcpo" ("\<bottom>") 
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

141 

14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

142 
defs 
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

143 
UU_def: "UU == @x.!y. x<<y" 
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

144 

14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

145 
text {* derive the old rule minimal *} 
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

146 

14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

147 
lemma UU_least: "ALL z. UU << z" 
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

148 
apply (unfold UU_def) 
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

149 
apply (rule some_eq_ex [THEN iffD2]) 
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

150 
apply (rule least) 
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

151 
done 
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

152 

14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

153 
lemmas minimal = UU_least [THEN spec, standard] 
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

154 

14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

155 
declare minimal [iff] 
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

156 

14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

157 
text {* useful lemmas about @{term UU} *} 
15563  158 

159 
lemma eq_UU_iff: "(x=UU)=(x<<UU)" 

160 
apply (rule iffI) 

161 
apply (erule ssubst) 

162 
apply (rule refl_less) 

163 
apply (rule antisym_less) 

164 
apply assumption 

165 
apply (rule minimal) 

166 
done 

167 

168 
lemma UU_I: "x << UU ==> x = UU" 

15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

169 
by (subst eq_UU_iff) 
15563  170 

171 
lemma not_less2not_eq: "~(x::'a::po)<<y ==> ~x=y" 

15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

172 
by auto 
15563  173 

174 
lemma chain_UU_I: "[chain(Y);lub(range(Y))=UU] ==> ALL i. Y(i)=UU" 

175 
apply (rule allI) 

176 
apply (rule antisym_less) 

177 
apply (rule_tac [2] minimal) 

178 
apply (erule subst) 

179 
apply (erule is_ub_thelub) 

180 
done 

181 

182 
lemma chain_UU_I_inverse: "ALL i. Y(i::nat)=UU ==> lub(range(Y::(nat=>'a::pcpo)))=UU" 

183 
apply (rule lub_chain_maxelem) 

184 
apply (erule spec) 

15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

185 
apply simp 
15563  186 
done 
187 

188 
lemma chain_UU_I_inverse2: "~lub(range(Y::(nat=>'a::pcpo)))=UU ==> EX i.~ Y(i)=UU" 

15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

189 
by (blast intro: chain_UU_I_inverse) 
15563  190 

191 
lemma notUU_I: "[ x<<y; ~x=UU ] ==> ~y=UU" 

15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

192 
by (blast intro: UU_I) 
15563  193 

194 
lemma chain_mono2: 

195 
"[EX j. ~Y(j)=UU;chain(Y::nat=>'a::pcpo)] ==> EX j. ALL i. j<i>~Y(i)=UU" 

15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

196 
by (blast dest: notUU_I chain_mono) 
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

197 

14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

198 
subsection {* Chainfinite and flat cpos *} 
15563  199 

15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

200 
text {* further useful classes for HOLCF domains *} 
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

201 

14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

202 
axclass chfin < cpo 
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

203 
chfin: "!Y. chain Y>(? n. max_in_chain n Y)" 
15563  204 

15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

205 
axclass flat < pcpo 
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

206 
ax_flat: "! x y. x << y > (x = UU)  (x=y)" 
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

207 

14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

208 
text {* some properties for chfin and flat *} 
15563  209 

15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

210 
text {* flat types are chfin *} 
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

211 

15563  212 
lemma flat_imp_chfin: 
15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

213 
 {*Used only in an "instance" declaration (Fun1.thy)*} 
15563  214 
"ALL Y::nat=>'a::flat. chain Y > (EX n. max_in_chain n Y)" 
215 
apply (unfold max_in_chain_def) 

216 
apply clarify 

217 
apply (case_tac "ALL i. Y (i) =UU") 

218 
apply (rule_tac x = "0" in exI) 

15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

219 
apply simp 
15563  220 
apply simp 
221 
apply (erule exE) 

222 
apply (rule_tac x = "i" in exI) 

15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

223 
apply clarify 
15563  224 
apply (erule le_imp_less_or_eq [THEN disjE]) 
225 
apply safe 

15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

226 
apply (blast dest: chain_mono ax_flat [rule_format]) 
15563  227 
done 
228 

15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

229 
instance flat < chfin 
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

230 
by intro_classes (rule flat_imp_chfin) 
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

231 

14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

232 
text {* flat subclass of chfin @{text ">"} @{text adm_flat} not needed *} 
15563  233 

234 
lemma flat_eq: "(a::'a::flat) ~= UU ==> a << b = (a = b)" 

15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

235 
by (safe dest!: ax_flat [rule_format]) 
15563  236 

237 
lemma chfin2finch: "chain (Y::nat=>'a::chfin) ==> finite_chain Y" 

15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

238 
by (simp add: chfin finite_chain_def) 
15563  239 

15588
14e3228f18cc
arranged for document generation, cleaned up some proofs
huffman
parents:
15577
diff
changeset

240 
text {* lemmata for improved admissibility introdution rule *} 
15563  241 

242 
lemma infinite_chain_adm_lemma: 

243 
"[chain Y; ALL i. P (Y i); 

244 
(!!Y. [ chain Y; ALL i. P (Y i); ~ finite_chain Y ] ==> P (lub(range Y))) 

245 
] ==> P (lub (range Y))" 

246 
apply (case_tac "finite_chain Y") 

247 
prefer 2 apply fast 

248 
apply (unfold finite_chain_def) 

249 
apply safe 

250 
apply (erule lub_finch1 [THEN thelubI, THEN ssubst]) 

251 
apply assumption 

252 
apply (erule spec) 

253 
done 

254 

255 
lemma increasing_chain_adm_lemma: 

256 
"[chain Y; ALL i. P (Y i); 

257 
(!!Y. [ chain Y; ALL i. P (Y i); 

258 
ALL i. EX j. i < j & Y i ~= Y j & Y i << Y j] 

259 
==> P (lub (range Y))) ] ==> P (lub (range Y))" 

260 
apply (erule infinite_chain_adm_lemma) 

261 
apply assumption 

262 
apply (erule thin_rl) 

263 
apply (unfold finite_chain_def) 

264 
apply (unfold max_in_chain_def) 

265 
apply (fast dest: le_imp_less_or_eq elim: chain_mono) 

266 
done 

15576
efb95d0d01f7
converted to newstyle theories, and combined numbered files
huffman
parents:
15563
diff
changeset

267 

243
c22b85994e17
Franz Regensburger's HigherOrder Logic of Computable Functions embedding LCF
nipkow
parents:
diff
changeset

268 
end 