psqueues-0.2.2.2/0000755000000000000000000000000012745134107011717 5ustar0000000000000000psqueues-0.2.2.2/psqueues.cabal0000644000000000000000000001046212745134107014560 0ustar0000000000000000Name: psqueues Version: 0.2.2.2 License: BSD3 License-file: LICENSE Maintainer: Jasper Van der Jeugt Bug-reports: https://github.com/bttr/psqueues/issues Synopsis: Pure priority search queues Category: Data Structures Build-type: Simple Cabal-version: >=1.8 Description: The psqueues package provides in three different flavors. . * @OrdPSQ k p v@, which uses the @Ord k@ instance to provide fast insertion, deletion and lookup. This implementation is based on Ralf Hinze's . Hence, it is similar to the library, although it is considerably faster and provides a slightly different API. . * @IntPSQ p v@ is a far more efficient implementation. It fixes the key type to @Int@ and uses a (like @IntMap@) with an additional min-heap property. . * @HashPSQ k p v@ is a fairly straightforward extension of @IntPSQ@: it simply uses the keys' hashes as indices in the @IntPSQ@. If there are any hash collisions, it uses an @OrdPSQ@ to resolve those. The performance of this implementation is comparable to that of @IntPSQ@, but it is more widely applicable since the keys are not restricted to @Int@, but rather to any @Hashable@ datatype. . Each of the three implementations provides the same API, so they can be used interchangeably. The benchmarks show how they perform relative to one another, and also compared to the other Priority Search Queue implementations on Hackage: and . . <> . <> . Typical applications of Priority Search Queues include: . * Caches, and more specifically LRU Caches; . * Schedulers; . * Pathfinding algorithms, such as Dijkstra's and A*. Extra-source-files: CHANGELOG Source-repository head type: git location: http://github.com/bttr/psqueues.git Library Ghc-options: -O2 -Wall Hs-source-dirs: src Build-depends: base >= 4.2 && < 5 , deepseq >= 1.2 && < 1.5 , hashable >= 1.2.1 && < 1.3 if impl(ghc>=6.10) Build-depends: ghc-prim Exposed-modules: Data.HashPSQ Data.IntPSQ Data.OrdPSQ Other-modules: Data.BitUtil Data.HashPSQ.Internal Data.IntPSQ.Internal Data.OrdPSQ.Internal Benchmark psqueues-benchmarks Type: exitcode-stdio-1.0 Hs-source-dirs: src benchmarks Main-is: Main.hs Other-modules: BenchmarkTypes Data.FingerTree.PSQueue.Benchmark Data.HashPSQ.Benchmark Data.IntPSQ.Benchmark Data.OrdPSQ.Benchmark Data.PSQueue.Benchmark Ghc-options: -Wall Build-depends: containers >= 0.5 , unordered-containers >= 0.2.4 , criterion >= 0.8 , mtl >= 2.1 , fingertree-psqueue >= 0.3 , PSQueue >= 1.1 , random >= 1.0 , base , deepseq , ghc-prim , hashable , psqueues Test-suite psqueues-tests Cpp-options: -DTESTING -DSTRICT Ghc-options: -Wall Hs-source-dirs: src tests Main-is: Main.hs Type: exitcode-stdio-1.0 Other-modules: Data.PSQ.Class Data.PSQ.Class.Gen Data.PSQ.Class.Tests Data.PSQ.Class.Util Data.HashPSQ.Tests Data.IntPSQ.Tests Data.OrdPSQ.Tests Build-depends: HUnit >= 1.2 && < 1.4 , QuickCheck >= 2.7 && < 2.10 , test-framework >= 0.8 && < 0.9 , test-framework-hunit >= 0.3 && < 0.4 , test-framework-quickcheck2 >= 0.3 && < 0.4 , base , array , deepseq , ghc-prim , hashable , psqueues , tagged psqueues-0.2.2.2/Setup.hs0000644000000000000000000000012712745134107013353 0ustar0000000000000000module Main (main) where import Distribution.Simple main :: IO () main = defaultMain psqueues-0.2.2.2/CHANGELOG0000644000000000000000000000117212745134107013132 0ustar0000000000000000- 0.2.2.2 * Bump QuickCheck dependency bounds - 0.2.2.1 * Fix benchmark compilation with stack - 0.2.2.0 * Fix import of Traversable on GHC 7.8 - 0.2.1.0 * Add Traversable instances - 0.2.0.3 * Bump HUnit dependency bounds - 0.2.0.2 * Bump QuickCheck dependency bounds - 0.2.0.1 * Minor documentation fixes - 0.2.0.0 * Add convenience `deleteMin` function * Bump `deepseq` dependency to 1.4 - 0.1.1.0 * Remove constraints from `size` - 0.1.0.1 * Extend cabal description, include CHANGELOG - 0.1.0.0 * First release: psqueues-0.2.2.2/LICENSE0000644000000000000000000000310712745134107012725 0ustar0000000000000000The Glasgow Haskell Compiler License Copyright 2004, The University Court of the University of Glasgow. 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 name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE 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 UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE 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. psqueues-0.2.2.2/benchmarks/0000755000000000000000000000000012745134107014034 5ustar0000000000000000psqueues-0.2.2.2/benchmarks/BenchmarkTypes.hs0000644000000000000000000000165412745134107017315 0ustar0000000000000000 module BenchmarkTypes where import Criterion type BElem = (Int, Int, ()) data BenchmarkSet = BenchmarkSet { bGroupName :: String , bMinView :: Benchmarkable , bLookup :: Benchmarkable , bInsertEmpty :: Benchmarkable , bInsertNew :: Benchmarkable , bInsertDuplicates :: Benchmarkable , bDelete :: Benchmarkable } runBenchmark :: [BenchmarkSet] -> [Benchmark] runBenchmark bset = [ bgroup "minView" $ map (bench' bMinView) bset , bgroup "lookup" $ map (bench' bLookup) bset , bgroup "insertEmpty" $ map (bench' bInsertEmpty) bset , bgroup "insertNew" $ map (bench' bInsertNew) bset , bgroup "insertDuplicates" $ map (bench' bInsertDuplicates) bset , bgroup "delete" $ map (bench' bDelete) bset ] where bench' f x = bench (bGroupName x) (f x) psqueues-0.2.2.2/benchmarks/Main.hs0000644000000000000000000000373512745134107015264 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module Main where import Criterion.Main import System.Random import BenchmarkTypes import qualified Data.OrdPSQ.Benchmark as OrdPSQ import qualified Data.IntPSQ.Benchmark as IntPSQ import qualified Data.HashPSQ.Benchmark as HashPSQ import qualified Data.PSQueue.Benchmark as PSQueue import qualified Data.FingerTree.PSQueue.Benchmark as FingerPSQ benchmarkSize :: Int benchmarkSize = 2 ^ (12 :: Int) {-# NOINLINE increasing #-} increasing :: [BElem] increasing = [(n, n, ()) | n <- [1 .. benchmarkSize]] {-# NOINLINE decreasing #-} decreasing :: [BElem] decreasing = reverse increasing {-# NOINLINE semirandom #-} semirandom :: [BElem] semirandom = [ (x, y, ()) | (_, x, y) <- zip3 [1 .. benchmarkSize] (randoms gen1) (randoms gen2) ] where gen1 = mkStdGen 1234 gen2 = mkStdGen 5678 main :: IO () main = defaultMain $ runBenchmark [ IntPSQ.benchmark "IntPSQ increasing" increasing , IntPSQ.benchmark "IntPSQ decreasing" decreasing , IntPSQ.benchmark "IntPSQ semirandom" semirandom , HashPSQ.benchmark "HashPSQ increasing" increasing , HashPSQ.benchmark "HashPSQ decreasing" decreasing , HashPSQ.benchmark "HashPSQ semirandom" semirandom , OrdPSQ.benchmark "OrdPSQ increasing" increasing , OrdPSQ.benchmark "OrdPSQ decreasing" decreasing , OrdPSQ.benchmark "OrdPSQ semirandom" semirandom , PSQueue.benchmark "PSQueue increasing" increasing , PSQueue.benchmark "PSQueue decreasing" decreasing , PSQueue.benchmark "PSQueue semirandom" semirandom , FingerPSQ.benchmark "FingerTree PSQueue increasing" increasing , FingerPSQ.benchmark "FingerTree PSQueue decreasing" decreasing , FingerPSQ.benchmark "FingerTree PSQueue semirandom" semirandom ] psqueues-0.2.2.2/benchmarks/Data/0000755000000000000000000000000012745134107014705 5ustar0000000000000000psqueues-0.2.2.2/benchmarks/Data/PSQueue/0000755000000000000000000000000012745134107016234 5ustar0000000000000000psqueues-0.2.2.2/benchmarks/Data/PSQueue/Benchmark.hs0000644000000000000000000000440712745134107020467 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} -- | This module provides benchmarks for the 'PSQueue' type from the PSQueue -- package. module Data.PSQueue.Benchmark ( benchmark ) where import Data.List (foldl') import qualified Data.PSQueue as PSQueue import Criterion.Main import Prelude hiding (lookup) import BenchmarkTypes import Data.Maybe (fromMaybe) benchmark :: String -> [BElem] -> BenchmarkSet benchmark name elems = BenchmarkSet { bGroupName = name , bMinView = whnf bench_minView initialPSQ , bLookup = whnf (bench_lookup keys) initialPSQ , bInsertEmpty = nf' (bench_insert firstElems) PSQueue.empty , bInsertNew = nf' (bench_insert secondElems) initialPSQ , bInsertDuplicates = nf' (bench_insert firstElems) initialPSQ , bDelete = nf' (bench_delete firstKeys) initialPSQ } where (firstElems, secondElems) = splitAt (numElems `div` 2) elems numElems = length elems keys = map (\(x, _, _) -> x) elems firstKeys = map (\(x, _, _) -> x) firstElems initialPSQ = PSQueue.fromList $ map toBinding firstElems :: PSQueue.PSQ Int Int toBinding :: BElem -> PSQueue.Binding Int Int toBinding (k, p, _) = k PSQueue.:-> p -- Get the size of the resulting PSQ, since there's no NFData instance. nf' f x = whnf (PSQueue.size . f) x -- Get the sum of all priorities by getting all elements using 'lookup' bench_lookup :: [Int] -> PSQueue.PSQ Int Int -> Int bench_lookup xs m = foldl' (\n k -> fromMaybe n (PSQueue.lookup k m)) 0 xs -- Insert a list of elements one-by-one into a PSQ bench_insert :: [BElem] -> PSQueue.PSQ Int Int -> PSQueue.PSQ Int Int bench_insert xs m0 = foldl' (\m (k, p, _) -> PSQueue.insert k p m) m0 xs -- Get the sum of all priorities by sequentially popping all elements using -- 'minView' bench_minView :: PSQueue.PSQ Int Int -> Int bench_minView = go 0 where go !n t = case PSQueue.minView t of Nothing -> n Just ((k PSQueue.:-> x), t') -> go (n + k + x) t' -- Empty a queue by sequentially removing all elements bench_delete :: [Int] -> PSQueue.PSQ Int Int -> PSQueue.PSQ Int Int bench_delete keys t0 = foldl' (\t k -> PSQueue.delete k t) t0 keys psqueues-0.2.2.2/benchmarks/Data/HashPSQ/0000755000000000000000000000000012745134107016154 5ustar0000000000000000psqueues-0.2.2.2/benchmarks/Data/HashPSQ/Benchmark.hs0000644000000000000000000000372112745134107020405 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module Data.HashPSQ.Benchmark ( benchmark ) where import Data.List (foldl') import qualified Data.HashPSQ as HashPSQ import Criterion.Main import Prelude hiding (lookup) import BenchmarkTypes benchmark :: String -> [BElem] -> BenchmarkSet benchmark name elems = BenchmarkSet { bGroupName = name , bMinView = whnf bench_minView initialPSQ , bLookup = whnf (bench_lookup keys) initialPSQ , bInsertEmpty = nf (bench_insert firstElems) HashPSQ.empty , bInsertNew = nf (bench_insert secondElems) initialPSQ , bInsertDuplicates = nf (bench_insert firstElems) initialPSQ , bDelete = nf (bench_delete firstKeys) initialPSQ } where (firstElems, secondElems) = splitAt (numElems `div` 2) elems numElems = length elems keys = map (\(x, _, _) -> x) elems firstKeys = map (\(x, _, _) -> x) firstElems initialPSQ = HashPSQ.fromList firstElems :: HashPSQ.HashPSQ Int Int () -- Get the sum of all priorities by getting all elements using 'lookup' bench_lookup :: [Int] -> HashPSQ.HashPSQ Int Int () -> Int bench_lookup xs m = foldl' (\n k -> maybe n fst (HashPSQ.lookup k m)) 0 xs -- Insert a list of elements one-by-one into a PSQ bench_insert :: [BElem] -> HashPSQ.HashPSQ Int Int () -> HashPSQ.HashPSQ Int Int () bench_insert xs m0 = foldl' (\m (k, p, v) -> HashPSQ.insert k p v m) m0 xs -- Get the sum of all priorities by sequentially popping all elements using -- 'minView' bench_minView :: HashPSQ.HashPSQ Int Int () -> Int bench_minView = go 0 where go !n t = case HashPSQ.minView t of Nothing -> n Just (k, x, _, t') -> go (n + k + x) t' -- Empty a queue by sequentially removing all elements bench_delete :: [Int] -> HashPSQ.HashPSQ Int Int () -> HashPSQ.HashPSQ Int Int () bench_delete keys t0 = foldl' (\t k -> HashPSQ.delete k t) t0 keys psqueues-0.2.2.2/benchmarks/Data/IntPSQ/0000755000000000000000000000000012745134107016023 5ustar0000000000000000psqueues-0.2.2.2/benchmarks/Data/IntPSQ/Benchmark.hs0000644000000000000000000000363712745134107020262 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module Data.IntPSQ.Benchmark ( benchmark ) where import Data.List (foldl') import qualified Data.IntPSQ as IntPSQ import Criterion.Main import Prelude hiding (lookup) import BenchmarkTypes benchmark :: String -> [BElem] -> BenchmarkSet benchmark name elems = BenchmarkSet { bGroupName = name , bMinView = whnf bench_minView initialPSQ , bLookup = whnf (bench_lookup keys) initialPSQ , bInsertEmpty = nf (bench_insert firstElems) IntPSQ.empty , bInsertNew = nf (bench_insert secondElems) initialPSQ , bInsertDuplicates = nf (bench_insert firstElems) initialPSQ , bDelete = nf (bench_delete firstKeys) initialPSQ } where (firstElems, secondElems) = splitAt (numElems `div` 2) elems numElems = length elems keys = map (\(x, _, _) -> x) elems firstKeys = map (\(x, _, _) -> x) firstElems initialPSQ = IntPSQ.fromList firstElems :: IntPSQ.IntPSQ Int () -- Get the sum of all priorities by getting all elements using 'lookup' bench_lookup :: [Int] -> IntPSQ.IntPSQ Int () -> Int bench_lookup xs m = foldl' (\n k -> maybe n fst (IntPSQ.lookup k m)) 0 xs -- Insert a list of elements one-by-one into a PSQ bench_insert :: [(Int, Int, ())] -> IntPSQ.IntPSQ Int () -> IntPSQ.IntPSQ Int () bench_insert xs m0 = foldl' (\m (k, p, v) -> IntPSQ.insert k p v m) m0 xs -- Get the sum of all priorities by sequentially popping all elements using -- 'minView' bench_minView :: IntPSQ.IntPSQ Int () -> Int bench_minView = go 0 where go !n t = case IntPSQ.minView t of Nothing -> n Just (k, p, _, t') -> go (n + k + p) t' -- Empty a queue by sequentially removing all elements bench_delete :: [Int] -> IntPSQ.IntPSQ Int () -> IntPSQ.IntPSQ Int () bench_delete keys t0 = foldl' (\t k -> IntPSQ.delete k t) t0 keys psqueues-0.2.2.2/benchmarks/Data/FingerTree/0000755000000000000000000000000012745134107016737 5ustar0000000000000000psqueues-0.2.2.2/benchmarks/Data/FingerTree/PSQueue/0000755000000000000000000000000012745134107020266 5ustar0000000000000000psqueues-0.2.2.2/benchmarks/Data/FingerTree/PSQueue/Benchmark.hs0000644000000000000000000000443512745134107022522 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} -- | This module contains benchmarks for the 'PSQueue' type from the -- `fingertree-psqueue` package. module Data.FingerTree.PSQueue.Benchmark ( benchmark ) where import Data.List (foldl') import Data.FingerTree.PSQueue (Binding (..)) import qualified Data.FingerTree.PSQueue as PSQueue import Criterion.Main import Prelude hiding (lookup) import BenchmarkTypes import Data.Maybe (fromMaybe) benchmark :: String -> [BElem] -> BenchmarkSet benchmark name elems = BenchmarkSet { bGroupName = name , bMinView = whnf bench_minView initialPSQ , bLookup = whnf (bench_lookup keys) initialPSQ , bInsertEmpty = nf' (bench_insert firstElems) PSQueue.empty , bInsertNew = nf' (bench_insert secondElems) initialPSQ , bInsertDuplicates = nf' (bench_insert firstElems) initialPSQ , bDelete = nf' (bench_delete firstKeys) initialPSQ } where (firstElems, secondElems) = splitAt (numElems `div` 2) elems numElems = length elems keys = map (\(x, _, _) -> x) elems firstKeys = map (\(x, _, _) -> x) firstElems initialPSQ :: PSQueue.PSQ Int Int initialPSQ = PSQueue.fromList $ map toBinding firstElems toBinding :: BElem -> Binding Int Int toBinding (k, p, _) = k :-> p -- Get the size of the resulting PSQs, since there's no NFData instance nf' f x = whnf (PSQueue.size . f) x bench_lookup :: [Int] -> PSQueue.PSQ Int Int -> Int bench_lookup xs m = foldl' (\n k -> fromMaybe n (PSQueue.lookup k m)) 0 xs bench_insert :: [BElem] -> PSQueue.PSQ Int Int -> PSQueue.PSQ Int Int bench_insert xs m0 = foldl' (\m (k, p, _) -> fingerInsert k p m) m0 xs where fingerInsert :: (Ord k, Ord v) => k -> v -> PSQueue.PSQ k v -> PSQueue.PSQ k v fingerInsert k v m = PSQueue.alter (const $ Just v) k m bench_minView :: PSQueue.PSQ Int Int -> Int bench_minView = go 0 where go !n t = case PSQueue.minView t of Nothing -> n Just ((k :-> x), t') -> go (n + k + x) t' -- Empty a queue by sequentially removing all elements bench_delete :: [Int] -> PSQueue.PSQ Int Int -> PSQueue.PSQ Int Int bench_delete keys t0 = foldl' (\t k -> PSQueue.delete k t) t0 keys psqueues-0.2.2.2/benchmarks/Data/OrdPSQ/0000755000000000000000000000000012745134107016015 5ustar0000000000000000psqueues-0.2.2.2/benchmarks/Data/OrdPSQ/Benchmark.hs0000644000000000000000000000365612745134107020255 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module Data.OrdPSQ.Benchmark ( benchmark ) where import Data.List (foldl') import qualified Data.OrdPSQ as OrdPSQ import Criterion.Main import Prelude hiding (lookup) import BenchmarkTypes benchmark :: String -> [BElem] -> BenchmarkSet benchmark name elems = BenchmarkSet { bGroupName = name , bMinView = whnf bench_minView initialPSQ , bLookup = whnf (bench_lookup keys) initialPSQ , bInsertEmpty = nf (bench_insert firstElems) OrdPSQ.empty , bInsertNew = nf (bench_insert secondElems) initialPSQ , bInsertDuplicates = nf (bench_insert firstElems) initialPSQ , bDelete = nf (bench_delete firstKeys) initialPSQ } where (firstElems, secondElems) = splitAt (numElems `div` 2) elems numElems = length elems keys = map (\(x, _, _) -> x) elems firstKeys = map (\(x, _, _) -> x) firstElems initialPSQ = OrdPSQ.fromList firstElems :: OrdPSQ.OrdPSQ Int Int () -- Get the sum of all priorities by getting all elements using 'lookup' bench_lookup :: [Int] -> OrdPSQ.OrdPSQ Int Int () -> Int bench_lookup xs m = foldl' (\n k -> maybe n fst (OrdPSQ.lookup k m)) 0 xs -- Insert a list of elements one-by-one into a PSQ bench_insert :: [BElem] -> OrdPSQ.OrdPSQ Int Int () -> OrdPSQ.OrdPSQ Int Int () bench_insert xs m0 = foldl' (\m (k, p, v) -> OrdPSQ.insert k p v m) m0 xs -- Get the sum of all priorities by sequentially popping all elements using -- 'minView' bench_minView :: OrdPSQ.OrdPSQ Int Int () -> Int bench_minView = go 0 where go !n t = case OrdPSQ.minView t of Nothing -> n Just (k, x, _, t') -> go (n + k + x) t' -- Empty a queue by sequentially removing all elements bench_delete :: [Int] -> OrdPSQ.OrdPSQ Int Int () -> OrdPSQ.OrdPSQ Int Int () bench_delete keys t0 = foldl' (\t k -> OrdPSQ.delete k t) t0 keys psqueues-0.2.2.2/tests/0000755000000000000000000000000012745134107013061 5ustar0000000000000000psqueues-0.2.2.2/tests/Main.hs0000644000000000000000000000215412745134107014303 0ustar0000000000000000import Data.Tagged (Tagged (..), untag) import Test.Framework (Test, defaultMain, testGroup) import qualified Data.HashPSQ as HashPSQ import qualified Data.HashPSQ.Tests import qualified Data.IntPSQ as IntPSQ import qualified Data.IntPSQ.Tests import qualified Data.OrdPSQ as OrdPSQ import qualified Data.OrdPSQ.Tests import qualified Data.PSQ.Class.Tests import Data.PSQ.Class.Util main :: IO () main = defaultMain [ testGroup "Data.IntPSQ.Tests" Data.IntPSQ.Tests.tests , testGroup "Data.HashPSQ.Tests" Data.HashPSQ.Tests.tests , testGroup "Data.OrdPSQ.Tests" Data.OrdPSQ.Tests.tests , testGroup "Data.PSQ.Class.Tests IntPSQ" $ untag (Data.PSQ.Class.Tests.tests :: Tagged IntPSQ.IntPSQ [Test]) , testGroup "Data.PSQ.Class.Tests PSQ" $ untag (Data.PSQ.Class.Tests.tests :: Tagged (OrdPSQ.OrdPSQ Int) [Test]) , testGroup "Data.PSQ.Class.Tests HashPSQ" $ untag (Data.PSQ.Class.Tests.tests :: Tagged (HashPSQ.HashPSQ LousyHashedInt) [Test]) ] psqueues-0.2.2.2/tests/Data/0000755000000000000000000000000012745134107013732 5ustar0000000000000000psqueues-0.2.2.2/tests/Data/PSQ/0000755000000000000000000000000012745134107014375 5ustar0000000000000000psqueues-0.2.2.2/tests/Data/PSQ/Class.hs0000644000000000000000000001046012745134107015777 0ustar0000000000000000-- | Generic class with properties and methods that are available for all -- different implementations ('IntPSQ', 'OrdPSQ' and 'HashPSQ'). {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} module Data.PSQ.Class ( PSQ (..) ) where import Data.Hashable (Hashable) import qualified Data.IntPSQ as IntPSQ import qualified Data.HashPSQ as HashPSQ import qualified Data.OrdPSQ as OrdPSQ class PSQ (psq :: * -> * -> *) where type Key psq :: * -- Query null :: Ord p => psq p v -> Bool size :: Ord p => psq p v -> Int member :: Ord p => Key psq -> psq p v -> Bool lookup :: Ord p => Key psq -> psq p v -> Maybe (p, v) findMin :: Ord p => psq p v -> Maybe (Key psq, p, v) -- Construction empty :: Ord p => psq p v singleton :: Ord p => Key psq -> p -> v -> psq p v -- Insertion insert :: Ord p => Key psq -> p -> v -> psq p v -> psq p v -- Delete/update delete :: Ord p => Key psq -> psq p v -> psq p v deleteMin :: Ord p => psq p v -> psq p v alter :: Ord p => (Maybe (p, v) -> (b, Maybe (p, v))) -> Key psq -> psq p v -> (b, psq p v) alterMin :: Ord p => (Maybe (Key psq, p, v) -> (b, Maybe (Key psq, p, v))) -> psq p v -> (b, psq p v) -- Lists fromList :: Ord p => [(Key psq, p, v)] -> psq p v toList :: Ord p => psq p v -> [(Key psq, p, v)] keys :: Ord p => psq p v -> [Key psq] -- Views insertView :: Ord p => Key psq -> p -> v -> psq p v -> (Maybe (p, v), psq p v) deleteView :: Ord p => Key psq -> psq p v -> Maybe (p, v, psq p v) minView :: Ord p => psq p v -> Maybe (Key psq, p, v, psq p v) -- Traversals map :: Ord p => (Key psq -> p -> v -> w) -> psq p v -> psq p w fold' :: Ord p => (Key psq -> p -> v -> a -> a) -> a -> psq p v -> a -- Validity check valid :: Ord p => psq p v -> Bool instance PSQ IntPSQ.IntPSQ where type Key IntPSQ.IntPSQ = Int null = IntPSQ.null size = IntPSQ.size member = IntPSQ.member lookup = IntPSQ.lookup findMin = IntPSQ.findMin empty = IntPSQ.empty singleton = IntPSQ.singleton insert = IntPSQ.insert delete = IntPSQ.delete deleteMin = IntPSQ.deleteMin alter = IntPSQ.alter alterMin = IntPSQ.alterMin fromList = IntPSQ.fromList toList = IntPSQ.toList keys = IntPSQ.keys insertView = IntPSQ.insertView deleteView = IntPSQ.deleteView minView = IntPSQ.minView map = IntPSQ.map fold' = IntPSQ.fold' valid = IntPSQ.valid instance forall k. Ord k => PSQ (OrdPSQ.OrdPSQ k) where type Key (OrdPSQ.OrdPSQ k) = k null = OrdPSQ.null size = OrdPSQ.size member = OrdPSQ.member lookup = OrdPSQ.lookup findMin = OrdPSQ.findMin empty = OrdPSQ.empty singleton = OrdPSQ.singleton insert = OrdPSQ.insert delete = OrdPSQ.delete deleteMin = OrdPSQ.deleteMin alter = OrdPSQ.alter alterMin = OrdPSQ.alterMin fromList = OrdPSQ.fromList toList = OrdPSQ.toList keys = OrdPSQ.keys insertView = OrdPSQ.insertView deleteView = OrdPSQ.deleteView minView = OrdPSQ.minView map = OrdPSQ.map fold' = OrdPSQ.fold' valid = OrdPSQ.valid instance forall k. (Hashable k, Ord k) => PSQ (HashPSQ.HashPSQ k) where type Key (HashPSQ.HashPSQ k) = k null = HashPSQ.null size = HashPSQ.size member = HashPSQ.member lookup = HashPSQ.lookup findMin = HashPSQ.findMin empty = HashPSQ.empty singleton = HashPSQ.singleton insert = HashPSQ.insert delete = HashPSQ.delete deleteMin = HashPSQ.deleteMin alter = HashPSQ.alter alterMin = HashPSQ.alterMin fromList = HashPSQ.fromList toList = HashPSQ.toList keys = HashPSQ.keys insertView = HashPSQ.insertView deleteView = HashPSQ.deleteView minView = HashPSQ.minView map = HashPSQ.map fold' = HashPSQ.fold' valid = HashPSQ.valid psqueues-0.2.2.2/tests/Data/PSQ/Class/0000755000000000000000000000000012745134107015442 5ustar0000000000000000psqueues-0.2.2.2/tests/Data/PSQ/Class/Util.hs0000644000000000000000000000517612745134107016724 0ustar0000000000000000-- | Various test utilities {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Data.PSQ.Class.Util ( LousyHashedInt (..) , TestKey (..) , arbitraryInt , arbitraryPriority , arbitraryTestKey , coverShowInstance , assertErrorCall , largerThanMaxPrio ) where import Control.Applicative ((<$>)) import Data.Hashable (Hashable (..)) import Control.Exception (ErrorCall (..), fromException, handle) import Test.HUnit (Assertion, assertFailure) import Test.QuickCheck (Arbitrary (..), Gen, arbitrary, choose) import Control.DeepSeq (NFData) import Data.PSQ.Class -- | A type we used a key in the PSQs in the tests. It intentionally has a -- really bad 'Hashable' instance so we get lots of collisions. newtype LousyHashedInt = LousyHashedInt Int deriving (Enum, Eq, Integral, NFData, Num, Ord, Real, Show) instance Arbitrary LousyHashedInt where arbitrary = LousyHashedInt <$> arbitraryInt instance Hashable LousyHashedInt where hashWithSalt salt (LousyHashedInt x) = hashWithSalt salt x `mod` 100 class (Arbitrary a, Enum a, Eq a, Num a, Ord a, Show a) => TestKey a where toTestKey :: Int -> a toTestKey = toEnum fromTestKey :: a -> Int fromTestKey = fromEnum instance TestKey LousyHashedInt where instance TestKey Int where arbitraryInt :: Gen Int arbitraryInt = arbitrary -- | Makes sure the priorities are taken from a small set so we have some -- collisions. arbitraryPriority :: Gen Int arbitraryPriority = choose (-10, 10) arbitraryTestKey :: TestKey a => Gen a arbitraryTestKey = toEnum <$> arbitraryInt -- | This is a bit ridiculous. We need to call all 'Show' methods to get 100% -- coverage. coverShowInstance :: Show a => a -> String coverShowInstance x = showsPrec 0 x $ showList [x] $ show x -- | Check that evaluating the second argument to Whitney Houston Normal Form -- results in a call to `error`. The error message is passed to the first -- handler, so you can perform checks on it. assertErrorCall :: (String -> Assertion) -> a -> Assertion assertErrorCall handler x = handle (\e -> case fromException e of Just (ErrorCall str) -> handler str Nothing -> assertFailure $ "assertErrorCall: expected `error` but got: " ++ show e) (x `seq` assertFailure "assertErrorCall: evaluated to WHNF and no exception was thrown") largerThanMaxPrio :: PSQ psq => psq Int v -> Int largerThanMaxPrio = maybe 3 (+ 1) . fold' (\_ p _ acc -> max' p acc) Nothing where max' x Nothing = Just x max' x (Just y) = Just (max x y) psqueues-0.2.2.2/tests/Data/PSQ/Class/Tests.hs0000644000000000000000000004006112745134107017101 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} module Data.PSQ.Class.Tests ( tests ) where import Prelude hiding (null, lookup, map, foldr) import Control.Applicative ((<$>)) import Control.DeepSeq (NFData, rnf) import Data.Tagged (Tagged (..), untag) import qualified Data.List as List import Data.Char (isPrint, isAlphaNum, ord, toLower) import Data.Foldable (Foldable, foldr) import Test.QuickCheck (Arbitrary (..), Property, (==>), forAll) import Test.HUnit (Assertion, assert, (@?=)) import Test.Framework (Test) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) import Data.PSQ.Class import Data.PSQ.Class.Gen import Data.PSQ.Class.Util -------------------------------------------------------------------------------- -- Index of tests -------------------------------------------------------------------------------- tests :: forall psq. (PSQ psq, TestKey (Key psq), Arbitrary (psq Int Char), Eq (psq Int Char), Foldable (psq Int), Functor (psq Int), NFData (psq Int Char), Show (psq Int Char)) => Tagged psq [Test] tests = Tagged [ testCase "rnf" (untag' test_rnf) , testCase "equality" (untag' test_equality) , testCase "size" (untag' test_size) , testCase "size2" (untag' test_size2) , testCase "empty" (untag' test_empty) , testCase "lookup" (untag' test_lookup) , testCase "findMin" (untag' test_findMin) , testCase "alter" (untag' test_alter) , testCase "alterMin" (untag' test_alterMin) , testCase "fromList" (untag' test_fromList) , testCase "foldr" (untag' test_foldr) , testProperty "show" (untag' prop_show) , testProperty "rnf" (untag' prop_rnf) , testProperty "size" (untag' prop_size) , testProperty "singleton" (untag' prop_singleton) , testProperty "memberLookup" (untag' prop_memberLookup) , testProperty "insertLookup" (untag' prop_insertLookup) , testProperty "insertDelete" (untag' prop_insertDelete) , testProperty "insertDeleteView" (untag' prop_insertDeleteView) , testProperty "deleteNonMember" (untag' prop_deleteNonMember) , testProperty "deleteMin" (untag' prop_deleteMin) , testProperty "alter" (untag' prop_alter) , testProperty "alterMin" (untag' prop_alterMin) , testProperty "toList" (untag' prop_toList) , testProperty "keys" (untag' prop_keys) , testProperty "insertView" (untag' prop_insertView) , testProperty "deleteView" (untag' prop_deleteView) , testProperty "map" (untag' prop_map) , testProperty "fmap" (untag' prop_fmap) , testProperty "fold'" (untag' prop_fold') , testProperty "foldr" (untag' prop_foldr) , testProperty "valid" (untag' prop_valid) ] where untag' :: Tagged psq test -> test untag' = untag -------------------------------------------------------------------------------- -- HUnit tests -------------------------------------------------------------------------------- test_rnf :: forall psq. (PSQ psq, TestKey (Key psq), NFData (psq Int Char)) => Tagged psq Assertion test_rnf = Tagged $ rnf (empty :: psq Int Char) `seq` return () test_equality :: forall psq. (PSQ psq, TestKey (Key psq), Eq (psq Int Char)) => Tagged psq Assertion test_equality = Tagged $ do -- Mostly to get 100% coverage assert $ e /= s assert $ s /= e where e = empty :: psq Int Char s = singleton 3 100 'a' :: psq Int Char test_size :: forall psq. (PSQ psq, TestKey (Key psq)) => Tagged psq Assertion test_size = Tagged $ do null (empty :: psq Int Char) @?= True null (singleton 1 100 'a' :: psq Int Char) @?= False test_size2 :: forall psq. (PSQ psq, TestKey (Key psq)) => Tagged psq Assertion test_size2 = Tagged $ do size (empty :: psq Int ()) @?= 0 size (singleton 1 100 'a' :: psq Int Char) @?= 1 size (fromList [(1, 100, 'a'), (2, 101, 'c'), (3, 102, 'b')] :: psq Int Char) @?= 3 test_empty :: forall psq. (PSQ psq, TestKey (Key psq)) => Tagged psq Assertion test_empty = Tagged $ do toList (empty :: psq Int ()) @?= [] size (empty :: psq Char Int) @?= 0 test_lookup :: forall psq. (PSQ psq, TestKey (Key psq)) => Tagged psq Assertion test_lookup = Tagged $ do employeeCurrency 1 @?= Just 1 employeeCurrency 2 @?= Nothing where employeeDept = fromList [(1, 100, 2), (3, 101, 1)] :: psq Int Int deptCountry = fromList [(1, 102, 1), (2, 103, 2)] :: psq Int Int countryCurrency = fromList [(1, 104, 2), (2, 105, 1)] :: psq Int Int employeeCurrency :: Int -> Maybe Int employeeCurrency name = do dept <- snd <$> lookup (toTestKey name) employeeDept country <- snd <$> lookup (toTestKey dept) deptCountry snd <$> lookup (toTestKey country) countryCurrency test_findMin :: forall psq. (PSQ psq, TestKey (Key psq)) => Tagged psq Assertion test_findMin = Tagged $ do findMin (empty :: psq Int Char) @?= Nothing findMin (fromList [(5, 101, 'a'), (3, 100, 'b')] :: psq Int Char) @?= Just (3, 100, 'b') test_alter :: forall psq. (PSQ psq, TestKey (Key psq), Eq (psq Int Char), Show (psq Int Char)) => Tagged psq Assertion test_alter = Tagged $ do alter f 3 (empty :: psq Int Char) @?= ("Hello", singleton 3 100 'a') alter f 3 (singleton 3 100 'a' :: psq Int Char) @?= ("World", empty) alter f 3 (singleton 3 100 'b' :: psq Int Char) @?= ("Cats", singleton 3 101 'b') where f Nothing = ("Hello", Just (100, 'a')) f (Just (100, 'a')) = ("World", Nothing) f (Just _) = ("Cats", Just (101, 'b')) test_alterMin :: forall psq. (PSQ psq, TestKey (Key psq), Eq (psq Int Char), Show (psq Int Char)) => Tagged psq Assertion test_alterMin = Tagged $ do alterMin (\_ -> ((), Nothing)) (empty :: psq Int Char) @?= ((), empty) alterMin (\_ -> ((), Nothing)) (singleton 3 100 'a' :: psq Int Char) @?= ((), empty) test_fromList :: forall psq. (PSQ psq, TestKey (Key psq), Eq (psq Int Char), Show (psq Int Char)) => Tagged psq Assertion test_fromList = Tagged $ let ls = [(1, 0, 'A'), (2, 0, 'B'), (3, 0, 'C'), (4, 0, 'D')] in (fromList ls :: psq Int Char) @?= fromList (reverse ls) test_foldr :: forall psq. (PSQ psq, TestKey (Key psq), Foldable (psq Int)) => Tagged psq Assertion test_foldr = Tagged $ foldr (\x acc -> acc + ord x) 0 (empty :: psq Int Char) @?= 0 -------------------------------------------------------------------------------- -- QuickCheck properties -------------------------------------------------------------------------------- -- | For 100% test coverage... prop_show :: forall psq. (PSQ psq, TestKey (Key psq), Show (psq Int Char)) => Tagged psq Property prop_show = Tagged $ forAll arbitraryPSQ $ \t -> length (coverShowInstance (t :: psq Int Char)) > 0 -- | For 100% test coverage... prop_rnf :: forall psq. (PSQ psq, TestKey (Key psq), NFData (psq Int Char), Show (psq Int Char)) => Tagged psq Property prop_rnf = Tagged $ forAll arbitraryPSQ $ \t -> rnf (t :: psq Int Char) `seq` True prop_size :: forall psq. (PSQ psq, TestKey (Key psq), Show (psq Int Char)) => Tagged psq (psq Int Char -> Bool) prop_size = Tagged $ \t -> size (t :: psq Int Char) == length (toList t) prop_singleton :: forall psq. (PSQ psq, TestKey (Key psq), Eq (psq Int Char)) => Tagged psq Property prop_singleton = Tagged $ forAll arbitraryTestKey $ \k -> forAll arbitraryPriority $ \p -> forAll arbitrary $ \x -> insert k p x empty == (singleton k p x :: psq Int Char) prop_memberLookup :: forall psq. (PSQ psq, TestKey (Key psq), Arbitrary (psq Int Char), Show (psq Int Char)) => Tagged psq (psq Int Char -> Property) prop_memberLookup = Tagged $ \t -> forAll arbitraryTestKey $ \k -> case lookup k (t :: psq Int Char) of Nothing -> not (member k t) Just _ -> member k t prop_insertLookup :: forall psq. (PSQ psq, TestKey (Key psq), Arbitrary (psq Int Char), Show (psq Int Char)) => Tagged psq (psq Int Char -> Property) prop_insertLookup = Tagged $ \t -> forAll arbitraryTestKey $ \k -> forAll arbitraryPriority $ \p -> forAll arbitrary $ \c -> lookup k (insert k p c (t :: psq Int Char)) == Just (p, c) prop_insertDelete :: forall psq. (PSQ psq, TestKey (Key psq), Arbitrary (psq Int Char), Eq (psq Int Char), Show (psq Int Char)) => Tagged psq (psq Int Char -> Property) prop_insertDelete = Tagged $ \t -> forAll arbitraryTestKey $ \k -> forAll arbitraryPriority $ \p -> forAll arbitrary $ \c -> (lookup k t == Nothing) ==> (delete k (insert k p c t) == (t :: psq Int Char)) prop_insertDeleteView :: forall psq. (PSQ psq, TestKey (Key psq), Arbitrary (psq Int Char), Eq (psq Int Char), Show (psq Int Char)) => Tagged psq (psq Int Char -> Property) prop_insertDeleteView = Tagged $ \t -> forAll arbitraryTestKey $ \k -> forAll arbitraryPriority $ \p -> forAll arbitrary $ \c -> case deleteView k (insert k p c (t :: psq Int Char)) of Nothing -> False Just (p', c', t') | member k t -> p' == p && c' == c && size t' < size t | otherwise -> p' == p && c' == c && t' == t prop_deleteNonMember :: forall psq. (PSQ psq, TestKey (Key psq), Arbitrary (psq Int Char), Eq (psq Int Char), Show (psq Int Char)) => Tagged psq (psq Int Char -> Property) prop_deleteNonMember = Tagged $ \t -> forAll arbitraryTestKey $ \k -> (lookup k t == Nothing) ==> (delete k t == (t :: psq Int Char)) prop_deleteMin :: forall psq. (PSQ psq, TestKey (Key psq), Arbitrary (psq Int Char), Eq (psq Int Char), Show (psq Int Char)) => Tagged psq (psq Int Char -> Bool) prop_deleteMin = Tagged $ \t -> let t' = deleteMin t in if null t then t' == t else case findMin t of Nothing -> False Just (k, _, _) -> size t' == size t - 1 && member k t && not (member k t') prop_alter :: forall psq. (PSQ psq, TestKey (Key psq), Show (psq Int Char)) => Tagged psq (psq Int Char -> Property) prop_alter = Tagged $ \t -> forAll arbitraryTestKey $ \k -> let ((), t') = alter f k t :: ((), psq Int Char) in case lookup k t of Just _ -> (size t - 1) == size t' && lookup k t' == Nothing Nothing -> (size t + 1) == size t' && lookup k t' /= Nothing where f Nothing = ((), Just (100, 'a')) f (Just _) = ((), Nothing) prop_alterMin :: forall psq. (PSQ psq, TestKey (Key psq), Arbitrary (psq Int Char), Eq (psq Int Char), Show (psq Int Char)) => Tagged psq (psq Int Char -> Bool) prop_alterMin = Tagged $ \t -> let (mbMin, t') = alterMin f (t :: psq Int Char) in case mbMin of Nothing -> t' == singleton 3 100 'a' Just (k, p, v) -> findMin t == Just (k, p, v) && member k t && (case () of _ | isAlphaNum v -> lookup k t' == Just (fromTestKey k, v) | isPrint v -> lookup (toTestKey $ ord v) t' == Just (ord v, v) | otherwise -> not (member k t')) where f Nothing = (Nothing, Just (3, 100, 'a')) f (Just (k, p, v)) | isAlphaNum v = (Just (k, p, v), Just (k, fromTestKey k, v)) | isPrint v = (Just (k, p, v), Just (toTestKey (ord v), ord v, v)) | otherwise = (Just (k, p, v), Nothing) prop_toList :: forall psq. (PSQ psq, TestKey (Key psq), Arbitrary (psq Int Char), Eq (psq Int Char), Show (psq Int Char)) => Tagged psq (psq Int Char -> Bool) prop_toList = Tagged $ \t -> (t :: psq Int Char) == fromList (toList t) prop_keys :: forall psq. (PSQ psq, TestKey (Key psq), Arbitrary (psq Int Char), Show (psq Int Char)) => Tagged psq (psq Int Char -> Bool) prop_keys = Tagged $ \t -> List.sort (keys (t :: psq Int Char)) == List.sort [k | (k, _, _) <- toList t] prop_insertView :: forall psq. (PSQ psq, TestKey (Key psq), Arbitrary (psq Int Char), Show (psq Int Char)) => Tagged psq (psq Int Char -> Property) prop_insertView = Tagged $ \t -> forAll arbitraryTestKey $ \k -> forAll arbitraryPriority $ \p -> forAll arbitrary $ \x -> case insertView k p x (t :: psq Int Char) of (mbPx, t') -> lookup k t == mbPx && lookup k t' == Just (p, x) prop_deleteView :: forall psq. (PSQ psq, TestKey (Key psq), Arbitrary (psq Int Char), Show (psq Int Char)) => Tagged psq (psq Int Char -> Property) prop_deleteView = Tagged $ \t -> forAll arbitraryTestKey $ \k -> case deleteView k (t :: psq Int Char) of Nothing -> not (member k t) Just (p, v, t') -> lookup k t == Just (p, v) && not (member k t') prop_map :: forall psq. (PSQ psq, TestKey (Key psq), Arbitrary (psq Int Char), Eq (psq Int Char), Show (psq Int Char)) => Tagged psq (psq Int Char -> Bool) prop_map = Tagged $ \t -> map f (t :: psq Int Char) == fromList (List.map (\(k, p, x) -> (k, p, f k p x)) (toList t)) where f k p x = if fromEnum k > p then x else 'a' prop_fmap :: forall psq. (PSQ psq, TestKey (Key psq), Arbitrary (psq Int Char), Eq (psq Int Char), Functor (psq Int), Show (psq Int Char)) => Tagged psq (psq Int Char -> Bool) prop_fmap = Tagged $ \t -> fmap toLower (t :: psq Int Char) == fromList (List.map (\(p, v, x) -> (p, v, toLower x)) (toList t)) prop_fold' :: forall psq. (PSQ psq, TestKey (Key psq), Arbitrary (psq Int Char), Show (psq Int Char)) => Tagged psq (psq Int Char -> Bool) prop_fold' = Tagged $ \t -> fold' f acc0 (t :: psq Int Char) == List.foldl' (\acc (k, p, x) -> f k p x acc) acc0 (toList t) where -- Needs to be commutative f k p x (kpSum, xs) = (kpSum + fromEnum k + p, List.sort (x : xs)) acc0 = (0, []) prop_foldr :: forall psq. (PSQ psq, Arbitrary (psq Int Char), Foldable (psq Int), Show (psq Int Char)) => Tagged psq (psq Int Char -> Bool) prop_foldr = Tagged $ \t -> foldr f 0 (t :: psq Int Char) == List.foldr (\(_, _, x) acc -> f x acc) 0 (toList t) where f x acc = acc + ord x prop_valid :: forall psq. (PSQ psq, Arbitrary (psq Int Char), Show (psq Int Char)) => Tagged psq (psq Int Char -> Bool) prop_valid = Tagged valid psqueues-0.2.2.2/tests/Data/PSQ/Class/Gen.hs0000644000000000000000000000460312745134107016512 0ustar0000000000000000-- | Higher-quality random generator for PSQ structures which generates a PSQ -- from a series of actions {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.PSQ.Class.Gen ( arbitraryPSQ ) where import Control.Applicative (pure, (<$>), (<*>)) import Test.QuickCheck (Gen, Arbitrary (..), frequency, choose, elements) import Control.Monad (foldM, replicateM) import Data.Hashable (Hashable) import Data.PSQ.Class (PSQ (..)) import Data.PSQ.Class.Util import qualified Data.OrdPSQ as OrdPSQ import qualified Data.IntPSQ as IntPSQ import qualified Data.HashPSQ as HashPSQ data Action k p v = Insert k p v | DeleteRandomMember | DeleteMin deriving (Show, Eq) arbitraryAction :: (Arbitrary k, Arbitrary v) => Gen (Action k Int v) arbitraryAction = frequency [ (10, Insert <$> arbitrary <*> arbitraryPriority <*> arbitrary) , (2, pure DeleteRandomMember) , (2, pure DeleteMin) ] apply :: PSQ psq => Action (Key psq) Int v -> psq Int v -> Gen (psq Int v) apply (Insert k p x) t = return $ insert k p x t apply DeleteRandomMember t = do key <- elements (keys t) return $ delete key t apply DeleteMin t = return $ case minView t of Nothing -> t Just (_, _, _, t') -> t' arbitraryPSQ :: forall psq v. (Arbitrary (Key psq), Arbitrary v, PSQ psq) => Gen (psq Int v) arbitraryPSQ = do numActions <- choose (0, 100) actions <- replicateM numActions arbitraryAction foldM (\t a -> apply a t) (empty :: psq Int v) actions shrinkPSQ :: forall psq p v. (Ord p, PSQ psq) => psq p v -> [psq p v] shrinkPSQ t = [delete k t | k <- keys t] instance forall k v. (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (OrdPSQ.OrdPSQ k Int v) where arbitrary = arbitraryPSQ shrink = shrinkPSQ instance forall v. (Arbitrary v) => Arbitrary (IntPSQ.IntPSQ Int v) where arbitrary = arbitraryPSQ shrink = shrinkPSQ instance forall k v. (Arbitrary k, Arbitrary v, Hashable k, Ord k) => Arbitrary (HashPSQ.HashPSQ k Int v) where arbitrary = arbitraryPSQ shrink = shrinkPSQ psqueues-0.2.2.2/tests/Data/HashPSQ/0000755000000000000000000000000012745134107015201 5ustar0000000000000000psqueues-0.2.2.2/tests/Data/HashPSQ/Tests.hs0000644000000000000000000000651412745134107016645 0ustar0000000000000000module Data.HashPSQ.Tests ( tests ) where import Prelude hiding (lookup) import Test.Framework (Test) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck (Property, arbitrary, forAll) import Test.HUnit (Assertion, assert) import Data.HashPSQ.Internal import qualified Data.OrdPSQ as OrdPSQ import Data.PSQ.Class.Gen import Data.PSQ.Class.Util -------------------------------------------------------------------------------- -- Index of tests -------------------------------------------------------------------------------- tests :: [Test] tests = [ testCase "showBucket" test_showBucket , testCase "toBucket" test_toBucket , testProperty "unsafeLookupIncreasePriority" prop_unsafeLookupIncreasePriority , testProperty "unsafeInsertIncreasePriority" prop_unsafeInsertIncreasePriority , testProperty "unsafeInsertIncreasePriorityView" prop_unsafeInsertIncreasePriorityView ] -------------------------------------------------------------------------------- -- Unit tests -------------------------------------------------------------------------------- test_showBucket :: Assertion test_showBucket = assert $ length (coverShowInstance bucket) > 0 where bucket :: Bucket Int Int Char bucket = B 1 'a' OrdPSQ.empty test_toBucket :: Assertion test_toBucket = assert True -- TODO (jaspervdj) -- assert $ mkBucket (OrdPSQ.empty :: OrdPSQ.OrdPSQ Int Int Char) -------------------------------------------------------------------------------- -- Properties -------------------------------------------------------------------------------- prop_unsafeLookupIncreasePriority :: Property prop_unsafeLookupIncreasePriority = forAll arbitraryPSQ $ \t -> forAll arbitrary $ \k -> let newP = maybe 0 ((+ 1) . fst) (lookup k t) (mbPx, t') = unsafeLookupIncreasePriority k newP t expect = case mbPx of Nothing -> Nothing Just (p, x) -> Just (p + 1, x) in valid (t' :: HashPSQ LousyHashedInt Int Char) && lookup k t' == expect && lookup k t == mbPx prop_unsafeInsertIncreasePriority :: Property prop_unsafeInsertIncreasePriority = forAll arbitraryPSQ $ \t -> forAll arbitrary $ \k -> forAll arbitrary $ \x -> let prio = largerThanMaxPrio t t' = unsafeInsertIncreasePriority k prio x t in valid (t' :: HashPSQ LousyHashedInt Int Char) && lookup k t' == Just (prio, x) prop_unsafeInsertIncreasePriorityView :: Property prop_unsafeInsertIncreasePriorityView = forAll arbitraryPSQ $ \t -> forAll arbitrary $ \k -> forAll arbitrary $ \x -> let prio = largerThanMaxPrio t (mbPx, t') = unsafeInsertIncreasePriorityView k prio x t in valid (t' :: HashPSQ LousyHashedInt Int Char) && lookup k t' == Just (prio, x) && lookup k t == mbPx psqueues-0.2.2.2/tests/Data/IntPSQ/0000755000000000000000000000000012745134107015050 5ustar0000000000000000psqueues-0.2.2.2/tests/Data/IntPSQ/Tests.hs0000644000000000000000000001131112745134107016503 0ustar0000000000000000module Data.IntPSQ.Tests where import Prelude hiding (lookup) import Test.QuickCheck (Property, arbitrary, forAll) import Test.Framework (Test) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit (Assertion, assert) import Data.IntPSQ.Internal import Data.PSQ.Class.Gen import Data.PSQ.Class.Util -------------------------------------------------------------------------------- -- Index of tests -------------------------------------------------------------------------------- tests :: [Test] tests = [ testCase "hasBadNils" test_hasBadNils , testProperty "unsafeInsertIncreasePriority" prop_unsafeInsertIncreasePriority , testProperty "unsafeInsertIncreasePriorityView" prop_unsafeInsertIncreasePriorityView , testProperty "unsafeInsertWithIncreasePriority" prop_unsafeInsertWithIncreasePriority , testProperty "unsafeInsertWithIncreasePriorityView" prop_unsafeInsertWithIncreasePriorityView , testProperty "unsafeLookupIncreasePriority" prop_unsafeLookupIncreasePriority ] -------------------------------------------------------------------------------- -- Unit tests -------------------------------------------------------------------------------- -- 100% test coverage... test_hasBadNils :: Assertion test_hasBadNils = assert $ hasBadNils (Bin 1 (2 :: Int) 'x' 0 Nil Nil) -------------------------------------------------------------------------------- -- QuickCheck properties -------------------------------------------------------------------------------- prop_unsafeInsertIncreasePriority :: Property prop_unsafeInsertIncreasePriority = forAll arbitraryPSQ $ \t -> forAll arbitrary $ \k -> forAll arbitrary $ \x -> let prio = largerThanMaxPrio t t' = unsafeInsertIncreasePriority k prio x t in valid (t' :: IntPSQ Int Char) && lookup k t' == Just (prio, x) prop_unsafeInsertIncreasePriorityView :: Property prop_unsafeInsertIncreasePriorityView = forAll arbitraryPSQ $ \t -> forAll arbitrary $ \k -> forAll arbitrary $ \x -> let prio = largerThanMaxPrio t (mbPx, t') = unsafeInsertIncreasePriorityView k prio x t in valid (t' :: IntPSQ Int Char) && lookup k t' == Just (prio, x) && lookup k t == mbPx prop_unsafeInsertWithIncreasePriority :: Property prop_unsafeInsertWithIncreasePriority = forAll arbitraryPSQ $ \t0 -> forAll arbitrary $ \k -> forAll arbitrary $ \x -> let t = fmap (\e -> [e]) t0 :: IntPSQ Int [Char] prio = largerThanMaxPrio t f = \newP newX oldP oldX -> (min newP oldP + 1, newX ++ oldX) t' = unsafeInsertWithIncreasePriority f k prio [x] t expect = case lookup k t of Nothing -> (prio, [x]) Just (p, y) -> (min prio p + 1, [x] ++ y) in valid t' && lookup k t' == Just expect prop_unsafeInsertWithIncreasePriorityView :: Property prop_unsafeInsertWithIncreasePriorityView = forAll arbitraryPSQ $ \t0 -> forAll arbitrary $ \k -> forAll arbitrary $ \x -> let t = fmap (\e -> [e]) t0 :: IntPSQ Int [Char] prio = largerThanMaxPrio t f = \newP newX oldP oldX -> (min newP oldP + 1, newX ++ oldX) (mbPx, t') = unsafeInsertWithIncreasePriorityView f k prio [x] t expect = case mbPx of Nothing -> (prio, [x]) Just (p, y) -> (min prio p + 1, [x] ++ y) in valid t' && lookup k t' == Just expect && lookup k t == mbPx prop_unsafeLookupIncreasePriority :: Property prop_unsafeLookupIncreasePriority = forAll arbitraryPSQ $ \t0 -> forAll arbitrary $ \k -> let t = fmap (\e -> [e]) t0 :: IntPSQ Int [Char] f = \oldP oldX -> (Just (oldP, oldX), oldP + 1, oldX ++ "k") (mbPx, t') = unsafeLookupIncreasePriority f k t expect = case mbPx of Nothing -> Nothing Just (p, x) -> Just (p + 1, x ++ "k") in valid t' && lookup k t' == expect && lookup k t == mbPx psqueues-0.2.2.2/tests/Data/OrdPSQ/0000755000000000000000000000000012745134107015042 5ustar0000000000000000psqueues-0.2.2.2/tests/Data/OrdPSQ/Tests.hs0000644000000000000000000000662712745134107016513 0ustar0000000000000000module Data.OrdPSQ.Tests ( tests ) where import Data.List (isInfixOf) import Test.Framework (Test) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit (Assertion, assert) import Data.OrdPSQ.Internal import Data.PSQ.Class.Gen () import Data.PSQ.Class.Util -------------------------------------------------------------------------------- -- Index of tests -------------------------------------------------------------------------------- tests :: [Test] tests = [ testCase "showElem" test_showElem , testCase "showLTree" test_showLTree , testCase "invalidLTree" test_invalidLTree , testCase "balanceErrors" test_balanceErrors , testProperty "toAscList" prop_toAscList ] -------------------------------------------------------------------------------- -- Tests the result of 'moduleError' for internal issues -------------------------------------------------------------------------------- assertModuleError :: String -> String -> a -> Assertion assertModuleError fun msg = assertErrorCall $ \e -> do assert $ fun `isInfixOf` e assert $ msg `isInfixOf` e -------------------------------------------------------------------------------- -- HUnit tests -------------------------------------------------------------------------------- test_showElem :: Assertion test_showElem = assert $ length (coverShowInstance (E 0 0 'A' :: Elem Int Int Char)) > 0 test_showLTree :: Assertion test_showLTree = do assert $ length (coverShowInstance t1) > 0 assert $ length (coverShowInstance t2) > 0 assert $ length (coverShowInstance t3) > 0 where t1, t2, t3 :: LTree Int Int Char t1 = Start t2 = LLoser 1 e Start 0 Start t3 = RLoser 1 e Start 0 Start e = E 0 0 'A' test_invalidLTree :: Assertion test_invalidLTree = do assertModuleError "left" "empty" (left (Start :: LTree Int Int Char)) assertModuleError "right" "empty" (right (Start :: LTree Int Int Char)) assertModuleError "maxKey" "empty" (maxKey (empty :: OrdPSQ Int Int Char)) test_balanceErrors :: Assertion test_balanceErrors = do assertModuleError "lsingleLeft" msg (lsingleLeft 0 0 'A' nil 0 nil) assertModuleError "rsingleLeft" msg (rsingleLeft 0 0 'A' nil 0 nil) assertModuleError "lsingleRight" msg (lsingleRight 0 0 'A' nil 0 nil) assertModuleError "rsingleRight" msg (rsingleRight 0 0 'A' nil 0 nil) assertModuleError "ldoubleLeft" msg (ldoubleLeft 0 0 'A' nil 0 nil) assertModuleError "rdoubleLeft" msg (rdoubleLeft 0 0 'A' nil 0 nil) assertModuleError "ldoubleRight" msg (ldoubleRight 0 0 'A' nil 0 nil) assertModuleError "rdoubleRight" msg (rdoubleRight 0 0 'A' nil 0 nil) where nil = Start :: LTree Int Int Char msg = "malformed" -------------------------------------------------------------------------------- -- QuickCheck properties -------------------------------------------------------------------------------- prop_toAscList :: OrdPSQ Int Int Char -> Bool prop_toAscList t = isUniqueSorted [k | (k, _, _) <- toAscList t] where isUniqueSorted (x : y : zs) = x < y && isUniqueSorted (y : zs) isUniqueSorted [_] = True isUniqueSorted [] = True psqueues-0.2.2.2/src/0000755000000000000000000000000012745134107012506 5ustar0000000000000000psqueues-0.2.2.2/src/Data/0000755000000000000000000000000012745134107013357 5ustar0000000000000000psqueues-0.2.2.2/src/Data/IntPSQ.hs0000644000000000000000000000200512745134107015026 0ustar0000000000000000-- | 'IntPSQ' fixes the key type to 'Int'. It is generally much faster than -- an 'OrdPSQ'. -- -- Many operations have a worst-case complexity of O(min(n,W)). This means that -- the operation can -- become linear in the number of elements with a maximum -- of W -- the number of bits in an Int (32 or 64). {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE UnboxedTuples #-} module Data.IntPSQ ( -- * Type IntPSQ -- * Query , null , size , member , lookup , findMin -- * Construction , empty , singleton -- * Insertion , insert -- * Delete/update , delete , deleteMin , alter , alterMin -- * Lists , fromList , toList , keys -- * Views , insertView , deleteView , minView -- * Traversal , map , fold' -- * Validity check , valid ) where import Prelude hiding (lookup, map, filter, foldr, foldl, null) import Data.IntPSQ.Internal psqueues-0.2.2.2/src/Data/HashPSQ.hs0000644000000000000000000000173712745134107015172 0ustar0000000000000000-- | A 'HashPSQ' offers very similar performance to 'IntPSQ'. In case of -- collisions, it uses an 'OrdPSQ' locally to solve those. -- -- This means worst case complexity is usually given by /O(min(n,W), log n)/, -- where /W/ is the number of bits in an 'Int'. This simplifies to /O(min(n,W))/ -- since /log n/ is always smaller than /W/ on current machines. module Data.HashPSQ ( -- * Type HashPSQ -- * Query , null , size , member , lookup , findMin -- * Construction , empty , singleton -- * Insertion , insert -- * Delete/update , delete , deleteMin , alter , alterMin -- * Lists , fromList , toList , keys -- * Views , insertView , deleteView , minView -- * Traversal , map , fold' -- * Validity check , valid ) where import Prelude hiding (foldr, lookup, map, null) import Data.HashPSQ.Internal psqueues-0.2.2.2/src/Data/OrdPSQ.hs0000644000000000000000000000227412745134107015030 0ustar0000000000000000-- | An 'OrdPSQ' uses the 'Ord' instance of the key type to build a priority -- search queue. -- -- It is based on Ralf Hinze's work. -- -- * Hinze, R., A Simple Implementation Technique for Priority Search Queues, -- ICFP 2001, pp. 110-121 -- -- -- -- This means it is similar to the -- package but -- our benchmarks showed it perform quite a bit faster. {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE BangPatterns #-} module Data.OrdPSQ ( -- * Type OrdPSQ -- * Query , null , size , member , lookup , findMin -- * Construction , empty , singleton -- * Insertion , insert -- * Delete/Update , delete , deleteMin , alter , alterMin -- * Conversion , fromList , toList , toAscList , keys -- * Views , insertView , deleteView , minView -- * Traversals , map , fold' -- * Validity check , valid ) where import Prelude hiding (map, lookup, null, foldr) import Data.OrdPSQ.Internal psqueues-0.2.2.2/src/Data/BitUtil.hs0000644000000000000000000000402712745134107015272 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ {-# LANGUAGE MagicHash #-} #endif #if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.BitUtil -- Copyright : (c) Clark Gaebel 2012 -- (c) Johan Tibel 2012 -- License : BSD-style -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : portable ----------------------------------------------------------------------------- module Data.BitUtil ( highestBitMask ) where -- On GHC, include MachDeps.h to get WORD_SIZE_IN_BITS macro. #if defined(__GLASGOW_HASKELL__) # include "MachDeps.h" #endif import Data.Bits ((.|.), xor) #if __GLASGOW_HASKELL__ import GHC.Exts (Word(..), Int(..)) import GHC.Prim (uncheckedShiftRL#) #else import Data.Word (shiftL, shiftR) #endif -- The highestBitMask implementation is based on -- http://graphics.stanford.edu/~seander/bithacks.html#RoundUpPowerOf2 -- which has been put in the public domain. -- | Return a word where only the highest bit is set. highestBitMask :: Word -> Word highestBitMask x1 = let x2 = x1 .|. x1 `shiftRL` 1 x3 = x2 .|. x2 `shiftRL` 2 x4 = x3 .|. x3 `shiftRL` 4 x5 = x4 .|. x4 `shiftRL` 8 x6 = x5 .|. x5 `shiftRL` 16 #if !(defined(__GLASGOW_HASKELL__) && WORD_SIZE_IN_BITS==32) x7 = x6 .|. x6 `shiftRL` 32 in x7 `xor` (x7 `shiftRL` 1) #else in x6 `xor` (x6 `shiftRL` 1) #endif {-# INLINE highestBitMask #-} -- Right and left logical shifts. shiftRL :: Word -> Int -> Word #if __GLASGOW_HASKELL__ {-------------------------------------------------------------------- GHC: use unboxing to get @shiftRL@ inlined. --------------------------------------------------------------------} shiftRL (W# x) (I# i) = W# (uncheckedShiftRL# x i) #else shiftRL x i = shiftR x i #endif {-# INLINE shiftRL #-} psqueues-0.2.2.2/src/Data/HashPSQ/0000755000000000000000000000000012745134107014626 5ustar0000000000000000psqueues-0.2.2.2/src/Data/HashPSQ/Internal.hs0000644000000000000000000004105112745134107016737 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} module Data.HashPSQ.Internal ( -- * Type Bucket (..) , mkBucket , HashPSQ (..) -- * Query , null , size , member , lookup , findMin -- * Construction , empty , singleton -- * Insertion , insert -- * Delete/update , delete , deleteMin , alter , alterMin -- * Lists , fromList , toList , keys -- * Views , insertView , deleteView , minView -- * Traversal , map , fold' -- * Unsafe operations , unsafeLookupIncreasePriority , unsafeInsertIncreasePriority , unsafeInsertIncreasePriorityView -- * Validity check , valid ) where import Control.DeepSeq (NFData (..)) import Data.Foldable (Foldable (foldr)) import Data.Hashable import qualified Data.List as List import Data.Maybe (isJust) import Prelude hiding (foldr, lookup, map, null) import Data.Traversable import qualified Data.IntPSQ.Internal as IntPSQ import qualified Data.OrdPSQ as OrdPSQ ------------------------------------------------------------------------------ -- Types ------------------------------------------------------------------------------ data Bucket k p v = B !k !v !(OrdPSQ.OrdPSQ k p v) deriving (Foldable, Functor, Show, Traversable) -- | Smart constructor which takes care of placing the minimum element directly -- in the 'Bucket'. {-# INLINABLE mkBucket #-} mkBucket :: (Ord k, Ord p) => k -> p -> v -> OrdPSQ.OrdPSQ k p v -> (p, Bucket k p v) mkBucket k p x opsq = -- TODO (jaspervdj): We could do an 'unsafeInsertNew' here for all call -- sites. case toBucket (OrdPSQ.insert k p x opsq) of Just bucket -> bucket Nothing -> error $ "mkBucket: internal error" toBucket :: (Ord k, Ord p) => OrdPSQ.OrdPSQ k p v -> Maybe (p, Bucket k p v) toBucket opsq = case OrdPSQ.minView opsq of Just (k, p, x, opsq') -> Just (p, B k x opsq') Nothing -> Nothing instance (NFData k, NFData p, NFData v) => NFData (Bucket k p v) where rnf (B k v x) = rnf k `seq` rnf v `seq` rnf x -- | A priority search queue with keys of type @k@ and priorities of type @p@ -- and values of type @v@. It is strict in keys, priorities and values. newtype HashPSQ k p v = HashPSQ (IntPSQ.IntPSQ p (Bucket k p v)) deriving (Foldable, Functor, NFData, Show, Traversable) instance (Eq k, Eq p, Eq v, Hashable k, Ord k, Ord p) => Eq (HashPSQ k p v) where x == y = case (minView x, minView y) of (Nothing , Nothing ) -> True (Just (xk, xp, xv, x'), (Just (yk, yp, yv, y'))) -> xk == yk && xp == yp && xv == yv && x' == y' (Just _ , Nothing ) -> False (Nothing , Just _ ) -> False ------------------------------------------------------------------------------ -- Query ------------------------------------------------------------------------------ -- | /O(1)/ True if the queue is empty. {-# INLINABLE null #-} null :: HashPSQ k p v -> Bool null (HashPSQ ipsq) = IntPSQ.null ipsq -- | /O(n)/ The number of elements stored in the PSQ. {-# INLINABLE size #-} size :: HashPSQ k p v -> Int size (HashPSQ ipsq) = IntPSQ.fold' (\_ _ (B _ _ opsq) acc -> 1 + OrdPSQ.size opsq + acc) 0 ipsq -- | /O(min(n,W))/ Check if a key is present in the the queue. {-# INLINABLE member #-} member :: (Hashable k, Ord k, Ord p) => k -> HashPSQ k p v -> Bool member k = isJust . lookup k -- | /O(min(n,W))/ The priority and value of a given key, or 'Nothing' if the -- key is not bound. {-# INLINABLE lookup #-} lookup :: (Ord k, Hashable k, Ord p) => k -> HashPSQ k p v -> Maybe (p, v) lookup k (HashPSQ ipsq) = do (p0, B k0 v0 os) <- IntPSQ.lookup (hash k) ipsq if k0 == k then return (p0, v0) else OrdPSQ.lookup k os -- | /O(1)/ The element with the lowest priority. findMin :: (Hashable k, Ord k, Ord p) => HashPSQ k p v -> Maybe (k, p, v) findMin (HashPSQ ipsq) = case IntPSQ.findMin ipsq of Nothing -> Nothing Just (_, p, B k x _) -> Just (k, p, x) -------------------------------------------------------------------------------- -- Construction -------------------------------------------------------------------------------- -- | /O(1)/ The empty queue. empty :: HashPSQ k p v empty = HashPSQ IntPSQ.empty -- | /O(1)/ Build a queue with one element. singleton :: (Hashable k, Ord k, Ord p) => k -> p -> v -> HashPSQ k p v singleton k p v = insert k p v empty -------------------------------------------------------------------------------- -- Insertion -------------------------------------------------------------------------------- -- | /O(min(n,W))/ Insert a new key, priority and value into the queue. If the key -- is already present in the queue, the associated priority and value are -- replaced with the supplied priority and value. {-# INLINABLE insert #-} insert :: (Ord k, Hashable k, Ord p) => k -> p -> v -> HashPSQ k p v -> HashPSQ k p v insert k p v (HashPSQ ipsq) = case IntPSQ.alter (\x -> ((), ins x)) (hash k) ipsq of ((), ipsq') -> HashPSQ ipsq' where ins Nothing = Just (p, B k v (OrdPSQ.empty)) ins (Just (p', B k' v' os)) | k' == k = -- Tricky: p might have less priority than an item in 'os'. Just (mkBucket k p v os) | p' < p || (p == p' && k' < k) = Just (p', B k' v' (OrdPSQ.insert k p v os)) | OrdPSQ.member k os = -- This is a bit tricky: k might already be present in 'os' and we -- don't want to end up with duplicate keys. Just (p, B k v (OrdPSQ.insert k' p' v' (OrdPSQ.delete k os))) | otherwise = Just (p , B k v (OrdPSQ.insert k' p' v' os)) -------------------------------------------------------------------------------- -- Delete/update -------------------------------------------------------------------------------- -- | /O(min(n,W))/ Delete a key and its priority and value from the queue. When -- the key is not a member of the queue, the original queue is returned. {-# INLINE delete #-} delete :: (Hashable k, Ord k, Ord p) => k -> HashPSQ k p v -> HashPSQ k p v delete k t = case deleteView k t of Nothing -> t Just (_, _, t') -> t' -- | /O(min(n,W))/ Delete the binding with the least priority, and return the -- rest of the queue stripped of that binding. In case the queue is empty, the -- empty queue is returned again. {-# INLINE deleteMin #-} deleteMin :: (Hashable k, Ord k, Ord p) => HashPSQ k p v -> HashPSQ k p v deleteMin t = case minView t of Nothing -> t Just (_, _, _, t') -> t' -- | /O(min(n,W))/ The expression @alter f k queue@ alters the value @x@ at @k@, -- or absence thereof. 'alter' can be used to insert, delete, or update a value -- in a queue. It also allows you to calculate an additional value @b@. {-# INLINABLE alter #-} alter :: (Hashable k, Ord k, Ord p) => (Maybe (p, v) -> (b, Maybe (p, v))) -> k -> HashPSQ k p v -> (b, HashPSQ k p v) alter f k (HashPSQ ipsq) = case IntPSQ.deleteView h ipsq of Nothing -> case f Nothing of (b, Nothing) -> (b, HashPSQ ipsq) (b, Just (p, x)) -> (b, HashPSQ $ IntPSQ.unsafeInsertNew h p (B k x OrdPSQ.empty) ipsq) Just (bp, B bk bx opsq, ipsq') | k == bk -> case f (Just (bp, bx)) of (b, Nothing) -> case toBucket opsq of Nothing -> (b, HashPSQ ipsq') Just (bp', bucket') -> (b, HashPSQ $ IntPSQ.unsafeInsertNew h bp' bucket' ipsq') (b, Just (p, x)) -> case mkBucket k p x opsq of (bp', bucket') -> (b, HashPSQ $ IntPSQ.unsafeInsertNew h bp' bucket' ipsq') | otherwise -> case OrdPSQ.alter f k opsq of (b, opsq') -> case mkBucket bk bp bx opsq' of (bp', bucket') -> (b, HashPSQ $ IntPSQ.unsafeInsertNew h bp' bucket' ipsq') where h = hash k -- | /O(min(n,W))/ A variant of 'alter' which works on the element with the -- minimum priority. Unlike 'alter', this variant also allows you to change the -- key of the element. {-# INLINABLE alterMin #-} alterMin :: (Hashable k, Ord k, Ord p) => (Maybe (k, p, v) -> (b, Maybe (k, p, v))) -> HashPSQ k p v -> (b, HashPSQ k p v) alterMin f t0 = let (t, mbX) = case minView t0 of Nothing -> (t0, Nothing) Just (k, p, x, t0') -> (t0', Just (k, p, x)) in case f mbX of (b, mbX') -> (b, maybe t (\(k, p, x) -> insert k p x t) mbX') -------------------------------------------------------------------------------- -- Lists -------------------------------------------------------------------------------- -- | /O(n*min(n,W))/ Build a queue from a list of (key, priority, value) tuples. -- If the list contains more than one priority and value for the same key, the -- last priority and value for the key is retained. {-# INLINABLE fromList #-} fromList :: (Hashable k, Ord k, Ord p) => [(k, p, v)] -> HashPSQ k p v fromList = List.foldl' (\psq (k, p, x) -> insert k p x psq) empty -- | /O(n)/ Convert a queue to a list of (key, priority, value) tuples. The -- order of the list is not specified. {-# INLINABLE toList #-} toList :: (Hashable k, Ord k, Ord p) => HashPSQ k p v -> [(k, p, v)] toList (HashPSQ ipsq) = [ (k', p', x') | (_, p, (B k x opsq)) <- IntPSQ.toList ipsq , (k', p', x') <- (k, p, x) : OrdPSQ.toList opsq ] -- | /O(n)/ Obtain the list of present keys in the queue. {-# INLINABLE keys #-} keys :: (Hashable k, Ord k, Ord p) => HashPSQ k p v -> [k] keys t = [k | (k, _, _) <- toList t] -------------------------------------------------------------------------------- -- Views -------------------------------------------------------------------------------- -- | /O(min(n,W))/ Insert a new key, priority and value into the queue. If the key -- is already present in the queue, then the evicted priority and value can be -- found the first element of the returned tuple. {-# INLINABLE insertView #-} insertView :: (Hashable k, Ord k, Ord p) => k -> p -> v -> HashPSQ k p v -> (Maybe (p, v), HashPSQ k p v) insertView k p x t = -- TODO (jaspervdj): Can be optimized easily case deleteView k t of Nothing -> (Nothing, insert k p x t) Just (p', x', _) -> (Just (p', x'), insert k p x t) -- | /O(min(n,W))/ Delete a key and its priority and value from the queue. If -- the key was present, the associated priority and value are returned in -- addition to the updated queue. {-# INLINABLE deleteView #-} deleteView :: forall k p v. (Hashable k, Ord k, Ord p) => k -> HashPSQ k p v -> Maybe (p, v, HashPSQ k p v) deleteView k (HashPSQ ipsq) = case IntPSQ.alter f (hash k) ipsq of (Nothing, _ ) -> Nothing (Just (p, x), ipsq') -> Just (p, x, HashPSQ ipsq') where f :: Maybe (p, Bucket k p v) -> (Maybe (p, v), Maybe (p, Bucket k p v)) f Nothing = (Nothing, Nothing) f (Just (p, B bk bx opsq)) | k == bk = case OrdPSQ.minView opsq of Nothing -> (Just (p, bx), Nothing) Just (k', p', x', opsq') -> (Just (p, bx), Just (p', B k' x' opsq')) | otherwise = case OrdPSQ.deleteView k opsq of Nothing -> (Nothing, Nothing) Just (p', x', opsq') -> (Just (p', x'), Just (p, B bk bx opsq')) -- | /O(min(n,W))/ Retrieve the binding with the least priority, and the -- rest of the queue stripped of that binding. {-# INLINABLE minView #-} minView :: (Hashable k, Ord k, Ord p) => HashPSQ k p v -> Maybe (k, p, v, HashPSQ k p v) minView (HashPSQ ipsq ) = case IntPSQ.alterMin f ipsq of (Nothing , _ ) -> Nothing (Just (k, p, x), ipsq') -> Just (k, p, x, HashPSQ ipsq') where f Nothing = (Nothing, Nothing) f (Just (h, p, B k x os)) = case OrdPSQ.minView os of Nothing -> (Just (k, p, x), Nothing) Just (k', p', x', os') -> (Just (k, p, x), Just (h, p', B k' x' os')) -------------------------------------------------------------------------------- -- Traversals -------------------------------------------------------------------------------- -- | /O(n)/ Modify every value in the queue. {-# INLINABLE map #-} map :: (k -> p -> v -> w) -> HashPSQ k p v -> HashPSQ k p w map f (HashPSQ ipsq) = HashPSQ (IntPSQ.map (\_ p v -> mapBucket p v) ipsq) where mapBucket p (B k v opsq) = B k (f k p v) (OrdPSQ.map f opsq) -- | /O(n)/ Strict fold over every key, priority and value in the queue. The order -- in which the fold is performed is not specified. {-# INLINABLE fold' #-} fold' :: (k -> p -> v -> a -> a) -> a -> HashPSQ k p v -> a fold' f acc0 (HashPSQ ipsq) = IntPSQ.fold' goBucket acc0 ipsq where goBucket _ p (B k v opsq) acc = let !acc1 = f k p v acc !acc2 = OrdPSQ.fold' f acc1 opsq in acc2 -------------------------------------------------------------------------------- -- Unsafe operations -------------------------------------------------------------------------------- {-# INLINABLE unsafeLookupIncreasePriority #-} unsafeLookupIncreasePriority :: (Hashable k, Ord k, Ord p) => k -> p -> HashPSQ k p v -> (Maybe (p, v), HashPSQ k p v) unsafeLookupIncreasePriority k p (HashPSQ ipsq) = (mbPV, HashPSQ ipsq') where (!mbPV, !ipsq') = IntPSQ.unsafeLookupIncreasePriority (\bp b@(B bk bx opsq) -> if k == bk then let (bp', b') = mkBucket k p bx opsq in (Just (bp, bx), bp', b') -- TODO (jaspervdj): Still a lookup-insert here: 3 traversals? else case OrdPSQ.lookup k opsq of Nothing -> (Nothing, bp, b) Just (p', x) -> let b' = B bk bx (OrdPSQ.insert k p x opsq) in (Just (p', x), bp, b')) (hash k) ipsq {-# INLINABLE unsafeInsertIncreasePriority #-} unsafeInsertIncreasePriority :: (Hashable k, Ord k, Ord p) => k -> p -> v -> HashPSQ k p v -> HashPSQ k p v unsafeInsertIncreasePriority k p x (HashPSQ ipsq) = HashPSQ $ IntPSQ.unsafeInsertWithIncreasePriority (\_ _ bp (B bk bx opsq) -> if k == bk then mkBucket k p x opsq else (bp, B bk bx (OrdPSQ.insert k p x opsq))) (hash k) p (B k x OrdPSQ.empty) ipsq {-# INLINABLE unsafeInsertIncreasePriorityView #-} unsafeInsertIncreasePriorityView :: (Hashable k, Ord k, Ord p) => k -> p -> v -> HashPSQ k p v -> (Maybe (p, v), HashPSQ k p v) unsafeInsertIncreasePriorityView k p x (HashPSQ ipsq) = (mbEvicted, HashPSQ ipsq') where (mbBucket, ipsq') = IntPSQ.unsafeInsertWithIncreasePriorityView (\_ _ bp (B bk bx opsq) -> if k == bk then mkBucket k p x opsq else (bp, B bk bx (OrdPSQ.insert k p x opsq))) (hash k) p (B k x OrdPSQ.empty) ipsq mbEvicted = case mbBucket of Nothing -> Nothing Just (bp, B bk bv opsq) | k == bk -> Just (bp, bv) | otherwise -> OrdPSQ.lookup k opsq -------------------------------------------------------------------------------- -- Validity check -------------------------------------------------------------------------------- -- | /O(n^2)/ Internal function to check if the 'HashPSQ' is valid, i.e. if all -- invariants hold. This should always be the case. valid :: (Hashable k, Ord k, Ord p) => HashPSQ k p v -> Bool valid t@(HashPSQ ipsq) = not (hasDuplicateKeys t) && and [validBucket k p bucket | (k, p, bucket) <- IntPSQ.toList ipsq] hasDuplicateKeys :: (Hashable k, Ord k, Ord p) => HashPSQ k p v -> Bool hasDuplicateKeys = any (> 1) . List.map length . List.group . List.sort . keys validBucket :: (Hashable k, Ord k, Ord p) => Int -> p -> Bucket k p v -> Bool validBucket h p (B k _ opsq) = OrdPSQ.valid opsq && -- Check that the first element of the bucket has lower priority than all -- the other elements. and [(p, k) < (p', k') && hash k' == h | (k', p', _) <- OrdPSQ.toList opsq] psqueues-0.2.2.2/src/Data/IntPSQ/0000755000000000000000000000000012745134107014475 5ustar0000000000000000psqueues-0.2.2.2/src/Data/IntPSQ/Internal.hs0000644000000000000000000005663212745134107016621 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE UnboxedTuples #-} module Data.IntPSQ.Internal ( -- * Type Nat , Key , Mask , IntPSQ (..) -- * Query , null , size , member , lookup , findMin -- * Construction , empty , singleton -- * Insertion , insert -- * Delete/update , delete , deleteMin , alter , alterMin -- * Lists , fromList , toList , keys -- * Views , insertView , deleteView , minView -- * Traversal , map , fold' -- * Unsafe manipulation , unsafeInsertNew , unsafeInsertIncreasePriority , unsafeInsertIncreasePriorityView , unsafeInsertWithIncreasePriority , unsafeInsertWithIncreasePriorityView , unsafeLookupIncreasePriority -- * Testing , valid , hasBadNils , hasDuplicateKeys , hasMinHeapProperty , validMask ) where import Control.Applicative ((<$>), (<*>)) import Control.DeepSeq (NFData (rnf)) import Data.Bits import Data.BitUtil import Data.Foldable (Foldable (foldr)) import Data.List (foldl') import Data.Maybe (isJust) import Data.Word (Word) import qualified Data.List as List import Prelude hiding (filter, foldl, foldr, lookup, map, null) import Data.Traversable -- TODO (SM): get rid of bang patterns {- -- Use macros to define strictness of functions. -- STRICT_x_OF_y denotes an y-ary function strict in the x-th parameter. -- We do not use BangPatterns, because they are not in any standard and we -- want the compilers to be compiled by as many compilers as possible. #define STRICT_1_OF_2(fn) fn arg _ | arg `seq` False = undefined -} ------------------------------------------------------------------------------ -- Types ------------------------------------------------------------------------------ -- A "Nat" is a natural machine word (an unsigned Int) type Nat = Word type Key = Int -- | We store masks as the index of the bit that determines the branching. type Mask = Int -- | A priority search queue with @Int@ keys and priorities of type @p@ and -- values of type @v@. It is strict in keys, priorities and values. data IntPSQ p v = Bin {-# UNPACK #-} !Key !p !v {-# UNPACK #-} !Mask !(IntPSQ p v) !(IntPSQ p v) | Tip {-# UNPACK #-} !Key !p !v | Nil deriving (Foldable, Functor, Show, Traversable) instance (NFData p, NFData v) => NFData (IntPSQ p v) where rnf (Bin _k p v _m l r) = rnf p `seq` rnf v `seq` rnf l `seq` rnf r rnf (Tip _k p v) = rnf p `seq` rnf v rnf Nil = () instance (Ord p, Eq v) => Eq (IntPSQ p v) where x == y = case (minView x, minView y) of (Nothing , Nothing ) -> True (Just (xk, xp, xv, x'), (Just (yk, yp, yv, y'))) -> xk == yk && xp == yp && xv == yv && x' == y' (Just _ , Nothing ) -> False (Nothing , Just _ ) -> False -- bit twiddling ---------------- {-# INLINE natFromInt #-} natFromInt :: Key -> Nat natFromInt = fromIntegral {-# INLINE intFromNat #-} intFromNat :: Nat -> Key intFromNat = fromIntegral {-# INLINE zero #-} zero :: Key -> Mask -> Bool zero i m = (natFromInt i) .&. (natFromInt m) == 0 {-# INLINE nomatch #-} nomatch :: Key -> Key -> Mask -> Bool nomatch k1 k2 m = natFromInt k1 .&. m' /= natFromInt k2 .&. m' where m' = maskW (natFromInt m) {-# INLINE maskW #-} maskW :: Nat -> Nat maskW m = complement (m-1) `xor` m {-# INLINE branchMask #-} branchMask :: Key -> Key -> Mask branchMask k1 k2 = intFromNat (highestBitMask (natFromInt k1 `xor` natFromInt k2)) ------------------------------------------------------------------------------ -- Query ------------------------------------------------------------------------------ -- | /O(1)/ True if the queue is empty. null :: IntPSQ p v -> Bool null Nil = True null _ = False -- | /O(n)/ The number of elements stored in the queue. size :: IntPSQ p v -> Int size Nil = 0 size (Tip _ _ _) = 1 size (Bin _ _ _ _ l r) = 1 + size l + size r -- TODO (SM): benchmark this against a tail-recursive variant -- | /O(min(n,W))/ Check if a key is present in the the queue. member :: Int -> IntPSQ p v -> Bool member k = isJust . lookup k -- | /O(min(n,W))/ The priority and value of a given key, or 'Nothing' if the -- key is not bound. lookup :: Int -> IntPSQ p v -> Maybe (p, v) lookup k = go where go t = case t of Nil -> Nothing Tip k' p' x' | k == k' -> Just (p', x') | otherwise -> Nothing Bin k' p' x' m l r | nomatch k k' m -> Nothing | k == k' -> Just (p', x') | zero k m -> go l | otherwise -> go r -- | /O(1)/ The element with the lowest priority. findMin :: Ord p => IntPSQ p v -> Maybe (Int, p, v) findMin t = case t of Nil -> Nothing Tip k p x -> Just (k, p, x) Bin k p x _ _ _ -> Just (k, p, x) ------------------------------------------------------------------------------ --- Construction ------------------------------------------------------------------------------ -- | /O(1)/ The empty queue. empty :: IntPSQ p v empty = Nil -- | /O(1)/ Build a queue with one element. singleton :: Ord p => Int -> p -> v -> IntPSQ p v singleton = Tip ------------------------------------------------------------------------------ -- Insertion ------------------------------------------------------------------------------ -- | /O(min(n,W))/ Insert a new key, priority and value into the queue. If the key -- is already present in the queue, the associated priority and value are -- replaced with the supplied priority and value. insert :: Ord p => Int -> p -> v -> IntPSQ p v -> IntPSQ p v insert k p x t0 = unsafeInsertNew k p x (delete k t0) -- | Internal function to insert a key that is *not* present in the priority -- queue. {-# INLINABLE unsafeInsertNew #-} unsafeInsertNew :: Ord p => Key -> p -> v -> IntPSQ p v -> IntPSQ p v unsafeInsertNew k p x = go where go t = case t of Nil -> Tip k p x Tip k' p' x' | (p, k) < (p', k') -> link k p x k' t Nil | otherwise -> link k' p' x' k (Tip k p x) Nil Bin k' p' x' m l r | nomatch k k' m -> if (p, k) < (p', k') then link k p x k' t Nil else link k' p' x' k (Tip k p x) (merge m l r) | otherwise -> if (p, k) < (p', k') then if zero k' m then Bin k p x m (unsafeInsertNew k' p' x' l) r else Bin k p x m l (unsafeInsertNew k' p' x' r) else if zero k m then Bin k' p' x' m (unsafeInsertNew k p x l) r else Bin k' p' x' m l (unsafeInsertNew k p x r) -- | Link link :: Key -> p -> v -> Key -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v link k p x k' k't otherTree | zero m k' = Bin k p x m k't otherTree | otherwise = Bin k p x m otherTree k't where m = branchMask k k' ------------------------------------------------------------------------------ -- Delete/Alter ------------------------------------------------------------------------------ -- | /O(min(n,W))/ Delete a key and its priority and value from the queue. When -- the key is not a member of the queue, the original queue is returned. {-# INLINABLE delete #-} delete :: Ord p => Int -> IntPSQ p v -> IntPSQ p v delete k = go where go t = case t of Nil -> Nil Tip k' _ _ | k == k' -> Nil | otherwise -> t Bin k' p' x' m l r | nomatch k k' m -> t | k == k' -> merge m l r | zero k m -> binShrinkL k' p' x' m (go l) r | otherwise -> binShrinkR k' p' x' m l (go r) -- | /O(min(n,W))/ Delete the binding with the least priority, and return the -- rest of the queue stripped of that binding. In case the queue is empty, the -- empty queue is returned again. {-# INLINE deleteMin #-} deleteMin :: Ord p => IntPSQ p v -> IntPSQ p v deleteMin t = case minView t of Nothing -> t Just (_, _, _, t') -> t' -- | /O(min(n,W))/ The expression @alter f k queue@ alters the value @x@ at @k@, -- or absence thereof. 'alter' can be used to insert, delete, or update a value -- in a queue. It also allows you to calculate an additional value @b@. {-# INLINE alter #-} alter :: Ord p => (Maybe (p, v) -> (b, Maybe (p, v))) -> Int -> IntPSQ p v -> (b, IntPSQ p v) alter f = \k t0 -> let (t, mbX) = case deleteView k t0 of Nothing -> (t0, Nothing) Just (p, v, t0') -> (t0', Just (p, v)) in case f mbX of (b, mbX') -> (b, maybe t (\(p, v) -> unsafeInsertNew k p v t) mbX') -- | /O(min(n,W))/ A variant of 'alter' which works on the element with the -- minimum priority. Unlike 'alter', this variant also allows you to change the -- key of the element. {-# INLINE alterMin #-} alterMin :: Ord p => (Maybe (Int, p, v) -> (b, Maybe (Int, p, v))) -> IntPSQ p v -> (b, IntPSQ p v) alterMin f t = case t of Nil -> case f Nothing of (b, Nothing) -> (b, Nil) (b, Just (k', p', x')) -> (b, Tip k' p' x') Tip k p x -> case f (Just (k, p, x)) of (b, Nothing) -> (b, Nil) (b, Just (k', p', x')) -> (b, Tip k' p' x') Bin k p x m l r -> case f (Just (k, p, x)) of (b, Nothing) -> (b, merge m l r) (b, Just (k', p', x')) | k /= k' -> (b, insert k' p' x' (merge m l r)) | p' <= p -> (b, Bin k p' x' m l r) | otherwise -> (b, unsafeInsertNew k p' x' (merge m l r)) -- | Smart constructor for a 'Bin' node whose left subtree could have become -- 'Nil'. {-# INLINE binShrinkL #-} binShrinkL :: Key -> p -> v -> Mask -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v binShrinkL k p x m Nil r = case r of Nil -> Tip k p x; _ -> Bin k p x m Nil r binShrinkL k p x m l r = Bin k p x m l r -- | Smart constructor for a 'Bin' node whose right subtree could have become -- 'Nil'. {-# INLINE binShrinkR #-} binShrinkR :: Key -> p -> v -> Mask -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v binShrinkR k p x m l Nil = case l of Nil -> Tip k p x; _ -> Bin k p x m l Nil binShrinkR k p x m l r = Bin k p x m l r ------------------------------------------------------------------------------ -- Lists ------------------------------------------------------------------------------ -- | /O(n*min(n,W))/ Build a queue from a list of (key, priority, value) tuples. -- If the list contains more than one priority and value for the same key, the -- last priority and value for the key is retained. {-# INLINABLE fromList #-} fromList :: Ord p => [(Int, p, v)] -> IntPSQ p v fromList = foldl' (\im (k, p, x) -> insert k p x im) empty -- | /O(n)/ Convert a queue to a list of (key, priority, value) tuples. The -- order of the list is not specified. toList :: IntPSQ p v -> [(Int, p, v)] toList = go [] where go acc Nil = acc go acc (Tip k' p' x') = (k', p', x') : acc go acc (Bin k' p' x' _m l r) = (k', p', x') : go (go acc r) l -- | /O(n)/ Obtain the list of present keys in the queue. keys :: IntPSQ p v -> [Int] keys t = [k | (k, _, _) <- toList t] -- TODO (jaspervdj): More efficient implementations possible ------------------------------------------------------------------------------ -- Views ------------------------------------------------------------------------------ -- | /O(min(n,W))/ Insert a new key, priority and value into the queue. If the key -- is already present in the queue, then the evicted priority and value can be -- found the first element of the returned tuple. insertView :: Ord p => Int -> p -> v -> IntPSQ p v -> (Maybe (p, v), IntPSQ p v) insertView k p x t0 = case deleteView k t0 of Nothing -> (Nothing, unsafeInsertNew k p x t0) Just (p', v', t) -> (Just (p', v'), unsafeInsertNew k p x t) -- | /O(min(n,W))/ Delete a key and its priority and value from the queue. If -- the key was present, the associated priority and value are returned in -- addition to the updated queue. {-# INLINABLE deleteView #-} deleteView :: Ord p => Int -> IntPSQ p v -> Maybe (p, v, IntPSQ p v) deleteView k t0 = case delFrom t0 of (# _, Nothing #) -> Nothing (# t, Just (p, x) #) -> Just (p, x, t) where delFrom t = case t of Nil -> (# Nil, Nothing #) Tip k' p' x' | k == k' -> (# Nil, Just (p', x') #) | otherwise -> (# t, Nothing #) Bin k' p' x' m l r | nomatch k k' m -> (# t, Nothing #) | k == k' -> let t' = merge m l r in t' `seq` (# t', Just (p', x') #) | zero k m -> case delFrom l of (# l', mbPX #) -> let t' = binShrinkL k' p' x' m l' r in t' `seq` (# t', mbPX #) | otherwise -> case delFrom r of (# r', mbPX #) -> let t' = binShrinkR k' p' x' m l r' in t' `seq` (# t', mbPX #) -- | /O(min(n,W))/ Retrieve the binding with the least priority, and the -- rest of the queue stripped of that binding. {-# INLINE minView #-} minView :: Ord p => IntPSQ p v -> Maybe (Int, p, v, IntPSQ p v) minView t = case t of Nil -> Nothing Tip k p x -> Just (k, p, x, Nil) Bin k p x m l r -> Just (k, p, x, merge m l r) ------------------------------------------------------------------------------ -- Traversal ------------------------------------------------------------------------------ -- | /O(n)/ Modify every value in the queue. {-# INLINABLE map #-} map :: (Int -> p -> v -> w) -> IntPSQ p v -> IntPSQ p w map f = go where go t = case t of Nil -> Nil Tip k p x -> Tip k p (f k p x) Bin k p x m l r -> Bin k p (f k p x) m (go l) (go r) -- | /O(n)/ Strict fold over every key, priority and value in the queue. The order -- in which the fold is performed is not specified. {-# INLINABLE fold' #-} fold' :: (Int -> p -> v -> a -> a) -> a -> IntPSQ p v -> a fold' f = go where go !acc Nil = acc go !acc (Tip k' p' x') = f k' p' x' acc go !acc (Bin k' p' x' _m l r) = let !acc1 = f k' p' x' acc !acc2 = go acc1 l !acc3 = go acc2 r in acc3 -- | Internal function that merges two *disjoint* 'IntPSQ's that share the -- same prefix mask. {-# INLINABLE merge #-} merge :: Ord p => Mask -> IntPSQ p v -> IntPSQ p v -> IntPSQ p v merge m l r = case l of Nil -> r Tip lk lp lx -> case r of Nil -> l Tip rk rp rx | (lp, lk) < (rp, rk) -> Bin lk lp lx m Nil r | otherwise -> Bin rk rp rx m l Nil Bin rk rp rx rm rl rr | (lp, lk) < (rp, rk) -> Bin lk lp lx m Nil r | otherwise -> Bin rk rp rx m l (merge rm rl rr) Bin lk lp lx lm ll lr -> case r of Nil -> l Tip rk rp rx | (lp, lk) < (rp, rk) -> Bin lk lp lx m (merge lm ll lr) r | otherwise -> Bin rk rp rx m l Nil Bin rk rp rx rm rl rr | (lp, lk) < (rp, rk) -> Bin lk lp lx m (merge lm ll lr) r | otherwise -> Bin rk rp rx m l (merge rm rl rr) ------------------------------------------------------------------------------ -- Improved insert performance for special cases ------------------------------------------------------------------------------ -- TODO (SM): Make benchmarks run again, integrate this function with insert -- and test how benchmarks times change. -- | Internal function to insert a key with priority larger than the -- maximal priority in the heap. This is always the case when using the PSQ -- as the basis to implement a LRU cache, which associates a -- access-tick-number with every element. {-# INLINE unsafeInsertIncreasePriority #-} unsafeInsertIncreasePriority :: Ord p => Key -> p -> v -> IntPSQ p v -> IntPSQ p v unsafeInsertIncreasePriority = unsafeInsertWithIncreasePriority (\newP newX _ _ -> (newP, newX)) {-# INLINE unsafeInsertIncreasePriorityView #-} unsafeInsertIncreasePriorityView :: Ord p => Key -> p -> v -> IntPSQ p v -> (Maybe (p, v), IntPSQ p v) unsafeInsertIncreasePriorityView = unsafeInsertWithIncreasePriorityView (\newP newX _ _ -> (newP, newX)) -- | This name is not chosen well anymore. This function: -- -- - Either inserts a value at a new key with a prio higher than the max of the -- entire PSQ. -- - Or, overrides the value at the key with a prio strictly higher than the -- original prio at that key (but not necessarily the max of the entire PSQ). {-# INLINABLE unsafeInsertWithIncreasePriority #-} unsafeInsertWithIncreasePriority :: Ord p => (p -> v -> p -> v -> (p, v)) -> Key -> p -> v -> IntPSQ p v -> IntPSQ p v unsafeInsertWithIncreasePriority f k p x t0 = -- TODO (jaspervdj): Maybe help inliner a bit here, check core. go t0 where go t = case t of Nil -> Tip k p x Tip k' p' x' | k == k' -> case f p x p' x' of (!fp, !fx) -> Tip k fp fx | otherwise -> link k' p' x' k (Tip k p x) Nil Bin k' p' x' m l r | nomatch k k' m -> link k' p' x' k (Tip k p x) (merge m l r) | k == k' -> case f p x p' x' of (!fp, !fx) | zero k m -> merge m (unsafeInsertNew k fp fx l) r | otherwise -> merge m l (unsafeInsertNew k fp fx r) | zero k m -> Bin k' p' x' m (go l) r | otherwise -> Bin k' p' x' m l (go r) {-# INLINABLE unsafeInsertWithIncreasePriorityView #-} unsafeInsertWithIncreasePriorityView :: Ord p => (p -> v -> p -> v -> (p, v)) -> Key -> p -> v -> IntPSQ p v -> (Maybe (p, v), IntPSQ p v) unsafeInsertWithIncreasePriorityView f k p x t0 = -- TODO (jaspervdj): Maybe help inliner a bit here, check core. case go t0 of (# t, mbPX #) -> (mbPX, t) where go t = case t of Nil -> (# Tip k p x, Nothing #) Tip k' p' x' | k == k' -> case f p x p' x' of (!fp, !fx) -> (# Tip k fp fx, Just (p', x') #) | otherwise -> (# link k' p' x' k (Tip k p x) Nil, Nothing #) Bin k' p' x' m l r | nomatch k k' m -> let t' = merge m l r in t' `seq` let t'' = link k' p' x' k (Tip k p x) t' in t'' `seq` (# t'', Nothing #) | k == k' -> case f p x p' x' of (!fp, !fx) | zero k m -> let t' = merge m (unsafeInsertNew k fp fx l) r in t' `seq` (# t', Just (p', x') #) | otherwise -> let t' = merge m l (unsafeInsertNew k fp fx r) in t' `seq` (# t', Just (p', x') #) | zero k m -> case go l of (# l', mbPX #) -> l' `seq` (# Bin k' p' x' m l' r, mbPX #) | otherwise -> case go r of (# r', mbPX #) -> r' `seq` (# Bin k' p' x' m l r', mbPX #) -- | This can NOT be used to delete elements. {-# INLINABLE unsafeLookupIncreasePriority #-} unsafeLookupIncreasePriority :: Ord p => (p -> v -> (Maybe b, p, v)) -> Key -> IntPSQ p v -> (Maybe b, IntPSQ p v) unsafeLookupIncreasePriority f k t0 = -- TODO (jaspervdj): Maybe help inliner a bit here, check core. case go t0 of (# t, mbB #) -> (mbB, t) where go t = case t of Nil -> (# Nil, Nothing #) Tip k' p' x' | k == k' -> case f p' x' of (!fb, !fp, !fx) -> (# Tip k fp fx, fb #) | otherwise -> (# t, Nothing #) Bin k' p' x' m l r | nomatch k k' m -> (# t, Nothing #) | k == k' -> case f p' x' of (!fb, !fp, !fx) | zero k m -> let t' = merge m (unsafeInsertNew k fp fx l) r in t' `seq` (# t', fb #) | otherwise -> let t' = merge m l (unsafeInsertNew k fp fx r) in t' `seq` (# t', fb #) | zero k m -> case go l of (# l', mbB #) -> l' `seq` (# Bin k' p' x' m l' r, mbB #) | otherwise -> case go r of (# r', mbB #) -> r' `seq` (# Bin k' p' x' m l r', mbB #) ------------------------------------------------------------------------------ -- Validity checks for the datastructure invariants ------------------------------------------------------------------------------ -- | /O(n^2)/ Internal function to check if the 'IntPSQ' is valid, i.e. if all -- invariants hold. This should always be the case. valid :: Ord p => IntPSQ p v -> Bool valid psq = not (hasBadNils psq) && not (hasDuplicateKeys psq) && hasMinHeapProperty psq && validMask psq hasBadNils :: IntPSQ p v -> Bool hasBadNils psq = case psq of Nil -> False Tip _ _ _ -> False Bin _ _ _ _ Nil Nil -> True Bin _ _ _ _ l r -> hasBadNils l || hasBadNils r hasDuplicateKeys :: IntPSQ p v -> Bool hasDuplicateKeys psq = any ((> 1) . length) (List.group . List.sort $ collectKeys [] psq) where collectKeys :: [Int] -> IntPSQ p v -> [Int] collectKeys ks Nil = ks collectKeys ks (Tip k _ _) = k : ks collectKeys ks (Bin k _ _ _ l r) = let ks' = collectKeys (k : ks) l in collectKeys ks' r hasMinHeapProperty :: Ord p => IntPSQ p v -> Bool hasMinHeapProperty psq = case psq of Nil -> True Tip _ _ _ -> True Bin _ p _ _ l r -> go p l && go p r where go :: Ord p => p -> IntPSQ p v -> Bool go _ Nil = True go parentPrio (Tip _ prio _) = parentPrio <= prio go parentPrio (Bin _ prio _ _ l r) = parentPrio <= prio && go prio l && go prio r data Side = L | R validMask :: IntPSQ p v -> Bool validMask Nil = True validMask (Tip _ _ _) = True validMask (Bin _ _ _ m left right ) = maskOk m left right && go m L left && go m R right where go :: Mask -> Side -> IntPSQ p v -> Bool go parentMask side psq = case psq of Nil -> True Tip k _ _ -> checkMaskAndSideMatchKey parentMask side k Bin k _ _ mask l r -> checkMaskAndSideMatchKey parentMask side k && maskOk mask l r && go mask L l && go mask R r checkMaskAndSideMatchKey parentMask side key = case side of L -> parentMask .&. key == 0 R -> parentMask .&. key == parentMask maskOk :: Mask -> IntPSQ p v -> IntPSQ p v -> Bool maskOk mask l r = case xor <$> childKey l <*> childKey r of Nothing -> True Just xoredKeys -> fromIntegral mask == highestBitMask (fromIntegral xoredKeys) childKey Nil = Nothing childKey (Tip k _ _) = Just k childKey (Bin k _ _ _ _ _) = Just k psqueues-0.2.2.2/src/Data/OrdPSQ/0000755000000000000000000000000012745134107014467 5ustar0000000000000000psqueues-0.2.2.2/src/Data/OrdPSQ/Internal.hs0000644000000000000000000005737212745134107016615 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} module Data.OrdPSQ.Internal ( -- * Type OrdPSQ (..) , LTree (..) , Elem (..) -- * Query , null , size , member , lookup , findMin -- * Construction , empty , singleton -- * Insertion , insert -- * Delete/Update , delete , deleteMin , alter , alterMin -- * Conversion , fromList , toList , toAscList , keys -- * Views , insertView , deleteView , minView -- * Traversals , map , fold' -- * Tournament view , TourView (..) , tourView , play -- * Balancing internals , left , right , maxKey , lsingleLeft , rsingleLeft , lsingleRight , rsingleRight , ldoubleLeft , rdoubleLeft , ldoubleRight , rdoubleRight -- * Validity check , valid ) where import Control.DeepSeq (NFData (rnf)) import Data.Foldable (Foldable (foldr)) import qualified Data.List as List import Data.Maybe (isJust) import Prelude hiding (foldr, lookup, map, null) import Data.Traversable -------------------------------------------------------------------------------- -- Types -------------------------------------------------------------------------------- -- | @E k p v@ binds the key @k@ to the value @v@ with priority @p@. data Elem k p v = E !k !p !v deriving (Foldable, Functor, Show, Traversable) instance (NFData k, NFData p, NFData v) => NFData (Elem k p v) where rnf (E k p v) = rnf k `seq` rnf p `seq` rnf v -- | A mapping from keys @k@ to priorites @p@ and values @v@. It is strict in -- keys, priorities and values. data OrdPSQ k p v = Void | Winner !(Elem k p v) !(LTree k p v) !k deriving (Foldable, Functor, Show, Traversable) instance (NFData k, NFData p, NFData v) => NFData (OrdPSQ k p v) where rnf Void = () rnf (Winner e t m) = rnf e `seq` rnf m `seq` rnf t instance (Ord k, Ord p, Eq v) => Eq (OrdPSQ k p v) where x == y = case (minView x, minView y) of (Nothing , Nothing ) -> True (Just (xk, xp, xv, x'), (Just (yk, yp, yv, y'))) -> xk == yk && xp == yp && xv == yv && x' == y' (Just _ , Nothing ) -> False (Nothing , Just _ ) -> False type Size = Int data LTree k p v = Start | LLoser {-# UNPACK #-} !Size {-# UNPACK #-} !(Elem k p v) !(LTree k p v) !k -- split key !(LTree k p v) | RLoser {-# UNPACK #-} !Size {-# UNPACK #-} !(Elem k p v) !(LTree k p v) !k -- split key !(LTree k p v) deriving (Foldable, Functor, Show, Traversable) instance (NFData k, NFData p, NFData v) => NFData (LTree k p v) where rnf Start = () rnf (LLoser _ e l k r) = rnf e `seq` rnf l `seq` rnf k `seq` rnf r rnf (RLoser _ e l k r) = rnf e `seq` rnf l `seq` rnf k `seq` rnf r -------------------------------------------------------------------------------- -- Query -------------------------------------------------------------------------------- -- | /O(1)/ True if the queue is empty. null :: OrdPSQ k p v -> Bool null Void = True null (Winner _ _ _) = False -- | /O(1)/ The number of elements in a queue. size :: OrdPSQ k p v -> Int size Void = 0 size (Winner _ lt _) = 1 + size' lt -- | /O(log n)/ Check if a key is present in the the queue. member :: Ord k => k -> OrdPSQ k p v -> Bool member k = isJust . lookup k -- | /O(log n)/ The priority and value of a given key, or 'Nothing' if the key -- is not bound. lookup :: (Ord k) => k -> OrdPSQ k p v -> Maybe (p, v) lookup k = go where go t = case tourView t of Null -> Nothing Single (E k' p v) | k == k' -> Just (p, v) | otherwise -> Nothing Play tl tr | k <= maxKey tl -> go tl | otherwise -> go tr -- | /O(1)/ The element with the lowest priority. findMin :: OrdPSQ k p v -> Maybe (k, p, v) findMin Void = Nothing findMin (Winner (E k p v) _ _) = Just (k, p, v) -------------------------------------------------------------------------------- -- Construction -------------------------------------------------------------------------------- -- | /O(1)/ The empty queue. empty :: OrdPSQ k p v empty = Void -- | /O(1)/ Build a queue with one element. singleton :: k -> p -> v -> OrdPSQ k p v singleton k p v = Winner (E k p v) Start k -------------------------------------------------------------------------------- -- Insertion -------------------------------------------------------------------------------- -- | /O(log n)/ Insert a new key, priority and value into the queue. If the key is -- already present in the queue, the associated priority and value are replaced -- with the supplied priority and value. {-# INLINABLE insert #-} insert :: (Ord k, Ord p) => k -> p -> v -> OrdPSQ k p v -> OrdPSQ k p v insert k p v = go where go t = case t of Void -> singleton k p v Winner (E k' p' v') Start _ -> case compare k k' of LT -> singleton k p v `play` singleton k' p' v' EQ -> singleton k p v GT -> singleton k' p' v' `play` singleton k p v Winner e (RLoser _ e' tl m tr) m' | k <= m -> go (Winner e tl m) `play` (Winner e' tr m') | otherwise -> (Winner e tl m) `play` go (Winner e' tr m') Winner e (LLoser _ e' tl m tr) m' | k <= m -> go (Winner e' tl m) `play` (Winner e tr m') | otherwise -> (Winner e' tl m) `play` go (Winner e tr m') -------------------------------------------------------------------------------- -- Delete/update -------------------------------------------------------------------------------- -- | /O(log n)/ Delete a key and its priority and value from the queue. When the -- key is not a member of the queue, the original queue is returned. {-# INLINABLE delete #-} delete :: (Ord k, Ord p) => k -> OrdPSQ k p v -> OrdPSQ k p v delete k = go where go t = case t of Void -> empty Winner (E k' p v) Start _ | k == k' -> empty | otherwise -> singleton k' p v Winner e (RLoser _ e' tl m tr) m' | k <= m -> go (Winner e tl m) `play` (Winner e' tr m') | otherwise -> (Winner e tl m) `play` go (Winner e' tr m') Winner e (LLoser _ e' tl m tr) m' | k <= m -> go (Winner e' tl m) `play` (Winner e tr m') | otherwise -> (Winner e' tl m) `play` go (Winner e tr m') -- | /O(log n)/ Delete the binding with the least priority, and return the -- rest of the queue stripped of that binding. In case the queue is empty, the -- empty queue is returned again. {-# INLINE deleteMin #-} deleteMin :: (Ord k, Ord p) => OrdPSQ k p v -> OrdPSQ k p v deleteMin t = case minView t of Nothing -> t Just (_, _, _, t') -> t' -- | /O(log n)/ The expression @alter f k queue@ alters the value @x@ at @k@, or -- absence thereof. 'alter' can be used to insert, delete, or update a value -- in a queue. It also allows you to calculate an additional value @b@. {-# INLINE alter #-} alter :: (Ord k, Ord p) => (Maybe (p, v) -> (b, Maybe (p, v))) -> k -> OrdPSQ k p v -> (b, OrdPSQ k p v) alter f k psq0 = let (psq1, mbPV) = case deleteView k psq0 of Nothing -> (psq0, Nothing) Just (p, v, psq) -> (psq, Just (p, v)) (!b, mbPV') = f mbPV in case mbPV' of Nothing -> (b, psq1) Just (p, v) -> (b, insert k p v psq1) -- | /O(log n)/ A variant of 'alter' which works on the element with the minimum -- priority. Unlike 'alter', this variant also allows you to change the key of -- the element. {-# INLINE alterMin #-} alterMin :: (Ord k, Ord p) => (Maybe (k, p, v) -> (b, Maybe (k, p, v))) -> OrdPSQ k p v -> (b, OrdPSQ k p v) alterMin f psq0 = case minView psq0 of Nothing -> let (!b, mbKPV) = f Nothing in (b, insertMay mbKPV psq0) Just (k,p,v, psq1) -> let (!b, mbKPV) = f $ Just (k, p, v) in (b, insertMay mbKPV psq1) where insertMay Nothing psq = psq insertMay (Just (k, p, v)) psq = insert k p v psq -------------------------------------------------------------------------------- -- Conversion -------------------------------------------------------------------------------- -- | /O(n*log n)/ Build a queue from a list of (key, priority, value) tuples. -- If the list contains more than one priority and value for the same key, the -- last priority and value for the key is retained. {-# INLINABLE fromList #-} fromList :: (Ord k, Ord p) => [(k, p, v)] -> OrdPSQ k p v fromList = foldr (\(k, p, v) q -> insert k p v q) empty -- | /O(n)/ Convert a queue to a list of (key, priority, value) tuples. The -- order of the list is not specified. toList :: OrdPSQ k p v -> [(k, p, v)] toList = toAscList -- | /O(n)/ Obtain the list of present keys in the queue. keys :: OrdPSQ k p v -> [k] keys t = [k | (k, _, _) <- toList t] -- TODO (jaspervdj): There must be faster implementations. -- | /O(n)/ Convert to an ascending list. toAscList :: OrdPSQ k p v -> [(k, p, v)] toAscList q = seqToList (toAscLists q) where toAscLists :: OrdPSQ k p v -> Sequ (k, p, v) toAscLists t = case tourView t of Null -> emptySequ Single (E k p v) -> singleSequ (k, p, v) Play tl tr -> toAscLists tl <> toAscLists tr -------------------------------------------------------------------------------- -- Views -------------------------------------------------------------------------------- -- | /O(log n)/ Insert a new key, priority and value into the queue. If the key is -- already present in the queue, then the evicted priority and value can be -- found the first element of the returned tuple. {-# INLINABLE insertView #-} insertView :: (Ord k, Ord p) => k -> p -> v -> OrdPSQ k p v -> (Maybe (p, v), OrdPSQ k p v) insertView k p x t = case deleteView k t of Nothing -> (Nothing, insert k p x t) Just (p', x', _) -> (Just (p', x'), insert k p x t) -- | /O(log n)/ Delete a key and its priority and value from the queue. If the -- key was present, the associated priority and value are returned in addition -- to the updated queue. {-# INLINABLE deleteView #-} deleteView :: (Ord k, Ord p) => k -> OrdPSQ k p v -> Maybe (p, v, OrdPSQ k p v) deleteView k psq = case psq of Void -> Nothing Winner (E k' p v) Start _ | k == k' -> Just (p, v, empty) | otherwise -> Nothing Winner e (RLoser _ e' tl m tr) m' | k <= m -> fmap (\(p,v,q) -> (p, v, q `play` (Winner e' tr m'))) (deleteView k (Winner e tl m)) | otherwise -> fmap (\(p,v,q) -> (p, v, (Winner e tl m) `play` q )) (deleteView k (Winner e' tr m')) Winner e (LLoser _ e' tl m tr) m' | k <= m -> fmap (\(p,v,q) -> (p, v, q `play` (Winner e tr m'))) (deleteView k (Winner e' tl m)) | otherwise -> fmap (\(p,v,q) -> (p, v, (Winner e' tl m) `play` q )) (deleteView k (Winner e tr m')) -- | /O(log n)/ Retrieve the binding with the least priority, and the -- rest of the queue stripped of that binding. {-# INLINABLE minView #-} minView :: (Ord k, Ord p) => OrdPSQ k p v -> Maybe (k, p, v, OrdPSQ k p v) minView Void = Nothing minView (Winner (E k p v) t m) = Just (k, p, v, secondBest t m) secondBest :: (Ord k, Ord p) => LTree k p v -> k -> OrdPSQ k p v secondBest Start _ = Void secondBest (LLoser _ e tl m tr) m' = Winner e tl m `play` secondBest tr m' secondBest (RLoser _ e tl m tr) m' = secondBest tl m `play` Winner e tr m' -------------------------------------------------------------------------------- -- Traversals -------------------------------------------------------------------------------- -- | /O(n)/ Modify every value in the queue. {-# INLINABLE map #-} map :: forall k p v w. (k -> p -> v -> w) -> OrdPSQ k p v -> OrdPSQ k p w map f = goPSQ where goPSQ :: OrdPSQ k p v -> OrdPSQ k p w goPSQ Void = Void goPSQ (Winner e l k) = Winner (goElem e) (goLTree l) k goElem :: Elem k p v -> Elem k p w goElem (E k p x) = E k p (f k p x) goLTree :: LTree k p v -> LTree k p w goLTree Start = Start goLTree (LLoser s e l k r) = LLoser s (goElem e) (goLTree l) k (goLTree r) goLTree (RLoser s e l k r) = RLoser s (goElem e) (goLTree l) k (goLTree r) -- | /O(n)/ Strict fold over every key, priority and value in the queue. The order -- in which the fold is performed is not specified. {-# INLINE fold' #-} fold' :: (k -> p -> v -> a -> a) -> a -> OrdPSQ k p v -> a fold' f = \acc0 psq -> case psq of Void -> acc0 (Winner (E k p v) t _) -> let !acc1 = f k p v acc0 in go acc1 t where go !acc Start = acc go !acc (LLoser _ (E k p v) lt _ rt) = go (f k p v (go acc lt)) rt go !acc (RLoser _ (E k p v) lt _ rt) = go (f k p v (go acc lt)) rt -------------------------------------------------------------------------------- -- Tournament view -------------------------------------------------------------------------------- data TourView k p v = Null | Single {-# UNPACK #-} !(Elem k p v) | Play (OrdPSQ k p v) (OrdPSQ k p v) tourView :: OrdPSQ k p v -> TourView k p v tourView Void = Null tourView (Winner e Start _) = Single e tourView (Winner e (RLoser _ e' tl m tr) m') = Winner e tl m `Play` Winner e' tr m' tourView (Winner e (LLoser _ e' tl m tr) m') = Winner e' tl m `Play` Winner e tr m' -- | Take two pennants and returns a new pennant that is the union of -- the two with the precondition that the keys in the first tree are -- strictly smaller than the keys in the second tree. {-# INLINABLE play #-} play :: (Ord p, Ord k) => OrdPSQ k p v -> OrdPSQ k p v -> OrdPSQ k p v Void `play` t' = t' t `play` Void = t Winner e@(E k p v) t m `play` Winner e'@(E k' p' v') t' m' | (p, k) `beats` (p', k') = Winner e (rbalance k' p' v' t m t') m' | otherwise = Winner e' (lbalance k p v t m t') m' -- | When priorities are equal, the tree with the lowest key wins. This is -- important to have a deterministic `==`, which requires on `minView` pulling -- out the elements in the right order. beats :: (Ord p, Ord k) => (p, k) -> (p, k) -> Bool beats (p, !k) (p', !k') = p < p' || (p == p' && k < k') {-# INLINE beats #-} -------------------------------------------------------------------------------- -- Balancing internals -------------------------------------------------------------------------------- -- | Balance factor omega :: Int omega = 4 -- Has to be greater than 3.75 because Hinze's paper said so. size' :: LTree k p v -> Size size' Start = 0 size' (LLoser s _ _ _ _) = s size' (RLoser s _ _ _ _) = s left, right :: LTree k p v -> LTree k p v left Start = moduleError "left" "empty loser tree" left (LLoser _ _ tl _ _ ) = tl left (RLoser _ _ tl _ _ ) = tl right Start = moduleError "right" "empty loser tree" right (LLoser _ _ _ _ tr) = tr right (RLoser _ _ _ _ tr) = tr maxKey :: OrdPSQ k p v -> k maxKey Void = moduleError "maxKey" "empty queue" maxKey (Winner _ _ m) = m lloser, rloser :: k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v lloser k p v tl m tr = LLoser (1 + size' tl + size' tr) (E k p v) tl m tr rloser k p v tl m tr = RLoser (1 + size' tl + size' tr) (E k p v) tl m tr lbalance, rbalance :: (Ord k, Ord p) => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v lbalance k p v l m r | size' l + size' r < 2 = lloser k p v l m r | size' r > omega * size' l = lbalanceLeft k p v l m r | size' l > omega * size' r = lbalanceRight k p v l m r | otherwise = lloser k p v l m r rbalance k p v l m r | size' l + size' r < 2 = rloser k p v l m r | size' r > omega * size' l = rbalanceLeft k p v l m r | size' l > omega * size' r = rbalanceRight k p v l m r | otherwise = rloser k p v l m r lbalanceLeft :: (Ord k, Ord p) => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v lbalanceLeft k p v l m r | size' (left r) < size' (right r) = lsingleLeft k p v l m r | otherwise = ldoubleLeft k p v l m r lbalanceRight :: (Ord k, Ord p) => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v lbalanceRight k p v l m r | size' (left l) > size' (right l) = lsingleRight k p v l m r | otherwise = ldoubleRight k p v l m r rbalanceLeft :: (Ord k, Ord p) => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v rbalanceLeft k p v l m r | size' (left r) < size' (right r) = rsingleLeft k p v l m r | otherwise = rdoubleLeft k p v l m r rbalanceRight :: (Ord k, Ord p) => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v rbalanceRight k p v l m r | size' (left l) > size' (right l) = rsingleRight k p v l m r | otherwise = rdoubleRight k p v l m r lsingleLeft :: (Ord k, Ord p) => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v lsingleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) | (p1, k1) `beats` (p2, k2) = lloser k1 p1 v1 (rloser k2 p2 v2 t1 m1 t2) m2 t3 | otherwise = lloser k2 p2 v2 (lloser k1 p1 v1 t1 m1 t2) m2 t3 lsingleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) = rloser k2 p2 v2 (lloser k1 p1 v1 t1 m1 t2) m2 t3 lsingleLeft _ _ _ _ _ _ = moduleError "lsingleLeft" "malformed tree" rsingleLeft :: k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v rsingleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) = rloser k1 p1 v1 (rloser k2 p2 v2 t1 m1 t2) m2 t3 rsingleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) = rloser k2 p2 v2 (rloser k1 p1 v1 t1 m1 t2) m2 t3 rsingleLeft _ _ _ _ _ _ = moduleError "rsingleLeft" "malformed tree" lsingleRight :: k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v lsingleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = lloser k2 p2 v2 t1 m1 (lloser k1 p1 v1 t2 m2 t3) lsingleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = lloser k1 p1 v1 t1 m1 (lloser k2 p2 v2 t2 m2 t3) lsingleRight _ _ _ _ _ _ = moduleError "lsingleRight" "malformed tree" rsingleRight :: (Ord k, Ord p) => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v rsingleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = lloser k2 p2 v2 t1 m1 (rloser k1 p1 v1 t2 m2 t3) rsingleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 | (p1, k1) `beats` (p2, k2) = rloser k1 p1 v1 t1 m1 (lloser k2 p2 v2 t2 m2 t3) | otherwise = rloser k2 p2 v2 t1 m1 (rloser k1 p1 v1 t2 m2 t3) rsingleRight _ _ _ _ _ _ = moduleError "rsingleRight" "malformed tree" ldoubleLeft :: (Ord k, Ord p) => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v ldoubleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) = lsingleLeft k1 p1 v1 t1 m1 (lsingleRight k2 p2 v2 t2 m2 t3) ldoubleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) = lsingleLeft k1 p1 v1 t1 m1 (rsingleRight k2 p2 v2 t2 m2 t3) ldoubleLeft _ _ _ _ _ _ = moduleError "ldoubleLeft" "malformed tree" ldoubleRight :: (Ord k, Ord p) => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v ldoubleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = lsingleRight k1 p1 v1 (lsingleLeft k2 p2 v2 t1 m1 t2) m2 t3 ldoubleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = lsingleRight k1 p1 v1 (rsingleLeft k2 p2 v2 t1 m1 t2) m2 t3 ldoubleRight _ _ _ _ _ _ = moduleError "ldoubleRight" "malformed tree" rdoubleLeft :: (Ord k, Ord p) => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v rdoubleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) = rsingleLeft k1 p1 v1 t1 m1 (lsingleRight k2 p2 v2 t2 m2 t3) rdoubleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) = rsingleLeft k1 p1 v1 t1 m1 (rsingleRight k2 p2 v2 t2 m2 t3) rdoubleLeft _ _ _ _ _ _ = moduleError "rdoubleLeft" "malformed tree" rdoubleRight :: (Ord k, Ord p) => k -> p -> v -> LTree k p v -> k -> LTree k p v -> LTree k p v rdoubleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = rsingleRight k1 p1 v1 (lsingleLeft k2 p2 v2 t1 m1 t2) m2 t3 rdoubleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = rsingleRight k1 p1 v1 (rsingleLeft k2 p2 v2 t1 m1 t2) m2 t3 rdoubleRight _ _ _ _ _ _ = moduleError "rdoubleRight" "malformed tree" -------------------------------------------------------------------------------- -- Validity check -------------------------------------------------------------------------------- -- | /O(n^2)/ Internal function to check if the 'OrdPSQ' is valid, i.e. if all -- invariants hold. This should always be the case. valid :: (Ord k, Ord p) => OrdPSQ k p v -> Bool valid t = not (hasDuplicateKeys t) && hasMinHeapProperty t && hasBinarySearchTreeProperty t && hasCorrectSizeAnnotations t hasDuplicateKeys :: Ord k => OrdPSQ k p v -> Bool hasDuplicateKeys = any (> 1) . List.map length . List.group . List.sort . keys hasMinHeapProperty :: forall k p v. (Ord k, Ord p) => OrdPSQ k p v -> Bool hasMinHeapProperty Void = True hasMinHeapProperty (Winner (E k0 p0 _) t0 _) = go k0 p0 t0 where go :: k -> p -> LTree k p v -> Bool go _ _ Start = True go k p (LLoser _ (E k' p' _) l _ r) = (p, k) < (p', k') && go k' p' l && go k p r go k p (RLoser _ (E k' p' _) l _ r) = (p, k) < (p', k') && go k p l && go k' p' r hasBinarySearchTreeProperty :: forall k p v. (Ord k, Ord p) => OrdPSQ k p v -> Bool hasBinarySearchTreeProperty t = case tourView t of Null -> True Single _ -> True Play l r -> all (<= k) (keys l) && all (>= k) (keys r) && hasBinarySearchTreeProperty l && hasBinarySearchTreeProperty r where k = maxKey l hasCorrectSizeAnnotations :: OrdPSQ k p v -> Bool hasCorrectSizeAnnotations Void = True hasCorrectSizeAnnotations (Winner _ t0 _) = go t0 where go :: LTree k p v -> Bool go t@Start = calculateSize t == 0 go t@(LLoser s _ l _ r) = calculateSize t == s && go l && go r go t@(RLoser s _ l _ r) = calculateSize t == s && go l && go r calculateSize :: LTree k p v -> Int calculateSize Start = 0 calculateSize (LLoser _ _ l _ r) = 1 + calculateSize l + calculateSize r calculateSize (RLoser _ _ l _ r) = 1 + calculateSize l + calculateSize r -------------------------------------------------------------------------------- -- Utility functions -------------------------------------------------------------------------------- moduleError :: String -> String -> a moduleError fun msg = error ("Data.OrdPSQ.Internal." ++ fun ++ ':' : ' ' : msg) {-# NOINLINE moduleError #-} -- | Hughes's efficient sequence type newtype Sequ a = Sequ ([a] -> [a]) emptySequ :: Sequ a emptySequ = Sequ (\as -> as) singleSequ :: a -> Sequ a singleSequ a = Sequ (\as -> a : as) (<>) :: Sequ a -> Sequ a -> Sequ a Sequ x1 <> Sequ x2 = Sequ (\as -> x1 (x2 as)) infixr 5 <> seqToList :: Sequ a -> [a] seqToList (Sequ x) = x []