src/HOL/Codatatype/BNF_Library.thy
author blanchet
Mon Sep 10 17:35:53 2012 +0200 (2012-09-10)
changeset 49255 2ecc533d6697
parent 49125 5fc5211cf104
child 49263 669a820ef213
permissions -rw-r--r--
use balanced sums for constructors (to gracefully handle 100 constructors or more)
blanchet@48975
     1
(*  Title:      HOL/Codatatype/BNF_Library.thy
blanchet@48975
     2
    Author:     Dmitriy Traytel, TU Muenchen
blanchet@48975
     3
    Copyright   2012
blanchet@48975
     4
blanchet@48975
     5
Library for bounded natural functors.
blanchet@48975
     6
*)
blanchet@48975
     7
blanchet@48975
     8
header {* Library for Bounded Natural Functors *}
blanchet@48975
     9
blanchet@48975
    10
theory BNF_Library
Christian@49090
    11
imports
Christian@49090
    12
  "../Ordinals_and_Cardinals/Cardinal_Arithmetic"
Christian@49090
    13
  "~~/src/HOL/Library/Prefix_Order"
blanchet@48979
    14
  Equiv_Relations_More
blanchet@48975
    15
begin
blanchet@48975
    16
blanchet@49116
    17
lemma iffI_np: "\<lbrakk>x \<Longrightarrow> \<not> y; \<not> x \<Longrightarrow> y\<rbrakk> \<Longrightarrow> \<not> x \<longleftrightarrow> y"
blanchet@49116
    18
by (erule iffI) (erule contrapos_pn)
blanchet@49116
    19
blanchet@49125
    20
lemma all_unit_eq: "(\<And>x. PROP P x) \<equiv> PROP P ()" by simp
blanchet@49125
    21
blanchet@49255
    22
lemma all_prod_eq: "(\<And>x. PROP P x) \<equiv> (\<And>a b. PROP P (a, b))" by clarsimp
blanchet@49125
    23
blanchet@49125
    24
lemma False_imp_eq: "(False \<Longrightarrow> P) \<equiv> Trueprop True"
blanchet@49125
    25
by presburger
blanchet@49125
    26
blanchet@49125
    27
lemma case_unit: "(case u of () => f) = f"
blanchet@49125
    28
by (cases u) (hypsubst, rule unit.cases)
blanchet@49125
    29
blanchet@49125
    30
lemma All_point_1: "(\<And>z. z = b \<Longrightarrow> phi z) \<equiv> Trueprop (phi b)"
blanchet@49125
    31
by presburger
blanchet@49125
    32
blanchet@48975
    33
lemma subset_Collect_iff: "B \<subseteq> A \<Longrightarrow> (B \<subseteq> {x \<in> A. P x}) = (\<forall>x \<in> B. P x)"
blanchet@48975
    34
by blast
blanchet@48975
    35
blanchet@48975
    36
lemma subset_CollectI: "B \<subseteq> A \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> Q x \<Longrightarrow> P x) \<Longrightarrow> ({x \<in> B. Q x} \<subseteq> {x \<in> A. P x})"
blanchet@48975
    37
by blast
blanchet@48975
    38
blanchet@48975
    39
lemma mem_Collect_eq_split: "{(x, y). (x, y) \<in> X} = X"
blanchet@48975
    40
by simp
blanchet@48975
    41
blanchet@48975
    42
lemma image_comp: "image (f o g) = image f o image g"
blanchet@48975
    43
by (rule ext) (auto simp only: o_apply image_def)
blanchet@48975
    44
blanchet@48975
    45
lemma empty_natural: "(\<lambda>_. {}) o f = image g o (\<lambda>_. {})"
blanchet@48975
    46
by (rule ext) simp
blanchet@48975
    47
blanchet@48975
    48
lemma Union_natural: "Union o image (image f) = image f o Union"
blanchet@48975
    49
by (rule ext) (auto simp only: o_apply)
blanchet@48975
    50
blanchet@48975
    51
lemma in_Union_o_assoc: "x \<in> (Union o gset o gmap) A \<Longrightarrow> x \<in> (Union o (gset o gmap)) A"
blanchet@48975
    52
by (unfold o_assoc)
blanchet@48975
    53
blanchet@48975
    54
lemma comp_single_set_bd:
blanchet@48975
    55
  assumes fbd_Card_order: "Card_order fbd" and
blanchet@48975
    56
    fset_bd: "\<And>x. |fset x| \<le>o fbd" and
blanchet@48975
    57
    gset_bd: "\<And>x. |gset x| \<le>o gbd"
blanchet@48975
    58
  shows "|\<Union>fset ` gset x| \<le>o gbd *c fbd"
blanchet@48975
    59
apply (subst sym[OF SUP_def])
blanchet@48975
    60
apply (rule ordLeq_transitive)
blanchet@48975
    61
apply (rule card_of_UNION_Sigma)
blanchet@48975
    62
apply (subst SIGMA_CSUM)
blanchet@48975
    63
apply (rule ordLeq_transitive)
blanchet@48975
    64
