; 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 (tagged-vector? xpr)
(and (vector? xpr)
(fx>= (vector-length xpr) 1)
(let ((top (vector-ref xpr 0)))
(condition-case (and (thunk? top)
(keyword? (top)))
((exn sequence) #t)))))
(define (tagged-vector kw . args)
(let ((result (make-vector (1+ (length args)))))
(vector-set! result 0 (thunk kw))
(do ((args args (cdr args))
(k 1 (1+ k)))
((null? args) result)
(vector-set! result k (car args)))))
(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