这次回顾第四章第三部分习题。

学习资料：

https://ocw.mit.edu/courses/electrical-engineering-and-computer-science/6-001-structure-and-interpretation-of-computer-programs-spring-2005/index.htm

https://github.com/DeathKing/Learning-SICP

https://mitpress.mit.edu/sites/default/files/sicp/index.html

https://www.bilibili.com/video/BV1Xx41117tr?from=search&seid=14983483066585274454

参考资料：

https://sicp.readthedocs.io/en/latest

http://community.schemewiki.org/?SICP-Solutions

http://community.schemewiki.org/?sicp

https://liujiacai.net/blog/2016/02/22/recursion-without-name/

https://mvanier.livejournal.com/2897.html

https://github.com/jiacai2050/sicp

https://liujiacai.net/

4.22(p276)

代码如下：

(load "ch4-mceval.scm")

(define (let? exp) (tagged-list? exp 'let))

(define (let-var-exp exp) (cadr exp))

(define (let-body exp) (cddr exp))

(define (get-var varexp)
    (if (null? varexp)
        '()
        (cons (caar varexp) (get-var (cdr varexp)))))

(define (get-exp varexp)
    (if (null? varexp)
        '()
        (cons (cadar varexp) (get-exp (cdr varexp)))))

(define (analyze-let->combination exp)
    (let ((varlist (get-var (let-var-exp exp)))
          ; add
          (explist (map analyze (get-exp (let-var-exp exp))))
          (body (analyze (let-body exp))))
         (cons (make-lambda varlist body) explist)))

(define (analyze exp)
    ; add
    (cond ((let? exp) (analyze-let->combination exp))
            (else
            (error "Unknown expression type -- EVAL" exp))))

4.23(p276)

参考资料：

http://community.schemewiki.org/?sicp-ex-4.23

Alyssa方法没有对内部的表达式执行分析，具体例子如下：

(define exps (exp))
(define procs (map analyze exps)) = (res)

; 课本方法
(loop (car procs) (cdr procs))
= (lambda (env) (res env))

; Alyssa方法
(lambda (env) (execute-sequence procs env))

4.24(p276)

略过，后续补充。

4.25(p278)

应用序会一直展开，然后递归爆栈，例子如下：

(define (unless condition usual-value exceptional-value)
    (if condition exceptional-value usual-value))

(define (factorial n)
    (display n)
    (unless (= n 1)
            (* n (factorial (- n 1)))
            1))

(factorial 5)

; 调用过程
; (* 5 (factorial 4))
; (* 5 (* 4 (factorial 3)))
; (* 5 (* 4 (* 3 (factorial 2))))
; (* 5 (* 4 (* 3 (* 2 (factorial 1)))))
; (* 5 (* 4 (* 3 (* 2 (* 1 (factorial 0))))))
; ...

4.26(p278)

参考资料：

https://github.com/jiacai2050/sicp/blob/master/exercises/04/4.26.md

http://community.schemewiki.org/?sicp-ex-4.26

特殊形式可以自己指定是否使用惰性求值，但是过程则不可以。

代码参考了第二份参考资料：

(load "ch4-mceval.scm")

; 派生表达式
(define (unless condition usual-value exceptional-value)
    (if condition exceptional-value usual-value))

(define (unless? exp) (tagged-list? exp 'unless))

(define (unless-condition exp) (cadr exp))

(define (unless-usual-value exp) (caddr exp))

(define (unless-exceptional-value exp) (cadddr exp))

(define (unless->if exp)
    (make-if (unless-condition exp)
             (unless-usual-value exp)
             (unless-exceptional-value exp)))

; 高阶
(define (test f pred a b c)
    (f (pred a b c)))

(test unless a b c)

4.27(p282)

调用过程：

count
; 计算了(id 10), 所以为1

w
; 计算了(id (id 10)), 所以为10

count
; 计算了(id (id 10)), 所以为2

代码：

(load "ch4-leval.scm")

(define the-global-environment (setup-environment))
(driver-loop)

(define (try a b)
  (if (= a 0) 1 b))

(try 0 (/ 1 0))

(define count 0)

(define (id x)
  (set! count (+ count 1))
  x)

(define w (id (id 10)))

count
; 0
w
; 10
count
; 2

结果：

;;; L-Eval input:
count
;;; L-Eval value:
1

;;; L-Eval input:
; 0
w
id

+

;;; L-Eval value:
10

;;; L-Eval input:
; 10
count
;;; L-Eval value:
2

4.28(p282)

参考资料：

http://community.schemewiki.org/?sicp-ex-4.28

例子：

(load "ch4-leval.scm")

(define the-global-environment (setup-environment))
(driver-loop)

(define (a x)
    (+ x 1))

(define (b a x)
    (a x))

(b a 1)

如果直接使用eval，则没有对a进行求值，调用会出错。

4.29(p282)

代码如下：

(load "ch4-leval.scm")

(define the-global-environment (setup-environment))
(driver-loop)

(define count 0)

(define (id x)
  (set! count (+ count 1))
  x)

(define (square x)
  (* x x))

(square (id 10))

(display count)

有记忆：

(square (id 10)) : 100
count : 1

无记忆：

(square (id 10)) : 100
; (* (id 10) (id 10))
count : 2

4.30(p282)

(a)

因为使用了display，display是primitive-procedure，根据如下代码，会直接执行：

((primitive-procedure? procedure)
         (apply-primitive-procedure
          procedure
          (list-of-arg-values arguments env)))
(b)

正文方法：

(p1 1) : (1 2)
(p2 1) : 1

其中第二项为1是因为无需执行

(set! x (cons x '(2)))

Cy的方法：

(p1 1) : (1 2)
(p2 1) : (1 2)
(c)

如果调用了primitive-procedure，那么肯定会求出值。

(d)

我觉得正文的方法好，效率高，而且是惰性求值。

4.31(p283)

参考资料：

http://community.schemewiki.org/?sicp-ex-4.31

代码如下：

(load "adaptive-eval.scm")

(define the-global-environment (setup-environment))
(driver-loop)

; test
; 基本过程
(define a 1)
(+ a 1)

; 常规过程
(define (f x)
  (+ x 2))
(f 3)

; lazy
(define (try a (b lazy))
  (if (= a 0) 1 b))

(try 0 (/ 1 0))

; lazy vs lazy memo
; lazy
(define (square x)
  (* x x))

(define count1 0)

(define (id1 (x lazy))
  (set! count1 (+ count1 1))
  x)

(define w1 (id1 (id1 10)))
(display count1)
; 0
w1
; 10
(display count1)
; 2

; lazy memo
(define count2 0)

(define (id2 (x lazy-memo))
  (set! count2 (+ count2 1))
  x)

(define w2 (id2 (id1 10)))
(display count2)
; 0
w2
; 10
(display count2)
; 1

adaptive-eval.scm代码：

(load "ch4-mceval.scm")

(define input-prompt ";;; L-Eval input:")
(define output-prompt ";;; L-Eval value:")

(define (driver-loop)
  (prompt-for-input input-prompt)
  (let ((input (read)))
    (let ((output
           (actual-value input the-global-environment)))
      (announce-output output-prompt)
      (user-print output)))
  (driver-loop))

; add start
(define (no-lazy? exp)
    (not (pair? exp)))

(define (lazy? exp)
    (eq? (cadr exp) 'lazy))

(define (lazy-memo? exp)
    (eq? (cadr exp) 'lazy-memo))

(define (thunk? obj) (tagged-list? obj 'thunk)) 
(define (thunk-memo? obj) (tagged-list? obj 'thunk-memo)) 
; add end

(define (eval exp env)
  (cond ((self-evaluating? exp) exp)
        ((variable? exp) (lookup-variable-value exp env))
        ((quoted? exp) (text-of-quotation exp))
        ((assignment? exp) (eval-assignment exp env))
        ((definition? exp) (eval-definition exp env))
        ((if? exp) (eval-if exp env))
        ((lambda? exp)
         (make-procedure (lambda-parameters exp)
                         (lambda-body exp)
                         env))
        ((begin? exp) 
         (eval-sequence (begin-actions exp) env))
        ((cond? exp) (eval (cond->if exp) env))
        ((application? exp)             ; clause from book
            (apply (eval (operator exp) env)
                (operands exp)
                env))
        (else
         (error "Unknown expression type -- EVAL" exp))))

(define (apply procedure arguments env)
  (cond ((primitive-procedure? procedure)
         (apply-primitive-procedure
          procedure
          ; change
          (list-of-values arguments env)))
        ((compound-procedure? procedure)
         (eval-sequence
           (procedure-body procedure)
           (extend-environment
             ; change
             (adaptive-procedure-parameters procedure)
             ; change
             (list-of-args procedure arguments env) 
             (procedure-environment procedure))))
        (else
         (error
          "Unknown procedure type -- APPLY" procedure))))

(define (actual-value exp env)
  (force-it (eval exp env)))

; change
(define (force-it obj)
  (cond ((thunk? obj) (actual-value (thunk-exp obj) (thunk-env obj)))
        ((thunk-memo? obj)
         (let ((result (actual-value
                        (thunk-exp obj)
                        (thunk-env obj))))
           (set-car! obj 'evaluated-thunk)
           (set-car! (cdr obj) result)  ; replace exp with its value
           (set-cdr! (cdr obj) '())     ; forget unneeded env
           result))
        ((evaluated-thunk? obj)
         (thunk-value obj))
        (else obj)))

; add start
(define (list-of-values exps env)
  (if (no-operands? exps)
      '()
      (cons (eval (first-operand exps) env)
            (list-of-values (rest-operands exps) env))))

; 获得参数
(define (adaptive-procedure-parameters procedure)
    (define (get-args par-list)
        (if (no-operands? par-list)
            '()
            (if (pair? (first-operand par-list))
                (cons (car (first-operand par-list)) (get-args (rest-operands par-list)))
                (cons (first-operand par-list) (get-args (rest-operands par-list))))))
    (get-args (procedure-parameters procedure)))

(define (list-of-args procedure exps env)
    (define (get-args par-list exps env)
        (if (no-operands? exps)
            '()
            (cond ((no-lazy? (first-operand par-list)) 
                    (cons (actual-value (first-operand exps) env)
                        (get-args (rest-operands par-list) (rest-operands exps)
                                        env)))
                    ((lazy? (first-operand par-list))
                    (cons (delay-it (first-operand exps) env)
                        (get-args (rest-operands par-list) (rest-operands exps)
                                        env)))
                    ((lazy-memo? (first-operand par-list))
                    (cons (delay-it-memo (first-operand exps) env) 
                        (get-args (rest-operands par-list) (rest-operands exps)
                                        env)))
                    (else (error
          "Unknown parameter type -- " (first-operand par-list))))))
    (get-args (procedure-parameters procedure) exps env))

(define (delay-it exp env)
  (list 'thunk exp env))

(define (delay-it-memo exp env)
  (list 'thunk-memo exp env))

(define (thunk? obj)
  (tagged-list? obj 'thunk))

(define (thunk-exp thunk) (cadr thunk))
(define (thunk-env thunk) (caddr thunk))
; add end

;; "thunk" that has been forced and is storing its (memoized) value
(define (evaluated-thunk? obj)
  (tagged-list? obj 'evaluated-thunk))

(define (thunk-value evaluated-thunk) (cadr evaluated-thunk))

;; A longer list of primitives -- suitable for running everything in 4.2
;; Overrides the list in ch4-mceval.scm

(define primitive-procedures
  (list (list 'car car)
        (list 'cdr cdr)
        (list 'cons cons)
        (list 'null? null?)
        (list 'list list)
        (list '+ +)
        (list '- -)
        (list '* *)
        (list '/ /)
        (list '= =)
        (list 'newline newline)
        (list 'display display)
;;      more primitives
        ))

'ADAPTIVE-LAZY-EVALUATOR-LOADED

输出：

;;; L-Eval input:
; test
; 基本过程
(define a 1)
;;; L-Eval value:
ok

;;; L-Eval input:
(+ a 1)
;;; L-Eval value:
2

;;; L-Eval input:
; 常规过程
(define (f x)
  (+ x 2))
;;; L-Eval value:
ok

;;; L-Eval input:
(f 3)
;;; L-Eval value:
5

;;; L-Eval input:
; lazy
(define (try a (b lazy))
  (if (= a 0) 1 b))
;;; L-Eval value:
ok

;;; L-Eval input:
(try 0 (/ 1 0))
;;; L-Eval value:
1

;;; L-Eval input:
; lazy vs lazy memo
; lazy
(define (square x)
  (* x x))
;;; L-Eval value:
ok

;;; L-Eval input:
(define count1 0)
;;; L-Eval value:
ok

;;; L-Eval input:
(define (id1 (x lazy))
  (set! count1 (+ count1 1))
  x)
;;; L-Eval value:
ok

;;; L-Eval input:
(define w1 (id1 (id1 10)))
;;; L-Eval value:
ok

;;; L-Eval input:
(display count1)1
;;; L-Eval value:
#!unspecific

;;; L-Eval input:
; 0
w1
;;; L-Eval value:
10

;;; L-Eval input:
; 10
(display count1)2
;;; L-Eval value:
#!unspecific

;;; L-Eval input:
; 2

; lazy memo
(define count2 0)
;;; L-Eval value:
ok

;;; L-Eval input:
(define (id2 (x lazy-memo))
  (set! count2 (+ count2 1))
  x)
;;; L-Eval value:
ok

;;; L-Eval input:
(define w2 (id2 (id1 10)))
;;; L-Eval value:
ok

;;; L-Eval input:
(display count2)1
;;; L-Eval value:
#!unspecific

;;; L-Eval input:
; 0
w2
;;; L-Eval value:
10

;;; L-Eval input:
; 10
(display count2)1
;;; L-Eval value:
#!unspecific

;;; L-Eval input:
; 1