mp-square-root.scm

(define (drop-while pred lis)
  (if (and (pair? lis) (pred (car lis))) (drop-while pred (cdr lis)) lis))

(define (mp-lt-d? xs ys)
  (cond ((null? xs) #f)
        ((= (car xs) (car ys)) (mp-lt-d? (cdr xs) (cdr ys)))
        (else (< (car xs) (car ys)))))

(define (mp-add-a->a xs y)
  (let lp ((z (+ (car xs) y)) (xs (cdr xs)) (zs '()))
    (if (or (< z 10) (null? xs)) `(,@(reverse zs) ,z . ,xs)
      (lp (+ (car xs) (quotient z 10)) (cdr xs) `(,(- z 10) . ,zs)))))

(define (mp-sub-a->d xs ys)
  (let lp ((xs (cdr xs)) (ys (cdr ys)) (z (- (car xs) (car ys))) (zs '()))
    (cond ((null? xs) `(,z . ,zs))
          ((< z 0) (lp (cdr xs) (cdr ys) (+ (car xs) (- (car ys)) -1)
                       `(,(+ z 10) . ,zs)))
          (else    (lp (cdr xs) (cdr ys) (- (car xs) (car ys))
                       `(,z . ,zs))))))

(define (mp-sqrt-d->a xs)
  (let* ((xs (drop-while zero? xs))
         (xs (if (odd? (length xs)) `(0 . ,xs) xs)))

    (let shift ((last-odd (reverse (mp-sub-a->d '(0 0) '(1 0)))) (ans '())
                (rest `(,(car xs) ,(cadr xs))) (src (cddr xs)))

      (let subtract ((last-odd last-odd) (count 0) (rest rest))
        (let ((last-odd+2 (reverse (mp-add-a->a last-odd 2))))
          (if (mp-lt-d? rest last-odd+2)
            (if (null? src)
              `(,count . ,ans)
              (shift `(9 . ,last-odd) `(,count . ,ans)
                     `(,(+ (* (car rest) 10) (cadr rest)) ,@(cddr rest)
                       ,(car src) ,(cadr src))
                     (cddr src)))

            (let ((last-odd (reverse last-odd+2)))
              (subtract last-odd (+ count 1)
                        (mp-sub-a->d (reverse rest) last-odd)))))))))