vpq (empty) → 0.1.0.0
raw patch · 7 files changed
+221/−0 lines, 7 filesdep +basedep +primitivedep +smallcheck
Dependencies added: base, primitive, smallcheck, tasty, tasty-smallcheck, util, vector, vpq
Files
- Data/PriorityQueue.hs +90/−0
- LICENSE +30/−0
- README.md +1/−0
- Util/Vector.hs +13/−0
- Util/Vector/Mutable.hs +8/−0
- test/Main.hs +8/−0
- vpq.cabal +71/−0
+ Data/PriorityQueue.hs view
@@ -0,0 +1,90 @@+module Data.PriorityQueue (PQ, singleton, insert, minView, minViewWithKey, minAlterWithKeyF,+ toOrdList, foldMapWithKey,+ foldrWithKey, foldlWithKey, foldrWithKeyM, foldlWithKeyM) where++import Control.Applicative+import Control.Monad+import Control.Monad.Primitive+import Data.Bits+import Data.Bool+import Data.Filtrable+import Data.Function (on)+import Data.Functor.Classes+import Data.Tuple (swap)+import Data.Vector.Generic ((!?), Vector)+import qualified Data.Vector.Generic as V+import Data.Vector.Generic.Mutable (MVector)+import qualified Data.Vector.Generic.Mutable as MV+import Util.Vector as V+import Util.Vector.Mutable as MV+import Util++newtype PQ v k a = PQ (v (k, a))++foldMapWithKey :: (Ord k, Vector v (k, a)) => Monoid b => (k -> a -> b) -> PQ v k a -> b+foldMapWithKey f = foldrWithKey ((<>) ∘∘ f) mempty++foldrWithKey :: (Ord k, Vector v (k, a)) => (k -> a -> b -> b) -> b -> PQ v k a -> b+foldrWithKey f z = minViewWithKey & \ case Nothing -> z+ Just (k, a, pq) -> f k a $ foldrWithKey f z pq++foldlWithKey :: (Ord k, Vector v (k, a)) => (k -> b -> a -> b) -> b -> PQ v k a -> b+foldlWithKey f z xs = foldrWithKey (\ k a c x -> c (f k x a)) id xs z++foldrWithKeyM :: (Ord k, Vector v (k, a)) => Monad m => (k -> a -> b -> m b) -> b -> PQ v k a -> m b+foldrWithKeyM f z xs = foldlWithKey f' pure xs z where f' k c x z = f k x z >>= c++foldlWithKeyM :: (Ord k, Vector v (k, a)) => Monad m => (k -> b -> a -> m b) -> b -> PQ v k a -> m b+foldlWithKeyM f z xs = foldrWithKey f' pure xs z where f' k x c z = f k z x >>= c++toOrdList :: (Ord k, Vector v (k, a)) => PQ v k a -> [(k, a)]+toOrdList = foldrWithKey (curry (:)) []++singleton :: Vector v (k, a) => k -> a -> PQ v k a+singleton = curry $ PQ . V.singleton++insert :: (Ord k, Vector v (k, a)) => k -> a -> PQ v k a -> PQ v k a+insert k a (PQ xs) = PQ $ V.modify go xs+ where go xs = do+ let l = MV.length xs+ xs <- MV.unsafeGrow xs 1+ MV.unsafeWrite xs l (k, a)+ siftUpBy (compare `on` fst) xs l++minAlterWithKeyF :: (Ord k, Vector v (k, a), Functor f)+ => (Maybe (k, a) -> f (Maybe (k, a))) -> PQ v k a -> f (PQ v k a)+minAlterWithKeyF f (PQ xs) = PQ . bool (uncurry id . \ a -> V.modify' (go a) xs) (maybe xs V.singleton) (V.null xs) <$> f (xs !? 0)+ where go Nothing xs = do+ MV.unsafeSwap xs 0 (MV.length xs - 1)+ V.init <$ siftDownBy (compare `on` fst) (MV.init xs)+ go (Just (k, a)) xs = do+ MV.unsafeWrite xs 0 (k, a)+ id <$ siftDownBy (compare `on` fst) xs++minView :: (Ord k, Vector v (k, a)) => PQ v k a -> Maybe (a, PQ v k a)+minView = minViewWithKey & fmap (\ (_, a, pq) -> (a, pq))++minViewWithKey :: (Ord k, Vector v (k, a)) => PQ v k a -> Maybe (k, a, PQ v k a)+minViewWithKey = minAlterWithKeyF (join (,)) & swap & sequenceA & fmap (\ (pq, (k, a)) -> (k, a, pq))++siftUpBy :: (MVector v a, PrimMonad m) => (a -> a -> Ordering) -> v (PrimState m) a -> Int -> m ()+siftUpBy cmp xs = go+ where go 0 = pure ()+ go n = do+ let m = n `shiftR` 1+ i <- MV.unsafeRead xs m+ j <- MV.unsafeRead xs n+ when (GT == cmp i j) $ MV.unsafeSwap xs m n >> go m++siftDownBy :: (MVector v a, PrimMonad m) => (a -> a -> Ordering) -> v (PrimState m) a -> m ()+siftDownBy cmp xs = go 0+ where go m = (liftA2 (minBy cmp') `on` \ n ->+ fmap ((,) n) <$> MV.readMaybe xs n) (m + m) (m + m + 1) >>= \ case+ Nothing -> pure ()+ Just (n, j) -> do+ i <- MV.unsafeRead xs m+ when (GT == cmp i j) $ MV.unsafeSwap xs m n >> go n+ cmp' = flip $ liftCompare (flip cmp `on` snd)++minBy :: (a -> a -> Ordering) -> a -> a -> a+minBy cmp x y | GT <- cmp x y = y | otherwise = x
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright M Farkas-Dyck © 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of M Farkas-Dyck nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"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 COPYRIGHT+OWNER 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.
+ README.md view
@@ -0,0 +1,1 @@+# vpq
+ Util/Vector.hs view
@@ -0,0 +1,13 @@+module Util.Vector where++import Control.Monad+import Control.Monad.ST+import Data.STRef+import Data.Vector.Generic+import Unsafe.Coerce++modify' :: Vector v a => (∀ s . Mutable v s a -> ST s b) -> v a -> (b, v a)+modify' f xs = runST $ do+ ref <- newSTRef undefined+ let ys = modify (f >=> writeSTRef ((unsafeCoerce :: STRef s a -> STRef t a) ref)) xs+ flip (,) ys <$> seq ys (readSTRef ref)
+ Util/Vector/Mutable.hs view
@@ -0,0 +1,8 @@+module Util.Vector.Mutable where++import Control.Monad (guard)+import Control.Monad.Primitive+import Data.Vector.Generic.Mutable as MV++readMaybe :: (PrimMonad m, MVector v a) => v (PrimState m) a -> Int -> m (Maybe a)+readMaybe xs k = (<$ guard (k < MV.length xs)) <$> unsafeRead xs k
+ test/Main.hs view
@@ -0,0 +1,8 @@+module Main where++import Test.SmallCheck+import Test.Tasty+import Test.Tasty.SmallCheck++main :: IO ()+main = pure ()
+ vpq.cabal view
@@ -0,0 +1,71 @@+name: vpq+version: 0.1.0.0+synopsis: Priority queue based on vector+-- description:+license: BSD3+license-file: LICENSE+author: M Farkas-Dyck+maintainer: strake888@gmail.com+copyright: 2018 M Farkas-Dyck+category: Data+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ hs-source-dirs: .+ exposed-modules: Data.PriorityQueue+ other-modules: Util.Vector+ , Util.Vector.Mutable+ build-depends: base >= 4.7 && < 5+ , primitive >=0.5 && <0.7+ , util >=0.1.7 && <0.8+ , vector >=0.12 && <0.13+ default-language: Haskell2010+ default-extensions: UnicodeSyntax+ , LambdaCase+ , InstanceSigs+ , PartialTypeSignatures+ , RankNTypes+ , PolyKinds+ , ConstraintKinds+ , FlexibleContexts+ , FlexibleInstances+ , StandaloneDeriving+ , DeriveFunctor+ , DeriveFoldable+ , DeriveTraversable+ , OverloadedStrings+ ghc-options: -Wall -Wcompat -Wredundant-constraints -Wno-name-shadowing+ -Wincomplete-record-updates -Wincomplete-uni-patterns++test-suite test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ build-depends: base >=4.11 && <5+ , smallcheck >=1.1.3+ , tasty >=1.0+ , tasty-smallcheck >=0.8+ , vpq+ default-language: Haskell2010+ default-extensions: UnicodeSyntax+ , LambdaCase+ , InstanceSigs+ , PartialTypeSignatures+ , PolyKinds+ , ConstraintKinds+ , FlexibleContexts+ , FlexibleInstances+ , StandaloneDeriving+ , DeriveFunctor+ , DeriveFoldable+ , DeriveTraversable+ , OverloadedStrings+ ghc-options: -Wall -Wcompat -Wredundant-constraints -Wno-name-shadowing+ -Wincomplete-record-updates -Wincomplete-uni-patterns+ -O2++source-repository head+ type: git+ location: https://github.com/strake/vpq