src/HOL/Codatatype/Tools/bnf_lfp.ML
changeset 49506 aeb0cc8889f2
parent 49504 df9b897fb254
child 49507 8826d5a4332b
equal deleted inserted replaced
49505:a944eefb67e6 49506:aeb0cc8889f2
  1669         val set_bd_tacss = map (map (fn thm => K (rtac thm 1))) (transpose set_bd_thmss);
  1669         val set_bd_tacss = map (map (fn thm => K (rtac thm 1))) (transpose set_bd_thmss);
  1670         val in_bd_tacs = map2 (K oo mk_in_bd_tac sum_Card_order suc_bd_Cnotzero)
  1670         val in_bd_tacs = map2 (K oo mk_in_bd_tac sum_Card_order suc_bd_Cnotzero)
  1671           in_incl_min_alg_thms card_of_min_alg_thms;
  1671           in_incl_min_alg_thms card_of_min_alg_thms;
  1672         val map_wpull_tacs = map (K o mk_wpull_tac) map_wpull_thms;
  1672         val map_wpull_tacs = map (K o mk_wpull_tac) map_wpull_thms;
  1673 
  1673 
  1674         val rel_O_Gr_tacs = replicate n (simple_rel_O_Gr_tac o #context);
  1674         val srel_O_Gr_tacs = replicate n (simple_srel_O_Gr_tac o #context);
  1675 
  1675 
  1676         val tacss = map10 zip_axioms map_id_tacs map_comp_tacs map_cong_tacs set_nat_tacss
  1676         val tacss = map10 zip_axioms map_id_tacs map_comp_tacs map_cong_tacs set_nat_tacss
  1677           bd_co_tacs bd_cinf_tacs set_bd_tacss in_bd_tacs map_wpull_tacs rel_O_Gr_tacs;
  1677           bd_co_tacs bd_cinf_tacs set_bd_tacss in_bd_tacs map_wpull_tacs srel_O_Gr_tacs;
  1678 
  1678 
  1679         val ctor_witss =
  1679         val ctor_witss =
  1680           let
  1680           let
  1681             val witss = map2 (fn Ds => fn bnf => mk_wits_of_bnf
  1681             val witss = map2 (fn Ds => fn bnf => mk_wits_of_bnf
  1682               (replicate (nwits_of_bnf bnf) Ds)
  1682               (replicate (nwits_of_bnf bnf) Ds)
  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, [])]))