;;;; algorithms.scm


(module ftl 

    (%a
     %a*
     %a-iota
     %a-tabulate
     %a-unfold
     %e=?
     %g->%o
     %g->%o/%g-splicing
     %g-append->%o
     %g-append->%o*
     %g-count-%t
     %g-filter-map1->%o
     %g-fold
     %g-for-each
     %g-last
     %g-last-%t
     %g-length
     %g-map1->%o
     %g-map1->%o/%g-splicing
     %g-partition-%t->%o+%o
     %g-remove-%t->%o
     %g-substitute-%t->%o
     %i->%a
     %i-andmap
     %i-andmap-%t
     %i-filter-map->%a
     %i-find-%t
     %i-map->%a
     %i-map1->%a
     %i-next
     %i-ormap
     %i-ormap-%t
     %i-position-%t
     %i-read
     %i-ref
     %li-empty?
     %li-peek
     %li-read
     %mv
     %mv-append
     %mv-copy
     %mv-fill!
     %mv-length
     %mv-ref
     %mv-reverse!
     %mv-set!
     %mv-sort!
     %mv-stable-sort!
     %o-create
     %o-result
     %o-write
     %oe-max
     %oe-min
     %oe<=?
     %oe<?
     %oe=?
     %oe>=?
     %oe>?
     %t?
     %v->%mv
     %v->%mv!
     %v-fold-left
     %v-fold-right
     %v-length
     %v-map->%mv
     %v-null?
     %v-ref
     %x
     a-interface
     a-interface?
     a=%mv
     a=%mv!
     a=%o
     a=%x-%a
     a=and
     a=char-file
     a=char-port
     a=count
     a=file
     a=list
     a=max
     a=min
     a=or
     a=port
     a=product
     a=reverse-%mv
     a=reverse-%mv!
     a=reverse-list
     a=string
     a=sum
     e-interface
     e-interface?
     e=%oe
     e=char
     e=char-ci
     e=l
     e=number
     e=q
     e=string
     e=string-ci
     e=v
     g-interface
     g-interface?
     g=%g-%x
     g=%i
     g=%v
     g=char-file
     g=char-port
     g=file
     g=iota
     g=line-file
     g=line-port
     g=list
     g=port
     g=reverse-%i
     g=reverse-%v
     g=reverse-list
     g=reverse-string
     g=reverse-vector
     g=string
     g=vector
     i-interface
     i-interface-read
     i-interface?
     i=%li
     i=%v
     i=char-port
     i=list
     i=port
     i=reverse-%v
     i=reverse-string
     i=reverse-vector
     i=string
     i=vector
     li-interface
     li-interface?
     li=%v
     li=char-port
     li=list
     li=reverse-%v
     li=string
     li=vector
     make-%a
     make-%mv
     mv-interface
     mv-interface?
     mv=string
     mv=vector
     o-interface
     o-interface?
     o=char-file
     o=char-port
     o=count
     o=file
     o=list
     o=max
     o=min
     o=port
     o=product
     o=reverse-list
     o=string
     o=sum
     oe-interface
     oe-interface?
     oe=char
     oe=char-ci
     oe=number
     oe=string
     oe=string-ci
     sub
     sub%i->%a
     sub%mv
     sub?
     t-interface
     t-interface?
     t=%e
     t=%x&%t
     t=char
     t=char-ci
     t=if
     t=if-not
     t=l
     t=not-%t
     t=number
     t=q
     t=string
     t=string-ci
     t=v
     v-interface
     v-interface?
     v=%mv
     v=string
     v=vector
     x-interface
     x-interface?
     x=abs
     x=add1
     x=car
     x=cdr
     x=char->integer
     x=downcase
     x=integer->char
     x=not
     x=sub1
     x=upcase)

(import scheme chicken)
(use data-structures extras)


;;; Helper syntax

(define-syntax values-case
  (syntax-rules ()
    ((values-case expr (formals . body) ...)
     (call-with-values (lambda () expr)
       (case-lambda (formals . body) ...)))))


;;; subs

(define-record sub vec start end)

(define (sub #!optional vec (start 0) end)
  (cond ((sub? vec)
	 (make-sub
	  (sub-vec vec)
	  (fx+ start (sub-start vec)) 
	  (if end (fx+ (sub-end vec) end) (sub-end vec))) )
	(else (make-sub vec start end)) ) )

(define (unwrap vec k)
  (if (sub? vec)
      (let ((v (sub-vec vec)))
	(k v 
	   (sub-start vec)
	   (or (sub-end vec)
	       (cond ((vector? v) (vector-length v))
		     ((string? v) (string-length v))
		     (else (error "sub-sequence is neither vector or string" vec))))))
      (k vec 0
	 (cond ((vector? vec) (vector-length vec))
	       ((string? vec) (string-length vec))
	       (else (error "sub-sequence is neither vector or string" vec))))))


;;; e

(define-record e-interface eq)
(define e-interface make-e-interface)
(define %e=? e-interface-eq)
(define e=q (e-interface eq?))
(define e=v (e-interface eqv?))
(define e=l (e-interface equal?))
(define e=number (e-interface =))
(define e=char (e-interface char=?))
(define e=char-ci (e-interface char-ci=?))
(define e=string (e-interface string=?))
(define e=string-ci (e-interface string-ci=?))

;;; oe

(define-record oe-interface eq less)
(define oe-interface make-oe-interface)
(define %oe=? oe-interface-eq)
(define %oe<? oe-interface-less)
(define (%oe>? oe) 
  (let ((eq (oe-interface-eq oe))
	(less (oe-interface-less oe)) )
    (lambda (x y) (and (not (eq x y)) (not (less x y)))) ) )
(define %oe<=? (o complement %oe>?))
(define %oe>=? (o complement %oe<?))
(define e=%oe (o e-interface %oe=?))
(define oe=number (oe-interface = <))
(define oe=char (oe-interface char=? char<?))
(define oe=char-ci (oe-interface char-ci=? char-ci<?))
(define oe=string (oe-interface string=? string<?))
(define oe=string-ci (oe-interface string-ci=? string-ci<?))

;;* e=%i-of-%e
;;* oe=%i-of-%oe

;;; x

(define-record x-interface f)
(define x-interface make-x-interface)
(define %x x-interface-f)
(define x=not (x-interface not))
(define x=abs (x-interface abs))
(define x=add1 (x-interface add1))
(define x=sub1 (x-interface sub1))
(define x=car (x-interface car))
(define x=cdr (x-interface cdr))
(define x=integer->char (x-interface integer->char))
(define x=char->integer (x-interface char->integer))
(define x=upcase (x-interface char-upcase))
(define x=downcase (x-interface char-downcase))

;;; t

(define-record t-interface p)
(define t-interface make-t-interface)
(define %t? t-interface-p)
(define t=%e (o t-interface %e=?))

;;* t=%oe<
;;* t=%oe>
;;* t=%oe>=
;;* t=%oe<=

(define (t=not-%t t) 
  (let ((t? (%t? t)))
    (t-interface (lambda (v f) (not (t? v f))))))

(define (t=%x&%t x t)
  (let ((fn (%x x)) (t? (%t? t))) 
    (t-interface (lambda (v f) (t? (fn v) f)))))

(define t=if (t-interface (lambda (v f) (f v))))
(define t=if-not (t=not-%t t=if))
(define t=q (t-interface eq?))
(define t=v (t-interface eqv?))
(define t=l (t-interface equal?))
(define t=number (t-interface =))
(define t=char (t-interface char=?))
(define t=char-ci (t-interface char-ci=?))
(define t=string (t-interface string=?))
(define t=string-ci (t-interface string-ci=?))

;;; g

(define-record g-interface fold)
(define g-interface make-g-interface)
(define %g-fold g-interface-fold)

(define (g=%i i)
  (let ((read (%i-read i)))
    (g-interface
     (lambda (k n s)
       (let loop ((s s) (r n))
	 (call-with-values (cut read s)
	   (lambda results
	     (if (null? results)
		 r
		 (loop (cadr results) (k (car results) r))))))))))

(define (g=reverse-%i i)
  (let ((read (%i-read i)))
    (g-interface
     (lambda (k n s)
       (let loop ((s s))
	 (call-with-values (cut read s)
	   (lambda results
	     (if (null? results)
		 n
		 (k (car results) (loop (cadr results)))))))))))

(define (g=%v v) (g-interface (%v-fold-left v)))
(define (g=reverse-%v v) (g-interface %v-fold-right v))

(define (g=%g-%x g x)
  (let ((f1 (%g-fold g))
	(fn (%x x)) )
    (g-interface (lambda (k n s) (fn (f1 k n s)) ) ) ) )

(define g=iota
  (g-interface
    (lambda (kons knil n) 
      (let loop ((i 0) (klst knil)) 
	(if (fx= i n) klst (loop (fx+ i 1) (kons i klst))))) ) )

(define g=list
  (g-interface
    (lambda (kons knil lst) 
      (let loop ((lst lst) (klst knil)) 
	(if (null? lst) klst (loop (cdr lst) (kons (car lst) klst))))) ) ) 

(define g=reverse-list
  (g-interface
    (lambda (kons knil list) 
      (let loop ((list list)) 
	(if (null? list) knil (kons (car list) (loop (cdr list)))))) ) )

(define g=string
  (g-interface
   (lambda (kons knil str)
     (unwrap
      str
      (lambda (s start end)
	(do ((i start (fx+ i 1))
	     (r knil (kons (string-ref s i) r)))
	    ((fx>= i end) r) ) ) ) ) ) )

(define g=reverse-string
  (g-interface
   (lambda (kons knil str)
     (unwrap
      str
      (lambda (s start end)
	(do ((i (fx- end 1) (fx- i 1))
	     (r knil (kons (string-ref s i) r)))
	    ((fx< i start) r) ) ) ) ) ) )

(define g=vector
  (g-interface
   (lambda (kons knil vec)
     (unwrap
      vec
      (lambda (v start end)
	(do ((i start (fx+ i 1))
	     (r knil (kons (vector-ref v i) r)))
	    ((fx>= i end) r) ) ) ) ) ) )

(define g=reverse-vector
  (g-interface
   (lambda (kons knil vec)
     (unwrap
      vec
      (lambda (v start end)
	(do ((i (fx- end 1) (fx- i 1))
	     (r knil (kons (vector-ref v i) r)))
	    ((fx>= i start) r) ) ) ) ) ) )

(define g=port
  (g-interface
    (lambda (kons knil port) 
      (let loop ((klst knil)) 
	(let ((obj (read port)))
	  (if (eof-object? obj) klst (loop (kons obj klst))))))))

(define g=char-port
  (g-interface
    (lambda (kons knil port) 
      (let loop ((klst knil)) 
	(let ((obj (read-char port)))
	  (if (eof-object? obj) klst (loop (kons obj klst))))))))

(define g=line-port
  (g-interface
    (lambda (kons knil port) 
      (let loop ((klst knil)) 
	(let ((obj (read-line port)))
	  (if (eof-object? obj) klst (loop (kons obj klst))))))))

(define g=file
  (g-interface
    (lambda (kons knil file)
      (call-with-input-file file 
	(lambda (port)
	  (let loop ((klst knil)) 
	    (let ((obj (read port)))
	      (if (eof-object? obj) klst (loop (kons obj klst))))))))))

(define g=char-file
  (g-interface
    (lambda (kons knil file) 
      (call-with-input-file file 
	(lambda (port)
	  (let loop ((klst knil)) 
	    (let ((obj (read-char port)))
	      (if (eof-object? obj) klst (loop (kons obj klst))))))))))

(define g=line-file
  (g-interface
    (lambda (kons knil file) 
      (call-with-input-file file 
	(lambda (port)
	  (let loop ((klst knil)) 
	    (let ((obj (read-line port))) 
	      (if (eof-object? obj) klst (loop (kons obj klst))))))))))


;;; o

(define-record o-interface create write result)
(define o-interface make-o-interface)
(define %o-create o-interface-create)
(define %o-write o-interface-write)
(define %o-result o-interface-result)

(define o=count
  (o-interface
   (lambda (#!optional (dst 0)) dst)
   (lambda (obj out) (add1 out))
   identity) )

(define o=sum
  (o-interface
    (lambda (#!optional (dst 0)) dst)
    +
    identity) )

(define o=product
  (o-interface
    (lambda (#!optional (dst 1)) dst)
    *
    identity) )

(define o=min
  (o-interface
    (lambda (#!optional dst) dst)
    (lambda (obj out) (if out (min obj out) obj))
    identity) )

(define o=max
  (o-interface
    (lambda (#!optional dst) dst)
    (lambda (obj out) (if out (max obj out) obj))
    identity) )

(define o=list
  (o-interface 
    (cut cons '() #f)
    (lambda (obj out)
     (let ((p (list obj)) (d (cdr out))) 
       (if d (set-cdr! d p) (set-car! out p))
       (set-cdr! out p)
       out))
    car) )

(define o=reverse-list
  (o-interface
    (lambda (#!optional (dst '())) dst)
    cons
    identity) )

(define o=port
  (o-interface
   (lambda (#!optional (dst (current-output-port))) dst)
   (lambda (obj out) (write obj out) out)
   identity) )

(define o=char-port
  (o-interface
   (lambda (#!optional (dst (current-output-port))) dst)
   (lambda (obj out) (write-char obj out) out)
   identity) )

(define o=file
  (o-interface
   open-output-file
   (lambda (obj out) (write obj out) out)
   (each close-output-port identity) ) )

(define o=char-file
  (o-interface
   open-output-file
   (lambda (obj out) (write-char obj out) out)
   (each close-output-port identity) ) )


;;; a

(define-record a-interface unfold)
(define a-interface make-a-interface)
(define %a-unfold a-interface-unfold)

(define (a=%o o)
  (define o-create (%o-create o))
  (define o-write (%o-write o))
  (define o-result (%o-result o))
  (a-interface
    (lambda (dekons klist . ?dst)
     (let loop ((out (apply o-create ?dst)) (klist klist))
       (values-case (dekons klist)
         (() (o-result out))
         ((obj klist) (loop (o-write obj out) klist)))))))

(define (a=%mv mv)
  (define mv-modify (%mv-set! mv))
  (define mv-new (make-%mv mv))
  (a-interface
    (lambda (dekons klist)
     (let loop ((klist klist) (n 0) (els '()))
       (values-case (dekons klist)
         (() 
          (let ((mvec (mv-new n)))
	    (unwrap
	     mvec
	     (lambda (data dstart dend) 
	       (do ((i (- dend 1) (- i 1)) (els els (cdr els)))
		   ((null? els) 
		    mvec)
		 (mv-modify data i (car els)))))) )
	 ((obj klist)
	  (loop klist (+ n 1) (cons obj els))))))))

(define (a=reverse-%mv mv)
  (define mv-modify (%mv-set! mv))
  (define mv-new (make-%mv mv))
  (a-interface
    (lambda (dekons klist)
     (let loop ((klist klist) (n 0) (els '()))
       (values-case (dekons klist)
         (() 
          (let ((mvec (mv-new n)))
	    (unwrap
	     mvec
	     (lambda (data dstart dend)
	       (do ((i dstart (+ i 1)) (els els (cdr els)))
		   ((null? els) 
		    mvec)
		 (mv-modify data i (car els)))))))
         ((obj klist)
          (loop klist (+ n 1) (cons obj els))))))))

(define (a=%mv! mv)
  (define mv-modify (%mv-set! mv))
  (define mv-new (make-%mv mv))
  (a-interface
    (lambda (dekons klist dst)
      (unwrap
       dst
       (lambda (data dstart dend)
	 (let loop ((klist klist) (i dstart))
	   (if (>= i dend)
	       dst ;no more space: end here
	       (values-case 
		(dekons klist)
		(() 
		 dst) ;********** TODO: return sub if dst is not full
		((obj klist)
		 (mv-modify data i obj)
		 (loop klist (+ i 1)))))))))) )

(define (a=reverse-%mv! mv)
  (define mv-modify (%mv-set! mv))
  (define mv-new (make-%mv mv))
  (a-interface
    (lambda (dekons klist dst)
      (unwrap
       dst
       (lambda (data dstart dend)
	 (let loop ((klist klist) (i (- dend 1)))
	   (if (< i dstart)
	       dst ;no space: end here
	       (values-case (dekons klist)
			    (() 
			     dst)
			    ((obj klist)
			     (mv-modify data i obj)
			     (loop klist (- i 1)))))))))) )

(define (a=%x-%a x a)
  (define fn (%x x))
  (define a-unfold (%a-unfold a))
  (a-interface
    (lambda (dekons klist . ?dst)
      (apply a-unfold
	     (lambda (klist)
	       (values-case (dekons klist)
			    (() (values))
			    ((val klist) (values (fn val) klist))))
	     klist
	     ?dst))))

(define a=count (a=%o o=count))
(define a=sum (a=%o o=sum))
(define a=product (a=%o o=product))
(define a=min (a=%o o=min))
(define a=max (a=%o o=max))
(define a=list (a=%o o=list))
(define a=reverse-list (a=%o o=reverse-list))
(define a=port (a=%o o=port))
(define a=char-port (a=%o o=char-port))
(define a=file (a=%o o=file))
(define a=char-file (a=%o o=char-file))

(define a=and
  (a-interface
    (lambda (dekons klist #!optional (?dst #t))
     (and ?dst
       (let loop ((klist klist))
         (values-case (dekons klist)
           (() #t)
           ((val klist) (and val (loop klist)))))))))

(define a=or
  (a-interface
    (lambda (dekons klist #!optional ?dst)
     (or ?dst
       (let loop ((klist klist))
         (values-case (dekons klist)
           (() #f)
           ((val klist) (or val (loop klist)))))))))


;;; i

(define-record i-interface read)
(define i-interface make-i-interface)
(define %i-read i-interface-read)

(define (i=%v v)
  (define v-ref (%v-ref v))
  (i-interface
   (lambda (in)
     (unwrap
      in
      (lambda (data start end)
	(if (fx>= start end)
	    (values)
	    (values (v-ref data start) (sub data (fx+ start 1) end))))))))

(define (i=reverse-%v v)
  (define v-ref (%v-ref v))
  (i-interface
   (lambda (in)
     (unwrap
      in
      (lambda (data start end)
	(if (fx>= start end)
	    (values)
	    (let ((i (fx- end 1)))
	      (values (v-ref data i) (sub data start i)))))))))

(define i=list
  (i-interface
   (lambda (in)
     (if (null? in)
	 (values)
	 (values (car in) (cdr in))))))

(define i=vector
  (i-interface
   (lambda (in)
     (unwrap
      in
      (lambda (d s e)
	(if (fx>= s e)
	    (values)
	    (values (vector-ref d s) (sub d (fx+ s 1) e))))))))

(define i=reverse-vector
  (i-interface
   (lambda (in)
     (unwrap
      in
      (lambda (d s e)
	(if (fx>= s e)
	    (values)
	    (let ((i (fx- e 1)))
	      (values (vector-ref d i) (sub d s i)))))))))

(define i=string
  (i-interface
   (lambda (in)
     (unwrap
      in
      (lambda (d s e)
	(if (fx>= s e)
	    (values)
	    (values (string-ref d s) (sub d (fx+ s 1) e))))))))

(define i=reverse-string
  (i-interface
   (lambda (in)
     (unwrap
      in
      (lambda (d s e)
	(if (fx>= s e)
	    (values)
	    (let ((i (fx- e 1)))
	      (values (string-ref d i) (sub d s i)))))))))

(define i=port
  (i-interface
   (lambda (in)
     (let ((x (read in)))
       (if (eof-object? x)
	   (values)
	   (values x in) ) ) ) ) )

(define i=char-port
  (i-interface
   (lambda (in)
     (let ((x (read-char in)))
       (if (eof-object? x)
	   (values)
	   (values x in) ) ) ) ) )


;;; li

(define-record li-interface read empty? peek)
(define li-interface make-li-interface)
(define %li-read li-interface-read)
(define %li-empty? li-interface-empty?)
(define %li-peek li-interface-peek)
(define i=%li (o i-interface %li-read))

(define (li=%v v)
  (define v-ref (%v-ref v))
  (li-interface
   (lambda (in)
     (unwrap
      in
      (lambda (data start end)
	(if (fx>= start end)
	    (values)
	    (values (v-ref data start) (sub data (fx+ start 1) end))))))
   (lambda (in)
     (unwrap
      in
      (lambda (data start end)
	(fx>= start end) ) ) )
   (lambda (in)
     (unwrap
      in
      (lambda (data start end)
	(v-ref data start) ) ) ) ) )

(define (li=reverse-%v v)
  (define v-ref (%v-ref v))
  (li-interface
   (lambda (in)
     (unwrap
      in
      (lambda (data start end)
	(if (fx>= start end)
	    (values)
	    (let ((i (fx- end 1)))
	      (values (v-ref data i) (sub data start i)))))))
   (lambda (in)
     (unwrap
      in
      (lambda (data start end)
	(fx< end start) ) ) )
   (lambda (in)
     (unwrap
      in
      (lambda (data start end)
	(v-ref data start) ) ) ) ) )

(define li=list
  (li-interface
   (lambda (in)
     (if (null? in)
	 (values)
	 (values (car in) (cdr in))))
   null?
   car) )

(define li=vector
  (li-interface
   (lambda (in)
     (unwrap
      in
      (lambda (d s e)
	(if (fx>= s e)
	    (values)
	    (values (vector-ref d s) (sub d (fx+ s 1) e))))))
   (lambda (in)
     (unwrap
      in
      (lambda (d s e)
	(fx>= s e) ) ) )
   (lambda (in)
     (unwrap
      in
      (lambda (d s e)
	(vector-ref d s))))))

(define li=string
  (li-interface
   (lambda (in)
     (unwrap
      in
      (lambda (d s e)
	(if (fx>= s e)
	    (values)
	    (values (string-ref d s) (sub d (fx+ s 1) e))))))
   (lambda (in)
     (unwrap
      in
      (lambda (d s e)
	(fx>= s e) ) ) )
   (lambda (in)
     (unwrap
      in
      (lambda (d s e)
	(string-ref d s))))))

(define li=char-port
  (li-interface
   (lambda (in)
     (let ((x (read-char in)))
       (if (eof-object? x)
	   (values)
	   (values x in) ) ) ) 
   (complement char-ready?)
   peek-char) )


;;; v

(define-record v-interface length ref)
(define v-interface make-v-interface)
(define %v-length v-interface-length)
(define %v-ref v-interface-ref)

;;* %v-ref (defined on sub)

(define v=vector
  (v-interface 
   (lambda (vec)
     (unwrap vec (lambda (d s e) (fx- e s))) )
   (lambda (vec n)
     (unwrap vec (lambda (d s e) (vector-ref d (fx+ s n))) ) ) ) )

(define v=string
  (v-interface 
   (lambda (vec)
     (unwrap vec (lambda (d s e) (fx- e s))) )
   (lambda (vec n)
     (unwrap vec (lambda (d s e) (string-ref d (fx+ s n))) ) ) ) )

;;* v=symbol

(define (%v-fold-left v)
  (let ((ref (%v-ref v)))
    (lambda (kons knil vec)
      (unwrap
       vec
       (lambda (data dstart dend)
	 (let loop ((i dstart) (klist knil))
	   (if (fx= i dend) 
	       klist
	       (loop (fx+ i 1) (kons (ref data i) klist)))))) ) ) )

(define (%v-fold-right v)
  (let ((ref (%v-ref v)))
    (lambda (kons knil vec)
      (unwrap
       vec
       (lambda (data dstart dend)
	 (let loop ((i dstart))
	   (if (fx= i dend) 
	       knil
	       (kons (ref data i) (loop (fx+ i 1))))))))))


;;; mv

(define-record mv-interface length ref set! make)
(define mv-interface make-mv-interface)
(define %mv-length mv-interface-length)
(define %mv-ref mv-interface-ref)
(define %mv-set! mv-interface-set!)
(define make-%mv mv-interface-make)
(define (v=%mv mv) (v-interface (%mv-length mv) (%mv-ref mv)))

(define mv=vector
  (mv-interface 
   (lambda (vec)
     (unwrap vec (lambda (d s e) (vector-ref d s))) )
   (lambda (vec n)
     (unwrap vec (lambda (d s e) (vector-ref d (fx+ s n))) ) )
   (lambda (vec n obj)
     (unwrap
      vec
      (lambda (d s e) (vector-set! d (fx+ s n) obj)) ) )
   make-vector) )

(define mv=string
  (mv-interface 
   (lambda (vec)
     (unwrap vec (lambda (d s e) (string-ref d s))) )
   (lambda (vec n)
     (unwrap vec (lambda (d s e) (string-ref d (fx+ s n))) ) )
   (lambda (vec n obj)
     (unwrap
      vec
      (lambda (d s e) (string-set! d (fx+ s n) obj)) ) )
   make-string) )


;;; Algorithms

(define (%oe-min oe) ;; obj1 obj2 ... => obj
  (define lss (%oe<? oe))
  (define (oe-min obj1 . obj*)
    (let loop ((m obj1) (obj* obj*))
      (cond 
        ((null? obj*) m)
        ((lss (car obj*) m) (loop (car obj*) (cdr obj*)))
        (else (loop m (cdr obj*))))))
  oe-min)

(define (%oe-max oe) ;; obj1 obj2 ... => obj
  (define lss (%oe<? oe))
  (define (oe-max obj1 . obj*)
    (let loop ((m obj1) (obj* obj*))
      (cond 
        ((null? obj*) m)
        ((lss m (car obj*)) (loop (car obj*) (cdr obj*)))
        (else (loop m (cdr obj*))))))
  oe-max)

(define (%v-null? v) ;; vec => bool
  (define (v-null? vec)
    (unwrap
     vec
     (lambda (d s e) (eq? s e))))
  v-null?)

(define (sub%mv mv) ;; mvec start end => mvec
  (define mv-access (%mv-ref mv))
  (define mv-modify (%mv-set! mv))
  (define mv-new (make-%mv mv))
  (define (submv mvec start end)
    (unwrap
     mvec
     (lambda (data dstart dend)
      (let ((new-mvec (mv-new (fx- end start))))
	(unwrap
	 new-mvec
	 (lambda (new-data new-dstart new-dend)
	   (let ((istart (fx+ dstart start)) (iend (fx+ dstart end)))
	     (do ((i istart (fx+ i 1)) (j new-dstart (fx+ j 1)))
		 ((fx= i iend) new-mvec)
	       (mv-modify new-data j (mv-access data i))))))))))
  submv)
  
(define (%mv-copy mv) ;; mvec => mvec
  (define mv-access (%mv-ref mv))
  (define mv-modify (%mv-set! mv))
  (define mv-new (make-%mv mv))
  (define (mv-copy mvec)
    (unwrap
     mvec
     (lambda (data dstart dend)
      (let ((new-mvec (mv-new (fx- dend dstart))))
	(unwrap
	 new-mvec
	 (lambda (new-data new-dstart new-dend)
          (do ((i dstart (fx+ i 1)) (j new-dstart (fx+ j 1)))
            ((fx= i dend) new-mvec)
            (mv-modify new-data j (mv-access data i)))))))))
  mv-copy)

(define (%mv-fill! mv) ;; mvec obj => unspecified
  (define mv-modify (%mv-set! mv))
  (define (mv-fill! mvec obj)
    (unwrap
     mvec
     (lambda (data dstart dend)
      (do ((i dstart (fx+ i 1)))
        ((fx= i dend) (void))
        (mv-modify data i obj)))))
  mv-fill!)

(define (%mv-append mv) ;; mvec ... => mvec
  (define mv-access (%mv-ref mv))
  (define mv-modify (%mv-set! mv))
  (define mv-new (make-%mv mv))
  (define (mv-append . vecs)
    (define newlen
      (let loop ((len 0) (vecs vecs))
        (if (null? vecs) len
	    (unwrap
	     (car vecs)
	     (lambda (data dstart dend)
	       (loop (fx+ len (fx- dend dstart)) (cdr vecs)))))))
    (let ((new-mvec (mv-new newlen)))
      (unwrap
       new-mvec
       (lambda (mdata mdstart mdend) 
         (let loop ((i mdstart) (j 0) (data #f) (dend 0) (vecs vecs))
            (cond
              ((fx< j dend)
               (mv-modify mdata i (mv-access data j))
               (loop (fx+ i 1) (fx+ j 1) data dend vecs))
              ((null? vecs)
               new-mvec)
              (else
	       (unwrap
		(car vecs)
                (lambda (data dstart dend) 
                  (loop i dstart data dend (cdr vecs)))))))))))
  mv-append)

(define (%v->%mv v mv) ;; vec => mvec
  (define v-access (%v-ref v))
  (define mv-modify (%mv-set! mv))
  (define mv-new (make-%mv mv))
  (define (v->mv vec)
    (unwrap
     vec
     (lambda (data dstart dend)
      (let ((new-mvec (mv-new (fx- dend dstart))))
	(unwrap 
	 new-mvec
	 (lambda (new-data new-dstart new-dend)
          (do ((i dstart (fx+ i 1)) (j new-dstart (fx+ j 1)))
            ((fx= i dend) new-mvec)
            (mv-modify new-data j (v-access data i)))))))))
  v->mv)

(define (%v->%mv! v mv)  ;; vec mvec => unspecified
  (define v-access (%v-ref v))
  (define mv-modify (%mv-set! mv))
  (define (v->mv! vec mvec)
    (unwrap 
     vec
     (lambda (data dstart dend) 
       (unwrap
	mvec
	(lambda (mdata mdstart mdend)
	  (if (and (eq? data mdata) (fx< dstart mdstart))
	      ;;move-left
	      (let ((len (min (fx- dend dstart) (fx- mdend mdstart))))
              (do ((i (fx+ dstart len) (fx- i 1)) (j (fx+ mdstart len) (fx- j 1)))
		  ((fx= i dstart) (void))
                (mv-modify mdata (fx- j 1) (v-access data (fx- i 1)))))
	      ;;move-right
	      (do ((i dstart (fx+ i 1)) (j mdstart (fx+ j 1)))
		  ((or (= i dend) (= j mdend)) (void))
		(mv-modify mdata j (v-access data i)))))))))
  v->mv!)

(define (%mv mv) ;; obj ... => mvec
  (define mv-modify (%mv-set! mv))
  (define mv-new (make-%mv mv))
  (define (mvector . elements)
    (let ((new-mvec (mv-new (length elements))))
      (unwrap
       new-mvec
       (lambda (data dstart dend)
        (do ((i dstart (fx+ i 1)) (els elements (cdr els)))
	    ((null? els) new-mvec)
          (mv-modify data i (car els)))))) )
  mvector)

(define (%mv-reverse! mv) ;; mvec => unspecified
  (define mv-access (%mv-ref mv))
  (define mv-modify (%mv-set! mv))
  (define mv-new (make-%mv mv))
  (define (mv-reverse! mvec)
    (unwrap
     mvec
     (lambda (data dstart dend)
      (let loop ((s dstart) (e dend))
        (if (fx> (fx- e s) 1)
            (let ((tmp (mv-access data s)) (e-1 (fx- e 1)))
              (mv-modify data s (mv-access data e-1))
              (mv-modify data e-1 tmp)
              (loop (fx+ 1 s) e-1)))))))
  mv-reverse!)

;;** %g->%v
;;** %v->%a

(define (%mv-sort! mv)
  (define mv-access (%mv-ref mv))
  (define mv-modify (%mv-set! mv))
  (define (mv-partition data lss s e pivot)
    (let loop ((i s) (b s)) 
      (cond ((fx= i e) b)
            ((lss (mv-access data i) pivot)
             (let ((x (mv-access data i)) (y (mv-access data b)))
	       (mv-modify data b x) (mv-modify data i y))
	     (loop (+ i 1) (+ b 1)))
	    (else (loop (+ i 1) b)))))
  (define (mv-sort! mvec lss)
    (unwrap
     mvec
     (lambda (data dstart dend)
      (let sort ((s dstart) (e (fx- dend 1)))
        (if (fx< s e)
            (let ((b (mv-partition data lss s e (mv-access data e))))
              (let ((x (mv-access data b)) (y (mv-access data e)))
		(mv-modify data b y) (mv-modify data e x))
              (if (fx<= (fx- b s) (fx- e b))
                  (begin (sort s (fx- b 1)) (sort (fx+ b 1) e))
                  (begin (sort (fx+ b 1) e) (sort s (fx- b 1))))))))) )
  mv-sort!)

(define (%mv-stable-sort! mv)
  (define mv-access (%mv-ref mv))
  (define mv-modify (%mv-set! mv))
  (define (listify data dstart dend)
    (do ((i dstart (+ i 1)) (l '() (cons (mv-access data i) l)))
        ((= i dend) l)))
  (define (mv-stable-sort! mvec lss)
    (unwrap
     mvec
     (lambda (data dstart dend)
       (let ((lst (sort! (listify data dstart dend) lss)))
	 (do ((i dstart (fx+ i 1)) (l lst (cdr l)))
	     ((fx= i dend))
	   (mv-modify data i (car l)))))) )
  mv-stable-sort!) 

;;** %v-binary-%oe-search

(define (%a-tabulate a)
  (define a-unfold (%a-unfold a))
  (define (a-tabulate n i->x . ?dst)
    (apply a-unfold
      (lambda (i) (if (fx>= i n) (values) (values (i->x i) (fx+ 1 i))))
      0
      ?dst))
  a-tabulate)

(define (%a-iota a)
  ;; feed a with (shifted/scaled) [0..n[
  (define a-unfold (%a-unfold a))
  (define (start&step s&s)
    (cond ((null? s&s) (values 0 1))
          ((null? (cdr s&s)) (values (cdr s&s) 1))
          (else (values (car s&s) (cadr s&s)))))
  (define (a-iota n . args)
    (receive (start step) (start&step args)
      (a-unfold
        (lambda (i) 
          (if (fx>= i n) 
              (values)
              (values (fx+ start (fx* step i)) (fx+ 1 i))))
        0)))
  a-iota)

(define (make-%a a)
  ;; feed a with obj, repeated n times
  (define a-unfold (%a-unfold a))
  (define (make-a n obj . ?dst)
    (apply a-unfold
      (lambda (i) 
        (if (fx>= i n) 
            (values)
            (values obj (fx+ 1 i))))
      0
      ?dst))
  make-a)

(define (%a a)
  ;; feed a with specific arguments
  (define a-unfold (%a-unfold a))
  (lambda args
    (a-unfold
      (lambda (l) 
        (if (null? l)
            (values)
            (values (car l) (cdr l))))
      args)))

(define (%a* a)
  ;; feed a(dst) with specific arguments
  (define a-unfold (%a-unfold a))
  (lambda args
    (a-unfold
      (lambda (l) 
        (if (null? (cdr l))
            (values)
            (values (car l) (cdr l))))
      args
      (ftl:last args))))

(define (ftl:last lst)
  (if (null? (cdr lst)) 
      (car lst) 
      (ftl:last (cdr lst))))

(define (%i-next i)
  (let ((i-read (%i-read i))) 
    (lambda (in)
      (call-with-values 
        (lambda () (i-read in))
        (lambda (e in1) in1))))) ;2 values expected

(define (%i->%a i a)
  (define i-read (%i-read i))
  (define a-unfold (%a-unfold a))
  (define (i->a src . ?dst)
    (apply a-unfold i-read src ?dst))
  i->a)

(define (%i-map1->%a i a)
  (define i-read (%i-read i))
  (define a-unfold (%a-unfold a))
  ;optional dst is allowed if a supports it
  (define (i-map1->a fn src . ?dst)
    (apply 
      a-unfold 
      (lambda (in) 
        (values-case (i-read in)
          (() (values))
          ((obj in) (values (fn obj) in))))
      src
      ?dst))
  i-map1->a)

(define (%i-map->%a i a)
  (define i-read (%i-read i))
  (define a-unfold (%a-unfold a))
  ;a should be able to initialize with no dst
  (define (i-map->a fn src . src*)
    (if (null? src*)
        (a-unfold
          (lambda (in)
            (values-case (i-read in)
              (() (values))
              ((obj in) (values (fn obj) in))))
          src)
        (a-unfold 
          (lambda (in*) 
            (let heads ((il in*) (hl '()) (tl '()))
              (if (null? il)
                  (values 
                    (apply fn (reverse hl))
                    (reverse tl))
                  (values-case (i-read (car il))
                    (() ;shortest in ended
                     (values))
                    ((obj in)
                     (heads (cdr il) (cons obj hl) (cons in tl)))))))
          (cons src src*))))
  i-map->a)

(define (%i-filter-map->%a i a)
  (define i-read (%i-read i))
  (define a-unfold (%a-unfold a))
  ;a should be able to initialize with no dst
  (define (i-filter-map->a fn src . src*)
    (if (null? src*)
        (a-unfold
          (lambda (in)
            (let loop ((in in))
              (values-case (i-read in)
                (() (values))
                ((obj in)
                 (let ((val (fn obj)))
                   (if val (values val in) (loop in)))))))
          src)
        (a-unfold 
          (lambda (in*)
            (let loop ((in* in*)) 
              (let heads ((il in*) (hl '()) (tl '()))
                (if (null? il)
                    (let ((val (apply fn (reverse hl))))
                      (if val
                          (values val (reverse tl))
                          (loop (reverse tl))))
                    (values-case (i-read (car il))
                      (() ;shortest in ended
                       (values))
                      ((obj in)
                       (heads (cdr il) 
                         (cons obj hl) (cons in tl))))))))
          (cons src src*))))
  i-filter-map->a)

;;* %i-sub%v-position-%e
;;* %i-filter-map1->%a
;;* %i-mismatch-%e

(define (%g-length g) ;; src => n
  (define g-fold (%g-fold g))
  (define (g-length src)
    (g-fold (lambda (obj n) (+ n 1)) 0 src))
  g-length)

(define (%g-for-each g) ;; proc src => unspecified
  ;; maps an effect to generator's output
  (define g-fold (%g-fold g))
  (define (g-for-each proc src)
    (g-fold 
      (lambda (obj u) (proc obj))
      (void)
      src))
  g-for-each)

(define (%g-last g) ;; src => obj or #f
  ;; keeps the last element generator's output
  (define g-fold (%g-fold g))
  (define (g-last src)
    (g-fold 
      (lambda (obj prev) obj)
      #f ;consistent with %g-last-%t
      src))
  g-last)

(define (%g-count-%t g t) ;; pobj src => n
  ;; counts elements that pass the test
  (let ((g-fold (%g-fold g))
	(test (%t? t)))
    (define (g-count-t p src)
      (g-fold 
       (lambda (obj n)
	 (if (test obj p) (+ n 1) n))
       0
       src))
    g-count-t))

(define (%g-last-%t g t) ;; pobj src => obj or #f
  ;; keeps the last element satisfying the test
  ;; there's no first-%t, because stopping is not in g,
  ;; and enumerating until the end after the result is known
  ;; is useless and possibly ineffective
  (let ((g-fold (%g-fold g))
	(test (%t? t)))
    (define (g-last-t p src)
      (g-fold 
       (lambda (obj prev)
	 (if (test obj p) obj prev))
       #f ;caveat: may be a real element
       src))
    g-last-t))

(define (%g->%o g o) ;; src [dst] => res
  ;; basic generator->output copy
  (define g-fold (%g-fold g))
  (define o-create (%o-create o))
  (define o-write (%o-write o))
  (define o-result (%o-result o))
  (define (g->o src . ?dst)
    (o-result 
      (g-fold 
        o-write 
        (apply o-create ?dst) 
        src)))
  g->o)

(define (%g-append->%o g o) ;; src ... => res 
  ;; generator->output copy, multiple sources
  (define g-fold (%g-fold g))
  (define o-create (%o-create o))
  (define o-write (%o-write o))
  (define o-result (%o-result o))
  (define (g-append->o . src*)
    (let loop ((src* src*) (out (o-create)))
      (if (null? src*)
          (o-result out)
          (loop (cdr src*)
            (g-fold o-write out (car src*))))))
  g-append->o)

(define (%g-append->%o* g o) ;; src ... out => res 
  ;; generator->output copy, multiple sources followed by a dst
  (define g-fold (%g-fold g))
  (define o-create (%o-create o))
  (define o-write (%o-write o))
  (define o-result (%o-result o))
  (define (g-append->o* . args)
    (let loop ((lst args) (out (o-create (ftl:last args))))
      (if (null? (cdr lst))
          (o-result out)
          (loop (cdr lst)
            (g-fold o-write out (car lst))))))
  g-append->o*)

(define (%g->%o/%g-splicing g o g1) ;; src [dst] => res
  ;; generator->output copy with splicing
  ;; generalization of concatenate
  ;; simplification of %g-map1->%o/%g-splicing
  (define g-fold (%g-fold g))
  (define g1-fold (%g-fold g1))
  (define o-create (%o-create o))
  (define o-write (%o-write o))
  (define o-result (%o-result o))
  (define (g->o/g-splicing src . ?dst)
    (o-result 
      (g-fold 
        (lambda (src1 out)
          (g1-fold o-write out src1))
        (apply o-create ?dst) 
        src)))
  g->o/g-splicing)

(define (%g-map1->%o g o) ;; fn src [dst] => res
  ;; generator->output with remapping
  (define g-fold (%g-fold g))
  (define o-create (%o-create o))
  (define o-write (%o-write o))
  (define o-result (%o-result o))
  (define (g-map1->o fn src . ?dst)
    (o-result 
      (g-fold 
        (lambda (obj out) 
          (o-write (fn obj) out))
        (apply o-create ?dst) 
        src)))
  g-map1->o)

(define (%g-map1->%o/%g-splicing g o g1) ;; fn src [dst] => res
  ;; generator->output with remapping and splicing
  ;; generalization of append-map (map returns 0 or more "outputs")
  ;;  to be "spliced" into the result
  (define g-fold (%g-fold g))
  (define g1-fold (%g-fold g1))
  (define o-create (%o-create o))
  (define o-write (%o-write o))
  (define o-result (%o-result o))
  (define (g-map1->o/g-splicing fn src . ?dst)
    (o-result 
      (g-fold 
        (lambda (obj out)
          (g1-fold o-write out (fn obj)))
        (apply o-create ?dst) 
        src)))
  g-map1->o/g-splicing)

(define (%g-remove-%t->%o g t o) ;; pobj src [dst] => res
  ;; generator->output with selecting by predicate
  ;; cf. inversed-predicate versions: select, filter
  ;; makes more sense than filter in t=<equality> cases
  (let ((g-fold (%g-fold g))
	(test (%t? t))
	(o-create (%o-create o))
	(o-write (%o-write o))
	(o-result (%o-result o)))
    (define (g-remove-t->o p src . ?dst)
      (o-result 
       (g-fold 
        (lambda (obj out) 
          (if (test obj p) out (o-write obj out)))
        (apply o-create ?dst) 
        src)))
    g-remove-t->o) )

(define (%g-partition-%t->%o+%o g t o o1) ;; src [dst1 [dst2]] => res1 res2
  ;; generator->output with partitioning in two by predicate
  (define g-fold (%g-fold g))
  (define test (%t? t))
  (define o-create (%o-create o))
  (define o-write (%o-write o))
  (define o-result (%o-result o))
  (define o1-create (%o-create o1))
  (define o1-write (%o-write o1))
  (define o1-result (%o-result o1))
  (let ()
    (define (g-partition-t->o+o p src . ?dsts)
      (let ((outs
	     (g-fold 
	      (lambda (obj outs) 
		(if (test obj p) 
		    (cons (o-write obj (car outs)) (cdr outs))
		    (cons (car outs) (o1-write obj (cdr outs)))))
	      (if (null? ?dsts)
		  (cons (o-create) (o1-create))
		  (cons (o-create (car ?dsts)) 
			(apply o1-create (cdr ?dsts)))) 
	      src)))
	(values 
	 (o-result (car outs)) 
	 (o1-result (cdr outs))))) 
    g-partition-t->o+o) )

(define (%g-filter-map1->%o g o) ;; fn src [dst] => res
  ;; generator->output with selecting mapped non-false
  (define g-fold (%g-fold g))
  (define o-create (%o-create o))
  (define o-write (%o-write o))
  (define o-result (%o-result o))
  (let ()
    (define (g-filter-map1->o fn src . ?dst)
      (o-result 
       (g-fold 
        (lambda (obj out)
          (let ((val (fn obj))) 
            (if val (o-write val out) out)))
        (apply o-create ?dst) 
        src)))
    g-filter-map1->o) )

(define (%g-substitute-%t->%o g t o) ;; newobj pobj src [dst] => res
  ;; generator->output with substituting selected elements
  (define g-fold (%g-fold g))
  (define test (%t? t))
  (define o-create (%o-create o))
  (define o-write (%o-write o))
  (define o-result (%o-result o))
  (let ()
    (define (g-substitute-t->o new p src . ?dst)
      (o-result 
       (g-fold 
        (lambda (obj out)
          (o-write (if (test obj p) new obj) out))
        (apply o-create ?dst) 
        src)))
    g-substitute-t->o) )

(define (%i-andmap-%t i t) ;; pobj src => bool
  (define i-read (%i-read i))
  (define test (%t? t))
  (let ()
    (define (i-andmap-t p src)
    (let loop ((in src))
      (values-case (i-read in)
        (() (and))
        ((obj in)
         (and (test obj p) (loop in))))))
  i-andmap-t) )

(define (%i-ormap-%t i t) ;; pobj src => bool
  (define i-read (%i-read i))
  (define test (%t? t))
  (let ()
    (define (i-ormap-t p src)
    (let loop ((in src))
      (values-case (i-read in)
        (() (or))
        ((obj in) 
         (or (test obj p) (loop in))))))
  i-ormap-t) )

(define (%i-andmap i) ;; fn src1 src2 ... => bool
  (define i-read (%i-read i))
  (define (i-andmap fn src . src*)
    (if (null? src*)
        (let loop ((in src))
          (values-case (i-read in)
            (() (and))
            ((obj in) (and (fn obj) (loop in)))))
        (let loop ((in* (cons src src*)))
          (let heads ((il in*) (hl '()) (tl '()))
            (if (null? il)
                (and (apply fn (reverse hl))
                     (loop (reverse tl)))
                (values-case 
		 (i-read (car il))
		 (() ;shortest in ended
                   (and))
                  ((obj in)
                   (heads (cdr il) (cons obj hl) (cons in tl)))))))))
  i-andmap)

(define (%i-ormap i) ;; fn src1 src2 ... => bool
  (define i-read (%i-read i))
  (define (i-ormap fn src . src*)
    (if (null? src*)
        (let loop ((in src))
          (values-case (i-read in)
            (() (or))
            ((obj in) (or (fn obj) (loop in)))))
        (let loop ((in* (cons src src*)))
          (let heads ((il in*) (hl '()) (tl '()))
            (if (null? il)
                (or (apply fn (reverse hl))
                    (loop (reverse tl)))
                (values-case (i-read (car il))
                  (() ;shortest in ended
                   (or))
                  ((obj in)
                   (heads (cdr il) (cons obj hl) (cons in tl)))))))))
  i-ormap)

(define (%i-ref i) ;; src n => obj
  (define i-read (%i-read i))
  (define (i-ref src n)
    (let loop ((in src) (n n))
      (receive (obj in) (i-read in)
        (if (zero? n) 
            obj
            (loop in (- n 1))))))
  i-ref)

;;** %i-take->%a
;;** %i-take->%a+tail

;;* %i-index
;;* %i-head->%a
;;* %i-take-%t->%a
;;* %i-take-map1->%a
;;* %i-take-map->%a

(define (sub%i->%a i a) ;; src from to [dst] => res
  (define i-read (%i-read i))
  (define a-unfold (%a-unfold a))
  (define (subi->a src from to . ?dst)
    (apply 
     a-unfold 
     (lambda (n&in)
       (let ((n (car n&in)) (in (cdr n&in)))
	 (if (< n to) 
	     (values-case (i-read in)
			  (() (values))
			  ((obj in) (values obj (cons (+ n 1) in))))
	     (values))))
     (cons from src))
    ?dst)
  subi->a)

(define (%i-find-%t i t) ;; pobj src => obj or #f
  (define i-read (%i-read i))
  (define test (%t? t))
  (let ()
    (define (i-find-t p src)
    (let loop ((in src))
      (values-case (i-read in)
        (() 
         #f)
        ((obj in)
         (if (test obj p) obj (loop in))))))
  i-find-t) )

;ALGORITHM %i-position-%t
(define (%i-position-%t i t) ;; pobj src => n or #f
  (define i-read (%i-read i))
  (define test (%t? t))
  (let ()
    (define (i-position-t p src)
    (let loop ((in src) (pos 0))
      (values-case (i-read in)
        (() 
         #f)
        ((obj in)
         (if (test obj p) pos (loop in (+ pos 1)))))))
  i-position-t) )

;;** %li-member-%t
;;** %li-drop-%t
;;** %li-position-%t

;;** %li-take-%t->%a
;;** %li-take-%t->%a+tail
;;** %li-take-map->%a+tail

;;* o=%a-elements
;;* i=%g-elements

;;* %mv-splice-%g
;;* %mv-replace-from-%g


;;; Suggestions by Thomas Chust:

;;; A string output collector.
(define o=string
  (o-interface
   ;; create
   (lambda (#!optional dst)
     (or dst (open-output-string)))
   ;; write
   (lambda (obj out)
     (display obj out)
     out)
   ;; result
   get-output-string))

(define a=string
  (a=%o o=string))

;;; Map vectors to an equal size mutable vector.
(define (%v-map->%mv v mv)
  (let ((v-length (%v-length v))
	(v-ref (%v-ref v))
	(make-mv (make-%mv mv))
	(mv-set! (%mv-set! mv))
	(list->min (%i->%a i=list a=min)))
    (lambda (proc . vs)
      (let ((min-length (list->min (map v-length vs))))
	(do ((mvec (make-mv min-length))
	     (i 0 (fx+ i 1)))
	    ((>= i min-length) mvec)
	  (mv-set! mvec i (apply proc (map (cut v-ref <> i) vs))))))))

)

'end