tag:blogger.com,1999:blog-82881949868202492162024-03-14T00:56:56.609-07:00Abstract Heresies Unorthodox opinions on computer science and programming.Joe Marshallhttp://www.blogger.com/profile/03233353484280456977noreply@blogger.comBlogger475125tag:blogger.com,1999:blog-8288194986820249216.post-26660473313662499192024-02-10T08:40:00.000-08:002024-02-10T08:40:01.632-08:00Bilinear Fractional Transformations<p>A <em>bilinear fractional transformation</em> (BiLFT) is a
two-argument function of the form<pre>(lambda (x y)
(/ (+ (* A x y) (* B x) (* C y) D)
(+ (* E x y) (* F x) (* G y) H)))</pre>
William Gosper figured out how to use BiLFTs to perform linear
fractional operations on infinite compositions of LFTs. It
isn’t as hard as it might seem.</p>
<p>BiLFTs do not form a group
under functional composition with LFTs, but they have this
interesting property: if you hold either input to the BiLFT constant,
the BiLFT becomes a LFT on the other input. So if we consider just
one of the inputs at a time (or the output), we can apply some
group-like operations.</p>
<p>You can compose LFTs with BiLFTs in three ways. First,
you can run the output of a BiLFT into the input of a LFT. Second
and third, you can run the output of a LFT into the either the x or
y input of a BiLFT. Composing a LFT with a BiLFT in any of these
ways produces another BiLFT, so there is some notion of closure
under composition. Composing the identity LFT with a BiLFT in any
of these ways does not change anything. For any composition of a
LFT with a BiLFT, you can compose the inverse of the LFT to undo the
composition.</p>
<p>BiLFTs can also form infinite compositions, but since there are two
inputs, each input can be infinite. We cannot use a Scheme stream,
but we can create a two-tailed stream-like object called a
<code>binary-expression</code>.
A <code>binary-expression</code> is a composition of two infinite
compositions. We represent a <code>binary-expression</code> as an object with
two delayed cdrs.<pre>(defclass binary-expression ()
((generation :initarg :generation
:initform 0)
(bilft :initarg :bilft
:initform (error "Required initarg :bilft was omitted."))
(delayed-left :initarg :delayed-left
:initform (error "Required initarg :delayed-left was omitted."))
(delayed-right :initarg :delayed-right
:initform (error "Required initarg :delayed-right was omitted."))))</pre></p>
<p>Like a LFT, we use <code>binary-expression</code>s by trying to
operate on the BiLFT, but forcing one of the tails and refining
the <code>binary-expression</code> when necessary.
<pre>(defun refine-left (binary-expression)
(let ((delayed-left (slot-value binary-expression 'delayed-left)))
(if (null delayed-left)
(error "Attempt to refine-left on empty stream.")
(let ((left (force delayed-left)))
(make-instance 'binary-expression
:generation (+ (slot-value binary-expression 'generation) 1)
:bilft (compose-bilft-lft-x
(slot-value binary-expression 'bilft)
(if (empty-stream? left)
(make-lft 1 1
0 0)
(stream-car left)))
:delayed-left (if (empty-stream? left)
nil
(stream-delayed-cdr left))
:delayed-right (slot-value binary-expression 'delayed-right))))))
(defun refine-right (binary-expression)
(let ((delayed-right (slot-value binary-expression 'delayed-right)))
(if (null delayed-right)
(error "Attempt to refine-right on empty stream.")
(let ((right (force delayed-right)))
(make-instance 'binary-expression
:generation (+ (slot-value binary-expression 'generation) 1)
:bilft (compose-bilft-lft-y
(slot-value binary-expression 'bilft)
(if (empty-stream? right)
(make-lft 1 1
0 0)
(stream-car right)))
:delayed-left (slot-value binary-expression 'delayed-left)
:delayed-right (if (empty-stream? right)
nil
(stream-delayed-cdr right)))))))</pre>
<p><code>refine-fairly</code> alternates forcing the delayed-left or
delayed-right tail while <code>refine-disjoint</code> looks at the
overlap in the ranges of the BiLFT.</p><pre>
(defun refine-fairly (binary-expression)
(if (zerop (mod (slot-value binary-expression 'generation) 2))
(if (null (slot-value binary-expression 'delayed-left))
(refine-right binary-expression)
(refine-left binary-expression))
(if (null (slot-value binary-expression 'delayed-right))
(refine-left binary-expression)
(refine-right binary-expression))))
(defun refine-disjoint (binary-expression)
(if (bilft-disjoint? (slot-value binary-expression 'bilft))
(refine-right binary-expression)
(refine-left binary-expression)))</pre>
<p>You can do arithmetic on infinite compositions by using the
appropriate BiLFT:<pre>
(defparameter bilft-add
(make-bilft 0 1 1 0
0 0 0 1))
(defparameter bilft-subtract
(make-bilft 0 1 -1 0
0 0 0 1))
(defparameter bilft-multiply
(make-bilft 1 0 0 0
0 0 0 1))
(defparameter bilft-divide
(make-bilft 0 1 0 0
0 0 1 0))</pre>
<h2>Converting a <code>binary-expression</code> to a LFT stream</h2>
<p><code>binary-expression</code>s can be operated on in an analagous
way to an infinite composition of LFTs, but in order to nest binary
expressions, we need to be able to turn one into an
infinite composition of LFTs so it can become the left or right
input of the other. The way to do this is to generate a stream of
LFTs and their inverses. The inverses are composed into the output
of the <code>binary-expression</code> while the LFTs are composed
downstream into one of the inputs of the next <code>binary-expression</code>.</p>
<p>The math works such that we can select any LFT that has an inverse,
but we want our <code>binary-expression</code> to represent a
narrowing transformation, so we try composing a few different LFTs
and their inverses and see if we still have a narrowing
transformation. If we find one, we proceed with the computation,
but if we cannot find a LFT and its inverse that preserves the
narrowing, we refine the <code>binary-expression</code> by forcing
one of the two delayed inputs and composing it.</p>
<pre>(defun decompose (left composed)
(values left (funcall (inverse-lft left) composed)))
(defun decompose-range? (left composed if-success if-failure)
(multiple-value-bind (left right) (decompose left composed)
(if (range? right) ;; does it still narrow?
(funcall if-success left right)
(funcall if-failure))))
(defun try-decompose-digit (lft if-success if-failure)
(decompose-range?
(make-lft 2 1 0 1) lft
if-success
(lambda ()
(decompose-range?
(make-lft 1 0 1 2) lft
if-success
(lambda ()
(decompose-range?
(make-lft 3 1 1 3) lft
if-success
if-failure))))))
(defun binary-expression-decompose-digit (binary-expression)
(try-decompose-digit
(slot-value binary-expression 'bilft)
(lambda (digit bilft)
(values digit (make-instance 'binary-expression
:generation (slot-value binary-expression 'generation)
:bilft bilft
:delayed-left (slot-value binary-expression 'delayed-left)
:delayed-right (slot-value binary-expression 'delayed-right))))
(lambda ()
(binary-expression-decompose-digit (refine-disjoint binary-expression)))))
(defun binary-expression->lft-stream (binary-expression)
(multiple-value-bind (digit remainder) (binary-expression-decompose-digit binary-expression)
(cons-lft-stream digit
(binary-expression->lft-stream remainder))))</pre></p>
<p>Now we have the machinery we need to do arithmetic on pairs of LFT streams.</p>
<h2>Infinite Expression Trees</h2>
<p>You can only go so far with a finite number of arithmetic
operations, but you can go much further with an infinite number.
For example, you can create converging infinite series. We can
recursively generate an infinite tree of binary expressions. We
unfold the tree and call a generating function at each recursive level.<pre>(defun unfold-expression-tree-1 (left generate counter)
(funcall (funcall generate counter)
left
(delay-lft-stream (unfold-expression-tree-1 left generate (+ counter 1)))))</pre>
Often the root of the tree is special, so the usual way we call this is<pre>(defun unfold-expression-tree (root-bilft left generate)
(funcall root-bilft
left
(delay-lft-stream (unfold-expression-tree-1 left generate 1))))</pre></p>
<h2>Square Root of Infinite Composition</h2>
<p>To compute the square root of an infinite composition, we create an
infinite tree. Each level of the tree refines the estimate of the
square root of the estimate from the next level down in the tree.<pre>(defun sqrt-lft-stream (lft-stream)
(unfold-expression-tree-1
lft-stream
(constantly (make-bilft 1 2 1 0
0 1 2 1))
0))</pre>but we need not construct an infinite tree if each level
is identical. We just re-use the level:<pre>(defun sqrt-lft-stream (lft-stream)
(let ((stream nil))
(setq stream
(funcall (make-bilft 1 2 1 0
0 1 2 1)
lft-stream
(delay-lft-stream stream)))
stream))</pre>This feeds back the square root into its own
computation. (These ideas are from Peter Potts and Reinhold Heckmann.)</p>
<h2>e<sup>x</sup> and log(x)</h2>
<p>Peter Potts gives these formulas for e<sup>x</sup> and log(x) where
x is an infinite composition of LFTs:<pre>(defun %exp-lft-stream (lft-stream)
(unfold-expression-tree-1
(lambda (n)
(make-bilft (+ (* 2 n) 2) (+ (* 2 n) 1) (* 2 n) (+ (* 2 n) 1)
(+ (* 2 n) 1) (* 2 n) (+ (* 2 n) 1) (+ (* 2 n) 2)))
0
(funcall (inverse-lft (make-lft 1 -1 1 1)) lft-stream)))
(defun %log-lft-stream (lft-stream)
(unfold-expression-tree
(make-bilft 1 1 -1 -1
0 1 1 0)
(lambda (n)
(make-bilft n (+ (* n 2) 1) (+ n 1) 0
0 (+ n 1) (+ (* n 2) 1) n))
lft-stream))</pre>These infinite expression trees converge only on a
limited range, so we need to use identities on the arguments and
results to extend the range to cover a wide set of inputs.</p>
Joe Marshallhttp://www.blogger.com/profile/03233353484280456977noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-10773318704146629222024-02-04T09:37:00.000-08:002024-02-04T09:37:33.435-08:00Infinite Composition<p>If you like functional composition, you’ll like linear
fractional transformations (LFTs). They behave very nicely when you
compose them (in fact, they are a group under functional
composition). If you compose two LFTs, you get another LFT. You
can keep composing as long as you wish. Let’s compose an
infinite number of LFTs.</p>
<p>I suppose I should argue that composing an infinite number of LFTs
will give you anything at all. Consider those LFTs with
non-negative coefficients. When given an input in the range [0,∞],
they will output a number in the range [A/C, B/D]. The output range
is narrower than, and contained within, the input range. If we compose two such LFTs, the
range of output of the outermost LFT will be even narrower. As we
compose more and more of these narrowing LFTs, the range of output
of the outermost LFT will become narrower and narrower. If we
compose an infinite number of narrowing LFTs, the output range will
narrow to a single point. Curiously, the limits on the range of output of a finite
composition of LFTs are always rational numbers, yet the output from
infinite composition of LFTs can be an irrational real number.</p>
<p>There are many ways to represent an infinite number of LFTs. A
generator or a co-routine, for example, but I like the stream
abstraction from Scheme. This is easily implemented in Common Lisp.
A <code>delay</code> macro creates promises:<pre>(defclass promise ()
((forced? :initform nil)
(values-or-thunk :initarg :thunk
:initform (error "Required initarg :thunk omitted.")))
(:documentation "A simple call-by-need thunk."))
(defmacro delay (expression)
“Delays evaluation of an expression and returns a promise.”
‘(make-instance ’promise :thunk (lambda () ,expression)))</pre>
and the <code>force</code> function forces evaluation:<pre>(defun force (promise)
“Returns the values of a promise, forcing it if necessary.”
(check-type promise promise)
;; Ensure the values have been memoized.
(unless (slot-value promise ’forced?)
(let ((values (multiple-value-list (funcall (slot-value promise ’values-or-thunk)))))
;; If this is not a recursive call, memoize the result.
;; If this is a recursive call, the result is discarded.
(unless (slot-value promise ’forced?)
(setf (slot-value promise ’values-or-thunk) values)
(setf (slot-value promise ’forced?) t))))
;; Return the memoized values.
(values-list (slot-value promise ’values-or-thunk)))</pre>
A stream is a cons of an element and a promise to produce the rest of
the stream:<pre>(defclass lft-stream ()
((car :initarg :car
:initform (error "Required initarg :car omitted.")
:reader stream-car)
(delayed-cdr :initarg :delayed-cdr
:initform (error "Required initarg :delayed-cdr omitted.")
:reader stream-delayed-cdr)))
(defmacro cons-lft-stream (car cdr)
‘(make-instance ’stream :car ,car :delayed-cdr (delay ,cdr)))
(defun stream-cdr (stream)
(force (stream-delayed-cdr stream)))</pre></p>
<p>A stream of LFTs will represent an infinite composition. The first
LFT is the outermost LFT in the composition. To incrementally
compose the LFTs, we force the delayed cdr of the stream to get the
second LFT. We compose the first LFT and the second LFT to get a
new stream car, and the cdr of the delayed cdr is the new stream
cdr. That is, we start with the stream <code>{F …}</code>, we force the
tail, getting <code>{F G …}</code>, then we compose the first
and second elements, getting <code>{(F∘G) …}</code>.<pre>(defun refine-lft-stream (lft-stream)
(let ((tail (stream-cdr lft-stream))) ;; forces cdr
(make-instance ’stream
:car (compose (stream-car lft-stream) (stream-car tail))
:delayed-cdr (stream-delayed-cdr tail))))</pre>
so we can now write code that operates on what we have composed so far
(in the car of the LFT stream), or, if we need to incrementally
compose more LFTs, we repeatedly call <code>refine-lft-stream</code> until we
have composed enough.</p>
<p>For example, we can compute the nearest float to an infinite
composition as follows:<pre>(defun nearest-single (lft-stream)
(let ((f0 (funcall (stream-car lft-stream) 0))
(finf (funcall (stream-car lft-stream) ’infinity)))
(if (and (numberp f0)
(numberp finf)
(= (coerce f0 ’single-float)
(coerce finf ’single-float)))
(coerce f0 ’single-float)
(nearest-single (refine-lft-stream lft-stream)))))</pre></p>
<p>The problem with infinite compositions is that they may never
narrow enough to proceed with a computation. For example, suppose
an infinite composition converged to a number exactly in between two
adjacent floating point numbers. The upper limit of the narrowing range will
always round to the float that is above, while the lower limit will
always round to the float that is below. The floats will never be
equal no matter how many terms of the infinite composition are
composed, so functions like <code>nearest-single</code> will never
return a value. This is a tradeoff. We either continue computing,
perhaps forever, with more and more precise values, or we stop at
some point, perhaps giving an incorrect answer.</p>
<h2>Operating on Infinite Compositions</h2>
<p>You can compose a LFT with an infinite composition of LFTs. If we
compose the LFT <code>F</code> with the infinite composition <code>{G H …}</code>, we
can represent this one of two ways. Either we just tack the <code>F</code> on to the
front, getting <code>{F G H …}</code>, or we continue
further and eagerly compose the first two elements
<code>{(F∘G) H …}</code>. If <code>F</code> is, for example, a LFT that
adds 10 or multiplies by 7, the effect is to add 10 to or multiply by 7
the infinite composition. In this way, we can do arithmetic
involving rational numbers and infinite compositions.</p>
<h2>Sources of Infinite Compositions</h2>
<p>It isn’t likely that you have a lot of <i>ad hoc</i> LFT
streams you want to compose. Instead, we want some sources of
infinite compositions. There are a few useful functions of finite
arguments that return infinite compositions. I got these from
Peter Potts's thesis. While most of these have limited ranges of
arguments, you can use identity operations to divide down the input
to an acceptable range and multiply up the output to the correct
answer.</p>
<h3>√(p/q)</h3>
<p>Reinhold Heckmann came up with this one:</p>
<pre>(defun %sqrt-rat (p q)
(let ((diff (- p q)))
(labels ((rollover (num den)
(let ((d (+ (* 2 (- den num)) diff)))
(if (> d 0)
(cons-lft-stream (make-lft 1 0 1 2) (rollover (* num 4) d))
(cons-lft-stream (make-lft 2 1 0 1) (rollover (- d) (* den 4)))))))
(rollover p q))))</pre>
<p>The LFTs that this returns are curious in that when you compose
them with a range, they divide the range in two and select one or
other (high or low) segment. The outermost LFT in the infinite
composition will represent a range that contains the square root,
and the subsequent LFTs will narrow it down by repeatedly
bifurcating it and selecting the top or bottom segment.</p>
<h3>e<sup>x</sup>, where x is rational and 1/2 < x ≤ 2</h3>
<pre>(defun %exp-rat (x)
(check-type x (rational (1/2) 2))
(cons-lft-stream
(make-lft (+ 2 x) x
(- 2 x) x)
(lft-stream-map (lambda (n)
(make-lft (+ (* 4 n) 2) x
x 0))
(naturals))))</pre>
<h3>log(x), where x is rational and x > 1</h3>
<pre>(defun %log-rat (x)
(check-type x (rational (1) *))
(lft-stream-map
(lambda (n)
(funcall (make-lft 0 (- x 1)
(- x 1) (+ (* n 2) 1))
(make-lft 0 (+ n 1)
(+ n 1) 2)))
(integers)))</pre>
<h3>x<sup>y</sup>, where x and y are rational and x > 1 and 0 < y < 1</h3>
<pre>(defun %rat-pow (x y)
(check-type x (rational (1) *))
(check-type y (rational (0) (1)))
(cons-lft-stream
(make-lft y 1
0 1)
(lft-stream-map
(lambda (n)
(funcall (make-lft 0 (- x 1)
(- x 1) (- (* n 2) 1))
(make-lft 0 (- n y)
(+ n y) 2)))
(naturals))))</pre>
<h3>tan(x), where x is rational and 0 < x ≤ 1</h3>
<pre>(defun %rat-tan (x)
(check-type x (rational (0) 1))
(lft-stream-map
(lambda (n)
(funcall (make-lft 0 x
x (+ (* n 4) 1))
(make-lft 0 x
x (- (* n -4) 3))))
(integers)))</pre>
<h3>tan<sup>-1</sup>(x), where x is rational and 0 < x ≤ 1</h3>
<pre>(defun big-k-stream (numerators denominators)
(cons-lft-stream (make-lft 0 (stream-car numerators)
1 (stream-car denominators))
(big-k-stream (stream-cdr numerators) (stream-cdr denominators))))
(defun %rat-atan (z)
(check-type z (rational (0) 1))
(let ((z-squared (square z)))
(cons-lft-stream (make-lft 0 z
1 1)
(big-k-stream (stream-map (lambda (square)
(* z-squared square))
(squares))
(stream-cdr (odds))))))</pre>
<p>These functions have limited applicability. In my next couple of
posts, I’ll show some functions that transform LFT streams
into other LFT streams, which can be used to increase the range of
inputs and outputs of these primitive sources.</p>
Joe Marshallhttp://www.blogger.com/profile/03233353484280456977noreply@blogger.com1tag:blogger.com,1999:blog-8288194986820249216.post-29141434519509638052024-01-28T12:00:00.000-08:002024-01-28T12:00:44.550-08:00Exponentiating Functions<p>If we compose a function F(x) with itself, we get F(F(x)) or F∘F.
If we compose it again, we get F(F(F(x))) or F∘F∘F. Rather than
writing ‘F’ over and over again, we can abuse
exponential notation and write (F∘F∘F) as F<sup>3</sup>, where the
superscript indicates how many times we compose the function.
F<sup>1</sup> is, naturally, just F. F<sup>0</sup> would be zero
applications of F, which would be the function that leaves its
argument unchanged, <i>i.e.</i> the identity function.</p>
<p>The analogy with exponentiation goes deeper. We can quickly
exponentiate a number with a divide and conquer
algorithm:<pre>(defun my-expt (base exponent)
(cond ((zerop exponent) 1)
((evenp exponent) (my-expt (* base base) (/ exponent 2)))
(t (* base (my-expt base (- exponent 1))))))</pre>
The analagous algorithm will exponentiate a function:<pre>(defun fexpt (f exponent)
(cond ((zerop exponent) #'identity)
((evenp exponent) (fexpt (compose f f) (/ exponent 2)))
(t (compose f (fexpt f (- exponent 1))))))</pre></p>
<p>The function <code>(lambda (x) (+ 1 (/ 1 x)))</code> takes the
reciprocal of its input and adds one to it. What happens if you
compose it with itself? We can rewrite it as a linear fractional
transformation
(LFT) <code>(make-lft 1 1 1 0)</code> and try it
out:<pre>> (make-lft 1 1 1 0)
#<LFT 1 + 1/x>
> (compose * (make-lft 1 1 1 0))
#<LFT (2x + 1)/(x + 1)>
> (compose * (make-lft 1 1 1 0))
#<LFT (3x + 2)/(2x + 1)>
> (compose * (make-lft 1 1 1 0))
#<LFT (5x + 3)/(3x + 2)>
> (compose * (make-lft 1 1 1 0))
#<LFT (8x + 5)/(5x + 3)>
> (compose * (make-lft 1 1 1 0))
#<LFT (13x + 8)/(8x + 5)>
> (compose * (make-lft 1 1 1 0))
#<LFT (21x + 13)/(13x + 8)></pre>
Notice how the coefficients are Fibonacci numbers.</p>
<p>We can compute Fibonacci numbers efficiently by exponentiating the
LFT <code>1 + 1/x</code>.<pre>> (fexpt (make-lft 1 1 1 0) 10)
#<LFT (89x + 55)/(55x + 34)>
> (fexpt (make-lft 1 1 1 0) 32)
#<LFT (3524578x + 2178309)/(2178309x + 1346269)></pre>
Since we’re using a divide and conquer algorithm, raising to the
32<sup>nd</sup> power involves only five matrix multiplies.</p>
<h2>Fixed points</h2>
If an input <code>x</code> maps to itself under
function <code>f</code>, we say that <code>x</code> is a fixed point
of <code>f</code>. So suppose we have a function <code>f</code> with
a fixed point <code>x</code>. We consider the function <code>f’</code> which
ignores its argument and outputs <code>x</code>.
If we compose <code>f</code> with <code>f’</code>, it
won’t make difference that we run the result
through <code>f</code> again, so <code>f’ = f∘f’ = f<sup>∞</sup></code>.
You can find a fixed point of a function by
composing the function with its fixed point. Unfortunately, that only
works in a lazy language, so you have two options: either choose a
finite number of compositions up front, or compose on demand.</p>
<p>You can approximate the fixed point of a function by exponentiating
the function to a large number.<pre>(defun approx-fixed-point (f)
(funcall (fexpt f 100) 1))
> (float (approx-fixed-point (make-lft 1 1 1 0)))
1.618034
> (float (funcall (make-lft 1 1 1 0) *))
1.618034</pre></p>
<p>Alternatively, we could incrementally compose <code>f</code> with
itself as needed. To tell if we are done, we need to determine if
we have reached a function that ignores its input and outputs the
fixed point. If the function is a LFT, we need only check that the
limits of the LFT are equal (up to the desired precision).<pre>(defun fixed-point (lft)
(let ((f0 (funcall lft 0))
(finf (funcall lft ’infinity)))
(if (and (numberp f0)
(numberp finf)
(= (coerce f0 ’single-float)
(coerce finf ’single-float)))
(coerce f0 ’single-float)
(fixed-point (compose lft lft)))))
> (fixed-point (make-lft 1 1 1 0))
1.618034
</pre>
Joe Marshallhttp://www.blogger.com/profile/03233353484280456977noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-2891750658796807702024-01-25T12:02:00.000-08:002024-01-25T12:02:05.377-08:00Roll Your Own Linear Fractional Transformations<p>Looking for a fun weekend project? Allow me to suggest <i>linear fractional transformations</i>.</p>
<p>A linear fractional transformation (LFT), also known as a Möbius
transformation or a homographic function, is a function of
the form<pre>(lambda (x)
(/ (+ (* A x) B)
(+ (* C x) D)))</pre>
You could just close over the coefficients,<pre>(defun make-lft (A B C D)
(lambda (x)
(/ (+ (* A x) B)
(+ (* C x) D))))</pre>but you’ll want access to <code>A</code>,
<code>B</code>, <code>C</code>, and <code>D</code>. If you implement LFTs
as funcallable CLOS instances, you can read out the coefficients from slot values.</p>
<h2>Constructor</h2>
<p>The coefficients <code>A</code>, <code>B</code>, <code>C</code>,
and <code>D</code> could in theory be any complex number, but we can
restrict them to being integers and retain a lot of the functionality.
If we multiply all the coefficients by the same factor, it doesn't
change the output of the LFT. If you have a rational coefficient
instead of an integer, you can multiply all the coefficients
by the denominator of the rational. If there is a common divisor
among the coefficients, you can divide it out to reduce to lowest
form. (In practice, the common divisor will likely be 2 if anything,
so if the coefficients are all even, divide them all by 2.) We can
also canonicalize the sign of the coefficients by multiplying all
the coefficients by -1 if necessary.</p>
<pre>(defun canonicalize-lft-coefficients (a b
c d receiver)
(cond ((or (minusp c)
(and (zerop c)
(minusp d)))
;; canonicalize sign
(canonicalize-lft-coefficients (- a) (- b)
(- c) (- d) receiver))
((and (evenp a)
(evenp b)
(evenp c)
(evenp d))
;; reduce if possible
(canonicalize-lft-coefficients (/ a 2) (/ b 2)
(/ c 2) (/ d 2) receiver))
(t (funcall receiver
a b
c d))))
(defun %make-lft (a b c d)
;; Constructor used when we know A, B, C, and D are integers.
(canonicalize-lft-coefficients
a b
c d
(lambda (a* b*
c* d*)
(make-instance 'lft
:a a* :b b*
:c c* :d d*))))
(defun make-lft (a b c d)
(etypecase a
(float (make-lft (rational a) b c d))
(integer
(etypecase b
(float (make-lft a (rational b) c d))
(integer
(etypecase c
(float (make-lft a b (rational c) d))
(integer
(etypecase d
(float (make-lft a b c (rational d)))
(integer (%make-lft a b
c d))
(rational (make-lft (* a (denominator d)) (* b (denominator d))
(* c (denominator d)) (numerator d)))))
(rational (make-lft (* a (denominator c)) (* b (denominator c))
(numerator c) (* d (denominator c))))))
(rational (make-lft (* a (denominator b)) (numerator b)
(* c (denominator b)) (* d (denominator b))))))
(rational (make-lft (numerator a) (* b (denominator a))
(* c (denominator a)) (* d (denominator a))))))</pre>
<h2>Printer</h2>
<p>One advantage of making LFTs be funcallable CLOS objects is that
you can define a <code>print-object</code> method on them. For my
LFTs, I defined <code>print-object</code> to print the LFT in
algabraic form. This will take a couple of hours to write because
of all the edge cases, but it enhances the use of LFTs.</p>
<pre>> (make-lft 3 2 4 -3)
#<LFT (3x + 2)/(4x - 3)></pre>
<p>Cases where some of the coefficients are 1 or 0.</p>
<pre>> (make-lft 1 0 3 -2)
#<LFT x/(3x - 2)>
> (make-lft 2 7 0 1)
#<LFT 2x + 7>
> (make-lft 3 1 1 0)
#<LFT 3 + 1/x></pre>
<h2>Application</h2>
<p>The most mundane way to use a LFT is to apply it to a number.<pre>> (defvar *my-lft* (make-lft 3 2 4 3))
*MY-LFT*
> (funcall *my-lft* 1/5)
13/19</pre></p>
<h2>Dividing by zero</h2>
<p>In general, LFTs approach the limit <code>A/C</code> as the
input <code>x</code> grows without bound. We can make our
funcallable CLOS instance behave this way when called on the special
symbol <code>’infinity</code>.<pre>> (funcall *my-lft* ’infinity)
3/4</pre></p>
<p>In general, LFTs have a pole when the value
of <code>x</code> is <code>-D/C</code>, which makes the denominator
of the LFT zero. Rather than throwing an error, we’ll make
the LFT return <code>’infinity</code><pre>> (funcall *my-lft* -3/4))
INFINITY</pre></p>
<h2>Inverse LFTs</h2>
<p>Another advantage of using a funcallable CLOS instance is that we
can find the inverse of a LFT. You can compute the inverse of a LFT
by swapping <code>A</code> and <code>D</code> and toggling the signs
of <code>B</code> and <code>C</code>.<pre>(defun inverse-lft (lft)
(make-lft (slot-value lft ’d)
(- (slot-value lft ’b))
(- (slot-value lft ’c))
(slot-value lft ’a)))</pre></p>
<h2>Composing LFTs</h2>
<p>LFTs are closed under functional composition — if you pipe
the output of one LFT into the input of another, the composite
function is equivalent to another LFT. The coefficients of the
composite LFT are the matrix multiply of the coefficients of the
separate terms.<pre>> (compose (make-lft 2 3 5 7) (make-lft 11 13 17 19))
#<LFT (73x + 83)/(174x + 198)></pre></p>
<h2>Using LFTs as linear functions</h2>
<p>A LFT can obviously be used as the simple linear function it is.
For instance, the “multiply by 3” function
is <code>(make-lft 3 0 0 1)</code> and the
“subtract 7” function
is <code>(make-lft 1 -7 0 1)</code>. <code>(make-lft 0 1 1 0)</code>
takes the reciprocal of its argument, and
<code>(make-lft 1 0 0 1)</code> is just the identity function.</p>
<h2>Using LFTs as ranges</h2>
<p>LFTs are monotonic except for the pole. If the pole of the LFT is
non-positive, and the input is non-negative, then the output of the
LFT is somewhere in the range <code>[A/C, B/D]</code>. We can use
those LFTs with a non-positive pole to represent ranges of rational
numbers. The limits of the range are the LFT evaluated at zero
and <code>’infinity</code>.</p>
<p>We can apply simple linear functions to ranges by composing the LFT
that represents the linear function with the LFT that represents the
range. The output will be a LFT that represents the modified
range. For example, the
LFT <code>(make-lft 3 2 4 3)</code> represents
the range <code>[2/3, 3/4]</code>. We add 7 to this range by
composing the
LFT <code>(make-lft 1 7 0 1)</code>. <pre>> (compose (make-lft 1 7 0 1) (make-lft 3 2 4 3))
#<LFT (31x + 23)/(4x + 3)></pre></p>
<h2>Application (redux)</h2>
<p>It makes sense to define what it means to funcall a LFT on another
LFT as being the composition of the LFTs.<pre>> (defvar *add-seven* (make-lft 1 7 0 1))
*ADD-SEVEN*
> (funcall *add-seven* 4)
11
> (funcall *add-seven* (make-lft 4 13 1 2))
#<LFT (11x + 27)/(x + 2)>
> (funcall * ’infinity)
11</pre></p>
<h2>Conclusion</h2>
<p>This should be enough information for you to implement LFTs in a
couple of hours. If you don’t want
to implement them yourself, just crib my code from <a href="https://github.com/jrm-code-project/homographic/blob/main/lisp/lft.lisp">https://github.com/jrm-code-project/homographic/blob/main/lisp/lft.lisp</a></p>
Joe Marshallhttp://www.blogger.com/profile/03233353484280456977noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-31281849535355186442023-11-24T07:50:00.000-08:002023-11-24T07:50:07.195-08:00GitHub Co-pilot Review<p>I recently tried out GitHub CoPilot. It is a system that uses
generative AI to help you write code.</p>
<p>The tool interfaces to your IDE — I used VSCode — and
acts as an autocomplete on steroids … or acid. Suggested
comments and code appear as you move the cursor and you can often choose from
a couple of different completions. The way to get it to write code was to
simply document what you wanted it to write in a comment. (There is
a chat interface where you can give it more directions, but I did
not play with that.)</p>
<p>I decided to give it my standard interview question: write a simple
TicTacToe class, include a method to detect a winner. The tool spit
out a method that checked an array for three in a row horizontally,
vertically, and along the two diagonals. Almost correct. While it
would detect three ‘X’s or ‘O’s, it also would detect three nulls in
a row and declare null the winner.</p>
<p>I went into the class definition and simply typed a comment
character. It suggested an <code>__init__</code> method. It
decided on a board representation of a 1-dimensional array of 9
characters, ‘X’ or ‘O’ (or null), and a character that determined
whose turn it was. Simply by moving the cursor down I was able to
get it to suggest methods to return the board array, return the
current turn, list the valid moves, and make a move. The suggested
code was straightforward and didn’t have bugs.</p>
<p>I then decided to try it out on something more realistic. I have a
linear fractional transform library I wrote in Common Lisp and I
tried porting it to Python. Co-pilot made numerous suggestions as I
was porting, to various degrees of success. It was able to complete
the equations for a 2x2 matrix multiply, but it got hopelessly
confused on higher order matrices. For the print method of a linear
fractional transform, it produced many lines of plausible looking
code. Unfortunately, the code has to be better than
“plausible looking” in order to run.</p>
<p>As a completion tool, co-pilot muddled its way along.
Occasionally, it would get a completion impressively right, but just
as frequently — or more often — it would get the
completion wrong, either grossly or subtly. It is the latter
that made me nervous. Co-pilot would produce code that looked
plausible, but it required a careful reading to determine if it was
correct. It would be all too easy to be careless and accept buggy
code.</p>
<p>The code Co-Pilot produced was serviceable and pedestrian, but
often not what I would have written. I consider myself a
“mostly functional” programmer. I use mutation
sparingly, and prefer to code by specifying mappings and
transformations rather than sequential steps. Co-pilot, drawing
from a large amount of code written by a variety of authors, seems
to prefer to program sequentially and imperatively. This isn’t
surprising, but it isn’t helpful, either.</p>
<p>Co-pilot is not going to put any programmers out of work. It
simply isn’t anywhere near good enough. It doesn’t understand what
you are attempting to accomplish with your program, it just pattern
matches against other code. A fair amount of code is full of
patterns and the pattern matching does a fair job. But exceptions
are the norm, and Co-pilot won’t handle edge cases unless the edge
case is extremely common.</p>
<p>I found myself accepting Co-pilot’s suggestions on occasion. Often
I’d accept an obviously wrong suggestion because it was close enough
and the editing seemed less. But I always had to guard against code
that seemed plausible but was not correct. I found that I spent a
lot of time reading and considering the code suggestions. Any time
savings from generating these suggestions was used up in vetting the
suggestions.</p>
<p>One danger of Co-pilot is using it as a coding standard. It
produces “lowest common denominator” code — code
that an undergraduate that hadn’t completed the course might
produce. For those of us that think the current standard of coding
is woefully inadequate, Co-pilot just reinforces this style of
coding.</p>
<p>Co-pilot is kind of fun to use, but I don’t think it helps me be
more productive. It is a bit quicker than looking things up on
stackoverflow, but its results have less context. You wouldn’t go
to stackoverflow and just copy code blindly. Co-pilot isn’t quite
that — it will at least rename the variables — but it
produces code that is more likely buggy than not.</p>
Joe Marshallhttp://www.blogger.com/profile/03233353484280456977noreply@blogger.com2tag:blogger.com,1999:blog-8288194986820249216.post-88267173551864839862023-10-13T02:17:00.001-07:002023-10-13T02:17:44.390-07:00Syntax-rules Primer<p>I recently had an inquiry about the copyright status of my <i>JRM’s Syntax Rules Primer for the Merely Eccentric</i>.
I don’t want to put it into public domain as that would allow anyone to rewrite it at will and leave that title. Instead, I'd like to release it on an MIT style license: feel free to copy it and distribute it, correct any errors, but please retain the general gist of the article and the title and the authorship.Joe Marshallhttp://www.blogger.com/profile/03233353484280456977noreply@blogger.com2tag:blogger.com,1999:blog-8288194986820249216.post-74617668114672122822023-09-27T09:31:00.000-07:002023-09-27T09:31:16.754-07:00<p>Greenspun's tenth rule of programming states
<blockquote>Any sufficiently complicated C or Fortran program
contains an ad hoc, informally-specified, bug ridden, slow
implementation of half of Common Lisp.</blockquote>
Observe that the Python interpreter is written in C.</p>
<p>In fact, most popular computer languages can be thought of as a
poorly implemented Common Lisp. There is a reason for this.
Church's lambda calculus is a great foundation for reasoning about
programming language semantics. Lisp can be seen as a realization of a
lambda calculus interpreter. By reasoning about a language's
semantics in Lisp, we're essentially reasoning about the semantics
in a variation of lambda calculus.</p>
Joe Marshallhttp://www.blogger.com/profile/03233353484280456977noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-334029260462332772023-08-05T11:46:00.000-07:002023-08-05T11:46:07.689-07:00Off-sides Penalty<p>Many years ago I was under the delusion that if Lisp were more
“normal looking” it would be adopted more readily. I
thought that maybe inferring the block structure from the
indentation (the “off-sides rule”) would make Lisp
easier to read. It does, sort of. It seems to make smaller
functions easier to read, but it seems to make it harder to read
large functions — it's too easy to forget how far you are
indented if there is a lot of vertical distance.</p>
<p> I was
feeling pretty good about this idea until I tried to write a macro.
A macro’s implementation function has block structure, but so does
the macro’s replacement text. It becomes ambiguous whether the
indentation is indicating block boundaries in the macro body or in
it’s expansion.</p>
<p>A decent macro needs a templating system. Lisp has backquote (aka
quasiquote). But notice that unquoting comes in both a splicing and
non-splicing form. A macro that used the off-sides rule would need
templating that also had indenting and non-indenting unquoting
forms. Trying to figure out the right combination of unquoting
would be a nightmare.</p>
<p>The off-sides rule doesn’t work for macros that have non-standard
indentation. Consider if you wanted to write a macro similar
to <code>unwind-protect</code> or <code>try…finally</code>.
Or if you want to have a macro that expands into just
the <code>finally</code> clause.</p>
<p>It became clear to me that there were going to be no simple rules.
It would be hard to design, hard to understand, and hard to use.
Even if you find parenthesis annoying, they are relatively simple to
understand and simple to use, even in complicated situations. This
isn’t to say that you couldn’t cobble together a macro
system that used the off-sides rule, it would just be much more
complicated and klunkier than Lisp’s.</p>
Joe Marshallhttp://www.blogger.com/profile/03233353484280456977noreply@blogger.com6tag:blogger.com,1999:blog-8288194986820249216.post-49589187753045856402023-07-26T11:13:00.001-07:002023-07-26T11:13:45.908-07:00The Garden Path<p>Follow me along this garden path (based on true events).</p>
<p>We have a nifty program and we want it to be flexible, so it has a
config file. We make up some sort of syntax that indicates
key/value pairs. Maybe we’re hipsters and use YAML. Life is good.</p>
<p>But we find that we to configure something dynamically, say based
on the value of an environment variable. So we add some escape
syntax to the config file to indicate that a value is a variable
rather than a literal. But sometimes the string needs a little work
done to it, so we add some string manipulation features to the
escape syntax.</p>
<p>And when we deploy the program, we find that we’ve want to
conditionalize part of the configuration based on the deployment, so
we add a conditional syntax to our config language. But
conditionals are predicated on boolean values, so we add booleans to
our config syntax. Or maybe we make strings do double duty. Of
course we need the basic boolean operators, too.</p>
<p>But there’s a lot of duplication across our configurations, so we
add the ability to indirectly refer to other config files. That
helps to some extent, but there’s a lot of stuff that is almost
duplicated, except for a little variation. So we add a way to make
a configuration template. Templating needs variables and quoting,
so we invent a syntax for those as well.</p>
<p>We’re building a computer language by accident, and without a clear
plan it is going to go poorly. Are there data types (aside from
strings)? Is there a coherent type system? Are the variables
lexically scoped? Is it call-by-name or call-by-value? Is it
recursive? Does it have first class (or even second class)
procedures? Did we get nested escaping right? How about quoted
nested escaping? And good grief our config language is in YAML!</p>
<p>If we had some forethought, we would have realized that we were
designing a language and we would have put the effort into making it
a good one. If we’re lazy, we’d just pick an existing good
language. Like Lisp.</p>
Joe Marshallhttp://www.blogger.com/profile/03233353484280456977noreply@blogger.com3tag:blogger.com,1999:blog-8288194986820249216.post-38077908682275259202023-07-08T10:21:00.000-07:002023-07-08T10:21:19.578-07:00Playing with AI<p>Write a polemic about how omitting conditional expressions from a
language is lazy and stupid.</p>
<blockquote>Conditional expressions are a fundamental feature of any
programming language that claims to be expressive, concise and
elegant. They allow programmers to write complex logic in a single
line, without the need for verbose and repetitive if-else
statements. They also enable functional programming paradigms, such
as pattern matching and recursion, that are essential for solving
many problems efficiently and elegantly.</blockquote>
<blockquote>Omitting conditional expressions from a language is a sign
of laziness and stupidity on the part of the language designers. It
shows that they do not care about the needs and preferences of their
users, who have to write more code, introduce more bugs, and suffer
more frustration. It also shows that they do not understand the
principles and benefits of functional programming, which have been
proven by decades of research and practice. They are stuck in an
imperative mindset, where everything has to be done with side
effects and mutations.</blockquote>
<blockquote>A language without conditional expressions is a crippled
language, that forces programmers to use hacks and workarounds to
achieve what should be simple and natural. It is a language that
discourages creativity, elegance and readability. It is a language
that should be avoided by anyone who values their time, sanity and
reputation.</blockquote>
<blockquote>Some examples of programming languages that don’t have conditional expressions are:
<ul><li>CoffeeScript</li>
<li>Go</li>
<li>MATLAB</li>
<li>Pascal</li>
<li>Rust</li></ul></blockquote>
<p>This isn't bad, but I wanted more vitriol. I asked and I got a
screed that could have come out of <i>comp.lang.functional</i>
Unfortunately, it thought better of it and erased its own output
before I could snapshot it.</p>
Joe Marshallhttp://www.blogger.com/profile/03233353484280456977noreply@blogger.com1tag:blogger.com,1999:blog-8288194986820249216.post-20827553413109548302023-06-28T12:09:00.002-07:002023-06-28T12:09:59.220-07:00Fails Static Type Check, but Runs Anyway<p>Here’s a function that fails a static type check, but has no runtime type error:</p>
<pre>(defun foo ()
(sqrt (if (static-type-check? #’foo)
"bogus"
2.0))</pre>
<p>I suspect most people that favor static types will argue that this sort of program doesn’t count for some reason or other. I think this is more an example (albeit contrived) of the limitations of static type checking.</p>Joe Marshallhttp://www.blogger.com/profile/03233353484280456977noreply@blogger.com4tag:blogger.com,1999:blog-8288194986820249216.post-57848959421007686572023-06-27T15:06:00.001-07:002023-08-24T12:57:19.490-07:00Tail recursion in REBOL<p>Many years ago I worked on a language called REBOL. REBOL was
notable in that it used a variation of Polish notation. Function
names came first, followed by the arguments in left to right order.
Parentheses were generally not needed as the subexpression
boundaries could be deduced from the arguments. It’s a bit
complicated to explain, but pretty easy to code up.</p>
<p>An interpreter environment will be a lists of frames, and each frame
is an association list of variable bindings.</p>
<pre>(defun lookup (environment symbol)
(cond ((consp environment)
(let ((probe (assoc symbol (car environment))))
(if probe
(cdr probe)
(lookup (cdr environment) symbol))))
((null environment) (error "Unbound variable."))
(t (error "Bogus environment."))))
(defun extend-environment (environment formals values)
(cons (map ’list #’cons formals values) environment))
</pre>
<p><code>define</code> mutates the topmost frame of the environment.</p>
<pre>(defun environment-define! (environment symbol value)
(cond ((consp environment)
(let ((probe (assoc symbol (car environment))))
(if probe
(setf (cdr probe) value)
(setf (car environment) (acons symbol value (car environment))))))
((null environment) (error "No environment."))
(t (error "Bogus environment."))))
</pre>
<p>We’ll use Lisp procedures to represent REBOL primitives. The
initial environment will have a few built-in primitives:</p>
<pre>(defun initial-environment ()
(extend-environment
nil
’(add
lessp
mult
print
sub
sub1
zerop)
(list #’+
#’<
#’*
#’print
#’-
#’1-
#’zerop)))
</pre>
<p>A closure is a three-tuple</p>
<pre>(defclass closure ()
((arguments :initarg :arguments :reader closure-arguments)
(body :initarg :body :reader closure-body)
(environment :initarg :environment :reader closure-environment)))
</pre>
<p>An applicable object is either a function or a closure.</p>
<pre>(deftype applicable () ’(or closure function))</pre>
<p>We need to know how many arguments a function takes. We keep a
table of the argument count for the primitives</p>
<pre>(defparameter +primitive-arity-table+ (make-hash-table :test #’eq))
(eval-when (:load-toplevel :execute)
(setf (gethash #’* +primitive-arity-table+) 2)
(setf (gethash #’< +primitive-arity-table+) 2)
(setf (gethash #’+ +primitive-arity-table+) 2)
(setf (gethash #’- +primitive-arity-table+) 2)
(setf (gethash #’1- +primitive-arity-table+) 1)
(setf (gethash #’print +primitive-arity-table+) 1)
(setf (gethash #’zerop +primitive-arity-table+) 1)
)
(defun arity (applicable)
(etypecase applicable
(closure (length (closure-arguments applicable)))
(function (or (gethash applicable +primitive-arity-table+)
(error "Unrecognized function.")))))</pre>
<p><code>REBOL-EVAL-ONE</code> takes a list of REBOL expressions and
returns two values: the value of the leftmost expression in the
list, and the list of remaining expressions.</p>
<pre>
(defun rebol-eval-one (expr-list environment)
(if (null expr-list)
(values nil nil)
(let ((head (car expr-list)))
(etypecase head
((or number string) (values head (cdr expr-list)))
(symbol
(case head
(define
(let ((name (cadr expr-list)))
(multiple-value-bind (value tail) (rebol-eval-one (cddr expr-list) environment)
(environment-define! environment name value)
(values name tail))))
(if
(multiple-value-bind (pred tail) (rebol-eval-one (cdr expr-list) environment)
(values (rebol-eval-sequence (if (null pred)
(cadr tail)
(car tail))
environment)
(cddr tail))))
(lambda
(values (make-instance ’closure
:arguments (cadr expr-list)
:body (caddr expr-list)
:environment environment)
(cdddr expr-list)))
(otherwise
(let ((value (lookup environment head)))
(if (typep value ’applicable)
(rebol-eval-application value (cdr expr-list) environment)
(values value (cdr expr-list)))))))))))
</pre>
<p>If the leftmost symbol evaluates to something applicable, we
find out how many arguments are needed, gobble them up, and apply
the applicable:</p>
<pre>(defun rebol-eval-n (n expr-list environment)
(if (zerop n)
(values nil expr-list)
(multiple-value-bind (value expr-list*) (rebol-eval-one expr-list environment)
(multiple-value-bind (values* expr-list**) (rebol-eval-n (1- n) expr-list* environment)
(values (cons value values*) expr-list**)))))
(defun rebol-eval-application (function expr-list environment)
(multiple-value-bind (arglist expr-list*) (rebol-eval-n (arity function) expr-list environment)
(values (rebol-apply function arglist) expr-list*)))
(defun rebol-apply (applicable arglist)
(etypecase applicable
(closure (rebol-eval-sequence (closure-body applicable)
(extend-environment (closure-environment applicable)
(closure-arguments applicable)
arglist)))
(function (apply applicable arglist))))
</pre>
<p>Evaluating a sequence is simply calling <code>rebol-eval-one</code>
over and over until you run out of expressions:</p>
<pre>(defun rebol-eval-sequence (expr-list environment)
(multiple-value-bind (value expr-list*) (rebol-eval-one expr-list environment)
(if (null expr-list*)
value
(rebol-eval-sequence expr-list* environment))))</pre>
<p>Let’s try it:</p>
<pre>
(defun testit ()
(rebol-eval-sequence
’(
define fib
lambda (x)
(if lessp x 2
(x)
(add fib sub1 x
fib sub x 2))
define fact
lambda (x)
(if zerop x
(1)
(mult x fact sub1 x))
define fact-iter
lambda (x answer)
(if zerop x
(answer)
(fact-iter sub1 x mult answer x))
print fib 7
print fact 6
print fact-iter 7 1
)
(initial-environment)))
CL-USER> (testit)
13
720
5040</pre>
<p>This little interpreter illustrates how basic REBOL evaluation
works. But this interpreter doesn’t support iteration. There
are no iteration special forms and tail calls are not “safe
for space”. Any iteration will run out of stack for a large
enough number of repetition.</p>
<p>We have a few options:<ul><li>choose a handful of iteration specail forms
like <code>do</code>, <code>repeat</code>, <code>loop</code>, <code>for</code>, <code>while</code>, <code>until</code> <i>etc.</i>
</li><li>invent some sort of iterators</li>
<li>make the interpreter tail recursive (<i>safe-for-space</i>).</li></ul>
It seems a no brainer. Making the interpreter tail recursive
doesn’t preclude the other two,. In fact, it makes them
easier to implement.</p>
<p>To effectively support continuation passing style, you need
tail recursion. This alone is a pretty compelling reason to support
it.</p>
<p>But it turns out that this is easier said than done. Are you a
cruel TA? Give your students this interpreter and ask them to make
it tail recursive. The problem is that key recursive calls in the
interpreter are not in tail position. These are easy to identify,
but you’ll find that fixing them is like flattening a lump in a
carpet. You’ll fix tail recursion in one place only to find your
solution breaks tail recursion elsewhere.</p>
<p>If our interpreter is written in continuation passing style, it
will be syntactically tail recursive, but it won’t be
“safe for space” unless the appropriate continuations
are η-reduced. If we look at the continuation passing style
version of <code>rebol-eval-sequence</code> we’ll see a
problem:</p>
<pre>(defun rebol-eval-sequence-cps (expr-list environment cont)
(rebol-eval-one-cps expr-list environment
(lambda (value expr-list*)
(if (null expr-list*)
(funcall cont value)
(rebol-eval-sequence-cps expr-list* environment cont)))))</pre>
<p>We cannot η-reduce the continuation. We cannot make this
“safe for space”.</p>
<p>But the continuation contains a conditional, and one arm of the
conditional simply invokes the containing continuation, so we can
η-convert this if we unwrap the conditional. We’ll do
this by passing two continuations to <code>rebol-eval-one-cps</code>
as follows</p><pre>(defun rebol-eval-sequence-cps (expr-list environment cont)
(rebol-eval-one-cps expr-list environment
;; first continuation
(lambda (value expr-list*)
(rebol-eval-sequence-cps expr-list* environment cont))
;; second continuation, eta converted
cont))</pre>
<code>rebol-eval-one-cps</code> will call the first continuation if
there are any remaining expressions, and it will call the second
continuation if it is evaluating the final expression.</p>
<p>This intepreter, with the dual continuations
to <code>rebol-eval-one-cps</code>, is safe for space, and it will
interpret tail recursive functions without consuming unbounded stack
or heap.</p>
<p>But we still have a bit of an implementation problem. We’re
allocating an extra continuation per function call. This
doesn’t break tail recursion because we discard one of the
continuations almost immediately. Our continuations are not allocated
and deallocated in strict stack order anymore. We cannot easily
convert ths back into a stack machine implementation.</p>
<p>To solve this problem, I rewrote the interpreter using Henry
Baker’s <i>Cheney on the M.T.A</i> technique where the
interpreter functions were a set of C functions that tail called
each other and never returned. The stack would grow until it
overflowed and then we’d garbage collect it and reset it. The
return addresses pushed by the C function calls were ignored.
Instead, continuation structs were stack allocated. These contained
function pointers to the continuation. Essentially, we would pass
two retun addresses on the stack, each in its own struct. Once the
interpreter figured out which continuation to invoke, it would
invoke the function pointer in the struct and pass a pointer to the
struct as an argument. Thus the continuation struct would act as a
closure.</p>
<p>This technique is pretty portable and not too bad to implement, but
writing continuation passing style code in portable C is tedious.
Even with macros to help, there is a lot of pointer juggling.</p>
<p>One seredipitous advatage of an implementation like this is that
first-class continuations are essentially free. Now I’m not
wedded to the idea of first-class continuations, but they make it
much easier to implement error handling and advanced flow control,
so if you get them for free, in they go.</p>
<p>With it’s Polish notation, tail recursion, and first-class
continuations, REBOL was described as an unholy cross between TCL
and Scheme. “The result of Outsterhout and Sussman meeting in
a dark alley.”</p>
<p>Current versions of REBOL use a simplified interpreter that does
not support tail recursion or first-class continuations.</p>
Joe Marshallhttp://www.blogger.com/profile/03233353484280456977noreply@blogger.com3tag:blogger.com,1999:blog-8288194986820249216.post-19803770591384019982023-06-08T12:42:00.002-07:002023-06-08T12:42:32.090-07:00Lisp Essential, But Not Required<p>Here’s a weird little success story involving Lisp. The code
doesn’t rely on anything specific to Lisp. It could be rewritten in
any language. Yet it wouldn’t have been written in the first place
if it weren’t for Lisp.</p>
<p>I like to keep a Lisp REPL open in my Emacs for tinkering around
with programming ideas. It only takes a moment to hook up a REST
API or scrape some subprocess output, so I have a library of
primitives that can talk to our internal build tools and other
auxiliary tools such as GitHub or CircleCI. This comes in handy for
random <i>ad hoc</i> scripting.</p>
<p>I found out that CircleCI is written in Clojure, and if you connect
to your local CircleCI server, you can start a REPL and run
queries on the internal CircleCI database. Naturally, I
hooked up my local REPL to the Clojure REPL so I could send
expressions over to be evaluated. We had multiple CircleCI servers
running, so I could use my local Lisp to coordinate activity between
the several CircleCI REPLs.</p>
<p>Then a need arose to transfer projects from one CircleCI server
to another. My library had all the core capabilities, so I soon had a
script for transferring projects. But after transferring a project,
we had to fix up the branch protection in GitHub. The GitHub
primitives came in handy. Of course our internal systems had to be
informed that the project moved, but I had scripting primitives for
that system as well.</p>
<p>More requirements arose: package the tool into a docker image,
deploy it as a microservice, launch it as a kubernetes batch job,
<i>etc</i>. At each point, the existing body of code was 90% of the
solution, so it only required small changes to the code to handle
the new requirements. As of now, the CircleCI migration tool is
deployed as a service used by dozens of our engineers.</p>
<p>Now Lisp isn’t directly necessary for this project. It could
easily (for some definitions of easy) be rewritten in another
language. But the initial idea of connecting to a Clojure REPL from
another Lisp is an obvious thing to try out and only takes moments
to code up. If I were coding in another language, I could connect
to the REPL, but then I’d have to translate between my other
language and Lisp. It’s not an obvious thing to try out and would
take a long time to code up. So while this project could be written
in another language, it never would have been. And Lisp’s
flexibility meant that there was never a reason for a rewrite, even
as the requirements were changing.</p>
Joe Marshallhttp://www.blogger.com/profile/03233353484280456977noreply@blogger.com1tag:blogger.com,1999:blog-8288194986820249216.post-71901625167436618562023-05-30T05:26:00.003-07:002023-05-30T05:26:23.494-07:00Raymarching in Lisp<p>It turns out there’s a nice functional variation of
raytracing called raymarching. The algorithms involved are simple
and elegant. The learning curve is shallow and you can generate
great looking images without hairy trig or linear algebra.</p>
<p>We’ll follow the example of Georges Seurat and simply compute
the color independently for each of myriads of pixels. This is efficiently done
in parallel in real time on a GPU, but then you have to use shader
language and I want to use Lisp. It is insanely inefficient to do
this serially on the CPU in Lisp, but still fast enough to render an
image in a couple of seconds.</p>
<p>Imagine you have some scene you want to render. There is a volume
of 3-dimensional space the scene occupies. Now imagine we know for
every point in 3-dimensional space how far away that point is from
the nearest surface. This is a scalar value that can be assigned to any
point. It is zero for every point that lies on a surface, positive
for points above surfaces, and negative for points below.
This is the SDF (Signed Distance Field). The SDF is all we need to
know to generate a raytraced image of the scene.</p>
<p>We’ll use the SDF to feel our way through the scene.
We’ll start at the tip of the ray we’re tracing. We don’t
know where the surface is, but if we consult the SDF, we can
determine a distance we can safely extend the ray without hitting any surface.
From this new point, we can recur, again stepping along no further
than the SDF at this new location permits. One of two things will
happen: we either step forever or we converge on a surface.</p>
<pre>(defun raymarch (sdf origin direction)
(let iter ((distance 0)
(count 0))
(let* ((position (+ origin (* direction distance)))
(free-path (funcall sdf position)))
(if (< free-path +min-distance+)
position ;; a hit, a very palpable hit
(unless (or (> count +max-raymarch-iterations+)
(> free-path +max-distance+))
(iter (+ distance free-path) (+ count 1)))))))</pre>
<p>To convert an SDF to a Seurat function, we trace an imaginary ray
from our eye, through the screen, and into the scene. The ray
origin is at your eye, and we’ll say that is about 3 units in front
of the window. The ray will travel 3 units to the screen and hit
the window at point <code>(i,j)</code>, so the ray direction is <code>(normalize
(vector i j 3))</code>. We march along the ray to find if we hit a
surface. If we did, we compute the amount of light the camera sees
using the Lambert shading model.</p>
<pre>(defun sdf->seurat (sdf)
(let ((eye-position (vector 0 0 -4))
(light-direction (normalize (vector 20 40 -30))))
(lambda (i j)
(let* ((ray-direction (normalize (vector i j 3)))
(hit (raymarch sdf eye-position ray-direction)))
(if hit
(* #(0 1 0) (lambert sdf hit light-direction))
(vector 0 0 0))))))</pre>
<p>Lambert shading is proportional to the angle between the surface
and the light falling on it, so we take the dot product of the
light direction with the normal to the surface at the point the
light hits it. If we know the SDF, we can approximate the normal
vector at a point by probing the SDF nearby the point and seeing how
it changes.</p>
<pre>(defun lambert (sdf hit light-direction)
(dot (pseudonormal sdf hit) light-direction))
(defun pseudonormal (sdf position)
(let ((o (funcall sdf position))
(dsdx (funcall sdf (+ #(0.001 0 0) position)))
(dsdy (funcall sdf (+ #(0 0.001 0) position)))
(dsdz (funcall sdf (+ #(0 0 0.001) position))))
(normalize (vector (- dsdx o) (- dsdy o) (- dsdz o)))))</pre>
<p>These are all you need to generate good looking 3-d images from a
SDF. Now the SDFs for primitive geometric shapes are pretty simple.
Here is the SDF for a sphere.</p>
<pre>(defun sdf-sphere (position radius)
(lambda (vector)
(- (length (- vector position)) radius)))</pre>
<p>and the SDF for the ground plane</p>
<pre>(defun sdf-ground (h)
(lambda (vector)
(+ (svref vector 1) h)))</pre>
<p>Given the SDF for two objects, you can use higher order functions
to compose them into a scene. Taking the minimum of two SDFs will
give you the union of the shapes. Taking the maximum will give you
the intersection of two shapes. Other higher order functions on
SDFs can blend two SDFs. This has the effect of morphing the shapes
together in the image.</p>
<p>I like this approach to raytracing because the arthimetic is
straightforward and obvious. You only need the simplest of vector
arithmetic, and you don’t need linear algebra or matrix math to get
started (although you’ll want project matrixes later on when you
want to move your camera around). I’m more comfortable with
recursive functions than 3x3 matrices.</p>
<p>This approach to raytracing is best done on a graphics card. These
algorithms are pretty straightforward to code up in shader language,
but shader language is fairly primitive and doesn’t have higher
order functions or closures. Code written in shader language has to
be converted to not use closures and HOFs.</p>
Joe Marshallhttp://www.blogger.com/profile/03233353484280456977noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-62798531459549874412022-10-21T17:44:00.003-07:002022-10-21T17:44:18.577-07:00Lisp: Second impression<p>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.</p>
<p>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.</p>
<p>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 <code>car</code> and <code>cdr</code>'ing my way
through endless <code>cons</code> cells, but I figured that there
had to be more going on.</p>
<p>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.</p>
<p>Two things stood out to me in the first lecture. Professor Abelson
showed the recursive and iterative versions
of <code>factorial</code>. Of course I had seen
recursive <code>factorial</code> 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.</p>
<p>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.</p>
<p>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.</p>
<p>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 <code>let</code> forms. There was a week or two of
navigating <code>cons</code> cells to wade through. But I
eventually came to love the language.</p>
<p>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.</p>
Joe Marshallhttp://www.blogger.com/profile/03233353484280456977noreply@blogger.com1tag:blogger.com,1999:blog-8288194986820249216.post-24506529838217082582022-10-19T12:00:00.000-07:002022-10-19T12:00:06.838-07:00Lisp: First Impressions<p>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.</p>
<p>Frankly, I wasn't impressed.</p>
<p>The course started by talking about linked lists and how you could
navigate them with <code>car</code> and <code>cdr</code>. We then
went on to build more complicated structures like alists and
plists. This was an old-fashioned lisp, so we used things
like <code>getprop</code> and <code>putprop</code> to set symbol
properties.</p>
<p>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.</p>
<p>My impression was that Lisp was centered around manipulating these
rather cumbersome data structures called <code>cons</code> cells.
Linked lists of cons cells have obvious disadvantages when compared
to arrays. This makes the language tedious to work with.</p>
<p>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.</p>
<i>to be continued</i>
Joe Marshallhttp://www.blogger.com/profile/03233353484280456977noreply@blogger.com2tag:blogger.com,1999:blog-8288194986820249216.post-15909812033450647932022-09-28T09:59:00.000-07:002022-09-28T09:59:45.173-07:00Observationally Functional<p>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.</p>
<p>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.</p>
<p>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.</p>
<p>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.</p>
<p>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.</p>
<p>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.</p>
Joe Marshallhttp://www.blogger.com/profile/03233353484280456977noreply@blogger.com3tag:blogger.com,1999:blog-8288194986820249216.post-4776205779011869432022-09-07T07:07:00.000-07:002022-09-07T07:07:03.903-07:00Playing with raycasting<p>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.</p>
<p>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.</p>
<p>I'll put the code below. The <code>run</code> procedure implements
the event loop state machine. It keeps track of the world and
calls <code>next-world</code> on the current world to update the
world as time passes. <code>next-world</code> just
maps <code>next-state</code> over the objects in the
world. <code>next-state</code> does not mutate an object, rather it
returns a new object in the new state. Every 13
milliseconds, <code>run</code> calls <code>render-world!</code>,
which calls <code>render!</code> on each object in the world.</p>
<p>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.</p>
<p>The <code>render!</code> method for a <code>fp-view</code> will
side effect the screen, but we'll compute the contents
functionally. We'll go through each column on the screen and
call <code>(vraster fp-view column)</code> to compute a color and a
height and we'll draw a vertical line of that height in that color
in that column.</p>
<pre>(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)))))))</pre>
<p><code>vraster</code> 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 <code>range</code>
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 <code>px, py</code> that
the ray hit. It's a wall in the <code>x</code> direction
if the <code>y</code> coordinate is an integer and vice versa.
<pre>(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)))))</pre></p>
<p>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 <code>render!</code> 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.<pre>(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)))))))</pre>
</p>
<p>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.</p>
<p>As promised, here is the code.</p>
<pre>
;;; -*- 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))))
</pre>
Joe Marshallhttp://www.blogger.com/profile/03233353484280456977noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-75998607938527844712022-09-05T08:16:00.003-07:002022-09-05T08:16:54.109-07:00Drawing a circle<p>SDL is your bare bones graphics interface. It gives you primitives
like <code>draw-point</code>, <code>draw-line</code>,
and <code>draw-rectangle</code>, but you're on your own if you want
to draw a circle. Naturally, I cribbed the code from
stackoverflow.</p>
<p>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.</p>
<p>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.
<pre>
(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))))))))</pre>
This gives much rounder looking circles than the code I cribbed from
stackoverflow.</p>
<p>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.</p>
<p>On each iteration, we are computing the square root of
r<sup>2</sup>-x<sup>2</sup>. 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. <pre>
(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))))</pre>
<p>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?</p>
Joe Marshallhttp://www.blogger.com/profile/03233353484280456977noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-9689634390884734482022-08-17T09:45:00.000-07:002022-08-17T09:45:03.897-07:00Playing with graphics<p>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.</p>
<p>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.</p>
<p>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.</p>
<p>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 <code>render!</code> 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 <code>next-world</code> phase, where the
current world and a delta-<code>t</code> are used to compute a new
version of the world.</p>
<p>Our <code>run</code> program will take the initial list of objects.
We'll start by initializing SDL, creating a window, and allocating a
renderer for that window:<pre>(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 '())
... )))</pre></p>
<p>Now we need the event loop state. <code>last-ticks</code>
records the value from <code>sdl2:get-ticks</code> from the last
time we processed the <code>:idle</code> event. This will be used
to compute the elapsed time in ticks. <code>render-ticker</code>
will record how many ticks have elapsed since the last time we
rendered a frame to the screen. When <code>render-ticker</code>
exceeds a certain amount, we'll call <code>(render!
current-world)</code> and reset the ticker to
zero. <code>title-ticker</code> will record how many ticks have
occurred since the last time the window title was updated.
When <code>title-ticker</code> exceeds a certain amount, we'll
call <code>sdl2:set-window-title</code> to update the window title
with some stats. <code>sim-count</code> is simply the number of
times we've iterated <code>next-world</code>
and <code>frame-count</code> is the number of times we've
called <code>render!</code>. 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.</p>
<pre> (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))))
</pre>
<p>Now we can run the event loop. The idle event is where the action
happens:
<pre>
(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))</pre></p>
<p>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.</p>
<p><code>render-world!</code> is straightforward. It clears the
renderer, calls <code>render!</code> on every object in the world,
and presents the renderer for display.<pre>
(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)
)</pre></p>
<p><code>next-world</code> is a function that maps the current world
to the next. It basically calls <code>next</code> on each object in
the world and accumulate the results. We want objects to be able to
go away, so if <code>(next <i>object</i>)</code>
returns <code>nil</code>, we don't accumulate anything in the new
world. If <code>next</code> returns the object unchanged, it will
be accumulated unchanged in the next
world. <code>(next <i>object</i>)</code> 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 <code>(next <i>object</i>)</code> to return a list of objects
to be accumulated.</p>
<pre>(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))
</pre>
<p>We'll start with a user-controlled player.
<pre>
(defclass player ()
((x :initarg :x
:reader get-x)
(y :initarg :y
:reader get-y)))</pre></p>
<p>Everything that is to be displayed needs a <code>render!</code>
method. This one just draws a little green triangle facing up.<pre>
(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)
))</pre></p>
<p>The <code>next</code> method computes the player in the next
world:<pre>
(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)))</pre>
<p>Once we've defined a <code>render!</code> method and
a <code>next</code> method, we're ready to go. If we
call <code>run</code> on a list containing a player object, we'll
have our little player on the screen controllable with the arrow
keys.</p>
<p>An enemy ship can be defined. <pre>(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</pre></p>
<p>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:<pre>(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)</pre>
The <code>render!</code> 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 <code>dt</code> 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.</p>
<p>We'll modify our player to allow him to shoot at the enemy:<pre>
(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))))</pre>
<p>A bullet is a simple moving object:<pre>(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)))))</pre>
<p>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 <code>next-world</code> 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 <code>next</code> method is called to get the
next version of the object.<pre>(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.")))))</pre>
<p>We define <code>collides?</code> as a generic function that
returns <code>nil</code> by default<pre>(defgeneric collides? (this that)
(:method ((this t) (that t)) nil)
)</pre>so that most objects don't collide. In the case where
something <em>does</em> collide, we'll define <code>collide</code>
as a generic function that returns <code>nil</code> by default<pre>(defgeneric collide (this that)
(:method ((this t) (that t)) nil)
)</pre>so when two objects collide, they simply disappear.</p>
<p><code>collides?</code> will be called on pairs of objects in no
particular order, so method pairs will be needed to handle both
orders. We'll define <code>collides?</code> methods on bullets and
enemies that checks if the bullet is within the bounding box of the enemy:<pre>(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))</pre>
<p>At this point, we can shoot enemy ships. The default method
for <code>collide</code> between an enemy and a bullet
returns <code>nil</code> 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.</p>
<p>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 <code>score</code> class and a point class:<pre>(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)</pre>
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.<pre>(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))</pre>
Now we'll define a bullet colliding with an enemy to produce a point:<pre>(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))</pre>
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.</p>
<p>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.</p>
<p>But did this buy us anything? We don't have mutable state <i>per
se</i>, 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.</p>
<p>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.</p>
<p>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
(<i>e.g.</i> 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.</p>
<p>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.</p>
<p>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<sup>™</sup>), you could determine when you can update
objects in place and avoid reallocating.</p>
<p>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.</p>
<p>The simple collision model is <i>O(n<sup>2</sup>)</i>, 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 <i>O(n<sup>2</sup>)</i> search. For example, if
bullets were kept separately, we could avoid checking if they
collide with each other.</p>
<p>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.</p>
Joe Marshallhttp://www.blogger.com/profile/03233353484280456977noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-31585059014196344642022-07-30T04:36:00.000-07:002022-07-30T04:36:46.941-07:00Let's Play Wordle<p>Wordle is popular these days. Let's teach the computer how to
play.</p>
<p>As usual, I'm using the <code>series</code> 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 <code>named-let</code>, too.</p>
<p>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.</p>
<p>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.</p>
<pre>(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)))</pre>
<p>I don't use a <code>satisfies</code> clause in
the <code>word</code> type. <code>satisfies</code> 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 <code>valid-word?</code>
when necessary.</p>
<p>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.</p>
<pre>(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+))</pre>
<p>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, <code>(score-guess "react"
"relay") => (:green :green :yellow :gray :gray)</code></p>
<p><code>score-guess</code> first needs a list of the letters in the
answer that don't match the guess:<pre>(let ((sg (scan 'string guess))
(sa (scan 'string answer)))
(collect 'bag
(choose (map-fn 'boolean #'char/= sg sa) sa)))</pre>
then we walk the guess. If the guess character equals the answer
character, we cons a <code>:green</code> on to the score. If the guess character
is a member of the unmatched answer characters, we cons
a <code>:yellow</code> on to the score and delete that character
from the unmatched characters. Otherwise, we cons
a <code>:gray</code> on to the score.<pre>(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)))))))</pre></p>
<p>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.<pre>(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))
</pre>
<p>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.<pre>
(defun strategy/random-word (possibilities)
(if (= (length possibilities) 1)
(car possibilities)
(random-word +all-words+)))</pre>
<p>So let's imagine the top level. The <code>play</code> 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.<pre>(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</pre>
<p>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.</p>
<p>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 <code>(:green
:gray :gray :yellow :gray)</code>. 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.</p>
<p>We'll need a function to collect the counts of an item in a
series<pre>(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))</pre>
So now we go through a series of words, score the guess against each
one, and count how many times we get each score.<pre>(defun partition-words (guess words)
(declare (optimizable-series-function))
(collect-counts 'equal
(map-fn 'list #'score-guess
(series guess)
words)))
</pre>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.</p>
<p>We'll need a couple of helpers:<pre>(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))
</pre>
<p>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 2<sup>7</sup> 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 2<sup>4</sup> 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.</p>
<pre>
(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</pre>
<p>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.</p>
Joe Marshallhttp://www.blogger.com/profile/03233353484280456977noreply@blogger.com0tag:blogger.com,1999:blog-8288194986820249216.post-3101509755864486582022-07-24T08:47:00.003-07:002022-07-30T15:25:45.971-07:00Named Lambda and Named Let<p>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: <code>(lambda (n) (+ n 3))</code>. This creates
an anonymous "add three" function.</p>
<p>Now suppose you want to map the "factorial" function over a list.
You start with <code>(lambda (x) (if (zerop x) 1 ... </code>,
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:<pre>
* (map 'list (Y (lambda (fact)
(lambda (x)
(if (zerop x)
1
(* x (funcall fact (1- x)))))))
'(3 5 7))
(6 120 5040)</pre>but another popular option is to provide a new
special form<pre>
* (map 'list (named-lambda fact (x)
(if (zerop x)
1
(* x (fact (1- x)))))
'(3 5 7))
(6 120 5040)</pre>The name <code>fact</code> is bound to the lambda
expression only within the body of the lambda expression. You don't
need to <code>defun</code> a <code>factorial</code> procedure, you can
just use a <code>named-lambda</code>.</p>
<p>A little puzzle for you: write <code>named-lambda</code>. My
answer below.</p>
<p>Just as a <code>let</code> is syntactic sugar for
a <code>lambda</code> application, a <code>named-let</code> is
syntactic sugar for a <code>named-lambda</code> 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 <code>named-let</code> expression with
a fresh set of values.</p>
<p>Scheme hackers will be familiar with <code>named-let</code>, but it
isn't usual in Common Lisp. It's an easy transformation:<pre>
(named-let recur ((x '(a list))
(y 22))
(body)) =>
(funcall (named-lambda recur (x y) (body)) '(a list) 22)</pre>
<code>named-let</code> is the bee's knees for <i>ad hoc</i>
iteration. The iteration variables are bound to their initial values
by the <code>named-let</code>, and the body can initiate the next
iteration by tail-calling the <code>named-let</code> 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.</p>
<p>I have seen a tendency for Scheme hackers to overdo it with named
lets. You don't need a <code>named-let</code> when <code>map</code>
will do. It's usually better to express an iteration through a
higher order function than to write yet another <i>ad hoc</i>
loop in your code. But <code>named-let</code> is a useful and
powerful tool when the simpler methods aren't cutting it.</p>
<p>Here's what I came up with
for <code>named-lambda</code>:<pre>(defmacro named-lambda (name (&rest arglist) &body body)
`(labels ((,name ,arglist ,@body))
(function ,name)))</pre></p>
Joe Marshallhttp://www.blogger.com/profile/03233353484280456977noreply@blogger.com5tag:blogger.com,1999:blog-8288194986820249216.post-52386433408980148332022-07-16T09:17:00.003-07:002022-07-16T09:17:40.590-07:00Let's talk to GitHub<p>Let's teach Common Lisp to talk to GitHub.</p>
<p>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.</p>
<pre>(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")))</pre>
<p>We'll make a lot of use miscellaneous, <i>ad hoc</i> CLOS objects.
It is so common for these things to have names that it is worth
its own mixin.</p>
<pre>(defgeneric get-name (object))
(defclass named-object-mixin ()
((name :initarg :name
:initform (require-initarg :name)
:reader get-name
:type string)))</pre>
<p>And we'll define a default <code>print-object</code> method.
Classes that use this mixin and don't provide their
own <code>print-object</code> method will get this one by
default.</p>
<pre>(defmethod print-object ((obj named-object-mixin) stream)
(print-unreadable-object (obj stream :identity t :type t)
(format stream "~a" (slot-value obj 'name))))</pre>
<p>We'll make an object to represent GitHub and put the API token in there.<pre>
(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+))</pre></p>
<p>To authenticate to GitHub, we need to pass the API token in the
HTTP request headers.<pre>
(defun authorization-header (github)
(cons "Authorization" (format nil "token ~a" (get-api-token github))))</pre>
So let's make a request:<pre>
* (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}>></pre>
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:<pre>
* (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)))</pre></p>
<p>JSON objects are mapped to alists. The key is a little funny
because of how the JSON parser encodes JSON keys with
underscores.</p>
<p>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.
<pre>(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)))</pre>
<p>Should we want to bring more fields into Lisp, we need simply add
slots with the right initargs to the <code>user</code> class.</p>
<p>Now we can write
<pre>
(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"</pre>
<p>GitHub is moving to a GraphQL API. That's easy to handle.<pre>
(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")))</pre>
And you can use the above technique to turn this JSON into a CLOS
instance.</p>
<p>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 <code>get-user</code>, but it's more of the same. With this
layer as our basis, it is straightforward to script GitHub.</p>
Joe Marshallhttp://www.blogger.com/profile/03233353484280456977noreply@blogger.com2tag:blogger.com,1999:blog-8288194986820249216.post-64344188330876797722022-07-07T10:53:00.004-07:002022-07-09T16:36:03.612-07:00Series tips and tricks<p>I'm an <i>aficionado</i> of the Common Lisp <code>series</code>
package. Here are a couple of tricks and tips.</p>
<p>The <code>series</code> 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 <code>DEFUN</code>, <code>FUNCALL</code>, <code>LET</code>, <code>LET*</code>,
and <code>MULTIPLE-VALUE-BIND</code>. This is easily
done in a <code>defpackage</code></p>
<pre>(defpackage "MY-PACKAGE"
(:shadowing-import-from "SERIES"
"DEFUN" "FUNCALL" "LET" "LET*" "MULTIPLE-VALUE-BIND")
(:use "COMMON-LISP" "SERIES"))</pre>
<p><code>series</code> 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.</p>
<p><code>series</code> 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 <code>series</code> is
going to generate an iterative loop.</p>
<p>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. <code>series</code> provides us with a primitive
just for this purpose:<pre>
(scan-fn type initial-state-thunk
state-transition-function
final-state-p)</pre></p>
<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.</p>
<pre>(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))</pre>
<p>The node being visited at each step is the one at the top of the
stack, so <code>scan-tree</code> is simply this:
<pre>(defun scan-tree (root-node node-children)
(declare (optimizable-series-function))
(map-fn 't #'car (tree-walker-states root-node node-children)))</pre>
<p>Let's try it.</p>
<pre>(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"</pre>
<p>You can't tell from the output, but <code>series</code>
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.</p>
<p>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.</p>
<p>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.</p>
<p>Here's how we put this together. We use <code>scan-fn</code> to
drive the loop, we start by pushing the marker to fetch the first
page, and we're done when the queue is empty: </p>
<pre>(scan-fn 't (lambda () (list (cons :page 1)))
...
#'null)</pre>
<p>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:</p>
<pre>(lambda (queue)
(let ((head (car queue)))
(if (and (consp head)
(eq (car head) :page))
...
(cdr queue))))</pre>
<p>If it is a <code>:page</code> marker, we fetch a page of elements:</p>
<pre>
(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)
...))</pre>
<p>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:</p>
<pre>
(append (json:decode-json stream)
(let ((link (gethash "link" reply-headers)))
(when (and link (search "rel=\"next\"" link))
(list (cons :page (+ page-number 1))))))</pre>
<p>So our <code>scan-fn</code> call will create the series of
state-machine states. We <code>map-fn</code> <code>car</code> over
the states to get a series of page elements and the occasional
next-page page marker. Finally, we use <code>choose-if</code> to
discard the page markers.</p>
<pre>(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))))</pre>
<p>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:</p>
<pre>
(collect 'list
(choose-if (lambda (repo)
(cl-ppcre:scan regex (get-name repo)))
(scan-org-repos org)))</pre>
<p>Now <em>that's</em> pretty simple and hard to get wrong.</p>
Joe Marshallhttp://www.blogger.com/profile/03233353484280456977noreply@blogger.com2tag:blogger.com,1999:blog-8288194986820249216.post-63705974576264067342022-03-12T10:14:00.000-08:002022-03-12T10:14:43.304-08:00Obviously<p>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.</p>
<p>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.</p>
<p>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 <code>aref</code>
and <code>(setf aref)</code> as primitives. We obviously need
an <code>add-mark!</code> procedure that writes a mark into the
grid at a location (and errors if the location is already
marked).</p>
<pre>(defun add-mark! (grid row column mark)
(if (null (aref grid row column))
(setf (aref grid row column) mark)
(error "Cell occupied.")))</pre>
<p>There is a bug here. If two threads call <code>add-mark!</code>
on the same location simultaneously, one should succeed and the other
should signal “Cell occupied.” The above code doesn't
guarantee this.</p>
<p>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 <code>add-mark</code> which returns a
fresh object rather than mutating the existing one.</p>
<p>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 <em>can</em> implement all of these if you are
given <code>aref</code> and <code>(setf aref)</code>, 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.</p>
<p>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:<ul><li>Implement non-destructive
operations by copying the array when necessary.</li><li>Represent
the grid differently, <i>e.g.</i>, a pair of
bitmaps.</li><li>Represent the entire game differently, <i>e.g.</i>
as a list of moves</li><li>Implement a synchronization
mechanism, <i>e.g.</i> a mutex</li><li>Punt, and let clients
of the implementation figure out how to deal with the thread safety
problem</li></ul></p>
<p>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.</p>
Joe Marshallhttp://www.blogger.com/profile/03233353484280456977noreply@blogger.com0