src/HOL/Tools/Sledgehammer/sledgehammer_mash.ML
changeset 60948 b710a5087116
parent 60649 e007aa6a8aa2
child 60971 6dfe08f5834e
equal deleted inserted replaced
60947:d5f7b424ba47 60948:b710a5087116
   766 fun thy_feature_of s = "y" ^ s
   766 fun thy_feature_of s = "y" ^ s
   767 fun type_feature_of s = "t" ^ s
   767 fun type_feature_of s = "t" ^ s
   768 fun class_feature_of s = "s" ^ s
   768 fun class_feature_of s = "s" ^ s
   769 val local_feature = "local"
   769 val local_feature = "local"
   770 
   770 
   771 fun crude_theory_ord p =
   771 fun crude_thm_ord ctxt =
   772   if Theory.subthy p then
   772   let
   773     if Theory.eq_thy p then EQUAL else LESS
   773     val ancestor_lengths =
   774   else if Theory.subthy (swap p) then
   774       fold (fn thy => Symtab.update (Context.theory_name thy, length (Context.ancestors_of thy)))
   775     GREATER
   775         (Theory.nodes_of (Proof_Context.theory_of ctxt)) Symtab.empty
   776   else
   776     val ancestor_length = Symtab.lookup ancestor_lengths o Context.theory_id_name
   777     (case int_ord (apply2 (length o Theory.ancestors_of) p) of
   777     fun crude_theory_ord p =
   778       EQUAL => string_ord (apply2 Context.theory_name p)
   778       if Context.eq_thy_id p then EQUAL
   779     | order => order)
   779       else if Context.proper_subthy_id p then LESS
   780 
   780       else if Context.proper_subthy_id (swap p) then GREATER
   781 fun crude_thm_ord ctxt p =
   781       else
   782   (case crude_theory_ord (apply2 Thm.theory_of_thm p) of
   782         (case apply2 ancestor_length p of
   783     EQUAL =>
   783           (SOME m, SOME n) =>
   784     (* The hack below is necessary because of odd dependencies that are not reflected in the theory
   784             (case int_ord (m, n) of
   785        comparison. *)
   785               EQUAL => string_ord (apply2 Context.theory_id_name p)
   786     let val q = apply2 (nickname_of_thm ctxt) p in
   786             | ord => ord)
   787       (* Hack to put "xxx_def" before "xxxI" and "xxxE" *)
   787         | _ => string_ord (apply2 Context.theory_id_name p))
   788       (case bool_ord (apply2 (String.isSuffix "_def") (swap q)) of
   788   in
   789         EQUAL => string_ord q
   789     fn p =>
       
   790       (case crude_theory_ord (apply2 Thm.theory_id_of_thm p) of
       
   791         EQUAL =>
       
   792         (* The hack below is necessary because of odd dependencies that are not reflected in the theory
       
   793            comparison. *)
       
   794         let val q = apply2 (nickname_of_thm ctxt) p in
       
   795           (* Hack to put "xxx_def" before "xxxI" and "xxxE" *)
       
   796           (case bool_ord (apply2 (String.isSuffix "_def") (swap q)) of
       
   797             EQUAL => string_ord q
       
   798           | ord => ord)
       
   799         end
   790       | ord => ord)
   800       | ord => ord)
   791     end
   801   end;
   792   | ord => ord)
   802 
   793 
   803 val thm_less_eq = Context.subthy_id o apply2 Thm.theory_id_of_thm
   794 val thm_less_eq = Theory.subthy o apply2 Thm.theory_of_thm
       
   795 fun thm_less p = thm_less_eq p andalso not (thm_less_eq (swap p))
   804 fun thm_less p = thm_less_eq p andalso not (thm_less_eq (swap p))
   796 
   805 
   797 val freezeT = Type.legacy_freeze_type
   806 val freezeT = Type.legacy_freeze_type
   798 
   807 
   799 fun freeze (t $ u) = freeze t $ freeze u
   808 fun freeze (t $ u) = freeze t $ freeze u
  1108              (maxs, Graph.Keys.fold (insert_new seen) (Graph.imm_preds G new) news))
  1117              (maxs, Graph.Keys.fold (insert_new seen) (Graph.imm_preds G new) news))
  1109   in
  1118   in
  1110     find_maxes Symtab.empty ([], Graph.maximals G)
  1119     find_maxes Symtab.empty ([], Graph.maximals G)
  1111   end
  1120   end
  1112 
  1121 
  1113 fun strict_subthy thyp = Theory.subthy thyp andalso not (Theory.subthy (swap thyp))
       
  1114 
       
  1115 fun maximal_wrt_access_graph _ _ [] = []
  1122 fun maximal_wrt_access_graph _ _ [] = []
  1116   | maximal_wrt_access_graph ctxt access_G ((fact as (_, th)) :: facts) =
  1123   | maximal_wrt_access_graph ctxt access_G ((fact as (_, th)) :: facts) =
  1117     let val thy = Thm.theory_of_thm th in
  1124     let val thy_id = Thm.theory_id_of_thm th in
  1118       fact :: filter_out (fn (_, th') => strict_subthy (Thm.theory_of_thm th', thy)) facts
  1125       fact :: filter_out (fn (_, th') =>
       
  1126         Context.proper_subthy_id (Thm.theory_id_of_thm th', thy_id)) facts
  1119       |> map (nickname_of_thm ctxt o snd)
  1127       |> map (nickname_of_thm ctxt o snd)
  1120       |> maximal_wrt_graph access_G
  1128       |> maximal_wrt_graph access_G
  1121     end
  1129     end
  1122 
  1130 
  1123 fun is_fact_in_graph ctxt access_G = can (Graph.get_node access_G) o nickname_of_thm ctxt
  1131 fun is_fact_in_graph ctxt access_G = can (Graph.get_node access_G) o nickname_of_thm ctxt