SICP/ex-3_63-72.scm

(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)