path: root/plus-inc.lisp

;;;; plus function

(defvar *number-units-at-beginning* nil)

(defun cut-digits (number-list-reversed)
  "Given a reversed number list it cuts unecessay digits."
  (cond
    ((null (cdr number-list-reversed)) number-list-reversed)
    ((eq (car number-list-reversed) '|0|)
     (cut-digits (cdr number-list-reversed)))
    (t number-list-reversed)))

(defun may-reverse (number)
  "If units is placed on the end, reverse; else keep it."
  (if *number-units-at-beginning*
      number
      (reverse number)))

(defun may-reverse-and-cut (number)
  "If units is placed on the end, reverse; else keep it. Also cuts unecessary digits."
  (if *number-units-at-beginning*
      (reverse (cut-digits (reverse number)))
      (reverse (cut-digits number))))

(defun explode-string (string)
  "Given a string, it returns a list of the symbol of this string"
  (loop for letter across string collect (intern (string letter))))

(defun explode (number)
  "Given a number (which can have letters), it returns a list of the symbols of this number"
  (loop for letter across (prin1-to-string number) collect (intern (string letter))))

(defun implode (number)
  "Given a list of the symbols of a number (which can have letters), it returns the symbol of this number"
  (intern (apply #'concatenate 'string (mapcar #'symbol-name number))))

(defun symbol-to-number (symbol)
  "Given a symbol, returns it's number."
  (nth-value 0 (parse-integer (symbol-name symbol))))

(defun next-digit (numerals digit)
  "Given a list of a numeral system and a digit, it returns the next digit."
  (cond
    ((eq (car (last numerals)) digit) (car numerals))
    ((not (eq (car numerals) digit)) (next-digit (cdr numerals) digit))
    (t (cadr numerals))))

(defun next-list-number (numerals number-list)
  "Given a list of a numeral system and a list of a number, it returns a list of the next number."
  (cond
    ((null number-list) (cons (if (eq (car numerals) '|0|)
				  (cadr numerals)
				  (car numerals))
			      nil))
    ((eq (car number-list) (car (last numerals)))
     (cons (car numerals) (next-list-number numerals (cdr number-list))))
    (t (cons (next-digit numerals (car number-list)) (cdr number-list)))))

(defun previous-digit (numerals digit)
  "Given a list of a numeral system and a digit, it returns the previous digit."
  (next-digit (reverse numerals) digit))

(defun previous-list-number (numerals number-list)
  "Given a list of a numeral system and a list of a number, it returns a list of the previous number."
  (cond
    ((and
      (null (cdr number-list))
      (eq (car number-list)
	   (if (eq (car numerals) '|0|)
	       (cadr numerals)
	       (car numerals))))
     nil)
    ((and
      (eq (car number-list) (car numerals))
      (not (null (cdr number-list))))
     (cons (previous-digit numerals (car number-list)) (previous-list-number numerals (cdr number-list))))
    (t (cons (previous-digit numerals (car number-list)) (cdr number-list)))))

(defun plus-args-list (numerals a b)
  "Given a list of a numeral system and 2 lists of numbers, it returns the list of it's sum."
  (cond
    ((and
      (null (cdr b))
      (eq (car b) (if (eq (car numerals) '|0|)
				(cadr numerals)
				(car numerals))))
     (next-list-number numerals a))
    (t (plus-args-list numerals (next-list-number numerals a) (previous-list-number numerals b)))))

(defun plus (numerals a b)
  "Given a list of a numeral system and 2 lists of symbols, it returns the list of it's sum."
  (may-reverse (plus-args-list numerals (may-reverse-and-cut a) (may-reverse-and-cut b))))

(defun plus-decimal (&rest args)
  "Given decimal numbers, it returns the symbol it's sum."
  (nth-value 0 (implode (may-reverse (reduce (lambda (a b) (plus-args-list '(|0| |1| |2| |3| |4| |5| |6| |7| |8| |9|) a b)) (mapcar #'may-reverse-and-cut (mapcar #'explode args)))))))

(defun plus-earth (&rest args)
  "Give earthal numbers, it returns it's sum."
  (symbol-to-number (nth-value 0 (implode (may-reverse (reduce (lambda (a b) (plus-args-list '(|1| |2| |3| |4| |5|) a b)) (mapcar #'may-reverse-and-cut (mapcar #'explode args))))))))