(sicp45)m3.60~m3.72

面倒なのでstream-*が@*になってます。

• stream-map -> @map
• stream->list -> @>list

(use my-stream)

;; m3.60
;;a0, a1, a2,...
;;
(define (mul-series s1 s2)
  (@cons (* (@car s1) (@car s2)) 
         (@add (mul-series s1 (@cdr s2))
               (@scale (@cdr s1) (@car s2)))))

;;個人的な内容
(define @mul mul-series)

(@>list
 (@add
  (@mul sine-series sine-series)
  (@mul cosine-series cosine-series)))
;; 45:user> => (1 0 0 0 0 0 0 0 0 0)

;; m3.61
;; S * X = 1	(if X = 1/S then S*X = S/S = 1)
;; (1 + Sr) * X = 1
;; X + Sr * X = 1
;; X = 1 - Sr * X

(define (invert-unit-series S)
  (let ((Sr (@cdr S)))
    (@cons 1 (@map (cut * -1 <>)  (mul-series (invert-unit-series S) Sr)))))
;;個人的な内容
(define @invert invert-unit-series)

;; m3.62
;; s1 / s2
(define (div-series s1 s2)
  (if (zero? (@car s2))
      (error "division by 0")
      (@mul s1 (@invert s2))))
;;個人的な内容
(define @div div-series)

(define tangent-series ;;tan = sin / cos
  (@div sine-series cosine-series))
(@>list tangent-series)
;; 67:user> => (0 1 0 1/3 0 2/15 0 17/315 0 62/2835)

;;==よく分からないのでべき級数の和を求める関数を作ってみよう
(define (sum-series series x . n)
  ;;streamを使う意味がなくなってしまっているけど…
  (let* ((times (get-optional n 10))
        (seq (reverse (@>list series times))))
    (fold (lambda (e re) (+ e (* re x))) 0 seq)))

(use math.const) ;;piを使いたい。

;;とりあえずあっているか確認する関数
(define (check series)
  (let ((seq (map (cut * pi <>) (list 0 0.5 1 1.5 2))))
    (map (cut sum-series series <> 100) seq)))

