src/HOLCF/Domain.thy
author huffman
Mon May 11 08:28:09 2009 -0700 (2009-05-11)
changeset 31095 b79d140f6d0b
parent 31076 99fe356cbbc2
child 31230 50deb3badfba
permissions -rw-r--r--
simplify fixrec proofs for mutually-recursive definitions; generate better fixpoint induction rules
huffman@15741
     1
(*  Title:      HOLCF/Domain.thy
huffman@15741
     2
    Author:     Brian Huffman
huffman@15741
     3
*)
huffman@15741
     4
huffman@15741
     5
header {* Domain package *}
huffman@15741
     6
huffman@15741
     7
theory Domain
huffman@16230
     8
imports Ssum Sprod Up One Tr Fixrec
huffman@30910
     9
uses
huffman@30910
    10
  ("Tools/cont_consts.ML")
huffman@30910
    11
  ("Tools/cont_proc.ML")
huffman@30910
    12
  ("Tools/domain/domain_library.ML")
huffman@30910
    13
  ("Tools/domain/domain_syntax.ML")
huffman@30910
    14
  ("Tools/domain/domain_axioms.ML")
huffman@30910
    15
  ("Tools/domain/domain_theorems.ML")
huffman@30910
    16
  ("Tools/domain/domain_extender.ML")
huffman@15741
    17
begin
huffman@15741
    18
huffman@15741
    19
defaultsort pcpo
huffman@15741
    20
wenzelm@23376
    21
huffman@15741
    22
subsection {* Continuous isomorphisms *}
huffman@15741
    23
huffman@15741
    24
text {* A locale for continuous isomorphisms *}
huffman@15741
    25
huffman@15741
    26
locale iso =
huffman@15741
    27
  fixes abs :: "'a \<rightarrow> 'b"
huffman@15741
    28
  fixes rep :: "'b \<rightarrow> 'a"
huffman@15741
    29
  assumes abs_iso [simp]: "rep\<cdot>(abs\<cdot>x) = x"
huffman@15741
    30
  assumes rep_iso [simp]: "abs\<cdot>(rep\<cdot>y) = y"
wenzelm@23376
    31
begin
huffman@15741
    32
wenzelm@23376
    33
lemma swap: "iso rep abs"
wenzelm@23376
    34
  by (rule iso.intro [OF rep_iso abs_iso])
huffman@15741
    35
huffman@31076
    36
lemma abs_below: "(abs\<cdot>x \<sqsubseteq> abs\<cdot>y) = (x \<sqsubseteq> y)"
huffman@17835
    37
proof
huffman@17835
    38
  assume "abs\<cdot>x \<sqsubseteq> abs\<cdot>y"
wenzelm@23376
    39
  then have "rep\<cdot>(abs\<cdot>x) \<sqsubseteq> rep\<cdot>(abs\<cdot>y)" by (rule monofun_cfun_arg)
wenzelm@23376
    40
  then show "x \<sqsubseteq> y" by simp
huffman@17835
    41
next
huffman@17835
    42
  assume "x \<sqsubseteq> y"
wenzelm@23376
    43
  then show "abs\<cdot>x \<sqsubseteq> abs\<cdot>y" by (rule monofun_cfun_arg)
huffman@17835
    44
qed
huffman@17835
    45
huffman@31076
    46
lemma rep_below: "(rep\<cdot>x \<sqsubseteq> rep\<cdot>y) = (x \<sqsubseteq> y)"
huffman@31076
    47
  by (rule iso.abs_below [OF swap])
huffman@17835
    48
wenzelm@23376
    49
lemma abs_eq: "(abs\<cdot>x = abs\<cdot>y) = (x = y)"
huffman@31076
    50
  by (simp add: po_eq_conv abs_below)
huffman@17835
    51
wenzelm@23376
    52
lemma rep_eq: "(rep\<cdot>x = rep\<cdot>y) = (x = y)"
wenzelm@23376
    53
  by (rule iso.abs_eq [OF swap])
huffman@17835
    54
