593 in |
593 in |
594 instantiate ([], [(cterm t, cterm newt)]) rl |
594 instantiate ([], [(cterm t, cterm newt)]) rl |
595 end |
595 end |
596 | split_rule_var' (t, rl) = rl; |
596 | split_rule_var' (t, rl) = rl; |
597 |
597 |
|
598 (*** Complete splitting of partially splitted rules ***) |
|
599 |
|
600 fun ap_split' (T::Ts) U u = Abs ("v", T, ap_split' Ts U |
|
601 (ap_split T (flat (map HOLogic.prodT_factors Ts) ---> U) |
|
602 (incr_boundvars 1 u) $ Bound 0)) |
|
603 | ap_split' _ _ u = u; |
|
604 |
|
605 fun complete_split_rule_var ((t as Var (v, T), ts), (rl, vs)) = |
|
606 let |
|
607 val cterm = Thm.cterm_of (#sign (rep_thm rl)) |
|
608 val (Us', U') = strip_type T; |
|
609 val Us = take (length ts, Us'); |
|
610 val U = drop (length ts, Us') ---> U'; |
|
611 val T' = flat (map HOLogic.prodT_factors Us) ---> U; |
|
612 fun mk_tuple (xs, v as Var ((a, _), T)) = |
|
613 let |
|
614 val Ts = HOLogic.prodT_factors T; |
|
615 val ys = variantlist (replicate (length Ts) a, xs); |
|
616 in (xs @ ys, (cterm v, cterm (HOLogic.mk_tuple T |
|
617 (map (Var o apfst (rpair 0)) (ys ~~ Ts))))) |
|
618 end; |
|
619 val newt = ap_split' Us U (Var (v, T')); |
|
620 val cterm = Thm.cterm_of (#sign (rep_thm rl)); |
|
621 val (vs', insts) = foldl_map mk_tuple (vs, ts); |
|
622 in |
|
623 (instantiate ([], [(cterm t, cterm newt)] @ insts) rl, vs') |
|
624 end |
|
625 | complete_split_rule_var (_, x) = x; |
|
626 |
|
627 fun collect_vars (vs, Abs (_, _, t)) = collect_vars (vs, t) |
|
628 | collect_vars (vs, t) = (case strip_comb t of |
|
629 (v as Var _, ts) => |
|
630 (case filter is_Var ts of [] => vs | ts' => (v, ts')::vs) |
|
631 | (t, ts) => foldl collect_vars (vs, ts)); |
|
632 |
598 in |
633 in |
599 |
634 |
600 val split_rule_var = standard o remove_split o split_rule_var'; |
635 val split_rule_var = standard o remove_split o split_rule_var'; |
601 |
636 |
602 (*Curries ALL function variables occurring in a rule's conclusion*) |
637 (*Curries ALL function variables occurring in a rule's conclusion*) |
603 fun split_rule rl = standard (remove_split (foldr split_rule_var' (term_vars (concl_of rl), rl))); |
638 fun split_rule rl = standard (remove_split (foldr split_rule_var' (term_vars (concl_of rl), rl))); |
604 |
639 |
|
640 fun complete_split_rule rl = |
|
641 standard (remove_split (fst (foldr complete_split_rule_var |
|
642 (collect_vars ([], concl_of rl), |
|
643 (rl, map (fst o fst o dest_Var) (term_vars (#prop (rep_thm rl)))))))); |
|
644 |
605 end; |
645 end; |