(sicp51)put-getの修正と問題4.11〜4.12

sicp

以下のことに気づいたので修正

  • put/getの引数の順序はop, typeの順だった（前のはtype, op)
    • install-evalの部分を少し変える必要がありそう。*1
    • あと、evalのgetの部分も
    • あー、変えなくていいのか。(get 'eval 'if)とかはif形式のオブジェクトに対するevalと考えればいい。
  • hash-table-getはテーブルに値が存在しない場合の戻り値を引数で指定できる。
    • condの=>を使って結構綺麗に書ける気がした

put/get

(define-module sicp.put-get  (export put get))
(select-module sicp.put-get)

(define *parent-table* (make-hash-table 'equal?))

(define (put op type item)
  (cond ((hash-table-get *parent-table* op #f)
         => (cut hash-table-put! <> type item))
        (else
         (hash-table-put! *parent-table* op (make-hash-table 'equal?))
         (put op type item))))

(define (get op type)
  (cond ((hash-table-get *parent-table* op #f)
         => (cut hash-table-get <> type #f))
        (else #f)))

(provide "sicp/put-get")

問題4.12

以下の定義を共通部分を抜き出して抽象化するという問題。

(define (lookup-variable-value var env)
  (define (env-loop env)
    (define (scan vars vals)
      (cond ((null? vars)
             (env-loop (enclosing-environment env)))
            ((eq? var (car vars))
             (car vals))
            (else (scan (cdr vars) (cdr vals)))))
    (if (eq? env the-empty-environment)
        (error "Unbound variable" var)
        (let ((frame (first-frame env)))
          (scan (frame-variables frame)
                (frame-values frame)))))
  (env-loop env))

(define (set-variable-value! var val env)
  (define (env-loop env)
    (define (scan vars vals)
      (cond ((null? vars)
             (env-loop (enclosing-environment env)))
            ((eq? var (car vars))
             (set-car! vals val))
            (else (scan (cdr vars) (cdr vals)))))
    (if (eq? env the-empty-environment)
        (error "Unbound variable -- SET!" var)
        (let ((frame (first-frame env)))
          (scan (frame-variables frame)
                (frame-values frame)))))
  (env-loop env))

(define (define-variable! var val env)
  (let ((frame (first-frame env)))
    (define (scan vars vals)
      (cond ((null? vars)
             (add-binding-to-frame! var val frame))
            ((eq? var (car vars))
             (set-car! vals val))
            (else (scan (cdr vars) (cdr vals)))))
    (scan (frame-variables frame)
          (frame-values frame))))

回答(やりすぎた）

(define (env-scan-maker var fail found)
  (define (scan vars vals)
    (cond ((null? vars) (fail))
          ((eq? var (car vars)) (found vals))
          (else
           (scan (cdr vars) (cdr vals)))))
  scan)

(define (env-loop-maker found-f error-f)
  (lambda (var env)
    (let env-loop ((env env))
      (define scan (env-scan-maker var
                                   (cute env-loop (enclosing-environment env))
                                   found-f))
        (env-pretravarse-check scan env error-f))))

(define (travarse-dispatcher fn env)
  (let ((frame (first-frame env)))
    (fn (frame-variables frame)
        (frame-values frame))))

(define (env-pretravarse-check scan-f env error-f)
  (if (eq? env the-empty-environment)
      (error-f)
      (travarse-dispatcher scan-f env)))

(define (lookup-variable-value var env)
  ((env-loop-maker (lambda (vals) (car vals))
                  (cut error "Unbound variable" var))
   var env))

(define (set-variable-value! var val env)
  ((env-loop-maker (lambda (vals) (set-car! vals val))
                   (cut error "Unbound variable -- SET!" var))
   var env))

(define (define-variable! var val env)
  (let1 frame (first-frame env)
    (define scan (env-scan-maker var
                  (cut add-binding-to-frame! var val frame)
                  (lambda  (vals) (set-car! vals val))))
    (scan (frame-variables frame) (frame-values frame))))

4.11と4.12の複合

(var . value)というpairで格納するとassocが使えるので少し楽に書ける。
ただ、add-binding-frameが少しかきづらかった気がした。

(define the-empty-environment '('env ))

(define (make-frame variables values)
  (map cons variables values))
(define (frame-variables frame) (map car frame))
(define (frame-values frame) (map cdr frame))

(define (add-binding-to-frame! var val frame)
  (let1 new (cons var val)
    (set-cdr! frame (cons new (cdr frame)))))

(define (env-scan-maker var fail found)
  (define (scan frame)
    (cond ((asoc var frame) => (cut found <>))
          (else (fail))))
  scan)

(define (env-loop-maker found error-f)
  (lambda (var env)
    (let env-loop ((env env))
      (define scan (env-scan-maker var
                                   (cute env-loop (enclosing-environment env)) 
                                   found))
      (if (eq? env the-empty-environment)
          (error-f)
          (scan (first-frame env))))))


(define (lookup-variable-value var env)
  ((env-loop-maker  (lambda (pair) (cdr pair))
                    (cut error "Unbound variable" var))
   var env))

(define (set-variable-value! var value env)
  ((env-loop-maker  (lambda (pair) (set-cdr! pair value))
                    (cut error "Unbound variable -- SET!" var))
   var env))

(define (define-variable! var value env)
  (define scan
    (env-scan-maker var
                    (cut add-binding-to-frame! var val frame)
                    (lambda (pair) (set-cdr! pair value))))
    (scan (first-frame env)))

*1:define-action!を元に定義していたので変える場所は一ヶ所で済む!!