;;;; -*- Scheme -*-

;;;
;;; FTL (Function Template Library) -- esl
;;;

;; This is a reference, not a "real" implementation,
;; so very few error checking is done.

;; check that we have all we need to proceed
'(cond-expand
  ((and 
     srfi-8    ;receive
     srfi-9    ;define-record-type
     srfi-16   ;case-lambda
     srfi-23   ;error
   )
   "OK"))

;; PLT scheme hack:
'(begin
  (require (lib "8.ss" "srfi"))
  (require (lib "9.ss" "srfi"))
  (require (lib "16.ss" "srfi"))
  (require (lib "23.ss" "srfi")))

;; Capture the values of standard functions used by FTL to
;; prevent infinite loops if they are replaced by FTL variants.
;; In real implementation, (let ((std:foo foo)...) define ... set! ...) 
;; or similar device should be used to capture all relevant bindings. 

(define std:min min)
(define std:max max)
(define std:list list)
(define std:null? null?)
(define std:length length)
(define std:list-tail list-tail)
(define std:list-ref list-ref)
(define std:reverse reverse)
(define std:assq assq)
(define std:memq memq)
(define std:map map)
(define std:for-each for-each)
(define std:string string)
(define std:make-string make-string)
(define std:string string)
(define std:string-length string-length)
(define std:string-ref string-ref)
(define std:string-set! string-set!)
(define std:string-copy string-copy)
(define std:string-fill! string-fill!)
(define std:string->list string->list)
(define std:list->string list->string)
(define std:substring substring)
(define std:string-append string-append)
(define std:string=? string<=?)
(define std:string<=? string<=?)
(define std:string<? string<?)
(define std:string>=? string>=?)
(define std:string>? string>?)
(define std:string-ci=? string-ci<=?)
(define std:string-ci<=? string-ci<=?)
(define std:string-ci<? string-ci<?)
(define std:string-ci>=? string-ci>=?)
(define std:string-ci>? string-ci>?)
(define std:string->symbol string->symbol)
(define std:symbol->string symbol->string)
(define std:vector vector)
(define std:make-vector make-vector)
(define std:vector-length vector-length)
(define std:vector-ref vector-ref)
(define std:vector-set! vector-set!)
(define std:vector-fill! vector-fill!)
(define std:vector->list vector->list)
(define std:list->vector list->vector)



;; Internal utils

;; macro to dispatch on # of returned values
(define-syntax values-case
  (syntax-rules ()
    ((values-case expr (formals . body) ...)
     (call-with-values (lambda () expr)
       (case-lambda (formals . body) ...)))))

