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