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:

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.