src/HOL/Code_Numeral.thy
author webertj
Fri Oct 19 15:12:52 2012 +0200 (2012-10-19)
changeset 49962 a8cc904a6820
parent 49834 b27bbb021df1
child 51143 0a2371e7ced3
permissions -rw-r--r--
Renamed {left,right}_distrib to distrib_{right,left}.
haftmann@29815
     1
(* Author: Florian Haftmann, TU Muenchen *)
haftmann@24999
     2
haftmann@31205
     3
header {* Type of target language numerals *}
haftmann@24999
     4
haftmann@31205
     5
theory Code_Numeral
huffman@47255
     6
imports Nat_Transfer Divides
haftmann@24999
     7
begin
haftmann@24999
     8
haftmann@24999
     9
text {*
haftmann@31205
    10
  Code numerals are isomorphic to HOL @{typ nat} but
haftmann@31205
    11
  mapped to target-language builtin numerals.
haftmann@24999
    12
*}
haftmann@24999
    13
haftmann@31205
    14
subsection {* Datatype of target language numerals *}
haftmann@24999
    15
wenzelm@49834
    16
typedef code_numeral = "UNIV \<Colon> nat set"
wenzelm@45694
    17
  morphisms nat_of of_nat ..
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@31205
    30
lemma code_numeral:
haftmann@31205
    31
  "(\<And>n\<Colon>code_numeral. PROP P n) \<equiv> (\<And>n\<Colon>nat. PROP P (of_nat n))"
haftmann@24999
    32
proof
haftmann@25767
    33
  fix n :: nat
haftmann@31205
    34
  assume "\<And>n\<Colon>code_numeral. PROP P n"
haftmann@29815
    35
  then show "PROP P (of_nat n)" .
haftmann@24999
    36
next
haftmann@31205
    37
  fix n :: code_numeral
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@31205
    43
lemma code_numeral_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
haftmann@31205
    48
lemma code_numeral_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@31205
    64
instantiation code_numeral :: 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
huffman@46547
    74
definition Suc where [simp]:
huffman@46547
    75
  "Suc k = of_nat (Nat.Suc (nat_of k))"
haftmann@26140
    76
huffman@46547
    77
rep_datatype "0 \<Colon> code_numeral" Suc
haftmann@26140
    78
proof -
haftmann@31205
    79
  fix P :: "code_numeral \<Rightarrow> bool"
haftmann@31205
    80
  fix k :: code_numeral
haftmann@29815
    81
  assume "P 0" then have init: "P (of_nat 0)" by simp
huffman@46547
    82
  assume "\<And>k. P k \<Longrightarrow> P (Suc k)"
huffman@46547
    83
    then have "\<And>n. P (of_nat n) \<Longrightarrow> P (Suc (of_nat n))" .
huffman@46547
    84
    then have step: "\<And>n. P (of_nat n) \<Longrightarrow> P (of_nat (Nat.Suc n))" by simp
haftmann@29815
    85
  from init step have "P (of_nat (nat_of k))"
berghofe@34915
    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@31205
    90
declare code_numeral_case [case_names nat, cases type: code_numeral]
haftmann@31205
    91
declare code_numeral.induct [case_names nat, induct type: code_numeral]
haftmann@26140
    92
haftmann@31205
    93
lemma code_numeral_decr [termination_simp]:
huffman@46547
    94
  "k \<noteq> of_nat 0 \<Longrightarrow> nat_of k - Nat.Suc 0 < nat_of k"
haftmann@30245
    95
  by (cases k) simp
haftmann@30245
    96
haftmann@30245
    97
lemma [simp, code]:
haftmann@31205
    98
  "code_numeral_size = nat_of"
haftmann@26140
    99
proof (rule ext)
haftmann@26140
   100
  fix k
haftmann@31205
   101
  have "code_numeral_size k = nat_size (nat_of k)"
huffman@46547
   102
    by (induct k rule: code_numeral.induct) (simp_all del: zero_code_numeral_def Suc_def, simp_all)
berghofe@34915
   103
  also have "nat_size (nat_of k) = nat_of k" by (induct ("nat_of k")) simp_all
