# HG changeset patch # User wenzelm # Date 1697574552 -7200 # Node ID c74fd21af246438eb21ce293b9486ffdff17cbfd # Parent 2cb027b951886013fdef38aba00aa1f26bee05d3 clarified simproc_setup (passive); diff -r 2cb027b95188 -r c74fd21af246 src/HOL/HOL.thy --- a/src/HOL/HOL.thy Tue Oct 17 22:25:48 2023 +0200 +++ b/src/HOL/HOL.thy Tue Oct 17 22:29:12 2023 +0200 @@ -1542,33 +1542,34 @@ ML_file \~~/src/Tools/induction.ML\ +simproc_setup swap_induct_false ("induct_false \ PROP P \ PROP Q") = + \fn _ => fn _ => fn ct => + (case Thm.term_of ct of + _ $ (P as _ $ \<^Const_>\induct_false\) $ (_ $ Q $ _) => + if P <> Q then SOME Drule.swap_prems_eq else NONE + | _ => NONE)\ + (passive) + +simproc_setup induct_equal_conj_curry ("induct_conj P Q \ PROP R") = + \fn _ => fn _ => fn ct => + (case Thm.term_of ct of + _ $ (_ $ P) $ _ => + let + fun is_conj \<^Const_>\induct_conj for P Q\ = is_conj P andalso is_conj Q + | is_conj \<^Const_>\induct_equal _ for _ _\ = true + | is_conj \<^Const_>\induct_true\ = true + | is_conj \<^Const_>\induct_false\ = true + | is_conj _ = false + in if is_conj P then SOME @{thm induct_conj_curry} else NONE end + | _ => NONE)\ + (passive) + declaration \ - fn _ => Induct.map_simpset (fn ss => ss - addsimprocs - [Simplifier.make_simproc \<^context> "swap_induct_false" - {lhss = [\<^term>\induct_false \ PROP P \ PROP Q\], - proc = fn _ => fn _ => fn ct => - (case Thm.term_of ct of - _ $ (P as _ $ \<^Const_>\induct_false\) $ (_ $ Q $ _) => - if P <> Q then SOME Drule.swap_prems_eq else NONE - | _ => NONE)}, - Simplifier.make_simproc \<^context> "induct_equal_conj_curry" - {lhss = [\<^term>\induct_conj P Q \ PROP R\], - proc = fn _ => fn _ => fn ct => - (case Thm.term_of ct of - _ $ (_ $ P) $ _ => - let - fun is_conj \<^Const_>\induct_conj for P Q\ = - is_conj P andalso is_conj Q - | is_conj \<^Const_>\induct_equal _ for _ _\ = true - | is_conj \<^Const_>\induct_true\ = true - | is_conj \<^Const_>\induct_false\ = true - | is_conj _ = false - in if is_conj P then SOME @{thm induct_conj_curry} else NONE end - | _ => NONE)}] + K (Induct.map_simpset (fn ss => ss + addsimprocs [\<^simproc>\swap_induct_false\, \<^simproc>\induct_equal_conj_curry\] |> Simplifier.set_mksimps (fn ctxt => - Simpdata.mksimps Simpdata.mksimps_pairs ctxt #> - map (rewrite_rule ctxt (map Thm.symmetric @{thms induct_rulify_fallback})))) + Simpdata.mksimps Simpdata.mksimps_pairs ctxt #> + map (rewrite_rule ctxt (map Thm.symmetric @{thms induct_rulify_fallback}))))) \ text \Pre-simplification of induction and cases rules\ @@ -1933,16 +1934,14 @@ declare eq_equal [symmetric, code_post] declare eq_equal [code] -setup \ - Code_Preproc.map_pre (fn ctxt => - ctxt addsimprocs - [Simplifier.make_simproc \<^context> "equal" - {lhss = [\<^term>\HOL.eq\], - proc = fn _ => fn _ => fn ct => - (case Thm.term_of ct of - Const (_, Type (\<^type_name>\fun\, [Type _, _])) => SOME @{thm eq_equal} - | _ => NONE)}]) -\ +simproc_setup equal (HOL.eq) = + \fn _ => fn _ => fn ct => + (case Thm.term_of ct of + Const (_, Type (\<^type_name>\fun\, [Type _, _])) => SOME @{thm eq_equal} + | _ => NONE)\ + (passive) + +setup \Code_Preproc.map_pre (fn ctxt => ctxt addsimprocs [\<^simproc>\equal\])\ subsubsection \Generic code generator foundation\ diff -r 2cb027b95188 -r c74fd21af246 src/HOL/Product_Type.thy --- a/src/HOL/Product_Type.thy Tue Oct 17 22:25:48 2023 +0200 +++ b/src/HOL/Product_Type.thy Tue Oct 17 22:29:12 2023 +0200 @@ -1303,12 +1303,12 @@ ML_file \Tools/set_comprehension_pointfree.ML\ -setup \ - Code_Preproc.map_pre (fn ctxt => ctxt addsimprocs - [Simplifier.make_simproc \<^context> "set comprehension" - {lhss = [\<^term>\Collect P\], - proc = K Set_Comprehension_Pointfree.code_simproc}]) -\ +simproc_setup set_comprehension ("Collect P") = + \K Set_Comprehension_Pointfree.code_simproc\ + (passive) + +setup \Code_Preproc.map_pre (fn ctxt => ctxt addsimprocs [\<^simproc>\set_comprehension\])\ + subsection \Lemmas about disjointness\