Progress Char

よくプログラムの作業中、ユーザーを待たせる間に、回転するカーソルが表示されることがありますよね？

それを作ってみました。

(define (progress)
  (define chars '(#\| #\/ #\- #\\))
  (define (loop l)
    (if (null? l)
        (loop chars)
        (begin (ticker (car l))
               (sleep 1)
               (loop (cdr l)))))
  (let ((t (thread (lambda ()
                     (loop chars)))))
    (lambda ()
      (kill-thread t))))

同じ位置に文字を表示し続けるためには、出力した文字と同じ数だけバックスペース文字を出力する必要があります。次の関数郡を利用しています。

(define ticker
  (opt-lambda (msg (out (current-output-port)))
    (unless (string? msg)
      (set! msg (build-string msg)))
    (let ((send (send-reply out))
          (erase (repeat #\backspace (string-length msg))))
      (send msg)
      (flush-output out)
      (send erase))))

(define (build-string . l)
  (get-output-string
   ((send-reply (open-output-string)) l)))

(define (constantly x) (lambda _ x))

(define (repeat c n)
  (build-string (map (constantly c) (iota n))))

;; Adapted from:
;; http://srfi.schemers.org/srfi-13/mail-archive/msg00073.html
(define send-reply
  (opt-lambda ((out (current-output-port)))
    (lambda fragments
      (let loop ((fragments fragments))
        (cond ((null? fragments) out)
              ((or (not (car fragments))
                   (null? (car fragments)))
               (loop (cdr fragments)))
              ((pair? (car fragments))
               (loop (car fragments))
               (loop (cdr fragments)))
              ((procedure? (car fragments))
               ((car fragments) (send-reply out))
               (loop (cdr fragments)))
              ((port? (car fragments))
               (copy-port (car fragments) out)
               (loop (cdr fragments)))
              (else
               (display (car fragments) out)
               (loop (cdr fragments))))))))

使い方:

(let ((stop (progress)))
  (do some time-consuming work)
  (stop))

残り時間や進捗状況は一切分かりませんが、フリーズしているのではないことを知らせる程度の効果はあります。