Skip to content

Instantly share code, notes, and snippets.

@vasalf
Last active Jun 27, 2019
Embed
What would you like to do?
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import Algebra.Graph.AdjacencyMap
import Algebra.Graph.AdjacencyMap.Algorithm
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Control.Monad
import Control.Monad.Random
import Control.Monad.State.Lazy
import Control.Monad.Trans.Maybe
import Data.Bits
import Data.List (splitAt)
import Data.Maybe (isJust, fromJust)
import System.Random (mkStdGen)
import Criterion.Main
findPath :: Ord a => a -> a -> AdjacencyMap a -> Bool
findPath s t g = t `elem` reachable s g
findPath' :: Ord a => a -> a -> AdjacencyMap a -> Bool
findPath' s t g = isJust $ run s t g
where
run :: Ord a => a -> a -> AdjacencyMap a -> Maybe [a]
run s t g = evalState (runMaybeT $ dfs t g s) Set.empty
dfs :: Ord a => a -> AdjacencyMap a -> a -> MaybeT (State (Set.Set a)) [a]
dfs t g u | u == t = return [u]
| otherwise = (:) u <$> do vis <- get
guard $ not $ u `Set.member` vis
modify $ Set.insert u
msum $ map (dfs t g) (neighbours u g)
neighbours :: Ord a => a -> AdjacencyMap a -> [a]
neighbours u = Set.toAscList . fromJust . Map.lookup u . adjacencyMap
btree :: Int -> AdjacencyMap Int
btree d = lefts d + rights d
where
lefts d = edges [(x, 2 * x) | x <- [1..(shift 1 (d - 1))]]
rights d = edges [(x, 2 * x + 1) | x <- [1..(shift 1 (d - 1))]]
grid :: Int -> AdjacencyMap Int
grid 1 = vertex 1
grid n = grid (n - 1) + edges [(i + 1, i + n) | i <- [(n * (n - 1) `div` 2)..(n * (n + 1) `div` 2)]] +
edges [(i + 1, i + n + 1) | i <- [(n * (n - 1) `div` 2)..(n * (n + 1) `div` 2)]]
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)
benchmarks :: Int -> Int -> AdjacencyMap Int -> [Benchmark]
benchmarks s t g = [ bench "findPath" $ nf (findPath s t) g
, bench "findPath'" $ nf (findPath' s t) g
]
main :: IO ()
main = defaultMain [ bgroup "clique/100" $ benchmarks 1 100 $ clique $ shuffle 179 [1..100]
, bgroup "clique/1000" $ benchmarks 1 1000 $ clique $ shuffle 179 [1..1000]
, bgroup "path/100000" $ benchmarks 1 100000 $ path [1..100000]
, bgroup "path/1000000" $ benchmarks 1 1000000 $ path [1..1000000]
, bgroup "btree/17" $ benchmarks 1 (shift 1 17) $ btree 17
, bgroup "btree/20" $ benchmarks 1 (shift 1 20) $ btree 20
, bgroup "grid/500" $ benchmarks 1 250000 $ grid 500
, bgroup "grid/1000" $ benchmarks 1 1000000 $ grid 1000
]
benchmarking clique/100/findPath
time 818.7 μs (808.2 μs .. 828.0 μs)
0.998 R² (0.997 R² .. 0.999 R²)
mean 801.6 μs (792.2 μs .. 811.4 μs)
std dev 31.06 μs (23.06 μs .. 44.41 μs)
variance introduced by outliers: 29% (moderately inflated)
benchmarking clique/100/findPath'
time 265.2 μs (262.3 μs .. 268.6 μs)
0.999 R² (0.998 R² .. 0.999 R²)
mean 264.4 μs (261.8 μs .. 267.0 μs)
std dev 8.276 μs (7.164 μs .. 9.579 μs)
variance introduced by outliers: 26% (moderately inflated)
benchmarking clique/1000/findPath
time 56.33 ms (54.84 ms .. 58.42 ms)
0.997 R² (0.993 R² .. 0.999 R²)
mean 55.94 ms (55.16 ms .. 56.75 ms)
std dev 1.534 ms (1.173 ms .. 2.080 ms)
benchmarking clique/1000/findPath'
time 2.613 ms (2.592 ms .. 2.634 ms)
0.999 R² (0.998 R² .. 0.999 R²)
mean 2.600 ms (2.573 ms .. 2.625 ms)
std dev 83.54 μs (67.62 μs .. 105.4 μs)
variance introduced by outliers: 16% (moderately inflated)
benchmarking path/100000/findPath
time 163.2 ms (157.0 ms .. 169.7 ms)
0.998 R² (0.996 R² .. 1.000 R²)
mean 168.0 ms (164.4 ms .. 176.3 ms)
std dev 7.706 ms (2.206 ms .. 11.83 ms)
variance introduced by outliers: 12% (moderately inflated)
benchmarking path/100000/findPath'
time 112.5 ms (106.8 ms .. 117.3 ms)
0.996 R² (0.985 R² .. 0.999 R²)
mean 112.5 ms (108.3 ms .. 117.1 ms)
std dev 6.543 ms (4.533 ms .. 10.32 ms)
variance introduced by outliers: 12% (moderately inflated)
benchmarking path/1000000/findPath
time 1.811 s (1.753 s .. 1.956 s)
0.999 R² (0.997 R² .. 1.000 R²)
mean 1.845 s (1.810 s .. 1.865 s)
std dev 34.26 ms (11.72 ms .. 46.43 ms)
variance introduced by outliers: 19% (moderately inflated)
benchmarking path/1000000/findPath'
time 1.298 s (1.052 s .. 1.470 s)
0.995 R² (0.992 R² .. 1.000 R²)
mean 1.290 s (1.236 s .. 1.345 s)
std dev 69.26 ms (30.74 ms .. 92.92 ms)
variance introduced by outliers: 19% (moderately inflated)
benchmarking btree/17/findPath
time 181.7 ms (170.0 ms .. 192.1 ms)
0.997 R² (0.989 R² .. 1.000 R²)
mean 184.0 ms (177.9 ms .. 195.6 ms)
std dev 10.92 ms (4.341 ms .. 16.00 ms)
variance introduced by outliers: 15% (moderately inflated)
benchmarking btree/17/findPath'
time 2.512 μs (2.483 μs .. 2.540 μs)
0.999 R² (0.998 R² .. 0.999 R²)
mean 2.515 μs (2.488 μs .. 2.542 μs)
std dev 91.99 ns (80.16 ns .. 108.3 ns)
variance introduced by outliers: 48% (moderately inflated)
benchmarking btree/20/findPath
time 1.509 s (1.268 s .. 1.813 s)
0.995 R² (0.985 R² .. 1.000 R²)
mean 1.615 s (1.543 s .. 1.714 s)
std dev 94.44 ms (727.2 μs .. 115.1 ms)
variance introduced by outliers: 19% (moderately inflated)
benchmarking btree/20/findPath'
time 3.493 μs (3.297 μs .. 3.687 μs)
0.983 R² (0.976 R² .. 0.994 R²)
mean 3.348 μs (3.274 μs .. 3.486 μs)
std dev 317.0 ns (215.8 ns .. 447.9 ns)
variance introduced by outliers: 86% (severely inflated)
benchmarking grid/500/findPath
time 70.03 ms (61.28 ms .. 84.04 ms)
0.953 R² (0.908 R² .. 0.994 R²)
mean 62.83 ms (59.14 ms .. 67.99 ms)
std dev 7.548 ms (4.619 ms .. 10.95 ms)
variance introduced by outliers: 43% (moderately inflated)
benchmarking grid/500/findPath'
time 86.26 ns (85.40 ns .. 87.17 ns)
0.999 R² (0.997 R² .. 0.999 R²)
mean 87.03 ns (86.15 ns .. 88.59 ns)
std dev 4.120 ns (2.742 ns .. 7.624 ns)
variance introduced by outliers: 68% (severely inflated)
benchmarking grid/1000/findPath
time 249.8 ms (166.0 ms .. 297.0 ms)
0.972 R² (0.919 R² .. 1.000 R²)
mean 258.0 ms (242.2 ms .. 276.7 ms)
std dev 22.48 ms (13.45 ms .. 33.27 ms)
variance introduced by outliers: 18% (moderately inflated)
benchmarking grid/1000/findPath'
time 92.75 ns (91.81 ns .. 93.72 ns)
0.999 R² (0.999 R² .. 0.999 R²)
mean 92.92 ns (91.88 ns .. 94.03 ns)
std dev 3.707 ns (3.016 ns .. 4.914 ns)
variance introduced by outliers: 60% (severely inflated)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment