src/HOLCF/Cprod.thy
author huffman
Wed Nov 30 00:53:30 2005 +0100 (2005-11-30)
changeset 18289 56ddf617d6e8
parent 18078 20e5a6440790
child 25131 2c8caac48ade
permissions -rw-r--r--
add constant unit_when
huffman@15600
     1
(*  Title:      HOLCF/Cprod.thy
huffman@15576
     2
    ID:         $Id$
huffman@15576
     3
    Author:     Franz Regensburger
huffman@15576
     4
wenzelm@16070
     5
Partial ordering for cartesian product of HOL products.
huffman@15576
     6
*)
huffman@15576
     7
huffman@15576
     8
header {* The cpo of cartesian products *}
huffman@15576
     9
huffman@15577
    10
theory Cprod
huffman@15577
    11
imports Cfun
huffman@15577
    12
begin
huffman@15576
    13
huffman@15576
    14
defaultsort cpo
huffman@15576
    15
huffman@16008
    16
subsection {* Type @{typ unit} is a pcpo *}
huffman@16008
    17
huffman@16008
    18
instance unit :: sq_ord ..
huffman@16008
    19
huffman@16008
    20
defs (overloaded)
huffman@16008
    21
  less_unit_def [simp]: "x \<sqsubseteq> (y::unit) \<equiv> True"
huffman@16008
    22
huffman@16008
    23
instance unit :: po
huffman@16008
    24
by intro_classes simp_all
huffman@16008
    25
huffman@16008
    26
instance unit :: cpo
huffman@16008
    27
by intro_classes (simp add: is_lub_def is_ub_def)
huffman@16008
    28
huffman@16008
    29
instance unit :: pcpo
huffman@16008
    30
by intro_classes simp
huffman@16008
    31
huffman@18289
    32
constdefs
huffman@18289
    33
  unit_when :: "'a \<rightarrow> unit \<rightarrow> 'a"
huffman@18289
    34
  "unit_when \<equiv> \<Lambda> a _. a"
huffman@16008
    35
huffman@18289
    36
translations
huffman@18289
    37
  "\<Lambda>(). t" == "unit_when\<cdot>t"
huffman@18289
    38
huffman@18289
    39
lemma unit_when [simp]: "unit_when\<cdot>a\<cdot>u = a"
huffman@18289
    40
by (simp add: unit_when_def)
huffman@18289
    41
huffman@18289
    42
huffman@18289
    43
subsection {* Product type is a partial order *}
huffman@15593
    44
huffman@15593
    45
instance "*" :: (sq_ord, sq_ord) sq_ord ..
huffman@15576
    46
huffman@15576
    47
defs (overloaded)
huffman@16081
    48
  less_cprod_def: "(op \<sqsubseteq>) \<equiv> \<lambda>p1 p2. (fst p1 \<sqsubseteq> fst p2 \<and> snd p1 \<sqsubseteq> snd p2)"
huffman@15576
    49
huffman@16081
    50
lemma refl_less_cprod: "(p::'a * 'b) \<sqsubseteq> p"
huffman@16081
    51
by (simp add: less_cprod_def)
huffman@15576
    52
huffman@16081
    53
lemma antisym_less_cprod: "\<lbrakk>(p1::'a * 'b) \<sqsubseteq> p2; p2 \<sqsubseteq> p1\<rbrakk> \<Longrightarrow> p1 = p2"
huffman@15576
    54
apply (unfold less_cprod_def)
huffman@15576
    55
apply (rule injective_fst_snd)
huffman@15576
    56
apply (fast intro: antisym_less)
huffman@15576
    57
apply (fast intro: antisym_less)
huffman@15576
    58
done
huffman@15576
    59
huffman@16081
    60
lemma trans_less_cprod: "\<lbrakk>(p1::'a*'b) \<sqsubseteq> p2; p2 \<sqsubseteq> p3\<rbrakk> \<Longrightarrow> p1 \<sqsubseteq> p3"
huffman@15576
    61
apply (unfold less_cprod_def)
huffman@15576
    62
apply (fast intro: trans_less)
huffman@15576
    63
done
huffman@15576
    64
huffman@15593
    65
