src/HOL/Library/Code_Index.thy
author haftmann
Fri Feb 06 09:05:19 2009 +0100 (2009-02-06)
changeset 29815 9e94b7078fa5
parent 28708 a1a436f09ec6
child 29823 0ab754d13ccd
permissions -rw-r--r--
mandatory prefix for index conversion operations
haftmann@29815
     1
(* Author: Florian Haftmann, TU Muenchen *)
haftmann@24999
     2
haftmann@24999
     3
header {* Type of indices *}
haftmann@24999
     4
haftmann@24999
     5
theory Code_Index
haftmann@28228
     6
imports Plain "~~/src/HOL/Code_Eval" "~~/src/HOL/Presburger"
haftmann@24999
     7
begin
haftmann@24999
     8
haftmann@24999
     9
text {*
haftmann@25767
    10
  Indices are isomorphic to HOL @{typ nat} but
haftmann@27104
    11
  mapped to target-language builtin integers.
haftmann@24999
    12
*}
haftmann@24999
    13
haftmann@24999
    14
subsection {* Datatype of indices *}
haftmann@24999
    15
haftmann@29815
    16
typedef (open) index = "UNIV \<Colon> nat set"
haftmann@29815
    17
  morphisms nat_of of_nat by rule
haftmann@24999
    18
haftmann@29815
    19
lemma of_nat_nat_of [simp]:
haftmann@29815
    20
  "of_nat (nat_of k) = k"
haftmann@29815
    21
  by (rule nat_of_inverse)
haftmann@24999
    22
haftmann@29815
    23
lemma nat_of_of_nat [simp]:
haftmann@29815
    24
  "nat_of (of_nat n) = n"
haftmann@29815
    25
  by (rule of_nat_inverse) (rule UNIV_I)
haftmann@24999
    26
haftmann@28708
    27
lemma [measure_function]:
haftmann@29815
    28
  "is_measure nat_of" by (rule is_measure_trivial)
haftmann@28708
    29
haftmann@24999
    30
lemma index:
haftmann@29815
    31
  "(\<And>n\<Colon>index. PROP P n) \<equiv> (\<And>n\<Colon>nat. PROP P (of_nat n))"
haftmann@24999
    32
proof
haftmann@25767
    33
  fix n :: nat
haftmann@25767
    34
  assume "\<And>n\<Colon>index. PROP P n"
haftmann@29815
    35
  then show "PROP P (of_nat n)" .
haftmann@24999
    36
next
haftmann@25767
    37
  fix n :: index
haftmann@29815
    38
  assume "\<And>n\<Colon>nat. PROP P (of_nat n)"
haftmann@29815
    39
  then have "PROP P (of_nat (nat_of n))" .
haftmann@25767
    40
  then show "PROP P n" by simp
haftmann@24999
    41
qed
haftmann@24999
    42
haftmann@26140
    43
lemma index_case:
haftmann@29815
    44
  assumes "\<And>n. k = of_nat n \<Longrightarrow> P"
haftmann@26140
    45
  shows P
haftmann@29815
    46
  by (rule assms [of "nat_of k"]) simp
haftmann@26140
    47
wenzelm@26304
    48
lemma index_induct_raw:
haftmann@29815
    49
  assumes "\<And>n. P (of_nat n)"
haftmann@26140
    50
  shows "P k"
haftmann@26140
    51
proof -
haftmann@29815
    52
  from assms have "P (of_nat (nat_of k))" .
haftmann@26140
    53
  then show ?thesis by simp
haftmann@26140
    54
qed
haftmann@26140
    55
haftmann@29815
    56
lemma nat_of_inject [simp]:
haftmann@29815
    57
  "nat_of k = nat_of l \<longleftrightarrow> k = l"
haftmann@29815
    58
  by (rule nat_of_inject)
haftmann@26140
    59
haftmann@29815
    60
lemma of_nat_inject [simp]:
haftmann@29815
    61
  "of_nat n = of_nat m \<longleftrightarrow> n = m"
haftmann@29815
    62
  by (rule of_nat_inject) (rule UNIV_I)+
haftmann@26140
    63
