3 Author: Amine Chaieb and Makarius |
3 Author: Amine Chaieb and Makarius |
4 |
4 |
5 Conversions: primitive equality reasoning. |
5 Conversions: primitive equality reasoning. |
6 *) |
6 *) |
7 |
7 |
8 infix 1 AND; |
8 infix 1 thenc; |
9 infix 0 OR; |
9 infix 0 orelsec; |
10 |
10 |
11 signature CONV = |
11 signature CONV = |
12 sig |
12 sig |
13 type conv = cterm -> thm |
13 type conv = cterm -> thm |
14 val no_conv: conv |
14 val no_conv: conv |
15 val all_conv: conv |
15 val all_conv: conv |
16 val option_conv: conv -> cterm -> thm option |
16 val thenc: conv * conv -> conv |
17 val AND: conv * conv -> conv |
17 val orelsec: conv * conv -> conv |
18 val OR: conv * conv -> conv |
18 val first_conv: conv list -> conv |
|
19 val every_conv: conv list -> conv |
|
20 val tryc: conv -> conv |
|
21 val repeatc: conv -> conv |
|
22 val cache_conv: conv -> conv |
|
23 val abs_conv: conv -> conv |
|
24 val combination_conv: conv -> conv -> conv |
|
25 val comb_conv: conv -> conv |
|
26 val arg_conv: conv -> conv |
|
27 val fun_conv: conv -> conv |
|
28 val arg1_conv: conv -> conv |
|
29 val fun2_conv: conv -> conv |
19 val forall_conv: int -> conv -> conv |
30 val forall_conv: int -> conv -> conv |
20 val concl_conv: int -> conv -> conv |
31 val concl_conv: int -> conv -> conv |
21 val prems_conv: int -> (int -> conv) -> conv |
32 val prems_conv: int -> (int -> conv) -> conv |
22 val goals_conv: (int -> bool) -> conv -> conv |
33 val goals_conv: (int -> bool) -> conv -> conv |
23 val fconv_rule: conv -> thm -> thm |
34 val fconv_rule: conv -> thm -> thm |
26 structure Conv: CONV = |
37 structure Conv: CONV = |
27 struct |
38 struct |
28 |
39 |
29 (* conversionals *) |
40 (* conversionals *) |
30 |
41 |
31 type conv = cterm -> thm |
42 type conv = cterm -> thm; |
32 |
43 |
33 fun no_conv _ = raise CTERM ("no conversion", []); |
44 fun no_conv _ = raise CTERM ("no conversion", []); |
34 val all_conv = Thm.reflexive; |
45 val all_conv = Thm.reflexive; |
35 |
46 |
36 val is_refl = op aconv o Logic.dest_equals o Thm.prop_of; |
47 val is_refl = op aconv o Logic.dest_equals o Thm.prop_of; |
37 |
48 |
38 fun option_conv conv ct = |
49 fun (cv1 thenc cv2) ct = |
39 (case try conv ct of |
|
40 NONE => NONE |
|
41 | SOME eq => if is_refl eq then NONE else SOME eq); |
|
42 |
|
43 fun (conv1 AND conv2) ct = |
|
44 let |
50 let |
45 val eq1 = conv1 ct; |
51 val eq1 = cv1 ct; |
46 val eq2 = conv2 (Thm.rhs_of eq1); |
52 val eq2 = cv2 (Thm.rhs_of eq1); |
47 in |
53 in |
48 if is_refl eq1 then eq2 |
54 if is_refl eq1 then eq2 |
49 else if is_refl eq2 then eq1 |
55 else if is_refl eq2 then eq1 |
50 else Thm.transitive eq1 eq2 |
56 else Thm.transitive eq1 eq2 |
51 end; |
57 end; |
52 |
58 |
53 fun (conv1 OR conv2) ct = |
59 fun (cv1 orelsec cv2) ct = |
54 (case try conv1 ct of SOME eq => eq | NONE => conv2 ct); |
60 (case try cv1 ct of SOME eq => eq | NONE => cv2 ct); |
|
61 |
|
62 fun first_conv cvs = fold_rev (curry op orelsec) cvs no_conv; |
|
63 fun every_conv cvs = fold_rev (curry op thenc) cvs all_conv; |
|
64 |
|
65 fun tryc cv = cv orelsec all_conv; |
|
66 fun repeatc cv ct = tryc (cv thenc repeatc cv) ct; |
|
67 |
|
68 fun cache_conv cv = |
|
69 let |
|
70 val cache = ref Termtab.empty; |
|
71 fun conv ct = |
|
72 (case Termtab.lookup (! cache) (term_of ct) of |
|
73 SOME th => th |
|
74 | NONE => |
|
75 let val th = cv ct |
|
76 in change cache (Termtab.update (term_of ct, th)); th end); |
|
77 in conv end; |
55 |
78 |
56 |
79 |
57 (* Pure conversions *) |
80 |
|
81 (** Pure conversions **) |
|
82 |
|
83 (* lambda terms *) |
|
84 |
|
85 fun abs_conv cv ct = |
|
86 (case term_of ct of |
|
87 Abs (x, _, _) => |
|
88 let val (v, ct') = Thm.dest_abs (SOME (gensym "abs_")) ct |
|
89 in Thm.abstract_rule x v (cv ct') end |
|
90 | _ => raise CTERM ("abs_conv", [ct])); |
|
91 |
|
92 fun combination_conv cv1 cv2 ct = |
|
93 let val (ct1, ct2) = Thm.dest_comb ct |
|
94 in Thm.combination (cv1 ct1) (cv2 ct2) end; |
|
95 |
|
96 fun comb_conv cv = combination_conv cv cv; |
|
97 fun arg_conv cv = combination_conv all_conv cv; |
|
98 fun fun_conv cv = combination_conv cv all_conv; |
|
99 |
|
100 val arg1_conv = fun_conv o arg_conv; |
|
101 val fun2_conv = fun_conv o fun_conv; |
|
102 |
|
103 |
|
104 (* logic *) |
58 |
105 |
59 (*rewrite B in !!x1 ... xn. B*) |
106 (*rewrite B in !!x1 ... xn. B*) |
60 fun forall_conv 0 cv ct = cv ct |
107 fun forall_conv 0 cv ct = cv ct |
61 | forall_conv n cv ct = |
108 | forall_conv n cv ct = |
62 (case try Thm.dest_comb ct of |
109 (case try Thm.dest_comb ct of |
63 NONE => cv ct |
110 NONE => cv ct |
64 | SOME (A, B) => |
111 | SOME (A, B) => |
65 (case (term_of A, term_of B) of |
112 (case (term_of A, term_of B) of |
66 (Const ("all", _), Abs (x, _, _)) => |
113 (Const ("all", _), Abs (x, _, _)) => |
67 let val (v, B') = Thm.dest_abs (SOME (gensym "all_")) B in |
114 let val (v, B') = Thm.dest_abs (SOME (gensym "all_")) B in |
68 Thm.combination (Thm.reflexive A) |
115 Thm.combination (all_conv A) |
69 (Thm.abstract_rule x v (forall_conv (n - 1) cv B')) |
116 (Thm.abstract_rule x v (forall_conv (n - 1) cv B')) |
70 end |
117 end |
71 | _ => cv ct)); |
118 | _ => cv ct)); |
72 |
119 |
73 (*rewrite B in A1 ==> ... ==> An ==> B*) |
120 (*rewrite B in A1 ==> ... ==> An ==> B*) |
74 fun concl_conv 0 cv ct = cv ct |
121 fun concl_conv 0 cv ct = cv ct |
75 | concl_conv n cv ct = |
122 | concl_conv n cv ct = |
76 (case try Thm.dest_implies ct of |
123 (case try Thm.dest_implies ct of |
77 NONE => cv ct |
124 NONE => cv ct |
78 | SOME (A, B) => Drule.imp_cong_rule (reflexive A) (concl_conv (n - 1) cv B)); |
125 | SOME (A, B) => Drule.imp_cong_rule (all_conv A) (concl_conv (n - 1) cv B)); |
79 |
126 |
80 (*rewrite the A's in A1 ==> ... ==> An ==> B*) |
127 (*rewrite the A's in A1 ==> ... ==> An ==> B*) |
81 fun prems_conv 0 _ = reflexive |
128 fun prems_conv 0 _ = all_conv |
82 | prems_conv n cv = |
129 | prems_conv n cv = |
83 let |
130 let |
84 fun conv i ct = |
131 fun conv i ct = |
85 if i = n + 1 then reflexive ct |
132 if i = n + 1 then all_conv ct |
86 else |
133 else |
87 (case try Thm.dest_implies ct of |
134 (case try Thm.dest_implies ct of |
88 NONE => reflexive ct |
135 NONE => all_conv ct |
89 | SOME (A, B) => Drule.imp_cong_rule (cv i A) (conv (i + 1) B)); |
136 | SOME (A, B) => Drule.imp_cong_rule (cv i A) (conv (i + 1) B)); |
90 in conv 1 end; |
137 in conv 1 end; |
91 |
138 |
92 fun goals_conv pred cv = prems_conv ~1 (fn i => if pred i then cv else all_conv); |
139 fun goals_conv pred cv = prems_conv ~1 (fn i => if pred i then cv else all_conv); |
93 fun fconv_rule cv th = equal_elim (cv (cprop_of th)) th; |
140 fun fconv_rule cv th = equal_elim (cv (cprop_of th)) th; |