exupero's blog

# Rewriting stack algorithms programmatically

In the previous post we rewrote a stack algorithm to make it easier to execute mentally, in particular making the following substitutions:

OriginalReplacement
`9 *``dup [10 *] dip -`
`5 /``10 / 2 *`
`[10 *] dip - 10 /``10 / -`

There are more substitutions we could make, so let's make a `rewrite` function that finds a pattern in a list of operations and replaces it.

``````(defn splice [seq start end insert]
(vec (concat (subvec seq 0 start)
insert
(subvec seq end))))``````
``````(defn rewrite [ops pattern replacement]
(let [len (count pattern)
[[i r]] (sequence
(comp
(map-indexed
(fn [i ops-window]
[i (when (= pattern ops-window)
replacement)]))
(filter second))
(partition len 1 ops))]
(if r
(splice ops i (+ i len) r)
ops)))``````
``````(rewrite '[9 * 5 / 32 +]
'[9 *]
'[dup [10 *] dip -])``````
``````[dup [10 *] dip - 5 / 32 +]
``````
``````(rewrite '[9 * 5 / 32 +]
'[5 /]
'[10 / 2 *])``````
``````[9 * 10 / 2 * 32 +]
``````

This is good enough to replace one sequence of constants with another, which we could do with the third substitution above, but unlike the 9 and 5 in the first two substitutions, the 10 has no special meaning; any other number follows the same identity.

To generalize the rewrite rule, we'll create a basic pattern matcher that recognizes symbols beginning with `?` as pattern variables.

``````(defn pattern-var? [x]
(and (symbol? x)
(= \? (first (name x)))))``````

Pattern variables all have to match the same value, so we'll track what each variable has matched with a hash map. Here's a function that walks a pattern sequence and a list of operations and builds up a map of name bindings, returning `nil` if a pattern fails to match:

``````(defn bindings
([pattern ops] (bindings pattern ops {}))
([pattern ops binds]
(reduce
(fn [binds [pat op]]
(cond
(pattern-var? pat)
, (if-let [bound (binds pat)]
(if (= bound op)
binds
(reduced nil))
(if (number? op)
(assoc binds pat op)
(reduced nil)))
(= pat op)
, binds
(and (vector? pat) (vector? op))
, (if-let [binds' (bindings pat op binds)]
(merge binds binds')
(reduced nil))
:else
, (reduced nil)))
binds
(map vector pattern ops))))``````

We'll use this function in a revised version of `rewrite` which checks for bindings instead of equality, then uses those bindings to rewrite the replacement:

``````(defn rewrite [ops pattern replacement]
(let [len (count pattern)
stop (- (count ops) len)]
(loop [i 0]
(if (<= i stop)
(let [ops-window (subvec ops i (+ i len))]
(if-let [binds (bindings pattern ops-window)]
(splice ops i (+ i len)
(clojure.walk/postwalk-replace
binds
replacement))
(recur (inc i))))
ops))))``````
``````(rewrite '[dup [10 *] dip - 10 / 2 * 32 +]
'[[?x *] dip - ?x /]
'[?x / -])``````
``````[dup 10 / - 2 * 32 +]
``````

To make multiple substitutions, let's apply rewrite rules until nothing changes:

``````(defn rewrite-first-matching [ops rules]
(reduce
(fn [ops [pattern replacement]]
(let [ops' (rewrite ops pattern replacement)]
(if (= ops' ops)
ops
(reduced ops'))))
ops rules))``````
``````(defn rewrites [ops rules]
(loop [ops ops]
(let [ops' (rewrite-first-matching ops rules)]
(if (= ops' ops)
ops
(recur ops')))))``````

Now we can apply all three rules:

``````(rewrites '[9 * 5 / 32 +]
'[[[9 *] [dup [10 *] dip -]]
[[5 /] [10 / 2 *]]
[[[?x *] dip - ?x /] [?x / -]]])``````
``````[dup 10 / - 2 * 32 +]
``````

Note that the order of the rules only affects which are checked first. If one makes a change, the others will be rechecked until none of the rules modify the list of operations.

We'll make some improvements to this scheme in the next post.