BenchDFS.hs

{-# 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
                   ]

report-osx.txt

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)