haftmann@31205
   104
  finally show "code_numeral_size k = nat_of k" .
haftmann@26140
   105
qed
haftmann@26140
   106
haftmann@30245
   107
lemma [simp, code]:
haftmann@29815
   108
  "size = nat_of"
haftmann@26140
   109
proof (rule ext)
haftmann@26140
   110
  fix k
haftmann@29815
   111
  show "size k = nat_of k"
huffman@46547
   112
  by (induct k) (simp_all del: zero_code_numeral_def Suc_def, simp_all)
haftmann@26140
   113
qed
haftmann@26140
   114
haftmann@31205
   115
lemmas [code del] = code_numeral.recs code_numeral.cases
haftmann@30245
   116
haftmann@28562
   117
lemma [code]:
haftmann@38857
   118
  "HOL.equal k l \<longleftrightarrow> HOL.equal (nat_of k) (nat_of l)"
haftmann@38857
   119
  by (cases k, cases l) (simp add: equal)
haftmann@24999
   120
haftmann@28351
   121
lemma [code nbe]:
haftmann@38857
   122
  "HOL.equal (k::code_numeral) k \<longleftrightarrow> True"
haftmann@38857
   123
  by (rule equal_refl)
haftmann@28351
   124
haftmann@24999
   125
haftmann@24999
   126
subsection {* Basic arithmetic *}
haftmann@24999
   127
haftmann@35028
   128
instantiation code_numeral :: "{minus, linordered_semidom, semiring_div, linorder}"
haftmann@25767
   129
begin
haftmann@24999
   130
haftmann@28562
   131
definition [simp, code del]:
haftmann@31205
   132
  "(1\<Colon>code_numeral) = of_nat 1"
haftmann@24999
   133
haftmann@28562
   134
definition [simp, code del]:
haftmann@29815
   135
  "n + m = of_nat (nat_of n + nat_of m)"
haftmann@25767
   136
haftmann@28562
   137
definition [simp, code del]:
haftmann@29815
   138
  "n - m = of_nat (nat_of n - nat_of m)"
haftmann@25767
   139
haftmann@28562
   140
definition [simp, code del]:
haftmann@29815
   141
  "n * m = of_nat (nat_of n * nat_of m)"
haftmann@25767
   142
haftmann@28562
   143
definition [simp, code del]:
haftmann@29815
   144
  "n div m = of_nat (nat_of n div nat_of m)"
haftmann@24999
   145
haftmann@28562
   146
definition [simp, code del]:
haftmann@29815
   147
  "n mod m = of_nat (nat_of n mod nat_of m)"
haftmann@24999
   148
haftmann@28562
   149
definition [simp, code del]:
haftmann@29815
   150
  "n \<le> m \<longleftrightarrow> nat_of n \<le> nat_of m"
haftmann@24999
   151
haftmann@28562
   152
definition [simp, code del]:
haftmann@29815
   153
  "n < m \<longleftrightarrow> nat_of n < nat_of m"
haftmann@24999
   154
haftmann@29815
   155
instance proof
webertj@49962
   156
qed (auto simp add: code_numeral distrib_right intro: mult_commute)
haftmann@28708
   157
haftmann@28708
   158
end
haftmann@28708
   159
huffman@47108
   160
lemma nat_of_numeral [simp]: "nat_of (numeral k) = numeral k"
huffman@47108
   161
  by (induct k rule: num_induct) (simp_all add: numeral_inc)
haftmann@46028
   162
huffman@47108
   163
definition Num :: "num \<Rightarrow> code_numeral"
huffman@47108
   164
  where [simp, code_abbrev]: "Num = numeral"
huffman@47108
   165
huffman@47108
   166
code_datatype "0::code_numeral" Num
haftmann@28708
   167
haftmann@46028
   168
lemma one_code_numeral_code [code]:
haftmann@31205
   169
  "(1\<Colon>code_numeral) = Numeral1"
huffman@47108
   170
  by simp
haftmann@46028
   171
haftmann@46028
   172
