Gauche で、binary-heap の key を有効にする

binary-heap-patch.scm

;;
;; binary-heap patch for key
;;

(use data.heap)

(with-module data.heap
 (define (make-binary-heap :key (comparator default-comparator)
                                (storage (make-sparse-vector))
                                (key identity))
   (unless (comparator-ordered? comparator)
     (error "make-binary-heap requires ordered comparator, \
             but got:" comparator))
   (receive (<: >:)
       ;(ecase (comparator-flavor comparator)
       ;  [(ordering) (values (comparator-ordering-predicate comparator)
       ;                      (^[a b] (>? comparator a b)))]
       ;  [(comparison) (values (^[a b] (<? comparator a b))
       ;                        (^[a b] (>? comparator a b)))])
       (values (^[a b] (<? comparator (key a) (key b)))
               (^[a b] (>? comparator (key a) (key b))))
     (make <binary-heap> :comparator comparator
           :storage (if (or (vector? storage) (uvector? storage)
                            (is-a? storage <sparse-vector-base>))
                      storage
                      (error "make-binary-heap requires a vector, a uvector \
                              or a sparse vector as a storage, but got:"
                             storage))
           :key key
           :capacity (cond [(vector? storage) (vector-length storage)]
                           [(uvector? storage) (uvector-length storage)]
                           [else +inf.0])
           :<: <:
           :>: >:)))
 )

(with-module data.heap
 (define (build-binary-heap storage :key (num-entries #f)
                                         (comparator default-comparator)
                                         (key identity))
   (unless (comparator-ordered? comparator)
     (error "build-binary-heap requires ordered comparator, \
             but got:" comparator))
   (let* ([xlen (cond
                 [(vector? storage) (vector-length storage)]
                 [(uvector? storage) (uvector-length storage)]
                 [(is-a? storage <sparse-vector-base>)
                  (sparse-vector-num-entries storage)]
                 [else (error "build-binary-heap requires a vector, a uvector \
                               or a sparse vector as a storage, but got:"
                               storage)])]
          [size (cond [(not num-entries) xlen]
                      [(and (integer? num-entries) (>= num-entries 0))
                       (min num-entries xlen)]
                      [else
                       (error "invalid num-entries value for build-binary-heap:"
                              num-entries)])])
     (receive (<: >:)
         ;(ecase (comparator-flavor comparator)
         ;  [(ordering) (values (comparator-ordering-predicate comparator)
         ;                      (^[a b] (>? comparator a b)))]
         ;  [(comparison) (values (^[a b] (<? comparator a b))
         ;                        (^[a b] (>? comparator a b)))])
         (values (^[a b] (<? comparator (key a) (key b)))
                 (^[a b] (>? comparator (key a) (key b))))
       (bh-heapify! storage <: >: size)
       (make <binary-heap> :comparator comparator :storage storage :key key
             :<: <: :>: >: :next-leaf (+ size 1)
             :capacity (cond [(vector? storage) (vector-length storage)]
                             [(uvector? storage) (uvector-length storage)]
                             [else +inf.0])))))
 )

test.bat

gosh test.scm
pause

test.scm

;;
;; Test binary-heap patch for key
;;

(add-load-path "." :relative)
(use gauche.test)

(test-start "binary-heap patch for key")
(use data.heap)
(load "binary-heap-patch")

(test-module 'data.heap)

(test-section "binary-heap-function")

(define *bh1* (make-binary-heap :key car))
(binary-heap-push! *bh1* (cons 1 200))
(binary-heap-push! *bh1* (cons 2 100))
(test* "binary-heap-find-min (key=car)" '(1 . 200) (binary-heap-find-min *bh1*))
(test* "binary-heap-find-max (key=car)" '(2 . 100) (binary-heap-find-max *bh1*))

(define *bh2* (make-binary-heap :key cdr))
(binary-heap-push! *bh2* (cons 1 200))
(binary-heap-push! *bh2* (cons 2 100))
(test* "binary-heap-find-min (key=cdr)" '(2 . 100) (binary-heap-find-min *bh2*))
(test* "binary-heap-find-max (key=cdr)" '(1 . 200) (binary-heap-find-max *bh2*))

(define *bh3* (make-binary-heap :key (^x (* -1 (car x)))))
(binary-heap-push! *bh3* (cons 1 200))
(binary-heap-push! *bh3* (cons 2 100))
(test* "binary-heap-find-min (key=(^x (* -1 (car x))))" '(2 . 100) (binary-heap-find-min *bh3*))
(test* "binary-heap-find-max (key=(^x (* -1 (car x))))" '(1 . 200) (binary-heap-find-max *bh3*))

;; summary
(format (current-error-port) "~%~a" ((with-module gauche.test format-summary)))

(test-end)