; Copyright (C) 2007 by Philip L. Bewig of Saint Louis, Missouri, USA. All rights
; reserved. Permission is hereby granted, free of charge, to any person obtaining a copy of
; this software and associated documentation files (the "Software"), to deal in the Software
; without restriction, including without limitation the rights to use, copy, modify, merge,
; publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to
; whom the Software is furnished to do so, subject to the following conditions: The above
; copyright notice and this permission notice shall be included in all copies or substantial
; portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
; FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR
; THE USE OR OTHER DEALINGS IN THE SOFTWARE.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; SRFI-9 records
(define-syntax define-record-type
(syntax-rules ()
((define-record-type type
(constructor constructor-tag ...)
predicate
(field-tag accessor . more) ...)
(begin
(define type
(make-record-type 'type '(field-tag ...)))
(define constructor
(record-constructor type '(constructor-tag ...)))
(define predicate
(record-predicate type))
(define-record-field type field-tag accessor . more)
...))))
(define-syntax define-record-field
(syntax-rules ()
((define-record-field type field-tag accessor)
(define accessor (record-accessor type 'field-tag)))
((define-record-field type field-tag accessor modifier)
(begin
(define accessor (record-accessor type 'field-tag))
(define modifier (record-modifier type 'field-tag))))))
(define record-marker (list 'record-marker))
(define real-vector? vector?)
(define (vector? x)
(and (real-vector? x)
(or (= 0 (vector-length x))
(not (eq? (vector-ref x 0)
record-marker)))))
(define eval
(let ((real-eval eval))
(lambda (exp env)
((real-eval `(lambda (vector?) ,exp))
vector?))))
(define (record? x)
(and (real-vector? x)
(< 0 (vector-length x))
(eq? (vector-ref x 0)
record-marker)))
(define (make-record size)
(let ((new (make-vector (+ size 1))))
(vector-set! new 0 record-marker)
new))
(define (record-ref record index)
(vector-ref record (+ index 1)))
(define (record-set! record index value)
(vector-set! record (+ index 1) value))
(define (record-type record)
(record-ref record 0))
(define :record-type (make-record 3))
(record-set! :record-type 0 :record-type)
(record-set! :record-type 1 ':record-type)
(record-set! :record-type 2 '(name field-tags))
(define (make-record-type name field-tags)
(let ((new (make-record 3)))
(record-set! new 0 :record-type)
(record-set! new 1 name)
(record-set! new 2 field-tags)
new))
(define (record-type-name record-type)
(record-ref record-type 1))
(define (record-type-field-tags record-type)
(record-ref record-type 2))
(define (field-index type tag)
(let loop ((i 1) (tags (record-type-field-tags type)))
(cond ((null? tags)
(error 'field-index "record type has no such field" type tag))
((eq? tag (car tags))
i)
(else
(loop (+ i 1) (cdr tags))))))
(define (record-constructor type tags)
(let ((size (length (record-type-field-tags type)))
(arg-count (length tags))
(indexes (map (lambda (tag)
(field-index type tag))
tags)))
(lambda args
(if (= (length args)
arg-count)
(let ((new (make-record (+ size 1))))
(record-set! new 0 type)
(for-each (lambda (arg i)
(record-set! new i arg))
args
indexes)
new)
(error 'record-constructor "wrong number of arguments to constructor" type args)))))
(define (record-predicate type)
(lambda (thing)
(and (record? thing)
(eq? (record-type thing)
type))))
(define (record-accessor type tag)
(let ((index (field-index type tag)))
(lambda (thing)
(if (and (record? thing)
(eq? (record-type thing)
type))
(record-ref thing index)
(error 'record-accessor "accessor applied to bad value" type tag thing)))))
(define (record-modifier type tag)
(let ((index (field-index type tag)))
(lambda (thing value)
(if (and (record? thing)
(eq? (record-type thing)
type))
(record-set! thing index value)
(error 'record-modifier "modifier applied to bad value" type tag thing)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; SRFI-23 errors (modified for R6RS)
(define (error reason . args)
(display "Error: ")
(display (symbol->string reason))
(for-each (lambda (arg)
(display " ")
(write arg))
args)
(newline)
(scheme-report-environment -1))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (streams primitive)
(define-record-type stream-type
(make-stream box)
stream?
(box stream-promise stream-promise!))
(define-syntax stream-lazy
(syntax-rules ()
((stream-lazy expr)
(make-stream
(cons 'lazy (lambda () expr))))))
(define (stream-eager expr)
(make-stream
(cons 'eager expr)))
(define-syntax stream-delay
(syntax-rules ()
((stream-delay expr)
(stream-lazy (stream-eager expr)))))
(define (stream-force promise)
(let ((content (stream-promise promise)))
(case (car content)
((eager) (cdr content))
((lazy) (let* ((promise* ((cdr content)))
(content (stream-promise promise)))
(if (not (eqv? (car content) 'eager))
(begin (set-car! content (car (stream-promise promise*)))
(set-cdr! content (cdr (stream-promise promise*)))
(stream-promise! promise* content)))
(stream-force promise))))))
(define stream-null (stream-delay (cons 'stream 'null)))
(define-record-type stream-pare-type
(make-stream-pare kar kdr)
stream-pare?
(kar stream-kar)
(kdr stream-kdr))
(define (stream-pair? obj)
(and (stream? obj) (stream-pare? (stream-force obj))))
(define (stream-null? obj)
(and (stream? obj)
(eqv? (stream-force obj)
(stream-force stream-null))))
(define-syntax stream-cons
(syntax-rules ()
((stream-cons obj strm)
(stream-eager (make-stream-pare (stream-delay obj) (stream-lazy strm))))))
(define (stream-car strm)
(cond ((not (stream? strm)) (error 'stream-car "non-stream"))
((stream-null? strm) (error 'stream-car "null stream"))
(else (stream-force (stream-kar (stream-force strm))))))
(define (stream-cdr strm)
(cond ((not (stream? strm)) (error 'stream-cdr "non-stream"))
((stream-null? strm) (error 'stream-cdr "null stream"))
(else (stream-kdr (stream-force strm)))))
(define-syntax stream-lambda
(syntax-rules ()
((stream-lambda formals body0 body1 ...)
(lambda formals (stream-lazy (let () body0 body1 ...))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (streams derived)
(define (exists pred? . lists)
(and (not (null? (car lists)))
(or (apply pred? (map car lists))
(apply exists pred? (map cdr lists)))))
(define-syntax define-stream
(syntax-rules ()
((define-stream (name . formal) body0 body1 ...)
(define name (stream-lambda formal body0 body1 ...)))))
(define (list->stream objs)
(define list->stream
(stream-lambda (objs)
(if (null? objs)
stream-null
(stream-cons (car objs) (list->stream (cdr objs))))))
(if (not (list? objs))
(error 'list->stream "non-list argument")
(list->stream objs)))
(define (port->stream . port)
(define port->stream
(stream-lambda (p)
(let ((c (read-char p)))
(if (eof-object? c)
stream-null
(stream-cons c (port->stream p))))))
(let ((p (if (null? port) (current-input-port) (car port))))
(if (not (input-port? p))
(error 'port->stream "non-input-port argument")
(port->stream p))))
(define-syntax stream
(syntax-rules ()
((stream) stream-null)
((stream x y ...) (stream-cons x (stream y ...)))))
(define (stream->list . args)
(let ((n (if (= 1 (length args)) #f (car args)))
(strm (if (= 1 (length args)) (car args) (cadr args))))
(cond ((not (stream? strm)) (error 'stream->list "non-stream argument"))
((and n (not (integer? n))) (error 'stream->list "non-integer count"))
((and n (negative? n)) (error 'stream->list "negative count"))
(else (let loop ((n (if n n -1)) (strm strm))
(if (or (zero? n) (stream-null? strm))
'()
(cons (stream-car strm) (loop (- n 1) (stream-cdr strm)))))))))
(define (stream-append . strms)
(define stream-append
(stream-lambda (strms)
(cond ((null? (cdr strms)) (car strms))
((stream-null? (car strms)) (stream-append (cdr strms)))
(else (stream-cons (stream-car (car strms))
(stream-append (cons (stream-cdr (car strms)) (cdr strms))))))))
(cond ((null? strms) stream-null)
((exists (lambda (x) (not (stream? x))) strms)
(error 'stream-append "non-stream argument"))
(else (stream-append strms))))
(define (stream-concat strms)
(define stream-concat
(stream-lambda (strms)
(cond ((stream-null? strms) stream-null)
((not (stream? (stream-car strms)))
(error 'stream-concat "non-stream object in input stream"))
((stream-null? (stream-car strms))
(stream-concat (stream-cdr strms)))
(else (stream-cons
(stream-car (stream-car strms))
(stream-concat
(stream-cons (stream-cdr (stream-car strms)) (stream-cdr strms))))))))
(if (not (stream? strms))
(error 'stream-concat "non-stream argument")
(stream-concat strms)))
(define stream-constant
(stream-lambda objs
(cond ((null? objs) stream-null)
((null? (cdr objs)) (stream-cons (car objs) (stream-constant (car objs))))
(else (stream-cons (car objs)
(apply stream-constant (append (cdr objs) (list (car objs)))))))))
(define (stream-drop n strm)
(define stream-drop
(stream-lambda (n strm)
(if (or (zero? n) (stream-null? strm))
strm
(stream-drop (- n 1) (stream-cdr strm)))))
(cond ((not (integer? n)) (error 'stream-drop "non-integer argument"))
((negative? n) (error 'stream-drop "negative argument"))
((not (stream? strm)) (error 'stream-drop "non-stream argument"))
(else (stream-drop n strm))))
(define (stream-drop-while pred? strm)
(define stream-drop-while
(stream-lambda (strm)
(if (and (stream-pair? strm) (pred? (stream-car strm)))
(stream-drop-while (stream-cdr strm))
strm)))
(cond ((not (procedure? pred?)) (error 'stream-drop-while "non-procedural argument"))
((not (stream? strm)) (error 'stream-drop-while "non-stream argument"))
(else (stream-drop-while strm))))
(define (stream-filter pred? strm)
(define stream-filter
(stream-lambda (strm)
(cond ((stream-null? strm) stream-null)
((pred? (stream-car strm))
(stream-cons (stream-car strm) (stream-filter (stream-cdr strm))))
(else (stream-filter (stream-cdr strm))))))
(cond ((not (procedure? pred?)) (error 'stream-filter "non-procedural argument"))
((not (stream? strm)) (error 'stream-filter "non-stream argument"))
(else (stream-filter strm))))
(define (stream-fold proc base strm)
(cond ((not (procedure? proc)) (error 'stream-fold "non-procedural argument"))
((not (stream? strm)) (error 'stream-fold "non-stream argument"))
(else (let loop ((base base) (strm strm))
(if (stream-null? strm)
base
(loop (proc base (stream-car strm)) (stream-cdr strm)))))))
(define (stream-for-each proc . strms)
(define (stream-for-each strms)
(if (not (exists stream-null? strms))
(begin (apply proc (map stream-car strms))
(stream-for-each (map stream-cdr strms)))))
(cond ((not (procedure? proc)) (error 'stream-for-each "non-procedural argument"))
((null? strms) (error 'stream-for-each "no stream arguments"))
((exists (lambda (x) (not (stream? x))) strms)
(error 'stream-for-each "non-stream argument"))
(else (stream-for-each strms))))
(define (stream-from first . step)
(define stream-from
(stream-lambda (first delta)
(stream-cons first (stream-from (+ first delta) delta))))
(let ((delta (if (null? step) 1 (car step))))
(cond ((not (number? first)) (error 'stream-from "non-numeric starting number"))
((not (number? delta)) (error 'stream-from "non-numeric step size"))
(else (stream-from first delta)))))
(define (stream-iterate proc base)
(define stream-iterate
(stream-lambda (base)
(stream-cons base (stream-iterate (proc base)))))
(if (not (procedure? proc))
(error 'stream-iterate "non-procedural argument")
(stream-iterate base)))
(define (stream-length strm)
(if (not (stream? strm))
(error 'stream-length "non-stream argument")
(let loop ((len 0) (strm strm))
(if (stream-null? strm)
len
(loop (+ len 1) (stream-cdr strm))))))
(define-syntax stream-let
(syntax-rules ()
((stream-let tag ((name val) ...) body1 body2 ...)
((letrec ((tag (stream-lambda (name ...) body1 body2 ...))) tag) val ...))))
(define (stream-map proc . strms)
(define stream-map
(stream-lambda (strms)
(if (exists stream-null? strms)
stream-null
(stream-cons (apply proc (map stream-car strms))
(stream-map (map stream-cdr strms))))))
(cond ((not (procedure? proc)) (error 'stream-map "non-procedural argument"))
((null? strms) (error 'stream-map "no stream arguments"))
((exists (lambda (x) (not (stream? x))) strms)
(error 'stream-map "non-stream argument"))
(else (stream-map strms))))
(define-syntax stream-match
(syntax-rules ()
((stream-match strm-expr clause ...)
(let ((strm strm-expr))
(cond
((not (stream? strm)) (error 'stream-match "non-stream argument"))
((stream-match-test strm clause) => car) ...
(else (error 'stream-match "pattern failure")))))))
(define-syntax stream-match-test
(syntax-rules ()
((stream-match-test strm (pattern fender expr))
(stream-match-pattern strm pattern () (and fender (list expr))))
((stream-match-test strm (pattern expr))
(stream-match-pattern strm pattern () (list expr)))))
(define-syntax stream-match-pattern
(lambda (x)
(define (wildcard? x)
(and (identifier? x)
(free-identifier=? x (syntax _))))
(syntax-case x ()
((stream-match-pattern strm () (binding ...) body)
(syntax (and (stream-null? strm) (let (binding ...) body))))
((stream-match-pattern strm (w? . rest) (binding ...) body)
(wildcard? #'w?)
(syntax (and (stream-pair? strm)
(let ((strm (stream-cdr strm)))
(stream-match-pattern strm rest (binding ...) body)))))
((stream-match-pattern strm (var . rest) (binding ...) body)
(syntax (and (stream-pair? strm)
(let ((temp (stream-car strm)) (strm (stream-cdr strm)))
(stream-match-pattern strm rest ((var temp) binding ...) body)))))
((stream-match-pattern strm w? (binding ...) body)
(wildcard? #'w?)
(syntax (let (binding ...) body)))
((stream-match-pattern strm var (binding ...) body)
(syntax (let ((var strm) binding ...) body))))))
(define-syntax stream-of
(syntax-rules ()
((stream-of expr rest ...)
(stream-of-aux expr stream-null rest ...))))
(define-syntax stream-of-aux
(syntax-rules (in is)
((stream-of-aux expr base)
(stream-cons expr base))
((stream-of-aux expr base (var in stream) rest ...)
(stream-let loop ((strm stream))
(if (stream-null? strm)
base
(let ((var (stream-car strm)))
(stream-of-aux expr (loop (stream-cdr strm)) rest ...)))))
((stream-of-aux expr base (var is exp) rest ...)
(let ((var exp)) (stream-of-aux expr base rest ...)))
((stream-of-aux expr base pred? rest ...)
(if pred? (stream-of-aux expr base rest ...) base))))
(define (stream-range first past . step)
(define stream-range
(stream-lambda (first past delta lt?)
(if (lt? first past)
(stream-cons first (stream-range (+ first delta) past delta lt?))
stream-null)))
(cond ((not (number? first)) (error 'stream-range "non-numeric starting number"))
((not (number? past)) (error 'stream-range "non-numeric ending number"))
(else (let ((delta (cond ((pair? step) (car step)) ((< first past) 1) (else -1))))
(if (not (number? delta))
(error 'stream-range "non-numeric step size")
(let ((lt? (if (< 0 delta) < >)))
(stream-range first past delta lt?)))))))
(define (stream-ref strm n)
(cond ((not (stream? strm)) (error 'stream-ref "non-stream argument"))
((not (integer? n)) (error 'stream-ref "non-integer argument"))
((negative? n) (error 'stream-ref "negative argument"))
(else (let loop ((strm strm) (n n))
(cond ((stream-null? strm) (error 'stream-ref "beyond end of stream"))
((zero? n) (stream-car strm))
(else (loop (stream-cdr strm) (- n 1))))))))
(define (stream-reverse strm)
(define stream-reverse
(stream-lambda (strm rev)
(if (stream-null? strm)
rev
(stream-reverse (stream-cdr strm) (stream-cons (stream-car strm) rev)))))
(if (not (stream? strm))
(error 'stream-reverse "non-stream argument")
(stream-reverse strm stream-null)))
(define (stream-scan proc base strm)
(define stream-scan
(stream-lambda (base strm)
(if (stream-null? strm)
(stream base)
(stream-cons base (stream-scan (proc base (stream-car strm)) (stream-cdr strm))))))
(cond ((not (procedure? proc)) (error 'stream-scan "non-procedural argument"))
((not (stream? strm)) (error 'stream-scan "non-stream argument"))
(else (stream-scan base strm))))
(define (stream-take n strm)
(define stream-take
(stream-lambda (n strm)
(if (or (stream-null? strm) (zero? n))
stream-null
(stream-cons (stream-car strm) (stream-take (- n 1) (stream-cdr strm))))))
(cond ((not (stream? strm)) (error 'stream-take "non-stream argument"))
((not (integer? n)) (error 'stream-take "non-integer argument"))
((negative? n) (error 'stream-take "negative argument"))
(else (stream-take n strm))))
(define (stream-take-while pred? strm)
(define stream-take-while
(stream-lambda (strm)
(cond ((stream-null? strm) stream-null)
((pred? (stream-car strm))
(stream-cons (stream-car strm) (stream-take-while (stream-cdr strm))))
(else stream-null))))
(cond ((not (stream? strm)) (error 'stream-take-while "non-stream argument"))
((not (procedure? pred?)) (error 'stream-take-while "non-procedural argument"))
(else (stream-take-while strm))))
(define (stream-unfold mapper pred? generator base)
(define stream-unfold
(stream-lambda (base)
(if (pred? base)
(stream-cons (mapper base) (stream-unfold (generator base)))
stream-null)))
(cond ((not (procedure? mapper)) (error 'stream-unfold "non-procedural mapper"))
((not (procedure? pred?)) (error 'stream-unfold "non-procedural pred?"))
((not (procedure? generator)) (error 'stream-unfold "non-procedural generator"))
(else (stream-unfold base))))
(define (stream-unfolds gen seed)
(define (len-values gen seed)
(call-with-values
(lambda () (gen seed))
(lambda vs (- (length vs) 1))))
(define unfold-result-stream
(stream-lambda (gen seed)
(call-with-values
(lambda () (gen seed))
(lambda (next . results)
(stream-cons results (unfold-result-stream gen next))))))
(define result-stream->output-stream
(stream-lambda (result-stream i)
(let ((result (list-ref (stream-car result-stream) (- i 1))))
(cond ((pair? result)
(stream-cons
(car result)
(result-stream->output-stream (stream-cdr result-stream) i)))
((not result)
(result-stream->output-stream (stream-cdr result-stream) i))
((null? result) stream-null)
(else (error 'stream-unfolds "can't happen"))))))
(define (result-stream->output-streams result-stream)
(let loop ((i (len-values gen seed)) (outputs '()))
(if (zero? i)
(apply values outputs)
(loop (- i 1) (cons (result-stream->output-stream result-stream i) outputs)))))
(if (not (procedure? gen))
(error 'stream-unfolds "non-procedural argument")
(result-stream->output-streams (unfold-result-stream gen seed))))
(define (stream-zip . strms)
(define stream-zip
(stream-lambda (strms)
(if (exists stream-null? strms)
stream-null
(stream-cons (map stream-car strms) (stream-zip (map stream-cdr strms))))))
(cond ((null? strms) (error 'stream-zip "no stream arguments"))
((exists (lambda (x) (not (stream? x))) strms)
(error 'stream-zip "non-stream argument"))
(else (stream-zip strms))))
Programming Praxis 