|
1 (* Title: HOL/UNITY/Lift |
|
2 ID: $Id$ |
|
3 Author: Lawrence C Paulson, Cambridge University Computer Laboratory |
|
4 Copyright 1998 University of Cambridge |
|
5 |
|
6 The Lift-Control Example |
|
7 *) |
|
8 |
|
9 Goal "[| x ~: A; y : A |] ==> x ~= y"; |
|
10 by (Blast_tac 1); |
|
11 qed "not_mem_distinct"; |
|
12 |
|
13 |
|
14 Addsimps [Lift_def RS def_prg_Init]; |
|
15 program_defs_ref := [Lift_def]; |
|
16 |
|
17 Addsimps (map simp_of_act |
|
18 [request_act_def, open_act_def, close_act_def, |
|
19 req_up_def, req_down_def, move_up_def, move_down_def, |
|
20 button_press_def]); |
|
21 |
|
22 (*The ALWAYS properties*) |
|
23 Addsimps (map simp_of_set [above_def, below_def, queueing_def, |
|
24 goingup_def, goingdown_def, ready_def]); |
|
25 |
|
26 Addsimps [bounded_def, open_stop_def, open_move_def, stop_floor_def, |
|
27 moving_up_def, moving_down_def]; |
|
28 |
|
29 AddIffs [Min_le_Max]; |
|
30 |
|
31 Goal "Lift : Always open_stop"; |
|
32 by (always_tac 1); |
|
33 qed "open_stop"; |
|
34 |
|
35 Goal "Lift : Always stop_floor"; |
|
36 by (always_tac 1); |
|
37 qed "stop_floor"; |
|
38 |
|
39 (*This one needs open_stop, which was proved above*) |
|
40 Goal "Lift : Always open_move"; |
|
41 by (cut_facts_tac [open_stop] 1); |
|
42 by (always_tac 1); |
|
43 qed "open_move"; |
|
44 |
|
45 Goal "Lift : Always moving_up"; |
|
46 by (always_tac 1); |
|
47 by (auto_tac (claset() addDs [zle_imp_zless_or_eq], |
|
48 simpset() addsimps [add1_zle_eq])); |
|
49 qed "moving_up"; |
|
50 |
|
51 Goal "Lift : Always moving_down"; |
|
52 by (always_tac 1); |
|
53 by (blast_tac (claset() addDs [zle_imp_zless_or_eq]) 1); |
|
54 qed "moving_down"; |
|
55 |
|
56 Goal "Lift : Always bounded"; |
|
57 by (cut_facts_tac [moving_up, moving_down] 1); |
|
58 by (always_tac 1); |
|
59 by Auto_tac; |
|
60 by (ALLGOALS (dtac not_mem_distinct THEN' assume_tac)); |
|
61 by (ALLGOALS arith_tac); |
|
62 qed "bounded"; |
|
63 |
|
64 |
|
65 |
|
66 (*** Progress ***) |
|
67 |
|
68 |
|
69 val abbrev_defs = [moving_def, stopped_def, |
|
70 opened_def, closed_def, atFloor_def, Req_def]; |
|
71 |
|
72 Addsimps (map simp_of_set abbrev_defs); |
|
73 |
|
74 |
|
75 (** The HUG'93 paper mistakenly omits the Req n from these! **) |
|
76 |
|
77 (** Lift_1 **) |
|
78 |
|
79 Goal "Lift : (stopped Int atFloor n) LeadsTo (opened Int atFloor n)"; |
|
80 by (cut_facts_tac [stop_floor] 1); |
|
81 by (ensures_tac "open_act" 1); |
|
82 qed "E_thm01"; (*lem_lift_1_5*) |
|
83 |
|
84 Goal "Lift : (Req n Int stopped - atFloor n) LeadsTo \ |
|
85 \ (Req n Int opened - atFloor n)"; |
|
86 by (cut_facts_tac [stop_floor] 1); |
|
87 by (ensures_tac "open_act" 1); |
|
88 qed "E_thm02"; (*lem_lift_1_1*) |
|
89 |
|
90 Goal "Lift : (Req n Int opened - atFloor n) LeadsTo \ |
|
91 \ (Req n Int closed - (atFloor n - queueing))"; |
|
92 by (ensures_tac "close_act" 1); |
|
93 qed "E_thm03"; (*lem_lift_1_2*) |
|
94 |
|
95 Goal "Lift : (Req n Int closed Int (atFloor n - queueing)) \ |
|
96 \ LeadsTo (opened Int atFloor n)"; |
|
97 by (ensures_tac "open_act" 1); |
|
98 qed "E_thm04"; (*lem_lift_1_7*) |
|
99 |
|
100 |
|
101 (** Lift 2. Statements of thm05a and thm05b were wrong! **) |
|
102 |
|
103 Open_locale "floor"; |
|
104 |
|
105 val Min_le_n = thm "Min_le_n"; |
|
106 val n_le_Max = thm "n_le_Max"; |
|
107 |
|
108 AddIffs [Min_le_n, n_le_Max]; |
|
109 |
|
110 val le_MinD = Min_le_n RS order_antisym; |
|
111 val Max_leD = n_le_Max RSN (2,order_antisym); |
|
112 |
|
113 val linorder_leI = linorder_not_less RS iffD1; |
|
114 |
|
115 AddSDs [le_MinD, linorder_leI RS le_MinD, |
|
116 Max_leD, linorder_leI RS Max_leD]; |
|
117 |
|
118 (*lem_lift_2_0 |
|
119 NOT an ensures property, but a mere inclusion; |
|
120 don't know why script lift_2.uni says ENSURES*) |
|
121 Goal "Lift : (Req n Int closed - (atFloor n - queueing)) \ |
|
122 \ LeadsTo ((closed Int goingup Int Req n) Un \ |
|
123 \ (closed Int goingdown Int Req n))"; |
|
124 by (auto_tac (claset() addSIs [subset_imp_LeadsTo] addSEs [int_neqE], |
|
125 simpset())); |
|
126 qed "E_thm05c"; |
|
127 |
|
128 (*lift_2*) |
|
129 Goal "Lift : (Req n Int closed - (atFloor n - queueing)) \ |
|
130 \ LeadsTo (moving Int Req n)"; |
|
131 by (rtac ([E_thm05c, LeadsTo_Un] MRS LeadsTo_Trans) 1); |
|
132 by (ensures_tac "req_down" 2); |
|
133 by (ensures_tac "req_up" 1); |
|
134 by Auto_tac; |
|
135 qed "lift_2"; |
|
136 |
|
137 |
|
138 (** Towards lift_4 ***) |
|
139 |
|
140 val metric_ss = simpset() addsplits [split_if_asm] |
|
141 addsimps [metric_def, vimage_def]; |
|
142 |
|
143 |
|
144 (*lem_lift_4_1 *) |
|
145 Goal "#0 < N ==> \ |
|
146 \ Lift : (moving Int Req n Int {s. metric n s = N} Int \ |
|
147 \ {s. floor s ~: req s} Int {s. up s}) \ |
|
148 \ LeadsTo \ |
|
149 \ (moving Int Req n Int {s. metric n s < N})"; |
|
150 by (cut_facts_tac [moving_up] 1); |
|
151 by (ensures_tac "move_up" 1); |
|
152 by Safe_tac; |
|
153 (*this step consolidates two formulae to the goal metric n s' <= metric n s*) |
|
154 by (etac (linorder_leI RS order_antisym RS sym) 1); |
|
155 by (auto_tac (claset(), metric_ss)); |
|
156 qed "E_thm12a"; |
|
157 |
|
158 |
|
159 (*lem_lift_4_3 *) |
|
160 Goal "#0 < N ==> \ |
|
161 \ Lift : (moving Int Req n Int {s. metric n s = N} Int \ |
|
162 \ {s. floor s ~: req s} - {s. up s}) \ |
|
163 \ LeadsTo (moving Int Req n Int {s. metric n s < N})"; |
|
164 by (cut_facts_tac [moving_down] 1); |
|
165 by (ensures_tac "move_down" 1); |
|
166 by Safe_tac; |
|
167 (*this step consolidates two formulae to the goal metric n s' <= metric n s*) |
|
168 by (etac (linorder_leI RS order_antisym RS sym) 1); |
|
169 by (auto_tac (claset(), metric_ss)); |
|
170 qed "E_thm12b"; |
|
171 |
|
172 (*lift_4*) |
|
173 Goal "#0<N ==> Lift : (moving Int Req n Int {s. metric n s = N} Int \ |
|
174 \ {s. floor s ~: req s}) LeadsTo \ |
|
175 \ (moving Int Req n Int {s. metric n s < N})"; |
|
176 by (rtac ([subset_imp_LeadsTo, [E_thm12a, E_thm12b] MRS LeadsTo_Un] |
|
177 MRS LeadsTo_Trans) 1); |
|
178 by Auto_tac; |
|
179 qed "lift_4"; |
|
180 |
|
181 |
|
182 (** towards lift_5 **) |
|
183 |
|
184 (*lem_lift_5_3*) |
|
185 Goal "#0<N \ |
|
186 \ ==> Lift : (closed Int Req n Int {s. metric n s = N} Int goingup) LeadsTo \ |
|
187 \ (moving Int Req n Int {s. metric n s < N})"; |
|
188 by (cut_facts_tac [bounded] 1); |
|
189 by (ensures_tac "req_up" 1); |
|
190 by (auto_tac (claset(), metric_ss)); |
|
191 qed "E_thm16a"; |
|
192 |
|
193 |
|
194 (*lem_lift_5_1 has ~goingup instead of goingdown*) |
|
195 Goal "#0<N ==> \ |
|
196 \ Lift : (closed Int Req n Int {s. metric n s = N} Int goingdown) LeadsTo \ |
|
197 \ (moving Int Req n Int {s. metric n s < N})"; |
|
198 by (cut_facts_tac [bounded] 1); |
|
199 by (ensures_tac "req_down" 1); |
|
200 by (auto_tac (claset(), metric_ss)); |
|
201 qed "E_thm16b"; |
|
202 |
|
203 |
|
204 (*lem_lift_5_0 proves an intersection involving ~goingup and goingup, |
|
205 i.e. the trivial disjunction, leading to an asymmetrical proof.*) |
|
206 Goal "#0<N ==> Req n Int {s. metric n s = N} <= goingup Un goingdown"; |
|
207 by (Clarify_tac 1); |
|
208 by (auto_tac (claset(), metric_ss)); |
|
209 qed "E_thm16c"; |
|
210 |
|
211 |
|
212 (*lift_5*) |
|
213 Goal "#0<N ==> Lift : (closed Int Req n Int {s. metric n s = N}) LeadsTo \ |
|
214 \ (moving Int Req n Int {s. metric n s < N})"; |
|
215 by (rtac ([subset_imp_LeadsTo, [E_thm16a, E_thm16b] MRS LeadsTo_Un] |
|
216 MRS LeadsTo_Trans) 1); |
|
217 by (dtac E_thm16c 1); |
|
218 by Auto_tac; |
|
219 qed "lift_5"; |
|
220 |
|
221 |
|
222 (** towards lift_3 **) |
|
223 |
|
224 (*lemma used to prove lem_lift_3_1*) |
|
225 Goal "[| metric n s = #0; Min <= floor s; floor s <= Max |] ==> floor s = n"; |
|
226 by (auto_tac (claset(), metric_ss)); |
|
227 qed "metric_eq_0D"; |
|
228 |
|
229 AddDs [metric_eq_0D]; |
|
230 |
|
231 |
|
232 (*lem_lift_3_1*) |
|
233 Goal "Lift : (moving Int Req n Int {s. metric n s = #0}) LeadsTo \ |
|
234 \ (stopped Int atFloor n)"; |
|
235 by (cut_facts_tac [bounded] 1); |
|
236 by (ensures_tac "request_act" 1); |
|
237 by Auto_tac; |
|
238 qed "E_thm11"; |
|
239 |
|
240 (*lem_lift_3_5*) |
|
241 Goal |
|
242 "Lift : (moving Int Req n Int {s. metric n s = N} Int {s. floor s : req s}) \ |
|
243 \ LeadsTo (stopped Int Req n Int {s. metric n s = N} Int {s. floor s : req s})"; |
|
244 by (ensures_tac "request_act" 1); |
|
245 by (auto_tac (claset(), metric_ss)); |
|
246 qed "E_thm13"; |
|
247 |
|
248 (*lem_lift_3_6*) |
|
249 Goal "#0 < N ==> \ |
|
250 \ Lift : \ |
|
251 \ (stopped Int Req n Int {s. metric n s = N} Int {s. floor s : req s}) \ |
|
252 \ LeadsTo (opened Int Req n Int {s. metric n s = N})"; |
|
253 by (ensures_tac "open_act" 1); |
|
254 by (auto_tac (claset(), metric_ss)); |
|
255 qed "E_thm14"; |
|
256 |
|
257 (*lem_lift_3_7*) |
|
258 Goal "Lift : (opened Int Req n Int {s. metric n s = N}) \ |
|
259 \ LeadsTo (closed Int Req n Int {s. metric n s = N})"; |
|
260 by (ensures_tac "close_act" 1); |
|
261 by (auto_tac (claset(), metric_ss)); |
|
262 qed "E_thm15"; |
|
263 |
|
264 |
|
265 (** the final steps **) |
|
266 |
|
267 Goal "#0 < N ==> \ |
|
268 \ Lift : \ |
|
269 \ (moving Int Req n Int {s. metric n s = N} Int {s. floor s : req s}) \ |
|
270 \ LeadsTo (moving Int Req n Int {s. metric n s < N})"; |
|
271 by (blast_tac (claset() addSIs [E_thm13, E_thm14, E_thm15, lift_5] |
|
272 addIs [LeadsTo_Trans]) 1); |
|
273 qed "lift_3_Req"; |
|
274 |
|
275 |
|
276 (*Now we observe that our integer metric is really a natural number*) |
|
277 Goal "Lift : Always {s. #0 <= metric n s}"; |
|
278 by (rtac (bounded RS Always_weaken) 1); |
|
279 by (auto_tac (claset(), metric_ss)); |
|
280 qed "Always_nonneg"; |
|
281 |
|
282 val R_thm11 = [Always_nonneg, E_thm11] MRS Always_LeadsTo_weaken; |
|
283 |
|
284 Goal "Lift : (moving Int Req n) LeadsTo (stopped Int atFloor n)"; |
|
285 by (rtac (Always_nonneg RS integ_0_le_induct) 1); |
|
286 by (case_tac "#0 < z" 1); |
|
287 (*If z <= #0 then actually z = #0*) |
|
288 by (force_tac (claset() addIs [R_thm11, order_antisym], |
|
289 simpset() addsimps [linorder_not_less]) 2); |
|
290 by (rtac ([asm_rl, Un_upper1] MRS LeadsTo_weaken_R) 1); |
|
291 by (rtac ([subset_imp_LeadsTo, [lift_4, lift_3_Req] MRS LeadsTo_Un] |
|
292 MRS LeadsTo_Trans) 1); |
|
293 by Auto_tac; |
|
294 qed "lift_3"; |
|
295 |
|
296 |
|
297 val LeadsTo_Trans_Un' = rotate_prems 1 LeadsTo_Trans_Un; |
|
298 (* [| Lift: B LeadsTo C; Lift: A LeadsTo B |] ==> Lift: (A Un B) LeadsTo C *) |
|
299 |
|
300 Goal "Lift : (Req n) LeadsTo (opened Int atFloor n)"; |
|
301 by (rtac LeadsTo_Trans 1); |
|
302 by (rtac ([E_thm04, LeadsTo_Un_post] MRS LeadsTo_Un) 2); |
|
303 by (rtac (E_thm01 RS LeadsTo_Trans_Un') 2); |
|
304 by (rtac (lift_3 RS LeadsTo_Trans_Un') 2); |
|
305 by (rtac (lift_2 RS LeadsTo_Trans_Un') 2); |
|
306 by (rtac ([E_thm03,E_thm02] MRS LeadsTo_Trans_Un') 2); |
|
307 by (rtac (open_move RS Always_LeadsToI) 1); |
|
308 by (rtac ([open_stop, subset_imp_LeadsTo] MRS Always_LeadsToI) 1); |
|
309 by (Clarify_tac 1); |
|
310 (*The case split is not essential but makes Blast_tac much faster. |
|
311 Calling rotate_tac prevents simplification from looping*) |
|
312 by (case_tac "open x" 1); |
|
313 by (ALLGOALS (rotate_tac ~1)); |
|
314 by Auto_tac; |
|
315 qed "lift_1"; |
|
316 |
|
317 Close_locale "floor"; |