module Queue (Queue(..), UpdateablePriorityQueue(..), 
	      UpdateableHeap, make_heap, Seq, empty) where

  import PropertyMap
  import SimpleQueue

  class Ord a =>
      Queue queue a | queue -> a where
    is_empty   :: queue -> Bool
    push    :: a -> queue -> queue
    pop     :: queue -> queue
    front   :: queue -> a

  class (Queue queue a, ReadPropertyMap pmap a prio) => 
      UpdateablePriorityQueue queue prio a pmap
      | queue -> prio, queue -> a where
    update  :: pmap -> a -> queue -> queue

  -- In the above, I had to add the functional dependencies
  -- queue -> prio, queue -> a 
  -- to get update to work. This strikes me as weird
  -- because the prio and a types are already dependent
  -- on the property map type.


  ------------------------------------------------------
  -- A Heap-based implementation of a Priority Queue
  ------------------------------------------------------

  data Heap prio a = EmHp
    | HeapNode (prio,a) (Heap prio a) (Heap prio a)

  data ReadPropertyMap pmap a prio =>
    UpdateableHeap prio a pmap = UpHeap (Heap prio a) pmap

  remove :: (Eq a, Ord b) => a -> Heap b a -> Heap b a
  remove x (HeapNode (p, y) h1 h2) =
    if x == y then (merge h1 h2)
    else (HeapNode (p, y) (remove x h1) (remove x h2))
  remove x EmHp = EmHp

  merge :: Ord a => Heap a b -> Heap a b -> Heap a b
  merge h1 EmHp = h1
  merge EmHp h2 = h2
  merge h1@(HeapNode (xp,x) l1 r1) h2@(HeapNode (yp,y) l2 r2) =
    if xp <= yp then (HeapNode (xp,x) l1 (merge r1 h2))
    else (HeapNode (yp,y) l2 (merge h1 r2))

  make_heap :: ReadPropertyMap pmap a prio => 
    pmap -> UpdateableHeap prio a pmap
  make_heap pmap = UpHeap EmHp pmap

  instance (Ord prio, Ord a, ReadPropertyMap pmap a prio) => 
      Queue (UpdateableHeap prio a pmap) a where
    is_empty (UpHeap EmHp pmap) = True
    is_empty (UpHeap _ pmap) = False

    push x (UpHeap h pmap) 
      = (UpHeap
          (merge (HeapNode ((get pmap x), x) EmHp EmHp)
                 h)
	  pmap)

    pop (UpHeap EmHp pmap) 
      = error "UpdateableHeap.pop: empty heap"
    pop (UpHeap (HeapNode pv h1 h2) pmap) 
      = (UpHeap (merge h1 h2) pmap)

    front (UpHeap EmHp pmap)
      = error "UpdateableHeap.front: empty heap"
    front (UpHeap (HeapNode (p,v) h1 h2) pmap) = v

  instance (Ord prio, Ord a, ReadPropertyMap pmap a prio) => 
      UpdateablePriorityQueue (UpdateableHeap prio a pmap) 
			      prio a pmap where
    update pmap x (UpHeap h old_pmap) 
	= push x (UpHeap (remove x h) pmap)


  ------------------------------------------------------
  -- FIFO Queue
  ------------------------------------------------------

  instance Ord a => Queue (Seq a) a where
    is_empty q = SimpleQueue.null q
    push a q = snoc q a
    pop q = ltail q
    front q = lhead q