[ create a new paste ] login | about

Project: programmingpraxis
Link: http://programmingpraxis.codepad.org/V8v6If7Z    [ raw code | output | fork ]

programmingpraxis - Scheme, pasted on May 3:
; priority queues

(define-syntax pq-rank (syntax-rules () ((_ pq) (vector-ref pq 0))))
(define-syntax pq-item (syntax-rules () ((_ pq) (vector-ref pq 1))))
(define-syntax pq-lkid (syntax-rules () ((_ pq) (vector-ref pq 2))))
(define-syntax pq-rkid (syntax-rules () ((_ pq) (vector-ref pq 3))))

(define pq-empty (vector 0 'pq-empty 'pq-empty 'pq-empty))
(define (pq-empty? pq) (eqv? pq pq-empty))

(define (pq-merge lt? p1 p2)
  (define (pq-swap item lkid rkid)
    (if (< (pq-rank rkid) (pq-rank lkid))
        (vector (+ (pq-rank rkid) 1) item lkid rkid)
        (vector (+ (pq-rank lkid) 1) item rkid lkid)))
  (cond ((pq-empty? p1) p2)
        ((pq-empty? p2) p1)
        ((lt? (pq-item p2) (pq-item p1))
          (pq-swap (pq-item p2) (pq-lkid p2)
                   (pq-merge lt? p1 (pq-rkid p2))))
        (else (pq-swap (pq-item p1) (pq-lkid p1)
                       (pq-merge lt? (pq-rkid p1) p2)))))

(define (pq-insert lt? x pq)
  (pq-merge lt? (vector 1 x pq-empty pq-empty) pq))

(define (pq-first pq)
  (if (pq-empty? pq)
      (error 'pq-first "empty priority queue")
      (pq-item pq)))

(define (pq-rest lt? pq)
  (if (pq-empty? pq)
      (error 'pq-rest "empty priority queue")
      (pq-merge lt? (pq-lkid pq) (pq-rkid pq))))

(define (list->pq lt? xs)
  (let loop ((xs xs) (pq pq-empty))
    (if (null? xs) pq
      (loop (cdr xs) (pq-insert lt? (car xs) pq)))))

(define (pq->list lt? pq)
  (let loop ((pq pq) (xs '()))
    (if (pq-empty? pq) (reverse xs)
      (loop (pq-rest lt? pq) (cons (pq-first pq) xs)))))

(define (pq-sort lt? xs)
  (pq->list lt? (list->pq lt? xs)))

(display (pq-sort < '(3 7 8 1 2 9 6 4 5)))


Output:
1
(1 2 3 4 5 6 7 8 9)


Create a new paste based on this one


Comments: