├── LICENSE
├── README.md
├── Setup.hs
├── big-oh.cabal
├── docs
    ├── 201511-fpsyd.pdf
    └── doh.png
├── example
    ├── codensity.hs
    ├── fib.hs
    └── sort.hs
├── hakaru-0.1.4-ghc-7.10.patch
├── src
    └── Test
    │   ├── BigOh.hs
    │   └── BigOh
    │       ├── Benchmark.hs
    │       ├── Fit
    │           ├── Base.hs
    │           ├── Hakaru.hs
    │           ├── Naive.hs
    │           └── R.hs
    │       ├── Generate.hs
    │       └── Plot.hs
└── stack.yaml


/LICENSE:
--------------------------------------------------------------------------------
 1 | Copyright (c) 2015, Tran Ma
 2 | 
 3 | All rights reserved.
 4 | 
 5 | Redistribution and use in source and binary forms, with or without
 6 | modification, are permitted provided that the following conditions are met:
 7 | 
 8 |     * Redistributions of source code must retain the above copyright
 9 |       notice, this list of conditions and the following disclaimer.
10 | 
11 |     * Redistributions in binary form must reproduce the above
12 |       copyright notice, this list of conditions and the following
13 |       disclaimer in the documentation and/or other materials provided
14 |       with the distribution.
15 | 
16 |     * Neither the name of Tran Ma nor the names of other
17 |       contributors may be used to endorse or promote products derived
18 |       from this software without specific prior written permission.
19 | 
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | Big Oh
 2 | ======
 3 | 
 4 | <img src="https://github.com/tranma/big-oh/blob/master/docs/doh.png" width="300">
 5 | 
 6 | This is an algorithmic complexity testing framework for Haskell, suitable for
 7 | an Agile (tm) approach to performance analysis.
 8 | 
 9 | Why solve recurrence equations when you can just fit squiggly lines into things?!
10 | 
11 | FP Sydney User Group 11/2015: [fpsyd-talk](docs/201511-fpsyd.pdf)
12 | 
13 | Hackage/docs TBA.
14 | 


--------------------------------------------------------------------------------
/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 | 


--------------------------------------------------------------------------------
/big-oh.cabal:
--------------------------------------------------------------------------------
 1 | name:                big-oh
 2 | version:             0.1.0.0
 3 | synopsis:            Complexity testing for Haskell.
 4 | description:         A Haskell library for testing time and space complexity.
 5 | license:             BSD3
 6 | license-file:        LICENSE
 7 | author:              Tran Ma
 8 | maintainer:          tran@defma.in
 9 | category:            Testing
10 | build-type:          Simple
11 | cabal-version:       >=1.10
12 | 
13 | library
14 |   exposed-modules:     Test.BigOh
15 |                      , Test.BigOh.Benchmark
16 |                      , Test.BigOh.Generate
17 |                      , Test.BigOh.Plot
18 |                      , Test.BigOh.Fit.Hakaru
19 |                      , Test.BigOh.Fit.R
20 |                      , Test.BigOh.Fit.Naive
21 |                      , Test.BigOh.Fit.Base
22 | 
23 |   build-depends:       base >= 4.8 && < 5
24 |                      , hakaru == 0.1.4
25 |                      , inline-r
26 |                      , criterion
27 |                      , statistics
28 |                      , ansigraph >= 0.1
29 |                      , QuickCheck >= 2.8
30 |                      , transformers
31 |                      , array
32 |                      , deepseq
33 |                      , vector
34 |                      , discrimination >= 0.1
35 |                      , ansi-terminal >= 0.6
36 | 
37 |   hs-source-dirs:      src
38 |   default-language:    Haskell2010
39 | 


--------------------------------------------------------------------------------
/docs/201511-fpsyd.pdf:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/tranma/empirical-big-oh/573815a8af9d5f3cda3c96e22d59b71ec9f29de9/docs/201511-fpsyd.pdf


--------------------------------------------------------------------------------
/docs/doh.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/tranma/empirical-big-oh/573815a8af9d5f3cda3c96e22d59b71ec9f29de9/docs/doh.png


