diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,5 @@ +#!/usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain + diff --git a/priority-queue.cabal b/priority-queue.cabal new file mode 100644 --- /dev/null +++ b/priority-queue.cabal @@ -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 +maintainer: James Cook +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 diff --git a/src/Data/PriorityQueue.hs b/src/Data/PriorityQueue.hs new file mode 100644 --- /dev/null +++ b/src/Data/PriorityQueue.hs @@ -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