Source

lazy-seq / lazy-seq.scm

Full commit
(module lazy-seq

(lazy-seq make-lazy-seq lazy-null
 lazy-seq? lazy-seq-realized? lazy-null? 
 lazy-seq->list list->lazy-seq lazy-list
 lazy-head lazy-tail lazy-length
 lazy-append lazy-reverse
 lazy-take lazy-drop lazy-ref
 lazy-take-while lazy-drop-while
 lazy-map lazy-filter lazy-each
 lazy-iterate lazy-repeat lazy-repeatedly
 lazy-numbers input-port->lazy-seq
 lazy-cycle lazy-append-map)

(import chicken scheme)
(use srfi-1 extras)

(define-record-type lazy-seq
  (%make-lazy-seq body value)
  lazy-seq?
  (body lazy-seq-body lazy-seq-body-set!)
  (value lazy-seq-value lazy-seq-value-set!))

(define-type lazy-seq
  (struct lazy-seq))

(define-type lazy-null
  lazy-seq)

(define-type lazy-body
  (or null (pair * lazy-seq)))

(: lazy-seq? (* --> boolean : lazy-seq))

(: make-lazy-seq ((-> (or lazy-body lazy-seq)) --> lazy-seq))
(define (make-lazy-seq body)
  (%make-lazy-seq body #f))

(define-syntax lazy-seq
  (syntax-rules ()
    ((_ body ...)
     (make-lazy-seq
      (lambda () body ...)))))

(define-record-printer (lazy-seq seq out)
  (display "#<lazy-" out)
  (cond ((not (lazy-seq-realized? seq))
         (display "seq ...>" out))
        ((lazy-null? seq)
         (display "null>" out))
        (else
         (display "seq" out)
         (let loop ((seq seq))
           (if (lazy-seq-realized? seq)
               (if (lazy-null? seq)
                   (display ">" out)
                   (begin
                     (display " " out)
                     (write (lazy-head seq) out)
                     (loop (lazy-tail seq))))
               (display " ...>" out))))))

(: lazy-seq-realized? (lazy-seq --> boolean))
(define (lazy-seq-realized? seq)
  (not (lazy-seq-body seq)))

(: lazy-null lazy-null)
(define lazy-null
  (lazy-seq '()))

(: lazy-null? (lazy-seq --> boolean))
(define (lazy-null? seq)
  (null? (realized-lazy-seq seq)))

(define-specialization (lazy-null? (seq lazy-null))
  #t)

(define-specialization (lazy-null? (seq lazy-seq))
  (null? (realized-lazy-seq seq)))

(: realized-lazy-seq (lazy-seq -> lazy-body))
(define (realized-lazy-seq seq)
  (or (lazy-seq-value seq)
      (let ((value ((lazy-seq-body seq))))
        (lazy-seq-body-set! seq #f)
        (let loop ((value value))
          (if (or (null? value) (pair? value))
              (begin
                (lazy-seq-value-set! seq value)
                value)
              (loop (or (lazy-seq-value value)
                        ((lazy-seq-body value)))))))))

(: lazy-head (lazy-seq -> *))
(define (lazy-head seq)
  (car (realized-lazy-seq seq)))

(: lazy-tail (lazy-seq -> lazy-seq))
(define (lazy-tail seq)
  (cdr (realized-lazy-seq seq)))

(: lazy-seq->list (lazy-seq -> (or null list)))
(define (lazy-seq->list seq)
  (if (lazy-null? seq)
      '()
      (cons (lazy-head seq)
            (lazy-seq->list
             (lazy-tail seq)))))

(: lazy-list (#!rest * --> lazy-seq))
(define (lazy-list . elements)
  (list->lazy-seq elements))

(: list->lazy-seq ((or null list) --> lazy-seq))
(define (list->lazy-seq list)
  (if (null? list)
      (%make-lazy-seq #f '())
      (%make-lazy-seq
       #f (cons (car list)
                (list->lazy-seq (cdr list))))))

(: lazy-length (lazy-seq -> fixnum))
(define (lazy-length seq)
  (let loop ((count 0) (seq seq))
    (if (lazy-null? seq)
        count
        (loop (+ count 1) (lazy-tail seq)))))

(: lazy-take (fixnum lazy-seq --> lazy-seq))
(define (lazy-take n seq)
  (lazy-seq
    (if (or (zero? n) (lazy-null? seq))
        '()
        (cons (lazy-head seq)
              (lazy-take (- n 1) (lazy-tail seq))))))

(: lazy-drop (fixnum lazy-seq --> lazy-seq))
(define (lazy-drop n seq)
  (lazy-seq
    (if (or (zero? n) (lazy-null? seq))
        seq
        (lazy-drop (- n 1) (lazy-tail seq)))))

(: lazy-take-while ((* -> boolean) lazy-seq --> lazy-seq))
(define (lazy-take-while pred? seq)
  (let loop ((seq seq))
    (lazy-seq
      (cond ((lazy-null? seq) '())
            ((pred? (lazy-head seq))
             (cons (lazy-head seq)
                   (loop (lazy-tail seq))))
            (else '())))))

(: lazy-drop-while ((* -> boolean) lazy-seq --> lazy-seq))
(define (lazy-drop-while pred? seq)
  (let loop ((seq seq))
    (lazy-seq
      (cond ((lazy-null? seq) '())
            ((pred? (lazy-head seq))
             (loop (lazy-tail seq)))
            (else seq)))))

(: lazy-numbers (#!rest * --> lazy-seq))
(define (lazy-numbers #!key (step 1) (start 0) count)
  (let loop ((count count) (start start) (step step))
    (lazy-seq
      (if (and count (zero? count))
          '()
          (cons start
                (loop (and count (- count 1))
                      (+ start step)
                      step))))))

(: lazy-append (#!rest lazy-seq --> lazy-seq))
(define (lazy-append . seqs)
  (let loop ((seqs seqs))
    (lazy-seq
      (if (null? seqs)
          '()
          (let loop2 ((seq (car seqs)))
            (lazy-seq
              (if (lazy-null? seq)
                  (loop (cdr seqs))
                  (cons (lazy-head seq)
                        (loop2 (lazy-tail seq))))))))))

(define (make-lazy-mapping-proc append-result)
  (case-lambda
   ((proc seq)
    (let loop ((seq seq))
      (lazy-seq
        (if (lazy-null? seq)
            '()
            (append-result
             (proc (lazy-head seq))
             (loop (lazy-tail seq)))))))
   ((proc seq . seqs)
    (let loop ((seqs (cons seq seqs)))
      (lazy-seq
        (if (any lazy-null? seqs)
            '()
            (append-result
             (apply proc (map lazy-head seqs))
             (loop (map lazy-tail seqs)))))))))

(: lazy-map ((* #!rest * -> *) lazy-seq #!rest lazy-seq --> lazy-seq))
(define lazy-map
  (make-lazy-mapping-proc cons))

;; (define-specialization (lazy-map (seq lazy-seq) (proc (* -> *)))
;;   (let loop ((seq seq))
;;     (lazy-seq
;;       (if (lazy-null? seq)
;;           '()
;;           (cons
;;            (proc (lazy-head seq))
;;            (loop (lazy-tail seq)))))))

(: lazy-append-map ((* #!rest * -> lazy-seq) lazy-seq #!rest lazy-seq --> lazy-seq))
(define lazy-append-map
  (make-lazy-mapping-proc lazy-append))

(: lazy-filter ((* -> boolean) lazy-seq --> lazy-seq))
(define (lazy-filter pred? seq)
  (let loop ((seq seq))
    (lazy-seq
      (if (lazy-null? seq)
          '()
          (let ((head (lazy-head seq))
                (tail (loop (lazy-tail seq))))
            (if (pred? head)
                (cons head tail)
                tail))))))

(: lazy-ref (fixnum lazy-seq -> *))
(define (lazy-ref n seq)
  (if (zero? n)
      (lazy-head seq)
      (lazy-ref (- n 1) (lazy-tail seq))))

(: lazy-each ((* #!rest * -> *) #!rest lazy-seq -> void))
(define (lazy-each proc . seqs)
  (unless (any lazy-null? seqs)
    (apply proc (map lazy-head seqs))
    (apply lazy-each proc (map lazy-tail seqs))))

(: input-port->lazy-seq (input-port (input-port -> *) --> lazy-seq))
(define (input-port->lazy-seq port read)
  (let loop ()
    (lazy-seq
      (let ((datum (read port)))
        (if (eof-object? datum)
            '()
            (cons datum (loop)))))))

(: lazy-repeat (* --> lazy-seq))
(define (lazy-repeat x)
  (lazy-seq (cons x (lazy-repeat x))))

(: lazy-repeatedly ((-> *) --> lazy-seq))
(define (lazy-repeatedly f)
  (lazy-seq (cons (f) (lazy-repeatedly f))))

(: lazy-iterate
   (forall ((f (x -> x)) x)
           (f x --> lazy-seq)))
;; (: lazy-iterate ((* -> *) * -> lazy-seq))
(define (lazy-iterate f x)
  (lazy-seq
    (cons x (lazy-iterate f (f x)))))

(: lazy-reverse (lazy-seq --> lazy-seq))
(define (lazy-reverse seq)
  (let loop ((seq seq) (rev-seq (lazy-seq '())))
    (lazy-seq
      (if (lazy-null? seq)
          rev-seq
          (loop (lazy-tail seq)
                (%make-lazy-seq #f (cons (lazy-head seq) rev-seq)))))))

(: lazy-cycle (lazy-seq --> lazy-seq))
(define (lazy-cycle seq)
  (lazy-seq
    (if (lazy-null? seq)
        '()
        (let loop ((rest seq))
          (lazy-seq
            (if (lazy-null? rest)
                (loop seq)
                (cons (lazy-head rest)
                      (loop (lazy-tail rest)))))))))

)