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