SICP-Refresher-Chapter-4(2)

1
2
3
4
5
6

;; in applicative order scheme
;; this factorial would runs into death loop
;; even with the n equals to 1
;; the (* n (factorial (- n 1))) will be computed in applicative order

;; it will pass in normal order scheme

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27

;; a

(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)
  (let ((condition (unless-condition exp))
	(usual-value (unless-usual-value exp))
	(usual-exceptional-value exp))
    (make-if condition usual-exceptional-value usual-value)))

(define (eval-unless exp env)
  (eval (unless-if exp) env))

;; implemetn unless? and eval-unless in eval

;; b
;; a case which is about high order procedure...

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16

(define count 0)

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

(define w (id (id 10)))

;; count
;; 1

;; w
;; 10

;; count
;; 2

1
2
3
4
5

;; the operator maybe a thunk lambda object
;; if not pass the actual-value result of operator to apply;
;; within apply it would always fall to the third clause
;; which reports error.
;; so it must be evaluated by actual-value before passed to apply.

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24

(define (fibonacci n)
  (cond ((= n 0) 0)
	((= n 1) 1)
	(else (+ (fibonacci (- n 1))
		 (fibonacci (- n 2))))))
;; better with memo-proc


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

;; with memo
;; (square (id 10))
;; 100

;; count
;; 1

;; without memo
;; (square (id 10)
;; 100

;; count
;; 2

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25

;; a
;; because the procedure body of (lambda (x) (newline) (display x)) has two primitive procedures
;; when evaluated using eval, it will call actual-value to get x

;; b
;; the original one
;; (p1 1) => (1 2)
;; (p2 1) => 1 (set! x (cons x '(2))) would be delayed in (p (set! x (cons x '(2))))

;; cy's version
;; (p1 1) => (1 2)
;; (p2 1) => (1 2)

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

(define (force-it obj)
  (if (thunk? obj)
      (actual-value (thunk-exp obj) (thunk-env obj))
      obj))				;when the exp is not a thunk, just return it


;; define
;; I prefer cy's way.

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65

;; in eval
((application? exp)
 (apply (actual-value (operator exp) env)
	(operands exp)
	env))				;keep same

(define (apply procedure arguments env)
  (cond ((primitive-procedure? procedure)
	 (apply-primitive-procedure
	  procedure
	  (list-of-arg-values arguments env)))
	((compound-procedure? procedure)
	 (let ((parameters (procedure-parameters procedure)))
	   (eval-sequence
	    (procedure-body procedure)
	    (extend-environment
	     (map (lambda (i) (if (not (pair? i)) i (car i))) parameters)
	     (list-of-mixed-args parameters arguments env)
	     (procedure-environment procedure)))))
	(else
	 (error
	  "Unknown procedure type -- APPLY" procedure))))

(define (list-of-arg-values exps env)
  (if (no-operands? exps)
      '()
      (cons (actual-value (first-operand exps) env)
	    (list-arg-values (rest-operands exps)
			     env))))

(define (list-of-mixed-args prms exps env)
  (define (on-prms prm exp env)
    (cond ((not (pair? prm)) (actual-value exp env))
	  ((eq? (cdr prm) 'lazy) (delay-it exp env))
	  ((eq? (cdr prm) 'lazy-memo) (delay-it-memo exp env))))
  (if (no-operands? exps)
      '()
      (cons (on-prms (car prms) (first-operand exps) env)
	    (list-of-mixed-args (cdr prms) (rest-operands exps) env))))

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

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

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

(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)
	   (set-cdr! (cdr obj) '())
	   result))
	((evaluated-thunk? obj)
	 (thunk-value obj))
	(else obj)))

;; other procedures kept unchanged

1
2
3
4
5
6
7
8
9

;; car and cdr of lazy list in this chapter are both delayed
;; only cdr of lazy list in chapter 3 is delayed

;; how could one programmer makes advantage of this feature?
;; just like the procedure list-ref
;; only computes the desired car part
;; as for the version defined in chapter 3
;; every car part would be computed until n equals to index;
;; the one in chapter 4 text is more efficient

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19

(define (quoted? exp)
  (tagged-list? exp 'quote))

(define (text-of-quotation exp)
  (let ((temp (cadr exp)))
    (if (not (pair? temp))
	temp
	(new-list temp))))

(define (new-list pair)
  (if (null? pair)
      '()
      (make-procedure
       '(m)
       (list (list 'm 'car-value 'cdr-value))
       (extend-environment
	(list 'car-value 'cdr-value)
	(list (car pair) (new-list (cdr pair)))
	the-empty-environment))))

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34

(define (user-print object)
  (cond ((compound-procedure? object)
	 (display (list 'compound-procedure
			(procedure-parameters object)
			(procedure-body object)
			'<procedure-env>)))
	((lazy-list? object)
	 (display (list 'lazy-list
			(caddddr object)
			'...)))
	(else (display object))))

;; reserve the old cons car cdr in evaluator

(define old-cons cons)

(define old-car car)

(define old-cdr cdr)

(define (tagged-list? exp symbol)
  (eq? (old-car exp) symbol))

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

(define (cons x y)
  (old-cons 'lazy-list (lambda (m) (m x y))))

(define (car z)
  ((old-cdr z) (lambda (p q) p)))

(define (cdr z)
  ((old-cdr z) (lambda (p q) q)))