author  blanchet 
Wed, 21 Jul 2010 21:15:07 +0200  
changeset 37926  e6ff246c0cdb 
parent 37925  1188e6bff48d 
child 37927  29cacb2c2184 
permissions  rwrr 
35826  1 
(* Title: HOL/Tools/Sledgehammer/metis_tactics.ML 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

2 
Author: Kong W. Susanto and Lawrence C. Paulson, CU Computer Laboratory 
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

3 
Copyright Cambridge University 2007 
23447  4 

29266  5 
HOL setup for the Metis prover. 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

6 
*) 
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

7 

35826  8 
signature METIS_TACTICS = 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

9 
sig 
32955  10 
val trace: bool Unsynchronized.ref 
24309
01f3e1a43c24
turned type_lits into configuration option (with attribute);
wenzelm
parents:
24300
diff
changeset

11 
val type_lits: bool Config.T 
24319  12 
val metis_tac: Proof.context > thm list > int > tactic 
13 
val metisF_tac: Proof.context > thm list > int > tactic 

32532
a0a54a51b15b
My umpteenth attempt to commit the method metisFT, a fullytyped version of metis
paulson
parents:
32530
diff
changeset

14 
val metisFT_tac: Proof.context > thm list > int > tactic 
24319  15 
val setup: theory > theory 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

16 
end 
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

17 

35826  18 
structure Metis_Tactics : METIS_TACTICS = 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

19 
struct 
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

20 

37578
9367cb36b1c4
renamed "Sledgehammer_FOL_Clauses" to "Metis_Clauses", so that Metis doesn't depend on Sledgehammer
blanchet
parents:
37577
diff
changeset

21 
open Metis_Clauses 
35826  22 

37516
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

23 
exception METIS of string * string 
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

24 

32956  25 
val trace = Unsynchronized.ref false; 
35826  26 
fun trace_msg msg = if !trace then tracing (msg ()) else (); 
32955  27 

36001  28 
val (type_lits, type_lits_setup) = Attrib.config_bool "metis_type_lits" (K true); 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

29 

35826  30 
datatype mode = FO  HO  FT (* firstorder, higherorder, fullytyped *) 
32532
a0a54a51b15b
My umpteenth attempt to commit the method metisFT, a fullytyped version of metis
paulson
parents:
32530
diff
changeset

31 

32956  32 
(*  *) 
33 
(* Useful Theorems *) 

34 
(*  *) 

33689
d0a9ce721e0c
properly inlined @{lemma} antiqutations  might also reduce proof terms a bit;
wenzelm
parents:
33339
diff
changeset

35 
val EXCLUDED_MIDDLE = @{lemma "P ==> ~ P ==> False" by (rule notE)} 
36945  36 
val REFL_THM = Thm.incr_indexes 2 @{lemma "t ~= t ==> False" by simp} 
33689
d0a9ce721e0c
properly inlined @{lemma} antiqutations  might also reduce proof terms a bit;
wenzelm
parents:
33339
diff
changeset

37 
val subst_em = @{lemma "s = t ==> P s ==> ~ P t ==> False" by simp} 
d0a9ce721e0c
properly inlined @{lemma} antiqutations  might also reduce proof terms a bit;
wenzelm
parents:
33339
diff
changeset

38 
val ssubst_em = @{lemma "s = t ==> P t ==> ~ P s ==> False" by simp} 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

39 

32956  40 
(*  *) 
41 
(* Useful Functions *) 

42 
(*  *) 

23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

43 

37417
0714ece49081
A function called "untyped_aconv" shouldn't look at the bound names!
blanchet
parents:
37410
diff
changeset

44 
(* Match untyped terms. *) 
0714ece49081
A function called "untyped_aconv" shouldn't look at the bound names!
blanchet
parents:
37410
diff
changeset

45 
fun untyped_aconv (Const (a, _)) (Const(b, _)) = (a = b) 
0714ece49081
A function called "untyped_aconv" shouldn't look at the bound names!
blanchet
parents:
37410
diff
changeset

46 
 untyped_aconv (Free (a, _)) (Free (b, _)) = (a = b) 
0714ece49081
A function called "untyped_aconv" shouldn't look at the bound names!
blanchet
parents:
37410
diff
changeset

47 
 untyped_aconv (Var ((a, _), _)) (Var ((b, _), _)) = 
0714ece49081
A function called "untyped_aconv" shouldn't look at the bound names!
blanchet
parents:
37410
diff
changeset

48 
(a = b) (* The index is ignored, for some reason. *) 
0714ece49081
A function called "untyped_aconv" shouldn't look at the bound names!
blanchet
parents:
37410
diff
changeset

49 
 untyped_aconv (Bound i) (Bound j) = (i = j) 
0714ece49081
A function called "untyped_aconv" shouldn't look at the bound names!
blanchet
parents:
37410
diff
changeset

50 
 untyped_aconv (Abs (_, _, t)) (Abs (_, _, u)) = untyped_aconv t u 
0714ece49081
A function called "untyped_aconv" shouldn't look at the bound names!
blanchet
parents:
37410
diff
changeset

51 
 untyped_aconv (t1 $ t2) (u1 $ u2) = 
0714ece49081
A function called "untyped_aconv" shouldn't look at the bound names!
blanchet
parents:
37410
diff
changeset

52 
untyped_aconv t1 u1 andalso untyped_aconv t2 u2 
0714ece49081
A function called "untyped_aconv" shouldn't look at the bound names!
blanchet
parents:
37410
diff
changeset

53 
 untyped_aconv _ _ = false 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

54 

32956  55 
(* Finding the relative location of an untyped term within a list of terms *) 
56 
fun get_index lit = 

57 
let val lit = Envir.eta_contract lit 

37498
b426cbdb5a23
removed Sledgehammer's support for the DFG syntax;
blanchet
parents:
37479
diff
changeset

58 
fun get _ [] = raise Empty 
32956  59 
 get n (x::xs) = if untyped_aconv lit (Envir.eta_contract (HOLogic.dest_Trueprop x)) 
60 
then n else get (n+1) xs 

61 
in get 1 end; 

23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

62 

32956  63 
(*  *) 
64 
(* HOL to FOL (Isabelle to Metis) *) 

65 
(*  *) 

23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

66 

32956  67 
fun fn_isa_to_met "equal" = "=" 
68 
 fn_isa_to_met x = x; 

23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

69 

32956  70 
fun metis_lit b c args = (b, (c, args)); 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

71 

37926
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

72 
fun metis_term_from_combtyp (CombTVar (s, _)) = Metis.Term.Var s 
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

73 
 metis_term_from_combtyp (CombTFree (s, _)) = Metis.Term.Fn (s, []) 
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

74 
 metis_term_from_combtyp (CombType ((s, _), tps)) = 
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

75 
Metis.Term.Fn (s, map metis_term_from_combtyp tps); 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

76 

32956  77 
(*These two functions insert type literals before the real literals. That is the 
78 
opposite order from TPTP linkup, but maybe OK.*) 

23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

79 

32956  80 
fun hol_term_to_fol_FO tm = 
35865  81 
case strip_combterm_comb tm of 
36170
0cdb76723c88
added original constant names to Sledgehammer internal terms + output short names if "debug" is set (for increased readability)
blanchet
parents:
36169
diff
changeset

82 
(CombConst ((c, _), _, tys), tms) => 
37926
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

83 
let val tyargs = map metis_term_from_combtyp tys 
32956  84 
val args = map hol_term_to_fol_FO tms 
85 
in Metis.Term.Fn (c, tyargs @ args) end 

36170
0cdb76723c88
added original constant names to Sledgehammer internal terms + output short names if "debug" is set (for increased readability)
blanchet
parents:
36169
diff
changeset

86 
 (CombVar ((v, _), _), []) => Metis.Term.Var v 
37402
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

87 
 _ => raise Fail "hol_term_to_fol_FO"; 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

88 

36170
0cdb76723c88
added original constant names to Sledgehammer internal terms + output short names if "debug" is set (for increased readability)
blanchet
parents:
36169
diff
changeset

89 
fun hol_term_to_fol_HO (CombVar ((s, _), _)) = Metis.Term.Var s 
0cdb76723c88
added original constant names to Sledgehammer internal terms + output short names if "debug" is set (for increased readability)
blanchet
parents:
36169
diff
changeset

90 
 hol_term_to_fol_HO (CombConst ((a, _), _, tylist)) = 
37926
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

91 
Metis.Term.Fn (fn_isa_to_met a, map metis_term_from_combtyp tylist) 
35865  92 
 hol_term_to_fol_HO (CombApp (tm1, tm2)) = 
32994  93 
Metis.Term.Fn (".", map hol_term_to_fol_HO [tm1, tm2]); 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

94 

