342 else case find_first (is_dep dep) facts of |
348 else case find_first (is_dep dep) facts of |
343 SOME ((name, status), th) => accum @ [((name, status), th)] |
349 SOME ((name, status), th) => accum @ [((name, status), th)] |
344 | NONE => accum (* shouldn't happen *) |
350 | NONE => accum (* shouldn't happen *) |
345 val facts = |
351 val facts = |
346 facts |> iterative_relevant_facts ctxt params prover |
352 facts |> iterative_relevant_facts ctxt params prover |
347 (max_facts |> the_default atp_dep_default_max_fact) NONE |
353 (max_facts |> the_default atp_dependency_default_max_fact) |
348 hyp_ts concl_t |
354 NONE hyp_ts concl_t |
349 |> fold (add_isar_dep facts) isar_deps |
355 |> fold (add_isar_dep facts) (these isar_deps) |
350 |> map fix_name |
356 |> map fix_name |
351 in |
357 in |
352 if verbose andalso not auto then |
358 if verbose andalso auto_level = 0 then |
353 let val num_facts = length facts in |
359 let val num_facts = length facts in |
354 "MaSh: " ^ quote prover ^ " on " ^ quote (nickname_of th) ^ |
360 "MaSh: " ^ quote prover ^ " on " ^ quote (nickname_of th) ^ |
355 " with " ^ string_of_int num_facts ^ " fact" ^ plural_s num_facts ^ |
361 " with " ^ string_of_int num_facts ^ " fact" ^ plural_s num_facts ^ |
356 "." |
362 "." |
357 |> Output.urgent_message |
363 |> Output.urgent_message |
358 end |
364 end |
359 else |
365 else |
360 (); |
366 (); |
361 case run_prover_for_mash ctxt params prover facts goal of |
367 case run_prover_for_mash ctxt params prover facts goal of |
362 {outcome = NONE, used_facts, ...} => |
368 {outcome = NONE, used_facts, ...} => |
363 (if verbose andalso not auto then |
369 (if verbose andalso auto_level = 0 then |
364 let val num_facts = length used_facts in |
370 let val num_facts = length used_facts in |
365 "Found proof with " ^ string_of_int num_facts ^ " fact" ^ |
371 "Found proof with " ^ string_of_int num_facts ^ " fact" ^ |
366 plural_s num_facts ^ "." |
372 plural_s num_facts ^ "." |
367 |> Output.urgent_message |
373 |> Output.urgent_message |
368 end |
374 end |
369 else |
375 else |
370 (); |
376 (); |
371 used_facts |> map fst) |
377 used_facts |> map fst |> trim_dependencies) |
372 | _ => isar_deps |
378 | _ => NONE |
373 end |
379 end |
374 |
380 |
375 |
381 |
376 (*** Low-level communication with MaSh ***) |
382 (*** Low-level communication with MaSh ***) |
377 |
383 |
582 else mash_QUERY ctxt overlord (max_suggs_of max_facts) (parents, feats) |
597 else mash_QUERY ctxt overlord (max_suggs_of max_facts) (parents, feats) |
583 val selected = facts |> suggested_facts suggs |
598 val selected = facts |> suggested_facts suggs |
584 val unknown = facts |> filter_out (is_fact_in_graph fact_G) |
599 val unknown = facts |> filter_out (is_fact_in_graph fact_G) |
585 in (selected, unknown) end |
600 in (selected, unknown) end |
586 |
601 |
587 fun update_fact_graph ctxt (name, parents, feats, deps) (upds, graph) = |
602 fun add_to_fact_graph ctxt (name, parents, feats, deps) (adds, graph) = |
588 let |
603 let |
589 fun maybe_add_from from (accum as (parents, graph)) = |
604 fun maybe_add_from from (accum as (parents, graph)) = |
590 try_graph ctxt "updating graph" accum (fn () => |
605 try_graph ctxt "updating graph" accum (fn () => |
591 (from :: parents, Graph.add_edge_acyclic (from, name) graph)) |
606 (from :: parents, Graph.add_edge_acyclic (from, name) graph)) |
592 val graph = graph |> Graph.default_node (name, ()) |
607 val graph = graph |> Graph.default_node (name, ()) |
593 val (parents, graph) = ([], graph) |> fold maybe_add_from parents |
608 val (parents, graph) = ([], graph) |> fold maybe_add_from parents |
594 val (deps, graph) = ([], graph) |> fold maybe_add_from deps |
609 val (deps, graph) = ([], graph) |> fold maybe_add_from deps |
595 in ((name, parents, feats, deps) :: upds, graph) end |
610 in ((name, parents, feats, deps) :: adds, graph) end |
596 |
611 |
597 val learn_timeout_slack = 2.0 |
612 val learn_timeout_slack = 2.0 |
598 |
613 |
599 fun launch_thread timeout task = |
614 fun launch_thread timeout task = |
600 let |
615 let |
626 end) |
641 end) |
627 |
642 |
628 fun sendback sub = |
643 fun sendback sub = |
629 Markup.markup Isabelle_Markup.sendback (sledgehammerN ^ " " ^ sub) |
644 Markup.markup Isabelle_Markup.sendback (sledgehammerN ^ " " ^ sub) |
630 |
645 |
631 (* Too many dependencies is a sign that a decision procedure is at work. There |
|
632 isn't much too learn from such proofs. *) |
|
633 val max_dependencies = 10 |
|
634 val commit_timeout = seconds 30.0 |
646 val commit_timeout = seconds 30.0 |
635 |
647 |
636 (* The timeout is understood in a very slack fashion. *) |
648 (* The timeout is understood in a very slack fashion. *) |
637 fun mash_learn_facts ctxt (params as {debug, verbose, overlord, timeout, ...}) |
649 fun mash_learn_facts ctxt (params as {debug, verbose, overlord, ...}) prover |
638 prover auto atp learn_timeout facts = |
650 auto_level atp learn_timeout facts = |
639 let |
651 let |
640 val timer = Timer.startRealTimer () |
652 val timer = Timer.startRealTimer () |
641 fun next_commit_time () = |
653 fun next_commit_time () = |
642 Time.+ (Timer.checkRealTimer timer, commit_timeout) |
654 Time.+ (Timer.checkRealTimer timer, commit_timeout) |
643 val {fact_G} = mash_get ctxt |
655 val {fact_G} = mash_get ctxt |
644 val (old_facts, new_facts) = |
656 val (old_facts, new_facts) = |
645 facts |> List.partition (is_fact_in_graph fact_G) |
657 facts |> List.partition (is_fact_in_graph fact_G) |
646 ||> sort (thm_ord o pairself snd) |
658 ||> sort (thm_ord o pairself snd) |
647 val num_new_facts = length new_facts |
|
648 in |
659 in |
649 (if not auto then |
660 if null new_facts andalso (not atp orelse null old_facts) then |
650 "MaShing" ^ |
661 if auto_level < 2 then |
651 (if not auto then |
662 "No new " ^ (if atp then "ATP" else "Isar") ^ " proofs to learn." ^ |
652 " " ^ string_of_int num_new_facts ^ " fact" ^ |
663 (if auto_level = 0 andalso not atp then |
653 plural_s num_new_facts ^ |
664 "\n\nHint: Try " ^ sendback learn_atpN ^ " to learn from ATP proofs." |
654 (if atp then " (ATP timeout: " ^ string_from_time timeout ^ ")" |
665 else |
655 else "") |
666 "") |
656 else |
|
657 "") ^ "..." |
|
658 else |
|
659 "") |
|
660 |> Output.urgent_message; |
|
661 if num_new_facts = 0 then |
|
662 if not auto then |
|
663 "Nothing to learn.\n\nHint: Try " ^ sendback relearn_isarN ^ " or " ^ |
|
664 sendback relearn_atpN ^ " to learn from scratch." |
|
665 else |
667 else |
666 "" |
668 "" |
667 else |
669 else |
668 let |
670 let |
669 val last_th = new_facts |> List.last |> snd |
|
670 (* crude approximation *) |
|
671 val ancestors = |
|
672 old_facts |> filter (fn (_, th) => thm_ord (th, last_th) <> GREATER) |
|
673 val all_names = |
671 val all_names = |
674 facts |> map snd |
672 facts |> map snd |
675 |> filter_out is_likely_tautology_or_too_meta |
673 |> filter_out is_likely_tautology_or_too_meta |
676 |> map (rpair () o nickname_of) |
674 |> map (rpair () o nickname_of) |
677 |> Symtab.make |
675 |> Symtab.make |
678 fun do_commit [] state = state |
676 val deps_of = |
679 | do_commit upds {fact_G} = |
677 if atp then |
|
678 atp_dependencies_of ctxt params prover auto_level facts all_names |
|
679 else |
|
680 isar_dependencies_of all_names |
|
681 fun do_commit [] [] state = state |
|
682 | do_commit adds reps {fact_G} = |
680 let |
683 let |
681 val (upds, fact_G) = |
684 val (adds, fact_G) = |
682 ([], fact_G) |> fold (update_fact_graph ctxt) upds |
685 ([], fact_G) |> fold (add_to_fact_graph ctxt) adds |
683 in mash_ADD ctxt overlord (rev upds); {fact_G = fact_G} end |
686 in |
684 fun trim_deps deps = if length deps > max_dependencies then [] else deps |
687 mash_ADD ctxt overlord (rev adds); |
685 fun commit last upds = |
688 mash_REPROVE ctxt overlord reps; |
686 (if debug andalso not auto then Output.urgent_message "Committing..." |
689 {fact_G = fact_G} |
687 else (); |
690 end |
688 mash_map ctxt (do_commit (rev upds)); |
691 fun commit last adds reps = |
689 if not last andalso not auto then |
692 (if debug andalso auto_level = 0 then |
690 let val num_upds = length upds in |
693 Output.urgent_message "Committing..." |
691 "Processed " ^ string_of_int num_upds ^ " fact" ^ |
694 else |
692 plural_s num_upds ^ " in the last " ^ |
695 (); |
|
696 mash_map ctxt (do_commit (rev adds) reps); |
|
697 if not last andalso auto_level = 0 then |
|
698 let val num_proofs = length adds + length reps in |
|
699 "Learned " ^ string_of_int num_proofs ^ " " ^ |
|
700 (if atp then "ATP" else "Isar") ^ " proof" ^ |
|
701 plural_s num_proofs ^ " in the last " ^ |
693 string_from_time commit_timeout ^ "." |
702 string_from_time commit_timeout ^ "." |
694 |> Output.urgent_message |
703 |> Output.urgent_message |
695 end |
704 end |
696 else |
705 else |
697 ()) |
706 ()) |
698 fun do_fact _ (accum as (_, (_, _, _, true))) = accum |
707 fun learn_new_fact _ (accum as (_, (_, _, _, true))) = accum |
699 | do_fact ((_, stature), th) |
708 | learn_new_fact ((_, stature), th) |
700 (upds, (parents, n, next_commit, false)) = |
709 (adds, (parents, n, next_commit, _)) = |
701 let |
710 let |
702 val name = nickname_of th |
711 val name = nickname_of th |
703 val feats = |
712 val feats = |
704 features_of ctxt prover (theory_of_thm th) stature [prop_of th] |
713 features_of ctxt prover (theory_of_thm th) stature [prop_of th] |
705 val deps = |
714 val deps = deps_of th |> these |
706 (if atp then atp_dependencies_of ctxt params prover auto facts |
|
707 else isar_dependencies_of) all_names th |
|
708 |> trim_deps |
|
709 val n = n |> not (null deps) ? Integer.add 1 |
715 val n = n |> not (null deps) ? Integer.add 1 |
710 val upds = (name, parents, feats, deps) :: upds |
716 val adds = (name, parents, feats, deps) :: adds |
711 val (upds, next_commit) = |
717 val (adds, next_commit) = |
712 if Time.> (Timer.checkRealTimer timer, next_commit) then |
718 if Time.> (Timer.checkRealTimer timer, next_commit) then |
713 (commit false upds; ([], next_commit_time ())) |
719 (commit false adds []; ([], next_commit_time ())) |
714 else |
720 else |
715 (upds, next_commit) |
721 (adds, next_commit) |
716 val timed_out = |
722 val timed_out = Time.> (Timer.checkRealTimer timer, learn_timeout) |
717 Time.> (Timer.checkRealTimer timer, learn_timeout) |
723 in (adds, ([name], n, next_commit, timed_out)) end |
718 in (upds, ([name], n, next_commit, timed_out)) end |
724 val n = |
719 val parents = max_facts_in_graph fact_G ancestors |
725 if null new_facts then |
720 val (upds, (_, n, _, _)) = |
726 0 |
721 ([], (parents, 0, next_commit_time (), false)) |
727 else |
722 |> fold do_fact new_facts |
728 let |
|
729 val last_th = new_facts |> List.last |> snd |
|
730 (* crude approximation *) |
|
731 val ancestors = |
|
732 old_facts |
|
733 |> filter (fn (_, th) => thm_ord (th, last_th) <> GREATER) |
|
734 val parents = max_facts_in_graph fact_G ancestors |
|
735 val (adds, (_, n, _, _)) = |
|
736 ([], (parents, 0, next_commit_time (), false)) |
|
737 |> fold learn_new_fact new_facts |
|
738 in commit true adds []; n end |
|
739 fun relearn_old_fact _ (accum as (_, (_, _, true))) = accum |
|
740 | relearn_old_fact (_, th) (reps, (n, next_commit, _)) = |
|
741 let |
|
742 val name = nickname_of th |
|
743 val (n, reps) = |
|
744 case deps_of th of |
|
745 SOME deps => (n + 1, (name, deps) :: reps) |
|
746 | NONE => (n, reps) |
|
747 val (reps, next_commit) = |
|
748 if Time.> (Timer.checkRealTimer timer, next_commit) then |
|
749 (commit false [] reps; ([], next_commit_time ())) |
|
750 else |
|
751 (reps, next_commit) |
|
752 val timed_out = Time.> (Timer.checkRealTimer timer, learn_timeout) |
|
753 in (reps, (n, next_commit, timed_out)) end |
|
754 val n = |
|
755 if null old_facts then |
|
756 n |
|
757 else |
|
758 let |
|
759 fun score_of (_, th) = |
|
760 random_range 0 (1000 * max_dependencies) |
|
761 - 500 * (th |> isar_dependencies_of all_names |
|
762 |> Option.map length |
|
763 |> the_default max_dependencies) |
|
764 val old_facts = |
|
765 old_facts |> map (`score_of) |
|
766 |> sort (int_ord o pairself fst) |
|
767 |> map snd |
|
768 val (reps, (n, _, _)) = |
|
769 ([], (n, next_commit_time (), false)) |
|
770 |> fold relearn_old_fact old_facts |
|
771 in commit true [] reps; n end |
723 in |
772 in |
724 commit true upds; |
773 if verbose orelse auto_level < 2 then |
725 if verbose orelse not auto then |
774 "Learned " ^ string_of_int n ^ " nontrivial " ^ |
726 "Learned " ^ string_of_int n ^ " nontrivial proof" ^ plural_s n ^ |
775 (if atp then "ATP" else "Isar") ^ " proof" ^ plural_s n ^ |
727 (if verbose then |
776 (if verbose then |
728 " in " ^ string_from_time (Timer.checkRealTimer timer) |
777 " in " ^ string_from_time (Timer.checkRealTimer timer) |
729 else |
778 else |
730 "") ^ "." |
779 "") ^ "." |
731 else |
780 else |
732 "" |
781 "" |
733 end |
782 end |
734 end |
783 end |
735 |
784 |
736 fun mash_learn ctxt (params as {provers, ...}) fact_override chained atp = |
785 fun mash_learn ctxt (params as {provers, timeout, ...}) fact_override chained |
|
786 atp = |
737 let |
787 let |
738 val css = Sledgehammer_Fact.clasimpset_rule_table_of ctxt |
788 val css = Sledgehammer_Fact.clasimpset_rule_table_of ctxt |
739 val ctxt = ctxt |> Config.put instantiate_inducts false |
789 val ctxt = ctxt |> Config.put instantiate_inducts false |
740 val facts = |
790 val facts = |
741 nearly_all_facts ctxt false fact_override Symtab.empty css chained [] |
791 nearly_all_facts ctxt false fact_override Symtab.empty css chained [] |
742 @{prop True} |
792 @{prop True} |
|
793 val num_facts = length facts |
|
794 val prover = hd provers |
|
795 fun learn auto_level atp = |
|
796 mash_learn_facts ctxt params prover auto_level atp infinite_timeout facts |
|
797 |> Output.urgent_message |
743 in |
798 in |
744 mash_learn_facts ctxt params (hd provers) false atp infinite_timeout facts |
799 (if atp then |
745 |> Output.urgent_message |
800 ("MaShing through " ^ string_of_int num_facts ^ " fact" ^ |
|
801 plural_s num_facts ^ " for ATP proofs (" ^ quote prover ^ " timeout: " ^ |
|
802 string_from_time timeout ^ ").\n\nCollecting Isar proofs first..." |
|
803 |> Output.urgent_message; |
|
804 learn 1 false; |
|
805 "Now collecting ATP proofs. This may take several hours. You can \ |
|
806 \safely stop the learning process at any point." |
|
807 |> Output.urgent_message; |
|
808 learn 0 true) |
|
809 else |
|
810 ("MaShing through " ^ string_of_int num_facts ^ " fact" ^ |
|
811 plural_s num_facts ^ " for Isar proofs..." |
|
812 |> Output.urgent_message; |
|
813 learn 0 false)) |
746 end |
814 end |
747 |
815 |
748 (* The threshold should be large enough so that MaSh doesn't kick in for Auto |
816 (* The threshold should be large enough so that MaSh doesn't kick in for Auto |
749 Sledgehammer and Try. *) |
817 Sledgehammer and Try. *) |
750 val min_secs_for_learning = 15 |
818 val min_secs_for_learning = 15 |