src/HOL/BNF_Comp.thy
author blanchet
Mon Mar 03 12:48:20 2014 +0100 (2014-03-03)
changeset 55854 ee270328a781
parent 55851 3d40cf74726c
child 55855 98ad5680173a
permissions -rw-r--r--
make 'typedef' optional, depending on size of original type
blanchet@55059
     1
(*  Title:      HOL/BNF_Comp.thy
blanchet@48975
     2
    Author:     Dmitriy Traytel, TU Muenchen
blanchet@48975
     3
    Copyright   2012
blanchet@48975
     4
blanchet@48975
     5
Composition of bounded natural functors.
blanchet@48975
     6
*)
blanchet@48975
     7
blanchet@48975
     8
header {* Composition of Bounded Natural Functors *}
blanchet@48975
     9
blanchet@48975
    10
theory BNF_Comp
blanchet@48975
    11
imports Basic_BNFs
blanchet@48975
    12
begin
blanchet@48975
    13
blanchet@49312
    14
lemma empty_natural: "(\<lambda>_. {}) o f = image g o (\<lambda>_. {})"
blanchet@49312
    15
by (rule ext) simp
blanchet@49312
    16
blanchet@49312
    17
lemma Union_natural: "Union o image (image f) = image f o Union"
blanchet@55066
    18
by (rule ext) (auto simp only: comp_apply)
blanchet@49312
    19
blanchet@49312
    20
lemma in_Union_o_assoc: "x \<in> (Union o gset o gmap) A \<Longrightarrow> x \<in> (Union o (gset o gmap)) A"
blanchet@55066
    21
by (unfold comp_assoc)
blanchet@49312
    22
blanchet@49312
    23
lemma comp_single_set_bd:
blanchet@49312
    24
  assumes fbd_Card_order: "Card_order fbd" and
blanchet@49312
    25
    fset_bd: "\<And>x. |fset x| \<le>o fbd" and
blanchet@49312
    26
    gset_bd: "\<And>x. |gset x| \<le>o gbd"
haftmann@52141
    27
  shows "|\<Union>(fset ` gset x)| \<le>o gbd *c fbd"
blanchet@49312
    28
apply (subst sym[OF SUP_def])
blanchet@49312
    29
apply (rule ordLeq_transitive)
blanchet@49312
    30
apply (rule card_of_UNION_Sigma)
blanchet@49312
    31
apply (subst SIGMA_CSUM)
blanchet@49312
    32
apply (rule ordLeq_transitive)
blanchet@49312
    33