haftmann@26140
    64
instantiation index :: zero
haftmann@26140
    65
begin
haftmann@26140
    66
haftmann@28562
    67
definition [simp, code del]:
haftmann@29815
    68
  "0 = of_nat 0"
haftmann@26140
    69
haftmann@26140
    70
instance ..
haftmann@26140
    71
haftmann@26140
    72
end
haftmann@26140
    73
haftmann@26140
    74
definition [simp]:
haftmann@29815
    75
  "Suc_index k = of_nat (Suc (nat_of k))"
haftmann@26140
    76
haftmann@27104
    77
rep_datatype "0 \<Colon> index" Suc_index
haftmann@26140
    78
proof -
haftmann@27104
    79
  fix P :: "index \<Rightarrow> bool"
haftmann@27104
    80
  fix k :: index
haftmann@29815
    81
  assume "P 0" then have init: "P (of_nat 0)" by simp
haftmann@26140
    82
  assume "\<And>k. P k \<Longrightarrow> P (Suc_index k)"
haftmann@29815
    83
    then have "\<And>n. P (of_nat n) \<Longrightarrow> P (Suc_index (of_nat n))" .
haftmann@29815
    84
    then have step: "\<And>n. P (of_nat n) \<Longrightarrow> P (of_nat (Suc n))" by simp
haftmann@29815
    85
  from init step have "P (of_nat (nat_of k))"
haftmann@29815
    86
    by (induct "nat_of k") simp_all
haftmann@26140
    87
  then show "P k" by simp
haftmann@27104
    88
qed simp_all
haftmann@26140
    89
haftmann@28562
    90
lemmas [code del] = index.recs index.cases
haftmann@26140
    91
haftmann@26140
    92
declare index_case [case_names nat, cases type: index]
haftmann@27104
    93
declare index.induct [case_names nat, induct type: index]
haftmann@26140
    94
haftmann@28562
    95
lemma [code]:
haftmann@29815
    96
  "index_size = nat_of"
haftmann@26140
    97
proof (rule ext)
haftmann@26140
    98
  fix k
haftmann@29815
    99
  have "index_size k = nat_size (nat_of k)"
haftmann@26140
   100
    by (induct k rule: index.induct) (simp_all del: zero_index_def Suc_index_def, simp_all)
haftmann@29815
   101
  also have "nat_size (nat_of k) = nat_of k" by (induct "nat_of k") simp_all
haftmann@29815
   102
  finally show "index_size k = nat_of k" .
haftmann@26140
   103
qed
haftmann@26140
   104
haftmann@28562
   105
lemma [code]:
haftmann@29815
   106
  "size = nat_of"
haftmann@26140
   107
proof (rule ext)
haftmann@26140
   108
  fix k
haftmann@29815
   109
  show "size k = nat_of k"
haftmann@26140
   110
  by (induct k) (simp_all del: zero_index_def Suc_index_def, simp_all)
haftmann@26140
   111
qed
haftmann@26140
   112
haftmann@28562
   113
lemma [code]:
haftmann@29815
   114
  "eq_class.eq k l \<longleftrightarrow> eq_class.eq (nat_of k) (nat_of l)"
haftmann@28346
   115
  by (cases k, cases l) (simp add: eq)
haftmann@24999
   116
haftmann@28351
   117
lemma [code nbe]:
haftmann@28351
   118
  "eq_class.eq (k::index) k \<longleftrightarrow> True"
haftmann@28351
   119
  by (rule HOL.eq_refl)
haftmann@28351
   120
haftmann@24999
   121
haftmann@25767
   122
subsection {* Indices as datatype of ints *}
haftmann@25767
   123
haftmann@25767
   124
instantiation index :: number
haftmann@25767
   125
begin
haftmann@24999
   126
haftmann@25767
   127
definition
haftmann@29815
   128
  "number_of = of_nat o nat"
haftmann@25767
   129
haftmann@25767
   130
instance ..
haftmann@25767
   131
haftmann@25767
   132
end
haftmann@24999
   133
haftmann@29815
   134
