299 lines
8.7 KiB
Scheme
299 lines
8.7 KiB
Scheme
(load "shared/util.scm")
|
|
|
|
(define (pi-summands n)
|
|
(cons-stream (/ 1. n)
|
|
(stream-map - (pi-summands (+ n 2)))))
|
|
|
|
(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")
|
|
|
|
(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
|
|
|
|
(display "\nex-3.67 - all-pairs\n")
|
|
|
|
(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))
|
|
|
|
(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)
|
|
|