运行基于 SICP 模式匹配规则的替换代码

Question

我在网上找到了本课的代码 (http://groups.csail.mit.edu/mac/ftpdir/6.001-fall91/ps4/matcher-from-lecture.scm)，我很高兴尝试调试它的时间。该代码看起来与 Sussman 编写的代码相当：

;;; Scheme code from the Pattern Matcher lecture

;; Pattern Matching and Simplification

(define (match pattern expression dictionary)
  (cond ((eq? dictionary 'failed) 'failed)
        ((atom? pattern)
         (if (atom? expression)
             (if (eq? pattern expression)
                 dictionary
                 'failed)
             'failed))
        ((arbitrary-constant? pattern)
         (if (constant? expression)
             (extend-dictionary pattern expression dictionary)
             'failed))
        ((arbitrary-variable? pattern)
         (if (variable? expression)
             (extend-dictionary pattern expression dictionary)
             'failed))
        ((arbitrary-expression? pattern)
         (extend-dictionary pattern expression dictionary))
        ((atom? expression) 'failed)
        (else
         (match (cdr pattern)
                (cdr expression)
                (match (car pattern)
                       (car expression)
                       dictionary)))))

(define (instantiate skeleton dictionary)
  (cond ((atom? skeleton) skeleton)
        ((skeleton-evaluation? skeleton)
         (evaluate (evaluation-expression skeleton)
                   dictionary))
        (else (cons (instantiate (car skeleton) dictionary)
                    (instantiate (cdr skeleton) dictionary)))))

(define (simplifier the-rules)
  (define (simplify-exp exp)
    (try-rules (if (compound? exp)
                   (simplify-parts exp)
                   exp)))
  (define (simplify-parts exp)
    (if (null? exp)
        '()
        (cons (simplify-exp   (car exp))
              (simplify-parts (cdr exp)))))
  (define (try-rules exp)
    (define (scan rules)
      (if (null? rules)
          exp
          (let ((dictionary (match (pattern (car rules))
                                   exp
                                   (make-empty-dictionary))))
            (if (eq? dictionary 'failed)
                (scan (cdr rules))
                (simplify-exp (instantiate (skeleton (car rules))
                                           dictionary))))))
    (scan the-rules))
  simplify-exp)

;; Dictionaries 

(define (make-empty-dictionary) '())

(define (extend-dictionary pat dat dictionary)
  (let ((vname (variable-name pat)))
    (let ((v (assq vname dictionary)))
      (cond ((null? v)
             (cons (list vname dat) dictionary))
            ((eq? (cadr v) dat) dictionary)
            (else 'failed)))))

(define (lookup var dictionary)
  (let ((v (assq var dictionary)))
    (if (null? v)
        var
        (cadr v))))

;; Expressions

(define (compound? exp) (pair?   exp))
(define (constant? exp) (number? exp))
(define (variable? exp) (atom?   exp))

;; Rules

(define (pattern  rule) (car  rule))
(define (skeleton rule) (cadr rule))

;; Patterns

(define (arbitrary-constant?    pattern)
  (if (pair? pattern) (eq? (car pattern) '?c) false))

(define (arbitrary-expression?  pattern)
  (if (pair? pattern) (eq? (car pattern) '? ) false))

(define (arbitrary-variable?    pattern)
  (if (pair? pattern) (eq? (car pattern) '?v) false))

(define (variable-name pattern) (cadr pattern))

;; Skeletons & Evaluations

(define (skeleton-evaluation?    skeleton)
  (if (pair? skeleton) (eq? (car skeleton) ':) false))

(define (evaluation-expression evaluation) (cadr evaluation))


;; Evaluate (dangerous magic)

(define (evaluate form dictionary)
  (if (atom? form)
      (lookup form dictionary)
      (apply (eval (lookup (car form) dictionary)
                   user-initial-environment)
             (mapcar (lambda (v) (lookup v dictionary))
                     (cdr form)))))

;;
;; A couple sample rule databases...
;;

;; Algebraic simplification

(define algebra-rules
  '(
    ( ((? op) (?c c1) (?c c2))                (: (op c1 c2))                )
    ( ((? op) (?  e ) (?c c ))                ((: op) (: c) (: e))          )
    ( (+ 0 (? e))                             (: e)                         )
    ( (* 1 (? e))                             (: e)                         )
    ( (* 0 (? e))                             0                             )
    ( (* (?c c1) (* (?c c2) (? e )))          (* (: (* c1 c2)) (: e))       )
    ( (* (?  e1) (* (?c c ) (? e2)))          (* (: c ) (* (: e1) (: e2)))  )
    ( (* (* (? e1) (? e2)) (? e3))            (* (: e1) (* (: e2) (: e3)))  )
    ( (+ (?c c1) (+ (?c c2) (? e )))          (+ (: (+ c1 c2)) (: e))       )
    ( (+ (?  e1) (+ (?c c ) (? e2)))          (+ (: c ) (+ (: e1) (: e2)))  )
    ( (+ (+ (? e1) (? e2)) (? e3))            (+ (: e1) (+ (: e2) (: e3)))  )
    ( (+ (* (?c c1) (? e)) (* (?c c2) (? e))) (* (: (+ c1 c2)) (: e))       )
    ( (* (? e1) (+ (? e2) (? e3)))            (+ (* (: e1) (: e2))
                                                 (* (: e1) (: e3)))         )
    ))

(define algsimp (simplifier algebra-rules))

;; Symbolic Differentiation

(define deriv-rules
  '(
    ( (dd (?c c) (? v))              0                                 )
    ( (dd (?v v) (? v))              1                                 )
    ( (dd (?v u) (? v))              0                                 )
    ( (dd (+ (? x1) (? x2)) (? v))   (+ (dd (: x1) (: v))
                                        (dd (: x2) (: v)))             )
    ( (dd (* (? x1) (? x2)) (? v))   (+ (* (: x1) (dd (: x2) (: v)))
                                        (* (dd (: x1) (: v)) (: x2)))  )
    ( (dd (** (? x) (?c n)) (? v))   (* (* (: n) (+ (: x) (: (- n 1))))
                                        (dd (: x) (: v)))              )
    ))

(define dsimp (simplifier deriv-rules))

(define scheme-rules
  '(( (square (?c n)) (: (* n n)) )
    ( (fact 0) 1 )
    ( (fact (?c n)) (* (: n) (fact (: (- n 1)))) )
    ( (fib 0) 0 )
    ( (fib 1) 1 )
    ( (fib (?c n)) (+ (fib (: (- n 1)))
                      (fib (: (- n 2)))) )
    ( ((? op) (?c e1) (?c e2)) (: (op e1 e2)) ) ))

(define scheme-evaluator (simplifier scheme-rules))

我在 DrRacket 中使用 R5RS 运行它，我遇到的第一个问题是那个原子？是一个未定义的标识符。所以，我发现我可以添加以下内容：

    (define (atom? x) ; atom? is not in a pair or null (empty)
    (and (not (pair? x))
    (not (null? x))))

然后我试图弄清楚如何真正运行这个野兽，所以我再次观看了视频并看到他使用以下内容：

(dsimp '(dd (+ x y) x))

正如 Sussman 所说，我应该回来 (+ 1 0)。相反，使用 R5RS 我似乎打破了扩展字典程序：

((eq? (cadr v) dat) dictionary) 

它返回的具体错误是：mcdr: expects argument of type mutable-pair;给定#f

当使用 neil/sicp 时，我在评估过程中中断了这一行：

(apply (eval (lookup (car form) dictionary)
                   user-initial-environment)

它返回的具体错误是：unbound identifier in module in: user-initial-environment

所以，说了这么多，我会很感激一些帮助，或者是朝着正确方向的一个很好的推动。谢谢！

Answer 1

您的代码来自 1991 年。由于 R5RS 于 1998 年问世，因此必须为 R4RS（或更早版本）编写代码。 R4RS 和后来的方案之间的区别之一是空列表在 R4RS 中被解释为 false，而在 R5RS 中被解释为 true。

例子：

  (if '() 1 2)

在 R5RS 中给出 1，但在 R4RS 中给出 2。

因此，诸如 assq 之类的过程可能会返回 '() 而不是 false。 这就是为什么您需要将extend-directory的定义更改为：

(define (extend-dictionary pat dat dictionary)
  (let ((vname (variable-name pat)))
    (let ((v (assq vname dictionary)))
      (cond ((not v)
             (cons (list vname dat) dictionary))
            ((eq? (cadr v) dat) dictionary)
            (else 'failed)))))

当时地图也被称为地图车。只需将 mapcar 替换为 map。

您在 DrRacket 中看到的错误是：

mcdr: expects argument of type <mutable-pair>; given '()

这意味着 cdr 得到了一个空列表。由于一个空列表有 no cdr 这会给出错误消息。现在 DrRacket 写 mcdr 而不是 cdr，但现在忽略它。

最佳建议：一次通过一个函数并使用 REPL 中的一些表达式。这比计算容易 一下子搞定一切。

最后开始你的程序：

(define user-initial-environment (scheme-report-environment 5))

与 R4RS（或 1991 年的 MIT 计划？）的另一个变化。

附录：

这段代码http://pages.cs.brandeis.edu/~mairson/Courses/cs21b/sym-diff.scm 几乎可以运行。 在 DrRacket 中添加前缀：

#lang r5rs
(define false #f)
(define user-initial-environment (scheme-report-environment 5))
(define mapcar map)

然后在扩展目录中将 (null?v) 更改为 (not v)。 这至少适用于简单的表达式。

Answer 2

Here 是适用于我的 mit-scheme（版本 9.1.1）的代码。

Answer 3

您也可以使用this code。它在 Racket 上运行。

为了不出错地运行“eval”，需要添加以下内容

(define ns (make-base-namespace))
(apply (eval '+ ns) '(1 2 3))