src/Pure/logic.ML
changeset 4679 24917efb31b5
parent 4667 6328d427a339
child 4693 2e47ea2c6109
equal deleted inserted replaced
4678:78715f589655 4679:24917efb31b5
    24   val is_equals         : term -> bool
    24   val is_equals         : term -> bool
    25   val lift_fns		: term * int -> (term -> term) * (term -> term)
    25   val lift_fns		: term * int -> (term -> term) * (term -> term)
    26   val list_flexpairs	: (term*term)list * term -> term
    26   val list_flexpairs	: (term*term)list * term -> term
    27   val list_implies	: term list * term -> term
    27   val list_implies	: term list * term -> term
    28   val list_rename_params: string list * term -> term
    28   val list_rename_params: string list * term -> term
    29   val rewrite_rule_extra_vars: term list -> term -> term -> string option
       
    30   val rewrite_rule_ok   : Sign.sg -> term list -> term -> term
       
    31                           -> string option * bool
       
    32   val mk_equals		: term * term -> term
    29   val mk_equals		: term * term -> term
    33   val mk_flexpair	: term * term -> term
    30   val mk_flexpair	: term * term -> term
    34   val mk_implies	: term * term -> term
    31   val mk_implies	: term * term -> term
    35   val mk_inclass	: typ * class -> term
    32   val mk_inclass	: typ * class -> term
    36   val mk_type		: typ -> term
    33   val mk_type		: typ -> term
   302   | unvarify (Var(ixn,T))    = Var(ixn, Type.unvarifyT T)  (*non-0 index!*)
   299   | unvarify (Var(ixn,T))    = Var(ixn, Type.unvarifyT T)  (*non-0 index!*)
   303   | unvarify (Abs (a,T,body)) = Abs (a, Type.unvarifyT T, unvarify body)
   300   | unvarify (Abs (a,T,body)) = Abs (a, Type.unvarifyT T, unvarify body)
   304   | unvarify (f$t) = unvarify f $ unvarify t
   301   | unvarify (f$t) = unvarify f $ unvarify t
   305   | unvarify t = t;
   302   | unvarify t = t;
   306 
   303 
   307 
       
   308 
       
   309 (** Test wellformedness of rewrite rules **)
       
   310 
       
   311 fun vperm (Var _, Var _) = true
       
   312   | vperm (Abs (_, _, s), Abs (_, _, t)) = vperm (s, t)
       
   313   | vperm (t1 $ t2, u1 $ u2) = vperm (t1, u1) andalso vperm (t2, u2)
       
   314   | vperm (t, u) = (t = u);
       
   315 
       
   316 fun var_perm (t, u) =
       
   317   vperm (t, u) andalso eq_set_term (term_vars t, term_vars u);
       
   318 
       
   319 (*simple test for looping rewrite*)
       
   320 fun looptest sign prems lhs rhs =
       
   321    is_Var (head_of lhs)
       
   322   orelse
       
   323    (exists (apl (lhs, op occs)) (rhs :: prems))
       
   324   orelse
       
   325    (null prems andalso
       
   326     Pattern.matches (#tsig (Sign.rep_sg sign)) (lhs, rhs))
       
   327 (*  orelse
       
   328    (case lhs of
       
   329       (f as Free _) $ (Var _) => exists (fn p => f occs p) prems orelse
       
   330                                  (null prems andalso f occs rhs)
       
   331     | _ => false)*);
       
   332 (*the condition "null prems" in the last cases is necessary because
       
   333   conditional rewrites with extra variables in the conditions may terminate
       
   334   although the rhs is an instance of the lhs. Example:
       
   335   ?m < ?n ==> f(?n) == f(?m)*)
       
   336 (*FIXME: proper test: lhs does not match a subterm of a premise
       
   337                       and does not match a subterm of the rhs if null prems *)
       
   338 
       
   339 fun rewrite_rule_extra_vars prems elhs erhs =
       
   340   if not ((term_vars erhs) subset
       
   341           (union_term (term_vars elhs, List.concat(map term_vars prems))))
       
   342   then Some("extra Var(s) on rhs") else
       
   343   if not ((term_tvars erhs) subset
       
   344           (term_tvars elhs  union  List.concat(map term_tvars prems)))
       
   345   then Some("extra TVar(s) on rhs")
       
   346   else None;
       
   347 
       
   348 fun rewrite_rule_ok sign prems lhs rhs =
       
   349   let
       
   350     val elhs = Pattern.eta_contract lhs;
       
   351     val erhs = Pattern.eta_contract rhs;
       
   352     val perm = var_perm (elhs, erhs) andalso not (elhs aconv erhs)
       
   353                andalso not (is_Var elhs)
       
   354   in (case rewrite_rule_extra_vars prems elhs erhs of
       
   355         None => if not perm andalso looptest sign prems elhs erhs
       
   356                 then Some("loops")
       
   357                 else None
       
   358       | some => some
       
   359       ,perm)
       
   360   end;
       
   361 
       
   362 end;
   304 end;