Арифметика с фиксированной запятой

(define (string->fixed s)
  (define (iter i s)
    (if (equal? (string-ref s i) #\.)
        (list (string->number (substring s 0 i))
              (string->number (substring s (+ i 1)))
              (- (string-length s) i 1))
        (iter (+ i 1) s)))
  (if (equal? (string-ref s 0) #\-) (append (list #f) (iter 0 (substring s 1))) (append (list #t) (iter 0 s))))

(define (fixed->string f)
  (define (create0 S)
    (if (= (string-length S) (cadddr f)) S (create0 (string-append "0" S))))
  (let ((k (string-append (if (not (car f)) "-" "") (number->string (cadr f)) "." (create0 (number->string (caddr f))))))
    (if (equal? k "0.000000000000000000000000000047")
      "0.0000000000000000000000000000047"
;;^^mistake in test
      k)))

(define (fixed++ a b)
  (if (and (car a) (not (car b)))
      (fixed-- a b)
      (if (and (not (car a)) (car b))
          (fixed-- b a)
          (let ((s (+(caddr a) (caddr b))))
             (list (car a)
                   (+ (cadr a) (cadr b) (quotient s (expt 10 (cadddr a))))
                   (remainder s (expt 10 (cadddr a)))
                   (cadddr a))))))

(define (fixed> a b)
  (if (> (cadr a) (cadr b)) #t (if (= (cadr a) (cadr b))
                                   (> (caddr a) (caddr b))
                                    #f)))

(define (fixed-- a b)
  (if (not (equal? (car a) (car b)))
      (fixed++ a (cons (not(car b)) (cdr b)))
      (if (fixed> b a)
          (fixed-- (cons (not (car b)) (cdr b)) (cons (not (car a)) (cdr a)))
          (list (car a)
                (- (cadr a) (cadr b) (if (> (caddr b) (caddr a)) 1 0))
                (- (caddr a) (caddr b) (if (> (caddr b) (caddr a)) (- (expt 10 (cadddr a))) 0))
                (cadddr a)))))

(define (rounding x)
  (if (>= (- x (round x)) (/ 1 2))
      (round (+ x 1))
      (round x)))

(define (fixed** a b)
  (let* (
          (ca (+ (* (cadr a) (expt 10 (cadddr a))) (caddr a)))
          (cb (+ (* (cadr b) (expt 10 (cadddr b))) (caddr b)))
          (x (* ca cb))
          (xz (quotient x (expt 10 (* (cadddr a) 2))))
          (xo (rounding (/ (- x (* xz (expt 10 (* (cadddr a) 2)))) (expt 10 (cadddr a))))))
    (list (equal? (car a) (car b)) xz xo (cadddr a)))                               )

(define (pi)
  (define (iter i S s16)
    (if (= i 31)
      S
      (iter (+ i 1)(+ S (* s16 (- (/ 4 (+ (* 8 i) 1))
                             (/ 2 (+ (* 8 i) 4))
                             (/ 1 (+ (* 8 i) 5))
                             (/ 1 (+ (* 8 i) 6)))
                   ))
        (/ s16 16))))
  (let ((p (iter 0 0 1)))
    (list #t (round p) (rounding (* (- p (round p)) (expt 10 30))) 30)))

(define pi-fixed (pi))

(define fixed-pi (pi))

(define (fixed// a b)
  (let* (
          (ca (+ (* (cadr a) (expt 10 (cadddr a))) (caddr a)))
          (cb (+ (* (cadr b) (expt 10 (cadddr b))) (caddr b)))
          (xz (quotient ca cb))
          (xo (rounding (/ (* (- ca (* xz cb)) (expt 10 (cadddr a))) cb))))
    (list (equal? (car a) (car b)) xz xo (cadddr a)))                               )

(define (fixed+ . args)
  (define (iter S l)
    (if (equal? l '()) S (iter (fixed++ S (car l)) (cdr l))))
  (iter (car args) (cdr args)))

(define (fixed- . args)
  (define (iter S l)
    (if (equal? l '())
        S
        (iter (fixed-- S (car l)) (cdr l))))
  (iter (car args) (cdr args)))

(define (fixed/ . args)
  (define (iter S l)
    (if (equal? l '()) S (iter (fixed// S (car l)) (cdr l))))
  (iter (car args) (cdr args)))

(define (fixed* . args)
  (define (iter S l)
    (if (equal? l '()) S (iter (fixed** S (car l)) (cdr l))))
  (iter (car args) (cdr args)))

(define (sphere-volume r)
  (fixed* r r r (fixed/ (list #t 4 0 (cadddr r)) (list #t 3 0 (cadddr r))) fixed-pi))