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