src/HOL/UNITY/ProgressSets.thy
author haftmann
Wed Jul 22 18:02:10 2009 +0200 (2009-07-22)
changeset 32139 e271a64f03ff
parent 30198 922f944f03b2
child 32604 8b3e2bc91a46
permissions -rw-r--r--
moved complete_lattice &c. into separate theory
paulson@13853
     1
(*  Title:      HOL/UNITY/ProgressSets
paulson@13853
     2
    ID:         $Id$
paulson@13853
     3
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
paulson@13853
     4
    Copyright   2003  University of Cambridge
paulson@13853
     5
paulson@13853
     6
Progress Sets.  From 
paulson@13853
     7
paulson@13853
     8
    David Meier and Beverly Sanders,
paulson@13853
     9
    Composing Leads-to Properties
paulson@13853
    10
    Theoretical Computer Science 243:1-2 (2000), 339-361.
paulson@13861
    11
paulson@13861
    12
    David Meier,
paulson@13861
    13
    Progress Properties in Program Refinement and Parallel Composition
paulson@13861
    14
    Swiss Federal Institute of Technology Zurich (1997)
paulson@13853
    15
*)
paulson@13853
    16
paulson@13853
    17
header{*Progress Sets*}
paulson@13853
    18
haftmann@16417
    19
theory ProgressSets imports Transformers begin
paulson@13853
    20
paulson@13866
    21
subsection {*Complete Lattices and the Operator @{term cl}*}
paulson@13866
    22
paulson@13853
    23
constdefs
paulson@13861
    24
  lattice :: "'a set set => bool"
paulson@13861
    25
   --{*Meier calls them closure sets, but they are just complete lattices*}
paulson@13861
    26
   "lattice L ==
paulson@13861
    27
	 (\<forall>M. M \<subseteq> L --> \<Inter>M \<in> L) & (\<forall>M. M \<subseteq> L --> \<Union>M \<in> L)"
paulson@13853
    28
paulson@13853
    29
  cl :: "['a set set, 'a set] => 'a set"
paulson@13853
    30
   --{*short for ``closure''*}
paulson@13861
    31
   "cl L r == \<Inter>{x. x\<in>L & r \<subseteq> x}"
paulson@13853
    32
paulson@13861
    33
lemma UNIV_in_lattice: "lattice L ==> UNIV \<in> L"
paulson@13861
    34
by (force simp add: lattice_def)
paulson@13853
    35
paulson@13861
    36
lemma empty_in_lattice: "lattice L ==> {} \<in> L"
paulson@13861
    37
by (force simp add: lattice_def)
paulson@13853
    38
paulson@13861
    39
lemma Union_in_lattice: "[|M \<subseteq> L; lattice L|] ==> \<Union>M \<in> L"
paulson@13861
    40
by (simp add: lattice_def)
paulson@13853
    41
paulson@13861
    42
lemma Inter_in_lattice: "[|M \<subseteq> L; lattice L|] ==> \<Inter>M \<in> L"
paulson@13861
    43
by (simp add: lattice_def)
paulson@13853
    44
paulson@13861
    45
lemma UN_in_lattice:
paulson@13861
    46
     "[|lattice L; !!i. i\<in>I ==> r i \<in> L|] ==> (\<Union>i\<in>I. r i) \<in> L"
haftmann@32139
    47
apply (simp add: UN_eq) 
paulson@13861
    48
apply (blast intro: Union_in_lattice) 
paulson@13853
    49
done
paulson@13853
    50
paulson@13861
    51
lemma INT_in_lattice:
paulson@13861
    52
     "[|lattice L; !!i. i\<in>I ==> r i \<in> L|] ==> (\<Inter>i\<in>I. r i)  \<in> L"
paulson@13853
    53
apply (simp add: INT_eq) 
paulson@13861
    54
apply (blast intro: Inter_in_lattice) 
paulson@13853
    55
done
paulson@13853
    56
paulson@13861
    57
lemma Un_in_lattice: "[|x\<in>L; y\<in>L; lattice L|] ==> x\<union>y \<in> L"
paulson@13853
    58
apply (simp only: Un_eq_Union) 
paulson@13861
    59
apply (blast intro: Union_in_lattice) 
paulson@13853
    60
done
paulson@13853
    61
paulson@13861
    62
lemma Int_in_lattice: "[|x\<in>L; y\<in>L; lattice L|] ==> x\<inter>y \<in> L"
paulson@13853
    63
apply (simp only: Int_eq_Inter) 
paulson@13861
    64
apply (blast intro: Inter_in_lattice) 
paulson@13853
    65
done
paulson@13853
    66
paulson@13861
    67
lemma lattice_stable: "lattice {X. F \<in> stable X}"
paulson@13861
    68
by (simp add: lattice_def stable_def constrains_def, blast)
paulson@13853
    69
paulson@13861
    70
text{*The next three results state that @{term "cl L r"} is the minimal
paulson@13861
    71
 element of @{term L} that includes @{term r}.*}
paulson@13861
    72
lemma cl_in_lattice: "lattice L ==> cl L r \<in> L"
paulson@13861
    73
apply (simp add: lattice_def cl_def)
paulson@13853
    74
apply (erule conjE)  
paulson@13853
    75
apply (drule spec, erule mp, blast) 
paulson@13853
    76
done
paulson@13853
    77
paulson@13861
    78
lemma cl_least: "[|c\<in>L; r\<subseteq>c|] ==> cl L r \<subseteq> c" 
paulson@13853
    79
by (force simp add: cl_def)
paulson@13853
    80
