diff options
Diffstat (limited to 'prescheme-nim-local/lib/ps-vector.scm')
| -rw-r--r-- | prescheme-nim-local/lib/ps-vector.scm | 204 |
1 files changed, 204 insertions, 0 deletions
diff --git a/prescheme-nim-local/lib/ps-vector.scm b/prescheme-nim-local/lib/ps-vector.scm new file mode 100644 index 0000000..369040f --- /dev/null +++ b/prescheme-nim-local/lib/ps-vector.scm @@ -0,0 +1,204 @@ +;;; ps-vector: vector utilities for Pre-Scheme +;;; +;;; These routines are based on SRFI-43 for Scheme, with some +;;; adjustments to account for the limitations of Pre-Scheme. +;;; +;;; Pre-Scheme's native vectors don't support vector-length at runtime, +;;; so we take an additional length argument, as is common practice in C. +;;; +;;; Pre-Scheme doesn't support variadic functions, so we have a variant +;;; for each arity, as you might do in C. It should be possible to +;;; generate these with a macro, but that's not yet implemented. + +;;; vector-unfold + +(define-syntax vector-unfold + (syntax-rules () + ((_ proc len) + (vector-unfold0 proc len)) + ((_ proc len seed) + (vector-unfold1 proc len seed)) + ((_ proc len seed1 seed2) + (vector-unfold2 proc len seed1 seed2)) + ((_ proc len seed1 seed2 seed3) + (vector-unfold3 proc len seed1 seed2 seed3)))) + +(define (vector-unfold0 proc len) + ;; FIXME get proc's return type without calling it + (let ((result (make-vector len (proc 0)))) + (let loop ((i 0)) + (if (= i len) + result + (begin + (vector-set! result i (proc i)) + (loop (+ i 1))))))) + +(define (vector-unfold1 proc len seed) + (let ((result (receive (val next) + (proc 0 seed) + (make-vector len val)))) + (let loop ((i 0) (seed seed)) + (if (= i len) + result + (receive (val next) + (proc i seed) + (vector-set! result i val) + (loop (+ i 1) next)))))) + +(define (vector-unfold2 proc len seed1 seed2) + (let ((result (receive (val next1 next2) + (proc 0 seed1 seed2) + (make-vector len val)))) + (let loop ((i 0) (seed1 seed1) (seed2 seed2)) + (if (= i len) + result + (receive (val next1 next2) + (proc i seed1 seed2) + (vector-set! result i val) + (loop (+ i 1) next1 next2)))))) + +(define (vector-unfold3 proc len seed1 seed2 seed3) + (let ((result (receive (val next1 next2 next3) + (proc 0 seed1 seed2 seed3) + (make-vector len val)))) + (let loop ((i 0) (seed1 seed1) (seed2 seed2) (seed3 seed3)) + (if (= i len) + result + (receive (val next1 next2 next3) + (proc i seed1 seed2 seed3) + (vector-set! result i val) + (loop (+ i 1) next1 next2 next3)))))) + +;;; vector-fold + +(define-syntax vector-fold + (syntax-rules () + ((_ proc init vec len) + (vector-fold1 proc init vec len)) + ((_ proc init vec1 len1 vec2 len2) + (vector-fold2 proc init vec1 len1 vec2 len2)) + ((_ proc init vec1 len1 vec2 len2 vec3 len3) + (vector-fold3 proc init vec1 len1 vec2 len2 vec3 len3)))) + +(define (vector-fold1 proc init vec len) + (let loop ((i 0) (result init)) + (if (= i len) + result + (loop (+ i 1) (proc i result (vector-ref vec i)))))) + +(define (vector-fold2 proc init vec1 len1 vec2 len2) + (let ((len (min len1 len2))) + (let loop ((i 0) (result init)) + (if (= i len) + result + (loop (+ i 1) (proc i result + (vector-ref vec1 i) + (vector-ref vec2 i))))))) + +(define (vector-fold3 proc init vec1 len1 vec2 len2 vec3 len3) + (let ((len (min len1 len2 len3))) + (let loop ((i 0) (result init)) + (if (= i len) + result + (loop (+ i 1) (proc i result + (vector-ref vec1 i) + (vector-ref vec2 i) + (vector-ref vec3 i))))))) + +;;; vector-map! + +(define-syntax vector-map! + (syntax-rules () + ((_ proc vec len) + (vector-map1! proc vec len)) + ((_ proc vec1 len1 vec2 len2) + (vector-map2! proc vec1 len1 vec2 len2)) + ((_ proc vec1 len1 vec2 len2 vec3 len3) + (vector-map3! proc vec1 len1 vec2 len2 vec3 len3)))) + +(define (vector-map1! proc vec len) + (vector-fold (lambda (i vec val) + (vector-set! vec i (proc i val)) + vec) + vec vec len)) + +(define (vector-map2! proc vec1 len1 vec2 len2) + (vector-fold (lambda (i vec val1 val2) + (vector-set! vec i (proc i val1 val2)) + vec) + vec1 vec1 len1 vec2 len2)) + +(define (vector-map3! proc vec1 len1 vec2 len2 vec3 len3) + (vector-fold (lambda (i vec val1 val2 val3) + (vector-set! vec i (proc i val1 val2 val3)) + vec) + vec1 vec1 len1 vec2 len2 vec3 len3)) + +;;; vector-map1 + +(define-syntax vector-map + (syntax-rules () + ((_ proc vec len) + (vector-map1 proc vec len)) + ((_ proc vec1 len1 vec2 len2) + (vector-map2 proc vec1 len1 vec2 len2)) + ((_ proc vec1 len1 vec2 len2 vec3 len3) + (vector-map3 proc vec1 len1 vec2 len2 vec3 len3)))) + +(define (vector-map1 proc vec len) + ;; FIXME get proc's return type without calling it + (let ((res (make-vector len (proc 0 (vector-ref vec 0))))) + (vector-fold (lambda (i res val) + (vector-set! res i (proc i val)) + res) + res vec len))) + +(define (vector-map2 proc vec1 len1 vec2 len2) + (let* ((len (min len1 len2)) + (res (make-vector len (proc 0 + (vector-ref vec1 0) + (vector-ref vec2 0))))) + (vector-fold (lambda (i res val1 val2) + (vector-set! res i (proc i val1 val2)) + res) + res vec1 len1 vec2 len2))) + +(define (vector-map3 proc vec1 len1 vec2 len2 vec3 len3) + (let* ((len (min len1 len2 len3)) + (res (make-vector len (proc 0 + (vector-ref vec1 0) + (vector-ref vec2 0) + (vector-ref vec3 0))))) + (vector-fold (lambda (i res val1 val2 val3) + (vector-set! res i (proc i val1 val2 val3)) + res) + res vec1 len1 vec2 len2 vec3 len3))) + +;;; vector-for-each + +(define-syntax vector-for-each + (syntax-rules () + ((_ proc vec len) + (vector-for-each1 proc vec len)) + ((_ proc vec1 len1 vec2 len2) + (vector-for-each2 proc vec1 len1 vec2 len2)) + ((_ proc vec1 len1 vec2 len2 vec3 len3) + (vector-for-each3 proc vec1 len1 vec2 len2 vec3 len3)))) + +(define (vector-for-each1 proc vec len) + (vector-fold (lambda (i res val) + (proc i val) + res) + (unspecific) vec len)) + +(define (vector-for-each2 proc vec1 len1 vec2 len2) + (vector-fold (lambda (i res val1 val2) + (proc i val1 val2) + res) + (unspecific) vec1 len1 vec2 len2)) + +(define (vector-for-each3 proc vec1 len1 vec2 len2 vec3 len3) + (vector-fold (lambda (i res val1 val2 val3) + (proc i val1 val2 val3) + res) + (unspecific) vec1 len1 vec2 len2 vec3 len3)) |