priority-queue (empty) → 0.1
raw patch · 4 files changed
+200/−0 lines, 4 filesdep +basedep +containersdep +queuesetup-changed
Dependencies added: base, containers, queue, reord, stateref
Files
- LICENSE +28/−0
- Setup.lhs +5/−0
- priority-queue.cabal +33/−0
- src/Data/PriorityQueue.hs +134/−0
+ LICENSE view
@@ -0,0 +1,28 @@+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,5 @@+#!/usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain+
+ priority-queue.cabal view
@@ -0,0 +1,33 @@+name: priority-queue+version: 0.1+stability: provisional+license: BSD3+license-file: LICENSE++cabal-version: >= 1.2+build-type: Simple++author: James Cook <mokus@deepbondi.net>+maintainer: James Cook <mokus@deepbondi.net>+homepage: http://darcs.deepbondi.net/priority-queue++category: Data+synopsis: Simple implementation of a priority queue.+description: Simple implementation of a priority queue.++flag splitBase++Library+ hs-source-dirs: src+ exposed-modules: Data.PriorityQueue+ + extensions: CPP+ + if flag(splitBase)+ build-depends: base >= 3, containers+ else+ build-depends: base < 3+ cpp-options: -DNoMinViewWithKey+ + build-depends: reord >= 0.0.0.2, stateref >= 0.2.1.0, + queue >= 0.1.1.1
+ src/Data/PriorityQueue.hs view
@@ -0,0 +1,134 @@+{-+ - ``Data/PriorityQueue''+ - (c) 2008 Cook, J. MR SSD, Inc.+ - + - the PriorityQueue kicks ass, if I do say so myself ;-)+ - the |DefaultStateRef| class makes the choice of StateRef+ - decidable, and the laxity of the StateRef classes' fundeps makes+ - queues constructible in monads other than where they are intended+ - to be used; eg:+ - + - q <- newPriorityQueue show :: IO (PriorityQueue STM Integer)+ - + - after which the whole interface to the queue is:+ - enqueue (x :: Integer) q :: STM ()+ - dequeue q :: STM Integer+ - + - If the queue is being constructed in the same scope it is used,+ - the full type of |newPriorityQueue f| can be inferred as well,+ - as long as |f|'s target type is monomorphic.+ - + -}+{-# LANGUAGE+ ExistentialQuantification,+ MultiParamTypeClasses,+ FlexibleContexts,+ FlexibleInstances,+ CPP+ #-}++module Data.PriorityQueue+ ( Enqueue(..)+ , Dequeue(..)+ , DequeueWhere(..)+ , PeekQueue(..)+ , QueueSize(..)+ + , PriorityQueue+ , newPriorityQueue+ , newPriorityQueueBy+ + ) where++import Data.Queue.Classes++import Data.StateRef+import Data.Ord.ReOrd+import qualified Data.Map as M+import Data.List++-- |The "pure" type at the chewy center.+data PQ a = forall p. Ord p =>+ PQ { priorityFunc :: a -> p+ , queue :: M.Map p [a]+ }++data PriorityQueue m a = + forall sr. ( DefaultStateRef sr m (PQ a)+ , ModifyRef sr m (PQ a) + ) => PriorityQueue sr++-- |Construct a new priority queue using the specified indexing function+newPriorityQueue :: + ( DefaultStateRef sr m1 (PQ a)+ , ModifyRef sr m1 (PQ a)+ , NewRef sr m (PQ a)+ , Ord p+ ) => (a -> p) -> m (PriorityQueue m1 a)+newPriorityQueue f = do+ pq <- newRef (PQ f M.empty)+ return (PriorityQueue pq)++-- |Construct a new priority queue using a comparator function. It is +-- the user's respensibility to ensure that this function provides a+-- sensible order.+newPriorityQueueBy :: + ( DefaultStateRef sr m1 (PQ a)+ , ModifyRef sr m1 (PQ a)+ , NewRef sr m (PQ a)+ ) => (a -> a -> Ordering) -> m (PriorityQueue m1 a)+newPriorityQueueBy cmp = newPriorityQueue (ReOrd cmp)++instance Monad m => Enqueue (PriorityQueue m a) m a where+ enqueue (PriorityQueue pqRef) x = modifyRef pqRef ins+ where ins (PQ f pq) = PQ f (M.insertWith (flip (++)) (f x) [x] pq)++instance Monad m => Dequeue (PriorityQueue m a) m a where+ dequeue q@(PriorityQueue pqRef) = atomicModifyRef pqRef dq+ where+ dq orig@(PQ f pq) = case minViewWithKey pq of+ Nothing -> (orig, Nothing)+ Just ((k,[]), pq') -> + -- this should never happen+ dq (PQ f pq')+ Just ((k,[i]), pq') -> (PQ f pq', Just i)+ Just ((k,i:is), pq') -> (PQ f (M.insert k is pq'), Just i)++-- quick hack; there's probably a more efficient (and/or less ugly) way to do this+instance Monad m => DequeueWhere (PriorityQueue m a) m a where+ dequeueWhere (PriorityQueue pqRef) p = atomicModifyRef pqRef dq+ where+ extractFirstWhere :: (a -> Bool) -> [a] -> (a, [a])+ extractFirstWhere p (x:xs)+ | p x = (x, xs)+ | otherwise = case extractFirstWhere p xs of+ (y, rest) -> (y, x:rest)+ + dq orig@(PQ f pq) = case partition (any p.snd) (M.toAscList pq) of+ ([], _) -> + (orig, Nothing)+ ((k, firstMatch): otherMatches, rest) -> case extractFirstWhere p firstMatch of+ (thing, otherThings) ->+ (PQ f (M.fromList ((k, otherThings) : otherMatches ++ rest)), Just thing)++instance Monad m => PeekQueue (PriorityQueue m a) m a where+ peekQueue (PriorityQueue pqRef) = do+ PQ f pq <- readRef pqRef+ return [v | (k, vs) <- M.toAscList pq, v <- vs]++instance Monad m => QueueSize (PriorityQueue m a) m where+ queueSize (PriorityQueue pqRef) = do+ PQ f pq <- readRef pqRef+ return (M.size pq)++-- |local version of minViewWithKey, because some versions of Data.Map+-- don't have it.+minViewWithKey :: (Monad m) => M.Map k a -> m ((k, a), M.Map k a)++#ifdef NoMinViewWithKey+minViewWithKey m = if M.null m+ then fail "empty map"+ else return (M.deleteFindMin m)+#else+minViewWithKey = M.minViewWithKey+#endif