lemma [code_abbrev]: "Numeral1 = (1\<Colon>code_numeral)"
haftmann@31205
   173
  using one_code_numeral_code ..
haftmann@28708
   174
haftmann@31205
   175
lemma plus_code_numeral_code [code nbe]:
haftmann@29815
   176
  "of_nat n + of_nat m = of_nat (n + m)"
haftmann@28708
   177
  by simp
haftmann@28708
   178
huffman@47108
   179
lemma minus_code_numeral_code [code nbe]:
huffman@47108
   180
  "of_nat n - of_nat m = of_nat (n - m)"
haftmann@28708
   181
  by simp
haftmann@28708
   182
haftmann@31205
   183
lemma times_code_numeral_code [code nbe]:
haftmann@29815
   184
  "of_nat n * of_nat m = of_nat (n * m)"
haftmann@28708
   185
  by simp
haftmann@28708
   186
haftmann@31205
   187
lemma less_eq_code_numeral_code [code nbe]:
haftmann@29815
   188
  "of_nat n \<le> of_nat m \<longleftrightarrow> n \<le> m"
haftmann@25767
   189
  by simp
haftmann@24999
   190
haftmann@31205
   191
lemma less_code_numeral_code [code nbe]:
haftmann@29815
   192
  "of_nat n < of_nat m \<longleftrightarrow> n < m"
haftmann@25767
   193
  by simp
haftmann@24999
   194
haftmann@31266
   195
lemma code_numeral_zero_minus_one:
haftmann@31266
   196
  "(0::code_numeral) - 1 = 0"
haftmann@31266
   197
  by simp
haftmann@31266
   198
haftmann@31266
   199
lemma Suc_code_numeral_minus_one:
huffman@46547
   200
  "Suc n - 1 = n"
haftmann@31266
   201
  by simp
haftmann@26140
   202
haftmann@29815
   203
lemma of_nat_code [code]:
haftmann@29815
   204
  "of_nat = Nat.of_nat"
haftmann@25918
   205
proof
haftmann@25918
   206
  fix n :: nat
haftmann@29815
   207
  have "Nat.of_nat n = of_nat n"
haftmann@25918
   208
    by (induct n) simp_all
haftmann@29815
   209
  then show "of_nat n = Nat.of_nat n"
haftmann@25918
   210
    by (rule sym)
haftmann@25918
   211
qed
haftmann@25918
   212
haftmann@31205
   213
lemma code_numeral_not_eq_zero: "i \<noteq> of_nat 0 \<longleftrightarrow> i \<ge> 1"
haftmann@25928
   214
  by (cases i) auto
haftmann@25928
   215
haftmann@31205
   216
definition nat_of_aux :: "code_numeral \<Rightarrow> nat \<Rightarrow> nat" where
haftmann@29815
   217
  "nat_of_aux i n = nat_of i + n"
haftmann@25928
   218
haftmann@29815
   219
lemma nat_of_aux_code [code]:
huffman@46547
   220
  "nat_of_aux i n = (if i = 0 then n else nat_of_aux (i - 1) (Nat.Suc n))"
haftmann@31205
   221
  by (auto simp add: nat_of_aux_def code_numeral_not_eq_zero)
haftmann@25928
   222
haftmann@29815
   223
lemma nat_of_code [code]:
haftmann@29815
   224
  "nat_of i = nat_of_aux i 0"
haftmann@29815
   225
  by (simp add: nat_of_aux_def)
haftmann@25918
   226
huffman@46547
   227
definition div_mod :: "code_numeral \<Rightarrow> code_numeral \<Rightarrow> code_numeral \<times> code_numeral" where
huffman@46547
   228
  [code del]: "div_mod n m = (n div m, n mod m)"
haftmann@26009
   229
haftmann@28562
   230
lemma [code]:
huffman@46547
   231
  "div_mod n m = (if m = 0 then (0, n) else (n div m, n mod m))"
huffman@46547
   232
  unfolding div_mod_def by auto
haftmann@26009
   233
haftmann@28562
   234