(check sine-series)
;; 87:user> => (0 1.0 0.0 -1.0000000000000004 0.0)
(check cosine-series)
;; 89:user> => (1 0.0 -1.0000000000000004 -1.5543122344752192e-15 1.0)
;;多分あっている。(tangentはどうだろ？）


;;あー、そう言えばtangentって漸近線だったような気がする。
;;(sum-series tangent-series (/ pi 4) 100)
;; 95:user> => 0.9999999999999999
;; あっているのかな？


(define (sqrt-improve guess x)
  (average guess (/ x guess)))
(define (average x y)
  (/ (+ x y) 2))
;;
(define (sqrt-stream x)
  (define guesses
    (@cons 1.0
           (@map (cut sqrt-improve <> x) guesses)))
  guesses)
(@>list (sqrt-stream 2))
;; (1.0 1.5 1.4166666666666665 1.4142156862745097 1.4142135623746899 1.414213562373095 1.414213562373095 1.414213562373095 1.414213562373095 1.414213562373095)

(define (pi-summands n)
  (@cons (/ 1.0 n) (@map - (pi-summands (+ n 2)))))

(define pi-stream
         (@scale (partial-sums (pi-summands 1)) 4))

(@>list pi-stream)
;; 15:user> => (4.0 2.666666666666667 3.466666666666667 2.8952380952380956 3.3396825396825403 2.9760461760461765 3.2837384837384844 3.017071817071818 3.2523659347188767 3.0418396189294032)

;; sequence accelerator
(define (square x) (* x x))

(define (euler-transform s)
  (let ((s0 (@ref s 0))
        (s1 (@ref s 1))
        (s2 (@ref s 2)))
    (@cons (- s2 (/ (square (- s2 s1))
                    (+ s0 (* -2 s1) s2)))
           (euler-transform (@cdr s)))))

(@>list (euler-transform pi-stream))
;; 18:user> => (3.166666666666667 3.1333333333333337 3.1452380952380956 3.13968253968254 3.1427128427128435 3.1408813408813416 3.142071817071818 3.1412548236077655 3.1418396189294033 3.141406718496503)
	;;確かに収束が早くなっている。

;;tableau
(define (make-tableau transform s)
  (@cons s (make-tableau transform
                         (transform s))))
(define (accelerated-sequence transform s)
  (@map @car (make-tableau transform s)))
(@>list (accelerated-sequence euler-transform
                              pi-stream))
;; 21:user> => (4.0 3.166666666666667 3.142105263157895 3.141599357319005 3.1415927140337785 3.1415926539752927 3.1415926535911765 3.141592653589778 3.1415926535897953 3.141592653589795)

;; m3.63
;; streamのcdr部分に位置するところが手続きなので、stream-cdrを呼ぶ度に計算が必要になっている。
;; その部分の手続きを同等な値を返すstreamにすれば、memo-procによって再計算が必要なくなる。
;; delayがmemo-procを使っていなければ、速度は変わらない。

;; m3.55をやっている時には気づかなかったけど…
	;;こうするべきだった＞＜
(define (partial-sums2 s)
  (define sums
    (@cons (@car s) (@add (@cdr s) sums)))
  sums)

;; (time (@ref (partial-sums integers) 1000))
;; (time (@ref (partial-sums2 integers) 1000))
;; 36:user> ;(time (|@ref| (partial-sums integers) 1000))
;; ; real   4.867
;; ; user   4.740
;; ; sys    0.090
;; => 501501
;; 37:user> ;(time (|@ref| (partial-sums2 integers) 1000))
;; ; real   0.009
;; ; user   0.000
;; ; sys    0.000
;; => 501501


;; m3.64
	;;これは簡単
(define (stream-limit s tolerance)
  (let loop ((state (@car s)) (next-stream (@cdr s)))
    (let1 next (@car next-stream)
      (if (> tolerance (abs (- state next)))
          next
          (loop next (@cdr next-stream))))))
(define (sqrt x tolerance)
  (stream-limit (sqrt-stream x) tolerance))
(sqrt 2 0.000001)
;; 39:user> => 1.414213562373095

;; m3.65
(define ones  (@cons 1 ones))

(define ln-stream
  (partial-sums2 (@map (lambda (x y)
                         (/ x (if (even? y) (- y) y)))
                       ones
                       integers)))
;; pi-streamと同様にこんな風にも書ける
;; (define (ln2-summands n)
;;   (@cons (/ 1 n) (@map - (ln2-summands(+ n 1)))))
;; (define ln2-stream
;;   (partial-sums2 (ln2-summands 1)))

;; (time (@ref ln-stream 100))
;; (time (@ref ln2-stream 100))
;; ; real   0.007
;; ; user   0.000
;; ; sys    0.000
;; => 4915662254209446955930873321941265013941117/7041757898200960193617914702466542659236800
;; 19:user> ;
;; ; real   0.051
;; ; user   0.040
;; ; sys    0.000
;; => 4915662254209446955930873321941265013941117/7041757898200960193617914702466542659236800

(@>list ln-stream)
;; 20:user> => (1 1/2 5/6 7/12 47/60 37/60 319/420 533/840 1879/2520 1627/2520)
(@>list (euler-transform ln-stream))
;; 21:user> => (7/10 29/42 25/36 457/660 541/780 97/140 9901/14280 33181/47880 1747/2520 441871/637560)
;;(@>list (accelerated-sequence euler-transform ln-stream)) 
	;;返ってこない。何でだろう？
	;;あー、わかった。表示される値が異様におおいんだ。
(@>list (accelerated-sequence euler-transform ln-stream) 6)
;; 30:user> => (1 7/10 165/238 380522285/548976276 755849325680052062216639661/1090460049411856348776491380 318738655178511632543822227346530350595387994474669640697143248267438214457834012964733985868157066661175569469393/459842677096914359400941379802880332404679211833600390612039625007123278498884893986945137648853585966630779010940)
	;;有理数 -> 実数ってどうすればいいんだろう？分かりません＞＜
	;;数字を表示するなら #i2/3　でできるけど…


;;initifiate-stream
(define (interleave s1 s2)
  (if (@null? s1)
      s2
      (@cons (@car s1)
             (interleave s2 (@cdr s1)))))

;; (@filter (lambda (pair)
;;            (prime? (+ (car pair) (cadr pair))))
;;          int-pairs)

(define (pairs s t)
  (@cons
   (list (@car s) (@car t))
   (interleave
    (@map (lambda (x) (list (@car s) x))
          (@cdr t))
    (pairs (@cdr s) (@cdr t)))))

;; m3.66
;;n n)とい風に両方とも同じになるところでわけてみると何か分かるかもしれない。

(define (f seq)
  (dolist (e seq)
    (when (= (car e) (cadr e))
        (newline))
    (display e)
    (display " ")))
(f (@>list (pairs integers integers) 100))


