Exercise2.53~2.72

Exercise2.53

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

by iwk

Exercise2.54

(define (myequal? x y)
  (cond ((and (null? x) (null? y)) #t)
	((and (list? x) (list? y)) (and (myequal? (car x) (car y)) (myequal? (cdr x) (cdr y))))
	(else (eq? x y))))

by iwk

Exercise2.55

まず、quote手続きと"'"の関係について述べる。
R5RSによると
'<datum>
(quote <datum>)
の単なる省略であると規定されている。
そして、また以下のようなことが成り立つ。
'(quote a) => (quote a)
''a        => (quote a)

これを踏まえ問題を解いてみる。
''abracadabra
はR5RSによれば
''abracadabra => (quote abracadabra)
と評価される。すなわち、データ形式で表現すると
[・][・] -> [・][/]
 ↓          ↓
[quote]     [abracadabra]
というリストになっている。第一要素はquoteであるので
このリストをcarすればquoteが返る。

by iwk

Exercise2.56

(define (exponentiation? x)
  (and (pair? x) (eq? (car x) '**)))
(define (base exp) (cadr exp))
(define (exponent exp) (caddr exp))
(define (make-exponentiation base pow)
  (cond ((=number? pow 0) 1)
	((=number? pow 1) base)
	((=number? base 0) 0)
	(else (list '** base pow))))

(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 expressin type --DERIV" exp))))

by iwk

Exercise2.57

(define (augend s)
  (let ((as (cddr s)))
    (if (null? (cdr as))
	(car as)
	(cons '+ as))))
(define (multiplicand p)
  (let ((ms (cddr p)))
    (if (null? (cdr ms))
	(car ms)
	(cons '* ms))))

by iwk

Exercise2.58

a.
(define (make-infix-sum a1 a2)
  (cond ((=number? a1 0) a2)
	((=number? a2 0) a1)
	(else (list a1 '+ a2))))
(define (make-infix-product m1 m2)
  (cond ((or (=number? m1 0) (=number? m2 0)) 0)
	((=number? m1 1) m2)
	((=number? m2 1) m1)
	(else (list m1 '* m2))))
(define (infix-sum? x)
  (and (pair? x) (eq? (cadr x) '+)))
(define (infix-addend s) (car s))
(define (infix-augend s) (caddr s))
(define (infix-product? x)
  (and (pair? x) (eq? (cadr x) '*)))
(define (infix-multiplier p) (car p))
(define (infix-multiplicand p) (caddr p))
(define (derive exp var)
  (cond ((number? exp) 0)
	((variable? exp)
	 (if (same-variable? exp var) 1 0))
	((infix-sum? exp)
	 (make-infix-sum (derive (infix-addend exp) var)
			 (derive (infix-augend exp) var)))
	((infix-product? exp)
	 (make-infix-sum
	  (make-infix-product (infix-multiplier exp)
			      (derive (infix-multiplicand exp) var))
	  (make-infix-product (derive (infix-multiplier exp) var)
			      (infix-multiplicand exp))))
	((exponentiation? exp)
	 (make-product (make-product (exponent exp) (make-exponentiation (base exp) (- (exponent exp) 1)))
		       (deriv (base exp) var)))
	(else
	 (error "unknown expressin type --DERIV" exp))))

b.
(define (make-infix-sum a1 a2)
  (cond ((=number? a1 0) a2)
	((=number? a2 0) a1)
	((infix-sum? a2) (cons a1 (cons '+ a2)))
	((infix-product? a2) (cons a1 (cons '* a2)))
	((and (number? a1) (number? a2)) (+ a1 a2))
	(else (list a1 '+ a2))))
(define (make-infix-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))))
(define (infix-sum? x) (and (pair? x) (eq? (cadr x) '+)))
(define (infix-addend s) (car s))
(define (infix-augend s)
  (let ((as (cddr s)))
    (if (null? (cdr as))
(car as)
	as)))
(define (infix-product? x) (and (pair? x) (eq? (cadr x) '*)))
(define (infix-multiplier p) (car p))
(define (infix-multiplicand p)
  (let ((ms (cddr p)))
    (if (null? (cdr ms))
	(car ms)
	ms)))

by iwk

Exercise2.59

(use srfi-1)
(define (union-set set1 set2)
  (append (append-map (lambda (x) (if (element-of-set? x set2) '() (list x))) set1) set2))

by iwk

Exercise2.60

Exercise2.61

(define (pivot xs)
  (cond ((or (null? xs) (null? (cdr xs))) 'done)
	((<= (car xs) (cadr xs)) (pivot (cdr xs)))
	(else (car xs))))
(define (partition piv xs lt mt)
  (if (null? xs)
      (cons lt mt)
      (if (< (car xs) piv)
	  (partition piv (cdr xs) (cons (car xs) lt) mt)
	  (partition piv (cdr xs) lt (cons (car xs) mt)))))
(define (qsort xs)
  (let ((piv (pivot xs)))
    (if (equal? piv 'done)
	xs
	(let* ((parts (partition piv xs '() '()))
	       (lt (car parts))
	       (mt (cdr parts)))
	  (append (qsort lt) (qsort mt))))))
(define (adjoin-ordered-set x set)
  (if (element-of-ordered-set? x set)
      set
      (qsort (cons x set))))

by iwk

Exercise2.62

Exercise2.63

Exercise2.64

Exercise2.65

Exercise2.66

Exercise2.67

gosh> (decode sample-message sample-tree)
(A D A B B C A)

by iwk

Exercise2.68

(define (encode message tree)
  (if (null? message)
      '()
      (append (encode-symbol (car message) tree)
	      (encode (cdr message) tree))))
(define (encode-symbol s tree)
  (if (leaf? tree)
      '()
      (let* ((left (left-branch tree))
	     (lsymbol (symbols left))
	     (right (right-branch tree))
	     (rsymbol (symbols right)))
	(cond ((elem s lsymbol) (cons 0 (encode-symbol s left)))
	      ((elem s rsymbol) (cons 1 (encode-symbol s right)))
	      (else (error "can't reach the leaf that holds the symbol -- ENCODE-SYMBOL" tree))))))
(define (elem x xs)
  (cond ((null? xs) #f)
	((equal? x (car xs)) #t)
	(else (elem x (cdr xs)))))

by iwk

Exercise2.69

(define (generate-huffman-tree pairs)
  (successive-merge (make-leaf-set pairs)))
(define (successive-merge leaves)
  (cond ((null? leaves) '())
	((null? (cdr leaves)) (car leaves))
	(else
	 (let ((ls (quick-huffman-sort leaves)))
	   (successive-merge (cons (make-code-tree (car ls) (cadr ls)) (cddr ls)))))))

(define (sorted? xs functor)
  (if (or (null? xs) (null? (cdr xs)))
      #t
      (let ((first (car xs))
	    (second (cadr xs)))
	(and (or ((functor =) first second) ((functor <) first second))
	     (sorted? (cdr xs) functor)))))
(define (split piv xs lt mt functor)
  (cond ((null? xs)
	 (cons lt mt))
	(((functor <) (car xs) piv)
	 (split piv (cdr xs) (cons (car xs) lt) mt functor))
	(else
	 (split piv (cdr xs) lt (cons (car xs) mt) functor))))
(define (quick-sort xs functor)
  (if (sorted? xs functor)
      xs
      (let* ((mean (- (quotient (length xs) 2) 1))
	     (piv (list-ref xs mean))
	     (splited (split piv xs '() '() functor))
	     (lt (car splited))
	     (mt (cdr splited)))
	(append (quick-sort lt functor) (quick-sort mt functor)))))

(define (quick-huffman-sort xs)
  (quick-sort xs (lambda (op) (lambda (x y) (op (weight x) (weight y))))))

by iwk

Exercise2.70

(define rock-pairs '((A 2) (NA 16) (BOOM 1) (SHA 3) (GET 2) (YIP 9) (JOB 2) (WAH 1)))
(define rock-tree (generate-huffman-tree rock-pairs))
(define rock-phrase '(GET A JOB
			  SHA NA NA NA NA NA NA NA NA
			  GET A JOB
			  SHA NA NA NA NA NA NA NA NA
			  WAH YIP YIP YIP YIP YIP YIP YIP YIP YIP
			  SHA BOOM))
 
gosh> (encode rock-phrase rock-tree)
(1 1 0 0 1 1 0 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 1 1 0 0 1 1 0 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 1 1 1 1 0 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 1 1 0 1 1 1 1 0 1)

by iwk

Exercise2.71

(use srfi-13)
(define (make-pairs n)
  (let* ((init (char->integer #\A))
	 (table (string-tabulate (compose integer->char (pa$ + init)) n))
	 (symlist ((compose (map$ (compose string->symbol list->string list)) string->list) table)) )
    (list-ec (:parallel (:list s symlist) (: i (+ n 1))) (list s (expt 2 i)))))
(define (pow-tree n)
  (generate-huffman-tree (make-pairs n)))
(define tree-5 (pow-tree 5))
(define tree-10 (pow-tree 10))

;gosh> (encode '(A) tree-5)
;(0 0 0 0)
;gosh> (encode '(E) tree-5)
;(1)
;
;gosh> (encode '(A) tree-10)
;(0 0 0 0 0 0 0 0 0)
;gosh> (encode '(J) tree-10)
;(1)

by iwk

タグ:

+ タグ編集
  • タグ:

このサイトはreCAPTCHAによって保護されており、Googleの プライバシーポリシー利用規約 が適用されます。

最終更新:2008年03月19日 01:15
ツールボックス

下から選んでください:

新しいページを作成する
ヘルプ / FAQ もご覧ください。