SICP/ex-3_63-72.scm

299 lines
8.7 KiB
Scheme
Raw Normal View History

2021-04-25 14:57:17 +02:00
(load "shared/util.scm")
2021-01-03 13:59:39 +01:00
2021-01-05 15:44:02 +01:00
(define (pi-summands n)
(cons-stream (/ 1. n)
(stream-map - (pi-summands (+ n 2)))))
2021-01-03 13:59:39 +01:00
2021-01-05 15:44:02 +01:00
(define pi-stream
(scale-stream (partial-sums (pi-summands 1)) 4))
(define (euler-transform s)
(let ((s0 (stream-ref s 0)) ; Sn-1
(s1 (stream-ref s 1)) ; Sn
(s2 (stream-ref s 2))) ; Sn+1
(cons-stream (- s2 (/ (square (- s2 s1))
(+ s0 (* -2 s1) s2)))
(euler-transform (stream-cdr s)))))
(define (make-tableau transform s)
(cons-stream s
(make-tableau transform
(transform s))))
(define (accelerated-sequence transform s)
(stream-map stream-car
(make-tableau transform s)))
; (display (take 5 pi-stream))
; (newline)
; (display (take 5 (euler-transform pi-stream)))
; (newline)
; (display (take 5 (accelerated-sequence euler-transform pi-stream)))
; (newline)
(display "\nex-3.63 - sqrt-stream\n")
(define (sqrt-improve guess x)
(average guess (/ x guess)))
(define (sqrt-stream x)
(cons-stream 1.0
(stream-map (lambda (guess)
(sqrt-improve guess x))
(sqrt-stream x))))
(define (sqrt-stream x)
(define guesses
(cons-stream 1.0
(stream-map (lambda (guess)
(sqrt-improve guess x))
guesses)))
guesses)
(display (stream-ref (sqrt-stream 2) 1000))
(newline)
; The first implementation of sqrt-stream computes each value of the stream
; only once. Louis' suggestion computes all previous values because of the
; recursive calls to sqrt-stream. If memoization was not used the two solutions
; would behave in the same way.
(display "\nex-3.64 - stream-limit\n")
(define (stream-limit stream tolerance)
(if (< (abs (- (stream-car stream)
(stream-car (stream-cdr stream))))
tolerance)
(stream-car (stream-cdr stream))
(stream-limit (stream-cdr stream) tolerance)))
(define (sqrt-tol x tolerance)
(stream-limit (sqrt-stream x) tolerance))
(assert (< (abs (- 1.4142135623730951 (sqrt-tol 2 0.01)))
0.01) #t)
(assert (< (abs (- 4.795831523312719 (sqrt-tol 23 0.001)))
0.001) #t)
(display "\nex-3.65 - ln2\n")
(define (ln2-summands n)
(cons-stream (/ 1. n)
(stream-map - (ln2-summands (+ n 1)))))
(define ln2-stream
(partial-sums (ln2-summands 1)))
; slow
(define (ln2-tol tolerance)
(stream-limit ln2-stream tolerance))
; fast
(define (ln2-tol tolerance)
(stream-limit (accelerated-sequence euler-transform ln2-stream) tolerance))
(assert (ln2-tol 0.00000000001)
0.6931471805599445)
; The series converges slowly. Only with acceleration we get a good result in
; reasonable time.
(display "\nex-3.66\n")
2021-01-06 12:09:20 +01:00
(define (pairs s t)
(cons-stream
(list (stream-car s) (stream-car t))
(interleave
(stream-map (lambda (x) (list (stream-car s) x))
(stream-cdr t))
(pairs (stream-cdr s) (stream-cdr t)))))
(define int-pairs (pairs integers integers))
(define prime-pairs
(stream-filter
(lambda (pair) (prime? (+ (car pair) (cadr pair))))
int-pairs))
(define (stream-append s1 s2)
(if (stream-null? s1)
s2
(cons-stream (stream-car s1)
(stream-append (stream-cdr s1) s2))))
(define (interleave s1 s2)
(if (stream-null? s1)
s2
(cons-stream (stream-car s1)
(interleave s2 (stream-cdr s1)))))
(assert (find (list 2 5) prime-pairs) 6)
(assert (find (list 3 3) int-pairs) 6)
(assert (find (list 1 100) int-pairs) 197)
;(assert (find (list 99 100) int-pairs) 1000)
;(assert (find (list 100 100) int-pairs) 10)
; I haven't been able to figure out the relationship by myself.
; The explanations on Schemewiki are good, though:
; http://community.schemewiki.org/?sicp-ex-3.66
2021-01-07 18:14:27 +01:00
(display "\nex-3.67 - all-pairs\n")
2021-01-06 12:09:20 +01:00
2021-01-07 18:14:27 +01:00
(define (all-pairs s t)
(cons-stream
(list (stream-car s) (stream-car t))
(interleave
(interleave
(stream-map (lambda (x) (list (stream-car s) x))
(stream-cdr t))
(stream-map (lambda (x) (list x (stream-car t)))
(stream-cdr s)))
(all-pairs (stream-cdr s) (stream-cdr t)))))
(define int-pairs (all-pairs integers integers))
(assert (stream-ref int-pairs 10) '(3 4))
(display "\nex-3.68 - non-lazy pairs\n")
(display "[answered]\n")
(define (bad-pairs s t)
(interleave
(stream-map (lambda (x) (list (stream-car s) x))
t)
(pairs (stream-cdr s) (stream-cdr t))))
; MIT-Scheme uses applicative-order evluation. Hence, pairs gets evaluated
; recursively. Since there is no delay this implementation results in an
; endless loop.
(display "\nex-3.69 - triples\n")
(define (triples a b c)
(cons-stream
(list (stream-car a) (stream-car b) (stream-car c))
(interleave
(stream-map (lambda (pairs) (cons (stream-car a) pairs))
(pairs b (stream-cdr c)))
(triples (stream-cdr a) (stream-cdr b) (stream-cdr c)))))
(define (pythagorean? a b c)
(= (+ (* a a) (* b b)) (* c c)))
(define pythagorean-triples
(stream-filter (lambda (ts) (apply pythagorean? ts))
(triples integers integers integers)))
(assert (stream-ref pythagorean-triples 1) '(6 8 10))
2021-01-07 20:48:38 +01:00
(display "\nex-3.70 - pairs-weighted\n")
(define (merge-weighted weight s1 s2)
(cond ((stream-null? s1) s2)
((stream-null? s2) s1)
(else
(let ((s1car (stream-car s1))
(s2car (stream-car s2)))
(cond ((< (apply weight s1car) (apply weight s2car))
(cons-stream s1car (merge-weighted weight (stream-cdr s1) s2)))
((> (apply weight s1car) (apply weight s2car))
(cons-stream s2car (merge-weighted weight s1 (stream-cdr s2))))
(else
(cons-stream
s1car
(cons-stream
s2car
(merge-weighted weight (stream-cdr s1)
(stream-cdr s2))))))))))
(define (pairs-weighted weight s t)
(cons-stream
(list (stream-car s) (stream-car t))
(merge-weighted
weight
(merge-weighted
weight
(stream-map (lambda (x) (list (stream-car s) x))
(stream-cdr t))
(stream-map (lambda (x) (list x (stream-car t)))
(stream-cdr s)))
(pairs-weighted weight (stream-cdr s) (stream-cdr t)))))
(define int-pairs-a
(stream-filter
(lambda (pair) (apply <= pair))
(pairs-weighted + integers integers)))
(assert (take 3 int-pairs-a)
'((1 1) (1 2) (1 3)))
(define integers-b
(stream-filter
(lambda (n) (not (or (= (remainder n 2) 0)
(= (remainder n 3) 0)
(= (remainder n 5) 0))))
integers))
(define int-pairs-b
(stream-filter
(lambda (pair) (apply <= pair))
(pairs-weighted
(lambda (a b) (+ (* 2 a) (* 3 b) (* 5 a b)))
integers-b integers-b)))
(assert (take 3 int-pairs-b)
'((1 1) (1 7) (1 11)))
(display "\nex-3.71 - ramanujan-numbers\n")
(define (ramanujan-value a b)
(+ (cube a) (cube b)))
(define ramanujan-canditates
(stream-map
(lambda (pair) (apply ramanujan-value pair))
(stream-filter (lambda (pair) (apply <= pair))
(pairs-weighted ramanujan-value integers integers))))
(define (ramanujan-numbers canditates)
(let ((a (stream-car canditates))
(b (stream-car (stream-cdr canditates))))
(if (= a b)
(cons-stream a (ramanujan-numbers (stream-cdr canditates)))
(ramanujan-numbers (stream-cdr canditates)))))
(assert (take 6 (ramanujan-numbers ramanujan-canditates))
'(1729 4104 13832 20683 32832 39312))
(display "\nex-3.72 - triple square-sum numbers\n")
(define (square-sum-weigth a b)
(+ (square a) (square b)))
(define (consume-equal-square-sums xs)
(let ((weight-first (apply square-sum-weigth (stream-car xs)))
(weight-second (apply square-sum-weigth (stream-car (stream-cdr xs))))
(pair-first (stream-car xs))
(pair-second (stream-car (stream-cdr xs))))
(if (= weight-first weight-second)
(cons (list weight-first pair-first) (consume-equal-square-sums (stream-cdr xs)))
(list (list weight-first pair-first)))))
(define (triple-square-sums)
(define (find xs)
(let ((sequence (consume-equal-square-sums xs)))
(if (not (= (length sequence) 3))
(find (stream-cdr xs))
(cons-stream
sequence
(find (drop (length sequence) xs))))))
(find
(stream-filter
(lambda (pair) (apply <= pair))
(pairs-weighted square-sum-weigth integers integers))))
(assert (car (car (car (take 1 (triple-square-sums)))))
325)
2021-01-07 18:14:27 +01:00