Planet Lisp

Alexander Artemenkobourbaki

· 17 hours ago

This is the system for verifying formal mathematical proofs. As I didn't use math since the high school and lack time to dive into the lengthy documentation :(

Here is the code snippet from the example:

;; Declare the wff type
(symkind "WFF")

;; The implication symbol
(prim wff "->" (wff ![x y]))

;; the axioms
(ax "ax1" (wff ![A B])
  (ass [-> A -> B A]))
(ax "ax2" (wff ![A B C])
  (ass [-> -> A -> B C -> -> A B -> A C]))

;; the rule of inference (modus ponens)
(ax "ax-mp" (wff ![A B])
  (hypo [A] [-> A B])
  (ass [B]))

;; theorem: identity law for '->'
;; compare with id1 in set.mm
(th "id" (wff "A")
  (ass [-> A A])
  (proof
    [ax1 A [-> A A]]
    [ax2 A [-> A A] A]
    [ax-mp [-> A -> -> A A A]
           [-> -> A -> A A -> A A]]
    [ax1 A A]
    [ax-mp [-> A -> A A] [-> A A]]))

If you eval it in the REPL, then you can verify it and output some information:

BOURBAKI-USER> (print-theorem !id)
Theorem id:
Variables: A
Distinct variable conditions: 
Hypotheses: 
Assertion: [-> A A]
Proof:
ax1 [A][-> A A]
ax2 [A][-> A A][A]
ax-mp [-> A -> -> A A A][-> -> A -> A A -> A A]
ax1 [A][A]
ax-mp [-> A -> A A][-> A A]

BOURBAKI-USER> (show-proof !id)
Proof for id:
ax1 => [-> A -> -> A A A]
ax2 => [-> -> A -> -> A A A -> -> A -> A A -> A A]
ax-mp => [-> -> A -> A A -> A A]
ax1 => [-> A -> A A]
ax-mp => [-> A A]

BOURBAKI-USER> (verify !id)
Theorem: "ax1"
Theorem: "ax2"
Theorem: "ax-mp"
Theorem: "id"
T

Bourbaki has a very good documentation. If you are interested in math libraries and don't know how to spend this weekend - enjoy it:

https://www.quicklisp.org/beta/UNOFFICIAL/docs/bourbaki/doc/bourbaki-3.7.pdf

Alexander Artemenkocl-tui

· 39 hours ago

This system is an experimental user interface library for the console. It uses cl-charms under the hood, to call ncurses. The library is not in Quicklisp yet but is installable from https://ultralisp.org

It contains a few examples. I've modified one to implement a simple chat-like interface:

┌──Online──────────┐
│Bob               │
│Alice             │
│Peter             │
│Lisper 313373     │23:08:46 Enter some text.
│                  │23:08:46 Esc to quit
│                  │23:08:52 Hello Lisp World!
│                  │23:09:05 This is a simple chat using
│                  │23:09:16 cl-tui and charms.
└──────────────────┘> Input box

cl-tui allows defining frames which can be stacked together. And you can write text inside the frame. Hope, there will be more primitives for other GUI elements like buttons text inputs, forms etc.

Here are pieces of the example. First, I defined a "roster" and a function to render it inside a frame. This function also draws a border around:

(defvar *roster* '("Bob"
                   "Alice"
                   "Peter"
                   "Lisper 313373"))

(defun draw-roster (&key frame)
  (draw-box frame)
  (put-text frame 0 3 "Online")
  
  (loop for name in *roster*
        for row upfrom 1
        do (put-text frame row 1 name)))

Next part is the code defining the application's layout. It is constructed from nested frames of different types. There is a frame for our roster, a frame to display chat log and to get user's input:

(define-frame main (container-frame :split-type :horizontal) :on :root)

