(sicp49)m4.8,m4.9

合っているか自信無いです＞＜

4.8named-letを作る

(define (named-let->definition exp)
  ;(letを外した式をもらう。
  (let ((name (car exp))
        (arguments (cadr exp))
        (body (caddr exp)))
    (let ((vars (map car arguments))
          (exps (map cadr arguments)))
      (sequence->exp (list (list 'define (cons name vars)
                                 body)
                           (cons name exps))))))
              
;;named-let
	;前回のlet->lambdaは上手く動いて無かったみたい。
(define (let->lambda exp)
  (if (symbol? (cadr exp)) ;letの次の値がsymbolならnamed-let
      (named-let->definition (cdr exp))
      (let ((arguments (cadr exp))
            (body (cddr exp)))
        (let ((vars (map car arguments))
              (exps (map cadr arguments)))
          (cons (make-lambda vars body) exps)))))

(let->lambda '(let ((a 2) (b 1))
                (+ a b)))
;((lambda (a b) (+ a b)) 2 1)

(let->lambda '(let fib-iter ((a 0) (b 1) (c 10))
                (if (zero? c)
                    a
                    (fib-iter b (+ a b) (- c 1)))))
#|(begin 
  (define (fib-iter a b c)
    (if (zero? c)
        a
        (fib-iter b (+ a b) (- c 1))))
  (fib-iter 0 1 10))
|#

4.9 do, while, untilを作成する。

while,until,doの順序で考えた。

;;例えばこのような感じに使う。
(let ((sum 0) (n 10))
  (while (> n 0)
    (set! sum (+ sum n))
    (set! n (- n 1)))
  sum)

;;上手く動くには、whileが終了したらsumだけになってほしい。
	;;whileの終了時にwhile以降の式(ここではsum)を呼べばいい。
;; (define (f anything rest)
;;   (if <終了条件>
;;       rest
;;       <継続の処理>))という感じになる必要がある。。
(define (eval-while exp env)
  (let ((first (car exp))
        (rest (cdr exp)))
    (define (run-while exp)
      (let ((pred (cadr exp))
            (body (caddr exp)))
        (make-if pred
                 (make-begin (list body (list run-while exp)))
                 rest)))
    (eval (run-while first) env)))

;until
(define (eval-until exp env)
  (let ((first (car exp))
        (rest (cdr exp)))
    (define (run-until exp)
      (let ((pred (cadr exp))
            (body (caddr exp)))
        (make-if pred
                 rest
                 (make-begin (list body (list run-until exp)))))
    (eval (run-until first) env)))

;;do
;;知らないので調べる。
;; http://www.shido.info/lisp/scheme7.html
;; (do binds (predicate value) body) の形
;; ;;例
;; (define (fact-do n)
;;   (do ((n1 n (- n1 1)) (p n (* p (- n1 1)))) ((= n1 1) p)))
;; 	;binds n1<-n (loopする度に n1<- n1-1)
;; 	       p<-n  (loopする度に p<- p * (n1-1)
;; 	;predicate n1 = 1
;; 	;value(return value) p

;;こんな感じで使う？
(define (total l)
  (do ((n 0 (+ n (car l))) (l l (cdr l))) ((null? l) n)))

(define (make-let exp) (cons 'let exp)

;;こんな感じでいいのかな？  
(define (run-do exp)
  (let ((binding (cadr exp))
        (predicate&value (caddr exp)))
    (let ((vars&exps (map (lambda (e) (list (car e) (cadr e))) binding))
          (set-f (map caddr binding)))
      (make-let (list 'loop vars&exps
                      (make-if (car predicate&value)
                               (cadr predicate&value)
                               (cons 'loop set-f)))))))

(run-do '(do ((n 0 (+ n (car l))) (l l (cdr l))) ((null? l) n)))
;;gosh> (let loop ((n 0) (l l)) (if (null? l) n (loop (+ n (car l)) (cdr l))))

(define (eval-do exp env)
  (eval (run-do exp) env))

追記

whileとかuntilの中の関数の引数はいらないかも

; while
(define (eval-while exp env)
  (let ((first (car exp))
        (rest (cdr exp)))
    (let ((pred (cadr first))
          (body (cddr first)))
    (define (run-while)
        (make-if pred
                 (make-begin (list body (list run-while)))
                 rest))
    ;(run-while))))
    (eval-sequence (run-while) env))))

;;eval-sequenceの方ではなく、commentされているrun-whileの方の時の出力
(print (eval-while'((while (> n 10)
               (set! sum (+ sum n))
               (set! n (+ n 1)))
                 sum)
           'env))
;;(if (> n 10) (begin ((set! sum (+ sum n)) (set! n (+ n 1))) (#<closure (eval-while run-while)>)) (sum))
;;最終的 (sum)が取り出されて、これをeval-sequenceに渡すとlast-sexp?がtrueになって、sumが出力されて終了。

;until
(define (eval-until exp env)
  (let ((first (car exp))
        (rest (cdr exp)))
    (let ((pred (cadr first))
          (body (caddr first)))
    (define (run-until)
        (make-if pred
                 rest
                 (make-begin (list body (list run-until)))))
    (eval-sequence (run-until) env)))