(in-package :cl-user)

(defun dragon4 (f)
  ;; straight from the paper
  ;; => digit-sequence; position of decimal point
  (let ((p (float-precision f))
        (res nil))
    (multiple-value-bind (f e) (integer-decode-float f)
      (incf e p)
      (let ((r (ash f (max (- e p) 0)))
            (s (ash 1 (max (- p e) 0))))
        (let* ((m- (ash 1 (max (- e p) 0)))
               (m+ m-)
               k h u low high)
          ;; simple fixup
          (when (= f (ash 1 (- p 1)))
            (setf m+ (ash m+ 1)
                  r (ash r 1)
                  s (ash s 1)))
          ;;
          (setf k 0)
          (loop
            (unless (< r (ceiling s 10)) (return))
            (setq k (- k 1)
                  r (* r 10)
                  m- (* m- 10)
                  m+ (* m+ 10)))
          ;;
          (loop
            (unless (>= (+ (* 2 r) m+) (* 2 s))
              (return))
            (setq s (* 10 s)
                  k (+ k 1)))
          ;;
          (setq h k)
          (loop
            (setq k (- k 1)
                  u (floor (* 10 r) s)
                  r (mod (* r 10) s)
                  m- (* m- 10)
                  m+ (* m+ 10)
                  low (< (* 2 r) m-)
                  high (> (* 2 r) (- (* 2 s) m+)))
            (unless (and (not low) (not high))
              (return))
            (push u res))
          ;;
          (cond ((and low (not high))
                 (push u res))
                ((and high (not low))
                 (push (1+ u) res))
                ((and low high)
                 (cond ((<= (* 2 r) s) (push u res))
                       ((>= (* 2 r) s) (push (1+ u) res)))))
          (values (reverse res) h k))))))