32956  95 
(*The fullytyped translation, to avoid type errors*) 
37926
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

96 
fun wrap_type (tm, ty) = Metis.Term.Fn("ti", [tm, metis_term_from_combtyp ty]); 
32956  97 

36170
0cdb76723c88
added original constant names to Sledgehammer internal terms + output short names if "debug" is set (for increased readability)
blanchet
parents:
36169
diff
changeset

98 
fun hol_term_to_fol_FT (CombVar ((s, _), ty)) = wrap_type (Metis.Term.Var s, ty) 
0cdb76723c88
added original constant names to Sledgehammer internal terms + output short names if "debug" is set (for increased readability)
blanchet
parents:
36169
diff
changeset

99 
 hol_term_to_fol_FT (CombConst((a, _), ty, _)) = 
32956  100 
wrap_type (Metis.Term.Fn(fn_isa_to_met a, []), ty) 
35865  101 
 hol_term_to_fol_FT (tm as CombApp(tm1,tm2)) = 
32956  102 
wrap_type (Metis.Term.Fn(".", map hol_term_to_fol_FT [tm1,tm2]), 
35865  103 
type_of_combterm tm); 
32532
a0a54a51b15b
My umpteenth attempt to commit the method metisFT, a fullytyped version of metis
paulson
parents:
32530
diff
changeset

104 

37923  105 
fun hol_literal_to_fol FO (FOLLiteral (pos, tm)) = 
36170
0cdb76723c88
added original constant names to Sledgehammer internal terms + output short names if "debug" is set (for increased readability)
blanchet
parents:
36169
diff
changeset

106 
let val (CombConst((p, _), _, tys), tms) = strip_combterm_comb tm 
37926
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

107 
val tylits = if p = "equal" then [] else map metis_term_from_combtyp tys 
32956  108 
val lits = map hol_term_to_fol_FO tms 
37923  109 
in metis_lit pos (fn_isa_to_met p) (tylits @ lits) end 
110 
 hol_literal_to_fol HO (FOLLiteral (pos, tm)) = 

35865  111 
(case strip_combterm_comb tm of 
36170
0cdb76723c88
added original constant names to Sledgehammer internal terms + output short names if "debug" is set (for increased readability)
blanchet
parents:
36169
diff
changeset

112 
(CombConst(("equal", _), _, _), tms) => 
37923  113 
metis_lit pos "=" (map hol_term_to_fol_HO tms) 
114 
 _ => metis_lit pos "{}" [hol_term_to_fol_HO tm]) (*hBOOL*) 

115 
 hol_literal_to_fol FT (FOLLiteral (pos, tm)) = 

35865  116 
(case strip_combterm_comb tm of 
36170
0cdb76723c88
added original constant names to Sledgehammer internal terms + output short names if "debug" is set (for increased readability)
blanchet
parents:
36169
diff
changeset

117 
(CombConst(("equal", _), _, _), tms) => 
37923  118 
metis_lit pos "=" (map hol_term_to_fol_FT tms) 
119 
 _ => metis_lit pos "{}" [hol_term_to_fol_FT tm]) (*hBOOL*); 

23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

120 

37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

121 
fun literals_of_hol_term thy mode t = 
35865  122 
let val (lits, types_sorts) = literals_of_term thy t 
32956  123 
in (map (hol_literal_to_fol mode) lits, types_sorts) end; 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

124 

32956  125 
(*Sign should be "true" for conjecture type constraints, "false" for type lits in clauses.*) 
37643
f576af716aa6
rewrote the TPTP problem generation code more or less from scratch;
blanchet
parents:
37632
diff
changeset