;; 43:user> 
;; (1 1) (1 2) 
;; (2 2) (1 3) (2 3) (1 4) 
;; (3 3) (1 5) (2 4) (1 6) (3 4) (1 7) (2 5) (1 8) 
;; (4 4) (1 9) (2 6) (1 10) (3 5) (1 11) (2 7) (1 12) (4 5) (1 13) (2 8) (1 14) (3 6) (1 15) (2 9) (1 16) 
;; (5 5) (1 17) (2 10) (1 18) (3 7) (1 19) (2 11) (1 20) (4 6) (1 21) (2 12) (1 22) (3 8) (1 23) (2 13) (1 24) (5 6) (1 25) (2 14) (1 26) (3 9) (1 27) (2 15) (1 28) (4 7) (1 29) (2 16) (1 30) (3 10) (1 31) (2 17) (1 32) 
;; (6 6) (1 33) (2 18) (1 34) (3 11) (1 35) (2 19) (1 36) (4 8) (1 37) (2 20) (1 38) (3 12) (1 39) (2 21) (1 40) (5 7) (1 41) (2 22) (1 42) (3 13) (1 43) (2 23) (1 44) (4 9) (1 45) (2 24) (1 46) (3 14) (1 47) (2 25) (1 48) (6 7) (1 49) (2 26) (1 50) (3 15) (1 51) => ()


(define (g n)
 (reverse (fold (lambda (x it)
          (if (= (car x) (cadr x))
              (cons (list x) it)
              (acons x (car it) (cdr it))))
        '()
        (@>list (pairs integers integers) n))))

(map length (g 255))
;; 80:user> => (2 4 8 16 32 64 128 1)
;; これなら、((1 1) ((1 2) (2 2))) という様に集めた方がよかったかもしれない。

(define (pref n) ;;楽に表示する様に
  (@ref (pairs integers integers) (- n 1)))

(define (f1 n) ;;(1, n)
  (* 2 (- 100 1)))

(define (f2 n) ;;(n, n+1)
	;; An=(n, n+1)
	;; A1=2
	;; An+1=An+(2**(n-2))*3
  (let loop ((c 1) (re 2))
    (if (= c n)
        re
        (loop (+ c 1) (+ re (* 3 (expt 2 (- c 1))))))))

(define (f3 n)
  (- (expt 2 n) 1))

;; (1,100)までに(f1 100) ;; 123:user> => 198
(pref (f1 100)) 
;; 7:user> => (1 100)

;; (99,100)までに(f2 99) ;; 124:user> => 950737950171172051122527404031
(map (lambda (n) (cons (list n) (pref (f2 n)))) (iota 10 2))
;; 10:user> => (((2) 2 3) ((3) 3 4) ((4) 4 5) ((5) 5 6) ((6) 6 7) ((7) 7 8) ((8) 8 9) ((9) 9 10) ((10) 10 11) ((11) 11 12))

;; (100,100)までに(f3 100) ;; 125:user> => 1267650600228229401496703205375
(map (lambda (n) (cons (list n) (pref (f3 n)))) (iota 10 2))
;; 11:user> => (((2) 2 2) ((3) 3 3) ((4) 4 4) ((5) 5 5) ((6) 6 6) ((7) 7 7) ((8) 8 8) ((9) 9 9) ((10) 10 10) ((11) 11 11))


;;m3.67
(define (pairs s t)
  (@cons
   (list (@car s) (@car t))
   (interleave
    (interleave
     (@map (lambda (x) (list (@car s) x))
           (@cdr t))
     (@map (lambda (x) (list x (@car t)))
           (@cdr s)))
    (pairs (@cdr s) (@cdr t)))))

(@>list (pairs integers integers) 20)
;; 16:user> => ((1 1) (1 2) (2 2) (2 1) (2 3) (1 3) (3 3) (3 1) (3 2) (1 4) (3 4) (4 1) (2 4) (1 5) (4 4) (5 1) (4 2) (1 6) (4 3) (6 1))

;; m3.68
(define (louis-pairs s t)
  (interleave
   (@map (lambda (x) (list (@car s) x))
         t)
   (louis-pairs (@cdr s) (@cdr t))))

;; (@>list (louis-pairs integers integers))
	;;無限ループ
	;;interleaveは一般的な手続きなので中の引数が遅延されずに評価されつづけてしまう。

;; m3.69
	;;pairにもうひとつ足せばいい。
(define (triples s t u)
  (@cons
   (list (@car s) (@car t) (@car u))
   (interleave
    (@map (lambda (x) (cons (@car s) x))
          (pairs (@cdr t) (@cdr u)))
    (triples (@cdr s) (@cdr t) (@cdr u)))))

(define Pythagoras-stream
  (@filter (lambda (e)
             (let ((i (car e)) (j (cadr e)) (k (caddr e)))
               (= (+ (square i) (square j))
                  (square k))))
           (triples integers integers integers)))

;; (@>list Pythagoras-stream 4)
;; 2:user> => ((3 4 5) (6 8 10) (5 12 13) (9 12 15))                     


;; m3.70
	;; 普通に比較の時にweightedを使う様にすればいいのかな？
