オンラインSICP読書女子会 #26 (2.3.2) #SICP

練習問題 2.56 - 2.58

うちのコードだんだん無駄にややこしさましましでちょっとアレ（）
シンプルさをもっと心がけなきゃ…＞ω＜;

2.3.2. 例: 記号微分

抽象データによる微分プログラム

今回使うデータ構造.
述語関数とコンストラクタとセレクタと. いっぱい.

(variable? e) e は変数か?
(same-variable? v1 v2) v1 と v2 は同じ変数か?
(sum? e) e は和か?
(addend e) 和 e の加数
(augend e) 和 e の被加数
(make-sum a1 a2) a1 と a2 の和を構築する
(product? e) e は積か?
(multiplier e) 積 e の定数
(multiplicand e) 積 e の被乗数
(make-product m1 m2) m1 と m2 の積を構築する

メインの記号微分の実装関数〜.
expression は exp より expr のほうがなんとなく好み.

(define (deriv exp var)
    (cond
        ((number? exp) 0)
        ((variable? exp)
            (if (same-variable? exp var) 1 0))
        ((sum? exp)
            (make-sum
                (deriv (addend exp) var)
                (deriv (augend exp) var)))
        ((product? exp)
            (make-sum
                (make-product
                    (multiplier exp)
                    (deriv (multiplicand exp) var))
                (make-product
                    (deriv (multiplier exp) var)
                    (multiplicand exp))))
        (else
            (error "unknown expression type: DERIV" exp))))

while a, b, and c are addends in a+b+c, a is the augend
augend - Wolfram|Alpha

in the expression a+b+c, a, b, and c are all addends
addend - Wolfram|Alpha

むしろ augend (被加数) が左辺で addend (加数) が右辺なのでは?・ω・;

当日の会話で a + b を (+ b a) って表現してるのなら成立する!?って思ったけど, 問題文で「 ax + b は (+ (* a x) b)と表現することになります」ってあったしそういうわけでもなさそう＝ω＝;

多項式の掛け算の微分ってこんな風にできるのね。もはやかけらも記憶に残ってない（）

代数式を表現する

データ構造用の関数の実装.
cadr とか caddr とかいまいち場所把握しづらいので (list-ref list index) のほう使いたい＝ω＝;

