nipkow@10213: (* Title: HOL/Product_Type.thy nipkow@10213: Author: Lawrence C Paulson, Cambridge University Computer Laboratory nipkow@10213: Copyright 1992 University of Cambridge wenzelm@11777: *) nipkow@10213: wenzelm@11838: header {* Cartesian products *} nipkow@10213: nipkow@15131: theory Product_Type haftmann@33959: imports Typedef Inductive Fun haftmann@24699: uses haftmann@24699: ("Tools/split_rule.ML") haftmann@31723: ("Tools/inductive_set.ML") nipkow@15131: begin wenzelm@11838: haftmann@24699: subsection {* @{typ bool} is a datatype *} haftmann@24699: haftmann@27104: rep_datatype True False by (auto intro: bool_induct) haftmann@24699: haftmann@24699: declare case_split [cases type: bool] haftmann@24699: -- "prefer plain propositional version" haftmann@24699: haftmann@28346: lemma haftmann@28562: shows [code]: "eq_class.eq False P \ \ P" haftmann@28562: and [code]: "eq_class.eq True P \ P" haftmann@28562: and [code]: "eq_class.eq P False \ \ P" haftmann@28562: and [code]: "eq_class.eq P True \ P" haftmann@28346: and [code nbe]: "eq_class.eq P P \ True" haftmann@28346: by (simp_all add: eq) haftmann@25534: haftmann@28346: code_const "eq_class.eq \ bool \ bool \ bool" haftmann@25534: (Haskell infixl 4 "==") haftmann@25534: haftmann@25534: code_instance bool :: eq haftmann@25534: (Haskell -) haftmann@24699: haftmann@26358: wenzelm@11838: subsection {* Unit *} wenzelm@11838: wenzelm@11838: typedef unit = "{True}" wenzelm@11838: proof haftmann@20588: show "True : ?unit" .. wenzelm@11838: qed wenzelm@11838: haftmann@24699: definition wenzelm@11838: Unity :: unit ("'(')") haftmann@24699: where haftmann@24699: "() = Abs_unit True" wenzelm@11838: paulson@24286: lemma unit_eq [noatp]: "u = ()" wenzelm@11838: by (induct u) (simp add: unit_def Unity_def) wenzelm@11838: wenzelm@11838: text {* wenzelm@11838: Simplification procedure for @{thm [source] unit_eq}. Cannot use wenzelm@11838: this rule directly --- it loops! wenzelm@11838: *} wenzelm@11838: wenzelm@26480: ML {* wenzelm@13462: val unit_eq_proc = haftmann@24699: let val unit_meta_eq = mk_meta_eq @{thm unit_eq} in haftmann@24699: Simplifier.simproc @{theory} "unit_eq" ["x::unit"] skalberg@15531: (fn _ => fn _ => fn t => if HOLogic.is_unit t then NONE else SOME unit_meta_eq) wenzelm@13462: end; wenzelm@11838: wenzelm@11838: Addsimprocs [unit_eq_proc]; wenzelm@11838: *} wenzelm@11838: haftmann@27104: rep_datatype "()" by simp haftmann@24699: wenzelm@11838: lemma unit_all_eq1: "(!!x::unit. PROP P x) == PROP P ()" wenzelm@11838: by simp wenzelm@11838: wenzelm@11838: lemma unit_all_eq2: "(!!x::unit. PROP P) == PROP P" wenzelm@11838: by (rule triv_forall_equality) wenzelm@11838: wenzelm@11838: text {* wenzelm@11838: This rewrite counters the effect of @{text unit_eq_proc} on @{term wenzelm@11838: [source] "%u::unit. f u"}, replacing it by @{term [source] wenzelm@11838: f} rather than by @{term [source] "%u. f ()"}. wenzelm@11838: *} wenzelm@11838: paulson@24286: lemma unit_abs_eta_conv [simp,noatp]: "(%u::unit. f ()) = f" wenzelm@11838: by (rule ext) simp nipkow@10213: haftmann@30924: instantiation unit :: default haftmann@30924: begin haftmann@30924: haftmann@30924: definition "default = ()" haftmann@30924: haftmann@30924: instance .. haftmann@30924: haftmann@30924: end nipkow@10213: haftmann@26358: text {* code generator setup *} haftmann@26358: haftmann@28562: lemma [code]: haftmann@28346: "eq_class.eq (u\unit) v \ True" unfolding eq unit_eq [of u] unit_eq [of v] by rule+ haftmann@26358: haftmann@26358: code_type unit haftmann@26358: (SML "unit") haftmann@26358: (OCaml "unit") haftmann@26358: (Haskell "()") haftmann@34886: (Scala "Unit") haftmann@26358: haftmann@26358: code_instance unit :: eq haftmann@26358: (Haskell -) haftmann@26358: haftmann@28346: code_const "eq_class.eq \ unit \ unit \ bool" haftmann@26358: (Haskell infixl 4 "==") haftmann@26358: haftmann@26358: code_const Unity haftmann@26358: (SML "()") haftmann@26358: (OCaml "()") haftmann@26358: (Haskell "()") haftmann@34886: (Scala "()") haftmann@26358: haftmann@26358: code_reserved SML haftmann@26358: unit haftmann@26358: haftmann@26358: code_reserved OCaml haftmann@26358: unit haftmann@26358: haftmann@34886: code_reserved Scala haftmann@34886: Unit haftmann@34886: haftmann@26358: wenzelm@11838: subsection {* Pairs *} nipkow@10213: haftmann@26358: subsubsection {* Product type, basic operations and concrete syntax *} nipkow@10213: haftmann@26358: definition haftmann@26358: Pair_Rep :: "'a \ 'b \ 'a \ 'b \ bool" haftmann@26358: where haftmann@26358: "Pair_Rep a b = (\x y. x = a \ y = b)" nipkow@10213: nipkow@10213: global nipkow@10213: nipkow@10213: typedef (Prod) haftmann@22838: ('a, 'b) "*" (infixr "*" 20) haftmann@26358: = "{f. \a b. f = Pair_Rep (a\'a) (b\'b)}" oheimb@11025: proof haftmann@26358: fix a b show "Pair_Rep a b \ ?Prod" haftmann@26358: by rule+ oheimb@11025: qed nipkow@10213: wenzelm@12114: syntax (xsymbols) schirmer@15422: "*" :: "[type, type] => type" ("(_ \/ _)" [21, 20] 20) nipkow@10213: syntax (HTML output) schirmer@15422: "*" :: "[type, type] => type" ("(_ \/ _)" [21, 20] 20) nipkow@10213: nipkow@10213: consts haftmann@26358: Pair :: "'a \ 'b \ 'a \ 'b" haftmann@26358: fst :: "'a \ 'b \ 'a" haftmann@26358: snd :: "'a \ 'b \ 'b" haftmann@26358: split :: "('a \ 'b \ 'c) \ 'a \ 'b \ 'c" haftmann@26358: curry :: "('a \ 'b \ 'c) \ 'a \ 'b \ 'c" nipkow@10213: wenzelm@11777: local nipkow@10213: wenzelm@19535: defs wenzelm@19535: Pair_def: "Pair a b == Abs_Prod (Pair_Rep a b)" wenzelm@19535: fst_def: "fst p == THE a. EX b. p = Pair a b" wenzelm@19535: snd_def: "snd p == THE b. EX a. p = Pair a b" haftmann@24162: split_def: "split == (%c p. c (fst p) (snd p))" haftmann@24162: curry_def: "curry == (%c x y. c (Pair x y))" wenzelm@19535: wenzelm@11777: text {* wenzelm@11777: Patterns -- extends pre-defined type @{typ pttrn} used in wenzelm@11777: abstractions. wenzelm@11777: *} nipkow@10213: nipkow@10213: nonterminals nipkow@10213: tuple_args patterns nipkow@10213: nipkow@10213: syntax nipkow@10213: "_tuple" :: "'a => tuple_args => 'a * 'b" ("(1'(_,/ _'))") nipkow@10213: "_tuple_arg" :: "'a => tuple_args" ("_") nipkow@10213: "_tuple_args" :: "'a => tuple_args => tuple_args" ("_,/ _") oheimb@11025: "_pattern" :: "[pttrn, patterns] => pttrn" ("'(_,/ _')") oheimb@11025: "" :: "pttrn => patterns" ("_") oheimb@11025: "_patterns" :: "[pttrn, patterns] => patterns" ("_,/ _") nipkow@10213: nipkow@10213: translations wenzelm@35115: "(x, y)" == "CONST Pair x y" nipkow@10213: "_tuple x (_tuple_args y z)" == "_tuple x (_tuple_arg (_tuple y z))" wenzelm@35115: "%(x, y, zs). b" == "CONST split (%x (y, zs). b)" wenzelm@35115: "%(x, y). b" == "CONST split (%x y. b)" wenzelm@35115: "_abs (CONST Pair x y) t" => "%(x, y). t" nipkow@10213: (* The last rule accommodates tuples in `case C ... (x,y) ... => ...' nipkow@10213: The (x,y) is parsed as `Pair x y' because it is logic, not pttrn *) nipkow@10213: wenzelm@35115: (*reconstruct pattern from (nested) splits, avoiding eta-contraction of body; wenzelm@35115: works best with enclosing "let", if "let" does not avoid eta-contraction*) schirmer@14359: print_translation {* wenzelm@35115: let wenzelm@35115: fun split_tr' [Abs (x, T, t as (Abs abs))] = wenzelm@35115: (* split (%x y. t) => %(x,y) t *) wenzelm@35115: let wenzelm@35115: val (y, t') = atomic_abs_tr' abs; wenzelm@35115: val (x', t'') = atomic_abs_tr' (x, T, t'); wenzelm@35115: in wenzelm@35115: Syntax.const @{syntax_const "_abs"} $ wenzelm@35115: (Syntax.const @{syntax_const "_pattern"} $ x' $ y) $ t'' wenzelm@35115: end wenzelm@35115: | split_tr' [Abs (x, T, (s as Const (@{const_syntax split}, _) $ t))] = wenzelm@35115: (* split (%x. (split (%y z. t))) => %(x,y,z). t *) wenzelm@35115: let wenzelm@35115: val Const (@{syntax_const "_abs"}, _) $ wenzelm@35115: (Const (@{syntax_const "_pattern"}, _) $ y $ z) $ t' = split_tr' [t]; wenzelm@35115: val (x', t'') = atomic_abs_tr' (x, T, t'); wenzelm@35115: in wenzelm@35115: Syntax.const @{syntax_const "_abs"} $ wenzelm@35115: (Syntax.const @{syntax_const "_pattern"} $ x' $ wenzelm@35115: (Syntax.const @{syntax_const "_patterns"} $ y $ z)) $ t'' wenzelm@35115: end wenzelm@35115: | split_tr' [Const (@{const_syntax split}, _) $ t] = wenzelm@35115: (* split (split (%x y z. t)) => %((x, y), z). t *) wenzelm@35115: split_tr' [(split_tr' [t])] (* inner split_tr' creates next pattern *) wenzelm@35115: | split_tr' [Const (@{syntax_const "_abs"}, _) $ x_y $ Abs abs] = wenzelm@35115: (* split (%pttrn z. t) => %(pttrn,z). t *) wenzelm@35115: let val (z, t) = atomic_abs_tr' abs in wenzelm@35115: Syntax.const @{syntax_const "_abs"} $ wenzelm@35115: (Syntax.const @{syntax_const "_pattern"} $ x_y $ z) $ t wenzelm@35115: end wenzelm@35115: | split_tr' _ = raise Match; wenzelm@35115: in [(@{const_syntax split}, split_tr')] end schirmer@14359: *} schirmer@14359: schirmer@15422: (* print "split f" as "\(x,y). f x y" and "split (\x. f x)" as "\(x,y). f x y" *) schirmer@15422: typed_print_translation {* schirmer@15422: let wenzelm@35115: fun split_guess_names_tr' _ T [Abs (x, _, Abs _)] = raise Match wenzelm@35115: | split_guess_names_tr' _ T [Abs (x, xT, t)] = schirmer@15422: (case (head_of t) of wenzelm@35115: Const (@{const_syntax split}, _) => raise Match wenzelm@35115: | _ => wenzelm@35115: let wenzelm@35115: val (_ :: yT :: _) = binder_types (domain_type T) handle Bind => raise Match; wenzelm@35115: val (y, t') = atomic_abs_tr' ("y", yT, incr_boundvars 1 t $ Bound 0); wenzelm@35115: val (x', t'') = atomic_abs_tr' (x, xT, t'); wenzelm@35115: in wenzelm@35115: Syntax.const @{syntax_const "_abs"} $ wenzelm@35115: (Syntax.const @{syntax_const "_pattern"} $ x' $ y) $ t'' wenzelm@35115: end) schirmer@15422: | split_guess_names_tr' _ T [t] = wenzelm@35115: (case head_of t of wenzelm@35115: Const (@{const_syntax split}, _) => raise Match wenzelm@35115: | _ => wenzelm@35115: let wenzelm@35115: val (xT :: yT :: _) = binder_types (domain_type T) handle Bind => raise Match; wenzelm@35115: val (y, t') = atomic_abs_tr' ("y", yT, incr_boundvars 2 t $ Bound 1 $ Bound 0); wenzelm@35115: val (x', t'') = atomic_abs_tr' ("x", xT, t'); wenzelm@35115: in wenzelm@35115: Syntax.const @{syntax_const "_abs"} $ wenzelm@35115: (Syntax.const @{syntax_const "_pattern"} $ x' $ y) $ t'' wenzelm@35115: end) schirmer@15422: | split_guess_names_tr' _ _ _ = raise Match; wenzelm@35115: in [(@{const_syntax split}, split_guess_names_tr')] end schirmer@15422: *} schirmer@15422: nipkow@10213: haftmann@26358: text {* Towards a datatype declaration *} wenzelm@11838: haftmann@26358: lemma surj_pair [simp]: "EX x y. p = (x, y)" haftmann@26358: apply (unfold Pair_def) haftmann@26358: apply (rule Rep_Prod [unfolded Prod_def, THEN CollectE]) haftmann@26358: apply (erule exE, erule exE, rule exI, rule exI) haftmann@26358: apply (rule Rep_Prod_inverse [symmetric, THEN trans]) haftmann@26358: apply (erule arg_cong) haftmann@26358: done wenzelm@11838: haftmann@26358: lemma PairE [cases type: *]: haftmann@26358: obtains x y where "p = (x, y)" haftmann@26358: using surj_pair [of p] by blast haftmann@26358: haftmann@26358: lemma ProdI: "Pair_Rep a b \ Prod" haftmann@26358: unfolding Prod_def by rule+ haftmann@26358: haftmann@26358: lemma Pair_Rep_inject: "Pair_Rep a b = Pair_Rep a' b' \ a = a' \ b = b'" haftmann@26358: unfolding Pair_Rep_def by (drule fun_cong, drule fun_cong) blast nipkow@10213: wenzelm@11838: lemma inj_on_Abs_Prod: "inj_on Abs_Prod Prod" wenzelm@11838: apply (rule inj_on_inverseI) wenzelm@11838: apply (erule Abs_Prod_inverse) wenzelm@11838: done wenzelm@11838: wenzelm@11838: lemma Pair_inject: wenzelm@18372: assumes "(a, b) = (a', b')" wenzelm@18372: and "a = a' ==> b = b' ==> R" wenzelm@18372: shows R wenzelm@18372: apply (insert prems [unfolded Pair_def]) wenzelm@18372: apply (rule inj_on_Abs_Prod [THEN inj_onD, THEN Pair_Rep_inject, THEN conjE]) wenzelm@18372: apply (assumption | rule ProdI)+ wenzelm@18372: done nipkow@10213: haftmann@27104: rep_datatype (prod) Pair haftmann@27104: proof - haftmann@27104: fix P p haftmann@27104: assume "\x y. P (x, y)" haftmann@27104: then show "P p" by (cases p) simp haftmann@27104: qed (auto elim: Pair_inject) haftmann@27104: haftmann@27104: lemmas Pair_eq = prod.inject wenzelm@11838: haftmann@22886: lemma fst_conv [simp, code]: "fst (a, b) = a" wenzelm@19535: unfolding fst_def by blast wenzelm@11838: haftmann@22886: lemma snd_conv [simp, code]: "snd (a, b) = b" wenzelm@19535: unfolding snd_def by blast oheimb@11025: haftmann@26358: haftmann@26358: subsubsection {* Basic rules and proof tools *} haftmann@26358: wenzelm@11838: lemma fst_eqD: "fst (x, y) = a ==> x = a" wenzelm@11838: by simp wenzelm@11838: wenzelm@11838: lemma snd_eqD: "snd (x, y) = a ==> y = a" wenzelm@11838: by simp wenzelm@11838: haftmann@26358: lemma pair_collapse [simp]: "(fst p, snd p) = p" wenzelm@11838: by (cases p) simp wenzelm@11838: haftmann@26358: lemmas surjective_pairing = pair_collapse [symmetric] wenzelm@11838: wenzelm@11838: lemma split_paired_all: "(!!x. PROP P x) == (!!a b. PROP P (a, b))" wenzelm@11820: proof wenzelm@11820: fix a b wenzelm@11820: assume "!!x. PROP P x" wenzelm@19535: then show "PROP P (a, b)" . wenzelm@11820: next wenzelm@11820: fix x wenzelm@11820: assume "!!a b. PROP P (a, b)" wenzelm@19535: from `PROP P (fst x, snd x)` show "PROP P x" by simp wenzelm@11820: qed wenzelm@11820: wenzelm@11838: text {* wenzelm@11838: The rule @{thm [source] split_paired_all} does not work with the wenzelm@11838: Simplifier because it also affects premises in congrence rules, wenzelm@11838: where this can lead to premises of the form @{text "!!a b. ... = wenzelm@11838: ?P(a, b)"} which cannot be solved by reflexivity. wenzelm@11838: *} wenzelm@11838: haftmann@26358: lemmas split_tupled_all = split_paired_all unit_all_eq2 haftmann@26358: wenzelm@26480: ML {* wenzelm@11838: (* replace parameters of product type by individual component parameters *) wenzelm@11838: val safe_full_simp_tac = generic_simp_tac true (true, false, false); wenzelm@11838: local (* filtering with exists_paired_all is an essential optimization *) wenzelm@16121: fun exists_paired_all (Const ("all", _) $ Abs (_, T, t)) = wenzelm@11838: can HOLogic.dest_prodT T orelse exists_paired_all t wenzelm@11838: | exists_paired_all (t $ u) = exists_paired_all t orelse exists_paired_all u wenzelm@11838: | exists_paired_all (Abs (_, _, t)) = exists_paired_all t wenzelm@11838: | exists_paired_all _ = false; wenzelm@11838: val ss = HOL_basic_ss wenzelm@26340: addsimps [@{thm split_paired_all}, @{thm unit_all_eq2}, @{thm unit_abs_eta_conv}] wenzelm@11838: addsimprocs [unit_eq_proc]; wenzelm@11838: in wenzelm@11838: val split_all_tac = SUBGOAL (fn (t, i) => wenzelm@11838: if exists_paired_all t then safe_full_simp_tac ss i else no_tac); wenzelm@11838: val unsafe_split_all_tac = SUBGOAL (fn (t, i) => wenzelm@11838: if exists_paired_all t then full_simp_tac ss i else no_tac); wenzelm@11838: fun split_all th = wenzelm@26340: if exists_paired_all (Thm.prop_of th) then full_simplify ss th else th; wenzelm@11838: end; wenzelm@26340: *} wenzelm@11838: wenzelm@26340: declaration {* fn _ => wenzelm@26340: Classical.map_cs (fn cs => cs addSbefore ("split_all_tac", split_all_tac)) wenzelm@16121: *} wenzelm@11838: wenzelm@11838: lemma split_paired_All [simp]: "(ALL x. P x) = (ALL a b. P (a, b))" wenzelm@11838: -- {* @{text "[iff]"} is not a good idea because it makes @{text blast} loop *} wenzelm@11838: by fast wenzelm@11838: haftmann@26358: lemma split_paired_Ex [simp]: "(EX x. P x) = (EX a b. P (a, b))" haftmann@26358: by fast haftmann@26358: haftmann@26358: lemma Pair_fst_snd_eq: "s = t \ fst s = fst t \ snd s = snd t" haftmann@26358: by (cases s, cases t) simp haftmann@26358: haftmann@26358: lemma prod_eqI [intro?]: "fst p = fst q \ snd p = snd q \ p = q" haftmann@26358: by (simp add: Pair_fst_snd_eq) haftmann@26358: haftmann@26358: haftmann@26358: subsubsection {* @{text split} and @{text curry} *} haftmann@26358: haftmann@28562: lemma split_conv [simp, code]: "split f (a, b) = f a b" haftmann@26358: by (simp add: split_def) haftmann@26358: haftmann@28562: lemma curry_conv [simp, code]: "curry f a b = f (a, b)" haftmann@26358: by (simp add: curry_def) haftmann@26358: haftmann@26358: lemmas split = split_conv -- {* for backwards compatibility *} haftmann@26358: haftmann@26358: lemma splitI: "f a b \ split f (a, b)" haftmann@26358: by (rule split_conv [THEN iffD2]) haftmann@26358: haftmann@26358: lemma splitD: "split f (a, b) \ f a b" haftmann@26358: by (rule split_conv [THEN iffD1]) haftmann@26358: haftmann@26358: lemma curryI [intro!]: "f (a, b) \ curry f a b" haftmann@26358: by (simp add: curry_def) haftmann@26358: haftmann@26358: lemma curryD [dest!]: "curry f a b \ f (a, b)" haftmann@26358: by (simp add: curry_def) haftmann@26358: haftmann@26358: lemma curryE: "curry f a b \ (f (a, b) \ Q) \ Q" haftmann@26358: by (simp add: curry_def) haftmann@26358: skalberg@14189: lemma curry_split [simp]: "curry (split f) = f" skalberg@14189: by (simp add: curry_def split_def) skalberg@14189: skalberg@14189: lemma split_curry [simp]: "split (curry f) = f" skalberg@14189: by (simp add: curry_def split_def) skalberg@14189: haftmann@26358: lemma split_Pair [simp]: "(\(x, y). (x, y)) = id" haftmann@26358: by (simp add: split_def id_def) wenzelm@11838: haftmann@26358: lemma split_eta: "(\(x, y). f (x, y)) = f" haftmann@31775: -- {* Subsumes the old @{text split_Pair} when @{term f} is the identity Datatype. *} haftmann@26358: by (rule ext) auto wenzelm@11838: haftmann@26358: lemma split_comp: "split (f \ g) x = f (g (fst x)) (snd x)" haftmann@26358: by (cases x) simp wenzelm@11838: haftmann@26358: lemma split_twice: "split f (split g p) = split (\x y. split f (g x y)) p" haftmann@26358: unfolding split_def .. wenzelm@11838: wenzelm@11838: lemma split_paired_The: "(THE x. P x) = (THE (a, b). P (a, b))" wenzelm@11838: -- {* Can't be added to simpset: loops! *} haftmann@26358: by (simp add: split_eta) wenzelm@11838: wenzelm@11838: lemma The_split: "The (split P) = (THE xy. P (fst xy) (snd xy))" wenzelm@11838: by (simp add: split_def) wenzelm@11838: haftmann@26358: lemma split_weak_cong: "p = q \ split c p = split c q" wenzelm@11838: -- {* Prevents simplification of @{term c}: much faster *} wenzelm@11838: by (erule arg_cong) wenzelm@11838: wenzelm@11838: lemma cond_split_eta: "(!!x y. f x y = g (x, y)) ==> (%(x, y). f x y) = g" wenzelm@11838: by (simp add: split_eta) wenzelm@11838: wenzelm@11838: text {* wenzelm@11838: Simplification procedure for @{thm [source] cond_split_eta}. Using wenzelm@11838: @{thm [source] split_eta} as a rewrite rule is not general enough, wenzelm@11838: and using @{thm [source] cond_split_eta} directly would render some wenzelm@11838: existing proofs very inefficient; similarly for @{text haftmann@26358: split_beta}. haftmann@26358: *} wenzelm@11838: wenzelm@26480: ML {* wenzelm@11838: local wenzelm@35364: val cond_split_eta_ss = HOL_basic_ss addsimps @{thms cond_split_eta}; wenzelm@35364: fun Pair_pat k 0 (Bound m) = (m = k) wenzelm@35364: | Pair_pat k i (Const (@{const_name Pair}, _) $ Bound m $ t) = wenzelm@35364: i > 0 andalso m = k + i andalso Pair_pat k (i - 1) t wenzelm@35364: | Pair_pat _ _ _ = false; wenzelm@35364: fun no_args k i (Abs (_, _, t)) = no_args (k + 1) i t wenzelm@35364: | no_args k i (t $ u) = no_args k i t andalso no_args k i u wenzelm@35364: | no_args k i (Bound m) = m < k orelse m > k + i wenzelm@35364: | no_args _ _ _ = true; wenzelm@35364: fun split_pat tp i (Abs (_, _, t)) = if tp 0 i t then SOME (i, t) else NONE wenzelm@35364: | split_pat tp i (Const (@{const_name split}, _) $ Abs (_, _, t)) = split_pat tp (i + 1) t wenzelm@35364: | split_pat tp i _ = NONE; wenzelm@20044: fun metaeq ss lhs rhs = mk_meta_eq (Goal.prove (Simplifier.the_context ss) [] [] wenzelm@35364: (HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs))) wenzelm@18328: (K (simp_tac (Simplifier.inherit_context ss cond_split_eta_ss) 1))); wenzelm@11838: wenzelm@35364: fun beta_term_pat k i (Abs (_, _, t)) = beta_term_pat (k + 1) i t wenzelm@35364: | beta_term_pat k i (t $ u) = wenzelm@35364: Pair_pat k i (t $ u) orelse (beta_term_pat k i t andalso beta_term_pat k i u) wenzelm@35364: | beta_term_pat k i t = no_args k i t; wenzelm@35364: fun eta_term_pat k i (f $ arg) = no_args k i f andalso Pair_pat k i arg wenzelm@35364: | eta_term_pat _ _ _ = false; wenzelm@11838: fun subst arg k i (Abs (x, T, t)) = Abs (x, T, subst arg (k+1) i t) wenzelm@35364: | subst arg k i (t $ u) = wenzelm@35364: if Pair_pat k i (t $ u) then incr_boundvars k arg wenzelm@35364: else (subst arg k i t $ subst arg k i u) wenzelm@35364: | subst arg k i t = t; wenzelm@35364: fun beta_proc ss (s as Const (@{const_name split}, _) $ Abs (_, _, t) $ arg) = wenzelm@11838: (case split_pat beta_term_pat 1 t of wenzelm@35364: SOME (i, f) => SOME (metaeq ss s (subst arg 0 i f)) skalberg@15531: | NONE => NONE) wenzelm@35364: | beta_proc _ _ = NONE; wenzelm@35364: fun eta_proc ss (s as Const (@{const_name split}, _) $ Abs (_, _, t)) = wenzelm@11838: (case split_pat eta_term_pat 1 t of wenzelm@35364: SOME (_, ft) => SOME (metaeq ss s (let val (f $ arg) = ft in f end)) skalberg@15531: | NONE => NONE) wenzelm@35364: | eta_proc _ _ = NONE; wenzelm@11838: in wenzelm@32010: val split_beta_proc = Simplifier.simproc @{theory} "split_beta" ["split f z"] (K beta_proc); wenzelm@32010: val split_eta_proc = Simplifier.simproc @{theory} "split_eta" ["split f"] (K eta_proc); wenzelm@11838: end; wenzelm@11838: wenzelm@11838: Addsimprocs [split_beta_proc, split_eta_proc]; wenzelm@11838: *} wenzelm@11838: berghofe@26798: lemma split_beta [mono]: "(%(x, y). P x y) z = P (fst z) (snd z)" wenzelm@11838: by (subst surjective_pairing, rule split_conv) wenzelm@11838: paulson@24286: lemma split_split [noatp]: "R(split c p) = (ALL x y. p = (x, y) --> R(c x y))" wenzelm@11838: -- {* For use with @{text split} and the Simplifier. *} paulson@15481: by (insert surj_pair [of p], clarify, simp) wenzelm@11838: wenzelm@11838: text {* wenzelm@11838: @{thm [source] split_split} could be declared as @{text "[split]"} wenzelm@11838: done after the Splitter has been speeded up significantly; wenzelm@11838: precompute the constants involved and don't do anything unless the wenzelm@11838: current goal contains one of those constants. wenzelm@11838: *} wenzelm@11838: paulson@24286: lemma split_split_asm [noatp]: "R (split c p) = (~(EX x y. p = (x, y) & (~R (c x y))))" paulson@14208: by (subst split_split, simp) wenzelm@11838: wenzelm@11838: wenzelm@11838: text {* wenzelm@11838: \medskip @{term split} used as a logical connective or set former. wenzelm@11838: wenzelm@11838: \medskip These rules are for use with @{text blast}; could instead wenzelm@11838: call @{text simp} using @{thm [source] split} as rewrite. *} wenzelm@11838: wenzelm@11838: lemma splitI2: "!!p. [| !!a b. p = (a, b) ==> c a b |] ==> split c p" wenzelm@11838: apply (simp only: split_tupled_all) wenzelm@11838: apply (simp (no_asm_simp)) wenzelm@11838: done wenzelm@11838: wenzelm@11838: lemma splitI2': "!!p. [| !!a b. (a, b) = p ==> c a b x |] ==> split c p x" wenzelm@11838: apply (simp only: split_tupled_all) wenzelm@11838: apply (simp (no_asm_simp)) wenzelm@11838: done wenzelm@11838: wenzelm@11838: lemma splitE: "split c p ==> (!!x y. p = (x, y) ==> c x y ==> Q) ==> Q" wenzelm@11838: by (induct p) (auto simp add: split_def) wenzelm@11838: wenzelm@11838: lemma splitE': "split c p z ==> (!!x y. p = (x, y) ==> c x y z ==> Q) ==> Q" wenzelm@11838: by (induct p) (auto simp add: split_def) wenzelm@11838: wenzelm@11838: lemma splitE2: wenzelm@11838: "[| Q (split P z); !!x y. [|z = (x, y); Q (P x y)|] ==> R |] ==> R" wenzelm@11838: proof - wenzelm@11838: assume q: "Q (split P z)" wenzelm@11838: assume r: "!!x y. [|z = (x, y); Q (P x y)|] ==> R" wenzelm@11838: show R wenzelm@11838: apply (rule r surjective_pairing)+ wenzelm@11838: apply (rule split_beta [THEN subst], rule q) wenzelm@11838: done wenzelm@11838: qed wenzelm@11838: wenzelm@11838: lemma splitD': "split R (a,b) c ==> R a b c" wenzelm@11838: by simp wenzelm@11838: wenzelm@11838: lemma mem_splitI: "z: c a b ==> z: split c (a, b)" wenzelm@11838: by simp wenzelm@11838: wenzelm@11838: lemma mem_splitI2: "!!p. [| !!a b. p = (a, b) ==> z: c a b |] ==> z: split c p" paulson@14208: by (simp only: split_tupled_all, simp) wenzelm@11838: wenzelm@18372: lemma mem_splitE: wenzelm@18372: assumes major: "z: split c p" wenzelm@18372: and cases: "!!x y. [| p = (x,y); z: c x y |] ==> Q" wenzelm@18372: shows Q wenzelm@18372: by (rule major [unfolded split_def] cases surjective_pairing)+ wenzelm@11838: wenzelm@11838: declare mem_splitI2 [intro!] mem_splitI [intro!] splitI2' [intro!] splitI2 [intro!] splitI [intro!] wenzelm@11838: declare mem_splitE [elim!] splitE' [elim!] splitE [elim!] wenzelm@11838: wenzelm@26340: ML {* wenzelm@11838: local (* filtering with exists_p_split is an essential optimization *) wenzelm@35364: fun exists_p_split (Const (@{const_name split},_) $ _ $ (Const (@{const_name Pair},_)$_$_)) = true wenzelm@11838: | exists_p_split (t $ u) = exists_p_split t orelse exists_p_split u wenzelm@11838: | exists_p_split (Abs (_, _, t)) = exists_p_split t wenzelm@11838: | exists_p_split _ = false; wenzelm@35364: val ss = HOL_basic_ss addsimps @{thms split_conv}; wenzelm@11838: in wenzelm@11838: val split_conv_tac = SUBGOAL (fn (t, i) => wenzelm@11838: if exists_p_split t then safe_full_simp_tac ss i else no_tac); wenzelm@11838: end; wenzelm@26340: *} wenzelm@26340: wenzelm@11838: (* This prevents applications of splitE for already splitted arguments leading wenzelm@11838: to quite time-consuming computations (in particular for nested tuples) *) wenzelm@26340: declaration {* fn _ => wenzelm@26340: Classical.map_cs (fn cs => cs addSbefore ("split_conv_tac", split_conv_tac)) wenzelm@16121: *} wenzelm@11838: paulson@24286: lemma split_eta_SetCompr [simp,noatp]: "(%u. EX x y. u = (x, y) & P (x, y)) = P" wenzelm@18372: by (rule ext) fast wenzelm@11838: paulson@24286: lemma split_eta_SetCompr2 [simp,noatp]: "(%u. EX x y. u = (x, y) & P x y) = split P" wenzelm@18372: by (rule ext) fast wenzelm@11838: wenzelm@11838: lemma split_part [simp]: "(%(a,b). P & Q a b) = (%ab. P & split Q ab)" wenzelm@11838: -- {* Allows simplifications of nested splits in case of independent predicates. *} wenzelm@18372: by (rule ext) blast wenzelm@11838: nipkow@14337: (* Do NOT make this a simp rule as it nipkow@14337: a) only helps in special situations nipkow@14337: b) can lead to nontermination in the presence of split_def nipkow@14337: *) nipkow@14337: lemma split_comp_eq: paulson@20415: fixes f :: "'a => 'b => 'c" and g :: "'d => 'a" paulson@20415: shows "(%u. f (g (fst u)) (snd u)) = (split (%x. f (g x)))" wenzelm@18372: by (rule ext) auto oheimb@14101: haftmann@26358: lemma pair_imageI [intro]: "(a, b) : A ==> f a b : (%(a, b). f a b) ` A" haftmann@26358: apply (rule_tac x = "(a, b)" in image_eqI) haftmann@26358: apply auto haftmann@26358: done haftmann@26358: wenzelm@11838: lemma The_split_eq [simp]: "(THE (x',y'). x = x' & y = y') = (x, y)" wenzelm@11838: by blast wenzelm@11838: wenzelm@11838: (* wenzelm@11838: the following would be slightly more general, wenzelm@11838: but cannot be used as rewrite rule: wenzelm@11838: ### Cannot add premise as rewrite rule because it contains (type) unknowns: wenzelm@11838: ### ?y = .x wenzelm@11838: Goal "[| P y; !!x. P x ==> x = y |] ==> (@(x',y). x = x' & P y) = (x,y)" paulson@14208: by (rtac some_equality 1) paulson@14208: by ( Simp_tac 1) paulson@14208: by (split_all_tac 1) paulson@14208: by (Asm_full_simp_tac 1) wenzelm@11838: qed "The_split_eq"; wenzelm@11838: *) wenzelm@11838: wenzelm@11838: text {* wenzelm@11838: Setup of internal @{text split_rule}. wenzelm@11838: *} wenzelm@11838: haftmann@25511: definition haftmann@25511: internal_split :: "('a \ 'b \ 'c) \ 'a \ 'b \ 'c" haftmann@25511: where wenzelm@11032: "internal_split == split" wenzelm@11032: wenzelm@11032: lemma internal_split_conv: "internal_split c (a, b) = c a b" wenzelm@11032: by (simp only: internal_split_def split_conv) wenzelm@11032: wenzelm@35364: use "Tools/split_rule.ML" wenzelm@35364: setup SplitRule.setup wenzelm@35364: wenzelm@11032: hide const internal_split wenzelm@11032: nipkow@10213: haftmann@24699: lemmas prod_caseI = prod.cases [THEN iffD2, standard] haftmann@24699: haftmann@24699: lemma prod_caseI2: "!!p. [| !!a b. p = (a, b) ==> c a b |] ==> prod_case c p" haftmann@24699: by auto haftmann@24699: haftmann@24699: lemma prod_caseI2': "!!p. [| !!a b. (a, b) = p ==> c a b x |] ==> prod_case c p x" haftmann@24699: by (auto simp: split_tupled_all) haftmann@24699: haftmann@24699: lemma prod_caseE: "prod_case c p ==> (!!x y. p = (x, y) ==> c x y ==> Q) ==> Q" haftmann@24699: by (induct p) auto haftmann@24699: haftmann@24699: lemma prod_caseE': "prod_case c p z ==> (!!x y. p = (x, y) ==> c x y z ==> Q) ==> Q" haftmann@24699: by (induct p) auto haftmann@24699: haftmann@24699: lemma prod_case_unfold: "prod_case = (%c p. c (fst p) (snd p))" haftmann@24699: by (simp add: expand_fun_eq) haftmann@24699: haftmann@24699: declare prod_caseI2' [intro!] prod_caseI2 [intro!] prod_caseI [intro!] haftmann@24699: declare prod_caseE' [elim!] prod_caseE [elim!] haftmann@24699: haftmann@24844: lemma prod_case_split: haftmann@24699: "prod_case = split" haftmann@24699: by (auto simp add: expand_fun_eq) haftmann@24699: bulwahn@26143: lemma prod_case_beta: bulwahn@26143: "prod_case f p = f (fst p) (snd p)" bulwahn@26143: unfolding prod_case_split split_beta .. bulwahn@26143: haftmann@24699: haftmann@24699: subsection {* Further cases/induct rules for tuples *} haftmann@24699: haftmann@24699: lemma prod_cases3 [cases type]: haftmann@24699: obtains (fields) a b c where "y = (a, b, c)" haftmann@24699: by (cases y, case_tac b) blast haftmann@24699: haftmann@24699: lemma prod_induct3 [case_names fields, induct type]: haftmann@24699: "(!!a b c. P (a, b, c)) ==> P x" haftmann@24699: by (cases x) blast haftmann@24699: haftmann@24699: lemma prod_cases4 [cases type]: haftmann@24699: obtains (fields) a b c d where "y = (a, b, c, d)" haftmann@24699: by (cases y, case_tac c) blast haftmann@24699: haftmann@24699: lemma prod_induct4 [case_names fields, induct type]: haftmann@24699: "(!!a b c d. P (a, b, c, d)) ==> P x" haftmann@24699: by (cases x) blast haftmann@24699: haftmann@24699: lemma prod_cases5 [cases type]: haftmann@24699: obtains (fields) a b c d e where "y = (a, b, c, d, e)" haftmann@24699: by (cases y, case_tac d) blast haftmann@24699: haftmann@24699: lemma prod_induct5 [case_names fields, induct type]: haftmann@24699: "(!!a b c d e. P (a, b, c, d, e)) ==> P x" haftmann@24699: by (cases x) blast haftmann@24699: haftmann@24699: lemma prod_cases6 [cases type]: haftmann@24699: obtains (fields) a b c d e f where "y = (a, b, c, d, e, f)" haftmann@24699: by (cases y, case_tac e) blast haftmann@24699: haftmann@24699: lemma prod_induct6 [case_names fields, induct type]: haftmann@24699: "(!!a b c d e f. P (a, b, c, d, e, f)) ==> P x" haftmann@24699: by (cases x) blast haftmann@24699: haftmann@24699: lemma prod_cases7 [cases type]: haftmann@24699: obtains (fields) a b c d e f g where "y = (a, b, c, d, e, f, g)" haftmann@24699: by (cases y, case_tac f) blast haftmann@24699: haftmann@24699: lemma prod_induct7 [case_names fields, induct type]: haftmann@24699: "(!!a b c d e f g. P (a, b, c, d, e, f, g)) ==> P x" haftmann@24699: by (cases x) blast haftmann@24699: haftmann@24699: haftmann@26358: subsubsection {* Derived operations *} haftmann@26358: haftmann@26358: text {* haftmann@26358: The composition-uncurry combinator. haftmann@26358: *} haftmann@26358: haftmann@26588: notation fcomp (infixl "o>" 60) haftmann@26358: haftmann@26588: definition haftmann@26588: scomp :: "('a \ 'b \ 'c) \ ('b \ 'c \ 'd) \ 'a \ 'd" (infixl "o\" 60) haftmann@26588: where haftmann@26588: "f o\ g = (\x. split g (f x))" haftmann@26358: haftmann@26588: lemma scomp_apply: "(f o\ g) x = split g (f x)" haftmann@26588: by (simp add: scomp_def) haftmann@26358: haftmann@26588: lemma Pair_scomp: "Pair x o\ f = f x" haftmann@26588: by (simp add: expand_fun_eq scomp_apply) haftmann@26358: haftmann@26588: lemma scomp_Pair: "x o\ Pair = x" haftmann@26588: by (simp add: expand_fun_eq scomp_apply) haftmann@26358: haftmann@26588: lemma scomp_scomp: "(f o\ g) o\ h = f o\ (\x. g x o\ h)" haftmann@26588: by (simp add: expand_fun_eq split_twice scomp_def) haftmann@26358: haftmann@26588: lemma scomp_fcomp: "(f o\ g) o> h = f o\ (\x. g x o> h)" haftmann@26588: by (simp add: expand_fun_eq scomp_apply fcomp_def split_def) haftmann@26358: haftmann@26588: lemma fcomp_scomp: "(f o> g) o\ h = f o> (g o\ h)" haftmann@26588: by (simp add: expand_fun_eq scomp_apply fcomp_apply) haftmann@26358: haftmann@31202: code_const scomp haftmann@31202: (Eval infixl 3 "#->") haftmann@31202: haftmann@26588: no_notation fcomp (infixl "o>" 60) haftmann@26588: no_notation scomp (infixl "o\" 60) haftmann@26358: haftmann@26358: haftmann@26358: text {* haftmann@26358: @{term prod_fun} --- action of the product functor upon haftmann@31775: Datatypes. haftmann@26358: *} haftmann@21195: haftmann@26358: definition prod_fun :: "('a \ 'c) \ ('b \ 'd) \ 'a \ 'b \ 'c \ 'd" where haftmann@28562: [code del]: "prod_fun f g = (\(x, y). (f x, g y))" haftmann@26358: haftmann@28562: lemma prod_fun [simp, code]: "prod_fun f g (a, b) = (f a, g b)" haftmann@26358: by (simp add: prod_fun_def) haftmann@26358: haftmann@26358: lemma prod_fun_compose: "prod_fun (f1 o f2) (g1 o g2) = (prod_fun f1 g1 o prod_fun f2 g2)" haftmann@26358: by (rule ext) auto haftmann@26358: haftmann@26358: lemma prod_fun_ident [simp]: "prod_fun (%x. x) (%y. y) = (%z. z)" haftmann@26358: by (rule ext) auto haftmann@26358: haftmann@26358: lemma prod_fun_imageI [intro]: "(a, b) : r ==> (f a, g b) : prod_fun f g ` r" haftmann@26358: apply (rule image_eqI) haftmann@26358: apply (rule prod_fun [symmetric], assumption) haftmann@26358: done haftmann@21195: haftmann@26358: lemma prod_fun_imageE [elim!]: haftmann@26358: assumes major: "c: (prod_fun f g)`r" haftmann@26358: and cases: "!!x y. [| c=(f(x),g(y)); (x,y):r |] ==> P" haftmann@26358: shows P haftmann@26358: apply (rule major [THEN imageE]) haftmann@26358: apply (rule_tac p = x in PairE) haftmann@26358: apply (rule cases) haftmann@26358: apply (blast intro: prod_fun) haftmann@26358: apply blast haftmann@26358: done haftmann@26358: haftmann@26358: definition haftmann@26358: apfst :: "('a \ 'c) \ 'a \ 'b \ 'c \ 'b" haftmann@26358: where haftmann@28562: [code del]: "apfst f = prod_fun f id" haftmann@26358: haftmann@26358: definition haftmann@26358: apsnd :: "('b \ 'c) \ 'a \ 'b \ 'a \ 'c" haftmann@26358: where haftmann@28562: [code del]: "apsnd f = prod_fun id f" haftmann@26358: haftmann@26358: lemma apfst_conv [simp, code]: haftmann@26358: "apfst f (x, y) = (f x, y)" haftmann@26358: by (simp add: apfst_def) haftmann@26358: hoelzl@33638: lemma apsnd_conv [simp, code]: haftmann@26358: "apsnd f (x, y) = (x, f y)" haftmann@26358: by (simp add: apsnd_def) haftmann@21195: haftmann@33594: lemma fst_apfst [simp]: haftmann@33594: "fst (apfst f x) = f (fst x)" haftmann@33594: by (cases x) simp haftmann@33594: haftmann@33594: lemma fst_apsnd [simp]: haftmann@33594: "fst (apsnd f x) = fst x" haftmann@33594: by (cases x) simp haftmann@33594: haftmann@33594: lemma snd_apfst [simp]: haftmann@33594: "snd (apfst f x) = snd x" haftmann@33594: by (cases x) simp haftmann@33594: haftmann@33594: lemma snd_apsnd [simp]: haftmann@33594: "snd (apsnd f x) = f (snd x)" haftmann@33594: by (cases x) simp haftmann@33594: haftmann@33594: lemma apfst_compose: haftmann@33594: "apfst f (apfst g x) = apfst (f \ g) x" haftmann@33594: by (cases x) simp haftmann@33594: haftmann@33594: lemma apsnd_compose: haftmann@33594: "apsnd f (apsnd g x) = apsnd (f \ g) x" haftmann@33594: by (cases x) simp haftmann@33594: haftmann@33594: lemma apfst_apsnd [simp]: haftmann@33594: "apfst f (apsnd g x) = (f (fst x), g (snd x))" haftmann@33594: by (cases x) simp haftmann@33594: haftmann@33594: lemma apsnd_apfst [simp]: haftmann@33594: "apsnd f (apfst g x) = (g (fst x), f (snd x))" haftmann@33594: by (cases x) simp haftmann@33594: haftmann@33594: lemma apfst_id [simp] : haftmann@33594: "apfst id = id" haftmann@33594: by (simp add: expand_fun_eq) haftmann@33594: haftmann@33594: lemma apsnd_id [simp] : haftmann@33594: "apsnd id = id" haftmann@33594: by (simp add: expand_fun_eq) haftmann@33594: haftmann@33594: lemma apfst_eq_conv [simp]: haftmann@33594: "apfst f x = apfst g x \ f (fst x) = g (fst x)" haftmann@33594: by (cases x) simp haftmann@33594: haftmann@33594: lemma apsnd_eq_conv [simp]: haftmann@33594: "apsnd f x = apsnd g x \ f (snd x) = g (snd x)" haftmann@33594: by (cases x) simp haftmann@33594: hoelzl@33638: lemma apsnd_apfst_commute: hoelzl@33638: "apsnd f (apfst g p) = apfst g (apsnd f p)" hoelzl@33638: by simp haftmann@21195: haftmann@26358: text {* haftmann@26358: Disjoint union of a family of sets -- Sigma. haftmann@26358: *} haftmann@26358: haftmann@26358: definition Sigma :: "['a set, 'a => 'b set] => ('a \ 'b) set" where haftmann@26358: Sigma_def: "Sigma A B == UN x:A. UN y:B x. {Pair x y}" haftmann@26358: haftmann@26358: abbreviation haftmann@26358: Times :: "['a set, 'b set] => ('a * 'b) set" haftmann@26358: (infixr "<*>" 80) where haftmann@26358: "A <*> B == Sigma A (%_. B)" haftmann@26358: haftmann@26358: notation (xsymbols) haftmann@26358: Times (infixr "\" 80) berghofe@15394: haftmann@26358: notation (HTML output) haftmann@26358: Times (infixr "\" 80) haftmann@26358: haftmann@26358: syntax wenzelm@35115: "_Sigma" :: "[pttrn, 'a set, 'b set] => ('a * 'b) set" ("(3SIGMA _:_./ _)" [0, 0, 10] 10) haftmann@26358: translations wenzelm@35115: "SIGMA x:A. B" == "CONST Sigma A (%x. B)" haftmann@26358: haftmann@26358: lemma SigmaI [intro!]: "[| a:A; b:B(a) |] ==> (a,b) : Sigma A B" haftmann@26358: by (unfold Sigma_def) blast haftmann@26358: haftmann@26358: lemma SigmaE [elim!]: haftmann@26358: "[| c: Sigma A B; haftmann@26358: !!x y.[| x:A; y:B(x); c=(x,y) |] ==> P haftmann@26358: |] ==> P" haftmann@26358: -- {* The general elimination rule. *} haftmann@26358: by (unfold Sigma_def) blast haftmann@20588: haftmann@26358: text {* haftmann@26358: Elimination of @{term "(a, b) : A \ B"} -- introduces no haftmann@26358: eigenvariables. haftmann@26358: *} haftmann@26358: haftmann@26358: lemma SigmaD1: "(a, b) : Sigma A B ==> a : A" haftmann@26358: by blast haftmann@26358: haftmann@26358: lemma SigmaD2: "(a, b) : Sigma A B ==> b : B a" haftmann@26358: by blast haftmann@26358: haftmann@26358: lemma SigmaE2: haftmann@26358: "[| (a, b) : Sigma A B; haftmann@26358: [| a:A; b:B(a) |] ==> P haftmann@26358: |] ==> P" haftmann@26358: by blast haftmann@20588: haftmann@26358: lemma Sigma_cong: haftmann@26358: "\A = B; !!x. x \ B \ C x = D x\ haftmann@26358: \ (SIGMA x: A. C x) = (SIGMA x: B. D x)" haftmann@26358: by auto haftmann@26358: haftmann@26358: lemma Sigma_mono: "[| A <= C; !!x. x:A ==> B x <= D x |] ==> Sigma A B <= Sigma C D" haftmann@26358: by blast haftmann@26358: haftmann@26358: lemma Sigma_empty1 [simp]: "Sigma {} B = {}" haftmann@26358: by blast haftmann@26358: haftmann@26358: lemma Sigma_empty2 [simp]: "A <*> {} = {}" haftmann@26358: by blast haftmann@26358: haftmann@26358: lemma UNIV_Times_UNIV [simp]: "UNIV <*> UNIV = UNIV" haftmann@26358: by auto haftmann@21908: haftmann@26358: lemma Compl_Times_UNIV1 [simp]: "- (UNIV <*> A) = UNIV <*> (-A)" haftmann@26358: by auto haftmann@26358: haftmann@26358: lemma Compl_Times_UNIV2 [simp]: "- (A <*> UNIV) = (-A) <*> UNIV" haftmann@26358: by auto haftmann@26358: haftmann@26358: lemma mem_Sigma_iff [iff]: "((a,b): Sigma A B) = (a:A & b:B(a))" haftmann@26358: by blast haftmann@26358: haftmann@26358: lemma Times_subset_cancel2: "x:C ==> (A <*> C <= B <*> C) = (A <= B)" haftmann@26358: by blast haftmann@26358: haftmann@26358: lemma Times_eq_cancel2: "x:C ==> (A <*> C = B <*> C) = (A = B)" haftmann@26358: by (blast elim: equalityE) haftmann@20588: haftmann@26358: lemma SetCompr_Sigma_eq: haftmann@26358: "Collect (split (%x y. P x & Q x y)) = (SIGMA x:Collect P. Collect (Q x))" haftmann@26358: by blast haftmann@26358: haftmann@26358: lemma Collect_split [simp]: "{(a,b). P a & Q b} = Collect P <*> Collect Q" haftmann@26358: by blast haftmann@26358: haftmann@26358: lemma UN_Times_distrib: haftmann@26358: "(UN (a,b):(A <*> B). E a <*> F b) = (UNION A E) <*> (UNION B F)" haftmann@26358: -- {* Suggested by Pierre Chartier *} haftmann@26358: by blast haftmann@26358: haftmann@26358: lemma split_paired_Ball_Sigma [simp,noatp]: haftmann@26358: "(ALL z: Sigma A B. P z) = (ALL x:A. ALL y: B x. P(x,y))" haftmann@26358: by blast haftmann@26358: haftmann@26358: lemma split_paired_Bex_Sigma [simp,noatp]: haftmann@26358: "(EX z: Sigma A B. P z) = (EX x:A. EX y: B x. P(x,y))" haftmann@26358: by blast haftmann@21908: haftmann@26358: lemma Sigma_Un_distrib1: "(SIGMA i:I Un J. C(i)) = (SIGMA i:I. C(i)) Un (SIGMA j:J. C(j))" haftmann@26358: by blast haftmann@26358: haftmann@26358: lemma Sigma_Un_distrib2: "(SIGMA i:I. A(i) Un B(i)) = (SIGMA i:I. A(i)) Un (SIGMA i:I. B(i))" haftmann@26358: by blast haftmann@26358: haftmann@26358: lemma Sigma_Int_distrib1: "(SIGMA i:I Int J. C(i)) = (SIGMA i:I. C(i)) Int (SIGMA j:J. C(j))" haftmann@26358: by blast haftmann@26358: haftmann@26358: lemma Sigma_Int_distrib2: "(SIGMA i:I. A(i) Int B(i)) = (SIGMA i:I. A(i)) Int (SIGMA i:I. B(i))" haftmann@26358: by blast haftmann@26358: haftmann@26358: lemma Sigma_Diff_distrib1: "(SIGMA i:I - J. C(i)) = (SIGMA i:I. C(i)) - (SIGMA j:J. C(j))" haftmann@26358: by blast haftmann@26358: haftmann@26358: lemma Sigma_Diff_distrib2: "(SIGMA i:I. A(i) - B(i)) = (SIGMA i:I. A(i)) - (SIGMA i:I. B(i))" haftmann@26358: by blast haftmann@21908: haftmann@26358: lemma Sigma_Union: "Sigma (Union X) B = (UN A:X. Sigma A B)" haftmann@26358: by blast haftmann@26358: haftmann@26358: text {* haftmann@26358: Non-dependent versions are needed to avoid the need for higher-order haftmann@26358: matching, especially when the rules are re-oriented. haftmann@26358: *} haftmann@21908: haftmann@26358: lemma Times_Un_distrib1: "(A Un B) <*> C = (A <*> C) Un (B <*> C)" nipkow@28719: by blast haftmann@26358: haftmann@26358: lemma Times_Int_distrib1: "(A Int B) <*> C = (A <*> C) Int (B <*> C)" nipkow@28719: by blast haftmann@26358: haftmann@26358: lemma Times_Diff_distrib1: "(A - B) <*> C = (A <*> C) - (B <*> C)" nipkow@28719: by blast haftmann@26358: nipkow@28719: lemma insert_times_insert[simp]: nipkow@28719: "insert a A \ insert b B = nipkow@28719: insert (a,b) (A \ insert b B \ insert a A \ B)" nipkow@28719: by blast haftmann@26358: paulson@33271: lemma vimage_Times: "f -` (A \ B) = ((fst \ f) -` A) \ ((snd \ f) -` B)" paulson@33271: by (auto, rule_tac p = "f x" in PairE, auto) paulson@33271: haftmann@26358: subsubsection {* Code generator setup *} haftmann@21908: haftmann@28562: lemma [code]: haftmann@28346: "eq_class.eq (x1\'a\eq, y1\'b\eq) (x2, y2) \ x1 = x2 \ y1 = y2" by (simp add: eq) haftmann@20588: haftmann@24844: lemma split_case_cert: haftmann@24844: assumes "CASE \ split f" haftmann@24844: shows "CASE (a, b) \ f a b" haftmann@24844: using assms by simp haftmann@24844: haftmann@24844: setup {* haftmann@24844: Code.add_case @{thm split_case_cert} haftmann@24844: *} haftmann@24844: haftmann@21908: code_type * haftmann@21908: (SML infix 2 "*") haftmann@21908: (OCaml infix 2 "*") haftmann@21908: (Haskell "!((_),/ (_))") haftmann@34900: (Scala "((_),/ (_))") haftmann@21908: haftmann@20588: code_instance * :: eq haftmann@20588: (Haskell -) haftmann@20588: haftmann@28346: code_const "eq_class.eq \ 'a\eq \ 'b\eq \ 'a \ 'b \ bool" haftmann@20588: (Haskell infixl 4 "==") haftmann@20588: haftmann@21908: code_const Pair haftmann@21908: (SML "!((_),/ (_))") haftmann@21908: (OCaml "!((_),/ (_))") haftmann@21908: (Haskell "!((_),/ (_))") haftmann@34886: (Scala "!((_),/ (_))") haftmann@20588: haftmann@22389: code_const fst and snd haftmann@22389: (Haskell "fst" and "snd") haftmann@22389: berghofe@15394: types_code berghofe@15394: "*" ("(_ */ _)") berghofe@16770: attach (term_of) {* berghofe@25885: fun term_of_id_42 aF aT bF bT (x, y) = HOLogic.pair_const aT bT $ aF x $ bF y; berghofe@16770: *} berghofe@16770: attach (test) {* berghofe@25885: fun gen_id_42 aG aT bG bT i = berghofe@25885: let berghofe@25885: val (x, t) = aG i; berghofe@25885: val (y, u) = bG i berghofe@25885: in ((x, y), fn () => HOLogic.pair_const aT bT $ t () $ u ()) end; berghofe@16770: *} berghofe@15394: berghofe@18706: consts_code berghofe@18706: "Pair" ("(_,/ _)") berghofe@18706: haftmann@21908: setup {* haftmann@21908: let haftmann@18013: haftmann@19039: fun strip_abs_split 0 t = ([], t) haftmann@19039: | strip_abs_split i (Abs (s, T, t)) = haftmann@18013: let haftmann@18013: val s' = Codegen.new_name t s; haftmann@18013: val v = Free (s', T) haftmann@19039: in apfst (cons v) (strip_abs_split (i-1) (subst_bound (v, t))) end wenzelm@35364: | strip_abs_split i (u as Const (@{const_name split}, _) $ t) = wenzelm@35364: (case strip_abs_split (i+1) t of berghofe@15394: (v :: v' :: vs, u) => (HOLogic.mk_prod (v, v') :: vs, u) berghofe@15394: | _ => ([], u)) berghofe@30604: | strip_abs_split i t = berghofe@30604: strip_abs_split i (Abs ("x", hd (binder_types (fastype_of t)), t $ Bound 0)); haftmann@18013: wenzelm@35364: fun let_codegen thy defs dep thyname brack t gr = wenzelm@35364: (case strip_comb t of wenzelm@35364: (t1 as Const (@{const_name Let}, _), t2 :: t3 :: ts) => berghofe@15394: let wenzelm@35364: fun dest_let (l as Const (@{const_name Let}, _) $ t $ u) = haftmann@19039: (case strip_abs_split 1 u of berghofe@15394: ([p], u') => apfst (cons (p, t)) (dest_let u') berghofe@15394: | _ => ([], l)) berghofe@15394: | dest_let t = ([], t); haftmann@28537: fun mk_code (l, r) gr = berghofe@15394: let haftmann@28537: val (pl, gr1) = Codegen.invoke_codegen thy defs dep thyname false l gr; haftmann@28537: val (pr, gr2) = Codegen.invoke_codegen thy defs dep thyname false r gr1; haftmann@28537: in ((pl, pr), gr2) end berghofe@16634: in case dest_let (t1 $ t2 $ t3) of skalberg@15531: ([], _) => NONE berghofe@15394: | (ps, u) => berghofe@15394: let haftmann@28537: val (qs, gr1) = fold_map mk_code ps gr; haftmann@28537: val (pu, gr2) = Codegen.invoke_codegen thy defs dep thyname false u gr1; haftmann@28537: val (pargs, gr3) = fold_map haftmann@28537: (Codegen.invoke_codegen thy defs dep thyname true) ts gr2 berghofe@15394: in haftmann@28537: SOME (Codegen.mk_app brack wenzelm@32952: (Pretty.blk (0, [Codegen.str "let ", Pretty.blk (0, flat berghofe@26975: (separate [Codegen.str ";", Pretty.brk 1] (map (fn (pl, pr) => berghofe@26975: [Pretty.block [Codegen.str "val ", pl, Codegen.str " =", berghofe@16634: Pretty.brk 1, pr]]) qs))), berghofe@26975: Pretty.brk 1, Codegen.str "in ", pu, haftmann@28537: Pretty.brk 1, Codegen.str "end"])) pargs, gr3) berghofe@15394: end berghofe@15394: end berghofe@16634: | _ => NONE); berghofe@15394: haftmann@28537: fun split_codegen thy defs dep thyname brack t gr = (case strip_comb t of wenzelm@35364: (t1 as Const (@{const_name split}, _), t2 :: ts) => berghofe@30604: let berghofe@30604: val ([p], u) = strip_abs_split 1 (t1 $ t2); berghofe@30604: val (q, gr1) = Codegen.invoke_codegen thy defs dep thyname false p gr; berghofe@30604: val (pu, gr2) = Codegen.invoke_codegen thy defs dep thyname false u gr1; berghofe@30604: val (pargs, gr3) = fold_map berghofe@30604: (Codegen.invoke_codegen thy defs dep thyname true) ts gr2 berghofe@30604: in berghofe@30604: SOME (Codegen.mk_app brack berghofe@30604: (Pretty.block [Codegen.str "(fn ", q, Codegen.str " =>", berghofe@30604: Pretty.brk 1, pu, Codegen.str ")"]) pargs, gr2) berghofe@30604: end berghofe@16634: | _ => NONE); berghofe@15394: haftmann@21908: in haftmann@21908: haftmann@20105: Codegen.add_codegen "let_codegen" let_codegen haftmann@20105: #> Codegen.add_codegen "split_codegen" split_codegen berghofe@15394: haftmann@21908: end berghofe@15394: *} berghofe@15394: haftmann@24699: haftmann@24699: subsection {* Legacy bindings *} haftmann@24699: haftmann@21908: ML {* paulson@15404: val Collect_split = thm "Collect_split"; paulson@15404: val Compl_Times_UNIV1 = thm "Compl_Times_UNIV1"; paulson@15404: val Compl_Times_UNIV2 = thm "Compl_Times_UNIV2"; paulson@15404: val PairE = thm "PairE"; paulson@15404: val Pair_Rep_inject = thm "Pair_Rep_inject"; paulson@15404: val Pair_def = thm "Pair_def"; haftmann@27104: val Pair_eq = @{thm "prod.inject"}; paulson@15404: val Pair_fst_snd_eq = thm "Pair_fst_snd_eq"; paulson@15404: val ProdI = thm "ProdI"; paulson@15404: val SetCompr_Sigma_eq = thm "SetCompr_Sigma_eq"; paulson@15404: val SigmaD1 = thm "SigmaD1"; paulson@15404: val SigmaD2 = thm "SigmaD2"; paulson@15404: val SigmaE = thm "SigmaE"; paulson@15404: val SigmaE2 = thm "SigmaE2"; paulson@15404: val SigmaI = thm "SigmaI"; paulson@15404: val Sigma_Diff_distrib1 = thm "Sigma_Diff_distrib1"; paulson@15404: val Sigma_Diff_distrib2 = thm "Sigma_Diff_distrib2"; paulson@15404: val Sigma_Int_distrib1 = thm "Sigma_Int_distrib1"; paulson@15404: val Sigma_Int_distrib2 = thm "Sigma_Int_distrib2"; paulson@15404: val Sigma_Un_distrib1 = thm "Sigma_Un_distrib1"; paulson@15404: val Sigma_Un_distrib2 = thm "Sigma_Un_distrib2"; paulson@15404: val Sigma_Union = thm "Sigma_Union"; paulson@15404: val Sigma_def = thm "Sigma_def"; paulson@15404: val Sigma_empty1 = thm "Sigma_empty1"; paulson@15404: val Sigma_empty2 = thm "Sigma_empty2"; paulson@15404: val Sigma_mono = thm "Sigma_mono"; paulson@15404: val The_split = thm "The_split"; paulson@15404: val The_split_eq = thm "The_split_eq"; paulson@15404: val The_split_eq = thm "The_split_eq"; paulson@15404: val Times_Diff_distrib1 = thm "Times_Diff_distrib1"; paulson@15404: val Times_Int_distrib1 = thm "Times_Int_distrib1"; paulson@15404: val Times_Un_distrib1 = thm "Times_Un_distrib1"; paulson@15404: val Times_eq_cancel2 = thm "Times_eq_cancel2"; paulson@15404: val Times_subset_cancel2 = thm "Times_subset_cancel2"; paulson@15404: val UNIV_Times_UNIV = thm "UNIV_Times_UNIV"; paulson@15404: val UN_Times_distrib = thm "UN_Times_distrib"; paulson@15404: val Unity_def = thm "Unity_def"; paulson@15404: val cond_split_eta = thm "cond_split_eta"; paulson@15404: val fst_conv = thm "fst_conv"; paulson@15404: val fst_def = thm "fst_def"; paulson@15404: val fst_eqD = thm "fst_eqD"; paulson@15404: val inj_on_Abs_Prod = thm "inj_on_Abs_Prod"; paulson@15404: val mem_Sigma_iff = thm "mem_Sigma_iff"; paulson@15404: val mem_splitE = thm "mem_splitE"; paulson@15404: val mem_splitI = thm "mem_splitI"; paulson@15404: val mem_splitI2 = thm "mem_splitI2"; paulson@15404: val prod_eqI = thm "prod_eqI"; paulson@15404: val prod_fun = thm "prod_fun"; paulson@15404: val prod_fun_compose = thm "prod_fun_compose"; paulson@15404: val prod_fun_def = thm "prod_fun_def"; paulson@15404: val prod_fun_ident = thm "prod_fun_ident"; paulson@15404: val prod_fun_imageE = thm "prod_fun_imageE"; paulson@15404: val prod_fun_imageI = thm "prod_fun_imageI"; haftmann@27104: val prod_induct = thm "prod.induct"; paulson@15404: val snd_conv = thm "snd_conv"; paulson@15404: val snd_def = thm "snd_def"; paulson@15404: val snd_eqD = thm "snd_eqD"; paulson@15404: val split = thm "split"; paulson@15404: val splitD = thm "splitD"; paulson@15404: val splitD' = thm "splitD'"; paulson@15404: val splitE = thm "splitE"; paulson@15404: val splitE' = thm "splitE'"; paulson@15404: val splitE2 = thm "splitE2"; paulson@15404: val splitI = thm "splitI"; paulson@15404: val splitI2 = thm "splitI2"; paulson@15404: val splitI2' = thm "splitI2'"; paulson@15404: val split_beta = thm "split_beta"; paulson@15404: val split_conv = thm "split_conv"; paulson@15404: val split_def = thm "split_def"; paulson@15404: val split_eta = thm "split_eta"; paulson@15404: val split_eta_SetCompr = thm "split_eta_SetCompr"; paulson@15404: val split_eta_SetCompr2 = thm "split_eta_SetCompr2"; paulson@15404: val split_paired_All = thm "split_paired_All"; paulson@15404: val split_paired_Ball_Sigma = thm "split_paired_Ball_Sigma"; paulson@15404: val split_paired_Bex_Sigma = thm "split_paired_Bex_Sigma"; paulson@15404: val split_paired_Ex = thm "split_paired_Ex"; paulson@15404: val split_paired_The = thm "split_paired_The"; paulson@15404: val split_paired_all = thm "split_paired_all"; paulson@15404: val split_part = thm "split_part"; paulson@15404: val split_split = thm "split_split"; paulson@15404: val split_split_asm = thm "split_split_asm"; paulson@15404: val split_tupled_all = thms "split_tupled_all"; paulson@15404: val split_weak_cong = thm "split_weak_cong"; paulson@15404: val surj_pair = thm "surj_pair"; paulson@15404: val surjective_pairing = thm "surjective_pairing"; paulson@15404: val unit_abs_eta_conv = thm "unit_abs_eta_conv"; paulson@15404: val unit_all_eq1 = thm "unit_all_eq1"; paulson@15404: val unit_all_eq2 = thm "unit_all_eq2"; paulson@15404: val unit_eq = thm "unit_eq"; paulson@15404: *} paulson@15404: haftmann@31723: use "Tools/inductive_set.ML" haftmann@31723: setup Inductive_Set.setup haftmann@24699: nipkow@10213: end