SICP-Refresher-Chapter-3(5)

1
2
3
4
5
6
7

(define (stream-map proc . argstreams)
  (if (stream-null? (car argstreams))
      the-empty-stream
      (cons-stream
       (apply proc (map stream-car argstreams))
       (apply stream-map
	      (cons proc (map stream-cdr argstreams))))))

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

;; 基于记忆性过程和延时求值
;; 第一个表达式
;; 0
;; value: x

;; 第二个
;; 1
;; 2
;; 3
;; 4
;; 5
;; value: 5

;; 第三个
;; 6
;; 7
;; value: 7

 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

(define sum 0)
;; sum 0

(define (accum x)
  (set! sum (+ x sum))
  sum)

;; accum

(define seq (stream-map accum (stream-enumerate-interval 1 20)))
;; sum 1

(define y (stream-filter even? seq))
;; sum 6

(define z (stream-filter (lambda (x) (= (remainder x 5) 0)) seq))
;; sum 10

(stream-ref y 7)
;; 6
;; 10
;; 28
;; 36
;; 66
;; 78
;; 120
;; 136

;; 136
;; sum 136

(display-stream z)
;; 10
;; 15
;; 45
;; 55
;; 105
;; 120
;; 190
;; 210

;; sum 210

;; 如果不使用记忆性过程的话，对 seq 流的求值将会产生重复计算；
;; 而每次重复对 seq 的流进行求值，都会调用 accum；
;; 每一次重复计算都会更新 sum 的值；

1
2
3
4
5
6

;; 1
;; 2
;; 4
;; 8
;; ...
;; (expt 2 n)

1
2
3

(define (mul-streams s1 s2)
  (stream-map * s1 s2))
(define factorials (cons-stream 1 (mul-streams factorials (stream-cdr integers))))

1
2
3
4
5
6

(define (partial-sums s)
  (cons-stream
   (stream-car s)
   (add-streams
    (partial-sums s)
    (stream-cdr s))))

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

(define (merge s1 s2)
  (cond ((stream-null? s1) s2)
	((stream-null? s2) s1)
	(else
	 (let ((s1car (stream-car s1))
	       (s2car (stream-car s2)))
	   (cond ((< s1car s2car)
		  (cons-stream s1car (merge (stream-cdr s1) s2)))
		 ((> s1car s2car)
		  (cons-stream s2car (merge s1 (stream-cdr s2))))
		 (else
		  (cons-stream s1car
			       (merge (stream-cdr s1))
			       (merge (stream-cdr s2)))))))))

(define s (cons-stream 1 (merge
			  (scale-stream s 2)
			  (merge
			   (scale-stream s 3)
			   (scale-stream s 5)))))

1
2
3
4

;; 使用基于 add-streams 过程的 fibs 流，所需加法步骤是与 n 相关的线性函数；
;; 如果在 delay 的实现中不使用记忆性过程，那每次去取 n-1 与 n-2 的 fib 值，
;; 都会引起这两个值的重复计算；
;; 就像中文版 SICP P24 中最初的 fib 程序，整个过程步数的增长阶是指数级的。

1
2
3
4
5
6
7
8
9

;; 计算出的流是 expand 第一个参数与第二个参数的商的小数点后无限位数
;; (num 需小于 den)

;; (expand 1 7 10)
;; (1 4 2 8 5 ...)
;; 1 / 7 = 0.14285...

;; (expand 3 8 10)
;; (3 7 5 0 0 ...)

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

;; a

(define (integers-starting-from n)
  (cons-stream n (integers-starting-from (+ n 1))))

(define (div-streams s1 s2)
  (stream-map / s1 s2))			;no 0 in s2

(define (integrate-series s)
  (define integers (integers-starting-from 1))
  (div-streams s integers))

;; b

(define exp-series
  (cons-stream 1 (integrate-series exp-series)))

(define sine-series
  (cons-stream 0 (integrate-series cosine-series)))

(define cosine-series
  (cons-stream 1 (integrate-series (scale-stream sine-series -1))))

1
2
3
4

