93 lines
2.6 KiB
Common Lisp
93 lines
2.6 KiB
Common Lisp
;;; balanced ternary
|
||
;;; represented as a list of 0, 1 or -1s, with least significant digit first
|
||
|
||
;;; convert ternary to integer
|
||
(defun bt-integer (b)
|
||
(reduce (lambda (x y) (+ x (* 3 y))) b :from-end t :initial-value 0))
|
||
|
||
;;; convert integer to ternary
|
||
(defun integer-bt (n)
|
||
(if (zerop n) nil
|
||
(case (mod n 3)
|
||
(0 (cons 0 (integer-bt (/ n 3))))
|
||
(1 (cons 1 (integer-bt (floor n 3))))
|
||
(2 (cons -1 (integer-bt (floor (1+ n) 3)))))))
|
||
|
||
;;; convert string to ternary
|
||
(defun string-bt (s)
|
||
(loop with o = nil for c across s do
|
||
(setf o (cons (case c (#\+ 1) (#\- -1) (#\0 0)) o))
|
||
finally (return o)))
|
||
|
||
;;; convert ternary to string
|
||
(defun bt-string (bt)
|
||
(if (not bt) "0"
|
||
(let* ((l (length bt))
|
||
(s (make-array l :element-type 'character)))
|
||
(mapc (lambda (b)
|
||
(setf (aref s (decf l))
|
||
(case b (-1 #\-) (0 #\0) (1 #\+))))
|
||
bt)
|
||
s)))
|
||
|
||
;;; arithmetics
|
||
(defun bt-neg (a) (map 'list #'- a))
|
||
(defun bt-sub (a b) (bt-add a (bt-neg b)))
|
||
|
||
(let ((tbl #((0 -1) (1 -1) (-1 0) (0 0) (1 0) (-1 1) (0 1))))
|
||
(defun bt-add-digits (a b c)
|
||
(values-list (aref tbl (+ 3 a b c)))))
|
||
|
||
(defun bt-add (a b &optional (c 0))
|
||
(if (not (and a b))
|
||
(if (zerop c) (or a b)
|
||
(bt-add (list c) (or a b)))
|
||
(multiple-value-bind (d c)
|
||
(bt-add-digits (if a (car a) 0) (if b (car b) 0) c)
|
||
(let ((res (bt-add (cdr a) (cdr b) c)))
|
||
;; trim leading zeros
|
||
(if (or res (not (zerop d)))
|
||
(cons d res))))))
|
||
|
||
(defun bt-mul (a b)
|
||
(if (not (and a b))
|
||
nil
|
||
(bt-add (case (car a)
|
||
(-1 (bt-neg b))
|
||
( 0 nil)
|
||
( 1 b))
|
||
(cons 0 (bt-mul (cdr a) b)))))
|
||
|
||
;;; division with quotient/remainder, for completeness
|
||
(defun bt-truncate (a b)
|
||
(let ((n (- (length a) (length b)))
|
||
(d (car (last b))))
|
||
(if (minusp n)
|
||
(values nil a)
|
||
(labels ((recur (a b x)
|
||
(multiple-value-bind (quo rem)
|
||
(if (plusp x) (recur a (cons 0 b) (1- x))
|
||
(values nil a))
|
||
|
||
(loop with g = (car (last rem))
|
||
with quo = (cons 0 quo)
|
||
while (= (length rem) (length b)) do
|
||
(cond ((= g d) (setf rem (bt-sub rem b)
|
||
quo (bt-add '(1) quo)))
|
||
((= g (- d)) (setf rem (bt-add rem b)
|
||
quo (bt-add '(-1) quo))))
|
||
(setf x (car (last rem)))
|
||
finally (return (values quo rem))))))
|
||
|
||
(recur a b n)))))
|
||
|
||
;;; test case
|
||
(let* ((a (string-bt "+-0++0+"))
|
||
(b (integer-bt -436))
|
||
(c (string-bt "+-++-"))
|
||
(d (bt-mul a (bt-sub b c))))
|
||
(format t "a~5d~8t~a~%b~5d~8t~a~%c~5d~8t~a~%a × (b − c) = ~d ~a~%"
|
||
(bt-integer a) (bt-string a)
|
||
(bt-integer b) (bt-string b)
|
||
(bt-integer c) (bt-string c)
|
||
(bt-integer d) (bt-string d)))
|