author | wenzelm |
Wed, 04 Mar 2015 19:53:18 +0100 | |
changeset 59582 | 0fbed69ff081 |
parent 59498 | 50b60f501b05 |
child 59584 | 4517e9a96ace |
permissions | -rw-r--r-- |
31775 | 1 |
(* Title: HOL/Tools/Function/scnp_reconstruct.ML |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
2 |
Author: Armin Heller, TU Muenchen |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
3 |
Author: Alexander Krauss, TU Muenchen |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
4 |
|
41114 | 5 |
Proof reconstruction for SCNP termination. |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
6 |
*) |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
7 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
8 |
signature SCNP_RECONSTRUCT = |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
9 |
sig |
29877 | 10 |
val sizechange_tac : Proof.context -> tactic -> tactic |
11 |
||
36521 | 12 |
val decomp_scnp_tac : ScnpSolve.label list -> Proof.context -> tactic |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
13 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
14 |
datatype multiset_setup = |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
15 |
Multiset of |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
16 |
{ |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
17 |
msetT : typ -> typ, |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
18 |
mk_mset : typ -> term list -> term, |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
19 |
mset_regroup_conv : int list -> conv, |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
20 |
mset_member_tac : int -> int -> tactic, |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
21 |
mset_nonempty_tac : int -> tactic, |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
22 |
mset_pwleq_tac : int -> tactic, |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
23 |
set_of_simps : thm list, |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
24 |
smsI' : thm, |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
25 |
wmsI2'' : thm, |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
26 |
wmsI1 : thm, |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
27 |
reduction_pair : thm |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
28 |
} |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
29 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
30 |
val multiset_setup : multiset_setup -> theory -> theory |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
31 |
end |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
32 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
33 |
structure ScnpReconstruct : SCNP_RECONSTRUCT = |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
34 |
struct |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
35 |
|
33099
b8cdd3d73022
function package: more standard names for structures and files
krauss
parents:
33063
diff
changeset
|
36 |
val PROFILE = Function_Common.PROFILE |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
37 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
38 |
open ScnpSolve |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
39 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
40 |
val natT = HOLogic.natT |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
41 |
val nat_pairT = HOLogic.mk_prodT (natT, natT) |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
42 |
|
58819 | 43 |
|
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
44 |
(* Theory dependencies *) |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
45 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
46 |
datatype multiset_setup = |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
47 |
Multiset of |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
48 |
{ |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
49 |
msetT : typ -> typ, |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
50 |
mk_mset : typ -> term list -> term, |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
51 |
mset_regroup_conv : int list -> conv, |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
52 |
mset_member_tac : int -> int -> tactic, |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
53 |
mset_nonempty_tac : int -> tactic, |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
54 |
mset_pwleq_tac : int -> tactic, |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
55 |
set_of_simps : thm list, |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
56 |
smsI' : thm, |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
57 |
wmsI2'' : thm, |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
58 |
wmsI1 : thm, |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
59 |
reduction_pair : thm |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
60 |
} |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
61 |
|
33522 | 62 |
structure Multiset_Setup = Theory_Data |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
63 |
( |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
64 |
type T = multiset_setup option |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
65 |
val empty = NONE |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
66 |
val extend = I; |
41493 | 67 |
val merge = merge_options |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
68 |
) |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
69 |
|
33099
b8cdd3d73022
function package: more standard names for structures and files
krauss
parents:
33063
diff
changeset
|
70 |
val multiset_setup = Multiset_Setup.put o SOME |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
71 |
|
33855
cd8acf137c9c
eliminated dead code and some unused bindings, reported by polyml
krauss
parents:
33583
diff
changeset
|
72 |
fun undef _ = error "undef" |
58819 | 73 |
|
33099
b8cdd3d73022
function package: more standard names for structures and files
krauss
parents:
33063
diff
changeset
|
74 |
fun get_multiset_setup thy = Multiset_Setup.get thy |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
75 |
|> the_default (Multiset |
58819 | 76 |
{ msetT = undef, mk_mset=undef, |
77 |
mset_regroup_conv=undef, mset_member_tac = undef, |
|
78 |
mset_nonempty_tac = undef, mset_pwleq_tac = undef, |
|
79 |
set_of_simps = [],reduction_pair = refl, |
|
80 |
smsI'=refl, wmsI2''=refl, wmsI1=refl }) |
|
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
81 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
82 |
fun order_rpair _ MAX = @{thm max_rpair_set} |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
83 |
| order_rpair msrp MS = msrp |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
84 |
| order_rpair _ MIN = @{thm min_rpair_set} |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
85 |
|
58819 | 86 |
fun ord_intros_max true = (@{thm smax_emptyI}, @{thm smax_insertI}) |
87 |
| ord_intros_max false = (@{thm wmax_emptyI}, @{thm wmax_insertI}) |
|
88 |
||
89 |
fun ord_intros_min true = (@{thm smin_emptyI}, @{thm smin_insertI}) |
|
90 |
| ord_intros_min false = (@{thm wmin_emptyI}, @{thm wmin_insertI}) |
|
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
91 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
92 |
fun gen_probl D cs = |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
93 |
let |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
94 |
val n = Termination.get_num_points D |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
95 |
val arity = length o Termination.get_measures D |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
96 |
fun measure p i = nth (Termination.get_measures D p) i |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
97 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
98 |
fun mk_graph c = |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
99 |
let |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
100 |
val (_, p, _, q, _, _) = Termination.dest_call D c |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
101 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
102 |
fun add_edge i j = |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
103 |
case Termination.get_descent D c (measure p i) (measure q j) |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
104 |
of SOME (Termination.Less _) => cons (i, GTR, j) |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
105 |
| SOME (Termination.LessEq _) => cons (i, GEQ, j) |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
106 |
| _ => I |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
107 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
108 |
val edges = |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
109 |
fold_product add_edge (0 upto arity p - 1) (0 upto arity q - 1) [] |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
110 |
in |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
111 |
G (p, q, edges) |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
112 |
end |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
113 |
in |
33063 | 114 |
GP (map_range arity n, map mk_graph cs) |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
115 |
end |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
116 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
117 |
(* General reduction pair application *) |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
118 |
fun rem_inv_img ctxt = |
54998 | 119 |
rtac @{thm subsetI} 1 |
120 |
THEN etac @{thm CollectE} 1 |
|
121 |
THEN REPEAT (etac @{thm exE} 1) |
|
122 |
THEN Local_Defs.unfold_tac ctxt @{thms inv_image_def} |
|
123 |
THEN rtac @{thm CollectI} 1 |
|
124 |
THEN etac @{thm conjE} 1 |
|
125 |
THEN etac @{thm ssubst} 1 |
|
55642
63beb38e9258
adapted to renaming of datatype 'cases' and 'recs' to 'case' and 'rec'
blanchet
parents:
54998
diff
changeset
|
126 |
THEN Local_Defs.unfold_tac ctxt @{thms split_conv triv_forall_equality sum.case} |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
127 |
|
58819 | 128 |
|
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
129 |
(* Sets *) |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
130 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
131 |
val setT = HOLogic.mk_setT |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
132 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
133 |
fun set_member_tac m i = |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
134 |
if m = 0 then rtac @{thm insertI1} i |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
135 |
else rtac @{thm insertI2} i THEN set_member_tac (m - 1) i |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
136 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
137 |
val set_nonempty_tac = rtac @{thm insert_not_empty} |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
138 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
139 |
fun set_finite_tac i = |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
140 |
rtac @{thm finite.emptyI} i |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
141 |
ORELSE (rtac @{thm finite.insertI} i THEN (fn st => set_finite_tac i st)) |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
142 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
143 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
144 |
(* Reconstruction *) |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
145 |
|
33855
cd8acf137c9c
eliminated dead code and some unused bindings, reported by polyml
krauss
parents:
33583
diff
changeset
|
146 |
fun reconstruct_tac ctxt D cs (GP (_, gs)) certificate = |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
147 |
let |
42361 | 148 |
val thy = Proof_Context.theory_of ctxt |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
149 |
val Multiset |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
150 |
{ msetT, mk_mset, |
33855
cd8acf137c9c
eliminated dead code and some unused bindings, reported by polyml
krauss
parents:
33583
diff
changeset
|
151 |
mset_regroup_conv, mset_pwleq_tac, set_of_simps, |
58819 | 152 |
smsI', wmsI2'', wmsI1, reduction_pair=ms_rp, ...} |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
153 |
= get_multiset_setup thy |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
154 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
155 |
fun measure_fn p = nth (Termination.get_measures D p) |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
156 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
157 |
fun get_desc_thm cidx m1 m2 bStrict = |
58819 | 158 |
(case Termination.get_descent D (nth cs cidx) m1 m2 of |
159 |
SOME (Termination.Less thm) => |
|
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
160 |
if bStrict then thm |
59582 | 161 |
else (thm COMP (Thm.lift_rule (Thm.cprop_of thm) @{thm less_imp_le})) |
58819 | 162 |
| SOME (Termination.LessEq (thm, _)) => |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
163 |
if not bStrict then thm |
40317
1eac228c52b3
replaced ancient sys_error by raise Fail, assuming that the latter is not handled specifically by the environment;
wenzelm
parents:
39925
diff
changeset
|
164 |
else raise Fail "get_desc_thm" |
58819 | 165 |
| _ => raise Fail "get_desc_thm") |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
166 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
167 |
val (label, lev, sl, covering) = certificate |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
168 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
169 |
fun prove_lev strict g = |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
170 |
let |
33855
cd8acf137c9c
eliminated dead code and some unused bindings, reported by polyml
krauss
parents:
33583
diff
changeset
|
171 |
val G (p, q, _) = nth gs g |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
172 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
173 |
fun less_proof strict (j, b) (i, a) = |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
174 |
let |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
175 |
val tag_flag = b < a orelse (not strict andalso b <= a) |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
176 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
177 |
val stored_thm = |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
178 |
get_desc_thm g (measure_fn p i) (measure_fn q j) |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
179 |
(not tag_flag) |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
180 |
|> Conv.fconv_rule (Thm.beta_conversion true) |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
181 |
|
58819 | 182 |
val rule = |
183 |
if strict |
|
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
184 |
then if b < a then @{thm pair_lessI2} else @{thm pair_lessI1} |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
185 |
else if b <= a then @{thm pair_leqI2} else @{thm pair_leqI1} |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
186 |
in |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
187 |
rtac rule 1 THEN PRIMITIVE (Thm.elim_implies stored_thm) |
33569 | 188 |
THEN (if tag_flag then Arith_Data.arith_tac ctxt 1 else all_tac) |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
189 |
end |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
190 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
191 |
fun steps_tac MAX strict lq lp = |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
192 |
let |
58819 | 193 |
val (empty, step) = ord_intros_max strict |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
194 |
in |
58819 | 195 |
if length lq = 0 |
196 |
then rtac empty 1 THEN set_finite_tac 1 |
|
197 |
THEN (if strict then set_nonempty_tac 1 else all_tac) |
|
198 |
else |
|
199 |
let |
|
200 |
val (j, b) :: rest = lq |
|
201 |
val (i, a) = the (covering g strict j) |
|
202 |
fun choose xs = set_member_tac (Library.find_index (curry op = (i, a)) xs) 1 |
|
203 |
val solve_tac = choose lp THEN less_proof strict (j, b) (i, a) |
|
204 |
in |
|
205 |
rtac step 1 THEN solve_tac THEN steps_tac MAX strict rest lp |
|
206 |
end |
|
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
207 |
end |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
208 |
| steps_tac MIN strict lq lp = |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
209 |
let |
58819 | 210 |
val (empty, step) = ord_intros_min strict |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
211 |
in |
58819 | 212 |
if length lp = 0 |
213 |
then rtac empty 1 |
|
214 |
THEN (if strict then set_nonempty_tac 1 else all_tac) |
|
215 |
else |
|
216 |
let |
|
217 |
val (i, a) :: rest = lp |
|
218 |
val (j, b) = the (covering g strict i) |
|
219 |
fun choose xs = set_member_tac (Library.find_index (curry op = (j, b)) xs) 1 |
|
220 |
val solve_tac = choose lq THEN less_proof strict (j, b) (i, a) |
|
221 |
in |
|
222 |
rtac step 1 THEN solve_tac THEN steps_tac MIN strict lq rest |
|
223 |
end |
|
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
224 |
end |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
225 |
| steps_tac MS strict lq lp = |
58819 | 226 |
let |
227 |
fun get_str_cover (j, b) = |
|
228 |
if is_some (covering g true j) then SOME (j, b) else NONE |
|
229 |
fun get_wk_cover (j, b) = the (covering g false j) |
|
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
230 |
|
58819 | 231 |
val qs = subtract (op =) (map_filter get_str_cover lq) lq |
232 |
val ps = map get_wk_cover qs |
|
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
233 |
|
58819 | 234 |
fun indices xs ys = map (fn y => Library.find_index (curry op = y) xs) ys |
235 |
val iqs = indices lq qs |
|
236 |
val ips = indices lp ps |
|
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
237 |
|
58819 | 238 |
local open Conv in |
239 |
fun t_conv a C = |
|
240 |
params_conv ~1 (K ((concl_conv ~1 o arg_conv o arg1_conv o a) C)) ctxt |
|
241 |
val goal_rewrite = |
|
242 |
t_conv arg1_conv (mset_regroup_conv iqs) |
|
243 |
then_conv t_conv arg_conv (mset_regroup_conv ips) |
|
244 |
end |
|
245 |
in |
|
246 |
CONVERSION goal_rewrite 1 |
|
247 |
THEN (if strict then rtac smsI' 1 |
|
248 |
else if qs = lq then rtac wmsI2'' 1 |
|
249 |
else rtac wmsI1 1) |
|
250 |
THEN mset_pwleq_tac 1 |
|
251 |
THEN EVERY (map2 (less_proof false) qs ps) |
|
252 |
THEN (if strict orelse qs <> lq |
|
253 |
then Local_Defs.unfold_tac ctxt set_of_simps |
|
254 |
THEN steps_tac MAX true |
|
255 |
(subtract (op =) qs lq) (subtract (op =) ps lp) |
|
256 |
else all_tac) |
|
257 |
end |
|
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
258 |
in |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
259 |
rem_inv_img ctxt |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
260 |
THEN steps_tac label strict (nth lev q) (nth lev p) |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
261 |
end |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
262 |
|
30450 | 263 |
val (mk_set, setT) = if label = MS then (mk_mset, msetT) else (HOLogic.mk_set, setT) |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
264 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
265 |
fun tag_pair p (i, tag) = |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
266 |
HOLogic.pair_const natT natT $ |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
267 |
(measure_fn p i $ Bound 0) $ HOLogic.mk_number natT tag |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
268 |
|
58819 | 269 |
fun pt_lev (p, lm) = |
270 |
Abs ("x", Termination.get_types D p, mk_set nat_pairT (map (tag_pair p) lm)) |
|
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
271 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
272 |
val level_mapping = |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
273 |
map_index pt_lev lev |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
274 |
|> Termination.mk_sumcases D (setT nat_pairT) |
59582 | 275 |
|> Thm.cterm_of thy |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
276 |
in |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
277 |
PROFILE "Proof Reconstruction" |
33099
b8cdd3d73022
function package: more standard names for structures and files
krauss
parents:
33063
diff
changeset
|
278 |
(CONVERSION (Conv.arg_conv (Conv.arg_conv (Function_Lib.regroup_union_conv sl))) 1 |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
279 |
THEN (rtac @{thm reduction_pair_lemma} 1) |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
280 |
THEN (rtac @{thm rp_inv_image_rp} 1) |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
281 |
THEN (rtac (order_rpair ms_rp label) 1) |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
282 |
THEN PRIMITIVE (instantiate' [] [SOME level_mapping]) |
54998 | 283 |
THEN unfold_tac ctxt @{thms rp_inv_image_def} |
284 |
THEN Local_Defs.unfold_tac ctxt @{thms split_conv fst_conv snd_conv} |
|
59498
50b60f501b05
proper context for resolve_tac, eresolve_tac, dresolve_tac, forward_tac etc.;
wenzelm
parents:
59159
diff
changeset
|
285 |
THEN REPEAT (SOMEGOAL (resolve_tac ctxt [@{thm Un_least}, @{thm empty_subsetI}])) |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
286 |
THEN EVERY (map (prove_lev true) sl) |
33040 | 287 |
THEN EVERY (map (prove_lev false) (subtract (op =) sl (0 upto length cs - 1)))) |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
288 |
end |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
289 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
290 |
|
39924
f4d3e70ed3a8
discontinued continuations to simplify control flow; dropped optimization in scnp
krauss
parents:
39923
diff
changeset
|
291 |
fun single_scnp_tac use_tags orders ctxt D = Termination.CALLS (fn (cs, i) => |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
292 |
let |
42361 | 293 |
val ms_configured = is_some (Multiset_Setup.get (Proof_Context.theory_of ctxt)) |
58819 | 294 |
val orders' = |
295 |
if ms_configured then orders |
|
296 |
else filter_out (curry op = MS) orders |
|
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
297 |
val gp = gen_probl D cs |
29877 | 298 |
val certificate = generate_certificate use_tags orders' gp |
299 |
in |
|
58819 | 300 |
(case certificate of |
301 |
NONE => no_tac |
|
302 |
| SOME cert => |
|
303 |
SELECT_GOAL (reconstruct_tac ctxt D cs gp cert) i |
|
304 |
THEN TRY (rtac @{thm wf_empty} i)) |
|
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
305 |
end) |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
306 |
|
39924
f4d3e70ed3a8
discontinued continuations to simplify control flow; dropped optimization in scnp
krauss
parents:
39923
diff
changeset
|
307 |
fun gen_decomp_scnp_tac orders autom_tac ctxt = |
58819 | 308 |
Termination.TERMINATION ctxt autom_tac (fn D => |
309 |
let |
|
310 |
val decompose = Termination.decompose_tac D |
|
311 |
val scnp_full = single_scnp_tac true orders ctxt D |
|
312 |
in |
|
313 |
REPEAT_ALL_NEW (scnp_full ORELSE' decompose) |
|
314 |
end) |
|
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
315 |
|
39924
f4d3e70ed3a8
discontinued continuations to simplify control flow; dropped optimization in scnp
krauss
parents:
39923
diff
changeset
|
316 |
fun gen_sizechange_tac orders autom_tac ctxt = |
59159 | 317 |
TRY (Function_Common.termination_rule_tac ctxt 1) |
30607
c3d1590debd8
eliminated global SIMPSET, CLASET etc. -- refer to explicit context;
wenzelm
parents:
30510
diff
changeset
|
318 |
THEN TRY (Termination.wf_union_tac ctxt) |
58819 | 319 |
THEN (rtac @{thm wf_empty} 1 ORELSE gen_decomp_scnp_tac orders autom_tac ctxt 1) |
29877 | 320 |
|
321 |
fun sizechange_tac ctxt autom_tac = |
|
39924
f4d3e70ed3a8
discontinued continuations to simplify control flow; dropped optimization in scnp
krauss
parents:
39923
diff
changeset
|
322 |
gen_sizechange_tac [MAX, MS, MIN] autom_tac ctxt |
29877 | 323 |
|
36521 | 324 |
fun decomp_scnp_tac orders ctxt = |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
325 |
let |
57959 | 326 |
val extra_simps = Named_Theorems.get ctxt @{named_theorems termination_simp} |
51717
9e7d1c139569
simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents:
42795
diff
changeset
|
327 |
val autom_tac = auto_tac (ctxt addsimps extra_simps) |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
328 |
in |
39924
f4d3e70ed3a8
discontinued continuations to simplify control flow; dropped optimization in scnp
krauss
parents:
39923
diff
changeset
|
329 |
gen_sizechange_tac orders autom_tac ctxt |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
330 |
end |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
331 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
332 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
333 |
(* Method setup *) |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
334 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
335 |
val orders = |
31242 | 336 |
Scan.repeat1 |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
337 |
((Args.$$$ "max" >> K MAX) || |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
338 |
(Args.$$$ "min" >> K MIN) || |
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
339 |
(Args.$$$ "ms" >> K MS)) |
31242 | 340 |
|| Scan.succeed [MAX, MS, MIN] |
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
341 |
|
58819 | 342 |
val _ = |
343 |
Theory.setup |
|
344 |
(Method.setup @{binding size_change} |
|
345 |
(Scan.lift orders --| Method.sections clasimp_modifiers >> |
|
346 |
(fn orders => SIMPLE_METHOD o decomp_scnp_tac orders)) |
|
347 |
"termination prover with graph decomposition and the NP subset of size change termination") |
|
29125
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
348 |
|
d41182a8135c
method "sizechange" proves termination of functions; added more infrastructure for termination proofs
krauss
parents:
diff
changeset
|
349 |
end |