lemma nat_of_number [simp]:
haftmann@29815
   135
  "nat_of (number_of k) = number_of k"
haftmann@26264
   136
  by (simp add: number_of_index_def nat_number_of_def number_of_is_id)
haftmann@26264
   137
haftmann@24999
   138
code_datatype "number_of \<Colon> int \<Rightarrow> index"
haftmann@24999
   139
haftmann@24999
   140
haftmann@24999
   141
subsection {* Basic arithmetic *}
haftmann@24999
   142
haftmann@25767
   143
instantiation index :: "{minus, ordered_semidom, Divides.div, linorder}"
haftmann@25767
   144
begin
haftmann@24999
   145
haftmann@28562
   146
definition [simp, code del]:
haftmann@29815
   147
  "(1\<Colon>index) = of_nat 1"
haftmann@24999
   148
haftmann@28562
   149
definition [simp, code del]:
haftmann@29815
   150
  "n + m = of_nat (nat_of n + nat_of m)"
haftmann@25767
   151
haftmann@28562
   152
definition [simp, code del]:
haftmann@29815
   153
  "n - m = of_nat (nat_of n - nat_of m)"
haftmann@25767
   154
haftmann@28562
   155
definition [simp, code del]:
haftmann@29815
   156
  "n * m = of_nat (nat_of n * nat_of m)"
haftmann@25767
   157
haftmann@28562
   158
definition [simp, code del]:
haftmann@29815
   159
  "n div m = of_nat (nat_of n div nat_of m)"
haftmann@24999
   160
haftmann@28562
   161
definition [simp, code del]:
haftmann@29815
   162
  "n mod m = of_nat (nat_of n mod nat_of m)"
haftmann@24999
   163
haftmann@28562
   164
definition [simp, code del]:
haftmann@29815
   165
  "n \<le> m \<longleftrightarrow> nat_of n \<le> nat_of m"
haftmann@24999
   166
haftmann@28562
   167
definition [simp, code del]:
haftmann@29815
   168
  "n < m \<longleftrightarrow> nat_of n < nat_of m"
haftmann@24999
   169
haftmann@29815
   170
instance proof
haftmann@29815
   171
qed (auto simp add: left_distrib)
haftmann@28708
   172
haftmann@28708
   173
end
haftmann@28708
   174
haftmann@28708
   175
lemma zero_index_code [code inline, code]:
haftmann@28708
   176
  "(0\<Colon>index) = Numeral0"
haftmann@28708
   177
  by (simp add: number_of_index_def Pls_def)
haftmann@28708
   178
lemma [code post]: "Numeral0 = (0\<Colon>index)"
haftmann@28708
   179
  using zero_index_code ..
haftmann@28708
   180
haftmann@28708
   181
lemma one_index_code [code inline, code]:
haftmann@28708
   182
  "(1\<Colon>index) = Numeral1"
haftmann@28708
   183
  by (simp add: number_of_index_def Pls_def Bit1_def)
haftmann@28708
   184
lemma [code post]: "Numeral1 = (1\<Colon>index)"
haftmann@28708
   185
  using one_index_code ..
haftmann@28708
   186
haftmann@28708
   187
lemma plus_index_code [code nbe]:
haftmann@29815
   188
  "of_nat n + of_nat m = of_nat (n + m)"
haftmann@28708
   189
  by simp
haftmann@28708
   190
haftmann@28708
   191
definition subtract_index :: "index \<Rightarrow> index \<Rightarrow> index" where
haftmann@28708
   192
  [simp, code del]: "subtract_index = op -"
haftmann@28708
   193
haftmann@28708
   194
lemma subtract_index_code [code nbe]:
haftmann@29815
   195
  "subtract_index (of_nat n) (of_nat m) = of_nat (n - m)"
haftmann@28708
   196
  by simp
haftmann@28708
   197
haftmann@28708
   198
lemma minus_index_code [code]:
haftmann@28708
   199
  "n - m = subtract_index n m"
haftmann@28708
   200
  by simp
haftmann@28708
   201
haftmann@28708
   202
lemma times_index_code [code nbe]:
haftmann@29815
   203
  "of_nat n * of_nat m = of_nat (n * m)"
