Controlling the terminal from Common Lisp (part 2)

Writing the example application

Time to write a new example application. Sit tight, we are writing a window manager! For the sake of being compatible with CLIM terminology we'll call it a frame manager. Each application will be represented by a frame defined by its bounding box and a rendering function.

(defclass frame-manager ()
  ((frames :initarg :frames :accessor frames :documentation "All frames")
   (active :initarg :active :accessor active :documentation "Active frame"))
  (:default-initargs :frames nil :active nil))

;;; Ha ha, totally not a clip.
(defclass frame (bbox)
  ((fn :initarg :fn :accessor fn))
  (:default-initargs :r1 1 :c1 1 :r2 24 :c2 80
                     :fn (constantly t)))

Displaying a frame involves calling the rendering function with clipping enabled, and showing decorations. Usually the cell width is smaller than its height, so drawing decorations as a vertical bar on one of the application sides makes more sense if we want to save some space. That's what we'll do. The active frame will be signified with a diffrent side bar color.

(defun render-application (fm frame)
  (with-clipping (*buffer* :r1 (r1 frame)
                           :c1 (c1 frame)
                           :r2 (r2 frame)
                           :c2 (c2 frame))
    (funcall (fn frame) frame)))

(defun render-decorations (fm frame)
  (declare (ignore fm))
  (loop with col = (1+ (c2 frame))
        for row from (1+ (r1 frame)) upto (1- (r2 frame))
        do (out (:row row :col col) " ")
        finally (out (:col col :row (r1 frame) :fgc #xff224400) "x")
                (out (:col col :row (r2 frame)) "/")))

(defun display-screen (fm)
  (dolist (frame (frames fm))
      (if (eq frame (active fm))
          (ctl (:bgc #x22224400) (:fgc #xffffff00))
          (ctl (:bgc #x11111100) (:fgc #xbbbbbb00)))
    (render-application fm frame)
    (render-decorations fm frame)))

Handling events is now a responsibility of a separate function. Current key actions:

C-Q : quit

C-R : update dimensions and redraw the console

C-N : change the active frame

C-U : call the user action

C-E : signal an error

The function start-display is slightly modified to behave better with errors.

(defun handle-event (fm event)
  (flet ((reset ()
           (ctl (:bgc #x22222200))
           (update-console-dimensions)
           (clear-terminal)))
    (cond ((keyp event #\Q :c)
           (cl-user::quit))
          ((keyp event #\R :c)
           (reset))
          ((keyp event #\N :c)
           (alexandria:if-let ((cur (active fm)))
             (let* ((fms (frames fm))
                    (pos (position cur fms))
                    (new (1+ pos)))
               (if (= new (length fms))
                   (setf (active fm) nil)
                   (setf (active fm) (elt fms new))))
             (setf (active fm) (first (frames fm)))))
          ((keyp event #\U :c)
           (ignore-errors (user-action)))
          ((keyp event #\E :c)
           (error "bam")))))

(defun start-display ()
  (loop
    (with-simple-restart (again "Start display again.")
      (ignore-errors (swank:create-server))
      (handler-case
          (with-console (:ios *terminal-io*)
            (show-screen))
        (error (sig) (error sig))))))

Define two application renderers so we have something to display. Note, that each renderer must know its frame position. In other words show-lambda as it is currently defined can't be moved as a frame. Noise demo is like a white noise, but in color.

(defun lambda-demo (frame)
  (declare (ignore frame))
  (flet ((ll (row col)
           (or (and (< (abs (- (+ col row) 26)) 2)
                    (<= col 20))
               (< (abs (- (+ (- 40 col) row) 26)) 2))))
    (with-clipping (*buffer* :fn #'ll :r1 2 :r2 11)
      (out (:row (1+ (random 12))
            :col (1+ (random 40))
            :bgc #x00000000
            :fgc #xbb000000)
           (alexandria:random-elt '("X" "O"))))
    (with-clipping (*buffer* :fn (lambda (row col)
                                   (or (= row 1)
                                       (= row 12)
                                       (funcall (complement #'ll) row col))))
      (out (:row (1+ (random 12))
            :col (1+ (random 40))
            :bgc #x00000000
            :fgc (alexandria:random-elt '(#x00444400 #x00444400 #x00664400)))
           (alexandria:random-elt '("+" "-"))))))

(defun noise-demo (frame)
  (loop for row from (r1 frame) upto (r2 frame)
        do (loop for col from (c1 frame) upto (c2 frame)
                 do (out (:row row
                          :col col
                          :bgc (alexandria:random-elt `(#x00000000 #x08080800))
                          :fgc (alexandria:random-elt `(#xffff8800 #x88ffff00)))
                         (alexandria:random-elt '("+" "-"))))))

(defun make-lambda-demo (&rest args &key r1 c1 r2 c2)
  (apply #'make-instance 'frame :fn #'lambda-demo args))

(defun make-noise-demo (&rest args &key r1 c1 r2 c2)
  (apply #'make-instance 'frame :fn #'noise-demo args))

The function show-screen starts a loop which is responsible for updating the screen. We are not calling sleep anymore because we'll measure performance. At the bottom we'll display a modeline printing whichever information we'll find useful.

(defun show-modeline ()
  (let ((row (rows *console*))
        (col (cols *console*)))
    (ctl (:bgc #xdddddd00)
         (:fgc #x22222200)
         (:clr row 1 row col))
    (out (:row row :col 1)
         (format nil "Rows: ~d, Cols: ~d" row col))))

(defun show-screen ()
  (loop with f1 = (make-lambda-demo :r2 12 :c2 40)
        with f2 = (make-noise-demo :r1 10 :c1 45 :r2 15 :c2 55)
        with fm = (make-instance 'frame-manager :frames (list f1 f2))
        do (loop for event = (read-input)
                 until (null event)
                 do (handle-event fm event))
        do (display-screen fm)
        do (show-modeline)))

It is easy to spot that the modeline flickers. This is because we first clear the whole line and then we draw on top of it. This is something that will be addressed soon.

Benchmarks and optimizations

To make meaningful optimizations, it is important to measure things. Otherwise we may spend hours and days on improving a loop performance when in fact we are bound by the I/O. We'll do some exploratory benchmarks, that is we'll create a metric and try to optimize it. The first thing coming to mind is FPS. Then, since we print onto the terminal, the number of characters written per frame. Finally, two compound metrics: an average number of writes per single terminal cell and the write velocity (total number of characters per second).

We'll display all in the modeline. Common Lisp has internal time, which has usually the unit equal to 1/1000s. This precision is not good enough. For instance if we draw 2000fps, the time difference will be less than the internal time unit. Instead we'll count the number of frames which we were able to render during one second. To measure the number of characters written we'll add a kludge to the function put : each write increases the counter. Escape sequences are also counted.

;; terminal.lisp
(defvar *counter* 0)
(defun put (&rest args)
  "Put raw string on a terminal"
  (let* ((str (format nil "~{~a~}" args))
         (len (length str)))
    (incf *counter* len)
    (princ str *terminal*))
  (finish-output *terminal*))

;; example.lisp
(let ((cycle-start (get-internal-real-time))
      (frame-count 0)
      (last-second 0))
  (defun get-fps ()
    (if (> (- (get-internal-real-time) cycle-start)
           internal-time-units-per-second)
        (setf cycle-start (get-internal-real-time)
              last-second frame-count
              frame-count 0)
        (incf frame-count))
    last-second))

(defun get-cpf ()
  (prog1 *counter*
    (setf *counter* 0)))

(defun show-modeline ()
  (let* ((row (rows *console*))
         (col (cols *console*))
         (cells (* row col))
         (fps (get-fps))
         (wch (get-cpf))
         (vel (* fps wch))
         (wpc (truncate wch cells))
         (str (format nil "Cells ~d (~d x ~d), FPS: ~d, WCH: ~d, WPC: ~d, VEL: ~d"
                      cells row col fps wch wpc vel))
         (rem (- col (length str)))
         (fil (if (plusp rem)
                  (make-string rem :initial-element #\space)
                  ""))
         (str (subseq (format nil "~a~a" str fil) 0 col)))
    (out (:row row :col 1) str)))

The current demos are not representative, because they do not fill all the cells in the terminal. For that we'll use a full screen noise demo and turn off the lambda demo. It fills the whole terminal except the last row where we display the modeline. To reduce the noise (ha ha!), we'll skip the window decorations and changing the output color.

(defun display-screen (fm)
  (dolist (frame (frames fm))
    ;; (if (eq frame (active fm))
    ;;     (ctl (:bgc #x22224400) (:fgc #xffffff00))
    ;;     (ctl (:bgc #x11111100) (:fgc #xbbbbbb00)))
    (render-application fm frame)
    ;; (render-decorations fm frame)
    ))

(defun ensure-demos (fm)
  (let* ((rows (1- (rows *console*)))
         (cols (cols *console*))
         (frames (frames fm))
         (frame (first frames)))
    (when (or (null frame)
              (not (null (rest frames)))
              (/= rows (r2 frame))
              (/= cols (c2 frame)))
      (setf (frames fm)
            (list (make-noise-demo :r2 rows :c2 cols))))))

(defun handle-event (fm event)
  #|...|#
  ((keyp event #\R :c)
   (reset)
   (setf (frames fm) nil)
   (ensure-demos fm))
  #|...|#)

(defun show-screen ()
  (loop with fm = (make-instance 'frame-manager)
        do (ensure-demos fm)
        do (loop for event = (read-input)
                 until (null event)
                 do (handle-event fm event))
        do (display-screen fm)
        do (show-modeline)))

You may need to type C-e and restart the display from a debugger to restart the show-screen loop. Now it looks more like it - FPS is crap and drops when we grow the terminal and update its dimensions with C-r . For the 25x80 terminal it is around 23fps with 125 writes per single cell and around 5M characters per second.

One obvious optimization is to call the function finish-output after each frame rendered, not after each sequence put on the terminal. We'll abstract flushing the buffer with a generic function flush-buffer which will be a part of the virtual buffer protocol. It will be accompanied with a new ctl operation called :fls .

(defgeneric flush-buffer (buffer &rest args))

(defmacro ctl (&rest operations)
  `(let ((buf *buffer*))
     ,@(loop for op in operations
             collect (destructuring-bind (name &rest args) op
                       (ecase name
                         (:fgc `(setf (fgc buf) ,@args))
                         (:bgc `(setf (bgc buf) ,@args))
                         (:row `(setf (row buf) ,@args))
                         (:col `(setf (col buf) ,@args))
                         (:clr `(clear-rectangle ,@args))
                         (:fls `(flush-buffer buf ,@args)))))))

(defmethod flush-buffer ((buffer buffer) &rest args)
  (declare (ignore buffer args))
  #|whoosh|#)

(defmethod flush-buffer ((buffer console) &rest args)
  (declare (ignore buffer args))
  (finish-output *terminal*))

We need to flush the buffer after each iteration of a display loop, otherwise we have no guarantees that anything will be displayed. Querying the terminal also requires flushing the output if we want to receive the response synchronously (like in the function get-cursor-position ).

;; terminal.lisp
(defvar *counter* 0)
(defun put (&rest args)
  "Put raw string on a terminal"
  (let* ((str (format nil "~{~a~}" args))
         (len (length str)))
    (incf *counter* len)
    (princ str *terminal*)))

;; console.lisp
(defun get-cursor-position ()
  (request-cursor-position)
  (finish-output *terminal*)
  (handler-case (loop (read-input))
    (cursor-position-report (c)
      (values (row c) (col c)))))

;;; example.lisp
(defun show-screen ()
  (loop with fm = (make-instance 'frame-manager)
        do (ensure-demos fm)
        do (loop for event = (read-input)
                 until (null event)
                 do (handle-event fm event))
        do (display-screen fm)
        do (show-modeline)
        do (ctl (:fls))))

This small change roughly doubles the performance, and that is very nice. For the 25x80 terminal it is around 53fps with 125 writes per single cell and around 13.5M characters per second.

Now let's examine the CPU and the I/O bounds. First recompile macros out and ctl to do nothing, compile-and-load the example.lisp file and refresh the display with C-r . After that, probe the fps from a repl.

(defmacro out ((&rest args) object))
(defmacro ctl (&rest operations))
;; compile-and-load example.lisp, C-r, (get-fps)

Now do the same with the following macro definitions:

(defmacro out ((&rest args))
  `(put "x"))

(defmacro ctl (&rest operations)
  `(let ((buf *buffer*))
     ,@(loop for op in operations
             collect (destructuring-bind (name &rest args) op
                       (case name
                         (:fls `(flush-buffer buf ,@args)))))))

;; compile-and-load example.lisp, C-r, (get-fps)

| row x col | cells | FPS (cpu) | FPS (i/o) | VEL (cpu) | VEL (i/o) |
|-----------|-------|-----------|-----------|-----------|-----------|
| 25 x 80   | 2000  | 194615    | 2683      | 389230000 | 5366000   |
| 50 x 80   | 4000  | 111795    | 1334      | 447180000 | 5336000   |
| 87 x 159  | 13833 | 38411     | 379       | 531339363 | 5242707   |
| 87 x 319  | 27753 | 20278     | 190       | 562775334 | 5273070   |

Based on the above benchmarks we are clearly bound by the I/O. Previous result from the "smoke" benchmark with velocity 13.5M char/s may be better because the used terminal emulator processes the escape sequences faster (changing the color doesn't require putting anything on the screen). The FPS (i/o) column gives us the best score we can possibly achieve (numbers may vary between software/hardware setups).

Restore macros out and ctl as they were and reload the file example.lisp . Let's take a closer look at the data:

| row x col | cells | FPS | WCH     | WPC | VEL      |
|-----------|-------|-----|---------|-----|----------|
| 25 x 80   | 2000  | 50  | 251330  | 125 | 12817830 |
| 50 x 80   | 4000  | 22  | 510880  | 127 | 11239360 |
| 87 x 159  | 13833 | 5   | 1790668 | 129 | 8953340  |
| 87 x 319  | 27753 | 2   | 3611308 | 130 | 7222616  |

Writing 100+ characters per cell seems pretty excessive. Reducing this number will be beneficial. Notice, that we do a little too much since we've added the function put-cell . The function sets the terminal cursor position and the cell colors, finally it writes the character. The macro out also sets the row, the column, the foreground and the background colors, and :after auxiliary methods configure the terminal. In other words for each character we:

out
put-cell
out

Recompile the following methods to do nothing and then remove them:

;; first compile, then remove
(defmethod (setf fgc) :after (rgba (instance console)))
(defmethod (setf bgc) :after (rgba (instance console)))
(defmethod (setf row) :after (row (instance console)))
(defmethod (setf col) :after (col (instance console)))

As expected, the number of writes per cell drops threefold. The WPC column is now constant (for a full screen applications which writes each cell) and amounts 40ch/cell. Fix the macro out so it doesn't change the slot in the console - it is not necessary anymore.

(defmacro out ((&key row col fgc bgc) object)
  `(let ((buf *buffer*)
         (str (princ-to-string ,object)))
     (assert (null (find #\newline str)))
     (let ((row (or ,row (row buf)))
           (col (or ,col (col buf)))
           (fgc (or ,fgc (fgc buf)))
           (bgc (or ,bgc (bgc buf))))
       (loop with row = row
             for col from col
             for ch across str
             do (put-cell buf row col ch fgc bgc)))))

We still do too much. Even when we draw consecutive cells we always set the cursor position. Same for colors. Even when there is no need to send the escape sequence we still do that. We'll maintain a cursor state (which will be separate from the "current" console colors). Ensuring that the terminal state is adeqate will be the responsibility of the function put-cell . Let's take one step at a time and move the logic from the macro out to the method put-cell .

(defmacro out ((&key row col fgc bgc) object)
  `(let ((buf *buffer*)
         (str (princ-to-string ,object)))
     (put-cell buf ,row ,col str ,fgc ,bgc)))

(defmethod put-cell ((buf console) row col str fgc bgc)
  (let ((row (or row (row buf)))
        (col (or col (col buf)))
        (fgc (or fgc (fgc buf)))
        (bgc (or bgc (bgc buf))))
    (loop for col from col
          for ch across (string str)
          when (inside-p buf row col)
            do (set-cursor-position row col)
               (set-foreground-color fgc)
               (set-background-color bgc)
               (put ch))))

The function put-cell now accepts strings. That is the optimization opportunity (our demo application won't benefit much from that because each character is drawn separately). Notice that now we do interpret the newline character. The way it is handled clearly indicates that the concept of a newline belongs to the text layout, not to the text itself.

We do not set the cursor position for each character anymore, so we need to increase the cursor position when the cursor is not inside the buffer. We use the function cursor-right for that.

(defmethod put-cell ((buf console) row col str fgc bgc)
  (let ((row (or row (row buf)))
        (col (or col (col buf)))
        (fgc (or fgc (fgc buf)))
        (bgc (or bgc (bgc buf))))
    (set-cursor-position row col)
    (set-foreground-color fgc)
    (set-background-color bgc)
    (loop for column from col
          for ch across str
          if (char= ch #\newline)
            do (incf row)
               (setf column col)
               (set-cursor-position row col)
          else
            do (if (inside-p buf row column)
                   (put ch)
                   (cursor-right)))))

Finally a separate cursor state. The function update-cursor-position is used to modify the cursor position without sending the escape sequence to the terminal. cursor-position and cursor-colors are used to query the terminal cursor state, and their setf counterparts modify that state (but only when it is required).

(defclass cursor ()
  ((cvp :initarg :cvp :accessor cvp :documentation "Cursor visible?")
   (row :initarg :row :accessor row :documentation "Cursor row")
   (col :initarg :col :accessor col :documentation "Cursor col")
   (fgc :initarg :fgc :accessor fgc :documentation "Foreground color")
   (bgc :initarg :bgc :accessor bgc :documentation "Background color"))
  (:default-initargs :cvp nil :fgc nil :bgc nil :row nil :col nil))

(defmethod initialize-instance :after
    ((instance cursor) &rest args &key fgc bgc row col cvp)
  (declare (ignore args))
  (set-cursor-visibility cvp)
  (set-cursor-position row col)
  (set-foreground-color fgc)
  (set-foreground-color bgc))

(defmethod (setf cvp) :before (cvp (cur cursor))
  (unless (eql cvp (cvp cur))
    (set-cursor-visibility cvp)))

(defmethod (setf row) :before (row (cur cursor))
  (unless (eql row (row cur))
    (set-cursor-position row (col cur))))

(defmethod (setf col) :before (col (cur cursor))
  (unless (eql col (col cur))
    (set-cursor-position (row cur) col)))

(defun update-cursor-position (cursor row col)
  (setf (slot-value cursor 'row) row
        (slot-value cursor 'col) col))

(defsetf cursor-position (cursor) (row col)
  `(let ((crow (row ,cursor))
         (ccol (col ,cursor)))
     (cond ((not (or (eql crow ,row)
                     (eql ccol ,col)))
            (set-cursor-position ,row ,col))
           ((not (eql crow ,row))
            (setf (row ,cursor) ,row))
           ((not (eql ccol ,col))
            (setf (col ,cursor) ,col)))
     (values ,row ,col)))

(defmethod (setf fgc) :before (fgc (cur cursor))
  (unless (eql fgc (fgc cur))
    (set-foreground-color fgc)))

(defmethod (setf bgc) :before (bgc (cur cursor))
  (unless (eql bgc (bgc cur))
    (set-background-color bgc)))

(defsetf cursor-colors (cursor) (fgc bgc)
  `(progn (setf (fgc ,cursor) ,fgc
                (bgc ,cursor) ,bgc)
          (values ,fgc ,bgc)))

Now we'll readjust the class console and its method put-cell to use the new class cursor :

(defclass console (buffer)
  ((ios :initarg :ios :accessor ios :documentation "Console I/O stream")
   (cur :initarg :cur :accessor cur :documentation "Drawing cursor")
   (ptr :initarg :ptr :accessor ptr :documentation "Pointer tracking")
   (fps :initarg :fps :accessor fps :documentation "Desired framerate")
   (hnd               :accessor hnd :documentation "Terminal handler"))
  (:default-initargs :ios (error "I/O stream must be specified.")
                     :fgc #xffa0a000
                     :bgc #x22222200
                     :row 1 :col 1
                     :ptr t :fps 10 :cvp nil))

(defmethod initialize-instance :after
    ((instance console) &rest args &key fgc bgc row col cvp ptr)
  (setf (hnd instance) (init-terminal))
  (set-mouse-tracking ptr)
  (setf (cur instance)
        (make-instance 'cursor :fgc fgc :bgc bgc :row row :col col :cvp cvp))
  (let ((*console* instance))
    (update-console-dimensions)))

;;; first compile, then remove
(defmethod (setf cvp) :after (cvp (instance console)))

(defmethod put-cell ((buf console) row col str fgc bgc)
  (let ((cur (cur buf))
        (row (or row (row buf)))
        (col (or col (col buf)))
        (fgc (or fgc (fgc buf)))
        (bgc (or bgc (bgc buf))))
    (setf (cursor-position cur) (values row col))
    (setf (cursor-colors   cur) (values fgc bgc))
    (loop with cols = (cols buf)
          with column = col
          for ch across str
          if (char= ch #\newline)
            do (incf row)
               (setf column col)
               (setf (cursor-position cur) (values row col))
          else
            do (if (inside-p buf row column)
                   (put ch)
                   (cursor-right))
               (if (= column cols)
                   (setf column col
                         row (1+ row)
                         (cursor-position cur) (values row col))
                   (incf column))
          finally
             (update-cursor-position cur row column))))

This change proves to be a major improvement over the previous abstraction when we draw to consecutive cells. We don't change the cursor state unless strictly necessary. After all these improvements it is time to look at the benchmark data:

| row x col | cells | FPS | WCH    | WPC | VEL      |
|-----------|-------|-----|--------|-----|----------|
| 25 x 80   | 2000  | 307 | 32000  | 16  | 10000000 |
| 50 x 80   | 4000  | 129 | 67000  | 16  | 8700000  |
| 87 x 159  | 13833 | 20  | 235000 | 16  | 4900000  |
| 87 x 319  | 27753 | 7   | 465000 | 16  | 2800000  |

Things have improved quite a lot. 16 characters per cell is due to a random color - it will be less favorable if the output cell will also be random (like in the lambda demo).

Rendering modes

Let's modify the noise demo to accept a sequence of colors from which the foreground color is picked randomly. The class frame will have one more slot named "ap" for the frame data.

(defclass frame (bbox)
  ((fn :initarg :fn :accessor fn)
   (ap :initarg :ap :accessor ap))
  (:default-initargs :r1 1 :c1 1 :r2 24 :c2 80 :ap nil
                     :fn (constantly t)))


(defun noise-demo (frame)
  (loop for row from (r1 frame) upto (r2 frame)
        do (loop for col from (c1 frame) upto (c2 frame)
                 do (out (:row row
                          :col col
                          :bgc (alexandria:random-elt `(#x00000000 #x08080800))
                          :fgc (alexandria:random-elt (ap frame)))
                         (alexandria:random-elt '("+" "-"))))))

(defun make-noise-demo (&rest args)
  (let ((frame (apply #'make-instance 'frame :fn #'noise-demo args)))
    (unless (ap frame)
      (setf (ap frame) '(#xffff8800 #x88ffff00)))
    frame))

Now let's bring back decorations and run a few demos:

(defun display-screen (fm)
  (ctl (:bgc #x33333300) (:fgc #xbbbbbb00))
  (dolist (frame (frames fm))
    (unless (eq frame (active fm))
      (render-decorations fm frame)
      (render-application fm frame)))
  (alexandria:when-let ((frame (active fm)))
    (ctl (:bgc #x33336600) (:fgc #xffffff00))
    (render-decorations fm frame)
    (render-application fm frame))
  (ctl (:bgc #x11111100) (:fgc #xbbbbbb00)))

(defun ensure-demos (fm)
  (unless (frames fm)
    (setf (frames fm)
          (list (make-noise-demo :r1 10 :c1 20 :r2 20 :c2 60 :ap '(#xff000000))
                (make-noise-demo :r1 15 :c1 40 :r2 25 :c2 80 :ap '(#x00ff0000))
                (make-lambda-demo :r1 1 :c1 1 :r2 12 :c2 40)))))

Uh oh, something interesting is happening. Despite a very high 950fps we can see a flicker! Not only that. The lambda demo, which is drawn last, and rightfully should be on top, is obscured by the red noise demo.

The flicker is because of how we draw things. We put each cell immedietely on the screen, so first we draw the first window, then on top of it the second window and then on top of it the third window. After that we repeat the process. This means that if we have two intersecting windows, then for part of the time it will have the content of the first window and for the rest of a time the content of the second one.

The issue with the lambda demo not being at the top is slightly different. In this demo we draw only one cell per frame, so only one cell may be drawn on top of the other window, and then the noise demo redraws a full window.

Another problem which is not visible is the performance penalty. If we are bound by the I/O, then drawing the same cell multiple times is very suboptimal. Ideally we'd modify each cell only once per frame.

We'll call the currently exhibited behavior a "direct rendering". Time to introduce a second mode, which we'll call an "indirect rendering". The idea is to buffer the data in an array and when we flush the virtual buffer in order to redraw the damaged parts of a terminal.

A direct rendering is useful in some applications, so we'll retain this functionality and allow switching rendering mode for each buffer with the ctl interface. Three modes will be defined: a direct rendering, an indirect rendering and a write-through rendering. The last one will combine the two: it will put the cell on the screen immedietely but it will also save its content in a buffer. We'll add three new functions to the virtual buffer protocol.

(defgeneric set-cell (buffer row col str fg bg))
(defgeneric rnd (buffer))
(defgeneric (setf rnd) (buffer mode)
  (:argument-precedence-order buffer mode))

The function set-cell is responsible for "doing the right thing", that is either putting the content directly on a screen or saving it in the internal array (or both). The accessor rnd is used to read and write the buffer rendering mode. The macro out calls now the function set-cell and the macro ctl has a new option :rnd .

(defmacro out ((&key row col fgc bgc) object)
  `(let ((buf *buffer*)
         (str (princ-to-string ,object)))
     (set-cell buf ,row ,col str ,fgc ,bgc)))

(defmacro ctl (&rest operations)
  `(let ((buf *buffer*))
     ,@(loop for op in operations
             collect (destructuring-bind (name &rest args) op
                       (ecase name
                         (:fgc `(setf (fgc buf) ,@args))
                         (:bgc `(setf (bgc buf) ,@args))
                         (:row `(setf (row buf) ,@args))
                         (:col `(setf (col buf) ,@args))
                         (:rnd `(setf (rnd buf) ,@args))
                         (:clr `(clear-rectangle ,@args))
                         (:fls `(flush-buffer buf ,@args)))))))

We'll optimize the rendering by tracking dirty cells. If the cell is not "dirty", then there is no need to put it on the terminal (that applies only to the indirect rendering mode). Cells will be stored in the array stored in a slot in the buffer, named data . We'll also add a slot for the rendering mode.

(defclass cell ()
  ((ch :initarg :ch :accessor ch)
   (fg :initarg :fg :accessor fg)
   (bg :initarg :bg :accessor bg)
   (dirty-p :initarg :dirty-p :accessor dirty-p))
  (:default-initargs :ch #\space
                     :fg (fgc *buffer*)
                     :bg (bgc *buffer*)
                     :dirty-p t))

(defclass buffer ()
  ((fgc :initarg :fgc :accessor fgc :documentation "Foregorund color")
   (bgc :initarg :bgc :accessor bgc :documentation "Background color")
   (row :initarg :row :accessor row :documentation "Current row")
   (col :initarg :col :accessor col :documentation "Current col")
   (rnd :initarg :rnd :accessor rnd :documentation "Rendering mode")
   (clip :initarg :clip :accessor clip :documentation "Clipping object")
   (data :initarg :data :accessor data :documentation "Data buffer")
   (rows :initarg :rows :accessor rows :documentation "Buffer number of rows")
   (cols :initarg :cols :accessor cols :documentation "Buffer number of cols"))
  (:default-initargs :fgc #xffa0a0
                     :bgc #x222222
                     :row 1
                     :col 1
                     :rnd :buf
                     :data (make-array (list 0 0) :adjustable t)
                     :clip (make-instance 'clip)))

Accessing the cell will be abstracted away with a function get-cell . The function translates the terminal index (starting from [1, 1]) to the array index. If the element is outside of the array, it will return a "dummy" cell, otherwise it will return the array element. Array elements are lazily initialized when accessed. Function will always return an object of the class cell .

(defmethod get-cell ((buf buffer) row col)
  (let ((data (data buf))
        (i0 (1- row))
        (i1 (1- col)))
    (if (array-in-bounds-p data i0 i1)
        (or (aref data i0 i1)
            (setf (aref data i0 i1) (make-instance 'cell)))
        (load-time-value
         (make-instance 'cell :ch #\space :fg #xffffff00 :bg #x00000000)))))

The array with data initially has dimensions (0 0) , so we need to update the array dimensions when the console dimensions change.

(defun update-console-dimensions ()
  (with-cursor-position ((expt 2 16) (expt 2 16))
    (multiple-value-bind (rows cols)
        (get-cursor-position)
      (setf (rows *console*) rows)
      (setf (cols *console*) cols)
      (setf (r2 (clip *console*)) rows)
      (setf (c2 (clip *console*)) cols)
      (adjust-array (data *console*)
                    (list rows cols)
                    :initial-element nil))))

Functions put-cell and set-cell both work on strings. To abstract the iteration away we'll introduce the macro iterate-cells . This operator is responsible for updating the row and the column variables when iterating over the string, so they indicate the correct cell. The operator "wraps", so that if we go beyond the last row, we'll start from the first row (similarily for columns).

(defmacro iterate-cells ((ch crow ccol wrap)
                         (buf row col str)
                         &body body)
  (alexandria:with-gensyms (cols rows)
    `(loop with ,rows = (rows ,buf)
           with ,cols = (cols ,buf)
           with ,crow = ,row
           with ,ccol = ,col
           with ,wrap = nil
           for ,ch across ,str
           do (progn ,@body)
              (setf ,wrap nil)
           if (eql ,ch #\newline)
             do (setf ,ccol 1
                      ,wrap t)
                (if (= ,crow ,rows)
                    (setf ,crow 1)
                    (incf ,crow 1))
           else
             do (if (= ,ccol ,cols)
                    (setf ,ccol 1
                          ,crow (1+ ,crow)
                          ,wrap t)
                    (incf ,ccol))
           finally (return (values ,crow ,ccol)))))

(defmethod put-cell ((buf console) row col str fgc bgc)
  (let ((cur (cur buf))
        (row (or row (row buf)))
        (col (or col (col buf)))
        (fgc (or fgc (fgc buf)))
        (bgc (or bgc (bgc buf))))
    (setf (cursor-position cur) (values row col))
    (setf (cursor-colors   cur) (values fgc bgc))
    (multiple-value-bind (final-row final-col)
        (iterate-cells (ch crow ccol wrap-p)
            (buf row col (string str))
          (when wrap-p
            (setf (cursor-position cur) (values crow ccol)))
          (if (inside-p buf crow ccol)
              (put ch)
              (cursor-right)))
      (update-cursor-position cur final-row final-col))))

Finally, the function set-cell will trace the cell state and modify its cached state. When a cell is dirty it means that it should be redrawn when flushing the buffer in the indirect rendering mode.

(defmethod set-cell ((buf buffer) row col str fgc bgc)
  (let ((rendering-mode (rnd buf))
        (row (or row (row buf)))
        (col (or col (col buf))))
    (when (member rendering-mode '(:buf :wrt))
     (iterate-cells (ch crow ccol wrap-p)
         (buf row col (string str))
       (when (inside-p buf crow ccol)
         (let* ((cell (get-cell buf crow ccol))
                (clean (and (not (dirty-p cell))
                            (eql ch (ch cell))
                            (eql fgc (fg cell))
                            (eql bgc (bg cell)))))
           (unless clean
             (setf (ch cell) ch
                   (fg cell) (or fgc (fgc buf))
                   (bg cell) (or bgc (bgc buf))))
           (setf (dirty-p cell)
                 (and (not clean)
                      (not (eq rendering-mode :wrt))))))))
    (when (member rendering-mode '(:dir :wrt))
      (put-cell buf row col str fgc bgc))))

When we change the console rendering mode to :buf we'll see nothing. The method flush-buffer should flush the array onto the terminal. A naive implementation looks like this:

(defmethod flush-buffer ((buffer console) &rest args)
  (declare (ignore args))
  (loop for row from 1 upto (rows buffer)
        do (loop for col from 1 upto (cols buffer)
                 for cell = (get-cell buffer row col)
                 do (put-cell buffer row col (ch cell) (fg cell) (bg cell))))
  (finish-output *terminal*))

However we may take the advantage of information about whether the cell is clean. Moreover, we know that cells are always consecutive unless we wrap over the right edge.

(defmethod flush-buffer ((buffer console) &rest args &key force)
  (declare (ignore args))
  (unless (eql (rnd buffer) :dir)
    (let* ((cursor (cur buffer))
           (last-fg (fgc cursor))
           (last-bg (bgc cursor))
           (gap 0))
      (set-cursor-position 1 1)
      (iterate-cells (cell crow ccol wrap-p)
          (buffer 1 1 (make-array (* (cols buffer)
                                     (rows buffer))
                                  :displaced-to (data buffer)))
        (when wrap-p
          (set-cursor-position crow ccol)
          (setf gap 0))
        (if (and cell (or force (dirty-p cell)))
            (let ((ch (ch cell))
                  (fg (fg cell))
                  (bg (bg cell)))
              (unless (= fg last-fg)
                (set-foreground-color fg)
                (setf last-fg fg))
              (unless (= bg last-bg)
                (set-background-color bg)
                (setf last-bg bg))
              (when (plusp gap)
                (cursor-right gap)
                (setf gap 0))
              (put ch)
              (setf (dirty-p cell) nil))
            (if force
                (put #\space)
                (incf gap))))
      (set-cursor-position (row cursor) (col cursor))
      (set-foreground-color (fgc cursor))
      (set-background-color (bgc cursor))))
  (finish-output *terminal*))

Surfaces

We have two problems with the lambda application: the demo can't be moved (because it starts drawing from the cell [1,1] ) and that it is obscured by a noise demo frame due to its infrequent writes. We'll now detach the notion of the application buffer and the console buffer. Our job would be much easier if we had conformally displaced arrays at our disposal - a multi-dimensional fill pointer and the displacement offset would allow us to map coordinates transparently. That said we can easily abstract all that away, because we do not expose naked arrays in the API.

To make the issue more apparent we'll move the lambda demo and make its window smaller than the actual output.

(defun ensure-demos (fm)
  (unless (frames fm)
    (setf (frames fm)
          (list (make-noise-demo :r1 8 :c1 25 :r2 20 :c2 60 :ap '(#x00ff0000))
                (make-lambda-demo :r1 5 :c1 20 :r2 16 :c2 45)))))

Each application will be rendered on a "surface", that is on a virtual buffer which is displaced onto the console. The internal buffer of a surface starts from coordinates [1,1] like the console, and then when we call the function put-cell , the coordinates are transformed, and the function set-cell is called on the console. The way surfaces are defined means that they may be stacked (that is the external buffer of a surface may be a virtual buffer which is another surface). Add a new file surface.lisp to the project.

(defclass surface (buffer bbox)
  ((sink :initarg :sink :accessor sink :documentation "Flush destination")))

(defmethod initialize-instance :after
    ((buf surface) &key data rows cols r1 c1 r2 c2)
  (destructuring-bind (d0 d1) (array-dimensions data)
    (unless rows
      (if (not (zerop d0))
          (setf rows d0)
          (setf rows (1+ (- r2 r1))))
      (setf (rows buf) rows))
    (unless cols
      (if (not (zerop d1))
          (setf cols d1)
          (setf cols (1+ (- c2 c1))))
      (setf (cols buf) cols)))
  (let ((clip (clip buf)))
    (setf (r2 clip) rows
          (c2 clip) cols))
  (adjust-array (data buf) (list rows cols) :initial-element nil))

(defmethod put-cell ((buf surface) row col ch fg bg)
  (let ((vrow (1- (+ (r1 buf) row)))
        (vcol (1- (+ (c1 buf) col))))
    (when (and (<= (r1 buf) vrow (r2 buf))
               (<= (c1 buf) vcol (c2 buf)))
      (set-cell (sink buf) vrow vcol ch fg bg))))

(defmethod flush-buffer ((buffer surface) &rest args &key force)
  (declare (ignore args))
  (unless (eq (rnd buffer) :dir)
    (loop for row from 1 upto (rows buffer)
          do (loop for col from 1 upto (cols buffer)
                   for cell = (get-cell buffer row col)
                   when (or force (dirty-p cell))
                     do (put-cell buffer row col (ch cell) (fg cell) (bg cell))
                        (setf (dirty-p cell) nil)))))

And we'll make the class frame inherit from the class surface :

(defclass frame (surface)
  ((fn :initarg :fn :accessor fn)
   (ap :initarg :ap :accessor ap))
  (:default-initargs :r1 1 :c1 1 :r2 24 :c2 80
                     :sink *buffer*
                     :fn (constantly t) :ap nil))

Now when we render the application, we render to its own buffer which we need to flush afterwards.

(defun render-application (fm frame)
  (declare (ignore fm))
  (with-buffer (frame)
    (funcall (fn frame) frame)
    (ctl (:fls))))

Finally both demos need to supply their number of rows, columns and they always render starting from the cell [1,1] . The function lambda-demo doesn't need changes, but the function noise-demo does, because it started drawing from the frame position offset. The size of the lambda demo is known, while for the noise demo it is inferred from the surface displacement.

(defun noise-demo (frame)
  (loop for row from 1 upto (rows frame)
        do (loop for col from 1 upto (cols frame)
                 do (out (:row row
                          :col col
                          :bgc (alexandria:random-elt `(#x00000000 #x08080800))
                          :fgc (alexandria:random-elt (ap frame)))
                         (alexandria:random-elt '("+" "-"))))))

(defun make-lambda-demo (&rest args)
  (apply #'make-instance 'frame :fn #'lambda-demo :rows 12 :cols 40
         args))

(defun make-noise-demo (&rest args)
  (let ((frame (apply #'make-instance 'frame :fn #'noise-demo args)))
    (unless (ap frame)
      (setf (ap frame) '(#xffff8800 #x88ffff00)))
    (setf (rows frame) (1+ (- (r2 frame) (r1 frame)))
          (cols frame) (1+ (- (c2 frame) (c1 frame))))
    frame))

The lambda sign is now properly offset, but the noise demo is still overexposed.

We may easily address that by forcing all cells to be flushed. Later on we'll tackle this problem from a different angle.

(defun render-application (fm frame)
  (declare (ignore fm))
  (with-buffer (frame)
    (funcall (fn frame) frame)
    (ctl (:fls :force t))))

The last missing functionality is the scrolling. The lambda demo does not fit in its window. We'll introduce two slots in the class surface which will represent the offset for the top-left corner of the buffer. For instance when the offset row is 3, then the third row of the buffer will be shown as the first row in the window. We only need to modify the function put-cell to account for that.

(defclass surface (buffer bbox)
  ((sink :initarg :sink :accessor sink :documentation "Flush destination")
   (row0 :initarg :row0 :accessor row0 :documentation "Scroll row offset")
   (col0 :initarg :col0 :accessor col0 :documentation "Scroll col offset"))
  (:default-initargs :row0 0 :col0 0))

(defmethod put-cell ((buf surface) row col ch fg bg)
  (let ((vrow (- (+ (r1 buf) row) (row0 buf) 1))
        (vcol (- (+ (c1 buf) col) (col0 buf) 1)))
    (when (and (<= (r1 buf) vrow (r2 buf))
               (<= (c1 buf) vcol (c2 buf)))
      (set-cell (sink buf) vrow vcol ch fg bg))))

(defun scroll-buffer (buf row-dx col-dx)
  (unless (typep buf 'surface)
    (return-from scroll-buffer))
  (incf (row0 buf) row-dx)
  (incf (col0 buf) col-dx))

(defun move-buffer (buf row-dx col-dx)
  (unless (typep buf 'surface)
    (return-from move-buffer))
  (incf (r1 buf) row-dx)
  (incf (r2 buf) row-dx)
  (incf (c1 buf) col-dx)
  (incf (c2 buf) col-dx))

This is something to be used by API clients, so operations mov and scr are added to the ctl macro:

(defmacro ctl (&rest operations)
  `(let ((buf *buffer*))
     (declare (ignorable buf))
     ,@(loop for op in operations
             collect (destructuring-bind (name &rest args) op
                       (ecase name
                         (:fgc `(setf (fgc buf) ,@args))
                         (:bgc `(setf (bgc buf) ,@args))
                         (:row `(setf (row buf) ,@args))
                         (:col `(setf (col buf) ,@args))
                         (:rnd `(setf (rnd buf) ,@args))
                         (:mov `(move-buffer ,@args))
                         (:scr `(scroll-buffer ,@args))
                         (:clr `(clear-rectangle ,@args))
                         (:fls `(flush-buffer buf ,@args)))))))

We'll now add new key bindings in the function handle-event to scroll and move the window. This way we'll gain some intuition of how it should work. When rendering decorations we'll use the character #\& to indicate that some output is not visible. To avoid glitches we'll also clear the whole screen in the function display-screen and clear the window background in render-decorations .

(defun render-decorations (fm frame)
  (declare (ignore fm))
  (let ((r1 (r1 frame))
        (c1 (c1 frame))
        (r2 (r2 frame))
        (c2 (c2 frame)))
    (ctl (:clr r1 c1 r2 c2))
    (loop with col = (1+ c2)
          for row from (1+ r1) upto (1- r2)
          do (out (:row row :col col) " ")
          finally (out (:col col :row r1 :fgc #xff224400) "x")
                  (when (or (> (rows frame) (1+ (- r2 r1)))
                            (> (cols frame) (1+ (- c2 c1))))
                    (out (:col col :row (1- r2)) "&"))
                  (out (:col col :row r2) "/"))))

(defun display-screen (fm)
  (ctl (:clr 1 1 (rows *console*) (cols *console*))
       (:bgc #x33333300) (:fgc #xbbbbbb00))
  (dolist (frame (frames fm))
    (unless (eq frame (active fm))
      (render-decorations fm frame)
      (render-application fm frame)))
  (alexandria:when-let ((frame (active fm)))
    (ctl (:bgc #x33336600) (:fgc #xffffff00))
    (render-decorations fm frame)
    (render-application fm frame))
  (ctl (:bgc #x11111100) (:fgc #xbbbbbb00)))

(defun handle-event (fm event)
  (flet ((reset ()
           (update-console-dimensions)
           (clear-terminal)
           (ctl (:bgc #x22222200)
                (:clr 1 1 (rows *console*) (cols *console*)))))
    (cond ((keyp event #\Q :c)
           (cl-user::quit))
          ((keyp event #\R :c)
           (reset)
           (setf (frames fm) nil)
           (setf (active fm) nil)
           (ensure-demos fm))
          ((keyp event :f5)
           (ctl (:fls :force t)))
          ((keyp event #\N :c)
           (alexandria:if-let ((cur (active fm)))
             (let* ((fms (frames fm))
                    (pos (position cur fms))
                    (new (1+ pos)))
               (if (= new (length fms))
                   (setf (active fm) nil)
                   (setf (active fm) (elt fms new))))
             (setf (active fm) (first (frames fm)))))
          ((keyp event #\U :c)
           (ignore-errors (user-action)))
          ((keyp event #\E :c)
           (error "bam"))
          ((keyp event :key-up)
           (alexandria:when-let ((frame (active fm)))
             (ctl (:scr frame -1 0))))
          ((keyp event :key-left)
           (alexandria:when-let ((frame (active fm)))
             (ctl (:scr frame 0 -1))))
          ((keyp event :key-down)
           (alexandria:when-let ((frame (active fm)))
             (ctl (:scr frame 1 0))))
          ((keyp event :key-right)
           (alexandria:when-let ((frame (active fm)))
             (ctl (:scr frame 0 1))))
          ((keyp event :key-up :c)
           (alexandria:when-let ((frame (active fm)))
             (ctl (:mov frame -1 0))))
          ((keyp event :key-down :c)
           (alexandria:when-let ((frame (active fm)))
             (ctl (:mov frame 1 0))))
          ((keyp event :key-left :c)
           (alexandria:when-let ((frame (active fm)))
             (ctl (:mov frame 0 -1))))
          ((keyp event :key-right :c)
           (alexandria:when-let ((frame (active fm)))
             (ctl (:mov frame 0 1)))))))

As a reminder, we change the active window with C-n . Scrolling is done with arrows, and moving the window is done with C-arrow .

While experimenting with the window, you may notice some inconsistency: scrolling moves the content in the opposite direction than moving the window (if we use the same arrow key). This discrepancy may be described with an analogy of a cursor: when you scroll right, you move an invisible cursor beyond the right edge, so the content is moved left to reveal what is under the "cursor". The alternative strategy, where pressing "right" moves the content to the right, could be described in terms of a touchscreen: you hold part of the screen and move it to the right, so the content moves along your finger. To signify a difference we'll talk about the "cursor scrolling" and the "finger scrolling".

The last step is to ensure that we don't scroll too much. The content scrolling should stop if we reach the maximum. What is considered the maximum depends on whether the window is bigger or smaller than the buffer. Consider two cases when cursor-scrolling down:

the window is smaller than the content : the scrolling stops when the bottom side of a buffer reaches the bottom side of a window

the window is bigger than the content : the scrolling stops when the top side of a buffer reaches the top side of a window

Let's add two lambda demos to illustrate the difference:

(defun ensure-demos (fm)
  (unless (frames fm)
    (setf (frames fm)
          (list (make-lambda-demo :r1 2 :c1 4 :r2 6 :c2 43)
                (make-lambda-demo :r1 9 :c1 4 :r2 23 :c2 43)))))

Functions move-to-row and move-to-col take the absolute argument, and if scrolling the window violates the constraint, it returns nil . In that case we move a maximum quantity in the scroll direction (so when we for instance cursor-scroll 1000 to the left and the line has only 100 characters, we'll end at the line beginning).

(defun move-to-row (buf row0)
  (let* ((rows (rows buf))
         (height (1+ (- (r2 buf) (r1 buf))))
         (vrow1 (- 1    row0))
         (vrow2 (- rows row0)))
    (when (if (> height rows)
              (and (<= 1 vrow1 height)
                   (<= 1 vrow2 height))
              (and (<= vrow1 1)
                   (>= vrow2 height)))
      (setf (row0 buf) row0))))

(defun move-to-col (buf col0)
  (let* ((cols (cols buf))
         (width (1+ (- (c2 buf) (c1 buf))))
         (vcol1 (- 1    col0))
         (vcol2 (- cols col0)))
    (when (if (> width cols)
              (and (<= 1 vcol1 width)
                   (<= 1 vcol2 width))
              (and (<= vcol1 1)
                   (>= vcol2 width)))
      (setf (col0 buf) col0))))

(defun scroll-buffer (buf row-dx col-dx)
  (unless (typep buf 'surface)
    (return-from scroll-buffer))
  (flet ((quantity (screen-size buffer-size dx)
           (if (alexandria:xor (> screen-size buffer-size)
                               (minusp dx))
               0
               (- buffer-size screen-size))))
    (unless (zerop row-dx)
      (let ((height (1+ (- (r2 buf) (r1 buf)))))
        (or (move-to-row buf (+ (row0 buf) row-dx))
            (setf (row0 buf)
                  (quantity height (rows buf) row-dx)))))
    (unless (zerop col-dx)
      (let ((width (1+ (- (c2 buf) (c1 buf)))))
        (or (move-to-col buf (+ (col0 buf) col-dx))
            (setf (col0 buf)
                  (quantity width (cols buf) col-dx)))))))

Multiple surfaces may be attached to the same virtual buffer data array. It is a matter of specifying the correct initargs. We'll add a hack because our frame manager currently assumes that the surface is a frame and thus has a method fn returning the display function.

(defun ensure-demos (fm)
  (unless (frames fm)
    (let* ((lambda-demo (make-lambda-demo :r1 5 :c1 20 :r2 16 :c2 45))
           (2nd-surface (make-instance 'surface
                                       :data (data lambda-demo)
                                       :sink *buffer*
                                       :rows 12 :cols 40
                                       :r1 20 :c1 20 :r2 30 :c2 45)))
      (setf (frames fm)
            (list (make-noise-demo :r1 8 :c1 25 :r2 20 :c2 60 :ap '(#x00ff0000))
                  lambda-demo
                  2nd-surface)))))

(defmethod fn (object)
  (constantly t))

Retained display mode

Let's introduce a few more examples to have more specimen we could talk about. The animation demo shows a square which bounces from the left to the right edge, and the report demo shows lines of the text.

(defun ensure-demos (fm)
  (unless (frames fm)
    (setf (frames fm)
          (list (make-lambda-demo    :r1 2  :c1 4  :r2 13 :c2 43)
                (make-noise-demo     :r1 2  :c1 50 :r2 13 :c2 77)
                (make-animation-demo :r1 5  :c1 10 :r2 11 :c2 70)
                (make-report-demo    :r1 15 :c1 10 :r2 20 :c2 70 :rows 50)))))

(defclass animation-frame (frame)
  ((sqr-speed :initarg :sqr-speed :reader sqr-speed)
   (direction :initarg :direction :accessor direction)
   (last-time :initarg :last-time :accessor last-time)
   (current-row :accessor current-row)
   (current-col :accessor current-col)
   (minimum-col :accessor minimum-col)
   (maximum-col :accessor maximum-col))
  (:default-initargs :sqr-speed 5
                     :direction 1
                     :last-time (get-internal-real-time)))

(defmethod initialize-instance :after
    ((frame animation-frame) &rest args)
  (let ((rows (rows frame))
        (cols (cols frame)))
   (setf (current-row frame) (1+ (truncate rows 2))
         (current-col frame) (1+ (truncate cols 2))
         (minimum-col frame) (+ 1    2)
         (maximum-col frame) (- cols 2))))

(defun animation-demo (frame)
  (let* ((rows (rows frame))
         (cols (cols frame))
         (speed (sqr-speed frame))
         (now (get-internal-real-time))
         (delta (/ (- now (last-time frame))
                   internal-time-units-per-second))
         (direction (direction frame))
         (current-col (current-col frame))
         (minimum-col (minimum-col frame))
         (maximum-col (maximum-col frame)))
    ;; Set colors and clear the window background.
    (ctl (:bgc #x44440000)
         (:fgc #xffbb0000)
         (:clr 1 1 rows cols))
    ;; Advance the square.
    (incf current-col (* delta speed direction))
    ;; Draw the rectangle.
    (loop with row = (current-row frame)
          with col = (alexandria:clamp (round current-col)
                                       minimum-col
                                       maximum-col)
          for r from (- row 1) upto (+ row 1)
          do (loop for c from (- col 2) upto (+ col 2)
                   do (out (:row r :col c
                            ;:bgc #xffffff00
                            :fgc #xff00ff00) "#")))
    ;; Update variables
    (setf (current-col frame) current-col
          (direction frame) (cond ((< current-col minimum-col) +1)
                                  ((> current-col maximum-col) -1)
                                  (t direction))
          (last-time frame) now)))

(defun make-animation-demo (&rest args)
  (apply #'make-instance 'animation-frame :fn 'animation-demo args))

(defun make-report-demo (&rest args)
  (flet ((reporter (frame)
           (let ((str "I'd like to report an event here!")
                 (rows (rows frame)))
             (ctl (:bgc #x00000000))
             (clear-rectangle 1 1 rows (cols frame))
             (loop for row from 1 upto rows
                   for id from 0
                   for string = (format nil "XXX ~d/~d: ~a" id (1- rows) str)
                   do (out (:row row :col 1 :fgc #xff888800) string)))))
    (apply #'make-instance 'frame :fn #'reporter args)))

When we look at these demos we can recognize that each one uses the buffer differently. The old demos "lambda" and "noise" output change synchronously when a new frame is drawn. The new demos change based on the asynchronous events - for the "animation" demo that is a time slice, for the "report" demo it is (hypothetically) a buffer contents change.

| demo      | display     | change source |
|-----------|-------------|---------------|
| lambda    | incremental | synchronous   |
| noise     | full redraw | synchronous   |
| animation | incremental | asynchronous  |
| report    | full redraw | asynchronous  |

With our rendering modes we can model each behavior, however the frame manager demo exhibits only one: synchronous full redraw. This option is correct for each demo, but it is suboptimal. We'll call it an immediate display, as opposed to a retained display where the buffer is not constantly filled with a new content.

A difference between the display and the repaint is not apparent. In terms of our buffers it could be explained like this:

:buf

The immediate rendering mode coalasces both concepts into one, so it could be described as drawing on the buffer in the :dir mode, or redisplaing it before each repaint.

In the retained rendering mode, the separation of these concepts is important. Displaying the content once may save some time (i.e in the report demo we don't need to reprint the same buffer over and over again for each render).

Moreover, at this point we may talk about display lists, that is lists of objects which have their own repaint methods. In CLIM a display list is called the output-record-history , and an element of said list are called the output-record . Compound output records may contain more (inner) output records, so objects in such display list form a tree with z-ordering.

We'll explore the topic of retained display and display lists further in another post which will introduce yet another layer of abstraction.

Conclusions

I hope you've liked this post as much as I've enjoyed working on it. It has grown considerably longer than I had anticipated, so I've decided to postpone the discussion of display lists and damage regions for a later time. The next post in this series will cover the input processing.

I'd like to thank Robert Strandh for offering the help and proofreading this text. All remaining mistakes are mine. Please don't hesitate to contact me with questions and remarks.

If you like this kind of work, you may toss a coin to your Lisper by making adonation.

• ← Previous