SICP演習問題3.67~3.72

もうちょっとましな名前をつけられないかなー。

;;exercise3.67
(define (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))) ;xが前
                 (stream-cdr s)))
     (pairs (stream-cdr s) (stream-cdr t)))))

(stream-ref-print (pairs integers integers) 20)

;;exercise3.68
;;cons-streamを使わないためcdrの評価が行われ, pairsを呼び出すので無限ループになる
;(define (pairs s t)
;  (interleave
;   (stream-map (lambda (x) (list (stream-car s) x))
;               t)
;   (pairs (stream-cdr s) (stream-cdr t))))

;;exercise3.69
;;これだと無限に対応していない
;;(1 1 **)の組合せが終わらないため, (1 2 **)の組合せが出てこない
(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)) ;consに注意
                (stream-map (lambda (y) (list (stream-car t) y))
                            (stream-cdr u)))
    (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))

;;解答確認1
(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)
              (stream-cdr u)))))

;;解答確認2
(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))
                  (pairs (stream-cdr t) (stream-cdr u)))
      (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))

(stream-ref-print (triples integers integers integers) 10)
(stream-ref-print (pairs integers integers) 10)

;;解答確認
;;これを実行するとmemoの効果が現れる
(define triples-of-integers (triples integers integers integers))
(define pythagoras
  (stream-filter (lambda (triple)
                         (= (+ (square (car triple)) (square (cadr triple))) (square (caddr triple))))
                 triples-of-integers))

(stream-ref-print pythagoras 5)

;;exercise3.70
(define (merge-weight s1 s2 weight)
  (cond [(stream-null? s1) s2]
        [(stream-null? s2) s1]
        [else
         (let ((s1car (stream-car s1))
               (s2car (stream-car s2)))
           (if (< (apply weight s1car) (apply weight s2car))  ;apply 対のweightを求めるので
               (cons-stream s1car (merge-weight (stream-cdr s1) s2 weight))
               (cons-stream s2car (merge-weight s1 (stream-cdr s2) weight))))]))

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

;;a
(define weight-func1 (lambda (x y) (+ x y)))
(stream-ref-print (weighted-pairs integers integers weight-func1) 10)

;;b
(define weight-func2 (lambda (x y) (+ (* 2 x) (* 3 y) (* 5 x y))))
(stream-ref-print (weighted-pairs integers integers weight-func2) 10)

;;exercise3.71
(define (cube x) (* x x x))
(define weight-func-of-cube (lambda (x y) (+ (cube x) (cube y))))
(define pairs-with-weighted-cube
  (weighted-pairs integers integers weight-func-of-cube))
(stream-ref-print pairs-with-weighted-cube 10)

;;exercise3.71
(define (cube x) (* x x x))
(define weight-func-of-cube (lambda (x y) (+ (cube x) (cube y))))
(define pairs-with-weighted-cube
  (weighted-pairs integers integers weight-func-of-cube))
(stream-ref-print pairs-with-weighted-cube 10)

(define (ramanujan stream)
  (let* ((first (stream-car stream))
        (second (stream-car (stream-cdr stream)))
        (first-weight (apply weight-func-of-cube first))
        (second-weight (apply weight-func-of-cube second)))
    (cond [(= first-weight second-weight)
           (print first second)
           (cons-stream first-weight
                        (ramanujan (stream-cdr stream)))]
          [else
           (ramanujan (stream-cdr stream))])))
(stream-ref-print (ramanujan pairs-with-weighted-cube) 6)

;;exercise3.72
(define weight-func-of-square (lambda (x y) (+ (square x) (square y))))
(define pairs-with-weighted-square
  (weighted-pairs integers integers weight-func-of-square))
(stream-ref-print pairs-with-weighted-square 2)

(define (triple-pair-of-square stream)
  (let* ((first (stream-car stream))
         (pre-second (stream-cdr stream))
         (second (stream-car pre-second))
         (pre-third (stream-cdr pre-second))
         (third (stream-car pre-third))
         (first-weight (apply weight-func-of-square first))
         (second-weight (apply weight-func-of-square second))
         (third-weight (apply weight-func-of-square third)))
    (cond [(= first-weight second-weight third-weight)
           (print first second third)
           (cons-stream first-weight
                        (triple-pair-of-square (stream-cdr stream)))]
          [else
           (triple-pair-of-square (stream-cdr stream))])))
(stream-ref-print (triple-pair-of-square pairs-with-weighted-square) 5)