sicp-ex-4.12

not a very good example on generalization but most likely what the author intended

  
  
  
 (define (tranverse var env on-find on-frame-end on-env-end) 
     (define (env-loop env) 
         (define (scan vars vals) 
             (cond ((null? vars) (on-frame-end env)) 
                   ((eq? var) (on-find vals)) 
                   (else (scan (cdr vars) (cdr vals))))) 
         (if (eq? env the-empty-environment) 
             (on-env-end) 
             (let ((frame (first-frame))) 
                 (scan (frame-variables frame) 
                       (frame-values frame))))) 
     (env-loop env)) 
  
 (define (lookup-variable-value var env) 
     (tranverse var 
                env 
                (lambda (vals) (car vals)) 
                (lambda (env) (lookup-variables-value var (enclosing-environment env))) 
                (lambda () (error "Unbound variable -- lookup-variable-value " var)))) 
  
 (define (set-variable-value! var val env) 
    (tranverse var 
               env 
               (lambda (vals) (set-car! vals val)) 
               (lambda (env) (set-variables-value! var val (enclosing-environment env))) 
               (lambda () (error "Unbound variable -- set-variable-value!" var)))) 
  
 (define (define-variable! var val env) 
     (tranverse var 
                env 
                (lambda (vals) (set-car! vals val)) 
                (lambda (env) (add-binding-to-frame! var val (first-frame env))) 
                (lambda () (error "Empty environment -- define-variable!"))))

