Skip to content

Instantly share code, notes, and snippets.

@mururu mururu/3.53.scm
Last active Dec 28, 2015

Embed
What would you like to do?
a
(load "./stream.scm")
(define (average x y) (/ (+ x y) 2))
(define (sqrt-improve guess x)
(average guess (/ x guess)))
(define (sqrt-stream x)
(define guesses
(cons-stream 1.0
(stream-map (lambda (guess)
(sqrt-improve guess x))
guesses)))
guesses)
;(display-stream (sqrt-stream 2))
(define (pi-summands n)
(cons-stream (/ 1.0 n)
(stream-map - (pi-summands (+ n 2)))))
(define pi-stream
(scale-stream (partial-sums (pi-summands 1)) 4))
;(display-stream pi-stream)
(define (square x) (* x x))
(define (euler-transform s)
(let ((s0 (stream-ref s 0))
(s1 (stream-ref s 1))
(s2 (stream-ref s 2)))
(cons-stream (- s2 (/ (square (- s2 s1))
(+ s0 (* -2 s1) s2)))
(euler-transform (stream-cdr s)))))
;; okasii
;(display-stream (euler-transform pi-stream))
(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)))
;; motto okasii
;(display-stream (accelerated-sequence euler-transform pi-stream))
(define (integers-starting-from n)
(cons-stream n (integers-starting-from (+ n 1))))
(define integers (integers-starting-from 1))
(define (interleave s1 s2)
(if (stream-null? s1)
s2
(cons-stream (stream-car s1)
(interleave s2 (stream-cdr s1)))))
(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)))))
;(display-stream (pairs integers integers))
; 局所変数を用いないとメモ化されない。
; memo-procを使わないなら効率はおよそかわらない。
(define (sqrt-stream x)
(cons-stream 1.0
(stream-map (lambda (quess)
(sqrt-improve guess x))
(sqrt-stream x))))
(load "./3.53.scm")
(define (abs x)
(if (>= x 0)
x
(* -1 x)))
(define (stream-limit s error-limit)
(let ((s0 (stream-ref s 0))
(s1 (stream-ref s 1)))
(if (< (abs (- s0 s1)) error-limit)
s1
(stream-limit (stream-cdr s) error-limit))))
(define (sqrt x tolerance)
(stream-limit (sqrt-stream x) tolerance))
(print (sqrt 2 0.000000001))
(load "./3.53.scm")
(define (ln2-summands n)
(cons-stream (/ 1.0 n)
(stream-map - (ln2-summands (+ n 1)))))
(define ln2-stream
(partial-sums (ln2-summands 1)))
(display-stream ln2-stream)
;(x,y)
;(1,1) = 1
;(1,a) = 2*(a-1)
;(a,a) = 2^a - 1
;(a,b) = (2^(x-1))*(1+2(y-x))-1
(define (pow x y)
(if (= y 0)
1
(* x (pow x (- y 1)))))
(define (pairs-value x y)
(cond
((and (= x 1) (= y 1)) 1)
((= x 1) (* 2 (- y 1)))
((= x y) (- (pow 2 x) 1))
(else (- (* (pow 2 (- x 1)) (+ 1 (* 2 (- y x)))) 1))))
(print (pairs-value 3 3))
(load "./3.53.scm")
(define (integers-starting-from-raise n)
(if (> n 100)
(raise "stop")
(cons-stream n (integers-starting-from-raise (+ n 1)))))
(define integers-r (integers-starting-from-raise 1))
;(display-stream (pairs integers-r integers-r))
(load "./3.53.scm")
(define (pairs-a s t)
(cons-stream
(list (stream-car s) (stream-car t))
(interleave
(stream-map (lambda (x) (list (stream-car s) x))
(stream-cdr t))
(interleave
(pairs (stream-cdr s) (stream-cdr t))
(pairs (stream-cdr t) s)))))
(display-stream (pairs-a integers integers))
(load "./3.53.scm")
(define (pairs-3 s t)
(interleave
(stream-map (lambda (x) (list (stream-car s) x))
t)
(pairs-3 (stream-cdr s) (stream-cdr t))))
(display-stream (pairs-3 integers integers))
(define (divisible? x y) (= (remainder x y) 0))
(define the-empty-stream '())
(define (stream-null? stream)
(eq? the-empty-stream stream))
(define (memo-proc proc)
(let ((already-run? false)
(result false))
(lambda ()
(if (not already-run?)
(begin (set! result (proc))
(set! already-run? true)
result)
result))))
(define-syntax delay
(syntax-rules ()
((_ x) (lambda () x))))
(define (force proc)
(proc))
(define-syntax cons-stream
(syntax-rules ()
((cons-stream head tail)
(cons head (delay tail)))))
(define (stream-car stream)
(car stream))
(define (stream-cdr stream)
(force (cdr stream)))
(define (stream-ref stream n)
(if (= n 0)
(stream-car stream)
(stream-ref (stream-cdr stream) (- n 1))))
;(define (stream-map proc stream)
; (if (stream-null? stream)
; '()
; (cons-stream (proc (stream-car stream))
; (stream-map proc (stream-cdr stream)))))
;; ex3.50 p225
(define (stream-map proc . arguments)
(if (null? (car arguments))
the-empty-stream
(cons-stream
(apply proc (map stream-car arguments))
(apply stream-map
(cons proc (map stream-cdr arguments))))))
(define (stream-for-each proc stream)
(if (stream-null? stream)
'done
(begin (proc (stream-car stream))
(stream-for-each proc (stream-cdr stream)))))
(define (stream-take stream n)
(if (= n 0)
'()
(cons-stream (stream-car stream)
(stream-take (stream-cdr stream) (- n 1)))))
(define (display-line x)
(newline)
(display x))
(define (display-stream stream)
(stream-for-each display-line stream))
(define (stream-enumerate-interval low high)
(if (> low high)
the-empty-stream
(cons-stream
low
(stream-enumerate-interval (+ low 1) high))))
(define (stream-filter pred stream)
(cond ((stream-null? stream) the-empty-stream)
((pred (stream-car stream))
(cons-stream (stream-car stream)
(stream-filter pred
(stream-cdr stream))))
(else (stream-filter pred (stream-cdr stream)))))
(define (integers-starting-from n)
(cons-stream n (integers-starting-from (+ n 1))))
(define integers (integers-starting-from 1))
(define (sieve stream)
(cons-stream
(stream-car stream)
(sieve (stream-filter
(lambda (x)
(not (divisible? x (stream-car stream))))
(stream-cdr stream)))))
(define primes (sieve (integers-starting-from 2)))
(define (add-streams s1 s2)
(stream-map + s1 s2))
(define (mul-streams s1 s2)
(stream-map * s1 s2))
(define (scale-stream stream factor)
(stream-map (lambda (x) (* factor x)) stream))
;;; p230 ex3.54
(define factorials (cons-stream 1 (mul-streams factorials (integers-starting-from 2))))
;;; p230 ex3.55
(define (partial-sums stream)
(let ((sum 0))
(stream-map (lambda (x)
(set! sum (+ sum x))
sum)
stream)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.