Friday, October 21, 2022

Lisp: Second impression

My first impressions of Lisp were not good. I didn't see how navigating list structure was of any use. It seemed to be just a more cumbersome way of getting at the data.

In fact, my first impressions of computer science were not very positive. I enjoyed hobbyist coding on my TRS-80, but “real” programming was tedious and the proscriptions of “doing it the correct way” took the joy out of it. I explored other options for my major. Fate intervened. Over the next year I realized my calling was EECS, so in my sophomore year I took all the intro courses.

I had heard that the introductory computer science course used Lisp. That was disappointing, but I started hearing things about Lisp that made me think I should take a second look. I learned that Lisp was considered the premier language of MIT's Artificial Intelligence Laboratory. It was invented by hackers and designed to be a programmable programming language that was infinitely customizable. The lab had developed special computers that ran Lisp on the hardware. The OS was even written in Lisp. I wasn't looking forward to car and cdr'ing my way through endless cons cells, but I figured that there had to be more going on.

6.001 was unlike the prior computer courses I had taken. The course was not about how to instruct a computer to perform a task — the course was about expressing ideas as computation. To me, this seemed a much better way to approach computers. Professor Hal Abelson was co-lecturing the course. He said that he chose Lisp as the teaching language because it was easier to express ideas clearly.

Two things stood out to me in the first lecture. Professor Abelson showed the recursive and iterative versions of factorial. Of course I had seen recursive factorial from the earlier course and I knew how it worked. Clearly the iterative version must work the same way. (One of my early hangups about Lisp was all the recursion.) I was suprised to find out that the Lisp system would automatically detect tail recursive cases and turn them into iteration. Evidentally, the makers of Lisp had put some thought into this.

Professor Abelson also demonstrated first class functions. He wrote a procedure that numerically approximates the derivative of a function. He then used that in a generic Newton's method solver. This is all straightforward stuff, but to a newbie like me, I thought it was amazing. In just a few lines of code we were doing simple calculus.

It was a mystery to me how first class functions were implemented, but I could see how they were used in the Newton's method solver. The code Professor Abelson wrote was clear and obvious. It captured the concept of derivatives and iterative improvement concisely, and it effectively computed answers to boot. I had to try it. Right after the lecture I went to lab and started typing examples at the REPL. Sure enough, they worked as advertised. A tail-recursive loop really didn't push any stack. It didn't leak even the tiniest bit of memory, no matter how long the loop. I tried the Newton's method solver to take cube roots. I passed the cube function to the derivative function and the result was a function that was numerically close to the derivative.

Now I was a bit more impressed with Lisp than I was earlier. I wasn't completely sold, but I could see some potential here. I wanted to learn a bit more before I dismissed it entirely. It took me several months to become a Lisp fan. The parenthesis were a small hurdle — it took me a couple of weeks to get the hang of let forms. There was a week or two of navigating cons cells to wade through. But I eventually came to love the language.

My first impression of Lisp was poor. The uselessness of traversing random list structure was unmotivating. My second impression was better. Professor Abelson teaching directly from preprints of S&ICP might have had something to do with it.

Wednesday, October 19, 2022

Lisp: First Impressions

My first exposure to Lisp was in the summer of 1981. I was taking a summer school intro to computers. The course was taught on a PDP-11, and for the first few weeks we programmed in Macro-11 assembly language. For the last couple of weeks they introduced Lisp.

Frankly, I wasn't impressed.

The course started by talking about linked lists and how you could navigate them with car and cdr. We then went on to build more complicated structures like alists and plists. This was an old-fashioned lisp, so we used things like getprop and putprop to set symbol properties.

The subject matter wasn't difficult to understand (though chasing pointers around list structure is error prone). Since we had just been learning Macro-11, it was natural to play with linked list structure in assembly code. We wrote assembly code to look things up in a plist.

My impression was that Lisp was centered around manipulating these rather cumbersome data structures called cons cells. Linked lists of cons cells have obvious disadvantages when compared to arrays. This makes the language tedious to work with.

The summer school course was my first “real” college course in computers. I was put off. “Real” computing wasn't as much fun as I had hoped it would be. I definitely wouldn't be considering it as a major, let alone a career. I wasn't interested in Lisp at all.

to be continued

Wednesday, September 28, 2022

Observationally Functional

A couple of years back I wrote a Java microservice that talks to Jenkins to find the state of a series of builds. The code was structured to be “observationally functional” — there were plenty of side effects, but the main data abstractions behaved as if they were immutable as far as the abstract API was concerned. This allows us to treat code that uses these objects as if it were pure functional code.

