author  blanchet 
Sat, 12 Jun 2010 11:11:07 +0200  
changeset 37402  12cb33916e37 
parent 37399  34f080a12063 
child 37410  2bf7e6136047 
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 

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

21 
open Sledgehammer_Util 
35865  22 
open Sledgehammer_FOL_Clause 
23 
open Sledgehammer_Fact_Preprocessor 

24 
open Sledgehammer_HOL_Clause 

25 
open Sledgehammer_Proof_Reconstruct 

26 
open Sledgehammer_Fact_Filter 

35826  27 

32956  28 
val trace = Unsynchronized.ref false; 
35826  29 
fun trace_msg msg = if !trace then tracing (msg ()) else (); 
32955  30 

36001  31 
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

32 

35826  33 
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

34 

32956  35 
(*  *) 
36 
(* Useful Theorems *) 

37 
(*  *) 

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

38 
val EXCLUDED_MIDDLE = @{lemma "P ==> ~ P ==> False" by (rule notE)} 
36945  39 
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

40 
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

41 
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

42 

32956  43 
(*  *) 
44 
(* Useful Functions *) 

45 
(*  *) 

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

46 

32956  47 
(* match untyped terms*) 
48 
fun untyped_aconv (Const(a,_)) (Const(b,_)) = (a=b) 

49 
 untyped_aconv (Free(a,_)) (Free(b,_)) = (a=b) 

50 
 untyped_aconv (Var((a,_),_)) (Var((b,_),_)) = (a=b) (*the index is ignored!*) 

51 
 untyped_aconv (Bound i) (Bound j) = (i=j) 

52 
 untyped_aconv (Abs(a,_,t)) (Abs(b,_,u)) = (a=b) andalso untyped_aconv t u 

53 
 untyped_aconv (t1$t2) (u1$u2) = untyped_aconv t1 u1 andalso untyped_aconv t2 u2 

54 
 untyped_aconv _ _ = false; 

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

55 

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

58 
let val lit = Envir.eta_contract lit 

59 
fun get n [] = raise Empty 

60 
 get n (x::xs) = if untyped_aconv lit (Envir.eta_contract (HOLogic.dest_Trueprop x)) 

61 
then n else get (n+1) xs 

62 
in get 1 end; 

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

63 

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

66 
(*  *) 

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

67 

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

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

70 

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

72 

36169
27b1cc58715e
store nonmangled names along with mangled type names in Sledgehammer for debugging purposes
blanchet
parents:
36168
diff
changeset

73 
fun hol_type_to_fol (TyVar (x, _)) = Metis.Term.Var x 
27b1cc58715e
store nonmangled names along with mangled type names in Sledgehammer for debugging purposes
blanchet
parents:
36168
diff
changeset

74 
 hol_type_to_fol (TyFree (s, _)) = Metis.Term.Fn (s, []) 
27b1cc58715e
store nonmangled names along with mangled type names in Sledgehammer for debugging purposes
blanchet
parents:
36168
diff
changeset

75 
 hol_type_to_fol (TyConstr ((s, _), tps)) = 
27b1cc58715e
store nonmangled names along with mangled type names in Sledgehammer for debugging purposes
blanchet
parents:
36168
diff
changeset

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

77 

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

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

80 

32956  81 
fun hol_term_to_fol_FO tm = 
35865  82 
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

83 
(CombConst ((c, _), _, tys), tms) => 
32956  84 
let val tyargs = map hol_type_to_fol tys 
85 
val args = map hol_term_to_fol_FO tms 

86 
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