wenzelm@23376
    55
lemma abs_strict: "abs\<cdot>\<bottom> = \<bottom>"
huffman@15741
    56
proof -
huffman@15741
    57
  have "\<bottom> \<sqsubseteq> rep\<cdot>\<bottom>" ..
wenzelm@23376
    58
  then have "abs\<cdot>\<bottom> \<sqsubseteq> abs\<cdot>(rep\<cdot>\<bottom>)" by (rule monofun_cfun_arg)
wenzelm@23376
    59
  then have "abs\<cdot>\<bottom> \<sqsubseteq> \<bottom>" by simp
wenzelm@23376
    60
  then show ?thesis by (rule UU_I)
huffman@15741
    61
qed
huffman@15741
    62
wenzelm@23376
    63
lemma rep_strict: "rep\<cdot>\<bottom> = \<bottom>"
wenzelm@23376
    64
  by (rule iso.abs_strict [OF swap])
huffman@15741
    65
wenzelm@23376
    66
lemma abs_defin': "abs\<cdot>x = \<bottom> \<Longrightarrow> x = \<bottom>"
huffman@15741
    67
proof -
huffman@17835
    68
  have "x = rep\<cdot>(abs\<cdot>x)" by simp
huffman@17835
    69
  also assume "abs\<cdot>x = \<bottom>"
huffman@15741
    70
  also note rep_strict
huffman@17835
    71
  finally show "x = \<bottom>" .
huffman@15741
    72
qed
huffman@15741
    73
wenzelm@23376
    74
