SICP 問題 2.58b

2.58b は解けそうになかったので解答を見てできるかぎり解説を入れてみました．
一部修正しています． 解答は↓から

p2pu-sicp/2.58.scm at master · sarabander/p2pu-sicp · GitHub

;; partには'beforeか'afterが入り，symbolの位置でexpを前後に分ける．
(define (extract part symbol exp)
  (define (iter subexp remaining)
    (cond ((null? remaining) remaining)
          ((eq? (car remaining) symbol)
           (cond ((eq? part 'before) subexp)
                 ((eq? part 'after) (cdr remaining))
                 (else (error "Unclear, do you mean 'before or after?"))))
          (else
           (iter (append subexp (list (car remaining)))
                 (cdr remaining)))))
  (let ((result (iter nil exp)))
    (if (eq? (length result) 1)
        (car result)
        result)))

;; リストにシンボルが入っているかを問う述語
(define (contains? symbol lis)
  (cond ((or (null? lis) (not (pair? lis))) false)
        ((eq? symbol (car lis)) true)
        (else (contains? symbol (cdr lis)))))

;; sum
(define (sum? x)
  (contains? '+ x))

(define (addend s)
  (extract 'before '+ s))

(define (augend s)
  (extract 'after '+ s))

;; product
(define (product? x)
  (contains? '* x))

(define (multiplier p)
  (extract 'before '* p))

(define (multiplicand p)
  (extract 'after '* p))

;; exponentiation
(define (exponentiation? e)
  (contains? '** e))

(define (base e)
  (extract 'before '** e))

(define (exponent e)
  (extract 'after '** e))



;; 簡約

;; かっこを外す
(define (fringe tree)
  (cond ((null? tree) '())
        ((not (pair? tree)) (list tree))
        (else (append (fringe (car tree))
                      (fringe (cdr tree))))))

;; 演算子で分けられたリストに分ける．
(define (split-by op polynome)
  (cond ((null? polynome) '())
        ((or (not (pair? polynome))
             (not (contains? op polynome))) ;;追加．これがないと最後の項がシングルトン以外の場合空リストになる．
         (list polynome))
        (else (append (list (extract 'before op polynome))
                      (split-by op (extract 'after op polynome))))))

(define (summands polynome)
  (split-by '+ polynome))

(define (factors polynome)
  (split-by '* polynome))

;; リストの要素の間にopを入れる
(define (infix op lst)
  (cond ((null? lst) '())
        ((null? (cdr lst)) lst)
        (else (append (list (car lst))
                      (cons op
                            (infix op (cdr lst)))))))

(define (infix-add s)
  (infix '+ s))

(define (infix-multiply p)
  (infix '* p))

;; リストの先頭のリストにだけopを適用する．
(define (apply-car op lst)
  (append (list (apply op (car lst)))
          (cadr lst)))

(define (apply-car+ s)
  (apply-car + s))

(define (apply-car* p)
  (apply-car * p))

;; (6)を6といった具合に数一つだけのリストをnumberにする
(define (release-singleton e)
  (if (= (length e) 1)
      (car e)
      e))

;; 数だけを先頭にあつめてリストにする
(define (group lst)
  (cons (filter number? lst)
        (list (filter (lambda (n) (not (number? n)))
                      lst))))

;; リストの先頭を最後にもっていく．
(define (shift-left lst)
  (append (cdr lst) (list (car lst))))


;; まずfringeでかっこを外し，summandsを使い，＋の位置で分けたリストに変換する．
;; そのリストに対してmapで各要素にfactors,group,apply-car*,release-singletonの順に手続きを適用する．
;; つまり，*でわけたリストに変換し，数字のみのリストをcarにもってきて，それに*を適用し，要素の間に＊をいれ，シングルトンがあれば，それを数字にする．
;; これが全要素に完了した後に出来たリストに対して，group,apply-car+,shift-left,infix-add,fringeを順に適用する．
;; 先頭に数字のみでできたリストを作り，それらを足し，リストの最後に移す．このリストの要素の間に＋を挿入し，かっこを取り払う．
(define (simplify polynome)
  ((compose fringe
            infix-add
            shift-left
            apply-car+
            group)
   (map (compose release-singleton
                 infix-multiply
                 apply-car*
                 group
                 factors)
        (summands (fringe polynome)))))