demo2.liscript

(print \n "ДЕМО: бесконечные списки - потоки:" \n)

; макрос отложенных вычислений, возвращает нульарную лямбду
  НЕ мемоизированный delay
;
(defmacro delay (expr) (lambda () expr))

; мемоизированный delay-memo
;
(defn memo-proc (proc)
    (def already-run? false result false)
    (lambda ()
        (cond already-run? result
              ((set! result (proc) already-run? true) result) )))
(defmacro delay-memo (expr) (memo-proc (lambda () expr)))

; функция их возобновления, удачное сочетание скобок:
  если передадим нульарную лямбду - вычислит ее,
  если другое значение - просто вернет его
;
(defn force (promise) (promise))

(def a (delay (+ 7 6)))
(print "запомнили отложенное вычисление: " a)
(print "вычислили результат: " (force a) \n)

; макрос-конструктор потока, чтобы delay-memo каждый раз не писать
;
(defmacro s-cons (x y) (cons x (delay-memo y)))

; функция берет хвост потока - если функция, то вычисляет ее,
  воспринимая, как порождающую поток. Плохо, функции в поток не засунешь.
;
(defn s-tail (stream) (def t (cdr stream) e (car t)) (cond (func? e) (force e) t))

; поток натуральных чисел, начиная с заданного
;
(defn int-from (n) (s-cons n (int-from (+ n 1))))
(def nats (int-from 1))
(print "поток натуральных чисел с 1: " \n nats \n)
(print "хвост этого потока: " \n (s-tail nats) \n)

; потоковые аналоги списковых функций
;
(defn s-take (n l)
    (cond (null? l) nil
          (> n 0) (cons (car l) (s-take (- n 1) (s-tail l)))
          nil))
(defn stream-ref (n s) (cond (= 0 n) (car s) (stream-ref (- n 1) (s-tail s)) ))
(defn s-map (f s) (s-cons (f (car s)) (s-map f (s-tail s))) )
(defn s-filter (f s)
    (cond (f (car s)) (s-cons (car s) (s-filter f (s-tail s)))
                                      (s-filter f (s-tail s)) ))
(defn s-zipwith (f s1 s2)
    (s-cons (f (car s1) (car s2)) (s-zipwith f (s-tail s1) (s-tail s2))))
(defn s-sum (s1 s2) (s-zipwith + s1 s2))

(print "первые 15 членов потока - суммы потоков чисел с 0 и со 100:")
(print (s-take 15 (s-sum (int-from 0) (int-from 100))) \n)

(def n 30)
; поток Фибоначчи - НЕ экспоненциальный расчет
;
(defn fibgen (a b) (s-cons a (fibgen b (+ a b))))
(def fibs (fibgen 0 1))
(print "первые " n " членов потока ряда Фибоначчи (НЕ экспоненциальный расчет):")
(print (s-take n fibs) \n)

; мемоизированный экспоненциальный расчет
;
(def fibsexp (s-cons 0 (s-cons 1 (s-sum (s-tail fibsexp) fibsexp))))
(print "первые " n " членов потока ряда Фибоначчи (мемоизированный экспоненциальный расчет):")
(print (s-take n fibsexp) \n)

; поток четных чисел
;
(def evens (s-filter (lambda (x) (= 0 (mod x 2))) (int-from 0)))
(print "первые 15 четных чисел:")
(print (s-take 15 evens) \n)

(def n 30)
; решето Эратосфена, поток простых чисел
;
(defn sieve (s)
    (def r (s-filter (lambda (x) (/= 0 (mod x (car s)))) (s-tail s)))
    (s-cons (car s) (sieve r)))
(def primes-Erat (sieve (int-from 2)))
(print "первые " n " простых чисел через решето Эратосфена:")
(print (s-take n primes-Erat) \n)

; поток простых чисел через гипотезу Бертрана
;
(def primes-Bert (s-cons 2 (s-filter prime? (int-from 3))))
(defn prime? (n)
    (defn square (n) (* n n))
    (defn iter (ps)
        (cond (> (square (car ps)) n) true
              (= 0 (mod n (car ps))) false
              (iter (s-tail ps)) ))
    (iter primes-Bert))
(print "первые " n " простых чисел через гипотезу Бертрана:")
(print (s-take n primes-Bert) \n)

