(module array mzscheme
(provide array
array?
array-ref
array-set!
array-length
array->list
array-insert!
array-remove!
array-add!
list->array
array->vector
vector->array
array-foreach
array-map
array-map!
array-space
)
(define-struct array-type (vect buckets length sem) (make-inspector))
(define (array . args)
(if (null? args)
(let ((A (make-array-type (make-vector 8 0) 8 0 (make-semaphore 1))))
A)
(if (array? (car args))
(apply array (array->list (car args)))
(let ((V (apply vector args)))
(let ((A (make-array-type V (vector-length V) (vector-length V) (make-semaphore 1))))
A)))))
(define (array? A)
(array-type? A))
(define (array-ref A i)
(let ((n (array-type-length A)))
(if (or (< i 0) (>= i n))
(array-error A (format "index ~a is out of bound (0..~a)." i (- n 1))))
(vector-ref (array-type-vect A) i)))
(define-syntax array-error
(syntax-rules ()
((_ A string)
(begin
(semaphore-post (array-type-sem A))
(error string)))))
(define (array-internal-resize A bb)
(let ((v (array-type-vect A))
(b (array-type-buckets A)))
(if (= bb b)
v
(let ((nv (make-vector bb 0)))
(let ((n (if (> bb b) b bb)))
(do ((i 0 (+ i 1)))
((>= i n) (begin
(set-array-type-buckets! A bb)
(set-array-type-vect! A nv)
nv))
(begin
(vector-set! nv i (vector-ref v i))
(vector-set! v i 0))))))))
(define (array-internal-crop A)
(semaphore-wait (array-type-sem A))
(let ((vect (array-internal-resize A (array-length A))))
(semaphore-post (array-type-sem A))
vect))
(define (array-set! A i value . internal)
(if (null? internal)
(semaphore-wait (array-type-sem A)))
(let ((n (array-type-length A)))
(if (or (< i 0) (> i n))
(array-error A (format "index ~a is out of bound (0..~a)." i n)))
(if (= i n)
(let ((buckets (array-type-buckets A)))
(if (= (array-type-length A) buckets)
(let ((new-buckets (* (+ buckets 1) 2)))
(let ((nv (array-internal-resize A new-buckets))) (vector-set! nv n value)
(set-array-type-vect! A nv)
(set-array-type-length! A (+ n 1))))
(begin
(vector-set! (array-type-vect A) i value)
(set-array-type-length! A (+ i 1)))))
(vector-set! (array-type-vect A) i value)))
(if (null? internal)
(semaphore-post (array-type-sem A)))
A)
(define (array-length A)
(array-type-length A))
(define (array-space A)
(array-type-buckets A))
(define (array-remove! A i)
(semaphore-wait (array-type-sem A))
(let ((N (- (array-length A) 1)))
(define (f k)
(if (< k N)
(begin
(array-set! A k (array-ref A (+ k 1)) 'internal)
(f (+ k 1)))))
(if (or (< i 0) (> i N))
(array-error A (format "index ~a is out of bound (0..~a)." i N))
(begin
(f i)
(vector-set! (array-type-vect A) N 0)
(set-array-type-length! A N))))
(semaphore-post (array-type-sem A))
A)
(define (array-add! A value)
(array-set! A (array-length A) value))
(define (array-insert! A value i)
(semaphore-wait (array-type-sem A))
(let ((N (array-length A)))
(define (f k)
(if (> k i)
(begin
(array-set! A k (array-ref A (- k 1)) 'internal)
(f (- k 1)))))
(if (or (< i 0) (> i N))
(array-error A (format "index ~a is out of bound (0..~a)." i N))
(begin
(f N)
(array-set! A i value 'internal))))
(semaphore-post (array-type-sem A))
A)
(define (array-foreach func A)
(let ((n (array-length A)))
(define (foreach i)
(if (= i n)
A
(begin
(func (array-ref A i))
(foreach (+ i 1)))))
(foreach 0))
A)
(define (array-map func A)
(let ((B (array)))
(let ((i 0))
(array-foreach (lambda (v)
(array-set! B i (func v))
(set! i (+ i 1)))
A))
B))
(define (array-map! func A)
(let ((i 0))
(array-foreach (lambda (e)
(array-set! A i (func e))
(set! i (+ i 1)))
A))
A)
(define (array->list A)
(vector->list (array-internal-crop A)))
(define (list->array L)
(apply array L))
(define (array->vector A)
(apply vector (array->list A)))
(define (vector->array V)
(apply array (vector->list V)))
)