(define (mul-series s1 s2)
  (cons-stream (* (stream-car s1) (stream-car s2))
	       (add-streams (scale-stream (stream-cdr s2) (stream-car s1))
			    (mul-series (stream-cdr s1) s2))))

1
2
3
4

(define (calculate-x s)
  (cons-stream
   1
   (scale-stream (mul-series (stream-cdr s) (calculate-x s)) -1)))

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12

;; (load "./ 3.61.scm")

(define (div-series s1 s2)
  (if (= (stream-car s2) 0)
      (error "element 0 in the second stream")
      (scale-stream (mul-series
		     s1
		     (calculate-x (scale-stream s2 (/ 1 (stream-car s2)))))
		    (/ 1 (stream-car s2)))))

(define tan-series
  (div-series sine-series cosine-series))

1
2
3
4
5
6
7

;; 因为重复计算；
;; 不用局部变量 guesses，那么每次递归调用 (sqrt-stream x) 都会构造一个新的流；
;; 而且其每个元素都必须重新计算，无法使用前面构建的流的记忆性过程的缓存结果；

;; when replace the delay implementation
;; 如果 delay 的实现不使用 memo-proc, 不使用记忆性过程带来的优化；
;; 两个版本在效率方面没有差异。

1
2
3
4
5
6
7

(define (stream-limit s t)
  (let ((sub-s (stream-map - s (stream-cdr s))))
    (define (get-the-desired sub-streams stream)
      (if (< (abs (stream-car sub-streams)) t)
	  (stream-car stream)
	  (get-the-desired (stream-cdr sub-streams) (stream-cdr stream))))
    (get-the-desired sub-s (stream-cdr s))))

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

(define (ln2-summands n)
  (cons-stream
   (/ 1.0 n)
   (stream-map - (ln2-summands (+ n 1)))))

(define ln2-stream
  (partial-sums (ln2-summands 1)))	;first way

(define ln2-stream-euler
  (euler-transfrom ln2-stream))		;second way

(define ln2-stream-accelerated
  (accelerated-sequence euler-transfrom ln2-stream)) ;third way

1

;; 放弃

 1
 2
 3
 4
 5
 6
 7
 8
 9
10

(define (pairs s t)
  (cons-stream
   (list (stream-car s) (stream-car t))
   (interleave
    (interleave
     (stream-map (lambda (x) (list x (stream-car t)))
		 (stream-cdr s))
     (stream-map (lambda (x) (list (strem-car s) x))
		 (stream-cdr t)))
    (pairs (stream-cdr s) (stream-cdr t)))))

1
2
3
4

;; 那么对 pairs 过程体 (interleave p1 p2) 的求值
;; 将会立即对其第二个参数表达式即另一个 pairs 过程调用求值；
;; 因为传入的流是无穷流，这样的递归归调用永远不会停止；
;; 最后解释器报错：exceeds maximum recursion depth

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

(define (triples s t u)
  (cons-stream
   (list (stream-car s) (stream-car t) (stream-car u))
   (interleave
    (stream-map (lambda (x) (cons (stream-car s) x))
		(stream-cdr (pairs t u)))
    (triples (stream-cdr s)
	     (stream-cdr t)
	     (strem-cdr u)))))

(define desired
  (let ((base-stream (triples integers integers integers)))
    (stream-filter
     (lambda (x) (= (square (caddr x)) (+ (square (car x)) (square (cadr x)))))
     base-stream)))

 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

(define (merge s1 s2)
  (cond ((stream-null? s1) s2)
	((stream-null? s2) s1)
	(else
	 (let ((s1car (stream-car s1))
	       (s2car (stream-car s2)))
	   (cond ((< s1car s2car)
		  (cons-stream s1car (merge (stream-cdr s1) s2)))
		 ((> s1car s2car)
		  (cons-stream s2car (merge s1 (stream-cdr s2))))
		 (else
		  (cons-stream s1car
			       (merge
				(stream-cdr s1)
				(stream-cdr s2)))))))))

