;;;; In a computer science course at Catonsville Community College, I had to
;;;; write functions to add, subtract, multiply, divide, modulo, exponentiate,
;;;; get the greatest common denominator, and get the least common multiple,
;;;; with the catch that I could only use the built in addition and subtraction
;;;; operators once each, to add (or subtract) exactly one, and I couldn't use
;;;; any of the other builtin operators for the functions I was writing.  All
;;;; operations would be on positive integers and would return integers.
;;;; I set myself two additional tasks: I would deal with all integers, both
;;;; positive and negative, and I would match the interfaces of the equivalent
;;;; functions in Common Lisp.
;;;;
;;;; That was almost a decade ago, and one of the first things I wrote in
;;;; Common Lisp.  I've decided to tackle the task again, using my current
;;;; Common Lisp knowledge.  (For one thing, back then I didn't even know about
;;;; packages, let alone shadowing.)  Hopefully the comparisons will show me in
;;;; a positive light.

(defpackage :numbers
  (:use :common-lisp
        :lisp-unit)
  (:shadow 1+ 1- + - * / mod expt gcd lcm abs))
(in-package :numbers)

(defun 1+ (number)
  (cl:1+ number))

(defun 1- (number)
  (cl:1- number))

(defun + (&rest numbers)
  (labels ((+r (a b)
             (cond
               ((< (abs a) (abs b))  (+r b a))
               ((zerop b)   a)
               ((plusp b)   (+r (1+ a) (1- b)))
               ((minusp b)  (+r (1- a) (1+ b))))))
    (if (endp numbers)
        0
        (reduce #'+r numbers))))

(defun - (number &rest more-numbers)
  (labels ((negate (n)
             (cond
               ((zerop n)   0)
               ((plusp n)   (1- (negate (1- n))))
               ((minusp n)  (1+ (negate (1+ n)))))))
    (if (endp more-numbers)
        (negate number)
        (+ number (negate (reduce #'+ more-numbers))))))

(defun abs (number)
  (if (minusp number)
      (- number)
      number))

(defun * (&rest numbers)
  (labels ((*r (a b &optional (product 0))
             (cond
               ((zerop b)  product)
               ((minusp b) (*r (- a) (- b)))
               ((plusp b)  (*r a (1- b) (+ product a))))))
    (if (endp numbers)
        1
        (reduce #'*r numbers))))

;;; We're only dealing with integers, so I'm going to make this work like
;;; truncate.
;;; Takes NUMBER and MORE-NUMBERS and returns QUOTIENT and REMAINDER such that
;;; NUMBER = REMAINDER + QUOTIENT * DIVISOR, where
;;; DIVISOR = (apply #'* MORE-NUMBERS), and
;;; 0 <= REMAINDER < DIVISOR
(defun / (number &rest more-numbers)
  (labels ((/r (d r)
             (cond
               ((or (and (plusp d)
                         (<= 0 r)
                         (< r d))
                    (and (minusp d)
                         (<= r 0)
                         (< d r)))
                (values 0 r))
               ((plusp (* (signum d) (signum r)))
                (multiple-value-bind (q r)
                    (/r d (- r d))
                  (values (1+ q) r)))
               ((minusp (* (signum d) (signum r)))
                (multiple-value-bind (q r)
                    (/r d (+ r d))
                  (values (1- q) r))))))
    (if (endp more-numbers)
        (values number 0)
        (let ((denominator (reduce #'* more-numbers)))
          (if (zerop denominator)
              (error 'division-by-zero)
              (/r denominator number))))))

(defun mod (number divisor)
  (multiple-value-bind (q r)
      (/ number divisor)
    (declare (ignore q))
    r))

(defun expt (base-number power-number)
  (labels ((expt-r (b p)
             (cond
               ((zerop p)   1)
               ((plusp p)   (* b (expt-r b (1- p))))
               ;; For completeness.
               ((minusp p)  (/ (expt-r b (- p)))))))
    (expt-r base-number power-number)))

(defun gcd (&rest integers)
  (labels ((gcd-r (m n)
             (if (< (abs m) (abs n))
                 (gcd-r n m)
                 (let ((r (mod m n)))
                   (if (zerop r)
                       n
                       (gcd-r n r))))))
    (if (endp integers)
        0
        (abs (reduce #'gcd-r integers)))))

(defun lcm (&rest integers)
  (labels ((lcm-r (a b)
             (/ (abs (* a b)) (gcd a b))))
    (cond
      ((endp integers)        1)
      ((endp (cdr integers))  (abs (car integers)))
      ((member 0 integers)    0)
      (t                      (reduce #'lcm-r integers)))))


(defmacro test-set (operator &rest set)
  (let ((cl-op (find-symbol (string operator) 'common-lisp)))
    `(assert-equal (,cl-op ,@set)
                   (,operator ,@set))))

(define-test +
  (test-set +)
    
  (test-set + -2)
  (test-set + -1)
  (test-set + 0)
  (test-set + 1)
  (test-set + 2)

  (test-set + 0 0)
  (test-set + 0 1)
  (test-set + 1 0)

  (test-set + 2 5)
  (test-set + 5 2)
  (test-set + 15 20 25 40 60)
  (test-set + 40 25 60 15 20)

  (test-set + 0 -1)
  (test-set + -1 0)
  (test-set + -5 5)
  (test-set + -10 -12 -14 6))

(define-test -
  (test-set - -2)
  (test-set - -1)
  (test-set - 0)
  (test-set - 1)
  (test-set - 2)

  (test-set - 0 0)
  (test-set - 0 1)
  (test-set - 1 0)

  (test-set - 2 5)
  (test-set - 5 2)
  (test-set - 15 20 25 40 60)
  (test-set - 40 25 60 15 20)

  (test-set - 0 -1)
  (test-set - -1 0)
  (test-set - -5 5)
  (test-set - -10 -12 -14 6))

(define-test *
  (test-set *)

  (test-set * -2)
  (test-set * -1)
  (test-set * 0)
  (test-set * 1)
  (test-set * 2)

  (test-set * 0 1)
  (test-set * 1 0)
  (test-set * 1 1)

  (test-set * 0 2)
  (test-set * 2 0)
  (test-set * 1 2)
  (test-set * 2 1)
  (test-set * 2 2)

  (test-set * 0 1)

  (test-set * 1 2 3 4)
  (test-set * 3 2 4 1)
  (test-set * 100 100))

(define-test /
  (labels ((test-/ (&rest set)
             (assert-equal (cl:truncate (car set) (apply #'cl:* (cdr set)))
                           (apply #'/ set)
                           set)))
    (test-/ -2)
    (test-/ -1)
    (test-/ 0)
    (test-/ 1)
    (test-/ 2)

    (assert-error 'division-by-zero (/ 0 0))
    (assert-error 'division-by-zero (/ 1 0))
    (test-/ 0 1)
    (test-/ 1 2)
    (test-/ 2 1)
    (test-/ 2 2)

    (test-/ 15 3)
    (test-/ 16 3)
    (test-/ 37 2 3)
    (test-/ 37 3 2)))

(define-test mod
  (assert-error 'division-by-zero (mod 0 0))
  (assert-error 'division-by-zero (mod 1 0))
  (test-set mod 0 1)

  (test-set mod 1 2)
  (test-set mod 2 1)
  (test-set mod 2 2)

  (test-set mod 2 5)
  (test-set mod 5 2)
  (test-set mod -2 5)
  (test-set mod 2 -5)
  (test-set mod -5 2)
  (test-set mod 5 -2)

  (test-set mod 5 15)
  (test-set mod 15 5)
  (test-set mod -5 15)
  (test-set mod 5 -15)
  (test-set mod 15 -5)
  (test-set mod -15 5))

(define-test expt
  (test-set expt 0 0)
  (test-set expt 0 1)
  (test-set expt 1 0)
  (test-set expt 0 2)
  (test-set expt 2 0)

  (test-set expt 1 1)
  (test-set expt 1 2)
  (test-set expt 2 1)
  (test-set expt 2 2)

  (test-set expt 2 10)
  (test-set expt 10 2)
  (test-set expt 3 7)
  (test-set expt 7 3))

(define-test gcd
  (test-set gcd)

  (test-set gcd -2)
  (test-set gcd -1)
  (test-set gcd 0)
  (test-set gcd 1)
  (test-set gcd 2)

  (assert-error 'division-by-zero (gcd 0 0))
  (assert-error 'division-by-zero (gcd 0 1))
  (assert-error 'division-by-zero (gcd 1 0))
  (test-set gcd 1 1)

  (test-set gcd 1 2)
  (test-set gcd 2 1)
  (test-set gcd 2 2)

  (test-set gcd 3 15)
  (test-set gcd 4 15)
  (test-set gcd 5 15)

  (test-set gcd 6 36)
  (test-set gcd 30 36)
  (test-set gcd 6 36 40)
  (test-set gcd 40 36 6)
  (test-set gcd 6 36 40 23))

(define-test lcm
  (test-set lcm)

  (test-set lcm -2)
  (test-set lcm -1)
  (test-set lcm 0)
  (test-set lcm 1)
  (test-set lcm 2)

  (test-set lcm 0 0)
  (test-set lcm 0 1)
  (test-set lcm 1 0)
  (test-set lcm 1 1)

  (test-set lcm 0 2)
  (test-set lcm 2 0)
  (test-set lcm 2 2)

  (test-set lcm 2 4)
  (test-set lcm 4 6)
  (test-set lcm 10 15)
  (test-set lcm 10 15 20)
  (test-set lcm 10 15 21))