126 
fun metis_of_type_literals pos (TyLitVar ((s, _), (s', _))) = 
36556
81dc2c20f052
use readable names in "debug" mode for type vars + don't pipe facts using "using" but rather give them directly to metis (works better with type variables)
blanchet
parents:
36401
diff
changeset

127 
metis_lit pos s [Metis.Term.Var s'] 
37643
f576af716aa6
rewrote the TPTP problem generation code more or less from scratch;
blanchet
parents:
37632
diff
changeset

128 
 metis_of_type_literals pos (TyLitFree ((s, _), (s', _))) = 
36556
81dc2c20f052
use readable names in "debug" mode for type vars + don't pipe facts using "using" but rather give them directly to metis (works better with type variables)
blanchet
parents:
36401
diff
changeset

129 
metis_lit pos s [Metis.Term.Fn (s',[])] 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

130 

32994  131 
fun default_sort _ (TVar _) = false 
33035  132 
 default_sort ctxt (TFree (x, s)) = (s = the_default [] (Variable.def_sort ctxt (x, ~1))); 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

133 

32956  134 
fun metis_of_tfree tf = 
36556
81dc2c20f052
use readable names in "debug" mode for type vars + don't pipe facts using "using" but rather give them directly to metis (works better with type variables)
blanchet
parents:
36401
diff
changeset

135 
Metis.Thm.axiom (Metis.LiteralSet.singleton (metis_of_type_literals true tf)); 
24937
340523598914
contextbased treatment of generalization; also handling TFrees in axiom clauses
paulson
parents:
24920
diff
changeset

136 

37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

137 
fun hol_thm_to_fol is_conjecture ctxt mode j skolems th = 
37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

138 
let 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

139 
val thy = ProofContext.theory_of ctxt 
37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

140 
val (skolems, (mlits, types_sorts)) = 
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

141 
th > prop_of > conceal_skolem_terms j skolems 
37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

142 
> (HOLogic.dest_Trueprop #> literals_of_hol_term thy mode) 
32956  143 
in 
144 
if is_conjecture then 

36556
81dc2c20f052
use readable names in "debug" mode for type vars + don't pipe facts using "using" but rather give them directly to metis (works better with type variables)
blanchet
parents:
36401
diff
changeset

145 
(Metis.Thm.axiom (Metis.LiteralSet.fromList mlits), 
37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

146 
type_literals_for_types types_sorts, skolems) 
32956  147 
else 
36966
adc11fb3f3aa
generate proper arity declarations for TFrees for SPASS's DFG format;
blanchet
parents:
36945
diff
changeset

148 
let val tylits = filter_out (default_sort ctxt) types_sorts 
adc11fb3f3aa
generate proper arity declarations for TFrees for SPASS's DFG format;
blanchet
parents:
36945
diff
changeset

149 
> type_literals_for_types 
32956  150 
val mtylits = if Config.get ctxt type_lits 
36556
81dc2c20f052
use readable names in "debug" mode for type vars + don't pipe facts using "using" but rather give them directly to metis (works better with type variables)
blanchet
parents:
36401
diff
changeset

151 
then map (metis_of_type_literals false) tylits else [] 
32956  152 
in 
37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

153 
(Metis.Thm.axiom (Metis.LiteralSet.fromList(mtylits @ mlits)), [], 
37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

154 
skolems) 
32956  155 
end 
156 
end; 

23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

157 

32956  158 
(* ARITY CLAUSE *) 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

159 

37643
f576af716aa6
rewrote the TPTP problem generation code more or less from scratch;
blanchet
parents:
37632
diff
changeset

160 
fun m_arity_cls (TConsLit ((c, _), (t, _), args)) = 
f576af716aa6
rewrote the TPTP problem generation code more or less from scratch;
blanchet
parents:
37632
diff
changeset

161 
metis_lit true c [Metis.Term.Fn(t, map (Metis.Term.Var o fst) args)] 
f576af716aa6
rewrote the TPTP problem generation code more or less from scratch;
blanchet
parents:
37632
diff
changeset

162 
 m_arity_cls (TVarLit ((c, _), (s, _))) = 
f576af716aa6
rewrote the TPTP problem generation code more or less from scratch;
blanchet
parents:
37632
diff
changeset

163 
metis_lit false c [Metis.Term.Var s] 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

164 

32956  165 
(*TrueI is returned as the Isabelle counterpart because there isn't any.*) 
35865  166 
fun arity_cls (ArityClause {conclLit, premLits, ...}) = 
32956  167 
(TrueI, 
168 
Metis.Thm.axiom (Metis.LiteralSet.fromList (map m_arity_cls (conclLit :: premLits)))); 

23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

169 

32956  170 
(* CLASSREL CLAUSE *) 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

171 

37925  172 
fun m_class_rel_cls (subclass, _) (superclass, _) = 
32956  173 
[metis_lit false subclass [Metis.Term.Var "T"], metis_lit true superclass [Metis.Term.Var "T"]]; 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

174 

37925  175 
fun class_rel_cls (ClassRelClause {subclass, superclass, ...}) = 
176 
(TrueI, Metis.Thm.axiom (Metis.LiteralSet.fromList (m_class_rel_cls subclass superclass))); 

23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

177 

32956  178 
(*  *) 
179 
(* FOL to HOL (Metis to Isabelle) *) 

180 
(*  *) 

23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

181 

32956  182 
datatype term_or_type = Term of Term.term  Type of Term.typ; 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

183 

32956  184 
fun terms_of [] = [] 
185 
 terms_of (Term t :: tts) = t :: terms_of tts 

186 
 terms_of (Type _ :: tts) = terms_of tts; 

23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

187 

32956  188 
fun types_of [] = [] 
32994  189 
 types_of (Term (Term.Var ((a,idx), _)) :: tts) = 
32956  190 
if String.isPrefix "_" a then 
191 
(*Variable generated by Metis, which might have been a type variable.*) 

32994  192 
TVar (("'" ^ a, idx), HOLogic.typeS) :: types_of tts 
32956  193 
else types_of tts 
194 
 types_of (Term _ :: tts) = types_of tts 

195 
 types_of (Type T :: tts) = T :: types_of tts; 

23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

196 

32956  197 
fun apply_list rator nargs rands = 
198 
let val trands = terms_of rands 

199 
in if length trands = nargs then Term (list_comb(rator, trands)) 

37402
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

200 
else raise Fail 
32956  201 
("apply_list: wrong number of arguments: " ^ Syntax.string_of_term_global Pure.thy rator ^ 
202 
" expected " ^ Int.toString nargs ^ 

203 
" received " ^ commas (map (Syntax.string_of_term_global Pure.thy) trands)) 

204 
end; 

23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

205 

24500  206 
fun infer_types ctxt = 
207 
Syntax.check_terms (ProofContext.set_mode ProofContext.mode_pattern ctxt); 

25713  208 

32956  209 
(*We use 1 rather than 0 because variable references in clauses may otherwise conflict 
210 
with variable constraints in the goal...at least, type inference often fails otherwise. 

211 
SEE ALSO axiom_inf below.*) 

212 
fun mk_var (w,T) = Term.Var((w,1), T); 

23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

213 

32956  214 
(*include the default sort, if available*) 
215 
fun mk_tfree ctxt w = 

216 
let val ww = "'" ^ w 

33035  217 
in TFree(ww, the_default HOLogic.typeS (Variable.def_sort ctxt (ww, ~1))) end; 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

218 

32956  219 
(*Remove the "apply" operator from an HO term*) 
220 
fun strip_happ args (Metis.Term.Fn(".",[t,u])) = strip_happ (u::args) t 

221 
 strip_happ args x = (x, args); 

23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

222 

36967
3c804030474b
fix bug in Isar proof reconstruction step relabeling + don't try to infer the sorts of TVars, since this often fails miserably
blanchet
parents:
36966
diff
changeset

223 
fun make_tvar s = TVar (("'" ^ s, 0), HOLogic.typeS) 
3c804030474b
fix bug in Isar proof reconstruction step relabeling + don't try to infer the sorts of TVars, since this often fails miserably
blanchet
parents:
36966
diff
changeset

224 

37926
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

225 
fun hol_type_from_metis_term _ (Metis.Term.Var v) = 
35865  226 
(case strip_prefix tvar_prefix v of 
227 
SOME w => make_tvar w 

228 
 NONE => make_tvar v) 

37926
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

229 
 hol_type_from_metis_term ctxt (Metis.Term.Fn(x, tys)) = 
37643
f576af716aa6
rewrote the TPTP problem generation code more or less from scratch;
blanchet
parents:
37632
diff
changeset

230 
(case strip_prefix type_const_prefix x of 
37926
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

231 
SOME tc => Term.Type (invert_const tc, 
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

232 
map (hol_type_from_metis_term ctxt) tys) 
32956  233 
 NONE => 
35865  234 
case strip_prefix tfree_prefix x of 
32956  235 
SOME tf => mk_tfree ctxt tf 
37926
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

236 
 NONE => raise Fail ("hol_type_from_metis_term: " ^ x)); 
32532
a0a54a51b15b
My umpteenth attempt to commit the method metisFT, a fullytyped version of metis
paulson
parents:
32530
diff
changeset

237 

32956  238 
(*Maps metis terms to isabelle terms*) 
37926
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

239 
fun hol_term_from_metis_PT ctxt fol_tm = 
32956  240 
let val thy = ProofContext.theory_of ctxt 
37926
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

241 
val _ = trace_msg (fn () => "hol_term_from_metis_PT: " ^ 
37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

242 
Metis.Term.toString fol_tm) 
32956  243 
fun tm_to_tt (Metis.Term.Var v) = 
35865  244 
(case strip_prefix tvar_prefix v of 
245 
SOME w => Type (make_tvar w) 

32956  246 
 NONE => 
35865  247 
case strip_prefix schematic_var_prefix v of 
32956  248 
SOME w => Term (mk_var (w, HOLogic.typeT)) 
249 
 NONE => Term (mk_var (v, HOLogic.typeT)) ) 

250 
(*Var from Metis with a name like _nnn; possibly a type variable*) 

251 
 tm_to_tt (Metis.Term.Fn ("{}", [arg])) = tm_to_tt arg (*hBOOL*) 

252 
 tm_to_tt (t as Metis.Term.Fn (".",_)) = 

253 
let val (rator,rands) = strip_happ [] t 

254 
in case rator of 

255 
Metis.Term.Fn(fname,ts) => applic_to_tt (fname, ts @ rands) 

256 
 _ => case tm_to_tt rator of 

257 
Term t => Term (list_comb(t, terms_of (map tm_to_tt rands))) 

37402
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

258 
 _ => raise Fail "tm_to_tt: HO application" 
32956  259 
end 
260 
 tm_to_tt (Metis.Term.Fn (fname, args)) = applic_to_tt (fname,args) 

261 
and applic_to_tt ("=",ts) = 

35865  262 
Term (list_comb(Const (@{const_name "op ="}, HOLogic.typeT), terms_of (map tm_to_tt ts))) 
32956  263 
 applic_to_tt (a,ts) = 
35865  264 
case strip_prefix const_prefix a of 
32956  265 
SOME b => 
35865  266 
let val c = invert_const b 
36909
7d5587f6d5f7
made Sledgehammer's fulltyped proof reconstruction work for the first time;
blanchet
parents:
36556
diff
changeset

267 
val ntypes = num_type_args thy c 
32956  268 
val nterms = length ts  ntypes 
269 
val tts = map tm_to_tt ts 

270 
val tys = types_of (List.take(tts,ntypes)) 

36909
7d5587f6d5f7
made Sledgehammer's fulltyped proof reconstruction work for the first time;
blanchet
parents:
36556
diff
changeset

271 
in if length tys = ntypes then 
32956  272 
apply_list (Const (c, dummyT)) nterms (List.drop(tts,ntypes)) 
37402
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

273 
else 
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

274 
raise Fail ("Constant " ^ c ^ " expects " ^ Int.toString ntypes ^ 
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

275 
" but gets " ^ Int.toString (length tys) ^ 
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

276 
" type arguments\n" ^ 
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

277 
cat_lines (map (Syntax.string_of_typ ctxt) tys) ^ 
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

278 
" the terms are \n" ^ 
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

279 
cat_lines (map (Syntax.string_of_term ctxt) (terms_of tts))) 
32956  280 
end 
281 
 NONE => (*Not a constant. Is it a type constructor?*) 

37643
f576af716aa6
rewrote the TPTP problem generation code more or less from scratch;
blanchet
parents:
37632
diff
changeset

282 
case strip_prefix type_const_prefix a of 
33227  283 
SOME b => 
37572
a899f9506f39
more intramodule dependency cleanup + merge "const" and "type_const" tables, since this is safe
blanchet
parents:
37566
diff
changeset

284 
Type (Term.Type (invert_const b, types_of (map tm_to_tt ts))) 
32956  285 
 NONE => (*Maybe a TFree. Should then check that ts=[].*) 
35865  286 
case strip_prefix tfree_prefix a of 
32956  287 
SOME b => Type (mk_tfree ctxt b) 
288 
 NONE => (*a fixed variable? They are Skolem functions.*) 

35865  289 
case strip_prefix fixed_var_prefix a of 
32956  290 
SOME b => 
291 
let val opr = Term.Free(b, HOLogic.typeT) 

292 
in apply_list opr (length ts) (map tm_to_tt ts) end 

37402
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

293 
 NONE => raise Fail ("unexpected metis function: " ^ a) 
37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

294 
in 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

295 
case tm_to_tt fol_tm of 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

296 
Term t => t 
37402
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

297 
 _ => raise Fail "fol_tm_to_tt: Term expected" 
37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

298 
end 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

299 

32956  300 
(*Maps fullytyped metis terms to isabelle terms*) 
37926
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

301 
fun hol_term_from_metis_FT ctxt fol_tm = 
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

302 
let val _ = trace_msg (fn () => "hol_term_from_metis_FT: " ^ 
37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

303 
Metis.Term.toString fol_tm) 
32994  304 
fun cvt (Metis.Term.Fn ("ti", [Metis.Term.Var v, _])) = 
35865  305 
(case strip_prefix schematic_var_prefix v of 
32956  306 
SOME w => mk_var(w, dummyT) 
307 
 NONE => mk_var(v, dummyT)) 

32994  308 
 cvt (Metis.Term.Fn ("ti", [Metis.Term.Fn ("=",[]), _])) = 
32956  309 
Const ("op =", HOLogic.typeT) 
310 
 cvt (Metis.Term.Fn ("ti", [Metis.Term.Fn (x,[]), ty])) = 

35865  311 
(case strip_prefix const_prefix x of 
312 
SOME c => Const (invert_const c, dummyT) 

32956  313 
 NONE => (*Not a constant. Is it a fixed variable??*) 
35865  314 
case strip_prefix fixed_var_prefix x of 
37926
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

315 
SOME v => Free (v, hol_type_from_metis_term ctxt ty) 
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

316 
 NONE => raise Fail ("hol_term_from_metis_FT bad constant: " ^ x)) 
32956  317 
 cvt (Metis.Term.Fn ("ti", [Metis.Term.Fn (".",[tm1,tm2]), _])) = 
318 
cvt tm1 $ cvt tm2 

319 
 cvt (Metis.Term.Fn (".",[tm1,tm2])) = (*untyped application*) 

320 
cvt tm1 $ cvt tm2 

321 
 cvt (Metis.Term.Fn ("{}", [arg])) = cvt arg (*hBOOL*) 

322 
 cvt (Metis.Term.Fn ("=", [tm1,tm2])) = 

35865  323 
list_comb(Const (@{const_name "op ="}, HOLogic.typeT), map cvt [tm1,tm2]) 
32956  324 
 cvt (t as Metis.Term.Fn (x, [])) = 
35865  325 
(case strip_prefix const_prefix x of 
326 
SOME c => Const (invert_const c, dummyT) 

32956  327 
 NONE => (*Not a constant. Is it a fixed variable??*) 
35865  328 
case strip_prefix fixed_var_prefix x of 
32956  329 
SOME v => Free (v, dummyT) 
37926
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

330 
 NONE => (trace_msg (fn () => "hol_term_from_metis_FT bad const: " ^ x); 
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

331 
hol_term_from_metis_PT ctxt t)) 
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

332 
 cvt t = (trace_msg (fn () => "hol_term_from_metis_FT bad term: " ^ Metis.Term.toString t); 
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

333 
hol_term_from_metis_PT ctxt t) 
37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

334 
in fol_tm > cvt end 
32532
a0a54a51b15b
My umpteenth attempt to commit the method metisFT, a fullytyped version of metis
paulson
parents:
32530
diff
changeset

335 

37926
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

336 
fun hol_term_from_metis FT = hol_term_from_metis_FT 
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

337 
 hol_term_from_metis _ = hol_term_from_metis_PT 
32532
a0a54a51b15b
My umpteenth attempt to commit the method metisFT, a fullytyped version of metis
paulson
parents:
32530
diff
changeset

338 

37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

339 
fun hol_terms_from_fol ctxt mode skolems fol_tms = 
37926
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

340 
let val ts = map (hol_term_from_metis mode ctxt) fol_tms 
32956  341 
val _ = trace_msg (fn () => " calling type inference:") 
342 
val _ = app (fn t => trace_msg (fn () => Syntax.string_of_term ctxt t)) ts 

37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

343 
val ts' = ts > map (reveal_skolem_terms skolems) > infer_types ctxt 
32956  344 
val _ = app (fn t => trace_msg 
345 
(fn () => " final term: " ^ Syntax.string_of_term ctxt t ^ 

346 
" of type " ^ Syntax.string_of_typ ctxt (type_of t))) 

347 
ts' 

348 
in ts' end; 

23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

349 

35865  350 
fun mk_not (Const (@{const_name Not}, _) $ b) = b 
32956  351 
 mk_not b = HOLogic.mk_not b; 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

352 

32956  353 
val metis_eq = Metis.Term.Fn ("=", []); 
32532
a0a54a51b15b
My umpteenth attempt to commit the method metisFT, a fullytyped version of metis
paulson
parents:
32530
diff
changeset

354 

32956  355 
(*  *) 
356 
(* FOL step Inference Rules *) 

357 
(*  *) 

23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

358 

32956  359 
(*for debugging only*) 
360 
fun print_thpair (fth,th) = 

361 
(trace_msg (fn () => "============================================="); 

362 
trace_msg (fn () => "Metis: " ^ Metis.Thm.toString fth); 

363 
trace_msg (fn () => "Isabelle: " ^ Display.string_of_thm_without_context th)); 

23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

364 

32956  365 
fun lookth thpairs (fth : Metis.Thm.thm) = 
33035  366 
the (AList.lookup (uncurry Metis.Thm.equal) thpairs fth) 
37402
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

367 
handle Option => 
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

368 
raise Fail ("Failed to find a Metis theorem " ^ Metis.Thm.toString fth); 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

369 

32956  370 
fun is_TrueI th = Thm.eq_thm(TrueI,th); 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

371 

32956  372 
fun cterm_incr_types thy idx = cterm_of thy o (map_types (Logic.incr_tvar idx)); 
24974  373 

32956  374 
fun inst_excluded_middle thy i_atm = 
375 
let val th = EXCLUDED_MIDDLE 

376 
val [vx] = Term.add_vars (prop_of th) [] 

377 
val substs = [(cterm_of thy (Var vx), cterm_of thy i_atm)] 

378 
in cterm_instantiate substs th end; 

23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

379 

32956  380 
(* INFERENCE RULE: AXIOM *) 
36945  381 
fun axiom_inf thpairs th = Thm.incr_indexes 1 (lookth thpairs th); 
32956  382 
(*This causes variables to have an index of 1 by default. SEE ALSO mk_var above.*) 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

383 

32956  384 
(* INFERENCE RULE: ASSUME *) 
37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

385 
fun assume_inf ctxt mode skolems atm = 
32956  386 
inst_excluded_middle 
37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

387 
(ProofContext.theory_of ctxt) 
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

388 
(singleton (hol_terms_from_fol ctxt mode skolems) (Metis.Term.Fn atm)) 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

389 

32956  390 
(* INFERENCE RULE: INSTANTIATE (Subst). Type instantiations are ignored. Trying to reconstruct 
391 
them admits new possibilities of errors, e.g. concerning sorts. Instead we try to arrange 

392 
that new TVars are distinct and that types can be inferred from terms.*) 

37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

393 
fun inst_inf ctxt mode skolems thpairs fsubst th = 
32956  394 
let val thy = ProofContext.theory_of ctxt 
395 
val i_th = lookth thpairs th 

396 
val i_th_vars = Term.add_vars (prop_of i_th) [] 

33035  397 
fun find_var x = the (List.find (fn ((a,_),_) => a=x) i_th_vars) 
32956  398 
fun subst_translation (x,y) = 
399 
let val v = find_var x 

37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

400 
(* We call "reveal_skolem_terms" and "infer_types" below. *) 
37926
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

401 
val t = hol_term_from_metis mode ctxt y 
32956  402 
in SOME (cterm_of thy (Var v), t) end 
403 
handle Option => 

404 
(trace_msg (fn() => "List.find failed for the variable " ^ x ^ 

405 
" in " ^ Display.string_of_thm ctxt i_th); 

406 
NONE) 

407 
fun remove_typeinst (a, t) = 

35865  408 
case strip_prefix schematic_var_prefix a of 
32956  409 
SOME b => SOME (b, t) 
35865  410 
 NONE => case strip_prefix tvar_prefix a of 
32956  411 
SOME _ => NONE (*type instantiations are forbidden!*) 
412 
 NONE => SOME (a,t) (*internal Metis var?*) 

413 
val _ = trace_msg (fn () => " isa th: " ^ Display.string_of_thm ctxt i_th) 

414 
val substs = map_filter remove_typeinst (Metis.Subst.toList fsubst) 

415 
val (vars,rawtms) = ListPair.unzip (map_filter subst_translation substs) 

37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

416 
val tms = rawtms > map (reveal_skolem_terms skolems) > infer_types ctxt 
32956  417 
val ctm_of = cterm_incr_types thy (1 + Thm.maxidx_of i_th) 
418 
val substs' = ListPair.zip (vars, map ctm_of tms) 

419 
val _ = trace_msg (fn () => 

420 
cat_lines ("subst_translations:" :: 

421 
(substs' > map (fn (x, y) => 

422 
Syntax.string_of_term ctxt (term_of x) ^ " > " ^ 

423 
Syntax.string_of_term ctxt (term_of y))))); 

37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

424 
in cterm_instantiate substs' i_th end 
37516
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

425 
handle THM (msg, _, _) => raise METIS ("inst_inf", msg) 
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

426 
 ERROR msg => raise METIS ("inst_inf", msg) 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

427 

32956  428 
(* INFERENCE RULE: RESOLVE *) 
25713  429 

32956  430 
(*Like RSN, but we rename apart only the type variables. Vars here typically have an index 
431 
of 1, and the use of RSN would increase this typically to 3. Instantiations of those Vars 

432 
could then fail. See comment on mk_var.*) 

433 
fun resolve_inc_tyvars(tha,i,thb) = 

37548
6a7a9261b9ad
make sure "metisFT" is tried upon "metis" failure in "resolve_inc_tyvars"
blanchet
parents:
37538
diff
changeset

434 
let 
6a7a9261b9ad
make sure "metisFT" is tried upon "metis" failure in "resolve_inc_tyvars"
blanchet
parents:
37538
diff
changeset

435 
val tha = Drule.incr_type_indexes (1 + Thm.maxidx_of thb) tha 
32956  436 
val ths = Seq.list_of (Thm.bicompose false (false,tha,nprems_of tha) i thb) 
437 
in 

438 
case distinct Thm.eq_thm ths of 

439 
[th] => th 

440 
 _ => raise THM ("resolve_inc_tyvars: unique result expected", i, [tha,thb]) 

37548
6a7a9261b9ad
make sure "metisFT" is tried upon "metis" failure in "resolve_inc_tyvars"
blanchet
parents:
37538
diff
changeset

441 
end 
6a7a9261b9ad
make sure "metisFT" is tried upon "metis" failure in "resolve_inc_tyvars"
blanchet
parents:
37538
diff
changeset

442 
handle TERM (msg, _) => raise METIS ("resolve_inc_tyvars", msg) 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

443 

37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

444 
fun resolve_inf ctxt mode skolems thpairs atm th1 th2 = 
32956  445 
let 
446 
val i_th1 = lookth thpairs th1 and i_th2 = lookth thpairs th2 

447 
val _ = trace_msg (fn () => " isa th1 (pos): " ^ Display.string_of_thm ctxt i_th1) 

448 
val _ = trace_msg (fn () => " isa th2 (neg): " ^ Display.string_of_thm ctxt i_th2) 

449 
in 

450 
if is_TrueI i_th1 then i_th2 (*Trivial cases where one operand is type info*) 

451 
else if is_TrueI i_th2 then i_th1 

452 
else 

453 
let 

37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

454 
val i_atm = singleton (hol_terms_from_fol ctxt mode skolems) 
37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

455 
(Metis.Term.Fn atm) 
32956  456 
val _ = trace_msg (fn () => " atom: " ^ Syntax.string_of_term ctxt i_atm) 
457 
val prems_th1 = prems_of i_th1 

458 
val prems_th2 = prems_of i_th2 

459 
val index_th1 = get_index (mk_not i_atm) prems_th1 

37402
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

460 
handle Empty => raise Fail "Failed to find literal in th1" 
32956  461 
val _ = trace_msg (fn () => " index_th1: " ^ Int.toString index_th1) 
462 
val index_th2 = get_index i_atm prems_th2 

37402
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

463 
handle Empty => raise Fail "Failed to find literal in th2" 
32956  464 
val _ = trace_msg (fn () => " index_th2: " ^ Int.toString index_th2) 
465 
in resolve_inc_tyvars (Meson.select_literal index_th1 i_th1, index_th2, i_th2) end 

466 
end; 

23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

467 

32956  468 
(* INFERENCE RULE: REFL *) 
469 
val refl_x = cterm_of @{theory} (Var (hd (Term.add_vars (prop_of REFL_THM) []))); 

470 
val refl_idx = 1 + Thm.maxidx_of REFL_THM; 

25713  471 

37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

472 
fun refl_inf ctxt mode skolems t = 
32956  473 
let val thy = ProofContext.theory_of ctxt 
37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

474 
val i_t = singleton (hol_terms_from_fol ctxt mode skolems) t 
32956  475 
val _ = trace_msg (fn () => " term: " ^ Syntax.string_of_term ctxt i_t) 
476 
val c_t = cterm_incr_types thy refl_idx i_t 

477 
in cterm_instantiate [(refl_x, c_t)] REFL_THM end; 

23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

478 

35865  479 
fun get_ty_arg_size _ (Const (@{const_name "op ="}, _)) = 0 (*equality has no type arguments*) 
36909
7d5587f6d5f7
made Sledgehammer's fulltyped proof reconstruction work for the first time;
blanchet
parents:
36556
diff
changeset

480 
 get_ty_arg_size thy (Const (c, _)) = (num_type_args thy c handle TYPE _ => 0) 
32994  481 
 get_ty_arg_size _ _ = 0; 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

482 

32956  483 
(* INFERENCE RULE: EQUALITY *) 
37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

484 
fun equality_inf ctxt mode skolems (pos, atm) fp fr = 
32956  485 
let val thy = ProofContext.theory_of ctxt 
486 
val m_tm = Metis.Term.Fn atm 

37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

487 
val [i_atm,i_tm] = hol_terms_from_fol ctxt mode skolems [m_tm, fr] 
32956  488 
val _ = trace_msg (fn () => "sign of the literal: " ^ Bool.toString pos) 
32994  489 
fun replace_item_list lx 0 (_::ls) = lx::ls 
32956  490 
 replace_item_list lx i (l::ls) = l :: replace_item_list lx (i1) ls 
491 
fun path_finder_FO tm [] = (tm, Term.Bound 0) 

492 
 path_finder_FO tm (p::ps) = 

35865  493 
let val (tm1,args) = strip_comb tm 
32956  494 
val adjustment = get_ty_arg_size thy tm1 
495 
val p' = if adjustment > p then p else padjustment 

496 
val tm_p = List.nth(args,p') 

37516
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

497 
handle Subscript => raise METIS ("equality_inf", Int.toString p ^ " adj " ^ 
32956  498 
Int.toString adjustment ^ " term " ^ Syntax.string_of_term ctxt tm) 
499 
val _ = trace_msg (fn () => "path_finder: " ^ Int.toString p ^ 

500 
" " ^ Syntax.string_of_term ctxt tm_p) 

501 
val (r,t) = path_finder_FO tm_p ps 

502 
in 

503 
(r, list_comb (tm1, replace_item_list t p' args)) 

504 
end 

505 
fun path_finder_HO tm [] = (tm, Term.Bound 0) 

506 
 path_finder_HO (t$u) (0::ps) = (fn(x,y) => (x, y$u)) (path_finder_HO t ps) 

32994  507 
 path_finder_HO (t$u) (_::ps) = (fn(x,y) => (x, t$y)) (path_finder_HO u ps) 
37402
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

508 
 path_finder_HO tm ps = 
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

509 
raise Fail ("equality_inf, path_finder_HO: path = " ^ 
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

510 
space_implode " " (map Int.toString ps) ^ 
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

511 
" isaterm: " ^ Syntax.string_of_term ctxt tm) 
32956  512 
fun path_finder_FT tm [] _ = (tm, Term.Bound 0) 
32994  513 
 path_finder_FT tm (0::ps) (Metis.Term.Fn ("ti", [t1, _])) = 
32956  514 
path_finder_FT tm ps t1 
32994  515 
 path_finder_FT (t$u) (0::ps) (Metis.Term.Fn (".", [t1, _])) = 
32956  516 
(fn(x,y) => (x, y$u)) (path_finder_FT t ps t1) 
32994  517 
 path_finder_FT (t$u) (1::ps) (Metis.Term.Fn (".", [_, t2])) = 
32956  518 
(fn(x,y) => (x, t$y)) (path_finder_FT u ps t2) 
37402
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

519 
 path_finder_FT tm ps t = 
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

520 
raise Fail ("equality_inf, path_finder_FT: path = " ^ 
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

521 
space_implode " " (map Int.toString ps) ^ 
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

522 
" isaterm: " ^ Syntax.string_of_term ctxt tm ^ 
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

523 
" folterm: " ^ Metis.Term.toString t) 
32956  524 
fun path_finder FO tm ps _ = path_finder_FO tm ps 
35865  525 
 path_finder HO (tm as Const(@{const_name "op ="},_) $ _ $ _) (p::ps) _ = 
32956  526 
(*equality: not curried, as other predicates are*) 
527 
if p=0 then path_finder_HO tm (0::1::ps) (*select first operand*) 

528 
else path_finder_HO tm (p::ps) (*1 selects second operand*) 

32994  529 
 path_finder HO tm (_ :: ps) (Metis.Term.Fn ("{}", [_])) = 
32956  530 
path_finder_HO tm ps (*if not equality, ignore head to skip hBOOL*) 
35865  531 
 path_finder FT (tm as Const(@{const_name "op ="}, _) $ _ $ _) (p::ps) 
32956  532 
(Metis.Term.Fn ("=", [t1,t2])) = 
533 
(*equality: not curried, as other predicates are*) 

534 
if p=0 then path_finder_FT tm (0::1::ps) 

535 
(Metis.Term.Fn (".", [Metis.Term.Fn (".", [metis_eq,t1]), t2])) 

536 
(*select first operand*) 

537 
else path_finder_FT tm (p::ps) 

538 
(Metis.Term.Fn (".", [metis_eq,t2])) 

539 
(*1 selects second operand*) 

32994  540 
 path_finder FT tm (_ :: ps) (Metis.Term.Fn ("{}", [t1])) = path_finder_FT tm ps t1 
32956  541 
(*if not equality, ignore head to skip the hBOOL predicate*) 
542 
 path_finder FT tm ps t = path_finder_FT tm ps t (*really an error case!*) 

35865  543 
fun path_finder_lit ((nt as Const (@{const_name Not}, _)) $ tm_a) idx = 
32956  544 
let val (tm, tm_rslt) = path_finder mode tm_a idx m_tm 
545 
in (tm, nt $ tm_rslt) end 

546 
 path_finder_lit tm_a idx = path_finder mode tm_a idx m_tm 

547 
val (tm_subst, body) = path_finder_lit i_atm fp 

548 
val tm_abs = Term.Abs("x", Term.type_of tm_subst, body) 

549 
val _ = trace_msg (fn () => "abstraction: " ^ Syntax.string_of_term ctxt tm_abs) 

550 
val _ = trace_msg (fn () => "i_tm: " ^ Syntax.string_of_term ctxt i_tm) 

551 
val _ = trace_msg (fn () => "located term: " ^ Syntax.string_of_term ctxt tm_subst) 

552 
val imax = maxidx_of_term (i_tm $ tm_abs $ tm_subst) (*ill typed but gives right max*) 

36945  553 
val subst' = Thm.incr_indexes (imax+1) (if pos then subst_em else ssubst_em) 
32956  554 
val _ = trace_msg (fn () => "subst' " ^ Display.string_of_thm ctxt subst') 
555 
val eq_terms = map (pairself (cterm_of thy)) 

33227  556 
(ListPair.zip (OldTerm.term_vars (prop_of subst'), [tm_abs, tm_subst, i_tm])) 
32956  557 
in cterm_instantiate eq_terms subst' end; 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

558 

32956  559 
val factor = Seq.hd o distinct_subgoals_tac; 
28528
0cf2749e8ef7
The result of the equality inference rule no longer undergoes factoring.
paulson
parents:
28262
diff
changeset

560 

37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

561 
fun step ctxt mode skolems thpairs p = 
37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

562 
case p of 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

563 
(fol_th, Metis.Proof.Axiom _) => factor (axiom_inf thpairs fol_th) 
37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

564 
 (_, Metis.Proof.Assume f_atm) => assume_inf ctxt mode skolems f_atm 
37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

565 
 (_, Metis.Proof.Subst (f_subst, f_th1)) => 
37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

566 
factor (inst_inf ctxt mode skolems thpairs f_subst f_th1) 
37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

567 
 (_, Metis.Proof.Resolve(f_atm, f_th1, f_th2)) => 
37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

568 
factor (resolve_inf ctxt mode skolems thpairs f_atm f_th1 f_th2) 
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

569 
 (_, Metis.Proof.Refl f_tm) => refl_inf ctxt mode skolems f_tm 
37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

570 
 (_, Metis.Proof.Equality (f_lit, f_p, f_r)) => 
37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

571 
equality_inf ctxt mode skolems f_lit f_p f_r 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

572 

35865  573 
fun real_literal (_, (c, _)) = not (String.isPrefix class_prefix c); 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

574 

37402
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

575 
(* FIXME: use "fold" instead *) 
37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

576 
fun translate _ _ _ thpairs [] = thpairs 
37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

577 
 translate ctxt mode skolems thpairs ((fol_th, inf) :: infpairs) = 
32956  578 
let val _ = trace_msg (fn () => "=============================================") 
579 
val _ = trace_msg (fn () => "METIS THM: " ^ Metis.Thm.toString fol_th) 

580 
val _ = trace_msg (fn () => "INFERENCE: " ^ Metis.Proof.inferenceToString inf) 

37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

581 
val th = Meson.flexflex_first_order (step ctxt mode skolems 
37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

582 
thpairs (fol_th, inf)) 
32956  583 
val _ = trace_msg (fn () => "ISABELLE THM: " ^ Display.string_of_thm ctxt th) 
584 
val _ = trace_msg (fn () => "=============================================") 

32994  585 
val n_metis_lits = 
586 
length (filter real_literal (Metis.LiteralSet.toList (Metis.Thm.clause fol_th))) 

32956  587 
in 
588 
if nprems_of th = n_metis_lits then () 

37516
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

589 
else raise METIS ("translate", "Proof reconstruction has gone wrong."); 
37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

590 
translate ctxt mode skolems ((fol_th, th) :: thpairs) infpairs 
32956  591 
end; 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

592 

32956  593 
(*Determining which axiom clauses are actually used*) 
594 
fun used_axioms axioms (th, Metis.Proof.Axiom _) = SOME (lookth axioms th) 

32994  595 
 used_axioms _ _ = NONE; 
24855  596 

32956  597 
(*  *) 
598 
(* Translation of HO Clauses *) 

599 
(*  *) 

23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

600 

37479
f6b1ee5b420b
try to improve Sledgehammer/Metis's behavior in full_types mode, e.g. by handing True, False, and If better
blanchet
parents:
37417
diff
changeset

601 
fun cnf_helper_theorem thy raw th = 
37926
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

602 
if raw then th else the_single (Clausifier.cnf_axiom thy false th) 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

603 

32956  604 
fun type_ext thy tms = 
35865  605 
let val subs = tfree_classes_of_terms tms 
606 
val supers = tvar_classes_of_terms tms 

607 
and tycons = type_consts_of_terms thy tms 

608 
val (supers', arity_clauses) = make_arity_clauses thy tycons supers 

37925  609 
val class_rel_clauses = make_class_rel_clauses thy subs supers' 
610 
in map class_rel_cls class_rel_clauses @ map arity_cls arity_clauses 

32956  611 
end; 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

612 

32956  613 
(*  *) 
614 
(* Logic maps manage the interface between HOL and firstorder logic. *) 

615 
(*  *) 

23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

616 

32956  617 
type logic_map = 
35865  618 
{axioms: (Metis.Thm.thm * thm) list, 
37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

619 
tfrees: type_literal list, 
37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

620 
skolems: (string * term) list} 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

621 

32994  622 
fun const_in_metis c (pred, tm_list) = 
32956  623 
let 
32994  624 
fun in_mterm (Metis.Term.Var _) = false 
32956  625 
 in_mterm (Metis.Term.Fn (".", tm_list)) = exists in_mterm tm_list 
626 
 in_mterm (Metis.Term.Fn (nm, tm_list)) = c=nm orelse exists in_mterm tm_list 

32994  627 
in c = pred orelse exists in_mterm tm_list end; 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

628 

32956  629 
(*Extract TFree constraints from context to include as conjecture clauses*) 
630 
fun init_tfrees ctxt = 

36966
adc11fb3f3aa
generate proper arity declarations for TFrees for SPASS's DFG format;
blanchet
parents:
36945
diff
changeset

631 
let fun add ((a,i),s) Ts = if i = ~1 then TFree(a,s) :: Ts else Ts in 
adc11fb3f3aa
generate proper arity declarations for TFrees for SPASS's DFG format;
blanchet
parents:
36945
diff
changeset

632 
Vartab.fold add (#2 (Variable.constraints_of ctxt)) [] 
adc11fb3f3aa
generate proper arity declarations for TFrees for SPASS's DFG format;
blanchet
parents:
36945
diff
changeset

633 
> type_literals_for_types 
36556
81dc2c20f052
use readable names in "debug" mode for type vars + don't pipe facts using "using" but rather give them directly to metis (works better with type variables)
blanchet
parents:
36401
diff
changeset

634 
end; 
24937
340523598914
contextbased treatment of generalization; also handling TFrees in axiom clauses
paulson
parents:
24920
diff
changeset

635 

32956  636 
(*transform isabelle type / arity clause to metis clause *) 
637 
fun add_type_thm [] lmap = lmap 

37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

638 
 add_type_thm ((ith, mth) :: cls) {axioms, tfrees, skolems} = 
37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

639 
add_type_thm cls {axioms = (mth, ith) :: axioms, tfrees = tfrees, 
37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

640 
skolems = skolems} 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

641 

32956  642 
(*Insert nonlogical axioms corresponding to all accumulated TFrees*) 
37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

643 
fun add_tfrees {axioms, tfrees, skolems} : logic_map = 
37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

644 
{axioms = map (rpair TrueI o metis_of_tfree) (distinct (op =) tfrees) @ 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

645 
axioms, 
37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

646 
tfrees = tfrees, skolems = skolems} 
25713  647 

32956  648 
fun string_of_mode FO = "FO" 
649 
 string_of_mode HO = "HO" 

650 
 string_of_mode FT = "FT" 

32532
a0a54a51b15b
My umpteenth attempt to commit the method metisFT, a fullytyped version of metis
paulson
parents:
32530
diff
changeset

651 

37479
f6b1ee5b420b
try to improve Sledgehammer/Metis's behavior in full_types mode, e.g. by handing True, False, and If better
blanchet
parents:
37417
diff
changeset

652 
val helpers = 
f6b1ee5b420b
try to improve Sledgehammer/Metis's behavior in full_types mode, e.g. by handing True, False, and If better
blanchet
parents:
37417
diff
changeset

653 
[("c_COMBI", (false, @{thms COMBI_def})), 
f6b1ee5b420b
try to improve Sledgehammer/Metis's behavior in full_types mode, e.g. by handing True, False, and If better
blanchet
parents:
37417
diff
changeset

654 
("c_COMBK", (false, @{thms COMBK_def})), 
f6b1ee5b420b
try to improve Sledgehammer/Metis's behavior in full_types mode, e.g. by handing True, False, and If better
blanchet
parents:
37417
diff
changeset

655 
("c_COMBB", (false, @{thms COMBB_def})), 
f6b1ee5b420b
try to improve Sledgehammer/Metis's behavior in full_types mode, e.g. by handing True, False, and If better
blanchet
parents:
37417
diff
changeset

656 
("c_COMBC", (false, @{thms COMBC_def})), 
f6b1ee5b420b
try to improve Sledgehammer/Metis's behavior in full_types mode, e.g. by handing True, False, and If better
blanchet
parents:
37417
diff
changeset

657 
("c_COMBS", (false, @{thms COMBS_def})), 
f6b1ee5b420b
try to improve Sledgehammer/Metis's behavior in full_types mode, e.g. by handing True, False, and If better
blanchet
parents:
37417
diff
changeset

658 
("c_fequal", (false, @{thms fequal_imp_equal equal_imp_fequal})), 
f6b1ee5b420b
try to improve Sledgehammer/Metis's behavior in full_types mode, e.g. by handing True, False, and If better
blanchet
parents:
37417
diff
changeset

659 
("c_True", (true, @{thms True_or_False})), 
f6b1ee5b420b
try to improve Sledgehammer/Metis's behavior in full_types mode, e.g. by handing True, False, and If better
blanchet
parents:
37417
diff
changeset

660 
("c_False", (true, @{thms True_or_False})), 
f6b1ee5b420b
try to improve Sledgehammer/Metis's behavior in full_types mode, e.g. by handing True, False, and If better
blanchet
parents:
37417
diff
changeset

661 
("c_If", (true, @{thms if_True if_False True_or_False}))] 
f6b1ee5b420b
try to improve Sledgehammer/Metis's behavior in full_types mode, e.g. by handing True, False, and If better
blanchet
parents:
37417
diff
changeset

662 

37623
295f3a9b44b6
move functions not needed by Metis out of "Metis_Clauses"
blanchet
parents:
37619
diff
changeset

663 
fun is_quasi_fol_clause thy = 
37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

664 
Meson.is_fol_term thy o snd o conceal_skolem_terms ~1 [] o prop_of 
37623
295f3a9b44b6
move functions not needed by Metis out of "Metis_Clauses"
blanchet
parents:
37619
diff
changeset

665 

32956  666 
(* Function to generate metis clauses, including comb and type clauses *) 
667 
fun build_map mode0 ctxt cls ths = 

668 
let val thy = ProofContext.theory_of ctxt 

669 
(*The modes FO and FT are sticky. HO can be downgraded to FO.*) 

670 
fun set_mode FO = FO 

37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

671 
 set_mode HO = 
37623
295f3a9b44b6
move functions not needed by Metis out of "Metis_Clauses"
blanchet
parents:
37619
diff
changeset

672 
if forall (is_quasi_fol_clause thy) (cls @ ths) then FO else HO 
32956  673 
 set_mode FT = FT 
674 
val mode = set_mode mode0 

675 
(*transform isabelle clause to metis clause *) 

37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

676 
fun add_thm is_conjecture ith {axioms, tfrees, skolems} : logic_map = 
37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

677 
let 
37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

678 
val (mth, tfree_lits, skolems) = 
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

679 
hol_thm_to_fol is_conjecture ctxt mode (length axioms) skolems ith 
32956  680 
in 
681 
{axioms = (mth, Meson.make_meta_clause ith) :: axioms, 

37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

682 
tfrees = union (op =) tfree_lits tfrees, skolems = skolems} 
32956  683 
end; 
37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

684 
val lmap = {axioms = [], tfrees = init_tfrees ctxt, skolems = []} 
37498
b426cbdb5a23
removed Sledgehammer's support for the DFG syntax;
blanchet
parents:
37479
diff
changeset

685 
> fold (add_thm true) cls 
b426cbdb5a23
removed Sledgehammer's support for the DFG syntax;
blanchet
parents:
37479
diff
changeset

686 
> add_tfrees 
b426cbdb5a23
removed Sledgehammer's support for the DFG syntax;
blanchet
parents:
37479
diff
changeset

687 
> fold (add_thm false) ths 
32956  688 
val clause_lists = map (Metis.Thm.clause o #1) (#axioms lmap) 
37479
f6b1ee5b420b
try to improve Sledgehammer/Metis's behavior in full_types mode, e.g. by handing True, False, and If better
blanchet
parents:
37417
diff
changeset

689 
fun is_used c = 
f6b1ee5b420b
try to improve Sledgehammer/Metis's behavior in full_types mode, e.g. by handing True, False, and If better
blanchet
parents:
37417
diff
changeset

690 
exists (Metis.LiteralSet.exists (const_in_metis c o #2)) clause_lists 
37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

691 
val lmap = 
37479
f6b1ee5b420b
try to improve Sledgehammer/Metis's behavior in full_types mode, e.g. by handing True, False, and If better
blanchet
parents:
37417
diff
changeset

692 
if mode = FO then 
f6b1ee5b420b
try to improve Sledgehammer/Metis's behavior in full_types mode, e.g. by handing True, False, and If better
blanchet
parents:
37417
diff
changeset

693 
lmap 
f6b1ee5b420b
try to improve Sledgehammer/Metis's behavior in full_types mode, e.g. by handing True, False, and If better
blanchet
parents:
37417
diff
changeset

694 
else 
f6b1ee5b420b
try to improve Sledgehammer/Metis's behavior in full_types mode, e.g. by handing True, False, and If better
blanchet
parents:
37417
diff
changeset

695 
let 
f6b1ee5b420b
try to improve Sledgehammer/Metis's behavior in full_types mode, e.g. by handing True, False, and If better
blanchet
parents:
37417
diff
changeset

696 
val helper_ths = 
f6b1ee5b420b
try to improve Sledgehammer/Metis's behavior in full_types mode, e.g. by handing True, False, and If better
blanchet
parents:
37417
diff
changeset

697 
helpers > filter (is_used o fst) 
f6b1ee5b420b
try to improve Sledgehammer/Metis's behavior in full_types mode, e.g. by handing True, False, and If better
blanchet
parents:
37417
diff
changeset

698 
> maps (fn (_, (raw, thms)) => 
f6b1ee5b420b
try to improve Sledgehammer/Metis's behavior in full_types mode, e.g. by handing True, False, and If better
blanchet
parents:
37417
diff
changeset

699 
if mode = FT orelse not raw then 
f6b1ee5b420b
try to improve Sledgehammer/Metis's behavior in full_types mode, e.g. by handing True, False, and If better
blanchet
parents:
37417
diff
changeset

700 
map (cnf_helper_theorem @{theory} raw) thms 
f6b1ee5b420b
try to improve Sledgehammer/Metis's behavior in full_types mode, e.g. by handing True, False, and If better
blanchet
parents:
37417
diff
changeset

701 
else 
f6b1ee5b420b
try to improve Sledgehammer/Metis's behavior in full_types mode, e.g. by handing True, False, and If better
blanchet
parents:
37417
diff
changeset

702 
[]) 
f6b1ee5b420b
try to improve Sledgehammer/Metis's behavior in full_types mode, e.g. by handing True, False, and If better
blanchet
parents:
37417
diff
changeset

703 
in lmap > fold (add_thm false) helper_ths end 
37410
2bf7e6136047
adjusted the polymorphism handling of Skolem constants so that proof reconstruction doesn't fail in "equality_inf"
blanchet
parents:
37402
diff
changeset

704 
in (mode, add_type_thm (type_ext thy (map prop_of (cls @ ths))) lmap) end 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

705 

32956  706 
fun refute cls = 
707 
Metis.Resolution.loop (Metis.Resolution.new Metis.Resolution.default cls); 

23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

708 

32956  709 
fun is_false t = t aconv (HOLogic.mk_Trueprop HOLogic.false_const); 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

710 

32956  711 
fun common_thm ths1 ths2 = exists (member Thm.eq_thm ths1) (map Meson.make_meta_clause ths2); 
24855  712 

37573  713 

37516
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

714 
(* Main function to start Metis proof and reconstruction *) 
32956  715 
fun FOL_SOLVE mode ctxt cls ths0 = 
716 
let val thy = ProofContext.theory_of ctxt 

35826  717 
val th_cls_pairs = 
37926
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

718 
map (fn th => (Thm.get_name_hint th, Clausifier.cnf_axiom thy false th)) ths0 
32956  719 
val ths = maps #2 th_cls_pairs 
720 
val _ = trace_msg (fn () => "FOL_SOLVE: CONJECTURE CLAUSES") 

721 
val _ = app (fn th => trace_msg (fn () => Display.string_of_thm ctxt th)) cls 

722 
val _ = trace_msg (fn () => "THEOREM CLAUSES") 

723 
val _ = app (fn th => trace_msg (fn () => Display.string_of_thm ctxt th)) ths 

37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

724 
val (mode, {axioms, tfrees, skolems}) = build_map mode ctxt cls ths 
32956  725 
val _ = if null tfrees then () 
726 
else (trace_msg (fn () => "TFREE CLAUSES"); 

37643
f576af716aa6
rewrote the TPTP problem generation code more or less from scratch;
blanchet
parents:
37632
diff
changeset

727 
app (fn TyLitFree ((s, _), (s', _)) => 
37573  728 
trace_msg (fn _ => s ^ "(" ^ s' ^ ")")) tfrees) 
32956  729 
val _ = trace_msg (fn () => "CLAUSES GIVEN TO METIS") 
730 
val thms = map #1 axioms 

731 
val _ = app (fn th => trace_msg (fn () => Metis.Thm.toString th)) thms 

732 
val _ = trace_msg (fn () => "mode = " ^ string_of_mode mode) 

733 
val _ = trace_msg (fn () => "START METIS PROVE PROCESS") 

734 
in 

33317  735 
case filter (is_false o prop_of) cls of 
32956  736 
false_th::_ => [false_th RS @{thm FalseE}] 
737 
 [] => 

738 
case refute thms of 

739 
Metis.Resolution.Contradiction mth => 

740 
let val _ = trace_msg (fn () => "METIS RECONSTRUCTION START: " ^ 

741 
Metis.Thm.toString mth) 

742 
val ctxt' = fold Variable.declare_constraints (map prop_of cls) ctxt 

743 
(*add constraints arising from converting goal to clause form*) 

744 
val proof = Metis.Proof.proof mth 

37625
35eeb95c5bee
rename "skolem_somes" to "skolems", now that there's only one flavor of Skolems
blanchet
parents:
37623
diff
changeset

745 
val result = translate ctxt' mode skolems axioms proof 
32956  746 
and used = map_filter (used_axioms axioms) proof 
747 
val _ = trace_msg (fn () => "METIS COMPLETED...clauses actually used:") 

748 
val _ = app (fn th => trace_msg (fn () => Display.string_of_thm ctxt th)) used 

33305  749 
val unused = th_cls_pairs > map_filter (fn (name, cls) => 
750 
if common_thm used cls then NONE else SOME name) 

32956  751 
in 
36383  752 
if not (null cls) andalso not (common_thm used cls) then 
753 
warning "Metis: The assumptions are inconsistent." 

754 
else 

755 
(); 

756 
if not (null unused) then 

36230
43d10a494c91
added warning about inconsistent context to Metis;
blanchet
parents:
36170
diff
changeset

757 
warning ("Metis: Unused theorems: " ^ commas_quote unused 
43d10a494c91
added warning about inconsistent context to Metis;
blanchet
parents:
36170
diff
changeset

758 
^ ".") 
43d10a494c91
added warning about inconsistent context to Metis;
blanchet
parents:
36170
diff
changeset

759 
else 
43d10a494c91
added warning about inconsistent context to Metis;
blanchet
parents:
36170
diff
changeset

760 
(); 
32956  761 
case result of 
762 
(_,ith)::_ => 

36230
43d10a494c91
added warning about inconsistent context to Metis;
blanchet
parents:
36170
diff
changeset

763 
(trace_msg (fn () => "Success: " ^ Display.string_of_thm ctxt ith); 
32956  764 
[ith]) 
36230
43d10a494c91
added warning about inconsistent context to Metis;
blanchet
parents:
36170
diff
changeset

765 
 _ => (trace_msg (fn () => "Metis: No result"); 
37516
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

766 
raise METIS ("FOL_SOLVE", "")) 
32956  767 
end 
768 
 Metis.Resolution.Satisfiable _ => 

769 
(trace_msg (fn () => "Metis: No firstorder proof with the lemmas supplied"); 

37516
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

770 
raise METIS ("FOL_SOLVE", "")) 
32956  771 
end; 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

772 

37626
1146291fe718
move blacklisting completely out of the clausifier;
blanchet
parents:
37625
diff
changeset

773 
val type_has_top_sort = 
1146291fe718
move blacklisting completely out of the clausifier;
blanchet
parents:
37625
diff
changeset

774 
exists_subtype (fn TFree (_, []) => true  TVar (_, []) => true  _ => false) 
1146291fe718
move blacklisting completely out of the clausifier;
blanchet
parents:
37625
diff
changeset

775 

37516
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

776 
fun generic_metis_tac mode ctxt ths i st0 = 
37926
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

777 
let 
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

778 
val _ = trace_msg (fn () => 
32956  779 
"Metis called with theorems " ^ cat_lines (map (Display.string_of_thm ctxt) ths)) 
780 
in 

37626
1146291fe718
move blacklisting completely out of the clausifier;
blanchet
parents:
37625
diff
changeset

781 
if exists_type type_has_top_sort (prop_of st0) then 
37516
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

782 
(warning ("Metis: Proof state contains the universal sort {}"); Seq.empty) 
35568
8fbbfc39508f
renamed type_has_empty_sort to type_has_topsort  {} is the full universal sort;
wenzelm
parents:
34087
diff
changeset

783 
else 
37926
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

784 
Meson.MESON (maps Clausifier.neg_clausify) 
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

785 
(fn cls => resolve_tac (FOL_SOLVE mode ctxt cls ths) 1) 
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

786 
ctxt i st0 
37516
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

787 
handle ERROR msg => raise METIS ("generic_metis_tac", msg) 
32956  788 
end 
37516
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

789 
handle METIS (loc, msg) => 
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

790 
if mode = HO then 
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

791 
(warning ("Metis: Falling back on \"metisFT\"."); 
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

792 
generic_metis_tac FT ctxt ths i st0) 
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

793 
else if msg = "" then 
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

794 
Seq.empty 
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

795 
else 
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

796 
raise error ("Metis (" ^ loc ^ "): " ^ msg) 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

797 

37516
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

798 
val metis_tac = generic_metis_tac HO 
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

799 
val metisF_tac = generic_metis_tac FO 
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

800 
val metisFT_tac = generic_metis_tac FT 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

801 

37516
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

802 
fun method name mode = 
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

803 
Method.setup name (Attrib.thms >> (fn ths => fn ctxt => 
37926
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

804 
METHOD (fn facts => HEADGOAL (CHANGED_PROP 
e6ff246c0cdb
renamings + only need second component of name pool to reconstruct proofs
blanchet
parents:
37925
diff
changeset

805 
o generic_metis_tac mode ctxt (facts @ ths))))) 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

806 

32956  807 
val setup = 
37516
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

808 
type_lits_setup 
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

809 
#> method @{binding metis} HO "Metis for FOL/HOL problems" 
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

810 
#> method @{binding metisF} FO "Metis for FOL problems" 
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

811 
#> method @{binding metisFT} FT 
c81c86bfc18a
have "metis" method and "metis_tac" fall back on "metisFT" upon failure, following a suggestion by Larry
blanchet
parents:
37509
diff
changeset

812 
"Metis for FOL/HOL problems with fullytyped translation" 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

813 

028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

814 
end; 