;;; heap.ss -- Jens Axel Søgaard -- 7th april 2003 (require (lib "plt-pretty-big-text.ss" "lang")) ; Signature for a totally ordered type (define-signature ordered^ (elm= elm< elm<=)) ; The integers with the natural total order as a signed unit (define integers@ (unit/sig ordered^ (import) (define elm= =) (define elm< <) (define elm<= <=))) ; Signature for a heap (define-signature heap^ (make-empty-heap empty? insert merge find-min ;delete-min )) ; The signed heap unit (define heap@ (unit/sig heap^ (import ordered^) ;;; IMPLEMENTATION ; A HEAP is either ; '() ; or ; (make-node rank left right) ; where rank is an integer and left, right are heaps. (define-struct node (rank elm left right)) (define empty? null?) (define (make-empty-heap) (list)) (define (merge h1 h2) (cond [(empty? h1) h2] [(empty? h2) h1] [else (let ([x (node-elm h1)] [y (node-elm h2)]) (if (elm<= x y) (make-heap x (node-left h1) (merge (node-right h1) h2)) (make-heap y (node-left h2) (merge h1 (node-right h2)))))])) (define (rank h) (if (empty? h) 0 (node-rank h))) (define (make-heap x a b) (let ([ra (rank a)] [rb (rank b)]) (if (>= ra rb) (make-node (add1 rb) x a b) (make-node (add1 ra) x b a)))) (define (insert x h) (merge (make-node 1 x (make-empty-heap) (make-empty-heap)) h)) (define (find-min h) (node-elm h)) (define (delete-min h) (merge (node-left h) (node-right h))) )) ; Heap of integers (define integer-heap@ (compound-unit/sig (import) (link (INTEGERS : ordered^ (integers@)) (INTEGER-HEAP : heap^ (heap@ INTEGERS))) (export (open INTEGER-HEAP)))) ; Export functions to the top level (namespace-variable-bind/invoke-unit/sig heap^ integer-heap@) ;;; TEST (define (list->heap l) (define (loop h l) (if (empty? l) h (loop (insert (first l) h) (rest l)))) (loop (make-empty-heap) l)) (define (heap->list h) (define (loop h l) (if (empty? h) l (loop (delete-min h) (cons (find-min h) l)))) (loop h '())) (define (heap-test) (define l1 (heap->list (list->heap (list 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)))) (define l2 (heap->list (list->heap (list 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)))) (and (equal? l1 l2) l1)) (heap-test)