Infinite stream implementation in Scheme

infinite_streams_in_scheme.scm

(define (force x)
  (x))

(define (stream-numbers-from n)
  (cons
    n
    (lambda () (stream-numbers-from (+ n 1)))))

(define (stream-multiples-of n)
  (stream-map
    (lambda (x) (* n x))
    (stream-numbers-from 1)))

(define (stream-constant-of x)
  (cons
    x
    (lambda () (stream-constant-of x))))

(define (stream-take-until predicate stream)
  (define (loop predicate accumulated rest)
    (let ((next-value (car rest)))
      (if (predicate next-value)
        (reverse (cons next-value accumulated))
        (loop predicate (cons next-value accumulated) (force (cdr rest))))))
  (loop predicate '() stream))

(define (stream-take stream n)
  (define (loop rest remaining-n accumulated)
    (if (<= remaining-n 0) (reverse accumulated)
      (let ((next-value (car rest)))
        (loop (force (cdr rest)) (- remaining-n 1) (cons next-value accumulated)))))
  (loop stream n '()))

(define (stream-drop stream n)
  (define (loop rest remaining-n)
    (if (<= remaining-n 0) rest
        (loop (force (cdr rest)) (- remaining-n 1))))
  (loop stream n))

(define (stream-map f stream)
  (cons
    (f (car stream))
    (lambda ()
      (stream-map
        f
        (force (cdr stream))))))

(define (stream-zip . streams)
  (define (stream-zip-two s1 s2)
    (let ((first (car s1))
          (second (car s2)))
      (cons
        (cons first second)
        (lambda ()
          (stream-zip-two
            (force (cdr s1))
            (force (cdr s2)))))))
  (define (loop rest-of-streams result)
    (if (null? rest-of-streams) result
      (let ((first-stream (car rest-of-streams)))
        (loop (cdr rest-of-streams) (stream-zip-two first-stream result)))))
  (loop streams (stream-constant-of '())))

(define (stream-merge-ordered ordering . streams)
  (define (stream-merge-two-ordered ordering s1 s2)
    (let ((first (car s1))
          (second (car s2)))
      (if (ordering first second)
        (cons
          first
          (lambda ()
            (stream-merge-two-ordered
              ordering
              (force (cdr s1))
              s2)))
        (cons
          second
          (lambda ()
            (stream-merge-two-ordered
               ordering
               s1
               (force (cdr s2))))))))
  (define (loop rest-of-streams result)
    (if (null? rest-of-streams) result
      (let ((first-stream (car rest-of-streams)))
        (loop (cdr rest-of-streams) (stream-merge-two-ordered ordering first-stream result)))))
  (loop (cdr streams) (car streams)))

; Usage
(define stream
  (stream-map
    (lambda (x) (* 5 x))
    (stream-numbers-from 1)))

(newline)
(display
  (stream-take-until
    (lambda (x) (>= x 10))
    stream))
(newline)

(newline)
(display
  (stream-take
    stream
    10))
(newline)

(newline)
(display
  (stream-take
    (stream-drop
       stream
       5)
    10))
(newline)

(newline)
(display
  (stream-take
    (stream-zip
      (stream-multiples-of 2)
      (stream-multiples-of 3)
      (stream-multiples-of 5))
    10))
(newline)

(newline)
(display
  (stream-take
    (stream-merge-ordered
      (lambda (x y) (< x y))
      (stream-multiples-of 2)
      (stream-multiples-of 3)
      (stream-multiples-of 5))
    15))
(newline)