src/HOLCF/Cprod.thy
author huffman
Wed Jan 02 18:29:03 2008 +0100 (2008-01-02)
changeset 25784 71157f7e671e
parent 25131 2c8caac48ade
child 25815 c7b1e7b7087b
permissions -rw-r--r--
update instance proofs for sq_ord, po; new instance proofs for dcpo
     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 instantiation unit :: sq_ord
    19 begin
    20 
    21 definition
    22   less_unit_def [simp]: "x \<sqsubseteq> (y::unit) \<equiv> True"
    23 
    24 instance ..
    25 end
    26 
    27 instance unit :: po
    28 by intro_classes simp_all
    29 
    30 instance unit :: dcpo
    31 by intro_classes (simp add: is_lub_def is_ub_def)
    32 
    33 instance unit :: pcpo
    34 by intro_classes simp
    35 
    36 definition
    37   unit_when :: "'a \<rightarrow> unit \<rightarrow> 'a" where
    38   "unit_when = (\<Lambda> a _. a)"
    39 
    40 translations
    41   "\<Lambda>(). t" == "CONST unit_when\<cdot>t"
    42 
    43 lemma unit_when [simp]: "unit_when\<cdot>a\<cdot>u = a"
    44 by (simp add: unit_when_def)
    45 
    46 
    47 subsection {* Product type is a partial order *}
    48 
    49 instantiation "*" :: (sq_ord, sq_ord) sq_ord
    50 begin
    51 
    52 definition
    53   less_cprod_def: "(op \<sqsubseteq>) \<equiv> \<lambda>p1 p2. (fst p1 \<sqsubseteq> fst p2 \<and> snd p1 \<sqsubseteq> snd p2)"
    54 
    55 instance ..
    56 end
    57 
    58 instance "*" :: (po, po) po
    59 proof
    60   fix x :: "'a \<times> 'b"
    61   show "x \<sqsubseteq> x"
    62     unfolding less_cprod_def by simp
    63 next
    64   fix x y :: "'a \<times> 'b"
    65   assume "x \<sqsubseteq> y" "y \<sqsubseteq> x" thus "x = y"
    66     unfolding less_cprod_def Pair_fst_snd_eq
    67     by (fast intro: antisym_less)
    68 next
    69   fix x y z :: "'a \<times> 'b"
    70   assume "x \<sqsubseteq> y" "y \<sqsubseteq> z" thus "x \<sqsubseteq> z"
    71     unfolding less_cprod_def
    72     by (fast intro: trans_less)
    73 qed
    74 
    75 
    76 subsection {* Monotonicity of @{text "(_,_)"}, @{term fst}, @{term snd} *}
    77 
    78 text {* Pair @{text "(_,_)"}  is monotone in both arguments *}
    79 
    80 lemma monofun_pair1: "monofun (\<lambda>x. (x, y))"
    81 by (simp add: monofun_def less_cprod_def)
    82 
    83 lemma monofun_pair2: "monofun (\<lambda>y. (x, y))"
    84 by (simp add: monofun_def less_cprod_def)
    85 
    86 lemma monofun_pair:
    87   "\<lbrakk>x1 \<sqsubseteq> x2; y1 \<sqsubseteq> y2\<rbrakk> \<Longrightarrow> (x1, y1) \<sqsubseteq> (x2, y2)"
    88 by (simp add: less_cprod_def)
    89 
    90 text {* @{term fst} and @{term snd} are monotone *}
    91 
    92 lemma monofun_fst: "monofun fst"
    93 by (simp add: monofun_def less_cprod_def)
    94 
    95 lemma monofun_snd: "monofun snd"
    96 by (simp add: monofun_def less_cprod_def)
    97 
    98 subsection {* Product type is a cpo *}
    99 
   100 lemma lub_cprod:
   101   fixes S :: "nat \<Rightarrow> ('a::cpo \<times> 'b::cpo)"
   102   assumes S: "chain S"
   103   shows "range S <<| (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
   104 apply (rule is_lubI)
   105 apply (rule ub_rangeI)
   106 apply (rule_tac t = "S i" in surjective_pairing [THEN ssubst])
   107 apply (rule monofun_pair)
   108 apply (rule is_ub_thelub)
   109 apply (rule ch2ch_monofun [OF monofun_fst S])
   110 apply (rule is_ub_thelub)
   111 apply (rule ch2ch_monofun [OF monofun_snd S])
   112 apply (rule_tac t = "u" in surjective_pairing [THEN ssubst])
   113 apply (rule monofun_pair)
   114 apply (rule is_lub_thelub)
   115 apply (rule ch2ch_monofun [OF monofun_fst S])
   116 apply (erule monofun_fst [THEN ub2ub_monofun])
   117 apply (rule is_lub_thelub)
   118 apply (rule ch2ch_monofun [OF monofun_snd S])
   119 apply (erule monofun_snd [THEN ub2ub_monofun])
   120 done
   121 
   122 lemma directed_lub_cprod:
   123   fixes S :: "('a::dcpo \<times> 'b::dcpo) set"
   124   assumes S: "directed S"
   125   shows "S <<| (\<Squnion>x\<in>S. fst x, \<Squnion>x\<in>S. snd x)"
   126 apply (rule is_lubI)
   127 apply (rule is_ubI)
   128 apply (rule_tac t=x in surjective_pairing [THEN ssubst])
   129 apply (rule monofun_pair)
   130 apply (erule is_ub_thelub' [OF dir2dir_monofun [OF monofun_fst S] imageI])
   131 apply (erule is_ub_thelub' [OF dir2dir_monofun [OF monofun_snd S] imageI])
   132 apply (rule_tac t=u in surjective_pairing [THEN ssubst])
   133 apply (rule monofun_pair)
   134 apply (rule is_lub_thelub')
   135 apply (rule dir2dir_monofun [OF monofun_fst S])
   136 apply (erule ub2ub_monofun' [OF monofun_fst])
   137 apply (rule is_lub_thelub')
   138 apply (rule dir2dir_monofun [OF monofun_snd S])
   139 apply (erule ub2ub_monofun' [OF monofun_snd])
   140 done
   141 
   142 lemma thelub_cprod:
   143   "chain (S::nat \<Rightarrow> 'a::cpo \<times> 'b::cpo)
   144     \<Longrightarrow> lub (range S) = (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
   145 by (rule lub_cprod [THEN thelubI])
   146 
   147 instance "*" :: (cpo, cpo) cpo
   148 proof
   149   fix S :: "nat \<Rightarrow> ('a \<times> 'b)"
   150   assume "chain S"
   151   hence "range S <<| (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
   152     by (rule lub_cprod)
   153   thus "\<exists>x. range S <<| x" ..
   154 qed
   155 
   156 instance "*" :: (dcpo, dcpo) dcpo
   157 proof
   158   fix S :: "('a \<times> 'b) set"
   159   assume "directed S"
   160   hence "S <<| (\<Squnion>x\<in>S. fst x, \<Squnion>x\<in>S. snd x)"
   161     by (rule directed_lub_cprod)
   162   thus "\<exists>x. S <<| x" ..
   163 qed
   164 
   165 subsection {* Product type is pointed *}
   166 
   167 lemma minimal_cprod: "(\<bottom>, \<bottom>) \<sqsubseteq> p"
   168 by (simp add: less_cprod_def)
   169 
   170 lemma least_cprod: "EX x::'a::pcpo * 'b::pcpo. ALL y. x \<sqsubseteq> y"
   171 apply (rule_tac x = "(\<bottom>, \<bottom>)" in exI)
   172 apply (rule minimal_cprod [THEN allI])
   173 done
   174 
   175 instance "*" :: (pcpo, pcpo) pcpo
   176 by intro_classes (rule least_cprod)
   177 
   178 text {* for compatibility with old HOLCF-Version *}
   179 lemma inst_cprod_pcpo: "UU = (UU,UU)"
   180 by (rule minimal_cprod [THEN UU_I, symmetric])
   181 
   182 
   183 subsection {* Continuity of @{text "(_,_)"}, @{term fst}, @{term snd} *}
   184 
   185 lemma contlub_pair1: "contlub (\<lambda>x. (x, y))"
   186 apply (rule contlubI)
   187 apply (subst thelub_cprod)
   188 apply (erule monofun_pair1 [THEN ch2ch_monofun])
   189 apply simp
   190 done
   191 
   192 lemma contlub_pair2: "contlub (\<lambda>y. (x, y))"
   193 apply (rule contlubI)
   194 apply (subst thelub_cprod)
   195 apply (erule monofun_pair2 [THEN ch2ch_monofun])
   196 apply simp
   197 done
   198 
   199 lemma cont_pair1: "cont (\<lambda>x. (x, y))"
   200 apply (rule monocontlub2cont)
   201 apply (rule monofun_pair1)
   202 apply (rule contlub_pair1)
   203 done
   204 
   205 lemma cont_pair2: "cont (\<lambda>y. (x, y))"
   206 apply (rule monocontlub2cont)
   207 apply (rule monofun_pair2)
   208 apply (rule contlub_pair2)
   209 done
   210 
   211 lemma contlub_fst: "contlub fst"
   212 apply (rule contlubI)
   213 apply (simp add: thelub_cprod)
   214 done
   215 
   216 lemma contlub_snd: "contlub snd"
   217 apply (rule contlubI)
   218 apply (simp add: thelub_cprod)
   219 done
   220 
   221 lemma cont_fst: "cont fst"
   222 apply (rule monocontlub2cont)
   223 apply (rule monofun_fst)
   224 apply (rule contlub_fst)
   225 done
   226 
   227 lemma cont_snd: "cont snd"
   228 apply (rule monocontlub2cont)
   229 apply (rule monofun_snd)
   230 apply (rule contlub_snd)
   231 done
   232 
   233 subsection {* Continuous versions of constants *}
   234 
   235 definition
   236   cpair :: "'a \<rightarrow> 'b \<rightarrow> ('a * 'b)"  -- {* continuous pairing *}  where
   237   "cpair = (\<Lambda> x y. (x, y))"
   238 
   239 definition
   240   cfst :: "('a * 'b) \<rightarrow> 'a" where
   241   "cfst = (\<Lambda> p. fst p)"
   242 
   243 definition
   244   csnd :: "('a * 'b) \<rightarrow> 'b" where
   245   "csnd = (\<Lambda> p. snd p)"      
   246 
   247 definition
   248   csplit :: "('a \<rightarrow> 'b \<rightarrow> 'c) \<rightarrow> ('a * 'b) \<rightarrow> 'c" where
   249   "csplit = (\<Lambda> f p. f\<cdot>(cfst\<cdot>p)\<cdot>(csnd\<cdot>p))"
   250 
   251 syntax
   252   "_ctuple" :: "['a, args] \<Rightarrow> 'a * 'b"  ("(1<_,/ _>)")
   253 
   254 syntax (xsymbols)
   255   "_ctuple" :: "['a, args] \<Rightarrow> 'a * 'b"  ("(1\<langle>_,/ _\<rangle>)")
   256 
   257 translations
   258   "\<langle>x, y, z\<rangle>" == "\<langle>x, \<langle>y, z\<rangle>\<rangle>"
   259   "\<langle>x, y\<rangle>"    == "CONST cpair\<cdot>x\<cdot>y"
   260 
   261 translations
   262   "\<Lambda>(CONST cpair\<cdot>x\<cdot>y). t" == "CONST csplit\<cdot>(\<Lambda> x y. t)"
   263 
   264 
   265 subsection {* Convert all lemmas to the continuous versions *}
   266 
   267 lemma cpair_eq_pair: "<x, y> = (x, y)"
   268 by (simp add: cpair_def cont_pair1 cont_pair2)
   269 
   270 lemma inject_cpair: "<a,b> = <aa,ba> \<Longrightarrow> a = aa \<and> b = ba"
   271 by (simp add: cpair_eq_pair)
   272 
   273 lemma cpair_eq [iff]: "(<a, b> = <a', b'>) = (a = a' \<and> b = b')"
   274 by (simp add: cpair_eq_pair)
   275 
   276 lemma cpair_less [iff]: "(<a, b> \<sqsubseteq> <a', b'>) = (a \<sqsubseteq> a' \<and> b \<sqsubseteq> b')"
   277 by (simp add: cpair_eq_pair less_cprod_def)
   278 
   279 lemma cpair_defined_iff [iff]: "(<x, y> = \<bottom>) = (x = \<bottom> \<and> y = \<bottom>)"
   280 by (simp add: inst_cprod_pcpo cpair_eq_pair)
   281 
   282 lemma cpair_strict: "<\<bottom>, \<bottom>> = \<bottom>"
   283 by simp
   284 
   285 lemma inst_cprod_pcpo2: "\<bottom> = <\<bottom>, \<bottom>>"
   286 by (rule cpair_strict [symmetric])
   287 
   288 lemma defined_cpair_rev: 
   289  "<a,b> = \<bottom> \<Longrightarrow> a = \<bottom> \<and> b = \<bottom>"
   290 by simp
   291 
   292 lemma Exh_Cprod2: "\<exists>a b. z = <a, b>"
   293 by (simp add: cpair_eq_pair)
   294 
   295 lemma cprodE: "\<lbrakk>\<And>x y. p = <x, y> \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
   296 by (cut_tac Exh_Cprod2, auto)
   297 
   298 lemma cfst_cpair [simp]: "cfst\<cdot><x, y> = x"
   299 by (simp add: cpair_eq_pair cfst_def cont_fst)
   300 
   301 lemma csnd_cpair [simp]: "csnd\<cdot><x, y> = y"
   302 by (simp add: cpair_eq_pair csnd_def cont_snd)
   303 
   304 lemma cfst_strict [simp]: "cfst\<cdot>\<bottom> = \<bottom>"
   305 by (simp add: inst_cprod_pcpo2)
   306 
   307 lemma csnd_strict [simp]: "csnd\<cdot>\<bottom> = \<bottom>"
   308 by (simp add: inst_cprod_pcpo2)
   309 
   310 lemma surjective_pairing_Cprod2: "<cfst\<cdot>p, csnd\<cdot>p> = p"
   311 apply (unfold cfst_def csnd_def)
   312 apply (simp add: cont_fst cont_snd cpair_eq_pair)
   313 done
   314 
   315 lemma less_cprod: "x \<sqsubseteq> y = (cfst\<cdot>x \<sqsubseteq> cfst\<cdot>y \<and> csnd\<cdot>x \<sqsubseteq> csnd\<cdot>y)"
   316 by (simp add: less_cprod_def cfst_def csnd_def cont_fst cont_snd)
   317 
   318 lemma eq_cprod: "(x = y) = (cfst\<cdot>x = cfst\<cdot>y \<and> csnd\<cdot>x = csnd\<cdot>y)"
   319 by (auto simp add: po_eq_conv less_cprod)
   320 
   321 lemma compact_cpair [simp]: "\<lbrakk>compact x; compact y\<rbrakk> \<Longrightarrow> compact <x, y>"
   322 by (rule compactI, simp add: less_cprod)
   323 
   324 lemma lub_cprod2: 
   325   "chain S \<Longrightarrow> range S <<| <\<Squnion>i. cfst\<cdot>(S i), \<Squnion>i. csnd\<cdot>(S i)>"
   326 apply (simp add: cpair_eq_pair cfst_def csnd_def cont_fst cont_snd)
   327 apply (erule lub_cprod)
   328 done
   329 
   330 lemma thelub_cprod2:
   331   "chain S \<Longrightarrow> lub (range S) = <\<Squnion>i. cfst\<cdot>(S i), \<Squnion>i. csnd\<cdot>(S i)>"
   332 by (rule lub_cprod2 [THEN thelubI])
   333 
   334 lemma csplit1 [simp]: "csplit\<cdot>f\<cdot>\<bottom> = f\<cdot>\<bottom>\<cdot>\<bottom>"
   335 by (simp add: csplit_def)
   336 
   337 lemma csplit2 [simp]: "csplit\<cdot>f\<cdot><x,y> = f\<cdot>x\<cdot>y"
   338 by (simp add: csplit_def)
   339 
   340 lemma csplit3 [simp]: "csplit\<cdot>cpair\<cdot>z = z"
   341 by (simp add: csplit_def surjective_pairing_Cprod2)
   342 
   343 lemmas Cprod_rews = cfst_cpair csnd_cpair csplit2
   344 
   345 end