src/HOLCF/Cprod.thy
author huffman
Wed Jun 08 00:07:46 2005 +0200 (2005-06-08)
changeset 16315 bfb2f513916a
parent 16210 5d1b752cacc1
child 16553 aa36d41e4263
permissions -rw-r--r--
added theorem less_cprod
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@16008
    32
huffman@16081
    33
subsection {* Type @{typ "'a * 'b"} is a partial order *}
huffman@15593
    34
huffman@15593
    35
instance "*" :: (sq_ord, sq_ord) sq_ord ..
huffman@15576
    36
huffman@15576
    37
defs (overloaded)
huffman@16081
    38
  less_cprod_def: "(op \<sqsubseteq>) \<equiv> \<lambda>p1 p2. (fst p1 \<sqsubseteq> fst p2 \<and> snd p1 \<sqsubseteq> snd p2)"
huffman@15576
    39
huffman@16081
    40
lemma refl_less_cprod: "(p::'a * 'b) \<sqsubseteq> p"
huffman@16081
    41
by (simp add: less_cprod_def)
huffman@15576
    42
huffman@16081
    43
lemma antisym_less_cprod: "\<lbrakk>(p1::'a * 'b) \<sqsubseteq> p2; p2 \<sqsubseteq> p1\<rbrakk> \<Longrightarrow> p1 = p2"
huffman@15576
    44
apply (unfold less_cprod_def)
huffman@15576
    45
apply (rule injective_fst_snd)
huffman@15576
    46
apply (fast intro: antisym_less)
huffman@15576
    47
apply (fast intro: antisym_less)
huffman@15576
    48
done
huffman@15576
    49
huffman@16081
    50
lemma trans_less_cprod: "\<lbrakk>(p1::'a*'b) \<sqsubseteq> p2; p2 \<sqsubseteq> p3\<rbrakk> \<Longrightarrow> p1 \<sqsubseteq> p3"
huffman@15576
    51
apply (unfold less_cprod_def)
huffman@15576
    52
apply (fast intro: trans_less)
huffman@15576
    53
done
huffman@15576
    54
huffman@15593
    55
instance "*" :: (cpo, cpo) po
huffman@15593
    56
by intro_classes
huffman@15593
    57
  (assumption | rule refl_less_cprod antisym_less_cprod trans_less_cprod)+
huffman@15576
    58
huffman@15576
    59
huffman@15593
    60
subsection {* Monotonicity of @{text "(_,_)"}, @{term fst}, @{term snd} *}
huffman@15576
    61
huffman@15593
    62
text {* Pair @{text "(_,_)"}  is monotone in both arguments *}
huffman@15576
    63
huffman@16081
    64
lemma monofun_pair1: "monofun (\<lambda>x. (x, y))"
huffman@16210
    65
by (simp add: monofun_def less_cprod_def)
huffman@15576
    66
huffman@16081
    67
lemma monofun_pair2: "monofun (\<lambda>y. (x, y))"
huffman@16210
    68
by (simp add: monofun_def less_cprod_def)
huffman@15576
    69
huffman@16081
    70
lemma monofun_pair:
huffman@16081
    71
  "\<lbrakk>x1 \<sqsubseteq> x2; y1 \<sqsubseteq> y2\<rbrakk> \<Longrightarrow> (x1, y1) \<sqsubseteq> (x2, y2)"
huffman@16081
    72
by (simp add: less_cprod_def)
huffman@15576
    73
huffman@15593
    74
text {* @{term fst} and @{term snd} are monotone *}
huffman@15576
    75
huffman@15576
    76
lemma monofun_fst: "monofun fst"
huffman@16210
    77
by (simp add: monofun_def less_cprod_def)
huffman@15576
    78
huffman@15576
    79
lemma monofun_snd: "monofun snd"
huffman@16210
    80
by (simp add: monofun_def less_cprod_def)
huffman@15576
    81
huffman@15593
    82
subsection {* Type @{typ "'a * 'b"} is a cpo *}
huffman@15576
    83
huffman@15576
    84
