; balanced ternary arithmetic
(define (drop-while pred? xs)
(let loop ((xs xs))
(if (or (null? xs) (not (pred? (car xs)))) xs
(loop (cdr xs)))))
(define (fold-left op base xs)
(if (null? xs)
base
(fold-left op (op base (car xs)) (cdr xs))))
(define (normalize xs)
(let ((xs (drop-while zero? xs)))
(if (null? xs) (list 0) xs)))
(define (ternary n)
(let loop ((n n) (ts (list)))
(if (zero? n) (normalize ts)
(case (modulo n 3)
; (quotient n 3) does the wrong thing if negative n
((0) (loop
(inexact
->exact
(floor (/ n
3))) (cons
0 ts
))) ((1) (loop
(inexact
->exact
(floor (/ n
3))) (cons
1 ts
))) ((2) (loop
(inexact
->exact
(floor (/ (+ n
1) 3))) (cons
-1 ts
)))))))
(define (decimal ts)
(fold-left (lambda (x y) (+ x x x y)) 0 ts))
(define (to-string ts)
(let ((digits '((0 . #\0) (1 . #\+) (-1 . #\-))))
(apply string (map (lambda (d) (cdr (assoc d digits))) ts))))
(define (from-string str)
(let ((chars '((#\0 . 0) (#\+ . 1) (#\- . -1))))
(map (lambda (c) (cdr (assoc c chars))) (string->list str))))
(define (plus xs ys)
(define (add x y c)
(let ((ts (ternary (+ x y c))))
(if (null? (cdr ts))
(values 0 (car ts))
(values (car ts) (cadr ts)))))
(let loop ((xs (reverse xs)) (ys (reverse ys)) (zs (list)) (carry 0))
(cond ((and (null? xs) (null? ys))
(normalize (cons carry zs)))
((null? xs)
(let-values (((c s) (add 0 (car ys) carry)))
(loop xs (cdr ys) (cons s zs) c)))
((null? ys)
(let-values (((c s) (add (car xs) 0 carry)))
(loop (cdr xs) ys (cons s zs) c)))
(else
(let-values (((c s) (add (car xs) (car ys) carry)))
(loop (cdr xs) (cdr ys) (cons s zs) c))))))
(define (negate xs) (map (lambda (d) (- d)) xs))
(define (times xs ys)
(let loop ((xs (reverse xs)) (shift (list)) (prod (list)))
(if (null? xs) (normalize prod)
(loop (cdr xs) (cons 0 shift)
(case (car xs)
((-1) (plus (negate (append ys shift)) prod))
((0) prod)
((1) (plus (append ys shift) prod)))))))
(display (decimal (plus (ternary 523) (ternary 476)))) (newline)
(display (decimal (plus (negate (ternary 523)) (ternary 476)))) (newline)
(display (decimal (times (ternary 523) (ternary 476)))) (newline)