fork download
copy 
  1. ; balanced ternary arithmetic
  2.  
  3. (define (drop-while pred? xs)
  4.   (let loop ((xs xs))
  5.     (if (or (null? xs) (not (pred? (car xs)))) xs
  6.       (loop (cdr xs)))))
  7.  
  8. (define (fold-left op base xs)
  9.   (if (null? xs)
  10.       base
  11.       (fold-left op (op base (car xs)) (cdr xs))))
  12.  
  13. (define (normalize xs)
  14.   (let ((xs (drop-while zero? xs)))
  15.     (if (null? xs) (list 0) xs)))
  16.  
  17. (define (ternary n)
  18.     (let loop ((n n) (ts (list)))
  19.       (if (zero? n) (normalize ts)
  20.         (case (modulo n 3)
  21.           ; (quotient n 3) does the wrong thing if negative n
  22.           ((0) (loop (inexact->exact (floor (/ n 3))) (cons 0 ts)))
  23.           ((1) (loop (inexact->exact (floor (/ n 3))) (cons 1 ts)))
  24.           ((2) (loop (inexact->exact (floor (/ (+ n 1) 3))) (cons -1 ts)))))))
  25.  
  26. (define (decimal ts)
  27.   (fold-left (lambda (x y) (+ x x x y)) 0 ts))
  28.  
  29. (define (to-string ts)
  30.   (let ((digits '((0 . #\0) (1 . #\+) (-1 . #\-))))
  31.     (apply string (map (lambda (d) (cdr (assoc d digits))) ts))))
  32.  
  33. (define (from-string str)
  34.   (let ((chars '((#\0 . 0) (#\+ . 1) (#\- . -1))))
  35.     (map (lambda (c) (cdr (assoc c chars))) (string->list str))))
  36.  
  37. (define (plus xs ys)
  38.   (define (add x y c)
  39.     (let ((ts (ternary (+ x y c))))
  40.       (if (null? (cdr ts))
  41.           (values 0 (car ts))
  42.           (values (car ts) (cadr ts)))))
  43.   (let loop ((xs (reverse xs)) (ys (reverse ys)) (zs (list)) (carry 0))
  44.     (cond ((and (null? xs) (null? ys))
  45.             (normalize (cons carry zs)))
  46.           ((null? xs)
  47.             (let-values (((c s) (add 0 (car ys) carry)))
  48.               (loop xs (cdr ys) (cons s zs) c)))
  49.           ((null? ys)
  50.             (let-values (((c s) (add (car xs) 0 carry)))
  51.               (loop (cdr xs) ys (cons s zs) c)))
  52.           (else
  53.             (let-values (((c s) (add (car xs) (car ys) carry)))
  54.               (loop (cdr xs) (cdr ys) (cons s zs) c))))))
  55.  
  56. (define (negate xs) (map (lambda (d) (- d)) xs))
  57.  
  58. (define (times xs ys)
  59.   (let loop ((xs (reverse xs)) (shift (list)) (prod (list)))
  60.     (if (null? xs) (normalize prod)
  61.       (loop (cdr xs) (cons 0 shift)
  62.         (case (car xs)
  63.           ((-1) (plus (negate (append ys shift)) prod))
  64.           ((0) prod)
  65.           ((1) (plus (append ys shift) prod)))))))
  66.  
  67. (display (decimal (plus (ternary 523) (ternary 476)))) (newline)
  68. (display (decimal (plus (negate (ternary 523)) (ternary 476)))) (newline)
  69. (display (decimal (times (ternary 523) (ternary 476)))) (newline)
Success #stdin #stdout 0.01s 7272KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
999
-47
248948
https://ideone.com/97fr7R
language:
()
created:
9 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!