; 		An exercise in Lazy Virology
; Another take at a list flattering problem discussed at length
; on comp.lang.scheme newsgroups in Sep/Oct 1997.
;
; The problem:
; given a list that may contain embedded lists, return the list of all
; atomic elements regardless of their nesting depth

; $Id: flatten-list.scm,v 1.1 1997/10/20 18:16:18 oleg Exp oleg $

(##include "myenv.scm")


	; The flattener itself
	; Note the function accesses each atomic element of the original
	; list exactly once. Furthermore, neither of the atomic elements
	; are cloned, duplicated or even moved in memory.
	;
	; The flattener returns a promise, which when forced, returns a pair
	; of a current atomic element and a promise to give more...
	;
	; Note that the function is tail-recursive _and_ tail-infective
	; it works like a virus, inserting itself into a newly made "cell"

(define (flatten x)
  (define (does-flatten x)
    (if (not (pair? x)) x
      (cond
        ((null? (car x)) (does-flatten (cdr x)))
        ((not (pair? (car x)))
          (cons (car x) (delay (does-flatten (cdr x)))))
        (else
          (does-flatten
            (cons (caar x) (cons (cdar x) (cdr x))))))))
  (delay (does-flatten x)))


	; "Forced" versions of car, cdr and null? (as well as 'display')
	; Some Scheme implementations provide for automatic forcing of
	; car, cdr, etc. arguments (as R4RS permits). The following definitions
	; would be unnecessary then. Alas, not in Gambit: it only touches,
	; but does not force ...
(define (fcar x) (car (force x)))
(define (fcdr x) (cdr (force x)))
(define (fnull? x) (null? (force x)))

(define (print-l x)
  (display " (")
  (cond
    ((fnull? x) (display ") "))
    (else
      (display (fcar x))
      (do ((x (fcdr x) (fcdr x))) ((fnull? x) (display ") "))
        (display #\space)
        (display (fcar x))))))


	; Tests
; (print-l (flatten '(1 2 3)))
; (print-l (flatten '(1 (2) 3)))
; (print-l (flatten '(() ((1 2)) (((3))))))
; (print-l (flatten '((1 (2)) () (3 (4 (5 (6 7 8 ())))))))

	; The flattener can handle cyclic lists as well...
(define (cyclic-list . x)
  (if (null? x) x
    (do ((head x) (tail x (cdr tail)))
        ((null? (cdr tail)) (set-cdr! tail head) head))))

	; Print at most n elements from the list x
	; We don't want to use display or other list function
	; to handle an _infinite_ data structure...
(define (print-n n x)
  (do ((i 0 (++ i)) (x x (fcdr x)))
      ((or (>= i n) (fnull? x)) (newline))
      (cout i ": " (fcar x) nl)))


;(define t4 (cyclic-list 1 2 3 4))
;(print-n 10 t4)
;(print-n 10 (flatten t4))

;(define t5 (cyclic-list '() 1 '(2 (3)) 4 '((5 ()))))
;(print-n 20 t5)
;(print-n 20 (flatten t5))