lemma lub_cprod: 
huffman@16210
    85
  "chain S \<Longrightarrow> range S <<| (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
huffman@15576
    86
apply (rule is_lubI)
huffman@15576
    87
apply (rule ub_rangeI)
huffman@15576
    88
apply (rule_tac t = "S i" in surjective_pairing [THEN ssubst])
huffman@15576
    89
apply (rule monofun_pair)
huffman@15576
    90
apply (rule is_ub_thelub)
huffman@15576
    91
apply (erule monofun_fst [THEN ch2ch_monofun])
huffman@15576
    92
apply (rule is_ub_thelub)
huffman@15576
    93
apply (erule monofun_snd [THEN ch2ch_monofun])
huffman@15576
    94
apply (rule_tac t = "u" in surjective_pairing [THEN ssubst])
huffman@15576
    95
apply (rule monofun_pair)
huffman@15576
    96
apply (rule is_lub_thelub)
huffman@15576
    97
apply (erule monofun_fst [THEN ch2ch_monofun])
huffman@15576
    98
apply (erule monofun_fst [THEN ub2ub_monofun])
huffman@15576
    99
apply (rule is_lub_thelub)
huffman@15576
   100
apply (erule monofun_snd [THEN ch2ch_monofun])
huffman@15576
   101
apply (erule monofun_snd [THEN ub2ub_monofun])
huffman@15576
   102
done
huffman@15576
   103
huffman@16081
   104
lemma thelub_cprod:
huffman@16081
   105
  "chain S \<Longrightarrow> lub (range S) = (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
huffman@16081
   106
by (rule lub_cprod [THEN thelubI])
huffman@15576
   107
huffman@16081
   108
lemma cpo_cprod:
huffman@16081
   109
  "chain (S::nat \<Rightarrow> 'a::cpo * 'b::cpo) \<Longrightarrow> \<exists>x. range S <<| x"
huffman@15593
   110
by (rule exI, erule lub_cprod)
huffman@15593
   111
huffman@15609
   112
instance "*" :: (cpo, cpo) cpo
huffman@15593
   113
by intro_classes (rule cpo_cprod)
huffman@15593
   114
huffman@15593
   115
subsection {* Type @{typ "'a * 'b"} is pointed *}
huffman@15593
   116
huffman@16081
   117
lemma minimal_cprod: "(\<bottom>, \<bottom>) \<sqsubseteq> p"
huffman@16081
   118
by (simp add: less_cprod_def)
huffman@15593
   119
huffman@16081
   120
lemma least_cprod: "EX x::'a::pcpo * 'b::pcpo. ALL y. x \<sqsubseteq> y"
huffman@16081
   121
apply (rule_tac x = "(\<bottom>, \<bottom>)" in exI)
huffman@15593
   122
apply (rule minimal_cprod [THEN allI])
huffman@15593
   123
done
huffman@15593
   124
huffman@15609
   125
instance "*" :: (pcpo, pcpo) pcpo
huffman@15593
   126
by intro_classes (rule least_cprod)
huffman@15593
   127
huffman@15593
   128
text {* for compatibility with old HOLCF-Version *}
huffman@15593
   129
lemma inst_cprod_pcpo: "UU = (UU,UU)"
huffman@16081
   130
by (rule minimal_cprod [THEN UU_I, symmetric])
huffman@16081
   131
huffman@15593
   132
huffman@15593
   133
subsection {* Continuity of @{text "(_,_)"}, @{term fst}, @{term snd} *}
huffman@15593
   134
huffman@16081
   135
lemma contlub_pair1: "contlub (\<lambda>x. (x,y))"
huffman@16210
   136
apply (rule contlubI)
huffman@15593
   137
apply (subst thelub_cprod)
huffman@15593
   138
apply (erule monofun_pair1 [THEN ch2ch_monofun])
huffman@16093
   139
apply (simp add: thelub_const)
huffman@15576
   140
done
huffman@15576
   141
huffman@16081
   142
lemma contlub_pair2: "contlub (\<lambda>y. (x, y))"
huffman@16210
   143
