src/Tools/rat.ML
author wenzelm
Sat, 09 Jun 2007 00:28:46 +0200
changeset 23297 06f108974fa1
parent 23261 85f27f79232f
child 23520 483fe92f00c1
permissions -rw-r--r--
simplified type integer;
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
23251
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
     1
(*  Title:      Pure/General/rat.ML
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
     2
    ID:         $Id$
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
     3
    Author:     Tobias Nipkow, TU Muenchen
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
     4
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
     5
Canonical implementation of exact rational numbers.
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
     6
*)
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
     7
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
     8
signature RAT =
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
     9
sig
23297
06f108974fa1 simplified type integer;
wenzelm
parents: 23261
diff changeset
    10
  eqtype rat
23251
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    11
  exception DIVZERO
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    12
  val zero: rat
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    13
  val one: rat
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    14
  val two: rat
23261
85f27f79232f tuned integers
haftmann
parents: 23251
diff changeset
    15
  val rat_of_int: integer -> rat
85f27f79232f tuned integers
haftmann
parents: 23251
diff changeset
    16
  val rat_of_quotient: integer * integer -> rat
85f27f79232f tuned integers
haftmann
parents: 23251
diff changeset
    17
  val quotient_of_rat: rat -> integer * integer
23251
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    18
  val string_of_rat: rat -> string
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    19
  val eq: rat * rat -> bool
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    20
  val cmp: rat * rat -> order
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    21
  val le: rat -> rat -> bool
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    22
  val lt: rat -> rat -> bool
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    23
  val cmp_zero: rat -> order
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    24
  val add: rat -> rat -> rat
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    25
  val mult: rat -> rat -> rat
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    26
  val neg: rat -> rat
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    27
  val inv: rat -> rat
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    28
  val roundup: rat -> rat
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    29
  val rounddown: rat -> rat
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    30
end;
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    31
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    32
structure Rat : RAT =
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    33
struct
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    34
23261
85f27f79232f tuned integers
haftmann
parents: 23251
diff changeset
    35
datatype rat = Rat of bool * integer * integer;
23251
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    36
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    37
exception DIVZERO;
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    38
23297
06f108974fa1 simplified type integer;
wenzelm
parents: 23261
diff changeset
    39
val zero = Rat (true, 0, 1);
06f108974fa1 simplified type integer;
wenzelm
parents: 23261
diff changeset
    40
val one = Rat (true, 1, 1);
06f108974fa1 simplified type integer;
wenzelm
parents: 23261
diff changeset
    41
val two = Rat (true, 2, 1);
23251
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    42
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    43
fun rat_of_int i =
23261
85f27f79232f tuned integers
haftmann
parents: 23251
diff changeset
    44
  let
85f27f79232f tuned integers
haftmann
parents: 23251
diff changeset
    45
    val (a, p) = Integer.signabs i
23297
06f108974fa1 simplified type integer;
wenzelm
parents: 23261
diff changeset
    46
  in Rat (a, p, 1) end;
23251
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    47
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    48
fun norm (a, p, q) =
23297
06f108974fa1 simplified type integer;
wenzelm
parents: 23261
diff changeset
    49
  if p = 0 then Rat (true, 0, 1)
23251
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    50
  else
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    51
    let
23261
85f27f79232f tuned integers
haftmann
parents: 23251
diff changeset
    52
      val (b, absp) = Integer.signabs p;
85f27f79232f tuned integers
haftmann
parents: 23251
diff changeset
    53
      val m = Integer.gcd absp q;
23297
06f108974fa1 simplified type integer;
wenzelm
parents: 23261
diff changeset
    54
    in Rat (a = b, absp div m, q div m) end;
23251
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    55
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    56
fun common (p1, q1, p2, q2) =
23261
85f27f79232f tuned integers
haftmann
parents: 23251
diff changeset
    57
  let
85f27f79232f tuned integers
haftmann
parents: 23251
diff changeset
    58
    val q' = Integer.lcm q1 q2;
