;;; 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)