instance "*" :: (cpo, cpo) po
huffman@15593
    66
by intro_classes
huffman@15593
    67
  (assumption | rule refl_less_cprod antisym_less_cprod trans_less_cprod)+
huffman@15576
    68
huffman@15576
    69
huffman@15593
    70
subsection {* Monotonicity of @{text "(_,_)"}, @{term fst}, @{term snd} *}
huffman@15576
    71
huffman@15593
    72
text {* Pair @{text "(_,_)"}  is monotone in both arguments *}
huffman@15576
    73
huffman@16081
    74
lemma monofun_pair1: "monofun (\<lambda>x. (x, y))"
huffman@16210
    75
by (simp add: monofun_def less_cprod_def)
huffman@15576
    76
huffman@16081
    77
lemma monofun_pair2: "monofun (\<lambda>y. (x, y))"
huffman@16210
    78
by (simp add: monofun_def less_cprod_def)
huffman@15576
    79
huffman@16081
    80
lemma monofun_pair:
huffman@16081
    81
  "\<lbrakk>x1 \<sqsubseteq> x2; y1 \<sqsubseteq> y2\<rbrakk> \<Longrightarrow> (x1, y1) \<sqsubseteq> (x2, y2)"
huffman@16081
    82
by (simp add: less_cprod_def)
huffman@15576
    83
huffman@15593
    84
text {* @{term fst} and @{term snd} are monotone *}
huffman@15576
    85
huffman@15576
    86
lemma monofun_fst: "monofun fst"
huffman@16210
    87
by (simp add: monofun_def less_cprod_def)
huffman@15576
    88
huffman@15576
    89
lemma monofun_snd: "monofun snd"
huffman@16210
    90
by (simp add: monofun_def less_cprod_def)
huffman@15576
    91
huffman@18289
    92
subsection {* Product type is a cpo *}
huffman@15576
    93
huffman@15576
    94
lemma lub_cprod: 
huffman@16210
    95
  "chain S \<Longrightarrow> range S <<| (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
huffman@15576
    96
apply (rule is_lubI)
huffman@15576
    97
apply (rule ub_rangeI)
huffman@15576
    98
apply (rule_tac t = "S i" in surjective_pairing [THEN ssubst])
huffman@15576
    99
apply (rule monofun_pair)
huffman@15576
   100
apply (rule is_ub_thelub)
huffman@15576
   101
apply (erule monofun_fst [THEN ch2ch_monofun])
huffman@15576
   102
apply (rule is_ub_thelub)
huffman@15576
   103
apply (erule monofun_snd [THEN ch2ch_monofun])
huffman@15576
   104
apply (rule_tac t = "u" in surjective_pairing [THEN ssubst])
huffman@15576
   105
apply (rule monofun_pair)
huffman@15576
   106
apply (rule is_lub_thelub)
huffman@15576
   107
apply (erule monofun_fst [THEN ch2ch_monofun])
huffman@15576
   108
apply (erule monofun_fst [THEN ub2ub_monofun])
huffman@15576
   109
apply (rule is_lub_thelub)
huffman@15576
   110
apply (erule monofun_snd [THEN ch2ch_monofun])
huffman@15576
   111
apply (erule monofun_snd [THEN ub2ub_monofun])
huffman@15576
   112
done
huffman@15576
   113
huffman@16081
   114
lemma thelub_cprod:
huffman@16081
   115
  "chain S \<Longrightarrow> lub (range S) = (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
huffman@16081
   116
by (rule lub_cprod [THEN thelubI])
huffman@15576
   117
huffman@16081
   118
lemma cpo_cprod:
huffman@16081
   119
  "chain (S::nat \<Rightarrow> 'a::cpo * 'b::cpo) \<Longrightarrow> \<exists>x. range S <<| x"
huffman@15593
   120
by (rule exI, erule lub_cprod)
huffman@15593
   121
huffman@15609
   122
instance "*" :: (cpo, cpo) cpo
huffman@15593
   123
by intro_classes (rule cpo_cprod)
huffman@15593
   124
huffman@18289
   125
subsection {* Product type is pointed *}
huffman@15593
   126
huffman@16081
   127