apply (rule contlubI)
huffman@15593
   144
apply (subst thelub_cprod)
huffman@15593
   145
apply (erule monofun_pair2 [THEN ch2ch_monofun])
huffman@16093
   146
apply (simp add: thelub_const)
huffman@15593
   147
done
huffman@15593
   148
huffman@16081
   149
lemma cont_pair1: "cont (\<lambda>x. (x, y))"
huffman@15593
   150
apply (rule monocontlub2cont)
huffman@15593
   151
apply (rule monofun_pair1)
huffman@15593
   152
apply (rule contlub_pair1)
huffman@15593
   153
done
huffman@15593
   154
huffman@16081
   155
lemma cont_pair2: "cont (\<lambda>y. (x, y))"
huffman@15593
   156
apply (rule monocontlub2cont)
huffman@15593
   157
apply (rule monofun_pair2)
huffman@15593
   158
apply (rule contlub_pair2)
huffman@15593
   159
done
huffman@15576
   160
huffman@16081
   161
lemma contlub_fst: "contlub fst"
huffman@16210
   162
apply (rule contlubI)
huffman@16210
   163
apply (simp add: thelub_cprod)
huffman@15593
   164
done
huffman@15593
   165
huffman@16081
   166
lemma contlub_snd: "contlub snd"
huffman@16210
   167
apply (rule contlubI)
huffman@16210
   168
apply (simp add: thelub_cprod)
huffman@15593
   169
done
huffman@15576
   170
huffman@16081
   171
lemma cont_fst: "cont fst"
huffman@15593
   172
apply (rule monocontlub2cont)
huffman@15593
   173
apply (rule monofun_fst)
huffman@15593
   174
apply (rule contlub_fst)
huffman@15593
   175
done
huffman@15593
   176
huffman@16081
   177
lemma cont_snd: "cont snd"
huffman@15593
   178
apply (rule monocontlub2cont)
huffman@15593
   179
apply (rule monofun_snd)
huffman@15593
   180
apply (rule contlub_snd)
huffman@15593
   181
done
huffman@15593
   182
huffman@15593
   183
subsection {* Continuous versions of constants *}
huffman@15576
   184
huffman@15576
   185
consts
huffman@16081
   186
  cpair  :: "'a \<rightarrow> 'b \<rightarrow> ('a * 'b)" (* continuous pairing *)
huffman@16081
   187
  cfst   :: "('a * 'b) \<rightarrow> 'a"
huffman@16081
   188
  csnd   :: "('a * 'b) \<rightarrow> 'b"
huffman@16081
   189
  csplit :: "('a \<rightarrow> 'b \<rightarrow> 'c) \<rightarrow> ('a * 'b) \<rightarrow> 'c"
huffman@15576
   190
huffman@15576
   191
syntax
huffman@16081
   192
  "@ctuple" :: "['a, args] \<Rightarrow> 'a * 'b"  ("(1<_,/ _>)")
huffman@15576
   193
huffman@15576
   194
translations
huffman@16081
   195
  "<x, y, z>" == "<x, <y, z>>"
huffman@16081
   196
  "<x, y>"    == "cpair$x$y"
huffman@15576
   197
huffman@15576
   198
defs
huffman@16081
   199
  cpair_def:  "cpair  \<equiv> (\<Lambda> x y. (x, y))"
huffman@16081
   200
  cfst_def:   "cfst   \<equiv> (\<Lambda> p. fst p)"
huffman@16081
   201
  csnd_def:   "csnd   \<equiv> (\<Lambda> p. snd p)"      
huffman@16081
   202
  csplit_def: "csplit \<equiv> (\<Lambda> f p. f\<cdot>(cfst\<cdot>p)\<cdot>(csnd\<cdot>p))"
huffman@15576
   203
huffman@15609
   204
subsection {* Syntax *}
huffman@15576
   205
huffman@15609
   206
text {* syntax for @{text "LAM <x,y,z>.e"} *}
huffman@15576
   207
huffman@15576
   208