(define (merge-weighted s1 s2 weight)
  (cond ((stream-null? s1) s2)
	((stream-null? s2) s1)
	(else
	 (let ((s1car (stream-car s1))
	       (s2car (stream-car s2)))
	   (cond ((< (weight s1car) (weight s2car))
		  (cons-stream s1car (merge-weighted (stream-cdr s1) s2 weight)))
		 ((> (weight s1car) (weight s2car))
		  (cons-stream s2car (merge-weighted s1 (stream-cdr s2) weight)))
		 (else
		  (cons-stream s1car
			       (merge-weighted
				(stream-cdr s1)
				s2 weight))))))))

(define (weighted-pairs s t weight)
  (cons-stream
   (list (stream-car s) (stream-car t))
   (merge-weighted
    (stream-map (lambda (x) (list (stream-car s) x))
		(stream-cdr t))
    (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
    weight)))

;; a

(define desired1
  (weighted-pairs
   integers
   integers
   (lambda (p) (+ (car p) (cadr p)))))

;; b

(define (weighted235 p)
  (+ (* 2 (car p)) (* 3 (cadr p)) (* 5 (car p) (cadr p))))

;; in Chinese version of SICP, i or j must be fully divided by 2, 3 or 5
(define s (cons-stream 1 (merge (scale-stream s 2)
				(merge (scale-stream s 3)
				       (scale-stream s 5)))))

(define desired2
  (weighted-pairs
   s
   s
   weighted235))

 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

(define (cube-pair p)
  (+ (expt (car p) 3) (expt (cadr p) 3)))

(define base-stream
  (weighted-pairs
   integers
   integers
   cube-pair))

(define (Ramanujan-pairs s1 s2)
  (if (= (cube-pair (stream-car s1))
	 (cube-pair (stream-car s2)))
      (cons-stream (cube-pair (stream-car s1))
		   (Ramanujan-pairs (stream-cdr s1)
				    (stream-cdr s2)))
      (Ramanujan-pairs (stream-cdr s1)
		       (stream-cdr s2))))

(define Ramanujan-streams
  (Ramanujan-pairs base-stream
		   (stream-cdr base-stream)))

;; 1729
;; 4104
;; 13832
;; 20683
;; 32832
;; 39312

 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

(define (square-pair p)
  (+ (square (car p)) (square (cadr p))))

(define base-stream
  (weighted-pairs
   integers
   integers
   square-pair))

(define (desired-pairs s1 s2 s3)
  (if (= (square-pair (stream-car s1))
	 (square-pair (stream-car s2))
	 (square-pair (stream-car s3)))
      (cons-stream (list (square-pair (stream-car s1))
			 (stream-car s1)
			 (stream-car s2)
			 (stream-car s3))
		   (desired-pairs (stream-cdr s1)
				  (stream-cdr s2)
				  (stream-cdr s3)))
      (desired-pairs (stream-cdr s1)
		     (stream-cdr s2)
		     (stream-cdr s3))))

(define desired-streams
  (desired-pairs base-stream
		 (stream-cdr base-stream)
		 (stream-cdr (stream-cdr base-stream))))

;; (325 (1 18) (6 17) (10 15))
;; (425 (5 20) (8 19) (13 16))
;; ...

1
2
3
4
5
6
7
8

(define (RC r c dt)
  (define (voltage i v0)
    (add-streams
     (scale-stream i r)
     (integral (scale-stream i (/ 1 c))
	       v0
	       dt)))
  voltage)

1
2
3
4
5

(define zero-crossings
  (stream-map
   sign-change-detector
   sense-data
   (cons-stream 0 sense-data)))

1
2
3
4
5
6

(define (make-zero-crossings input-stream last-value last-avpt)
  (let ((avpt (/ (+ (stream-car input-stream) last-value) 2)))
    (cons-stream (sign-change-detector avpt last-avpt)
		 (make-zero-crossings (stream-cdr input-stream)
				      (stream-car input-stream)
				      avpt))))

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12

(define (smooth input-stream)
  (stream-map (lambda (i j) (/ (+ i j) 2))
	      (cons-stream 0 input-stream)
	      input-stream))

(define (make-zero-crossings input-stream smooth)
  (let ((smooth-stream (smooth input-stream)))
    (stream-map sign-change-detector
		smooth-stream
		(cons-stream
		 0
		 smooth-stream))))

1
2
3
4
5
6
7
8
9

(define (integral delayed-integrand initial-value dt)
  (cons-stream initial-value
	       (let ((integrand (force delayed-integrand)))
		 (if (stream-null? integrand)
		     the-empty-stream
		     (integral (dealy (stream-cdr integrand))
			       (+ (* dt (stream-car integrand))
				  initial-value)
			       dt)))))

1
2
3
4
5

(define (solve-2nd a b dt y0 dy0)
  (define y (integral (delay dy) y0 dt))
  (define dy (integral (delay ddy) dy0 dt))
  (define ddy (add-streams (scale-stream dy a) (scale-stream y b)))
  y)

1
2
3
4
5

(define (solve-2nd f y0 dy0 dt)
  (define y (integral (delay dy) y0 dt))
  (define dy (integral (delay ddy) dy0 dt))
  (define ddy (stream-map f dy y))
  y)

 1
 2
 3
 4
 5
 6
 7
 8
 9
10

(define (RLC r l c dt)
  (lambda (vc0 il0)
    (define vc (integral (delay dvc) vc0 dt))
    (define il (integral (delay dil) il0 dt))
    (define dvc (scale-stream il (- (/ 1 c))))
    (define dil
      (add-streams
       (scale-stream vc (/ 1 l))
       (scale-stream il (- (/ r l)))))
    (stream-map cons vc il)))

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

;; order-stream (('generate) ('reset 124) ...)

(define (random-numbers order-stream val)
  (define (base-stream base)
    (cons-stream
     base
     (random-numbers
      (stream-cdr order-stream)
      (rand-update base))))
  (cond ((eq? (car (stream-car order-stream)) 'generate)
	 (base-stream val))
	((eq? (car (stream-car order-stream)) 'reset)
	 (base-stream (cadr (stream-car order-stream))))
	(else "Invalid order" (stream-car order-stream))))

 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

(define (monte-carlo experiment-stream passed failed)
  (define (next passed failed)
    (cons-stream
     (/ passed (+ passed failed))
     (monte-carlo
      (stream-cdr experiment-stream) passed failed)))
  (if (stream-car experiment-stream)
      (next (+ passed 1) failed)
      (next passed (+ failed 1))))

(define (rand-numbers a1 a2)
  (cons-stream
   (random-in-range a1 a2)
   (rand-numbers a1 a2)))

(define (make-point x y)
  (cons x y))

(define (x-point p)
  (car p))

(define (y-point p)
  (cdr p))

(define (mid-point p1 p2)
  (let ((x (/ (+ (x-point p1) (x-point p2)) 2))
	(y (/ (+ (y-point p1) (y-point p2)) 2)))
    (make-point x y)))

(define (radius-square p1 p2)
  (let ((x1 (x-point p1))
	(x2 (x-point p2)))
    (square (abs (/ (- x1 x2) 2)))))

(define (p r1 r2 m1 m2 rs)
  (not (> (+ (square (- r1 m1))
	     (square (- r2 m2)))
	  rs)))

(define (random-in-range low high)
  (let ((range (- high low)))
    (+ low (random range))))

(define (estimate-integral x1 x2 y1 y2)
  (define x-random-stream (rand-numbers x1 x2))
  (define y-random-stream (rand-numbers y1 y2))
  (define p1 (make-point x1 y1))
  (define p2 (make-point x2 y2))
  (define center (mid-point p1 p2))
  (define m1 (x-point center))
  (define m2 (y-point center))
  (define rs (radius-square p1 p2))
  (define (integral-test r1 r2)
    (p r1 r2 m1 m2 rs))
  (define results-stream
    (stream-map
     integral-test
     x-random-stream
     y-random-stream))

  (monte-carlo results-stream 0 0))