paulson@13853
    81
text{*The next three lemmas constitute assertion (4.61)*}
paulson@13861
    82
lemma cl_mono: "r \<subseteq> r' ==> cl L r \<subseteq> cl L r'"
paulson@13861
    83
by (simp add: cl_def, blast)
paulson@13861
    84
paulson@13861
    85
lemma subset_cl: "r \<subseteq> cl L r"
paulson@13861
    86
by (simp add: cl_def, blast)
paulson@13861
    87
paulson@13874
    88
text{*A reformulation of @{thm subset_cl}*}
paulson@13874
    89
lemma clI: "x \<in> r ==> x \<in> cl L r"
paulson@13874
    90
by (simp add: cl_def, blast)
paulson@13874
    91
paulson@13874
    92
text{*A reformulation of @{thm cl_least}*}
paulson@13874
    93
lemma clD: "[|c \<in> cl L r; B \<in> L; r \<subseteq> B|] ==> c \<in> B"
paulson@13874
    94
by (force simp add: cl_def)
paulson@13874
    95
paulson@13861
    96
lemma cl_UN_subset: "(\<Union>i\<in>I. cl L (r i)) \<subseteq> cl L (\<Union>i\<in>I. r i)"
paulson@13853
    97
by (simp add: cl_def, blast)
paulson@13853
    98
paulson@13861
    99
lemma cl_Un: "lattice L ==> cl L (r\<union>s) = cl L r \<union> cl L s"
paulson@13861
   100
apply (rule equalityI) 
paulson@13861
   101
 prefer 2 
paulson@13861
   102
  apply (simp add: cl_def, blast)
paulson@13861
   103
apply (rule cl_least)
paulson@13861
   104
 apply (blast intro: Un_in_lattice cl_in_lattice)
paulson@13861
   105
apply (blast intro: subset_cl [THEN subsetD])  
paulson@13861
   106
done
paulson@13853
   107
paulson@13861
   108
lemma cl_UN: "lattice L ==> cl L (\<Union>i\<in>I. r i) = (\<Union>i\<in>I. cl L (r i))"
paulson@13853
   109
apply (rule equalityI) 
paulson@13866
   110
 prefer 2 apply (simp add: cl_def, blast)
paulson@13853
   111
apply (rule cl_least)
paulson@13861
   112
 apply (blast intro: UN_in_lattice cl_in_lattice)
paulson@13853
   113
apply (blast intro: subset_cl [THEN subsetD])  
paulson@13853
   114
done
paulson@13853
   115
paulson@13874
   116
lemma cl_Int_subset: "cl L (r\<inter>s) \<subseteq> cl L r \<inter> cl L s"
paulson@13874
   117
by (simp add: cl_def, blast)
paulson@13874
   118
paulson@13861
   119
lemma cl_idem [simp]: "cl L (cl L r) = cl L r"
paulson@13853
   120
by (simp add: cl_def, blast)
paulson@13853
   121
paulson@13861
   122
lemma cl_ident: "r\<in>L ==> cl L r = r" 
paulson@13853
   123
by (force simp add: cl_def)
paulson@13853
   124
paulson@13874
   125
lemma cl_empty [simp]: "lattice L ==> cl L {} = {}"
paulson@13874
   126
by (simp add: cl_ident empty_in_lattice)
paulson@13874
   127
paulson@13874
   128
lemma cl_UNIV [simp]: "lattice L ==> cl L UNIV = UNIV"
paulson@13874
   129
by (simp add: cl_ident UNIV_in_lattice)
paulson@13874
   130
paulson@13853
   131
text{*Assertion (4.62)*}
paulson@13861
   132
lemma cl_ident_iff: "lattice L ==> (cl L r = r) = (r\<in>L)" 
paulson@13853
   133
apply (rule iffI) 
paulson@13853
   134
 apply (erule subst)
paulson@13861
   135
 apply (erule cl_in_lattice)  
paulson@13853
   136
apply (erule cl_ident) 
paulson@13853
   137
done
paulson@13853
   138
paulson@13861
   139
lemma cl_subset_in_lattice: "[|cl L r \<subseteq> r; lattice L|] ==> r\<in>L" 
paulson@13861
   140
by (simp add: cl_ident_iff [symmetric] equalityI subset_cl)
paulson@13861
   141
paulson@13861
   142
paulson@13866
   143
subsection {*Progress Sets and the Main Lemma*}
paulson@13888
   144
text{*A progress set satisfies certain closure conditions and is a 
paulson@13888
   145
simple way of including the set @{term "wens_set F B"}.*}
paulson@13866
   146
paulson@13861
   147
constdefs 
paulson@13861
   148
  closed :: "['a program, 'a set, 'a set,  'a set set] => bool"
paulson@13861
   149
   "closed F T B L == \<forall>M. \<forall>act \<in> Acts F. B\<subseteq>M & T\<inter>M \<in> L -->
paulson@13861
   150
                              T \<inter> (B \<union> wp act M) \<in> L"
paulson@13861
   151
paulson@13861
   152
  progress_set :: "['a program, 'a set, 'a set] => 'a set set set"
paulson@13861
   153
   "progress_set F T B ==
paulson@13870
   154
      {L. lattice L & B \<in> L & T \<in> L & closed F T B L}"
paulson@13861
   155
paulson@13861
   156
lemma closedD:
paulson@13861
   157
   "[|closed F T B L; act \<in> Acts F; B\<subseteq>M; T\<inter>M \<in> L|] 