;; (define (merge-weighted weighted s1 s2)
;;   (cond ((@null? s1) s2)
;;         ((@null? s2) s1)
;;         (else
;;          (let ((s1car (@car s1))
;;                (s2car (@car s2)))
;;            (cond ((< (weighted s1car) (weighted s2car))
;;                   (@cons s1car (merge-weighted weighted (@cdr s1) s2)))
;;                  ((> (weighted s1car) (weighted s2car))
;;                   (@cons s2car (merge-weighted weighted s1 (@cdr s2))))
;;                  (else
;;                   (@cons s1car
;;                                (merge-weighted weighted
;;                                       (@cdr s1)
;;                                       (@cdr s2)))))))))
;;あー違う。重みが同じでも違うものが存在する。 (1 3) (2 2)とか（(i+j)のときの）

(define (merge-weighted weighted s1 s2)
  (cond ((@null? s1) s2)
        ((@null? s2) s1)
        (else
         (let ((s1car (@car s1))(s2car (@car s2)))
           (if (<= (weighted s1car) (weighted s2car))
                   (@cons s1car (merge-weighted weighted (@cdr s1) s2))
                   (@cons s2car (merge-weighted weighted s1 (@cdr s2))))))))

(define (weighted-pairs weighted s t)
  (@cons
   (list (@car s) (@car t))
   (merge-weighted weighted
                   (@map (lambda (x) (list (@car s) x))
                         (@cdr t))
                   (weighted-pairs weighted (@cdr s) (@cdr t)))))

;;a.
(define (f proc)
  (@>list (weighted-pairs (lambda (e)
                            (let ((i (car e)) (j (cadr e)))
                              (+ i j))) integers integers)))
(f (lambda (i j) (+ i j)))
;; 10:user> => ((1 1) (1 2) (1 3) (2 2) (1 4) (2 3) (1 5) (2 4) (3 3) (1 6))

;; b.
(define b-answer
  (let ((s (@filter (lambda (x)
                      (not (or (= 0 (remainder x 2))
                               (= 0 (remainder x 3))
                               (= 0 (remainder x 5)))))
                    integers)))
    (weighted-pairs (lambda (e)
                      (let ((i (car e)) (j (cadr e)))
                        (+ (* 2 i) (* 3 j) (* 5 i j))))
                    s s)))
(@>list b-answer)
;; 20:user> => ((1 1) (1 7) (1 11) (1 13) (1 17) (1 19) (1 23) (1 29) (1 31) (7 7))


(use util.match) ;;パターンマッチが使いたい。

;; m.3.71
(define (find-ramanujan-number n)
  (let* ((cube (lambda (x) (* x x x)))
         (weight (lambda (e)
                   (let ((i (car e)) (j (cadr e)))
                     (+ (cube i) (cube j))))))
    (define (@filter2 pred? s)
      ;;そう言えば、streamだし停止条件いらないかも？
      (let ((this (@car s)) (next (@car (@cdr s))))
        (if (pred? this next)
            (@cons this
                   (@cons next
                          (@filter2 pred? (@cdr s))))
            (@filter2 pred? (@cdr s)))))
    (define (layout l)
      (match l
        ((a b . xs) (cons (list (weight a) a b) (layout xs)))
        (_ '())))
    (let1 stream 
        (@filter2  (lambda (sn sn+1)
                   ( = (weight sn) (weight sn+1)))
                   (weighted-pairs weight integers integers))
      (layout (@>list stream (* 2 n))))))

(find-ramanujan-number 2)
;; 65:user> => ((1729 (1 12) (9 10)) (4104 (2 16) (9 15)))
(map car (find-ramanujan-number 6))
;; 66:user> => (1729 4104 13832 20683 32832 39312)

;;@filter2の部分がちょっと無駄かもしれない。
	;;layoutと処理を混ぜてしまっても良かったかも？
	;;letのstreamで出てくる数が何かおかしいし。

;;m3.73
	;;@filter2を一般化できれば…
	;;綺麗に一般化できないなー
(define (@filter3 pred? s)
  (let ((next (@cdr s)))
    (if (pred? (@car s) (@car next) (@car (@cdr next)))
        (@cons (@car s)
               (@filter3 pred? (@cdr s)))
        (@filter3 pred? (@cdr s)))))

(define 3kinds-square-sum
  (let* ((square (lambda (x) (* x x)))
         (weight (lambda (e) (+ (square (car e)) (square (cadr e))))))
    (@map weight 
          (@filter3 (lambda (sn sn+1 sn+2)
                      (let1 seed (weight sn)
                        (and (= (weight sn+1) seed)
                             (= (weight sn+2) seed))))
                    (weighted-pairs weight
                                    integers
                                    integers)))))
(@>list 3kinds-square-sum)
76:user> => (325 425 650 725 845 850 925 1025 1105 1105)