merged
authorblanchet
Wed Oct 06 17:44:21 2010 +0200 (2010-10-06)
changeset 39963626b1d360d42
parent 39929 a62e01e9b22c
parent 39962 d42ddd7407ca
child 39964 8ca95d819c7c
merged
NEWS
src/HOL/List.thy
src/HOL/Tools/Sledgehammer/meson_clausify.ML
src/HOL/Tools/Sledgehammer/metis_reconstruct.ML
src/HOL/Tools/Sledgehammer/metis_tactics.ML
src/HOL/Tools/Sledgehammer/metis_translate.ML
src/HOL/Tools/meson.ML
     1.1 --- a/NEWS	Wed Oct 06 13:48:12 2010 +0200
     1.2 +++ b/NEWS	Wed Oct 06 17:44:21 2010 +0200
     1.3 @@ -248,6 +248,46 @@
     1.4  * Function package: .psimps rules are no longer implicitly declared [simp].
     1.5  INCOMPATIBILITY.
     1.6  
     1.7 +* Weaker versions of the "meson" and "metis" proof methods are now available in
     1.8 +  "HOL-Plain", without dependency on "Hilbert_Choice". The proof methods become
     1.9 +  more powerful after "Hilbert_Choice" is loaded in "HOL-Main".
    1.10 +
    1.11 +* MESON: Renamed lemmas:
    1.12 +  meson_not_conjD ~> Meson.not_conjD
    1.13 +  meson_not_disjD ~> Meson.not_disjD
    1.14 +  meson_not_notD ~> Meson.not_notD
    1.15 +  meson_not_allD ~> Meson.not_allD
    1.16 +  meson_not_exD ~> Meson.not_exD
    1.17 +  meson_imp_to_disjD ~> Meson.imp_to_disjD
    1.18 +  meson_not_impD ~> Meson.not_impD
    1.19 +  meson_iff_to_disjD ~> Meson.iff_to_disjD
    1.20 +  meson_not_iffD ~> Meson.not_iffD
    1.21 +  meson_not_refl_disj_D ~> Meson.not_refl_disj_D
    1.22 +  meson_conj_exD1 ~> Meson.conj_exD1
    1.23 +  meson_conj_exD2 ~> Meson.conj_exD2
    1.24 +  meson_disj_exD ~> Meson.disj_exD
    1.25 +  meson_disj_exD1 ~> Meson.disj_exD1
    1.26 +  meson_disj_exD2 ~> Meson.disj_exD2
    1.27 +  meson_disj_assoc ~> Meson.disj_assoc
    1.28 +  meson_disj_comm ~> Meson.disj_comm
    1.29 +  meson_disj_FalseD1 ~> Meson.disj_FalseD1
    1.30 +  meson_disj_FalseD2 ~> Meson.disj_FalseD2
    1.31 +INCOMPATIBILITY.
    1.32 +
    1.33 +* Sledgehammer: Renamed lemmas:
    1.34 +  COMBI_def ~> Meson.COMBI_def
    1.35 +  COMBK_def ~> Meson.COMBK_def
    1.36 +  COMBB_def ~> Meson.COMBB_def
    1.37 +  COMBC_def ~> Meson.COMBC_def
    1.38 +  COMBS_def ~> Meson.COMBS_def
    1.39 +  abs_I ~> Meson.abs_I
    1.40 +  abs_K ~> Meson.abs_K
    1.41 +  abs_B ~> Meson.abs_B
    1.42 +  abs_C ~> Meson.abs_C
    1.43 +  abs_S ~> Meson.abs_S
    1.44 +INCOMPATIBILITY.
    1.45 +
    1.46 +
    1.47  *** FOL ***
    1.48  
    1.49  * All constant names are now qualified.  INCOMPATIBILITY.
     2.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     2.2 +++ b/src/HOL/ATP.thy	Wed Oct 06 17:44:21 2010 +0200
     2.3 @@ -0,0 +1,17 @@
     2.4 +(*  Title:      HOL/ATP.thy
     2.5 +    Author:     Fabian Immler, TU Muenchen
     2.6 +    Author:     Jasmin Blanchette, TU Muenchen
     2.7 +*)
     2.8 +
     2.9 +header {* Automatic Theorem Provers (ATPs) *}
    2.10 +
    2.11 +theory ATP
    2.12 +imports Plain
    2.13 +uses "Tools/ATP/atp_problem.ML"
    2.14 +     "Tools/ATP/atp_proof.ML"
    2.15 +     "Tools/ATP/atp_systems.ML"
    2.16 +begin
    2.17 +
    2.18 +setup ATP_Systems.setup
    2.19 +
    2.20 +end
     3.1 --- a/src/HOL/Hilbert_Choice.thy	Wed Oct 06 13:48:12 2010 +0200
     3.2 +++ b/src/HOL/Hilbert_Choice.thy	Wed Oct 06 17:44:21 2010 +0200
     3.3 @@ -7,8 +7,7 @@
     3.4  
     3.5  theory Hilbert_Choice
     3.6  imports Nat Wellfounded Plain
     3.7 -uses ("Tools/meson.ML")
     3.8 -     ("Tools/choice_specification.ML")
     3.9 +uses ("Tools/choice_specification.ML")
    3.10  begin
    3.11  
    3.12  subsection {* Hilbert's epsilon *}
    3.13 @@ -81,17 +80,7 @@
    3.14  
    3.15  subsection{*Axiom of Choice, Proved Using the Description Operator*}
    3.16  
    3.17 -ML {*
    3.18 -structure Meson_Choices = Named_Thms
    3.19 -(
    3.20 -  val name = "meson_choice"
    3.21 -  val description = "choice axioms for MESON's (and Metis's) skolemizer"
    3.22 -)
    3.23 -*}
    3.24 -
    3.25 -setup Meson_Choices.setup
    3.26 -
    3.27 -lemma choice [meson_choice]: "\<forall>x. \<exists>y. Q x y ==> \<exists>f. \<forall>x. Q x (f x)"
    3.28 +lemma choice: "\<forall>x. \<exists>y. Q x y ==> \<exists>f. \<forall>x. Q x (f x)"
    3.29  by (fast elim: someI)
    3.30  
    3.31  lemma bchoice: "\<forall>x\<in>S. \<exists>y. Q x y ==> \<exists>f. \<forall>x\<in>S. Q x (f x)"
    3.32 @@ -451,128 +440,6 @@
    3.33    done
    3.34  
    3.35  
    3.36 -subsection {* The Meson proof procedure *}
    3.37 -
    3.38 -subsubsection {* Negation Normal Form *}
    3.39 -
    3.40 -text {* de Morgan laws *}
    3.41 -
    3.42 -lemma meson_not_conjD: "~(P&Q) ==> ~P | ~Q"
    3.43 -  and meson_not_disjD: "~(P|Q) ==> ~P & ~Q"
    3.44 -  and meson_not_notD: "~~P ==> P"
    3.45 -  and meson_not_allD: "!!P. ~(\<forall>x. P(x)) ==> \<exists>x. ~P(x)"
    3.46 -  and meson_not_exD: "!!P. ~(\<exists>x. P(x)) ==> \<forall>x. ~P(x)"
    3.47 -  by fast+
    3.48 -
    3.49 -text {* Removal of @{text "-->"} and @{text "<->"} (positive and
    3.50 -negative occurrences) *}
    3.51 -
    3.52 -lemma meson_imp_to_disjD: "P-->Q ==> ~P | Q"
    3.53 -  and meson_not_impD: "~(P-->Q) ==> P & ~Q"
    3.54 -  and meson_iff_to_disjD: "P=Q ==> (~P | Q) & (~Q | P)"
    3.55 -  and meson_not_iffD: "~(P=Q) ==> (P | Q) & (~P | ~Q)"
    3.56 -    -- {* Much more efficient than @{prop "(P & ~Q) | (Q & ~P)"} for computing CNF *}
    3.57 -  and meson_not_refl_disj_D: "x ~= x | P ==> P"
    3.58 -  by fast+
    3.59 -
    3.60 -
    3.61 -subsubsection {* Pulling out the existential quantifiers *}
    3.62 -
    3.63 -text {* Conjunction *}
    3.64 -
    3.65 -lemma meson_conj_exD1: "!!P Q. (\<exists>x. P(x)) & Q ==> \<exists>x. P(x) & Q"
    3.66 -  and meson_conj_exD2: "!!P Q. P & (\<exists>x. Q(x)) ==> \<exists>x. P & Q(x)"
    3.67 -  by fast+
    3.68 -
    3.69 -
    3.70 -text {* Disjunction *}
    3.71 -
    3.72 -lemma meson_disj_exD: "!!P Q. (\<exists>x. P(x)) | (\<exists>x. Q(x)) ==> \<exists>x. P(x) | Q(x)"
    3.73 -  -- {* DO NOT USE with forall-Skolemization: makes fewer schematic variables!! *}
    3.74 -  -- {* With ex-Skolemization, makes fewer Skolem constants *}
    3.75 -  and meson_disj_exD1: "!!P Q. (\<exists>x. P(x)) | Q ==> \<exists>x. P(x) | Q"
    3.76 -  and meson_disj_exD2: "!!P Q. P | (\<exists>x. Q(x)) ==> \<exists>x. P | Q(x)"
    3.77 -  by fast+
    3.78 -
    3.79 -
    3.80 -subsubsection {* Generating clauses for the Meson Proof Procedure *}
    3.81 -
    3.82 -text {* Disjunctions *}
    3.83 -
    3.84 -lemma meson_disj_assoc: "(P|Q)|R ==> P|(Q|R)"
    3.85 -  and meson_disj_comm: "P|Q ==> Q|P"
    3.86 -  and meson_disj_FalseD1: "False|P ==> P"
    3.87 -  and meson_disj_FalseD2: "P|False ==> P"
    3.88 -  by fast+
    3.89 -
    3.90 -
    3.91 -subsection{*Lemmas for Meson, the Model Elimination Procedure*}
    3.92 -
    3.93 -text{* Generation of contrapositives *}
    3.94 -
    3.95 -text{*Inserts negated disjunct after removing the negation; P is a literal.
    3.96 -  Model elimination requires assuming the negation of every attempted subgoal,
    3.97 -  hence the negated disjuncts.*}
    3.98 -lemma make_neg_rule: "~P|Q ==> ((~P==>P) ==> Q)"
    3.99 -by blast
   3.100 -
   3.101 -text{*Version for Plaisted's "Postive refinement" of the Meson procedure*}
   3.102 -lemma make_refined_neg_rule: "~P|Q ==> (P ==> Q)"
   3.103 -by blast
   3.104 -
   3.105 -text{*@{term P} should be a literal*}
   3.106 -lemma make_pos_rule: "P|Q ==> ((P==>~P) ==> Q)"
   3.107 -by blast
   3.108 -
   3.109 -text{*Versions of @{text make_neg_rule} and @{text make_pos_rule} that don't
   3.110 -insert new assumptions, for ordinary resolution.*}
   3.111 -
   3.112 -lemmas make_neg_rule' = make_refined_neg_rule
   3.113 -
   3.114 -lemma make_pos_rule': "[|P|Q; ~P|] ==> Q"
   3.115 -by blast
   3.116 -
   3.117 -text{* Generation of a goal clause -- put away the final literal *}
   3.118 -
   3.119 -lemma make_neg_goal: "~P ==> ((~P==>P) ==> False)"
   3.120 -by blast
   3.121 -
   3.122 -lemma make_pos_goal: "P ==> ((P==>~P) ==> False)"
   3.123 -by blast
   3.124 -
   3.125 -
   3.126 -subsubsection{* Lemmas for Forward Proof*}
   3.127 -
   3.128 -text{*There is a similarity to congruence rules*}
   3.129 -
   3.130 -(*NOTE: could handle conjunctions (faster?) by
   3.131 -    nf(th RS conjunct2) RS (nf(th RS conjunct1) RS conjI) *)
   3.132 -lemma conj_forward: "[| P'&Q';  P' ==> P;  Q' ==> Q |] ==> P&Q"
   3.133 -by blast
   3.134 -
   3.135 -lemma disj_forward: "[| P'|Q';  P' ==> P;  Q' ==> Q |] ==> P|Q"
   3.136 -by blast
   3.137 -
   3.138 -(*Version of @{text disj_forward} for removal of duplicate literals*)
   3.139 -lemma disj_forward2:
   3.140 -    "[| P'|Q';  P' ==> P;  [| Q'; P==>False |] ==> Q |] ==> P|Q"
   3.141 -apply blast 
   3.142 -done
   3.143 -
   3.144 -lemma all_forward: "[| \<forall>x. P'(x);  !!x. P'(x) ==> P(x) |] ==> \<forall>x. P(x)"
   3.145 -by blast
   3.146 -
   3.147 -lemma ex_forward: "[| \<exists>x. P'(x);  !!x. P'(x) ==> P(x) |] ==> \<exists>x. P(x)"
   3.148 -by blast
   3.149 -
   3.150 -
   3.151 -subsection {* Meson package *}
   3.152 -
   3.153 -use "Tools/meson.ML"
   3.154 -
   3.155 -setup Meson.setup
   3.156 -
   3.157 -
   3.158  subsection {* Specification package -- Hilbertized version *}
   3.159  
   3.160  lemma exE_some: "[| Ex P ; c == Eps P |] ==> P c"
   3.161 @@ -580,5 +447,4 @@
   3.162  
   3.163  use "Tools/choice_specification.ML"
   3.164  
   3.165 -
   3.166  end
     4.1 --- a/src/HOL/IsaMakefile	Wed Oct 06 13:48:12 2010 +0200
     4.2 +++ b/src/HOL/IsaMakefile	Wed Oct 06 17:44:21 2010 +0200
     4.3 @@ -154,6 +154,8 @@
     4.4    Groups.thy \
     4.5    Inductive.thy \
     4.6    Lattices.thy \
     4.7 +  Meson.thy \
     4.8 +  Metis.thy \
     4.9    Nat.thy \
    4.10    Option.thy \
    4.11    Orderings.thy \
    4.12 @@ -201,6 +203,12 @@
    4.13    Tools/inductive_realizer.ML \
    4.14    Tools/inductive_set.ML \
    4.15    Tools/lin_arith.ML \
    4.16 +  Tools/Meson/meson.ML \
    4.17 +  Tools/Meson/meson_clausify.ML \
    4.18 +  Tools/Meson/meson_tactic.ML \
    4.19 +  Tools/Metis/metis_reconstruct.ML \
    4.20 +  Tools/Metis/metis_translate.ML \
    4.21 +  Tools/Metis/metis_tactics.ML \
    4.22    Tools/nat_arith.ML \
    4.23    Tools/primrec.ML \
    4.24    Tools/prop_logic.ML \
    4.25 @@ -219,12 +227,14 @@
    4.26    $(SRC)/Provers/Arith/fast_lin_arith.ML \
    4.27    $(SRC)/Provers/order.ML \
    4.28    $(SRC)/Provers/trancl.ML \
    4.29 +  $(SRC)/Tools/Metis/metis.ML \
    4.30    $(SRC)/Tools/rat.ML
    4.31  
    4.32  $(OUT)/HOL-Plain: plain.ML $(PLAIN_DEPENDENCIES)
    4.33  	@$(ISABELLE_TOOL) usedir -b -f plain.ML -g true $(OUT)/Pure HOL-Plain
    4.34  
    4.35  MAIN_DEPENDENCIES = $(PLAIN_DEPENDENCIES) \
    4.36 +  ATP.thy \
    4.37    Big_Operators.thy \
    4.38    Code_Evaluation.thy \
    4.39    Code_Numeral.thy \
    4.40 @@ -264,7 +274,6 @@
    4.41    $(SRC)/Provers/Arith/cancel_numerals.ML \
    4.42    $(SRC)/Provers/Arith/combine_numerals.ML \
    4.43    $(SRC)/Provers/Arith/extract_common_term.ML \
    4.44 -  $(SRC)/Tools/Metis/metis.ML \
    4.45    Tools/async_manager.ML \
    4.46    Tools/ATP/atp_problem.ML \
    4.47    Tools/ATP/atp_proof.ML \
    4.48 @@ -275,7 +284,6 @@
    4.49    Tools/int_arith.ML \
    4.50    Tools/groebner.ML \
    4.51    Tools/list_code.ML \
    4.52 -  Tools/meson.ML \
    4.53    Tools/nat_numeral_simprocs.ML \
    4.54    Tools/Nitpick/kodkod.ML \
    4.55    Tools/Nitpick/kodkod_sat.ML \
    4.56 @@ -315,10 +323,6 @@
    4.57    Tools/recdef.ML \
    4.58    Tools/record.ML \
    4.59    Tools/semiring_normalizer.ML \
    4.60 -  Tools/Sledgehammer/meson_clausify.ML \
    4.61 -  Tools/Sledgehammer/metis_reconstruct.ML \
    4.62 -  Tools/Sledgehammer/metis_translate.ML \
    4.63 -  Tools/Sledgehammer/metis_tactics.ML \
    4.64    Tools/Sledgehammer/sledgehammer.ML \
    4.65    Tools/Sledgehammer/sledgehammer_filter.ML \
    4.66    Tools/Sledgehammer/sledgehammer_minimize.ML \
     5.1 --- a/src/HOL/List.thy	Wed Oct 06 13:48:12 2010 +0200
     5.2 +++ b/src/HOL/List.thy	Wed Oct 06 17:44:21 2010 +0200
     5.3 @@ -5,7 +5,7 @@
     5.4  header {* The datatype of finite lists *}
     5.5  
     5.6  theory List
     5.7 -imports Plain Quotient Presburger Code_Numeral Sledgehammer Recdef
     5.8 +imports Plain Quotient Presburger Code_Numeral Recdef
     5.9  uses ("Tools/list_code.ML")
    5.10  begin
    5.11  
     6.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     6.2 +++ b/src/HOL/Meson.thy	Wed Oct 06 17:44:21 2010 +0200
     6.3 @@ -0,0 +1,207 @@
     6.4 +(*  Title:      HOL/Meson.thy
     6.5 +    Author:     Lawrence C. Paulson, Cambridge University Computer Laboratory
     6.6 +    Author:     Tobias Nipkow, TU Muenchen
     6.7 +    Author:     Jasmin Blanchette, TU Muenchen
     6.8 +    Copyright   2001  University of Cambridge
     6.9 +*)
    6.10 +
    6.11 +header {* MESON Proof Method *}
    6.12 +
    6.13 +theory Meson
    6.14 +imports Datatype
    6.15 +uses ("Tools/Meson/meson.ML")
    6.16 +     ("Tools/Meson/meson_clausify.ML")
    6.17 +     ("Tools/Meson/meson_tactic.ML")
    6.18 +begin
    6.19 +
    6.20 +section {* Negation Normal Form *}
    6.21 +
    6.22 +text {* de Morgan laws *}
    6.23 +
    6.24 +lemma not_conjD: "~(P&Q) ==> ~P | ~Q"
    6.25 +  and not_disjD: "~(P|Q) ==> ~P & ~Q"
    6.26 +  and not_notD: "~~P ==> P"
    6.27 +  and not_allD: "!!P. ~(\<forall>x. P(x)) ==> \<exists>x. ~P(x)"
    6.28 +  and not_exD: "!!P. ~(\<exists>x. P(x)) ==> \<forall>x. ~P(x)"
    6.29 +  by fast+
    6.30 +
    6.31 +text {* Removal of @{text "-->"} and @{text "<->"} (positive and
    6.32 +negative occurrences) *}
    6.33 +
    6.34 +lemma imp_to_disjD: "P-->Q ==> ~P | Q"
    6.35 +  and not_impD: "~(P-->Q) ==> P & ~Q"
    6.36 +  and iff_to_disjD: "P=Q ==> (~P | Q) & (~Q | P)"
    6.37 +  and not_iffD: "~(P=Q) ==> (P | Q) & (~P | ~Q)"
    6.38 +    -- {* Much more efficient than @{prop "(P & ~Q) | (Q & ~P)"} for computing CNF *}
    6.39 +  and not_refl_disj_D: "x ~= x | P ==> P"
    6.40 +  by fast+
    6.41 +
    6.42 +
    6.43 +section {* Pulling out the existential quantifiers *}
    6.44 +
    6.45 +text {* Conjunction *}
    6.46 +
    6.47 +lemma conj_exD1: "!!P Q. (\<exists>x. P(x)) & Q ==> \<exists>x. P(x) & Q"
    6.48 +  and conj_exD2: "!!P Q. P & (\<exists>x. Q(x)) ==> \<exists>x. P & Q(x)"
    6.49 +  by fast+
    6.50 +
    6.51 +
    6.52 +text {* Disjunction *}
    6.53 +
    6.54 +lemma disj_exD: "!!P Q. (\<exists>x. P(x)) | (\<exists>x. Q(x)) ==> \<exists>x. P(x) | Q(x)"
    6.55 +  -- {* DO NOT USE with forall-Skolemization: makes fewer schematic variables!! *}
    6.56 +  -- {* With ex-Skolemization, makes fewer Skolem constants *}
    6.57 +  and disj_exD1: "!!P Q. (\<exists>x. P(x)) | Q ==> \<exists>x. P(x) | Q"
    6.58 +  and disj_exD2: "!!P Q. P | (\<exists>x. Q(x)) ==> \<exists>x. P | Q(x)"
    6.59 +  by fast+
    6.60 +
    6.61 +lemma disj_assoc: "(P|Q)|R ==> P|(Q|R)"
    6.62 +  and disj_comm: "P|Q ==> Q|P"
    6.63 +  and disj_FalseD1: "False|P ==> P"
    6.64 +  and disj_FalseD2: "P|False ==> P"
    6.65 +  by fast+
    6.66 +
    6.67 +
    6.68 +text{* Generation of contrapositives *}
    6.69 +
    6.70 +text{*Inserts negated disjunct after removing the negation; P is a literal.
    6.71 +  Model elimination requires assuming the negation of every attempted subgoal,
    6.72 +  hence the negated disjuncts.*}
    6.73 +lemma make_neg_rule: "~P|Q ==> ((~P==>P) ==> Q)"
    6.74 +by blast
    6.75 +
    6.76 +text{*Version for Plaisted's "Postive refinement" of the Meson procedure*}
    6.77 +lemma make_refined_neg_rule: "~P|Q ==> (P ==> Q)"
    6.78 +by blast
    6.79 +
    6.80 +text{*@{term P} should be a literal*}
    6.81 +lemma make_pos_rule: "P|Q ==> ((P==>~P) ==> Q)"
    6.82 +by blast
    6.83 +
    6.84 +text{*Versions of @{text make_neg_rule} and @{text make_pos_rule} that don't
    6.85 +insert new assumptions, for ordinary resolution.*}
    6.86 +
    6.87 +lemmas make_neg_rule' = make_refined_neg_rule
    6.88 +
    6.89 +lemma make_pos_rule': "[|P|Q; ~P|] ==> Q"
    6.90 +by blast
    6.91 +
    6.92 +text{* Generation of a goal clause -- put away the final literal *}
    6.93 +
    6.94 +lemma make_neg_goal: "~P ==> ((~P==>P) ==> False)"
    6.95 +by blast
    6.96 +
    6.97 +lemma make_pos_goal: "P ==> ((P==>~P) ==> False)"
    6.98 +by blast
    6.99 +
   6.100 +
   6.101 +section {* Lemmas for Forward Proof *}
   6.102 +
   6.103 +text{*There is a similarity to congruence rules*}
   6.104 +
   6.105 +(*NOTE: could handle conjunctions (faster?) by
   6.106 +    nf(th RS conjunct2) RS (nf(th RS conjunct1) RS conjI) *)
   6.107 +lemma conj_forward: "[| P'&Q';  P' ==> P;  Q' ==> Q |] ==> P&Q"
   6.108 +by blast
   6.109 +
   6.110 +lemma disj_forward: "[| P'|Q';  P' ==> P;  Q' ==> Q |] ==> P|Q"
   6.111 +by blast
   6.112 +
   6.113 +(*Version of @{text disj_forward} for removal of duplicate literals*)
   6.114 +lemma disj_forward2:
   6.115 +    "[| P'|Q';  P' ==> P;  [| Q'; P==>False |] ==> Q |] ==> P|Q"
   6.116 +apply blast 
   6.117 +done
   6.118 +
   6.119 +lemma all_forward: "[| \<forall>x. P'(x);  !!x. P'(x) ==> P(x) |] ==> \<forall>x. P(x)"
   6.120 +by blast
   6.121 +
   6.122 +lemma ex_forward: "[| \<exists>x. P'(x);  !!x. P'(x) ==> P(x) |] ==> \<exists>x. P(x)"
   6.123 +by blast
   6.124 +
   6.125 +
   6.126 +section {* Clausification helper *}
   6.127 +
   6.128 +lemma TruepropI: "P \<equiv> Q \<Longrightarrow> Trueprop P \<equiv> Trueprop Q"
   6.129 +by simp
   6.130 +
   6.131 +
   6.132 +text{* Combinator translation helpers *}
   6.133 +
   6.134 +definition COMBI :: "'a \<Rightarrow> 'a" where
   6.135 +[no_atp]: "COMBI P = P"
   6.136 +
   6.137 +definition COMBK :: "'a \<Rightarrow> 'b \<Rightarrow> 'a" where
   6.138 +[no_atp]: "COMBK P Q = P"
   6.139 +
   6.140 +definition COMBB :: "('b => 'c) \<Rightarrow> ('a => 'b) \<Rightarrow> 'a \<Rightarrow> 'c" where [no_atp]:
   6.141 +"COMBB P Q R = P (Q R)"
   6.142 +
   6.143 +definition COMBC :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> 'c" where
   6.144 +[no_atp]: "COMBC P Q R = P R Q"
   6.145 +
   6.146 +definition COMBS :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'c" where
   6.147 +[no_atp]: "COMBS P Q R = P R (Q R)"
   6.148 +
   6.149 +lemma abs_S [no_atp]: "\<lambda>x. (f x) (g x) \<equiv> COMBS f g"
   6.150 +apply (rule eq_reflection)
   6.151 +apply (rule ext) 
   6.152 +apply (simp add: COMBS_def) 
   6.153 +done
   6.154 +
   6.155 +lemma abs_I [no_atp]: "\<lambda>x. x \<equiv> COMBI"
   6.156 +apply (rule eq_reflection)
   6.157 +apply (rule ext) 
   6.158 +apply (simp add: COMBI_def) 
   6.159 +done
   6.160 +
   6.161 +lemma abs_K [no_atp]: "\<lambda>x. y \<equiv> COMBK y"
   6.162 +apply (rule eq_reflection)
   6.163 +apply (rule ext) 
   6.164 +apply (simp add: COMBK_def) 
   6.165 +done
   6.166 +
   6.167 +lemma abs_B [no_atp]: "\<lambda>x. a (g x) \<equiv> COMBB a g"
   6.168 +apply (rule eq_reflection)
   6.169 +apply (rule ext) 
   6.170 +apply (simp add: COMBB_def) 
   6.171 +done
   6.172 +
   6.173 +lemma abs_C [no_atp]: "\<lambda>x. (f x) b \<equiv> COMBC f b"
   6.174 +apply (rule eq_reflection)
   6.175 +apply (rule ext) 
   6.176 +apply (simp add: COMBC_def) 
   6.177 +done
   6.178 +
   6.179 +
   6.180 +section {* Skolemization helpers *}
   6.181 +
   6.182 +definition skolem :: "'a \<Rightarrow> 'a" where
   6.183 +[no_atp]: "skolem = (\<lambda>x. x)"
   6.184 +
   6.185 +lemma skolem_COMBK_iff: "P \<longleftrightarrow> skolem (COMBK P (i\<Colon>nat))"
   6.186 +unfolding skolem_def COMBK_def by (rule refl)
   6.187 +
   6.188 +lemmas skolem_COMBK_I = iffD1 [OF skolem_COMBK_iff]
   6.189 +lemmas skolem_COMBK_D = iffD2 [OF skolem_COMBK_iff]
   6.190 +
   6.191 +
   6.192 +section {* Meson package *}
   6.193 +
   6.194 +use "Tools/Meson/meson.ML"
   6.195 +use "Tools/Meson/meson_clausify.ML"
   6.196 +use "Tools/Meson/meson_tactic.ML"
   6.197 +
   6.198 +setup {*
   6.199 +  Meson.setup
   6.200 +  #> Meson_Tactic.setup
   6.201 +*}
   6.202 +
   6.203 +hide_const (open) COMBI COMBK COMBB COMBC COMBS skolem
   6.204 +hide_fact (open) not_conjD not_disjD not_notD not_allD not_exD imp_to_disjD
   6.205 +    not_impD iff_to_disjD not_iffD not_refl_disj_D conj_exD1 conj_exD2 disj_exD
   6.206 +    disj_exD1 disj_exD2 disj_assoc disj_comm disj_FalseD1 disj_FalseD2 TruepropI
   6.207 +    COMBI_def COMBK_def COMBB_def COMBC_def COMBS_def abs_I abs_K abs_B abs_C
   6.208 +    abs_S skolem_def skolem_COMBK_iff skolem_COMBK_I skolem_COMBK_D
   6.209 +
   6.210 +end
     7.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.2 +++ b/src/HOL/Metis.thy	Wed Oct 06 17:44:21 2010 +0200
     7.3 @@ -0,0 +1,37 @@
     7.4 +(*  Title:      HOL/Metis.thy
     7.5 +    Author:     Lawrence C. Paulson, Cambridge University Computer Laboratory
     7.6 +    Author:     Jia Meng, Cambridge University Computer Laboratory and NICTA
     7.7 +    Author:     Jasmin Blanchette, TU Muenchen
     7.8 +*)
     7.9 +
    7.10 +header {* Metis Proof Method *}
    7.11 +
    7.12 +theory Metis
    7.13 +imports Meson
    7.14 +uses "~~/src/Tools/Metis/metis.ML"
    7.15 +     ("Tools/Metis/metis_translate.ML")
    7.16 +     ("Tools/Metis/metis_reconstruct.ML")
    7.17 +     ("Tools/Metis/metis_tactics.ML")
    7.18 +begin
    7.19 +
    7.20 +definition fequal :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where [no_atp]:
    7.21 +"fequal X Y \<longleftrightarrow> (X = Y)"
    7.22 +
    7.23 +lemma fequal_imp_equal [no_atp]: "\<not> fequal X Y \<or> X = Y"
    7.24 +by (simp add: fequal_def)
    7.25 +
    7.26 +lemma equal_imp_fequal [no_atp]: "\<not> X = Y \<or> fequal X Y"
    7.27 +by (simp add: fequal_def)
    7.28 +
    7.29 +lemma equal_imp_equal [no_atp]: "X = Y ==> X = Y"
    7.30 +by auto
    7.31 +
    7.32 +use "Tools/Metis/metis_translate.ML"
    7.33 +use "Tools/Metis/metis_reconstruct.ML"
    7.34 +use "Tools/Metis/metis_tactics.ML"
    7.35 +setup Metis_Tactics.setup
    7.36 +
    7.37 +hide_const (open) fequal
    7.38 +hide_fact (open) fequal_def fequal_imp_equal equal_imp_fequal equal_imp_equal
    7.39 +
    7.40 +end
     8.1 --- a/src/HOL/Plain.thy	Wed Oct 06 13:48:12 2010 +0200
     8.2 +++ b/src/HOL/Plain.thy	Wed Oct 06 17:44:21 2010 +0200
     8.3 @@ -1,7 +1,7 @@
     8.4  header {* Plain HOL *}
     8.5  
     8.6  theory Plain
     8.7 -imports Datatype FunDef Extraction
     8.8 +imports Datatype FunDef Extraction Metis
     8.9  begin
    8.10  
    8.11  text {*
     9.1 --- a/src/HOL/Probability/Sigma_Algebra.thy	Wed Oct 06 13:48:12 2010 +0200
     9.2 +++ b/src/HOL/Probability/Sigma_Algebra.thy	Wed Oct 06 17:44:21 2010 +0200
     9.3 @@ -242,7 +242,7 @@
     9.4  lemma sigma_sets_Un:
     9.5    "a \<in> sigma_sets sp A \<Longrightarrow> b \<in> sigma_sets sp A \<Longrightarrow> a \<union> b \<in> sigma_sets sp A"
     9.6  apply (simp add: Un_range_binary range_binary_eq)
     9.7 -apply (rule Union, simp add: binary_def COMBK_def fun_upd_apply)
     9.8 +apply (rule Union, simp add: binary_def fun_upd_apply)
     9.9  done
    9.10  
    9.11  lemma sigma_sets_Inter:
    10.1 --- a/src/HOL/Quotient.thy	Wed Oct 06 13:48:12 2010 +0200
    10.2 +++ b/src/HOL/Quotient.thy	Wed Oct 06 17:44:21 2010 +0200
    10.3 @@ -5,7 +5,7 @@
    10.4  header {* Definition of Quotient Types *}
    10.5  
    10.6  theory Quotient
    10.7 -imports Plain Sledgehammer
    10.8 +imports Plain Hilbert_Choice
    10.9  uses
   10.10    ("Tools/Quotient/quotient_info.ML")
   10.11    ("Tools/Quotient/quotient_typ.ML")
   10.12 @@ -319,12 +319,12 @@
   10.13  lemma ball_reg_right:
   10.14    assumes a: "\<And>x. R x \<Longrightarrow> P x \<longrightarrow> Q x"
   10.15    shows "All P \<longrightarrow> Ball R Q"
   10.16 -  using a by (metis COMBC_def Collect_def Collect_mem_eq)
   10.17 +  using a by (metis Collect_def Collect_mem_eq)
   10.18  
   10.19  lemma bex_reg_left:
   10.20    assumes a: "\<And>x. R x \<Longrightarrow> Q x \<longrightarrow> P x"
   10.21    shows "Bex R Q \<longrightarrow> Ex P"
   10.22 -  using a by (metis COMBC_def Collect_def Collect_mem_eq)
   10.23 +  using a by (metis Collect_def Collect_mem_eq)
   10.24  
   10.25  lemma ball_reg_left:
   10.26    assumes a: "equivp R"
   10.27 @@ -381,13 +381,13 @@
   10.28    assumes a: "!x :: 'a. (R x --> P x --> Q x)"
   10.29    and     b: "Ball R P"
   10.30    shows "Ball R Q"
   10.31 -  using a b by (metis COMBC_def Collect_def Collect_mem_eq)
   10.32 +  using a b by (metis Collect_def Collect_mem_eq)
   10.33  
   10.34  lemma bex_reg:
   10.35    assumes a: "!x :: 'a. (R x --> P x --> Q x)"
   10.36    and     b: "Bex R P"
   10.37    shows "Bex R Q"
   10.38 -  using a b by (metis COMBC_def Collect_def Collect_mem_eq)
   10.39 +  using a b by (metis Collect_def Collect_mem_eq)
   10.40  
   10.41  
   10.42  lemma ball_all_comm:
    11.1 --- a/src/HOL/Refute.thy	Wed Oct 06 13:48:12 2010 +0200
    11.2 +++ b/src/HOL/Refute.thy	Wed Oct 06 17:44:21 2010 +0200
    11.3 @@ -8,7 +8,7 @@
    11.4  header {* Refute *}
    11.5  
    11.6  theory Refute
    11.7 -imports Hilbert_Choice List
    11.8 +imports Hilbert_Choice List Sledgehammer
    11.9  uses "Tools/refute.ML"
   11.10  begin
   11.11  
    12.1 --- a/src/HOL/Sledgehammer.thy	Wed Oct 06 13:48:12 2010 +0200
    12.2 +++ b/src/HOL/Sledgehammer.thy	Wed Oct 06 17:44:21 2010 +0200
    12.3 @@ -1,125 +1,25 @@
    12.4  (*  Title:      HOL/Sledgehammer.thy
    12.5      Author:     Lawrence C. Paulson, Cambridge University Computer Laboratory
    12.6      Author:     Jia Meng, Cambridge University Computer Laboratory and NICTA
    12.7 -    Author:     Fabian Immler, TU Muenchen
    12.8      Author:     Jasmin Blanchette, TU Muenchen
    12.9  *)
   12.10  
   12.11  header {* Sledgehammer: Isabelle--ATP Linkup *}
   12.12  
   12.13  theory Sledgehammer
   12.14 -imports Plain Hilbert_Choice
   12.15 -uses
   12.16 -  ("Tools/ATP/atp_problem.ML")
   12.17 -  ("Tools/ATP/atp_proof.ML")
   12.18 -  ("Tools/ATP/atp_systems.ML")
   12.19 -  ("~~/src/Tools/Metis/metis.ML")
   12.20 -  ("Tools/Sledgehammer/meson_clausify.ML")
   12.21 -  ("Tools/Sledgehammer/metis_translate.ML")
   12.22 -  ("Tools/Sledgehammer/metis_reconstruct.ML")
   12.23 -  ("Tools/Sledgehammer/metis_tactics.ML")
   12.24 -  ("Tools/Sledgehammer/sledgehammer_util.ML")
   12.25 -  ("Tools/Sledgehammer/sledgehammer_filter.ML")
   12.26 -  ("Tools/Sledgehammer/sledgehammer_translate.ML")
   12.27 -  ("Tools/Sledgehammer/sledgehammer_reconstruct.ML")
   12.28 -  ("Tools/Sledgehammer/sledgehammer.ML")
   12.29 -  ("Tools/Sledgehammer/sledgehammer_minimize.ML")
   12.30 -  ("Tools/Sledgehammer/sledgehammer_isar.ML")
   12.31 +imports ATP
   12.32 +uses "Tools/Sledgehammer/sledgehammer_util.ML"
   12.33 +     "Tools/Sledgehammer/sledgehammer_filter.ML"
   12.34 +     "Tools/Sledgehammer/sledgehammer_translate.ML"
   12.35 +     "Tools/Sledgehammer/sledgehammer_reconstruct.ML"
   12.36 +     "Tools/Sledgehammer/sledgehammer.ML"
   12.37 +     "Tools/Sledgehammer/sledgehammer_minimize.ML"
   12.38 +     "Tools/Sledgehammer/sledgehammer_isar.ML"
   12.39  begin
   12.40  
   12.41 -lemma TruepropI: "P \<equiv> Q \<Longrightarrow> Trueprop P \<equiv> Trueprop Q"
   12.42 -by simp
   12.43 -
   12.44 -definition skolem :: "'a \<Rightarrow> 'a" where
   12.45 -[no_atp]: "skolem = (\<lambda>x. x)"
   12.46 -
   12.47 -definition COMBI :: "'a \<Rightarrow> 'a" where
   12.48 -[no_atp]: "COMBI P = P"
   12.49 -
   12.50 -definition COMBK :: "'a \<Rightarrow> 'b \<Rightarrow> 'a" where
   12.51 -[no_atp]: "COMBK P Q = P"
   12.52 -
   12.53 -definition COMBB :: "('b => 'c) \<Rightarrow> ('a => 'b) \<Rightarrow> 'a \<Rightarrow> 'c" where [no_atp]:
   12.54 -"COMBB P Q R = P (Q R)"
   12.55 -
   12.56 -definition COMBC :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> 'c" where
   12.57 -[no_atp]: "COMBC P Q R = P R Q"
   12.58 -
   12.59 -definition COMBS :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'c" where
   12.60 -[no_atp]: "COMBS P Q R = P R (Q R)"
   12.61 -
   12.62 -definition fequal :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where [no_atp]:
   12.63 -"fequal X Y \<longleftrightarrow> (X = Y)"
   12.64 -
   12.65 -lemma fequal_imp_equal [no_atp]: "\<not> fequal X Y \<or> X = Y"
   12.66 -by (simp add: fequal_def)
   12.67 -
   12.68 -lemma equal_imp_fequal [no_atp]: "\<not> X = Y \<or> fequal X Y"
   12.69 -by (simp add: fequal_def)
   12.70 -
   12.71 -lemma equal_imp_equal [no_atp]: "X = Y ==> X = Y"
   12.72 -by auto
   12.73 -
   12.74 -lemma skolem_COMBK_iff: "P \<longleftrightarrow> skolem (COMBK P (i\<Colon>nat))"
   12.75 -unfolding skolem_def COMBK_def by (rule refl)
   12.76 -
   12.77 -lemmas skolem_COMBK_I = iffD1 [OF skolem_COMBK_iff]
   12.78 -lemmas skolem_COMBK_D = iffD2 [OF skolem_COMBK_iff]
   12.79 -
   12.80 -text{*Theorems for translation to combinators*}
   12.81 -
   12.82 -lemma abs_S [no_atp]: "\<lambda>x. (f x) (g x) \<equiv> COMBS f g"
   12.83 -apply (rule eq_reflection)
   12.84 -apply (rule ext) 
   12.85 -apply (simp add: COMBS_def) 
   12.86 -done
   12.87 -
   12.88 -lemma abs_I [no_atp]: "\<lambda>x. x \<equiv> COMBI"
   12.89 -apply (rule eq_reflection)
   12.90 -apply (rule ext) 
   12.91 -apply (simp add: COMBI_def) 
   12.92 -done
   12.93 -
   12.94 -lemma abs_K [no_atp]: "\<lambda>x. y \<equiv> COMBK y"
   12.95 -apply (rule eq_reflection)
   12.96 -apply (rule ext) 
   12.97 -apply (simp add: COMBK_def) 
   12.98 -done
   12.99 -
  12.100 -lemma abs_B [no_atp]: "\<lambda>x. a (g x) \<equiv> COMBB a g"
  12.101 -apply (rule eq_reflection)
  12.102 -apply (rule ext) 
  12.103 -apply (simp add: COMBB_def) 
  12.104 -done
  12.105 -
  12.106 -lemma abs_C [no_atp]: "\<lambda>x. (f x) b \<equiv> COMBC f b"
  12.107 -apply (rule eq_reflection)
  12.108 -apply (rule ext) 
  12.109 -apply (simp add: COMBC_def) 
  12.110 -done
  12.111 -
  12.112 -use "Tools/ATP/atp_problem.ML"
  12.113 -use "Tools/ATP/atp_proof.ML"
  12.114 -use "Tools/ATP/atp_systems.ML"
  12.115 -setup ATP_Systems.setup
  12.116 -
  12.117 -use "~~/src/Tools/Metis/metis.ML"
  12.118 -use "Tools/Sledgehammer/meson_clausify.ML"
  12.119 -setup Meson_Clausify.setup
  12.120 -
  12.121 -use "Tools/Sledgehammer/metis_translate.ML"
  12.122 -use "Tools/Sledgehammer/metis_reconstruct.ML"
  12.123 -use "Tools/Sledgehammer/metis_tactics.ML"
  12.124 -setup Metis_Tactics.setup
  12.125 -
  12.126 -use "Tools/Sledgehammer/sledgehammer_util.ML"
  12.127 -use "Tools/Sledgehammer/sledgehammer_filter.ML"
  12.128 -use "Tools/Sledgehammer/sledgehammer_translate.ML"
  12.129 -use "Tools/Sledgehammer/sledgehammer_reconstruct.ML"
  12.130 -use "Tools/Sledgehammer/sledgehammer.ML"
  12.131 -setup Sledgehammer.setup
  12.132 -use "Tools/Sledgehammer/sledgehammer_minimize.ML"
  12.133 -use "Tools/Sledgehammer/sledgehammer_isar.ML"
  12.134 -setup Sledgehammer_Isar.setup
  12.135 +setup {*
  12.136 +  Sledgehammer.setup
  12.137 +  #> Sledgehammer_Isar.setup
  12.138 +*}
  12.139  
  12.140  end
    13.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    13.2 +++ b/src/HOL/Tools/Meson/meson.ML	Wed Oct 06 17:44:21 2010 +0200
    13.3 @@ -0,0 +1,720 @@
    13.4 +(*  Title:      HOL/Tools/Meson/meson.ML
    13.5 +    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    13.6 +    Author:     Jasmin Blanchette, TU Muenchen
    13.7 +
    13.8 +The MESON resolution proof procedure for HOL.
    13.9 +When making clauses, avoids using the rewriter -- instead uses RS recursively.
   13.10 +*)
   13.11 +
   13.12 +signature MESON =
   13.13 +sig
   13.14 +  val trace: bool Unsynchronized.ref
   13.15 +  val term_pair_of: indexname * (typ * 'a) -> term * 'a
   13.16 +  val size_of_subgoals: thm -> int
   13.17 +  val has_too_many_clauses: Proof.context -> term -> bool
   13.18 +  val make_cnf: thm list -> thm -> Proof.context -> thm list * Proof.context
   13.19 +  val finish_cnf: thm list -> thm list
   13.20 +  val presimplify: thm -> thm
   13.21 +  val make_nnf: Proof.context -> thm -> thm
   13.22 +  val choice_theorems : theory -> thm list
   13.23 +  val skolemize_with_choice_theorems : Proof.context -> thm list -> thm -> thm
   13.24 +  val skolemize : Proof.context -> thm -> thm
   13.25 +  val is_fol_term: theory -> term -> bool
   13.26 +  val make_clauses_unsorted: thm list -> thm list
   13.27 +  val make_clauses: thm list -> thm list
   13.28 +  val make_horns: thm list -> thm list
   13.29 +  val best_prolog_tac: (thm -> int) -> thm list -> tactic
   13.30 +  val depth_prolog_tac: thm list -> tactic
   13.31 +  val gocls: thm list -> thm list
   13.32 +  val skolemize_prems_tac : Proof.context -> thm list -> int -> tactic
   13.33 +  val MESON:
   13.34 +    tactic -> (thm list -> thm list) -> (thm list -> tactic) -> Proof.context
   13.35 +    -> int -> tactic
   13.36 +  val best_meson_tac: (thm -> int) -> Proof.context -> int -> tactic
   13.37 +  val safe_best_meson_tac: Proof.context -> int -> tactic
   13.38 +  val depth_meson_tac: Proof.context -> int -> tactic
   13.39 +  val prolog_step_tac': thm list -> int -> tactic
   13.40 +  val iter_deepen_prolog_tac: thm list -> tactic
   13.41 +  val iter_deepen_meson_tac: Proof.context -> thm list -> int -> tactic
   13.42 +  val make_meta_clause: thm -> thm
   13.43 +  val make_meta_clauses: thm list -> thm list
   13.44 +  val meson_tac: Proof.context -> thm list -> int -> tactic
   13.45 +  val setup: theory -> theory
   13.46 +end
   13.47 +
   13.48 +structure Meson : MESON =
   13.49 +struct
   13.50 +
   13.51 +val trace = Unsynchronized.ref false;
   13.52 +fun trace_msg msg = if ! trace then tracing (msg ()) else ();
   13.53 +
   13.54 +val max_clauses_default = 60;
   13.55 +val (max_clauses, setup) = Attrib.config_int "meson_max_clauses" (K max_clauses_default);
   13.56 +
   13.57 +(*No known example (on 1-5-2007) needs even thirty*)
   13.58 +val iter_deepen_limit = 50;
   13.59 +
   13.60 +val disj_forward = @{thm disj_forward};
   13.61 +val disj_forward2 = @{thm disj_forward2};
   13.62 +val make_pos_rule = @{thm make_pos_rule};
   13.63 +val make_pos_rule' = @{thm make_pos_rule'};
   13.64 +val make_pos_goal = @{thm make_pos_goal};
   13.65 +val make_neg_rule = @{thm make_neg_rule};
   13.66 +val make_neg_rule' = @{thm make_neg_rule'};
   13.67 +val make_neg_goal = @{thm make_neg_goal};
   13.68 +val conj_forward = @{thm conj_forward};
   13.69 +val all_forward = @{thm all_forward};
   13.70 +val ex_forward = @{thm ex_forward};
   13.71 +
   13.72 +val not_conjD = @{thm not_conjD};
   13.73 +val not_disjD = @{thm not_disjD};
   13.74 +val not_notD = @{thm not_notD};
   13.75 +val not_allD = @{thm not_allD};
   13.76 +val not_exD = @{thm not_exD};
   13.77 +val imp_to_disjD = @{thm imp_to_disjD};
   13.78 +val not_impD = @{thm not_impD};
   13.79 +val iff_to_disjD = @{thm iff_to_disjD};
   13.80 +val not_iffD = @{thm not_iffD};
   13.81 +val conj_exD1 = @{thm conj_exD1};
   13.82 +val conj_exD2 = @{thm conj_exD2};
   13.83 +val disj_exD = @{thm disj_exD};
   13.84 +val disj_exD1 = @{thm disj_exD1};
   13.85 +val disj_exD2 = @{thm disj_exD2};
   13.86 +val disj_assoc = @{thm disj_assoc};
   13.87 +val disj_comm = @{thm disj_comm};
   13.88 +val disj_FalseD1 = @{thm disj_FalseD1};
   13.89 +val disj_FalseD2 = @{thm disj_FalseD2};
   13.90 +
   13.91 +
   13.92 +(**** Operators for forward proof ****)
   13.93 +
   13.94 +
   13.95 +(** First-order Resolution **)
   13.96 +
   13.97 +fun term_pair_of (ix, (ty,t)) = (Var (ix,ty), t);
   13.98 +
   13.99 +(*FIXME: currently does not "rename variables apart"*)
  13.100 +fun first_order_resolve thA thB =
  13.101 +  (case
  13.102 +    try (fn () =>
  13.103 +      let val thy = theory_of_thm thA
  13.104 +          val tmA = concl_of thA
  13.105 +          val Const("==>",_) $ tmB $ _ = prop_of thB
  13.106 +          val tenv =
  13.107 +            Pattern.first_order_match thy (tmB, tmA)
  13.108 +                                          (Vartab.empty, Vartab.empty) |> snd
  13.109 +          val ct_pairs = map (pairself (cterm_of thy) o term_pair_of) (Vartab.dest tenv)
  13.110 +      in  thA RS (cterm_instantiate ct_pairs thB)  end) () of
  13.111 +    SOME th => th
  13.112 +  | NONE => raise THM ("first_order_resolve", 0, [thA, thB]))
  13.113 +
  13.114 +(* Applying "choice" swaps the bound variable names. We tweak
  13.115 +   "Thm.rename_boundvars"'s input to get the desired names. *)
  13.116 +fun fix_bounds (_ $ (Const (@{const_name Ex}, _)
  13.117 +                     $ Abs (_, _, Const (@{const_name All}, _) $ _)))
  13.118 +               (t0 $ (Const (@{const_name All}, T1)
  13.119 +                      $ Abs (a1, T1', Const (@{const_name Ex}, T2)
  13.120 +                                      $ Abs (a2, T2', t')))) =
  13.121 +    t0 $ (Const (@{const_name All}, T1)
  13.122 +          $ Abs (a2, T1', Const (@{const_name Ex}, T2) $ Abs (a1, T2', t')))
  13.123 +  | fix_bounds _ t = t
  13.124 +
  13.125 +(* Hack to make it less likely that we lose our precious bound variable names in
  13.126 +   "rename_bvs_RS" below, because of a clash. *)
  13.127 +val protect_prefix = "_"
  13.128 +
  13.129 +fun protect_bounds (t $ u) = protect_bounds t $ protect_bounds u
  13.130 +  | protect_bounds (Abs (s, T, t')) =
  13.131 +    Abs (protect_prefix ^ s, T, protect_bounds t')
  13.132 +  | protect_bounds t = t
  13.133 +
  13.134 +(* Forward proof while preserving bound variables names*)
  13.135 +fun rename_bvs_RS th rl =
  13.136 +  let
  13.137 +    val t = concl_of th
  13.138 +    val r = concl_of rl
  13.139 +    val th' = th RS Thm.rename_boundvars r (protect_bounds r) rl
  13.140 +    val t' = concl_of th'
  13.141 +  in Thm.rename_boundvars t' (fix_bounds t' t) th' end
  13.142 +
  13.143 +(*raises exception if no rules apply*)
  13.144 +fun tryres (th, rls) =
  13.145 +  let fun tryall [] = raise THM("tryres", 0, th::rls)
  13.146 +        | tryall (rl::rls) = (rename_bvs_RS th rl handle THM _ => tryall rls)
  13.147 +  in  tryall rls  end;
  13.148 +
  13.149 +(*Permits forward proof from rules that discharge assumptions. The supplied proof state st,
  13.150 +  e.g. from conj_forward, should have the form
  13.151 +    "[| P' ==> ?P; Q' ==> ?Q |] ==> ?P & ?Q"
  13.152 +  and the effect should be to instantiate ?P and ?Q with normalized versions of P' and Q'.*)
  13.153 +fun forward_res ctxt nf st =
  13.154 +  let fun forward_tacf [prem] = rtac (nf prem) 1
  13.155 +        | forward_tacf prems =
  13.156 +            error (cat_lines
  13.157 +              ("Bad proof state in forward_res, please inform lcp@cl.cam.ac.uk:" ::
  13.158 +                Display.string_of_thm ctxt st ::
  13.159 +                "Premises:" :: map (Display.string_of_thm ctxt) prems))
  13.160 +  in
  13.161 +    case Seq.pull (ALLGOALS (Misc_Legacy.METAHYPS forward_tacf) st)
  13.162 +    of SOME(th,_) => th
  13.163 +     | NONE => raise THM("forward_res", 0, [st])
  13.164 +  end;
  13.165 +
  13.166 +(*Are any of the logical connectives in "bs" present in the term?*)
  13.167 +fun has_conns bs =
  13.168 +  let fun has (Const _) = false
  13.169 +        | has (Const(@{const_name Trueprop},_) $ p) = has p
  13.170 +        | has (Const(@{const_name Not},_) $ p) = has p
  13.171 +        | has (Const(@{const_name HOL.disj},_) $ p $ q) = member (op =) bs @{const_name HOL.disj} orelse has p orelse has q
  13.172 +        | has (Const(@{const_name HOL.conj},_) $ p $ q) = member (op =) bs @{const_name HOL.conj} orelse has p orelse has q
  13.173 +        | has (Const(@{const_name All},_) $ Abs(_,_,p)) = member (op =) bs @{const_name All} orelse has p
  13.174 +        | has (Const(@{const_name Ex},_) $ Abs(_,_,p)) = member (op =) bs @{const_name Ex} orelse has p
  13.175 +        | has _ = false
  13.176 +  in  has  end;
  13.177 +
  13.178 +
  13.179 +(**** Clause handling ****)
  13.180 +
  13.181 +fun literals (Const(@{const_name Trueprop},_) $ P) = literals P
  13.182 +  | literals (Const(@{const_name HOL.disj},_) $ P $ Q) = literals P @ literals Q
  13.183 +  | literals (Const(@{const_name Not},_) $ P) = [(false,P)]
  13.184 +  | literals P = [(true,P)];
  13.185 +
  13.186 +(*number of literals in a term*)
  13.187 +val nliterals = length o literals;
  13.188 +
  13.189 +
  13.190 +(*** Tautology Checking ***)
  13.191 +
  13.192 +fun signed_lits_aux (Const (@{const_name HOL.disj}, _) $ P $ Q) (poslits, neglits) =
  13.193 +      signed_lits_aux Q (signed_lits_aux P (poslits, neglits))
  13.194 +  | signed_lits_aux (Const(@{const_name Not},_) $ P) (poslits, neglits) = (poslits, P::neglits)
  13.195 +  | signed_lits_aux P (poslits, neglits) = (P::poslits, neglits);
  13.196 +
  13.197 +fun signed_lits th = signed_lits_aux (HOLogic.dest_Trueprop (concl_of th)) ([],[]);
  13.198 +
  13.199 +(*Literals like X=X are tautologous*)
  13.200 +fun taut_poslit (Const(@{const_name HOL.eq},_) $ t $ u) = t aconv u
  13.201 +  | taut_poslit (Const(@{const_name True},_)) = true
  13.202 +  | taut_poslit _ = false;
  13.203 +
  13.204 +fun is_taut th =
  13.205 +  let val (poslits,neglits) = signed_lits th
  13.206 +  in  exists taut_poslit poslits
  13.207 +      orelse
  13.208 +      exists (member (op aconv) neglits) (HOLogic.false_const :: poslits)
  13.209 +  end
  13.210 +  handle TERM _ => false;       (*probably dest_Trueprop on a weird theorem*)
  13.211 +
  13.212 +
  13.213 +(*** To remove trivial negated equality literals from clauses ***)
  13.214 +
  13.215 +(*They are typically functional reflexivity axioms and are the converses of
  13.216 +  injectivity equivalences*)
  13.217 +
  13.218 +val not_refl_disj_D = @{thm not_refl_disj_D};
  13.219 +
  13.220 +(*Is either term a Var that does not properly occur in the other term?*)
  13.221 +fun eliminable (t as Var _, u) = t aconv u orelse not (Logic.occs(t,u))
  13.222 +  | eliminable (u, t as Var _) = t aconv u orelse not (Logic.occs(t,u))
  13.223 +  | eliminable _ = false;
  13.224 +
  13.225 +fun refl_clause_aux 0 th = th
  13.226 +  | refl_clause_aux n th =
  13.227 +       case HOLogic.dest_Trueprop (concl_of th) of
  13.228 +          (Const (@{const_name HOL.disj}, _) $ (Const (@{const_name HOL.disj}, _) $ _ $ _) $ _) =>
  13.229 +            refl_clause_aux n (th RS disj_assoc)    (*isolate an atom as first disjunct*)
  13.230 +        | (Const (@{const_name HOL.disj}, _) $ (Const(@{const_name Not},_) $ (Const(@{const_name HOL.eq},_) $ t $ u)) $ _) =>
  13.231 +            if eliminable(t,u)
  13.232 +            then refl_clause_aux (n-1) (th RS not_refl_disj_D)  (*Var inequation: delete*)
  13.233 +            else refl_clause_aux (n-1) (th RS disj_comm)  (*not between Vars: ignore*)
  13.234 +        | (Const (@{const_name HOL.disj}, _) $ _ $ _) => refl_clause_aux n (th RS disj_comm)
  13.235 +        | _ => (*not a disjunction*) th;
  13.236 +
  13.237 +fun notequal_lits_count (Const (@{const_name HOL.disj}, _) $ P $ Q) =
  13.238 +      notequal_lits_count P + notequal_lits_count Q
  13.239 +  | notequal_lits_count (Const(@{const_name Not},_) $ (Const(@{const_name HOL.eq},_) $ _ $ _)) = 1
  13.240 +  | notequal_lits_count _ = 0;
  13.241 +
  13.242 +(*Simplify a clause by applying reflexivity to its negated equality literals*)
  13.243 +fun refl_clause th =
  13.244 +  let val neqs = notequal_lits_count (HOLogic.dest_Trueprop (concl_of th))
  13.245 +  in  zero_var_indexes (refl_clause_aux neqs th)  end
  13.246 +  handle TERM _ => th;  (*probably dest_Trueprop on a weird theorem*)
  13.247 +
  13.248 +
  13.249 +(*** Removal of duplicate literals ***)
  13.250 +
  13.251 +(*Forward proof, passing extra assumptions as theorems to the tactic*)
  13.252 +fun forward_res2 nf hyps st =
  13.253 +  case Seq.pull
  13.254 +        (REPEAT
  13.255 +         (Misc_Legacy.METAHYPS (fn major::minors => rtac (nf (minors@hyps) major) 1) 1)
  13.256 +         st)
  13.257 +  of SOME(th,_) => th
  13.258 +   | NONE => raise THM("forward_res2", 0, [st]);
  13.259 +
  13.260 +(*Remove duplicates in P|Q by assuming ~P in Q
  13.261 +  rls (initially []) accumulates assumptions of the form P==>False*)
  13.262 +fun nodups_aux ctxt rls th = nodups_aux ctxt rls (th RS disj_assoc)
  13.263 +    handle THM _ => tryres(th,rls)
  13.264 +    handle THM _ => tryres(forward_res2 (nodups_aux ctxt) rls (th RS disj_forward2),
  13.265 +                           [disj_FalseD1, disj_FalseD2, asm_rl])
  13.266 +    handle THM _ => th;
  13.267 +
  13.268 +(*Remove duplicate literals, if there are any*)
  13.269 +fun nodups ctxt th =
  13.270 +  if has_duplicates (op =) (literals (prop_of th))
  13.271 +    then nodups_aux ctxt [] th
  13.272 +    else th;
  13.273 +
  13.274 +
  13.275 +(*** The basic CNF transformation ***)
  13.276 +
  13.277 +fun estimated_num_clauses bound t =
  13.278 + let
  13.279 +  fun sum x y = if x < bound andalso y < bound then x+y else bound
  13.280 +  fun prod x y = if x < bound andalso y < bound then x*y else bound
  13.281 +  
  13.282 +  (*Estimate the number of clauses in order to detect infeasible theorems*)
  13.283 +  fun signed_nclauses b (Const(@{const_name Trueprop},_) $ t) = signed_nclauses b t
  13.284 +    | signed_nclauses b (Const(@{const_name Not},_) $ t) = signed_nclauses (not b) t
  13.285 +    | signed_nclauses b (Const(@{const_name HOL.conj},_) $ t $ u) =
  13.286 +        if b then sum (signed_nclauses b t) (signed_nclauses b u)
  13.287 +             else prod (signed_nclauses b t) (signed_nclauses b u)
  13.288 +    | signed_nclauses b (Const(@{const_name HOL.disj},_) $ t $ u) =
  13.289 +        if b then prod (signed_nclauses b t) (signed_nclauses b u)
  13.290 +             else sum (signed_nclauses b t) (signed_nclauses b u)
  13.291 +    | signed_nclauses b (Const(@{const_name HOL.implies},_) $ t $ u) =
  13.292 +        if b then prod (signed_nclauses (not b) t) (signed_nclauses b u)
  13.293 +             else sum (signed_nclauses (not b) t) (signed_nclauses b u)
  13.294 +    | signed_nclauses b (Const(@{const_name HOL.eq}, Type ("fun", [T, _])) $ t $ u) =
  13.295 +        if T = HOLogic.boolT then (*Boolean equality is if-and-only-if*)
  13.296 +            if b then sum (prod (signed_nclauses (not b) t) (signed_nclauses b u))
  13.297 +                          (prod (signed_nclauses (not b) u) (signed_nclauses b t))
  13.298 +                 else sum (prod (signed_nclauses b t) (signed_nclauses b u))
  13.299 +                          (prod (signed_nclauses (not b) t) (signed_nclauses (not b) u))
  13.300 +        else 1
  13.301 +    | signed_nclauses b (Const(@{const_name Ex}, _) $ Abs (_,_,t)) = signed_nclauses b t
  13.302 +    | signed_nclauses b (Const(@{const_name All},_) $ Abs (_,_,t)) = signed_nclauses b t
  13.303 +    | signed_nclauses _ _ = 1; (* literal *)
  13.304 + in signed_nclauses true t end
  13.305 +
  13.306 +fun has_too_many_clauses ctxt t =
  13.307 +  let val max_cl = Config.get ctxt max_clauses in
  13.308 +    estimated_num_clauses (max_cl + 1) t > max_cl
  13.309 +  end
  13.310 +
  13.311 +(*Replaces universally quantified variables by FREE variables -- because
  13.312 +  assumptions may not contain scheme variables.  Later, generalize using Variable.export. *)
  13.313 +local  
  13.314 +  val spec_var = Thm.dest_arg (Thm.dest_arg (#2 (Thm.dest_implies (Thm.cprop_of spec))));
  13.315 +  val spec_varT = #T (Thm.rep_cterm spec_var);
  13.316 +  fun name_of (Const (@{const_name All}, _) $ Abs(x,_,_)) = x | name_of _ = Name.uu;
  13.317 +in  
  13.318 +  fun freeze_spec th ctxt =
  13.319 +    let
  13.320 +      val cert = Thm.cterm_of (ProofContext.theory_of ctxt);
  13.321 +      val ([x], ctxt') = Variable.variant_fixes [name_of (HOLogic.dest_Trueprop (concl_of th))] ctxt;
  13.322 +      val spec' = Thm.instantiate ([], [(spec_var, cert (Free (x, spec_varT)))]) spec;
  13.323 +    in (th RS spec', ctxt') end
  13.324 +end;
  13.325 +
  13.326 +(*Used with METAHYPS below. There is one assumption, which gets bound to prem
  13.327 +  and then normalized via function nf. The normal form is given to resolve_tac,
  13.328 +  instantiate a Boolean variable created by resolution with disj_forward. Since
  13.329 +  (nf prem) returns a LIST of theorems, we can backtrack to get all combinations.*)
  13.330 +fun resop nf [prem] = resolve_tac (nf prem) 1;
  13.331 +
  13.332 +(* Any need to extend this list with "HOL.type_class", "HOL.eq_class",
  13.333 +   and "Pure.term"? *)
  13.334 +val has_meta_conn = exists_Const (member (op =) ["==", "==>", "=simp=>", "all", "prop"] o #1);
  13.335 +
  13.336 +fun apply_skolem_theorem (th, rls) =
  13.337 +  let
  13.338 +    fun tryall [] = raise THM ("apply_skolem_theorem", 0, th::rls)
  13.339 +      | tryall (rl :: rls) =
  13.340 +        first_order_resolve th rl handle THM _ => tryall rls
  13.341 +  in tryall rls end
  13.342 +
  13.343 +(* Conjunctive normal form, adding clauses from th in front of ths (for foldr).
  13.344 +   Strips universal quantifiers and breaks up conjunctions.
  13.345 +   Eliminates existential quantifiers using Skolemization theorems. *)
  13.346 +fun cnf old_skolem_ths ctxt (th, ths) =
  13.347 +  let val ctxtr = Unsynchronized.ref ctxt   (* FIXME ??? *)
  13.348 +      fun cnf_aux (th,ths) =
  13.349 +        if not (can HOLogic.dest_Trueprop (prop_of th)) then ths (*meta-level: ignore*)
  13.350 +        else if not (has_conns [@{const_name All}, @{const_name Ex}, @{const_name HOL.conj}] (prop_of th))
  13.351 +        then nodups ctxt th :: ths (*no work to do, terminate*)
  13.352 +        else case head_of (HOLogic.dest_Trueprop (concl_of th)) of
  13.353 +            Const (@{const_name HOL.conj}, _) => (*conjunction*)
  13.354 +                cnf_aux (th RS conjunct1, cnf_aux (th RS conjunct2, ths))
  13.355 +          | Const (@{const_name All}, _) => (*universal quantifier*)
  13.356 +                let val (th',ctxt') = freeze_spec th (!ctxtr)
  13.357 +                in  ctxtr := ctxt'; cnf_aux (th', ths) end
  13.358 +          | Const (@{const_name Ex}, _) =>
  13.359 +              (*existential quantifier: Insert Skolem functions*)
  13.360 +              cnf_aux (apply_skolem_theorem (th, old_skolem_ths), ths)
  13.361 +          | Const (@{const_name HOL.disj}, _) =>
  13.362 +              (*Disjunction of P, Q: Create new goal of proving ?P | ?Q and solve it using
  13.363 +                all combinations of converting P, Q to CNF.*)
  13.364 +              let val tac =
  13.365 +                  Misc_Legacy.METAHYPS (resop cnf_nil) 1 THEN
  13.366 +                   (fn st' => st' |> Misc_Legacy.METAHYPS (resop cnf_nil) 1)
  13.367 +              in  Seq.list_of (tac (th RS disj_forward)) @ ths  end
  13.368 +          | _ => nodups ctxt th :: ths  (*no work to do*)
  13.369 +      and cnf_nil th = cnf_aux (th,[])
  13.370 +      val cls =
  13.371 +            if has_too_many_clauses ctxt (concl_of th)
  13.372 +            then (trace_msg (fn () => "cnf is ignoring: " ^ Display.string_of_thm ctxt th); ths)
  13.373 +            else cnf_aux (th,ths)
  13.374 +  in  (cls, !ctxtr)  end;
  13.375 +
  13.376 +fun make_cnf old_skolem_ths th ctxt = cnf old_skolem_ths ctxt (th, [])
  13.377 +
  13.378 +(*Generalization, removal of redundant equalities, removal of tautologies.*)
  13.379 +fun finish_cnf ths = filter (not o is_taut) (map refl_clause ths);
  13.380 +
  13.381 +
  13.382 +(**** Generation of contrapositives ****)
  13.383 +
  13.384 +fun is_left (Const (@{const_name Trueprop}, _) $
  13.385 +               (Const (@{const_name HOL.disj}, _) $ (Const (@{const_name HOL.disj}, _) $ _ $ _) $ _)) = true
  13.386 +  | is_left _ = false;
  13.387 +
  13.388 +(*Associate disjuctions to right -- make leftmost disjunct a LITERAL*)
  13.389 +fun assoc_right th =
  13.390 +  if is_left (prop_of th) then assoc_right (th RS disj_assoc)
  13.391 +  else th;
  13.392 +
  13.393 +(*Must check for negative literal first!*)
  13.394 +val clause_rules = [disj_assoc, make_neg_rule, make_pos_rule];
  13.395 +
  13.396 +(*For ordinary resolution. *)
  13.397 +val resolution_clause_rules = [disj_assoc, make_neg_rule', make_pos_rule'];
  13.398 +
  13.399 +(*Create a goal or support clause, conclusing False*)
  13.400 +fun make_goal th =   (*Must check for negative literal first!*)
  13.401 +    make_goal (tryres(th, clause_rules))
  13.402 +  handle THM _ => tryres(th, [make_neg_goal, make_pos_goal]);
  13.403 +
  13.404 +(*Sort clauses by number of literals*)
  13.405 +fun fewerlits(th1,th2) = nliterals(prop_of th1) < nliterals(prop_of th2);
  13.406 +
  13.407 +fun sort_clauses ths = sort (make_ord fewerlits) ths;
  13.408 +
  13.409 +fun has_bool @{typ bool} = true
  13.410 +  | has_bool (Type (_, Ts)) = exists has_bool Ts
  13.411 +  | has_bool _ = false
  13.412 +
  13.413 +fun has_fun (Type (@{type_name fun}, _)) = true
  13.414 +  | has_fun (Type (_, Ts)) = exists has_fun Ts
  13.415 +  | has_fun _ = false
  13.416 +
  13.417 +(*Is the string the name of a connective? Really only | and Not can remain,
  13.418 +  since this code expects to be called on a clause form.*)
  13.419 +val is_conn = member (op =)
  13.420 +    [@{const_name Trueprop}, @{const_name HOL.conj}, @{const_name HOL.disj},
  13.421 +     @{const_name HOL.implies}, @{const_name Not},
  13.422 +     @{const_name All}, @{const_name Ex}, @{const_name Ball}, @{const_name Bex}];
  13.423 +
  13.424 +(*True if the term contains a function--not a logical connective--where the type
  13.425 +  of any argument contains bool.*)
  13.426 +val has_bool_arg_const =
  13.427 +    exists_Const
  13.428 +      (fn (c,T) => not(is_conn c) andalso exists has_bool (binder_types T));
  13.429 +
  13.430 +(*A higher-order instance of a first-order constant? Example is the definition of
  13.431 +  one, 1, at a function type in theory Function_Algebras.*)
  13.432 +fun higher_inst_const thy (c,T) =
  13.433 +  case binder_types T of
  13.434 +      [] => false (*not a function type, OK*)
  13.435 +    | Ts => length (binder_types (Sign.the_const_type thy c)) <> length Ts;
  13.436 +
  13.437 +(*Returns false if any Vars in the theorem mention type bool.
  13.438 +  Also rejects functions whose arguments are Booleans or other functions.*)
  13.439 +fun is_fol_term thy t =
  13.440 +    Term.is_first_order ["all", @{const_name All}, @{const_name Ex}] t andalso
  13.441 +    not (exists_subterm (fn Var (_, T) => has_bool T orelse has_fun T
  13.442 +                           | _ => false) t orelse
  13.443 +         has_bool_arg_const t orelse
  13.444 +         exists_Const (higher_inst_const thy) t orelse
  13.445 +         has_meta_conn t);
  13.446 +
  13.447 +fun rigid t = not (is_Var (head_of t));
  13.448 +
  13.449 +fun ok4horn (Const (@{const_name Trueprop},_) $ (Const (@{const_name HOL.disj}, _) $ t $ _)) = rigid t
  13.450 +  | ok4horn (Const (@{const_name Trueprop},_) $ t) = rigid t
  13.451 +  | ok4horn _ = false;
  13.452 +
  13.453 +(*Create a meta-level Horn clause*)
  13.454 +fun make_horn crules th =
  13.455 +  if ok4horn (concl_of th)
  13.456 +  then make_horn crules (tryres(th,crules)) handle THM _ => th
  13.457 +  else th;
  13.458 +
  13.459 +(*Generate Horn clauses for all contrapositives of a clause. The input, th,
  13.460 +  is a HOL disjunction.*)
  13.461 +fun add_contras crules th hcs =
  13.462 +  let fun rots (0,_) = hcs
  13.463 +        | rots (k,th) = zero_var_indexes (make_horn crules th) ::
  13.464 +                        rots(k-1, assoc_right (th RS disj_comm))
  13.465 +  in case nliterals(prop_of th) of
  13.466 +        1 => th::hcs
  13.467 +      | n => rots(n, assoc_right th)
  13.468 +  end;
  13.469 +
  13.470 +(*Use "theorem naming" to label the clauses*)
  13.471 +fun name_thms label =
  13.472 +    let fun name1 th (k, ths) =
  13.473 +          (k-1, Thm.put_name_hint (label ^ string_of_int k) th :: ths)
  13.474 +    in  fn ths => #2 (fold_rev name1 ths (length ths, []))  end;
  13.475 +
  13.476 +(*Is the given disjunction an all-negative support clause?*)
  13.477 +fun is_negative th = forall (not o #1) (literals (prop_of th));
  13.478 +
  13.479 +val neg_clauses = filter is_negative;
  13.480 +
  13.481 +
  13.482 +(***** MESON PROOF PROCEDURE *****)
  13.483 +
  13.484 +fun rhyps (Const("==>",_) $ (Const(@{const_name Trueprop},_) $ A) $ phi,
  13.485 +           As) = rhyps(phi, A::As)
  13.486 +  | rhyps (_, As) = As;
  13.487 +
  13.488 +(** Detecting repeated assumptions in a subgoal **)
  13.489 +
  13.490 +(*The stringtree detects repeated assumptions.*)
  13.491 +fun ins_term t net = Net.insert_term (op aconv) (t, t) net;
  13.492 +
  13.493 +(*detects repetitions in a list of terms*)
  13.494 +fun has_reps [] = false
  13.495 +  | has_reps [_] = false
  13.496 +  | has_reps [t,u] = (t aconv u)
  13.497 +  | has_reps ts = (fold ins_term ts Net.empty; false) handle Net.INSERT => true;
  13.498 +
  13.499 +(*Like TRYALL eq_assume_tac, but avoids expensive THEN calls*)
  13.500 +fun TRYING_eq_assume_tac 0 st = Seq.single st
  13.501 +  | TRYING_eq_assume_tac i st =
  13.502 +       TRYING_eq_assume_tac (i-1) (Thm.eq_assumption i st)
  13.503 +       handle THM _ => TRYING_eq_assume_tac (i-1) st;
  13.504 +
  13.505 +fun TRYALL_eq_assume_tac st = TRYING_eq_assume_tac (nprems_of st) st;
  13.506 +
  13.507 +(*Loop checking: FAIL if trying to prove the same thing twice
  13.508 +  -- if *ANY* subgoal has repeated literals*)
  13.509 +fun check_tac st =
  13.510 +  if exists (fn prem => has_reps (rhyps(prem,[]))) (prems_of st)
  13.511 +  then  Seq.empty  else  Seq.single st;
  13.512 +
  13.513 +
  13.514 +(* net_resolve_tac actually made it slower... *)
  13.515 +fun prolog_step_tac horns i =
  13.516 +    (assume_tac i APPEND resolve_tac horns i) THEN check_tac THEN
  13.517 +    TRYALL_eq_assume_tac;
  13.518 +
  13.519 +(*Sums the sizes of the subgoals, ignoring hypotheses (ancestors)*)
  13.520 +fun addconcl prem sz = size_of_term (Logic.strip_assums_concl prem) + sz;
  13.521 +
  13.522 +fun size_of_subgoals st = fold_rev addconcl (prems_of st) 0;
  13.523 +
  13.524 +
  13.525 +(*Negation Normal Form*)
  13.526 +val nnf_rls = [imp_to_disjD, iff_to_disjD, not_conjD, not_disjD,
  13.527 +               not_impD, not_iffD, not_allD, not_exD, not_notD];
  13.528 +
  13.529 +fun ok4nnf (Const (@{const_name Trueprop},_) $ (Const (@{const_name Not}, _) $ t)) = rigid t
  13.530 +  | ok4nnf (Const (@{const_name Trueprop},_) $ t) = rigid t
  13.531 +  | ok4nnf _ = false;
  13.532 +
  13.533 +fun make_nnf1 ctxt th =
  13.534 +  if ok4nnf (concl_of th)
  13.535 +  then make_nnf1 ctxt (tryres(th, nnf_rls))
  13.536 +    handle THM ("tryres", _, _) =>
  13.537 +        forward_res ctxt (make_nnf1 ctxt)
  13.538 +           (tryres(th, [conj_forward,disj_forward,all_forward,ex_forward]))
  13.539 +    handle THM ("tryres", _, _) => th
  13.540 +  else th
  13.541 +
  13.542 +(*The simplification removes defined quantifiers and occurrences of True and False.
  13.543 +  nnf_ss also includes the one-point simprocs,
  13.544 +  which are needed to avoid the various one-point theorems from generating junk clauses.*)
  13.545 +val nnf_simps =
  13.546 +  @{thms simp_implies_def Ex1_def Ball_def Bex_def if_True if_False if_cancel
  13.547 +         if_eq_cancel cases_simp}
  13.548 +val nnf_extra_simps = @{thms split_ifs ex_simps all_simps simp_thms}
  13.549 +
  13.550 +val nnf_ss =
  13.551 +  HOL_basic_ss addsimps nnf_extra_simps
  13.552 +    addsimprocs [defALL_regroup,defEX_regroup, @{simproc neq}, @{simproc let_simp}];
  13.553 +
  13.554 +val presimplify =
  13.555 +  rewrite_rule (map safe_mk_meta_eq nnf_simps) #> simplify nnf_ss
  13.556 +
  13.557 +fun make_nnf ctxt th = case prems_of th of
  13.558 +    [] => th |> presimplify |> make_nnf1 ctxt
  13.559 +  | _ => raise THM ("make_nnf: premises in argument", 0, [th]);
  13.560 +
  13.561 +fun choice_theorems thy =
  13.562 +  try (Global_Theory.get_thm thy) "Hilbert_Choice.choice" |> the_list
  13.563 +
  13.564 +(* Pull existential quantifiers to front. This accomplishes Skolemization for
  13.565 +   clauses that arise from a subgoal. *)
  13.566 +fun skolemize_with_choice_theorems ctxt choice_ths =
  13.567 +  let
  13.568 +    fun aux th =
  13.569 +      if not (has_conns [@{const_name Ex}] (prop_of th)) then
  13.570 +        th
  13.571 +      else
  13.572 +        tryres (th, choice_ths @
  13.573 +                    [conj_exD1, conj_exD2, disj_exD, disj_exD1, disj_exD2])
  13.574 +        |> aux
  13.575 +        handle THM ("tryres", _, _) =>
  13.576 +               tryres (th, [conj_forward, disj_forward, all_forward])
  13.577 +               |> forward_res ctxt aux
  13.578 +               |> aux
  13.579 +               handle THM ("tryres", _, _) =>
  13.580 +                      rename_bvs_RS th ex_forward
  13.581 +                      |> forward_res ctxt aux
  13.582 +  in aux o make_nnf ctxt end
  13.583 +
  13.584 +fun skolemize ctxt =
  13.585 +  let val thy = ProofContext.theory_of ctxt in
  13.586 +    skolemize_with_choice_theorems ctxt (choice_theorems thy)
  13.587 +  end
  13.588 +
  13.589 +(* "RS" can fail if "unify_search_bound" is too small. *)
  13.590 +fun try_skolemize ctxt th =
  13.591 +  try (skolemize ctxt) th
  13.592 +  |> tap (fn NONE => trace_msg (fn () => "Failed to skolemize " ^
  13.593 +                                         Display.string_of_thm ctxt th)
  13.594 +           | _ => ())
  13.595 +
  13.596 +fun add_clauses th cls =
  13.597 +  let val ctxt0 = Variable.global_thm_context th
  13.598 +      val (cnfs, ctxt) = make_cnf [] th ctxt0
  13.599 +  in Variable.export ctxt ctxt0 cnfs @ cls end;
  13.600 +
  13.601 +(*Make clauses from a list of theorems, previously Skolemized and put into nnf.
  13.602 +  The resulting clauses are HOL disjunctions.*)
  13.603 +fun make_clauses_unsorted ths = fold_rev add_clauses ths [];
  13.604 +val make_clauses = sort_clauses o make_clauses_unsorted;
  13.605 +
  13.606 +(*Convert a list of clauses (disjunctions) to Horn clauses (contrapositives)*)
  13.607 +fun make_horns ths =
  13.608 +    name_thms "Horn#"
  13.609 +      (distinct Thm.eq_thm_prop (fold_rev (add_contras clause_rules) ths []));
  13.610 +
  13.611 +(*Could simply use nprems_of, which would count remaining subgoals -- no
  13.612 +  discrimination as to their size!  With BEST_FIRST, fails for problem 41.*)
  13.613 +
  13.614 +fun best_prolog_tac sizef horns =
  13.615 +    BEST_FIRST (has_fewer_prems 1, sizef) (prolog_step_tac horns 1);
  13.616 +
  13.617 +fun depth_prolog_tac horns =
  13.618 +    DEPTH_FIRST (has_fewer_prems 1) (prolog_step_tac horns 1);
  13.619 +
  13.620 +(*Return all negative clauses, as possible goal clauses*)
  13.621 +fun gocls cls = name_thms "Goal#" (map make_goal (neg_clauses cls));
  13.622 +
  13.623 +fun skolemize_prems_tac ctxt prems =
  13.624 +  cut_facts_tac (map_filter (try_skolemize ctxt) prems) THEN' REPEAT o etac exE
  13.625 +
  13.626 +(*Basis of all meson-tactics.  Supplies cltac with clauses: HOL disjunctions.
  13.627 +  Function mkcl converts theorems to clauses.*)
  13.628 +fun MESON preskolem_tac mkcl cltac ctxt i st =
  13.629 +  SELECT_GOAL
  13.630 +    (EVERY [Object_Logic.atomize_prems_tac 1,
  13.631 +            rtac ccontr 1,
  13.632 +            preskolem_tac,
  13.633 +            Subgoal.FOCUS (fn {context = ctxt', prems = negs, ...} =>
  13.634 +                      EVERY1 [skolemize_prems_tac ctxt negs,
  13.635 +                              Subgoal.FOCUS (cltac o mkcl o #prems) ctxt']) ctxt 1]) i st
  13.636 +  handle THM _ => no_tac st;    (*probably from make_meta_clause, not first-order*)
  13.637 +
  13.638 +
  13.639 +(** Best-first search versions **)
  13.640 +
  13.641 +(*ths is a list of additional clauses (HOL disjunctions) to use.*)
  13.642 +fun best_meson_tac sizef =
  13.643 +  MESON all_tac make_clauses
  13.644 +    (fn cls =>
  13.645 +         THEN_BEST_FIRST (resolve_tac (gocls cls) 1)
  13.646 +                         (has_fewer_prems 1, sizef)
  13.647 +                         (prolog_step_tac (make_horns cls) 1));
  13.648 +
  13.649 +(*First, breaks the goal into independent units*)
  13.650 +fun safe_best_meson_tac ctxt =
  13.651 +     SELECT_GOAL (TRY (safe_tac (claset_of ctxt)) THEN
  13.652 +                  TRYALL (best_meson_tac size_of_subgoals ctxt));
  13.653 +
  13.654 +(** Depth-first search version **)
  13.655 +
  13.656 +val depth_meson_tac =
  13.657 +  MESON all_tac make_clauses
  13.658 +    (fn cls => EVERY [resolve_tac (gocls cls) 1, depth_prolog_tac (make_horns cls)]);
  13.659 +
  13.660 +
  13.661 +(** Iterative deepening version **)
  13.662 +
  13.663 +(*This version does only one inference per call;
  13.664 +  having only one eq_assume_tac speeds it up!*)
  13.665 +fun prolog_step_tac' horns =
  13.666 +    let val (horn0s, _) = (*0 subgoals vs 1 or more*)
  13.667 +            take_prefix Thm.no_prems horns
  13.668 +        val nrtac = net_resolve_tac horns
  13.669 +    in  fn i => eq_assume_tac i ORELSE
  13.670 +                match_tac horn0s i ORELSE  (*no backtracking if unit MATCHES*)
  13.671 +                ((assume_tac i APPEND nrtac i) THEN check_tac)
  13.672 +    end;
  13.673 +
  13.674 +fun iter_deepen_prolog_tac horns =
  13.675 +    ITER_DEEPEN iter_deepen_limit (has_fewer_prems 1) (prolog_step_tac' horns);
  13.676 +
  13.677 +fun iter_deepen_meson_tac ctxt ths = ctxt |> MESON all_tac make_clauses
  13.678 +  (fn cls =>
  13.679 +    (case (gocls (cls @ ths)) of
  13.680 +      [] => no_tac  (*no goal clauses*)
  13.681 +    | goes =>
  13.682 +        let
  13.683 +          val horns = make_horns (cls @ ths)
  13.684 +          val _ = trace_msg (fn () =>
  13.685 +            cat_lines ("meson method called:" ::
  13.686 +              map (Display.string_of_thm ctxt) (cls @ ths) @
  13.687 +              ["clauses:"] @ map (Display.string_of_thm ctxt) horns))
  13.688 +        in
  13.689 +          THEN_ITER_DEEPEN iter_deepen_limit
  13.690 +            (resolve_tac goes 1) (has_fewer_prems 1) (prolog_step_tac' horns)
  13.691 +        end));
  13.692 +
  13.693 +fun meson_tac ctxt ths =
  13.694 +  SELECT_GOAL (TRY (safe_tac (claset_of ctxt)) THEN TRYALL (iter_deepen_meson_tac ctxt ths));
  13.695 +
  13.696 +
  13.697 +(**** Code to support ordinary resolution, rather than Model Elimination ****)
  13.698 +
  13.699 +(*Convert a list of clauses (disjunctions) to meta-level clauses (==>),
  13.700 +  with no contrapositives, for ordinary resolution.*)
  13.701 +
  13.702 +(*Rules to convert the head literal into a negated assumption. If the head
  13.703 +  literal is already negated, then using notEfalse instead of notEfalse'
  13.704 +  prevents a double negation.*)
  13.705 +val notEfalse = read_instantiate @{context} [(("R", 0), "False")] notE;
  13.706 +val notEfalse' = rotate_prems 1 notEfalse;
  13.707 +
  13.708 +fun negated_asm_of_head th =
  13.709 +    th RS notEfalse handle THM _ => th RS notEfalse';
  13.710 +
  13.711 +(*Converting one theorem from a disjunction to a meta-level clause*)
  13.712 +fun make_meta_clause th =
  13.713 +  let val (fth,thaw) = Drule.legacy_freeze_thaw_robust th
  13.714 +  in  
  13.715 +      (zero_var_indexes o Thm.varifyT_global o thaw 0 o 
  13.716 +       negated_asm_of_head o make_horn resolution_clause_rules) fth
  13.717 +  end;
  13.718 +
  13.719 +fun make_meta_clauses ths =
  13.720 +    name_thms "MClause#"
  13.721 +      (distinct Thm.eq_thm_prop (map make_meta_clause ths));
  13.722 +
  13.723 +end;
    14.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    14.2 +++ b/src/HOL/Tools/Meson/meson_clausify.ML	Wed Oct 06 17:44:21 2010 +0200
    14.3 @@ -0,0 +1,367 @@
    14.4 +(*  Title:      HOL/Tools/Meson/meson_clausify.ML
    14.5 +    Author:     Jia Meng, Cambridge University Computer Laboratory and NICTA
    14.6 +    Author:     Jasmin Blanchette, TU Muenchen
    14.7 +
    14.8 +Transformation of HOL theorems into CNF forms.
    14.9 +*)
   14.10 +
   14.11 +signature MESON_CLAUSIFY =
   14.12 +sig
   14.13 +  val new_skolem_var_prefix : string
   14.14 +  val extensionalize_theorem : thm -> thm
   14.15 +  val introduce_combinators_in_cterm : cterm -> thm
   14.16 +  val introduce_combinators_in_theorem : thm -> thm
   14.17 +  val to_definitional_cnf_with_quantifiers : theory -> thm -> thm
   14.18 +  val cluster_of_zapped_var_name : string -> (int * (int * int)) * bool
   14.19 +  val cnf_axiom :
   14.20 +    Proof.context -> bool -> int -> thm -> (thm * term) option * thm list
   14.21 +end;
   14.22 +
   14.23 +structure Meson_Clausify : MESON_CLAUSIFY =
   14.24 +struct
   14.25 +
   14.26 +open Meson
   14.27 +
   14.28 +(* the extra "?" helps prevent clashes *)
   14.29 +val new_skolem_var_prefix = "?SK"
   14.30 +val new_nonskolem_var_prefix = "?V"
   14.31 +
   14.32 +(**** Transformation of Elimination Rules into First-Order Formulas****)
   14.33 +
   14.34 +val cfalse = cterm_of @{theory HOL} HOLogic.false_const;
   14.35 +val ctp_false = cterm_of @{theory HOL} (HOLogic.mk_Trueprop HOLogic.false_const);
   14.36 +
   14.37 +(* Converts an elim-rule into an equivalent theorem that does not have the
   14.38 +   predicate variable. Leaves other theorems unchanged. We simply instantiate
   14.39 +   the conclusion variable to False. (Cf. "transform_elim_term" in
   14.40 +   "Sledgehammer_Util".) *)
   14.41 +fun transform_elim_theorem th =
   14.42 +  case concl_of th of    (*conclusion variable*)
   14.43 +       @{const Trueprop} $ (v as Var (_, @{typ bool})) =>
   14.44 +           Thm.instantiate ([], [(cterm_of @{theory HOL} v, cfalse)]) th
   14.45 +    | v as Var(_, @{typ prop}) =>
   14.46 +           Thm.instantiate ([], [(cterm_of @{theory HOL} v, ctp_false)]) th
   14.47 +    | _ => th
   14.48 +
   14.49 +
   14.50 +(**** SKOLEMIZATION BY INFERENCE (lcp) ****)
   14.51 +
   14.52 +fun mk_old_skolem_term_wrapper t =
   14.53 +  let val T = fastype_of t in
   14.54 +    Const (@{const_name Meson.skolem}, T --> T) $ t
   14.55 +  end
   14.56 +
   14.57 +fun beta_eta_in_abs_body (Abs (s, T, t')) = Abs (s, T, beta_eta_in_abs_body t')
   14.58 +  | beta_eta_in_abs_body t = Envir.beta_eta_contract t
   14.59 +
   14.60 +(*Traverse a theorem, accumulating Skolem function definitions.*)
   14.61 +fun old_skolem_defs th =
   14.62 +  let
   14.63 +    fun dec_sko (Const (@{const_name Ex}, _) $ (body as Abs (_, T, p))) rhss =
   14.64 +        (*Existential: declare a Skolem function, then insert into body and continue*)
   14.65 +        let
   14.66 +          val args = OldTerm.term_frees body
   14.67 +          (* Forms a lambda-abstraction over the formal parameters *)
   14.68 +          val rhs =
   14.69 +            list_abs_free (map dest_Free args,
   14.70 +                           HOLogic.choice_const T $ beta_eta_in_abs_body body)
   14.71 +            |> mk_old_skolem_term_wrapper
   14.72 +          val comb = list_comb (rhs, args)
   14.73 +        in dec_sko (subst_bound (comb, p)) (rhs :: rhss) end
   14.74 +      | dec_sko (Const (@{const_name All},_) $ Abs (a, T, p)) rhss =
   14.75 +        (*Universal quant: insert a free variable into body and continue*)
   14.76 +        let val fname = Name.variant (OldTerm.add_term_names (p,[])) a
   14.77 +        in dec_sko (subst_bound (Free(fname,T), p)) rhss end
   14.78 +      | dec_sko (@{const conj} $ p $ q) rhss = rhss |> dec_sko p |> dec_sko q
   14.79 +      | dec_sko (@{const disj} $ p $ q) rhss = rhss |> dec_sko p |> dec_sko q
   14.80 +      | dec_sko (@{const Trueprop} $ p) rhss = dec_sko p rhss
   14.81 +      | dec_sko _ rhss = rhss
   14.82 +  in  dec_sko (prop_of th) []  end;
   14.83 +
   14.84 +
   14.85 +(**** REPLACING ABSTRACTIONS BY COMBINATORS ****)
   14.86 +
   14.87 +val fun_cong_all = @{thm fun_eq_iff [THEN iffD1]}
   14.88 +
   14.89 +(* Removes the lambdas from an equation of the form "t = (%x. u)".
   14.90 +   (Cf. "extensionalize_term" in "Sledgehammer_Translate".) *)
   14.91 +fun extensionalize_theorem th =
   14.92 +  case prop_of th of
   14.93 +    _ $ (Const (@{const_name HOL.eq}, Type (_, [Type (@{type_name fun}, _), _]))
   14.94 +         $ _ $ Abs _) => extensionalize_theorem (th RS fun_cong_all)
   14.95 +  | _ => th
   14.96 +
   14.97 +fun is_quasi_lambda_free (Const (@{const_name Meson.skolem}, _) $ _) = true
   14.98 +  | is_quasi_lambda_free (t1 $ t2) =
   14.99 +    is_quasi_lambda_free t1 andalso is_quasi_lambda_free t2
  14.100 +  | is_quasi_lambda_free (Abs _) = false
  14.101 +  | is_quasi_lambda_free _ = true
  14.102 +
  14.103 +val [f_B,g_B] = map (cterm_of @{theory}) (OldTerm.term_vars (prop_of @{thm abs_B}));
  14.104 +val [g_C,f_C] = map (cterm_of @{theory}) (OldTerm.term_vars (prop_of @{thm abs_C}));
  14.105 +val [f_S,g_S] = map (cterm_of @{theory}) (OldTerm.term_vars (prop_of @{thm abs_S}));
  14.106 +
  14.107 +(* FIXME: Requires more use of cterm constructors. *)
  14.108 +fun abstract ct =
  14.109 +  let
  14.110 +      val thy = theory_of_cterm ct
  14.111 +      val Abs(x,_,body) = term_of ct
  14.112 +      val Type(@{type_name fun}, [xT,bodyT]) = typ_of (ctyp_of_term ct)
  14.113 +      val cxT = ctyp_of thy xT
  14.114 +      val cbodyT = ctyp_of thy bodyT
  14.115 +      fun makeK () =
  14.116 +        instantiate' [SOME cxT, SOME cbodyT] [SOME (cterm_of thy body)]
  14.117 +                     @{thm abs_K}
  14.118 +  in
  14.119 +      case body of
  14.120 +          Const _ => makeK()
  14.121 +        | Free _ => makeK()
  14.122 +        | Var _ => makeK()  (*though Var isn't expected*)
  14.123 +        | Bound 0 => instantiate' [SOME cxT] [] @{thm abs_I} (*identity: I*)
  14.124 +        | rator$rand =>
  14.125 +            if loose_bvar1 (rator,0) then (*C or S*)
  14.126 +               if loose_bvar1 (rand,0) then (*S*)
  14.127 +                 let val crator = cterm_of thy (Abs(x,xT,rator))
  14.128 +                     val crand = cterm_of thy (Abs(x,xT,rand))
  14.129 +                     val abs_S' = cterm_instantiate [(f_S,crator),(g_S,crand)] @{thm abs_S}
  14.130 +                     val (_,rhs) = Thm.dest_equals (cprop_of abs_S')
  14.131 +                 in
  14.132 +                   Thm.transitive abs_S' (Conv.binop_conv abstract rhs)
  14.133 +                 end
  14.134 +               else (*C*)
  14.135 +                 let val crator = cterm_of thy (Abs(x,xT,rator))
  14.136 +                     val abs_C' = cterm_instantiate [(f_C,crator),(g_C,cterm_of thy rand)] @{thm abs_C}
  14.137 +                     val (_,rhs) = Thm.dest_equals (cprop_of abs_C')
  14.138 +                 in
  14.139 +                   Thm.transitive abs_C' (Conv.fun_conv (Conv.arg_conv abstract) rhs)
  14.140 +                 end
  14.141 +            else if loose_bvar1 (rand,0) then (*B or eta*)
  14.142 +               if rand = Bound 0 then Thm.eta_conversion ct
  14.143 +               else (*B*)
  14.144 +                 let val crand = cterm_of thy (Abs(x,xT,rand))
  14.145 +                     val crator = cterm_of thy rator
  14.146 +                     val abs_B' = cterm_instantiate [(f_B,crator),(g_B,crand)] @{thm abs_B}
  14.147 +                     val (_,rhs) = Thm.dest_equals (cprop_of abs_B')
  14.148 +                 in Thm.transitive abs_B' (Conv.arg_conv abstract rhs) end
  14.149 +            else makeK()
  14.150 +        | _ => raise Fail "abstract: Bad term"
  14.151 +  end;
  14.152 +
  14.153 +(* Traverse a theorem, remplacing lambda-abstractions with combinators. *)
  14.154 +fun introduce_combinators_in_cterm ct =
  14.155 +  if is_quasi_lambda_free (term_of ct) then
  14.156 +    Thm.reflexive ct
  14.157 +  else case term_of ct of
  14.158 +    Abs _ =>
  14.159 +    let
  14.160 +      val (cv, cta) = Thm.dest_abs NONE ct
  14.161 +      val (v, _) = dest_Free (term_of cv)
  14.162 +      val u_th = introduce_combinators_in_cterm cta
  14.163 +      val cu = Thm.rhs_of u_th
  14.164 +      val comb_eq = abstract (Thm.cabs cv cu)
  14.165 +    in Thm.transitive (Thm.abstract_rule v cv u_th) comb_eq end
  14.166 +  | _ $ _ =>
  14.167 +    let val (ct1, ct2) = Thm.dest_comb ct in
  14.168 +        Thm.combination (introduce_combinators_in_cterm ct1)
  14.169 +                        (introduce_combinators_in_cterm ct2)
  14.170 +    end
  14.171 +
  14.172 +fun introduce_combinators_in_theorem th =
  14.173 +  if is_quasi_lambda_free (prop_of th) then
  14.174 +    th
  14.175 +  else
  14.176 +    let
  14.177 +      val th = Drule.eta_contraction_rule th
  14.178 +      val eqth = introduce_combinators_in_cterm (cprop_of th)
  14.179 +    in Thm.equal_elim eqth th end
  14.180 +    handle THM (msg, _, _) =>
  14.181 +           (warning ("Error in the combinator translation of " ^
  14.182 +                     Display.string_of_thm_without_context th ^
  14.183 +                     "\nException message: " ^ msg ^ ".");
  14.184 +            (* A type variable of sort "{}" will make abstraction fail. *)
  14.185 +            TrueI)
  14.186 +
  14.187 +(*cterms are used throughout for efficiency*)
  14.188 +val cTrueprop = cterm_of @{theory HOL} HOLogic.Trueprop;
  14.189 +
  14.190 +(*Given an abstraction over n variables, replace the bound variables by free
  14.191 +  ones. Return the body, along with the list of free variables.*)
  14.192 +fun c_variant_abs_multi (ct0, vars) =
  14.193 +      let val (cv,ct) = Thm.dest_abs NONE ct0
  14.194 +      in  c_variant_abs_multi (ct, cv::vars)  end
  14.195 +      handle CTERM _ => (ct0, rev vars);
  14.196 +
  14.197 +val skolem_def_raw = @{thms skolem_def_raw}
  14.198 +
  14.199 +(* Given the definition of a Skolem function, return a theorem to replace
  14.200 +   an existential formula by a use of that function.
  14.201 +   Example: "EX x. x : A & x ~: B ==> sko A B : A & sko A B ~: B"  [.] *)
  14.202 +fun old_skolem_theorem_from_def thy rhs0 =
  14.203 +  let
  14.204 +    val rhs = rhs0 |> Type.legacy_freeze_thaw |> #1 |> cterm_of thy
  14.205 +    val rhs' = rhs |> Thm.dest_comb |> snd
  14.206 +    val (ch, frees) = c_variant_abs_multi (rhs', [])
  14.207 +    val (hilbert, cabs) = ch |> Thm.dest_comb |>> term_of
  14.208 +    val T =
  14.209 +      case hilbert of
  14.210 +        Const (_, Type (@{type_name fun}, [_, T])) => T
  14.211 +      | _ => raise TERM ("old_skolem_theorem_from_def: expected \"Eps\"",
  14.212 +                         [hilbert])
  14.213 +    val cex = cterm_of thy (HOLogic.exists_const T)
  14.214 +    val ex_tm = Thm.capply cTrueprop (Thm.capply cex cabs)
  14.215 +    val conc =
  14.216 +      Drule.list_comb (rhs, frees)
  14.217 +      |> Drule.beta_conv cabs |> Thm.capply cTrueprop
  14.218 +    fun tacf [prem] =
  14.219 +      rewrite_goals_tac skolem_def_raw
  14.220 +      THEN rtac ((prem |> rewrite_rule skolem_def_raw)
  14.221 +                 RS Global_Theory.get_thm thy "Hilbert_Choice.someI_ex") 1
  14.222 +  in
  14.223 +    Goal.prove_internal [ex_tm] conc tacf
  14.224 +    |> forall_intr_list frees
  14.225 +    |> Thm.forall_elim_vars 0  (*Introduce Vars, but don't discharge defs.*)
  14.226 +    |> Thm.varifyT_global
  14.227 +  end
  14.228 +
  14.229 +fun to_definitional_cnf_with_quantifiers thy th =
  14.230 +  let
  14.231 +    val eqth = cnf.make_cnfx_thm thy (HOLogic.dest_Trueprop (prop_of th))
  14.232 +    val eqth = eqth RS @{thm eq_reflection}
  14.233 +    val eqth = eqth RS @{thm TruepropI}
  14.234 +  in Thm.equal_elim eqth th end
  14.235 +
  14.236 +fun zapped_var_name ((ax_no, cluster_no), skolem) index_no s =
  14.237 +  (if skolem then new_skolem_var_prefix else new_nonskolem_var_prefix) ^
  14.238 +  "_" ^ string_of_int ax_no ^ "_" ^ string_of_int cluster_no ^ "_" ^
  14.239 +  string_of_int index_no ^ "_" ^ s
  14.240 +
  14.241 +fun cluster_of_zapped_var_name s =
  14.242 +  let val get_int = the o Int.fromString o nth (space_explode "_" s) in
  14.243 +    ((get_int 1, (get_int 2, get_int 3)),
  14.244 +     String.isPrefix new_skolem_var_prefix s)
  14.245 +  end
  14.246 +
  14.247 +fun zap (cluster as (cluster_no, cluster_skolem)) index_no pos ct =
  14.248 +  ct
  14.249 +  |> (case term_of ct of
  14.250 +        Const (s, _) $ Abs (s', _, _) =>
  14.251 +        if s = @{const_name all} orelse s = @{const_name All} orelse
  14.252 +           s = @{const_name Ex} then
  14.253 +          let
  14.254 +            val skolem = (pos = (s = @{const_name Ex}))
  14.255 +            val (cluster, index_no) =
  14.256 +              if skolem = cluster_skolem then (cluster, index_no)
  14.257 +              else ((cluster_no ||> cluster_skolem ? Integer.add 1, skolem), 0)
  14.258 +          in
  14.259 +            Thm.dest_comb #> snd
  14.260 +            #> Thm.dest_abs (SOME (zapped_var_name cluster index_no s'))
  14.261 +            #> snd #> zap cluster (index_no + 1) pos
  14.262 +          end
  14.263 +        else
  14.264 +          Conv.all_conv
  14.265 +      | Const (s, _) $ _ $ _ =>
  14.266 +        if s = @{const_name "==>"} orelse s = @{const_name implies} then
  14.267 +          Conv.combination_conv (Conv.arg_conv (zap cluster index_no (not pos)))
  14.268 +                                (zap cluster index_no pos)
  14.269 +        else if s = @{const_name conj} orelse s = @{const_name disj} then
  14.270 +          Conv.combination_conv (Conv.arg_conv (zap cluster index_no pos))
  14.271 +                                (zap cluster index_no pos)
  14.272 +        else
  14.273 +          Conv.all_conv
  14.274 +      | Const (s, _) $ _ =>
  14.275 +        if s = @{const_name Trueprop} then
  14.276 +          Conv.arg_conv (zap cluster index_no pos)
  14.277 +        else if s = @{const_name Not} then
  14.278 +          Conv.arg_conv (zap cluster index_no (not pos))
  14.279 +        else
  14.280 +          Conv.all_conv
  14.281 +      | _ => Conv.all_conv)
  14.282 +
  14.283 +fun ss_only ths = MetaSimplifier.clear_ss HOL_basic_ss addsimps ths
  14.284 +
  14.285 +val no_choice =
  14.286 +  @{prop "ALL x. EX y. Q x y ==> EX f. ALL x. Q x (f x)"}
  14.287 +  |> Logic.varify_global
  14.288 +  |> Skip_Proof.make_thm @{theory}
  14.289 +
  14.290 +(* Converts an Isabelle theorem into NNF. *)
  14.291 +fun nnf_axiom choice_ths new_skolemizer ax_no th ctxt =
  14.292 +  let
  14.293 +    val thy = ProofContext.theory_of ctxt
  14.294 +    val th =
  14.295 +      th |> transform_elim_theorem
  14.296 +         |> zero_var_indexes
  14.297 +         |> new_skolemizer ? forall_intr_vars
  14.298 +    val (th, ctxt) = Variable.import true [th] ctxt |>> snd |>> the_single
  14.299 +    val th = th |> Conv.fconv_rule Object_Logic.atomize
  14.300 +                |> extensionalize_theorem
  14.301 +                |> make_nnf ctxt
  14.302 +  in
  14.303 +    if new_skolemizer then
  14.304 +      let
  14.305 +        fun skolemize choice_ths =
  14.306 +          skolemize_with_choice_theorems ctxt choice_ths
  14.307 +          #> simplify (ss_only @{thms all_simps[symmetric]})
  14.308 +        val pull_out =
  14.309 +          simplify (ss_only @{thms all_simps[symmetric] ex_simps[symmetric]})
  14.310 +        val (discharger_th, fully_skolemized_th) =
  14.311 +          if null choice_ths then
  14.312 +            th |> `I |>> pull_out ||> skolemize [no_choice]
  14.313 +          else
  14.314 +            th |> skolemize choice_ths |> `I
  14.315 +        val t =
  14.316 +          fully_skolemized_th |> cprop_of
  14.317 +          |> zap ((ax_no, 0), true) 0 true |> Drule.export_without_context
  14.318 +          |> cprop_of |> Thm.dest_equals |> snd |> term_of
  14.319 +      in
  14.320 +        if exists_subterm (fn Var ((s, _), _) =>
  14.321 +                              String.isPrefix new_skolem_var_prefix s
  14.322 +                            | _ => false) t then
  14.323 +          let
  14.324 +            val (ct, ctxt) =
  14.325 +              Variable.import_terms true [t] ctxt
  14.326 +              |>> the_single |>> cterm_of thy
  14.327 +          in (SOME (discharger_th, ct), Thm.assume ct, ctxt) end
  14.328 +       else
  14.329 +         (NONE, th, ctxt)
  14.330 +      end
  14.331 +    else
  14.332 +      (NONE, th, ctxt)
  14.333 +  end
  14.334 +
  14.335 +(* Convert a theorem to CNF, with additional premises due to skolemization. *)
  14.336 +fun cnf_axiom ctxt0 new_skolemizer ax_no th =
  14.337 +  let
  14.338 +    val thy = ProofContext.theory_of ctxt0
  14.339 +    val choice_ths = choice_theorems thy
  14.340 +    val (opt, nnf_th, ctxt) = nnf_axiom choice_ths new_skolemizer ax_no th ctxt0
  14.341 +    fun clausify th =
  14.342 +      make_cnf (if new_skolemizer orelse null choice_ths then
  14.343 +                  []
  14.344 +                else
  14.345 +                  map (old_skolem_theorem_from_def thy)
  14.346 +                      (old_skolem_defs th)) th ctxt
  14.347 +    val (cnf_ths, ctxt) =
  14.348 +      clausify nnf_th
  14.349 +      |> (fn ([], _) =>
  14.350 +             clausify (to_definitional_cnf_with_quantifiers thy nnf_th)
  14.351 +           | p => p)
  14.352 +    fun intr_imp ct th =
  14.353 +      Thm.instantiate ([], map (pairself (cterm_of thy))
  14.354 +                               [(Var (("i", 0), @{typ nat}),
  14.355 +                                 HOLogic.mk_nat ax_no)])
  14.356 +                      (zero_var_indexes @{thm skolem_COMBK_D})
  14.357 +      RS Thm.implies_intr ct th
  14.358 +  in
  14.359 +    (opt |> Option.map (I #>> singleton (Variable.export ctxt ctxt0)
  14.360 +                        ##> (term_of #> HOLogic.dest_Trueprop
  14.361 +                             #> singleton (Variable.export_terms ctxt ctxt0))),
  14.362 +     cnf_ths |> map (introduce_combinators_in_theorem
  14.363 +                     #> (case opt of SOME (_, ct) => intr_imp ct | NONE => I))
  14.364 +             |> Variable.export ctxt ctxt0
  14.365 +             |> finish_cnf
  14.366 +             |> map Thm.close_derivation)
  14.367 +  end
  14.368 +  handle THM _ => (NONE, [])
  14.369 +
  14.370 +end;
    15.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    15.2 +++ b/src/HOL/Tools/Meson/meson_tactic.ML	Wed Oct 06 17:44:21 2010 +0200
    15.3 @@ -0,0 +1,29 @@
    15.4 +(*  Title:      HOL/Tools/Meson/meson_tactic.ML
    15.5 +    Author:     Jia Meng, Cambridge University Computer Laboratory and NICTA
    15.6 +    Author:     Jasmin Blanchette, TU Muenchen
    15.7 +
    15.8 +The "meson" proof method for HOL.
    15.9 +*)
   15.10 +
   15.11 +signature MESON_TACTIC =
   15.12 +sig
   15.13 +  val meson_general_tac : Proof.context -> thm list -> int -> tactic
   15.14 +  val setup: theory -> theory
   15.15 +end;
   15.16 +
   15.17 +structure Meson_Tactic : MESON_TACTIC =
   15.18 +struct
   15.19 +
   15.20 +open Meson_Clausify
   15.21 +
   15.22 +fun meson_general_tac ctxt ths =
   15.23 +  let val ctxt = Classical.put_claset HOL_cs ctxt in
   15.24 +    Meson.meson_tac ctxt (maps (snd o cnf_axiom ctxt false 0) ths)
   15.25 +  end
   15.26 +
   15.27 +val setup =
   15.28 +  Method.setup @{binding meson} (Attrib.thms >> (fn ths => fn ctxt =>
   15.29 +     SIMPLE_METHOD' (CHANGED_PROP o meson_general_tac ctxt ths)))
   15.30 +     "MESON resolution proof procedure"
   15.31 +
   15.32 +end;
    16.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    16.2 +++ b/src/HOL/Tools/Metis/metis_reconstruct.ML	Wed Oct 06 17:44:21 2010 +0200
    16.3 @@ -0,0 +1,557 @@
    16.4 +(*  Title:      HOL/Tools/Metis/metis_reconstruct.ML
    16.5 +    Author:     Kong W. Susanto, Cambridge University Computer Laboratory
    16.6 +    Author:     Lawrence C. Paulson, Cambridge University Computer Laboratory
    16.7 +    Author:     Jasmin Blanchette, TU Muenchen
    16.8 +    Copyright   Cambridge University 2007
    16.9 +
   16.10 +Proof reconstruction for Metis.
   16.11 +*)
   16.12 +
   16.13 +signature METIS_RECONSTRUCT =
   16.14 +sig
   16.15 +  type mode = Metis_Translate.mode
   16.16 +
   16.17 +  val trace : bool Unsynchronized.ref
   16.18 +  val lookth : (Metis_Thm.thm * 'a) list -> Metis_Thm.thm -> 'a
   16.19 +  val untyped_aconv : term -> term -> bool
   16.20 +  val replay_one_inference :
   16.21 +    Proof.context -> mode -> (string * term) list
   16.22 +    -> Metis_Thm.thm * Metis_Proof.inference -> (Metis_Thm.thm * thm) list
   16.23 +    -> (Metis_Thm.thm * thm) list
   16.24 +end;
   16.25 +
   16.26 +structure Metis_Reconstruct : METIS_RECONSTRUCT =
   16.27 +struct
   16.28 +
   16.29 +open Metis_Translate
   16.30 +
   16.31 +val trace = Unsynchronized.ref false
   16.32 +fun trace_msg msg = if !trace then tracing (msg ()) else ()
   16.33 +
   16.34 +datatype term_or_type = SomeTerm of term | SomeType of typ
   16.35 +
   16.36 +fun terms_of [] = []
   16.37 +  | terms_of (SomeTerm t :: tts) = t :: terms_of tts
   16.38 +  | terms_of (SomeType _ :: tts) = terms_of tts;
   16.39 +
   16.40 +fun types_of [] = []
   16.41 +  | types_of (SomeTerm (Var ((a,idx), _)) :: tts) =
   16.42 +      if String.isPrefix "_" a then
   16.43 +          (*Variable generated by Metis, which might have been a type variable.*)
   16.44 +          TVar (("'" ^ a, idx), HOLogic.typeS) :: types_of tts
   16.45 +      else types_of tts
   16.46 +  | types_of (SomeTerm _ :: tts) = types_of tts
   16.47 +  | types_of (SomeType T :: tts) = T :: types_of tts;
   16.48 +
   16.49 +fun apply_list rator nargs rands =
   16.50 +  let val trands = terms_of rands
   16.51 +  in  if length trands = nargs then SomeTerm (list_comb(rator, trands))
   16.52 +      else raise Fail
   16.53 +        ("apply_list: wrong number of arguments: " ^ Syntax.string_of_term_global Pure.thy rator ^
   16.54 +          " expected " ^ Int.toString nargs ^
   16.55 +          " received " ^ commas (map (Syntax.string_of_term_global Pure.thy) trands))
   16.56 +  end;
   16.57 +
   16.58 +fun infer_types ctxt =
   16.59 +  Syntax.check_terms (ProofContext.set_mode ProofContext.mode_pattern ctxt);
   16.60 +
   16.61 +(*We use 1 rather than 0 because variable references in clauses may otherwise conflict
   16.62 +  with variable constraints in the goal...at least, type inference often fails otherwise.
   16.63 +  SEE ALSO axiom_inf below.*)
   16.64 +fun mk_var (w, T) = Var ((w, 1), T)
   16.65 +
   16.66 +(*include the default sort, if available*)
   16.67 +fun mk_tfree ctxt w =
   16.68 +  let val ww = "'" ^ w
   16.69 +  in  TFree(ww, the_default HOLogic.typeS (Variable.def_sort ctxt (ww, ~1)))  end;
   16.70 +
   16.71 +(*Remove the "apply" operator from an HO term*)
   16.72 +fun strip_happ args (Metis_Term.Fn(".",[t,u])) = strip_happ (u::args) t
   16.73 +  | strip_happ args x = (x, args);
   16.74 +
   16.75 +fun make_tvar s = TVar (("'" ^ s, 0), HOLogic.typeS)
   16.76 +
   16.77 +fun smart_invert_const "fequal" = @{const_name HOL.eq}
   16.78 +  | smart_invert_const s = invert_const s
   16.79 +
   16.80 +fun hol_type_from_metis_term _ (Metis_Term.Var v) =
   16.81 +     (case strip_prefix_and_unascii tvar_prefix v of
   16.82 +          SOME w => make_tvar w
   16.83 +        | NONE   => make_tvar v)
   16.84 +  | hol_type_from_metis_term ctxt (Metis_Term.Fn(x, tys)) =
   16.85 +     (case strip_prefix_and_unascii type_const_prefix x of
   16.86 +          SOME tc => Type (smart_invert_const tc,
   16.87 +                           map (hol_type_from_metis_term ctxt) tys)
   16.88 +        | NONE    =>
   16.89 +      case strip_prefix_and_unascii tfree_prefix x of
   16.90 +          SOME tf => mk_tfree ctxt tf
   16.91 +        | NONE    => raise Fail ("hol_type_from_metis_term: " ^ x));
   16.92 +
   16.93 +(*Maps metis terms to isabelle terms*)
   16.94 +fun hol_term_from_metis_PT ctxt fol_tm =
   16.95 +  let val thy = ProofContext.theory_of ctxt
   16.96 +      val _ = trace_msg (fn () => "hol_term_from_metis_PT: " ^
   16.97 +                                  Metis_Term.toString fol_tm)
   16.98 +      fun tm_to_tt (Metis_Term.Var v) =
   16.99 +             (case strip_prefix_and_unascii tvar_prefix v of
  16.100 +                  SOME w => SomeType (make_tvar w)
  16.101 +                | NONE =>
  16.102 +              case strip_prefix_and_unascii schematic_var_prefix v of
  16.103 +                  SOME w => SomeTerm (mk_var (w, HOLogic.typeT))
  16.104 +                | NONE   => SomeTerm (mk_var (v, HOLogic.typeT)) )
  16.105 +                    (*Var from Metis with a name like _nnn; possibly a type variable*)
  16.106 +        | tm_to_tt (Metis_Term.Fn ("{}", [arg])) = tm_to_tt arg   (*hBOOL*)
  16.107 +        | tm_to_tt (t as Metis_Term.Fn (".",_)) =
  16.108 +            let val (rator,rands) = strip_happ [] t
  16.109 +            in  case rator of
  16.110 +                    Metis_Term.Fn(fname,ts) => applic_to_tt (fname, ts @ rands)
  16.111 +                  | _ => case tm_to_tt rator of
  16.112 +                             SomeTerm t => SomeTerm (list_comb(t, terms_of (map tm_to_tt rands)))
  16.113 +                           | _ => raise Fail "tm_to_tt: HO application"
  16.114 +            end
  16.115 +        | tm_to_tt (Metis_Term.Fn (fname, args)) = applic_to_tt (fname,args)
  16.116 +      and applic_to_tt ("=",ts) =
  16.117 +            SomeTerm (list_comb(Const (@{const_name HOL.eq}, HOLogic.typeT), terms_of (map tm_to_tt ts)))
  16.118 +        | applic_to_tt (a,ts) =
  16.119 +            case strip_prefix_and_unascii const_prefix a of
  16.120 +                SOME b =>
  16.121 +                  let
  16.122 +                    val c = smart_invert_const b
  16.123 +                    val ntypes = num_type_args thy c
  16.124 +                    val nterms = length ts - ntypes
  16.125 +                    val tts = map tm_to_tt ts
  16.126 +                    val tys = types_of (List.take(tts,ntypes))
  16.127 +                    val t =
  16.128 +                      if String.isPrefix new_skolem_const_prefix c then
  16.129 +                        Var (new_skolem_var_from_const c,
  16.130 +                             Type_Infer.paramify_vars (tl tys ---> hd tys))
  16.131 +                      else
  16.132 +                        Const (c, dummyT)
  16.133 +                  in if length tys = ntypes then
  16.134 +                         apply_list t nterms (List.drop(tts,ntypes))
  16.135 +                     else
  16.136 +                       raise Fail ("Constant " ^ c ^ " expects " ^ Int.toString ntypes ^
  16.137 +                                   " but gets " ^ Int.toString (length tys) ^
  16.138 +                                   " type arguments\n" ^
  16.139 +                                   cat_lines (map (Syntax.string_of_typ ctxt) tys) ^
  16.140 +                                   " the terms are \n" ^
  16.141 +                                   cat_lines (map (Syntax.string_of_term ctxt) (terms_of tts)))
  16.142 +                     end
  16.143 +              | NONE => (*Not a constant. Is it a type constructor?*)
  16.144 +            case strip_prefix_and_unascii type_const_prefix a of
  16.145 +                SOME b =>
  16.146 +                SomeType (Type (smart_invert_const b, types_of (map tm_to_tt ts)))
  16.147 +              | NONE => (*Maybe a TFree. Should then check that ts=[].*)
  16.148 +            case strip_prefix_and_unascii tfree_prefix a of
  16.149 +                SOME b => SomeType (mk_tfree ctxt b)
  16.150 +              | NONE => (*a fixed variable? They are Skolem functions.*)
  16.151 +            case strip_prefix_and_unascii fixed_var_prefix a of
  16.152 +                SOME b =>
  16.153 +                  let val opr = Free (b, HOLogic.typeT)
  16.154 +                  in  apply_list opr (length ts) (map tm_to_tt ts)  end
  16.155 +              | NONE => raise Fail ("unexpected metis function: " ^ a)
  16.156 +  in
  16.157 +    case tm_to_tt fol_tm of
  16.158 +      SomeTerm t => t
  16.159 +    | SomeType T => raise TYPE ("fol_tm_to_tt: Term expected", [T], [])
  16.160 +  end
  16.161 +
  16.162 +(*Maps fully-typed metis terms to isabelle terms*)
  16.163 +fun hol_term_from_metis_FT ctxt fol_tm =
  16.164 +  let val _ = trace_msg (fn () => "hol_term_from_metis_FT: " ^
  16.165 +                                  Metis_Term.toString fol_tm)
  16.166 +      fun cvt (Metis_Term.Fn ("ti", [Metis_Term.Var v, _])) =
  16.167 +             (case strip_prefix_and_unascii schematic_var_prefix v of
  16.168 +                  SOME w =>  mk_var(w, dummyT)
  16.169 +                | NONE   => mk_var(v, dummyT))
  16.170 +        | cvt (Metis_Term.Fn ("ti", [Metis_Term.Fn ("=",[]), _])) =
  16.171 +            Const (@{const_name HOL.eq}, HOLogic.typeT)
  16.172 +        | cvt (Metis_Term.Fn ("ti", [Metis_Term.Fn (x,[]), ty])) =
  16.173 +           (case strip_prefix_and_unascii const_prefix x of
  16.174 +                SOME c => Const (smart_invert_const c, dummyT)
  16.175 +              | NONE => (*Not a constant. Is it a fixed variable??*)
  16.176 +            case strip_prefix_and_unascii fixed_var_prefix x of
  16.177 +                SOME v => Free (v, hol_type_from_metis_term ctxt ty)
  16.178 +              | NONE => raise Fail ("hol_term_from_metis_FT bad constant: " ^ x))
  16.179 +        | cvt (Metis_Term.Fn ("ti", [Metis_Term.Fn (".",[tm1,tm2]), _])) =
  16.180 +            cvt tm1 $ cvt tm2
  16.181 +        | cvt (Metis_Term.Fn (".",[tm1,tm2])) = (*untyped application*)
  16.182 +            cvt tm1 $ cvt tm2
  16.183 +        | cvt (Metis_Term.Fn ("{}", [arg])) = cvt arg   (*hBOOL*)
  16.184 +        | cvt (Metis_Term.Fn ("=", [tm1,tm2])) =
  16.185 +            list_comb(Const (@{const_name HOL.eq}, HOLogic.typeT), map cvt [tm1,tm2])
  16.186 +        | cvt (t as Metis_Term.Fn (x, [])) =
  16.187 +           (case strip_prefix_and_unascii const_prefix x of
  16.188 +                SOME c => Const (smart_invert_const c, dummyT)
  16.189 +              | NONE => (*Not a constant. Is it a fixed variable??*)
  16.190 +            case strip_prefix_and_unascii fixed_var_prefix x of
  16.191 +                SOME v => Free (v, dummyT)
  16.192 +              | NONE => (trace_msg (fn () => "hol_term_from_metis_FT bad const: " ^ x);
  16.193 +                  hol_term_from_metis_PT ctxt t))
  16.194 +        | cvt t = (trace_msg (fn () => "hol_term_from_metis_FT bad term: " ^ Metis_Term.toString t);
  16.195 +            hol_term_from_metis_PT ctxt t)
  16.196 +  in fol_tm |> cvt end
  16.197 +
  16.198 +fun hol_term_from_metis FT = hol_term_from_metis_FT
  16.199 +  | hol_term_from_metis _ = hol_term_from_metis_PT
  16.200 +
  16.201 +fun hol_terms_from_fol ctxt mode old_skolems fol_tms =
  16.202 +  let val ts = map (hol_term_from_metis mode ctxt) fol_tms
  16.203 +      val _ = trace_msg (fn () => "  calling type inference:")
  16.204 +      val _ = app (fn t => trace_msg (fn () => Syntax.string_of_term ctxt t)) ts
  16.205 +      val ts' = ts |> map (reveal_old_skolem_terms old_skolems)
  16.206 +                   |> infer_types ctxt
  16.207 +      val _ = app (fn t => trace_msg
  16.208 +                    (fn () => "  final term: " ^ Syntax.string_of_term ctxt t ^
  16.209 +                              "  of type  " ^ Syntax.string_of_typ ctxt (type_of t)))
  16.210 +                  ts'
  16.211 +  in  ts'  end;
  16.212 +
  16.213 +(* ------------------------------------------------------------------------- *)
  16.214 +(* FOL step Inference Rules                                                  *)
  16.215 +(* ------------------------------------------------------------------------- *)
  16.216 +
  16.217 +(*for debugging only*)
  16.218 +(*
  16.219 +fun print_thpair (fth,th) =
  16.220 +  (trace_msg (fn () => "=============================================");
  16.221 +   trace_msg (fn () => "Metis: " ^ Metis_Thm.toString fth);
  16.222 +   trace_msg (fn () => "Isabelle: " ^ Display.string_of_thm_without_context th));
  16.223 +*)
  16.224 +
  16.225 +fun lookth thpairs (fth : Metis_Thm.thm) =
  16.226 +  the (AList.lookup (uncurry Metis_Thm.equal) thpairs fth)
  16.227 +  handle Option.Option =>
  16.228 +         raise Fail ("Failed to find Metis theorem " ^ Metis_Thm.toString fth)
  16.229 +
  16.230 +fun cterm_incr_types thy idx = cterm_of thy o (map_types (Logic.incr_tvar idx));
  16.231 +
  16.232 +(* INFERENCE RULE: AXIOM *)
  16.233 +
  16.234 +fun axiom_inf thpairs th = Thm.incr_indexes 1 (lookth thpairs th);
  16.235 +    (*This causes variables to have an index of 1 by default. SEE ALSO mk_var above.*)
  16.236 +
  16.237 +(* INFERENCE RULE: ASSUME *)
  16.238 +
  16.239 +val EXCLUDED_MIDDLE = @{lemma "P ==> ~ P ==> False" by (rule notE)}
  16.240 +
  16.241 +fun inst_excluded_middle thy i_atm =
  16.242 +  let val th = EXCLUDED_MIDDLE
  16.243 +      val [vx] = Term.add_vars (prop_of th) []
  16.244 +      val substs = [(cterm_of thy (Var vx), cterm_of thy i_atm)]
  16.245 +  in  cterm_instantiate substs th  end;
  16.246 +
  16.247 +fun assume_inf ctxt mode old_skolems atm =
  16.248 +  inst_excluded_middle
  16.249 +      (ProofContext.theory_of ctxt)
  16.250 +      (singleton (hol_terms_from_fol ctxt mode old_skolems) (Metis_Term.Fn atm))
  16.251 +
  16.252 +(* INFERENCE RULE: INSTANTIATE (SUBST). Type instantiations are ignored. Trying
  16.253 +   to reconstruct them admits new possibilities of errors, e.g. concerning
  16.254 +   sorts. Instead we try to arrange that new TVars are distinct and that types
  16.255 +   can be inferred from terms. *)
  16.256 +
  16.257 +fun inst_inf ctxt mode old_skolems thpairs fsubst th =
  16.258 +  let val thy = ProofContext.theory_of ctxt
  16.259 +      val i_th = lookth thpairs th
  16.260 +      val i_th_vars = Term.add_vars (prop_of i_th) []
  16.261 +      fun find_var x = the (List.find (fn ((a,_),_) => a=x) i_th_vars)
  16.262 +      fun subst_translation (x,y) =
  16.263 +        let val v = find_var x
  16.264 +            (* We call "reveal_old_skolem_terms" and "infer_types" below. *)
  16.265 +            val t = hol_term_from_metis mode ctxt y
  16.266 +        in  SOME (cterm_of thy (Var v), t)  end
  16.267 +        handle Option.Option =>
  16.268 +               (trace_msg (fn () => "\"find_var\" failed for " ^ x ^
  16.269 +                                    " in " ^ Display.string_of_thm ctxt i_th);
  16.270 +                NONE)
  16.271 +             | TYPE _ =>
  16.272 +               (trace_msg (fn () => "\"hol_term_from_metis\" failed for " ^ x ^
  16.273 +                                    " in " ^ Display.string_of_thm ctxt i_th);
  16.274 +                NONE)
  16.275 +      fun remove_typeinst (a, t) =
  16.276 +            case strip_prefix_and_unascii schematic_var_prefix a of
  16.277 +                SOME b => SOME (b, t)
  16.278 +              | NONE => case strip_prefix_and_unascii tvar_prefix a of
  16.279 +                SOME _ => NONE          (*type instantiations are forbidden!*)
  16.280 +              | NONE => SOME (a,t)    (*internal Metis var?*)
  16.281 +      val _ = trace_msg (fn () => "  isa th: " ^ Display.string_of_thm ctxt i_th)
  16.282 +      val substs = map_filter remove_typeinst (Metis_Subst.toList fsubst)
  16.283 +      val (vars,rawtms) = ListPair.unzip (map_filter subst_translation substs)
  16.284 +      val tms = rawtms |> map (reveal_old_skolem_terms old_skolems)
  16.285 +                       |> infer_types ctxt
  16.286 +      val ctm_of = cterm_incr_types thy (1 + Thm.maxidx_of i_th)
  16.287 +      val substs' = ListPair.zip (vars, map ctm_of tms)
  16.288 +      val _ = trace_msg (fn () =>
  16.289 +        cat_lines ("subst_translations:" ::
  16.290 +          (substs' |> map (fn (x, y) =>
  16.291 +            Syntax.string_of_term ctxt (term_of x) ^ " |-> " ^
  16.292 +            Syntax.string_of_term ctxt (term_of y)))));
  16.293 +  in cterm_instantiate substs' i_th end
  16.294 +  handle THM (msg, _, _) =>
  16.295 +         error ("Cannot replay Metis proof in Isabelle:\n" ^ msg)
  16.296 +
  16.297 +(* INFERENCE RULE: RESOLVE *)
  16.298 +
  16.299 +(* Like RSN, but we rename apart only the type variables. Vars here typically
  16.300 +   have an index of 1, and the use of RSN would increase this typically to 3.
  16.301 +   Instantiations of those Vars could then fail. See comment on "mk_var". *)
  16.302 +fun resolve_inc_tyvars thy tha i thb =
  16.303 +  let
  16.304 +    val tha = Drule.incr_type_indexes (1 + Thm.maxidx_of thb) tha
  16.305 +    fun aux tha thb =
  16.306 +      case Thm.bicompose false (false, tha, nprems_of tha) i thb
  16.307 +           |> Seq.list_of |> distinct Thm.eq_thm of
  16.308 +        [th] => th
  16.309 +      | _ => raise THM ("resolve_inc_tyvars: unique result expected", i,
  16.310 +                        [tha, thb])
  16.311 +  in
  16.312 +    aux tha thb
  16.313 +    handle TERM z =>
  16.314 +           (* The unifier, which is invoked from "Thm.bicompose", will sometimes
  16.315 +              refuse to unify "?a::?'a" with "?a::?'b" or "?a::nat" and throw a
  16.316 +              "TERM" exception (with "add_ffpair" as first argument). We then
  16.317 +              perform unification of the types of variables by hand and try
  16.318 +              again. We could do this the first time around but this error
  16.319 +              occurs seldom and we don't want to break existing proofs in subtle
  16.320 +              ways or slow them down needlessly. *)
  16.321 +           case [] |> fold (Term.add_vars o prop_of) [tha, thb]
  16.322 +                   |> AList.group (op =)
  16.323 +                   |> maps (fn ((s, _), T :: Ts) =>
  16.324 +                               map (fn T' => (Free (s, T), Free (s, T'))) Ts)
  16.325 +                   |> rpair (Envir.empty ~1)
  16.326 +                   |-> fold (Pattern.unify thy)
  16.327 +                   |> Envir.type_env |> Vartab.dest
  16.328 +                   |> map (fn (x, (S, T)) =>
  16.329 +                              pairself (ctyp_of thy) (TVar (x, S), T)) of
  16.330 +             [] => raise TERM z
  16.331 +           | ps => aux (instantiate (ps, []) tha) (instantiate (ps, []) thb)
  16.332 +  end
  16.333 +
  16.334 +fun mk_not (Const (@{const_name Not}, _) $ b) = b
  16.335 +  | mk_not b = HOLogic.mk_not b
  16.336 +
  16.337 +(* Match untyped terms. *)
  16.338 +fun untyped_aconv (Const (a, _)) (Const(b, _)) = (a = b)
  16.339 +  | untyped_aconv (Free (a, _)) (Free (b, _)) = (a = b)
  16.340 +  | untyped_aconv (Var ((a, _), _)) (Var ((b, _), _)) =
  16.341 +    (a = b) (* The index is ignored, for some reason. *)
  16.342 +  | untyped_aconv (Bound i) (Bound j) = (i = j)
  16.343 +  | untyped_aconv (Abs (_, _, t)) (Abs (_, _, u)) = untyped_aconv t u
  16.344 +  | untyped_aconv (t1 $ t2) (u1 $ u2) =
  16.345 +    untyped_aconv t1 u1 andalso untyped_aconv t2 u2
  16.346 +  | untyped_aconv _ _ = false
  16.347 +
  16.348 +(* Finding the relative location of an untyped term within a list of terms *)
  16.349 +fun literal_index lit =
  16.350 +  let
  16.351 +    val lit = Envir.eta_contract lit
  16.352 +    fun get _ [] = raise Empty
  16.353 +      | get n (x :: xs) =
  16.354 +        if untyped_aconv lit (Envir.eta_contract (HOLogic.dest_Trueprop x)) then
  16.355 +          n
  16.356 +        else
  16.357 +          get (n+1) xs
  16.358 +  in get 1 end
  16.359 +
  16.360 +(* Permute a rule's premises to move the i-th premise to the last position. *)
  16.361 +fun make_last i th =
  16.362 +  let val n = nprems_of th
  16.363 +  in  if 1 <= i andalso i <= n
  16.364 +      then Thm.permute_prems (i-1) 1 th
  16.365 +      else raise THM("select_literal", i, [th])
  16.366 +  end;
  16.367 +
  16.368 +(* Maps a rule that ends "... ==> P ==> False" to "... ==> ~P" while suppressing
  16.369 +   double-negations. *)
  16.370 +val negate_head = rewrite_rule [@{thm atomize_not}, not_not RS eq_reflection]
  16.371 +
  16.372 +(* Maps the clause  [P1,...Pn]==>False to [P1,...,P(i-1),P(i+1),...Pn] ==> ~P *)
  16.373 +val select_literal = negate_head oo make_last
  16.374 +
  16.375 +fun resolve_inf ctxt mode old_skolems thpairs atm th1 th2 =
  16.376 +  let
  16.377 +    val thy = ProofContext.theory_of ctxt
  16.378 +    val i_th1 = lookth thpairs th1 and i_th2 = lookth thpairs th2
  16.379 +    val _ = trace_msg (fn () => "  isa th1 (pos): " ^ Display.string_of_thm ctxt i_th1)
  16.380 +    val _ = trace_msg (fn () => "  isa th2 (neg): " ^ Display.string_of_thm ctxt i_th2)
  16.381 +  in
  16.382 +    (* Trivial cases where one operand is type info *)
  16.383 +    if Thm.eq_thm (TrueI, i_th1) then
  16.384 +      i_th2
  16.385 +    else if Thm.eq_thm (TrueI, i_th2) then
  16.386 +      i_th1
  16.387 +    else
  16.388 +      let
  16.389 +        val i_atm = singleton (hol_terms_from_fol ctxt mode old_skolems)
  16.390 +                              (Metis_Term.Fn atm)
  16.391 +        val _ = trace_msg (fn () => "  atom: " ^ Syntax.string_of_term ctxt i_atm)
  16.392 +        val prems_th1 = prems_of i_th1
  16.393 +        val prems_th2 = prems_of i_th2
  16.394 +        val index_th1 = literal_index (mk_not i_atm) prems_th1
  16.395 +              handle Empty => raise Fail "Failed to find literal in th1"
  16.396 +        val _ = trace_msg (fn () => "  index_th1: " ^ Int.toString index_th1)
  16.397 +        val index_th2 = literal_index i_atm prems_th2
  16.398 +              handle Empty => raise Fail "Failed to find literal in th2"
  16.399 +        val _ = trace_msg (fn () => "  index_th2: " ^ Int.toString index_th2)
  16.400 +    in
  16.401 +      resolve_inc_tyvars thy (select_literal index_th1 i_th1) index_th2 i_th2
  16.402 +    end
  16.403 +  end;
  16.404 +
  16.405 +(* INFERENCE RULE: REFL *)
  16.406 +
  16.407 +val REFL_THM = Thm.incr_indexes 2 @{lemma "t ~= t ==> False" by simp}
  16.408 +
  16.409 +val refl_x = cterm_of @{theory} (Var (hd (Term.add_vars (prop_of REFL_THM) [])));
  16.410 +val refl_idx = 1 + Thm.maxidx_of REFL_THM;
  16.411 +
  16.412 +fun refl_inf ctxt mode old_skolems t =
  16.413 +  let val thy = ProofContext.theory_of ctxt
  16.414 +      val i_t = singleton (hol_terms_from_fol ctxt mode old_skolems) t
  16.415 +      val _ = trace_msg (fn () => "  term: " ^ Syntax.string_of_term ctxt i_t)
  16.416 +      val c_t = cterm_incr_types thy refl_idx i_t
  16.417 +  in  cterm_instantiate [(refl_x, c_t)] REFL_THM  end;
  16.418 +
  16.419 +(* INFERENCE RULE: EQUALITY *)
  16.420 +
  16.421 +val subst_em = @{lemma "s = t ==> P s ==> ~ P t ==> False" by simp}
  16.422 +val ssubst_em = @{lemma "s = t ==> P t ==> ~ P s ==> False" by simp}
  16.423 +
  16.424 +val metis_eq = Metis_Term.Fn ("=", []);
  16.425 +
  16.426 +fun get_ty_arg_size _ (Const (@{const_name HOL.eq}, _)) = 0  (*equality has no type arguments*)
  16.427 +  | get_ty_arg_size thy (Const (c, _)) = (num_type_args thy c handle TYPE _ => 0)
  16.428 +  | get_ty_arg_size _ _ = 0;
  16.429 +
  16.430 +fun equality_inf ctxt mode old_skolems (pos, atm) fp fr =
  16.431 +  let val thy = ProofContext.theory_of ctxt
  16.432 +      val m_tm = Metis_Term.Fn atm
  16.433 +      val [i_atm,i_tm] = hol_terms_from_fol ctxt mode old_skolems [m_tm, fr]
  16.434 +      val _ = trace_msg (fn () => "sign of the literal: " ^ Bool.toString pos)
  16.435 +      fun replace_item_list lx 0 (_::ls) = lx::ls
  16.436 +        | replace_item_list lx i (l::ls) = l :: replace_item_list lx (i-1) ls
  16.437 +      fun path_finder_FO tm [] = (tm, Bound 0)
  16.438 +        | path_finder_FO tm (p::ps) =
  16.439 +            let val (tm1,args) = strip_comb tm
  16.440 +                val adjustment = get_ty_arg_size thy tm1
  16.441 +                val p' = if adjustment > p then p else p-adjustment
  16.442 +                val tm_p = List.nth(args,p')
  16.443 +                  handle Subscript =>
  16.444 +                         error ("Cannot replay Metis proof in Isabelle:\n" ^
  16.445 +                                "equality_inf: " ^ Int.toString p ^ " adj " ^
  16.446 +                                Int.toString adjustment ^ " term " ^
  16.447 +                                Syntax.string_of_term ctxt tm)
  16.448 +                val _ = trace_msg (fn () => "path_finder: " ^ Int.toString p ^
  16.449 +                                      "  " ^ Syntax.string_of_term ctxt tm_p)
  16.450 +                val (r,t) = path_finder_FO tm_p ps
  16.451 +            in
  16.452 +                (r, list_comb (tm1, replace_item_list t p' args))
  16.453 +            end
  16.454 +      fun path_finder_HO tm [] = (tm, Bound 0)
  16.455 +        | path_finder_HO (t$u) (0::ps) = (fn(x,y) => (x, y$u)) (path_finder_HO t ps)
  16.456 +        | path_finder_HO (t$u) (_::ps) = (fn(x,y) => (x, t$y)) (path_finder_HO u ps)
  16.457 +        | path_finder_HO tm ps =
  16.458 +          raise Fail ("Cannot replay Metis proof in Isabelle:\n" ^
  16.459 +                      "equality_inf, path_finder_HO: path = " ^
  16.460 +                      space_implode " " (map Int.toString ps) ^
  16.461 +                      " isa-term: " ^  Syntax.string_of_term ctxt tm)
  16.462 +      fun path_finder_FT tm [] _ = (tm, Bound 0)
  16.463 +        | path_finder_FT tm (0::ps) (Metis_Term.Fn ("ti", [t1, _])) =
  16.464 +            path_finder_FT tm ps t1
  16.465 +        | path_finder_FT (t$u) (0::ps) (Metis_Term.Fn (".", [t1, _])) =
  16.466 +            (fn(x,y) => (x, y$u)) (path_finder_FT t ps t1)
  16.467 +        | path_finder_FT (t$u) (1::ps) (Metis_Term.Fn (".", [_, t2])) =
  16.468 +            (fn(x,y) => (x, t$y)) (path_finder_FT u ps t2)
  16.469 +        | path_finder_FT tm ps t =
  16.470 +          raise Fail ("Cannot replay Metis proof in Isabelle:\n" ^
  16.471 +                      "equality_inf, path_finder_FT: path = " ^
  16.472 +                      space_implode " " (map Int.toString ps) ^
  16.473 +                      " isa-term: " ^  Syntax.string_of_term ctxt tm ^
  16.474 +                      " fol-term: " ^ Metis_Term.toString t)
  16.475 +      fun path_finder FO tm ps _ = path_finder_FO tm ps
  16.476 +        | path_finder HO (tm as Const(@{const_name HOL.eq},_) $ _ $ _) (p::ps) _ =
  16.477 +             (*equality: not curried, as other predicates are*)
  16.478 +             if p=0 then path_finder_HO tm (0::1::ps)  (*select first operand*)
  16.479 +             else path_finder_HO tm (p::ps)        (*1 selects second operand*)
  16.480 +        | path_finder HO tm (_ :: ps) (Metis_Term.Fn ("{}", [_])) =
  16.481 +             path_finder_HO tm ps      (*if not equality, ignore head to skip hBOOL*)
  16.482 +        | path_finder FT (tm as Const(@{const_name HOL.eq}, _) $ _ $ _) (p::ps)
  16.483 +                            (Metis_Term.Fn ("=", [t1,t2])) =
  16.484 +             (*equality: not curried, as other predicates are*)
  16.485 +             if p=0 then path_finder_FT tm (0::1::ps)
  16.486 +                          (Metis_Term.Fn (".", [Metis_Term.Fn (".", [metis_eq,t1]), t2]))
  16.487 +                          (*select first operand*)
  16.488 +             else path_finder_FT tm (p::ps)
  16.489 +                   (Metis_Term.Fn (".", [metis_eq,t2]))
  16.490 +                   (*1 selects second operand*)
  16.491 +        | path_finder FT tm (_ :: ps) (Metis_Term.Fn ("{}", [t1])) = path_finder_FT tm ps t1
  16.492 +             (*if not equality, ignore head to skip the hBOOL predicate*)
  16.493 +        | path_finder FT tm ps t = path_finder_FT tm ps t  (*really an error case!*)
  16.494 +      fun path_finder_lit ((nt as Const (@{const_name Not}, _)) $ tm_a) idx =
  16.495 +            let val (tm, tm_rslt) = path_finder mode tm_a idx m_tm
  16.496 +            in (tm, nt $ tm_rslt) end
  16.497 +        | path_finder_lit tm_a idx = path_finder mode tm_a idx m_tm
  16.498 +      val (tm_subst, body) = path_finder_lit i_atm fp
  16.499 +      val tm_abs = Abs ("x", type_of tm_subst, body)
  16.500 +      val _ = trace_msg (fn () => "abstraction: " ^ Syntax.string_of_term ctxt tm_abs)
  16.501 +      val _ = trace_msg (fn () => "i_tm: " ^ Syntax.string_of_term ctxt i_tm)
  16.502 +      val _ = trace_msg (fn () => "located term: " ^ Syntax.string_of_term ctxt tm_subst)
  16.503 +      val imax = maxidx_of_term (i_tm $ tm_abs $ tm_subst)  (*ill typed but gives right max*)
  16.504 +      val subst' = Thm.incr_indexes (imax+1) (if pos then subst_em else ssubst_em)
  16.505 +      val _ = trace_msg (fn () => "subst' " ^ Display.string_of_thm ctxt subst')
  16.506 +      val eq_terms = map (pairself (cterm_of thy))
  16.507 +        (ListPair.zip (OldTerm.term_vars (prop_of subst'), [tm_abs, tm_subst, i_tm]))
  16.508 +  in  cterm_instantiate eq_terms subst'  end;
  16.509 +
  16.510 +val factor = Seq.hd o distinct_subgoals_tac;
  16.511 +
  16.512 +fun step ctxt mode old_skolems thpairs p =
  16.513 +  case p of
  16.514 +    (fol_th, Metis_Proof.Axiom _) => factor (axiom_inf thpairs fol_th)
  16.515 +  | (_, Metis_Proof.Assume f_atm) => assume_inf ctxt mode old_skolems f_atm
  16.516 +  | (_, Metis_Proof.Metis_Subst (f_subst, f_th1)) =>
  16.517 +    factor (inst_inf ctxt mode old_skolems thpairs f_subst f_th1)
  16.518 +  | (_, Metis_Proof.Resolve(f_atm, f_th1, f_th2)) =>
  16.519 +    factor (resolve_inf ctxt mode old_skolems thpairs f_atm f_th1 f_th2)
  16.520 +  | (_, Metis_Proof.Refl f_tm) => refl_inf ctxt mode old_skolems f_tm
  16.521 +  | (_, Metis_Proof.Equality (f_lit, f_p, f_r)) =>
  16.522 +    equality_inf ctxt mode old_skolems f_lit f_p f_r
  16.523 +
  16.524 +fun flexflex_first_order th =
  16.525 +  case Thm.tpairs_of th of
  16.526 +      [] => th
  16.527 +    | pairs =>
  16.528 +        let val thy = theory_of_thm th
  16.529 +            val (_, tenv) =
  16.530 +              fold (Pattern.first_order_match thy) pairs (Vartab.empty, Vartab.empty)
  16.531 +            val t_pairs = map Meson.term_pair_of (Vartab.dest tenv)
  16.532 +            val th' = Thm.instantiate ([], map (pairself (cterm_of thy)) t_pairs) th
  16.533 +        in  th'  end
  16.534 +        handle THM _ => th;
  16.535 +
  16.536 +fun is_metis_literal_genuine (_, (s, _)) = not (String.isPrefix class_prefix s)
  16.537 +fun is_isabelle_literal_genuine t =
  16.538 +  case t of _ $ (Const (@{const_name Meson.skolem}, _) $ _) => false | _ => true
  16.539 +
  16.540 +fun count p xs = fold (fn x => if p x then Integer.add 1 else I) xs 0
  16.541 +
  16.542 +fun replay_one_inference ctxt mode old_skolems (fol_th, inf) thpairs =
  16.543 +  let
  16.544 +    val _ = trace_msg (fn () => "=============================================")
  16.545 +    val _ = trace_msg (fn () => "METIS THM: " ^ Metis_Thm.toString fol_th)
  16.546 +    val _ = trace_msg (fn () => "INFERENCE: " ^ Metis_Proof.inferenceToString inf)
  16.547 +    val th = step ctxt mode old_skolems thpairs (fol_th, inf)
  16.548 +             |> flexflex_first_order
  16.549 +    val _ = trace_msg (fn () => "ISABELLE THM: " ^ Display.string_of_thm ctxt th)
  16.550 +    val _ = trace_msg (fn () => "=============================================")
  16.551 +    val num_metis_lits =
  16.552 +      fol_th |> Metis_Thm.clause |> Metis_LiteralSet.toList
  16.553 +             |> count is_metis_literal_genuine
  16.554 +    val num_isabelle_lits =
  16.555 +      th |> prems_of |> count is_isabelle_literal_genuine
  16.556 +    val _ = if num_metis_lits = num_isabelle_lits then ()
  16.557 +            else error "Cannot replay Metis proof in Isabelle: Out of sync."
  16.558 +  in (fol_th, th) :: thpairs end
  16.559 +
  16.560 +end;
    17.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    17.2 +++ b/src/HOL/Tools/Metis/metis_tactics.ML	Wed Oct 06 17:44:21 2010 +0200
    17.3 @@ -0,0 +1,433 @@
    17.4 +(*  Title:      HOL/Tools/Metis/metis_tactics.ML
    17.5 +    Author:     Kong W. Susanto, Cambridge University Computer Laboratory
    17.6 +    Author:     Lawrence C. Paulson, Cambridge University Computer Laboratory
    17.7 +    Author:     Jasmin Blanchette, TU Muenchen
    17.8 +    Copyright   Cambridge University 2007
    17.9 +
   17.10 +HOL setup for the Metis prover.
   17.11 +*)
   17.12 +
   17.13 +signature METIS_TACTICS =
   17.14 +sig
   17.15 +  val trace : bool Unsynchronized.ref
   17.16 +  val type_lits : bool Config.T
   17.17 +  val new_skolemizer : bool Config.T
   17.18 +  val metis_tac : Proof.context -> thm list -> int -> tactic
   17.19 +  val metisF_tac : Proof.context -> thm list -> int -> tactic
   17.20 +  val metisFT_tac : Proof.context -> thm list -> int -> tactic
   17.21 +  val setup : theory -> theory
   17.22 +end
   17.23 +
   17.24 +structure Metis_Tactics : METIS_TACTICS =
   17.25 +struct
   17.26 +
   17.27 +open Metis_Translate
   17.28 +open Metis_Reconstruct
   17.29 +
   17.30 +structure Int_Pair_Graph =
   17.31 +  Graph(type key = int * int val ord = prod_ord int_ord int_ord)
   17.32 +
   17.33 +fun trace_msg msg = if !trace then tracing (msg ()) else ()
   17.34 +
   17.35 +val (type_lits, type_lits_setup) = Attrib.config_bool "metis_type_lits" (K true)
   17.36 +val (new_skolemizer, new_skolemizer_setup) =
   17.37 +  Attrib.config_bool "metis_new_skolemizer" (K false)
   17.38 +
   17.39 +fun is_false t = t aconv (HOLogic.mk_Trueprop HOLogic.false_const);
   17.40 +
   17.41 +fun have_common_thm ths1 ths2 =
   17.42 +  exists (member Thm.eq_thm ths1) (map Meson.make_meta_clause ths2)
   17.43 +
   17.44 +(*Determining which axiom clauses are actually used*)
   17.45 +fun used_axioms axioms (th, Metis_Proof.Axiom _) = SOME (lookth axioms th)
   17.46 +  | used_axioms _ _ = NONE;
   17.47 +
   17.48 +val clause_params =
   17.49 +  {ordering = Metis_KnuthBendixOrder.default,
   17.50 +   orderLiterals = Metis_Clause.UnsignedLiteralOrder,
   17.51 +   orderTerms = true}
   17.52 +val active_params =
   17.53 +  {clause = clause_params,
   17.54 +   prefactor = #prefactor Metis_Active.default,
   17.55 +   postfactor = #postfactor Metis_Active.default}
   17.56 +val waiting_params =
   17.57 +  {symbolsWeight = 1.0,
   17.58 +   variablesWeight = 0.0,
   17.59 +   literalsWeight = 0.0,
   17.60 +   models = []}
   17.61 +val resolution_params = {active = active_params, waiting = waiting_params}
   17.62 +
   17.63 +(* FIXME ### GET RID OF skolem WRAPPER by looking at substitution *)
   17.64 +
   17.65 +fun term_instantiate thy = cterm_instantiate o map (pairself (cterm_of thy))
   17.66 +
   17.67 +(* In principle, it should be sufficient to apply "assume_tac" to unify the
   17.68 +   conclusion with one of the premises. However, in practice, this is unreliable
   17.69 +   because of the mildly higher-order nature of the unification problems.
   17.70 +   Typical constraints are of the form
   17.71 +   "?SK_a_b_c_x SK_d_e_f_y ... SK_a_b_c_x ... SK_g_h_i_z =?= SK_a_b_c_x",
   17.72 +   where the nonvariables are goal parameters. *)
   17.73 +(* FIXME: ### try Pattern.match instead *)
   17.74 +fun unify_first_prem_with_concl thy i th =
   17.75 +  let
   17.76 +    val goal = Logic.get_goal (prop_of th) i |> Envir.beta_eta_contract
   17.77 +    val prem = goal |> Logic.strip_assums_hyp |> hd
   17.78 +    val concl = goal |> Logic.strip_assums_concl
   17.79 +    fun pair_untyped_aconv (t1, t2) (u1, u2) =
   17.80 +      untyped_aconv t1 u1 andalso untyped_aconv t2 u2
   17.81 +    fun add_terms tp inst =
   17.82 +      if exists (pair_untyped_aconv tp) inst then inst
   17.83 +      else tp :: map (apsnd (subst_atomic [tp])) inst
   17.84 +    fun is_flex t =
   17.85 +      case strip_comb t of
   17.86 +        (Var _, args) => forall is_Bound args
   17.87 +      | _ => false
   17.88 +    fun unify_flex flex rigid =
   17.89 +      case strip_comb flex of
   17.90 +        (Var (z as (_, T)), args) =>
   17.91 +        add_terms (Var z,
   17.92 +          fold_rev (curry absdummy) (take (length args) (binder_types T)) rigid)
   17.93 +      | _ => raise TERM ("unify_flex: expected flex", [flex])
   17.94 +    fun unify_potential_flex comb atom =
   17.95 +      if is_flex comb then unify_flex comb atom
   17.96 +      else if is_Var atom then add_terms (atom, comb)
   17.97 +      else raise TERM ("unify_terms", [comb, atom])
   17.98 +    fun unify_terms (t, u) =
   17.99 +      case (t, u) of
  17.100 +        (t1 $ t2, u1 $ u2) =>
  17.101 +        if is_flex t then unify_flex t u
  17.102 +        else if is_flex u then unify_flex u t
  17.103 +        else fold unify_terms [(t1, u1), (t2, u2)]
  17.104 +      | (_ $ _, _) => unify_potential_flex t u
  17.105 +      | (_, _ $ _) => unify_potential_flex u t
  17.106 +      | (Var _, _) => add_terms (t, u)
  17.107 +      | (_, Var _) => add_terms (u, t)
  17.108 +      | _ => if untyped_aconv t u then I else raise TERM ("unify_terms", [t, u])
  17.109 +  in th |> term_instantiate thy (unify_terms (prem, concl) []) end
  17.110 +
  17.111 +fun shuffle_key (((axiom_no, (_, index_no)), _), _) = (index_no, axiom_no)
  17.112 +fun shuffle_ord p =
  17.113 +  rev_order (prod_ord int_ord int_ord (pairself shuffle_key p))
  17.114 +
  17.115 +val copy_prem = @{lemma "P ==> (P ==> P ==> Q) ==> Q" by fast}
  17.116 +
  17.117 +fun copy_prems_tac [] ns i =
  17.118 +    if forall (curry (op =) 1) ns then all_tac else copy_prems_tac (rev ns) [] i
  17.119 +  | copy_prems_tac (1 :: ms) ns i =
  17.120 +    rotate_tac 1 i THEN copy_prems_tac ms (1 :: ns) i
  17.121 +  | copy_prems_tac (m :: ms) ns i =
  17.122 +    etac copy_prem i THEN copy_prems_tac ms (m div 2 :: (m + 1) div 2 :: ns) i
  17.123 +
  17.124 +fun instantiate_forall_tac thy params t i =
  17.125 +  let
  17.126 +    fun repair (t as (Var ((s, _), _))) =
  17.127 +        (case find_index (fn ((s', _), _) => s' = s) params of
  17.128 +           ~1 => t
  17.129 +         | j => Bound j)
  17.130 +      | repair (t $ u) = repair t $ repair u
  17.131 +      | repair t = t
  17.132 +    val t' = t |> repair |> fold (curry absdummy) (map snd params)
  17.133 +    fun do_instantiate th =
  17.134 +      let val var = Term.add_vars (prop_of th) [] |> the_single in
  17.135 +        th |> term_instantiate thy [(Var var, t')]
  17.136 +      end
  17.137 +  in
  17.138 +    etac @{thm allE} i
  17.139 +    THEN rotate_tac ~1 i
  17.140 +    THEN PRIMITIVE do_instantiate
  17.141 +  end
  17.142 +
  17.143 +fun release_clusters_tac _ _ _ _ [] = K all_tac
  17.144 +  | release_clusters_tac thy ax_counts substs params
  17.145 +                         ((ax_no, cluster_no) :: clusters) =
  17.146 +    let
  17.147 +      fun in_right_cluster s =
  17.148 +        (s |> Meson_Clausify.cluster_of_zapped_var_name |> fst |> snd |> fst)
  17.149 +        = cluster_no
  17.150 +      val cluster_substs =
  17.151 +        substs
  17.152 +        |> map_filter (fn (ax_no', (_, (_, tsubst))) =>
  17.153 +                          if ax_no' = ax_no then
  17.154 +                            tsubst |> filter (in_right_cluster
  17.155 +                                              o fst o fst o dest_Var o fst)
  17.156 +                                   |> map snd |> SOME
  17.157 +                           else
  17.158 +                             NONE)
  17.159 +      val n = length cluster_substs
  17.160 +      fun do_cluster_subst cluster_subst =
  17.161 +        map (instantiate_forall_tac thy params) cluster_subst @ [rotate_tac 1]
  17.162 +      val params' = params (* FIXME ### existentials! *)
  17.163 +      val first_prem = find_index (fn (ax_no', _) => ax_no' = ax_no) substs
  17.164 +    in
  17.165 +      rotate_tac first_prem
  17.166 +      THEN' (EVERY' (maps do_cluster_subst cluster_substs))
  17.167 +      THEN' rotate_tac (~ first_prem - length cluster_substs)
  17.168 +      THEN' release_clusters_tac thy ax_counts substs params' clusters
  17.169 +    end
  17.170 +
  17.171 +val cluster_ord =
  17.172 +  prod_ord (prod_ord int_ord (prod_ord int_ord int_ord)) bool_ord
  17.173 +
  17.174 +val tysubst_ord =
  17.175 +  list_ord (prod_ord Term_Ord.fast_indexname_ord
  17.176 +                     (prod_ord Term_Ord.sort_ord Term_Ord.typ_ord))
  17.177 +
  17.178 +structure Int_Tysubst_Table =
  17.179 +  Table(type key = int * (indexname * (sort * typ)) list
  17.180 +        val ord = prod_ord int_ord tysubst_ord)
  17.181 +
  17.182 +(* Attempts to derive the theorem "False" from a theorem of the form
  17.183 +   "P1 ==> ... ==> Pn ==> False", where the "Pi"s are to be discharged using the
  17.184 +   specified axioms. The axioms have leading "All" and "Ex" quantifiers, which
  17.185 +   must be eliminated first. *)
  17.186 +fun discharge_skolem_premises ctxt axioms prems_imp_false =
  17.187 +  if prop_of prems_imp_false aconv @{prop False} then
  17.188 +    prems_imp_false
  17.189 +  else
  17.190 +    let
  17.191 +      val thy = ProofContext.theory_of ctxt
  17.192 +      (* distinguish variables with same name but different types *)
  17.193 +      val prems_imp_false' =
  17.194 +        prems_imp_false |> try (forall_intr_vars #> gen_all)
  17.195 +                        |> the_default prems_imp_false
  17.196 +      val prems_imp_false =
  17.197 +        if prop_of prems_imp_false aconv prop_of prems_imp_false' then
  17.198 +          prems_imp_false
  17.199 +        else
  17.200 +          prems_imp_false'
  17.201 +      fun match_term p =
  17.202 +        let
  17.203 +          val (tyenv, tenv) =
  17.204 +            Pattern.first_order_match thy p (Vartab.empty, Vartab.empty)
  17.205 +          val tsubst =
  17.206 +            tenv |> Vartab.dest
  17.207 +                 |> sort (cluster_ord
  17.208 +                          o pairself (Meson_Clausify.cluster_of_zapped_var_name
  17.209 +                                      o fst o fst))
  17.210 +                 |> map (Meson.term_pair_of
  17.211 +                         #> pairself (Envir.subst_term_types tyenv))
  17.212 +          val tysubst = tyenv |> Vartab.dest
  17.213 +        in (tysubst, tsubst) end
  17.214 +      fun subst_info_for_prem subgoal_no prem =
  17.215 +        case prem of
  17.216 +          _ $ (Const (@{const_name Meson.skolem}, _) $ (_ $ t $ num)) =>
  17.217 +          let val ax_no = HOLogic.dest_nat num in
  17.218 +            (ax_no, (subgoal_no,
  17.219 +                     match_term (nth axioms ax_no |> the |> snd, t)))
  17.220 +          end
  17.221 +        | _ => raise TERM ("discharge_skolem_premises: Malformed premise",
  17.222 +                           [prem])
  17.223 +      fun cluster_of_var_name skolem s =
  17.224 +        let
  17.225 +          val ((ax_no, (cluster_no, _)), skolem') =
  17.226 +            Meson_Clausify.cluster_of_zapped_var_name s
  17.227 +        in
  17.228 +          if skolem' = skolem andalso cluster_no > 0 then
  17.229 +            SOME (ax_no, cluster_no)
  17.230 +          else
  17.231 +            NONE
  17.232 +        end
  17.233 +      fun clusters_in_term skolem t =
  17.234 +        Term.add_var_names t [] |> map_filter (cluster_of_var_name skolem o fst)
  17.235 +      fun deps_for_term_subst (var, t) =
  17.236 +        case clusters_in_term false var of
  17.237 +          [] => NONE
  17.238 +        | [(ax_no, cluster_no)] =>
  17.239 +          SOME ((ax_no, cluster_no),
  17.240 +                clusters_in_term true t
  17.241 +                |> cluster_no > 1 ? cons (ax_no, cluster_no - 1))
  17.242 +        | _ => raise TERM ("discharge_skolem_premises: Expected Var", [var])
  17.243 +      val prems = Logic.strip_imp_prems (prop_of prems_imp_false)
  17.244 +      val substs = prems |> map2 subst_info_for_prem (1 upto length prems)
  17.245 +                         |> sort (int_ord o pairself fst)
  17.246 +      val depss = maps (map_filter deps_for_term_subst o snd o snd o snd) substs
  17.247 +      val clusters = maps (op ::) depss
  17.248 +      val ordered_clusters =
  17.249 +        Int_Pair_Graph.empty
  17.250 +        |> fold Int_Pair_Graph.default_node (map (rpair ()) clusters)
  17.251 +        |> fold Int_Pair_Graph.add_deps_acyclic depss
  17.252 +        |> Int_Pair_Graph.topological_order
  17.253 +        handle Int_Pair_Graph.CYCLES _ =>
  17.254 +               error "Cannot replay Metis proof in Isabelle without axiom of \
  17.255 +                     \choice."
  17.256 +      val params0 =
  17.257 +        [] |> fold (Term.add_vars o snd) (map_filter I axioms)
  17.258 +           |> map (`(Meson_Clausify.cluster_of_zapped_var_name o fst o fst))
  17.259 +           |> filter (fn (((_, (cluster_no, _)), skolem), _) =>
  17.260 +                         cluster_no = 0 andalso skolem)
  17.261 +           |> sort shuffle_ord |> map snd
  17.262 +      val ax_counts =
  17.263 +        Int_Tysubst_Table.empty
  17.264 +        |> fold (fn (ax_no, (_, (tysubst, _))) =>
  17.265 +                    Int_Tysubst_Table.map_default ((ax_no, tysubst), 0)
  17.266 +                                                  (Integer.add 1)) substs
  17.267 +        |> Int_Tysubst_Table.dest
  17.268 +(* for debugging:
  17.269 +      fun string_for_subst_info (ax_no, (subgoal_no, (tysubst, tsubst))) =
  17.270 +        "ax: " ^ string_of_int ax_no ^ "; asm: " ^ string_of_int subgoal_no ^
  17.271 +        "; tysubst: " ^ PolyML.makestring tysubst ^ "; tsubst: {" ^
  17.272 +        commas (map ((fn (s, t) => s ^ " |-> " ^ t)
  17.273 +                     o pairself (Syntax.string_of_term ctxt)) tsubst) ^ "}"
  17.274 +      val _ = tracing ("SUBSTS (" ^ string_of_int (length substs) ^ "):\n" ^
  17.275 +                       cat_lines (map string_for_subst_info substs))
  17.276 +      val _ = tracing ("OUTERMOST SKOLEMS: " ^ PolyML.makestring params0)
  17.277 +      val _ = tracing ("ORDERED CLUSTERS: " ^ PolyML.makestring ordered_clusters)
  17.278 +      val _ = tracing ("AXIOM COUNTS: " ^ PolyML.makestring ax_counts)
  17.279 +*)
  17.280 +      fun rotation_for_subgoal i =
  17.281 +        find_index (fn (_, (subgoal_no, _)) => subgoal_no = i) substs
  17.282 +    in
  17.283 +      Goal.prove ctxt [] [] @{prop False}
  17.284 +          (K (cut_rules_tac
  17.285 +                  (map (fst o the o nth axioms o fst o fst) ax_counts) 1
  17.286 +              THEN TRY (REPEAT_ALL_NEW (etac @{thm exE}) 1)
  17.287 +              THEN copy_prems_tac (map snd ax_counts) [] 1
  17.288 +              THEN release_clusters_tac thy ax_counts substs params0
  17.289 +                                        ordered_clusters 1
  17.290 +              THEN match_tac [prems_imp_false] 1
  17.291 +              THEN ALLGOALS (fn i =>
  17.292 +                       rtac @{thm Meson.skolem_COMBK_I} i
  17.293 +                       THEN rotate_tac (rotation_for_subgoal i) i
  17.294 +                       THEN PRIMITIVE (unify_first_prem_with_concl thy i)
  17.295 +                       THEN assume_tac i)))
  17.296 +    end
  17.297 +
  17.298 +(* Main function to start Metis proof and reconstruction *)
  17.299 +fun FOL_SOLVE mode ctxt cls ths0 =
  17.300 +  let val thy = ProofContext.theory_of ctxt
  17.301 +      val type_lits = Config.get ctxt type_lits
  17.302 +      val new_skolemizer =
  17.303 +        Config.get ctxt new_skolemizer orelse null (Meson.choice_theorems thy)
  17.304 +      val th_cls_pairs =
  17.305 +        map2 (fn j => fn th =>
  17.306 +                (Thm.get_name_hint th,
  17.307 +                 Meson_Clausify.cnf_axiom ctxt new_skolemizer j th))
  17.308 +             (0 upto length ths0 - 1) ths0
  17.309 +      val thss = map (snd o snd) th_cls_pairs
  17.310 +      val dischargers = map (fst o snd) th_cls_pairs
  17.311 +      val _ = trace_msg (fn () => "FOL_SOLVE: CONJECTURE CLAUSES")
  17.312 +      val _ = app (fn th => trace_msg (fn () => Display.string_of_thm ctxt th)) cls
  17.313 +      val _ = trace_msg (fn () => "THEOREM CLAUSES")
  17.314 +      val _ = app (app (fn th => trace_msg (fn () => Display.string_of_thm ctxt th))) thss
  17.315 +      val (mode, {axioms, tfrees, old_skolems}) =
  17.316 +        build_logic_map mode ctxt type_lits cls thss
  17.317 +      val _ = if null tfrees then ()
  17.318 +              else (trace_msg (fn () => "TFREE CLAUSES");
  17.319 +                    app (fn TyLitFree ((s, _), (s', _)) =>
  17.320 +                            trace_msg (fn () => s ^ "(" ^ s' ^ ")")) tfrees)
  17.321 +      val _ = trace_msg (fn () => "CLAUSES GIVEN TO METIS")
  17.322 +      val thms = map #1 axioms
  17.323 +      val _ = app (fn th => trace_msg (fn () => Metis_Thm.toString th)) thms
  17.324 +      val _ = trace_msg (fn () => "mode = " ^ string_of_mode mode)
  17.325 +      val _ = trace_msg (fn () => "START METIS PROVE PROCESS")
  17.326 +  in
  17.327 +      case filter (is_false o prop_of) cls of
  17.328 +          false_th::_ => [false_th RS @{thm FalseE}]
  17.329 +        | [] =>
  17.330 +      case Metis_Resolution.new resolution_params {axioms = thms, conjecture = []}
  17.331 +           |> Metis_Resolution.loop of
  17.332 +          Metis_Resolution.Contradiction mth =>
  17.333 +            let val _ = trace_msg (fn () => "METIS RECONSTRUCTION START: " ^
  17.334 +                          Metis_Thm.toString mth)
  17.335 +                val ctxt' = fold Variable.declare_constraints (map prop_of cls) ctxt
  17.336 +                             (*add constraints arising from converting goal to clause form*)
  17.337 +                val proof = Metis_Proof.proof mth
  17.338 +                val result =
  17.339 +                  fold (replay_one_inference ctxt' mode old_skolems) proof axioms
  17.340 +                and used = map_filter (used_axioms axioms) proof
  17.341 +                val _ = trace_msg (fn () => "METIS COMPLETED...clauses actually used:")
  17.342 +                val _ = app (fn th => trace_msg (fn () => Display.string_of_thm ctxt th)) used
  17.343 +                val unused = th_cls_pairs |> map_filter (fn (name, (_, cls)) =>
  17.344 +                  if have_common_thm used cls then NONE else SOME name)
  17.345 +            in
  17.346 +                if not (null cls) andalso not (have_common_thm used cls) then
  17.347 +                  warning "Metis: The assumptions are inconsistent."
  17.348 +                else
  17.349 +                  ();
  17.350 +                if not (null unused) then
  17.351 +                  warning ("Metis: Unused theorems: " ^ commas_quote unused
  17.352 +                           ^ ".")
  17.353 +                else
  17.354 +                  ();
  17.355 +                case result of
  17.356 +                    (_,ith)::_ =>
  17.357 +                        (trace_msg (fn () => "Success: " ^ Display.string_of_thm ctxt ith);
  17.358 +                         [discharge_skolem_premises ctxt dischargers ith])
  17.359 +                  | _ => (trace_msg (fn () => "Metis: No result"); [])
  17.360 +            end
  17.361 +        | Metis_Resolution.Satisfiable _ =>
  17.362 +            (trace_msg (fn () => "Metis: No first-order proof with the lemmas supplied");
  17.363 +             [])
  17.364 +  end;
  17.365 +
  17.366 +(* Extensionalize "th", because that makes sense and that's what Sledgehammer
  17.367 +   does, but also keep an unextensionalized version of "th" for backward
  17.368 +   compatibility. *)
  17.369 +fun also_extensionalize_theorem th =
  17.370 +  let val th' = Meson_Clausify.extensionalize_theorem th in
  17.371 +    if Thm.eq_thm (th, th') then [th]
  17.372 +    else th :: Meson.make_clauses_unsorted [th']
  17.373 +  end
  17.374 +
  17.375 +val neg_clausify =
  17.376 +  single
  17.377 +  #> Meson.make_clauses_unsorted
  17.378 +  #> maps also_extensionalize_theorem
  17.379 +  #> map Meson_Clausify.introduce_combinators_in_theorem
  17.380 +  #> Meson.finish_cnf
  17.381 +
  17.382 +fun preskolem_tac ctxt st0 =
  17.383 +  (if exists (Meson.has_too_many_clauses ctxt)
  17.384 +             (Logic.prems_of_goal (prop_of st0) 1) then
  17.385 +     cnf.cnfx_rewrite_tac ctxt 1
  17.386 +   else
  17.387 +     all_tac) st0
  17.388 +
  17.389 +val type_has_top_sort =
  17.390 +  exists_subtype (fn TFree (_, []) => true | TVar (_, []) => true | _ => false)
  17.391 +
  17.392 +fun generic_metis_tac mode ctxt ths i st0 =
  17.393 +  let
  17.394 +    val _ = trace_msg (fn () =>
  17.395 +        "Metis called with theorems " ^ cat_lines (map (Display.string_of_thm ctxt) ths))
  17.396 +  in
  17.397 +    if exists_type type_has_top_sort (prop_of st0) then
  17.398 +      (warning ("Metis: Proof state contains the universal sort {}"); Seq.empty)
  17.399 +    else
  17.400 +      Meson.MESON (preskolem_tac ctxt) (maps neg_clausify)
  17.401 +                  (fn cls => resolve_tac (FOL_SOLVE mode ctxt cls ths) 1)
  17.402 +                  ctxt i st0
  17.403 +  end
  17.404 +
  17.405 +val metis_tac = generic_metis_tac HO
  17.406 +val metisF_tac = generic_metis_tac FO
  17.407 +val metisFT_tac = generic_metis_tac FT
  17.408 +
  17.409 +(* Whenever "X" has schematic type variables, we treat "using X by metis" as
  17.410 +   "by (metis X)", to prevent "Subgoal.FOCUS" from freezing the type variables.
  17.411 +   We don't do it for nonschematic facts "X" because this breaks a few proofs
  17.412 +   (in the rare and subtle case where a proof relied on extensionality not being
  17.413 +   applied) and brings few benefits. *)
  17.414 +val has_tvar =
  17.415 +  exists_type (exists_subtype (fn TVar _ => true | _ => false)) o prop_of
  17.416 +fun method name mode =
  17.417 +  Method.setup name (Attrib.thms >> (fn ths => fn ctxt =>
  17.418 +    METHOD (fn facts =>
  17.419 +               let
  17.420 +                 val (schem_facts, nonschem_facts) =
  17.421 +                   List.partition has_tvar facts
  17.422 +               in
  17.423 +                 HEADGOAL (Method.insert_tac nonschem_facts THEN'
  17.424 +                           CHANGED_PROP
  17.425 +                           o generic_metis_tac mode ctxt (schem_facts @ ths))
  17.426 +               end)))
  17.427 +
  17.428 +val setup =
  17.429 +  type_lits_setup
  17.430 +  #> new_skolemizer_setup
  17.431 +  #> method @{binding metis} HO "Metis for FOL/HOL problems"
  17.432 +  #> method @{binding metisF} FO "Metis for FOL problems"
  17.433 +  #> method @{binding metisFT} FT
  17.434 +            "Metis for FOL/HOL problems with fully-typed translation"
  17.435 +
  17.436 +end;
    18.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    18.2 +++ b/src/HOL/Tools/Metis/metis_translate.ML	Wed Oct 06 17:44:21 2010 +0200
    18.3 @@ -0,0 +1,771 @@
    18.4 +(*  Title:      HOL/Tools/Metis/metis_translate.ML
    18.5 +    Author:     Jia Meng, Cambridge University Computer Laboratory and NICTA
    18.6 +    Author:     Kong W. Susanto, Cambridge University Computer Laboratory
    18.7 +    Author:     Lawrence C. Paulson, Cambridge University Computer Laboratory
    18.8 +    Author:     Jasmin Blanchette, TU Muenchen
    18.9 +
   18.10 +Translation of HOL to FOL for Metis.
   18.11 +*)
   18.12 +
   18.13 +signature METIS_TRANSLATE =
   18.14 +sig
   18.15 +  type name = string * string
   18.16 +  datatype type_literal =
   18.17 +    TyLitVar of name * name |
   18.18 +    TyLitFree of name * name
   18.19 +  datatype arLit =
   18.20 +    TConsLit of name * name * name list |
   18.21 +    TVarLit of name * name
   18.22 +  datatype arity_clause =
   18.23 +    ArityClause of {name: string, conclLit: arLit, premLits: arLit list}
   18.24 +  datatype class_rel_clause =
   18.25 +    ClassRelClause of {name: string, subclass: name, superclass: name}
   18.26 +  datatype combtyp =
   18.27 +    CombTVar of name |
   18.28 +    CombTFree of name |
   18.29 +    CombType of name * combtyp list
   18.30 +  datatype combterm =
   18.31 +    CombConst of name * combtyp * combtyp list (* Const and Free *) |
   18.32 +    CombVar of name * combtyp |
   18.33 +    CombApp of combterm * combterm
   18.34 +  datatype fol_literal = FOLLiteral of bool * combterm
   18.35 +
   18.36 +  datatype mode = FO | HO | FT
   18.37 +  type logic_map =
   18.38 +    {axioms: (Metis_Thm.thm * thm) list,
   18.39 +     tfrees: type_literal list,
   18.40 +     old_skolems: (string * term) list}
   18.41 +
   18.42 +  val type_wrapper_name : string
   18.43 +  val bound_var_prefix : string
   18.44 +  val schematic_var_prefix: string
   18.45 +  val fixed_var_prefix: string
   18.46 +  val tvar_prefix: string
   18.47 +  val tfree_prefix: string
   18.48 +  val const_prefix: string
   18.49 +  val type_const_prefix: string
   18.50 +  val class_prefix: string
   18.51 +  val new_skolem_const_prefix : string
   18.52 +  val invert_const: string -> string
   18.53 +  val ascii_of: string -> string
   18.54 +  val unascii_of: string -> string
   18.55 +  val strip_prefix_and_unascii: string -> string -> string option
   18.56 +  val make_bound_var : string -> string
   18.57 +  val make_schematic_var : string * int -> string
   18.58 +  val make_fixed_var : string -> string
   18.59 +  val make_schematic_type_var : string * int -> string
   18.60 +  val make_fixed_type_var : string -> string
   18.61 +  val make_fixed_const : string -> string
   18.62 +  val make_fixed_type_const : string -> string
   18.63 +  val make_type_class : string -> string
   18.64 +  val num_type_args: theory -> string -> int
   18.65 +  val new_skolem_var_from_const: string -> indexname
   18.66 +  val type_literals_for_types : typ list -> type_literal list
   18.67 +  val make_class_rel_clauses :
   18.68 +    theory -> class list -> class list -> class_rel_clause list
   18.69 +  val make_arity_clauses :
   18.70 +    theory -> string list -> class list -> class list * arity_clause list
   18.71 +  val combtyp_of : combterm -> combtyp
   18.72 +  val strip_combterm_comb : combterm -> combterm * combterm list
   18.73 +  val combterm_from_term :
   18.74 +    theory -> int -> (string * typ) list -> term -> combterm * typ list
   18.75 +  val reveal_old_skolem_terms : (string * term) list -> term -> term
   18.76 +  val tfree_classes_of_terms : term list -> string list
   18.77 +  val tvar_classes_of_terms : term list -> string list
   18.78 +  val type_consts_of_terms : theory -> term list -> string list
   18.79 +  val string_of_mode : mode -> string
   18.80 +  val build_logic_map :
   18.81 +    mode -> Proof.context -> bool -> thm list -> thm list list
   18.82 +    -> mode * logic_map
   18.83 +end
   18.84 +
   18.85 +structure Metis_Translate : METIS_TRANSLATE =
   18.86 +struct
   18.87 +
   18.88 +val type_wrapper_name = "ti"
   18.89 +
   18.90 +val bound_var_prefix = "B_"
   18.91 +val schematic_var_prefix = "V_"
   18.92 +val fixed_var_prefix = "v_"
   18.93 +
   18.94 +val tvar_prefix = "T_";
   18.95 +val tfree_prefix = "t_";
   18.96 +
   18.97 +val const_prefix = "c_";
   18.98 +val type_const_prefix = "tc_";
   18.99 +val class_prefix = "class_";
  18.100 +
  18.101 +val skolem_const_prefix = "Sledgehammer" ^ Long_Name.separator ^ "Sko"
  18.102 +val old_skolem_const_prefix = skolem_const_prefix ^ "o"
  18.103 +val new_skolem_const_prefix = skolem_const_prefix ^ "n"
  18.104 +
  18.105 +fun union_all xss = fold (union (op =)) xss []
  18.106 +
  18.107 +(* Readable names for the more common symbolic functions. Do not mess with the
  18.108 +   last nine entries of the table unless you know what you are doing. *)
  18.109 +val const_trans_table =
  18.110 +  Symtab.make [(@{type_name Product_Type.prod}, "prod"),
  18.111 +               (@{type_name Sum_Type.sum}, "sum"),
  18.112 +               (@{const_name HOL.eq}, "equal"),
  18.113 +               (@{const_name HOL.conj}, "and"),
  18.114 +               (@{const_name HOL.disj}, "or"),
  18.115 +               (@{const_name HOL.implies}, "implies"),
  18.116 +               (@{const_name Set.member}, "member"),
  18.117 +               (@{const_name Metis.fequal}, "fequal"),
  18.118 +               (@{const_name Meson.COMBI}, "COMBI"),
  18.119 +               (@{const_name Meson.COMBK}, "COMBK"),
  18.120 +               (@{const_name Meson.COMBB}, "COMBB"),
  18.121 +               (@{const_name Meson.COMBC}, "COMBC"),
  18.122 +               (@{const_name Meson.COMBS}, "COMBS"),
  18.123 +               (@{const_name True}, "True"),
  18.124 +               (@{const_name False}, "False"),
  18.125 +               (@{const_name If}, "If")]
  18.126 +
  18.127 +(* Invert the table of translations between Isabelle and ATPs. *)
  18.128 +val const_trans_table_inv =
  18.129 +  Symtab.update ("fequal", @{const_name HOL.eq})
  18.130 +                (Symtab.make (map swap (Symtab.dest const_trans_table)))
  18.131 +
  18.132 +val invert_const = perhaps (Symtab.lookup const_trans_table_inv)
  18.133 +
  18.134 +(*Escaping of special characters.
  18.135 +  Alphanumeric characters are left unchanged.
  18.136 +  The character _ goes to __
  18.137 +  Characters in the range ASCII space to / go to _A to _P, respectively.
  18.138 +  Other characters go to _nnn where nnn is the decimal ASCII code.*)
  18.139 +val A_minus_space = Char.ord #"A" - Char.ord #" ";
  18.140 +
  18.141 +fun stringN_of_int 0 _ = ""
  18.142 +  | stringN_of_int k n = stringN_of_int (k-1) (n div 10) ^ Int.toString (n mod 10);
  18.143 +
  18.144 +fun ascii_of_c c =
  18.145 +  if Char.isAlphaNum c then String.str c
  18.146 +  else if c = #"_" then "__"
  18.147 +  else if #" " <= c andalso c <= #"/"
  18.148 +       then "_" ^ String.str (Char.chr (Char.ord c + A_minus_space))
  18.149 +  else ("_" ^ stringN_of_int 3 (Char.ord c))  (*fixed width, in case more digits follow*)
  18.150 +
  18.151 +val ascii_of = String.translate ascii_of_c;
  18.152 +
  18.153 +(** Remove ASCII armouring from names in proof files **)
  18.154 +
  18.155 +(*We don't raise error exceptions because this code can run inside the watcher.
  18.156 +  Also, the errors are "impossible" (hah!)*)
  18.157 +fun unascii_aux rcs [] = String.implode(rev rcs)
  18.158 +  | unascii_aux rcs [#"_"] = unascii_aux (#"_"::rcs) []  (*ERROR*)
  18.159 +      (*Three types of _ escapes: __, _A to _P, _nnn*)
  18.160 +  | unascii_aux rcs (#"_" :: #"_" :: cs) = unascii_aux (#"_"::rcs) cs
  18.161 +  | unascii_aux rcs (#"_" :: c :: cs) =
  18.162 +      if #"A" <= c andalso c<= #"P"  (*translation of #" " to #"/"*)
  18.163 +      then unascii_aux (Char.chr(Char.ord c - A_minus_space) :: rcs) cs
  18.164 +      else
  18.165 +        let val digits = List.take (c::cs, 3) handle Subscript => []
  18.166 +        in
  18.167 +            case Int.fromString (String.implode digits) of
  18.168 +                NONE => unascii_aux (c:: #"_"::rcs) cs  (*ERROR*)
  18.169 +              | SOME n => unascii_aux (Char.chr n :: rcs) (List.drop (cs, 2))
  18.170 +        end
  18.171 +  | unascii_aux rcs (c::cs) = unascii_aux (c::rcs) cs
  18.172 +val unascii_of = unascii_aux [] o String.explode
  18.173 +
  18.174 +(* If string s has the prefix s1, return the result of deleting it,
  18.175 +   un-ASCII'd. *)
  18.176 +fun strip_prefix_and_unascii s1 s =
  18.177 +  if String.isPrefix s1 s then
  18.178 +    SOME (unascii_of (String.extract (s, size s1, NONE)))
  18.179 +  else
  18.180 +    NONE
  18.181 +
  18.182 +(*Remove the initial ' character from a type variable, if it is present*)
  18.183 +fun trim_type_var s =
  18.184 +  if s <> "" andalso String.sub(s,0) = #"'" then String.extract(s,1,NONE)
  18.185 +  else error ("trim_type: Malformed type variable encountered: " ^ s);
  18.186 +
  18.187 +fun ascii_of_indexname (v,0) = ascii_of v
  18.188 +  | ascii_of_indexname (v,i) = ascii_of v ^ "_" ^ Int.toString i;
  18.189 +
  18.190 +fun make_bound_var x = bound_var_prefix ^ ascii_of x
  18.191 +fun make_schematic_var v = schematic_var_prefix ^ ascii_of_indexname v
  18.192 +fun make_fixed_var x = fixed_var_prefix ^ ascii_of x
  18.193 +
  18.194 +fun make_schematic_type_var (x,i) =
  18.195 +      tvar_prefix ^ (ascii_of_indexname (trim_type_var x,i));
  18.196 +fun make_fixed_type_var x = tfree_prefix ^ (ascii_of (trim_type_var x));
  18.197 +
  18.198 +fun lookup_const c =
  18.199 +  case Symtab.lookup const_trans_table c of
  18.200 +    SOME c' => c'
  18.201 +  | NONE => ascii_of c
  18.202 +
  18.203 +(* HOL.eq MUST BE "equal" because it's built into ATPs. *)
  18.204 +fun make_fixed_const @{const_name HOL.eq} = "equal"
  18.205 +  | make_fixed_const c = const_prefix ^ lookup_const c
  18.206 +
  18.207 +fun make_fixed_type_const c = type_const_prefix ^ lookup_const c
  18.208 +
  18.209 +fun make_type_class clas = class_prefix ^ ascii_of clas;
  18.210 +
  18.211 +(* The number of type arguments of a constant, zero if it's monomorphic. For
  18.212 +   (instances of) Skolem pseudoconstants, this information is encoded in the
  18.213 +   constant name. *)
  18.214 +fun num_type_args thy s =
  18.215 +  if String.isPrefix skolem_const_prefix s then
  18.216 +    s |> space_explode Long_Name.separator |> List.last |> Int.fromString |> the
  18.217 +  else
  18.218 +    (s, Sign.the_const_type thy s) |> Sign.const_typargs thy |> length
  18.219 +
  18.220 +fun new_skolem_var_from_const s =
  18.221 +  let
  18.222 +    val ss = s |> space_explode Long_Name.separator
  18.223 +    val n = length ss
  18.224 +  in (nth ss (n - 2), nth ss (n - 3) |> Int.fromString |> the) end
  18.225 +
  18.226 +
  18.227 +(**** Definitions and functions for FOL clauses for TPTP format output ****)
  18.228 +
  18.229 +type name = string * string
  18.230 +
  18.231 +(**** Isabelle FOL clauses ****)
  18.232 +
  18.233 +(* The first component is the type class; the second is a TVar or TFree. *)
  18.234 +datatype type_literal =
  18.235 +  TyLitVar of name * name |
  18.236 +  TyLitFree of name * name
  18.237 +
  18.238 +(*Make literals for sorted type variables*)
  18.239 +fun sorts_on_typs_aux (_, [])   = []
  18.240 +  | sorts_on_typs_aux ((x,i),  s::ss) =
  18.241 +      let val sorts = sorts_on_typs_aux ((x,i), ss)
  18.242 +      in
  18.243 +          if s = "HOL.type" then sorts
  18.244 +          else if i = ~1 then TyLitFree (`make_type_class s, `make_fixed_type_var x) :: sorts
  18.245 +          else TyLitVar (`make_type_class s, (make_schematic_type_var (x,i), x)) :: sorts
  18.246 +      end;
  18.247 +
  18.248 +fun sorts_on_typs (TFree (a,s)) = sorts_on_typs_aux ((a,~1),s)
  18.249 +  | sorts_on_typs (TVar (v,s))  = sorts_on_typs_aux (v,s);
  18.250 +
  18.251 +(*Given a list of sorted type variables, return a list of type literals.*)
  18.252 +fun type_literals_for_types Ts =
  18.253 +  fold (union (op =)) (map sorts_on_typs Ts) []
  18.254 +
  18.255 +(** make axiom and conjecture clauses. **)
  18.256 +
  18.257 +(**** Isabelle arities ****)
  18.258 +
  18.259 +datatype arLit =
  18.260 +  TConsLit of name * name * name list |
  18.261 +  TVarLit of name * name
  18.262 +
  18.263 +datatype arity_clause =
  18.264 +  ArityClause of {name: string, conclLit: arLit, premLits: arLit list}
  18.265 +
  18.266 +
  18.267 +fun gen_TVars 0 = []
  18.268 +  | gen_TVars n = ("T_" ^ Int.toString n) :: gen_TVars (n-1);
  18.269 +
  18.270 +fun pack_sort(_,[])  = []
  18.271 +  | pack_sort(tvar, "HOL.type"::srt) = pack_sort (tvar, srt)   (*IGNORE sort "type"*)
  18.272 +  | pack_sort(tvar, cls::srt) =
  18.273 +    (`make_type_class cls, (tvar, tvar)) :: pack_sort (tvar, srt)
  18.274 +
  18.275 +(*Arity of type constructor tcon :: (arg1,...,argN)res*)
  18.276 +fun make_axiom_arity_clause (tcons, name, (cls,args)) =
  18.277 +  let
  18.278 +    val tvars = gen_TVars (length args)
  18.279 +    val tvars_srts = ListPair.zip (tvars, args)
  18.280 +  in
  18.281 +    ArityClause {name = name,
  18.282 +                 conclLit = TConsLit (`make_type_class cls,
  18.283 +                                      `make_fixed_type_const tcons,
  18.284 +                                      tvars ~~ tvars),
  18.285 +                 premLits = map TVarLit (union_all (map pack_sort tvars_srts))}
  18.286 +  end
  18.287 +
  18.288 +
  18.289 +(**** Isabelle class relations ****)
  18.290 +
  18.291 +datatype class_rel_clause =
  18.292 +  ClassRelClause of {name: string, subclass: name, superclass: name}
  18.293 +
  18.294 +(*Generate all pairs (sub,super) such that sub is a proper subclass of super in theory thy.*)
  18.295 +fun class_pairs _ [] _ = []
  18.296 +  | class_pairs thy subs supers =
  18.297 +      let
  18.298 +        val class_less = Sorts.class_less (Sign.classes_of thy)
  18.299 +        fun add_super sub super = class_less (sub, super) ? cons (sub, super)
  18.300 +        fun add_supers sub = fold (add_super sub) supers
  18.301 +      in fold add_supers subs [] end
  18.302 +
  18.303 +fun make_class_rel_clause (sub,super) =
  18.304 +  ClassRelClause {name = sub ^ "_" ^ super,
  18.305 +                  subclass = `make_type_class sub,
  18.306 +                  superclass = `make_type_class super}
  18.307 +
  18.308 +fun make_class_rel_clauses thy subs supers =
  18.309 +  map make_class_rel_clause (class_pairs thy subs supers);
  18.310 +
  18.311 +
  18.312 +(** Isabelle arities **)
  18.313 +
  18.314 +fun arity_clause _ _ (_, []) = []
  18.315 +  | arity_clause seen n (tcons, ("HOL.type",_)::ars) =  (*ignore*)
  18.316 +      arity_clause seen n (tcons,ars)
  18.317 +  | arity_clause seen n (tcons, (ar as (class,_)) :: ars) =
  18.318 +      if member (op =) seen class then (*multiple arities for the same tycon, class pair*)
  18.319 +          make_axiom_arity_clause (tcons, lookup_const tcons ^ "_" ^ class ^ "_" ^ Int.toString n, ar) ::
  18.320 +          arity_clause seen (n+1) (tcons,ars)
  18.321 +      else
  18.322 +          make_axiom_arity_clause (tcons, lookup_const tcons ^ "_" ^ class, ar) ::
  18.323 +          arity_clause (class::seen) n (tcons,ars)
  18.324 +
  18.325 +fun multi_arity_clause [] = []
  18.326 +  | multi_arity_clause ((tcons, ars) :: tc_arlists) =
  18.327 +      arity_clause [] 1 (tcons, ars) @ multi_arity_clause tc_arlists
  18.328 +
  18.329 +(*Generate all pairs (tycon,class,sorts) such that tycon belongs to class in theory thy
  18.330 +  provided its arguments have the corresponding sorts.*)
  18.331 +fun type_class_pairs thy tycons classes =
  18.332 +  let val alg = Sign.classes_of thy
  18.333 +      fun domain_sorts tycon = Sorts.mg_domain alg tycon o single
  18.334 +      fun add_class tycon class =
  18.335 +        cons (class, domain_sorts tycon class)
  18.336 +        handle Sorts.CLASS_ERROR _ => I
  18.337 +      fun try_classes tycon = (tycon, fold (add_class tycon) classes [])
  18.338 +  in  map try_classes tycons  end;
  18.339 +
  18.340 +(*Proving one (tycon, class) membership may require proving others, so iterate.*)
  18.341 +fun iter_type_class_pairs _ _ [] = ([], [])
  18.342 +  | iter_type_class_pairs thy tycons classes =
  18.343 +      let val cpairs = type_class_pairs thy tycons classes
  18.344 +          val newclasses = union_all (union_all (union_all (map (map #2 o #2) cpairs)))
  18.345 +            |> subtract (op =) classes |> subtract (op =) HOLogic.typeS
  18.346 +          val (classes', cpairs') = iter_type_class_pairs thy tycons newclasses
  18.347 +      in (union (op =) classes' classes, union (op =) cpairs' cpairs) end;
  18.348 +
  18.349 +fun make_arity_clauses thy tycons classes =
  18.350 +  let val (classes', cpairs) = iter_type_class_pairs thy tycons classes
  18.351 +  in  (classes', multi_arity_clause cpairs)  end;
  18.352 +
  18.353 +datatype combtyp =
  18.354 +  CombTVar of name |
  18.355 +  CombTFree of name |
  18.356 +  CombType of name * combtyp list
  18.357 +
  18.358 +datatype combterm =
  18.359 +  CombConst of name * combtyp * combtyp list (* Const and Free *) |
  18.360 +  CombVar of name * combtyp |
  18.361 +  CombApp of combterm * combterm
  18.362 +
  18.363 +datatype fol_literal = FOLLiteral of bool * combterm
  18.364 +
  18.365 +(*********************************************************************)
  18.366 +(* convert a clause with type Term.term to a clause with type clause *)
  18.367 +(*********************************************************************)
  18.368 +
  18.369 +(*Result of a function type; no need to check that the argument type matches.*)
  18.370 +fun result_type (CombType (_, [_, tp2])) = tp2
  18.371 +  | result_type _ = raise Fail "non-function type"
  18.372 +
  18.373 +fun combtyp_of (CombConst (_, tp, _)) = tp
  18.374 +  | combtyp_of (CombVar (_, tp)) = tp
  18.375 +  | combtyp_of (CombApp (t1, _)) = result_type (combtyp_of t1)
  18.376 +
  18.377 +(*gets the head of a combinator application, along with the list of arguments*)
  18.378 +fun strip_combterm_comb u =
  18.379 +    let fun stripc (CombApp(t,u), ts) = stripc (t, u::ts)
  18.380 +        |   stripc  x =  x
  18.381 +    in stripc(u,[]) end
  18.382 +
  18.383 +fun combtype_of (Type (a, Ts)) =
  18.384 +    let val (folTypes, ts) = combtypes_of Ts in
  18.385 +      (CombType (`make_fixed_type_const a, folTypes), ts)
  18.386 +    end
  18.387 +  | combtype_of (tp as TFree (a, _)) = (CombTFree (`make_fixed_type_var a), [tp])
  18.388 +  | combtype_of (tp as TVar (x, _)) =
  18.389 +    (CombTVar (make_schematic_type_var x, string_of_indexname x), [tp])
  18.390 +and combtypes_of Ts =
  18.391 +  let val (folTyps, ts) = ListPair.unzip (map combtype_of Ts) in
  18.392 +    (folTyps, union_all ts)
  18.393 +  end
  18.394 +
  18.395 +(* same as above, but no gathering of sort information *)
  18.396 +fun simple_combtype_of (Type (a, Ts)) =
  18.397 +    CombType (`make_fixed_type_const a, map simple_combtype_of Ts)
  18.398 +  | simple_combtype_of (TFree (a, _)) = CombTFree (`make_fixed_type_var a)
  18.399 +  | simple_combtype_of (TVar (x, _)) =
  18.400 +    CombTVar (make_schematic_type_var x, string_of_indexname x)
  18.401 +
  18.402 +fun new_skolem_const_name th_no s num_T_args =
  18.403 +  [new_skolem_const_prefix, string_of_int th_no, s, string_of_int num_T_args]
  18.404 +  |> space_implode Long_Name.separator
  18.405 +
  18.406 +(* Converts a term (with combinators) into a combterm. Also accummulates sort
  18.407 +   infomation. *)
  18.408 +fun combterm_from_term thy th_no bs (P $ Q) =
  18.409 +      let val (P', tsP) = combterm_from_term thy th_no bs P
  18.410 +          val (Q', tsQ) = combterm_from_term thy th_no bs Q
  18.411 +      in  (CombApp (P', Q'), union (op =) tsP tsQ)  end
  18.412 +  | combterm_from_term thy _ _ (Const (c, T)) =
  18.413 +      let
  18.414 +        val (tp, ts) = combtype_of T
  18.415 +        val tvar_list =
  18.416 +          (if String.isPrefix old_skolem_const_prefix c then
  18.417 +             [] |> Term.add_tvarsT T |> map TVar
  18.418 +           else
  18.419 +             (c, T) |> Sign.const_typargs thy)
  18.420 +          |> map simple_combtype_of
  18.421 +        val c' = CombConst (`make_fixed_const c, tp, tvar_list)
  18.422 +      in  (c',ts)  end
  18.423 +  | combterm_from_term _ _ _ (Free (v, T)) =
  18.424 +      let val (tp, ts) = combtype_of T
  18.425 +          val v' = CombConst (`make_fixed_var v, tp, [])
  18.426 +      in  (v',ts)  end
  18.427 +  | combterm_from_term _ th_no _ (Var (v as (s, _), T)) =
  18.428 +    let
  18.429 +      val (tp, ts) = combtype_of T
  18.430 +      val v' =
  18.431 +        if String.isPrefix Meson_Clausify.new_skolem_var_prefix s then
  18.432 +          let
  18.433 +            val tys = T |> strip_type |> swap |> op ::
  18.434 +            val s' = new_skolem_const_name th_no s (length tys)
  18.435 +          in
  18.436 +            CombConst (`make_fixed_const s', tp, map simple_combtype_of tys)
  18.437 +          end
  18.438 +        else
  18.439 +          CombVar ((make_schematic_var v, string_of_indexname v), tp)
  18.440 +    in (v', ts) end
  18.441 +  | combterm_from_term _ _ bs (Bound j) =
  18.442 +      let
  18.443 +        val (s, T) = nth bs j
  18.444 +        val (tp, ts) = combtype_of T
  18.445 +        val v' = CombConst (`make_bound_var s, tp, [])
  18.446 +      in (v', ts) end
  18.447 +  | combterm_from_term _ _ _ (Abs _) = raise Fail "HOL clause: Abs"
  18.448 +
  18.449 +fun predicate_of thy th_no ((@{const Not} $ P), pos) =
  18.450 +    predicate_of thy th_no (P, not pos)
  18.451 +  | predicate_of thy th_no (t, pos) =
  18.452 +    (combterm_from_term thy th_no [] (Envir.eta_contract t), pos)
  18.453 +
  18.454 +fun literals_of_term1 args thy th_no (@{const Trueprop} $ P) =
  18.455 +    literals_of_term1 args thy th_no P
  18.456 +  | literals_of_term1 args thy th_no (@{const HOL.disj} $ P $ Q) =
  18.457 +    literals_of_term1 (literals_of_term1 args thy th_no P) thy th_no Q
  18.458 +  | literals_of_term1 (lits, ts) thy th_no P =
  18.459 +    let val ((pred, ts'), pol) = predicate_of thy th_no (P, true) in
  18.460 +      (FOLLiteral (pol, pred) :: lits, union (op =) ts ts')
  18.461 +    end
  18.462 +val literals_of_term = literals_of_term1 ([], [])
  18.463 +
  18.464 +fun old_skolem_const_name i j num_T_args =
  18.465 +  old_skolem_const_prefix ^ Long_Name.separator ^
  18.466 +  (space_implode Long_Name.separator (map Int.toString [i, j, num_T_args]))
  18.467 +
  18.468 +fun conceal_old_skolem_terms i old_skolems t =
  18.469 +  if exists_Const (curry (op =) @{const_name Meson.skolem} o fst) t then
  18.470 +    let
  18.471 +      fun aux old_skolems
  18.472 +             (t as (Const (@{const_name Meson.skolem}, Type (_, [_, T])) $ _)) =
  18.473 +          let
  18.474 +            val (old_skolems, s) =
  18.475 +              if i = ~1 then
  18.476 +                (old_skolems, @{const_name undefined})
  18.477 +              else case AList.find (op aconv) old_skolems t of
  18.478 +                s :: _ => (old_skolems, s)
  18.479 +              | [] =>
  18.480 +                let
  18.481 +                  val s = old_skolem_const_name i (length old_skolems)
  18.482 +                                                (length (Term.add_tvarsT T []))
  18.483 +                in ((s, t) :: old_skolems, s) end
  18.484 +          in (old_skolems, Const (s, T)) end
  18.485 +        | aux old_skolems (t1 $ t2) =
  18.486 +          let
  18.487 +            val (old_skolems, t1) = aux old_skolems t1
  18.488 +            val (old_skolems, t2) = aux old_skolems t2
  18.489 +          in (old_skolems, t1 $ t2) end
  18.490 +        | aux old_skolems (Abs (s, T, t')) =
  18.491 +          let val (old_skolems, t') = aux old_skolems t' in
  18.492 +            (old_skolems, Abs (s, T, t'))
  18.493 +          end
  18.494 +        | aux old_skolems t = (old_skolems, t)
  18.495 +    in aux old_skolems t end
  18.496 +  else
  18.497 +    (old_skolems, t)
  18.498 +
  18.499 +fun reveal_old_skolem_terms old_skolems =
  18.500 +  map_aterms (fn t as Const (s, _) =>
  18.501 +                 if String.isPrefix old_skolem_const_prefix s then
  18.502 +                   AList.lookup (op =) old_skolems s |> the
  18.503 +                   |> map_types Type_Infer.paramify_vars
  18.504 +                 else
  18.505 +                   t
  18.506 +               | t => t)
  18.507 +
  18.508 +
  18.509 +(***************************************************************)
  18.510 +(* Type Classes Present in the Axiom or Conjecture Clauses     *)
  18.511 +(***************************************************************)
  18.512 +
  18.513 +fun set_insert (x, s) = Symtab.update (x, ()) s
  18.514 +
  18.515 +fun add_classes (sorts, cset) = List.foldl set_insert cset (flat sorts)
  18.516 +
  18.517 +(*Remove this trivial type class*)
  18.518 +fun delete_type cset = Symtab.delete_safe (the_single @{sort HOL.type}) cset;
  18.519 +
  18.520 +fun tfree_classes_of_terms ts =
  18.521 +  let val sorts_list = map (map #2 o OldTerm.term_tfrees) ts
  18.522 +  in  Symtab.keys (delete_type (List.foldl add_classes Symtab.empty sorts_list))  end;
  18.523 +
  18.524 +fun tvar_classes_of_terms ts =
  18.525 +  let val sorts_list = map (map #2 o OldTerm.term_tvars) ts
  18.526 +  in  Symtab.keys (delete_type (List.foldl add_classes Symtab.empty sorts_list))  end;
  18.527 +
  18.528 +(*fold type constructors*)
  18.529 +fun fold_type_consts f (Type (a, Ts)) x = fold (fold_type_consts f) Ts (f (a,x))
  18.530 +  | fold_type_consts _ _ x = x;
  18.531 +
  18.532 +(*Type constructors used to instantiate overloaded constants are the only ones needed.*)
  18.533 +fun add_type_consts_in_term thy =
  18.534 +  let
  18.535 +    fun aux (Const x) =
  18.536 +        fold (fold_type_consts set_insert) (Sign.const_typargs thy x)
  18.537 +      | aux (Abs (_, _, u)) = aux u
  18.538 +      | aux (Const (@{const_name Meson.skolem}, _) $ _) = I
  18.539 +      | aux (t $ u) = aux t #> aux u
  18.540 +      | aux _ = I
  18.541 +  in aux end
  18.542 +
  18.543 +fun type_consts_of_terms thy ts =
  18.544 +  Symtab.keys (fold (add_type_consts_in_term thy) ts Symtab.empty);
  18.545 +
  18.546 +(* ------------------------------------------------------------------------- *)
  18.547 +(* HOL to FOL  (Isabelle to Metis)                                           *)
  18.548 +(* ------------------------------------------------------------------------- *)
  18.549 +
  18.550 +datatype mode = FO | HO | FT  (* first-order, higher-order, fully-typed *)
  18.551 +
  18.552 +fun string_of_mode FO = "FO"
  18.553 +  | string_of_mode HO = "HO"
  18.554 +  | string_of_mode FT = "FT"
  18.555 +
  18.556 +fun fn_isa_to_met_sublevel "equal" = "=" (* FIXME: "c_fequal" *)
  18.557 +  | fn_isa_to_met_sublevel x = x
  18.558 +fun fn_isa_to_met_toplevel "equal" = "="
  18.559 +  | fn_isa_to_met_toplevel x = x
  18.560 +
  18.561 +fun metis_lit b c args = (b, (c, args));
  18.562 +
  18.563 +fun metis_term_from_combtyp (CombTVar (s, _)) = Metis_Term.Var s
  18.564 +  | metis_term_from_combtyp (CombTFree (s, _)) = Metis_Term.Fn (s, [])
  18.565 +  | metis_term_from_combtyp (CombType ((s, _), tps)) =
  18.566 +    Metis_Term.Fn (s, map metis_term_from_combtyp tps);
  18.567 +
  18.568 +(*These two functions insert type literals before the real literals. That is the
  18.569 +  opposite order from TPTP linkup, but maybe OK.*)
  18.570 +
  18.571 +fun hol_term_to_fol_FO tm =
  18.572 +  case strip_combterm_comb tm of
  18.573 +      (CombConst ((c, _), _, tys), tms) =>
  18.574 +        let val tyargs = map metis_term_from_combtyp tys
  18.575 +            val args   = map hol_term_to_fol_FO tms
  18.576 +        in Metis_Term.Fn (c, tyargs @ args) end
  18.577 +    | (CombVar ((v, _), _), []) => Metis_Term.Var v
  18.578 +    | _ => raise Fail "non-first-order combterm"
  18.579 +
  18.580 +fun hol_term_to_fol_HO (CombConst ((a, _), _, tylist)) =
  18.581 +      Metis_Term.Fn (fn_isa_to_met_sublevel a, map metis_term_from_combtyp tylist)
  18.582 +  | hol_term_to_fol_HO (CombVar ((s, _), _)) = Metis_Term.Var s
  18.583 +  | hol_term_to_fol_HO (CombApp (tm1, tm2)) =
  18.584 +       Metis_Term.Fn (".", map hol_term_to_fol_HO [tm1, tm2]);
  18.585 +
  18.586 +(*The fully-typed translation, to avoid type errors*)
  18.587 +fun wrap_type (tm, ty) =
  18.588 +  Metis_Term.Fn (type_wrapper_name, [tm, metis_term_from_combtyp ty])
  18.589 +
  18.590 +fun hol_term_to_fol_FT (CombVar ((s, _), ty)) = wrap_type (Metis_Term.Var s, ty)
  18.591 +  | hol_term_to_fol_FT (CombConst((a, _), ty, _)) =
  18.592 +      wrap_type (Metis_Term.Fn(fn_isa_to_met_sublevel a, []), ty)
  18.593 +  | hol_term_to_fol_FT (tm as CombApp(tm1,tm2)) =
  18.594 +       wrap_type (Metis_Term.Fn(".", map hol_term_to_fol_FT [tm1,tm2]),
  18.595 +                  combtyp_of tm)
  18.596 +
  18.597 +fun hol_literal_to_fol FO (FOLLiteral (pos, tm)) =
  18.598 +      let val (CombConst((p, _), _, tys), tms) = strip_combterm_comb tm
  18.599 +          val tylits = if p = "equal" then [] else map metis_term_from_combtyp tys
  18.600 +          val lits = map hol_term_to_fol_FO tms
  18.601 +      in metis_lit pos (fn_isa_to_met_toplevel p) (tylits @ lits) end
  18.602 +  | hol_literal_to_fol HO (FOLLiteral (pos, tm)) =
  18.603 +     (case strip_combterm_comb tm of
  18.604 +          (CombConst(("equal", _), _, _), tms) =>
  18.605 +            metis_lit pos "=" (map hol_term_to_fol_HO tms)
  18.606 +        | _ => metis_lit pos "{}" [hol_term_to_fol_HO tm])   (*hBOOL*)
  18.607 +  | hol_literal_to_fol FT (FOLLiteral (pos, tm)) =
  18.608 +     (case strip_combterm_comb tm of
  18.609 +          (CombConst(("equal", _), _, _), tms) =>
  18.610 +            metis_lit pos "=" (map hol_term_to_fol_FT tms)
  18.611 +        | _ => metis_lit pos "{}" [hol_term_to_fol_FT tm])   (*hBOOL*);
  18.612 +
  18.613 +fun literals_of_hol_term thy th_no mode t =
  18.614 +      let val (lits, types_sorts) = literals_of_term thy th_no t
  18.615 +      in  (map (hol_literal_to_fol mode) lits, types_sorts) end;
  18.616 +
  18.617 +(*Sign should be "true" for conjecture type constraints, "false" for type lits in clauses.*)
  18.618 +fun metis_of_type_literals pos (TyLitVar ((s, _), (s', _))) =
  18.619 +    metis_lit pos s [Metis_Term.Var s']
  18.620 +  | metis_of_type_literals pos (TyLitFree ((s, _), (s', _))) =
  18.621 +    metis_lit pos s [Metis_Term.Fn (s',[])]
  18.622 +
  18.623 +fun default_sort _ (TVar _) = false
  18.624 +  | default_sort ctxt (TFree (x, s)) = (s = the_default [] (Variable.def_sort ctxt (x, ~1)));
  18.625 +
  18.626 +fun metis_of_tfree tf =
  18.627 +  Metis_Thm.axiom (Metis_LiteralSet.singleton (metis_of_type_literals true tf));
  18.628 +
  18.629 +fun hol_thm_to_fol is_conjecture th_no ctxt type_lits mode j old_skolems th =
  18.630 +  let
  18.631 +    val thy = ProofContext.theory_of ctxt
  18.632 +    val (old_skolems, (mlits, types_sorts)) =
  18.633 +     th |> prop_of |> Logic.strip_imp_concl
  18.634 +        |> conceal_old_skolem_terms j old_skolems
  18.635 +        ||> (HOLogic.dest_Trueprop #> literals_of_hol_term thy th_no mode)
  18.636 +  in
  18.637 +    if is_conjecture then
  18.638 +      (Metis_Thm.axiom (Metis_LiteralSet.fromList mlits),
  18.639 +       type_literals_for_types types_sorts, old_skolems)
  18.640 +    else
  18.641 +      let
  18.642 +        val tylits = filter_out (default_sort ctxt) types_sorts
  18.643 +                     |> type_literals_for_types
  18.644 +        val mtylits =
  18.645 +          if type_lits then map (metis_of_type_literals false) tylits else []
  18.646 +      in
  18.647 +        (Metis_Thm.axiom (Metis_LiteralSet.fromList(mtylits @ mlits)), [],
  18.648 +         old_skolems)
  18.649 +      end
  18.650 +  end;
  18.651 +
  18.652 +val helpers =
  18.653 +  [("c_COMBI", (false, map (`I) @{thms Meson.COMBI_def})),
  18.654 +   ("c_COMBK", (false, map (`I) @{thms Meson.COMBK_def})),
  18.655 +   ("c_COMBB", (false, map (`I) @{thms Meson.COMBB_def})),
  18.656 +   ("c_COMBC", (false, map (`I) @{thms Meson.COMBC_def})),
  18.657 +   ("c_COMBS", (false, map (`I) @{thms Meson.COMBS_def})),
  18.658 +   ("c_fequal", (false, map (rpair @{thm equal_imp_equal})
  18.659 +                            @{thms fequal_imp_equal equal_imp_fequal})),
  18.660 +   ("c_True", (true, map (`I) @{thms True_or_False})),
  18.661 +   ("c_False", (true, map (`I) @{thms True_or_False})),
  18.662 +   ("c_If", (true, map (`I) @{thms if_True if_False True_or_False}))]
  18.663 +
  18.664 +(* ------------------------------------------------------------------------- *)
  18.665 +(* Logic maps manage the interface between HOL and first-order logic.        *)
  18.666 +(* ------------------------------------------------------------------------- *)
  18.667 +
  18.668 +type logic_map =
  18.669 +  {axioms: (Metis_Thm.thm * thm) list,
  18.670 +   tfrees: type_literal list,
  18.671 +   old_skolems: (string * term) list}
  18.672 +
  18.673 +fun is_quasi_fol_clause thy =
  18.674 +  Meson.is_fol_term thy o snd o conceal_old_skolem_terms ~1 [] o prop_of
  18.675 +
  18.676 +(*Extract TFree constraints from context to include as conjecture clauses*)
  18.677 +fun init_tfrees ctxt =
  18.678 +  let fun add ((a,i),s) Ts = if i = ~1 then TFree(a,s) :: Ts else Ts in
  18.679 +    Vartab.fold add (#2 (Variable.constraints_of ctxt)) []
  18.680 +    |> type_literals_for_types
  18.681 +  end;
  18.682 +
  18.683 +(*Insert non-logical axioms corresponding to all accumulated TFrees*)
  18.684 +fun add_tfrees {axioms, tfrees, old_skolems} : logic_map =
  18.685 +     {axioms = map (rpair TrueI o metis_of_tfree) (distinct (op =) tfrees) @
  18.686 +               axioms,
  18.687 +      tfrees = tfrees, old_skolems = old_skolems}
  18.688 +
  18.689 +(*transform isabelle type / arity clause to metis clause *)
  18.690 +fun add_type_thm [] lmap = lmap
  18.691 +  | add_type_thm ((ith, mth) :: cls) {axioms, tfrees, old_skolems} =
  18.692 +      add_type_thm cls {axioms = (mth, ith) :: axioms, tfrees = tfrees,
  18.693 +                        old_skolems = old_skolems}
  18.694 +
  18.695 +fun const_in_metis c (pred, tm_list) =
  18.696 +  let
  18.697 +    fun in_mterm (Metis_Term.Var _) = false
  18.698 +      | in_mterm (Metis_Term.Fn (".", tm_list)) = exists in_mterm tm_list
  18.699 +      | in_mterm (Metis_Term.Fn (nm, tm_list)) = c=nm orelse exists in_mterm tm_list
  18.700 +  in  c = pred orelse exists in_mterm tm_list  end;
  18.701 +
  18.702 +(* ARITY CLAUSE *)
  18.703 +fun m_arity_cls (TConsLit ((c, _), (t, _), args)) =
  18.704 +    metis_lit true c [Metis_Term.Fn(t, map (Metis_Term.Var o fst) args)]
  18.705 +  | m_arity_cls (TVarLit ((c, _), (s, _))) =
  18.706 +    metis_lit false c [Metis_Term.Var s]
  18.707 +(*TrueI is returned as the Isabelle counterpart because there isn't any.*)
  18.708 +fun arity_cls (ArityClause {conclLit, premLits, ...}) =
  18.709 +  (TrueI,
  18.710 +   Metis_Thm.axiom (Metis_LiteralSet.fromList (map m_arity_cls (conclLit :: premLits))));
  18.711 +
  18.712 +(* CLASSREL CLAUSE *)
  18.713 +fun m_class_rel_cls (subclass, _) (superclass, _) =
  18.714 +  [metis_lit false subclass [Metis_Term.Var "T"], metis_lit true superclass [Metis_Term.Var "T"]];
  18.715 +fun class_rel_cls (ClassRelClause {subclass, superclass, ...}) =
  18.716 +  (TrueI, Metis_Thm.axiom (Metis_LiteralSet.fromList (m_class_rel_cls subclass superclass)));
  18.717 +
  18.718 +fun type_ext thy tms =
  18.719 +  let val subs = tfree_classes_of_terms tms
  18.720 +      val supers = tvar_classes_of_terms tms
  18.721 +      and tycons = type_consts_of_terms thy tms
  18.722 +      val (supers', arity_clauses) = make_arity_clauses thy tycons supers
  18.723 +      val class_rel_clauses = make_class_rel_clauses thy subs supers'
  18.724 +  in  map class_rel_cls class_rel_clauses @ map arity_cls arity_clauses
  18.725 +  end;
  18.726 +
  18.727 +(* Function to generate metis clauses, including comb and type clauses *)
  18.728 +fun build_logic_map mode0 ctxt type_lits cls thss =
  18.729 +  let val thy = ProofContext.theory_of ctxt
  18.730 +      (*The modes FO and FT are sticky. HO can be downgraded to FO.*)
  18.731 +      fun set_mode FO = FO
  18.732 +        | set_mode HO =
  18.733 +          if forall (forall (is_quasi_fol_clause thy)) (cls :: thss) then FO
  18.734 +          else HO
  18.735 +        | set_mode FT = FT
  18.736 +      val mode = set_mode mode0
  18.737 +      (*transform isabelle clause to metis clause *)
  18.738 +      fun add_thm th_no is_conjecture (metis_ith, isa_ith)
  18.739 +                  {axioms, tfrees, old_skolems} : logic_map =
  18.740 +        let
  18.741 +          val (mth, tfree_lits, old_skolems) =
  18.742 +            hol_thm_to_fol is_conjecture th_no ctxt type_lits mode (length axioms)
  18.743 +                           old_skolems metis_ith
  18.744 +        in
  18.745 +           {axioms = (mth, Meson.make_meta_clause isa_ith) :: axioms,
  18.746 +            tfrees = union (op =) tfree_lits tfrees, old_skolems = old_skolems}
  18.747 +        end;
  18.748 +      val lmap = {axioms = [], tfrees = init_tfrees ctxt, old_skolems = []}
  18.749 +                 |> fold (add_thm 0 true o `I) cls
  18.750 +                 |> add_tfrees
  18.751 +                 |> fold (fn (th_no, ths) => fold (add_thm th_no false o `I) ths)
  18.752 +                         (1 upto length thss ~~ thss)
  18.753 +      val clause_lists = map (Metis_Thm.clause o #1) (#axioms lmap)
  18.754 +      fun is_used c =
  18.755 +        exists (Metis_LiteralSet.exists (const_in_metis c o #2)) clause_lists
  18.756 +      val lmap =
  18.757 +        if mode = FO then
  18.758 +          lmap
  18.759 +        else
  18.760 +          let
  18.761 +            val helper_ths =
  18.762 +              helpers |> filter (is_used o fst)
  18.763 +                      |> maps (fn (c, (needs_full_types, thms)) =>
  18.764 +                                  if not (is_used c) orelse
  18.765 +                                     needs_full_types andalso mode <> FT then
  18.766 +                                    []
  18.767 +                                  else
  18.768 +                                    thms)
  18.769 +          in lmap |> fold (add_thm ~1 false) helper_ths end
  18.770 +  in
  18.771 +    (mode, add_type_thm (type_ext thy (maps (map prop_of) (cls :: thss))) lmap)
  18.772 +  end
  18.773 +
  18.774 +end;
    19.1 --- a/src/HOL/Tools/Sledgehammer/meson_clausify.ML	Wed Oct 06 13:48:12 2010 +0200
    19.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    19.3 @@ -1,394 +0,0 @@
    19.4 -(*  Title:      HOL/Tools/Sledgehammer/meson_clausify.ML
    19.5 -    Author:     Jia Meng, Cambridge University Computer Laboratory and NICTA
    19.6 -    Author:     Jasmin Blanchette, TU Muenchen
    19.7 -
    19.8 -Transformation of axiom rules (elim/intro/etc) into CNF forms.
    19.9 -*)
   19.10 -
   19.11 -signature MESON_CLAUSIFY =
   19.12 -sig
   19.13 -  val new_skolem_var_prefix : string
   19.14 -  val extensionalize_theorem : thm -> thm
   19.15 -  val introduce_combinators_in_cterm : cterm -> thm
   19.16 -  val introduce_combinators_in_theorem : thm -> thm
   19.17 -  val to_definitional_cnf_with_quantifiers : theory -> thm -> thm
   19.18 -  val cluster_of_zapped_var_name : string -> (int * int) * bool
   19.19 -  val cnf_axiom :
   19.20 -    Proof.context -> bool -> int -> thm -> (thm * term) option * thm list
   19.21 -  val meson_general_tac : Proof.context -> thm list -> int -> tactic
   19.22 -  val setup: theory -> theory
   19.23 -end;
   19.24 -
   19.25 -structure Meson_Clausify : MESON_CLAUSIFY =
   19.26 -struct
   19.27 -
   19.28 -(* the extra "?" helps prevent clashes *)
   19.29 -val new_skolem_var_prefix = "?SK"
   19.30 -val new_nonskolem_var_prefix = "?V"
   19.31 -
   19.32 -(**** Transformation of Elimination Rules into First-Order Formulas****)
   19.33 -
   19.34 -val cfalse = cterm_of @{theory HOL} HOLogic.false_const;
   19.35 -val ctp_false = cterm_of @{theory HOL} (HOLogic.mk_Trueprop HOLogic.false_const);
   19.36 -
   19.37 -(* Converts an elim-rule into an equivalent theorem that does not have the
   19.38 -   predicate variable. Leaves other theorems unchanged. We simply instantiate
   19.39 -   the conclusion variable to False. (Cf. "transform_elim_term" in
   19.40 -   "Sledgehammer_Util".) *)
   19.41 -fun transform_elim_theorem th =
   19.42 -  case concl_of th of    (*conclusion variable*)
   19.43 -       @{const Trueprop} $ (v as Var (_, @{typ bool})) =>
   19.44 -           Thm.instantiate ([], [(cterm_of @{theory HOL} v, cfalse)]) th
   19.45 -    | v as Var(_, @{typ prop}) =>
   19.46 -           Thm.instantiate ([], [(cterm_of @{theory HOL} v, ctp_false)]) th
   19.47 -    | _ => th
   19.48 -
   19.49 -
   19.50 -(**** SKOLEMIZATION BY INFERENCE (lcp) ****)
   19.51 -
   19.52 -fun mk_old_skolem_term_wrapper t =
   19.53 -  let val T = fastype_of t in
   19.54 -    Const (@{const_name skolem}, T --> T) $ t
   19.55 -  end
   19.56 -
   19.57 -fun beta_eta_under_lambdas (Abs (s, T, t')) =
   19.58 -    Abs (s, T, beta_eta_under_lambdas t')
   19.59 -  | beta_eta_under_lambdas t = Envir.beta_eta_contract t
   19.60 -
   19.61 -(*Traverse a theorem, accumulating Skolem function definitions.*)
   19.62 -fun old_skolem_defs th =
   19.63 -  let
   19.64 -    fun dec_sko (Const (@{const_name Ex}, _) $ (body as Abs (_, T, p))) rhss =
   19.65 -        (*Existential: declare a Skolem function, then insert into body and continue*)
   19.66 -        let
   19.67 -          val args = OldTerm.term_frees body
   19.68 -          (* Forms a lambda-abstraction over the formal parameters *)
   19.69 -          val rhs =
   19.70 -            list_abs_free (map dest_Free args,
   19.71 -                           HOLogic.choice_const T $ beta_eta_under_lambdas body)
   19.72 -            |> mk_old_skolem_term_wrapper
   19.73 -          val comb = list_comb (rhs, args)
   19.74 -        in dec_sko (subst_bound (comb, p)) (rhs :: rhss) end
   19.75 -      | dec_sko (Const (@{const_name All},_) $ Abs (a, T, p)) rhss =
   19.76 -        (*Universal quant: insert a free variable into body and continue*)
   19.77 -        let val fname = Name.variant (OldTerm.add_term_names (p,[])) a
   19.78 -        in dec_sko (subst_bound (Free(fname,T), p)) rhss end
   19.79 -      | dec_sko (@{const conj} $ p $ q) rhss = rhss |> dec_sko p |> dec_sko q
   19.80 -      | dec_sko (@{const disj} $ p $ q) rhss = rhss |> dec_sko p |> dec_sko q
   19.81 -      | dec_sko (@{const Trueprop} $ p) rhss = dec_sko p rhss
   19.82 -      | dec_sko _ rhss = rhss
   19.83 -  in  dec_sko (prop_of th) []  end;
   19.84 -
   19.85 -
   19.86 -(**** REPLACING ABSTRACTIONS BY COMBINATORS ****)
   19.87 -
   19.88 -val fun_cong_all = @{thm fun_eq_iff [THEN iffD1]}
   19.89 -
   19.90 -(* Removes the lambdas from an equation of the form "t = (%x. u)".
   19.91 -   (Cf. "extensionalize_term" in "Sledgehammer_Translate".) *)
   19.92 -fun extensionalize_theorem th =
   19.93 -  case prop_of th of
   19.94 -    _ $ (Const (@{const_name HOL.eq}, Type (_, [Type (@{type_name fun}, _), _]))
   19.95 -         $ _ $ Abs _) => extensionalize_theorem (th RS fun_cong_all)
   19.96 -  | _ => th
   19.97 -
   19.98 -fun is_quasi_lambda_free (Const (@{const_name skolem}, _) $ _) = true
   19.99 -  | is_quasi_lambda_free (t1 $ t2) =
  19.100 -    is_quasi_lambda_free t1 andalso is_quasi_lambda_free t2
  19.101 -  | is_quasi_lambda_free (Abs _) = false
  19.102 -  | is_quasi_lambda_free _ = true
  19.103 -
  19.104 -val [f_B,g_B] = map (cterm_of @{theory}) (OldTerm.term_vars (prop_of @{thm abs_B}));
  19.105 -val [g_C,f_C] = map (cterm_of @{theory}) (OldTerm.term_vars (prop_of @{thm abs_C}));
  19.106 -val [f_S,g_S] = map (cterm_of @{theory}) (OldTerm.term_vars (prop_of @{thm abs_S}));
  19.107 -
  19.108 -(* FIXME: Requires more use of cterm constructors. *)
  19.109 -fun abstract ct =
  19.110 -  let
  19.111 -      val thy = theory_of_cterm ct
  19.112 -      val Abs(x,_,body) = term_of ct
  19.113 -      val Type(@{type_name fun}, [xT,bodyT]) = typ_of (ctyp_of_term ct)
  19.114 -      val cxT = ctyp_of thy xT
  19.115 -      val cbodyT = ctyp_of thy bodyT
  19.116 -      fun makeK () =
  19.117 -        instantiate' [SOME cxT, SOME cbodyT] [SOME (cterm_of thy body)]
  19.118 -                     @{thm abs_K}
  19.119 -  in
  19.120 -      case body of
  19.121 -          Const _ => makeK()
  19.122 -        | Free _ => makeK()
  19.123 -        | Var _ => makeK()  (*though Var isn't expected*)
  19.124 -        | Bound 0 => instantiate' [SOME cxT] [] @{thm abs_I} (*identity: I*)
  19.125 -        | rator$rand =>
  19.126 -            if loose_bvar1 (rator,0) then (*C or S*)
  19.127 -               if loose_bvar1 (rand,0) then (*S*)
  19.128 -                 let val crator = cterm_of thy (Abs(x,xT,rator))
  19.129 -                     val crand = cterm_of thy (Abs(x,xT,rand))
  19.130 -                     val abs_S' = cterm_instantiate [(f_S,crator),(g_S,crand)] @{thm abs_S}
  19.131 -                     val (_,rhs) = Thm.dest_equals (cprop_of abs_S')
  19.132 -                 in
  19.133 -                   Thm.transitive abs_S' (Conv.binop_conv abstract rhs)
  19.134 -                 end
  19.135 -               else (*C*)
  19.136 -                 let val crator = cterm_of thy (Abs(x,xT,rator))
  19.137 -                     val abs_C' = cterm_instantiate [(f_C,crator),(g_C,cterm_of thy rand)] @{thm abs_C}
  19.138 -                     val (_,rhs) = Thm.dest_equals (cprop_of abs_C')
  19.139 -                 in
  19.140 -                   Thm.transitive abs_C' (Conv.fun_conv (Conv.arg_conv abstract) rhs)
  19.141 -                 end
  19.142 -            else if loose_bvar1 (rand,0) then (*B or eta*)
  19.143 -               if rand = Bound 0 then Thm.eta_conversion ct
  19.144 -               else (*B*)
  19.145 -                 let val crand = cterm_of thy (Abs(x,xT,rand))
  19.146 -                     val crator = cterm_of thy rator
  19.147 -                     val abs_B' = cterm_instantiate [(f_B,crator),(g_B,crand)] @{thm abs_B}
  19.148 -                     val (_,rhs) = Thm.dest_equals (cprop_of abs_B')
  19.149 -                 in Thm.transitive abs_B' (Conv.arg_conv abstract rhs) end
  19.150 -            else makeK()
  19.151 -        | _ => raise Fail "abstract: Bad term"
  19.152 -  end;
  19.153 -
  19.154 -(* Traverse a theorem, remplacing lambda-abstractions with combinators. *)
  19.155 -fun introduce_combinators_in_cterm ct =
  19.156 -  if is_quasi_lambda_free (term_of ct) then
  19.157 -    Thm.reflexive ct
  19.158 -  else case term_of ct of
  19.159 -    Abs _ =>
  19.160 -    let
  19.161 -      val (cv, cta) = Thm.dest_abs NONE ct
  19.162 -      val (v, _) = dest_Free (term_of cv)
  19.163 -      val u_th = introduce_combinators_in_cterm cta
  19.164 -      val cu = Thm.rhs_of u_th
  19.165 -      val comb_eq = abstract (Thm.cabs cv cu)
  19.166 -    in Thm.transitive (Thm.abstract_rule v cv u_th) comb_eq end
  19.167 -  | _ $ _ =>
  19.168 -    let val (ct1, ct2) = Thm.dest_comb ct in
  19.169 -        Thm.combination (introduce_combinators_in_cterm ct1)
  19.170 -                        (introduce_combinators_in_cterm ct2)
  19.171 -    end
  19.172 -
  19.173 -fun introduce_combinators_in_theorem th =
  19.174 -  if is_quasi_lambda_free (prop_of th) then
  19.175 -    th
  19.176 -  else
  19.177 -    let
  19.178 -      val th = Drule.eta_contraction_rule th
  19.179 -      val eqth = introduce_combinators_in_cterm (cprop_of th)
  19.180 -    in Thm.equal_elim eqth th end
  19.181 -    handle THM (msg, _, _) =>
  19.182 -           (warning ("Error in the combinator translation of " ^
  19.183 -                     Display.string_of_thm_without_context th ^
  19.184 -                     "\nException message: " ^ msg ^ ".");
  19.185 -            (* A type variable of sort "{}" will make abstraction fail. *)
  19.186 -            TrueI)
  19.187 -
  19.188 -(*cterms are used throughout for efficiency*)
  19.189 -val cTrueprop = cterm_of @{theory HOL} HOLogic.Trueprop;
  19.190 -
  19.191 -(*Given an abstraction over n variables, replace the bound variables by free
  19.192 -  ones. Return the body, along with the list of free variables.*)
  19.193 -fun c_variant_abs_multi (ct0, vars) =
  19.194 -      let val (cv,ct) = Thm.dest_abs NONE ct0
  19.195 -      in  c_variant_abs_multi (ct, cv::vars)  end
  19.196 -      handle CTERM _ => (ct0, rev vars);
  19.197 -
  19.198 -val skolem_def_raw = @{thms skolem_def_raw}
  19.199 -
  19.200 -(* Given the definition of a Skolem function, return a theorem to replace
  19.201 -   an existential formula by a use of that function.
  19.202 -   Example: "EX x. x : A & x ~: B ==> sko A B : A & sko A B ~: B"  [.] *)
  19.203 -fun old_skolem_theorem_from_def thy rhs0 =
  19.204 -  let
  19.205 -    val rhs = rhs0 |> Type.legacy_freeze_thaw |> #1 |> cterm_of thy
  19.206 -    val rhs' = rhs |> Thm.dest_comb |> snd
  19.207 -    val (ch, frees) = c_variant_abs_multi (rhs', [])
  19.208 -    val (hilbert, cabs) = ch |> Thm.dest_comb |>> term_of
  19.209 -    val T =
  19.210 -      case hilbert of
  19.211 -        Const (@{const_name Eps}, Type (@{type_name fun}, [_, T])) => T
  19.212 -      | _ => raise TERM ("old_skolem_theorem_from_def: expected \"Eps\"",
  19.213 -                         [hilbert])
  19.214 -    val cex = cterm_of thy (HOLogic.exists_const T)
  19.215 -    val ex_tm = Thm.capply cTrueprop (Thm.capply cex cabs)
  19.216 -    val conc =
  19.217 -      Drule.list_comb (rhs, frees)
  19.218 -      |> Drule.beta_conv cabs |> Thm.capply cTrueprop
  19.219 -    fun tacf [prem] =
  19.220 -      rewrite_goals_tac skolem_def_raw
  19.221 -      THEN rtac ((prem |> rewrite_rule skolem_def_raw) RS @{thm someI_ex}) 1
  19.222 -  in
  19.223 -    Goal.prove_internal [ex_tm] conc tacf
  19.224 -    |> forall_intr_list frees
  19.225 -    |> Thm.forall_elim_vars 0  (*Introduce Vars, but don't discharge defs.*)
  19.226 -    |> Thm.varifyT_global
  19.227 -  end
  19.228 -
  19.229 -fun to_definitional_cnf_with_quantifiers thy th =
  19.230 -  let
  19.231 -    val eqth = cnf.make_cnfx_thm thy (HOLogic.dest_Trueprop (prop_of th))
  19.232 -    val eqth = eqth RS @{thm eq_reflection}
  19.233 -    val eqth = eqth RS @{thm TruepropI}
  19.234 -  in Thm.equal_elim eqth th end
  19.235 -
  19.236 -fun zapped_var_name ax_no (cluster_no, skolem) s =
  19.237 -  (if skolem then new_skolem_var_prefix else new_nonskolem_var_prefix) ^
  19.238 -  "_" ^ string_of_int ax_no ^ "_" ^ string_of_int cluster_no ^ "_" ^ s
  19.239 -
  19.240 -fun cluster_of_zapped_var_name s =
  19.241 -  ((1, 2) |> pairself (the o Int.fromString o nth (space_explode "_" s)),
  19.242 -   String.isPrefix new_skolem_var_prefix s)
  19.243 -
  19.244 -fun rename_vars_to_be_zapped ax_no =
  19.245 -  let
  19.246 -    fun aux (cluster as (cluster_no, cluster_skolem)) pos t =
  19.247 -      case t of
  19.248 -        (t1 as Const (s, _)) $ Abs (s', T, t') =>
  19.249 -        if s = @{const_name all} orelse s = @{const_name All} orelse
  19.250 -           s = @{const_name Ex} then
  19.251 -          let
  19.252 -            val skolem = (pos = (s = @{const_name Ex}))
  19.253 -            val cluster =
  19.254 -              if skolem = cluster_skolem then cluster
  19.255 -              else (cluster_no |> cluster_skolem ? Integer.add 1, skolem)
  19.256 -            val s' = zapped_var_name ax_no cluster s'
  19.257 -          in t1 $ Abs (s', T, aux cluster pos t') end
  19.258 -        else
  19.259 -          t
  19.260 -      | (t1 as Const (s, _)) $ t2 $ t3 =>
  19.261 -        if s = @{const_name "==>"} orelse s = @{const_name implies} then
  19.262 -          t1 $ aux cluster (not pos) t2 $ aux cluster pos t3
  19.263 -        else if s = @{const_name conj} orelse s = @{const_name disj} then
  19.264 -          t1 $ aux cluster pos t2 $ aux cluster pos t3
  19.265 -        else
  19.266 -          t
  19.267 -      | (t1 as Const (s, _)) $ t2 =>
  19.268 -        if s = @{const_name Trueprop} then t1 $ aux cluster pos t2
  19.269 -        else if s = @{const_name Not} then t1 $ aux cluster (not pos) t2
  19.270 -        else t
  19.271 -      | _ => t
  19.272 -  in aux (0, true) true end
  19.273 -
  19.274 -fun zap pos ct =
  19.275 -  ct
  19.276 -  |> (case term_of ct of
  19.277 -        Const (s, _) $ Abs (s', _, _) =>
  19.278 -        if s = @{const_name all} orelse s = @{const_name All} orelse
  19.279 -           s = @{const_name Ex} then
  19.280 -          Thm.dest_comb #> snd #> Thm.dest_abs (SOME s') #> snd #> zap pos
  19.281 -        else
  19.282 -          Conv.all_conv
  19.283 -      | Const (s, _) $ _ $ _ =>
  19.284 -        if s = @{const_name "==>"} orelse s = @{const_name implies} then
  19.285 -          Conv.combination_conv (Conv.arg_conv (zap (not pos))) (zap pos)
  19.286 -        else if s = @{const_name conj} orelse s = @{const_name disj} then
  19.287 -          Conv.combination_conv (Conv.arg_conv (zap pos)) (zap pos)
  19.288 -        else
  19.289 -          Conv.all_conv
  19.290 -      | Const (s, _) $ _ =>
  19.291 -        if s = @{const_name Trueprop} then Conv.arg_conv (zap pos)
  19.292 -        else if s = @{const_name Not} then Conv.arg_conv (zap (not pos))
  19.293 -        else Conv.all_conv
  19.294 -      | _ => Conv.all_conv)
  19.295 -
  19.296 -fun ss_only ths = MetaSimplifier.clear_ss HOL_basic_ss addsimps ths
  19.297 -
  19.298 -val no_choice =
  19.299 -  @{prop "ALL x. EX y. Q x y ==> EX f. ALL x. Q x (f x)"}
  19.300 -  |> Logic.varify_global
  19.301 -  |> Skip_Proof.make_thm @{theory}
  19.302 -
  19.303 -(* Converts an Isabelle theorem into NNF. *)
  19.304 -fun nnf_axiom choice_ths new_skolemizer ax_no th ctxt =
  19.305 -  let
  19.306 -    val thy = ProofContext.theory_of ctxt
  19.307 -    val th =
  19.308 -      th |> transform_elim_theorem
  19.309 -         |> zero_var_indexes
  19.310 -         |> new_skolemizer ? forall_intr_vars
  19.311 -    val (th, ctxt) = Variable.import true [th] ctxt |>> snd |>> the_single
  19.312 -    val th = th |> Conv.fconv_rule Object_Logic.atomize
  19.313 -                |> extensionalize_theorem
  19.314 -                |> Meson.make_nnf ctxt
  19.315 -  in
  19.316 -    if new_skolemizer then
  19.317 -      let
  19.318 -        fun rename_bound_vars th =
  19.319 -          let val t = concl_of th in
  19.320 -            th |> Thm.rename_boundvars t (rename_vars_to_be_zapped ax_no t)
  19.321 -          end
  19.322 -        fun skolemize choice_ths =
  19.323 -          Meson.skolemize_with_choice_thms ctxt choice_ths
  19.324 -          #> simplify (ss_only @{thms all_simps[symmetric]})
  19.325 -        val pull_out =
  19.326 -          simplify (ss_only @{thms all_simps[symmetric] ex_simps[symmetric]})
  19.327 -        val (discharger_th, fully_skolemized_th) =
  19.328 -          if null choice_ths then
  19.329 -            th |> rename_bound_vars |> `I |>> pull_out ||> skolemize [no_choice]
  19.330 -          else
  19.331 -            th |> skolemize choice_ths |> rename_bound_vars |> `I
  19.332 -        val t =
  19.333 -          fully_skolemized_th |> cprop_of
  19.334 -          |> zap true |> Drule.export_without_context
  19.335 -          |> cprop_of |> Thm.dest_equals |> snd |> term_of
  19.336 -      in
  19.337 -        if exists_subterm (fn Var ((s, _), _) =>
  19.338 -                              String.isPrefix new_skolem_var_prefix s
  19.339 -                            | _ => false) t then
  19.340 -          let
  19.341 -            val (ct, ctxt) =
  19.342 -              Variable.import_terms true [t] ctxt
  19.343 -              |>> the_single |>> cterm_of thy
  19.344 -          in (SOME (discharger_th, ct), Thm.assume ct, ctxt) end
  19.345 -       else
  19.346 -         (NONE, th, ctxt)
  19.347 -      end
  19.348 -    else
  19.349 -      (NONE, th, ctxt)
  19.350 -  end
  19.351 -
  19.352 -(* Convert a theorem to CNF, with additional premises due to skolemization. *)
  19.353 -fun cnf_axiom ctxt0 new_skolemizer ax_no th =
  19.354 -  let
  19.355 -    val thy = ProofContext.theory_of ctxt0
  19.356 -    val choice_ths = Meson_Choices.get ctxt0
  19.357 -    val (opt, nnf_th, ctxt) = nnf_axiom choice_ths new_skolemizer ax_no th ctxt0
  19.358 -    fun clausify th =
  19.359 -      Meson.make_cnf (if new_skolemizer then
  19.360 -                        []
  19.361 -                      else
  19.362 -                        map (old_skolem_theorem_from_def thy)
  19.363 -                            (old_skolem_defs th)) th ctxt
  19.364 -    val (cnf_ths, ctxt) =
  19.365 -      clausify nnf_th
  19.366 -      |> (fn ([], _) =>
  19.367 -             clausify (to_definitional_cnf_with_quantifiers thy nnf_th)
  19.368 -           | p => p)
  19.369 -    fun intr_imp ct th =
  19.370 -      Thm.instantiate ([], map (pairself (cterm_of @{theory}))
  19.371 -                               [(Var (("i", 1), @{typ nat}),
  19.372 -                                 HOLogic.mk_nat ax_no)])
  19.373 -                      @{thm skolem_COMBK_D}
  19.374 -      RS Thm.implies_intr ct th
  19.375 -  in
  19.376 -    (opt |> Option.map (I #>> singleton (Variable.export ctxt ctxt0)
  19.377 -                        ##> (term_of #> HOLogic.dest_Trueprop
  19.378 -                             #> singleton (Variable.export_terms ctxt ctxt0))),
  19.379 -     cnf_ths |> map (introduce_combinators_in_theorem
  19.380 -                     #> (case opt of SOME (_, ct) => intr_imp ct | NONE => I))
  19.381 -             |> Variable.export ctxt ctxt0
  19.382 -             |> Meson.finish_cnf
  19.383 -             |> map Thm.close_derivation)
  19.384 -  end
  19.385 -  handle THM _ => (NONE, [])
  19.386 -
  19.387 -fun meson_general_tac ctxt ths =
  19.388 -  let val ctxt = Classical.put_claset HOL_cs ctxt in
  19.389 -    Meson.meson_tac ctxt (maps (snd o cnf_axiom ctxt false 0) ths)
  19.390 -  end
  19.391 -
  19.392 -val setup =
  19.393 -  Method.setup @{binding meson} (Attrib.thms >> (fn ths => fn ctxt =>
  19.394 -     SIMPLE_METHOD' (CHANGED_PROP o meson_general_tac ctxt ths)))
  19.395 -     "MESON resolution proof procedure"
  19.396 -
  19.397 -end;
    20.1 --- a/src/HOL/Tools/Sledgehammer/metis_reconstruct.ML	Wed Oct 06 13:48:12 2010 +0200
    20.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    20.3 @@ -1,555 +0,0 @@
    20.4 -(*  Title:      HOL/Tools/Sledgehammer/metis_reconstruct.ML
    20.5 -    Author:     Kong W. Susanto, Cambridge University Computer Laboratory
    20.6 -    Author:     Lawrence C. Paulson, Cambridge University Computer Laboratory
    20.7 -    Author:     Jasmin Blanchette, TU Muenchen
    20.8 -    Copyright   Cambridge University 2007
    20.9 -
   20.10 -Proof reconstruction for Metis.
   20.11 -*)
   20.12 -
   20.13 -signature METIS_RECONSTRUCT =
   20.14 -sig
   20.15 -  type mode = Metis_Translate.mode
   20.16 -
   20.17 -  val trace : bool Unsynchronized.ref
   20.18 -  val lookth : (Metis_Thm.thm * 'a) list -> Metis_Thm.thm -> 'a
   20.19 -  val untyped_aconv : term -> term -> bool
   20.20 -  val replay_one_inference :
   20.21 -    Proof.context -> mode -> (string * term) list
   20.22 -    -> Metis_Thm.thm * Metis_Proof.inference -> (Metis_Thm.thm * thm) list
   20.23 -    -> (Metis_Thm.thm * thm) list
   20.24 -end;
   20.25 -
   20.26 -structure Metis_Reconstruct : METIS_RECONSTRUCT =
   20.27 -struct
   20.28 -
   20.29 -open Metis_Translate
   20.30 -
   20.31 -val trace = Unsynchronized.ref false
   20.32 -fun trace_msg msg = if !trace then tracing (msg ()) else ()
   20.33 -
   20.34 -datatype term_or_type = SomeTerm of term | SomeType of typ
   20.35 -
   20.36 -fun terms_of [] = []
   20.37 -  | terms_of (SomeTerm t :: tts) = t :: terms_of tts
   20.38 -  | terms_of (SomeType _ :: tts) = terms_of tts;
   20.39 -
   20.40 -fun types_of [] = []
   20.41 -  | types_of (SomeTerm (Var ((a,idx), _)) :: tts) =
   20.42 -      if String.isPrefix "_" a then
   20.43 -          (*Variable generated by Metis, which might have been a type variable.*)
   20.44 -          TVar (("'" ^ a, idx), HOLogic.typeS) :: types_of tts
   20.45 -      else types_of tts
   20.46 -  | types_of (SomeTerm _ :: tts) = types_of tts
   20.47 -  | types_of (SomeType T :: tts) = T :: types_of tts;
   20.48 -
   20.49 -fun apply_list rator nargs rands =
   20.50 -  let val trands = terms_of rands
   20.51 -  in  if length trands = nargs then SomeTerm (list_comb(rator, trands))
   20.52 -      else raise Fail
   20.53 -        ("apply_list: wrong number of arguments: " ^ Syntax.string_of_term_global Pure.thy rator ^
   20.54 -          " expected " ^ Int.toString nargs ^
   20.55 -          " received " ^ commas (map (Syntax.string_of_term_global Pure.thy) trands))
   20.56 -  end;
   20.57 -
   20.58 -fun infer_types ctxt =
   20.59 -  Syntax.check_terms (ProofContext.set_mode ProofContext.mode_pattern ctxt);
   20.60 -
   20.61 -(*We use 1 rather than 0 because variable references in clauses may otherwise conflict
   20.62 -  with variable constraints in the goal...at least, type inference often fails otherwise.
   20.63 -  SEE ALSO axiom_inf below.*)
   20.64 -fun mk_var (w, T) = Var ((w, 1), T)
   20.65 -
   20.66 -(*include the default sort, if available*)
   20.67 -fun mk_tfree ctxt w =
   20.68 -  let val ww = "'" ^ w
   20.69 -  in  TFree(ww, the_default HOLogic.typeS (Variable.def_sort ctxt (ww, ~1)))  end;
   20.70 -
   20.71 -(*Remove the "apply" operator from an HO term*)
   20.72 -fun strip_happ args (Metis_Term.Fn(".",[t,u])) = strip_happ (u::args) t
   20.73 -  | strip_happ args x = (x, args);
   20.74 -
   20.75 -fun make_tvar s = TVar (("'" ^ s, 0), HOLogic.typeS)
   20.76 -
   20.77 -fun smart_invert_const "fequal" = @{const_name HOL.eq}
   20.78 -  | smart_invert_const s = invert_const s
   20.79 -
   20.80 -fun hol_type_from_metis_term _ (Metis_Term.Var v) =
   20.81 -     (case strip_prefix_and_unascii tvar_prefix v of
   20.82 -          SOME w => make_tvar w
   20.83 -        | NONE   => make_tvar v)
   20.84 -  | hol_type_from_metis_term ctxt (Metis_Term.Fn(x, tys)) =
   20.85 -     (case strip_prefix_and_unascii type_const_prefix x of
   20.86 -          SOME tc => Type (smart_invert_const tc,
   20.87 -                           map (hol_type_from_metis_term ctxt) tys)
   20.88 -        | NONE    =>
   20.89 -      case strip_prefix_and_unascii tfree_prefix x of
   20.90 -          SOME tf => mk_tfree ctxt tf
   20.91 -        | NONE    => raise Fail ("hol_type_from_metis_term: " ^ x));
   20.92 -
   20.93 -(*Maps metis terms to isabelle terms*)
   20.94 -fun hol_term_from_metis_PT ctxt fol_tm =
   20.95 -  let val thy = ProofContext.theory_of ctxt
   20.96 -      val _ = trace_msg (fn () => "hol_term_from_metis_PT: " ^
   20.97 -                                  Metis_Term.toString fol_tm)
   20.98 -      fun tm_to_tt (Metis_Term.Var v) =
   20.99 -             (case strip_prefix_and_unascii tvar_prefix v of
  20.100 -                  SOME w => SomeType (make_tvar w)
  20.101 -                | NONE =>
  20.102 -              case strip_prefix_and_unascii schematic_var_prefix v of
  20.103 -                  SOME w => SomeTerm (mk_var (w, HOLogic.typeT))
  20.104 -                | NONE   => SomeTerm (mk_var (v, HOLogic.typeT)) )
  20.105 -                    (*Var from Metis with a name like _nnn; possibly a type variable*)
  20.106 -        | tm_to_tt (Metis_Term.Fn ("{}", [arg])) = tm_to_tt arg   (*hBOOL*)
  20.107 -        | tm_to_tt (t as Metis_Term.Fn (".",_)) =
  20.108 -            let val (rator,rands) = strip_happ [] t
  20.109 -            in  case rator of
  20.110 -                    Metis_Term.Fn(fname,ts) => applic_to_tt (fname, ts @ rands)
  20.111 -                  | _ => case tm_to_tt rator of
  20.112 -                             SomeTerm t => SomeTerm (list_comb(t, terms_of (map tm_to_tt rands)))
  20.113 -                           | _ => raise Fail "tm_to_tt: HO application"
  20.114 -            end
  20.115 -        | tm_to_tt (Metis_Term.Fn (fname, args)) = applic_to_tt (fname,args)
  20.116 -      and applic_to_tt ("=",ts) =
  20.117 -            SomeTerm (list_comb(Const (@{const_name HOL.eq}, HOLogic.typeT), terms_of (map tm_to_tt ts)))
  20.118 -        | applic_to_tt (a,ts) =
  20.119 -            case strip_prefix_and_unascii const_prefix a of
  20.120 -                SOME b =>
  20.121 -                  let
  20.122 -                    val c = smart_invert_const b
  20.123 -                    val ntypes = num_type_args thy c
  20.124 -                    val nterms = length ts - ntypes
  20.125 -                    val tts = map tm_to_tt ts
  20.126 -                    val tys = types_of (List.take(tts,ntypes))
  20.127 -                    val t = if String.isPrefix new_skolem_const_prefix c then
  20.128 -                              Var (new_skolem_var_from_const c, tl tys ---> hd tys)
  20.129 -                            else
  20.130 -                              Const (c, dummyT)
  20.131 -                  in if length tys = ntypes then
  20.132 -                         apply_list t nterms (List.drop(tts,ntypes))
  20.133 -                     else
  20.134 -                       raise Fail ("Constant " ^ c ^ " expects " ^ Int.toString ntypes ^
  20.135 -                                   " but gets " ^ Int.toString (length tys) ^
  20.136 -                                   " type arguments\n" ^
  20.137 -                                   cat_lines (map (Syntax.string_of_typ ctxt) tys) ^
  20.138 -                                   " the terms are \n" ^
  20.139 -                                   cat_lines (map (Syntax.string_of_term ctxt) (terms_of tts)))
  20.140 -                     end
  20.141 -              | NONE => (*Not a constant. Is it a type constructor?*)
  20.142 -            case strip_prefix_and_unascii type_const_prefix a of
  20.143 -                SOME b =>
  20.144 -                SomeType (Type (smart_invert_const b, types_of (map tm_to_tt ts)))
  20.145 -              | NONE => (*Maybe a TFree. Should then check that ts=[].*)
  20.146 -            case strip_prefix_and_unascii tfree_prefix a of
  20.147 -                SOME b => SomeType (mk_tfree ctxt b)
  20.148 -              | NONE => (*a fixed variable? They are Skolem functions.*)
  20.149 -            case strip_prefix_and_unascii fixed_var_prefix a of
  20.150 -                SOME b =>
  20.151 -                  let val opr = Free (b, HOLogic.typeT)
  20.152 -                  in  apply_list opr (length ts) (map tm_to_tt ts)  end
  20.153 -              | NONE => raise Fail ("unexpected metis function: " ^ a)
  20.154 -  in
  20.155 -    case tm_to_tt fol_tm of
  20.156 -      SomeTerm t => t
  20.157 -    | SomeType T => raise TYPE ("fol_tm_to_tt: Term expected", [T], [])
  20.158 -  end
  20.159 -
  20.160 -(*Maps fully-typed metis terms to isabelle terms*)
  20.161 -fun hol_term_from_metis_FT ctxt fol_tm =
  20.162 -  let val _ = trace_msg (fn () => "hol_term_from_metis_FT: " ^
  20.163 -                                  Metis_Term.toString fol_tm)
  20.164 -      fun cvt (Metis_Term.Fn ("ti", [Metis_Term.Var v, _])) =
  20.165 -             (case strip_prefix_and_unascii schematic_var_prefix v of
  20.166 -                  SOME w =>  mk_var(w, dummyT)
  20.167 -                | NONE   => mk_var(v, dummyT))
  20.168 -        | cvt (Metis_Term.Fn ("ti", [Metis_Term.Fn ("=",[]), _])) =
  20.169 -            Const (@{const_name HOL.eq}, HOLogic.typeT)
  20.170 -        | cvt (Metis_Term.Fn ("ti", [Metis_Term.Fn (x,[]), ty])) =
  20.171 -           (case strip_prefix_and_unascii const_prefix x of
  20.172 -                SOME c => Const (smart_invert_const c, dummyT)
  20.173 -              | NONE => (*Not a constant. Is it a fixed variable??*)
  20.174 -            case strip_prefix_and_unascii fixed_var_prefix x of
  20.175 -                SOME v => Free (v, hol_type_from_metis_term ctxt ty)
  20.176 -              | NONE => raise Fail ("hol_term_from_metis_FT bad constant: " ^ x))
  20.177 -        | cvt (Metis_Term.Fn ("ti", [Metis_Term.Fn (".",[tm1,tm2]), _])) =
  20.178 -            cvt tm1 $ cvt tm2
  20.179 -        | cvt (Metis_Term.Fn (".",[tm1,tm2])) = (*untyped application*)
  20.180 -            cvt tm1 $ cvt tm2
  20.181 -        | cvt (Metis_Term.Fn ("{}", [arg])) = cvt arg   (*hBOOL*)
  20.182 -        | cvt (Metis_Term.Fn ("=", [tm1,tm2])) =
  20.183 -            list_comb(Const (@{const_name HOL.eq}, HOLogic.typeT), map cvt [tm1,tm2])
  20.184 -        | cvt (t as Metis_Term.Fn (x, [])) =
  20.185 -           (case strip_prefix_and_unascii const_prefix x of
  20.186 -                SOME c => Const (smart_invert_const c, dummyT)
  20.187 -              | NONE => (*Not a constant. Is it a fixed variable??*)
  20.188 -            case strip_prefix_and_unascii fixed_var_prefix x of
  20.189 -                SOME v => Free (v, dummyT)
  20.190 -              | NONE => (trace_msg (fn () => "hol_term_from_metis_FT bad const: " ^ x);
  20.191 -                  hol_term_from_metis_PT ctxt t))
  20.192 -        | cvt t = (trace_msg (fn () => "hol_term_from_metis_FT bad term: " ^ Metis_Term.toString t);
  20.193 -            hol_term_from_metis_PT ctxt t)
  20.194 -  in fol_tm |> cvt end
  20.195 -
  20.196 -fun hol_term_from_metis FT = hol_term_from_metis_FT
  20.197 -  | hol_term_from_metis _ = hol_term_from_metis_PT
  20.198 -
  20.199 -fun hol_terms_from_fol ctxt mode old_skolems fol_tms =
  20.200 -  let val ts = map (hol_term_from_metis mode ctxt) fol_tms
  20.201 -      val _ = trace_msg (fn () => "  calling type inference:")
  20.202 -      val _ = app (fn t => trace_msg (fn () => Syntax.string_of_term ctxt t)) ts
  20.203 -      val ts' = ts |> map (reveal_old_skolem_terms old_skolems)
  20.204 -                   |> infer_types ctxt
  20.205 -      val _ = app (fn t => trace_msg
  20.206 -                    (fn () => "  final term: " ^ Syntax.string_of_term ctxt t ^
  20.207 -                              "  of type  " ^ Syntax.string_of_typ ctxt (type_of t)))
  20.208 -                  ts'
  20.209 -  in  ts'  end;
  20.210 -
  20.211 -(* ------------------------------------------------------------------------- *)
  20.212 -(* FOL step Inference Rules                                                  *)
  20.213 -(* ------------------------------------------------------------------------- *)
  20.214 -
  20.215 -(*for debugging only*)
  20.216 -(*
  20.217 -fun print_thpair (fth,th) =
  20.218 -  (trace_msg (fn () => "=============================================");
  20.219 -   trace_msg (fn () => "Metis: " ^ Metis_Thm.toString fth);
  20.220 -   trace_msg (fn () => "Isabelle: " ^ Display.string_of_thm_without_context th));
  20.221 -*)
  20.222 -
  20.223 -fun lookth thpairs (fth : Metis_Thm.thm) =
  20.224 -  the (AList.lookup (uncurry Metis_Thm.equal) thpairs fth)
  20.225 -  handle Option.Option =>
  20.226 -         raise Fail ("Failed to find Metis theorem " ^ Metis_Thm.toString fth)
  20.227 -
  20.228 -fun cterm_incr_types thy idx = cterm_of thy o (map_types (Logic.incr_tvar idx));
  20.229 -
  20.230 -(* INFERENCE RULE: AXIOM *)
  20.231 -
  20.232 -fun axiom_inf thpairs th = Thm.incr_indexes 1 (lookth thpairs th);
  20.233 -    (*This causes variables to have an index of 1 by default. SEE ALSO mk_var above.*)
  20.234 -
  20.235 -(* INFERENCE RULE: ASSUME *)
  20.236 -
  20.237 -val EXCLUDED_MIDDLE = @{lemma "P ==> ~ P ==> False" by (rule notE)}
  20.238 -
  20.239 -fun inst_excluded_middle thy i_atm =
  20.240 -  let val th = EXCLUDED_MIDDLE
  20.241 -      val [vx] = Term.add_vars (prop_of th) []
  20.242 -      val substs = [(cterm_of thy (Var vx), cterm_of thy i_atm)]
  20.243 -  in  cterm_instantiate substs th  end;
  20.244 -
  20.245 -fun assume_inf ctxt mode old_skolems atm =
  20.246 -  inst_excluded_middle
  20.247 -      (ProofContext.theory_of ctxt)
  20.248 -      (singleton (hol_terms_from_fol ctxt mode old_skolems) (Metis_Term.Fn atm))
  20.249 -
  20.250 -(* INFERENCE RULE: INSTANTIATE (SUBST). Type instantiations are ignored. Trying
  20.251 -   to reconstruct them admits new possibilities of errors, e.g. concerning
  20.252 -   sorts. Instead we try to arrange that new TVars are distinct and that types
  20.253 -   can be inferred from terms. *)
  20.254 -
  20.255 -fun inst_inf ctxt mode old_skolems thpairs fsubst th =
  20.256 -  let val thy = ProofContext.theory_of ctxt
  20.257 -      val i_th = lookth thpairs th
  20.258 -      val i_th_vars = Term.add_vars (prop_of i_th) []
  20.259 -      fun find_var x = the (List.find (fn ((a,_),_) => a=x) i_th_vars)
  20.260 -      fun subst_translation (x,y) =
  20.261 -        let val v = find_var x
  20.262 -            (* We call "reveal_old_skolem_terms" and "infer_types" below. *)
  20.263 -            val t = hol_term_from_metis mode ctxt y
  20.264 -        in  SOME (cterm_of thy (Var v), t)  end
  20.265 -        handle Option.Option =>
  20.266 -               (trace_msg (fn () => "\"find_var\" failed for " ^ x ^
  20.267 -                                    " in " ^ Display.string_of_thm ctxt i_th);
  20.268 -                NONE)
  20.269 -             | TYPE _ =>
  20.270 -               (trace_msg (fn () => "\"hol_term_from_metis\" failed for " ^ x ^
  20.271 -                                    " in " ^ Display.string_of_thm ctxt i_th);
  20.272 -                NONE)
  20.273 -      fun remove_typeinst (a, t) =
  20.274 -            case strip_prefix_and_unascii schematic_var_prefix a of
  20.275 -                SOME b => SOME (b, t)
  20.276 -              | NONE => case strip_prefix_and_unascii tvar_prefix a of
  20.277 -                SOME _ => NONE          (*type instantiations are forbidden!*)
  20.278 -              | NONE => SOME (a,t)    (*internal Metis var?*)
  20.279 -      val _ = trace_msg (fn () => "  isa th: " ^ Display.string_of_thm ctxt i_th)
  20.280 -      val substs = map_filter remove_typeinst (Metis_Subst.toList fsubst)
  20.281 -      val (vars,rawtms) = ListPair.unzip (map_filter subst_translation substs)
  20.282 -      val tms = rawtms |> map (reveal_old_skolem_terms old_skolems)
  20.283 -                       |> infer_types ctxt
  20.284 -      val ctm_of = cterm_incr_types thy (1 + Thm.maxidx_of i_th)
  20.285 -      val substs' = ListPair.zip (vars, map ctm_of tms)
  20.286 -      val _ = trace_msg (fn () =>
  20.287 -        cat_lines ("subst_translations:" ::
  20.288 -          (substs' |> map (fn (x, y) =>
  20.289 -            Syntax.string_of_term ctxt (term_of x) ^ " |-> " ^
  20.290 -            Syntax.string_of_term ctxt (term_of y)))));
  20.291 -  in cterm_instantiate substs' i_th end
  20.292 -  handle THM (msg, _, _) =>
  20.293 -         error ("Cannot replay Metis proof in Isabelle:\n" ^ msg)
  20.294 -
  20.295 -(* INFERENCE RULE: RESOLVE *)
  20.296 -
  20.297 -(* Like RSN, but we rename apart only the type variables. Vars here typically
  20.298 -   have an index of 1, and the use of RSN would increase this typically to 3.
  20.299 -   Instantiations of those Vars could then fail. See comment on "mk_var". *)
  20.300 -fun resolve_inc_tyvars thy tha i thb =
  20.301 -  let
  20.302 -    val tha = Drule.incr_type_indexes (1 + Thm.maxidx_of thb) tha
  20.303 -    fun aux tha thb =
  20.304 -      case Thm.bicompose false (false, tha, nprems_of tha) i thb
  20.305 -           |> Seq.list_of |> distinct Thm.eq_thm of
  20.306 -        [th] => th
  20.307 -      | _ => raise THM ("resolve_inc_tyvars: unique result expected", i,
  20.308 -                        [tha, thb])
  20.309 -  in
  20.310 -    aux tha thb
  20.311 -    handle TERM z =>
  20.312 -           (* The unifier, which is invoked from "Thm.bicompose", will sometimes
  20.313 -              refuse to unify "?a::?'a" with "?a::?'b" or "?a::nat" and throw a
  20.314 -              "TERM" exception (with "add_ffpair" as first argument). We then
  20.315 -              perform unification of the types of variables by hand and try
  20.316 -              again. We could do this the first time around but this error
  20.317 -              occurs seldom and we don't want to break existing proofs in subtle
  20.318 -              ways or slow them down needlessly. *)
  20.319 -           case [] |> fold (Term.add_vars o prop_of) [tha, thb]
  20.320 -                   |> AList.group (op =)
  20.321 -                   |> maps (fn ((s, _), T :: Ts) =>
  20.322 -                               map (fn T' => (Free (s, T), Free (s, T'))) Ts)
  20.323 -                   |> rpair (Envir.empty ~1)
  20.324 -                   |-> fold (Pattern.unify thy)
  20.325 -                   |> Envir.type_env |> Vartab.dest
  20.326 -                   |> map (fn (x, (S, T)) =>
  20.327 -                              pairself (ctyp_of thy) (TVar (x, S), T)) of
  20.328 -             [] => raise TERM z
  20.329 -           | ps => aux (instantiate (ps, []) tha) (instantiate (ps, []) thb)
  20.330 -  end
  20.331 -
  20.332 -fun mk_not (Const (@{const_name Not}, _) $ b) = b
  20.333 -  | mk_not b = HOLogic.mk_not b
  20.334 -
  20.335 -(* Match untyped terms. *)
  20.336 -fun untyped_aconv (Const (a, _)) (Const(b, _)) = (a = b)
  20.337 -  | untyped_aconv (Free (a, _)) (Free (b, _)) = (a = b)
  20.338 -  | untyped_aconv (Var ((a, _), _)) (Var ((b, _), _)) =
  20.339 -    (a = b) (* The index is ignored, for some reason. *)
  20.340 -  | untyped_aconv (Bound i) (Bound j) = (i = j)
  20.341 -  | untyped_aconv (Abs (_, _, t)) (Abs (_, _, u)) = untyped_aconv t u
  20.342 -  | untyped_aconv (t1 $ t2) (u1 $ u2) =
  20.343 -    untyped_aconv t1 u1 andalso untyped_aconv t2 u2
  20.344 -  | untyped_aconv _ _ = false
  20.345 -
  20.346 -(* Finding the relative location of an untyped term within a list of terms *)
  20.347 -fun literal_index lit =
  20.348 -  let
  20.349 -    val lit = Envir.eta_contract lit
  20.350 -    fun get _ [] = raise Empty
  20.351 -      | get n (x :: xs) =
  20.352 -        if untyped_aconv lit (Envir.eta_contract (HOLogic.dest_Trueprop x)) then
  20.353 -          n
  20.354 -        else
  20.355 -          get (n+1) xs
  20.356 -  in get 1 end
  20.357 -
  20.358 -(* Permute a rule's premises to move the i-th premise to the last position. *)
  20.359 -fun make_last i th =
  20.360 -  let val n = nprems_of th
  20.361 -  in  if 1 <= i andalso i <= n
  20.362 -      then Thm.permute_prems (i-1) 1 th
  20.363 -      else raise THM("select_literal", i, [th])
  20.364 -  end;
  20.365 -
  20.366 -(* Maps a rule that ends "... ==> P ==> False" to "... ==> ~P" while suppressing
  20.367 -   double-negations. *)
  20.368 -val negate_head = rewrite_rule [@{thm atomize_not}, not_not RS eq_reflection]
  20.369 -
  20.370 -(* Maps the clause  [P1,...Pn]==>False to [P1,...,P(i-1),P(i+1),...Pn] ==> ~P *)
  20.371 -val select_literal = negate_head oo make_last
  20.372 -
  20.373 -fun resolve_inf ctxt mode old_skolems thpairs atm th1 th2 =
  20.374 -  let
  20.375 -    val thy = ProofContext.theory_of ctxt
  20.376 -    val i_th1 = lookth thpairs th1 and i_th2 = lookth thpairs th2
  20.377 -    val _ = trace_msg (fn () => "  isa th1 (pos): " ^ Display.string_of_thm ctxt i_th1)
  20.378 -    val _ = trace_msg (fn () => "  isa th2 (neg): " ^ Display.string_of_thm ctxt i_th2)
  20.379 -  in
  20.380 -    (* Trivial cases where one operand is type info *)
  20.381 -    if Thm.eq_thm (TrueI, i_th1) then
  20.382 -      i_th2
  20.383 -    else if Thm.eq_thm (TrueI, i_th2) then
  20.384 -      i_th1
  20.385 -    else
  20.386 -      let
  20.387 -        val i_atm = singleton (hol_terms_from_fol ctxt mode old_skolems)
  20.388 -                              (Metis_Term.Fn atm)
  20.389 -        val _ = trace_msg (fn () => "  atom: " ^ Syntax.string_of_term ctxt i_atm)
  20.390 -        val prems_th1 = prems_of i_th1
  20.391 -        val prems_th2 = prems_of i_th2
  20.392 -        val index_th1 = literal_index (mk_not i_atm) prems_th1
  20.393 -              handle Empty => raise Fail "Failed to find literal in th1"
  20.394 -        val _ = trace_msg (fn () => "  index_th1: " ^ Int.toString index_th1)
  20.395 -        val index_th2 = literal_index i_atm prems_th2
  20.396 -              handle Empty => raise Fail "Failed to find literal in th2"
  20.397 -        val _ = trace_msg (fn () => "  index_th2: " ^ Int.toString index_th2)
  20.398 -    in
  20.399 -      resolve_inc_tyvars thy (select_literal index_th1 i_th1) index_th2 i_th2
  20.400 -    end
  20.401 -  end;
  20.402 -
  20.403 -(* INFERENCE RULE: REFL *)
  20.404 -
  20.405 -val REFL_THM = Thm.incr_indexes 2 @{lemma "t ~= t ==> False" by simp}
  20.406 -
  20.407 -val refl_x = cterm_of @{theory} (Var (hd (Term.add_vars (prop_of REFL_THM) [])));
  20.408 -val refl_idx = 1 + Thm.maxidx_of REFL_THM;
  20.409 -
  20.410 -fun refl_inf ctxt mode old_skolems t =
  20.411 -  let val thy = ProofContext.theory_of ctxt
  20.412 -      val i_t = singleton (hol_terms_from_fol ctxt mode old_skolems) t
  20.413 -      val _ = trace_msg (fn () => "  term: " ^ Syntax.string_of_term ctxt i_t)
  20.414 -      val c_t = cterm_incr_types thy refl_idx i_t
  20.415 -  in  cterm_instantiate [(refl_x, c_t)] REFL_THM  end;
  20.416 -
  20.417 -(* INFERENCE RULE: EQUALITY *)
  20.418 -
  20.419 -val subst_em = @{lemma "s = t ==> P s ==> ~ P t ==> False" by simp}
  20.420 -val ssubst_em = @{lemma "s = t ==> P t ==> ~ P s ==> False" by simp}
  20.421 -
  20.422 -val metis_eq = Metis_Term.Fn ("=", []);
  20.423 -
  20.424 -fun get_ty_arg_size _ (Const (@{const_name HOL.eq}, _)) = 0  (*equality has no type arguments*)
  20.425 -  | get_ty_arg_size thy (Const (c, _)) = (num_type_args thy c handle TYPE _ => 0)
  20.426 -  | get_ty_arg_size _ _ = 0;
  20.427 -
  20.428 -fun equality_inf ctxt mode old_skolems (pos, atm) fp fr =
  20.429 -  let val thy = ProofContext.theory_of ctxt
  20.430 -      val m_tm = Metis_Term.Fn atm
  20.431 -      val [i_atm,i_tm] = hol_terms_from_fol ctxt mode old_skolems [m_tm, fr]
  20.432 -      val _ = trace_msg (fn () => "sign of the literal: " ^ Bool.toString pos)
  20.433 -      fun replace_item_list lx 0 (_::ls) = lx::ls
  20.434 -        | replace_item_list lx i (l::ls) = l :: replace_item_list lx (i-1) ls
  20.435 -      fun path_finder_FO tm [] = (tm, Bound 0)
  20.436 -        | path_finder_FO tm (p::ps) =
  20.437 -            let val (tm1,args) = strip_comb tm
  20.438 -                val adjustment = get_ty_arg_size thy tm1
  20.439 -                val p' = if adjustment > p then p else p-adjustment
  20.440 -                val tm_p = List.nth(args,p')
  20.441 -                  handle Subscript =>
  20.442 -                         error ("Cannot replay Metis proof in Isabelle:\n" ^
  20.443 -                                "equality_inf: " ^ Int.toString p ^ " adj " ^
  20.444 -                                Int.toString adjustment ^ " term " ^
  20.445 -                                Syntax.string_of_term ctxt tm)
  20.446 -                val _ = trace_msg (fn () => "path_finder: " ^ Int.toString p ^
  20.447 -                                      "  " ^ Syntax.string_of_term ctxt tm_p)
  20.448 -                val (r,t) = path_finder_FO tm_p ps
  20.449 -            in
  20.450 -                (r, list_comb (tm1, replace_item_list t p' args))
  20.451 -            end
  20.452 -      fun path_finder_HO tm [] = (tm, Bound 0)
  20.453 -        | path_finder_HO (t$u) (0::ps) = (fn(x,y) => (x, y$u)) (path_finder_HO t ps)
  20.454 -        | path_finder_HO (t$u) (_::ps) = (fn(x,y) => (x, t$y)) (path_finder_HO u ps)
  20.455 -        | path_finder_HO tm ps =
  20.456 -          raise Fail ("Cannot replay Metis proof in Isabelle:\n" ^
  20.457 -                      "equality_inf, path_finder_HO: path = " ^
  20.458 -                      space_implode " " (map Int.toString ps) ^
  20.459 -                      " isa-term: " ^  Syntax.string_of_term ctxt tm)
  20.460 -      fun path_finder_FT tm [] _ = (tm, Bound 0)
  20.461 -        | path_finder_FT tm (0::ps) (Metis_Term.Fn ("ti", [t1, _])) =
  20.462 -            path_finder_FT tm ps t1
  20.463 -        | path_finder_FT (t$u) (0::ps) (Metis_Term.Fn (".", [t1, _])) =
  20.464 -            (fn(x,y) => (x, y$u)) (path_finder_FT t ps t1)
  20.465 -        | path_finder_FT (t$u) (1::ps) (Metis_Term.Fn (".", [_, t2])) =
  20.466 -            (fn(x,y) => (x, t$y)) (path_finder_FT u ps t2)
  20.467 -        | path_finder_FT tm ps t =
  20.468 -          raise Fail ("Cannot replay Metis proof in Isabelle:\n" ^
  20.469 -                      "equality_inf, path_finder_FT: path = " ^
  20.470 -                      space_implode " " (map Int.toString ps) ^
  20.471 -                      " isa-term: " ^  Syntax.string_of_term ctxt tm ^
  20.472 -                      " fol-term: " ^ Metis_Term.toString t)
  20.473 -      fun path_finder FO tm ps _ = path_finder_FO tm ps
  20.474 -        | path_finder HO (tm as Const(@{const_name HOL.eq},_) $ _ $ _) (p::ps) _ =
  20.475 -             (*equality: not curried, as other predicates are*)
  20.476 -             if p=0 then path_finder_HO tm (0::1::ps)  (*select first operand*)
  20.477 -             else path_finder_HO tm (p::ps)        (*1 selects second operand*)
  20.478 -        | path_finder HO tm (_ :: ps) (Metis_Term.Fn ("{}", [_])) =
  20.479 -             path_finder_HO tm ps      (*if not equality, ignore head to skip hBOOL*)
  20.480 -        | path_finder FT (tm as Const(@{const_name HOL.eq}, _) $ _ $ _) (p::ps)
  20.481 -                            (Metis_Term.Fn ("=", [t1,t2])) =
  20.482 -             (*equality: not curried, as other predicates are*)
  20.483 -             if p=0 then path_finder_FT tm (0::1::ps)
  20.484 -                          (Metis_Term.Fn (".", [Metis_Term.Fn (".", [metis_eq,t1]), t2]))
  20.485 -                          (*select first operand*)
  20.486 -             else path_finder_FT tm (p::ps)
  20.487 -                   (Metis_Term.Fn (".", [metis_eq,t2]))
  20.488 -                   (*1 selects second operand*)
  20.489 -        | path_finder FT tm (_ :: ps) (Metis_Term.Fn ("{}", [t1])) = path_finder_FT tm ps t1
  20.490 -             (*if not equality, ignore head to skip the hBOOL predicate*)
  20.491 -        | path_finder FT tm ps t = path_finder_FT tm ps t  (*really an error case!*)
  20.492 -      fun path_finder_lit ((nt as Const (@{const_name Not}, _)) $ tm_a) idx =
  20.493 -            let val (tm, tm_rslt) = path_finder mode tm_a idx m_tm
  20.494 -            in (tm, nt $ tm_rslt) end
  20.495 -        | path_finder_lit tm_a idx = path_finder mode tm_a idx m_tm
  20.496 -      val (tm_subst, body) = path_finder_lit i_atm fp
  20.497 -      val tm_abs = Abs ("x", type_of tm_subst, body)
  20.498 -      val _ = trace_msg (fn () => "abstraction: " ^ Syntax.string_of_term ctxt tm_abs)
  20.499 -      val _ = trace_msg (fn () => "i_tm: " ^ Syntax.string_of_term ctxt i_tm)
  20.500 -      val _ = trace_msg (fn () => "located term: " ^ Syntax.string_of_term ctxt tm_subst)
  20.501 -      val imax = maxidx_of_term (i_tm $ tm_abs $ tm_subst)  (*ill typed but gives right max*)
  20.502 -      val subst' = Thm.incr_indexes (imax+1) (if pos then subst_em else ssubst_em)
  20.503 -      val _ = trace_msg (fn () => "subst' " ^ Display.string_of_thm ctxt subst')
  20.504 -      val eq_terms = map (pairself (cterm_of thy))
  20.505 -        (ListPair.zip (OldTerm.term_vars (prop_of subst'), [tm_abs, tm_subst, i_tm]))
  20.506 -  in  cterm_instantiate eq_terms subst'  end;
  20.507 -
  20.508 -val factor = Seq.hd o distinct_subgoals_tac;
  20.509 -
  20.510 -fun step ctxt mode old_skolems thpairs p =
  20.511 -  case p of
  20.512 -    (fol_th, Metis_Proof.Axiom _) => factor (axiom_inf thpairs fol_th)
  20.513 -  | (_, Metis_Proof.Assume f_atm) => assume_inf ctxt mode old_skolems f_atm
  20.514 -  | (_, Metis_Proof.Metis_Subst (f_subst, f_th1)) =>
  20.515 -    factor (inst_inf ctxt mode old_skolems thpairs f_subst f_th1)
  20.516 -  | (_, Metis_Proof.Resolve(f_atm, f_th1, f_th2)) =>
  20.517 -    factor (resolve_inf ctxt mode old_skolems thpairs f_atm f_th1 f_th2)
  20.518 -  | (_, Metis_Proof.Refl f_tm) => refl_inf ctxt mode old_skolems f_tm
  20.519 -  | (_, Metis_Proof.Equality (f_lit, f_p, f_r)) =>
  20.520 -    equality_inf ctxt mode old_skolems f_lit f_p f_r
  20.521 -
  20.522 -fun flexflex_first_order th =
  20.523 -  case Thm.tpairs_of th of
  20.524 -      [] => th
  20.525 -    | pairs =>
  20.526 -        let val thy = theory_of_thm th
  20.527 -            val (_, tenv) =
  20.528 -              fold (Pattern.first_order_match thy) pairs (Vartab.empty, Vartab.empty)
  20.529 -            val t_pairs = map Meson.term_pair_of (Vartab.dest tenv)
  20.530 -            val th' = Thm.instantiate ([], map (pairself (cterm_of thy)) t_pairs) th
  20.531 -        in  th'  end
  20.532 -        handle THM _ => th;
  20.533 -
  20.534 -fun is_metis_literal_genuine (_, (s, _)) = not (String.isPrefix class_prefix s)
  20.535 -fun is_isabelle_literal_genuine t =
  20.536 -  case t of _ $ (Const (@{const_name skolem}, _) $ _) => false | _ => true
  20.537 -
  20.538 -fun count p xs = fold (fn x => if p x then Integer.add 1 else I) xs 0
  20.539 -
  20.540 -fun replay_one_inference ctxt mode old_skolems (fol_th, inf) thpairs =
  20.541 -  let
  20.542 -    val _ = trace_msg (fn () => "=============================================")
  20.543 -    val _ = trace_msg (fn () => "METIS THM: " ^ Metis_Thm.toString fol_th)
  20.544 -    val _ = trace_msg (fn () => "INFERENCE: " ^ Metis_Proof.inferenceToString inf)
  20.545 -    val th = step ctxt mode old_skolems thpairs (fol_th, inf)
  20.546 -             |> flexflex_first_order
  20.547 -    val _ = trace_msg (fn () => "ISABELLE THM: " ^ Display.string_of_thm ctxt th)
  20.548 -    val _ = trace_msg (fn () => "=============================================")
  20.549 -    val num_metis_lits =
  20.550 -      fol_th |> Metis_Thm.clause |> Metis_LiteralSet.toList
  20.551 -             |> count is_metis_literal_genuine
  20.552 -    val num_isabelle_lits =
  20.553 -      th |> prems_of |> count is_isabelle_literal_genuine
  20.554 -    val _ = if num_metis_lits = num_isabelle_lits then ()
  20.555 -            else error "Cannot replay Metis proof in Isabelle: Out of sync."
  20.556 -  in (fol_th, th) :: thpairs end
  20.557 -
  20.558 -end;
    21.1 --- a/src/HOL/Tools/Sledgehammer/metis_tactics.ML	Wed Oct 06 13:48:12 2010 +0200
    21.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    21.3 @@ -1,341 +0,0 @@
    21.4 -(*  Title:      HOL/Tools/Sledgehammer/metis_tactics.ML
    21.5 -    Author:     Kong W. Susanto, Cambridge University Computer Laboratory
    21.6 -    Author:     Lawrence C. Paulson, Cambridge University Computer Laboratory
    21.7 -    Author:     Jasmin Blanchette, TU Muenchen
    21.8 -    Copyright   Cambridge University 2007
    21.9 -
   21.10 -HOL setup for the Metis prover.
   21.11 -*)
   21.12 -
   21.13 -signature METIS_TACTICS =
   21.14 -sig
   21.15 -  val trace : bool Unsynchronized.ref
   21.16 -  val type_lits : bool Config.T
   21.17 -  val new_skolemizer : bool Config.T
   21.18 -  val metis_tac : Proof.context -> thm list -> int -> tactic
   21.19 -  val metisF_tac : Proof.context -> thm list -> int -> tactic
   21.20 -  val metisFT_tac : Proof.context -> thm list -> int -> tactic
   21.21 -  val setup : theory -> theory
   21.22 -end
   21.23 -
   21.24 -structure Metis_Tactics : METIS_TACTICS =
   21.25 -struct
   21.26 -
   21.27 -open Metis_Translate
   21.28 -open Metis_Reconstruct
   21.29 -
   21.30 -structure Int_Pair_Graph =
   21.31 -  Graph(type key = int * int val ord = prod_ord int_ord int_ord)
   21.32 -
   21.33 -fun trace_msg msg = if !trace then tracing (msg ()) else ()
   21.34 -
   21.35 -val (type_lits, type_lits_setup) = Attrib.config_bool "metis_type_lits" (K true)
   21.36 -val (new_skolemizer, new_skolemizer_setup) =
   21.37 -  Attrib.config_bool "metis_new_skolemizer" (K false)
   21.38 -
   21.39 -fun is_false t = t aconv (HOLogic.mk_Trueprop HOLogic.false_const);
   21.40 -
   21.41 -fun have_common_thm ths1 ths2 =
   21.42 -  exists (member Thm.eq_thm ths1) (map Meson.make_meta_clause ths2)
   21.43 -
   21.44 -(*Determining which axiom clauses are actually used*)
   21.45 -fun used_axioms axioms (th, Metis_Proof.Axiom _) = SOME (lookth axioms th)
   21.46 -  | used_axioms _ _ = NONE;
   21.47 -
   21.48 -val clause_params =
   21.49 -  {ordering = Metis_KnuthBendixOrder.default,
   21.50 -   orderLiterals = Metis_Clause.UnsignedLiteralOrder,
   21.51 -   orderTerms = true}
   21.52 -val active_params =
   21.53 -  {clause = clause_params,
   21.54 -   prefactor = #prefactor Metis_Active.default,
   21.55 -   postfactor = #postfactor Metis_Active.default}
   21.56 -val waiting_params =
   21.57 -  {symbolsWeight = 1.0,
   21.58 -   variablesWeight = 0.0,
   21.59 -   literalsWeight = 0.0,
   21.60 -   models = []}
   21.61 -val resolution_params = {active = active_params, waiting = waiting_params}
   21.62 -
   21.63 -(* In principle, it should be sufficient to apply "assume_tac" to unify the
   21.64 -   conclusion with one of the premises. However, in practice, this fails
   21.65 -   horribly because of the mildly higher-order nature of the unification
   21.66 -   problems. Typical constraints are of the form "?x a b =?= b", where "a" and
   21.67 -   "b" are goal parameters. *)
   21.68 -fun unify_prem_with_concl thy i th =
   21.69 -  let
   21.70 -    val goal = Logic.get_goal (prop_of th) i |> Envir.beta_eta_contract
   21.71 -    val prem = goal |> Logic.strip_assums_hyp |> the_single
   21.72 -    val concl = goal |> Logic.strip_assums_concl
   21.73 -    fun add_types Tp instT =
   21.74 -      if exists (curry (op =) Tp) instT then instT
   21.75 -      else Tp :: map (apsnd (typ_subst_atomic [Tp])) instT
   21.76 -    fun unify_types (T, U) =
   21.77 -      if T = U then
   21.78 -        I
   21.79 -      else case (T, U) of
   21.80 -        (TVar _, _) => add_types (T, U)
   21.81 -      | (_, TVar _) => add_types (U, T)
   21.82 -      | (Type (s, Ts), Type (t, Us)) =>
   21.83 -        if s = t andalso length Ts = length Us then fold unify_types (Ts ~~ Us)
   21.84 -        else raise TYPE ("unify_types", [T, U], [])
   21.85 -      | _ => raise TYPE ("unify_types", [T, U], [])
   21.86 -    fun pair_untyped_aconv (t1, t2) (u1, u2) =
   21.87 -      untyped_aconv t1 u1 andalso untyped_aconv t2 u2
   21.88 -    fun add_terms tp inst =
   21.89 -      if exists (pair_untyped_aconv tp) inst then inst
   21.90 -      else tp :: map (apsnd (subst_atomic [tp])) inst
   21.91 -    fun is_flex t =
   21.92 -      case strip_comb t of
   21.93 -        (Var _, args) => forall (is_Bound orf is_Var (*FIXME: orf is_Free*)) args
   21.94 -      | _ => false
   21.95 -    fun unify_flex flex rigid =
   21.96 -      case strip_comb flex of
   21.97 -        (Var (z as (_, T)), args) =>
   21.98 -        add_terms (Var z,
   21.99 -          (* FIXME: reindex bound variables *)
  21.100 -          fold_rev (curry absdummy) (take (length args) (binder_types T)) rigid)
  21.101 -      | _ => raise TERM ("unify_flex: expected flex", [flex])
  21.102 -    fun unify_potential_flex comb atom =
  21.103 -      if is_flex comb then unify_flex comb atom
  21.104 -      else if is_Var atom then add_terms (atom, comb)
  21.105 -      else raise TERM ("unify_terms", [comb, atom])
  21.106 -    fun unify_terms (t, u) =
  21.107 -      case (t, u) of
  21.108 -        (t1 $ t2, u1 $ u2) =>
  21.109 -        if is_flex t then unify_flex t u
  21.110 -        else if is_flex u then unify_flex u t
  21.111 -        else fold unify_terms [(t1, u1), (t2, u2)]
  21.112 -      | (_ $ _, _) => unify_potential_flex t u
  21.113 -      | (_, _ $ _) => unify_potential_flex u t
  21.114 -      | (Var _, _) => add_terms (t, u)
  21.115 -      | (_, Var _) => add_terms (u, t)
  21.116 -      | _ => if untyped_aconv t u then I else raise TERM ("unify_terms", [t, u])
  21.117 -
  21.118 -    val inst = [] |> unify_terms (prem, concl)
  21.119 -    val _ = trace_msg (fn () => cat_lines (map (fn (t, u) =>
  21.120 -        Syntax.string_of_term @{context} t ^ " |-> " ^
  21.121 -        Syntax.string_of_term @{context} u) inst))
  21.122 -    val instT = fold (fn Tp => unify_types (pairself fastype_of Tp)
  21.123 -                               handle TERM _ => I) inst []
  21.124 -    val inst = inst |> map (pairself (subst_atomic_types instT))
  21.125 -    val cinstT = instT |> map (pairself (ctyp_of thy))
  21.126 -    val cinst = inst |> map (pairself (cterm_of thy))
  21.127 -  in th |> Thm.instantiate (cinstT, []) |> Thm.instantiate ([], cinst) end
  21.128 -  handle Empty => th (* ### FIXME *)
  21.129 -
  21.130 -val cluster_ord = prod_ord (prod_ord int_ord int_ord) bool_ord
  21.131 -
  21.132 -(* Attempts to derive the theorem "False" from a theorem of the form
  21.133 -   "P1 ==> ... ==> Pn ==> False", where the "Pi"s are to be discharged using the
  21.134 -   specified axioms. The axioms have leading "All" and "Ex" quantifiers, which
  21.135 -   must be eliminated first. *)
  21.136 -fun discharge_skolem_premises ctxt axioms prems_imp_false =
  21.137 -  case prop_of prems_imp_false of
  21.138 -    @{prop False} => prems_imp_false
  21.139 -  | prems_imp_false_prop =>
  21.140 -    let
  21.141 -      val thy = ProofContext.theory_of ctxt
  21.142 -      fun match_term p =
  21.143 -        let
  21.144 -          val (tyenv, tenv) =
  21.145 -            Pattern.first_order_match thy p (Vartab.empty, Vartab.empty)
  21.146 -          val tsubst =
  21.147 -            tenv |> Vartab.dest
  21.148 -                 |> sort (cluster_ord
  21.149 -                          o pairself (Meson_Clausify.cluster_of_zapped_var_name
  21.150 -                                      o fst o fst))
  21.151 -                 |> map (Meson.term_pair_of
  21.152 -                         #> pairself (Envir.subst_term_types tyenv))
  21.153 -        in (tyenv, tsubst) end
  21.154 -      fun subst_info_for_prem assm_no prem =
  21.155 -        case prem of
  21.156 -          _ $ (Const (@{const_name skolem}, _) $ (_ $ t $ num)) =>
  21.157 -          let val ax_no = HOLogic.dest_nat num in
  21.158 -            (ax_no, (assm_no, match_term (nth axioms ax_no |> snd, t)))
  21.159 -          end
  21.160 -        | _ => raise TERM ("discharge_skolem_premises: Malformed premise",
  21.161 -                           [prem])
  21.162 -      fun cluster_of_var_name skolem s =
  21.163 -        let val (jj, skolem') = Meson_Clausify.cluster_of_zapped_var_name s in
  21.164 -          if skolem' = skolem then SOME jj else NONE
  21.165 -        end
  21.166 -      fun clusters_in_term skolem t =
  21.167 -        Term.add_var_names t [] |> map_filter (cluster_of_var_name skolem o fst)
  21.168 -      fun deps_for_term_subst (var, t) =
  21.169 -        case clusters_in_term false var of
  21.170 -          [] => NONE
  21.171 -        | [(ax_no, cluster_no)] =>
  21.172 -          SOME ((ax_no, cluster_no),
  21.173 -                clusters_in_term true t
  21.174 -                |> cluster_no > 0 ? cons (ax_no, cluster_no - 1))
  21.175 -        | _ => raise TERM ("discharge_skolem_premises: Expected Var", [var])
  21.176 -      val prems = Logic.strip_imp_prems prems_imp_false_prop
  21.177 -      val substs = map2 subst_info_for_prem (0 upto length prems - 1) prems
  21.178 -      val depss = maps (map_filter deps_for_term_subst o snd o snd o snd) substs
  21.179 -      val clusters = maps (op ::) depss
  21.180 -      val ordered_clusters =
  21.181 -        Int_Pair_Graph.empty
  21.182 -        |> fold Int_Pair_Graph.default_node (map (rpair ()) clusters)
  21.183 -        |> fold Int_Pair_Graph.add_deps_acyclic depss
  21.184 -        |> Int_Pair_Graph.topological_order
  21.185 -        handle Int_Pair_Graph.CYCLES _ =>
  21.186 -               error "Cannot replay Metis proof in Isabelle without axiom of \
  21.187 -                     \choice."
  21.188 -(* for debugging:
  21.189 -      val _ = tracing ("SUBSTS: " ^ PolyML.makestring substs)
  21.190 -      val _ = tracing ("ORDERED: " ^ PolyML.makestring ordered_clusters)
  21.191 -*)
  21.192 -    in
  21.193 -      Goal.prove ctxt [] [] @{prop False}
  21.194 -          (K (cut_rules_tac (map fst axioms) 1
  21.195 -              THEN TRY (REPEAT_ALL_NEW (etac @{thm exE}) 1)
  21.196 -              (* two copies are better than one (FIXME) *)
  21.197 -              THEN etac @{lemma "P ==> (P ==> P ==> Q) ==> Q" by fast} 1
  21.198 -              THEN TRY (REPEAT_ALL_NEW (etac @{thm allE}) 1)
  21.199 -              THEN match_tac [prems_imp_false] 1
  21.200 -              THEN DETERM_UNTIL_SOLVED
  21.201 -                       (rtac @{thm skolem_COMBK_I} 1
  21.202 -                        THEN PRIMITIVE (unify_prem_with_concl thy 1)
  21.203 -                        THEN assume_tac 1)))
  21.204 -    end
  21.205 -
  21.206 -(* Main function to start Metis proof and reconstruction *)
  21.207 -fun FOL_SOLVE mode ctxt cls ths0 =
  21.208 -  let val thy = ProofContext.theory_of ctxt
  21.209 -      val type_lits = Config.get ctxt type_lits
  21.210 -      val new_skolemizer =
  21.211 -        Config.get ctxt new_skolemizer orelse null (Meson_Choices.get ctxt)
  21.212 -      val th_cls_pairs =
  21.213 -        map2 (fn j => fn th =>
  21.214 -                (Thm.get_name_hint th,
  21.215 -                 Meson_Clausify.cnf_axiom ctxt new_skolemizer j th))
  21.216 -             (0 upto length ths0 - 1) ths0
  21.217 -      val thss = map (snd o snd) th_cls_pairs
  21.218 -      val dischargers = map_filter (fst o snd) th_cls_pairs
  21.219 -      val _ = trace_msg (fn () => "FOL_SOLVE: CONJECTURE CLAUSES")
  21.220 -      val _ = app (fn th => trace_msg (fn () => Display.string_of_thm ctxt th)) cls
  21.221 -      val _ = trace_msg (fn () => "THEOREM CLAUSES")
  21.222 -      val _ = app (app (fn th => trace_msg (fn () => Display.string_of_thm ctxt th))) thss
  21.223 -      val (mode, {axioms, tfrees, old_skolems}) =
  21.224 -        build_logic_map mode ctxt type_lits cls thss
  21.225 -      val _ = if null tfrees then ()
  21.226 -              else (trace_msg (fn () => "TFREE CLAUSES");
  21.227 -                    app (fn TyLitFree ((s, _), (s', _)) =>
  21.228 -                            trace_msg (fn () => s ^ "(" ^ s' ^ ")")) tfrees)
  21.229 -      val _ = trace_msg (fn () => "CLAUSES GIVEN TO METIS")
  21.230 -      val thms = map #1 axioms
  21.231 -      val _ = app (fn th => trace_msg (fn () => Metis_Thm.toString th)) thms
  21.232 -      val _ = trace_msg (fn () => "mode = " ^ string_of_mode mode)
  21.233 -      val _ = trace_msg (fn () => "START METIS PROVE PROCESS")
  21.234 -  in
  21.235 -      case filter (is_false o prop_of) cls of
  21.236 -          false_th::_ => [false_th RS @{thm FalseE}]
  21.237 -        | [] =>
  21.238 -      case Metis_Resolution.new resolution_params {axioms = thms, conjecture = []}
  21.239 -           |> Metis_Resolution.loop of
  21.240 -          Metis_Resolution.Contradiction mth =>
  21.241 -            let val _ = trace_msg (fn () => "METIS RECONSTRUCTION START: " ^
  21.242 -                          Metis_Thm.toString mth)
  21.243 -                val ctxt' = fold Variable.declare_constraints (map prop_of cls) ctxt
  21.244 -                             (*add constraints arising from converting goal to clause form*)
  21.245 -                val proof = Metis_Proof.proof mth
  21.246 -                val result =
  21.247 -                  fold (replay_one_inference ctxt' mode old_skolems) proof axioms
  21.248 -                and used = map_filter (used_axioms axioms) proof
  21.249 -                val _ = trace_msg (fn () => "METIS COMPLETED...clauses actually used:")
  21.250 -                val _ = app (fn th => trace_msg (fn () => Display.string_of_thm ctxt th)) used
  21.251 -                val unused = th_cls_pairs |> map_filter (fn (name, (_, cls)) =>
  21.252 -                  if have_common_thm used cls then NONE else SOME name)
  21.253 -            in
  21.254 -                if not (null cls) andalso not (have_common_thm used cls) then
  21.255 -                  warning "Metis: The assumptions are inconsistent."
  21.256 -                else
  21.257 -                  ();
  21.258 -                if not (null unused) then
  21.259 -                  warning ("Metis: Unused theorems: " ^ commas_quote unused
  21.260 -                           ^ ".")
  21.261 -                else
  21.262 -                  ();
  21.263 -                case result of
  21.264 -                    (_,ith)::_ =>
  21.265 -                        (trace_msg (fn () => "Success: " ^ Display.string_of_thm ctxt ith);
  21.266 -                         [discharge_skolem_premises ctxt dischargers ith])
  21.267 -                  | _ => (trace_msg (fn () => "Metis: No result"); [])
  21.268 -            end
  21.269 -        | Metis_Resolution.Satisfiable _ =>
  21.270 -            (trace_msg (fn () => "Metis: No first-order proof with the lemmas supplied");
  21.271 -             [])
  21.272 -  end;
  21.273 -
  21.274 -(* Extensionalize "th", because that makes sense and that's what Sledgehammer
  21.275 -   does, but also keep an unextensionalized version of "th" for backward
  21.276 -   compatibility. *)
  21.277 -fun also_extensionalize_theorem th =
  21.278 -  let val th' = Meson_Clausify.extensionalize_theorem th in
  21.279 -    if Thm.eq_thm (th, th') then [th]
  21.280 -    else th :: Meson.make_clauses_unsorted [th']
  21.281 -  end
  21.282 -
  21.283 -val neg_clausify =
  21.284 -  single
  21.285 -  #> Meson.make_clauses_unsorted
  21.286 -  #> maps also_extensionalize_theorem
  21.287 -  #> map Meson_Clausify.introduce_combinators_in_theorem
  21.288 -  #> Meson.finish_cnf
  21.289 -
  21.290 -fun preskolem_tac ctxt st0 =
  21.291 -  (if exists (Meson.has_too_many_clauses ctxt)
  21.292 -             (Logic.prems_of_goal (prop_of st0) 1) then
  21.293 -     cnf.cnfx_rewrite_tac ctxt 1
  21.294 -   else
  21.295 -     all_tac) st0
  21.296 -
  21.297 -val type_has_top_sort =
  21.298 -  exists_subtype (fn TFree (_, []) => true | TVar (_, []) => true | _ => false)
  21.299 -
  21.300 -fun generic_metis_tac mode ctxt ths i st0 =
  21.301 -  let
  21.302 -    val _ = trace_msg (fn () =>
  21.303 -        "Metis called with theorems " ^ cat_lines (map (Display.string_of_thm ctxt) ths))
  21.304 -  in
  21.305 -    if exists_type type_has_top_sort (prop_of st0) then
  21.306 -      (warning ("Metis: Proof state contains the universal sort {}"); Seq.empty)
  21.307 -    else
  21.308 -      Meson.MESON (preskolem_tac ctxt) (maps neg_clausify)
  21.309 -                  (fn cls => resolve_tac (FOL_SOLVE mode ctxt cls ths) 1)
  21.310 -                  ctxt i st0
  21.311 -  end
  21.312 -
  21.313 -val metis_tac = generic_metis_tac HO
  21.314 -val metisF_tac = generic_metis_tac FO
  21.315 -val metisFT_tac = generic_metis_tac FT
  21.316 -
  21.317 -(* Whenever "X" has schematic type variables, we treat "using X by metis" as
  21.318 -   "by (metis X)", to prevent "Subgoal.FOCUS" from freezing the type variables.
  21.319 -   We don't do it for nonschematic facts "X" because this breaks a few proofs
  21.320 -   (in the rare and subtle case where a proof relied on extensionality not being
  21.321 -   applied) and brings few benefits. *)
  21.322 -val has_tvar =
  21.323 -  exists_type (exists_subtype (fn TVar _ => true | _ => false)) o prop_of
  21.324 -fun method name mode =
  21.325 -  Method.setup name (Attrib.thms >> (fn ths => fn ctxt =>
  21.326 -    METHOD (fn facts =>
  21.327 -               let
  21.328 -                 val (schem_facts, nonschem_facts) =
  21.329 -                   List.partition has_tvar facts
  21.330 -               in
  21.331 -                 HEADGOAL (Method.insert_tac nonschem_facts THEN'
  21.332 -                           CHANGED_PROP
  21.333 -                           o generic_metis_tac mode ctxt (schem_facts @ ths))
  21.334 -               end)))
  21.335 -
  21.336 -val setup =
  21.337 -  type_lits_setup
  21.338 -  #> new_skolemizer_setup
  21.339 -  #> method @{binding metis} HO "Metis for FOL/HOL problems"
  21.340 -  #> method @{binding metisF} FO "Metis for FOL problems"
  21.341 -  #> method @{binding metisFT} FT
  21.342 -            "Metis for FOL/HOL problems with fully-typed translation"
  21.343 -
  21.344 -end;
    22.1 --- a/src/HOL/Tools/Sledgehammer/metis_translate.ML	Wed Oct 06 13:48:12 2010 +0200
    22.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    22.3 @@ -1,771 +0,0 @@
    22.4 -(*  Title:      HOL/Tools/Sledgehammer/metis_translate.ML
    22.5 -    Author:     Jia Meng, Cambridge University Computer Laboratory and NICTA
    22.6 -    Author:     Kong W. Susanto, Cambridge University Computer Laboratory
    22.7 -    Author:     Lawrence C. Paulson, Cambridge University Computer Laboratory
    22.8 -    Author:     Jasmin Blanchette, TU Muenchen
    22.9 -
   22.10 -Translation of HOL to FOL for Metis.
   22.11 -*)
   22.12 -
   22.13 -signature METIS_TRANSLATE =
   22.14 -sig
   22.15 -  type name = string * string
   22.16 -  datatype type_literal =
   22.17 -    TyLitVar of name * name |
   22.18 -    TyLitFree of name * name
   22.19 -  datatype arLit =
   22.20 -    TConsLit of name * name * name list |
   22.21 -    TVarLit of name * name
   22.22 -  datatype arity_clause =
   22.23 -    ArityClause of {name: string, conclLit: arLit, premLits: arLit list}
   22.24 -  datatype class_rel_clause =
   22.25 -    ClassRelClause of {name: string, subclass: name, superclass: name}
   22.26 -  datatype combtyp =
   22.27 -    CombTVar of name |
   22.28 -    CombTFree of name |
   22.29 -    CombType of name * combtyp list
   22.30 -  datatype combterm =
   22.31 -    CombConst of name * combtyp * combtyp list (* Const and Free *) |
   22.32 -    CombVar of name * combtyp |
   22.33 -    CombApp of combterm * combterm
   22.34 -  datatype fol_literal = FOLLiteral of bool * combterm
   22.35 -
   22.36 -  datatype mode = FO | HO | FT
   22.37 -  type logic_map =
   22.38 -    {axioms: (Metis_Thm.thm * thm) list,
   22.39 -     tfrees: type_literal list,
   22.40 -     old_skolems: (string * term) list}
   22.41 -
   22.42 -  val type_wrapper_name : string
   22.43 -  val bound_var_prefix : string
   22.44 -  val schematic_var_prefix: string
   22.45 -  val fixed_var_prefix: string
   22.46 -  val tvar_prefix: string
   22.47 -  val tfree_prefix: string
   22.48 -  val const_prefix: string
   22.49 -  val type_const_prefix: string
   22.50 -  val class_prefix: string
   22.51 -  val new_skolem_const_prefix : string
   22.52 -  val invert_const: string -> string
   22.53 -  val ascii_of: string -> string
   22.54 -  val unascii_of: string -> string
   22.55 -  val strip_prefix_and_unascii: string -> string -> string option
   22.56 -  val make_bound_var : string -> string
   22.57 -  val make_schematic_var : string * int -> string
   22.58 -  val make_fixed_var : string -> string
   22.59 -  val make_schematic_type_var : string * int -> string
   22.60 -  val make_fixed_type_var : string -> string
   22.61 -  val make_fixed_const : string -> string
   22.62 -  val make_fixed_type_const : string -> string
   22.63 -  val make_type_class : string -> string
   22.64 -  val num_type_args: theory -> string -> int
   22.65 -  val new_skolem_var_from_const: string -> indexname
   22.66 -  val type_literals_for_types : typ list -> type_literal list
   22.67 -  val make_class_rel_clauses :
   22.68 -    theory -> class list -> class list -> class_rel_clause list
   22.69 -  val make_arity_clauses :
   22.70 -    theory -> string list -> class list -> class list * arity_clause list
   22.71 -  val combtyp_of : combterm -> combtyp
   22.72 -  val strip_combterm_comb : combterm -> combterm * combterm list
   22.73 -  val combterm_from_term :
   22.74 -    theory -> int -> (string * typ) list -> term -> combterm * typ list
   22.75 -  val reveal_old_skolem_terms : (string * term) list -> term -> term
   22.76 -  val tfree_classes_of_terms : term list -> string list
   22.77 -  val tvar_classes_of_terms : term list -> string list
   22.78 -  val type_consts_of_terms : theory -> term list -> string list
   22.79 -  val string_of_mode : mode -> string
   22.80 -  val build_logic_map :
   22.81 -    mode -> Proof.context -> bool -> thm list -> thm list list
   22.82 -    -> mode * logic_map
   22.83 -end
   22.84 -
   22.85 -structure Metis_Translate : METIS_TRANSLATE =
   22.86 -struct
   22.87 -
   22.88 -val type_wrapper_name = "ti"
   22.89 -
   22.90 -val bound_var_prefix = "B_"
   22.91 -val schematic_var_prefix = "V_"
   22.92 -val fixed_var_prefix = "v_"
   22.93 -
   22.94 -val tvar_prefix = "T_";
   22.95 -val tfree_prefix = "t_";
   22.96 -
   22.97 -val const_prefix = "c_";
   22.98 -val type_const_prefix = "tc_";
   22.99 -val class_prefix = "class_";
  22.100 -
  22.101 -val skolem_const_prefix = "Sledgehammer" ^ Long_Name.separator ^ "Sko"
  22.102 -val old_skolem_const_prefix = skolem_const_prefix ^ "o"
  22.103 -val new_skolem_const_prefix = skolem_const_prefix ^ "n"
  22.104 -
  22.105 -fun union_all xss = fold (union (op =)) xss []
  22.106 -
  22.107 -(* Readable names for the more common symbolic functions. Do not mess with the
  22.108 -   last nine entries of the table unless you know what you are doing. *)
  22.109 -val const_trans_table =
  22.110 -  Symtab.make [(@{type_name Product_Type.prod}, "prod"),
  22.111 -               (@{type_name Sum_Type.sum}, "sum"),
  22.112 -               (@{const_name HOL.eq}, "equal"),
  22.113 -               (@{const_name HOL.conj}, "and"),
  22.114 -               (@{const_name HOL.disj}, "or"),
  22.115 -               (@{const_name HOL.implies}, "implies"),
  22.116 -               (@{const_name Set.member}, "member"),
  22.117 -               (@{const_name fequal}, "fequal"),
  22.118 -               (@{const_name COMBI}, "COMBI"),
  22.119 -               (@{const_name COMBK}, "COMBK"),
  22.120 -               (@{const_name COMBB}, "COMBB"),
  22.121 -               (@{const_name COMBC}, "COMBC"),
  22.122 -               (@{const_name COMBS}, "COMBS"),
  22.123 -               (@{const_name True}, "True"),
  22.124 -               (@{const_name False}, "False"),
  22.125 -               (@{const_name If}, "If")]
  22.126 -
  22.127 -(* Invert the table of translations between Isabelle and ATPs. *)
  22.128 -val const_trans_table_inv =
  22.129 -  Symtab.update ("fequal", @{const_name HOL.eq})
  22.130 -                (Symtab.make (map swap (Symtab.dest const_trans_table)))
  22.131 -
  22.132 -val invert_const = perhaps (Symtab.lookup const_trans_table_inv)
  22.133 -
  22.134 -(*Escaping of special characters.
  22.135 -  Alphanumeric characters are left unchanged.
  22.136 -  The character _ goes to __
  22.137 -  Characters in the range ASCII space to / go to _A to _P, respectively.
  22.138 -  Other characters go to _nnn where nnn is the decimal ASCII code.*)
  22.139 -val A_minus_space = Char.ord #"A" - Char.ord #" ";
  22.140 -
  22.141 -fun stringN_of_int 0 _ = ""
  22.142 -  | stringN_of_int k n = stringN_of_int (k-1) (n div 10) ^ Int.toString (n mod 10);
  22.143 -
  22.144 -fun ascii_of_c c =
  22.145 -  if Char.isAlphaNum c then String.str c
  22.146 -  else if c = #"_" then "__"
  22.147 -  else if #" " <= c andalso c <= #"/"
  22.148 -       then "_" ^ String.str (Char.chr (Char.ord c + A_minus_space))
  22.149 -  else ("_" ^ stringN_of_int 3 (Char.ord c))  (*fixed width, in case more digits follow*)
  22.150 -
  22.151 -val ascii_of = String.translate ascii_of_c;
  22.152 -
  22.153 -(** Remove ASCII armouring from names in proof files **)
  22.154 -
  22.155 -(*We don't raise error exceptions because this code can run inside the watcher.
  22.156 -  Also, the errors are "impossible" (hah!)*)
  22.157 -fun unascii_aux rcs [] = String.implode(rev rcs)
  22.158 -  | unascii_aux rcs [#"_"] = unascii_aux (#"_"::rcs) []  (*ERROR*)
  22.159 -      (*Three types of _ escapes: __, _A to _P, _nnn*)
  22.160 -  | unascii_aux rcs (#"_" :: #"_" :: cs) = unascii_aux (#"_"::rcs) cs
  22.161 -  | unascii_aux rcs (#"_" :: c :: cs) =
  22.162 -      if #"A" <= c andalso c<= #"P"  (*translation of #" " to #"/"*)
  22.163 -      then unascii_aux (Char.chr(Char.ord c - A_minus_space) :: rcs) cs
  22.164 -      else
  22.165 -        let val digits = List.take (c::cs, 3) handle Subscript => []
  22.166 -        in
  22.167 -            case Int.fromString (String.implode digits) of
  22.168 -                NONE => unascii_aux (c:: #"_"::rcs) cs  (*ERROR*)
  22.169 -              | SOME n => unascii_aux (Char.chr n :: rcs) (List.drop (cs, 2))
  22.170 -        end
  22.171 -  | unascii_aux rcs (c::cs) = unascii_aux (c::rcs) cs
  22.172 -val unascii_of = unascii_aux [] o String.explode
  22.173 -
  22.174 -(* If string s has the prefix s1, return the result of deleting it,
  22.175 -   un-ASCII'd. *)
  22.176 -fun strip_prefix_and_unascii s1 s =
  22.177 -  if String.isPrefix s1 s then
  22.178 -    SOME (unascii_of (String.extract (s, size s1, NONE)))
  22.179 -  else
  22.180 -    NONE
  22.181 -
  22.182 -(*Remove the initial ' character from a type variable, if it is present*)
  22.183 -fun trim_type_var s =
  22.184 -  if s <> "" andalso String.sub(s,0) = #"'" then String.extract(s,1,NONE)
  22.185 -  else error ("trim_type: Malformed type variable encountered: " ^ s);
  22.186 -
  22.187 -fun ascii_of_indexname (v,0) = ascii_of v
  22.188 -  | ascii_of_indexname (v,i) = ascii_of v ^ "_" ^ Int.toString i;
  22.189 -
  22.190 -fun make_bound_var x = bound_var_prefix ^ ascii_of x
  22.191 -fun make_schematic_var v = schematic_var_prefix ^ ascii_of_indexname v
  22.192 -fun make_fixed_var x = fixed_var_prefix ^ ascii_of x
  22.193 -
  22.194 -fun make_schematic_type_var (x,i) =
  22.195 -      tvar_prefix ^ (ascii_of_indexname (trim_type_var x,i));
  22.196 -fun make_fixed_type_var x = tfree_prefix ^ (ascii_of (trim_type_var x));
  22.197 -
  22.198 -fun lookup_const c =
  22.199 -  case Symtab.lookup const_trans_table c of
  22.200 -    SOME c' => c'
  22.201 -  | NONE => ascii_of c
  22.202 -
  22.203 -(* HOL.eq MUST BE "equal" because it's built into ATPs. *)
  22.204 -fun make_fixed_const @{const_name HOL.eq} = "equal"
  22.205 -  | make_fixed_const c = const_prefix ^ lookup_const c
  22.206 -
  22.207 -fun make_fixed_type_const c = type_const_prefix ^ lookup_const c
  22.208 -
  22.209 -fun make_type_class clas = class_prefix ^ ascii_of clas;
  22.210 -
  22.211 -(* The number of type arguments of a constant, zero if it's monomorphic. For
  22.212 -   (instances of) Skolem pseudoconstants, this information is encoded in the
  22.213 -   constant name. *)
  22.214 -fun num_type_args thy s =
  22.215 -  if String.isPrefix skolem_const_prefix s then
  22.216 -    s |> space_explode Long_Name.separator |> List.last |> Int.fromString |> the
  22.217 -  else
  22.218 -    (s, Sign.the_const_type thy s) |> Sign.const_typargs thy |> length
  22.219 -
  22.220 -fun new_skolem_var_from_const s =
  22.221 -  let
  22.222 -    val ss = s |> space_explode Long_Name.separator
  22.223 -    val n = length ss
  22.224 -  in (nth ss (n - 2), nth ss (n - 3) |> Int.fromString |> the) end
  22.225 -
  22.226 -
  22.227 -(**** Definitions and functions for FOL clauses for TPTP format output ****)
  22.228 -
  22.229 -type name = string * string
  22.230 -
  22.231 -(**** Isabelle FOL clauses ****)
  22.232 -
  22.233 -(* The first component is the type class; the second is a TVar or TFree. *)
  22.234 -datatype type_literal =
  22.235 -  TyLitVar of name * name |
  22.236 -  TyLitFree of name * name
  22.237 -
  22.238 -(*Make literals for sorted type variables*)
  22.239 -fun sorts_on_typs_aux (_, [])   = []
  22.240 -  | sorts_on_typs_aux ((x,i),  s::ss) =
  22.241 -      let val sorts = sorts_on_typs_aux ((x,i), ss)
  22.242 -      in
  22.243 -          if s = "HOL.type" then sorts
  22.244 -          else if i = ~1 then TyLitFree (`make_type_class s, `make_fixed_type_var x) :: sorts
  22.245 -          else TyLitVar (`make_type_class s, (make_schematic_type_var (x,i), x)) :: sorts
  22.246 -      end;
  22.247 -
  22.248 -fun sorts_on_typs (TFree (a,s)) = sorts_on_typs_aux ((a,~1),s)
  22.249 -  | sorts_on_typs (TVar (v,s))  = sorts_on_typs_aux (v,s);
  22.250 -
  22.251 -(*Given a list of sorted type variables, return a list of type literals.*)
  22.252 -fun type_literals_for_types Ts =
  22.253 -  fold (union (op =)) (map sorts_on_typs Ts) []
  22.254 -
  22.255 -(** make axiom and conjecture clauses. **)
  22.256 -
  22.257 -(**** Isabelle arities ****)
  22.258 -
  22.259 -datatype arLit =
  22.260 -  TConsLit of name * name * name list |
  22.261 -  TVarLit of name * name
  22.262 -
  22.263 -datatype arity_clause =
  22.264 -  ArityClause of {name: string, conclLit: arLit, premLits: arLit list}
  22.265 -
  22.266 -
  22.267 -fun gen_TVars 0 = []
  22.268 -  | gen_TVars n = ("T_" ^ Int.toString n) :: gen_TVars (n-1);
  22.269 -
  22.270 -fun pack_sort(_,[])  = []
  22.271 -  | pack_sort(tvar, "HOL.type"::srt) = pack_sort (tvar, srt)   (*IGNORE sort "type"*)
  22.272 -  | pack_sort(tvar, cls::srt) =
  22.273 -    (`make_type_class cls, (tvar, tvar)) :: pack_sort (tvar, srt)
  22.274 -
  22.275 -(*Arity of type constructor tcon :: (arg1,...,argN)res*)
  22.276 -fun make_axiom_arity_clause (tcons, name, (cls,args)) =
  22.277 -  let
  22.278 -    val tvars = gen_TVars (length args)
  22.279 -    val tvars_srts = ListPair.zip (tvars, args)
  22.280 -  in
  22.281 -    ArityClause {name = name,
  22.282 -                 conclLit = TConsLit (`make_type_class cls,
  22.283 -                                      `make_fixed_type_const tcons,
  22.284 -                                      tvars ~~ tvars),
  22.285 -                 premLits = map TVarLit (union_all (map pack_sort tvars_srts))}
  22.286 -  end
  22.287 -
  22.288 -
  22.289 -(**** Isabelle class relations ****)
  22.290 -
  22.291 -datatype class_rel_clause =
  22.292 -  ClassRelClause of {name: string, subclass: name, superclass: name}
  22.293 -
  22.294 -(*Generate all pairs (sub,super) such that sub is a proper subclass of super in theory thy.*)
  22.295 -fun class_pairs _ [] _ = []
  22.296 -  | class_pairs thy subs supers =
  22.297 -      let
  22.298 -        val class_less = Sorts.class_less (Sign.classes_of thy)
  22.299 -        fun add_super sub super = class_less (sub, super) ? cons (sub, super)
  22.300 -        fun add_supers sub = fold (add_super sub) supers
  22.301 -      in fold add_supers subs [] end
  22.302 -
  22.303 -fun make_class_rel_clause (sub,super) =
  22.304 -  ClassRelClause {name = sub ^ "_" ^ super,
  22.305 -                  subclass = `make_type_class sub,
  22.306 -                  superclass = `make_type_class super}
  22.307 -
  22.308 -fun make_class_rel_clauses thy subs supers =
  22.309 -  map make_class_rel_clause (class_pairs thy subs supers);
  22.310 -
  22.311 -
  22.312 -(** Isabelle arities **)
  22.313 -
  22.314 -fun arity_clause _ _ (_, []) = []
  22.315 -  | arity_clause seen n (tcons, ("HOL.type",_)::ars) =  (*ignore*)
  22.316 -      arity_clause seen n (tcons,ars)
  22.317 -  | arity_clause seen n (tcons, (ar as (class,_)) :: ars) =
  22.318 -      if member (op =) seen class then (*multiple arities for the same tycon, class pair*)
  22.319 -          make_axiom_arity_clause (tcons, lookup_const tcons ^ "_" ^ class ^ "_" ^ Int.toString n, ar) ::
  22.320 -          arity_clause seen (n+1) (tcons,ars)
  22.321 -      else
  22.322 -          make_axiom_arity_clause (tcons, lookup_const tcons ^ "_" ^ class, ar) ::
  22.323 -          arity_clause (class::seen) n (tcons,ars)
  22.324 -
  22.325 -fun multi_arity_clause [] = []
  22.326 -  | multi_arity_clause ((tcons, ars) :: tc_arlists) =
  22.327 -      arity_clause [] 1 (tcons, ars) @ multi_arity_clause tc_arlists
  22.328 -
  22.329 -(*Generate all pairs (tycon,class,sorts) such that tycon belongs to class in theory thy
  22.330 -  provided its arguments have the corresponding sorts.*)
  22.331 -fun type_class_pairs thy tycons classes =
  22.332 -  let val alg = Sign.classes_of thy
  22.333 -      fun domain_sorts tycon = Sorts.mg_domain alg tycon o single
  22.334 -      fun add_class tycon class =
  22.335 -        cons (class, domain_sorts tycon class)
  22.336 -        handle Sorts.CLASS_ERROR _ => I
  22.337 -      fun try_classes tycon = (tycon, fold (add_class tycon) classes [])
  22.338 -  in  map try_classes tycons  end;
  22.339 -
  22.340 -(*Proving one (tycon, class) membership may require proving others, so iterate.*)
  22.341 -fun iter_type_class_pairs _ _ [] = ([], [])
  22.342 -  | iter_type_class_pairs thy tycons classes =
  22.343 -      let val cpairs = type_class_pairs thy tycons classes
  22.344 -          val newclasses = union_all (union_all (union_all (map (map #2 o #2) cpairs)))
  22.345 -            |> subtract (op =) classes |> subtract (op =) HOLogic.typeS
  22.346 -          val (classes', cpairs') = iter_type_class_pairs thy tycons newclasses
  22.347 -      in (union (op =) classes' classes, union (op =) cpairs' cpairs) end;
  22.348 -
  22.349 -fun make_arity_clauses thy tycons classes =
  22.350 -  let val (classes', cpairs) = iter_type_class_pairs thy tycons classes
  22.351 -  in  (classes', multi_arity_clause cpairs)  end;
  22.352 -
  22.353 -datatype combtyp =
  22.354 -  CombTVar of name |
  22.355 -  CombTFree of name |
  22.356 -  CombType of name * combtyp list
  22.357 -
  22.358 -datatype combterm =
  22.359 -  CombConst of name * combtyp * combtyp list (* Const and Free *) |
  22.360 -  CombVar of name * combtyp |
  22.361 -  CombApp of combterm * combterm
  22.362 -
  22.363 -datatype fol_literal = FOLLiteral of bool * combterm
  22.364 -
  22.365 -(*********************************************************************)
  22.366 -(* convert a clause with type Term.term to a clause with type clause *)
  22.367 -(*********************************************************************)
  22.368 -
  22.369 -(*Result of a function type; no need to check that the argument type matches.*)
  22.370 -fun result_type (CombType (_, [_, tp2])) = tp2
  22.371 -  | result_type _ = raise Fail "non-function type"
  22.372 -
  22.373 -fun combtyp_of (CombConst (_, tp, _)) = tp
  22.374 -  | combtyp_of (CombVar (_, tp)) = tp
  22.375 -  | combtyp_of (CombApp (t1, _)) = result_type (combtyp_of t1)
  22.376 -
  22.377 -(*gets the head of a combinator application, along with the list of arguments*)
  22.378 -fun strip_combterm_comb u =
  22.379 -    let fun stripc (CombApp(t,u), ts) = stripc (t, u::ts)
  22.380 -        |   stripc  x =  x
  22.381 -    in stripc(u,[]) end
  22.382 -
  22.383 -fun combtype_of (Type (a, Ts)) =
  22.384 -    let val (folTypes, ts) = combtypes_of Ts in
  22.385 -      (CombType (`make_fixed_type_const a, folTypes), ts)
  22.386 -    end
  22.387 -  | combtype_of (tp as TFree (a, _)) = (CombTFree (`make_fixed_type_var a), [tp])
  22.388 -  | combtype_of (tp as TVar (x, _)) =
  22.389 -    (CombTVar (make_schematic_type_var x, string_of_indexname x), [tp])
  22.390 -and combtypes_of Ts =
  22.391 -  let val (folTyps, ts) = ListPair.unzip (map combtype_of Ts) in
  22.392 -    (folTyps, union_all ts)
  22.393 -  end
  22.394 -
  22.395 -(* same as above, but no gathering of sort information *)
  22.396 -fun simple_combtype_of (Type (a, Ts)) =
  22.397 -    CombType (`make_fixed_type_const a, map simple_combtype_of Ts)
  22.398 -  | simple_combtype_of (TFree (a, _)) = CombTFree (`make_fixed_type_var a)
  22.399 -  | simple_combtype_of (TVar (x, _)) =
  22.400 -    CombTVar (make_schematic_type_var x, string_of_indexname x)
  22.401 -
  22.402 -fun new_skolem_const_name th_no s num_T_args =
  22.403 -  [new_skolem_const_prefix, string_of_int th_no, s, string_of_int num_T_args]
  22.404 -  |> space_implode Long_Name.separator
  22.405 -
  22.406 -(* Converts a term (with combinators) into a combterm. Also accummulates sort
  22.407 -   infomation. *)
  22.408 -fun combterm_from_term thy th_no bs (P $ Q) =
  22.409 -      let val (P', tsP) = combterm_from_term thy th_no bs P
  22.410 -          val (Q', tsQ) = combterm_from_term thy th_no bs Q
  22.411 -      in  (CombApp (P', Q'), union (op =) tsP tsQ)  end
  22.412 -  | combterm_from_term thy _ _ (Const (c, T)) =
  22.413 -      let
  22.414 -        val (tp, ts) = combtype_of T
  22.415 -        val tvar_list =
  22.416 -          (if String.isPrefix old_skolem_const_prefix c then
  22.417 -             [] |> Term.add_tvarsT T |> map TVar
  22.418 -           else
  22.419 -             (c, T) |> Sign.const_typargs thy)
  22.420 -          |> map simple_combtype_of
  22.421 -        val c' = CombConst (`make_fixed_const c, tp, tvar_list)
  22.422 -      in  (c',ts)  end
  22.423 -  | combterm_from_term _ _ _ (Free (v, T)) =
  22.424 -      let val (tp, ts) = combtype_of T
  22.425 -          val v' = CombConst (`make_fixed_var v, tp, [])
  22.426 -      in  (v',ts)  end
  22.427 -  | combterm_from_term _ th_no _ (Var (v as (s, _), T)) =
  22.428 -    let
  22.429 -      val (tp, ts) = combtype_of T
  22.430 -      val v' =
  22.431 -        if String.isPrefix Meson_Clausify.new_skolem_var_prefix s then
  22.432 -          let
  22.433 -            val tys = T |> strip_type |> swap |> op ::
  22.434 -            val s' = new_skolem_const_name th_no s (length tys)
  22.435 -          in
  22.436 -            CombConst (`make_fixed_const s', tp, map simple_combtype_of tys)
  22.437 -          end
  22.438 -        else
  22.439 -          CombVar ((make_schematic_var v, string_of_indexname v), tp)
  22.440 -    in (v', ts) end
  22.441 -  | combterm_from_term _ _ bs (Bound j) =
  22.442 -      let
  22.443 -        val (s, T) = nth bs j
  22.444 -        val (tp, ts) = combtype_of T
  22.445 -        val v' = CombConst (`make_bound_var s, tp, [])
  22.446 -      in (v', ts) end
  22.447 -  | combterm_from_term _ _ _ (Abs _) = raise Fail "HOL clause: Abs"
  22.448 -
  22.449 -fun predicate_of thy th_no ((@{const Not} $ P), pos) =
  22.450 -    predicate_of thy th_no (P, not pos)
  22.451 -  | predicate_of thy th_no (t, pos) =
  22.452 -    (combterm_from_term thy th_no [] (Envir.eta_contract t), pos)
  22.453 -
  22.454 -fun literals_of_term1 args thy th_no (@{const Trueprop} $ P) =
  22.455 -    literals_of_term1 args thy th_no P
  22.456 -  | literals_of_term1 args thy th_no (@{const HOL.disj} $ P $ Q) =
  22.457 -    literals_of_term1 (literals_of_term1 args thy th_no P) thy th_no Q
  22.458 -  | literals_of_term1 (lits, ts) thy th_no P =
  22.459 -    let val ((pred, ts'), pol) = predicate_of thy th_no (P, true) in
  22.460 -      (FOLLiteral (pol, pred) :: lits, union (op =) ts ts')
  22.461 -    end
  22.462 -val literals_of_term = literals_of_term1 ([], [])
  22.463 -
  22.464 -fun old_skolem_const_name i j num_T_args =
  22.465 -  old_skolem_const_prefix ^ Long_Name.separator ^
  22.466 -  (space_implode Long_Name.separator (map Int.toString [i, j, num_T_args]))
  22.467 -
  22.468 -fun conceal_old_skolem_terms i old_skolems t =
  22.469 -  if exists_Const (curry (op =) @{const_name skolem} o fst) t then
  22.470 -    let
  22.471 -      fun aux old_skolems
  22.472 -              (t as (Const (@{const_name skolem}, Type (_, [_, T])) $ _)) =
  22.473 -          let
  22.474 -            val (old_skolems, s) =
  22.475 -              if i = ~1 then
  22.476 -                (old_skolems, @{const_name undefined})
  22.477 -              else case AList.find (op aconv) old_skolems t of
  22.478 -                s :: _ => (old_skolems, s)
  22.479 -              | [] =>
  22.480 -                let
  22.481 -                  val s = old_skolem_const_name i (length old_skolems)
  22.482 -                                                (length (Term.add_tvarsT T []))
  22.483 -                in ((s, t) :: old_skolems, s) end
  22.484 -          in (old_skolems, Const (s, T)) end
  22.485 -        | aux old_skolems (t1 $ t2) =
  22.486 -          let
  22.487 -            val (old_skolems, t1) = aux old_skolems t1
  22.488 -            val (old_skolems, t2) = aux old_skolems t2
  22.489 -          in (old_skolems, t1 $ t2) end
  22.490 -        | aux old_skolems (Abs (s, T, t')) =
  22.491 -          let val (old_skolems, t') = aux old_skolems t' in
  22.492 -            (old_skolems, Abs (s, T, t'))
  22.493 -          end
  22.494 -        | aux old_skolems t = (old_skolems, t)
  22.495 -    in aux old_skolems t end
  22.496 -  else
  22.497 -    (old_skolems, t)
  22.498 -
  22.499 -fun reveal_old_skolem_terms old_skolems =
  22.500 -  map_aterms (fn t as Const (s, _) =>
  22.501 -                 if String.isPrefix old_skolem_const_prefix s then
  22.502 -                   AList.lookup (op =) old_skolems s |> the
  22.503 -                   |> map_types Type_Infer.paramify_vars
  22.504 -                 else
  22.505 -                   t
  22.506 -               | t => t)
  22.507 -
  22.508 -
  22.509 -(***************************************************************)
  22.510 -(* Type Classes Present in the Axiom or Conjecture Clauses     *)
  22.511 -(***************************************************************)
  22.512 -
  22.513 -fun set_insert (x, s) = Symtab.update (x, ()) s
  22.514 -
  22.515 -fun add_classes (sorts, cset) = List.foldl set_insert cset (flat sorts)
  22.516 -
  22.517 -(*Remove this trivial type class*)
  22.518 -fun delete_type cset = Symtab.delete_safe (the_single @{sort HOL.type}) cset;
  22.519 -
  22.520 -fun tfree_classes_of_terms ts =
  22.521 -  let val sorts_list = map (map #2 o OldTerm.term_tfrees) ts
  22.522 -  in  Symtab.keys (delete_type (List.foldl add_classes Symtab.empty sorts_list))  end;
  22.523 -
  22.524 -fun tvar_classes_of_terms ts =
  22.525 -  let val sorts_list = map (map #2 o OldTerm.term_tvars) ts
  22.526 -  in  Symtab.keys (delete_type (List.foldl add_classes Symtab.empty sorts_list))  end;
  22.527 -
  22.528 -(*fold type constructors*)
  22.529 -fun fold_type_consts f (Type (a, Ts)) x = fold (fold_type_consts f) Ts (f (a,x))
  22.530 -  | fold_type_consts _ _ x = x;
  22.531 -
  22.532 -(*Type constructors used to instantiate overloaded constants are the only ones needed.*)
  22.533 -fun add_type_consts_in_term thy =
  22.534 -  let
  22.535 -    fun aux (Const x) =
  22.536 -        fold (fold_type_consts set_insert) (Sign.const_typargs thy x)
  22.537 -      | aux (Abs (_, _, u)) = aux u
  22.538 -      | aux (Const (@{const_name skolem}, _) $ _) = I
  22.539 -      | aux (t $ u) = aux t #> aux u
  22.540 -      | aux _ = I
  22.541 -  in aux end
  22.542 -
  22.543 -fun type_consts_of_terms thy ts =
  22.544 -  Symtab.keys (fold (add_type_consts_in_term thy) ts Symtab.empty);
  22.545 -
  22.546 -(* ------------------------------------------------------------------------- *)
  22.547 -(* HOL to FOL  (Isabelle to Metis)                                           *)
  22.548 -(* ------------------------------------------------------------------------- *)
  22.549 -
  22.550 -datatype mode = FO | HO | FT  (* first-order, higher-order, fully-typed *)
  22.551 -
  22.552 -fun string_of_mode FO = "FO"
  22.553 -  | string_of_mode HO = "HO"
  22.554 -  | string_of_mode FT = "FT"
  22.555 -
  22.556 -fun fn_isa_to_met_sublevel "equal" = "=" (* FIXME: "c_fequal" *)
  22.557 -  | fn_isa_to_met_sublevel x = x
  22.558 -fun fn_isa_to_met_toplevel "equal" = "="
  22.559 -  | fn_isa_to_met_toplevel x = x
  22.560 -
  22.561 -fun metis_lit b c args = (b, (c, args));
  22.562 -
  22.563 -fun metis_term_from_combtyp (CombTVar (s, _)) = Metis_Term.Var s
  22.564 -  | metis_term_from_combtyp (CombTFree (s, _)) = Metis_Term.Fn (s, [])
  22.565 -  | metis_term_from_combtyp (CombType ((s, _), tps)) =
  22.566 -    Metis_Term.Fn (s, map metis_term_from_combtyp tps);
  22.567 -
  22.568 -(*These two functions insert type literals before the real literals. That is the
  22.569 -  opposite order from TPTP linkup, but maybe OK.*)
  22.570 -
  22.571 -fun hol_term_to_fol_FO tm =
  22.572 -  case strip_combterm_comb tm of
  22.573 -      (CombConst ((c, _), _, tys), tms) =>
  22.574 -        let val tyargs = map metis_term_from_combtyp tys
  22.575 -            val args   = map hol_term_to_fol_FO tms
  22.576 -        in Metis_Term.Fn (c, tyargs @ args) end
  22.577 -    | (CombVar ((v, _), _), []) => Metis_Term.Var v
  22.578 -    | _ => raise Fail "non-first-order combterm"
  22.579 -
  22.580 -fun hol_term_to_fol_HO (CombConst ((a, _), _, tylist)) =
  22.581 -      Metis_Term.Fn (fn_isa_to_met_sublevel a, map metis_term_from_combtyp tylist)
  22.582 -  | hol_term_to_fol_HO (CombVar ((s, _), _)) = Metis_Term.Var s
  22.583 -  | hol_term_to_fol_HO (CombApp (tm1, tm2)) =
  22.584 -       Metis_Term.Fn (".", map hol_term_to_fol_HO [tm1, tm2]);
  22.585 -
  22.586 -(*The fully-typed translation, to avoid type errors*)
  22.587 -fun wrap_type (tm, ty) =
  22.588 -  Metis_Term.Fn (type_wrapper_name, [tm, metis_term_from_combtyp ty])
  22.589 -
  22.590 -fun hol_term_to_fol_FT (CombVar ((s, _), ty)) = wrap_type (Metis_Term.Var s, ty)
  22.591 -  | hol_term_to_fol_FT (CombConst((a, _), ty, _)) =
  22.592 -      wrap_type (Metis_Term.Fn(fn_isa_to_met_sublevel a, []), ty)
  22.593 -  | hol_term_to_fol_FT (tm as CombApp(tm1,tm2)) =
  22.594 -       wrap_type (Metis_Term.Fn(".", map hol_term_to_fol_FT [tm1,tm2]),
  22.595 -                  combtyp_of tm)
  22.596 -
  22.597 -fun hol_literal_to_fol FO (FOLLiteral (pos, tm)) =
  22.598 -      let val (CombConst((p, _), _, tys), tms) = strip_combterm_comb tm
  22.599 -          val tylits = if p = "equal" then [] else map metis_term_from_combtyp tys
  22.600 -          val lits = map hol_term_to_fol_FO tms
  22.601 -      in metis_lit pos (fn_isa_to_met_toplevel p) (tylits @ lits) end
  22.602 -  | hol_literal_to_fol HO (FOLLiteral (pos, tm)) =
  22.603 -     (case strip_combterm_comb tm of
  22.604 -          (CombConst(("equal", _), _, _), tms) =>
  22.605 -            metis_lit pos "=" (map hol_term_to_fol_HO tms)
  22.606 -        | _ => metis_lit pos "{}" [hol_term_to_fol_HO tm])   (*hBOOL*)
  22.607 -  | hol_literal_to_fol FT (FOLLiteral (pos, tm)) =
  22.608 -     (case strip_combterm_comb tm of
  22.609 -          (CombConst(("equal", _), _, _), tms) =>
  22.610 -            metis_lit pos "=" (map hol_term_to_fol_FT tms)
  22.611 -        | _ => metis_lit pos "{}" [hol_term_to_fol_FT tm])   (*hBOOL*);
  22.612 -
  22.613 -fun literals_of_hol_term thy th_no mode t =
  22.614 -      let val (lits, types_sorts) = literals_of_term thy th_no t
  22.615 -      in  (map (hol_literal_to_fol mode) lits, types_sorts) end;
  22.616 -
  22.617 -(*Sign should be "true" for conjecture type constraints, "false" for type lits in clauses.*)
  22.618 -fun metis_of_type_literals pos (TyLitVar ((s, _), (s', _))) =
  22.619 -    metis_lit pos s [Metis_Term.Var s']
  22.620 -  | metis_of_type_literals pos (TyLitFree ((s, _), (s', _))) =
  22.621 -    metis_lit pos s [Metis_Term.Fn (s',[])]
  22.622 -
  22.623 -fun default_sort _ (TVar _) = false
  22.624 -  | default_sort ctxt (TFree (x, s)) = (s = the_default [] (Variable.def_sort ctxt (x, ~1)));
  22.625 -
  22.626 -fun metis_of_tfree tf =
  22.627 -  Metis_Thm.axiom (Metis_LiteralSet.singleton (metis_of_type_literals true tf));
  22.628 -
  22.629 -fun hol_thm_to_fol is_conjecture th_no ctxt type_lits mode j old_skolems th =
  22.630 -  let
  22.631 -    val thy = ProofContext.theory_of ctxt
  22.632 -    val (old_skolems, (mlits, types_sorts)) =
  22.633 -     th |> prop_of |> Logic.strip_imp_concl
  22.634 -        |> conceal_old_skolem_terms j old_skolems
  22.635 -        ||> (HOLogic.dest_Trueprop #> literals_of_hol_term thy th_no mode)
  22.636 -  in
  22.637 -    if is_conjecture then
  22.638 -      (Metis_Thm.axiom (Metis_LiteralSet.fromList mlits),
  22.639 -       type_literals_for_types types_sorts, old_skolems)
  22.640 -    else
  22.641 -      let
  22.642 -        val tylits = filter_out (default_sort ctxt) types_sorts
  22.643 -                     |> type_literals_for_types
  22.644 -        val mtylits =
  22.645 -          if type_lits then map (metis_of_type_literals false) tylits else []
  22.646 -      in
  22.647 -        (Metis_Thm.axiom (Metis_LiteralSet.fromList(mtylits @ mlits)), [],
  22.648 -         old_skolems)
  22.649 -      end
  22.650 -  end;
  22.651 -
  22.652 -val helpers =
  22.653 -  [("c_COMBI", (false, map (`I) @{thms COMBI_def})),
  22.654 -   ("c_COMBK", (false, map (`I) @{thms COMBK_def})),
  22.655 -   ("c_COMBB", (false, map (`I) @{thms COMBB_def})),
  22.656 -   ("c_COMBC", (false, map (`I) @{thms COMBC_def})),
  22.657 -   ("c_COMBS", (false, map (`I) @{thms COMBS_def})),
  22.658 -   ("c_fequal", (false, map (rpair @{thm equal_imp_equal})
  22.659 -                            @{thms fequal_imp_equal equal_imp_fequal})),
  22.660 -   ("c_True", (true, map (`I) @{thms True_or_False})),
  22.661 -   ("c_False", (true, map (`I) @{thms True_or_False})),
  22.662 -   ("c_If", (true, map (`I) @{thms if_True if_False True_or_False}))]
  22.663 -
  22.664 -(* ------------------------------------------------------------------------- *)
  22.665 -(* Logic maps manage the interface between HOL and first-order logic.        *)
  22.666 -(* ------------------------------------------------------------------------- *)
  22.667 -
  22.668 -type logic_map =
  22.669 -  {axioms: (Metis_Thm.thm * thm) list,
  22.670 -   tfrees: type_literal list,
  22.671 -   old_skolems: (string * term) list}
  22.672 -
  22.673 -fun is_quasi_fol_clause thy =
  22.674 -  Meson.is_fol_term thy o snd o conceal_old_skolem_terms ~1 [] o prop_of
  22.675 -
  22.676 -(*Extract TFree constraints from context to include as conjecture clauses*)
  22.677 -fun init_tfrees ctxt =
  22.678 -  let fun add ((a,i),s) Ts = if i = ~1 then TFree(a,s) :: Ts else Ts in
  22.679 -    Vartab.fold add (#2 (Variable.constraints_of ctxt)) []
  22.680 -    |> type_literals_for_types
  22.681 -  end;
  22.682 -
  22.683 -(*Insert non-logical axioms corresponding to all accumulated TFrees*)
  22.684 -fun add_tfrees {axioms, tfrees, old_skolems} : logic_map =
  22.685 -     {axioms = map (rpair TrueI o metis_of_tfree) (distinct (op =) tfrees) @
  22.686 -               axioms,
  22.687 -      tfrees = tfrees, old_skolems = old_skolems}
  22.688 -
  22.689 -(*transform isabelle type / arity clause to metis clause *)
  22.690 -fun add_type_thm [] lmap = lmap
  22.691 -  | add_type_thm ((ith, mth) :: cls) {axioms, tfrees, old_skolems} =
  22.692 -      add_type_thm cls {axioms = (mth, ith) :: axioms, tfrees = tfrees,
  22.693 -                        old_skolems = old_skolems}
  22.694 -
  22.695 -fun const_in_metis c (pred, tm_list) =
  22.696 -  let
  22.697 -    fun in_mterm (Metis_Term.Var _) = false
  22.698 -      | in_mterm (Metis_Term.Fn (".", tm_list)) = exists in_mterm tm_list
  22.699 -      | in_mterm (Metis_Term.Fn (nm, tm_list)) = c=nm orelse exists in_mterm tm_list
  22.700 -  in  c = pred orelse exists in_mterm tm_list  end;
  22.701 -
  22.702 -(* ARITY CLAUSE *)
  22.703 -fun m_arity_cls (TConsLit ((c, _), (t, _), args)) =
  22.704 -    metis_lit true c [Metis_Term.Fn(t, map (Metis_Term.Var o fst) args)]
  22.705 -  | m_arity_cls (TVarLit ((c, _), (s, _))) =
  22.706 -    metis_lit false c [Metis_Term.Var s]
  22.707 -(*TrueI is returned as the Isabelle counterpart because there isn't any.*)
  22.708 -fun arity_cls (ArityClause {conclLit, premLits, ...}) =
  22.709 -  (TrueI,
  22.710 -   Metis_Thm.axiom (Metis_LiteralSet.fromList (map m_arity_cls (conclLit :: premLits))));
  22.711 -
  22.712 -(* CLASSREL CLAUSE *)
  22.713 -fun m_class_rel_cls (subclass, _) (superclass, _) =
  22.714 -  [metis_lit false subclass [Metis_Term.Var "T"], metis_lit true superclass [Metis_Term.Var "T"]];
  22.715 -fun class_rel_cls (ClassRelClause {subclass, superclass, ...}) =
  22.716 -  (TrueI, Metis_Thm.axiom (Metis_LiteralSet.fromList (m_class_rel_cls subclass superclass)));
  22.717 -
  22.718 -fun type_ext thy tms =
  22.719 -  let val subs = tfree_classes_of_terms tms
  22.720 -      val supers = tvar_classes_of_terms tms
  22.721 -      and tycons = type_consts_of_terms thy tms
  22.722 -      val (supers', arity_clauses) = make_arity_clauses thy tycons supers
  22.723 -      val class_rel_clauses = make_class_rel_clauses thy subs supers'
  22.724 -  in  map class_rel_cls class_rel_clauses @ map arity_cls arity_clauses
  22.725 -  end;
  22.726 -
  22.727 -(* Function to generate metis clauses, including comb and type clauses *)
  22.728 -fun build_logic_map mode0 ctxt type_lits cls thss =
  22.729 -  let val thy = ProofContext.theory_of ctxt
  22.730 -      (*The modes FO and FT are sticky. HO can be downgraded to FO.*)
  22.731 -      fun set_mode FO = FO
  22.732 -        | set_mode HO =
  22.733 -          if forall (forall (is_quasi_fol_clause thy)) (cls :: thss) then FO
  22.734 -          else HO
  22.735 -        | set_mode FT = FT
  22.736 -      val mode = set_mode mode0
  22.737 -      (*transform isabelle clause to metis clause *)
  22.738 -      fun add_thm th_no is_conjecture (metis_ith, isa_ith)
  22.739 -                  {axioms, tfrees, old_skolems} : logic_map =
  22.740 -        let
  22.741 -          val (mth, tfree_lits, old_skolems) =
  22.742 -            hol_thm_to_fol is_conjecture th_no ctxt type_lits mode (length axioms)
  22.743 -                           old_skolems metis_ith
  22.744 -        in
  22.745 -           {axioms = (mth, Meson.make_meta_clause isa_ith) :: axioms,
  22.746 -            tfrees = union (op =) tfree_lits tfrees, old_skolems = old_skolems}
  22.747 -        end;
  22.748 -      val lmap = {axioms = [], tfrees = init_tfrees ctxt, old_skolems = []}
  22.749 -                 |> fold (add_thm 0 true o `I) cls
  22.750 -                 |> add_tfrees
  22.751 -                 |> fold (fn (th_no, ths) => fold (add_thm th_no false o `I) ths)
  22.752 -                         (1 upto length thss ~~ thss)
  22.753 -      val clause_lists = map (Metis_Thm.clause o #1) (#axioms lmap)
  22.754 -      fun is_used c =
  22.755 -        exists (Metis_LiteralSet.exists (const_in_metis c o #2)) clause_lists
  22.756 -      val lmap =
  22.757 -        if mode = FO then
  22.758 -          lmap
  22.759 -        else
  22.760 -          let
  22.761 -            val helper_ths =
  22.762 -              helpers |> filter (is_used o fst)
  22.763 -                      |> maps (fn (c, (needs_full_types, thms)) =>
  22.764 -                                  if not (is_used c) orelse
  22.765 -                                     needs_full_types andalso mode <> FT then
  22.766 -                                    []
  22.767 -                                  else
  22.768 -                                    thms)
  22.769 -          in lmap |> fold (add_thm ~1 false) helper_ths end
  22.770 -  in
  22.771 -    (mode, add_type_thm (type_ext thy (maps (map prop_of) (cls :: thss))) lmap)
  22.772 -  end
  22.773 -
  22.774 -end;
    23.1 --- a/src/HOL/Tools/Sledgehammer/sledgehammer_filter.ML	Wed Oct 06 13:48:12 2010 +0200
    23.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_filter.ML	Wed Oct 06 17:44:21 2010 +0200
    23.3 @@ -1,6 +1,8 @@
    23.4  (*  Title:      HOL/Tools/Sledgehammer/sledgehammer_filter.ML
    23.5      Author:     Jia Meng, Cambridge University Computer Laboratory and NICTA
    23.6      Author:     Jasmin Blanchette, TU Muenchen
    23.7 +
    23.8 +Sledgehammer's relevance filter.
    23.9  *)
   23.10  
   23.11  signature SLEDGEHAMMER_FILTER =
   23.12 @@ -585,6 +587,7 @@
   23.13  fun is_formula_too_complex t =
   23.14    apply_depth t > max_apply_depth orelse formula_has_too_many_lambdas [] t
   23.15  
   23.16 +(* FIXME: Extend to "Meson" and "Metis" *)
   23.17  val exists_sledgehammer_const =
   23.18    exists_Const (fn (s, _) => String.isPrefix sledgehammer_prefix s)
   23.19  
    24.1 --- a/src/HOL/Tools/Sledgehammer/sledgehammer_reconstruct.ML	Wed Oct 06 13:48:12 2010 +0200
    24.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_reconstruct.ML	Wed Oct 06 17:44:21 2010 +0200
    24.3 @@ -370,11 +370,11 @@
    24.4      pair (raw_term_from_pred thy full_types tfrees u)
    24.5  
    24.6  val combinator_table =
    24.7 -  [(@{const_name COMBI}, @{thm COMBI_def_raw}),
    24.8 -   (@{const_name COMBK}, @{thm COMBK_def_raw}),
    24.9 -   (@{const_name COMBB}, @{thm COMBB_def_raw}),
   24.10 -   (@{const_name COMBC}, @{thm COMBC_def_raw}),
   24.11 -   (@{const_name COMBS}, @{thm COMBS_def_raw})]
   24.12 +  [(@{const_name Meson.COMBI}, @{thm Meson.COMBI_def_raw}),
   24.13 +   (@{const_name Meson.COMBK}, @{thm Meson.COMBK_def_raw}),
   24.14 +   (@{const_name Meson.COMBB}, @{thm Meson.COMBB_def_raw}),
   24.15 +   (@{const_name Meson.COMBC}, @{thm Meson.COMBC_def_raw}),
   24.16 +   (@{const_name Meson.COMBS}, @{thm Meson.COMBS_def_raw})]
   24.17  
   24.18  fun uncombine_term (t1 $ t2) = betapply (pairself uncombine_term (t1, t2))
   24.19    | uncombine_term (Abs (s, T, t')) = Abs (s, T, uncombine_term t')
    25.1 --- a/src/HOL/Tools/Sledgehammer/sledgehammer_translate.ML	Wed Oct 06 13:48:12 2010 +0200
    25.2 +++ b/src/HOL/Tools/Sledgehammer/sledgehammer_translate.ML	Wed Oct 06 17:44:21 2010 +0200
    25.3 @@ -222,15 +222,15 @@
    25.4    count_combformula combformula
    25.5  
    25.6  val optional_helpers =
    25.7 -  [(["c_COMBI"], @{thms COMBI_def}),
    25.8 -   (["c_COMBK"], @{thms COMBK_def}),
    25.9 -   (["c_COMBB"], @{thms COMBB_def}),
   25.10 -   (["c_COMBC"], @{thms COMBC_def}),
   25.11 -   (["c_COMBS"], @{thms COMBS_def})]
   25.12 +  [(["c_COMBI"], @{thms Meson.COMBI_def}),
   25.13 +   (["c_COMBK"], @{thms Meson.COMBK_def}),
   25.14 +   (["c_COMBB"], @{thms Meson.COMBB_def}),
   25.15 +   (["c_COMBC"], @{thms Meson.COMBC_def}),
   25.16 +   (["c_COMBS"], @{thms Meson.COMBS_def})]
   25.17  val optional_typed_helpers =
   25.18    [(["c_True", "c_False", "c_If"], @{thms True_or_False}),
   25.19     (["c_If"], @{thms if_True if_False})]
   25.20 -val mandatory_helpers = @{thms fequal_def}
   25.21 +val mandatory_helpers = @{thms Metis.fequal_def}
   25.22  
   25.23  val init_counters =
   25.24    [optional_helpers, optional_typed_helpers] |> maps (maps fst)
   25.25 @@ -300,7 +300,7 @@
   25.26              let val ty_args = if full_types then [] else ty_args in
   25.27                if s = "equal" then
   25.28                  if top_level andalso length args = 2 then (name, [])
   25.29 -                else (("c_fequal", @{const_name fequal}), ty_args)
   25.30 +                else (("c_fequal", @{const_name Metis.fequal}), ty_args)
   25.31                else if top_level then
   25.32                  case s of
   25.33                    "c_False" => (("$false", s'), [])
    26.1 --- a/src/HOL/Tools/meson.ML	Wed Oct 06 13:48:12 2010 +0200
    26.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    26.3 @@ -1,702 +0,0 @@
    26.4 -(*  Title:      HOL/Tools/meson.ML
    26.5 -    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    26.6 -
    26.7 -The MESON resolution proof procedure for HOL.
    26.8 -When making clauses, avoids using the rewriter -- instead uses RS recursively.
    26.9 -*)
   26.10 -
   26.11 -signature MESON =
   26.12 -sig
   26.13 -  val trace: bool Unsynchronized.ref
   26.14 -  val term_pair_of: indexname * (typ * 'a) -> term * 'a
   26.15 -  val size_of_subgoals: thm -> int
   26.16 -  val has_too_many_clauses: Proof.context -> term -> bool
   26.17 -  val make_cnf: thm list -> thm -> Proof.context -> thm list * Proof.context
   26.18 -  val finish_cnf: thm list -> thm list
   26.19 -  val presimplify: thm -> thm
   26.20 -  val make_nnf: Proof.context -> thm -> thm
   26.21 -  val skolemize_with_choice_thms : Proof.context -> thm list -> thm -> thm
   26.22 -  val skolemize : Proof.context -> thm -> thm
   26.23 -  val is_fol_term: theory -> term -> bool
   26.24 -  val make_clauses_unsorted: thm list -> thm list
   26.25 -  val make_clauses: thm list -> thm list
   26.26 -  val make_horns: thm list -> thm list
   26.27 -  val best_prolog_tac: (thm -> int) -> thm list -> tactic
   26.28 -  val depth_prolog_tac: thm list -> tactic
   26.29 -  val gocls: thm list -> thm list
   26.30 -  val skolemize_prems_tac : Proof.context -> thm list -> int -> tactic
   26.31 -  val MESON:
   26.32 -    tactic -> (thm list -> thm list) -> (thm list -> tactic) -> Proof.context
   26.33 -    -> int -> tactic
   26.34 -  val best_meson_tac: (thm -> int) -> Proof.context -> int -> tactic
   26.35 -  val safe_best_meson_tac: Proof.context -> int -> tactic
   26.36 -  val depth_meson_tac: Proof.context -> int -> tactic
   26.37 -  val prolog_step_tac': thm list -> int -> tactic
   26.38 -  val iter_deepen_prolog_tac: thm list -> tactic
   26.39 -  val iter_deepen_meson_tac: Proof.context -> thm list -> int -> tactic
   26.40 -  val make_meta_clause: thm -> thm
   26.41 -  val make_meta_clauses: thm list -> thm list
   26.42 -  val meson_tac: Proof.context -> thm list -> int -> tactic
   26.43 -  val setup: theory -> theory
   26.44 -end
   26.45 -
   26.46 -structure Meson : MESON =
   26.47 -struct
   26.48 -
   26.49 -val trace = Unsynchronized.ref false;
   26.50 -fun trace_msg msg = if ! trace then tracing (msg ()) else ();
   26.51 -
   26.52 -val max_clauses_default = 60;
   26.53 -val (max_clauses, setup) = Attrib.config_int "meson_max_clauses" (K max_clauses_default);
   26.54 -
   26.55 -(*No known example (on 1-5-2007) needs even thirty*)
   26.56 -val iter_deepen_limit = 50;
   26.57 -
   26.58 -val disj_forward = @{thm disj_forward};
   26.59 -val disj_forward2 = @{thm disj_forward2};
   26.60 -val make_pos_rule = @{thm make_pos_rule};
   26.61 -val make_pos_rule' = @{thm make_pos_rule'};
   26.62 -val make_pos_goal = @{thm make_pos_goal};
   26.63 -val make_neg_rule = @{thm make_neg_rule};
   26.64 -val make_neg_rule' = @{thm make_neg_rule'};
   26.65 -val make_neg_goal = @{thm make_neg_goal};
   26.66 -val conj_forward = @{thm conj_forward};
   26.67 -val all_forward = @{thm all_forward};
   26.68 -val ex_forward = @{thm ex_forward};
   26.69 -
   26.70 -val not_conjD = @{thm meson_not_conjD};
   26.71 -val not_disjD = @{thm meson_not_disjD};
   26.72 -val not_notD = @{thm meson_not_notD};
   26.73 -val not_allD = @{thm meson_not_allD};
   26.74 -val not_exD = @{thm meson_not_exD};
   26.75 -val imp_to_disjD = @{thm meson_imp_to_disjD};
   26.76 -val not_impD = @{thm meson_not_impD};
   26.77 -val iff_to_disjD = @{thm meson_iff_to_disjD};
   26.78 -val not_iffD = @{thm meson_not_iffD};
   26.79 -val conj_exD1 = @{thm meson_conj_exD1};
   26.80 -val conj_exD2 = @{thm meson_conj_exD2};
   26.81 -val disj_exD = @{thm meson_disj_exD};
   26.82 -val disj_exD1 = @{thm meson_disj_exD1};
   26.83 -val disj_exD2 = @{thm meson_disj_exD2};
   26.84 -val disj_assoc = @{thm meson_disj_assoc};
   26.85 -val disj_comm = @{thm meson_disj_comm};
   26.86 -val disj_FalseD1 = @{thm meson_disj_FalseD1};
   26.87 -val disj_FalseD2 = @{thm meson_disj_FalseD2};
   26.88 -
   26.89 -
   26.90 -(**** Operators for forward proof ****)
   26.91 -
   26.92 -
   26.93 -(** First-order Resolution **)
   26.94 -
   26.95 -fun term_pair_of (ix, (ty,t)) = (Var (ix,ty), t);
   26.96 -
   26.97 -(*FIXME: currently does not "rename variables apart"*)
   26.98 -fun first_order_resolve thA thB =
   26.99 -  (case
  26.100 -    try (fn () =>
  26.101 -      let val thy = theory_of_thm thA
  26.102 -          val tmA = concl_of thA
  26.103 -          val Const("==>",_) $ tmB $ _ = prop_of thB
  26.104 -          val tenv =
  26.105 -            Pattern.first_order_match thy (tmB, tmA)
  26.106 -                                          (Vartab.empty, Vartab.empty) |> snd
  26.107 -          val ct_pairs = map (pairself (cterm_of thy) o term_pair_of) (Vartab.dest tenv)
  26.108 -      in  thA RS (cterm_instantiate ct_pairs thB)  end) () of
  26.109 -    SOME th => th
  26.110 -  | NONE => raise THM ("first_order_resolve", 0, [thA, thB]))
  26.111 -
  26.112 -(* Applying "choice" swaps the bound variable names. We tweak
  26.113 -   "Thm.rename_boundvars"'s input to get the desired names. *)
  26.114 -fun tweak_bounds (_ $ (Const (@{const_name Ex}, _)
  26.115 -                       $ Abs (_, _, Const (@{const_name All}, _) $ _)))
  26.116 -                 (t0 $ (Const (@{const_name All}, T1)
  26.117 -                        $ Abs (a1, T1', Const (@{const_name Ex}, T2)
  26.118 -                                        $ Abs (a2, T2', t')))) =
  26.119 -    t0 $ (Const (@{const_name All}, T1)
  26.120 -          $ Abs (a2, T1', Const (@{const_name Ex}, T2) $ Abs (a1, T2', t')))
  26.121 -  | tweak_bounds _ t = t
  26.122 -
  26.123 -(* Forward proof while preserving bound variables names*)
  26.124 -fun rename_bvs_RS th rl =
  26.125 -  let
  26.126 -    val th' = th RS rl
  26.127 -    val t = concl_of th
  26.128 -    val t' = concl_of th'
  26.129 -  in Thm.rename_boundvars t' (tweak_bounds t' t) th' end
  26.130 -
  26.131 -(*raises exception if no rules apply*)
  26.132 -fun tryres (th, rls) =
  26.133 -  let fun tryall [] = raise THM("tryres", 0, th::rls)
  26.134 -        | tryall (rl::rls) = (rename_bvs_RS th rl handle THM _ => tryall rls)
  26.135 -  in  tryall rls  end;
  26.136 -
  26.137 -(*Permits forward proof from rules that discharge assumptions. The supplied proof state st,
  26.138 -  e.g. from conj_forward, should have the form
  26.139 -    "[| P' ==> ?P; Q' ==> ?Q |] ==> ?P & ?Q"
  26.140 -  and the effect should be to instantiate ?P and ?Q with normalized versions of P' and Q'.*)
  26.141 -fun forward_res ctxt nf st =
  26.142 -  let fun forward_tacf [prem] = rtac (nf prem) 1
  26.143 -        | forward_tacf prems =
  26.144 -            error (cat_lines
  26.145 -              ("Bad proof state in forward_res, please inform lcp@cl.cam.ac.uk:" ::
  26.146 -                Display.string_of_thm ctxt st ::
  26.147 -                "Premises:" :: map (Display.string_of_thm ctxt) prems))
  26.148 -  in
  26.149 -    case Seq.pull (ALLGOALS (Misc_Legacy.METAHYPS forward_tacf) st)
  26.150 -    of SOME(th,_) => th
  26.151 -     | NONE => raise THM("forward_res", 0, [st])
  26.152 -  end;
  26.153 -
  26.154 -(*Are any of the logical connectives in "bs" present in the term?*)
  26.155 -fun has_conns bs =
  26.156 -  let fun has (Const _) = false
  26.157 -        | has (Const(@{const_name Trueprop},_) $ p) = has p
  26.158 -        | has (Const(@{const_name Not},_) $ p) = has p
  26.159 -        | has (Const(@{const_name HOL.disj},_) $ p $ q) = member (op =) bs @{const_name HOL.disj} orelse has p orelse has q
  26.160 -        | has (Const(@{const_name HOL.conj},_) $ p $ q) = member (op =) bs @{const_name HOL.conj} orelse has p orelse has q
  26.161 -        | has (Const(@{const_name All},_) $ Abs(_,_,p)) = member (op =) bs @{const_name All} orelse has p
  26.162 -        | has (Const(@{const_name Ex},_) $ Abs(_,_,p)) = member (op =) bs @{const_name Ex} orelse has p
  26.163 -        | has _ = false
  26.164 -  in  has  end;
  26.165 -
  26.166 -
  26.167 -(**** Clause handling ****)
  26.168 -
  26.169 -fun literals (Const(@{const_name Trueprop},_) $ P) = literals P
  26.170 -  | literals (Const(@{const_name HOL.disj},_) $ P $ Q) = literals P @ literals Q
  26.171 -  | literals (Const(@{const_name Not},_) $ P) = [(false,P)]
  26.172 -  | literals P = [(true,P)];
  26.173 -
  26.174 -(*number of literals in a term*)
  26.175 -val nliterals = length o literals;
  26.176 -
  26.177 -
  26.178 -(*** Tautology Checking ***)
  26.179 -
  26.180 -fun signed_lits_aux (Const (@{const_name HOL.disj}, _) $ P $ Q) (poslits, neglits) =
  26.181 -      signed_lits_aux Q (signed_lits_aux P (poslits, neglits))
  26.182 -  | signed_lits_aux (Const(@{const_name Not},_) $ P) (poslits, neglits) = (poslits, P::neglits)
  26.183 -  | signed_lits_aux P (poslits, neglits) = (P::poslits, neglits);
  26.184 -
  26.185 -fun signed_lits th = signed_lits_aux (HOLogic.dest_Trueprop (concl_of th)) ([],[]);
  26.186 -
  26.187 -(*Literals like X=X are tautologous*)
  26.188 -fun taut_poslit (Const(@{const_name HOL.eq},_) $ t $ u) = t aconv u
  26.189 -  | taut_poslit (Const(@{const_name True},_)) = true
  26.190 -  | taut_poslit _ = false;
  26.191 -
  26.192 -fun is_taut th =
  26.193 -  let val (poslits,neglits) = signed_lits th
  26.194 -  in  exists taut_poslit poslits
  26.195 -      orelse
  26.196 -      exists (member (op aconv) neglits) (HOLogic.false_const :: poslits)
  26.197 -  end
  26.198 -  handle TERM _ => false;       (*probably dest_Trueprop on a weird theorem*)
  26.199 -
  26.200 -
  26.201 -(*** To remove trivial negated equality literals from clauses ***)
  26.202 -
  26.203 -(*They are typically functional reflexivity axioms and are the converses of
  26.204 -  injectivity equivalences*)
  26.205 -
  26.206 -val not_refl_disj_D = @{thm meson_not_refl_disj_D};
  26.207 -
  26.208 -(*Is either term a Var that does not properly occur in the other term?*)
  26.209 -fun eliminable (t as Var _, u) = t aconv u orelse not (Logic.occs(t,u))
  26.210 -  | eliminable (u, t as Var _) = t aconv u orelse not (Logic.occs(t,u))
  26.211 -  | eliminable _ = false;
  26.212 -
  26.213 -fun refl_clause_aux 0 th = th
  26.214 -  | refl_clause_aux n th =
  26.215 -       case HOLogic.dest_Trueprop (concl_of th) of
  26.216 -          (Const (@{const_name HOL.disj}, _) $ (Const (@{const_name HOL.disj}, _) $ _ $ _) $ _) =>
  26.217 -            refl_clause_aux n (th RS disj_assoc)    (*isolate an atom as first disjunct*)
  26.218 -        | (Const (@{const_name HOL.disj}, _) $ (Const(@{const_name Not},_) $ (Const(@{const_name HOL.eq},_) $ t $ u)) $ _) =>
  26.219 -            if eliminable(t,u)
  26.220 -            then refl_clause_aux (n-1) (th RS not_refl_disj_D)  (*Var inequation: delete*)
  26.221 -            else refl_clause_aux (n-1) (th RS disj_comm)  (*not between Vars: ignore*)
  26.222 -        | (Const (@{const_name HOL.disj}, _) $ _ $ _) => refl_clause_aux n (th RS disj_comm)
  26.223 -        | _ => (*not a disjunction*) th;
  26.224 -
  26.225 -fun notequal_lits_count (Const (@{const_name HOL.disj}, _) $ P $ Q) =
  26.226 -      notequal_lits_count P + notequal_lits_count Q
  26.227 -  | notequal_lits_count (Const(@{const_name Not},_) $ (Const(@{const_name HOL.eq},_) $ _ $ _)) = 1
  26.228 -  | notequal_lits_count _ = 0;
  26.229 -
  26.230 -(*Simplify a clause by applying reflexivity to its negated equality literals*)
  26.231 -fun refl_clause th =
  26.232 -  let val neqs = notequal_lits_count (HOLogic.dest_Trueprop (concl_of th))
  26.233 -  in  zero_var_indexes (refl_clause_aux neqs th)  end
  26.234 -  handle TERM _ => th;  (*probably dest_Trueprop on a weird theorem*)
  26.235 -
  26.236 -
  26.237 -(*** Removal of duplicate literals ***)
  26.238 -
  26.239 -(*Forward proof, passing extra assumptions as theorems to the tactic*)
  26.240 -fun forward_res2 nf hyps st =
  26.241 -  case Seq.pull
  26.242 -        (REPEAT
  26.243 -         (Misc_Legacy.METAHYPS (fn major::minors => rtac (nf (minors@hyps) major) 1) 1)
  26.244 -         st)
  26.245 -  of SOME(th,_) => th
  26.246 -   | NONE => raise THM("forward_res2", 0, [st]);
  26.247 -
  26.248 -(*Remove duplicates in P|Q by assuming ~P in Q
  26.249 -  rls (initially []) accumulates assumptions of the form P==>False*)
  26.250 -fun nodups_aux ctxt rls th = nodups_aux ctxt rls (th RS disj_assoc)
  26.251 -    handle THM _ => tryres(th,rls)
  26.252 -    handle THM _ => tryres(forward_res2 (nodups_aux ctxt) rls (th RS disj_forward2),
  26.253 -                           [disj_FalseD1, disj_FalseD2, asm_rl])
  26.254 -    handle THM _ => th;
  26.255 -
  26.256 -(*Remove duplicate literals, if there are any*)
  26.257 -fun nodups ctxt th =
  26.258 -  if has_duplicates (op =) (literals (prop_of th))
  26.259 -    then nodups_aux ctxt [] th
  26.260 -    else th;
  26.261 -
  26.262 -
  26.263 -(*** The basic CNF transformation ***)
  26.264 -
  26.265 -fun estimated_num_clauses bound t =
  26.266 - let
  26.267 -  fun sum x y = if x < bound andalso y < bound then x+y else bound
  26.268 -  fun prod x y = if x < bound andalso y < bound then x*y else bound
  26.269 -  
  26.270 -  (*Estimate the number of clauses in order to detect infeasible theorems*)
  26.271 -  fun signed_nclauses b (Const(@{const_name Trueprop},_) $ t) = signed_nclauses b t
  26.272 -    | signed_nclauses b (Const(@{const_name Not},_) $ t) = signed_nclauses (not b) t
  26.273 -    | signed_nclauses b (Const(@{const_name HOL.conj},_) $ t $ u) =
  26.274 -        if b then sum (signed_nclauses b t) (signed_nclauses b u)
  26.275 -             else prod (signed_nclauses b t) (signed_nclauses b u)
  26.276 -    | signed_nclauses b (Const(@{const_name HOL.disj},_) $ t $ u) =
  26.277 -        if b then prod (signed_nclauses b t) (signed_nclauses b u)
  26.278 -             else sum (signed_nclauses b t) (signed_nclauses b u)
  26.279 -    | signed_nclauses b (Const(@{const_name HOL.implies},_) $ t $ u) =
  26.280 -        if b then prod (signed_nclauses (not b) t) (signed_nclauses b u)
  26.281 -             else sum (signed_nclauses (not b) t) (signed_nclauses b u)
  26.282 -    | signed_nclauses b (Const(@{const_name HOL.eq}, Type ("fun", [T, _])) $ t $ u) =
  26.283 -        if T = HOLogic.boolT then (*Boolean equality is if-and-only-if*)
  26.284 -            if b then sum (prod (signed_nclauses (not b) t) (signed_nclauses b u))
  26.285 -                          (prod (signed_nclauses (not b) u) (signed_nclauses b t))
  26.286 -                 else sum (prod (signed_nclauses b t) (signed_nclauses b u))
  26.287 -                          (prod (signed_nclauses (not b) t) (signed_nclauses (not b) u))
  26.288 -        else 1
  26.289 -    | signed_nclauses b (Const(@{const_name Ex}, _) $ Abs (_,_,t)) = signed_nclauses b t
  26.290 -    | signed_nclauses b (Const(@{const_name All},_) $ Abs (_,_,t)) = signed_nclauses b t
  26.291 -    | signed_nclauses _ _ = 1; (* literal *)
  26.292 - in signed_nclauses true t end
  26.293 -
  26.294 -fun has_too_many_clauses ctxt t =
  26.295 -  let val max_cl = Config.get ctxt max_clauses in
  26.296 -    estimated_num_clauses (max_cl + 1) t > max_cl
  26.297 -  end
  26.298 -
  26.299 -(*Replaces universally quantified variables by FREE variables -- because
  26.300 -  assumptions may not contain scheme variables.  Later, generalize using Variable.export. *)
  26.301 -local  
  26.302 -  val spec_var = Thm.dest_arg (Thm.dest_arg (#2 (Thm.dest_implies (Thm.cprop_of spec))));
  26.303 -  val spec_varT = #T (Thm.rep_cterm spec_var);
  26.304 -  fun name_of (Const (@{const_name All}, _) $ Abs(x,_,_)) = x | name_of _ = Name.uu;
  26.305 -in  
  26.306 -  fun freeze_spec th ctxt =
  26.307 -    let
  26.308 -      val cert = Thm.cterm_of (ProofContext.theory_of ctxt);
  26.309 -      val ([x], ctxt') = Variable.variant_fixes [name_of (HOLogic.dest_Trueprop (concl_of th))] ctxt;
  26.310 -      val spec' = Thm.instantiate ([], [(spec_var, cert (Free (x, spec_varT)))]) spec;
  26.311 -    in (th RS spec', ctxt') end
  26.312 -end;
  26.313 -
  26.314 -(*Used with METAHYPS below. There is one assumption, which gets bound to prem
  26.315 -  and then normalized via function nf. The normal form is given to resolve_tac,
  26.316 -  instantiate a Boolean variable created by resolution with disj_forward. Since
  26.317 -  (nf prem) returns a LIST of theorems, we can backtrack to get all combinations.*)
  26.318 -fun resop nf [prem] = resolve_tac (nf prem) 1;
  26.319 -
  26.320 -(* Any need to extend this list with "HOL.type_class", "HOL.eq_class",
  26.321 -   and "Pure.term"? *)
  26.322 -val has_meta_conn = exists_Const (member (op =) ["==", "==>", "=simp=>", "all", "prop"] o #1);
  26.323 -
  26.324 -fun apply_skolem_theorem (th, rls) =
  26.325 -  let
  26.326 -    fun tryall [] = raise THM ("apply_skolem_theorem", 0, th::rls)
  26.327 -      | tryall (rl :: rls) =
  26.328 -        first_order_resolve th rl handle THM _ => tryall rls
  26.329 -  in tryall rls end
  26.330 -
  26.331 -(* Conjunctive normal form, adding clauses from th in front of ths (for foldr).
  26.332 -   Strips universal quantifiers and breaks up conjunctions.
  26.333 -   Eliminates existential quantifiers using Skolemization theorems. *)
  26.334 -fun cnf old_skolem_ths ctxt (th, ths) =
  26.335 -  let val ctxtr = Unsynchronized.ref ctxt   (* FIXME ??? *)
  26.336 -      fun cnf_aux (th,ths) =
  26.337 -        if not (can HOLogic.dest_Trueprop (prop_of th)) then ths (*meta-level: ignore*)
  26.338 -        else if not (has_conns [@{const_name All}, @{const_name Ex}, @{const_name HOL.conj}] (prop_of th))
  26.339 -        then nodups ctxt th :: ths (*no work to do, terminate*)
  26.340 -        else case head_of (HOLogic.dest_Trueprop (concl_of th)) of
  26.341 -            Const (@{const_name HOL.conj}, _) => (*conjunction*)
  26.342 -                cnf_aux (th RS conjunct1, cnf_aux (th RS conjunct2, ths))
  26.343 -          | Const (@{const_name All}, _) => (*universal quantifier*)
  26.344 -                let val (th',ctxt') = freeze_spec th (!ctxtr)
  26.345 -                in  ctxtr := ctxt'; cnf_aux (th', ths) end
  26.346 -          | Const (@{const_name Ex}, _) =>
  26.347 -              (*existential quantifier: Insert Skolem functions*)
  26.348 -              cnf_aux (apply_skolem_theorem (th, old_skolem_ths), ths)
  26.349 -          | Const (@{const_name HOL.disj}, _) =>
  26.350 -              (*Disjunction of P, Q: Create new goal of proving ?P | ?Q and solve it using
  26.351 -                all combinations of converting P, Q to CNF.*)
  26.352 -              let val tac =
  26.353 -                  Misc_Legacy.METAHYPS (resop cnf_nil) 1 THEN
  26.354 -                   (fn st' => st' |> Misc_Legacy.METAHYPS (resop cnf_nil) 1)
  26.355 -              in  Seq.list_of (tac (th RS disj_forward)) @ ths  end
  26.356 -          | _ => nodups ctxt th :: ths  (*no work to do*)
  26.357 -      and cnf_nil th = cnf_aux (th,[])
  26.358 -      val cls =
  26.359 -            if has_too_many_clauses ctxt (concl_of th)
  26.360 -            then (trace_msg (fn () => "cnf is ignoring: " ^ Display.string_of_thm ctxt th); ths)
  26.361 -            else cnf_aux (th,ths)
  26.362 -  in  (cls, !ctxtr)  end;
  26.363 -
  26.364 -fun make_cnf old_skolem_ths th ctxt = cnf old_skolem_ths ctxt (th, [])
  26.365 -
  26.366 -(*Generalization, removal of redundant equalities, removal of tautologies.*)
  26.367 -fun finish_cnf ths = filter (not o is_taut) (map refl_clause ths);
  26.368 -
  26.369 -
  26.370 -(**** Generation of contrapositives ****)
  26.371 -
  26.372 -fun is_left (Const (@{const_name Trueprop}, _) $
  26.373 -               (Const (@{const_name HOL.disj}, _) $ (Const (@{const_name HOL.disj}, _) $ _ $ _) $ _)) = true
  26.374 -  | is_left _ = false;
  26.375 -
  26.376 -(*Associate disjuctions to right -- make leftmost disjunct a LITERAL*)
  26.377 -fun assoc_right th =
  26.378 -  if is_left (prop_of th) then assoc_right (th RS disj_assoc)
  26.379 -  else th;
  26.380 -
  26.381 -(*Must check for negative literal first!*)
  26.382 -val clause_rules = [disj_assoc, make_neg_rule, make_pos_rule];
  26.383 -
  26.384 -(*For ordinary resolution. *)
  26.385 -val resolution_clause_rules = [disj_assoc, make_neg_rule', make_pos_rule'];
  26.386 -
  26.387 -(*Create a goal or support clause, conclusing False*)
  26.388 -fun make_goal th =   (*Must check for negative literal first!*)
  26.389 -    make_goal (tryres(th, clause_rules))
  26.390 -  handle THM _ => tryres(th, [make_neg_goal, make_pos_goal]);
  26.391 -
  26.392 -(*Sort clauses by number of literals*)
  26.393 -fun fewerlits(th1,th2) = nliterals(prop_of th1) < nliterals(prop_of th2);
  26.394 -
  26.395 -fun sort_clauses ths = sort (make_ord fewerlits) ths;
  26.396 -
  26.397 -fun has_bool @{typ bool} = true
  26.398 -  | has_bool (Type (_, Ts)) = exists has_bool Ts
  26.399 -  | has_bool _ = false
  26.400 -
  26.401 -fun has_fun (Type (@{type_name fun}, _)) = true
  26.402 -  | has_fun (Type (_, Ts)) = exists has_fun Ts
  26.403 -  | has_fun _ = false
  26.404 -
  26.405 -(*Is the string the name of a connective? Really only | and Not can remain,
  26.406 -  since this code expects to be called on a clause form.*)
  26.407 -val is_conn = member (op =)
  26.408 -    [@{const_name Trueprop}, @{const_name HOL.conj}, @{const_name HOL.disj},
  26.409 -     @{const_name HOL.implies}, @{const_name Not},
  26.410 -     @{const_name All}, @{const_name Ex}, @{const_name Ball}, @{const_name Bex}];
  26.411 -
  26.412 -(*True if the term contains a function--not a logical connective--where the type
  26.413 -  of any argument contains bool.*)
  26.414 -val has_bool_arg_const =
  26.415 -    exists_Const
  26.416 -      (fn (c,T) => not(is_conn c) andalso exists has_bool (binder_types T));
  26.417 -
  26.418 -(*A higher-order instance of a first-order constant? Example is the definition of
  26.419 -  one, 1, at a function type in theory Function_Algebras.*)
  26.420 -fun higher_inst_const thy (c,T) =
  26.421 -  case binder_types T of
  26.422 -      [] => false (*not a function type, OK*)
  26.423 -    | Ts => length (binder_types (Sign.the_const_type thy c)) <> length Ts;
  26.424 -
  26.425 -(*Returns false if any Vars in the theorem mention type bool.
  26.426 -  Also rejects functions whose arguments are Booleans or other functions.*)
  26.427 -fun is_fol_term thy t =
  26.428 -    Term.is_first_order ["all", @{const_name All}, @{const_name Ex}] t andalso
  26.429 -    not (exists_subterm (fn Var (_, T) => has_bool T orelse has_fun T
  26.430 -                           | _ => false) t orelse
  26.431 -         has_bool_arg_const t orelse
  26.432 -         exists_Const (higher_inst_const thy) t orelse
  26.433 -         has_meta_conn t);
  26.434 -
  26.435 -fun rigid t = not (is_Var (head_of t));
  26.436 -
  26.437 -fun ok4horn (Const (@{const_name Trueprop},_) $ (Const (@{const_name HOL.disj}, _) $ t $ _)) = rigid t
  26.438 -  | ok4horn (Const (@{const_name Trueprop},_) $ t) = rigid t
  26.439 -  | ok4horn _ = false;
  26.440 -
  26.441 -(*Create a meta-level Horn clause*)
  26.442 -fun make_horn crules th =
  26.443 -  if ok4horn (concl_of th)
  26.444 -  then make_horn crules (tryres(th,crules)) handle THM _ => th
  26.445 -  else th;
  26.446 -
  26.447 -(*Generate Horn clauses for all contrapositives of a clause. The input, th,
  26.448 -  is a HOL disjunction.*)
  26.449 -fun add_contras crules th hcs =
  26.450 -  let fun rots (0,_) = hcs
  26.451 -        | rots (k,th) = zero_var_indexes (make_horn crules th) ::
  26.452 -                        rots(k-1, assoc_right (th RS disj_comm))
  26.453 -  in case nliterals(prop_of th) of
  26.454 -        1 => th::hcs
  26.455 -      | n => rots(n, assoc_right th)
  26.456 -  end;
  26.457 -
  26.458 -(*Use "theorem naming" to label the clauses*)
  26.459 -fun name_thms label =
  26.460 -    let fun name1 th (k, ths) =
  26.461 -          (k-1, Thm.put_name_hint (label ^ string_of_int k) th :: ths)
  26.462 -    in  fn ths => #2 (fold_rev name1 ths (length ths, []))  end;
  26.463 -
  26.464 -(*Is the given disjunction an all-negative support clause?*)
  26.465 -fun is_negative th = forall (not o #1) (literals (prop_of th));
  26.466 -
  26.467 -val neg_clauses = filter is_negative;
  26.468 -
  26.469 -
  26.470 -(***** MESON PROOF PROCEDURE *****)
  26.471 -
  26.472 -fun rhyps (Const("==>",_) $ (Const(@{const_name Trueprop},_) $ A) $ phi,
  26.473 -           As) = rhyps(phi, A::As)
  26.474 -  | rhyps (_, As) = As;
  26.475 -
  26.476 -(** Detecting repeated assumptions in a subgoal **)
  26.477 -
  26.478 -(*The stringtree detects repeated assumptions.*)
  26.479 -fun ins_term t net = Net.insert_term (op aconv) (t, t) net;
  26.480 -
  26.481 -(*detects repetitions in a list of terms*)
  26.482 -fun has_reps [] = false
  26.483 -  | has_reps [_] = false
  26.484 -  | has_reps [t,u] = (t aconv u)
  26.485 -  | has_reps ts = (fold ins_term ts Net.empty; false) handle Net.INSERT => true;
  26.486 -
  26.487 -(*Like TRYALL eq_assume_tac, but avoids expensive THEN calls*)
  26.488 -fun TRYING_eq_assume_tac 0 st = Seq.single st
  26.489 -  | TRYING_eq_assume_tac i st =
  26.490 -       TRYING_eq_assume_tac (i-1) (Thm.eq_assumption i st)
  26.491 -       handle THM _ => TRYING_eq_assume_tac (i-1) st;
  26.492 -
  26.493 -fun TRYALL_eq_assume_tac st = TRYING_eq_assume_tac (nprems_of st) st;
  26.494 -
  26.495 -(*Loop checking: FAIL if trying to prove the same thing twice
  26.496 -  -- if *ANY* subgoal has repeated literals*)
  26.497 -fun check_tac st =
  26.498 -  if exists (fn prem => has_reps (rhyps(prem,[]))) (prems_of st)
  26.499 -  then  Seq.empty  else  Seq.single st;
  26.500 -
  26.501 -
  26.502 -(* net_resolve_tac actually made it slower... *)
  26.503 -fun prolog_step_tac horns i =
  26.504 -    (assume_tac i APPEND resolve_tac horns i) THEN check_tac THEN
  26.505 -    TRYALL_eq_assume_tac;
  26.506 -
  26.507 -(*Sums the sizes of the subgoals, ignoring hypotheses (ancestors)*)
  26.508 -fun addconcl prem sz = size_of_term (Logic.strip_assums_concl prem) + sz;
  26.509 -
  26.510 -fun size_of_subgoals st = fold_rev addconcl (prems_of st) 0;
  26.511 -
  26.512 -
  26.513 -(*Negation Normal Form*)
  26.514 -val nnf_rls = [imp_to_disjD, iff_to_disjD, not_conjD, not_disjD,
  26.515 -               not_impD, not_iffD, not_allD, not_exD, not_notD];
  26.516 -
  26.517 -fun ok4nnf (Const (@{const_name Trueprop},_) $ (Const (@{const_name Not}, _) $ t)) = rigid t
  26.518 -  | ok4nnf (Const (@{const_name Trueprop},_) $ t) = rigid t
  26.519 -  | ok4nnf _ = false;
  26.520 -
  26.521 -fun make_nnf1 ctxt th =
  26.522 -  if ok4nnf (concl_of th)
  26.523 -  then make_nnf1 ctxt (tryres(th, nnf_rls))
  26.524 -    handle THM ("tryres", _, _) =>
  26.525 -        forward_res ctxt (make_nnf1 ctxt)
  26.526 -           (tryres(th, [conj_forward,disj_forward,all_forward,ex_forward]))
  26.527 -    handle THM ("tryres", _, _) => th
  26.528 -  else th
  26.529 -
  26.530 -(*The simplification removes defined quantifiers and occurrences of True and False.
  26.531 -  nnf_ss also includes the one-point simprocs,
  26.532 -  which are needed to avoid the various one-point theorems from generating junk clauses.*)
  26.533 -val nnf_simps =
  26.534 -  @{thms simp_implies_def Ex1_def Ball_def Bex_def if_True if_False if_cancel
  26.535 -         if_eq_cancel cases_simp}
  26.536 -val nnf_extra_simps = @{thms split_ifs ex_simps all_simps simp_thms}
  26.537 -
  26.538 -val nnf_ss =
  26.539 -  HOL_basic_ss addsimps nnf_extra_simps
  26.540 -    addsimprocs [defALL_regroup,defEX_regroup, @{simproc neq}, @{simproc let_simp}];
  26.541 -
  26.542 -val presimplify =
  26.543 -  rewrite_rule (map safe_mk_meta_eq nnf_simps) #> simplify nnf_ss
  26.544 -
  26.545 -fun make_nnf ctxt th = case prems_of th of
  26.546 -    [] => th |> presimplify |> make_nnf1 ctxt
  26.547 -  | _ => raise THM ("make_nnf: premises in argument", 0, [th]);
  26.548 -
  26.549 -(* Pull existential quantifiers to front. This accomplishes Skolemization for
  26.550 -   clauses that arise from a subgoal. *)
  26.551 -fun skolemize_with_choice_thms ctxt choice_ths =
  26.552 -  let
  26.553 -    fun aux th =
  26.554 -      if not (has_conns [@{const_name Ex}] (prop_of th)) then
  26.555 -        th
  26.556 -      else
  26.557 -        tryres (th, choice_ths @
  26.558 -                    [conj_exD1, conj_exD2, disj_exD, disj_exD1, disj_exD2])
  26.559 -        |> aux
  26.560 -        handle THM ("tryres", _, _) =>
  26.561 -               tryres (th, [conj_forward, disj_forward, all_forward])
  26.562 -               |> forward_res ctxt aux
  26.563 -               |> aux
  26.564 -               handle THM ("tryres", _, _) =>
  26.565 -                      rename_bvs_RS th ex_forward
  26.566 -                      |> forward_res ctxt aux
  26.567 -  in aux o make_nnf ctxt end
  26.568 -
  26.569 -fun skolemize ctxt = skolemize_with_choice_thms ctxt (Meson_Choices.get ctxt)
  26.570 -
  26.571 -(* "RS" can fail if "unify_search_bound" is too small. *)
  26.572 -fun try_skolemize ctxt th =
  26.573 -  try (skolemize ctxt) th
  26.574 -  |> tap (fn NONE => trace_msg (fn () => "Failed to skolemize " ^
  26.575 -                                         Display.string_of_thm ctxt th)
  26.576 -           | _ => ())
  26.577 -
  26.578 -fun add_clauses th cls =
  26.579 -  let val ctxt0 = Variable.global_thm_context th
  26.580 -      val (cnfs, ctxt) = make_cnf [] th ctxt0
  26.581 -  in Variable.export ctxt ctxt0 cnfs @ cls end;
  26.582 -
  26.583 -(*Make clauses from a list of theorems, previously Skolemized and put into nnf.
  26.584 -  The resulting clauses are HOL disjunctions.*)
  26.585 -fun make_clauses_unsorted ths = fold_rev add_clauses ths [];
  26.586 -val make_clauses = sort_clauses o make_clauses_unsorted;
  26.587 -
  26.588 -(*Convert a list of clauses (disjunctions) to Horn clauses (contrapositives)*)
  26.589 -fun make_horns ths =
  26.590 -    name_thms "Horn#"
  26.591 -      (distinct Thm.eq_thm_prop (fold_rev (add_contras clause_rules) ths []));
  26.592 -
  26.593 -(*Could simply use nprems_of, which would count remaining subgoals -- no
  26.594 -  discrimination as to their size!  With BEST_FIRST, fails for problem 41.*)
  26.595 -
  26.596 -fun best_prolog_tac sizef horns =
  26.597 -    BEST_FIRST (has_fewer_prems 1, sizef) (prolog_step_tac horns 1);
  26.598 -
  26.599 -fun depth_prolog_tac horns =
  26.600 -    DEPTH_FIRST (has_fewer_prems 1) (prolog_step_tac horns 1);
  26.601 -
  26.602 -(*Return all negative clauses, as possible goal clauses*)
  26.603 -fun gocls cls = name_thms "Goal#" (map make_goal (neg_clauses cls));
  26.604 -
  26.605 -fun skolemize_prems_tac ctxt prems =
  26.606 -  cut_facts_tac (map_filter (try_skolemize ctxt) prems) THEN' REPEAT o etac exE
  26.607 -
  26.608 -(*Basis of all meson-tactics.  Supplies cltac with clauses: HOL disjunctions.
  26.609 -  Function mkcl converts theorems to clauses.*)
  26.610 -fun MESON preskolem_tac mkcl cltac ctxt i st =
  26.611 -  SELECT_GOAL
  26.612 -    (EVERY [Object_Logic.atomize_prems_tac 1,
  26.613 -            rtac ccontr 1,
  26.614 -            preskolem_tac,
  26.615 -            Subgoal.FOCUS (fn {context = ctxt', prems = negs, ...} =>
  26.616 -                      EVERY1 [skolemize_prems_tac ctxt negs,
  26.617 -                              Subgoal.FOCUS (cltac o mkcl o #prems) ctxt']) ctxt 1]) i st
  26.618 -  handle THM _ => no_tac st;    (*probably from make_meta_clause, not first-order*)
  26.619 -
  26.620 -
  26.621 -(** Best-first search versions **)
  26.622 -
  26.623 -(*ths is a list of additional clauses (HOL disjunctions) to use.*)
  26.624 -fun best_meson_tac sizef =
  26.625 -  MESON all_tac make_clauses
  26.626 -    (fn cls =>
  26.627 -         THEN_BEST_FIRST (resolve_tac (gocls cls) 1)
  26.628 -                         (has_fewer_prems 1, sizef)
  26.629 -                         (prolog_step_tac (make_horns cls) 1));
  26.630 -
  26.631 -(*First, breaks the goal into independent units*)
  26.632 -fun safe_best_meson_tac ctxt =
  26.633 -     SELECT_GOAL (TRY (safe_tac (claset_of ctxt)) THEN
  26.634 -                  TRYALL (best_meson_tac size_of_subgoals ctxt));
  26.635 -
  26.636 -(** Depth-first search version **)
  26.637 -
  26.638 -val depth_meson_tac =
  26.639 -  MESON all_tac make_clauses
  26.640 -    (fn cls => EVERY [resolve_tac (gocls cls) 1, depth_prolog_tac (make_horns cls)]);
  26.641 -
  26.642 -
  26.643 -(** Iterative deepening version **)
  26.644 -
  26.645 -(*This version does only one inference per call;
  26.646 -  having only one eq_assume_tac speeds it up!*)
  26.647 -fun prolog_step_tac' horns =
  26.648 -    let val (horn0s, _) = (*0 subgoals vs 1 or more*)
  26.649 -            take_prefix Thm.no_prems horns
  26.650 -        val nrtac = net_resolve_tac horns
  26.651 -    in  fn i => eq_assume_tac i ORELSE
  26.652 -                match_tac horn0s i ORELSE  (*no backtracking if unit MATCHES*)
  26.653 -                ((assume_tac i APPEND nrtac i) THEN check_tac)
  26.654 -    end;
  26.655 -
  26.656 -fun iter_deepen_prolog_tac horns =
  26.657 -    ITER_DEEPEN iter_deepen_limit (has_fewer_prems 1) (prolog_step_tac' horns);
  26.658 -
  26.659 -fun iter_deepen_meson_tac ctxt ths = ctxt |> MESON all_tac make_clauses
  26.660 -  (fn cls =>
  26.661 -    (case (gocls (cls @ ths)) of
  26.662 -      [] => no_tac  (*no goal clauses*)
  26.663 -    | goes =>
  26.664 -        let
  26.665 -          val horns = make_horns (cls @ ths)
  26.666 -          val _ = trace_msg (fn () =>
  26.667 -            cat_lines ("meson method called:" ::
  26.668 -              map (Display.string_of_thm ctxt) (cls @ ths) @
  26.669 -              ["clauses:"] @ map (Display.string_of_thm ctxt) horns))
  26.670 -        in
  26.671 -          THEN_ITER_DEEPEN iter_deepen_limit
  26.672 -            (resolve_tac goes 1) (has_fewer_prems 1) (prolog_step_tac' horns)
  26.673 -        end));
  26.674 -
  26.675 -fun meson_tac ctxt ths =
  26.676 -  SELECT_GOAL (TRY (safe_tac (claset_of ctxt)) THEN TRYALL (iter_deepen_meson_tac ctxt ths));
  26.677 -
  26.678 -
  26.679 -(**** Code to support ordinary resolution, rather than Model Elimination ****)
  26.680 -
  26.681 -(*Convert a list of clauses (disjunctions) to meta-level clauses (==>),
  26.682 -  with no contrapositives, for ordinary resolution.*)
  26.683 -
  26.684 -(*Rules to convert the head literal into a negated assumption. If the head
  26.685 -  literal is already negated, then using notEfalse instead of notEfalse'
  26.686 -  prevents a double negation.*)
  26.687 -val notEfalse = read_instantiate @{context} [(("R", 0), "False")] notE;
  26.688 -val notEfalse' = rotate_prems 1 notEfalse;
  26.689 -
  26.690 -fun negated_asm_of_head th =
  26.691 -    th RS notEfalse handle THM _ => th RS notEfalse';
  26.692 -
  26.693 -(*Converting one theorem from a disjunction to a meta-level clause*)
  26.694 -fun make_meta_clause th =
  26.695 -  let val (fth,thaw) = Drule.legacy_freeze_thaw_robust th
  26.696 -  in  
  26.697 -      (zero_var_indexes o Thm.varifyT_global o thaw 0 o 
  26.698 -       negated_asm_of_head o make_horn resolution_clause_rules) fth
  26.699 -  end;
  26.700 -
  26.701 -fun make_meta_clauses ths =
  26.702 -    name_thms "MClause#"
  26.703 -      (distinct Thm.eq_thm_prop (map make_meta_clause ths));
  26.704 -
  26.705 -end;