;;
;; 
;; 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/>.
;;
;;


(import scheme chicken)
(require-library srfi-1 srfi-13 extras)
(import (only srfi-1 fold every)
        (only srfi-13 string-concatenate)
        (only extras printf pp))
(require-extension srfi-4 miscmacros matchable)


(define (s+ . args)
  (string-concatenate (map ->string args)))


(define $ string->symbol)


(define (make-srfi-4-merge-sort-crunch types elts<)

  (let ((ops
         '(
           (simple vector_blit make-vector-blit vector-ref vector-set!)
           ((elt<) vector_merge make-vector-merge vector-ref vector-set! vector_blit vector-length)
           ((elt<) vector_merge_sort make-vector-merge-sort vector_merge vector_blit vector-length)
           ))
        )
        
  (for-each
   pp
   `(
     (define f64make-vector make-f64vector)
     (define (fpmin a b) (if (< a b) a b))
     
     (define-syntax define-syntax-rule
       (syntax-rules ()
         ((_ (name . args) . more)
          (define-syntax name
            (syntax-rules ()
              ((_ . args) . more))))))
     
     
     (define-syntax-rule
       (make-vector-blit name vector-ref vector-set!)
       (define (name from i end to j)
         (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-syntax-rule
       (make-vector-merge name elt< vector-ref vector-set! vector_blit vector-length)
       (define (name a p q r b n)
         (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)
                   (vector_blit a i q b k)
                   (if (< j r)
                       (vector_blit a j r b k)))
               ))
         b
         )
       )


     (define-syntax-rule
       (make-vector-merge-sort name elt< vector_merge vector_blit vector-length)
       (define (name a b)
         (let ((n (vector-length a)))
           (let recur ((m 1))
             (if (< m n)
                 (let inner-recur ((p 0))
                   (if (< p (- n m))
                       (let ((q (+ p m))
                             (r (fpmin (+ p (* 2 m)) n)))
                         (vector_merge a p q r b p)
                         (vector_blit b p r a p)
                         (inner-recur (+ p (* 2 m)))
                         )
                       (recur (* m 2))))
                 ))
           a
           )))


     ,@(map (match-lambda ((op . body) `(define (,op i vi v vj) ,(body 'i 'vi 'v 'vj)))) elts< )

     ,@(concatenate 
        (map (match-lambda
              (('simple oper kons . vops)
               (map 
                (lambda (type)
                  (let ((fn ($ (s+ type oper))))
                    `(,kons ,fn ,@(map (lambda (n) ($ (s+ type n))) vops))))
                types))

              ((('elt<) oper kons . vops)
               (map 
                (lambda (type elt<)
                  (let ((fn ($ (s+ type oper))))
                    `(,kons ,fn ,(car elt<) ,@(map (lambda (n) ($ (s+ type n))) vops))))
                types elts<))
              
              )
             ops))
     ))
  ))


(define (make-srfi-4-blit-crunch types)

  (let ((ops
         '(
           (simple vector_blit make-vector-blit vector-ref vector-set!)
           ))
        )
        
  (for-each
   pp
   `(
     (define f64make-vector make-f64vector)
     (define (fpmin a b) (if (< a b) a b))
     
     (define-syntax define-syntax-rule
       (syntax-rules ()
         ((_ (name . args) . more)
          (define-syntax name
            (syntax-rules ()
              ((_ . args) . more))))))
     
     
     (define-syntax-rule
       (make-vector-blit name vector-ref vector-set!)
       (define (name from i end to j)
         (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)))
               ))
         ))


     ,@(concatenate 
        (map (match-lambda
              (('simple oper kons . vops)
               (map 
                (lambda (type)
                  (let ((fn ($ (s+ type oper))))
                    `(,kons ,fn ,@(map (lambda (n) ($ (s+ type n))) vops))))
                types))

              )
             ops))
     ))
  ))

(make-srfi-4-merge-sort-crunch 
 '(f64)
 `((f64-elt< . ,(lambda (i vi j vj) `(< ,vi ,vj))))
 )