fork(1) download
copy 
  1. ; priority queues with distinct elements
  2.  
  3. ; priority queue -- pairing heaps
  4.  
  5. (define pq-empty (list))
  6.  
  7. (define pq-empty? null?)
  8.  
  9. (define (pq-first pq)
  10.   (if (null? pq)
  11.       (error 'pq-first "can't extract minimum from null queue")
  12.       (car pq)))
  13.  
  14. (define (pq-merge lt? p1 p2)
  15.   (cond ((null? p1) p2)
  16.         ((null? p2) p1)
  17.         ((lt? (car p2) (car p1))
  18.           (cons (car p2) (cons p1 (cdr p2))))
  19.         (else (cons (car p1) (cons p2 (cdr p1))))))
  20.  
  21. (define (pq-insert lt? x pq)
  22.   (pq-merge lt? (list x) pq))
  23.  
  24. (define (pq-merge-pairs lt? ps)
  25.   (cond ((null? ps) '())
  26.         ((null? (cdr ps)) (car ps))
  27.         (else (pq-merge lt? (pq-merge lt? (car ps) (cadr ps))
  28.                             (pq-merge-pairs lt? (cddr ps))))))
  29.  
  30. (define (pq-rest lt? pq)
  31.   (if (null? pq)
  32.       (error 'pq-rest "can't delete minimum from null queue")
  33.       (pq-merge-pairs lt? (cdr pq))))
  34.  
  35. (define (list->pq lt? xs)
  36.   (let loop ((xs xs) (pq pq-empty))
  37.     (if (null? xs) pq
  38.       (loop (cdr xs) (pq-insert lt? (car xs) pq)))))
  39.  
  40. (define (pq->list lt? pq)
  41.   (let loop ((pq pq) (xs '()))
  42.     (if (pq-empty? pq) (reverse xs)
  43.       (loop (pq-rest lt? pq) (cons (pq-first pq) xs)))))
  44.  
  45. ; binary search tree
  46.  
  47. (define bst-empty (list))
  48.  
  49. (define bst-empty? null?)
  50.  
  51. (define (bst-member? lt? item bst)
  52.   (cond ((bst-empty? bst) #f)
  53.         ((lt? item (car bst))
  54.           (bst-member? lt? item (cadr bst)))
  55.         ((lt? (car bst) item)
  56.           (bst-member? lt? item (caddr bst)))
  57.         (else #t)))
  58.  
  59. (define (bst-insert lt? item bst)
  60.   (cond ((bst-empty? bst)
  61.           (list item (list) (list)))
  62.         ((lt? item (car bst))
  63.           (list (car bst)
  64.                 (bst-insert lt? item (cadr bst))
  65.                 (caddr bst)))
  66.         ((lt? (car bst) item)
  67.           (list (car bst)
  68.                 (cadr bst)
  69.                 (bst-insert lt? item (caddr bst))))
  70.         (else bst)))
  71.  
  72. (define (bst-successor bst)
  73.   (cond ((bst-empty? bst) bst-empty)
  74.         ((bst-empty? (cadr bst)) bst)
  75.         (else (bst-successor (cadr bst)))))
  76.  
  77. (define (bst-delete-root lt? bst)
  78.   (cond ((and (bst-empty? (cadr bst))
  79.           (bst-empty? (caddr bst))) bst-empty)
  80.         ((bst-empty? (cadr bst)) (caddr bst))
  81.         ((bst-empty? (caddr bst)) (cadr bst))
  82.         (else (let ((new-root (car (bst-successor (caddr bst)))))
  83.                 (list new-root (cadr bst)
  84.                       (bst-delete lt? new-root (caddr bst)))))))
  85.  
  86. (define (bst-delete lt? item bst)
  87.   (cond ((bst-empty? bst) bst)
  88.         ((lt? item (car bst))
  89.           (list (car bst)
  90.                 (bst-delete lt? item (cadr bst))
  91.                 (caddr bst)))
  92.         ((lt? (car bst) item)
  93.           (list (car bst)
  94.                 (cadr bst)
  95.                 (bst-delete lt? item (caddr bst))))
  96.         (else (bst-delete-root lt? bst))))
  97.  
  98. ; distinct priority queue
  99.  
  100. (define (make-dpq lt?) (list lt? pq-empty bst-empty))
  101.  
  102. (define (dpq-empty? dpq) (pq-empty? (cadr dpq)))
  103.  
  104. (define (dpq-first dpq)
  105.   (if (dpq-empty? dpq)
  106.       (error 'dpq-first "can't extract minimum from null queue")
  107.       (pq-first (cadr dpq))))
  108.  
  109. (define (dpq-insert item dpq)
  110.   (if (bst-member? (car dpq) item (caddr dpq))
  111.       dpq
  112.       (list (car dpq)
  113.             (pq-insert (car dpq) item (cadr dpq))
  114.             (bst-insert (car dpq) item (caddr dpq)))))
  115.  
  116. (define (dpq-rest dpq)
  117.   (if (dpq-empty? dpq)
  118.       (error 'dpq-rest "can't delete minimum from null queue")
  119.       (list (car dpq)
  120.             (pq-rest (car dpq) (cadr dpq))
  121.             (bst-delete (car dpq) (dpq-first dpq) (caddr dpq)))))
  122.  
  123. (define (dpq-enlist dpq) (pq->list (car dpq) (cadr dpq)))
  124.  
  125. ; demonstration
  126.  
  127. (define dpq (make-dpq <))
  128. (set! dpq (dpq-insert 3 dpq))
  129. (set! dpq (dpq-insert 4 dpq))
  130. (set! dpq (dpq-insert 1 dpq))
  131. (set! dpq (dpq-insert 5 dpq))
  132. (set! dpq (dpq-insert 3 dpq))
  133. (set! dpq (dpq-insert 2 dpq))
  134. (set! dpq (dpq-insert 5 dpq))
  135. (set! dpq (dpq-insert 1 dpq))
  136. (set! dpq (dpq-insert 2 dpq))
  137. (set! dpq (dpq-insert 4 dpq))
  138. (display (dpq-enlist dpq)) (newline)
  139. (display (dpq-first dpq)) (newline)
  140. (set! dpq (dpq-rest dpq))
  141. (set! dpq (dpq-rest dpq))
  142. (display (dpq-first dpq)) (newline)
  143. (set! dpq (dpq-rest dpq))
  144. (set! dpq (dpq-rest dpq))
  145. (display (dpq-first dpq)) (newline)
  146. (set! dpq (dpq-rest dpq))
  147. (display (dpq-enlist dpq)) (newline)
Success #stdin #stdout 0.07s 8896KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
(1 2 3 4 5)
1
3
5
()
https://ideone.com/K8njrh
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!