lemma minimal_cprod: "(\<bottom>, \<bottom>) \<sqsubseteq> p"
huffman@16081
   128
by (simp add: less_cprod_def)
huffman@15593
   129
huffman@16081
   130
lemma least_cprod: "EX x::'a::pcpo * 'b::pcpo. ALL y. x \<sqsubseteq> y"
huffman@16081
   131
apply (rule_tac x = "(\<bottom>, \<bottom>)" in exI)
huffman@15593
   132
apply (rule minimal_cprod [THEN allI])
huffman@15593
   133
done
huffman@15593
   134
huffman@15609
   135
instance "*" :: (pcpo, pcpo) pcpo
huffman@15593
   136
by intro_classes (rule least_cprod)
huffman@15593
   137
huffman@15593
   138
text {* for compatibility with old HOLCF-Version *}
huffman@15593
   139
lemma inst_cprod_pcpo: "UU = (UU,UU)"
huffman@16081
   140
by (rule minimal_cprod [THEN UU_I, symmetric])
huffman@16081
   141
huffman@15593
   142
huffman@15593
   143
subsection {* Continuity of @{text "(_,_)"}, @{term fst}, @{term snd} *}
huffman@15593
   144
huffman@16916
   145
lemma contlub_pair1: "contlub (\<lambda>x. (x, y))"
huffman@16210
   146
apply (rule contlubI)
huffman@15593
   147
apply (subst thelub_cprod)
huffman@15593
   148
apply (erule monofun_pair1 [THEN ch2ch_monofun])
huffman@18077
   149
apply simp
huffman@15576
   150
done
huffman@15576
   151
huffman@16081
   152
lemma contlub_pair2: "contlub (\<lambda>y. (x, y))"
huffman@16210
   153
apply (rule contlubI)
huffman@15593
   154
apply (subst thelub_cprod)
huffman@15593
   155
apply (erule monofun_pair2 [THEN ch2ch_monofun])
huffman@18077
   156
apply simp
huffman@15593
   157
done
huffman@15593
   158
huffman@16081
   159
lemma cont_pair1: "cont (\<lambda>x. (x, y))"
huffman@15593
   160
apply (rule monocontlub2cont)
huffman@15593
   161
apply (rule monofun_pair1)
huffman@15593
   162
apply (rule contlub_pair1)
huffman@15593
   163
done
huffman@15593
   164
huffman@16081
   165
lemma cont_pair2: "cont (\<lambda>y. (x, y))"
huffman@15593
   166
apply (rule monocontlub2cont)
huffman@15593
   167
apply (rule monofun_pair2)
huffman@15593
   168
apply (rule contlub_pair2)
huffman@15593
   169
done
huffman@15576
   170
huffman@16081
   171
lemma contlub_fst: "contlub fst"
huffman@16210
   172
apply (rule contlubI)
huffman@16210
   173
apply (simp add: thelub_cprod)
huffman@15593
   174
done
huffman@15593
   175
huffman@16081
   176
lemma contlub_snd: "contlub snd"
huffman@16210
   177
apply (rule contlubI)
huffman@16210
   178
apply (simp add: thelub_cprod)
huffman@15593
   179
done
huffman@15576
   180
huffman@16081
   181
lemma cont_fst: "cont fst"
huffman@15593
   182
apply (rule monocontlub2cont)
huffman@15593
   183
apply (rule monofun_fst)
huffman@15593
   184
apply (rule contlub_fst)
huffman@15593
   185
done
huffman@15593
   186
huffman@16081
   187
lemma cont_snd: "cont snd"
huffman@15593
   188
apply (rule monocontlub2cont)
huffman@15593
   189
apply (rule monofun_snd)
huffman@15593
   190
apply (rule contlub_snd)
huffman@15593
   191
done
huffman@15593
   192
huffman@15593
   193
subsection {* Continuous versions of constants *}
huffman@15576
   194
huffman@17834
   195
constdefs
huffman@17834
   196
  cpair :: "'a \<rightarrow> 'b \<rightarrow> ('a * 'b)" (* continuous pairing *)
huffman@17834
   197
  "cpair \<equiv> (\<Lambda> x y. (x, y))"
