A bit more challenging

In my previous post, I gave the puzzle of taking a pattern and generating code that matches it. The tricky part was making sure that the pattern is completely traversed at compile time. If the object to be tested matches the pattern, the pattern variables and their values were to be returned in an alist.

It would be better, however, to generate code where the pattern variables become bindings of Scheme variables. Instead of generating code that stuffs the values into an alist, like this code does at the highlighted points:

(make-matcher '((? one) and (? two))) =>

(lambda (object)
  (and (pair? object)
       (let ((left-submatch
              ((lambda (object) (list (cons 'one object))) (car object)))
             (right-submatch
              ((lambda (object)
                 (and (pair? object)
                      (let ((left-submatch
                             ((lambda (object)
                                (and (eqv? object 'and)
                                     '()))
                              (car object)))
                            (right-submatch
                             ((lambda (object)
                                (and (pair? object)
                                     (let ((left-submatch
                                            ((lambda (object)
                                               (list (cons 'two object)))
                                             (car object)))
                                           (right-submatch
                                            ((lambda (object)
                                               (and (eqv? object '())
                                                    '()))
                                             (cdr object))))
                                       (and left-submatch
                                            right-submatch
                                            (append left-submatch
                                                    right-submatch)))))
                              (cdr object))))
                        (and left-submatch
                             right-submatch
                             (append left-submatch right-submatch)))))
               (cdr object))))
         (and left-submatch
              right-submatch
              (append left-submatch right-submatch)))))

We'd generate something more like this:

(make-matcher '((? one) and (? two)) <user code goes here>) =>

(lambda (object)
  (and (pair? object)
       (let ((one (car object))
             (tail1 (cdr object)))
         (and (pair? tail1)
              (eq? (car tail1) 'and)
              (let ((tail2 (cdr tail1)))
                (and (pair? tail2)
                     (let ((two (car tail2)))
                       (and (null? (cdr tail2))
                            <user code goes here>))))))))

This is more challenging for two reasons. First, we need to ensure that the pattern variable names become bound in a scope that encloses the user's code so that free references to pattern variables are correctly captured. In addition, we need to ensure that other “helper” bindings, like tail1 and tail2 do not capture free references by accident. (That is to say, watch your macro hygiene.) Second, you have to be sure that subpattern bindings are visible to the entire body of the user code. This will throw a monkey wrench into the simple recursive solution.

Slightly trickier

In my previous post, I gave a small pattern matching problem. It is easily solved by recursively descending the pattern and the object to match. This is analogous to interpreting the pattern because you walk the pattern each time you want to try to match an object.

If the pattern is constant, though, you can walk the pattern once and generate code that can match against an object much more quickly:

(define my-matcher
  (eval (make-matcher '(a (? var1) (nested (c (? var2)))))
        user-initial-environment))

(my-matcher '(a b (nested (c d)))) => ((var1 . b) (var2 . d))

I'd rate this as an intermediate puzzle. It isn't very different from the previous one, but you have to pay more attention to the phase of evaluation. As a hint, here are a pair of possible matchers:

(make-matcher '((? car) . (? cdr))) =>

(lambda (object)
  (and (pair? object)
       (let ((p1 ((lambda (object) (list (cons 'car object))) (car object)))
             (p2 ((lambda (object) (list (cons 'cdr object))) (cdr object))))
         (and p1
              p2
              (append p1 p2)))))

(make-matcher '((? one) and (? two))) =>

(lambda (object)
  (and (pair? object)
       (let ((left-submatch
              ((lambda (object) (list (cons 'one object))) (car object)))
             (right-submatch
              ((lambda (object)
                 (and (pair? object)
                      (let ((left-submatch
                             ((lambda (object)
                                (and (eqv? object 'and)
                                     '()))
                              (car object)))
                            (right-submatch
                             ((lambda (object)
                                (and (pair? object)
                                     (let ((left-submatch
                                            ((lambda (object)
                                               (list (cons 'two object)))
                                             (car object)))
                                           (right-submatch
                                            ((lambda (object)
                                               (and (eqv? object '())
                                                    '()))
                                             (cdr object))))
                                       (and left-submatch
                                            right-submatch
                                            (append left-submatch
                                                    right-submatch)))))
                              (cdr object))))
                        (and left-submatch
                             right-submatch
                             (append left-submatch right-submatch)))))
               (cdr object))))
         (and left-submatch
              right-submatch
              (append left-submatch right-submatch)))))

Astute readers will notice that this latter matcher is doing more work than necessary. If the match against part of the pattern fails, it still attempts to match the rest of the pattern. It only notices just before assembling the final result. Also, using append to assemble the sub-matches is a terrible waste.

A small puzzle

Here's a quick little puzzle that isn't too hard.

A pattern is:

1. A symbol, number, boolean, or null (an atom).
2. A pattern variable, which is a two element list where the first element is the symbol ? and the second is a symbolic (a symbol) name.

   ;;   Examples:
   ;;     (pattern-variable? '(? foo))                      => #t
   ;;     (pattern-variable? '(? another-pattern-variable)) => #t
   ;;
   ;;     (pattern-variable? '(not a (pattern variable)))   => #f
   ;;     (pattern-variable? '(?))                          => #f
   ;;     (pattern-variable? '(foo ?))                      => #f
   ;;     (pattern-variable? '(? foo . bar))                => #f
   ;;     (pattern-variable? '(? foo quux))                 => #f
   
   (define (pattern-variable? thing)
     (and (pair? thing)
          (eq? (car thing) '?)
          (pair? (cdr thing))
          (symbol? (cadr thing))
          (null? (cddr thing))))

3. A pair (a cons) of two patterns.

Write a program that given a pattern and some list structure (an object composed of pairs, numbers, symbols, nulls, etc.) returns an association list (an alist) of the pattern variable names and the associated matching elements, or #F if the pattern does not match.

;;  Examples:
;;   (pmatch '(foo (? pvar1) (? pvar2) bar) '(foo 33 #f bar))
;;      => ((pvar2 . #f) (pvar1 . 33))
;;
;;   (pmatch '(foo (? pvar) bar) '(quux 33 bar))
;;      => #f
;;
;;   (pmatch '(a (? var1) (nested (c (? var2)))) '(a b (nested (c d))))
;;      => ((var2 . d) (var1 . b))
;;
;;  Edge cases:
;;
;;   (pmatch '(a b c) '(a b c))
;;      => '()
;;
;;   (pmatch '(foo (? pvar1) (? pvar2) bar) '(foo 33 (xyzzy #f) bar))
;;      => ((pvar2 xyzzy #f) (pvar1 . 33))
;;
;;   (pmatch '(foo . (? pvar)) '(foo bar baz))
;;      => ((pvar bar baz))
;;
;;   (pmatch '((? ?) quux) '(foo quux))
;;      => ((? . foo))
;;
;;   (pmatch '(? ?) '(foo quux))
;;      => ((? foo quux))
;;
;;   (pmatch '(? ? ?) '(foo quux))
;;      => #f

Please be careful and obfuscate your solution if you want to post it.