;;;; whole numbers

(define (native->whole n)
    (if (= n 0)
	'()
	(cons (= (remainder n 2) 1)
	      (native->whole (quotient n 2)))))

(define (whole->native i)
    (let conv ((i i) (v 1))
	 (cond ((null? i)
		0)
	       ((car i)
		(+ v (conv (cdr i) (* v 2))))
	       (else
		(conv (cdr i) (* v 2))))))

(define (whole-normalize i)
    (if (null? i)
	'()
	(let ((r (whole-normalize (cdr i))))
	  (if (and (not (car i)) (null? r))
	      '()
	      (cons (car i) r)))))

(define (whole-inc i)
    (cond ((null? i)
	   (cons #t '()))
	  ((car i)
	   (cons #f (whole-inc (cdr i))))
	  (else
	   (cons #t (cdr i)))))

(define (whole-add i1 i2)
    (let add ((i1 i1) (i2 i2) (c #f))
	 (cond ((and (null? i1) (null? i2))
		(if c
		    (cons c '())
		    '()))
	       ((null? i1)
		(if c
		    (add (cons c '()) i2 #f)
		    i2))
	       ((null? i2)
		(add i2 i1 c))
	       (else
		(let ((d1 (car i1))
		      (r1 (cdr i1))
		      (d2 (car i2))
		      (r2 (cdr i2)))
		  (cond ((and (not d1) (not d2) (not c))
			 (cons #f (add r1 r2 #f)))
			((or (and d1 (not d2) (not c))
			     (and (not d1) d2 (not c))
			     (and (not d1) (not d2) c))
			 (cons #t (add r1 r2 #f)))
			((or (and d1 d2 (not c))
			     (and d1 (not d2) c)
			     (and (not d1) d2 c))
			 (cons #f (add r1 r2 #t)))
			(else
			 (cons #t (add r1 r2 #t)))))))))

;;; works for i1 >= i2
(define (whole-sub i1 i2)
    (letrec ((sub (lambda (i1 i2 c)
		    (cond ((null? i1)
			   '())
			  ((and (null? i2) (not c))
			   i1)
			  ((and (null? i2) c)
			   (if (car i1)
			       (cons #f (cdr i1))
			       (cons #t (sub (cdr i1) '() #t))))
			  (else
			   (let ((d1 (car i1))
				 (r1 (cdr i1))
				 (d2 (car i2))
				 (r2 (cdr i2)))
			     (cond ((and d1 (not d2) (not c))
				    (cons #t (sub r1 r2 #f)))
				   ((or (and d1 (or (and d2 (not c))
						    (and (not d2) c)))
					(and (not d1) (not d2) (not c)))
				    (cons #f (sub r1 r2 #f)))
				   ((or (and d1 d2 c)
					(and (not d1) (or (and d2 (not c))
							  (and (not d2) c))))
				    (cons #t (sub r1 r2 #t)))
				   ((and (not d1) d2 c)
				    (cons #f (sub r1 r2 #t))))))))))
	    (whole-normalize (sub i1 i2 #f))))

(define (whole-mul i1 i2)
    (letrec ((mul (lambda (i1)
		    (cond ((null? i1)
			   '())
			  ((car i1)
			   (whole-add i2 (cons #f (mul (cdr i1)))))
			  (else
			   (cons #f (mul (cdr i1))))))))
	    (whole-normalize (mul i1))))

(define (whole-eq? i1 i2)
    (cond ((and (null? i1) (null? i2))
	   #t)
	  ((and (not (null? i1)) (not (null? i2)))
	   (and (or (and (car i1) (car i2))
		    (and (not (car i1)) (not (car i2))))
		(whole-eq? (cdr i1) (cdr i2))))
	  (else
	   #f)))

(define (whole-less? i1 i2)
    (cond ((and (null? i1) (null? i2))
	   #f)
	  ((null? i1)
	   #t)
	  ((null? i2)
	   #f)
	  ((whole-less? (cdr i1) (cdr i2))
	   #t)
	  ((whole-eq? (cdr i1) (cdr i2))
	   (and (car i2) (not (car i1))))
	  (else
	   #f)))

(define (whole-leq? i1 i2)
    (or (whole-eq? i1 i2)
	(whole-less? i1 i2)))

(define (whole-div-mod i1 i2)
    (letrec ((div (lambda (i1)
		    (cond ((null? i1)
			   (cons '()
				 '()))
			  ((whole-less? i1 i2)
			   (cons '()
				 i1))
			  ((whole-eq? i1 i2)
			   (cons (cons #t '())
				 '()))
			  (else
			   (let ((res (div (cdr i1))))
			     (let ((q (car res))
				   (r (whole-normalize (cons (car i1) (cdr res)))))
			       (if (not (whole-less? r i2))
				   (cons (cons #t q)
					 (whole-sub r i2))
				   (cons (cons #f q)
					 r)))))))))
	    (let ((res (div i1)))
	      (let ((q (car res))
		    (r (cdr res)))
		(cons (whole-normalize q)
		      r)))))

(define (whole-div i1 i2)
    (car (whole-div-mod i1 i2)))

(define (whole-mod i1 i2)
    (cdr (whole-div-mod i1 i2)))

;;;; integers

(define (native->integer n)
    (if (< n 0)
	(cons #t (native->whole (- n)))
	(cons #f (native->whole n))))

(define (integer->native i)
    (if (car i)
	(- (whole->native (cdr i)))
	(whole->native (cdr i))))

(define (integer-add i1 i2)
    (cond ((and (car i1) (car i2))
	   (cons #t (whole-add (cdr i1) (cdr i2))))
	  ((and (car i1) (not (car i2)))
	   (integer-add i2 i1))
	  ((and (not (car i1)) (car i2))
	   (cond ((whole-less? (cdr i2) (cdr i1))
		  (cons #f (whole-sub (cdr i1) (cdr i2))))
		 ((whole-eq? (cdr i1) (cdr i2))
		  (cons #f '()))
		 (else
		  (cons #t (whole-sub (cdr i2) (cdr i1))))))
	  ((and (not (car i1)) (not (car i2)))
	   (cons #f (whole-add (cdr i1) (cdr i2))))))

(define (integer-sub i1 i2)
    (integer-add i1 (cons (not (car i2)) (cdr i2))))

(define (integer-mul i1 i2)
    (let ((r (whole-mul (cdr i1) (cdr i2)))
	  (s (or (and (car i1) (not (car i2))) (and (not (car i1)) (car i2)))))
      (cons s r)))

(define (integer-eq? i1 i2)
    (and (or (and (car i1) (car i2))
	     (and (not (car i1)) (not (car i2))))
	 (whole-eq? (cdr i1) (cdr i2))))

(define (integer-less? i1 i2)
    (cond ((and (car i1) (car i2))
	   (whole-less? (cdr i2) (cdr i1)))
	  ((and (car i1) (not (car i2)))
	   #t)
	  ((and (not (car i1)) (car i2))
	   #f)
	  (else
	   (whole-less? (cdr i1) (cdr i2)))))

(define (integer-leq? i1 i2)
    (or (integer-eq? i1 i2)
	(integer-less? i1 i2)))
