diff --git a/graphgif.scm b/graphgif.scm index da2fbca..fe5fbca 100644 --- a/graphgif.scm +++ b/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 ;; ;;;;;;;;;;;;