226 |
226 |
227 fun smart_invert_const "fequal" = @{const_name "op ="} |
227 fun smart_invert_const "fequal" = @{const_name "op ="} |
228 | smart_invert_const s = invert_const s |
228 | smart_invert_const s = invert_const s |
229 |
229 |
230 fun hol_type_from_metis_term _ (Metis.Term.Var v) = |
230 fun hol_type_from_metis_term _ (Metis.Term.Var v) = |
231 (case strip_prefix_and_undo_ascii tvar_prefix v of |
231 (case strip_prefix_and_unascii tvar_prefix v of |
232 SOME w => make_tvar w |
232 SOME w => make_tvar w |
233 | NONE => make_tvar v) |
233 | NONE => make_tvar v) |
234 | hol_type_from_metis_term ctxt (Metis.Term.Fn(x, tys)) = |
234 | hol_type_from_metis_term ctxt (Metis.Term.Fn(x, tys)) = |
235 (case strip_prefix_and_undo_ascii type_const_prefix x of |
235 (case strip_prefix_and_unascii type_const_prefix x of |
236 SOME tc => Term.Type (smart_invert_const tc, |
236 SOME tc => Term.Type (smart_invert_const tc, |
237 map (hol_type_from_metis_term ctxt) tys) |
237 map (hol_type_from_metis_term ctxt) tys) |
238 | NONE => |
238 | NONE => |
239 case strip_prefix_and_undo_ascii tfree_prefix x of |
239 case strip_prefix_and_unascii tfree_prefix x of |
240 SOME tf => mk_tfree ctxt tf |
240 SOME tf => mk_tfree ctxt tf |
241 | NONE => raise Fail ("hol_type_from_metis_term: " ^ x)); |
241 | NONE => raise Fail ("hol_type_from_metis_term: " ^ x)); |
242 |
242 |
243 (*Maps metis terms to isabelle terms*) |
243 (*Maps metis terms to isabelle terms*) |
244 fun hol_term_from_metis_PT ctxt fol_tm = |
244 fun hol_term_from_metis_PT ctxt fol_tm = |
245 let val thy = ProofContext.theory_of ctxt |
245 let val thy = ProofContext.theory_of ctxt |
246 val _ = trace_msg (fn () => "hol_term_from_metis_PT: " ^ |
246 val _ = trace_msg (fn () => "hol_term_from_metis_PT: " ^ |
247 Metis.Term.toString fol_tm) |
247 Metis.Term.toString fol_tm) |
248 fun tm_to_tt (Metis.Term.Var v) = |
248 fun tm_to_tt (Metis.Term.Var v) = |
249 (case strip_prefix_and_undo_ascii tvar_prefix v of |
249 (case strip_prefix_and_unascii tvar_prefix v of |
250 SOME w => Type (make_tvar w) |
250 SOME w => Type (make_tvar w) |
251 | NONE => |
251 | NONE => |
252 case strip_prefix_and_undo_ascii schematic_var_prefix v of |
252 case strip_prefix_and_unascii schematic_var_prefix v of |
253 SOME w => Term (mk_var (w, HOLogic.typeT)) |
253 SOME w => Term (mk_var (w, HOLogic.typeT)) |
254 | NONE => Term (mk_var (v, HOLogic.typeT)) ) |
254 | NONE => Term (mk_var (v, HOLogic.typeT)) ) |
255 (*Var from Metis with a name like _nnn; possibly a type variable*) |
255 (*Var from Metis with a name like _nnn; possibly a type variable*) |
256 | tm_to_tt (Metis.Term.Fn ("{}", [arg])) = tm_to_tt arg (*hBOOL*) |
256 | tm_to_tt (Metis.Term.Fn ("{}", [arg])) = tm_to_tt arg (*hBOOL*) |
257 | tm_to_tt (t as Metis.Term.Fn (".",_)) = |
257 | tm_to_tt (t as Metis.Term.Fn (".",_)) = |
264 end |
264 end |
265 | tm_to_tt (Metis.Term.Fn (fname, args)) = applic_to_tt (fname,args) |
265 | tm_to_tt (Metis.Term.Fn (fname, args)) = applic_to_tt (fname,args) |
266 and applic_to_tt ("=",ts) = |
266 and applic_to_tt ("=",ts) = |
267 Term (list_comb(Const (@{const_name "op ="}, HOLogic.typeT), terms_of (map tm_to_tt ts))) |
267 Term (list_comb(Const (@{const_name "op ="}, HOLogic.typeT), terms_of (map tm_to_tt ts))) |
268 | applic_to_tt (a,ts) = |
268 | applic_to_tt (a,ts) = |
269 case strip_prefix_and_undo_ascii const_prefix a of |
269 case strip_prefix_and_unascii const_prefix a of |
270 SOME b => |
270 SOME b => |
271 let val c = smart_invert_const b |
271 let val c = smart_invert_const b |
272 val ntypes = num_type_args thy c |
272 val ntypes = num_type_args thy c |
273 val nterms = length ts - ntypes |
273 val nterms = length ts - ntypes |
274 val tts = map tm_to_tt ts |
274 val tts = map tm_to_tt ts |
282 cat_lines (map (Syntax.string_of_typ ctxt) tys) ^ |
282 cat_lines (map (Syntax.string_of_typ ctxt) tys) ^ |
283 " the terms are \n" ^ |
283 " the terms are \n" ^ |
284 cat_lines (map (Syntax.string_of_term ctxt) (terms_of tts))) |
284 cat_lines (map (Syntax.string_of_term ctxt) (terms_of tts))) |
285 end |
285 end |
286 | NONE => (*Not a constant. Is it a type constructor?*) |
286 | NONE => (*Not a constant. Is it a type constructor?*) |
287 case strip_prefix_and_undo_ascii type_const_prefix a of |
287 case strip_prefix_and_unascii type_const_prefix a of |
288 SOME b => |
288 SOME b => |
289 Type (Term.Type (smart_invert_const b, types_of (map tm_to_tt ts))) |
289 Type (Term.Type (smart_invert_const b, types_of (map tm_to_tt ts))) |
290 | NONE => (*Maybe a TFree. Should then check that ts=[].*) |
290 | NONE => (*Maybe a TFree. Should then check that ts=[].*) |
291 case strip_prefix_and_undo_ascii tfree_prefix a of |
291 case strip_prefix_and_unascii tfree_prefix a of |
292 SOME b => Type (mk_tfree ctxt b) |
292 SOME b => Type (mk_tfree ctxt b) |
293 | NONE => (*a fixed variable? They are Skolem functions.*) |
293 | NONE => (*a fixed variable? They are Skolem functions.*) |
294 case strip_prefix_and_undo_ascii fixed_var_prefix a of |
294 case strip_prefix_and_unascii fixed_var_prefix a of |
295 SOME b => |
295 SOME b => |
296 let val opr = Term.Free(b, HOLogic.typeT) |
296 let val opr = Term.Free(b, HOLogic.typeT) |
297 in apply_list opr (length ts) (map tm_to_tt ts) end |
297 in apply_list opr (length ts) (map tm_to_tt ts) end |
298 | NONE => raise Fail ("unexpected metis function: " ^ a) |
298 | NONE => raise Fail ("unexpected metis function: " ^ a) |
299 in |
299 in |
305 (*Maps fully-typed metis terms to isabelle terms*) |
305 (*Maps fully-typed metis terms to isabelle terms*) |
306 fun hol_term_from_metis_FT ctxt fol_tm = |
306 fun hol_term_from_metis_FT ctxt fol_tm = |
307 let val _ = trace_msg (fn () => "hol_term_from_metis_FT: " ^ |
307 let val _ = trace_msg (fn () => "hol_term_from_metis_FT: " ^ |
308 Metis.Term.toString fol_tm) |
308 Metis.Term.toString fol_tm) |
309 fun cvt (Metis.Term.Fn ("ti", [Metis.Term.Var v, _])) = |
309 fun cvt (Metis.Term.Fn ("ti", [Metis.Term.Var v, _])) = |
310 (case strip_prefix_and_undo_ascii schematic_var_prefix v of |
310 (case strip_prefix_and_unascii schematic_var_prefix v of |
311 SOME w => mk_var(w, dummyT) |
311 SOME w => mk_var(w, dummyT) |
312 | NONE => mk_var(v, dummyT)) |
312 | NONE => mk_var(v, dummyT)) |
313 | cvt (Metis.Term.Fn ("ti", [Metis.Term.Fn ("=",[]), _])) = |
313 | cvt (Metis.Term.Fn ("ti", [Metis.Term.Fn ("=",[]), _])) = |
314 Const (@{const_name "op ="}, HOLogic.typeT) |
314 Const (@{const_name "op ="}, HOLogic.typeT) |
315 | cvt (Metis.Term.Fn ("ti", [Metis.Term.Fn (x,[]), ty])) = |
315 | cvt (Metis.Term.Fn ("ti", [Metis.Term.Fn (x,[]), ty])) = |
316 (case strip_prefix_and_undo_ascii const_prefix x of |
316 (case strip_prefix_and_unascii const_prefix x of |
317 SOME c => Const (smart_invert_const c, dummyT) |
317 SOME c => Const (smart_invert_const c, dummyT) |
318 | NONE => (*Not a constant. Is it a fixed variable??*) |
318 | NONE => (*Not a constant. Is it a fixed variable??*) |
319 case strip_prefix_and_undo_ascii fixed_var_prefix x of |
319 case strip_prefix_and_unascii fixed_var_prefix x of |
320 SOME v => Free (v, hol_type_from_metis_term ctxt ty) |
320 SOME v => Free (v, hol_type_from_metis_term ctxt ty) |
321 | NONE => raise Fail ("hol_term_from_metis_FT bad constant: " ^ x)) |
321 | NONE => raise Fail ("hol_term_from_metis_FT bad constant: " ^ x)) |
322 | cvt (Metis.Term.Fn ("ti", [Metis.Term.Fn (".",[tm1,tm2]), _])) = |
322 | cvt (Metis.Term.Fn ("ti", [Metis.Term.Fn (".",[tm1,tm2]), _])) = |
323 cvt tm1 $ cvt tm2 |
323 cvt tm1 $ cvt tm2 |
324 | cvt (Metis.Term.Fn (".",[tm1,tm2])) = (*untyped application*) |
324 | cvt (Metis.Term.Fn (".",[tm1,tm2])) = (*untyped application*) |
325 cvt tm1 $ cvt tm2 |
325 cvt tm1 $ cvt tm2 |
326 | cvt (Metis.Term.Fn ("{}", [arg])) = cvt arg (*hBOOL*) |
326 | cvt (Metis.Term.Fn ("{}", [arg])) = cvt arg (*hBOOL*) |
327 | cvt (Metis.Term.Fn ("=", [tm1,tm2])) = |
327 | cvt (Metis.Term.Fn ("=", [tm1,tm2])) = |
328 list_comb(Const (@{const_name "op ="}, HOLogic.typeT), map cvt [tm1,tm2]) |
328 list_comb(Const (@{const_name "op ="}, HOLogic.typeT), map cvt [tm1,tm2]) |
329 | cvt (t as Metis.Term.Fn (x, [])) = |
329 | cvt (t as Metis.Term.Fn (x, [])) = |
330 (case strip_prefix_and_undo_ascii const_prefix x of |
330 (case strip_prefix_and_unascii const_prefix x of |
331 SOME c => Const (smart_invert_const c, dummyT) |
331 SOME c => Const (smart_invert_const c, dummyT) |
332 | NONE => (*Not a constant. Is it a fixed variable??*) |
332 | NONE => (*Not a constant. Is it a fixed variable??*) |
333 case strip_prefix_and_undo_ascii fixed_var_prefix x of |
333 case strip_prefix_and_unascii fixed_var_prefix x of |
334 SOME v => Free (v, dummyT) |
334 SOME v => Free (v, dummyT) |
335 | NONE => (trace_msg (fn () => "hol_term_from_metis_FT bad const: " ^ x); |
335 | NONE => (trace_msg (fn () => "hol_term_from_metis_FT bad const: " ^ x); |
336 hol_term_from_metis_PT ctxt t)) |
336 hol_term_from_metis_PT ctxt t)) |
337 | cvt t = (trace_msg (fn () => "hol_term_from_metis_FT bad term: " ^ Metis.Term.toString t); |
337 | cvt t = (trace_msg (fn () => "hol_term_from_metis_FT bad term: " ^ Metis.Term.toString t); |
338 hol_term_from_metis_PT ctxt t) |
338 hol_term_from_metis_PT ctxt t) |
408 handle Option => |
408 handle Option => |
409 (trace_msg (fn() => "List.find failed for the variable " ^ x ^ |
409 (trace_msg (fn() => "List.find failed for the variable " ^ x ^ |
410 " in " ^ Display.string_of_thm ctxt i_th); |
410 " in " ^ Display.string_of_thm ctxt i_th); |
411 NONE) |
411 NONE) |
412 fun remove_typeinst (a, t) = |
412 fun remove_typeinst (a, t) = |
413 case strip_prefix_and_undo_ascii schematic_var_prefix a of |
413 case strip_prefix_and_unascii schematic_var_prefix a of |
414 SOME b => SOME (b, t) |
414 SOME b => SOME (b, t) |
415 | NONE => case strip_prefix_and_undo_ascii tvar_prefix a of |
415 | NONE => case strip_prefix_and_unascii tvar_prefix a of |
416 SOME _ => NONE (*type instantiations are forbidden!*) |
416 SOME _ => NONE (*type instantiations are forbidden!*) |
417 | NONE => SOME (a,t) (*internal Metis var?*) |
417 | NONE => SOME (a,t) (*internal Metis var?*) |
418 val _ = trace_msg (fn () => " isa th: " ^ Display.string_of_thm ctxt i_th) |
418 val _ = trace_msg (fn () => " isa th: " ^ Display.string_of_thm ctxt i_th) |
419 val substs = map_filter remove_typeinst (Metis.Subst.toList fsubst) |
419 val substs = map_filter remove_typeinst (Metis.Subst.toList fsubst) |
420 val (vars,rawtms) = ListPair.unzip (map_filter subst_translation substs) |
420 val (vars,rawtms) = ListPair.unzip (map_filter subst_translation substs) |
421 val tms = rawtms |> map (reveal_skolem_terms skolems) |> infer_types ctxt |
421 val tms = rawtms |> map (reveal_skolem_terms skolems) |> infer_types ctxt |
422 val ctm_of = cterm_incr_types thy (1 + Thm.maxidx_of i_th) |
422 val ctm_of = cterm_incr_types thy (1 + Thm.maxidx_of i_th) |