apply (rule card_of_Csum_Times')
blanchet@49312
    34
apply (rule fbd_Card_order)
blanchet@49312
    35
apply (rule ballI)
blanchet@49312
    36
apply (rule fset_bd)
blanchet@49312
    37
apply (rule ordLeq_transitive)
blanchet@49312
    38
apply (rule cprod_mono1)
blanchet@49312
    39
apply (rule gset_bd)
blanchet@49312
    40
apply (rule ordIso_imp_ordLeq)
blanchet@49312
    41
apply (rule ordIso_refl)
blanchet@49312
    42
apply (rule Card_order_cprod)
blanchet@49312
    43
done
blanchet@49312
    44
haftmann@52141
    45
lemma Union_image_insert: "\<Union>(f ` insert a B) = f a \<union> \<Union>(f ` B)"
blanchet@49312
    46
by simp
blanchet@49312
    47
haftmann@52141
    48
lemma Union_image_empty: "A \<union> \<Union>(f ` {}) = A"
blanchet@49312
    49
by simp
blanchet@49312
    50
blanchet@49312
    51
lemma image_o_collect: "collect ((\<lambda>f. image g o f) ` F) = image g o collect F"
blanchet@49312
    52
by (rule ext) (auto simp add: collect_def)
blanchet@49312
    53
blanchet@49312
    54
lemma conj_subset_def: "A \<subseteq> {x. P x \<and> Q x} = (A \<subseteq> {x. P x} \<and> A \<subseteq> {x. Q x})"
blanchet@49312
    55
by blast
blanchet@49312
    56
haftmann@52141
    57
lemma UN_image_subset: "\<Union>(f ` g x) \<subseteq> X = (g x \<subseteq> {x. f x \<subseteq> X})"
blanchet@49312
    58
by blast
blanchet@49312
    59
haftmann@52141
    60
lemma comp_set_bd_Union_o_collect: "|\<Union>\<Union>((\<lambda>f. f x) ` X)| \<le>o hbd \<Longrightarrow> |(Union \<circ> collect X) x| \<le>o hbd"
blanchet@55066
    61
by (unfold comp_apply collect_def SUP_def)
blanchet@49312
    62
blanchet@49312
    63
lemma wpull_cong:
blanchet@49312
    64
"\<lbrakk>A' = A; B1' = B1; B2' = B2; wpull A B1 B2 f1 f2 p1 p2\<rbrakk> \<Longrightarrow> wpull A' B1' B2' f1 f2 p1 p2"
blanchet@49312
    65
by simp
blanchet@49312
    66
traytel@51893
    67
lemma Grp_fst_snd: "(Grp (Collect (split R)) fst)^--1 OO Grp (Collect (split R)) snd = R"
traytel@51893
    68
unfolding Grp_def fun_eq_iff relcompp.simps by auto
traytel@51893
    69
traytel@51893
    70
lemma OO_Grp_cong: "A = B \<Longrightarrow> (Grp A f)^--1 OO Grp A g = (Grp B f)^--1 OO Grp B g"
blanchet@55705
    71
by (rule arg_cong)
traytel@51893
    72
traytel@55803
    73
lemma vimage2p_relcompp_mono: "R OO S \<le> T \<Longrightarrow>
traytel@55803
    74
  vimage2p f g R OO vimage2p g h S \<le> vimage2p f h T"
traytel@55803
    75
  unfolding vimage2p_def by auto
traytel@55803
    76
traytel@55803
    77
lemma type_copy_map_cong0: "M (g x) = N (h x) \<Longrightarrow> (f o M o g) x = (f o N o h) x"
traytel@55803
    78
  by auto
traytel@55803
    79
traytel@55803
    80
lemma type_copy_set_bd: "(\<And>y. |S y| \<le>o bd) \<Longrightarrow> |(S o Rep) x| \<le>o bd"
traytel@55803
    81
  by auto
traytel@55803
    82
traytel@55803
    83
lemma vimage2p_cong: "R = S \<Longrightarrow> vimage2p f g R = vimage2p f g S"
traytel@55803
    84
  by simp
traytel@55803
    85
traytel@55803
    86
context
traytel@55803
    87
fixes Rep Abs
traytel@55803
    88
assumes type_copy: "type_definition Rep Abs UNIV"
traytel@55803
    89
begin
traytel@55803
    90
traytel@55803
    91
lemma type_copy_map_id0: "M = id \<Longrightarrow> Abs o M o Rep = id"
traytel@55803
    92
  using type_definition.Rep_inverse[OF type_copy] by auto
traytel@55811
    93
traytel@55803
    94
lemma type_copy_map_comp0: "M = M1 o M2 \<Longrightarrow> f o M o g = (f o M1 o Rep) o (Abs o M2 o g)"
traytel@55803
    95
  using type_definition.Abs_inverse[OF type_copy UNIV_I] by auto
traytel@55811
    96
traytel@55803
    97
lemma type_copy_set_map0: "S o M = image f o S' \<Longrightarrow> (S o Rep) o (Abs o M o g) = image f o (S' o g)"
traytel@55803
    98
  using type_definition.Abs_inverse[OF type_copy UNIV_I] by (auto simp: o_def fun_eq_iff)
traytel@55811
    99
traytel@55803
   100
lemma type_copy_wit: "x \<in> (S o Rep) (Abs y) \<Longrightarrow> x \<in> S y"
traytel@55803
   101
  using type_definition.Abs_inverse[OF type_copy UNIV_I] by auto
traytel@55811
   102
traytel@55803
   103
lemma type_copy_vimage2p_Grp_Rep: "vimage2p f Rep (Grp (Collect P) h) =
traytel@55803
   104
    Grp (Collect (\<lambda>x. P (f x))) (Abs o h o f)"
traytel@55803
   105
  unfolding vimage2p_def Grp_def fun_eq_iff
traytel@55803
   106
  by (auto simp: type_definition.Abs_inverse[OF type_copy UNIV_I]
traytel@55803
   107
   type_definition.Rep_inverse[OF type_copy] dest: sym)
traytel@55811
   108
traytel@55803
   109
lemma type_copy_vimage2p_Grp_Abs:
traytel@55803
   110
  "\<And>h. vimage2p g Abs (Grp (Collect P) h) = Grp (Collect (\<lambda>x. P (g x))) (Rep o h o g)"
traytel@55803
   111
  unfolding vimage2p_def Grp_def fun_eq_iff
traytel@55803
   112
  by (auto simp: type_definition.Abs_inverse[OF type_copy UNIV_I]
traytel@55803
   113
   type_definition.Rep_inverse[OF type_copy] dest: sym)
traytel@55811
   114
traytel@55811
   115
lemma type_copy_ex_RepI: "(\<exists>b. F b) = (\<exists>b. F (Rep b))"
traytel@55811
   116
proof safe
traytel@55811
   117
  fix b assume "F b"
traytel@55811
   118
  show "\<exists>b'. F (Rep b')"
traytel@55811
   119
  proof (rule exI)
traytel@55811
   120
    from `F b` show "F (Rep (Abs b))" using type_definition.Abs_inverse[OF type_copy] by auto
traytel@55811
   121
  qed
traytel@55811
   122
qed blast
traytel@55811
   123
traytel@55803
   124
lemma vimage2p_relcompp_converse:
traytel@55803
   125
  "vimage2p f g (R^--1 OO S) = (vimage2p Rep f R)^--1 OO vimage2p Rep g S"
traytel@55803
   126
  unfolding vimage2p_def relcompp.simps conversep.simps fun_eq_iff image_def
traytel@55811
   127
  by (auto simp: type_copy_ex_RepI)
traytel@55803
   128
traytel@55803
   129
end
traytel@55803
   130
blanchet@55854
   131
definition id_rep :: "'a \<Rightarrow> 'a" where "id_rep = (\<lambda>x. x)"
blanchet@55854
   132
definition id_abs :: "'a \<Rightarrow> 'a" where "id_abs = (\<lambda>x. x)"
blanchet@55854
   133
blanchet@55854
   134
lemma type_definition_id_rep_abs_UNIV: "type_definition id_rep id_abs UNIV"
blanchet@55854
   135
  unfolding id_rep_def id_abs_def by unfold_locales auto
blanchet@55854
   136
blanchet@55851
   137
lemma csum_dup: "cinfinite r \<Longrightarrow> Card_order r \<Longrightarrow> p +c p' =o r +c r \<Longrightarrow> p +c p' =o r"
blanchet@55851
   138
by (metis csum_absorb2' ordIso_transitive ordLeq_refl)
blanchet@55851
   139
blanchet@55851
   140
lemma cprod_dup: "cinfinite r \<Longrightarrow> Card_order r \<Longrightarrow> p *c p' =o r *c r \<Longrightarrow> p *c p' =o r"
blanchet@55851
   141
by (metis cprod_infinite ordIso_transitive)
blanchet@55851
   142
blanchet@55062
   143
ML_file "Tools/BNF/bnf_comp_tactics.ML"
blanchet@55062
   144
ML_file "Tools/BNF/bnf_comp.ML"
blanchet@49309
   145
blanchet@55854
   146
hide_const id_rep id_abs
blanchet@55854
   147
hide_fact id_rep_def id_abs_def type_definition_id_rep_abs_UNIV
blanchet@55854
   148
blanchet@48975
   149
end