src/Pure/drule.ML
changeset 31945 d5f186aa0bed
parent 31904 a86896359ca4
child 31977 e03059ae2d82
equal deleted inserted replaced
31944:c8a35979a5bc 31945:d5f186aa0bed
   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]);