lemma [code]:
huffman@46547
   235
  "n div m = fst (div_mod n m)"
huffman@46547
   236
  unfolding div_mod_def by simp
haftmann@26009
   237
haftmann@28562
   238
lemma [code]:
huffman@46547
   239
  "n mod m = snd (div_mod n m)"
huffman@46547
   240
  unfolding div_mod_def by simp
haftmann@26009
   241
haftmann@31205
   242
definition int_of :: "code_numeral \<Rightarrow> int" where
haftmann@31192
   243
  "int_of = Nat.of_nat o nat_of"
haftmann@28708
   244
haftmann@31192
   245
lemma int_of_code [code]:
haftmann@31192
   246
  "int_of k = (if k = 0 then 0
haftmann@31192
   247
    else (if k mod 2 = 0 then 2 * int_of (k div 2) else 2 * int_of (k div 2) + 1))"
haftmann@33340
   248
proof -
haftmann@33340
   249
  have "(nat_of k div 2) * 2 + nat_of k mod 2 = nat_of k" 
haftmann@33340
   250
    by (rule mod_div_equality)
haftmann@33340
   251
  then have "int ((nat_of k div 2) * 2 + nat_of k mod 2) = int (nat_of k)" 
haftmann@33340
   252
    by simp
haftmann@33340
   253
  then have "int (nat_of k) = int (nat_of k div 2) * 2 + int (nat_of k mod 2)" 
huffman@44821
   254
    unfolding of_nat_mult of_nat_add by simp
haftmann@33340
   255
  then show ?thesis by (auto simp add: int_of_def mult_ac)
haftmann@33340
   256
qed
haftmann@28708
   257
haftmann@28708
   258
huffman@47108
   259
hide_const (open) of_nat nat_of Suc int_of
huffman@46547
   260
haftmann@28708
   261
haftmann@28228
   262
subsection {* Code generator setup *}
haftmann@24999
   263
haftmann@37958
   264
text {* Implementation of code numerals by bounded integers *}
haftmann@25767
   265
haftmann@31205
   266
code_type code_numeral
haftmann@24999
   267
  (SML "int")
haftmann@31377
   268
  (OCaml "Big'_int.big'_int")
haftmann@37947
   269
  (Haskell "Integer")
haftmann@37958
   270
  (Scala "BigInt")
haftmann@24999
   271
haftmann@38857
   272
code_instance code_numeral :: equal
haftmann@24999
   273
  (Haskell -)
haftmann@24999
   274
haftmann@24999
   275
setup {*
huffman@47108
   276
  Numeral.add_code @{const_name Num}
haftmann@37958
   277
    false Code_Printer.literal_naive_numeral "SML"
huffman@47108
   278
  #> fold (Numeral.add_code @{const_name Num}
haftmann@37958
   279
    false Code_Printer.literal_numeral) ["OCaml", "Haskell", "Scala"]
haftmann@24999
   280
*}
haftmann@24999
   281
haftmann@25918
   282
code_reserved SML Int int
haftmann@37958
   283
code_reserved Eval Integer
haftmann@24999
   284
huffman@47108
   285
code_const "0::code_numeral"
huffman@47108
   286
  (SML "0")
huffman@47108
   287
  (OCaml "Big'_int.zero'_big'_int")
huffman@47108
   288
  (Haskell "0")
huffman@47108
   289
  (Scala "BigInt(0)")
huffman@47108
   290
huffman@46547
   291
code_const "plus \<Colon> code_numeral \<Rightarrow> code_numeral \<Rightarrow> code_numeral"
haftmann@25928
   292
  (SML "Int.+/ ((_),/ (_))")
haftmann@31377
   293
  (OCaml "Big'_int.add'_big'_int")
haftmann@24999
   294
  (Haskell infixl 6 "+")
haftmann@34886
   295
  (Scala infixl 7 "+")
haftmann@37958
   296
  (Eval infixl 8 "+")
haftmann@24999
   297
huffman@47108
   298
code_const "minus \<Colon> code_numeral \<Rightarrow> code_numeral \<Rightarrow> code_numeral"
huffman@47108
   299
  (SML "Int.max/ (0 : int,/ Int.-/ ((_),/ (_)))")
huffman@47108
   300
  (OCaml "Big'_int.max'_big'_int/ Big'_int.zero'_big'_int/ (Big'_int.sub'_big'_int/ _/ _)")
haftmann@48431
   301
  (Haskell "Prelude.max/ (0 :: Integer)/ (_/ -/ _)")
haftmann@34886
   302
  (Scala "!(_/ -/ _).max(0)")
huffman@47108
   303
  (Eval "Integer.max/ 0/ (_/ -/ _)")
haftmann@24999
   304
huffman@46547
   305
code_const "times \<Colon> code_numeral \<Rightarrow> code_numeral \<Rightarrow> code_numeral"
haftmann@25928
   306
  (SML "Int.*/ ((_),/ (_))")
haftmann@31377
   307
  (OCaml "Big'_int.mult'_big'_int")
haftmann@24999
   308
  (Haskell infixl 7 "*")
haftmann@34886
   309
  (Scala infixl 8 "*")
haftmann@37958
   310
  (Eval infixl 8 "*")
haftmann@24999
   311
huffman@46547
   312
code_const Code_Numeral.div_mod
haftmann@37958
   313
  (SML "!(fn n => fn m =>/ if m = 0/ then (0, n) else/ (Int.div (n, m), Int.mod (n, m)))")
haftmann@34898
   314
  (OCaml "Big'_int.quomod'_big'_int/ (Big'_int.abs'_big'_int _)/ (Big'_int.abs'_big'_int _)")
haftmann@26009
   315
  (Haskell "divMod")
haftmann@37958
   316
  (Scala "!((k: BigInt) => (l: BigInt) =>/ if (l == 0)/ (BigInt(0), k) else/ (k.abs '/% l.abs))")
haftmann@39818
   317
  (Eval "!(fn n => fn m =>/ if m = 0/ then (0, n) else/ (Integer.div'_mod n m))")
haftmann@25928
   318
haftmann@38857
   319
code_const "HOL.equal \<Colon> code_numeral \<Rightarrow> code_numeral \<Rightarrow> bool"
haftmann@24999
   320
  (SML "!((_ : Int.int) = _)")
haftmann@31377
   321
  (OCaml "Big'_int.eq'_big'_int")
haftmann@39272
   322
  (Haskell infix 4 "==")
haftmann@34886
   323
  (Scala infixl 5 "==")
haftmann@37958
   324
  (Eval "!((_ : int) = _)")
haftmann@24999
   325
huffman@46547
   326
code_const "less_eq \<Colon> code_numeral \<Rightarrow> code_numeral \<Rightarrow> bool"
haftmann@25928
   327
  (SML "Int.<=/ ((_),/ (_))")
haftmann@31377
   328
  (OCaml "Big'_int.le'_big'_int")
haftmann@24999
   329
  (Haskell infix 4 "<=")
haftmann@34898
   330
  (Scala infixl 4 "<=")
haftmann@37958
   331
  (Eval infixl 6 "<=")
haftmann@24999
   332
huffman@46547
   333
code_const "less \<Colon> code_numeral \<Rightarrow> code_numeral \<Rightarrow> bool"
haftmann@25928
   334
  (SML "Int.</ ((_),/ (_))")
haftmann@31377
   335
  (OCaml "Big'_int.lt'_big'_int")
haftmann@24999
   336
  (Haskell infix 4 "<")
haftmann@34898
   337
  (Scala infixl 4 "<")
haftmann@37958
   338
  (Eval infixl 6 "<")
haftmann@24999
   339
huffman@46547
   340
code_modulename SML
huffman@46547
   341
  Code_Numeral Arith
huffman@46547
   342
huffman@46547
   343
code_modulename OCaml
huffman@46547
   344
  Code_Numeral Arith
huffman@46547
   345
huffman@46547
   346
code_modulename Haskell
huffman@46547
   347
  Code_Numeral Arith
huffman@46547
   348
haftmann@24999
   349
end
haftmann@46664
   350