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