660 in |
660 in |
661 `(conj_dests nn) thm |
661 `(conj_dests nn) thm |
662 end; |
662 end; |
663 |
663 |
664 val induct_cases = quasi_unambiguous_case_names (maps (map name_of_ctr) ctrss); |
664 val induct_cases = quasi_unambiguous_case_names (maps (map name_of_ctr) ctrss); |
665 |
665 val induct_case_names_attr = Attrib.internal (K (Rule_Cases.case_names induct_cases)); |
666 val (fold_thmss, rec_thmss) = |
666 |
|
667 val xctrss = map2 (map2 (curry Term.list_comb)) ctrss xsss; |
|
668 |
|
669 fun mk_iter_thmss x_Tssss fss iters iter_defs ctor_iter_thms = |
667 let |
670 let |
668 val xctrss = map2 (map2 (curry Term.list_comb)) ctrss xsss; |
671 val fiters = map (lists_bmoc fss) iters; |
669 val gfolds = map (lists_bmoc gss) folds; |
|
670 val hrecs = map (lists_bmoc hss) recs; |
|
671 |
672 |
672 fun mk_goal fss fiter xctr f xs fxs = |
673 fun mk_goal fss fiter xctr f xs fxs = |
673 fold_rev (fold_rev Logic.all) (xs :: fss) |
674 fold_rev (fold_rev Logic.all) (xs :: fss) |
674 (mk_Trueprop_eq (fiter $ xctr, Term.list_comb (f, fxs))); |
675 (mk_Trueprop_eq (fiter $ xctr, Term.list_comb (f, fxs))); |
675 |
676 |
677 if try (fst o HOLogic.dest_prodT) U = SOME T then |
678 if try (fst o HOLogic.dest_prodT) U = SOME T then |
678 Term.lambda u (HOLogic.mk_prod (u, f $ u)) |
679 Term.lambda u (HOLogic.mk_prod (u, f $ u)) |
679 else |
680 else |
680 f; |
681 f; |
681 |
682 |
682 fun unzip_iters fiters (x as Free (_, T)) = |
683 fun unzip_iters (x as Free (_, T)) = |
683 map (fn U => if U = T then x else |
684 map (fn U => if U = T then x else |
684 build_map lthy (indexify (perhaps (try (snd o HOLogic.dest_prodT)) o snd) Cs |
685 build_map lthy (indexify (perhaps (try (snd o HOLogic.dest_prodT)) o snd) Cs |
685 (fn kk => fn TU => nth fiters kk |> maybe_tick TU (nth us kk))) (T, U) $ x); |
686 (fn kk => fn TU => maybe_tick TU (nth us kk) (nth fiters kk))) (T, U) $ x); |
686 |
687 |
687 val gxsss = map2 (map2 (flat_rec oo map2 (unzip_iters gfolds))) xsss y_Tssss; |
688 val fxsss = map2 (map2 (flat_rec oo map2 unzip_iters)) xsss x_Tssss; |
688 val hxsss = map2 (map2 (flat_rec oo map2 (unzip_iters hrecs))) xsss z_Tssss; |
689 |
689 |
690 val goalss = map5 (map4 o mk_goal gss) fiters xctrss fss xsss fxsss; |
690 val fold_goalss = map5 (map4 o mk_goal gss) gfolds xctrss gss xsss gxsss; |
691 |
691 val rec_goalss = map5 (map4 o mk_goal hss) hrecs xctrss hss xsss hxsss; |
692 val tacss = |
692 |
693 map2 (map o mk_iter_tac pre_map_defs (nested_map_ids'' @ nesting_map_ids'') iter_defs) |
693 val fold_tacss = |
694 ctor_iter_thms ctr_defss; |
694 map2 (map o mk_iter_tac pre_map_defs nesting_map_ids'' fold_defs) |
|
695 ctor_fold_thms ctr_defss; |
|
696 val rec_tacss = |
|
697 map2 (map o mk_iter_tac pre_map_defs (nested_map_ids'' @ nesting_map_ids'') rec_defs) |
|
698 ctor_rec_thms ctr_defss; |
|
699 |
695 |
700 fun prove goal tac = |
696 fun prove goal tac = |
701 Goal.prove_sorry lthy [] [] goal (tac o #context) |
697 Goal.prove_sorry lthy [] [] goal (tac o #context) |
702 |> Thm.close_derivation; |
698 |> Thm.close_derivation; |
703 in |
699 in |
704 (map2 (map2 prove) fold_goalss fold_tacss, map2 (map2 prove) rec_goalss rec_tacss) |
700 map2 (map2 prove) goalss tacss |
705 end; |
701 end; |
706 |
702 |
707 val induct_case_names_attr = Attrib.internal (K (Rule_Cases.case_names induct_cases)); |
703 val fold_thmss = mk_iter_thmss y_Tssss gss folds fold_defs ctor_fold_thms; |
|
704 val rec_thmss = mk_iter_thmss z_Tssss hss recs rec_defs ctor_rec_thms; |
708 in |
705 in |
709 ((induct_thm, induct_thms, [induct_case_names_attr]), |
706 ((induct_thm, induct_thms, [induct_case_names_attr]), |
710 (fold_thmss, code_simp_attrs), (rec_thmss, code_simp_attrs)) |
707 (fold_thmss, code_simp_attrs), (rec_thmss, code_simp_attrs)) |
711 end; |
708 end; |
712 |
709 |