src/HOL/ex/Records.thy
author haftmann
Fri Oct 10 19:55:32 2014 +0200 (2014-10-10)
changeset 58646 cd63a4b12a33
parent 58310 91ea607a34d8
child 58889 5b7a9633cfa8
permissions -rw-r--r--
specialized specification: avoid trivial instances
wenzelm@10052
     1
(*  Title:      HOL/ex/Records.thy
wenzelm@46231
     2
    Author:     Wolfgang Naraschewski, Norbert Schirmer and Markus Wenzel,
schirmer@14700
     3
                TU Muenchen
wenzelm@10052
     4
*)
wenzelm@10052
     5
wenzelm@10052
     6
header {* Using extensible records in HOL -- points and coloured points *}
wenzelm@10052
     7
haftmann@33596
     8
theory Records
wenzelm@46231
     9
imports Main
haftmann@33596
    10
begin
wenzelm@10052
    11
wenzelm@10052
    12
subsection {* Points *}
wenzelm@10052
    13
wenzelm@10052
    14
record point =
wenzelm@11939
    15
  xpos :: nat
wenzelm@11939
    16
  ypos :: nat
wenzelm@10052
    17
wenzelm@10052
    18
text {*
wenzelm@11939
    19
  Apart many other things, above record declaration produces the
wenzelm@11939
    20
  following theorems:
wenzelm@10052
    21
*}
wenzelm@10052
    22
schirmer@14700
    23
wenzelm@46231
    24
thm point.simps
wenzelm@46231
    25
thm point.iffs
wenzelm@46231
    26
thm point.defs
wenzelm@10052
    27
wenzelm@10052
    28
