2015/10/27

# 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))

(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)))))))

(infix '+ s))

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

;; リストの先頭のリストにだけopを適用する．
(define (apply-car op lst)
(append (list (apply op (car 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にもってきて，それに*を適用し，要素の間に＊をいれ，シングルトンがあれば，それを数字にする．
;; 先頭に数字のみでできたリストを作り，それらを足し，リストの最後に移す．このリストの要素の間に＋を挿入し，かっこを取り払う．
(define (simplify polynome)
((compose fringe