(define ftl:unspecified 
  (if #f #t))

(define ftl:undefined 
  (lambda args (error "FTL Error: undefined effect!")))

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


;; Line-by-line read/write (exported by FTL)

(define (read-line . ?port)
  ;; read using 128-byte buffers
  (let loop ((p (if (null? ?port) (current-input-port) (car ?port))))
    (let ((buf (std:make-string 128)))
      (let loop1 ((i 0))
        (if (= i 128)
            (let ((buf1 (loop p)))
              (if (eof-object? buf1) 
                  buf
                  (std:string-append buf buf1)))
            (let ((c (read-char p)))
               (cond 
			     ((eof-object? c)
                  (if (> i 0) 
				      (std:substring buf 0 i)
					  c)) ;eof
                 ((char=? c #\newline) 
				  (std:substring buf 0 i))
                 (else
                  (std:string-set! buf i c)
                   (loop1 (+ 1 i))))))))))

(define (write-line str . ?port)
  (let ((p (if (null? ?port) (current-output-port) (car ?port))))
    (display str p)
	(newline p)))



;; Vector subranges are represented by <vec, start, end> records;
;; they store the original arguments with #f substituted for missing end.
;; If a subrange of a subrange is taken, "absolute" indices are calculated 
;; by the 'sub' constructor.

(define-record-type :sub
  (make-sub vec start end)
  sub?
  (vec sub-vec set-sub-vec!)
  (start sub-start set-sub-start!)
  (end sub-end set-sub-end!))

(define-syntax sub-case
  (syntax-rules (else)
    ((sub-case expr (formals . body) (else alt))
     (let ((x expr))
       (if (sub? x) 
           ((lambda formals . body) (sub-vec x) (sub-start x) (sub-end x)) 
           alt)))))

(define sub
  (case-lambda
    ((vec)
     vec)
    ((vec start)
     (sub-case vec
       ((vec start0 end0)
        (make-sub vec (+ start0 start) end0))
       (else
        (make-sub vec start #f))))
    ((vec start end)
     (sub-case vec
       ((vec start0 end0)
        (make-sub vec (+ start0 start) (+ start0 end)))
       (else
        (make-sub vec start end))))))


;; Interfaces

;; In the reference implementation, we don't pay much attention
;; to performance of template procedures, so interfaces are
;; represented as a-lists; it gives us the possibility to share
;; implementations between different "views" of the same data
;; structure and provide direct access to builtin functions
;; when they match the job at hand (even if the job is not
;; a primitive). Other ways to implement the specification
;; exist, with more strict type control and better high-order
;; performance.

;; macro to hide a-lists construction...
(define-syntax interface
  (syntax-rules ()
    ((interface)
     '())
    ((interface ((name . args) exp ...) . more)
     (cons (cons 'name (lambda args exp ...))
       (interface . more)))
    ((interface (name value) . more)
     (cons (cons 'name value)
       (interface . more)))))

;; .. and access
(define-syntax iref
  (syntax-rules ()
    ((iref int key default)
     (cond ((std:assq 'key int) => cdr)
           (else default)))
    ((iref int key)
     (cond ((std:assq 'key int) => cdr)
           ;(#t (error 'iref "no ~s in ~s" 'key int))
           (else ftl:undefined)))))



;; EQUALITY (e) / ORDER & EQUALITY (oe) / TEST (t)

;proper way to define a new e interface
(define (e-interface eq)
  (interface
    (eq eq)))

;proper way to define a new oe interface
(define (oe-interface eq lss)
  (interface
    (eq eq)
    (lss lss)))

;proper way to define a new t interface
(define (t-interface test)
  (interface
    (test test)))


;we cheat and cut corners, leaving proper ways to others.

;INTERFACE e=q
(define e=q
  (interface
    (eq eq?)
    ;cheat: direct access to builtins
    ))

;INTERFACE e=v
(define e=v
  (interface
    (eq eqv?)
    ;cheat: direct access to builtins
    ))

;INTERFACE e=l
(define e=l
  (interface
    (eq equal?)
    ;cheat: direct access to builtins
    ))

;INTERFACE oe=number
(define oe=number
  (interface
    (eq =)
    (lss <)
    ;cheat: direct access to builtins
    (gtr >)
    (leq <=)
    (geq >=)
    (min min)
    (max max)))

;INTERFACE oe=char
(define oe=char
  (interface
    (eq char=?)
    (lss char<?)
    ;cheat: direct access to builtins
    (gtr char>?)
    (leq char<=?)
    (geq char>=?)))

;INTERFACE oe=char-ci
(define oe=char-ci
  (interface
    (eq char-ci=?)
    (lss char-ci<?)
    ;cheat: direct access to builtins
    (gtr char-ci>?)
    (leq char-ci<=?)
    (geq char-ci>=?)))

;;INTERFACE e=number
;(define e=number oe=number) ;downcast

;;INTERFACE e=char
;(define e=char oe=char) ;downcast

;;INTERFACE e=char-ci
;(define e=char-ci oe=char-ci) ;downcast

;INTERFACE(CAST) e=%oe
(define (e=%oe oe)
  oe) ;downcast

;INTERFACE t=if
(define t=if 
  (interface 
    ((test v p) (p v))))

;INTERFACE t=if-not
(define t=if-not 
  (interface 
    ((test v p) (not (p v)))))

;INTERFACE(CAST) t=%e
(define (t=%e e)
  (define eq (iref e eq))
  (interface 
    (test eq)))

;INTERFACE t=%oe<
(define (t=%oe< oe)
  (define lss (iref oe lss))
  (interface 
    (test lss)))

;INTERFACE t=%oe>
(define (t=%oe> oe)
  (define lss (iref oe lss))
  (interface 
    ((test v p) (lss p v))))

;INTERFACE t=%oe>=
(define (t=%oe>= oe)
  (define lss (iref oe lss))
  (interface 
    ((test v p) (not (lss v p)))))

;INTERFACE t=%oe<=
(define (t=%oe<= oe)
  (define lss (iref oe lss))
  (interface 
    ((test v p) (not (lss p v)))))

;INTERFACE t=not-%t
(define (t=not-%t t)
  (define test (iref t test))
  (define (not-test v p) (not (test v p)))
  (interface 
    (test (iref t ntest not-test)))) ;support cheats

;;INTERFACE t=q
;(define t=q 
;  (t=%e e=q)) ;(almost) downcast

;;INTERFACE t=v
;(define t=v 
;  (t=%e e=v)) ;(almost) downcast

;;INTERFACE t=l
;(define t=l 
;  (t=%e e=l))  ;(almost) downcast

;;INTERFACE t=number
;(define t=number 
;  (t=%e e=number))  ;(almost) downcast

;;INTERFACE t=char
;(define t=char 
;  (t=%e e=char))    ;(almost) downcast

;;INTERFACE t=char-ci
;(define t=char-ci 
;  (t=%e e=char-ci)) ;(almost) downcast



;; Algorithms over e / oe / t

;ALGORITHM %e=?
(define (%e=? e) ;; obj1 obj2 => bool
  (iref e eq))

;; ((%e=? e=string-ci) "Template" "TemPLATE")
;; => #t

;ALGORITHM %oe=?
(define (%oe=? oe) ;; obj1 obj2 => bool
  (iref oe eq))

;ALGORITHM %oe<?
(define (%oe<? oe) ;; obj1 obj2 => bool
  (iref oe lss))

;ALGORITHM %oe>?
(define (%oe>? oe) ;; obj1 obj2 => bool
  (define lss (iref oe lss))
  (define (oe>? obj1 obj2)
    (lss obj2 obj1))
  (iref oe gtr oe>?)) ;support cheats
    
;ALGORITHM %oe>=?
(define (%oe>=? oe) ;; obj1 obj2 => bool
  (define lss (iref oe lss))
  (define (oe>=? obj1 obj2)
    (not (lss obj1 obj2)))
  (iref oe geq oe>=?)) ;support cheats

;ALGORITHM %oe<=?
(define (%oe<=? oe) ;; obj1 obj2 => bool
  (define lss (iref oe lss))
  (define (oe<=? obj1 obj2)
    (not (lss obj2 obj1)))
  (iref oe leq oe<=?)) ;support cheats

;; ((%oe<? oe=string-ci) "Template" "TemPLATE")
;; => #f
;; ((%oe<=? oe=string-ci) "Templa" "TemPLATE")
;; => #t


;ALGORITHM %oe-min
(define (%oe-min oe) ;; obj1 obj2 ... => obj
  (define lss (iref oe lss))
  (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*))))))
  (iref oe min oe-min)) ;support cheats

;ALGORITHM %oe-max
(define (%oe-max oe) ;; obj1 obj2 ... => obj
  (define lss (iref oe lss))
  (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*))))))
  (iref oe max oe-max)) ;support cheats

;; ((%oe-max oe=number) 3 2 9 1 4)
;; => 9

;; ((%oe-min oe=char-ci) #\B #\c #\a #\D)
;; => #\a


;ALGORITHM %t?
(define (%t? t) ;; obj pobj => bool 
  (iref t test))

;; ((%t? t=q) 4 4.0)
;; => #f ;could be either #t or #f
;; ((%t? t=number) 4 4.0)
;; => #t
;; ((%t? t=if) 4 even?)
;; => #t

 

;; TRANSFORMATION (x)

;proper way to define a new x interface
(define (x-interface fn)
  (interface
    (fn fn)))

;INTERFACE x=not
(define x=not 
  (interface (fn not)))

;INTERFACE x=abs
(define x=abs 
  (interface (fn abs)))

;INTERFACE x=add1
(define x=add1 
  (interface ((fn x) (+ x 1))))

;INTERFACE x=sub1
(define x=sub1 
  (interface ((fn x) (- x 1))))

;INTERFACE x=car
(define x=car 
  (interface (fn car)))

;INTERFACE x=cdr
(define x=cdr 
  (interface (fn cdr)))

;INTERFACE x=itoc
(define x=itoc 
  (interface (fn integer->char)))

;INTERFACE x=ctoi
(define x=ctoi 
  (interface (fn char->integer)))

;INTERFACE x=upcase
(define x=upcase 
  (interface (fn char-upcase)))

;INTERFACE x=downcase
(define x=downcase 
  (interface (fn char-downcase)))


;; Algorithms over x

;ALGORITHM %x
(define (%x x) ;; obj => obj 
  (iref x fn))

;; ((%x x=downcase) #\A)
;; => #\a




;; GENERALIZED VECTORS (v) / MUTABLE VECTORS (mv)

;proper way to define a new v interface
(define (v-interface unwrap access)
  (interface
    (unwrap unwrap)
    (access access)))

;proper way to define a new mv interface
(define (mv-interface unwrap access modify new)
  (interface
    (unwrap unwrap)
    (access access)
    (modify modify)
    (new new)))

;INTERFACE v=iota
(define v=iota
  (interface
    ((unwrap n) 
     (sub-case n
       ((n start0 end0)
        (values 0 start0 (or end0 n)))
       (else
        (values 0 0 n))))
     (access +)))

;INTERFACE v=symbol
(define v=symbol
  (interface
    ((unwrap sym) 
     (sub-case sym
       ((sym start0 end0)
        (let ((str (std:symbol->string sym)))
          (values str start0 (or end0 (std:string-length str)))))
       (else
        (let ((str (std:symbol->string sym)))
          (values str 0 (std:string-length str))))))
     (access std:string-ref)))

;INTERFACE mv=vector
(define mv=vector
  (interface
    ((unwrap vec)
     (sub-case vec
       ((vec start0 end0)
        (values vec start0 (or end0 (std:vector-length vec))))
       (else
        (values vec 0 (std:vector-length vec)))))
     (access std:vector-ref)
     (modify std:vector-set!)
     (new std:make-vector)
     ;cheats
     (fromlist std:list->vector)))

;;INTERFACE v=vector
;(define v=vector 
;  mv=vector) ;downcast

;INTERFACE mv=string
(define mv=string
  (interface
    ((unwrap str)
     (sub-case str
       ((str start0 end0)
        (values str start0 (or end0 (std:string-length str))))
       (else
        (values str 0 (std:string-length str)))))
     (access std:string-ref)
     (modify std:string-set!)
     (new std:make-string)
     ;cheats
     (fromlist std:list->string)))

;;INTERFACE v=string
;(define v=string 
;  mv=string) ;downcast

;INTERFACE(CAST) v=%mv
(define (v=%mv mv)
  mv) ;downcast



;; Algorithms over v

;ALGORITHM %v-length
(define (%v-length v) ;; vec => n
  (define v-unwrap (iref v unwrap))
  (define (v-length vec)
    (receive (data dstart dend) (v-unwrap vec)
      (- dend dstart)))
  (iref v length v-length)) ;support cheats

;; ((%v-length v=vector) '#(a b c))
;; => 3


;ALGORITHM %v-ref
(define (%v-ref v) ;; vec n => obj
  (define v-unwrap (iref v unwrap))
  (define v-access (iref v access))
  (define (v-ref vec n)
    (receive (data dstart dend) (v-unwrap vec)
      (v-access data (+ dstart n))))
  (iref v ref v-ref)) ;support cheats

;; ((%v-ref v=vector) '#(a b c) 1)
;; => b
;; ((%v-ref v=string) "abc" 1)
;; => #\b


;ALGORITHM %v-null?
(define (%v-null? v) ;; vec => bool
  (define v-unwrap (iref v unwrap))
  (define (v-null? vec)
    (receive (data dstart dend) (v-unwrap vec)
      (= dend dstart)))
  (iref v null? v-null?)) ;support cheats

;; ((%v-null? v=vector) '#())
;; => #t
;; ((%v-null? v=string) "a")
;; => #f


;ALGORITHM %v-fold-left
(define (%v-fold-left v) ;; kons knil vec => res
  (define v-unwrap (iref v unwrap))
  (define v-access (iref v access))
  (define (v-fold-left kons knil vec)
    (receive (data dstart dend) (v-unwrap vec)
      (let loop ((i dstart) (klist knil))
        (if (= i dend) 
            klist
            (loop (+ i 1) (kons (v-access data i) klist))))))
  (iref v fold-left v-fold-left)) ;support cheats

;; ((%v-fold-left v=vector) cons '() '#(1 2 3 4 5))
;; => (5 4 3 2 1)


;ALGORITHM %v-fold-right
(define (%v-fold-right v) ;; kons knil vec => res
  (define v-unwrap (iref v unwrap))
  (define v-access (iref v access))
  (define (v-fold-right kons knil vec)
    (receive (data dstart dend) (v-unwrap vec)
      (let loop ((i dstart))
        (if (= i dend) 
            knil
            (kons (v-access data i) (loop (+ i 1)))))))
  (iref v fold-right v-fold-right)) ;support cheats

;; ((%v-fold-right v=vector) cons '() '#(1 2 3 4 5))
;; => (1 2 3 4 5)



;; Algorithms over mv


;ALGORITHM %mv-set!
(define (%mv-set! mv) ;; mvec n obj => unspecified
  (define mv-unwrap (iref mv unwrap))
  (define mv-modify (iref mv modify))
  (define (mv-set! mvec n obj)
    (receive (data dstart dend) (mv-unwrap mvec)
      (mv-modify data (+ dstart n) obj)))
  (iref mv set! mv-set!)) ;support cheats

;; (let ((vec (vector 'a 'b))) ((%mv-set! mv=vector) vec 1 'c) vec)
;; => #(a c)


;ALGORITHM make-%mv
(define (make-%mv mv) ;; n [obj] => vec
  (iref mv new))

;; ((make-%mv mv=vector) 3 'c)
;; => #(c c c)


;ALGORITHM sub%mv
(define (sub%mv mv) ;; mvec start end => mvec
  (define mv-unwrap (iref mv unwrap))
  (define mv-access (iref mv access))
  (define mv-modify (iref mv modify))
  (define mv-new (iref mv new))
  (define (submv mvec start end)
    (receive (data dstart dend) (mv-unwrap mvec)
      (let ((new-mvec (mv-new (- end start))))
        (receive (new-data new-dstart new-dend) (mv-unwrap new-mvec)
          (let ((istart (+ dstart start)) (iend (+ dstart end)))
            (do ((i istart (+ i 1)) (j new-dstart (+ j 1)))
              ((= i iend) new-mvec)
              (mv-modify new-data j (mv-access data i))))))))
  (iref mv sub submv)) ;support cheats
  
;; ((sub%mv mv=string) "hello, world!" 2 4)
;; => "ll"


;ALGORITHM %mv-copy
(define (%mv-copy mv) ;; mvec => mvec
  (define mv-unwrap (iref mv unwrap))
  (define mv-access (iref mv access))
  (define mv-modify (iref mv modify))
  (define mv-new (iref mv new))
  (define (mv-copy mvec)
    (receive (data dstart dend) (mv-unwrap mvec)
      (let ((new-mvec (mv-new (- dend dstart))))
        (receive (new-data new-dstart new-dend) (mv-unwrap new-mvec)
          (do ((i dstart (+ i 1)) (j new-dstart (+ j 1)))
            ((= i dend) new-mvec)
            (mv-modify new-data j (mv-access data i)))))))
  (iref mv copy mv-copy)) ;support cheats

;; ((%mv-copy mv=string) "hello, world!")
;; => "hello, world!"
;; ((%mv-copy mv=string) (sub "hello, world!" 2 4))
;; => "ll"


;ALGORITHM %mv-fill!
(define (%mv-fill! mv) ;; mvec obj => unspecified
  (define mv-unwrap (iref mv unwrap))
  (define mv-modify (iref mv modify))
  (define (mv-fill! mvec obj)
    (receive (data dstart dend) (mv-unwrap mvec)
      (do ((i dstart (+ i 1)))
        ((= i dend) ftl:unspecified)
        (mv-modify data i obj))))
  (iref mv fill! mv-fill!)) ;support cheats

;; (let ((x (vector 1 2 3))) ((%mv-fill! mv=vector) x 44) x)
;; => #(44 44 44)
;; (let ((x (string-copy "Hello!"))) 
;;   ((%mv-fill! mv=string) (sub x 1 5) #\i) x)
;; => "Hiiii!"


;ALGORITHM %mv-resize
(define (%mv-resize mv) ;; mvec n [obj] => mvec
  (define mv-unwrap (iref mv unwrap))
  (define mv-access (iref mv access))
  (define mv-modify (iref mv modify))
  (define mv-new (iref mv new))
  (define (mv-resize mvec n . ?obj)
    (receive (data dstart dend) (mv-unwrap mvec)
      (let ((new-mvec (mv-new n)))
        (receive (new-data new-dstart new-dend) (mv-unwrap new-mvec)
          (do ((i dstart (+ i 1)) (j new-dstart (+ j 1)))
            ((or (= i dend) (= j new-dend))
             (if (and (< j new-dend) (pair? ?obj))
                 (let ((obj (car ?obj)))
                   (do ((j j (+ j 1))) ((= j new-dend) new-mvec)
                     (mv-modify new-data j obj))) 
                 new-mvec))
            (mv-modify new-data j (mv-access data i)))))))
  (iref mv resize mv-resize)) ;support cheats

;; ((%mv-resize mv=string) "Hello, FTL" 15 #\!)
;; => "Hello, FTL!!!!!"
;; ((%mv-resize mv=string) "Hello, FTL" 5)
;; => "Hello"
;; ((%mv-resize mv=string) (sub "Hello, FTL" 7) 5 #\!)
;; => "FTL!!"


;ALGORITHM %v->%mv
(define (%v->%mv v mv) ;; vec => mvec
  (define v-unwrap (iref v unwrap))
  (define v-access (iref v access))
  (define mv-unwrap (iref mv unwrap))
  (define mv-modify (iref mv modify))
  (define mv-new (iref mv new))
  (define (v->mv vec)
    (receive (data dstart dend) (v-unwrap vec)
      (let ((new-mvec (mv-new (- dend dstart))))
        (receive (new-data new-dstart new-dend) (mv-unwrap new-mvec)
          (do ((i dstart (+ i 1)) (j new-dstart (+ j 1)))
            ((= i dend) new-mvec)
            (mv-modify new-data j (v-access data i)))))))
  v->mv)

;; ((%v->%mv v=string mv=vector) "Franz Liszt")
;; => #(#\F #\r #\a #\n #\z #\space #\L #\i #\s #\z #\t)


;ALGORITHM %v->%mv!
(define (%v->%mv! v mv)  ;; vec mvec => unspecified
  ;; main idea of having v->mv! is to handle overlapping
  ;; cases correctly (i->a is better in all other cases)
  (define v-unwrap (iref v unwrap))
  (define v-access (iref v access))
  (define mv-unwrap (iref mv unwrap))
  (define mv-modify (iref mv modify))
  (define (v->mv! vec mvec)
    (receive (data dstart dend) (v-unwrap vec)
      (receive (mdata mdstart mdend) (mv-unwrap mvec)
        (if (and (eq? data mdata) (< dstart mdstart))
            ;move-left
            (let ((len (min (- dend dstart) (- mdend mdstart))))
              (do ((i (+ dstart len) (- i 1)) (j (+ mdstart len) (- j 1)))
                ((= i dstart) ftl:unspecified)
                (mv-modify mdata (- j 1) (v-access data (- i 1)))))
            ;move-right
            (do ((i dstart (+ i 1)) (j mdstart (+ j 1)))
              ((or (= i dend) (= j mdend)) ftl:unspecified)
              (mv-modify mdata j (v-access data i)))))))
  v->mv!)

;; (let ((x (string-copy "Hello!"))) 
;;   ((%v->%mv! v=vector mv=string) '#(#\E #\H #\E) (sub x 2 5)) x)
;; => "HeEHE!"
;; (let ((x (string-copy "0123456789"))) 
;;   ((%v->%mv! v=string mv=string) (sub x 0 5) (sub x 3 9)) x)
;; => "0120123489"
;; (let ((x (string-copy "0123456789"))) 
;;   ((%v->%mv! v=string mv=string) (sub x 3 9) (sub x 0 5)) x)
;; => "3456756789"


;ALGORITHM %mv-remove-%t!
(define (%mv-remove-%t! mv t) ;; pobj mvec => submvec
  (define mv-unwrap (iref mv unwrap))
  (define mv-access (iref mv access))
  (define mv-modify (iref mv modify))
  (define test (iref t test))
  (define (mv-remove-t! p mvec) 
    ;=> mvec or its sub
    (receive (data dstart dend) (mv-unwrap mvec)
      (let loop ((d dstart) (s dstart))
        (if (= s dend)
            (if (= d dend)
                mvec
                (sub-case mvec
                  ((mvec start end)
                   (make-sub mvec start d))
                  (else
                   (make-sub mvec 0 d))))
					  (let ((obj (mv-access data s)))
              (if (test obj p) 
                  (loop d (+ s 1))
                  (begin 
                    (if (> s d) (mv-modify data d obj)) 
                    (loop (+ d 1) (+ s 1)))))))))  
  mv-remove-t!)

;; (let ((s (string-copy "0a1b2c3d4e5f6g7h8i9j"))) 
;;   ((%mv-remove-%t! mv=string t=if) char-alphabetic? s))
;; => #[":sub" "01234567895f6g7h8i9j" 0 10]
;; (let ((s (string-copy "0a1b2c3d4e5f6g7h8i9j"))) 
;;   ((%mv-remove-%t! mv=string t=if) char-whitespace? s))
;; => "0a1b2c3d4e5f6g7h8i9j"


;ALGORITHM %mv
(define (%mv mv) ;; obj ... => mvec
  (define mv-unwrap (iref mv unwrap))
  (define mv-modify (iref mv modify))
  (define mv-new (iref mv new))
  (define (mvector . elements)
    (let ((new-mvec (mv-new (std:length elements))))
      (receive (data dstart dend) (mv-unwrap new-mvec)
        (do ((i dstart (+ i 1)) (els elements (cdr els)))
          ((null? els) new-mvec)
          (mv-modify data i (car els))))))
  (iref mv vector mvector)) ;support cheats

;; ((%mv mv=vector) 44 #\a 12)
;; => #(44 #\a 12)


;ALGORITHM list->%mv
(define (list->%mv mv) ;; list => mvec
  (define mv-unwrap (iref mv unwrap))
  (define mv-modify (iref mv modify))
  (define mv-new (iref mv new))
  (define (list->mv elements)
    (let ((new-mvec (mv-new (std:length elements))))
      (receive (data dstart dend) (mv-unwrap new-mvec)
        (do ((i dstart (+ i 1)) (els elements (cdr els)))
          ((null? els) new-mvec)
          (mv-modify data i (car els))))))
  (iref mv fromlist list->mv)) ;support cheats

;; ((list->%mv mv=vector) '(44 #\a 12))
;; => #(44 #\a 12)


;ALGORITHM %mv-append
(define (%mv-append mv) ;; mvec ... => mvec
  (define mv-unwrap (iref mv unwrap))
  (define mv-access (iref mv access))
  (define mv-modify (iref mv modify))
  (define mv-new (iref mv new))
  (define (mv-append . vecs)
    (define newlen
      (let loop ((len 0) (vecs vecs))
        (if (null? vecs) len
          (receive (data dstart dend) (mv-unwrap (car vecs))
            (loop (+ len (- dend dstart)) (cdr vecs))))))
    (let ((new-mvec (mv-new newlen)))
      (receive (mdata mdstart mdend) (mv-unwrap new-mvec)
         (let loop ((i mdstart) (j 0) (data #f) (dend 0) (vecs vecs))
            (cond
              ((< j dend)
               (mv-modify mdata i (mv-access data j))
               (loop (+ i 1) (+ j 1) data dend vecs))
              ((null? vecs)
               new-mvec)
              (else
                (receive (data dstart dend) (mv-unwrap (car vecs))
                  (loop i dstart data dend (cdr vecs)))))))))
  (iref mv append mv-append)) ;support cheats

;; ((%mv-append mv=string) "Franz" " " "Liszt")
;; => "Franz Liszt"
;; ((%mv-append mv=string) "Franz" (sub "[ ]" 1 2) "Liszt")
;; => "Franz Liszt"


;ALGORITHM sub%mv-replace
(define (sub%mv-replace mv) ;; mvec start end withmvec => mvec
  (define mv-append (%mv-append mv))
  (define (submv-replace mvec start end with-mvec)
    (mv-append
      (sub mvec 0 start)
      with-mvec
      (sub mvec end)))
  submv-replace)

;; ((sub%mv-replace mv=string)
;;  "It's easy to code it up in Scheme." 5 9 "lots of fun")
;; => "It's lots of fun to code it up in Scheme."


;ALGORITHM %mv-splice
(define (%mv-splice mv) ;; mvec n mvec2 => mvec
  (define mv-append (%mv-append mv))
  (define (mv-splice mvec pos mvec1)
    (mv-append (sub mvec 0 pos) mvec1 (sub mvec pos)))
  mv-splice)

;; ((%mv-splice mv=string)
;;  "It's easy to code it up in Scheme." 5 "incredibly ")
;; => "It's incredibly easy to code it up in Scheme."


;ALGORITHM sub%mv-delete
(define (sub%mv-delete mv) ;; mvec start end => mvec
  (define mv-append (%mv-append mv))
  (define (submv-delete mvec start end)
    (mv-append (sub mvec 0 start) (sub mvec end)))
  submv-delete)

;; ((sub%mv-delete mv=string)
;;  "It's easy to code it up in Scheme." 23 33)
;; => "It's easy to code it up."


;ALGORITHM %mv-reverse!
(define (%mv-reverse! mv) ;; mvec => unspecified
  (define mv-unwrap (iref mv unwrap))
  (define mv-access (iref mv access))
  (define mv-modify (iref mv modify))
  (define mv-new (iref mv new))
  (define (mv-reverse! mvec)
    (receive (data dstart dend) (mv-unwrap mvec)
      (let loop ((s dstart) (e dend))
        (if (> (- e s) 1)
            (let ((tmp (mv-access data s)) (e-1 (- e 1)))
              (mv-modify data s (mv-access data e-1))
              (mv-modify data e-1 tmp)
              (loop (+ 1 s) e-1))))))
  (iref mv reverse! mv-reverse!)) ;support cheats


;ALGORITHM %v-sorted?
(define (%v-sorted? v) ;; vec less => bool
  (define v-unwrap (iref v unwrap))
  (define v-access (iref v access))
  (define (v-sorted? vec lss)
    (receive (data dstart dend) (v-unwrap vec)
		  (or (<= (- dend dstart) 1) 
          (let loop ((x (v-access data dstart)) (i (+ dstart 1)))
					  (let ((y (v-access data i)))
						  (if (lss y x) 
							    #f 
							    (if (< (+ i 1) dend)
											(loop y (+ i 1))
											#t))))))) 
  (iref v sorted? v-sorted?)) ;support cheats

;ALGORITHM %v-%oe-sorted?
(define (%v-%oe-sorted? v oe) ;; vec => bool
  (define v-sorted? (%v-sorted? v))
  (define lss (iref oe lss))
  (define (v-oe-sorted? vec)
	  (v-sorted? vec lss))
	v-oe-sorted?)

;; ((%v-%oe-sorted? v=string oe=char-ci) "eEiIoOpPqQrRTtUuWwyY")
;; => #t


;ALGORITHM %mv-sort!
(define (%mv-sort! mv) ;; vec less => unspecified 
  ;allowed to be be non-stable - we go with naive quicksort
  (define mv-unwrap (iref mv unwrap))
  (define mv-access (iref mv access))
  (define mv-modify (iref mv modify))
	(define (mv-partition data lss s e pivot)
    (let loop ((i s) (b s)) 
			(cond ((= 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)
    (receive (data dstart dend) (mv-unwrap mvec)
      (let sort ((s dstart) (e (- dend 1)))
        (if (< 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 (<= (- b s) (- e b))
                  (begin (sort s (- b 1)) (sort (+ b 1) e))
                  (begin (sort (+ b 1) e) (sort s (- b 1)))))))))
  (iref mv sort! mv-sort!)) ;support cheats

;ALGORITHM %mv-%oe-sort!
(define (%mv-%oe-sort! mv oe) ;; vec => unspecified
  (define mv-sort! (%mv-sort! mv))
  (define lss (iref oe lss))
  (define (mv-oe-sort! mvec)
	  (mv-sort!	mvec lss))
	mv-oe-sort!)

;; (let ((s (string-copy "QWERTYUIOPqwertyuiop")))
;;	 ((%mv-%oe-sort! mv=string oe=char-ci) s)
;;	 s)
;; => "eEiIoOpPqQrRTtUuWwyY"


;ALGORITHM %mv-stable-sort!
(define (%mv-stable-sort! mv) ;; vec less => unspecified
  ;required to be stable - merge-sort via a list
  (define mv-unwrap (iref mv unwrap))
  (define mv-access (iref mv access))
  (define mv-modify (iref mv modify))
	(define (merge! lst1 lst2 lss) 
		(cond
			((null? lst1) lst2)
			((null? lst2) lst1)
			((lss (car lst2) (car lst1))
			 (set-cdr! lst2 (merge! lst1 (cdr lst2) lss))
			 lst2)
			(else (set-cdr! lst1 (merge! (cdr lst1) lst2 lss)) lst1)))
	(define (split! lst)
		(if (null? lst)
				lst
				(let loop ((hd lst) (tl (cdr lst)))
					(if (or (null? tl) (null? (cdr tl)))
							(let ((x (cdr hd))) (set-cdr! hd '()) x)
							(loop (cdr hd) (cddr tl))))))
	(define (sort! lst lss) 
		(if (or (null? lst) (null? (cdr lst))) 
        lst
        (let ((lst2 (split! lst)))
					(merge! (sort! lst lss) (sort! lst2 lss) lss))))
  (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)
    (receive (data dstart dend) (mv-unwrap mvec)
	    (let ((lst (sort! (listify data dstart dend) lss)))
		    (do ((i dstart (+ i 1)) (l lst (cdr l)))
          ((= i dend))
				  (mv-modify data i (car l)))))) 
  (iref mv stable-sort! mv-stable-sort!)) ;support cheats


;ALGORITHM %mv-stable-%oe-sort!
(define (%mv-stable-%oe-sort! mv oe) ;; vec => unspecified
  (define mv-stable-sort! (%mv-stable-sort! mv))
  (define lss (iref oe lss))
  (define (mv-stable-oe-sort! mvec)
	  (mv-stable-sort! mvec lss))
	mv-stable-oe-sort!)

;; (let ((s (string-copy "QWERTYUIOPqwertyuiop")))
;;	 ((%mv-stable-%oe-sort! mv=string oe=char-ci) s)
;;	 s)
;; => "eEiIoOpPqQrRtTuUwWyY"


;ALGORITHM %mv-remove-adjacent-duplicates!
(define (%mv-remove-adjacent-duplicates! mv) ;; mvec eq => subvec
  (define mv-unwrap (iref mv unwrap))
  (define mv-access (iref mv access))
  (define mv-modify (iref mv modify))
  (define (mv-remove-adjacent-duplicates! mvec eq) 
    ;=> mvec or its sub
    (receive (data dstart dend) (mv-unwrap mvec)
		  (if (<= (- dend dstart) 1)
          mvec 
          (let loop ((x (mv-access data dstart)) 
                     (d (+ dstart 1)) 
                     (s (+ dstart 1)))
            (if (= s dend)
                (if (= d dend)
                    mvec
                    (sub-case mvec
                      ((mvec start end)
                       (make-sub mvec start d))
                      (else
                       (make-sub mvec 0 d))))
					      (let ((y (mv-access data s)))
                  (if (eq x y) 
                      (loop x d (+ s 1))
                      (begin 
                        (if (> s d) (mv-modify data d y)) 
                        (loop y (+ d 1) (+ s 1))))))))))  
  mv-remove-adjacent-duplicates!)

;ALGORITHM %mv-remove-adjacent-%e-duplicates!
(define (%mv-remove-adjacent-%e-duplicates! mv e) ;; vec => subvec
  (define mv-remove-adjacent-duplicates! 
    (%mv-remove-adjacent-duplicates! mv))
  (define eq (iref e eq))
  (define (mv-remove-adjacent-e-duplicates! mvec)
	  (mv-remove-adjacent-duplicates! mvec eq))
	mv-remove-adjacent-e-duplicates!)

;; (let ((s (string-copy "QWERTYUIOPqwertyuiop")))
;;	 ((%mv-%oe-sort! mv=string oe=char-ci) s)
;;   ((%mv-remove-adjacent-%e-duplicates! mv=string (e=%oe oe=char-ci)) s))
;; => #[":sub" "eiopqrTUWyrRTtUuWwyY" 0 10]


;ALGORITHM %v-binary-search
(define (%v-binary-search v) ;; vec obj less => n or #f
  (define v-unwrap (iref v unwrap))
  (define v-access (iref v access))
  ;unlike SRFI 43, we use the same lss as in sort
  (define (v-binary-search vec obj lss)
    (receive (data dstart dend) (v-unwrap vec)
      (let search ((s dstart) (e dend))
        (let ((len (- e s)))
          (case len
            ((0) 
             #f)
            ((1) 
             (let ((x (v-access data s)))
               (if (or (lss x obj) (lss obj x)) 
                   #f
                   (- s dstart)))) ;relative!
            (else
             (let ((i (+ s (quotient len 2))))
               (let ((x (v-access data i)))
                 (cond
                   ((lss obj x) (search s i))
                   ((lss x obj) (search (+ i 1) e))
                   (else (- i dstart)))))))))))
  (iref v binary-search v-binary-search)) ;support cheats

;ALGORITHM %v-position-%oe/sorted
(define (%v-position-%oe/sorted v oe) ;; obj vec => n or #f
  (define v-binary-search (%v-binary-search v))
  (define lss (iref oe lss))
  (define (v-position-oe/sorted obj vec)
	  (v-binary-search vec obj lss))
	v-position-oe/sorted)

;; ((%v-position-%oe/sorted v=string oe=char-ci) #\I "eEiIoOpPqQrRtTuUwWyY")
;; => 2  ;actually, position of i, but that's OK for -ci search
;; ((%v-position-%oe/sorted v=string oe=char-ci) #\S "eEiIoOpPqQrRtTuUwWyY")
;; => #f
;; ((%v-position-%oe/sorted v=string oe=char-ci) #\Q 
;;  (sub "eEiIoOpPqQrRtTuUwWyY" 4 10))
;; => 5  ;relative to sub's start




;; GENERALIZED LISTS (l, rl, ml, rml)

;proper way to define a new l interface
(define (l-interface null? car cdr)
  (interface
    (null? null?)
    (car car)
		(cdr cdr)))

;rl has the same structure as l -- extra restrictions are implicit
(define rl-interface l-interface) 

;proper way to define a new ml interface
(define (ml-interface null? car cdr set-car!)
  (interface
    (null? null?)
    (car car)
		(cdr cdr)
		(set-car! set-car!)))

;rml has the same structure as ml -- extra restrictions are implicit
(define rml-interface ml-interface) 


;INTERFACE rml=list
(define rml=list
  (interface
	  (null? null?)
		(car car)
		(cdr cdr)
		(set-car! set-car!)
		;cheats
		(tail std:list-tail)
		(ref std:list-ref)))

;;INTERFACE ml=list
;(define ml=list 
;  rml=list) ;downcast

;;INTERFACE rl=list
;(define rl=list 
;  rml=list) ;downcast

;;INTERFACE l=list
;(define l=list 
;  rml=list) ;downcast

;INTERFACE rml=sublists
(define rml=sublists
  (interface
	  (null? null?)
		(car values)
		(cdr cdr)))

;INTERFACE l=char-port
(define l=char-port
  (interface
	  ((null? p) (eof-object? (peek-char p)))
		(car peek-char)
		(cdr read-char)))

;INTERFACE rl=%v
(define (rl=%v v)
  (define v-unwrap (iref v unwrap))
  (define v-access (iref v access))
  (interface
    ((null? vec) 
     (receive (data dstart dend) (v-unwrap vec)
       (= dend dstart)))
    ((car vec)
     (receive (data dstart dend) (v-unwrap vec)
       (v-access data dstart)))
    ((cdr vec)
     (sub-case vec
       ((vec start0 end0)
        (make-sub vec (+ start0 1) end0))
       (else
        (make-sub vec 1 #f))))))

;;INTERFACE l=%v
;(define l=%v 
;  rl=%v) ;downgrade

;INTERFACE rml=%mv
(define (rml=%mv mv)
  (define mv-unwrap (iref mv unwrap))
  (define mv-access (iref mv access))
  (define mv-modify (iref mv modify))
  (interface
    ((null? vec) 
     (receive (data dstart dend) (mv-unwrap vec)
       (= dend dstart)))
    ((car vec)
     (receive (data dstart dend) (mv-unwrap vec)
       (mv-access data dstart)))
    ((set-car! vec obj)
     (receive (data dstart dend) (mv-unwrap vec)
       (mv-modify data dstart obj)))
    ((cdr vec)
     (sub-case vec
       ((vec start0 end0)
        (make-sub vec (+ start0 1) end0))
       (else
        (make-sub vec 1 #f))))))

;;INTERFACE ml=%mv
;(define ml=%mv
;  rml=%mv) ;downgrade

;INTERFACE rl=reverse-%v
(define (rl=reverse-%v v)
  (define v-unwrap (iref v unwrap))
  (define v-access (iref v access))
  (interface
    ((null? vec) 
     (receive (data dstart dend) (v-unwrap vec)
       (= dend dstart)))
    ((car vec)
     (receive (data dstart dend) (v-unwrap vec)
       (v-access data (- dend 1))))
    ((cdr vec)
     (sub-case vec
       ((vec start0 end0)
        (make-sub vec start0 (- end0 1)))
       (else
			  (receive (data dstart dend) (v-unwrap vec)
          (make-sub vec 0 (- dend dstart 1))))))))

;;INTERFACE l=reverse-%v
;(define l=reverse-%v 
;  rl=reverse-%v) ;downgrade

;INTERFACE rml=reverse-%mv
(define (rml=reverse-%mv mv)
  (define mv-unwrap (iref mv unwrap))
  (define mv-access (iref mv access))
  (define mv-modify (iref mv modify))
  (interface
    ((null? vec) 
     (receive (data dstart dend) (mv-unwrap vec)
       (= dend dstart)))
    ((car vec)
     (receive (data dstart dend) (mv-unwrap vec)
       (mv-access data (- dend 1))))
    ((set-car! vec obj)
     (receive (data dstart dend) (mv-unwrap vec)
       (mv-modify data (- dend 1) obj)))
    ((cdr vec)
     (sub-case vec
       ((vec start0 end0)
        (make-sub vec start0 (- end0 1)))
       (else
			  (receive (data dstart dend) (mv-unwrap vec)
          (make-sub vec 0 (- dend dstart 1))))))))

;;INTERFACE ml=reverse-%mv
;(define ml=reverse-%mv
;  rml=reverse-%mv) ;downgrade

;INTERFACE(CAST) l=%ml
(define (l=%ml ml)
   ml) ;downcast

;INTERFACE(CAST) ml=%rml
(define (ml=%rml rml) 
  rml) ;downcast

;INTERFACE(CAST) l=%rl
(define (l=%rl rl)
  rl) ;downcast

;INTERFACE(CAST) rl=%rml
(define (rl=%rml rml)
  rml) ;downcast

;INTERFACE(CAST) l=%rml
(define (l=%rml rml)
  rml) ;downcast


;; Membership tests	as extensiond of e to rl

;INTERFACE t=%rl-%e-member
(define (t=%rl-%e-member rl e)
  (define rl-null? (iref rl null?))
  (define rl-car (iref rl car))
  (define rl-cdr (iref rl cdr))
  (define eq (iref e eq))
  (define (rle-member v p)
    (let loop ((lst p))
		  (cond
			  ((rl-null? lst) #f)
				((eq v (rl-car lst)) #t)
				(else (loop (rl-cdr lst))))))
  (interface (test rle-member)))


;same thing, better readability

;INTERFACE t=%rl-%e-members
(define t=%rl-%e-members 
  t=%rl-%e-member)

;string extensions traditionally have shorter names

;INTERFACE t=string-member
(define t=string-member 
  (t=%rl-%e-member (rl=%v (v=%mv mv=string)) (e=%oe oe=char)))

;INTERFACE t=string-members
(define t=string-members 
  t=string-member)

;INTERFACE t=string-ci-member
(define t=string-ci-member 
  (t=%rl-%e-member (rl=%v (v=%mv mv=string)) (e=%oe oe=char-ci)))

;INTERFACE t=string-ci-members
(define t=string-ci-members t=string-ci-member)


;; Algorithms over l / rl / ml / rml

;ALGORITHM %l-null?
(define (%l-null? l) ;; lis => bool 
  (iref l null?))

;ALGORITHM %l-car
(define (%l-car l) ;; lis => obj
  (iref l car))

;ALGORITHM %l-cdr
(define (%l-cdr l) ;; lis => lis
  (iref l cdr))

;ALGORITHM %ml-set-car!
(define (%ml-set-car! ml) ;; mlis obj => unspecified 
  (iref ml set-car!))


;ALGORITHM %l-tail
(define (%l-tail l) ;; lis n => lis
  (define l-cdr (iref l cdr))
  (define (l-tail lst n)
    (let loop ((lst lst) (n n))
      (if (zero? n)
          lst
          (loop (l-cdr lst) (- n 1)))))
  (iref l tail l-tail)) ;support cheats


;ALGORITHM %l-ref
(define (%l-ref l) ;; lis n => obj
  (define l-cdr (iref l cdr))
  (define l-car (iref l car))
  (define (l-ref lst n)
    (let loop ((lst lst) (n n))
      (if (zero? n) 
          (l-car lst)
          (loop (l-cdr lst) (- n 1)))))
  (iref l ref l-ref)) ;support cheats


;ALGORITHM %ml-set!
(define (%ml-set! ml) ;; lis n obj => unspecified
  (define ml-cdr (iref ml cdr))
  (define ml-set-car! (iref ml set-car!))
  (define (ml-set! lst n obj)
    (let loop ((lst lst) (n n))
      (if (zero? n) 
          (ml-set-car! lst obj)
          (loop (ml-cdr lst) (- n 1)))))
  (iref ml set! ml-set!)) ;support cheats


;ALGORITHM %l-member-%t
(define (%l-member-%t l t) ;; pobj lis => lis or #f
  (define l-null? (iref l null?))
  (define l-car (iref l car))
  (define l-cdr (iref l cdr))
  (define test (iref t test))
  (define (l-member-t p lst)
    (let loop ((lst lst))
      (if (l-null? lst)
          #f
          (let ((obj (l-car lst)))
            (if (test obj p) 
                lst
                (loop (l-cdr lst)))))))
  l-member-t)


;ALGORITHM %l-drop-%t
(define (%l-drop-%t l t) ;; pobj lis => lis
  (define l-null? (iref l null?))
  (define l-car (iref l car))
  (define l-cdr (iref l cdr))
  (define test (iref t test))
  (define (l-drop-t p lst)
    (let loop ((lst lst))
      (if (l-null? lst)
          lst
          (let ((obj (l-car lst)))
            (if (test obj p) 
                (loop (l-cdr lst))
                lst)))))
  l-drop-t)


;ALGORITHM %l-take->%a+tail
(define (%l-take->%a+tail l a) ;; lis n [dst] => res lis
  (define l-null? (iref l null?))
  (define l-car (iref l car))
  (define l-cdr (iref l cdr))
  (define a-unfold (iref a unfold))
  (define (l-take->a+tail lst n . ?dst)
    (define tail lst)
    (let ((res
            (apply 
              a-unfold 
              (lambda (n&lst)
                (let ((n (car n&lst)) (lst (cdr n&lst)))
                  (set! tail lst)
                  (if (and (> n 0) (not (l-null? lst)))
                      (values 
											  (l-car lst) 
												(cons (- n 1) (l-cdr lst)))
                      (values))))
              (cons n lst) 
              ?dst)))
      (values res lst)))
  l-take->a+tail)


;ALGORITHM %l-take-%t->%a+tail
(define (%l-take-%t->%a+tail l t a) ;; pobj lis [dst] => res lis
  (define l-null? (iref l null?))
  (define l-car (iref l car))
  (define l-cdr (iref l cdr))
  (define test (iref t test))
  (define a-unfold (iref a unfold))
  (define (l-take-t->a+tail p lst . ?dst)
    (define tail lst)
    (let ((res
            (apply 
              a-unfold 
              (lambda (lst)
                (set! tail lst)
                (if (l-null? lst)
								    (values)
								    (let ((obj (l-car lst)))
										  (if (test obj p)
											    (values obj (l-cdr lst))
													(values)))))
              lst 
              ?dst)))
      (values res lst)))
  l-take-t->a+tail)


;ALGORITHM %l-take-map->%a+tail
(define (%l-take-map->%a+tail l a) ;; fn lis [dst] => res lis
  (define l-null? (iref l null?))
  (define l-car (iref l car))
  (define l-cdr (iref l cdr))
  (define a-unfold (iref a unfold))
  (define (l-take-map->a+tail fn lst . ?dst)
    (define tail lst)
    (let ((res
            (apply 
              a-unfold 
              (lambda (lst)
                (set! tail lst)
                (if (l-null? lst)
								    (values)
								    (let ((val (fn (l-car lst))))
										  (if val
											    (values val (l-cdr lst))
													(values)))))
              lst 
              ?dst)))
      (values res lst)))
  l-take-map->a+tail)


;ALGORITHM %rl-remove-%e-duplicates->%a
(define (%rl-remove-%e-duplicates->%a rl e a) ;; rlis [dst] => res
  ;quadratic/stable - always leaves the last of dups
  (define rl-null? (iref rl null?))
  (define rl-car (iref rl car))
  (define rl-cdr (iref rl cdr))
	(define eq (iref e eq))
  (define a-unfold (iref a unfold))
	(define (rl-lastsuch-e elt lst)
	  (let loop ((lst lst))
		  (cond ((rl-null? lst) #t)
			      ((eq elt (rl-car lst)) #f)
						(else (loop (rl-cdr lst))))))
  (define (rl-remove-e-duplicates->a lst . ?dst)
    (apply 
      a-unfold 
      (lambda (lst)
			  (let loop ((lst lst))
          (if (rl-null? lst)
					  	(values)
						  (let ((elt (rl-car lst)))
						    (if (rl-lastsuch-e elt lst)
										(values elt (rl-cdr lst))
										(loop (rl-cdr lst)))))))
      lst 
      ?dst))
  rl-remove-e-duplicates->a)


;ALGORITHM %ml-map!
(define (%ml-map! ml) ;; fn mlis1 lis ... => unspecified
  (define ml-null? (iref ml null?))
  (define ml-car (iref ml car))
  (define ml-cdr (iref ml cdr))
  (define ml-set-car! (iref ml set-car!))
  (define (ml-map! f lst . lst*)
    (if (null? lst*)
        (do ((l lst (ml-cdr l))) ((ml-null? l) lst)
          (ml-set-car! l (f (ml-car l)))) 
        (let loop ((lst* (cons lst lst*)))
          (let heads ((ll lst*) (hl '()) (tl '()))
            (cond
              ((null? ll)
               (ml-set-car! (car lst*) (apply f (std:reverse hl)))
               (loop (std:reverse tl)))
              ((ml-null? (car ll))
               lst)
              (else
               (heads (cdr ll) 
                 (cons (ml-car (car ll)) hl) 
                 (cons (ml-cdr (car ll)) tl))))))))
  ml-map!)

;; (let ((s1 (string-copy "Hello, FTL!")) (s2 "ZZZZZZZ"))
;;   ((%ml-map! (ml=%mv mv=string)) (%oe-max oe=char) s1 s2)
;;   s1)
;; => "ZelloZZFTL!"
;; (let ((s (string-copy "Hello, FTL!")))
;;   ((%ml-map! (ml=%mv mv=string)) char-upcase (sub s 2 4))
;;   s) 
;; => "HeLLo, FTL!"


;ALGORITHM %ml-substitute-%t!
(define (%ml-substitute-%t! ml t) ;; newobj pobj mlis => unspecified
  (define ml-null? (iref ml null?))
  (define ml-car (iref ml car))
  (define ml-cdr (iref ml cdr))
  (define ml-set-car! (iref ml set-car!))
  (define test (iref t test))
  (define (ml-substitute-t! new p lst)
    (let loop ((lst lst))
      (cond 
        ((ml-null? lst) 
         ftl:unspecified)
        ((test (ml-car lst) p) 
         (ml-set-car! lst new)
         (loop (ml-cdr lst)))
        (else
         (loop (ml-cdr lst))))))
  ml-substitute-t!)

;; (let ((s (string-copy "Hello, FTL!")))
;;   ((%ml-substitute-%t! (ml=%mv mv=string) t=char-ci) #\* #\l s)
;;   s)
;; => "He**o, FT*!"



;; GENERATORS (g)


;proper way to define a new g interface
(define (g-interface fold)
  (interface
    (fold fold)))

;INTERFACE g=iota
(define g=iota
  (interface
    ((fold kons knil n) 
     (let loop ((i 0) (klst knil)) 
       (if (= i n) klst (loop (+ i 1) (kons i klst)))))
    ;cheat: fast versions of non-primitives
    (length values)))

;INTERFACE g=list
(define g=list
  (interface
    ((fold kons knil lst) 
     (let loop ((lst lst) (klst knil)) 
       (if (null? lst) klst (loop (cdr lst) (kons (car lst) klst)))))
    ;cheat: fast versions of non-primitives
    (length std:length)
    (for-each std:for-each)))

;INTERFACE g=reverse-list
(define g=reverse-list
  (interface
    ((fold kons knil list) 
     (let loop ((list list)) 
       (if (null? list) knil (kons (car list) (loop (cdr list))))))
    ;cheat: fast versions of non-primitives
    (length std:length)))

;INTERFACE g=%v
(define (g=%v v)
  (interface
    (fold (%v-fold-left v))
    ;cheat: fast(er) versions of non-primitives
    (length (%v-length v))))

;INTERFACE g=reverse-%v
(define (g=reverse-%v v)
  (interface
    (fold (%v-fold-right v))
    ;cheat: fast(er) versions of non-primitives
    (length (%v-length v))))

;INTERFACE g=sexp-port    
(define g=sexp-port
  (interface
    ((fold kons knil port) 
     (let loop ((klst knil)) 
       (let ((obj (read port))) ;do it BEFORE loop
         (if (eof-object? obj) klst (loop (kons obj klst))))))))

;; NB: reverse-port is also possible, but it will need to read all the 
;; file into memory before the actual folding

;INTERFACE g=char-port
(define g=char-port
  (interface
    ((fold kons knil port) 
     (let loop ((klst knil)) 
       (let ((obj (read-char port))) ;do it BEFORE loop
         (if (eof-object? obj) klst (loop (kons obj klst))))))))

;INTERFACE g=line-port
(define g=line-port
  (interface
    ((fold kons knil port) 
     (let loop ((klst knil)) 
       (let ((obj (read-line port))) ;do it BEFORE loop
         (if (eof-object? obj) klst (loop (kons obj klst))))))))

;INTERFACE g=sexp-file
(define g=sexp-file
  (interface
    ((fold kons knil file)
     (call-with-input-file file 
       (lambda (port)
         (let loop ((klst knil)) 
           (let ((obj (read port))) ;do it BEFORE loop
             (if (eof-object? obj) klst (loop (kons obj klst))))))))))

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

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

;INTERFACE g=%g-%x
(define (g=%g-%x g x)
  ;; fusion
  (define g-fold (iref g fold))
  (define x-fn (iref x fn))
  (define (g-x-fold kons knil src)
    (g-fold
      (lambda (obj klst) (kons (x-fn obj) klst))
      knil
      src))
  (interface
    (fold g-x-fold)))


;; Algorithms over g

;ALGORITHM %g-fold
(define (%g-fold g) ;; kons knil src => res 
  (iref g fold))

;; ((%g-fold g=iota) cons '() 10)
;; => (9 8 7 6 5 4 3 2 1 0)
;; ((%g-fold (g=%g-%x g=iota x=add1)) cons '() 10)
;; => (10 9 8 7 6 5 4 3 2 1)
;; ((%g-fold (g=%g-%x g=string x=upcase)) cons '() "hello")
;; => (#\O #\L #\L #\E #\H)


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

;; ((%g-length g=iota) 44)
;; => 44
;; ((%g-length g=sexp-file) "ftl.ss")
;; => 114 (so far...)


;ALGORITHM %g-for-each
(define (%g-for-each g) ;; proc src => unspecified
  ;; maps an effect to generator's output
  (define g-fold (iref g fold))
  (define (g-for-each proc src)
    (g-fold 
      (lambda (obj u) (proc obj))
      ftl:unspecified
      src))
  (iref g for-each g-for-each)) ;support cheats

;; ((%g-for-each g=iota) write 10)
;; writes 0123456789
;; ((%g-for-each g=list) write '(0 1 2 3 4 5 6 7 8 9))
;; writes 0123456789
;; ((%g-for-each g=reverse-list) write '(0 1 2 3 4 5 6 7 8 9))
;; writes 9876543210
;; ((%g-for-each g=reverse-string) display "0123456789")
;; writes 9876543210


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

;; ((%g-last g=list) '(0 1 2 3 4 5 6 7 8 9))
;; => 9
;; ((%g-last g=sexp-file) "ftl.ss")
;; => 'end ;see below 


;ALGORITHM %g-count-%t
(define (%g-count-%t g t) ;; pobj src => n
  ;; counts elements that pass the test
  (define g-fold (iref g fold))
  (define test (iref t test))
  (define (g-count-t p src)
    (g-fold 
      (lambda (obj n)
        (if (test obj p) (+ n 1) n))
      0
      src))
  g-count-t) ;can't cheat: double dispatch

;; ((%g-count-%t g=list t=if) even? '(0 1 2 3 4))
;; => 3
;; ((%g-count-%t g=char-port t=char-ci) #\a 
;;  (open-input-string "Abracadabra"))
;; => 5


;ALGORITHM %g-last-%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
  (define g-fold (iref g fold))
  (define test (iref t test))
  (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) ;can't cheat: double dispatch

;; ((%g-last-%t g=list t=if-not) even? '(0 1 2 3 4))
;; => 3




;; OUTPUTS (o)

;proper way to define a new o interface
(define (o-interface create write result)
  (interface
    (create create)
    (write write)
    (result result)))

;INTERFACE o=count
(define o=count
  (interface
    ((create . ?dst) (if (null? ?dst) 0 (car ?dst)))
    ((write obj out) (+ out 1))
    (result values)))

;INTERFACE o=sum
(define o=sum
  (interface
    ((create . ?dst) (if (null? ?dst) 0 (car ?dst)))
    (write +)
    (result values)))

;INTERFACE o=product
(define o=product
  (interface
    ((create . ?dst) (if (null? ?dst) 1 (car ?dst)))
    (write *)
    (result values)))

;INTERFACE o=min
(define o=min
  (interface
    ((create . ?dst) (if (null? ?dst) #f (car ?dst)))
    ((write obj out) (if out (min obj out) obj))
    (result values)))

;INTERFACE o=max
(define o=max
  (interface
    ((create . ?dst) (if (null? ?dst) #f (car ?dst)))
    ((write obj out) (if out (max obj out) obj))
    (result values)))

;INTERFACE o=list
(define o=list
  (interface 
    ((create) ;no optional dst!
     (cons '() #f)) 
    ((write obj out) ;'tconc'
     (let ((p (std:list obj)) (d (cdr out))) 
       (if d (set-cdr! d p) (set-car! out p))
       (set-cdr! out p)
       out))
    (result car)))

;INTERFACE o=reverse-list
(define o=reverse-list
  (interface
    ((create . ?dst) (if (null? ?dst) '() (car ?dst)))
    (write cons)
    (result values)))

;INTERFACE o=%e-lset
(define (o=%e-lset e)
  (define eq (iref e eq))
  (interface
    ((create . ?dst) (if (null? ?dst) '() (car ?dst)))
    ((write obj out) 
		 (let loop ((l out))
		   (cond ((null? l) (cons obj out))
			       ((eq obj (car l)) out)
						 (else (loop (cdr l))))))
    (result values)))

;INTERFACE o=%mv
(define (o=%mv mv)
  ;progressive realloc can be better, but we'll just
  ;collect a list via tconc and convert it in the end 
  (define list->mv (list->%mv mv))
  (interface
    ((create) ;no optional dst!
     (cons '() #f)) 
    ((write obj out) ;'tconc'
     (let ((p (std:list obj)) (d (cdr out))) 
       (if d (set-cdr! d p) (set-car! out p))
       (set-cdr! out p)
       out))
    ((result out)
     (list->mv (car out)))))

;INTERFACE o=sexp-port
(define o=sexp-port
  (interface
    ((create . ?dst) 
     (if (null? ?dst) (current-output-port) (car ?dst)))
    ((write obj out) (write obj out) (newline out) out)
    (result values))) ;port is still open

;INTERFACE o=char-port
(define o=char-port
  (interface
    ((create . ?dst) 
     (if (null? ?dst) (current-output-port) (car ?dst)))
    ((write obj out) (write-char obj out) out)
    (result values))) ;port is still open

;INTERFACE o=line-port
(define o=line-port
  (interface
    ((create . ?dst) 
     (if (null? ?dst) (current-output-port) (car ?dst)))
    ((write obj out) (write-line obj out) out)
    (result values))) ;port is still open

;INTERFACE o=sexp-file
(define o=sexp-file
  (interface
    (create open-input-file) ;arg is required!
    ((write obj out) (write obj out) (newline out) out)
    (result close-output-port)))

;INTERFACE o=char-file
(define o=char-file
  (interface
    (create open-input-file) ;arg is required!
    ((write obj out) (write-char obj out) out)
    (result close-output-port)))

;INTERFACE o=line-file
(define o=line-file
  (interface
    (create open-input-file) ;arg is required!
    ((write obj out) (write-line obj out) out)
    (result close-output-port)))

;INTERFACE o=gcd
(define o=gcd
  (interface
    ((create . ?dst) (if (null? ?dst) 0 (car ?dst)))
    (write gcd)
    (result values)))

;INTERFACE o=lcm
(define o=lcm
  (interface
    ((create . ?dst) (if (null? ?dst) 1 (car ?dst)))
    (write lcm)
    (result values)))

; special interest?
; o=mean
; o=quadratic-mean
; o=geometric-mean



;; Algorithms over o


;ALGORITHM %o-create
(define (%o-create o) ;; [dst] => out
  (iref o create))

;ALGORITHM %o-write
(define (%o-write o) ;; obj out => out
  (iref o write))

;ALGORITHM %o-result
(define (%o-result o) ;; out => res
  (iref o result))

;; ((%o-result o=list)
;;   ((%o-write o=list) 100
;;     ((%o-write o=list) 200
;;       ((%o-create o=list)))))
;; => (200 100)



;; Algorithms over g and o


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

;; ((%g->%o g=string o=list) "hello")
;; => (#\h #\e #\l #\l #\o)
;; ((%g->%o g=list o=list) '(1 2 3 4 5))
;; => (1 2 3 4 5)
;; ((%g->%o g=list o=product) '(1 2 3 4 5))
;; => 120


;ALGORITHM %g-append->%o
(define (%g-append->%o g o) ;; src ... => res 
  ;; generator->output copy, multiple sources
  (define g-fold (iref g fold))
  (define o-create (iref o create))
  (define o-write (iref o write))
  (define o-result (iref o result))
  (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)

;; ((%g-append->%o g=string o=list) "Hello" ", " "FTL!")
;; => (#\H #\e #\l #\l #\o #\, #\space #\F #\T #\L #\!)


;ALGORITHM %g-append->%o*
(define (%g-append->%o* g o) ;; src ... out => res 
  ;; generator->output copy, multiple sources followed by a dst
  (define g-fold (iref g fold))
  (define o-create (iref o create))
  (define o-write (iref o write))
  (define o-result (iref o result))
  (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*)

;; ((%g-append->%o* g=list o=max) '(1 4 2 5) '(3 5 6) 0)
;; => 6
;; ((%g-append->%o* g=list o=reverse-list) '(1 4 2 5) '(3 5 6) 0)
;; => (6 5 3 5 2 4 1 . 0)


;ALGORITHM %g->%o/%g-splicing
(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 (iref g fold))
  (define g1-fold (iref g1 fold))
  (define o-create (iref o create))
  (define o-write (iref o write))
  (define o-result (iref o result))
  (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)

;; ((%g->%o/%g-splicing g=list o=list g=string) '("He" "llo" ", FTL!"))
;; => (#\H #\e #\l #\l #\o #\, #\space #\F #\T #\L #\!)


;ALGORITHM %g-map1->%o
(define (%g-map1->%o g o) ;; fn src [dst] => res
  ;; generator->output with remapping
  (define g-fold (iref g fold))
  (define o-create (iref o create))
  (define o-write (iref o write))
  (define o-result (iref o result))
  (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)

;; ((%g-map1->%o g=string o=list) char-upcase "hello")
;; => (#\H #\E #\L #\L #\O)


;ALGORITHM %g-map1->%o/%g-splicing
(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 (iref g fold))
  (define g1-fold (iref g1 fold))
  (define o-create (iref o create))
  (define o-write (iref o write))
  (define o-result (iref o result))
  (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)

;; ((%g-map1->%o/%g-splicing g=string o=list g=list) 
;;   (lambda (c) (list c (char-upcase c)))
;;   "Hello!")
;; => (#\H #\H #\e #\E #\l #\L #\l #\L #\o #\O #\! #\!)


;ALGORITHM %g-remove-%t->%o
(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
  (define g-fold (iref g fold))
  (define test (iref t test))
  (define o-create (iref o create))
  (define o-write (iref o write))
  (define o-result (iref o result))
  (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)

;; ((%g-remove-%t->%o g=string t=char-ci o=list) #\l "Hello, FTL!")
;; => (#\H #\e #\o #\, #\space #\F #\T #\!)


;ALGORITHM %g-partition-%t->%o+%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 (iref g fold))
  (define test (iref t test))
  (define o-create (iref o create))
  (define o-write (iref o write))
  (define o-result (iref o result))
  (define o1-create (iref o1 create))
  (define o1-write (iref o1 write))
  (define o1-result (iref o1 result))
  (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)

;; ((%g-partition-%t->%o+%o g=string t=char-ci o=list o=reverse-list) 
;;   #\l "Hello, FTL!")
;; => (#\l #\l #\L)
;;    (#\! #\T #\F #\space #\, #\o #\e #\H)


;ALGORITHM %g-filter-map1->%o
(define (%g-filter-map1->%o g o) ;; fn src [dst] => res
  ;; generator->output with selecting mapped non-false
  (define g-fold (iref g fold))
  (define o-create (iref o create))
  (define o-write (iref o write))
  (define o-result (iref o result))
  (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)

;; ((%g-filter-map1->%o g=string o=list) 
;;   (lambda (c) (and (char-lower-case? c) (char-upcase c)))
;;   "Hello, FTL!")
;; => (#\E #\L #\L #\O)


;ALGORITHM %g-substitute-%t->%o
(define (%g-substitute-%t->%o g t o) ;; newobj pobj src [dst] => res
  ;; generator->output with substituting selected elements
  (define g-fold (iref g fold))
  (define test (iref t test))
  (define o-create (iref o create))
  (define o-write (iref o write))
  (define o-result (iref o result))
  (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)

;; ((%g-substitute-%t->%o g=string t=char-ci o=list) 
;;   #\* #\l "Hello, FTL!")
;; => (#\H #\e #\* #\* #\o #\, #\space #\F #\T #\* #\!)




;; ACCUMULATORS (a)

;proper way to define a new a interface
(define (a-interface unfold) 
  (interface 
    (unfold unfold)))


;INTERFACE a=%o
(define (a=%o o)
  ;; active accumulators can be built from passive outputs
  (define o-create (%o-create o))
  (define o-write (%o-write o))
  (define o-result (%o-result o))
  (interface
    ((unfold 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=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=sexp-port (a=%o o=sexp-port))
;(define a=char-port (a=%o o=char-port))
;(define a=line-port (a=%o o=line-port))
;(define a=sexp-file (a=%o o=sexp-file))
;(define a=char-file (a=%o o=char-file))
;(define a=line-file (a=%o o=line-file))
;(define a=gcd (a=%o o=gcd))
;(define a=lcm (a=%o o=lcm))


;INTERFACE a=and
(define a=and
  ;; short-circuit: bails out at first opportunity
  (interface
    ((unfold dekons klist . ?dst)
     (and (or (null? ?dst) (car ?dst))
       (let loop ((klist klist))
         (values-case (dekons klist)
           (() #t)
           ((val klist) (and val (loop klist)))))))))

;INTERFACE a=or
(define a=or
  ;; short-circuit: bails out at first opportunity
  (interface
    ((unfold dekons klist . ?dst)
     (or (and (pair? ?dst) (car ?dst))
       (let loop ((klist klist))
         (values-case (dekons klist)
           (() #f)
           ((val klist) (or val (loop klist)))))))))


;INTERFACE a=%mv
(define (a=%mv mv)
  (define mv-unwrap (iref mv unwrap))
  (define mv-modify (iref mv modify))
  (define mv-new (iref mv new))
  ;naive method: collect reverse list, then convert
  (interface
    ((unfold dekons klist) ;no dst!
     (let loop ((klist klist) (n 0) (els '()))
       (values-case (dekons klist)
         (() 
          (let ((mvec (mv-new n)))
            (receive (data dstart dend) (mv-unwrap mvec)
              (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))))))))

;INTERFACE a=reverse-%mv
(define (a=reverse-%mv mv)
  (define mv-unwrap (iref mv unwrap))
  (define mv-modify (iref mv modify))
  (define mv-new (iref mv new))
  ;naive method: collect list, then convert
  (interface
    ((unfold dekons klist) ;no dst!
     (let loop ((klist klist) (n 0) (els '()))
       (values-case (dekons klist)
         (() 
          (let ((mvec (mv-new n)))
            (receive (data dstart dend) (mv-unwrap mvec)
              (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))))))))

;INTERFACE a=%mv!
(define (a=%mv! mv)
  (define mv-unwrap (iref mv unwrap))
  (define mv-modify (iref mv modify))
  (define mv-new (iref mv new))
  (interface
    ((unfold dekons klist dst) ;dst required!
     (receive (data dstart dend) (mv-unwrap dst)
       (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))))))))))


;INTERFACE a=reverse-%mv!
(define (a=reverse-%mv! mv)
  (define mv-unwrap (iref mv unwrap))
  (define mv-modify (iref mv modify))
  (define mv-new (iref mv new))
  (interface
    ((unfold dekons klist dst) ;dst required!
     (receive (data dstart dend) (mv-unwrap dst)
       (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))))))))))

;INTERFACE a=%x-%a
(define (a=%x-%a x a)
  ;; fusion: 'map' x onto a's input
  (define fn (iref x fn))
  (define a-unfold (iref a unfold))
  (interface
    ((unfold dekons klist . ?dst)
     (apply a-unfold
       (lambda (klist)
         (values-case (dekons klist)
           (() (values))
           ((val klist) (values (fn val) klist))))
       klist
       ?dst))))



;; Algorithms over a


;ALGORITHM %a-unfold
(define (%a-unfold a) ;; dekons klst [dst] => res 
  (iref a unfold))


;ALGORITHM %a-tabulate
(define (%a-tabulate a) ;; n fn [dst] => res
  ;; feed a with i->x where i goes over [0..n[
  (define a-unfold (iref a unfold))
  (define (a-tabulate n i->x . ?dst)
    (apply a-unfold
      (lambda (i) (if (>= i n) (values) (values (i->x i) (+ 1 i))))
      0
      ?dst))
  a-tabulate)


;ALGORITHM %a-iota
(define (%a-iota a) ;; n [start [step]] => res
  ;; feed a with (shifted/scaled) [0..n[
  (define a-unfold (iref a unfold))
  (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 (>= i n) 
              (values)
              (values (+ start (* step i)) (+ 1 i))))
        0)))
  a-iota)


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


;ALGORITHM %a
(define (%a a) ;; obj ... => res
  ;; feed a with specific arguments
  (define a-unfold (iref a unfold))
  (lambda args
    (a-unfold
      (lambda (l) 
        (if (null? l)
            (values)
            (values (car l) (cdr l))))
      args)))


;ALGORITHM %a*
(define (%a* a) ;; obj ... dst => res
  ;; feed a(dst) with specific arguments
  (define a-unfold (iref a unfold))
  (lambda args
    (a-unfold
      (lambda (l) 
        (if (null? (cdr l))
            (values)
            (values (car l) (cdr l))))
      args
      (ftl:last args))))



;; INPUTS (i)

;proper way to define a new i interface
(define (i-interface open read)
  (interface 
    (open open)
    (read read)))


;INTERFACE i=%l
(define (i=%l l)
  (define l-null? (iref l null?))
  (define l-car (iref l car))
  (define l-cdr (iref l cdr))
  (interface
    (open values)
    ((read in)
     (if (l-null? in)
         (values)
         (values (l-car in) (l-cdr in))))))

;INTERFACE i=sexp-port
(define i=sexp-port
  (interface
    (open values)
    ((read in)
     (let ((x (read in)))
       (if (eof-object? x)
           (values)
           (values x in))))))

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

;INTERFACE i=line-port
(define i=line-port
  (interface
    (open values)
    ((read in)
     (let ((x (read-line in)))
       (if (eof-object? x)
           (values)
           (values x in))))))

;INTERFACE i=sexp-file
(define i=sexp-file
  (interface
    (open open-input-file)
    ((read in)
     (let ((x (read in)))
       (if (eof-object? x)
           (values)
           (values x in))))))

;INTERFACE i=char-file
(define i=char-file
  (interface
    (open open-input-file)
    ((read lin)
     (let ((x (read-char lin)))
       (if (eof-object? x)
           (values)
           (values x lin))))))

;INTERFACE i=line-file
(define i=line-file
  (interface
    (open open-input-file)
    ((read in)
     (let ((x (read-line in)))
       (if (eof-object? x)
           (values)
           (values x in))))))



;; Algorithms over i


;ALGORITHM %i-open
(define (%i-open i) ;; src => in
  (iref i open))

;ALGORITHM %i-read
(define (%i-read i) ;; in => (values) or (values obj in)
  (iref i read))


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


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


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


;ALGORITHM %i-andmap
(define (%i-andmap i) ;; fn src1 src2 ... => bool
  (define i-open (iref i open))
  (define i-read (iref i read))
  (define (i-andmap fn src . src*)
    (if (std:null? src*)
        (let loop ((in (i-open src)))
          (values-case (i-read in)
            (() (and))
            ((obj in) (and (fn obj) (loop in)))))
        (let loop ((in* (map i-open (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)))))))))
  (iref i andmap i-andmap))


;ALGORITHM %i-ormap
(define (%i-ormap i) ;; fn src1 src2 ... => bool
  (define i-open (iref i open))
  (define i-read (iref i read))
  (define (i-ormap fn src . src*)
    (if (std:null? src*)
        (let loop ((in (i-open src)))
          (values-case (i-read in)
            (() (or))
            ((obj in) (or (fn obj) (loop in)))))
        (let loop ((in* (map i-open (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)))))))))
  (iref i ormap i-ormap))


;ALGORITHM %i-find-%t
(define (%i-find-%t i t) ;; pobj src => obj or #f
  (define i-open (iref i open))
  (define i-read (iref i read))
  (define test (iref t test))
  (define (i-find-t p src)
    (let loop ((in (i-open 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-open (iref i open))
  (define i-read (iref i read))
  (define test (iref t test))
  (define (i-position-t p src)
    (let loop ((in (i-open src)) (pos 0))
      (values-case (i-read in)
        (() 
         #f)
        ((obj in)
         (if (test obj p) pos (loop in (+ pos 1)))))))
  i-position-t)


;ALGORITHM %i-index
(define (%i-index i) ;; fn src1 src2 ... => n or #f
  (define i-open (iref i open))
  (define i-read (iref i read))
  (define (i-index fn src . src*)
    (if (std:null? src*)
        (let loop ((in (i-open src)) (pos 0))
          (values-case (i-read in)
            (() 
             #f)
            ((obj in) 
             (if (fn obj) pos (loop in (+ pos 1))))))
        (let loop ((in* (map i-open (cons src src*))) (pos 0))
          (let heads ((il in*) (hl '()) (tl '()))
            (if (null? il)
                (if (apply fn (reverse hl))
                    pos
                    (loop (reverse tl) (+ pos 1)))
                (values-case (i-read (car il))
                  (() ;shortest in ended
                   #f)
                  ((obj in)
                   (heads (cdr il) (cons obj hl) (cons in tl)))))))))
  i-index)


;ALGORITHM %i-mismatch-%e
(define (%i-mismatch-%e i e) ;; src1 src2 => n or #f
  (define i-open (iref i open))
  (define i-read (iref i read))
  (define eq (iref e eq))
  (define (i-mismatch-e src1 src2)
    (let loop ((in1 (i-open src1)) (in2 (i-open src2)) (pos 0))
      (values-case (i-read in1)
        (() 
         (values-case (i-read in2)
           (() #f)
           (else pos)))
        ((obj1 in1)
         (values-case (i-read in2)
           (() pos)
           ((obj2 in2)
            (if (eq obj1 obj2) (loop in1 in2 (+ pos 1)) pos)))))))
  i-mismatch-e)


;ALGORITHM %i-sub%v-position-%e
(define (%i-sub%v-position-%e i v e) ;; vec src => n or #f
  ;; Olin Shivers'es KMP code from SRFI 13, modified
  ;; to work with %i and %v interfaces. Look up original
  ;; Knuth-Morris-Pratt algorithm desription there.
  (define v-unwrap (iref v unwrap))
  (define v-access (iref v access))
  (define i-open (iref i open))
  (define i-read (iref i read))
  (define eq (iref e eq))
  (define (v-make-kmp-restart-vector pvec)
    (receive (data start end) (v-unwrap pvec)
      (let* ((rvlen (- end start))
             (rv (std:make-vector rvlen -1)))
        (if (> rvlen 0)
            (let ((rvlen-1 (- rvlen 1))
                  (c0 (v-access data start)))
              (let lp1 ((i 0) (j -1) (k start)) 
                (if (< i rvlen-1)
                    (let ((ck (v-access data k)))
                      (let lp2 ((j j))
                        (cond ((= j -1)
                               (let ((i1 (+ i 1)))
                                 (std:vector-set! rv i1 (if (eq ck c0) -1 0))
                                 (lp1 i1 0 (+ k 1))))
                              ((eq ck (v-access data (+ j start)))
                               (let* ((i1 (+ 1 i))
                                (j1 (+ 1 j)))
                                 (std:vector-set! rv i1 j1)
                                 (lp1 i1 j1 (+ k 1))))
                              (else (lp2 (vector-ref rv j))))))))))
                    rv)))
  (define (i-subv-position-e pvec src)
    (let ((in (i-open src)) (rv (v-make-kmp-restart-vector pvec)))
      (receive (pdata pstart pend) (v-unwrap pvec)
        (let ((plen (- pend pstart)))
          (let loop ((si 0) (pi 0) (pj plen))
            (if (= pi plen) 
                (- si plen) ;win: return start position
                (values-case (i-read in)
                  (() #f) ;lose
                  ((obj in)
                   (if (eq obj (v-access pdata (+ pstart pi)))
                       (loop (+ 1 si) (+ 1 pi) (- pj 1)) ;advance.
                       (let ((pi (std:vector-ref rv pi))) ;retreat.
                         (if (= pi -1)
                             (loop (+ si 1) 0 plen) ;punt
                             (loop si pi (- plen pi)))))))))))))
  i-subv-position-e)

;; funny procedure to look up symbols in a file by their character content
;;
;; (define fkmps (%i-sub%v-position-%e i=char-file v=symbol (e=%oe oe=char-ci)))
;; (fkmps 'shivers "ftl.ss")
;; => 91098 
;; (fkmps (sub '**shivers** 2 9) "ftl.ss")
;; => 91098
;; (fkmps 'mccarthy "ftl.ss")
;; => #f



;; Lexicographical extensions of e and oe to i


;INTERFACE e=%i-of-%e
(define (e=%i-of-%e i e)
  (define i-open (iref i open))
  (define i-read (iref i read))
  (define e-eq (iref e eq))
  (define (ie-eq src1 src2)
    (let loop ((in1 (i-open src1)) (in2 (i-open src2)))
      (values-case (i-read in1)
        (() 
         (values-case (i-read in2)
           (() #t)
           (else #f)))
        ((obj1 in1)
         (values-case (i-read in2)
           (() #f)
           ((obj2 in2)
            (and (e-eq obj1 obj2) (loop in1 in2))))))))
  (interface (eq ie-eq)))


;INTERFACE oe=%i-of-%oe
(define (oe=%i-of-%oe i oe)
  (define i-open (iref i open))
  (define i-read (iref i read))
  (define oe-eq (iref oe eq))
  (define oe-lss (iref oe lss))
  (define (ioe-eq src1 src2)
    (let loop ((in1 (i-open src1)) (in2 (i-open src2)))
      (values-case (i-read in1)
        (() 
         (values-case (i-read in2)
           (() #t)
           (else #f)))
        ((obj1 in1)
         (values-case (i-read in2)
           (() #f)
           ((obj2 in2)
            (and (oe-eq obj1 obj2) (loop in1 in2))))))))
  (define (ioe-lss src1 src2)
    (let loop ((in1 (i-open src1)) (in2 (i-open src2)))
      (values-case (i-read in1)
        (() 
         (values-case (i-read in2)
           (() #f)
           (else #t)))
        ((obj1 in1)
         (values-case (i-read in2)
           (() #f)
           ((obj2 in2)
            (and (oe-lss obj1 obj2) (loop in1 in2))))))))
  (interface (eq ioe-eq) (lss ioe-lss)))


;string extensions traditionally have shorter names

;INTERFACE oe=string
(define oe=string	
  (oe=%i-of-%oe (i=%l (l=%rml (rml=%mv mv=string))) oe=char))

;INTERFACE oe=string-ci
(define oe=string-ci
  (oe=%i-of-%oe (i=%l (l=%rml (rml=%mv mv=string))) oe=char-ci))

;INTERFACE e=string
(define e=string 
  oe=string) ;downcast

;INTERFACE e=string-ci
(define e=string-ci 
  oe=string-ci) ;downcast

;INTERFACE t=string
(define t=string 
  oe=string) ;downcast

;INTERFACE t=string-ci
(define t=string-ci
  oe=string-ci)  ;downcast



;; Algorithms over i and a


;ALGORITHM %i->%a
(define (%i->%a i a) ;; src [dst] => res
  (define i-open (iref i open))
  (define i-read (iref i read))
  (define a-unfold (iref a unfold))
  (define (i->a src . ?dst)
    (apply a-unfold i-read (i-open src) ?dst))
  i->a)


;ALGORITHM %i-map1->%a
(define (%i-map1->%a i a) ;; fn src [dst] => res
  (define i-open (iref i open))
  (define i-read (iref i read))
  (define a-unfold (iref a unfold))
  ;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))))
      (i-open src) 
      ?dst))
  i-map1->a)


;ALGORITHM %i-map->%a
(define (%i-map->%a i a) ;; fn src1 src ... => res
  (define i-open (iref i open))
  (define i-read (iref i read))
  (define a-unfold (iref a unfold))
  ;a should be able to initialize with no dst
  (define (i-map->a fn src . src*)
    (if (std:null? src*)
        (a-unfold
          (lambda (in)
            (values-case (i-read in)
              (() (values))
              ((obj in) (values (fn obj) in))))
          (i-open 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)))))))
          (map i-open (cons src src*)))))
  i-map->a)


;ALGORITHM %i-filter-map1->%a
(define (%i-filter-map1->%a i a) ;; fn src [dst] => res
  (define i-open (iref i open))
  (define i-read (iref i read))
  (define a-unfold (iref a unfold))
  ;optional dst is allowed if a supports it
  (define (i-filter-map1->a fn src . ?dst)
    (apply
      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)))))))
      (i-open src)
      ?dst))
  i-filter-map1->a)


;ALGORITHM %i-filter-map->%a
(define (%i-filter-map->%a i a) ;; fn src1 src ... => res
  (define i-open (iref i open))
  (define i-read (iref i read))
  (define a-unfold (iref a unfold))
  ;a should be able to initialize with no dst
  (define (i-filter-map->a fn src . src*)
    (if (std: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)))))))
          (i-open 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))))))))
          (map i-open (cons src src*)))))
  i-filter-map->a)


;ALGORITHM %i-head->%a
(define (%i-head->%a i a) ;; src n [dst] => res
  (define i-open (iref i open))
  (define i-read (iref i read))
  (define a-unfold (iref a unfold))
  (define (i-head->a src n . ?dst)
    (apply 
      a-unfold 
      (lambda (n&in)
        (let ((n (car n&in)) (in (cdr n&in)))
          (if (> n 0) 
              (values-case (i-read in)
                (() (values))
                ((obj in) (values obj (cons (- n 1) in))))
              (values))))
      (cons n (i-open src)) 
      ?dst))
  i-head->a)


;ALGORITHM sub%i->%a
(define (sub%i->%a i a) ;; src from to [dst] => res
  (define i-open (iref i open))
  (define i-read (iref i read))
  (define a-unfold (iref a unfold))
  (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 (i-open src)) 
      ?dst))
  subi->a)


;ALGORITHM %i-take-%t->%a
(define (%i-take-%t->%a i t a) ;; pobj src [dst] => res
  (define i-open (iref i open))
  (define i-read (iref i read))
  (define test (iref t test))
  (define a-unfold (iref a unfold))
  (define (i-take-t->a p src . ?dst)
    (apply 
      a-unfold 
      (lambda (in)
			  (values-case (i-read in)
				  (() (values))
					((obj in)
					 (if (test obj p)
					     (values obj in)
							 (values)))))
      (i-open src) 
      ?dst))
  i-take-t->a)


;ALGORITHM %i-take-map1->%a
(define (%i-take-map1->%a i a) ;; fn src [dst] => res
  (define i-open (iref i open))
  (define i-read (iref i read))
  (define a-unfold (iref a unfold))
  ;optional dst is allowed if a supports it
  (define (i-take-map1->a fn src . ?dst)
    (apply 
      a-unfold 
      (lambda (in)
        (values-case (i-read in)
          (() (values))
					((obj in)
           (let ((val (fn obj)))
             (if val (values val in) (values))))))
      (i-open src) 
      ?dst))
  i-take-map1->a)


;ALGORITHM %i-take-map->%a
(define (%i-take-map->%a i a) ;; fn src1 src2 ... => res
  (define i-open (iref i open))
  (define i-read (iref i read))
  (define a-unfold (iref a unfold))
  ;a should be able to initialize with no dst
  (define (i-take-map->a fn src . src*)
    (if (std:null? src*)
        (a-unfold
          (lambda (in)
            (values-case (i-read in)
              (() (values))
              ((obj in)
               (let ((val (fn obj)))
                 (if val (values obj in) (values))))))
          (i-open src))
        (a-unfold 
          (lambda (in*)
            (let loop ((in* in*)) 
              (let heads ((il in*) (hl '()) (tl '()))
                (if (null? il)
                    (let ((obj* (reverse hl)))
                      (let ((val (apply fn obj*)))
                        (if val
                            (values (car obj*) (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))))))))
          (map i-open (cons src src*)))))
  i-take-map->a)



;; Miscellaneous algorithms


;ALGORITHM %mv-replace-from-%g
(define (%mv-replace-from-%g mv g) ;; mvec start end src => mvec
  (define mv-append (%mv-append mv))
  (define g->mv (%g->%o g (o=%mv mv)))
  (define g-fold (iref g fold))
  (define (mv-replace-from-g mvec start end src)
    (mv-append
      (sub mvec 0 start)
      (g->mv src)
      (sub mvec end)))
  submv-replace-from-g)
  
;; ((sub%mv-replace-from-%g mv=string g=list)
;;  "It's easy to code it up in Scheme." 5 9 '(#\f #\u #\n))
;; => "It's fun to code it up in Scheme."


;ALGORITHM %mv-splice-%g
(define (%mv-splice-%g mv g) ;; mvec n src => mvec
  (define mv-append (%mv-append mv))
  (define g->mv (%g->%o g (o=%mv mv)))
  (define g-fold (iref g fold))
  (define (mv-splice-g mvec pos src)
    (mv-append (sub mvec 0 pos) (g->mv src) (sub mvec pos)))
  mv-splice-g)
  
;; ((%mv-splice-%g mv=string g=list)
;;  "It's easy to code it up in Scheme." 5 '(#\v #\e #\r #\y #\space))
;; => "It's very easy to code it up in Scheme."



;---------------------------------------------------------------------------

#|

(define debug-palindrome
  (let ()
    (define (match x) (char-ci=? (car x) (caddr x)))
    (template-define*
      iota-filter-map1->list
      list-position-if-not list-find-if list-tail list-ref
      string-length string-ref substring)
    (lambda (s)
      (let* ((pairs (iota-filter-map1->list
                      (lambda (j) 
                        (let ((c (string-ref s j)))
                          (if (char-alphabetic? c) (list c j) #f)))
                      (string-length s)))
             (quads (map append pairs (reverse pairs)))
             (diffpos (list-position-if-not match quads)))
        (if diffpos
            (let* ((diff (list-ref quads diffpos))
                   (same (list-find-if match (list-tail quads (+ diffpos 1)))))
              (if same
                  (format "/~a/ (at ~d) is not the reverse of /~a/"
                     (substring s (cadr diff) (cadr same))
                     (cadr diff)
                     (substring s (+ (cadddr same) 1) (+ (cadddr diff) 1)))
                  "This palindrome is completely messed up!"))
            #f)))))
                  
> (debug-palindrome "A man, a plan, a canal - Panama!")
#f
> (debug-palindrome "A man, an plan, a canal - Panama!")
"/n plan, a canal - P/ (at 8) is not the reverse of /n plan, a canal - P/"
> (debug-palindrome "Common Lisp: The Language")
"/Commo/ (at 0) is not the reverse of /guage/"
> (debug-palindrome "Complete mismatches are hard to find")
"/Complete mism/ (at 0) is not the reverse of /re hard to find/"              

;; may be really slow because of call/cc; 'elements' is added to
;; the name as a hint to this fact and to make CFG parse finite.
;; Also, dynamic-wind may cause unexpected effects if used by g
;; in a non-reversible manner (e.g. to open/close ports).

(define (i=%g-elements g)
  (define g-fold (iref g fold))
  (interface
    ((open src)
     (lambda (initial-cc)
       ((g-fold
          (lambda (elt latest-cc)
            (call/cc
              (lambda (return-cc-to-g)
                (latest-cc elt return-cc-to-g))))
          initial-cc
          src))))
     (read call/cc)))
     

(define (o=%a-elements a)
  (define a-unfold (iref a unfold))
  (interface
    ((create . ?dst)
		 (call/cc
		   (lambda (initial-cc) 
         (apply 
				   a-unfold 
					 call/cc 
					 initial-cc 
					 ?dst))))
    ((write obj return-vv-to-a)
		 (call/cc  
		   (lambda (latest-cc) 
			   (return-vv-to-a obj latest-cc))))
		((result return-vv-to-a) ,,,,, (return-vv-to-a))))



i    <open(src->i), read(i->x,i)>
ri   <open(src->i), read(i->x,i), rest(i->src)>
li   <open(src->i), read(i->x,i), empty?(i->b), peek(i->x), next(i->x)>
lri  <open(src->i), read(i->x,i), empty?(i->b), peek(i->x), rest(i->src)> 

more requirements:

- old iterators still work

possible i's:

iota - need to open, lookahead, no way to reflect rest
list - no need to open, lookahead, rest easily reflected
reverse-list - ?
(pure) vector - need to open, lookahead, rest reflected by copying
(sub) vector - no need to open (vec/sub accepted), l/a, rest is easy (sub)
(pure) reverse-vector	- same as for (pure) vector
(sub) reverse-vector	- same as for (sub) vector
string - see vector
reverse-string - see vector
port - no need to open, no l/a, rest is itself, non-reusable (old iterators are dead)
line-port	- same as port
char-port - no need to open, l/a, rest is itself, non-reusable (old iterators are dead)
file - need to open, no l/a, no natural rest, non-reusable
line-file	- same as file
char-file	- need to open, l/a, no natural rest, non-reusable

So, we have the following combinations:
rli <asis, l/a, natural rest, reentrant> - list, (sub){reverse}{vector,string}
li  <asis, l/a, natural rest, non-ree> char-port 
i   <asis, no l/a, natural rest, non-ree> port, line-port 
?   <open, l/a, unnatural rest, ree> - (pure){reverse}{vector,string}
rls <open, l/a, no natural rest, ree> - iota 
ls  <open, l/a, no natural rest, non-ree> char-file 
s   <open, no l/a, no natural rest, non-ree> file, line-file

...s differs from the corresponding ...i by explicit Open and 
no natural rest. Ideal for g, but not perfect as i.
 
- reentrancy is not yet used by any algorithm
- what is better: 
1)  ability to handle unprepared/indirect sources like filenames
or 2)	ability to get reasonable tails?
	
I'd say 2) because 1) is possible with g, but 2) is the reason
for i's very existance (stop early, continue later).

If we drop 1), we have <read> or <read, empty?, peek, next> and these:

rli=list ;; stream also is readable this way 
rli=%v  rli=reverse-%v	  ;; accept vecs/subs, tail is vec/sub

li=char-port
i=sexp-port
i=line-port

iota, string, and vector go as rli (iota gets subbed too!)

files are only in g.

- lists, vectors, strings allow writing through the iterator
- iota, ports do not allow writing through the iterator

(rename li to l, than writeability (poke) is in ml (mutable list)
 l is <empty?, peek, next>, ml is <empty?, peek, next, poke>,
 i <read> is made from l via i=%l
 rl is reentrant list
 ml is mutable list (some algs need mutability, but don't care about r)
 rml is reentrant mutable list
- problem: v is assumed to be reentrant (rv)? there's no iterator per se
- lists: 
 rml=list
 rml=%mv rml=reverse-%mv rl=%v rl=reverse-%v ;=>
 rml=vector rml=string rml=reverse-vector rml=reverse-string
 rl=iota rl=reverse-iota
 rl=stream l=char-port 
- inputs:
 i=sexp-port i=line-port
 i=%l ;=>
 i=char-port ;; and others...
)



Problem: o is different: it has 'create', so iterator
is not the same as dst. Fix this by leaving funny stuff
to a's ?	Is symmetry worth something these days?

Even if it is: with only clean o and i, it is
impossible to get, say, file->file because
there's no such thing as g->a


clean (need only write and default):
o=count
o=sum
o=product
o=min
o=max
o=reverse-list
o=sexp-port
o=char-port

funny (need create or result)
o=list - tconc or reverse?
o=sexp-file
o=char-file

even funnier:
o=%mv o=%mv!


Compromise:

i = <open(src->in), read(in->obj,in')>; 
in is an opaque iterator of no interest to anybody

o = <create(dst->out), write(obj,out->out'), result(out->x)>
in is an opaque iterator of no interest to anybody

l = <init???(in->in), null?(in->b), peek(in->obj), next(in->in')>
in is user-accessible type; it can be used as input to other
algorithms



|#

'end