23297
06f108974fa1 simplified type integer;
wenzelm
parents: 23261
diff changeset
    59
  in (p1 * (q' div q1), p2 * (q' div q2), q') end
23251
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    60
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    61
fun rat_of_quotient (p, q) =
23261
85f27f79232f tuned integers
haftmann
parents: 23251
diff changeset
    62
  let
85f27f79232f tuned integers
haftmann
parents: 23251
diff changeset
    63
    val (a, absq) = Integer.signabs q;
85f27f79232f tuned integers
haftmann
parents: 23251
diff changeset
    64
  in
23297
06f108974fa1 simplified type integer;
wenzelm
parents: 23261
diff changeset
    65
    if absq = 0 then raise DIVZERO
23261
85f27f79232f tuned integers
haftmann
parents: 23251
diff changeset
    66
    else norm (a, p, absq)
85f27f79232f tuned integers
haftmann
parents: 23251
diff changeset
    67
  end;
23251
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    68
23297
06f108974fa1 simplified type integer;
wenzelm
parents: 23261
diff changeset
    69
fun quotient_of_rat (Rat (a, p, q)) = (if a then p else ~ p, q);
23251
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    70
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    71
fun string_of_rat r =
23261
85f27f79232f tuned integers
haftmann
parents: 23251
diff changeset
    72
  let
85f27f79232f tuned integers
haftmann
parents: 23251
diff changeset
    73
    val (p, q) = quotient_of_rat r;
85f27f79232f tuned integers
haftmann
parents: 23251
diff changeset
    74
  in Integer.string_of_int p ^ "/" ^ Integer.string_of_int q end;
23251
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    75
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    76
fun eq (Rat (false, _, _), Rat (true, _, _)) = false
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    77
  | eq (Rat (true, _, _), Rat (false, _, _)) = false
23297
06f108974fa1 simplified type integer;
wenzelm
parents: 23261
diff changeset
    78
  | eq (Rat (_, p1, q1), Rat (_, p2, q2)) = p1 = p2 andalso q1 = q2;
23251
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    79
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    80
fun cmp (Rat (false, _, _), Rat (true, _, _)) = LESS
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    81
  | cmp (Rat (true, _, _), Rat (false, _, _)) = GREATER
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    82
  | cmp (Rat (a, p1, q1), Rat (_, p2, q2)) =
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    83
      let val (r1, r2, _) = common (p1, q1, p2, q2)
23261
85f27f79232f tuned integers
haftmann
parents: 23251
diff changeset
    84
      in if a then Integer.cmp (r1, r2) else Integer.cmp (r2, r1) end;
23251
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    85
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    86
fun le a b = let val order = cmp (a, b) in order = LESS orelse order = EQUAL end;
23261
85f27f79232f tuned integers
haftmann
parents: 23251
diff changeset
    87
fun lt a b = (cmp (a, b) = LESS);
23251
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    88
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    89
fun cmp_zero (Rat (false, _, _)) = LESS
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    90
  | cmp_zero (Rat (_, 0, _)) = EQUAL
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    91
  | cmp_zero (Rat (_, _, _)) = GREATER;
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    92
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    93
fun add (Rat (a1, p1, q1)) (Rat(a2, p2, q2)) =
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    94
  let
23261
85f27f79232f tuned integers
haftmann
parents: 23251
diff changeset
    95
    val (r1, r2, den) = common (p1, q1, p2, q2);
23297
06f108974fa1 simplified type integer;
wenzelm
parents: 23261
diff changeset
    96
    val num = (if a1 then r1 else ~ r1)
06f108974fa1 simplified type integer;
wenzelm
parents: 23261
diff changeset
    97
      + (if a2 then r2 else ~ r2);
23251
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    98
  in norm (true, num, den) end;
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
    99
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
   100
fun mult (Rat (a1, p1, q1)) (Rat (a2, p2, q2)) =
23297
06f108974fa1 simplified type integer;
wenzelm
parents: 23261
diff changeset
   101
  norm (a1 = a2, p1 * p2, q1 * q2);
23251
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
   102
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
   103
fun neg (r as Rat (b, p, q)) =
23297
06f108974fa1 simplified type integer;
wenzelm
parents: 23261
diff changeset
   104
  if p = 0 then r
23251
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
   105
  else Rat (not b, p, q);
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
   106
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
   107
fun inv (Rat (a, p, q)) =
23297
06f108974fa1 simplified type integer;
wenzelm
parents: 23261
diff changeset
   108
  if q = 0 then raise DIVZERO
23251
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
   109
  else Rat (a, q, p);
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
   110
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
   111
fun roundup (r as Rat (a, p, q)) =
23297
06f108974fa1 simplified type integer;
wenzelm
parents: 23261
diff changeset
   112
  if q = 1 then r
23251
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
   113
  else
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
   114
    let
23297
06f108974fa1 simplified type integer;
wenzelm
parents: 23261
diff changeset
   115
      fun round true q = Rat (true, q + 1, 1)
23251
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
   116
        | round false q =
23297
06f108974fa1 simplified type integer;
wenzelm
parents: 23261
diff changeset
   117
            Rat (q = 0, 0, 1);
06f108974fa1 simplified type integer;
wenzelm
parents: 23261
diff changeset
   118
    in round a (p div q) end;
23251
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
   119
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
   120
fun rounddown (r as Rat (a, p, q)) =
23297
06f108974fa1 simplified type integer;
wenzelm
parents: 23261
diff changeset
   121
  if q = 1 then r
23251
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
   122
  else
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
   123
    let
23297
06f108974fa1 simplified type integer;
wenzelm
parents: 23261
diff changeset
   124
      fun round true q = Rat (true, q, 1)
06f108974fa1 simplified type integer;
wenzelm
parents: 23261
diff changeset
   125
        | round false q = Rat (false, q + 1, 1)
06f108974fa1 simplified type integer;
wenzelm
parents: 23261
diff changeset
   126
    in round a (p div q) end;
23251
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
   127
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
   128
end;
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
   129
23261
85f27f79232f tuned integers
haftmann
parents: 23251
diff changeset
   130
infix 7 */ //;
23297
06f108974fa1 simplified type integer;
wenzelm
parents: 23261
diff changeset
   131
infix 6 +/ -/;
23251
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
   132
infix 4 =/ </ <=/ >/ >=/ <>/;
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
   133
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
   134
fun a +/ b = Rat.add a b;
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
   135
fun a -/ b = a +/ Rat.neg b;
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
   136
fun a */ b = Rat.mult a b;
23297
06f108974fa1 simplified type integer;
wenzelm
parents: 23261
diff changeset
   137
fun a // b = a */ Rat.inv b;
23261
85f27f79232f tuned integers
haftmann
parents: 23251
diff changeset
   138
fun a =/ b = Rat.eq (a, b);
23251
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
   139
fun a </ b = Rat.lt a b;
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
   140
fun a <=/ b = Rat.le a b;
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
   141
fun a >/ b = b </ a;
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
   142
fun a >=/ b = b <=/ a;
471b576aad25 moved generic algebra modules
haftmann
parents:
diff changeset
   143
fun a <>/ b = not (a =/ b);