; поток частичных сумм любого потока
;
(defn partial-sums (f s)
    (defn go (a s) (s-cons (f a (car s)) (go (f a (car s)) (s-tail s)) ))
    (go 0 s))
(print "частичные суммы натурального ряда:")
(print (s-take 20 (partial-sums + (int-from 1))) \n)

(def n 30)
; мердж и числа Хэмминга
;
(defn merge (s1 s2)
    (cond (null? s1) s2
          (null? s2) s1
          (< (car s1) (car s2)) (s-cons (car s1) (merge (s-tail s1) s2))
          (> (car s1) (car s2)) (s-cons (car s2) (merge s1 (s-tail s2)))
                                (s-cons (car s1) (merge (s-tail s1) (s-tail s2))) ))
(defn s-scale (k s) (s-map (lambda (x) (* k x)) s))
(def hamm (s-cons 1 (merge (s-scale 2 hamm) (merge (s-scale 3 hamm) (s-scale 5 hamm)) )))
(print "первые " n " чисел Хэмминга:")
(print (s-take n hamm) \n)

; интегрирование потоков - степенных рядов
  экспонента
;
(defn s-integrate (s)
    (defn go (n s) (s-cons (/ (car s) n) (go (+ n 1) (s-tail s)) ))
    (go 1.0 s))
(def s-exp (s-cons 1.0 (s-integrate s-exp)))
(print "ряд частичных сумм экспоненты от 1:")
(print (s-take 8 (partial-sums + s-exp)) \n)

; синус-косинус
;
(defn s-scale (k s) (s-map (lambda (x) (* k x)) s))
(def s-cos (s-cons 1.0 (s-integrate (s-scale -1 s-sin))))
(def s-sin (s-cons 0.0 (s-integrate s-cos)))
(print "ряд синуса 1:  " \n (s-take 10 (partial-sums + s-sin)) \n)
(print "ряд косинуса 1:" \n (s-take 10 (partial-sums + s-cos)) \n)

; поток приближений квадратного корня
;
(defn average (x y) (/ (+ x y) 2))
(defn sqrt-improve (guess x) (average guess (/ x guess)))
(defn sqrt-stream (x)
    (defn r () (s-map (lambda (guess) (sqrt-improve guess x)) (sqrt-stream x)))
    (s-cons 1.0 (r)))
(print "ряд приближений к квадратному корню из 16:")
(print (s-take 8 (sqrt-stream 16)) \n)

; приближение к числу пи
;
(defn pi-summands (n)
    (defn r () (s-map (lambda (x) (- 0 x)) (pi-summands (+ n 2))))
    (s-cons (/ 1.0 n) (r)))
(def pi-stream (s-scale 4.0 (partial-sums + (pi-summands 1))))
(print "ряд приближений к числу пи:")
(print (s-take 8 pi-stream) \n)

; трансформация Эйлера - ускоритель сходимости ряда
;
(defn euler-transform (s)
    (defn square (x) (* x x))
    (def s0 (stream-ref 0 s))
    (def s1 (stream-ref 1 s))
    (def s2 (stream-ref 2 s))
    (s-cons (- s2 (/ (square (- s2 s1)) (+ s0 (* -2 s1) s2))) (euler-transform (s-tail s))))
(print "ряд приближений к числу пи - однократное применение Эйлера:")
(print (s-take 8 (euler-transform pi-stream)) \n)

(defn make-tableau (t s) (s-cons s (make-tableau t (t s))))
(defn accelerated-sequence (s) (s-map car (make-tableau euler-transform s)))
(print "ряд приближений к числу пи - последовательное применение Эйлера:")
(print (s-take 8 (accelerated-sequence pi-stream)) \n)

(defn integral (delayed-integrand initial-value dt)
    (def int (s-cons initial-value
        (s-zipwith + (s-scale dt (force delayed-integrand)) int)))
    int)
(defn solve (f y0 dt)
    (def y  (integral (delay-memo dy) y0 dt))
    (def dy (s-map f y))
    y)
(print "какой-то непонятный диффур из SICP:")
(print (stream-ref 20 (solve (lambda (y) y) 1 0.01)) \n)

(print "Код данных примеров вы можете посмотреть в файле.")