87 
 (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

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

89 

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

90 
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

91 
 hol_term_to_fol_HO (CombConst ((a, _), _, tylist)) = 
32994  92 
Metis.Term.Fn (fn_isa_to_met a, map hol_type_to_fol tylist) 
35865  93 
 hol_term_to_fol_HO (CombApp (tm1, tm2)) = 
32994  94 
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

95 

32956  96 
(*The fullytyped translation, to avoid type errors*) 
97 
fun wrap_type (tm, ty) = Metis.Term.Fn("ti", [tm, hol_type_to_fol ty]); 

98 

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

99 
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

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

105 

35865  106 
fun hol_literal_to_fol FO (Literal (pol, 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

107 
let val (CombConst((p, _), _, tys), tms) = strip_combterm_comb tm 
32956  108 
val tylits = if p = "equal" then [] else map hol_type_to_fol tys 
109 
val lits = map hol_term_to_fol_FO tms 

110 
in metis_lit pol (fn_isa_to_met p) (tylits @ lits) end 

35865  111 
 hol_literal_to_fol HO (Literal (pol, tm)) = 
112 
(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

113 
(CombConst(("equal", _), _, _), tms) => 
32956  114 
metis_lit pol "=" (map hol_term_to_fol_HO tms) 
115 
 _ => metis_lit pol "{}" [hol_term_to_fol_HO tm]) (*hBOOL*) 

35865  116 
 hol_literal_to_fol FT (Literal (pol, tm)) = 
117 
(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

118 
(CombConst(("equal", _), _, _), tms) => 
32956  119 
metis_lit pol "=" (map hol_term_to_fol_FT tms) 
120 
 _ => metis_lit pol "{}" [hol_term_to_fol_FT tm]) (*hBOOL*); 

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

121 

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

122 
fun literals_of_hol_term thy mode t = 
35865  123 
let val (lits, types_sorts) = literals_of_term thy t 
32956  124 
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

125 

32956  126 
(*Sign should be "true" for conjecture type constraints, "false" for type lits in clauses.*) 
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 
fun metis_of_type_literals pos (TyLitVar (s, (s', _))) = 
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

128 
metis_lit pos s [Metis.Term.Var s'] 
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_of_type_literals pos (TyLitFree (s, (s', _))) = 
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

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

131 

32994  132 
fun default_sort _ (TVar _) = false 
33035  133 
 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

134 

32956  135 
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

136 
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

137 

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

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

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

140 
val thy = ProofContext.theory_of ctxt 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

141 
val (skolem_somes, (mlits, types_sorts)) = 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

142 
th > prop_of > kill_skolem_Eps j skolem_somes 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

143 
> (HOLogic.dest_Trueprop #> literals_of_hol_term thy mode) 
32956  144 
in 
145 
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

146 
(Metis.Thm.axiom (Metis.LiteralSet.fromList mlits), 
37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

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

149 
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

150 
> type_literals_for_types 
32956  151 
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

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

154 
(Metis.Thm.axiom (Metis.LiteralSet.fromList(mtylits @ mlits)), [], 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

155 
skolem_somes) 
32956  156 
end 
157 
end; 

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

158 

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

160 

35865  161 
fun m_arity_cls (TConsLit (c,t,args)) = 
162 
metis_lit true (make_type_class c) [Metis.Term.Fn(t, map Metis.Term.Var args)] 

163 
 m_arity_cls (TVarLit (c,str)) = 

164 
metis_lit false (make_type_class c) [Metis.Term.Var str]; 

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

165 

32956  166 
(*TrueI is returned as the Isabelle counterpart because there isn't any.*) 
35865  167 
fun arity_cls (ArityClause {conclLit, premLits, ...}) = 
32956  168 
(TrueI, 
169 
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

170 

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

172 

32956  173 
fun m_classrel_cls subclass superclass = 
174 
[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

175 

35865  176 
fun classrel_cls (ClassrelClause {subclass, superclass, ...}) = 
32956  177 
(TrueI, Metis.Thm.axiom (Metis.LiteralSet.fromList (m_classrel_cls subclass superclass))); 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

178 

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

181 
(*  *) 

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

182 

32956  183 
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

184 

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

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

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

188 

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

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

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

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

197 

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

200 
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

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

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

205 
end; 

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

206 

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

25713  209 

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

212 
SEE ALSO axiom_inf below.*) 

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

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

214 

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

217 
let val ww = "'" ^ w 

33035  218 
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

219 

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

222 
 strip_happ args x = (x, args); 

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

223 

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

224 
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

225 

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

229 
 NONE => make_tvar v) 

32956  230 
 fol_type_to_isa ctxt (Metis.Term.Fn(x, tys)) = 
35865  231 
(case strip_prefix tconst_prefix x of 
232 
SOME tc => Term.Type (invert_type_const tc, map (fol_type_to_isa ctxt) tys) 

32956  233 
 NONE => 
35865  234 
case strip_prefix tfree_prefix x of 
32956  235 
SOME tf => mk_tfree ctxt tf 
37402
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

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

237 

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

238 
fun reintroduce_skolem_Eps thy skolem_somes = 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

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

240 
fun aux Ts args t = 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

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

242 
t1 $ t2 => aux Ts (aux Ts [] t2 :: args) t1 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

243 
 Abs (s, T, t') => list_comb (Abs (s, T, aux (T :: Ts) [] t'), args) 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

244 
 Const (s, T) => 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

245 
if String.isPrefix skolem_Eps_pseudo_theory s then 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

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

247 
val (T', args', def') = AList.lookup (op =) skolem_somes s > the 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

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

249 
def' > subst_free (args' ~~ args) 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

250 
> map_types Type_Infer.paramify_vars 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

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

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

253 
list_comb (t, args) 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

254 
 t => list_comb (t, args) 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

255 
in aux [] [] end 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

256 

32956  257 
(*Maps metis terms to isabelle terms*) 
37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

258 
fun hol_term_from_fol_PT ctxt fol_tm = 
32956  259 
let val thy = ProofContext.theory_of ctxt 
37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

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

261 
Metis.Term.toString fol_tm) 
32956  262 
fun tm_to_tt (Metis.Term.Var v) = 
35865  263 
(case strip_prefix tvar_prefix v of 
264 
SOME w => Type (make_tvar w) 

32956  265 
 NONE => 
35865  266 
case strip_prefix schematic_var_prefix v of 
32956  267 
SOME w => Term (mk_var (w, HOLogic.typeT)) 
268 
 NONE => Term (mk_var (v, HOLogic.typeT)) ) 

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

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

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

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

273 
in case rator of 

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

275 
 _ => case tm_to_tt rator of 

276 
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

277 
 _ => raise Fail "tm_to_tt: HO application" 
32956  278 
end 
279 
 tm_to_tt (Metis.Term.Fn (fname, args)) = applic_to_tt (fname,args) 

280 
and applic_to_tt ("=",ts) = 

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

286 
val ntypes = num_type_args thy c 
32956  287 
val nterms = length ts  ntypes 
288 
val tts = map tm_to_tt ts 

289 
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

290 
in if length tys = ntypes then 
32956  291 
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

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

293 
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

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

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

296 
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

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

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

35865  301 
case strip_prefix tconst_prefix a of 
33227  302 
SOME b => 
35865  303 
Type (Term.Type (invert_type_const b, types_of (map tm_to_tt ts))) 
32956  304 
 NONE => (*Maybe a TFree. Should then check that ts=[].*) 
35865  305 
case strip_prefix tfree_prefix a of 
32956  306 
SOME b => Type (mk_tfree ctxt b) 
307 
 NONE => (*a fixed variable? They are Skolem functions.*) 

35865  308 
case strip_prefix fixed_var_prefix a of 
32956  309 
SOME b => 
310 
let val opr = Term.Free(b, HOLogic.typeT) 

311 
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

312 
 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

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

314 
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

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

316 
 _ => 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

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

318 

32956  319 
(*Maps fullytyped metis terms to isabelle terms*) 
37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

320 
fun hol_term_from_fol_FT ctxt fol_tm = 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

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

322 
Metis.Term.toString fol_tm) 
32994  323 
fun cvt (Metis.Term.Fn ("ti", [Metis.Term.Var v, _])) = 
35865  324 
(case strip_prefix schematic_var_prefix v of 
32956  325 
SOME w => mk_var(w, dummyT) 
326 
 NONE => mk_var(v, dummyT)) 

32994  327 
 cvt (Metis.Term.Fn ("ti", [Metis.Term.Fn ("=",[]), _])) = 
32956  328 
Const ("op =", HOLogic.typeT) 
329 
 cvt (Metis.Term.Fn ("ti", [Metis.Term.Fn (x,[]), ty])) = 

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

32956  332 
 NONE => (*Not a constant. Is it a fixed variable??*) 
35865  333 
case strip_prefix fixed_var_prefix x of 
32956  334 
SOME v => Free (v, fol_type_to_isa ctxt ty) 
37402
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

335 
 NONE => raise Fail ("hol_term_from_fol_FT bad constant: " ^ x)) 
32956  336 
 cvt (Metis.Term.Fn ("ti", [Metis.Term.Fn (".",[tm1,tm2]), _])) = 
337 
cvt tm1 $ cvt tm2 

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

339 
cvt tm1 $ cvt tm2 

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

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

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

32956  346 
 NONE => (*Not a constant. Is it a fixed variable??*) 
35865  347 
case strip_prefix fixed_var_prefix x of 
32956  348 
SOME v => Free (v, dummyT) 
37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

349 
 NONE => (trace_msg (fn () => "hol_term_from_fol_FT bad const: " ^ x); 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

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

351 
 cvt t = (trace_msg (fn () => "hol_term_from_fol_FT bad term: " ^ Metis.Term.toString t); 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

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

353 
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

354 

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

355 
fun hol_term_from_fol FT = hol_term_from_fol_FT 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

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

357 

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

358 
fun hol_terms_from_fol ctxt mode skolem_somes fol_tms = 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

359 
let val thy = ProofContext.theory_of ctxt 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

360 
val ts = map (hol_term_from_fol mode ctxt) fol_tms 
32956  361 
val _ = trace_msg (fn () => " calling type inference:") 
362 
val _ = app (fn t => trace_msg (fn () => Syntax.string_of_term ctxt t)) ts 

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

363 
val ts' = 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

364 
ts > map (reintroduce_skolem_Eps thy skolem_somes) > infer_types ctxt 
32956  365 
val _ = app (fn t => trace_msg 
366 
(fn () => " final term: " ^ Syntax.string_of_term ctxt t ^ 

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

368 
ts' 

369 
in ts' end; 

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

370 

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

373 

32956  374 
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

375 

32956  376 
(*  *) 
377 
(* FOL step Inference Rules *) 

378 
(*  *) 

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

379 

32956  380 
(*for debugging only*) 
381 
fun print_thpair (fth,th) = 

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

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

384 
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

385 

32956  386 
fun lookth thpairs (fth : Metis.Thm.thm) = 
33035  387 
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

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

389 
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

390 

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

392 

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

32956  395 
fun inst_excluded_middle thy i_atm = 
396 
let val th = EXCLUDED_MIDDLE 

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

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

399 
in cterm_instantiate substs th end; 

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

400 

32956  401 
(* INFERENCE RULE: AXIOM *) 
36945  402 
fun axiom_inf thpairs th = Thm.incr_indexes 1 (lookth thpairs th); 
32956  403 
(*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

404 

32956  405 
(* INFERENCE RULE: ASSUME *) 
37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

406 
fun assume_inf ctxt mode skolem_somes atm = 
32956  407 
inst_excluded_middle 
408 
(ProofContext.theory_of ctxt) 

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

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

410 

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

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

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

414 
fun inst_inf ctxt mode skolem_somes thpairs fsubst th = 
32956  415 
let val thy = ProofContext.theory_of ctxt 
416 
val i_th = lookth thpairs th 

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

33035  418 
fun find_var x = the (List.find (fn ((a,_),_) => a=x) i_th_vars) 
32956  419 
fun subst_translation (x,y) = 
420 
let val v = find_var x 

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

421 
(* We call "reintroduce_skolem_Eps" and "infer_types" below. *) 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

422 
val t = hol_term_from_fol mode ctxt y 
32956  423 
in SOME (cterm_of thy (Var v), t) end 
424 
handle Option => 

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

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

427 
NONE) 

428 
fun remove_typeinst (a, t) = 

35865  429 
case strip_prefix schematic_var_prefix a of 
32956  430 
SOME b => SOME (b, t) 
35865  431 
 NONE => case strip_prefix tvar_prefix a of 
32956  432 
SOME _ => NONE (*type instantiations are forbidden!*) 
433 
 NONE => SOME (a,t) (*internal Metis var?*) 

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

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

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

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

437 
val tms = rawtms > map (reintroduce_skolem_Eps thy skolem_somes) 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

438 
> infer_types ctxt 
32956  439 
val ctm_of = cterm_incr_types thy (1 + Thm.maxidx_of i_th) 
440 
val substs' = ListPair.zip (vars, map ctm_of tms) 

441 
val _ = trace_msg (fn () => 

442 
cat_lines ("subst_translations:" :: 

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

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

445 
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

446 
in cterm_instantiate substs' i_th end 
37318  447 
handle THM (msg, _, _) => error ("metis error (inst_inf):\n" ^ msg) 
448 
 ERROR msg => error ("metis error (inst_inf):\n" ^ msg ^ 

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

449 
"\n(Perhaps you want to try \"metisFT\" if you \ 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

450 
\haven't done so already.)") 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

451 

32956  452 
(* INFERENCE RULE: RESOLVE *) 
25713  453 

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

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

457 
fun resolve_inc_tyvars(tha,i,thb) = 

458 
let val tha = Drule.incr_type_indexes (1 + Thm.maxidx_of thb) tha 

459 
val ths = Seq.list_of (Thm.bicompose false (false,tha,nprems_of tha) i thb) 

460 
in 

461 
case distinct Thm.eq_thm ths of 

462 
[th] => th 

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

464 
end; 

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

465 

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

466 
fun resolve_inf ctxt mode skolem_somes thpairs atm th1 th2 = 
32956  467 
let 
468 
val i_th1 = lookth thpairs th1 and i_th2 = lookth thpairs th2 

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

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

471 
in 

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

473 
else if is_TrueI i_th2 then i_th1 

474 
else 

475 
let 

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

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

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

480 
val prems_th2 = prems_of i_th2 

481 
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

482 
handle Empty => raise Fail "Failed to find literal in th1" 
32956  483 
val _ = trace_msg (fn () => " index_th1: " ^ Int.toString index_th1) 
484 
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

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

488 
end; 

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

489 

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

492 
val refl_idx = 1 + Thm.maxidx_of REFL_THM; 

25713  493 

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

494 
fun refl_inf ctxt mode skolem_somes t = 
32956  495 
let val thy = ProofContext.theory_of ctxt 
37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

496 
val i_t = singleton (hol_terms_from_fol ctxt mode skolem_somes) t 
32956  497 
val _ = trace_msg (fn () => " term: " ^ Syntax.string_of_term ctxt i_t) 
498 
val c_t = cterm_incr_types thy refl_idx i_t 

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

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

500 

35865  501 
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

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

504 

32956  505 
(* INFERENCE RULE: EQUALITY *) 
37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

506 
fun equality_inf ctxt mode skolem_somes (pos, atm) fp fr = 
32956  507 
let val thy = ProofContext.theory_of ctxt 
508 
val m_tm = Metis.Term.Fn atm 

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

509 
val [i_atm,i_tm] = hol_terms_from_fol ctxt mode skolem_somes [m_tm, fr] 
32956  510 
val _ = trace_msg (fn () => "sign of the literal: " ^ Bool.toString pos) 
32994  511 
fun replace_item_list lx 0 (_::ls) = lx::ls 
32956  512 
 replace_item_list lx i (l::ls) = l :: replace_item_list lx (i1) ls 
513 
fun path_finder_FO tm [] = (tm, Term.Bound 0) 

514 
 path_finder_FO tm (p::ps) = 

35865  515 
let val (tm1,args) = strip_comb tm 
32956  516 
val adjustment = get_ty_arg_size thy tm1 
517 
val p' = if adjustment > p then p else padjustment 

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

519 
handle Subscript => error ("equality_inf: " ^ Int.toString p ^ " adj " ^ 

520 
Int.toString adjustment ^ " term " ^ Syntax.string_of_term ctxt tm) 

521 
val _ = trace_msg (fn () => "path_finder: " ^ Int.toString p ^ 

522 
" " ^ Syntax.string_of_term ctxt tm_p) 

523 
val (r,t) = path_finder_FO tm_p ps 

524 
in 

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

526 
end 

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

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

32994  529 
 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

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

531 
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

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

533 
" isaterm: " ^ Syntax.string_of_term ctxt tm) 
32956  534 
fun path_finder_FT tm [] _ = (tm, Term.Bound 0) 
32994  535 
 path_finder_FT tm (0::ps) (Metis.Term.Fn ("ti", [t1, _])) = 
32956  536 
path_finder_FT tm ps t1 
32994  537 
 path_finder_FT (t$u) (0::ps) (Metis.Term.Fn (".", [t1, _])) = 
32956  538 
(fn(x,y) => (x, y$u)) (path_finder_FT t ps t1) 
32994  539 
 path_finder_FT (t$u) (1::ps) (Metis.Term.Fn (".", [_, t2])) = 
32956  540 
(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

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

542 
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

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

544 
" 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

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

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

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

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

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

558 
(*select first operand*) 

559 
else path_finder_FT tm (p::ps) 

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

561 
(*1 selects second operand*) 

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

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

568 
 path_finder_lit tm_a idx = path_finder mode tm_a idx m_tm 

569 
val (tm_subst, body) = path_finder_lit i_atm fp 

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

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

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

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

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

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

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

580 

32956  581 
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

582 

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

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

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

585 
(fol_th, Metis.Proof.Axiom _) => factor (axiom_inf thpairs fol_th) 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

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

587 
 (_, Metis.Proof.Subst (f_subst, f_th1)) => 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

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

589 
 (_, Metis.Proof.Resolve(f_atm, f_th1, f_th2)) => 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

590 
factor (resolve_inf ctxt mode skolem_somes thpairs f_atm f_th1 f_th2) 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

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

592 
 (_, Metis.Proof.Equality (f_lit, f_p, f_r)) => 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

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

594 

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

596 

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

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

598 
fun translate _ _ _ thpairs [] = thpairs 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

599 
 translate ctxt mode skolem_somes thpairs ((fol_th, inf) :: infpairs) = 
32956  600 
let val _ = trace_msg (fn () => "=============================================") 
601 
val _ = trace_msg (fn () => "METIS THM: " ^ Metis.Thm.toString fol_th) 

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

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

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

604 
thpairs (fol_th, inf)) 
32956  605 
val _ = trace_msg (fn () => "ISABELLE THM: " ^ Display.string_of_thm ctxt th) 
606 
val _ = trace_msg (fn () => "=============================================") 

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

32956  609 
in 
610 
if nprems_of th = n_metis_lits then () 

611 
else error "Metis: proof reconstruction has gone wrong"; 

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

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

614 

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

32994  617 
 used_axioms _ _ = NONE; 
24855  618 

32956  619 
(*  *) 
620 
(* Translation of HO Clauses *) 

621 
(*  *) 

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

622 

35865  623 
fun cnf_th thy th = hd (cnf_axiom thy th); 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

624 

32956  625 
fun type_ext thy tms = 
35865  626 
let val subs = tfree_classes_of_terms tms 
627 
val supers = tvar_classes_of_terms tms 

628 
and tycons = type_consts_of_terms thy tms 

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

630 
val classrel_clauses = make_classrel_clauses thy subs supers' 

32956  631 
in map classrel_cls classrel_clauses @ map arity_cls arity_clauses 
632 
end; 

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

633 

32956  634 
(*  *) 
635 
(* Logic maps manage the interface between HOL and firstorder logic. *) 

636 
(*  *) 

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

637 

32956  638 
type logic_map = 
35865  639 
{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

640 
tfrees: type_literal list, 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

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

642 

32994  643 
fun const_in_metis c (pred, tm_list) = 
32956  644 
let 
32994  645 
fun in_mterm (Metis.Term.Var _) = false 
32956  646 
 in_mterm (Metis.Term.Fn (".", tm_list)) = exists in_mterm tm_list 
647 
 in_mterm (Metis.Term.Fn (nm, tm_list)) = c=nm orelse exists in_mterm tm_list 

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

649 

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

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

652 
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

653 
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

654 
> 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

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

656 

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

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

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

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

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

662 

32956  663 
(*Insert nonlogical axioms corresponding to all accumulated TFrees*) 
37399
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

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

665 
{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

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

667 
tfrees = tfrees, skolem_somes = skolem_somes} 
25713  668 

32956  669 
fun string_of_mode FO = "FO" 
670 
 string_of_mode HO = "HO" 

671 
 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

672 

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

675 
let val thy = ProofContext.theory_of ctxt 

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

677 
fun set_mode FO = FO 

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

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

679 
if forall (is_quasi_fol_term thy o prop_of) (cls @ ths) then FO 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

680 
else HO 
32956  681 
 set_mode FT = FT 
682 
val mode = set_mode mode0 

683 
(*transform isabelle clause to metis clause *) 

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

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

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

686 
val (mth, tfree_lits, skolem_somes) = 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

687 
hol_thm_to_fol is_conjecture ctxt mode (length axioms) skolem_somes 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

688 
ith 
32956  689 
in 
690 
{axioms = (mth, Meson.make_meta_clause ith) :: axioms, 

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

691 
tfrees = union (op =) tfree_lits tfrees, 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

692 
skolem_somes = skolem_somes} 
32956  693 
end; 
37402
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

694 
val lmap as {skolem_somes, ...} = 
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

695 
{axioms = [], tfrees = init_tfrees ctxt, skolem_somes = []} 
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

696 
> fold (add_thm true) cls 
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

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

698 
> fold (add_thm false) ths 
32956  699 
val clause_lists = map (Metis.Thm.clause o #1) (#axioms lmap) 
32994  700 
fun used c = exists (Metis.LiteralSet.exists (const_in_metis c o #2)) clause_lists 
32956  701 
(*Now check for the existence of certain combinators*) 
35865  702 
val thI = if used "c_COMBI" then [cnf_th @{theory} @{thm COMBI_def}] else [] 
703 
val thK = if used "c_COMBK" then [cnf_th @{theory} @{thm COMBK_def}] else [] 

704 
val thB = if used "c_COMBB" then [cnf_th @{theory} @{thm COMBB_def}] else [] 

705 
val thC = if used "c_COMBC" then [cnf_th @{theory} @{thm COMBC_def}] else [] 

706 
val thS = if used "c_COMBS" then [cnf_th @{theory} @{thm COMBS_def}] else [] 

707 
val thEQ = if used "c_fequal" then [cnf_th @{theory} @{thm fequal_imp_equal}, cnf_th @{theory} @{thm equal_imp_fequal}] else [] 

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

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

709 
lmap > mode <> FO 
34f080a12063
proper polymorphic Skolemization of uncached facts + synchronization of caching and relevance filter
blanchet
parents:
37318
diff
changeset

710 
? fold (add_thm false) (thEQ @ thS @ thC @ thB @ thK @ thI) 
32956  711 
in 
37402
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

712 
(mode, add_type_thm (type_ext thy 
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

713 
(* FIXME: Call"kill_skolem_Eps" here? *) 
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

714 
(map ((*snd o kill_skolem_Eps ~1 skolem_somes o*) prop_of) 
12cb33916e37
"raise Fail" for internal errors + one new internal error (instead of "Match")
blanchet
parents:
37399
diff
changeset

715 
(cls @ ths))) lmap) 
32956  716 
end; 
23442
028e39e5e8f3
The Metis prover (slightly modified version from Larry);
wenzelm
parents:
diff
changeset

717 

32956  718 
fun refute cls = 
719 
Metis.Resolution.loop (Metis.Resolution.new Metis.Resolution.default cls); 

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

720 

32956  721 
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

722 

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

32956  725 
exception METIS of string; 
28233
f14f34194f63
The metis method now fails in the usual manner, rather than raising an exception,
paulson
parents:
28175
diff
changeset

726 

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

727 
(* Main function to start metis proof and reconstruction *) 
32956  728 
fun FOL_SOLVE mode ctxt cls ths0 = 
729 
let val thy = ProofContext.theory_of ctxt 

35826  730 
val th_cls_pairs = 
35865  731 
map (fn th => (Thm.get_name_hint th, cnf_axiom thy th)) ths0 
32956  732 
val ths = maps #2 th_cls_pairs 
733 
val _ = trace_msg (fn () => "FOL_SOLVE: CONJECTURE CLAUSES") 

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

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

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

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

737 
val (mode, {axioms, tfrees, skolem_somes}) = build_map mode ctxt cls ths 
32956  738 
val _ = if null tfrees then () 
739 
else (trace_msg (fn () => "TFREE CLAUSES"); 

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

740 
app (fn tf => trace_msg (fn _ => tptp_of_type_literal true tf NONE > fst)) tfrees) 
32956  741 
val _ = trace_msg (fn () => "CLAUSES GIVEN TO METIS") 
742 
val thms = map #1 axioms 

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

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

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

746 
in 

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

750 
case refute thms of 

751 
Metis.Resolution.Contradiction mth => 

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

753 
Metis.Thm.toString mth) 

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

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

756 
val proof = Metis.Proof.proof mth 

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

757 
val result = translate ctxt' mode skolem_somes axioms proof 
32956  758 
and used = map_filter (used_axioms axioms) proof 
759 
val _ = trace_msg (fn () => "METIS COMPLETED...clauses actually used:") 

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

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

32956  763 
in 
36383  764 
if not (null cls) andalso not (common_thm used cls) then 
765 
warning "Metis: The assumptions are inconsistent." 

766 
else 

767 
(); 

768 
if not (null unused) then 

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

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

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

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

772 
(); 
32956  773 
case result of 
774 
(_,ith)::_ => 

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

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

777 
 _ => (trace_msg (fn () => "Metis: No result"); 
32956  778 
[]) 
779 
end 

780 
 Metis.Resolution.Satisfiable _ => 

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

782 
[]) 

783 
end; 

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

784 

32956  785 
fun metis_general_tac mode ctxt ths i st0 = 
786 
let val _ = trace_msg (fn () => 

787 
"Metis called with theorems " ^ cat_lines (map (Display.string_of_thm ctxt) ths)) 

788 
in 

35865  789 
if exists_type type_has_topsort (prop_of st0) 
35568
8fbbfc39508f
renamed type_has_empty_sort to type_has_topsort  {} is the full universal sort;
wenzelm
parents:
34087
diff
changeset

790 
then raise METIS "Metis: Proof state contains the universal sort {}" 
8fbbfc39508f
renamed type_has_empty_sort to type_has_topsort  {} is the full universal sort;
wenzelm
parents:
34087
diff
changeset

791 
else 
36401
31252c4d4923
adapt code to reflect new signature of "neg_clausify"
blanchet
parents:
36383
diff
changeset

792 
(Meson.MESON (maps neg_clausify) 
35568
8fbbfc39508f
renamed type_has_empty_sort to type_has_topsort  {} is the full universal sort;
wenzelm
parents:
34087
diff
changeset

793 
(fn cls => resolve_tac (FOL_SOLVE mode ctxt cls ths) 1) ctxt i 
35865  794 
THEN Meson_Tactic.expand_defs_tac st0) st0 
32956  795 
end 
796 
handle METIS s => (warning ("Metis: " ^ s); Seq.empty); 

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

797 

32956  798 
val metis_tac = metis_general_tac HO; 
799 
val metisF_tac = metis_general_tac FO; 

800 
val metisFT_tac = metis_general_tac FT; 

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

801 

32956  802 
fun method name mode comment = Method.setup name (Attrib.thms >> (fn ths => fn ctxt => 
803 
SIMPLE_METHOD' (CHANGED_PROP o metis_general_tac mode ctxt ths))) comment; 

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

804 

32956  805 
val setup = 
806 
type_lits_setup #> 

35865  807 
method @{binding metis} HO "METIS for FOL and HOL problems" #> 
32956  808 
method @{binding metisF} FO "METIS for FOL problems" #> 
35568
8fbbfc39508f
renamed type_has_empty_sort to type_has_topsort  {} is the full universal sort;
wenzelm
parents:
34087
diff
changeset

809 
method @{binding metisFT} FT "METIS with fullytyped translation" #> 
32956  810 
Method.setup @{binding finish_clausify} 
35865  811 
(Scan.succeed (K (SIMPLE_METHOD (Meson_Tactic.expand_defs_tac refl)))) 
32956  812 
"cleanup after conversion to clauses"; 
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; 