MASSACHVSETTS INSTITVTE OF TECHNOLOGY
      Department of Electrical Engineering and Computer Science

                          6.891 Spring 2007
                            Problem Set 5

  Issued: Wed. 7 Mar 2007                    Due: Wed. 14 March 2007

Reading: MIT/GNU Scheme Reference Manual
            Section 2.11.3: Syntactic Closures

         http://en.wikipedia.org/wiki/Term_rewriting

Code:  load.scm, rule-compiler.scm, instantiator.scm, matcher.scm,
       rule-simplifier.scm, rules.scm, eq-prop.scm (all attached)

                     More Term-Rewriting Systems

The rule system that we worked with last week is limited in that the
elementary patterns and elementary templates are predetermined by the
designer of the system.  But we often want to add a new pattern
constituent or a new template constituent.  In this problem set we
will improve the rule system so as to make it easy to invent and add
new pattern and template mechanisms.

Let's start with the patterns.  If we want to add a new pattern, such
as the ones that we made in problem set 3, we have to do two things.
We have to create the combinator that implements the new functionality
and we have to add the syntax for using it to the compile-pattern
procedure.  One way to make the syntax extensible is to break up the
compile-pattern procedure and make it use a data-directed dispatch.
Here is an elegant way to implement this plan:

     (define (compile-pattern pattern use-env)
       (let loop ((pattern pattern))
         (cond ((pair? pattern)
                (let ((proc (eq-get (car pattern) 'pattern-keyword)))
                  (cond (proc
                         (proc pattern use-env loop))
                        ((list? pattern)
                         `(match:list ,@(map loop pattern)))
                        (else
                         (error "Illegal pattern" pattern)))))
               (else
                `(match:eqv ',pattern)))))

     (define (compile-match-element pattern use-env loop)
       (if (match:restricted? pattern)
           `(match:element ',(match:variable-name pattern)
                           ,(close-syntax (match:restriction pattern)
                                          use-env))
           `(match:element ',(match:variable-name pattern))))

     (eq-put! '? 'pattern-keyword compile-match-element)

     (define (compile-match-segment pattern use-env loop)
       `(match:segment ',(match:variable-name pattern)))

     (eq-put! '?? 'pattern-keyword compile-match-segment)

Notice that we are using the property mechanism to extend the syntax,
by attaching a compilation procedure to each syntactic keyword.  This
kind of extensibility mechanism is clean and easy.  Assigning "?" as
a pattern keyword does not prevent it from being used in other ways in
other contexts.

----------------------------
Problem 5.1

Add in your favorite match extension from Problem Set 3.  Our favorite
is match:choice (with syntax keyword ?:choice).  You need not change
any of the files in the rule system.  You just have to add a file with
your combinator, its compilation procedure, and its attachment to the
pattern keyword you choose.  Then add your extension file to the list
of files loaded in the loader (in load.scm).

Demonstrate your extension in a rule system.
----------------------------

The other thing to notice is that the use-env (environment of use) is
passed into the pattern compiler from the rule macro transformer
(through the compile-rule procedure).  This use environment is passed
to each compilation procedure, but in the example above it is used
only in compile-match-element, and only in the compilation of a match
restriction associated with the match variable.

----------------------------
Problem 5.2

Why is close-syntax needed?  What would be a possible evil consequence
of replacing:

     (close-syntax (match:restriction pattern) use-env)

with the simpler:

     (match:restriction pattern)

Explain in a few concise sentences.  Give an example.
----------------------------

Currently, we allow two kinds of restrictions in our rule systems.
We allow restrictions on the values that a match variable may take on,
as in (? x number?), and we allow overall restrictions on the
applicability of a rule, with a predicate expression that can test the
values of variables resulting from a match, as in the commutative law:

     (rule (* (? b) (? a))
           (expr<? (: a) (: b))
           (* (: a) (: b)))

WATCH OUT HERE!  We changed the rule syntax so that the value of a
pattern variable is represented in the predicate and in the template
with a colon rather than a question mark.  We will see why this was
useful later.

Sometimes we would like to apply restrictions to a match that are not
just about one pattern variable, but which are localized to one
subexpression of a larger pattern.  For example, suppose we are
looking for a trinomial that is a perfect square in some larger
pattern, perhaps in a square root:  If a, b, c are numbers, then
a*x^2+b*x+c is a perfect square if b^2=4*a*c.  We would like to
introduce a new pattern construct so that we can write the following
pattern fragment:

     (?r (+ (* (? a number?) (expt (? x) 2))
            (* (? b number?) (? x))
            (? c number?))
         (= (expt (: b) 2) (* 4 (: a) (: c))))

Here a, b, c are restricted to be numbers, and the combination is
restricted by the predicate expression following it.  This pattern
may then appear as a subexpression pattern of any other pattern.
Let's implement this.

----------------------------
Problem 5.3

Given the syntactic part of the code, as follows:

     (define (compile-match-restrict pattern use-env loop)
       (let ((inside (loop (match:restriction-pattern pattern))))
         `(match:restrict ,inside
                          ,(close-in-dictionary
                            (match:restriction-restriction pattern)
                            use-env))))

     (eq-put! '?r 'pattern-keyword compile-match-restrict)

     (define (match:restriction-pattern pattern)
       (cadr pattern))

     (define (match:restriction-restriction pattern)
       (caddr pattern))

fill in the combinator definition:

     (define (match:restrict match-combinator restriction?)
       (define (restrict-match data dictionary succeed)
         ...)
       restrict-match)

required to implement the required behavior.

Demonstrate your program with some nice examples.
----------------------------

The template mechanism can also be made more flexible by building it
as a set of instantiation combinators.  This required a rewrite of the
Problem Set 4 instantiator.  (See instantiator.scm.)  As implemented
in Problem Set 4, the interface between the template substitution and
Scheme, though convenient, was a bit muddy.  So we changed the
interface to separate pattern variable references from ordinary Scheme
variable references, introducing the colon construct (viz., (: x)
means "the value of pattern variable x").  Accordingly, we changed the
meaning of the keywords ? and ?? in templates to mean "the Scheme
value of" and "the Scheme value of, spliced in", respectively.  Thus
the numerical simplification rule that used to be written:

     (rule (+ (? x number?) (? y number?) (?? z))
           none
           (+ (? (+ x y)) (?? z)))

is now written:

     (rule (+ (? x number?) (? y number?) (?? z))
           none
           (+ (? (+ (: x) (: y))) (?? (: z))))

This is a bit ugly, but it makes a clearer interface between Scheme
evaluation and instantiation.  To make it nicer, we also allow the use
of the Scheme reader syntax for unquote and unquote-splicing, which
usually appear in quasiquotations, so the rule above may be written:

     (rule (+ (? x number?) (? y number?) (?? z))
           none
           (+ ,(+ (: x) (: y)) ,@(: z)))

Note that this leverages the following Scheme reader expansions:

      ,<expr> ==> (unquote <expr>)
     ,@<expr> ==> (unquote-splicing <expr>)

...just as the familiar 'foo expands at read time into (quote foo).

All this syntax is implemented in the file rule-compiler.scm.  As in
patterns, the property mechanism is used to implement the
data-directed dispatch for template keywords.

A useful instantiation combinator is one that allows a Scheme program
to further transform the expression resulting from the instantiation
of a skeleton.  This may be used to invoke specialized simplifiers for
particular expression types that may be constructed.  So, for example,
the instantiation skeleton:

     (+ (:t simplify-product
            (* ,(: coefficient) ,@(: factors)))
        ,@(: addends))

allows a Scheme procedure, simplify-product, to do special-case
simplifications of the newly-constructed product.  It might, for
example, be the application of a number of rules, such as:

     (define simplify-product
       (rule-simplifier
         (list (rule (* 0 (?? x)) none 0)
               (rule (* 1 (?? x)) none (* ,@(: x)))
               (rule (* (? x)) none ,(: x)))))

----------------------------
Problem 5.4

Implement the :t syntax and the appropriate instantiation combinator
with its associated instantiation template compiler.

Demonstrate that it works, and use it for something interesting.
----------------------------

;;;; File:  load.scm -- Loader for rule system (eq-prop & instantiator)

(load "eq-prop") ;; NB:  must load this file before rule-compiler.scm!

(load "rule-compiler")
(load "instantiator")
(load "matcher")
(load "rule-simplifier")

(define (rule-memoize x) x)   ;;; NB:  Scaffolding stub for prob 4.5

(load "rules")







;;;; File:  rule-compiler.scm -- abstract syntax & no MAKE-LAMBDA magic!

(define-syntax rule
  (sc-macro-transformer
   (lambda (form use-env)
     (if (syntax-match? '(DATUM EXPRESSION DATUM) (cdr form))
         (compile-rule (cadr form) (caddr form) (cadddr form) use-env)
         (ill-formed-syntax form)))))

(define (compile-rule pattern restriction template use-env)
  `(rule:make ,(compile-pattern pattern use-env)
              ,(compile-restriction restriction use-env)
              ,(compile-instantiator template use-env)))

(define (compile-pattern pattern use-env)
  (let loop ((pattern pattern))
    (cond ((pair? pattern)
           (let ((proc (eq-get (car pattern) 'pattern-keyword)))
             (cond (proc
                    (proc pattern use-env loop))
                   ((list? pattern)
                    `(match:list ,@(map loop pattern)))
                   (else
                    (error "Illegal pattern" pattern)))))
          (else
           `(match:eqv ',pattern)))))

(define (compile-match-element pattern use-env loop)
  (if (match:restricted? pattern)
      `(match:element ',(match:variable-name pattern)
                      ,(close-syntax (match:restriction pattern) use-env))
      `(match:element ',(match:variable-name pattern))))

(eq-put! '? 'pattern-keyword compile-match-element)


(define (compile-match-segment pattern use-env loop)
  `(match:segment ',(match:variable-name pattern)))

(eq-put! '?? 'pattern-keyword compile-match-segment)



(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 use-env)
  (if (eq? expr 'none)
      `#f
      (close-in-dictionary expr use-env)))

(define (close-in-dictionary expr use-env)
  `(lambda (*dictionary*)
     ,(capture-syntactic-environment
       (lambda (trans-env)
         (close-syntax
          (instantiate-variables expr '*dictionary* trans-env)
          use-env)))))

(define (instantiate-variables expr dict trans-env)
  (let loop ((expr expr))
    (cond ((skel:variable? expr)
           (close-syntax
            `(instantiate:lookup ',(skel:variable-name expr)
                                 ,dict)
            trans-env))
          ((list? expr) (map loop expr))
          (else expr))))


(define (compile-instantiator skel use-env)
  `(instantiate-interface
    ,(let loop ((skel skel))
       (cond ((pair? skel)
              (let ((proc (eq-get (car skel) 'template-keyword)))
                (cond (proc
                       (proc skel use-env loop))
                      ((list? skel)
                       `(instantiate:list ,@(map loop skel)))
                      (else
                       (error "Illegal template" skel)))))
             (else
              `(instantiate:constant ',skel))))))

(define (compile-instantiate-variable skel use-env loop)
  `(instantiate:variable ',(skel:variable-name skel)))

(eq-put! ': 'template-keyword compile-instantiate-variable)


(define (compile-instantiate-element skel use-env loop)
  `(instantiate:element
    ,(close-in-dictionary (skel:element-expression skel)
                          use-env)))

(eq-put! '? 'template-keyword compile-instantiate-element)
(eq-put! 'unquote 'template-keyword compile-instantiate-element)


(define (compile-instantiate-segment skel use-env loop)
  `(instantiate:segment
    ,(close-in-dictionary (skel:segment-expression skel)
                          use-env)))

(eq-put! '?? 'template-keyword compile-instantiate-segment)
(eq-put! 'unquote-splicing 'template-keyword compile-instantiate-segment)


(define (skel:constant? skeleton)
  (not (pair? skeleton)))

(define (skel:variable? skeleton)
  (and (pair? skeleton)
       (eq? (car skeleton) ':)))

(define (skel:variable-name skeleton)
  (cadr 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))

(define (instantiate:lookup varname dictionary)
  (let ((vcell (match:lookup varname dictionary)))
    (if vcell
        (match:value vcell)
        (error "Unbound pattern variable:" varname))))

#|
;;; For example ... no restriction

(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
 (instantiate-interface
  (instantiate:list
   (instantiate:constant (quote +))
   (instantiate:list
    (instantiate:constant (quote +))
    (instantiate:element
     (lambda (*dictionary*)
       (instantiate:lookup (quote a) *dictionary*)))
    (instantiate:element
     (lambda (*dictionary*)
       (instantiate:lookup (quote b) *dictionary*))))
   (instantiate:element
    (lambda (*dictionary*)
      (instantiate:lookup (quote c) *dictionary*))))))
|#

#|
;;; For example ... with a restriction

(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 (*dictionary*)
   (> (instantiate:lookup (quote a) *dictionary*) 3))
 (instantiate-interface
  (instantiate:list
   (instantiate:constant (quote +))
   (instantiate:list
    (instantiate:constant (quote +))
    (instantiate:element
     (lambda (*dictionary*)
       (instantiate:lookup (quote a) *dictionary*)))
    (instantiate:element
     (lambda (*dictionary*)
       (instantiate:lookup (quote b) *dictionary*))))
   (instantiate:element
    (lambda (*dictionary*)
      (instantiate:lookup (quote c) *dictionary*))))))
|#

;;;; File:  instantiator.scm

;;;; Combinator version of the instantiator

(define (instantiate:variable variable-name)
  (lambda (dictionary continue)
    (continue (instantiate:lookup variable-name
                                  dictionary)
              #f)))

(define (instantiate:constant constant)
  (lambda (dictionary continue)
    (continue constant #f)))

(define (instantiate:element element-generator)
  (lambda (dictionary continue)
    (continue (element-generator dictionary) #f)))

(define (instantiate:segment segment-generator)
  (lambda (dictionary continue)
    (let ((elements (segment-generator dictionary)))
      (continue elements (length elements)))))

(define (instantiate:list . element-sources)
  (lambda (dictionary continue)
    (continue
     (let lp ((ess element-sources))
       (if (null? ess)
           '()
           ((car ess) dictionary
                      (lambda (elements number)
                        (if (not number)
                            (cons elements
                                  (lp (cdr ess)))
                            (append elements
                                    (lp (cdr ess))))))))
     #f)))





(define (instantiate:lookup varname dictionary)
  (let ((vcell (match:lookup varname dictionary)))
    (if vcell
        (match:value vcell)
        (error "Unbound pattern variable:" varname))))


(define (instantiate-interface combinator)
  (lambda (dictionary)
    (combinator dictionary
                (lambda (thing flag)
                  (if (not flag)
                      thing
                      #f)))))

#|
;;; Examples

(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 (*dictionary*)
   (> (instantiate:lookup (quote a) *dictionary*) 3))
 (instantiate-interface
  (instantiate:list
   (instantiate:constant (quote +))
   (instantiate:list
    (instantiate:constant (quote +))
    (instantiate:element
     (lambda (*dictionary*)
       (instantiate:lookup (quote a) *dictionary*)))
    (instantiate:element
     (lambda (*dictionary*)
       (instantiate:lookup (quote b) *dictionary*))))
   (instantiate:element
    (lambda (*dictionary*)
      (instantiate:lookup (quote c) *dictionary*))))))
|#

#|
;;; Examples ... cont'd

(pp (syntax
     '(rule (+ (?? a)
               (* (? n1 number?) (?? f1))
               (?? b)
               (* (? n2 number?) (?? f1))
               (?? c))
            none
            (+ (?? (: a))
               (* (? (+ (: n1) (: n2))) (?? (: f1)))
               (?? (: b))
               (?? (: c))))
     (the-environment)))
(rule:make
 (match:list
  (match:eqv (quote +))
  (match:segment (quote a))
  (match:list (match:eqv (quote *))
              (match:element (quote n1) number?)
              (match:segment (quote f1)))
  (match:segment (quote b))
  (match:list (match:eqv (quote *))
              (match:element (quote n2) number?)
              (match:segment (quote f1)))
  (match:segment (quote c)))
 #f
 (instantiate-interface
  (instantiate:list
   (instantiate:constant (quote +))
   (instantiate:segment
    (lambda (*dictionary*)
      (instantiate:lookup (quote a) *dictionary*)))
   (instantiate:list
    (instantiate:constant (quote *))
    (instantiate:element
     (lambda (*dictionary*)
       (+ (instantiate:lookup (quote n1) *dictionary*)
          (instantiate:lookup (quote n2) *dictionary*))))
    (instantiate:segment
     (lambda (*dictionary*)
       (instantiate:lookup (quote f1) *dictionary*))))
   (instantiate:segment
    (lambda (*dictionary*)
      (instantiate:lookup (quote b) *dictionary*)))
   (instantiate:segment
    (lambda (*dictionary*)
      (instantiate:lookup (quote c) *dictionary*))))))
|#

;;;; File:  matcher.scm  [Note:  same code as in PS04]

;;;; 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:->combinators pattern)
  (define (compile 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)))
          ((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))

;;; These restrictions are for variable elements.

(define (match:restricted? pattern)
  (not (null? (cddr pattern))))

(define (match:restriction pattern)
  (caddr 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))
|#

;;;; 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 ((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 and instantiator

(define (rule:make matcher restriction instantiator)
  (define (the-rule expression)
    (matcher (list expression)
             '()
             (lambda (dictionary n)
               (and (= n 1)
                    (and (or (not restriction)
                             (restriction dictionary))
                         (instantiator dictionary))))))
    the-rule)

;;;; File:  rules.scm -- Some sample algebraic simplification rules

(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))))))))
             #t))
        ((list? y) #f)
        (else
         (error "Unknown expression type -- expr<?"
                x y))))

(define algebra
  (rule-simplifier
   (list


    ;; Sums


    (rule (+ (? a)) none (: a))

    (rule (+ (?? a) (+ (?? b)) (?? c))
          none
          (+ ,@(: a) ,@(: b) ,@(: c)))

    (rule (+ (?? a) (? y) (? x) (?? b))
          (expr<? (: x) (: y))
          (+ ,@(: a) (: x) (: y) ,@(: b)))


    ;; Products


    (rule (* (? a)) none (: a))

    (rule (* (?? a) (* (?? b)) (?? c))
          none
          (* ,@(: a) ,@(: b) ,@(: c)))

    (rule (* (?? a) (? y) (? x) (?? b))
          (expr<? (: x) (: y))
          (* ,@(: a) (: x) (: y) ,@(: b)))


    ;; Distributive law


    (rule (* (?? a) (+ (?? b)) (?? c))
          none
          (+ ,@(map (lambda (x)
                      `(* ,@(: a) ,x ,@(: c)))
                    (: 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)))

    ;; Collecting like terms.  Why is this so painful?

    (rule (+ (?? a)
             (* (? n1 number?) (?? f1))
             (?? b)
             (* (? n2 number?) (?? f1))
             (?? c))
          none
          (+ (?? (: a))
             (* (? (+ (: n1) (: n2))) (?? (: f1)))
             (?? (: b))
             (?? (: c))))

    (rule (+ (?? a)
             (* (?? f1))
             (?? b)
             (* (? n2 number?) (?? f1))
             (?? c))
          none
          (+ (?? (: a))
             (* (? (+ 1 (: n2))) (?? (: f1)))
             (?? (: b))
             (?? (: c))))

    (rule (+ (?? a)
             (? x)
             (?? b)
             (* (? n2 number?) (? x))
             (?? c))
          none
          (+ (?? (: a))
             (* (? (+ 1 (: n2))) (? (: x)))
             (?? (: b))
             (?? (: c))))

    (rule (+ (?? a)
             (? x)
             (?? b)
             (? x)
             (?? c))
          none
          (+ (?? (: a))
             (* 2 (? (: x)))
             (?? (: b))
             (?? (: c))))

    )))

#|
(algebra '(+ y (* 4 x) z (* 5 z) (* 3 x)))
;Value: (+ y (* 6 z) (* 7 x))

(algebra '(+ y (* -2 x w) (* x 4 y) (* w x) z (* 5 z) (* x w) (* x y 3)))
;Value: (+ y (* 6 z) (* 7 x y))
|#

;;;; File:  eq-prop.scm

;;;; Traditional LISP property lists
;;; extended to work on any kind of eq?
;;; data structure.

(declare (usual-integrations))


(define eq-properties
  (make-eq-hash-table))

(define (eq-put! node property value)
  (let ((plist
         (hash-table/get eq-properties node #f)))
    (if plist
        (let ((vcell
               (assq property (cdr plist))))
          (if vcell
              (set-cdr! vcell value)
              (set-cdr! plist
                (cons (cons property value)
                      (cdr plist)))))
        (hash-table/put! eq-properties node
         (list node (cons property value)))))
  'done)

(define (eq-get node property)
  (let ((plist
         (hash-table/get eq-properties node #f)))
    (if plist
        (let ((vcell
               (assq property (cdr plist))))
          (if vcell
              (cdr vcell)
              #f))
        #f)))

(define (eq-rem! node property)
  (let ((plist
         (hash-table/get eq-properties node #f)))
    (if plist
        (let ((vcell
               (assq property (cdr plist))))
          (if vcell
              (hash-table/put!
               eq-properties
               node
               (delq! vcell plist))))))
  'done)

(define (eq-adjoin! node property new)
  (eq-put! node property
           (eq-set/adjoin new
                          (or (eq-get node property)
                              '())))
  'done)

(define (eq-plist node)
  (hash-table/get eq-properties node #f))

(define (eq-path path)
  (define (lp node)
    (if node
        (if (pair? path)
            (eq-get ((eq-path (cdr path)) node)
                    (car path))
            node)
        #f))
  lp)