31 |
31 |
32 (**** simplify {(x1, ..., xn). (x1, ..., xn) : S} to S ****) |
32 (**** simplify {(x1, ..., xn). (x1, ..., xn) : S} to S ****) |
33 |
33 |
34 val collect_mem_simproc = |
34 val collect_mem_simproc = |
35 Simplifier.simproc (theory "Set") "Collect_mem" ["Collect t"] (fn thy => fn ss => |
35 Simplifier.simproc (theory "Set") "Collect_mem" ["Collect t"] (fn thy => fn ss => |
36 fn S as Const ("Collect", Type ("fun", [_, T])) $ t => |
36 fn S as Const (@{const_name Collect}, Type ("fun", [_, T])) $ t => |
37 let val (u, _, ps) = HOLogic.strip_psplits t |
37 let val (u, _, ps) = HOLogic.strip_psplits t |
38 in case u of |
38 in case u of |
39 (c as Const ("op :", _)) $ q $ S' => |
39 (c as Const (@{const_name "op :"}, _)) $ q $ S' => |
40 (case try (HOLogic.strip_ptuple ps) q of |
40 (case try (HOLogic.strip_ptuple ps) q of |
41 NONE => NONE |
41 NONE => NONE |
42 | SOME ts => |
42 | SOME ts => |
43 if not (loose_bvar (S', 0)) andalso |
43 if not (loose_bvar (S', 0)) andalso |
44 ts = map Bound (length ps downto 0) |
44 ts = map Bound (length ps downto 0) |
72 fun close p t f = |
72 fun close p t f = |
73 let val vs = Term.add_vars t [] |
73 let val vs = Term.add_vars t [] |
74 in Drule.instantiate' [] (rev (map (SOME o cterm_of thy o Var) vs)) |
74 in Drule.instantiate' [] (rev (map (SOME o cterm_of thy o Var) vs)) |
75 (p (fold (Logic.all o Var) vs t) f) |
75 (p (fold (Logic.all o Var) vs t) f) |
76 end; |
76 end; |
77 fun mkop "op &" T x = SOME (Const (@{const_name Lattices.inf}, T --> T --> T), x) |
77 fun mkop @{const_name "op &"} T x = |
78 | mkop "op |" T x = SOME (Const (@{const_name Lattices.sup}, T --> T --> T), x) |
78 SOME (Const (@{const_name Lattices.inf}, T --> T --> T), x) |
|
79 | mkop @{const_name "op |"} T x = |
|
80 SOME (Const (@{const_name Lattices.sup}, T --> T --> T), x) |
79 | mkop _ _ _ = NONE; |
81 | mkop _ _ _ = NONE; |
80 fun mk_collect p T t = |
82 fun mk_collect p T t = |
81 let val U = HOLogic.dest_setT T |
83 let val U = HOLogic.dest_setT T |
82 in HOLogic.Collect_const U $ |
84 in HOLogic.Collect_const U $ |
83 HOLogic.mk_psplits (HOLogic.flat_tuple_paths p) U HOLogic.boolT t |
85 HOLogic.mk_psplits (HOLogic.flat_tuple_paths p) U HOLogic.boolT t |
84 end; |
86 end; |
85 fun decomp (Const (s, _) $ ((m as Const ("op :", |
87 fun decomp (Const (s, _) $ ((m as Const (@{const_name "op :"}, |
86 Type (_, [_, Type (_, [T, _])]))) $ p $ S) $ u) = |
88 Type (_, [_, Type (_, [T, _])]))) $ p $ S) $ u) = |
87 mkop s T (m, p, S, mk_collect p T (head_of u)) |
89 mkop s T (m, p, S, mk_collect p T (head_of u)) |
88 | decomp (Const (s, _) $ u $ ((m as Const ("op :", |
90 | decomp (Const (s, _) $ u $ ((m as Const (@{const_name "op :"}, |
89 Type (_, [_, Type (_, [T, _])]))) $ p $ S)) = |
91 Type (_, [_, Type (_, [T, _])]))) $ p $ S)) = |
90 mkop s T (m, p, mk_collect p T (head_of u), S) |
92 mkop s T (m, p, mk_collect p T (head_of u), S) |
91 | decomp _ = NONE; |
93 | decomp _ = NONE; |
92 val simp = full_simp_tac (Simplifier.inherit_context ss |
94 val simp = full_simp_tac (Simplifier.inherit_context ss |
93 (HOL_basic_ss addsimps [mem_Collect_eq, split_conv])) 1; |
95 (HOL_basic_ss addsimps [mem_Collect_eq, split_conv])) 1; |
261 |
263 |
262 (**** declare rules for converting predicates to sets ****) |
264 (**** declare rules for converting predicates to sets ****) |
263 |
265 |
264 fun add ctxt thm (tab as {to_set_simps, to_pred_simps, set_arities, pred_arities}) = |
266 fun add ctxt thm (tab as {to_set_simps, to_pred_simps, set_arities, pred_arities}) = |
265 case prop_of thm of |
267 case prop_of thm of |
266 Const ("Trueprop", _) $ (Const ("op =", Type (_, [T, _])) $ lhs $ rhs) => |
268 Const (@{const_name Trueprop}, _) $ (Const (@{const_name "op ="}, Type (_, [T, _])) $ lhs $ rhs) => |
267 (case body_type T of |
269 (case body_type T of |
268 Type ("bool", []) => |
270 @{typ bool} => |
269 let |
271 let |
270 val thy = Context.theory_of ctxt; |
272 val thy = Context.theory_of ctxt; |
271 fun factors_of t fs = case strip_abs_body t of |
273 fun factors_of t fs = case strip_abs_body t of |
272 Const ("op :", _) $ u $ S => |
274 Const (@{const_name "op :"}, _) $ u $ S => |
273 if is_Free S orelse is_Var S then |
275 if is_Free S orelse is_Var S then |
274 let val ps = HOLogic.flat_tuple_paths u |
276 let val ps = HOLogic.flat_tuple_paths u |
275 in (SOME ps, (S, ps) :: fs) end |
277 in (SOME ps, (S, ps) :: fs) end |
276 else (NONE, fs) |
278 else (NONE, fs) |
277 | _ => (NONE, fs); |
279 | _ => (NONE, fs); |
278 val (h, ts) = strip_comb lhs |
280 val (h, ts) = strip_comb lhs |
279 val (pfs, fs) = fold_map factors_of ts []; |
281 val (pfs, fs) = fold_map factors_of ts []; |
280 val ((h', ts'), fs') = (case rhs of |
282 val ((h', ts'), fs') = (case rhs of |
281 Abs _ => (case strip_abs_body rhs of |
283 Abs _ => (case strip_abs_body rhs of |
282 Const ("op :", _) $ u $ S => |
284 Const (@{const_name "op :"}, _) $ u $ S => |
283 (strip_comb S, SOME (HOLogic.flat_tuple_paths u)) |
285 (strip_comb S, SOME (HOLogic.flat_tuple_paths u)) |
284 | _ => error "member symbol on right-hand side expected") |
286 | _ => error "member symbol on right-hand side expected") |
285 | _ => (strip_comb rhs, NONE)) |
287 | _ => (strip_comb rhs, NONE)) |
286 in |
288 in |
287 case (name_type_of h, name_type_of h') of |
289 case (name_type_of h, name_type_of h') of |
410 let |
412 let |
411 val thy = ProofContext.theory_of lthy; |
413 val thy = ProofContext.theory_of lthy; |
412 val {set_arities, pred_arities, to_pred_simps, ...} = |
414 val {set_arities, pred_arities, to_pred_simps, ...} = |
413 PredSetConvData.get (Context.Proof lthy); |
415 PredSetConvData.get (Context.Proof lthy); |
414 fun infer (Abs (_, _, t)) = infer t |
416 fun infer (Abs (_, _, t)) = infer t |
415 | infer (Const ("op :", _) $ t $ u) = |
417 | infer (Const (@{const_name "op :"}, _) $ t $ u) = |
416 infer_arities thy set_arities (SOME (HOLogic.flat_tuple_paths t), u) |
418 infer_arities thy set_arities (SOME (HOLogic.flat_tuple_paths t), u) |
417 | infer (t $ u) = infer t #> infer u |
419 | infer (t $ u) = infer t #> infer u |
418 | infer _ = I; |
420 | infer _ = I; |
419 val new_arities = filter_out |
421 val new_arities = filter_out |
420 (fn (x as Free (_, T), _) => x mem params andalso length (binder_types T) > 1 |
422 (fn (x as Free (_, T), _) => x mem params andalso length (binder_types T) > 1 |