Use (d-) implement heap procedures

graphgif.scm

@@ -1,6 +1,7 @@
 (define-module (graphgif))
 
 (use-modules (cairo)
+	     (d-)
 	     (srfi srfi-1)
 	     (srfi srfi-9 gnu)
 	     (srfi srfi-43))
@@ -178,6 +179,43 @@
 ;; ALGORITHMS!!! ;;
 ;;;;;;;;;;;;;;;;;;;
 
+;; Heap algorithms
+(define (heap-insert priority item heap)
+  (define (fix-up! i heap)
+    (if (zero? i)
+	heap
+	(let* ([parent (quotient i 2)]
+	       [i-priority (car (vector-ref heap i))]
+	       [parent-priority (car (vector-ref heap parent))])
+	  (when (<= i-priority parent-priority)
+	    (vector-swap! heap i parent))
+	  (fix-up! parent heap))))
+  (fix-up! (vector-length heap) (vector-append heap (vector (cons priority item)))))
+
+(define (heap-peek heap)
+  (if (vector-empty? heap) #f (vector-ref heap 0)))
+
+(define (heap-pop heap)
+  (define (fix-down! heap i)
+    (let* ([len (vector-length heap)]
+	   [left (* 2 i)]
+	   [right (1+ left)])
+      (if (< left len)
+	  (let ([min (if (< right len)
+			 (argmin (compose car (partial vector-ref heap)) i left right)
+			 (argmin (compose car (partial vector-ref heap)) i left))])
+	    (if (= min i)
+		heap
+		(begin
+		  (vector-swap! heap i min)
+		  (fix-down! heap i))))
+	  heap)))
+  (if (vector-empty? heap)
+      heap
+      (let ([new-heap (vector-copy heap 0 (1- (vector-length heap)))])
+	(vector-set! new-heap 0 (vector-ref heap (1- (vector-length heap))))
+	(fix-down! new-heap 0))))
+
 ;;;;;;;;;;;;
 ;; Output ;;
 ;;;;;;;;;;;;