{-# LANGUAGE Rank2Types, MultiParamTypeClasses, FlexibleInstances, GeneralizedNewtypeDeriving, TypeFamilies, UndecidableInstances #-}{- | Safe implementation of an array-backed binary heap. The 'HeapT' transformer requires that the underlying monad provide a 'MonadST' instance, meaning that the bottom-level monad must be 'ST'. This critical restriction protects referential transparency, disallowing multi-threaded behavior as if the '[]' monad were at the bottom level. (The 'HeapM' monad takes care of the 'ST' bottom level automatically.)
-}moduleControl.Monad.Queue.Heap(HeapM,HeapT,runHeapM,runHeapMOn,runHeapT,runHeapTOn)whereimportControl.Monad.Array.ArrayTimportControl.Monad.Array.ClassimportControl.Monad.STimportControl.Monad.ST.ClassimportControl.Monad.State.StrictimportControl.Monad.RWS.ClassimportControl.Monad.Queue.ClassimportControl.Monad-- | Monad based on an array implementation of a standard binary heap.typeHeapMse=HeapTe(STs)-- | Monad transformer based on an array implementation of a standard binary heap.newtypeHeapTema=HeapT{execHeapT::StateTInt(ArrayTem)a}deriving(Monad,MonadPlus,MonadFix,MonadReaderr,MonadWriterw)instanceMonadTrans(HeapTe)wherelift=HeapT.lift.liftinstanceMonadStatesm=>MonadStates(HeapTem)whereget=liftgetput=lift.put-- | Runs an 'HeapM' computation starting with an empty heap.runHeapM::Orde=>(foralls.HeapMsea)->arunHeapMm=runST$runHeapTmrunHeapMOn::Orde=>(foralls.HeapMsea)->Int->[e]->arunHeapMOnmnl=runST$runHeapTOnmnlrunHeapT::(MonadSTm,Monadm)=>HeapTema->marunHeapTm=runArrayT_16(evalStateT(execHeapTm)0)-- | Runs an 'HeapM' computation starting with a heap initialized to hold the specified list. (Since this can be done with linear preprocessing, this is more efficient than inserting the elements one by one.)runHeapTOn::(MonadSTm,Monadm,Orde)=>HeapTema-- ^ The transformer operation.->Int-- ^ The starting size of the heap (must be equal to the length of the list)->[e]-- ^ The initial contents of the heap->marunHeapTOnmnl=runArrayT_n$flipevalStateTn$domapM_(uncurryunsafeWriteAt)(zip[0..n-1]l)mapM_(\i->unsafeReadAti>>=heapDownni)[n-1,n-2..0]execHeapTminstance(MonadSTm,Monadm,Orde)=>MonadQueue(HeapTem)wheretypeQKey(HeapTem)=equeuePeek=HeapT$dosize<-getifsize>0thenliftMJust(unsafeReadAt0)elsereturnNothingqueueInsertx=HeapT$dosize<-getensureHeap(size+1)put(size+1)heapUpsizexqueueDelete=HeapT$dosize<-getput(size-1)unsafeReadAt(size-1)>>=heapDown(size-1)0>>unsafeWriteAt(size-1)undefinedqueueSize=HeapTgetensureHeap::MonadArraym=>Int->m()ensureHeapn=docap<-askSizewhen(n-1>=cap)(resize(2*n))heapUp::(MonadArraym,e~ArrayElemm,Orde)=>Int->e->m()heapUp=letheapUp'0x=unsafeWriteAt0xheapUp'ix=letj=(i-1)`quot`2indoaj<-unsafeReadAtjifx>=ajthenunsafeWriteAtixelseunsafeWriteAtiaj>>heapUp'jxinheapUp'heapDown::(MonadArraym,e~ArrayElemm,Orde)=>Int->Int->e->m()heapDownsize=heapDown'whereheapDown'ix=letlch=2*i+1;rch=lch+1incasecomparerchsizeofLT->doal<-unsafeReadAtlchar<-unsafeReadAtrchlet(ach,ch)=ifal<arthen(al,lch)else(ar,rch)ifach<xthenunsafeWriteAtiach>>heapDown'chxelseunsafeWriteAtixEQ->doal<-readAtlchifal<xthenunsafeWriteAtial>>unsafeWriteAtlchxelseunsafeWriteAtixGT->unsafeWriteAtix