(* ----------------------------------------------- *)
(* GNU GPL opensource, C.McCormack and L.Allison,  *)
(* Monash U., Clayton, Australia, August 2006      *)
(* ----------------------------------------------- *)

datatype BigInt = Neg of (int list) | Pos of (int list);
                  (* NB all operations must guarantee NO (Neg [0]) ! *)
    (* strictly speaking, Pos includes zero, i.e. all `non-negative' *)

val internalBase = 100;  (* say *)

val zero = Pos [0];

fun invert LESS    = GREATER
  | invert EQUAL   = EQUAL
  | invert GREATER = LESS;

fun negate (Neg x)   = Pos x   (* < 0 *)
  | negate (Pos [0]) = Pos [0] (* = 0 *)
  | negate (Pos x)   = Neg x;  (* > 0 *)

fun lift f (Pos xs) = Pos (f xs)  (* a well-known FP trick *)
  | lift f (Neg xs) = Neg (f xs);

fun clean b =                    (* put b:BigInt into correct canonical form *)
   let fun chop []  = []  (* chop off any most sig. zero-digits *)
         | chop [0] = []
         | chop (0::xs) = (case chop xs of [] => [] | ys => 0::ys)
         | chop (x::xs) = x::chop xs;
       val b' = lift chop b
   in case b' of  Neg [] => zero  | Pos [] => zero | b' => b'
   end;

(* ------------------------------------------------------------------------- *)
(* Make 'compare' first, then 'plus' & 'minus', then 'times', & finally IO   *)

fun compare (Pos _) (Neg _)  = GREATER
  | compare (x as (Neg _)) y = invert(compare (negate x) (negate y))
  | compare (Pos x) (Pos y) =  (* linear-time but... *)
    let val lx = length x      (* ...could be slightly more efficient *)
        and ly = length y;
        fun f [] [] = EQUAL
         |  f (x::xs) (y::ys) =
              if      x < y then LESS
              else if x > y then GREATER
              else (* x = y *) f xs ys
    in if      lx < ly then LESS
       else if lx > ly then GREATER
       else (* lx = ly *) f (rev x) (rev y)
    end;

fun plus (Pos ms) (Pos ns) =
      let fun f c [] [] = [c]
            | f c xs [] = f 0 [c] xs
            | f c [] xs = f c xs []
            | f c (x::xs) (y::ys) =
              let val cxy = c+x+y;
                  val x'  = cxy mod internalBase
                  and c'  = cxy div internalBase;
              in x' :: (f c' xs ys)
              end
      in clean(Pos (f 0 ms ns))
      end
  | plus (m as (Neg _)) (n as (Neg _)) = negate(plus (negate m) (negate n))
  | plus (m as (Pos _)) (n as (Neg _)) = minus m (negate n)    (* m+n=m-(-n) *)
  | plus (m as (Neg _)) (n as (Pos _)) = plus n m                 (* m+n=n+m *)

and minus (m as (Pos ms)) (n as (Pos ns)) =
      (case compare m n of
        LESS    => negate(minus n m)  |   (* m-n=-(n-m) *)
        EQUAL   => zero  |
        GREATER =>
          let fun f 0 [] [] = []
                | f b (m::ms) (n::ns) =               (* b ~ borrow *)
                    let val bn = b+n
                    in if bn > m then (internalBase+m-bn)::(f 1 ms ns)
                                 else (m-bn)::(f 0 ms ns)
                    end
                | f b ms [] = f b ms [0]
          in clean(Pos (f 0 ms ns))
          end
      )
  | minus (m as (Pos _)) (n as (Neg _)) = plus m (negate n)    (* m-n=m+(-n) *)
  | minus (m as (Neg _)) (n as (Neg _)) =
      minus (negate n) (negate m)                           (* m-n = -n-(-m) *)
  | minus (m as (Neg _)) (n as (Pos _)) = negate(minus n m);   (* m-n=-(n-m) *)

fun timesDigit _ 0 = zero
  | timesDigit n 1 = n
  | timesDigit (n as (Neg _)) d = negate(timesDigit (negate n) d)
  | timesDigit (Pos n) d =                       (* NB. 1 < d < internalBase *)
      let fun t 0 [] = []
            | t c [] = [c]
            | t c (n::ns) =  (* c ~ carry, note d is a const for t *)
                let val nd = n*d + c
                in (nd mod internalBase)::(t (nd div internalBase) ns)
                end
      in Pos (t 0 n)
      end;

fun times (m as (Pos _)) (n as (Pos ns)) =
      let fun t []      = zero
            | t (d::ds) = plus (timesDigit m d) (shift (t ds))
          and shift (Pos ds) = Pos (0::ds)
      in t ns
      end
  | times (m as (Neg _)) (n as (Neg _)) = times (negate m) (negate n)
  | times (m as (Pos _)) (n as (Neg _)) = negate(times m (negate n))
  | times (m as (Neg _)) (n as (Pos _)) = times n m;

(* ------------------------------------------------------------------------- *)

exception BadBase;   (* for when the base is out of range *)
exception BadString; (* for an invalid string representation *)

fun isDecimalDigit x = x >= #"0" andalso x <= #"9";
fun isUpperDigit   x = x >= #"A" andalso x <= #"Z";
fun isLowerDigit   x = x >= #"a" andalso x <= #"z";

(* converts a char into its numeric digit value *)
fun digitVal x base =
      let
        val digit = (ord x) - (if      isDecimalDigit x then ord #"0"
                               else if isUpperDigit   x then ord #"A" - 10
                               else if isLowerDigit   x then ord #"a" - 10
                                                        else raise BadString);
      in
        (* check that the digit is in range *)
        if digit >= base then raise BadString
                         else digit
      end;

(* converts a numeric digit value into the corresponding char *)
fun digitChar x = chr (x + (if x < 10 then ord #"0" else ord #"A" - 10));

fun fromString s =
      let
        (* converts the chars representing the base into the actual number *)
        fun base' []      _ = raise BadString
          | base' [#"]"]  b = if b <= internalBase then b else raise BadBase
          | base' (x::xs) b = base' xs (b * 10 + (digitVal x 10));

        (* searches for the '[' character and passes the rest off to base',
           or if there was no '[' it returns the default base, 10 *)
        fun base []         = 10
          | base (#"["::xs) = base' xs 0
          | base (x::xs)    = base xs;

        (* converts from the base of the string to internalBase *)
        fun digits' []        i _    = i
          | digits' (#"["::_) i _    = i
          | digits' (x::xs)   i base =
              let
                (* 'i' is the accumulated value so far.  for each digit we
                   compute i * base + digit and pass this in as the new
                   'i' value in the recursive call. *)
                val j = times i (Pos [base]);
                val k = plus  j (Pos [digitVal x base]);
              in
                digits' xs k base
              end;

        fun digits L = digits' L zero (base L);

        (* parses the sign character and passes the rest off to digits *)
        fun sign (#"+"::xs) = digits xs
          | sign (#"-"::xs) = negate (digits xs)
          | sign (#"["::_)  = raise BadString
          | sign []         = raise BadString
          | sign L          = digits L;

      in
        sign (explode s)
      end;

(* divides a BigInt by a single digit number (assumes n >= 0),
   used by toString *)
fun divide m n =
      let
        (* converts a BigInt into a tuple of the sign (as a bool) and the
           digit list *)
        fun break (Pos ms) = (true,  ms)
          | break (Neg ms) = (false, ms);

        (* converts a tuple of a sign (as a bool) and a digit list into
           a BigInt *)
        fun mend (true,  ms)  = Pos ms
          | mend (false, ms)  = Neg ms;

        fun divide' []      c z = (z, c) (* base: no digits left, just return
                                                  the carry *)
          | divide' (x::xs) c z =        (* rec:  some digits left... *)
              let
                val x' = x + c * internalBase; (* add the carry to the current
                                                  digit *)
                val d  = x' div n; (* do the division *)
                val m  = x' mod n; (* compute the new carry *)
              in
                divide' xs m (d::z)
              end;

        val (sign, ms) = break m; (* extract the sign and digits *)
        val (quo, rem) = divide' (rev ms) 0 []; (* do the division, and get back
                                                   the quotient (as a list) and
                                                   remainder *)
      in
        (clean (mend (sign, quo)), rem) (* return the quotient as a BigInt,
                                           and the remainder *)
      end;

fun toString base m =
      if   base >= 2 andalso base <= 36
      then let
             (* repeatedly divides the BigInt 'm' by 'base', and builds a list
                of the remainder digits *)
             fun toString' (Pos [0]) ds = ds
               | toString' m         ds =
                   let
                     val (quo, rem) = divide m base
                   in
                     toString' quo ((digitChar rem)::ds)
                   end;

             val digits = toString' m [];

             val sstr = case m of Neg _ => "-" | _ => "";
             val dstr = if null digits then "0" else implode digits;
             val bstr = if base = 10 then "" else "[" ^ Int.toString base ^ "]";
           in
             sstr ^ dstr ^ bstr
           end
      else raise BadBase;

(* the internal representation returned looks just like the ML values,
   e.g. "Pos [1,2,3]" *)
fun show m =
    let
      fun show'' []      = "]"
        | show'' (x::xs) = "," ^ Int.toString x ^ show'' xs;

      fun show'  (x::xs) = Int.toString x ^ show'' xs;
    in
      case m of Pos ms => "Pos [" ^ show' ms
              | Neg ms => "Neg [" ^ show' ms
    end;

(* converts an int to a BigInt by repeated division, similarly to toString *)
fun fromInt 0 = zero
  | fromInt x =
      if   x < 0 then negate (fromInt (~x))
      else let
             fun fromInt' 0 ds = ds
               | fromInt' x ds = fromInt' (x div internalBase)
                                          ((x mod internalBase)::ds);
           in
             Pos (fromInt' x [])
           end;

(* converts a BigInt to an int by repeated addition and multiplication by the
   base *)
fun toInt m =
      let
        fun toInt' []      = 0
          | toInt' (x::xs) = x + internalBase * (toInt' xs);
      in
        case m of Pos ms => toInt' ms
                | Neg ms => ~(toInt' ms)
      end;
(* ------------------------------------------------------------------------- *)