--------------------------------------------------------------------------------
/example/codensity.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE RankNTypes, MultiParamTypeClasses,FlexibleInstances, FlexibleContexts #-}
  2 | import           Criterion.Types
  3 | import qualified Data.Discrimination as D
  4 | import           Data.Ix
  5 | import           Data.List
  6 | 
  7 | import           Test.BigOh
  8 | import qualified Test.BigOh.Fit.R    as R
  9 | import Control.Monad
 10 | import Prelude hiding (abs)
 11 | 
 12 | main
 13 |   = rVoodoo
 14 |   $ do header "free:"
 15 |        go (== 2) (== R.Quadratic) (lengthTrace . slowRunRevEcho)
 16 |        header  "codensity:"
 17 |        go (== 1) (== R.Linear) (lengthTrace . fastRunRevEcho)
 18 |   where
 19 |    go i o f
 20 |      = do x <- genRunWhnf (defaultsForListInput :: Settings [Char])
 21 |                              { generator = return . genInputSized
 22 |                              , benchConf = defaultBenchmarkConfig { timeLimit = 2 }
 23 |                              , sampleRange = (10,2000)
 24 |                              , numSamples = 10
 25 |                              }
 26 |                           f
 27 |           graphPoints $ getPoints x
 28 |           header "Naive:"
 29 |           naive i x
 30 |           header  "R:"
 31 |           rlm   o x
 32 | 
 33 | 
 34 | 
 35 | data Free f a = Return a | Wrap (f (Free f a))
 36 | 
 37 | instance Functor f => Functor (Free f) where 
 38 |   fmap f x = x >>= return . f
 39 | 
 40 | instance Functor f => Applicative (Free f) where
 41 |   pure = Return
 42 |   (<*>) = ap
 43 | 
 44 | instance Functor f => Monad (Free f) where 
 45 |   return = Return
 46 |   Return a >>= k = k a
 47 |   Wrap t >>= k = Wrap (fmap (>>= k) t)
 48 | 
 49 | newtype C m a = C (forall b. (a -> m b) -> m b)
 50 | 
 51 | rep :: Monad m => m a -> C m a
 52 | rep m = C (m >>=)
 53 | 
 54 | abs :: Monad m => C m a -> m a
 55 | abs (C p) = p return
 56 | 
 57 | instance Functor (C m) where
 58 |   fmap f x = x >>= return . f
 59 | instance Applicative (C m) where
 60 |   pure = return
 61 |   (<*>) = ap
 62 | 
 63 | instance Monad (C m) where 
 64 |   return a = C ($ a)
 65 |   C r >>= k = C (\h -> r (\a -> case k a of C q -> q h))
 66 | 
 67 | class (Functor f, Monad m) => FreeLike f m where 
 68 |   wrap :: f (m a) -> m a
 69 | 
 70 | instance Functor f => FreeLike f (Free f) where 
 71 |   wrap = Wrap
 72 | 
 73 | instance FreeLike f m => FreeLike f (C m) where 
 74 |   wrap t = C (\h -> wrap (fmap (\(C r) -> r h) t))
 75 | 
 76 | 
 77 | improve :: Functor f => (forall m. FreeLike f m => m a) -> Free f a
 78 | improve m = abs m
 79 | 
 80 | 
 81 | 
 82 | data FakeIO n = GetChar (Char -> n) 
 83 |               | PutChar Char n
 84 | instance Functor FakeIO where 
 85 |   fmap f (GetChar c) = GetChar (fmap f c)
 86 |   fmap f (PutChar c n) = PutChar c (f n)
 87 | 
 88 | getChar' :: FreeLike FakeIO m => m Char
 89 | getChar' = wrap (GetChar return)
 90 | 
 91 | putChar' :: FreeLike FakeIO m => Char -> m ()
 92 | putChar' c = wrap (PutChar c (return ()))
 93 | 
 94 | 
 95 | 
 96 | revEcho :: FreeLike FakeIO m => m ()
 97 | revEcho = do
 98 |   c <- getChar'
 99 |   when (c /= ' ') $ do
100 |     revEcho
101 |     putChar' c
102 | 
103 | lengthTrace :: Trace a -> Int
104 | lengthTrace (Read t) = lengthTrace t
105 | lengthTrace (Print _ t) = 1 + lengthTrace t
106 | lengthTrace _ = 0
107 | 
108 | data Trace a = Read (Trace a) | Print Char (Trace a) | Finish a deriving (Show)
109 | 
110 | run :: Free FakeIO a -> [Char] -> Trace a
111 | run (Return a) cs = Finish a
112 | run (Wrap (GetChar f)) (c:cs) = Read (run (f c) cs) 
113 | run (Wrap (PutChar c f)) cs = Print c (run f cs) 
114 | 
115 | slowRunRevEcho :: [Char] -> Trace ()
116 | slowRunRevEcho = run (revEcho :: Free FakeIO ())
117 | 
118 | fastRunRevEcho :: [Char] -> Trace ()
119 | fastRunRevEcho = run (improve revEcho)
120 | 
121 | genInputSized :: Int -> [Char]
122 | genInputSized n = take n (cycle "abcdefgh") ++ " " 
123 | 


--------------------------------------------------------------------------------
/example/fib.hs:
--------------------------------------------------------------------------------
 1 | import           Data.Monoid
 2 | import           Test.BigOh
 3 | import qualified Test.BigOh.Fit.R as R
 4 | 
 5 | main
 6 |   = rVoodoo
 7 |   $ do header "Fibonacci"
 8 |        go (> 2) (== R.Exp) fib
 9 |   where
10 |     go i o f
11 |       = do x <- genRunWhnf (defaultsForIntInput { numSamples = 10, sampleRange = (1,20) }) f
12 |            graphPoints (getPoints x)
13 |            putStrLn $ "xs=" <> show (fst $ unzip $ getPoints x)
14 |            putStrLn $ "ys=" <> show (snd $ unzip $ getPoints x)
15 |            header "Naive:"
16 |            naive i x
17 |            header  "R:"
18 |            rlm   o x
19 | 
20 | fib :: Int -> Int
21 | fib m | m < 0     = error "negative!"
22 |       | otherwise = go m
23 |   where go 0 = 0
24 |         go 1 = 1
25 |         go n = go (n-1) + go (n-2)
26 | 
27 | 


--------------------------------------------------------------------------------
/example/sort.hs:
--------------------------------------------------------------------------------
 1 | import           Criterion.Types
 2 | import qualified Data.Discrimination as D
 3 | import           Data.Ix
 4 | import           Data.List
 5 | 
 6 | import           Test.BigOh
 7 | import qualified Test.BigOh.Fit.R    as R
 8 | 
 9 | 
10 | main
11 |   = rVoodoo
12 |   $ do header "Selection sort"
13 |        go (== 2) (== R.Quadratic) selection
14 |        header  "Quick sort"
15 |        go (inRange (1,2)) (inRange (R.Linear,R.Quadratic)) (sort :: [Int] -> [Int])
16 |        header  "Discrimination (radix) sort"
17 |        go (== 1) (== R.Linear) (D.sort :: [Int] -> [Int])
18 |   where
19 |    go i o f
20 |      = do x <- genRunWhnf (defaultsForListInput
21 |                              { benchConf = defaultBenchmarkConfig { timeLimit = 2 }})
22 |                           f
23 |           graphPoints $ getPoints x
24 |           header "Naive:"
25 |           naive i x
26 |           header  "R:"
27 |           rlm   o x
28 | 
29 | selection :: [Int] -> [Int]
30 | selection [] = []
31 | selection xs = let x = maximum xs in selection (delete x xs) ++ [x]
32 | 


