(defpackage :bignum
  (:use :cl))

(in-package :bignum)

(defparameter base 10
  "Pick whatever you like, but it better is even.")

(define-symbol-macro halfbase
    (floor base 2))

(defparameter z-zero '(0))
(defparameter z-one '(1))

(defun n-length (a)
  (let ((r 0))
    (do ((i 0 (+ i 1))
         (q a (cdr q)))
        ((null q) r)
      (unless (zerop (car q))
        (setq r (+ i 1))))))

(defun ith-digit (x i)
  (or (nth i x) 0))

(defun digit-sign (x)
  (if (< x halfbase) 0 (1- base)))

;;;

(defun z-add (a b &optional (carry 0))
  (multiple-value-bind (carry sum)
      (floor (+ carry (car a) (car b)) base)
    (cond ((null (cdr a))
           (cond ((null (cdr b))
                  (let ((a-sign (digit-sign (car a)))
                        (b-sign (digit-sign (car b))))
                    (num-cons sum (list (mod (+ a-sign b-sign carry) base)))))
                 (t
                  (let ((a-sign (digit-sign (car a))))
                    (num-cons sum (z-add (list a-sign)
                                     (cdr b)
                                     carry))))))
          ((null (cdr b))
           (let ((b-sign (digit-sign (car b))))
             (num-cons sum (z-add (cdr a)
                              (list b-sign)
                              carry))))
          (t
           (num-cons sum (z-add (cdr a) (cdr b) carry))))))

(defun num-cons (new rest)
  "Conses a new number and makes sure that the result is normalized
given that `rest` is normalized as well."
  (cond ((null rest) (list new))
        ((and (null (cdr rest))
              (zerop (car rest))
              (< new halfbase))
         (list new))
        ((and (null (cdr rest))
              (= (1- base) (car rest))
              (>= new halfbase))
         (list new))
        (t
         (cons new rest))))

(defun z-neg (a &optional (carry 1))
  (let* ((a-digit (- (1- base) (car a)))
         (a-sign (if (< a-digit halfbase) 0 (1- base))))
    (multiple-value-bind (carry sum)
        (floor (+ carry a-digit) base)
      (num-cons sum (cond ((null (cdr a))
                           (list (mod (+ a-sign carry) base)))
                          (t
                           (z-neg (cdr a) carry)))))))

(defun z-sub (a b)
  (z-add a (z-neg b)))

(defun z-minusp (a)
  (cond ((null (cdr a))
         (>= (car a) halfbase))
        (t
         (z-minusp (cdr a)))))

(defun n-scale (k a carry)
  "Multiplies a number by one digit."
  (let* ((a-digit (car a)))
    (multiple-value-bind (hi lo)
        (floor (+ carry (* k a-digit)) base)
      (num-cons lo
                (if (cdr a)
                    (n-scale k (cdr a) hi)
                    (num-cons hi (list 0)))))))

(defun z-mul (a b)
  (cond ((z-minusp a)
         (z-neg (z-mul (z-neg a) b)))
        ((z-minusp b)
         (z-neg (z-mul a (z-neg b))))
        (t
         (n-mul a b))))

(defun n-mul (a b)
  (cond ((null (cdr a)) (n-scale (car a) b 0))
        ((null (cdr b)) (n-scale (car b) a 0))
        (t
         (z-add (n-scale (car a) b 0)
                (n-scale base (n-mul (cdr a) b) 0)))))

(defun n-compare (a b)
  (cond ((null a)
         (if (null b) 0 -1))
        ((null b) +1)
        (t (let ((r (n-compare (cdr a) (cdr b))))
             (if (zerop r)
                 (cond ((< (car a) (car b)) -1)
                       ((> (car a) (car b)) +1)
                       (t 0))
                 r)))))

(defun n-div (a b)
  ;; We still need to scale!!
  (let* ((na (n-length a))
         (nb (n-length b))
         (q z-zero))
    (when (>= na nb)
      (let* ((b* (ith-digit b (1- nb))))
        (do ((i na (- i 1))
             (p (make-list (- na nb) :initial-element 0)
                (cdr p)))
            ((< i nb))
          (do* ((guess (min (1- base)
                         (floor (+ (* base (ith-digit a i))
                                   (ith-digit a (1- i)))
                                b*))
                    (- guess 1))
                (r (z-sub a (append p (n-scale guess b 0)))
                   (z-add r (append p b))))
               ((not (z-minusp r))
                (setq a r)
                (setq q (num-cons guess q)))))))
    (values q a)))

#+(or)
(defun integer-z (x)
  (cond ((< x 0)
         (z-neg (integer-z (- x))))
        ((= x 0)
         (list 0))
        (t
         (multiple-value-bind (hi low)
             (floor x base)
           (num-cons low (integer-z hi))))))

#+(or)
(defun z-integer (x)
  (if (z-minusp x)
      (- (z-integer (z-neg x)))
      (+ (car x) (if (cdr x)
                     (* base (z-integer (cdr x)))
                     0))))