Решение упражнения 2.58 из SICP

10 February, 2008 (13:01) | Решения упражнений

Начнем с более простой части А упражнения. При записи в инфиксной форме с расстановкой всех скобок операции сложения и умножения принимают всегда по два аргумента. Причем порядок следования элементов в списке всегда такой: первый аргумент, знак операции, второй аргумент.

Таким образом мы сразу же достаточно прямолинейным способом получаем определения предикатов, селекторов и конструкторов (в конструкторах не реализовано упрощение выражений для большей наглядности):

(define (sum? e)
  (and (pair? e) (eq? (cadr e) '+)))

(define (addend e)
  (car e))

(define (augend e)
  (caddr e))

(define (make-sum a1 a2)
  (list a1 '+ a2))

(define (product? e)
  (and (pair? e) (eq? (cadr e) '*)))

(define (multiplier e)
  (car e))

(define (multiplicand e)
  (caddr e))

(define (make-product m1 m2)
  (list m1 '* m2))

Теперь перейдем к части Б упражнения. Здесь ситуация осложняется тем, что каждая операция уже не задается жестко списком из трех элементов в фиксированном порядке. Для того, чтобы определить, какая операция перед нами, нужно найти то действие, которое будет выполняться первым и, соответственно, по нему определить, что это за операция и к каким операндам она применяется. Для этого введем вспомогательную процедуру split, которая, получив на вход элемент и последовательность, разбивает последовательность на список элементов до заданного элемента и список элементов после заданного элемента и возвращает список из этих двух списков. Если же элемент отсутствует в последовательности, split возвращает null:

(define (split el seq)
  (define (split-iter before after)
    (cond ((null? after) null)
          ((eq? (car after) el) (list before (cdr after)))
          (else (split-iter (append before (list (car after)))
                            (cdr after)))))
  (split-iter '() seq))

С помощью процедуры split мы теперь сможем разделять выражение для суммы или произведения по операции + или * и тем самым определить предикаты и селекторы:

(define (sum? e)
  (and (pair? e)
       (not (null? (split '+ e)))))

(define (omit-parenthesis e)
  (if (null? (cdr e))
      (car e)
      e))

(define (addend e)
  (omit-parenthesis (car (split '+ e))))

(define (augend e)
  (omit-parenthesis (cadr (split '+ e))))

(define (product? e)
  (and (pair? e)
       (not (sum? e))
       (not (null? (split '* e)))))

(define (multiplier e)
  (omit-parenthesis (car (split '* e))))

(define (multiplicand e)
  (omit-parenthesis (cadr (split '* e))))

Обратите внимание на две вещи:

  1. При проверке на то, является ли выражение произведением, мы сначала убеждаемся в том, что оно не является суммой. Это необходимо делать, так как сложение имеет более низкий приоритет, а значит выражение вида A*B+C является суммой, а не произведением.
  2. Мы вводим процедуру omit-parenthesis, которая убирает ненужные скобки вокруг переменных и чисел при получении аргументов сложения и умножения.

Теперь определим конструкторы для сложения и умножения. Здесь нам снова понадобятся вспомогательные процедуры:

(define (add-parenthesis predicate? e)
  (if (predicate? e)
      e
      (list e)))

(define (sum-or-product? e)
  (pair? e))

(define (make-operation op predicate? arg1 arg2)
  (append (add-parenthesis predicate? arg1)
          (list op)
          (add-parenthesis predicate? arg2)))

Процедура add-parenthesis в некотором смысле обратна omit-parenthesis. Она окружает скобками выражения, не удовлетворяющую предикату. Процедура sum-or-product? является предикатом, возвращающим истину на сумме и произведении и ложь на всем остальном. В нашем случае он может быть записан очень просто. Наконец, make-operation выполняет основную работу, соединяя выражения-операнды, окружая их скобками при необходимости.

Записать конструкторы для сложения и умножения очень просто:

(define (make-sum a1 a2)
  (make-operation '+ sum-or-product? a1 a2))

(define (make-product m1 m2)
  (make-operation '* product? m1 m2))

На этом адаптация программы дифференцирования для записей в инфиксной форме завершена. Проверим, как она работает на каком-нибудь примере:

> (deriv '(x + 3 * (x + y + 2)) 'x)
(1 + 3 * (1 + 0 + 0) + 0 * (x + y + 2))

Как видим, расчет производится верно, но полученное в результате выражение можно упростить. Для этого просто слегка модифицируем процедуры-конструкторы, добавив в них абсолютно те же условия, которые были в старых конструкторах, работавших с префиксной формой:

(define (make-sum a1 a2)
  (cond ((=number? a1 0) a2)
        ((=number? a2 0) a1)
        ((and (number? a1) (number? a2)) (+ a1 a2))
        (else (make-operation '+ sum-or-product? a1 a2))))

(define (make-product m1 m2)
  (cond ((or (=number? m1 0) (=number? m2 0)) 0)
        ((=number? m1 1) m2)
        ((=number? m2 1) m1)
        ((and (number? m1) (number? m2)) (* m1 m2))
        (else (make-operation '* product? m1 m2))))

Теперь результат вычисления производной упрощается:

> (deriv '(x + 3 * (x + y + 2)) 'x)
4

То, что правила упрощения не изменились при смене представления выражений, – абсолютно нормально. Это даже подсказывает, что правила упрощения в реальной системе символьного дифференцирования были бы отделены от конструкторов и селекторов и вынесены на более высокий уровень абстракции.

Comments

Comment from Sergey Khenkin
Date: February 10, 2008, 1:08 pm

Если вам хочется применить здесь полноценный синтаксический анализ, это, конечно же, тоже возможно. Этим путем пошел, например, Эли Бендерски в своем решении. Мне, однако, кажется, что суть упражнения заключается совершенно в другом.

Comment from thror
Date: December 14, 2008, 6:13 pm

здравствуйте.

Существует еще один подход к решению данной проблемы, совмещаюший в себе обе идеи-преобразования между представлениями при помощи классической компиляции, и в то же время изменение лишь конструкторов и селекторов.

Представьте, что в нашей системе есть уже реализация конструкторов и селекторов для постфиксного представления выражений.

Но нужно создать конструкторы и селекторы не для простого инфиксного представления, а для какого нибудь более сложного, анализ которого был бы весьма нетривиален. Как быть тогда?

Изящное, хотя и не очень эффективное решение состояло бы в написании компиляторов из этого представления в постфиксную запись, и обратно.

Затем в конструкторах, например суммы, мы преобразуем слагаемые в постфиксный вид, затем собираем из них сумму при помощи известного конструктора для постфиксного вида, и результат преобразуем обратно.

Хоть это и не эффективно в некоторых случаях, но имеет и свои плюсы.

1. Мы можем применять хорошо разработанную технику для написания преобразователей между представлениями. В то время как реализация конструкторов и селекторов может быть не очевидна.
2. Данный подход универсален, и годится в любом случае, когда нам необходимо создать еще одно представление абстрактного типа данных в системе.
З. Этот подход позволяет использовать смешанную технику, когда для каждого из представлений часть конструкторов и селекторов реализуется напрямую, а часть через подобное преобразование.
4. Иногда он по эффективности является оптимальным.

Вообщем, ждите код в ближайшие пару часов. По крайней мере повеселитесь читая его. В нем я следую при построении компиляторов между представлениями классической схеме анализа методом рекурсивного спуска, немного преобразовав грамматику инфиксных выражений для удобства, и используя наследуемые атрибуты. Максимально приближенно к грамматике для понятности.

Более подробно об этом можно почитать в Ахо, Сети, Ульман, Лэм. Компиляторы, принципы технологии и инструменты. 2е издание.

Comment from thror
Date: December 14, 2008, 9:35 pm

;;; SICP: ex2-58b/adt/arith/DERIV-arith-add

(define (make-add lhs rhs)
  (cond ((num-eq? lhs (make-num 0)) rhs)
        ((num-eq? rhs (make-num 0)) lhs)
        ((and (num-is? lhs) (num-is? rhs))
         (make-num (+ (num-val lhs) (num-val rhs))))
        (else (list '+ lhs rhs))))

(define (add-lhs add)
  (cadr add))

(define (add-rhs add)
  (caddr add))

(define (add-is? exp)
  (and (pair? exp) (eq? (car exp) '+)))
;;; SICP: ex2-58b/adt/arith/DERIV-arith-deriv

(define (deriv exp var)
  (cond ((num-is? exp)
         (make-num 0))
        ((var-is? exp)
         (if (var-eq? exp var)
             (make-num 1)
             (make-num 0)))
        ((add-is? exp)
         (make-add (deriv (add-lhs exp) var)
                   (deriv (add-rhs exp) var)))
        ((mul-is? exp)
         (make-add (make-mul (mul-lhs exp)
                             (deriv (mul-rhs exp) var))
                   (make-mul (deriv (mul-lhs exp) var)
                             (mul-rhs exp))))
        ((pow-is? exp)
         (make-mul (pow-rhs exp)
                   (make-mul (make-pow (pow-lhs exp)
                                       (make-num (- (num-val (pow-rhs exp)) 1)))
                             (deriv (pow-lhs exp) var))))
        (else
         (error "Unknown expression type -- DERIV" exp))))
;;; SICP: ex2-58b/adt/arith/DERIV-arith-mul

(define (make-mul lhs rhs)
  (cond ((or (num-eq? lhs (make-num 0))
             (num-eq? rhs (make-num 0)))
         (make-num 0))
        ((num-eq? lhs (make-num 1)) rhs)
        ((num-eq? rhs (make-num 1)) lhs)
        ((and (num-is? lhs) (num-is? rhs))
         (make-num (* (num-val lhs) (num-val rhs))))
        (else (list '* lhs rhs))))

(define (mul-lhs mul)
  (cadr mul))

(define (mul-rhs mul)
  (caddr mul))

(define (mul-is? exp)
  (and (pair? exp) (eq? (car exp) '*)))
;;; SICP: ex2-58b/adt/arith/DERIV-arith-num

(define (make-num lhs)
  lhs)

(define (num-val num)
  num)

(define (num-is? exp)
  (number? exp))

(define (num-eq? exp1 exp2)
  (and (num-is? exp1)
       (num-is? exp2)
       (= (num-val exp1)
          (num-val exp2))))
;;; SICP: ex2-58b/adt/arith/DERIV-arith-pow

(define (make-pow lhs rhs)
  (cond ((num-eq? rhs (make-num 0)) (make-num 1))
        ((num-eq? rhs (make-num 1)) lhs)
        ((and (num-is? lhs) (num-is? rhs))
         (make-num (expt (num-val lhs) (num-val rhs))))
        (else (list '** lhs rhs))))

(define (pow-lhs pow)
  (cadr pow))

(define (pow-rhs pow)
  (caddr pow))

(define (pow-is? exp)
  (and (pair? exp) (eq? (car exp) '**)))
;;; SICP: ex2-58b/adt/iexpr/DERIV-arith-to-inote

(define (arith->inote exp)
  (cond ((num-is? exp) (num-val exp))
        ((var-is? exp) (var-sym exp))
        ((add-is? exp)
         (let ((lhs-inote (arith->inote (add-lhs exp)))
               (rhs-inote (arith->inote (add-rhs exp))))
           (list lhs-inote '+ rhs-inote)))
        ((mul-is? exp)
         (let ((lhs-inote (arith->inote (mul-lhs exp)))
               (rhs-inote (arith->inote (mul-rhs exp))))
           (list lhs-inote '* rhs-inote)))
        ((pow-is? exp)
         (let ((lhs-inote (arith->inote (pow-lhs exp)))
               (rhs-inote (arith->inote (pow-rhs exp))))
           (list lhs-inote '** rhs-inote)))
        (else
         (error "Unknown expression type -- ARITH->INOTE" exp))))
;;; SICP: ex2-58b/adt/pexpr/DERIV-arith-to-pnote

(define (arith->pnote exp)
  (cond ((num-is? exp) (num-val exp))
        ((var-is? exp) (var-sym exp))
        ((add-is? exp)
         (let ((lhs-pnote (arith->pnote (add-lhs exp)))
               (rhs-pnote (arith->pnote (add-rhs exp))))
           (list '+ lhs-pnote rhs-pnote)))
        ((mul-is? exp)
         (let ((lhs-pnote (arith->pnote (mul-lhs exp)))
               (rhs-pnote (arith->pnote (mul-rhs exp))))
           (list '* lhs-pnote rhs-pnote)))
        ((pow-is? exp)
         (let ((lhs-pnote (arith->pnote (pow-lhs exp)))
               (rhs-pnote (arith->pnote (pow-rhs exp))))
           (list '** lhs-pnote rhs-pnote)))
        (else
         (error "Unknown expression type -- ARITH->PNOTE" exp))))
;;; SICP: ex2-58b/adt/yexpr/DERIV-arith-to-ynote

(define (arith->ynote exp)
  (cond ((num-is? exp) (num-val exp))
        ((var-is? exp) (var-sym exp))
        ((add-is? exp)
         (let ((lhs-ynote (arith->ynote (add-lhs exp)))
               (rhs-ynote (arith->ynote (add-rhs exp))))
           (list lhs-ynote '+ rhs-ynote)))
        ((mul-is? exp)
         (let ((lhs-ynote (arith->ynote (mul-lhs exp)))
               (rhs-ynote (arith->ynote (mul-rhs exp))))
           (list lhs-ynote '* rhs-ynote)))
        ((pow-is? exp)
         (let ((lhs-ynote (arith->ynote (pow-lhs exp)))
               (rhs-ynote (arith->ynote (pow-rhs exp))))
           (list lhs-ynote '** rhs-ynote)))
        (else
         (error "Unknown expression type -- ARITH->YNOTE" exp))))
;;; SICP: ex2-58b/adt/arith/DERIV-arith-var

(define (make-var lhs)
  lhs)

(define (var-sym var)
  var)

(define (var-is? exp)
  (symbol? exp))

(define (var-eq? exp1 exp2)
  (and (var-is? exp1)
       (var-is? exp2)
       (eq? (var-sym exp1)
            (var-sym exp2))))
;;; SICP: ex2-58b/adt/iexpr/DERIV-iexpr-add

(define (iexpr-make-add lhs rhs)
  (arith->inote (make-add (inote->arith (lexan lhs))
                          (inote->arith (lexan rhs)))))

(define (iexpr-add-lhs add)
  (arith->inote (add-lhs (inote->arith (lexan add)))))

(define (iexpr-add-rhs add)
  (arith->inote (add-rhs (inote->arith (lexan add)))))

(define (iexpr-add-is? exp)
  (add-is? (inote->arith (lexan exp))))
;;; SICP: ex2-58b/adt/iexpr/DERIV-iexpr-deriv

(define (iexpr-deriv exp var)
  (cond ((iexpr-num-is? exp)
         (iexpr-make-num 0))
        ((iexpr-var-is? exp)
         (if (iexpr-var-eq? exp var)
             (iexpr-make-num 1)
             (iexpr-make-num 0)))
        ((iexpr-add-is? exp)
         (iexpr-make-add (iexpr-deriv (iexpr-add-lhs exp) var)
                         (iexpr-deriv (iexpr-add-rhs exp) var)))
        ((iexpr-mul-is? exp)
         (iexpr-make-add (iexpr-make-mul (iexpr-mul-lhs exp)
                                         (iexpr-deriv (iexpr-mul-rhs exp) var))
                         (iexpr-make-mul (iexpr-deriv (iexpr-mul-lhs exp) var)
                                         (iexpr-mul-rhs exp))))
        ((iexpr-pow-is? exp)
         (iexpr-make-mul (iexpr-pow-rhs exp)
                         (iexpr-make-mul (iexpr-make-pow (iexpr-pow-lhs exp)
                                                         (iexpr-make-num (- (iexpr-num-val (iexpr-pow-rhs exp)) 1)))
                                         (iexpr-deriv (iexpr-pow-lhs exp) var))))
        (else
         (error "Unknown expression type -- DERIV" exp))))
;;; SICP: ex2-58b/adt/iexpr/DERIV-iexpr-mul

(define (iexpr-make-mul lhs rhs)
  (arith->inote (make-mul (inote->arith (lexan lhs))
                          (inote->arith (lexan rhs)))))

(define (iexpr-mul-lhs mul)
  (arith->inote (mul-lhs (inote->arith (lexan mul)))))

(define (iexpr-mul-rhs mul)
  (arith->inote (mul-rhs (inote->arith (lexan mul)))))

(define (iexpr-mul-is? exp)
  (mul-is? (inote->arith (lexan exp))))
;;; SICP: ex2-58b/adt/iexpr/DERIV-iexpr-num

(define (iexpr-make-num lhs)
  (arith->inote (inote->arith (lexan lhs))))

(define (iexpr-num-val num)
  (num-val (inote->arith (lexan num))))

(define (iexpr-num-is? exp)
  (num-is? (inote->arith (lexan exp))))

(define (iexpr-num-eq? exp1 exp2)
  (num-eq? (inote->arith (lexan exp1))
           (inote->arith (lexan exp2))))
;;; SICP: ex2-58b/adt/iexpr/DERIV-iexpr-pow

(define (iexpr-make-pow lhs rhs)
  (arith->inote (make-pow (inote->arith (lexan lhs))
                          (inote->arith (lexan rhs)))))

(define (iexpr-pow-lhs pow)
  (arith->inote (pow-lhs (inote->arith (lexan pow)))))

(define (iexpr-pow-rhs pow)
  (arith->inote (pow-rhs (inote->arith (lexan pow)))))

(define (iexpr-pow-is? exp)
  (pow-is? (inote->arith (lexan exp))))
;;; SICP: ex2-58b/adt/iexpr/DERIV-iexpr-var

(define (iexpr-make-var lhs)
  (arith->inote (inote->arith (lexan lhs))))

(define (iexpr-var-sym var)
  (var-sym (inote->arith (lexan var))))

(define (iexpr-var-is? lhs)
  (symbol? (inote->arith (lexan lhs))))

(define (iexpr-var-eq? exp1 exp2)
  (var-eq? (inote->arith (lexan exp1))
           (inote->arith (lexan exp2))))
;;; SICP: ex2-58b/adt/iexpr/DERIV-inote-to-arith.README

;; (a)

expr
    : expr + term
    ö term
    ;
term
    : term * factor
    ö factor
    ;
factor
    : factor ** power
    ö power
    ;
power
    : ( expr )
    ö VAR
    ö NUMBER
    ;

;; (b)

expr
    : term expr-rest
    ;
expr-rest
    : + term expr-rest
    ö
    ;
term
    : factor term-rest
    ;
term-rest
    : * factor term-rest
    ö
    ;
factor
    : power factor-rest
    ;
factor-rest
    : ** power factor-rest
    ö
    ;
power
    : ( expr )
    ö VAR
    ö NUMBER
    ;

;; (c)

expr
    : term         ä expr-rest.inh = term.node ñ
      expr-rest    ä expr.node = expr-rest.syn ñ
    ;
expr-rest
    : +
      term         ä expr-rest'.inh = make-add(expr-rest.inh, term.node) ñ
      expr-rest'   ä expr-rest.syn = expr-rest'.syn ñ
    ;
expr-rest
    :              ä expr-rest.syn = expr-rest.inh ñ
    ;
term
    : factor       ä term-rest.inh = factor.node ñ
      term-rest    ä term.node = term-rest.syn ñ
    ;
term-rest
    : *
      factor       ä term-rest'.inh = make-mul(term-rest.inh, factor.node) ñ
      term-rest'   ä term-rest.syn = term-rest'.syn ñ
    ;
term-rest
    :              ä term-rest.syn = term-rest.inh ñ
    ;
factor
    : power        ä factor-rest.inh = power.node ñ
      factor-rest  ä factor.node = factor-rest.syn ñ
    ;
factor-rest
    : **
      power        ä factor-rest'.inh = make-pow(factor-rest.inh, power.node) ñ
      factor-rest' ä factor-rest.syn = factor-rest'.syn ñ
    ;
factor-rest
    :              ä factor-rest.syn = factor-rest.inh ñ
    ;
power
    : (
      expr
      )            ä power-node = expr.node ñ
    ;
power
    : VAR          ä power-node = make-var(VAR.sym) ñ
    ;
power
    : NUMBER       ä power-node = make-num(NUMBER.val) ñ
    ;
;;; SICP: ex2-58b/adt/iexpr/DERIV-inote-to-arith

(define (inote->arith scan)
  (define lookahead (scan))

  (define (move)
    (set! lookahead (scan)))

  (define (match tag)
    (if (eq? (token-tag lookahead) tag)
        (move)
        (error "Syntax error -- INOTE->ARITH")))

  (define (parse-expr)
    ;; expr : term expr-rest
    (let* ((term-node (parse-term))
           (expr-rest-inh term-node)
           (expr-rest-syn (parse-expr-rest expr-rest-inh))
           (expr-node expr-rest-syn))
      expr-node))

  (define (parse-expr-rest inh)
    (cond ((eq? (token-tag lookahead) '*add*)
           ;; expr-rest : + term expr-rest
           (match '*add*)
           (let* ((term-node (parse-term))
                  (expr-rest-inh (make-add inh term-node))
                  (expr-rest-syn (parse-expr-rest expr-rest-inh))
                  (syn expr-rest-syn))
             syn))
          (else
           ;; expr-rest : *epsilon*
           (let* ((syn inh))
             syn))))

  (define (parse-term)
    ;; term : factor term-rest
    (let* ((factor-node (parse-factor))
           (term-rest-inh factor-node)
           (term-rest-syn (parse-term-rest term-rest-inh))
           (term-node term-rest-syn))
      term-node))

  (define (parse-term-rest inh)
    (cond ((eq? (token-tag lookahead) '*mul*)
           ;; term-rest : * factor term-rest
           (match '*mul*)
           (let* ((factor-node (parse-factor))
                  (term-rest-inh (make-mul inh factor-node))
                  (term-rest-syn (parse-term-rest term-rest-inh))
                  (syn term-rest-syn))
             syn))
          (else
           ;; term-rest : *epsilon*
           (let* ((syn inh))
             syn))))

  (define (parse-factor)
    ;; factor : power factor-rest
    (let* ((power-node (parse-power))
           (factor-rest-inh power-node)
           (factor-rest-syn (parse-factor-rest factor-rest-inh))
           (factor-node factor-rest-syn))
      factor-node))

  (define (parse-factor-rest inh)
    (cond ((eq? (token-tag lookahead) '*pow*)
           ;; factor-rest : ** power factor-rest
           (match '*pow*)
           (let* ((power-node (parse-power))
                  (factor-rest-inh (make-pow inh power-node))
                  (factor-rest-syn (parse-factor-rest factor-rest-inh))
                  (syn factor-rest-syn))
             syn))
          (else
           ;; factor-rest : *epsilon*
           (let* ((syn inh))
             syn))))

  (define (parse-power)
    (cond ((eq? (token-tag lookahead) '*exp*)
           ;; power : ( expr )
           (let* ((expr-node (inote->arith (lexan (token-val lookahead))))
                  (power-node expr-node))
             (match '*exp*)
             power-node))
          ((eq? (token-tag lookahead) '*num*)
           ;; power : NUMBER
           (let* ((power-node (make-num (token-val lookahead))))
             (match '*num*)
             power-node))
          ((eq? (token-tag lookahead) '*var*)
           ;; power : VAR
           (let* ((power-node (make-var (token-val lookahead))))
             (match '*var*)
             power-node))
          (else
           (error "Syntax error -- INOTE->ARITH"))))

  (parse-expr))
;;; SICP: ex2-58b/adt/lexan/DERIV-lexan-lexan

(define (lexan exp)
  (define (dispatch sym)
    (cond ((eq? sym '+)
           (make-token '*add* sym))
          ((eq? sym '*)
           (make-token '*mul* sym))
          ((eq? sym '**)
           (make-token '*pow* sym))
          ((number? sym)
           (make-token '*num* sym))
          ((symbol? sym)
           (make-token '*var* sym))
          ((pair? sym)
           (make-token '*exp* sym))
          (else
           (make-token '*foo* sym))))

  (lambda ()
    (cond ((null? exp)
           (make-token '*eof* '()))
          ((pair? exp)
           (let ((sym (car exp)))
             (set! exp (cdr exp))
             (dispatch sym)))
          (else
           (let ((sym exp))
             (set! exp '())
             (dispatch sym))))))
;;; SICP: ex2-58b/adt/lexan/DERIV-lexan-token

(define (make-token tag val)
  (cons tag val))

(define (token-tag token)
  (car token))

(define (token-val token)
  (cdr token))
;;; SICP: ex2-58b/adt/pexpr/DERIV-pexpr-add

(define (pexpr-make-add lhs rhs)
  (arith->pnote (make-add (pnote->arith (lexan lhs))
                          (pnote->arith (lexan rhs)))))

(define (pexpr-add-lhs add)
  (arith->pnote (add-lhs (pnote->arith (lexan add)))))

(define (pexpr-add-rhs add)
  (arith->pnote (add-rhs (pnote->arith (lexan add)))))

(define (pexpr-add-is? exp)
  (add-is? (pnote->arith (lexan exp))))
;;; SICP: ex2-58b/adt/pexpr/DERIV-pexpr-deriv

(define (pexpr-deriv exp var)
  (cond ((pexpr-num-is? exp)
         (pexpr-make-num 0))
        ((pexpr-var-is? exp)
         (if (pexpr-var-eq? exp var)
             (pexpr-make-num 1)
             (pexpr-make-num 0)))
        ((pexpr-add-is? exp)
         (pexpr-make-add (pexpr-deriv (pexpr-add-lhs exp) var)
                         (pexpr-deriv (pexpr-add-rhs exp) var)))
        ((pexpr-mul-is? exp)
         (pexpr-make-add (pexpr-make-mul (pexpr-mul-lhs exp)
                                         (pexpr-deriv (pexpr-mul-rhs exp) var))
                         (pexpr-make-mul (pexpr-deriv (pexpr-mul-lhs exp) var)
                                         (pexpr-mul-rhs exp))))
        ((pexpr-pow-is? exp)
         (pexpr-make-mul (pexpr-pow-rhs exp)
                         (pexpr-make-mul (pexpr-make-pow (pexpr-pow-lhs exp)
                                                         (pexpr-make-num (- (pexpr-num-val (pexpr-pow-rhs exp)) 1)))
                                         (pexpr-deriv (pexpr-pow-lhs exp) var))))
        (else
         (error "Unknown expression type -- DERIV" exp))))
;;; SICP: ex2-58b/adt/pexpr/DERIV-pexpr-mul

(define (pexpr-make-mul lhs rhs)
  (arith->pnote (make-mul (pnote->arith (lexan lhs))
                          (pnote->arith (lexan rhs)))))

(define (pexpr-mul-lhs mul)
  (arith->pnote (mul-lhs (pnote->arith (lexan mul)))))

(define (pexpr-mul-rhs mul)
  (arith->pnote (mul-rhs (pnote->arith (lexan mul)))))

(define (pexpr-mul-is? exp)
  (mul-is? (pnote->arith (lexan exp))))
;;; SICP: ex2-58b/adt/pexpr/DERIV-pexpr-num

(define (pexpr-make-num lhs)
  (arith->pnote (pnote->arith (lexan lhs))))

(define (pexpr-num-val num)
  (num-val (pnote->arith (lexan num))))

(define (pexpr-num-is? exp)
  (num-is? (pnote->arith (lexan exp))))

(define (pexpr-num-eq? exp1 exp2)
  (num-eq? (pnote->arith (lexan exp1))
           (pnote->arith (lexan exp2))))
;;; SICP: ex2-58b/adt/pexpr/DERIV-pexpr-pow

(define (pexpr-make-pow lhs rhs)
  (arith->pnote (make-pow (pnote->arith (lexan lhs))
                          (pnote->arith (lexan rhs)))))

(define (pexpr-pow-lhs pow)
  (arith->pnote (pow-lhs (pnote->arith (lexan pow)))))

(define (pexpr-pow-rhs pow)
  (arith->pnote (pow-rhs (pnote->arith (lexan pow)))))

(define (pexpr-pow-is? exp)
  (pow-is? (pnote->arith (lexan exp))))
;;; SICP: ex2-58b/adt/pexpr/DERIV-pexpr-var

(define (pexpr-make-var lhs)
  (arith->pnote (pnote->arith (lexan lhs))))

(define (pexpr-var-sym var)
  (var-sym (pnote->arith (lexan var))))

(define (pexpr-var-is? lhs)
  (symbol? (pnote->arith (lexan lhs))))

(define (pexpr-var-eq? exp1 exp2)
  (var-eq? (pnote->arith (lexan exp1))
           (pnote->arith (lexan exp2))))
;;; SICP: ex2-58b/adt/pexpr/DERIV-pnote-to-arith.README

;; (a)

expr
    : +  expr expr
    ö *  expr expr
    ö ** expr expr
    ö ( expr )
    ö VAR
    ö NUMBER
    ;

;; (b)

expr
    : +  expr' expr''  ä expr.node = make-add(expr'.node, expr''.node) ñ
    ö *  expr' expr''  ä expr.node = make-mul(expr'.node, expr''.node) ñ
    ö ** expr' expr''  ä expr.node = make-pow(expr'.node, expr''.node) ñ
    ö ( expr' )        ä expr.node = expr'.node ñ
    ö VAR              ä expr.node = make-var(VAR.sym) ñ
    ö NUMBER           ä expr.node = make-num(NUMBER.val) ñ
    ;
;;; SICP: ex2-58b/adt/pexpr/DERIV-pnote-to-arith

(define (pnote->arith scan)
  (define lookahead (scan))

  (define (move)
    (set! lookahead (scan)))

  (define (match tag)
    (if (eq? (token-tag lookahead) tag)
        (move)
        (error "Syntax error -- PNOTE->ARITH")))

  (define (parse-expr)
    (cond ((eq? (token-tag lookahead) '*add*)
           ;; expr : + expr expr
           (match '*add*)
           (let* ((lhs-expr-node (parse-expr))
                  (rhs-expr-node (parse-expr))
                  (expr-node (make-add lhs-expr-node rhs-expr-node)))
             expr-node))
          ((eq? (token-tag lookahead) '*mul*)
           ;; expr : * expr expr
           (match '*mul*)
           (let* ((lhs-expr-node (parse-expr))
                  (rhs-expr-node (parse-expr))
                  (expr-node (make-mul lhs-expr-node rhs-expr-node)))
             expr-node))
          ((eq? (token-tag lookahead) '*pow*)
           ;; expr : ** expr expr
           (match '*pow*)
           (let* ((lhs-expr-node (parse-expr))
                  (rhs-expr-node (parse-expr))
                  (expr-node (make-pow lhs-expr-node rhs-expr-node)))
             expr-node))
          ((eq? (token-tag lookahead) '*exp*)
           ;; expr : ( expr )
           (let* ((expr-node (pnote->arith (lexan (token-val lookahead)))))
             (match '*exp*)
             expr-node))
          ((eq? (token-tag lookahead) '*num*)
           ;; expr : NUMBER
           (let* ((expr-node (make-num (token-val lookahead))))
             (match '*num*)
             expr-node))
          ((eq? (token-tag lookahead) '*var*)
           ;; expr : VAR
           (let* ((expr-node (make-var (token-val lookahead))))
             (match '*var*)
             expr-node))
          (else
           (error "Syntax error -- PNOTE->ARITH"))))

  (parse-expr))
;;; SICP: ex2-58b/adt/yexpr/DERIV-yexpr-add

(define (yexpr-make-add lhs rhs)
  (arith->ynote (make-add (ynote->arith (lexan lhs))
                          (ynote->arith (lexan rhs)))))

(define (yexpr-add-lhs add)
  (arith->ynote (add-lhs (ynote->arith (lexan add)))))

(define (yexpr-add-rhs add)
  (arith->ynote (add-rhs (ynote->arith (lexan add)))))

(define (yexpr-add-is? exp)
  (add-is? (ynote->arith (lexan exp))))
;;; SICP: ex2-58b/adt/yexpr/DERIV-yexpr-deriv

(define (yexpr-deriv exp var)
  (cond ((yexpr-num-is? exp)
         (yexpr-make-num 0))
        ((yexpr-var-is? exp)
         (if (yexpr-var-eq? exp var)
             (yexpr-make-num 1)
             (yexpr-make-num 0)))
        ((yexpr-add-is? exp)
         (yexpr-make-add (yexpr-deriv (yexpr-add-lhs exp) var)
                         (yexpr-deriv (yexpr-add-rhs exp) var)))
        ((yexpr-mul-is? exp)
         (yexpr-make-add (yexpr-make-mul (yexpr-mul-lhs exp)
                                         (yexpr-deriv (yexpr-mul-rhs exp) var))
                         (yexpr-make-mul (yexpr-deriv (yexpr-mul-lhs exp) var)
                                         (yexpr-mul-rhs exp))))
        ((yexpr-pow-is? exp)
         (yexpr-make-mul (yexpr-pow-rhs exp)
                         (yexpr-make-mul (yexpr-make-pow (yexpr-pow-lhs exp)
                                                         (yexpr-make-num (- (yexpr-num-val (yexpr-pow-rhs exp)) 1)))
                                         (yexpr-deriv (yexpr-pow-lhs exp) var))))
        (else
         (error "Unknown expression type -- DERIV" exp))))
;;; SICP: ex2-58b/adt/yexpr/DERIV-yexpr-mul

(define (yexpr-make-mul lhs rhs)
  (arith->ynote (make-mul (ynote->arith (lexan lhs))
                          (ynote->arith (lexan rhs)))))

(define (yexpr-mul-lhs mul)
  (arith->ynote (mul-lhs (ynote->arith (lexan mul)))))

(define (yexpr-mul-rhs mul)
  (arith->ynote (mul-rhs (ynote->arith (lexan mul)))))

(define (yexpr-mul-is? exp)
  (mul-is? (ynote->arith (lexan exp))))
;;; SICP: ex2-58b/adt/yexpr/DERIV-yexpr-num

(define (yexpr-make-num lhs)
  (arith->ynote (ynote->arith (lexan lhs))))

(define (yexpr-num-val num)
  (num-val (ynote->arith (lexan num))))

(define (yexpr-num-is? exp)
  (num-is? (ynote->arith (lexan exp))))

(define (yexpr-num-eq? exp1 exp2)
  (num-eq? (ynote->arith (lexan exp1))
           (ynote->arith (lexan exp2))))
;;; SICP: ex2-58b/adt/yexpr/DERIV-yexpr-pow

(define (yexpr-make-pow lhs rhs)
  (arith->ynote (make-pow (ynote->arith (lexan lhs))
                          (ynote->arith (lexan rhs)))))

(define (yexpr-pow-lhs pow)
  (arith->ynote (pow-lhs (ynote->arith (lexan pow)))))

(define (yexpr-pow-rhs pow)
  (arith->ynote (pow-rhs (ynote->arith (lexan pow)))))

(define (yexpr-pow-is? exp)
  (pow-is? (ynote->arith (lexan exp))))
;;; SICP: ex2-58b/adt/yexpr/DERIV-yexpr-var

(define (yexpr-make-var lhs)
  (arith->ynote (ynote->arith (lexan lhs))))

(define (yexpr-var-sym var)
  (var-sym (ynote->arith (lexan var))))

(define (yexpr-var-is? lhs)
  (symbol? (ynote->arith (lexan lhs))))

(define (yexpr-var-eq? exp1 exp2)
  (var-eq? (ynote->arith (lexan exp1))
           (ynote->arith (lexan exp2))))
;;; SICP: ex2-58b/adt/yexpr/DERIV-ynote-to-arith.README

;; (a)

expr
    : term +  term
    ö term *  term
    ö term ** term
    ö term
    ;

term
    : ( expr )
    ö VAR
    ö NUMBER
    ;

;; (b)

expr
    : term expr-rest
    ;
expr-rest
    : +  term
    ö *  term
    ö ** term
    ö
    ;
term
    : ( expr )
    ö VAR
    ö NUMBER
    ;

;; (c)

expr
    : term       ä expr-rest.inh = term.node ñ
      expr-rest  ä expr.node = expr-rest.syn ñ
    ;
expr-rest
    : +
      term       ä expr-rest.syn = make-add(expr-rest.inh, term.node) ñ
    ;
expr-rest
    : *
      term       ä expr-rest.syn = make-mul(expr-rest.inh, term.node) ñ
    ;
expr-rest
    : **
      term       ä expr-rest.syn = make-pow(expr-rest.inh, term.node) ñ
    ;
expr-rest
    :            ä expr-rest.syn = expr-rest.inh ñ
    ;
term
    : (
      expr
      )          ä term.node = expr.node ñ
    ;
term
    : VAR        ä term.node = make-var(VAR.sym) ñ
    ;
term
    : NUMBER     ä term.node = make-num(NUMBER.val) ñ
    ;
;;; SICP: ex2-58b/adt/yexpr/DERIV-ynote-to-arith

(define (ynote->arith scan)
  (define lookahead (scan))

  (define (move)
    (set! lookahead (scan)))

  (define (match tag)
    (if (eq? (token-tag lookahead) tag)
        (move)
        (error "Syntax error -- YNOTE->ARITH")))

  (define (parse)
    ;; expr' : expr EOF
    (let* ((expr-node (parse-expr)))
      (match '*eof*)
      expr-node))

  (define (parse-expr)
    ;; expr : term expr-rest
    (let* ((term-node (parse-term))
           (expr-rest-inh term-node)
           (expr-rest-syn (parse-expr-rest expr-rest-inh))
           (expr-node expr-rest-syn))
      expr-node))

  (define (parse-expr-rest inh)
    (cond ((eq? (token-tag lookahead) '*add*)
           ;; expr-rest : + term
           (match '*add*)
           (let* ((term-node (parse-term))
                  (expr-rest-syn (make-add inh term-node))
                  (syn expr-rest-syn))
             syn))
          ((eq? (token-tag lookahead) '*mul*)
           ;; expr-rest : * term
           (match '*mul*)
           (let* ((term-node (parse-term))
                  (expr-rest-syn (make-mul inh term-node))
                  (syn expr-rest-syn))
             syn))
          ((eq? (token-tag lookahead) '*pow*)
           ;; expr-rest : ** term
           (match '*pow*)
           (let* ((term-node (parse-term))
                  (expr-rest-syn (make-pow inh term-node))
                  (syn expr-rest-syn))
             syn))
          (else
           ;; expr-rest : *epsilon*
           (let* ((syn inh))
             syn))))

  (define (parse-term)
    (cond ((eq? (token-tag lookahead) '*exp*)
           ;; term : ( expr )
           (let* ((expr-node (ynote->arith (lexan (token-val lookahead))))
                  (term-node expr-node))
             (match '*exp*)
             term-node))
          ((eq? (token-tag lookahead) '*num*)
           ;; term : NUMBER
           (let* ((term-node (make-num (token-val lookahead))))
             (match '*num*)
             term-node))
          ((eq? (token-tag lookahead) '*var*)
           ;; term : VAR
           (let* ((term-node (make-var (token-val lookahead))))
             (match '*var*)
             term-node))
          (else
           (error "Syntax error -- YNOTE-ARITH"))))

  (parse))
;;; SICP: ex2-58b/adt/DERIV.README

;; IEXPR

expr
    : expr + term
    ö term
    ;
term
    : term * factor
    ö factor
    ;
factor
    : factor ** power
    ö power
    ;
power
    : ( expr )
    ö VAR
    ö NUMBER
    ;

;; PEXPR

expr
    : +  expr expr
    ö *  expr expr
    ö ** expr expr
    ö ( expr )
    ö VAR
    ö NUMBER
    ;

;; YEXPR

expr
    : term +  term
    ö term *  term
    ö term ** term
    ;
term
    : ( expr )
    ö VAR
    ö NUMBER
    ;
;;; SICP: ex2-58b/adt/DERIV

(load "arith/DERIV-arith-num.scm")
(load "arith/DERIV-arith-var.scm")
(load "arith/DERIV-arith-add.scm")
(load "arith/DERIV-arith-mul.scm")
(load "arith/DERIV-arith-pow.scm")
(load "arith/DERIV-arith-deriv.scm")

(load "lexan/DERIV-lexan-token.scm")
(load "lexan/DERIV-lexan-lexan.scm")

(load "iexpr/DERIV-arith-to-inote.scm")
(load "iexpr/DERIV-inote-to-arith.scm")
(load "iexpr/DERIV-iexpr-num.scm")
(load "iexpr/DERIV-iexpr-var.scm")
(load "iexpr/DERIV-iexpr-add.scm")
(load "iexpr/DERIV-iexpr-mul.scm")
(load "iexpr/DERIV-iexpr-pow.scm")
(load "iexpr/DERIV-iexpr-deriv.scm")

(load "pexpr/DERIV-arith-to-pnote.scm")
(load "pexpr/DERIV-pnote-to-arith.scm")
(load "pexpr/DERIV-pexpr-num.scm")
(load "pexpr/DERIV-pexpr-var.scm")
(load "pexpr/DERIV-pexpr-add.scm")
(load "pexpr/DERIV-pexpr-mul.scm")
(load "pexpr/DERIV-pexpr-pow.scm")
(load "pexpr/DERIV-pexpr-deriv.scm")

(load "yexpr/DERIV-arith-to-ynote.scm")
(load "yexpr/DERIV-ynote-to-arith.scm")
(load "yexpr/DERIV-yexpr-num.scm")
(load "yexpr/DERIV-yexpr-var.scm")
(load "yexpr/DERIV-yexpr-add.scm")
(load "yexpr/DERIV-yexpr-mul.scm")
(load "yexpr/DERIV-yexpr-pow.scm")
(load "yexpr/DERIV-yexpr-deriv.scm")

Comment from thror
Date: December 23, 2008, 7:23 pm

так длинно лишь потому что код приведен одновременно для четырех различных представлений. Но это позволяет лучше понять идею. Фактически для каждого представления уникальными являются два преобразователя. Остальной код-идентичен. Количественную потерю в эффективности сумеете оценить сами. Имена конструкторов и селекторов изменены лишь для того, чтоб все представления могли без конфликтов сосуществовать одновременно.

Comment from thror
Date: December 23, 2008, 7:29 pm

интересно что существует элегантный метод, позволяющий преодолеть эту потерю в эффективности, основанный на идее “вызова по необходимости”, реализовать который я предлагаю самостоятельно.

Comment from Irv
Date: January 2, 2017, 10:56 pm

предикаты (не зависят друг от друга, как у автора)

(define (sum? x)
  (pair?
   (filter
    (lambda(i) (eq? i '+))
    x)))

(define (product? x)
  (pair?
   (filter
    (lambda(i) (eq? i '*))
    x)))  

слагаемые (выражение до + и выражение после +)

(define (addend x)
  (define (iter result tail)
    (if (eq? '+ (car tail))
        (if (null? (cdr result))
            (car result)
            result)
        (iter (cons (car tail) result) (cdr tail))))   
  (iter '() x))
  
(define (augend x)
  (if (eq? '+ (car x))
      (if (null? (cdr (cdr x)))
          (car (cdr x))
          (cdr x))
      (augend (cdr x))))

аналогично, множители

(define (multiplier x)
  (define (iter result tail)
    (if (eq? '* (car tail))
        (if (null? (cdr result))
            (car result)
            result)
        (iter (cons (car tail) result) (cdr tail))))   
  (iter '() x))
  
(define (multiplicand x)
  (if (eq? '* (car x))
      (if (null? (cdr (cdr x)))
          (car (cdr x))
          (cdr x))
      (multiplicand (cdr x))))

Write a comment