MASSACHVSETTS INSTITVTE OF TECHNOLOGY
Department of Electrical Engineering and Computer Science
6.945 Spring 2009
Problem Set 6
Issued: Wed. 11 Mar. 2009 Due: Wed. 18 Mar. 2009
Reading: MIT Scheme Reference Manual, section 2.11: Macros
This is complicated stuff, so don't try to read it until you
need to in the compilation part of the problem set.
Code: load.scm, rule-compiler.scm, matcher.scm, rule-simplifier.scm,
rules.scm, all attached.
Pattern Matching and Instantiation, continued
In this problem set we extend our pattern matching system to build a
primitive algebraic simplifier, based on pattern matching and
instantiation.
In rules.scm there are two elementary rule systems. A rule has three
parts: a pattern to match a subexpression, a predicate expression that
must be true for the rule to be applicable, and a skeleton to be
instantiated and replace the matched subexpression.
The rules are assembled into a list and handed to the rule-simplifier
procedure. The result is a simplifier procedure that can be applied
to an algebraic expression.
The first rule system demonstrates only elementary features. It does
not use segment variables or restricted variables. The first system
has three rules: The first rule implements the associative law of
addition, the second implements the commutative law of multiplication,
and the third implements the distributive law of multiplication over
addition.
The commutative law looks like:
(rule (* (? b) (? a))
(expr
(rule:make
(match:list (match:eqv (quote *))
(match:segment (quote a))
(match:element (quote y))
(match:element (quote x))
(match:segment (quote b)))
(lambda (b x y a)
(expr a 3)
(+ (+ (? a) (? b)) (? c)) )
(the-environment)))
(rule:make
(match:list
(match:eqv (quote +))
(match:element (quote a))
(match:list (match:eqv (quote +))
(match:element (quote b))
(match:element (quote c))))
(lambda (c b a)
(> a 3))
(lambda (c b a)
(list (quote +) (list (quote +) a b) c)))
|#
;;;; 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)
;;; Here we have added an optional restriction argument to allow
;;; conditional matches.
(define (match:element variable #!optional restriction?)
(if (default-object? restriction?)
(set! restriction? (lambda (x) #t)))
(define (element-match data dictionary succeed)
(and (pair? data)
;; NB: might be many distinct restrictions
(restriction? (car 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) '(? ??)))))
;;; These restrictions are for variable elements.
(define (match:restricted? pattern)
(not (null? (cddr pattern))))
(define (match:restriction pattern)
(caddr 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))
|#
;;;; File: rule-simplifier.scm
;;;; Match and Substitution Language Interpreter
(declare (usual-integrations))
;;; This is a descendent of the infamous 6.001 rule interpreter,
;;; originally written by GJS for a lecture in the faculty course held
;;; at MIT in the summer of 1983, and subsequently used and tweaked
;;; from time to time. This subsystem has been a serious pain in the
;;; ass, because of its expressive limitations, but I have not had the
;;; guts to seriously improve it since its first appearance. -- GJS
;;; January 2006. I have the guts now! The new matcher is based on
;;; combinators and is in matcher.scm. -- GJS
(define (rule-simplifier the-rules)
(define (simplify-expression expression)
(let ((simplified-subexpressions
(if (list? expression)
(map simplify-expression expression)
expression)))
(let ((result
(try-rules simplified-subexpressions the-rules)))
(if result
(simplify-expression result)
simplified-subexpressions))))
(rule-memoize simplify-expression))
(define (try-rules expression the-rules)
(define (scan rules)
(if (null? rules)
#f
(or ((car rules) expression)
(scan (cdr rules)))))
(scan the-rules))
;;;; Rule applicator, using combinator-based matcher.
(define (rule:make matcher restriction instantiator)
(define (the-rule expression)
(matcher (list expression)
'()
(lambda (dictionary n)
(and (= n 1)
(let ((args (map match:value dictionary)))
(and (or (not restriction)
(apply restriction args))
(apply instantiator args)))))))
the-rule)
;;; File: rules.scm -- Some sample algebraic simplification rules
(define algebra-1
(rule-simplifier
(list
;; Associative law of addition
(rule (+ (? a) (+ (? b) (? c)))
none
(+ (+ (? a) (? b)) (? c)))
;; Commutative law of multiplication
(rule (* (? b) (? a))
(expr nx ny) #f)
(else
(let lp ((x x) (y y))
(cond ((null? x) #f) ; same
((expr