; [sec-2.3.2-a.scm]
;
(define (sec-2.3.2-a)
    (print "(deriv '(+ x 3) 'x)")
    (print ";==> " (deriv '(+ x 3) 'x))
    (print "(deriv '(* x y) 'x)")
    (print ";==> " (deriv '(* x y) 'x))
    (print "(deriv '(* (* x y) (+ x 3)) 'x)")
    (print ";==> " (deriv '(* (* x y) (+ x 3)) 'x))
    #t)


; exp=expression
(define (deriv exp var)
    (cond
        ((number? exp) 0)
        ((variable? exp)
            (if (same-variable? exp var) 1 0))
        ((sum? exp)
            (make-sum
                (deriv (addend exp) var)
                (deriv (augend exp) var)))
        ((product? exp)
            (make-sum
                (make-product
                    (multiplier exp)
                    (deriv (multiplicand exp) var))
                (make-product
                    (deriv (multiplier exp) var)
                    (multiplicand exp))))
        (else
            (error "unknown expression type: DERIV" exp))))


(define (variable? x) (symbol? x))


(define (same-variable? v1 v2)
    (and
        (variable? v1)
        (variable? v2)
        (eq? v1 v2)))


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


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


(define (sum? x)
    (and (pair? x) (eq? (car x) '+)))


(define (addend s)
    (cadr s))


(define (augend s)
    (caddr s))


(define (product? x)
    (and
        (pair? x)
        (eq? (car x) '*)))


(define (multiplier p)
    (cadr p))


(define (multiplicand p)
    (caddr p))

実行結果:

gosh> (sec-2.3.2-a)
(deriv '(+ x 3) 'x)
;==> (+ 1 0)
(deriv '(* x y) 'x)
;==> (+ (* x 0) (* 1 y))
(deriv '(* (* x y) (+ x 3)) 'x)
;==> (+ (* (* x y) (+ 1 0)) (* (+ (* x 0) (* 1 y)) (+ x 3)))
#t

即値部分への演算実行

前作った関数を上書きしてる部分になんとなく ; @override とかマーカーコメントいれてみたり.

; [sec-2.3.2-b.scm]
;
(define (sec-2.3.2-b)
    (print "(deriv '(+ x 3) 'x)")
    (print ";==> " (deriv '(+ x 3) 'x))
    (print "(deriv '(* x y) 'x)")
    (print ";==> " (deriv '(* x y) 'x))
    (print "(deriv '(* (* x y) (+ x 3)) 'x)")
    (print ";==> " (deriv '(* (* x y) (+ x 3)) 'x))
    #t)


(load "./sec-2.3.2-a")


; @override
(define (make-sum a1 a2)
    (cond
        ((=number? a1 0) a2)
        ((=number? a2 0) a1)
        ((and (number? a1) (number? a2))
            (+ a1 a2))
        (else (list '+ a1 a2))))


(define (=number? exp num)
    (and
        (number? exp)
        (= exp num)))


; @override
(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
            (list '* m1 m2))))

実行結果:

gosh> (sec-2.3.2-b)
(deriv '(+ x 3) 'x)
;==> 1
(deriv '(* x y) 'x)
;==> y
(deriv '(* (* x y) (+ x 3)) 'x)
;==> (+ (* x y) (* y (+ x 3)))

最初 (+ 1 0) になってたところが単に 1 になったり (* x 0) とか残ってたのが消えたり〜.

(+ (* x y) (* y (+ x 3))) は (x * y) + (y * (x + 3)) なので x について解いたら 2xy + 3y になるけれど, 今回はそいうのはしないっぽい.

ex-2.56. 累乗の微分

累乗が expt なの地味にいつも忘れてる＝ω＝;

実装

; [ex-2.56.scm]
;
(define (ex-2.56)
    (print "(deriv '(* a (** x 3)) 'x)")
    (print ";==> " (deriv '(* a (** x 3)) 'x))
    (print "(deriv '(* a (** x (** x 5))) 'x)")
    (print ";==> " (deriv '(* a (** x (** x 5))) 'x))
    #t)


(load "./sec-2.3.2-b")


(define (exponentiation? x)
    (and (pair? x) (eq? (car x) '**)))


(define (base x)
    (cadr x))


(define (exponent x)
    (caddr x))


(define (make-exponent x y)
    (cond
        ((=number? y 0) 1)
        ((=number? y 1) x)
        ((and (number? x) (number? y)) (expt x y))
        (else (list '** x y))))


; @override
(define (deriv exp var)
    (cond
        ((number? exp) 0)
        ((variable? exp)
            (if (same-variable? exp var) 1 0))
        ((sum? exp)
            (make-sum
                (deriv (addend exp) var)
                (deriv (augend exp) var)))
        ((product? exp)
            (make-sum
                (make-product
                    (multiplier exp)
                    (deriv (multiplicand exp) var))
                (make-product
                    (deriv (multiplier exp) var)
                    (multiplicand exp))))
        ((exponentiation? exp)
            (make-product
                (exponent exp)
                (make-product
                    (make-exponent (base exp) (make-sum (exponent exp) -1))
                    (deriv (base exp) var))))
        (else
            (error "unknown expression type: DERIV" exp))))

実行結果

gosh> (ex-2.56)
(deriv '(* a (** x 3)) 'x)
;==> (* a (* 3 (** x 2)))
(deriv '(* a (** x (** x 5))) 'x)
;==> (* a (* (** x 5) (** x (+ (** x 5) -1))))

ex-2.57. 被演算子を可変長引数に

handle sums and products of arbitrary numbers of terms というのね.

例えば、和の addend (加数) は最初の項で、 augend (被加数) は残りの項の和というようにする。

とあるけれど, augend の方は式がちょうど2項だった場合は右辺値をそのまま,
3項以上の場合は2項目以降の部分の式という風に実装してみた.

こんな感じ:

(addend '(+ a b)   ;==> a
(augend '(+ a b)   ;==> b
(augend '(+ a b c) ;==> (+ b c)

乗算と, 問題文にはなかったけれど累乗もついでに.

実装

; [ex-2.57.scm]
;
(define (ex-2.57)
    (print "(addend '(+ a b)")
    (print ";==> " (addend '(+ a b)))
    (print "(augend '(+ a b)")
    (print ";==> " (augend '(+ a b)))
    (print "(augend '(+ a b c)")
    (print ";==> " (augend '(+ a b c)))

    (newline)
    (print "(multiplier '(* a b)")
    (print ";==> " (multiplier '(* a b)))
    (print "(multiplicand '(* a b)")
    (print ";==> " (multiplicand '(* a b)))
    (print "(multiplicand '(* a b c)")
    (print ";==> " (multiplicand '(* a b c)))

    (newline)
    (print "(base '(** a b)")
    (print ";==> " (base '(** a b)))
    (print "(exponent '(** a b)")
    (print ";==> " (exponent '(** a b)))
    (print "(exponent '(** a b c)")
    (print ";==> " (exponent '(** a b c)))

    (newline)
    (print "(deriv '(* x y (+ x 3)) 'x)")
    (print ";==> " (deriv '(* x y (+ x 3)) 'x))

    (newline)
    (print "(deriv '(* a (** x 3)) 'x)")
    (print ";==> " (deriv '(* a (** x 3)) 'x))
    (print "(deriv '(* a (** x x 5)) 'x)")
    (print ";==> " (deriv '(* a (** x x 5)) 'x))
    #t)


(load "./ex-2.56")


; @override
(define (addend s)
    (cadr s))


; @override
(define (augend s)
    (if
        (null? (cdddr s))
        ; 2項のみ.
        (caddr s)
        ; 3項以上.
        (cons '+ (cddr s))))


; @override
(define (make-sum a1 a2)
    (cond
        ((=number? a1 0) a2)
        ((=number? a2 0) a1)
        ((and (number? a1) (number? a2))
            (+ a1 a2))

        ((sum? a1)
            (if
                (sum? a2)
                ; both a1 and a2 are sum.
                (append '(+) (cdr a1) (cdr a2))
                ; a1 is a sum, but a2 is not a sum.
                (append '(+) (cdr a1) (list a2))))
        ((sum? a2)
            ; a1 is not a sum, but a2 is a sum.
            (append '(+) (list a1) (cdr a2)))
        (else
            ; both a1 and a2 are not sum.
            (list '+ a1 a2))))


; @override
(define (multiplier p)
    (cadr p))


; @override
(define (multiplicand p)
    (if
        (null? (cdddr p))
        ; 2項のみ.
        (caddr p)
        ; 3項以上.
        (cons '* (cddr p))))


; @override
(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))

        ((product? m1)
            (if
                (product? m2)
                ; both m1 and m2 are product.
                (append '(*) (cdr m1) (cdr m2))
                ; m1 is a product, but m2 is not a product.
                (append '(*) (cdr m1) (list m2))))
        ((product? m2)
            ; m1 is not a product, but m2 is a product.
            (append '(*) (list m1) (cdr m2)))
        (else
            ; both m1 and m2 are not product.
            (list '* m1 m2))))


; @override
(define (base x)
    (cadr x))


; @override
(define (exponent x)
    (if
        (null? (cdddr x))
        ; 2項のみ.
        (caddr x)
        ; 3項以上.
        (cons '** (cddr x))))


; @override
(define (make-exponent x y)
    (cond
        ((=number? y 0) 1)
        ((=number? y 1) x)
        ((and (number? x) (number? y)) (expt x y))

        ((exponentiation? x)
            (if
                (exponentiation? y)
                ; both x and y are product.
                (append '(**) (cdr x) (cdr y))
                ; x is a product, but y is not a product.
                (append '(**) (cdr x) (list y))))
        ((exponentiation? y)
            ; x is not a product, but y is a product.
            (append '(**) (list x) (cdr y)))
        (else
            ; both x and y are not product.
            (list '** x y))))

実行結果

gosh> (ex-2.57)
(addend '(+ a b)
;==> a
(augend '(+ a b)
;==> b
(augend '(+ a b c)
;==> (+ b c)

(multiplier '(* a b)
;==> a
(multiplicand '(* a b)
;==> b
(multiplicand '(* a b c)
;==> (* b c)

(base '(** a b)
;==> a
(exponent '(** a b)
;==> b
(exponent '(** a b c)
;==> (** b c)

(deriv '(* x y (+ x 3)) 'x)
;==> (+ (* x y) (* y (+ x 3)))

(deriv '(* a (** x 3)) 'x)
;==> (* a 3 (** x 2))
(deriv '(* a (** x x 5)) 'x)
;==> (* a (** x 5) (** x (+ (** x 5) -1)))

ex-2.57. おまけ. 重複部分の共通化.

加算・乗算・累乗で同じようなことしてるとこがちらほらあるので共通化してみた.

さいしょいじっててうまく動かなくてすっごくなやんだけれど,

(define (make-sum a1 a2)
    (cond
        ((=number? a1 0) a2)
        ((=number? a2 0) a1)
        ((and (number? a1) (number? a2))
            (+ a1 a2))

        (bin-expr-append '+ a1 a2)))

こんななってたけどうごくのねこれ…＞＜；

bin-expr-append が else じゃないから他の条件句と同じように普通に評価
評価結果: #<closure bin-expr-append>
#f じゃないので真の扱い
((...) expr1 expr2 expr3 ...) な cond パラメータにマッチしたつもりでここに分岐
'+, a1, a2 を順に評価
'+, a1 は副作用持たないので実行結果にはでてこないでほぼ無視状態
最後の評価結果である a2 がそのまま関数の実行結果として返る

そしてばぐー＝ω＝;
Lisp さん型も構文もゆるふわ…

実装

; [ex-2.57-bin-expr]
;
(define (ex-2.57-bin-expr)
    (print "(addend '(+ a b)")
    (print ";==> " (addend '(+ a b)))
    (print "(augend '(+ a b)")
    (print ";==> " (augend '(+ a b)))
    (print "(augend '(+ a b c)")
    (print ";==> " (augend '(+ a b c)))

    (newline)
    (print "(multiplier '(* a b)")
    (print ";==> " (multiplier '(* a b)))
    (print "(multiplicand '(* a b)")
    (print ";==> " (multiplicand '(* a b)))
    (print "(multiplicand '(* a b c)")
    (print ";==> " (multiplicand '(* a b c)))

    (newline)
    (print "(base '(** a b)")
    (print ";==> " (base '(** a b)))
    (print "(exponent '(** a b)")
    (print ";==> " (exponent '(** a b)))
    (print "(exponent '(** a b c)")
    (print ";==> " (exponent '(** a b c)))

    (newline)
    (print "(deriv '(* x y (+ x 3)) 'x)")
    (print ";==> " (deriv '(* x y (+ x 3)) 'x))

    (newline)
    (print "(deriv '(* a (** x 3)) 'x)")
    (print ";==> " (deriv '(* a (** x 3)) 'x))
    (print "(deriv '(* a (** x x 5)) 'x)")
    (print ";==> " (deriv '(* a (** x x 5)) 'x))
    #t)


(load "./ex-2.56")


(define (bin-expr-of? op expr)
    (and (pair? expr) (eq? (car expr) op)))


(define (bin-expr-op expr)
    (car expr))


(define (bin-expr-lhs expr)
    (cadr expr))


(define (bin-expr-rhs expr)
    (if
        (null? (cdddr expr))
        ; 2項のみ.
        (caddr expr)
        ; 3項以上.
        (cons (bin-expr-op expr) (cddr expr))))


(define (bin-expr-append op expr1 expr2)
    (cond
        ((bin-expr-of? op expr1)
            (if
                (bin-expr-of? op expr2)
                ; both expr1 and expr2 are bin-expr of 'op'.
                (append (list op) (cdr expr1) (cdr expr2))
                ; expr1 is a bin-expr of 'op', but expr2 is not a bin-expr of 'op'.
                (append (list op) (cdr expr1) (list expr2))))
        ((bin-expr-of? op expr2)
            ; expr1 is not a bin-expr of 'op', but expr2 is a bin-expr of 'op'.
            (append (list op) (list expr1) (cdr expr2)))
        (else
            ; both expr1 and expr2 are not bin-expr of 'op'.
            (list op expr1 expr2))))


; @override
(define (addend s)
    (bin-expr-lhs s))


; @override
(define (augend s)
    (bin-expr-rhs s))


; @override
(define (make-sum a1 a2)
    (cond
        ((=number? a1 0) a2)
        ((=number? a2 0) a1)
        ((and (number? a1) (number? a2))
            (+ a1 a2))

        (else (bin-expr-append '+ a1 a2))))


; @override
(define (multiplier p)
    (bin-expr-lhs p))


; @override
(define (multiplicand p)
    (bin-expr-rhs p))


; @override
(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 (bin-expr-append '* m1 m2))))


; @override
(define (base x)
    (bin-expr-lhs x))


; @override
(define (exponent x)
    (bin-expr-rhs x))


; @override
(define (make-exponent x y)
    (cond
        ((=number? y 0) 1)
        ((=number? y 1) x)
        ((and (number? x) (number? y)) (expt x y))

        (else (bin-expr-append '** x y))))

実行結果

結果は変わらないけれど＞ω＜

gosh> (ex-2.57-bin-expr)
(addend '(+ a b)
;==> a
(augend '(+ a b)
;==> b
(augend '(+ a b c)
;==> (+ b c)

(multiplier '(* a b)
;==> a
(multiplicand '(* a b)
;==> b
(multiplicand '(* a b c)
;==> (* b c)

(base '(** a b)
;==> a
(exponent '(** a b)
;==> b
(exponent '(** a b c)
;==> (** b c)

(deriv '(* x y (+ x 3)) 'x)
;==> (+ (* x y) (* y (+ x 3)))

(deriv '(* a (** x 3)) 'x)
;==> (* a 3 (** x 2))
(deriv '(* a (** x x 5)) 'x)
;==> (* a (** x 5) (** x (+ (** x 5) -1)))

ex-2.58. (a) 中置記法

Lisp 的な (+ 'a 'b) から普通の数式的な ('a + 'b) に.

ひとまずは同じ括弧のレベルなかは1つの演算子だけな制約で. Lisp の時と同じように.

実装

; [ex-2.58-a.scm]
;
(define (ex-2.58-a)
    (print "(addend '(a + b))")
    (print ";==> " (addend '(a + b)))
    (print "(augend '(a + b))")
    (print ";==> " (augend '(a + b)))
    (print "(augend '(a + b + c))")
    (print ";==> " (augend '(a + b + c)))

    (newline)
    (print "(multiplier '(a * b))")
    (print ";==> " (multiplier '(a * b)))
    (print "(multiplicand '(a * b))")
    (print ";==> " (multiplicand '(a * b)))
    (print "(multiplicand '(a * b * c))")
    (print ";==> " (multiplicand '(a * b * c)))

    (newline)
    (print "(base '(a ** b))")
    (print ";==> " (base '(a ** b)))
    (print "(exponent '(a ** b))")
    (print ";==> " (exponent '(a ** b)))
    (print "(exponent '(a ** b ** c))")
    (print ";==> " (exponent '(a ** b ** c)))

    (newline)
    (print "(deriv '(x * y * (x + 3)) 'x)")
    (print ";==> " (deriv '(x * y * (x + 3)) 'x))

    (newline)
    (print "(deriv '(a * (x ** 3)) 'x)")
    (print ";==> " (deriv '(a * (x ** 3)) 'x))
    (print "(deriv '(a * (x ** x ** 5)) 'x)")
    (print ";==> " (deriv '(a * (x ** x ** 5)) 'x))
    #t)


(load "./ex-2.56")


(define (bin-expr-of? op expr)
    (and (pair? expr) (pair? (cdr expr)) (eq? (cadr expr) op)))


(define (bin-expr-op expr)
    (cadr expr))


(define (bin-expr-lhs expr)
    (car expr))


(define (bin-expr-rhs expr)
    (if
        (null? (cdddr expr))
        ; 2項のみ.
        (caddr expr)
        ; 3項以上.
        (cddr expr)))


(define (bin-expr-append op expr1 expr2)
    (cond
        ((bin-expr-of? op expr1)
            (if
                (bin-expr-of? op expr2)
                ; both expr1 and expr2 are bin-expr of 'op'.
                (append (cdr expr1) (list op) (cdr expr2))
                ; expr1 is a bin-expr of 'op', but expr2 is not a bin-expr of 'op'.
                (append (cdr expr1) (list op) (list expr2))))
        ((bin-expr-of? op expr2)
            ; expr1 is not a bin-expr of 'op', but expr2 is a bin-expr of 'op'.
            (append (list expr1) (list op) (cdr expr2)))
        (else
            ; both expr1 and expr2 are not bin-expr of 'op'.
            (list expr1 op expr2))))


; @override
(define (sum? s)
    (bin-expr-of? '+ s))


; @override
(define (addend s)
    (bin-expr-lhs s))


; @override
(define (augend s)
    (bin-expr-rhs s))


; @override
(define (make-sum a1 a2)
    (cond
        ((=number? a1 0) a2)
        ((=number? a2 0) a1)
        ((and (number? a1) (number? a2))
            (+ a1 a2))

        (else (bin-expr-append '+ a1 a2))))


; @override
(define (product? p)
    (bin-expr-of? '* p))


; @override
(define (multiplier p)
    (bin-expr-lhs p))


; @override
(define (multiplicand p)
    (bin-expr-rhs p))


; @override
(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 (bin-expr-append '* m1 m2))))


; @override
(define (exponentiation? x)
    (bin-expr-of? '** x))


; @override
(define (base x)
    (bin-expr-lhs x))


; @override
(define (exponent x)
    (bin-expr-rhs x))


; @override
(define (make-exponent x y)
    (cond
        ((=number? y 0) 1)
        ((=number? y 1) x)
        ((and (number? x) (number? y)) (expt x y))

        (else (bin-expr-append '** x y))))

実行結果

gosh> (ex-2.58-a)
(addend '(a + b))
;==> a
(augend '(a + b))
;==> b
(augend '(a + b + c))
;==> (b + c)

(multiplier '(a * b))
;==> a
(multiplicand '(a * b))
;==> b
(multiplicand '(a * b * c))
;==> (b * c)

(base '(a ** b))
;==> a
(exponent '(a ** b))
;==> b
(exponent '(a ** b ** c))
;==> (b ** c)

(deriv '(x * y * (x + 3)) 'x)
;==> ((x * y) + (y * (x + 3)))

(deriv '(a * (x ** 3)) 'x)
;==> (a * * (x ** 2))
(deriv '(a * (x ** x ** 5)) 'x)
;==> (a * * (x ** ((x ** 5) + -1)))

ex-2.58. (b) 演算子の混合配置

同じ括弧内でも優先順位的に問題無い場合は異なる演算子の場合でも括弧を省略するような対応.

こんなの:

(make-product (make-sum 'a 'b) (make-sum 'c 'd))
;==> ((a + b) * (c + d))
(make-sum (make-product 'a 'b) (make-product 'c 'd))
;==> (a * b + c * d)

この問題ってしれっと優先順位の対応以外に, (a + b) の2項式のみだったのを (a + b + c) みたいな3項以上の式に対応するのが一緒に入ってるのね・ω・;

複数の演算子が1つの括弧内に混在しているので, 優先度の低い演算子があったら先にそこで分割することで, 優先度の高い演算子が先に項内で演算された後に, 優先度の低い演算子で処理されるようになる.

優先順位に応じた処理順は最初からちょうどいい順番になってるっぽい.

例. a * b + c の場合:

優先度の低い + がある
sum? が真
加算としての処理に分岐
(addend expr) ==> lhs ==> a * b
(augend expr) ==> rhs ==> c
lhs 及び rhs では分割対象とする演算子が必ず含まれている事前条件を満たすとする.
逆に, 加算でない場合 (sum? が偽の場合) には addend, augend は呼ばれることはない
加算でない場合は, 次に優先度の低い乗算 (product?) にて同様に.
さらに同様に累乗 (exponentiation?) にて同様に.

そんなかんじ.

特定の演算子部分で lhs op rhs に分割する処理を expr op expr op ... op expr な構造の op 部分の一致をしらべていったけど, expr 部分に演算子が出てくることはないから片っ端から expr か op かも気にせずに判定していっても問題なかったぽい. なるほど〜・ω・*

実装

; [ex-2.58-b.scm]
;
(define (ex-2.58-b)
    (print "(make-product (make-sum 'a 'b) (make-sum 'c 'd))")
    (print ";==> " (make-product (make-sum 'a 'b) (make-sum 'c 'd)))
    (print "(make-sum (make-product 'a 'b) (make-product 'c 'd))")
    (print ";==> " (make-sum (make-product 'a 'b) (make-product 'c 'd)))

    (newline)
    (print "(deriv '(x * y * (x + 3)) 'x)")
    (print ";==> " (deriv '(x * y * (x + 3)) 'x))

    (newline)
    (print "(deriv '(a * (x ** 3)) 'x)")
    (print ";==> " (deriv '(a * (x ** 3)) 'x))
    (print "(deriv '(a * (x ** x ** 5)) 'x)")
    (print ";==> " (deriv '(a * (x ** x ** 5)) 'x))
    #t)


(load "./ex-2.56")


(define (bin-expr-of? op expr)
    (and
        (pair? expr)       ; (lhs . _)
        (pair? (cdr expr)) ; (lhs . op . _)
        (or
            (eq? (cadr expr) op)             ; op match?
            (bin-expr-of? op (cddr expr))))) ; recursion.


(define (bin-expr-lhs op expr)
    (define (iter op rest left)
        (cond
            ((null? rest) ; never seen the op.
                (error "operator not found: " op " in " (reverse left)))
            ((eq? (car rest) op) ; same op?
                ; split at here.
                (if
                    (null? (cdr left)) ; lhs is a singleton?
                    (car left)         ; singleton.
                    (reverse left)))   ; compound.
            (else
                (iter op (cddr rest) (append (list (cadr rest) (car rest)) left)))))

    (iter op (cdr expr) (list (car expr))))


(define (bin-expr-rhs op expr)
    (define (iter op rest)
        (if
            (eq? (car rest) op)
            (if  ; the op found. split at here.
                (null? (cddr rest)) ; rhs is a singleton?
                (cadr rest)         ; singleton.
                (cdr rest))         ; compound.
            (iter op (cddr rest))))

    (iter op (cdr expr)))


(define (bin-expr-append paren-if? op expr1 expr2)
    (define (inner op expr1 expr2)
        (cond
            ((and (pair? expr1) (pair? expr2))
                (append expr1 (list op) expr2))
            ((and (pair? expr1) (not (pair? expr2)))
                (append expr1 (list op) (list expr2)))
            ((and (not (pair? expr1)) (pair? expr2))
                (append (list expr1) (list op) expr2))
            ((and (not (pair? expr1)) (not (pair? expr2)))
                (list expr1 op expr2))
            (else
                (error "NEVER REACH HERE:" op expr1 expr2))))

    (define (do-paren-if expr)
        (cond
            ((not (paren-if? expr))
                expr)
            ((not (list? expr))
                expr)
            (else
                (list expr)))) ; enparen.

    (inner op (do-paren-if expr1) (do-paren-if expr2)))


; @override
(define (sum? s)
    (bin-expr-of? '+ s))


; @override
(define (addend s)
    (bin-expr-lhs '+ s))


; @override
(define (augend s)
    (bin-expr-rhs '+ s))


; @override
(define (make-sum a1 a2)
    ; parens are never required.
    (define (never e) #f)

    (cond
        ((=number? a1 0) a2)
        ((=number? a2 0) a1)
        ((and (number? a1) (number? a2))
            (+ a1 a2))

        (else (bin-expr-append never '+ a1 a2))))


; @override
(define (product? p)
    (bin-expr-of? '* p))


; @override
(define (multiplier p)
    (bin-expr-lhs '* p))


; @override
(define (multiplicand p)
    (bin-expr-rhs '* p))


; @override
(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 (bin-expr-append sum? '* m1 m2))))


; @override
(define (exponentiation? x)
    (bin-expr-of? '** x))


; @override
(define (base x)
    (bin-expr-lhs '** x))


; @override
(define (exponent x)
    (bin-expr-rhs '** x))


; @override
(define (make-exponent x y)
    (define (sum-or-product? x)
        (or (sum? x) (product? x)))

    (cond
        ((=number? y 0) 1)
        ((=number? y 1) x)
        ((and (number? x) (number? y)) (expt x y))

        (else (bin-expr-append sum-or-product? '** x y))))

実行結果

gosh> (ex-2.58-b)
(make-product (make-sum 'a 'b) (make-sum 'c 'd))
;==> ((a + b) * (c + d))
(make-sum (make-product 'a 'b) (make-product 'c 'd))
;==> (a * b + c * d)

(deriv '(x * y * (x + 3)) 'x)
;==> (x * y + y * (x + 3))

(deriv '(a * (x ** 3)) 'x)
;==> (a * 3 * x ** 2)
(deriv '(a * (x ** x ** 5)) 'x)
;==> (a * x ** 5 * x ** (x ** 5 + -1))

おまけ: 比較用に共通化した処理を展開したコード

やっつけで加算のとこだけざくっと手で展開してみた. あってるかは知らない＞ω＜

; @override
(define (sum? expr)
    ; (bin-expr-of? '+ expr))
    (and
        (pair? expr)       ; expr=(lhs . _)      = (car . cdr)
        (pair? (cdr expr)) ; expr=(lhs . op . _) = (car . cadr . cddr )
        (or
            (eq? (cadr expr) '+)  ; op match?
            (sum? (cddr expr))))) ; recursion.


; @override
(define (addend expr)
    ; (bin-expr-lhs '+ expr))
    (define (iter rest left)
        (cond
            ((null? rest) ; never seen the op.
                (error "operator not found: '+' in " (reverse left)))
            ((eq? (car rest) '+) ; same op?
                ; split at here.
                (if
                    (null? (cdr left)) ; lhs is a singleton?
                    (car left)         ; singleton.
                    (reverse left)))   ; compound.
            (else
                (iter (cddr rest) (append (list (cadr rest) (car rest)) left)))))

    (iter (cdr expr) (list (car expr))))


; @override
(define (augend expr)
    ; (bin-expr-rhs '+ expr))
    (define (iter rest)
        (if
            (eq? (car rest) '+)
            (if  ; the op found. split at here.
                (null? (cddr rest)) ; rhs is a singleton?
                (cadr rest)         ; singleton.
                (cdr rest))         ; compound.
            (iter (cddr rest))))

    (iter (cdr expr)))


; @override
(define (make-sum a1 a2)
    (cond
        ((=number? a1 0) a2)
        ((=number? a2 0) a1)
        ((and (number? a1) (number? a2))
            (+ a1 a2))

        (else
            ; (bin-expr-append never '+ a1 a2)
            (cond
                ((and (pair? a1) (pair? a2))
                    (append a1 (list '+) a2))
                ((and (pair? a1) (not (pair? a2)))
                    (append a1 (list '+) (list a2)))
                ((and (not (pair? a1)) (pair? a2))
                    (append (list a1) (list '+) a2))
                ((and (not (pair? a1)) (not (pair? a2)))
                    (list a1 '+ a2))
                (else
                    (error "NEVER REACH HERE:" '+ a1 a2))))))

おまけ (2): 演算子の優先順の確認

; 括弧なしで実行.
gosh> (deriv '(x * x + x) 'x)
(x + x + 1)
gosh> (deriv '(x + x * x) 'x)
(1 + x + x)

; * を明示的に優先 (通常の優先順での処理と同等).
gosh> (deriv '(x + (x * x)) 'x)
(1 + x + x)
gosh> (deriv '((x * x) + x) 'x)
(x + x + 1)

; + を明示的に優先 (明示的に処理順を逆転させた場合).
gosh> (deriv '(x * (x + x)) 'x)
(x * 2 + x + x)
gosh> (deriv '((x + x) * x) 'x)
(x + x + 2 * x)

括弧なしの場合でも * 部分に括弧をつけて明示的に優先処理させた場合と同じ結果が得られている.

試しに deriv で sum? 部分と product? 部分の順番を入れ替えると誤った結果になるはず. というわけで試してみた:

(define (deriv exp var)
    (cond
        ((number? exp) 0)
        ((variable? exp)
            (if (same-variable? exp var) 1 0))
        ; わざと product? を先に判定.
        ((product? exp)
            ...)
        ((sum? exp)
            ...)
        ((exponentiation? exp)

; わざと誤った処理順に変えて実行した結果.
gosh> (deriv '(x * x + x) 'x)
(x * 2 + x + x)
gosh> (deriv '(x + x * x) 'x)
(x + x + 2 * x)

; * を明示的に優先 (通常の優先順での処理と同等).
gosh> (deriv '(x + (x * x)) 'x)
(1 + x + x)
gosh> (deriv '((x * x) + x) 'x)
(x + x + 1)

; + を明示的に優先 (明示的に処理順を逆転させた場合).
gosh> (deriv '(x * (x + x)) 'x)
(x * 2 + x + x)
gosh> (deriv '((x + x) * x) 'x)
(x + x + 2 * x)

想像通り, + を優先して結合させた場合の結果が誤って得られるようになった.

おまけ (3): 演算の結合方向

結合方向は右結合になってる模様.
なので右結合な累乗に対して適切に動作する.
加算及び乗算は本来は左結合だけど, 今回のでは対称律を持つので右結合で処理しても結果は同値であり問題は生じない.

累乗 (右結合) の場合:

; 普通に実行.
gosh> (deriv '(x ** x ** x) 'x)
(x ** x * x ** (x ** x + -1))

; 右結合の場合の結果.
gosh> (deriv '(x ** (x ** x)) 'x)
(x ** x * x ** (x ** x + -1))

; 左結合の場合の結果.
gosh> (deriv '((x ** x) ** x) 'x)
(x * x ** x ** (x + -1) * x * x ** (x + -1))

正しく右結合で処理されている.

乗算 (左結合) の場合:

; 普通に実行.
gosh> (deriv '(x * x * x) 'x)
(x * (x + x) + x * x)

; 右結合の場合の結果.
gosh> (deriv '(x * (x * x)) 'x)
(x * (x + x) + x * x)

; 左結合の場合の結果.
gosh> (deriv '((x * x) * x) 'x)
(x * x + (x + x) * x)

右結合で処理されてしまっている.
しかしここでは対称律を持つので結果的に問題はない.

加算 (左結合) の場合:

; 普通に実行.
gosh> (deriv '(x + x + x) 'x)
3

; 右結合の場合の結果.
gosh> (deriv '((x + x) + x) 'x)
3

; 左結合の場合の結果.
gosh> (deriv '(x + (x + x)) 'x)
3

違いが見えないけれど乗算の場合と同じのはず＞ω＜;