src/HOLCF/Cprod.thy
author huffman
Tue Dec 16 21:31:55 2008 -0800 (2008-12-16)
changeset 29138 661a8db7e647
parent 27413 3154f3765cc7
child 29530 9905b660612b
permissions -rw-r--r--
remove cvs Id tags
     1 (*  Title:      HOLCF/Cprod.thy
     2     Author:     Franz Regensburger
     3 *)
     4 
     5 header {* The cpo of cartesian products *}
     6 
     7 theory Cprod
     8 imports Bifinite
     9 begin
    10 
    11 defaultsort cpo
    12 
    13 subsection {* Type @{typ unit} is a pcpo *}
    14 
    15 instantiation unit :: sq_ord
    16 begin
    17 
    18 definition
    19   less_unit_def [simp]: "x \<sqsubseteq> (y::unit) \<equiv> True"
    20 
    21 instance ..
    22 end
    23 
    24 instance unit :: discrete_cpo
    25 by intro_classes simp
    26 
    27 instance unit :: finite_po ..
    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 instantiation "*" :: (sq_ord, sq_ord) sq_ord
    46 begin
    47 
    48 definition
    49   less_cprod_def: "(op \<sqsubseteq>) \<equiv> \<lambda>p1 p2. (fst p1 \<sqsubseteq> fst p2 \<and> snd p1 \<sqsubseteq> snd p2)"
    50 
    51 instance ..
    52 end
    53 
    54 instance "*" :: (po, po) po
    55 proof
    56   fix x :: "'a \<times> 'b"
    57   show "x \<sqsubseteq> x"
    58     unfolding less_cprod_def by simp
    59 next
    60   fix x y :: "'a \<times> 'b"
    61   assume "x \<sqsubseteq> y" "y \<sqsubseteq> x" thus "x = y"
    62     unfolding less_cprod_def Pair_fst_snd_eq
    63     by (fast intro: antisym_less)
    64 next
    65   fix x y z :: "'a \<times> 'b"
    66   assume "x \<sqsubseteq> y" "y \<sqsubseteq> z" thus "x \<sqsubseteq> z"
    67     unfolding less_cprod_def
    68     by (fast intro: trans_less)
    69 qed
    70 
    71 subsection {* Monotonicity of @{text "(_,_)"}, @{term fst}, @{term snd} *}
    72 
    73 lemma prod_lessI: "\<lbrakk>fst p \<sqsubseteq> fst q; snd p \<sqsubseteq> snd q\<rbrakk> \<Longrightarrow> p \<sqsubseteq> q"
    74 unfolding less_cprod_def by simp
    75 
    76 lemma Pair_less_iff [simp]: "(a, b) \<sqsubseteq> (c, d) = (a \<sqsubseteq> c \<and> b \<sqsubseteq> d)"
    77 unfolding less_cprod_def by simp
    78 
    79 text {* Pair @{text "(_,_)"}  is monotone in both arguments *}
    80 
    81 lemma monofun_pair1: "monofun (\<lambda>x. (x, y))"
    82 by (simp add: monofun_def)
    83 
    84 lemma monofun_pair2: "monofun (\<lambda>y. (x, y))"
    85 by (simp add: monofun_def)
    86 
    87 lemma monofun_pair:
    88   "\<lbrakk>x1 \<sqsubseteq> x2; y1 \<sqsubseteq> y2\<rbrakk> \<Longrightarrow> (x1, y1) \<sqsubseteq> (x2, y2)"
    89 by simp
    90 
    91 text {* @{term fst} and @{term snd} are monotone *}
    92 
    93 lemma monofun_fst: "monofun fst"
    94 by (simp add: monofun_def less_cprod_def)
    95 
    96 lemma monofun_snd: "monofun snd"
    97 by (simp add: monofun_def less_cprod_def)
    98 
    99 subsection {* Product type is a cpo *}
   100 
   101 lemma is_lub_Pair:
   102   "\<lbrakk>range X <<| x; range Y <<| y\<rbrakk> \<Longrightarrow> range (\<lambda>i. (X i, Y i)) <<| (x, y)"
   103 apply (rule is_lubI [OF ub_rangeI])
   104 apply (simp add: less_cprod_def is_ub_lub)
   105 apply (frule ub2ub_monofun [OF monofun_fst])
   106 apply (drule ub2ub_monofun [OF monofun_snd])
   107 apply (simp add: less_cprod_def is_lub_lub)
   108 done
   109 
   110 lemma lub_cprod:
   111   fixes S :: "nat \<Rightarrow> ('a::cpo \<times> 'b::cpo)"
   112   assumes S: "chain S"
   113   shows "range S <<| (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
   114 proof -
   115   have "chain (\<lambda>i. fst (S i))"
   116     using monofun_fst S by (rule ch2ch_monofun)
   117   hence 1: "range (\<lambda>i. fst (S i)) <<| (\<Squnion>i. fst (S i))"
   118     by (rule cpo_lubI)
   119   have "chain (\<lambda>i. snd (S i))"
   120     using monofun_snd S by (rule ch2ch_monofun)
   121   hence 2: "range (\<lambda>i. snd (S i)) <<| (\<Squnion>i. snd (S i))"
   122     by (rule cpo_lubI)
   123   show "range S <<| (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
   124     using is_lub_Pair [OF 1 2] by simp
   125 qed
   126 
   127 lemma thelub_cprod:
   128   "chain (S::nat \<Rightarrow> 'a::cpo \<times> 'b::cpo)
   129     \<Longrightarrow> (\<Squnion>i. S i) = (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
   130 by (rule lub_cprod [THEN thelubI])
   131 
   132 instance "*" :: (cpo, cpo) cpo
   133 proof
   134   fix S :: "nat \<Rightarrow> ('a \<times> 'b)"
   135   assume "chain S"
   136   hence "range S <<| (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
   137     by (rule lub_cprod)
   138   thus "\<exists>x. range S <<| x" ..
   139 qed
   140 
   141 instance "*" :: (finite_po, finite_po) finite_po ..
   142 
   143 instance "*" :: (discrete_cpo, discrete_cpo) discrete_cpo
   144 proof
   145   fix x y :: "'a \<times> 'b"
   146   show "x \<sqsubseteq> y \<longleftrightarrow> x = y"
   147     unfolding less_cprod_def Pair_fst_snd_eq
   148     by simp
   149 qed
   150 
   151 subsection {* Product type is pointed *}
   152 
   153 lemma minimal_cprod: "(\<bottom>, \<bottom>) \<sqsubseteq> p"
   154 by (simp add: less_cprod_def)
   155 
   156 instance "*" :: (pcpo, pcpo) pcpo
   157 by intro_classes (fast intro: minimal_cprod)
   158 
   159 lemma inst_cprod_pcpo: "\<bottom> = (\<bottom>, \<bottom>)"
   160 by (rule minimal_cprod [THEN UU_I, symmetric])
   161 
   162 
   163 subsection {* Continuity of @{text "(_,_)"}, @{term fst}, @{term snd} *}
   164 
   165 lemma cont_pair1: "cont (\<lambda>x. (x, y))"
   166 apply (rule contI)
   167 apply (rule is_lub_Pair)
   168 apply (erule cpo_lubI)
   169 apply (rule lub_const)
   170 done
   171 
   172 lemma cont_pair2: "cont (\<lambda>y. (x, y))"
   173 apply (rule contI)
   174 apply (rule is_lub_Pair)
   175 apply (rule lub_const)
   176 apply (erule cpo_lubI)
   177 done
   178 
   179 lemma contlub_fst: "contlub fst"
   180 apply (rule contlubI)
   181 apply (simp add: thelub_cprod)
   182 done
   183 
   184 lemma contlub_snd: "contlub snd"
   185 apply (rule contlubI)
   186 apply (simp add: thelub_cprod)
   187 done
   188 
   189 lemma cont_fst: "cont fst"
   190 apply (rule monocontlub2cont)
   191 apply (rule monofun_fst)
   192 apply (rule contlub_fst)
   193 done
   194 
   195 lemma cont_snd: "cont snd"
   196 apply (rule monocontlub2cont)
   197 apply (rule monofun_snd)
   198 apply (rule contlub_snd)
   199 done
   200 
   201 subsection {* Continuous versions of constants *}
   202 
   203 definition
   204   cpair :: "'a \<rightarrow> 'b \<rightarrow> ('a * 'b)"  -- {* continuous pairing *}  where
   205   "cpair = (\<Lambda> x y. (x, y))"
   206 
   207 definition
   208   cfst :: "('a * 'b) \<rightarrow> 'a" where
   209   "cfst = (\<Lambda> p. fst p)"
   210 
   211 definition
   212   csnd :: "('a * 'b) \<rightarrow> 'b" where
   213   "csnd = (\<Lambda> p. snd p)"      
   214 
   215 definition
   216   csplit :: "('a \<rightarrow> 'b \<rightarrow> 'c) \<rightarrow> ('a * 'b) \<rightarrow> 'c" where
   217   "csplit = (\<Lambda> f p. f\<cdot>(cfst\<cdot>p)\<cdot>(csnd\<cdot>p))"
   218 
   219 syntax
   220   "_ctuple" :: "['a, args] \<Rightarrow> 'a * 'b"  ("(1<_,/ _>)")
   221 
   222 syntax (xsymbols)
   223   "_ctuple" :: "['a, args] \<Rightarrow> 'a * 'b"  ("(1\<langle>_,/ _\<rangle>)")
   224 
   225 translations
   226   "\<langle>x, y, z\<rangle>" == "\<langle>x, \<langle>y, z\<rangle>\<rangle>"
   227   "\<langle>x, y\<rangle>"    == "CONST cpair\<cdot>x\<cdot>y"
   228 
   229 translations
   230   "\<Lambda>(CONST cpair\<cdot>x\<cdot>y). t" == "CONST csplit\<cdot>(\<Lambda> x y. t)"
   231 
   232 
   233 subsection {* Convert all lemmas to the continuous versions *}
   234 
   235 lemma cpair_eq_pair: "<x, y> = (x, y)"
   236 by (simp add: cpair_def cont_pair1 cont_pair2)
   237 
   238 lemma pair_eq_cpair: "(x, y) = <x, y>"
   239 by (simp add: cpair_def cont_pair1 cont_pair2)
   240 
   241 lemma inject_cpair: "<a,b> = <aa,ba> \<Longrightarrow> a = aa \<and> b = ba"
   242 by (simp add: cpair_eq_pair)
   243 
   244 lemma cpair_eq [iff]: "(<a, b> = <a', b'>) = (a = a' \<and> b = b')"
   245 by (simp add: cpair_eq_pair)
   246 
   247 lemma cpair_less [iff]: "(<a, b> \<sqsubseteq> <a', b'>) = (a \<sqsubseteq> a' \<and> b \<sqsubseteq> b')"
   248 by (simp add: cpair_eq_pair less_cprod_def)
   249 
   250 lemma cpair_defined_iff [iff]: "(<x, y> = \<bottom>) = (x = \<bottom> \<and> y = \<bottom>)"
   251 by (simp add: inst_cprod_pcpo cpair_eq_pair)
   252 
   253 lemma cpair_strict [simp]: "\<langle>\<bottom>, \<bottom>\<rangle> = \<bottom>"
   254 by simp
   255 
   256 lemma inst_cprod_pcpo2: "\<bottom> = <\<bottom>, \<bottom>>"
   257 by (rule cpair_strict [symmetric])
   258 
   259 lemma defined_cpair_rev: 
   260  "<a,b> = \<bottom> \<Longrightarrow> a = \<bottom> \<and> b = \<bottom>"
   261 by simp
   262 
   263 lemma Exh_Cprod2: "\<exists>a b. z = <a, b>"
   264 by (simp add: cpair_eq_pair)
   265 
   266 lemma cprodE: "\<lbrakk>\<And>x y. p = <x, y> \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
   267 by (cut_tac Exh_Cprod2, auto)
   268 
   269 lemma cfst_cpair [simp]: "cfst\<cdot><x, y> = x"
   270 by (simp add: cpair_eq_pair cfst_def cont_fst)
   271 
   272 lemma csnd_cpair [simp]: "csnd\<cdot><x, y> = y"
   273 by (simp add: cpair_eq_pair csnd_def cont_snd)
   274 
   275 lemma cfst_strict [simp]: "cfst\<cdot>\<bottom> = \<bottom>"
   276 unfolding inst_cprod_pcpo2 by (rule cfst_cpair)
   277 
   278 lemma csnd_strict [simp]: "csnd\<cdot>\<bottom> = \<bottom>"
   279 unfolding inst_cprod_pcpo2 by (rule csnd_cpair)
   280 
   281 lemma cpair_cfst_csnd: "\<langle>cfst\<cdot>p, csnd\<cdot>p\<rangle> = p"
   282 by (cases p rule: cprodE, simp)
   283 
   284 lemmas surjective_pairing_Cprod2 = cpair_cfst_csnd
   285 
   286 lemma less_cprod: "x \<sqsubseteq> y = (cfst\<cdot>x \<sqsubseteq> cfst\<cdot>y \<and> csnd\<cdot>x \<sqsubseteq> csnd\<cdot>y)"
   287 by (simp add: less_cprod_def cfst_def csnd_def cont_fst cont_snd)
   288 
   289 lemma eq_cprod: "(x = y) = (cfst\<cdot>x = cfst\<cdot>y \<and> csnd\<cdot>x = csnd\<cdot>y)"
   290 by (auto simp add: po_eq_conv less_cprod)
   291 
   292 lemma cfst_less_iff: "cfst\<cdot>x \<sqsubseteq> y = x \<sqsubseteq> <y, csnd\<cdot>x>"
   293 by (simp add: less_cprod)
   294 
   295 lemma csnd_less_iff: "csnd\<cdot>x \<sqsubseteq> y = x \<sqsubseteq> <cfst\<cdot>x, y>"
   296 by (simp add: less_cprod)
   297 
   298 lemma compact_cfst: "compact x \<Longrightarrow> compact (cfst\<cdot>x)"
   299 by (rule compactI, simp add: cfst_less_iff)
   300 
   301 lemma compact_csnd: "compact x \<Longrightarrow> compact (csnd\<cdot>x)"
   302 by (rule compactI, simp add: csnd_less_iff)
   303 
   304 lemma compact_cpair: "\<lbrakk>compact x; compact y\<rbrakk> \<Longrightarrow> compact <x, y>"
   305 by (rule compactI, simp add: less_cprod)
   306 
   307 lemma compact_cpair_iff [simp]: "compact <x, y> = (compact x \<and> compact y)"
   308 apply (safe intro!: compact_cpair)
   309 apply (drule compact_cfst, simp)
   310 apply (drule compact_csnd, simp)
   311 done
   312 
   313 instance "*" :: (chfin, chfin) chfin
   314 apply intro_classes
   315 apply (erule compact_imp_max_in_chain)
   316 apply (rule_tac p="\<Squnion>i. Y i" in cprodE, simp)
   317 done
   318 
   319 lemma lub_cprod2: 
   320   "chain S \<Longrightarrow> range S <<| <\<Squnion>i. cfst\<cdot>(S i), \<Squnion>i. csnd\<cdot>(S i)>"
   321 apply (simp add: cpair_eq_pair cfst_def csnd_def cont_fst cont_snd)
   322 apply (erule lub_cprod)
   323 done
   324 
   325 lemma thelub_cprod2:
   326   "chain S \<Longrightarrow> (\<Squnion>i. S i) = <\<Squnion>i. cfst\<cdot>(S i), \<Squnion>i. csnd\<cdot>(S i)>"
   327 by (rule lub_cprod2 [THEN thelubI])
   328 
   329 lemma csplit1 [simp]: "csplit\<cdot>f\<cdot>\<bottom> = f\<cdot>\<bottom>\<cdot>\<bottom>"
   330 by (simp add: csplit_def)
   331 
   332 lemma csplit2 [simp]: "csplit\<cdot>f\<cdot><x,y> = f\<cdot>x\<cdot>y"
   333 by (simp add: csplit_def)
   334 
   335 lemma csplit3 [simp]: "csplit\<cdot>cpair\<cdot>z = z"
   336 by (simp add: csplit_def cpair_cfst_csnd)
   337 
   338 lemmas Cprod_rews = cfst_cpair csnd_cpair csplit2
   339 
   340 subsection {* Product type is a bifinite domain *}
   341 
   342 instantiation "*" :: (profinite, profinite) profinite
   343 begin
   344 
   345 definition
   346   approx_cprod_def:
   347     "approx = (\<lambda>n. \<Lambda>\<langle>x, y\<rangle>. \<langle>approx n\<cdot>x, approx n\<cdot>y\<rangle>)"
   348 
   349 instance proof
   350   fix i :: nat and x :: "'a \<times> 'b"
   351   show "chain (approx :: nat \<Rightarrow> 'a \<times> 'b \<rightarrow> 'a \<times> 'b)"
   352     unfolding approx_cprod_def by simp
   353   show "(\<Squnion>i. approx i\<cdot>x) = x"
   354     unfolding approx_cprod_def
   355     by (simp add: lub_distribs eta_cfun)
   356   show "approx i\<cdot>(approx i\<cdot>x) = approx i\<cdot>x"
   357     unfolding approx_cprod_def csplit_def by simp
   358   have "{x::'a \<times> 'b. approx i\<cdot>x = x} \<subseteq>
   359         {x::'a. approx i\<cdot>x = x} \<times> {x::'b. approx i\<cdot>x = x}"
   360     unfolding approx_cprod_def
   361     by (clarsimp simp add: pair_eq_cpair)
   362   thus "finite {x::'a \<times> 'b. approx i\<cdot>x = x}"
   363     by (rule finite_subset,
   364         intro finite_cartesian_product finite_fixes_approx)
   365 qed
   366 
   367 end
   368 
   369 instance "*" :: (bifinite, bifinite) bifinite ..
   370 
   371 lemma approx_cpair [simp]:
   372   "approx i\<cdot>\<langle>x, y\<rangle> = \<langle>approx i\<cdot>x, approx i\<cdot>y\<rangle>"
   373 unfolding approx_cprod_def by simp
   374 
   375 lemma cfst_approx: "cfst\<cdot>(approx i\<cdot>p) = approx i\<cdot>(cfst\<cdot>p)"
   376 by (cases p rule: cprodE, simp)
   377 
   378 lemma csnd_approx: "csnd\<cdot>(approx i\<cdot>p) = approx i\<cdot>(csnd\<cdot>p)"
   379 by (cases p rule: cprodE, simp)
   380 
   381 end