I'm trying to use the criterion library to do some benchmarking.
I've tried a simple example:
module Main where
import Criterion.Types
import Criterion.Main
myConfig :: Config
myConfig = defaultConfig {
resamples = 1
}
main :: IO ()
main = do
let f = (\x -> bench (show x) $ whnf xyz x)
defaultMainWith myConfig [
bgroup "fib" [
env (pure 5) f
]
]
xyz :: Int -> [Double]
xyz 0 = []
xyz x = case x of
100 -> [sin $ fromIntegral x] ++ (xyz (x - 1))
_ -> [sin $ fromIntegral (2 * x)] ++ (xyz (x - 1))
However this seems to take a few seconds to complete, I'd assume it'd complete significantly quicker?
Why is it taking so long? How can I reduce the duration (even at the cost of inaccuracy)?
Set the timeLimit field of Config. For example:
myConfig :: Config
myConfig = defaultConfig {
resamples = 1, timeLimit = 1
}
Related
Duplicating this from github as per #HeinrichApfelmus's suggestion:
This may be just a usage error on my part, but I am noticing a strange phenomenon when trying to set up conditional visibility/layout for dynamically created UI elements (in WX of course). As somewhat of a toy-example, I tried to create a widget that created StaticText elements on the fly and allowed the user to "browse" through these elements through '<' '>' buttons.
The problem I am noting is that all labels are invisible until a new one is created, at which point the current widget in focus becomes visible. Whether this is a bug or just a paradigm I am misusing, or a subtlety with reactive frameworks, I am unsure as to how to resolve this. Here is the code I have at this point, which exhibits the problem:
{-# LANGUAGE RecursiveDo #-}
module Test.Adder where
import Reactive.Banana
import Reactive.Banana.WX
import Graphics.UI.WX.Attributes
import Graphics.UI.WX hiding (Event, newEvent, empty, Identity)
import Graphics.UI.WXCore hiding (Event, Timer, empty, Identity, newEvent)
import Graphics.UI.WXCore.Frame
-- | Combine Unit-Events
anyEvent :: [Event ()] -> Event ()
anyEvent = foldl1 (unionWith (\_ _ -> ()))
-- | Unsugared if-then-else function
if_ :: Bool -> a -> a -> a
if_ True x _ = x
if_ False _ y = y
-- | Apply a function to the value at an index, or return a default value
-- if the index is out of range
(!?) :: (a -> b) -> b -> Int -> ([a] -> b)
(f!? ~y) n xs
| n < 0 = y
| otherwise = case drop n xs of
x:_ -> f x
[] -> y
main :: IO ()
main = start test
create :: Window w -> Int -> Behavior Int -> Event Int -> Event () -> MomentIO (StaticText ())
create t i bi ei eRef = do
let tx = replicate i '\t' ++ show i
x <- liftIO $ staticText t [ text := tx ]
let beq = (==i) <$> bi
let eMe = filterE (==i) ei
sink x [ visible :== beq ]
reactimate (refresh x <$ anyEvent [ eRef, () <$ eMe ])
return x
test :: IO ()
test = do
f <- frame [text := "Test"]
add <- button f [ text := "+" ]
prv <- button f [ text := "<" ]
cur <- staticText f []
nxt <- button f [ text := ">" ]
tab <- panel f [ clientSize := sz 200 300 ]
deb <- staticText f []
ref <- button f [ text := "refresh" ]
let networkDescription :: MomentIO ()
networkDescription = mdo
eAdd <- event0 add command
eRef <- event0 ref command
let bNotFirst = (>0) <$> bCur
bNotLast = (<) <$> bCur <*> bNext
sink prv [ enabled :== bNotFirst ]
sink cur [ text :== show <$> bCur ]
sink nxt [ enabled :== bNotLast ]
ePrev <- event0 prv command
eNext <- event0 nxt command
let eDelta :: Enum n => Event (n -> n)
eDelta = unions [ pred <$ whenE bNotFirst ePrev
, succ <$ whenE bNotLast eNext ]
eChange = flip ($) <$> bCur <#> eDelta
bCur <- stepper 0 $ eChange
(eIndex, bCount) <- mapAccum 0 ((\x -> (x, succ x)) <$ eAdd)
let bView = (\n i -> if_ (n==0) (0) i) <$> bCount <*> bCur
bNext = pred <$> bCount
eCreate = (\n -> create tab n bView eChange $ anyEvent [eRef,eAdd]) <$> eIndex
reCreate <- execute eCreate
bItemer <- accumB id $ flip (.) . (:) <$> reCreate
let bItems = ($[]) <$> bItemer
bThis = (widget!?(nullLayouts!!0)) <$> bCur <*> bItems
sink tab [ layout :== bThis ]
liftIO $ set f [ layout := column 5 [ margin 10 $ row 5 [ widget add
, widget prv
, widget cur
, widget nxt
, widget ref
]
, fill $ widget tab
]
]
network <- compile networkDescription
actuate network
>
Hi I am generating a sparse DAG of 1000 X 1000 nodes each having ~4 edges (direction). Here is the relevant code : Full Code with imports
The problem i am solving has values between [0-1500]. I have hardcoded 1501 as upper value for now. I am trying to calculate longest path of edges in the DAG. However, these details are not direct part of my question :
My question is related to how to judge the usage of force or similar constructs while writing algos in haskell :
type OutGoingEdges = Map.Map NodeId [ NodeId ]
type NodesData = Map.Map NodeId Node
type NodeId = Int
data DAG = AdjList
{ outGoingEdges :: OutGoingEdges
, nodesData :: NodesData
} deriving (Eq, Show)
makeDAG :: DAGDataPath -> IO (DAG, SourceNodes)
makeDAG filepath = do
listOfListOfInts <- makeInteger <$> readLines filepath
let [width, height] = head listOfListOfInts
numNodes = width * height
rows = (replicate width 1501) : (drop 1 listOfListOfInts) ++ [(replicate width 1501)]
heightsWithNodeIdsRows = force . fmap (\ (row, rowId) -> fmap (\ (height, colId) -> (height, rowId * width + colId)) $ zip row [1..]) $ zip rows [1..]
emptyGraph = AdjList Map.empty $ Map.fromList (fmap (\(h, nid) -> (nid, Node h)) . concat . tail . init $ heightsWithNodeIdsRows)
emptyNodesWithEdges = Set.empty
threeRowsInOneGo = zip3 heightsWithNodeIdsRows (drop 1 heightsWithNodeIdsRows) (drop 2 heightsWithNodeIdsRows)
(graph, nodesWithInEdges) = DL.foldl' makeGraph (emptyGraph, emptyNodesWithEdges) threeRowsInOneGo
sourceNodes = Set.difference (Set.fromList . Map.keys . nodesData $ graph) nodesWithInEdges
-- traceShow [take 10 . Map.keys . nodesData $ graph] (return (Set.toList sourceNodes))
-- traceShow graph (return (Set.toList sourceNodes))
-- traceShow sourceNodes (return (Set.toList sourceNodes))
return (graph, force $ Set.toList sourceNodes)
where
makeGraph (graphTillNow, nodesWithInEdges) (prevRow, row, nextRow) =
let updownEdges = zip3 prevRow row nextRow
(graph', nodesInEdges') = addEdges (graphTillNow, nodesWithInEdges) updownEdges
leftRightEdges = zip3 ((1501, 0) : row) (drop 1 row) (drop 2 row)
(graph'', nodesInEdges'') = addEdges (graph', nodesInEdges') leftRightEdges
Next line is interesting... graph'' is DAG and nodesInEdges'' is a Set NodeId
in (graph'', nodesInEdges'')
addEdges (g, n) edges =
DL.foldl' (\ (!g', !n') ((p, pId), (c, cId), (n, nId)) ->
let (g'', n'') = if c > p
then (makeEdge cId pId g', Set.insert pId n')
else (g', n')
(g''', n''') = if c > n
then (makeEdge cId nId g'', Set.insert nId n'')
else (g'', n'')
in (g''', n'''))
(g, n)
edges
While profiling i found that, if i use (force graph'', force nodesInEdges'') instead of (graph'', nodesInEdges''), my memory usage reduces from 3 GB to 600 MB. But running time of program increases from 37 secs to 69 secs. These numbers are from time command and looking at activity monitor. I also checked with profiling and it was similar results.
I am compiling profile builds with :
stack build --executable-profiling --library-profiling --ghc-options="-fprof-auto -auto-all -caf-all -fforce-recomp -rtsopts" --file-watch
I have ghc-7.10.3 and stack 1.1.2.
I think that force goes over the data structure again and again.
Can force be told to not go over the graph if it already fully evaluated ?
Can i use some other strategy ?
Sample Input:
2 2 -- width height
1 2
3 4
Output:
3
Output is length of longest path in the graph. [4 -> 2 -> 1] i.e. [(1,1),(0,1), (0,0)]. Just to remind, correctness of program is not the question;
space/time efficiency is. Thanks
I have the following code. The M prefix designates functions from Data.Map.Strict, and Table is a type alias for Data.Map.Strict.Map Mapping Bool, where Mapping is an arbitrary opaque structure.
computeCoverage :: Table -> Expr -> Maybe Coverage
computeCoverage t e = go t True M.empty
where go src flag targ
| null src = if flag
then Nothing
else Just (M.size t, targ)
| otherwise = let ((m, b), rest) = M.deleteFindMin src
result = interpret e m
flag' = result && flag in
go rest flag' (if b == result then targ else M.insert m b targ)
I would like to be able to use Control.Parallel to perform this with as much parallelism as possible. However, I'm not sure how to do this. Based on reading Data.Map.Strict, it seems what you're supposed to do is call splitRoot, then do whatever parallel stuff you want on the resulting list, then recombine (I guess?). Have I basically got the right idea? If not, what should I do instead to parallelize the code above?
Here's a contrived example. You just use parMap over M.splitRoot m:
import qualified Data.Map.Strict as M
import Control.Parallel.Strategies
import System.Environment
fib 0 = 0
fib 1 = 1
fib n = fib (n-2) + fib (n-1)
theMap :: Int -> M.Map Int Int
theMap n = M.fromList [ (x, 33 + mod x 3) | x <- [1..n] ]
isInteresting n = mod (fib n) 2 == 0
countInteresting :: M.Map Int Int -> Int
countInteresting m = length $ filter isInteresting (M.elems m)
doit :: Int -> [Int]
doit n = parMap rseq countInteresting (M.splitRoot $ theMap n)
main :: IO ()
main = do
( arg1 : _) <- getArgs
let n = read arg1
print $ doit n
Note, however these caveats:
the splits may not be of equal size
use splitRoot if working with a Map is helpful for your computation; this particular example doesn't benefit from the Map structure of root - it could have just parMapped over the elements.
I hope this works by just pasting and running it with "runghc euler4.hs 1000". Since I am having a hard time learning Haskell, can someone perhaps tell me how I could improve here? Especially all those "fromIntegral" are a mess.
module Main where
import System.Environment
main :: IO ()
main = do
args <- getArgs
let
hBound = read (args !! 0)::Int
squarePal = pal hBound
lBound = floor $ fromIntegral squarePal /
(fromIntegral hBound / fromIntegral squarePal)
euler = maximum $ takeWhile (>squarePal) [ x | y <- [lBound..hBound],
z <- [y..hBound],
let x = y * z,
let s = show x,
s == reverse s ]
putStrLn $ show euler
pal :: Int -> Int
pal n
| show pow == reverse (show pow) = n
| otherwise = pal (n-1)
where
pow = n^2
If what you want is integer division, you should use div instead of converting back and forth to Integral in order to use ordinary /.
module Main where
import System.Environment
main :: IO ()
main = do
(arg:_) <- getArgs
let
hBound = read arg :: Int
squarePal = pal hBound
lBound = squarePal * squarePal `div` hBound
euler = maximum $ takeWhile (>squarePal) [ x | y <- [lBound..hBound],
z <- [y..hBound],
let x = y * z,
let s = show x,
s == reverse s ]
print euler
pal :: Int -> Int
pal n
| show pow == reverse (show pow) = n
| otherwise = pal (n - 1)
where
pow = n * n
(I've re-written the lbound expression, that used two /, and fixed some styling issues highlighted by hlint.)
Okay, couple of things:
First, it might be better to pass in a lower bound and an upper bound for this question, it makes it a little bit more expandable.
If you're only going to use the first two (one in your previous case) arguments from the CL, we can handle this with pattern matching easily and avoid yucky statements like (args !! 0):
(arg0:arg1:_) <- getArgs
Let's convert these to Ints:
let [a, b] = map (\x -> read x :: Int) [arg0,arg1]
Now we can reference a and b, our upper and lower bounds.
Next, let's make a function that runs through all of the numbers between an upper and lower bound and gets a list of their products:
products a b = [x*y | x <- [a..b], y <- [x..b]]
We do not have to run over each number twice, so we start x at our current y to get all of the different products.
from here, we'll want to make a method that filters out non-palindromes in some data set:
palindromes xs = filter palindrome xs
where palindrome x = show x == reverse $ show x
finally, in our main function:
print . maximum . palindromes $ products a b
Here's the full code if you would like to review it:
import System.Environment
main = do
(arg0:arg1:_) <- getArgs
let [a, b] = map (\x -> read x :: Int) [arg0,arg1]
print . maximum . palindromes $ products a b
products a b = [x*y | x <- [a..b], y <- [x..b]]
palindromes = filter palindrome
where palindrome x = (show x) == (reverse $ show x)
I would like to implement a certain type of throttling of events in reactive-banana. It should work such that an event is not let through if arrives at less then delta seconds from the last event that passed through. If it is not let through then it is stored and is fired after delta seconds from the last fired event.
Below is a program that implements this for lists of time stamped numbers. Would it be possible to translate this to reactive-banana ?
Also, in reactive-banana how do I fire an event x seconds after some other event comes in ?
module Main where
import Data.List
-- 1 second throtling
-- logic is to never output a value before 1 second has passed since last value was outputed.
main :: IO()
main = print $ test [ (0.0, 1.0), (1.1, 2.0), (1.5,3.0), (1.7,4.0), (2.2, 5.0) ]
--should output [ (0.0, 1.0), (1.1, 2.0), (2.1,4.0), (3.1, 5.0) ]
test :: [(Double,Double)] -> [(Double,Double)]
test list = g v (concat xs)
where
(v, xs) = mapAccumL f (-50,Nothing) list
g (t, Just x) ys = ys ++ [ (t+1,x) ]
g _ ys = ys
f (lasttime, Just holdvalue) (t,x) = if t > (lasttime+1) then
if t > (lasttime + 2) then
( (t, Nothing), [ (lasttime+1,holdvalue), (t,x)] )
else ( (lasttime+1, Just x) , [ (lasttime+1,holdvalue) ] )
else
( (lasttime, Just x), [] )
f (lasttime, Nothing) (t,x) = if t > (lasttime+1) then
( (t,Nothing) , [ (t, x ) ] )
else ( (lasttime, Just x), [] )
As of reactive-banana-0.6, it is definitely possible to implement the functionality you desire, but it is a little involved.
Basically, you have use an external framework like wxHaskell to create a timer, which you can then use to schedule events. The Wave.hs example demonstrates how to do that.
At the moment, I have opted to not include a notion of time in the reactive-banana library itself. The reason is simply that different external framework have timers of different resolution or quality, there is no one-size that fits it all.
I do intend to add common helper functions that deal with time and timers to the library itself, but I still need to find a good way to make it generic over different timers and figure out which guarantees I can provide.
Ok, I managed to implement what I described in my question. I'm not so happy that IO is needed to control the timer via reactimate. I wonder if it would be possible to have a throttle with signature throttle::Event t a -> Int -> Event t a ...
ps: I'm very novice in Haskell so the code could probably a lot more compact or elegant.
{-----------------------------------------------------------------------------
------------------------------------------------------------------------------}
{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. NetworkDescription t"
import Graphics.UI.WX hiding (Event)
import Reactive.Banana
import Reactive.Banana.WX
import Data.Time
{-----------------------------------------------------------------------------
Main
------------------------------------------------------------------------------}
data ThrottledValue a = FireStoredValue a | FireNowAndStartTimer a| HoldIt a | Stopped deriving Show
data ThrottledEvent a = TimerEvent | RealEvent a deriving Show
main = start $ do
f <- frame [text := "Countercesss"]
sl1 <- hslider f False 0 100 []
sl2 <- hslider f False 0 100 []
set f [ layout := column 0 [widget sl1, widget sl2] ]
t <- timer f []
set t [ enabled := False ]
let networkDescription :: forall t. NetworkDescription t ()
networkDescription = do
slEv <- event0 sl1 command
tick <- event0 t command
slB <- behavior sl1 selection
let (throttledEv, reactimates) = throttle (slB <# slEv) tick t 100
reactimates
reactimate $ fmap (\x -> set sl2 [selection := x]) throttledEv
net <- compile networkDescription
actuate net
throttle::Event t a -> Event t () -> Timer -> Int -> (Event t a, NetworkDescription t () )
throttle ev tick timer dt = (throttledEv, reactimates)
where
all = union (fmap (\x-> RealEvent x) ev) (fmap (\x -> TimerEvent) tick)
result = accumE Stopped $ fmap h all
where
h (RealEvent x) Stopped = FireNowAndStartTimer x
h TimerEvent Stopped = Stopped
h (RealEvent x) (FireNowAndStartTimer _) = HoldIt x
h TimerEvent (FireNowAndStartTimer _) = Stopped
h (RealEvent x) (HoldIt _) = HoldIt x
h (TimerEvent) (HoldIt y) = FireStoredValue y
h (RealEvent x) (FireStoredValue _) = HoldIt x
h (TimerEvent) (FireStoredValue _) = Stopped
start (FireStoredValue a) = Just $ resetTimer timer dt
start (FireNowAndStartTimer a) = Just $ resetTimer timer dt
start _ = Nothing
stop Stopped = Just $ stopTimer timer
stop _ = Nothing
reactimates = do
reactimate $ filterJust $ fmap stop result
reactimate $ filterJust $ fmap start result
filterFired (FireStoredValue a) = Just a
filterFired (FireNowAndStartTimer a) = Just a
filterFired _ = Nothing
throttledEv = filterJust $ fmap filterFired result
startTimer t dt = set t [ enabled := True, interval := dt ]
stopTimer t = set t [ enabled := False ]
resetTimer t dt = stopTimer t >> startTimer t dt