; Author: Juergen Lorenz ; ju (at) jugilo (dot) de
;
; Copyright (c) 2016-2018, 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
   thunk thunk? tagged-vector-of
   tagged-vector tagged-vector? tagged-vector-ref tagged-vector-tail
   cons* list-of pseudo-list-of vector-of symbol-dispatcher)
  (import scheme
          (only chicken case-lambda receive condition-case define-inline
                define-values gensym string->keyword assert fixnum?
                fx+ fx- fx= fx> fx< fx>= error subvector print keyword?)
          (only data-structures chop conjoin disjoin list-of?)
          (only simple-exceptions raise make-exception))

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

;;; helpers
;;; -------
(define-inline (1+ n) (fx+ n 1))
(define-inline (1- n) (fx- n 1))
(define-inline (0= n) (fx= n 0))
(define-inline (0<= n) (fx>= n 0))


(define-syntax thunk
  (syntax-rules ()
    ((_ xpr . xprs)
     (lambda () xpr . xprs))))

(define (thunk? xpr)
  (let ((type (gensym 'thunk)))
    (and (procedure? xpr)
         (if (eq? (condition-case (xpr)
                    ((exn arity) type))
                  type)
           #f #t))))

(define-values (tagged-vector tagged-vector?)
  (let ((type (gensym 'tagged-vector)))
    (values
      (lambda (kw . args)
        (let ((result (make-vector (1+ (length args)))))
          (vector-set! result 0 (thunk (values kw type)))
                       ;0
                       ;(lambda ()
                       ;  (values kw type)))
          (do ((args args (cdr args))
               (k 1 (1+ k)))
            ((null? args) result)
            (vector-set! result k (car args)))))
      (lambda (xpr)
        (and (vector? xpr)
             (fx>= (vector-length xpr) 1)
             (let ((top (vector-ref xpr 0)))
               (if (thunk? top)
                 (condition-case
                   (receive (key sym) (top)
                     (and (keyword? key)
                          (symbol? sym)
                          (eq? sym type)))
                   ((exn) #f))
                 #f)))))))

(define (tagged-vector-ref tv k)
  (if (0= k)
    ((vector-ref tv k))
    (vector-ref tv k)))

(define (tagged-vector-tail tv k)
  (cond
    ((fx= k (vector-length tv))
     (vector (thunk
               (raise
                 (seq-exception 'tagged-vector-tail
                                "can't access null tagged vector")))))
    ((0= k) tv)
    (else 
      (let* ((tail (subvector tv k))
             (len (vector-length tail))
             (result (make-vector (1+ len))))
        (vector-set! result 0 (vector-ref tv 0))
        (do ((i 0 (1+ i)))
          ((fx= i len) result)
          (vector-set! result (1+ i) (vector-ref tail i)))))))

;;; (seq-ref seq k)
;;; ---------------
;;; access to a sequence item
;;; the second returned value is needed in seq-null?
(define (seq-ref seq k)
  (assert (0<= k) 'seq-ref)
  (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
         (let loop ((pl seq) (n k))
           (if (pair? pl)
             (if (0= n)
               (car pl)
               (loop (cdr pl) (1- n)))
             (raise (seq-exception 'seq-ref
                                   "out of range" seq k))))))
      ((tagged-vector? seq)
       (condition-case (tagged-vector-ref seq k)
         ((exn)
          (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)
  (assert (0<= k) 'seq-tail)
  (cond
    ((list? seq)
     (condition-case (list-tail seq k)
       ((exn) (raise (seq-exception 'seq-tail
                                           "out of range" seq k)))))
    ((pair? seq)
     (condition-case
       (let loop ((pl seq) (n k))
         (if (pair? pl)
           (if (0= n)
             pl
             (loop (cdr pl) (1- n)))
           (if (fx> n 0)
             (raise (seq-exception 'seq-tail
                                   "out-of-range" seq k))
             pl)))))
    ((tagged-vector? seq)
     (condition-case (tagged-vector-tail seq k)
       ((exn)
        (raise (seq-exception 'seq-tail
                              "out of range" seq k)))))
    ((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*)
    ((tagged-vector? seq) tagged-vector)
    ((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)
    ((tagged-vector? seq) #t)
    ((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)
      (tagged-vector? 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 (1+ n)))
                   (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
                   ((fx= n (vector-length vec))
                    #t)
                   ((ok? (vector-ref vec n))
                    (loop (1+ n)))
                   (else #f)))))))
    )
    (vector-of? (apply conjoin oks?))))

;;; (tagged-vector-of ok? ...)
;;; --------------------------
;;; returns a vector predicate which checks all ok? arguments
(define (tagged-vector-of . oks?)
  (lambda (xpr)
    (and (tagged-vector? xpr)
         ((apply vector-of oks?)
          (subvector xpr 1)))))

;;; (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")
    (tagged-vector
      procedure:
      (tagged-vector kw arg ...)
      "generates a tagged vector with keyword kw and args arg ...")
    (tagged-vector?
      procedure:
      (tagged-vector? xpr)
      "type predicate")
    (tagged-vector-of
      procedure:
      (tagged-vector-of ok? ...)
      "generates a tagged vector predicate which checks all of its arguments")
    (tagged-vector-ref
      procedure:
      (tagged-vector-ref tv k)
      "access to kth item of tagged vector tv")
    (tagged-vector-tail
      procedure:
      (tagged-vector-tail tv k)
      "returns a tagged subvector of tv starting at k")
    (thunk
      macro:
      (thunk xpr ....)
      "generates a thunk with body xpr ....")
    (thunk?
      procedure:
      (thunk? xpr)
      "checks if xpr is a thunk, i.e. a nullary procedure")
    (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