lemma rep_defin': "rep\<cdot>z = \<bottom> \<Longrightarrow> z = \<bottom>"
wenzelm@23376
    75
  by (rule iso.abs_defin' [OF swap])
huffman@15741
    76
wenzelm@23376
    77
lemma abs_defined: "z \<noteq> \<bottom> \<Longrightarrow> abs\<cdot>z \<noteq> \<bottom>"
wenzelm@23376
    78
  by (erule contrapos_nn, erule abs_defin')
huffman@15741
    79
wenzelm@23376
    80
lemma rep_defined: "z \<noteq> \<bottom> \<Longrightarrow> rep\<cdot>z \<noteq> \<bottom>"
wenzelm@23376
    81
  by (rule iso.abs_defined [OF iso.swap]) (rule iso_axioms)
huffman@17835
    82
wenzelm@23376
    83
lemma abs_defined_iff: "(abs\<cdot>x = \<bottom>) = (x = \<bottom>)"
wenzelm@23376
    84
  by (auto elim: abs_defin' intro: abs_strict)
huffman@17835
    85
wenzelm@23376
    86
lemma rep_defined_iff: "(rep\<cdot>x = \<bottom>) = (x = \<bottom>)"
wenzelm@23376
    87
  by (rule iso.abs_defined_iff [OF iso.swap]) (rule iso_axioms)
huffman@15741
    88
huffman@17836
    89
lemma (in iso) compact_abs_rev: "compact (abs\<cdot>x) \<Longrightarrow> compact x"
huffman@17836
    90
proof (unfold compact_def)
huffman@17836
    91
  assume "adm (\<lambda>y. \<not> abs\<cdot>x \<sqsubseteq> y)"
huffman@17836
    92
  with cont_Rep_CFun2
huffman@17836
    93
  have "adm (\<lambda>y. \<not> abs\<cdot>x \<sqsubseteq> abs\<cdot>y)" by (rule adm_subst)
huffman@31076
    94
  then show "adm (\<lambda>y. \<not> x \<sqsubseteq> y)" using abs_below by simp
huffman@17836
    95
qed
huffman@17836
    96
wenzelm@23376
    97
lemma compact_rep_rev: "compact (rep\<cdot>x) \<Longrightarrow> compact x"
wenzelm@23376
    98
  by (rule iso.compact_abs_rev [OF iso.swap]) (rule iso_axioms)
huffman@17836
    99
wenzelm@23376
   100
lemma compact_abs: "compact x \<Longrightarrow> compact (abs\<cdot>x)"
wenzelm@23376
   101
  by (rule compact_rep_rev) simp
huffman@17836
   102
wenzelm@23376
   103
lemma compact_rep: "compact x \<Longrightarrow> compact (rep\<cdot>x)"
wenzelm@23376
   104
  by (rule iso.compact_abs [OF iso.swap]) (rule iso_axioms)
huffman@17836
   105
wenzelm@23376
   106
lemma iso_swap: "(x = abs\<cdot>y) = (rep\<cdot>x = y)"
huffman@15741
   107
proof
huffman@15741
   108
  assume "x = abs\<cdot>y"
wenzelm@23376
   109
  then have "rep\<cdot>x = rep\<cdot>(abs\<cdot>y)" by simp
wenzelm@23376
   110
  then show "rep\<cdot>x = y" by simp
huffman@15741
   111
next
huffman@15741
   112
  assume "rep\<cdot>x = y"
wenzelm@23376
   113
  then have "abs\<cdot>(rep\<cdot>x) = abs\<cdot>y" by simp
wenzelm@23376
   114
  then show "x = abs\<cdot>y" by simp
huffman@15741
   115
qed
huffman@15741
   116
wenzelm@23376
   117
end
wenzelm@23376
   118
wenzelm@23376
   119
huffman@15741
   120
subsection {* Casedist *}
huffman@15741
   121
huffman@15741
   122
lemma ex_one_defined_iff:
huffman@15741
   123
  "(\<exists>x. P x \<and> x \<noteq> \<bottom>) = P ONE"
huffman@15741
   124
 apply safe
huffman@15741
   125
  apply (rule_tac p=x in oneE)
huffman@15741
   126
   apply simp
huffman@15741
   127
  apply simp
huffman@15741
   128
 apply force
wenzelm@23376
   129
 done
huffman@15741
   130
huffman@15741
   131
lemma ex_up_defined_iff:
huffman@15741
   132
  "(\<exists>x. P x \<and> x \<noteq> \<bottom>) = (\<exists>x. P (up\<cdot>x))"
huffman@15741
   133
 apply safe
huffman@16754
   134
  apply (rule_tac p=x in upE)
huffman@15741
   135
   apply simp
huffman@15741
   136
  apply fast
huffman@16320
   137
 apply (force intro!: up_defined)
wenzelm@23376
   138
 done
huffman@15741
   139
huffman@15741
   140
lemma ex_sprod_defined_iff:
huffman@15741
   141
 "(\<exists>y. P y \<and> y \<noteq> \<bottom>) =
huffman@15741
   142
  (\<exists>x y. (P (:x, y:) \<and> x \<noteq> \<bottom>) \<and> y \<noteq> \<bottom>)"
huffman@15741
   143
 apply safe
huffman@15741
   144
  apply (rule_tac p=y in sprodE)
huffman@15741
   145
   apply simp
huffman@15741
   146
  apply fast
huffman@16217
   147
 apply (force intro!: spair_defined)
wenzelm@23376
   148
 done
huffman@15741
   149
huffman@15741
   150
lemma ex_sprod_up_defined_iff:
huffman@15741
   151
 "(\<exists>y. P y \<and> y \<noteq> \<bottom>) =
huffman@15741
   152
  (\<exists>x y. P (:up\<cdot>x, y:) \<and> y \<noteq> \<bottom>)"
huffman@15741
   153
 apply safe
huffman@15741
   154
  apply (rule_tac p=y in sprodE)
huffman@15741
   155
   apply simp
huffman@16754
   156
  apply (rule_tac p=x in upE)
huffman@15741
   157
   apply simp
huffman@15741
   158
  apply fast
huffman@16217
   159
 apply (force intro!: spair_defined)
wenzelm@23376
   160
 done
huffman@15741
   161
huffman@15741
   162
lemma ex_ssum_defined_iff:
huffman@15741
   163
 "(\<exists>x. P x \<and> x \<noteq> \<bottom>) =
huffman@15741
   164
 ((\<exists>x. P (sinl\<cdot>x) \<and> x \<noteq> \<bottom>) \<or>
huffman@15741
   165
  (\<exists>x. P (sinr\<cdot>x) \<and> x \<noteq> \<bottom>))"
huffman@15741
   166
 apply (rule iffI)
huffman@15741
   167
  apply (erule exE)
huffman@15741
   168
  apply (erule conjE)
huffman@15741
   169
  apply (rule_tac p=x in ssumE)
huffman@15741
   170
    apply simp
huffman@15741
   171
   apply (rule disjI1, fast)
huffman@15741
   172
  apply (rule disjI2, fast)
huffman@15741
   173
 apply (erule disjE)
huffman@17835
   174
  apply force
huffman@17835
   175
 apply force
wenzelm@23376
   176
 done
huffman@15741
   177
huffman@15741
   178
lemma exh_start: "p = \<bottom> \<or> (\<exists>x. p = x \<and> x \<noteq> \<bottom>)"
wenzelm@23376
   179
  by auto
huffman@15741
   180
huffman@15741
   181
lemmas ex_defined_iffs =
huffman@15741
   182
   ex_ssum_defined_iff
huffman@15741
   183
   ex_sprod_up_defined_iff
huffman@15741
   184
   ex_sprod_defined_iff
huffman@15741
   185
   ex_up_defined_iff
huffman@15741
   186
   ex_one_defined_iff
huffman@15741
   187
huffman@15741
   188
text {* Rules for turning exh into casedist *}
huffman@15741
   189
huffman@15741
   190
lemma exh_casedist0: "\<lbrakk>R; R \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P" (* like make_elim *)
wenzelm@23376
   191
  by auto
huffman@15741
   192
huffman@15741
   193
lemma exh_casedist1: "((P \<or> Q \<Longrightarrow> R) \<Longrightarrow> S) \<equiv> (\<lbrakk>P \<Longrightarrow> R; Q \<Longrightarrow> R\<rbrakk> \<Longrightarrow> S)"
wenzelm@23376
   194
  by rule auto
huffman@15741
   195
huffman@15741
   196
lemma exh_casedist2: "(\<exists>x. P x \<Longrightarrow> Q) \<equiv> (\<And>x. P x \<Longrightarrow> Q)"
wenzelm@23376
   197
  by rule auto
huffman@15741
   198
huffman@15741
   199
lemma exh_casedist3: "(P \<and> Q \<Longrightarrow> R) \<equiv> (P \<Longrightarrow> Q \<Longrightarrow> R)"
wenzelm@23376
   200
  by rule auto
huffman@15741
   201
huffman@15741
   202
lemmas exh_casedists = exh_casedist1 exh_casedist2 exh_casedist3
huffman@15741
   203
huffman@30910
   204
huffman@30910
   205
subsection {* Installing the domain package *}
huffman@30910
   206
huffman@30911
   207
lemmas con_strict_rules =
huffman@30911
   208
  sinl_strict sinr_strict spair_strict1 spair_strict2
huffman@30911
   209
huffman@30911
   210
lemmas con_defin_rules =
huffman@30911
   211
  sinl_defined sinr_defined spair_defined up_defined ONE_defined
huffman@30911
   212
huffman@30911
   213
lemmas con_defined_iff_rules =
huffman@30911
   214
  sinl_defined_iff sinr_defined_iff spair_strict_iff up_defined ONE_defined
huffman@30911
   215
huffman@30910
   216
use "Tools/cont_consts.ML"
huffman@30910
   217
use "Tools/cont_proc.ML"
huffman@30910
   218
use "Tools/domain/domain_library.ML"
huffman@30910
   219
use "Tools/domain/domain_syntax.ML"
huffman@30910
   220
use "Tools/domain/domain_axioms.ML"
huffman@30910
   221
use "Tools/domain/domain_theorems.ML"
huffman@30910
   222
use "Tools/domain/domain_extender.ML"
huffman@30910
   223
huffman@15741
   224
end