1718 val fold_sets = fold_thms lthy (maps (fn bnf => |
1718 val fold_sets = fold_thms lthy (maps (fn bnf => |
1719 map (fn thm => thm RS @{thm meta_eq_to_obj_eq}) (set_defs_of_bnf bnf)) Ibnfs); |
1719 map (fn thm => thm RS @{thm meta_eq_to_obj_eq}) (set_defs_of_bnf bnf)) Ibnfs); |
1720 |
1720 |
1721 val timer = time (timer "registered new datatypes as BNFs"); |
1721 val timer = time (timer "registered new datatypes as BNFs"); |
1722 |
1722 |
1723 val rels = map2 (fn Ds => mk_rel_of_bnf Ds (passiveAs @ Ts) (passiveBs @ Ts')) Dss bnfs; |
1723 val srels = map2 (fn Ds => mk_srel_of_bnf Ds (passiveAs @ Ts) (passiveBs @ Ts')) Dss bnfs; |
1724 val Irels = map (mk_rel_of_bnf deads passiveAs passiveBs) Ibnfs; |
1724 val Isrels = map (mk_srel_of_bnf deads passiveAs passiveBs) Ibnfs; |
1725 val preds = map2 (fn Ds => mk_pred_of_bnf Ds (passiveAs @ Ts) (passiveBs @ Ts')) Dss bnfs; |
1725 val preds = map2 (fn Ds => mk_pred_of_bnf Ds (passiveAs @ Ts) (passiveBs @ Ts')) Dss bnfs; |
1726 val Ipreds = map (mk_pred_of_bnf deads passiveAs passiveBs) Ibnfs; |
1726 val Ipreds = map (mk_pred_of_bnf deads passiveAs passiveBs) Ibnfs; |
1727 |
1727 |
1728 val IrelRs = map (fn Irel => Term.list_comb (Irel, IRs)) Irels; |
1728 val IrelRs = map (fn Isrel => Term.list_comb (Isrel, IRs)) Isrels; |
1729 val relRs = map (fn rel => Term.list_comb (rel, IRs @ IrelRs)) rels; |
1729 val relRs = map (fn srel => Term.list_comb (srel, IRs @ IrelRs)) srels; |
1730 val Ipredphis = map (fn Irel => Term.list_comb (Irel, Iphis)) Ipreds; |
1730 val Ipredphis = map (fn Isrel => Term.list_comb (Isrel, Iphis)) Ipreds; |
1731 val predphis = map (fn rel => Term.list_comb (rel, Iphis @ Ipredphis)) preds; |
1731 val predphis = map (fn srel => Term.list_comb (srel, Iphis @ Ipredphis)) preds; |
1732 |
1732 |
1733 val in_rels = map in_rel_of_bnf bnfs; |
1733 val in_srels = map in_srel_of_bnf bnfs; |
1734 val in_Irels = map in_rel_of_bnf Ibnfs; |
1734 val in_Isrels = map in_srel_of_bnf Ibnfs; |
1735 val rel_defs = map rel_def_of_bnf bnfs; |
1735 val srel_defs = map srel_def_of_bnf bnfs; |
1736 val Irel_defs = map rel_def_of_bnf Ibnfs; |
1736 val Isrel_defs = map srel_def_of_bnf Ibnfs; |
1737 val Ipred_defs = map pred_def_of_bnf Ibnfs; |
1737 val Ipred_defs = map pred_def_of_bnf Ibnfs; |
1738 |
1738 |
1739 val set_incl_thmss = map (map (fold_sets o hd)) Fset_set_thmsss; |
1739 val set_incl_thmss = map (map (fold_sets o hd)) Fset_set_thmsss; |
1740 val set_set_incl_thmsss = map (transpose o map (map fold_sets o tl)) Fset_set_thmsss; |
1740 val set_set_incl_thmsss = map (transpose o map (map fold_sets o tl)) Fset_set_thmsss; |
1741 val folded_map_simp_thms = map fold_maps map_simp_thms; |
1741 val folded_map_simp_thms = map fold_maps map_simp_thms; |
1742 val folded_set_simp_thmss = map (map fold_sets) set_simp_thmss; |
1742 val folded_set_simp_thmss = map (map fold_sets) set_simp_thmss; |
1743 val folded_set_simp_thmss' = transpose folded_set_simp_thmss; |
1743 val folded_set_simp_thmss' = transpose folded_set_simp_thmss; |
1744 |
1744 |
1745 val Irel_simp_thms = |
1745 val Isrel_simp_thms = |
1746 let |
1746 let |
1747 fun mk_goal xF yF ctor ctor' IrelR relR = fold_rev Logic.all (xF :: yF :: IRs) |
1747 fun mk_goal xF yF ctor ctor' IrelR relR = fold_rev Logic.all (xF :: yF :: IRs) |
1748 (mk_Trueprop_eq (HOLogic.mk_mem (HOLogic.mk_prod (ctor $ xF, ctor' $ yF), IrelR), |
1748 (mk_Trueprop_eq (HOLogic.mk_mem (HOLogic.mk_prod (ctor $ xF, ctor' $ yF), IrelR), |
1749 HOLogic.mk_mem (HOLogic.mk_prod (xF, yF), relR))); |
1749 HOLogic.mk_mem (HOLogic.mk_prod (xF, yF), relR))); |
1750 val goals = map6 mk_goal xFs yFs ctors ctor's IrelRs relRs; |
1750 val goals = map6 mk_goal xFs yFs ctors ctor's IrelRs relRs; |
1751 in |
1751 in |
1752 map12 (fn i => fn goal => fn in_rel => fn map_comp => fn map_cong => |
1752 map12 (fn i => fn goal => fn in_srel => fn map_comp => fn map_cong => |
1753 fn map_simp => fn set_simps => fn ctor_inject => fn ctor_dtor => |
1753 fn map_simp => fn set_simps => fn ctor_inject => fn ctor_dtor => |
1754 fn set_naturals => fn set_incls => fn set_set_inclss => |
1754 fn set_naturals => fn set_incls => fn set_set_inclss => |
1755 Skip_Proof.prove lthy [] [] goal |
1755 Skip_Proof.prove lthy [] [] goal |
1756 (K (mk_rel_simp_tac in_Irels i in_rel map_comp map_cong map_simp set_simps |
1756 (K (mk_srel_simp_tac in_Isrels i in_srel map_comp map_cong map_simp set_simps |
1757 ctor_inject ctor_dtor set_naturals set_incls set_set_inclss)) |
1757 ctor_inject ctor_dtor set_naturals set_incls set_set_inclss)) |
1758 |> Thm.close_derivation) |
1758 |> Thm.close_derivation) |
1759 ks goals in_rels map_comp's map_congs folded_map_simp_thms folded_set_simp_thmss' |
1759 ks goals in_srels map_comp's map_congs folded_map_simp_thms folded_set_simp_thmss' |
1760 ctor_inject_thms ctor_dtor_thms set_natural'ss set_incl_thmss set_set_incl_thmsss |
1760 ctor_inject_thms ctor_dtor_thms set_natural'ss set_incl_thmss set_set_incl_thmsss |
1761 end; |
1761 end; |
1762 |
1762 |
1763 val Ipred_simp_thms = |
1763 val Ipred_simp_thms = |
1764 let |
1764 let |
1765 fun mk_goal xF yF ctor ctor' Ipredphi predphi = fold_rev Logic.all (xF :: yF :: Iphis) |
1765 fun mk_goal xF yF ctor ctor' Ipredphi predphi = fold_rev Logic.all (xF :: yF :: Iphis) |
1766 (mk_Trueprop_eq (Ipredphi $ (ctor $ xF) $ (ctor' $ yF), predphi $ xF $ yF)); |
1766 (mk_Trueprop_eq (Ipredphi $ (ctor $ xF) $ (ctor' $ yF), predphi $ xF $ yF)); |
1767 val goals = map6 mk_goal xFs yFs ctors ctor's Ipredphis predphis; |
1767 val goals = map6 mk_goal xFs yFs ctors ctor's Ipredphis predphis; |
1768 in |
1768 in |
1769 map3 (fn goal => fn rel_def => fn Irel_simp => |
1769 map3 (fn goal => fn srel_def => fn Isrel_simp => |
1770 Skip_Proof.prove lthy [] [] goal |
1770 Skip_Proof.prove lthy [] [] goal |
1771 (mk_pred_simp_tac rel_def Ipred_defs Irel_defs Irel_simp) |
1771 (mk_pred_simp_tac srel_def Ipred_defs Isrel_defs Isrel_simp) |
1772 |> Thm.close_derivation) |
1772 |> Thm.close_derivation) |
1773 goals rel_defs Irel_simp_thms |
1773 goals srel_defs Isrel_simp_thms |
1774 end; |
1774 end; |
1775 |
1775 |
1776 val timer = time (timer "additional properties"); |
1776 val timer = time (timer "additional properties"); |
1777 |
1777 |
1778 val ls' = if m = 1 then [0] else ls |
1778 val ls' = if m = 1 then [0] else ls |
1784 |
1784 |
1785 val Ibnf_notes = |
1785 val Ibnf_notes = |
1786 [(map_simpsN, map single folded_map_simp_thms), |
1786 [(map_simpsN, map single folded_map_simp_thms), |
1787 (set_inclN, set_incl_thmss), |
1787 (set_inclN, set_incl_thmss), |
1788 (set_set_inclN, map flat set_set_incl_thmsss), |
1788 (set_set_inclN, map flat set_set_incl_thmsss), |
1789 (rel_simpN, map single Irel_simp_thms), |
1789 (srel_simpN, map single Isrel_simp_thms), |
1790 (pred_simpN, map single Ipred_simp_thms)] @ |
1790 (pred_simpN, map single Ipred_simp_thms)] @ |
1791 map2 (fn i => fn thms => (mk_set_simpsN i, map single thms)) ls' folded_set_simp_thmss |
1791 map2 (fn i => fn thms => (mk_set_simpsN i, map single thms)) ls' folded_set_simp_thmss |
1792 |> maps (fn (thmN, thmss) => |
1792 |> maps (fn (thmN, thmss) => |
1793 map2 (fn b => fn thms => |
1793 map2 (fn b => fn thms => |
1794 ((Binding.qualify true (Binding.name_of b) (Binding.name thmN), []), [(thms, [])])) |
1794 ((Binding.qualify true (Binding.name_of b) (Binding.name thmN), []), [(thms, [])])) |