Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Branch: master
Fetching contributors…

Cannot retrieve contributors at this time

392 lines (367 sloc) 11.292 kB
#lang scheme
;;; Typed Vector Collection
;;; vtype.ss
;;; Copyright (c) 2009 M. Douglas Williams
;;;
;;; This file is part of the Typed Vector Collection.
;;;
;;; The Typed Vector Collection is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License as
;;; published by the Free Software Foundation, either version 3 of the License,
;;; or (at your option) any later version.
;;;
;;; The Typed Vector Collection is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public License
;;; along with the Typed Vector Collection. If not, see
;;; <http://www.gnu.org/licenses/>.
;;;
;;; -----------------------------------------------------------------------------
;;; Version Date Comment
;;; 1.0.0 2009/08/17 Initial version. (MDW)
;;;
;;; -----------------------------------------------------------------------------
;;; To Do:
;;;
;;; -----------------------------------------------------------------------------
(require srfi/4)
;;; (struct vtpe (specifier
;;; element-size
;;; coerce-f
;;; vector?-f
;;; make-vector-f
;;; vector-f
;;; vector-length-f
;;; vector-ref-f
;;; vector-set!-f
;;; vector->list-f
;;; list->vector-f))
;;; specifier : symbol?
;;; element-size : exact-positive-integer?
;;; coerce-f : procedure?
;;; vector?-f : procedure?
;;; make-vector-f : procedure?
;;; vector-f : procedure?
;;; vector-length-f : procedure?
;;; vector-ref-f : procedure?
;;; vector-set!-f : procedure?
;;; vector->list-f : procedure?
;;; list->vector-f : procedure?
;;; base-vtype : (or/c vtype? false/c)
;;; A vtype instance represents a type of vector that can be represented as a
;;; vtype-vector. Currently, these can be an object vector (using native
;;; Scheme vectors), any of the SRFI 4 vector type, or others that can be
;;; represented in one of these (e.g., complex vectors as SRFI 4 floating-point
;;; vectors).
(define-struct vtype
(specifier
element-size
coerce-f
vector?-f
make-vector-f
vector-f
vector-length-f
vector-ref-f
vector-set!-f
vector->list-f
list->vector-f
base-vtype))
;;; vtype-table : hash-eq?
(define vtype-table (make-hasheq))
;;; (define-vector-type specifier
;;; element-size
;;; coerce-f
;;; vector?-f
;;; make-vector-f
;;; vector-f
;;; vector-length-f
;;; vector-ref-f
;;; vector-set!-f
;;; vector->list-f
;;; list->vector-f)
(define-syntax define-vector-type
(syntax-rules ()
((define-vector-type specifier
coerce-f
vector?-f
make-vector-f
vector-f
vector-length-f
vector-ref-f
vector-set!-f
vector->list-f
list->vector-f)
(begin
(define specifier
(make-vtype 'specifier
1
coerce-f
vector?-f
make-vector-f
vector-f
vector-length-f
vector-ref-f
vector-set!-f
vector->list-f
list->vector-f
#f))
(hash-set! vtype-table 'specifier specifier)))))
;;; The predefined base vector types;
;;; object - any Scheme objects
;;; u8 - unsigned 8-bit integers
;;; u16 - unsigned 16-bit integers
;;; u32 - unsigned 32-bit integers
;;; u64 - unsigned 64-bit integers
;;; s8 - signed 8-bit integers
;;; s16 - signed 16-bit integers
;;; s32 - signed 32-bit integers
;;; s64 - signed 64-bit integers
;;; f32 - 32-bit floats
;;; f64 - 64-bit floats
;;; Object vectors using native Scheme vectors
(define-vector-type object
(lambda (x) x)
vector?
make-vector
vector
vector-length
vector-ref
vector-set!
vector->list
list->vector)
;;; Unsigned 8-bit integer vectors using SRFI 4 u8vector
(define-vector-type u8
inexact->exact
u8vector?
make-u8vector
u8vector
u8vector-length
u8vector-ref
u8vector-set!
u8vector->list
list->u8vector)
;;; Unsigned 16-bit integer vectors using SRFI 4 u16vector
(define-vector-type u16
inexact->exact
u16vector?
make-u16vector
u16vector
u16vector-length
u16vector-ref
u16vector-set!
u16vector->list
list->u16vector)
;;; Unsigned 32-bit integer vectors using SRFI 4 u32vector
(define-vector-type u32
inexact->exact
u32vector?
make-u32vector
u32vector
u32vector-length
u32vector-ref
u32vector-set!
u32vector->list
list->u32vector)
;;; Unsigned 64-bit integer vectors using SRFI 4 u64vector
(define-vector-type u64
inexact->exact
u64vector?
make-u64vector
u64vector
u64vector-length
u64vector-ref
u64vector-set!
u64vector->list
list->u64vector)
;;; Signed 8-bit integer vectors using SRFI 4 s8vector
(define-vector-type s8
inexact->exact
s8vector?
make-s8vector
s8vector
s8vector-length
s8vector-ref
s8vector-set!
s8vector->list
list->s8vector)
;;; Signed 16-bit integer vectors using SRFI 4 s16vector
(define-vector-type s16
inexact->exact
s16vector?
make-s16vector
s16vector
s16vector-length
s16vector-ref
s16vector-set!
s16vector->list
list->s16vector)
;;; Signed 32-bit integer vectors using SRFI 4 s32vector
(define-vector-type s32
inexact->exact
s32vector?
make-s32vector
s32vector
s32vector-length
s32vector-ref
s32vector-set!
s32vector->list
list->s32vector)
;;; Signed 64-bit integer vectors using SRFI 4 s64vector
(define-vector-type s64
inexact->exact
s64vector?
make-s64vector
s64vector
s64vector-length
s64vector-ref
s64vector-set!
s64vector->list
list->s64vector)
;;; 32-bit float vectors using SRFI 4 f32vector
(define-vector-type f32
exact->inexact
f32vector?
make-f32vector
f32vector
f32vector-length
f32vector-ref
f32vector-set!
f32vector->list
list->f32vector)
;;; 64-bit float vectors using SRFI 4 f64vector
(define-vector-type f64
exact->inexact
f64vector?
make-f64vector
f64vector
f64vector-length
f64vector-ref
f64vector-set!
f64vector->list
list->f64vector)
;;; Complex Vectors
(define-syntax define-complex-vector-type
(syntax-rules ()
((define-complex-vector-type specifier base)
(begin
(define specifier
(let ((base-coerce (vtype-coerce-f base))
(base-vector? (vtype-vector?-f base))
(base-make-vector (vtype-make-vector-f base))
(base-vector (vtype-vector-f base))
(base-vector-length (vtype-vector-length-f base))
(base-vector-ref (vtype-vector-ref-f base))
(base-vector-set! (vtype-vector-set!-f base))
(base-vector->list (vtype-vector->list-f base))
(base-list->vector (vtype-list->vector-f base)))
(make-vtype
'specifier
2
base-coerce
(lambda (obj)
(and base-vector?
(even? (base-vector-length obj))))
(lambda (n . opt-fill)
(let ((vect (base-make-vector (* 2 n))))
(unless (null? opt-fill)
(let ((real (real-part (car opt-fill)))
(imag (imag-part (car opt-fill))))
(for ((i (in-range n)))
(base-vector-set! vect (* 2 i) (base-coerce real))
(base-vector-set! vect (+ (* 2 i) 1) (base-coerce real)))))
vect))
(lambda data
(let ((vect (base-make-vector (* 2 (length data)))))
(for ((item (in-list data))
(i (in-naturals)))
(let ((real (real-part item))
(imag (imag-part item)))
(base-vector-set! vect (* 2 i) (base-coerce real))
(base-vector-set! vect (+ (* 2 i) 1) (base-coerce real))))
vect))
(lambda (vect)
(/ (base-vector-length vect) 2))
(lambda (vect i)
(make-rectangular
(base-vector-ref vect (* 2 i))
(base-vector-ref vect (+ (* 2 i) 1))))
(lambda (vect i value)
(base-vector-set! vect (* 2 i) (base-coerce (real-part value)))
(base-vector-set! vect (+ (* 2 i) 1) (base-coerce (imag-part value))))
(lambda (vect)
(build-list
(/ (base-vector-length vect) 2)
(lambda (i)
(make-rectangular
(base-vector-ref vect (* 2 i))
(base-vector-ref vect (+ (* 2 i) 1))))))
(lambda (data)
(let ((vect (base-make-vector (* 2 (length data)))))
(for ((item (in-list data))
(i (in-naturals)))
(let ((real (real-part item))
(imag (imag-part item)))
(base-vector-set! vect (* 2 i) (base-coerce real))
(base-vector-set! vect (+ (* 2 i) 1) (base-coerce real))))
vect))
base)))
(hash-set! vtype-table 'specifier specifier)))))
;;; Complex versions of the base numeric vector types
(define-complex-vector-type cu8 u8)
(define-complex-vector-type cu16 u16)
(define-complex-vector-type cu32 u32)
(define-complex-vector-type cu64 u64)
(define-complex-vector-type cs8 s8)
(define-complex-vector-type cs16 s16)
(define-complex-vector-type cs32 s32)
(define-complex-vector-type cs64 s64)
(define-complex-vector-type cf32 f32)
(define-complex-vector-type cf64 f64)
;;; (symbol->vtype sym)-> (or/c vtype? #f)
;;; sym : symbol?
(define (symbol->vtype sym)
(hash-ref vtype-table sym #f))
;; vtype-or-symbol->vtype: (or/c vtype? symbol?) -> (or/c vtype? #f)
;;; (vtype-or-symbol->vtype vtype-or-symbol) -> (or/c vtype? #f)
(define (vtype-or-symbol->vtype vtype-or-symbol)
(if (vtype? vtype-or-symbol)
vtype-or-symbol
(symbol->vtype vtype-or-symbol)))
;; Module Interface
(provide define-vector-type define-complex-vector-type
object u8 u16 u32 u64 s8 s16 s32 s64 f32 f64
cu8 cu16 cu32 cu64 cs8 cs16 cs32 cs64 cf32 cf64)
(provide/contract
(vtype?
(-> any/c boolean?))
(vtype-specifier
(-> vtype? symbol?))
(vtype-element-size
(-> vtype? (and/c natural-number/c (>/c 0))))
(vtype-coerce-f
(-> vtype? procedure?))
(vtype-vector?-f
(-> vtype? procedure?))
(vtype-make-vector-f
(-> vtype? procedure?))
(vtype-vector-f
(-> vtype? procedure?))
(vtype-vector-length-f
(-> vtype? procedure?))
(vtype-vector-ref-f
(-> vtype? procedure?))
(vtype-vector-set!-f
(-> vtype? procedure?))
(vtype-vector->list-f
(-> vtype? procedure?))
(vtype-list->vector-f
(-> vtype? procedure?))
(vtype-base-vtype
(-> vtype? (or/c vtype? false/c)))
(symbol->vtype
(-> symbol? (or/c vtype? false/c)))
(vtype-or-symbol->vtype
(-> (or/c vtype? symbol?) (or/c vtype? false/c))))
Jump to Line
Something went wrong with that request. Please try again.