(define-frame roster (simple-frame :render #'draw-roster) :on main :w 20)

(define-frame chat (container-frame :split-type :vertical) :on main)

(define-frame log (log-frame) :on chat)

;; Edit-frame implements a single-line text editor.
;; It will misbehave if its height is not 1.
(define-frame input (edit-frame :prompt "> ") :on chat :h 1)

We also need two functions to add users input into the chat window and to process keystrokes:

(defun finish-input ()
  ;; Get text from edit-frame
  (let ((text (get-text 'input)))
    ;; Append it to the log-frame
    (append-line 'log text)
    ;; And clear the text in edit-frame
    (clear-text 'input)))


(defun start ()
  (with-screen ()
    (append-line 'log "Enter some text.")
    (append-line 'log "Esc to quit")
    (loop
      (refresh)
      (let ((key (read-key)))
        (case key
          ;; Esc and Newline are handled here
          (#\Esc (return))
          (#\Newline (finish-input))
          (:key-up (cl-tui:scroll-log 'log 1))
          (:key-down (cl-tui:scroll-log 'log -1))
          ;; Everything else is sent to the edit-frame.
          (t (handle-key 'input key)))))))

That is all the app.

Checkout the repository. There you'll find more examples!

For those, who are interested in using ncurses, here are reviews of the two lower-level libraries:

Alexander Artemenkoclack-pretend

· 2 days ago

This is the last middleware in our Clack/Lack series. What does it do? It helps during website development remembering last requests you did from the browser and allowing to replay them from the REPL.

Clack-pretend interposes itself into a Lack middlewares chain. To define the app you need to use a special builder macro and to specify at which point requests and responses should be captured:

POFTHEDAY> (defparameter *app*
             (clack-pretend:pretend-builder (:insert 2)
               :accesslog
               :session
               (lambda (env)
                 (let* ((path (getf env :path-info))
                        (query (getf env :query-string))
                        (message (format nil "Path: ~A, query: ~A"
                                         path query)))
                   (format t "Processing request:~%  ~A~%"
                           message)
                   '(200 (:content-type "text/plain")
                     ("Hello world!"))))))
*APP*
POFTHEDAY> (defparameter *server*
             (clack:clackup *app*
                            :port 8000))
Hunchentoot server is started.
Listening on 127.0.0.1:8000.

Now I'll make a request using curl:

[poftheday] curl -v 'http://localhost:8000/some/route?foo=Bar'
> GET /some/route?foo=Bar HTTP/1.1
> Host: localhost:8000
> User-Agent: curl/7.54.0
> Accept: */*
> 
< HTTP/1.1 200 OK
< Date: Wed, 01 Jul 2020 19:23:12 GMT
< Server: Hunchentoot 1.2.38
< Transfer-Encoding: chunked
< Content-Type: text/plain
< Set-Cookie: lack.session=0d629e3a1d2681d99c40f7b2086ec97d53e2b884; path=/; expires=Sat, 31 Dec 2140 14:45:27 GMT

And we can look up what was the last request:

POFTHEDAY> (clack-pretend:last-input)
(:LACK.SESSION.OPTIONS
 (:ID "0d629e3a1d2681d99c40f7b2086ec97d53e2b884"
  :NEW-SESSION T :CHANGE-ID NIL :EXPIRE NIL)
 :LACK.SESSION #<HASH-TABLE :TEST EQUAL :COUNT 0 {1005EB8A03}>
 :REQUEST-METHOD :GET
 :SCRIPT-NAME ""
 :PATH-INFO "/some/route"
 :SERVER-NAME "localhost"
 :SERVER-PORT 8000
 :SERVER-PROTOCOL :HTTP/1.1
 :REQUEST-URI "/some/route?foo=Bar"
 :URL-SCHEME "http"
 :REMOTE-ADDR "127.0.0.1"
 :REMOTE-PORT 53671
 :QUERY-STRING "foo=Bar"
 :RAW-BODY #<FLEXI-STREAMS:FLEXI-IO-STREAM {1005EB6FD3}>
 :CONTENT-LENGTH NIL
 :CONTENT-TYPE NIL
 :CLACK.STREAMING T
 :CLACK.IO #<CLACK.HANDLER.HUNCHENTOOT::CLIENT {1005EB7043}>
 :HEADERS #<HASH-TABLE :TEST EQUAL :COUNT 3 {1005EB72C3}>
 :QUERY-PARAMETERS (("foo" . "Bar")))

POFTHEDAY> (rutils:hash-table-to-alist
            (getf * :headers))
(("host" . "localhost:8000")
 ("user-agent" . "curl/7.54.0")
 ("accept" . "*/*"))

Now it is time to replay the request from the REPL:

POFTHEDAY> (clack-pretend:run-pretend)
Processing request:
  Path: /some/route, query: foo=Bar
(200 (:CONTENT-TYPE "text/plain") ("Hello world!"))

;; You can override path to check, it with the same
;; headers and session:
POFTHEDAY> (clack-pretend:run-pretend
            :path-info "/other/path")
Processing request:
  Path: /other/path, query: foo=Bar
(200 (:CONTENT-TYPE "text/plain") ("Hello world!"))

Seems, clack-pretend is a great addition for web development with Clack.

It will be interesting to improve it to store not only the last N successful requests but also to store requests resulting unhandled error. This way you'll be able to replay errors your users experience in production!

Alexander Artemenkoclack-static-asset-middleware

· 3 days ago

This middleware in some sense like a builtin lack-middleware-static, reviewed last week.

The difference is that this middleware is more suitable for production because implements an infinite cache TTL for static assets.

An infinite cache TTL trick is useful when you want to speed up your website loading. Here is how it works.

Your server returns Cache-Control HTTP header and set static files TTL to some large value like a year to make it cached for a long long period of time.

But how to expire this cache if you will need to update CSS or JavaScript on your site?

The only way is to change the URL. This is what lack-middleware-static does for you. It calculates MD5 hash from the file's content and makes it a part of the URL.

When the content of the static file is changed, its URL changed as well. Browser notices that change and reloads the content.

Middleware provides a special tag for Djula template language. Setting up templates for djula is out of thescope of this post and we'll use busted-uri-for-path instead, to create a path to a file including a cache hash.

First, we need to start our server and configure the middleware. Pay attention to the probe-file call. Root should be an absolute pathname. With relative pathname, you'll get a wrong result :(

POFTHEDAY> (clack:clackup
            (funcall
             clack-static-asset-middleware:*clack-static-asset-middleware*
             (lambda (env)
               (list 200 (list :content-type "text/plain")
                     (list (format nil
                                   "Access this file: ~A"
                                   (clack-static-asset-middleware:busted-uri-for-path

                                    "site.css")))))
             :path "static/"
             :root (probe-file "static-files/"))
            :port 9004)
Hunchentoot server is started.
Listening on 127.0.0.1:9004.

Now we can access our index page to get the static's URL:

POFTHEDAY> (dex:get "http://localhost:9004/")
"Access this file: /static/site_ebb4fccbf8e0590b0fcf44c3748af88d.css"
200

Pay attention to the file's suffix. It is an md5 hash from file's content. This sum is calculated when you start the application. If you'll change the file, during the next deploy another md5 hash will be generated and browser will reload its content.

If we'll access this file, the server will respond with Cache-Control header and set the TTL to 1 year:

POFTHEDAY> (dex:get "http://localhost:9004/static/site_ebb4fccbf8e0590b0fcf44c3748af88d.css")
"body {font-size: 10px;}"
200 (8 bits, #xC8, #o310, #b11001000)
#<HASH-TABLE :TEST EQUAL :COUNT 8 {1001E58473}>
#<QURI.URI.HTTP:URI-HTTP http://localhost:9004/static/site_ebb4fccbf8e0590b0fcf44c3748af88d.css>
#<SB-SYS:FD-STREAM for "socket 127.0.0.1:53729, peer: 127.0.0.1:9004" {1001E37873}>

POFTHEDAY> (rutils:hash-table-to-alist #v56:2)
(("date" . "Tue, 30 Jun 2020 19:39:55 GMT")
 ("server" . "Hunchentoot 1.3.0")
 ("accept-ranges" . "bytes")
 ("last-modified" . "Tue, 30 Jun 2020 19:15:56 GMT")
 ("vary" . "Accept-Encoding")
 ("cache-control" . "public, max-age=31556926")
 ("content-length" . "23")
 ("content-type" . "text/css; charset=utf-8"))

Tomorrow we'll review the last Clack's middleware. I found only 3 of them on the Quicklisp. If you know about other middlewares, let me know and we'll continue our journey to the world of web development with Clack!

Alexander Artemenkoclack-errors

· 4 days ago

This is the Clack middleware which adds a nicely rendered error page for your website. It pretends to be a clone of the RoR's better_errors library but has only a limited number of features.

Clack-errors is able to show a backtrace and content of the env variable. But it does not allow you to inspect the variables of stack frames and does not show HTTP headers.

It has a demo application which can be loaded as :clack-errors-demo ASDF system.

If you'll do a (clack-errors-demo:start) it will start a webserver on the 8000 port.

Access the http://localhost:8001/error URL to see the page like this:

You can customize the behaviour of the middleware by two options: :debug and :prod-render. :debug is t by default and if you set it to the nil, middleware will not show backtrace. It will call :prod-render function instead.

Also, you might override some internal variables like +dev-template+, *dev-css-path*, etc. But it is better to send a pull-request which will allow redefining dev renderer.

Personally, I'm don't see the need in such middleware in the Common Lisp web application, because you have much better backtrace inspection tool in the SLIME or other IDE.

Alexander Artemenkolack-middleware-csrf

· 5 days ago

This lack middleware provides some level of security for your webapp, preventing a CSRF attacks. It has a function csrf-html-tag which returns a hidden input element to embed into a form.

The input stores a special token. Middleware saves this token into the current session and ensures the user sends this token in the following requests. If he doesn't, a 400 status code will be returned.

Let's take our yesterday's app and make it more secure!

First, we need to rewrite our main application to make it render a login form with CSRF token. Pay attention to how does it call a csrf-html-tag function at the end.

If you are going to develop an application with a lots of forms, then it is good idea to define a macro which will apply CSRF protection automatically.

POFTHEDAY> (defun main (env)
             (let* ((session (getf env :lack.session))
                    (login (gethash :login session)))
               (cond
                 (login
                  (list 200 (list :content-type "text/plain")
                        (list (format nil "Welcome, ~A!"
                                      login))))
                 (t
                  (list 200 (list :content-type "text/plain")
                        (list (format nil "
<form method=\"POST\" action=\"/login\">
  <input type=\"text\" name=\"login\"></input>
  <input type=\"password\" name=\"password\"></input>
  ~A
</form>
"
                          (lack.middleware.csrf:csrf-html-tag session))))))))

All other apps remain the same, we only need to build the whole app including the csrf middleware.

This middleware should go after the :session middleware, because it depends on it:

POFTHEDAY> (clack:clackup
            (lack:builder
             :session
             :csrf
             (:mount "/login" 'login)
             (:mount "/logout" 'logout)
             'main)
            :port 8091)
Hunchentoot server is started.
Listening on 127.0.0.1:8091.

This is how our form is rendered. Note a "hidden" input at the end of the form:

POFTHEDAY> (dex:get "http://localhost:8091/")
"
<form method=\"POST\" action=\"/login\">
  <input type=\"text\" name=\"login\"></input>
  <input type=\"password\" name=\"password\"></input>
  <input type=\"hidden\" name=\"_csrf_token\" value=\"8de1c8a47\">
</form>

If we try to do a POST request without the token, we'll receive a 400 error:

POFTHEDAY> (handler-case
               (dex:post "http://localhost:8091/login"
                         :content '(("login" . "bob")
                                    ("password" . "$ecret"))
                         :headers '((:cookie . "lack.session=75bccc")))
             (dexador:http-request-failed (c)
               (values (dexador:response-status c)
                       (dexador:response-body c))))
400
"Bad Request: invalid CSRF token"

Using the code we'll be able to log in:

POFTHEDAY> (dex:post "http://localhost:8091/login"
                     :content '(("login" . "bob")
                                ("password" . "$ecret")
                                ("_csrf_token" . "8de1c8a47"))
                     :headers '((:cookie . "lack.session=75bccc")))
"Dear Bob, you welcome!"
200

The middleware also has a few settings.

You can set :session-key to a value other than _csrf_token. But this changes only a token's key inside the session. Form field's name remains the _csrf_token.

Other option is :one-time. Set it to true if you want to remove a token from the session after the first successful POST, PUT, DELETE or PATCH.

And finally, you can define your own handler for the error page and pass it as ":block-app". It should be a usual Clack app.

Alexander Artemenkolack-middleware-session

· 6 days ago

This middleware makes your app stateful and allows to associate some information with the current user.

There are two abstractions behind Lack sessions - state and store.

State object defines how to keep track of a session. Lack includes only one type of state class. It keeps state id in the browser's cookies.

Store object defines where to store data, associated with a state. There are three store classes in the Lack. The default stores data in memory, using a hash table. There are also dbi and redis stores.

Now let's create an app that allows a user to login in and logout.

First, we need an app for logging it checks the password as we did in yesterday's post on basic auth. If the password is correct, we'll put a user's login into a session's hash:

POFTHEDAY> (defun login (env)
             (let* ((params (getf env :body-parameters))
                    (login (alexandria:assoc-value
                            params
                            "login" :test #'string=))
                    (password (alexandria:assoc-value
                               params
                               "password" :test #'string=))
                    (session (getf env
                                   :lack.session)))
               (cond
                 ((and (string= login
                                "bob")
                       (string= password
                                "$ecret"))
                  (setf (gethash :login
                                 session)
                        login)
                  '(200 (:content-type "text/plain")
                    ("Dear Bob, you welcome!")))
                 (t
                  '(200 (:content-type "text/plain")
                    ("Wrong password!"))))))

Also, we need a function to logout. It set's a special flag to let middleware know that all session data should be wiped from the store:

POFTHEDAY> (defun logout (env)
             (setf (getf (getf env :lack.session.options)
                         :expire)
                   t)
             '(200 (:content-type "text/plain")
               ("Now you are logged our")))

The main app will use data from the session and will show a welcome message if the user is authenticated:

POFTHEDAY> (defun main (env)
             (let* ((session (getf env :lack.session))
                    (login (gethash :login session)))
               (cond
                 (login
                  (list 200 (list :content-type "text/plain")
                        (list (format nil "Welcome, ~A!"
                                      login))))
                 (t
                  '(403 (:content-type "text/plain")
                        ("Access denied"))))))

And finally, we need to combine these apps using mount middleware (it was reviewed a few days ago) and slap the session middleware on it:

POFTHEDAY> (clack:clackup
            (lack:builder
             :session
             (:mount "/login" 'login)
             (:mount "/logout" 'logout)
             'main)
            :port 8089)
Hunchentoot server is started.
Listening on 127.0.0.1:8089.

Now let's try to log in:

POFTHEDAY> (values (dex:get "http://localhost:8090/"))
"Access denied"

POFTHEDAY> (multiple-value-bind (response code headers)
               (dex:post "http://localhost:8090/login"
                         :content '(("login" . "bob")
                                    ("password" . "$ecret")))
             (values response code
                     (rutils:hash-table-to-alist headers)))
"Dear Bob, you welcome!"
200
(("date" . "Sat, 27 Jun 2020 20:47:13 GMT")
 ("server" . "Hunchentoot 1.2.38")
 ("transfer-encoding" . "chunked")
 ("content-type" . "text/plain")
 ("set-cookie"
  "lack.session=b10c66; path=/; expires=Fri, 23 Dec 2140 17:24:51 GMT"))

The server returned the "set-cookie" header. Usually, the browser will pass this cookie content during the following requests. We'll emulate this behavior to make a request to the main app:

POFTHEDAY> (let ((headers '((:cookie . "lack.session=b10c66"))))
             (values (dex:get "http://localhost:8090/"
                              :headers headers)))
"Welcome, bob!"

And finally, we'll check how does log out will work:

POFTHEDAY> (let ((headers '((:cookie . "lack.session=b10c66"))))
             (values (dex:post "http://localhost:8090/logout"
                               :headers headers)))
"Now you are logged out"

POFTHEDAY> (let ((headers '((:cookie . "lack.session=b10c66"))))
             (dex:get "http://localhost:8090/"
                              :headers headers))
"Access denied"

See!? We've built a simple web application using Lack micro-framework! Add something like Spinneret to render HTML and Lass + Parenscript to render CSS and JS and we'll have a full-fledged webapp!

Alexander Artemenkolack-middleware-auth-basic

· 7 days ago

This Lack middleware is also undocumented, but it is short enough to understand from sources how to configure it.

When configuring this middleware, you should pass it a function which accepts username and password and returns a t if the password is correct. Also, this function may return a user object as a second value. Returned user or original username from the HTTP header will be added to the environment plist as :remote-user.

Here is an example:

POFTHEDAY> (defparameter *app*
             (lambda (env)
               (list 200 '(:content-type "text/plain")
                     (list (format nil
                                   "Hello ~A!"
                                   (getf env :remote-user))))))

POFTHEDAY> (defun auth (user pass)
             (when (and (string= user "bob")
                        (string= pass "$ecret"))
               (values t
                       "Bob The Admin")))

POFTHEDAY> (clack:clackup
            (lack:builder
             (:auth-basic :authenticator #'auth)
             *app*)
            :port 8080)
Hunchentoot server is started.
Listening on 127.0.0.1:8080.

POFTHEDAY> (handler-case (dex:get "http://localhost:8080/foo/bar")
             (error (condition)
               (values (dex:response-status condition)
                       (dex:response-body condition))))
401 (9 bits, #x191)
"Authorization required"

POFTHEDAY> (dex:get "http://localhost:8080/foo/bar"
                    :basic-auth '("bob" . "$ecret"))
"Hello Bob The Admin!"
200

That is it. Very simple, isn't it?

But please, don't hardcode passwords in the sources as I did :)

Alexander Artemenkolack-middleware-static

· 8 days ago

This middleware can be used to serve files from a directory. However, I don't recommend using it for production because it should be inefficient because a few lambdas are created on each request.

The middleware should be parametrized with two arguments: path and root.

The path is a prefix from the URL. The root is the root directory on the local filesystem. For example, if root is /tmp/files/ and path is /static/ then for URL http://my-site.com/static/some/file.txt Lack will return content of the /tmp/files/some/file.txt.

Here is a small example, showing how does it work:

POFTHEDAY> (defparameter *app*
             (lambda (env)
               '(200 (:content-type "text/plain")
                 ("A main app's response"))))

POFTHEDAY> (clack:clackup
            (lack:builder
             (:static
              ;; This is a path of URL
              ;; to serve static files
              :path "/static/"
              ;; from this directory
              ;; on the filesystem
              :root #P"./static-files/")
             *app*)
            :port 8082)
Hunchentoot server is started.
Listening on 127.0.0.1:8082.

POFTHEDAY> (values (dex:get "http://localhost:8082/static/the-file.txt"))
"My static file"

POFTHEDAY> (values (dex:get "http://localhost:8082/static/missing.txt"))
; Debugger entered on #<DEXADOR.ERROR:HTTP-REQUEST-NOT-FOUND {100B944133}>

POFTHEDAY> (values (dex:get "http://localhost:8082/other/path"))
"A main app's response"

Also, you can pass a function as a path argument. This way some sort of filtering may be done. The function should return another path and you probably will need to remove a prefix from it.

For example, if we want to serve only a css files from the static-files directory:

POFTHEDAY> (alexandria:write-string-into-file
            "Some secret README"
            #P"static-files/README.txt")

POFTHEDAY> (alexandria:write-string-into-file
            "Just CSS file"
            #P"static-files/the.css")

POFTHEDAY> (clack:clackup
            (lack:builder
             (:static
              ;; This is a function to filter filename
              ;; of the served static files:
              :path (lambda (original-path)
                      ;; When this function returns nil,
                      ;; the request is passed to the main application.
                      (when (and (str:ends-with-p ".css"
                                                  original-path)
                                 (str:starts-with-p "/static/"
                                                    original-path))
                        ;; you need to rewrite the path manually:
                        (subseq original-path 7)))
              ;; from this directory
              ;; on the filesystem
              :root #P"./static-files/")
             *app*)
            :port 8085)
Hunchentoot server is started.
Listening on 127.0.0.1:8085.

POFTHEDAY> (dex:get "http://localhost:8085/static/the.css")
"Just CSS file"

POFTHEDAY> (dex:get "http://localhost:8085/static/README.txt")
"A main app's response"

There is no any way to return 404 or 403 error in this case. This should be done on the main app's level.

That is it for today. Tomorrow we'll how to protect your app with basic auth!

Alexander Artemenkolack-middleware-mount

· 9 days ago

We continue to review Lack's middlewares and this one gives you the ability to route requests to different apps depending on the path.

Here is a quick example. We want to plug a blog and admin into our main app:

POFTHEDAY> (defparameter *main-app*
             (lambda (env)
               (list 200 '(:content-type "text/plain")
                     (list (format nil "~A~%This is main app!"
                                   (getf env :path-info))))))

POFTHEDAY> (defparameter *blog*
             (lambda (env)
               (list 200 '(:content-type "text/plain")
                     (list (format nil "~A~%The Blog."
                                   (getf env :path-info))))))

POFTHEDAY> (defparameter *admin*
             (lambda (env)
               (list 200 '(:content-type "text/plain")
                     (list (format nil "~A~%Administration interface."
                                   (getf env :path-info))))))

POFTHEDAY> (clack:clackup
            (lack:builder
             (:mount "/blog" *blog*)
             (:mount "/admin" *admin*)
             *main-app*)
            :port 8044)
Hunchentoot server is started.
Listening on 127.0.0.1:8044.

POFTHEDAY> (dex:get "http://localhost:8044/some/page")
"/some/page
This is main app!"

POFTHEDAY> (dex:get "http://localhost:8044/blog/post-1")
"/post-1
The Blog."

POFTHEDAY> (dex:get "http://localhost:8044/admin/blog/posts?id=1")
"/blog/posts
Administration interface."

Pay attention to paths, returned as the first line of each response. It is relative to the mount point. This middleware rewrites the path so that an app can be mounted with any prefix.

That is it for today. Tomorrow we'll see how we can serve static with Lack.

Alexander Artemenkolack-middleware-backtrace

· 10 days ago

You might consider this a cheating, but I really want to review all Lack middlewares regardless most of them are from the same Lack project. These middlewares are loadable as separate ASDF systems.

The problem of Lack middlewares is that they are not documented.

This middleware will output a backtrace and all request parameters to the stream or a file.

If you are using clack:clackup function to start your app, it will apply a backtrace middleware to it, unless :use-default-middlewares nil argument was given. Without configuration, all backtraces will be written to *error-output* stream.

Let's see how does it work!

POFTHEDAY> (defparameter *app*
             (lambda (env)
               (declare (ignorable env))
               (error "Oh my God!")))
*APP*
POFTHEDAY> (clack:clackup *app*
                          :port 8085)
Hunchentoot server is started.
Listening on 127.0.0.1:8085.

POFTHEDAY> (values (dex:get "http://localhost:8085/foo/bar"))
Backtrace for: #<SB-THREAD:THREAD "hunchentoot-worker-127.0.0.1:56469" RUNNING {1007707373}>
0: ((LAMBDA NIL :IN UIOP/IMAGE:PRINT-BACKTRACE))
1: ((FLET "THUNK" :IN UIOP/STREAM:CALL-WITH-SAFE-IO-SYNTAX))
2: (SB-IMPL::%WITH-STANDARD-IO-SYNTAX #<CLOSURE (FLET "THUNK" :IN UIOP/STREAM:CALL-WITH-SAFE-IO-SYNTAX) {D85A24B}>)
3: (UIOP/STREAM:CALL-WITH-SAFE-IO-SYNTAX #<CLOSURE (LAMBDA NIL :IN UIOP/IMAGE:PRINT-BACKTRACE) {100791B9EB}> :PACKAGE :CL)
4: (UIOP/IMAGE:PRINT-CONDITION-BACKTRACE #<SIMPLE-ERROR "Oh my God!" {100791B943}> :STREAM #<SYNONYM-STREAM :SYMBOL SLYNK::*CURRENT-ERROR-OUTPUT* {1001541093}> :COUNT NIL)
5: (LACK.MIDDLEWARE.BACKTRACE::PRINT-ERROR #<SIMPLE-ERROR "Oh my God!" {100791B943}> (:REQUEST-METHOD :GET :SCRIPT-NAME "" :PATH-INFO "/foo/bar" :SERVER-NAME "localhost" :SERVER-PORT 8085 :SERVER-PROTOCOL :HTTP/1.1 ...) #<SYNONYM-STREAM :SYMBOL SLYNK::*CURRENT-ERROR-OUTPUT* {1001541093}>)
6: ((FLET LACK.MIDDLEWARE.BACKTRACE::OUTPUT-BACKTRACE :IN "/Users/art/projects/lisp/lisp-project-of-the-day/.qlot/dists/ultralisp/software/fukamachi-lack-20200524065357/src/middleware/backtrace.lisp") #<SIMPLE-ERROR "Oh my God!" {100791B943}> (:REQUEST-METHOD :GET :SCRIPT-NAME "" :PATH-INFO "/foo/bar" :SERVER-NAME "localhost" :SERVER-PORT 8085 :SERVER-PROTOCOL :HTTP/1.1 ...))
...
31: (SB-THREAD::NEW-LISP-THREAD-TRAMPOLINE #<SB-THREAD:THREAD "hunchentoot-worker-127.0.0.1:56469" RUNNING {1007707373}> NIL #<CLOSURE (LABELS BORDEAUX-THREADS::%BINDING-DEFAULT-SPECIALS-WRAPPER :IN BORDEAUX-THREADS::BINDING-DEFAULT-SPECIALS) {100770731B}> NIL)
32: ("foreign function: call_into_lisp")
33: ("foreign function: new_thread_trampoline")
Above backtrace due to this condition:
Oh my God!

Request:
    REQUEST-METHOD: :GET
    SCRIPT-NAME: ""
    PATH-INFO: "/foo/bar"
    SERVER-NAME: "localhost"
    SERVER-PORT: 8085
    SERVER-PROTOCOL: :HTTP/1.1
    REQUEST-URI: "/foo/bar"
    URL-SCHEME: "http"
    REMOTE-ADDR: "127.0.0.1"
    REMOTE-PORT: 56469
    QUERY-STRING: NIL
    RAW-BODY: #<FLEXI-STREAMS:FLEXI-IO-STREAM {100791B313}>
    CONTENT-LENGTH: 0
    CONTENT-TYPE: NIL
    CLACK.STREAMING: T
    CLACK.IO: #<CLACK.HANDLER.HUNCHENTOOT::CLIENT {100791B363}>
    HEADERS:
        user-agent: "Dexador/0.9.14 (SBCL 2.0.2); Darwin; 19.5.0"
        host: "localhost:8085"
        accept: "*/*"

The problem here is that I did not receive a 500 error. An interactive debugger popped up instead and HTTP request finished with a timeout. To solve this problem, we need to pass a :debug nil argument to clackup:

(clack:clackup *app*
               :port 8085
               :debug nil)

Now we'll try other configuration of this backtrace middleware.

To write output to the file, you need to specify the output option. It can be either a string or a pathname:

POFTHEDAY> (clack:clackup
            (lack:builder
             (:backtrace :output "/tmp/errors.log")
             *app*)
            :port 8089
            :debug nil
            ;; If you don't turn off this,
            ;; backtrace also will be written to the
            ;; *error-output*.
            :use-default-middlewares nil)

Also, you can pass as the output a variable pointing to the stream:

POFTHEDAY> (clack:clackup
            (lack:builder
             (:backtrace :output *trace-output*)
             *app*)
            :port 8090
            :debug nil
            :use-default-middlewares nil)

Another interesting option is :result-on-error. It can be a function or a list with the response data. This way we can return a customized error response:

POFTHEDAY> (clack:clackup
            (lack:builder
             (:backtrace :output "/tmp/errors.log"
                         :result-on-error
                         '(500 (:content-type "text/plain")
                           ("Stay patient. "
                            "We already fixing this error in the REPL")))
             *app*)
            :port 8092
            :debug nil
            :use-default-middlewares nil)

POFTHEDAY> (handler-case (dex:get "http://localhost:8092/foo/bar")
             (error (condition)
               condition))

#<DEXADOR.ERROR:HTTP-REQUEST-INTERNAL-SERVER-ERROR {1009B3BA03}>

POFTHEDAY> (dexador:response-status *)
500
POFTHEDAY> (dexador:response-body **)
"Stay patient. We already fixing this error in the REPL"

Specifying a function as an error handler allows you to render an error response using information from the unhandled condition:

POFTHEDAY> (defun make-error-response (condition)
             (list 500 '(:content-type "text/plain")
                   (list (format nil
                                 "Unhandled error: ~A"
                                 condition))))

POFTHEDAY> (clack:clackup
            (lack:builder
             (:backtrace :output "/tmp/errors.log"
                         :result-on-error
                         #'make-error-response)
             *app*)
            :port 8093
            :use-default-middlewares nil)

POFTHEDAY> (handler-case (dex:get "http://localhost:8093/foo/bar")
             (error (condition)
               (values (dex:response-status condition)
                       (dex:response-body condition))))
500
"Unhandled error: Oh my God!"

Notice, I didn't specify a :debug nil argument for clackup. When you are using :result-on-error argument on backtrace middleware, it will return a response before the lisp debugger will have a chance to pop up.

If you want to invoke debugger in some cases, you can call a (invoke-debugger condition) somewhere inside make-error-response function.

Yesterday we'll review some other Lack's middleware.

Alexander Artemenkolack

· 11 days ago

Lack is a library, used by Clack to compose web apps from middlewares.

Yesterday we've used the lack-middleware-accesslog system to log every request to our webapp. But app configuration was not convenient. Lack provides a macro to compose an application from middlewares:

POFTHEDAY> (defparameter *app*
             (lack:builder
              ;; middlewares
              :accesslog
              ;; the app
              (lambda (env)
                (declare (ignorable env))
                '(200 (:content-type "text/plain")
                  ("Hello, World")))))

POFTHEDAY> (clack:clackup *app*
                          :port 8080)
Hunchentoot server is started.
Listening on 127.0.0.1:8080.

POFTHEDAY> (values (dex:get "http://localhost:8080/foo/bar"))
127.0.0.1 - [22/Jun/2020:22:15:23 +03:00] "GET /foo/bar HTTP/1.1"
         200 12 "-" "Dexador/0.9.14 (SBCL 2.0.2); Darwin; 19.5.0"
"Hello, World"

You can pass a middleware as a keyword or as a s-exp. In the slatter case, all values except the first one, will be passed to the middleware functions.

This way a middleware can be configured. Here is for example, how we can replace a logging function to use log4cl (by the way, remind me to tell you about log4cl, it is wonderful!):

POFTHEDAY> (defparameter *app*
             (lack:builder
              ;; middlewares
              (:accesslog :logger
                          (lambda (message)
                            (log:info message)))
              ;; the app
              (lambda (env)
                (declare (ignorable env))
                '(200 (:content-type "text/plain")
                  ("Hello, World")))))

POFTHEDAY> (clack:clackup *app*
                          :port 8081)

POFTHEDAY> (values (dex:get "http://localhost:8081/foo/bar"))

 <INFO> [22:38:06] poftheday () -
  POFTHEDAY::MESSAGE: "127.0.0.1 - [22/Jun/2020:22:38:06 +03:00] 
                \"GET /foo/bar HTTP/1.1\" 200 12 \"-\"
                \"Dexador/0.9.14 (SBCL 2.0.2); Darwin; 19.5.0\""
  
"Hello, World"

Multiple middlewares can be passed to the lack:builder.

When we are specifying the middleware's name as a keyword, lack tries to search a middleware function using lack.util:find-middleware.

POFTHEDAY> (lack.util:find-middleware :accesslog)

#<FUNCTION (LAMBDA (LACK.MIDDLEWARE.ACCESSLOG::APP &KEY :LOGGER :FORMATTER)
             :IN
             "/Users/art/projects/lisp/lisp-project-of-the-day/.qlot/dists/\
  ultralisp/software/fukamachi-lack-20200524065357/src/middleware/accesslog.lisp")
  {22D1F6CB}>

If you intend to create an opensource library providing Lack middleware and want this discovery work for it, then you have to follow these rules.

Your system has to define a package prefixed with LACK.MIDDLEWARE. And it should export a variable with name matched to the pattern *LACK-MIDDLEWARE-...*. This variable should be bound to a middleware function.

For example, access log middleware defines the LACK.MIDDLEWARE.ACCESSLOG:*LACK-MIDDLEWARE-ACCESSLOG* variable.

Another interesting feature, I didn't cover yet the ability to write an app which delays it's response or stream it back. Luckily, these kinds of applications are covered by Lack's documentation.

Tomorrow, we'll look at some Lack's middleware.

Vsevolod DyomkinEval Spotted in the Wild

· 11 days ago

(#lisptips on the dynamic nature of CLOS magnified by eval)

Since starting programming in Lisp, I always had an impression that using eval is a taboo. Or rather, a cul-de-sac that you never want to touch. When I was only learning Lisp, I had a couple of unsuccessful and rather stupid attempts of utilizing it to bend the language to my view of how it should function — only to learn how it is really intended to function. After that, it occupied its rightful place on my mind's shelf of "low-level constructs only needed to implement the language".

Yet, recently, I saw a legitimate use case for it and even wrote a piece of production code containing eval! That was such a revelation that I wanted to share it in this short post.

So, here is the case I needed to solve: I was developing a parser for a new data format that had to fit into an existing set of parsers. The parsers not only decode the data but also store it in the datastore using the CLOS machinery for datastore access. I.e. there's a generic function to store an individual piece of data that is specialized for different connection/datastore types. Now, my parser had to prepare the individual pieces and, eventually, they would be fed to this function. But that may happen independently of the parser operation: when the data store commit is performed.

Yet, there was another issue at play: the data format allows the individual items to be interdependent, i.e. reference one another via an implicit reference. And when the data is persisted, due to the properties of the data store, these references should be changed to the internal ids of the referenced items. And those are not known before the commit happens. I.e. I was in the following situation:

  • my parser produces an array of items that are to be persisted to the dataset at some later time
  • the order of their addition matters as the dependent items should be added after the ones they reference
  • and as the referenced item is added its id should be saved
  • and assigned to a field of the dependent item before that item is also added

This program logic is quite normal, apart from the fact that my parser doesn't have control over the whole workflow. Actually, the data persistence stage operates in the inversion of control paradigm, i.e. I can only override (rather, augment) the part of the program that is responsible for processing an individual item. Needless to say that I had no desire or intention to reimplement all the different (I believe, 7) ways of interaction with the datastore that had their own methods plus a number of before/after/around-methods.

In fact, CLOS is very flexible and provides a way, using an object of my own mixin-class to hold the state and around-method specialized on it, to achieve my goal of fitting into this whole machinery without distracting it or having to reimplement anything. If not for one issue: limited facilities for dynamic creation of classes.

So, here's what I wanted to do and to avoid:

  1. I wanted to define a mixin-class and an around-method for it to augment the data storing procedure with saving of the ids of specified items and assigning them to fields in other items before persisting them. Here's the sketch of the relevant code:

    (defclass my-data-store-mixin ()
    ((linked-items-table :reader my-mixin-table
    :initform (make-hash-table))))

    (defmethod add-item :around ((db my-data-store-mixin) item)
    (let ((linked-items-table (my-mixin-table db))
    (item-id (call-next-method)))
    (dolist (it (gethash item linked-items-table))
    (remhash it linked-items-table)
    (setf (reference it) item-id))
    (remhash item linked-items-table)
    item-id))
  2. Yet, I didn't want this code to run when other data formats are imported, hence my mixin should have been "activated" if and only if my specific format is parsed.
  3. In other words, I needed a way to dynamically add this mixin to an existing connection object, in the context of the parser call, and then restore the connection to its previous state. In general, CLOS also provides such a facility with its change-class operator. I would say, this would have been a manifestation of a dynamic object system in all its glory if not for one deficiency.
  4. You can't just dynamically define a temporary class: the one that will inherit from the class of the current connection and my mixin. defclass is a macro that's expected to deal with names known ahead-of-time and coded as part of its call: it doesn't evaluate variables. Usually, all such APIs in Lisp have a make-function counterpart. I.e. what I needed was:

    (let ((temp-class (gensym))
    (current-db-class (class-of *db*)))
    (make-class temp-class (list (class-name current-db-class) my-data-store-mixin) nil)
    (unwind-protect (progn (change-class *db* temp-class)
    ;; execute my code
    )
    (change-class *db* current-db-class)))
    But CLOS just doesn't have an API for that. (Which might be perfectly reasonable — and I don't want to delve into the discussion of those reasons in this post). Actually, there's MOP for that. But I'd prefer not to take the MOP route here for another set of reasons I want to skip discussing now :) Suffice to say that it is complicated and, from my experience with the MOP, I developed a stance that it's another area intended for language implementation usage — not for user-level code.
  5. And here's where eval comes to the rescue. In place of the nonexisting make-class I could just put this piece:

    (let ((class (intern (format nil "my-mixed-~a" (class-name current-db-class)))))
    (when (not (find-class class nil))
    (eval `(defclass ,class (,(class-of *db*) my-data-store-mixin) ()))))

So, eval is an escape hatch into the world of ultimate dynamism. This operator can add it anywhere: whether an appropriate API was left out due to lack of foresight or even when it was not intended to exist... :)

Alexander Artemenkolack-middleware-accesslog

· 12 days ago

Yesterday, I've showed you how does Clack work. A web app is a function which returns a list with the response or a function which should return create such list pass it to the provided callback.

Now we'll add a logging to our app with the lack-middleware-accesslog system.

To do this, we must wrap our app's function into another function like this:

;; Now we'll create a simple app:
POFTHEDAY> (defparameter *app*
             (lambda (env)
               '(200 (:content-type "text/plain")
                 ("Hello, World"))))

;; And wrap it into the middleware:
POFTHEDAY> (defparameter *app-with-access-log*
             (funcall lack.middleware.accesslog:*lack-middleware-accesslog*
                      *app*))

;; Now it's time to start our app:
POFTHEDAY> (clack:clackup *app-with-access-log*
                          :port 8000)

Woo server is started.
Listening on 127.0.0.1:8000.

;; And to make a test request:
POFTHEDAY> (values (dex:get "http://localhost:8000/"))
127.0.0.1 - [21/Jun/2020:22:50:52 +03:00] "GET / HTTP/1.1" 
  200 12 "-" "Dexador/0.9.14 (SBCL 2.0.2); Darwin; 19.5.0"
"Hello, World"

Look how a log message was printed to the STDOUT.

Now let's see how does this middleware works. Here is its content. It is a little bit complicated because the middleware needs to handle cases when an app returns a function instead of the normal response:

(defparameter *lack-middleware-accesslog*
  (let ((no-body '#:no-body))
    (lambda (app &key
              (logger
               (lambda (output) (format t "~&~A~%" output)))
              (formatter #'default-formatter))
      (lambda (env)
        (funcall-with-cb
         app env
         (lambda (res)
           (funcall logger
                    (funcall formatter env res (now)))
           res)))))
  "Middleware for logging requests")

I'll show you a simpler version of this logging middleware:

;; Here is the middleware:
POFTHEDAY> (defun simple-logging (app)
             (lambda (env)
               (let ((response
                       (funcall app env)))
                 (format t "~A ~A -> ~A~%"
                         (getf env :request-method)
                         (getf env :path-info)
                         (car response))
                 response)))

;; And this is an example how we can apply it to our app:
POFTHEDAY> (defparameter *app-with-simple-log*
             (simple-logging *app*))

POFTHEDAY> (clack:clackup *app-with-simple-log*
                          :port 8000)
Hunchentoot server is started.
Listening on 127.0.0.1:8000.

POFTHEDAY> (values (dex:get "http://localhost:8000/"))
GET / -> 200
"Hello, World"

POFTHEDAY> (values (dex:get "http://localhost:8000/foo/bar"))
GET /foo/bar -> 200
"Hello, World"

Tomorrow we'll try the better way to apply middlewares to a Clack app.

Alexander Artemenkoclack

· 13 days ago

Today we begin our sprint around Fukamachi's web tools and will start from the Clack.

Clack is an intermediate layer between the real webserver and your application code. It unifies requests parsing and you don't need to rewrite an app if you'll decide to run your app under another webserver.

Today it supports FCGI, Hunchentoot, Toot, Woo, Wookie. Woo and Wookie are asynchronous and can be used to serve hundreds of simultaneous connections.

Another interesting feature of Clack is that application is the only a lambda function. Because of this, the application code can be wrapped with middlewares. There are a number of middlewares: for logging, handling errors, serving static files, etc.

Here is an example of the simplest app. A function should return a list of status-code, headers plist and the content. The content should be a list of strings, a vector of bytes or pathname:

POFTHEDAY> (defparameter *server*
             (clack:clackup
              (lambda (env)
                (declare (ignore env))
                '(200 (:content-type "text/plain")
                  ("Hello, Lisp World!")))
              :port 8000))
Hunchentoot server is started.
Listening on 127.0.0.1:8000.

POFTHEDAY> (nth-value 0
             (dex:get "http://localhost:8000"))
"Hello, Lisp World!"

POFTHEDAY> (clack:stop *server*)
T

Compare this with plain Hunchentoot application:

POFTHEDAY> (hunchentoot:define-easy-handler (say-yo :uri "/") ()
             (setf (hunchentoot:content-type*)
                   "text/plain")
             "Hello Lisp World")

POFTHEDAY> (hunchentoot:start
            (make-instance 'hunchentoot:easy-acceptor
                           :port 8002))

POFTHEDAY> (dex:get "http://localhost:8002/"
                    :headers '(("Custom-Header" . "Hello")))
127.0.0.1 - [2020-06-20 20:58:04] "GET / HTTP/1.1" 200 16 "-" 
            "Dexador/0.9.14 (SBCL 2.0.2); Darwin; 19.5.0"
"Hello Lisp World"

Clack version is more coherent. All request parameters are in one place and it is obvious how to return a status code or the headers.

Here is the content of the env var passed by the Clack to the application function:

;; For this request:
POFTHEDAY> (dex:get "http://localhost:8000/some/path"
                    :headers '(("Custom-Header" . "Hello")))

;; This plist will be passed as env argument
;; to the function:
(:REQUEST-METHOD :GET
 :SCRIPT-NAME ""
 :PATH-INFO "/some/path"
 :SERVER-NAME "localhost"
 :SERVER-PORT 8000
 :SERVER-PROTOCOL :HTTP/1.1
 :REQUEST-URI "/some/path"
 :URL-SCHEME "http"
 :REMOTE-ADDR "127.0.0.1"
 :REMOTE-PORT 51325
 :QUERY-STRING NIL
 :RAW-BODY #<FLEXI-STREAMS:FLEXI-IO-STREAM {1009183813}>
 :CONTENT-LENGTH 0
 :CONTENT-TYPE NIL
 :CLACK.STREAMING T
 :CLACK.IO #<CLACK.HANDLER.HUNCHENTOOT::CLIENT {1009183863}>
 :HEADERS #<HASH-TABLE :TEST EQUAL :COUNT 4 {1009183AE3}>)

;; And here is the content of the HEADERS:
POFTHEDAY> (rutils:print-hash-table
            (getf * :headers))
#{EQUAL
  "user-agent" "Dexador/0.9.14 (SBCL 2.0.2); Darwin; 19.5.0"
  "host" "localhost:8000"
  "accept" "*/*"
  "custom-header" "Hello"
 }

Tomorrow we'll review a Clack middleware and see how to apply to the app.

Alexander Artemenkopcall

· 14 days ago

This library contains a few primitives for parallel code execution. It is like a baby lparallel.

PCall provides a thread pool, few macro to execute and wait parallel task and a thread-safe Queue.

Here is a simple demo which runs two tasks in parallel and then executes a body. A digit on each line is a number of seconds elapsed since the form was evaluated:

POFTHEDAY> (let ((started-at (get-universal-time)))
             (flet ((info (message &rest args)
                      (let ((seconds-since-start
                              (- (get-universal-time)
                                  started-at)))
                        (format t "~A: ~A~%"
                                seconds-since-start
                                (apply #'format nil message
                                       args)))))
               (pcall:plet ((foo (progn (info "Creating Foo")
                                        (sleep 5)
                                        (info "Foo was created")
                                        :foo-result))
                            (bar (progn (info "Creating Bar")
                                        (sleep 3)
                                        (info "Bar was created")
                                    :bar-result)))
                 (info "Plet's body is executed immediately.")
                 (info "And it will wait for the result when you access the value.")
                 (info "Here is the Bar's value: ~S"
                       bar)
                 (info "Task foo still executing in the background.")
                 (info "Here is the Foo's value: ~S"
                       foo))))
0: Plet's body is executed immediately.
0: And it will wait for the result when you access the value.
0: Creating Bar
0: Creating Foo
3: Bar was created
3: Here is the Bar's value: :BAR-RESULT
3: Task foo still executing in the background.
5: Foo was created
5: Here is the Foo's value: :FOO-RESULT

There are a few more interesting functions allowing to execute and wait for tasks. And a thread-safe queue can be loaded using the standalone system pcall-queue.

PCall can be useful when you don't need such a sophisticated tool as lparallel and just want to use thread pool or queue.

If you are interested in trying PCall, read it's docs here because it is not hosted on the GitHub and Quickdocs.org does not show it's docs either.

TurtleWareCharming CLIM tutorial part 2 - Rethinking The Output

· 15 days ago

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-terminal
  • close-console -> close-terminal
  • clear-console -> clear-terminal
  • reset-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 macro with-console
  • clipping code (the clip variables and operators inside and with-clipping)
  • macros letf, out and ctl
  • functions clear-rectangle, get-cursor-position and update-console-dimensions
  • the class console and 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 :buf mode
  • 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.

Alexander Artemenkotrivial-tco

· 15 days ago

This library could be considered as a portability layer for tail call optimization.

When I first found it, I decided it implements a TCO for implementations which do not support it by doing a trampolining trick like this. But I was wrong.

It does ensure the proper declaration is used on implementations which support a proper TCO and signals warning or error on others.

Here is an example on SBCL, which supports TCO only if speed declared to be greater or equal to debug:

POFTHEDAY> (declaim (optimize (debug 3) (speed 1))

POFTHEDAY> (labels ((sum-aux (acc x)
                        (if (zerop x)
                            acc
                            (sum-aux (+ acc x) (- x 1))))
                      (sum (n)
                        (sum-aux 0 n)))
               (sum 1000000))
Control stack guard page temporarily disabled: proceed with caution
; Debugger entered on #<SB-KERNEL::CONTROL-STACK-EXHAUSTED {1004F12E73}>
[1] POFTHEDAY> 
; Evaluation aborted on #<SB-KERNEL::CONTROL-STACK-EXHAUSTED {1004F12E73}>

POFTHEDAY> (tco:with-tail-call-optimization ()
             (labels ((sum-aux (acc x)
                        (if (zerop x)
                            acc
                            (sum-aux (+ acc x) (- x 1))))
                      (sum (n)
                        (sum-aux 0 n)))
               (sum 1000000)))
500000500000 (39 bits, #x746A5A2920)

This macro gets expanded into:

(let ()
  (declare (optimize (speed 3)))
  (labels ((sum-aux (acc x)
             (if (zerop x)
                 acc
                 (sum-aux (+ acc x) (- x 1))))
           (sum (n)
             (sum-aux 0 n)))
    (sum 1000000)))

That is it. Use this library, if you want to employ a tail call and want to ensure they a properly optimized by your Lisp implementation.

Maybe this article by Marc Simpson will be interesting for you. It investigates which Common Lisp implementations have a proper TCO implementation.

Alexander Artemenkolass-flexbox

· 16 days ago

This is an addon to the lass library, reviewed in #0021 post. Lass-flexbox adds to lass an ability to expand Flexbox CSS properties into browser-specific vendor prefixes:

POFTHEDAY> (lass:compile-and-write
            '(.container :flexbox
              (.item :align-self "center")))
".container{
    display: -webkit-box;
    display: -webkit-flex;
    display: -moz-flex;
    display: -ms-flexbox;
    display: flex;
}

.container .item{
    -webkit-align-self: center;
    -moz-align-self: center;
    -ms-flex-item-align: center;
    align-self: center;
}"

I found a great illustrated article on how does Flexbox works and now we'll try to reproduce some layout from this article:

POFTHEDAY> (format t "<style>~A</style>
                      <div class=\"example\">
                        <div class=\"item\">One</div>
                        <div class=\"item\">Two</div>
                        <div class=\"item\">Three</div>
                      </div>
                     "
                   (lass:compile-and-write
                    '(.example
                      :flexbox
                      :align-items "flex-end"
                      :justify-content "space-around"
                      :border 1px solid gray
                      (.item :margin 0.5rem
                             :padding 0.5rem)
                      ((:and .item (:nth-child 1))
                       :background lime
                       :flex 1
                       :height 30px)
                      ((:and .item (:nth-child 2))
                       :background orange
                       :flex 2
                       :height 70px)
                      ((:and .item (:nth-child 3))
                       :background purple
                       :flex 3
                       :height 50px))))

This lisp code will generate us these CSS and HTML:

Code

<style>.example{
    display: -webkit-box;
    display: -webkit-flex;
    display: -moz-flex;
    display: -ms-flexbox;
    display: flex;
    -webkit-box-align: end;
    -ms-flex-align: end;
    -webkit-align-items: flex-end;
    -moz-align-items: flex-end;
    align-items: flex-end;
    -ms-flex-pack: distribute;
    -webkit-justify-content: space-around;
    -moz-justify-content: space-around;
    justify-content: space-around;
    border: 1px solid gray;
}

.example .item{
    margin: 0.5rem;
    padding: 0.5rem;
}

.example .item:nth-child(1){
    background: lime;
    flex: 1;
    height: 30px;
}

.example .item:nth-child(2){
    background: orange;
    flex: 2;
    height: 70px;
}

.example .item:nth-child(3){
    background: purple;
    flex: 3;
    height: 50px;
}</style>

<div class="example">
  <div class="item">One</div>
  <div class="item">Two</div>
  <div class="item">Three</div>
</div>

Result

.example{ display: -webkit-box; display: -webkit-flex; display: -moz-flex; display: -ms-flexbox; display: flex; -webkit-box-align: end; -ms-flex-align: end; -webkit-align-items: flex-end; -moz-align-items: flex-end; align-items: flex-end; -ms-flex-pack: distribute; -webkit-justify-content: space-around; -moz-justify-content: space-around; justify-content: space-around; border: 1px solid gray; } .example .item{ margin: 0.5rem; padding: 0.5rem; } .example .item:nth-child(1){ background: lime; flex: 1; height: 30px; } .example .item:nth-child(2){ background: orange; flex: 2; height: 70px; } .example .item:nth-child(3){ background: purple; flex: 3; height: 50px; }
One
Two
Three

Exciting, isn't it!?

ABCL DevA Future History of Arming Bears

· 17 days ago
As part of the ongoing Online Lisp Meeting series, a recording of a talk about ABCL with the following precis is now available online:

With the recent releases of Armed Bear Common Lisp over the past six months, the future of extending the implementation has come into sharper focus.  The majority of this work has occurred within the head of one individual with little chance for public review and reflection. We believe that our externalized exposition of the reasoning behind these efforts will be of interest to those interested in the future history of Common Lisp implementations.

In the past few months, we released abcl-1.6.0 in which we extended the set of underlying Java Virtual Machines (JVM) that the implementation runs on to include openjdk11 and openjdk14 while maintaining compatibilty with openjdk6.  With the internal overhaul or arrays specialized on unsigned bytes in abcl-1.7.0, we made it possible to share such byte vectors with memory allocated outside of the hosting JVM via system interfaces such as malloc().  

We first present a brief prehistory on the Armed Bear Common Lisp Implementation.  Then, we first present the goals and challenges in affecting these changes within the ABCL codebase by showing examples from recent experience.  Then, we use this initial exposition to serve as a springboard to discuss outstanding needed changes in the ABCL 1 branch, and to outline some of the features intended to be present in ABCL 2, due to be released in the Fall of 2020.

A revised version of the notes for the presentation is available for deeper, asynchronous reflection. 

Alexander Artemenkoprbs

· 17 days ago

This library provides a pseudo-random binary sequence generator useful for error detection in communication streams. It will be useful, if you are building own protocol over UDP, for example.

Here is how it works. There is a function which creates a sequence generator. Its result is a lambda function which can return a requested number of random bits:

POFTHEDAY> (defparameter *generator*
             (prbs:bit-gen 33 :seed (get-universal-time)))

POFTHEDAY> (funcall *generator* 10)
#*0111000101

POFTHEDAY> (funcall *generator* 10)
#*0010011100

POFTHEDAY> (funcall *generator* 10)
#*1011001110

There is also a function to check if these pieces match the desired sequence. It should be used on the "receiver" to check if the message was corrupted or some packets were lost.

Let's simulate a situation when we send our data in 1024 bit chunks and one chunk was lost:

SENDER> (defparameter *generator*
           (prbs:bit-gen 33 :seed (get-universal-time)))

;; These chunks are generated by the sender side
SENDER> (defparameter *first-chunk*
           (funcall *generator* 1024))

SENDER> *first-chunk*
#*011100010100100111001000001001110111...

SENDER> (defparameter *second-chunk*
           (funcall *generator* 1024))

SENDER> (defparameter *third-chunk*
           (funcall *generator* 1024))

;; The reveiver creates a special tracker
;; when it receives the first chunk of data
RECEIVER> (defparameter *tracker*
             (prbs.err:prbs-lock
              *first-chunk*
              33))
RECEIVER> *tracker*
#<CLOSURE (LAMBDA (PRBS.ERR::BITS) :IN PRBS.ERR::MAKE-TRACKER) {10080FF8BB}>

;; Now let's pretend we have lost our second packet
;; and process the third right after the first one:
RECEIVER> (funcall *tracker*
             *third-chunk*)
520
2048

In case of found errors, tracker returns their number as the first value. The second value is the total number of processed bits. This way we can calculate an error rate. In this case, tracker decided there are 520 bits which have wrong values.

Let's simulate another situation when it received the second chunk, but 10 bits were corrupted and their value was flipped:

SENDER> (defparameter *corrupted-second-chunk*
           (copy-seq *second-chunk*))

;; Accidentally, some bits were corrupted:
IN-THE-MIDDLE> (loop for i from 100 below 110
                     do (setf (bit *corrupted-second-chunk* i)
                              (logxor (bit *corrupted-second-chunk* i)
                                      1)))

RECEIVER> (defparameter *tracker*
            (prbs.err:prbs-lock
             *first-chunk*
             33))

;; Now we process the corrupted chunk:
RECEIVER> (funcall *tracker*
                    *corrupted-second-chunk*)
10
2048

;; After the processing of third chunk,
;; tracker still show us there were encountered 10
;; errors:
RECEIVER> (funcall *tracker*
                   *third-chunk*)
10
3072

So, this library will be useful if you'll decide to implement a protocol which needs to determine if there were errors introduced into the data.

Alexander Artemenkothe-cost-of-nothing

· 18 days ago

This is a library by Marco Heisig. It is convenient to use when you want to decide which data structure to use or whether some function is too slow.

Of cause, you can measure execution time with the time macro. But in this case, you'll have to select a number of iteration and to parse time's output and do some time manipulation.

The-cost-of-nothing does everything for you. It runs given form in chunks, measures an execution time for each chunk, divides and calculates average execution time.

Let's see how long does it take to access an element in the hash-table.

POFTHEDAY> (let ((h (make-hash-table)))
             (time
              (loop repeat 1000000000
                    do (gethash :foo h))))
Evaluation took:
  0.271 seconds of real time
  0.270554 seconds of total run time (0.270170 user, 0.000384 system)
  100.00% CPU
  597,543,804 processor cycles
  0 bytes consed

;; Now we have to calculate a speed of the
;; single operation:
POFTHEDAY> (/ 0.271
              1000000000)
2.71e-10

I had to guess a number of iteration to get meaningful execution time and also did some arithmetics after that.

POFTHEDAY> (let ((h (make-hash-table)))
             (the-cost-of-nothing:benchmark
              (gethash :foo h)))
1.11d-8

;; You also can receive a human readable value:
POFTHEDAY> (let ((h (make-hash-table)))
             (the-cost-of-nothing:bench
              (gethash :foo h)))
11.36 nanoseconds

Here we see result 11 nanoseconds, however with time macro we received only 0.271 nanoseconds. Probably this is because the overhead introduced by the-cost-of-nothing. It tries to subtract overhead time from the result, but seems it does works for very fast operations.

In case if you are measuring the cost of very fast operations it is better to make a loop even when using the-cost-of-nothing:

POFTHEDAY> (let ((h (make-hash-table)))
             (/ (the-cost-of-nothing:benchmark
                 (loop repeat 1000
                       do (gethash :foo h)))
                1000))
2.59d-10

How does benchmark macro work?

It has two parameters: timeout and min-sample-time. A tested form gets wrapped into the lambda function and executed in the loop a number of times to measure samples.

On each iteration, the form is executed in another loop where the number of iterations is automatically tuned to make this inner loop run no less than min-sample-time.

After that, an average overall sampled times is calculated and overhead time is subtracted. Overhead time is precalculated as the cost of nil form execution.

On my system, overhead value is 2.7e-9.

I tried to rewrite the function which measures a sample's time to make the calculation fairer, but without significant result.

Here is what I've got:

(defun sample-execution-time-of-thunk (thunk min-sample-time)
  "Measure the execution time of invoking THUNK more and more often, until
the execution time exceeds MIN-SAMPLE-TIME."
  (declare (optimize (speed 3) (debug 1)))
  
  (loop with started-at of-type integer = (get-internal-run-time)
        with run-until of-type integer = (+ started-at
                                             (round (* min-sample-time
                                                       internal-time-units-per-second)))
        for iterations of-type integer = 1 then (* iterations 2)
        summing iterations into total-iterations
        do (loop repeat iterations
                 do (funcall thunk))
        when (>= (get-internal-run-time)
                 run-until)
          do (return (/ (- (get-internal-run-time)
                            started-at)
                        internal-time-units-per-second
                        total-iterations))))

I removed a call to an additional function and to local-time:timestamp-difference, but result is not much better - only 10.71 nanoseconds.

Am I missing something? Maybe compiler does some optimizations, when it sees a gethash call in a loop which does not change the dict?

POFTHEDAY> (let ((h (make-hash-table)))
             (the-cost-of-nothing:bench
              (gethash :foo h)))
10.71 nanoseconds

Another interesting thing about the-cost-of-nothing is that it includes a benchmark which measures some the cost of some common operations.

Even if they are not precise, it is interesting to compare their relative values. Here are numbers received on my Macbook Pro.

Pay attention to how does cost grow for calling the function with multiple keyword arguments:

POFTHEDAY> (asdf:test-system :the-cost-of-nothing)

= The Cost Of Nothing =
Implementation: SBCL 2.0.2
Machine: X86-64 Intel(R) Core(TM) i7-8750H CPU @ 2.20GHz
Hostname: art-2osx

== Memory Management ==
Cost of allocating a cons cell: 6.76 nanoseconds
Cost of garbage collection: 10.68 milliseconds
Cost of full garbage collection: 107.05 milliseconds

== Functions ==
FUNCALL with zero mandatory arguments: 2.71 nanoseconds
FUNCALL with one mandatory argument: 2.68 nanoseconds
FUNCALL with two mandatory arguments: 2.52 nanoseconds
FUNCALL with three mandatory arguments: 2.43 nanoseconds
FUNCALL with four mandatory arguments: 2.74 nanoseconds
FUNCALL with five mandatory arguments: 2.62 nanoseconds
FUNCALL with six mandatory arguments: 2.78 nanoseconds
FUNCALL with zero optional arguments: 2.71 nanoseconds
FUNCALL with one optional argument: 3.24 nanoseconds
FUNCALL with two optional arguments: 3.00 nanoseconds
FUNCALL with three optional arguments: 3.23 nanoseconds
FUNCALL with four optional arguments: 3.09 nanoseconds
FUNCALL with five optional arguments: 3.42 nanoseconds
FUNCALL with six optional arguments: 3.38 nanoseconds
FUNCALL with zero keyword arguments: 2.71 nanoseconds
FUNCALL with one keyword argument: 5.35 nanoseconds
FUNCALL with two keyword arguments: 5.76 nanoseconds
FUNCALL with three keyword arguments: 8.34 nanoseconds
FUNCALL with four keyword arguments: 12.45 nanoseconds
FUNCALL with five keyword arguments: 14.88 nanoseconds
FUNCALL with six keyword arguments: 17.58 nanoseconds
FUNCALL with zero rest arguments: 2.71 nanoseconds
FUNCALL with one rest argument: 2.65 nanoseconds
FUNCALL with two rest arguments: 2.53 nanoseconds
FUNCALL with three rest arguments: 2.48 nanoseconds
FUNCALL with four rest arguments: 2.79 nanoseconds
FUNCALL with five rest arguments: 2.91 nanoseconds
FUNCALL with six rest arguments: 2.66 nanoseconds

== Numerics ==
Flops (single-float): 4.25 gigaflops
Flops (double-float): 2.71 gigaflops

I think it would be great to make this library to output some statistics about collected samples - a number of samples, standard deviation, like IPython does:

Python 3.7.7 (default, Mar 10 2020, 15:43:33)
Type 'copyright', 'credits' or 'license' for more information
IPython 7.14.0 -- An enhanced Interactive Python. Type '?' for help.

In [1]: d = {'what': 42}

In [2]: %timeit d['what']
35.7 ns ± 0.405 ns per loop (mean ± std. dev. of 7 runs, 10000000 loops each)

In [3]:

As @guicho271828 noted, SBCL is able to figure out that gethash's results aren't used in the loop and optimizes it away.

I've checked this hypothesis, and with gethash wrapped with a function results of "time" macro and "benchmark" macro are the same:

POFTHEDAY> (defun get-value (h)
             (gethash :foo h))

POFTHEDAY> (let ((h (make-hash-table)))
             (time
              (loop repeat 1000000000
                    do (get-value h))))
Evaluation took:
  12.968 seconds of real time
  12.966402 seconds of total run time (12.958497 user, 0.007905 system)
  99.98% CPU
  28,634,122,802 processor cycles
  0 bytes consed
  
POFTHEDAY> (/ 12.968
              1000000000)
1.2968e-8

POFTHEDAY> (let ((h (make-hash-table)))
             (the-cost-of-nothing:benchmark
              (get-value h)))
1.1339696e-8

POFTHEDAY> (let ((h (make-hash-table)))
             (the-cost-of-nothing:benchmark
              (gethash :foo h)))
1.0396756e-8

Alexander Artemenkoteddy

· 19 days ago

I always wanted to work from Common Lisp with data like we do in Python. That is how does Teddy born.

Teddy make it possible to define a data frame full of data, to slice it in different ways, to join data frames, see some statistics about the data and render plots.

This is a proof of the concept and API will be changed. Check the ChangeLog.md to learn about new abilities and refactoring details.

Here is how we can create a simple data frame:

POFTHEDAY> (teddy/data-frame:make-data-frame
            '("Idx" "Integers" "Uniform floats" "Gaussian")
            :rows
            (loop repeat 10
                  for idx upfrom 0
                  collect (list idx
                                (random 100)
                                (random 1.0)
                                (statistics:random-normal
                                 :mean 5.0
                                 :sd 0.2))))
+-----+----------+----------------+----------+
| Idx | Integers | Uniform floats | Gaussian |
+-----+----------+----------------+----------+
|   0 |       41 |           0.27 |   4.89d0 |
|   1 |       98 |           0.08 |   4.93d0 |
|   2 |        8 |           0.45 |   5.15d0 |
|   3 |       56 |           0.63 |   4.87d0 |
|   4 |       79 |           0.42 |   4.72d0 |
|   5 |       19 |           0.04 |   4.73d0 |
|   6 |        1 |           0.34 |   4.93d0 |
|   7 |       79 |           0.60 |   5.25d0 |
|   8 |       42 |           0.08 |   5.10d0 |
|   9 |        7 |           0.86 |   5.31d0 |
+-----+----------+----------------+----------+

Now we can slice it by columns, rows or both:

POFTHEDAY> (teddy/data-frame:head *d* 2)
+-----+----------+----------------+----------+
| Idx | Integers | Uniform floats | Gaussian |
+-----+----------+----------------+----------+
|   0 |       41 |           0.27 |   4.89d0 |
|   1 |       98 |           0.08 |   4.93d0 |
+-----+----------+----------------+----------+
POFTHEDAY> (teddy/data-frame:tail *d* 2)
+-----+----------+----------------+----------+
| Idx | Integers | Uniform floats | Gaussian |
+-----+----------+----------------+----------+
|   8 |       42 |           0.08 |   5.10d0 |
|   9 |        7 |           0.86 |   5.31d0 |
+-----+----------+----------------+----------+
POFTHEDAY> (teddy/data-frame:slice
            *d*
            :columns '("idx" "gaussian"))
+-----+----------+
| Idx | Gaussian |
+-----+----------+
|   0 |   4.89d0 |
|   1 |   4.93d0 |
|   2 |   5.15d0 |
|   3 |   4.87d0 |
|   4 |   4.72d0 |
|   5 |   4.73d0 |
|   6 |   4.93d0 |
|   7 |   5.25d0 |
|   8 |   5.10d0 |
|   9 |   5.31d0 |
+-----+----------+
POFTHEDAY> (teddy/data-frame:slice *d*
            :columns '("idx" "gaussian")
            :from 4
            :to 6)
+-----+----------+
| Idx | Gaussian |
+-----+----------+
|   4 |   4.72d0 |
|   5 |   4.73d0 |
+-----+----------+

Also, we might want to see some descriptive statistical data about our data frame. This is pretty easy with Teddy:

POFTHEDAY> (teddy/stats:stats *d*)
+----------------+--------+--------+--------+--------+--------+-------+-------+---------+
| Column         | Min    | p25    | p50    | p75    | Max    | Mean  | SD    | Sum     |
+----------------+--------+--------+--------+--------+--------+-------+-------+---------+
| Idx            |      0 |      2 |   4.50 |      7 |      9 |  4.50 |  3.03 |      45 |
| Integers       |      1 |      8 |  41.50 |     79 |     98 | 43.00 | 34.40 |     430 |
| Uniform floats |   0.04 |   0.08 |   0.38 |   0.60 |   0.86 |  0.38 |  0.27 |    3.75 |
| Gaussian       | 4.72d0 | 4.87d0 | 4.93d0 | 5.15d0 | 5.31d0 |  4.99 |  0.20 | 49.88d0 |
+----------------+--------+--------+--------+--------+--------+-------+-------+---------+

Probably, we can make some extandable protocol to calculate other properties.

Data frame stores data as columns. Each column is a vector of a particular type. If you want to process a row, you can create an iterator and use it to go through rows like that:

POFTHEDAY> (loop with iterator = (teddy/data-frame:make-iterator *d*)
                 for row = (funcall iterator)
                 while row
                 do (format t "Row: ~S~%"
                            row))
Row: (0 41 0.26806116 4.887522971759381d0)
Row: (1 98 0.081421256 4.928584134866222d0)
Row: (2 8 0.45165908 5.147222819038834d0)
Row: (3 56 0.62647486 4.874349648519968d0)
Row: (4 79 0.41671002 4.7239718274963485d0)
Row: (5 19 0.04152584 4.727268395019779d0)
Row: (6 1 0.3369373 4.93339303609316d0)
Row: (7 79 0.59791017 5.2466443304900965d0)
Row: (8 42 0.076958776 5.103448455243024d0)
Row: (9 7 0.85732913 5.310498824093041d0)

Plotting facilities as rudimentary, but should be improved.. All functions related to plotting are in the teddy/plot package. Right now GNUPlot is used via eazy-gnuplot library.

Here is how we can plot our data from all columns:

POFTHEDAY> (teddy/plot:plot *d*
            "docs/media/0099/simple-plot.png")

If we want to plot only gaussian, then it will be wrong, because we need a histogram type of plot. This feature is "to be done":

POFTHEDAY> (teddy/plot:plot
            (teddy/data-frame:slice *d*
                                    :columns '("Idx" "Gaussian"))
            "docs/media/0099/gaussian.png")

Another type of plots Teddy is able to render right now is a "timeseries".

Let's plot how does Moscow's population was changed over years:

POFTHEDAY> (defparameter *moscow-population*
             (teddy/data-frame:make-data-frame
              '("Date" "Population")
              :rows '(("1350-01-01" 30000)
                      ("1840-01-01" 349000)
                      ("1907-01-01" 1345700)
                      ("1967-01-01" 6422000)
                      ("1994-01-01" 9066000)
                      ("2010-01-01" 11500000)
                      ("2020-01-01" 12680000))))
*MOSCOW-POPULATION*
POFTHEDAY> (teddy/plot:plot-timeseries
            *moscow-population* "docs/media/0099/moscow2.png"
            :title "Moscow population")
"docs/media/0099/moscow.png"

Right now, Teddy installable only from Ultralisp, because it is the best place to host unstable fast-changing Common Lisp libraries.

Join the effort to make Teddy really useful for data analysis!

Send your pull-requests to:

https://github.com/40ants/teddy

Pavel Korolev:claw honing

· 22 days ago

Free time too play with CL is quite a luxury item for me as of late, but finally! - I've got a whole week of me-time and I'm planning to pour all of it into :claw - the precious jewel at the heart of most of my projects.

:claw is a library for automatically creating Common Lisp bindings to foreign libraries that provide C interface. :claw already works well, but having access only to libraries with C-compatible interface is quite limiting. I'm a game developer both at work and at home and a lot of gamedev libraries are either C++ only and don't export any C interface at all or such interface is out-of-date or heavily underdocumented. Unfortunately, I don't have enough man-hours to reimplement all of those in pure Common Lisp myself and bindings seem like a huge time saver. That's right, I'm working on bringing C++ support into :claw.

In this post, I'll try to summarize how I envision this support being implemented in :claw. If you think something can be done better, faster or maybe I'm plain wrong somewhere - I appreciate if you drop a comment with your ideas here or via email/IRC.

Quicklisp newsJune 2020 Quicklisp dist update now available

· 23 days ago
New projects:
  • 3b-hdr — reader and writer for radiance HDR files — MIT
  • algae — Assortment of Lisp Game Algorithms and Experiments — MIT
  • arithmetic-operators-as-words — Just simple macros that expand to the normal arithmetic operators. I personally hate using the symbols.. — MIT
  • bnf — BNF example generator. Useful for testing parser. — MIT
  • check-bnf — Macro arguments checker. — MIT
  • cl-async-await — An implementation of async/await for Common Lisp — AGPLv3
  • cl-batis — SQL Mapping Framework for Common Lisp — MIT
  • cl-dbi-connection-pool — CL-DBI-Connection-Pool - connection pool for CL-DBI — LLGPL
  • cl-fix — A FIX (Financial Information eXchange) library for Common Lisp — Apache 2.0
  • cl-migratum — Database schema migration system for Common Lisp — BSD 2-Clause
  • cl-renderdoc — Wrapper around the renderdoc In-Application API for Common Lisp — MIT
  • cl-string-generator — Generate string from regular expression — MIT
  • cl-zipper — An implementation of functional zippers for Common Lisp — MIT Expat
  • clast — CLAST is a Common Lisp library that can produce an "abstract syntax tree" of a "form". Its main use is for source analysis and transformation, e.g., extracting the "free variables" list from a form. — BSD
  • clcs-code — Companion code for "The Common Lisp Condition System" — MIT
  • clj — Some clojure conveniences for Common Lisp — MIT
  • com-on — Utilities for dealing with COM interfaces. — zlib
  • core-reader — Utilities for stream oriented reader. — MIT
  • gtirb-capstone — Integration between GTIRB and the Capstone/Keystone libraries — MIT
  • gtirb-functions — Function objects over GTIRB — MIT
  • jingoh — DSL to notate specification, rather than test framework. — MIT
  • matrix-case — Control flow macros which writing nested CASE easily. — Public domain
  • millet — Wrapper for implementation dependent tiny utilities. — MIT
  • null-package — Safe and robust S-Expression reader. Useful to read from unfailthfull stream/socket. — MIT
  • packet-crafting — A library to craft network packets. — MIT
  • postmodern-localtime — postmodern-localtime — You don't even have to buy me a beer
  • prompt-for — Type safe user input. — MIT
  • read-as-string — Reading S-Expression string from stream. — MIT
  • resignal-bind — Tiny signal capturing facility. — MIT
  • structure-ext — Tiny structure extensions for common lisp — MIT
  • trestrul — Tiny utilities for TREe-STRUctured-List. — Public Domain
  • validate-list — Allows you to validate the contents and structure of a list based off of a template — MIT
Updated projects3bzahungry-fleeceanypoolaprilarray-operationsarrivalasdf-vizassert-pasync-processbinary-iobinpackbordeaux-threadsbpcacaucffichirpci-utilscity-hashcl+sslcl-ansi-termcl-argparsecl-ascii-tablecl-asynccl-capstonecl-conllucl-cudacl-dbicl-fadcl-gamepadcl-gservercl-hamcrestcl-krakencl-liballegrocl-libuvcl-mysqlcl-patternscl-quickcheckcl-random-forestcl-telegram-botcl-threadpoolcl-utilscl-webkitcladclmlcloser-mopclxcommon-lisp-jupytercommonqtconcrete-syntax-treecroatoancxmldatamusedatum-commentsdbusdeedsdeploydestructuring-bind-stardjuladns-clientdocbrowsereasy-routeseazy-documentationeclectorfare-scriptsfast-generic-functionsfemlispfiascoflac-metadataflareflexi-streamsflowfsetfunctional-treesgendlgeneric-clgeowktgolden-utilsgraphgtirbgtypehelambdaphu.dwim.defhunchentootiteratejpeg-turbolacklasslisp-binaryliterate-lisplocal-timemarkupmcclimmgl-paxmicmacmito-attachmentmutilitynamed-readtablesnibblesnumcloriginoverlordparsleypatchworkpathname-utilsperceptual-hashespetalisppiggyback-parameterspngloadportable-condition-systempostmodernprotobufpzmqquery-fsquriroanrpcqryeboysanity-clausescalplsealable-metaobjectsselserapeumshadowshellpoolsip-hashsnappyspecialization-storespecialized-functionspinneretst-jsonstaplestatic-vectorsstripestumpwmswank-clientswank-crewsycamoresystem-localetaggertentest-utilstootertrace-dbtrivial-backtracetrivial-mimestrivial-package-local-nicknamesumbraunix-optsverbosevgplotvom-jsonwinhttpwordnetxhtmlambdazpb-exif.

Removed projects: avl-tree, cl-mango, doubly-linked-list, hspell, osmpbf, pngload-fast.

To get this update, use (ql:update-dist "quicklisp").

ABCL DevThe Bear Arms for Sharing Byte Vectors with 1.7.0

· 30 days ago
We are pleased to announce the immediate availability of the ABCL
1.7.0 release.

After consuming a steady diet of java.nio.ByteBuffer objects over the
past month, the Bear has managed to incorporate the use of these
abstractions for arrays specialized on the commonly used unsigned-byte
types (or (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32)).
This replacement of the use arrays of primitive bytes is denoted by
the presence of the :NIO keyword in CL:*FEATURES*.

With this :NIO overhaul, we have extended our implementation of ANSI
Common Lisp CL:MAKE-ARRAY with two additional keywords,
viz. :NIO-BUFFER and :NIO-DIRECT.

Now, the :NIO-BUFFER keyword argument to CL:MAKE-ARRAY allows one to construct a vector directly utilizing the contents of an already allocated
java.nio.ByteBuffer object.  When combined with the ability of JNA to
allocate memory on the heap via a malloc() system call, we implemented
shareable byte vectors in CFFI-SYS:MAKE-SHAREABLE-BYTE-VECTOR.

    (let* ((length 16)
           (byte-buffer (java:jstatic "allocate"
                                      "java.nio.ByteBuffer" length)))
      (make-array length :element-type '(unsigned-byte 8) 
                         :nio-buffer byte-buffer))

When the :NIO-DIRECT keyword argument is called with a non-NIL value,
the implementation creates a byte vector with a "directly allocated"
java.nio.ByteBuffer object.  Such direct buffers typically have
somewhat higher allocation and deallocation costs than non-direct
buffers.  The contents of direct buffers may reside outside of the
normal garbage-collected heap, and so their impact upon the memory
footprint of an application might not be obvious. It is therefore
recommended that direct buffers be allocated primarily for large,
long-lived buffers that are subject to the underlying system's native
I/O operations.  In general it is best to allocate direct buffers only
when they yield a measurable gain in program performance. In the near
future, we intend to explore the performance gains available CL:LOAD
by accessing direct buffers memory mapped to our on-disk fasl
representation.  Our fasls, as zipped archives, currently require a
new seek() from the beginning for each component they
contain.  With a memory mapped direct buffer we should be able to
simply read from the appropriate byte offset for each component.

A complete overview of the accumulated fixes and changes since the
previous release may be viewed in the file describing our CHANGES.


TurtleWareConformal array displacement

· 30 days ago

In Common Lisp it is possible to displace one array to another. This is a useful feature which allows reusing the same memory for different array shapes. On LispM it was possible to displace arrays conformally and treat array as a multi-dimensional object instead of a continuous memory block.

It is said that one array is worth thousand of strings. Let's illustrate the difference with an example:

ARRAY*> (defparameter *arr* (make-array '(8 8) :initial-element 0))
*ARR*
ARRAY*> *arr*
#2A((0 0 0 0 0 0 0 0)
    (0 0 0 0 0 0 0 0)
    (0 0 0 0 0 0 0 0)
    (0 0 0 0 0 0 0 0)
    (0 0 0 0 0 0 0 0)
    (0 0 0 0 0 0 0 0)
    (0 0 0 0 0 0 0 0)
    (0 0 0 0 0 0 0 0))
ARRAY*> (defparameter *dis*
          (make-array '(4 4)
                      :displaced-to *arr*
                      :displaced-index-offset
                      (array-row-major-index *arr* 2 2)))
*DIS*
ARRAY*> (loop for i from 0 below (array-total-size *dis*)
              do (setf (row-major-aref *dis* i) 1))
NIL
ARRAY*> *arr*
#2A((0 0 0 0 0 0 0 0)
    (0 0 0 0 0 0 0 0)
    (0 0 1 1 1 1 1 1)
    (1 1 1 1 1 1 1 1)
    (1 1 0 0 0 0 0 0)
    (0 0 0 0 0 0 0 0)
    (0 0 0 0 0 0 0 0)
    (0 0 0 0 0 0 0 0))

Had the array *dis* been displaced conformally, the result would be different:

ARRAY*> (defparameter *arr* (make-array '(8 8) :initial-element 0))
*ARR*
ARRAY*> (defparameter *dis*
          (make-array '(4 4)
                      :displaced-to *arr*
                      :displaced-index-offset '(2 2)))
*DIS*
ARRAY*> (loop for i from 0 below (array-total-size *dis*)
                do (setf (row-major-aref *dis* i) 1))
NIL
ARRAY*> *arr*
#2A((0 0 0 0 0 0 0 0)
    (0 0 0 0 0 0 0 0)
    (0 0 1 1 1 1 0 0)
    (0 0 1 1 1 1 0 0)
    (0 0 1 1 1 1 0 0)
    (0 0 1 1 1 1 0 0)
    (0 0 0 0 0 0 0 0)
    (0 0 0 0 0 0 0 0))

Such displacement is especially attractive when you want to model the API to return a particular slice of an array (for instance representing a screen). From that there is only one step further to add a multi-dimensional fill pointer. It serves the same purpose as for vectors. In this post I'll sketch a hack which implements something resembling arrays which are conformally displaced.

First I'll shadow array symbols which will be implemented. Package meant for consumption is named eu.turtleware.hacks.array* while the actual code is put in the package eu.turtleware.hacks.array*.implementation.

(defpackage #:eu.turtleware.hacks.array*
  (:use)
  (:export #:array*
           ;; Constructors
           #:make-array #:adjust-array
           ;; Predicates
           #:arrayp
           #:array-in-bounds-p
           #:adjustable-array-p
           #:array-has-fill-pointer-p
           ;; Accessors
           #:row-major-aref #:aref
           ;; Readers
           #:array-dimensions #:array-dimension #:array-rank
           #:array-element-type #:array-displacement
           #:array-total-size #:array-row-major-index))

(defpackage #:eu.turtleware.hacks.array*.implementation
  (:use #:cl #:eu.turtleware.hacks.array*)
  (:shadowing-import-from #:eu.turtleware.hacks.array*
                          #:array*
                          ;; Constructors
                          #:make-array #:adjust-array
                          ;; Predicates
                          #:arrayp
                          #:array-in-bounds-p
                          #:adjustable-array-p
                          #:array-has-fill-pointer-p
                          ;; Accessors
                          #:row-major-aref #:aref
                          ;; Readers
                          #:array-dimensions #:array-dimension #:array-rank
                          #:array-element-type #:array-displacement
                          #:array-total-size #:array-row-major-index))
(in-package #:eu.turtleware.hacks.array*.implementation)

I don't particularly care here about performance and consing in this implementation, because the conformal displacement should be implemented by Common Lisp vendors. They could leverage non-portable parts of the array implementation (i.e weak references to arrays which are displaced to the array). Most functions are generic and each will works for "real" arrays too.

array* is a wrapper which has four slots. array is the array to which we displace to, start and fillp define a slice of the array, and the flag inner indicates whether the array is not shared.

(defclass array* ()
  ((array :initarg :array :accessor %array)
   (start :initarg :start :accessor %start)
   (fillp :initarg :fillp :accessor %fillp)
   (inner :initarg :inner :accessor %inner)))

Some generic functions are very mundane. Macro define-wrapper is defined for such cases.

(defmacro define-wrapper (name (array-var &rest args) &body body)
  (let ((cl-name (find-symbol (symbol-name name) (find-package 'cl))))
    `(defgeneric ,name (,array-var ,@args)
       (:method ((,array-var cl:array) ,@args)
         (,cl-name ,array-var ,@args))
       (:method ((,array-var array*) ,@args)
         ,@body))))

Predicates are straightforward. arrayp works on any object, the rest works only for arrays.

(defgeneric arrayp (array)
  (:method (array) nil)
  (:method ((array cl:array)) t)
  (:method ((array array*)) t))

(define-wrapper adjustable-array-p (array)
  t)

(define-wrapper array-has-fill-pointer-p (array)
  t)

(defgeneric array-in-bounds-p (array &rest subscripts)
  (:method ((array cl:array) &rest subscripts)
    (apply #'cl:array-in-bounds-p array subscripts))
  (:method ((array array*) &rest subscripts)
    (loop for start in (%start array)
          for fillp in (%fillp array)
          for len = (- fillp start)
          for sub in subscripts
          unless (typep sub `(integer 0 ,len))
            do (return-from array-in-bounds-p nil)
          finally (return t))))

Readers are also trivial. array-displacement returns the third value indicating the last index in the displaced-to array.

(define-wrapper array-element-type (array)
  (array-element-type (%array array)))

(define-wrapper array-rank (array)
  (length (%start array)))

(define-wrapper array-dimensions (array)
  (mapcar #'- (%fillp array) (%start array)))

(define-wrapper array-dimension (array axis-number)
  (- (nth (%fillp array) axis-number)
     (nth (%start array) axis-number)))

(define-wrapper array-total-size (array)
  (reduce #'* (array-dimensions array)))

(define-wrapper array-displacement (array)
  (values (%array array)
          (%start array)
          (%fillp array)))

Accessors are more tricky. For aref I'll define a helper function get-real-subscripts which translates supplied subscripts to the underlying array's subscripts.

(defun get-real-subscripts (array &rest subscripts)
  (loop for sub in subscripts
        for off in (%start array)
        for flp in (%fillp array)
        for ind = (+ sub off)
        if (and (>= ind off) (< ind flp))
          collect ind into subs
        else
          do (error "Invalid index.")
        finally
           (return subs)))

Now implementing aref and (setf aref) is a matter of translating subscripts and calling the function on a displaced-to array.

(defgeneric aref (array &rest subscripts)
  (:method ((array cl:array) &rest subscripts)
    (apply #'cl:aref array subscripts))
  (:method ((array array*) &rest subscripts)
    (apply #'cl:aref
           (%array array)
           (apply #'get-real-subscripts array subscripts))))

(defgeneric (setf aref) (new-value array &rest subscripts)
  (:argument-precedence-order array new-value)
  (:method (new-value (array cl:array) &rest subscripts)
    (apply #'(setf cl:aref) new-value array subscripts))
  (:method (new-value (array array*) &rest subscripts)
    (apply #'(setf aref)
           new-value
           (%array array)
           (apply #'get-real-subscripts array subscripts))))

To access the array with the row major index a function which reconstructs subscripts from the integer is necessary. A reverse operation computes the row major index from subscripts and it is of course array-row-major-index.

(defun row-major-index-to-subscripts (array index)
  (loop with ind = index
        with sub
        for rem on (array-dimensions array)
        do (multiple-value-setq (sub ind)
             (truncate ind (reduce #'* (cdr rem))))
        collect sub))

(defgeneric array-row-major-index (array &rest subscripts)
  (:method ((array cl:array) &rest subscripts)
    (apply #'cl:array-row-major-index array subscripts))
  (:method ((array array*) &rest subscripts)
    ;; Q: Can we do better?; A: Of course we can!
    ;; Q: Why won't we?;     A: Too much hassle!
    (loop for rem on (array-dimensions array)
          for sub in subscripts
          summing (* sub (reduce #'* (cdr rem))))))

Having row-major-index-to-subscripts implemented, accessors row-major-aref and (setf row-major-aref) are easy:

(define-wrapper row-major-aref (array index)
  (apply #'aref array (row-major-index-to-subscripts array index)))

(defgeneric (setf row-major-aref) (new-value array index)
  (:argument-precedence-order array index new-value)
  (:method (new-value (array cl:array) index)
    (setf (cl:row-major-aref array index) new-value))
  (:method (new-value (array array*) index)
    (apply #'(setf aref) new-value array
           (row-major-index-to-subscripts array index))))

As noted before, I don't care about offsetting computations to compilation time. However if I did I could have made an interesting blunder (which can be avoided by the implementation made by a vendor): write a hash function which takes row major index of the array and returns row major index of the displaced-to array. That would make access faster. The problem is that when the displaced-to array is adjusted, the hash function may be invalid because array dimensions change and there is no portable way to detect that - each function would need to explicitly check the displaced-to array dimensions if they are the same as previously.

Now it is time to implement constructors make-array and adjust-array. They are quite similar, especially when it comes to validating parameters. The next three functions are utilities shared by both. check-conformal-args validates arguments. Most notably it checks whether displacement arguments have the same arity as the array rank.

(defun check-conformal-args
    (dimensions initial-element initial-contents
     fill-pointer displaced-to displaced-index-offset)
  (cond ((and (not displaced-to) displaced-index-offset)
         (error "Can't specify ~s without ~s."
                :displaced-index-offset :displaced-to))
        ((and displaced-to (or initial-element initial-contents))
         (error "~s and ~s are mutually exclusive with ~s."
                :initial-element :initial-contents :displaced-to))
        ((and (consp fill-pointer)
              (/= (length fill-pointer) (length dimensions)))
         (error "~s must have the same length as DIMENSIONS."
                :fill-pointer))
        ((and (consp displaced-index-offset)
              (/= (length displaced-index-offset) (length dimensions)))
         (error "~s must have the same length as DIMENSIONS."
                :displaced-index-offset))))

Slots start and fillp are expressed as indexes of the displaced-to array (usually fill-pointer is expressed in vector indexes). I use a helper function to return lists for displaced-index-offset and fill-pointer which are computed based on array dimensions. This function assumes, that arguments are already validated with check-conformal-args.

(defun fix-displacement (dimensions displaced-index-offset fill-pointer)
  ;; Correct the FILL-POINTER and the DISPLACED-INDEX-OFFSET. Both
  ;; should be expressed in the destination array indexes.
  (cond ((and (atom fill-pointer)
              (atom displaced-index-offset))
         (setf displaced-index-offset
               (make-list (length dimensions) :initial-element 0))
         (setf fill-pointer dimensions))
        ((atom fill-pointer)
         (setf fill-pointer (mapcar #'+ displaced-index-offset dimensions)))
        ((atom displaced-index-offset)
         (setf displaced-index-offset (mapcar #'- fill-pointer dimensions)))
        (t
         (setf fill-pointer (mapcar #'+ displaced-index-offset fill-pointer))))
  (values displaced-index-offset fill-pointer))

The last function checks whether final indexes have valid order:

(defun check-indexes (dimensions displaced-index-offset fill-pointer)
  (every #'<=
         (make-list (length dimensions) :initial-element 0)
         displaced-index-offset
         fill-pointer
         (mapcar #'+ displaced-index-offset dimensions)))

make-array may construct three different objects:

  • cl:array instance when there is no conformal displacement
  • array* instance with inner=Y for multi-dimensional fill-pointer
  • array* instance with inner=N for conformally displaced array
(defun make-array (dimensions &rest args
                   &key
                     (element-type t)
                     initial-element
                     initial-contents
                     adjustable
                     fill-pointer
                     displaced-to
                     displaced-index-offset)
  (declare (ignore element-type adjustable))
  (when (and (atom displaced-index-offset)
             (atom fill-pointer)
             (not (typep displaced-to 'array)))
    (return-from make-array
      (apply #'cl:make-array dimensions args)))
  (check-conformal-args dimensions initial-element initial-contents
                        fill-pointer displaced-to displaced-index-offset)
  (when (null displaced-to)
    ;; implies that D-I-O is NIL and that F-P is CONS
    (remf args :fill-pointer)
    (return-from make-array
      (make-instance 'array*
                     :array (apply #'cl:make-array dimensions args)
                     :start (make-list (length dimensions) :initial-element 0)
                     :fillp fill-pointer
                     :inner t)))
  (multiple-value-setq (displaced-index-offset fill-pointer)
    (fix-displacement dimensions displaced-index-offset fill-pointer))
  ;; Assert the indice correctness.
  (if (and (check-indexes dimensions displaced-index-offset fill-pointer)
           (every #'<= fill-pointer (array-dimensions displaced-to)))
      (make-instance 'array*
                     :array displaced-to
                     :start displaced-index-offset
                     :fillp fill-pointer
                     :inner nil)
      (error "Invalid FILL-POINTER or DISPLACED-INDEX-OFFSET specification.")))

adjust-array, unless called on cl:array (in which case it calls cl:adjust-array), always preserves the array identity. When the array is confromally displaced to another one (inner=NIL), or the parameter displaced-to is not NIL, A new array is created with make-array and slots are copied from the result.

Otherwise the displaced-to array is private, so it is possible to adjust start and fillp. If the result does not fit in the displaced-to array, it is adjusted too.

(defun adjust-array (array dimensions &rest args
                     &key
                       element-type
                       initial-element
                       initial-contents
                       fill-pointer
                       displaced-to
                       displaced-index-offset)
  (declare (ignore element-type))
  (etypecase array
    (cl:array
     (apply #'adjust-array array dimensions args))
    (array*
     (when (or (not (%inner array)) displaced-to)
       (let ((arr (apply #'make-array array dimensions args)))
         (if (typep arr 'array*)
             (setf (%array array) (%array arr)
                   (%start array) (%start arr)
                   (%fillp array) (%fillp arr)
                   (%inner array) nil)
             (setf (%array array) arr
                   (%start array) (make-list (length dimensions) :initial-element 0)
                   (%fillp array) (array-dimensions arr)
                   (%inner array) t))))
     (check-conformal-args dimensions initial-element initial-contents
                           fill-pointer displaced-to displaced-index-offset)
     (setf displaced-to (%inner array))
     (multiple-value-setq (displaced-index-offset fill-pointer)
       (fix-displacement dimensions displaced-index-offset fill-pointer))
     ;; Assert the indice correctness.
     (unless (check-indexes dimensions displaced-index-offset fill-pointer)
       (error "Invalid FILL-POINTER or DISPLACED-INDEX-OFFSET specification."))
     (unless (every #'<= fill-pointer displaced-to)
       (remf args fill-pointer)
       (remf args displaced-index-offset)
       (setf displaced-to (apply #'adjust-array displaced-to fill-pointer args)))
     (setf (%array array) displaced-to
           (%start array) displaced-index-offset
           (%fillp array) fill-pointer)
     array)))

That's all. As noted before, this is a mere sketch, but works fairly good. I've written it to incorporate in the charming-clim tutorial, but I've decided to not complicate description too much. Still I think that it is an interesting insight so I've decided to make it into a separate post. In the future I'd like to incorporate this very cool feature into the Embeddable Common Lisp.

If you feel like supporting me with my FLOSS contributions and blogging you may become my patron.

Nicolas HafnerThe Road Ahead - June Kandria Update

· 33 days ago

header
Another month already gone by. Unlike last month, I have managed to work on a few things this month, though it isn't much yet. So, in order to bolster the content a bit, I thought I'd also talk about the rough roadmap I have for Kandria.

But first, let's go over the progress for the month. I started working on the first real enemy of the game: a wolf fit for dark, underground caverns.

wolf

All of the animations I need for it (for now) are done, and I added a really primitive AI for it. In the process of this I also started to work on an optimisation and cleanup to revise the sprite system in the engine. Specifically, I wanted to be able to remove some of the kludges I had introduced in Kandria to extend the frame information, and allow the system to use packed sprite atlases. So far, I had been using a very primitive implementation where each sprite was a horizontal strip of frames, each frame a fixed size.

horizontal sprite sheet

That's the player sprite sheet up there.

However, this is very, very wasteful. Despite the low resolution of the player sprite (16x32 for many frames), this atlas ended up being 13'760x50! With a packed atlas however, the size can be reduced to 441x383, that's a total pixel reduction of 4x! A packed atlas is also much more square, so it is much more likely to fit into the texture size limits of older graphics cards.

packed sprite atlas

Anyway, I completely rewrote the sprite system in Trial to work with sprite atlases and generally to allow having each frame be of a different size. However, ripping things out like this and rewriting them usually causes a lot of headaches to fix everything up to work with the new system. And so it did. Once I got started with the cleanup though I couldn't help myself and started ripping out other components that were shoddy, too.

And now I'm in the uncomfortable position of all my past technical debt staring me in the face. There's a lot that I need to rip out and replace to make less of a hack. I probably should have done that long ago, but you know, hindsight is 20/20. Anyway, there's some big engine things that I feel I need to rewrite now, before it gets any worse. Despite this ostensibly being a good thing, it makes me feel really terrible, because it means there won't be any tangible progress for a while longer. Seeing people on Twitter make great progress with their games doesn't help either, and makes me regret trying to roll my own engine quite a bit. Despite all that, I'm not going to switch to something else quite yet.

Another thing that happened this month is that I finally got the news back from ProHelvetia. Unsurprisingly to me, I did not get the funding. That's a bummer, but it honestly doesn't change anything really. I was never intending on relying on their grant anyway, so I'm just going to keep moving like before. I'll just have to dig a bit deeper into my own pockets for when I start hiring help during production. I might also try applying again next year - we'll see.

This neatly brings us to the current roadmap for Kandria. Now, I've never been any good at long-term planning. In fact, I typically try to avoid it, since I believe I won't have any idea how things turn out anyway, so planning too far ahead is just futile. That being said, I do have a task list that goes from very precise to very imprecise as time goes on:

  • Fix Trial's scene graph and shader pipeline mess. This will also affect other projects using Trial in a big way. Explaining what exactly this entails is a bit out of scope of this, but I'll probably write a separate gamedev article about it.
  • Fix and improve the node graph AI. This is what allows NPCs to move like a normal character across the 2D terrain. Currently it's a very primitive and limited implementation that needs to be fixed up to work better for the enemy AI.
  • Implement a better AI for the wolf enemy. Currently the AI does not fit well with the behaviour I had imagined for the wolf. This should be a very minor and simple task.
  • Fine tune the combat to be more fluid and fun to play. This will involve a lot of manual adjustment and testing. I'll also release another prototype demo version at this point to get some feedback from others.
  • Rewrite libmixed to work with bip-buffers, and ultimately to work with proper varying sample counts and allow resampling. This is necessary to make it work on all platforms, and will lead to allowing sound and music in Kandria.
  • Implement simple sound and graphical effects for the combat. This should again make it a lot more fun to play and should improve the perceived quality a lot. This is another public demo milestone.
  • Fix and reinstate the dialogue and quest systems. This should allow adding NPCs to talk to, and should add a simple quest system to track progression.
  • Write an editor for the quest system. The quest system is a flow graph, which is unbearably tedious to manipulate without specialised UI.
  • Begin production. With all of the prerequisites now done, production can begin in earnest.
  • Develop a full vertical slice of the central hub area. This should include NPCs that move around, a set of quests to fulfil, as well as a few combat encounters and locations to explore.
  • Another demo might be released here, to gather more feedback about the overall picture.
  • Develop a full horizontal slice. This will require the story to be fully realised, and most of the rough level design as well.
  • Publish a 'first chapter' type of demo to gather attention and market the game some more.
  • Finish the full game.

Of course, the further down the items are, the less certain I am that I'll be able to get to them in that order, let alone when exactly I'll get to them. Initially, before all the Corona crap, the plan was to reach the production stage by August or September this year. Now I'm not too sure that'll be possible to reach, but here's to hoping anyway.

Whatever the case, I'll keep doing the weekly posts on my mailing list, as well as the public monthlies, and keep you up to date on what's going on that way. In case you're not already subscribed: the mailing list weeklies also have other juicy info on the game besides the rough development updates of the monthlies! Don't forget, if you want to talk about Kandria with me or others that are interested, there's also a Discord.

Anyway, that's about it for this month. I'll get back to thinking about that first task now...

TurtleWareControlling the terminal

· 39 days ago

When building a console backend for McCLIM there are three terminal capabilities that we need:

  • configuring the terminal (raw mode, no echo, querying properties)
  • drawing output (positioning the cursor and writing with attributes)
  • reading events (keyboard, pointer, and window status changes)

Configuring the terminal

To know where the terminal is, we need to start the implementation from it and save the streams in a separate variable, because SWANK rebind them for the SLIME session.

(defvar *console-io* *terminal-io*)
(swank:create-server)
(loop (sleep most-positive-fixnum))

We can implement most things with ANSI escape sequences and various extensions to them. Unfortunately we can't turn off echo and line buffering from that way, we need to use a minimal C program to do that, which we will call with FFI.

/* This small program is written based on a tutorial found under URL:
   https://viewsourcecode.org/snaptoken/kilo/02.enteringRawMode.html */

#include <stdlib.h>
#include <termios.h>
#include <unistd.h>

struct termios *enable_raw() {
  struct termios *orig_termios = malloc(sizeof(struct termios));
  struct termios raw;
  tcgetattr(STDIN_FILENO, orig_termios);
  raw = *orig_termios;
  raw.c_iflag &= ~(BRKINT | ICRNL | INPCK | ISTRIP | IXON);
  raw.c_oflag &= ~(OPOST);
  raw.c_cflag |= (CS8);
  raw.c_lflag &= ~(ECHO | ICANON | IEXTEN | ISIG);
  tcsetattr(STDIN_FILENO, TCSAFLUSH, &raw);
  return orig_termios;
}

void disable_raw(struct termios *orig_termios) {
  tcsetattr(STDIN_FILENO, TCSAFLUSH, orig_termios);
  free(orig_termios);
}

And here's how we will use it. ASDF will compile the C file and load the resulting shared library. To allow interactive programming we'll use a function show-screen and call it once per second.

(defpackage #:eu.turtleware.charming-clim
  (:use #:cl)
  (:export #:start-display))
(in-package #:eu.turtleware.charming-clim)

;; gcc raw-mode.c -shared -o raw-mode.so
;; (cffi:load-foreign-library "/path/to/raw-mode.so")

(cffi:defcfun (enable-raw "enable_raw")
    :pointer)
(cffi:defcfun (disable-raw "disable_raw")
    :void
  (handler :pointer))

(defvar *console-io* *terminal-io*)

(defmacro with-console (opts &body body)
  (declare (ignore opts))
  (let ((handler (gensym)))
    `(let ((,handler (enable-raw)))
       (unwind-protect (progn ,@body)
         (disable-raw ,handler)))))

(declaim (notinline show-screen))
(defun show-screen ()
  (format *console-io* "~acHello World!" #\esc)
  (finish-output *console-io*))

(defun start-display ()
  (swank:create-server)
  (with-console ()
    (loop (sleep 1)
          (show-screen))))

Finally, to wrap things up, we need to define a loadable system. Let's name the C file "raw-mode.c", and the Lisp file "terminal.lisp". The directory will have a flat structure with the ASDF definition file eu.turtleware.charming-clim.asd.

(defpackage #:charming-clim-system
  (:use #:asdf #:cl)
  (:export #:cfile))
(in-package #:charming-clim-system)

(defclass cfile (c-source-file) ())

(defmethod output-files ((o compile-op) (c cfile))
  (list (make-pathname :name (component-name c) :type "so")))

(defmethod perform ((o compile-op) (c cfile))
  (let ((in  (first (input-files o c)))
        (out (first (output-files o c))))
    (uiop:run-program (format nil "cc -shared ~a -o ~a" in out))))

(defmethod perform ((o load-op) (c cfile))
  (let ((in (first (input-files o c))))
    (uiop:call-function "cffi:load-foreign-library" in)))

(defmethod operation-done-p ((o compile-op) (c cfile))
  (let ((in  (first (input-files o c)))
        (out (first (output-files o c))))
    (and (probe-file in)
         (probe-file out)
         (> (file-write-date out) (file-write-date in)))))

(defsystem "eu.turtleware.charming-clim"
  :defsystem-depends-on (#:cffi)
  :depends-on (#:cffi #:swank)
  :components ((:static-file "tutorial.org")
               (:cfile "raw-mode")
               (:file "terminal")))

Now it is enough to load the system eu.turtleware.charming-clim in a terminal (not in Emacs!), and call the function start-display to see on the screen a string "Hello World!". Now connect to a swank server and let the hacking begin!

Escape sequences

We will control the terminal by using ANSI escape sequences and with some few extensions to receive the pointer events. To understand better how escape sequences work you may read into the following:

wikipedia article : https://en.wikipedia.org/wiki/ANSI%5Fescape%5Fcode

control sequences : https://invisible-island.net/xterm/ctlseqs/ctlseqs.html

standard ecma-48 : https://www.ecma-international.org/publications/standards/Ecma-048.htm

Escape sequences usually start with the control sequence introducer and may accept parameters. Numbers are encoded with digit characters with delimiters. Character case matters. Let's define a few utilities.

(defun put (&rest args)
  "Put raw string on a console"
  (format *console-io* "~{~a~}" args)
  (finish-output *console-io*))

(defun esc (&rest args)
  "Escape sequence"
  (apply #'put (code-char #x1b) args))

(defun csi (&rest args)
  "Control sequence introducer"
  (apply #'esc #\[ args))

(defun sgr (&rest args)
  "Select Graphic Rendition"
  (apply #'csi (append args '("m"))))

Time to add a high-level interface. These few functions illustrate how the terminal is controlled. We'll add more functions when we need them.

(defun reset-console ()
  "Clears the screen, attributes, cursor position etc."
  (esc "c"))

(defun clear-console (&optional (mode 2))
  "Erase in display"
  ;; Defined modes:
  ;; 0 - clear from cursor to the end of the display
  ;; 1 - clear from cursor to the start of the display
  ;; 2 - clear entire display
  (csi mode "J"))

(defun clear-line (&optional (mode 2))
  "Erase in line."
  ;; Defined modes:
  ;; 0 - clear from cursor to the end of the line
  ;; 1 - clear from cursor to the start of the line
  ;; 2 - clear entire line
  (csi mode "K"))

(defun set-foreground-color (r g b)
  (sgr "38;2;" r ";" g ";" b))

(defun set-background-color (r g b)
  (sgr "48;2;" r ";" g ";" b))

(defun save-cursor-position ()
  (csi "s"))

(defun restore-cursor-position ()
  (csi "u"))

(defun set-cursor-position (row col)
  (cond ((and row col)
         (csi row ";" col "H"))
        ((not (null col))
         (csi row ";H"))
        ((not (null row))
         (csi ";" col "H"))))

(defmacro with-cursor-position ((row col) &body body)
  `(progn
     (save-cursor-position)
     (set-cursor-position ,row ,col)
     (unwind-protect (progn ,@body)
       (restore-cursor-position))))

(defun (setf cursor-visibility) (visiblep)
  (if visiblep
      (csi "?" 2 5 "h")
      (csi "?" 2 5 "l")))

Time to something more fun. Typing the following in a REPL while the terminal is open gives the most satisfying result. The example below shows an important property of the terminal: the first character is addressed with a coordinate [1, 1].

(defparameter *row* 2)
(defparameter *col* 2)
(defparameter *dir* 1)
(reset-console)
(setf (cursor-visibility) nil)
(set-background-color #x00 #x22 #x22)
(set-foreground-color #xff #x22 #x22)

(declaim (notinline show-screen))
(defun show-screen ()
  (clear-console)
  (let ((str "Hello World!"))
    (set-cursor-position *row* (incf *col* *dir*))
    (cond ((>= (+ (1- *col*) (length str)) 80)
           (setf *dir* -1))
          ((<= *col* 2)
           (setf *dir* +1)))

    (with-cursor-position (*row*  1) (put "|"))
    (with-cursor-position (*row* 81) (put "|"))
    (put str)))

Now we'll improve the loop in start-display to easily modify the configuration. This step will require restarting the application because we modify the entry point.

(defmacro with-console (opts &body body)
  (declare (ignore opts))
  (let ((handler (gensym)))
    `(let ((,handler (enable-raw)))
       (unwind-protect (progn ,@body)
         (disable-raw ,handler)
         (reset-console)))))

(defun show-screen ()
  (set-cursor-position (1+ (random 24))
                       (1+ (random 80)))
  (if (zerop (random 2))
      (put "+")
      (put "-")))

(defparameter *conf*
  (list :sleep 1/60
        :cursorp nil
        :foreground '(#xff #xa0 #xa0)
        :background '(#x00 #x22 #x22)))

(defun start-display ()
  (ignore-errors (swank:create-server))
  (loop
    (with-simple-restart (run-again "Run again")
      (with-console () (display-loop)))))

(defun display-loop ()
  (loop with conf
        with seconds
        do (unless (equalp conf *conf*)
             (setf conf (copy-list *conf*))
             (destructuring-bind (&key sleep cursorp
                                       foreground background)
                 conf
               (setf seconds sleep)
               (reset-console)
               (setf (cursor-visibility) (getf conf :cursorp))
               (apply #'set-background-color background)
               (apply #'set-foreground-color foreground)
               (clear-console)))
           (sleep seconds)
           (show-screen)))

Reading the input

We've configured the terminal to accept data in raw mode. Despite that we can only read input as it is provided by the display server, there is no portable way to access raw keycode press and release events. That is unfortunate.

There are two characters that have a special meaning. ESC starts the escape sequence and DEL is not a graphical character (despite not being a control character). We will signify their uniqueness by defining appropriate constants.

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defconstant +delete+ (code-char #x7f)
    "The DEL character (#\Rubout), last in the ASCII table.")
  (defconstant +escape+ (code-char #x1b)
    "The ESC character (#\esc)."))

From the parsing perspective when we read the input we may encounter one of the following situations:

  • no characters are available
  • character is a graphic character (may span few bytes)
  • ESC starts the escape sequence which needs to be parsed
  • DEL character is read
  • character is a control character (needs to be parsed)
(defun read-input (&aux (ch (read-char-no-hang *console-io*)))
  ;; READ-CHAR may read more than one byte and return an alphanumeric
  ;; character. That's fine because we will return it as-is then.
  (cond ((or (null ch) (graphic-char-p ch))
         (return-from read-input ch))
        ((deletep ch))
        ((escapep ch))
        ((controlp ch))
        (t (error "Unknown input sequence, char code 0x~x~%."
                  (char-code ch)))))

We will use read-char-no-hang to avoid blocking. read-input will return either nil (for no available input), a graphical character, a keyword for known keys which are not graphical, or a gesture object if there are modifiers present (or a non-graphical character appears which doesn't have a keyword equivalent).

We may encounter four types of input: control characters (from C0 and C1 group), escape sequences, delete and other alphanumerical characters. Control sequence and other modifiers like Alt must be encoded, so we will define a simple class representing a gesture. The character which is read from the terminal will be always either a character, a keyword, or a gesture (or null when there's no input).

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defconstant  +c1-mod+   16)
  (defconstant  +meta-mod+  8)
  (defconstant  +ctrl-mod+  4)
  (defparameter +alt-mod+   2)
  (defconstant  +alt-mod*+  2)
  (defconstant  +shift-mod+ 1))

(defclass gesture ()
  ((key  :initarg :key  :accessor gesture-key)
   (mods :initarg :mods :accessor gesture-mods)))

(defmethod print-object ((o gesture) s)
  (print-unreadable-object (o s :type nil :identity nil)
    (let ((key (gesture-key o))
          (mods (gesture-mods o)))
      (format s "~s ~s"
              key
              (loop for p in (list +c1-mod+
                                   +meta-mod+
                                   +ctrl-mod+
                                   +alt-mod*+
                                   +shift-mod+)
                    for k in '(:C1 :Meta :Ctrl :Alt :Shift)
                    unless (zerop (logand mods p))
                      collect k)))))

Implementing functions deletep and controlp is easy. In a case of the control character we return its canonical form with a modifier. It is worth noting, that C1 group is not part of ASCII characters.

(defun control-char-p (ch &aux (code (char-code ch)))
  (or (<= 0 code 31)
      (<= 128 code 159)))

(defun controlp (ch &aux (code (char-code ch)))
  "Predicate determining if the character is a control character.
Returns a generalized boolean (when true returns a gesture)."
  (cond ((<= 0 code 31)
         (make-instance 'gesture
                        :mods +ctrl-mod+
                        :key (code-char (+ code 64))))
        ((<= 128 code 159)
         (make-instance 'gesture
                        :mods +c1-mod+
                        :key (code-char (- code 64))))))

(defun deletep (ch)
  (when (char= ch +delete+)
    :delete))

Parsing an escape sequence requires more code. The exact sequence format for special keys varies between terminal emulators. On top of that some sequences are ambiguous. We are going to focus on the most popular ones which should be compatible with most emulators. When the escape character is read and there is no further input, we return the keyword :escape. Otherwise we try to parse the sequence.

(defun escapep (ch)
  (unless (char= ch +escape+)
    (return-from escapep nil))
  (alexandria:if-let ((next-ch (read-char-no-hang *console-io*)))
    ;; The escape sequence grammar: [\[NO](<num>)(;<num>)[~A-Z].
    (multiple-value-bind (num1 num2 terminator)
        (parse-escape-sequence)
      (resolve-key next-ch num1 num2 terminator))
    :escape))

When we parse the escape sequence there are few possibilities. For instance ESC [ is known as the Control Sequence Introducer, some terminals produce ESC <char> when we press Alt+ etc. Here is the approach we are going to take:

  • if we read ESC <char> with no further input, assume Alt+
  • if we read ESC <char> and there is further input we try to parse the sequence with two optional numbers and a terminating character
  • we try to resolve the character by comparing with known sequences

Function parse-escape-sequence tries to read the sequence with two numbers defaulting to one and returns (values num1 num2 char). If there is nothing to read, the last value is NIL. Escape sequence looks like this: ESC GROUP-CHAR (NUM1) (';' NUM2) TERMINATING-CHAR.

(defun parse-escape-sequence ()
  (let ((char (read-char-no-hang *console-io*))
        (num1 1)
        (num2 1))
    (flet ((read-num ()
             (loop while (and char (digit-char-p char))
                   collecting char into num
                   do (setf char (read-char-no-hang *console-io*))
                   finally (when num
                             (return (parse-integer (coerce num 'string)))))))
      (setf num1 (or (read-num) 1))
      (when (null char)
        (return-from parse-escape-sequence (values num1 num2 char)))
      (when (char= char #\;)
        (setf char (read-char-no-hang *console-io*)
              num2 (or (read-num) 1)))
      (values num1 num2 char))))

We want to be able to define new escape sequences when needed, so we will create a small macro responsible for registering new ones. It will use the appropriate parser based on the group and the terminator character. The function accepts two numeric arguments.

(eval-when (:compile-toplevel :load-toplevel  :execute)
  (defvar *key-resolvers* (make-hash-table)))

(defmacro define-key-resolver (group terminator (num1 num2) &body body)
  `(setf (gethash ,(+ (char-code terminator)
                      (ash (char-code group) 8))
                  (progn *key-resolvers*))
         (lambda (,num1 ,num2)
           (declare (ignorable ,num1 ,num2))
           ,@body)))

Some escape sequences are used to encode keys. In that case the second number represents the key modifiers. When it is decremented by one, then it is a modifier bit-field. We also need to account for control characters. This is implemented in the utility called maybe-combo:

(defun maybe-combo (key num2)
  (alexandria:if-let ((ctrl (and (characterp key) (controlp key))))
    (prog1 ctrl
      (setf (gesture-mods ctrl) (logior (1- num2) +ctrl-mod+)))
    (or (and (= num2 1) key)
        (make-instance 'gesture :key key :mods (1- num2)))))

Now is time to define a handful of known sequences (from the CSI group and from the SS3):

(define-key-resolver #\[ #\~ (num1 num2)
  (let ((key (case num1
               (1 :home) (2  :insert) (3    :delete)
               (4  :end) (5 :page-up) (6 :page-down)
               (11  :f1) (12 :f2)  (13  :f3) (14  :f4) ; deprecated
               (15  :f5) (17 :f6)  (18  :f7) (19  :f8)
               (20  :f9) (21 :f10) (23 :f11) (24 :f12)
               (25 :f13) (26 :f14) (28 :f15) (29 :f16)
               (31 :f17) (32 :f18) (33 :f19) (34 :f20))))
    (maybe-combo key num2)))

(define-key-resolver #\[ #\A (num1 num2) (maybe-combo :key-up    num2))
(define-key-resolver #\[ #\B (num1 num2) (maybe-combo :key-down  num2))
(define-key-resolver #\[ #\C (num1 num2) (maybe-combo :key-right num2))
(define-key-resolver #\[ #\D (num1 num2) (maybe-combo :key-left  num2))

(define-key-resolver #\O #\P (num1 num2) (maybe-combo :f1 num2))
(define-key-resolver #\O #\Q (num1 num2) (maybe-combo :f2 num2))
(define-key-resolver #\O #\R (num1 num2) (maybe-combo :f3 num2))
(define-key-resolver #\O #\S (num1 num2) (maybe-combo :f4 num2))

And, finally, the function resolve-key which is called by escapep. When the read is incomplete, then it assumes a combination Alt+, otherwise it calls the key resolver. If there is no defined resolver for a sequence we create an "unknown" gesture, which may be inspected to learn the reported escape sequence.

(defun resolve-key (group num1 num2 |Hasta la vista, baby|)
  (if (null |Hasta la vista, baby|)
      ;; When there is no terminating character, then it is probably a
      ;; result of pressing ALT+<char>. This is ambiguous, i.e ALT+[
      ;; generates CSI. We try to be as robust as we can here.
      (maybe-combo (case group
                     (#.+escape+ :escape)
                     (#.+delete+ :delete)
                     (t group))
                   (1+ +alt-mod+))
      (funcall (gethash (+ (char-code |Hasta la vista, baby|)
                           (ash (char-code group) 8))
                        *key-resolvers*
                        #'(lambda (num1 num2)
                            (let ((k (format nil
                                             "Unknown sequence: ESC ~c ~d ~d ~c"
                                             group num1 num2
                                             |Hasta la vista, baby|)))
                              (make-instance 'gesture :key k :mods 0))))
               num1 num2)))

With all that in place, all what is left is the test code. It will print characters which are on the terminal, so we can verify if they are properly recognized. Notice, that we do not clear a whole line after printing the sequence (only the reminder of it) to avoid unnecessary flicker. Some key combinations like Alt+F4 may be intercepted by the window manager.

(let ((characters nil))
  (defun show-screen ()
    (loop for ch = (read-input)
          until (null ch)
          do (push ch characters))
    (setf characters (subseq characters 0 (min 12 (length characters))))
    (set-cursor-position (1+ (random 12))
                         (1+ (random 40)))
    (if (zerop (random 2))
        (put "+")
        (put "-"))
    (with-cursor-position (1 44)
      (loop for row from 1
            for ch in characters
            do (set-cursor-position row 44)
               (format *console-io* (format nil "Read: ~s" ch))
               (clear-line 0)))))

You might have noticed, that the +alt-mod+ is defined to be a parameter. This is to allow mapping the key ALT to META.

(defun (setf alt-is-meta) (bool)
  (if bool
      (setf +alt-mod+ +meta-mod+)
      (setf +alt-mod+ +alt-mod*+)))

Civilizing the interface

We can do quite a lot already. Our previous demo, despite being pretty basic, proves that. We want to add some interactive behavior to the application and assign actions to some key combinations. First though we'll refactor our abstraction so there is less global state. We will also isolate the low-level terminal access in init-console and close-console functions, so we may treat the handler as an opaque object. We retain the variable *console-io*, but we bind it only in the console context. We also bind there a variable *console*.

(defun init-console ()
  (prog1 (enable-raw)
    (reset-console)))

(defun close-console (handler)
  (disable-raw handler)
  (reset-console))

(defvar *console*)
(defvar *console-io*)

(defclass console ()
  ((ios :initarg :ios :accessor ios :documentation "I/O stream for the terminal.")
   (fgc :initarg :fgc :accessor fgc :documentation "Foregorund color.")
   (bgc :initarg :bgc :accessor bgc :documentation "Background color.")
   (pos :initarg :pos :accessor pos :documentation "Cursor position.")
   (cvp :initarg :cvp :accessor cvp :documentation "Cursor visibility.")
   (fps :initarg :fps :accessor fps :documentation "Desired framerate.")
   (app :initarg :app :accessor app :documentation "Application state.")
   (hnd               :accessor hnd :documentation "Terminal handler."))
  (:default-initargs
   :ios (error "I/O stream must be specified.")
   :fgc '(#xff #xa0 #xa0)
   :bgc '(#x00 #x22 #x22)
   :pos '(1 . 1)
   :cvp nil
   :fps 60
   :app nil))

(defmethod initialize-instance :after ((instance console) &key ios fgc bgc cvp)
  (setf (hnd instance) (init-console))
  (apply #'set-foreground-color fgc)
  (apply #'set-background-color bgc)
  (setf (cursor-visibility) cvp))

(defmacro with-console ((&rest args
                         &key ios fgc bgc cvp fps &allow-other-keys)
                        &body body)
  (declare (ignore fgc bgc cvp fps))
  `(let* ((*console-io* ,ios)
          (*console* (make-instance 'console ,@args)))
     (unwind-protect (progn ,@body)
       (close-console (hnd *console*)))))

(defun start-display ()
  (ignore-errors (swank:create-server))
  (loop
    (with-simple-restart (run-again "Run again")
      (with-console (:ios *terminal-io*)
        (display-loop)))))

(defun display-loop ()
  (clear-console)
  (loop (sleep (/ (fps *console*)))
        (show-screen)))

To add some interactive behavior we want to assign actions to keys. We'll define a predicate deciding whether a key matches supplied parameters.

(defun keyp (ch key &rest mods)
  (if (null mods)
      (eql ch key)
      (and (typep ch 'gesture)
           (eql (gesture-key ch) key)
           (eql (gesture-mods ch)
                (loop for m in mods
                      summing (ecase m
                                (:c1 +c1-mod+)
                                (:m  +meta-mod+)
                                (:c  +ctrl-mod+)
                                (:a  +alt-mod*+)
                                (:s  +shift-mod+)))))))

Now we will add three key combinations:

C-q : exit the application

C-r : clear the console (i.e to wipe glitches)

C-u : call the user function

(defun show-screen ()
  (loop for ch = (read-input)
        until (null ch)
        do (push ch (app *console*))
           (cond ((keyp ch #\Q :c)
                  (cl-user::quit))
                 ((keyp ch #\R :c)
                  (setf (app *console*) nil)
                  (clear-console))
                 ((keyp ch #\U :c)
                  (ignore-errors (user-action)))))
  (let ((ch (app *console*)))
    (setf (app *console*)
          (subseq ch 0 (min 12 (length ch)))))
  (set-cursor-position (1+ (random 12))
                       (1+ (random 40)))
  (if (zerop (random 2))
      (put "+")
      (put "-"))
  (with-cursor-position (1 44)
    (loop for row from 1
          for ch in (app *console*)
          do (set-cursor-position row 44)
             (format *console-io* (format nil "Read: ~s" ch))
             (clear-line 0))))

Notice that instead of a closure we use the slot app. Function user-action may be defined from REPL - when C-u is pressed it will be executed. It may be used for instance to change the configuration. We still need to add appropriate methods that set the console on the configuration change.

(defmethod (setf fgc) :after (rgb (instance console))
  (apply #'set-foreground-color rgb))

(defmethod (setf bgc) :after (rgb (instance console))
  (apply #'set-background-color rgb))

(defmethod (setf pos) :before (pos (instance console))
  (check-type (car pos) (integer 1))
  (check-type (cdr pos) (integer 1)))

(defmethod (setf pos) :after (pos (instance console))
  (set-cursor-position (car pos) (cdr pos)))

(defmethod (setf cvp) :after (cvp (instance console))
  (setf (cursor-visibility) (not (null cvp))))

;; for example
(defun user-action ()
  (setf (fgc *console*) (list (random 255) (random 255) (random 255)))
  (setf (bgc *console*) (list (random 255) (random 255) (random 255)))
  (clear-console))

We still don't have any means to limit the terminal region for output. This operation is known as clipping in graphics. We are going to implement a flexible mechanism based on dynamic variables. For simple clipping we provide min/max row/col, and for more complex use cases a custom predicate may be specified. The macro is called with-clipping and may be nested to achieve the intersection of the clipping areas.

The macro out allows specifying a row, a column, a foreground color and a background color. It respects clipping limitations by testing each character. The state of the console is left as it was before invoking the operator.

(defvar *row1* '(1))
(defvar *col1* '(1))
(defvar *row2* '(24))
(defvar *col2* '(80))
(defvar *fun* (list (constantly t)))

(defmacro with-clipping ((&key fun row1 col1 row2 col2) &body body)
  `(let (,@(when row1 `((*row1* (cons (max (car *row1*) ,row1) *row1*))))
         ,@(when col1 `((*col1* (cons (max (car *col1*) ,col1) *col1*))))
         ,@(when row2 `((*row2* (cons (min (car *row2*) ,row2) *row1*))))
         ,@(when col2 `((*col2* (cons (min (car *col2*) ,col2) *col2*))))
         ,@(when fun  `((*fun*  (cons (let ((old (car *fun*)))
                                        (lambda (row col)
                                          (and (funcall ,fun row col)
                                               (funcall old row col))))
                                      (progn *fun*))))))
     ,@body))

(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)))))

(defun inside (row col)
  (and (<= (car *row1*) row (car *row2*))
       (<= (car *col1*) col (car *col2*))
       (funcall (car *fun*) row col)))

(defmacro out ((&key row col fgc bgc) object)
  "Put an object on a console"
  (let ((pos (cond ((and row col) `(cons ,row ,col))
                   (row `(cons ,row (cdr (pos *console*))))
                   (col `(cons (car (pos *console*)) col)))))
    `(let ((str (princ-to-string ,object)))
       (assert (null (find #\newline str)))
       (letf (((pos *console*) (cons (or ,row (car (pos *console*)))
                                     (or ,col (cdr (pos *console*)))))
              ,@(when fgc `(((fgc *console*) ,fgc)))
              ,@(when bgc `(((bgc *console*) ,bgc))))
         (let* ((pos (pos *console*))
                (row (car pos))
                (col (cdr pos)))
           (loop for c from col
                 for s across str
                 when (inside row c)
                   do (put s)))))))

Another important functionality is a way to clear a specific region. That and other user-facing control utilities will be available from the operator ctl.

(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)))

(defmacro ctl (&rest operations)
  `(progn
     ,@(loop for op in operations
             collect (destructuring-bind (name &rest args) op
                       (ecase name
                         (:clr `(clear-rectangle ,@args))
                         (:fgc `(setf (fgc *console*) (list ,@args)))
                         (:bgc `(setf (bgc *console*) (list ,@args)))
                         (:cvp `(setf (cursor-visibility) ,@args))
                         (:pos `(setf (pos *console*) (cons ,(car args)
                                                            ,(cdr args)))))))))

Time to use our new tools to a new version of the function show-screen and the function user-action. In show-screen we define a local function ll which is a predicate responsible for clipping output to the lambda shape. In the first clipping body we limit drawing to said ad-hoc lambda and clip out the first and the last row for aesthetic reasons. The second body in with-clipping does the opposite: draws everywhere in the drawing plane except for the lambda drawing. Finally we implement a user action which clears part of the drawing area. To invoke it press C-u.

(defun show-screen ()
  (loop for ch = (read-input)
        until (null ch)
        do (push ch (app *console*))
           (cond ((keyp ch #\Q :c)
                  (cl-user::quit))
                 ((keyp ch #\R :c)
                  (setf (app *console*) nil)
                  (clear-console))
                 ((keyp ch #\U :c)
                  (ignore-errors (user-action)))))
  (let ((ch (app *console*)))
    (setf (app *console*)
          (subseq ch 0 (min 12 (length ch)))))
  (flet ((ll (row col)
           (or (and (< (abs (- (+ col row) 26)) 2)
                    (<= col 20))
               (< (abs (- (+ (- 40 col) row) 26)) 2))))
    (with-clipping (:fun #'ll :row1 2 :row2 11)
      (out (:row (1+ (random 12))
            :col (1+ (random 40))
            :bgc `(0 0 0)
            :fgc '(#xbb #x00 #x00))
           (alexandria:random-elt '("X" "O"))))
    (with-clipping (:fun (lambda (row col)
                           (or (= row 1)
                               (= row 12)
                               (funcall (complement #'ll) row col))))
      (out (:row (1+ (random 12))
            :col (1+ (random 40))
            :bgc `(0 0 0)
            :fgc (list #x00
                       (alexandria:random-elt '(#x44 #x44 #x44 #x44 #x66))
                       #x44))
           (alexandria:random-elt '("+" "-")))))
  (ctl (:clr 1 44 12 (car *col2*)))
  (loop for row from 1
        for ch in (app *console*)
        do (out (:row row :col 44)
                (prin1-to-string ch))))

(defun user-action ()
  (ctl (:fgc (random 255) (random 255) (random 255))
       (:bgc (random 255) (random 255) (random 255))
       (:clr 4 4 10 10)))

Clearing the screen part with (:clr 1 44 12 (car *col2*)) may cause a flicker on terminal emulators with slow refresh rate. For now we will reduce the FPS, but later we will take another approach to avoid this problem.

(defclass console ()
  (#|...|#)
  (:default-initargs
   #|...|#
   :fps 10
   #|...|#))

Determining the terminal dimensions

Time to learn how to determine the terminal size. We already know how to set a cursor position. Interesting property of this command is that if we request to set its position beyond the terminal limits, the cursor will be positioned on a terminal boundary instead. That's how we are going to determine the terminal size.

(defun request-cursor-position ()
  (csi 6 "n"))

(defun user-action ()
  (with-cursor-position (10 3)
    (request-cursor-position)))

When we execute the user command by pressing C-u our program will tell us, that an unknown sequence has been read: ESC [ 10 3 R. Indeed, that's the sequence that is documented as a result. We will define a condition to signal, that the cursor-position-report has arrived. When the sequence is read a condition is signaled and a gesture is returned.

(define-condition cursor-position-report ()
  ((rows :initarg :row :reader row)
   (cols :initarg :col :reader col)))

(define-key-resolver #\[ #\R (row col)
  (signal 'cursor-position-report :row row :col col)
  (make-instance 'gesture
                 :key (format nil "Cursor position: ~s ~s" row col)
                 :mods 0))

We will use it to print a character on the right bottom cell to see if it works. An important bit of information is that if we set the cursor beyond the terminal, it will be positioned over the last cell instead, so if we request the position back, we should receive a total number of rows and columns of the terminal.

To do that we'll add slots to the class console and add a handler above the read-input which will assign these slots. Moreover we will modify the user-action to request the cursor position after setting it a big value. Now when we press C-u, the character should appear on the bottom-right corner of the terminal. Notice, that we also update the clipping area (row2 and col2). Otherwise the character would have been filtered.

(defclass console ()
  (#|...|#
   (rows :accessor rows :initform 24 :documentation "Terminal number of rows.")
   (cols :accessor cols :initform 80 :documentation "Terminal number of cols."))
  #|...|#)

(defun show-screen ()
  (loop for ch = (handler-case (read-input)
                   (cursor-position-report (c)
                     (let ((row (row c))
                           (col (col c)))
                       (setf *row2* (list row))
                       (setf *col2* (list col))
                       (setf (rows *console*) row)
                       (setf (cols *console*) col)))
                     nil)
        #|...|#)
  #|...|#
  (out (:row (rows *console*)
        :col (cols *console*))
       "×"))

(defun user-action ()
  (with-cursor-position ((expt 2 16) (expt 2 16))
    (request-cursor-position)))

We are left with a few problems:

  • old markers don't disappear unless we reset the whole console
  • any cursor position request will end up in resizing of the console
  • the console is not resized automatically

We could have incorporated installing a signal handler for the sigwinch, but we'll settle on a simpler solution which will be incorporated when we refactor the I/O model in the next post. For now we'll initialize the size when initializing the console and when resetting it.

(defun get-cursor-position ()
  (request-cursor-position)
  ;; If the appropriate key resolver is not defined, this will loop
  ;; forever and the application will freeze.
  (handler-case (loop (read-input))
    (cursor-position-report (c)
      (values (row c) (col c)))))

(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 *row2* (list rows))
      (setf *col2* (list cols)))))

(defmethod initialize-instance :after
    ((instance console) &key fgc bgc pos cvp)
  #| ... |#
  (let ((*console* instance))
    (update-console-dimensions)))

(defun show-screen ()
  (loop #| ... |#
    (cond (#| ... |#
           ((keyp ch #\R :c)
            (setf (app *console*) nil)
            (update-console-dimensions)
            (clear-console))
           #| ... |#)))
  #| ... |#)

Adding a mouse tracking support

Terminal emulators which are compatible with xterm allow tracking the mouse. There are few possible modes (i.e track only mouse clicks), as well as a few schemes for reporting events. We are interested in tracking all events reported in the extended scheme (because the "default" scheme has serious limitations due to byte encoding).

;;; (csi ? tracking ; encoding h/l)
;;; tracking: 1000 - normal, 1002 - button, 1003 - all motion
;;; encoding: 1006 - sgr encoding scheme
(defun (setf mouse-tracking) (enabledp)
  (if enabledp
      (csi "?" 1003 ";" 1006 "h")
      (csi "?" 1003 "l")))

Each event is reported as ESC [ > Cb;Cx;Cy m/M. Cb encodes pressed buttons, Cx and Cy are integers put in text for the event column and row. Until now we were only parsing input sequences which have two numbers, so it is time to improve the parse-escape-sequence function to accept any number of semicolon separated integers:

(defun parse-escape-sequence (&aux char)
  (flet ((read-num ()
           (loop while (and char (digit-char-p char))
                 collecting char into num
                 do (setf char (read-char-no-hang *console-io*))
                 finally (when num
                           (return (parse-integer (coerce num 'string)))))))
    (loop
      do (setf char (read-char-no-hang *console-io*))
      collect (or (read-num) 1) into nums
      until (or (null char)
                (char/= #\; char))
      finally (return (values nums char)))))

(defun escapep (ch)
  (unless (char= ch +escape+)
    (return-from escapep nil))
  (alexandria:if-let ((next-ch (read-char-no-hang *console-io*)))
    ;; A keycode: [\[NO](<num>)(;<num>)[~A-Z].
    (multiple-value-bind (nums terminator)
        (parse-escape-sequence)
      (destructuring-bind (&optional (num1 1) (num2 1)) nums
        (resolve-key next-ch num1 num2 terminator)))
    :escape))

Mouse state encoded in Cb works as follows:

  • if the sixth bit (32) is "on", it is a motion event
  • otherwise terminating character #\M is "press", #\m is "release"
  • modifiers are encoded in third to fifth bits (shift, alt, ctrl)
  • pressed mouse button is encoded in two first bits, and seventh/eight

This bit twiddling is a good opportunity to use ldb and ash as seen below:

(defun resolve-mouse (btn col row |Hasta la vista, baby|)
  (let ((state (cond ((not (zerop (ldb (cons 1 5) btn))) :motion)
                     ((char= #\M |Hasta la vista, baby|) :press)
                     ((char= #\m |Hasta la vista, baby|) :release)))
        (mods (+ (if (zerop (ldb (cons 1 2) btn)) 0 +shift-mod+)
                 (if (zerop (ldb (cons 1 3) btn)) 0 +alt-mod+)
                 (if (zerop (ldb (cons 1 4) btn)) 0 +ctrl-mod+)))
        (key (case (+ (ldb (cons 2 0) btn)
                      (ash (ldb (cons 2 6) btn) 2))
               (#b0000 :left)
               (#b0001 :middle)
               (#b0010 :right)
               (#b0011 :none)
               ;; 64
               (#b0100 :wheel-up)
               (#b0101 :wheel-down)
               (#b0110 :wheel-left)
               (#b0111 :wheel-right)
               ;; 128 (xterm >= 341)
               (#b1000 :extra-1)
               (#b1001 :extra-2)
               (#b1010 :extra-3)
               (#b1011 :extra-4))))
    (make-instance 'gesture
                   :key (format nil "row: ~2d col: ~2d [~a ~a] ~a"
                                row col key btn state)
                   :mods mods)))

Now we add handling mouse to the escapep function and allow enabling it in user-action:

(defun escapep (ch)
  (unless (char= ch +escape+)
    (return-from escapep nil))
  (alexandria:if-let ((next-ch (read-char-no-hang *console-io*)))
    ;; A keycode: [\[NO](<num>)(;<num>)[~A-Z].
    ;; SGR mouse: '[' '<' num ';' num ';' num ';' [Mm]
    (if (and (char= #\[ next-ch)
             (char= #\< (peek-char t *console-io* nil #\x))
             (read-char-no-hang *console-io*))
        (multiple-value-bind (nums terminator)
            (parse-escape-sequence)
          (destructuring-bind (num1 num2 num3) nums
            (resolve-mouse num1 num2 num3 terminator)))
        (multiple-value-bind (nums terminator)
            (parse-escape-sequence)
          (destructuring-bind (&optional (num1 1) (num2 1)) nums
            (resolve-key next-ch num1 num2 terminator))))
    :escape))

(defun user-action ()
  (setf (mouse-tracking) t))

When you press C-u now all mouse events should be reported i.e as #<"row: 13 col: 95 [LEFT 0] RELEASE" NIL>. It is noteworthy that some terminals despite claiming that they are xterm-compatible, may behave differently. I.e on KDE's Konsole mouse motion is reported only when any mouse button is pressed.

Finally, it is time to integrate the pointer tracking in our ctl interface and to the console class.

(defmacro ctl (&rest operations)
  #|...|#
  (:ptr `(setf (mouse-tracking) ,@args))
  #|...|#)

(defclass console ()
  (#|...|#
   (ptr :initarg :ptr :accessor ptr :documentation "Pointer tracking.")
   #|...|#)
  (:default-initargs #|...|# :ptr t #|... |#))


(defmethod initialize-instance :after
    ((instance console) &key fgc bgc pos cvp ptr)
  #|...|#
  (setf (mouse-tracking) ptr)
  #|...|#)

(defmethod (setf ptr) :after (ptr (instance console))
  (setf (mouse-tracking) (not (null ptr))))

Some terminal emulators bind the command "paste primary selection" to the middle button press action, so don't be surprised when they do.

Conclusions

This is the first part of a tutorial which is split in five:

  1. Controlling the terminal
  2. Rethinking the Input/Output
  3. Rendering on the console
  4. Rendering on the console (2)
  5. Writing a McCLIM backend

In the second post we'll construct a frame manager with windows and animations as well as scrolling and other common abstractions. In the third one we'll go through state-of-the-art algorithms to be able to render lines, curves, and such. The fourth will extend concepts of the third one by adding styles and alpha blending. The fifth part will be a guide about how to write a backend for McCLIM.

There will be three outcomes of this case study:

  • A standalone TUI toolkit independent of ncurses (and CLIM)
  • McCLIM backend for the terminal based on the above
  • Documentation for McCLIM on how to write new backends

My main motivations were to make some rendering issues in McCLIM apparent by growing a pixel into something as big and non-square as a terminal cell and to have plenty of fun while hacking something amusing. The second goal is already achieved!

I'd like to thank Jānis Džeriņš, Michał Herda and Christoph Keßler for offering the help with this text review and providing useful hints. All mistakes are mine :-). Please don't hesitate to contact me with questions and remarks.

If you feel like supporting me with my FLOSS contributions you may become my patron here https://www.patreon.com/jackdaniel%5Fkochmanski.

Michał HerdaCall for review: package-local nicknames on CLISP

· 39 days ago

#CommonLisp #Lisp

Joram Schrijver, known as mood on Freenode, has implemented package-local nicknames on CLISP.

If anyone is anyhow familiar with the CLISP codebase and is capable of reviewing that merge request, please review it - it is an important last step in pushing support for package-local nicknames across all of the Common Lisp ecosystem. (They are already supported by SBCL, CCL, ECL, Clasp, ABCL, ACL, and will be supported in LispWorks 7.2)


For older items, see the Planet Lisp Archives.


Last updated: 2020-07-03 18:52