1 (* Title: HOL/Integ/presburger.ML
3 Author: Amine Chaieb and Stefan Berghofer, TU Muenchen
4 License: GPL (GNU GENERAL PUBLIC LICENSE)
6 Tactic for solving arithmetical Goals in Presburger Arithmetic
9 (* This version of presburger deals with occurences of functional symbols in the subgoal and abstract over them to try to prove the more general formula. It then resolves with the subgoal. To enable this feature call the procedure with the parameter abs
12 signature PRESBURGER =
14 val presburger_tac : bool -> bool -> int -> tactic
15 val presburger_method : bool -> bool -> int -> Proof.method
16 val setup : (theory -> theory) list
20 structure Presburger: PRESBURGER =
23 val trace = ref false;
24 fun trace_msg s = if !trace then tracing s else ();
26 (*-----------------------------------------------------------------*)
27 (*cooper_pp: provefunction for the one-exstance quantifier elimination*)
28 (* Here still only one problem : The proof for the arithmetical transformations done on the dvd atomic formulae*)
29 (*-----------------------------------------------------------------*)
31 val presburger_ss = simpset_of (theory "Presburger");
33 fun cooper_pp sg (fm as e$Abs(xn,xT,p)) =
34 let val (xn1,p1) = variant_abs (xn,xT,p)
35 in (CooperProof.cooper_prv sg (Free (xn1, xT)) p1) end;
37 fun mnnf_pp sg fm = CooperProof.proof_of_cnnf sg fm
38 (CooperProof.proof_of_evalc sg);
40 fun tmproof_of_int_qelim sg fm =
41 Qelim.tproof_of_mlift_qelim sg CooperDec.is_arith_rel
42 (CooperProof.proof_of_linform sg) (mnnf_pp sg) (cooper_pp sg) fm;
45 (* Theorems to be used in this tactic*)
47 val zdvd_int = thm "zdvd_int";
48 val zdiff_int_split = thm "zdiff_int_split";
49 val all_nat = thm "all_nat";
50 val ex_nat = thm "ex_nat";
51 val number_of1 = thm "number_of1";
52 val number_of2 = thm "number_of2";
53 val split_zdiv = thm "split_zdiv";
54 val split_zmod = thm "split_zmod";
55 val mod_div_equality' = thm "mod_div_equality'";
56 val split_div' = thm "split_div'";
57 val Suc_plus1 = thm "Suc_plus1";
58 val imp_le_cong = thm "imp_le_cong";
59 val conj_le_cong = thm "conj_le_cong";
61 (* extract all the constants in a term*)
62 fun add_term_typed_consts (Const (c, T), cs) = (c,T) ins cs
63 | add_term_typed_consts (t $ u, cs) =
64 add_term_typed_consts (t, add_term_typed_consts (u, cs))
65 | add_term_typed_consts (Abs (_, _, t), cs) = add_term_typed_consts (t, cs)
66 | add_term_typed_consts (_, cs) = cs;
68 fun term_typed_consts t = add_term_typed_consts(t,[]);
71 val bT = HOLogic.boolT;
72 val iT = HOLogic.intT;
73 val binT = HOLogic.binT;
74 val nT = HOLogic.natT;
76 (* Allowed Consts in formulae for presburger tactic*)
79 [("All", (iT --> bT) --> bT),
80 ("Ex", (iT --> bT) --> bT),
81 ("All", (nT --> bT) --> bT),
82 ("Ex", (nT --> bT) --> bT),
84 ("op &", bT --> bT --> bT),
85 ("op |", bT --> bT --> bT),
86 ("op -->", bT --> bT --> bT),
87 ("op =", bT --> bT --> bT),
90 ("op <=", iT --> iT --> bT),
91 ("op =", iT --> iT --> bT),
92 ("op <", iT --> iT --> bT),
93 ("Divides.op dvd", iT --> iT --> bT),
94 ("Divides.op div", iT --> iT --> iT),
95 ("Divides.op mod", iT --> iT --> iT),
96 ("op +", iT --> iT --> iT),
97 ("op -", iT --> iT --> iT),
98 ("op *", iT --> iT --> iT),
99 ("HOL.abs", iT --> iT),
100 ("uminus", iT --> iT),
101 ("HOL.max", iT --> iT --> iT),
102 ("HOL.min", iT --> iT --> iT),
104 ("op <=", nT --> nT --> bT),
105 ("op =", nT --> nT --> bT),
106 ("op <", nT --> nT --> bT),
107 ("Divides.op dvd", nT --> nT --> bT),
108 ("Divides.op div", nT --> nT --> nT),
109 ("Divides.op mod", nT --> nT --> nT),
110 ("op +", nT --> nT --> nT),
111 ("op -", nT --> nT --> nT),
112 ("op *", nT --> nT --> nT),
114 ("HOL.max", nT --> nT --> nT),
115 ("HOL.min", nT --> nT --> nT),
117 ("Numeral.bin.Bit", binT --> bT --> binT),
118 ("Numeral.bin.Pls", binT),
119 ("Numeral.bin.Min", binT),
120 ("Numeral.number_of", binT --> iT),
121 ("Numeral.number_of", binT --> nT),
129 (* Preparation of the formula to be sent to the Integer quantifier *)
130 (* elimination procedure *)
131 (* Transforms meta implications and meta quantifiers to object *)
132 (* implications and object quantifiers *)
135 (*==================================*)
136 (* Abstracting on subterms ========*)
137 (*==================================*)
138 (* Returns occurences of terms that are function application of type int or nat*)
140 fun getfuncs fm = case strip_comb fm of
141 (Free (_, T), ts as _ :: _) =>
142 if body_type T mem [iT, nT]
143 andalso not (ts = []) andalso forall (null o loose_bnos) ts
145 else foldl op union ([], map getfuncs ts)
146 | (Var (_, T), ts as _ :: _) =>
147 if body_type T mem [iT, nT]
148 andalso not (ts = []) andalso forall (null o loose_bnos) ts then [fm]
149 else foldl op union ([], map getfuncs ts)
150 | (Const (s, T), ts) =>
151 if (s, T) mem allowed_consts orelse not (body_type T mem [iT, nT])
152 then foldl op union ([], map getfuncs ts)
154 | (Abs (s, T, t), _) => getfuncs t
158 fun abstract_pres sg fm =
160 let val T = fastype_of t
161 in all T $ Abs ("x", T, abstract_over (t, u)) end)
166 (* hasfuncs_on_bounds dont care of the type of the functions applied!
167 It returns true if there is a subterm coresponding to the application of
168 a function on a bounded variable.
170 Function applications are allowed only for well predefined functions a
173 fun has_free_funcs fm = case strip_comb fm of
174 (Free (_, T), ts as _ :: _) =>
175 if (body_type T mem [iT,nT]) andalso (not (T mem [iT,nT]))
177 else exists (fn x => x) (map has_free_funcs ts)
178 | (Var (_, T), ts as _ :: _) =>
179 if (body_type T mem [iT,nT]) andalso not (T mem [iT,nT])
181 else exists (fn x => x) (map has_free_funcs ts)
182 | (Const (s, T), ts) => exists (fn x => x) (map has_free_funcs ts)
183 | (Abs (s, T, t), _) => has_free_funcs t
187 (*returns true if the formula is relevant for presburger arithmetic tactic
188 The constants occuring in term t should be a subset of the allowed_consts
189 There also should be no occurences of application of functions on bounded
190 variables. Whenever this function will be used, it will be ensured that t
191 will not contain subterms with function symbols that could have been
194 fun relevant ps t = (term_typed_consts t) subset allowed_consts andalso
195 map (fn i => snd (nth_elem (i, ps))) (loose_bnos t) @
196 map (snd o dest_Free) (term_frees t) @ map (snd o dest_Var) (term_vars t)
198 andalso not (has_free_funcs t);
201 fun prepare_for_presburger sg q fm =
203 val ps = Logic.strip_params fm
204 val hs = map HOLogic.dest_Trueprop (Logic.strip_assums_hyp fm)
205 val c = HOLogic.dest_Trueprop (Logic.strip_assums_concl fm)
206 val _ = if relevant (rev ps) c then ()
207 else (trace_msg ("Conclusion is not a presburger term:\n" ^
208 Sign.string_of_term sg c); raise CooperDec.COOPER)
209 fun mk_all ((s, T), (P,n)) =
210 if 0 mem loose_bnos P then
211 (HOLogic.all_const T $ Abs (s, T, P), n)
212 else (incr_boundvars ~1 P, n-1)
213 fun mk_all2 (v, t) = HOLogic.all_const (fastype_of v) $ lambda v t;
214 val (rhs,irhs) = partition (relevant (rev ps)) hs
216 val (fm',np) = foldr (fn ((x, T), (fm,n)) => mk_all ((x, T), (fm,n)))
217 (ps,(foldr HOLogic.mk_imp (rhs, c), np))
218 val (vs, _) = partition (fn t => q orelse (type_of t) = nT)
219 (term_frees fm' @ term_vars fm');
220 val fm2 = foldr mk_all2 (vs, fm')
221 in (fm2, np + length vs, length rhs) end;
223 (*Object quantifier to meta --*)
224 fun spec_step n th = if (n=0) then th else (spec_step (n-1) th) RS spec ;
226 (* object implication to meta---*)
227 fun mp_step n th = if (n=0) then th else (mp_step (n-1) th) RS mp;
229 (* the presburger tactic*)
231 (* Parameters : q = flag for quantify ofer free variables ;
232 a = flag for abstracting over function occurences
235 fun presburger_tac q a i = ObjectLogic.atomize_tac i THEN (fn st =>
237 val g = BasisLibrary.List.nth (prems_of st, i - 1)
238 val sg = sign_of_thm st
239 (* The Abstraction step *)
240 val g' = if a then abstract_pres sg g else g
241 (* Transform the term*)
242 val (t,np,nh) = prepare_for_presburger sg q g'
243 (* Some simpsets for dealing with mod div abs and nat*)
244 val simpset0 = HOL_basic_ss
245 addsimps [mod_div_equality', Suc_plus1]
246 addsplits [split_zdiv, split_zmod, split_div', split_min, split_max]
247 (* Simp rules for changing (n::int) to int n *)
248 val simpset1 = HOL_basic_ss
249 addsimps [nat_number_of_def, zdvd_int] @ map (fn r => r RS sym)
250 [int_int_eq, zle_int, zless_int, zadd_int, zmult_int]
251 addsplits [zdiff_int_split]
252 (*simp rules for elimination of int n*)
254 val simpset2 = HOL_basic_ss
255 addsimps [nat_0_le, all_nat, ex_nat, number_of1, number_of2, int_0, int_1]
256 addcongs [conj_le_cong, imp_le_cong]
257 (* simp rules for elimination of abs *)
258 val simpset3 = HOL_basic_ss addsplits [abs_split]
259 val ct = cterm_of sg (HOLogic.mk_Trueprop t)
260 (* Theorem for the nat --> int transformation *)
261 val pre_thm = Seq.hd (EVERY
262 [simp_tac simpset0 1,
263 TRY (simp_tac simpset1 1), TRY (simp_tac simpset2 1),
264 TRY (simp_tac simpset3 1), TRY (simp_tac presburger_ss 1)]
266 fun assm_tac i = REPEAT_DETERM_N nh (assume_tac i)
267 (* The result of the quantifier elimination *)
268 val (th, tac) = case (prop_of pre_thm) of
269 Const ("==>", _) $ (Const ("Trueprop", _) $ t1) $ _ =>
270 (trace_msg ("calling procedure with term:\n" ^
271 Sign.string_of_term sg t1);
272 ((tmproof_of_int_qelim sg (Pattern.eta_long [] t1) RS iffD2) RS pre_thm,
273 assm_tac (i + 1) THEN (if q then I else TRY) (rtac TrueI i)))
274 | _ => (pre_thm, assm_tac i)
275 in (rtac (((mp_step nh) o (spec_step np)) th) i
277 end handle Subscript => no_tac st | CooperDec.COOPER => no_tac st);
279 fun presburger_args meth =
281 Args.$$$ "no_quantify" >> K (apfst (K false))
282 || Args.$$$ "abs" >> K (apsnd (K true));
285 (Scan.optional (Args.$$$ "(" |-- Scan.repeat1 parse_flag --| Args.$$$ ")") [] >>
286 curry (foldl op |>) (true, false))
287 (fn (q,a) => fn _ => meth q a 1)
290 fun presburger_method q a i = Method.METHOD (fn facts =>
291 Method.insert_tac facts 1 THEN presburger_tac q a i)
294 [Method.add_method ("presburger",
295 presburger_args presburger_method,
296 "decision procedure for Presburger arithmetic"),
297 ArithTheoryData.map (fn {splits, inj_consts, discrete, presburger} =>
298 {splits = splits, inj_consts = inj_consts, discrete = discrete,
299 presburger = Some (presburger_tac true false)})];
303 val presburger_tac = Presburger.presburger_tac true true;