diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -1,33 +1,103 @@ -import Criterion.Main - -import Data.List (unfoldr) -import Data.Vector.Unboxed (Vector) -import qualified Data.Vector.Unboxed as Vector -import System.Random.MWC -import qualified Data.Foldable as Foldable -import Control.Arrow +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +import Control.Monad (replicateM) +import Criterion.Main +import qualified Data.Heap as Heap import qualified Data.Heap.Stable as Stable +import Data.List (foldl') import qualified Data.PQueue.Prio.Min as PQueue import qualified Data.PriorityQueue.FingerTree as FingerTree -import qualified Data.Heap as Heap +import System.Random.MWC (create, uniformR) -createGroup :: Vector (Int, ()) -> String -> (a -> [(Int, ())]) -> (a -> Int -> () -> a) -> a -> Benchmark -createGroup xs name toListAsc snoc empty = - bench name $ whnf (sum . map fst . toListAsc . Vector.foldl' (\acc (k, v) -> snoc acc k v) empty) xs +class BenchHeap h where + heapName :: String + insert :: h -> Int -> h + empty :: h + drain :: h -> Int +buildThenDrain :: forall h. (BenchHeap h) => [Int] -> Int +buildThenDrain = drain . foldl' insert (empty @h) + +benchHeap :: forall h. (BenchHeap h) => [Int] -> Benchmark +benchHeap keys = bench (heapName @h) $ whnf (buildThenDrain @h) keys + +instance BenchHeap (Stable.Heap Int Int) where + heapName = "stable-heap" + insert h k = Stable.snoc h k k + empty = Stable.empty + drain = go 0 + where + go !acc h = case Stable.minView h of + Stable.EmptyView -> acc + Stable.MinView l k _ r -> go (acc + k) (Stable.append l r) + +instance BenchHeap (FingerTree.PQueue Int Int) where + heapName = "fingertree" + insert h k = FingerTree.add k k h + empty = FingerTree.empty + drain = go 0 + where + go !acc h = case FingerTree.minViewWithKey h of + Nothing -> acc + Just ((k, _), h') -> go (acc + k) h' + +instance BenchHeap (PQueue.MinPQueue Int Int) where + heapName = "pqueue" + insert h k = PQueue.insert k k h + empty = PQueue.empty + drain = go 0 + where + go !acc h = case PQueue.minViewWithKey h of + Nothing -> acc + Just ((k, _), h') -> go (acc + k) h' + +instance BenchHeap (Heap.Heap (Heap.Entry Int Int)) where + heapName = "heaps" + insert h k = Heap.insert (Heap.Entry k k) h + empty = Heap.empty + drain = go 0 + where + go !acc h = case Heap.viewMin h of + Nothing -> acc + Just (e, h') -> go (acc + Heap.priority e) h' + +randomKeys :: Int -> IO [Int] +randomKeys n = do + gen <- create + replicateM n (uniformR (0, n * 10) gen) + +ascendingKeys, descendingKeys, equalKeys :: Int -> [Int] +ascendingKeys n = [0 .. n - 1] +descendingKeys n = [n - 1, n - 2 .. 0] +equalKeys n = replicate n 0 + main :: IO () main = do - gen <- create - xs <- asGenIO (`uniformVector` 1000) gen :: IO (Vector Int) - let create = createGroup (Vector.zip xs (Vector.replicate 1000 ())) + let sizes = [100, 1000, 10000] + randomInputs <- traverse (\n -> (n,) <$> randomKeys n) sizes + + let allBenches keys = + [ benchHeap @(Stable.Heap Int Int) keys, + benchHeap @(FingerTree.PQueue Int Int) keys, + benchHeap @(PQueue.MinPQueue Int Int) keys, + benchHeap @(Heap.Heap (Heap.Entry Int Int)) keys + ] + defaultMain - [ bgroup "unstable" - [ create "pqueue" PQueue.toAscList (\q k v -> PQueue.insert k v q) PQueue.empty - , create "heap" (map (Heap.priority &&& Heap.payload) . Foldable.toList) (\h k v -> Heap.insert (Heap.Entry k v) h) Heap.empty - ] - , bgroup "stable" - [ create "stable-heap" Stable.toAscList Stable.snoc Stable.empty - , create "fingertree" (unfoldr FingerTree.minViewWithKey) (\q k v -> FingerTree.add k v q) FingerTree.empty - ] + [ bgroup + "by-size" + [bgroup (show n) (allBenches keys) | (n, keys) <- randomInputs], + bgroup "by-distribution" $ + let n = 1000 + random = snd (randomInputs !! 1) + in [ bgroup "random" (allBenches random), + bgroup "ascending" (allBenches (ascendingKeys n)), + bgroup "descending" (allBenches (descendingKeys n)), + bgroup "equal" (allBenches (equalKeys n)) + ] ] diff --git a/stable-heap.cabal b/stable-heap.cabal --- a/stable-heap.cabal +++ b/stable-heap.cabal @@ -1,5 +1,6 @@ +cabal-version: 2.2 name: stable-heap -version: 0.2.1.0 +version: 0.3.0.0 synopsis: Purely functional stable heaps (fair priority queues) description: This library provides a purely functional implementation of @@ -15,29 +16,20 @@ license-file: LICENSE author: Jake McArthur maintainer: Jake.McArthur@gmail.com -copyright: Copyright (C) 2015-2016 Jake McArthur -homepage: http://hub.darcs.net/jmcarthur/stable-heap -bug-reports: http://hub.darcs.net/jmcarthur/stable-heap/issues +copyright: Copyright (C) 2015-2023 Jake McArthur +homepage: https://github.com/jmcarthur/stable-heap +bug-reports: https://github.com/jmcarthur/stable-heap/issues category: Data Structures build-type: Simple -cabal-version: >=1.10 stability: experimental -tested-with: GHC ==7.8.4, - GHC ==7.10.3, - GHC ==8.0.2, - GHC ==8.2.2, - GHC ==8.4.4, - GHC ==8.6.5, - GHC ==8.8.4, - GHC ==8.10.7, - GHC ==9.0.2, - GHC ==9.2.7, - GHC ==9.4.4, - GHC ==9.6.1 +tested-with: GHC ==9.6.7, + GHC ==9.8.4, + GHC ==9.10.3, + GHC ==9.12.2 library exposed-modules: Data.Heap.Stable - build-depends: base >=4.7 && <4.19 + build-depends: base ^>=4.18 || ^>=4.19 || ^>=4.20 || ^>=4.21 hs-source-dirs: src default-language: Haskell2010 other-extensions: DeriveTraversable, Trustworthy, TypeFamilies @@ -46,25 +38,24 @@ type: exitcode-stdio-1.0 hs-source-dirs: test build-depends: base, - QuickCheck, + QuickCheck ^>=2.16, stable-heap, - tasty, - tasty-quickcheck, - transformers + tasty ^>=1.5, + tasty-quickcheck ^>=0.11, + transformers ^>=0.6 main-is: Test.hs default-language: Haskell2010 benchmark bench type: exitcode-stdio-1.0 hs-source-dirs: bench - build-depends: base >=4.7 && <4.19, - criterion >= 1.1, - fingertree >= 0.1, - heaps >= 0.3, - mwc-random >= 0.13, - pqueue >= 1.2, - stable-heap, - vector >= 0.10 + build-depends: base, + criterion ^>=1.6, + fingertree ^>=0.1, + heaps ^>=0.4, + mwc-random ^>=0.15, + pqueue ^>=1.6, + stable-heap main-is: Bench.hs default-language: Haskell2010 @@ -75,4 +66,4 @@ source-repository this type: git location: https://github.com/jmcarthur/stable-heap.git - tag: v0.2.1.0 + tag: v0.3.0.0 diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -37,7 +37,7 @@ \(H a :: H Int Int) (H b) -> Heap.toList (Heap.append a b) == Heap.toList a ++ Heap.toList b , testProperty "appends" $ - \(map toHeap -> hs :: [Heap Int Int]) -> + \(map toHeap -> (hs :: [Heap Int Int])) -> (Heap.toList . Heap.appends) hs == concatMap Heap.toList hs , testProperty "minView" $ \(H h :: H Int Int) -> @@ -103,7 +103,7 @@ \(H (fmap apply -> a) :: H [Int] (Fun Int Int)) (H b :: H [Int] Int) -> Heap.toList (a <*> b) == fromWriterT (toWriterT a <*> toWriterT b) , testProperty "(>>=)" $ - \(H a :: H [Int] Int) (fmap toHeap . apply -> f :: Int -> Heap [Int] Int) -> + \(H a :: H [Int] Int) (fmap toHeap . apply -> (f :: Int -> Heap [Int] Int)) -> Heap.toList (a >>= f) == fromWriterT (toWriterT a >>= toWriterT . f) ]