--------------------------------------------------------------------------------
/hakaru-0.1.4-ghc-7.10.patch:
--------------------------------------------------------------------------------
  1 | diff --git a/Language/Hakaru/ImportanceSampler.hs b/Language/Hakaru/ImportanceSampler.hs
  2 | index 731bc5b..0066fc9 100644
  3 | --- a/Language/Hakaru/ImportanceSampler.hs
  4 | +++ b/Language/Hakaru/ImportanceSampler.hs
  5 | @@ -15,6 +15,7 @@ import Language.Hakaru.Sampler (Sampler, deterministic, smap, sbind)
  6 |  
  7 |  import qualified System.Random.MWC as MWC
  8 |  import Control.Monad.Primitive
  9 | +import Control.Monad(ap)
 10 |  import Data.Monoid
 11 |  import Data.Dynamic
 12 |  import System.IO.Unsafe
 13 | @@ -31,10 +32,17 @@ bind measure continuation =
 14 |      sbind (unMeasure measure conds)
 15 |            (\(a,cds) -> unMeasure (continuation a) cds))
 16 |  
 17 | +instance Functor Measure where
 18 | +  fmap f x = x >>= return . f
 19 | +
 20 |  instance Monad Measure where
 21 |    return x = Measure (\conds -> deterministic (point (x,conds) 1))
 22 |    (>>=)    = bind
 23 |  
 24 | +instance Applicative Measure where 
 25 | +  pure = return
 26 | +  (<*>) = ap
 27 | +
 28 |  updateMixture :: Typeable a => Cond -> Dist a -> Sampler a
 29 |  updateMixture (Just cond) dist =
 30 |      case fromDynamic cond of
 31 | diff --git a/Language/Hakaru/Symbolic.hs b/Language/Hakaru/Symbolic.hs
 32 | index 7159eeb..63f23fa 100644
 33 | --- a/Language/Hakaru/Symbolic.hs
 34 | +++ b/Language/Hakaru/Symbolic.hs
 35 | @@ -3,7 +3,7 @@
 36 |  
 37 |  module Language.Hakaru.Symbolic where
 38 |  
 39 | -import Prelude hiding (Real)
 40 | +import Prelude hiding (Real, pure)
 41 |  
 42 |  data Real
 43 |  data Prob
 44 | diff --git a/hakaru.cabal b/hakaru.cabal
 45 | index 7f626ac..ebfecd9 100644
 46 | --- a/hakaru.cabal
 47 | +++ b/hakaru.cabal
 48 | @@ -36,26 +36,26 @@ library
 49 |                         StandaloneDeriving, OverloadedStrings,
 50 |                         FlexibleInstances, RebindableSyntax
 51 |    build-depends:       base >=4.6 && <5.0,
 52 | -                       random >=1.0 && <1.1,
 53 | -                       transformers >=0.3 && <0.4,
 54 | +                       random >=1.0 && <1.2,
 55 | +                       transformers >=0.3 && <0.5,
 56 |                         containers >=0.5 && <0.6,
 57 |                         pretty >=1.1 && <1.2,
 58 | -                       logfloat >=0.12 && <0.13,
 59 | +                       logfloat >=0.13 && <0.14,
 60 |                         hmatrix >=0.16 && <0.17,
 61 |                         math-functions >=0.1 && <0.2,
 62 |                         vector >=0.10 && <0.11,
 63 |                         cassava >=0.4 && <0.5,
 64 |                         zlib >=0.5 && <0.6,
 65 |                         bytestring >=0.10 && <0.11,
 66 | -                       aeson >=0.7 && <0.8,
 67 | -                       text >=1.1 && <1.2,
 68 | +                       aeson >=0.7 && <0.9,
 69 | +                       text >=1.1 && <1.3,
 70 |                         statistics >=0.11 && <0.14,
 71 |                         parsec >=3.1 && <3.2,
 72 |                         array >=0.4,
 73 |                         mwc-random >=0.13 && <0.14,
 74 |                         directory >=1.2 && <1.3,
 75 |                         integration >= 0.2.0 && < 0.3.0,
 76 | -                       primitive >= 0.5 && < 0.6,
 77 | +                       primitive >= 0.5 && < 0.7,
 78 |                         parallel >=3.2 && <3.3,
 79 |                         monad-loops >= 0.3.0.2
 80 |    -- hs-source-dirs:      
 81 | @@ -75,17 +75,17 @@ test-suite hakaru-test
 82 |                         test-framework,
 83 |                         test-framework-quickcheck2,
 84 |                         test-framework-hunit,
 85 | -                       random >=1.0 && <1.1,
 86 | +                       random >=1.0 && <1.2,
 87 |                         pretty >=1.1 && <1.2,
 88 |                         containers >=0.5 && <0.6,
 89 | -                       logfloat >=0.12 && <0.13,
 90 | +                       logfloat >=0.13 && <0.14,
 91 |                         math-functions >=0.1 && <0.2,
 92 |                         statistics >=0.11 && <0.14,
 93 |                         hmatrix >=0.16 && <0.17,
 94 |                         vector >=0.10 && <0.11,
 95 |                         hakaru >= 0.1.3,
 96 |                         mwc-random >=0.13 && <0.14,
 97 | -                       primitive >= 0.5 && < 0.6,
 98 | +                       primitive >= 0.5 && < 0.7,
 99 |                         monad-loops >= 0.3.0.2
100 |      default-language:  Haskell2010
101 |  
102 | 


