SICP 問題 3.70

;; mergeを参考にして重みをつけてmerge-weightedを定義する
(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)))
                (let ((w1 (weight s1car))
                      (w2 (weight s2car)))
                  (cond
                   ((< w1 w2)
                    (cons-stream s1car
                                 (merge-weighted (stream-cdr s1) s2 weight)))
                   (else
                    (cons-stream s2car
                                 (merge-weighted s1 (stream-cdr s2) weight)))))))))

;; pairsを参考にweighted-pairsを定義する
(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 (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)))

(define i+j (weighted-pairs integers integers (lambda (x) (+ (car x) (cadr x)))))

(define 2i+3j+5ij
  (weighted-pairs integers integers
                  (lambda (x) (+ (* 2 (car x))
                                 (* 3 (cadr x))
                                 (* 5 (car x) (cadr x))))))

;; 重みづけがちゃんと機能しているかを確認する
(define (stream-head-weight s n weight)
  (let iter ((s s)
             (n n))
    (if (zero? n)
        'done
        (begin
          (display (stream-car s))
          (display " : ")
          (display (weight (stream-car s)))
          (newline)
          (iter (stream-cdr s) (- n 1))))))

gosh> (stream-head-weight i+j 20 (lambda (x) (+ (car x) (cadr x))))
(1 1) : 2
(1 2) : 3
(2 2) : 4
(1 3) : 4
(2 3) : 5
(1 4) : 5
(3 3) : 6
(2 4) : 6
(1 5) : 6
(3 4) : 7
(2 5) : 7
(1 6) : 7
(4 4) : 8
(3 5) : 8
(2 6) : 8
(1 7) : 8
(4 5) : 9
(3 6) : 9
(2 7) : 9
(1 8) : 9
done
gosh> (stream-head-weight 2i+3j+5ij 20 (lambda (x) (+ (* 2 (car x))
                                                      (* 3 (cadr x))
                                                      (* 5 (car x) (cadr x)))))
(1 1) : 10
(1 2) : 18
(1 3) : 26
(2 2) : 30
(1 4) : 34
(1 5) : 42
(2 3) : 43
(1 6) : 50
(2 4) : 56
(1 7) : 58
(3 3) : 60
(1 8) : 66
(2 5) : 69
(1 9) : 74
(3 4) : 78
(2 6) : 82
(1 10) : 82
(1 11) : 90
(2 7) : 95
(3 5) : 96
done