;; a (define (apply-generic op . args) (let ((type-tags (map type-tag args))) (let ((proc (get op type-tags))) (if proc ;;false (apply proc (map contents args)) (if (= (length args) 2) (let ((type1 (car type-tags)) (type2 (cadr type-tags))…

(define (=zero? x) (apply-generic '=zero? x y)) ;; scheme-numberパッケージに追加 (put '=zero? '(scheme-number) (lambda (x) (= x 0))) ;; rationalパッケージに追加 (put '=zero? '(rational) (lambda (x) (= (numer x) 0))) ;; complexパッケージに…

;; scheme-numberパッケージに追加 (put 'equ? '(scheme-number scheme-number) (lambda (x y) (tag (= x y)))) ;; rationalパッケージに追加 (put 'equ? '(rational rational) (lambda (x y) (and (= (numer x) (numer y)) (= (denom x) (denom y))))) ;; c…

(define (attach-tag type-tag contents) (if (eq? type-tag 'scheme-number) contents (cons type-tag contents))) (define (type-tag datum) (cond ((number? (car datum)) 'scheme-number) ((pair? datum) (car datum)) (else (error "Bad tagged datum -…

(put 'real-part '(complex) real-part) (put 'imag-part '(complex) imag-part) (put 'magnitude '(complex) magnitude) (put 'angle '(complex) angle) ;; magnitudeはcomplex型を知らないのでerrorを返す． ;; なので表にcomplex型を追加すれば動く． (ma…

;; 明示的ディスパッチによるジェネリック演算 データの型が追加されるたびに各演算にその型用の演算を追加していく． 新しい演算が追加されたときはそれを追加するだけ． ;; データ主導スタイル データの型が追加されると，それらをパッケージを作ってputす…

(define (make-from-mag-ang r a) (define (dispatch op) (cond ((eq? op 'magnitude) r) ((eq? op 'angle) a) ((eq? op 'real-part) (* r (cos a))) ((eq? op 'imag-part) (* r (sin a))) (else (error "Unknown op -- MAKE-FROM-MAG-ANG" op)))) dispatch)

;; a ;; 各事業所ごとに従業員ファイルを作っていると考え，person-fileのcar部に ;; 従業所を識別するコードを入れるようにする． (define (get-record name person-file) ((get 'get-record (division person-file)) name file)) (define (division file) …

再帰で (define (eratosthenes n) (define (recur lis) (if (null? lis) '() (cons (car lis) (recur (filter (lambda (x) (not (= (modulo x (car lis)) 0))) lis))))) (recur (iota (- (round n) 1) 2))) 繰り返しで (define (eratosthenes n) (define (it…

(define (deriv exp var) (cond ((number? exp) 0) ((variable? exp) (if (same-variable? exp var) 1 0)) (else (get 'deriv (operator exp)) (operands exp) var))) (define (operator exp) (car exp)) (define (operands exp) (cdr exp)) ;; a 元のプログ…

n = 5のとき，最高頻度の記号には4bit.最低頻度の記号には1bit必要． n = 10のとき，最高頻度の記号には9bit.最低頻度の記号には1bit必要．

gosh> (define q-pairs '((A 2) (BOOM 1) (GET 2) (JOB 2) (NA 16) (SHA 3) (YIP 9) (WAH 1))) q-pairs gosh> (define q-tree (successive-merge (make-leaf-set q-pairs))) q-tree gosh> (define message '(GET A JOB SHA NA NA NA NA NA NA NA NA GET A JO…

(define (generate-huffman-tree pairs) (successive-merge (make-leaf-set pairs))) ;; pairsは昇順に並んでいるので先頭の2要素をmake-code-pairsする． ;; それを(cddr pairs)にadjoin-setすればまた昇順に並んだpairsができるのでそれを繰り返す． (defi…

(define (encode message tree) (if (null? message) '() (append (encode-symbol (car message) tree) (encode (cdr message) tree)))) (define (encode-symbol msg tree) (if (leaf? tree) '() (cond ((memq msg (symbols (left-branch tree))) (cons 0 (e…

;; Huffman木 (define (make-leaf symbol weight) (list 'leaf symbol weight)) (define (leaf? object) (eq? (car object) 'leaf)) (define (symbol-leaf x) (cadr x)) (define (weight-leaf x) (caddr x)) (define (make-code-tree left right) (list left…

2.58b は解けそうになかったので解答を見てできるかぎり解説を入れてみました． 一部修正しています． 解答は↓から p2pu-sicp/2.58.scm at master · sarabander/p2pu-sicp · GitHub ;; partには'beforeか'afterが入り，symbolの位置でexpを前後に分ける． (d…

(define (lookup-tree given-key set-of-records) (cond (let ((key-record (key (car set-of-records)))) ((null? set-of-records) false) ((= given-key key-record) (car set-of-records)) ((< given-key key-record) (lookup-tree given-key (left-branc…

(define (union-tree s t) (list->tree (union-set (tree->list-2 s) (tree->list-2 t)))) (define (intersection-tree s t) (list->tree (intersection-set-local (tree->list-2 s) (tree->list-2 t))))

;a 先頭から(n-1)/2番目までをleft-treeとしてpartial-treeにかける． 残ったリストの先頭をthis-entryとしてこの木の分岐点におく． そのcdrをright-treeとしてpartial-treeにかける． これを繰り返して木を作る． 5 / \ 1 9 \ / \ 3 7 11 ;b O(n)

(define (tree->list-1 tree) (if (null? tree) '() (append (tree->list-1 (left-branch tree)) (cons (entry tree) (tree->list-1 (right-branch tree)))))) (define (tree->list-2 tree) (define (copy-to-list tree result-list) (if (null? tree) resul…

(define (union-set s t) (cond ((null? s) t) ((null? t) s) ((= (car s) (car t)) (cons (car s) (union-set (cdr s) (cdr t)))) ((< (car s) (car t)) (cons (car s) (union-set (cdr s) t))) ((< (car t) (car s)) (cons (car t) (union-set s (cdr t)))…

(define (adjoin-set x s) (cond ((null? s) (list x)) ((= x (car s)) s) ((< x (car s)) (cons x s)) (else (cons (car s) (adjoin-set x (cdr s)))))) ;; 同じ数字，またはxより大きい数字が出てきた時点で計算が終わるので順序付けられない表現に比べ半…

;; element-of-set? intersection-setはそのまま (define (adjoin-set x s) (cons x s)) (define (union-set s t) (append s t)) ;; element-of-set?やintersection-setについてはsetの中身が増えることで比較回数が増えて効率は下がる． ;; adjoin-set unio…

(define (element-of-set? x set) (cond ((null? set) false) ((equal? x (car set)) true) (else (element-of-set? x (cdr set))))) (define (unionset s t) (cond ((null? s) t) ((element-of-set? (car s) t) (unionset (cdr s) t)) (else (cons (car s) …

;; a (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 (make-product m1 m2) (cond ((or (=number? m1 0) (=number? m2 0)) 0) ((=number? m1 1)…

(define (augend s) (if (null? (cdddr s)) (caddr s) (cons '+ (cddr s)))) (define (multiplicand p) (if (null? (cdddr p)) (caddr p) (cons '* (cddr p)))) これ作るので精一杯でした． make-sumやmake-productを可変長引数に対応できるように変更するの…

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

''abracadabraは'abracadabraを返す． (car ''abracadabra)はquoteを返す． (cdr ''abracadabra)は(abracadabra)を返す． つまり'abracadabraは(quote abracadabra)のことで， ''abracadabraは'(quote abracadabra)のことである． そのため(car ''abracadabr…

(define (equal? a b) (or (and (not (pair? a)) (not (pair? b)) (eq? a b)) (and (pair? a) (pair? b) (equal? (car a) (car b)) (equal? (cdr a) (cdr b))))) gosh> (equal? '(this is a list) '(this is a list)) #t gosh> (equal? '(this is a list) '(…

(list 'a 'b 'c) (a b c) (list (list 'george)) ((george)) (cdr '((x1 x2) (y1 y2))) ((y1 y2)) (cadr '((x1 x2) (y1 y2))) (y1 y2) (pair? (car '(a short list))) #f (memq 'red '((red shoes) (blue socks))) #f (memq 'red '(red shoes blue socks)) (…