diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +The 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Main.hs @@ -0,0 +1,53 @@ +{-# 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 + ] diff --git a/psqueues.cabal b/psqueues.cabal new file mode 100644 --- /dev/null +++ b/psqueues.cabal @@ -0,0 +1,110 @@ +name: psqueues +version: 0.1.0.0 +license: BSD3 +license-file: LICENSE +maintainer: haskell@better.com +bug-reports: https://github.com/bttr/psqueues/issues +synopsis: Pure priority search queues +category: Data Structures +description: + A priority search queue manages a set of triples of the form + @(key, priority, value)@ and allows for efficient lookup by key, and + efficient lookup and removal of the element with minimal priority. This + package contains three, performant implementations of priority search + queues, which differ in the requirements on the type of keys. + . + * 'IntPSQ's are the most efficient structure, but require the keys to be + of type 'Int'. + . + * 'OrdPSQ's just require the key to implement the `Ord` typeclass, but are + the slowest structures of the three. + . + * 'HashPSQ's require the key to implement both the 'Ord' and 'Hashable' + typeclasses. They use an 'IntMap' over the hash of the keys combined + with a 'OrdPSQ' to manage collisions. Except for keys with a very fast + comparison and small smaps 'HashPSQ's are faster than 'OrdPSQ's. + . + Typical use cases for priority search queues are LRU caches, where the + priority is the time of the last access, and timeout management, where the + priority is the time at which the timeout should trigger. +build-type: Simple +cabal-version: >=1.8 +extra-source-files: + +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.4 + , 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 + 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.3 + , QuickCheck >= 2.7 && < 2.8 + , 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 diff --git a/src/Data/BitUtil.hs b/src/Data/BitUtil.hs new file mode 100644 --- /dev/null +++ b/src/Data/BitUtil.hs @@ -0,0 +1,66 @@ +{-# 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 #-} diff --git a/src/Data/HashPSQ.hs b/src/Data/HashPSQ.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashPSQ.hs @@ -0,0 +1,50 @@ +-- | 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 + , 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 diff --git a/src/Data/HashPSQ/Internal.hs b/src/Data/HashPSQ/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashPSQ/Internal.hs @@ -0,0 +1,445 @@ +{-# LANGUAGE BangPatterns #-} +{-# 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 + , 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 Data.Maybe (isJust) +import Prelude hiding (foldr, lookup, map, null) +import qualified Data.List as List + +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 (Show) + +-- | 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 (NFData, Show) + +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 + +instance Foldable (HashPSQ k p) where + foldr f z0 (HashPSQ ipsq) = + foldr f' z0 ipsq + where + f' (B _ x opsq) z = f x (foldr f z opsq) + +instance Functor (HashPSQ k p) where + fmap f = map (\_ _ v -> f v) + + +------------------------------------------------------------------------------ +-- 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 :: (Hashable k, Ord p) => 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 in 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))/ The expression @alter f k map@ 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 in 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 queueu. +{-# 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 map. 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 'OrdPSQ' 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] diff --git a/src/Data/IntPSQ.hs b/src/Data/IntPSQ.hs new file mode 100644 --- /dev/null +++ b/src/Data/IntPSQ.hs @@ -0,0 +1,53 @@ +-- | '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 + , 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 diff --git a/src/Data/IntPSQ/Internal.hs b/src/Data/IntPSQ/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/IntPSQ/Internal.hs @@ -0,0 +1,696 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# 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 + , 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.DeepSeq (NFData(rnf)) +import Control.Applicative ((<$>), (<*>)) + +import Data.BitUtil +import Data.Bits +import Data.List (foldl') +import Data.Maybe (isJust) +import Data.Word (Word) +import Data.Foldable (Foldable (foldr)) + +import qualified Data.List as List + +import Prelude hiding (lookup, map, filter, foldr, foldl, null) + +-- 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 (Show) + +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 + +instance Foldable (IntPSQ p) where + foldr _ z Nil = z + foldr f z (Tip _ _ v) = f v z + foldr f z (Bin _ _ v _ l r) = f v z'' + where + z' = foldr f z l + z'' = foldr f z' r + +instance Functor (IntPSQ p) where + fmap f = map (\_ _ v -> f v) + + +-- 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 PSQ. +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 in 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))/ The expression @alter f k map@ 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 in 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 queueu. +{-# 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 map. 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 'OrdPSQ' 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 diff --git a/src/Data/OrdPSQ.hs b/src/Data/OrdPSQ.hs new file mode 100644 --- /dev/null +++ b/src/Data/OrdPSQ.hs @@ -0,0 +1,61 @@ +-- | 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 + , 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 diff --git a/src/Data/OrdPSQ/Internal.hs b/src/Data/OrdPSQ/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/OrdPSQ/Internal.hs @@ -0,0 +1,652 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE BangPatterns #-} +module Data.OrdPSQ.Internal + ( -- * Type + OrdPSQ (..) + , LTree (..) + , Elem (..) + + -- * Query + , null + , size + , member + , lookup + , findMin + + -- * Construction + , empty + , singleton + + -- * Insertion + , insert + + -- * Delete/Update + , delete + , 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 Prelude hiding (map, lookup, null, foldr) +import Control.DeepSeq (NFData(rnf)) +import Data.Maybe (isJust) +import Data.Foldable (Foldable (foldr)) +import qualified Data.List as List + +-------------------------------------------------------------------------------- +-- 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 (Show) + +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 (Show) + +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 + +instance Foldable (OrdPSQ k p) where + foldr _ z Void = z + foldr f z (Winner (E _ _ x) l _) = f x (foldr f z l) + +instance Functor (OrdPSQ k p) where + fmap f = map (\_ _ v -> f v) + +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 (Show) + +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 + +instance Foldable (LTree k p) where + foldr _ z Start = z + foldr f z (LLoser _ (E _ _ x) l _ r) = f x (foldr f (foldr f z r) l) + foldr f z (RLoser _ (E _ _ x) l _ r) = f x (foldr f (foldr f z r) l) + + +-------------------------------------------------------------------------------- +-- 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 :: (Ord p) => 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 in 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)/ The expression @alter f k map@ 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 in 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 queueu. +{-# 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 map. 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 [] diff --git a/tests/Data/HashPSQ/Tests.hs b/tests/Data/HashPSQ/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Data/HashPSQ/Tests.hs @@ -0,0 +1,91 @@ +module 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 diff --git a/tests/Data/IntPSQ/Tests.hs b/tests/Data/IntPSQ/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Data/IntPSQ/Tests.hs @@ -0,0 +1,116 @@ +module 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 diff --git a/tests/Data/OrdPSQ/Tests.hs b/tests/Data/OrdPSQ/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Data/OrdPSQ/Tests.hs @@ -0,0 +1,89 @@ +module 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 diff --git a/tests/Data/PSQ/Class.hs b/tests/Data/PSQ/Class.hs new file mode 100644 --- /dev/null +++ b/tests/Data/PSQ/Class.hs @@ -0,0 +1,149 @@ +-- | 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 + 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 + 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 + 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 + 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 diff --git a/tests/Data/PSQ/Class/Gen.hs b/tests/Data/PSQ/Class/Gen.hs new file mode 100644 --- /dev/null +++ b/tests/Data/PSQ/Class/Gen.hs @@ -0,0 +1,75 @@ +-- | 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 diff --git a/tests/Data/PSQ/Class/Tests.hs b/tests/Data/PSQ/Class/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Data/PSQ/Class/Tests.hs @@ -0,0 +1,425 @@ +{-# 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 "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_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 diff --git a/tests/Data/PSQ/Class/Util.hs b/tests/Data/PSQ/Class/Util.hs new file mode 100644 --- /dev/null +++ b/tests/Data/PSQ/Class/Util.hs @@ -0,0 +1,80 @@ +-- | 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) diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,31 @@ +import 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]) + ]