prescheme-demo/lib/ps-vector.scm

;;; 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))