--------------------------------------------------------------------------------
/src/Test/BigOh.hs:
--------------------------------------------------------------------------------
  1 | module Test.BigOh
  2 |   ( Settings(..)
  3 |   , module X
  4 |   , naiveWhnf
  5 |   , rlmWhnf
  6 |   , mcmcWhnf
  7 |   , naive
  8 |   , rlm
  9 |   , mcmc
 10 |   , genRunWhnf
 11 |   , defaultsForListInput
 12 |   , defaultsForIntInput
 13 |   , getPoints
 14 |   , rVoodoo
 15 |   ) where
 16 | 
 17 | import           Control.Arrow
 18 | import           Criterion.Types
 19 | import           Data.List
 20 | import           Data.Monoid
 21 | import           Data.Ord
 22 | import           Language.R.Instance   as R
 23 | import           Test.BigOh.Benchmark  as X
 24 | import           Test.BigOh.Fit.Base
 25 | import qualified Test.BigOh.Fit.Hakaru as H
 26 | import qualified Test.BigOh.Fit.Naive  as Naive
 27 | import qualified Test.BigOh.Fit.R      as R
 28 | import           Test.BigOh.Generate   as X
 29 | import           Test.BigOh.Plot       as X
 30 | import           Test.QuickCheck
 31 | import qualified Criterion.Types as C
 32 | 
 33 | import Debug.Trace
 34 | 
 35 | 
 36 | data Settings s
 37 |   = Settings
 38 |   { generator   :: Int -> Gen s
 39 |   , numSamples  :: Int
 40 |   , sampleRange :: (Int, Int)
 41 |   , benchConf   :: C.Config
 42 |   }
 43 | 
 44 | genRunWhnf :: Settings s -> (s -> x) -> IO [(Input s, Report)]
 45 | genRunWhnf (Settings gen n r conf) func
 46 |   = do x <- generate $ genWhnf n r gen func
 47 |        runInputs conf x
 48 | 
 49 | getPoints :: [(Input a, Report)] -> [Point]
 50 | getPoints xs
 51 |   = first fromIntegral <$> getTimes xs
 52 | 
 53 | goodnessOfRSquared :: Double -> Double
 54 | goodnessOfRSquared x
 55 |  | x /= x    = 1 / 0 -- fucking NaN
 56 |  | otherwise = abs (1 - x)
 57 | 
 58 | defaultsForListInput :: Arbitrary a => Settings [a]
 59 | defaultsForListInput
 60 |   = Settings (\n -> take n <$> infiniteList) 10 (50, 2000) defaultBenchmarkConfig
 61 | 
 62 | defaultsForIntInput :: Settings Int
 63 | defaultsForIntInput
 64 |   = Settings return 10 (5,30) defaultBenchmarkConfig
 65 | 
 66 | rVoodoo :: IO a -> IO a
 67 | rVoodoo = R.withEmbeddedR R.defaultConfig
 68 | 
 69 | --------------------------------------------------------------------------------
 70 | 
 71 | naiveWhnf :: Settings s -> (s -> x) -> (Naive.Order -> Bool) -> IO Bool
 72 | naiveWhnf ss f predi = genRunWhnf ss f >>= naive predi
 73 | 
 74 | rlmWhnf :: Settings s -> (s -> x) -> (R.Order -> Bool) -> IO Bool
 75 | rlmWhnf   ss f predi = genRunWhnf ss f >>= rlm predi
 76 | 
 77 | mcmcWhnf :: Settings s -> (s -> x) -> (H.Order -> Bool) -> IO Bool
 78 | mcmcWhnf  ss f predi = genRunWhnf ss f >>= mcmc predi
 79 | 
 80 | naive :: (Naive.Order -> Bool) -> [(Input a, Report)] -> IO Bool
 81 | naive predicate reps
 82 |   = do let points  = getPoints reps
 83 |        let epsilon = minimum $ getStdDevs reps
 84 | 
 85 |        case Naive.polyOrder epsilon points of
 86 |          Just o
 87 |            | predicate o -> passed $ "PASSED: Seems to be O(n" ++ superscript o ++ ")"
 88 |            | otherwise   -> failed $ "FAILED: Seems to be O(n" ++ superscript o ++ ")"
 89 |          Nothing
 90 |            -> inconclusive "INCONCLUSIVE: Ran out of points! Maybe it's not polynomial?"
 91 | 
 92 | rlm :: (R.Order -> Bool) -> [(Input a, Report)] -> IO Bool
 93 | rlm predi reps
 94 |   = do let points = getPoints reps
 95 |        lms       <- mapM (flip R.lm points) R.knownOrders
 96 |        let lms'   = zip R.knownOrders lms
 97 |            best   = trace ("rsquares: " <> show lms') $ minimumBy (comparing (goodnessOfRSquared . snd)) lms'
 98 |            b      = predi (fst best)
 99 | 
100 |        if b
101 |        then passed $ "PASSED: Seems to be O(" <> R.pretty (fst best) <> ")"
102 |        else failed $ "FAILED: Seems to be O(" <> R.pretty (fst best) <> ")"
103 | 
104 |        return b
105 | 
106 | mcmc :: (H.Order -> Bool) -> [(Input a, Report)] -> IO Bool
107 | mcmc predi reps
108 |   = do let points   = getPoints reps
109 |            (xs, ys) = unzip points
110 |        H.fit predi H.knownOrders xs ys
111 | 


--------------------------------------------------------------------------------
/src/Test/BigOh/Benchmark.hs:
--------------------------------------------------------------------------------
 1 | -- * This module defines how to run and extract time/space data
 2 | --   from benchmarks.
 3 | --
 4 | module Test.BigOh.Benchmark
 5 |   ( -- * Running benchmarks
 6 |     runInputs
 7 |   , getTimes
 8 |   , getStdDevs
 9 |   , defaultBenchmarkConfig
10 |   ) where
11 | 
12 | import           Control.Monad.IO.Class
13 | import           Criterion.Internal
14 | import           Criterion.Main
15 | import           Criterion.Measurement
16 | import           Criterion.Monad
17 | import           Criterion.Types
18 | import           Statistics.Resampling.Bootstrap
19 | 
20 | import           Test.BigOh.Generate
21 | 
22 | defaultBenchmarkConfig = defaultConfig { timeLimit = 1, resamples = 100 }
23 | 
24 | runOne :: Config -> Benchmarkable -> IO Report
25 | runOne cfg x
26 |   = withConfig cfg
27 |   $ do liftIO initializeTime
28 |        runAndAnalyseOne 0 "" x
29 | 
30 | runInputs :: Config -> [(Benchmarkable, Input a)] -> IO [(Input a, Report)]
31 | runInputs cfg xs
32 |   = zip (map snd xs) <$> mapM (runOne cfg . fst) xs
33 | 
34 | getTimes :: [(Input a, Report)] -> [(Int, Double)]
35 | getTimes = map go
36 |   where
37 |     go (i, report)
38 |       = (inputSize i, estPoint $ anMean $ reportAnalysis report)
39 | 
40 | getStdDevs :: [(Input a, Report)] -> [Double]
41 | getStdDevs = map (estPoint . anStdDev . reportAnalysis . snd)
42 | 


--------------------------------------------------------------------------------
/src/Test/BigOh/Fit/Base.hs:
--------------------------------------------------------------------------------
 1 | module Test.BigOh.Fit.Base where
 2 | 
 3 | import Data.List
 4 | 
 5 | type Point = (Double, Double)
 6 | 
 7 | variance :: [Double] -> Double
 8 | variance xs@(_:_:_)
 9 |  = let (n,_,m2) = foldl' go (0,0,0) xs
10 |    in   m2 / (n - 1)
11 |  where
12 |   go (n,m,m2) x
13 |    = let n'    = n + 1
14 |          delta = x - m
15 |          m'    = m + delta / n'
16 |          m2'   = m2 + delta * (x - m')
17 |      in  (n',m',m2')
18 | variance _ = 0 / 0
19 | 
20 | sd :: [Double] -> Double
21 | sd = sqrt . variance
22 | 
23 | mean :: [Double] -> Double
24 | mean xs = sum xs / fromIntegral (length xs)
25 | 


--------------------------------------------------------------------------------
/src/Test/BigOh/Fit/Hakaru.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE MultiWayIf #-}
  2 | module Test.BigOh.Fit.Hakaru
  3 |   ( -- * Complexity defs
  4 |     Coefficient
  5 |   , Order(..)
  6 |   , Fit(..)
  7 |   , knownOrders
  8 |   , exponential
  9 |   , constant
 10 |   , linear
 11 |   , quadratic
 12 |   , cubic
 13 |   , nlogn
 14 |   , poly1d
 15 | 
 16 |   -- * Fitting curves
 17 |   , bestFit
 18 |   , fit
 19 |   ) where
 20 | 
 21 | import           Control.Arrow
 22 | import           Control.Monad
 23 | import           Data.Dynamic
 24 | import           Data.List
 25 | import           Data.Monoid
 26 | import           Data.Ord
 27 | import qualified Data.Vector                  as V
 28 | import           Language.Hakaru.Distribution
 29 | import           Language.Hakaru.Metropolis
 30 | import           Language.Hakaru.Types
 31 | import qualified Statistics.Sample            as S
 32 | 
 33 | import           Test.BigOh.Fit.Base
 34 | 
 35 | 
 36 | data Fit
 37 |   = Fit { xVals :: [Double]
 38 |         , yVals :: [Double]
 39 |         , burnN :: Int
 40 |         , takeN :: Int
 41 |         }
 42 | 
 43 | -- | Given a complexity order and some data,
 44 | --   determine if the order best describes the data.
 45 | fit :: (Order -> Bool) -> [Order] -> [Double] -> [Double] -> IO Bool
 46 | fit predi orders xs ys
 47 |   = go (50 :: Int) burnStart takeStart
 48 |   where
 49 |    burnStart = 10000
 50 |    takeStart = 1000
 51 |    go try b t
 52 |     = do ranked    <- bestFit' orders (Fit xs ys b t)
 53 |          putStrLn ("ranked: " <> show (fmap (first name) ranked))
 54 |          let order' = fst $ head ranked
 55 |          if | predi order'              -> return True
 56 |             | try        == 0           -> return False
 57 |             | otherwise                 -> go (try - 1) (b * 2) (t * 2)
 58 | 
 59 | -- | Find the complexity order that best fits the data.
 60 | --
 61 | bestFit :: [Order] -> Fit ->  IO Order
 62 | bestFit orders f
 63 |   = fst . head <$> bestFit' orders f
 64 | 
 65 | bestFit' :: [Order] -> Fit ->  IO [(Order, Double)]
 66 | bestFit' orders f@(Fit xs ys _ _)
 67 |   = do fits   <- mapM (`curveFit` f) orders
 68 |        let fs  = fmap (<$> xs) fits
 69 |            rs  = fmap (rSquared ys) fs
 70 |            rs' = zip orders rs
 71 |            rs''= sortBy (comparing snd) rs'
 72 |        return rs''
 73 | 
 74 | -- | Given a complexity order and some data, generate a curve of
 75 | --   that order that fit the data.
 76 | --
 77 | curveFit :: Order -> Fit -> IO (Double -> Double)
 78 | curveFit thing (Fit xs ys dropn taken)
 79 |  = do l <- mcmc (measureForOrder thing xs ys)
 80 |                 (map (Just . toDyn . Lebesgue) ys)
 81 |       let means = expectations $ take taken $ drop dropn l
 82 |       return $ mkCurve thing means
 83 | 
 84 | -- | Create a sampler for a class of curves with some x values.
 85 | --   e.g. sample @y = a*x^2 + b*x +c@
 86 | --
 87 | measureForOrder :: Order -> [Double] -> [Double] -> Measure [Double]
 88 | measureForOrder order xs ys
 89 |   = measureForOrder' 0 (maximum $ fmap abs ys) (sd ys) order xs
 90 | 
 91 | measureForOrder' :: Double -> Double -> Double -> Order -> [Double] -> Measure [Double]
 92 | measureForOrder' mean range sdev (Order _ n func) xs
 93 |   = do w <- replicateM n $ unconditioned (normal mean range)
 94 |        y <- mapM (conditioned . withinNormal w) xs
 95 |        return w
 96 |   where
 97 |    withinNormal w x
 98 |      = normal (func w x) sdev
 99 | 
100 | -- | Given a bunch of possible coefficient sets, return the
101 | --   expected value of each coeffient.
102 | --   e.g. for @a*x^2 + b^x + c@,some possible coffients might be:
103 | --        @[[a=0,b=1,c=4], [a=3,b=4,c=2]]@, @expectations@ returns
104 | --        the expected values for @a, b, c@.
105 | --
106 | expectations :: [[Double]] -> [Double]
107 | expectations l = map (S.mean . V.fromList) (transpose l)
108 | 
109 | --------------------------------------------------------------------------------
110 | 
111 | type Coefficient = Double
112 | 
113 | -- | A complexity order, e.g. exponential, quadratic.
114 | data Order
115 |   = Order
116 |     { name      :: String
117 |     , numCoeffs :: Int
118 |     , mkCurve   :: [Coefficient] -> Double -> Double
119 |     }
120 | 
121 | knownOrders :: [Order]
122 | knownOrders = [exponential, constant, linear, quadratic, cubic, nlogn]
123 | 
124 | exponential :: Order
125 | exponential
126 |   = Order "exp" 4 $ \[a, b, c, d] x -> a * (2 ** (b * x + c)) + d
127 | 
128 | constant :: Order
129 | constant
130 |   = Order "constant" 1 poly1d
131 | 
132 | linear :: Order
133 | linear
134 |   = Order "linear" 2 poly1d
135 | 
136 | quadratic :: Order
137 | quadratic
138 |   = Order "quadratic" 3 poly1d
139 | 
140 | cubic :: Order
141 | cubic
142 |   = Order "cubic" 4 poly1d
143 | 
144 | nlogn :: Order
145 | nlogn
146 |   = Order "nlogn" 2
147 |   $ \[a, b] n -> a * n * log  n + b
148 | 
149 | poly1d :: [Double] -> Double -> Double
150 | poly1d weights a = poly weights a 1
151 |    where
152 |      poly [] _ _ = 0
153 |      poly (w:ws) x acc = w*acc + (poly ws x acc*x)
154 | 
155 | square :: Num a => a -> a
156 | square x = x * x
157 | 
158 | rSquared
159 |   :: [Double] -- ^ data set y1..yn
160 |   -> [Double] -- ^ model f1..fn
161 |   -> Double   -- ^ r squared
162 | rSquared ys fs
163 |  = let yBar  = sum ys / fromIntegral (length ys)
164 |        ssTot = sum (fmap (square . subtract yBar) ys)
165 |        ssRes = sum (fmap square (zipWith (-) ys fs))
166 |    in  (ssTot - ssRes) / ssTot
167 | 


--------------------------------------------------------------------------------
/src/Test/BigOh/Fit/Naive.hs:
--------------------------------------------------------------------------------
 1 | module Test.BigOh.Fit.Naive
 2 |   ( Order
 3 |   , fit
 4 |   , polyOrder
 5 |   , deriv
 6 |   ) where
 7 | 
 8 | import           Test.BigOh.Fit.Base
 9 | 
10 | type Order = Int -- ahahaha
11 | 
12 | 
13 | -- | Estimate the polynomial order for some points, given
14 | --   a margin of error.
15 | --
16 | polyOrder :: Double -> [Point] -> Maybe Order
17 | polyOrder epsilon points@(_:_:_:_)
18 |   | isConstant points
19 |   = Just 0
20 |   | otherwise
21 |   = fmap succ $ polyOrder epsilon $ deriv points
22 |   where
23 |    isConstant derivs
24 |     = sd (fmap snd derivs) < epsilon
25 | polyOrder _ _
26 |   = Nothing
27 | 
28 | deriv :: [Point] -> [Point]
29 | deriv points
30 |   = let gs = zipWith gradient points (drop 1 points)
31 |     in  zip (fmap fst points) gs
32 | 
33 | gradient :: Point -> Point -> Double
34 | gradient (x1, y1) (x2, y2)
35 |    = (y2 - y1) / (x2 - x1)
36 | 
37 | -- doesn't work very well, just use polyOrder
38 | fit :: Order -> [Point] -> Bool
39 | fit order points = go (100 :: Int) startEpsilon
40 |   where
41 |     startEpsilon
42 |       = 2.1e-6 -- 0.1 * sd (fmap snd points)
43 |     go 0 _
44 |       = False
45 |     go n e
46 |       = case polyOrder e points of
47 |           -- haven't found an order
48 |           Nothing
49 |             -> go (n - 1) (e * 2 / 3)
50 |           -- found an order
51 |           Just order'
52 |             -- but it's not the right one, it's less
53 |             | order' < order
54 |             -> go (n - 1) (e * 2)
55 |             -- but it's not the right one, it's more
56 |             | order' > order
57 |             -> go (n - 1) (e * 2 / 3)
58 |             -- bingo
59 |             | otherwise
60 |             -> True
61 | 


--------------------------------------------------------------------------------
/src/Test/BigOh/Fit/R.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE GADTs       #-}
 2 | {-# LANGUAGE QuasiQuotes #-}
 3 | module Test.BigOh.Fit.R where
 4 | 
 5 | import           Data.Ix
 6 | import           Data.Monoid
 7 | import           Data.Vector.SEXP
 8 | import qualified Foreign.R           as R
 9 | import           Language.R.HExp
10 | import           Language.R.Instance as R
11 | import           Language.R.QQ
12 | import           Test.BigOh.Fit.Base
13 | import           Test.BigOh.Plot
14 | 
15 | 
16 | data Order
17 |   = Constant
18 |   | LogN
19 |   | Linear
20 |   | NLogN
21 |   | Quadratic
22 |   | Cubic
23 |   | Quartic
24 |   deriving (Show, Eq, Ord, Bounded, Enum, Ix)
25 | 
26 | knownOrders :: [Order]
27 | knownOrders = [minBound..maxBound]
28 | 
29 | lm :: Order -> [Point] -> IO Double
30 | lm order points
31 |  = let (xs, ys) = unzip points
32 |    in R.runRegion
33 |         $ do it <- lm' order xs ys
34 |              R.unSomeSEXP it
35 |                $ \it'
36 |                -> case hexp it' of
37 |                     Real v -> headM v
38 |                     Int  v -> fromIntegral <$> headM v
39 |                     _      -> error "R result isn't a number"
40 | 
41 | lm' :: Order -> [Double] -> [Double] -> R s (R.SomeSEXP s)
42 | lm' order x y
43 |   = do [r| x = x_hs |]
44 |        [r| y = y_hs |]
45 |        case order of
46 |          Constant    -> [r|summary(lm(y ~ 1))$adj.r.squared|]
47 |          LogN        -> [r|summary(lm(y ~ I(log(x))))$adj.r.squared|]
48 |          NLogN       -> [r|summary(lm(y ~ I(x * log(x))))$adj.r.squared|]
49 |          Linear      -> [r|summary(lm(y ~ I(x)))$adj.r.squared|]
50 |          Quadratic   -> [r|summary(lm(y ~ I(x^2) + I(x)))$adj.r.squared|]
51 |          Cubic       -> [r|summary(lm(y ~ I(x^3) + I(x^2) + I(x)))$adj.r.squared|]
52 |          Quartic     -> [r|summary(lm(y ~ I(x^4) + I(x^3) + I(x^2) + I(x)))$adj.r.squared|]
53 | 
54 | pretty :: Order -> String
55 | pretty Constant    = "1"
56 | pretty LogN        = "log n"
57 | pretty Linear      = "n"
58 | pretty NLogN       = "n log n"
59 | pretty Quadratic   = "n" <> superscript 2
60 | pretty Cubic       = "n" <> superscript 3
61 | pretty Quartic     = "n" <> superscript 4
62 | 


--------------------------------------------------------------------------------
/src/Test/BigOh/Generate.hs:
--------------------------------------------------------------------------------
 1 | -- * This module defines arbitrary-based benchmark generators.
 2 | --
 3 | module Test.BigOh.Generate
 4 |   ( -- * Benchmark generators
 5 |     Input(..)
 6 |   , genWhnf
 7 |   , genNf
 8 |   , genInputs
 9 |   , genIndependentInputs
10 |   ) where
11 | 
12 | import           Control.Applicative
13 | import           Prelude
14 | import           Control.DeepSeq
15 | import           Criterion.Main
16 | import qualified Data.List              as L
17 | import           Test.QuickCheck
18 | import           Control.Monad
19 | 
20 | data Input a
21 |   = Input
22 |   { input :: a
23 |   , inputSize :: Int
24 |   } deriving (Show)
25 | 
26 | 
27 | -- | Given a function `f :: a -> b`, generate inputs of type `a`,
28 | --   then apply the generated inputs to `f` and evaluate to
29 | --   weak head-normal form.
30 | --
31 | genWhnf
32 |   :: Int                      -- ^ max number of inputs
33 |   -> (Int, Int)               -- ^ range of input size
34 |   -> (Int -> Gen a)           -- ^ given a size, how to generate an input
35 |   -> (a -> b)                 -- ^ function to evaluate
36 |   -> Gen [(Benchmarkable, Input a)] -- ^ the inputs and their benchmarks
37 | genWhnf n range fromSize func
38 |   = do xs <- genInputs n range fromSize
39 |        return $ zipWith ((,) . whnf func . input) xs xs
40 | 
41 | -- | Given a function `f :: a -> b`, generate inputs of type `a`,
42 | --   then apply the generated inputs to `f` and evaluate to
43 | --   head-normal form.
44 | --
45 | genNf
46 |   :: (NFData b)
47 |   => Int                            -- ^ max number of inputs
48 |   -> (Int, Int)                     -- ^ range of input size
49 |   -> (Int -> Gen a)                 -- ^ given a size, how to generate an input
50 |   -> (a -> b)                       -- ^ function to evaluate
51 |   -> Gen [(Benchmarkable, Input a)] -- ^ the inputs and their benchmarks
52 | genNf n range fromSize func
53 |   = do xs <- genInputs n range fromSize
54 |        return $ zipWith ((,) . nf func . input) xs xs
55 | 
56 | genInputs
57 |   ::  Int            -- ^ max number of inputs
58 |   -> (Int, Int)      -- ^ range of input size
59 |   -> (Int -> Gen a)  -- ^ given a size, generate an input
60 |   -> Gen [Input a]
61 | genInputs n (x,y) f
62 |   = let step = max 1 $ (y - x) `div` n
63 |         sizes = takeWhile (< y) $ iterate (+ step) x
64 |     in  zipWithM (\a b -> Input <$> f a <*> pure b) sizes sizes
65 | 
66 | genIndependentInputs :: Int -> (Int, Int) -> (Int -> Gen a) -> Gen [Input a]
67 | genIndependentInputs n range f
68 |   = do xs <- take n . map getPositive <$> infiniteList
69 |        let sorted = L.nub $ L.sort xs
70 |            high   = L.last sorted
71 |            low    = L.head sorted
72 |            sizes  = map (linmap (low, high) range) sorted
73 |        zipWithM (\a b -> Input <$> f a <*> pure b) sizes sizes
74 | 
75 | linmap :: Integral a => (a, a) -> (a, a) -> a -> a
76 | linmap (x1, y1) (x2, y2) v
77 |   = x2 + (v - x1) * (y2 - x2) `div` (y1 - x1)
78 | 


--------------------------------------------------------------------------------
/src/Test/BigOh/Plot.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE FlexibleContexts #-}
  2 | module Test.BigOh.Plot where
  3 | 
  4 | import           Control.Arrow
  5 | import           Control.Monad
  6 | import           Control.Monad.ST
  7 | import qualified Data.Array.MArray        as AM
  8 | import           Data.Array.ST
  9 | import qualified Data.Array.ST            as AS
 10 | import           Data.Array.Unboxed
 11 | import qualified Data.List                as L
 12 | import           Data.Ord
 13 | import           Data.STRef
 14 | import           System.Console.ANSI
 15 | import           System.Console.Ansigraph
 16 | 
 17 | type Range  = (Double, Double)
 18 | 
 19 | data Plot
 20 |   = Plot
 21 |   { plotWidth  :: Int
 22 |   , plotHeight :: Int
 23 |   , plotPoints :: [(Double, Double)] }
 24 |   deriving Show
 25 | 
 26 | graphPoints :: [(Double, Double)] -> IO ()
 27 | graphPoints points
 28 |   | ps <- shiftUp points
 29 |   = mapM_ (posgraph . fmap (fromIntegral :: Int -> Double))
 30 |           (plotToGraphs $ Plot 32 64 ps)
 31 | 
 32 | shiftUp :: [(Double, Double)] -> [(Double, Double)]
 33 | shiftUp ps
 34 |   = let minY = snd $ L.minimumBy (comparing snd) ps
 35 |     in  if minY < 0
 36 |         then fmap (second (+ abs minY)) ps
 37 |         else ps
 38 | 
 39 | plotToGraphs :: Plot -> [[Int]]
 40 | plotToGraphs p@(Plot _ height _)
 41 |   = let ys = plotToYs p
 42 |         slice n = map (\v -> ((v - (n*8)) `max` 0) `min` 8) ys
 43 |      in reverse $ map slice [0..height `div` 8]
 44 | 
 45 | plotToYs :: Plot -> [Int]
 46 | plotToYs = grabYs . plotToArray
 47 | 
 48 | -- | Grab the highest y for each x
 49 | grabYs :: UArray (Int, Int) Char -> [Int]
 50 | grabYs a
 51 |   = let ((x0, y0), (xn, yn)) = bounds a
 52 |         ugh = reverse [y0..yn]
 53 |     in  flip fmap [x0..xn]
 54 |          $ \x -> case dropWhile (\y -> (a ! (x,y)) == ' ') ugh of
 55 |                    []     -> 0
 56 |                    (y':_) -> yn - y'
 57 | 
 58 | plotToArray :: Plot -> UArray (Int, Int) Char
 59 | plotToArray (Plot width height points)
 60 |   = AS.runSTUArray
 61 |   $ do let maxX   = L.maximum $ fmap fst points
 62 |            maxY   = L.maximum $ fmap snd points
 63 |            scaleX = maxX / fromIntegral width
 64 |            scaleY = maxY / fromIntegral height
 65 |            scaled = fmap ((/scaleX) *** (/scaleY)) points
 66 |        a <- AM.newArray ((0,0), (width, height)) ' '
 67 |        let scaled' = fmap go scaled
 68 |        let pairs = zip scaled' (drop 1 scaled')
 69 |        forM_ pairs $ uncurry (bresenham a 'x')
 70 |        return a
 71 |  where
 72 |   go (x,y) = (round x, height - round y)
 73 | 
 74 | printArray :: UArray (Int, Int) Char -> IO ()
 75 | printArray a
 76 |   = do let (minB, maxB) = bounds a
 77 |            row i        = [ a ! (x, i) | x <- [fst minB .. snd maxB] ]
 78 |            thing        = fmap row [snd minB .. snd maxB]
 79 |        mapM_ putStrLn thing
 80 | 
 81 | bresenham
 82 |   :: STUArray s (Int, Int) Char -> Char -> (Int, Int) -> (Int, Int) -> ST s ()
 83 | bresenham vec val (xa, ya) (xb, yb)
 84 |   = do yV     <- var y1
 85 |        errorV <- var $ deltax `div` 2
 86 |        forM_ [x1 .. x2] (\x -> do
 87 |          y <- get yV
 88 |          draw $ if steep then (y, x) else (x, y)
 89 |          mutate errorV $ subtract deltay
 90 |          err <- get errorV
 91 |          when (err < 0) (do
 92 |              mutate yV (+ ystep)
 93 |              mutate errorV (+ deltax)))
 94 |     where steep = abs (yb - ya) > abs (xb - xa)
 95 |           (xa', ya', xb', yb')
 96 |             = if steep
 97 |               then (ya, xa, yb, xb)
 98 |               else (xa, ya, xb, yb)
 99 |           (x1, y1, x2, y2)
100 |             = if xa' > xb'
101 |               then (xb', yb', xa', ya')
102 |               else (xa', ya', xb', yb')
103 |           deltax = x2 - x1
104 |           deltay = abs $ y2 - y1
105 |           ystep  = if y1 < y2 then 1 else -1
106 |           var    = Data.STRef.newSTRef
107 |           get    = Data.STRef.readSTRef
108 |           mutate = Data.STRef.modifySTRef
109 |           draw (x,y) = AM.writeArray vec (x,y) val
110 | 
111 | --------------------------------------------------------------------------------
112 | 
113 | withColor :: Color -> a -> String -> IO a
114 | withColor c r x = do
115 |   setSGR [SetColor Foreground Vivid c]
116 |   putStrLn x
117 |   setSGR [Reset]
118 |   return r
119 | 
120 | passed, failed, inconclusive :: String -> IO Bool
121 | passed       = withColor Green True
122 | failed       = withColor Red False
123 | inconclusive = withColor Yellow False
124 | 
125 | header = withColor Blue ()
126 | 
127 | superscript :: Int -> String
128 | superscript = map go . show
129 |   where
130 |     go '0' = '⁰'
131 |     go '1' = '¹'
132 |     go '2' = '²'
133 |     go '3' = '³'
134 |     go '4' = '⁴'
135 |     go '5' = '⁵'
136 |     go '6' = '⁶'
137 |     go '7' = '⁷'
138 |     go '8' = '⁸'
139 |     go '9' = '⁹'
140 |     go x   = x
141 | 
142 | 


--------------------------------------------------------------------------------
/stack.yaml:
--------------------------------------------------------------------------------
 1 | flags: {}
 2 | extra-package-dbs: []
 3 | packages:
 4 | - '.'
 5 | - ../hakaru-0.1.4
 6 | - location:
 7 |     git: git@github.com:tweag/HaskellR
 8 |     commit: c29067a23c3d0a353a4373c60b7897dbd186a516
 9 |   subdirs:
10 |   - inline-r
11 | extra-deps:
12 | - ansigraph-0.1.0.0
13 | - logfloat-0.13.3.3
14 | - discrimination-0.1
15 | - promises-0.2
16 | resolver: lts-3.11
17 | 


--------------------------------------------------------------------------------