apply (rule card_of_Csum_Times')
blanchet@48975
    65
apply (rule fbd_Card_order)
blanchet@48975
    66
apply (rule ballI)
blanchet@48975
    67
apply (rule fset_bd)
blanchet@48975
    68
apply (rule ordLeq_transitive)
blanchet@48975
    69
apply (rule cprod_mono1)
blanchet@48975
    70
apply (rule gset_bd)
blanchet@48975
    71
apply (rule ordIso_imp_ordLeq)
blanchet@48975
    72
apply (rule ordIso_refl)
blanchet@48975
    73
apply (rule Card_order_cprod)
blanchet@48975
    74
done
blanchet@48975
    75
blanchet@48975
    76
lemma Union_image_insert: "\<Union>f ` insert a B = f a \<union> \<Union>f ` B"
blanchet@48975
    77
by simp
blanchet@48975
    78
blanchet@48975
    79
lemma Union_image_empty: "A \<union> \<Union>f ` {} = A"
blanchet@48975
    80
by simp
blanchet@48975
    81
blanchet@48975
    82
definition collect where
blanchet@48975
    83
  "collect F x = (\<Union>f \<in> F. f x)"
blanchet@48975
    84
blanchet@48975
    85
lemma collect_o: "collect F o g = collect ((\<lambda>f. f o g) ` F)"
blanchet@48975
    86
by (rule ext) (auto simp only: o_apply collect_def)
blanchet@48975
    87
blanchet@48975
    88
lemma image_o_collect: "collect ((\<lambda>f. image g o f) ` F) = image g o collect F"
blanchet@48975
    89
by (rule ext) (auto simp add: collect_def)
blanchet@48975
    90
blanchet@48975
    91
lemma conj_subset_def: "A \<subseteq> {x. P x \<and> Q x} = (A \<subseteq> {x. P x} \<and> A \<subseteq> {x. Q x})"
blanchet@49255
    92
by blast
blanchet@48975
    93
blanchet@48975
    94
lemma subset_emptyI: "(\<And>x. x \<in> A \<Longrightarrow> False) \<Longrightarrow> A \<subseteq> {}"
blanchet@49255
    95
by blast
blanchet@48975
    96
blanchet@48975
    97
lemma rev_bspec: "a \<in> A \<Longrightarrow> \<forall>z \<in> A. P z \<Longrightarrow> P a"
blanchet@48975
    98
by simp
blanchet@48975
    99
blanchet@48975
   100
lemma Un_cong: "\<lbrakk>A = B; C = D\<rbrakk> \<Longrightarrow> A \<union> C = B \<union> D"
blanchet@49255
   101
by simp
blanchet@48975
   102
blanchet@48975
   103
lemma UN_image_subset: "\<Union>f ` g x \<subseteq> X = (g x \<subseteq> {x. f x \<subseteq> X})"
blanchet@49255
   104
by blast
blanchet@48975
   105
blanchet@48975
   106
lemma image_Collect_subsetI:
blanchet@48975
   107
  "(\<And>x. P x \<Longrightarrow> f x \<in> B) \<Longrightarrow> f ` {x. P x} \<subseteq> B"
blanchet@49255
   108
by blast
blanchet@48975
   109
blanchet@48975
   110
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@48975
   111
by (unfold o_apply collect_def SUP_def)
blanchet@48975
   112
blanchet@48975
   113
lemma sum_case_comp_Inl:
blanchet@48975
   114
"sum_case f g \<circ> Inl = f"
blanchet@48975
   115
unfolding comp_def by simp
blanchet@48975
   116
blanchet@48975
   117
lemma sum_case_expand_Inr: "f o Inl = g \<Longrightarrow> f x = sum_case g (f o Inr) x"
blanchet@48975
   118
by (auto split: sum.splits)
blanchet@48975
   119
blanchet@48975
   120
lemma converse_mono:
blanchet@48975
   121
"R1 ^-1 \<subseteq> R2 ^-1 \<longleftrightarrow> R1 \<subseteq> R2"
blanchet@48975
   122
unfolding converse_def by auto
blanchet@48975
   123
blanchet@48975
   124
lemma converse_shift:
blanchet@48975
   125
"R1 \<subseteq> R2 ^-1 \<Longrightarrow> R1 ^-1 \<subseteq> R2"
blanchet@48975
   126
unfolding converse_def by auto
blanchet@48975
   127
blanchet@48975
   128
lemma converse_Times: "(A \<times> B) ^-1 = B \<times> A"
blanchet@48975
   129
by auto
blanchet@48975
   130
blanchet@48975
   131
lemma equiv_triv1:
blanchet@48975
   132
assumes "equiv A R" and "(a, b) \<in> R" and "(a, c) \<in> R"
blanchet@48975
   133
shows "(b, c) \<in> R"
blanchet@48975
   134
using assms unfolding equiv_def sym_def trans_def by blast
blanchet@48975
   135
blanchet@48975
   136
lemma equiv_triv2:
blanchet@48975
   137
assumes "equiv A R" and "(a, b) \<in> R" and "(b, c) \<in> R"
blanchet@48975
   138
shows "(a, c) \<in> R"
blanchet@48975
   139
using assms unfolding equiv_def trans_def by blast
blanchet@48975
   140
blanchet@48975
   141
lemma equiv_proj:
blanchet@48975
   142
  assumes e: "equiv A R" and "z \<in> R"
blanchet@48975
   143
  shows "(proj R o fst) z = (proj R o snd) z"
blanchet@48975
   144
proof -
blanchet@48975
   145
  from assms(2) have z: "(fst z, snd z) \<in> R" by auto
blanchet@48975
   146
  have P: "\<And>x. (fst z, x) \<in> R \<Longrightarrow> (snd z, x) \<in> R" by (erule equiv_triv1[OF e z])
blanchet@48975
   147
  have "\<And>x. (snd z, x) \<in> R \<Longrightarrow> (fst z, x) \<in> R" by (erule equiv_triv2[OF e z])
blanchet@48975
   148
  with P show ?thesis unfolding proj_def[abs_def] by auto
blanchet@48975
   149
qed
blanchet@48975
   150
blanchet@48975
   151
blanchet@48975
   152
section{* Weak pullbacks: *}
blanchet@48975
   153
blanchet@48975
   154
definition csquare where
blanchet@48975
   155
"csquare A f1 f2 p1 p2 \<longleftrightarrow> (\<forall> a \<in> A. f1 (p1 a) = f2 (p2 a))"
blanchet@48975
   156
blanchet@48975
   157
definition wpull where
blanchet@48975
   158
"wpull A B1 B2 f1 f2 p1 p2 \<longleftrightarrow>
blanchet@48975
   159
 (\<forall> b1 b2. b1 \<in> B1 \<and> b2 \<in> B2 \<and> f1 b1 = f2 b2 \<longrightarrow> (\<exists> a \<in> A. p1 a = b1 \<and> p2 a = b2))"
blanchet@48975
   160
blanchet@48975
   161
lemma wpull_cong:
blanchet@48975
   162
"\<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@48975
   163
by simp
blanchet@48975
   164
blanchet@48975
   165
lemma wpull_id: "wpull UNIV B1 B2 id id id id"
blanchet@48975
   166
unfolding wpull_def by simp
blanchet@48975
   167
blanchet@48975
   168
blanchet@48975
   169
(* Weak pseudo-pullbacks *)
blanchet@48975
   170
blanchet@48975
   171
definition wppull where
blanchet@48975
   172
"wppull A B1 B2 f1 f2 e1 e2 p1 p2 \<longleftrightarrow>
blanchet@48975
   173
 (\<forall> b1 b2. b1 \<in> B1 \<and> b2 \<in> B2 \<and> f1 b1 = f2 b2 \<longrightarrow>
blanchet@48975
   174
           (\<exists> a \<in> A. e1 (p1 a) = e1 b1 \<and> e2 (p2 a) = e2 b2))"
blanchet@48975
   175
blanchet@48975
   176
blanchet@48975
   177
(* The pullback of sets *)
blanchet@48975
   178
definition thePull where
blanchet@48975
   179
"thePull B1 B2 f1 f2 = {(b1,b2). b1 \<in> B1 \<and> b2 \<in> B2 \<and> f1 b1 = f2 b2}"
blanchet@48975
   180
blanchet@48975
   181
lemma wpull_thePull:
blanchet@48975
   182
"wpull (thePull B1 B2 f1 f2) B1 B2 f1 f2 fst snd"
blanchet@48975
   183
unfolding wpull_def thePull_def by auto
blanchet@48975
   184
blanchet@48975
   185
lemma wppull_thePull:
blanchet@48975
   186
assumes "wppull A B1 B2 f1 f2 e1 e2 p1 p2"
blanchet@48975
   187
shows
blanchet@48975
   188
"\<exists> j. \<forall> a' \<in> thePull B1 B2 f1 f2.
blanchet@48975
   189
   j a' \<in> A \<and>
blanchet@48975
   190
   e1 (p1 (j a')) = e1 (fst a') \<and> e2 (p2 (j a')) = e2 (snd a')"
blanchet@48975
   191
(is "\<exists> j. \<forall> a' \<in> ?A'. ?phi a' (j a')")
blanchet@48975
   192
proof(rule bchoice[of ?A' ?phi], default)
blanchet@48975
   193
  fix a' assume a': "a' \<in> ?A'"
blanchet@48975
   194
  hence "fst a' \<in> B1" unfolding thePull_def by auto
blanchet@48975
   195
  moreover
blanchet@48975
   196
  from a' have "snd a' \<in> B2" unfolding thePull_def by auto
blanchet@48975
   197
  moreover have "f1 (fst a') = f2 (snd a')"
blanchet@48975
   198
  using a' unfolding csquare_def thePull_def by auto
blanchet@48975
   199
  ultimately show "\<exists> ja'. ?phi a' ja'"
blanchet@48975
   200
  using assms unfolding wppull_def by auto
blanchet@48975
   201
qed
blanchet@48975
   202
blanchet@48975
   203
lemma wpull_wppull:
blanchet@48975
   204
assumes wp: "wpull A' B1 B2 f1 f2 p1' p2'" and
blanchet@48975
   205
1: "\<forall> a' \<in> A'. j a' \<in> A \<and> e1 (p1 (j a')) = e1 (p1' a') \<and> e2 (p2 (j a')) = e2 (p2' a')"
blanchet@48975
   206
shows "wppull A B1 B2 f1 f2 e1 e2 p1 p2"
blanchet@48975
   207
unfolding wppull_def proof safe
blanchet@48975
   208
  fix b1 b2
blanchet@48975
   209
  assume b1: "b1 \<in> B1" and b2: "b2 \<in> B2" and f: "f1 b1 = f2 b2"
blanchet@48975
   210
  then obtain a' where a': "a' \<in> A'" and b1: "b1 = p1' a'" and b2: "b2 = p2' a'"
blanchet@48975
   211
  using wp unfolding wpull_def by blast
blanchet@48975
   212
  show "\<exists>a\<in>A. e1 (p1 a) = e1 b1 \<and> e2 (p2 a) = e2 b2"
blanchet@48975
   213
  apply(rule bexI[of _ "j a'"]) unfolding b1 b2 using a' 1 by auto
blanchet@48975
   214
qed
blanchet@48975
   215
blanchet@48975
   216
lemma wppull_id: "\<lbrakk>wpull UNIV UNIV UNIV f1 f2 p1 p2; e1 = id; e2 = id\<rbrakk> \<Longrightarrow>
blanchet@48975
   217
   wppull UNIV UNIV UNIV f1 f2 e1 e2 p1 p2"
blanchet@48975
   218
by (erule wpull_wppull) auto
blanchet@48975
   219
blanchet@48975
   220
blanchet@48975
   221
(* Operators: *)
blanchet@48975
   222
definition diag where "diag A \<equiv> {(a,a) | a. a \<in> A}"
blanchet@48975
   223
definition "Gr A f = {(a,f a) | a. a \<in> A}"
blanchet@48975
   224
definition image2 where "image2 A f g = {(f a, g a) | a. a \<in> A}"
blanchet@48975
   225
blanchet@48975
   226
lemma diagI: "x \<in> A \<Longrightarrow> (x, x) \<in> diag A"
blanchet@48975
   227
unfolding diag_def by simp
blanchet@48975
   228
blanchet@48975
   229
lemma diagE: "(a, b) \<in> diag A \<Longrightarrow> a = b"
blanchet@48975
   230
unfolding diag_def by simp
blanchet@48975
   231
blanchet@48975
   232
lemma diagE': "x \<in> diag A \<Longrightarrow> fst x = snd x"
blanchet@48975
   233
unfolding diag_def by auto
blanchet@48975
   234
blanchet@48975
   235
lemma diag_fst: "x \<in> diag A \<Longrightarrow> fst x \<in> A"
blanchet@48975
   236
unfolding diag_def by auto
blanchet@48975
   237
blanchet@48975
   238
lemma diag_UNIV: "diag UNIV = Id"
blanchet@48975
   239
unfolding diag_def by auto
blanchet@48975
   240
blanchet@48975
   241
lemma diag_converse: "diag A = (diag A) ^-1"
blanchet@48975
   242
unfolding diag_def by auto
blanchet@48975
   243
blanchet@48975
   244
lemma diag_Comp: "diag A = diag A O diag A"
blanchet@48975
   245
unfolding diag_def by auto
blanchet@48975
   246
blanchet@48975
   247
lemma diag_Gr: "diag A = Gr A id"
blanchet@48975
   248
unfolding diag_def Gr_def by simp
blanchet@48975
   249
blanchet@48975
   250
lemma diag_UNIV_I: "x = y \<Longrightarrow> (x, y) \<in> diag UNIV"
blanchet@48975
   251
unfolding diag_def by auto
blanchet@48975
   252
blanchet@48975
   253
lemma image2_eqI: "\<lbrakk>b = f x; c = g x; x \<in> A\<rbrakk> \<Longrightarrow> (b, c) \<in> image2 A f g"
blanchet@48975
   254
unfolding image2_def by auto
blanchet@48975
   255
blanchet@48975
   256
lemma Id_def': "Id = {(a,b). a = b}"
blanchet@48975
   257
by auto
blanchet@48975
   258
blanchet@48975
   259
lemma Id_alt: "Id = Gr UNIV id"
blanchet@48975
   260
unfolding Gr_def by auto
blanchet@48975
   261
blanchet@48975
   262
lemma Id_subset: "Id \<subseteq> {(a, b). P a b \<or> a = b}"
blanchet@48975
   263
by auto
blanchet@48975
   264
blanchet@48975
   265
lemma IdD: "(a, b) \<in> Id \<Longrightarrow> a = b"
blanchet@48975
   266
by auto
blanchet@48975
   267
blanchet@48975
   268
lemma image2_Gr: "image2 A f g = (Gr A f)^-1 O (Gr A g)"
blanchet@48975
   269
unfolding image2_def Gr_def by auto
blanchet@48975
   270
blanchet@48975
   271
lemma GrI: "\<lbrakk>x \<in> A; f x = fx\<rbrakk> \<Longrightarrow> (x, fx) \<in> Gr A f"
blanchet@48975
   272
unfolding Gr_def by simp
blanchet@48975
   273
blanchet@48975
   274
lemma GrE: "(x, fx) \<in> Gr A f \<Longrightarrow> (x \<in> A \<Longrightarrow> f x = fx \<Longrightarrow> P) \<Longrightarrow> P"
blanchet@48975
   275
unfolding Gr_def by simp
blanchet@48975
   276
blanchet@48975
   277
lemma GrD1: "(x, fx) \<in> Gr A f \<Longrightarrow> x \<in> A"
blanchet@48975
   278
unfolding Gr_def by simp
blanchet@48975
   279
blanchet@48975
   280
lemma GrD2: "(x, fx) \<in> Gr A f \<Longrightarrow> f x = fx"
blanchet@48975
   281
unfolding Gr_def by simp
blanchet@48975
   282
blanchet@48975
   283
lemma Gr_UNIV_id: "f = id \<Longrightarrow> (Gr UNIV f)^-1 O Gr UNIV f = Gr UNIV f"
blanchet@48975
   284
unfolding Gr_def by auto
blanchet@48975
   285
blanchet@48975
   286
lemma Gr_fst_snd: "(Gr R fst)^-1 O Gr R snd = R"
blanchet@48975
   287
unfolding Gr_def by auto
blanchet@48975
   288
blanchet@48975
   289
lemma Gr_mono: "A \<subseteq> B \<Longrightarrow> Gr A f \<subseteq> Gr B f"
blanchet@48975
   290
unfolding Gr_def by auto
blanchet@48975
   291
blanchet@48975
   292
lemma subst_rel_def: "A = B \<Longrightarrow> (Gr A f)^-1 O Gr A g = (Gr B f)^-1 O Gr B g"
blanchet@48975
   293
by simp
blanchet@48975
   294
blanchet@48975
   295
lemma abs_pred_def: "\<lbrakk>\<And>x y. (x, y) \<in> rel = pred x y\<rbrakk> \<Longrightarrow> rel = Collect (split pred)"
blanchet@48975
   296
by auto
blanchet@48975
   297
blanchet@48975
   298
lemma Collect_split_cong: "Collect (split pred) = Collect (split pred') \<Longrightarrow> pred = pred'"
blanchet@48975
   299
by blast
blanchet@48975
   300
blanchet@48975
   301
lemma pred_def_abs: "rel = Collect (split pred) \<Longrightarrow> pred = (\<lambda>x y. (x, y) \<in> rel)"
blanchet@48975
   302
by auto
blanchet@48975
   303
blanchet@48975
   304
lemma wpull_Gr:
blanchet@48975
   305
"wpull (Gr A f) A (f ` A) f id fst snd"
blanchet@48975
   306
unfolding wpull_def Gr_def by auto
blanchet@48975
   307
blanchet@48975
   308
lemma Gr_incl: "Gr A f \<subseteq> A <*> B \<longleftrightarrow> f ` A \<subseteq> B"
blanchet@48975
   309
unfolding Gr_def by auto
blanchet@48975
   310
blanchet@48975
   311
lemma equiv_Image: "equiv A R \<Longrightarrow> (\<And>a b. (a, b) \<in> R \<Longrightarrow> a \<in> A \<and> b \<in> A \<and> R `` {a} = R `` {b})"
blanchet@48975
   312
unfolding equiv_def refl_on_def Image_def by (auto intro: transD symD)
blanchet@48975
   313
blanchet@48975
   314
definition relImage where
blanchet@48975
   315
"relImage R f \<equiv> {(f a1, f a2) | a1 a2. (a1,a2) \<in> R}"
blanchet@48975
   316
blanchet@48975
   317
definition relInvImage where
blanchet@48975
   318
"relInvImage A R f \<equiv> {(a1, a2) | a1 a2. a1 \<in> A \<and> a2 \<in> A \<and> (f a1, f a2) \<in> R}"
blanchet@48975
   319
blanchet@48975
   320
lemma relImage_Gr:
blanchet@48975
   321
"\<lbrakk>R \<subseteq> A \<times> A\<rbrakk> \<Longrightarrow> relImage R f = (Gr A f)^-1 O R O Gr A f"
blanchet@48975
   322
unfolding relImage_def Gr_def relcomp_def by auto
blanchet@48975
   323
blanchet@48975
   324
lemma relInvImage_Gr: "\<lbrakk>R \<subseteq> B \<times> B\<rbrakk> \<Longrightarrow> relInvImage A R f = Gr A f O R O (Gr A f)^-1"
blanchet@48975
   325
unfolding Gr_def relcomp_def image_def relInvImage_def by auto
blanchet@48975
   326
blanchet@48975
   327
lemma relImage_mono:
blanchet@48975
   328
"R1 \<subseteq> R2 \<Longrightarrow> relImage R1 f \<subseteq> relImage R2 f"
blanchet@48975
   329
unfolding relImage_def by auto
blanchet@48975
   330
blanchet@48975
   331
lemma relInvImage_mono:
blanchet@48975
   332
"R1 \<subseteq> R2 \<Longrightarrow> relInvImage A R1 f \<subseteq> relInvImage A R2 f"
blanchet@48975
   333
unfolding relInvImage_def by auto
blanchet@48975
   334
blanchet@48975
   335
lemma relInvImage_diag:
blanchet@48975
   336
"(\<And>a1 a2. f a1 = f a2 \<longleftrightarrow> a1 = a2) \<Longrightarrow> relInvImage A (diag B) f \<subseteq> Id"
blanchet@48975
   337
unfolding relInvImage_def diag_def by auto
blanchet@48975
   338
blanchet@48975
   339
lemma relInvImage_UNIV_relImage:
blanchet@48975
   340
"R \<subseteq> relInvImage UNIV (relImage R f) f"
blanchet@48975
   341
unfolding relInvImage_def relImage_def by auto
blanchet@48975
   342
blanchet@48975
   343
lemma relImage_proj:
blanchet@48975
   344
assumes "equiv A R"
blanchet@48975
   345
shows "relImage R (proj R) \<subseteq> diag (A//R)"
blanchet@48975
   346
unfolding relImage_def diag_def apply safe
blanchet@48975
   347
using proj_iff[OF assms]
blanchet@48975
   348
by (metis assms equiv_Image proj_def proj_preserves)
blanchet@48975
   349
blanchet@48975
   350
lemma relImage_relInvImage:
blanchet@48975
   351
assumes "R \<subseteq> f ` A <*> f ` A"
blanchet@48975
   352
shows "relImage (relInvImage A R f) f = R"
blanchet@48975
   353
using assms unfolding relImage_def relInvImage_def by fastforce
blanchet@48975
   354
blanchet@48975
   355
blanchet@48975
   356
(* Relation composition as a weak pseudo-pullback *)
blanchet@48975
   357
blanchet@48975
   358
(* pick middle *)
blanchet@48975
   359
definition "pickM P Q a c = (SOME b. (a,b) \<in> P \<and> (b,c) \<in> Q)"
blanchet@48975
   360
blanchet@48975
   361
lemma pickM:
blanchet@48975
   362
assumes "(a,c) \<in> P O Q"
blanchet@48975
   363
shows "(a, pickM P Q a c) \<in> P \<and> (pickM P Q a c, c) \<in> Q"
blanchet@48975
   364
unfolding pickM_def apply(rule someI_ex)
blanchet@48975
   365
using assms unfolding relcomp_def by auto
blanchet@48975
   366
blanchet@48975
   367
definition fstO where "fstO P Q ac = (fst ac, pickM P Q (fst ac) (snd ac))"
blanchet@48975
   368
definition sndO where "sndO P Q ac = (pickM P Q (fst ac) (snd ac), snd ac)"
blanchet@48975
   369
blanchet@48975
   370
lemma fstO_in: "ac \<in> P O Q \<Longrightarrow> fstO P Q ac \<in> P"
blanchet@48975
   371
by (metis assms fstO_def pickM surjective_pairing)
blanchet@48975
   372
blanchet@48975
   373
lemma fst_fstO: "fst bc = (fst \<circ> fstO P Q) bc"
blanchet@48975
   374
unfolding comp_def fstO_def by simp
blanchet@48975
   375
blanchet@48975
   376
lemma snd_sndO: "snd bc = (snd \<circ> sndO P Q) bc"
blanchet@48975
   377
unfolding comp_def sndO_def by simp
blanchet@48975
   378
blanchet@48975
   379
lemma sndO_in: "ac \<in> P O Q \<Longrightarrow> sndO P Q ac \<in> Q"
blanchet@48975
   380
by (metis assms sndO_def pickM surjective_pairing)
blanchet@48975
   381
blanchet@48975
   382
lemma csquare_fstO_sndO:
blanchet@48975
   383
"csquare (P O Q) snd fst (fstO P Q) (sndO P Q)"
blanchet@48975
   384
unfolding csquare_def fstO_def sndO_def using pickM by auto
blanchet@48975
   385
blanchet@48975
   386
lemma wppull_fstO_sndO:
blanchet@48975
   387
shows "wppull (P O Q) P Q snd fst fst snd (fstO P Q) (sndO P Q)"
blanchet@48975
   388
using pickM unfolding wppull_def fstO_def sndO_def relcomp_def by auto
blanchet@48975
   389
blanchet@48975
   390
lemma subst_Pair: "P x y \<Longrightarrow> a = (x, y) \<Longrightarrow> P (fst a) (snd a)"
blanchet@48975
   391
by simp
blanchet@48975
   392
blanchet@48975
   393
lemma snd_fst_flip: "snd xy = (fst o (%(x, y). (y, x))) xy"
blanchet@48975
   394
by (simp split: prod.split)
blanchet@48975
   395
blanchet@48975
   396
lemma fst_snd_flip: "fst xy = (snd o (%(x, y). (y, x))) xy"
blanchet@48975
   397
by (simp split: prod.split)
blanchet@48975
   398
blanchet@48975
   399
lemma flip_rel: "A \<subseteq> (R ^-1) \<Longrightarrow> (%(x, y). (y, x)) ` A \<subseteq> R"
blanchet@48975
   400
by auto
blanchet@48975
   401
blanchet@48975
   402
lemma fst_diag_id: "(fst \<circ> (%x. (x, x))) z = id z"
blanchet@48975
   403
by simp
blanchet@48975
   404
blanchet@48975
   405
lemma snd_diag_id: "(snd \<circ> (%x. (x, x))) z = id z"
blanchet@48975
   406
by simp
blanchet@48975
   407
blanchet@48975
   408
lemma fst_snd: "\<lbrakk>snd x = (y, z)\<rbrakk> \<Longrightarrow> fst (snd x) = y"
blanchet@48975
   409
by simp
blanchet@48975
   410
blanchet@48975
   411
lemma snd_snd: "\<lbrakk>snd x = (y, z)\<rbrakk> \<Longrightarrow> snd (snd x) = z"
blanchet@48975
   412
by simp
blanchet@48975
   413
blanchet@48975
   414
lemma fstI: "x = (y, z) \<Longrightarrow> fst x = y"
blanchet@48975
   415
by simp
blanchet@48975
   416
blanchet@48975
   417
lemma sndI: "x = (y, z) \<Longrightarrow> snd x = z"
blanchet@48975
   418
by simp
blanchet@48975
   419
blanchet@48975
   420
lemma Collect_restrict: "{x. x \<in> X \<and> P x} \<subseteq> X"
blanchet@48975
   421
by auto
blanchet@48975
   422
blanchet@48975
   423
lemma Collect_restrict': "{(x, y) | x y. phi x y \<and> P x y} \<subseteq> {(x, y) | x y. phi x y}"
blanchet@48975
   424
by auto
blanchet@48975
   425
blanchet@48975
   426
lemma prop_restrict: "\<lbrakk>x \<in> Z; Z \<subseteq> {x. x \<in> X \<and> P x}\<rbrakk> \<Longrightarrow> P x"
blanchet@48975
   427
by auto
blanchet@48975
   428
blanchet@48975
   429
lemma underS_I: "\<lbrakk>i \<noteq> j; (i, j) \<in> R\<rbrakk> \<Longrightarrow> i \<in> rel.underS R j"
blanchet@48975
   430
unfolding rel.underS_def by simp
blanchet@48975
   431
blanchet@48975
   432
lemma underS_E: "i \<in> rel.underS R j \<Longrightarrow> i \<noteq> j \<and> (i, j) \<in> R"
blanchet@48975
   433
unfolding rel.underS_def by simp
blanchet@48975
   434
blanchet@48975
   435
lemma underS_Field: "i \<in> rel.underS R j \<Longrightarrow> i \<in> Field R"
blanchet@48975
   436
unfolding rel.underS_def Field_def by auto
blanchet@48975
   437
blanchet@48975
   438
lemma FieldI2: "(i, j) \<in> R \<Longrightarrow> j \<in> Field R"
blanchet@48975
   439
unfolding Field_def by auto
blanchet@48975
   440
blanchet@48975
   441
blanchet@48975
   442
subsection {* Convolution product *}
blanchet@48975
   443
blanchet@48975
   444
definition convol ("<_ , _>") where
blanchet@48975
   445
"<f , g> \<equiv> %a. (f a, g a)"
blanchet@48975
   446
blanchet@48975
   447
lemma fst_convol:
blanchet@48975
   448
"fst o <f , g> = f"
blanchet@48975
   449
apply(rule ext)
blanchet@48975
   450
unfolding convol_def by simp
blanchet@48975
   451
blanchet@48975
   452
lemma snd_convol:
blanchet@48975
   453
"snd o <f , g> = g"
blanchet@48975
   454
apply(rule ext)
blanchet@48975
   455
unfolding convol_def by simp
blanchet@48975
   456
blanchet@48975
   457
lemma fst_convol': "fst (<f, g> x) = f x"
blanchet@48975
   458
using fst_convol unfolding convol_def by simp
blanchet@48975
   459
blanchet@48975
   460
lemma snd_convol': "snd (<f, g> x) = g x"
blanchet@48975
   461
using snd_convol unfolding convol_def by simp
blanchet@48975
   462
blanchet@48975
   463
lemma image_convolD: "\<lbrakk>(a, b) \<in> <f, g> ` X\<rbrakk> \<Longrightarrow> \<exists>x. x \<in> X \<and> a = f x \<and> b = g x"
blanchet@48975
   464
unfolding convol_def by auto
blanchet@48975
   465
blanchet@48975
   466
lemma convol_expand_snd: "fst o f = g \<Longrightarrow>  <g, snd o f> = f"
blanchet@48975
   467
unfolding convol_def by auto
blanchet@48975
   468
blanchet@48975
   469
subsection{* Facts about functions *}
blanchet@48975
   470
blanchet@48975
   471
lemma pointfreeE: "f o g = f' o g' \<Longrightarrow> f (g x) = f' (g' x)"
blanchet@48975
   472
unfolding o_def fun_eq_iff by simp
blanchet@48975
   473
blanchet@48975
   474
lemma pointfree_idE: "f o g = id \<Longrightarrow> f (g x) = x"
blanchet@48975
   475
unfolding o_def fun_eq_iff by simp
blanchet@48975
   476
blanchet@48975
   477
definition inver where
blanchet@48975
   478
  "inver g f A = (ALL a : A. g (f a) = a)"
blanchet@48975
   479
blanchet@48975
   480
lemma bij_betw_iff_ex:
blanchet@48975
   481
  "bij_betw f A B = (EX g. g ` B = A \<and> inver g f A \<and> inver f g B)" (is "?L = ?R")
blanchet@48975
   482
proof (rule iffI)
blanchet@48975
   483
  assume ?L
blanchet@48975
   484
  hence f: "f ` A = B" and inj_f: "inj_on f A" unfolding bij_betw_def by auto
blanchet@48975
   485
  let ?phi = "% b a. a : A \<and> f a = b"
blanchet@48975
   486
  have "ALL b : B. EX a. ?phi b a" using f by blast
blanchet@48975
   487
  then obtain g where g: "ALL b : B. g b : A \<and> f (g b) = b"
blanchet@48975
   488
    using bchoice[of B ?phi] by blast
blanchet@48975
   489
  hence gg: "ALL b : f ` A. g b : A \<and> f (g b) = b" using f by blast
blanchet@48975
   490
  have gf: "inver g f A" unfolding inver_def by (metis gg imageI inj_f the_inv_into_f_f)
blanchet@48975
   491
  moreover have "g ` B \<le> A \<and> inver f g B" using g unfolding inver_def by blast
blanchet@48975
   492
  moreover have "A \<le> g ` B"
blanchet@48975
   493
  proof safe
blanchet@48975
   494
    fix a assume a: "a : A"
blanchet@48975
   495
    hence "f a : B" using f by auto
blanchet@48975
   496
    moreover have "a = g (f a)" using a gf unfolding inver_def by auto
blanchet@48975
   497
    ultimately show "a : g ` B" by blast
blanchet@48975
   498
  qed
blanchet@48975
   499
  ultimately show ?R by blast
blanchet@48975
   500
next
blanchet@48975
   501
  assume ?R
blanchet@48975
   502
  then obtain g where g: "g ` B = A \<and> inver g f A \<and> inver f g B" by blast
blanchet@48975
   503
  show ?L unfolding bij_betw_def
blanchet@48975
   504
  proof safe
blanchet@48975
   505
    show "inj_on f A" unfolding inj_on_def
blanchet@48975
   506
    proof safe
blanchet@48975
   507
      fix a1 a2 assume a: "a1 : A"  "a2 : A" and "f a1 = f a2"
blanchet@48975
   508
      hence "g (f a1) = g (f a2)" by simp
blanchet@48975
   509
      thus "a1 = a2" using a g unfolding inver_def by simp
blanchet@48975
   510
    qed
blanchet@48975
   511
  next
blanchet@48975
   512
    fix a assume "a : A"
blanchet@48975
   513
    then obtain b where b: "b : B" and a: "a = g b" using g by blast
blanchet@48975
   514
    hence "b = f (g b)" using g unfolding inver_def by auto
blanchet@48975
   515
    thus "f a : B" unfolding a using b by simp
blanchet@48975
   516
  next
blanchet@48975
   517
    fix b assume "b : B"
blanchet@48975
   518
    hence "g b : A \<and> b = f (g b)" using g unfolding inver_def by auto
blanchet@48975
   519
    thus "b : f ` A" by auto
blanchet@48975
   520
  qed
blanchet@48975
   521
qed
blanchet@48975
   522
blanchet@48975
   523
lemma bijI: "\<lbrakk>\<And>x y. (f x = f y) = (x = y); \<And>y. \<exists>x. y = f x\<rbrakk> \<Longrightarrow> bij f"
blanchet@48975
   524
unfolding bij_def inj_on_def by auto blast
blanchet@48975
   525
blanchet@48975
   526
lemma bij_betw_ex_weakE:
blanchet@48975
   527
  "\<lbrakk>bij_betw f A B\<rbrakk> \<Longrightarrow> \<exists>g. g ` B \<subseteq> A \<and> inver g f A \<and> inver f g B"
blanchet@48975
   528
by (auto simp only: bij_betw_iff_ex)
blanchet@48975
   529
blanchet@48975
   530
lemma inver_surj: "\<lbrakk>g ` B \<subseteq> A; f ` A \<subseteq> B; inver g f A\<rbrakk> \<Longrightarrow> g ` B = A"
blanchet@48975
   531
unfolding inver_def by auto (rule rev_image_eqI, auto)
blanchet@48975
   532
blanchet@48975
   533
lemma inver_mono: "\<lbrakk>A \<subseteq> B; inver f g B\<rbrakk> \<Longrightarrow> inver f g A"
blanchet@48975
   534
unfolding inver_def by auto
blanchet@48975
   535
blanchet@48975
   536
lemma inver_pointfree: "inver f g A = (\<forall>a \<in> A. (f o g) a = a)"
blanchet@48975
   537
unfolding inver_def by simp
blanchet@48975
   538
blanchet@48975
   539
lemma bij_betwE: "bij_betw f A B \<Longrightarrow> \<forall>a\<in>A. f a \<in> B"
blanchet@48975
   540
unfolding bij_betw_def by auto
blanchet@48975
   541
blanchet@48975
   542
lemma bij_betw_imageE: "bij_betw f A B \<Longrightarrow> f ` A = B"
blanchet@48975
   543
unfolding bij_betw_def by auto
blanchet@48975
   544
blanchet@48975
   545
lemma inverE: "\<lbrakk>inver f f' A; x \<in> A\<rbrakk> \<Longrightarrow> f (f' x) = x"
blanchet@48975
   546
unfolding inver_def by auto
blanchet@48975
   547
blanchet@48975
   548
lemma bij_betw_inver1: "bij_betw f A B \<Longrightarrow> inver (inv_into A f) f A"
blanchet@48975
   549
unfolding bij_betw_def inver_def by auto
blanchet@48975
   550
blanchet@48975
   551
lemma bij_betw_inver2: "bij_betw f A B \<Longrightarrow> inver f (inv_into A f) B"
blanchet@48975
   552
unfolding bij_betw_def inver_def by auto
blanchet@48975
   553
blanchet@48975
   554
lemma bij_betwI: "\<lbrakk>bij_betw g B A; inver g f A; inver f g B\<rbrakk> \<Longrightarrow> bij_betw f A B"
blanchet@48975
   555
by (metis bij_betw_iff_ex bij_betw_imageE)
blanchet@48975
   556
blanchet@48975
   557
lemma bij_betwI':
blanchet@48975
   558
  "\<lbrakk>\<And>x y. \<lbrakk>x \<in> X; y \<in> X\<rbrakk> \<Longrightarrow> (f x = f y) = (x = y);
blanchet@48975
   559
    \<And>x. x \<in> X \<Longrightarrow> f x \<in> Y;
blanchet@48975
   560
    \<And>y. y \<in> Y \<Longrightarrow> \<exists>x \<in> X. y = f x\<rbrakk> \<Longrightarrow> bij_betw f X Y"
blanchet@48975
   561
unfolding bij_betw_def inj_on_def by auto (metis rev_image_eqI)
blanchet@48975
   562
blanchet@48975
   563
lemma o_bij:
blanchet@48975
   564
  assumes gf: "g o f = id" and fg: "f o g = id"
blanchet@48975
   565
  shows "bij f"
blanchet@48975
   566
unfolding bij_def inj_on_def surj_def proof safe
blanchet@48975
   567
  fix a1 a2 assume "f a1 = f a2"
blanchet@48975
   568
  hence "g ( f a1) = g (f a2)" by simp
blanchet@48975
   569
  thus "a1 = a2" using gf unfolding fun_eq_iff by simp
blanchet@48975
   570
next
blanchet@48975
   571
  fix b
blanchet@48975
   572
  have "b = f (g b)"
blanchet@48975
   573
  using fg unfolding fun_eq_iff by simp
blanchet@48975
   574
  thus "EX a. b = f a" by blast
blanchet@48975
   575
qed
blanchet@48975
   576
blanchet@48975
   577
lemma surj_fun_eq:
blanchet@48975
   578
  assumes surj_on: "f ` X = UNIV" and eq_on: "\<forall>x \<in> X. (g1 o f) x = (g2 o f) x"
blanchet@48975
   579
  shows "g1 = g2"
blanchet@48975
   580
proof (rule ext)
blanchet@48975
   581
  fix y
blanchet@48975
   582
  from surj_on obtain x where "x \<in> X" and "y = f x" by blast
blanchet@48975
   583
  thus "g1 y = g2 y" using eq_on by simp
blanchet@48975
   584
qed
blanchet@48975
   585
blanchet@48975
   586
lemma Card_order_wo_rel: "Card_order r \<Longrightarrow> wo_rel r"
blanchet@48975
   587
unfolding wo_rel_def card_order_on_def by blast 
blanchet@48975
   588
blanchet@48975
   589
lemma Cinfinite_limit: "\<lbrakk>x \<in> Field r; Cinfinite r\<rbrakk> \<Longrightarrow>
blanchet@48975
   590
  \<exists>y \<in> Field r. x \<noteq> y \<and> (x, y) \<in> r"
blanchet@48975
   591
unfolding cinfinite_def by (auto simp add: infinite_Card_order_limit)
blanchet@48975
   592
blanchet@48975
   593
lemma Card_order_trans:
blanchet@48975
   594
  "\<lbrakk>Card_order r; x \<noteq> y; (x, y) \<in> r; y \<noteq> z; (y, z) \<in> r\<rbrakk> \<Longrightarrow> x \<noteq> z \<and> (x, z) \<in> r"
blanchet@48975
   595
unfolding card_order_on_def well_order_on_def linear_order_on_def
blanchet@48975
   596
  partial_order_on_def preorder_on_def trans_def antisym_def by blast
blanchet@48975
   597
blanchet@48975
   598
lemma Cinfinite_limit2:
blanchet@48975
   599
 assumes x1: "x1 \<in> Field r" and x2: "x2 \<in> Field r" and r: "Cinfinite r"
blanchet@48975
   600
 shows "\<exists>y \<in> Field r. (x1 \<noteq> y \<and> (x1, y) \<in> r) \<and> (x2 \<noteq> y \<and> (x2, y) \<in> r)"
blanchet@48975
   601
proof -
blanchet@48975
   602
  from r have trans: "trans r" and total: "Total r" and antisym: "antisym r"
blanchet@48975
   603
    unfolding card_order_on_def well_order_on_def linear_order_on_def
blanchet@48975
   604
      partial_order_on_def preorder_on_def by auto
blanchet@48975
   605
  obtain y1 where y1: "y1 \<in> Field r" "x1 \<noteq> y1" "(x1, y1) \<in> r"
blanchet@48975
   606
    using Cinfinite_limit[OF x1 r] by blast
blanchet@48975
   607
  obtain y2 where y2: "y2 \<in> Field r" "x2 \<noteq> y2" "(x2, y2) \<in> r"
blanchet@48975
   608
    using Cinfinite_limit[OF x2 r] by blast
blanchet@48975
   609
  show ?thesis
blanchet@48975
   610
  proof (cases "y1 = y2")
blanchet@48975
   611
    case True with y1 y2 show ?thesis by blast
blanchet@48975
   612
  next
blanchet@48975
   613
    case False
blanchet@48975
   614
    with y1(1) y2(1) total have "(y1, y2) \<in> r \<or> (y2, y1) \<in> r"
blanchet@48975
   615
      unfolding total_on_def by auto
blanchet@48975
   616
    thus ?thesis
blanchet@48975
   617
    proof
blanchet@48975
   618
      assume *: "(y1, y2) \<in> r"
blanchet@48975
   619
      with trans y1(3) have "(x1, y2) \<in> r" unfolding trans_def by blast
blanchet@48975
   620
      with False y1 y2 * antisym show ?thesis by (cases "x1 = y2") (auto simp: antisym_def)
blanchet@48975
   621
    next
blanchet@48975
   622
      assume *: "(y2, y1) \<in> r"
blanchet@48975
   623
      with trans y2(3) have "(x2, y1) \<in> r" unfolding trans_def by blast
blanchet@48975
   624
      with False y1 y2 * antisym show ?thesis by (cases "x2 = y1") (auto simp: antisym_def)
blanchet@48975
   625
    qed
blanchet@48975
   626
  qed
blanchet@48975
   627
qed
blanchet@48975
   628
blanchet@48975
   629
lemma Cinfinite_limit_finite: "\<lbrakk>finite X; X \<subseteq> Field r; Cinfinite r\<rbrakk>
blanchet@48975
   630
 \<Longrightarrow> \<exists>y \<in> Field r. \<forall>x \<in> X. (x \<noteq> y \<and> (x, y) \<in> r)"
blanchet@48975
   631
proof (induct X rule: finite_induct)
blanchet@48975
   632
  case empty thus ?case unfolding cinfinite_def using ex_in_conv[of "Field r"] finite.emptyI by auto
blanchet@48975
   633
next
blanchet@48975
   634
  case (insert x X)
blanchet@48975
   635
  then obtain y where y: "y \<in> Field r" "\<forall>x \<in> X. (x \<noteq> y \<and> (x, y) \<in> r)" by blast
blanchet@48975
   636
  then obtain z where z: "z \<in> Field r" "x \<noteq> z \<and> (x, z) \<in> r" "y \<noteq> z \<and> (y, z) \<in> r"
blanchet@48975
   637
    using Cinfinite_limit2[OF _ y(1) insert(5), of x] insert(4) by blast
blanchet@48975
   638
  show ?case by (metis Card_order_trans insert(5) insertE y(2) z)
blanchet@48975
   639
qed
blanchet@48975
   640
blanchet@48975
   641
lemma insert_subsetI: "\<lbrakk>x \<in> A; X \<subseteq> A\<rbrakk> \<Longrightarrow> insert x X \<subseteq> A"
blanchet@48975
   642
by auto
blanchet@48975
   643
blanchet@48975
   644
(*helps resolution*)
blanchet@48975
   645
lemma well_order_induct_imp:
blanchet@48975
   646
  "wo_rel r \<Longrightarrow> (\<And>x. \<forall>y. y \<noteq> x \<and> (y, x) \<in> r \<longrightarrow> y \<in> Field r \<longrightarrow> P y \<Longrightarrow> x \<in> Field r \<longrightarrow> P x) \<Longrightarrow>
blanchet@48975
   647
     x \<in> Field r \<longrightarrow> P x"
blanchet@48975
   648
by (erule wo_rel.well_order_induct)
blanchet@48975
   649
blanchet@48975
   650
lemma meta_spec2:
blanchet@48975
   651
  assumes "(\<And>x y. PROP P x y)"
blanchet@48975
   652
  shows "PROP P x y"
blanchet@48975
   653
by (rule `(\<And>x y. PROP P x y)`)
blanchet@48975
   654
Christian@49077
   655
(*Extended Sublist*)
blanchet@48975
   656
blanchet@48975
   657
definition prefCl where
blanchet@48975
   658
  "prefCl Kl = (\<forall> kl1 kl2. kl1 \<le> kl2 \<and> kl2 \<in> Kl \<longrightarrow> kl1 \<in> Kl)"
blanchet@48975
   659
definition PrefCl where
blanchet@48975
   660
  "PrefCl A n = (\<forall>kl kl'. kl \<in> A n \<and> kl' \<le> kl \<longrightarrow> (\<exists>m\<le>n. kl' \<in> A m))"
blanchet@48975
   661
blanchet@48975
   662
lemma prefCl_UN:
blanchet@48975
   663
  "\<lbrakk>\<And>n. PrefCl A n\<rbrakk> \<Longrightarrow> prefCl (\<Union>n. A n)"
blanchet@48975
   664
unfolding prefCl_def PrefCl_def by fastforce
blanchet@48975
   665
blanchet@48975
   666
definition Succ where "Succ Kl kl = {k . kl @ [k] \<in> Kl}"
blanchet@48975
   667
definition Shift where "Shift Kl k = {kl. k # kl \<in> Kl}"
blanchet@48975
   668
definition shift where "shift lab k = (\<lambda>kl. lab (k # kl))"
blanchet@48975
   669
blanchet@48975
   670
lemmas sh_def = Shift_def shift_def
blanchet@48975
   671
blanchet@48975
   672
lemma empty_Shift: "\<lbrakk>[] \<in> Kl; k \<in> Succ Kl []\<rbrakk> \<Longrightarrow> [] \<in> Shift Kl k"
blanchet@48975
   673
unfolding Shift_def Succ_def by simp
blanchet@48975
   674
blanchet@48975
   675
lemma Shift_clists: "Kl \<subseteq> Field (clists r) \<Longrightarrow> Shift Kl k \<subseteq> Field (clists r)"
blanchet@48975
   676
unfolding Shift_def clists_def Field_card_of by auto
Christian@49090
   677
blanchet@48975
   678
lemma Shift_prefCl: "prefCl Kl \<Longrightarrow> prefCl (Shift Kl k)"
blanchet@48975
   679
unfolding prefCl_def Shift_def
blanchet@48975
   680
proof safe
blanchet@48975
   681
  fix kl1 kl2
blanchet@48975
   682
  assume "\<forall>kl1 kl2. kl1 \<le> kl2 \<and> kl2 \<in> Kl \<longrightarrow> kl1 \<in> Kl"
blanchet@48975
   683
    "kl1 \<le> kl2" "k # kl2 \<in> Kl"
Christian@49090
   684
  thus "k # kl1 \<in> Kl" using Cons_prefix_Cons[of k kl1 k kl2] by blast
blanchet@48975
   685
qed
blanchet@48975
   686
blanchet@48975
   687
lemma not_in_Shift: "kl \<notin> Shift Kl x \<Longrightarrow> x # kl \<notin> Kl"
blanchet@48975
   688
unfolding Shift_def by simp
blanchet@48975
   689
blanchet@48975
   690
lemma prefCl_Succ: "\<lbrakk>prefCl Kl; k # kl \<in> Kl\<rbrakk> \<Longrightarrow> k \<in> Succ Kl []"
blanchet@48975
   691
unfolding Succ_def proof
blanchet@48975
   692
  assume "prefCl Kl" "k # kl \<in> Kl"
Christian@49090
   693
  moreover have "k # [] \<le> k # kl" by auto
blanchet@48975
   694
  ultimately have "k # [] \<in> Kl" unfolding prefCl_def by blast
blanchet@48975
   695
  thus "[] @ [k] \<in> Kl" by simp
blanchet@48975
   696
qed
blanchet@48975
   697
blanchet@48975
   698
lemma SuccD: "k \<in> Succ Kl kl \<Longrightarrow> kl @ [k] \<in> Kl"
blanchet@48975
   699
unfolding Succ_def by simp
blanchet@48975
   700
blanchet@48975
   701
lemmas SuccE = SuccD[elim_format]
blanchet@48975
   702
blanchet@48975
   703
lemma SuccI: "kl @ [k] \<in> Kl \<Longrightarrow> k \<in> Succ Kl kl"
blanchet@48975
   704
unfolding Succ_def by simp
blanchet@48975
   705
blanchet@48975
   706
lemma ShiftD: "kl \<in> Shift Kl k \<Longrightarrow> k # kl \<in> Kl"
blanchet@48975
   707
unfolding Shift_def by simp
blanchet@48975
   708
blanchet@48975
   709
lemma Succ_Shift: "Succ (Shift Kl k) kl = Succ Kl (k # kl)"
blanchet@48975
   710
unfolding Succ_def Shift_def by auto
blanchet@48975
   711
blanchet@48975
   712
lemma ShiftI: "k # kl \<in> Kl \<Longrightarrow> kl \<in> Shift Kl k"
blanchet@48975
   713
unfolding Shift_def by simp
blanchet@48975
   714
blanchet@48975
   715
lemma Func_cexp: "|Func A B| =o |B| ^c |A|"
blanchet@48975
   716
unfolding cexp_def Field_card_of by (simp only: card_of_refl)
blanchet@48975
   717
blanchet@48975
   718
lemma clists_bound: "A \<in> Field (cpow (clists r)) - {{}} \<Longrightarrow> |A| \<le>o clists r"
blanchet@48975
   719
unfolding cpow_def clists_def Field_card_of by (auto simp: card_of_mono1)
blanchet@48975
   720
blanchet@48975
   721
lemma cpow_clists_czero: "\<lbrakk>A \<in> Field (cpow (clists r)) - {{}}; |A| =o czero\<rbrakk> \<Longrightarrow> False"
blanchet@48975
   722
unfolding cpow_def clists_def
blanchet@48975
   723
by (auto simp add: card_of_ordIso_czero_iff_empty[symmetric])
blanchet@48975
   724
   (erule notE, erule ordIso_transitive, rule czero_ordIso)
blanchet@48975
   725
blanchet@48975
   726
lemma incl_UNION_I:
blanchet@48975
   727
assumes "i \<in> I" and "A \<subseteq> F i"
blanchet@48975
   728
shows "A \<subseteq> UNION I F"
blanchet@48975
   729
using assms by auto
blanchet@48975
   730
blanchet@48975
   731
lemma Nil_clists: "{[]} \<subseteq> Field (clists r)"
blanchet@48975
   732
unfolding clists_def Field_card_of by auto
blanchet@48975
   733
blanchet@48975
   734
lemma Cons_clists:
blanchet@48975
   735
  "\<lbrakk>x \<in> Field r; xs \<in> Field (clists r)\<rbrakk> \<Longrightarrow> x # xs \<in> Field (clists r)"
blanchet@48975
   736
unfolding clists_def Field_card_of by auto
blanchet@48975
   737
blanchet@48975
   738
lemma length_Cons: "length (x#xs) = Suc (length xs)"
blanchet@48975
   739
by simp
blanchet@48975
   740
blanchet@48975
   741
lemma length_append_singleton: "length (xs @ [x]) = Suc (length xs)"
blanchet@48975
   742
by simp
blanchet@48975
   743
blanchet@48975
   744
(*injection into the field of a cardinal*)
blanchet@48975
   745
definition "toCard_pred A r f \<equiv> inj_on f A \<and> f ` A \<subseteq> Field r \<and> Card_order r"
blanchet@48975
   746
definition "toCard A r \<equiv> SOME f. toCard_pred A r f"
blanchet@48975
   747
blanchet@48975
   748
lemma ex_toCard_pred:
blanchet@48975
   749
"\<lbrakk>|A| \<le>o r; Card_order r\<rbrakk> \<Longrightarrow> \<exists> f. toCard_pred A r f"
blanchet@48975
   750
unfolding toCard_pred_def
blanchet@48975
   751
using card_of_ordLeq[of A "Field r"]
blanchet@48975
   752
      ordLeq_ordIso_trans[OF _ card_of_unique[of "Field r" r], of "|A|"]
blanchet@48975
   753
by blast
blanchet@48975
   754
blanchet@48975
   755
lemma toCard_pred_toCard:
blanchet@48975
   756
  "\<lbrakk>|A| \<le>o r; Card_order r\<rbrakk> \<Longrightarrow> toCard_pred A r (toCard A r)"
blanchet@48975
   757
unfolding toCard_def using someI_ex[OF ex_toCard_pred] .
blanchet@48975
   758
blanchet@48975
   759
lemma toCard_inj: "\<lbrakk>|A| \<le>o r; Card_order r; x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow>
blanchet@48975
   760
  toCard A r x = toCard A r y \<longleftrightarrow> x = y"
blanchet@48975
   761
using toCard_pred_toCard unfolding inj_on_def toCard_pred_def by blast
blanchet@48975
   762
blanchet@48975
   763
lemma toCard: "\<lbrakk>|A| \<le>o r; Card_order r; b \<in> A\<rbrakk> \<Longrightarrow> toCard A r b \<in> Field r"
blanchet@48975
   764
using toCard_pred_toCard unfolding toCard_pred_def by blast
blanchet@48975
   765
blanchet@48975
   766
definition "fromCard A r k \<equiv> SOME b. b \<in> A \<and> toCard A r b = k"
blanchet@48975
   767
blanchet@48975
   768
lemma fromCard_toCard:
blanchet@48975
   769
"\<lbrakk>|A| \<le>o r; Card_order r; b \<in> A\<rbrakk> \<Longrightarrow> fromCard A r (toCard A r b) = b"
blanchet@48975
   770
unfolding fromCard_def by (rule some_equality) (auto simp add: toCard_inj)
blanchet@48975
   771
blanchet@48975
   772
(* pick according to the weak pullback *)
blanchet@48975
   773
definition pickWP_pred where
blanchet@48975
   774
"pickWP_pred A p1 p2 b1 b2 a \<equiv>
blanchet@48975
   775
 a \<in> A \<and> p1 a = b1 \<and> p2 a = b2"
blanchet@48975
   776
blanchet@48975
   777
definition pickWP where
blanchet@48975
   778
"pickWP A p1 p2 b1 b2 \<equiv>
blanchet@48975
   779
 SOME a. pickWP_pred A p1 p2 b1 b2 a"
blanchet@48975
   780
blanchet@48975
   781
lemma pickWP_pred:
blanchet@48975
   782
assumes "wpull A B1 B2 f1 f2 p1 p2" and
blanchet@48975
   783
"b1 \<in> B1" and "b2 \<in> B2" and "f1 b1 = f2 b2"
blanchet@48975
   784
shows "\<exists> a. pickWP_pred A p1 p2 b1 b2 a"
blanchet@48975
   785
using assms unfolding wpull_def pickWP_pred_def by blast
blanchet@48975
   786
blanchet@48975
   787
lemma pickWP_pred_pickWP:
blanchet@48975
   788
assumes "wpull A B1 B2 f1 f2 p1 p2" and
blanchet@48975
   789
"b1 \<in> B1" and "b2 \<in> B2" and "f1 b1 = f2 b2"
blanchet@48975
   790
shows "pickWP_pred A p1 p2 b1 b2 (pickWP A p1 p2 b1 b2)"
blanchet@48975
   791
unfolding pickWP_def using assms by(rule someI_ex[OF pickWP_pred])
blanchet@48975
   792
blanchet@48975
   793
lemma pickWP:
blanchet@48975
   794
assumes "wpull A B1 B2 f1 f2 p1 p2" and
blanchet@48975
   795
"b1 \<in> B1" and "b2 \<in> B2" and "f1 b1 = f2 b2"
blanchet@48975
   796
shows "pickWP A p1 p2 b1 b2 \<in> A"
blanchet@48975
   797
      "p1 (pickWP A p1 p2 b1 b2) = b1"
blanchet@48975
   798
      "p2 (pickWP A p1 p2 b1 b2) = b2"
blanchet@48975
   799
using assms pickWP_pred_pickWP unfolding pickWP_pred_def by fastforce+
blanchet@48975
   800
blanchet@48975
   801
lemma ssubst_mem: "\<lbrakk>t = s; s \<in> X\<rbrakk> \<Longrightarrow> t \<in> X" by simp
blanchet@48975
   802
blanchet@48975
   803
lemma Inl_Field_csum: "a \<in> Field r \<Longrightarrow> Inl a \<in> Field (r +c s)"
blanchet@48975
   804
unfolding Field_card_of csum_def by auto
blanchet@48975
   805
blanchet@48975
   806
lemma Inr_Field_csum: "a \<in> Field s \<Longrightarrow> Inr a \<in> Field (r +c s)"
blanchet@48975
   807
unfolding Field_card_of csum_def by auto
blanchet@48975
   808
blanchet@48975
   809
lemma nat_rec_0: "f = nat_rec f1 (%n rec. f2 n rec) \<Longrightarrow> f 0 = f1"
blanchet@48975
   810
by auto
blanchet@48975
   811
blanchet@48975
   812
lemma nat_rec_Suc: "f = nat_rec f1 (%n rec. f2 n rec) \<Longrightarrow> f (Suc n) = f2 n (f n)"
blanchet@48975
   813
by auto
blanchet@48975
   814
blanchet@48975
   815
lemma list_rec_Nil: "f = list_rec f1 (%x xs rec. f2 x xs rec) \<Longrightarrow> f [] = f1"
blanchet@48975
   816
by auto
blanchet@48975
   817
blanchet@48975
   818
lemma list_rec_Cons: "f = list_rec f1 (%x xs rec. f2 x xs rec) \<Longrightarrow> f (x # xs) = f2 x xs (f xs)"
blanchet@48975
   819
by auto
blanchet@48975
   820
blanchet@48975
   821
lemma sum_case_cong: "p = q \<Longrightarrow> sum_case f g p = sum_case f g q"
blanchet@48975
   822
by simp
blanchet@48975
   823
blanchet@48975
   824
lemma sum_case_step:
blanchet@48975
   825
  "sum_case (sum_case f' g') g (Inl p) = sum_case f' g' p"
blanchet@48975
   826
  "sum_case f (sum_case f' g') (Inr p) = sum_case f' g' p"
blanchet@48975
   827
by auto
blanchet@48975
   828
blanchet@49255
   829
lemma one_pointE: "\<lbrakk>\<And>x. s = x \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
blanchet@49255
   830
by simp
blanchet@49255
   831
blanchet@49255
   832
lemma obj_sumE_f:
blanchet@49255
   833
"\<lbrakk>\<forall>x. s = f (Inl x) \<longrightarrow> P; \<forall>x. s = f (Inr x) \<longrightarrow> P\<rbrakk> \<Longrightarrow> \<forall>x. s = f x \<longrightarrow> P"
blanchet@49255
   834
by (metis sum.exhaust)
blanchet@49255
   835
blanchet@48975
   836
lemma obj_sumE: "\<lbrakk>\<forall>x. s = Inl x \<longrightarrow> P; \<forall>x. s = Inr x \<longrightarrow> P\<rbrakk> \<Longrightarrow> P"
blanchet@48975
   837
by (cases s) auto
blanchet@48975
   838
blanchet@48975
   839
lemma obj_sum_step:
blanchet@48975
   840
  "\<lbrakk>\<forall>x. s = f (Inr (Inl x)) \<longrightarrow> P; \<forall>x. s = f (Inr (Inr x)) \<longrightarrow> P\<rbrakk> \<Longrightarrow> \<forall>x. s = f (Inr x) \<longrightarrow> P"
blanchet@48975
   841
by (metis obj_sumE)
blanchet@48975
   842
blanchet@48975
   843
lemma not_arg_cong_Inr: "x \<noteq> y \<Longrightarrow> Inr x \<noteq> Inr y"
blanchet@49255
   844
by simp
blanchet@48975
   845
blanchet@48975
   846
end