Hello all,
Have been toying with scsh for some time,
and am now looking to do some time-series modelling / analysis
using scsh and it seems like a streams abstraction would be a good way
to go about this..
After reviewing SICP and the various srfi documents, I was attempting
to find a good library of streams for r5rs scheme that worked with scsh.
Finding none & that the srfi-40 wasn't implemented for scsh, I decided
to take a crack at hooking it into the build.
Attached is my first crack at a patch against scsh-0.6.7 using the
reference implementation I extracted from the srfi doc. In it's current
state it seems to work for me using the examples / test cases given in
the srfi document (can submit my simple tests upon request)
FWIW It was tested on DragonFlyBSD v1.8 using the pkgsrc-patched version
of scsh , although since it's pure scheme I doubt that makes much
difference..
Please let me know if theres anything I need to do to fix it up to make
it acceptable, I'd much prefer to get this in base than to maintain my
own patchset.
Thanks in advance & thanks for such a nice scheme system.
- Chris
diff -urwN scsh-0.6.7.orig/scheme/more-interfaces.scm
scsh-0.6.7/scheme/more-interfaces.scm
--- scsh-0.6.7.orig/scheme/more-interfaces.scm 2004-01-27 04:49:14.000000000
-0500
+++ scsh-0.6.7/scheme/more-interfaces.scm 2007-08-29 21:48:17.000000000
-0400
@@ -649,6 +649,24 @@
option-processor
args-fold))
+(define-interface srfi-40-interface
+ (export
+ make-stream
+ stream?
+ stream-error
+ stream-null
+ (stream-cons :syntax)
+ stream-null?
+ stream-pair?
+ stream-car
+ stream-cdr
+ (stream-delay :syntax)
+ stream
+ stream-unfoldn
+ stream-map
+ stream-for-each
+ stream-filter))
+
(define-interface srfi-42-interface
(export ((do-ec
list-ec append-ec
diff -urwN scsh-0.6.7.orig/scheme/more-packages.scm
scsh-0.6.7/scheme/more-packages.scm
--- scsh-0.6.7.orig/scheme/more-packages.scm 2004-10-06 07:38:16.000000000
-0400
+++ scsh-0.6.7/scheme/more-packages.scm 2007-08-29 21:37:07.000000000 -0400
@@ -952,6 +952,13 @@
srfi-11)
(files (srfi srfi-37)))
+(define-structure srfi-40 srfi-40-interface
+ (open scheme
+ srfi-1
+ srfi-9
+ srfi-23)
+ (files (srfi srfi-40)))
+
; Eager Comprehensions
(define-structure srfi-42 srfi-42-interface
@@ -1055,7 +1062,7 @@
srfi-11 srfi-13 srfi-14 srfi-16 srfi-17
srfi-23 srfi-25 srfi-26 srfi-27 srfi-28
srfi-31 srfi-37
- srfi-42
+ srfi-40 srfi-42
)
:structure)
make-srfi-19
Binary files scsh-0.6.7.orig/scheme/sh.core and scsh-0.6.7/scheme/sh.core differ
diff -urwN scsh-0.6.7.orig/scheme/srfi/srfi-40.scm
scsh-0.6.7/scheme/srfi/srfi-40.scm
--- scsh-0.6.7.orig/scheme/srfi/srfi-40.scm 1969-12-31 19:00:00.000000000
-0500
+++ scsh-0.6.7/scheme/srfi/srfi-40.scm 2007-08-29 21:20:06.000000000 -0400
@@ -0,0 +1,218 @@
+;;; $Id$
+;;;
+;;; Copyright (C) 2003 by Philip L. Bewig of Saint Louis, Missouri,
+;;; United States of America. 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-40 : A Library of Streams
+;;; Adapted for scsh by Chris Turner <c.turner@199technologies.org>
+;;; Requires SRFI's 1, 9, and 23, provided by scsh.
+;;;
+;;; Implementation
+;;;
+;;; A reference implementation of streams is shown below. It strongly
+;;; prefers simplicity and clarity to efficiency, and though a reasonable
+;;; attempt is made to be safe-for-space, no promises are made. The
+;;; reference implementation relies on the mechanism for defining record
+;;; types of SRFI-9, and the functions `any` and `every` from SRFI-1.
+;;; The `stream-error` function aborts by calling `error` as defined
+;;; in SRFI 23.
+;;;
+;;; PROMISES A LA SRFI-45
+;;; ---------------------
+;;;
+;;; A separate implementation is necessary to
+;;; have promises that answer #t to stream?
+;;; This requires lots of complicated type conversions.
+;;;
+
+(define-record-type s:promise (make-s:promise kind content) s:promise?
+ (kind s:promise-kind set-s:promise-kind!)
+ (content s:promise-content set-s:promise-content!))
+
+(define-record-type box (make-box x) box?
+ (x unbox set-box!))
+
+(define-syntax srfi-40:lazy
+ (syntax-rules ()
+ ((lazy exp)
+ (make-box (make-s:promise 'lazy (lambda () exp))))))
+
+(define (srfi-40:eager x)
+ (make-stream (make-box (make-s:promise 'eager x))))
+
+(define-syntax srfi-40:delay
+ (syntax-rules ()
+ ((srfi-40:delay exp) (srfi-40:lazy (srfi-40:eager exp)))))
+
+(define (srfi-40:force promise)
+ (let ((content (unbox promise)))
+ (case (s:promise-kind content)
+ ((eager) (s:promise-content content))
+ ((lazy)
+ (let* ((promise* (stream-promise ((s:promise-content content))))
+ (content (unbox promise)))
+ (if (not (eqv? 'eager (s:promise-kind content)))
+ (begin
+ (set-s:promise-kind! content (s:promise-kind (unbox promise*)))
+ (set-s:promise-content! content (s:promise-content (unbox
promise*)))
+ (set-box! promise* content)))
+ (srfi-40:force promise))))))
+
+
+;;; LIBRARY OF SYNTAX AND FUNCTIONS TO MANIPULATE STREAMS
+;;;
+;;; A stream is a new data type, disjoint from all other data types, that
+;;; contains a promise that, when forced, is either nil (a single object
+;;; distinguishable from all other objects) or consists of an object
+;;; (the stream element) followed by a stream. Each stream element is
+;;; evaluated exactly once, when it is first retrieved (not when it is
+;;; created); once evaluated its value is saved to be returned by
+;;; subsequent retrievals without being evaluated again.
+
+;; STREAM-TYPE -- type of streams
+;; STREAM? object -- #t if object is a stream, #f otherwise
+(define-record-type stream-type
+ (make-stream promise)
+ stream?
+ (promise stream-promise))
+
+;;; UTILITY FUNCTIONS
+
+;; STREAM-ERROR message -- print message then abort execution
+; replace this with a call to the native error handler
+; if stream-error returns, so will the stream library function that called it
+(define stream-error error)
+
+;;; STREAM SYNTAX AND FUNCTIONS
+
+;; STREAM-NULL -- the distinguished nil stream
+(define stream-null (make-stream (srfi-40:delay '())))
+
+;; STREAM-CONS object stream -- primitive constructor of streams
+(define-syntax stream-cons
+ (syntax-rules ()
+ ((stream-cons obj strm)
+ (make-stream
+ (srfi-40:delay
+ (if (not (stream? strm))
+ (stream-error "attempt to stream-cons onto non-stream")
+ (cons obj strm)))))))
+
+;; STREAM-NULL? object -- #t if object is the null stream, #f otherwise
+(define (stream-null? obj)
+ (and (stream? obj) (null? (srfi-40:force (stream-promise obj)))))
+
+;; STREAM-PAIR? object -- #t if object is a non-null stream, #f otherwise
+(define (stream-pair? obj)
+ (and (stream? obj) (not (null? (srfi-40:force (stream-promise obj))))))
+
+;; STREAM-CAR stream -- first element of stream
+(define (stream-car strm)
+ (cond ((not (stream? strm)) (stream-error "attempt to take stream-car of
non-stream"))
+ ((stream-null? strm) (stream-error "attempt to take stream-car of
null stream"))
+ (else (car (srfi-40:force (stream-promise strm))))))
+
+;; STREAM-CDR stream -- remaining elements of stream after first
+(define (stream-cdr strm)
+ (cond ((not (stream? strm)) (stream-error "attempt to take stream-cdr of
non-stream"))
+ ((stream-null? strm) (stream-error "attempt to take stream-cdr of
null stream"))
+ (else (cdr (srfi-40:force (stream-promise strm))))))
+
+;; STREAM-DELAY object -- the essential stream mechanism
+(define-syntax stream-delay
+ (syntax-rules ()
+ ((stream-delay expr)
+ (make-stream
+ (srfi-40:lazy expr)))))
+
+;; STREAM object ... -- new stream whose elements are object ...
+(define (stream . objs)
+ (let loop ((objs objs))
+ (stream-delay
+ (if (null? objs)
+ stream-null
+ (stream-cons (car objs) (loop (cdr objs)))))))
+
+;; STREAM-UNFOLDN generator seed n -- n+1 streams from (generator seed)
+(define (stream-unfoldn gen seed n)
+ (define (unfold-result-stream gen seed)
+ (let loop ((seed seed))
+ (stream-delay
+ (call-with-values
+ (lambda () (gen seed))
+ (lambda (next . results)
+ (stream-cons results (loop next)))))))
+ (define (result-stream->output-stream result-stream i)
+ (stream-delay
+ (let ((result (list-ref (stream-car result-stream) i)))
+ (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 (stream-error "can't happen"))))))
+ (define (result-stream->output-streams result-stream n)
+ (let loop ((i 0) (outputs '()))
+ (if (= i n)
+ (apply values (reverse outputs))
+ (loop (+ i 1)
+ (cons (result-stream->output-stream result-stream i)
+ outputs)))))
+ (result-stream->output-streams (unfold-result-stream gen seed) n))
+
+;; STREAM-MAP func stream ... -- stream produced by applying func element-wise
+(define (stream-map func . strms)
+ (cond ((not (procedure? func)) (stream-error "non-functional argument to
stream-map"))
+ ((null? strms) (stream-error "no stream arguments to stream-map"))
+ ((not (every stream? strms)) (stream-error "non-stream argument to
stream-map"))
+ (else (let loop ((strms strms))
+ (stream-delay
+ (if (any stream-null? strms)
+ stream-null
+ (stream-cons (apply func (map stream-car strms))
+ (loop (map stream-cdr strms)))))))))
+
+;; STREAM-FOR-EACH proc stream ... -- apply proc element-wise for side-effects
+(define (stream-for-each proc . strms)
+ (cond ((not (procedure? proc)) (stream-error "non-functional argument to
stream-for-each"))
+ ((null? strms) (stream-error "no stream arguments to stream-for-each"))
+ ((not (every stream? strms)) (stream-error "non-stream argument to
stream-for-each"))
+ (else (let loop ((strms strms))
+ (if (not (any stream-null? strms))
+ (begin (apply proc (map stream-car strms))
+ (loop (map stream-cdr strms))))))))
+
+;; STREAM-FILTER pred? stream -- new stream including only items passing pred?
+(define (stream-filter pred? strm)
+ (cond ((not (procedure? pred?)) (stream-error "non-functional argument to
stream-filter"))
+ ((not (stream? strm)) (stream-error "attempt to apply stream-filter to
non-stream"))
+ (else (stream-unfoldn
+ (lambda (s)
+ (values
+ (stream-cdr s)
+ (cond ((stream-null? s) '())
+ ((pred? (stream-car s)) (list (stream-car s)))
+ (else #f))))
+ strm
+ 1))))
|