From bcc309a5db2214ae2ebaab17c54f8d1f8833025b Mon Sep 17 00:00:00 2001
From: bnewbold <bnewbold@eta.mit.edu>
Date: Mon, 16 Mar 2009 13:50:28 -0400
Subject: ps06 raw

---
 ps06_rule_systems/ghelper.scm         | 102 +++++
 ps06_rule_systems/load.scm            |   8 +
 ps06_rule_systems/matcher.scm         | 195 +++++++++
 ps06_rule_systems/ps.txt              | 797 ++++++++++++++++++++++++++++++++++
 ps06_rule_systems/rule-compiler.scm   | 161 +++++++
 ps06_rule_systems/rule-simplifier.scm |  53 +++
 ps06_rule_systems/rules.scm           | 123 ++++++
 7 files changed, 1439 insertions(+)
 create mode 100644 ps06_rule_systems/ghelper.scm
 create mode 100644 ps06_rule_systems/load.scm
 create mode 100644 ps06_rule_systems/matcher.scm
 create mode 100644 ps06_rule_systems/ps.txt
 create mode 100644 ps06_rule_systems/rule-compiler.scm
 create mode 100644 ps06_rule_systems/rule-simplifier.scm
 create mode 100644 ps06_rule_systems/rules.scm

diff --git a/ps06_rule_systems/ghelper.scm b/ps06_rule_systems/ghelper.scm
new file mode 100644
index 0000000..7b8613d
--- /dev/null
+++ b/ps06_rule_systems/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/ps06_rule_systems/load.scm b/ps06_rule_systems/load.scm
new file mode 100644
index 0000000..62117c7
--- /dev/null
+++ b/ps06_rule_systems/load.scm
@@ -0,0 +1,8 @@
+(load "ghelper")
+(load "rule-compiler")
+(load "matcher")
+(load "rule-simplifier")
+
+(define (rule-memoize x) x)   ;;; NB:  Scaffolding stub for prob 4.5
+
+(load "rules")
\ No newline at end of file
diff --git a/ps06_rule_systems/matcher.scm b/ps06_rule_systems/matcher.scm
new file mode 100644
index 0000000..fdc9c7d
--- /dev/null
+++ b/ps06_rule_systems/matcher.scm
@@ -0,0 +1,195 @@
+;;;; 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)
+       (or (null? 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))
+|#
diff --git a/ps06_rule_systems/ps.txt b/ps06_rule_systems/ps.txt
new file mode 100644
index 0000000..449ce60
--- /dev/null
+++ b/ps06_rule_systems/ps.txt
@@ -0,0 +1,797 @@
+
+                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<? a b)
+          (* (? a) (? b)))
+
+Notice the rule-restriction predicate expression in the rule for the
+commutative law.  The restriction predicate expr<? imposes an ordering
+on algebraic expressions.
+
+-------------
+Problem 6.1:
+
+Why is the (expr<? a b) restriction necessary in the commutative law?
+What would go wrong if the there was no restriction? (Indicated by the
+symbol "none" in the restriction slot of the rule.)
+-------------
+
+
+The second system of rules is far more interesting.  It is built with
+the assumption that addition and multiplication are n-ary operations:
+it needs segment variables to make this work.  It also uses variable
+restrictions to allow rules for simplifying numerical terms and
+prefactors.
+-------------
+Problem 6.2:
+
+In the second system how does the use of the ordering on expressions
+imposed on the commutative laws make the numerical simplification
+rules effective?
+
+Suppose that the commutative laws did not force an ordering, how would
+we have to write the numerical simplification rules?  Explain why
+numerical simplification would become very expensive.
+-------------
+
+-------------
+Problem 6.3:
+
+The ordering in the commutative laws evolves an n^2 bubble sort on the
+terms of a sum and the factors of a product.  This can get pretty bad
+if there are many terms, as in a serious algebra problem.  Is there
+some way in this system to make a more efficient sort?  If not, why
+not?  If so, how would you arrange it?
+-------------
+
+-------------
+Problem 6.4:
+
+The system we have described does not collect like terms.  For example:
+
+(algebra-2 '(+ (* 4 x) (* 3 x)))
+;Value (+ (* 3 x) (* 4 x))
+
+Add rules that cause the collection of like terms, leaving the result
+as a sum of terms.  Demonstrate your solution.  Your solution must be
+able to handle problems like:
+
+(algebra-3
+  '(+ y (* x -2 w) (* x 4 y) (* w x) z (* 5 z) (* x w) (* x y 3)))
+;Value: (+ y (* 6 z) (* 7 x y))
+-------------
+
+Now that we have some experience with the use of such a rule system,
+let's dive in to see how it works.
+
+The center of the simplifier is in the file rule-simplifier.scm.  It
+is composed of three parts.  The first one, rule-simplifier, is a
+simple recursive simplifier constructor.  It produces a procedure,
+simplify-expression, that takes an expression and uses the rules to
+simplify the expression.  It recursively simplifies all the
+subexpressions of an expression, and then applies the rules to
+simplify the resulting expression.  It does this repeatedly until the
+process converges and the expression returned is a fixed point of the
+simplification process.
+
+     (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))
+
+
+The procedure rule-memoize may be thought of as an identity function:
+
+     (define (rule-memoize f) f)      ; CAVEAT:  Defined in "load.scm"
+
+but we can change this to be a memoizer that can greatly reduce the
+computational complexity of the process.
+
+A rule returns #f if it cannot be applied to an expression.  The
+procedure try-rules just scans the list of rules, returning the result
+of the first rule that applies, or the #f if no rule applies:
+
+     (define (try-rules expression the-rules)
+       (define (scan rules)
+         (if (null? rules)
+             #f
+             (or ((car rules) expression)
+                 (scan (cdr rules)))))
+       (scan the-rules))
+
+A rule is made from a matcher combinator procedure, a restriction
+predicate procedure and an instantiator procedure.  These are put
+together by the procedure rule:make.  If the matcher succeeds it
+produces a dictionary and a count of items eaten by the matcher from
+the list containing the expression to match.  If this number is 1 then
+if either there is no restriction predicate or the restriction
+predicate is satisfied then the instantiator is called.  The
+restriction predicate procedure and the instantiator procedure take as
+arguments the values of the variables bound in the match.  These
+procedures are compiled from the rule patterns and skeletons, by a
+process we will see later.
+
+     (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)
+
+
+-------------
+Problem 6.5:
+
+Problem 3.27 in SICP (pp. 272--273) shows the basic idea of
+memoization.  We talked about this in class on Friday.  Can this help
+the simplifier?  How?
+
+Write a memoizer that may be useful in dealing with expressions in the
+rule-simplifier procedure.  One problem is that we don't want to store
+a table with an unbounded number of big expressions.  However, most of
+the advantage in this kind of memoizer comes from using it as a cache
+for recent results.  Implement an LRU memoizer mechanism that stores
+only a limited number of entries and throws away the Least-Recently
+Used one.  Demonstrate your program.
+-------------
+
+                           Magic Macrology
+
+The call to rule:make is composed from the expression representing a
+rule by the rule compiler, found in rule-compiler.scm.  There are
+complications here, imposed by the use of a macro implementing syntax
+for rules.  Consider the rule:
+
+     (rule (* (?? a) (? y) (? x) (?? b))
+           (expr<? x y)
+           (* (?? a) (? x) (? y) (?? b)))
+
+The rule macro turns this into a call to compile-rule:
+
+     (compile-rule '(* (?? a) (? y) (? x) (?? b))
+                   '(expr<? x y)
+                   '(* (?? a) (? x) (? y) (?? b))
+                   some-environment)
+
+We can see the expression this expands into with the following magic
+incantation:
+
+     (pp (syntax
+          (compile-rule '(* (?? a) (? y) (? x) (?? b))
+                        '(expr<? x y)
+                        '(* (?? a) (? x) (? y) (?? b))
+                        (the-environment))
+          (the-environment)))
+  ==>
+     (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<? x y))
+      (lambda (b x y a)
+        (cons (quote *) (append a (cons x (cons y b))))))
+
+We see that the rule expands into a call to rule:make with arguments
+that construct the matcher combinator, the predicate procedure, and
+the instantiation procedure.  This is the expression that is evaluated
+to make the rule.  In more conventional languages macros expand
+directly into code that is substituted for the macro call.  However
+this process is not referentially transparent, because the macro
+expansion may use symbols that conflict with the user's symbols.  In
+Scheme we try to avoid this problem, allowing a user to write
+"hygienic macros" that cannot cause conflicts.  However this is a bit
+more complicated than just substituting one expression for another.
+We will not try to explain the problems or the solutions here, but we
+will just use the solutions described in the MIT Scheme reference
+manual, section 2.11.
+
+;;;; File:  load.scm -- Loader for rule system
+
+(load "rule-compiler")
+(load "matcher")
+(load "rule-simplifier")
+
+(define (rule-memoize x) x)   ;;; NB:  Scaffolding stub for prob 4.5
+
+(load "rules")
+
+
+
+
+
+
+
+;;;; File:  rule-compiler.scm
+
+(define-syntax rule
+  (sc-macro-transformer
+   (lambda (form env)
+     (if (syntax-match? '(DATUM EXPRESSION DATUM) (cdr form))
+         (compile-rule (cadr form) (caddr form) (cadddr form) env)
+         (ill-formed-syntax form)))))
+
+(define (compile-rule pattern restriction template env)
+  (let ((names (pattern-names pattern)))
+    `(rule:make ,(compile-pattern pattern env)
+                ,(compile-restriction restriction env names)
+                ,(compile-instantiator template env names))))
+
+(define (pattern-names pattern)
+  (let loop ((pattern pattern) (names '()))
+    (cond ((or (match:element? pattern)
+               (match:segment? pattern))
+           (let ((name (match:variable-name pattern)))
+             (if (memq name names)
+                 names
+                 (cons name names))))
+          ((list? pattern)
+           (let elt-loop ((elts pattern) (names names))
+             (if (pair? elts)
+                 (elt-loop (cdr elts) (loop (car elts) names))
+                 names)))
+          (else names))))
+
+(define (compile-pattern pattern env)
+  (let loop ((pattern pattern))
+    (cond ((match:element? pattern)
+           (if (match:restricted? pattern)
+               `(match:element ',(match:variable-name pattern)
+                               ,(match:restriction pattern))
+               `(match:element ',(match:variable-name pattern))))
+          ((match:segment? pattern)
+           `(match:segment ',(match:variable-name pattern)))
+          ((null? pattern)
+           `(match:eqv '()))
+          ((list? pattern)
+           `(match:list ,@(map loop pattern)))
+          (else
+           `(match:eqv ',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))
+
+
+;;; These restrictions are for variable elements.
+
+(define (match:restricted? pattern)
+  (not (null? (cddr pattern))))
+
+(define (match:restriction pattern)
+  (caddr pattern))
+
+;;; The restriction is a predicate that must be true for the rule to
+;;; be applicable.  This is not the same as a variable element
+;;; restriction.
+
+(define (compile-restriction expr env names)
+  (if (eq? expr 'none)
+      `#f
+      (make-lambda names env
+        (lambda (body-environment)
+          (close-syntax expr body-environment)))))
+
+
+(define (compile-instantiator skel env names)
+  (make-lambda names env
+    (lambda (body-environment)
+      (list 'quasiquote
+            (let ((wrap
+                   (lambda (expr)
+                     (close-syntax expr body-environment))))
+              (let loop ((skel skel))
+                (cond ((skel:element? skel)
+                       (list 'unquote
+                             (wrap (skel:element-expression skel))))
+                      ((skel:segment? skel)
+                       (list 'unquote-splicing
+                             (wrap (skel:segment-expression skel))))
+                      ((list? skel) (map loop skel))
+                      (else skel))))))))
+
+                       
+(define (skel:constant? skeleton)
+  (not (pair? skeleton)))
+
+
+(define (skel:element? skeleton)
+  (and (pair? skeleton)
+       (eq? (car skeleton) '?)))
+
+(define (skel:element-expression skeleton)
+  (cadr skeleton))
+
+
+(define (skel:segment? skeleton)
+  (and (pair? skeleton)
+       (eq? (car skeleton) '??)))
+
+(define (skel:segment-expression skeleton)
+  (cadr skeleton))
+
+;; Magic!
+(define (make-lambda bvl use-env generate-body)
+  (capture-syntactic-environment
+   (lambda (transform-env)
+     (close-syntax `(,(close-syntax 'lambda transform-env)
+                     ,bvl
+                     ,(capture-syntactic-environment
+                       (lambda (use-env*)
+                         (close-syntax (generate-body use-env*)
+                                       transform-env))))
+                   use-env))))
+
+#|
+;;; For example
+
+(pp (syntax '(rule (+ (? a) (+ (? b) (? c)))
+                   none
+                   (+ (+ (? 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))))
+ #f
+ (lambda (c b a)
+   (list (quote +) (list (quote +) a b) c)))
+
+(pp (syntax '(rule (+ (? a) (+ (? b) (? c)))
+                   (> 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<? a b)
+          (* (? a) (? b)))
+
+    ;; Distributive law of multiplication over addition
+    (rule (* (? a) (+ (? b) (? c)))
+          none
+          (+ (* (? a) (? b)) (* (? a) (? c))))
+
+    )))
+
+(define (expr<? x y)
+  (cond ((null? x)
+         (if (null? y) #f #t))
+        ((null? y) #f)
+        ((number? x)
+         (if (number? y) (< x y) #t))
+        ((number? y) #f)
+        ((symbol? x)
+         (if (symbol? y) (symbol<? x y) #t))
+        ((symbol? y) #f)
+        ((list? x)
+         (if (list? y)
+             (let ((nx (length x)) (ny (length y)))
+               (cond ((< nx ny) #t)
+                     ((> nx ny) #f)
+                     (else
+                      (let lp ((x x) (y y))
+                        (cond ((null? x) #f) ; same
+                              ((expr<? (car x) (car y)) #t)
+                              ((expr<? (car y) (car x)) #f)
+                              (else (lp (cdr x) (cdr y))))))))))
+        ((list? y) #f)
+        (else
+         (error "Unknown expression type -- expr<?"
+                x y))))
+
+#|
+(algebra-1 '(* (+ y (+ z w)) x))
+;Value: (+ (+ (* x y) (* x z)) (* w x))
+|#
+
+(define algebra-2
+  (rule-simplifier
+   (list
+
+    ;; Sums
+
+    (rule (+ (? a)) none (? a))
+
+    (rule (+ (?? a) (+ (?? b)))
+          none
+          (+ (?? a) (?? b)))
+
+    (rule (+ (+ (?? a)) (?? b))
+          none
+          (+ (?? a) (?? b)))
+
+    (rule (+ (?? a) (? y) (? x) (?? b))
+          (expr<? x y)
+          (+ (?? a) (? x) (? y) (?? b)))
+    
+
+    ;; Products
+
+    (rule (* (? a)) none (? a))
+
+    (rule (* (?? a) (* (?? b)))
+          none
+          (* (?? a) (?? b)))
+
+    (rule (* (* (?? a)) (?? b))
+          none
+          (* (?? a) (?? b)))
+
+    (rule (* (?? a) (? y) (? x) (?? b))
+          (expr<? x y)
+          (* (?? a) (? x) (? y) (?? b)))
+
+
+    ;; Distributive law
+
+    (rule (* (? a) (+ (?? b)))
+          none
+          (+ (?? (map (lambda (x) `(* ,a ,x)) b))))
+
+
+    ;; Numerical simplifications below
+
+    (rule (+ 0 (?? x)) none (+ (?? x)))
+
+    (rule (+ (? x number?) (? y number?) (?? z))
+          none
+          (+ (? (+ x y)) (?? z)))
+
+
+    (rule (* 0 (?? x)) none 0)
+     
+    (rule (* 1 (?? x)) none (* (?? x)))
+
+    (rule (* (? x number?) (? y number?) (?? z))
+          none
+          (* (? (* x y)) (?? z)))
+
+    )))
+
+#|
+(algebra-2 '(* (+ y (+ z w)) x))
+;Value: (+ (* w x) (* x y) (* x z))
+
+(algebra-2 '(+ (* 3 (+ x 1)) -3))
+;Value: (* 3 x)
+|#
diff --git a/ps06_rule_systems/rule-compiler.scm b/ps06_rule_systems/rule-compiler.scm
new file mode 100644
index 0000000..f705308
--- /dev/null
+++ b/ps06_rule_systems/rule-compiler.scm
@@ -0,0 +1,161 @@
+(define-syntax rule
+  (sc-macro-transformer
+   (lambda (form env)
+     (if (syntax-match? '(DATUM EXPRESSION DATUM) (cdr form))
+	 (compile-rule (cadr form) (caddr form) (cadddr form) env)
+	 (ill-formed-syntax form)))))
+
+(define (compile-rule pattern restriction template env)
+  (let ((names (pattern-names pattern)))
+    `(rule:make ,(compile-pattern pattern env)
+		,(compile-restriction restriction env names)
+		,(compile-instantiator template env names))))
+
+;;; These could be generic, but I am lazy today... GJS
+
+(define (pattern-names pattern)
+  (let loop ((pattern pattern) (names '()))
+    (cond ((or (match:element? pattern)
+	       (match:segment? pattern))
+	   (let ((name (match:variable-name pattern)))
+	     (if (memq name names)
+		 names
+		 (cons name names))))
+	  ((list? pattern)
+	   (let elt-loop ((elts pattern) (names names))
+	     (if (pair? elts)
+		 (elt-loop (cdr elts) (loop (car elts) names))
+		 names)))
+	  (else names))))
+
+(define (compile-pattern pattern env)
+  (let loop ((pattern pattern))
+    (cond ((match:element? pattern)
+	   (if (match:restricted? pattern)
+	       `(match:element ',(match:variable-name pattern)
+			       ,(match:restriction pattern))
+	       `(match:element ',(match:variable-name pattern))))
+	  ((match:segment? pattern)
+	   `(match:segment ',(match:variable-name pattern)))
+	  ((null? pattern)
+	   `(match:eqv '()))
+	  ((list? pattern)
+	   `(match:list ,@(map loop pattern)))
+	  (else
+	   `(match:eqv ',pattern)))))
+
+
+;;; These are repeated from match.scm
+
+(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:restricted? pattern)
+  (not (null? (cddr pattern))))
+
+(define (match:restriction pattern)
+  (caddr pattern))
+
+;;; The restriction is a predicate that must be true for the rule to
+;;; be applicable.  This is not the same as a variable element
+;;; restriction.
+
+(define (compile-restriction expr env names)
+  (if (eq? expr 'none)
+      `#f
+      (make-lambda names env
+	(lambda (env)
+	  (close-syntax expr env)))))
+
+
+(define (compile-instantiator skel env names)
+  (make-lambda names env
+    (lambda (env)
+      (list 'quasiquote
+	    (let ((wrap (lambda (expr) (close-syntax expr env))))
+	      (let loop ((skel skel))
+		(cond ((skel:element? skel)
+		       (list 'unquote
+			     (wrap (skel:element-expression skel))))
+		      ((skel:segment? skel)
+		       (list 'unquote-splicing
+			     (wrap (skel:segment-expression skel))))
+		      ((list? skel) (map loop skel))
+		      (else skel))))))))
+
+		       
+(define (skel:constant? skeleton)
+  (not (pair? skeleton)))
+
+
+(define (skel:element? skeleton)
+  (and (pair? skeleton)
+       (eq? (car skeleton) '?)))
+
+(define (skel:element-expression skeleton)
+  (cadr skeleton))
+
+
+(define (skel:segment? skeleton)
+  (and (pair? skeleton)
+       (eq? (car skeleton) '??)))
+
+(define (skel:segment-expression skeleton)
+  (cadr skeleton))
+
+;; Magic!
+(define (make-lambda bvl use-env generate-body)
+  (capture-syntactic-environment
+   (lambda (transform-env)
+     (close-syntax `(,(close-syntax 'lambda transform-env)
+		     ,bvl
+		     ,(capture-syntactic-environment
+		       (lambda (use-env*)
+			 (close-syntax (generate-body use-env*)
+				       transform-env))))
+		   use-env))))
+
+#|
+;;; For example
+
+(pp (syntax '(rule (+ (? a) (+ (? b) (? c)))
+		   none
+		   (+ (+ (? 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))))
+ #f
+ (lambda (c b a)
+   (list (quote +) (list (quote +) a b) c)))
+
+(pp (syntax '(rule (+ (? a) (+ (? b) (? c)))
+		   (> 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)))
+
+|#
\ No newline at end of file
diff --git a/ps06_rule_systems/rule-simplifier.scm b/ps06_rule_systems/rule-simplifier.scm
new file mode 100644
index 0000000..a402e63
--- /dev/null
+++ b/ps06_rule_systems/rule-simplifier.scm
@@ -0,0 +1,53 @@
+;;;;         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 ((ssubs
+	   (if (list? expression)
+	       (map simplify-expression expression)
+	       expression)))
+      (let ((result (try-rules ssubs the-rules)))
+	(if result
+	    (simplify-expression result)
+	    ssubs))))
+  (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)
+
diff --git a/ps06_rule_systems/rules.scm b/ps06_rule_systems/rules.scm
new file mode 100644
index 0000000..4ba2451
--- /dev/null
+++ b/ps06_rule_systems/rules.scm
@@ -0,0 +1,123 @@
+(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<? a b)
+	  (* (? a) (? b)))
+
+    ;; Distributive law of multiplication over addition
+    (rule (* (? a) (+ (? b) (? c)))
+	  none
+	  (+ (* (? a) (? b)) (* (? a) (? c))))
+
+    )))
+
+(define (expr<? x y)
+  (cond ((null? x)
+	 (if (null? y) #f #t))
+	((null? y) #f)
+	((number? x)
+	 (if (number? y) (< x y) #t))
+	((number? y) #f)
+	((symbol? x)
+	 (if (symbol? y) (symbol<? x y) #t))
+	((symbol? y) #f)
+	((list? x)
+	 (if (list? y)
+	     (let ((nx (length x)) (ny (length y)))
+	       (cond ((< nx ny) #t)
+		     ((> nx ny) #f)
+		     (else
+		      (let lp ((x x) (y y))
+			(cond ((null? x) #f) ; same
+			      ((expr<? (car x) (car y)) #t)
+			      ((expr<? (car y) (car x)) #f)
+			      (else (lp (cdr x) (cdr y))))))))))
+	((list? y) #f)
+	(else
+	 (error "Unknown expression type -- expr<?"
+		x y))))
+
+#|
+(algebra-1 '(* (+ y (+ z w)) x))
+;Value: (+ (+ (* x y) (* x z)) (* w x))
+|#
+
+(define algebra-2
+  (rule-simplifier
+   (list
+
+    ;; Sums
+
+    (rule (+ (? a)) none (? a))
+
+    (rule (+ (?? a) (+ (?? b)))
+	  none
+	  (+ (?? a) (?? b)))
+
+    (rule (+ (+ (?? a)) (?? b))
+	  none
+	  (+ (?? a) (?? b)))
+
+    (rule (+ (?? a) (? y) (? x) (?? b))
+	  (expr<? x y)
+	  (+ (?? a) (? x) (? y) (?? b)))
+    
+
+    ;; Products
+
+    (rule (* (? a)) none (? a))
+
+    (rule (* (?? a) (* (?? b)))
+	  none
+	  (* (?? a) (?? b)))
+
+    (rule (* (* (?? a)) (?? b))
+	  none
+	  (* (?? a) (?? b)))
+
+    (rule (* (?? a) (? y) (? x) (?? b))
+	  (expr<? x y)
+	  (* (?? a) (? x) (? y) (?? b)))
+
+
+    ;; Distributive law
+
+    (rule (* (? a) (+ (?? b)))
+	  none
+	  (+ (?? (map (lambda (x) `(* ,a ,x)) b))))
+
+
+    ;; Numerical simplifications below
+
+    (rule (+ 0 (?? x)) none (+ (?? x)))
+
+    (rule (+ (? x number?) (? y number?) (?? z))
+	  none
+	  (+ (? (+ x y)) (?? z)))
+
+
+    (rule (* 0 (?? x)) none 0)
+     
+    (rule (* 1 (?? x)) none (* (?? x)))
+
+    (rule (* (? x number?) (? y number?) (?? z))
+	  none
+	  (* (? (* x y)) (?? z)))
+
+    )))
+
+#|
+(algebra-2 '(* (+ y (+ z w)) x))
+;Value: (+ (* w x) (* x y) (* x z))
+
+(algebra-2 '(+ (* 3 (+ x 1)) -3))
+;Value: (* 3 x)
+|#
-- 
cgit v1.2.3