author | wenzelm |
Fri, 06 Mar 2015 13:39:34 +0100 | |
changeset 59618 | e6939796717e |
parent 59582 | 0fbed69ff081 |
child 59621 | 291934bac95e |
permissions | -rw-r--r-- |
37744 | 1 |
(* Title: HOL/Tools/Function/pat_completeness.ML |
33083 | 2 |
Author: Alexander Krauss, TU Muenchen |
3 |
||
4 |
Method "pat_completeness" to prove completeness of datatype patterns. |
|
5 |
*) |
|
6 |
||
7 |
signature PAT_COMPLETENESS = |
|
8 |
sig |
|
54407
e95831757903
ported part of function package to new 'Ctr_Sugar' abstraction
blanchet
parents:
54406
diff
changeset
|
9 |
val pat_completeness_tac: Proof.context -> int -> tactic |
e95831757903
ported part of function package to new 'Ctr_Sugar' abstraction
blanchet
parents:
54406
diff
changeset
|
10 |
val prove_completeness: Proof.context -> term list -> term -> term list list -> |
e95831757903
ported part of function package to new 'Ctr_Sugar' abstraction
blanchet
parents:
54406
diff
changeset
|
11 |
term list list -> thm |
33083 | 12 |
end |
13 |
||
14 |
structure Pat_Completeness : PAT_COMPLETENESS = |
|
15 |
struct |
|
16 |
||
33099
b8cdd3d73022
function package: more standard names for structures and files
krauss
parents:
33083
diff
changeset
|
17 |
open Function_Lib |
b8cdd3d73022
function package: more standard names for structures and files
krauss
parents:
33083
diff
changeset
|
18 |
open Function_Common |
33083 | 19 |
|
20 |
||
21 |
fun mk_argvar i T = Free ("_av" ^ (string_of_int i), T) |
|
22 |
fun mk_patvar i T = Free ("_pv" ^ (string_of_int i), T) |
|
23 |
||
36945 | 24 |
fun inst_free var inst = Thm.forall_elim inst o Thm.forall_intr var |
33083 | 25 |
|
26 |
fun inst_case_thm thy x P thm = |
|
59582 | 27 |
let val [Pv, xv] = Term.add_vars (Thm.prop_of thm) [] |
33083 | 28 |
in |
59582 | 29 |
thm |> cterm_instantiate (map (apply2 (Thm.cterm_of thy)) [(Var xv, x), (Var Pv, P)]) |
33083 | 30 |
end |
31 |
||
32 |
fun invent_vars constr i = |
|
33 |
let |
|
34 |
val Ts = binder_types (fastype_of constr) |
|
35 |
val j = i + length Ts |
|
36 |
val is = i upto (j - 1) |
|
37 |
val avs = map2 mk_argvar is Ts |
|
38 |
val pvs = map2 mk_patvar is Ts |
|
39 |
in |
|
40 |
(avs, pvs, j) |
|
41 |
end |
|
42 |
||
59618 | 43 |
fun filter_pats ctxt cons pvars [] = [] |
44 |
| filter_pats ctxt cons pvars (([], thm) :: pts) = raise Match |
|
45 |
| filter_pats ctxt cons pvars (((pat as Free _) :: pats, thm) :: pts) = |
|
46 |
let val inst = list_comb (cons, pvars) in |
|
47 |
(inst :: pats, |
|
48 |
inst_free (Proof_Context.cterm_of ctxt pat) (Proof_Context.cterm_of ctxt inst) thm) |
|
49 |
:: (filter_pats ctxt cons pvars pts) |
|
33083 | 50 |
end |
51 |
| filter_pats thy cons pvars ((pat :: pats, thm) :: pts) = |
|
52 |
if fst (strip_comb pat) = cons |
|
53 |
then (pat :: pats, thm) :: (filter_pats thy cons pvars pts) |
|
54 |
else filter_pats thy cons pvars pts |
|
55 |
||
56 |
||
51717
9e7d1c139569
simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents:
47432
diff
changeset
|
57 |
fun transform_pat _ avars c_assum ([] , thm) = raise Match |
9e7d1c139569
simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents:
47432
diff
changeset
|
58 |
| transform_pat ctxt avars c_assum (pat :: pats, thm) = |
59618 | 59 |
let |
60 |
val (_, subps) = strip_comb pat |
|
61 |
val eqs = |
|
62 |
map (Proof_Context.cterm_of ctxt o HOLogic.mk_Trueprop o HOLogic.mk_eq) (avars ~~ subps) |
|
63 |
val c_eq_pat = |
|
64 |
simplify (put_simpset HOL_basic_ss ctxt addsimps (map Thm.assume eqs)) c_assum |
|
65 |
in |
|
66 |
(subps @ pats, |
|
67 |
fold_rev Thm.implies_intr eqs (Thm.implies_elim thm c_eq_pat)) |
|
68 |
end |
|
33083 | 69 |
|
70 |
||
71 |
exception COMPLETENESS |
|
72 |
||
51717
9e7d1c139569
simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents:
47432
diff
changeset
|
73 |
fun constr_case ctxt P idx (v :: vs) pats cons = |
59618 | 74 |
let |
75 |
val (avars, pvars, newidx) = invent_vars cons idx |
|
76 |
val c_hyp = |
|
77 |
Proof_Context.cterm_of ctxt |
|
78 |
(HOLogic.mk_Trueprop (HOLogic.mk_eq (v, list_comb (cons, avars)))) |
|
79 |
val c_assum = Thm.assume c_hyp |
|
80 |
val newpats = map (transform_pat ctxt avars c_assum) (filter_pats ctxt cons pvars pats) |
|
81 |
in |
|
82 |
o_alg ctxt P newidx (avars @ vs) newpats |
|
83 |
|> Thm.implies_intr c_hyp |
|
84 |
|> fold_rev (Thm.forall_intr o Proof_Context.cterm_of ctxt) avars |
|
85 |
end |
|
33083 | 86 |
| constr_case _ _ _ _ _ _ = raise Match |
51717
9e7d1c139569
simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents:
47432
diff
changeset
|
87 |
and o_alg _ P idx [] (([], Pthm) :: _) = Pthm |
9e7d1c139569
simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents:
47432
diff
changeset
|
88 |
| o_alg _ P idx (v :: vs) [] = raise COMPLETENESS |
9e7d1c139569
simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents:
47432
diff
changeset
|
89 |
| o_alg ctxt P idx (v :: vs) pts = |
59618 | 90 |
if forall (is_Free o hd o fst) pts (* Var case *) |
91 |
then o_alg ctxt P idx vs |
|
92 |
(map (fn (pv :: pats, thm) => |
|
93 |
(pats, refl RS |
|
94 |
(inst_free (Proof_Context.cterm_of ctxt pv) |
|
95 |
(Proof_Context.cterm_of ctxt v) thm))) pts) |
|
96 |
else (* Cons case *) |
|
97 |
let |
|
98 |
val thy = Proof_Context.theory_of ctxt |
|
99 |
val T as Type (tname, _) = fastype_of v |
|
100 |
val SOME {exhaust=case_thm, ...} = Ctr_Sugar.ctr_sugar_of ctxt tname |
|
101 |
val constrs = inst_constrs_of ctxt T |
|
102 |
val c_cases = map (constr_case ctxt P idx (v :: vs) pts) constrs |
|
103 |
in |
|
104 |
inst_case_thm thy v P case_thm |
|
105 |
|> fold (curry op COMP) c_cases |
|
106 |
end |
|
33083 | 107 |
| o_alg _ _ _ _ _ = raise Match |
108 |
||
51717
9e7d1c139569
simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents:
47432
diff
changeset
|
109 |
fun prove_completeness ctxt xs P qss patss = |
33083 | 110 |
let |
111 |
fun mk_assum qs pats = |
|
112 |
HOLogic.mk_Trueprop P |
|
113 |
|> fold_rev (curry Logic.mk_implies o HOLogic.mk_Trueprop o HOLogic.mk_eq) (xs ~~ pats) |
|
114 |
|> fold_rev Logic.all qs |
|
59618 | 115 |
|> Proof_Context.cterm_of ctxt |
33083 | 116 |
|
117 |
val hyps = map2 mk_assum qss patss |
|
59618 | 118 |
fun inst_hyps hyp qs = fold (Thm.forall_elim o Proof_Context.cterm_of ctxt) qs (Thm.assume hyp) |
33083 | 119 |
val assums = map2 inst_hyps hyps qss |
120 |
in |
|
51717
9e7d1c139569
simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents:
47432
diff
changeset
|
121 |
o_alg ctxt P 2 xs (patss ~~ assums) |
36945 | 122 |
|> fold_rev Thm.implies_intr hyps |
33083 | 123 |
end |
124 |
||
125 |
fun pat_completeness_tac ctxt = SUBGOAL (fn (subgoal, i) => |
|
126 |
let |
|
127 |
val (vs, subgf) = dest_all_all subgoal |
|
128 |
val (cases, _ $ thesis) = Logic.strip_horn subgf |
|
129 |
handle Bind => raise COMPLETENESS |
|
130 |
||
131 |
fun pat_of assum = |
|
132 |
let |
|
133 |
val (qs, imp) = dest_all_all assum |
|
134 |
val prems = Logic.strip_imp_prems imp |
|
135 |
in |
|
136 |
(qs, map (HOLogic.dest_eq o HOLogic.dest_Trueprop) prems) |
|
137 |
end |
|
138 |
||
139 |
val (qss, x_pats) = split_list (map pat_of cases) |
|
140 |
val xs = map fst (hd x_pats) |
|
47060
e2741ec9ae36
prefer explicitly qualified exception List.Empty;
wenzelm
parents:
42361
diff
changeset
|
141 |
handle List.Empty => raise COMPLETENESS |
33083 | 142 |
|
143 |
val patss = map (map snd) x_pats |
|
51717
9e7d1c139569
simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents:
47432
diff
changeset
|
144 |
val complete_thm = prove_completeness ctxt xs thesis qss patss |
59618 | 145 |
|> fold_rev (Thm.forall_intr o Proof_Context.cterm_of ctxt) vs |
33083 | 146 |
in |
52467 | 147 |
PRIMITIVE (fn st => Drule.compose (complete_thm, i, st)) |
33083 | 148 |
end |
149 |
handle COMPLETENESS => no_tac) |
|
150 |
||
151 |
end |