src/HOL/Tools/Sledgehammer/metis_tactics.ML
changeset 38748 69fea359d3f8
parent 38695 e85ce10cef1a
child 38864 4abe644fcea5
equal deleted inserted replaced
38747:b264ae66cede 38748:69fea359d3f8
   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)