src/HOL/Tools/record.ML
changeset 74537 44e4f09b1cc4
parent 74383 107941e8fa01
child 74538 45c09620f726
equal deleted inserted replaced
74536:7d05d44ff9a9 74537:44e4f09b1cc4
  1600       in Logic.mk_equals (Logic.all s (P $ s), fold_rev Logic.all vars_more (P $ ext)) end;
  1600       in Logic.mk_equals (Logic.all s (P $ s), fold_rev Logic.all vars_more (P $ ext)) end;
  1601 
  1601 
  1602     val inject = timeit_msg ctxt "record extension inject proof:" (fn () =>
  1602     val inject = timeit_msg ctxt "record extension inject proof:" (fn () =>
  1603       simplify (put_simpset HOL_ss defs_ctxt)
  1603       simplify (put_simpset HOL_ss defs_ctxt)
  1604         (Goal.prove_sorry_global defs_thy [] [] inject_prop
  1604         (Goal.prove_sorry_global defs_thy [] [] inject_prop
  1605           (fn {context = ctxt, ...} =>
  1605           (fn {context = ctxt', ...} =>
  1606             simp_tac (put_simpset HOL_basic_ss ctxt addsimps [ext_def]) 1 THEN
  1606             simp_tac (put_simpset HOL_basic_ss ctxt' addsimps [ext_def]) 1 THEN
  1607             REPEAT_DETERM
  1607             REPEAT_DETERM
  1608               (resolve_tac ctxt @{thms refl_conj_eq} 1 ORELSE
  1608               (resolve_tac ctxt' @{thms refl_conj_eq} 1 ORELSE
  1609                 Iso_Tuple_Support.iso_tuple_intros_tac ctxt 1 ORELSE
  1609                 Iso_Tuple_Support.iso_tuple_intros_tac ctxt' 1 ORELSE
  1610                 resolve_tac ctxt [refl] 1))));
  1610                 resolve_tac ctxt' [refl] 1))));
  1611 
  1611 
  1612 
  1612 
  1613     (*We need a surjection property r = (| f = f r, g = g r ... |)
  1613     (*We need a surjection property r = (| f = f r, g = g r ... |)
  1614       to prove other theorems. We haven't given names to the accessors
  1614       to prove other theorems. We haven't given names to the accessors
  1615       f, g etc yet however, so we generate an ext structure with
  1615       f, g etc yet however, so we generate an ext structure with
  1632         surject
  1632         surject
  1633       end);
  1633       end);
  1634 
  1634 
  1635     val split_meta = timeit_msg ctxt "record extension split_meta proof:" (fn () =>
  1635     val split_meta = timeit_msg ctxt "record extension split_meta proof:" (fn () =>
  1636       Goal.prove_sorry_global defs_thy [] [] split_meta_prop
  1636       Goal.prove_sorry_global defs_thy [] [] split_meta_prop
  1637         (fn {context = ctxt, ...} =>
  1637         (fn {context = ctxt', ...} =>
  1638           EVERY1
  1638           EVERY1
  1639            [resolve_tac ctxt @{thms equal_intr_rule},
  1639            [resolve_tac ctxt' @{thms equal_intr_rule},
  1640             Goal.norm_hhf_tac ctxt,
  1640             Goal.norm_hhf_tac ctxt',
  1641             eresolve_tac ctxt @{thms meta_allE}, assume_tac ctxt,
  1641             eresolve_tac ctxt' @{thms meta_allE}, assume_tac ctxt',
  1642             resolve_tac ctxt [@{thm prop_subst} OF [surject]],
  1642             resolve_tac ctxt' [@{thm prop_subst} OF [surject]],
  1643             REPEAT o eresolve_tac ctxt @{thms meta_allE}, assume_tac ctxt]));
  1643             REPEAT o eresolve_tac ctxt' @{thms meta_allE}, assume_tac ctxt']));
  1644 
  1644 
  1645     val induct = timeit_msg ctxt "record extension induct proof:" (fn () =>
  1645     val induct = timeit_msg ctxt "record extension induct proof:" (fn () =>
  1646       let val (assm, concl) = induct_prop in
  1646       let val (assm, concl) = induct_prop in
  1647         Goal.prove_sorry_global defs_thy [] [assm] concl
  1647         Goal.prove_sorry_global defs_thy [] [assm] concl
  1648           (fn {context = ctxt, prems, ...} =>
  1648           (fn {context = ctxt', prems, ...} =>
  1649             cut_tac (split_meta RS Drule.equal_elim_rule2) 1 THEN
  1649             cut_tac (split_meta RS Drule.equal_elim_rule2) 1 THEN
  1650             resolve_tac ctxt prems 2 THEN
  1650             resolve_tac ctxt' prems 2 THEN
  1651             asm_simp_tac (put_simpset HOL_ss ctxt) 1)
  1651             asm_simp_tac (put_simpset HOL_ss ctxt') 1)
  1652       end);
  1652       end);
  1653 
  1653 
  1654     val ([(_, [induct']), (_, [inject']), (_, [surjective']), (_, [split_meta'])], thm_thy) =
  1654     val ([(_, [induct']), (_, [inject']), (_, [surjective']), (_, [split_meta'])], thm_thy) =
  1655       defs_thy
  1655       defs_thy
  1656       |> Global_Theory.note_thmss ""
  1656       |> Global_Theory.note_thmss ""
  2139 
  2139 
  2140     val parent_induct = Option.map #induct_scheme (try List.last parents);
  2140     val parent_induct = Option.map #induct_scheme (try List.last parents);
  2141 
  2141 
  2142     val induct_scheme = timeit_msg defs_ctxt "record induct_scheme proof:" (fn () =>
  2142     val induct_scheme = timeit_msg defs_ctxt "record induct_scheme proof:" (fn () =>
  2143       Goal.prove_sorry_global defs_thy [] [] induct_scheme_prop
  2143       Goal.prove_sorry_global defs_thy [] [] induct_scheme_prop
  2144         (fn {context = ctxt, ...} =>
  2144         (fn {context = ctxt', ...} =>
  2145           EVERY
  2145           EVERY
  2146            [case parent_induct of NONE => all_tac | SOME ind => try_param_tac ctxt rN ind 1,
  2146            [case parent_induct of NONE => all_tac | SOME ind => try_param_tac ctxt' rN ind 1,
  2147             try_param_tac ctxt rN ext_induct 1,
  2147             try_param_tac ctxt' rN ext_induct 1,
  2148             asm_simp_tac (put_simpset HOL_basic_ss ctxt) 1]));
  2148             asm_simp_tac (put_simpset HOL_basic_ss ctxt') 1]));
  2149 
  2149 
  2150     val induct = timeit_msg defs_ctxt "record induct proof:" (fn () =>
  2150     val induct = timeit_msg defs_ctxt "record induct proof:" (fn () =>
  2151       Goal.prove_sorry_global defs_thy [] [#1 induct_prop] (#2 induct_prop)
  2151       Goal.prove_sorry_global defs_thy [] [#1 induct_prop] (#2 induct_prop)
  2152         (fn {context = ctxt, prems, ...} =>
  2152         (fn {context = ctxt', prems, ...} =>
  2153           try_param_tac ctxt rN induct_scheme 1
  2153           try_param_tac ctxt' rN induct_scheme 1
  2154           THEN try_param_tac ctxt "more" @{thm unit.induct} 1
  2154           THEN try_param_tac ctxt' "more" @{thm unit.induct} 1
  2155           THEN resolve_tac ctxt prems 1));
  2155           THEN resolve_tac ctxt' prems 1));
  2156 
  2156 
  2157     val surjective = timeit_msg defs_ctxt "record surjective proof:" (fn () =>
  2157     val surjective = timeit_msg defs_ctxt "record surjective proof:" (fn () =>
  2158       Goal.prove_sorry_global defs_thy [] [] surjective_prop
  2158       Goal.prove_sorry_global defs_thy [] [] surjective_prop
  2159         (fn {context = ctxt, ...} =>
  2159         (fn {context = ctxt', ...} =>
  2160           EVERY
  2160           EVERY
  2161            [resolve_tac ctxt [surject_assist_idE] 1,
  2161            [resolve_tac ctxt' [surject_assist_idE] 1,
  2162             simp_tac (put_simpset HOL_basic_ss ctxt addsimps ext_defs) 1,
  2162             simp_tac (put_simpset HOL_basic_ss ctxt' addsimps ext_defs) 1,
  2163             REPEAT
  2163             REPEAT
  2164               (Iso_Tuple_Support.iso_tuple_intros_tac ctxt 1 ORELSE
  2164               (Iso_Tuple_Support.iso_tuple_intros_tac ctxt' 1 ORELSE
  2165                 (resolve_tac ctxt [surject_assistI] 1 THEN
  2165                 (resolve_tac ctxt' [surject_assistI] 1 THEN
  2166                   simp_tac (put_simpset (get_sel_upd_defs defs_thy) ctxt
  2166                   simp_tac (put_simpset (get_sel_upd_defs defs_thy) ctxt'
  2167                     addsimps (sel_defs @ @{thms o_assoc id_apply id_o o_id})) 1))]));
  2167                     addsimps (sel_defs @ @{thms o_assoc id_apply id_o o_id})) 1))]));
  2168 
  2168 
  2169     val cases_scheme = timeit_msg defs_ctxt "record cases_scheme proof:" (fn () =>
  2169     val cases_scheme = timeit_msg defs_ctxt "record cases_scheme proof:" (fn () =>
  2170       Goal.prove_sorry_global defs_thy [] [#1 cases_scheme_prop] (#2 cases_scheme_prop)
  2170       Goal.prove_sorry_global defs_thy [] [#1 cases_scheme_prop] (#2 cases_scheme_prop)
  2171         (fn {context = ctxt, prems, ...} =>
  2171         (fn {context = ctxt', prems, ...} =>
  2172           resolve_tac ctxt prems 1 THEN
  2172           resolve_tac ctxt' prems 1 THEN
  2173           resolve_tac ctxt [surjective] 1));
  2173           resolve_tac ctxt' [surjective] 1));
  2174 
  2174 
  2175     val cases = timeit_msg defs_ctxt "record cases proof:" (fn () =>
  2175     val cases = timeit_msg defs_ctxt "record cases proof:" (fn () =>
  2176       Goal.prove_sorry_global defs_thy [] [] cases_prop
  2176       Goal.prove_sorry_global defs_thy [] [] cases_prop
  2177         (fn {context = ctxt, ...} =>
  2177         (fn {context = ctxt', ...} =>
  2178           try_param_tac ctxt rN cases_scheme 1 THEN
  2178           try_param_tac ctxt' rN cases_scheme 1 THEN
  2179           ALLGOALS (asm_full_simp_tac
  2179           ALLGOALS (asm_full_simp_tac
  2180             (put_simpset HOL_basic_ss ctxt addsimps @{thms unit_all_eq1}))));
  2180             (put_simpset HOL_basic_ss ctxt' addsimps @{thms unit_all_eq1}))));
  2181 
  2181 
  2182     val split_meta = timeit_msg defs_ctxt "record split_meta proof:" (fn () =>
  2182     val split_meta = timeit_msg defs_ctxt "record split_meta proof:" (fn () =>
  2183       Goal.prove_sorry_global defs_thy [] [] split_meta_prop
  2183       Goal.prove_sorry_global defs_thy [] [] split_meta_prop
  2184         (fn {context = ctxt', ...} =>
  2184         (fn {context = ctxt', ...} =>
  2185           EVERY1
  2185           EVERY1
  2188             resolve_tac ctxt' [@{thm prop_subst} OF [surjective]],
  2188             resolve_tac ctxt' [@{thm prop_subst} OF [surjective]],
  2189             REPEAT o eresolve_tac ctxt' @{thms meta_allE}, assume_tac ctxt']));
  2189             REPEAT o eresolve_tac ctxt' @{thms meta_allE}, assume_tac ctxt']));
  2190 
  2190 
  2191     val split_object = timeit_msg defs_ctxt "record split_object proof:" (fn () =>
  2191     val split_object = timeit_msg defs_ctxt "record split_object proof:" (fn () =>
  2192       Goal.prove_sorry_global defs_thy [] [] split_object_prop
  2192       Goal.prove_sorry_global defs_thy [] [] split_object_prop
  2193         (fn {context = ctxt, ...} =>
  2193         (fn {context = ctxt', ...} =>
  2194           resolve_tac ctxt [@{lemma "Trueprop A \<equiv> Trueprop B \<Longrightarrow> A = B" by (rule iffI) unfold}] 1 THEN
  2194           resolve_tac ctxt' [@{lemma "Trueprop A \<equiv> Trueprop B \<Longrightarrow> A = B" by (rule iffI) unfold}] 1 THEN
  2195           rewrite_goals_tac ctxt @{thms atomize_all [symmetric]} THEN
  2195           rewrite_goals_tac ctxt' @{thms atomize_all [symmetric]} THEN
  2196           resolve_tac ctxt [split_meta] 1));
  2196           resolve_tac ctxt' [split_meta] 1));
  2197 
  2197 
  2198     val split_ex = timeit_msg defs_ctxt "record split_ex proof:" (fn () =>
  2198     val split_ex = timeit_msg defs_ctxt "record split_ex proof:" (fn () =>
  2199       Goal.prove_sorry_global defs_thy [] [] split_ex_prop
  2199       Goal.prove_sorry_global defs_thy [] [] split_ex_prop
  2200         (fn {context = ctxt, ...} =>
  2200         (fn {context = ctxt', ...} =>
  2201           simp_tac
  2201           simp_tac
  2202             (put_simpset HOL_basic_ss ctxt addsimps
  2202             (put_simpset HOL_basic_ss ctxt' addsimps
  2203               (@{lemma "\<exists>x. P x \<equiv> \<not> (\<forall>x. \<not> P x)" by simp} ::
  2203               (@{lemma "\<exists>x. P x \<equiv> \<not> (\<forall>x. \<not> P x)" by simp} ::
  2204                 @{thms not_not Not_eq_iff})) 1 THEN
  2204                 @{thms not_not Not_eq_iff})) 1 THEN
  2205           resolve_tac ctxt [split_object] 1));
  2205           resolve_tac ctxt' [split_object] 1));
  2206 
  2206 
  2207     val equality = timeit_msg defs_ctxt "record equality proof:" (fn () =>
  2207     val equality = timeit_msg defs_ctxt "record equality proof:" (fn () =>
  2208       Goal.prove_sorry_global defs_thy [] [] equality_prop
  2208       Goal.prove_sorry_global defs_thy [] [] equality_prop
  2209         (fn {context = ctxt, ...} =>
  2209         (fn {context = ctxt', ...} =>
  2210           asm_full_simp_tac (put_simpset record_ss ctxt addsimps (split_meta :: sel_convs)) 1));
  2210           asm_full_simp_tac (put_simpset record_ss ctxt' addsimps (split_meta :: sel_convs)) 1));
  2211 
  2211 
  2212     val ([(_, sel_convs'), (_, upd_convs'), (_, sel_defs'), (_, upd_defs'),
  2212     val ([(_, sel_convs'), (_, upd_convs'), (_, sel_defs'), (_, upd_defs'),
  2213           (_, fold_congs'), (_, unfold_congs'),
  2213           (_, fold_congs'), (_, unfold_congs'),
  2214           (_, splits' as [split_meta', split_object', split_ex']), (_, derived_defs'),
  2214           (_, splits' as [split_meta', split_object', split_ex']), (_, derived_defs'),
  2215           (_, [surjective']), (_, [equality']), (_, [induct_scheme']), (_, [induct']),
  2215           (_, [surjective']), (_, [equality']), (_, [induct_scheme']), (_, [induct']),