;;
;; 
;; A collection of utility functions for manipulating SRFI-4 vectors.
;;
;;
;; Copyright 2007-2013 Ivan Raikov and the Okinawa Institute of Science and Technology.
;;
;;
;; This program is free software: you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; This program 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
;; General Public License for more details.
;;
;; A full copy of the GPL license can be found at
;; <http://www.gnu.org/licenses/>.
;;
;;

(module srfi-4-utils

 (f64vector-fold f32vector-fold s32vector-fold u32vector-fold
		 s16vector-fold u16vector-fold s8vector-fold u8vector-fold
		 f64vector-map f32vector-map s32vector-map u32vector-map
		 s16vector-map u16vector-map s8vector-map u8vector-map
		 f64vector-foldi f32vector-foldi s32vector-foldi u32vector-foldi
		 s16vector-foldi u16vector-foldi s8vector-foldi u8vector-foldi
		 f64vector-mapi f32vector-mapi s32vector-mapi u32vector-mapi
		 s16vector-mapi u16vector-mapi s8vector-mapi u8vector-mapi

                 f64vector-blit! f32vector-blit! s32vector-blit! u32vector-blit!
		 s16vector-blit! u16vector-blit! s8vector-blit! u8vector-blit!

		 f64vector-quick-sort! f32vector-quick-sort! s32vector-quick-sort! u32vector-quick-sort!
		 s16vector-quick-sort! u16vector-quick-sort! s8vector-quick-sort! u8vector-quick-sort!

                 f64vector-merge! f32vector-merge! s32vector-merge! u32vector-merge!
		 s16vector-merge! u16vector-merge! s8vector-merge! u8vector-merge!

		 f64vector-merge-sort! f32vector-merge-sort! s32vector-merge-sort! u32vector-merge-sort!
		 s16vector-merge-sort! u16vector-merge-sort! s8vector-merge-sort! u8vector-merge-sort!

                 )

 (import scheme chicken)
 (require-library srfi-1 extras)
 (import (only srfi-1 fold every)
         (only extras printf))
 (require-extension srfi-4 srfi-42 srfi-4-comprehensions)

(define (make-vector-fold vector-length vector-ref)
  (lambda (f x0 v . rest)
    (let ((n   (vector-length v))
	  (vs  (cons v rest)))
      (fold-ec x0 (:range i 0 n) 
	       (map (lambda (v) (vector-ref v i)) vs)
	       (lambda (x ax) (apply f (append x (list ax))))))))

(define f64vector-fold (make-vector-fold f64vector-length f64vector-ref))
(define f32vector-fold (make-vector-fold f32vector-length f32vector-ref))
(define s32vector-fold (make-vector-fold s32vector-length s32vector-ref))
(define u32vector-fold (make-vector-fold u32vector-length u32vector-ref))
(define s16vector-fold (make-vector-fold s16vector-length s16vector-ref))
(define u16vector-fold (make-vector-fold u16vector-length u16vector-ref))
(define s8vector-fold  (make-vector-fold s8vector-length s8vector-ref))
(define u8vector-fold  (make-vector-fold u8vector-length u8vector-ref))


(define (make-vector-foldi vector-length vector-ref)
  (lambda (f x0 v . rest)
    (let ((n   (vector-length v))
	  (vs  (cons v rest)))
      (fold-ec x0 (:range i 0 n) 
	       (cons i (map (lambda (v) (vector-ref v i)) vs))
	       (lambda (x ax) (apply f (append x (list ax))))))))


(define f64vector-foldi (make-vector-foldi f64vector-length f64vector-ref))
(define f32vector-foldi (make-vector-foldi f32vector-length f32vector-ref))
(define s32vector-foldi (make-vector-foldi s32vector-length s32vector-ref))
(define u32vector-foldi (make-vector-foldi u32vector-length u32vector-ref))
(define s16vector-foldi (make-vector-foldi s16vector-length s16vector-ref))
(define u16vector-foldi (make-vector-foldi u16vector-length u16vector-ref))
(define s8vector-foldi  (make-vector-foldi s8vector-length s8vector-ref))
(define u8vector-foldi  (make-vector-foldi u8vector-length u8vector-ref))


(define (f64vector-map f v . rest)  
  (let ((n (f64vector-length v)))
    (f64vector-of-length-ec n (:range i 0 n) (apply f (map (lambda (v) (f64vector-ref v i)) (cons v rest))))))
(define (f32vector-map f v . rest)  
  (let ((n (f32vector-length v)))
    (f32vector-of-length-ec n (:range i 0 n) (apply f (map (lambda (v) (f32vector-ref v i)) (cons v rest))))))
(define (s32vector-map f v . rest)  
  (let ((n (s32vector-length v)))
    (s32vector-of-length-ec n (:range i 0 n) (apply f (map (lambda (v) (s32vector-ref v i)) (cons v rest))))))
(define (u32vector-map f v . rest)  
  (let ((n (u32vector-length v)))
    (u32vector-of-length-ec n (:range i 0 n) (apply f (map (lambda (v) (u32vector-ref v i)) (cons v rest))))))
(define (s16vector-map f v . rest)  
  (let ((n (s16vector-length v)))
    (s16vector-of-length-ec n (:range i 0 n) (apply f (map (lambda (v) (s16vector-ref v i)) (cons v rest))))))
(define (u16vector-map f v . rest)  
  (let ((n (u16vector-length v)))
    (u16vector-of-length-ec n (:range i 0 n) (apply f (map (lambda (v) (u16vector-ref v i)) (cons v rest))))))
(define (s8vector-map f v . rest)  
  (let ((n (s8vector-length v)))
    (s8vector-of-length-ec n (:range i 0 n) (apply f (map (lambda (v) (s8vector-ref v i)) (cons v rest))))))
(define (u8vector-map f v . rest)  
  (let ((n (u8vector-length v)))
    (u8vector-of-length-ec n (:range i 0 n) (apply f (map (lambda (v) (u8vector-ref v i)) (cons v rest))))))


(define (f64vector-mapi f v . rest)  
  (let ((n (f64vector-length v)))
    (f64vector-of-length-ec n (:range i 0 n) (apply f (cons i  (map (lambda (v) (f64vector-ref v i)) (cons v rest)))))))
(define (f32vector-mapi f v . rest)  
  (let ((n (f32vector-length v)))
    (f32vector-of-length-ec n (:range i 0 n) (apply f (cons i  (map (lambda (v) (f32vector-ref v i)) (cons v rest)))))))
(define (s32vector-mapi f v . rest)  
  (let ((n (s32vector-length v)))
    (s32vector-of-length-ec n (:range i 0 n) (apply f (cons i  (map (lambda (v) (s32vector-ref v i)) (cons v rest)))))))
(define (u32vector-mapi f v . rest)  
  (let ((n (u32vector-length v)))
    (u32vector-of-length-ec n (:range i 0 n) (apply f (cons i  (map (lambda (v) (u32vector-ref v i)) (cons v rest)))))))
(define (s16vector-mapi f v . rest)  
  (let ((n (s16vector-length v)))
    (s16vector-of-length-ec n (:range i 0 n) (apply f (cons i  (map (lambda (v) (s16vector-ref v i)) (cons v rest)))))))
(define (u16vector-mapi f v . rest)  
  (let ((n (u16vector-length v)))
    (u16vector-of-length-ec n (:range i 0 n) (apply f (cons i  (map (lambda (v) (u16vector-ref v i)) (cons v rest)))))))
(define (s8vector-mapi f v . rest)  
  (let ((n (s8vector-length v)))
    (s8vector-of-length-ec n (:range i 0 n) (apply f (cons i  (map (lambda (v) (s8vector-ref v i)) (cons v rest)))))))
(define (u8vector-mapi f v . rest)  
  (let ((n (u8vector-length v)))
    (u8vector-of-length-ec n (:range i 0 n) (apply f (cons i (map (lambda (v) (u8vector-ref v i)) (cons v rest)))))))


;;
;; In-place quick sort from SRFI-32 reference implementation.
;; Modified so that the comparison function uses element indices as
;; well as element values:
;;
;; elt< :: i1 v1 i2 v2 -> boolean
;;
;; Copyright (c) 1998 by Olin Shivers. You may do as you please with
;; this code, as long as you do not delete this notice or hold me
;; responsible for any outcome related to its use.
;;

(define (srfi-4-vector-quick-sort! vector-ref vector-set! vector-length)
  (lambda (elt< v . rest)
   (let-optionals rest ((start 0) (end (vector-length v)))
    (let recur ((l start) (r end))	; Sort the range [l,r).
      (if (fx< 1 (fx- r l))
	  
	  ;; Choose the median of V[l], V[r], and V[middle] for the pivot.
	  (let ((median
		 (lambda (i1 i2 i3)
		   (let ((v1 (vector-ref v i1))
			 (v2 (vector-ref v i2))
			 (v3 (vector-ref v i3)))
		     (receive (ilittle little ibig big)
			      (if (elt< i1 v1 i2 v2) (values i1 v1 i2 v2) (values i2 v2 i1 v1))
			      (if (elt< ibig big i3 v3) 
				  (values ibig big)
				  (if (elt< ilittle little i3 v3) 
				      (values i3 v3) 
				      (values ilittle little))))))))
	    
	    (let-values (((ipivot pivot) (median l (quotient (fx+ l r) 2) (fx- r 1))))
   	      (let loop ((i l) (j (fx- r 1)))
		(let ((i (let scan ((i i)) (if (elt< i (vector-ref v i) ipivot pivot)
					       (scan (fx+ i 1))
					       i)))
		      (j (let scan ((j j)) (if (elt< ipivot pivot j (vector-ref v j))
					       (scan (fx- j 1))
					       j))))
		  (if (fx< i j)
		      (let ((tmp (vector-ref v j)))		
			(vector-set! v j (vector-ref v i))	; Swap V[I]
			(vector-set! v i tmp)		;  and V[J].
			(loop (fx+ i 1) (fx- j 1)))
		      
		      (begin (recur l i) (recur (fx+ j 1) r)))))))
	  v)))))


(define f64vector-quick-sort!
  (srfi-4-vector-quick-sort! f64vector-ref f64vector-set! f64vector-length))
(define f32vector-quick-sort!
  (srfi-4-vector-quick-sort! f32vector-ref f32vector-set! f32vector-length))
(define s32vector-quick-sort!
  (srfi-4-vector-quick-sort! s32vector-ref s32vector-set! s32vector-length))
(define u32vector-quick-sort!
  (srfi-4-vector-quick-sort! u32vector-ref u32vector-set! u32vector-length))
(define s16vector-quick-sort!
  (srfi-4-vector-quick-sort! s16vector-ref s16vector-set! s16vector-length))
(define u16vector-quick-sort!
  (srfi-4-vector-quick-sort! u16vector-ref u16vector-set! u16vector-length))
(define s8vector-quick-sort!
  (srfi-4-vector-quick-sort! s8vector-ref s8vector-set! s8vector-length))
(define u8vector-quick-sort!
  (srfi-4-vector-quick-sort! u8vector-ref u8vector-set! u8vector-length))


; Blit FROM[I,END) to TO[J,?].

(define (srfi-4-vector-blit! vector-ref vector-set! )
  (lambda (from i end to j)      
    (assert (< i end))
    (let recur ((i i) (j j))
      (if (< i end)
          (let ((vi (vector-ref from i)))
            (vector-set! to j vi)
            (recur (+ i 1) (+ j 1)))
          ))
      ))


(define f64vector-blit!
  (srfi-4-vector-blit! f64vector-ref f64vector-set!))
(define f32vector-blit!
  (srfi-4-vector-blit! f32vector-ref f32vector-set!))
(define s32vector-blit!
  (srfi-4-vector-blit! s32vector-ref s32vector-set!))
(define u32vector-blit!
  (srfi-4-vector-blit! u32vector-ref u32vector-set!))
(define s16vector-blit!
  (srfi-4-vector-blit! s16vector-ref s16vector-set!))
(define u16vector-blit!
  (srfi-4-vector-blit! u16vector-ref u16vector-set!))
(define s8vector-blit!
  (srfi-4-vector-blit! s8vector-ref s8vector-set!))
(define u8vector-blit!
  (srfi-4-vector-blit! u8vector-ref u8vector-set!))


;; Given array A and indices p, q, r such that p < q < r, 
;; merge subarray A[p..q) and subarray A[q..r) into array B[n..]

(define (srfi-4-vector-merge! vector-ref vector-set! vblit! vector-length)
  (lambda (elt< a p q r b n)
    (assert (and (< p q) (< q r)))
    (let recur ((i p) (j q) (k n))
      (if (and (< i q) (< j r))
          (let ((ai (vector-ref a i))
                (bj (vector-ref a j)))
            (if (elt< i ai j bj)
                (begin
                  (vector-set! b k ai)
                  (recur (+ 1 i) j (+ 1 k)))
                (begin
                  (vector-set! b k bj)
                  (recur i (+ 1 j) (+ 1 k)))
                ))
          (if (< i q)
              (vblit! a i q b k)
              (if (< j r)
                  (vblit! a j r b k))))
      b
      ))
  )



(define f64vector-merge!
  (srfi-4-vector-merge! f64vector-ref f64vector-set! f64vector-blit! f64vector-length ))
(define f32vector-merge!
  (srfi-4-vector-merge! f32vector-ref f32vector-set! f32vector-blit! f32vector-length ))
(define s32vector-merge!
  (srfi-4-vector-merge! s32vector-ref s32vector-set! s32vector-blit! s32vector-length ))
(define u32vector-merge!
  (srfi-4-vector-merge! u32vector-ref u32vector-set! u32vector-blit! u32vector-length ))
(define s16vector-merge!
  (srfi-4-vector-merge! s16vector-ref s16vector-set! s16vector-blit! s16vector-length ))
(define u16vector-merge!
  (srfi-4-vector-merge! u16vector-ref u16vector-set! u16vector-blit! u16vector-length ))
(define s8vector-merge!
  (srfi-4-vector-merge! s8vector-ref s8vector-set! s8vector-blit! s8vector-length ))
(define u8vector-merge!
  (srfi-4-vector-merge! u8vector-ref u8vector-set! u8vector-blit! u8vector-length ))



;; Vector merge sort
(define (srfi-4-vector-merge-sort! vector-length vector-ref vector-set! vector-merge! vblit!)
  (lambda (elt< a )
    (let ((b (make-f64vector (vector-length a) 0.)))
      (let recur ((p 0) (r (vector-length a)))
        (if (> (- r p) 2)
            (let ((q (+ p (quotient (- r p 1) 2))))
              (recur p q)
              (recur q r)
              (vector-merge! elt< a p q r b p)
              (vblit! b p r a p)
              )
            (let ((v1 (vector-ref a p))
                  (v2 (vector-ref a (+ 1 p))))
              (if (elt< (+ 1 p) v2 p v1 )
                  (begin (vector-set! a p v2)
                         (vector-set! a (+ 1 p) v1)))
              )
            ))
      b)
    ))
                   

(define f64vector-merge-sort!
  (srfi-4-vector-merge-sort! f64vector-length f64vector-ref f64vector-set! f64vector-merge! f64vector-blit!))
(define f32vector-merge-sort!
  (srfi-4-vector-merge-sort! f32vector-length f32vector-ref f32vector-set! f32vector-merge! f32vector-blit!))
(define s32vector-merge-sort!
  (srfi-4-vector-merge-sort! s32vector-length s32vector-ref s32vector-set! s32vector-merge! s32vector-blit!))
(define u32vector-merge-sort!
  (srfi-4-vector-merge-sort! u32vector-length u32vector-ref u32vector-set! u32vector-merge! u32vector-blit!))
(define s16vector-merge-sort!
  (srfi-4-vector-merge-sort! s16vector-length s16vector-ref s16vector-set! s16vector-merge! s16vector-blit!))
(define u16vector-merge-sort!
  (srfi-4-vector-merge-sort! u16vector-length u16vector-ref u16vector-set! u16vector-merge! u16vector-blit!))
(define s8vector-merge-sort!
  (srfi-4-vector-merge-sort! s8vector-length s8vector-ref s8vector-set! s8vector-merge! s8vector-blit!))
(define u8vector-merge-sort!
  (srfi-4-vector-merge-sort! u8vector-length u8vector-ref u8vector-set! u8vector-merge! u8vector-blit!))

)