371 in (Thm.instantiate ([],insts) fth, thaw) end |
371 in (Thm.instantiate ([],insts) fth, thaw) end |
372 end; |
372 end; |
373 |
373 |
374 (*Rotates a rule's premises to the left by k*) |
374 (*Rotates a rule's premises to the left by k*) |
375 fun rotate_prems 0 = I |
375 fun rotate_prems 0 = I |
376 | rotate_prems k = permute_prems 0 k; |
376 | rotate_prems k = Thm.permute_prems 0 k; |
377 |
377 |
378 fun with_subgoal i f = rotate_prems (i - 1) #> f #> rotate_prems (1 - i); |
378 fun with_subgoal i f = rotate_prems (i - 1) #> f #> rotate_prems (1 - i); |
379 |
379 |
380 (* permute prems, where the i-th position in the argument list (counting from 0) |
380 (*Permute prems, where the i-th position in the argument list (counting from 0) |
381 gives the position within the original thm to be transferred to position i. |
381 gives the position within the original thm to be transferred to position i. |
382 Any remaining trailing positions are left unchanged. *) |
382 Any remaining trailing positions are left unchanged.*) |
383 val rearrange_prems = let |
383 val rearrange_prems = |
384 fun rearr new [] thm = thm |
384 let |
385 | rearr new (p::ps) thm = rearr (new+1) |
385 fun rearr new [] thm = thm |
386 (map (fn q => if new<=q andalso q<p then q+1 else q) ps) |
386 | rearr new (p :: ps) thm = |
387 (permute_prems (new+1) (new-p) (permute_prems new (p-new) thm)) |
387 rearr (new + 1) |
|
388 (map (fn q => if new <= q andalso q < p then q + 1 else q) ps) |
|
389 (Thm.permute_prems (new + 1) (new - p) (Thm.permute_prems new (p - new) thm)) |
388 in rearr 0 end; |
390 in rearr 0 end; |
389 |
391 |
390 (*Resolution: exactly one resolvent must be produced.*) |
392 (*Resolution: exactly one resolvent must be produced.*) |
391 fun tha RSN (i,thb) = |
393 fun tha RSN (i,thb) = |
392 case Seq.chop 2 (biresolution false [(false,tha)] i thb) of |
394 case Seq.chop 2 (Thm.biresolution false [(false,tha)] i thb) of |
393 ([th],_) => th |
395 ([th],_) => th |
394 | ([],_) => raise THM("RSN: no unifiers", i, [tha,thb]) |
396 | ([],_) => raise THM("RSN: no unifiers", i, [tha,thb]) |
395 | _ => raise THM("RSN: multiple unifiers", i, [tha,thb]); |
397 | _ => raise THM("RSN: multiple unifiers", i, [tha,thb]); |
396 |
398 |
397 (*resolution: P==>Q, Q==>R gives P==>R. *) |
399 (*resolution: P==>Q, Q==>R gives P==>R. *) |
398 fun tha RS thb = tha RSN (1,thb); |
400 fun tha RS thb = tha RSN (1,thb); |
399 |
401 |
400 (*For joining lists of rules*) |
402 (*For joining lists of rules*) |
401 fun thas RLN (i,thbs) = |
403 fun thas RLN (i,thbs) = |
402 let val resolve = biresolution false (map (pair false) thas) i |
404 let val resolve = Thm.biresolution false (map (pair false) thas) i |
403 fun resb thb = Seq.list_of (resolve thb) handle THM _ => [] |
405 fun resb thb = Seq.list_of (resolve thb) handle THM _ => [] |
404 in maps resb thbs end; |
406 in maps resb thbs end; |
405 |
407 |
406 fun thas RL thbs = thas RLN (1,thbs); |
408 fun thas RL thbs = thas RLN (1,thbs); |
407 |
409 |
423 |
425 |
424 (*compose Q and [...,Qi,Q(i+1),...]==>R to [...,Q(i+1),...]==>R |
426 (*compose Q and [...,Qi,Q(i+1),...]==>R to [...,Q(i+1),...]==>R |
425 with no lifting or renaming! Q may contain ==> or meta-quants |
427 with no lifting or renaming! Q may contain ==> or meta-quants |
426 ALWAYS deletes premise i *) |
428 ALWAYS deletes premise i *) |
427 fun compose(tha,i,thb) = |
429 fun compose(tha,i,thb) = |
428 distinct Thm.eq_thm (Seq.list_of (bicompose false (false,tha,0) i thb)); |
430 distinct Thm.eq_thm (Seq.list_of (Thm.bicompose false (false,tha,0) i thb)); |
429 |
431 |
430 fun compose_single (tha,i,thb) = |
432 fun compose_single (tha,i,thb) = |
431 case compose (tha,i,thb) of |
433 case compose (tha,i,thb) of |
432 [th] => th |
434 [th] => th |
433 | _ => raise THM ("compose: unique result expected", i, [tha,thb]); |
435 | _ => raise THM ("compose: unique result expected", i, [tha,thb]); |