summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorbnewbold <bnewbold@eta.mit.edu>2009-03-08 23:06:20 -0400
committerbnewbold <bnewbold@eta.mit.edu>2009-03-08 23:06:20 -0400
commitbf7258c23db3e4a942f39b21b37b61315756a132 (patch)
tree080df2c17faf13099e3819ec214de7f1341c2ba1
parent1bb045d3580d2b21794d109461fbe064ae38f3b8 (diff)
download6.945-bf7258c23db3e4a942f39b21b37b61315756a132.tar.gz
6.945-bf7258c23db3e4a942f39b21b37b61315756a132.zip
pset05 raw files
-rw-r--r--ps05_pattern_matching/ghelper.scm102
-rw-r--r--ps05_pattern_matching/load.scm2
-rw-r--r--ps05_pattern_matching/matcher.scm176
-rw-r--r--ps05_pattern_matching/ps.txt791
4 files changed, 1071 insertions, 0 deletions
diff --git a/ps05_pattern_matching/ghelper.scm b/ps05_pattern_matching/ghelper.scm
new file mode 100644
index 0000000..7b8613d
--- /dev/null
+++ b/ps05_pattern_matching/ghelper.scm
@@ -0,0 +1,102 @@
+;;;; Most General Generic-Operator Dispatch
+
+(declare (usual-integrations))
+
+;;; Generic-operator dispatch is implemented here by a discrimination
+;;; list, where the arguments passed to the operator are examined by
+;;; predicates that are supplied at the point of attachment of a
+;;; handler (by ASSIGN-OPERATION).
+
+;;; To be the correct branch all arguments must be accepted by
+;;; the branch predicates, so this makes it necessary to
+;;; backtrack to find another branch where the first argument
+;;; is accepted if the second argument is rejected. Here
+;;; backtracking is implemented by OR.
+
+(define (make-generic-operator arity default-operation)
+ (let ((record (make-operator-record arity)))
+
+ (define (operator . arguments)
+ (if (not (= (length arguments) arity))
+ (error:wrong-number-of-arguments operator arity arguments))
+ (let ((succeed
+ (lambda (handler)
+ (apply handler arguments))))
+ (let per-arg
+ ((tree (operator-record-tree record))
+ (args arguments)
+ (fail
+ (lambda ()
+ (error:no-applicable-methods operator arguments))))
+ (let per-pred ((tree tree) (fail fail))
+ (cond ((pair? tree)
+ (if ((caar tree) (car args))
+ (if (pair? (cdr args))
+ (per-arg (cdar tree)
+ (cdr args)
+ (lambda ()
+ (per-pred (cdr tree) fail)))
+ (succeed (cdar tree)))
+ (per-pred (cdr tree) fail)))
+ ((null? tree)
+ (fail))
+ (else
+ (succeed tree)))))))
+
+ (hash-table/put! *generic-operator-table* operator record)
+ (if default-operation
+ (assign-operation operator default-operation))
+ operator))
+
+(define *generic-operator-table*
+ (make-eq-hash-table))
+
+(define (make-operator-record arity) (cons arity '()))
+(define (operator-record-arity record) (car record))
+(define (operator-record-tree record) (cdr record))
+(define (set-operator-record-tree! record tree) (set-cdr! record tree))
+
+(define (assign-operation operator handler . argument-predicates)
+ (let ((record
+ (let ((record (hash-table/get *generic-operator-table* operator #f))
+ (arity (length argument-predicates)))
+ (if record
+ (begin
+ (if (not (<= arity (operator-record-arity record)))
+ (error "Incorrect operator arity:" operator))
+ record)
+ (let ((record (make-operator-record arity)))
+ (hash-table/put! *generic-operator-table* operator record)
+ record)))))
+ (set-operator-record-tree! record
+ (bind-in-tree argument-predicates
+ handler
+ (operator-record-tree record))))
+ operator)
+
+(define defhandler assign-operation)
+
+(define (bind-in-tree keys handler tree)
+ (let loop ((keys keys) (tree tree))
+ (if (pair? keys)
+ (let find-key ((tree* tree))
+ (if (pair? tree*)
+ (if (eq? (caar tree*) (car keys))
+ (begin
+ (set-cdr! (car tree*)
+ (loop (cdr keys) (cdar tree*)))
+ tree)
+ (find-key (cdr tree*)))
+ (cons (cons (car keys)
+ (loop (cdr keys) '()))
+ tree)))
+ (if (pair? tree)
+ (let ((p (last-pair tree)))
+ (if (not (null? (cdr p)))
+ (warn "Replacing a handler:" (cdr p) handler))
+ (set-cdr! p handler)
+ tree)
+ (begin
+ (if (not (null? tree))
+ (warn "Replacing top-level handler:" tree handler))
+ handler))))) \ No newline at end of file
diff --git a/ps05_pattern_matching/load.scm b/ps05_pattern_matching/load.scm
new file mode 100644
index 0000000..c765ea2
--- /dev/null
+++ b/ps05_pattern_matching/load.scm
@@ -0,0 +1,2 @@
+(load "ghelper")
+(load "matcher")
diff --git a/ps05_pattern_matching/matcher.scm b/ps05_pattern_matching/matcher.scm
new file mode 100644
index 0000000..371a88f
--- /dev/null
+++ b/ps05_pattern_matching/matcher.scm
@@ -0,0 +1,176 @@
+;;;; Matcher based on match combinators, CPH/GJS style.
+;;; Idea is in Hewitt's PhD thesis (1969).
+
+(declare (usual-integrations))
+
+;;; There are match procedures that can be applied to data items. A
+;;; match procedure either accepts or rejects the data it is applied
+;;; to. Match procedures can be combined to apply to compound data
+;;; items.
+
+;;; A match procedure takes a list containing a data item, a
+;;; dictionary, and a success continuation. The dictionary
+;;; accumulates the assignments of match variables to values found in
+;;; the data. The success continuation takes two arguments: the new
+;;; dictionary, and the number of items absorbed from the list by the
+;;; match. If a match procedure fails it returns #f.
+
+;;; Primitive match procedures:
+
+(define (match:eqv pattern-constant)
+ (define (eqv-match data dictionary succeed)
+ (and (pair? data)
+ (eqv? (car data) pattern-constant)
+ (succeed dictionary 1)))
+ eqv-match)
+
+(define (match:element variable)
+ (define (element-match data dictionary succeed)
+ (and (pair? data)
+ (let ((vcell (match:lookup variable dictionary)))
+ (if vcell
+ (and (equal? (match:value vcell) (car data))
+ (succeed dictionary 1))
+ (succeed (match:bind variable (car data) dictionary)
+ 1)))))
+ element-match)
+
+
+;;; Support for the dictionary.
+
+(define (match:bind variable data-object dictionary)
+ (cons (list variable data-object) dictionary))
+
+(define (match:lookup variable dictionary)
+ (assq variable dictionary))
+
+(define (match:value vcell)
+ (cadr vcell))
+
+(define (match:segment variable)
+ (define (segment-match data dictionary succeed)
+ (and (list? data)
+ (let ((vcell (match:lookup variable dictionary)))
+ (if vcell
+ (let lp ((data data)
+ (pattern (match:value vcell))
+ (n 0))
+ (cond ((pair? pattern)
+ (if (and (pair? data)
+ (equal? (car data) (car pattern)))
+ (lp (cdr data) (cdr pattern) (+ n 1))
+ #f))
+ ((not (null? pattern)) #f)
+ (else (succeed dictionary n))))
+ (let ((n (length data)))
+ (let lp ((i 0))
+ (if (<= i n)
+ (or (succeed (match:bind variable
+ (list-head data i)
+ dictionary)
+ i)
+ (lp (+ i 1)))
+ #f)))))))
+ segment-match)
+
+(define (match:list . match-combinators)
+ (define (list-match data dictionary succeed)
+ (and (pair? data)
+ (let lp ((data (car data))
+ (matchers match-combinators)
+ (dictionary dictionary))
+ (cond ((pair? matchers)
+ ((car matchers) data dictionary
+ (lambda (new-dictionary n)
+ (if (> n (length data))
+ (error "Matcher ate too much." n))
+ (lp (list-tail data n)
+ (cdr matchers)
+ new-dictionary))))
+ ((pair? data) #f)
+ ((null? data)
+ (succeed dictionary 1))
+ (else #f)))))
+ list-match)
+
+;;; Syntax of matching is determined here.
+
+(define (match:element? pattern)
+ (and (pair? pattern)
+ (eq? (car pattern) '?)))
+
+(define (match:segment? pattern)
+ (and (pair? pattern)
+ (eq? (car pattern) '??)))
+
+(define (match:variable-name pattern)
+ (cadr pattern))
+
+(define (match:list? pattern)
+ (and (list? pattern)
+ (not (memq (car pattern) '(? ??)))))
+
+
+(define match:->combinators
+ (make-generic-operator 1 match:eqv))
+
+(defhandler match:->combinators
+ (lambda (pattern) (match:element (match:variable-name pattern)))
+ match:element?)
+
+(defhandler match:->combinators
+ (lambda (pattern) (match:segment (match:variable-name pattern)))
+ match:segment?)
+
+(defhandler match:->combinators
+ (lambda (pattern)
+ (apply match:list (map match:->combinators pattern)))
+ match:list?)
+
+
+(define (matcher pattern)
+ (let ((match-combinator (match:->combinators pattern)))
+ (lambda (datum)
+ (match-combinator
+ (list datum)
+ '()
+ (lambda (dictionary number-of-items-eaten)
+ (and (= number-of-items-eaten 1)
+ dictionary))))))
+
+#|
+((match:->combinators '(a ((? b) 2 3) 1 c))
+ '((a (1 2 3) 1 c))
+ '()
+ (lambda (x y) `(succeed ,x ,y)))
+;Value: (succeed ((b 1)) 1)
+
+((match:->combinators '(a ((? b) 2 3) (? b) c))
+ '((a (1 2 3) 2 c))
+ '()
+ (lambda (x y) `(succeed ,x ,y)))
+;Value: #f
+
+((match:->combinators '(a ((? b) 2 3) (? b) c))
+ '((a (1 2 3) 1 c))
+ '()
+ (lambda (x y) `(succeed ,x ,y)))
+;Value: (succeed ((b 1)) 1)
+
+
+((match:->combinators '(a (?? x) (?? y) (?? x) c))
+ '((a b b b b b b c))
+ '()
+ (lambda (x y)
+ (pp `(succeed ,x ,y))
+ #f))
+(succeed ((y (b b b b b b)) (x ())) 1)
+(succeed ((y (b b b b)) (x (b))) 1)
+(succeed ((y (b b)) (x (b b))) 1)
+(succeed ((y ()) (x (b b b))) 1)
+;Value: #f
+
+((matcher '(a ((? b) 2 3) (? b) c))
+ '(a (1 2 3) 1 c))
+;Value: ((b 1))
+|# \ No newline at end of file
diff --git a/ps05_pattern_matching/ps.txt b/ps05_pattern_matching/ps.txt
new file mode 100644
index 0000000..3f568a9
--- /dev/null
+++ b/ps05_pattern_matching/ps.txt
@@ -0,0 +1,791 @@
+
+ MASSACHVSETTS INSTITVTE OF TECHNOLOGY
+ Department of Electrical Engineering and Computer Science
+
+ 6.945 Spring 2009
+ Problem Set 5
+
+ Issued: Wed. 4 March 2009 Due: Wed. 11 March 2009
+
+
+Reading: SICP Section 4.4, especially 4.4.4.3 and 4.4.4.4
+
+Code: load.scm, ghelper.scm (same as before), matcher.scm (attached)
+
+ Pattern Matching and Instantiation
+
+One of the most important techniques in advanced symbolic programming
+is the use of patterns. We can match patterns against data objects,
+and we can instantiate a pattern to make a data object. For example,
+the elementary laws of algebra are usually expressed as patterns and
+instantiations:
+
+ a * (b + c) <==> a * b + a * c
+
+This is the distributive law of multiplication over addition. It says
+that we can replace one side with the other without changing the value
+of the expression. Each side of the law is a pattern, with particular
+pattern variables a, b, c, and pattern constants *, +. More
+precisely, what the law says is that if we find an algebraic
+expression that is the product of something and a sum of terms, we can
+replace it with a sum of two products, and vice versa.
+
+In this problem set we will investigate how to organize programs based
+on pattern-match. A key idea will be compilation of patterns into
+combinators that are the pieces of a matcher. In the next problem set
+we will study building this into a simple rule system.
+
+
+ A Language of Patterns
+
+The first job is to make up our language of patterns. We will start
+with something simple. We will make our patterns out of Lisp (Scheme)
+lists. Unlike the mathematical example above, we will not have
+reserved symbols, such as * and +, so we will have to distinguish
+pattern variables from pattern constants. Pattern variables can be
+represented by lists beginning with the query symbol: "?". This is a
+traditional choice. So in this language the patterns that make up the
+distributive law may be represented as follows, assuming that we are
+manipulating Lisp prefix mathematical expressions:
+
+ (* (? a) (+ (? b) (? c)))
+
+ (+ (* (? a) (? b)) (* (? a) (? c)))
+
+You might complain that we could have used distinguished symbols, such
+as "?a" instead of the long-winded (? a). That would be fine, but
+that choice will make it a bit harder to extend, say if we want a
+variable that is restricted to match only numbers. Of course, we can
+add syntax later if it is helpful, but remember Alan Perlis's maxim:
+"Syntactic sugar causes cancer of the semicolon."
+
+One constraint on our design of the matcher is that the second pattern
+above should match
+
+ (+ (* (cos x) (exp y)) (* (cos x) (sin z)))
+
+where a=(cos x), b=(exp y), and c=(sin z). It should not match
+
+ (+ (* (cos x) (exp y)) (* (cos (+ x y)) (sin z)))
+
+because there is no consistent assignment possible for (? a) (unless,
+somehow x=x+y. We will learn about that sort of stuff later when
+we study unification matching. Here we will decide that there is no
+match possible.)
+
+Another constraint, which will have important influence on the
+structure of the matcher, is the requirement for "segment variables."
+Suppose we want to find instances of particular patterns in a sequence
+of many terms. For example, suppose we want to make a rule to find
+combinations of squares of sines and cosines and replace them with 1:
+
+ (+ ... (expt (sin theta) 2) ... (expt (cos theta) 2) ...)
+
+ ==> (+ 1 ... ... ...)
+
+The "..." here may stand for many terms. We will need segment
+variables, with the prefix "??" that can match many terms, so the
+pattern we will write is:
+
+ (+ (?? t1) (expt (sin (? x)) 2) (?? t2) (expt (cos (? x)) 2) (?? t3))
+
+ ==> (+ 1 (?? t1) (?? t2) (?? t3))
+
+Segment variables have a profound effect, because we don't know how
+long a segment is until we find the next part that matches, and we may
+be able to match the same data item many ways. For example, there may
+be both squares of sines and cosines of angles theta and phi in the
+same sum. Even simpler, the pattern
+
+ (a (?? x) (?? y) (?? x) c)
+
+can match the datum
+
+ (a b b b b b b c)
+
+in four different ways. (Notice that the segment variable x must eat
+up the same number of "b"s in the two places it appears in the
+pattern.) So the matcher must do a search over the space of possible
+assignments to the segment variables.
+
+ Design of the Matcher
+
+A matcher for a particular pattern is constructed from a family of
+mix-and-match combinators that can be combined to make combinators of
+the same type. Each primitive element of the pattern is represented
+by a primitive combinator and the only combination, list, is
+represented by a combinator that combines combinators to make a
+compound one.
+
+The match combinators are procedures that take three arguments: data
+to be matched, a dictionary of bindings of pattern variables, and a
+procedure to be called if the match is successful. The arguments to
+the succeed procedure must be the new dictionary resulting from the
+match and the number of data items eaten from the input data by this
+matcher. A match combinator returns #f if the match is unsuccessful.
+
+In general, a match combinator that is expected to match a single
+object, such as a symbol or a list, will eat the car of the data given
+to it and report that it ate one thing. However, a segment matcher
+may eat more than one thing, and it must report the number it ate.
+There are four basic match combinators. Let's go through them one by
+one.
+
+
+The match procedure match:eqv takes a pattern constant and produces a
+match combinator. It succeeds if and only if the data is a pair whose
+car is equal (using eqv?) to the pattern constant. If successful, it
+does not add to the dictionary and absorbs one item from the data.
+
+(define (match:eqv pattern-constant)
+ (define (eqv-match data dictionary succeed)
+ (and (pair? data)
+ (eqv? (car data) pattern-constant)
+ (succeed dictionary 1)))
+ eqv-match)
+
+
+The match procedure match:element is used to make a match combinator
+for an ordinary pattern variable, such as (? x). Such a variable
+wants to eat up exactly one item from the input data. There are
+two cases. If the variable already has a value in the dictionary the
+combinator succeeds only if the value is equal (using equal?) to the
+car of the data. If the variable has no value, the combinator
+succeeds with the new dictionary resulting from binding the variable
+to the car of the data in the given dictionary.
+
+(define (match:element variable)
+ (define (element-match data dictionary succeed)
+ (and (pair? data)
+ (let ((vcell (match:lookup variable dictionary)))
+ (if vcell
+ (and (equal? (match:value vcell) (car data))
+ (succeed dictionary 1))
+ (succeed (match:bind variable (car data) dictionary)
+ 1)))))
+ element-match)
+
+A segment variable procedure makes a more interesting combinator.
+
+(define (match:segment variable)
+ (define (segment-match data dictionary succeed)
+ (and (list? data)
+ (let ((vcell (match:lookup variable dictionary)))
+ (if vcell
+ (let lp ((data data)
+ (pattern (match:value vcell))
+ (n 0))
+ (cond ((pair? pattern)
+ (if (and (pair? data)
+ (equal? (car data) (car pattern)))
+ (lp (cdr data) (cdr pattern) (+ n 1))
+ #f))
+ ((not (null? pattern)) #f)
+ (else (succeed dictionary n))))
+ (let ((n (length data)))
+ (let lp ((i 0))
+ (if (<= i n)
+ (or (succeed (match:bind variable
+ (list-head data i)
+ dictionary)
+ i)
+ (lp (+ i 1)))
+ #f)))))))
+ segment-match)
+
+Here the input data must be a list, so we can compute its length.
+Again, there are two possibilities, either the variable already has a
+value or it does not yet have a value. If it has a value, each item
+of the value must be the same as a corresponding item from the data.
+If this is true, the match succeeds, eating a number of items from the
+input data equal to the number in the stored value. If the segment
+variable does not yet have a value it must be given one. The
+segment-variable match combinator starts by assuming that the segment
+will eat no items from the data. However, if that success ultimately
+leads to a later failure in the match, the segment tries to eat one
+more element than it had already tried. (This is accomplished by
+executing (lp (+ i 1)).) If the segment variable runs out of data
+items, it fails to match.
+
+Finally, there is the list matcher:
+
+(define (match:list . match-combinators)
+ (define (list-match data dictionary succeed)
+ (and (pair? data)
+ (let lp ((data (car data))
+ (matchers match-combinators)
+ (dictionary dictionary))
+ (cond ((pair? matchers)
+ ((car matchers) data dictionary
+ (lambda (new-dictionary n)
+ (lp (list-tail data n)
+ (cdr matchers)
+ new-dictionary))))
+ ((pair? data) #f)
+ (else (succeed dictionary 1))))))
+ list-match)
+
+The list match procedure takes match combinators and makes a list
+combinator that matches a list, which is the car of the given data, if
+and only if the given match combinators eat up all of the elements in
+the data list. It applies the combinators in succession. When a
+match combinator succeeds it tells the list combinator how many items
+to jump over before passing the result to the next combinator. Notice
+that the list combinator has exactly the same interface as the other
+three, allowing it to be incorporated into a combination.
+
+
+
+
+The dictionary we will use is just an alist of variable-value pairs:
+
+(define (match:bind variable data-object dictionary)
+ (cons (list variable data-object) dictionary))
+
+(define (match:lookup variable dictionary)
+ (assq variable dictionary))
+
+(define (match:value vcell)
+ (cadr vcell))
+
+
+
+
+ Using Match Combinators
+
+For example, we can make a combinator that matches a list of any
+number of elements, starting with the symbol a, ending with the symbol
+b, and with a segment variable (?? x) between them by the combination:
+
+ (match:list (match:eqv 'a) (match:segment 'x) (match:eqv 'b))
+
+We can apply it to data. The initial dictionary is the empty list.
+
+((match:list (match:eqv 'a) (match:segment 'x) (match:eqv 'b))
+ '((a 1 2 b))
+ '()
+ list)
+;Value: ((x (1 2)) 1)
+
+This was a successful match.
+The dictionary returned has exactly one entry: x=(1 2).
+The match ate exactly one element, the list (a 1 2 b) from the input.
+
+((match:list (match:eqv 'a) (match:segment 'x) (match:eqv 'b))
+ '((a 1 2 b 3))
+ '()
+ (lambda (d n) d))
+;Value: #f
+
+This was a failure, because there was nothing to match the 3 after the
+b in the input data.
+
+We can automate the construction of pattern matchers from patterns
+with an elementary compiler. First, we need to define the syntax.
+
+(define (match:element? pattern)
+ (and (pair? pattern)
+ (eq? (car pattern) '?)))
+
+(define (match:segment? pattern)
+ (and (pair? pattern)
+ (eq? (car pattern) '??)))
+
+(define (match:variable-name pattern)
+ (cadr pattern))
+
+(define (match:list? pattern)
+ (and (list? pattern)
+ (not (memq (car pattern) '(? ??)))))
+
+List syntax is any list that does not begin with a variable
+declaration.
+
+The compiler itself is just a generic operator.
+
+(define match:->combinators (make-generic-operator 1 match:eqv))
+
+(defhandler match:->combinators
+ (lambda (pattern) (match:element (match:variable-name pattern)))
+ match:element?)
+
+(defhandler match:->combinators
+ (lambda (pattern) (match:segment (match:variable-name pattern)))
+ match:segment?)
+
+(defhandler match:->combinators
+ (lambda (pattern)
+ (apply match:list (map match:->combinators pattern)))
+ match:list?)
+
+By varying this compiler, we can change the syntax of patterns any way
+we like.
+
+The compiler produces as its value a match combinator appropriate for
+the pattern it is given: it has exactly the same interface as the
+elementary combinators given. Some simple examples are:
+
+ ((match:->combinators '(a ((? b) 2 3) (? b) c))
+ '((a (1 2 3) 2 c))
+ '()
+ (lambda (x y) `(succeed ,x ,y)))
+ ;Value: #f
+
+ ((match:->combinators '(a ((? b) 2 3) (? b) c))
+ '((a (1 2 3) 1 c))
+ '()
+ (lambda (x y) `(succeed ,x ,y)))
+ ;Value: (succeed ((b 1)) 1)
+
+Some patterns involving segment variables may match in many ways. We
+can elicit all of the matches by failing back into the matcher to
+select the next one, until they are all exhausted:
+
+ ((match:->combinators '(a (?? x) (?? y) (?? x) c))
+ '((a b b b b b b c))
+ '()
+ (lambda (dict y)
+ (pp `(succeed ,dict ,y))
+ #f))
+ (succeed ((y (b b b b b b)) (x ())) 1)
+ (succeed ((y (b b b b)) (x (b))) 1)
+ (succeed ((y (b b)) (x (b b))) 1)
+ (succeed ((y ()) (x (b b b))) 1)
+ ;Value: #f
+
+-------------
+Problem 3.1:
+
+In the example above we got multiple matches, by returning #f from a
+success procedure. This is probably pretty mysterious. How does it
+work? Explain, in a short but concise paragraph, how the sequence of
+matches is generated.
+-------------
+
+This interface is not very nice for using the matcher. It is
+convenient for building into other systems that need this flexibility.
+However, for playing with the matcher it is convenient to use:
+
+ (define (matcher pattern)
+ (let ((match-combinator (match:->combinators pattern)))
+ (lambda (datum)
+ (match-combinator
+ (list datum)
+ '()
+ (lambda (dictionary number-of-items-eaten)
+ (and (= number-of-items-eaten 1)
+ dictionary))))))
+
+With this interface we explicitly give the pattern to get the matcher
+procedure. We give the matcher procedure the datum the pattern is to
+match, and we get either a dictionary or #f.
+
+((matcher '(a ((? b) 2 3) (? b) c))
+ '(a (1 2 3) 1 c))
+;Value: ((b 1))
+
+
+Quite often we want to restrict the kind of object that can be matched
+by a pattern variable. For example, we may want to make a pattern
+where a variable can only match a positive integer. For example, we
+may be interested in finding positive integer powers of sine
+functions. We could write the pattern we want as follows:
+
+ (expt (sin (? x)) (? n exact-positive-integer?))
+
+But there are a number of complications here, not the least of which
+is that the symbols expt and sin are pattern constants, but the symbol
+exact-positive-integer? must be evaluated to a procedure. Let's worry
+about that later. First we need a matcher procedure that can be used
+to make a matcher combinator satisfying this requirement. One way to
+do this is to make match:element take an extra argument, perhaps
+optional, which is the predicate for testing the datum for
+acceptability. Alternatively, we can make an entirely new matcher
+procedure, say match:element-restricted, which takes two arguments:
+the name of a variable and the restriction predicate. It should return
+an appropriate match combinator.
+
+-------------
+Problem 3.2:
+
+Choose one of these strategies and make a new matcher procedure or
+modify an existing matcher procedure so as to implement pattern
+variables with restrictions.
+
+Demonstrate your modification.
+-------------
+
+There is still this nasty problem of evaluation of the predicate
+expression with the compilation of the new matcher syntax, alluded to
+earlier (viz., exact-positive-integer? in the preceding problem
+example). One approach is to address the issue in the pattern
+specification. An alternative approach is to postpone addressing it
+when the patterns are compiled into the combinators.
+
+Specifically, we could specify the patterns using quasiquote (a.k.a.
+backquote) when specifying input patterns. For example,
+
+ `(a b ,(+ 20 3) d) --> (a b 23 d)
+
+Consult the MIT Scheme Reference Manual for details on QUASIQUOTE.
+
+Alternatively, one might invoke EVAL at pattern compile time (i.e.,
+within match:->combinators), postponing resolving the predicate name
+to its associated procedure until the point where the combinator is
+generated. For example,
+
+ (eval 'integer? user-initial-environment)
+
+returns the procedure named by the symbol "integer?".
+
+One might also contemplate a point-of-use case where the predicate
+symbol is not resolved until it is actually needed within the
+invocation of each generated combinator. This does not lead to a
+pretty solution.
+
+-------------
+Problem 3.3:
+
+How do you want to solve this problem? One way is to use the
+quasiquote mechanism built into Scheme (and every other Lisp).
+Another way is to do an explicit evaluation in the compiler. I (GJS)
+like the first way. Explain how this works, and demonstrate it on a
+real problem.
+
+Explain the considerations you used to make your choice. Feel free to
+propose (and implement) other alternatives.
+-------------
+
+ Choice is Good
+
+Another interesting way to extend our pattern language is to introduce
+a choice operator:
+
+ (?:choice <pattern>...)
+
+This should compile into a combinator that tries to match each of the
+(possibly null) list of <pattern>s in order from left to right,
+returning the first successful match or #f if none match. (This
+should remind you of regular expression "alternation" but the choice
+of the name "choice" is more traditional in pattern matching.)
+
+For example:
+
+((match:->combinators '(?:choice a b (? x) c))
+ '(z)
+ '()
+ (lambda (d n) `(succeed ,d ,n)))
+;Value: (succeed ((x z)) 1)
+
+((match:->combinators `((? y) (?:choice a b (? x ,string?) (? y ,symbol?) c)))
+ '((z z))
+ '()
+ (lambda (d n) `(succeed ,d ,n)))
+;Value: (succeed ((y z)) 1)
+
+((match:->combinators `(?:choice b (? x ,symbol?)))
+ '(b)
+ '()
+ (lambda (x y)
+ (pp `(succeed ,x ,y))
+ #f))
+(succeed () 1)
+(succeed ((x b)) 1)
+;Value: #f
+
+-------------
+Problem 3.4:
+
+Implement a new matcher procedure, match:choice, for this new pattern schema.
+Augment the pattern compiler appropriately.
+
+As always, demonstrate your code on the examples provided and on a couple of
+your own, both positive and negative boundary cases.
+-------------
+
+ Naming is Better
+
+Another extension is to provide named patterns, analogous to Scheme's LETREC.
+
+Naming allows shorter, more modular patterns while also supporting recursive
+sub-patterns, including mutually recursive sub-patterns.
+
+For instance, the pattern:
+
+ (?:pletrec ((odd-even-etc (?:choice () (1 (?:ref even-odd-etc))))
+ (even-odd-etc (?:choice () (2 (?:ref odd-even-etc)))))
+ (?:ref odd-even-etc))
+
+...should match all lists of the following form (including the empty list):
+
+ (1 (2 (1 (2 (1 (... ())...)))))
+
+Here, ?:PLETREC introduces a block of mutually recursive pattern definitions
+while ?:REF dereferences a defined pattern in place (in order to distinguish
+them from literal symbols like "a" and from pattern variables like "(? x)").
+
+In a proper environment-based LETREC-like implementation, nested ?:PLETREC
+instances would introduce distinct contour lines for scoping. You needn't
+worry about that here. Specifically, just as pattern variables all share a
+common global namespace, so too can your pattern definitions.
+
+To wit, notice how the pattern combinators traverse the pattern and data in
+left-to-right depth first order, binding the first textual appearance of each
+distinct pattern variable (like "(? x)") to its corresponding datum then
+treating each subsequent textual appearance in the pattern as a constraining
+instance. This is achieved by threading the dictionary through the depth-first
+control path. Pay particular attention to the appearance of NEW-DICTIONARY in
+the body of MATCH:LIST.
+
+This, in essence, decrees the leftmost, deepest instance of each unique pattern
+variable to be a defining instance in an implicit flat global namespace with
+all subsequent downstream appearances being constraining instances.
+
+Feel free to make PLETREC behave similarly rather than rewrite all the existing
+combinator interfaces to accept an extra PATTERN-ENVIRONMENT parameter, or
+whatever.
+
+-------------
+Problem 3.5
+
+Implement these new PLETREC and REF pattern schemata. One approach is
+to implement new matcher procedures, match:pletrec and match:ref, then
+augment the pattern compiler appropriately. Other approaches may also
+work. Explain your approach briefly if it is subtle or non-obvious.
+
+As always, demonstrate your code on the examples provided and on a
+couple of your own, both positive and negative boundary cases.
+-------------
+
+ Anonymity is Best
+
+Finally, it is handy to be able to restrict a match sub-expression without
+having to name it.
+
+For example:
+
+ (?:pletrec ((btos
+ (?:choice ()
+ (?:restrict ,symbol?)
+ ((?:ref btos) (?:ref btos)))))
+ (binary tree of symbols: (?:ref btos)))
+
+...should be able to match each of:
+
+ (binary tree of symbols: ())
+ (binary tree of symbols: (a b))
+ (binary tree of symbols: ((a b) (c ())))
+
+...but none of:
+
+ (binary tree of symbols: (a))
+ (binary tree of symbols: ((a b) (c)))
+ (binary tree of symbols: (a 2))
+
+
+-------------
+Problem 3.6
+
+Implement a new matcher procedure, match:restrict, for this new pattern schema.
+Augment the pattern compiler appropriately.
+
+As always, demonstrate your code on the examples provided and on a couple of
+your own, both positive and negative boundary cases.
+-------------
+
+
+ A Potential Project
+
+The matcher we have is still not a complete language, in that it does
+not support namespace scoping and parametric patterns. For example,
+we cannot write the following pattern, even though it is obvious what
+it means:
+
+ (?:pletrec ((palindrome
+ (?:pnew (x)
+ (?:choice ()
+ ((? x ,symbol?)
+ (?:ref palindrome)
+ (? x))))))
+ (?:ref palindrome))
+
+This pattern is intended to match only lists of symbols that are
+palindromes. For this to work in any reasonable way ?:pnew creates
+fresh lexically-scoped pattern variables that can be referred to only
+in the body of the ?:pnew.
+
+A fully-worked out pattern language is a neat subsystem to have, but
+it is not entirely trivial to build. As you will see later, there are
+also "semantic matchers" that know something about the constants in a
+data item. One possible nice project is to flesh out these ideas and
+produce a full pattern language.
+
+;;;; Matcher based on match combinators, CPH/GJS style.
+;;; Idea is in Hewitt's PhD thesis (1969).
+
+(declare (usual-integrations))
+
+;;; There are match procedures that can be applied to data items. A
+;;; match procedure either accepts or rejects the data it is applied
+;;; to. Match procedures can be combined to apply to compound data
+;;; items.
+
+;;; A match procedure takes a list containing a data item, a
+;;; dictionary, and a success continuation. The dictionary
+;;; accumulates the assignments of match variables to values found in
+;;; the data. The success continuation takes two arguments: the new
+;;; dictionary, and the number of items absorbed from the list by the
+;;; match. If a match procedure fails it returns #f.
+
+;;; Primitive match procedures:
+
+(define (match:eqv pattern-constant)
+ (define (eqv-match data dictionary succeed)
+ (and (pair? data)
+ (eqv? (car data) pattern-constant)
+ (succeed dictionary 1)))
+ eqv-match)
+
+(define (match:element variable)
+ (define (element-match data dictionary succeed)
+ (and (pair? data)
+ (let ((vcell (match:lookup variable dictionary)))
+ (if vcell
+ (and (equal? (match:value vcell) (car data))
+ (succeed dictionary 1))
+ (succeed (match:bind variable (car data) dictionary)
+ 1)))))
+ element-match)
+
+
+;;; Support for the dictionary.
+
+(define (match:bind variable data-object dictionary)
+ (cons (list variable data-object) dictionary))
+
+(define (match:lookup variable dictionary)
+ (assq variable dictionary))
+
+(define (match:value vcell)
+ (cadr vcell))
+
+(define (match:segment variable)
+ (define (segment-match data dictionary succeed)
+ (and (list? data)
+ (let ((vcell (match:lookup variable dictionary)))
+ (if vcell
+ (let lp ((data data)
+ (pattern (match:value vcell))
+ (n 0))
+ (cond ((pair? pattern)
+ (if (and (pair? data)
+ (equal? (car data) (car pattern)))
+ (lp (cdr data) (cdr pattern) (+ n 1))
+ #f))
+ ((not (null? pattern)) #f)
+ (else (succeed dictionary n))))
+ (let ((n (length data)))
+ (let lp ((i 0))
+ (if (<= i n)
+ (or (succeed (match:bind variable
+ (list-head data i)
+ dictionary)
+ i)
+ (lp (+ i 1)))
+ #f)))))))
+ segment-match)
+
+(define (match:list . match-combinators)
+ (define (list-match data dictionary succeed)
+ (and (pair? data)
+ (let lp ((data (car data))
+ (matchers match-combinators)
+ (dictionary dictionary))
+ (cond ((pair? matchers)
+ ((car matchers) data dictionary
+ (lambda (new-dictionary n)
+ (if (> n (length data))
+ (error "Matcher ate too much." n))
+ (lp (list-tail data n)
+ (cdr matchers)
+ new-dictionary))))
+ ((pair? data) #f)
+ ((null? data)
+ (succeed dictionary 1))
+ (else #f)))))
+ list-match)
+
+;;; Syntax of matching is determined here.
+
+(define (match:->combinators pattern)
+ (define (compile pattern)
+ (cond ((match:element? pattern)
+ (match:element (match:variable-name pattern)))
+ ((match:segment? pattern)
+ (match:segment (match:variable-name pattern)))
+ ((list? pattern)
+ (apply match:list (map compile pattern)))
+ (else (match:eqv pattern))))
+ (compile pattern))
+
+
+
+(define (match:element? pattern)
+ (and (pair? pattern)
+ (eq? (car pattern) '?)))
+
+(define (match:segment? pattern)
+ (and (pair? pattern)
+ (eq? (car pattern) '??)))
+
+(define (match:variable-name pattern)
+ (cadr pattern))
+
+
+
+(define (matcher pattern)
+ (let ((match-combinator (match:->combinators pattern)))
+ (lambda (datum)
+ (match-combinator
+ (list datum)
+ '()
+ (lambda (dictionary number-of-items-eaten)
+ (and (= number-of-items-eaten 1)
+ dictionary))))))
+
+#|
+((match:->combinators '(a ((? b) 2 3) 1 c))
+ '((a (1 2 3) 1 c))
+ '()
+ (lambda (x y) `(succeed ,x ,y)))
+;Value: (succeed ((b 1)) 1)
+
+((match:->combinators '(a ((? b) 2 3) (? b) c))
+ '((a (1 2 3) 2 c))
+ '()
+ (lambda (x y) `(succeed ,x ,y)))
+;Value: #f
+
+((match:->combinators '(a ((? b) 2 3) (? b) c))
+ '((a (1 2 3) 1 c))
+ '()
+ (lambda (x y) `(succeed ,x ,y)))
+;Value: (succeed ((b 1)) 1)
+
+
+((match:->combinators '(a (?? x) (?? y) (?? x) c))
+ '((a b b b b b b c))
+ '()
+ (lambda (x y)
+ (pp `(succeed ,x ,y))
+ #f))
+(succeed ((y (b b b b b b)) (x ())) 1)
+(succeed ((y (b b b b)) (x (b))) 1)
+(succeed ((y (b b)) (x (b b))) 1)
+(succeed ((y ()) (x (b b b))) 1)
+;Value: #f
+
+((matcher '(a ((? b) 2 3) (? b) c))
+ '(a (1 2 3) 1 c))
+;Value: ((b 1))
+|#