huffman@17834
   198
huffman@17834
   199
  cfst :: "('a * 'b) \<rightarrow> 'a"
huffman@17834
   200
  "cfst \<equiv> (\<Lambda> p. fst p)"
huffman@17834
   201
huffman@17834
   202
  csnd :: "('a * 'b) \<rightarrow> 'b"
huffman@17834
   203
  "csnd \<equiv> (\<Lambda> p. snd p)"      
huffman@17834
   204
huffman@16081
   205
  csplit :: "('a \<rightarrow> 'b \<rightarrow> 'c) \<rightarrow> ('a * 'b) \<rightarrow> 'c"
huffman@17834
   206
  "csplit \<equiv> (\<Lambda> f p. f\<cdot>(cfst\<cdot>p)\<cdot>(csnd\<cdot>p))"
huffman@15576
   207
huffman@15576
   208
syntax
huffman@17834
   209
  "_ctuple" :: "['a, args] \<Rightarrow> 'a * 'b"  ("(1<_,/ _>)")
huffman@17834
   210
huffman@17834
   211
syntax (xsymbols)
huffman@17834
   212
  "_ctuple" :: "['a, args] \<Rightarrow> 'a * 'b"  ("(1\<langle>_,/ _\<rangle>)")
huffman@15576
   213
huffman@15576
   214
translations
huffman@18078
   215
  "\<langle>x, y, z\<rangle>" == "\<langle>x, \<langle>y, z\<rangle>\<rangle>"
huffman@18078
   216
  "\<langle>x, y\<rangle>"    == "cpair\<cdot>x\<cdot>y"
huffman@17834
   217
huffman@17816
   218
translations
huffman@18078
   219
  "\<Lambda>(cpair\<cdot>x\<cdot>y). t" == "csplit\<cdot>(\<Lambda> x y. t)"
huffman@17816
   220
huffman@15576
   221
huffman@15593
   222
subsection {* Convert all lemmas to the continuous versions *}
huffman@15576
   223
huffman@16081
   224
lemma cpair_eq_pair: "<x, y> = (x, y)"
huffman@16081
   225
by (simp add: cpair_def cont_pair1 cont_pair2)
huffman@16081
   226
huffman@16081
   227
lemma inject_cpair: "<a,b> = <aa,ba> \<Longrightarrow> a = aa \<and> b = ba"
huffman@16081
   228
by (simp add: cpair_eq_pair)
huffman@15576
   229
huffman@16081
   230
lemma cpair_eq [iff]: "(<a, b> = <a', b'>) = (a = a' \<and> b = b')"
huffman@16081
   231
by (simp add: cpair_eq_pair)
huffman@15576
   232
huffman@18077
   233
lemma cpair_less [iff]: "(<a, b> \<sqsubseteq> <a', b'>) = (a \<sqsubseteq> a' \<and> b \<sqsubseteq> b')"
huffman@16081
   234
by (simp add: cpair_eq_pair less_cprod_def)
huffman@16057
   235
huffman@18077
   236
lemma cpair_defined_iff [iff]: "(<x, y> = \<bottom>) = (x = \<bottom> \<and> y = \<bottom>)"
huffman@16916
   237
by (simp add: inst_cprod_pcpo cpair_eq_pair)
huffman@16916
   238
huffman@16210
   239
lemma cpair_strict: "<\<bottom>, \<bottom>> = \<bottom>"
huffman@18077
   240
by simp
huffman@16210
   241
huffman@16081
   242
lemma inst_cprod_pcpo2: "\<bottom> = <\<bottom>, \<bottom>>"
huffman@16916
   243
by (rule cpair_strict [symmetric])
huffman@15576
   244
huffman@15576
   245
lemma defined_cpair_rev: 
huffman@16081
   246
 "<a,b> = \<bottom> \<Longrightarrow> a = \<bottom> \<and> b = \<bottom>"
huffman@18077
   247
by simp
huffman@16081
   248
huffman@16081
   249
lemma Exh_Cprod2: "\<exists>a b. z = <a, b>"
huffman@16081
   250
by (simp add: cpair_eq_pair)
huffman@16081
   251
huffman@16081
   252
