author  wenzelm 
Mon, 07 Apr 2008 21:25:18 +0200  
changeset 26568  3a3a83493f00 
parent 26364  cb6f360ab425 
child 26711  3a478bfa1650 
permissions  rwrr 
22313
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

1 
(* Title: HOL/Nominal/nominal_inductive.ML 
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

2 
ID: $Id$ 
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

3 
Author: Stefan Berghofer, TU Muenchen 
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

4 

22530  5 
Infrastructure for proving equivariance and strong induction theorems 
6 
for inductive predicates involving nominal datatypes. 

22313
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

7 
*) 
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

8 

1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

9 
signature NOMINAL_INDUCTIVE = 
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

10 
sig 
22730
8bcc8809ed3b
nominal_inductive no longer proves equivariance.
berghofe
parents:
22544
diff
changeset

11 
val prove_strong_ind: string > (string * string list) list > theory > Proof.state 
8bcc8809ed3b
nominal_inductive no longer proves equivariance.
berghofe
parents:
22544
diff
changeset

12 
val prove_eqvt: string > string list > theory > theory 
22313
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

13 
end 
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

14 

1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

15 
structure NominalInductive : NOMINAL_INDUCTIVE = 
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

16 
struct 
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

17 

24570
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

18 
val inductive_forall_name = "HOL.induct_forall"; 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

19 
val inductive_forall_def = thm "induct_forall_def"; 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

20 
val inductive_atomize = thms "induct_atomize"; 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

21 
val inductive_rulify = thms "induct_rulify"; 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

22 

621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

23 
fun rulify_term thy = MetaSimplifier.rewrite_term thy inductive_rulify []; 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

24 

621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

25 
val atomize_conv = 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

26 
MetaSimplifier.rewrite_cterm (true, false, false) (K (K NONE)) 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

27 
(HOL_basic_ss addsimps inductive_atomize); 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

28 
val atomize_intr = Conv.fconv_rule (Conv.prems_conv ~1 atomize_conv); 
24832  29 
fun atomize_induct ctxt = Conv.fconv_rule (Conv.prems_conv ~1 
26568  30 
(Conv.params_conv ~1 (K (Conv.prems_conv ~1 atomize_conv)) ctxt)); 
24570
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

31 

22530  32 
val finite_Un = thm "finite_Un"; 
33 
val supp_prod = thm "supp_prod"; 

34 
val fresh_prod = thm "fresh_prod"; 

35 

24570
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

36 
val perm_bool = mk_meta_eq (thm "perm_bool"); 
22313
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

37 
val perm_boolI = thm "perm_boolI"; 
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

38 
val (_, [perm_boolI_pi, _]) = Drule.strip_comb (snd (Thm.dest_comb 
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

39 
(Drule.strip_imp_concl (cprop_of perm_boolI)))); 
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

40 

25824  41 
fun mk_perm_bool pi th = th RS Drule.cterm_instantiate 
42 
[(perm_boolI_pi, pi)] perm_boolI; 

43 

24570
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

44 
fun mk_perm_bool_simproc names = Simplifier.simproc_i 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

