Big Numbers: Input And Output

June 14, 2011

; big numbers

(define (take n xs)
  (let loop ((n n) (xs xs) (ys '()))
    (if (or (zero? n) (null? xs))
        (reverse ys)
        (loop (- n 1) (cdr xs)
              (cons (car xs) ys)))))

(define (drop n xs)
  (let loop ((n n) (xs xs))
    (if (or (zero? n) (null? xs)) xs
      (loop (- n 1) (cdr xs)))))

(define verbose? #t)

(define big-base 10)

(define (integer->big int)
  (if (zero? int) (list 0)
    (if (negative? int)
        (let ((x (integer->big (- int))))
          (cons (- (car x)) (cdr x)))
        (let loop ((int int) (big '()))
          (if (< int big-base)
              (cons (+ (length big) 1)
                    (reverse (cons int big)))
              (loop (quotient int big-base)
                    (cons (modulo int big-base) big)))))))

(define (big->integer big)
  (if (zero? (car big)) 0
    (if (negative? (car big))
        (- (big->integer (cons (- (car big)) (cdr big))))
        (let loop ((bs (reverse (cdr big))) (n 0))
          (if (null? bs) n
            (loop (cdr bs) (+ (car bs) (* n big-base))))))))

(define (big-abs big)
  (if (positive? (car big)) big (cons (- (car big)) (cdr big))))
(define (big-negate big) (cons (* (car big) -1) (cdr big)))

(define (big-positive? big) (positive? (car big)))
(define (big-negative? big) (negative? (car big)))
(define (big-zero? big) (zero? (car big)))

(define (big-even? big)
  (or (big-zero? big) (even? (cadr big))))
(define (big-odd? big)
  (not (or (big-zero? big) (even? (cadr big)))))

(define (big-compare big1 big2)
  ; big1 < big2 => -1 ; big1 = big2 => 0 ; big1 > big2 => 1
  (cond ((< (car big1) (car big2)) -1)
        ((< (car big2) (car big1)) 1)
        (else (let loop ((b1 (reverse (cdr big1)))
                         (b2 (reverse (cdr big2))))
                (cond ((null? b1) 0)
                      ((< (car b1) (car b2)) -1)
                      ((< (car b2) (car b1)) 1)
                      (else (loop (cdr b1) (cdr b2))))))))

(define (big-eq? big1 big2)
  (zero? (big-compare big1 big2)))
(define (big-ne? big1 big2)
  (not (zero? (big-compare big1 big2))))
(define (big-lt? big1 big2)
  (negative? (big-compare big1 big2)))
(define (big-gt? big1 big2)
  (positive? (big-compare big1 big2)))
(define (big-le? big1 big2)
  (not (positive? (big-compare big1 big2))))
(define (big-ge? big1 big2)
  (not (negative? (big-compare big1 big2))))

(define (big-plus big1 big2)
  (define (reduce xs)
    (if (null? (cdr xs)) xs
      (if (positive? (car xs)) xs
        (reduce (cdr xs)))))
  (define (add b1 b2)
    (let loop ((b1 b1) (b2 b2) (c 0) (bs '()))
      (cond ((null? b1)
              (if (zero? c) (reverse bs) (reverse (cons 1 bs))))
            ((null? b2)
              (let* ((sum (+ (car b1) c))
                     (new-c (if (<= big-base sum) 1 0)))
                (loop (cdr b1) b2 new-c
                      (cons (modulo sum big-base) bs))))
            (else (let* ((sum (+ (car b1) (car b2) c))
                         (new-c (if (<= big-base sum) 1 0)))
                    (loop (cdr b1) (cdr b2) new-c
                          (cons (modulo sum big-base) bs)))))))
  (define (sub b1 b2)
    (let loop ((b1 b1) (b2 b2) (c 0) (bs '()))
      (cond ((null? b1) (reverse (reduce bs)))
            ((null? b2)
              (let* ((diff (- (car b1) c))
                     (new-c (if (< diff 0) 1 0)))
                (loop (cdr b1) b2 new-c
                      (cons (modulo diff big-base) bs))))
            (else (let* ((diff (- (car b1) (car b2) c))
                         (new-c (if (< diff 0) 1 0)))
                    (loop (cdr b1) (cdr b2) new-c
                          (cons (modulo diff big-base) bs)))))))
  (if (zero? (car big1)) big2
    (if (zero? (car big2)) big1
      (let* ((b1 (cdr big1)) (b2 (cdr big2))
             (lt? (big-lt? (big-abs big1) (big-abs big2)))
             (s1 (if (positive? (car big1)) 1 -1))
             (s2 (if (positive? (car big2)) 1 -1))
             (x (apply (if (= s1 s2) add sub)
                       (if lt? (list b2 b1) (list b1 b2))))
             (len (length x)))
        (if (equal? x (list 0)) x
          (cons (* len (if (or (and lt? (= s2 1))
                           (and (not lt?) (= s1 1)))
                         1 -1))
                x))))))

(define (big-minus big1 big2)
  (big-plus big1 (big-negate big2)))

(define (big-times big1 big2)
  (define (add b1 b2)
    (let loop ((b1 b1) (b2 b2) (c 0) (bs '()))
      (cond ((null? b1)
              (if (zero? c) (reverse bs) (reverse (cons 1 bs))))
            ((null? b2)
              (let* ((sum (+ (car b1) c))
                     (new-c (if (<= big-base sum) 1 0)))
                (loop (cdr b1) b2 new-c
                      (cons (modulo sum big-base) bs))))
            (else (let* ((sum (+ (car b1) (car b2) c))
                         (new-c (if (<= big-base sum) 1 0)))
                    (loop (cdr b1) (cdr b2) new-c
                          (cons (modulo sum big-base) bs)))))))
  (define (sign x) (if (negative? x) -1 (if (positive? x) 1 0)))
  (define (times big1 big2)
    (let loop ((b1 big1) (b2 big2) (zs '())
               (c 0) (ps '()) (bs '()))
      (cond ((null? b1) bs)
            ((null? b2) (let ((zs (cons 0 zs)))
              (loop (cdr b1) big2 zs 0 zs
                (add (reverse (if (zero? c) ps (cons c ps))) bs))))
            (else (let* ((x (+ (* (car b1) (car b2)) c))
                         (c (quotient x big-base))
                         (p (modulo x big-base)))
                    (loop b1 (cdr b2) zs c (cons p ps) bs))))))
  (if (or (big-zero? big1) (big-zero? big2)) (list 0)
    (let* ((b1 (cdr big1)) (b2 (cdr big2))
           (x (times b1 b2)) (len (length x)))
      (cons (* len (sign (* (car big1) (car big2)))) x))))

(define (big-divide ns ds) ; (values quotient remainder)
  (define (sign x) (if (negative? x) -1 (if (positive? x) 1 0)))
  (define (lt? xs ys)
    (let ((xlen (length xs)) (ylen (length ys)))
      (if (< xlen ylen) #t (if (< ylen xlen) #f
        (let loop ((xs (reverse xs)) (ys (reverse ys)))
          (cond ((null? xs) #f) ; equal
                ((< (car xs) (car ys)) #t)
                ((< (car ys) (car xs)) #f)
                (else (loop (cdr xs) (cdr ys)))))))))
  (define (reduce xs)
    (if (null? (cdr xs)) xs
      (if (positive? (car xs)) xs
        (reduce (cdr xs)))))
  (define (add b1 b2)
    (let loop ((b1 b1) (b2 b2) (c 0) (bs '()))
      (cond ((null? b1)
              (if (zero? c) (reverse bs) (reverse (cons 1 bs))))
            ((null? b2)
              (let* ((sum (+ (car b1) c))
                     (new-c (if (<= big-base sum) 1 0)))
                (loop (cdr b1) b2 new-c
                      (cons (modulo sum big-base) bs))))
            (else (let* ((sum (+ (car b1) (car b2) c))
                         (new-c (if (<= big-base sum) 1 0)))
                    (loop (cdr b1) (cdr b2) new-c
                          (cons (modulo sum big-base) bs)))))))
  (define (sub b1 b2)
    (let loop ((b1 b1) (b2 b2) (c 0) (bs '()))
      (cond ((null? b1) (reverse (reduce bs)))
            ((null? b2)
              (let* ((diff (- (car b1) c))
                     (new-c (if (< diff 0) 1 0)))
                (loop (cdr b1) b2 new-c
                      (cons (modulo diff big-base) bs))))
            (else (let* ((diff (- (car b1) (car b2) c))
                         (new-c (if (< diff 0) 1 0)))
                    (loop (cdr b1) (cdr b2) new-c
                          (cons (modulo diff big-base) bs)))))))
  (define (times big1 big2)
    (let loop ((b1 big1) (b2 big2) (zs '())
               (c 0) (ps '()) (bs '()))
      (cond ((null? b1) bs)
            ((null? b2) (let ((zs (cons 0 zs)))
              (loop (cdr b1) big2 zs 0 zs
                (add (reverse (if (zero? c) ps (cons c ps))) bs))))
            (else (let* ((x (+ (* (car b1) (car b2)) c))
                         (c (quotient x big-base))
                         (p (modulo x big-base)))
                    (loop b1 (cdr b2) zs c (cons p ps) bs))))))
  (define (mul1 ns d)
    (let loop ((ns ns) (c 0) (ps '()))
      (if (null? ns) (reverse (if (zero? c) ps (cons c ps)))
        (let* ((x (+ (* (car ns) d) c))
               (c (quotient x big-base))
               (p (modulo x big-base)))
          (loop (cdr ns) c (cons p ps))))))
  (define (div1 ns d)
    (let loop ((rev-ns (reverse ns)) (qs '()) (r 0))
      (if (null? rev-ns) (values (reverse (reduce (reverse qs))) (list r))
        (let* ((x (+ (* r big-base) (car rev-ns)))
               (q (quotient x d)) (r (modulo x d)))
          (loop (cdr rev-ns) (cons q qs) r)))))
  (define (nextq x d0 d1 ns)
    (let loop ((q (quotient x d0)))
      (if (< (* q d1) (+ (* (- x (* q d0)) big-base) (caddr ns))) q
        (loop (- q 1)))))
  (define (nextn j n rev-ns ds*q)
    (when verbose?
      (display " nextn: n = ") (display n)
      (display ", rev-ns = ") (display rev-ns)
      (display ", ds*q = ") (display ds*q) (newline))
    (let ((zs (append (reverse (sub (reverse (take (+ n 1) rev-ns)) ds*q))
                      (drop (+ n 1) rev-ns))))
      (if (< (length zs) (+ n j)) (cons 0 zs) zs)))
  (define (div ns ds)
    (if (lt? ns ds) (values '(0) ns)
      (let* ((n (length ds)) (m (- (length ns) n)))
        (if (= n 1) (div1 ns (car ds))
          (let* ((d (quotient big-base (+ (car (reverse ds)) 1)))
                 (rev-ns (reverse (mul1 ns d)))
                 (rev-ns (if (= (length ns) (length rev-ns))
                           (cons 0 rev-ns) rev-ns))
                 (ds (mul1 ds d))
                 (d0 (car (reverse ds)))
                 (d1 (cadr (reverse ds))))
            (when verbose?
              (display "init: m = ") (display m)
              (display ", n = ") (display n)
              (display ", d = ") (display d)
              (display ", rev-ns = ") (display rev-ns)
              (display ", ds = ") (display ds)
              (display ", d0 = ") (display d0)
              (display ", d1 = ") (display d1) (newline))
            (let loop ((j m) (rev-ns rev-ns) (qs '()))
              (when verbose?
                (display "loop: ") (display j) (display " ")
                (display rev-ns) (display " ") (display qs)
                (when (negative? j) (newline)))
              (if (negative? j)
                  (call-with-values
                    (lambda () (div1 (reverse rev-ns) d))
                    (lambda (q r) (values (reverse (reduce (reverse qs))) q)))
                  (let* ((x (+ (* (car rev-ns) big-base) (cadr rev-ns)))
                         (q (nextq x d0 d1 rev-ns))
                         (ds*q (mul1 ds q)))
                    (when verbose?
                      (display " | x = ") (display x) (display ", q = ")
                      (display q) (newline))
                    (if (lt? (reverse (take (+ n 1) rev-ns)) ds*q)
                        (let* ((q (- q 1)) (ds*q (sub ds*q ds)))
                          (display "D6!") (newline)
                          (loop (- j 1) (nextn j n rev-ns ds*q) (cons q qs)))
                        (loop (- j 1) (nextn j n rev-ns ds*q) (cons q qs)))))))))))
  (if (big-zero? ds) (error 'big-divide "divide by zero")
    (let ((sn (sign (car ns))) (sd (sign (car ds))))
      (call-with-values
        (lambda () (div (cdr (big-abs ns)) (cdr (big-abs ds))))
        (lambda (qs rs)
          (if (equal? qs '(0))
              (values '(0) (cons (* sn (length rs)) rs))
              (values (cons (* (if (= sn sd) 1 -1) (length qs)) qs)
                      (cons (* sn (length rs)) rs))))))))

(define (string->big str . args)
  (define (char->digit c)
    (cond ((char-numeric? c) (- (char->integer c) 48))
          ((char-upper-case? c) (- (char->integer c) 55))
          ((char-lower-case? c) (- (char->integer c) 87))
          (else (error 'char->digit "illegal character"))))
  (if (string=? str "") '(0)
    (let* ((radix (list 1 (if (null? args) 10 (car args))))
           (s (if (char=? (string-ref str 0) #\-) -1 1))
           (ds (string->list str))
           (ds (if (positive? s) ds (cdr ds)))
           (ds (map char->digit ds)))
      (let loop ((ds (cdr ds)) (big (list 1 (car ds))))
        (if (null? ds) (cons (* s (car big)) (cdr big))
          (loop (cdr ds)
                (big-plus (big-times big radix)
                          (list 1 (car ds)))))))))

(define (big->string big . args)
  (define (digit->char d)
    (cond ((< d 10) (integer->char (+ d 48)))
          ((< d 36) (integer->char (+ d 55)))
          (else (error 'digit->char "illegal digit"))))
  (if (big-zero? big) "0"
    (if (big-negative? big) (string-append "-" (big->string (big-negate big)))
      (let ((radix (list 1 (if (null? args) 10 (car args)))))
        (let loop ((big big) (ds '()))
          (if (big-zero? big) (list->string ds)
            (call-with-values
              (lambda () (big-divide big radix))
              (lambda (q r) (loop q (cons (digit->char (cadr r)) ds))))))))))

About these ads

Pages: 1 2 3

One Response to “Big Numbers: Input And Output”

  1. My Haskell solution (see http://bonsaicode.wordpress.com/2011/06/14/programming-praxis-big-numbers-input-and-output/ for a version with comments):

    readBase :: (Num a, Enum a) => a -> String -> a
    readBase b ('-':xs) = - readBase b xs
    readBase b xs       = foldl (\a x -> b * a + val x) 0 xs where
        val d = maybe (error "unrecognized digit") id . lookup d $ zip
                (['0'..'9'] ++ ['A'..'Z'] ++ ['a'..'z']) [0..]
    
    showBase :: Integral a => a -> a -> String
    showBase b n = if n < 0 then '-' : showBase b (abs n) else
                   map (digit . snd) $ m : reverse ms  where
        ((_:ms), (m:_)) = span ((> 0) . fst) $ iterate (flip divMod b . fst) (n, 0)
        digit d = maybe undefined id . lookup d . zip [0..] $
                  ['0'..'9'] ++ ['A'..'Z'] ++ ['a'..'z']
    

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s

Follow

Get every new post delivered to your Inbox.

Join 637 other followers

%d bloggers like this: