Skip to content

Instantly share code, notes, and snippets.

@vasalf
Created Aug 9, 2019
Embed
What would you like to do?
BenchStars.hs
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import Algebra.Graph.Bipartite.AdjacencyMap
import Control.Monad.Random
import Criterion.Main
import Control.Monad (foldM, replicateM)
import Data.Traversable (sequenceA)
starsOverlays :: (Ord a, Ord b) => [(a, [b])] -> AdjacencyMap a b
starsOverlays = overlays . map (uncurry star)
starsEdges :: (Ord a, Ord b) => [(a, [b])] -> AdjacencyMap a b
starsEdges xs = overlay (vertices (map fst (filter (null . snd) xs)) []) (edges (concat (map sequenceA xs)))
shuffle :: Int -> [a] -> [a]
shuffle _ [] = []
shuffle seed xs = evalRand (run xs) (mkStdGen seed)
where
change :: Int -> a -> [a] -> [a]
change i x xs = let (left, _:right) = splitAt i xs
in left ++ [x] ++ right
run :: RandomGen g => [a] -> Rand g [a]
run (x:xs) = foldM action [x] xs
action :: RandomGen g => [a] -> a -> Rand g [a]
action xs x = do i <- getRandomR (0, (length xs) - 1)
let y = xs !! i
return $ y:(change i x xs)
randomDense :: Int -> Int -> [(Int, [Int])]
randomDense seed n = [ (x, shuffle x [1..n]) | x <- shuffle seed [1..n] ]
randomDistinct :: Int -> Int -> [(Int, [Int])]
randomDistinct seed n = [ (x, shuffle x [x * n + 1..x * n + n]) | x <- shuffle seed [1..n] ]
randomLeftEqual :: Int -> Int -> [(Int, [Int])]
randomLeftEqual seed n = [ (1, shuffle x [x * n + 1..x * n + n]) | x <- shuffle seed [1..n] ]
randomAllEqual :: Int -> Int -> [(Int, [Int])]
randomAllEqual seed n = [ (1, shuffle x [1..n]) | x <- shuffle seed [1..n] ]
randomEdges :: Int -> Int -> Int -> [(Int, [Int])]
randomEdges seedx seedy n = [ (x, [y]) | (x, y) <- zip xs ys ]
where
xs = evalRand (replicateM n (getRandomR (1, n))) (mkStdGen seedx)
ys = evalRand (replicateM n (getRandomR (1, n))) (mkStdGen seedy)
benchmarks :: (Ord a, Ord b, Show a, Show b) => [(a, [b])] -> [Benchmark]
benchmarks l = [ bench "overlays" $ nf (length . show . starsOverlays) l
, bench "edges" $ nf (length . show . starsEdges) l
]
main :: IO ()
main = defaultMain [ bgroup "dense/500" $ benchmarks $ randomDense 179 500
, bgroup "distinct/500" $ benchmarks $ randomDistinct 179 500
, bgroup "leftEqual/500" $ benchmarks $ randomLeftEqual 179 500
, bgroup "allEqual/500" $ benchmarks $ randomAllEqual 179 500
, bgroup "edges/40000" $ benchmarks $ randomEdges 179 239 40000
]
benchmarking dense/500/overlays
time 605.0 ms (597.8 ms .. NaN s)
1.000 R² (1.000 R² .. 1.000 R²)
mean 610.7 ms (607.9 ms .. 615.8 ms)
std dev 4.953 ms (121.9 μs .. 5.981 ms)
variance introduced by outliers: 19% (moderately inflated)
benchmarking dense/500/edges
time 602.4 ms (565.6 ms .. 630.7 ms)
1.000 R² (0.999 R² .. 1.000 R²)
mean 623.1 ms (611.3 ms .. 633.6 ms)
std dev 12.80 ms (10.78 ms .. 14.28 ms)
variance introduced by outliers: 19% (moderately inflated)
benchmarking distinct/500/overlays
time 400.2 ms (298.1 ms .. 503.1 ms)
0.991 R² (0.968 R² .. 1.000 R²)
mean 430.6 ms (409.6 ms .. 448.4 ms)
std dev 25.37 ms (16.34 ms .. 31.01 ms)
variance introduced by outliers: 19% (moderately inflated)
benchmarking distinct/500/edges
time 532.2 ms (497.4 ms .. 604.5 ms)
0.998 R² (0.995 R² .. 1.000 R²)
mean 541.6 ms (526.0 ms .. 559.3 ms)
std dev 17.57 ms (7.346 ms .. 24.18 ms)
variance introduced by outliers: 19% (moderately inflated)
benchmarking leftEqual/500/overlays
time 400.2 ms (381.8 ms .. 436.6 ms)
0.999 R² (0.998 R² .. 1.000 R²)
mean 420.2 ms (409.2 ms .. 438.4 ms)
std dev 17.58 ms (3.916 ms .. 23.26 ms)
variance introduced by outliers: 19% (moderately inflated)
benchmarking leftEqual/500/edges
time 543.3 ms (478.7 ms .. 581.8 ms)
0.998 R² (0.995 R² .. 1.000 R²)
mean 551.1 ms (534.1 ms .. 571.2 ms)
std dev 20.90 ms (9.279 ms .. 29.06 ms)
variance introduced by outliers: 19% (moderately inflated)
benchmarking allEqual/500/overlays
time 261.4 ms (255.1 ms .. 264.0 ms)
1.000 R² (0.999 R² .. 1.000 R²)
mean 260.4 ms (257.7 ms .. 262.2 ms)
std dev 2.887 ms (1.688 ms .. 4.312 ms)
variance introduced by outliers: 16% (moderately inflated)
benchmarking allEqual/500/edges
time 160.4 ms (157.4 ms .. 163.0 ms)
1.000 R² (0.999 R² .. 1.000 R²)
mean 156.2 ms (154.6 ms .. 157.9 ms)
std dev 2.462 ms (1.743 ms .. 3.355 ms)
variance introduced by outliers: 12% (moderately inflated)
benchmarking edges/40000/overlays
time 245.4 ms (224.9 ms .. 258.2 ms)
0.998 R² (0.995 R² .. 1.000 R²)
mean 246.9 ms (243.0 ms .. 250.8 ms)
std dev 4.949 ms (2.846 ms .. 5.608 ms)
variance introduced by outliers: 16% (moderately inflated)
benchmarking edges/40000/edges
time 242.9 ms (235.6 ms .. 247.5 ms)
1.000 R² (0.999 R² .. 1.000 R²)
mean 239.7 ms (235.4 ms .. 242.0 ms)
std dev 3.924 ms (1.466 ms .. 5.552 ms)
variance introduced by outliers: 16% (moderately inflated)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment