src/HOL/Tools/numeral_syntax.ML
author wenzelm
Fri Jan 02 19:29:18 2009 +0100 (2009-01-02)
changeset 29316 0a7fcdd77f4b
parent 26086 3c243098b64a
child 35115 446c5063e4fd
permissions -rw-r--r--
removed dead code;
proper "_numeral" token markup;
proper printing of arguments (higher-order numerals);
wenzelm@6905
     1
(*  Title:      HOL/Tools/numeral_syntax.ML
kleing@20067
     2
    Authors:    Markus Wenzel, TU Muenchen
wenzelm@6905
     3
wenzelm@21780
     4
Concrete syntax for generic numerals -- preserves leading zeros/ones.
wenzelm@6905
     5
*)
wenzelm@6905
     6
wenzelm@6905
     7
signature NUMERAL_SYNTAX =
wenzelm@6905
     8
sig
wenzelm@18708
     9
  val setup: theory -> theory
wenzelm@6905
    10
end;
wenzelm@6905
    11
wenzelm@6905
    12
structure NumeralSyntax: NUMERAL_SYNTAX =
wenzelm@6905
    13
struct
wenzelm@6905
    14
wenzelm@21780
    15
(* parse translation *)
wenzelm@21780
    16
wenzelm@21780
    17
local
wenzelm@21780
    18
wenzelm@21780
    19
fun mk_bin num =
wenzelm@21780
    20
  let
huffman@26086
    21
    fun bit b bs = HOLogic.mk_bit b $ bs;
wenzelm@29316
    22
    fun mk 0 = Syntax.const @{const_name Int.Pls}
wenzelm@29316
    23
      | mk ~1 = Syntax.const @{const_name Int.Min}
wenzelm@24630
    24
      | mk i = let val (q, r) = Integer.div_mod i 2 in bit r (mk q) end;
wenzelm@29316
    25
  in mk (#value (Syntax.read_xnum num)) end;
wenzelm@21780
    26
wenzelm@21780
    27
in
wenzelm@21780
    28
wenzelm@21780
    29
fun numeral_tr (*"_Numeral"*) [t as Const (num, _)] =
haftmann@25919
    30
      Syntax.const @{const_name Int.number_of} $ mk_bin num
wenzelm@21780
    31
  | numeral_tr (*"_Numeral"*) ts = raise TERM ("numeral_tr", ts);
wenzelm@21780
    32
wenzelm@21780
    33
end;
wenzelm@6905
    34
wenzelm@21780
    35
wenzelm@21780
    36
(* print translation *)
wenzelm@21780
    37
wenzelm@21780
    38
local
wenzelm@21780
    39
haftmann@25919
    40
fun dest_bin (Const (@{const_syntax "Int.Pls"}, _)) = []
haftmann@25919
    41
  | dest_bin (Const (@{const_syntax "Int.Min"}, _)) = [~1]
huffman@26086
    42
  | dest_bin (Const (@{const_syntax "Int.Bit0"}, _) $ bs) = 0 :: dest_bin bs
huffman@26086
    43
  | dest_bin (Const (@{const_syntax "Int.Bit1"}, _) $ bs) = 1 :: dest_bin bs
wenzelm@21780
    44
  | dest_bin _ = raise Match;
wenzelm@21780
    45
wenzelm@21780
    46
fun leading _ [] = 0
wenzelm@21780
    47
  | leading (i: int) (j :: js) = if i = j then 1 + leading i js else 0;
wenzelm@21780
    48
wenzelm@21780
    49
fun int_of [] = 0
wenzelm@24630
    50
  | int_of (b :: bs) = b + 2 * int_of bs;
wenzelm@6905
    51
wenzelm@6905
    52
fun dest_bin_str tm =
wenzelm@6905
    53
  let
wenzelm@21780
    54
    val rev_digs = dest_bin tm;
wenzelm@21780
    55
    val (sign, z) =
wenzelm@6905
    56
      (case rev rev_digs of
wenzelm@21780
    57
        ~1 :: bs => ("-", leading 1 bs)
wenzelm@21780
    58
      | bs => ("", leading 0 bs));
wenzelm@21780
    59
    val i = int_of rev_digs;
wenzelm@24630
    60
    val num = string_of_int (abs i);
wenzelm@11701
    61
  in
wenzelm@21780
    62
    if (i = 0 orelse i = 1) andalso z = 0 then raise Match
wenzelm@21780
    63
    else sign ^ implode (replicate z "0") ^ num
wenzelm@11701
    64
  end;
wenzelm@6905
    65
wenzelm@29316
    66
fun syntax_numeral t =
wenzelm@29316
    67
  Syntax.const "_Numeral" $ (Syntax.const "_numeral" $ Syntax.free (dest_bin_str t));
wenzelm@29316
    68
wenzelm@21780
    69
in
wenzelm@6905
    70
wenzelm@6905
    71
fun numeral_tr' show_sorts (*"number_of"*) (Type ("fun", [_, T])) (t :: ts) =
wenzelm@29316
    72
      let val t' =
wenzelm@29316
    73
        if not (! show_types) andalso can Term.dest_Type T then syntax_numeral t
wenzelm@29316
    74
        else Syntax.const Syntax.constrainC $ syntax_numeral t $ Syntax.term_of_typ show_sorts T
wenzelm@29316
    75
      in list_comb (t', ts) end
wenzelm@13110
    76
  | numeral_tr' _ (*"number_of"*) T (t :: ts) =
wenzelm@29316
    77
      if T = dummyT then list_comb (syntax_numeral t, ts)
wenzelm@13110
    78
      else raise Match
wenzelm@6905
    79
  | numeral_tr' _ (*"number_of"*) _ _ = raise Match;
wenzelm@6905
    80
wenzelm@21780
    81
end;
wenzelm@21780
    82
wenzelm@6905
    83
wenzelm@6905
    84
(* theory setup *)
wenzelm@6905
    85
wenzelm@6905
    86
val setup =
wenzelm@24712
    87
  Sign.add_trfuns ([], [("_Numeral", numeral_tr)], [], []) #>
haftmann@25919
    88
  Sign.add_trfunsT [(@{const_syntax Int.number_of}, numeral_tr')];
wenzelm@6905
    89
wenzelm@6905
    90
end;