haftmann@28708
   204
  by simp
haftmann@28708
   205
haftmann@28708
   206
lemma less_eq_index_code [code nbe]:
haftmann@29815
   207
  "of_nat n \<le> of_nat m \<longleftrightarrow> n \<le> m"
haftmann@25767
   208
  by simp
haftmann@24999
   209
haftmann@28708
   210
lemma less_index_code [code nbe]:
haftmann@29815
   211
  "of_nat n < of_nat m \<longleftrightarrow> n < m"
haftmann@25767
   212
  by simp
haftmann@24999
   213
haftmann@26140
   214
lemma Suc_index_minus_one: "Suc_index n - 1 = n" by simp
haftmann@26140
   215
haftmann@29815
   216
lemma of_nat_code [code]:
haftmann@29815
   217
  "of_nat = Nat.of_nat"
haftmann@25918
   218
proof
haftmann@25918
   219
  fix n :: nat
haftmann@29815
   220
  have "Nat.of_nat n = of_nat n"
haftmann@25918
   221
    by (induct n) simp_all
haftmann@29815
   222
  then show "of_nat n = Nat.of_nat n"
haftmann@25918
   223
    by (rule sym)
haftmann@25918
   224
qed
haftmann@25918
   225
haftmann@29815
   226
lemma index_not_eq_zero: "i \<noteq> of_nat 0 \<longleftrightarrow> i \<ge> 1"
haftmann@25928
   227
  by (cases i) auto
haftmann@25928
   228
haftmann@29815
   229
definition nat_of_aux :: "index \<Rightarrow> nat \<Rightarrow> nat" where
haftmann@29815
   230
  "nat_of_aux i n = nat_of i + n"
haftmann@25928
   231
haftmann@29815
   232
lemma nat_of_aux_code [code]:
haftmann@29815
   233
  "nat_of_aux i n = (if i = 0 then n else nat_of_aux (i - 1) (Suc n))"
haftmann@29815
   234
  by (auto simp add: nat_of_aux_def index_not_eq_zero)
haftmann@25928
   235
haftmann@29815
   236
lemma nat_of_code [code]:
haftmann@29815
   237
  "nat_of i = nat_of_aux i 0"
haftmann@29815
   238
  by (simp add: nat_of_aux_def)
haftmann@25918
   239
haftmann@28708
   240
definition div_mod_index ::  "index \<Rightarrow> index \<Rightarrow> index \<times> index" where
haftmann@28562
   241
  [code del]: "div_mod_index n m = (n div m, n mod m)"
haftmann@26009
   242
haftmann@28562
   243
lemma [code]:
haftmann@26009
   244
  "div_mod_index n m = (if m = 0 then (0, n) else (n div m, n mod m))"
haftmann@26009
   245
  unfolding div_mod_index_def by auto
haftmann@26009
   246
haftmann@28562
   247
lemma [code]:
haftmann@26009
   248
  "n div m = fst (div_mod_index n m)"
haftmann@26009
   249
  unfolding div_mod_index_def by simp
haftmann@26009
   250
haftmann@28562
   251
lemma [code]:
haftmann@26009
   252
  "n mod m = snd (div_mod_index n m)"
haftmann@26009
   253
  unfolding div_mod_index_def by simp
haftmann@26009
   254
haftmann@29815
   255
hide (open) const of_nat nat_of
haftmann@26009
   256
haftmann@28708
   257
subsection {* ML interface *}
haftmann@28708
   258
haftmann@28708
   259
ML {*
haftmann@28708
   260
structure Index =
haftmann@28708
   261
struct
haftmann@28708
   262
haftmann@28708
   263
fun mk k = HOLogic.mk_number @{typ index} k;
haftmann@28708
   264
haftmann@28708
   265
end;
haftmann@28708
   266
*}
haftmann@28708
   267
haftmann@28708
   268
haftmann@28228
   269
subsection {* Code generator setup *}
haftmann@24999
   270
haftmann@25767
   271
text {* Implementation of indices by bounded integers *}
haftmann@25767
   272
haftmann@24999
   273
