(sicp48)m4.3~m4.7

今日やった分。

4.3

データ主導の形に変更。gets/putsはてきとうに(putsはわざわざ作らなくてもいいかも）

#|
;;getの中身を作るためのelisp
(defun make-func-mem (beg end) (interactive "r")
  (let ((mem '()))
    (save-excursion
     (goto-char end)
     (while (and (> (point) beg)
                 (search-backward-regexp "\(define \(\\\(.+?\\\)[ \)].*\)" nil t))
       (push (match-string-no-properties 1) mem)))
    (let ((context 
	   (apply #'concat(mapcar (lambda (word)
                                    (concat "(" word " . ,|" word "|) "))
                                  mem))))
      
      (insert (concat "`(" context ")\n")))))
|#


(define (test exp env)
  (print "exp: " exp)
  (print "env: " env))

;;面倒なので、つくってある関数にわたそう
(define (@set! exp env) (eval-assignment exp env))
(define (@define exp env) (eval-definition exp env))
(define (@if exp env) (eval-if exp env))
(define (@lambda exp env)
  (make-procedure (lambda-parameters exp)
                  (lambda-body exp)
                  env))
(define (@begin exp env)
  (eval-sequence (begin-actions exp) env))
(define (@quote exp env) (text-of-quotation exp))
(define (@cond exp env)
  (@eval (cond->if exp) env))

;;((cdr `(test . ,test)) "exp" "env")
;;quasi-quoteを使えばいい
(define get
  (let ((procedures `((test . ,|test|) (@set! . ,|@set!|) (@define . ,|@define|) (@if . ,|@if|) (@lambda . ,|@lambda|) (@begin . ,|@begin|) (@quote . ,|@quote|) (@cond . ,|@cond|) )))
    (lambda (tag)
       (cond ((assoc tag procedures) => cdr)
             (else #f)))))

(define (@eval exp env)
  (cond ((self-evaluating? exp) exp)
        ((variable? exp) (lookup-variable-value exp env))
        ((get (car exp)) => (lambda (f) (f (cdr exp) env)))
        ((application? exp)
         (@apply (@eval (operator exp) env)
                 (list-of-values (operands exp) env)))
        (else
         (error "Unknown expression type -- EVAL" exp))))

4.4

特にむずかしいところは存在しない（途中で処理を終らせたいから、foldとかが使えないくらい）

;;and/or
(define (@and exp env)
  (let loop ((state #f) (seq exp))
    (if (null? seq)
        state
        (let ((first (car seq))
              (rest (cdr seq)))
          (if first
              (loop first rest) ;firstは#f以外の値(#tとはかぎらない)
              #f)))))

;(@and '(#t #t a) 'test)
;; gosh> #?=seq
;; #?-    (#t #t a)
;; #?=seq
;; #?-    (#t a)
;; #?=seq
;; #?-    (a)
;; #?=seq
;; #?-    ()
;; a

(define (@or exp env)
  (let loop ((seq exp))
    (if (null? seq)
        #f
        (let ((first (car seq))
              (rest (cdr seq)))
          (if first
              first
              (loop rest))))))

;; (@or '(#f 2 #f #f) 'test)
;; gosh> #?=seq
;; #?-    (#f 2 #f #f)
;; #?=seq
;; #?-    (2 #f #f)
;; 2

あとは、@evalの中に加えるだけ

(define get
  (let ((procedures `((test . ,|test|) (@set! . ,|@set!|) (@define . ,|@define|) (@if . ,|@if|) (@lambda . ,|@lambda|) (@begin . ,|@begin|) (@quote . ,|@quote|) (@cond . ,|@cond|) (@and . ,|@and|) (@or . ,|@or|) )))
    (lambda (tag)
       (cond ((assoc tag procedures) => cdr)
             (else #f)))))

ifにてんかいしても良かったかもしれない。

4.5

expand-clausesを書き変えれば良さそう。

(define (expand-clauses clauses)
  (if (null? clauses)
      #f
      (let ((first (car clauses))
            (rest (cdr clauses)))
        (if (cond-else-clause? first)
            (if (null? rest)
                (sequence->exp (cond-actions first))
                (error "ELSE clause isn't last -- COND->IF"
                       clauses))
            (let ((firsts-actions (cond-actions first)))
              (if (eq? '=> (car firsts-actions))
                  (let ((predicate-value (cond-predicate first))
                        (recipient (cadr firsts-actions)))
                        (make-if predicate-value
                                 (list recipient predicate-value)
                                 (expand-clauses rest)))
                  (make-if (cond-predicate first)
                           (sequence->exp firsts-actions)
                           (expand-clauses rest))))))))

;; (expand-clauses (cond-clauses
;;                  '(@cond ((= n 3) 2)
;;                          ((= n 1) => square)
;;                          (else 0))))
;; gosh> (if (= n 3) 2 (if #0=(= n 1) (square #0#) 0))

4.6

letをlambda式に変更

;lambda <- let
;; '((lambda vars body) exps) <- (let var&exps body)

(define (@let exp env)
  (@apply (let->lambda exp) env))

(define (let->lambda exp)
  (let ((arguments (cadr exp))
        (body (caddr exp)))
    (let ((vars (map car arguments))
         ;; (exps (map (lambda (x) (eval (cadr x) 'interaction-environment)) arguments)))
          (exps (map (lambda (x) (@eval (cadr x) 'local)) arguments)))
      (list (make-lambda vars body) exps))))

;; (map (lambda (x) (eval (cadr x) 'interaction-environment)) '((a (+ 1 2)) (b (* 2 2))))

;; (let->lambda 
;;  '(let ((a (+ 1 2))
;;         (b (* 3 3)))
;;     (+ a b)))
;; gosh> ((lambda (a b) + a b) (3 9))

evalで計算しちゃったらよくないかも

(define (let->lambda exp)
  (let ((arguments (cadr exp))
        (body (caddr exp)))
    (let ((vars (map car arguments))
          (exps (map cadr arguments)))
      (list (make-lambda vars body) exps))))

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

(define get
  (let ((procedures `((test . ,|test|) (@set! . ,|@set!|) (@define . ,|@define|) (@if . ,|@if|) (@lambda . ,|@lambda|) (@begin . ,|@begin|) (@quote . ,|@quote|) (@cond . ,|@cond|) (@and . ,|@and|) (@or . ,|@or|) (@let . ,|@let|))))
        (lambda (tag)
          (cond ((assoc tag procedures) => cdr)
                (else #f)))))

getって名前だとほかの関数とぶつかりそう。
getのlocal-variableに格納しないで、globalにおいても良いかもしれない
あー,あと、速さを気にするならfor-eachとpush!を使ったほうがいいかも（ループの数をへらせる）
;;こんな感じで

(define (let->lambda exp)
  (let ((arguments (reverse (cadr exp)))  ;;向きをさかさまにしておく
        (body (caddr exp))
        (vars '())
        (exps '()))
    (for-each (lambda (x) (push! vars (car x))
                 (push! exps (cadr x)))
              arguments)
    (list (make-lambda vars body) exps)))

4.7

let*->letによる表現に変更。foldでできそう。

(define (let*->nested-lets exp)
  (let ((vals (cadr exp))
        (body (caddr exp)))
    (fold (lambda (x it)
            (cons 'let (list (list x) it)))
          body
          (reverse vals))))

(let*->nested-lets 
 '(let* ((x 3)
         (y (+ x 2))
         (z (* x y)))
    (+ x y z)))
;; gosh> (let ((x 3)) (let ((y (+ x 2))) (let ((z (* x y))) (+ x y z))))