syntax
huffman@16081
   209
  "_LAM" :: "[patterns, 'a \<Rightarrow> 'b] \<Rightarrow> ('a \<rightarrow> 'b)"  ("(3LAM <_>./ _)" [0, 10] 10)
huffman@15576
   210
huffman@15576
   211
translations
huffman@16081
   212
  "LAM <x,y,zs>. b"       == "csplit$(LAM x. LAM <y,zs>. b)"
huffman@15576
   213
  "LAM <x,y>. LAM zs. b"  <= "csplit$(LAM x y zs. b)"
huffman@15576
   214
  "LAM <x,y>.b"           == "csplit$(LAM x y. b)"
huffman@15576
   215
huffman@15576
   216
syntax (xsymbols)
huffman@16081
   217
  "_LAM" :: "[patterns, 'a => 'b] => ('a -> 'b)"  ("(3\<Lambda>()<_>./ _)" [0, 10] 10)
huffman@15576
   218
huffman@15609
   219
text {* syntax for Let *}
huffman@15609
   220
huffman@15609
   221
constdefs
huffman@16081
   222
  CLet :: "'a \<rightarrow> ('a \<rightarrow> 'b) \<rightarrow> 'b"
huffman@16081
   223
  "CLet \<equiv> \<Lambda> s f. f\<cdot>s"
huffman@15609
   224
huffman@15609
   225
nonterminals
huffman@15609
   226
  Cletbinds  Cletbind
huffman@15609
   227
huffman@15609
   228
syntax
huffman@15609
   229
  "_Cbind"  :: "[pttrn, 'a] => Cletbind"             ("(2_ =/ _)" 10)
huffman@15609
   230
  "_Cbindp" :: "[patterns, 'a] => Cletbind"          ("(2<_> =/ _)" 10)
huffman@15609
   231
  ""        :: "Cletbind => Cletbinds"               ("_")
huffman@15609
   232
  "_Cbinds" :: "[Cletbind, Cletbinds] => Cletbinds"  ("_;/ _")
huffman@15609
   233
  "_CLet"   :: "[Cletbinds, 'a] => 'a"               ("(Let (_)/ in (_))" 10)
huffman@15609
   234
huffman@15609
   235
translations
huffman@15609
   236
  "_CLet (_Cbinds b bs) e"  == "_CLet b (_CLet bs e)"
huffman@15609
   237
  "Let x = a in LAM ys. e"  == "CLet$a$(LAM x ys. e)"
huffman@15609
   238
  "Let x = a in e"          == "CLet$a$(LAM x. e)"
huffman@15609
   239
  "Let <xs> = a in e"       == "CLet$a$(LAM <xs>. e)"
huffman@15609
   240
huffman@15593
   241
subsection {* Convert all lemmas to the continuous versions *}
huffman@15576
   242
huffman@16081
   243
lemma cpair_eq_pair: "<x, y> = (x, y)"
huffman@16081
   244
by (simp add: cpair_def cont_pair1 cont_pair2)
huffman@16081
   245
huffman@16081
   246
lemma inject_cpair: "<a,b> = <aa,ba> \<Longrightarrow> a = aa \<and> b = ba"
huffman@16081
   247
by (simp add: cpair_eq_pair)
huffman@15576
   248
huffman@16081
   249
lemma cpair_eq [iff]: "(<a, b> = <a', b'>) = (a = a' \<and> b = b')"
huffman@16081
   250
by (simp add: cpair_eq_pair)
huffman@15576
   251
huffman@16081
   252
lemma cpair_less: "(<a, b> \<sqsubseteq> <a', b'>) = (a \<sqsubseteq> a' \<and> b \<sqsubseteq> b')"
huffman@16081
   253
by (simp add: cpair_eq_pair less_cprod_def)
huffman@16057
   254
huffman@16210
   255
lemma cpair_strict: "<\<bottom>, \<bottom>> = \<bottom>"
huffman@16210
   256
by (simp add: cpair_eq_pair inst_cprod_pcpo)
huffman@16210
   257
huffman@16081
   258
lemma inst_cprod_pcpo2: "\<bottom> = <\<bottom>, \<bottom>>"
huffman@16081
   259
