fork download
copy 
  1. ; conditional heap insertion
  2.  
  3. (define-syntax pq-rank (syntax-rules () ((_ pq) (vector-ref pq 0))))
  4. (define-syntax pq-item (syntax-rules () ((_ pq) (vector-ref pq 1))))
  5. (define-syntax pq-lkid (syntax-rules () ((_ pq) (vector-ref pq 2))))
  6. (define-syntax pq-rkid (syntax-rules () ((_ pq) (vector-ref pq 3))))
  7.  
  8. (define pq-empty (vector 0 'pq-empty 'pq-empty 'pq-empty))
  9. (define (pq-empty? pq) (eqv? pq pq-empty))
  10.  
  11. (define (pq-merge lt? p1 p2)
  12.   (define (pq-swap item lkid rkid)
  13.     (if (< (pq-rank rkid) (pq-rank lkid))
  14.         (vector (+ (pq-rank rkid) 1) item lkid rkid)
  15.         (vector (+ (pq-rank lkid) 1) item rkid lkid)))
  16.   (cond ((pq-empty? p1) p2)
  17.         ((pq-empty? p2) p1)
  18.         ((lt? (pq-item p2) (pq-item p1))
  19.           (pq-swap (pq-item p2) (pq-lkid p2)
  20.                    (pq-merge lt? p1 (pq-rkid p2))))
  21.         (else (pq-swap (pq-item p1) (pq-lkid p1)
  22.                        (pq-merge lt? (pq-rkid p1) p2)))))
  23.  
  24. (define (pq-insert lt? x pq)
  25.   (pq-merge lt? (vector 1 x pq-empty pq-empty) pq))
  26.  
  27. (define (pq-first pq)
  28.   (if (pq-empty? pq)
  29.       (error 'pq-first "empty priority queue")
  30.       (pq-item pq)))
  31.  
  32. (define (pq-rest lt? pq)
  33.   (if (pq-empty? pq)
  34.       (error 'pq-rest "empty priority queue")
  35.       (pq-merge lt? (pq-lkid pq) (pq-rkid pq))))
  36.  
  37. (define (pq-contains? lt? x pq)
  38.   (if (pq-empty? pq) #f
  39.     (if (lt? x (pq-item pq)) #f
  40.       (if (not (lt? (pq-item pq) x)) #t
  41.         (or (pq-contains? lt? x (pq-lkid pq))
  42.             (pq-contains? lt? x (pq-rkid pq)))))))
  43.  
  44. (define (pq-conditional-insert lt? x pq)
  45.   (if (pq-contains? lt? x pq) pq
  46.     (pq-insert lt? x pq)))
  47.  
  48. (define pq
  49.   (pq-insert < 3
  50.   (pq-insert < 7
  51.   (pq-insert < 8
  52.   (pq-insert < 1
  53.   (pq-insert < 2
  54.   (pq-insert < 9
  55.   (pq-insert < 6
  56.   (pq-insert < 4
  57.   (pq-insert < 5
  58.   pq-empty))))))))))
  59.  
  60. (display pq) (newline)
  61.  
  62. (display (pq-contains? < 3 pq)) (newline)
  63.  
  64. (display (pq-contains? < 0 pq)) (newline)
  65.  
  66. (display (pq-conditional-insert < 0 pq))
Success #stdin #stdout 0.05s 8744KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
#(2 1 #(2 2 #(2 4 #(1 5 #(1 9 #(0 pq-empty pq-empty pq-empty) #(0 pq-empty pq-empty pq-empty)) #(0 pq-empty pq-empty pq-empty)) #(1 6 #(0 pq-empty pq-empty pq-empty) #(0 pq-empty pq-empty pq-empty))) #(1 7 #(0 pq-empty pq-empty pq-empty) #(0 pq-empty pq-empty pq-empty))) #(1 3 #(1 8 #(0 pq-empty pq-empty pq-empty) #(0 pq-empty pq-empty pq-empty)) #(0 pq-empty pq-empty pq-empty)))
#t
#f
#(1 0 #(2 1 #(2 2 #(2 4 #(1 5 #(1 9 #(0 pq-empty pq-empty pq-empty) #(0 pq-empty pq-empty pq-empty)) #(0 pq-empty pq-empty pq-empty)) #(1 6 #(0 pq-empty pq-empty pq-empty) #(0 pq-empty pq-empty pq-empty))) #(1 7 #(0 pq-empty pq-empty pq-empty) #(0 pq-empty pq-empty pq-empty))) #(1 3 #(1 8 #(0 pq-empty pq-empty pq-empty) #(0 pq-empty pq-empty pq-empty)) #(0 pq-empty pq-empty pq-empty))) #(0 pq-empty pq-empty pq-empty))
https://ideone.com/Mz798f
language:
Scheme (guile 2.2.4)
created:
7 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!