If a data structure is observationally functional, then regardless of what the implementation does, there is no way to observe side effects at the abstract level. Primarily, this means that if you call a function twice with the same arguments, you always get the same answer. (This implies, but it isn't obvious, that calling a function should not mutate anything that would cause a different function to change.) This restriction has a lot of wiggle room. You can certainly side effect anything local to the abstraction that doesn't get returned to the caller. You can side effect data until the point it is returned to the caller.

The main data abstraction my microservice works with is a representation of the build metadata tree on the Jenkins server. The higher level code walks this tree looking for builds and metadata. The code maintains the illusion that the tree is a local data structure, but the implementation of the tree contains URL references to data that is stored on the Jenkins server. As the higher level code walks the tree, the lower level code fetches the data from the Jenkins server on demand and caches it.

Writing the code this way allows me to separate the data transfer and marshaling parts from the data traversal and analysis part. The tree, though it is mutated as it is traversed, is immutable in the parts that have already been visited. The caching code, which actually mutates the tree, needs to be synchronized across multiple threads, but the traversal code does not. Nodes in the tree that have already been visited are never mutated, so no synchronization is needed.

Once the caching tree abstraction was written, the higher level code simply walks the tree, selecting and filtering nodes, then reading the field values in the nodes. But the higher level code can be treated as if it were pure functional because there are no observable side effects. An advantage of pure functional code is that it is trivially thread safe, so my microservice can run hundreds of threads in parallel, each walking separate parts of the Jenkins tree and none interfering with the other. The only part of the code that uses synchronization is the tree caching code.

This implementation approach was quite fruitful. Once the code was tested with a single thread, it was obvious that multiple threads ought to work (because they couldn't observe each other's side effects) and when I turned the thread count up, no debugging was necessary. The code has been running continuously with dozens of threads for the past couple of years with no timing, synchronization, or race condition bugs.

Wednesday, September 7, 2022

Playing with raycasting

I wanted to learn about raycasting. Raycasting is like a simplified version of ray tracing. As in ray tracing, you examine the environment by projecting a ray from your current location out in some direction to determine what is visible in that direction. But we simplify the problem by only considering two dimensions.

I was also interested in making the graphics more functional and less dependent upon side effects. Now obviously rendering an image to the screen is going to involve side effects, but we can refactor the rendering problem into two subproblems, a pure function that maps the world to an image and the procedure that displays the image.

I'll put the code below. The run procedure implements the event loop state machine. It keeps track of the world and calls next-world on the current world to update the world as time passes. next-world just maps next-state over the objects in the world. next-state does not mutate an object, rather it returns a new object in the new state. Every 13 milliseconds, run calls render-world!, which calls render! on each object in the world.

We're going to use raycasting to fake up a first-person view of a two-dimensional maze. From a position within the maze, we'll cast a ray in a direction and see how far away the wall is. If we peer at the wall through a narrow slit in just that direction, it will appear as a vertical line with height inversely proportional to its distance. If we sweep the ray direction and stack the vertical lines next to each other, it will create three dimensional effect.

The render! method for a fp-view will side effect the screen, but we'll compute the contents functionally. We'll go through each column on the screen and call (vraster fp-view column) to compute a color and a height and we'll draw a vertical line of that height in that color in that column.

(defmethod render! (renderer (fp-view fp-view))
  (dotimes (column +window-width+)
    (multiple-value-bind (r g b height)
        (vraster fp-view column)
      (sdl2:set-render-draw-color renderer r g b #xFF)
      (sdl2:render-draw-line renderer
                             column (round (+ (/ +window-height+ 2) (/ height 2)))
                             column (round (- (/ +window-height+ 2) (/ height 2)))))))

vraster is a function that returns the color and height of the wall on a particular column on the screen. It figures out the angle at which to cast to a ray and calls range to find the distance to the nearest wall at that angle. This is sufficient to determine the wall height for that column, but the first person effect is enhanced significantly if you tint the color according to the distance and the direction of the wall. Knowing the distance, we compute the exact point px, py that the ray hit. It's a wall in the x direction if the y coordinate is an integer and vice versa.

(defparameter +field-of-view+ (/ pi 4))

(defun column->theta (column)
  (- (* (/ column +window-width+) +field-of-view+) (/ +field-of-view+ 2)))

(defun vraster (fp-view column)
  (let* ((location (get-location fp-view))
         (theta (column->theta column))
         (distance (range location theta))
         (px (+ (get-x location) (* (sin (+ (get-theta location) theta)) distance)))
         (py (+ (get-y location) (* (cos (+ (get-theta location) theta)) distance)))
         (wx (< (abs (- py (round py))) 0.05))
         (wy (< (abs (- px (round px))) 0.05)))
    (values
     (min #xFF (floor (/ (if wx #xff #x00) distance)))
     (min #xFF (floor (/ #xFF distance)))
     (min #xFF (floor (/ (if wy #xff #x00) distance)))
     (min +window-height+ (/ (* +window-height+ 2) distance)))))

So we've factored the rendering of a frame into a procedure that draws on the screen and a function that returns what to draw. The direct advantage of this is that we can determine what we should draw without actually drawing it. As an example, suppose we wanted to generate a stereo pair of images. The only thing we need to change is the render! method. It will now compute the view from two slightly different locations and put one set of columns on the left and the other on the right.

(defmethod render! (renderer (fp-view fp-view))
  (dotimes (column (/ +window-width+ 2))
    (multiple-value-bind (r g b height)
        (vraster (left-eye (get-location fp-view)) (* column 2))
      (sdl2:set-render-draw-color renderer r g b #xFF)
      (sdl2:render-draw-line renderer
                             column (round (+ (/ +window-height+ 2) (/ height 2)))
                             column (round (- (/ +window-height+ 2) (/ height 2)))))
    (multiple-value-bind (r g b height)
        (vraster (right-eye (get-location fp-view)) (* column 2))
      (sdl2:set-render-draw-color renderer r g b #xFF)
      (sdl2:render-draw-line renderer
                             (+ column (/ +window-width+ 2)) (round (+ (/ +window-height+ 2) (/ height 2)))
                             (+ column (/ +window-width+ 2)) (round (- (/ +window-height+ 2) (/ height 2)))))))

In this and in a previous post I've gone through the effort of writing some graphics code while avoiding unnecessary side effects. Typical graphics examples and tutorials are stuffed to the brim with global variables, state, and side effects. I wanted to see which side effects were intrinsic to graphics and which are simply incidental to how the examples are coded. It appears that large amounts of the global state and side effects are unnecessary and a more functional approach is reasonable.

As promised, here is the code.

;;; -*- Lisp -*-

(defpackage "RAYCAST"
  (:shadowing-import-from "NAMED-LET" "LET")
  (:use "COMMON-LISP" "NAMED-LET""))

(in-package "RAYCAST")

(defparameter +window-height+ 480)
(defparameter +window-width+ 640)

(defgeneric next-state (object dt)
  (:method ((object t) dt) object))
(defgeneric render! (renderer thing))

(defun next-world (previous-world dt)
  (map 'list (lambda (object) (next-state object dt)) previous-world))

(defun render-world! (renderer world)
  (sdl2:set-render-draw-color renderer #x00 #x00 #x00 #xFF)
  (sdl2:render-clear renderer)
  (mapc (lambda (object) (render! renderer object)) world)
  (sdl2:render-present renderer))

(defun run (initial-world)
  (sdl2:with-init (:video)
    (sdl2:with-window (window
                       :h +window-height+
                       :w +window-width+
                       :flags '(:shown))
      (sdl2:with-renderer (renderer window :index -1 :flags '(:accelerated :presentvsync))

        (let ((last-ticks 0)
              (render-ticker 0)
              (title-ticker 0)
              (sim-count 0)
              (frame-count 0)
              (world initial-world))

          (flet ((title-tick! (dticks)
                   (incf title-ticker dticks)
                   (when (>= title-ticker 1000)
                     (decf title-ticker 1000)
                     (sdl2:set-window-title window
                                            (format nil "Sim rate: ~d, Frame rate: ~d"
                                                    sim-count frame-count))
                     (setq sim-count 0)
                     (setq frame-count 0)))

                 (world-tick! (dticks)
                   (incf sim-count)
                   (setq world (next-world world (/ dticks 1000))))

                 (render-tick! (dticks)
                   (incf render-ticker dticks)
                   (when (>= render-ticker 13)
                     (incf frame-count)
                     (decf render-ticker 13)
                     (render-world! renderer world))))

            (sdl2:with-event-loop (:method :poll)

              (:idle ()
                     (let ((this-ticks (sdl2:get-ticks)))
                       (if (= this-ticks last-ticks)
                           (sdl2:delay 1)
                           (let ((dticks (- this-ticks last-ticks)))
                             (setq last-ticks this-ticks)
                             (title-tick! dticks)
                             (world-tick! dticks)
                             (render-tick! dticks)))))

              (:keydown (:keysym keysym)
                        (case (sdl2:scancode keysym)
                          ((:scancode-x :scancode-escape) (sdl2:push-quit-event))
                          ((:scancode-left :scancode-right
                            :scancode-up :scancode-down
                            :scancode-pageup :scancode-pagedown)
                           nil)
                          (t (format *trace-output* "~&Keydown: ~s" (sdl2:scancode keysym))
                           (force-output *trace-output*))))

              (:quit () t)
              )))))))

(defparameter +maze+
  #2a((1 1 1 1 1 1 1 1 1 1 1 1)
      (1 0 0 1 0 0 0 0 0 0 0 1)
      (1 0 0 1 0 0 0 0 0 0 0 1)
      (1 0 1 1 0 0 0 1 0 1 0 1)
      (1 0 0 0 0 0 0 0 0 0 0 1)
      (1 0 0 0 0 0 0 1 0 1 0 1)
      (1 0 0 0 0 0 0 0 0 0 0 1)
      (1 0 0 0 0 0 0 0 0 0 0 1)
      (1 0 0 0 0 1 0 0 0 1 0 1)
      (1 0 0 0 0 0 0 0 0 0 0 1)
      (1 1 1 1 1 1 1 1 1 1 1 1)))

(defclass location ()
  ((maze :initarg :maze
         :initform +maze+
         :reader get-maze)
   (x :initarg :x
      :initform 2.5
      :reader get-x)
   (y :initarg :y
      :initform 2.5
      :reader get-y)
   (theta :initarg :theta
          :initform 0
          :reader get-theta)))

(defun ud-input ()
  (- (if (sdl2:keyboard-state-p :scancode-up) 1 0)
     (if (sdl2:keyboard-state-p :scancode-down) 1 0)))

(defun lr-input ()
  (- (if (sdl2:keyboard-state-p :scancode-right) 1 0)
     (if (sdl2:keyboard-state-p :scancode-left) 1 0)))

(defun pg-input ()
  (- (if (sdl2:keyboard-state-p :scancode-pageup) 1 0)
     (if (sdl2:keyboard-state-p :scancode-pagedown) 1 0)))

(defun canonicalize-angle (angle)
  (cond ((>= angle pi) (canonicalize-angle (- angle (* pi 2))))
        ((>= angle (- pi)) angle)
        (t (canonicalize-angle (+ angle (* pi 2))))))

(defparameter +translation-rate+ 3.0) ;; tiles per second
(defparameter +rotation-rate+ pi) ;; radians per second

(defmethod next-state ((location location) dt)
  (let ((fbstep (* (ud-input) +translation-rate+ dt))
        (lrstep (* (pg-input) +translation-rate+ dt))
        (thstep (* (lr-input) +rotation-rate+ dt))

        (old-x (get-x location))
        (old-y (get-y location))
        (cos-theta (cos (get-theta location)))
        (sin-theta (sin (get-theta location))))

    (let ((new-x (+ old-x (* sin-theta fbstep) (- (* cos-theta lrstep))))
          (new-y (+ old-y (* cos-theta fbstep) (+ (* sin-theta lrstep))))
          (new-theta (canonicalize-angle (+ (get-theta location) thstep))))
      (cond ((zerop (aref (get-maze location) (floor new-x) (floor new-y)))
             (make-instance 'location :x new-x :y new-y :theta new-theta))
            ((zerop (aref (get-maze location) (floor old-x) (floor new-y)))
             (make-instance 'location :x old-x :y new-y :theta new-theta))
            ((zerop (aref (get-maze location) (floor new-x) (floor old-y)))
             (make-instance 'location :x new-x :y old-y :theta new-theta))
            (t
             (make-instance 'location :x old-x :y old-y :theta new-theta))))))

(defclass fp-view ()
  ((location :initarg :location
             :reader get-location)))

(defmethod next-state ((fp-view fp-view) dt)
  (make-instance 'fp-view :location (next-state (get-location fp-view) dt)))

(defun range (location relative-theta)
  (let* ((angle (+ (get-theta location) relative-theta))

         (dx/dS (sin angle))
         (dy/dS (cos angle))

         (x-step (if (< dx/dS 0) -1 1))
         (y-step (if (< dy/dS 0) -1 1))

         (dS/dx (abs (/ 1 (if (zerop dx/dS) 1e-30 dx/dS))))
         (dS/dy (abs (/ 1 (if (zerop dy/dS) 1e-30 dy/dS)))))

    (let dda ((next-x (* dS/dx
                         (if (< dx/dS 0)
                             (- (get-x location) (floor (get-x location)))
                             (- (+ 1.0 (floor (get-x location))) (get-x location)))))
              (mapx (floor (get-x location)))
              (next-y (* dS/dy
                         (if (< dy/dS 0)
                             (- (get-y location) (floor (get-y location)))
                             (- (+ 1.0 (floor (get-y location))) (get-y location)))))
              (mapy (floor (get-y location)))
              (distance 0))
      (cond ((not (zerop (aref (get-maze location) mapx mapy))) distance)
            ((< next-x next-y)
             (dda (+ next-x dS/dx) (+ mapx x-step)
                  next-y mapy
                  next-x))
            (t
             (dda next-x mapx
                  (+ next-y dS/dy) (+ mapy y-step)
                  next-y))))))

(defparameter +field-of-view+ (/ pi 4))

(defun column->theta (column)
  (- (* (/ column +window-width+) +field-of-view+) (/ +field-of-view+ 2)))

(defun vraster (location column)
  (let* ((theta (column->theta column))
         (distance (range location theta))
         (px (+ (get-x location) (* (sin (+ (get-theta location) theta)) distance)))
         (py (+ (get-y location) (* (cos (+ (get-theta location) theta)) distance)))
         (wx (< (abs (- py (round py))) 0.05))
         (wy (< (abs (- px (round px))) 0.05)))
    (values
     (min #xFF (floor (/ (if wx #xff #x00) distance)))
     (min #xFF (floor (/ #xfF distance)))
     (min #xFF (floor (/ (if wy #xff #x00) distance)))
     (min +window-height+ (/ (* +window-height+ 2) distance)))))

(defmethod render! (renderer (fp-view fp-view))
  (dotimes (column +window-width+)
    (multiple-value-bind (r g b height)
        (vraster (get-location fp-view) column)
      (sdl2:set-render-draw-color renderer r g b #xFF)
      (sdl2:render-draw-line renderer
                             column (round (+ (/ +window-height+ 2) (/ height 2)))
                             column (round (- (/ +window-height+ 2) (/ height 2)))))))

;; (run (list (make-instance 'fp-view :location (make-instance 'location))))

Monday, September 5, 2022

Drawing a circle

SDL is your bare bones graphics interface. It gives you primitives like draw-point, draw-line, and draw-rectangle, but you're on your own if you want to draw a circle. Naturally, I cribbed the code from stackoverflow.

Small circles didn't look right — they were a little squarish. The code worked by walking along pixels in one direction and accumulating an error term. When the error term got large enough, it would be reset and the code would advance a step along the other pixel axis. The error term was computed using integer math so that the circle was drawn quickly. The problem is that the integer math has rounding error and the rounding error is noticable with small circles.

For reference, it is straightforward to draw an exact circle. A circle isn't a function, but circle segment between 0 and 45 degrees is a function. If we mirror that segment eight ways horizontally, vertically, and at 90 degrees, we'll get a full circle.

(defun eightfold-point (renderer center-x center-y x y)
  (sdl2:render-draw-point renderer (+ center-x x) (+ center-y y))
  (sdl2:render-draw-point renderer (+ center-x x) (- center-y y))
  (sdl2:render-draw-point renderer (- center-x x) (+ center-y y))
  (sdl2:render-draw-point renderer (- center-x x) (- center-y y))

  (sdl2:render-draw-point renderer (+ center-x y) (- center-y x))
  (sdl2:render-draw-point renderer (+ center-x y) (+ center-y x))
  (sdl2:render-draw-point renderer (- center-x y) (- center-y x))
  (sdl2:render-draw-point renderer (- center-x y) (+ center-y x)))

(defun draw-circle (renderer center-x center-y radius)
  (let ((r-squared (* radius radius)))
    (dotimes (x (1+ (ceiling (/ radius (sqrt 2)))))
      (eightfold-point renderer
                       center-x center-y
                       x (round (sqrt (- r-squared (* x x))))))))
This gives much rounder looking circles than the code I cribbed from stackoverflow.

The problem, of course, is that this code computes a square root on each iteration. These days, computers are fast and that's not a big issue, but let's try to improve things.

On each iteration, we are computing the square root of r2-x2. This quantity changes between iterations, but not by much. You can compute a square root pretty quickly using Newton's method. The square root computed last iteration isn't that far from the new square root, so we can use the previous square root as the initial guess for Newton's method. Since we started pretty close to the right answer, we only need a single pass of Newton's method to get close enough to the square root for the current iteration.

(defun average (a b) (/ (+ a b) 2))

(defun draw-circle1 (renderer center-x center-y radius)
  (let ((x-limit (ceiling (/ radius (sqrt 2)))))
    (do ((x 0 (1+ x))
         (o 1 (+ o 2))
         (r2-x2 (* radius radius) (- r2-x2 o))
         (y radius (round (average y (/ (- r2-x2 o) y)))))
        ((> x x-limit))
      (eightfold-point renderer center-x center-y x y))))

This gives us pretty round circles — rounder than the integer methods, but not as round as the sqrt method. It requires less arithmetic than the sqrt method, but more than the integer method. What is more annoying, squarish circles or the amount of time it takes to draw round ones?

Wednesday, August 17, 2022

Playing with graphics

I wanted to play with some graphics. I don't know much about graphics, so I wanted to start with the basics. I played around with a couple of demos and I found that easiest to get reliably working was SDL2.

After downloading the SDL binary library and installing the FFI bindings with Quicklisp, I was off and running. You can find numerous SDL demos and tutorials on line and I tried a number of them. After I felt confident I decided to try something simple.

One thing I've noticed about graphics programs is the ubiquity of mutable state. Everything seems mutable and is freely modified and global variables abound. As a mostly functional programmer, I am alarmed by this. I wanted to see where we'd get if we tried to be more functional in our approach and avoid mutable data structures where practical.

Now the pixels on the screen had best be mutable, and I'm not trying to put a functional abstraction over the drawing primitives. We'll encapsulate the rest of the state in a state machine that is driven by the SDL event loop. The state machine will keep track of time and the current world. The current world is simply an immutable list of immutable objects. The state machine can transition through a render! phase, where it renders all the objects in the current world to a fresh frame. It attempts to do this about 75 times a second. The state machine can also transition through a next-world phase, where the current world and a delta-t are used to compute a new version of the world.

Our run program will take the initial list of objects. We'll start by initializing SDL, creating a window, and allocating a renderer for that window:

(defun run (initial-world)
  (sdl2:with-init (:video)
    (sdl2:with-window (window
                       :h +window-height+
                       :w +window-width+
                       :flags '(:shown))
      (sdl2:with-renderer (renderer window :index -1 :flags '())
        ... )))

Now we need the event loop state. last-ticks records the value from sdl2:get-ticks from the last time we processed the :idle event. This will be used to compute the elapsed time in ticks. render-ticker will record how many ticks have elapsed since the last time we rendered a frame to the screen. When render-ticker exceeds a certain amount, we'll call (render! current-world) and reset the ticker to zero. title-ticker will record how many ticks have occurred since the last time the window title was updated. When title-ticker exceeds a certain amount, we'll call sdl2:set-window-title to update the window title with some stats. sim-count is simply the number of times we've iterated next-world and frame-count is the number of times we've called render!. These are reset to zero every time we refresh the window title, so we'll have the frames per second and the world steps per second in the window title.

        (let ((last-ticks 0)
              (render-ticker 0)
              (title-ticker 0)
              (sim-count 0)
              (frame-count 0)
              (world initial-world))

          (flet ((title-tick! (dticks)
                   (incf title-ticker dticks)
                   (when (>= title-ticker 1000)
                     (decf title-ticker 1000)
                     (sdl2:set-window-title window (format nil "Sim rate: ~d, Frame rate: ~d" sim-count frame-count))
                     (setq sim-count 0)
                     (setq frame-count 0)))

                 (world-tick! (dticks)
                   (incf sim-count)
                   (setq world (next-world world (/ dticks 1000))))

                 (render-tick! (dticks)
                   (incf render-ticker dticks)
                   (when (>= render-ticker 13)
                     (incf frame-count)
                     (decf render-ticker 13)
                     (render-world! renderer world))))

Now we can run the event loop. The idle event is where the action happens:

          (sdl2:with-event-loop (:method :poll)

              (:idle ()
                     (let ((this-ticks (sdl2:get-ticks)))
                       (if (= this-ticks last-ticks)
                           (sdl2:delay 1)
                           (let ((dticks (- this-ticks last-ticks)))
                             (setq last-ticks this-ticks)
                             (title-tick! dticks)
                             (world-tick! dticks)
                             (render-tick! dticks)))))

              (:keydown (:keysym keysym)
                        (case (sdl2:scancode keysym)
                          (:scancode-escape (sdl2:push-quit-event))
                          (:scancode-x      (sdl2:push-quit-event))))

              (:quit () t))

Now that's a bunch of state, but it's more or less under control because what we have is a state machine and the state variables aren't accessible to anything.

render-world! is straightforward. It clears the renderer, calls render! on every object in the world, and presents the renderer for display.

(defun render-world! (renderer world)
  (sdl2:set-render-draw-color renderer #x00 #x00 #x00 #xFF)
  (sdl2:render-clear renderer)
  (mapc (lambda (object) (render! renderer object)) world)
  (sdl2:render-present renderer)
  )

next-world is a function that maps the current world to the next. It basically calls next on each object in the world and accumulate the results. We want objects to be able to go away, so if (next object) returns nil, we don't accumulate anything in the new world. If next returns the object unchanged, it will be accumulated unchanged in the next world. (next object) returns a new version of an object to simulate an update to the object. We want to be able to increase the amount of objects, so we allow (next object) to return a list of objects to be accumulated.

(defun next-world (previous-world dt)
  (fold-left
   (lambda (items item)
     (let ((more (next item dt)))
       (cond ((null more) items)
             ((consp more) (append more items))
             (t (cons more items)))))
   '()
   previous-world))

We'll start with a user-controlled player.

(defclass player ()
  ((x :initarg :x
      :reader get-x)
   (y :initarg :y
      :reader get-y)))

Everything that is to be displayed needs a render! method. This one just draws a little green triangle facing up.

(defmethod render! (renderer (player player))
  (let ((x (floor (get-x player)))
        (y (floor (get-y player))))
    (sdl2:set-render-draw-color renderer #x00 #xFF #x00 #xFF)
    (sdl2:render-draw-line renderer (- x 8) (+ y 8) (+ x 8) (+ y 8))
    (sdl2:render-draw-line renderer (- x 8) (+ y 8) (- x 1) (- y 16))
    (sdl2:render-draw-line renderer (+ x 8) (+ y 8) x (- y 16))
    (sdl2:render-draw-point renderer x y)
    ))

The next method computes the player in the next world:


(defun x-input ()
  (- (if (sdl2:keyboard-state-p :scancode-right)
         1
         0)
     (if (sdl2:keyboard-state-p :scancode-left)
         1
         0)))

(defun y-input ()
  (- (if (sdl2:keyboard-state-p :scancode-down)
         1
         0)
     (if (sdl2:keyboard-state-p :scancode-up)
         1
         0)))

(defparameter +player-speed+ 200.0) ;; pixels per second

(defmethod next ((player player) dt)
  (let ((new-x (max 8  (min (- +window-width+ 8)
                            (+ (get-x player)
                               (* (x-input) +player-speed+ dt)))))
        (new-y (max 16 (min (- +window-height+ 8)
                            (+ (get-y player)
                               (* (y-input) +player-speed+ dt))))))
    (make-instance 'player :x new-x :y new-y)))

Once we've defined a render! method and a next method, we're ready to go. If we call run on a list containing a player object, we'll have our little player on the screen controllable with the arrow keys.

An enemy ship can be defined.

(defclass enemy ()
  ((x :initarg :x :reader get-x)
   (y :initarg :y :reader get-y)
   (dx :initarg :dx :reader get-dx)
   (dy :initarg :dy :reader get-dy)))

(defmethod next ((enemy enemy) dt)
  (let ((new-x (+ (get-x enemy) (* (get-dx enemy) dt)))
        (new-y (+ (get-y enemy) (* (get-dy enemy) dt))))
    (when (and (>= new-x 8)
               (< new-x (+ +window-width+ 8))
               (>= new-y 8)
               (< new-y (- +window-height+ 16)))
      (make-instance 'enemy
                     :x new-x
                     :y new-y
                     :dx (get-dx enemy)
                     :dy (get-dy enemy)))))

;;; Render method omitted

As given, enemy ships will drift at constant speed until they run off the screen. We'd like to replenish the supply, so we'll make an enemy spawner:

(defclass enemy-spawner ()
  ((timer :initarg :timer :initform 0 :reader get-timer)))

(defmethod next ((spawner enemy-spawner) dt)
  (let ((new-time (- (get-timer spawner) dt)))
    (if (> new-time 0)
        (make-instance 'enemy-spawner :timer new-time)
        (list (make-instance 'enemy-spawner :timer (+ 1 (random 4)))
              (make-instance 'enemy :x (random (+ (- +window-width+ 32) 16))
                                    :y 16
                                    :dx (- 25 (random 50))
                                    :dy (+ (random 100) 50))))))

(defmethod render! (renderer (enemy-spawner enemy-spawner))
  nil)
The render! method doesn't do anything so a spawner doesn't have an image. It simply has a timer. To compute the next spawner, we subtract dt and create a new spawner with the reduced amount of time. If that's not a positive amount of time, though, we create two objects: a new spawner with somewhere between 1 and 5 seconds time and a new enemy ship.

We'll modify our player to allow him to shoot at the enemy:

(defclass player ()
  ((x :initarg :x
      :reader get-x)
   (y :initarg :y
      :reader get-y)
   (fire-cycle :initarg :fire-cycle
               :initform 0
               :reader get-fire-cycle)))

(defmethod next ((player player) dt)
  (let ((new-x (limit 8 (- +window-width+ 8) (+ (get-x player) (* (x-input) +player-speed+ dt))))
        (new-y (limit 16 (- +window-height+ 8) (+ (get-y player) (* (y-input) +player-speed+ dt))))
        (next-fire-cycle (- (get-fire-cycle player) dt)))
    (if (and (sdl2:keyboard-state-p :scancode-space)
             (< next-fire-cycle 0))
        (list
         (make-instance 'player
                        :x new-x
                        :y new-y
                        :fire-cycle .1)
         (make-instance 'bullet
                               :x (- (get-x player) 8)
                               :y (- (get-y player) 16)
                               :dx 0
                               :dy (- +bullet-speed+))
         (make-instance 'bullet
                               :x (+ (get-x player) 8)
                               :y (- (get-y player) 16)
                               :dx 0
                               :dy (- +bullet-speed+)))
        (make-instance 'player
                       :x new-x
                       :y new-y
                       :fire-cycle next-fire-cycle))))

A bullet is a simple moving object:

(defclass bullet ()
  ((x :initarg :x :reader get-x)
   (y :initarg :y :reader get-y)
   (dx :initarg :dx :reader get-dx)
   (dy :initarg :dy :reader get-dy)))

(defmethod next ((bullet bullet) dt)
  (let ((new-x (+ (get-x bullet) (* (get-dx bullet) dt)))
        (new-y (+ (get-y bullet) (* (get-dy bullet) dt))))
    (when (and (>= new-x 0)
               (< new-x +window-width+)
               (>= new-y 0)
               (< new-y +window-height+))
      (make-instance 'bullet
                     :x new-x
                     :y new-y
                     :dx (get-dx bullet)
                     :dy (get-dy bullet)))))

At this point we can move around the screen and shoot at enemies that spawn periodically. The problem is that the bullets go right through the enemy. We need to handle object collisions. We'll modify the next-world function. As it loops over the objects in the world, it will perform an inner loop that checks for collisions with other objects. If two objects collide, a function is called to get the collision results and those results are added to the list of objects in the world. If an object doesn't collide with anything, the next method is called to get the next version of the object.

(defun next-world (previous-world dt)
  (let outer ((tail previous-world)
              (next-world '()))
    (cond ((consp tail)
           (let ((this (car tail)))
             (let inner ((those (cdr tail)))
               (cond ((consp those)
                      (let ((that (car those))
                            (others (cdr those)))
                        (if (collides? this that)
                            (outer (append (collide this that) (delete that (cdr tail)))
                                   next-world)
                            (inner others))))
                     ((null those)
                      (outer (cdr tail)
                             (let ((more (next this dt)))
                               (cond ((consp more) (append more next-world))
                                     ((null more) next-world)
                                     (t (cons more next-world))))))
                     (t (error "Bad list."))))))
          ((null tail) next-world)
          (t (error "Bad list.")))))

We define collides? as a generic function that returns nil by default

(defgeneric collides? (this that)
  (:method ((this t) (that t)) nil)
  )
so that most objects don't collide. In the case where something does collide, we'll define collide as a generic function that returns nil by default
(defgeneric collide (this that)
  (:method ((this t) (that t)) nil)
  )
so when two objects collide, they simply disappear.

collides? will be called on pairs of objects in no particular order, so method pairs will be needed to handle both orders. We'll define collides? methods on bullets and enemies that checks if the bullet is within the bounding box of the enemy:

(defmethod collides? ((this bullet) (that enemy))
  (and (> (get-x this) (- (get-x that) 8))
       (< (get-x this) (+ (get-x that) 8))
       (> (get-y this) (- (get-y that) 8))
       (< (get-y this) (+ (get-y that) 8))))

(defmethod collides? ((this enemy) (that bullet))
  (collides? that this))

At this point, we can shoot enemy ships. The default method for collide between an enemy and a bullet returns nil so the enemy and the bullet simply disappear. If we were fancy, we could arrange for it to return an explosion object or several debris objects.

It would be nice to keep a tally of the number of enemy ships we have shot. We don't have to add any extra machinery for this. We create a score class and a point class:

(defclass score ()
  ((value :initarg :value
          :reader get-value)))

(defmethod next ((score score) dt) score)

;;; Render method prints score on screen.

(defclass point ()
  ((value :initarg :value
          :reader get-value)))

(defmethod next ((point point) dt) point)

(defmethod render! (renderer (point point)) nil)
Scores and points are immutable objects without positions, but we'll define methods so that when a score and a point collide, the result is a higher score.
(defmethod collides? ((this point) (that score)) t)
(defmethod collides? ((this score) (that point)) t)

(defmethod collide ((this point) (that score))
  (list (make-instance 'score
                       :font (get-font that)
                       :value (+ (get-value this) (get-value that)))))

(defmethod collide ((this score) (that point))
  (collide that this))
Now we'll define a bullet colliding with an enemy to produce a point:
(defmethod collide ((this bullet) (that enemy))
  (list (make-instance 'point :value 1)
        ;; add explosion object here
        ))

(defmethod collide ((this enemy) (that bullet))
  (collide that this))
So when you shoot an enemy, the bullet and enemy disappear to be replaced by a point. On the next update, the point will collide with the score to be replaced with an updated score.

At this point we've got a little demo game where we can fly a ship around and shoot enemies and a running score is kept. The world model is immutable and worlds are functions of previous worlds. I'll call it a successful proof of concept.

But did this buy us anything? We don't have mutable state per se, but we've kind of cheated. When we create new versions of an object, each version is immutable, but the sequence of versions taken as a whole seem to be evolving over time. For example, consider the score. At each time step, there is an immutable score object, but over time what is considered the current score changes. We've eliminated the direct problems of mutation, but we've introduced the problem of keeping track of what series of immutable versions correspond to a single evolving instance.

In this small example, we're not keeping track of the evolving objects. For instance, each bullet, as it is updated from step to step, is actually created anew at its new position on each step. The old bullet instance is dropped and the new instance really has no idea how it got there. Bullets are such simple objects that this doesn't matter, but the current score is different. It makes sense for there to be a singleton score object that increases over time, but we haven't built that in to our model. Instead, we've designed a set of collision interactions that drive the score.

We've eliminated the direct mutable state in our objects and our world, but sometimes we want to model stateful objects. We therefore create objects that represent state transitions (e.g. points) and then use the collision mechanism to combine the transition objects with the objects that represent physical entities. That seems a bit convoluted, and I don't think it will scale.

On the other hand, we do gain the immediate benefits of the world and the objects being immutable. Saving and restoring a world is trivial. Reasoning about objects at each update is easy because the objects don't change, but we now have to reason about how objects appear to change in the long run.

The tradeoff of immutable objects is increased allocation. But although a lot more consing is happening, most of it can be quickly reclaimed by the generational collector, so noticable GC pauses are infrequent. I haven't measured the performance, but it is certainly adequate for the little example I wrote. If you had a mechanism to reason about the objects as linear types (Sufficiently Smart Compiler), you could determine when you can update objects in place and avoid reallocating.

The world model, simply a list of objects, is flexible, but not well structured. For instance, the current score and the bullets are among the elements mixed together in this list. You'd have to search this list to find specific elements or filter this list to find elements of a certain type.

The simple collision model is O(n2), so it can't handle a ton of objects. A more sophisticated world model would be needed to keep track of different classes of collidable objects to avoid the O(n2) search. For example, if bullets were kept separately, we could avoid checking if they collide with each other.

The point of this exercise was to play with graphics and see what you can do without the mutable state that is alarmingly ubiquitous. It turns out that you can go pretty far, but it's kind of strange.

Saturday, July 30, 2022

Let's Play Wordle

Wordle is popular these days. Let's teach the computer how to play.

As usual, I'm using the series library. Also, if you are coding along, there's a function or two I omitted that you'll have to write yourself. Note that I use a named-let, too.

To play Wordle, you try to deduce the secret word by making guesses. After each guess, you are told which letters you got exactly right and which are right, but in the wrong position. Each guess narrows down the number of possible answers until there is one left. It's a simple matter of making good guesses.

Here I define a word as a simple string of five characters and a predicate for testing that the word is all lowercase, alphabetic, ascii characters.

(deftype word () `(simple-string 5))

(defun valid-word? (thing)
  (and (typep thing 'word)
       (str:downcase? thing)
       (every #'alpha-char-p thing)
       (every #'str:ascii-char-p thing)))

I don't use a satisfies clause in the word type. satisfies can cause issues with optimization and performance because it is can be hard to control where the compiler inserts type checks. I just manually call valid-word? when necessary.

To read a word file, we read each line in the file, trim it, and select only the valid words. This works on the canonical word files, but you can read words from the system dictionary or other places if you want.

(defun read-word-file (pathname)
  (collect 'bag
    (choose-if #'valid-word?
      (map-fn 'string #'str:trim
        (scan-file pathname #'read-line)))))

(defparameter +word-file+ "~/wordle/words.txt")
(defparameter +answer-file+ "~/wordle/answers.txt")

(defparameter +all-words+ (read-word-file +word-file+))
(defparameter +all-answers+ (read-word-file +all-answers+))

We need to score a guess. When you make a guess, the squares under the letters turn green if the letter is correct, yellow if the letter is incorrect, but appears in the answer, and gray if the letter does not appear in the answer. We'll just return a list of the colors (as keywords). For example, (score-guess "react" "relay") => (:green :green :yellow :gray :gray)

score-guess first needs a list of the letters in the answer that don't match the guess:

(let ((sg (scan 'string guess))
      (sa (scan 'string answer)))
  (collect 'bag
    (choose (map-fn 'boolean #'char/= sg sa) sa)))
then we walk the guess. If the guess character equals the answer character, we cons a :green on to the score. If the guess character is a member of the unmatched answer characters, we cons a :yellow on to the score and delete that character from the unmatched characters. Otherwise, we cons a :gray on to the score.
(defun score-guess (guess answer)
  (declare (type word guess answer))
  (let walk ((index 0)
             (score '())
             (unmatched-chars (let ((sg (scan 'string guess))
                                    (sa (scan 'string answer)))
                                (collect 'bag
                                  (choose (map-fn 'boolean #'char/= sg sa) sa)))))
    (if (>= index 5)
        (nreverse score)
        (let ((guess-char (schar guess index)))
          (cond ((char= guess-char (schar answer index))
                 (walk (1+ index) (cons :green score) unmatched-chars))
                ((member guess-char unmatched-chars)
                 (walk (1+ index) (cons :yellow score) (delete guess-char unmatched-chars)))
                (t
                 (walk (1+ index) (cons :gray score) unmatched-chars)))))))

Once we've made a guess and have a score, we'll want to narrow down the possible words. We just go over the word list and keep the words that have a matching score.

(defun prune-words (guess score words)
  (declare (optimizable-series-function) (off-line-port words))
  (choose-if
   (lambda (word)
     (equal (score-guess guess word) score))
   words))

We'll need a strategy for picking a word to guess. Here's an easy, naive one to start with: if there is only one possible word left, guess that one, otherwise guess a completely random word and narrow down the possibility list.

(defun strategy/random-word (possibilities)
  (if (= (length possibilities) 1)
      (car possibilities)
      (random-word +all-words+)))

So let's imagine the top level. The play function will play a single round of Wordle. We'll be keeping track of the possible words as we go. We choose a guess based on our strategy, then score the guess. If we got the right answer, we're done, but otherwise we narrow down the list of possibilites to those that have the same score and play the next round.

(defun play (strategy &optional (round 1)
                        (possibilities +all-answers+)
                        (secret-word (random-word +all-answers+)))
  (let* ((guess (funcall strategy possibilities))
         (score (score-guess guess secret-word)))
    (format t "~&~d guessing ~s ~s ..." round guess score)
    (if (equal score '(:green :green :green :green :green))
        (progn (format t "correct.") round)
        (let ((new-possibilities
                (collect 'bag (prune-words guess score (scan 'list possibilities)))))
          (format t "narrowed to ~d possibilities." (length new-possibilities))
          (play strategy (+ round 1) new-possibilities secret-word)))))

WORDLE> (play #'strategy/random-word)

1 guessing "culty" (:GRAY :GRAY :GRAY :GRAY :GRAY) ...narrowed to 519 possibilities.
2 guessing "hings" (:GRAY :GRAY :GRAY :GRAY :GRAY) ...narrowed to 101 possibilities.
3 guessing "india" (:GRAY :GRAY :YELLOW :GRAY :GRAY) ...narrowed to 9 possibilities.
4 guessing "lauds" (:GRAY :GRAY :GRAY :YELLOW :GRAY) ...narrowed to 8 possibilities.
5 guessing "stedd" (:GRAY :GRAY :GRAY :GRAY :GREEN) ...narrowed to 2 possibilities.
6 guessing "khets" (:GRAY :GRAY :GRAY :GRAY :GRAY) ...narrowed to 2 possibilities.
7 guessing "bared" (:GREEN :GRAY :YELLOW :GRAY :GREEN) ...narrowed to 1 possibilities.
8 guessing "brood" (:GREEN :GREEN :GREEN :GREEN :GREEN) ...correct.
8

It plays Wordle. Not very well, but it plays. This strategy seems to average a bit more than seven guesses a game. A better strategy should reduce this average.

When you guess a word, you divide the space of possible answers into a set of equivalence classes by score. I picture these as a set of bins, each labeled with a different score, like (:green :gray :gray :yellow :gray). Making a guess divides the list of possible words among the bins. A bad guess will only use a few bins and have uneven bins. A good guess will use a larger set of bins and divide things more evenly.

We'll need a function to collect the counts of an item in a series

(defun collect-counts (test items)
  (declare (optimizable-series-function))
  (collect-fn t
              (lambda () (make-hash-table :test test))
              (lambda (table item)
                (incf (gethash item table 0))
                table)
              items))
So now we go through a series of words, score the guess against each one, and count how many times we get each score.
(defun partition-words (guess words)
  (declare (optimizable-series-function))
  (collect-counts 'equal
                  (map-fn 'list #'score-guess
                          (series guess)
                          words)))
This returns a hash table that maps scores to the number of words matching that score. We need to measure how good a job this table does at narrowing down the word list.

We'll need a couple of helpers:

(defun weighted-sum (weights elements)
  (declare (optimizable-series-function))
  (collect-sum (map-fn 'real #'* weights elements)))

(defun scan-hash-values (hash-table)
  (declare (optimizable-series-function))
  (multiple-value-bind (keys values) (scan-hash hash-table)
    (declare (ignore keys))
    values))

Now we have to decide how to evaluate how well a partition (set of bins) narrows down possible word list. Suppose our word list originally had 128 words. That's 27 items, so it would take seven binary splits to single out a word. Now suppose after narrowing, we find we're down to 16 words. That's 24 items, so the narrowing is equivalent to three binary splits. The value of an entire set of bins is the weighted average of the narrowing of each bin.

(defun evaluate-partition1 (partition)
  (let* ((original-size (collect-sum (scan-hash-values partition)))
         (original-bits (log2 original-size)))

    (flet ((info-gain (bin-size)
             (- original-bits (log2 bin-size)))

           (weight (bin-size)
             (/ (coerce bin-size 'double-float)
                (coerce original-size 'double-float))))

      (let ((bin-sizes (scan-hash-values partition)))
        (weighted-sum
         (map-fn 'real #'weight bin-sizes)
         (map-fn 'real #'info-gain bin-sizes))))))

(defun evaluate-guess (guess possibilities)
  (evaluate-partition (partition-words guess (scan 'list possibilities))))

(defun best-guess (guesses possibilities)
  (best #'> guesses :key (lambda (guess) (evaluate-guess guess possibilities))))

WORDLE> (play #'strategy/best-word)

1 guessing "soare" (:GRAY :GREEN :GRAY :GRAY :GRAY) ...narrowed to 87 possibilities.
2 guessing "culty" (:GRAY :GRAY :YELLOW :GRAY :GRAY) ...narrowed to 1 possibilities.
3 guessing "login" (:GREEN :GREEN :GREEN :GREEN :GREEN) ...correct.
3

With this strategy, we seem to average about 3.5 guess per game. This is much better than the tad over 7 we had before.

Sunday, July 24, 2022

Named Lambda and Named Let

Suppose you want to map the "add three" function over a list. You don't need to define a name for the function, you can just use a lambda expression: (lambda (n) (+ n 3)). This creates an anonymous "add three" function.

Now suppose you want to map the "factorial" function over a list. You start with (lambda (x) (if (zerop x) 1 ... , but how can you recursively call an anonymous function? We need the function to have a local name within its own body. One option is to use the Y operator:

* (map 'list (Y (lambda (fact)
                  (lambda (x)
                    (if (zerop x)
                        1
                        (* x (funcall fact (1- x)))))))
       '(3 5 7))
(6 120 5040)
but another popular option is to provide a new special form
* (map 'list (named-lambda fact (x)
               (if (zerop x)
                   1
                   (* x (fact (1- x)))))
     '(3 5 7))
(6 120 5040)
The name fact is bound to the lambda expression only within the body of the lambda expression. You don't need to defun a factorial procedure, you can just use a named-lambda.

A little puzzle for you: write named-lambda. My answer below.

Just as a let is syntactic sugar for a lambda application, a named-let is syntactic sugar for a named-lambda application. The name is bound to the lambda expression that performs the variable binding, so you can use that name to make a recursive call. In effect, you can re-invoke the named-let expression with a fresh set of values.

Scheme hackers will be familiar with named-let, but it isn't usual in Common Lisp. It's an easy transformation:

(named-let recur ((x '(a list))
                  (y 22))    
   (body)) =>

(funcall (named-lambda recur (x y) (body)) '(a list) 22)
named-let is the bee's knees for ad hoc iteration. The iteration variables are bound to their initial values by the named-let, and the body can initiate the next iteration by tail-calling the named-let with the updated values for the iteration variables. Since there is no constraint on where or when you iterate, or how you update the iteration variables, this allows very general iteration.

I have seen a tendency for Scheme hackers to overdo it with named lets. You don't need a named-let when map will do. It's usually better to express an iteration through a higher order function than to write yet another ad hoc loop in your code. But named-let is a useful and powerful tool when the simpler methods aren't cutting it.

Here's what I came up with for named-lambda:

(defmacro named-lambda (name (&rest arglist) &body body)
  `(labels ((,name ,arglist ,@body))
     (function ,name)))

Saturday, July 16, 2022

Let's talk to GitHub

Let's teach Common Lisp to talk to GitHub.

We'll need an API token. I like to put these sorts of things in config files. This makes it easier to configure scripts that are deployed to containers. You simply make the config files available through a mount point when starting the container. That way, you can avoid baking credentials into the script.

(defun config-directory ()
  (merge-pathnames
    (make-pathname :directory '(:relative ".config" "github"))
    (user-homedir-pathname)))

(defun config-file (&rest keyargs)
  (merge-pathnames (apply #'make-pathname keyargs) (config-directory)))

(defun load-token (pathname)
  (with-open-file (stream pathname :direction :input)
    (str:trim (read-line stream))))

(defun github-api-token ()
  (load-token (config-file :name "api-token")))

We'll make a lot of use miscellaneous, ad hoc CLOS objects. It is so common for these things to have names that it is worth its own mixin.

(defgeneric get-name (object))

(defclass named-object-mixin ()
  ((name :initarg :name
         :initform (require-initarg :name)
         :reader get-name
         :type string)))

And we'll define a default print-object method. Classes that use this mixin and don't provide their own print-object method will get this one by default.

(defmethod print-object ((obj named-object-mixin) stream)
  (print-unreadable-object (obj stream :identity t :type t)
    (format stream "~a" (slot-value obj 'name))))

We'll make an object to represent GitHub and put the API token in there.

(defclass github (named-object-mixin)
  ((api-token :initarg :api-token
              :initform (require-initarg :api-token)
              :reader get-api-token)))

(defparameter +github+ nil)

(defun github ()  
  (unless (and (boundp '+github+)
               (symbol-value '+github+))
    (setf (symbol-value '+github+)
          (make-instance 'github 
                         :name "GitHub"
                         :api-token (github-api-token))))
  (symbol-value '+github+))

To authenticate to GitHub, we need to pass the API token in the HTTP request headers.

(defun authorization-header (github)
  (cons "Authorization" (format nil "token ~a" (get-api-token github))))
So let's make a request:
* (dex:get "https://api.github.com/user"
           :headers (list (authorization-header (github))
                          '("Accept" . "application/vnd.github.v3+json")))
"{"login":"joseph-marshall69","id":60371090,"node_id":"MDQ6VXNlcjYwMzcxMDkw","avatar_url":"https://avatars.githubusercontent.com/u/60371090?v=4","gravatar_id":"","url":"https://api.github.com/users/jos...[sly-elided string of length 1535]"
200 (8 bits, #xC8, #o310, #b11001000)
#<HASH-TABLE :TEST EQUAL :COUNT 26 {1002A9B2A3}>
#<QURI.URI.HTTP:URI-HTTPS https://api.github.com/user>
#<CL+SSL::SSL-STREAM for #<FD-STREAM for "socket 172.26.126.123:33674, peer: 192.30.255.116:443" {1002A96333}>>
Success! But we got back the string representation of a JSON object. We'll instead request a stream as a return value and pass it to a JSON parser:
* (json:decode-json
    (dex:get "https://api.github.com/user"
             :headers (list (authorization-header (github))
                            '("Accept" . "application/vnd.github.v3+json"))
             :want-stream t))

((:LOGIN . "jrm-code-project") (:ID . 51824598)
 (:NODE--ID . "MDQ6VXNlcjUxODI0NTk4")
 (:AVATAR--URL . "https://avatars.githubusercontent.com/u/51824598?v=4")
 (:GRAVATAR--ID . "") (:URL . "https://api.github.com/users/jrm-code-project")
 (:HTML--URL . "https://github.com/jrm-code-project")
 (:FOLLOWERS--URL . "https://api.github.com/users/jrm-code-project/followers")
 (:FOLLOWING--URL
  . "https://api.github.com/users/jrm-code-project/following{/other_user}")
 (:GISTS--URL
  . "https://api.github.com/users/jrm-code-project/gists{/gist_id}")
 (:STARRED--URL
  . "https://api.github.com/users/jrm-code-project/starred{/owner}{/repo}")
 (:SUBSCRIPTIONS--URL
  . "https://api.github.com/users/jrm-code-project/subscriptions")
 (:ORGANIZATIONS--URL . "https://api.github.com/users/jrm-code-project/orgs")
 (:REPOS--URL . "https://api.github.com/users/jrm-code-project/repos")
 (:EVENTS--URL
  . "https://api.github.com/users/jrm-code-project/events{/privacy}")
 (:RECEIVED--EVENTS--URL
  . "https://api.github.com/users/jrm-code-project/received_events")
 (:TYPE . "User") (:SITE--ADMIN) (:NAME . "Joe Marshall") (:COMPANY)
 (:BLOG . "https://sites.google.com/site/evalapply/")
 (:LOCATION . "Seattle, WA") (:EMAIL) (:HIREABLE) (:BIO) (:TWITTER--USERNAME)
 (:PUBLIC--REPOS . 9) (:PUBLIC--GISTS . 0) (:FOLLOWERS . 21) (:FOLLOWING . 0)
 (:CREATED--AT . "2019-06-14T12:33:06Z")
 (:UPDATED--AT . "2022-03-15T15:18:03Z") (:PRIVATE--GISTS . 0)
 (:TOTAL--PRIVATE--REPOS . 0) (:OWNED--PRIVATE--REPOS . 0)
 (:DISK--USAGE . 44815) (:COLLABORATORS . 0) (:TWO--FACTOR--AUTHENTICATION)
 (:PLAN (:NAME . "free") (:SPACE . 976562499) (:COLLABORATORS . 0)
  (:PRIVATE--REPOS . 10000)))

JSON objects are mapped to alists. The key is a little funny because of how the JSON parser encodes JSON keys with underscores.

An alist is sort of a poor man's object. The problem with an alist is that there is no type associated with it. We know the slots in our poor man's object, but we don't know the class. Without the class information, we don't have a predicate or a way to dispatch to methods. We should create a real CLOS object from this JSON.

(defclass user (named-object-mixin)
  ((login :initarg :login)
   (id :initarg :id)
   (node-id :initarg :node--id)))

(defun json->user-instance (json)
  (apply #'make-instance 'user
         :allow-other-keys t
         (alist->plist json)))

Should we want to bring more fields into Lisp, we need simply add slots with the right initargs to the user class.

Now we can write

(defun get-self (github)
  (json->user-instance
    (json:decode-json
      (dex:get "https://api.github.com/user"
               :headers (list (authorization-header github)
                              '("Accept" . "application/vnd.github.v3+json"))
               :want-stream t))))

* (get-self (github))
#<USER Joe Marshall {1002BE7013}>

* (inspect *)

The object is a STANDARD-OBJECT of type USER.
0. NAME: "Joe Marshall"
1. LOGIN: "jrm-code-project"
2. ID: 51824598
3. NODE-ID: "MDQ6VXNlcjUxODI0NTk4"

GitHub is moving to a GraphQL API. That's easy to handle.


(defun graphql-query (github query &rest variables)
  (let ((content (json:encode-json-to-string
                  `((query . ,query)
                    (variables . ,(plist->alist variables))))))
    (let* ((json (json:decode-json
                  (dex:post "https://api.github.com/graphql"
                            :headers (list (authorization-header github)
                                           '("Accept" . "application/vnd.github.v3+json")
                                           '("Content-Type" . "application/json"))
                            :content content
                            :want-stream t)))
           (errors (cdr (assoc :errors json))))
      (when errors
        (let ((first-error (car errors)))
          (error (cdr (assoc :message first-error)))))
      (cdr (assoc :data json)))))

(defparameter +get-user-by-login-query+
  "query ($login: String!) {
     user (login: $login) {
       databaseId
       login
       name
       }
    }")
    
* (graphql-query (github) +get-user-by-login-query+ :login "jrm-code-project")
((:USER (:DATABASE-ID . 51824598) (:LOGIN . "jrm-code-project")
  (:NAME . "Joe Marshall")))
And you can use the above technique to turn this JSON into a CLOS instance.

At this point we're cooking. We can call GitHub from Common Lisp and get CLOS objects in return. Of course we need more calls other than get-user, but it's more of the same. With this layer as our basis, it is straightforward to script GitHub.

Thursday, July 7, 2022

Series tips and tricks

I'm an aficionado of the Common Lisp series package. Here are a couple of tricks and tips.

The series package works by walking your code at macro expansion time. It is able to perform better optimizations if it can walk the Common Lisp forms DEFUN, FUNCALL, LET, LET*, and MULTIPLE-VALUE-BIND. This is easily done in a defpackage

(defpackage "MY-PACKAGE"
  (:shadowing-import-from "SERIES"
     "DEFUN" "FUNCALL" "LET" "LET*" "MULTIPLE-VALUE-BIND")
  (:use "COMMON-LISP" "SERIES"))

series will still mostly work if you don't shadowing-import these symbols, but it will miss some important optimizations. I mention this tip because I've seen people have problems by omitting this import.

series was designed to handle basic linear iteration, and it's quite good at that, but you'll really hit a wall if you try anything fancier. But I had two good cases where I wanted to push the limits. One is tree traversal. I wanted the series of nodes in a tree. This is easily done recursively, but series is going to generate an iterative loop.

We can eliminate recursion by making a state machine with a stack. We'll make a state machine that can walk the tree and create a series out of all the states it occupies as it walks. series provides us with a primitive just for this purpose:

  (scan-fn type initial-state-thunk
                state-transition-function
                final-state-p)

To traverse a tree, the initial state is just our stack. The state transition function pops the stack and pushes the children of the popped node (if any). We're done when the stack is empty.

(defun tree-walker-states (root-node node-children)
  (declare (optimizable-series-function))
  (scan-fn 'list (lambda () (list root-node))
                 (lambda (stack)
                   (append (funcall node-children (car stack)) (cdr stack)))
                 #'null))

The node being visited at each step is the one at the top of the stack, so scan-tree is simply this:

(defun scan-tree (root-node node-children)    
  (declare (optimizable-series-function))
  (map-fn 't #'car (tree-walker-states root-node node-children)))

Let's try it.

(defun pathname-children (pathname)
  (and (uiop:directory-pathname-p pathname)
       (directory (make-pathname :name :wild
                                 :type :wild
                                 :defaults pathname))))

(defun scan-directory (pathname)
  (declare (optimizable-series-function))
  (scan-tree pathname #'pathname-children))

> (collect-nth 240 (scan-directory "~/.m2/"))
#P"/home/jrm/.m2/repository/com/fasterxml/jackson/module/jackson-module-parameter-names/2.9.7/jackson-module-parameter-names-2.9.7.pom"

You can't tell from the output, but series pipelined this form. It didn't create an in-memory data structure with hundreds of thousands of pathnames just to select the 240th. It only walked the tree as far as it needed to find the 240th element.

The second case where I want to push the limits is in processing REST API calls. Some API calls return lists of items and it's nice to return them as a series. But API calls that return lists usually want to paginate the results, so we need a way to iterate over the pages while iterating over the items within the pages.

A trick similar to the previous one works. We keep a queue of items to yield and at each state transition we dequeue one item. At the end of the queue is a special item that indicates that we need to fetch the next page.

Here's how we put this together. We use scan-fn to drive the loop, we start by pushing the marker to fetch the first page, and we're done when the queue is empty:

(scan-fn 't (lambda () (list (cons :page 1)))
                 ...
                 #'null)

The state transition function examines the head of the queue. If it isn't a special marker, we just continue with the tail of the queue:

(lambda (queue)
  (let ((head (car queue)))
    (if (and (consp head)
             (eq (car head) :page))
        ...
        (cdr queue))))

If it is a :page marker, we fetch a page of elements:

(let* ((page-number (cdr head))
       (paged-url   (format nil "~a~[~;~:;?page=~:*~d~]" base-url page-number)))
   (multiple-value-bind (stream code reply-headers)
       (dex:get paged-url
                :headers request-headers
                :want-stream t)
     ...))

And we construct the new queue. The elements are decoded from the stream, but if we have more pages, we append the next page marker to the list of elements:

(append (json:decode-json stream)
        (let ((link (gethash "link" reply-headers)))
          (when (and link (search "rel=\"next\"" link))
            (list (cons :page (+ page-number 1))))))

So our scan-fn call will create the series of state-machine states. We map-fn car over the states to get a series of page elements and the occasional next-page page marker. Finally, we use choose-if to discard the page markers.

(defun scan-paged-api (base-url request-headers)
  (declare (optimizable-series-function))
  (choose-if
   (lambda (item)
     (not (and (consp item)
               (eq (car item) :page))))
   (map-fn t #'car
     (scan-fn 'list
       (lambda () (list (cons :page 1)))
       (lambda (stack)
         (let ((top (car stack)))
           (if (and (consp top)
                    (eq (car top) :page))
               (let* ((page-number (cdr top))
                      (paged-url (format nil "~a~[~;~:;?page=~:*~d~]" base-url page-number)))
                 (multiple-value-bind (stream code reply-headers)
                     (dex:get paged-url
                              :headers request-headers
                              :want-stream t)
                   (assert (= code 200))
                   (append (json:decode-json stream)
                           (let ((link (gethash "link" reply-headers)))
                             (when (and link (search "rel=\"next\"" link))
                               (list (cons :page (+ page-number 1))))))))
               (cdr stack))))
      #'null))))

That's pretty complex. What's the payoff? Later code becomes much, much simpler. Here's an example. I have a variation on the above code that is specialized for GitHub. I can, for example, write a loop that iterates through the repos in an org, filters them by name, and collects the matching ones into a list like this:

(collect 'list
  (choose-if (lambda (repo)
               (cl-ppcre:scan regex (get-name repo)))
             (scan-org-repos org)))

Now that's pretty simple and hard to get wrong.

Saturday, March 12, 2022

Obviously

It's kind of obvious that the representations you choose will influence the character of the code that uses them. If you represent things in lists, you will likely end up with code that recursively cdrs down them. If you represent things in an array, you will likely end up with code that iteratively walks through the array.

Sometimes there are several reasonable representation options and you have to make an engineering decision. Other times, there is one representation option that is obviously superior. But often enough there is one representation option that is obvious, but not necessarily superior. You don't want to pick a representation simply because it is obvious.

Let me give a concrete example. The problem is implementing a Tic Tac Toe server. Our junior programmer reasons as follows: the game is played on a three by three grid, which should obviously be a three by three array. This gives us aref and (setf aref) as primitives. We obviously need an add-mark! procedure that writes a mark into the grid at a location (and errors if the location is already marked).

(defun add-mark! (grid row column mark)
  (if (null (aref grid row column))
      (setf (aref grid row column) mark)
      (error "Cell occupied.")))

There is a bug here. If two threads call add-mark! on the same location simultaneously, one should succeed and the other should signal “Cell occupied.” The above code doesn't guarantee this.

So let's back up. Our more experienced programmer reasons like this: since we're writing a server we can expect multiple threads. An approach relying on mutable state will need synchronization mechanisms, but synchronization is a non-issue if we use immutable representations. If we decide on immutable representations, then we'll have operations like add-mark which returns a fresh object rather than mutating the existing one.

Rather than immediately pinning down a representation, our experienced programmer considers the Tic Tac Toe abstraction. What are the fundamental abstract operations? We need to be able to create an fresh game, make a mark, check to see if there are three in a row, check to see if any empty spaces are left, and print a grid. Certainly you can implement all of these if you are given aref and (setf aref), but you might choose to do things differently based on how the abstraction is going to be used. For example, if you needed to be able to rewind and replay a game, a list of moves might be a better representation.

Of course we consider a three by three array as a possible grid representation. But arrays are designed to be modified in place, so we're going to be pulled towards using them as mutable state. We have an engineering choice:

  • Implement non-destructive operations by copying the array when necessary.
  • Represent the grid differently, e.g., a pair of bitmaps.
  • Represent the entire game differently, e.g. as a list of moves
  • Implement a synchronization mechanism, e.g. a mutex
  • Punt, and let clients of the implementation figure out how to deal with the thread safety problem

A three by three array is an obvious choice for a Tic Tac Toe implementation. Depending on other considerations, though, it isn't obviously the best choice.

Monday, February 14, 2022

Symbols vs. Strings

Most popular computer languages don't have symbols as a data type. You can make do with a string, or encode your symbol as a small integer or enum. It's a hack, but simple enough and common enough that it doesn't need a second thought.

Lisp has symbols, though, so if you are using a string as a stand-in you should give it a second thought. In Lisp, symbols and strings have different roles. Strings are composite objects, symbols are atomic. String operations are concerned with the contents of the string, symbol operations are concerned with the identity of the symbol.

I saw a Common Lisp Tic Tac Toe program that represented the players' marks with the strings "X" and "O". I could see no reason why it couldn't have used the symbols 'X and 'O. Or the keywords :X and :O. Or how about the Unicode symbols '✗ and '◯?

Symbolic processing is the raison d'être of Lisp. It's a little absurd to represent symbols as strings in Lisp.

Saturday, February 5, 2022

Imperative vs. Declarative

I saw this recently:

    token = request.headers.get('Authorization')
    token = token.split(' ')[1]

From an imperative programming point of view, there is nothing wrong with this. We assign to the token variable the contents of the Authorization header, then we assign to the token variable the second substring after splitting along spaces. After executing these two statements, token will contain the desired value.

From a declarative programming point of view, this is terrible. The first statement binds the name token to the Authorization header, but the second statement contradicts the first by changing the binding of token to mean something else. Thinking declaratively, we'd much prefer either

    header = request.headers.get('Authorization')
    token = header.split(' ')[1]
or
    token = request.headers.get('Authorization').split(' ')[1]

The first option avoids the contradition and reassignment by simply using a separate variable. The item we get from request.headers isn't a token, it's a header, so we should name the variable appropriately. The token is a separate quantity that we compute from the header and the code directly reflects that.

The second option just avoids the intermediate variable and lets the compiler choose how to deal with it. Again, there is no contradiction or reassignment, token receives its final value when it is bound.

The problem is this: in the original pair of statements, the first statement

    token = request.headers.get('Authorization')
while imperatively a valid command, is declaratively a lie. It says that token is literally the Authorization header, but it isn't. The second statement patches things up by fixing the value of token to be what it ought. It seems poor practice to deliberately put these sorts of lies in our programs. We can make the first statement true by simply renaming the variable.

Thursday, January 6, 2022

Idle puzzles 2: Revenge of the Shift

The idle puzzles got some web traffic, so here are a couple more in the same vein. Not much new, just a variation on a theme. They can be done in your head, but I spent a few minutes coding up some solutions to see what was involved.

In the previous puzzles, you were given these numeric primitives:

(import 'cl:zerop (find-package "PUZZLE"))
(defun puzzle::shr (n) (floor n 2))
(defun puzzle::shl0 (n) (* n 2))
(defun puzzle::shl1 (n) (1+ (* n 2)))
and the task was to implement basic arithmetic on non-negative integers.

These puzzles extend the task to include negatve numbers. We are given one additional primitive:

(defun puzzle::-1? (n) (= n -1))

If you want challenge yourself, you could speedrun the problems from start to finish. Or try to adapt the solutions to the prior puzzles with the minimal amount of editing and new code (minimize the diff). Another thing you could try is instrumenting shr, shl0, and shl1 to count the amount of shifting taking place and try to minimize that.

Here is the puzzle:

;;; -*- Lisp -*-

(defpackage "PUZZLE"
  (:use)
  (:import-from "COMMON-LISP"
                "AND"
                "COND"
                "DEFUN"
                "IF"
                "FUNCALL"
                "FUNCTION"
                "LAMBDA"
                "LET"
                "MULTIPLE-VALUE-BIND"
                "NIL"
                "NOT"
                "OR"
                "T"
                "VALUES"
                "ZEROP"))

(defun puzzle::shr (n) (floor n 2))
(defun puzzle::shl0 (n) (* n 2))
(defun puzzle::shl1 (n) (1+ (* n 2)))

(defun puzzle::-1? (n) (= n -1)) ;; new primitive

(in-package "PUZZLE")

;;; You can only use the symbols you can access in the PUZZLE package.

;;; Problem -1 (Example).  Fix = to handle negative numbers.

(defun = (l r)
  (cond ((zerop l) (zerop r))
        ((-1? l) (-1? r))     ;; new base case
        ((zerop r) nil)
        ((-1? r) nil)         ;; new base case
        (t (multiple-value-bind (l* l0) (shr l)
             (multiple-value-bind (r* r0) (shr r)
               (if (zerop l0)
                   (and (zerop r0)
                        (= l* r*))
                   (and (not (zerop r0))
                        (= l* r*))))))))

;;; Problem 0.  Implement minusp and plusp.

;;; Problem 1.  Fix > to handle negative numbers.

;;; Problem 2.  Fix inc and dec to handle negative numbers.

;;; Problem 3.  Implement logand, logior, and logxor.

;;; Problem 4.  Implement neg (unary minus).

;;; Problem 5.  Fix add and sub to handle negative numbers.

;;; Problem 6.  Fix mul to handle negative numbers.

;;; Problem 7.  Implement floor and ceiling for both positive and
;;;             negative numbers

My Solutions

The reason we're given a new primitive, -1?, is because the shr function has two fixed points: 0, and -1. So when we write code that recurs over a shr, the recursion is going to bottom out in one of those two base cases and we need to distinguish between them. The earlier puzzles ensured we'd bottom out at zero by specifying non-negative numbers, but if we allow negative numbers, our recursions could bottom out at -1.

;;; Problem 0.  Implement minusp and plusp

(defun minusp (n)
  (cond ((zerop n) nil)  
        ((-1? n) t)
        (t (minusp (shr n)))))

(defun plusp (n)
  (not (or (zerop n)
           (minusp n))))

We have to handle both base cases for both the arguments:

;;; Problem 1.  Fix > to handle negative numbers.

(defun > (l r)
  (cond ((zerop l) (minusp r))
        ((-1? l) (and (minusp r)
                      (not (-1? r))))
        ((or (zerop r)
             (-1? r)) (plusp l))
        (t (multiple-value-bind (l* l0) (shr l)
             (multiple-value-bind (r* r0) (shr r)
               (if (and (not (zerop l0)) (zerop r0))
                   (not (> r* l*))
                   (> l* r*)))))

This is interesting. The base case handles when one or the other argument is 0 or -1, but the recursive case doesn't know if the arguments are positive or negative. It doesn't seem to care, either. What is going on? This is the result of using floor on a negative number. The remainder is still a positive number, so when we operate on l0 and r0 we treat them as positive numbers regardless of whether l or r are positive or negative.

;;; Problem 2.  Fix inc and dec to handle negative numbers.

(defun inc (n)  
  (if (-1? n)
      0
      (multiple-value-bind (n* n0) (shr r)
         (if (zerop n0)
             (shl1 n*)
             (shl0 (inc n*))))))

(defun dec (n)  
  (if (zerop n)
      -1
      (multiple-value-bind (n* n0) (shr r)
         (if (zerop n0)
             (shl1 (dec n*))
             (shl0 n*)))))

Well that was easy, we just had to handle the zero crossing.

No doubt you've noticed that shr shifts a number to the right as if it were held in a register. If you shift the bits out of a negative number, you will notice that the bits come out as if the number were "stored" in two's complement form, with negative numbers being infinitely extended to the left with 1s. This is curious because we didn't design or choose a two's complement representation, it just sort of appears.

;;; Problem 3.  Implement logand, logior, and logxor.

(defun logand (l r)
  (cond ((zerop l) 0)
        ((-1? l) r)
        ((zerop r) 0)
        ((-1? r) l)
        (t (multiple-value-bind (l* l0) (shr l)
             (multiple-value-bind (r* r0) (shr r)
               (if (or (zerop l0) (zerop r0))
                   (shl0 (logand l* r*))
                   (shl1 (logand l* r*))))))))

(defun logior (l r)
  (cond ((zerop l) r)
        ((-1? l) -1)
        ((zerop r) l)
        ((-1? r) -1)
        (t (multiple-value-bind (l* l0) (shr l)
             (multiple-value-bind (r* r0) (shr r)
               (if (and (zerop l0) (zerop r0))
                   (shl0 (logior l* r*))
                   (shl1 (logior l* r*))))))))

(defun complement (n)
  (cond ((zerop n) -1)
        ((-1? n) 0)
        (t (multiple-value-bind (n* n0) (shr n)
             (if (zerop n0)
                 (shl1 (complement n*))
                 (shl0 (complement n*)))))))

(defun logxor (l r)
  (cond ((zerop l) r)
        ((-1? l) (complement r))
        ((zerop r) l)
        ((-1? r) (complement l))
        (t (multiple-value-bind (l* l0) (shr l)
             (multiple-value-bind (r* r0) (shr r)
               (if (or (and (zerop l0) (zerop r0))
                       (and (not (zerop l0)) (not (zerop r0))))
                   (shl0 (logxor l* r*))
                   (shl1 (logxor l* r*))))))))

;;; Problem 4.  Implement neg (unary minus).

(defun neg (n)
  (cond ((zerop n) 0)
        ((-1? n) 1)
        (t (multiple-value-bind (n* n0) (shr n)
             (if (zerop n0)
                 (shl0 (neg n*))
                 (shl1 (complement n*)))))))

This is basically (inc (complement n)), which is how you negate a two's complement number, but inc and the complement step have been folded together to reduce the amount of shifting.

;;; Problem 5.  Fix add and sub to handle negative numbers.

(defun add (l r)
  (cond ((zerop l) r)
        ((-1? l) (dec r))
        ((zerop r) l)
        ((-1? r) (dec l))
        (t (multiple-value-bind (l* l0) (shr l)
             (multiple-value-bind (r* r0) (shr r)
               (if (zerop l0)
                   (if (zerop r0)
                       (shl0 (add l* r*))
                       (shl1 (add l* r*)))
                   (if (zerop r0)
                       (shl1 (add l* r*))
                       (shl0 (addc l* r*)))))))))

(defun addc (l r)
  (cond ((zerop l) (inc r))
        ((-1? l) r)
        ((zerop r) (inc l))
        ((-1? r) l)
        (t (multiple-value-bind (l* l0) (shr l)
             (multiple-value-bind (r* r0) (shr r)
               (if (zerop l0)
                   (if (zerop r0)
                       (shl1 (add l* r*))
                       (shl0 (addc l* r*)))
                   (if (zerop r0)
                       (shl0 (addc l* r*))
                       (shl1 (addc l* r*)))))))))

(defun sub (l r) (add l (neg r)))

The great thing about two's complement is that you can handle negative numbers without changing how you handle the low order bits. For add and addc, I only had to add the two additional base cases for l or r being -1.

By the way, you shouldn't define sub this way. It's double the number of shifts.

;;; Problem 6.  Fix mul to handle negative numbers.

(defun fma (l r a)
  (cond ((zerop r) a)
        ((-1? r) (sub a l))   ;; added this line
        (t (multiple-value-bind (r* r0) (shr r)
             (fma (shl0 l) r* (if (zerop r0) a (add l a)))))))

(defun mul (l r) (fma l r 0))

Two's complement to the rescue again. The loop can treat the low-order bits of r the same way regardless of whether r is positive or negative.

;;; Problem 7.  Implement floor and ceiling for both positive and
;;;             negative numbers

(defun floor0 (n d)
  (if (> d n)
      (values 0 n)
      (multiple-value-bind (q r) (floor0 n (shl0 d))
        (if (> d r)
            (values (shl0 q) r)
            (values (shl1 q) (sub r d))))))

(defun ceil0 (n d)
  (if (not (> n d))
      (values 1 (sub n d))
      (multiple-value-bind (q r) (ceil0 n (shl0 d))
        (let ((r1 (add d r)))
          (if (plusp r1)
              (values (shl0 q) r)
              (values (dec (shl0 q)) r1))))))

(defun floor (n d)
  (if (minusp n)
      (multiple-value-bind (q r) (ceiling (neg n) d)
        (values (neg q) (neg r)))
      (if (minusp d)
          (multiple-value-bind (q r) (ceil0 n (neg d))
            (values (neg q) r))
          (floor0 n d))))

(defun ceiling (n d)
  (if (minusp n)
      (multiple-value-bind (q r) (floor (neg n) d)
        (values (neg q) (neg r)))
      (if (minusp d)
          (multiple-value-bind (q r) (floor0 n (neg d))
            (values (neg q) r))
          (ceil0 n d))))

My original method for division doesn't work too well with negative numbers. I worked around that by converting the problem to positive numbers and converting the answer back to negative numbers where appropriate. Supporting negative numbers for division is an exercise in combinatorics. All this checking for minusp and calls to neg cause a lot of shifting of numbers. There is no doubt a better way, but my brain hurts now.