code_type index
haftmann@24999
   274
  (SML "int")
haftmann@24999
   275
  (OCaml "int")
haftmann@25967
   276
  (Haskell "Int")
haftmann@24999
   277
haftmann@24999
   278
code_instance index :: eq
haftmann@24999
   279
  (Haskell -)
haftmann@24999
   280
haftmann@24999
   281
setup {*
haftmann@25928
   282
  fold (Numeral.add_code @{const_name number_index_inst.number_of_index}
haftmann@25928
   283
    false false) ["SML", "OCaml", "Haskell"]
haftmann@24999
   284
*}
haftmann@24999
   285
haftmann@25918
   286
code_reserved SML Int int
haftmann@25918
   287
code_reserved OCaml Pervasives int
haftmann@24999
   288
haftmann@24999
   289
code_const "op + \<Colon> index \<Rightarrow> index \<Rightarrow> index"
haftmann@25928
   290
  (SML "Int.+/ ((_),/ (_))")
haftmann@25967
   291
  (OCaml "Pervasives.( + )")
haftmann@24999
   292
  (Haskell infixl 6 "+")
haftmann@24999
   293
haftmann@28708
   294
code_const "subtract_index \<Colon> index \<Rightarrow> index \<Rightarrow> index"
haftmann@25918
   295
  (SML "Int.max/ (_/ -/ _,/ 0 : int)")
haftmann@25918
   296
  (OCaml "Pervasives.max/ (_/ -/ _)/ (0 : int) ")
haftmann@25918
   297
  (Haskell "max/ (_/ -/ _)/ (0 :: Int)")
haftmann@24999
   298
haftmann@24999
   299
code_const "op * \<Colon> index \<Rightarrow> index \<Rightarrow> index"
haftmann@25928
   300
  (SML "Int.*/ ((_),/ (_))")
haftmann@25967
   301
  (OCaml "Pervasives.( * )")
haftmann@24999
   302
  (Haskell infixl 7 "*")
haftmann@24999
   303
haftmann@26009
   304
code_const div_mod_index
haftmann@26009
   305
  (SML "(fn n => fn m =>/ (n div m, n mod m))")
haftmann@26009
   306
  (OCaml "(fun n -> fun m ->/ (n '/ m, n mod m))")
haftmann@26009
   307
  (Haskell "divMod")
haftmann@25928
   308
haftmann@28346
   309
code_const "eq_class.eq \<Colon> index \<Rightarrow> index \<Rightarrow> bool"
haftmann@24999
   310
  (SML "!((_ : Int.int) = _)")
haftmann@25967
   311
  (OCaml "!((_ : int) = _)")
haftmann@24999
   312
  (Haskell infixl 4 "==")
haftmann@24999
   313
haftmann@24999
   314
code_const "op \<le> \<Colon> index \<Rightarrow> index \<Rightarrow> bool"
haftmann@25928
   315
  (SML "Int.<=/ ((_),/ (_))")
haftmann@25967
   316
  (OCaml "!((_ : int) <= _)")
haftmann@24999
   317
  (Haskell infix 4 "<=")
haftmann@24999
   318
haftmann@24999
   319
code_const "op < \<Colon> index \<Rightarrow> index \<Rightarrow> bool"
haftmann@25928
   320
  (SML "Int.</ ((_),/ (_))")
haftmann@25967
   321
  (OCaml "!((_ : int) < _)")
haftmann@24999
   322
  (Haskell infix 4 "<")
haftmann@24999
   323
haftmann@28228
   324
text {* Evaluation *}
haftmann@28228
   325
haftmann@28562
   326
lemma [code, code del]:
haftmann@28228
   327
  "(Code_Eval.term_of \<Colon> index \<Rightarrow> term) = Code_Eval.term_of" ..
haftmann@28228
   328
haftmann@28228
   329
code_const "Code_Eval.term_of \<Colon> index \<Rightarrow> term"
haftmann@28228
   330
  (SML "HOLogic.mk'_number/ HOLogic.indexT/ (IntInf.fromInt/ _)")
haftmann@28228
   331
haftmann@24999
   332
end