Tuberculosis gibber demo

gibber.lisp

(defpackage #:tuberculosis/demo/gibber
  (:use #:cl #:tuberculosis #:monotonic-clock)
  (:import-from #:alexandria #:random-elt)
  (:export #:main))

(in-package #:tuberculosis/demo/gibber)

(defun benchmark-redisplays (function)
  (let ((start 0)
        (elapsed 0)
        (redisplays 0))
    (with-text-display
      (setf start (monotonic-now/ms))
      (loop
       (setf elapsed (- (monotonic-now/ms) start))
       (when (>= elapsed 10000)
         (return))
       (funcall function)
       (redisplay)
       (incf redisplays)))
    (* redisplays (/ elapsed) 1000)))

(defmacro benchmark (name &body forms)
  `(list ',name
         (benchmark-redisplays (lambda () ,@forms))))

(defun report (&rest benchmarks)
  (loop for (name rps) in benchmarks
        do (format t "~A: ~F redisplays/s~%" name rps)))

(defun random-char ()
  #\X)

(defun random-color ()
  (random-elt '(:red :green :blue :white :black)))

(defun main ()
  (report
   (benchmark nothing)
   (benchmark random-char
     (draw-char (random (display-width))
                (random (display-height))
                (random-char)))
   (benchmark full
     (dotimes (y (display-height))
       (dotimes (x (display-width))
         (draw-char x
                    y
                    (random-char)
                    (random-color)
                    (random-color)))))))

text-display.lisp

;;;; +----------------------------------------------------------------+
;;;; | Tuberculosis                                                   |
;;;; +----------------------------------------------------------------+

(defpackage #:tuberculosis/text-display
  (:use #:cl)
  (:import-from
   #:acute-terminal-control
   #:background
   #:cursor
   #:dimensions
   #:disable-system-buffering
   #:disable-system-echoing
   #:enable-system-buffering
   #:enable-system-echoing
   #:erase
   #:foreground)
  (:export
   #:with-text-display
   #:draw-char
   #:toggle-char
   #:display-width
   #:display-height
   #:redisplay))

(in-package #:tuberculosis/text-display)

(defstruct (text-area (:constructor %make-text-area)
                      (:copier nil))
  width
  height
  ;; The following are attribute vectors of width-by-height
  ;; dimensions.
  value-buffer
  fg-buffer
  bg-buffer)

(defun make-text-area (width height &key (initial-value #\Space)
                                         (initial-fg :white)
                                         (initial-bg :black))
  (flet ((buffer (initial-element)
           (make-array (* width height) :initial-element initial-element)))
    (%make-text-area :width width
                     :height height
                     :value-buffer (buffer initial-value)
                     :fg-buffer (buffer initial-fg)
                     :bg-buffer (buffer initial-bg))))

(defun text-area-copy (text-area)
  (%make-text-area :width (text-area-width text-area)
                   :height (text-area-height text-area)
                   :value-buffer (copy-seq (text-area-value-buffer text-area))
                   :fg-buffer (copy-seq (text-area-fg-buffer text-area))
                   :bg-buffer (copy-seq (text-area-bg-buffer text-area))))

(defun text-area-replace (new old)
  (replace (text-area-value-buffer new) (text-area-value-buffer old))
  (replace (text-area-fg-buffer new) (text-area-fg-buffer old))
  (replace (text-area-bg-buffer new) (text-area-bg-buffer old)))

(defun text-area-cell-index (text-area x y)
  (+ (* y (text-area-width text-area)) x))

(defun text-area-set-cell (text-area x y value fg bg)
  (let ((index (text-area-cell-index text-area x y)))
    (when value
      (setf (aref (text-area-value-buffer text-area) index) value))
    (when fg
      (setf (aref (text-area-fg-buffer text-area) index) fg))
    (when bg
      (setf (aref (text-area-bg-buffer text-area) index) bg))
    (values)))

(defun text-area-toggle-cell (text-area x y)
  (let ((index (text-area-cell-index text-area x y)))
    (rotatef (aref (text-area-fg-buffer text-area) index)
             (aref (text-area-bg-buffer text-area) index))))

(defun inhibited-value-p (value)
  (member value
          '(10 #\Newline
            13 #\Return
            27 #\Escape
            12 #\Page
            11 #\Vt
            07 #\Bel)))

(defun write-cell (value fg bg)
  (setf (foreground) fg)
  (setf (background) bg)
  (cond ((inhibited-value-p value)
         (write-char #\Space))
        ((integerp value)
         (write-byte value *standard-output*))
        (t
         (write-char value))))

(defun text-area-render (new old)
  (if (null old)
      (text-area-render-from-scratch new)
      (text-area-render-incremental new old)))

(defun text-area-render-from-scratch (text-area)
  (erase)
  (let ((index 0)
        (width (text-area-width text-area))
        (height (text-area-height text-area)))
    (dotimes (y height)
      (setf (cursor) (cons (1+ y) 1))
      (dotimes (x width)
        (write-cell (aref (text-area-value-buffer text-area) index)
                    (aref (text-area-fg-buffer text-area) index)
                    (aref (text-area-bg-buffer text-area) index))
        (incf index))))
  (force-output))

(defun text-area-render-incremental (new old)
  (let ((height (text-area-height new))
        (width (text-area-width new))
        (index 0))
    (dotimes (y height)
      (dotimes (x width)
        (let ((old-value (aref (text-area-value-buffer old) index))
              (new-value (aref (text-area-value-buffer new) index))
              (old-fg (aref (text-area-fg-buffer old) index))
              (new-fg (aref (text-area-fg-buffer new) index))
              (old-bg (aref (text-area-bg-buffer old) index))
              (new-bg (aref (text-area-bg-buffer new) index)))
          (when (or (not (eql old-value new-value))
                    (not (eql old-fg new-fg))
                    (not (eql old-bg new-bg)))
            (setf (cursor) (cons (1+ y) (1+ x)))
            (write-cell new-value new-fg new-bg)))
        (incf index)))
    (setf (cursor) (cons height width))
    (force-output)))

;; External interface implementation

(defvar *text-area-current* nil)

(defvar *text-area-previous* nil)

(defun call-with-text-display (function)
  (disable-system-buffering)
  (disable-system-echoing)
  (setf (foreground) :white)
  (setf (background) :black)
  (erase)
  (let ((dims (dimensions)))
    (when (null dims)
      (error "Can't get screen dimensions."))
    (let ((*text-area-current* (make-text-area (cdr dims) (car dims)))
          (*text-area-previous* nil))
      (unwind-protect
           (funcall function)
        (setf (foreground) :default)
        (setf (background) :default)
        (erase)
        (setf (cursor) '(1 . 1))
        (enable-system-echoing)
        (enable-system-buffering)))))

(defmacro with-text-display (&body forms)
  "Set up a text display for the duration of evaluation of FORMS.

This macro evaluates FORMS after setting up the display for the
drawing of characters, and also tears down the display on exit.  If no
special care is taken to bind stream variables such as
*STANDARD-OUTPUT* to appropriate streams, then output to them may not
look as expected.  Instead, use DRAW-CHAR to output characters."
  `(call-with-text-display (lambda () ,@forms)))

(defun draw-char (x y char &optional foreground background)
  "Draw a character to the text display at column X, row Y.

The parameter CHAR should be either a character, or a character code
to be passed to CODE-CHAR.

If FOREGROUND or BACKGROUND are non-nil, they should be symbols
designating the foreground or background colors, respectively, for the
character."
  (text-area-set-cell *text-area-current* x y char foreground background))

(defun toggle-char (x y)
  "Exchange the foreground and background colors for the characters at
column X, row Y."
  (text-area-toggle-cell *text-area-current* x y))

(defun display-width ()
  "Return the number of columns in the text display."
  (text-area-width *text-area-current*))

(defun display-height ()
  "Return the number of rows in the text display."
  (text-area-height *text-area-current*))

(defun redisplay ()
  "Refresh the display.

Update the text display to reflect the changes made using operators
DRAW-CHAR and TOGGLE-CHAR."
  (text-area-render *text-area-current* *text-area-previous*)
  (when (null *text-area-previous*)
    (setf *text-area-previous* (text-area-copy *text-area-current*)))
  (text-area-replace *text-area-previous* *text-area-current*))