paulson@14150
   158
    ==> T \<inter> (B \<union> wp act M) \<in> L" 
paulson@13861
   159
by (simp add: closed_def) 
paulson@13861
   160
paulson@13866
   161
text{*Note: the formalization below replaces Meier's @{term q} by @{term B}
paulson@13866
   162
and @{term m} by @{term X}. *}
paulson@13866
   163
paulson@13866
   164
text{*Part of the proof of the claim at the bottom of page 97.  It's
paulson@13866
   165
proved separately because the argument requires a generalization over
paulson@13866
   166
all @{term "act \<in> Acts F"}.*}
paulson@13861
   167
lemma lattice_awp_lemma:
paulson@13866
   168
  assumes TXC:  "T\<inter>X \<in> C" --{*induction hypothesis in theorem below*}
paulson@13866
   169
      and BsubX:  "B \<subseteq> X"   --{*holds in inductive step*}
paulson@13861
   170
      and latt: "lattice C"
paulson@13866
   171
      and TC:   "T \<in> C"
paulson@13866
   172
      and BC:   "B \<in> C"
paulson@13866
   173
      and clos: "closed F T B C"
paulson@13866
   174
    shows "T \<inter> (B \<union> awp F (X \<union> cl C (T\<inter>r))) \<in> C"
paulson@13861
   175
apply (simp del: INT_simps add: awp_def INT_extend_simps) 
paulson@13861
   176
apply (rule INT_in_lattice [OF latt]) 
paulson@13861
   177
apply (erule closedD [OF clos]) 
paulson@13866
   178
apply (simp add: subset_trans [OF BsubX Un_upper1]) 
paulson@13866
   179
apply (subgoal_tac "T \<inter> (X \<union> cl C (T\<inter>r)) = (T\<inter>X) \<union> cl C (T\<inter>r)")
paulson@13874
   180
 prefer 2 apply (blast intro: TC clD) 
paulson@13861
   181
apply (erule ssubst) 
paulson@13866
   182
apply (blast intro: Un_in_lattice latt cl_in_lattice TXC) 
paulson@13861
   183
done
paulson@13861
   184
paulson@13866
   185
text{*Remainder of the proof of the claim at the bottom of page 97.*}
paulson@13861
   186
lemma lattice_lemma:
paulson@13866
   187
  assumes TXC:  "T\<inter>X \<in> C" --{*induction hypothesis in theorem below*}
paulson@13866
   188
      and BsubX:  "B \<subseteq> X"   --{*holds in inductive step*}
paulson@13861
   189
      and act:  "act \<in> Acts F"
paulson@13861
   190
      and latt: "lattice C"
paulson@13866
   191
      and TC:   "T \<in> C"
paulson@13866
   192
      and BC:   "B \<in> C"
paulson@13866
   193
      and clos: "closed F T B C"
paulson@13866
   194
    shows "T \<inter> (wp act X \<inter> awp F (X \<union> cl C (T\<inter>r)) \<union> X) \<in> C"
paulson@13866
   195
apply (subgoal_tac "T \<inter> (B \<union> wp act X) \<in> C")
paulson@13866
   196
 prefer 2 apply (simp add: closedD [OF clos] act BsubX TXC)
paulson@13861
   197
apply (drule Int_in_lattice
paulson@13866
   198
              [OF _ lattice_awp_lemma [OF TXC BsubX latt TC BC clos, of r]
paulson@13861
   199
                    latt])
paulson@13861
   200
