Решение упражнения 2.58 из SICP
Начнем с более простой части А упражнения. При записи в инфиксной форме с расстановкой всех скобок операции сложения и умножения принимают всегда по два аргумента. Причем порядок следования элементов в списке всегда такой: первый аргумент, знак операции, второй аргумент.
Таким образом мы сразу же достаточно прямолинейным способом получаем определения предикатов, селекторов и конструкторов (в конструкторах не реализовано упрощение выражений для большей наглядности):
(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))))
Обратите внимание на две вещи:
- При проверке на то, является ли выражение произведением, мы сначала убеждаемся в том, что оно не является суммой. Это необходимо делать, так как сложение имеет более низкий приоритет, а значит выражение вида A*B+C является суммой, а не произведением.
- Мы вводим процедуру 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
интересно что существует элегантный метод, позволяющий преодолеть эту потерю в эффективности, основанный на идее “вызова по необходимости”, реализовать который я предлагаю самостоятельно.
Write a comment