I'd like to implement custom messages to be handled by a custom layout.
data ModifySideContainer = IncrementLeftColumnContainer | IncrementRightColumnContainer deriving Typeable
instance Message ModifySideContainer
I'm not too sure how to handle the custom message within pureMessage(https://hackage.haskell.org/package/xmonad-0.13/docs/XMonad-Core.html#v:pureMessage)
This is my current pureMessage implementation (within the custom layout):
pureMessage l#(MiddleColumn sr mcc deltaInc _) m = msum [
fmap resize (fromMessage m),
fmap incmastern (fromMessage m)
]
where
resize Expand = l {splitRatio = (min 0.5 $ sr + deltaInc)}
resize Shrink = l {splitRatio = (max 0 $ sr - deltaInc)}
incmastern (IncMasterN x) = l { middleColumnCount = max 0 (mcc+x) }
I don't quite understand how this logic works (I've copied it from somewhere), what is msum doing here? I guess I'll know once I find the instance declaration of mplus for Maybe.
Figured it out. You just need to add additional 'layouts' within the list.
Essentially all msum does is get the first Just value and return it for example:
msum [Nothing, Nothing, Just 1, Just 2, Nothing] will return Just 1.
pureMessage l#(MiddleColumn sRatio mcc deltaInc _ leftCount rightCount) m = msum [
fmap resize (fromMessage m),
fmap incmastern (fromMessage m),
fmap incSideContainer (fromMessage m)
]
where
incSideContainer IncrementLeftColumnContainer = l
{ leftContainerCount = leftCount + 1, rightContainerCount = rightCount - 1}
incSideContainer IncrementRightColumnContainer = l
{ leftContainerCount = leftCount - 1, rightContainerCount = rightCount + 1}
resize Expand = l {splitRatio = (min 0.5 $ sRatio + deltaInc)}
resize Shrink = l {splitRatio = (max 0 $ sRatio - deltaInc)}
incmastern (IncMasterN x) = l { middleColumnCount = max 0 (mcc+x) }
Related
I'm trying to understand how shrink works in Haskell's QuickCheck, so I've come up with a minimal example shown below, but when I run it, the falsified examples are not shrunk.
The result object shows that no shrinks where tried, and adding a "trace" to the shrink definition doesn't print anything.
So why are the counterexamples not shrunk? Why is 'shrink' never called?
import Debug.Trace
import Test.QuickCheck
simpleString = listOf1 $ choose ('a','d')
newtype SimpleString = SimpleString String deriving (Show)
splits l = [splitAt i l | i <- [0..length l]]
removeOne l = [x ++ drop 1 y | (x,y) <- splits l, y /= []]
instance Arbitrary SimpleString where
arbitrary = fmap SimpleString simpleString
shrink ss | trace ("shrink " ++ show ss) False = undefined
shrink (SimpleString []) | trace " shrink []" True = [SimpleString ""]
shrink (SimpleString ss) | trace (" shrink " ++ show ss) True = [SimpleString ss' | ss' <- removeOne ss ]
numberOf c l = length $ filter (== c) l
prop = forAll arbitrary $ \(SimpleString s) -> length s > 5 ==> numberOf 'a' s /= numberOf 'b' s
Every sample run with quickCheckResult prop yields something like the following:
*** Failed! Falsified (after 4 tests):
SimpleString "aaccbb"
Failure {numTests = 4, numDiscarded = 190, numShrinks = 0, numShrinkTries = 0, numShrinkFinal = 0, usedSeed = SMGen 8220098710381543270 7510598040095200595, usedSize = 6, reason = "Falsified", theException = Nothing, output = "*** Failed! Falsified (after 4 tests):\nSimpleString \"aaccbb\"\n", failingTestCase = ["SimpleString \"aaccbb\""], failingLabels = [], failingClasses = fromList []}
Note that numShrinks = 0, numShrinkTries = 0 always. Why is this?
Thanks
PS: I'm running ghc 8.8.3 with QuickCheck 2.14.2 on macOS.
I want to do something like
array ((0,0), (25, 25)) [((i,j), 1) | i <- [0..25], j <- [i..25]]
which you can see by the array index, is only defined when i <= j. However, when I try to print this out in ghci I get an error because it tries to print things like (1,0) due to the array bounds.
((1,0),*** Exception: (Array.!): undefined array element
I could just have the array be square and put something like 0's in those entries, but I think that would be suboptimal. Is there a way I can set up the bounds of this array to be "triangular"?
A simple upper triangular index can be defined as:
import Data.Ix (Ix, range, index, inRange)
data UpperTriagIndex = Int :. Int
deriving (Show, Ord, Eq)
instance Ix UpperTriagIndex where
range (a :. b, c :. d) = concatMap (\i -> (i :.) <$> [max i b..d]) [a..c]
inRange (a :. b, c :. d) (i :. j) = a <= i && i <= c && b <= j && j <= d
index pr#(a :. b, c :. d) ix#(i :. j)
| inRange pr ix = f a - f i + j - i
| otherwise = error "out of range!"
where f x = let s = d + 1 - max x b in s * (s + 1) `div` 2
One can verify that range and index round trip even if the array is not square. For example:
\> let pr = (0 :. 0, 3 :. 5) in index pr <$> range pr
[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17] -- [0..17]
and:
\> import Data.Array (array, (!))
\> let f i j = (i :. j, "row: " ++ show i ++ ", col: " ++ show j)
\> let a = array ((0 :. 0), (3 :. 3)) [f i j | i <- [0..3], j <- [i..3]]
\> a ! (2 :. 3)
"row: 2, col: 3"
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 am given this type definition:
data Tree = Leaf Char | Branch2 Char Tree Tree | Branch3 Char Tree Tree Tree
How can I write a method that gives me the maximum path length of the tree (count the nodes in the path)?
You would want to write a recursive function to do this. For each Tree constructor, you'll need a different case in your function. To start with, you know that the depth of any Leaf is 1, so
maxDepth :: Tree -> Int
maxDepth (Leaf _) = 1
maxDepth (Branch2 c left right) = maximum [???]
maxDepth (Branch3 c left center right) = maximum [???]
I'll let you finish the rest of the function. You could do it a few different ways as well (such as using max instead of maximum).
with lazy corecursive breadth-first tree traversal:
treedepth tree = fst $ last queue
where
queue = (1,tree) : gen 1 queue
gen 0 p = []
gen len ((d,Leaf _ ) : p) = gen (len - 1) p
gen len ((d,Branch2 _ l r) : p) = (d+1,l) : (d+1,r) : gen (len + 1) p
gen len ((d,Branch3 _ l c r) : p) = (d+1,l) : (d+1,c) : (d+1,r) : gen (len + ??) p
changing it to the depth-first traversal will turn it into a regular recursion.
I'd probably write a tail-recursive solution by using continuation passing.
depth :: Tree -> Int
depth t = go t id
where
go (Leaf _) k = k 0
go (Branch2 _ l r) k = go l $ \dl -> go r $ \dr -> k (1 + max dl dr)
go (Branch3 _ l m r) k = go l $ \dl -> go m $ \dm -> go r $ \dr -> k (1 + max dl (max dm dr))
depth :: Tree -> Int
depth (Leaf _) = 1
depth (Branch2 c left right) = max((depth(left) + 1) (depth(right) + 1))
depth (Branch3 c left center right) = max(max((depth(left) + 1) (depth(right) + 1)) (depth(center) + 1))
Is that right? Sorry i'm not so good in recursive programming.
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