1 (******************* admissibility tactic *********************** |
1 (* Title: HOLCF/adm.ML |
2 checks whether adm_subst theorem is applicable to the |
2 ID: $Id$ |
3 current proof state. "t" is instantiated with a term of chain- |
3 Author: Stefan Berghofer, TU Muenchen |
4 finite type, so that adm_chain_finite can be applied. |
|
5 |
4 |
6 example of usage: |
5 Admissibility tactic. |
7 |
6 |
8 by (adm_tac cont_tacRs 1); |
7 Checks whether adm_subst theorem is applicable to the current proof |
9 |
8 state: |
10 *****************************************************************) |
|
11 |
9 |
12 local |
10 [| cont t; adm P |] ==> adm (%x. P (t x)) |
|
11 |
|
12 "t" is instantiated with a term of chain-finite type, so that |
|
13 adm_chain_finite can be applied: |
|
14 |
|
15 adm (P::'a::{chfin,pcpo} => bool) |
|
16 |
|
17 *) |
|
18 |
|
19 signature ADM = |
|
20 sig |
|
21 val adm_tac: (int -> tactic) -> int -> tactic |
|
22 end; |
|
23 |
|
24 structure Adm: ADM = |
|
25 struct |
|
26 |
13 |
27 |
14 (*** find_subterms t 0 [] |
28 (*** find_subterms t 0 [] |
15 returns lists of terms with the following properties: |
29 returns lists of terms with the following properties: |
16 1. all terms in the list are disjoint subterms of t |
30 1. all terms in the list are disjoint subterms of t |
17 2. all terms contain the variable which is bound at level 0 |
31 2. all terms contain the variable which is bound at level 0 |
60 | t1 => t1; |
74 | t1 => t1; |
61 |
75 |
62 |
76 |
63 (*** check whether all terms in list are equal ***) |
77 (*** check whether all terms in list are equal ***) |
64 |
78 |
65 fun eq_terms (ts as ((t, _)::_)) = forall (fn (t2, _) => t2 aconv t) ts; |
79 fun eq_terms [] = true |
|
80 | eq_terms (ts as (t, _) :: _) = forall (fn (t2, _) => t2 aconv t) ts; |
66 |
81 |
67 |
82 |
68 (*** NOTE: when the following two functions are called, all terms in the list |
83 (*figure out internal names*) |
69 are equal (only their "paths" differ!) |
84 val chfin_pcpoS = Sign.intern_sort (sign_of HOLCF.thy) ["chfin", "pcpo"]; |
70 ***) |
|
71 |
|
72 val HOLCF_sg = sign_of HOLCF.thy; |
|
73 val chfinS = Sign.intern_sort HOLCF_sg ["chfin"]; |
|
74 val pcpoS = Sign.intern_sort HOLCF_sg ["pcpo"]; |
|
75 val cont_name = Sign.intern_const (sign_of HOLCF.thy) "cont"; |
85 val cont_name = Sign.intern_const (sign_of HOLCF.thy) "cont"; |
76 val adm_name = Sign.intern_const (sign_of HOLCF.thy) "adm"; |
86 val adm_name = Sign.intern_const (sign_of HOLCF.thy) "adm"; |
77 |
87 |
78 |
88 |
79 (*** check whether type of terms in list is chain finite ***) |
89 (*** check whether type of terms in list is chain finite ***) |
80 |
90 |
81 fun is_chfin sign T params ((t, _)::_) = |
91 fun is_chfin sign T params ((t, _)::_) = |
82 let val {tsig, ...} = Sign.rep_sg sign; |
92 let val {tsig, ...} = Sign.rep_sg sign; |
83 val parTs = map snd (rev params) |
93 val parTs = map snd (rev params) |
84 in Type.of_sort tsig (fastype_of1 (T::parTs, t), [hd chfinS, hd pcpoS]) end; |
94 in Type.of_sort tsig (fastype_of1 (T::parTs, t), chfin_pcpoS) end; |
85 |
95 |
86 |
96 |
87 (*** try to prove that terms in list are continuous |
97 (*** try to prove that terms in list are continuous |
88 if successful, add continuity theorem to list l ***) |
98 if successful, add continuity theorem to list l ***) |
89 |
99 |
90 fun prove_cont tac sign s T prems params (l, ts as ((t, _)::_)) = |
100 fun prove_cont tac sign s T prems params (l, ts as ((t, _)::_)) = |
91 (let val parTs = map snd (rev params); |
101 let val parTs = map snd (rev params); |
92 val contT = (T --> (fastype_of1 (T::parTs, t))) --> HOLogic.boolT; |
102 val contT = (T --> (fastype_of1 (T::parTs, t))) --> HOLogic.boolT; |
93 fun mk_all [] t = t |
103 fun mk_all [] t = t |
94 | mk_all ((a,T)::Ts) t = (all T) $ (Abs (a, T, mk_all Ts t)); |
104 | mk_all ((a,T)::Ts) t = (all T) $ (Abs (a, T, mk_all Ts t)); |
95 val t = HOLogic.mk_Trueprop((Const (cont_name, contT)) $ (Abs(s, T, t))); |
105 val t = HOLogic.mk_Trueprop((Const (cont_name, contT)) $ (Abs(s, T, t))); |
96 val t' = mk_all params (Logic.list_implies (prems, t)); |
106 val t' = mk_all params (Logic.list_implies (prems, t)); |
97 val thm = prove_goalw_cterm [] (cterm_of sign t') |
107 val thm = prove_goalw_cterm [] (cterm_of sign t') |
98 (fn ps => [cut_facts_tac ps 1, tac 1]) |
108 (fn ps => [cut_facts_tac ps 1, tac 1]) |
99 in (ts, thm)::l end) handle _ => l; |
109 in (ts, thm)::l end |
|
110 handle _ => l; |
100 |
111 |
101 |
112 |
102 (*** instantiation of adm_subst theorem (a bit tricky) |
113 (*** instantiation of adm_subst theorem (a bit tricky) |
103 NOTE: maybe unnecessary (if "cont_thm RS adm_subst" works properly) ***) |
114 NOTE: maybe unnecessary (if "cont_thm RS adm_subst" works properly) ***) |
104 |
115 |
127 |
138 |
128 (*** extract subgoal i from proof state ***) |
139 (*** extract subgoal i from proof state ***) |
129 |
140 |
130 fun nth_subgoal i thm = nth_elem (i-1, prems_of thm); |
141 fun nth_subgoal i thm = nth_elem (i-1, prems_of thm); |
131 |
142 |
132 in |
|
133 |
143 |
134 (*** the admissibility tactic |
144 (*** the admissibility tactic |
135 NOTE: |
145 NOTE: |
136 (compose_tac (false, rule, 2) i) THEN |
146 (compose_tac (false, rule, 2) i) THEN |
137 (rtac cont_thm i) THEN ... |
147 (rtac cont_thm i) THEN ... |
138 could probably be replaced by |
148 could probably be replaced by |
139 (rtac (cont_thm RS adm_subst) 1) THEN ... |
149 (rtac (cont_thm RS adm_subst) 1) THEN ... |
140 ***) |
150 ***) |
141 |
151 |
|
152 fun try_dest_adm (Const _ $ (Const (name, _) $ Abs abs)) = |
|
153 if name = adm_name then Some abs else None |
|
154 | try_dest_adm _ = None; |
|
155 |
142 fun adm_tac tac i state = |
156 fun adm_tac tac i state = |
143 state |> |
157 state |> |
144 let val goali = nth_subgoal i state |
158 let val goali = nth_subgoal i state in |
145 in |
159 (case try_dest_adm (Logic.strip_assums_concl goali) of |
146 case Logic.strip_assums_concl goali of |
160 None => no_tac |
147 ((Const _) $ ((Const (name, _)) $ (Abs (s, T, t)))) => |
161 | Some (s, T, t) => |
148 let val {sign, ...} = rep_thm state; |
162 let |
149 val prems = Logic.strip_assums_hyp goali; |
163 val sign = sign_of_thm state; |
150 val params = Logic.strip_params goali; |
164 val prems = Logic.strip_assums_hyp goali; |
151 val ts = find_subterms t 0 []; |
165 val params = Logic.strip_params goali; |
152 val ts' = filter eq_terms ts; |
166 val ts = find_subterms t 0 []; |
153 val ts'' = filter (is_chfin sign T params) ts'; |
167 val ts' = filter eq_terms ts; |
154 val thms = foldl (prove_cont tac sign s T prems params) ([], ts'') |
168 val ts'' = filter (is_chfin sign T params) ts'; |
155 in if name = adm_name then case thms of |
169 val thms = foldl (prove_cont tac sign s T prems params) ([], ts''); |
156 ((ts as ((t', _)::_), cont_thm)::_) => |
170 in |
157 let val paths = map snd ts; |
171 (case thms of |
158 val rule = inst_adm_subst_thm state i params s T t' t paths; |
172 ((ts as ((t', _)::_), cont_thm)::_) => |
159 in |
173 let |
160 (compose_tac (false, rule, 2) i) THEN |
174 val paths = map snd ts; |
161 (rtac cont_thm i) THEN |
175 val rule = inst_adm_subst_thm state i params s T t' t paths; |
162 (REPEAT (assume_tac i)) THEN |
176 in |
163 (rtac adm_chain_finite i) |
177 compose_tac (false, rule, 2) i THEN |
164 end |
178 rtac cont_thm i THEN |
165 | [] => no_tac |
179 REPEAT (assume_tac i) THEN |
166 else no_tac |
180 rtac adm_chain_finite i |
167 end |
181 end |
168 | _ => no_tac |
182 | [] => no_tac) |
|
183 end) |
169 end; |
184 end; |
|
185 |
170 |
186 |
171 end; |
187 end; |
172 |
188 |
|
189 |
|
190 open Adm; |