Event loop with ncurse

events.lisp

(ql:quickload '(:iolib :cl-charms))
(defpackage :tui (:use :cl :cl-charms :iomux))
(in-package :tui)

;;; From http://turtleware.eu/posts/cl-charms-crash-course.html

(defun start-color ()
  (when (eql (charms/ll:has-colors) charms/ll:FALSE)
    (error "Your terminal does not support color."))
  (let ((ret-code (charms/ll:start-color)))
    (if (= ret-code 0)
        T
        (error "start-color error ~s." ret-code))))

(eval-when (:load-toplevel :compile-toplevel :execute)
  (defconstant +black+   charms/ll:COLOR_BLACK)
  (defconstant +red+     charms/ll:COLOR_RED)
  (defconstant +green+   charms/ll:COLOR_GREEN)
  (defconstant +yellow+  charms/ll:COLOR_YELLOW)
  (defconstant +blue+    charms/ll:COLOR_BLUE)
  (defconstant +magenta+ charms/ll:COLOR_MAGENTA)
  (defconstant +cyan+    charms/ll:COLOR_CYAN)
  (defconstant +white+   charms/ll:COLOR_WHITE))

(defmacro define-color-pair ((name pair) foreground background)
  `(with-curses ()
     (start-color)
     (defparameter ,name (progn (charms/ll:init-pair ,pair ,foreground ,background)
                                (charms/ll:color-pair ,pair)))))

(define-color-pair (+white/blue+ 1) +white+ +blue+)
(define-color-pair (+black/red+ 2) +black+ +red+)

(defun draw-window-background (window color-pair)
  (charms/ll:wbkgd (charms::window-pointer window) color-pair))

(defun call-with-colors (window color-pair function)
  (let ((ptr (charms::window-pointer window)))
    (charms/ll:wattron ptr color-pair)
    (unwind-protect (funcall function)
      (charms/ll:wattroff ptr color-pair))))
  
(defmacro with-colors ((window color-pair) &body body)
  `(call-with-colors ,window ,color-pair (lambda () ,@body)))

;;;;;;;;;;


(defun newline (&optional (count 1))
  (loop repeat count do
    (write-char-at-cursor *standard-window* #\Newline)))

(defun print-text-char-by-char (text delay-seconds &aux interrupted)
  (disable-echoing)
  (enable-raw-input :interpret-control-characters t)
  (enable-non-blocking-mode *standard-window*)
  (let ((fd
          ;; on sbcl, try to get the FD of the TTY to attach an event
          ;; handler on it (so that the event loop can be interrupted
          ;; even when the animation is otherwise waiting for the
          ;; timer)
          #+sbcl
          (ignore-errors (sb-sys:fd-stream-fd sb-sys:*tty*))
          #-sbcl
          nil))
    (unwind-protect
         (with-event-base (event-base)
           (let ((timer nil) (index 0))
             (labels ((on-key (fd event error)
                        (declare (ignore fd event error))
                        (get-char *standard-window*)
                        (complete))
                      (complete ()
                        (setf interrupted t)
                        (write-string-at-cursor *standard-window*
                                                (subseq text index))
                        (refresh-window *standard-window*)
                        (end-printing))
                      (end-printing ()
                        (when timer
                          (remove-timer event-base timer)
                          (exit-event-loop event-base)
                          (setf timer nil)))
                      (on-tick ()
                        (cond
                          ((>= index (length text))
                           (end-printing))
                          ((and (not fd)
                                (get-char *standard-input* :ignore-error t))
                           (complete))
                          (t
                           (write-char-at-cursor *standard-window*
                                                 (char text index))
                           (incf index)
                           (refresh-window *standard-window*)))))
               (setf timer (add-timer event-base
                                      #'on-tick
                                      delay-seconds))
               (when fd
                 (set-io-handler event-base fd :read #'on-key))
               (event-dispatch event-base))))
      (disable-non-blocking-mode *standard-window*)
      (disable-raw-input)
      (enable-echoing)))
  interrupted)

(defparameter *default-cps* 15)

(defun print-text (text &optional (characters-per-seconds *default-cps*))
  (check-type characters-per-seconds (or null real))
  (assert (not (eql 0 characters-per-seconds)))
  (if characters-per-seconds
      (print-text-char-by-char text (/ 1 characters-per-seconds))
      (write-string-at-cursor *standard-window* text)))

(defun %input-into (buffer)
  (loop
    for c = (get-char *standard-window* :ignore-error t)
    while c until (member c '(#\newline #\etx))
    do (case c
         ((#\backspace #\rubout)
          (cond
            ((plusp (fill-pointer buffer))
             (vector-pop buffer)
             (move-cursor-left *standard-window*)
             (clear-line-after-cursor *standard-window*))
            (t (charms/ll:flash))))
         (t 
          (cond 
            ((graphic-char-p c)
             (write-char-at-cursor *standard-window* c)
             (vector-push c buffer))
            (t (warn "ignored char ~a" c)))))
    finally (newline)))

(defun make-buffer ()
  (make-array 64 :element-type 'character :fill-pointer 0 :adjustable t))

(defun input ()
  (let ((result (make-buffer)))
    (enable-raw-input)
    (disable-echoing)
    (prog1 result
      (unwind-protect (%input-into result)           
        (enable-echoing)
        (disable-raw-input)))))

(defparameter *banner*
  "Stack Overflow - Where Developers Learn, Share, & Build Careers")

(defun prompt (prompt)
  (print-text prompt)
  (multiple-value-bind (x y) (cursor-position *standard-window*)
    (let ((value (with-colors (*standard-window* +white/blue+) (input))))
      (prog1 value
        (multiple-value-bind (nx ny) (cursor-position *standard-window*)
          (move-cursor *standard-window* x y)
          (print-text value nil)
          (move-cursor *standard-window* nx ny)
          (refresh-window *standard-window*))))))

(defun clear ()
  (clear-window *standard-window* :force-repaint t)
  (refresh-window *standard-window*))

(defun fmt (control &rest args)
  (print-text (apply #'format nil control args)))

(defun test (&optional (banner *banner*))
  (prog (name value)
     (with-curses ()
       (clear)
       (let ((interrupted (print-text banner)))
         (newline 2)
         ;; if the previous text was interrupted, write the prompt quickly too
         (setf name (let ((*default-cps* (unless interrupted *default-cps*)))
                      (prompt "Enter your name: ")))
         (when (alexandria:emptyp name)
           (setf name 'anonymous))
         (move-cursor-down *standard-window* :amount 1)
         (fmt "Hello, ~a~%~%" name)
         (setf value (prompt "Enter something else: "))
         (return
           (values name value))))))