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

;; Documentation, see array.pod

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; A very simple array implementation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;; Type definition

(define-struct array-type (vect buckets length sem) (make-inspector))

;;;; Core functions

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


;;; Error handling
(define-syntax array-error
  (syntax-rules ()
    ((_ A string)
     (begin
       (semaphore-post (array-type-sem A))
       (error string)))))

;;; Returns the new vector in A
(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))))))))


;;; Returns the new vector in A
(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))) ;;;(if (> new-buckets 1000) (+ 1000 buckets) 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)

;;;; Derived functions

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

)