naga:2-53 > 2-97

naga

Todo

2.64
2.65
2.66
2.67
2.68
2.69
2.70
2.71
2.72
2.73
2.74
2.75
2.76
2.79
2.81
2.82
2.83
2.84
2.85
2.86

Exercise 2.53

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

Exercise 2.54

(define (equal? x y)
  (cond ((and (symbol? x) (symbol? y)) (eq? x y))
        ((and (pair? x) (pair? y)) (and (equal? (car x) (car y)) (equal? (cdr x) (cdr y))))
        ((and (null? x) (null? y)))
        (else #f)))
;;gosh> (equal? '(this is a list) '(this is a list))
;;#t
;;gosh> (equal? '(this is a list) '(this (is a) list))
;;#f

Exercise 2.55

;; 'x は（quate x)のシンタックスシュガーなので
;; (car ''abr～)->(car (quote (quote abr～)))を評価すると(quote abr～)のcarをとることになるので
;; ->quote
;;gosh> (car ''abr)
;;quote

Exercise 2.56

(define (exponentiation? x)
  (and (pair? x) (eq? (car x) '**)))
(define (base s) (cadr s))
(define (exponent s) (caddr s))
(define (make-exponentiation e1 e2)
  (cond ((=number? e2 0) 1)
        ((=number? e2 1) e1)
        (else (list '** e1 e2))))
(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
          (make-product (exponent exp)
                        (make-exponentiation (base exp)
                                             (- (exponent exp) 1)))
          (deriv (base exp) var)))
        (else
         (error 'unknown expression type -- DERIV' exp))))
;;gosh> (deriv '(** (+ x 3) 5) 'x)
;;(* 5 (** (+ x 3) 4))

Exercise 2.57

(define (augend s)
  (if (null? (cdddr s))
      (caddr s)
      (cons '+ (cddr s))))
(define (multiplicand p)
  (if (null? (cdddr p))
      (caddr p)
      (cons '* (cddr p))))
;;gosh> (deriv '(* x y (+ x 3)) 'x)
;;(+ (* x y) (* y (+ x 3)))

Exercise 2.58

;; a
(define (sum? x) (and (pair? x) (eq? (cadr x) '+)))
(define (addend s) (car s))
(define (augend s) (caddr s))
(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 (product? p) (and (pair? p) (eq? (cadr p) '*)))
(define (multiplier p) (car p))
(define (multiplicand p) (caddr p))
(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> (deriv '(x + (3 * (x + (y + 2)))) 'x)
;;4
;;gosh> (deriv '((x * x) + (4 * x) + 4) 'x)
;;((x + x) + 4)

;; b
;;exp のリスト要素中に優先度の低い演算子+があればexpはsumであり、+の前までをaddend,+の後ろをaugend
;;とする。*についても同様におこなうが、sum?の判定と処理をproduct?の判定と処理に先立って行うことで、
;;演算子の優先度にしたがった処理となる。
(define (dup-list-till s l)
  (if (eq? s (car l))
      '()
      (cons (car l) (dup-list-till s (cdr l)))))
(define (1st-item-if-not-pairs p)
  (if (null? (cdr p))
      (car p)
      p))
(define (sum? x) (and (pair? x) (memq '+ x)))
(define (addend x)
  (1st-item-if-not-pairs (dup-list-till '+ x)))
(define (augend x)
  (1st-item-if-not-pairs (cdr (memq '+ x))))
(define (product? p) (and (pair? p) (memq '* p)))
(define (multiplier p)
  (1st-item-if-not-pairs (dup-list-till '* p)))
(define (multiplicand p)
  (1st-item-if-not-pairs (cdr (memq '* p))))
;;gosh> (deriv '(x + 3 * (x + y + 2)) 'x)
;;4
;;gosh> (deriv '(x * x + 4 * x + 3) 'x)
;;((x + x) + 4)

Exercise 2.59

(define (union-set set1 set2)
  (cond ((null? set1) set2)
        ((element-of-set? (car set1) set2)
         (union-set (cdr set1) set2))
        (else (cons (car set1) (union-set (cdr set1) set2)))))
;;gosh> (define a '(5 4 3 2 1))
;;a
;;gosh> (define b '(8 7 6 5 4))
;;b
;;gosh> (union-set a b)
;;(3 2 1 8 7 6 5 4)

Exercise 2.60

(define (element-of-set? x set)
  (cond ((null? set) #f)
        ((equal? x (car set)) #t)
        (else (element-of-set? x (cdr set)))))
(define (adjoin-set x set)
  (cons x set))
(define (union-set set1 set2)
  (append set1 set2))
(define (intersection-set set1 set2)
  (cond ((or (null? set1) (null? set2)) '())
        ((element-of-set? (car set1) set2)
         (cons (car set1)
               (intersection-set (cdr set1) (remove-from-set (car set1) set2))))
        (else (intersection-set (cdr set1) set2))))
(define (remove-from-set x set)
  (define (rec set)
    (cond ((null? set) '())
          ((eq? x (car set)) (cdr set))
          (else (cons (car set) (rec (cdr set))))))
  (rec set))
;;gosh> (define a '(1 1 2 3 3))
;;a
;;gosh> (define b '(1 3 3 4))
;;b
;;gosh> (adjoin-set 2 a)
;;(2 1 1 2 3 3)
;;gosh> (union-set a b)
;;(1 1 2 3 3 1 3 3 4)
;;gosh> (intersection-set a b)
;;(1 3 3)

Exercise 2.61

(define (adjoin-set x set)
  (cond ((null? set) (append set (list x)))
        ((= x (car set)) set)
        ((< x (car set)) (cons x set))
        (else (cons (car set) (adjoin-set x (cdr set))))))
;;gosh> (define set '(2 3 5 6))
;;set
;;gosh> (adjoin-set 1 set)
;;(1 2 3 5 6)
;;gosh> (adjoin-set 7 set)
;;(2 3 5 6 7)
;;gosh> (adjoin-set 4 set)
;;(2 3 4 5 6)
;;gosh> (adjoin-set 3 set)
;;(2 3 5 6)

Exercise 2.62

(define (union-set set1 set2)
  (cond ((null? set1) set2)
        ((null? set2) set1)
        (else (let ((x1 (car set1))
                    (x2 (car set2)))
                (cond ((= x1 x2) (cons x1 (union-set (cdr set1) (cdr set2))))
                      ((< x1 x2) (cons x1 (union-set (cdr set1) set2)))
                      (else (cons x2 (union-set set1 (cdr set2)))))))))
;;gosh> (define set1 '(1 3 5 7))
;;set1
;;gosh> (define set2 '(2 4 5 6 8))
;;set2
;;gosh> (union-set set1 set2)
;;(1 2 3 4 5 6 7 8)

Exercise 2.63

(define t1 (make-tree 7 (make-tree 3 (make-tree 1 '() '()) (make-tree 5 '() '()))
                      (make-tree 9 () (make-tree 11 '() '()))))
(define t2 (make-tree 3 (make-tree 1 '() '())
                      (make-tree 7 (make-tree 5 '() '()) (make-tree 9 '() (make-tree 11 '() '())))))
(define t3 (make-tree 5 (make-tree 3 (make-tree 1 '() '()) '())
                      (make-tree 9 (make-tree 7 '() '()) (make-tree 11 '() '()))))
(define (tree->list-1 tree)
  (if (null? tree)
      '()
      (append (tree->list-1 (left-branch-tree tree))
              (cons (entry tree)
                    (tree->list-1 (right-branch-tree tree))))))
(define (tree->list-2 tree)
  (define (copy-to-list tree result-list)
    (if (null? tree)
        result-list
        (copy-to-list (left-branch-tree tree)
                      (cons (entry tree)
                            (copy-to-list (right-branch-tree tree)
                                          result-list)))))
  (copy-to-list tree '()))
;;gosh>t1
;;(7 (3 (1 () ()) (5 () ())) (9 () (11 () ())))
;;gosh> t2
;;(3 (1 () ()) (7 (5 () ()) (9 () (11 () ()))))
;;gosh> t3
;;(5 (3 (1 () ()) ()) (9 (7 () ()) (11 () ())))
;;gosh> (tree->list-1 t1)
;;(1 3 5 7 9 11)
;;gosh> (tree->list-1 t2)
;;(1 3 5 7 9 11)
;;gosh> (tree->list-1 t3)
;;(1 3 5 7 9 11)
;;gosh> (tree->list-2 t1)
;;(1 3 5 7 9 11)
;;gosh> (tree->list-2 t2)
;;(1 3 5 7 9 11)
;;gosh> (tree->list-2 t3)
;;(1 3 5 7 9 11)
; a  両方ともbinary-treeからordered-listを生成
; b  両方とも１度の呼出しでエントリを正しい位置においてleft-branchとright-branchを再帰的に処理するので
;    オーダとしては同じθ(n)？

Exercise 2.64

Exercise 2.65

Exercise 2.66

Exercise 2.67

(define sample-tree
  (make-code-tree (make-leaf 'A 4)
                  (make-code-tree
                   (make-leaf 'B 2)
                   (make-code-tree (make-leaf 'D 1)
                                   (make-leaf 'C 1)))))
(define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0))
;;gosh> (decode sample-message sample-tree)
;;(A D A B B C A)

Exercise 2.68

(define (encode message tree)
  (if (null? message)
      '()
      (append (encode-symbol (car message) tree)
              (encode (cdr message) tree))))
(define (encode-symbol symbol tree)
  (define (rec stree)
    (cond ((leaf? stree) '())
          ((memq symbol (symbols (left-branch stree)))
           (cons 0 (rec (left-branch stree))))
          (else
           (cons 1 (rec (right-branch stree))))))
  (if (memq symbol (symbols tree))
      (rec tree)
      (error "bad symbol -- ENCODE-SYMBOL" symbol)))
;;gosh> (encode '(A D A B B C A) sample-tree)
;;(0 1 1 0 0 1 0 1 0 1 1 1 0)

Exercise 2.69

(define (generate-huffman-tree pairs)
  (successive-merge (make-leaf-set pairs)))
(define (successive-merge leaf-set)
  (cond ((null? (cdr leaf-set)) (car leaf-set))
        (else (successive-merge (adjoin-set-huffman
                                 (make-code-tree (car leaf-set) (cadr leaf-set))
                                 (cddr leaf-set))))))
(define pairs '((A 4) (B 2) (C 1) (D 1)))
;;gosh> (display (generate-huffman-tree pairs))
;;((leaf A 4) ((leaf B 2) ((leaf D 1) (leaf C 1) (D C) 2) (B D C) 4) (A B D C) 8)#<undef>

Exercise 2.70

Exercise 2.71

Exercise 2.72

Exercise 2.73

Exercise 2.74

Exercise 2.75

Exercise 2.76

Exercise 2.77

(define (install-complex-selector-package)
  (put 'reak-part '(complex) real-part)
  (put 'imag-part '(complex) imag-part)
  (put 'magnitude '(complex) magnitude)
  (put 'angle '(complex) angle))
(install-complex-selector-package)
(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))
;;gosh> (define z (make-complex-from-real-imag 3 4))
;;z
;;gosh> z
;;(complex rectangular 3 . 4)
;;gosh> (magnitude z)
;;5.0
;;(magnitude::top z)->(apply-genric 'magnitude z)->
;;(magnitude::top (cdr z))->(apply-generic 'magnitude (cdr z))->
;;(magnitude::rectangular-package (cddr z))->5.0

Exercise 2.78

(define (attach-tag type-tag contents)
  (cond ((eq? type-tag 'scheme-number) contents)
        (else (cons type-tag contents))))
(define (type-tag datum)
  (cond ((number? datum) 'scheme-number)
        ((pair? datum) (car datum))
        (else (error "Bad tagged datum -- TYPE-TAG" datum))))
(define (contents datum)
  (cond ((number? datum) datum)
        ((pair? datum) (cdr datum))
        (else (error "Bad tagged datum -- CONTENTS" datum))))
;;gosh> (define n (make-scheme-number 5))
;;n
;;gosh> n
;;5
;;gosh> (type-tag n)
;;scheme-number
;;gosh> (contents n)
;;5

Exercise 2.79

Exercise 2.80

(define (=zero? x) (apply-generic '=zero? x))
(define (install-=zero?-package)
  (put '=zero? '(scheme-number) (lambda (x) (= x 0)))
  (put '=zero? '(rational)
       (lambda (q) (=zero? (numer q))))
  (put '=zero? '(complex)
       (lambda (z) (=zero? (magnitude z))))
  'done)
(install-=zero?-package)
;; テスト
(define o0 0)
(define o1 1)
(define r0 (make-rational 0 1))
(define r0.5 (make-rational 1 2))
(define c1 (make-complex-from-real-imag 1 1))
(define c0 (make-complex-from-mag-ang 0 1))
;; 結果
;;gosh> (=zero? o0)
;;#t
;;gosh> (=zero? o1)
;;#f
;;gosh> (=zero? r0)
;;#t
;;gosh> (=zero? r0.5)
;;#f
;;gosh> (=zero? c1)
;;#f
;;gosh> (=zero? c0)
;;#t

Exercise 2.81

Exercise 2.82

Exercise 2.83

Exercise 2.84

Exercise 2.85

Exercise 2.86

Exercise 2.87

;; なぜadjoin-termはzero?でなく=zero?を使うのだろう？
;;
(put 'zero? '(polynomial)
     (lambda (z) (empty-termlist? z)))
(define (=zero? coeff)
  (zero? coeff))
;; テスト
(define p1 (make-polynomial 'x '((4 4) (2 2) (0 1))))
(define p2 (make-polynomial 'x '((3 3) (1 1))))
(define p3 (make-polynomial 'x '((2 -2))))
(define p4 (make-polynomial 'x '((2 2))))
(define p5 (make-polynomial 'y '((3 (polynomial x (2 -2))) (1 1))))
(define p6 (make-polynomial 'y '((3  (polynomial x (2 2))) (1 1))))
(display (add p1 p2)) (newline)
(display (add p2 p1)) (newline)
(display (add p1 p3)) (newline)
(display (add p3 p4)) (newline)
(display p3) (newline)
(display p4) (newline)
(display p5) (newline)
(display p6) (newline)
(display (add p5 p6)) (newline)
;; 結果
(polynomial x (4 4) (3 3) (2 2) (1 1) (0 1))
(polynomial x (4 4) (3 3) (2 2) (1 1) (0 1))
(polynomial x (4 4) (0 1))
(polynomial x)
(polynomial x (2 -2))
(polynomial x (2 2))
(polynomial y (3 (polynomial x (2 -2))) (1 1))
(polynomial y (3 (polynomial x (2 2))) (1 1))
(polynomial y (3 (polynomial x)) (1 2)) ；一応多項式の係数も判定できているようだ

上記はex2.80で定義する汎用述語が「=zero?」ではなく「zero?」と勘違いしていたため、間違った
内容となっています。

;; ex2.80に追加して
;; polynomial用の=zero?をgeneric operationに登録
(put '=zero? '(polynomial)
     (lambda (z) (empty-termlist? z))) 
;; テスト
(define p1 (make-polynomial 'x '((4 4) (2 2) (0 1))))
(define p2 (make-polynomial 'x '((3 3) (1 1))))
(define p3 (make-polynomial 'x '((2 -2))))
(define p4 (make-polynomial 'x '((2 2))))
(define p5 (make-polynomial 'y '((3 (polynomial x (2 -2))) (1 1))))
(define p6 (make-polynomial 'y '((3  (polynomial x (2 2))) (1 1))))
(display (add p1 p2)) (newline)
(display (add p2 p1)) (newline)
(display (add p1 p3)) (newline)
(display (add p3 p4)) (newline)
(display p3) (newline)
(display p4) (newline)
(display p5) (newline)
(display p6) (newline)
(display (add p5 p6)) (newline)
;; 結果
;;(polynomial x (4 4) (3 3) (2 2) (1 1) (0 1))
;;(polynomial x (4 4) (3 3) (2 2) (1 1) (0 1))
;;(polynomial x (4 4) (0 1))
;;(polynomial x)
;;(polynomial x (2 -2))
;;(polynomial x (2 2))
;;(polynomial y (3 (polynomial x (2 -2))) (1 1))
;;(polynomial y (3 (polynomial x (2 2))) (1 1))
;;(polynomial y (3 (polynomial x)) (1 2)) ；一応多項式の係数も判定できているようだ