meteorgan

  
  
  
 ;; this solution is based on exercise 4.11, that's to say i used different frame. 
 (define (extend-environment vars vals base-env) 
         (if (= (length vars) (length vals)) 
                 (cons (make-frame vars vals) base-env) 
                 (if (< (length vars) (length vals)) 
                         (error "Too few arguments supplied" vars vals) 
                         (error "Too many arguments supplied" vars vals)))) 
  
 ;; look up a variable in a frame 
 (define (lookup-binding-in-frame var frame) 
         (cond ((null? frame) (cons false '())) 
                   ((eq? (car (car frame)) var) 
                    (cons true (cdr (car frame)))) 
                   (else (lookup-binding-in-frame var (cdr frame))))) 
  
 ;; in frame, set var to val 
 (define (set-binding-in-frame var val frame) 
         (cond ((null? frame) false) 
                   ((eq? (car (car frame)) var) 
                    (set-cdr! (car frame) val) 
                    true) 
                   (else (set-binding-in-frame var val (cdr frame))))) 
  
 (define (lookup-variable-value var env) 
         (if (eq? env the-empty-environment) 
                 (error "Unbound variable" var)) 
                 (let ((result (lookup-binding-in-frame var (first-frame env)))) 
                         (if (car result) 
                                 (cdr result) 
                                 (lookup-variable-value var (enclosing-environment env))))) 
  
 (define (set-variable-value! var val env) 
         (if (eq? env the-empty-environment) 
                 (error "Unbound variable -- SET" var) 
                 (if (set-binding-in-frame var val (first-frame env)) 
                         true 
                         (set-variable-value! var val (enclosing-environment  env))))) 
  
 (define (define-variable! var val env) 
         (let ((frame (first-frame env))) 
                 (if (set-binding-in-frame var val frame) 
                         true 
                         (set-car! env (cons (cons var val) frame)))))

SophiaG

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

mazj

something need be change in SophiaG's answer, the "next" and "match" need be a lambda but not a exp.

  
 (define (env-loop env next match) 
     (define (scan vars vals) 
         (cond ((null? vars) (next env)) 
               ((eq? var (car vars)) (match 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))))) 
 (define (lookup-variable-value var env) 
     (env-loop env 
               (lambda (env) (env-loop (enclosing-environment env))) 
               car)) 
 (define (set-variable-value! var val env) 
     (env-loop env 
               (lambda (env) (env-loop (enclosing-environment env))) 
               (lambda (vals) (set-car! vals val)))) 
 (define (define-variable! var val env) 
     (let ((frame (first-frame env))) 
         (env-loop env 
                   (lambda (env) (add-binding-to-frame!  
                                     var val (first-frame env))) 
                   (lambda (vals) (set-car! vals val)))))

Ada

  
 ;; general procedure 
 (define (env-loop match-proc end-frame end-env env) 
   (define (scan vars vals current-frame current-env) 
     (cond ((null? vars) 
            (end-frame current-frame current-env)) 
           ((eq? var (car vars)) 
            (match-proc vars vals current-frame current-env)) 
           (else 
            (scan (cdr vars) (cdr vals) current-frame current-env)))) 
   (if (eq? env the-empty-environment) 
       (end-env) 
       (let ((frame (first-frame env))) 
         (scan (frame-variables frame) 
               (frame-values frame) 
               frame env)))) 
  
 ;; lookup-variable-value 
 (define (lookup-variable-value var env) 
   (define (match-proc vars vals cur-frame cur-env) (car vals)) 
   (define (end-env) (error "Unbound variable" var)) 
   (define (end-frame cur-frame cur-env)                       ;; !!! 
     (env-loop match-proc end-frame end-env (enclosing-environment cur-env))) 
    (env-loop match-proc end-frame end-env env)) 
  
 ;; set-variable-value! 
 (define (set-variable-value! var val env) 
   (define (match-proc vars vals cur-frame cur-env) (set-car! vals val)) 
   (define (end-env) (error "Unbound variable" var)) 
   (define (end-frame cur-frame cur-env)                       ;; !!! 
     (env-loop match-proc end-frame end-env (enclosing-environment cur-env))) 
   (env-loop match-proc end-frame end-env env)) 
  
 ;; define-variable! 
 (define (define-variable! var val env) 
   (define (match-proc vars vals cur-frame cur-env) (set-car! vals val)) 
   (define (end-env) (error "Unbound variable" var)) 
   (define (end-frame cur-frame cur-env)                       ;; !!! 
     (add-binding-to-frame! var val cur-frame)) 
   (env-loop match-proc end-frame end-env env))

CrazyAlvaro

I don't think SophiaG's solution is correct, since you can't just pass 'text' to be evaluated later

  
 (define (scan-frame var frame no-vars-callback found-callback) 
   (define (scan variables values) 
     (cond ((null? variables) 
            (no-vars-callback)) 
           ((eq? var (car variables)) 
            (found-callback variables values)) 
           (else (scan (cdr variables) (cdr values))))) 
   (scan (frame-variables frame) (frame-values frame))) 
  
 (define (search-env var env success-callback) 
   (define no-found-callback 
     ; search the next environment 
     (search-env var (enclosing-environment env) success-callback)) 
   (if (eq? env the-empty-environment) 
       (error "Unbound variable" var) 
       (scan-frame var (first-frame env) no-found-callback success-callback))) 
  
 (define (lookup-variable-value var env) 
   (search-env var env (lambda (vars vals) (car vals)))) 
  
 (define (set-variable-value! var val env) 
   (search-env var env (lambda (vars vals) (set-car! vals val)))) 
  
 (define (define-variable! var val env) 
   (scan-frame 
     var 
     (first-frame env) 
     (lambda () (add-binding-to-frame! var val frame) 
     (lambda (vars vals) (set-car! vals val)))))

poly

. . .

  
  
 (define (env-loop var-not-in-frame proc env var) 
   (define (scan frame) 
     (define (iter vars vals) 
       (cond ((null? vars) (var-not-in-frame)) 
             ((eq? var (car vars)) (proc vals)) 
             (else 
              (iter (cdr vars) (cdr vals))))) 
     (iter (frame-variables frame) (frame-values frame))) 
    
   (if (eq? env the-empty-environment) 
       (error "Unbound variable" var) 
       (let ((frame (first-frame env))) 
         (or (scan frame) ; the iteration won't be actived if the value of 
                          ; (scan frame) isn't false, which means the action 
                          ; here is depended on value of (var-not-in-frame) 
             (env-loop var-not-in-frame proc (enclosing-environment env) var))))) 
  
 (define (lookup-variable-value var env) 
   (define (var-not-in-frame) false) 
   (env-loop var-not-in-frame car env var)) 
  
 (define (set-variable-value! var val env) 
   (define (var-not-in-frame) false) 
   (env-loop var-not-in-frame (lambda (x) (set-car! x val)) env var)) 
  
 (define (define-variable! var val env) 
   (define (var-not-in-frame) 
     (add-binding-to-frame! var val (first-frame env))) 
   (env-loop var-not-in-frame (lambda (x) (set-car! x val)) env var))

I just found out there is bug: if var is bound to "false" then the scan will return false and env-loop will keep on iteration until it hits an error.

new one:

 (define (env-loop env var var-not-in-frame proc) 
   (define (scan vars vals) 
     (cond ((null? vars) (var-not-in-frame env)) 
           ((eq? var (car vars)) (proc 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))))) 
  
 (define (lookup-variable-value var env) 
   (define (var-not-in-frame env) 
     (lookup-variable-value var (enclosing-environment env))) 
   (env-loop env var var-not-in-frame car)) 
  
 (define (set-val! val) 
   (lambda (vals) (set-car! vals val))) 
  
 (define (set-variable-value! var val env) 
   (define (var-not-in-frame env) 
     (set-variable-value! var val (enclosing-environment env))) 
   (env-loop env var var-not-in-frame (set-val! val))) 
  
 (define (define-variable! var val env) 
   (define (var-not-in-frame env) 
     (add-binding-to-frame! var val (first-frame env))) 
   (env-loop env var var-not-in-frame (set-val! val)))

aos

I think the easiest way to solve this is to just pass a message as to which method called env-loop. For example:

 (define (env-loop var val env action) 
   (define (scan vars vals) 
     (cond ((and (eq? env the-empty-environment) 
                 (or (eq? action 'lookup-var) 
                     (eq? action 'set-var!))) 
            (error "Undefined variable" var)) 
           ((null? vars) 
            (if (or (eq? action 'lookup-var) 
                    (eq? action 'set-var!)) 
                (env-loop 
                  var 
                  val 
                  (enclosing-environment env) 
                  action) 
                (add-binding-to-frame! 
                  var val (first-frame env)))) 
           ((eq? var (car vars)) 
            (if (or (eq? action 'define-var) 
                    (eq? action 'set-var!)) 
                (set-car! vals val) 
                (car vals))) 
           (else (scan (cdr vars) 
                       (cdr vals))))) 
   (let ((frame (first-frame env))) 
     (scan (frame-variables frame) 
           (frame-values frame)))) 
  
 (define (lookup-variable-value var env) 
   (env-loop var '() env 'lookup-var)) 
  
 (define (set-variable-value! var val env) 
   (env-loop var val env 'set-var!)) 
  
 (define (define-variable! var val env) 
   (env-loop var val env 'define-var))

Here we can just check against the action parameter to determine what action to take! The important information that does not change is captured in the env-loop environment (such as var, val, env, and action) and scan does not have to worry about it.

revc

All procedures try to find the specified variable in the environment, if any, the procedure will perform the corresponding actions; if not, it will take other actions.

 #lang racket 
 (require compatibility/mlist) 
  
 ;;; representing frames 
 (define (make-frame variables values) 
   (mcons variables values)) 
  
 (define (frame-variables frame) (mcar frame)) 
 (define (frame-values frame) (mcdr frame)) 
  
 (define (add-binding-to-frame! var val frame) 
   (set-mcar! frame (mcons var (mcar frame))) 
   (set-mcdr! frame (mcons val (mcdr frame)))) 
  
  
  
 ;;; representing environments (a list of frames) 
 (define (enclosing-environment env) (mcdr env)) 
 (define (first-frame env) (mcar env)) 
 (define the-empty-environment empty) 
  
  
  
 ;;; operations on environments 
  
 (define (find-var-and-do var env unfound found) 
   (define (scan vars vals) 
     (cond [(null? vars) (unfound)] 
           [(eq? var (mcar vars)) (found vals)] 
           [else (scan (mcdr vars) (mcdr vals))])) 
   (if (eq? env the-empty-environment) 
       (error "Unbound variable" var) 
       (let ([frame (first-frame env)]) 
         (scan (frame-variables frame) 
               (frame-values frame))))) 
  
 ;;; return a value 
 (define (lookup-variable-value var env) 
   (find-var-and-do var env 
                    (λ () (lookup-variable-value var (enclosing-environment env))) 
                    (λ (vals) (mcar vals)))) 
  
 ;;; add a new binding 
 (define (define-variable! var val env) 
   (find-var-and-do var env 
                    (λ () (add-binding-to-frame! var val (first-frame env))) 
                    (λ (vals) (set-mcar! vals val)))) 
  
 ;;; change an existed binding 
 (define (set-variable-value! var val env) 
   (find-var-and-do var env 
                    (λ () (set-variable-value! var val (enclosing-environment env))) 
                    (λ (vals) (set-mcar! vals val)))) 
  
  
 ;;; return new environment 
 (define (extend-environment vars vals base-env) 
   (if (= (length vars) (length vals)) 
       (mcons (make-frame vars vals) base-env) 
       (if (< (length vars) (length vals)) 
           (error "Too many arguments supplied" vars vals) 
           (error "Too few arguments supplied" vars vals))))

o3o3o

There are two parts: traverse-env and traverse-frame, each of which just do simple thing:

if find or match by var, return matched (var, val);
if-not return NOT-MATCH.

And we need some action on the upper function according the returned result of traverse-* function.

I think using callback is not good way, because the callbacks need some args which should not be fixed in some conditions.

I also tried to use call-back with call-back text which is going to be called by eval. There are two reason not to use call-back:

eval need a env argument;
The invoker wrting call-back function has to jump into the traverse-* to see what to invoke.

 (define (traverse-env env var match-action) 
   (define (env-loop-iter env) 
     (if (eq? env the-empty-environment) 
         "NOT-MATCH" 
         (let* ((frame (first-frame env))) 
           (res (tranverse-frame frame var)) 
           (if (eq? res "NOT-MATCH") 
               (env-loop-iter (enclosing-environment env)) 
               (list frame res))))); return (frame (vars vals) if matched 
   (env-loop-iter env)) 
  
 (define (tranverse-frame frame var match-action not-match-action) 
   (define (scan-iner vars vals) 
     (cond ((null? vars) 
            "NOT-MATCH" 
            ((eq? var (car vars)) 
             (list vals vals)) ; return (vars vals) if matched 
            (else  
              (scan-iner (cdr vars) (cdr vals)))))) 
   (scan-iner (frame-variables frame)  
              (frame-values frame))) 
  
 (define (lookup-variable-value var env) 
   (let (res (traverse-env env var)) 
     (if (eq? res "NOT-MATCH") 
         (error "Unbound variable" var) 
         (caadadr res)))) ; (frame (vars vals)) -> val 
  
 (define (set-variable-value! var val env) 
   (let (res (traverse-env env var)) 
     (if (eq? res "NOT-MATCH") 
         (error "Unbound variable -- SET!" var) 
         (set-car! ((cadadr res) val))))) ; (frame (vars vals)) -> vals 
  
 (define (define-variable! var val env) 
   (let* ((frame (first-frame env))) 
     (res (tranverse-frame frame)) 
     (if (eq? "NOT-MATCH") 
         (add-binding-to-frame! var val frame) 
         (set-car! ((cadr res) val))))) ; (vars vals) -> vals

Sphinxsky

I think exercise 4-11 and exercise 4-12 should be donetogether！

  
  
  
 ; The most important abstraction!!! 
 (define (scan items is-over? is-it? get-now get-other) 
     (if (is-over? items) 
         #f 
         (let ((now (get-now items))) 
             (if (is-it? now) 
                 now 
                 (scan (get-other items) is-over? is-it? get-now get-other))))) 
  
  
  
 ; define binding 
 (define (make-binding var val) 
     (cons var val)) 
 (define (binding-var binding) 
     (car binding)) 
 (define (binding-val binding) 
     (cdr binding)) 
 (define (set-binding! binding new-val) 
     (set-cdr! binding new-val)) 
  
  
  
 ; define frame (exercise 4-11) 
 (define (make-frame variables values-) 
  
     (define (lookup var bindings) 
         (define (is-it? now) 
             (eq? var (binding-var now))) 
         (scan bindings null? is-it? car cdr)) 
      
     (let ((bindings (map make-binding variables values-))) 
         (lambda (msg) 
             (cond ((eq? msg 'add) 
                     (lambda (binding) 
                         (set! bindings (cons binding bindings)))) 
                 ((eq? msg 'lookup) 
                     (lambda (var) 
                         (lookup var bindings))) 
                 ((eq? msg 'vars) 
                     (map binding-var bindings)) 
                 ((eq? msg 'vals) 
                     (map binding-val bindings)) 
                 (else (error "Unknown operation -- FRAME" msg)))))) 
  
 (define (frame-variables frame) 
     (frame 'vars)) 
 (define (frame-values frame) 
     (frame 'vals)) 
 (define (add-binding-to-frame! var val frame) 
     ((frame 'add) (make-binding var val))) 
 (define (lookup-binding-to-frame var frame) 
     ((frame 'lookup) var)) 
  
  
  
 ; the code in book 
 (define (enclosing-environment env) 
     (cdr env)) 
 (define (first-frame env) 
     (car env)) 
 (define the-empty-environment '()) 
  
 ; define environment 
 (define (is-empty-environment? env) 
     (eq? env the-empty-environment)) 
  
 (define (lookup-binding-to-environment var env) 
     (define (get-now env) 
         (lookup-binding-to-frame var (first-frame env))) 
     (scan 
         env 
         is-empty-environment? 
         (lambda (now) now) 
         get-now 
         enclosing-environment)) 
  
 ; The rewriting process makes the scope of variables more friendly 
 (define (extend-environment vars vals base-env) 
     (let ((vars-len (length vars)) 
           (vals-len (length vals))) 
         (if (= vars-len vals-len) 
             (if (is-empty-environment? base-env) 
                 (cons (make-frame vars vals) base-env) 
                 (let ((ff (first-frame base-env)) 
                       (ee (enclosing-environment base-env))) 
                     (set-car! base-env (make-frame vars vals)) 
                     (set-cdr! base-env (cons ff ee)) 
                     base-env)) 
             (if (< vars-len vals-len) 
                 (error "Too many arguments supplied" vars vals) 
                 (error "Too few arguments supplied" vars vals))))) 
  
  
 ; =============================== exercise 4-12 =============================== 
 (define (lookup-variable-value var env) 
     (let ((binding (lookup-binding-to-environment var env))) 
         (if binding 
             (binding-val binding) 
             (error "Unbound variable" var)))) 
  
 (define (set-variable-value! var val env) 
     (let ((binding (lookup-binding-to-environment var env))) 
         (if binding 
             (set-binding! binding val) 
             (error "Unbound variable -- SET!" var)))) 
  
 (define (define-variable! var val env) 
     (let* ((frame (first-frame env)) 
            (binding (lookup-binding-to-frame var frame))) 
         (if binding 
             (set-binding! binding val) 
             (add-binding-to-frame! var val frame))))

master

To define variables we only need to search the current frame, for the other two procedures we need to go through all frames and recurse into each one separately. Seems like a good opportunity for abstraction! search-frame searches the bindings in the current frame, and search-environment searches through the environment by calling search-frame for each frame in sequence.

 (define (search-environment var env match nomatch error-message) 
   (define (rec env) 
     (if (eq? env the-empty-environment) 
         (error error-message var) 
         (let ((frame (first-frame env))) 
           (search-frame var frame match nomatch)))) 
   (rec env)) 
  
 (define (search-frame var frame match nomatch) 
   (define (rec bindings) 
     (cond ((null? bindings) (nomatch)) 
           ((let ((res (assoc var bindings))) 
            (match res))) 
           (else (rec (cdr bindings))))) 
   (rec (frame-bindings frame))) 
  
 (define (lookup-variable-value var env) 
   (search-environment var 
                       env 
                       (lambda (res) (and res (cdr res))) 
                       (lambda () (lookup-variable-value var (enclosing-environment env))) 
                       "Unbound variable")) 
  
 (define (set-variable-value! var val env) 
   (search-environment var 
                       env 
                       (lambda (res) (and res (set-cdr! res val))) 
                       (lambda () (set-variable-value! var val (enclosing-environment env))) 
                       "Unbound variable: SET!")) 
  
 (define (define-variable! var val env) 
   (let ((frame (first-frame env))) 
     (search-frame var 
                   frame 
                   (lambda (res) (and res (set-cdr! res val))) 
                   (lambda () (add-binding-to-frame! var val frame)))))

SteeleDynamics

(master)'s solution above is correct and is (almost???) Continuation-Passing Style (CPS). Correct me if I am wrong. I think (???) my solution is correctly implemented in CPS, where sc is the success continuation and fc is the failure continuation.

 ; frame-lookup-cps procedure 
 (define (frame-lookup-cps var vars vals sc fc)    ;! 
   (cond ((null? vars) (fc)) 
         ((eq? var (car vars)) (sc vals)) 
         (else (frame-lookup-cps var (cdr vars) (cdr vals) sc fc)))) 
  
 ; env-lookup-cps procedure 
 (define (env-lookup-cps var env sc fc)            ;! 
   (if (eq? env the-empty-environment) 
       (fc) 
       (let ((frame (first-frame env))) 
         (let ((vars (frame-variables frame)) 
               (vals (frame-values frame)) 
               (enc (enclosing-environment env))) 
           (let ((fc (lambda () (env-lookup-cps var enc sc fc)))) 
             (frame-lookup-cps var vars vals sc fc)))))) 
  
 ; lookup-variable-value procedure 
 (define (lookup-variable-value var env)           ;! 
   (env-lookup-cps 
    var 
    env 
    (lambda (vals) (car vals)) 
    (lambda () (error "Unbound variable" var)))) 
  
 ; set-variable-value! mutator procedure 
 (define (set-variable-value! var val env)         ;! 
   (env-lookup-cps 
    var 
    env 
    (lambda (vals) (set-car! vals val)) 
    (lambda () (error "Unbound variable -- SET!" var)))) 
  
 ; define-variable! mutator procedure 
 (define (define-variable! var val env)            ;! 
   (let ((frame (first-frame env))) 
     (let ((vars (frame-variables frame)) 
           (vals (frame-values frame))) 
       (frame-lookup-cps 
         var 
         vars 
         vals 
         (lambda (vals) (set-car! vals val)) 
         (lambda () (add-binding-to-frame! var val frame))))))