; Copyright (c) 2020 , Juergen Lorenz, ju (at) jugilo (dot) de
; All rights reserved.
; 
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions are
; met:
; 
; Redistributions of source code must retain the above copyright
; notice, this list of conditions and the following disclaimer.
; 
; Redistributions in binary form must reproduce the above copyright
; notice, this list of conditions and the following disclaimer in the
; documentation and/or other materials provided with the distribution.
; Neither the name of the author nor the names of its contributors may be
; used to endorse or promote products derived from this software without
; specific prior written permission. 
;   
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.


#|[
This module allows to acces some sequence types, in particular lists,
pairs, vectors and strings with a common interface. The number of
sequence types handled can be enhanced.
The egg is not as complete and sophisticated as Felix' sequences egg,
but quite usable. In particular, it is sufficient for use in Paul
Graham's dbind implementation, cf. On Lisp, p. 232, which is the
workhorse of my bindings egg.
]|#

(module simple-sequences (
  sequence-db
  sequence?
  seq-length
  seq-ref
  seq-tail
  seq-maker
  seq-nil
  seq-pseudo?
  sequence->list
  seq-reverse
  subseq
  seq-filter
  seq-memp
  seq-append
  seq-map
  seq-for-each
  seq-ref*
  seq-flat?
  seq-length*
  seq-map*
  simple-sequences
  )

(import scheme (chicken base))

(define (true? x) #t)

;(pair x . xs)
;pair constructor
;the sentinel nil comes first
(define (pair nil . xs)
  (append xs nil))

;(pair-length seq)
;length of seq, the sentinel not counted
(define (pair-length seq)
  (let loop ((seq seq) (len 0))
    (if (pair? seq)
      (loop (cdr seq) (+ len 1))
      len)))

;(pair-split pls)
;returns two values, the list-part of pls and the sentinel
(define (pair-split pls)
  (let loop ((pls pls) (lst '()))
    (if (pair? pls)
      (loop (cdr pls) (cons (car pls) lst))
      (list (reverse lst) pls))))

(define sequence-types #f)
  ; to be populated by (sequence-db)

#|[
(sequence-db)
(sequence-db seq)
(sequence-db seq? seq-length seq-ref seq-tail seq-maker . pos?)
--- procedure ---
database processing:
the first resets the database to the standard with
lists, pairs, vectors and strings,
the second returns the vector of handlers as well as the discriminator,
the third adds a new database record either at the end or before the
pos? discriminator.
A record cosists of a discriminator, seq?, and a vector with items
seq-lenth, seq-ref, seq-tail and seq-maker patterned after vectors.
Note, that the last record can handle atoms, albeit it is not a
sequence.
]|#
(define sequence-db
  (let ((true?
          (lambda (x) #t))
        (insert
          (lambda (x xs ok?)
            (let recur ((xs xs))
              (cond
                ((null? xs) '())
                ((ok? (car xs))
                 (cons x (cons (car xs) (recur (cdr xs)))))
                (else (cons (car xs) (recur (cdr xs))))))))
        )
    (let* ((standard-db
             (list (cons list?
                         (vector length
                                 list-ref
                                 list-tail
                                 list))
                   (cons pair?
                         (vector
                                 pair-length
                                 list-ref
                                 list-tail
                                 pair))
                   (cons vector?
                         (vector vector-length
                                 vector-ref
                                 subvector
                                 vector))
                   (cons string?
                         (vector string-length
                                 string-ref
                                 substring
                                 string))
                   (cons true? ;(lambda (x) #t)
                         (vector (lambda (x) 0)
                                 (lambda (x k)
                                   (error 'standard-db
                                          "out of range" x k))
                                 (lambda (x k)
                                   (if (zero? k)
                                     x
                                     (error 'standard-db
                                            "out of range" x k)))
                                 (lambda (x) x)))
                   ))
           (db standard-db))
      (case-lambda
        (()
         (set! db standard-db)
         (set! sequence-types (map car standard-db))
         sequence-types)
        ((seq)
         (let loop ((db db))
           (cond
             ((null? db)
              (error 'sequence-db "no handlers supplied" seq))
             (((caar db) seq) (values (cdar db) (caar db)))
             (else (loop (cdr db))))))
        ((seq? seq-length seq-ref seq-tail seq-maker . pos?)
         (let ((par (cons seq?
                          (vector seq-length seq-ref seq-tail seq-maker))))
           (if (null? pos?)
             (set! db (insert par db (lambda (x)
                                       (eq? (car x) true?))))
             (set! db (insert par db (lambda (x)
                                       (eq? (car x) (car pos?))))))
           (set! sequence-types (map car db))
           sequence-types))
        ))))

#|[
(sequence? x)
--- procedure ---
type predicate.
]|#
(define (sequence? x)
  (sequence-db) ; initialize sequence-types
  (let loop ((lst sequence-types))
    (cond
      ((null? (cdr lst)) #f)
      (((car lst) x) #t)
      (else (loop (cdr lst))))))

#|[
(seq-length seq)
--- procedure ---
returns the length of a sequences
]|#
(define (seq-length seq)
  ((vector-ref (sequence-db seq) 0) seq))

#|[
(seq-ref seq k)
--- procedure ---
returns the item of seq at position k
]|#
(define (seq-ref seq k)
  ((vector-ref (sequence-db seq) 1) seq k))

#|[
(seq-tail seq k)
--- procedure ---
reuturns the subsequence of seq starting at position k.
Note that k might be equal to (seq-length seq), returning
the sentinel of empty sequence
]|#
(define (seq-tail seq k)
  ((vector-ref (sequence-db seq) 2) seq k))

#|[
(seq-maker seq)
--- procedure ---
returns the maker, like list or vector, to create new sequences
of the same type as seq.
]|#
(define (seq-maker seq)
  (vector-ref (sequence-db seq) 3))

#|[
(seq-nil seq)
--- procedure ---
returns the sentinel of pairs or empty sequences
]|#
(define (seq-nil seq)
  (seq-tail seq (seq-length seq)))

#|[
(seq-pseudo? x)
--- procedure ---
checks, if the sequence is pseudo, i.e. a pair.
This is needed to handle pairs like other sequences.
]|#
(define (seq-pseudo? x)
  (and (sequence? x)
       (receive (vec check?) (sequence-db x)
         (eq? check? pair?))))

#|[
(sequence->list seq)
--- procedure ---
type transformer
]|#
(define (sequence->list seq)
  (let loop ((k (- (seq-length seq) 1)) (result '()))
    (if (negative? k)
      result
      (loop (- k 1) (cons (seq-ref seq k) result)))))

#|[
(seq-reverse seq)
--- procedure ---
returns a new sequence with items reversed
]|#
(define (seq-reverse seq)
  (let* ((len (seq-length seq))
         (lst
           (let loop ((k 0) (result '()))
             (if (= k len)
               result
               (loop (+ k 1) (cons (seq-ref seq k) result))))))
    (if (seq-pseudo? seq)
      (apply (seq-maker seq) (cons (seq-nil seq) lst))
      (apply (seq-maker seq) lst))))

#|[
(subseq seq i)
(subseq seq i j)
--- procedure ---
creates a new sequence of the same type as seq consisting
of seq's items from i included and j excluded 
]|#
(define (subseq seq i . js)
  (if (null? js)
    (seq-tail seq i)
    (let ((j (car js)))
      (if (<= 0 i j (seq-length seq))
        (let loop ((k 0)
                   (lst (if (seq-pseudo? seq)
                          (list (seq-nil seq))
                          '())))
          (cond
            ((= k j)
             (apply (seq-maker seq) (reverse lst)))
            ((and (>= k i) (< k j))
             (loop (+ k 1) (cons (seq-ref seq k) lst)))
            (else
              (loop (+ k 1) lst))))
        (error 'subseq "out of range" seq i j)))))

#|[
(seq-filter ok? seq)
--- procedure ---
returns two subsequences of the same type as seq of items
passed or not passed by the ok? test
]|#
(define (seq-filter ok? seq)
  (let ((len (seq-length seq))
        (nil (seq-nil seq))
        (pseudo? (seq-pseudo? seq));)
        (maker (seq-maker seq)))
    (let loop ((k 0)
               (yes (if pseudo? (list nil) '()))
               (no (if pseudo? (list nil) '())))
      (if (= k len)
        (values (apply maker (reverse yes))
                (apply maker (reverse no)))
        (let ((val (seq-ref seq k)))
          (if (ok? val)
            (loop (+ k 1) (cons val yes) no)
            (loop (+ k 1) yes (cons val no))))))))

#|[
(seq-memp ok? seq)
--- procedure ---
returns a new sequence of seq's type of items from seq
starting at the first item which passes the ok? test,
or #f
]|#
(define (seq-memp ok? seq)
  (let ((len (seq-length seq)))
    (let loop ((k 0))
      (cond
        ((= k len)
         (seq-tail seq k))
        ((ok? (seq-ref seq k))
         (seq-tail seq k))
        (else (loop (+ k 1)))))))

#|[
(seq-append seq . seqs)
--- procedure ---
appends the items of all argument sequences, which must be of the same
type as seq and in case of pairs, the same sentinel
]|#
(define (seq-append seq . seqs)
  (cond
    ((null? seqs) seq)
    ((null? (cdr seqs))
     (let ((seq1 (car seqs)))
       (if (eq? (seq-maker seq) (seq-maker seq1))
         (let ((maker (seq-maker seq))); (len (seq-length seq)))
           (apply maker
                  (if (seq-pseudo? seq)
                    (if (equal? (seq-nil seq) (seq-nil seq1))
                      (cons (seq-nil seq)
                            (append (sequence->list seq)
                                    (sequence->list seq1)))
                      (error 'seq-append
                             "different nils"
                             seq seq1))
                    (append (sequence->list seq)
                            (sequence->list seq1)))))
         (error 'seq-append "different types of sequences" seq seq1))))
     (else (apply seq-append (seq-append seq (car seqs)) (cdr seqs)))))

#|[
(seq-map fn seq . seqs)
--- procedure ---
maps the argument sequences up to the shortest length.
All sequences must be of the same type, and in case of pairs,
must have the same sentinels
]|#
(define (seq-map fn seq . seqs)
  (if (null? seqs)
    (let ((len (seq-length seq)))
      (let loop ((k 0)
                 (lst (if (seq-pseudo? seq)
                        (list (seq-nil seq))
                        '())))
        (if (= k len)
          (apply (seq-maker seq) (reverse lst))
          (loop (+ k 1)
                (cons (fn (seq-ref seq k)) lst)))))
    (let ((maker (seq-maker seq))
          (makers (map seq-maker seqs))
          (all? (lambda (ok? lst)
                  (let loop ((lst lst))
                    (cond
                      ((null? lst) #t)
                      ((ok? (car lst))
                       (loop (cdr lst)))
                      (else #f)))))
          )
      (if (all? (lambda (m) (eq? m maker)) makers)
        (let* ((seqs (cons seq seqs))
               (len (apply min (map seq-length seqs))))
          (let loop ((k 0)
                     (lst (if (seq-pseudo? (car seqs))
                            (if (all? (lambda (n)
                                          (equal? n (seq-nil (car seqs))))
                                        (map seq-nil (cdr seqs)))
                              (list (seq-nil (car seqs)))
                              (error 'seq-map "different nils"))
                          '())))
            (if (= k len)
              (apply maker (reverse lst))
              (loop (+ k 1)
                    (cons (apply fn (map (lambda (seq) (seq-ref seq k))
                                         seqs))
                          lst)))))
        (error 'seq-map "different sequence types" seq seqs)))))
        
#|[
(seq-for-each proc seq . seqs)
--- procedure ---
applies proc to each item of seq and seqs
up to the shortest length. The sequences might be
of different type
]|#
(define (seq-for-each proc seq . seqs)
  (let* ((seqs (cons seq seqs))
         (len (apply min (map seq-length seqs))))
    (let loop ((k 0))
      (unless (= k len)
        (apply proc (map (lambda (seq) (seq-ref seq k))
                         seqs))
        (loop (+ k 1))))))

;;; nestet sequences
;;; -----------------

#|[
(seq-ref* seq ind)
--- procedure ---
references the value of a nested sequence at appropriate index list:
with index '(0) it returns (seq-ref seq 0),
with index '(1 0) it returns (seq-ref (seq-ref seq 1) 0) 
]|#
(define (seq-ref* seq ind)
  (cond
    ((null? ind) seq)
    ((integer? ind)
     (seq-ref seq ind))
    (else
      (seq-ref* (seq-ref* seq (car ind)) (cdr ind)))))

#|[
(seq-flat? seq)
--- procedure ---
is the sequence seq flat?
]|#
(define (seq-flat? seq)
  (and (sequence? seq)
       (not (memv #t (let loop ((i 0) (result '()))
                       (if (= i (seq-length seq))
                         result
                         (loop (+ 1 i)
                               (cons (sequence? (seq-ref seq i))
                                     result))))))))

#|[
(seq-length* seq)
--- procedure ---
counts the number of items in a nested sequence seq
]|#
(define (seq-length* seq)
  (let loop ((i 0) (result 0))
    (if (= i (seq-length seq))
      result
      (let ((val (seq-ref seq i)))
        (if (sequence? val)
          (loop (+ i 1) (+ result (seq-length* val)))
          (loop (+ i 1) (+ 1 result)))))))

#|[
(seq-map* fn seq)
--- procedure ---
deep map: maps all items of a nested sequence seq with function fn
]|#
(define (seq-map* fn seq)
  (let recur ((i 0))
    (if (= i (seq-length seq))
      (if (seq-pseudo? seq)
        (list (seq-nil seq))
        '())
      (let ((val (seq-ref seq i)))
        (if (sequence? val)
          (apply (seq-maker seq)
                 (if (seq-pseudo? val)
                   (cons (append (seq-map* fn (sequence->list val))
                                 (seq-nil val))
                         (recur (+ i 1)))
                   (cons (seq-map* fn val) (recur (+ i 1)))))
          (apply (seq-maker seq)
                 (cons (fn val)
                       (sequence->list (recur (+ i 1))))))))))

#|[
(simple-sequences)
(simple-sequences sym)
--- procedure ---
documentation procedure
]|#
(define simple-sequences
  (let (
    (alist '(
      (sequence-db
        procedure:
        (sequence-db)
        (sequence-db seq)
        (sequence-db seq? seq-length seq-ref seq-tail seq-maker . pos?)
        "database processing:"
        "the first resets the database to the standard with"
        "lists, pairs, vectors and strings,"
        "the second returns the vector of handlers as well as the discriminator,"
        "the third adds a new database record either at the end or before the"
        "pos? discriminator."
        "A record cosists of a discriminator, seq?, and a vector with items"
        "seq-lenth, seq-ref, seq-tail and seq-maker patterned after vectors."
        "Note, that the last record can handle atoms, albeit it is not a"
        "sequence."
        )
      (sequence?
        procedure:
        (sequence? x)
        "type predicate."
        )
      (seq-length
        procedure:
        (seq-length seq)
        "returns the length of a sequences"
        )
      (seq-ref
        procedure:
        (seq-ref seq k)
        "returns the item of seq at position k"
        )
      (seq-tail
        procedure:
        (seq-tail seq k)
        "reuturns the subsequence of seq starting at position k."
        "Note that k might be equal to (seq-length seq), returning"
        "the sentinel of empty sequence"
        )
      (seq-maker
        procedure:
        (seq-maker seq)
        "returns the maker, like list or vector, to create new sequences"
        "of the same type as seq."
        )
      (seq-nil
        procedure:
        (seq-nil seq)
        "returns the sentinel of pairs or empty sequences"
        )
      (seq-pseudo?
        procedure:
        (seq-pseudo? x)
        "checks, if the sequence is pseudo, i.e. a pair."
        "This is needed to handle pairs like other sequences."
        )
      (sequence->list
        procedure:
        (sequence->list seq)
        "type transformer"
        )
      (seq-reverse
        procedure:
        (seq-reverse seq)
        "returns a new sequence with items reversed"
        )
      (subseq
        procedure:
        (subseq seq i)
        (subseq seq i j)
        "creates a new sequence of the same type as seq consisting"
        "of seq's items from i included and j excluded "
        )
      (seq-filter
        procedure:
        (seq-filter ok? seq)
        "returns two subsequences of the same type as seq of items"
        "passed or not passed by the ok? test"
        )
      (seq-memp
        procedure:
        (seq-memp ok? seq)
        "returns a new sequence of seq's type of items from seq"
        "starting at the first item which passes the ok? test,"
        "or #f"
        )
      (seq-append
        procedure:
        (seq-append seq . seqs)
        "appends the items of all argument sequences, which must be of the same"
        "type as seq and in case of pairs, the same sentinel"
        )
      (seq-map
        procedure:
        (seq-map fn seq . seqs)
        "maps the argument sequences up to the shortest length."
        "All sequences must be of the same type, and in case of pairs,"
        "must have the same sentinels"
        )
      (seq-for-each
        procedure:
        (seq-for-each proc seq . seqs)
        "applies proc to each item of seq and seqs"
        "up to the shortest length. The sequences might be"
        "of different type"
        )
      (seq-ref*
        procedure:
        (seq-ref* seq ind)
        "references the value of a nested sequence at appropriate index list:"
        "with index '(0) it returns (seq-ref seq 0),"
        "with index '(1 0) it returns (seq-ref (seq-ref seq 1) 0) "
        )
      (seq-flat?
        procedure:
        (seq-flat? seq)
        "is the sequence seq flat?"
        )
      (seq-length*
        procedure:
        (seq-length* seq)
        "counts the number of items in a nested sequence seq"
        )
      (seq-map*
        procedure:
        (seq-map* fn seq)
        "deep map: maps all items of a nested sequence seq with function fn"
        )
      (simple-sequences
        procedure:
        (simple-sequences)
        (simple-sequences sym)
        "with sym: documentation of exported symbol"
        "without sym: list of exported symbols"
        )
        ))
      )
      (case-lambda
        (() (map car alist))
        ((sym)
         (let ((pair (assq sym alist)))
           (if pair
             (for-each print (cdr pair))
             (print "Choose one of " (map car alist))))))))
)