fidzu : LISP

This library provides a few methods to work with data tables. Think about it as a limited version of Pandas Dataframe for Common Lisp.

Data-table abilities are really modest. For example, it does not provide methods to investigate data in the table.

To overcome this limitation, we'll use another library - cl-ascii-table and define a describe-object method for data tables:

POFTHEDAY> (defparameter *dt*
             (make-instance 'data-table:data-table
                            :column-names '("Name" "Birthday" "Age")
                            :rows '(("Bob" "1985-05-17" 35)
                                    ("Alice" "1989-02-23" 31)
                                    ("John" "2000-01-03" 20))))

;; This is what we'll wee by default:
POFTHEDAY> (describe *dt*)
#<DATA-TABLE:DATA-TABLE {1003D50293}>
  [standard-object]

Slots with :INSTANCE allocation:
  COLUMN-NAMES                   = ("Name" "Birthday" "Age")
  COLUMN-TYPES                   = (STRING STRING (INTEGER 0 4611686018427387903))
  ROWS                           = (("Bob" "1985-05-17" 35) ("Alice" "1989-02-23" 31))

;; But with custom method we might make it more
;; more convenient:
POFTHEDAY> (defmethod describe-object ((obj data-table:data-table) stream)
             (loop with table = (ascii-table:make-table
                                 (data-table:column-names obj))
                   for row in (data-table:rows obj)
                   do (ascii-table:add-row table row)
                   finally (ascii-table:display table)))

POFTHEDAY> (describe *dt*)
+-------+------------+-----+
| Name  | Birthday   | Age |
+-------+------------+-----+
| Bob   | 1985-05-17 |  35 |
| Alice | 1989-02-23 |  31 |
| John  | 2000-01-03 |  20 |
+-------+------------+-----+

Now let's see what capabilities for data slicing does it have.

Here is how we can retrieve columns. Pay attention, column names are case insensitive. But if case mismatch, column names of the resulting table will be different. Maybe this is a bug:

