marquee in the shell

marquee.scm

#!/usr/local/bin/gosh

(use gauche.parseopt)
(use gauche.process)
(use srfi-1)
(use srfi-13)

(define (usage cmd)
  (print "usage: " cmd " [option] ... input")
  (print " options:")
  (print "   h|help           print this help")
  (print "   a|alternate      move from side to side") ; not implemented
  (print "   s|scrollamount   milliseconds of scrolling speed (default: 100)")
  (print "   r|reverse        move to right")
  (exit))

(define (get-tput-val . args)
  (process-output->string `(tput ,@args)))

(define (tput . args)
  (run-process `(tput ,@args)))

(define (return-to-top)
  (tput 'cup 0 0))

(define (sleep-milliseconds n)
  (sys-nanosleep (* n 1000000)))

(define (with-full-screen thunk)
  (dynamic-wind
    (^ _ (tput 'civis)(tput 'clear))
    thunk
    (^ _ (tput 'cnorm))))

(define (fill-list ls len var)
  (if (<= len (length ls))
      ls
      (append ls (list-tabulate (- len (length ls)) (^ _ var)))))

(define (string-pad-both/index str len index reverse?)
  (if reverse?
      (string-pad-right (string-pad str (- len index)) len)
      (string-pad (string-pad-right str (- len index)) len)))

(define (make-marquee-printer messages reverse? alternate?)
  (let* ((cols (x->integer (get-tput-val 'cols)))
         (lines (x->integer (get-tput-val 'lines)))
         (msg-max-width (apply max (map string-length messages)))
         (msg-width (max cols msg-max-width))
         (messages (take messages (min lines (length messages)))))
    (let1 i 0
      (^ _ (let* ((pudder (cut string-pad-both/index <>
                               msg-width (- msg-width i) reverse?))
                  (padded (map pudder messages))
                  (cutter (cut string-take <>
                               (if (< cols msg-width)
                                   cols
                                   msg-width)))
                  (cutted (map cutter padded))
                  (msg (apply string-append
                              (intersperse (string #\newline) cutted))))
             (print msg)
             (if (< i (+ msg-width msg-max-width))
                 (inc! i)
                 (set! i 0)))))))

(define (main args)
  (let-args (cdr args)
      ((help "h|help" => (cut usage (car args)))
       (alternate "a|alternate")
       (scrollamount "s|scrollamount=i" 100)
       (reverse "r|reverse")
       (else (opt . _)
             (print "Unknown option : " opt)
             (usage (car args)))
       . rest)
    (set-signal-handler! SIGINT (^ _ (exit)))
    (let1 messages (if (null? rest)
                       (port->string-list (current-input-port))
                       (call-with-input-string (car rest) port->string-list))
      (with-full-screen
       (^ _ (let1 murquee (make-marquee-printer messages reverse alternate)
              (while #t
                (return-to-top)
                (murquee)
                (flush)
                (sleep-milliseconds scrollamount))))))))