apply (subgoal_tac
paulson@13866
   201
	 "T \<inter> (B \<union> wp act X) \<inter> (T \<inter> (B \<union> awp F (X \<union> cl C (T\<inter>r)))) = 
paulson@13866
   202
	  T \<inter> (B \<union> wp act X \<inter> awp F (X \<union> cl C (T\<inter>r)))") 
paulson@13861
   203
 prefer 2 apply blast 
paulson@13861
   204
apply simp  
paulson@13866
   205
apply (drule Un_in_lattice [OF _ TXC latt])  
paulson@13861
   206
apply (subgoal_tac
paulson@13866
   207
	 "T \<inter> (B \<union> wp act X \<inter> awp F (X \<union> cl C (T\<inter>r))) \<union> T\<inter>X = 
paulson@13866
   208
	  T \<inter> (wp act X \<inter> awp F (X \<union> cl C (T\<inter>r)) \<union> X)")
paulson@13866
   209
 apply simp 
paulson@13866
   210
apply (blast intro: BsubX [THEN subsetD]) 
paulson@13861
   211
done
paulson@13861
   212
paulson@13861
   213
paulson@13866
   214
text{*Induction step for the main lemma*}
paulson@13861
   215
lemma progress_induction_step:
paulson@13866
   216
  assumes TXC:  "T\<inter>X \<in> C" --{*induction hypothesis in theorem below*}
paulson@13861
   217
      and act:  "act \<in> Acts F"
paulson@13866
   218
      and Xwens: "X \<in> wens_set F B"
paulson@13861
   219
      and latt: "lattice C"
paulson@13866
   220
      and  TC:  "T \<in> C"
paulson@13866
   221
      and  BC:  "B \<in> C"
paulson@13866
   222
      and clos: "closed F T B C"
paulson@13861
   223
      and Fstable: "F \<in> stable T"
paulson@13866
   224
  shows "T \<inter> wens F act X \<in> C"
paulson@13861
   225
proof -
paulson@13866
   226
  from Xwens have BsubX: "B \<subseteq> X"
paulson@13866
   227
    by (rule wens_set_imp_subset) 
paulson@13866
   228
  let ?r = "wens F act X"
paulson@13866
   229
  have "?r \<subseteq> (wp act X \<inter> awp F (X\<union>?r)) \<union> X"
paulson@13866
   230
    by (simp add: wens_unfold [symmetric])
paulson@13866
   231
  then have "T\<inter>?r \<subseteq> T \<inter> ((wp act X \<inter> awp F (X\<union>?r)) \<union> X)"
paulson@13866
   232
    by blast
paulson@13866
   233
  then have "T\<inter>?r \<subseteq> T \<inter> ((wp act X \<inter> awp F (T \<inter> (X\<union>?r))) \<union> X)"
paulson@13866
   234
    by (simp add: awp_Int_eq Fstable stable_imp_awp_ident, blast) 
paulson@13866
   235
  then have "T\<inter>?r \<subseteq> T \<inter> ((wp act X \<inter> awp F (X \<union> cl C (T\<inter>?r))) \<union> X)"
paulson@13866
   236
    by (blast intro: awp_mono [THEN [2] rev_subsetD] subset_cl [THEN subsetD])
paulson@13866
   237
  then have "cl C (T\<inter>?r) \<subseteq> 
paulson@13866
   238
             cl C (T \<inter> ((wp act X \<inter> awp F (X \<union> cl C (T\<inter>?r))) \<union> X))"
paulson@13866
   239
    by (rule cl_mono) 
paulson@13866
   240
  then have "cl C (T\<inter>?r) \<subseteq> 
paulson@13866
   241
             T \<inter> ((wp act X \<inter> awp F (X \<union> cl C (T\<inter>?r))) \<union> X)"
paulson@13866
   242
    by (simp add: cl_ident lattice_lemma [OF TXC BsubX act latt TC BC clos])
paulson@13866
   243
  then have "cl C (T\<inter>?r) \<subseteq> (wp act X \<inter> awp F (X \<union> cl C (T\<inter>?r))) \<union> X"
paulson@13866
   244
    by blast
paulson@13866
   245
  then have "cl C (T\<inter>?r) \<subseteq> ?r"
paulson@13866
   246
    by (blast intro!: subset_wens) 
paulson@13866
   247
  then have cl_subset: "cl C (T\<inter>?r) \<subseteq> T\<inter>?r"
paulson@13866
   248
    by (simp add: Int_subset_iff cl_ident TC
paulson@13866
   249
                  subset_trans [OF cl_mono [OF Int_lower1]]) 
paulson@13866
   250
  show ?thesis
paulson@13866
   251
    by (rule cl_subset_in_lattice [OF cl_subset latt]) 
paulson@13861
   252
qed
paulson@13861
   253
paulson@13888
   254
text{*Proved on page 96 of Meier's thesis.  The special case when
paulson@13888
   255
   @{term "T=UNIV"} states that every progress set for the program @{term F}
paulson@13888
   256
   and set @{term B} includes the set @{term "wens_set F B"}.*}
paulson@13861
   257
lemma progress_set_lemma:
paulson@13870
   258
     "[|C \<in> progress_set F T B; r \<in> wens_set F B; F \<in> stable T|] ==> T\<inter>r \<in> C"
paulson@13861
   259
apply (simp add: progress_set_def, clarify) 
paulson@13861
   260
apply (erule wens_set.induct) 
paulson@13861
   261
  txt{*Base*}
paulson@13861
   262
  apply (simp add: Int_in_lattice) 
paulson@13861
   263
 txt{*The difficult @{term wens} case*}
paulson@13861
   264
 apply (simp add: progress_induction_step) 
paulson@13861
   265
txt{*Disjunctive case*}
paulson@13861
   266
apply (subgoal_tac "(\<Union>U\<in>W. T \<inter> U) \<in> C") 
paulson@13861
   267
 apply (simp add: Int_Union) 
paulson@13861
   268
apply (blast intro: UN_in_lattice) 
paulson@13861
   269
done
paulson@13861
   270
paulson@13866
   271
paulson@13866
   272
subsection {*The Progress Set Union Theorem*}
paulson@13866
   273
paulson@13866
   274
lemma closed_mono:
paulson@13866
   275
  assumes BB':  "B \<subseteq> B'"
paulson@13866
   276
      and TBwp: "T \<inter> (B \<union> wp act M) \<in> C"
paulson@13866
   277
      and B'C:  "B' \<in> C"
paulson@13866
   278
      and TC:   "T \<in> C"
paulson@13866
   279
      and latt: "lattice C"
paulson@13866
   280
  shows "T \<inter> (B' \<union> wp act M) \<in> C"
paulson@13866
   281
proof -
paulson@13866
   282
  from TBwp have "(T\<inter>B) \<union> (T \<inter> wp act M) \<in> C"
paulson@13866
   283
    by (simp add: Int_Un_distrib)
paulson@13866
   284
  then have TBBC: "(T\<inter>B') \<union> ((T\<inter>B) \<union> (T \<inter> wp act M)) \<in> C"
paulson@13866
   285
    by (blast intro: Int_in_lattice Un_in_lattice TC B'C latt) 
paulson@13866
   286
  show ?thesis
paulson@13866
   287
    by (rule eqelem_imp_iff [THEN iffD1, OF _ TBBC], 
paulson@13866
   288
        blast intro: BB' [THEN subsetD]) 
paulson@13866
   289
qed
paulson@13866
   290
paulson@13866
   291
paulson@13866
   292
lemma progress_set_mono:
paulson@13866
   293
    assumes BB':  "B \<subseteq> B'"
paulson@13866
   294
    shows
paulson@13866
   295
     "[| B' \<in> C;  C \<in> progress_set F T B|] 
paulson@13866
   296
      ==> C \<in> progress_set F T B'"
paulson@13866
   297
by (simp add: progress_set_def closed_def closed_mono [OF BB'] 
paulson@13866
   298
                 subset_trans [OF BB']) 
paulson@13866
   299
paulson@13866
   300
theorem progress_set_Union:
paulson@13874
   301
  assumes leadsTo: "F \<in> A leadsTo B'"
paulson@13874
   302
      and prog: "C \<in> progress_set F T B"
paulson@13870
   303
      and Fstable: "F \<in> stable T"
paulson@13866
   304
      and BB':  "B \<subseteq> B'"
paulson@13866
   305
      and B'C:  "B' \<in> C"
paulson@13866
   306
      and Gco: "!!X. X\<in>C ==> G \<in> X-B co X"
paulson@13866
   307
  shows "F\<squnion>G \<in> T\<inter>A leadsTo B'"
paulson@13870
   308
apply (insert prog Fstable) 
paulson@13866
   309
apply (rule leadsTo_Join [OF leadsTo]) 
paulson@13866
   310
  apply (force simp add: progress_set_def awp_iff_stable [symmetric]) 
paulson@13866
   311
apply (simp add: awp_iff_constrains)
paulson@13866
   312
apply (drule progress_set_mono [OF BB' B'C]) 
paulson@13866
   313
apply (blast intro: progress_set_lemma Gco constrains_weaken_L 
paulson@13866
   314
                    BB' [THEN subsetD]) 
paulson@13866
   315
done
paulson@13866
   316
paulson@13870
   317
paulson@13870
   318
subsection {*Some Progress Sets*}
paulson@13870
   319
paulson@13870
   320
lemma UNIV_in_progress_set: "UNIV \<in> progress_set F T B"
paulson@13870
   321
by (simp add: progress_set_def lattice_def closed_def)
paulson@13870
   322
paulson@13874
   323
paulson@13874
   324
paulson@13885
   325
subsubsection {*Lattices and Relations*}
paulson@13874
   326
text{*From Meier's thesis, section 4.5.3*}
paulson@13874
   327
paulson@13874
   328
constdefs
paulson@13874
   329
  relcl :: "'a set set => ('a * 'a) set"
paulson@13885
   330
    -- {*Derived relation from a lattice*}
paulson@13874
   331
    "relcl L == {(x,y). y \<in> cl L {x}}"
paulson@13885
   332
  
paulson@13885
   333
  latticeof :: "('a * 'a) set => 'a set set"
paulson@13885
   334
    -- {*Derived lattice from a relation: the set of upwards-closed sets*}
paulson@13885
   335
    "latticeof r == {X. \<forall>s t. s \<in> X & (s,t) \<in> r --> t \<in> X}"
paulson@13885
   336
paulson@13874
   337
paulson@13874
   338
lemma relcl_refl: "(a,a) \<in> relcl L"
paulson@13874
   339
by (simp add: relcl_def subset_cl [THEN subsetD])
paulson@13874
   340
paulson@13874
   341
lemma relcl_trans:
paulson@13874
   342
     "[| (a,b) \<in> relcl L; (b,c) \<in> relcl L; lattice L |] ==> (a,c) \<in> relcl L"
paulson@13874
   343
apply (simp add: relcl_def)
paulson@13874
   344
apply (blast intro: clD cl_in_lattice)
paulson@13874
   345
done
paulson@13874
   346
nipkow@30198
   347
lemma refl_relcl: "lattice L ==> refl (relcl L)"
nipkow@30198
   348
by (simp add: refl_onI relcl_def subset_cl [THEN subsetD])
paulson@13874
   349
paulson@13874
   350
lemma trans_relcl: "lattice L ==> trans (relcl L)"
paulson@13874
   351
by (blast intro: relcl_trans transI)
paulson@13874
   352
paulson@13885
   353
lemma lattice_latticeof: "lattice (latticeof r)"
paulson@13885
   354
by (auto simp add: lattice_def latticeof_def)
paulson@13885
   355
paulson@13885
   356
lemma lattice_singletonI:
paulson@13885
   357
     "[|lattice L; !!s. s \<in> X ==> {s} \<in> L|] ==> X \<in> L"
paulson@13885
   358
apply (cut_tac UN_singleton [of X]) 
paulson@13885
   359
apply (erule subst) 
paulson@13885
   360
apply (simp only: UN_in_lattice) 
paulson@13885
   361
done
paulson@13885
   362
paulson@13885
   363
text{*Equation (4.71) of Meier's thesis.  He gives no proof.*}
paulson@13885
   364
lemma cl_latticeof:
nipkow@30198
   365
     "[|refl r; trans r|] 
paulson@13885
   366
      ==> cl (latticeof r) X = {t. \<exists>s. s\<in>X & (s,t) \<in> r}" 
paulson@13885
   367
apply (rule equalityI) 
paulson@13885
   368
 apply (rule cl_least) 
paulson@13885
   369
  apply (simp (no_asm_use) add: latticeof_def trans_def, blast)
nipkow@30198
   370
 apply (simp add: latticeof_def refl_on_def, blast)
paulson@13885
   371
apply (simp add: latticeof_def, clarify)
paulson@13885
   372
apply (unfold cl_def, blast) 
paulson@13885
   373
done
paulson@13885
   374
paulson@13885
   375
text{*Related to (4.71).*}
paulson@13874
   376
lemma cl_eq_Collect_relcl:
paulson@13874
   377
     "lattice L ==> cl L X = {t. \<exists>s. s\<in>X & (s,t) \<in> relcl L}" 
paulson@13885
   378
apply (cut_tac UN_singleton [of X]) 
paulson@13885
   379
apply (erule subst) 
paulson@13874
   380
apply (force simp only: relcl_def cl_UN)
paulson@13874
   381
done
paulson@13874
   382
paulson@13885
   383
text{*Meier's theorem of section 4.5.3*}
paulson@13885
   384
theorem latticeof_relcl_eq: "lattice L ==> latticeof (relcl L) = L"
paulson@13885
   385
apply (rule equalityI) 
paulson@13885
   386
 prefer 2 apply (force simp add: latticeof_def relcl_def cl_def, clarify) 
paulson@13885
   387
apply (rename_tac X)
paulson@13885
   388
apply (rule cl_subset_in_lattice)   
paulson@13885
   389
 prefer 2 apply assumption
paulson@13885
   390
apply (drule cl_ident_iff [OF lattice_latticeof, THEN iffD2])
paulson@13885
   391
apply (drule equalityD1)   
paulson@13885
   392
apply (rule subset_trans) 
paulson@13885
   393
 prefer 2 apply assumption
paulson@13885
   394
apply (thin_tac "?U \<subseteq> X") 
paulson@13885
   395
apply (cut_tac A=X in UN_singleton) 
paulson@13885
   396
apply (erule subst) 
paulson@13885
   397
apply (simp only: cl_UN lattice_latticeof 
paulson@13885
   398
                  cl_latticeof [OF refl_relcl trans_relcl]) 
paulson@13885
   399
apply (simp add: relcl_def) 
paulson@13885
   400
done
paulson@13885
   401
paulson@13885
   402
theorem relcl_latticeof_eq:
nipkow@30198
   403
     "[|refl r; trans r|] ==> relcl (latticeof r) = r"
berghofe@23767
   404
by (simp add: relcl_def cl_latticeof)
paulson@13885
   405
paulson@13874
   406
paulson@13874
   407
subsubsection {*Decoupling Theorems*}
paulson@13874
   408
paulson@13874
   409
constdefs
paulson@13874
   410
  decoupled :: "['a program, 'a program] => bool"
paulson@13874
   411
   "decoupled F G ==
paulson@13874
   412
	\<forall>act \<in> Acts F. \<forall>B. G \<in> stable B --> G \<in> stable (wp act B)"
paulson@13874
   413
paulson@13874
   414
paulson@13874
   415
text{*Rao's Decoupling Theorem*}
paulson@13874
   416
lemma stableco: "F \<in> stable A ==> F \<in> A-B co A"
paulson@13874
   417
by (simp add: stable_def constrains_def, blast) 
paulson@13874
   418
paulson@13874
   419
theorem decoupling:
paulson@13874
   420
  assumes leadsTo: "F \<in> A leadsTo B"
paulson@13874
   421
      and Gstable: "G \<in> stable B"
paulson@13874
   422
      and dec:     "decoupled F G"
paulson@13874
   423
  shows "F\<squnion>G \<in> A leadsTo B"
paulson@13874
   424
proof -
paulson@13874
   425
  have prog: "{X. G \<in> stable X} \<in> progress_set F UNIV B"
paulson@13874
   426
    by (simp add: progress_set_def lattice_stable Gstable closed_def
paulson@13874
   427
                  stable_Un [OF Gstable] dec [unfolded decoupled_def]) 
paulson@13874
   428
  have "F\<squnion>G \<in> (UNIV\<inter>A) leadsTo B" 
paulson@13874
   429
    by (rule progress_set_Union [OF leadsTo prog],
paulson@13874
   430
        simp_all add: Gstable stableco)
paulson@13874
   431
  thus ?thesis by simp
paulson@13874
   432
qed
paulson@13874
   433
paulson@13874
   434
paulson@13874
   435
text{*Rao's Weak Decoupling Theorem*}
paulson@13874
   436
theorem weak_decoupling:
paulson@13874
   437
  assumes leadsTo: "F \<in> A leadsTo B"
paulson@13874
   438
      and stable: "F\<squnion>G \<in> stable B"
paulson@13874
   439
      and dec:     "decoupled F (F\<squnion>G)"
paulson@13874
   440
  shows "F\<squnion>G \<in> A leadsTo B"
paulson@13874
   441
proof -
paulson@13874
   442
  have prog: "{X. F\<squnion>G \<in> stable X} \<in> progress_set F UNIV B" 
paulson@13874
   443
    by (simp del: Join_stable
paulson@13874
   444
             add: progress_set_def lattice_stable stable closed_def
paulson@13874
   445
                  stable_Un [OF stable] dec [unfolded decoupled_def])
paulson@13874
   446
  have "F\<squnion>G \<in> (UNIV\<inter>A) leadsTo B" 
paulson@13874
   447
    by (rule progress_set_Union [OF leadsTo prog],
paulson@13874
   448
        simp_all del: Join_stable add: stable,
paulson@13874
   449
        simp add: stableco) 
paulson@13874
   450
  thus ?thesis by simp
paulson@13874
   451
qed
paulson@13874
   452
paulson@13874
   453
text{*The ``Decoupling via @{term G'} Union Theorem''*}
paulson@13874
   454
theorem decoupling_via_aux:
paulson@13874
   455
  assumes leadsTo: "F \<in> A leadsTo B"
paulson@13874
   456
      and prog: "{X. G' \<in> stable X} \<in> progress_set F UNIV B"
paulson@13874
   457
      and GG':  "G \<le> G'"  
paulson@13874
   458
               --{*Beware!  This is the converse of the refinement relation!*}
paulson@13874
   459
  shows "F\<squnion>G \<in> A leadsTo B"
paulson@13874
   460
proof -
paulson@13874
   461
  from prog have stable: "G' \<in> stable B"
paulson@13874
   462
    by (simp add: progress_set_def)
paulson@13874
   463
  have "F\<squnion>G \<in> (UNIV\<inter>A) leadsTo B" 
paulson@13874
   464
    by (rule progress_set_Union [OF leadsTo prog],
paulson@13874
   465
        simp_all add: stable stableco component_stable [OF GG'])
paulson@13874
   466
  thus ?thesis by simp
paulson@13874
   467
qed
paulson@13874
   468
paulson@13874
   469
paulson@13874
   470
subsection{*Composition Theorems Based on Monotonicity and Commutativity*}
paulson@13874
   471
paulson@13888
   472
subsubsection{*Commutativity of @{term "cl L"} and assignment.*}
paulson@13874
   473
constdefs 
paulson@13874
   474
  commutes :: "['a program, 'a set, 'a set,  'a set set] => bool"
paulson@13874
   475
   "commutes F T B L ==
paulson@13874
   476
       \<forall>M. \<forall>act \<in> Acts F. B \<subseteq> M --> 
paulson@13874
   477
           cl L (T \<inter> wp act M) \<subseteq> T \<inter> (B \<union> wp act (cl L (T\<inter>M)))"
paulson@13874
   478
paulson@13874
   479
paulson@13888
   480
text{*From Meier's thesis, section 4.5.6*}
paulson@13885
   481
lemma commutativity1_lemma:
paulson@13874
   482
  assumes commutes: "commutes F T B L" 
paulson@13874
   483
      and lattice:  "lattice L"
paulson@13874
   484
      and BL: "B \<in> L"
paulson@13874
   485
      and TL: "T \<in> L"
paulson@13874
   486
  shows "closed F T B L"
paulson@13874
   487
apply (simp add: closed_def, clarify)
paulson@13874
   488
apply (rule ProgressSets.cl_subset_in_lattice [OF _ lattice])  
paulson@15102
   489
apply (simp add: Int_Un_distrib cl_Un [OF lattice] Un_subset_iff 
paulson@13874
   490
                 cl_ident Int_in_lattice [OF TL BL lattice] Un_upper1)
paulson@13874
   491
apply (subgoal_tac "cl L (T \<inter> wp act M) \<subseteq> T \<inter> (B \<union> wp act (cl L (T \<inter> M)))") 
paulson@13874
   492
 prefer 2 
paulson@15102
   493
 apply (cut_tac commutes, simp add: commutes_def) 
paulson@13874
   494
apply (erule subset_trans) 
paulson@13874
   495
apply (simp add: cl_ident)
paulson@13874
   496
apply (blast intro: rev_subsetD [OF _ wp_mono]) 
paulson@13874
   497
done
paulson@13874
   498
paulson@13888
   499
text{*Version packaged with @{thm progress_set_Union}*}
paulson@13885
   500
lemma commutativity1:
paulson@13885
   501
  assumes leadsTo: "F \<in> A leadsTo B"
paulson@13885
   502
      and lattice:  "lattice L"
paulson@13885
   503
      and BL: "B \<in> L"
paulson@13885
   504
      and TL: "T \<in> L"
paulson@13885
   505
      and Fstable: "F \<in> stable T"
paulson@13885
   506
      and Gco: "!!X. X\<in>L ==> G \<in> X-B co X"
paulson@13885
   507
      and commutes: "commutes F T B L" 
paulson@13885
   508
  shows "F\<squnion>G \<in> T\<inter>A leadsTo B"
paulson@13885
   509
by (rule progress_set_Union [OF leadsTo _ Fstable subset_refl BL Gco],
paulson@13885
   510
    simp add: progress_set_def commutativity1_lemma commutes lattice BL TL) 
paulson@13885
   511
paulson@13885
   512
paulson@13885
   513
paulson@13874
   514
text{*Possibly move to Relation.thy, after @{term single_valued}*}
paulson@13874
   515
constdefs
paulson@13874
   516
  funof :: "[('a*'b)set, 'a] => 'b"
paulson@13874
   517
   "funof r == (\<lambda>x. THE y. (x,y) \<in> r)"
paulson@13874
   518
paulson@13874
   519
lemma funof_eq: "[|single_valued r; (x,y) \<in> r|] ==> funof r x = y"
paulson@13874
   520
by (simp add: funof_def single_valued_def, blast)
paulson@13874
   521
paulson@13874
   522
lemma funof_Pair_in:
paulson@13874
   523
     "[|single_valued r; x \<in> Domain r|] ==> (x, funof r x) \<in> r"
paulson@13874
   524
by (force simp add: funof_eq) 
paulson@13874
   525
paulson@13874
   526
lemma funof_in:
paulson@13874
   527
     "[|r``{x} \<subseteq> A; single_valued r; x \<in> Domain r|] ==> funof r x \<in> A" 
paulson@13874
   528
by (force simp add: funof_eq)
paulson@13874
   529
 
paulson@13874
   530
lemma funof_imp_wp: "[|funof act t \<in> A; single_valued act|] ==> t \<in> wp act A"
paulson@13874
   531
by (force simp add: in_wp_iff funof_eq)
paulson@13874
   532
paulson@13874
   533
paulson@13874
   534
subsubsection{*Commutativity of Functions and Relation*}
paulson@13874
   535
text{*Thesis, page 109*}
paulson@13874
   536
paulson@13885
   537
(*FIXME: this proof is an ungodly mess*)
paulson@13888
   538
text{*From Meier's thesis, section 4.5.6*}
paulson@13885
   539
lemma commutativity2_lemma:
paulson@13874
   540
  assumes dcommutes: 
paulson@13874
   541
        "\<forall>act \<in> Acts F. 
paulson@13874
   542
         \<forall>s \<in> T. \<forall>t. (s,t) \<in> relcl L --> 
paulson@13874
   543
                      s \<in> B | t \<in> B | (funof act s, funof act t) \<in> relcl L"
paulson@13874
   544
      and determ: "!!act. act \<in> Acts F ==> single_valued act"
paulson@13874
   545
      and total: "!!act. act \<in> Acts F ==> Domain act = UNIV"
paulson@13874
   546
      and lattice:  "lattice L"
paulson@13874
   547
      and BL: "B \<in> L"
paulson@13874
   548
      and TL: "T \<in> L"
paulson@13874
   549
      and Fstable: "F \<in> stable T"
paulson@13874
   550
  shows  "commutes F T B L"
paulson@15102
   551
apply (simp add: commutes_def del: Int_subset_iff, clarify)  
paulson@13874
   552
apply (rename_tac t)
paulson@13874
   553
apply (subgoal_tac "\<exists>s. (s,t) \<in> relcl L & s \<in> T \<inter> wp act M") 
paulson@13885
   554
 prefer 2 
paulson@13885
   555
 apply (force simp add: cl_eq_Collect_relcl [OF lattice], simp, clarify) 
paulson@13874
   556
apply (subgoal_tac "\<forall>u\<in>L. s \<in> u --> t \<in> u") 
paulson@13874
   557
 prefer 2 
paulson@13874
   558
 apply (intro ballI impI) 
paulson@13874
   559
 apply (subst cl_ident [symmetric], assumption)
paulson@13874
   560
 apply (simp add: relcl_def)  
paulson@13874
   561
 apply (blast intro: cl_mono [THEN [2] rev_subsetD])  
paulson@13874
   562
apply (subgoal_tac "funof act s \<in> T\<inter>M") 
paulson@13874
   563
 prefer 2 
paulson@13874
   564
 apply (cut_tac Fstable) 
paulson@13874
   565
 apply (force intro!: funof_in 
paulson@13874
   566
              simp add: wp_def stable_def constrains_def determ total) 
paulson@13874
   567
apply (subgoal_tac "s \<in> B | t \<in> B | (funof act s, funof act t) \<in> relcl L")
paulson@13874
   568
 prefer 2
paulson@13874
   569
 apply (rule dcommutes [rule_format], assumption+) 
paulson@13874
   570
apply (subgoal_tac "t \<in> B | funof act t \<in> cl L (T\<inter>M)")
paulson@13874
   571
 prefer 2 
paulson@13874
   572
 apply (simp add: relcl_def)
paulson@13874
   573
 apply (blast intro: BL cl_mono [THEN [2] rev_subsetD])  
paulson@13874
   574
apply (subgoal_tac "t \<in> B | t \<in> wp act (cl L (T\<inter>M))")
paulson@13874
   575
 prefer 2
paulson@13874
   576
 apply (blast intro: funof_imp_wp determ) 
paulson@13874
   577
apply (blast intro: TL cl_mono [THEN [2] rev_subsetD])  
paulson@13874
   578
done
paulson@13874
   579
paulson@13885
   580
paulson@13888
   581
text{*Version packaged with @{thm progress_set_Union}*}
paulson@13885
   582
lemma commutativity2:
paulson@13885
   583
  assumes leadsTo: "F \<in> A leadsTo B"
paulson@13885
   584
      and dcommutes: 
paulson@13885
   585
        "\<forall>act \<in> Acts F. 
paulson@13885
   586
         \<forall>s \<in> T. \<forall>t. (s,t) \<in> relcl L --> 
paulson@13885
   587
                      s \<in> B | t \<in> B | (funof act s, funof act t) \<in> relcl L"
paulson@13885
   588
      and determ: "!!act. act \<in> Acts F ==> single_valued act"
paulson@13885
   589
      and total: "!!act. act \<in> Acts F ==> Domain act = UNIV"
paulson@13885
   590
      and lattice:  "lattice L"
paulson@13885
   591
      and BL: "B \<in> L"
paulson@13885
   592
      and TL: "T \<in> L"
paulson@13885
   593
      and Fstable: "F \<in> stable T"
paulson@13885
   594
      and Gco: "!!X. X\<in>L ==> G \<in> X-B co X"
paulson@13885
   595
  shows "F\<squnion>G \<in> T\<inter>A leadsTo B"
paulson@13885
   596
apply (rule commutativity1 [OF leadsTo lattice]) 
paulson@13885
   597
apply (simp_all add: Gco commutativity2_lemma dcommutes determ total
paulson@13885
   598
                     lattice BL TL Fstable)
paulson@13885
   599
done
paulson@13885
   600
paulson@13885
   601
paulson@13888
   602
subsection {*Monotonicity*}
paulson@14150
   603
text{*From Meier's thesis, section 4.5.7, page 110*}
paulson@13888
   604
(*to be continued?*)
paulson@13888
   605
paulson@13853
   606
end