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)))

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)))))))