Charming CLIM tutorial part 2 – Rethinking The Output
Tagged as lisp, foss, console, clim
Written on 2020-06-19 by Daniel 'jackdaniel' Kochmański
This is the second part of a tutorial about building a McCLIM backend for the terminal starting from zero. After reading the first issue we should have a good grasp of how to control and read input from the terminal. It is time to refine things for efficiency and ease of use. If you didn't follow the last part, here is the archive with the source code which will serve as a starter for this post.
Right now our I/O is synchronous with the terminal. When we call out
or ctl, the characters are sent to it immediately, and we read the
input with read-input until the stream is empty. The model
introduced in the previous post is certainly simple, but simple models
tend to be hard to use efficiently. We'll settle on easy instead.
In this post I'll focus on the output.
Layered abstraction
All problems in computer science can be solved by another level of indirection. -- David Wheeler
We'll build a convenient abstraction for writing the console applications. It would be a shame, though, if we had abandoned means to manipulate the terminal directly. The library will present different APIs, so it is possible to cater to the programmer needs. In principle it is not feasible to use two different abstractions simultaneously because higher abstractions build upon lower ones and things may go awry.
... except for the problem of too many layers of indirection. -- Unknown
For now we'll define two packages: eu.turtleware.charming-clim/l0
and eu.turtleware.charming-clim.terminal/l1 with different levels of
abstraction for accessing the terminal. They are meant only as means
to export symbols, all implementation is done in a single package.
This practice greatly improves a quality of life of the person who
works with Common Lisp packages. Now create a file packages.lisp.
(defpackage #:eu.turtleware.charming-clim/l0
(:export #:init-terminal
#:close-terminal
#:*terminal*
#:put #:esc #:csi #:sgr
#:read-input #:keyp
#:reset-terminal
#:clear-terminal
#:clear-line
#:set-foreground-color
#:set-background-color
#:with-cursor-position
#:set-cursor-position
#:save-cursor-position
#:restore-cursor-position
#:request-cursor-position
#:cursor-up
#:cursor-down
#:cursor-right
#:cursor-left
#:set-cursor-visibility
#:set-mouse-tracking))
(defpackage #:eu.turtleware.charming-clim/l1
(:export #:with-console #:out #:ctl))
(defpackage #:eu.turtleware.charming-clim
(:use #:common-lisp
#:eu.turtleware.charming-clim/l0
#:eu.turtleware.charming-clim/l1))We'll take this opportunity to make function naming more consistent and introduce the cursor manipulation utilities. Rename functions
(setf cursor-visibility)->set-cursor-visibility(setf mouse-tracking)->set-mouse-tracking(setf alt-is-meta)->set-alt-is-meta
and add escape sequences for manipulating the cursor. Don't forget to
change references to renamed functions in other parts of the code (in
the macro ctl and in functions initialize-instance, (setf ptr)
and (setf cvp).
(macrolet ((moveit (endch)
`(if (= n 1)
(csi ,endch)
(csi n ,endch))))
(defun cursor-up (&optional (n 1)) (moveit "A"))
(defun cursor-down (&optional (n 1)) (moveit "B"))
(defun cursor-right (&optional (n 1)) (moveit "C"))
(defun cursor-left (&optional (n 1)) (moveit "D")))
(defun set-cursor-visibility (visiblep)
(if visiblep
(csi "?" 2 5 "h")
(csi "?" 2 5 "l")))
;;; (csi ? tracking ; encoding h/l)
;;; tracking: 1000 - normal, 1002 - button, 1003 - all motion
;;; 1004 - focus in/out
;;; encoding: 1006 - sgr encoding scheme
(defun set-mouse-tracking (enabledp)
(if enabledp
(csi "?" 1003 ";" 1006 "h")
(csi "?" 1003 "l")))
(defun set-alt-is-meta (bool)
(if bool
(setf +alt-mod+ +meta-mod+)
(setf +alt-mod+ +alt-mod*+)))From now on, when we talk about the low level abstraction, we'll call the destination object a "terminal", while when we talk about the high level abstraction, we'll call its destination object a "console". Rename the following symbols
*console-io*->*terminal*init-console->init-terminalclose-console->close-terminalclear-console->clear-terminalreset-console->reset-terminal
and replace all references in the source code to use new symbols. Move
the variable *terminal* and functions init-terminal and
close-terminal to the top (below the foreign function definitions).
We'll slightly refactor set-*-color functions. Instead of accepting
each color separately, functions will consume the number representing
a color RGBA value. For instance #ff000000 for a color red. The alpha
channel will be ignored for now, but having this component will save
us another change of a data representation format.
(defun set-foreground-color (color)
(let ((r (ldb (byte 8 24) color))
(g (ldb (byte 8 16) color))
(b (ldb (byte 8 8) color))
(a (ldb (byte 8 0) color)))
(declare (ignore a))
(sgr "38;2;" r ";" g ";" b)))
(defun set-background-color (color)
(let ((r (ldb (byte 8 24) color))
(g (ldb (byte 8 16) color))
(b (ldb (byte 8 8) color))
(a (ldb (byte 8 0) color)))
(declare (ignore a))
(sgr "48;2;" r ";" g ";" b)))and fix all references in the source code:
(defmacro ctl (&rest operations)
`(#|...|#
(:fgc `(setf (fgc *console*) ,@args))
(:bgc `(setf (bgc *console*) ,@args))))
(defclass console ()
#|...|#
(:default-initargs :fgc #xffa0a000 :bgc #x22222200))
(defmethod initialize-instance :after
((instance console) &key fgc bgc pos cvp ptr)
#|...|#
(set-foreground-color fgc)
(set-background-color bgc))
(defmethod (setf fgc) :after (rgba (instance console))
(set-foreground-color rgba))
(defmethod (setf bgc) :after (rgba (instance console))
(set-background-color rgba))
(defun show-screen ()
#|...|#
(out (:bgc #x00000000 :fgc #xbb000000))
(out (:bgc #x00000000
:fgc (alexandria:random-elt '(#x00444400 #x00444400 #x00664400)))))
We'll now move parts related to the console to a separate file
console.lisp in this order:
- the variable
*console*and the macrowith-console - clipping code (the clip variables and operators
insideandwith-clipping) - macros
letf,outandctl - functions
clear-rectangle,get-cursor-positionandupdate-console-dimensions - the class
consoleand its methods
Finally, the example code will be put in a file example.lisp. Move
functions show-screen and start-display there.
The defsystem form in the file eu.turtleware.charming-clim.asd now
looks like this:
(defsystem "eu.turtleware.charming-clim"
:defsystem-depends-on (#:cffi)
:depends-on (#:alexandria #:cffi #:swank)
:components ((:cfile "raw-mode")
(:file "packages")
(:file "terminal" :depends-on ("packages"))
(:file "console" :depends-on ("packages" "terminal"))
(:file "example" :depends-on ("packages" "console"))))Virtual buffers
The console object has many responsibilities, so refactoring it to
inherit from a class which implements only parts related to the output
makes sense. That will also be useful when we decide to add yet
another layer of indirection. When implementing the buffer class
we'll also fix an unfortunate position representation as a cons, and
the clip area specification. Create a file output.lisp and add it to
the asd file.
(defsystem "eu.turtleware.charming-clim"
:defsystem-depends-on (#:cffi)
:depends-on (#:alexandria #:cffi #:swank)
:components ((:cfile "raw-mode")
(:file "packages")
(:file "terminal" :depends-on ("packages"))
(:file "output" :depends-on ("packages"))
(:file "console" :depends-on ("packages" "output" "terminal"))
(:file "example" :depends-on ("packages" "console"))))Macros out and ctl will operate on the current virtual buffer. In
order to do that, we'll define a protocol which must be implemented by
all virtual buffers. with-clipping now becomes a convenience macro
expanding to a generic function invoke-with-clipping. A macro
with-buffer is introduced to bind the current buffer, which is bound
to the variable *buffer*.
(defgeneric put-cell (buffer row col ch fg bg))
(defgeneric fgc (buffer))
(defgeneric (setf fgc) (fgc buffer)
(:argument-precedence-order buffer fgc))
(defgeneric bgc (buffer))
(defgeneric (setf bgc) (bgc buffer)
(:argument-precedence-order buffer bgc))
(defgeneric row (buffer))
(defgeneric (setf row) (row buffer)
(:argument-precedence-order buffer row))
(defgeneric col (buffer))
(defgeneric (setf col) (col buffer)
(:argument-precedence-order buffer col))
(defgeneric rows (buffer))
(defgeneric cols (buffer))
(defgeneric inside-p (buffer row col))
(defgeneric invoke-with-clipping (buffer continuation
&rest opts
&key r1 c1 r2 c2 fn))
(defmacro with-clipping ((buffer &rest opts) &body body)
(let ((fn (gensym)))
`(flet ((,fn () ,@body))
(declare (dynamic-extent (function ,fn)))
(invoke-with-clipping ,buffer (function ,fn) ,@opts))))
(defvar *buffer*)
(defmacro with-buffer ((object) &body body)
`(let ((*buffer* ,object)) ,@body))Implementing the ctl and out macros in these terms follows. We'll
leave out the :cvp and :ptr options from the ctl macro for a
time being. letf and clear-rectangle are left unchanged. Remove
old macros from the console.lisp file.
(defmacro letf (bindings &body body)
(loop for (place value) in bindings
for old-val = (gensym)
collect `(,old-val ,place) into saves
collect `(setf ,place ,value) into store
collect `(setf ,place ,old-val) into restore
finally (return `(let (,@saves)
(unwind-protect (progn ,@store ,@body)
,@restore)))))
(defmacro out ((&key row col fgc bgc) object)
`(let ((buf *buffer*)
(str (princ-to-string ,object)))
(assert (null (find #\newline str)))
(letf (((row buf) (or ,row (row buf)))
((col buf) (or ,col (col buf)))
((fgc buf) (or ,fgc (fgc buf)))
((bgc buf) (or ,bgc (bgc buf))))
(loop with row = (row buf)
for col from (col buf)
for ch across str
with bgc = (bgc buf)
with fgc = (fgc buf)
do (put-cell buf row col ch fgc bgc)))))
(defmacro ctl (&rest operations)
`(let ((buf *buffer*))
,@(loop for op in operations
collect (destructuring-bind (name &rest args) op
(ecase name
(:clr `(clear-rectangle ,@args))
(:fgc `(setf (fgc buf) ,@args))
(:bgc `(setf (bgc buf) ,@args))
(:row `(setf (row buf) ,@args))
(:col `(setf (col buf) ,@args)))))))
(defun clear-rectangle (r1 c1 r2 c2)
(loop with str = (make-string (1+ (- c2 c1)) :initial-element #\space)
for r from r1 upto r2
do (out (:row r :col c1) str)))What would a protocol be without the implementation? Clipping will be
implemented with the class clip. This choice is transparent, because
all functions are specialized on the buffer. Each buffer has its own
clipping region. Virtual buffers don't know how to draw on a screen,
so put-cell prints a warning.
(defclass bbox ()
((r1 :initarg :r1 :accessor r1)
(c1 :initarg :c1 :accessor c1)
(r2 :initarg :r2 :accessor r2)
(c2 :initarg :c2 :accessor c2)))
(defclass clip (bbox)
((fn :initarg :fn :accessor fn))
(:default-initargs :r1 1 :c1 1 :r2 24 :c2 80
:fn (constantly t)))
(defclass buffer ()
((fgc :initarg :fgc :accessor fgc :documentation "Foreground 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")
(clip :initarg :clip :accessor clip :documentation "Clipping object")
(rows :initarg :rows :accessor rows :documentation "Buffer number of rows")
(cols :initarg :cols :accessor cols :documentation "Buffer number of cols"))
(:default-initargs :clip (make-instance 'clip)))
(defmethod put-cell ((buffer buffer) row col ch fg bg)
(warn "put-cell: default method does nothing!"))
(defmethod inside-p ((buffer buffer) row col)
(let ((clip (clip buffer)))
(and (<= (r1 clip) row (r2 clip))
(<= (c1 clip) col (c2 clip))
(funcall (fn clip) row col))))
(defmethod invoke-with-clipping ((buffer buffer) cont &key r1 c1 r2 c2 fn)
(let ((clip (clip buffer)))
(let ((old-r1 (r1 clip))
(old-c1 (c1 clip))
(old-r2 (r2 clip))
(old-c2 (c2 clip))
(old-fn (fn clip)))
(setf (r1 clip) (max (or r1 old-r1) old-r1)
(c1 clip) (max (or c1 old-c1) old-c1)
(r2 clip) (min (or r2 old-r2) old-r2)
(c2 clip) (min (or c2 old-c2) old-c2)
(fn clip) (if (null fn)
old-fn
(lambda (row col)
(and (funcall fn row col)
(funcall old-fn row col)))))
(unwind-protect (funcall cont)
(setf (r1 clip) old-r1
(c1 clip) old-c1
(r2 clip) old-r2
(c2 clip) old-c2
(fn clip) old-fn)))))Finally, we can modify the console class itself. The macro
with-console binds a buffer separately, so we may access to both the
output buffer and the console at the same time.
(defmacro with-console ((&rest args
&key ios fgc bgc cvp fps &allow-other-keys)
&body body)
(declare (ignore fgc bgc cvp fps))
`(let* ((*terminal* ,ios)
(*console* (make-instance 'console ,@args)))
(unwind-protect (with-buffer (*console*) ,@body)
(close-terminal (hnd *console*)))))Updating the console dimensions now involves modifying upper bounds of the clipping region.
(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))))And the class console itself is remodeled to inherit from the class
buffer. Notice that we get rid of the slots pos and app.
(defclass console (buffer)
((ios :initarg :ios :accessor ios :documentation "Console I/O stream.")
(cvp :initarg :cvp :accessor cvp :documentation "Cursor visibility.")
(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
:cvp nil :ptr t :fps 10))
(defmethod initialize-instance :after
((instance console) &key fgc bgc row col cvp ptr)
(setf (hnd instance) (init-terminal))
(set-foreground-color fgc)
(set-background-color bgc)
(set-cursor-position row col)
(set-cursor-visibility cvp)
(set-mouse-tracking ptr)
(let ((*console* instance))
(update-console-dimensions)))
(defmethod (setf fgc) :after (rgba (instance console))
(set-foreground-color rgba))
(defmethod (setf bgc) :after (rgba (instance console))
(set-background-color rgba))
(defmethod (setf row) :after (row (instance console))
(set-cursor-position row nil))
(defmethod (setf col) :after (col (instance console))
(set-cursor-position nil col))
(defmethod (setf ptr) :after (ptr (instance console))
(set-mouse-tracking (not (null ptr))))
(defmethod (setf cvp) :after (cvp (instance console))
(set-cursor-visibility (not (null cvp))))Putting a cell on the screen is a matter of first setting the cursor
position and cell colors, and then calling the function put. It is
the responsibility of the function put-cell to verify, that the cell
is inside a clipping region.
(defmethod put-cell ((buffer console) row col ch fg bg)
(when (inside-p buffer row col)
(set-cursor-position row col)
(set-foreground-color fg)
(set-background-color bg)
(put ch)))Finally we need to account for a change in the with-clipping macro
to pass a buffer as the first argument and remove references to the
app accessor. Modify the function show-screen:
(defun show-screen ()
(loop for ch = (read-input)
until (null ch)
do (cond ((keyp ch #\Q :c)
(cl-user::quit))
((keyp ch #\U :c)
(ignore-errors (user-action)))))
(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 '("+" "-"))))))All these changes were pretty invasive, so make sure to restart the image and try running the application once more to ensure, that everything still works.
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:
- set the cursor position and colors in
out - set the cursor position and colors in
put-cell - restore the cursor position and colors in
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 immediately 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
immediately 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:
- displaying - drawing on the buffer in the
:bufmode - repainting - flushing the buffer
The immediate rendering mode coalasces both concepts into one, so it
could be described as drawing on the buffer in the :dir mode, or
redisplaying 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 a donation.