Modified the explicit evaluator to a lazy one. And here are the main blocks I added.
actual-value
(save continue)
(save env)
(save exp)
(assign continue (label force-it))
(goto (label eval-dispatch))
force-it
(test (op thunk?) (reg val))
(branch (label thunk-extract))
(restore exp)
(restore env)
(restore continue)
(goto (reg continue))
thunk-extract
(assign env (op thunk-env) (reg val))
(assign exp (op thunk-exp) (reg val))
(goto (label actual-value))
Here is the whole source file
Tuesday, November 29, 2011
Playing with Fibonacci - solution of SICP exercise 5.29
Here is the exercise and my answer.
Exercise 5.29. Monitor the stack operations in the tree-recursive Fibonacci computation:
(define (fib n)
(if (< n 2)
n
(+ (fib (- n 1)) (fib (- n 2)))))
b. Give a formula for the total number of pushes used to compute Fib(n) for n > 2. You should find that the number of pushes (which correlates well with the time used) grows exponentially with n. Hint: Let S(n) be the number of pushes used in computing Fib(n). You should be able to argue that there is a formula that expresses S(n) in terms of S(n - 1), S(n - 2), and some fixed ``overhead'' constant k that is independent of n. Give the formula, and say what k is. Then show that S(n) can be expressed as a Fib(n + 1) + b and give the values of a and b.
My answer:
From Fibonacci function definition above, we can make the conclusion that
S(n) = S(n-1) + S(n-2) + k.
This looks already like the orignal Fibnacci sequence but let's have a look at S(0) and S(1).
S(0) contains only the overhead pushes, let's say this is [a], but not the k above.
S(1) is same.
For S(n) and n>2, k includes not only [a] but also pushes before computation of [+] of S(n-1) and S(n-2).
So S(n) should look like below:
a, a, 2a + k, 3a + 2k, 5a + 4k, ... ...
And the original Fibonacci is:
0, 1, 1, 2, 3, 5, ... ...
Then S(n) must has the format below.
aFib(n+1) + b.
And if given 2 total pushes, etc., S(1) and S(2), we can calculate the value of [a] and [k] as below.
a=16 and k=40.
Experiment:
Exercise 5.29. Monitor the stack operations in the tree-recursive Fibonacci computation:
(define (fib n)
(if (< n 2)
n
(+ (fib (- n 1)) (fib (- n 2)))))
b. Give a formula for the total number of pushes used to compute Fib(n) for n > 2. You should find that the number of pushes (which correlates well with the time used) grows exponentially with n. Hint: Let S(n) be the number of pushes used in computing Fib(n). You should be able to argue that there is a formula that expresses S(n) in terms of S(n - 1), S(n - 2), and some fixed ``overhead'' constant k that is independent of n. Give the formula, and say what k is. Then show that S(n) can be expressed as a Fib(n + 1) + b and give the values of a and b.
My answer:
From Fibonacci function definition above, we can make the conclusion that
S(n) = S(n-1) + S(n-2) + k.
This looks already like the orignal Fibnacci sequence but let's have a look at S(0) and S(1).
S(0) contains only the overhead pushes, let's say this is [a], but not the k above.
S(1) is same.
For S(n) and n>2, k includes not only [a] but also pushes before computation of [+] of S(n-1) and S(n-2).
So S(n) should look like below:
a, a, 2a + k, 3a + 2k, 5a + 4k, ... ...
And the original Fibonacci is:
0, 1, 1, 2, 3, 5, ... ...
Then S(n) must has the format below.
aFib(n+1) + b.
And if given 2 total pushes, etc., S(1) and S(2), we can calculate the value of [a] and [k] as below.
a=16 and k=40.
Experiment:
Saturday, September 17, 2011
Solution of SICP Exercise 5.24
Below is the implementation of cond as a basic form without reducing it to if.
Source code (main part only)
ev-cond
(save continue)
(assign argl (op cond-clauses) (reg exp))
ev-cond-loop
(assign unev (op car) (reg argl))
(test (op cond-else-clause?) (reg unev))
(branch (label ev-cond-actions))
(assign exp (op cond-predicate) (reg unev))
(save argl)
(save unev)
(assign continue (label ev-cond-val))
(goto (label eval-dispatch))
ev-cond-val
(restore unev)
(restore argl)
(test (op true?) (reg val))
(branch (label ev-cond-actions))
(assign argl (op cdr) (reg argl))
(goto (label ev-cond-loop))
ev-cond-actions
(assign unev (op cond-actions) (reg unev))
(assign continue (label ev-cond-end))
(goto (label ev-sequence))
ev-cond-end
(restore continue)
(goto (reg continue))
Test result
Source code (main part only)
ev-cond
(save continue)
(assign argl (op cond-clauses) (reg exp))
ev-cond-loop
(assign unev (op car) (reg argl))
(test (op cond-else-clause?) (reg unev))
(branch (label ev-cond-actions))
(assign exp (op cond-predicate) (reg unev))
(save argl)
(save unev)
(assign continue (label ev-cond-val))
(goto (label eval-dispatch))
ev-cond-val
(restore unev)
(restore argl)
(test (op true?) (reg val))
(branch (label ev-cond-actions))
(assign argl (op cdr) (reg argl))
(goto (label ev-cond-loop))
ev-cond-actions
(assign unev (op cond-actions) (reg unev))
(assign continue (label ev-cond-end))
(goto (label ev-sequence))
ev-cond-end
(restore continue)
(goto (reg continue))
Test result
Friday, September 16, 2011
Find all prime numbers using SQL--Sieve of Eratosthenes
There is no loop syntax in SQL but we can also do the job just as in other programming languages.
Inspired by a book written by Celko, I also wrote a piece of SQL code to find all prime numbers
in a table populated with natural numbers.
Please refer to Sieve of Eratosthenes
Please refer to Sieve of Eratosthenes
Sunday, June 26, 2011
Solution of SICP Exercise 5.17
I think the best solution is adding the label information for each instruction
at the time when the function "extract-labels" is called.
But too lazy to modify many basic functions and decide to add label information
when the machine is created and update/refer to the information in the function
"execute".
The approach to hand "GOTO (REG XXX)" is too dirty and hope to modify it
when have time.
比较好的解决方案应该是在EXTRACT-LABELS函数中给每个指令另外加上LABEL的信息。
但是对于懒得修改很多基本的函数。于是决定在make-machine中加上LABEL的信息，
之后在EXECUTE函数中参照并随时加以修改。
但是之前没有很好考虑处理GOTO (REG xxx)语句的情况，导致不得不根据指令反过来
判断LABEL。希望有时间再修改吧。
一番良い方法は多分、Extract-labels関数に各命令のラベル情報
も追加してあげて、Execute関数それらを出力する。
いくつかの基本関数を修正しなければならないので、気が遠くなったので、
代わりに、make-machineにラベル情報を追加し、Execute関数にそれらを
参照/更新するアプローチを取った。
但し、GOTO （REG xxx）のケースは考慮不足で、汚い処理になってしまった。
時間があるときに修正しようかな。
Execution image（実行イーメージ）
(set-register-contents! fm 'n 3)
;Value: done
(fm 'trace-on)
;Value: #f
(fm 'prepare-label-trace)
;Value: ()
(start fm)
(label: controller text: (assign continue (label fact-done)))
(label: controller text: (test (op =) (reg n) (const 1)))
(label: controller text: (branch (label base-case)))
(label: controller text: (save continue))
(label: controller text: (save n))
(label: controller text: (assign n (op -) (reg n) (const 1)))
(label: controller text: (assign continue (label after-fact)))
(label: controller text: (goto (label fact-loop)))
(label: fact-loop text: (test (op =) (reg n) (const 1)))
(label: fact-loop text: (branch (label base-case)))
(label: fact-loop text: (save continue))
(label: fact-loop text: (save n))
(label: fact-loop text: (assign n (op -) (reg n) (const 1)))
(label: fact-loop text: (assign continue (label after-fact)))
(label: fact-loop text: (goto (label fact-loop)))
(label: fact-loop text: (test (op =) (reg n) (const 1)))
(label: fact-loop text: (branch (label base-case)))
(label: base-case text: (assign val (const 1)))
(label: base-case text: (goto (reg continue)))
(label: after-fact text: (restore n))
(label: after-fact text: (restore continue))
(label: after-fact text: (assign val (op *) (reg n) (reg val)))
(label: after-fact text: (goto (reg continue)))
(label: after-fact text: (restore n))
(label: after-fact text: (restore continue))
(label: after-fact text: (assign val (op *) (reg n) (reg val)))
(label: after-fact text: (goto (reg continue)))
;Value: done
Simulator instructions used above（上記レジスタマシーンfmのコード）：
(define fm
(make-machine
'(n val continue)
(list (list '= =) (list '- -) (list '* *))
'(controller
(assign continue (label fact-done))
fact-loop
(test (op =) (reg n) (const 1))
(branch (label base-case))
(save continue)
(save n)
(assign n (op -) (reg n) (const 1))
(assign continue (label after-fact))
(goto (label fact-loop))
after-fact
(restore n)
(restore continue)
(assign val (op *) (reg n) (reg val))
(goto (reg continue))
base-case
(assign val (const 1))
(goto (reg continue))
fact-done)))
Functions modified and added in the implementation of the simulator machine
(define (make-machine register-names ops controller-text)
(let ((machine (make-new-machine)))
(for-each (lambda (register-name)
((machine 'allocate-register) register-name))
register-names)
((machine 'install-operations) ops)
((machine 'install-labels) controller-text)
((machine 'install-instruction-sequence)
(assemble controller-text machine))
machine))
(define (make-new-machine)
(let ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(the-instruction-sequence '())
(counter 0)
(trace-flg #f)
(the-labels '())
(current-label 'initial-label)
(current-label-counter 1)
(current-label-info '())) (let ((the-ops
(list (list 'initialize-stack
(lambda () (stack 'initialize)))
(list 'print-stack-statistics
(lambda () (stack 'print-statistics)))))
(register-table
(list (list 'pc pc) (list 'flag flag))))
(define (allocate-register name)
(if (assoc name register-table)
(error "Multiply defined register: " name)
(set! register-table
(cons (list name (make-register name))
register-table)))
'register-allocated)
(define (lookup-register name)
(let ((val (assoc name register-table)))
(if val
(cadr val)
(error "Unknown register:" name))))
(define (initialize-program-counter)
(set! counter 0))
(define (print-program-counter)
(newline)
(display (list 'program-counter= counter)))
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
(let ((text (instruction-text (car insts))))
(if (not (false? trace-flg))
(begin
(newline)
(display
(list 'label: (caar current-label-info) 'text: text))))
((instruction-execution-proc (car insts)))
(set! counter (+ counter 1))
(cond ((eq? (car text) 'goto)
(let ((goto-dest (cadr text)))
(if (eq? (car goto-dest) 'reg)
(set-label-info-cmds!
(map
(lambda (x) (car x))
(get-contents pc)))
(set-label-info! (cadr goto-dest)))))
((eq? (car text) 'branch)
(if (get-contents flag)
(set-label-info! (cadadr text))))
(else
(update-label-info! (+ current-label-counter 1))))
(execute)))))
(define (install-labels controller-text)
(define (iter seq symb counter seq-follow-symb)
(if (null? seq)
'()
(if (symbol? (car seq))
(cons (cons symb (cons counter seq-follow-symb))
(iter (cdr seq) (car seq) 0 (cdr seq)))
(iter (cdr seq) symb (+ counter 1) seq-follow-symb))))
(let ((insts (cdr controller-text)))
(iter insts (car controller-text) 0 insts)))
(define (prepare-label-trace!)
(set! current-label-info the-labels))
; (set! current-label (caar current-label-info)))
(define (update-label-info! counter)
(let ((label-counter (car current-label-info)))
(let ((counter-threshold (cadr label-counter)))
(if (= counter counter-threshold)
(begin
(set! current-label-info (cdr current-label-info))
(set! current-label-counter 1))
(set! current-label-counter counter)))))
(define (set-label-info! label)
(define (iter labels-info label-text)
(if (null? labels-info)
(set! current-label-info '())
(if (eq? (caar labels-info) label-text)
(set! current-label-info labels-info)
(iter (cdr labels-info) label-text))))
(iter the-labels label))
(define (set-label-info-cmds! seq)
(define (iter labels-info cmds)
(if (null? labels-info)
(set! current-label-info '())
(if (equal?
(filter
(lambda (x)
(not (symbol? x)))
(cddar labels-info))
cmds)
(set! current-label-info labels-info)
(iter (cdr labels-info) cmds))))
(iter the-labels seq))
(define (dispatch message)
(cond ((eq? message 'start)
(set-contents! pc the-instruction-sequence)
(execute))
((eq? message 'install-instruction-sequence)
(lambda (seq) (set! the-instruction-sequence seq)))
((eq? message 'allocate-register) allocate-register)
((eq? message 'get-register) lookup-register)
((eq? message 'install-operations)
(lambda (ops) (set! the-ops (append the-ops ops))))
((eq? message 'stack) stack)
((eq? message 'operations) the-ops)
((eq? message 'print-program-counter)
(print-program-counter))
((eq? message 'initialize-program-counter)
(initialize-program-counter))
((eq? message 'trace-on)
(set! trace-flg #t))
((eq? message 'trace-off)
(set! trace-flg #f))
((eq? message 'install-labels)
(lambda (controller-text)
(set! the-labels
(install-labels controller-text))))
((eq? message 'prepare-label-trace)
(prepare-label-trace!))
(else (error "Unknown request -- MACHINE" message))))
dispatch)))
at the time when the function "extract-labels" is called.
But too lazy to modify many basic functions and decide to add label information
when the machine is created and update/refer to the information in the function
"execute".
The approach to hand "GOTO (REG XXX)" is too dirty and hope to modify it
when have time.
比较好的解决方案应该是在EXTRACT-LABELS函数中给每个指令另外加上LABEL的信息。
但是对于懒得修改很多基本的函数。于是决定在make-machine中加上LABEL的信息，
之后在EXECUTE函数中参照并随时加以修改。
但是之前没有很好考虑处理GOTO (REG xxx)语句的情况，导致不得不根据指令反过来
判断LABEL。希望有时间再修改吧。
一番良い方法は多分、Extract-labels関数に各命令のラベル情報
も追加してあげて、Execute関数それらを出力する。
いくつかの基本関数を修正しなければならないので、気が遠くなったので、
代わりに、make-machineにラベル情報を追加し、Execute関数にそれらを
参照/更新するアプローチを取った。
但し、GOTO （REG xxx）のケースは考慮不足で、汚い処理になってしまった。
時間があるときに修正しようかな。
Execution image（実行イーメージ）
(set-register-contents! fm 'n 3)
;Value: done
(fm 'trace-on)
;Value: #f
(fm 'prepare-label-trace)
;Value: ()
(start fm)
(label: controller text: (assign continue (label fact-done)))
(label: controller text: (test (op =) (reg n) (const 1)))
(label: controller text: (branch (label base-case)))
(label: controller text: (save continue))
(label: controller text: (save n))
(label: controller text: (assign n (op -) (reg n) (const 1)))
(label: controller text: (assign continue (label after-fact)))
(label: controller text: (goto (label fact-loop)))
(label: fact-loop text: (test (op =) (reg n) (const 1)))
(label: fact-loop text: (branch (label base-case)))
(label: fact-loop text: (save continue))
(label: fact-loop text: (save n))
(label: fact-loop text: (assign n (op -) (reg n) (const 1)))
(label: fact-loop text: (assign continue (label after-fact)))
(label: fact-loop text: (goto (label fact-loop)))
(label: fact-loop text: (test (op =) (reg n) (const 1)))
(label: fact-loop text: (branch (label base-case)))
(label: base-case text: (assign val (const 1)))
(label: base-case text: (goto (reg continue)))
(label: after-fact text: (restore n))
(label: after-fact text: (restore continue))
(label: after-fact text: (assign val (op *) (reg n) (reg val)))
(label: after-fact text: (goto (reg continue)))
(label: after-fact text: (restore n))
(label: after-fact text: (restore continue))
(label: after-fact text: (assign val (op *) (reg n) (reg val)))
(label: after-fact text: (goto (reg continue)))
;Value: done
Simulator instructions used above（上記レジスタマシーンfmのコード）：
(define fm
(make-machine
'(n val continue)
(list (list '= =) (list '- -) (list '* *))
'(controller
(assign continue (label fact-done))
fact-loop
(test (op =) (reg n) (const 1))
(branch (label base-case))
(save continue)
(save n)
(assign n (op -) (reg n) (const 1))
(assign continue (label after-fact))
(goto (label fact-loop))
after-fact
(restore n)
(restore continue)
(assign val (op *) (reg n) (reg val))
(goto (reg continue))
base-case
(assign val (const 1))
(goto (reg continue))
fact-done)))
Functions modified and added in the implementation of the simulator machine
(define (make-machine register-names ops controller-text)
(let ((machine (make-new-machine)))
(for-each (lambda (register-name)
((machine 'allocate-register) register-name))
register-names)
((machine 'install-operations) ops)
((machine 'install-labels) controller-text)
((machine 'install-instruction-sequence)
(assemble controller-text machine))
machine))
(define (make-new-machine)
(let ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(the-instruction-sequence '())
(counter 0)
(trace-flg #f)
(the-labels '())
(current-label 'initial-label)
(current-label-counter 1)
(current-label-info '())) (let ((the-ops
(list (list 'initialize-stack
(lambda () (stack 'initialize)))
(list 'print-stack-statistics
(lambda () (stack 'print-statistics)))))
(register-table
(list (list 'pc pc) (list 'flag flag))))
(define (allocate-register name)
(if (assoc name register-table)
(error "Multiply defined register: " name)
(set! register-table
(cons (list name (make-register name))
register-table)))
'register-allocated)
(define (lookup-register name)
(let ((val (assoc name register-table)))
(if val
(cadr val)
(error "Unknown register:" name))))
(define (initialize-program-counter)
(set! counter 0))
(define (print-program-counter)
(newline)
(display (list 'program-counter= counter)))
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
(let ((text (instruction-text (car insts))))
(if (not (false? trace-flg))
(begin
(newline)
(display
(list 'label: (caar current-label-info) 'text: text))))
((instruction-execution-proc (car insts)))
(set! counter (+ counter 1))
(cond ((eq? (car text) 'goto)
(let ((goto-dest (cadr text)))
(if (eq? (car goto-dest) 'reg)
(set-label-info-cmds!
(map
(lambda (x) (car x))
(get-contents pc)))
(set-label-info! (cadr goto-dest)))))
((eq? (car text) 'branch)
(if (get-contents flag)
(set-label-info! (cadadr text))))
(else
(update-label-info! (+ current-label-counter 1))))
(execute)))))
(define (install-labels controller-text)
(define (iter seq symb counter seq-follow-symb)
(if (null? seq)
'()
(if (symbol? (car seq))
(cons (cons symb (cons counter seq-follow-symb))
(iter (cdr seq) (car seq) 0 (cdr seq)))
(iter (cdr seq) symb (+ counter 1) seq-follow-symb))))
(let ((insts (cdr controller-text)))
(iter insts (car controller-text) 0 insts)))
(define (prepare-label-trace!)
(set! current-label-info the-labels))
; (set! current-label (caar current-label-info)))
(define (update-label-info! counter)
(let ((label-counter (car current-label-info)))
(let ((counter-threshold (cadr label-counter)))
(if (= counter counter-threshold)
(begin
(set! current-label-info (cdr current-label-info))
(set! current-label-counter 1))
(set! current-label-counter counter)))))
(define (set-label-info! label)
(define (iter labels-info label-text)
(if (null? labels-info)
(set! current-label-info '())
(if (eq? (caar labels-info) label-text)
(set! current-label-info labels-info)
(iter (cdr labels-info) label-text))))
(iter the-labels label))
(define (set-label-info-cmds! seq)
(define (iter labels-info cmds)
(if (null? labels-info)
(set! current-label-info '())
(if (equal?
(filter
(lambda (x)
(not (symbol? x)))
(cddar labels-info))
cmds)
(set! current-label-info labels-info)
(iter (cdr labels-info) cmds))))
(iter the-labels seq))
(define (dispatch message)
(cond ((eq? message 'start)
(set-contents! pc the-instruction-sequence)
(execute))
((eq? message 'install-instruction-sequence)
(lambda (seq) (set! the-instruction-sequence seq)))
((eq? message 'allocate-register) allocate-register)
((eq? message 'get-register) lookup-register)
((eq? message 'install-operations)
(lambda (ops) (set! the-ops (append the-ops ops))))
((eq? message 'stack) stack)
((eq? message 'operations) the-ops)
((eq? message 'print-program-counter)
(print-program-counter))
((eq? message 'initialize-program-counter)
(initialize-program-counter))
((eq? message 'trace-on)
(set! trace-flg #t))
((eq? message 'trace-off)
(set! trace-flg #f))
((eq? message 'install-labels)
(lambda (controller-text)
(set! the-labels
(install-labels controller-text))))
((eq? message 'prepare-label-trace)
(prepare-label-trace!))
(else (error "Unknown request -- MACHINE" message))))
dispatch)))
Friday, June 10, 2011
Hanoi Tower puzzle in MIT Scheme（ハノイの塔）
Showed my children the Hanoi-tower which comes along with an excellent editor called Xyzzy.
But the movement is so fast that it did not make sense to them.
So I tried to write a version of the puzzle to show the move of every step clearly.
周末给孩子看Xyzzy自带的Hanoi-tower。但是由于速度比较快，根本看不清
每一步的细节，只能看到开始和结束的状态。于是还是决定自己动手写一个。
週末にXyzzyのハノイの塔を子供達に見せたが、スピードが早く、開始と終了の
状態しか見えなかった。自分で動きはっきり見えるバージョンを書こうと思った。
Result of the program（実行結果）
Source code:
(define (hanoi-iter n start destination intermediate)
(newline)
(let ((dat (list start destination intermediate)))
(map
(lambda (x)
(newline)
(display x))
(format-merged-columns
(list (cdr (assoc 'destination dat))
(cdr (assoc 'intermediate dat))
(cdr (assoc 'start dat)))
n (+ (* n 2) 1))))
(define (iter m s g t)
(cond ((= m 0)
(newline)
(let ((dat (list s g t)))
(map
(lambda (x)
(newline)
(display x))
(format-merged-columns
(list (cdr (assoc 'destination dat))
(cdr (assoc 'intermediate dat))
(cdr (assoc 'start dat)))
n (+ (* n 2) 1)))))
((= m 1)
(set! g (cons (car g) (cons (cadr s) (cdr g))))
(set! s (cons (car s) (cddr s)))
(iter (- m 1) s g t))
(else
(iter (- m 1) s t g)
(set! t (cons (car t)
(append (list-head (cdr s) (- m 1)) (cdr t))))
(set! s (cons (car s) (list-tail (cdr s) (- m 1))))
(iter 1 s g t)
(set! g (cons (car g)
(cons (cadr s) (cdr g))))
(set! s (cons (car s) (cddr s)))
(iter (- m 1) t g s))))
(iter n start destination intermediate))
(define (hanoi n)
(let loop ((m n) (start '()))
(if (= m 0)
(hanoi-iter n (cons 'start start) (cons 'destination '()) (cons 'intermediate '()))
(let ((k (- m 1)))
(loop k (cons k start))))))
(define (format-merged-columns columns height width)
(map
(lambda (merged-plates)
(reduce string-append ""
;(car
; (map
; (lambda (plate)
; (reduce string-append "" plate))
merged-plates))
(merge-columns columns height width)))
(define (merge-columns columns height width)
(if (null? columns)
(make-list height)
(map append
(adjust-column (car columns) height width)
(merge-columns (cdr columns) height width))))
(define (adjust-column column height width)
(let ((col-len (length column))
(half-pad-seq
(make-list (/ (- width 1) 2) " ")))
(let ((pad-elms
(make-list (- height col-len)
(append
half-pad-seq
(cons "|" half-pad-seq)))))
(append pad-elms
(let loop ((plates column))
(if (null? plates)
'()
(cons (adjust-plate (car plates) width)
(loop (cdr plates)))))))))
(define (adjust-plate plate-number format-length)
(let ((len (+ (* plate-number 2) 1)))
(let ((mid-part
(make-list len (number->string plate-number))))
(let ((remain-half-len
(/ (- format-length (length mid-part)) 2)))
(let ((remain-half
(make-list remain-half-len " ")))
(append remain-half
(append mid-part
remain-half)))))))
But the movement is so fast that it did not make sense to them.
So I tried to write a version of the puzzle to show the move of every step clearly.
周末给孩子看Xyzzy自带的Hanoi-tower。但是由于速度比较快，根本看不清
每一步的细节，只能看到开始和结束的状态。于是还是决定自己动手写一个。
週末にXyzzyのハノイの塔を子供達に見せたが、スピードが早く、開始と終了の
状態しか見えなかった。自分で動きはっきり見えるバージョンを書こうと思った。
Result of the program（実行結果）
Source code:
(define (hanoi-iter n start destination intermediate)
(newline)
(let ((dat (list start destination intermediate)))
(map
(lambda (x)
(newline)
(display x))
(format-merged-columns
(list (cdr (assoc 'destination dat))
(cdr (assoc 'intermediate dat))
(cdr (assoc 'start dat)))
n (+ (* n 2) 1))))
(define (iter m s g t)
(cond ((= m 0)
(newline)
(let ((dat (list s g t)))
(map
(lambda (x)
(newline)
(display x))
(format-merged-columns
(list (cdr (assoc 'destination dat))
(cdr (assoc 'intermediate dat))
(cdr (assoc 'start dat)))
n (+ (* n 2) 1)))))
((= m 1)
(set! g (cons (car g) (cons (cadr s) (cdr g))))
(set! s (cons (car s) (cddr s)))
(iter (- m 1) s g t))
(else
(iter (- m 1) s t g)
(set! t (cons (car t)
(append (list-head (cdr s) (- m 1)) (cdr t))))
(set! s (cons (car s) (list-tail (cdr s) (- m 1))))
(iter 1 s g t)
(set! g (cons (car g)
(cons (cadr s) (cdr g))))
(set! s (cons (car s) (cddr s)))
(iter (- m 1) t g s))))
(iter n start destination intermediate))
(define (hanoi n)
(let loop ((m n) (start '()))
(if (= m 0)
(hanoi-iter n (cons 'start start) (cons 'destination '()) (cons 'intermediate '()))
(let ((k (- m 1)))
(loop k (cons k start))))))
(define (format-merged-columns columns height width)
(map
(lambda (merged-plates)
(reduce string-append ""
;(car
; (map
; (lambda (plate)
; (reduce string-append "" plate))
merged-plates))
(merge-columns columns height width)))
(define (merge-columns columns height width)
(if (null? columns)
(make-list height)
(map append
(adjust-column (car columns) height width)
(merge-columns (cdr columns) height width))))
(define (adjust-column column height width)
(let ((col-len (length column))
(half-pad-seq
(make-list (/ (- width 1) 2) " ")))
(let ((pad-elms
(make-list (- height col-len)
(append
half-pad-seq
(cons "|" half-pad-seq)))))
(append pad-elms
(let loop ((plates column))
(if (null? plates)
'()
(cons (adjust-plate (car plates) width)
(loop (cdr plates)))))))))
(define (adjust-plate plate-number format-length)
(let ((len (+ (* plate-number 2) 1)))
(let ((mid-part
(make-list len (number->string plate-number))))
(let ((remain-half-len
(/ (- format-length (length mid-part)) 2)))
(let ((remain-half
(make-list remain-half-len " ")))
(append remain-half
(append mid-part
remain-half)))))))
Sunday, May 29, 2011
Solution of SICP Exercise 5.15
Think it is good to provide two types of access to the information.
One is to add some trace operations directly in the machine instructions, e.g.
(perform (op print-program-counter), which has the merit that
we can get the information even if the machine never stops.
(which means we have no chance to get the information form outside the machine)
Another is provide an interface in the underlying machine model itself, e.g.
(factorial-machine 'print-program-counter).
This is useful when we want a compact set of instructions without trace commands in it
and we are sure have chance to access the machine from outside.
觉得应该像5.14那样提供两种界面，一种是直接将追踪信息写在指令中。比如，
(perform (op print-program-counter)
好处是即使程序不停也依然可以看到想要的信息
另外一种是通过底层的机器模型提供所需信息。比如，
(factorial-machine 'print-program-counter)
好处是可以将指令简介化，不在处理中加入和处理无关的追踪信息的输出。
２種類のインターフェースを提供したほうが良いと思う。
一つは、コマンドの中に直接トレース情報出力のコマンド追加。
例えば、 (perform (op print-program-counter)
これによって、停止しない処理でも必要な情報取れる。
もう一つは、下層のマシーンモデルにトレース情報取得のインターフェース追加。
例えば、(factorial-machine 'print-program-counter)
これによって、処理に余計なトレース情報出力コマンド入れず、処理に専念するプログラムができる。
(define (make-new-machine)
(let ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(the-instruction-sequence '())
(counter 0))
(define (initialize-program-counter)
(set! counter 0))
(define (print-program-counter)
(newline)
(display (list 'program-counter= counter)))
(let ((the-ops
(list (list 'initialize-stack
(lambda () (stack 'initialize)))
(list 'print-stack-statistics
(lambda () (stack 'print-statistics)))
(list 'initialize-program-counter
(lambda ()
(initialize-program-counter)))
(list 'print-program-counter
(lambda ()
(print-program-counter))))) (register-table
(list (list 'pc pc) (list 'flag flag))))
(define (allocate-register name)
(if (assoc name register-table)
(error "Multiply defined register: " name)
(set! register-table
(cons (list name (make-register name))
register-table)))
'register-allocated)
(define (lookup-register name)
(let ((val (assoc name register-table)))
(if val
(cadr val)
(error "Unknown register:" name))))
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
(begin
((instruction-execution-proc (car insts)))
(set! counter (+ counter 1))
(execute)))))
(define (dispatch message)
(cond ((eq? message 'start)
(set-contents! pc the-instruction-sequence)
(execute))
((eq? message 'install-instruction-sequence)
(lambda (seq) (set! the-instruction-sequence seq)))
((eq? message 'allocate-register) allocate-register)
((eq? message 'get-register) lookup-register)
((eq? message 'install-operations)
(lambda (ops) (set! the-ops (append the-ops ops))))
((eq? message 'stack) stack)
((eq? message 'operations) the-ops)
((eq? message 'print-program-counter)
(print-program-counter))
((eq? message 'initialize-program-counter)
(initialize-program-counter)) (else (error "Unknown request -- MACHINE" message))))
dispatch)))
One is to add some trace operations directly in the machine instructions, e.g.
(perform (op print-program-counter), which has the merit that
we can get the information even if the machine never stops.
(which means we have no chance to get the information form outside the machine)
Another is provide an interface in the underlying machine model itself, e.g.
(factorial-machine 'print-program-counter).
This is useful when we want a compact set of instructions without trace commands in it
and we are sure have chance to access the machine from outside.
觉得应该像5.14那样提供两种界面，一种是直接将追踪信息写在指令中。比如，
(perform (op print-program-counter)
好处是即使程序不停也依然可以看到想要的信息
另外一种是通过底层的机器模型提供所需信息。比如，
(factorial-machine 'print-program-counter)
好处是可以将指令简介化，不在处理中加入和处理无关的追踪信息的输出。
２種類のインターフェースを提供したほうが良いと思う。
一つは、コマンドの中に直接トレース情報出力のコマンド追加。
例えば、 (perform (op print-program-counter)
これによって、停止しない処理でも必要な情報取れる。
もう一つは、下層のマシーンモデルにトレース情報取得のインターフェース追加。
例えば、(factorial-machine 'print-program-counter)
これによって、処理に余計なトレース情報出力コマンド入れず、処理に専念するプログラムができる。
(define (make-new-machine)
(let ((pc (make-register 'pc))
(flag (make-register 'flag))
(stack (make-stack))
(the-instruction-sequence '())
(counter 0))
(define (initialize-program-counter)
(set! counter 0))
(define (print-program-counter)
(newline)
(display (list 'program-counter= counter)))
(let ((the-ops
(list (list 'initialize-stack
(lambda () (stack 'initialize)))
(list 'print-stack-statistics
(lambda () (stack 'print-statistics)))
(list 'initialize-program-counter
(lambda ()
(initialize-program-counter)))
(list 'print-program-counter
(lambda ()
(print-program-counter))))) (register-table
(list (list 'pc pc) (list 'flag flag))))
(define (allocate-register name)
(if (assoc name register-table)
(error "Multiply defined register: " name)
(set! register-table
(cons (list name (make-register name))
register-table)))
'register-allocated)
(define (lookup-register name)
(let ((val (assoc name register-table)))
(if val
(cadr val)
(error "Unknown register:" name))))
(define (execute)
(let ((insts (get-contents pc)))
(if (null? insts)
'done
(begin
((instruction-execution-proc (car insts)))
(set! counter (+ counter 1))
(execute)))))
(define (dispatch message)
(cond ((eq? message 'start)
(set-contents! pc the-instruction-sequence)
(execute))
((eq? message 'install-instruction-sequence)
(lambda (seq) (set! the-instruction-sequence seq)))
((eq? message 'allocate-register) allocate-register)
((eq? message 'get-register) lookup-register)
((eq? message 'install-operations)
(lambda (ops) (set! the-ops (append the-ops ops))))
((eq? message 'stack) stack)
((eq? message 'operations) the-ops)
((eq? message 'print-program-counter)
(print-program-counter))
((eq? message 'initialize-program-counter)
(initialize-program-counter)) (else (error "Unknown request -- MACHINE" message))))
dispatch)))
Saturday, May 28, 2011
Solution of SICP Exercise 5.14
Below is the solution of Exercise 5.14.
Found some solutions on the web try to get
the trace information using something like
((factorial-machine 'stack) print-statistics)
instead of modifying instructions set of the factorial machine,
which is not the intent of this exercise.
下面是练习5.14的解决方案。
我注意到有些网上的方案直接访问STACK的print-statistics函数。
((factorial-machine 'stack) print-statistics)
显然这不是本练习的目的。
練習問題5.14の回答は下記の通りになります。
直接スタックのprint-statistics関数を使用し、
情報を取得することも可能ですが、本練習の目的ではないと思います。
(define fm
(make-machine
'(n val continue)
(list (list '= =) (list '- -) (list '* *) (list 'read read) (list 'output write))
'(controller
(assign n (op read))
(perform (op initialize-stack))
(assign continue (label fact-done))
fact-loop
(test (op =) (reg n) (const 1))
(branch (label base-case))
(save continue)
(save n)
(assign n (op -) (reg n) (const 1))
(assign continue (label after-fact))
(goto (label fact-loop))
after-fact
(restore n)
(restore continue)
(assign val (op *) (reg n) (reg val))
(goto (reg continue))
base-case
(assign val (const 1))
(goto (reg continue))
fact-done
(perform (op output) (reg val))
(perform (op print-stack-statistics))
(goto (label controller)))))
Found some solutions on the web try to get
the trace information using something like
((factorial-machine 'stack) print-statistics)
instead of modifying instructions set of the factorial machine,
which is not the intent of this exercise.
下面是练习5.14的解决方案。
我注意到有些网上的方案直接访问STACK的print-statistics函数。
((factorial-machine 'stack) print-statistics)
显然这不是本练习的目的。
練習問題5.14の回答は下記の通りになります。
直接スタックのprint-statistics関数を使用し、
情報を取得することも可能ですが、本練習の目的ではないと思います。
(define fm
(make-machine
'(n val continue)
(list (list '= =) (list '- -) (list '* *) (list 'read read) (list 'output write))
'(controller
(assign n (op read))
(perform (op initialize-stack))
(assign continue (label fact-done))
fact-loop
(test (op =) (reg n) (const 1))
(branch (label base-case))
(save continue)
(save n)
(assign n (op -) (reg n) (const 1))
(assign continue (label after-fact))
(goto (label fact-loop))
after-fact
(restore n)
(restore continue)
(assign val (op *) (reg n) (reg val))
(goto (reg continue))
base-case
(assign val (const 1))
(goto (reg continue))
fact-done
(perform (op output) (reg val))
(perform (op print-stack-statistics))
(goto (label controller)))))
Subscribe to:
Posts (Atom)