; Author: Juergen Lorenz ; ju (at) jugilo (dot) de
;
; Copyright (c) 2016, Juergen Lorenz
; 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 dispasser.
; 
; Redistributions in binary form must reproduce the above copyright
; notice, this list of conditions and the following dispasser 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.

(require-library simple-exceptions)

(module basic-sequences
  (seq-db seq-null? seq? seq-of seq-ref seq-tail seq-maker seq-exception
   seq-car seq-cdr seq-random-access? basic-sequences
   cons* list-of pseudo-list-of vector-of symbol-dispatcher)
  (import scheme
          (only chicken case-lambda receive condition-case error subvector print)
          (only data-structures chop conjoin disjoin list-of?)
          (only simple-exceptions raise make-exception))

;;; exceptions
;;; ----------
(define seq-exception
  (make-exception "sequence exception" 'sequence))

;;; (seq-ref seq k)
;;; ---------------
;;; access to a sequence item
;;; the second returned value is needed in seq-null?
(define (seq-ref seq k)
  (values
    (cond
      ((list? seq)
       (condition-case (list-ref seq k)
         ((exn)
          (raise (seq-exception 'seq-ref
                                "out of range" seq k)))))
      ((pair? seq)
       (condition-case
         (if (< k 0)
           (raise (seq-exception 'seq-ref "out-of-range" seq k))
           (let loop ((pl seq) (n k))
             (if (pair? pl)
               (if (zero? n)
                 (car pl)
                 (loop (cdr pl) (- n 1)))
               (raise (seq-exception 'seq-ref
                                     "out of range" seq k)))))))
      ((vector? seq)
       (condition-case (vector-ref seq k)
         ((exn)
          (raise (seq-exception 'seq-ref
                                "out of range" seq k)))))
      ((string? seq)
       (condition-case (string-ref seq k)
         ((exn)
          (raise (seq-exception 'seq-ref "out of range" seq k)))))
      (else
        (let loop ((db (seq-db)))
          (cond
            ((null? db)
             (raise (seq-exception 'seq-ref
                                   "no handler defined"
                                   seq)))
            (((caar db) seq)
             ((vector-ref (cdar db) 0) seq k))
            (else (loop (cdr db)))))))
    #f))

;;; (seq-tail seq k)
;;; ----------------
;;; access to the tail of a sequence
(define (seq-tail seq k)
  (cond
    ((list? seq)
     (condition-case (list-tail seq k)
       ((exn) (raise (seq-exception 'seq-tail
                                         "out of range" seq k)))))
    ((pair? seq)
     (condition-case
       (if (< k 0)
         (raise (seq-exception 'seq-tail
                                    "out-of-range" seq k))
         (let loop ((pl seq) (n k))
           (if (pair? pl)
             (if (zero? n)
               pl
               (loop (cdr pl) (- n 1)))
             (if (> n 0)
               (raise (seq-exception 'seq-tail
                                          "out-of-range" seq k))
               pl))))))
    ((vector? seq)
     (condition-case (subvector seq k)
       ((exn) (raise (seq-exception 'seq-tail
                                         "out of range" seq k)))))
    ((string? seq)
     (condition-case (substring seq k)
       ((exn) (raise (seq-exception 'seq-tail
                                         "out of range" seq k)))))
    (else
      (let loop ((db (seq-db)))
        (cond
          ((null? db)
           seq)
          (((caar db) seq)
           ((vector-ref (cdar db) 1) seq k))
          (else (loop (cdr db))))))))

(define (seq-maker seq)
  (cond
    ((list? seq) list)
    ((pair? seq) cons*)
    ((vector? seq) vector)
    ((string? seq) string)
    (else
      (let loop ((db (seq-db)))
        (cond
          ((null? db)
           (raise (seq-exception 'seq-maker
                                 "no handler defined"
                                 seq)))
          (((caar db) seq)
           (vector-ref (cdar db) 2))
          (else (loop (cdr db))))))))

(define (seq-random-access? seq)
  (cond
    ((list? seq) #f)
    ((pair? seq) #f)
    ((vector? seq) #t)
    ((string? seq) #t)
    (else
      (let loop ((db (seq-db)))
        (cond
          ((null? db)
           (raise (seq-exception 'seq-maker
                                 "no handler defined"
                                 seq)))
          (((caar db) seq)
           (vector-ref (cdar db) 3))
          (else (loop (cdr db))))))))

;;; (seq-null? seq)
;;; ---------------
;;; tests for emptiness of a sequence
(define (seq-null? seq)
  (receive (result out-of-bounds?)
    (condition-case (seq-ref seq 0)
      ((exn sequence) (values #t #t)))
    (if out-of-bounds? #t #f)))

;;; (seq-car seq)
;;; -------------
;;; returns the first item of a sequence
(define (seq-car seq)
  (seq-ref seq 0))

;;; (seq-cdr seq)
;;; -------------
;;; returns the first tail of a sequence
(define (seq-cdr seq)
  (seq-tail seq 1))

;;; (seq-db type? ref: ref tail: tail maker: maker ra?: random-access?)
;;; ------------------------------------------------------------------
;;; adds a new sequence type to the database
;;; (seq-db)
;;; --------
;;; shows the sequence database
(define seq-db
  (let ((db '()))
    (case-lambda
      (() db)
      ((type? . keyword-args)
       (let* ((args (chop keyword-args 2))
              (vec (make-vector (length args))))
         ;; populate vec and add to db
         (do ((args args (cdr args)))
           ((null? args)
            (set! db
                  (cons (cons type? vec) db)))
             (case (caar args)
               ((#:ref)
                (vector-set! vec
                             0
                             (lambda (seq k)
                               (condition-case
                                 ((cadar args) seq k)
                                 ((exn)
                                  (raise (seq-exception 'seq-ref
                                                        "out of range"
                                                        seq k)))))))
               ((#:tail)
                (vector-set! vec
                             1
                             (lambda (seq k)
                               (condition-case
                                 ((cadar args) seq k)
                                 ((exn)
                                  (raise (seq-exception 'seq-tail
                                                        "out of range"
                                                        seq k)))))))
               ((#:maker)
                (vector-set! vec 2 (cadar args)))
               ((#:ra?)
                (vector-set! vec 3 (cadar args)))
               (else
                 (raise (seq-exception 'seq-db
                                       "not a keyword"
                                       (caar args))))
               )))))))

;;; (seq? xpr)
;;; ----------
;;; sequence predicate
(define (seq? xpr)
  (or (list? xpr)
      (pair? xpr)
      (vector? xpr)
      (string? xpr)
      ((apply disjoin (map car (seq-db))) xpr)))

;;; (seq-of ok? ....)
;;; --------------------
;;; returns a sequence predicate which checks all ok? arguments
(define (seq-of . oks?)
  (let (
    (seq-of?
      (lambda (ok?)
        (lambda (xpr)
          (and (seq? xpr)
               (let loop ((n 0))
                 (cond
                   ((seq-null? (seq-tail xpr n))
                    #t)
                   ((ok? (seq-ref xpr n))
                    (loop (+ n 1)))
                   (else #f)))))))
    )
    (seq-of? (apply conjoin oks?))))

;;; (cons* arg . args)
;;; ------------------
;;; sequential version of cons
(define (cons* arg . args)
  (let ((revs (reverse (cons arg args))))
    (let loop ((args (reverse (cdr revs))))
      (if (null? args)
        (car revs)
        (cons (car args) (loop (cdr args)))))))

;;; (list-of ok? ....)
;;; ------------------
;;; returns a list predicate which checks all ok? arguments
(define (list-of . oks?) (list-of? (apply conjoin oks?)))

;;; (pseudo-list-of ok? ....)
;;; ------------------
;;; returns a pseudo-list predicate which checks all ok? arguments
(define (pseudo-list-of . oks?)
  (letrec
    ((pseudo-list-of?
       (lambda (ok?)
         (lambda (xpr)
           (or (ok? xpr)
               (and (pair? xpr)
                    (ok? (car xpr))
                    ((pseudo-list-of? ok?) (cdr xpr))))))))
    (pseudo-list-of? (apply conjoin oks?))))

;;; (vector-of ok? ....)
;;; --------------------
;;; returns a vector predicate which checks all ok? arguments
(define (vector-of . oks?)
  (let (
    (vector-of?
      (lambda (ok?)
        (lambda (vec)
          (and (vector? vec)
               (let loop ((n 0))
                 (cond
                   ((= n (vector-length vec))
                    #t)
                   ((ok? (vector-ref vec n))
                    (loop (+ n 1)))
                   (else #f)))))))
    )
    (vector-of? (apply conjoin oks?))))

;;; (symbol-dispatcher alist)
;;; -------------------------
;;; returns a procedure of zero or one argument, which shows all cars
;;; or the cdr of the alist item with car symbol
(define (symbol-dispatcher alist)
  (case-lambda
    (()
     (map car alist))
    ((sym)
     (let ((pair (assq sym alist)))
       (if pair
         (for-each print (cdr pair))
         (error "Not in list"
                sym
                (map car alist)))))))


;;; (basic-sequences sym ..)
;;; ----------------------
;;; documentation procedure
(define basic-sequences
  (symbol-dispatcher '(
    (seq-ref
      procedure:
      (seq-ref seq k)
      "sequence version of list-ref")
    (seq-tail
      procedure:
      (seq-tail seq k)
      "sequence version of list-tail")
    (seq-car
      procedure:
      (seq-car seq)
      "sequence version of cdr")
    (seq-cdr
      procedure:
      (seq-cdr seq)
      "sequence version of cdr")
    (seq-null?
      procedure:
      (seq-null? seq)
      "sequence version of null?")
    (seq?
      procedure:
      (seq? xpr)
      "checks if xpr is a sequence")
    (seq-of
      procedure:
      (seq-of ok? ...)
      "returns a sequence predicate which checks sequence items")
    (seq-maker
      procedure:
      (seq-maker seq)
      "returns a constructor for seq's type")
    (seq-random-access?
      procedure:
      (seq-random-access? seq)
      "checks, if seq is a random access sequence")
    (seq-db
      procedure:
      (seq-db)
      "shows the sequence database"
      (seq-db type ref: ref tail: tail maker: maker ra?: random-access?)
      "adds a new sequence type to the database where the keywords"
      "name arguments being accessed as seq-ref and seq-tail seq-maker"
      "and seq-random-access? respectively")
    (seq-exception
      procedure:
      (seq-exception loc msg arg ...)
      "generates a composite condition with location symbol, string message"
      "and possible additional arguments arg ...")
    (cons*
      procedure:
      (cons* arg ....)
      "iterative version of cons")
    (list-of
      procedure:
      (list-of ok? ...)
      "generates a list predicate which checks all of its arguments")
    (pseudo-list-of
      procedure:
      (pseudo-list-of ok? ...)
      "generates a pseudo-list predicate which checks all of its arguments")
    (vector-of
      procedure:
      (vector-of ok? ...)
      "generates a vector predicate which checks all of its arguments")
    (symbol-dispatcher
      procedure:
      (symbol-dispatcher alist)
      "generates a procedure of zero or one argument showing all"
      "cars or the cdr or the alist item with symbol as car")
    )))
  ) ; basic-sequences

;(import basic-sequences)
;
;(use arrays)
;(seq-db array? ra?: #t ref: array-ref tail: array-tail maker: array)
;(define (seq-head seq n)
;  (let loop ((k 0) (result '()))
;    (if (= k n)
;      (apply (seq-maker seq) (reverse result))
;      (loop (+ k 1) (cons (seq-ref seq k) result)))))
;(define (seq-length seq)
;  (let loop ((k 0))
;    (if (seq-null? (seq-tail seq k))
;      k
;      (loop (+ k 1)))))
;