src/HOL/Tools/res_clause.ML
changeset 15615 d72b1867d09d
parent 15610 f855fd163b62
child 15774 9df37a0e935d
equal deleted inserted replaced
15614:b098158a3f39 15615:d72b1867d09d
   237 	(make_fixed_var x,type_of T)
   237 	(make_fixed_var x,type_of T)
   238     end
   238     end
   239   | pred_name_type (Var(_,_))   = raise CLAUSE("Predicate Not First Order")
   239   | pred_name_type (Var(_,_))   = raise CLAUSE("Predicate Not First Order")
   240   | pred_name_type _          = raise CLAUSE("Predicate input unexpected");
   240   | pred_name_type _          = raise CLAUSE("Predicate input unexpected");
   241 
   241 
       
   242 
       
   243 (* For type equality *)
       
   244 (* here "arg_typ" is the type of "="'s argument's type, not the type of the equality *)
       
   245 (* Find type of equality arg *)
       
   246 fun eq_arg_type (Type("fun",[T,_])) = 
       
   247     let val (folT,_) = type_of T;
       
   248     in
       
   249 	folT
       
   250     end;
       
   251 
       
   252 
       
   253 
   242 fun fun_name_type (Const(c,T)) = (lookup_const c,type_of T)
   254 fun fun_name_type (Const(c,T)) = (lookup_const c,type_of T)
   243   | fun_name_type (Free(x,T)) = (make_fixed_var x,type_of T)
   255   | fun_name_type (Free(x,T)) = (make_fixed_var x,type_of T)
   244   | fun_name_type _ = raise CLAUSE("Function Not First Order");
   256   | fun_name_type _ = raise CLAUSE("Function Not First Order");
   245     
   257     
   246 
   258 
       
   259 
   247 fun term_of (Var(ind_nm,T)) = 
   260 fun term_of (Var(ind_nm,T)) = 
   248     let val (folType,ts) = type_of T
   261     let val (folType,ts) = type_of T
   249     in
   262     in
   250 	(UVar(make_schematic_var(string_of_indexname ind_nm),folType),ts)
   263 	(UVar(make_schematic_var(string_of_indexname ind_nm),folType),ts)
   251     end
   264     end
   255     in
   268     in
   256 	if is_meta then (UVar(make_schematic_var x,folType),ts)
   269 	if is_meta then (UVar(make_schematic_var x,folType),ts)
   257 	else
   270 	else
   258             (Fun(make_fixed_var x,folType,[]),ts)
   271             (Fun(make_fixed_var x,folType,[]),ts)
   259     end
   272     end
   260   | term_of (Const(c,T)) = 
   273   | term_of (Const(c,T)) =  (* impossible to be equality *)
   261     let val (folType,ts) = type_of T
   274     let val (folType,ts) = type_of T
   262      in
   275      in
   263         (Fun(lookup_const c,folType,[]),ts)
   276         (Fun(lookup_const c,folType,[]),ts)
   264     end    
   277     end    
   265   | term_of (app as (t $ a)) = 
   278   | term_of (app as (t $ a)) = 
   269                  val (args',ts2) = ResLib.unzip (map term_of args)
   282                  val (args',ts2) = ResLib.unzip (map term_of args)
   270                  val ts3 = ResLib.flat_noDup (ts1::ts2)
   283                  val ts3 = ResLib.flat_noDup (ts1::ts2)
   271             in
   284             in
   272 		(Fun(funName,funType,args'),ts3)
   285 		(Fun(funName,funType,args'),ts3)
   273             end
   286             end
   274     in
   287 	fun term_of_eq ((Const ("op =", typ)),args) =
   275         case f of Const(_,_) => term_of_aux ()
   288 	    let val arg_typ = eq_arg_type typ
       
   289 		val (args',ts) = ResLib.unzip (map term_of args)
       
   290 		val equal_name = lookup_const ("op =")
       
   291 	    in
       
   292 		(Fun(equal_name,arg_typ,args'),ResLib.flat_noDup ts)
       
   293 	    end
       
   294     in
       
   295         case f of Const ("op =", typ) => term_of_eq (f,args)
       
   296 	        | Const(_,_) => term_of_aux ()
   276                 | Free(s,_)  => if (checkMeta s) then (raise CLAUSE("Function Not First Order")) else term_of_aux ()
   297                 | Free(s,_)  => if (checkMeta s) then (raise CLAUSE("Function Not First Order")) else term_of_aux ()
   277                 | _          => raise CLAUSE("Function Not First Order")
   298                 | _          => raise CLAUSE("Function Not First Order")
   278     end
   299     end
   279   | term_of _ = raise CLAUSE("Function Not First Order"); 
   300   | term_of _ = raise CLAUSE("Function Not First Order"); 
   280 
   301 
   281 
   302 
   282 
   303 
   283 
       
   284 (* For type equality *)
       
   285 (* here "arg_typ" is the type of "="'s argument's type, not the type of the equality *)
       
   286 (* Find type of equality arg *)
       
   287 local
       
   288 
       
   289 fun eq_arg_type (Type("fun",[T,_])) = 
       
   290     let val (folT,_) = type_of T;
       
   291     in
       
   292 	folT
       
   293     end;
       
   294 
       
   295 in
       
   296 
   304 
   297 fun pred_of_eq ((Const ("op =", typ)),args) =
   305 fun pred_of_eq ((Const ("op =", typ)),args) =
   298     let val arg_typ = eq_arg_type typ 
   306     let val arg_typ = eq_arg_type typ 
   299 	val (args',ts) = ResLib.unzip (map term_of args)
   307 	val (args',ts) = ResLib.unzip (map term_of args)
   300 	val equal_name = lookup_const "op ="
   308 	val equal_name = lookup_const "op ="
   301     in
   309     in
   302 	(Predicate(equal_name,arg_typ,args'),ResLib.flat_noDup ts)
   310 	(Predicate(equal_name,arg_typ,args'),ResLib.flat_noDup ts)
   303     end;
   311     end;
   304 
   312 
   305 end;
       
   306 
   313 
   307 (* changed for non-equality predicate *)
   314 (* changed for non-equality predicate *)
   308 (* The input "pred" cannot be an equality *)
   315 (* The input "pred" cannot be an equality *)
   309 fun pred_of_nonEq (pred,args) = 
   316 fun pred_of_nonEq (pred,args) = 
   310     let val (predName,(predType,ts1)) = pred_name_type pred
   317     let val (predName,(predType,ts1)) = pred_name_type pred
   551 
   558 
   552 fun string_of_kind (Clause cls) = name_of_kind (#kind cls);
   559 fun string_of_kind (Clause cls) = name_of_kind (#kind cls);
   553 
   560 
   554 fun string_of_axiomName (Clause cls) = #axiom_name cls;
   561 fun string_of_axiomName (Clause cls) = #axiom_name cls;
   555 
   562 
   556 fun string_of_term (UVar(x,_)) = x
       
   557   | string_of_term (Fun (name,typ,[])) = name
       
   558   | string_of_term (Fun (name,typ,terms)) = 
       
   559     let val terms' = map string_of_term terms
       
   560     in
       
   561         if (!keep_types) then name ^ (ResLib.list_to_string (typ :: terms'))
       
   562         else name ^ (ResLib.list_to_string terms')
       
   563     end;
       
   564 
       
   565 
       
   566 
       
   567 (****!!!! Changed for typed equality !!!!****)
   563 (****!!!! Changed for typed equality !!!!****)
   568 fun wrap_eq_type typ t = eq_typ_wrapper ^"(" ^ t ^ "," ^ typ ^ ")";
   564 fun wrap_eq_type typ t = eq_typ_wrapper ^"(" ^ t ^ "," ^ typ ^ ")";
   569 
   565 
   570 
   566 
   571 (****!!!! Changed for typed equality !!!!****)
   567 (****!!!! Changed for typed equality !!!!****)
   575     in
   571     in
   576 	if ((!keep_types) andalso (!special_equal)) then 
   572 	if ((!keep_types) andalso (!special_equal)) then 
   577 	    "equal(" ^ (wrap_eq_type typ tstr1) ^ "," ^ (wrap_eq_type typ tstr2) ^ ")"
   573 	    "equal(" ^ (wrap_eq_type typ tstr1) ^ "," ^ (wrap_eq_type typ tstr2) ^ ")"
   578 	else
   574 	else
   579 	    "equal(" ^ tstr1 ^ "," ^ tstr2 ^ ")"
   575 	    "equal(" ^ tstr1 ^ "," ^ tstr2 ^ ")"
       
   576     end
       
   577 
       
   578 
       
   579 and
       
   580     string_of_term (UVar(x,_)) = x
       
   581   | string_of_term (Fun("equal",typ,terms)) = string_of_equality(typ,terms)
       
   582   | string_of_term (Fun (name,typ,[])) = name
       
   583   | string_of_term (Fun (name,typ,terms)) = 
       
   584     let val terms' = map string_of_term terms
       
   585     in
       
   586         if (!keep_types) then name ^ (ResLib.list_to_string (typ :: terms'))
       
   587         else name ^ (ResLib.list_to_string terms')
   580     end;
   588     end;
   581 
   589 
   582 
   590 
   583 
   591 
   584 (* Changed for typed equality *)
   592 (* Changed for typed equality *)