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