Todo
3.8
3.9
3.10
3.11
3.20
3.26
3.27
3.30
3.31
3.32
3.33
3.34
3.35
3.36
3.37
Exercise 3.1
(define (make-accumulator sum)
(lambda (num) (set! sum (+ sum num)) sum))
;;gosh> (define A (make-accumulator 5))
;;A
;;gosh> (A 10)
;;15
;;gosh> (A 10)
;;25
Exercise 3.2
(define (make-monitored f)
(let ((count 0))
(lambda (x)
(cond ((eq? x 'how-many-calls?) count)
((eq? x 'reset-count) (set! count 0))
(else (begin (set! count (+ count 1))
(f x)))))))
;;gosh> (define s (make-monitored sqrt))
;;s
;;gosh> (s 100)
;;10.0
;;gosh> (s 'how-many-calls?)
;;1
;;gosh> (s 'reset-count)
;;0
;;gosh> (s 'how-many-calls?)
;;0
Exercise 3.3
(define (make-account balance password)
(define (withdraw amount)
(if (>= balance amount)
(begin (set! balance (- balance amount))
balance)
"Insufficient funds"))
(define (deposit amount)
(set! balance (+ balance amount))
balance)
(define (dispatch p m)
(cond ((pass-error? p) (lambda (m)))
((eq? m 'withdraw) withdraw)
((eq? m 'deposit) deposit)
(else (error "Unknown request -- MAKE-ACCOUNT" m)))
)
(define (pass-error? p)
(if (eq? p password)
#f
(error "Incorrect password")))
dispatch)
;;gosh> (define acc (make-account 100 'secret-password))
;;acc
;;gosh> ((acc 'secret-password 'withdraw) 40)
;;60
;;gosh> ((acc 'some-other-password 'deposit) 50)
;;*** ERROR: Incorrect password
Exercise 3.4
;; 7回連続ではテストが面倒なので4回連続で
(define (make-account balance password)
(let ((ipc 0))
(define (withdraw amount)
(if (>= balance amount)
(begin (set! balance (- balance amount))
balance)
"Insufficient funds"))
(define (deposit amount)
(set! balance (+ balance amount))
balance)
(define (dispatch p m)
(cond ((pass-error? p) (lambda (m)))
((eq? m 'withdraw) withdraw)
((eq? m 'deposit) deposit)
(else (error "Unknown request -- MAKE-ACCOUNT" m)))
)
(define (pass-error? p)
(if (eq? p password)
(begin (set! ipc 0) #f)
(begin (display "Incorrect password")(newline)
(set! ipc (+ ipc 1))
(if (> ipc 3)
(display "call-the-cops")
)
#t)))
dispatch))
;;gosh> (define a (make-account 100 'a))
;;a
;;gosh> ((a 'b 'withdraw) 20)
;;Incorrect password
;;#<undef>
;;gosh> ((a 'b 'withdraw) 20)
;;Incorrect password
;;#<undef>
;;gosh> ((a 'b 'withdraw) 20)
;;Incorrect password
;;#<undef>
;;gosh> ((a 'b 'withdraw) 20)
;;Incorrect password
;;call-the-cops#<undef>
Exercise 3.5
(use srfi-27)
(define (estimate-integral p x1 x2 y1 y2 trials)
(let ((xl (if (< x1 x2) x1 x2))
(xh (if (< x1 x2) x2 x1))
(yl (if (< y1 y2) y1 y2))
(yh (if (< y1 y2) y2 y1)))
(define (experiment)
(let ((x (random-in-range xl xh))
(y (random-in-range yl yh)))
(p x y)))
(define (random-in-range low high)
(let ((range (- high low)))
(+ low (* (random-real) range))))
(abs (* (- x1 x2) (- y1 y2) (monte-carlo trials experiment)))))
;;
(define (p x y)
(<= (+ (expt (- x 5.0) 2) (expt (- y 7.0) 2)) 9.0))
;;gosh> (/ (estimate-integral p 2 8 4 10 100000) 9.0)
;;3.1396800000000002
;;gosh> (/ (estimate-integral p 2 8 4 10 1000000) 9.0)
;;3.142024
Exercise 3.6
(define rand
(let ((x 0))
(define (rand-update x)
(remainder (+ (* x 93) 5) 128))
(define reset
(lambda (nv)
(set! x nv)))
(define generate
(lambda ()
(set! x (rand-update x))
x))
(define (dispatch m)
(cond ((eq? m 'generate) generate)
((eq? m 'reset) reset)
(else (error "Unknown request -- RAND" m))))
dispatch))
;;gosh> ((rand 'generate))
;;5
;;gosh> ((rand 'generate))
;;86
;;gosh> ((rand 'generate))
;;67
;;gosh> ((rand 'reset) 0)
;;0
;;gosh> ((rand 'generate))
;;5
;;gosh> ((rand 'generate))
;;86
;;gosh> ((rand 'generate))
;;67
Exercise 3.7
(define (make-account balance password)
(define (withdraw amount)
(if (>= balance amount)
(begin (set! balance (- balance amount))
balance)
"Insufficient funds"))
(define (deposit amount)
(set! balance (+ balance amount))
balance)
(define (dispatch p m)
(cond ((pass-error? p) (lambda (m)))
((eq? m 'withdraw) withdraw)
((eq? m 'deposit) deposit)
(else (error "Unknown request -- MAKE-ACCOUNT" m)))
)
(define (pass-error? p)
(if (eq? p password)
#f
(error "Incorrect password")))
dispatch)
;; 正しい新しいpasswordなら本来のpasswordでaccountにアクセスする
(define (make-joint account password new-password)
(define (joint p m)
(cond ((pass-error? p) (lambda (m)))
(else (account password m))
))
(define (pass-error? p)
(if (eq? p new-password)
#f
(error "Incorrect password")))
joint)
;;gosh> (define peter-acc (make-account 150 'open-sesame))
;;peter-acc
;;gosh> (define paul-acc (make-joint peter-acc 'open-sesame 'rosebud))
;;paul-acc
;;gosh> ((paul-acc 'rosebud 'deposit) 20)
;;170
;;gosh> ((paul-acc 'rosebud 'withdraw) 70)
;;100
;;gosh> ((paul-acc 'xxxxx 'deposit) 100)
;;*** ERROR: Incorrect password
;;gosh> (define john-acc (make-joint peter-acc 'close-sesame 'xyzzz))
;;john-acc
;;gosh> ((john-acc 'xyzzz 'withdraw) 30)
;;*** ERROR: Incorrect password
Exercise 3.12
(define (append! x y)
(set-cdr! (last-pair x) y)
x)
(define x (list 'a 'b))
(define y (list 'c 'd))
(define z (append x y))
z
;(a b c d)
;; x->[ | ]->[ |/]
;; a b
(cdr x)
;(b)
(define w (append! x y))
;; y->[ | ]->[ |/]
;; c d
;; x↓
;; w->[ | ]->[ | ]->[ | ]->[ |/]
;; a b c d
w
;(a b c d)g
(cdr x)
;(b c d)
Exercise 3.13
(define (make-cycle x)
(set-cdr! (last-pair x) x)
x)
(define z (make-cycle (list 'a 'b 'c))
;; +---------------+
;; ↓ ↑
;; z->[ | ]->[ | ]->[ | ]
;; 'a 'b 'c
;(last-pair z)
→loop(こういう状態のことをどう表現するのがいいのだろう？
hang upはちょっと違う気がするし。
Exercise 3.14
(define (mystery x)
(define (loop x y)
(if (null? x)
y
(let ((temp (cdr x)))
(set-cdr! x y)
(loop temp x))))
(loop x '()))
;; may be reverse!
(define v (list 'a 'b 'c 'd))
;v->[ | ]->[ | ]->[ | ]->[ |/]
; a b c d
(define w (mystery v))
;v-----------------------↓
;w->[ | ]->[ | ]->[ | ]->[ |/]
; d c b a
Exercise 3.15
(define (set-to-wow! x)
(set-car! (car x) 'wow)
x)
(define x (list 'a 'b))
(define z1 (cons x x))
;z1->[ | ]
; ↓ ↓
;x ->[ | ]->[ |/])
; ↓ ↓
; 'a 'b
(set-to-wow! z1)
; ((wow b) wow b)
;z1->[ | ]
; ↓ ↓
;x ->[ | ]->[ |/])
; ↓ ↓
; 'wow 'b
(define z2 (cons (list 'a 'b) (list 'a 'b)))
;z2->[ | ]->[ | ]->[ |/])
; | ↓ ↓
; | 'a 'b
; | ↑ ↑
; ----->[ | ]->[ |/])
(set-to-wow! z2)
; ((wow b) a b)
;z2->[ | ]->[ | ]->[ |/]
; | ↓ ↓
; | 'a 'b
; | ↑
; ----->[ | ]->[ |/]
; ↓
; 'wow
Exercise 3.16
(define (count-pairs x)
(if (not (pair? x))
0
(+ (count-pairs (car x))
(count-pairs (cdr x))
1)))
(define c3 '(a b c))
;; (count-pairs c3)
;; 3
; c3->[ | ]->[ | ]->[ |/]
(define c4
(let ((x '(a b c)))
(set-car! x (cddr x))
x))
;; (cout-pairs c4)
;; 4
; c4->[ | ]->[ | ]->[ |/]
; ↓-----------↑
(define c7
(let ((x '(a b c)))
(set-car! x (cdr x))
(set-car! (cdr x) (cddr x))
x))
;; (count-pairs c7)
;; 7
; ↑-----↓
; c7->[ | ]->[ | ]->[ |/]
; ↓-----↑
(define cl
(let ((x '(a b c)))
(set-cdr! (cddr x) x)
x))
;; (count-pairs cl)
;;
; cl->[ | ]->[ | ]->[ | ]
; ↑--------------↓
Exercise 3.17
;; c3, c4, c7, cl は Exercise 3.16 のものを使用
(define (count-pairs x)
(let ((marked '()))
(define (count-with-mark x)
(if (or (not (pair? x)) (memq x marked))
0
(begin (set! marked (cons x marked))
(+ (count-with-mark (car x))
(count-with-mark (cdr x))
1))))
(count-with-mark x)))
;;gosh> (count-pairs c3)
;;3
;;gosh> (count-pairs c4)
;;3
;;gosh> (count-pairs c7)
;;3
;;gosh> (count-pairs cl)
;;3
Exercise 3.18
(define (cycle? x)
(let ((marked '()))
(define (suc x)
(let ((save '()))
(cond ((memq x marked) #t) ;; cycle
(else
(set! marked (cons x marked))
(cond ((pair? (car x))
(set! save marked) ;; save current marked list
(cond ((suc (car x)) #t) ;; cycle in car part
(else (set! marked save) (suc (cdr x)))))
((or (null? (cdr x)) (not (pair? (cdr x)))) #f)
(else (suc (cdr x))))))))
(if (pair? x)
(suc x)
(error "CYCLE? gets not pair" x))))
(define c3 (list 'a 'b 'C))
(define c4
(let ((x '(a b c)))
(set-car! (cdr x) (cddr x))
x))
(define cycle1
(let ((x '(a b c)))
(set-cdr! (cddr x) x)
x))
(define cycle2
(let ((x '(a b c)))
(set-car! (cddr x) x)
x))
(define cycle3
(let ((x '(a b c)))
(set-cdr! x x)
x))
(define cycle4
(let ((x '(a b c)))
(set-car! x x)
x))
;;gosh> (cycle? c3)
;;#f
;;gosh> (cycle? c4)
;;#f
;;gosh> (cycle? cycle1)
;;#t
;;gosh> (cycle? cycle2)
;;#t
;;gosh> (cycle? cycle3)
;;#t
;;gosh> (cycle? cycle4)
;;#t
Exercise 3.19
;; このpairはlistの中で何番目のpairのはずというのを確認することでloopを検出する。
;; 一応題意は満足していると思う。carでのloopには対応できない。
(define (cycle? x)
(define (index? k lst)
(define (iter lst count)
(if (eq? k lst)
count
(iter (cdr lst) (+ count 1))))
(iter lst 1))
(define (iter p num)
(cond ((not (pair? (cdr p))) #f)
((= (index? p x) num) (iter (cdr p) (+ num 1)))
(else #t)))
(if (pair? x)
(iter x 1)
(error "CYCLE? gets not pair" x)))
(define c3 (list 'a 'b 'C))
(define cycle1
(let ((x '(a b c)))
(set-cdr! (cddr x) x)
x))
(define cycle3
(let ((x '(a b c)))
(set-cdr! x x)
x))
;;gosh> (cycle? c3)
;;#f
;;gosh> (cycle? c4)
;;#f
;;gosh> (cycle? cycle1)
;;#t
;;gosh> (cycle? cycle2)
;;#t
;;gosh> (cycle? cycle3)
;;#t
;;gosh> (cycle? cycle4)
;;#t
Exercise 3.20
Exercise 3.21
(define (print-queue queue)
(front-ptr queue))
;;gosh> (define q (make-queue))
;;q
;;gosh> (print-queue q)
;;()
;;gosh> (insert-queue! q 'a)
;;(#0=(a) . #0#)
;;gosh> (print-queue q)
;;(a)
;;gosh> (insert-queue! q 'b)
;;((a . #0=(b)) . #0#)
;;gosh> (print-queue q)
;;(a b)
;;gosh> (delete-queue! q)
;;(#0=(b) . #0#)
;;gosh> (print-queue q)
;;(b)
;;gosh> (delete-queue! q)
;;(() b)
;;gosh> (print-queue q)
;;()
Exercise 3.22
(define (make-queue)
(let ((front-ptr '()) (rear-ptr '()))
(define (empty-queue?)
(null? front-ptr))
(define (front-queue)
(if (empty-queue?)
(error "FRONT called with an empty queue")
(car front-ptr)))
(define (insert-queue! item)
(let ((new-pair (cons item '())))
(cond ((empty-queue?)
(set! front-ptr new-pair)
(set! rear-ptr new-pair))
(else
(set-cdr! rear-ptr new-pair)
(set! rear-ptr new-pair)
front-ptr))))
(define (delete-queue!)
(cond ((empty-queue?)
(error "DELETE called with an empty queue"))
(else
(set! front-ptr (cdr front-ptr)))))
(define (dispatch . l)
(let ((m (car l)))
(cond ((eq? m 'front-queue) (front-queue))
((eq? m 'empty-queue?) (empty-queue?))
((eq? m 'insert-queue!) (insert-queue! (cadr l)))
((eq? m 'delete-queue!) (delete-queue!))
(else (error "Undefined operation -- QUEUE")))))
dispatch))
;;gosh> (define q (make-queue))
;;q
;;gosh> (q 'empty-queue?)
;;#t
;;gosh> (q 'insert-queue! 'a)
;;(a)
;;gosh> (q 'empty-queue?)
;;#f
;;gosh> (q 'insert-queue! 'b)
;;(a b)
;;gosh> (q 'insert-queue! 'c)
;;(a b c)
;;gosh> (q 'delete-queue!)
;;(b c)
;;gosh> (q 'front-queue)
;;b
Exercise 3.23
;; deque->[ : ]-----------+
;; | |
;; +->[ : ]+->[ : ]->[ :/] : cdr が次の entry への pointer
;; | | +---|------|-+
;; +---|-------|-+ | |
;; [ :/] [ : ] [ : ] : cdr が前の entry への pointer
;; | | |
;; item1 item2 item3
(define (make-deque)
(cons '() '()))
(define (empty-deque? deque)
(null? (car deque)))
(define (front-deque deque)
(if (empty-deque? deque)
(error "FRONT called with an empty deque" (dq-print (dq-pr)int deque))
(dq-item (front-ptr deque))))
(define (rear-deque deque)
(if (empty-deque? deque)
(error "REAR called with an empty deque" (dq-print deque))
(dq-item (rear-ptr deque))))
(define (front-insert-deque! deque item)
(let ((new-entry (make-dq-entry item)))
(cond ((empty-deque? deque)
(set-front-ptr! deque new-entry)
(set-rear-ptr! deque new-entry)
(dq-print deque))
(else
(dq-set-np! new-entry (front-ptr deque))
(dq-set-pp! (front-ptr deque) new-entry)
(set-front-ptr! deque new-entry)
(dq-print deque)))))
(define (rear-insert-deque! deque item)
(let ((new-entry (make-dq-entry item)))
(cond ((empty-deque? deque)
(set-front-ptr! deque new-entry)
(set-rear-ptr! deque new-entry)
(dq-print deque))
(else
(dq-set-pp! new-entry (rear-ptr deque))
(dq-set-np! (rear-ptr deque) new-entry)
(set-rear-ptr! deque new-entry)
(dq-print deque)))))
(define (front-delete-deque! deque)
(cond ((empty-deque? deque)
(error "FRONT-DELETE called with an empty deque" (dq-print deque)))
((null? (dq-np (front-ptr deque)))
(set-front-ptr! deque '())
(dq-print deque))
(else
(dq-set-pp! (dq-np (front-ptr deque)) '())
(set-front-ptr! deque (dq-np (front-ptr deque)))
(dq-print deque))))
(define (rear-delete-deque! deque)
(cond ((empty-deque? deque)
(error "REAR-DELETE called with an empty deque" (dq-print deque)))
((null? (dq-np (front-ptr deque)))
(set-front-ptr! deque '())
(dq-print deque))
(else
(dq-set-np! (dq-pp (rear-ptr deque)) '())
(set-rear-ptr! deque (dq-pp (rear-ptr deque)))
(dq-print deque))))
(define (make-dq-entry item)
(cons (cons item '()) '()))
(define (dq-item dq-entry)
(caar dq-entry))
(define (dq-np dq-entry)
(cdr dq-entry))
(define (dq-pp dq-entry)
(cdar dq-entry))
(define (dq-set-np! dq-entry ptr)
(set-cdr! dq-entry ptr))
(define (dq-set-pp! dq-entry ptr)
(set-cdr! (car dq-entry) ptr))
(define (dq-print deque)
(define (iter ep)
(cond ((null? ep) (display ")") (newline))
(else
(display (dq-item ep)) (if (not (null? (dq-np ep))) (display " ") #t)
(iter (dq-np ep)))))
(define (iterr ep)
(cond ((null? ep) (display "]") (newline))
(else
(display (dq-item ep)) (if (not (null? (dq-pp ep))) (display " ") #t)
(iterr (dq-pp ep)))))
(display "(")
(iter (front-ptr deque))
(display "[")
(iterr (dequee)))
;;gosh> (define dq (make-deque))
;;dq
;;gosh> (front-insert-deque! dq 'a)
;;(a)
;;[a]
;;#<undef>
;;gosh> (rear-insert-deque! dq 'c)
;;(a c)
;;[c a]
;;#<undef>
;;gosh> (front-delete-deque! dq)
;;(c)
;;[c]
;;#<undef>
;;gosh> (rear-delete-deque! dq)
;;()
;;[c]
;;#<undef>
Exercise 3.24
(define (make-table same-key?)
(let ((local-table (list '*table*)))
(define (assoc key alist)
(cond ((null? alist) #f)
((same-key? key (caar alist)) (car alist))
(else (assoc key (cdr alist)))))
(define (lookup key-1 key-2)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
#f)))))
(define (insert! key-1 key-2 value)
(let ((subtable (assoc key-1 (cdr local-table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! local-table
(cons (list key-1
(cons key-2 value))
(cdr local-table))))
'ok))
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define operation-table (make-table same-key?))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
;; 整数部分での比較
(define (same-key? key val)
(equal? (floor key) (floor val)))
(put 1.5 1.5 '1*1)
(put 2.5 2.5 '2*2)
;;gosh> (get 2.2 2.2)
;;|2*2|
;;gosh> (get 1.2 1.2)
;;|1*1|
;;gosh> (get 2.2 1.2)
;;#f
Exercise 3.25
;; キー数を内部的に1stキーとする。
(define (make-table)
(let ((local-table (list '*table*)))
(define (lookup key-list)
(define (iter keys subtable)
(let ((tr (assoc (car keys) (cdr subtable))))
(cond ((not tr) #f)
((and tr (null? (cdr keys))) (cdr tr))
(else (iter (cdr keys) tr)))))
(iter (cons (length key-list) key-list) local-table))
(define (insert! key-list value)
(define (iter keys subtable)
(let ((tr (assoc (car keys) (cdr subtable))))
(cond ((and tr (null? (cdr keys))) (set-cdr! tr value))
(tr (iter (cdr keys) tr))
((null? (cdr keys))
(set-cdr! subtable (cons (cons (car keys) value)
(cdr subtable))))
(else (set-cdr! subtable (cons (cons (car keys) '())
(cdr subtable)))
(iter (cdr keys) (cadr subtable))))))
(iter (cons (length key-list) key-list) local-table)
;;(print local-table)(newline)
'ok)
(define (dispatch m)
(cond ((eq? m 'lookup-proc) lookup)
((eq? m 'insert-proc!) insert!)
(else (error "Unknown operation -- TABLE" m))))
dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))
(put '(1 2 3) 'a)
(put '(1 2 4) 'b)
(put '(1 3 3) 'c)
(put '(1 2 3 4) 'd)
;;gosh> (get '(1 2))
;;#f
;;gosh> (get '(1 2 3))
;;a
;;gosh> (get '(1 2 3 4))
;;d
;;gosh> (get '(1 2 3 4 5))
;;#f
;;gosh> (get '(1 3 3))
;;c
Exercise 3.26
Exercise 3.27
Exercise 3.28
(define (or-gate o1 o2 output)
(define (or-action-procedure)
(let ((new-value
(logical-or (get-signal o1) (get-signal o2))))
(after-delay or-gate-delay
(lambda ()
(set-signal! output new-value)))))
(add-action! o1 or-action-procedure)
(add-action! o2 or-action-procedure)
'ok)
(define (logical-or o1 o2)
(if (and (or (= o1 0) (= o1 1)) (or (= o2 0) (= o2 1)))
(cond ((and (= o1 0) (= o2 0)) 0)
(else 1))
(error "invalid signal" o1 o2)))
(define a (make-wire))
(define b (make-wire))
(define o (make-wire))
(or-gate a b o)
(probe 'a a)
(probe 'b b)
(probe 'o o)
;;a 0 New-value =0
;;b 0 New-value =0
;;o 0 New-value =0
;;#t
;;gosh> (set-signal! a 1)
;;a 0 New-value =1
;;done
;;gosh> (propagate)
;;o 5 New-value =1
;;done
;;gosh> (set-signal! b 1)
;;b 5 New-value =1
;;done
;;gosh> (propagate)
;;done
;;gosh> (set-signal! b 0)
;;b 10 New-value =0
;;done
;;gosh> (propagate)
;;done
;;gosh> (set-signal! a 0)
;;a 15 New-value =0
;;done
;;gosh> (propagate)
;;o 20 New-value =0
;;done
Exercise 3.29
(define (or-gatex o1 o2 output)
(let ((a1 (make-wire)) (a2 (make-wire)) (a3 (make-wire)))
(inverter o1 a1)
(inverter o2 a2)
(and-gate a1 a2 a3)
(inverter a3 output)))
;;2 inverter-delay(=2) + 1 and-gate-delay(=3)
(define a (make-wire))
(define b (make-wire))
(define o (make-wire))
(or-gatex a b o)
(probe 'a a)
(probe 'b b)
(probe 'o o)
;;a 0 New-value =0
;;b 0 New-value =0
;;o 0 New-value =0
;;#t
;;gosh>(set-signal! a 1)
;;a 0 New-value =1
;;done
;;gosh> (propagate)
;;o 2 New-value =1
;;o 7 New-value =0
;;o 7 New-value =1
;;done
;;gosh> (set-signal! b 1)
;;b 7 New-value =1
;;done
;;gosh> (propagate)
;;done
;;gosh> (set-signal! b 0)
;;b 12 New-value =0
;;done
;;gosh> (propagate)
;;done
;;gosh> (set-signal! a 0)
;;a 17 New-value =0
;;done
;;gosh> (propagate)
;;o 24 New-value =0
;;done
最終更新：2008年07月26日 14:16
