(module callable-sequences (
  callable-sequences
  make-sas-callable
  make-ras-callable
  make-callable
  make-callable*
  callable-sas?
  callable-ras?
  callable?
  callable-length
  callable-null?
  callable-data
  callable-reverse
  )

  (import scheme
          (only (chicken base) atom? receive gensym print error case-lambda)
          (only (chicken format) format)
          (only (chicken condition) condition-case)
          )

;;; a variant of Mario's callable-lists
;;; to be returned instead of lists in dotted-lambdas

(define make-sas-callable 'make-sas-callable)
(define callable-sas? 'callable-sas?)
(define make-ras-callable 'make-ras-callable)
(define callable-ras? 'callable-ras?)

(let ((in (gensym 'in)) (sas (gensym 'sas)) (ras (gensym 'ras)))
  (set! make-sas-callable
    (lambda (seq seq-cons seq-car seq-cdr seq-null?)
      (let maker ((seq seq))
        (receive (nil len)
          (let loop ((seq seq) (k 0))
            (if (seq-null? seq)
              (values seq k)
              (loop (seq-cdr seq) (+ k 1))))
          (case-lambda
            (() (values seq len))
            ((k)
             (cond
               ((and (integer? k) (>= k 0) (< k len))
                (let loop ((seq seq) (n 0))
                  (if (= n k)
                    (seq-car seq)
                    (loop (seq-cdr seq) (+ n 1)))))
               ((and (symbol? k) (eq? k in))
                sas)
               (else
                 (error 'make-sas-callable
                        (format #f
                                "k=~A is out of range for length=~A~%"
                                k len)))))
            ((k l)
             (let ((revers (let loop ((seq seq) (revers nil))
                             (if (seq-null? seq)
                               revers
                               (loop (seq-cdr seq)
                                     (seq-cons (seq-car seq)
                                               revers))))))
               (cond
                 ((and (integer? k) (integer? l)
                       (>= k 0) (<= k l) (<= l len))
                  (maker
                    (let recur ((seq seq) (n 0))
                      (cond
                        ((= n l) nil)
                        ((and (>= n k) (< n l))
                         (seq-cons (seq-car seq) (recur (seq-cdr seq) (+ n 1))))
                        (else
                          (recur (seq-cdr seq) (+ n 1)))))
                    ))
                 ((and (integer? k) (not l) (>= k 0))
                  ((maker seq) k len))
                 ((and (integer? k) (integer? l)
                       (>= l -1) (< l k) (< k len))
                  ((maker revers) (- len k 1) (- len l 1)))
                 ((and (not k) (integer? l) (>= l -1))
                  ((maker revers) 0 (- len l 1)))
                 (else
                   (error 'make-sas-callable
                          (format #f
                                  "at least k=~A or l=~A is out of range for length=~A~%"
                                  k l len)))))
            ))))))
  (set! callable-sas?
    (lambda (xpr)
      (and (procedure? xpr)
           (eqv? (condition-case (xpr in)
                   ((exn) #f))
                 sas))))
  (set! make-ras-callable
    (lambda (seq make-seq seq-ref seq-set! seq-length)
      (let maker ((seq seq))
        (let ((len (seq-length seq)))
          (case-lambda
            (() (values seq len))
            ((k)
             (cond
               ((and (integer? k) (>= k 0) (< k len))
                (seq-ref seq k))
               ((and (symbol? k) (eq? k in))
                ras)
               (else
                 (error 'make-ras-callable
                        (format #f
                                "k=~A is out of range for length=~A~%"
                                k len)))))
            ((k l)
             (cond
               ((and (integer? k) (integer? l)
                     (>= k 0) (<= k l) (<= l len))
                (let ((result (make-seq (- l k))))
                  (do ((n k (+ n 1)))
                    ((= n l) (maker result))
                    (seq-set! result (- n k) (seq-ref seq n))))) 
               ((and (integer? k) (not l) (>= k 0))
                ((maker seq) k len))
               ((and (integer? k) (integer? l)
                     (>= l -1) (< l k) (< k len))
                (let ((result (make-seq (- k l))))
                  (do ((n k (- n 1)))
                    ((= n l) (maker result))
                    (seq-set! result (- k n) (seq-ref seq n))))) 
               ((and (not k) (integer? l) (>= l -1))
                (let ((result (make-seq (- len l 1))))
                  (do ((n (- len 1) (- n 1)))
                    ((= n l) (maker result))
                    (seq-set! result (- len n 1) (seq-ref seq n)))))
               (else
                 (error 'make-ras-callable
                        (format #f
                                "at least k=~A or l=~A is out of range for length=~A~%"
                                k l len)))))
            )))))
  (set! callable-ras?
    (lambda (xpr)
      (and (procedure? xpr)
           (eqv? (condition-case (xpr in)
                   ((exn) #f))
                 ras))))
  )

(define (any? xpr) #t)

(define make-callable
  (let* (
    (standard-db
      (list
        (cons list?
              (lambda (seq) (make-sas-callable seq
                                               cons
                                               car
                                               cdr
                                               null?)))
        (cons pair?
              (lambda (seq) (make-sas-callable seq
                                               cons
                                               car
                                               cdr
                                               atom?)))
        (cons vector?
              (lambda (seq) (make-ras-callable seq
                                               make-vector
                                               vector-ref
                                               vector-set!
                                               vector-length)))
        (cons string?
              (lambda (seq) (make-ras-callable seq
                                               make-string
                                               string-ref
                                               string-set!
                                               string-length)))
        (cons any?
              (lambda (seq) (error 'make-callable
                                   "not a sequence"
                                   seq)))
        ))
    (db standard-db)
    )
    (case-lambda
      (() ; reset database
       (set! db standard-db)
       db)
      ((seq)
       (make-callable seq #f)) ; not recursive
      ((x y)
       (cond
         ((boolean? y)
          (let ((seq x) (recursive? y))
            (if recursive?
              (let* ((sequence?
                      (lambda (seq)
                        (let ((tests (map car (cdr (reverse db)))))
                          (if (memv #t (map (lambda (fn) (fn seq))
                                            tests))
                            #t #f))))
                     (cseq (make-callable seq))
                     (len (callable-length cseq)))
                ;(print (map sequence? '(() #() (a . b) "" #f)))
                (make-callable
                  (let recur ((i 0))
                    (cond
                      ((= i len)
                       (callable-data (cseq i #f)))
                      ((sequence? (cseq i))
                       (cons (make-callable (cseq i) #t) (recur (+ i 1))))
                      ((pair? (cseq i))
                       (cons (make-callable (cseq i) #t) (recur (+ i 1))))
                      (else
                        (cons (cseq i) (recur (+ i 1))))))))
              (let loop ((db db))
                (if ((caar db) seq)
                  ((cdar db) seq)
                  (loop (cdr db)))))))
         ((and (procedure? x) (procedure? y))
          (let ((seq? x) (seq-maker y))
            ;; add new predicate-maker-pair as the next to last item
            (set! db
              (let recur ((db db))
                (if (null? (cdr db))
                  (list (cons seq? seq-maker) (car db))
                  (cons (car db) (recur (cdr db))))))
            db))
         (else (error 'make-callable
                      "type mismatch" x y))))
      )))

(define (make-callable* seq)
  (make-callable seq #t))

(define (callable? xpr)
  (or (callable-sas? xpr)
      (callable-ras? xpr)))

(define (callable-length seq)
  (call-with-values seq (lambda (a b) b)))

(define (callable-data seq)
  (call-with-values seq (lambda (a b) a)))

(define (callable-null? xpr)
  (and (callable? xpr) (zero? (callable-length xpr))))

(define (callable-reverse seq)
  ;(seq (- (callable-length seq) 1) -1))
  (seq #f -1))

;;; (callable-sequences sym ..)
;;; -----------------------
;;; documentation procedure
(define callable-sequences
  (let ((syms '(callables make-callable callable? callable-length)))
    (case-lambda
      (() syms)
      ((sym)
       (if (memq sym syms)
         (case sym
           ((make-sas-callable)
            (print "  procedure:")
            (print "  (make-sas-callable seq seq-cons seq-car seq-cdr seq-null?)")
            (print "  returns a procedure with access to its")
            (print "  sequential-access sequence argument, including slices"))
           ((make-ras-callable)
            (print "  procedure:")
            (print "  (make-ras-callable seq make-seq seq-ref seq-set! seq-length)")
            (print "  returns a procedure with access to its")
            (print "  random-access sequence argument, including slices"))
           ((make-callable)
            (print "  generic procedure:")
            (print "  (make-callable)")
            (print "  (make-callable seq)")
            (print "  (make-callable seq? seq-maker)")
            (print "  the first resets the local database,")
            (print "  the second returns a procedure with access")
            (print "  to its sequence argument, including slices")
            (print "  and the third inserts a new item to the local")
            (print "  database in next to last position"))
           ((make-callable*)
            (print "  procdure:")
            (print "  (make-callable* seq)")
            (print "  recursive version of (make-callable seq"))
           ((callable-sas?)
            (print "  procedure:")
            (print "  type predicate for callable sequential-acces sequences"))
           ((callable-ras?)
            (print "  procedure:")
            (print "  type predicate for callable random-acces sequences"))
           ((callable?)
            (print "  procedure:")
            (print "  type predicate: either callable-sas? or callable-ras?"))
           ((callable-null? xpr)
            (print "  procedure:")
            (print "  xpr is callable? and its data are empty"))
           ((callable-length)
            (print "  procedure:")
            (print "  length of callable sequence"))
           ((callable-data)
            (print "  procedure:")
            (print "  encapsulated data of callable sequence"))
           ((callable-reverse)
            (print "  procedure:")
            (print "  reverse of callable sequence"))
           ((callables sym ..)
            (print "  procedure:")
            (print "  documentation procedure"))
           )
         (print "not in list " sym ", chose one of " syms)))
         )))
) ; module

(import callable-sequences simple-tests)
;(define nil (make-callable '()))
;(define vec (make-callable #(0 1 2 3 4 5)))
;(define str (make-callable "012345"))
;(define lst (make-callable '(0 1 2 3 4 5)))
;(define pair (make-callable '(0 1 2 3 4 5 . 6)))
;(ppp (make-callable)
;     (make-callable boolean? identity)
;     )
(define ls* (make-callable* '(a (b c))))
(define pl* (make-callable* '(a (b . c))))
(define lv* (make-callable* '(a #(b c))))
(define vp* (make-callable* (vector 'a '(b . c))))
(define vs* (make-callable* (vector 'a "bc")))
(ppp (ls* 0)
     ((ls* 1) 1)
     (((ls* 1) 2 #f))
     ((pl* 1) 0)
     (((pl* 1) 1 #f))
     ((lv* 1) 1)
     ((vp* 1) 0)
     (((vp* 1) 1 #f))
     ((vs* 1) 0)
     ((vs* 1) 1)
     (((vs* 1) 2 #f))
     )