45 
(theory_of_thm perm_bool) "perm_bool" [@{term "perm pi x"}] (fn thy => fn ss => 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

46 
fn Const ("Nominal.perm", _) $ _ $ t => 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

47 
if the_default "" (try (head_of #> dest_Const #> fst) t) mem names 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

48 
then SOME perm_bool else NONE 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

49 
 _ => NONE); 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

50 

22530  51 
val allE_Nil = read_instantiate_sg (the_context()) [("x", "[]")] allE; 
52 

22313
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

53 
fun transp ([] :: _) = [] 
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

54 
 transp xs = map hd xs :: transp (map tl xs); 
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

55 

22530  56 
fun add_binders thy i (t as (_ $ _)) bs = (case strip_comb t of 
57 
(Const (s, T), ts) => (case strip_type T of 

58 
(Ts, Type (tname, _)) => 

59 
(case NominalPackage.get_nominal_datatype thy tname of 

60 
NONE => fold (add_binders thy i) ts bs 

61 
 SOME {descr, index, ...} => (case AList.lookup op = 

62 
(#3 (the (AList.lookup op = descr index))) s of 

63 
NONE => fold (add_binders thy i) ts bs 

64 
 SOME cargs => fst (fold (fn (xs, x) => fn (bs', cargs') => 

65 
let val (cargs1, (u, _) :: cargs2) = chop (length xs) cargs' 

66 
in (add_binders thy i u 

67 
(fold (fn (u, T) => 

68 
if exists (fn j => j < i) (loose_bnos u) then I 

69 
else insert (op aconv o pairself fst) 

70 
(incr_boundvars (~i) u, T)) cargs1 bs'), cargs2) 

71 
end) cargs (bs, ts ~~ Ts)))) 

72 
 _ => fold (add_binders thy i) ts bs) 

73 
 (u, ts) => add_binders thy i u (fold (add_binders thy i) ts bs)) 

74 
 add_binders thy i (Abs (_, _, t)) bs = add_binders thy (i + 1) t bs 

75 
 add_binders thy i _ bs = bs; 

76 

24570
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

77 
fun split_conj f names (Const ("op &", _) $ p $ q) _ = (case head_of p of 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

78 
Const (name, _) => 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

79 
if name mem names then SOME (f p q) else NONE 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

80 
 _ => NONE) 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

81 
 split_conj _ _ _ _ = NONE; 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

82 

621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

83 
fun strip_all [] t = t 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

84 
 strip_all (_ :: xs) (Const ("All", _) $ Abs (s, T, t)) = strip_all xs t; 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

85 

621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

86 
(*********************************************************************) 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

87 
(* maps R ... & (ALL pi_1 ... pi_n z. P z (pi_1 o ... o pi_n o t)) *) 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

88 
(* or ALL pi_1 ... pi_n. P (pi_1 o ... o pi_n o t) *) 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

89 
(* to R ... & id (ALL z. (pi_1 o ... o pi_n o t)) *) 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

90 
(* or id (ALL z. (pi_1 o ... o pi_n o t)) *) 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

91 
(* *) 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

92 
(* where "id" protects the subformula from simplification *) 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

93 
(*********************************************************************) 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

94 

621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

95 
fun inst_conj_all names ps pis (Const ("op &", _) $ p $ q) _ = 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

96 
(case head_of p of 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

97 
Const (name, _) => 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

98 
if name mem names then SOME (HOLogic.mk_conj (p, 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

99 
Const ("Fun.id", HOLogic.boolT > HOLogic.boolT) $ 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

100 
(subst_bounds (pis, strip_all pis q)))) 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

101 
else NONE 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

102 
 _ => NONE) 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

103 
 inst_conj_all names ps pis t u = 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

104 
if member (op aconv) ps (head_of u) then 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

105 
SOME (Const ("Fun.id", HOLogic.boolT > HOLogic.boolT) $ 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

106 
(subst_bounds (pis, strip_all pis t))) 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

107 
else NONE 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

108 
 inst_conj_all _ _ _ _ _ = NONE; 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

109 

621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

110 
fun inst_conj_all_tac k = EVERY 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

111 
[TRY (EVERY [etac conjE 1, rtac conjI 1, atac 1]), 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

112 
REPEAT_DETERM_N k (etac allE 1), 
26359  113 
simp_tac (HOL_basic_ss addsimps [@{thm id_apply}]) 1]; 
24570
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

114 

621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

115 
fun map_term f t u = (case f t u of 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

116 
NONE => map_term' f t u  x => x) 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

117 
and map_term' f (t $ u) (t' $ u') = (case (map_term f t t', map_term f u u') of 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

118 
(NONE, NONE) => NONE 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

119 
 (SOME t'', NONE) => SOME (t'' $ u) 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

120 
 (NONE, SOME u'') => SOME (t $ u'') 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

121 
 (SOME t'', SOME u'') => SOME (t'' $ u'')) 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

122 
 map_term' f (Abs (s, T, t)) (Abs (s', T', t')) = (case map_term f t t' of 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

123 
NONE => NONE 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

124 
 SOME t'' => SOME (Abs (s, T, t''))) 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

125 
 map_term' _ _ _ = NONE; 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

126 

621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

127 
(*********************************************************************) 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

128 
(* Prove F[f t] from F[t], where F is monotone *) 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

129 
(*********************************************************************) 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

130 

621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

131 
fun map_thm ctxt f tac monos opt th = 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

132 
let 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

133 
val prop = prop_of th; 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

134 
fun prove t = 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

135 
Goal.prove ctxt [] [] t (fn _ => 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

136 
EVERY [cut_facts_tac [th] 1, etac rev_mp 1, 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

137 
REPEAT_DETERM (FIRSTGOAL (resolve_tac monos)), 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

138 
REPEAT_DETERM (rtac impI 1 THEN (atac 1 ORELSE tac))]) 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

139 
in Option.map prove (map_term f prop (the_default prop opt)) end; 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

140 

25824  141 
fun first_order_matchs pats objs = Thm.first_order_match 
142 
(Conjunction.mk_conjunction_balanced pats, 

143 
Conjunction.mk_conjunction_balanced objs); 

144 

145 
fun first_order_mrs ths th = ths MRS 

146 
Thm.instantiate (first_order_matchs (cprems_of th) (map cprop_of ths)) th; 

147 

22730
8bcc8809ed3b
nominal_inductive no longer proves equivariance.
berghofe
parents:
22544
diff
changeset

148 
fun prove_strong_ind s avoids thy = 
22313
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

149 
let 
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

150 
val ctxt = ProofContext.init thy; 
25824  151 
val ({names, ...}, {raw_induct, intrs, elims, ...}) = 
22730
8bcc8809ed3b
nominal_inductive no longer proves equivariance.
berghofe
parents:
22544
diff
changeset

152 
InductivePackage.the_inductive ctxt (Sign.intern_const thy s); 
25824  153 
val ind_params = InductivePackage.params_of raw_induct; 
24832  154 
val raw_induct = atomize_induct ctxt raw_induct; 
25824  155 
val elims = map (atomize_induct ctxt) elims; 
24570
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

156 
val monos = InductivePackage.get_monos ctxt; 
24571  157 
val eqvt_thms = NominalThmDecls.get_eqvt_thms ctxt; 
22788
3038bd211582
eqvt_tac now instantiates introduction rules before applying them.
berghofe
parents:
22755
diff
changeset

158 
val _ = (case names \\ foldl (apfst prop_of #> add_term_consts) [] eqvt_thms of 
3038bd211582
eqvt_tac now instantiates introduction rules before applying them.
berghofe
parents:
22755
diff
changeset

159 
[] => () 
3038bd211582
eqvt_tac now instantiates introduction rules before applying them.
berghofe
parents:
22755
diff
changeset

160 
 xs => error ("Missing equivariance theorem for predicate(s): " ^ 
3038bd211582
eqvt_tac now instantiates introduction rules before applying them.
berghofe
parents:
22755
diff
changeset

161 
commas_quote xs)); 
22530  162 
val induct_cases = map fst (fst (RuleCases.get (the 
24861
cc669ca5f382
tuned Induct interface: prefer pred'' over set'';
wenzelm
parents:
24832
diff
changeset

163 
(Induct.lookup_inductP ctxt (hd names))))); 
22530  164 
val raw_induct' = Logic.unvarify (prop_of raw_induct); 
25824  165 
val elims' = map (Logic.unvarify o prop_of) elims; 
22530  166 
val concls = raw_induct' > Logic.strip_imp_concl > HOLogic.dest_Trueprop > 
167 
HOLogic.dest_conj > map (HOLogic.dest_imp ##> strip_comb); 

168 
val ps = map (fst o snd) concls; 

169 

170 
val _ = (case duplicates (op = o pairself fst) avoids of 

171 
[] => () 

172 
 xs => error ("Duplicate case names: " ^ commas_quote (map fst xs))); 

173 
val _ = assert_all (null o duplicates op = o snd) avoids 

174 
(fn (a, _) => error ("Duplicate variable names for case " ^ quote a)); 

175 
val _ = (case map fst avoids \\ induct_cases of 

176 
[] => () 

177 
 xs => error ("No such case(s) in inductive definition: " ^ commas_quote xs)); 

25824  178 
val avoids' = if null induct_cases then replicate (length intrs) ("", []) 
179 
else map (fn name => 

180 
(name, the_default [] (AList.lookup op = avoids name))) induct_cases; 

22530  181 
fun mk_avoids params (name, ps) = 
182 
let val k = length params  1 

183 
in map (fn x => case find_index (equal x o fst) params of 

184 
~1 => error ("No such variable in case " ^ quote name ^ 

185 
" of inductive definition: " ^ quote x) 

186 
 i => (Bound (k  i), snd (nth params i))) ps 

187 
end; 

188 

189 
val prems = map (fn (prem, avoid) => 

190 
let 

191 
val prems = map (incr_boundvars 1) (Logic.strip_assums_hyp prem); 

192 
val concl = incr_boundvars 1 (Logic.strip_assums_concl prem); 

193 
val params = Logic.strip_params prem 

194 
in 

195 
(params, 

196 
fold (add_binders thy 0) (prems @ [concl]) [] @ 

197 
map (apfst (incr_boundvars 1)) (mk_avoids params avoid), 

198 
prems, strip_comb (HOLogic.dest_Trueprop concl)) 

199 
end) (Logic.strip_imp_prems raw_induct' ~~ avoids'); 

200 

201 
val atomTs = distinct op = (maps (map snd o #2) prems); 

202 
val ind_sort = if null atomTs then HOLogic.typeS 

203 
else Sign.certify_sort thy (map (fn T => Sign.intern_class thy 

204 
("fs_" ^ Sign.base_name (fst (dest_Type T)))) atomTs); 

205 
val fs_ctxt_tyname = Name.variant (map fst (term_tfrees raw_induct')) "'n"; 

206 
val fs_ctxt_name = Name.variant (add_term_names (raw_induct', [])) "z"; 

207 
val fsT = TFree (fs_ctxt_tyname, ind_sort); 

208 

24570
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

209 
val inductive_forall_def' = Drule.instantiate' 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

210 
[SOME (ctyp_of thy fsT)] [] inductive_forall_def; 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

211 

22530  212 
fun lift_pred' t (Free (s, T)) ts = 
213 
list_comb (Free (s, fsT > T), t :: ts); 

214 
val lift_pred = lift_pred' (Bound 0); 

215 

24570
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

216 
fun lift_prem (t as (f $ u)) = 
22530  217 
let val (p, ts) = strip_comb t 
218 
in 

219 
if p mem ps then 

24570
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

220 
Const (inductive_forall_name, 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

221 
(fsT > HOLogic.boolT) > HOLogic.boolT) $ 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

222 
Abs ("z", fsT, lift_pred p (map (incr_boundvars 1) ts)) 
22530  223 
else lift_prem f $ lift_prem u 
224 
end 

225 
 lift_prem (Abs (s, T, t)) = Abs (s, T, lift_prem t) 

226 
 lift_prem t = t; 

227 

228 
fun mk_distinct [] = [] 

229 
 mk_distinct ((x, T) :: xs) = List.mapPartial (fn (y, U) => 

230 
if T = U then SOME (HOLogic.mk_Trueprop 

231 
(HOLogic.mk_not (HOLogic.eq_const T $ x $ y))) 

232 
else NONE) xs @ mk_distinct xs; 

233 

234 
fun mk_fresh (x, T) = HOLogic.mk_Trueprop 

25824  235 
(NominalPackage.fresh_const T fsT $ x $ Bound 0); 
22530  236 

237 
val (prems', prems'') = split_list (map (fn (params, bvars, prems, (p, ts)) => 

238 
let 

239 
val params' = params @ [("y", fsT)]; 

240 
val prem = Logic.list_implies 

241 
(map mk_fresh bvars @ mk_distinct bvars @ 

242 
map (fn prem => 

243 
if null (term_frees prem inter ps) then prem 

244 
else lift_prem prem) prems, 

245 
HOLogic.mk_Trueprop (lift_pred p ts)); 

246 
val vs = map (Var o apfst (rpair 0)) (rename_wrt_term prem params') 

247 
in 

248 
(list_all (params', prem), (rev vs, subst_bounds (vs, prem))) 

249 
end) prems); 

250 

251 
val ind_vars = 

252 
(DatatypeProp.indexify_names (replicate (length atomTs) "pi") ~~ 

253 
map NominalAtoms.mk_permT atomTs) @ [("z", fsT)]; 

254 
val ind_Ts = rev (map snd ind_vars); 

255 

256 
val concl = HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj 

257 
(map (fn (prem, (p, ts)) => HOLogic.mk_imp (prem, 

258 
HOLogic.list_all (ind_vars, lift_pred p 

259 
(map (fold_rev (NominalPackage.mk_perm ind_Ts) 

260 
(map Bound (length atomTs downto 1))) ts)))) concls)); 

261 

262 
val concl' = HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj 

263 
(map (fn (prem, (p, ts)) => HOLogic.mk_imp (prem, 

264 
lift_pred' (Free (fs_ctxt_name, fsT)) p ts)) concls)); 

265 

266 
val vc_compat = map (fn (params, bvars, prems, (p, ts)) => 

267 
map (fn q => list_all (params, incr_boundvars ~1 (Logic.list_implies 

24570
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

268 
(List.mapPartial (fn prem => 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

269 
if null (ps inter term_frees prem) then SOME prem 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

270 
else map_term (split_conj (K o I) names) prem prem) prems, q)))) 
22530  271 
(mk_distinct bvars @ 
272 
maps (fn (t, T) => map (fn (u, U) => HOLogic.mk_Trueprop 

25824  273 
(NominalPackage.fresh_const U T $ u $ t)) bvars) 
22530  274 
(ts ~~ binder_types (fastype_of p)))) prems; 
275 

26343
0dd2eab7b296
simplified get_thm(s): back to plain name argument;
wenzelm
parents:
26337
diff
changeset

276 
val perm_pi_simp = PureThy.get_thms thy "perm_pi_simp"; 
0dd2eab7b296
simplified get_thm(s): back to plain name argument;
wenzelm
parents:
26337
diff
changeset

277 
val pt2_atoms = map (fn aT => PureThy.get_thm thy 
26337  278 
("pt_" ^ Sign.base_name (fst (dest_Type aT)) ^ "2")) atomTs; 
24570
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

279 
val eqvt_ss = HOL_basic_ss addsimps (eqvt_thms @ perm_pi_simp @ pt2_atoms) 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

280 
addsimprocs [mk_perm_bool_simproc ["Fun.id"]]; 
26343
0dd2eab7b296
simplified get_thm(s): back to plain name argument;
wenzelm
parents:
26337
diff
changeset

281 
val fresh_bij = PureThy.get_thms thy "fresh_bij"; 
0dd2eab7b296
simplified get_thm(s): back to plain name argument;
wenzelm
parents:
26337
diff
changeset

282 
val perm_bij = PureThy.get_thms thy "perm_bij"; 
0dd2eab7b296
simplified get_thm(s): back to plain name argument;
wenzelm
parents:
26337
diff
changeset

283 
val fs_atoms = map (fn aT => PureThy.get_thm thy 
26337  284 
("fs_" ^ Sign.base_name (fst (dest_Type aT)) ^ "1")) atomTs; 
26343
0dd2eab7b296
simplified get_thm(s): back to plain name argument;
wenzelm
parents:
26337
diff
changeset

285 
val exists_fresh' = PureThy.get_thms thy "exists_fresh'"; 
0dd2eab7b296
simplified get_thm(s): back to plain name argument;
wenzelm
parents:
26337
diff
changeset

286 
val fresh_atm = PureThy.get_thms thy "fresh_atm"; 
0dd2eab7b296
simplified get_thm(s): back to plain name argument;
wenzelm
parents:
26337
diff
changeset

287 
val calc_atm = PureThy.get_thms thy "calc_atm"; 
0dd2eab7b296
simplified get_thm(s): back to plain name argument;
wenzelm
parents:
26337
diff
changeset

288 
val perm_fresh_fresh = PureThy.get_thms thy "perm_fresh_fresh"; 
22530  289 

290 
fun obtain_fresh_name ts T (freshs1, freshs2, ctxt) = 

291 
let 

292 
(** protect terms to avoid that supp_prod interferes with **) 

293 
(** pairs used in introduction rules of inductive predicate **) 

294 
fun protect t = 

295 
let val T = fastype_of t in Const ("Fun.id", T > T) $ t end; 

296 
val p = foldr1 HOLogic.mk_prod (map protect ts @ freshs1); 

297 
val ex = Goal.prove ctxt [] [] (HOLogic.mk_Trueprop 

298 
(HOLogic.exists_const T $ Abs ("x", T, 

25824  299 
NominalPackage.fresh_const T (fastype_of p) $ 
22530  300 
Bound 0 $ p))) 
301 
(fn _ => EVERY 

302 
[resolve_tac exists_fresh' 1, 

303 
simp_tac (HOL_ss addsimps (supp_prod :: finite_Un :: fs_atoms)) 1]); 

304 
val (([cx], ths), ctxt') = Obtain.result 

305 
(fn _ => EVERY 

306 
[etac exE 1, 

307 
full_simp_tac (HOL_ss addsimps (fresh_prod :: fresh_atm)) 1, 

26359  308 
full_simp_tac (HOL_basic_ss addsimps [@{thm id_apply}]) 1, 
22530  309 
REPEAT (etac conjE 1)]) 
310 
[ex] ctxt 

311 
in (freshs1 @ [term_of cx], freshs2 @ ths, ctxt') end; 

312 

25824  313 
fun mk_ind_proof thy thss = 
22530  314 
let val ctxt = ProofContext.init thy 
315 
in Goal.prove_global thy [] prems' concl' (fn ihyps => 

316 
let val th = Goal.prove ctxt [] [] concl (fn {context, ...} => 

317 
rtac raw_induct 1 THEN 

318 
EVERY (maps (fn ((((_, bvars, oprems, _), vc_compat_ths), ihyp), (vs, ihypt)) => 

319 
[REPEAT (rtac allI 1), simp_tac eqvt_ss 1, 

320 
SUBPROOF (fn {prems = gprems, params, concl, context = ctxt', ...} => 

321 
let 

322 
val (params', (pis, z)) = 

323 
chop (length params  length atomTs  1) (map term_of params) > 

324 
split_last; 

325 
val bvars' = map 

326 
(fn (Bound i, T) => (nth params' (length params'  i), T) 

327 
 (t, T) => (t, T)) bvars; 

328 
val pi_bvars = map (fn (t, _) => 

329 
fold_rev (NominalPackage.mk_perm []) pis t) bvars'; 

330 
val (P, ts) = strip_comb (HOLogic.dest_Trueprop (term_of concl)); 

331 
val (freshs1, freshs2, ctxt'') = fold 

332 
(obtain_fresh_name (ts @ pi_bvars)) 

333 
(map snd bvars') ([], [], ctxt'); 

334 
val freshs2' = NominalPackage.mk_not_sym freshs2; 

335 
val pis' = map NominalPackage.perm_of_pair (pi_bvars ~~ freshs1); 

24570
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

336 
fun concat_perm pi1 pi2 = 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

337 
let val T = fastype_of pi1 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

338 
in if T = fastype_of pi2 then 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

339 
Const ("List.append", T > T > T) $ pi1 $ pi2 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

340 
else pi2 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

341 
end; 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

342 
val pis'' = fold (concat_perm #> map) pis' pis; 
22530  343 
val env = Pattern.first_order_match thy (ihypt, prop_of ihyp) 
344 
(Vartab.empty, Vartab.empty); 

345 
val ihyp' = Thm.instantiate ([], map (pairself (cterm_of thy)) 

346 
(map (Envir.subst_vars env) vs ~~ 

347 
map (fold_rev (NominalPackage.mk_perm []) 

348 
(rev pis' @ pis)) params' @ [z])) ihyp; 

24570
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

349 
fun mk_pi th = 
26359  350 
Simplifier.simplify (HOL_basic_ss addsimps [@{thm id_apply}] 
24570
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

351 
addsimprocs [NominalPackage.perm_simproc]) 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

352 
(Simplifier.simplify eqvt_ss 
25824  353 
(fold_rev (mk_perm_bool o cterm_of thy) 
354 
(rev pis' @ pis) th)); 

24570
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

355 
val (gprems1, gprems2) = split_list 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

356 
(map (fn (th, t) => 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

357 
if null (term_frees t inter ps) then (SOME th, mk_pi th) 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

358 
else 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

359 
(map_thm ctxt (split_conj (K o I) names) 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

360 
(etac conjunct1 1) monos NONE th, 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

361 
mk_pi (the (map_thm ctxt (inst_conj_all names ps (rev pis'')) 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

362 
(inst_conj_all_tac (length pis'')) monos (SOME t) th)))) 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

363 
(gprems ~~ oprems)) >> List.mapPartial I; 
22530  364 
val vc_compat_ths' = map (fn th => 
365 
let 

25824  366 
val th' = first_order_mrs gprems1 th; 
22530  367 
val (bop, lhs, rhs) = (case concl_of th' of 
368 
_ $ (fresh $ lhs $ rhs) => 

369 
(fn t => fn u => fresh $ t $ u, lhs, rhs) 

370 
 _ $ (_ $ (_ $ lhs $ rhs)) => 

371 
(curry (HOLogic.mk_not o HOLogic.mk_eq), lhs, rhs)); 

372 
val th'' = Goal.prove ctxt'' [] [] (HOLogic.mk_Trueprop 

373 
(bop (fold_rev (NominalPackage.mk_perm []) pis lhs) 

374 
(fold_rev (NominalPackage.mk_perm []) pis rhs))) 

375 
(fn _ => simp_tac (HOL_basic_ss addsimps 

376 
(fresh_bij @ perm_bij)) 1 THEN rtac th' 1) 

377 
in Simplifier.simplify (eqvt_ss addsimps fresh_atm) th'' end) 

378 
vc_compat_ths; 

379 
val vc_compat_ths'' = NominalPackage.mk_not_sym vc_compat_ths'; 

380 
(** Since calc_atm simplifies (pi :: 'a prm) o (x :: 'b) to x **) 

381 
(** we have to presimplify the rewrite rules **) 

382 
val calc_atm_ss = HOL_ss addsimps calc_atm @ 

383 
map (Simplifier.simplify (HOL_ss addsimps calc_atm)) 

384 
(vc_compat_ths'' @ freshs2'); 

385 
val th = Goal.prove ctxt'' [] [] 

386 
(HOLogic.mk_Trueprop (list_comb (P $ hd ts, 

387 
map (fold (NominalPackage.mk_perm []) pis') (tl ts)))) 

388 
(fn _ => EVERY ([simp_tac eqvt_ss 1, rtac ihyp' 1, 

389 
REPEAT_DETERM_N (nprems_of ihyp  length gprems) 

390 
(simp_tac calc_atm_ss 1), 

391 
REPEAT_DETERM_N (length gprems) 

24570
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

392 
(simp_tac (HOL_ss 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

393 
addsimps inductive_forall_def' :: gprems2 
22530  394 
addsimprocs [NominalPackage.perm_simproc]) 1)])); 
395 
val final = Goal.prove ctxt'' [] [] (term_of concl) 

396 
(fn _ => cut_facts_tac [th] 1 THEN full_simp_tac (HOL_ss 

397 
addsimps vc_compat_ths'' @ freshs2' @ 

398 
perm_fresh_fresh @ fresh_atm) 1); 

399 
val final' = ProofContext.export ctxt'' ctxt' [final]; 

400 
in resolve_tac final' 1 end) context 1]) 

401 
(prems ~~ thss ~~ ihyps ~~ prems''))) 

402 
in 

403 
cut_facts_tac [th] 1 THEN REPEAT (etac conjE 1) THEN 

404 
REPEAT (REPEAT (resolve_tac [conjI, impI] 1) THEN 

405 
etac impE 1 THEN atac 1 THEN REPEAT (etac allE_Nil 1) THEN 

406 
asm_full_simp_tac (simpset_of thy) 1) 

407 
end) 

408 
end; 

409 

25824  410 
(** strong case analysis rule **) 
411 

412 
val cases_prems = map (fn ((name, avoids), rule) => 

413 
let 

414 
val prem :: prems = Logic.strip_imp_prems rule; 

415 
val concl = Logic.strip_imp_concl rule; 

416 
val used = add_term_free_names (rule, []) 

417 
in 

418 
(prem, 

419 
List.drop (snd (strip_comb (HOLogic.dest_Trueprop prem)), length ind_params), 

420 
concl, 

421 
fst (fold_map (fn (prem, (_, avoid)) => fn used => 

422 
let 

423 
val prems = Logic.strip_assums_hyp prem; 

424 
val params = Logic.strip_params prem; 

425 
val bnds = fold (add_binders thy 0) prems [] @ mk_avoids params avoid; 

426 
fun mk_subst (p as (s, T)) (i, j, used, ps, qs, is, ts) = 

427 
if member (op = o apsnd fst) bnds (Bound i) then 

428 
let 

429 
val s' = Name.variant used s; 

430 
val t = Free (s', T) 

431 
in (i + 1, j, s' :: used, ps, (t, T) :: qs, i :: is, t :: ts) end 

432 
else (i + 1, j + 1, used, p :: ps, qs, is, Bound j :: ts); 

433 
val (_, _, used', ps, qs, is, ts) = fold_rev mk_subst params 

434 
(0, 0, used, [], [], [], []) 

435 
in 

436 
((ps, qs, is, map (curry subst_bounds (rev ts)) prems), used') 

437 
end) (prems ~~ avoids) used)) 

438 
end) 

439 
(InductivePackage.partition_rules' raw_induct (intrs ~~ avoids') ~~ 

440 
elims'); 

441 

442 
val cases_prems' = 

443 
map (fn (prem, args, concl, prems) => 

444 
let 

445 
fun mk_prem (ps, [], _, prems) = 

446 
list_all (ps, Logic.list_implies (prems, concl)) 

447 
 mk_prem (ps, qs, _, prems) = 

448 
list_all (ps, Logic.mk_implies 

449 
(Logic.list_implies 

450 
(mk_distinct qs @ 

451 
maps (fn (t, T) => map (fn u => HOLogic.mk_Trueprop 

452 
(NominalPackage.fresh_const T (fastype_of u) $ t $ u)) 

453 
args) qs, 

454 
HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj 

455 
(map HOLogic.dest_Trueprop prems))), 

456 
concl)) 

457 
in map mk_prem prems end) cases_prems; 

458 

459 
val cases_eqvt_ss = HOL_ss addsimps eqvt_thms @ calc_atm delsplits [split_if]; 

460 

461 
fun mk_cases_proof thy ((((name, thss), elim), (prem, args, concl, prems)), 

462 
prems') = 

463 
let val ctxt1 = ProofContext.init thy 

464 
in (name, Goal.prove_global thy [] (prem :: prems') concl (fn hyp :: hyps => 

465 
EVERY (rtac (hyp RS elim) 1 :: 

466 
map (fn (((_, vc_compat_ths), case_hyp), (_, qs, is, _)) => 

467 
SUBPROOF (fn {prems = case_hyps, params, context = ctxt2, concl, ...} => 

468 
if null qs then 

469 
rtac (first_order_mrs case_hyps case_hyp) 1 

470 
else 

471 
let 

472 
val params' = map (term_of o nth (rev params)) is; 

473 
val tab = params' ~~ map fst qs; 

474 
val (hyps1, hyps2) = chop (length args) case_hyps; 

475 
(* turns a = t and [x1 # t, ..., xn # t] *) 

476 
(* into [x1 # a, ..., xn # a] *) 

477 
fun inst_fresh th' ths = 

478 
let val (ths1, ths2) = chop (length qs) ths 

479 
in 

480 
(map (fn th => 

481 
let 

482 
val (cf, ct) = 

483 
Thm.dest_comb (Thm.dest_arg (cprop_of th)); 

484 
val arg_cong' = Drule.instantiate' 

485 
[SOME (ctyp_of_term ct)] 

486 
[NONE, SOME ct, SOME cf] (arg_cong RS iffD2); 

487 
val inst = Thm.first_order_match (ct, 

488 
Thm.dest_arg (Thm.dest_arg (cprop_of th'))) 

489 
in [th', th] MRS Thm.instantiate inst arg_cong' 

490 
end) ths1, 

491 
ths2) 

492 
end; 

493 
val (vc_compat_ths1, vc_compat_ths2) = 

494 
chop (length vc_compat_ths  length args * length qs) 

495 
(map (first_order_mrs hyps2) vc_compat_ths); 

496 
val vc_compat_ths' = 

497 
NominalPackage.mk_not_sym vc_compat_ths1 @ 

498 
flat (fst (fold_map inst_fresh hyps1 vc_compat_ths2)); 

499 
val (freshs1, freshs2, ctxt3) = fold 

500 
(obtain_fresh_name (args @ map fst qs @ params')) 

501 
(map snd qs) ([], [], ctxt2); 

502 
val freshs2' = NominalPackage.mk_not_sym freshs2; 

503 
val pis = map (NominalPackage.perm_of_pair) 

504 
((freshs1 ~~ map fst qs) @ (params' ~~ freshs1)); 

505 
val mk_pis = fold_rev mk_perm_bool (map (cterm_of thy) pis); 

506 
val obj = cterm_of thy (foldr1 HOLogic.mk_conj (map (map_aterms 

507 
(fn x as Free _ => 

508 
if x mem args then x 

509 
else (case AList.lookup op = tab x of 

510 
SOME y => y 

511 
 NONE => fold_rev (NominalPackage.mk_perm []) pis x) 

512 
 x => x) o HOLogic.dest_Trueprop o prop_of) case_hyps)); 

513 
val inst = Thm.first_order_match (Thm.dest_arg 

514 
(Drule.strip_imp_concl (hd (cprems_of case_hyp))), obj); 

515 
val th = Goal.prove ctxt3 [] [] (term_of concl) 

516 
(fn {context = ctxt4, ...} => 

517 
rtac (Thm.instantiate inst case_hyp) 1 THEN 

518 
SUBPROOF (fn {prems = fresh_hyps, ...} => 

519 
let 

520 
val fresh_hyps' = NominalPackage.mk_not_sym fresh_hyps; 

521 
val case_ss = cases_eqvt_ss addsimps 

522 
vc_compat_ths' @ freshs2' @ fresh_hyps' 

523 
val fresh_fresh_ss = case_ss addsimps perm_fresh_fresh; 

524 
val hyps1' = map 

525 
(mk_pis #> Simplifier.simplify fresh_fresh_ss) hyps1; 

526 
val hyps2' = map 

527 
(mk_pis #> Simplifier.simplify case_ss) hyps2; 

528 
val case_hyps' = hyps1' @ hyps2' 

529 
in 

530 
simp_tac case_ss 1 THEN 

531 
REPEAT_DETERM (TRY (rtac conjI 1) THEN 

532 
resolve_tac case_hyps' 1) 

533 
end) ctxt4 1) 

534 
val final = ProofContext.export ctxt3 ctxt2 [th] 

535 
in resolve_tac final 1 end) ctxt1 1) 

536 
(thss ~~ hyps ~~ prems)))) 

537 
end 

538 

22530  539 
in 
540 
thy > 

541 
ProofContext.init > 

542 
Proof.theorem_i NONE (fn thss => ProofContext.theory (fn thy => 

543 
let 

544 
val ctxt = ProofContext.init thy; 

545 
val rec_name = space_implode "_" (map Sign.base_name names); 

546 
val ind_case_names = RuleCases.case_names induct_cases; 

25824  547 
val induct_cases' = InductivePackage.partition_rules' raw_induct 
548 
(intrs ~~ induct_cases); 

549 
val thss' = map (map atomize_intr) thss; 

550 
val thsss = InductivePackage.partition_rules' raw_induct (intrs ~~ thss'); 

24570
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

551 
val strong_raw_induct = 
25824  552 
mk_ind_proof thy thss' > InductivePackage.rulify; 
553 
val strong_cases = map (mk_cases_proof thy ##> InductivePackage.rulify) 

554 
(thsss ~~ elims ~~ cases_prems ~~ cases_prems'); 

22530  555 
val strong_induct = 
556 
if length names > 1 then 

557 
(strong_raw_induct, [ind_case_names, RuleCases.consumes 0]) 

558 
else (strong_raw_induct RSN (2, rev_mp), 

559 
[ind_case_names, RuleCases.consumes 1]); 

560 
val ([strong_induct'], thy') = thy > 

24712
64ed05609568
proper Sign operations instead of Theory aliases;
wenzelm
parents:
24571
diff
changeset

561 
Sign.add_path rec_name > 
22530  562 
PureThy.add_thms [(("strong_induct", #1 strong_induct), #2 strong_induct)]; 
563 
val strong_inducts = 

564 
ProjectRule.projects ctxt (1 upto length names) strong_induct' 

565 
in 

566 
thy' > 

567 
PureThy.add_thmss [(("strong_inducts", strong_inducts), 

568 
[ind_case_names, RuleCases.consumes 1])] > snd > 

25824  569 
Sign.parent_path > 
570 
fold (fn ((name, elim), (_, cases)) => 

571 
Sign.add_path (Sign.base_name name) #> 

572 
PureThy.add_thms [(("strong_cases", elim), 

573 
[RuleCases.case_names (map snd cases), 

574 
RuleCases.consumes 1])] #> snd #> 

575 
Sign.parent_path) (strong_cases ~~ induct_cases') 

22530  576 
end)) 
24570
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

577 
(map (map (rulify_term thy #> rpair [])) vc_compat) 
22530  578 
end; 
579 

22730
8bcc8809ed3b
nominal_inductive no longer proves equivariance.
berghofe
parents:
22544
diff
changeset

580 
fun prove_eqvt s xatoms thy = 
22530  581 
let 
582 
val ctxt = ProofContext.init thy; 

22788
3038bd211582
eqvt_tac now instantiates introduction rules before applying them.
berghofe
parents:
22755
diff
changeset

583 
val ({names, ...}, {raw_induct, intrs, elims, ...}) = 
22730
8bcc8809ed3b
nominal_inductive no longer proves equivariance.
berghofe
parents:
22544
diff
changeset

584 
InductivePackage.the_inductive ctxt (Sign.intern_const thy s); 
24832  585 
val raw_induct = atomize_induct ctxt raw_induct; 
586 
val elims = map (atomize_induct ctxt) elims; 

24570
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

587 
val intrs = map atomize_intr intrs; 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

588 
val monos = InductivePackage.get_monos ctxt; 
22788
3038bd211582
eqvt_tac now instantiates introduction rules before applying them.
berghofe
parents:
22755
diff
changeset

589 
val intrs' = InductivePackage.unpartition_rules intrs 
3038bd211582
eqvt_tac now instantiates introduction rules before applying them.
berghofe
parents:
22755
diff
changeset

590 
(map (fn (((s, ths), (_, k)), th) => 
3038bd211582
eqvt_tac now instantiates introduction rules before applying them.
berghofe
parents:
22755
diff
changeset

591 
(s, ths ~~ InductivePackage.infer_intro_vars th k ths)) 
3038bd211582
eqvt_tac now instantiates introduction rules before applying them.
berghofe
parents:
22755
diff
changeset

592 
(InductivePackage.partition_rules raw_induct intrs ~~ 
3038bd211582
eqvt_tac now instantiates introduction rules before applying them.
berghofe
parents:
22755
diff
changeset

593 
InductivePackage.arities_of raw_induct ~~ elims)); 
22730
8bcc8809ed3b
nominal_inductive no longer proves equivariance.
berghofe
parents:
22544
diff
changeset

594 
val atoms' = NominalAtoms.atoms_of thy; 
8bcc8809ed3b
nominal_inductive no longer proves equivariance.
berghofe
parents:
22544
diff
changeset

595 
val atoms = 
8bcc8809ed3b
nominal_inductive no longer proves equivariance.
berghofe
parents:
22544
diff
changeset

596 
if null xatoms then atoms' else 
8bcc8809ed3b
nominal_inductive no longer proves equivariance.
berghofe
parents:
22544
diff
changeset

597 
let val atoms = map (Sign.intern_type thy) xatoms 
8bcc8809ed3b
nominal_inductive no longer proves equivariance.
berghofe
parents:
22544
diff
changeset

598 
in 
8bcc8809ed3b
nominal_inductive no longer proves equivariance.
berghofe
parents:
22544
diff
changeset

599 
(case duplicates op = atoms of 
8bcc8809ed3b
nominal_inductive no longer proves equivariance.
berghofe
parents:
22544
diff
changeset

600 
[] => () 
8bcc8809ed3b
nominal_inductive no longer proves equivariance.
berghofe
parents:
22544
diff
changeset

601 
 xs => error ("Duplicate atoms: " ^ commas xs); 
8bcc8809ed3b
nominal_inductive no longer proves equivariance.
berghofe
parents:
22544
diff
changeset

602 
case atoms \\ atoms' of 
8bcc8809ed3b
nominal_inductive no longer proves equivariance.
berghofe
parents:
22544
diff
changeset

603 
[] => () 
8bcc8809ed3b
nominal_inductive no longer proves equivariance.
berghofe
parents:
22544
diff
changeset

604 
 xs => error ("No such atoms: " ^ commas xs); 
8bcc8809ed3b
nominal_inductive no longer proves equivariance.
berghofe
parents:
22544
diff
changeset

605 
atoms) 
8bcc8809ed3b
nominal_inductive no longer proves equivariance.
berghofe
parents:
22544
diff
changeset

606 
end; 
26343
0dd2eab7b296
simplified get_thm(s): back to plain name argument;
wenzelm
parents:
26337
diff
changeset

607 
val perm_pi_simp = PureThy.get_thms thy "perm_pi_simp"; 
26364
cb6f360ab425
Equivariance prover now uses permutation simprocs as well.
berghofe
parents:
26359
diff
changeset

608 
val eqvt_ss = Simplifier.theory_context thy HOL_basic_ss addsimps 
24571  609 
(NominalThmDecls.get_eqvt_thms ctxt @ perm_pi_simp) addsimprocs 
26364
cb6f360ab425
Equivariance prover now uses permutation simprocs as well.
berghofe
parents:
26359
diff
changeset

610 
[mk_perm_bool_simproc names, 
cb6f360ab425
Equivariance prover now uses permutation simprocs as well.
berghofe
parents:
26359
diff
changeset

611 
NominalPermeq.perm_simproc_app, NominalPermeq.perm_simproc_fun]; 
22313
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

612 
val t = Logic.unvarify (concl_of raw_induct); 
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

613 
val pi = Name.variant (add_term_names (t, [])) "pi"; 
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

614 
val ps = map (fst o HOLogic.dest_imp) 
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

615 
(HOLogic.dest_conj (HOLogic.dest_Trueprop t)); 
25824  616 
fun eqvt_tac pi (intr, vs) st = 
22544  617 
let 
618 
fun eqvt_err s = error 

619 
("Could not prove equivariance for introduction rule\n" ^ 

620 
Sign.string_of_term (theory_of_thm intr) 

621 
(Logic.unvarify (prop_of intr)) ^ "\n" ^ s); 

22788
3038bd211582
eqvt_tac now instantiates introduction rules before applying them.
berghofe
parents:
22755
diff
changeset

622 
val res = SUBPROOF (fn {prems, params, ...} => 
3038bd211582
eqvt_tac now instantiates introduction rules before applying them.
berghofe
parents:
22755
diff
changeset

623 
let 
24570
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

624 
val prems' = map (fn th => the_default th (map_thm ctxt 
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

625 
(split_conj (K I) names) (etac conjunct2 1) monos NONE th)) prems; 
25824  626 
val prems'' = map (fn th => Simplifier.simplify eqvt_ss 
627 
(mk_perm_bool (cterm_of thy pi) th)) prems'; 

22788
3038bd211582
eqvt_tac now instantiates introduction rules before applying them.
berghofe
parents:
22755
diff
changeset

628 
val intr' = Drule.cterm_instantiate (map (cterm_of thy) vs ~~ 
3038bd211582
eqvt_tac now instantiates introduction rules before applying them.
berghofe
parents:
22755
diff
changeset

629 
map (cterm_of thy o NominalPackage.mk_perm [] pi o term_of) params) 
3038bd211582
eqvt_tac now instantiates introduction rules before applying them.
berghofe
parents:
22755
diff
changeset

630 
intr 
24570
621b60b1df00
Generalized equivariance and nominal_inductive commands to
berghofe
parents:
23531
diff
changeset

631 
in (rtac intr' THEN_ALL_NEW (TRY o resolve_tac prems'')) 1 
22544  632 
end) ctxt 1 st 
633 
in 

634 
case (Seq.pull res handle THM (s, _, _) => eqvt_err s) of 

635 
NONE => eqvt_err ("Rule does not match goal\n" ^ 

636 
Sign.string_of_term (theory_of_thm st) (hd (prems_of st))) 

637 
 SOME (th, _) => Seq.single th 

638 
end; 

22313
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

639 
val thss = map (fn atom => 
25824  640 
let val pi' = Free (pi, NominalAtoms.mk_permT (Type (atom, []))) 
22530  641 
in map (fn th => zero_var_indexes (th RS mp)) 
22313
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

642 
(DatatypeAux.split_conj_thm (Goal.prove_global thy [] [] 
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

643 
(HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj (map (fn p => 
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

644 
HOLogic.mk_imp (p, list_comb 
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

645 
(apsnd (map (NominalPackage.mk_perm [] pi')) (strip_comb p)))) ps))) 
22788
3038bd211582
eqvt_tac now instantiates introduction rules before applying them.
berghofe
parents:
22755
diff
changeset

646 
(fn _ => EVERY (rtac raw_induct 1 :: map (fn intr_vs => 
3038bd211582
eqvt_tac now instantiates introduction rules before applying them.
berghofe
parents:
22755
diff
changeset

647 
full_simp_tac eqvt_ss 1 THEN 
25824  648 
eqvt_tac pi' intr_vs) intrs')))) 
22544  649 
end) atoms 
650 
in 

651 
fold (fn (name, ths) => 

24712
64ed05609568
proper Sign operations instead of Theory aliases;
wenzelm
parents:
24571
diff
changeset

652 
Sign.add_path (Sign.base_name name) #> 
22544  653 
PureThy.add_thmss [(("eqvt", ths), [NominalThmDecls.eqvt_add])] #> snd #> 
24712
64ed05609568
proper Sign operations instead of Theory aliases;
wenzelm
parents:
24571
diff
changeset

654 
Sign.parent_path) (names ~~ transp thss) thy 
22544  655 
end; 
22313
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

656 

1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

657 

1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

658 
(* outer syntax *) 
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

659 

1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

660 
local structure P = OuterParse and K = OuterKeyword in 
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

661 

24867  662 
val _ = OuterSyntax.keywords ["avoids"]; 
663 

664 
val _ = 

22313
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

665 
OuterSyntax.command "nominal_inductive" 
22530  666 
"prove equivariance and strong induction theorem for inductive predicate involving nominal datatypes" K.thy_goal 
667 
(P.name  Scan.optional (P.$$$ "avoids"  P.and_list1 (P.name  

668 
(P.$$$ ":"  Scan.repeat1 P.name))) [] >> (fn (name, avoids) => 

22730
8bcc8809ed3b
nominal_inductive no longer proves equivariance.
berghofe
parents:
22544
diff
changeset

669 
Toplevel.print o Toplevel.theory_to_proof (prove_strong_ind name avoids))); 
22313
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

670 

24867  671 
val _ = 
22530  672 
OuterSyntax.command "equivariance" 
673 
"prove equivariance for inductive predicate involving nominal datatypes" K.thy_decl 

22730
8bcc8809ed3b
nominal_inductive no longer proves equivariance.
berghofe
parents:
22544
diff
changeset

674 
(P.name  Scan.optional (P.$$$ "["  P.list1 P.name  P.$$$ "]") [] >> 
8bcc8809ed3b
nominal_inductive no longer proves equivariance.
berghofe
parents:
22544
diff
changeset

675 
(fn (name, atoms) => Toplevel.theory (prove_eqvt name atoms))); 
22530  676 

22313
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

677 
end; 
1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

678 

1a507b463f50
First steps towards strengthening of induction rules for
berghofe
parents:
diff
changeset

679 
end 