;;;; sequences.scm


;; (define-polymorphic (NAME . LLIST) ((TYPE ...) BODY ...) ...)

;; this is just a glorified typecase, but allows us to use type
;; hierarchies and multi-dispatch.

(define-syntax define-polymorphic 
  (er-macro-transformer
  (lambda (x r c)
    (let* ((head (cadr x))
           (clauses (cddr x))
           (name (car head))
           (llist (cdr head))
           (allargs
            (let loop ((llist llist))
              (cond ((or (not (pair? llist))
                         (memq (car llist) '(#!rest #!optional #!key)))
                     llist)
                    ((symbol? (car llist))
                     (cons (car llist) (loop (cdr llist))))
                    (else (cons (caar llist) (loop (cdr llist)))))))
           (typedargs 
            (let loop ((llist llist))
              (cond ((or (not (pair? llist))
                         (memq (car llist) '(#!rest #!optional #!key)))
                     '())
                    ((symbol? (car llist))
                     (loop (cdr llist)))
                    (else (cons (caar llist) (loop (cdr llist)))))))
           (untypedargs 
            (let loop ((llist llist))
              (cond ((null? llist) '())
                    ((memq (car llist) '(#!rest #!optional #!key))
                     (cons (if (pair? (cadr llist))
                               (caadr llist)
                               (cadr llist))
                           (loop (cddr llist))))
                    ((symbol? (car llist))
                     (cons (car llist) (loop (cdr llist))))
                    (else (loop (cdr llist))))))
           (%define (r 'define))
           (%define-generic (r 'define-generic))
           (%begin (r 'begin))
           (generic (string->symbol 
                     (string-append (symbol->string name) "-generic"))))
      `(,%begin
        ,@(map (lambda (clause)
                 (let ((types (car clause))
                       (body (cdr clause)))
                   `(,%define-generic
                     (,generic 
                      ,@(append (map list types typedargs) untypedargs))
                     ,@body)))
               clauses)
        (,%define 
         (,name . ,allargs)
         (,generic ,@typedargs ,@untypedargs))
        )))
  ))

;;; sequence types

(define-record linear-sequence
  make					; LENGTH INIT -> S
  head					; S -> X
  next					; S -> S'
  state)					;

(define-record random-access-sequence
  make					; LENGTH INIT -> S
  elt					; S INDEX -> X
  size					; S -> FIXNUM
  data)					;

(define ras? random-access-sequence?)
(define ls? linear-sequence?)

(define (random-access-sequence? x)
  (or (vector? x)
      (string? x)
      (ras? x)))

(define (linear-sequence? x)
  (or (list? x)
      (ls? x)))

(define (sequence? x)
  (or (list? x)
      (vector? x)
      (string? x)
      (ras? x)
      (ls? x)))

(define-type <sequence> sequence?)
(define-type <random-access-sequence> ras? <sequence>)
(define-type <linear-sequence> ls? <sequence>)
(define-type <list> list? <linear-sequence>)
(define-type <vector> vector? <random-access-sequence>)
(define-type <string> string? <random-access-sequence>)

(define make-ras make-random-access-sequence)

(define make-random-access-sequence
  (let ((old make-random-access-sequence))
    (lambda (maker elt size)
      (old
       maker
       elt
       size
       (maker 0 #f)))))

(define make-ls make-linear-sequence)

(define make-linear-sequence
  (let ((old make-linear-sequence))
    (lambda (maker head next)
      (old
       maker
       head
       next
       #f))))


;;; iterator types

(define-record iterator
  index					; FIXNUM
  sequence				; SEQUENCE
  state)				; LINEAR-SEQUENCE-STATE | RANDOM-ACCESS-SEQUENCE-DATA

(define (linear-iterator? x)
  (and (iterator? x) 
       (linear-sequence? (iterator-sequence x))))

(define (random-access-iterator? x)
  (and (iterator? x) 
       (random-access-sequence? (iterator-sequence x))))

(define-type <fixnum> fixnum?)

(define-type <iterator> iterator?)
(define-type <linear-iterator> linear-iterator? <iterator>)
(define-type <random-access-iterator> random-access-iterator? <iterator>)

(define index iterator-index)


;;; helper operations

(define (la-skip x n loc)
  (let ((next (linear-sequence-next x)))
    (let loop ((state (linear-sequence-state x))
	       (j n))
      (cond ((eq? 0 j) state)
	    ((not state) (error loc "index out of range" n x))
	    (else (loop (next state) (fx- j 1)))))))


;;; operators

(define-polymorphic (size (s))
  ((<list>) (length s))
  ((<vector>) (vector-length s))
  ((<string>) (string-length s))
  ((<linear-sequence>) 
   (let ((next (linear-sequence-next s)))
     (do ((state (linear-sequence-state s) (next state))
	  (n 0 (fx+ n 1)))
	 ((not state) n))))
  ((<random-access-sequence>)
   ((random-access-sequence-size s) (random-access-sequence-data s))))

#| Currently disabled, since it would fail for linear sequences

(define (check-iterator it s loc)
  (if (eq? s (iterator-sequence it))
      it
      (error loc "iterator does not refer to given sequence" it s)))
|#

(define-syntax check-iterator
  (syntax-rules ()
    ((_ i x loc) i)))

(define-polymorphic (elt0 (x) (i))
  ((<list> <fixnum>) (list-ref x i))
  ((<list> <linear-iterator>) 
   (car (iterator-state (check-iterator i x 'elt))))
  ((<vector> <fixnum>) (vector-ref x i))
  ((<string> <fixnum>) (string-ref x i))
  ((<linear-sequence> <linear-iterator>)
   ((linear-sequence-head x) (iterator-state (check-iterator i x 'elt))))
  ((<vector> <random-access-iterator>)
   (vector-ref x (iterator-index (check-iterator i x 'elt))))
  ((<string> <random-access-iterator>)
   (string-ref x (iterator-index (check-iterator i x 'elt))))
  ((<random-access-sequence> <random-access-iterator>)
   ((random-access-sequence-elt x)
    (random-access-sequence-data x)
    (iterator-index (check-iterator i x 'elt))))
  ((<linear-sequence> <fixnum>)
   (let ((state (la-skip x i 'elt)))
     ((linear-sequence-head x) state)))
  ((<random-access-sequence> <fixnum>) 
   ((random-access-sequence-elt x) (random-access-sequence-data x) i)))

(define-polymorphic (setelt0 (x) (i) y)
  ((<list> <fixnum>) (set-car! (list-tail x i) y)) 
  ((<list> <linear-iterator>)
   (set-car! (iterator-state (check-iterator i x 'elt)) y))
  ((<vector> <fixnum>) (vector-set! x i y))
  ((<string> <fixnum>) (string-set! x i y))
  ((<vector> <random-access-iterator>)
   (vector-set! x (iterator-index (check-iterator i x 'elt)) y))
  ((<string> <random-access-iterator>)
   (string-set! x (iterator-index (check-iterator i x 'elt)) y))
  ((<linear-sequence> <linear-iterator>)
   ((setter (linear-sequence-head x)) (iterator-state (check-iterator i x 'elt)) y))
  ((<random-access-sequence> <random-access-iterator>)
   ((setter (random-access-sequence-elt x)) (iterator-state (check-iterator i x 'elt)) y))
  ((<linear-sequence> <fixnum>) 
   (let ((state (la-skip x i 'elt)))
     ((setter (linear-sequence-head x)) state y)))
  ((<random-access-sequence> <fixnum>) 
   ((setter (random-access-sequence-elt x)) 
    (random-access-sequence-data x)
    i y)))

(define elt
  (getter-with-setter
   elt0
   setelt0))

(define-polymorphic (make (s) len init)
  ((<list>) 
   (##sys#check-fixnum len 'make)
   (let loop ((len len) (lst '()))
     (if (fx<= len 0)
	 (reverse lst)
	 (loop (fx- len 1) (cons init lst)))))
  ((<string>) (make-string len (or init #\space)))
  ((<vector>) (make-vector len init))
  ((<linear-sequence>) 
   (let ((maker (linear-sequence-make s)))
     (make-ls
      maker
      (linear-sequence-head s)
      (linear-sequence-next s)
      (maker len init))))
  ((<random-access-sequence>) 
   (let ((maker (random-access-sequence-make s)))
     (make-ras
      maker
      (random-access-sequence-elt s)
      (random-access-sequence-size s)
      (maker len init)))))

(define-polymorphic (rev (x))
  ((<list>) (reverse x))
  ((<vector>)
   (let* ((len (vector-length x))
	  (v2 (make-vector len)))
     (let loop ((i 0) (j (fx- len 1)))
       (if (fx<= i j)
	   (let ((v (vector-ref x i)))
	     (vector-set! v2 i (vector-ref x j))
	     (vector-set! v2 j v)
	     (loop (fx+ i 1) (fx- j 1)))
	   v2))))
  ((<string>)
   (let* ((len (string-length x))
	  (v2 (make-string len)))
     (let loop ((i 0) (j (fx- len 1)))
       (if (fx<= i j)
	   (let ((v (string-ref x i)))
	     (string-set! v2 i (string-ref x j))
	     (string-set! v2 j v)
	     (loop (fx+ i 1) (fx- j 1)))
	   v2))))
  ((<linear-sequence>)
   (let* ((len (size-generic x))
	  (new ((linear-sequence-make x) len #f))
	  (head (linear-sequence-head x))
	  (sethead (setter head))
	  (next (linear-sequence-next x)))
     (do ((i 0 (fx+ i 1))
	  (state (linear-sequence-state x) (next state))
	  (newstate new (next newstate)))
	 ((fx>= i len) 
	  (make-ls make head next new))
       (sethead newstate (head state)))))
  ((<random-access-sequence>)
   (let* ((data (random-access-sequence-data x))
	  (lenf (random-access-sequence-size x))
	  (len (lenf data))
	  (maker (random-access-sequence-make x))
	  (v2 (maker len #f))
	  (ref (random-access-sequence-elt x))
	  (set (setter ref)))
     (let loop ((i 0) (j (fx- len 1)))
       (if (fx<= i j)
	   (let ((v (ref data i)))
	     (set v2 i (ref data j))
	     (set v2 j v)
	     (loop (fx+ i 1) (fx- j 1)))
	   (make-ras maker ref lenf v2))))))

(define-polymorphic (sub0 (x) start #!optional end)
  ((<list>)
   (##sys#check-fixnum start 'sub)
   (when end (##sys#check-fixnum end 'sub))
   (do ((hd x (cdr hd))
	(i 0 (fx+ i 1)))
       ((fx>= i start)
	(let loop ((hd hd) (j i) (s '()))
	  (cond ((if end (fx>= j end) (null? hd)) (reverse s))
		((null? hd) (error 'sub "out of range (end)" end x))
		(else 
		 (loop (cdr hd) (fx+ j 1) (cons (car hd) s))))))
     (unless (pair? hd)
       (error 'sub "out of range (start)" start x))))
  ((<vector>)
   (##sys#check-fixnum start 'sub)
   (when end (##sys#check-fixnum end 'sub))
   (let* ((len (vector-length x))
	  (end (or end len))
	  (len2 (fx- end start))
	  (v2 (make-vector len2)))
     (do ((i start (fx+ i 1))
	  (j 0 (fx+ j 1)))
	 ((fx>= i end) v2)
       (vector-set! v2 j (vector-ref x i)))))
  ((<string>)
   (##sys#check-fixnum start 'sub)
   (when end (##sys#check-fixnum end 'sub))
   (let* ((len (string-length x))
	  (end (or end len))
	  (len2 (fx- end start))
	  (v2 (make-string len2)))
     (do ((i start (fx+ i 1))
	  (j 0 (fx+ j 1)))
	 ((fx>= i end) v2)
       (string-set! v2 j (string-ref x i)))))
  ((<linear-sequence>)
   (##sys#check-fixnum start 'sub)
   (when end (##sys#check-fixnum end 'sub))
   (let* ((head (linear-sequence-head x))
	  (sethead (setter head))
	  (next (linear-sequence-next x))
	  (maker (linear-sequence-make x)))
     (do ((hd (linear-sequence-state x) (next hd))
	  (i 0 (fx+ i 1)))
	 ((fx>= i start)
	  (let ((new (maker (fx- end start) #f)))
	    (let loop ((hd hd) (j i) (s (linear-sequence-state new)))
	      (cond ((and end (fx>= j end)) 
		     (make-ls maker head next new))
		    ((next hd) =>
		     (lambda (nxt)
		       (sethead s (head hd))
		       (loop nxt (fx+ j 1) (next s))))
		    (else (error 'sub "out of range (end)" end x))))))
       (unless hd
	 (error 'sub "out of range (start)" start x)))))
  ((<random-access-sequence>)
   (##sys#check-fixnum start 'sub)
   (when end (##sys#check-fixnum end 'sub))
   (let* ((size (random-access-sequence-size x))
	  (len (size x))
	  (end (or end len))
	  (len2 (fx- end start))
	  (maker (random-access-sequence-make x))
	  (v2 (maker len2 #f))
	  (ref (random-access-sequence-elt x))
	  (set (setter ref)))
     (do ((i start (fx+ i 1))
	  (j 0 (fx+ j 1)))
	 ((fx>= i end) 
	  (make-ras maker ref size v2))
       (set v2 j (ref x i))))))

(define-polymorphic (setsub0 (x) start end/y #!optional y/end)
  ;;XXX y must be of same type - this should be checked
  ((<list>)
   (let ((end (and y/end end/y))
	 (y (if y/end y/end end/y)))
     (##sys#check-fixnum start 'sub)
     (when end (##sys#check-fixnum end 'sub))
     (##sys#check-list y 'sub) 
     (do ((hd x (cdr hd))
	  (i 0 (fx+ i 1)))
	 ((fx>= i start)
	  (let loop ((hd hd) (j i) (y y))
	    (cond ((if end (fx>= j end) (null? hd)))
		  ((null? hd) (error 'sub "out of range (end)" end x))
		  (else
		   (set-car! hd (car y))
		   (loop (cdr hd) (fx+ j 1) (cdr y))))))
       (unless (pair? hd)
	 (error 'sub "out of range (start)" start x)))))
  ((<vector>)
   (let ((end (and y/end end/y))
	 (y (if y/end y/end end/y)))
     (##sys#check-fixnum start 'sub)
     (when end (##sys#check-fixnum end 'sub))
     (let* ((len (vector-length x))
	    (len2 (vector-length y))
	    (end (or end len)))
       (do ((i start (fx+ i 1))
	    (j 0 (fx+ j 1)))
	   ((or (fx>= i end) (fx>= j len2)))
	 (vector-set! x i (vector-ref y j))))))
  ((<string>)
   (let ((end (and y/end end/y))
	 (y (if y/end y/end end/y)))
     (##sys#check-fixnum start 'sub)
     (when end (##sys#check-fixnum end 'sub))
     (let* ((len (string-length x))
	    (len2 (string-length y))
	    (end (or end len)))
       (do ((i start (fx+ i 1))
	    (j 0 (fx+ j 1)))
	   ((or (fx>= i end) (fx>= j len2)))
	 (string-set! x i (string-ref y j))))))
  ((<linear-sequence>)
   (let ((end (and y/end end/y))
	 (y (if y/end y/end end/y)))
     (##sys#check-fixnum start 'sub)
     (when end (##sys#check-fixnum end 'sub))
     (let* ((head (linear-sequence-head x))
	    (sethead (setter head))
	    (next (linear-sequence-next x)))
       (do ((hd (linear-sequence-state x) (next hd))
	    (i 0 (fx+ i 1)))
	   ((fx>= i start)
	    (let loop ((hd hd) (j i) (s (linear-sequence-state y)))
	      (cond ((and end (fx>= j end)))
		    ((next hd) =>
		     (lambda (nxt)
		       (sethead hd (head s))
		       (loop nxt (fx+ j 1) (next s))))
		    (else (error 'sub "out of range (end)" end x)))))
	 (unless hd
	   (error 'sub "out of range (start)" start x))))))
  ((<random-access-sequence>)
   (let ((end (and y/end end/y))
	 (y (if y/end y/end end/y)))
     (##sys#check-fixnum start 'sub)
     (when end (##sys#check-fixnum end 'sub))
     (let* ((data1 (random-access-sequence-data x))
	    (len1 ((random-access-sequence-size x) data1))
	    (data2 (random-access-sequence-data y))
	    (len2 ((random-access-sequence-size y) data2))
	    (end (or end len1))
	    (ref (random-access-sequence-elt y))
	    (set (setter (random-access-sequence-elt x))))
       (do ((i start (fx+ i 1))
	    (j 0 (fx+ j 1)))
	   ((or (fx>= i end) (fx>= j len2)))
	 (set data1 i (ref data2 j)))))))

(define sub
  (getter-with-setter
   sub0
   setsub0))

(define-polymorphic (foldl proc seed (x))
  ((<list>)
   (let fold ((seed seed) (x x))
     (if (null? x) 
	 seed
	 (fold (proc seed (car x)) (cdr x)))))
  ((<vector>)
   (let ((len (vector-length x)))
     (let fold ((seed seed) (i 0))
       (if (fx>= i len)
	   seed
	   (fold (proc seed (vector-ref x i)) (fx+ i 1))))))
  ((<string>)
   (let ((len (string-length x)))
     (let fold ((seed seed) (i 0))
       (if (fx>= i len)
	   seed
	   (fold (proc seed (string-ref x i)) (fx+ i 1))))))
  ((<linear-sequence>)
   (let ((head (linear-sequence-head x))
	 (next (linear-sequence-next x)))
     (let fold ((seed seed) (x (linear-sequence-state x)))
       (if (not x)
	   seed
	   (fold (proc seed (head x)) (next x))))))
  ((<random-access-sequence>)
   (let* ((data (random-access-sequence-data x))
	  (len ((random-access-sequence-size x) data))
	  (ref (random-access-sequence-elt x)))
     (let fold ((seed seed) (i 0))
       (if (fx>= i len)
	   seed
	   (fold (proc seed (ref data i)) (fx+ i 1)))))))

(define-polymorphic (foldr proc seed (x))
  ((<list>)
   (let fold ((x x))
     (if (null? x) 
	 seed
	 (proc (car x) (fold (cdr x))))))
  ((<vector>)
   (let ((len (vector-length x)))
     (let fold ((i 0))
       (if (fx>= i len)
	   seed
	   (proc (vector-ref x i) (fold (fx+ i 1)))))))
  ((<string>)
   (let ((len (string-length x)))
     (let fold ((i 0))
       (if (fx>= i len)
	   seed
	   (proc (string-ref x i) (fold (fx+ i 1)))))))
  ((<linear-sequence>)
   (let ((head (linear-sequence-head x))
	 (next (linear-sequence-next x)))
     (let fold ((x (linear-sequence-state x)))
       (if (not x)
	   seed
	   (proc (head x) (fold (next x)))))))
  ((<random-access-sequence>)
   (let* ((data (random-access-sequence-data x))
	  (len ((random-access-sequence-size x) data))
	  (ref (random-access-sequence-elt x)))
     (let fold ((i 0))
       (if (fx>= i len)
	   seed
	   (proc (ref data i) (fold (fx+ i 1))))))))

(define-polymorphic (sequence (s) #!rest xs)
  ((<list>) 
   xs)
  ((<linear-sequence>)
   (let* ((maker (linear-sequence-make s))
	  (head (linear-sequence-head s))
	  (next (linear-sequence-next s))
	  (sethead (setter head))
	  (new (maker (length xs) #f)))
     (do ((xs xs (cdr xs))
	  (s new (next s)))
	 ((null? xs) 
	  (make-ls maker head next new))
       (sethead s (car xs)))))
  ((any)
   (let* ((n (length xs))
	  (s (make-generic s n #f)))
     (do ((xs xs (cdr xs))
	  (i 0 (fx+ i 1)))
	 ((null? xs) s)
       (setelt0-generic s i (car xs))))))

(define-polymorphic (for proc (s))
  ((<list>) (for-each proc s))
  ((<linear-sequence>)
   (let ((next (linear-sequence-next s))
	 (head (linear-sequence-head s)))
     (let loop ((s (linear-sequence-state s)))
       (when s
	 (proc (head s))
	 (loop (next s))))))
  ((any) 
   (let ((len (size-generic s)))
     (do ((i 0 (fx+ i 1)))
	 ((fx>= i len))
       (proc (elt0-generic s i))))))

(define-polymorphic (smap (proto) proc (s))
  ((<list> <list>) (map proc s))
  ((<list> any)
   (let ((len (size-generic s)))
     (let loop ((i 0) (r '()))
       (if (fx>= i len)
	   (reverse r)
	   (loop (fx+ i 1) (cons (proc (elt0-generic s i)) r))))))
  ((<linear-sequence> <linear-sequence>)
   (let* ((make1 (linear-sequence-make proto))
	  (head1 (linear-sequence-head proto))
	  (sethead1 (setter head1))
	  (next1 (linear-sequence-next s))
	  (head2 (linear-sequence-head s))
	  (next2 (linear-sequence-next s))
	  (len (size-generic s))
	  (new (make1 len #f)))
     (let loop ((n new) (s (linear-sequence-state s)))
       (if (not s)
	   (make-ls make1 head1 next1 new)
	   (let ((x (proc (head2 s))))
	     (sethead1 n x)
	     (loop (next1 n) (next2 s)))))))
  ((<linear-sequence> any)
   (let* ((maker (linear-sequence-make proto))
	  (head (linear-sequence-head proto))
	  (sethead (setter head))
	  (next (linear-sequence-next proto))
	  (len (size-generic s))
	  (new (maker len #f)))
     (let loop ((i 0) (n new))
       (if (fx>= i len)
	   (make-ls make head next new)
	   (let ((x (proc (elt0-generic s i))))
	     (sethead n x)
	     (loop (fx+ i 1) (next n)))))))
  ((any <linear-sequence>)
   (let* ((len (size-generic s))
	  (head (linear-sequence-head s))
	  (next (linear-sequence-next s))
	  (new (make-generic proto len #f)))
     (let loop ((i 0) (s (linear-sequence-state s)))
       (if (fx>= i len)
	   new
	   (let ((x (proc (head s))))
	     (setelt0-generic new i x)
	     (loop (fx+ i 1) (next s)))))))
  ((any any)
   (let* ((len (size-generic s))
	  (dest (make-generic proto len #f)))
     (do ((i 0 (fx+ i 1)))
	 ((fx>= i len) dest)
       (setelt0-generic dest i (proc (elt0-generic s i)))))))

(define (coerce proto s)
  (smap proto identity s))

(define (copy s)
  (coerce s s))

(define-polymorphic (iterator (s) #!optional (position 0))
  ((<list>) 
   (let ((tl (list-tail s position)))
     (make-iterator position s (and (pair? tl) tl))))
  ((<vector>) (make-iterator position s s))
  ((<string>) (make-iterator position s s))
  ((<linear-sequence>)
   (let ((state
	  (if (eq? position 0)
	      (linear-sequence-state s)
	      (la-skip s position 'iterator))))
     (make-iterator position s state)))
  ((<random-access-sequence>)
   (make-iterator position s (random-access-sequence-data s))))

(define-polymorphic (at-end? (it))
  ((<linear-iterator>) (not (iterator-state it)))
  ((<random-access-iterator>) (fx>= (iterator-index it) (size (iterator-sequence it)))))

(define-polymorphic (linear-iterator-step (s))
  ((<list>) 
   (lambda (s)
     (let ((s (cdr s)))
       (and (pair? s) s))))
  ((<linear-sequence>) (linear-sequence-next s)))

(define-polymorphic (advance (it) #!optional (step 1))
  ((<linear-iterator>)
   (##sys#check-fixnum step 'advance)
   (when (fx< step 0)
     (error 'advance "iterator over linear sequence can not advance backwards" it step))
   (let ((next (linear-iterator-step (iterator-sequence it))))
     (do ((n step (fx- n 1))
	  (state (iterator-state it) (and state (next state))))
	 ((zero? n)
	  (make-iterator 
	   (fx+ (iterator-index it) step)
	   (iterator-sequence it)
	   state)))))
  ((<random-access-iterator>)
   (##sys#check-fixnum step 'advance)
   (make-iterator
    (fx+ (iterator-index it) step)
    (iterator-sequence it)
    (iterator-state it))))

(define-polymorphic (advance! (it) #!optional (step 1))
  ((<linear-iterator>)
   (##sys#check-fixnum step 'advance!)
   (when (fx< step 0)
     (error 'advance! "iterator over linear sequence can not advance backwards" it step))
   (let ((next (linear-iterator-step (iterator-sequence it))))
     (do ((n step (fx- n 1))
	  (state (iterator-state it) (and state (next state))))
	 ((zero? n)
	  (iterator-index-set! it (fx+ (iterator-index it) step))
	  (iterator-state-set! it state)
	  it))))
  ((<random-access-iterator>)
   (##sys#check-fixnum step 'advance!)
   (iterator-index-set! it (fx+ (iterator-index it) step))
   it))

(define (for* proc s)
  (let loop ((it (iterator s)))
    (unless (at-end?-generic it)
      (proc s it)
      (loop (advance!-generic it 1)))))

(define (smap* proto proc s)
  (let ((it (iterator s)))
    (smap 
     proto
     (lambda _
       (let ((x (proc s it)))
	 (advance!-generic it 1)
	 x))
     s)))

(define (port->sequence port #!optional (reader read-char))
  (let* ((tag (list 'tag))
	 (last tag))
    (make-linear-sequence 
     (lambda _ port)
     (getter-with-setter
      (lambda _ 
	(cond ((eq? last tag)
	       (set! last (reader port))
	       (when (eof-object? last)
		 (close-input-port port))
	       last)
	      (else last)))
      (lambda _
	(error "can not write element of input-port sequence" port)))
     (lambda _
       (set! last (reader port))
       (cond ((eof-object? last)
	      (close-input-port port)
	      #f)
	     (else port))))))

(define (pos fn s)
  (let ((it (iterator s)))
    (let loop ()
      (cond ((at-end?-generic it) #f)
	    ((fn (elt0-generic s it)) (index it))
	    (else 
	     (advance!-generic it 1)
	     (loop))))))

;;XXX these could be faster by special-casing for lists and linear-sequences

(define (take fn s)
  (let ((it (iterator s)))
    (let loop ()
      (cond ((at-end?-generic it) (copy s))
	    ((fn (elt0-generic s it))
	     (advance!-generic it 1)
	     (loop))
	    (else (sub s 0 (index it)))))))

(define (drop fn s)
  (let ((it (iterator s)))
    (let loop ()
      (cond ((at-end?-generic it) (make-generic s 0 #f))
	    ((fn (elt0-generic s it))
	     (advance!-generic it 1)
	     (loop))
	    (else (sub s (index it)))))))

(define (split fn s)
  (let ((it (iterator s)))
    (let loop ()
      (cond ((at-end? it) 
	     (values (copy s) (make-generic s 0 #f)))
	    ((fn (elt0-generic s it))
	     (advance!-generic it 1)
	     (loop))
	    (else
	     (let ((i (index it)))
	       (values 
		(sub s 0 i)
		(sub s i))))))))

(define (partition fn s)
  (let ((it (iterator s)))
    (let loop ((yes '()) (no '()))
      (if (at-end? it) 
	  (values 
	   (coerce s (reverse yes))
	   (coerce s (reverse no)))
	  (let ((x (elt0-generic s it)))
	    (advance!-generic it 1)
	    (if (fn x)
		(loop (cons x yes) no)
		(loop yes (cons x no))))))))

(define (fill! fn s #!optional (start 0) (end (size s)))
  (let ((it (iterator s start)))
    (do () ((fx< (index it) end) s)
      (setelt0-generic s it (fn s it))
      (advance!-generic it 1))))

(define (is? x) (cut equal? <> x))

(define (filter st fn s)
  (let ((it (iterator s)))
    (let loop ((yes '()))
      (if (at-end?-generic it) 
	  (coerce st (reverse yes))
	  (let ((x (elt s it)))
	    (advance!-generic it 1)
	    (if (fn x)
		(loop (cons x yes))
		(loop yes)))))))

(define-polymorphic (peek (s))
  ((<list>) (car s))
  ((any) (elt0-generic s 0)))

(define-polymorphic (pop (s))
  ((<list>) (cdr s))
  ((<linear-sequence>) ((linear-sequence-next s) s))
  ((any) (sub0-generic s 1 (size-generic s))))

(define-polymorphic (empty? (s))
  ((<list>) (null? s))
  ((any) (zero? (size-generic s))))

(define (all? fn s)
  (let ((it (iterator s)))
    (let loop ()
      (or (at-end?-generic it) 
	  (let ((x (elt0-generic s it)))
	    (advance!-generic it 1)
	    (and (fn x) (loop)))))))

(define (thereis? fn s)
  (let ((it (iterator s)))
    (let loop ()
      (and (not (at-end?-generic it))
	   (let ((x (elt0-generic s it)))
	     (advance!-generic it 1)
	     (or (fn x) (loop)))))))

(define (intersection st = s1 . ss)
  (cond ((thereis? empty? ss) '())
	((null? ss) s1)
	(else
	 (filter
	  st
	  (lambda (x)
	    (all? (lambda (s2) (thereis? (cut = x <>) s2)) ss))
	  s1))))

(define (difference st = s1 . ss)
  (cond ((null? ss) s1)
	(else
	 (filter
	  st
	  (lambda (x)
	    (all? (lambda (s2) (not (thereis? (cut = x <>) s2))) ss))
	  s1))))

(define (union st = . ss)
  (coerce
   st
   (foldl
    (lambda (ans s)			
      (cond ((empty?-generic s) ans)	; Don't copy any lists
	    (else
	     (foldl
	      (lambda (ans elt)
		(if (thereis? (lambda (x) (= x elt)) ans)
		    ans
		    (cons elt ans)))
	      ans s))))
    '() ss)))