lemma cprodE: "\<lbrakk>\<And>x y. p = <x, y> \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
huffman@16081
   253
by (cut_tac Exh_Cprod2, auto)
huffman@16081
   254
huffman@16210
   255
lemma cfst_cpair [simp]: "cfst\<cdot><x, y> = x"
huffman@16081
   256
by (simp add: cpair_eq_pair cfst_def cont_fst)
huffman@15576
   257
huffman@16210
   258
lemma csnd_cpair [simp]: "csnd\<cdot><x, y> = y"
huffman@16081
   259
by (simp add: cpair_eq_pair csnd_def cont_snd)
huffman@16081
   260
huffman@16081
   261
lemma cfst_strict [simp]: "cfst\<cdot>\<bottom> = \<bottom>"
huffman@16081
   262
by (simp add: inst_cprod_pcpo2)
huffman@16081
   263
huffman@16081
   264
lemma csnd_strict [simp]: "csnd\<cdot>\<bottom> = \<bottom>"
huffman@16081
   265
by (simp add: inst_cprod_pcpo2)
huffman@16081
   266
huffman@16081
   267
lemma surjective_pairing_Cprod2: "<cfst\<cdot>p, csnd\<cdot>p> = p"
huffman@16081
   268
apply (unfold cfst_def csnd_def)
huffman@16081
   269
apply (simp add: cont_fst cont_snd cpair_eq_pair)
huffman@15576
   270
done
huffman@15576
   271
huffman@16750
   272
lemma less_cprod: "x \<sqsubseteq> y = (cfst\<cdot>x \<sqsubseteq> cfst\<cdot>y \<and> csnd\<cdot>x \<sqsubseteq> csnd\<cdot>y)"
huffman@16315
   273
by (simp add: less_cprod_def cfst_def csnd_def cont_fst cont_snd)
huffman@16315
   274
huffman@16750
   275
lemma eq_cprod: "(x = y) = (cfst\<cdot>x = cfst\<cdot>y \<and> csnd\<cdot>x = csnd\<cdot>y)"
huffman@16750
   276
by (auto simp add: po_eq_conv less_cprod)
huffman@16750
   277
huffman@17837
   278
lemma compact_cpair [simp]: "\<lbrakk>compact x; compact y\<rbrakk> \<Longrightarrow> compact <x, y>"
huffman@17837
   279
by (rule compactI, simp add: less_cprod)
huffman@17837
   280
huffman@15576
   281
lemma lub_cprod2: 
huffman@16081
   282
  "chain S \<Longrightarrow> range S <<| <\<Squnion>i. cfst\<cdot>(S i), \<Squnion>i. csnd\<cdot>(S i)>"
huffman@16081
   283
apply (simp add: cpair_eq_pair cfst_def csnd_def cont_fst cont_snd)
huffman@15593
   284
apply (erule lub_cprod)
huffman@15576
   285
done
huffman@15576
   286
huffman@16081
   287
lemma thelub_cprod2:
huffman@16081
   288
  "chain S \<Longrightarrow> lub (range S) = <\<Squnion>i. cfst\<cdot>(S i), \<Squnion>i. csnd\<cdot>(S i)>"
huffman@16081
   289
by (rule lub_cprod2 [THEN thelubI])
huffman@15576
   290
huffman@18077
   291
lemma csplit1 [simp]: "csplit\<cdot>f\<cdot>\<bottom> = f\<cdot>\<bottom>\<cdot>\<bottom>"
huffman@18077
   292
by (simp add: csplit_def)
huffman@18077
   293
huffman@16081
   294
lemma csplit2 [simp]: "csplit\<cdot>f\<cdot><x,y> = f\<cdot>x\<cdot>y"
huffman@15593
   295
by (simp add: csplit_def)
huffman@15576
   296
huffman@16553
   297
lemma csplit3 [simp]: "csplit\<cdot>cpair\<cdot>z = z"
huffman@15593
   298
by (simp add: csplit_def surjective_pairing_Cprod2)
huffman@15576
   299
huffman@16210
   300
lemmas Cprod_rews = cfst_cpair csnd_cpair csplit2
huffman@15576
   301
huffman@15576
   302
end