text {*
wenzelm@11939
    29
  The set of theorems @{thm [source] point.simps} is added
wenzelm@11939
    30
  automatically to the standard simpset, @{thm [source] point.iffs} is
wenzelm@11939
    31
  added to the Classical Reasoner and Simplifier context.
wenzelm@10052
    32
schirmer@14700
    33
  \medskip Record declarations define new types and type abbreviations:
wenzelm@10357
    34
  @{text [display]
schirmer@14700
    35
"  point = \<lparr>xpos :: nat, ypos :: nat\<rparr> = () point_ext_type
schirmer@14700
    36
  'a point_scheme = \<lparr>xpos :: nat, ypos :: nat, ... :: 'a\<rparr>  = 'a point_ext_type"}
wenzelm@10052
    37
*}
wenzelm@10052
    38
wenzelm@11939
    39
consts foo2 :: "(| xpos :: nat, ypos :: nat |)"
wenzelm@11939
    40
consts foo4 :: "'a => (| xpos :: nat, ypos :: nat, ... :: 'a |)"
wenzelm@10052
    41
wenzelm@10052
    42
wenzelm@10052
    43
subsubsection {* Introducing concrete records and record schemes *}
wenzelm@10052
    44
wenzelm@46231
    45
definition foo1 :: point
wenzelm@46231
    46
  where "foo1 = (| xpos = 1, ypos = 0 |)"
haftmann@22737
    47
wenzelm@46231
    48
definition foo3 :: "'a => 'a point_scheme"
wenzelm@46231
    49
  where "foo3 ext = (| xpos = 1, ypos = 0, ... = ext |)"
wenzelm@10052
    50
wenzelm@10052
    51
wenzelm@10052
    52
subsubsection {* Record selection and record update *}
wenzelm@10052
    53
wenzelm@46231
    54
definition getX :: "'a point_scheme => nat"
wenzelm@46231
    55
  where "getX r = xpos r"
wenzelm@21404
    56
wenzelm@46231
    57
definition setX :: "'a point_scheme => nat => 'a point_scheme"
wenzelm@46231
    58
  where "setX r n = r (| xpos := n |)"
wenzelm@10052
    59
wenzelm@10052
    60
wenzelm@10052
    61
subsubsection {* Some lemmas about records *}
wenzelm@10052
    62
wenzelm@10357
    63
text {* Basic simplifications. *}
wenzelm@10052
    64
wenzelm@11939
    65
lemma "point.make n p = (| xpos = n, ypos = p |)"
wenzelm@11939
    66
  by (simp only: point.make_def)
wenzelm@10052
    67
wenzelm@11939
    68
lemma "xpos (| xpos = m, ypos = n, ... = p |) = m"
wenzelm@10052
    69
  by simp
wenzelm@10052
    70
wenzelm@11939
    71
lemma "(| xpos = m, ypos = n, ... = p |) (| xpos:= 0 |) = (| xpos = 0, ypos = n, ... = p |)"
wenzelm@10052
    72
  by simp
wenzelm@10052
    73
wenzelm@10052
    74
wenzelm@10357
    75
text {* \medskip Equality of records. *}
wenzelm@10052
    76
wenzelm@11939
    77
lemma "n = n' ==> p = p' ==> (| xpos = n, ypos = p |) = (| xpos = n', ypos = p' |)"
wenzelm@10052
    78
  -- "introduction of concrete record equality"
wenzelm@10052
    79
  by simp
wenzelm@10052
    80
wenzelm@11939
    81
lemma "(| xpos = n, ypos = p |) = (| xpos = n', ypos = p' |) ==> n = n'"
wenzelm@10052
    82
  -- "elimination of concrete record equality"
wenzelm@10052
    83
  by simp
wenzelm@10052
    84
wenzelm@11939
    85
lemma "r (| xpos := n |) (| ypos := m |) = r (| ypos := m |) (| xpos := n |)"
wenzelm@10052
    86
  -- "introduction of abstract record equality"
wenzelm@10052
    87
  by simp
wenzelm@10052
    88
wenzelm@11939
    89
lemma "r (| xpos := n |) = r (| xpos := n' |) ==> n = n'"
wenzelm@10052
    90
  -- "elimination of abstract record equality (manual proof)"
wenzelm@10052
    91
proof -
wenzelm@11939
    92
  assume "r (| xpos := n |) = r (| xpos := n' |)" (is "?lhs = ?rhs")
wenzelm@46231
    93
  then have "xpos ?lhs = xpos ?rhs" by simp
wenzelm@46231
    94
  then show ?thesis by simp
wenzelm@10052
    95
qed
wenzelm@10052
    96
wenzelm@10052
    97
wenzelm@10357
    98
text {* \medskip Surjective pairing *}
wenzelm@10052
    99
wenzelm@11939
   100
lemma "r = (| xpos = xpos r, ypos = ypos r |)"
wenzelm@10052
   101
  by simp
wenzelm@10052
   102
wenzelm@12591
   103
lemma "r = (| xpos = xpos r, ypos = ypos r, ... = point.more r |)"
wenzelm@10052
   104
  by simp
wenzelm@10052
   105
wenzelm@10052
   106
wenzelm@10357
   107
text {*
wenzelm@11939
   108
  \medskip Representation of records by cases or (degenerate)
wenzelm@11939
   109
  induction.
wenzelm@10357
   110
*}
wenzelm@10052
   111
schirmer@14700
   112
lemma "r(| xpos := n |) (| ypos := m |) = r (| ypos := m |) (| xpos := n |)"
wenzelm@11939
   113
proof (cases r)
wenzelm@11939
   114
  fix xpos ypos more
wenzelm@11939
   115
  assume "r = (| xpos = xpos, ypos = ypos, ... = more |)"
wenzelm@46231
   116
  then show ?thesis by simp
wenzelm@11939
   117
qed
wenzelm@11939
   118
wenzelm@11939
   119
lemma "r (| xpos := n |) (| ypos := m |) = r (| ypos := m |) (| xpos := n |)"
wenzelm@11939
   120
proof (induct r)
wenzelm@11939
   121
  fix xpos ypos more
wenzelm@11939
   122
  show "(| xpos = xpos, ypos = ypos, ... = more |) (| xpos := n, ypos := m |) =
wenzelm@11939
   123
      (| xpos = xpos, ypos = ypos, ... = more |) (| ypos := m, xpos := n |)"
wenzelm@10052
   124
    by simp
wenzelm@10052
   125
qed
wenzelm@10052
   126
wenzelm@11939
   127
lemma "r (| xpos := n |) (| xpos := m |) = r (| xpos := m |)"
wenzelm@11939
   128
proof (cases r)
wenzelm@11939
   129
  fix xpos ypos more
wenzelm@11939
   130
  assume "r = \<lparr>xpos = xpos, ypos = ypos, \<dots> = more\<rparr>"
wenzelm@46231
   131
  then show ?thesis by simp
wenzelm@10052
   132
qed
wenzelm@10052
   133
wenzelm@11939
   134
lemma "r (| xpos := n |) (| xpos := m |) = r (| xpos := m |)"
wenzelm@11939
   135
proof (cases r)
wenzelm@11939
   136
  case fields
wenzelm@46231
   137
  then show ?thesis by simp
wenzelm@11939
   138
qed
wenzelm@11939
   139
wenzelm@11939
   140
lemma "r (| xpos := n |) (| xpos := m |) = r (| xpos := m |)"
wenzelm@11939
   141
  by (cases r) simp
wenzelm@11939
   142
wenzelm@10052
   143
wenzelm@10357
   144
text {*
wenzelm@10357
   145
 \medskip Concrete records are type instances of record schemes.
wenzelm@10357
   146
*}
wenzelm@10052
   147
wenzelm@46231
   148
definition foo5 :: nat
wenzelm@46231
   149
  where "foo5 = getX (| xpos = 1, ypos = 0 |)"
wenzelm@10052
   150
wenzelm@10052
   151
wenzelm@11939
   152
text {* \medskip Manipulating the ``@{text "..."}'' (more) part. *}
wenzelm@10052
   153
wenzelm@46231
   154
definition incX :: "'a point_scheme => 'a point_scheme"
wenzelm@46231
   155
  where "incX r = (| xpos = xpos r + 1, ypos = ypos r, ... = point.more r |)"
wenzelm@10052
   156
wenzelm@11939
   157
lemma "incX r = setX r (Suc (getX r))"
wenzelm@11939
   158
  by (simp add: getX_def setX_def incX_def)
wenzelm@11939
   159
wenzelm@10052
   160
wenzelm@10357
   161
text {* An alternative definition. *}
wenzelm@10052
   162
wenzelm@46231
   163
definition incX' :: "'a point_scheme => 'a point_scheme"
wenzelm@46231
   164
  where "incX' r = r (| xpos := xpos r + 1 |)"
wenzelm@10052
   165
wenzelm@10052
   166
wenzelm@10052
   167
subsection {* Coloured points: record extension *}
wenzelm@10052
   168
blanchet@58310
   169
datatype colour = Red | Green | Blue
wenzelm@10052
   170
wenzelm@10052
   171
record cpoint = point +
wenzelm@10052
   172
  colour :: colour
wenzelm@10052
   173
wenzelm@10052
   174
wenzelm@10052
   175
text {*
schirmer@14700
   176
  The record declaration defines a new type constructure and abbreviations:
wenzelm@10357
   177
  @{text [display]
wenzelm@46231
   178
"  cpoint = (| xpos :: nat, ypos :: nat, colour :: colour |) =
schirmer@14700
   179
     () cpoint_ext_type point_ext_type
wenzelm@46231
   180
   'a cpoint_scheme = (| xpos :: nat, ypos :: nat, colour :: colour, ... :: 'a |) =
schirmer@14700
   181
     'a cpoint_ext_type point_ext_type"}
wenzelm@10052
   182
*}
wenzelm@10052
   183
wenzelm@10052
   184
consts foo6 :: cpoint
wenzelm@11939
   185
consts foo7 :: "(| xpos :: nat, ypos :: nat, colour :: colour |)"
wenzelm@11939
   186
consts foo8 :: "'a cpoint_scheme"
wenzelm@11939
   187
consts foo9 :: "(| xpos :: nat, ypos :: nat, colour :: colour, ... :: 'a |)"
wenzelm@10052
   188
wenzelm@10052
   189
wenzelm@10357
   190
text {*
wenzelm@10357
   191
 Functions on @{text point} schemes work for @{text cpoints} as well.
wenzelm@10357
   192
*}
wenzelm@10052
   193
wenzelm@46231
   194
definition foo10 :: nat
wenzelm@46231
   195
  where "foo10 = getX (| xpos = 2, ypos = 0, colour = Blue |)"
wenzelm@10052
   196
wenzelm@10052
   197
wenzelm@10052
   198
subsubsection {* Non-coercive structural subtyping *}
wenzelm@10052
   199
wenzelm@10357
   200
text {*
wenzelm@10357
   201
 Term @{term foo11} has type @{typ cpoint}, not type @{typ point} ---
wenzelm@10357
   202
 Great!
wenzelm@10357
   203
*}
wenzelm@10052
   204
wenzelm@46231
   205
definition foo11 :: cpoint
wenzelm@46231
   206
  where "foo11 = setX (| xpos = 2, ypos = 0, colour = Blue |) 0"
wenzelm@10052
   207
wenzelm@10052
   208
wenzelm@10052
   209
subsection {* Other features *}
wenzelm@10052
   210
wenzelm@10357
   211
text {* Field names contribute to record identity. *}
wenzelm@10052
   212
wenzelm@10052
   213
record point' =
wenzelm@11939
   214
  xpos' :: nat
wenzelm@11939
   215
  ypos' :: nat
wenzelm@10052
   216
wenzelm@10357
   217
text {*
wenzelm@11939
   218
  \noindent May not apply @{term getX} to @{term [source] "(| xpos' =
wenzelm@11939
   219
  2, ypos' = 0 |)"} -- type error.
wenzelm@10357
   220
*}
wenzelm@10052
   221
wenzelm@10357
   222
text {* \medskip Polymorphic records. *}
wenzelm@10052
   223
wenzelm@10052
   224
record 'a point'' = point +
wenzelm@10052
   225
  content :: 'a
wenzelm@10052
   226
wenzelm@42463
   227
type_synonym cpoint'' = "colour point''"
wenzelm@10052
   228
schirmer@25707
   229
schirmer@25707
   230
schirmer@25707
   231
text {* Updating a record field with an identical value is simplified.*}
schirmer@25707
   232
lemma "r (| xpos := xpos r |) = r"
schirmer@25707
   233
  by simp
schirmer@25707
   234
schirmer@25707
   235
text {* Only the most recent update to a component survives simplification. *}
schirmer@25707
   236
lemma "r (| xpos := x, ypos := y, xpos := x' |) = r (| ypos := y, xpos := x' |)"
schirmer@25707
   237
  by simp
schirmer@25707
   238
schirmer@25707
   239
text {* In some cases its convenient to automatically split
schirmer@25707
   240
(quantified) records. For this purpose there is the simproc @{ML [source]
haftmann@38012
   241
"Record.split_simproc"} and the tactic @{ML [source]
haftmann@38012
   242
"Record.split_simp_tac"}.  The simplification procedure
schirmer@25707
   243
only splits the records, whereas the tactic also simplifies the
schirmer@25707
   244
resulting goal with the standard record simplification rules. A
schirmer@25707
   245
(generalized) predicate on the record is passed as parameter that
schirmer@25707
   246
decides whether or how `deep' to split the record. It can peek on the
schirmer@25707
   247
subterm starting at the quantified occurrence of the record (including
schirmer@25707
   248
the quantifier). The value @{ML "0"} indicates no split, a value
schirmer@25707
   249
greater @{ML "0"} splits up to the given bound of record extension and
schirmer@25707
   250
finally the value @{ML "~1"} completely splits the record.
haftmann@38012
   251
@{ML [source] "Record.split_simp_tac"} additionally takes a list of
schirmer@25707
   252
equations for simplification and can also split fixed record variables.
schirmer@25707
   253
schirmer@25707
   254
*}
schirmer@25707
   255
schirmer@25707
   256
lemma "(\<forall>r. P (xpos r)) \<longrightarrow> (\<forall>x. P x)"
wenzelm@51717
   257
  apply (tactic {* simp_tac (put_simpset HOL_basic_ss @{context}
wenzelm@51717
   258
    addsimprocs [Record.split_simproc (K ~1)]) 1 *})
schirmer@25707
   259
  apply simp
schirmer@25707
   260
  done
schirmer@25707
   261
schirmer@25707
   262
lemma "(\<forall>r. P (xpos r)) \<longrightarrow> (\<forall>x. P x)"
wenzelm@51717
   263
  apply (tactic {* Record.split_simp_tac @{context} [] (K ~1) 1*})
schirmer@25707
   264
  apply simp
schirmer@25707
   265
  done
schirmer@25707
   266
schirmer@25707
   267
lemma "(\<exists>r. P (xpos r)) \<longrightarrow> (\<exists>x. P x)"
wenzelm@51717
   268
  apply (tactic {* simp_tac (put_simpset HOL_basic_ss @{context}
wenzelm@51717
   269
    addsimprocs [Record.split_simproc (K ~1)]) 1 *})
schirmer@25707
   270
  apply simp
schirmer@25707
   271
  done
schirmer@25707
   272
schirmer@25707
   273
lemma "(\<exists>r. P (xpos r)) \<longrightarrow> (\<exists>x. P x)"
wenzelm@51717
   274
  apply (tactic {* Record.split_simp_tac @{context} [] (K ~1) 1 *})
schirmer@25707
   275
  apply simp
schirmer@25707
   276
  done
schirmer@25707
   277
schirmer@25707
   278
lemma "\<And>r. P (xpos r) \<Longrightarrow> (\<exists>x. P x)"
wenzelm@51717
   279
  apply (tactic {* simp_tac (put_simpset HOL_basic_ss @{context}
wenzelm@51717
   280
    addsimprocs [Record.split_simproc (K ~1)]) 1 *})
schirmer@25707
   281
  apply auto
schirmer@25707
   282
  done
schirmer@25707
   283
schirmer@25707
   284
lemma "\<And>r. P (xpos r) \<Longrightarrow> (\<exists>x. P x)"
wenzelm@51717
   285
  apply (tactic {* Record.split_simp_tac @{context} [] (K ~1) 1*})
schirmer@25707
   286
  apply auto
schirmer@25707
   287
  done
schirmer@25707
   288
schirmer@25707
   289
lemma "P (xpos r) \<Longrightarrow> (\<exists>x. P x)"
wenzelm@51717
   290
  apply (tactic {* Record.split_simp_tac @{context} [] (K ~1) 1*})
schirmer@25707
   291
  apply auto
schirmer@25707
   292
  done
schirmer@25707
   293
schirmer@25707
   294
lemma True
schirmer@25707
   295
proof -
schirmer@25707
   296
  {
wenzelm@26932
   297
    fix P r
schirmer@25707
   298
    assume pre: "P (xpos r)"
wenzelm@46231
   299
    then have "\<exists>x. P x"
schirmer@25707
   300
      apply -
wenzelm@51717
   301
      apply (tactic {* Record.split_simp_tac @{context} [] (K ~1) 1 *})
wenzelm@46231
   302
      apply auto
schirmer@25707
   303
      done
schirmer@25707
   304
  }
schirmer@25707
   305
  show ?thesis ..
schirmer@25707
   306
qed
schirmer@25707
   307
wenzelm@46231
   308
text {* The effect of simproc @{ML [source] Record.ex_sel_eq_simproc} is
wenzelm@46231
   309
  illustrated by the following lemma. *}
schirmer@25707
   310
schirmer@25707
   311
lemma "\<exists>r. xpos r = x"
wenzelm@51717
   312
  apply (tactic {* simp_tac (put_simpset HOL_basic_ss @{context}
wenzelm@51717
   313
    addsimprocs [Record.ex_sel_eq_simproc]) 1 *})
schirmer@25707
   314
  done
schirmer@25707
   315
schirmer@25707
   316
haftmann@34971
   317
subsection {* A more complex record expression *}
haftmann@34971
   318
haftmann@34971
   319
record ('a, 'b, 'c) bar = bar1 :: 'a
haftmann@34971
   320
  bar2 :: 'b
haftmann@34971
   321
  bar3 :: 'c
haftmann@34971
   322
  bar21 :: "'b \<times> 'a"
haftmann@34971
   323
  bar32 :: "'c \<times> 'b"
haftmann@34971
   324
  bar31 :: "'c \<times> 'a"
haftmann@34971
   325
haftmann@34971
   326
haftmann@33613
   327
subsection {* Some code generation *}
haftmann@33613
   328
haftmann@37826
   329
export_code foo1 foo3 foo5 foo10 checking SML
haftmann@33613
   330
gerwin@47842
   331
text {*
gerwin@47842
   332
  Code generation can also be switched off, for instance for very large records
gerwin@47842
   333
*}
gerwin@47842
   334
gerwin@47842
   335
declare [[record_codegen = false]]
gerwin@47842
   336
gerwin@47842
   337
record not_so_large_record =
gerwin@47842
   338
  bar520 :: nat
gerwin@47842
   339
  bar521 :: "nat * nat"
gerwin@47842
   340
gerwin@47842
   341
declare [[record_codegen = true]]
gerwin@47842
   342
wenzelm@10052
   343
end