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
最終更新:2008年03月19日 01:15