handle local facts smoothly in MaSh
authorblanchet
Fri, 20 Jul 2012 22:19:45 +0200
changeset 493939e96486d53ad
parent 49392 4a11914fd530
child 49394 2b5ad61e2ccc
handle local facts smoothly in MaSh
src/HOL/TPTP/mash_eval.ML
src/HOL/TPTP/mash_export.ML
src/HOL/Tools/Sledgehammer/sledgehammer_filter_mash.ML
     1.1 --- a/src/HOL/TPTP/mash_eval.ML	Fri Jul 20 22:19:45 2012 +0200
     1.2 +++ b/src/HOL/TPTP/mash_eval.ML	Fri Jul 20 22:19:45 2012 +0200
     1.3 @@ -28,7 +28,7 @@
     1.4  
     1.5  val all_names =
     1.6    filter_out is_likely_tautology_or_too_meta
     1.7 -  #> map (rpair () o Thm.get_name_hint) #> Symtab.make
     1.8 +  #> map (rpair () o nickname_of) #> Symtab.make
     1.9  
    1.10  fun evaluate_mash_suggestions ctxt params thy file_name =
    1.11    let
    1.12 @@ -70,7 +70,7 @@
    1.13        let
    1.14          val (name, suggs) = extract_query line
    1.15          val th =
    1.16 -          case find_first (fn (_, th) => Thm.get_name_hint th = name) facts of
    1.17 +          case find_first (fn (_, th) => nickname_of th = name) facts of
    1.18              SOME (_, th) => th
    1.19            | NONE => error ("No fact called \"" ^ name ^ "\"")
    1.20          val goal = goal_of_thm thy th
     2.1 --- a/src/HOL/TPTP/mash_export.ML	Fri Jul 20 22:19:45 2012 +0200
     2.2 +++ b/src/HOL/TPTP/mash_export.ML	Fri Jul 20 22:19:45 2012 +0200
     2.3 @@ -32,7 +32,7 @@
     2.4    ths |> sort (thm_ord o swap o pairself snd)
     2.5        |> map (snd #> `(theory_of_thm #> Context.theory_name))
     2.6        |> AList.coalesce (op =)
     2.7 -      |> map (apsnd (map Thm.get_name_hint))
     2.8 +      |> map (apsnd (map nickname_of))
     2.9  
    2.10  fun has_thy thy th =
    2.11    Context.theory_name thy = Context.theory_name (theory_of_thm th)
    2.12 @@ -51,7 +51,7 @@
    2.13  
    2.14  val all_names =
    2.15    filter_out is_likely_tautology_or_too_meta
    2.16 -  #> map (rpair () o Thm.get_name_hint) #> Symtab.make
    2.17 +  #> map (rpair () o nickname_of) #> Symtab.make
    2.18  
    2.19  fun generate_accessibility thy include_thy file_name =
    2.20    let
    2.21 @@ -83,7 +83,7 @@
    2.22        |> not include_thy ? filter_out (has_thy thy o snd)
    2.23      fun do_fact ((_, (_, status)), th) =
    2.24        let
    2.25 -        val name = Thm.get_name_hint th
    2.26 +        val name = nickname_of th
    2.27          val feats =
    2.28            features_of ctxt prover (theory_of_thm th) status [prop_of th]
    2.29          val s = escape_meta name ^ ": " ^ escape_metas feats ^ "\n"
    2.30 @@ -101,7 +101,7 @@
    2.31      val all_names = all_names ths
    2.32      fun do_thm th =
    2.33        let
    2.34 -        val name = Thm.get_name_hint th
    2.35 +        val name = nickname_of th
    2.36          val deps = isabelle_dependencies_of all_names th
    2.37          val s = escape_meta name ^ ": " ^ escape_metas deps ^ "\n"
    2.38        in File.append path s end
    2.39 @@ -118,18 +118,17 @@
    2.40        |> not include_thy ? filter_out (has_thy thy o snd)
    2.41      val ths = facts |> map snd
    2.42      val all_names = all_names ths
    2.43 -    fun is_dep dep (_, th) = Thm.get_name_hint th = dep
    2.44 +    fun is_dep dep (_, th) = nickname_of th = dep
    2.45      fun add_isar_dep facts dep accum =
    2.46        if exists (is_dep dep) accum then
    2.47          accum
    2.48        else case find_first (is_dep dep) facts of
    2.49          SOME ((name, status), th) => accum @ [((name, status), th)]
    2.50        | NONE => accum (* shouldn't happen *)
    2.51 -    fun fix_name ((_, stature), th) =
    2.52 -      ((fn () => th |> Thm.get_name_hint, stature), th)
    2.53 +    fun fix_name ((_, stature), th) = ((fn () => nickname_of th, stature), th)
    2.54      fun do_thm th =
    2.55        let
    2.56 -        val name = Thm.get_name_hint th
    2.57 +        val name = nickname_of th
    2.58          val goal = goal_of_thm thy th
    2.59          val (_, hyp_ts, concl_t) = ATP_Util.strip_subgoal ctxt goal 1
    2.60          val deps =
    2.61 @@ -168,7 +167,7 @@
    2.62      val all_names = all_names ths
    2.63      fun do_fact ((_, (_, status)), th) prevs =
    2.64        let
    2.65 -        val name = Thm.get_name_hint th
    2.66 +        val name = nickname_of th
    2.67          val feats = features_of ctxt prover thy status [prop_of th]
    2.68          val deps = isabelle_dependencies_of all_names th
    2.69          val kind = Thm.legacy_get_kind th
    2.70 @@ -196,7 +195,7 @@
    2.71              |>> sort (thm_ord o pairself snd)
    2.72      fun do_fact (fact as (_, th)) old_facts =
    2.73        let
    2.74 -        val name = Thm.get_name_hint th
    2.75 +        val name = nickname_of th
    2.76          val goal = goal_of_thm thy th
    2.77          val (_, hyp_ts, concl_t) = ATP_Util.strip_subgoal ctxt goal 1
    2.78          val kind = Thm.legacy_get_kind th
     3.1 --- a/src/HOL/Tools/Sledgehammer/sledgehammer_filter_mash.ML	Fri Jul 20 22:19:45 2012 +0200
     3.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_filter_mash.ML	Fri Jul 20 22:19:45 2012 +0200
     3.3 @@ -25,6 +25,7 @@
     3.4    val unescape_meta : string -> string
     3.5    val unescape_metas : string -> string list
     3.6    val extract_query : string -> string * string list
     3.7 +  val nickname_of : thm -> string
     3.8    val suggested_facts : string list -> ('a * thm) list -> ('a * thm) list
     3.9    val mesh_facts :
    3.10      int -> (('a * thm) list * ('a * thm) list) list -> ('a * thm) list
    3.11 @@ -122,9 +123,30 @@
    3.12      [goal_name, suggs] => (unescape_meta goal_name, unescape_metas suggs)
    3.13    | _ => ("", [])
    3.14  
    3.15 +fun parent_of_local_thm th =
    3.16 +  let
    3.17 +    val thy = th |> Thm.theory_of_thm
    3.18 +    val facts = thy |> Global_Theory.facts_of
    3.19 +    val space = facts |> Facts.space_of
    3.20 +    fun id_of s = #id (Name_Space.the_entry space s)
    3.21 +    fun max_id (s', _) (s, id) =
    3.22 +      let val id' = id_of s' in if id > id' then (s, id) else (s', id') end
    3.23 +  in ("", ~1) |> Facts.fold_static max_id facts |> fst end
    3.24 +
    3.25 +val local_prefix = "local" ^ Long_Name.separator
    3.26 +
    3.27 +fun nickname_of th =
    3.28 +  let val hint = Thm.get_name_hint th in
    3.29 +    (* FIXME: There must be a better way to detect local facts. *)
    3.30 +    case try (unprefix local_prefix) hint of
    3.31 +      SOME suff =>
    3.32 +      parent_of_local_thm th ^ Long_Name.separator ^ Long_Name.separator ^ suff
    3.33 +    | NONE => hint
    3.34 +  end
    3.35 +
    3.36  fun suggested_facts suggs facts =
    3.37    let
    3.38 -    fun add_fact (fact as (_, th)) = Symtab.default (Thm.get_name_hint th, fact)
    3.39 +    fun add_fact (fact as (_, th)) = Symtab.default (nickname_of th, fact)
    3.40      val tab = Symtab.empty |> fold add_fact facts
    3.41    in map_filter (Symtab.lookup tab) suggs end
    3.42  
    3.43 @@ -468,11 +490,11 @@
    3.44  
    3.45  fun parents_wrt_facts facts fact_graph =
    3.46    let
    3.47 -    val facts = [] |> fold (cons o Thm.get_name_hint o snd) facts
    3.48 +    val facts = [] |> fold (cons o nickname_of o snd) facts
    3.49      val tab = Symtab.empty |> fold (fn name => Symtab.update (name, ())) facts
    3.50      fun insert_not_seen seen name =
    3.51        not (member (op =) seen name) ? insert (op =) name
    3.52 -    fun parents_of seen parents [] = parents
    3.53 +    fun parents_of _ parents [] = parents
    3.54        | parents_of seen parents (name :: names) =
    3.55          if Symtab.defined tab name then
    3.56            parents_of (name :: seen) (name :: parents) names
    3.57 @@ -488,7 +510,7 @@
    3.58  fun max_suggs_of max_facts = max_facts + Int.min (200, max_facts)
    3.59  
    3.60  fun is_fact_in_graph fact_graph (_, th) =
    3.61 -  can (Graph.get_node fact_graph) (Thm.get_name_hint th)
    3.62 +  can (Graph.get_node fact_graph) (nickname_of th)
    3.63  
    3.64  fun mash_suggest_facts ctxt ({overlord, ...} : params) prover max_facts hyp_ts
    3.65                         concl_t facts =
    3.66 @@ -545,13 +567,13 @@
    3.67          val ths = facts |> map snd
    3.68          val all_names =
    3.69            ths |> filter_out is_likely_tautology_or_too_meta
    3.70 -              |> map (rpair () o Thm.get_name_hint)
    3.71 +              |> map (rpair () o nickname_of)
    3.72                |> Symtab.make
    3.73          fun trim_deps deps = if length deps > max_dependencies then [] else deps
    3.74          fun do_fact _ (accum as (_, true)) = accum
    3.75            | do_fact ((_, (_, status)), th) ((parents, upds), false) =
    3.76              let
    3.77 -              val name = Thm.get_name_hint th
    3.78 +              val name = nickname_of th
    3.79                val feats =
    3.80                  features_of ctxt prover (theory_of_thm th) status [prop_of th]
    3.81                val deps = isabelle_dependencies_of all_names th |> trim_deps
    3.82 @@ -591,7 +613,7 @@
    3.83      val prover = hd provers
    3.84      val name = ATP_Util.timestamp () ^ " " ^ serial_string () (* fresh enough *)
    3.85      val feats = features_of ctxt prover thy General [t]
    3.86 -    val deps = used_ths |> map Thm.get_name_hint
    3.87 +    val deps = used_ths |> map nickname_of
    3.88    in
    3.89      mash_map ctxt (fn {thys, fact_graph} =>
    3.90          let