by (simp add: cpair_eq_pair inst_cprod_pcpo)
huffman@15576
   260
huffman@15576
   261
lemma defined_cpair_rev: 
huffman@16081
   262
 "<a,b> = \<bottom> \<Longrightarrow> a = \<bottom> \<and> b = \<bottom>"
huffman@16081
   263
by (simp add: inst_cprod_pcpo cpair_eq_pair)
huffman@16081
   264
huffman@16081
   265
lemma Exh_Cprod2: "\<exists>a b. z = <a, b>"
huffman@16081
   266
by (simp add: cpair_eq_pair)
huffman@16081
   267
huffman@16081
   268
lemma cprodE: "\<lbrakk>\<And>x y. p = <x, y> \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
huffman@16081
   269
by (cut_tac Exh_Cprod2, auto)
huffman@16081
   270
huffman@16210
   271
lemma cfst_cpair [simp]: "cfst\<cdot><x, y> = x"
huffman@16081
   272
by (simp add: cpair_eq_pair cfst_def cont_fst)
huffman@15576
   273
huffman@16210
   274
lemma csnd_cpair [simp]: "csnd\<cdot><x, y> = y"
huffman@16081
   275
by (simp add: cpair_eq_pair csnd_def cont_snd)
huffman@16081
   276
huffman@16081
   277
lemma cfst_strict [simp]: "cfst\<cdot>\<bottom> = \<bottom>"
huffman@16081
   278
by (simp add: inst_cprod_pcpo2)
huffman@16081
   279
huffman@16081
   280
lemma csnd_strict [simp]: "csnd\<cdot>\<bottom> = \<bottom>"
huffman@16081
   281
by (simp add: inst_cprod_pcpo2)
huffman@16081
   282
huffman@16081
   283
lemma surjective_pairing_Cprod2: "<cfst\<cdot>p, csnd\<cdot>p> = p"
huffman@16081
   284
apply (unfold cfst_def csnd_def)
huffman@16081
   285
apply (simp add: cont_fst cont_snd cpair_eq_pair)
huffman@15576
   286
done
huffman@15576
   287
huffman@16315
   288
lemma less_cprod: "p1 \<sqsubseteq> p2 = (cfst\<cdot>p1 \<sqsubseteq> cfst\<cdot>p2 \<and> csnd\<cdot>p1 \<sqsubseteq> csnd\<cdot>p2)"
huffman@16315
   289
by (simp add: less_cprod_def cfst_def csnd_def cont_fst cont_snd)
huffman@16315
   290
huffman@15576
   291
lemma lub_cprod2: 
huffman@16081
   292
  "chain S \<Longrightarrow> range S <<| <\<Squnion>i. cfst\<cdot>(S i), \<Squnion>i. csnd\<cdot>(S i)>"
huffman@16081
   293
apply (simp add: cpair_eq_pair cfst_def csnd_def cont_fst cont_snd)
huffman@15593
   294
apply (erule lub_cprod)
huffman@15576
   295
done
huffman@15576
   296
huffman@16081
   297
lemma thelub_cprod2:
huffman@16081
   298
  "chain S \<Longrightarrow> lub (range S) = <\<Squnion>i. cfst\<cdot>(S i), \<Squnion>i. csnd\<cdot>(S i)>"
huffman@16081
   299
by (rule lub_cprod2 [THEN thelubI])
huffman@15576
   300
huffman@16081
   301
lemma csplit2 [simp]: "csplit\<cdot>f\<cdot><x,y> = f\<cdot>x\<cdot>y"
huffman@15593
   302
by (simp add: csplit_def)
huffman@15576
   303
huffman@16081
   304
lemma csplit3: "csplit\<cdot>cpair\<cdot>z = z"
huffman@15593
   305
by (simp add: csplit_def surjective_pairing_Cprod2)
huffman@15576
   306
huffman@16210
   307
lemmas Cprod_rews = cfst_cpair csnd_cpair csplit2
huffman@15576
   308
huffman@15576
   309
end