51404 bsmntbombdood ;;;; ;;;; Purely functional, mergeable priority queues. ;;;; ;;;; A priority queue is a bag of ordered elements, with addition of ;;;; elements, removal of the minimum element, and merging of two ;;;; queues into one. The order of elements is given by a predicate ;;;; that's a curried argument to each operation; using different ;;;; predicates on the same queue will produce unpredictable results. ;;;; ;;;; PQ-MIN, PQ-INSERT, and PQ-MERGE are constant-time, while ;;;; PQ-REMOVE-MIN is conjectured to take logarithmic amortized time, ;;;; assuming a single thread of use; see Chris Okasaki's paper ;;;; ``Functional Data Structures'' for a way to handle general access ;;;; patterns efficiently. This code is adapted from that paper. ;;;; ;;;; We represent a queue by a pairing heap: either the empty heap, or ;;;; a pair of the minimum element and a list of sub-heaps that merge ;;;; to form the overall heap. The sub-heaps must not be empty. ;;;; ;;;; This code is in the public domain. ;;;; ;;;; Darius Bacon <darius@accesscom.com> ;;;; http://www.accesscom.com/~darius ;;;; ;; This is the only non-R4RS procedure used: ;(define error ; (lambda (complaint object) ...)) ;; For a significant speedup, get your compiler to inline these: (define make-pq cons) (define pq/elem car) (define pq/rest cdr) ;; The priority queue with no elements. (define empty-pq '()) ;; True iff PQ is empty. (define pq-empty? null?) ;; Return the minimum element of PQ. ;; Signals an error if PQ is empty. (define pq-min (lambda (<=?) (lambda (pq) (if (pq-empty? pq) (error "PQ-MIN of an empty pq" '()) (pq/elem pq))))) ;; Return a priority queue with a single element, ELEM. (define unit-pq (lambda (<=?) (lambda (elem) (make-pq elem '())))) ;; Return a priority queue combining the elements of PQ1 and PQ2. (define pq-merge (lambda (<=?) (lambda (pq1 pq2) (cond ((pq-empty? pq1) pq2) ((pq-empty? pq2) pq1) (else (let ((min1 (pq/elem pq1)) (min2 (pq/elem pq2))) (if (<=? min1 min2) (make-pq min1 (cons pq2 (pq/rest pq1))) (make-pq min2 (cons pq1 (pq/rest pq2)))))))))) ;; Return PQ with ELEM inserted. (define pq-insert (lambda (<=?) (lambda (pq elem) ; ((pq-merge <=?) (unit-pq elem) pq))) (cond ((pq-empty? pq) (make-pq elem '())) (else (let ((min1 (pq/elem pq)) (min2 elem)) (if (<=? min1 min2) (make-pq min1 (cons (make-pq elem '()) (pq/rest pq))) (make-pq min2 (cons pq '()))))))))) ;; Return PQ with its minimum element removed. ;; Signals an error if PQ is empty. (define pq-remove-min (lambda (<=?) (let ((merge (pq-merge? <=?))) (lambda (pq) (if (pq-empty? pq) (error "PQ-REMOVE-MIN of empty pq" '()) (let merging ((pqs (pq/rest pq))) (cond ((null? pqs) empty-pq) ((null? (cdr pqs)) (car pqs)) (else (merge ;((pq-merge <=?) (car pqs) (cadr pqs)) (let* ((pq1 (car pqs)) (pq2 (cadr pqs)) (min1 (pq/elem pq1)) (min2 (pq/elem pq2))) (if (<=? min1 min2) (make-pq min1 (cons pq2 (pq/rest pq1))) (make-pq min2 (cons pq1 (pq/rest pq2))))) (merging (cddr pqs))))))))))) ;;; ;;; Testing ;;; (define int-min (pq-min <=)) (define int-insert (pq-insert <=)) (define int-remove-min (pq-remove-min <=)) (define grow-and-shrink (lambda (numbers empty empty? get-min insert remove-min) (let* ((history '()) (insert (lambda (pq elem) (let ((pq (insert pq elem))) (set! history (cons (get-min pq) history)) pq))) (remove-min (lambda (pq) (let ((pq (remove-min pq))) (set! history (cons (if (empty? pq) 'empty (get-min pq)) history)) pq)))) (define growing (lambda (pq ns) (if (null? ns) pq (let ((pq (insert pq (car ns))) (ns (cdr ns))) (if (null? ns) pq (growing (remove-min (insert pq (car ns))) (cdr ns))))))) (define shrinking (lambda (pq ns) (if (empty? pq) (reverse history) (shrinking (remove-min (remove-min (insert pq (car ns)))) (cdr ns))))) (shrinking (growing empty-pq numbers) numbers)))) (define test-with (lambda (numbers) (define insert-sorted (lambda (ns n) (if (or (null? ns) (<= n (car ns))) (cons n ns) (cons (car ns) (insert-sorted (cdr ns) n))))) (let ((history-1 (grow-and-shrink numbers empty-pq pq-empty? int-min int-insert int-remove-min)) (history-2 (grow-and-shrink numbers '() null? car insert-sorted cdr))) (if (equal? history-1 history-2) history-1 (error "Test failed" (list history-1 history-2)))))) (define test-each-tail (lambda (numbers) (do ((ns numbers (cdr ns))) ((null? ns)) (test-with ns) (test-with (reverse ns))))) (define test (lambda () (test-each-tail '(3 1 4 1 5 9 2 6 5 3 5 8 9 7 9 3 2 3 8 4 6 2 6 4 3 3 8 3 2 7 9 5 0 2 8 8 4 1 9 7 1 6 9 3 9 9 3 7 5 1 0 2 7 1 8 2 8 1 8 2 8 4 5 9 0 4 5)) (test-each-tail '(0 1 2 3 4 5)) (test-each-tail '(0 0 0 0 0)))) 3405041874 #lispcafe Scheme