POFTHEDAY> (describe
            (data-table:select-columns *dt*
                                       '("Name" "Age")))
+-------+-----+
| Name  | Age |
+-------+-----+
| Bob   |  35 |
| Alice |  31 |
| John  |  20 |
+-------+-----+
; No values
POFTHEDAY> (describe
            (data-table:select-columns *dt*
                                       '("name" "age")))
+-------+-----+
| name  | age |
+-------+-----+
| Bob   |  35 |
| Alice |  31 |
| John  |  20 |
+-------+-----+

There is also a way to select a subtable using indices.

This is how we can select contiguous columns with "Name" and "Age" labels:

;; We have to do call this method first.
;; It will fill a list of datatypes.
;; Without filled list of datatypes, make-sub-table will fail :(

POFTHEDAY> (data-table:coerce-data-table-of-strings-to-types *dt*)

POFTHEDAY> (describe
            (data-table:make-sub-table *dt*
                                       :lci 1 :uci 3))
+------------+-----+
| Birthday   | Age |
+------------+-----+
| 1985-05-17 |  35 |
| 1989-02-23 |  31 |
| 2000-01-03 |  20 |
+------------+-----+

If we want to select only the last two rows, then we have to do some math:

;; In pandas.DataFrame this will be just: dt.tail(2)
;;
POFTHEDAY> (let ((rows-count (data-table:number-of-rows *dt*)))
             (describe
              (data-table:make-sub-table *dt*
                                         :lri (- rows-count 2)
                                         :uri rows-count)))
+-------+------------+-----+
| Name  | Birthday   | Age |
+-------+------------+-----+
| Alice | 1989-02-23 |  31 |
| John  | 2000-01-03 |  20 |
+-------+------------+-----+

Also, we can combine column selection by name with make-sub-table. But this will create an intermediate table.

There is also a method overlay-region to combine two tables. Let's use it to add email for Genry and Mary:

POFTHEDAY> (defparameter *dt*
             (data-table:plists-to-data-table
              '((:id 1 :name "Bob")
                (:id 2 :name "Genry")
                (:id 3 :name "Mary"))))

POFTHEDAY> (describe *dt*)
+----+-------+
| ID | NAME  |
+----+-------+
|  1 | Bob   |
|  2 | Genry |
|  3 | Mary  |
+----+-------+

POFTHEDAY> (data-table:overlay-region
            (data-table:plists-to-data-table
             '((:email "genry@gmail.com")
               (:email "mary@hormail.com")))
            *dt*)
NIL

POFTHEDAY> (describe *dt*)
+------------------+-------+
| ID               | NAME  |
+------------------+-------+
| genry@gmail.com  | Bob   |
| mary@hormail.com | Genry |
|                3 | Mary  |
+------------------+-------+

POFTHEDAY> ;; Oh, this method modified the original table :(((

To fix the issue, we need to recreate an original table and to specify indexes for applied overlay:

POFTHEDAY> (defparameter *dt*
             (data-table:plists-to-data-table
              '((:id 1 :name "Bob")
                (:id 2 :name "Genry")
                (:id 3 :name "Mary"))))

POFTHEDAY> (data-table:overlay-region
            (data-table:plists-to-data-table
             '((:email "genry@gmail.com")
               (:email "mary@hormail.com")))
            *dt*
            :col-idx 2
            :row-idx 1)

;; But new column has no name now :(
POFTHEDAY> (describe *dt*)
+----+-------+------------------+
| ID | NAME  | NIL              |
+----+-------+------------------+
|  1 | Bob   | NIL              |
|  2 | Genry | genry@gmail.com  |
|  3 | Mary  | mary@hormail.com |
+----+-------+------------------+

It would be nice to have support for indices and joins like in Pandas. That is what I expect from the data manipulation library.

We've viewed almost all core functions of the data-table library. There are also data coercion and comparison functions. But I think this library has lots of room for improvement.

Maybe @guicho271828 has plans to build a dataframe library as supplementary to his NumCL?

29 May 2020 12:15am GMT

This system adds Unicode support to the cl-ppcre.

What does it mean? It means that after loading cl-ppcre-unicode you'll be able to match against Unicode symbol properties.

A property matcher has a special syntax in cl-ppcre's regexps: \p{PropertyName}.

Here is an example:

;; This is how we can find out a position
;; of the first Cyrillic letter:

POFTHEDAY> (ppcre:scan "\\p{Cyrillic}"
                       "123Ю56")
3

;; Here we are extracting a
;; sequence of Emoji from the text:
POFTHEDAY> (ppcre:regex-replace
            ".*?([\\p{Emoticons}|\\p{Supplemental Symbols and Pictographs}]+).*"
            "Hello, Lisper! 🤗😃 How are you?"
            "\\1")
"🤗😃"

We are using two different Unicode classes as properties because these two characters belong to different classes.

You can use cl-unicode to discover the character's unicode class:

POFTHEDAY> (cl-unicode:code-block #\😃)
"Emoticons"

POFTHEDAY> (cl-unicode:code-block #\🤗)
"Supplemental Symbols and Pictographs"

The way, how cl-ppcre-unicode works is very interesting. It turns out that cl-ppcre has a special hook which allows you to define a property resolver.

For example, if you want to have a special property for vowels, you might do something like that:

POFTHEDAY> (defun my-property-resolver (property-name)
             (if (string-equal property-name
                               "vowel")
                 (rutils:fn vovel-p (character)
                   (member character '(#\A #\E #\I #\O #\U)
                           :test #'char-equal))
                 (cl-ppcre-unicode:unicode-property-resolver
                  property-name)))

POFTHEDAY> (setf cl-ppcre:*property-resolver*
                 #'my-property-resolver)

;; And now we can use the "Vowel" property in any
;; regular expressions!
POFTHEDAY> (ppcre:regex-replace-all
            "\\p{Vowel}"
            "Hello, Lisper! How are you?"
            "")
"Hll, Lspr! Hw r y?"

Isn't this cool!? 🤪

27 May 2020 8:15pm GMT

JOSE is an implementation of Javascript Object Signing and Encryption.

This @nitro_idiot's library implements a JSON Web Signature and allows to encode, decode and inspect JWT tokens.

JOSE can be useful to implement signed token exchange between microservices.

I found a great article on what JWT, JWS and JWE are. Read it you want more about them. To demonstrate, how does token inspection work, I took a JWT token from the article and parsed it with Common Lisp JOSE:

POFTHEDAY> (jose/jwt:inspect-token
            "eyJhbGciOiJSUzI1NiIsImtpZCI6Ijc4YjRjZjIzNjU2ZGMzOTUzNjRmMWI2YzAyOTA3NjkxZjJjZGZmZTEifQ.eyJpc3MiOiJhY2NvdW50cy5nb29nbGUuY29tIiwic3ViIjoiMTEwNTAyMjUxMTU4OTIwMTQ3NzMyIiwiYXpwIjoiODI1MjQ5ODM1NjU5LXRlOHFnbDcwMWtnb25ub21ucDRzcXY3ZXJodTEyMTFzLmFwcHMuZ29vZ2xldXNlcmNvbnRlbnQuY29tIiwiZW1haWwiOiJwcmFiYXRoQHdzbzIuY29tIiwiYXRfaGFzaCI6InpmODZ2TnVsc0xCOGdGYXFSd2R6WWciLCJlbWFpbF92ZXJpZmllZCI6dHJ1ZSwiYXVkIjoiODI1MjQ5ODM1NjU5LXRlOHFnbDcwMWtnb25ub21ucDRzcXY3ZXJodTEyMTFzLmFwcHMuZ29vZ2xldXNlcmNvbnRlbnQuY29tIiwiaGQiOiJ3c28yLmNvbSIsImlhdCI6MTQwMTkwODI3MSwiZXhwIjoxNDAxOTEyMTcxfQ.TVKv-pdyvk2gW8sGsCbsnkqsrS0T-H00xnY6ETkIfgIxfotvFn5IwKm3xyBMpy0FFe0Rb5Ht8AEJV6PdWyxz8rMgX2HROWqSo_RfEfUpBb4iOsq4W28KftW5H0IA44VmNZ6zU4YTqPSt4TPhyFC9fP2D_Hg7JQozpQRUfbWTJI")

(("exp" . 1401912171) ("iat" . 1401908271) ("hd" . "wso2.com")
 ("aud"
  . "825249835659-te8qgl701kgonnomnp4sqv7erhu1211s.apps.googleusercontent.com")
 ("email_verified" . T) ("at_hash" . "zf86vNulsLB8gFaqRwdzYg")
 ("email" . "prabath@wso2.com")
 ("azp"
  . "825249835659-te8qgl701kgonnomnp4sqv7erhu1211s.apps.googleusercontent.com")
 ("sub" . "110502251158920147732") ("iss" . "accounts.google.com"))

(("alg" . "RS256") ("kid" . "78b4cf23656dc395364f1b6c02907691f2cdffe1"))

#(77 82 175 250 151 114 190 77 160 91 203 6 176 38 236 158 74 172 173 45 19 248
  125 52 198 118 58 17 57 8 126 2 49 126 139 111 22 126 72 192 169 183 199 32
  76 167 45 5 21 237 17 111 145 237 240 1 9 87 163 221 91 44 115 242 179 32 95
  97 209 57 106 146 163 244 95 17 245 41 5 190 34 58 202 184 91 111 10 126 213
  185 31 66 0 227 133 102 53 158 179 83 134 19 168 244 173 225 51 225 200 80
  189 124 253 131 252 120 59 37 10 51 165 4 84 125 181 147 36)

Inspect returns payload, headers and the signature.

There are also two methods encode and decode. Here is how we can use them to issue and verify JWT token:

POFTHEDAY> (defparameter
               *secret* (ironclad:ascii-string-to-byte-array
                         "I Love Common Lisp!"))

POFTHEDAY> (defparameter
               *token*
             (jose:encode :hs256 *secret*
                          '(("user"  . "Bob")
                            ("email" . "bob@gmail.com"))))

;; Now this token can be sent to the authenticated
;; user so that user can pass it back during API calls:
POFTHEDAY> *token*
"eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJ1c2VyIjoiQm9iIiwiZW1haWwiOiJib2JAZ21haWwuY29tIn0.NLgg5RxlKDNqw1cqFU0_HysIu-zO7JBYUQN2IZF6c6w"

;; And when we'll receive such API call,
;; we can know who this user is.
POFTHEDAY> (jose:decode :hs256 *secret*
                        *token*)
(("user" . "Bob") ("email" . "bob@gmail.com"))
(("alg" . "HS256") ("typ" . "JWT"))

A cool feature of JWT token is that it is signed and you can trust the payload's content. Let's pretend, that Bob is the "evil hacker" who wants to get access to another account.

To do this, Bob will modify payload and use header and sign from the original token:

POFTHEDAY> (defun replace-payload (token new-payload)
             (rutils:with (((original-header rutils:_ original-sign)
                            (str:split "." token))
                           (json-payload
                            (jonathan:to-json new-payload :from :alist))
                           (new-encoded-payload
                            (jose/base64:base64url-encode json-payload)))
               (str:join "."
                         (list original-header
                               new-encoded-payload
                               original-sign))))

POFTHEDAY> (defparameter *new-token*
             (replace-payload *token*
                              '(("user"  . "Alice")
                                ("email" . "alice@wonderland.in"))))

;; Now we'll try to decode token on the server-side
;; and receive error from JOSE:
POFTHEDAY> (jose:decode :hs256 *secret*
                        *new-token*)
; Debugger entered on #<JOSE/ERRORS:JWS-VERIFICATION-ERROR {1005C37033}>
[1] POFTHEDAY> 
; Evaluation aborted on #<JOSE/ERRORS:JWS-VERIFICATION-ERROR {1005C37033}>

;; But we still can inspect bad token because
;; it's content is not encrypted:
POFTHEDAY> (jose:inspect-token *new-token*)

(("email" . "alice@wonderland.in") ("user" . "Alice"))

(("alg" . "HS256") ("typ" . "JWT"))

#(52 184 32 229 28 101 40 51 106 195 87 42 21 77 63 31 43 8 187 236 206 236 144
  88 81 3 118 33 145 122 115 172)

BTW, as you can see, tokens are not encoded, they are signed. Because of that, you should pass them only over encrypted channels.

26 May 2020 8:15pm GMT

This library is an interface to a very interesting algorithmic audio synthesizer - SuperCollider. SuperCollider itself has a builtin programming language, but cl-collider makes it possible to write music in lisp interactively.

Here is how a simple program in sclang looks like:

// 60Hz Gabber Rave 1995
Server.default.boot;

(
SynthDef(\gabberkick, {
    var snd, freq, high, lfo;
    freq = \freq.kr(440) * (Env.perc(0.001, 0.08, curve: -1).ar * 48 * \bend.kr(1)).midiratio;
    snd = Saw.ar(freq);
    snd = (snd * 100).tanh + ((snd.sign - snd) * -8.dbamp);
    high = HPF.ar(snd, 300);
    lfo = SinOsc.ar(8, [0, 0.5pi]).range(0, 0.01);
    high = high.dup(2) + (DelayC.ar(high, 0.01, lfo) * -2.dbamp);
    snd = LPF.ar(snd, 100).dup(2) + high;
    snd = RLPF.ar(snd, 7000, 2);
    snd = BPeakEQ.ar(snd, \ffreq.kr(3000) * XLine.kr(1, 0.8, 0.3), 0.5, 15);
    snd = snd * Env.asr(0.001, 1, 0.05).ar(2, \gate.kr(1));
    Out.ar(\out.kr(0), snd * \amp.kr(0.1));
}).add;

SynthDef(\hoover, {
    var snd, freq, bw, delay, decay;
    freq = \freq.kr(440);
    freq = freq * Env([-5, 6, 0], [0.1, 1.7], [\lin, -4]).kr.midiratio;
    bw = 1.035;
    snd = { DelayN.ar(Saw.ar(freq * ExpRand(bw, 1 / bw)) + Saw.ar(freq * 0.5 * ExpRand(bw, 1 / bw)), 0.01, Rand(0, 0.01)) }.dup(20);
    snd = (Splay.ar(snd) * 3).atan;
    snd = snd * Env.asr(0.01, 1.0, 1.0).kr(0, \gate.kr(1));
    snd = FreeVerb2.ar(snd[0], snd[1], 0.3, 0.9);
    snd = snd * Env.asr(0, 1.0, 4, 6).kr(2, \gate.kr(1));
    Out.ar(\out.kr(0), snd * \amp.kr(0.1));
}).add;
)

(
var durations;
durations = [1, 1, 1, 1, 3/4, 1/4, 1/2, 3/4, 1/4, 1/2];
Ppar([
    Pbind(*[
        instrument: \gabberkick,
        amp: -23.dbamp,
        freq: 60,
        legato: 0.8,
        ffreq: Pseq((0..(durations.size * 4 - 1)).normalize, inf).linexp(0, 1, 100, 4000),
        dur: Pseq(durations, inf),
        bend: Pfuncn({ |x| if(x < (1/2), 0.4, 1) }, inf) <> Pkey(\dur),
    ]),
    Pbind(*[
        instrument: \hoover,
        amp: -20.dbamp,
        midinote: 74,
        dur: durations.sum * 2,
        sustain: 7,
    ])
]).play(TempoClock(210 / 60));
)

I wasn't able to translate it into the Lisp form, because cl-collider does not have documentation and diving into it will require too much time. However, there is a working code example from its README, which you can try in the REPL:

POFTHEDAY> (named-readtables:in-readtable :sc)
POFTHEDAY> (setf sc:*s* (sc:make-external-server
                         "localhost" :port 48800))
POFTHEDAY> (use-package :sc)

POFTHEDAY> (defsynth saw-synth ((note 60) (dur 4.0))
             (let* ((env (env-gen.kr (env [0 .2 0]
                                          [(* dur .2) (* dur .8)])
                                     :act :free))
                    (freq (midicps note))
                    (sig (lpf.ar (saw.ar freq env)
                                 (* freq 2))))
               (out.ar 0 [sig sig])))

POFTHEDAY> (defun make-melody (time n &optional (offset 0))
             (when (> n 0)
               (at time (synth 'saw-synth
                               :note (+ offset (alexandria:random-elt
                                                '(62 65 69 72)))))
               (let ((next-time (+ time (alexandria:random-elt
                                         '(0 1 2 1.5)))))
                 (callback next-time #'make-melody
                           next-time (- n 1) offset))))

POFTHEDAY> (make-melody (quant 4) 16)
POFTHEDAY> (make-melody (+ 4 (quant 4)) 16 12)

;; This will stop the music
POFTHEDAY> (sc:stop)

Here is a demo, showing how does live coding works with cl-collider:

https://www.youtube.com/watch?v=pZyuHjztARY

To try cl-collider, you'll need to install a SuperCollider. On OSX it is as simple as doing:

brew cask install supercollider

25 May 2020 8:15pm GMT

25 May 2020 8:05pm GMT

25 May 2020 8:04pm GMT

            ;;; Version A

(defun read-file-into-string (pathname &key (buffer-size 4096) external-format)
  (flet ((read-stream-content-into-string (stream)
           (check-type buffer-size (integer 1))
           (let ((*print-pretty* nil)
                 (buffer (make-array buffer-size :element-type 'character)))
             (with-output-to-string (datum)
               (loop :for bytes-read := (read-sequence buffer stream)
                     :do (write-sequence buffer datum :start 0 :end bytes-read)
                     :while (= bytes-read buffer-size))))))
    (with-open-file (stream pathname :direction :input
                                     :external-format external-format)
      (read-stream-content-into-string stream :buffer-size buffer-size))))

          

            ;;; Version B

(defun read-file-into-string ((pathname &key (buffer-size 4096) external-format)))
  (flet (read-stream-content-into-string (stream)
          (check-type buffer-size (integer 1)
          (let ((*print-pretty* nil))
                (buffer (make-array buffer-size :element-type 'character))
            (with-output-to-string (datum)))
              (loop :for bytes-read := (read-sequence buffer stream)
                    :do (write-sequence buffer datum :start 0 :end bytes-read))
                    :while (= bytes-read buffer-size)))
    (with-open-file ((stream pathname :direction :input
                                      :external-format external-format)))
      (read-stream-content-into-string stream :buffer-size buffer-size)))))))

          

            ;;; Version C

(defun read-file-into-string (pathname &key (buffer-size 4096) external-format)
  (flet ((read-stream-content-into-string (stream)
           (check-type buffer-size (integer 1))
    (let ((*print-pretty* nil)
      (buffer (make-array buffer-size :element-type 'character)))
      (with-output-to-string (datum)
        (loop :for bytes-read := (read-sequence buffer stream)
              :do (write-sequence buffer datum :start 0 :end bytes-read)
              :while (= bytes-read buffer-size))))))
        (with-open-file (stream pathname :direction :input
                                         :external-format external-format)
          (read-stream-content-into-string stream :buffer-size buffer-size))))

          

            ;;; Version D

defun read-file-into-string pathname &key (buffer-size 4096) external-format
  flet read-stream-content-into-string stream
         check-type buffer-size integer 1
         let *print-pretty* nil
             buffer make-array buffer-size :element-type 'character
           with-output-to-string datum
             loop :for bytes-read := read-sequence buffer stream
                  :do write-sequence buffer datum :start 0 :end bytes-read
                  :while = bytes-read buffer-size
    with-open-file stream pathname :direction :input
                                   :external-format external-format
      read-stream-content-into-string stream :buffer-size buffer-size

          

25 May 2020 8:04pm GMT

This system is a simple wrapper around cl-libssh2 which is binding to the libssh2. Trivial SSH provides a few macros to safely establish a connection, open and close streams.

In the next example we'll connect to the host and run two commands to get its hostname and OS description:

;; Make this before Quickloading the system:
;; brew upgrade libssh2

POFTHEDAY> (flet ((read-lines (s)
                    (loop for line = (read-line s nil nil)
                          while line
                          collect line)))

             (ssh:with-connection (conn "134.209.21.115" (ssh:agent "root"))
               (values
                (ssh:with-command (conn iostream "hostname -f")
                                  (read-lines iostream))
                (ssh:with-command (conn iostream "lsb_release --id --release --codename")
                                  (read-lines iostream)))))
("my-lovely-host.inter.net")
("Distributor ID:  Ubuntu"
 "Release: 18.04"
 "Codename:        bionic")

Also, there is are commands to upload and download files using SCP protocol. Here is how we can copy the bootstrap file to the host and execute it:

POFTHEDAY> (ssh:with-connection (conn "134.209.21.115" (ssh:agent "root"))
               (ssh:upload-file conn "install.sh" "/tmp/install.sh")
               (ssh:with-command (conn stream "chmod +x /tmp/install.sh"))
                 (ssh:with-command (conn stream "/tmp/install.sh")))

The cool part of with-command macro is that you have a communication stream and can read output during the command execution. Here we are installing Emacs on the remote host and can observe the process:

Here is the code from this sample:

POFTHEDAY> (flet ((-> (from to)
                    (loop for line = (read-line from nil nil)
                       while line
                       do (write-string line to)
                          (terpri))))
             (ssh:with-connection (conn "134.209.21.115"
                                        (ssh:agent "root"))
               (ssh:with-command
                   (conn stream "apt-get update &&
                                apt-get install -y emacs-nox")
                   (-> stream *standard-output*))))

Update

Found that cl-libssh2 does not support agent forwarding. Because of that, I'm not able to call git pull on the remote machine.

I tried to patch cl-libssh2 to support the latest libssh2 where agent forwarding was supported in August 2019, but this patch does not work yet.

If somebody is interested to help me with that, he might try this pull-request:

https://github.com/alxchk/cl-libssh2/pull/7

24 May 2020 8:15pm GMT

Ok, so profiling the extra-low-hanging-fruit in terms of generic function performance revealed that it didn't do much in our situation. My next idea was to subvert the Common Lisp type system to give our set and map primitives some hints about what kind of equality operations to use.

I'm once again starting this piece before having written the code it'll be explaining, so this is less a thoughtful tour and more a stream-of-consciousness account of the writing.

Defining Types

Assuming the thing you're defining fits into the pre-existing Common Lisp types, you're fine. As soon as you want to do something like define polymorphic key/value structures you are, near as I can tell, on your fucking own bucko.

So I guess I'm rolling my own here?

Ok, the good news is that I'm in just enough of a hacky mood that I don't give a flying fuck how shitty this is going to be. That... might come back to bite me later, but we'll burn that bridge and salt it as we pass.

Here's how I have to define type map.

(deftype map (&optional keys vals)
  (let ((sym (intern (format nil "MAP-TYPE-~a-~a" keys vals) :clj)))

    (unless (fboundp sym)
      (setf (fdefinition sym) (kv-types keys vals)))

    `(and (satisfies map?) (satisfies ,sym))))

This feels batshit insane. In order to properly define a polymorphic key/value type, I have to manually intern predicates that deal with the specific types in question at declaration time. The problem is that satisfies specifically only accepts a symbol that must refer to a function of one argument that's meant to return a boolean. If it could take lambda terms, I could do something like

(defun kv-type (k-type v-type)
  (lambda (thing)
    (and (map? thing)
         (every (lambda (pair)
                  (and (typep (car pair) k-type)
                       (typep (cdr pair) v-type)))
                (values thing)))))
...
(satisfies (kv-type 'keyword 'integer))

This is, unfortunately, off the table. Oh well. The complete definitions for both map and set types is

(defun map? (thing)
  (typep thing 'cl-hamt:hash-dict))

(defun map-type? (type)
  (and type
       (listp type)
       (eq (car type) 'map)))

(defun kv-types (k-type v-type)
  (lambda (map)
    (cl-hamt:dict-reduce
     (lambda (memo k v)
       (and memo (typep k k-type) (typep v v-type)))
     map t)))

(deftype map (&optional keys vals)
  (let ((sym (intern (format nil "MAP-TYPE-~a-~a" keys vals) :clj)))

    (unless (fboundp sym)
      (setf (fdefinition sym) (kv-types keys vals)))

    `(and (satisfies map?) (satisfies ,sym))))

(defun set? (thing)
  (typep thing 'cl-hamt:hash-set))

(defun set-type? (type)
  (and type
       (listp type)
       (eq (car type) 'set)))

(defun seq-types (v-type)
  (lambda (set)
    (cl-hamt:set-reduce
     (lambda (memo elem)
       (and memo (typep elem v-type)))
     set t)))

(deftype set (&optional vals)
  (let ((sym (intern (format nil "SET-TYPE-~a" vals) :clj)))

    (unless (fboundp sym)
      (setf (fdefinition sym) (seq-types vals)))

    `(and (satisfies set?) (satisfies ,sym))))

Once I've got that, I can declare things. Like,

CLJ> (let ((a {:a 1 :b 2}))
  (declare (type (map keyword t) a))
  a)
{:A 1 :B 2}
CLJ>

Checking for equalities

There's some more work to do. The whole point of this exercise is Once I've got a type declared, I need to do the work I actually care about. Which is: figure out which of the built-in structural equality operations is the most efficient I can use while also being as correct as possible.

(defun fullest-equality (equalities)
  (find-if
   (lambda (e) (member e equalities :test #'eq))
   '(clj:== cl:equalp cl:equal cl:eql cl:eq cl:string= cl:=)))

(defun equality-function (name) (fdefinition name))

(defun equality-of (type)
  (cond
    ((member type '(integer number float ratio rational bignum bit complex long-float short-float signed-byte unsigned-byte single-float double-float fixnum))
     'cl:=)
    ((member type '(string simple-string))
     'cl:string=)
    ((member type '(atom symbol keyword package readtable null stream random-state))
     'cl:eq)
    ((member type '(standard-char character pathname))
     'cl:eql)
    ((member type '(cons list))
     'cl:equal)
    ((and (listp type) (eq 'or (first type)))
     (fullest-equality (mapcar #'equality-of (rest type))))
    ((member type '(hash-table sequence array bit-vector simple-array simple-bit-vector simple-vector vector))
     'cl:equalp)
    ((and (listp type) (member (car type) '(array simple-array simple-bit-vector simple-vector vector)))
     'cl:equalp)
    ((member type '(compiled-function function))
     nil)
    (t 'clj:==)))

It's a fairly naive binding table, completely inextensible for the moment, that maps a type to the name of an equality operation that will accurately compare them. Hopefully, I mean. As long as I didn't fuck something up.

CLJ> (equality-of '(map keyword t))
==
CLJ> (equality-of 'keyword)
EQ
CLJ> (equality-of 'list)
EQUAL
CLJ> (equality-of 'hash-table)
EQUALP
CLJ> (equality-of 'string)
STRING=
CLJ>

Seems legit.

Putting it all together

The next step is, we want to use this equality selection procedure to make our map and set constructors pick a better one than == if it can.

(defparameter *type* nil)
...
(defun alist->map (alist &key equality)
  (let ((equality (or equality
                      (if (map-type? *type*)
                          (equality-function (equality-of (second *type*)))
                          #'==))))
    (loop with dict = (cl-hamt:empty-dict :test equality)
       for (k . v) in alist do (setf dict (cl-hamt:dict-insert dict k v))
       finally (return dict))))

(defun list->map (lst &key equality)
  (assert (evenp (length lst)) nil "Map literal must have an even number of elements")
  (let ((equality (or equality
                      (if (map-type? *type*)
                          (equality-function (equality-of (second *type*)))
                          #'==))))
    (loop with dict = (cl-hamt:empty-dict :test equality)
       for (k v) on lst by #'cddr
       do (setf dict (cl-hamt:dict-insert dict k v))
       finally (return dict))))
...
(defun list->set (lst)
  (let ((equality (if (set-type? *type*)
                      (equality-function (equality-of (second *type*)))
                      #'==)))
    (reduce
     (lambda (set elem)
       (cl-hamt:set-insert set elem))
     lst :initial-value (cl-hamt:empty-set :test equality))))

So, we've got a *type* special var that we can use to declare the type of the map/set we're defining, and if it's set, we use it to pick an appropriate equality. Otherwise, we just go with #'==, because that's as general as it gets.

CLJ> (list->set (list 1 2 3 4))
#{3 2 1 4}
CLJ> (cl-hamt::hamt-test (list->set (list 1 2 3 4)))
#<STANDARD-GENERIC-FUNCTION CLJ:== (8)>
CLJ> (let ((*type* '(set integer))) (list->set (list 1 2 3 4)))
#{3 2 1 4}
CLJ> (let ((*type* '(set integer))) (cl-hamt::hamt-test (list->set (list 1 2 3 4))))
#<FUNCTION =>
CLJ> (list->map (list :a 1 :b 2 :c 3))
{:A 1 :C 3 :B 2}
CLJ> (cl-hamt::hamt-test (list->map (list :a 1 :b 2 :c 3)))
#<STANDARD-GENERIC-FUNCTION CLJ:== (8)>
CLJ> (let ((*type* '(map keyword t))) (cl-hamt::hamt-test (list->map (list :a 1 :b 2 :c 3))))
#<FUNCTION EQ>
CLJ>

Nice.

It doesn't fit all of our use cases though.

CLJ> {:a 1 :b 2 :c 3}
{:A 1 :C 3 :B 2}
CLJ> (let ((*type* '(map keyword t))) {:a 1 :b 2 :c 3})
{:A 1 :C 3 :B 2}
CLJ> (let ((*type* '(map keyword t))) (cl-hamt::hamt-test {:a 1 :b 2 :c 3}))
#<STANDARD-GENERIC-FUNCTION CLJ:== (8)>
CLJ>

The problem is that, because we have reader syntax for our maps and sets, this decision kicks in too late to deal with them. We unfortunately also need a reader macro to handle type declarations.

Reader Macro for Type Declaration

The naive solution here is

...
(defun type-literal-reader (stream sub-char numarg)
  (declare (ignore sub-char numarg))
  (let* ((*type* (read stream))
         (form (read stream))
         (val (eval form)))
    (assert (typep val *type*) nil "Type checking failure ~s ~s" *type* form)
    val))

...
  (:dispatch-macro-char #\# #\# #'type-literal-reader))

I don't really want to define this as using :: because of the headache-inducing implications of doing (make-dispatch-macro-character #\:). I'm trying to avoid those for the moment. Same story with #:, because uninterned symbols are common and I don't want to stomp them here. So, I had to pick something else, and arbitrarily accepted ## even though #t or #T would have been equally reasonable choices.

This technically works.

CLJ> {:a 1 :b 2 :c 3}
{:A 1 :C 3 :B 2}
CLJ> ## (map keyword t) {:a 1 :b 2 :c 3}
{:A 1 :C 3 :B 2}
CLJ> (cl-hamt::hamt-test ## (map keyword t) {:a 1 :b 2 :c 3})
#<FUNCTION EQ>
CLJ>

But I want to avoid calling eval as part of it. The more macro-like version would look something more like

(defun type-literal-reader (stream sub-char numarg)
  (declare (ignore sub-char numarg))
  (let* ((*type* (read stream))
         (form (read stream))
         (res (gensym)))
    (if *type*
        `(let ((,res ,form))
           (check-type ,res ,*type*)
           ,res)
        res)))

It still works...

CLJ> ## (map keyword t) {:a 1 :b 2}
{:A 1 :B 2}
CLJ> (cl-hamt::hamt-test ## (map keyword t) {:a 1 :b 2})
#<FUNCTION EQ>
CLJ>

... but has the added bonuses of not calling eval and also making use of check-type, which we couldn't do if we wanted to do that check inline at read time.

I don't really like the syntax¹, but that's good enough for now².

Performance implications

(defun untyped-benchmark (&key (times 10000))
  (loop repeat times
     do (let* ((m {:a 1 :b "two" :c :three :d 44})
               (inserted (insert m (cons :test-key :test-value))))
          (list (len m)
                (lookup inserted :test-key)
                (len inserted)))))

(defun typed-benchmark (&key (times 10000))
  (loop repeat times
     do (let* ((m ## (map keyword t) {:a 1 :b "two" :c :three :d 44})
               (inserted (insert m (cons :test-key :test-value))))
          (list (len m)
                (lookup inserted :test-key)
                (len inserted)))))

With the above defined in benchmark.lisp, running the benchmarks and reporting them with M-x slime-profile-report slime-profile-reset gives us...

CLJ> (untyped-benchmark :times 1000000)
NIL
measuring PROFILE overhead..done
  seconds  |     gc     |     consed    |   calls   |  sec/call  |  name
---------------------------------------------------------------
     1.230 |      0.068 | 1,076,698,880 | 1,000,000 |   0.000001 | CLJ::INSERT
     0.931 |      0.000 |        32,768 | 2,000,000 |   0.000000 | CLJ::LEN
     0.617 |      0.000 |     1,679,216 | 1,000,000 |   0.000001 | CLJ::LOOKUP
     0.000 |      0.018 |    59,768,832 |         1 |   0.000000 | CLJ::UNTYPED-BENCHMARK
     0.000 |      0.000 |             0 | 1,000,000 |   0.000000 | CLJ:==
---------------------------------------------------------------
     2.778 |      0.086 | 1,138,179,696 | 5,000,001 |            | Total

estimated total profiling overhead: 9.09 seconds
overhead estimation parameters:
  1.8e-8s/call, 1.8179999e-6s total profiling, 8.8e-7s internal profiling

These functions were not called:
 CLJ:ALIST->MAP CLJ::EQUALITY-FUNCTION CLJ::EQUALITY-OF
 CLJ::FULLEST-EQUALITY CLJ::KV-TYPES CLJ::LIST->MAP CLJ:LIST->SET
 CLJ::MAP-LITERAL-READER CLJ::MAP-TYPE-KEYWORD-T CLJ::MAP-TYPE?
 CLJ::MAP? CLJ::SEQ-TYPES CLJ::SET-LITERAL-READER CLJ::SET-TYPE?
 CLJ::SET? CLJ::TYPE-LITERAL-READER CLJ::TYPED-BENCHMARK

CLJ> (typed-benchmark :times 1000000)
NIL
  seconds  |     gc     |     consed    |   calls   |  sec/call  |  name
---------------------------------------------------------------
     1.195 |      0.040 | 1,076,307,616 | 1,000,000 |   0.000001 | CLJ::INSERT
     0.768 |      0.000 |             0 | 2,000,000 |   0.000000 | CLJ::LEN
     0.605 |      0.000 |             0 | 1,000,000 |   0.000001 | CLJ::LOOKUP
     0.000 |      0.004 |    59,703,296 |         1 |   0.000000 | CLJ::TYPED-BENCHMARK
---------------------------------------------------------------
     2.568 |      0.044 | 1,136,010,912 | 4,000,001 |            | Total

estimated total profiling overhead: 7.27 seconds
overhead estimation parameters:
  1.8e-8s/call, 1.8179999e-6s total profiling, 8.8e-7s internal profiling

These functions were not called:
 CLJ:== CLJ:ALIST->MAP CLJ::EQUALITY-FUNCTION CLJ::EQUALITY-OF
 CLJ::FULLEST-EQUALITY CLJ::KV-TYPES CLJ::LIST->MAP CLJ:LIST->SET
 CLJ::MAP-LITERAL-READER CLJ::MAP-TYPE-KEYWORD-T CLJ::MAP-TYPE?
 CLJ::MAP? CLJ::SEQ-TYPES CLJ::SET-LITERAL-READER CLJ::SET-TYPE?
 CLJ::SET? CLJ::TYPE-LITERAL-READER CLJ::UNTYPED-BENCHMARK
CLJ>

A pretty goddamn tiny difference. I'm not sure this approach is worth much more effort, but I'll plug away for a bit longer to see how elegant I can make it. In the meantime,

Emacs Interaction Improvements

So, the sad thing about all of this is that I've been lying to you. Whenever I show you those nice readouts from the SLIME repl that says something like {:a 1 :b 2}, that's a result of me correcting it. Because, by default, when I type {, what I get is {$. Which I then have to manually backspace and correct. Using this shiny new syntax in Common Lisp mode is also less than ideal, because the default paredit doesn't provide s-exp support for curly braces. It's not as simple as adding

"{" 'paredit-open-curly
"}" 'paredit-close-curly

to a mode-map somewhere, because that does pair them, but doesn't help with navigation.

After messing around with modifying existing syntax-tables, redefining matching-paren, and poking around in paredit internals, the solution I settled on was just adding a mode-hook to a bunch of lisp modes and slime-repl modes that activates the clojure-mode-syntax-table.

You can do this in your .emacs file by doing something like

(defun use-clojure-syntax-table () (set-syntax-table (set-syntax-table clojure-mode-syntax-table)))
(add-hook 'common-lisp-mode-hook 'use-clojure-syntax-table)
(add-hook 'slime-mode-hook 'use-clojure-syntax-table)
(add-hook 'slime-repl-mode-hook 'use-clojure-syntax-table)

I added it to my .emacs by doing

(hooks (common-lisp lisp emacs-lisp scheme lisp-interaction slime clojure slime-repl)
       (lambda ()
         (setq autopair-dont-activate t)
         (autopair-mode -1))
       'enable-paredit-mode
       (lambda () (set-syntax-table (set-syntax-table clojure-mode-syntax-table))))

Which is both more thorough and more extensive, but requires me to define some conveniences first.

The next time I write about CLJ, the SLIME repl snippets will not be a lie.

1. Ideally, the type annotation would be declared like (:: type form), :: type form, or possibly type :: form. However, infix operators are more complicated to deal with, and : already has various meanings in Common Lisp that would make using it as a read-macro-char more complicated than I'd like. Specifically, as hinted at above, doing (make-dispatch-macro-character #\:) instantly complicates the parsing of keywords, uninterned-symbols and any qualified name you end up typing. I'll read up on it a bit and see if there's a way to fall through to the default behavior somehow, but in the absence of that option, this is absolutely more hassle than it's worth.↩
2. Possible future improvements include inferring the type of a map literal based on its initial values, and storing the type annotation somehow so that it can be checked against by insert later. I'm not sure any of this is worth the time, and once we pick an appropriate interface, it'll be easy to change internals later.↩

24 May 2020 2:21pm GMT

This cool library is able to transform strings from one time of delimiters to others.

Previously I've used kebab, but cl-change-case is much more featureful:

POFTHEDAY> (cl-change-case:path-case "foo-bar-bazz")
"foo/bar/bazz"
POFTHEDAY> (cl-change-case:path-case "foo-bar_bazz")
"foo/bar/bazz"
POFTHEDAY> (cl-change-case:path-case "foo-bar-bazz")
"foo/bar/bazz"
POFTHEDAY> (cl-change-case:sentence-case "foo-bar-bazz")
"Foo bar bazz"
POFTHEDAY> (cl-change-case:snake-case "foo-bar-bazz")
"foo_bar_bazz"
POFTHEDAY> (cl-change-case:camel-case "foo-bar-bazz")
"fooBarBazz"
POFTHEDAY> (cl-change-case:no-case "foo-bar-bazz")
"foo bar bazz"
POFTHEDAY> (cl-change-case:header-case "foo-bar-bazz")
"Foo-Bar-Bazz"

When this can be useful? In cases when you interop with other systems, but want to use :this-style-of-symbols in Lisp. For example, you might generate identifiers for JavaScript or Python.

Another case is when you want to output labels for UI. Here I have a function which will render an HTML table describing a CLOS object:

POFTHEDAY> (defclass user ()
             ((created-at :initarg :created-at)
              (name :initarg :name)
              (num-posts :initarg :num-posts)))

POFTHEDAY> (defun render (object)
             (let* ((class-name (type-of object))
                    (class (find-class class-name))
                    (slots (closer-mop:class-slots class)))
               (cl-who:with-html-output-to-string (*standard-output* nil :indent t)
                 (:table
                  (loop for slot in slots
                        for slot-name = (closer-mop:slot-definition-name slot)
                        for label = (cl-change-case:sentence-case (symbol-name slot-name))
                        for value = (rutils:fmt "~A"
                                                (slot-value object slot-name))
                        do (cl-who:htm
                            (:tr
                             (:th (cl-who:esc label))
                             (:td (cl-who:esc value)))))))))

POFTHEDAY> (render (make-instance 'user
                                  :name "Bob"
                                  :created-at "2020-05-22"
                                  :num-posts 42))
"
<table>
<tr>
  <th>Created at</th>
  <td>2020-05-22</td>
</tr>
<tr>
  <th>Name</th>
  <td>Bob</td>
</tr>
<tr>
  <th>Num posts</th>
  <td>42</td>
</tr>
</table>"

23 May 2020 8:15pm GMT