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.